(* --------------------------------------------------------------------
 * (c) Copyright 2011--2012 Microsoft Corporation and Inria.
 * (c) Copyright 2012--2014 Inria.
 * (c) Copyright 2012--2014 IMDEA Software Institute.
 * -------------------------------------------------------------------- *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import ssreflect ssrnat ssrbool eqtype fintype.
From mathcomp Require Import tuple seq fintype bigop ssralg finalg.
From mathcomp Require Import ssrfun choice zmodp fingroup.

Require Import SsrMultinomials.mpoly polyall polydec ssrring.

Import GRing.Theory.

Local Open Scope ring_scope.

Set Implicit Arguments.
Unset Strict Implicit.

(* -------------------------------------------------------------------- *)
Local Notation simp := Monoid.simpm.

Reserved Notation "\- x" (at level 50).

(* -------------------------------------------------------------------- *)
(* FIXME: move me                                                       *)
Lemma ltn_pred (n m : nat): (n.-1 < m.-1) -> (n < m).
Proof. by case: n m => [|n] [|m]. Qed.

Lemma maxn_pred n m: maxn n.-1 m.-1 = (maxn n m).-1.
Proof. by case: n m => [|n] [|m]; rewrite ?(maxn0, max0n, maxnSS). Qed.

Definition monotone f := forall m n, (f m <= f n) = (m <= n).

Lemma map_maxn f n m: monotone f -> f (maxn n m) = maxn (f n) (f m).
Proof.
  move=> mono_f; rewrite /maxn [f n < _]ltnNge mono_f.
  by rewrite -ltnNge; case: (_ < _).
Qed.

(* -------------------------------------------------------------------- *)
Module ECUFieldType.
  Record mixin_of (K : ringType) : Type := Mixin {
    _ : 2%:R != 0 :> K;
    _ : 3%:R != 0 :> K
  }.

  Section ClassDef.
    Record class_of (K : Type) := Class {
      base  : GRing.Field.class_of K;
      mixin : mixin_of (GRing.Field.Pack base K)
    }.

    Local Coercion base : class_of >-> GRing.Field.class_of.

    Structure type := Pack {sort; _ : class_of sort; _ : Type}.

    Local Coercion sort : type >-> Sortclass.

    Variables (T : Type) (cT : type).

    Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
    Definition clone c of phant_id class c := @Pack T c T.

    Definition pack b0 (m0 : mixin_of (@GRing.Field.Pack T b0 T)) :=
      fun bT b & phant_id (@GRing.Field.class bT) b =>
      fun    m & phant_id m0 m => Pack (@Class T b m) T.

    Definition eqType          := Equality.Pack             class cT.
    Definition choiceType      := Choice.Pack               class cT.
    Definition zmodType        := GRing.Zmodule.Pack        class cT.
    Definition ringType        := GRing.Ring.Pack           class cT.
    Definition comRingType     := GRing.ComRing.Pack        class cT.
    Definition unitRingType    := GRing.UnitRing.Pack       class cT.
    Definition comUnitRingType := GRing.ComUnitRing.Pack    class cT.
    Definition idomainType     := GRing.IntegralDomain.Pack class cT.
    Definition fieldType       := GRing.Field.Pack          class cT.
  End ClassDef.

  Module Exports.
    Coercion base  : class_of >-> GRing.Field.class_of.
    Coercion mixin : class_of >-> mixin_of.
    Coercion sort  : type     >-> Sortclass.

    Bind Scope ring_scope with sort.

    Coercion eqType : type >-> Equality.type.
    Canonical eqType.
    Coercion choiceType : type >-> Choice.type.
    Canonical choiceType.
    Coercion zmodType : type >-> GRing.Zmodule.type.
    Canonical zmodType.
    Coercion ringType : type >-> GRing.Ring.type.
    Canonical ringType.
    Coercion comRingType : type >-> GRing.ComRing.type.
    Canonical comRingType.
    Coercion unitRingType : type >-> GRing.UnitRing.type.
    Canonical unitRingType.
    Coercion comUnitRingType : type >-> GRing.ComUnitRing.type.
    Canonical comUnitRingType.
    Coercion idomainType : type >-> GRing.IntegralDomain.type.
    Canonical idomainType.
    Coercion fieldType : type >-> GRing.Field.type.
    Canonical fieldType.

    Notation ecuFieldType := type.
    Notation ECUFieldType T m := (@pack T _ m _ _ id _ id).
    Notation ECUFieldMixin := Mixin.

    Notation "[ 'ecuFieldType' 'of' T ]" := (@clone T _ _ id)
      (at level 0, format "[ 'ecuFieldType'  'of'  T ]") : form_scope.
  End Exports.
End ECUFieldType.

Export ECUFieldType.Exports.

Section ECUFieldTypeTheory.
  Variable K : ecuFieldType.

  Lemma ecu_chi2: 2%:R != 0 :> K.
  Proof. by case: K => [? [? []]]. Qed.

  Lemma ecu_chi3: 3%:R != 0 :> K.
  Proof. by case: K => [? [? []]]. Qed.

  Lemma ecu_eq_oppr:
    forall (x : K), x = -x -> x = 0.
  Proof.
    move=> x; move/(congr1 (+%R x)); rewrite subrr -mulr2n => /eqP.
    by rewrite -mulr_natl mulf_eq0 (negbTE ecu_chi2) => /eqP.
  Qed.
End ECUFieldTypeTheory.

(* -------------------------------------------------------------------- *)
Module ECUFinField.
  Local Notation mixin_of T b := (Finite.mixin_of (EqType T b)).
  Local Notation fin_ c := (@Finite.Class _ c c).
  Local Notation do_pack pack T := (pack T _ _ id _ _ id).

  Local Notation base_group T vT fT :=
    (@FinGroup.PackBase T (FinRing.groupMixin vT) (Finite.class fT)).
  Local Notation fin_group B V := (@FinGroup.Pack B (@addNr V)).

  Section ClassDef.
    Record class_of R := Class {
      base  : ECUFieldType.class_of R;
      mixin : mixin_of R base
    }.

    Definition base2 R (c : class_of R) := FinRing.Field.Class (mixin c).

    Local Coercion base  : class_of >-> ECUFieldType.class_of.
    Local Coercion base2 : class_of >-> FinRing.Field.class_of.

    Structure type := Pack {sort; _ : class_of sort; _ : Type}.
    Local Coercion sort : type >-> Sortclass.

    Definition pack := FinRing.gen_pack Pack Class ECUFieldType.class.

    Variable cT : type.

    Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.

    Let xT := let: Pack T _ _ := cT in T.
    Notation xclass := (class : class_of xT).

    Definition eqType := @Equality.Pack cT xclass xT.
    Definition choiceType := @Choice.Pack cT xclass xT.
    Definition countType := @Countable.Pack cT (fin_ xclass) xT.
    Definition finType := @Finite.Pack cT (fin_ xclass) xT.
    Definition zmodType := @GRing.Zmodule.Pack cT xclass xT.
    Definition finZmodType := @FinRing.Zmodule.Pack cT xclass xT.
    Definition ringType := @GRing.Ring.Pack cT xclass xT.
    Definition finRingType := @FinRing.Ring.Pack cT xclass xT.
    Definition comRingType := @GRing.ComRing.Pack cT xclass xT.
    Definition finComRingType := @FinRing.ComRing.Pack cT xclass xT.
    Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT.
    Definition finUnitRingType := @FinRing.UnitRing.Pack cT xclass xT.
    Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT.
    Definition finComUnitRingType := @FinRing.ComUnitRing.Pack cT xclass xT.
    Definition idomainType := @GRing.IntegralDomain.Pack cT xclass xT.
    Definition finIdomainType := @FinRing.IntegralDomain.Pack cT xclass xT.
    Definition fieldType := @GRing.Field.Pack cT xclass xT.
    Definition finFieldType := @FinRing.Field.Pack cT xclass xT.
    Definition ecuFieldType := @ECUFieldType.Pack cT xclass xT.

    Definition join_finType := @Finite.Pack fieldType (fin_ xclass) xT.
    Definition join_finZmodType := @FinRing.Zmodule.Pack fieldType xclass xT.
    Definition join_finRingType := @FinRing.Ring.Pack fieldType xclass xT.
    Definition join_finUnitRingType := @FinRing.UnitRing.Pack fieldType xclass xT.
    Definition join_finComRingType := @FinRing.ComRing.Pack fieldType xclass xT.
    Definition join_finComUnitRingType := @FinRing.ComUnitRing.Pack fieldType xclass xT.
    Definition join_finIdomainType := @FinRing.IntegralDomain.Pack fieldType xclass xT.
    Definition join_finFieldType := @FinRing.Field.Pack fieldType xclass xT.

    Definition baseFinGroupType := base_group cT zmodType finType.
    Definition finGroupType := fin_group baseFinGroupType zmodType.
    Definition join_baseFinGroupType := base_group zmodType zmodType finType.
    Definition join_finGroupType := fin_group join_baseFinGroupType zmodType.
  End ClassDef.

  Module Exports.
    Coercion base  : class_of >-> ECUFieldType.class_of.
    Coercion base2 : class_of >-> FinRing.Field.class_of.
    Coercion sort  : type >-> Sortclass.

    Bind Scope ring_scope with sort.

    Coercion eqType : type >-> Equality.type.
    Canonical eqType.
    Coercion choiceType : type >-> Choice.type.
    Canonical choiceType.
    Coercion countType : type >-> Countable.type.
    Canonical countType.
    Coercion finType : type >-> Finite.type.
    Canonical finType.
    Coercion zmodType : type >-> GRing.Zmodule.type.
    Canonical zmodType.
    Coercion finZmodType : type >-> FinRing.Zmodule.type.
    Canonical finZmodType.
    Coercion ringType : type >-> GRing.Ring.type.
    Canonical ringType.
    Coercion finRingType : type >-> FinRing.Ring.type.
    Canonical finRingType.
    Coercion comRingType : type >-> GRing.ComRing.type.
    Canonical comRingType.
    Coercion finComRingType : type >-> FinRing.ComRing.type.
    Canonical finComRingType.
    Coercion unitRingType : type >-> GRing.UnitRing.type.
    Canonical unitRingType.
    Coercion finUnitRingType : type >-> FinRing.UnitRing.type.
    Canonical finUnitRingType.
    Coercion comUnitRingType : type >-> GRing.ComUnitRing.type.
    Canonical comUnitRingType.
    Coercion finComUnitRingType : type >-> FinRing.ComUnitRing.type.
    Canonical finComUnitRingType.
    Coercion idomainType : type >-> GRing.IntegralDomain.type.
    Canonical idomainType.
    Coercion finIdomainType : type >-> FinRing.IntegralDomain.type.
    Canonical finIdomainType.
    Coercion fieldType : type >-> GRing.Field.type.
    Canonical fieldType.
    Coercion finFieldType : type >-> FinRing.Field.type.
    Canonical finFieldType.
    Coercion ecuFieldType : type >-> ECUFieldType.type.
    Canonical ecuFieldType.

    Canonical fieldType.
    Canonical join_finType.
    Canonical join_finZmodType.
    Canonical join_finRingType.
    Canonical join_finComRingType.
    Canonical join_finUnitRingType.
    Canonical join_finComUnitRingType.
    Canonical join_finIdomainType.
    Canonical join_finFieldType.

    Notation finECUFieldType := ECUFinField.type.

    Notation "[ 'finECUFieldType' 'of' T ]" := (do_pack pack T)
      (at level 0, format "[ 'finECUFieldType'  'of'  T ]") : form_scope.

    Canonical baseFinGroupType.
    Canonical finGroupType.
    Canonical join_baseFinGroupType.
    Canonical join_finGroupType.
  End Exports.
End ECUFinField.

Export ECUFinField.Exports.

(* -------------------------------------------------------------------- *)
Module ECUDecFieldType.
  Section ClassDef.
    Record class_of (K : Type) := Class {
      base  : ECUFieldType.class_of K;
      mixin : GRing.DecidableField.mixin_of (GRing.UnitRing.Pack base K)
    }.

    Local Coercion base : class_of >-> ECUFieldType.class_of.

    Definition base2 F m := GRing.DecidableField.Class (@mixin F m).
    Local Coercion base2 : class_of >-> GRing.DecidableField.class_of.

    Structure type := Pack {sort; _ : class_of sort; _ : Type}.

    Local Coercion sort : type >-> Sortclass.

    Variables (T : Type) (cT : type).

    Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
    Definition clone c of phant_id class c := @Pack T c T.

    Definition pack b0 (m0 : GRing.DecidableField.mixin_of (@GRing.UnitRing.Pack T b0 T)) :=
      fun bT b  & phant_id (@ECUFieldType.class bT) b =>
      fun    m  & phant_id m0 m =>
        Pack (@Class T b m) T.

    Definition eqType             := Equality.Pack             class cT.
    Definition choiceType         := Choice.Pack               class cT.
    Definition zmodType           := GRing.Zmodule.Pack        class cT.
    Definition ringType           := GRing.Ring.Pack           class cT.
    Definition comRingType        := GRing.ComRing.Pack        class cT.
    Definition unitRingType       := GRing.UnitRing.Pack       class cT.
    Definition comUnitRingType    := GRing.ComUnitRing.Pack    class cT.
    Definition idomainType        := GRing.IntegralDomain.Pack class cT.
    Definition fieldType          := GRing.Field.Pack          class cT.
    Definition decFieldType       := GRing.DecidableField.Pack class cT.
    Definition ecuFieldType       := ECUFieldType.Pack         class cT.
  End ClassDef.

  Module Exports.
    Coercion base  : class_of >-> ECUFieldType.class_of.
    Coercion sort  : type     >-> Sortclass.

    Bind Scope ring_scope with sort.

    Coercion eqType : type >-> Equality.type.
    Canonical eqType.
    Coercion choiceType : type >-> Choice.type.
    Canonical choiceType.
    Coercion zmodType : type >-> GRing.Zmodule.type.
    Canonical zmodType.
    Coercion ringType : type >-> GRing.Ring.type.
    Canonical ringType.
    Coercion comRingType : type >-> GRing.ComRing.type.
    Canonical comRingType.
    Coercion unitRingType : type >-> GRing.UnitRing.type.
    Canonical unitRingType.
    Coercion comUnitRingType : type >-> GRing.ComUnitRing.type.
    Canonical comUnitRingType.
    Coercion idomainType : type >-> GRing.IntegralDomain.type.
    Canonical idomainType.
    Coercion fieldType : type >-> GRing.Field.type.
    Canonical fieldType.
    Coercion decFieldType : type >-> GRing.DecidableField.type.
    Canonical decFieldType.
    Coercion ecuFieldType : type >-> ECUFieldType.type.
    Canonical ecuFieldType.

    Notation ecuDecFieldType := ECUDecFieldType.type.
    Notation EcuDecFieldMixin := GRing.DecidableField.Mixin.
    Notation EcuDecFieldType T m := (@pack T _ m _ _ id _ id).

    Notation "[ 'ecuDecFieldType' 'of' T ]" := (@pack T _ _ _ id _ id)
      (at level 0, format "[ 'ecuDecFieldType'  'of'  T ]") : form_scope.
  End Exports.
End ECUDecFieldType.

Export ECUDecFieldType.Exports.

(* -------------------------------------------------------------------- *)
Record ecuType (K : ringType) := {
  cA : K;
  cB : K;
  _  : 4%:R * cA^+3 + 27%:R * cB^+2 != 0
}.

Notation "K '#a'" := (K.(cA)) (at level 30).
Notation "K '#b'" := (K.(cB)) (at level 30).

Section ECUTypeTheory.
  Variable K : ringType.
  Variable E : ecuType K.

  Lemma ecu_DN0: 4%:R * (E#a)^+3 + 27%:R * (E#b)^+2 != 0 :> K.
  Proof. by case: E. Qed.
End ECUTypeTheory.

(* -------------------------------------------------------------------- *)
Section PointDef.
  Inductive point (K : Type) : Type :=
  | EC_Inf : point K
  | EC_In  : K -> K -> point K.
End PointDef.

Section PointEq.
  Variable T : eqType.

  Local Notation point := (point T).

  Definition point_eq (p1 p2 : point) :=
    match p1, p2 with
    | EC_Inf     , EC_Inf      => true
    | EC_In x1 y1, EC_In x2 y2 => [&& (x1 == x2) & (y1 == y2)]
    | _          , _           => false
    end.

  Lemma point_eqP:
    forall (p1 p2 : point), reflect (p1 = p2) (point_eq p1 p2).
  Proof.
    move=> p1 p2; apply: (iffP idP); last first.
    + by move=> {p2} <-; case: p1 => //= *; rewrite !eqxx.
    move: p1 p2 => [|x1 y1] [|x2 y2] //=.
    by case/andP; do 2! (move/eqP=> ->).
  Qed.

  Definition point_eqMixin := EqMixin point_eqP.

  Canonical Structure point_eqType :=
    Eval hnf in (EqType _ point_eqMixin).
End PointEq.

(* -------------------------------------------------------------------- *)
Notation "∞"           := (@EC_Inf _)    (at level 8).
Notation "(| x , y |)" := (@EC_In _ x y) (at level 8, x, y at level 15).

(* -------------------------------------------------------------------- *)
Section PointChoice.
  Variable T : choiceType.

  Definition encode (p : point T) :=
    match p with
    | EC_Inf    => [::]
    | EC_In x y => [:: x; y]
    end.

  Definition decode (c : seq T) :=
    match c with
    | [::]      => Some (EC_Inf _)
    | [:: x; y] => Some (EC_In x y)
    | _         => None
    end.

  Lemma codeK : pcancel encode decode.
  Proof. by case. Qed.

  Definition point_choiceMixin := PcanChoiceMixin codeK.

  Canonical Structure point_choiceType :=
    Eval hnf in (ChoiceType _ point_choiceMixin).
End PointChoice.

(* -------------------------------------------------------------------- *)
Section PointCount.
  Variable T : countType.

  Definition pickle (p : point T) :=
    match p with
    | EC_Inf    => None
    | EC_In x y => Some (x, y)
    end.

  Definition unpickle (p : option (T * T)) :=
    match p with
    | None        => EC_Inf _
    | Some (x, y) => EC_In x y
    end.

  Definition pickleK: cancel pickle unpickle.
  Proof. by case. Qed.

  Definition point_countMixin := CanCountMixin pickleK.

  Canonical Structure point_countType :=
    Eval hnf in (CountType _ point_countMixin).
End PointCount.

(* -------------------------------------------------------------------- *)
Section PointFinType.
  Variable T : finType.

  Definition points := (EC_Inf T) :: [seq (|x.1, x.2|) | x : T*T].

  Lemma uniq_points: uniq points.
  Proof.
    rewrite /points /=; apply/andP; split.
    + by apply/memPn=> P /mapP [x _ ->].
    + rewrite map_inj_uniq ?enum_uniq //.
      by case=> [x1 y1] [x2 y2]; case => -> ->.
  Qed.

  Lemma total_points : points =i {: point T}.
  Proof.
    case=> [|x y] //; rewrite /points inE /=.
    pose xy := (x, y); have ->: (|x, y|) = (|xy.1, xy.2|) by [].
    by apply: map_f; rewrite {}/xy; apply: mem_enum.
  Qed.

  Definition point_finMixin := UniqFinMixin uniq_points total_points.
  Canonical point_finType := FinType (point T) point_finMixin.

  Lemma npoints: #|{: point T}| = (#|T|^2).+1.
  Proof.
    rewrite /= cardT enumT unlock /=.
    by rewrite size_map -cardT /= card_prod.
  Qed.
End PointFinType.

(* -------------------------------------------------------------------- *)
Section EC.
  Variable K : ringType.
  Variable E : ecuType K.

  Definition oncurve (p : point K) := (
    match p with
    | EC_Inf    => true
    | EC_In x y => y^+2 == x^+3 + E#a * x + E#b
    end).

  Inductive ec : Type := EC p of oncurve p.

  Coercion point_of_ec p := let: EC p _ := p in p.

  Canonical Structure ec_subType := [subType for point_of_ec by ec_rect].

  Definition ec_eqMixin := [eqMixin of ec by <:].
  Canonical Structure ec_eqType := Eval hnf in EqType ec ec_eqMixin.

  Definition ec_choiceMixin := [choiceMixin of ec by <:].
  Canonical Structure ec_choiceType := Eval hnf in ChoiceType ec ec_choiceMixin.

  Lemma oncurve_ec: forall p : ec, oncurve p.
  Proof. exact: valP. Qed.

  Hint Resolve oncurve_ec.
End EC.

Notation "[ 'oc' 'of' p ]" := (oncurve_ec p).

(* -------------------------------------------------------------------- *)
Section ECCountType.
  Variable K : finRingType.
  Variable E : ecuType K.

  Definition ec_countMixin := [countMixin of (ec_subType E) by <:].
  Canonical Structure ec_countType := Eval hnf in CountType (ec E) ec_countMixin.

  Canonical ec_subCountType := Eval hnf in [subCountType of ec E].
End ECCountType.

(* -------------------------------------------------------------------- *)
Section ECFinType.
  Variable K : finFieldType.
  Variable E : ecuType K.

  Local Notation ec := (@ec K E).

  Definition ec_finMixin := [finMixin of ec by <:].
  Canonical ec_finType := Eval hnf in (FinType ec ec_finMixin).
End ECFinType.

(* -------------------------------------------------------------------- *)
Section XPoly.
  Variable K : ringType.
  Variable E : ecuType K.

  Local Notation a := (E#a).
  Local Notation b := (E#b).

  Definition Xpoly := locked (Poly [:: b; a; 0; 1]).

  Lemma size_Xpoly : size Xpoly = 4.
  Proof.
    by unlock Xpoly; rewrite (@PolyK _ 0) //= oner_neq0.
  Qed.

  Lemma XpolyE: Xpoly = 'X^3 + a *: 'X + b%:P.
  Proof.
    apply/polyP=> i; unlock Xpoly; rewrite (@PolyK _ 0) //= ?oner_neq0 //.
    rewrite !coef_add_poly coefXn coefC coefZ coefX; move: i.
    by do 5! (case; first by rewrite !simp); move=> ?; rewrite /= !simp.
  Qed.

  Lemma XpolyN0: Xpoly != 0.
  Proof. by rewrite -size_poly_eq0 size_Xpoly. Qed.

  Lemma horner_Xpoly:
    forall x, Xpoly.[x] = x ^+ 3 + a * x + b.
  Proof. by move=> x; rewrite XpolyE !(hornerXn, hornerE). Qed.

  Lemma Xpoly_oncurve c:
    (root Xpoly c) = oncurve E (|c, 0|).
  Proof.
    by rewrite rootE horner_Xpoly /= expr2 mulr0 eq_sym.
  Qed.

  Lemma oncurve_root x y: oncurve E (|x, y|) = root ('X ^+ 2 - (Xpoly.[x])%:P) y.
  Proof.
    by rewrite rootE !(hornerE, hornerXn, horner_Xpoly) subr_eq0.
  Qed.

  Lemma Xpoly_monic: Xpoly \is monic.
  Proof.
    apply/monicP; unlock lead_coef Xpoly.
    by rewrite !(PolyK (c := 0)) //= oner_eq0.
  Qed.

  Lemma map_XpolyE (rT : ringType) (f : {rmorphism K -> rT}):
    map_poly f Xpoly = 'X^3 + (f (E#a)) *: 'X + (f (E#b))%:P.
  Proof.
    pose rwE := (rmorphD, map_polyC, map_polyZ, map_polyXn, map_polyX).
    by rewrite XpolyE; do! rewrite !rwE /=.
  Qed.
End XPoly.

(* -------------------------------------------------------------------- *)
Module ECGroup.
  Section Defs.
    Variable K : ecuFieldType.
    Variable E : ecuType K.

    Local Notation Xpoly := (@Xpoly _ E).

    Lemma eqrN_eq0 (y : K): (y == -y) = (y == 0).
    Proof.
      rewrite -addr_eq0 -{1 2}[y]mul1r -mulrDl.
      by rewrite mulf_eq0 (negbTE (ecu_chi2 K)).
    Qed.

    Definition neg (p : point K) :=
      if p is (|x, y|) then (|x, -y|) else ∞.

    Definition add (p1 p2 : point K) :=
      let p1 := if oncurve E p1 then p1 else ∞ in
      let p2 := if oncurve E p2 then p2 else ∞ in

        match p1, p2 with
        | ∞, _ => p2 | _, ∞ => p1

        | (|x1, y1|), (|x2, y2|) =>
          if   x1 == x2
          then if   (y1 == y2) && (y1 != 0)
               then
                 let s  := (3%:R * x1^+2 + E#a) / (2%:R * y1) in
                 let xs := s^+2 - 2%:R * x1 in
                   (| xs, - s * (xs - x1) - y1 |)
               else
                 ∞
          else
            let s  := (y2 - y1) / (x2 - x1) in
            let xs := s^+2 - x1 - x2 in
              (| xs, - s * (xs - x1) - y1 |)
        end.

    Lemma zeroO : oncurve E ∞.
    Proof. by []. Qed.

    Lemma negO : forall p, oncurve E p -> oncurve E (neg p).
    Proof. by case=> [|x y] //=; rewrite sqrrN. Qed.

    Lemma oncurveN p: (oncurve E p) = (oncurve E (neg p)).
    Proof.
      apply/idP/idP; move/negO => //.
      by case: p => [|x y] //=; rewrite opprK.
    Qed.

    Lemma oncurveN_fin x y: oncurve E (|x, -y|) = oncurve E (|x, y|).
    Proof. by move: (oncurveN (|x, y|)). Qed.

    Local Notation sizep := (size : {poly _} -> _).

    Definition line (p q : K * K) : K * K * K :=
      let: (x1, y1) := p in
      let: (x2, y2) := q in

      match oncurve E (|x1, y1|) && oncurve E (|x2, y2|) with
      | false => (0, 0, 0)
      | true  =>
          if   x1 == x2
          then if   (y1 == y2) && (y1 != 0)
               then
                 let s := (3%:R * x1^+2 + E#a) / (2%:R * y1) in
                   (1, -s, y2 - s * x2)
               else
                 (0, 1, x1)
          else
            let s := (y2 - y1) / (x2 - x1) in
              (1, -s, y2 - s * x2)
      end.

    Definition ladd (p1 p2 : point K) :=
      let p1 := if oncurve E p1 then p1 else ∞ in
      let p2 := if oncurve E p2 then p2 else ∞ in

        match p1, p2 with
        | ∞, _ => neg p2 | _, ∞ => neg p1
        | (|x1, y1|), (|x2, y2|) =>
            let: (u, v, c) := line (x1, y1) (x2, y2) in
              if u == 0 then ∞ else
                let: x := u^-2 * v ^+ 2 - (x1 + x2) in
                let: y := u^-1 * (c - v * x) in
                  (|x, y|)
        end.

    Lemma ladd_addE p q: ladd p q = neg (add p q).
    Proof.
      rewrite /ladd /add;
        set pp := if oncurve E p then _ else _;
        set qq := if oncurve E q then _ else _.
      have oncve_pp: oncurve E pp by rewrite {}/pp; case h: (oncurve E p).
      have oncve_qq: oncurve E qq by rewrite {}/qq; case h: (oncurve E q).
      move: {p q} pp oncve_pp qq oncve_qq.
      case=> [|x1 y1] oncve_1 [|x2 y2] oncve_2 //.
      rewrite /line oncve_1 oncve_2 /=.
      case: (x1 =P x2); first (case: andP; first last).
      + by move=> _ _; rewrite eqxx.
      + case=> /eqP <- nz_y1 <-; rewrite oner_eq0.
        rewrite !(simp, expr1n, invr1, opprD, opprK) /=.
        by set s := ((_ + E#a) / _); congr (|_, _|); ssring.
      + move/eqP => ne_x1x2; rewrite oner_eq0.
        rewrite !(simp, expr1n, invr1, opprD, opprK) /=.
        set s := (y2 - y1) / _; congr (|_, _|); first by ssring.
        set l := (y2 - _ - _); set r := - _.
          have {l}->: l = s^+3 - s * (x1 + x2) + (y2 - s * x2) by ssring.
          have {r}->: r = s^+3 - s * (x1 + x2) + (y1 - s * x1) by ssring.
        have nz_x2Bx1: x2 - x1 != 0 by rewrite subr_eq0 eq_sym.
        congr (_ + _); apply/(@mulfI _ (x2 - x1)) => //.
        by rewrite !mulrBr !mulrA [_ / _]mulrAC divff // !simp; ssring.
    Qed.

    Lemma line_outcveE p q:
         ~~ (oncurve E (|p.1, p.2|) && oncurve E (|q.1, q.2|))
      -> line p q = (0, 0, 0).
    Proof. by case: p q => [x1 y1] [x2 y2]; rewrite /line => /negbTE ->. Qed.

    Lemma line_sym p q: line p q = line q p.
    Proof.
      case: p q => [x1 y1] [x2 y2]; rewrite /line;
        have [oncve_1 | outcve_1] := (boolP (oncurve E (|x1, y1|)));
        have [oncve_2 | outcve_2] := (boolP (oncurve E (|x2, y2|))) => //=.
      rewrite ![x2==_]eq_sym; case: (x1 =P x2) => [<-|/eqP ne_x1x2]; last first.
        rewrite -![y2 - y1]opprB -![x2 - x1]opprB !invrN !mulrNN.
        congr (_, _, _); rewrite [X in _-X=_]mulrAC [X in _=_-X]mulrAC.
        rewrite -[X in X+_=_]divr1 -[X in _=X+_]divr1 -!mulNr.
        rewrite !addf_div ?(oner_neq0, subr_eq0, ne_x1x2) // !simp.
        by congr (_ / _); rewrite !opprB !(mulrDl, mulrDr); ssring.
      rewrite ![y2==_]eq_sym; case: (y1 =P y2) => [<-|/eqP ne_y1y2] => //=.
      by rewrite [0==y1]eq_sym; have [->|->] := (eqVneq y1 0); rewrite ?eqxx.
    Qed.

    Lemma line_okl p q:
      let: (u, v, c) := line p q in
        u * p.2 + v * p.1 - c = 0.
    Proof.
      case: p q => [x1 y1] [x2 y2]; rewrite /line;
        have [oncve_1 | outcve_1] := (boolP (oncurve E (|x1, y1|)));
        have [oncve_2 | outcve_2] := (boolP (oncurve E (|x2, y2|)));
          rewrite ?(simp, oppr0) //=.
      case: (x1 =P x2) => [<-|/eqP ne_x1x2]; last first.
        rewrite !simp /= mulNr ![_ / _ * _]mulrAC opprD opprK !addrA.
        rewrite [_-y2]addrAC -!addrA -mulNr -mulrDl !addrA.
        rewrite -[y1-y2]divr1 addf_div ?(oner_eq0, subr_eq0) 1?eq_sym //.
        apply/eqP; rewrite !simp /=.
        rewrite mulf_eq0 invr_eq0 orbC subr_eq0 eq_sym (negbTE ne_x1x2) /=.
        by apply/eqP; ssring.
      case: (y1 =P y2) => [<-|/eqP ne_y1y2] /=; last by rewrite !simp subrr.
      have [->|nz_y1] := eqVneq y1 0; first by rewrite eqxx /= !simp subrr.
      by rewrite nz_y1 !simp; ssring.
    Qed.

    Lemma line_okr p q:
      let: (u, v, c) := line p q in
        u * q.2 + v * q.1 - c = 0.
    Proof. by rewrite line_sym; apply: line_okl. Qed.

    Lemma thdimp p q:
      let: (u, v, c) := line p q in
      let: r := Xpoly - (u^-1 *: (v *: 'X - c%:P)) ^+ 2 in
      let: z := u ^- 2 * v ^+ 2 - (p.1 + q.1) in
        u != 0 -> r = ('X - p.1%:P) * ('X - q.1%:P) * ('X - z%:P).
    Proof.
      set pp := (|p.1, p.2|); set qq := (|q.1, q.2|).
      case: (boolP (oncurve E pp && oncurve E qq)); last first.
        by move/line_outcveE=> ->; rewrite eqxx.
      case/andP=> oncve_p oncve_q; case lE: (line p q) => [[u v] c].
      move=> nz_u; set r := (Xpoly - _);
        set c0 := E#b - u^-2 * c^+2;
        set c1 := E#a + (u^-2 * v * c) *+ 2;
        set c2 := - u^-2 * v^+2;
          have Er: r = Poly [:: c0; c1; c2; 1].
      + apply/polyP=> i; unlock Xpoly; rewrite (@PolyK _ 0) //= ?oner_neq0 //.
        pose coefE := (coefMC, coefCM, coefE).
        rewrite /r XpolyE !(exprZn, sqrrB) !coefE; move: i.
        do 4! (case; first by rewrite !(simp, oppr0, exprVn, eqxx) //=; ssring).
        by move=> i; rewrite !(simp, oppr0, exprVn, eqxx) /= nth_nil.
      have sz_r: size r = 4 by rewrite Er (@PolyK _ 0) // oner_eq0.
      have nz_r: r != 0 by rewrite -size_poly_eq0 sz_r.
      have monic_r: r \is monic.
        apply/monicP; rewrite Er lead_coefE -{2}Er sz_r.
        by rewrite (@PolyK _ 0) // oner_neq0.
      have root_pVq: forall s, (s == p) || (s == q) -> root r s.1.
        move=> s eq_s_pq; have oncve_s: oncurve E (|s.1, s.2|).
          by case/orP: eq_s_pq => /eqP ->.
        have: u * s.2 + v * s.1 - c = 0.
          case/orP: eq_s_pq => /eqP->.
          + by move: (line_okl p q); rewrite lE.
          + by move: (line_okr p q); rewrite lE.
        move/eqP; rewrite -addrA addrC addr_eq0 => /eqP vsBcE.
        rewrite rootE /r !(horner_exp, hornerE) /= vsBcE.
        rewrite !mulrN sqrrN mulrA mulVf // mul1r.
        by rewrite horner_Xpoly -(eqP oncve_s) subrr.
      have h: forall x, count (pred1 x) [:: p.1; q.1] <= \mu_x r.
        move=> x /=; rewrite addn0; case: (p.1 =P x); last first.
          move/eqP=> ne_p1x; rewrite add0n; case: (q.1 =P x) => //=.
          move=> <-; rewrite mu_gt0 //; apply: root_pVq.
          by rewrite eqxx orbT.
        move=> /esym Exp; case: (q.1 =P x); last first.
          move/eqP=> ne_q1x; rewrite addn0 /= mu_gt0 // Exp.
          by apply: root_pVq; rewrite eqxx.
        move=> /esym Exq /=; rewrite addn1; move: lE.
        have pairE: forall x, (x.1, x.2) = x by move=> ?? [].
        rewrite /line -[p]pairE -[q]pairE {pairE} oncve_p oncve_q /=.
        rewrite -Exp -Exq eqxx /=; case: andP; last first.
          by move=> _ [/esym z_u _ _]; rewrite z_u eqxx in nz_u.
        case=> [/eqP eq_p2q2 nz_q2] [/esym one_u /esym Ev /esym Ec].
        apply: ltn_pred; rewrite /= -subn1 -mu_deriv_char; first last.
        + by rewrite Exp; apply: root_pVq; rewrite eqxx.
        + rewrite sz_r; case => [|[|[|[|i]]]] // _.
          * by rewrite inE /= ecu_chi2.
          * by rewrite inE /= ecu_chi3.
        rewrite mu_gt0; last first.
          rewrite Er /deriv -{1}Er sz_r -size_poly_eq0.
          by rewrite polyseq_poly // (@PolyK _ 0) //= ?(oner_neq0, ecu_chi3).
        rewrite rootE /deriv /horner sz_r polyseq_poly; last first.
          by rewrite Er (@PolyK _ 0) ?(oner_neq0, ecu_chi3).
        rewrite Er (@PolyK _ 0) ?oner_eq0 //= mul0r add0r mulr1n.
        rewrite /c2 /c1 one_u expr1n invr1 !(mul1r, mulN1r).
        set w := (_ + _ : K); pose k := (3%:R * x^+2 + E#a).
        have {w} ->: w = k - 2%:R * x * v^+2 + 2%:R * (c * v) by ssring.
        pose w := (2%:R * p.2); apply/eqP/(@mulIf _ (w^+2)).
          by rewrite expf_neq0 // mulf_neq0 // ecu_chi2.
        rewrite mul0r 2!mulrDl !mulNr.
        have ->:  2%:R * (c * v) * w ^+ 2 = 2%:R * (c * w) * (v * w) by ssring.
        have ->: (2%:R * x * v ^+ 2) * w ^+ 2 = 2%:R * x * (v * w)^+2 by ssring.
        have ->: v * w = - (3%:R * x ^+ 2 + E #a).
          rewrite Ev /w -mulNr -mulrA mulVf ?mulr1 //.
          by rewrite mulf_neq0 // ecu_chi2.
        have ->: c * w = q.2 * w - (3%:R * x ^+ 2 + E #a) * x.
          rewrite Ec /w mulrBl; congr (_ - _); rewrite mulrAC.
          congr (_ * _); rewrite -mulrA mulVf ?mulr1 //.
          by rewrite mulf_neq0 // ecu_chi2.
        by rewrite -eq_p2q2 {}/w {}/k Exp; ssring.
      have: ('X - p.1%:P) * ('X - q.1%:P) %| r.
        move: (@roots_dvdp _ r [:: p.1; q.1]).
        rewrite !big_cons big_nil mulr1; apply.
        by apply/allP=> x _; rewrite inE; apply: h.
      case/dvdpP=> qr Er'; have/(congr1 sizep) := Er'.
      have := nz_r; rewrite {1}Er' mulf_eq0 => /norP [nz_qr _].
      rewrite sz_r !size_mul // ?(mulf_neq0, polyXsubC_eq0) //.
      rewrite !size_XsubC /= addn3 /=; case=> /esym/eqP.
      case/size_polyf2P=> k; rewrite eqp_monic ?monicXsubC //; last first.
        by move: monic_r; rewrite Er' !(monicMr, monicXsubC) //.
      move/eqP=> Eqr {nz_qr}; move: Er'; rewrite {}Eqr => Er'.
      have/(congr1 (fun (x : {poly K})=> x`_2)) := Er'.
      set cs := [tuple k; p.1; q.1]; move/esym/eqP: (mroots_sum cs).
      rewrite 3!big_cons big_nil mulr1 eqr_oppLR => /eqP->.
      rewrite {1}Er (@PolyK _ 0) ?oner_neq0 // unlock /= !simp /=.
      move=> Ec2; have: k = - (c2 + p.1 + q.1) by rewrite Ec2; ssring.
      move=> Ek; move: Er'; rewrite Ek=> ->.
      rewrite !mulrA [X in _ = X]mulrC !mulrA; congr (_ * _ * _).
      by rewrite -!polyC_opp opprK /c2; congr ('X + _%:P); ssring.
    Qed.

    Lemma negK: involutive neg.
    Proof. by case=> [|x y] //=; rewrite opprK. Qed.

    Lemma addO p q: oncurve E (add p q).
    Proof.
      rewrite oncurveN -ladd_addE /ladd;
        set pp := if oncurve E p then _ else _;
        set qq := if oncurve E q then _ else _.
      have oncve_pp: oncurve E pp by rewrite {}/pp; case h: (oncurve E p).
      have oncve_qq: oncurve E qq by rewrite {}/qq; case h: (oncurve E q).
      move: {p q} pp oncve_pp qq oncve_qq.
      case=> [|x1 y1] oncve_1 [|x2 y2] oncve_2; rewrite -?oncurveN //.
      case h: (line _ _) => [[u v] c]; case: (u =P 0) => //.
      move/eqP=> nz_u; set z := u ^- 2 * v ^+ 2 - (x1 + x2).
      move: (thdimp (x1, y1) (x2, y2)); rewrite h => /(_ nz_u) /=.
      move/(congr1 (fun p => p.[z]))/esym; rewrite -/z.
      rewrite hornerM hornerXsubC subrr mulr0 => /esym/eqP.
      rewrite 2!hornerE subr_eq0 horner_Xpoly => /eqP->.
      apply/eqP; rewrite -mul_polyC !(horner_exp, hornerE) /=.
      by rewrite !exprMn; congr (_ * _); rewrite -[c-_]opprK opprB sqrrN.
    Qed.

    Lemma add0o : {in (oncurve E), left_id ∞ add}.
    Proof.
      move=> p; rewrite /in_mem /= => oncve_p.
      by rewrite /add /= oncve_p.
    Qed.

    Lemma addNo : left_inverse ∞ neg add.
    Proof.
      move=> p; rewrite /add -oncurveN.
      have [|] := (boolP (oncurve E p)) => // _.
      case: p=> [|x y] //=; rewrite eqxx /= eq_sym; case Hy0: (y == 0).
      + by rewrite (eqP Hy0) oppr0 eqxx //.
      + rewrite oppr_eq0 Hy0 andbT; case HyN: (y == -y) => //=.
        by absurd false=> //; rewrite -Hy0 -eqrN_eq0 HyN.
    Qed.

    Lemma addoC : commutative add.
    Proof.
      move=> p1 p2; rewrite /add;
        have [|] := (boolP (oncurve E p1)) => // _;
        have [|] := (boolP (oncurve E p2)) => // _; first last.
      + by case: p2.
      + by case: p1.
      case: p1 p2 => [|x1 y1] [|x2 y2] //=.
      rewrite [x2 == _]eq_sym [y2 == _]eq_sym.
      case Ex: (x1 == x2); first (case Ey: (y1 == y2)) => //=.
      + by rewrite -(eqP Ey) -(eqP Ex); case Ey0: (y1 == 0).
      + congr (| _, _ |); first (rewrite -!addrA; congr (_^+2 + _)).
        * by rewrite -[y2 - _]opprB -[x2 - _]opprB invrN mulrNN.
        * by rewrite addrC.
      rewrite -[y2 - _]opprB -[x2 - _]opprB invrN mulrNN.
      set Dx := (x1 - x2); set Dy := (y1 - y2); set a := Dy / Dx.
      have HDx: Dx != 0 by apply/negP; rewrite subr_eq0 Ex.
      rewrite !mulrDr -!addrA; congr (-a * a ^+ 2 + _); rewrite !mulrNN.
      rewrite ![a * x1 + _]addrCA; congr (_ + (_ + _)).
      rewrite ![a * _]mulrC /a !mulrA -[y1]mul1r -[y2]mul1r.
      rewrite -[1](divff HDx) ![Dx / Dx * _]mulrAC.
      rewrite -!mulrBl; congr (_ / _).
      rewrite /Dx /Dy !mulrDl !mulrDr !mulNr !mulrN.
      rewrite !opprB !addrA [_ - (_ * y1)]addrC !addrA addNr add0r.
      symmetry; rewrite -[_ - _ + _]addrA addNr addr0.
      by rewrite addrC.
    Qed.

    Notation   zeroec := (EC zeroO).
    Definition negec  := [fun p     : ec E => EC (negO [oc of p])].
    Definition addec  := [fun p1 p2 : ec E => EC (addO p1 p2)].

    Lemma addNe : left_inverse zeroec negec addec.
    Proof. by move=> [p Hp]; apply/eqP; rewrite eqE /= addNo. Qed.

    Lemma add0e : left_id zeroec addec.
    Proof. by move=> [p Hp]; apply/eqP; rewrite eqE /= add0o. Qed.

    Lemma addeC : commutative addec.
    Proof.
      move=> [p1 Hp1] [p2 Hp2]; apply/eqP=> /=.
      by rewrite eqE /= addoC.
    Qed.
  End Defs.
End ECGroup.

Local Notation "\- x" := (@ECGroup.neg _ x).

(* -------------------------------------------------------------------- *)
Section ECGroupTheory.
  Variable K : ecuFieldType.
  Variable E : ecuType K.

  Lemma oncurveN p: (oncurve E p) = (oncurve E (\- p)).
  Proof. by apply: ECGroup.oncurveN. Qed.

  Lemma oncurveN_fin x y: oncurve E (|x, -y|) = oncurve E (|x, y|).
  Proof. by apply: ECGroup.oncurveN_fin. Qed.
End ECGroupTheory.

(* -------------------------------------------------------------------- *)
Section ECTheory.
  Variable K : idomainType.
  Variable E : ecuType K.

  Local Notation a := (E#a).
  Local Notation b := (E#b).

  Lemma smooth : forall x, \mu_x (Xpoly E) <= 1.
  Proof.
    move=> x; rewrite leqNgt -root_le_mu ?XpolyN0 //.
    apply/negP; case/Pdiv.IdomainMonic.dvdpP.
    + by rewrite monic_exp ?monicXsubC.
    move=> /= p Hfactor; move: (congr1 (size : {poly _} -> _) Hfactor).
    have HpN0: p != 0.
    + by apply/negP => /eqP Hp; move/eqP: Hfactor;
        rewrite Hp mul0r (negbTE (XpolyN0 _)).
    rewrite size_Xpoly size_proper_mul; last first.
    + rewrite mulf_neq0 // lead_coef_eq0 //.
      by rewrite expf_neq0 ?polyXsubC_eq0.
    rewrite size_exp_XsubC addnC /=; case/esym; case/polyseq2.
    move=> [p2 p1] /= Hp1N0 Ep; move/polyP: Hfactor => EC.
    + move: (EC 3); unlock Xpoly; rewrite coef_Poly coefM.
      rewrite !big_ord_recr /= big_ord0 add0r Ep sqpp_sub_polyseq /=.
      rewrite !simp => Ep1; rewrite -!Ep1 in Ep => {Ep1 Hp1N0}.
    + move: (EC 2); unlock Xpoly; rewrite coef_Poly coefM.
      rewrite !big_ord_recr /= big_ord0 add0r Ep sqpp_sub_polyseq /=.
      rewrite !simp => /esym /eqP; rewrite subr_eq0=> /eqP Ep2.
      rewrite Ep2 in Ep => {Ep2}.
    + move: (EC 1%N); unlock Xpoly; rewrite coef_Poly coefM.
      rewrite !big_ord_recr /= big_ord0 add0r Ep sqpp_sub_polyseq /=.
      rewrite mul1r -mulrN mulrCA 2!mulrA -natrM /=.
      rewrite mulrN -mulrA -expr2; move/(congr1 -%R).
      rewrite opprD opprK -{2}[x^+2]mul1r -mulrBl.
      rewrite -(@natrB _ _ 1) //; move/(congr1 -%R); rewrite opprK=> Ea.
    + move: (EC 0%N); unlock Xpoly; rewrite coef_Poly coefM.
      rewrite !big_ord_recr /= big_ord0 add0r Ep sqpp_sub_polyseq /=.
      rewrite -mulrA -exprS => Eb.
    move: (ecu_DN0 E).
    rewrite Ea Eb exprNn exprMn -exprM -signr_odd expr1.
    rewrite mulN1r mulrN -natrX mulrA -natrM.
    rewrite exprMn -exprM -natrX [27%:R * _]mulrA -natrM.
    by rewrite addrC subrr eqxx.
  Qed.
End ECTheory.

(* -------------------------------------------------------------------- *)
Section XPolyClosed.
  Variable K : ecuDecFieldType.
  Variable E : ecuType K.

  Hypothesis closedK : GRing.ClosedField.axiom K.

  Local Notation clK := (ClosedFieldType K closedK).

  Lemma Xpoly_factor:
    exists2 cs : 3.-tuple K,
      (uniq cs) & Xpoly E = \prod_(c <- cs) ('X - c%:P).
  Proof.
    move: (PolyClosed.roots_factor_theorem_f closedK (Xpoly E)).
    rewrite (monicP (Xpoly_monic E)) scale1r; set cs := roots _ => ->.
    have size_cs: size cs == 3 by rewrite (@roots_size clK) size_Xpoly.
    exists (Tuple size_cs)=> //=; apply: count_mem_uniq.
    move=> k; rewrite -roots_mu ?XpolyN0 //; move: (smooth E k).
    rewrite leq_eqVlt ltnS leqn0 rootsP ?XpolyN0 // mem_root -rootE.
    by rewrite -mu_gt0 ?XpolyN0 //; case/orP=> /eqP->.
  Qed.
End XPolyClosed.


Require Import Raft.

Require Import CommonDefinitions.

Section SortedInterface.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition logs_sorted_host net :=
    forall h,
      sorted (log (nwState net h)).

  Definition logs_sorted_nw net :=
    forall p t n prevT prevI entries c,
      In p (nwPackets net) ->
      (pBody p) = AppendEntries t n prevT prevI entries c ->
      sorted entries.

  Definition packets_gt_prevIndex net :=
    forall p t n pli plt entries c e,
      In p (nwPackets net) ->
      (pBody p) = AppendEntries t n pli plt entries c ->
      In e entries ->
      eIndex e > pli.

  Definition packets_ge_prevTerm net :=
    forall p t n pli plt entries c e,
      In p (nwPackets net) ->
      (pBody p) = AppendEntries t n pli plt entries c ->
      In e entries ->
      eTerm e >= plt.

  Definition logs_sorted net :=
    logs_sorted_host net /\ logs_sorted_nw net /\
    packets_gt_prevIndex net /\ packets_ge_prevTerm net.

  Class sorted_interface : Prop :=
    {
      handleAppendEntries_logs_sorted :
        forall net p t n pli plt es ci st' m,
          raft_intermediate_reachable net ->
          logs_sorted net ->
          handleAppendEntries (pDst p) (nwState net (pDst p)) t n pli plt es ci =
          (st', m) ->
          pBody p = AppendEntries t n pli plt es ci ->
          In p (nwPackets net) ->
          sorted (log st');
      handleClientRequest_logs_sorted :
        forall h client id c out st l net,
          handleClientRequest h (nwState net h) client id c = (out, st, l) ->
          raft_intermediate_reachable net ->
          logs_sorted_host net ->
          sorted (log st);
      logs_sorted_invariant :
        forall net,
          raft_intermediate_reachable net ->
          logs_sorted net
    }.
End SortedInterface.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Abstract domain for neededness analysis *)

Require Import Coqlib.
Require Import Maps.
Require Import IntvSets.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Events.
Require Import Lattice.
Require Import Registers.
Require Import ValueDomain.
Require Import Op.
Require Import RTL.

(** * Neededness for values *)

Inductive nval : Type :=
  | Nothing              (**r value is entirely unused *)
  | I (m: int)           (**r only need the bits that are 1 in [m] *)
  | All.                 (**r every bit of the value is used *)

Definition eq_nval (x y: nval) : {x=y} + {x<>y}.
Proof.
  decide equality. apply Int.eq_dec.
Defined.

(** ** Agreement between two values relative to a need. *)

Definition iagree (p q mask: int) : Prop :=
  forall i, 0 <= i < Int.zwordsize -> Int.testbit mask i = true ->
            Int.testbit p i = Int.testbit q i.

Fixpoint vagree (v w: val) (x: nval) {struct x}: Prop :=
  match x with
  | Nothing => True
  | I m =>
      match v, w with
      | Vint p, Vint q => iagree p q m
      | Vint p, _ => False
      | _, _ => True
      end
  | All => Val.lessdef v w
  end.

Lemma vagree_same: forall v x, vagree v v x.
Proof.
  intros. destruct x; simpl; auto; destruct v; auto. red; auto.
Qed.

Lemma vagree_lessdef: forall v w x, Val.lessdef v w -> vagree v w x.
Proof.
  intros. inv H. apply vagree_same. destruct x; simpl; auto.
Qed.

Lemma lessdef_vagree: forall v w, vagree v w All -> Val.lessdef v w.
Proof.
  intros. simpl in H. auto.
Qed.

Hint Resolve vagree_same vagree_lessdef lessdef_vagree: na.

Inductive vagree_list: list val -> list val -> list nval -> Prop :=
  | vagree_list_nil: forall nvl,
      vagree_list nil nil nvl
  | vagree_list_default: forall v1 vl1 v2 vl2,
      vagree v1 v2 All -> vagree_list vl1 vl2 nil ->
      vagree_list (v1 :: vl1) (v2 :: vl2) nil
  | vagree_list_cons: forall v1 vl1 v2 vl2 nv1 nvl,
      vagree v1 v2 nv1 -> vagree_list vl1 vl2 nvl ->
      vagree_list (v1 :: vl1) (v2 :: vl2) (nv1 :: nvl).

Lemma lessdef_vagree_list:
  forall vl1 vl2, vagree_list vl1 vl2 nil -> Val.lessdef_list vl1 vl2.
Proof.
  induction vl1; intros; inv H; constructor; auto with na.
Qed.

Lemma vagree_lessdef_list:
  forall vl1 vl2, Val.lessdef_list vl1 vl2 -> forall nvl, vagree_list vl1 vl2 nvl.
Proof.
  induction 1; intros.
  constructor.
  destruct nvl; constructor; auto with na.
Qed.

Hint Resolve lessdef_vagree_list vagree_lessdef_list: na.

(** ** Ordering and least upper bound between value needs *)

Inductive nge: nval -> nval -> Prop :=
  | nge_nothing: forall x, nge All x
  | nge_all: forall x, nge x Nothing
  | nge_int: forall m1 m2,
      (forall i, 0 <= i < Int.zwordsize -> Int.testbit m2 i = true -> Int.testbit m1 i = true) ->
      nge (I m1) (I m2).

Lemma nge_refl: forall x, nge x x.
Proof.
  destruct x; constructor; auto.
Qed.

Hint Constructors nge: na.
Hint Resolve nge_refl: na.

Lemma nge_trans: forall x y, nge x y -> forall z, nge y z -> nge x z.
Proof.
  induction 1; intros w VG; inv VG; eauto with na.
Qed.

Lemma nge_agree:
  forall v w x y, nge x y -> vagree v w x -> vagree v w y.
Proof.
  induction 1; simpl; auto.
- destruct v; auto with na.
- destruct v, w; intuition. red; auto.
Qed.

Definition nlub (x y: nval) : nval :=
  match x, y with
  | Nothing, _ => y
  | _, Nothing => x
  | I m1, I m2 => I (Int.or m1 m2)
  | _, _ => All
  end.

Lemma nge_lub_l:
  forall x y, nge (nlub x y) x.
Proof.
  unfold nlub; destruct x, y; auto with na.
  constructor. intros. autorewrite with ints; auto. rewrite H0; auto.
Qed.

Lemma nge_lub_r:
  forall x y, nge (nlub x y) y.
Proof.
  unfold nlub; destruct x, y; auto with na.
  constructor. intros. autorewrite with ints; auto. rewrite H0. apply orb_true_r; auto.
Qed.

(** ** Properties of agreement between integers *)

Lemma iagree_refl:
  forall p m, iagree p p m.
Proof.
  intros; red; auto.
Qed.

Remark eq_same_bits:
  forall i x y, x = y -> Int.testbit x i = Int.testbit y i.
Proof.
  intros; congruence.
Qed.

Lemma iagree_and_eq:
  forall x y mask,
  iagree x y mask <-> Int.and x mask = Int.and y mask.
Proof.
  intros; split; intros.
- Int.bit_solve. specialize (H i H0).
  destruct (Int.testbit mask i).
  rewrite ! andb_true_r; auto.
  rewrite ! andb_false_r; auto.
- red; intros. exploit (eq_same_bits i); eauto; autorewrite with ints; auto.
  rewrite H1. rewrite ! andb_true_r; auto.
Qed.

Lemma iagree_mone:
  forall p q, iagree p q Int.mone -> p = q.
Proof.
  intros. rewrite iagree_and_eq in H. rewrite ! Int.and_mone in H. auto.
Qed.

Lemma iagree_zero:
  forall p q, iagree p q Int.zero.
Proof.
  intros. rewrite iagree_and_eq. rewrite ! Int.and_zero; auto.
Qed.

Lemma iagree_and:
  forall x y n m,
  iagree x y (Int.and m n) -> iagree (Int.and x n) (Int.and y n) m.
Proof.
  intros. rewrite iagree_and_eq in *. rewrite ! Int.and_assoc.
  rewrite (Int.and_commut n). auto.
Qed.

Lemma iagree_not:
  forall x y m, iagree x y m -> iagree (Int.not x) (Int.not y) m.
Proof.
  intros; red; intros; autorewrite with ints; auto. f_equal; auto.
Qed.

Lemma iagree_not':
  forall x y m, iagree (Int.not x) (Int.not y) m -> iagree x y m.
Proof.
  intros. rewrite <- (Int.not_involutive x). rewrite <- (Int.not_involutive y).
  apply iagree_not; auto.
Qed.

Lemma iagree_or:
  forall x y n m,
  iagree x y (Int.and m (Int.not n)) -> iagree (Int.or x n) (Int.or y n) m.
Proof.
  intros. apply iagree_not'. rewrite ! Int.not_or_and_not. apply iagree_and.
  apply iagree_not; auto.
Qed.

Lemma iagree_bitwise_binop:
  forall sem f,
  (forall x y i, 0 <= i < Int.zwordsize ->
       Int.testbit (f x y) i = sem (Int.testbit x i) (Int.testbit y i)) ->
  forall x1 x2 y1 y2 m,
  iagree x1 y1 m -> iagree x2 y2 m -> iagree (f x1 x2) (f y1 y2) m.
Proof.
  intros; red; intros. rewrite ! H by auto. f_equal; auto.
Qed.

Lemma iagree_shl:
  forall x y m n,
  iagree x y (Int.shru m n) -> iagree (Int.shl x n) (Int.shl y n) m.
Proof.
  intros; red; intros. autorewrite with ints; auto.
  destruct (zlt i (Int.unsigned n)).
- auto.
- generalize (Int.unsigned_range n); intros.
  apply H. omega. rewrite Int.bits_shru by omega.
  replace (i - Int.unsigned n + Int.unsigned n) with i by omega.
  rewrite zlt_true by omega. auto.
Qed.

Lemma iagree_shru:
  forall x y m n,
  iagree x y (Int.shl m n) -> iagree (Int.shru x n) (Int.shru y n) m.
Proof.
  intros; red; intros. autorewrite with ints; auto.
  destruct (zlt (i + Int.unsigned n) Int.zwordsize).
- generalize (Int.unsigned_range n); intros.
  apply H. omega. rewrite Int.bits_shl by omega.
  replace (i + Int.unsigned n - Int.unsigned n) with i by omega.
  rewrite zlt_false by omega. auto.
- auto.
Qed.

Lemma iagree_shr_1:
  forall x y m n,
  Int.shru (Int.shl m n) n = m ->
  iagree x y (Int.shl m n) -> iagree (Int.shr x n) (Int.shr y n) m.
Proof.
  intros; red; intros. rewrite <- H in H2. rewrite Int.bits_shru in H2 by auto.
  rewrite ! Int.bits_shr by auto.
  destruct (zlt (i + Int.unsigned n) Int.zwordsize).
- apply H0; auto. generalize (Int.unsigned_range n); omega.
- discriminate.
Qed.

Lemma iagree_shr:
  forall x y m n,
  iagree x y (Int.or (Int.shl m n) (Int.repr Int.min_signed)) ->
  iagree (Int.shr x n) (Int.shr y n) m.
Proof.
  intros; red; intros. rewrite ! Int.bits_shr by auto.
  generalize (Int.unsigned_range n); intros.
  set (j := if zlt (i + Int.unsigned n) Int.zwordsize
            then i + Int.unsigned n
            else Int.zwordsize - 1).
  assert (0 <= j < Int.zwordsize).
  { unfold j; destruct (zlt (i + Int.unsigned n) Int.zwordsize); omega. }
  apply H; auto. autorewrite with ints; auto. apply orb_true_intro.
  unfold j; destruct (zlt (i + Int.unsigned n) Int.zwordsize).
- left. rewrite zlt_false by omega.
  replace (i + Int.unsigned n - Int.unsigned n) with i by omega.
  auto.
- right. reflexivity.
Qed.

Lemma iagree_rol:
  forall p q m amount,
  iagree p q (Int.ror m amount) ->
  iagree (Int.rol p amount) (Int.rol q amount) m.
Proof.
  intros. assert (Int.zwordsize > 0) by (compute; auto).
  red; intros. rewrite ! Int.bits_rol by auto. apply H.
  apply Z_mod_lt; auto.
  rewrite Int.bits_ror.
  replace (((i - Int.unsigned amount) mod Int.zwordsize + Int.unsigned amount)
   mod Int.zwordsize) with i. auto.
  apply Int.eqmod_small_eq with Int.zwordsize; auto.
  apply Int.eqmod_trans with ((i - Int.unsigned amount) + Int.unsigned amount).
  apply Int.eqmod_refl2; omega.
  eapply Int.eqmod_trans. 2: apply Int.eqmod_mod; auto.
  apply Int.eqmod_add.
  apply Int.eqmod_mod; auto.
  apply Int.eqmod_refl.
  apply Z_mod_lt; auto.
  apply Z_mod_lt; auto.
Qed.

Lemma iagree_ror:
  forall p q m amount,
  iagree p q (Int.rol m amount) ->
  iagree (Int.ror p amount) (Int.ror q amount) m.
Proof.
  intros. rewrite ! Int.ror_rol_neg by apply int_wordsize_divides_modulus.
  apply iagree_rol.
  rewrite Int.ror_rol_neg by apply int_wordsize_divides_modulus.
  rewrite Int.neg_involutive; auto.
Qed.

Lemma eqmod_iagree:
  forall m x y,
  Int.eqmod (two_p (Int.size m)) x y ->
  iagree (Int.repr x) (Int.repr y) m.
Proof.
  intros. set (p := nat_of_Z (Int.size m)).
  generalize (Int.size_range m); intros RANGE.
  assert (EQ: Int.size m = Z_of_nat p). { symmetry; apply nat_of_Z_eq. omega. }
  rewrite EQ in H; rewrite <- two_power_nat_two_p in H.
  red; intros. rewrite ! Int.testbit_repr by auto.
  destruct (zlt i (Int.size m)).
  eapply Int.same_bits_eqmod; eauto. omega.
  assert (Int.testbit m i = false) by (eapply Int.bits_size_2; omega).
  congruence.
Qed.

Definition complete_mask (m: int) := Int.zero_ext (Int.size m) Int.mone.

Lemma iagree_eqmod:
  forall x y m,
  iagree x y (complete_mask m) ->
  Int.eqmod (two_p (Int.size m)) (Int.unsigned x) (Int.unsigned y).
Proof.
  intros. set (p := nat_of_Z (Int.size m)).
  generalize (Int.size_range m); intros RANGE.
  assert (EQ: Int.size m = Z_of_nat p). { symmetry; apply nat_of_Z_eq. omega. }
  rewrite EQ; rewrite <- two_power_nat_two_p.
  apply Int.eqmod_same_bits. intros. apply H. omega.
  unfold complete_mask. rewrite Int.bits_zero_ext by omega.
  rewrite zlt_true by omega. rewrite Int.bits_mone by omega. auto.
Qed.

Lemma complete_mask_idem:
  forall m, complete_mask (complete_mask m) = complete_mask m.
Proof.
  unfold complete_mask; intros. destruct (Int.eq_dec m Int.zero).
+ subst m; reflexivity.
+ assert (Int.unsigned m <> 0).
  { red; intros; elim n. rewrite <- (Int.repr_unsigned m). rewrite H; auto. }
  assert (0 < Int.size m).
  { apply Int.Zsize_pos'. generalize (Int.unsigned_range m); omega. }
  generalize (Int.size_range m); intros.
  f_equal. apply Int.bits_size_4. tauto.
  rewrite Int.bits_zero_ext by omega. rewrite zlt_true by omega.
  apply Int.bits_mone; omega.
  intros. rewrite Int.bits_zero_ext by omega. apply zlt_false; omega.
Qed.

(** ** Abstract operations over value needs. *)

Ltac InvAgree :=
  simpl vagree in *;
  repeat (
  auto || exact Logic.I ||
  match goal with
  | [ H: False |- _ ] => contradiction
  | [ H: match ?v with Vundef => _ | Vint _ => _ | Vlong _ => _ | Vfloat _ => _ | Vsingle _ => _ | Vptr _ _ => _ end |- _ ] => destruct v
  end).

(** And immediate, or immediate *)

Definition andimm (x: nval) (n: int) :=
  match x with
  | Nothing => Nothing
  | I m => I (Int.and m n)
  | All => I n
  end.

Lemma andimm_sound:
  forall v w x n,
  vagree v w (andimm x n) ->
  vagree (Val.and v (Vint n)) (Val.and w (Vint n)) x.
Proof.
  unfold andimm; intros; destruct x; simpl in *; unfold Val.and.
- auto.
- InvAgree. apply iagree_and; auto.
- InvAgree. rewrite iagree_and_eq in H. rewrite H; auto.
Qed.

Definition orimm (x: nval) (n: int) :=
  match x with
  | Nothing => Nothing
  | I m => I (Int.and m (Int.not n))
  | _ => I (Int.not n)
  end.

Lemma orimm_sound:
  forall v w x n,
  vagree v w (orimm x n) ->
  vagree (Val.or v (Vint n)) (Val.or w (Vint n)) x.
Proof.
  unfold orimm; intros; destruct x; simpl in *.
- auto.
- unfold Val.or; InvAgree. apply iagree_or; auto.
- InvAgree. simpl. apply Val.lessdef_same. f_equal. apply iagree_mone.
  apply iagree_or. rewrite Int.and_commut. rewrite Int.and_mone. auto.
Qed.

(** Bitwise operations: and, or, xor, not *)

Definition bitwise (x: nval) := x.

Remark bitwise_idem: forall nv, bitwise (bitwise nv) = bitwise nv.
Proof. auto. Qed.

Lemma vagree_bitwise_binop:
  forall f,
  (forall p1 p2 q1 q2 m,
     iagree p1 q1 m -> iagree p2 q2 m -> iagree (f p1 p2) (f q1 q2) m) ->
  forall v1 w1 v2 w2 x,
  vagree v1 w1 (bitwise x) -> vagree v2 w2 (bitwise x) ->
  vagree (match v1, v2 with Vint i1, Vint i2 => Vint(f i1 i2) | _, _ => Vundef end)
         (match w1, w2 with Vint i1, Vint i2 => Vint(f i1 i2) | _, _ => Vundef end)
         x.
Proof.
  unfold bitwise; intros. destruct x; simpl in *.
- auto.
- InvAgree.
- inv H0; auto. inv H1; auto. destruct w1; auto.
Qed.

Lemma and_sound:
  forall v1 w1 v2 w2 x,
  vagree v1 w1 (bitwise x) -> vagree v2 w2 (bitwise x) ->
  vagree (Val.and v1 v2) (Val.and w1 w2) x.
Proof (vagree_bitwise_binop Int.and (iagree_bitwise_binop andb Int.and Int.bits_and)).

Lemma or_sound:
  forall v1 w1 v2 w2 x,
  vagree v1 w1 (bitwise x) -> vagree v2 w2 (bitwise x) ->
  vagree (Val.or v1 v2) (Val.or w1 w2) x.
Proof (vagree_bitwise_binop Int.or (iagree_bitwise_binop orb Int.or Int.bits_or)).

Lemma xor_sound:
  forall v1 w1 v2 w2 x,
  vagree v1 w1 (bitwise x) -> vagree v2 w2 (bitwise x) ->
  vagree (Val.xor v1 v2) (Val.xor w1 w2) x.
Proof (vagree_bitwise_binop Int.xor (iagree_bitwise_binop xorb Int.xor Int.bits_xor)).

Lemma notint_sound:
  forall v w x,
  vagree v w (bitwise x) -> vagree (Val.notint v) (Val.notint w) x.
Proof.
  intros. rewrite ! Val.not_xor. apply xor_sound; auto with na.
Qed.

(** Shifts and rotates *)

Definition shlimm (x: nval) (n: int) :=
  match x with
  | Nothing => Nothing
  | I m => I (Int.shru m n)
  | All => I (Int.shru Int.mone n)
  end.

Lemma shlimm_sound:
  forall v w x n,
  vagree v w (shlimm x n) ->
  vagree (Val.shl v (Vint n)) (Val.shl w (Vint n)) x.
Proof.
  unfold shlimm; intros. unfold Val.shl.
  destruct (Int.ltu n Int.iwordsize).
  destruct x; simpl in *.
- auto.
- InvAgree. apply iagree_shl; auto.
- InvAgree. apply Val.lessdef_same. f_equal. apply iagree_mone. apply iagree_shl; auto.
- destruct v; auto with na.
Qed.

Definition shruimm (x: nval) (n: int) :=
  match x with
  | Nothing => Nothing
  | I m => I (Int.shl m n)
  | All => I (Int.shl Int.mone n)
  end.

Lemma shruimm_sound:
  forall v w x n,
  vagree v w (shruimm x n) ->
  vagree (Val.shru v (Vint n)) (Val.shru w (Vint n)) x.
Proof.
  unfold shruimm; intros. unfold Val.shru.
  destruct (Int.ltu n Int.iwordsize).
  destruct x; simpl in *.
- auto.
- InvAgree. apply iagree_shru; auto.
- InvAgree. apply Val.lessdef_same. f_equal. apply iagree_mone. apply iagree_shru; auto.
- destruct v; auto with na.
Qed.

Definition shrimm (x: nval) (n: int) :=
  match x with
  | Nothing => Nothing
  | I m => I (let m' := Int.shl m n in
              if Int.eq_dec (Int.shru m' n) m
              then m'
              else Int.or m' (Int.repr Int.min_signed))
  | All => I (Int.or (Int.shl Int.mone n) (Int.repr Int.min_signed))
  end.

Lemma shrimm_sound:
  forall v w x n,
  vagree v w (shrimm x n) ->
  vagree (Val.shr v (Vint n)) (Val.shr w (Vint n)) x.
Proof.
  unfold shrimm; intros. unfold Val.shr.
  destruct (Int.ltu n Int.iwordsize).
  destruct x; simpl in *.
- auto.
- InvAgree.
  destruct (Int.eq_dec (Int.shru (Int.shl m n) n) m).
  apply iagree_shr_1; auto.
  apply iagree_shr; auto.
- InvAgree. apply Val.lessdef_same. f_equal. apply iagree_mone. apply iagree_shr. auto.
- destruct v; auto with na.
Qed.

Definition rolm (x: nval) (amount mask: int) :=
  match x with
  | Nothing => Nothing
  | I m => I (Int.ror (Int.and m mask) amount)
  | _ => I (Int.ror mask amount)
  end.

Lemma rolm_sound:
  forall v w x amount mask,
  vagree v w (rolm x amount mask) ->
  vagree (Val.rolm v amount mask) (Val.rolm w amount mask) x.
Proof.
  unfold rolm; intros; destruct x; simpl in *.
- auto.
- unfold Val.rolm; InvAgree. unfold Int.rolm.
  apply iagree_and. apply iagree_rol. auto.
- unfold Val.rolm; InvAgree. apply Val.lessdef_same. f_equal. apply iagree_mone.
  unfold Int.rolm. apply iagree_and. apply iagree_rol. rewrite Int.and_commut.
  rewrite Int.and_mone. auto.
Qed.

Definition ror (x: nval) (amount: int) :=
  match x with
  | Nothing => Nothing
  | I m => I (Int.rol m amount)
  | All => All
  end.

Lemma ror_sound:
  forall v w x n,
  vagree v w (ror x n) ->
  vagree (Val.ror v (Vint n)) (Val.ror w (Vint n)) x.
Proof.
  unfold ror; intros. unfold Val.ror.
  destruct (Int.ltu n Int.iwordsize).
  destruct x; simpl in *.
- auto.
- InvAgree. apply iagree_ror; auto.
- inv H; auto.
- destruct v; auto with na.
Qed.

(** Modular arithmetic operations: add, mul, opposite.
    (But not subtraction because of the pointer - pointer case. *)

Definition modarith (x: nval) :=
  match x with
  | Nothing => Nothing
  | I m => I (complete_mask m)
  | All => All
  end.

Lemma add_sound:
  forall v1 w1 v2 w2 x,
  vagree v1 w1 (modarith x) -> vagree v2 w2 (modarith x) ->
  vagree (Val.add v1 v2) (Val.add w1 w2) x.
Proof.
  unfold modarith; intros. destruct x; simpl in *.
- auto.
- unfold Val.add; InvAgree. apply eqmod_iagree. apply Int.eqmod_add; apply iagree_eqmod; auto.
- inv H; auto. inv H0; auto. destruct w1; auto.
Qed.

Remark modarith_idem: forall nv, modarith (modarith nv) = modarith nv.
Proof.
  destruct nv; simpl; auto. f_equal; apply complete_mask_idem.
Qed.

Lemma mul_sound:
  forall v1 w1 v2 w2 x,
  vagree v1 w1 (modarith x) -> vagree v2 w2 (modarith x) ->
  vagree (Val.mul v1 v2) (Val.mul w1 w2) x.
Proof.
  unfold mul, add; intros. destruct x; simpl in *.
- auto.
- unfold Val.mul; InvAgree. apply eqmod_iagree. apply Int.eqmod_mult; apply iagree_eqmod; auto.
- inv H; auto. inv H0; auto. destruct w1; auto.
Qed.

Lemma neg_sound:
  forall v w x,
  vagree v w (modarith x) ->
  vagree (Val.neg v) (Val.neg w) x.
Proof.
  intros; destruct x; simpl in *.
- auto.
- unfold Val.neg; InvAgree.
  apply eqmod_iagree. apply Int.eqmod_neg. apply iagree_eqmod; auto.
- inv H; simpl; auto.
Qed.

(** Conversions: zero extension, sign extension, single-of-float *)

Definition zero_ext (n: Z) (x: nval) :=
  match x with
  | Nothing => Nothing
  | I m => I (Int.zero_ext n m)
  | All => I (Int.zero_ext n Int.mone)
  end.

Lemma zero_ext_sound:
  forall v w x n,
  vagree v w (zero_ext n x) ->
  0 <= n ->
  vagree (Val.zero_ext n v) (Val.zero_ext n w) x.
Proof.
  unfold zero_ext; intros.
  destruct x; simpl in *.
- auto.
- unfold Val.zero_ext; InvAgree.
  red; intros. autorewrite with ints; try omega.
  destruct (zlt i1 n); auto. apply H; auto.
  autorewrite with ints; try omega. rewrite zlt_true; auto.
- unfold Val.zero_ext; InvAgree; auto. apply Val.lessdef_same. f_equal.
  Int.bit_solve; try omega. destruct (zlt i1 n); auto. apply H; auto.
  autorewrite with ints; try omega. apply zlt_true; auto.
Qed.

Definition sign_ext (n: Z) (x: nval) :=
  match x with
  | Nothing => Nothing
  | I m => I (Int.or (Int.zero_ext n m) (Int.shl Int.one (Int.repr (n - 1))))
  | All => I (Int.zero_ext n Int.mone)
  end.

Lemma sign_ext_sound:
  forall v w x n,
  vagree v w (sign_ext n x) ->
  0 < n < Int.zwordsize ->
  vagree (Val.sign_ext n v) (Val.sign_ext n w) x.
Proof.
  unfold sign_ext; intros. destruct x; simpl in *.
- auto.
- unfold Val.sign_ext; InvAgree.
  red; intros. autorewrite with ints; try omega.
  set (j := if zlt i1 n then i1 else n - 1).
  assert (0 <= j < Int.zwordsize).
  { unfold j; destruct (zlt i1 n); omega. }
  apply H; auto.
  autorewrite with ints; try omega. apply orb_true_intro.
  unfold j; destruct (zlt i1 n).
  left. rewrite zlt_true; auto.
  right. rewrite Int.unsigned_repr. rewrite zlt_false by omega.
  replace (n - 1 - (n - 1)) with 0 by omega. reflexivity.
  generalize Int.wordsize_max_unsigned; omega.
- unfold Val.sign_ext; InvAgree; auto. apply Val.lessdef_same. f_equal.
  Int.bit_solve; try omega.
  set (j := if zlt i1 n then i1 else n - 1).
  assert (0 <= j < Int.zwordsize).
  { unfold j; destruct (zlt i1 n); omega. }
  apply H; auto. rewrite Int.bits_zero_ext; try omega.
  rewrite zlt_true. apply Int.bits_mone; auto.
  unfold j. destruct (zlt i1 n); omega.
Qed.

(** The needs of a memory store concerning the value being stored. *)

Definition store_argument (chunk: memory_chunk) :=
  match chunk with
  | Mint8signed | Mint8unsigned => I (Int.repr 255)
  | Mint16signed | Mint16unsigned => I (Int.repr 65535)
  | _ => All
  end.

Lemma store_argument_sound:
  forall chunk v w,
  vagree v w (store_argument chunk) ->
  list_forall2 memval_lessdef (encode_val chunk v) (encode_val chunk w).
Proof.
  intros.
  assert (UNDEF: list_forall2 memval_lessdef
                     (list_repeat (size_chunk_nat chunk) Undef)
                     (encode_val chunk w)).
  {
     rewrite <- (encode_val_length chunk w).
     apply repeat_Undef_inject_any.
  }
  assert (SAME: forall vl1 vl2,
                vl1 = vl2 ->
                list_forall2 memval_lessdef vl1 vl2).
  {
     intros. subst vl2. revert vl1. induction vl1; constructor; auto.
     apply memval_lessdef_refl.
  }

  intros. unfold store_argument in H; destruct chunk.
- InvAgree. apply SAME. simpl; f_equal. apply encode_int_8_mod.
  change 8 with (Int.size (Int.repr 255)). apply iagree_eqmod; auto.
- InvAgree. apply SAME. simpl; f_equal. apply encode_int_8_mod.
  change 8 with (Int.size (Int.repr 255)). apply iagree_eqmod; auto.
- InvAgree. apply SAME. simpl; f_equal. apply encode_int_16_mod.
  change 16 with (Int.size (Int.repr 65535)). apply iagree_eqmod; auto.
- InvAgree. apply SAME. simpl; f_equal. apply encode_int_16_mod.
  change 16 with (Int.size (Int.repr 65535)). apply iagree_eqmod; auto.
- apply encode_val_inject. rewrite val_inject_id; auto.
- apply encode_val_inject. rewrite val_inject_id; auto.
- apply encode_val_inject. rewrite val_inject_id; auto.
- apply encode_val_inject. rewrite val_inject_id; auto.
- apply encode_val_inject. rewrite val_inject_id; auto.
- apply encode_val_inject. rewrite val_inject_id; auto.
Qed.

Lemma store_argument_load_result:
  forall chunk v w,
  vagree v w (store_argument chunk) ->
  Val.lessdef (Val.load_result chunk v) (Val.load_result chunk w).
Proof.
  unfold store_argument; intros; destruct chunk;
  auto using Val.load_result_lessdef; InvAgree; simpl.
- apply sign_ext_sound with (v := Vint i) (w := Vint i0) (x := All) (n := 8).
  auto. compute; auto.
- apply zero_ext_sound with (v := Vint i) (w := Vint i0) (x := All) (n := 8).
  auto. omega.
- apply sign_ext_sound with (v := Vint i) (w := Vint i0) (x := All) (n := 16).
  auto. compute; auto.
- apply zero_ext_sound with (v := Vint i) (w := Vint i0) (x := All) (n := 16).
  auto. omega.
Qed.

(** The needs of a comparison *)

Definition maskzero (n: int) := I n.

Lemma maskzero_sound:
  forall v w n b,
  vagree v w (maskzero n) ->
  Val.maskzero_bool v n = Some b ->
  Val.maskzero_bool w n = Some b.
Proof.
  unfold maskzero; intros.
  unfold Val.maskzero_bool; InvAgree; try discriminate.
  inv H0. rewrite iagree_and_eq in H. rewrite H. auto.
Qed.

(** The default abstraction: if the result is unused, the arguments are
  unused; otherwise, the arguments are needed in full. *)

Definition default (x: nval) :=
  match x with
  | Nothing => Nothing
  | _ => All
  end.

Section DEFAULT.

Variable ge: genv.
Variable sp: block.
Variables m1 m2: mem.
Hypothesis PERM: forall b ofs k p, Mem.perm m1 b ofs k p -> Mem.perm m2 b ofs k p.

Let valid_pointer_inj:
  forall b1 ofs b2 delta,
  inject_id b1 = Some(b2, delta) ->
  Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true ->
  Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true.
Proof.
  unfold inject_id; intros. inv H. rewrite Int.add_zero.
  rewrite Mem.valid_pointer_nonempty_perm in *. eauto.
Qed.

Let weak_valid_pointer_inj:
  forall b1 ofs b2 delta,
  inject_id b1 = Some(b2, delta) ->
  Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true ->
  Mem.weak_valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true.
Proof.
  unfold inject_id; intros. inv H. rewrite Int.add_zero.
  rewrite Mem.weak_valid_pointer_spec in *.
  rewrite ! Mem.valid_pointer_nonempty_perm in *.
  destruct H0; [left|right]; eauto.
Qed.

Let weak_valid_pointer_no_overflow:
  forall b1 ofs b2 delta,
  inject_id b1 = Some(b2, delta) ->
  Mem.weak_valid_pointer m1 b1 (Int.unsigned ofs) = true ->
  0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned.
Proof.
  unfold inject_id; intros. inv H. rewrite Zplus_0_r. apply Int.unsigned_range_2.
Qed.

Let valid_different_pointers_inj:
  forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2,
  b1 <> b2 ->
  Mem.valid_pointer m1 b1 (Int.unsigned ofs1) = true ->
  Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true ->
  inject_id b1 = Some (b1', delta1) ->
  inject_id b2 = Some (b2', delta2) ->
  b1' <> b2' \/
  Int.unsigned (Int.add ofs1 (Int.repr delta1)) <> Int.unsigned (Int.add ofs2 (Int.repr delta2)).
Proof.
  unfold inject_id; intros. left; congruence.
Qed.

Lemma default_needs_of_condition_sound:
  forall cond args1 b args2,
  eval_condition cond args1 m1 = Some b ->
  vagree_list args1 args2 nil ->
  eval_condition cond args2 m2 = Some b.
Proof.
  intros. apply eval_condition_inj with (f := inject_id) (m1 := m1) (vl1 := args1); auto.
  apply val_inject_list_lessdef. apply lessdef_vagree_list. auto.
Qed.

Lemma default_needs_of_operation_sound:
  forall op args1 v1 args2 nv,
  eval_operation ge (Vptr sp Int.zero) op args1 m1 = Some v1 ->
  vagree_list args1 args2 nil
  \/ vagree_list args1 args2 (default nv :: nil)
  \/ vagree_list args1 args2 (default nv :: default nv :: nil) ->
  nv <> Nothing ->
  exists v2,
     eval_operation ge (Vptr sp Int.zero) op args2 m2 = Some v2
  /\ vagree v1 v2 nv.
Proof.
  intros. assert (default nv = All) by (destruct nv; simpl; congruence).
  rewrite H2 in H0.
  assert (Val.lessdef_list args1 args2).
  {
    destruct H0. auto with na.
    destruct H0. inv H0; constructor; auto with na.
    inv H0; constructor; auto with na. inv H8; constructor; auto with na.
  }
  exploit (@eval_operation_inj _ _ _ _ ge ge inject_id).
  eassumption. auto. auto. auto.
  instantiate (1 := op). intros. apply val_inject_lessdef; auto.
  apply val_inject_lessdef. instantiate (1 := Vptr sp Int.zero). instantiate (1 := Vptr sp Int.zero). auto.
  apply val_inject_list_lessdef; eauto.
  eauto.
  intros (v2 & A & B). exists v2; split; auto.
  apply vagree_lessdef. apply val_inject_lessdef. auto.
Qed.

End DEFAULT.

(** ** Detecting operations that are redundant and can be turned into a move *)

Definition andimm_redundant (x: nval) (n: int) :=
  match x with
  | Nothing => true
  | I m => Int.eq_dec (Int.and m (Int.not n)) Int.zero
  | _ => false
  end.

Lemma andimm_redundant_sound:
  forall v w x n,
  andimm_redundant x n = true ->
  vagree v w (andimm x n) ->
  vagree (Val.and v (Vint n)) w x.
Proof.
  unfold andimm_redundant; intros. destruct x; try discriminate.
- simpl; auto.
- InvBooleans. simpl in *; unfold Val.and; InvAgree.
  red; intros. exploit (eq_same_bits i1); eauto.
  autorewrite with ints; auto. rewrite H2; simpl; intros.
  destruct (Int.testbit n i1) eqn:N; try discriminate.
  rewrite andb_true_r. apply H0; auto. autorewrite with ints; auto.
  rewrite H2, N; auto.
Qed.

Definition orimm_redundant (x: nval) (n: int) :=
  match x with
  | Nothing => true
  | I m => Int.eq_dec (Int.and m n) Int.zero
  | _ => false
  end.

Lemma orimm_redundant_sound:
  forall v w x n,
  orimm_redundant x n = true ->
  vagree v w (orimm x n) ->
  vagree (Val.or v (Vint n)) w x.
Proof.
  unfold orimm_redundant; intros. destruct x; try discriminate.
- auto.
- InvBooleans. simpl in *; unfold Val.or; InvAgree.
  apply iagree_not'. rewrite Int.not_or_and_not.
  apply (andimm_redundant_sound (Vint (Int.not i)) (Vint (Int.not i0)) (I m) (Int.not n)).
  simpl. rewrite Int.not_involutive. apply proj_sumbool_is_true. auto.
  simpl. apply iagree_not; auto.
Qed.

Definition rolm_redundant (x: nval) (amount mask: int) :=
  Int.eq_dec amount Int.zero && andimm_redundant x mask.

Lemma rolm_redundant_sound:
  forall v w x amount mask,
  rolm_redundant x amount mask = true ->
  vagree v w (rolm x amount mask) ->
  vagree (Val.rolm v amount mask) w x.
Proof.
  unfold rolm_redundant; intros; InvBooleans. subst amount. rewrite Val.rolm_zero.
  apply andimm_redundant_sound; auto.
  assert (forall n, Int.ror n Int.zero = n).
  { intros. rewrite Int.ror_rol_neg by apply int_wordsize_divides_modulus.
    rewrite Int.neg_zero. apply Int.rol_zero. }
  unfold rolm, andimm in *. destruct x; auto.
  rewrite H in H0. auto.
  rewrite H in H0. auto.
Qed.

Definition zero_ext_redundant (n: Z) (x: nval) :=
  match x with
  | Nothing => true
  | I m => Int.eq_dec (Int.zero_ext n m) m
  | _ => false
  end.

Lemma zero_ext_redundant_sound:
  forall v w x n,
  zero_ext_redundant n x = true ->
  vagree v w (zero_ext n x) ->
  0 <= n ->
  vagree (Val.zero_ext n v) w x.
Proof.
  unfold zero_ext_redundant; intros. destruct x; try discriminate.
- auto.
- simpl in *; InvAgree. simpl. InvBooleans. rewrite <- H.
  red; intros; autorewrite with ints; try omega.
  destruct (zlt i1 n). apply H0; auto.
  rewrite Int.bits_zero_ext in H3 by omega. rewrite zlt_false in H3 by auto. discriminate.
Qed.

Definition sign_ext_redundant (n: Z) (x: nval) :=
  match x with
  | Nothing => true
  | I m => Int.eq_dec (Int.zero_ext n m) m
  | _ => false
  end.

Lemma sign_ext_redundant_sound:
  forall v w x n,
  sign_ext_redundant n x = true ->
  vagree v w (sign_ext n x) ->
  0 < n ->
  vagree (Val.sign_ext n v) w x.
Proof.
  unfold sign_ext_redundant; intros. destruct x; try discriminate.
- auto.
- simpl in *; InvAgree. simpl. InvBooleans. rewrite <- H.
  red; intros; autorewrite with ints; try omega.
  destruct (zlt i1 n). apply H0; auto.
  rewrite Int.bits_or; auto. rewrite H3; auto.
  rewrite Int.bits_zero_ext in H3 by omega. rewrite zlt_false in H3 by auto. discriminate.
Qed.

(** * Neededness for register environments *)

Module NVal <: SEMILATTICE.

  Definition t := nval.
  Definition eq (x y: t) := (x = y).
  Definition eq_refl: forall x, eq x x := (@refl_equal t).
  Definition eq_sym: forall x y, eq x y -> eq y x := (@sym_equal t).
  Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@trans_equal t).
  Definition beq (x y: t) : bool := proj_sumbool (eq_nval x y).
  Lemma beq_correct: forall x y, beq x y = true -> eq x y.
  Proof. unfold beq; intros. InvBooleans. auto. Qed.
  Definition ge := nge.
  Lemma ge_refl: forall x y, eq x y -> ge x y.
  Proof. unfold eq, ge; intros. subst y. apply nge_refl. Qed.
  Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Proof. unfold ge; intros. eapply nge_trans; eauto. Qed.
  Definition bot : t := Nothing.
  Lemma ge_bot: forall x, ge x bot.
  Proof. intros. constructor. Qed.
  Definition lub := nlub.
  Lemma ge_lub_left: forall x y, ge (lub x y) x.
  Proof nge_lub_l.
  Lemma ge_lub_right: forall x y, ge (lub x y) y.
  Proof nge_lub_r.
End NVal.

Module NE := LPMap1(NVal).

Definition nenv := NE.t.

Definition nreg (ne: nenv) (r: reg) := NE.get r ne.

Definition eagree (e1 e2: regset) (ne: nenv) : Prop :=
  forall r, vagree e1#r e2#r (NE.get r ne).

Lemma nreg_agree:
  forall rs1 rs2 ne r, eagree rs1 rs2 ne -> vagree rs1#r rs2#r (nreg ne r).
Proof.
  intros. apply H.
Qed.

Hint Resolve nreg_agree: na.

Lemma eagree_ge:
  forall e1 e2 ne ne',
  eagree e1 e2 ne -> NE.ge ne ne' -> eagree e1 e2 ne'.
Proof.
  intros; red; intros. apply nge_agree with (NE.get r ne); auto. apply H0.
Qed.

Lemma eagree_bot:
  forall e1 e2, eagree e1 e2 NE.bot.
Proof.
  intros; red; intros. rewrite NE.get_bot. exact Logic.I.
Qed.

Lemma eagree_same:
  forall e ne, eagree e e ne.
Proof.
  intros; red; intros. apply vagree_same.
Qed.

Lemma eagree_update_1:
  forall e1 e2 ne v1 v2 nv r,
  eagree e1 e2 ne -> vagree v1 v2 nv -> eagree (e1#r <- v1) (e2#r <- v2) (NE.set r nv ne).
Proof.
  intros; red; intros. rewrite NE.gsspec. rewrite ! PMap.gsspec.
  destruct (peq r0 r); auto.
Qed.

Lemma eagree_update:
  forall e1 e2 ne v1 v2 r,
  vagree v1 v2 (nreg ne r) ->
  eagree e1 e2 (NE.set r Nothing ne) ->
  eagree (e1#r <- v1) (e2#r <- v2) ne.
Proof.
  intros; red; intros. specialize (H0 r0). rewrite NE.gsspec in H0.
  rewrite ! PMap.gsspec. destruct (peq r0 r).
  subst r0. auto.
  auto.
Qed.

Lemma eagree_update_dead:
  forall e1 e2 ne v1 r,
  nreg ne r = Nothing ->
  eagree e1 e2 ne -> eagree (e1#r <- v1) e2 ne.
Proof.
  intros; red; intros. rewrite PMap.gsspec.
  destruct (peq r0 r); auto. subst. unfold nreg in H. rewrite H. red; auto.
Qed.

(** * Neededness for memory locations *)

Inductive nmem : Type :=
  | NMemDead
  | NMem (stk: ISet.t) (gl: PTree.t ISet.t).

(** Interpretation of [nmem]:
- [NMemDead]: all memory locations are unused (dead).  Acts as bottom.
- [NMem stk gl]: all memory locations are used, except:
  - the stack locations whose offset is in the interval [stk]
  - the global locations whose offset is in the corresponding entry of [gl].
*)

Section LOCATIONS.

Variable ge: genv.
Variable sp: block.

Inductive nlive: nmem -> block -> Z -> Prop :=
  | nlive_intro: forall stk gl b ofs
      (STK: b = sp -> ~ISet.In ofs stk)
      (GL: forall id iv,
           Genv.find_symbol ge id = Some b ->
           gl!id = Some iv ->
           ~ISet.In ofs iv),
      nlive (NMem stk gl) b ofs.

(** All locations are live *)

Definition nmem_all := NMem ISet.empty (PTree.empty _).

Lemma nlive_all: forall b ofs, nlive nmem_all b ofs.
Proof.
  intros; constructor; intros.
  apply ISet.In_empty.
  rewrite PTree.gempty in H0; discriminate.
Qed.

(** Add a range of live locations to [nm].  The range starts at
  the abstract pointer [p] and has length [sz]. *)

Definition nmem_add (nm: nmem) (p: aptr) (sz: Z) : nmem :=
  match nm with
  | NMemDead => nmem_all       (**r very conservative, should never happen *)
  | NMem stk gl =>
      match p with
      | Gl id ofs =>
          match gl!id with
          | Some iv => NMem stk (PTree.set id (ISet.remove (Int.unsigned ofs) (Int.unsigned ofs + sz) iv) gl)
          | None => nm
          end
      | Glo id =>
          NMem stk (PTree.remove id gl)
      | Stk ofs =>
          NMem (ISet.remove (Int.unsigned ofs) (Int.unsigned ofs + sz) stk) gl
      | Stack =>
          NMem ISet.empty gl
      | _ => nmem_all
      end
  end.

Lemma nlive_add:
  forall bc b ofs p nm sz i,
  genv_match bc ge ->
  bc sp = BCstack ->
  pmatch bc b ofs p ->
  Int.unsigned ofs <= i < Int.unsigned ofs + sz ->
  nlive (nmem_add nm p sz) b i.
Proof.
  intros. unfold nmem_add. destruct nm. apply nlive_all.
  inv H1; try (apply nlive_all).
  - (* Gl id ofs *)
    assert (Genv.find_symbol ge id = Some b) by (eapply H; eauto).
    destruct gl!id as [iv|] eqn:NG.
  + constructor; simpl; intros.
    congruence.
    assert (id0 = id) by (eapply Genv.genv_vars_inj; eauto). subst id0.
    rewrite PTree.gss in H5. inv H5. rewrite ISet.In_remove.
    intros [A B]. elim A; auto.
  + constructor; simpl; intros.
    congruence.
    assert (id0 = id) by (eapply Genv.genv_vars_inj; eauto). subst id0.
    congruence.
  - (* Glo id *)
    assert (Genv.find_symbol ge id = Some b) by (eapply H; eauto).
    constructor; simpl; intros.
    congruence.
    assert (id0 = id) by (eapply Genv.genv_vars_inj; eauto). subst id0.
    rewrite PTree.grs in H5. congruence.
  - (* Stk ofs *)
    constructor; simpl; intros.
    rewrite ISet.In_remove. intros [A B]. elim A; auto.
    assert (bc b = BCglob id) by (eapply H; eauto). congruence.
  - (* Stack *)
    constructor; simpl; intros.
    apply ISet.In_empty.
    assert (bc b = BCglob id) by (eapply H; eauto). congruence.
Qed.

Lemma incl_nmem_add:
  forall nm b i p sz,
  nlive nm b i -> nlive (nmem_add nm p sz) b i.
Proof.
  intros. inversion H; subst. unfold nmem_add; destruct p; try (apply nlive_all).
- (* Gl id ofs *)
  destruct gl!id as [iv|] eqn:NG.
  + split; simpl; intros. auto.
    rewrite PTree.gsspec in H1. destruct (peq id0 id); eauto. inv H1.
    rewrite ISet.In_remove. intros [P Q]. eelim GL; eauto.
  + auto.
- (* Glo id *)
  split; simpl; intros. auto.
  rewrite PTree.grspec in H1. destruct (PTree.elt_eq id0 id). congruence. eauto.
- (* Stk ofs *)
  split; simpl; intros.
  rewrite ISet.In_remove. intros [P Q]. eelim STK; eauto.
  eauto.
- (* Stack *)
  split; simpl; intros.
  apply ISet.In_empty.
  eauto.
Qed.

(** Remove a range of locations from [nm], marking these locations as dead.
  The range starts at the abstract pointer [p] and has length [sz]. *)

Definition nmem_remove (nm: nmem) (p: aptr) (sz: Z) : nmem :=
  match nm with
  | NMemDead => NMemDead
  | NMem stk gl =>
    match p with
    | Gl id ofs =>
        let iv' :=
        match gl!id with
        | Some iv => ISet.add (Int.unsigned ofs) (Int.unsigned ofs + sz) iv
        | None    => ISet.interval (Int.unsigned ofs) (Int.unsigned ofs + sz)
        end in
        NMem stk (PTree.set id iv' gl)
    | Stk ofs =>
        NMem (ISet.add (Int.unsigned ofs) (Int.unsigned ofs + sz) stk) gl
    | _ => nm
    end
  end.

Lemma nlive_remove:
  forall bc b ofs p nm sz b' i,
  genv_match bc ge ->
  bc sp = BCstack ->
  pmatch bc b ofs p ->
  nlive nm b' i ->
  b' <> b \/ i < Int.unsigned ofs \/ Int.unsigned ofs + sz <= i ->
  nlive (nmem_remove nm p sz) b' i.
Proof.
  intros. inversion H2; subst. unfold nmem_remove; inv H1; auto.
- (* Gl id ofs *)
  set (iv' := match gl!id with
                  | Some iv =>
                      ISet.add (Int.unsigned ofs) (Int.unsigned ofs + sz) iv
                  | None =>
                      ISet.interval (Int.unsigned ofs)
                        (Int.unsigned ofs + sz)
              end).
  assert (Genv.find_symbol ge id = Some b) by (eapply H; eauto).
  split; simpl; auto; intros.
  rewrite PTree.gsspec in H6. destruct (peq id0 id).
+ inv H6. destruct H3. congruence. destruct gl!id as [iv0|] eqn:NG.
  rewrite ISet.In_add. intros [P|P]. omega. eelim GL; eauto.
  rewrite ISet.In_interval. omega.
+ eauto.
- (* Stk ofs *)
  split; simpl; auto; intros. destruct H3.
  elim H3. subst b'. eapply bc_stack; eauto.
  rewrite ISet.In_add. intros [P|P]. omega. eapply STK; eauto.
Qed.

(** Test (conservatively) whether some locations in the range delimited
  by [p] and [sz] can be live in [nm]. *)

Definition nmem_contains (nm: nmem) (p: aptr) (sz: Z) :=
  match nm with
  | NMemDead => false
  | NMem stk gl =>
      match p with
      | Gl id ofs =>
          match gl!id with
          | Some iv => negb (ISet.contains (Int.unsigned ofs) (Int.unsigned ofs + sz) iv)
          | None => true
          end
      | Stk ofs =>
          negb (ISet.contains (Int.unsigned ofs) (Int.unsigned ofs + sz) stk)
      | _ => true  (**r conservative answer *)
      end
  end.

Lemma nlive_contains:
  forall bc b ofs p nm sz i,
  genv_match bc ge ->
  bc sp = BCstack ->
  pmatch bc b ofs p ->
  nmem_contains nm p sz = false ->
  Int.unsigned ofs <= i < Int.unsigned ofs + sz ->
  ~(nlive nm b i).
Proof.
  unfold nmem_contains; intros. red; intros L; inv L.
  inv H1; try discriminate.
- (* Gl id ofs *)
  assert (Genv.find_symbol ge id = Some b) by (eapply H; eauto).
  destruct gl!id as [iv|] eqn:HG; inv H2.
  destruct (ISet.contains (Int.unsigned ofs) (Int.unsigned ofs + sz) iv) eqn:IC; try discriminate.
  rewrite ISet.contains_spec in IC. eelim GL; eauto.
- (* Stk ofs *)
  destruct (ISet.contains (Int.unsigned ofs) (Int.unsigned ofs + sz) stk) eqn:IC; try discriminate.
  rewrite ISet.contains_spec in IC. eelim STK; eauto. eapply bc_stack; eauto.
Qed.

(** Kill all stack locations between 0 and [sz], and mark everything else
  as live.  This reflects the effect of freeing the stack block at
  a [Ireturn] or [Itailcall] instruction. *)

Definition nmem_dead_stack (sz: Z) :=
  NMem (ISet.interval 0 sz) (PTree.empty _).

Lemma nlive_dead_stack:
  forall sz b' i, b' <> sp \/ ~(0 <= i < sz) -> nlive (nmem_dead_stack sz) b' i.
Proof.
  intros; constructor; simpl; intros.
- rewrite ISet.In_interval. intuition.
- rewrite PTree.gempty in H1; discriminate.
Qed.

(** Least upper bound *)

Definition nmem_lub (nm1 nm2: nmem) : nmem :=
  match nm1, nm2 with
  | NMemDead, _ => nm2
  | _, NMemDead => nm1
  | NMem stk1 gl1, NMem stk2 gl2 =>
      NMem (ISet.inter stk1 stk2)
           (PTree.combine
                (fun o1 o2 =>
                  match o1, o2 with
                  | Some iv1, Some iv2 => Some(ISet.inter iv1 iv2)
                  | _, _ => None
                  end)
                gl1 gl2)
  end.

Lemma nlive_lub_l:
  forall nm1 nm2 b i, nlive nm1 b i -> nlive (nmem_lub nm1 nm2) b i.
Proof.
  intros. inversion H; subst. destruct nm2; simpl. auto.
  constructor; simpl; intros.
- rewrite ISet.In_inter. intros [P Q]. eelim STK; eauto.
- rewrite PTree.gcombine in H1 by auto.
  destruct gl!id as [iv1|] eqn:NG1; try discriminate;
  destruct gl0!id as [iv2|] eqn:NG2; inv H1.
  rewrite ISet.In_inter. intros [P Q]. eelim GL; eauto.
Qed.

Lemma nlive_lub_r:
  forall nm1 nm2 b i, nlive nm2 b i -> nlive (nmem_lub nm1 nm2) b i.
Proof.
  intros. inversion H; subst. destruct nm1; simpl. auto.
  constructor; simpl; intros.
- rewrite ISet.In_inter. intros [P Q]. eelim STK; eauto.
- rewrite PTree.gcombine in H1 by auto.
  destruct gl0!id as [iv1|] eqn:NG1; try discriminate;
  destruct gl!id as [iv2|] eqn:NG2; inv H1.
  rewrite ISet.In_inter. intros [P Q]. eelim GL; eauto.
Qed.

(** Boolean-valued equality test *)

Definition nmem_beq (nm1 nm2: nmem) : bool :=
  match nm1, nm2 with
  | NMemDead, NMemDead => true
  | NMem stk1 gl1, NMem stk2 gl2 => ISet.beq stk1 stk2 && PTree.beq ISet.beq gl1 gl2
  | _, _ => false
  end.

Lemma nmem_beq_sound:
  forall nm1 nm2 b ofs,
  nmem_beq nm1 nm2 = true ->
  (nlive nm1 b ofs <-> nlive nm2 b ofs).
Proof.
  unfold nmem_beq; intros.
  destruct nm1 as [ | stk1 gl1]; destruct nm2 as [ | stk2 gl2]; try discriminate.
- split; intros L; inv L.
- InvBooleans. rewrite ISet.beq_spec in H0. rewrite PTree.beq_correct in H1.
  split; intros L; inv L; constructor; intros.
+ rewrite <- H0. eauto.
+ specialize (H1 id). rewrite H2 in H1. destruct gl1!id as [iv1|] eqn: NG; try contradiction.
  rewrite ISet.beq_spec in H1. rewrite <- H1. eauto.
+ rewrite H0. eauto.
+ specialize (H1 id). rewrite H2 in H1. destruct gl2!id as [iv2|] eqn: NG; try contradiction.
  rewrite ISet.beq_spec in H1. rewrite H1. eauto.
Qed.

End LOCATIONS.

(** * The lattice for dataflow analysis *)

Module NA <: SEMILATTICE.

  Definition t := (nenv * nmem)%type.

  Definition eq (x y: t) :=
    NE.eq (fst x) (fst y) /\
    (forall ge sp b ofs, nlive ge sp (snd x) b ofs <-> nlive ge sp (snd y) b ofs).

  Lemma eq_refl: forall x, eq x x.
  Proof.
    unfold eq; destruct x; simpl; split. apply NE.eq_refl. tauto.
  Qed.
  Lemma eq_sym: forall x y, eq x y -> eq y x.
  Proof.
    unfold eq; destruct x, y; simpl. intros [A B].
    split. apply NE.eq_sym; auto.
    intros. rewrite B. tauto.
  Qed.
  Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
  Proof.
    unfold eq; destruct x, y, z; simpl. intros [A B] [C D]; split.
    eapply NE.eq_trans; eauto.
    intros. rewrite B; auto.
  Qed.

  Definition beq (x y: t) : bool :=
    NE.beq (fst x) (fst y) && nmem_beq (snd x) (snd y).

  Lemma beq_correct: forall x y, beq x y = true -> eq x y.
  Proof.
    unfold beq, eq; destruct x, y; simpl; intros. InvBooleans. split.
    apply NE.beq_correct; auto.
    intros. apply nmem_beq_sound; auto.
  Qed.

  Definition ge (x y: t) : Prop :=
    NE.ge (fst x) (fst y) /\
    (forall ge sp b ofs, nlive ge sp (snd y) b ofs -> nlive ge sp (snd x) b ofs).

  Lemma ge_refl: forall x y, eq x y -> ge x y.
  Proof.
    unfold eq, ge; destruct x, y; simpl. intros [A B]; split.
    apply NE.ge_refl; auto.
    intros. apply B; auto.
  Qed.
  Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Proof.
    unfold ge; destruct x, y, z; simpl. intros [A B] [C D]; split.
    eapply NE.ge_trans; eauto.
    auto.
  Qed.

  Definition bot : t := (NE.bot, NMemDead).

  Lemma ge_bot: forall x, ge x bot.
  Proof.
    unfold ge, bot; destruct x; simpl. split.
    apply NE.ge_bot.
    intros. inv H.
  Qed.

  Definition lub (x y: t) : t :=
    (NE.lub (fst x) (fst y), nmem_lub (snd x) (snd y)).

  Lemma ge_lub_left: forall x y, ge (lub x y) x.
  Proof.
    unfold ge; destruct x, y; simpl; split.
    apply NE.ge_lub_left.
    intros; apply nlive_lub_l; auto.
  Qed.
  Lemma ge_lub_right: forall x y, ge (lub x y) y.
  Proof.
    unfold ge; destruct x, y; simpl; split.
    apply NE.ge_lub_right.
    intros; apply nlive_lub_r; auto.
  Qed.

End NA.


(* Modular Specifications for Concurrent Modules. *)

From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang proofmode notation.
From iris.proofmode Require Import proofmode.
From iris.algebra Require Import agree frac frac_auth.
From iris.prelude Require Import options.

From iris.bi.lib Require Import fractional.

From iris.heap_lang.lib Require Import par.

Definition cntCmra : cmra := prodR fracR (agreeR ZO).

Class cntG Σ := CntG { CntG_inG :> inG Σ cntCmra }.
Definition cntΣ : gFunctors := #[GFunctor cntCmra ].

Global Instance subG_cntΣ {Σ} : subG cntΣ Σ → cntG Σ.
Proof. solve_inG. Qed.

Definition newcounter : val :=
  λ: "m", ref "m".

Definition read : val := λ: "ℓ", !"ℓ".

Definition incr: val :=
  rec: "incr" "l" :=
     let: "oldv" := !"l" in
     if: CAS "l" "oldv" ("oldv" + #1)
       then "oldv" (* return old value if success *)
       else "incr" "l".

Definition wk_incr : val :=
    λ: "l", let: "n" := !"l" in
            "l" <- "n" + #1.

Section cnt_model.
  Context `{!cntG Σ}.

  Definition makeElem (q : Qp) (m : Z) : cntCmra := (q, to_agree m).
  Typeclasses Opaque makeElem.

  Notation "γ ⤇[ q ] m" := (own γ (makeElem q m))
    (at level 20, q at level 50, format "γ ⤇[ q ]  m") : bi_scope.
  Notation "γ ⤇½ m" := (own γ (makeElem (1/2) m))
    (at level 20, format "γ ⤇½  m") : bi_scope.

  Global Instance makeElem_fractional γ m: Fractional (λ q, γ ⤇[q] m)%I.
  Proof.
    intros p q. rewrite /makeElem.
    rewrite -own_op; f_equiv.
    split; first done.
    by rewrite /= agree_idemp.
  Qed.

  Global Instance makeElem_as_fractional γ m q:
    AsFractional (own γ (makeElem q m)) (λ q, γ ⤇[q] m)%I q.
  Proof.
    split; first done. apply _.
  Qed.

  Global Instance makeElem_Exclusive m: Exclusive (makeElem 1 m).
  Proof.
    rewrite /makeElem. intros [y ?] [H _]. apply (exclusive_l _ _ H).
  Qed.

  Lemma makeElem_op p q n:
    makeElem p n ⋅ makeElem q n ≡ makeElem (p + q) n.
  Proof.
    rewrite /makeElem; split; first done.
    by rewrite /= agree_idemp.
  Qed.

  Lemma makeElem_eq γ p q (n m : Z):
    γ ⤇[p] n -∗ γ ⤇[q] m -∗ ⌜n = m⌝.
  Proof.
    iIntros "H1 H2".
    iDestruct (own_valid_2 with "H1 H2") as %HValid.
    destruct HValid as [_ H2].
    iIntros "!%"; by apply to_agree_op_inv_L.
  Qed.

  Lemma makeElem_entail γ p q (n m : Z):
    γ ⤇[p] n -∗ γ ⤇[q] m -∗ γ ⤇[p + q] n.
  Proof.
    iIntros "H1 H2".
    iDestruct (makeElem_eq with "H1 H2") as %->.
    iCombine "H1" "H2" as "H".
    by rewrite makeElem_op.
  Qed.

  Lemma makeElem_update γ (n m k : Z):
    γ ⤇½ n -∗ γ ⤇½ m ==∗ γ ⤇[1] k.
  Proof.
    iIntros "H1 H2".
    iDestruct (makeElem_entail with "H1 H2") as "H".
    rewrite Qp_div_2.
    iApply (own_update with "H"); by apply cmra_update_exclusive.
  Qed.
End cnt_model.

Notation "γ ⤇[ q ] m" := (own γ (makeElem q m))
  (at level 20, q at level 50, format "γ ⤇[ q ]  m") : bi_scope.
Notation "γ ⤇½ m" := (own γ (makeElem (1/2) m))
  (at level 20, format "γ ⤇½  m") : bi_scope.

Section cnt_spec.
  Context `{!heapGS Σ, !cntG Σ} (N : namespace).

  Definition cnt_inv ℓ γ := (∃ (m : Z), ℓ ↦ #m ∗ γ ⤇½ m)%I.

  Definition Cnt (ℓ : loc) (γ : gname) : iProp Σ :=
    inv (N .@ "internal") (cnt_inv ℓ γ).

  Lemma Cnt_alloc (E : coPset) (m : Z) (ℓ : loc):
    (ℓ ↦ #m) ={E}=∗ ∃ γ, Cnt ℓ γ ∗ γ ⤇½ m.
  Proof.
    iIntros "Hpt".
    iMod (own_alloc (makeElem 1 m)) as (γ) "[Hown1 Hown2]"; first done.
    iMod (inv_alloc (N.@ "internal") _ (cnt_inv ℓ γ)%I with "[Hpt Hown1]") as "#HInc".
    { iExists _; iFrame. }
    iModIntro; iExists _; iFrame "# Hown2".
  Qed.

  Theorem newcounter_spec (E : coPset) (m : Z):
    ↑(N .@ "internal") ⊆ E →
    {{{ True }}} newcounter #m @ E {{{ (ℓ : loc), RET #ℓ; ∃ γ, Cnt ℓ γ ∗ γ ⤇½ m}}}.
  Proof.
    iIntros (Hsubset Φ) "#Ht HΦ".
    wp_lam.
    wp_alloc ℓ as "Hl".
    iApply "HΦ".
    by iApply Cnt_alloc.
  Qed.

  Theorem read_spec (γ : gname) (E : coPset) (P : iProp Σ) (Q : Z → iProp Σ) (ℓ : loc):
    ↑(N .@ "internal") ⊆ E →
    (∀ m, □ (γ ⤇½ m ∗ P ={E ∖ ↑(N .@ "internal")}=∗ γ ⤇½ m ∗ Q m)) ⊢
    {{{ Cnt ℓ γ ∗ P}}} read #ℓ @ E {{{ (m : Z), RET #m; Cnt ℓ γ ∗ Q m }}}.
  Proof.
    iIntros (Hsubset) "#HVS".
    iIntros (Φ) "!# [#HInc HP] HCont".
    wp_rec.
    rewrite /Cnt.
    iInv (N .@ "internal") as (m) "[>Hpt >Hown]" "HClose".
    iMod ("HVS" $! m with "[Hown HP]") as "[Hown HQ]"; first by iFrame.
    wp_load.
    iMod ("HClose" with "[Hpt Hown]") as "_".
    { iNext; iExists _; iFrame. }
    iApply "HCont".
    iModIntro.
    iFrame.
    done.
  Qed.

  Theorem incr_spec (γ : gname) (E : coPset) (P : iProp Σ) (Q : Z → iProp Σ) (ℓ : loc):
    ↑(N .@ "internal") ⊆ E →
    (∀ (n : Z), □ (γ ⤇½ n ∗ P  ={E ∖ ↑(N .@ "internal")}=∗ γ ⤇½ (n+1) ∗ Q n)) ⊢
    {{{ Cnt ℓ γ ∗ P }}} incr #ℓ @ E {{{ (m : Z), RET #m; Cnt ℓ γ ∗ Q m}}}.
  Proof.
    iIntros (Hsubset) "#HVS".
    iIntros (Φ) "!# [#HInc HP] HCont".
    iLöb as "IH".
    wp_rec.
    wp_bind (! _)%E.
    iInv (N .@ "internal") as (m) "[>Hpt >Hown]" "HClose".
    wp_load.
    iMod ("HClose" with "[Hpt Hown]") as "_".
    { iNext; iExists _; iFrame. }
    iModIntro.
    wp_let.
    wp_op.
    wp_bind (CmpXchg _ _ _)%E.
    iInv (N .@ "internal") as (m') "[>Hpt >Hown]" "HClose".
    destruct (decide (m = m')); simplify_eq.
    - wp_cmpxchg_suc.
      iMod ("HVS" $! m' with "[Hown HP]") as "[Hown HQ]"; first iFrame.
      iMod ("HClose" with "[Hpt Hown]") as "_".
      { iNext; iExists _; iFrame. }
      iModIntro.
      wp_pures.
      iApply "HCont"; by iFrame.
    - wp_cmpxchg_fail.
      iMod ("HClose" with "[Hpt Hown]") as "_".
      { iNext; iExists _; iFrame. }
      iModIntro.
      wp_pures.
      iApply ("IH" with "HP HCont").
  Qed.

  Theorem wk_incr_spec (γ : gname) (E : coPset) (P Q : iProp Σ) (ℓ : loc) (n : Z) (q : Qp):
    ↑(N .@ "internal") ⊆ E →
    □ (γ ⤇½ n ∗ γ ⤇[q] n ∗ P ={E ∖ ↑(N .@ "internal")}=∗ γ ⤇½ (n+1) ∗ Q) -∗
    {{{ Cnt ℓ γ ∗ γ ⤇[q] n ∗ P}}} wk_incr #ℓ @ E {{{ RET #(); Cnt ℓ γ ∗ Q}}}.
  Proof.
    iIntros (Hsubset) "#HVS".
    iIntros (Φ) "!# [#HInc [Hγ HP]] HCont".
    wp_lam.
    wp_bind (! _)%E.
    iInv (N .@ "internal") as (m) "[>Hpt >Hown]" "HClose".
    wp_load.
    iDestruct (makeElem_eq with "Hγ Hown") as %->.
    iMod ("HClose" with "[Hpt Hown]") as "_".
    { iNext; iExists _; iFrame. }
    iModIntro.
    wp_let.
    wp_op.
    iInv (N .@ "internal") as (k) "[>Hpt >Hown]" "HClose".
    iDestruct (makeElem_eq with "Hγ Hown") as %->.
    iMod ("HVS" with "[$Hown $HP $Hγ]") as "[Hown HQ]".
    wp_store.
    iMod ("HClose" with "[Hpt Hown]") as "_".
    { iNext; iExists _; iFrame. }
    iModIntro.
    iApply "HCont"; by iFrame.
  Qed.

  Theorem wk_incr_spec' (γ : gname) (E : coPset) (P Q : iProp Σ) (ℓ : loc) (n : Z) (q : Qp):
    ↑(N .@ "internal") ⊆ E →
    □ (γ ⤇½ n ∗ γ ⤇[q] n ∗ P ={E ∖ ↑(N .@ "internal")}=∗ γ ⤇½ (n+1) ∗  γ ⤇[q] (n + 1) ∗ Q) -∗
    {{{ Cnt ℓ γ ∗ γ ⤇[q] n ∗ P}}} wk_incr #ℓ @ E {{{ RET #(); Cnt ℓ γ ∗  γ ⤇[q] (n + 1) ∗ Q}}}.
  Proof.
    iIntros (Hsubset) "#HVS".
    iApply wk_incr_spec; done.
Qed.

End cnt_spec.
Global Opaque newcounter incr read wk_incr.

Section incr_twice.
  Context `{!heapGS Σ, !cntG Σ} (N : namespace).
  Definition incr_twice : val := λ: "ℓ", incr "ℓ" ;; incr "ℓ".

  Theorem incr_twice_spec (γ : gname) (E : coPset) (P : iProp Σ) (Q Q' : Z → iProp Σ) (ℓ : loc):
    ↑(N .@ "internal") ⊆ E →
    (∀ (n : Z), □ (γ ⤇½ n ∗ P  ={E ∖ ↑(N .@ "internal")}=∗ γ ⤇½ (n+1) ∗ Q n))
      -∗
      (∀ (n : Z), □ (γ ⤇½ n ∗ (∃ m, Q m)  ={E ∖ ↑(N .@ "internal")}=∗ γ ⤇½ (n+1) ∗ Q' n))
      -∗
      {{{ Cnt N ℓ γ ∗ P }}} incr_twice #ℓ @ E {{{ (m : Z), RET #m; Cnt N ℓ γ ∗ Q' m}}}.
  Proof.
    iIntros (?) "#HVS1 #HVS2 !#".
    iIntros (Φ) "HPre HΦ".
    wp_lam. wp_bind (incr _)%E.
    wp_apply (incr_spec with "HVS1 HPre"); auto.
    iIntros (m) "[HCnt HPre]".
    wp_seq.
    wp_apply (incr_spec with "HVS2 [$HCnt HPre]"); auto.
  Qed.
End incr_twice.

Section example_1.
  Context `{!heapGS Σ, !spawnG Σ, !cntG Σ} (N : namespace).

  Definition incr_2 : val :=
    λ: "x",
       let: "l" := newcounter "x" in
       incr "l" ||| incr "l";;
       read "l".

  (* Prove that incr is safe w.r.t. data race. TODO: prove a stronger post-condition *)
  Lemma incr_2_safe:
    ∀ (x: Z), ⊢ WP incr_2 #x {{ _, True }}.
  Proof using Type* N.
    iIntros (x).
    rewrite /incr_2 /=.
    wp_lam.
    wp_bind (newcounter _)%E.
    wp_apply newcounter_spec; auto; iIntros (ℓ) "H".
    iDestruct "H" as (γ) "[#HInc Hown2]".
    iMod (inv_alloc (N.@ "external") _ (∃m, own γ (makeElem (1/2) m))%I with "[Hown2]") as "#Hinv".
    { iNext; iExists _; iFrame. }
    iDestruct (incr_spec N γ ⊤ True%I (λ _, True)%I with "[]") as "#HIncr"; eauto.
    { iIntros (n) "!# [Hown _]".
      iInv (N .@ "external") as (m) ">Hownm" "H2".
      iMod (makeElem_update _ _ _ (n + 1) with "Hown Hownm") as "[Hown Hown']".
      iMod ("H2" with "[Hown]") as "_".
      { iExists _; iFrame. }
      iModIntro; iFrame.
    }
    wp_let.
    wp_bind (_ ||| _)%E.
    let tac := iApply ("HIncr" with "[$HInc]"); iNext; by iIntros (?) "_" in
    wp_smart_apply (wp_par (λ _, True%I) (λ _, True%I)); [tac | tac | ].
    { iIntros (v1 v2) "_ !>".
      wp_seq.
      wp_apply (read_spec _ _ _ True%I (λ _, True%I)); auto.
    }
  Qed.
End example_1.


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 P A B C D A1 B1 C1 D1 C1prime K : Universe, ((wd_ O E /\ (wd_ P B /\ (wd_ A B /\ (wd_ K O /\ (wd_ O A1 /\ (wd_ K A1 /\ (wd_ C1prime O /\ (wd_ C1prime A1 /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ P A /\ (wd_ A C /\ (wd_ P C /\ (wd_ O C1 /\ (wd_ O B1 /\ (wd_ A1 Eprime /\ (wd_ Eprime K /\ (col_ P A B /\ (col_ P C D /\ (col_ O E A1 /\ (col_ O E B1 /\ (col_ O E C1 /\ (col_ O E D1 /\ col_ O C1 C1prime))))))))))))))))))))))) -> col_ O C1 A1)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 A B C Aprime Cprime P Q : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Aprime Cprime /\ (wd_ P Q /\ (wd_ A Aprime /\ (wd_ B Aprime /\ (wd_ C Cprime /\ (wd_ A P /\ (wd_ A Q /\ (wd_ Aprime Aprime /\ (wd_ B Cprime /\ (wd_ Aprime C /\ (col_ Aprime P Q /\ (col_ Cprime P Q /\ (col_ A B C /\ col_ A B Aprime)))))))))))))))) -> col_ Aprime B C)).
Proof.
  time tac.
Qed.

End FOFProblem.