Require Export egalite reactions_transformations reactions_transformations_meta.
Require Import List Nat Omega.
Import ListNotations.

(** Added atomic equality *)

Local Open Scope eqb_scope.

Instance: EqbSpec (nat*nat).
Proof.
  apply eqbspec_couples.
Qed.

Instance: EqbSpec (nat*nat*nat).
Proof.
  apply eqbspec_couples.
Qed.

Instance eqb_atomes{A:Type}`{Eqb A} : Eqb Molecule :=
  fun (m1 m2: @Molecule A) =>
  match m1, m2 with
  | un, un => true
  | atome a1, atome a2 => a1 =? a2
  | _, _ => false
  end.

(** Tactiques *)

Ltac premierGauche n := eapply (premierGauche n); try reflexivity; simpl.

(* Plusieurs premierGauche successifs *)
Ltac premierGaucheListe l :=
  match l with
  | ?n::?l' => premierGauche n; premierGaucheListe l'
  | [] => simpl
  end.

(* Il faudrait peut être le placer ailleurs? Toujours est il qu'il est utilisé dans
 la tactique suivante (supprConjMultGauche)*)
Lemma associativiteConjonctionMultiplicativeGauche :
  forall A : Type, forall M1 M2 M3 : (@Molecule A),
      forall G N,
        EquivalenceMoleculaire (( M1 ⊗ M2 ⊗ M3 ) :: G) N
        -> EquivalenceMoleculaire (( M1 ⊗ (M2 ⊗ M3)) :: G) N.
Proof.
  intros A M1 M2 M3 G N H.
  apply conjonctionMultiplicativeGauche.
  eapply (premierGauche 1).
  unfold valeur; simpl.
  destruct G; simpl; reflexivity.
  simpl.
  apply conjonctionMultiplicativeGauche.
  eapply (premierGauche 2).
  unfold valeur; destruct G; simpl; reflexivity.
  simpl.
  destruct G; simpl;
  apply equivalenceDefinitionEquivalenceMoleculaireP;
  do 2 eapply (inversionConjonctionMultiplicativeGauche _ _ _ []); simpl;
  apply equivalenceDefinitionEquivalenceMoleculaire; assumption.
Qed.

(* Tactique qui supprime toutes les occurence de ⊗ à gauche de l'EquivalenceMoleculaire
    M1 ⊗ ... ⊗ Mn ≡ ...             =>            M1, ... , Mn ≡ ...
*)

Ltac supprConjMultGauche :=
(* La Molecule est d'abord mise sous une forme normale (ie (((A1⊗A2)⊗A3) ... ) en utilisant
   l'associativité *)
repeat (apply associativiteConjonctionMultiplicativeGauche);
repeat (eapply (conjonctionMultiplicativeGauche)).

(** Force the transform of any left multiplicative conjunction into a list
    Complex, thus to use when no other choice. Otherwise, try supprConjMultGauche *)

Ltac FormeNormaleGaucheRec L n next_tactic :=
  match L with
  | [] => idtac "Molecule under normal form"
  | ?M :: ?L' => match M with
                         | ?M1 ⊗ ?M2 => premierGauche n; next_tactic
                         | atome ?a    => FormeNormaleGaucheRec L' (S n) next_tactic
                         | un                  => FormeNormaleGaucheRec L' (S n) next_tactic
                         end
  end.

Ltac FormeNormaleGauche :=
  supprConjMultGauche;
  match goal with
  | |- EquivalenceMoleculaire ?L _ => FormeNormaleGaucheRec L 0 FormeNormaleGauche
  end.

Ltac conjonctionMultiplicativeDroite n :=
match n with
| 0 => repeat (eapply identiteAtome); simpl
| 1 => repeat (eapply identiteAtome); simpl
| S ?n' => try (eapply (conjonctionMultiplicativeDroite n')); conjonctionMultiplicativeDroite n'
end.

Lemma associativiteConjonctionMultiplicativeDroite :
  forall A : Type, forall N, forall M1 M2 M3 : (@Molecule A),
        EquivalenceMoleculaire N (M1 ⊗ M2 ⊗ M3)
        -> EquivalenceMoleculaire N (M1 ⊗ (M2 ⊗ M3)).
Proof.
  intros. apply (coupureMolecule (length N) (M1 ⊗ M2 ⊗ M3)).
  rewrite prefixeEnFin; trivial.
  rewrite suffixeEnFin.
  apply symmetrieMoleculaire.
  apply associativiteConjonctionMultiplicativeGauche.
  apply reflexiviteMoleculaire.
Qed.

Lemma associativiteConjonctionMultiplicativeDroite2 :
  forall A : Type, forall N, forall M1 M2 M3 M4 : (@Molecule A),
        EquivalenceMoleculaire N (M1 ⊗ M2 ⊗ M3 ⊗ M4)
        -> EquivalenceMoleculaire N (M1 ⊗ (M2 ⊗ M3) ⊗ M4).
Proof.
  intros. apply (coupureMolecule (length N) (M1 ⊗ M2 ⊗ M3 ⊗ M4)).
  rewrite prefixeEnFin; trivial.
  rewrite suffixeEnFin.
  apply symmetrieMoleculaire.
  supprConjMultGauche.
  premierGauche 1.
  apply conjonctionMultiplicativeGauche.
  premierGaucheListe [3; 2; 2;3].
  conjonctionMultiplicativeDroite 4; apply reflexiviteMoleculaire.
Qed.

Ltac formeNormaleDroite := repeat (apply associativiteConjonctionMultiplicativeDroite).

Ltac supprNeutre :=
  apply (neutreTransformation 0); simpl; trivial.

Ltac resoudreMoleculeInconnue :=
  repeat (eapply (conjonctionMultiplicativeDroite 1); try eapply identiteAtome).

Ltac resoudreAbsences := intros; repeat (split; try discriminate).

Ltac reordonnerAutomatiquementRec M :=
  match goal with
  | |- EquivalenceMoleculaire ?l _ =>
                     match M with
                     | ?M'⊗?At =>
                         match eval compute in (indexOf At l) with
                         | Some ?n => premierGauche n; reordonnerAutomatiquementRec M'
                         end
                     | ?At =>
                         match eval compute in (indexOf At l) with
                         | Some ?n => premierGauche n
                         | None       => simpl
                         end
                     end
  end.

Ltac reordonnerAutomatiquement :=
  match goal with
  | |- EquivalenceMoleculaire ?l ?M =>
                reordonnerAutomatiquementRec M;
                conjonctionMultiplicativeDroite eval compute in (length l)
  end;
  try apply (conjonctionMultiplicativeDroite 0); simpl;
  try apply unDroite;
  try eapply identiteAtome.

Ltac reordonnerAutomatiquementExistentielle :=
  match goal with
  | |- EquivalenceMoleculaire _ (?M⊗_) =>
                match eval compute in (tailleMolecule M) with
                | ?m => reordonnerAutomatiquementRec M;
                              apply (conjonctionMultiplicativeDroite m);
                              try (conjonctionMultiplicativeDroite m; reflexivity)
                end
  end.

Ltac dupliquerExponentielle n :=
  eapply (conjonctionAdditiviteDroiteTransformation n); [ reflexivity | simpl];
  eapply (conjonctionMultiplicativeTransformation n); [ reflexivity | simpl];
   eapply (premiereRegle n); [ reflexivity | simpl].

Ltac PlusDeGC := left; red; intros; simpl; repeat(split; try discriminate); reflexivity.

Ltac PlusDeCListe :=
  left; red ; simpl; intuition;
  try(match goal with
        | H : _ |- _ => try discriminate H; injection H; intro; subst; reflexivity
        end
        ); reflexivity.

Ltac ChoisirNeutrePartoutRec n :=
   eapply (conjonctionAdditiviteGaucheTransformation 0); [reflexivity | simpl];
   eapply (instanciationMolecule 0 ); [reflexivity | simpl];
   eapply (reactionTransformation 0); simpl;
   [reflexivity
   | apply identiteTransformation;
              [reflexivity | supprConjMultGauche; resoudreMoleculeInconnue ]
   | try PlusDeGC; try PlusDeCListe; try right
   | supprNeutre;
     match goal with
     | |- Transformation ?l _ _ => match l with
                                   | [] => apply identiteTransformation; [reflexivity |
                                           supprConjMultGauche; repeat apply inversionC;
                                           apply symmetrieMoleculaire; cbv delta;
                                           FormeNormaleGauche;
                                           idtac "There is/are" n "guard constraint(s) to solve.";
                                           reordonnerAutomatiquement]
                                   | ?x :: ?l' => ChoisirNeutrePartoutRec (S n)
                                   end
     end
    ].

Ltac ChoisirNeutrePartout := ChoisirNeutrePartoutRec 0.

(* Essayer avec auto de tout résoudre seul *)
Hint Extern 4 (forall _, Absence _ _) => try resoudreAbsences.
Hint Extern 4 (_ /\ _) => try resoudreAbsences.
Hint Extern 4 (_ /\ _ /\ _) => try resoudreAbsences; simpl; intuition; omega.
Hint Extern 4 (_ = _) => try resoudreAbsences.
Hint Extern 4 (EquivalenceMoleculaire _ _) => try resoudreMoleculeInconnue.
Hint Extern 4 (EquivalenceMoleculaire _ _) => try reordonnerAutomatiquementExistentielle.
Hint Extern 4 (Transformation (neutreRegle :: _) _ _) => try supprNeutre.
Hint Extern 4 (Transformation [] _ _) => try (eapply identiteTransformation; trivial;
                                                                                supprConjMultGauche; cbv delta;
                                                                                reordonnerAutomatiquement).

Ltac simplBlocage :=
  tryif (apply blocageConjonctionAdditive; intros)
  then simplBlocage
  else tryif (apply blocageConjonctionMultiplicative; intros)
          then simplBlocage
          else tryif (apply blocageQuantificationMolecule; intros)
                  then simplBlocage
                  else tryif (apply blocageQuantificationValeur; intros)
                          then simplBlocage
                          else tryif (apply blocageReaction; intros)
                                  then simplBlocage
                                  else tryif (apply blocageReactionAvecContinuation; intros)
                                          then simplBlocage
                                          else unfold not; intros.


(* --------------------------------------------------------------------
 * Copyright (c) - 2017--2021 - Xavier Allamigeon <xavier.allamigeon at inria.fr>
 * Copyright (c) - 2017--2021 - Ricardo D. Katz <katz@cifasis-conicet.gov.ar>
 * Copyright (c) - 2019--2021 - Pierre-Yves Strub <pierre-yves@strub.nu>
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra finmap.
Require Import extra_misc inner_product vector_order.

Import Order.Theory.

Set   Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Unset SsrOldRewriteGoalsOrder.

Import GRing.Theory Num.Theory.

Local Open Scope ring_scope.

(* -------------------------------------------------------------------- *)
Reserved Notation "{ 'fsfun' T ~> R }"
  (at level 0, format "{ 'fsfun'  T  ~>  R }").

Reserved Notation "{ 'conic' T ~> R }"
  (at level 0, format "{ 'conic'  T  ~>  R }").

Reserved Notation "{ 'convex' T ~> R }"
  (at level 0, format "{ 'convex'  T  ~>  R }").

Reserved Notation "\0 %:FS"
  (at level 2, format "\0 %:FS").

Reserved Notation "\0 %:PFS"
  (at level 1, format "\0 %:PFS").

Reserved Notation "x \bary V"
  (at level 70, format "x  \bary  V").

(* -------------------------------------------------------------------- *)
Declare Scope conicfun_scope.
Declare Scope convexfun_scope.

(* -------------------------------------------------------------------- *)
Notation "{ 'fsfun' T ~> R }" :=
  {fsfun T -> R for (fun=> 0)} : type_scope.

(* -------------------------------------------------------------------- *)
Section FsFunZmod.
Context {T : choiceType} {R : zmodType}.

Implicit Types f g h : {fsfun T ~> R}.

Definition fs0 : {fsfun T ~> R} := [fsfun].

Definition fsopp f : {fsfun T ~> R} :=
  [fsfun x in finsupp f => -f x].

Definition fsadd f g : {fsfun T ~> R} :=
  [fsfun x in (finsupp f `|` finsupp g)%fset => f x + g x].

Notation "\0 %:FS" := fs0 : fsfun_scope.
Notation "- f"     := (fsopp f)  : fsfun_scope.
Notation "f + g"   := (fsadd f g) : fsfun_scope.

Lemma fs0E x : (\0%:FS x)%fsfun = 0.
Proof. by rewrite fsfunE. Qed.

Lemma fsoppE f x : (- f)%fsfun x = -(f x).
Proof. by rewrite fsfunE; case: finsuppP => // _; rewrite oppr0. Qed.

Lemma fsaddE f g x : (f + g)%fsfun x = (f x + g x).
Proof.
by rewrite fsfunE in_fsetU; (do 2! case: finsuppP => ? //=); rewrite addr0.
Qed.

Let fsfunwE := (fs0E, fsoppE, fsaddE).

Lemma fsfun_zmod :
  [/\ associative fsadd
    , commutative fsadd
    , left_id fs0 fsadd
    & left_inverse fs0 fsopp fsadd].
Proof. split.
+ by move=> f g h; apply/fsfunP=> x /=; rewrite !fsfunwE addrA.
+ by move=> f g; apply/fsfunP=> x /=; rewrite !fsfunwE addrC.
+ by move=> f; apply/fsfunP=> x /=; rewrite !fsfunwE add0r.
+ by move=> f; apply/fsfunP=> x /=; rewrite !fsfunwE addNr.
Qed.

Let addfA := let: And4 h _ _ _ := fsfun_zmod in h.
Let addfC := let: And4 _ h _ _ := fsfun_zmod in h.
Let add0f := let: And4 _ _ h _ := fsfun_zmod in h.
Let addNf := let: And4 _ _ _ h := fsfun_zmod in h.

Definition fsfun_zmodMixin := ZmodMixin addfA addfC add0f addNf.
Canonical fsfun_zmodType := Eval hnf in ZmodType {fsfun T ~> R} fsfun_zmodMixin.

Lemma supp_fs0 : finsupp 0%R = fset0.
Proof. by rewrite finsupp0. Qed.

Lemma supp_fsN f : finsupp (-f)%fsfun = finsupp f.
Proof.
by apply/fsetP=> x; rewrite !mem_finsupp fsfunwE oppr_eq0.
Qed.

Lemma supp_fsD f g :
  (finsupp (f + g)%R `<=` finsupp f `|` finsupp g)%fset.
Proof.
apply/fsubsetP=> x; rewrite in_fsetU !mem_finsupp !fsfunwE.
case: (f x =P 0) => //= ->; case: (g x =P 0) => //= ->.
by rewrite addr0 eqxx.
Qed.
Lemma mem_fsN x f : (x \in finsupp (-f)%R) -> x \in finsupp f.
Proof. by rewrite supp_fsN. Qed.

Lemma mem_fsD x f g :
  x \in finsupp (f + g)%R -> x \in finsupp f \/ x \in finsupp g.
Proof.
by move/(fsubsetP (supp_fsD _ _)); rewrite in_fsetU (rwP orP).
Qed.
End FsFunZmod.

(* -------------------------------------------------------------------- *)
Section FsFunLmod.
Context {T : choiceType} {R : ringType}.

Implicit Types (c : R) (f g h : {fsfun T ~> R}).

Definition fsscale c f : {fsfun T ~> R} :=
  [fsfun x in finsupp f => c * f x].

Notation "c *: f" := (fsscale c f) : fsfun_scope.

Lemma fsscaleE c f x : (c *: f)%fsfun x = c * f x.
Proof.
by rewrite fsfunE; case: finsuppP => // _; rewrite mulr0.
Qed.

Let fsfunwE := (@fs0E, @fsoppE, @fsaddE, fsscaleE).

Lemma fsfun_lmod :
  [/\ forall c1 c2 f, fsscale c1 (fsscale c2 f) = fsscale (c1 * c2) f
    , left_id 1 fsscale
    , right_distributive fsscale +%R
    & forall f, {morph fsscale^~ f : c1 c2 / c1 + c2}].
Proof. split.
+ by move=> c1 c2 f; apply/fsfunP=> x /=; rewrite !fsfunwE mulrA.
+ by move=> f; apply/fsfunP=> x /=; rewrite !fsfunwE mul1r.
+ by move=> c f g; apply/fsfunP=> x /=; rewrite !fsfunwE mulrDr.
+ by move=> f c1 c2; apply/fsfunP=> x /=; rewrite !fsfunwE mulrDl.
Qed.

Let scale_fsfunA  := let: And4 h _ _ _ := fsfun_lmod in h.
Let scale_fsfun1  := let: And4 _ h _ _ := fsfun_lmod in h.
Let scale_fsfunDr := let: And4 _ _ h _ := fsfun_lmod in h.
Let scale_fsfunDl := let: And4 _ _ _ h := fsfun_lmod in h.

Definition fsfun_lmodMixin :=
  LmodMixin scale_fsfunA scale_fsfun1 scale_fsfunDr scale_fsfunDl.
Canonical fsfun_lmodType :=
  Eval hnf in LmodType R {fsfun T ~> R} fsfun_lmodMixin.
End FsFunLmod.

(* -------------------------------------------------------------------- *)
Section FsFunLmodId.
Context {T : choiceType} {R : idomainType}.

Implicit Types (c : R) (f g h : {fsfun T ~> R}).

Lemma supp_fsZ c f : c != 0 -> finsupp (c *: f)%fsfun = finsupp f.
Proof.
move=> nz_c; apply/fsetP => x; rewrite !mem_finsupp fsscaleE.
by rewrite mulf_eq0 (negbTE nz_c).
Qed.

Lemma mem_fsZ x c f : c != 0 -> x \in finsupp (c *: f)%R -> x \in finsupp f.
Proof. by move/supp_fsZ=> ->. Qed.
End FsFunLmodId.

(* -------------------------------------------------------------------- *)
Definition fsfunwE := (@fs0E, @fsaddE, @fsoppE, @fsscaleE).

(* -------------------------------------------------------------------- *)
Section Combine.
Context {R : ringType} {L : lmodType R}.

Implicit Types (f g h : {fsfun L ~> R}).

Definition combine f : L := \sum_(x : finsupp f) f (fsval x) *: fsval x.

Lemma combinewE E f : (finsupp f `<=` E)%fset ->
  combine f = \sum_(x : E) f (fsval x) *: (fsval x).
Proof.
move=> leEw; pose F x := f x *: x; rewrite /combine.
rewrite -!(big_seq_fsetE _ _ predT F) /= {}/F.
have /permEl h := perm_filterC (mem (finsupp f)) E.
rewrite -{h}(perm_big _ h) big_cat /= 2![X in _+X](big_seq, big1) 1?addr0.
+ move=> x; rewrite mem_filter inE memNfinsupp.
  by case/andP=> [/eqP->]; rewrite scale0r.
apply/perm_big/uniq_perm; rewrite ?(fset_uniq, filter_uniq) //.
by move=> x; rewrite mem_filter inE andb_idr // => /(fsubsetP leEw).
Qed.

Lemma combineE f : combine f = \sum_(x : finsupp f) f (fsval x) *: (fsval x).
Proof. by []. Qed.
End Combine.

(* -------------------------------------------------------------------- *)
Section Weight.
Context {T : choiceType} {R : zmodType}.

Implicit Types (f g h : {fsfun T ~> R}).

Definition weight f := \sum_(x : finsupp f) f (fsval x).

Lemma weightwE E w : (finsupp w `<=` E)%fset ->
  weight w = \sum_(x : E) w (fsval x).
Proof.
move=> leEw; rewrite /weight -!(big_seq_fsetE _ _ predT) /=.
have /permEl h := perm_filterC (mem (finsupp w)) E.
rewrite -{h}(perm_big _ h) big_cat /= 2![X in _+X](big_seq, big1).
+ by move=> x; rewrite mem_filter inE memNfinsupp => /andP[/eqP->].
rewrite addr0; apply/perm_big/uniq_perm; rewrite ?filter_uniq //.
by move=> x; rewrite mem_filter inE andb_idr // => /(fsubsetP leEw).
Qed.

Lemma weightE f : weight f = \sum_(x : finsupp f) f (fsval x).
Proof. by []. Qed.

Lemma weight0 : weight 0 = 0.
Proof. by apply: big1 => -[/= x _ _]; rewrite fsfunwE. Qed.

Lemma weightD f g : weight (f + g) = weight f + weight g.
Proof.
pose E := (finsupp f `|` finsupp g)%fset.
rewrite !(@weightwE E) 1?(fsubsetUl, fsubsetUr, supp_fsD) // {}/E.
by rewrite -big_split /=; apply: eq_bigr=> -[/= x _ _]; rewrite fsaddE.
Qed.
End Weight.

(* -------------------------------------------------------------------- *)
Section Comb.
Context {T : choiceType} {R : numDomainType}.

Implicit Types (w : {fsfun T ~> R}).

Definition conic  w := [forall x : finsupp w, 0 <= w (fsval x)].
Definition convex w := conic w && (weight w == 1).

Lemma conicP w :
  reflect (forall x, x \in finsupp w -> 0 <= w x) (conic w).
Proof. apply: (iffP forallP) => /= [h x|h].
+ by move=> xw; apply: (h (Sub x xw)).
+ by case=> [/= x xw]; apply: h.
Qed.

Lemma convexP w :
  reflect
    [/\ forall x, x \in finsupp w -> 0 <= w x & weight w = 1]
    (convex w).
Proof. by apply: (iffP andP); case=> /conicP h /eqP ->; split. Qed.

Lemma convex_conic w : convex w -> conic w.
Proof. by case/andP. Qed.

Lemma conicwP w : reflect (forall x, 0 <= w x) (conic w).
Proof. apply: (iffP idP).
+ by move/conicP=> h x; case: (finsuppP w x) => // /h.
+ by move=> h; apply/conicP=> x _; apply: h.
Qed.

Lemma conic0 : conic 0.
Proof. by apply/conicP=> x; rewrite fsfunwE. Qed.

Lemma conicD w1 w2 : conic w1 -> conic w2 -> conic (w1 + w2).
Proof.
move=> /conicwP h1 /conicwP h2; apply/conicwP=> x.
by rewrite fsfunwE addr_ge0.
Qed.

Lemma conic_finsuppE x w : conic w -> (x \in finsupp w) = (0 < w x).
Proof.
by move=> /conicwP h; rewrite lt_neqAle h andbT eq_sym; apply: mem_finsupp.
Qed.

Lemma conic_weight_ge0 w : conic w -> 0 <= weight w.
Proof. by move/conicwP=> ge0_w; rewrite weightE; apply: sumr_ge0. Qed.
End Comb.

(* -------------------------------------------------------------------- *)
Section SubConic.
Context {T : choiceType} {R : numDomainType}.

Record conicFun := mkConicFun
  { conic_val :> {fsfun T ~> R}; _ : conic conic_val }.

Canonical conicfun_subType := Eval hnf in [subType for conic_val].
Definition conicfun_eqMixin := [eqMixin of conicFun by <:].
Canonical conicfun_eqType := Eval hnf in EqType conicFun conicfun_eqMixin.
Definition conicfun_choiceMixin := [choiceMixin of conicFun by <:].
Canonical conicfun_choiceType :=
  Eval hnf in ChoiceType conicFun conicfun_choiceMixin.

Definition conicfun_of (_ : phant T) (_ : phant R) := conicFun.
Identity Coercion type_of_conicfun : conicfun_of >-> conicFun.
End SubConic.

Notation "{ 'conic' T ~> R }" :=
  (conicfun_of (Phant T) (Phant R)) : type_scope.

Bind Scope conicfun_scope with conicFun.
Bind Scope conicfun_scope with conicfun_of.

Delimit Scope conicfun_scope with cof.

(* -------------------------------------------------------------------- *)
Section SubConicTheory.
Context {T : choiceType} {R : realDomainType}.

Canonical conicfun_of_subType    := Eval hnf in [subType    of {conic T ~> R}].
Canonical conicfun_of_eqType     := Eval hnf in [eqType     of {conic T ~> R}].
Canonical conicfun_of_choiceType := Eval hnf in [choiceType of {conic T ~> R}].

Implicit Types (w : {conic T ~> R}).

Lemma fconicP w1 w2 : w1 =1 w2 <-> w1 = w2.
Proof. by rewrite fsfunP (rwP val_eqP) (rwP eqP). Qed.

Lemma gt0_fconic w x : x \in finsupp w -> 0 < w x.
Proof. by rewrite conic_finsuppE // (valP w). Qed.

Lemma ge0_fconic w x : 0 <= w x.
Proof. by move/conicwP: (valP w); apply. Qed.

(* We have to lock the definitions *)
Definition conicf0 : {conic T ~> R} :=
  nosimpl (mkConicFun conic0).

Definition conicfD : _ -> _ -> {conic T ~> R} :=
  nosimpl (fun w1 w2 => mkConicFun (conicD (valP w1) (valP w2))).

Notation "\0 %:PFS" := conicf0 : conicfun_scope.
Notation "f + g" := (conicfD f g) : conicfun_scope.

Lemma fconic0E x : (\0%:PFS)%cof x = 0.
Proof. by rewrite fsfunwE. Qed.

Lemma fconicDE w1 w2 x : (w1 + w2)%cof x = w1 x + w2 x.
Proof. by rewrite fsfunwE. Qed.

Definition fconicwE := (fconic0E, fconicDE).

Lemma conic_comoid_r :
  [/\ associative conicfD
    , left_id conicf0 conicfD
    , right_id conicf0 conicfD
    & commutative conicfD].
Proof. split.
+ by move=> w1 w2 w3; apply/fconicP => x; rewrite !fconicwE addrA.
+ by move=> w; apply/fconicP => x; rewrite !fconicwE add0r.
+ by move=> w; apply/fconicP => x; rewrite !fconicwE addr0.
+ by move=> w1 w2; apply/fconicP => x; rewrite !fconicwE addrC.
Qed.

Let addpA := let: And4 h _ _ _ := conic_comoid_r in h.
Let add0p := let: And4 _ h _ _ := conic_comoid_r in h.
Let addp0 := let: And4 _ _ h _ := conic_comoid_r in h.
Let addpC := let: And4 _ _ _ h := conic_comoid_r in h.

Canonical conic_monoid := Monoid.Law addpA add0p addp0.
Canonical conic_comoid := Monoid.ComLaw addpC.

Lemma mem_coffinsupp w x : (x \in finsupp w) = (0 < w x).
Proof. by rewrite mem_finsupp lt_neqAle eq_sym ge0_fconic andbT. Qed.

Lemma coffinsupp0 : finsupp (\0%:PFS)%cof = fset0.
Proof. by rewrite supp_fs0. Qed.

Lemma coffinsuppD w1 w2 :
  finsupp (w1 + w2)%cof = (finsupp w1 `|` finsupp w2)%fset.
Proof.
apply/fsetP=> x; rewrite in_fsetE !mem_coffinsupp fconicwE.
have := ge0_fconic w1 x; rewrite le_eqVlt => /orP[].
+ by move/eqP=> <-; rewrite ltxx add0r.
+ by move=> gt0_w1; rewrite gt0_w1 ltr_paddr // ge0_fconic.
Qed.

Lemma ge0_cofweight w : 0 <= weight w.
Proof. by apply/conic_weight_ge0/valP. Qed.
End SubConicTheory.

Notation "\0 %:PFS" := conicf0 : conicfun_scope.
Notation "f + g" := (conicfD f g) : conicfun_scope.

(* -------------------------------------------------------------------- *)
Section ConicUniform.
Context {T : choiceType} {R : numDomainType}.

Implicit Type S : {fset T}.

Lemma fconicu_r S : @conic T R [fsfun _ in S => 1].
Proof.
apply/conicP=> x /(fsubsetP (finsupp_sub _ _ _)) x_in.
by rewrite fsfunE ifT.
Qed.

Definition fconicu : {fset T} -> {conic T ~> R} :=
  nosimpl (fun S => mkConicFun (fconicu_r S)).

Lemma fconicuE S x : fconicu S x = (x \in S)%:R.
Proof. by rewrite fsfunE; case: ifP. Qed.

Lemma finsupp_fconicu S : finsupp (fconicu S) = S.
Proof.
apply/fsetP => y; rewrite mem_finsupp fconicuE.
by rewrite pnatr_eq0 eqb0 negbK.
Qed.
End ConicUniform.

(* -------------------------------------------------------------------- *)
Section SubConvex.
Context {T : choiceType} {R : numDomainType}.

Record convexFun := mkConvexfun
  { convex_val :> {fsfun T ~> R}; _ : convex convex_val }.

Canonical convexfun_subType := Eval hnf in [subType for convex_val].
Definition convexfun_eqMixin := [eqMixin of convexFun by <:].
Canonical convexfun_eqType := Eval hnf in EqType convexFun convexfun_eqMixin.
Definition convexfun_choiceMixin := [choiceMixin of convexFun by <:].
Canonical convexfun_choiceType :=
  Eval hnf in ChoiceType convexFun convexfun_choiceMixin.

Definition convexfun_of (_ : phant T) (_ : phant R) := convexFun.
Identity Coercion type_of_convexfun : convexfun_of >-> convexFun.
End SubConvex.

Notation "{ 'convex' T ~> R }" :=
  (convexfun_of (Phant T) (Phant R)) : type_scope.

Bind Scope convexfun_scope with convexFun.
Bind Scope convexfun_scope with convexfun_of.

Delimit Scope convexfun_scope with cvf.

(* -------------------------------------------------------------------- *)
Section SubConvexTheory.
Context {T : choiceType} {R : realDomainType}.

Canonical convexfun_of_subType    := Eval hnf in [subType    of {convex T ~> R}].
Canonical convexfun_of_eqType     := Eval hnf in [eqType     of {convex T ~> R}].
Canonical convexfun_of_choiceType := Eval hnf in [choiceType of {convex T ~> R}].

Implicit Types (w : {convex T ~> R}).

Lemma fconvexP w1 w2 : w1 =1 w2 <-> w1 = w2.
Proof. by rewrite fsfunP (rwP val_eqP) (rwP eqP). Qed.

Lemma conic_fconvex w : conic w.
Proof. by apply/convex_conic/valP. Qed.

Lemma convex_fconvex w : convex w.
Proof. by apply/valP. Qed.

Lemma gt0_fconvex w x : x \in finsupp w -> 0 < w x.
Proof. by rewrite conic_finsuppE //; apply/conic_fconvex. Qed.

Lemma ge0_fconvex w x : 0 <= w x.
Proof. by move/conicwP: (conic_fconvex w); apply. Qed.

Lemma ge0_cvweight w : 0 <= weight w.
Proof. by apply/conic_weight_ge0/conic_fconvex. Qed.

Lemma wgt1_fconvex w : weight w = 1.
Proof. by case/convexP: (valP w). Qed.

Lemma le1_fconvex w x : w x <= 1.
Proof.
case: finsuppP => // xw; rewrite -(wgt1_fconvex w) weightE.
rewrite -(big_seq_fsetE _ _ predT) /= -(fsetD1K xw).
rewrite big_fsetU1 ?fsetD11 //= ler_addl.
by apply: sumr_ge0=> i _; apply: ge0_fconvex.
Qed.

Lemma fconvex_insupp_neq0 w : (finsupp w == fset0) = false.
Proof.
apply/negP=> /eqP zw; have := wgt1_fconvex w.
by rewrite weightE zw big_fset0 (rwP eqP) eq_sym oner_eq0.
Qed.
End SubConvexTheory.

(* -------------------------------------------------------------------- *)
Section CvxDirac.
Context {T : choiceType} {R : realDomainType}.

Lemma fcvx1_r x : @convex T R [fsfun _ in [fset x]%fset => 1].
Proof. apply/convexP; split=> /=.
+ by move=> y _; rewrite fsfunE; case: ifP.
+ rewrite (weightwE (E := [fset x]%fset)); last first.
    by rewrite big_fset1 /= fsfunE fset11.
  apply/fsubsetP=> y; rewrite mem_finsupp fsfunE in_fset1.
  by case: ifP => //; rewrite eqxx.
Qed.

Definition fcvx1 : T -> {convex T ~> R} :=
  nosimpl (fun x => mkConvexfun (fcvx1_r x)).

Lemma fcvx1E x y : fcvx1 x y = (y == x)%:R.
Proof. by rewrite fsfunE in_fset1; case: ifP. Qed.

Lemma finsupp_fcvx1 x : finsupp (fcvx1 x) = [fset x]%fset.
Proof.
apply/fsetP=> y; rewrite in_fset1 mem_finsupp fcvx1E.
by rewrite pnatr_eq0 eqb0 negbK.
Qed.

Lemma mem_fcvx1 x y : (y \in finsupp (fcvx1 x)) = (y == x).
Proof. by rewrite finsupp_fcvx1 in_fset1. Qed.

Lemma fcvx1E_finsupp (w : {convex T ~> R}) x y :
  (finsupp w `<=` [fset x])%fset -> w y = (y == x)%:R.
Proof.
rewrite fsubset1 fconvex_insupp_neq0 orbF => /eqP fw.
case: finsuppP; rewrite fw in_fset1; first by move=> /negbTE->.
move=> /eqP ->; move: (wgt1_fconvex w); rewrite weightE eqxx /=.
by rewrite fw big_fset1 /=.
Qed.
End CvxDirac.

(*-------------------------------------------------------------------- *)
Section CvxDiracCombine.
Context {R : realDomainType} {L : lmodType R}.

Lemma combine_fcvx1 (x : L) : combine (fcvx1 x) = x.
Proof.
by rewrite combineE finsupp_fcvx1 big_fset1 fcvx1E eqxx scale1r.
Qed.
End CvxDiracCombine.

(* -------------------------------------------------------------------- *)
Section CvxSegment.
Context {R : realDomainType} {L : lmodType R}.

Definition clamp a : R :=
  if 0 <= a <= 1 then a else 0.

Lemma clamp_id a : 0 <= a <= 1 -> clamp a = a.
Proof. by rewrite /clamp => ->. Qed.

Lemma rg01_clamp a : 0 <= clamp a <= 1.
Proof.
by rewrite /clamp; case: ifP => // _; rewrite lexx ler01.
Qed.

Lemma ge0_clamp a : 0 <= clamp a.
Proof. by case/andP: (rg01_clamp a). Qed.

Lemma le1_clamp a : clamp a <= 1.
Proof. by case/andP: (rg01_clamp a). Qed.

Lemma ge0_1Bclamp a : 0 <= 1 - clamp a.
Proof. by rewrite subr_ge0 le1_clamp. Qed.

Lemma le1_1Bclamp a : 1 - clamp a <= 1.
Proof. by rewrite ler_subl_addr ler_addl ge0_clamp. Qed.

Lemma fseg_r a x y :
  @convex L R [fsfun z in [fset x; y]%fset =>
     (z == x)%:R * (1 - clamp a) + (z == y)%:R * clamp a].
Proof. apply/convexP; split=> /=.
+ move=> z _; rewrite fsfunE; case: ifP => // _.
  by rewrite addr_ge0 // mulr_ge0 // (ler0n, ge0_clamp, ge0_1Bclamp).
+ rewrite (@weightwE _ _ [fset x; y]%fset) ?finsupp_sub //.
  case: (x =P y) => [->|/eqP ne_xy]; first rewrite fsetUid big_fset1.
  - by rewrite fsfunE /= fset11 eqxx !mul1r addrNK.
  rewrite -(big_seq_fsetE _ _ predT) /= big_fsetU1 ?in_fset1 //=.
  rewrite big_seq_fset1 !fsfunE !(fset21, fset22) [y == x]eq_sym.
  by rewrite !(eqxx, negbTE ne_xy) !Monoid.simpm /= addrNK.
Qed.

Definition fseg : _ -> _ -> _ -> {convex L ~> R} :=
  nosimpl (fun a x y => mkConvexfun (fseg_r a x y)).

Lemma fsegE a x y z :
  fseg a x y z = (z == x)%:R * (1 - clamp a) + (z == y)%:R * clamp a.
Proof.
rewrite fsfunE in_fset2; do! case: (z =P _) => //= _.
by rewrite !mul0r addr0.
Qed.

Lemma finsupp_fseg a x y : (finsupp (fseg a x y) `<=` [fset x; y])%fset.
Proof. by apply: finsupp_sub. Qed.

Lemma combine_fseg a x y :
  combine (fseg a x y) = (1 - clamp a) *: x + clamp a *: y.
Proof.
rewrite (combinewE (finsupp_fseg a x y)); case: (x =P y) => [<-|].
+ by rewrite fsetUid big_fset1 fsegE /= eqxx !mul1r -scalerDl.
move/eqP => ne_xy; pose F z := fseg a x y z *: z.
rewrite -(big_seq_fsetE _ _ predT F) {}/F /=.
rewrite big_fsetU1 ?in_fset1 //= big_seq_fset1 !fsegE.
by rewrite [y == x]eq_sym !(eqxx, negbTE ne_xy) !Monoid.simpm.
Qed.

Lemma cvxsegP x p q :
      (exists2 a, 0 <= a <= 1 & x = (1 - a) *: p + a *: q)
  <-> (exists2 w : {convex L ~> R},
         (finsupp w `<=` [fset p; q])%fset & x = combine w).
Proof. split.
+ case=> a rg01_a ->; exists (fseg a p q).
  - by apply: finsupp_fseg.
  - by rewrite combine_fseg clamp_id.
+ case=> w le_w_pq ->; rewrite (combinewE le_w_pq); exists (w q).
  - by rewrite ge0_fconvex le1_fconvex.
  case: (p =P q) le_w_pq => [<-|/eqP nz_pq] le_w_pq.
  - rewrite fsetUid big_fset1 /= -scalerDl subrK scale1r.
    suff ->: w p = 1 by rewrite scale1r.
    move: le_w_pq; rewrite fsetUid => /fcvx1E_finsupp.
    by move=> ->; rewrite eqxx.
  pose F x := w x *: x; rewrite -(big_seq_fsetE _ _ predT F) /=.
  rewrite big_fsetU1 ?in_fset1 //= big_seq_fset1 {}/F.
  move: (weightwE le_w_pq); rewrite -(big_seq_fsetE _ _ predT) /=.
  rewrite big_fsetU1 ?in_fset1 // big_seq_fset1 /=.
  by rewrite wgt1_fconvex => ->; rewrite addrK.
Qed.
End CvxSegment.

(* -------------------------------------------------------------------- *)
Section CvxUniform.
Context {R : realFieldType} {L : lmodType R}.
Variable V : {fset L}.

Definition fsuni: {fsfun L ~> R} := [fsfun _ in V => #|` V|%:R^-1].

