(**********************************************************************)
(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                      Tree-Calculus                                 *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                       Fixpoints.v                                  *)
(*                                                                    *)
(*                        Barry Jay                                   *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Omega List Max.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Tree_calculus.Tree_Terms.
Require Import IntensionalLib.Tree_calculus.Tree_Tactics.
Require Import IntensionalLib.Tree_calculus.Tree_reduction.
Require Import IntensionalLib.Tree_calculus.Tree_Normal.
Require Import IntensionalLib.Tree_calculus.Tree_Closed.
Require Import IntensionalLib.Tree_calculus.Substitution.
Require Import IntensionalLib.Tree_calculus.Tree_Eval.
Require Import IntensionalLib.Tree_calculus.Star.
Require Import IntensionalLib.Tree_calculus.Wait.

(* fixpoints that wait *)

(* Y2 *)

Definition omega2 :=
star_opt(star_opt (App (Ref 0) (app_comb (app_comb (Ref 1) (Ref 1)) (Ref 0)))).

Definition Y2 f := app_comb (app_comb omega2 omega2) f.

Lemma Y2_program: forall f, program f -> program (Y2 f).
Proof.
  unfold Y2, omega2; split_all; unfold program; split;
unfold subst, subst_rec; fold subst_rec; nf_out; try eapply2 H.
unfold subst, subst_rec; fold subst_rec; nf_out; try eapply2 H.
unfold maxvar; fold maxvar. simpl. nf_out. simpl.
  rewrite max_zero; eapply2 H.
Qed.

Lemma omega2_omega2 :
forall f, sf_red (App (App omega2 omega2) f) (App f (Y2 f)).
Proof.
unfold omega2 at 1. intros.
eapply transitive_red. eapply2 star_opt_beta2.
unfold subst, subst_rec; fold subst_rec.
insert_Ref_out. unfold lift.  rewrite lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null. eapply2 preserves_app_sf_red.
rewrite ! subst_rec_preserves_app_comb.
repeat (rewrite subst_rec_ref; insert_Ref_out).
unfold lift. rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.  rewrite lift_rec_null. unfold Y2. auto.
Qed.

Lemma Y2_fix_f: forall M N,
sf_red (App (Y2 M) N) (App (App M (Y2 M)) N).
Proof.
unfold Y2 at 1.  intros.
eapply transitive_red. eapply2 app_comb_red.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 omega2_omega2. auto. auto.
Qed.

(* Y3 *)

Definition omega3 :=
star_opt(star_opt (star_opt (App (App (Ref 1)
  (star_opt (app_comb (app_comb (app_comb (Ref 3) (Ref 3)) (Ref 2)) (Ref 0))))
                                    (Ref 0)))).

Definition Y3 f := star_opt (app_comb (app_comb (app_comb omega3 omega3) (lift 1 f)) (Ref 0)).

Lemma omega3_program: program omega3.
Proof.
split; auto. unfold omega3; nf_out.  eapply2 nf_active.  eapply2 nf_active.
unfold subst, subst_rec; fold subst_rec; nf_out; try eapply2 H; cbv; auto.
Qed.

Lemma Y3_program: forall f, program f -> program (Y3 f).
Proof.
intros.  unfold Y3; split; auto.
nf_out; try eapply2 omega3_program.   eapply2 H.
(* 1 *)
rewrite maxvar_star_opt. rewrite ! maxvar_app_comb.
replace (maxvar omega3) with 0 by eapply2 omega3_program. simpl.
replace (maxvar (lift 1 f)) with 0.
auto.  unfold lift; rewrite lift_rec_closed.
assert(maxvar f = 0) by eapply2 H; auto.
eapply2 H.
Qed.

Lemma omega3_omega3 :
forall f M, sf_red (App (App (App omega3 omega3) f) M) (App (App f (Y3 f)) M).
Proof.
unfold omega3 at 1. intros.
eapply transitive_red. eapply2 star_opt_beta3.
unfold subst; rewrite ! subst_rec_app.
rewrite ! subst_rec_preserves_star_opt.
rewrite ! subst_rec_preserves_app_comb.
repeat (rewrite ! subst_rec_ref; insert_Ref_out).
unfold lift; rewrite ! lift_rec_lift_rec; try omega. unfold plus.
rewrite ! subst_rec_lift_rec; try omega. rewrite ! lift_rec_null.
rewrite ! (lift_rec_closed omega3).
unfold Y3.  auto.
unfold omega3; cbv; auto.
Qed.

Lemma Y3_fix_f: forall M N P,
sf_red (App (App (Y3 M) N) P) (App (App (App M (Y3 M)) N) P).
Proof.
unfold Y3 at 1.  intros.
eapply transitive_red. eapply preserves_app_sf_red. eapply star_opt_beta. auto.
unfold subst, subst_rec; fold subst_rec.
rewrite ! subst_rec_preserves_app_comb.
rewrite ! (subst_rec_closed omega3).
2: unfold omega3; cbv; omega.
unfold lift; rewrite subst_rec_lift_rec; try omega.
unfold subst_rec; fold subst_rec. insert_Ref_out. unfold lift.
rewrite ! lift_rec_null.
eapply transitive_red. eapply2 app_comb_red.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red. eapply2 app_comb_red.
auto. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 omega3_omega3. auto. auto.
Qed.

Definition omega_k k :=
star_opt(star_opt (App (Ref 0) (app_comb (app_comb (app_comb (A_k (S k)) (Ref 1)) (Ref 1))
                                    (Ref 0)))).

Definition Y_k k := app_comb (app_comb (A_k (S k)) (omega_k k)) (omega_k k).

Lemma omega_k_normal: forall k, normal (omega_k k).
Proof.
intros; unfold omega_k. repeat eapply2 star_opt_normal.
eapply2 nf_active.  repeat eapply2 app_comb_normal.
Qed.

Lemma omega_k_closed: forall k, maxvar(omega_k k) = 0.
Proof.
induction k; intros.
cbv; auto.
unfold omega_k; fold omega_k.
rewrite ! maxvar_star_opt.
rewrite maxvar_app.
rewrite ! maxvar_app_comb.
rewrite A_k_closed.
simpl. auto.
Qed.

Lemma omega_omega :
forall k M, sf_red (App (App (omega_k k) (omega_k k)) M) (App M (app_comb (Y_k k) M)).
Proof.
unfold omega_k at 1. intros.
eapply transitive_red. eapply2 star_opt_beta2.
subst_tac.  unfold lift.  rewrite lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null. eapply2 preserves_app_sf_red.
repeat rewrite subst_rec_preserves_app_comb.
repeat rewrite (subst_rec_closed (A_k _)); try (rewrite A_k_closed; omega).
rewrite ! subst_rec_ref; insert_Ref_out.
unfold lift. rewrite ! lift_rec_null.  unfold pred.
subst_tac. unfold lift; rewrite lift_rec_null.
unfold Y_k. auto.
Qed.

Lemma omega_k_alt:
  forall k,
    subst (star_opt
             (star_opt (App (Ref 0) (app_comb (app_comb (app_comb (Ref 2) (Ref 1)) (Ref 1)) (Ref 0)))))
             (A_k (S k)) =
    (omega_k k).
Proof.
  intros. unfold subst; rewrite ! subst_rec_preserves_star_opt. subst_tac.
  rewrite ! subst_rec_preserves_app_comb. repeat subst_tac.
  unfold lift; rewrite lift_rec_closed. unfold omega_k. congruence. apply A_k_closed.
Qed.

Lemma omega_k_mono: forall n k, omega_k n <> omega_k (S (k+n)).
Proof.
  intros.
  rewrite <- ! omega_k_alt. intro.
  assert(A_k (S n) = A_k (S (S (k+n)))). eapply star_opt_mono.
  2: eexact H.   cbv; auto.
  assert(S n = S (S (k+n))) by (apply A_k_mono; auto).
omega.
Qed.

Lemma Y_k_program: forall k, program (Y_k k).
Proof.
intros. unfold program. split.
unfold Y_k. repeat eapply2 app_comb_normal.
apply omega_k_normal. auto.
apply omega_k_normal. auto.
 unfold Y_k. rewrite !  maxvar_app_comb.
 rewrite A_k_closed; try omega.
 rewrite ! omega_k_closed.  auto.
Qed.

Lemma Y_k_normal: forall k, normal (Y_k k). Proof. eapply2 Y_k_program. Qed.
Lemma Y_k_closed: forall k, maxvar (Y_k k) = 0. Proof. eapply2 Y_k_program. Qed.

Lemma Y0_fix: forall M N,
sf_red (App (App (Y_k 0) M) N) (App (App M (app_comb (Y_k 0) M)) N).
Proof.
unfold Y_k at 1.  intros.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto. auto.
eapply transitive_red. eapply preserves_app_sf_red.  eapply preserves_app_sf_red.
eapply A3_red. auto. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply app_comb_red. auto.
unfold A_k. eapply transitive_red. eapply a_op_red.
eapply transitive_red. eapply preserves_app_sf_red. eapply app_comb_red. auto.
eapply preserves_app_sf_red. 2: auto.
eapply omega_omega.
Qed.

Lemma Y1_fix: forall M N P,
sf_red (App (App (App (Y_k 1) M) N) P) (App (App (App M (app_comb (Y_k 1) M)) N) P).
Proof.
unfold Y_k at 1.  intros.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red. eapply2 app_comb_red. auto. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto. auto. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 A3_red.  all: auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red. eapply2 app_comb_red. all: auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red. eapply2 A3_red. all: auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 app_comb_red. auto.
unfold A_k. eapply transitive_red. eapply preserves_app_sf_red. eapply2 a_op2_red. auto.
eapply transitive_red. eapply2 app_comb_red.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red. eapply2 app_comb_red. all: auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 omega_omega. all: auto.
Qed.

Lemma Y2_fix: forall M N P Q,
sf_red (App (App (App (App (Y_k 2) M) N) P) Q) (App (App (App (App M (app_comb (Y_k 2) M)) N) P) Q).
Proof.
unfold Y_k at 1.  intros.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply2 app_comb_red. all: auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply preserves_app_sf_red. eapply2 app_comb_red. all: auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red.  eapply preserves_app_sf_red.
eapply2 A3_red.  all:auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply2 app_comb_red.  all:auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply2 A3_red.  all:auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 A3_red.  all:auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 app_comb_red. all: auto.
unfold A_k.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 a_op2_red. auto.
eapply transitive_red. eapply2 app_comb_red.
eapply transitive_red. eapply preserves_app_sf_red.
 eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. all: auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply2 app_comb_red. all: auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply2 omega_omega.  all: auto.
Qed.

(*
Notation "A ~ B" := (App A B) (at level 79, left associativity).
Notation S := (Op Sop).
Notation K := (App (Op Fop) (Op Fop)).
Notation I := (App (App (Op Sop) (App (Op Fop) (Op Fop))) (App (Op Fop) (Op Fop))).

Print Y2_comb_val.

Lemma Y2_val: Y_k 2 = Y2_comb_val.
Proof.  cbv. auto. Qed.

Definition a_op_val :=
 (S ~
    (S ~ (K ~ S) ~
     (S ~ (K ~ (S ~ (K ~ S))) ~
      (S ~ (S ~ (K ~ S) ~ (S ~ (K ~ K) ~ (S ~ (K ~ S) ~ (S ~ (K ~ K) ~ I)))) ~
         (K ~ (S ~ (K ~ K) ~ I))))) ~ (K ~ (K ~ I))).

Lemma a_op_value : a_op  = a_op_val.
Proof. cbv. auto. Qed.

Lemma a_op_size : size a_op_val = 113.
Proof. cbv. auto. Qed.

  *)


(** * Pushouts defined in terms of colimits *)
(** ** Contents
- Definition of pushouts
- Coincides with the direct definition
*)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.Combinatorics.StandardFiniteSets.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.pushouts.

Local Open Scope cat.

(** * Definition of pushouts in terms of colimits *)
Section def_po.

  Variable C : category.

  Local Open Scope stn.
  Definition One : three := ● 0.
  Definition Two : three := ● 1.
  Definition Three : three := ● 2.

  Definition pushout_graph : graph.
  Proof.
    exists three.
    use three_rec.
    - apply three_rec.
      + apply empty.
      + apply unit.
      + apply unit.
    - apply (λ _, empty).
    - apply three_rec.
      + apply empty.
      + apply empty.
      + apply empty.
  Defined.

  Definition pushout_diagram {a b c : C} (f : C ⟦a, b⟧) (g : C⟦a, c⟧) :
    diagram pushout_graph C.
  Proof.
    exists (three_rec a b c).
    use three_rec_dep; cbn.
    - use three_rec_dep; cbn.
      + apply fromempty.
      + intros _; exact f.
      + intros _; exact g.
    - intros x; apply fromempty.
    - use three_rec_dep; cbn; apply fromempty.
  Defined.

  Definition PushoutCocone {a b c : C} (f : C ⟦a, b⟧) (g : C⟦a, c⟧) (d : C)
             (f' : C ⟦b, d⟧) (g' : C ⟦c, d⟧) (H : f · f' = g · g') :
    cocone (pushout_diagram f g) d.
  Proof.
    use make_cocone.
    - use three_rec_dep; try assumption.
      apply (f · f').
    - use three_rec_dep; use three_rec_dep.
      + exact (empty_rect _).
      + intros x; apply idpath.
      + intros x; apply (! H).
      + exact (empty_rect _).
      + exact (empty_rect _).
      + exact (empty_rect _).
      + exact (empty_rect _).
      + exact (empty_rect _).
      + exact (empty_rect _).
  Defined.

  Definition isPushout {a b c d : C} (f : C ⟦a, b⟧) (g : C ⟦a, c⟧)
             (i1 : C⟦b, d⟧) (i2 : C⟦c, d⟧) (H : f · i1 = g · i2) : UU :=
    isColimCocone (pushout_diagram f g) d (PushoutCocone f g d i1 i2 H).

  Definition make_isPushout {a b c d : C} (f : C ⟦a, b⟧) (g : C ⟦a, c⟧)
             (i1 : C⟦b, d⟧) (i2 : C⟦c, d⟧) (H : f · i1 = g · i2) :
    (∏ e (h : C ⟦b, e⟧) (k : C⟦c, e⟧)(Hk : f · h = g · k ),
     iscontr (total2 (fun hk : C⟦d, e⟧ => dirprod (i1 · hk = h)(i2 · hk = k)))) →
    isPushout f g i1 i2 H.
  Proof.
    intros H' x cx. unfold is_cocone_mor; simpl in *.
    set (H1 := H' x (coconeIn cx Two) (coconeIn cx Three)).
    use (let p : f · coconeIn cx Two = g · coconeIn cx Three
                       := _ in _ ).
    { eapply pathscomp0; [apply (coconeInCommutes cx One Two tt)|].
      apply pathsinv0, (coconeInCommutes cx One Three tt). }
    set (H2 := H1 p).
    use tpair.
    + exists (pr1 (pr1 H2)).
      use three_rec_dep.
      * abstract (use (pathscomp0 _ (coconeInCommutes cx One Two tt));
        change (three_rec_dep _ _ _ _ _) with (f · i1);
        change (dmor _ _) with f; rewrite <- assoc;
        apply cancel_precomposition, (pr1 (pr2 (pr1 H2)))).
      * abstract ( apply (pr1 (pr2 (pr1 H2)))).
      * abstract (now use (pathscomp0 _ (pr2 (pr2 (pr1 H2))))).
    + abstract (intro t; apply subtypePath;
               [ intro; apply impred; intro; apply C
               | destruct t as [t p0];
                 apply path_to_ctr; split; [ apply (p0 Two) | apply (p0 Three) ]]).
  Defined.

  Definition Pushout {a b c : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) : UU :=
    ColimCocone (pushout_diagram f g).

  Definition make_Pushout {a b c : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) (d : C)
             (i1 : C⟦b,d⟧) (i2 : C ⟦c,d⟧) (H : f · i1 = g · i2)
             (ispo : isPushout f g i1 i2 H) : Pushout f g.
  Proof.
    use tpair.
    - exists d.
      use PushoutCocone; assumption.
    - apply ispo.
  Defined.

  Definition Pushouts : UU := ∏ (a b c : C) (f : C⟦a, b⟧)(g : C⟦a, c⟧), Pushout f g.

  Definition hasPushouts : UU := ∏ (a b c : C) (f : C⟦a, b⟧) (g : C⟦a, c⟧), ishinh (Pushout f g).

  Definition PushoutObject {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧}:
    Pushout f g -> C := λ H, colim H.
  (* Coercion PushoutObject : Pushout >-> ob. *)

  Definition PushoutIn1 {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po : Pushout f g) :
    C⟦b, colim Po⟧ := colimIn Po Two.

  Definition PushoutIn2 {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po : Pushout f g) :
    C⟦c, colim Po⟧ := colimIn Po Three.

  Definition PushoutSqrCommutes {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po : Pushout f g) :
    f · PushoutIn1 Po = g · PushoutIn2 Po.
  Proof.
    eapply pathscomp0; [apply (colimInCommutes Po One Two tt) |].
    apply (!colimInCommutes Po One Three tt).
  Qed.

  Definition PushoutArrow {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po : Pushout f g) (e : C)
             (h : C⟦b, e⟧) (k : C⟦c, e⟧) (H : f · h = g · k) : C⟦colim Po, e⟧.
  Proof.
    now use colimArrow; use PushoutCocone.
  Defined.

  Lemma PushoutArrow_PushoutIn1 {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧}  (Po : Pushout f g)
        (e : C) (h : C⟦b , e⟧) (k : C⟦c, e⟧) (H : f · h = g · k) :
    PushoutIn1 Po · PushoutArrow Po e h k H = h.
  Proof.
    exact (colimArrowCommutes Po e _ Two).
  Qed.

  Lemma PushoutArrow_PushoutIn2 {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po : Pushout f g)
        (e : C) (h : C⟦b, e⟧) (k : C⟦c, e⟧) (H : f · h = g · k) :
    PushoutIn2 Po · PushoutArrow Po e h k H = k.
  Proof.
    exact (colimArrowCommutes Po e _ Three).
  Qed.

  Lemma PushoutArrowUnique {a b c d : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) (Po : Pushout f g) (e : C)
        (h : C⟦b, e⟧) (k : C⟦c, e⟧) (Hcomm : f · h = g · k) (w : C⟦PushoutObject Po, e⟧)
        (H1 : PushoutIn1 Po · w = h) (H2 : PushoutIn2 Po · w = k) :
    w = PushoutArrow Po _ h k Hcomm.
  Proof.
    apply path_to_ctr.
    use three_rec_dep; try assumption.
    set (X := colimInCommutes Po One Two tt).
    use (pathscomp0 (! (maponpaths (λ h' : _, h' · w) X))).
    now rewrite <- assoc; simpl; rewrite <- H1.
  Qed.

  Definition isPushout_Pushout {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (P : Pushout f g) :
    isPushout f g (PushoutIn1 P) (PushoutIn2 P) (PushoutSqrCommutes P).
  Proof.
    apply make_isPushout.
    intros e h k HK.
    use tpair.
    - use tpair.
      + apply (PushoutArrow P _ h k HK).
      + split.
        * apply PushoutArrow_PushoutIn1.
        * apply PushoutArrow_PushoutIn2.
    - intro t.
      apply subtypePath.
      + intro. apply isapropdirprod; apply C.
      + destruct t as [t p]. simpl.
        use (PushoutArrowUnique _ _ P).
        * apply e.
        * apply (pr1 p).
        * apply (pr2 p).
  Qed.

  (** ** Pushouts to Pushouts *)

  Definition identity_is_Pushout_input {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po : Pushout f g) :
    total2 (fun hk : C⟦colim Po, colim Po⟧ => dirprod (PushoutIn1 Po · hk = PushoutIn1 Po)
                                                   (PushoutIn2 Po · hk = PushoutIn2 Po)).
  Proof.
    exists (identity (colim Po)).
    apply make_dirprod; apply id_right.
  Defined.

  (* was PushoutArrowUnique *)
  Lemma PushoutArrowUnique' {a b c d : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) (i1 : C⟦b, d⟧) (i2 : C⟦c, d⟧)
        (H : f · i1 = g · i2) (P : isPushout f g i1 i2 H) e (h : C⟦b, e⟧) (k : C⟦c, e⟧)
        (Hcomm : f · h = g · k) (w : C⟦d, e⟧) (H1 : i1 · w = h) (H2 : i2 · w = k) :
    w =  (pr1 (pr1 (P e (PushoutCocone f g _ h k Hcomm)))).
  Proof.
    apply path_to_ctr.
    use three_rec_dep; try assumption; simpl.
    change (three_rec_dep (λ n, C⟦three_rec a b c n, d⟧) _ _ _ _) with (f · i1).
    change (three_rec_dep (λ n, C⟦three_rec a b c n, e⟧) _ _ _ _) with (f · h).
    now rewrite <- assoc, H1.
  Qed.

  Lemma PushoutEndo_is_identity {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po : Pushout f g)
        (k : C⟦colim Po , colim Po⟧)
        (kH1 : PushoutIn1 Po · k = PushoutIn1 Po) (kH2 : PushoutIn2 Po · k = PushoutIn2 Po) :
    identity (colim Po) = k.
  Proof.
    apply colim_endo_is_identity.
    use three_rec_dep; cbn.
    - unfold colimIn.
      set (T := (coconeInCommutes (colimCocone Po) One Three tt)).
      use (pathscomp0 (! (maponpaths (λ h' : _, h' · k) T))).
      use (pathscomp0 _ (coconeInCommutes (colimCocone Po) One Three tt)).
      rewrite <- assoc. apply cancel_precomposition.
      apply kH2.
    - apply kH1.
    - apply kH2.
  Qed.

  Definition from_Pushout_to_Pushout {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧}
             (Po Po': Pushout f g) : C⟦colim Po , colim Po'⟧.
  Proof.
    apply (PushoutArrow Po (colim Po') (PushoutIn1 _ ) (PushoutIn2 _)).
    exact (PushoutSqrCommutes _ ).
  Defined.

  Lemma are_inverses_from_Pushout_to_Pushout {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧}
        (Po Po': Pushout f g) :
    is_inverse_in_precat (from_Pushout_to_Pushout Po Po') (from_Pushout_to_Pushout Po' Po).
  Proof.
    split; apply pathsinv0;
      apply PushoutEndo_is_identity;
      rewrite assoc;
      unfold from_Pushout_to_Pushout;
      repeat rewrite PushoutArrow_PushoutIn1;
      repeat rewrite PushoutArrow_PushoutIn2;
      auto.
  Qed.

  Lemma isiso_from_Pushout_to_Pushout {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧}
        (Po Po': Pushout f g) : is_iso (from_Pushout_to_Pushout Po Po').
  Proof.
    apply (is_iso_qinv _ (from_Pushout_to_Pushout Po' Po)).
    apply are_inverses_from_Pushout_to_Pushout.
  Defined.

  Definition iso_from_Pushout_to_Pushout {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧}
             (Po Po': Pushout f g) : iso (colim Po) (colim Po') :=
    tpair _ _ (isiso_from_Pushout_to_Pushout Po Po').

  (** pushout lemma *)

  Section pushout_lemma.

    Variables a b c d e x : C.
    Variables (f : C⟦a, b⟧) (g : C⟦a, c⟧) (h : C⟦b, e⟧) (k : C⟦c, e⟧)
              (i : C⟦b, d⟧) (j : C⟦e, x⟧) (m : C⟦d, x⟧).
    Hypothesis H1 : f · h = g · k.
    Hypothesis H2 : i · m = h · j.
    Hypothesis P1 : isPushout _ _ _ _ H1.
    Hypothesis P2 : isPushout _ _ _ _ H2.

    Lemma glueSquares : f · i · m = g · k · j.
    Proof.
      rewrite <- assoc.
      rewrite H2.
      rewrite <- H1.
      repeat rewrite <- assoc.
      apply idpath.
    Qed.

    (** TODO: isPushoutGluedSquare : isPushout (f · i) g m (k · j) glueSquares. *)

  End pushout_lemma.

    Lemma inv_from_iso_iso_from_Pushout (a b c : C) (f : C⟦a, b⟧) (g : C⟦a, c⟧)
          (Po : Pushout f g) (Po' : Pushout f g):
      inv_from_iso (iso_from_Pushout_to_Pushout Po Po') = from_Pushout_to_Pushout Po' Po.
    Proof.
      apply pathsinv0.
      apply inv_iso_unique'.
      set (T := are_inverses_from_Pushout_to_Pushout Po Po').
      apply (pr1 T).
    Qed.

  (** ** Connections to other colimits *)

  Lemma Pushout_from_Colims : Colims C -> Pushouts.
  Proof.
    intros H a b c f g; apply H.
  Defined.

End def_po.

(** * Definitions coincide
  In this section we show that pushouts defined as special colimits coincide
  with the direct definition. *)
Section pushout_coincide.

  Variable C : category.

  (** ** isPushout *)

  Lemma equiv_isPushout1 {a b c d : C} (f : C ⟦a, b⟧) (g : C ⟦a, c⟧)
        (i1 : C⟦b, d⟧) (i2 : C⟦c, d⟧) (H : f · i1 = g · i2) :
    limits.pushouts.isPushout f g i1 i2 H -> isPushout C f g i1 i2 H.
  Proof.
    intros X R cc.
    set (XR := limits.pushouts.make_Pushout f g d i1 i2 H X).
    use unique_exists.
    + use (limits.pushouts.PushoutArrow XR).
      - exact (coconeIn cc Two).
      - exact (coconeIn cc Three).
      - use (pathscomp0 ((coconeInCommutes cc One Two tt))).
        apply (!(coconeInCommutes cc One Three tt)).
    + use three_rec_dep; simpl.
      - change (three_rec_dep (λ n, C⟦three_rec a b c n, d⟧) _ _ _ _) with (f · i1).
        rewrite <- assoc, (limits.pushouts.PushoutArrow_PushoutIn1 XR).
        apply (coconeInCommutes cc One Two tt).
      - apply (limits.pushouts.PushoutArrow_PushoutIn1 XR).
      - apply (limits.pushouts.PushoutArrow_PushoutIn2 XR).
    + intros y; apply impred_isaprop; intros t; apply C.
    + intros y T.
      use limits.pushouts.PushoutArrowUnique.
      - apply (T Two).
      - apply (T Three).
  Qed.

  Lemma equiv_isPushout2 {a b c d : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧)
        (i1 : C⟦b, d⟧) (i2 : C⟦c, d⟧) (H : f · i1 = g · i2) :
    limits.pushouts.isPushout f g i1 i2 H <- isPushout C f g i1 i2 H.
  Proof.
    intros X R k h HH.
    set (XR := make_Pushout C f g d i1 i2 H X).
    use unique_exists.
    + use (PushoutArrow C XR).
      - exact k.
      - exact h.
      - exact HH.
    + split.
      - exact (PushoutArrow_PushoutIn1 C XR R k h HH).
      - exact (PushoutArrow_PushoutIn2 C XR R k h HH).
    + intros y; apply isapropdirprod; apply C.
    + intros y T.
      use (PushoutArrowUnique C _ _ XR).
      - exact R.
      - exact (pr1 T).
      - exact (pr2 T).
  Qed.

  (** ** Pushout *)

  Definition equiv_Pushout1 {a b c : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) :
    limits.pushouts.Pushout f g -> Pushout C f g.
  Proof.
    intros X.
    exact (make_Pushout
             C f g X
             (limits.pushouts.PushoutIn1 X)
             (limits.pushouts.PushoutIn2 X)
             (limits.pushouts.PushoutSqrCommutes X)
             (equiv_isPushout1 _ _ _ _ _ (limits.pushouts.isPushout_Pushout X))).
  Defined.

  Definition equiv_Pushout2 {a b c : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) :
    limits.pushouts.Pushout f g <- Pushout C f g.
  Proof.
    intros X.
    exact (limits.pushouts.make_Pushout
             f g
             (PushoutObject C X)
             (PushoutIn1 C X)
             (PushoutIn2 C X)
             (PushoutSqrCommutes C X)
             (equiv_isPushout2 _ _ _ _ _ (isPushout_Pushout C X))).
  Defined.

End pushout_coincide.


Require Import PerformanceExperiments.Harness.

Fixpoint fact (n : nat) := match n with 0 => 1 | S n' => n * fact n' end.
Fixpoint walk (n : nat) : unit := match n with 0 => tt | S n => walk n end.
Definition skip (n : nat) : unit := tt.
Inductive value := the (A : Type) (_ : A).
Arguments the : clear implicits.
Notation slown n := (the (walk (fact n) = tt) (eq_refl tt)) (only parsing).
Notation fastn n := (the (skip (fact n) = tt) (eq_refl tt)) (only parsing).

Notation iota_the v := match v return value with
                       | the A a => the A a
                       end.

Inductive speed := slow | fast.
Ltac describe_goal_gen factn speed n := idtac "Params: a-n=" n ", fact-n=" factn (* ", speed=" speed*).
Ltac step_goal_constr _ v := uconstr:(iota_the v).
Ltac redgoal_constr _ v := constr:(v).
Ltac time_solve_goal_gen_slow with_abstract n v :=
  optimize_heap;
  restart_timer;
  let v2 := (eval cbv beta iota in v) in
  finish_timing ("Tactic call beta-iota-slow");
  time "unify-beta-iota-slow" unify v v2;
  lazymatch with_abstract with
  | true => let __ := constr:(ltac:(time "abstract-unify-beta-iota-slow" abstract exact_no_check (eq_refl v)) : v = v2) in
            idtac
  | false => idtac
  end.
Ltac time_solve_goal_gen_fast with_abstract n v :=
  optimize_heap;
  restart_timer;
  let v2 := (eval cbv beta iota in v) in
  finish_timing ("Tactic call beta-iota-fast");
  time "unify-beta-iota-fast" unify v v2;
  lazymatch with_abstract with
  | true => let __ := constr:(ltac:(time "abstract-unify-beta-iota-fast" abstract exact_no_check (eq_refl v)) : v = v2) in
            idtac
  | false => idtac
  end.
Ltac mkgoal_init speed factn :=
  let factn := (eval cbv in (Z.to_nat factn)) in
  lazymatch speed with
  | slow => constr:(slown factn)
  | fast => constr:(fastn factn)
  end.


(* Parameterization of the grade lattice *)

Require Import Metalib.Metatheory.

Require Import Coq.Structures.Orders.
Require Import Coq.Bool.Sumbool.
Require Import Coq.Program.Equality.
Require Import ssreflect.

Module Type GradeSig.

Parameter grade : Set.

Parameter q_Top : grade.
Parameter q_Bot : grade.
Parameter q_C   : grade.

Parameter q_R   : grade.

Parameter q_eqb  : grade -> grade -> bool.
Parameter q_leb  : grade -> grade -> bool.
Parameter q_join : grade -> grade -> grade.
Parameter q_meet : grade -> grade -> grade.

Parameter q_eq   : grade -> grade.

(* Equality *)
Definition t := grade.
Definition eq := @Logic.eq grade.
Definition eqb  := q_eqb.
Parameter q_eq_dec : forall (A : grade) (B : grade), { A = B } + { not (A = B) }.
Instance equ  : @EqDec_eq grade := q_eq_dec.
Parameter eqb_eq : forall (n m : grade), q_eqb n m = true <-> n = m.
Definition eq_equiv : Equivalence (@Logic.eq grade) := eq_equivalence.
Definition eq_dec := q_eq_dec.
Include BackportEq.

(* Order *)
Definition leb  := q_leb.
Definition le n m := is_true (q_leb n m).
Definition q_lt n m := is_true (q_leb n m) /\ n <> m.

(* Size *)
Definition size_grade : grade -> nat := fun _ => 1%nat.
Lemma size_grade_min : forall q1, (1 <= size_grade q1). intros. unfold size_grade. auto. Qed.

(* Notation *)
Declare Scope grade_scope.
Bind Scope grade_scope with grade.
Local Open Scope grade_scope.

Infix "=?" := q_eqb (at level 70) : grade_scope.
Infix "<=?" := q_leb (at level 70) : grade_scope.
Notation "q1 <= q2" := (is_true (q_leb q1 q2)) (at level 70)  : grade_scope.
Notation "q1 < q2" := (q_lt q1 q2) (at level 70)  : grade_scope.
Notation "x * y"  := (q_join x y) : grade_scope.
Notation "x + y " := (q_meet x y)  : grade_scope.

(* join and meet are commutative and associative *)
Axiom join_assoc : forall a b c, a * (b * c) = (a * b) * c.
Axiom join_comm  : forall a b, a * b = b * a.
Axiom meet_assoc : forall a b c, a + (b + c) = (a + b) + c.
Axiom meet_comm : forall a b, a + b = b + a.

(* absorption laws *)
Axiom absorb_meet : forall a b, a * (a + b) = a.
Axiom absorb_join : forall a b, a + (a * b) = a.

(* join and meet are idempotent *)
Axiom join_idem : forall a, a * a = a.
Axiom meet_idem : forall psi, psi + psi = psi.

(* bounded *)
Axiom join_Top_r : forall a, a * q_Top = q_Top.
Axiom meet_Bot_r : forall a, a + q_Bot = q_Bot.

(* Everything is either below or above C, and you can tell which *)
Axiom order_q_C_dec : forall q, { q <= q_C } + { q_C < q }.

(* Pre order *)
Axiom leb_leq  : forall (n m : grade), (n <=? m) = true <-> n <= m.

Axiom join_leq : forall a b,  a <= b -> (a * b) = b.
Axiom leq_join : forall a b, (a * b) = b -> a <= b.

Axiom meet_leq : forall a b,  a <= b -> (a + b) = a.
Axiom leq_meet : forall a b, (a + b) = a -> a <= b.

Lemma q_leb_refl : forall n, is_true (n <=? n).
Proof. intro n. apply leq_join. rewrite join_idem. auto. Qed.

Lemma q_leb_trans: forall m n p, is_true (n <=? m) -> is_true (m <=? p) -> is_true (n <=? p).
Proof. intros. apply leq_join. apply join_leq in H. apply join_leq in H0. rewrite <- H0.
rewrite join_assoc. rewrite -> H. auto. Qed.

Instance le_preorder : PreOrder le.
Proof. split. intro x. apply q_leb_refl. unfold Transitive. intros. eapply q_leb_trans; eauto. Qed.

End GradeSig.

Declare Module Grade : GradeSig.
Export Grade.

Hint Rewrite join_assoc join_Top_r join_idem : grade.

Section GradeFacts.

(* Properties about the lattice used in the development. *)

Local Open Scope grade_scope.

Lemma q_leb_antisym : forall a b, a <= b -> b <= a -> a = b.
Proof. intros. apply join_leq in H. apply join_leq in H0. rewrite join_comm in H0.
rewrite <- H. symmetry. auto. Qed.

Lemma leq_Top : forall a, a <= q_Top.
Proof. intros. apply leq_join. rewrite join_Top_r. auto. Qed.

Lemma leq_Bot : forall a, q_Bot <= a.
Proof. intros. apply leq_meet. rewrite meet_comm. rewrite meet_Bot_r. auto. Qed.

Lemma leq_join_l : forall a b, a <= a * b.
Proof. intros. apply leq_join. rewrite join_assoc. rewrite join_idem. auto. Qed.

Lemma leq_join_r : forall a b, b <= a * b.
Proof. intros. apply leq_join. rewrite join_comm. rewrite <- join_assoc. rewrite join_idem. auto. Qed.

Lemma join_Top_l : forall a, q_Top * a = q_Top.
Proof. intros. rewrite join_comm. apply join_Top_r. Qed.

Lemma join_idem_l : forall (a b:grade), a * (a * b) = a * b.
Proof. intros. rewrite join_assoc. rewrite join_idem. auto. Qed.

Hint Rewrite join_idem_l join_Top_l : grade.

Lemma po_join_l : forall a b c , a <= b -> a * c <= b * c.
Proof. intros. apply leq_join. apply join_leq in H.
rewrite join_assoc.
replace (a * c * b * c) with (a * (c * b) * c). 2: autorewrite with grade; auto.
rewrite (join_comm c). autorewrite with grade.
rewrite <- join_assoc. rewrite join_idem.
rewrite H. auto. Qed.

Lemma po_join_r : forall a b c , a <= b -> c * a <= c * b.
Proof.
  intros. apply leq_join. apply join_leq in H.
  rewrite (join_comm c a). rewrite join_assoc.
  replace (a * c * c * b) with (a * (c * c) * b). rewrite join_idem.
  rewrite <- join_assoc. rewrite (join_comm c b). rewrite join_assoc.
  rewrite H. auto.
  rewrite join_assoc. auto.
Qed.

Lemma join_lub : forall a b c,
    a <= c -> b <= c -> a * b <= c.
Proof.
  intros. apply leq_join. apply join_leq in H. apply join_leq in H0.
  rewrite <- join_assoc. rewrite H0. auto. Qed.

Lemma leq_meet_l : forall a b, a + b <= a.
Proof. intros. apply leq_meet. rewrite (meet_comm a b).
       rewrite <- meet_assoc.
       rewrite meet_idem. auto. Qed.

Lemma leq_meet_r : forall a b, a + b <= b.
Proof. intros. apply leq_meet.
       rewrite <- meet_assoc. rewrite meet_idem. auto. Qed.

Lemma po_meet_l : forall a b c , a <= b -> a + c <= b + c.
Proof.
  intros. apply leq_meet. apply meet_leq in H.
  rewrite meet_assoc.
  replace (a + c + b + c) with (a + (c + b) + c).
  rewrite (meet_comm c b). rewrite meet_assoc.
  rewrite H. rewrite <- meet_assoc. rewrite meet_idem. auto.
  rewrite meet_assoc. auto.
Qed.

Lemma po_meet_r : forall a b c , a <= b -> c + a <= c + b.
Proof. intros. rewrite meet_comm. rewrite (meet_comm c b).
       apply po_meet_l. auto. Qed.

Lemma still_higher : forall a b,
  q_C < a -> b <= q_C -> q_C < a * b.
Proof.
  intros. inversion H.
  apply join_leq in H0. apply join_leq in H1.
  split.
  - apply leq_join.
    rewrite join_assoc. rewrite H1. auto.
  - move => h. apply H2. apply q_leb_antisym. apply leq_join. auto.
    apply leq_join.
    rewrite <- H0. rewrite join_assoc. rewrite <- h. rewrite join_idem.
    symmetry. auto.
Qed.

Lemma meet_mult : forall {a b},
      a <= q_C ->
      q_C + (b * a) = (q_C + b) * a.
Proof.
  intros.
  destruct (order_q_C_dec b).
  + move: (meet_leq _ _ i) => h1. rewrite meet_comm in h1. rewrite h1.
    have LT: (a * b <= q_C). apply join_lub; auto.
    rewrite meet_comm.
    move: (meet_leq _ _ LT) => h2. rewrite join_comm in h2. rewrite h2.
    rewrite join_comm. auto.
  + inversion q. clear q. clear H1.
    move: (meet_leq _ _ H0) => h1. rewrite h1.
    have LT: (q_C <= a * b).
    transitivity (a * q_C). eapply leq_join_r. eapply po_join_r. auto.
    apply meet_leq in LT. rewrite join_comm in LT. rewrite LT.
    apply join_leq in H. rewrite <- H at 1. rewrite join_comm. auto.
Qed.

Lemma lt_not_leq : forall {psi psi0},
 psi < psi0 -> ~ psi0 <= psi.
Proof.
  intros psi psi0 H. inversion H. move=>h. apply H1. eapply q_leb_antisym; auto. Qed.

Lemma not_leq_lower : forall {psi psi0 phi},
    psi <= phi -> ~ psi0 <= phi -> ~ psi0 <= psi.
Proof.
  intros. move=> h. apply H0. transitivity psi; auto.
Qed.

End GradeFacts.


(*
    Copyright (C) 2012  G. Gonthier, B. Ziliani, A. Nanevski, D. Dreyer

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

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

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

From mathcomp
Require Import ssreflect ssrbool seq eqtype.
From LemmaOverloading
Require Import heaps.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Same as noalias but with Coq Type Classes. *)

(* Scan *)
Definition scan_axiom h s :=
  def h -> uniq s /\ forall x, x \in s -> x \in dom h.

Class Scan (h : heap) :=
        { seq_of : seq ptr ;
          scan : scan_axiom h seq_of }.

Program Instance scan_union h1 h2 (f1 : Scan h1) (f2 : Scan h2) :
                   Scan (h1:+h2) | 2 := {| seq_of := @seq_of _ f1 ++ @seq_of _ f2 |}.
Next Obligation.
case: f1 f2=>s1 /= sc1 [s2 /= sc2] D.
case/(_ (defUnl D)): sc1=>U1 H1; case/(_ (defUnr D)): sc2=>U2 H2.
split=>[|x]; last first.
- rewrite mem_cat; case/orP; [move/H1 | move/H2];
  by rewrite domUn !inE /= D => -> //=; rewrite orbT.
rewrite cat_uniq U1 U2 andbT -all_predC.
apply/allP=>x; move/H2=>H3; apply: (introN idP); move/H1=>H4.
by case: defUn D=>// _ _; move/(_ _ H4); rewrite H3.
Qed.

Program Instance scan_ptr A x (v : A) : Scan (x:->v) | 1 := {| seq_of :=  [:: x] |}.
Next Obligation.
rewrite /scan_axiom /= defPt => D; split=>//.
by move=>y; rewrite inE; move/eqP=>->; rewrite domPt inE /= eq_refl D.
Qed.

Program Instance scan_default h : Scan h | 10 := {| seq_of := [::] |}.
Next Obligation.
by move=>_; split.
Qed.

Lemma scanE x h (f : Scan h): def h -> x \in seq_of -> x \in dom h.
Proof. move=>D; case:f=>s /= [//|_]; apply. Qed.

Example ex_scan x y h :
          let: hp := (y :-> 1 :+ h :+ x :-> 2) in def hp -> x \in dom hp.
Proof.
move=>D.
apply: scanE=>//=.
by rewrite ?in_cons ?eqxx ?orbT.
Abort.

(* Search *)
Class Search (x : ptr) (s : seq ptr) :=
        { search : x \in s }.

Program Instance search_found x s : Search x (x :: s).
Next Obligation.
by rewrite inE eq_refl.
Qed.

Program Instance search_recurse x y s (f : Search x s) : Search x (y :: s) | 5.
Next Obligation.
by case: f; rewrite inE=>->; rewrite orbT.
Qed.

Example ex_find (x y z : ptr) : x \in [:: z; x; y].
Proof.
rewrite search.
Abort.

(* Search2 *)
Definition search2_axiom (x y : ptr) (s : seq ptr) :=
  [/\ x \in s, y \in s & uniq s -> x != y].

Class Search2 x y s := { search2 : search2_axiom x y s}.

Program Instance search2_foundx x y s (s1 : Search y s) : Search2 x y (x :: s).
Next Obligation.
case: s1=>s2; rewrite /search2_axiom !inE eq_refl.
by rewrite s2 orbT; split=>//; case/andP=>H2 _; case: eqP s2 H2=>// -> ->.
Qed.

Program Instance search2_foundy x y s (f : Search x s) : Search2 x y (y :: s).
Next Obligation.
case: f=>H1; rewrite /search2_axiom !inE eq_refl.
by rewrite H1 orbT; split=>//; case/andP=>H2 _; case: eqP H1 H2=>// -> ->.
Qed.

Program Instance search2_foundz x y z s (f : Search2 x y s) : Search2 x y (z :: s) | 1.
Next Obligation.
case: f=>[[H1 H2 H3]].
rewrite /search2_axiom /= !inE /= H1 H2 !orbT; split=>//.
by case/andP=>_; apply: H3.
Qed.

Lemma find2E x y s (f : Search2 x y s) : uniq s -> x != y.
Proof. by move: f=>[[_ _]]; apply. Qed.

Arguments find2E [x y s f].

Example ex_find2 (w x y z : ptr) : uniq [:: z; y; w; x] -> x != y.
move=>H.
rewrite (find2E H).
Abort.

(* Now, the main lemma *)
Lemma noaliasR h x y (sc : Scan h) (s2 : Search2 x y seq_of):
               def h -> x != y.
Proof.
move=>D.
by case: sc s2=>s /= [//|] U _ [/= [_ _ H3]]; apply: H3.
Qed.

Arguments noaliasR [h x y sc s2].

Hint Extern 20 (Search2 _ _ _) => progress simpl  : typeclass_instances.

Example ex_noalias x1 x2 : def (x2 :-> 1 :+ x1 :-> 2) -> x1 != x2.
Proof.
move=>D.
by eapply (noaliasR D).
Abort.

Example ex_noalias2 x1 x2 h : def (x2 :-> 1 :+ h :+ x1 :-> 2) -> x1 != x2.
Proof.
move=>D.
by eapply (noaliasR D).
Abort.

Example exnc A (x1 x2 x3 x4 : ptr) (v1 v2 : A) (h1 h2 : heap) :
  def (h1 :+ x2 :-> 1 :+ h2 :+ x1 :-> v2 :+ (x3 :-> v1 :+ empty)) ->
     (x1 != x2) /\
     (x1 != x2) && (x2 != x3) && (x3 != x1) /\
     (x2 == x3) = false /\ (x1 == x2) = false /\
     ((x1 != x2) && (x2 != x3)) = (x1 != x2) /\
     ((x1 != x2) && (x2 != x3)) = (x1 != x2) /\
     ((x1 != x2) && (x2 != x3)) = (x1 != x2) /\
     ((x1 != x2) && (x2 != x3)) = (x1 != x2) /\
     (x1 != x2) && (x2 != x3) && (x1 != x4) && (x3 != x1).

Proof.
move=>D.
split.
- by apply: (noaliasR D).
split.
  (* backwards reasoning works *)
- by rewrite !(noaliasR D).
split.
  (* subterm selection works *)
- by rewrite [x2 == x3](negbTE (noaliasR D)).
split.
- (* composition works *)
  by rewrite (negbTE (noaliasR D)).
split.
- by rewrite [x2 != x3](noaliasR D) andbT.
split.
- by rewrite (noaliasR (x := x2) D) andbT.
split.
- by rewrite (noaliasR (y := x3) D) andbT.
split.
- by rewrite (noaliasR (x := x2) (y := x3) D) andbT.
(* rewriting skips the subgoals that don't apply *)
(* just as it should *)
rewrite !(negbTE (noaliasR D)).
admit.
Abort.


Require Import RamifyCoq.CertiGC.gc_spec.

Lemma sem_sub_pp_total_space: forall s,
    isptr (space_start s) ->
    force_val
      (sem_sub_pp int_or_ptr_type
                  (offset_val (WORD_SIZE * total_space s) (space_start s))
                  (space_start s)) = Vint (Int.repr (total_space s)).
Proof.
  intros. destruct (space_start s); try contradiction. simpl. destruct (eq_block b b).
  2: exfalso; apply n; reflexivity.
  inv_int i. rewrite ptrofs_add_repr, ptrofs_sub_repr.
  replace (ofs + WORD_SIZE * total_space s - ofs) with
      (WORD_SIZE * total_space s)%Z by omega. simpl.
  pose proof (total_space_signed_range s). unfold Ptrofs.divs.
  rewrite !Ptrofs.signed_repr by rep_omega. unfold vptrofs, Archi.ptr64.
  rewrite WORD_SIZE_eq, Z.mul_comm, Z.quot_mul, ptrofs_to_int_repr by omega.
  reflexivity.
Qed.

Lemma sem_sub_pp_rest_space: forall s,
    isptr (space_start s) ->
    force_val
      (sem_sub_pp int_or_ptr_type
                  (offset_val (WORD_SIZE * total_space s) (space_start s))
                  (offset_val (WORD_SIZE * used_space s) (space_start s))) =
    Vint (Int.repr (total_space s - used_space s)).
Proof.
  intros. destruct (space_start s); try contradiction. simpl. destruct (eq_block b b).
  2: exfalso; apply n; reflexivity.
  inv_int i.
  rewrite !ptrofs_add_repr, ptrofs_sub_repr.
  replace (ofs + WORD_SIZE * total_space s - (ofs + WORD_SIZE * used_space s)) with
          (WORD_SIZE * (total_space s - used_space s))%Z by
      (rewrite Z.mul_sub_distr_l; omega). simpl.
  pose proof (rest_space_signed_range s). rewrite <- Z.mul_sub_distr_l in H0.
  unfold Ptrofs.divs. rewrite !Ptrofs.signed_repr by rep_omega.
  unfold vptrofs, Archi.ptr64. rewrite WORD_SIZE_eq, Z.mul_comm, Z.quot_mul,
                               ptrofs_to_int_repr by omega. reflexivity.
Qed.

Lemma t_info_space_address: forall t_info i,
    0 <= i -> isptr (ti_heap_p t_info) ->
    force_val (sem_add_ptr_int space_type Signed
                               (offset_val 0 (ti_heap_p t_info)) (vint i)) =
    space_address t_info (Z.to_nat i).
Proof.
  intros. rewrite isptr_offset_val_zero by assumption.
  rewrite sem_add_pi_ptr_special'; auto. unfold space_address.
  rewrite Z2Nat.id by omega. simpl. f_equal.
Qed.

Ltac tc_val_Znth := entailer!; rewrite Znth_map by assumption;
                    unfold space_tri; apply isptr_is_pointer_or_null;
                    try assumption.

Lemma body_garbage_collect:
  semax_body Vprog Gprog f_garbage_collect garbage_collect_spec.
Proof.
  start_function.
  sep_apply (create_mem_mgr gv).
  unfold before_gc_thread_info_rep, heap_struct_rep. Intros. forward. pose proof H.
  destruct H as [? _]. pose proof (gt_gs_compatible _ _ H _ (graph_has_gen_O _)).
  destruct H3 as [? [? ?]].
  replace (heap_head (ti_heap t_info)) with (nth_space t_info 0) by
      (destruct (heap_head_cons (ti_heap t_info)) as [hs [hl [? ?]]];
       unfold nth_space; rewrite H6, H7; simpl; reflexivity).
  assert (isptr (space_start (nth_space t_info 0))) by
      (rewrite <- H3; apply start_isptr). do 2 forward. deadvars!.
  rewrite upd_Znth0, sublist_1_cons, Zlength_cons, sublist_same by omega.
  fold (space_tri (nth_space t_info 0)). rewrite <- map_cons.
  replace (nth_space t_info 0 :: tl (spaces (ti_heap t_info))) with
      (spaces (ti_heap t_info)) by
      (destruct (heap_head_cons (ti_heap t_info)) as [hs [hl [? ?]]];
       unfold nth_space; rewrite H7; simpl; reflexivity).
  gather_SEP (data_at sh heap_type _ _) (heap_rest_rep _).
  gather_SEP (data_at sh thread_info_type _ _)
             (data_at sh heap_type _ _ * heap_rest_rep _).
  replace_SEP 0 (thread_info_rep sh t_info ti) by
    (unfold thread_info_rep, heap_struct_rep; entailer!;
    do 2 (unfold_data_at (data_at _ _ _ _); cancel)).
  forward_for_simple_bound
    11
    (EX i: Z, EX g': LGraph, EX roots': roots_t, EX t_info': thread_info,
     PROP (super_compatible (g', t_info', roots') f_info outlier;
           garbage_collect_condition g' t_info' roots' f_info;
           safe_to_copy_to_except g' (Z.to_nat i);
           firstn_gen_clear g' (Z.to_nat i);
           garbage_collect_loop f_info (nat_inc_list (Z.to_nat i)) roots g roots' g';
           graph_has_gen g' (Z.to_nat i))
     LOCAL (temp _h (ti_heap_p t_info'); temp _fi fi; temp _ti ti;
            gvars gv)
     SEP (thread_info_rep sh t_info' ti;
          mem_mgr gv;
          all_string_constants rsh gv;
          fun_info_rep rsh f_info fi;
          outlier_rep outlier;
          graph_rep g';
          ti_token_rep t_info')).
  - Exists g roots t_info. destruct H2 as [? [? [? ?]]].
    pose proof (graph_has_gen_O g). entailer!. split; [|split; [|split]].
    + red. auto.
    + apply stc_stcte_O_iff; assumption.
    + red. intros. simpl in H12. omega.
    + unfold nat_inc_list. simpl. constructor.
  - cbv beta. Intros g' roots' t_info'. unfold thread_info_rep. Intros.
    unfold heap_struct_rep. assert (0 <= i + 1 < Zlength (spaces (ti_heap t_info'))) by
        (rewrite spaces_size; rep_omega).
    pose proof (space_start_is_pointer_or_null _ _ _ (proj1 H8) H14). forward.
    1: entailer!; rewrite Znth_map by assumption; unfold space_tri; assumption.
    rewrite Znth_map by assumption. unfold space_tri at 1.
    forward_if
      (EX g1: LGraph, EX t_info1: thread_info,
       PROP (super_compatible (g1, t_info1, roots') f_info outlier;
             garbage_collect_condition g1 t_info1 roots' f_info;
             safe_to_copy_to_except g1 (Z.to_nat i);
             firstn_gen_clear g1 (Z.to_nat i);
             new_gen_relation (Z.to_nat (i + 1)) g' g1;
             graph_has_gen g1 (Z.to_nat (i + 1)))
       LOCAL (temp _h (ti_heap_p t_info1); temp _fi fi; temp _ti ti;
              gvars gv; temp _i (Vint (Int.repr i)))
       SEP (thread_info_rep sh t_info1 ti;
            ti_token_rep t_info1;
            mem_mgr gv;
            all_string_constants rsh gv;
            fun_info_rep rsh f_info fi;
            outlier_rep outlier;
            graph_rep g1)).
    + remember (space_start (Znth (i + 1) (spaces (ti_heap t_info')))).
      Transparent denote_tc_test_eq. destruct v0; try contradiction.
      * simpl in H15. subst i0. simpl. entailer!.
      * simpl. entailer!. assert (isptr (Vptr b i0)) by exact I. rewrite Heqv0 in *.
        pull_left (heap_rest_rep (ti_heap t_info')). pull_left (graph_rep g').
        destruct H8. rewrite <- (space_start_isptr_iff g') in H23 by assumption.
        sep_apply (graph_and_heap_rest_valid_ptr g' t_info' _ H23); auto.
        1: destruct H9 as [? [? [? [? ?]]]]; assumption.
        rewrite nth_space_Znth, Z2Nat.id by omega.
        sep_apply (valid_pointer_weak
                     (space_start (Znth (i + 1) (spaces (ti_heap t_info'))))).
        apply extend_weak_valid_pointer. Opaque denote_tc_test_eq.
    + assert (0 <= i < Zlength (spaces (ti_heap t_info'))) by omega.
      pose proof (space_start_isptr _ _ _ (proj1 H8) H17 H13). forward.
      1: entailer!; rewrite Znth_map by assumption; unfold space_tri;
        apply isptr_is_pointer_or_null, isptr_offset_val'; assumption.
      rewrite Znth_map by assumption. unfold space_tri at 1. forward.
      1: entailer!; rewrite Znth_map by assumption; unfold space_tri;
        apply isptr_is_pointer_or_null; assumption.
      rewrite Znth_map by assumption. unfold space_tri at 1. forward.
      1: entailer!; destruct (space_start (Znth i (spaces (ti_heap t_info'))));
        try contradiction; simpl; unfold denote_tc_samebase;
          apply prop_right; simpl; destruct (peq b b); simpl; [|apply n]; auto.
      simpl sem_binary_operation'.
      change (Tpointer tvoid {| attr_volatile := false; attr_alignas := Some 2%N |})
        with int_or_ptr_type. remember (Znth i (spaces (ti_heap t_info'))).
      rewrite sem_sub_pp_total_space by assumption. subst s.
      pose proof H9. destruct H19 as [_ [_ [_ [_ ?]]]].
      pose proof (ti_size_gen _ _ _ (proj1 H8) H13 H19). unfold gen_size in H20.
      rewrite nth_space_Znth, Z2Nat.id in H20 by omega. rewrite H20. clear H19 H20.
      assert_PROP (isptr (ti_heap_p t_info')) by entailer!.
      gather_SEP (data_at sh heap_type _ _) (heap_rest_rep _).
      gather_SEP (data_at sh thread_info_type _ ti) (data_at sh heap_type _ _ * heap_rest_rep _).
      (* gather_SEP 0 1 2. *)
      replace_SEP 0 (thread_info_rep sh t_info' ti) by
          (unfold thread_info_rep, heap_struct_rep; entailer!). pose proof H14.
      rewrite spaces_size in H20. unfold thread_info_rep. Intros.
      rewrite hsr_single_explicit with (i := i + 1). 2: assumption.
      2: rewrite Zlength_map, spaces_size; reflexivity. Intros.
      freeze [0;2;3;4;7;8;9] FR.
      sep_apply (data_at_data_at_
                   sh space_type
                   (Znth (i + 1) (map space_tri (spaces (ti_heap t_info'))))
                   (space_address t_info' (Z.to_nat (i + 1)))).
      pose proof (t_info_space_address _ _ (proj1 H14) H19).
      assert (0 <= 2 * nth_gen_size (Z.to_nat i) < MAX_SPACE_SIZE) by
          (rewrite ngs_S by omega; apply ngs_range; rep_omega).
      forward_call (sh, (space_address t_info' (Z.to_nat (i + 1))),
                    (2 * nth_gen_size (Z.to_nat i))%Z, gv, rsh).
      * rewrite Int.signed_repr by (apply ngs_int_singed_range; rep_omega).
        rewrite ngs_S by omega. apply ngs_int_singed_range. rep_omega.
      * simpl. entailer!.
      * rewrite ngs_S by omega. Intros p. rewrite ngs_S in H22 by omega.
        assert (Hso: 0 <= 0 <= (nth_gen_size (Z.to_nat (i + 1)))) by omega.
        rewrite data_at__isptr. Intros.
        remember (Build_space p 0
                              (nth_gen_size (Z.to_nat (i + 1))) Ews Hso (proj2 H22))
          as sp. remember (Build_generation_info p O Ews Pp writable_Ews) as gi.
        assert (forall (gr: LGraph) (gen: nat),
                   generation_space_compatible gr (gen, gi, sp)) by
            (intros; red; rewrite Heqsp, Heqgi; simpl; intuition).
        remember (lgraph_add_new_gen g' gi) as g1.
        remember (ti_add_new_space t_info' sp _ H20) as t_info1. pose proof H16.
        rewrite <- (space_start_isnull_iff g') in H16; auto. 2: apply (proj1 H8).
        assert (number_of_vertices gi = O) by (subst gi; simpl; reflexivity).
        assert (super_compatible (g1, t_info1, roots') f_info outlier). {
          subst g1 t_info1. apply super_compatible_add; auto.
          replace (i + 1 - 1) with i by omega. assumption. }
        assert (firstn_gen_clear g1 (Z.to_nat i)) by
            (subst g1; apply firstn_gen_clear_add; assumption).
        assert (new_gen_relation (Z.to_nat (i + 1)) g' g1). {
          subst g1. red. rewrite if_false by assumption. exists gi. split; auto. }
        gather_SEP 2 5.
        (* gather_SEP (malloc_token Ews (tarray int_or_ptr_type (nth_gen_size (Z.to_nat (i + 1)))) p) (FRZL FR). *)
        assert (total_space sp = nth_gen_size (Z.to_nat (i + 1))) by
            (subst sp; simpl; reflexivity). rewrite <- H29.
        assert (space_start sp = p) by (subst sp; simpl; reflexivity). rewrite <- H30.
        assert (space_start sp <> nullval) by
            (rewrite H30; destruct p; try contradiction; intro; inversion H31).
        sep_apply (ti_token_rep_add t_info' sp (i + 1) H20); auto.
        replace (space_start sp,
                 (space_start sp,
                  offset_val (WORD_SIZE * total_space sp) (space_start sp))) with
            (space_tri sp) by
            (unfold space_tri; do 2 f_equal; subst sp; simpl;
             rewrite Z.mul_0_r, isptr_offset_val_zero by assumption; reflexivity).
        thaw FR.
        gather_SEP 11 2 3.
        rewrite (heap_struct_rep_add t_info' sh sp (i + 1) H20), <- Heqt_info1.
        replace (ti_heap_p t_info') with (ti_heap_p t_info1) by
            (subst t_info1; simpl; reflexivity).
        replace (ti_args t_info') with (ti_args t_info1) by
            (subst t_info1; simpl; reflexivity).
        replace_SEP 9 (space_rest_rep sp). {
          unfold space_rest_rep. rewrite if_false by assumption.
          replace (space_sh sp) with Ews by (subst sp; simpl; reflexivity).
          replace (used_space sp) with 0 by (subst sp; simpl; reflexivity).
          rewrite Z.sub_0_r, Z.mul_0_r, isptr_offset_val_zero by
              (subst; simpl; assumption). entailer!. }
        gather_SEP 3 9.
        (* gather_SEP (heap_rest_rep (ti_heap t_info')) (space_rest_rep sp). *)
        rewrite (heap_rest_rep_add _ _ (i + 1) H20), <- Heqt_info1 by assumption.

        gather_SEP 3 1 0.
        (* gather_SEP (heap_struct_rep sh _ _) *)
                   (* (heap_rest_rep _). *)
        rewrite <- sepcon_assoc.
        replace_SEP 0 (thread_info_rep sh t_info1 ti) by
            (unfold thread_info_rep; entailer!). rewrite (graph_rep_add g' gi); auto.
        3: destruct H9 as [? [? [? [? ?]]]]; assumption.
        2: apply graph_unmarked_copy_compatible;
          destruct H9 as [? [? [? [? ?]]]]; assumption. rewrite <- Heqg1.
        assert (graph_has_gen g1 (Z.to_nat (i + 1))). {
          subst g1. rewrite ang_graph_has_gen. right. clear -H13 H16 H7.
          unfold graph_has_gen in *.
          replace (Z.to_nat (i + 1)) with (Z.to_nat i + 1)%nat in *. 1: omega.
          change (S O) with (Z.to_nat 1). rewrite <- Z2Nat.inj_add by omega. auto. }
        assert (safe_to_copy_to_except g1 (Z.to_nat i)) by
            (subst g1; apply stcte_add; auto; subst gi; simpl; reflexivity).
        assert (garbage_collect_condition g1 t_info1 roots' f_info) by
            (subst g1 t_info1; apply gcc_add; assumption).
        Opaque super_compatible. Exists g1 t_info1. entailer!.
    + forward. remember (space_start (Znth (i + 1) (spaces (ti_heap t_info')))).
      assert (isptr v). {
        destruct v; try contradiction. simpl in H15. subst i0. contradiction.
        simpl. exact I. } subst v. rewrite <- (space_start_isptr_iff g') in H17; auto.
      2: destruct H8; auto. assert (new_gen_relation (Z.to_nat (i + 1)) g' g') by
          (unfold new_gen_relation; rewrite if_true; auto).
      Exists g' t_info'. entailer!. unfold thread_info_rep, heap_struct_rep.
      entailer!.
    + Intros g1 t_info1. forward_if True. 1: contradiction.
      1: forward; Intros; entailer!. Intros. assert_PROP (isptr (ti_heap_p t_info1))
        by (unfold thread_info_rep, heap_struct_rep; entailer!).
      assert (Z.to_nat (i + 1) = S (Z.to_nat i)) by
          (rewrite Z2Nat.inj_add by omega; simpl; omega).
      assert (do_generation_condition
                g1 t_info1 roots' f_info (Z.to_nat i) (Z.to_nat (i + 1))) by
          (rewrite H23 in *; apply gc_cond_implies_do_gen_cons; auto;
           apply (proj1 H16)). pose proof (t_info_space_address _ _ (proj1 H7) H22).
      pose proof (t_info_space_address _ _ (proj1 H14) H22).
      forward_call (rsh, sh, gv, fi, ti, g1, t_info1, f_info, roots', outlier,
                    (Z.to_nat i), (Z.to_nat (i + 1))). 1: simpl; entailer!.
      1: do 4 (split; auto); rewrite H23; apply n_Sn.
      Intros vret. destruct vret as [[g2 t_info2] roots2]. simpl fst in *.
      simpl snd in *. replace (ti_heap_p t_info1) with (ti_heap_p t_info2) by
          (rewrite (proj1 H28); reflexivity). unfold thread_info_rep, heap_struct_rep.
      Intros. assert (graph_has_gen g2 (Z.to_nat (i + 1))) by
          (rewrite <- do_gen_graph_has_gen; eauto).
      assert (graph_has_gen g2 (Z.to_nat i)) by (red in H30 |-* ; omega).
      assert (isptr (space_start (Znth i (spaces (ti_heap t_info2))))). {
        rewrite <- (Z2Nat.id i), <- nth_space_Znth,
        <- (proj1 (gt_gs_compatible _ _ (proj1 H27) _ H31)) by omega.
        apply start_isptr. }
      assert (0 <= i < Zlength (spaces (ti_heap t_info2))) by
          (rewrite spaces_size; rep_omega). forward.
      1: tc_val_Znth; rewrite isptr_offset_val; assumption. forward. 1: tc_val_Znth.
      rewrite Znth_map by assumption. unfold space_tri at 1 2.
      assert (0 <= i + 1 < Zlength (spaces (ti_heap t_info2))) by
          (rewrite spaces_size; rep_omega).
      assert (isptr (space_start (Znth (i + 1) (spaces (ti_heap t_info2))))). {
        rewrite <- (Z2Nat.id (i + 1)), <- nth_space_Znth,
        <- (proj1 (gt_gs_compatible _ _ (proj1 H27) _ H30)) by omega.
        apply start_isptr. } forward.
      1: tc_val_Znth; rewrite isptr_offset_val; assumption. forward.
      1: tc_val_Znth; rewrite isptr_offset_val; assumption.
      rewrite Znth_map by assumption. unfold space_tri at 1 2. rewrite H23 in *.
      assert (garbage_collect_condition g2 t_info2 roots2 f_info) by
          (eapply (do_gen_gcc g1 t_info1 roots'); eauto).
      assert (firstn_gen_clear g2 (Z.to_nat (i + 1))) by
          (rewrite H23; eapply do_gen_firstn_gen_clear; eauto).
      assert (safe_to_copy_to_except g2 (Z.to_nat (i + 1))) by
          (rewrite H23; eapply do_gen_stcte; eauto). gather_SEP 4 5 6.
      replace_SEP 0 (thread_info_rep sh t_info2 ti) by
          (unfold thread_info_rep, heap_struct_rep; entailer!).
      assert (garbage_collect_loop
                f_info (nat_inc_list (Z.to_nat (i + 1))) roots g roots2 g2) by
          (rewrite H23, nat_inc_list_S; eapply gcl_add_tail; eauto).
      replace_SEP 5 (ti_token_rep t_info2) by
          (erewrite ti_rel_token_the_same; eauto; entailer!).
      forward_if.
      * destruct (space_start (Znth i (spaces (ti_heap t_info2)))); try contradiction.
        destruct (space_start (Znth (i + 1) (spaces (ti_heap t_info2))));
          try contradiction. Transparent denote_tc_samebase.
        unfold denote_tc_samebase. simpl. Opaque denote_tc_samebase. entailer!.
      * change (Tpointer tvoid
                         {| attr_volatile := false; attr_alignas := Some 2%N |})
          with int_or_ptr_type in H39.
        rewrite sem_sub_pp_total_space, sem_sub_pp_rest_space in H40; auto.
        simpl in H40. apply typed_true_of_bool in H40. rewrite negb_true_iff in H40.
        apply lt_repr_false in H40. 2: apply rest_space_repable_signed.
        2: apply total_space_repable_signed.
        assert (safe_to_copy_gen g2 (Z.to_nat i) (S (Z.to_nat i))). {
          red. destruct H27 as [? _]. destruct H36 as [_ [_ [_ [_ ?]]]].
          do 2 (erewrite <- ti_size_gen; eauto). rewrite <- H23 in *.
          unfold gen_size, graph_gen_size. destruct (gt_gs_compatible _ _ H27 _ H30)
            as [_ [_ ?]]. rewrite H41, !nth_space_Znth, !Z2Nat.id; omega. }
        assert (graph_thread_info_compatible g2 t_info2) by (apply (proj1 H27)).
        assert (graph_gen_clear g2 O) by (apply H37; rewrite H23; omega).
        forward_call (rsh, sh, gv, fi, ti, g2, t_info2, f_info, roots2). forward.
        Exists g2 t_info2 roots2. entailer!. split.
        -- exists (Z.to_nat i). rewrite <- H23 at 1. split; assumption.
        -- rewrite H23 in H38. eapply safe_to_copy_complete; eauto.
      * forward. Intros. Exists g2 roots2 t_info2. rewrite <- H23 in *. entailer!.
  - Intros g2 roots2 t_info2. unfold all_string_constants. Intros.
    forward_call ((gv ___stringlit_13),
                  (map init_data2byte (gvar_init v___stringlit_13)), rsh).
    exfalso; assumption.
Qed.


Require Import GhostSimulations.
Require Import Raft.
Require Import RaftRefinementInterface.

Require Import CommonTheorems.

Require Import SpecLemmas.
Require Import RefinementSpecLemmas.

Require Import UpdateLemmas.
Local Arguments update {_} {_} {_} _ _ _ _ : simpl never.

Require Import LogMatchingInterface.
Require Import LeaderLogsTermSanityInterface.
Require Import LeaderLogsSortedInterface.
Require Import SortedInterface.
Require Import LeaderLogsSublogInterface.
Require Import LeaderLogsContiguousInterface.
Require Import TermsAndIndicesFromOneInterface.

Require Import LeaderLogsLogMatchingInterface.

Section LeaderLogsLogMatching.

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

  Context {rri : raft_refinement_interface}.
  Context {lmi : log_matching_interface}.
  Context {lltsi : leaderLogs_term_sanity_interface}.
  Context {llsi : leaderLogs_sorted_interface}.
  Context {si : sorted_interface}.
  Context {llsli : leaderLogs_sublog_interface}.
  Context {llci : leaderLogs_contiguous_interface}.
  Context {taifoi : terms_and_indices_from_one_interface}.

  Definition leaderLogs_entries_match_nw (net : network) : Prop :=
    forall h llt ll p t src pli plt es ci,
      In (llt, ll) (leaderLogs (fst (nwState net h))) ->
      In p (nwPackets net) ->
      pBody p = AppendEntries t src pli plt es ci ->
      (forall e1 e2,
         eIndex e1 = eIndex e2 ->
         eTerm e1 = eTerm e2 ->
         In e1 es ->
         In e2 ll ->
         (forall e3,
            eIndex e3 <= eIndex e1 ->
            In e3 es ->
            In e3 ll) /\
         (pli <> 0 ->
          exists e4,
            eIndex e4 = pli /\
            eTerm e4 = plt /\
            In e4 ll)).

  Definition leaderLogs_entries_match (net : network) : Prop :=
    leaderLogs_entries_match_host net /\
    leaderLogs_entries_match_nw net.

  Lemma leaderLogs_entries_match_init :
    refined_raft_net_invariant_init leaderLogs_entries_match.
  Proof using.
    unfold refined_raft_net_invariant_init, leaderLogs_entries_match,
           leaderLogs_entries_match_host, leaderLogs_entries_match_nw.
    simpl.
    intuition.
  Qed.

  Ltac update_destruct :=
    match goal with
      | [ H : context [ update _ ?x _ ?y ] |- _ ] =>
        destruct (name_eq_dec x y); subst; rewrite_update; simpl in *
      | [ |- context [ update _ ?x _ ?y ] ] =>
        destruct (name_eq_dec x y); subst; rewrite_update; simpl in *
    end.

  Lemma entries_match_cons_gt_maxTerm :
    forall x xs ys,
      sorted xs ->
      sorted ys ->
      eIndex x > maxIndex xs ->
      eTerm x > maxTerm ys ->
      entries_match xs ys ->
      entries_match (x :: xs) ys.
  Proof using.
    unfold entries_match.
    intuition; simpl in *; intuition; subst; subst;
    try match goal with
        | [ H : In _ _ |- _ ] => apply maxTerm_is_max in H; [| solve[auto]]; omega
        | [ H : In _ _ |- _ ] => apply maxIndex_is_max in H; [| solve[auto]]; omega
      end.
    - match goal with
        | [ H : _ |- _ ] => solve [eapply H; eauto]
      end.
    - right. match goal with
        | [ H : _ |- _ ] => solve [eapply H; eauto]
      end.
  Qed.

  Lemma entries_match_cons_sublog :
    forall x xs ys,
      sorted xs ->
      sorted ys ->
      eIndex x > maxIndex xs ->
      entries_match xs ys ->
      (forall y, In y ys -> eTerm x = eTerm y -> In y xs) ->
      entries_match (x :: xs) ys.
  Proof using.
    unfold entries_match.
    intuition; simpl in *; intuition; subst; subst;
    try solve [
         exfalso; try find_apply_hyp_hyp;
          match goal with
            | [ H : In _ _ |- _ ] => apply maxIndex_is_max in H; [| solve[auto]]; omega
          end].
    - match goal with
        | [ H : _ |- _ ] => solve [eapply H; eauto]
      end.
    - right. match goal with
        | [ H : _ |- _ ] => solve [eapply H; eauto]
      end.
  Qed.

  Lemma entries_match_nil :
    forall l,
      entries_match l [].
  Proof using.
    red.
    simpl.
    intuition.
  Qed.

  Lemma lifted_logs_sorted_nw :
    forall net p t n plt plti es ci,
      refined_raft_intermediate_reachable net ->
      In p (nwPackets net) ->
      pBody p = AppendEntries t n plt plti es ci ->
      sorted es.
  Proof using si rri.
    intros.
    pose proof (lift_prop _ logs_sorted_invariant).
    find_insterU. conclude_using eauto.
    unfold logs_sorted in *. break_and.
    unfold logs_sorted_nw in *.
    eapply H3.
    - unfold deghost. simpl.
      apply in_map_iff. eauto.
    - simpl. eauto.
  Qed.

  Lemma lifted_logs_sorted_host :
    forall net h ,
      refined_raft_intermediate_reachable net ->
      sorted (log (snd (nwState net h))).
  Proof using si rri.
    intros.
    pose proof (lift_prop _ logs_sorted_invariant).
    find_insterU. conclude_using eauto.
    unfold logs_sorted in *. break_and.
    unfold logs_sorted_host in *.
    find_insterU.
    find_rewrite_lem deghost_spec.
    eauto.
  Qed.

  Lemma leaderLogs_entries_match_nw_packet_set :
    forall net net',
      leaderLogs_entries_match_nw net ->
      (forall p, In p (nwPackets net') ->
                 is_append_entries (pBody p) ->
                 In p (nwPackets net)) ->
      (forall h, leaderLogs (fst (nwState net' h)) = leaderLogs (fst (nwState net h))) ->
      leaderLogs_entries_match_nw net'.
  Proof using.
    unfold leaderLogs_entries_match_nw.
    intros.
    eapply_prop_hyp In nwPackets; [|eauto 10].
    match goal with
      | [ H : _ |- _ ] =>
        solve [eapply H; eauto;
               repeat find_higher_order_rewrite;
               eauto]
    end.
  Qed.

  Lemma leaderLogs_entries_match_host_state_same :
    forall net net',
      leaderLogs_entries_match_host net ->
      (forall h, leaderLogs (fst (nwState net' h)) = leaderLogs (fst (nwState net h))) ->
      (forall h, log (snd (nwState net' h)) = log (snd (nwState net h))) ->
      leaderLogs_entries_match_host net'.
  Proof using.
    unfold leaderLogs_entries_match_host.
    intuition.
    repeat find_higher_order_rewrite. eauto.
  Qed.

  Lemma handleClientRequest_no_send :
    forall h st client id c out st' ms,
      handleClientRequest h st client id c = (out, st', ms) ->
      ms = [].
  Proof using.
    unfold handleClientRequest.
    intros.
    repeat break_match; repeat find_inversion; auto.
  Qed.

  Lemma leaderLogs_entries_match_client_request :
    refined_raft_net_invariant_client_request leaderLogs_entries_match.
  Proof using llsli si llsi lltsi rri.
    unfold refined_raft_net_invariant_client_request, leaderLogs_entries_match.
    intros.
    split.
    - { unfold leaderLogs_entries_match_host.
        simpl. intuition. subst. repeat find_higher_order_rewrite.
        repeat update_destruct.
        - find_rewrite_lem update_elections_data_client_request_leaderLogs.
          destruct (log d) using (handleClientRequest_log_ind ltac:(eauto)).
          + eauto.
          + destruct ll.
            * apply entries_match_nil.
            * { apply entries_match_cons_gt_maxTerm; eauto.
                - eauto using lifted_logs_sorted_host.
                - eapply leaderLogs_sorted_invariant; eauto.
                - omega.
                - find_copy_apply_lem_hyp leaderLogs_currentTerm_invariant; auto.
                  find_copy_apply_lem_hyp leaderLogs_term_sanity_invariant.
                  unfold leaderLogs_term_sanity in *.
                  eapply_prop_hyp In In; simpl; eauto. repeat find_rewrite.
                  simpl in *. omega.
              }
        - find_rewrite_lem update_elections_data_client_request_leaderLogs.
          eauto.
        - destruct (log d) using (handleClientRequest_log_ind ltac:(eauto)).
          + eauto.
          + apply entries_match_cons_sublog; eauto.
            * eauto using lifted_logs_sorted_host.
            * eapply leaderLogs_sorted_invariant; eauto.
            * omega.
            * intros.
              eapply leaderLogs_sublog_invariant; eauto.
              simpl in *. congruence.
        - eauto.
      }
    - eapply leaderLogs_entries_match_nw_packet_set with (net:=net); intuition.
      + find_apply_hyp_hyp. intuition eauto.
        erewrite handleClientRequest_no_send with (ms := l) in * by eauto.
        simpl in *. intuition.
      + simpl. subst. find_higher_order_rewrite.
        rewrite update_fun_comm. simpl.
        rewrite update_fun_comm. simpl.
        rewrite update_elections_data_client_request_leaderLogs.
        now rewrite update_nop_ext' by auto.
  Qed.

  Lemma leaderLogs_entries_match_timeout :
    refined_raft_net_invariant_timeout leaderLogs_entries_match.
  Proof using.
    unfold refined_raft_net_invariant_timeout, leaderLogs_entries_match.
    intuition.
    - eapply leaderLogs_entries_match_host_state_same; eauto;
      simpl; intros; subst; find_higher_order_rewrite;
      repeat update_destruct; rewrite_update; auto;
      try rewrite update_elections_data_timeout_leaderLogs;
      try erewrite handleTimeout_log_same by eauto; eauto.
    - eapply leaderLogs_entries_match_nw_packet_set with (net:=net); intuition.
      + simpl in *. find_apply_hyp_hyp.  intuition.
        do_in_map. subst. simpl in *.
        exfalso. eapply handleTimeout_not_is_append_entries; eauto 10.
      + simpl. repeat find_higher_order_rewrite.
        rewrite update_fun_comm. simpl.
        rewrite update_fun_comm. simpl.
        rewrite update_elections_data_timeout_leaderLogs.
        rewrite update_nop_ext'; auto.
  Qed.

  Lemma lifted_log_matching :
    forall net,
      refined_raft_intermediate_reachable net ->
      log_matching (deghost net).
  Proof using lmi rri.
    intros.
    pose proof (lift_prop _ log_matching_invariant).
    find_insterU. conclude_using eauto.
    auto.
  Qed.

  Lemma lifted_log_matching_host :
    forall net,
      refined_raft_intermediate_reachable net ->
      (forall h h',
         entries_match (log (snd (nwState net h))) (log (snd (nwState net h')))) /\
      (forall h i,
         1 <= i <= maxIndex (log (snd (nwState net h))) ->
         exists e, eIndex e = i /\ In e (log (snd (nwState net h)))) /\
      (forall h e,
         In e (log (snd (nwState net h))) -> eIndex e > 0).
  Proof using lmi rri.
    intros.
    find_apply_lem_hyp lifted_log_matching.
    unfold log_matching, log_matching_hosts in *.
    intuition; repeat rewrite <- deghost_spec with (net0 := net).
    - auto.
    - match goal with
        | [ H : _ |- _ ] => solve [apply H; rewrite deghost_spec; auto]
      end.
    - match goal with
        | [ H : _ |- _ ] => solve [eapply H; rewrite deghost_spec; eauto]
      end.
  Qed.

  Lemma lifted_log_matching_nw :
    forall net,
      refined_raft_intermediate_reachable net ->
      forall p t leaderId prevLogIndex prevLogTerm entries leaderCommit,
        In p (nwPackets net) ->
        pBody p = AppendEntries t leaderId prevLogIndex prevLogTerm entries leaderCommit ->
        (forall h e1 e2,
           In e1 entries ->
           In e2 (log (snd (nwState net h))) ->
           eIndex e1 = eIndex e2 ->
           eTerm e1 = eTerm e2 ->
           (forall e3,
              eIndex e3 <= eIndex e1 ->
              In e3 entries ->
              In e3 (log (snd (nwState net h)))) /\
           (prevLogIndex <> 0 ->
            exists e4,
              eIndex e4 = prevLogIndex /\
              eTerm e4 = prevLogTerm /\
              In e4 (log (snd (nwState net h))))) /\
        (forall i,
           prevLogIndex < i <= maxIndex entries ->
           exists e,
             eIndex e = i /\
             In e entries) /\
        (forall e,
           In e entries ->
           prevLogIndex < eIndex e).
  Proof using lmi rri.
    intros.
    find_apply_lem_hyp lifted_log_matching.
    unfold log_matching, log_matching_nw in *.
    break_and.
    match goal with
      | [ H : forall _ : packet , _ |- _ ] =>
        do 7 insterU H;
          conclude H ltac:(unfold deghost; simpl; eapply in_map_iff; eexists; eauto);
          conclude H ltac:(simpl; eauto)
    end.
    intuition.
    - rewrite <- deghost_spec with (net0 := net).
      eapply H3 with (e1:=e1)(e2:=e2); eauto.
      rewrite deghost_spec.  auto.
    - rewrite <- deghost_spec with (net0 := net).
      eapply H3 with (e1:=e1)(e2:=e2); eauto.
      rewrite deghost_spec.  auto.
  Qed.

  Ltac use_log_matching_nw :=
    pose proof (lifted_log_matching_nw _ ltac:(eauto));
    match goal with
      | [ H : _  |- _ ] =>
        eapply H; [|eauto];
        repeat find_rewrite; intuition
    end.

  Lemma handleAppendEntries_doesn't_send_AE :
    forall n st t i l t' l' l'' st' m,
      handleAppendEntries n st t i l t' l' l'' = (st', m) ->
      ~ is_append_entries m.
  Proof using.
    unfold handleAppendEntries.
    intros.
    repeat break_match; find_inversion; intro; break_exists; discriminate.
  Qed.

  Lemma leaderLogs_entries_match_append_entries :
    refined_raft_net_invariant_append_entries leaderLogs_entries_match.
  Proof using taifoi si llsi lmi rri.
    unfold refined_raft_net_invariant_append_entries, leaderLogs_entries_match.
    intuition.
    - unfold leaderLogs_entries_match_host in *. intros.
      {
        intros. simpl in *. repeat find_higher_order_rewrite.
        find_rewrite_lem update_fun_comm. simpl in *.
        find_rewrite_lem update_fun_comm.
        find_rewrite_lem update_elections_data_appendEntries_leaderLogs.
        find_erewrite_lem update_nop_ext'.
        update_destruct; rewrite_update;
        try rewrite update_elections_data_appendEntries_leaderLogs in *; eauto.
        destruct (log d) using (handleAppendEntries_log_ind ltac:(eauto)); eauto.
        + subst. eapply entries_match_scratch with (plt0 := plt).
          * eauto using lifted_logs_sorted_nw.
          * apply sorted_uniqueIndices.
            eapply leaderLogs_sorted_invariant; eauto.
          * eapply_prop leaderLogs_entries_match_nw; eauto.
          * use_log_matching_nw.
          * use_log_matching_nw.
          * match goal with
              | [ H : In _ (leaderLogs _) |- _ ] =>
                eapply terms_and_indices_from_one_invariant in H; [|solve[auto]]
            end.
            unfold terms_and_indices_from_one in *. intros.
            find_apply_hyp_hyp. intuition.
        + eapply entries_match_append; eauto.
          * eauto using lifted_logs_sorted_host.
          * eapply leaderLogs_sorted_invariant; eauto.
          * eauto using lifted_logs_sorted_nw.
          * use_log_matching_nw.
          * use_log_matching_nw.
          * eapply findAtIndex_intro; eauto using lifted_logs_sorted_host, sorted_uniqueIndices.
      }
    - (* nw *)
      unfold leaderLogs_entries_match_nw in *.
      intros. simpl in *. repeat find_higher_order_rewrite.
      find_rewrite_lem update_fun_comm. simpl in *.
      find_rewrite_lem update_fun_comm.
      find_rewrite_lem update_elections_data_appendEntries_leaderLogs.
      find_erewrite_lem update_nop_ext'.
      find_apply_hyp_hyp. break_or_hyp.
      + intuition; match goal with
            | [ H : _ |- _ ] => solve [eapply H with (p0 := p0); eauto with *]
          end.
      + simpl in *.
        find_copy_apply_lem_hyp handleAppendEntries_doesn't_send_AE.
        exfalso. eauto 10.
  Qed.

  Lemma leaderLogs_entries_match_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply leaderLogs_entries_match.
  Proof using.
    unfold refined_raft_net_invariant_append_entries_reply, leaderLogs_entries_match.
    intuition.
    - eapply leaderLogs_entries_match_host_state_same; eauto; simpl; intros;
      repeat find_higher_order_rewrite; update_destruct; rewrite_update; auto.
      erewrite handleAppendEntriesReply_same_log by eauto. auto.
    - eapply leaderLogs_entries_match_nw_packet_set; eauto; simpl.
      + intros. find_apply_hyp_hyp. repeat find_rewrite. intuition; [eauto with *|].
        find_apply_lem_hyp handleAppendEntriesReply_packets. subst. simpl in *. intuition.
      + intros. repeat find_higher_order_rewrite; update_destruct; rewrite_update; auto; find_rewrite; auto.
  Qed.

  Lemma handleRequestVote_packets :
    forall h st t candidate lli llt st' m,
      handleRequestVote h st t candidate lli llt = (st', m) ->
      ~ is_append_entries m.
  Proof using.
    intros. unfold handleRequestVote, advanceCurrentTerm in *.
    repeat break_match; find_inversion;
    subst; intuition; break_exists; congruence.
  Qed.

  Lemma leaderLogs_entries_match_request_vote :
    refined_raft_net_invariant_request_vote leaderLogs_entries_match.
  Proof using.
    unfold refined_raft_net_invariant_request_vote, leaderLogs_entries_match.
    intuition.
    - eapply leaderLogs_entries_match_host_state_same; eauto; simpl; intros;
      repeat find_higher_order_rewrite; update_destruct; rewrite_update; auto.
      + now rewrite leaderLogs_update_elections_data_requestVote.
      + erewrite handleRequestVote_log; eauto.
    - eapply leaderLogs_entries_match_nw_packet_set; eauto; simpl.
      + intros. find_apply_hyp_hyp. repeat find_rewrite. intuition; [eauto with *|].
        find_apply_lem_hyp handleRequestVote_packets. subst. simpl in *. intuition.
      + intros. repeat find_higher_order_rewrite; update_destruct; rewrite_update; auto.
        now rewrite leaderLogs_update_elections_data_requestVote.
  Qed.

  Lemma leaderLogs_entries_match_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply leaderLogs_entries_match.
  Proof using lmi rri.
    unfold refined_raft_net_invariant_request_vote_reply, leaderLogs_entries_match.
    intuition.
    - unfold leaderLogs_entries_match_host in *.
      intros. simpl in *. subst.
      repeat find_higher_order_rewrite.
      rewrite update_fun_comm. simpl.
      rewrite update_fun_comm. simpl.
      rewrite update_nop_ext' by now rewrite handleRequestVoteReply_same_log.
      find_rewrite_lem update_fun_comm. simpl in *.
      update_destruct; rewrite_update; eauto.
      find_eapply_lem_hyp leaderLogs_update_elections_data_RVR; eauto.
      intuition eauto.
      subst.
      rewrite handleRequestVoteReply_same_log.
      apply lifted_log_matching_host. auto.
    - unfold leaderLogs_entries_match_nw in *.
      intros. simpl in *. subst.
      repeat find_higher_order_rewrite.
      find_rewrite_lem update_fun_comm. simpl in *.
      find_rewrite_lem update_fun_comm.
      update_destruct; rewrite_update.
      + find_eapply_lem_hyp leaderLogs_update_elections_data_RVR; eauto.
        break_or_hyp.
        * repeat find_reverse_rewrite. eauto.
        * break_and. subst.
          rewrite handleRequestVoteReply_same_log.
          find_rewrite_lem handleRequestVoteReply_same_log.
          pose proof (lifted_log_matching_nw _ ltac:(eauto)).
          repeat find_reverse_rewrite.
          match goal with
            | [ H : _, pkt : packet  |- _ ] =>
              solve [eapply H with (p := pkt); eauto]
          end.
      + repeat find_reverse_rewrite. eauto.
  Qed.

  Lemma doLeader_messages :
    forall st h os st' ms,
      doLeader st h = (os, st', ms) ->
      ms = [] \/
      ms = map (replicaMessage st' h)
               (filter (fun h' : name => if name_eq_dec h h' then false else true)
                       nodes).
  Proof using.
    unfold doLeader.
    intros.
    repeat break_match; repeat find_inversion; auto.
  Qed.

  Lemma leaderLogs_entries_match_do_leader :
    refined_raft_net_invariant_do_leader leaderLogs_entries_match.
  Proof using llci si llsi rri.
    unfold refined_raft_net_invariant_do_leader, leaderLogs_entries_match.
    intuition.
    - eapply leaderLogs_entries_match_host_state_same; eauto; simpl; intros;
      find_higher_order_rewrite; update_destruct; rewrite_update; auto.
      + find_rewrite. auto.
      + erewrite doLeader_same_log by eauto. find_rewrite. auto.
    - unfold leaderLogs_entries_match_nw in *. intros. simpl in *.
      repeat find_higher_order_rewrite.
      find_rewrite_lem update_fun_comm. simpl in *.
      match goal with
        | [ H : _ |- _ ] =>
          rewrite update_nop_ext' in H by (find_rewrite; auto)
      end.
      find_apply_hyp_hyp. break_or_hyp.
      + find_reverse_rewrite. eauto.
      + do_in_map. subst. simpl in *.
        find_copy_apply_lem_hyp doLeader_messages.
        break_or_hyp.
        * simpl in *. intuition.
        * do_in_map. find_apply_lem_hyp filter_In.
          break_and. break_if; try discriminate.
          unfold replicaMessage in *. subst. simpl in *. find_inversion.
          { intuition.
            - repeat find_erewrite_lem doLeader_same_log.
              eapply_prop leaderLogs_entries_match_host; eauto.
              + match goal with
                  | [ H : _ |- _ ] => rewrite H
                end. simpl.
                eauto using findGtIndex_in.
              + auto with *.
              + find_rewrite. simpl. eauto using findGtIndex_in.
            - find_copy_apply_lem_hyp leaderLogs_contiguous_invariant; auto.
              unfold contiguous_range_exact_lo in *. break_and.
              match goal with
                | [ H : forall _, _ < _ <= _ -> _ |- context [eIndex _ = ?x]] =>
                  remember (x) as index;
                  specialize (H index); forward H
              end.
              + intuition; auto using neq_0_lt.
                find_apply_lem_hyp findGtIndex_necessary. break_and.
                eapply le_trans.
                * apply lt_le_weak. eauto.
                * repeat find_rewrite. eapply maxIndex_is_max; auto.
                  eapply leaderLogs_sorted_invariant; eauto.
              + concludes. break_exists_exists. intuition.
                match goal with
                  | [ H : context [leaderLogs_entries_match_host],
                     H' : context [leaderLogs] |- _ ] =>
                    eapply H with (h := src)(e := e1)(e' := e2)(e'' := x) in H'; auto
                end.
                * pose proof lifted_logs_sorted_host net src ltac:(auto).
                  repeat find_rewrite. simpl in *.
                  repeat find_erewrite_lem doLeader_same_log.
                  erewrite doLeader_same_log by eauto.
                  erewrite findAtIndex_intro; eauto using sorted_uniqueIndices.
                * find_apply_lem_hyp findGtIndex_necessary. break_and.
                  repeat find_erewrite_lem doLeader_same_log.
                  repeat find_rewrite. simpl in *.
                  auto.
                * find_apply_lem_hyp findGtIndex_necessary. break_and.
                  omega.
          }
  Qed.

  Lemma doGenericServer_packets :
    forall h st os st' ps,
      doGenericServer h st = (os, st', ps) ->
      ps = [].
  Proof using.
    intros. unfold doGenericServer in *.
    repeat break_match; find_inversion; subst; auto.
  Qed.

  Lemma leaderLogs_entries_match_do_generic_server :
    refined_raft_net_invariant_do_generic_server leaderLogs_entries_match.
  Proof using.
    unfold refined_raft_net_invariant_do_generic_server, leaderLogs_entries_match.
    intuition.
    - eapply leaderLogs_entries_match_host_state_same; eauto; simpl; intros;
      find_higher_order_rewrite; update_destruct; rewrite_update; auto.
      + find_rewrite. auto.
      + erewrite doGenericServer_log by eauto. find_rewrite. auto.
    - eapply leaderLogs_entries_match_nw_packet_set; eauto; simpl.
      + intros. find_apply_hyp_hyp. intuition.
        find_apply_lem_hyp doGenericServer_packets. subst. simpl in *. intuition.
      + intros. find_higher_order_rewrite; update_destruct; rewrite_update; auto; find_rewrite; auto.
  Qed.

  Lemma leaderLogs_entries_match_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset leaderLogs_entries_match.
  Proof using.
    unfold refined_raft_net_invariant_state_same_packet_subset, leaderLogs_entries_match.
    intuition.
    - eapply leaderLogs_entries_match_host_state_same; eauto; intros; find_higher_order_rewrite; auto.
    - eapply leaderLogs_entries_match_nw_packet_set; eauto; intros; find_higher_order_rewrite; auto.
  Qed.

  Lemma leaderLogs_entries_match_reboot :
    refined_raft_net_invariant_reboot leaderLogs_entries_match.
  Proof using.
    unfold refined_raft_net_invariant_reboot, leaderLogs_entries_match, reboot.
    intuition.
    - eapply leaderLogs_entries_match_host_state_same; eauto; intros; find_higher_order_rewrite;
      update_destruct; rewrite_update; auto; find_rewrite; auto.
    - eapply leaderLogs_entries_match_nw_packet_set; eauto; try find_rewrite; intuition.
      find_higher_order_rewrite; update_destruct; rewrite_update; try find_rewrite; auto.
  Qed.

  Lemma leaderLogs_entries_match_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      leaderLogs_entries_match net.
  Proof using taifoi llci llsli si llsi lltsi lmi rri.
    intros.
    apply refined_raft_net_invariant; auto.
    - apply leaderLogs_entries_match_init.
    - apply leaderLogs_entries_match_client_request.
    - apply leaderLogs_entries_match_timeout.
    - apply leaderLogs_entries_match_append_entries.
    - apply leaderLogs_entries_match_append_entries_reply.
    - apply leaderLogs_entries_match_request_vote.
    - apply leaderLogs_entries_match_request_vote_reply.
    - apply leaderLogs_entries_match_do_leader.
    - apply leaderLogs_entries_match_do_generic_server.
    - apply leaderLogs_entries_match_state_same_packet_subset.
    - apply leaderLogs_entries_match_reboot.
  Qed.

  Instance lllmi : leaderLogs_entries_match_interface : Prop.
  Proof.
    split.
    apply leaderLogs_entries_match_invariant.
  Qed.
End LeaderLogsLogMatching.


Require Import Fiat.Common
        Fiat.Computation
        Fiat.ADT
        Fiat.ADTRefinement.Core
        Coq.Sets.Ensembles.

Generalizable All Variables.
Set Implicit Arguments.

Section sMethodRefinement.

  (** Old and new representations **)
  Variables oldRep newRep : Type.

  (* Type of state (heaps in the case of ByteString ADT). *)
  Variable ST : Type.

  (** Abstraction Relation *)
  Variable AbsR : oldRep -> newRep -> ST -> Prop.

  Definition sMethodType
             (arity : nat)
             (rep : Type)
             (dom : list Type)
             (cod : option Type)
    := methodType arity rep (ST :: dom)
                   match cod with
                   | Some T => Some (prod ST T)
                   | None => Some ST
                   end.

  Fixpoint sRefineMethod''
           {dom : list Type}
           {cod : option Type}
    : methodType' oldRep dom cod
      -> methodType'
           newRep dom
           match cod with
           | Some T => Some (prod ST T)
           | None => Some ST
           end
      -> Prop :=
    match dom return
          methodType' oldRep dom cod
          -> methodType'
               newRep dom
               match cod with
               | Some T => Some (prod ST T)
               | None => Some ST
               end
          -> Prop
    with
    | nil =>
      match cod return
            methodType' oldRep [] cod
            -> methodType'
                 newRep []
                 match cod with
                 | Some T => Some (prod ST T)
                 | None => Some ST
                 end
            -> Prop
      with
      | Some cod' =>
        fun oldMethod newMethod =>
            refine (r_o' <- oldMethod;
                  `(r_n', s') <- {r_n_s | AbsR (fst r_o') (fst r_n_s) (snd r_n_s)};
                  ret (r_n', (s', snd r_o')))
                   newMethod
      | _ =>
        fun oldMethod newMethod =>
            refine (r_o' <- oldMethod;
                      {r_n_s | AbsR r_o' (fst r_n_s) (snd r_n_s)})
                   newMethod
      end
    | cons D dom' =>
      fun oldMethod newMethod =>
        forall d : D,
          @sRefineMethod'' dom' cod (oldMethod d)
                         (newMethod d)
    end.

  Fixpoint sRefineMethod'
           (arity : nat)
           (s : ST)
           {dom : list Type}
           {cod : option Type}
           (oldMethod : methodType arity oldRep dom cod)
           (newMethod : sMethodType arity newRep dom cod)
    : Prop
    :=
      match arity return methodType arity oldRep dom cod
                         -> sMethodType arity newRep dom cod
                         -> Prop with
      | 0 => fun oldMethod newMethod =>
               @sRefineMethod'' dom cod oldMethod (newMethod s)
      | S arity' =>
        fun oldMethod newMethod =>
          forall r_o r_n,
            AbsR r_o r_n s ->
            sRefineMethod' arity' s (oldMethod r_o) (newMethod r_n)
      end oldMethod newMethod.

  Definition sRefineMethod
             {arity : nat}
             {dom : list Type}
             {cod : option Type}
             (oldMethod : methodType arity oldRep dom cod)
             (newMethod : sMethodType arity newRep dom cod)
    : Prop := forall s : ST, sRefineMethod' arity s oldMethod newMethod.

End sMethodRefinement.

Definition sSig (ST : Type) (Sig : ADTSig) : ADTSig :=
  {| MethodIndex := MethodIndex Sig;
     MethodDomCod idx :=
       (fst (fst (MethodDomCod Sig idx)),
        cons ST (snd (fst (MethodDomCod Sig idx))),
        match (snd (MethodDomCod Sig idx)) with
          | Some T => Some (prod ST T)
          | None => Some ST
          end) |}.

Definition sADT (ST : Type) (Sig : ADTSig) :=
  ADT (sSig ST Sig).

Record refine_sADT {Sig}
       (ST : Type)
       (A : ADT Sig)
       (B : sADT ST Sig) :=
  refines_sADT {
      sAbsR : _;
      sADTRefinementPreservesMethods
      : forall idx : MethodIndex Sig,
          @sRefineMethod
            (Rep A) (Rep B) ST sAbsR
            (fst (fst (MethodDomCod Sig idx)))
            (snd (fst (MethodDomCod Sig idx)))
            (snd (MethodDomCod Sig idx))
            (Methods A idx)
            (Methods B idx) }.