Lemma fsuni_finsupp: finsupp fsuni = V.
Proof.
apply/fsetP => x; rewrite mem_finsupp /fsuni fsfunE.
case: ifP => //.
- move=> x_in_V; rewrite invr_neq0=> //.
  rewrite pnatr_eq0 -lt0n cardfs_gt0.
  by apply/fset0Pn; exists x.
- by move=> _; rewrite eq_refl.
Qed.

Definition fsavg := combine fsuni.

Hypothesis VProp0 : V != fset0.

Lemma cvxavg_r: @convex L R fsuni.
Proof.
apply/convexP; split=> /=.
- move=> x _; rewrite fsfunE; case: ifP => // _.
  by rewrite invr_ge0 ler0n.
- rewrite weightE (eq_bigr (fun=> #|` V|%:R^-1)) /=.
  + move=> i _; rewrite fsfunE.
    by rewrite -{1}fsuni_finsupp (fsvalP i).
  + rewrite sumr_const cardT /= fsuni_finsupp -cardE -cardfE.
    rewrite -(@mulr_natl _ _ #|` V|) divff //.
    by move: VProp0; rewrite -cardfs_gt0 -(ltr0n R); move/lt0r_neq0.
Qed.

Definition cvxuni := nosimpl (mkConvexfun cvxavg_r).
Definition cvxavg := combine cvxuni.

Lemma cvxavg_fsavg : cvxavg = fsavg.
Proof.
by rewrite /cvxavg /fsavg /=.
Qed.

End CvxUniform.

(* -------------------------------------------------------------------- *)
Section Bary.
Context {R : realDomainType} {L : lmodType R}.

Implicit Types (V : {fset L}) (w : {convex L ~> R}).

Definition bary (V : {fset L}) :=
  fun x : L => exists2 w : {convex L ~> R},
    {subset finsupp w <= V} & x = combine w.

Notation "x \bary V" := (bary V x) : form_scope.

Lemma bary_subset V1 V2 x :
  {subset V1 <= V2} -> x \bary V1 -> x \bary V2.
Proof.
move=> le_V1_V2 [w le_w_V1 ->]; exists w => //.
by move=> {}x /le_w_V1 /le_V1_V2.
Qed.

Lemma bary1 x : x \bary [fset x]%fset.
Proof.
exists (fcvx1 x); last by rewrite combine_fcvx1.
by move=> y; rewrite mem_fcvx1 => /eqP->; rewrite fset11.
Qed.
End Bary.

(* -------------------------------------------------------------------- *)
Section ConvexPred.
Context {R : realFieldType} {L : lmodType R} (P : pred L).

Definition convex_pred :=
  forall x y : L, x \in P -> y \in P ->
    forall a : R, 0 <= a <= 1 -> (1-a) *: x + a *: y \in P.

Lemma combine2C (x y : L) (α : R) :
  (1-α) *: x + α *: y = (1 - (1 - α)) *: y + (1 - α) *: x.
Proof.
by rewrite subKr addrC.
Qed.

Lemma combine2_line (v w : L) α :
  (1 - α) *: v + α *: w = v + α *: (w - v).
Proof.
by rewrite scalerBl scale1r addrAC -addrA -scalerBr.
Qed.

Hypothesis cvxP : convex_pred.

(* FIXME: TO BE REWORKED *)
Lemma convexW (w : {convex L ~> R}) :
  {in finsupp w, forall x, x \in P} -> combine w \in P.
Proof.
move=> wP; rewrite combineE; pose F x := w x *: x.
rewrite -!(big_seq_fsetE _ _ predT F) /= {}/F.
move: {-2}(finsupp _) (erefl (finsupp w)) => X.
elim/finSet_rect: X w wP => X ih w wP XE.
have /negP/negP := fconvex_insupp_neq0 w.
rewrite -XE => /fset0Pn[x xX]; rewrite -(fsetD1K xX).
rewrite big_fsetU1 ?fsetD11 //=.
have w1: \sum_(y <- (X `\ x)%fset) w y = 1 - w x.
+ rewrite -(wgt1_fconvex w) weightE -(big_seq_fsetE _ _ predT) /=.
  rewrite -XE -[in RHS](fsetD1K xX) big_fsetU1 ?fsetD11 //=.
  by rewrite addrAC subrr add0r.
have := le1_fconvex w x; rewrite le_eqVlt => /orP[/eqP wxE|lt1_wx].
+ rewrite wxE scale1r big1_seq /= ?addr0; last by apply: wP; rewrite -XE.
  move=> y yXDx; rewrite (rwP eqP); suff ->: w y = 0 by rewrite scale0r.
  move/eqP: w1; rewrite wxE subrr psumr_eq0 => [z _|].
  - by apply: ge0_fconvex.
  - by move/allP=> h; apply/eqP/h.
pose wR : {fsfun _ ~> _} := [fsfun a in (X `\ x)%fset => w a / (1 - w x)].
have hE: \sum_(y <- (X `\ x)%fset) w y *: y
        = (1 - w x) *: \sum_(y <- (X `\ x)%fset) wR y *: y.
+ rewrite scaler_sumr !big_seq; apply: eq_bigr=> y yXDx.
  rewrite scalerA fsfunE yXDx mulrCA divff ?mulr1 //.
  by rewrite subr_eq0 eq_sym lt_eqF.
rewrite hE addrC; (apply: cvxP; try by apply: wP; rewrite -XE); last first.
+ by rewrite ge0_fconvex le1_fconvex.
have cvx_wR: convex wR; first (apply/convexP; split).
+ move=> y _; rewrite fsfunE; case: ifP=> // _.
  by rewrite divr_ge0 1?ge0_fconvex // subr_ge0 le1_fconvex.
+ rewrite (weightwE (E := (X `\ x)%fset)).
  - by apply: finsupp_sub.
  - rewrite (eq_bigr (fun y => w (val y) / (1 - w x))) /=.
    * by move=> y _; rewrite fsfunE fsvalP.
    rewrite -mulr_suml -(big_seq_fsetE _ _ predT w) /=.
    by rewrite w1 divff // subr_eq0 eq_sym lt_eqF.
have supp_wR: (finsupp wR = X `\ x)%fset.
+ apply/fsetP=> y; rewrite mem_finsupp fsfunE.
  case: ifP; rewrite ?eqxx //= => yXdx.
  rewrite mulf_eq0 invr_eq0 gt_eqF ?gt0_fconvex //=.
  * by rewrite -XE; apply/fsubsetP/fsubD1set: yXdx.
  by rewrite subr_eq0 eq_sym lt_eqF.
have /= := ih (X `\ x)%fset _ (mkConvexfun cvx_wR); apply=> //.
+ by apply: fproperD1.
+ by move=> y; rewrite supp_wR in_fsetD1 => /andP[_]; rewrite XE => /wP.
Qed.
End ConvexPred.

(* -------------------------------------------------------------------- *)
Section VectToFsFun.
Context {T : choiceType} {R : ringType}.

Definition frank (S : {fset T}) (v : S) : 'I_#|`S| :=
  cast_ord (esym (cardfE _)) (enum_rank v).

Lemma frankK (S : {fset T}) :
  cancel (fun i : 'I_#|`S| => [`fnthP i]%fset) (@frank S).
Proof.
move=> i; apply/(@cast_ord_inj _ _ (cardfE S))/eqP.
rewrite cast_ordKV -(inj_eq (enum_val_inj)) enum_rankK -(rwP eqP).
apply/val_eqP => /=; set j := cast_ord _ i.
rewrite /fnth (tnth_nth (val (enum_default j))) /= {1}enum_fsetE.
by rewrite (nth_map (enum_default j)) // -cardE -cardfE.
Qed.

Lemma fnthK (S : {fset T}) :
  cancel (@frank S) (fun i : 'I_#|`S| => [`fnthP i]%fset).
Proof.
move=> x; apply/val_eqP/eqP => /=; rewrite /fnth.
rewrite (tnth_nth (val x)) /= enum_fsetE /=.
by rewrite (nth_map x)? nth_enum_rank // -cardE.
Qed.

Lemma val_fnthK (S : {fset T}) (v : S) : fnth (frank v) = fsval v.
Proof. by have := fnthK v => /(congr1 val). Qed.

Lemma bij_frank (S : {fset T}) : bijective (@frank S).
Proof. exact: (Bijective (@fnthK _) (@frankK S)). Qed.

Definition vect_to_fsfun (I : {fset T}) (c : 'cV[R]_#|`I|) : {fsfun T ~> R} :=
  [fsfun v : I => c (frank v) 0].

Lemma finsupp_vect_to_fsfun (I : {fset T}) (c : 'cV[R]_#|`I|) :
  (finsupp (@vect_to_fsfun I c) `<=` I)%fset.
Proof.
apply/fsubsetP=> x; rewrite mem_finsupp fsfun_ffun.
by case: insubP => //=; rewrite eqxx.
Qed.
End VectToFsFun.

(* -------------------------------------------------------------------- *)
Section VectToFsFunTheory.
Context {T : choiceType} {R : realFieldType}.

Lemma conic_vect_to_fsfun (I : {fset T}) (c : 'cV[R]_#|`I|) :
  (0) <=m (c) -> conic (vect_to_fsfun c).
Proof.
move=> ge0_c; apply/conicwP => x; rewrite fsfun_ffun.
by case: insubP => //= i _ _; apply: gev0P.
Qed.

Lemma convex_vect_to_fsfun (I : {fset T}) (c : 'cV[R]_#|`I|) :
  (0) <=m (c) -> '[const_mx 1, c] = 1 -> convex (vect_to_fsfun c).
Proof.
move=> ge0_c Σc_eq_1; rewrite /convex conic_vect_to_fsfun //=.
rewrite (weightwE (finsupp_vect_to_fsfun _)) -(rwP eqP).
move: Σc_eq_1; rewrite vdotC vdotr_const_mx1 => <-.
rewrite (reindex (@frank _ _)) /=; first by apply/onW_bij/bij_frank.
apply: eq_bigr=> i _; rewrite fsfun_ffun insubT //=.
by move=> hin; rewrite fsetsubE.
Qed.
End VectToFsFunTheory.


Require Import List Bool Relations Morphisms Equalities.
Import ListNotations.
Require Export Classes Field Value Packet History Sets.

Module NetKAT (F : FIELDSPEC) (V : VALUESPEC(F)).

  (** * Packets, Histories, and History Sets *)
  Module P := Packet.Packet(F)(V).
  Module H := History.History(F)(V)(P).

  (** * NetKAT Syntax.
     For simplicity, we restrict Filters to simple tests
     and provide a negated filter NFilter, instead of defining predicates.
     We do not lose expressivity (since all negations can be pushed down).
  *)
  Inductive policy : Set :=
    | Drop : policy
    | Id : policy
    | Filter  : forall f, V.t f -> policy
    | NFilter : forall f, V.t f -> policy
    | Mod : forall (f : F.t), V.t f -> policy
    | Union   : policy -> policy -> policy
    | Seq     : policy -> policy -> policy
    | Star    : policy -> policy
    | Dup     : policy.

  Implicit Type p q r : policy.

  Notation "f <- v" := (Mod f v) (at level 30, no associativity, format "f <- v") : netkat_scope.
  Notation "f == v" := (Filter f v) (at level 30, no associativity, format "f == v") : netkat_scope.
  Notation "f != v" := (NFilter f v) (at level 30, no associativity, format "f != v") : netkat_scope.
  Notation "p + q" := (Union p q) (at level 50, left associativity) : netkat_scope.
  Notation "p ;; q" := (Seq p q) (at level 40, left associativity) : netkat_scope.
  Notation "p *" := (Star p) (at level 31, left associativity, format "p *") : netkat_scope.
  Notation "pk [ f := v ]" := (P.mod pk f v) (at level 10, no associativity, format "pk [ f := v ]") : netkat_scope.
  Global Open Scope netkat_scope.
  Delimit Scope netkat_scrope with netkat.

  (** * NetKAT denotational Semantics *)

  (* auxilliary functions for (repeated) kleisli composition *)
  Definition kleisli (f g : H.t -> set H.t) : H.t -> set H.t :=
    fun h h' => exists h'', f h h'' /\ g h'' h'.

  Fixpoint power n f :=
    match n with
      | O => @singleton H.t
      | S n => kleisli f (power n f)
    end.

  (* denotational semantics *)
  Fixpoint denot (p : policy) (h : H.t) : set H.t :=
  match p, h with
  | Drop, _ =>
      @empty H.t
  | Id, h =>
      singleton h
  | Filter f v, (pk,h) =>
      if v =d= pk f then singleton (pk,h)
      else @empty H.t
  | NFilter f v, (pk,h) =>
      if v <d> pk f then singleton (pk,h)
      else @empty H.t
  | Mod f v, (pk,h) =>
      singleton (pk[f:=v], h)
  | p+q, h =>
      union (denot p h) (denot q h)
  | p;;q, h =>
      kleisli (denot p) (denot q) h
  | p*, h =>
      fun h' => ex (fun n => power n (denot p) h h')
  | Dup, (pk,h) =>
      singleton (pk, pk::h)
  end.

  Notation "'[|' p '|]'" := (denot p) (at level 1) : netkat_scope.

  (* Denotational equivalence. *)
  Definition equiv : relation policy :=
    fun p q => forall h, eq ([|p|] h) ([|q|] h).

  Lemma equiv_refl : Reflexive equiv.
    Proof. intros p h. reflexivity. Qed.

  Lemma equiv_sym : Symmetric equiv.
  Proof. intros p q H h. symmetry. apply (H h). Qed.

  Lemma equiv_trans : Transitive equiv.
  Proof. intros p q r H1 H2 h. rewrite -> (H1 h). apply (H2 h). Qed.

  (* This allows us to use reflexivity, symmetry, and rewrite for denotational equivalence *)
  Instance equiv_equiv : Equivalence equiv.
  Proof. split; [apply equiv_refl | apply equiv_sym | apply equiv_trans]. Qed.

  Notation "p === q" := (equiv p q) (at level 80) : netkat_scope.
  Notation "p <== q" := (p + q === q) (at level 80) : netkat_scope.

  (* The NetKAT operators are "proper" w.r.t. equivalence ===,
     i.e. p===q -> p + r === p + q, etc. We need to make Coq aware of this
     explicitly so we can use the rewrite tactic.
     See www.labri.fr/perso/casteran/CoqArt/TypeClassesTut/typeclassestut.pdf
     Section 3.5 for details. *)

  Lemma plus_equiv_right: forall p q r, q === r -> p + q === p + r.
  Proof.
    intros p q r H h h'.
    split; intros H0; (destruct H0; [left | right;apply H]); assumption.
  Qed.

  Lemma plus_equiv_left: forall p q r, p === q -> p + r === q + r.
  Proof.
    intros p q r H h h'.
    split; intros H0; (destruct H0; [left;apply H | right]); assumption.
  Qed.

  Instance plus_equiv_proper :
    Proper (equiv ==> equiv ==> equiv) Union.
  Proof.
    intros p p' Hp q q' Hq.
    assert (p'+q === p'+q') by auto using plus_equiv_right, Hq.
    assert (p+q === p'+q) by auto using plus_equiv_left, Hp.
    rewrite H0; rewrite H; reflexivity.
  Qed.

  Lemma seq_equiv_right: forall p q r, q === r -> p ;; q === p ;; r.
  Proof.
    intros p q r H h h'.
    split; intros H0; destruct H0 as [h'' [H0 H1]];
    apply H in H1; exists h''; auto.
  Qed.

  Lemma seq_equiv_left: forall p q r, p === q -> p ;; r === q ;; r.
  Proof.
    intros p q r H h h'.
    split; intros H0; destruct H0 as [h'' [H0 H1]];
    apply H in H0; exists h''; auto.
  Qed.

  Instance seq_equiv_proper :
    Proper (equiv ==> equiv ==> equiv) Seq.
  Proof.
    intros p p' Hp q q' Hq.
    rewrite (seq_equiv_left _ _ _ Hp).
    rewrite (seq_equiv_right p' _ _ Hq).
    reflexivity.
  Qed.

  Lemma star_equiv: forall p q, p === q -> p* === q*.
  Proof.
    intros p q H h h'.
    split;
      (intros H0; destruct H0 as [n]; exists n;
       generalize dependent h';  generalize dependent h;
       induction n; intuition);
      simpl in H0; destruct H0 as [h'' [H0 H1]];
      apply H in H0; simpl; exists h''; split; try(apply IHn); assumption.
  Qed.

  Instance star_equiv_proper :
    Proper (equiv ==> equiv) Star.
  Proof. intros p q. apply star_equiv; assumption. Qed.

  (** * NetKAT Axioms & useful corollaries *)

  (* some auxilliary lemmas about kleisli composition *)
  Lemma kleisli_assoc: forall f f' f'' h,
    eq (kleisli (kleisli f f') f'' h) (kleisli f (kleisli f' f'') h).
  Proof.
    intros p q r h0.
    intros h1.
    split; intros H; destruct H as [h' [H1 H2]];
    [destruct H1 as [h'' [H0 H1]] | destruct H2 as [h'' [H2 H3]]];
    repeat (eapply ex_intro; intuition eauto).
  Qed.

  Lemma kleisli_right_id: forall f h, eq (f h) (kleisli f (@singleton H.t) h).
  Proof.
    intros p h h'.
    split; intros H.
    + exists h'; intuition.
    + destruct H as [h'' [H0 H1]]. congruence.
  Qed.

  Lemma kleisli_left_id: forall f h, eq (f h) (kleisli (@singleton H.t) f h).
  Proof.
    intros p h h'.
    split; intros H.
    + exists h; intuition.
    + destruct H as [h'' [H0 H1]]. congruence.
  Qed.

  Lemma power_slide: forall n f h,
    eq (power (S n) f h) (kleisli (power n f) f h).
  Proof.
    intros n.
    induction n; intros f h.
    + simpl. unfold kleisli. split; intros H; destruct H as [h'' [H0 H1]].
      - exists h. intuition congruence.
      - exists x. intuition congruence.
    + cut (eq (kleisli f (power (S n) f) h) (kleisli (kleisli f (power n f)) f h)); auto.
      rewrite -> kleisli_assoc. intros h'.
      split; intros H; destruct H as [h'' [H0 H1]];
      exists h''; split; try(apply IHn); assumption.
  Qed.

  Corollary power_slide': forall n f h,
    eq (kleisli f (power n f) h) (kleisli (power n f) f h).
  Proof.
    apply power_slide.
  Qed.

  Lemma power_decompose n m f h h':
    power (m+n) f h h' <-> exists h'', power m f h h'' /\ power n f h'' h'.
  Proof.
    split; intro H; generalize dependent h; generalize dependent h';
    generalize dependent n; induction m; intros; simpl in *.
    - exists h. intuition.
    - destruct H as [h'' [H0 H1]].
      assert (H2 := IHm _ _ _ H1).
      destruct H2 as [h''' [H2 H3]].
      exists h'''; intuition simpl.
      exists h''; intuition.
    - destruct H as [h'' [H0 H1]]. congruence.
    - destruct H as [h'' [H0 H2]].
      destruct H0 as [h''' [H0 H1]].
      exists h'''; eauto.
    Qed.

  (* NetKAT axioms and useful corollaries *)
  Theorem ka_plus_assoc : forall p q r : policy, (p+q)+r === p+(q+r).
  Proof.
   intros p q r h.
   apply union_assoc.
  Qed.

  Theorem ka_plus_comm : forall p q : policy, p + q === q + p.
  Proof.
   intros p q h.
   simpl.
   apply union_comm.
  Qed.

  Theorem ka_plus_zero : forall p : policy, p + Drop === p.
  Proof.
    intros p h.
    simpl.
    apply union_empty_right.
  Qed.

  Corollary ka_zero_plus: forall p : policy, Drop + p === p.
  Proof.
    intros p.
    rewrite -> ka_plus_comm; rewrite -> ka_plus_zero; reflexivity.
  Qed.

  Theorem ka_plus_idem : forall p : policy, p + p === p.
  Proof.
    intros p h.
    simpl.
    apply union_idem.
  Qed.

  Theorem ka_seq_assoc : forall p q r : policy, (p;;q);;r === p;;(q;;r).
  Proof.
    intros p q r h.
    simpl.
    apply kleisli_assoc.
  Qed.

  Theorem ka_one_seq : forall p : policy, Id;; p === p.
  Proof.
    intros p h h'.
    split; intro H.
    + destruct H as [h''[H0 H1]]. simpl in H0. congruence.
    + simpl. eapply ex_intro; eauto.
  Qed.

  Theorem ka_seq_one : forall p : policy, p;; Id === p.
  Proof.
    intros p h h'.
    split; intro H.
    + destruct H as [h''[H0 H1]]. simpl in H1. congruence.
    + simpl. eapply ex_intro; eauto.
  Qed.

  Theorem ka_seq_dist_l : forall p q r : policy,
    p;; (q + r) === p;;q + (p;; r).
  Proof.
    intros p q r h h''.
    split; intro H.
    + destruct H as [h' [H0 [H1|H1]]]; [left | right]; exists h'; auto.
    + repeat destruct H; exists x; intuition eauto.
      - apply union_mono_left; assumption.
      - apply union_mono_right; assumption.
  Qed.

  Theorem ka_seq_dist_r : forall p q r : policy,
    (p + q);; r === p;;r + q;; r.
  Proof.
    intros p q r h h''.
    split; intro H.
    + destruct H as [h' [[H1|H1] H0]]; [left | right]; exists h'; auto.
    + repeat destruct H; exists x; intuition eauto.
      - apply union_mono_left; assumption.
      - apply union_mono_right; assumption.
  Qed.

  Theorem ka_zero_seq : forall p : policy, Drop;; p === Drop.
  Proof.
    intros p h h'.
    split; intros H; repeat destruct H; eauto.
  Qed.

  Theorem ka_seq_zero : forall p : policy, p;; Drop === Drop.
  Proof.
    intros p h h'.
    split; intros H; repeat destruct H; eauto.
  Qed.

  Theorem ka_unroll_l : forall p : policy, Id + p;;p* === p*.
  Proof.
    intros p h h'.
    split; intros H; repeat destruct H.
    + exists 0. congruence.
    + destruct H0 as [n H0]. exists (S n).
      simpl. exists x. auto.
    + destruct x; simpl in H; [left|right].
      - congruence.
      - repeat destruct H. exists x0. intuition eauto.
        exists x. assumption.
  Qed.

  Theorem ka_unroll_r : forall p : policy, Id + p*;;p === p*.
  Proof.
    intros p h h'.
    split; intros H; repeat destruct H.
    + exists 0. congruence.
    + exists (S x0).
      simpl. apply power_slide. exists x. auto.
    + destruct x; simpl in H; [left|right].
      - congruence.
      - apply power_slide' in H.
        repeat destruct H. exists x0. intuition eauto.
        exists x. assumption.
  Qed.

  Lemma ka_seq_mon_left: forall p q r, p <== q -> p;;r <== q;;r.
  Proof.
    intros p q r H h h'.
    split; intros H0.
    + repeat destruct H0; exists x; intuition.
      apply H. left. assumption.
    + right. assumption.
  Qed.

  Lemma ka_seq_mon_right: forall p q r, q <== r -> p;;q <== p;;r.
  Proof.
    intros p q r H h h'.
    split; intros H0.
    + repeat destruct H0; exists x; intuition.
      apply H. left. assumption.
    + right; assumption.
  Qed.

  Lemma ka_plus_mon_left: forall p q r, p<==q -> p + r <== q + r.
  Proof.
    intros p q r H h h'.
    split; intros H0.
    + destruct H0 as [[H0|H0]|[H0|H0]]; [left|right|left|right]; auto.
      apply H; left; assumption.
    + right; assumption.
  Qed.

  Lemma ka_plus_mon_right: forall p q r, q<==r -> p + q <== p + r.
  Proof.
    intros p q r H h h'.
    split; intros H0.
    + destruct H0 as [[H0|H0]|[H0|H0]]; [left|right|left|right]; auto.
      apply H; left; assumption.
    + right; assumption.
  Qed.

  Lemma ka_plus_leq: forall p q r, (p + q <== r) <-> (p <== r /\ q <== r).
  Proof.
    intros p q r.
    split; intro H.
      split;intros h h';split; intro H'.
        destruct H'. apply H. left. left. assumption. assumption.
        right; assumption.
        apply H. destruct H' as [H0|H0]; [left;right|right]; assumption.
        right; assumption.
    destruct H as [H0 H1].
    intros h h'.
    split; intro H.
      destruct H as [H|H].
        destruct H as [H|H]; [apply H0 | apply H1]; left; assumption.
        assumption.
    right. assumption.
  Qed.

  (*
  Theorem ka_lfp_l: forall p q r, (q + p;r <== r) -> (p*;q <== r).
  Proof.
    intros p q r H.
    rewrite -> ka_plus_leq in H.
    destruct H as [H0 H1].
    intros h h'.
    split; intros H.
      destruct H.
        destruct H as [h'']; destruct H as [H2 H3]. destruct H2 as [n].
        induction n.
          apply H0. left. simpl in H. unfold HSet.singleton in H. subst h''. assumption.
        simpl in H. apply power_slide' in H.
          destruct H as [h''']. destruct H as [H2 H4].
          apply (IHn h'''). assumption.

  Qed.
  *)

  (** * Tactics for automated axiomatic reasoning *)
  Create HintDb netkat.
  Hint Rewrite ka_plus_assoc ka_plus_zero ka_zero_plus ka_plus_idem
    ka_seq_assoc ka_one_seq ka_seq_one ka_zero_seq ka_zero_plus
    ka_seq_zero : netkat.

  (* Tactic that tries to rewrite using all "safe" rules and
     then discharges all trivial goals. *)
  Ltac netkat :=
    simpl; try reflexivity;
    autorewrite with netkat using (simpl; try reflexivity).

  (* Tactic that does case splits on policies and then tries
     to solve goals using axiomatic rewriting *)
Ltac netkat_cases :=
intros;
(match goal with
  | [ p:policy, q:policy, r:policy |- _ ] =>
      destruct p; destruct q; destruct r
  | [ p:policy, q:policy |- _ ] => destruct p; destruct q
  | [ p:policy |- _ ] => destruct p
  | _ => idtac
end); netkat.

Ltac netkat_induction id :=
  induction id as [ | | | | | p1 IH1 p2 IH2 | p1 IH1 p2 IH2 | p0 IH | ];
  netkat;
  match goal with
    | [IH1: _ === _, IH2: _ === _ |- _ ] =>
        first [rewrite -> IH1; rewrite <- IH1];
        first [rewrite -> IH2; rewrite <- IH2]
    | [IH: _ === _ |- _] => first [rewrite -> IH | rewrite <- IH]
  end;
  netkat.

End NetKAT.


Require Import List.
Export ListNotations.
Require Import PeanoNat.
Require Import Lia.
Require Import Classical.

Require Import Ensembles.
Require Import K_Syntax.
Require Import K_GHC.
Require Import K_Kripke_sem.

Lemma Ax_valid : forall A, KAxioms A -> (forall M w, wforces M w A).
Proof.
intros A Ax. inversion Ax ; destruct H ; subst ; simpl ; intros ; auto.
- destruct H ; destruct H ; subst ; simpl ; intros ; auto.
- destruct H ; subst ; simpl ; intros ; auto.
- destruct H ; subst ; simpl. intros.
  destruct (classic (wforces M w x)) ; auto.
  assert ((wforces M w x -> wforces M w x0) -> False).
  intros. apply H0. auto. apply H. intros. exfalso ; auto.
- destruct H ; subst ; simpl ; intros ; auto.
- destruct H ; subst ; simpl ; intros ; auto.
Qed.

Theorem wSoundness0 : forall s, (wKH_prv s) ->
        (loc_conseq (fst s) (snd s)).
Proof.
intros s D. induction D.
(* Id *)
- inversion H. subst. simpl. intro. intros. apply H1. assumption.
(* Ax *)
- inversion H. subst. simpl. intro. intros. apply Ax_valid. assumption.
(* MP *)
- inversion H1. subst. simpl. assert (J1: loc_conseq Γ (A --> B)).
  apply H0 with (prem:=(Γ, A --> B)). apply in_eq.
  assert (J2: loc_conseq Γ A).
  apply H0 with (prem:=(Γ, A)). apply in_cons. apply in_eq.
  intro. intros. unfold loc_conseq in J1.
  pose (J1 M w H2). simpl in w0. apply w0.
  pose (J2 M w H2). auto.
(* DNw *)
- inversion H1. subst. simpl. assert (J1: loc_conseq (Empty_set _) A).
  apply H0 with (prem:=(Empty_set _, A)) ; apply in_eq.
  intro. intros. simpl. intros.
  assert (J2: (forall A, In _ (Empty_set _) A -> wforces M v A)).
  intros. inversion H4.
  pose (J1 M v J2). auto.
Qed.

Theorem wSoundness : forall Γ A, wKH_prv (Γ, A) -> (loc_conseq Γ A).
Proof.
intros. apply wSoundness0 in H ; auto.
Qed.

Theorem sSoundness0 : forall s, (sKH_prv s) ->
        (glob_conseq (fst s) (snd s)).
Proof.
intros s D. induction D.
(* Ids *)
- inversion H. subst. simpl. intro. intros. apply H1. assumption.
(* Axs *)
- inversion H. subst. simpl. intro. intros. unfold mforces. apply Ax_valid. assumption.
(* MPs *)
- inversion H1. subst. simpl. assert (J1: glob_conseq Γ (A --> B)).
  apply H0 with (prem:=(Γ, A --> B)). apply in_eq.
  assert (J2: glob_conseq Γ A).
  apply H0 with (prem:=(Γ, A)). apply in_cons. apply in_eq.
  intro. intros. unfold glob_conseq in J1.
  pose (J1 M H2). intro.
  pose (J2 M H2). apply m. apply m0.
(* DNs *)
- inversion H1. subst. simpl. assert (J1: glob_conseq Γ A).
  apply H0 with (prem:=(Γ, A)) ; apply in_eq.
  intro. intros. intro. pose (J1 M H2). intro. intro. apply m.
Qed.

Theorem sSoundness : forall Γ A, sKH_prv (Γ, A) -> (glob_conseq Γ A).
Proof.
intros. apply sSoundness0 in H ; auto.
Qed.

(* Consequences of soundness results. *)

Variable p : V.

Definition nat_val n (q : V) : Prop := n = 0.

Instance M : kmodel :=
      {|
        nodes := nat ;
        reachable := lt ;
        val := nat_val
      |}.

Lemma Consequences_Soundness1 :
  exists s, (sKH_prv s) /\ ((wKH_prv s) -> False).
Proof.
exists (Singleton _ # p , Box # p). split.
apply sNec with (ps:=[(Singleton MPropF # p, # p)]).
2: apply sNecRule_I. intros. inversion H ; subst. 2: inversion H0.
apply Ids. apply IdRule_I. apply In_singleton.
intro. apply wSoundness in H.
assert (J0: forall B : MPropF, In MPropF (Singleton MPropF # p) B -> wforces M 0 B).
intros. inversion H0. cbn. unfold nat_val. auto.
pose (H M 0 J0).
simpl in w. assert (J1: 0 < 1). lia.
pose (w 1 J1). unfold nat_val in n. inversion n.
Qed.

Lemma Consequences_Soundness2 :
  (sKH_prv (Singleton _ # p , Box # p)) /\ ((sKH_prv (Empty_set _, (# p) --> (Box # p))) -> False).
Proof.
split.
apply sNec with (ps:=[(Singleton MPropF # p, # p)]).
2: apply sNecRule_I. intros. inversion H ; subst. 2: inversion H0.
apply Ids. apply IdRule_I. apply In_singleton.
intro. apply sSoundness in H.
assert (J0: forall B : MPropF, In MPropF (Empty_set MPropF) B -> mforces M B).
intros. inversion H0.
pose (H M J0).
pose (m 0). simpl in w.
assert (J1: nat_val 0 p). unfold nat_val ; auto.
assert (J2: 0 < 1). lia.
pose (w J1 1 J2). unfold nat_val in n. inversion n.
Qed.


(** * Testcases for [inequality_chains.v]
Authors:
    - Jim Portegies
Creation date: 30 Oct 2021

Testcases for (in)equality chains.
--------------------------------------------------------------------------------

This file is part of Waterproof-lib.

Waterproof-lib is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

Waterproof-lib is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with Waterproof-lib.  If not, see <https://www.gnu.org/licenses/>.
*)

(* Tests for (in)equality chains *)

From Ltac2 Require Import Ltac2.
Require Import Waterproof.auxiliary.
Require Import Waterproof.test_auxiliary.

Load inequality_chains.

(* Test 0: check if notations work. *)

Goal (& 3 < 4 <= 5 ≤ 7).
Abort.

Goal forall A : Type, forall a : A, & a = a = a = a.
Abort.

(* Test 1: sample proof *)
Goal (3 < 5) /\ (5 = 2 + 3) <-> (& 3 < 5 = 2 + 3).
split.
- intro H.
  cbn.
  destruct H.
  repeat split.
  + assumption.

- intro H.
  cbn in H.
  destruct H as [H1 H2].
  split.
  + assumption.
  + assumption.
Qed.

(* Test 2: check if terms of a subset can be coerced to terms of the underlying set (here: [R]). *)
Goal forall x : R, (& x < INR 0 = INR 0).
Abort.
(* Test 3 : different coercion, namely IZR *)
Goal forall x : R, (& x < up x = up x).
Abort.

(** More tests *)
(* Valid (though incorrect) inputs *)
Goal (& 1 = 2 = 2). Abort.
Goal (& 1 = 2 = 3 = 4). Abort.
Goal (& 1 = 2 < 3 = 4). Abort.
Goal (& 1 = 2 < 3 ≤ 4). Abort.
Goal (& 1 = 2 > 3 = 4). Abort.
Goal (& 1 ≥ 2 > 3 = 4). Abort.
(* Invalid input: combining < and > in one chain *)
Goal True.
Fail pose (Aux.type_of (& 1 < 2 = 3 > 4)).
epose (Aux.type_of (& 1 < 2 = 3 > 4)). (* Does type check, evars are added ... *)
Abort.
Fail Goal (& 1 < 2 = 3 > 4). (* Esoteric error. *)
(* Check for correctness global, weak global and total stamements. *)
Goal True.
assert_constr_equal (eval cbn in (& 1 = 2 = 3 = 4)) constr:((1 = 2 /\ 2 = 3) /\ 3 = 4).
(* Eval cbn in (global_statement (& 1 = 2 = 3 = 4)).*) (* Expected: 1 = 4 , :( *) (* Untestable *)
assert_constr_equal (eval cbn in (& 1 < 2 = 3 < 4)) constr:((1 < 2 /\ 2 = 3) /\ 3 < 4).
(*Eval cbn in (global_statement (1 &< 2 &< 3 &= 4)). (* Expected: 1 < 4 *) (* Untestable *)*)
(*Eval cbn in (weak_global_statement (1 &< 2 &< 3 &= 4)). (* Expected: 1 <= 4*) (* Untestable *)*)
assert_constr_equal (eval cbn in (& 1 > 2 > 3 = 4)) constr:((1 > 2 /\ 2 > 3) /\ 3 = 4). (* Expected: (1 > 2 /\ 2 > 3) /\ 3 = 4 *)
(*Eval cbn in (global_statement (1 &> 2 &> 3 &= 4)). (* Expected: 1 > 4 *) (* Untestable *)*)
(*Eval cbn in (weak_global_statement (1 &> 2 &> 3 &= 4)). (* Expected: 1 >= 4 *) (* Untestable *)*)
Abort.

(* Usage in hypotheses *)
Goal (& 1 < 2 < 3) -> (& 4 = 100 = 100) -> (1 < 3).
Proof.
  intros H1 H2.
  cbn in H1, H2.
Abort.
(* Usage in goal *)
Goal (& 1 < 2 <= 3 < 4).
Proof.
  repeat split; cbn.
Abort.

(** Test whether one can provide a custom relation for an EqualInterpretation.
*)
Local Parameter X : Type.
Require Import Relations.
Local Parameter rel : relation X.

#[local] Instance equal_setoid_interpretation : EqualInterpretation X :=
  { eq_rel_to_pred my_rel x y := rel x y
  }.

Local Parameter y : X.

Goal (& y = y = y).
change (rel y y /\ rel y y).
Abort.

Goal forall x : X, (& x = x = x).
intro x.
(* Test that the correct interpretation has been chosen *)
change (rel x x /\ rel x x).
Abort.

(** Test whether coercions from the naturals work for equalities over the reals numbers.
*)
Local Parameter rel_R : relation R.

#[local] Instance equal_setoid_interpretation_R : EqualInterpretation R :=
  { eq_rel_to_pred my_rel x y := rel_R x y
  }.

Goal forall x : R, (& 0%nat = x = 3%nat).
intro x.
(* Test that the correct interpretation has been chosen *)
change (rel_R 0%R x /\ rel_R x (1 + 1 + 1)%R).
Abort.


Require Import VST.floyd.proofauto.
Require Import Coq.ZArith.ZArith.
Require Import CertiGraph.floyd_ext.closed_lemmas.
Require Export CertiGraph.kruskal.kruskal_edgelist.

Local Open Scope Z.

#[export] Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.

Definition MAX_EDGES:= 8. (*We can malloc, but it's not quite relevant*)
Definition t_struct_edge := Tstruct _edge noattr.
Definition t_wedgearray_graph := Tstruct _graph noattr.
Definition wedgerep := reptype t_struct_edge.
#[export] Instance wedgerep_inhabitant : Inhabitant wedgerep :=
                                    (Vundef, (Vundef, Vundef)).

(*Warning: reptype of a struct doesn’t destruct nicely*)
Definition def_wedgerep (x: reptype t_struct_edge) :=
  is_int I32 Signed (fst x) /\
  is_int I32 Signed (fst (snd x)) /\
  is_int I32 Signed (snd (snd x)).

(*Comparator*)
Definition wedge_le (x y: wedgerep) :=
match x, y with
| (Vint x',_),(Vint y',_) => Int.signed x' <= Int.signed y'
| _,_ => False
end.

Lemma wedge_le_refl: forall x, def_wedgerep x -> wedge_le x x.
Proof.
  intros. destruct H as [? [? ?]].
  unfold wedge_le.
  rewrite (surjective_pairing x).
  destruct (fst x); trivial. lia.
Qed.

Definition wedge_eq (x y: wedgerep) :=
match x, y with
| (Vint x',_),(Vint y',_) => Int.signed x' = Int.signed y'
| _,_ => False
end.

Lemma wedge_eq_refl:
  forall x, def_wedgerep x -> wedge_eq x x.
Proof.
  intros. destruct H as [? [? ?]].
  unfold wedge_eq. rewrite (surjective_pairing x).
  destruct (fst x); trivial.
Qed.

Lemma wedge_eq_symm:
  forall x y, def_wedgerep x -> def_wedgerep y -> wedge_eq x y -> wedge_eq y x.
Proof.
  intros.
  destruct H as [? [? ?]].
  destruct H0 as [? [? ?]].
  rewrite (surjective_pairing x) in *.
  rewrite (surjective_pairing y) in *.
  unfold wedge_eq in *.
  destruct x, y; simpl fst in *; simpl snd in *.
  destruct y, y0; trivial. lia.
Qed.

Definition wedge_lt (x y: wedgerep) :=
match x, y with
| (Vint x',_),(Vint y',_) => Int.signed x' < Int.signed y'
| _,_ => False
end.

Lemma wedge_lt_irrefl:
   forall a, def_wedgerep a -> wedge_lt a a -> False.
Proof.
intros.
destruct H as [? [? ?]].
unfold wedge_lt in H0.
rewrite (surjective_pairing a) in *.
destruct (fst a); trivial. lia.
Qed.

Lemma wedge_lt_le:
  forall x y, def_wedgerep x -> def_wedgerep y -> wedge_lt x y -> wedge_le x y.
Proof.
intros.
destruct H as [? [? ?]].
destruct H0 as [? [? ?]].
unfold wedge_lt in H1.
unfold wedge_le.
rewrite (surjective_pairing x) in *.
rewrite (surjective_pairing y) in *.
destruct x, y.
simpl fst in *. simpl snd in *.
destruct y0, y; trivial. lia.
Qed.

Lemma wedge_lt_le_flip:
  forall x y, def_wedgerep x -> def_wedgerep y -> wedge_lt x y -> ~ (wedge_le y x).
Proof.
  unfold not; intros.
  destruct H as [? [? ?]].
  destruct H0 as [? [? ?]].
  unfold wedge_le in H2; unfold wedge_lt in H1.
  rewrite (surjective_pairing x) in *.
  rewrite (surjective_pairing y) in *.
  destruct x, y.
  simpl fst in *. simpl snd in *.
  destruct y0, y; trivial. lia.
Qed.

Lemma wedge_lt_eq_flip:
  forall x y, def_wedgerep x -> def_wedgerep y -> wedge_lt x y -> ~ (wedge_eq y x).
Proof.
  unfold not; intros.
  destruct H as [? [? ?]].
  destruct H0 as [? [? ?]].
  unfold wedge_eq in H2; unfold wedge_lt in H1.
  rewrite (surjective_pairing x) in *.
  rewrite (surjective_pairing y) in *.
  destruct x, y.
  simpl fst in *. simpl snd in *.
  destruct y0, y; trivial. lia.
Qed.

Lemma wedge_le_lt_flip:
  forall x y, def_wedgerep x -> def_wedgerep y -> wedge_le x y -> ~ (wedge_lt y x).
Proof.
  unfold not; intros.
  destruct H as [? [? ?]].
  destruct H0 as [? [? ?]].
  unfold wedge_lt in H2; unfold wedge_le in H1.
  rewrite (surjective_pairing x) in *.
  rewrite (surjective_pairing y) in *.
  destruct x, y.
  simpl fst in *. simpl snd in *.
  destruct y0, y; trivial. lia.
Qed.

Lemma wedge_eq_lt_flip:
  forall x y, def_wedgerep x -> def_wedgerep y -> wedge_eq x y -> ~ (wedge_lt y x).
Proof.
  unfold not; intros.
  destruct H as [? [? ?]].
  destruct H0 as [? [? ?]].
  unfold wedge_lt in H2; unfold wedge_eq in H1.
  rewrite (surjective_pairing x) in *.
  rewrite (surjective_pairing y) in *.
  destruct x, y.
  simpl fst in *. simpl snd in *.
  destruct y0, y; trivial. lia.
Qed.

Lemma is_wedge_middle:
  forall (before: list wedgerep) (bl: list wedgerep) (after: list wedgerep) i,
       Forall def_wedgerep bl ->
       Zlength before <= i < Zlength before + Zlength bl ->
       is_int I32 Signed (fst (Znth i (before ++ bl ++ after))) /\
       is_int I32 Signed (fst (snd (Znth i (before ++ bl ++ after)))) /\
       is_int I32 Signed (snd (snd (Znth i (before ++ bl ++ after)))).
Proof.
intros.
rewrite app_Znth2 by lia. rewrite app_Znth1 by lia.
eapply Forall_Znth; eauto. lia.
Qed.

(* For the sorting *)

Require Import RelationClasses.
Require Import CertiGraph.binheap.binary_heap_model.
Require Import CertiGraph.binheap.binary_heap_Zmodel.

Definition heap_item : Type := int * (int * int).
(* This should be x >= y *)
Definition cmp (x y: heap_item) := negb (Int.lt (fst x) (fst y)).
Definition cmp_rel (a b : heap_item) : Prop :=
  cmp a b = true.
Lemma cmp_dec: forall a a', {cmp_rel a a'} + {~cmp_rel a a'}.
Proof.
  intros [? ?] [? ?]. unfold cmp_rel, cmp. simpl. case (Int.lt i i0); simpl; auto.
Qed.
#[export] Instance cmp_po: PreOrder cmp_rel.
Proof.
  constructor. intros [? ?]. red. unfold cmp. simpl. case_eq (Int.lt i i); auto; intro. exfalso.
  apply lt_inv in H. lia.
  intros [? ?] [? ?] [? ?]. unfold cmp_rel, cmp. simpl.
  case_eq (Int.lt i i0); auto. discriminate.
  case_eq (Int.lt i i0); auto. discriminate.
  case_eq (Int.lt i i0); auto. discriminate. simpl.
  intros ? _ _ _.
  apply lt_false_inv in H.
  intro.
  assert (Int.lt i0 i1 = false). {
    rewrite <- (negb_involutive (Int.lt i0 i1)). rewrite H0. trivial. }
  apply lt_false_inv in H1.
  case_eq (Int.lt i i1). 2: trivial. intro.
  apply lt_inv in H2. lia.
Qed.
Lemma cmp_linear: forall a b,
  cmp_rel a b \/ cmp_rel b a.
Proof.
  intros [? ?] [? ?]. unfold cmp_rel, cmp; simpl.
  case_eq (Int.lt i i0); auto. intro.
  right.
  case_eq (Int.lt i0 i); auto. intro. exfalso.
  apply lt_inv in H. apply lt_inv in H0.
  lia.
Qed.

Definition heap_ordered := binary_heap_model.heapOrdered heap_item cmp_rel.
Definition heap_ordered_bounded (L : list heap_item) (b : Z) :=
  binary_heap_model.heapOrdered_bounded heap_item cmp_rel L (Z.to_nat b).
Definition weak_heap_ordered_bottom_up (L : list heap_item) (x : Z) :=
  binary_heap_model.weak_heapOrdered2 heap_item cmp_rel L (Z.to_nat x).
Definition weak_heap_ordered_top_down_bounded (L : list heap_item) (b : Z) (x : Z) :=
  binary_heap_model.weak_heapOrdered_bounded heap_item cmp_rel L (Z.to_nat b) (Z.to_nat x).
Definition swim := binary_heap_model.swim heap_item cmp_rel cmp_dec.
Definition sink L i := binary_heap_model.sink heap_item cmp_rel cmp_dec (L,i).
Definition build_heap_helper L i := binary_heap_model.build_heap_helper heap_item cmp_rel cmp_dec L i.

Lemma Zparent_repr: forall i,
  0 < i <= Int.max_unsigned ->
  Int.repr (Zparent i) = Int.divu (Int.repr (i - 1)) (Int.repr 2).
Proof.
  intros. unfold Int.divu. repeat rewrite Int.unsigned_repr.
  2,3: rep_lia. rewrite Zparent_unfold. trivial. lia.
Qed.

Definition heap_item_rep (i : heap_item) : wedgerep :=
  (Vint (fst i), (Vint (fst (snd i)), Vint (snd (snd i)))).

Definition hitem (sh : share) (i : heap_item) : val -> mpred :=
  data_at sh t_struct_edge (heap_item_rep i).

Definition harray (sh : share) (contents : list heap_item) : val -> mpred :=
  data_at sh (tarray t_struct_edge (Zlength contents)) (map heap_item_rep contents).

Lemma harray_emp: forall sh arr,
  harray sh [] arr |-- emp.
Proof.
  unfold harray. intros. rewrite data_at_isptr. entailer. rewrite data_at_zero_array_eq; auto.
Qed.

Lemma fold_harray': forall sh L i arr,
  i = Zlength L ->
  data_at sh (tarray t_struct_edge i) (map heap_item_rep L) arr = harray sh L arr.
Proof. intros. rewrite H. reflexivity. Qed.

Lemma fold_harray: forall sh L arr,
  data_at sh (tarray t_struct_edge (Zlength L)) (map heap_item_rep L) arr = harray sh L arr.
Proof. reflexivity. Qed.

Lemma harray_split: forall sh L1 L2 ptr,
  harray sh (L1 ++ L2) ptr =
  ((harray sh L1 ptr) *
   (harray sh L2 (field_address0 (tarray t_struct_edge (Zlength (L1 ++ L2))) [ArraySubsc (Zlength L1)] ptr)))%logic.
Proof.
  intros. unfold harray.
  rewrite map_app.
  rewrite (split2_data_at_Tarray_app (Zlength L1) (Zlength (L1 ++ L2)) sh t_struct_edge (map heap_item_rep L1) (map heap_item_rep L2)).
  2: rewrite Zlength_map; reflexivity. 2: rewrite Zlength_app, Zlength_map; lia.
  rewrite Zlength_app.
  replace (Zlength L1 + Zlength L2 - Zlength L1) with (Zlength L2) by lia.
  trivial.
Qed.


Require Import Equations.Equations.

Require Export Parser.FocusedSyntaxDerive.
Require Export Parser.FocusedSyntaxNullable.

Opaque unfocus_helper.
Opaque result.
Opaque derive.

Program Fixpoint parse { A } (fs: Focused_Syntax A) (ts: list token)
  (pre:
    ~ has_conflict_ind (core fs) /\
    ~ have_conflict_ind (layers fs)
  ): option A :=
  match ts with
  | nil => result fs
  | t :: ts =>
    match derive fs t _ with
    | None => None
    | Some fs' => parse fs' ts _
    end
  end.

Next Obligation.
  lights; eauto using derive_no_conflict, derive_no_conflicts.
Qed.

Fail Next Obligation. (* no more obligation for `parse` *)

Lemma parse_sound:
  forall ts A (fs: Focused_Syntax A) pre v,
    parse fs ts pre = Some v ->
    matches (unfocus fs) ts v.
Proof.
  induction ts; repeat light;
    eauto using result_sound.

  - revert H.
    generalize (parse_obligation_2 A fs pre a);
      repeat light || destruct_match.

    pose proof (IHts _ _ _ _ H); lights;
      eauto using derive_sound_add.
Qed.

Lemma parse_complete:
  forall ts A (fs: Focused_Syntax A) pre v,
    matches (unfocus fs) ts v ->
    ~ has_conflict_ind (unfocus fs) ->
    parse fs ts pre = Some v.
Proof.
  induction ts; repeat light || options || destruct_match;
    eauto using result_complete.

  generalize (parse_obligation_2 A fs pre a);
    repeat light || destruct_match || destruct_and.

  - unshelve epose proof (derive_sound_remove _ _ _ _ _ _ _ matched _ H) as HM;
      eauto using derive_no_conflict_unfocus.
  - eapply derive_complete in H;
      repeat light || options || destruct_match || rewrite_any.
Qed.

Program Definition parse_correct_statement: Prop :=
  forall A (s: Syntax A) (LL1: ll1_ind s) ts v,
    parse (focus s) ts _ = Some v <->
    matches s ts v.

Fail Next Obligation. (* no more obligations for parse_correct_statement *)

Lemma parse_correct: parse_correct_statement.
Proof.
  unfold parse_correct_statement; lights;
    eauto using parse_complete.
  apply_anywhere parse_sound; rewrite unfocus_focus in *; auto.
Qed.

Lemma non_ambiguous_ll1:
  forall ts A (s: Syntax A) v1 v2,
    matches s ts v1 ->
    matches s ts v2 ->
    ll1_ind s ->
    v1 = v2.
Proof.
  unfold ll1_ind; intros.
  rewrite <- (unfocus_focus A s) in *.
  assert (
    ~ has_conflict_ind (core (focus s)) /\
    ~ have_conflict_ind (layers (focus s))
  ) as pre; [ lights | idtac ].
  apply (parse_complete  _ _ _ pre) in H; [ idtac | lights ].
  apply (parse_complete  _ _ _ pre) in H0; lights.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Rewriter.Language.Wf.
Require Import Crypto.Language.WfExtra.
Require Import Crypto.Rewriter.AllTacticsExtra.
Require Import Crypto.Rewriter.RulesProofs.

Module Compilers.
  Import Language.Compilers.
  Import Language.API.Compilers.
  Import Language.Wf.Compilers.
  Import Language.WfExtra.Compilers.
  Import Rewriter.AllTacticsExtra.Compilers.RewriteRules.GoalType.
  Import Rewriter.AllTactics.Compilers.RewriteRules.Tactic.
  Import Compilers.Classes.

  Module Import RewriteRules.
    Section __.
      Context (bitwidth : Z)
              (lgcarrymax : Z).

      Definition VerifiedRewriterMultiRetSplit : VerifiedRewriter_with_args false false true (multiret_split_rewrite_rules_proofs bitwidth lgcarrymax).
      Proof using All. make_rewriter. Defined.

      Definition default_opts := Eval hnf in @default_opts VerifiedRewriterMultiRetSplit.
      Let optsT := Eval hnf in optsT VerifiedRewriterMultiRetSplit.

      Definition RewriteMultiRetSplit (opts : optsT) {t : API.type} := Eval hnf in @Rewrite VerifiedRewriterMultiRetSplit opts t.

      Lemma Wf_RewriteMultiRetSplit opts {t} e (Hwf : Wf e) : Wf (@RewriteMultiRetSplit opts t e).
      Proof. now apply VerifiedRewriterMultiRetSplit. Qed.

      Lemma Interp_RewriteMultiRetSplit opts {t} e (Hwf : Wf e) : API.Interp (@RewriteMultiRetSplit opts t e) == API.Interp e.
      Proof. now apply VerifiedRewriterMultiRetSplit. Qed.
    End __.
  End RewriteRules.

  Module Export Hints.
#[global]
    Hint Resolve Wf_RewriteMultiRetSplit : wf wf_extra.
#[global]
    Hint Opaque RewriteMultiRetSplit : wf wf_extra interp interp_extra rewrite.
#[global]
    Hint Rewrite @Interp_RewriteMultiRetSplit : interp interp_extra.
  End Hints.
End Compilers.


Require Import Kami.AllNotations ProcKami.FU ProcKami.Div.
Require Import ProcKami.RiscvIsaSpec.Insts.Alu.AluFuncs.
Require Import List.

Section Alu.
  Context `{procParams: ProcParams}.

  Definition MultInputType
    := STRUCT_TYPE {
           "xlen"  :: XlenValue;
           "arg1" :: Bit (2 * Xlen)%nat;
           "arg2" :: Bit (2 * Xlen)%nat
         }.

  Definition MultOutputType
    := STRUCT_TYPE {
           "xlen" :: XlenValue;
           "res" :: Bit (2 * Xlen)%nat
         }.

  Local Open Scope kami_expr.

  Section ty.
    Variable ty: Kind -> Type.

    Definition trunc_msb
               (xlen : XlenValue @# ty)
               (x : Bit (2 * Xlen) @# ty)
      :  Bit Rlen @# ty
      := IF xlen == $1
    then
      SignExtendTruncLsb Rlen
                         (ZeroExtendTruncMsb 32
                                             (unsafeTruncLsb (2 * 32) x))
    else
      SignExtendTruncLsb Rlen
                         (ZeroExtendTruncMsb 64
                                             (unsafeTruncLsb (2 * 64) x)).

  End ty.

  Definition Mult : FUEntry
    := {|
        fuName := "mult";
        fuFunc := fun ty (sem_in_pkt_expr : MultInputType ## ty)
                  => LETE sem_in_pkt
                     :  MultInputType
                          <- sem_in_pkt_expr;
        RetE
          (STRUCT {
               "xlen" ::= #sem_in_pkt @% "xlen";
               "res" ::= (unsafeTruncLsb (2 * Xlen)
                                         ((#sem_in_pkt @% "arg1") * (#sem_in_pkt @% "arg2")))
             } : MultOutputType @# ty);
        fuInsts
        :=
          {|
            instName   := "mul";
            xlens      := xlens_all;
            extensions := "M" :: nil;
            ext_ctxt_off := nil;
            uniqId
            := fieldVal instSizeField ('b"11")  ::
                        fieldVal opcodeField ('b"01100") ::
                        fieldVal funct3Field ('b"000")   ::
                        fieldVal funct7Field ('b"0000001") ::
                        nil;
            inputXform
            := fun ty (cfg_pkt : ContextCfgPkt @# ty) context_pkt_expr
               => LETE context_pkt
                       <- context_pkt_expr;
            RetE
              ((STRUCT {
                    "xlen"  ::= (cfg_pkt @% "xlen");
                    "arg1" ::= xlen_sign_extend (2 * Xlen) (cfg_pkt @% "xlen") (#context_pkt @% "reg1");
                    "arg2" ::= xlen_sign_extend (2 * Xlen) (cfg_pkt @% "xlen") (#context_pkt @% "reg2")
               }) : MultInputType @# ty);
            outputXform
            := fun ty (res_expr : MultOutputType ## ty)
               => LETE res <- res_expr;
            RetE (intRegTag (xlen_sign_extend Rlen (#res @% "xlen") (#res @% "res")));
            optMemParams := None;
            instHints   := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
          |} ::
             {|
               instName   := "mulh";
               xlens      := xlens_all;
               extensions := "M" :: nil;
               ext_ctxt_off := nil;
               uniqId
               := fieldVal instSizeField ('b"11")  ::
                           fieldVal opcodeField ('b"01100") ::
                           fieldVal funct3Field ('b"001")   ::
                           fieldVal funct7Field ('b"0000001") ::
                           nil;
               inputXform
               := fun ty (cfg_pkt : ContextCfgPkt @# ty) context_pkt_expr
                  => LETE context_pkt
                          <- context_pkt_expr;
               RetE
                 ((STRUCT {
                       "xlen"  ::= (cfg_pkt @% "xlen");
                       "arg1" ::= xlen_sign_extend (2 * Xlen) (cfg_pkt @% "xlen") (#context_pkt @% "reg1");
                       "arg2" ::= xlen_sign_extend (2 * Xlen) (cfg_pkt @% "xlen") (#context_pkt @% "reg2")
                     } : MultInputType @# ty));
               outputXform
               := fun ty (res_expr : MultOutputType ## ty)
                  => LETE res <- res_expr;
               RetE (intRegTag (trunc_msb (#res @% "xlen") (#res @% "res")));
               optMemParams := None;
               instHints   := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
             |} ::
             {|
               instName   := "mulhsu";
               xlens      := xlens_all;
               extensions := "M" :: nil;
               ext_ctxt_off := nil;
               uniqId
               := fieldVal instSizeField ('b"11")  ::
                           fieldVal opcodeField ('b"01100") ::
                           fieldVal funct3Field ('b"010")   ::
                           fieldVal funct7Field ('b"0000001") ::
                           nil;
               inputXform
               := fun ty (cfg_pkt : ContextCfgPkt @# ty) context_pkt_expr
                  => LETE context_pkt
                          <- context_pkt_expr;
               RetE
                 ((STRUCT {
                       "xlen"  ::= (cfg_pkt @% "xlen");
                       "arg1" ::= xlen_sign_extend (2 * Xlen) (cfg_pkt @% "xlen") (#context_pkt @% "reg1");
                       "arg2" ::= xlen_zero_extend (2 * Xlen) (cfg_pkt @% "xlen") (#context_pkt @% "reg2")
                  }) : MultInputType @# ty);
               outputXform
               := fun ty (res_expr : MultOutputType ## ty)
                  => LETE res <- res_expr;
               RetE (intRegTag (trunc_msb (#res @% "xlen") (#res @% "res")));
               optMemParams := None;
               instHints   := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
             |} ::
             {|
               instName   := "mulhu";
               xlens      := xlens_all;
               extensions := "M" :: nil;
               ext_ctxt_off := nil;
               uniqId
               := fieldVal instSizeField ('b"11")  ::
                           fieldVal opcodeField ('b"01100") ::
                           fieldVal funct3Field ('b"011")   ::
                           fieldVal funct7Field ('b"0000001") ::
                           nil;
               inputXform
               := fun ty (cfg_pkt : ContextCfgPkt @# ty) context_pkt_expr
                  => LETE context_pkt
                          <- context_pkt_expr;
               RetE
                 ((STRUCT {
                       "xlen"  ::= (cfg_pkt @% "xlen");
                       "arg1" ::= xlen_zero_extend (2 * Xlen) (cfg_pkt @% "xlen") (#context_pkt @% "reg1");
                       "arg2" ::= xlen_zero_extend (2 * Xlen) (cfg_pkt @% "xlen") (#context_pkt @% "reg2")
                  }) : MultInputType @# ty);
               outputXform
               := fun ty (res_expr : MultOutputType ## ty)
                  => LETE res <- res_expr;
               RetE (intRegTag (trunc_msb (#res @% "xlen") (#res @% "res")));
               optMemParams := None;
               instHints   := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
             |} ::
             {|
               instName   := "mulw";
               xlens      :=  (Xlen64 :: nil);
               extensions := "M" :: nil;
               ext_ctxt_off := nil;
               uniqId
               := fieldVal instSizeField ('b"11")  ::
                           fieldVal opcodeField ('b"01110") ::
                           fieldVal funct3Field ('b"000")   ::
                           fieldVal funct7Field ('b"0000001") ::
                           nil;
               inputXform
               := fun ty (cfg_pkt : ContextCfgPkt @# ty) context_pkt_expr
                  => LETE context_pkt
                          <- context_pkt_expr;
               RetE
                 ((STRUCT {
                       "xlen"  ::= (cfg_pkt @% "xlen");
                       "arg1" ::= sign_extend_trunc 32 (2 * Xlen) (#context_pkt @% "reg1");
                       "arg2" ::= sign_extend_trunc 32 (2 * Xlen) (#context_pkt @% "reg2")
                  }) : MultInputType @# ty);
               outputXform
               := fun ty (res_expr : MultOutputType ## ty)
                  => LETE res <- res_expr;
               RetE (intRegTag (sign_extend_trunc 32 Rlen (#res @% "res")));
               optMemParams := None;
               instHints   := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
             |} ::
             nil
      |}.

  Local Close Scope kami_expr.

End Alu.


(** This file provides constructions to lift
a PROP-level binary relation to various closures. *)
From iris.bi.lib Require Export fixpoint.
From iris.proofmode Require Import proofmode.
From iris.prelude Require Import options.

(* The sections add extra BI assumptions, which is only picked up with "Type"*. *)
Set Default Proof Using "Type*".

(** * Definitions *)
Section definitions.
  Context {PROP : bi} `{!BiInternalEq PROP}.
  Context {A : ofe}.

  Local Definition bi_rtc_pre (R : A → A → PROP)
      (x2 : A) (rec : A → PROP) (x1 : A) : PROP :=
    <affine> (x1 ≡ x2) ∨ ∃ x', R x1 x' ∗ rec x'.

  (** The reflexive transitive closure. *)
  Definition bi_rtc (R : A → A → PROP) (x1 x2 : A) : PROP :=
    bi_least_fixpoint (bi_rtc_pre R x2) x1.

  Global Instance: Params (@bi_rtc) 4 := {}.
  Typeclasses Opaque bi_rtc.

  Local Definition bi_tc_pre (R : A → A → PROP)
      (x2 : A) (rec : A → PROP) (x1 : A) : PROP :=
    R x1 x2 ∨ ∃ x', R x1 x' ∗ rec x'.

  (** The transitive closure. *)
  Definition bi_tc (R : A → A → PROP) (x1 x2 : A) : PROP :=
    bi_least_fixpoint (bi_tc_pre R x2) x1.

  Global Instance: Params (@bi_tc) 4 := {}.
  Typeclasses Opaque bi_tc.

  (** Reductions of exactly [n] steps. *)
  Fixpoint bi_nsteps (R : A → A → PROP) (n : nat) (x1 x2 : A) : PROP :=
    match n with
    | 0    => <affine> (x1 ≡ x2)
    | S n' => ∃ x', R x1 x' ∗ bi_nsteps R n' x' x2
    end.

  Global Instance: Params (@bi_nsteps) 5 := {}.
  Typeclasses Opaque bi_nsteps.
End definitions.

Local Instance bi_rtc_pre_mono {PROP : bi} `{!BiInternalEq PROP}
    {A : ofe} (R : A → A → PROP) `{!NonExpansive2 R} (x : A) :
  BiMonoPred (bi_rtc_pre R x).
Proof.
  constructor; [|solve_proper].
  iIntros (rec1 rec2 ??) "#H". iIntros (x1) "[Hrec | Hrec]".
  { by iLeft. }
  iRight.
  iDestruct "Hrec" as (x') "[HP Hrec]".
  iDestruct ("H" with "Hrec") as "Hrec". eauto with iFrame.
Qed.

Global Instance bi_rtc_ne {PROP : bi} `{!BiInternalEq PROP} {A : ofe} (R : A → A → PROP) :
  NonExpansive2 (bi_rtc R).
Proof.
  intros n x1 x2 Hx y1 y2 Hy. rewrite /bi_rtc Hx. f_equiv=> rec z.
  solve_proper.
Qed.

Global Instance bi_rtc_proper {PROP : bi} `{!BiInternalEq PROP} {A : ofe} (R : A → A → PROP)
  : Proper ((≡) ==> (≡) ==> (⊣⊢)) (bi_rtc R).
Proof. apply ne_proper_2. apply _. Qed.

Local Instance bi_tc_pre_mono `{!BiInternalEq PROP}
    {A : ofe} (R : A → A → PROP) `{NonExpansive2 R} (x : A) :
  BiMonoPred (bi_tc_pre R x).
Proof.
  constructor; [|solve_proper].
  iIntros (rec1 rec2 ??) "#H". iIntros (x1) "Hrec".
  iDestruct "Hrec" as "[Hrec | Hrec]".
  { by iLeft. }
  iDestruct "Hrec" as (x') "[HR Hrec]".
  iRight. iExists x'. iFrame "HR". by iApply "H".
Qed.

Global Instance bi_tc_ne `{!BiInternalEq PROP} {A : ofe}
    (R : A → A → PROP) `{NonExpansive2 R} :
  NonExpansive2 (bi_tc R).
Proof.
  intros n x1 x2 Hx y1 y2 Hy. rewrite /bi_tc Hx. f_equiv=> rec z.
  solve_proper.
Qed.

Global Instance bi_tc_proper `{!BiInternalEq PROP} {A : ofe}
    (R : A → A → PROP) `{NonExpansive2 R}
  : Proper ((≡) ==> (≡) ==> (⊣⊢)) (bi_tc R).
Proof. apply ne_proper_2. apply _. Qed.

Global Instance bi_nsteps_ne {PROP : bi} `{!BiInternalEq PROP}
    {A : ofe} (R : A → A → PROP) `{NonExpansive2 R} (n : nat) :
  NonExpansive2 (bi_nsteps R n).
Proof. induction n; solve_proper. Qed.

Global Instance bi_nsteps_proper {PROP : bi} `{!BiInternalEq PROP}
    {A : ofe} (R : A → A → PROP) `{NonExpansive2 R} (n : nat)
  : Proper ((≡) ==> (≡) ==> (⊣⊢)) (bi_nsteps R n).
Proof. apply ne_proper_2. apply _. Qed.

(** * General theorems *)
Section general.
  Context {PROP : bi} `{!BiInternalEq PROP}.
  Context {A : ofe}.
  Context (R : A → A → PROP) `{!NonExpansive2 R}.

  (** ** Results about the reflexive-transitive closure [bi_rtc] *)
  Local Lemma bi_rtc_unfold (x1 x2 : A) :
    bi_rtc R x1 x2 ≡ bi_rtc_pre R x2 (λ x1, bi_rtc R x1 x2) x1.
  Proof. by rewrite /bi_rtc; rewrite -least_fixpoint_unfold. Qed.

  Lemma bi_rtc_strong_ind_l x2 Φ :
    NonExpansive Φ →
    □ (∀ x1, <affine> (x1 ≡ x2) ∨ (∃ x', R x1 x' ∗ (Φ x' ∧ bi_rtc R x' x2)) -∗ Φ x1) -∗
    ∀ x1, bi_rtc R x1 x2 -∗ Φ x1.
 Proof.
    iIntros (?) "#IH". rewrite /bi_rtc.
    by iApply (least_fixpoint_ind (bi_rtc_pre R x2) with "IH").
  Qed.

  Lemma bi_rtc_ind_l x2 Φ :
    NonExpansive Φ →
    □ (∀ x1, <affine> (x1 ≡ x2) ∨ (∃ x', R x1 x' ∗ Φ x') -∗ Φ x1) -∗
    ∀ x1, bi_rtc R x1 x2 -∗ Φ x1.
  Proof.
    iIntros (?) "#IH". rewrite /bi_rtc.
    by iApply (least_fixpoint_iter (bi_rtc_pre R x2) with "IH").
  Qed.

  Lemma bi_rtc_refl x : ⊢ bi_rtc R x x.
  Proof. rewrite bi_rtc_unfold. by iLeft. Qed.

  Lemma bi_rtc_l x1 x2 x3 : R x1 x2 -∗ bi_rtc R x2 x3 -∗ bi_rtc R x1 x3.
  Proof.
    iIntros "H1 H2".
    iEval (rewrite bi_rtc_unfold /bi_rtc_pre). iRight.
    iExists x2. iFrame.
  Qed.

  Lemma bi_rtc_once x1 x2 : R x1 x2 -∗ bi_rtc R x1 x2.
  Proof. iIntros "H". iApply (bi_rtc_l with "H"). iApply bi_rtc_refl. Qed.

  Lemma bi_rtc_trans x1 x2 x3 : bi_rtc R x1 x2 -∗ bi_rtc R x2 x3 -∗ bi_rtc R x1 x3.
  Proof.
    iRevert (x1).
    iApply bi_rtc_ind_l.
    { solve_proper. }
    iIntros "!>" (x1) "[H | H] H2".
    { by iRewrite "H". }
    iDestruct "H" as (x') "[H IH]".
    iApply (bi_rtc_l with "H").
    by iApply "IH".
  Qed.

  Lemma bi_rtc_r x y z : bi_rtc R x y -∗ R y z -∗ bi_rtc R x z.
  Proof.
    iIntros "H H'".
    iApply (bi_rtc_trans with "H").
    by iApply bi_rtc_once.
  Qed.

  Lemma bi_rtc_inv x z :
    bi_rtc R x z -∗ <affine> (x ≡ z) ∨ ∃ y, R x y ∗ bi_rtc R y z.
  Proof. rewrite bi_rtc_unfold. iIntros "[H | H]"; eauto. Qed.

  Global Instance bi_rtc_affine :
    (∀ x y, Affine (R x y)) →
    ∀ x y, Affine (bi_rtc R x y).
  Proof. intros. apply least_fixpoint_affine; apply _. Qed.

  (* FIXME: It would be nicer to use the least_fixpoint_persistent lemmas,
            but they seem to weak. *)
  Global Instance bi_rtc_persistent :
    (∀ x y, Persistent (R x y)) →
    ∀ x y, Persistent (bi_rtc R x y).
  Proof.
    intros ? x y. rewrite /Persistent.
    iRevert (x). iApply bi_rtc_ind_l; first solve_proper.
    iIntros "!>" (x) "[#Heq | (%x' & #Hxx' & #Hx'y)]".
    { iRewrite "Heq". iApply bi_rtc_refl. }
    iApply (bi_rtc_l with "Hxx' Hx'y").
  Qed.

  (** ** Results about the transitive closure [bi_tc] *)
  Local Lemma bi_tc_unfold (x1 x2 : A) :
    bi_tc R x1 x2 ≡ bi_tc_pre R x2 (λ x1, bi_tc R x1 x2) x1.
  Proof. by rewrite /bi_tc; rewrite -least_fixpoint_unfold. Qed.

  Lemma bi_tc_strong_ind_l x2 Φ :
    NonExpansive Φ →
    □ (∀ x1, (R x1 x2 ∨ (∃ x', R x1 x' ∗ (Φ x' ∧ bi_tc R x' x2))) -∗ Φ x1) -∗
    ∀ x1, bi_tc R x1 x2 -∗ Φ x1.
  Proof.
    iIntros (?) "#IH". rewrite /bi_tc.
    iApply (least_fixpoint_ind (bi_tc_pre R x2) with "IH").
  Qed.

  Lemma bi_tc_ind_l x2 Φ :
    NonExpansive Φ →
    □ (∀ x1, (R x1 x2 ∨ (∃ x', R x1 x' ∗ Φ x')) -∗ Φ x1) -∗
    ∀ x1, bi_tc R x1 x2 -∗ Φ x1.
  Proof.
    iIntros (?) "#IH". rewrite /bi_tc.
    iApply (least_fixpoint_iter (bi_tc_pre R x2) with "IH").
  Qed.

  Lemma bi_tc_l x1 x2 x3 : R x1 x2 -∗ bi_tc R x2 x3 -∗ bi_tc R x1 x3.
  Proof.
    iIntros "H1 H2".
    iEval (rewrite bi_tc_unfold /bi_tc_pre).
    iRight. iExists x2. iFrame.
  Qed.

  Lemma bi_tc_once x1 x2 : R x1 x2 -∗ bi_tc R x1 x2.
  Proof.
    iIntros "H".
    iEval (rewrite bi_tc_unfold /bi_tc_pre).
    by iLeft.
  Qed.

  Lemma bi_tc_trans x1 x2 x3 : bi_tc R x1 x2 -∗ bi_tc R x2 x3 -∗ bi_tc R x1 x3.
  Proof.
    iRevert (x1).
    iApply bi_tc_ind_l.
    { solve_proper. }
    iIntros "!>" (x1) "H H2".
    iDestruct "H" as "[H | H]".
    { iApply (bi_tc_l with "H H2"). }
    iDestruct "H" as (x') "[H IH]".
    iApply (bi_tc_l with "H").
    by iApply "IH".
  Qed.

  Lemma bi_tc_r x y z : bi_tc R x y -∗ R y z -∗ bi_tc R x z.
  Proof.
    iIntros "H H'".
    iApply (bi_tc_trans with "H").
    by iApply bi_tc_once.
  Qed.

  Lemma bi_tc_rtc_l x y z : bi_rtc R x y -∗ bi_tc R y z -∗ bi_tc R x z.
  Proof.
    iRevert (x).
    iApply bi_rtc_ind_l. { solve_proper. }
    iIntros "!>" (x) "[Heq | H] Hyz".
    { by iRewrite "Heq". }
    iDestruct "H" as (x') "[H IH]".
    iApply (bi_tc_l with "H").
    by iApply "IH".
  Qed.

  Lemma bi_tc_rtc_r x y z : bi_tc R x y -∗ bi_rtc R y z -∗ bi_tc R x z.
  Proof.
    iIntros "Hxy Hyz".
    iRevert (x) "Hxy". iRevert (y) "Hyz".
    iApply bi_rtc_ind_l. { solve_proper. }
    iIntros "!>" (y) "[Heq | H] %x Hxy".
    { by iRewrite -"Heq". }
    iDestruct "H" as (y') "[H IH]".
    iApply "IH". iApply (bi_tc_r with "Hxy H").
  Qed.

  Lemma bi_tc_rtc x y : bi_tc R x y -∗ bi_rtc R x y.
  Proof.
    iRevert (x). iApply bi_tc_ind_l. { solve_proper. }
    iIntros "!>" (x) "[Hxy | H]".
    { by iApply bi_rtc_once. }
    iDestruct "H" as (x') "[H H']".
    iApply (bi_rtc_l with "H H'").
  Qed.

  Global Instance bi_tc_affine :
    (∀ x y, Affine (R x y)) →
    ∀ x y, Affine (bi_tc R x y).
  Proof. intros. apply least_fixpoint_affine; apply _. Qed.

  Global Instance bi_tc_absorbing :
    (∀ x y, Absorbing (R x y)) →
    ∀ x y, Absorbing (bi_tc R x y).
  Proof. intros. apply least_fixpoint_absorbing; apply _. Qed.

  (* FIXME: It would be nicer to use the least_fixpoint_persistent lemmas,
            but they seem to weak. *)
  Global Instance bi_tc_persistent :
    (∀ x y, Persistent (R x y)) →
    ∀ x y, Persistent (bi_tc R x y).
  Proof.
    intros ? x y. rewrite /Persistent.
    iRevert (x). iApply bi_tc_ind_l; first solve_proper.
    iIntros "!# %x [#H|(%x'&#?&#?)] !>"; first by iApply bi_tc_once.
    by iApply bi_tc_l.
  Qed.

  (** ** Results about [bi_nsteps] *)
  Lemma bi_nsteps_O x : ⊢ bi_nsteps R 0 x x.
  Proof. auto. Qed.
  Lemma bi_nsteps_once x y : R x y -∗ bi_nsteps R 1 x y.
  Proof. simpl. eauto. Qed.
  Lemma bi_nsteps_once_inv x y : bi_nsteps R 1 x y -∗ R x y.
  Proof. iDestruct 1 as (x') "[Hxx' Heq]". by iRewrite -"Heq". Qed.
  Lemma bi_nsteps_l n x y z : R x y -∗ bi_nsteps R n y z -∗ bi_nsteps R (S n) x z.
  Proof. iIntros "? ?". iExists y. iFrame. Qed.

  Lemma bi_nsteps_trans n m x y z :
    bi_nsteps R n x y -∗ bi_nsteps R m y z -∗ bi_nsteps R (n + m) x z.
  Proof.
    iInduction n as [|n] "IH" forall (x); simpl.
    - iIntros "Heq". iRewrite "Heq". auto.
    - iDestruct 1 as (x') "[Hxx' Hx'y]". iIntros "Hyz".
      iExists x'. iFrame "Hxx'". iApply ("IH" with "Hx'y Hyz").
  Qed.

  Lemma bi_nsteps_r n x y z :
    bi_nsteps R n x y -∗ R y z -∗ bi_nsteps R (S n) x z.
  Proof.
    iIntros "Hxy Hyx". rewrite -Nat.add_1_r.
    iApply (bi_nsteps_trans with "Hxy").
    by iApply bi_nsteps_once.
  Qed.

  Lemma bi_nsteps_add_inv n m x z :
    bi_nsteps R (n + m) x z -∗ ∃ y, bi_nsteps R n x y ∗ bi_nsteps R m y z.
  Proof.
    iInduction n as [|n] "IH" forall (x).
    - iIntros "Hxz". iExists x. auto.
    - iDestruct 1 as (y) "[Hxy Hyz]".
      iDestruct ("IH" with "Hyz") as (y') "[Hyy' Hy'z]".
      iExists y'. iFrame "Hy'z".
      iApply (bi_nsteps_l with "Hxy Hyy'").
  Qed.

  Lemma bi_nsteps_inv_r n x z :
    bi_nsteps R (S n) x z -∗ ∃ y, bi_nsteps R n x y ∗ R y z.
  Proof.
    rewrite -Nat.add_1_r bi_nsteps_add_inv /=.
    iDestruct 1 as (y) "[Hxy (%x' & Hxx' & Heq)]".
    iExists y. iRewrite -"Heq". iFrame.
  Qed.

  (** ** Equivalences between closure operators *)
  Lemma bi_rtc_tc x y : bi_rtc R x y ⊣⊢ <affine> (x ≡ y) ∨ bi_tc R x y.
  Proof.
    iSplit.
    - iRevert (x). iApply bi_rtc_ind_l. { solve_proper. }
      iIntros "!>" (x) "[Heq | H]".
      { by iLeft. }
      iRight.
      iDestruct "H" as (x') "[H [Heq | IH]]".
      { iRewrite -"Heq". by iApply bi_tc_once. }
      iApply (bi_tc_l with "H IH").
    - iIntros "[Heq | Hxy]".
      { iRewrite "Heq". iApply bi_rtc_refl. }
      by iApply bi_tc_rtc.
  Qed.

  Lemma bi_tc_nsteps x y :
    bi_tc R x y ⊣⊢ ∃ n, <affine> ⌜0 < n⌝ ∗ bi_nsteps R n x y.
  Proof.
    iSplit.
    - iRevert (x). iApply bi_tc_ind_l. { solve_proper. }
      iIntros "!>" (x) "[Hxy | H]".
      { iExists 1. iSplitR; first auto with lia.
        iApply (bi_nsteps_l with "Hxy"). iApply bi_nsteps_O. }
      iDestruct "H" as (x') "[Hxx' IH]".
      iDestruct "IH" as (n ?) "Hx'y".
      iExists (S n). iSplitR; first auto with lia.
      iApply (bi_nsteps_l with "Hxx' Hx'y").
    - iDestruct 1 as (n ?) "Hxy".
      iInduction n as [|n] "IH" forall (y). { lia. }
      rewrite bi_nsteps_inv_r.
      iDestruct "Hxy" as (x') "[Hxx' Hx'y]".
      destruct n.
      { simpl. iRewrite "Hxx'". by iApply bi_tc_once. }
      iApply (bi_tc_r with "[Hxx'] Hx'y").
      iApply ("IH" with "[%] Hxx'"). lia.
  Qed.

  Lemma bi_rtc_nsteps x y : bi_rtc R x y ⊣⊢ ∃ n, bi_nsteps R n x y.
  Proof.
    iSplit.
    - iRevert (x). iApply bi_rtc_ind_l. { solve_proper. }
      iIntros "!>" (x) "[Heq | H]".
      { iExists 0. iRewrite "Heq". iApply bi_nsteps_O. }
      iDestruct "H" as (x') "[Hxx' IH]".
      iDestruct "IH" as (n) "Hx'y".
      iExists (S n). iApply (bi_nsteps_l with "Hxx' Hx'y").
    - iDestruct 1 as (n) "Hxy".
      iInduction n as [|n] "IH" forall (y).
      { simpl. iRewrite "Hxy". iApply bi_rtc_refl. }
      iDestruct (bi_nsteps_inv_r with "Hxy") as (x') "[Hxx' Hx'y]".
      iApply (bi_rtc_r with "[Hxx'] Hx'y").
      by iApply "IH".
  Qed.
End general.

Section timeless.
  Context {PROP : bi} `{!BiInternalEq PROP, !BiAffine PROP}.
  Context `{!OfeDiscrete A}.
  Context (R : A → A → PROP) `{!NonExpansive2 R}.

  Global Instance bi_nsteps_timeless n :
    (∀ x y, Timeless (R x y)) →
    ∀ x y, Timeless (bi_nsteps R n x y).
  Proof. induction n; apply _. Qed.

  Global Instance bi_rtc_timeless :
    (∀ x y, Timeless (R x y)) →
    ∀ x y, Timeless (bi_rtc R x y).
  Proof. intros ? x y. rewrite bi_rtc_nsteps. apply _. Qed.

  Global Instance bi_tc_timeless :
    (∀ x y, Timeless (R x y)) →
    ∀ x y, Timeless (bi_tc R x y).
  Proof. intros ? x y. rewrite bi_tc_nsteps. apply _. Qed.
End timeless.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime Eprimeprime A B C Bprime Bprimeprime : Universe, ((wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ B O /\ (wd_ A O /\ (wd_ C O /\ (wd_ O Eprimeprime /\ (wd_ E Eprimeprime /\ (wd_ B E /\ (wd_ A E /\ (wd_ Bprime O /\ (wd_ Eprime Eprimeprime /\ (wd_ Bprimeprime Bprime /\ (wd_ Bprime Eprime /\ (wd_ Bprimeprime Eprimeprime /\ (wd_ A Eprime /\ (wd_ A Eprimeprime /\ (wd_ Eprime C /\ (wd_ A Bprime /\ (wd_ A C /\ (wd_ Bprime C /\ (wd_ E Bprime /\ (wd_ Eprime B /\ (wd_ B Bprime /\ (wd_ B Bprimeprime /\ (wd_ B Eprimeprime /\ (wd_ Bprimeprime E /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O Eprime Bprime /\ (col_ O Eprimeprime Bprimeprime /\ (col_ Eprimeprime Bprimeprime Bprime /\ col_ Eprime Bprimeprime Bprime))))))))))))))))))))))))))))))))) -> col_ Eprimeprime Eprime Bprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Init.Prelude.

Goal True.
  Time (pose proof I as H; do 500 (pose proof (id H) as G; clear H; pose proof (id G) as H; clear G); clear H).
  (* Finished transaction in 0.089 secs (0.046u,0.042s) (successful) *)
  Time (pose proof I as H; do 1000 (pose proof (id H) as G; clear H; pose proof (id G) as H; clear G); clear H).
  (* Finished transaction in 0.164 secs (0.123u,0.039s) (successful) *)
  Time (pose proof I as H; do 2000 (pose proof (id H) as G; clear H; pose proof (id G) as H; clear G); clear H).
  (* Finished transaction in 0.256 secs (0.245u,0.009s) (successful) *)
  Time (pose proof I as H; do 4000 (pose proof (id H) as G; clear H; pose proof (id G) as H; clear G); clear H).
  (* Finished transaction in 0.486 secs (0.452u,0.032s) (successful) *)
  Time (pose proof I as H; do 8000 (pose proof (id H) as G; clear H; pose proof (id G) as H; clear G); clear H).
  (* Finished transaction in 1.096 secs (1.032u,0.059s) (successful) *)
  exact I.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require list.List.

(* Why3 assumption *)
Fixpoint mem {a:Type} {a_WT:WhyType a} (x:a) (l:(list a)) {struct l}: Prop :=
  match l with
  | Init.Datatypes.nil => False
  | (Init.Datatypes.cons y r) => (x = y) \/ (mem x r)
  end.

Lemma mem_std :
  forall {a:Type} {a_WT:WhyType a} (x:a) (l:list a),
  mem x l <-> List.In x l.
Proof.
intros a a_WT x l.
induction l as [|h q].
easy.
simpl.
split ; intros [H|H].
now left.
right.
now apply IHq.
now left.
right.
now apply IHq.
Qed.