Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Construction.Comma.
Require Import Category.Instance.Fun.
Require Import Category.Instance.Cat.

Generalizable All Variables.

Ltac reduce :=
  repeat match goal with
    | [ H : {p : _ & _ } |- _ ] => destruct H
    end;
  simpl; auto; try split; cat; simpl; cat.

#[local] Obligation Tactic := simpl; intros.

#[export]
Program Instance Comma_Iso_to_Left {A : Category} {B : Category} {C : Category}
        (x y : A ⟶ C) (iso : x ≅[Fun] y) (z : B ⟶ C) :
  (x ↓ z) ⟶ (y ↓ z).
Next Obligation.
  exists ``X; simpl.
  exact (`2 X ∘ transform[from iso] _).
Defined.
Next Obligation.
  exists ``f; simpl.
  rewrite comp_assoc.
  rewrite <- (`2 f).
  rewrite <- comp_assoc.
  rewrite <- naturality.
  rewrite comp_assoc.
  reflexivity.
Defined.
Next Obligation. now repeat intro. Qed.
Next Obligation. now split. Qed.
Next Obligation. now split. Qed.

#[export]
Program Instance Comma_Iso_from_Left {A : Category} {B : Category} {C : Category}
        (x y : A ⟶ C) (iso : x ≅[Fun] y) (z : B ⟶ C) :
  (y ↓ z) ⟶ (x ↓ z).
Next Obligation.
  exists ``X; simpl.
  exact (`2 X ∘ transform[to iso] _).
Defined.
Next Obligation.
  exists ``f; simpl.
  rewrite comp_assoc.
  rewrite <- (`2 f).
  do 2 rewrite <- comp_assoc.
  apply compose_respects; try reflexivity.
  now rewrite <- naturality.
Defined.
Next Obligation. now repeat intro. Qed.
Next Obligation. now split. Qed.
Next Obligation. now split. Qed.

#[export]
Program Instance Comma_Iso_to_Right {A : Category} {B : Category} {C : Category}
        (x y : B ⟶ C) (iso : x ≅[Fun] y) (z : A ⟶ C) :
  (z ↓ x) ⟶ (z ↓ y).
Next Obligation.
  exists ``X; simpl.
  exact (transform[to iso] _ ∘ `2 X).
Defined.
Next Obligation.
  exists ``f; simpl.
  rewrite <- comp_assoc.
  rewrite (`2 f).
  rewrite comp_assoc.
  rewrite <- naturality.
  rewrite comp_assoc.
  reflexivity.
Defined.
Next Obligation. now repeat intro. Qed.
Next Obligation. now split. Qed.
Next Obligation. now split. Qed.

#[export]
Program Instance Comma_Iso_from_Right {A : Category} {B : Category} {C : Category}
        (x y : B ⟶ C) (iso : x ≅[Fun] y) (z : A ⟶ C) :
  (z ↓ y) ⟶ (z ↓ x).
Next Obligation.
  exists ``X; simpl.
  exact (transform[from iso] _ ∘ `2 X).
Defined.
Next Obligation.
  exists ``f; simpl.
  rewrite <- comp_assoc.
  rewrite (`2 f).
  rewrite comp_assoc.
  rewrite <- naturality.
  rewrite comp_assoc.
  reflexivity.
Defined.
Next Obligation. now repeat intro. Qed.
Next Obligation. now split. Qed.
Next Obligation. now split. Qed.

#[export]
Program Instance Comma_Iso {A : Category} {B : Category} {C : Category} :
  Proper (@Isomorphism Fun ==> @Isomorphism Fun ==> @Isomorphism Cat)
         (@Comma A B C).
Next Obligation.
  proper.
  transitivity (y ↓ x0). {
    isomorphism; simpl.
    - apply Comma_Iso_to_Left; assumption.
    - apply Comma_Iso_from_Left; assumption.
    - constructive; simpl.
      + exists (id, id); cat.
        rewrite <- comp_assoc; simpl;
        srewrite (iso_to_from X); cat.
      + exists (id, id); cat.
        rewrite <- comp_assoc; simpl;
        srewrite (iso_to_from X); cat.
      + clear; simpl; cat.
      + clear; simpl; cat.
      + clear; simpl.
        split.
        * symmetry.
          rewrite id_right.
          apply id_left.
        * symmetry.
          rewrite id_right.
          apply id_left.
    - constructive; simpl.
      + exists (id, id); cat.
        rewrite <- comp_assoc; simpl;
        srewrite (iso_from_to X); cat.
      + exists (id, id); cat.
        rewrite <- comp_assoc; simpl;
        srewrite (iso_from_to X); cat.
      + clear; simpl.
        split; apply id_left.
      + clear; simpl.
        split; apply id_left.
      + clear; simpl.
        split; rewrite id_right; symmetry; apply id_left.
  }
  isomorphism; simpl.
  - apply Comma_Iso_to_Right; assumption.
  - apply Comma_Iso_from_Right; assumption.
  - constructive; simpl.
    + exists (id, id); cat.
      rewrite comp_assoc; simpl;
      srewrite (iso_to_from X0); cat.
    + exists (id, id); cat.
      rewrite comp_assoc; simpl;
      srewrite (iso_to_from X0); cat.
    + clear; simpl; cat.
    + clear; simpl; cat.
    + clear; simpl.
      split; symmetry; rewrite id_right; apply id_left.
  - constructive; simpl.
    + exists (id, id); cat.
      rewrite comp_assoc; simpl;
      srewrite (iso_from_to X0); cat.
    + exists (id, id); cat.
      rewrite comp_assoc; simpl;
      srewrite (iso_from_to X0); cat.
    + clear; simpl.
      split; apply id_left.
    + clear; simpl.
      split; apply id_left.
    + clear; simpl.
      split; symmetry; rewrite id_right; apply id_left.
Qed.


Require Export Program.Basics. Open Scope program_scope.
From Paco Require Import paco2 pacotac.
Set Implicit Arguments.

Section GeneralizedPaco2.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.

Local Notation rel := (rel2 T0 T1).

Section RClo.

Inductive rclo2 (clo: rel->rel) (r: rel): rel :=
| rclo2_base
    x0 x1
    (IN: r x0 x1):
    @rclo2 clo r x0 x1
| rclo2_clo'
    r' x0 x1
    (LE: r' <2= rclo2 clo r)
    (IN: clo r' x0 x1):
    @rclo2 clo r x0 x1
.

Lemma rclo2_mon_gen clo clo' r r' x0 x1
      (IN: @rclo2 clo r x0 x1)
      (LEclo: clo <3= clo')
      (LEr: r <2= r') :
  @rclo2 clo' r' x0 x1.
Proof.
  induction IN; intros.
  - econstructor 1. apply LEr, IN.
  - econstructor 2; [intros; eapply H, PR|apply LEclo, IN].
Qed.

Lemma rclo2_mon clo:
  monotone2 (rclo2 clo).
Proof.
  repeat intro. eapply rclo2_mon_gen; [apply IN|intros; apply PR|apply LE].
Qed.

Lemma rclo2_clo clo r:
  clo (rclo2 clo r) <2= rclo2 clo r.
Proof.
  intros. econstructor 2; [|apply PR].
  intros. apply PR0.
Qed.

Lemma rclo2_clo_base clo r:
  clo r <2= rclo2 clo r.
Proof.
  intros. eapply rclo2_clo', PR.
  intros. apply rclo2_base, PR0.
Qed.

Lemma rclo2_rclo clo r:
  rclo2 clo (rclo2 clo r) <2= rclo2 clo r.
Proof.
  intros. induction PR.
  - eapply IN.
  - econstructor 2; [eapply H | eapply IN].
Qed.

Lemma rclo2_compose clo r:
  rclo2 (rclo2 clo) r <2= rclo2 clo r.
Proof.
  intros. induction PR.
  - apply rclo2_base, IN.
  - apply rclo2_rclo.
    eapply rclo2_mon; [apply IN|apply H].
Qed.

End RClo.

Section Main.

Variable gf: rel -> rel.
Hypothesis gf_mon: monotone2 gf.

Variant gpaco2 clo r rg x0 x1 : Prop :=
| gpaco2_intro (IN: @rclo2 clo (paco2 (compose gf (rclo2 clo)) (rg \2/ r) \2/ r) x0 x1)
.

Definition gupaco2 clo r := gpaco2 clo r r.

Lemma gpaco2_def_mon clo : monotone2 (compose gf (rclo2 clo)).
Proof.
  eapply monotone2_compose. apply gf_mon. apply rclo2_mon.
Qed.

#[local] Hint Resolve gpaco2_def_mon : paco.

Lemma gpaco2_mon clo r r' rg rg' x0 x1
      (IN: @gpaco2 clo r rg x0 x1)
      (LEr: r <2= r')
      (LErg: rg <2= rg'):
  @gpaco2 clo r' rg' x0 x1.
Proof.
  destruct IN. econstructor.
  eapply rclo2_mon. apply IN.
  intros. destruct PR; [|right; apply LEr, H].
  left. eapply paco2_mon. apply H.
  intros. destruct PR.
  - left. apply LErg, H0.
  - right. apply LEr, H0.
Qed.

Lemma gupaco2_mon clo r r' x0 x1
      (IN: @gupaco2 clo r x0 x1)
      (LEr: r <2= r'):
  @gupaco2 clo r' x0 x1.
Proof.
  eapply gpaco2_mon. apply IN. apply LEr. apply LEr.
Qed.

Lemma gpaco2_base clo r rg: r <2= gpaco2 clo r rg.
Proof.
  econstructor. apply rclo2_base. right. apply PR.
Qed.

Lemma gpaco2_gen_guard  clo r rg:
  gpaco2 clo r (rg \2/ r) <2= gpaco2 clo r rg.
Proof.
  intros. destruct PR. econstructor.
  eapply rclo2_mon. apply IN. intros.
  destruct PR; [|right; apply H].
  left. eapply paco2_mon_gen; intros. apply H. apply PR.
  destruct PR. apply H0. right. apply H0.
Qed.

Lemma gpaco2_rclo clo r rg:
  rclo2 clo r <2= gpaco2 clo r rg.
Proof.
  intros. econstructor.
  eapply rclo2_mon. apply PR.
  intros. right. apply PR0.
Qed.

Lemma gpaco2_clo clo r rg:
  clo r <2= gpaco2 clo r rg.
Proof.
  intros. apply gpaco2_rclo. eapply rclo2_clo_base, PR.
Qed.

Lemma gpaco2_gen_rclo clo r rg:
  gpaco2 (rclo2 clo) r rg <2= gpaco2 clo r rg.
Proof.
  intros. destruct PR. econstructor.
  apply rclo2_compose.
  eapply rclo2_mon. apply IN. intros.
  destruct PR; [|right; apply H].
  left. eapply paco2_mon_gen; intros; [apply H| |apply PR].
  eapply gf_mon, rclo2_compose. apply PR.
Qed.

Lemma gpaco2_step_gen clo r rg:
  gf (gpaco2 clo (rg \2/ r) (rg \2/ r)) <2= gpaco2 clo r rg.
Proof.
  intros. econstructor. apply rclo2_base. left.
  pstep. eapply gf_mon. apply PR.
  intros. destruct PR0. eapply rclo2_mon. apply IN.
  intros. destruct PR0.
  - left. eapply paco2_mon. apply H. intros. destruct PR0; apply H0.
  - right. apply H.
Qed.

Lemma gpaco2_step clo r rg:
  gf (gpaco2 clo rg rg) <2= gpaco2 clo r rg.
Proof.
  intros. apply gpaco2_step_gen.
  eapply gf_mon. apply PR. intros.
  eapply gpaco2_mon. apply PR0. left; apply PR1. left; apply PR1.
Qed.

Lemma gpaco2_final clo r rg:
  (r \2/ paco2 gf rg) <2= gpaco2 clo r rg.
Proof.
  intros. destruct PR. apply gpaco2_base, H.
  econstructor. apply rclo2_base.
  left. eapply paco2_mon_gen. apply H.
  - intros. eapply gf_mon. apply PR.
    intros. apply rclo2_base. apply PR0.
  - intros. left. apply PR.
Qed.

Lemma gpaco2_unfold clo r rg:
  gpaco2 clo r rg <2= rclo2 clo (gf (gupaco2 clo (rg \2/ r)) \2/ r).
Proof.
  intros. destruct PR.
  eapply rclo2_mon. apply IN.
  intros. destruct PR; cycle 1. right; apply H.
  left. _punfold H; [|apply gpaco2_def_mon].
  eapply gf_mon. apply H.
  intros. econstructor.
  eapply rclo2_mon. apply PR.
  intros. destruct PR0; cycle 1. right. apply H0.
  left. eapply paco2_mon. apply H0.
  intros. left. apply PR0.
Qed.

Lemma gpaco2_cofix clo r rg
      l (OBG: forall rr (INC: rg <2= rr) (CIH: l <2= rr), l <2= gpaco2 clo r rr):
  l <2= gpaco2 clo r rg.
Proof.
  assert (IN: l <2= gpaco2 clo r (rg \2/ l)).
  { intros. apply OBG; [left; apply PR0 | right; apply PR0 | apply PR]. }
  clear OBG. intros. apply IN in PR.
  destruct PR. econstructor.
  eapply rclo2_mon. apply IN0.
  clear x0 x1 IN0.
  intros. destruct PR; [|right; apply H].
  left. revert x0 x1 H.
  pcofix CIH. intros.
  _punfold H0; [..|apply gpaco2_def_mon]. pstep.
  eapply gf_mon. apply H0. intros.
  apply rclo2_rclo. eapply rclo2_mon. apply PR.
  intros. destruct PR0.
  - apply rclo2_base. right. apply CIH. apply H.
  - destruct H; [destruct H|].
    + apply rclo2_base. right. apply CIH0. left. apply H.
    + apply IN in H. destruct H.
      eapply rclo2_mon. apply IN0.
      intros. destruct PR0.
      * right. apply CIH. apply H.
      * right. apply CIH0. right. apply H.
    + apply rclo2_base. right. apply CIH0. right. apply H.
Qed.

Lemma gpaco2_gupaco clo r rg:
  gupaco2 clo (gpaco2 clo r rg) <2= gpaco2 clo r rg.
Proof.
  eapply gpaco2_cofix.
  intros. destruct PR. econstructor.
  apply rclo2_rclo. eapply rclo2_mon. apply IN.
  intros. destruct PR.
  - apply rclo2_base. left.
    eapply paco2_mon. apply H.
    intros. left; apply CIH.
    econstructor. apply rclo2_base. right.
    destruct PR; apply H0.
  - destruct H. eapply rclo2_mon. apply IN0.
    intros. destruct PR; [| right; apply H].
    left. eapply paco2_mon. apply H.
    intros. destruct PR.
    + left. apply INC. apply H0.
    + right. apply H0.
Qed.

Lemma gpaco2_gpaco clo r rg:
  gpaco2 clo (gpaco2 clo r rg) (gupaco2 clo (rg \2/ r)) <2= gpaco2 clo r rg.
Proof.
  intros. apply gpaco2_unfold in PR.
  econstructor. apply rclo2_rclo. eapply rclo2_mon. apply PR. clear x0 x1 PR. intros.
  destruct PR; [|destruct H; apply IN].
  apply rclo2_base. left. pstep.
  eapply gf_mon. apply H. clear x0 x1 H. intros.
  cut (@gupaco2 clo (rg \2/ r) x0 x1).
  { intros. destruct H. eapply rclo2_mon. apply IN. intros.
    destruct PR0; [|right; apply H].
    left. eapply paco2_mon. apply H. intros. destruct PR0; apply H0.
  }
  apply gpaco2_gupaco. eapply gupaco2_mon. apply PR. intros.
  destruct PR0; [apply H|].
  eapply gpaco2_mon; [apply H|right|left]; intros; apply PR0.
Qed.

Lemma gpaco2_uclo uclo clo r rg
      (LEclo: uclo <3= gupaco2 clo) :
  uclo (gpaco2 clo r rg) <2= gpaco2 clo r rg.
Proof.
  intros. apply gpaco2_gupaco. apply LEclo, PR.
Qed.

Lemma gpaco2_weaken  clo r rg:
  gpaco2 (gupaco2 clo) r rg <2= gpaco2 clo r rg.
Proof.
  intros. apply gpaco2_unfold in PR.
  induction PR.
  - destruct IN; cycle 1. apply gpaco2_base, H.
    apply gpaco2_step_gen. eapply gf_mon. apply H.
    clear x0 x1 H.
    eapply gpaco2_cofix. intros.
    apply gpaco2_unfold in PR.
    induction PR.
    + destruct IN; cycle 1. apply gpaco2_base, H.
      apply gpaco2_step. eapply gf_mon. apply H.
      intros. apply gpaco2_base. apply CIH.
      eapply gupaco2_mon. apply PR.
      intros. destruct PR0; apply H0.
    + apply gpaco2_gupaco.
      eapply gupaco2_mon. apply IN. apply H.
  - apply gpaco2_gupaco.
    eapply gupaco2_mon. apply IN. apply H.
Qed.

End Main.

#[local] Hint Resolve gpaco2_def_mon : paco.

Section GeneralMonotonicity.

Variable gf: rel -> rel.

Lemma gpaco2_mon_gen (gf' clo clo': rel -> rel) x0 x1 r r' rg rg'
      (IN: @gpaco2 gf clo r rg x0 x1)
      (gf_mon: monotone2 gf)
      (LEgf: gf <3= gf')
      (LEclo: clo <3= clo')
      (LEr: r <2= r')
      (LErg: rg <2= rg') :
  @gpaco2 gf' clo' r' rg' x0 x1.
Proof.
  eapply gpaco2_mon; [|apply LEr|apply LErg].
  destruct IN. econstructor.
  eapply rclo2_mon_gen. apply IN. apply LEclo.
  intros. destruct PR; [| right; apply H].
  left. eapply paco2_mon_gen. apply H.
  - intros. eapply LEgf.
    eapply gf_mon. apply PR.
    intros. eapply rclo2_mon_gen. apply PR0. apply LEclo. intros; apply PR1.
  - intros. apply PR.
Qed.

Lemma gpaco2_mon_bot (gf' clo clo': rel -> rel) x0 x1 r' rg'
      (IN: @gpaco2 gf clo bot2 bot2 x0 x1)
      (gf_mon: monotone2 gf)
      (LEgf: gf <3= gf')
      (LEclo: clo <3= clo'):
  @gpaco2 gf' clo' r' rg' x0 x1.
Proof.
  eapply gpaco2_mon_gen. apply IN. apply gf_mon. apply LEgf. apply LEclo. contradiction. contradiction.
Qed.

Lemma gupaco2_mon_gen (gf' clo clo': rel -> rel) x0 x1 r r'
      (IN: @gupaco2 gf clo r x0 x1)
      (gf_mon: monotone2 gf)
      (LEgf: gf <3= gf')
      (LEclo: clo <3= clo')
      (LEr: r <2= r'):
  @gupaco2 gf' clo' r' x0 x1.
Proof.
  eapply gpaco2_mon_gen. apply IN. apply gf_mon. apply LEgf. apply LEclo. apply LEr. apply LEr.
Qed.

End GeneralMonotonicity.

Section Compatibility.

Variable gf: rel -> rel.
Hypothesis gf_mon: monotone2 gf.

Structure compatible2 (clo: rel -> rel) : Prop :=
  compat2_intro {
      compat2_mon: monotone2 clo;
      compat2_compat : forall r,
          clo (gf r) <2= gf (clo r);
    }.

Structure wcompatible2 clo : Prop :=
  wcompat2_intro {
      wcompat2_mon: monotone2 clo;
      wcompat2_wcompat : forall r,
          clo (gf r) <2= gf (gupaco2 gf clo r);
    }.

Lemma rclo2_dist clo
      (MON: monotone2 clo)
      (DIST: forall r1 r2, clo (r1 \2/ r2) <2= (clo r1 \2/ clo r2)):
  forall r1 r2, rclo2 clo (r1 \2/ r2) <2= (rclo2 clo r1 \2/ rclo2 clo r2).
Proof.
  intros. induction PR.
  + destruct IN; [left|right]; apply rclo2_base, H.
  + assert (REL: clo (rclo2 clo r1 \2/ rclo2 clo r2) x0 x1).
    { eapply MON. apply IN. apply H. }
    apply DIST in REL. destruct REL; [left|right]; apply rclo2_clo, H0.
Qed.

Lemma rclo2_compat clo
      (COM: compatible2 clo):
  compatible2 (rclo2 clo).
Proof.
  econstructor.
  - apply rclo2_mon.
  - intros. induction PR.
    + eapply gf_mon. apply IN.
      intros. eapply rclo2_base. apply PR.
    + eapply gf_mon.
      * eapply COM. eapply COM. apply IN. apply H.
      * intros. eapply rclo2_clo. apply PR.
Qed.

Lemma rclo2_wcompat clo
      (COM: wcompatible2 clo):
  wcompatible2 (rclo2 clo).
Proof.
  econstructor.
  - apply rclo2_mon.
  - intros. induction PR.
    + eapply gf_mon. apply IN.
      intros. apply gpaco2_base. apply PR.
    + eapply gf_mon.
      * eapply COM. eapply COM. apply IN. apply H.
      * intros. eapply gpaco2_gupaco. apply gf_mon.
        eapply gupaco2_mon_gen; intros; [apply PR|apply gf_mon|apply PR0| |apply PR0].
        apply rclo2_clo_base, PR0.
Qed.

Lemma compat2_wcompat clo
      (CMP: compatible2 clo):
  wcompatible2 clo.
Proof.
  econstructor. apply CMP.
  intros. apply CMP in PR.
  eapply gf_mon. apply PR.
  intros. apply gpaco2_clo, PR0.
Qed.

Lemma wcompat2_compat clo
      (WCMP: wcompatible2 clo) :
  compatible2 (gupaco2 gf clo).
Proof.
  econstructor.
  { red; intros. eapply gpaco2_mon. apply IN. apply LE. apply LE. }

  intros. apply gpaco2_unfold in PR; [|apply gf_mon].
  induction PR.
  - destruct IN; cycle 1.
    + eapply gf_mon. apply H.
      intros. apply gpaco2_base, PR.
    + eapply gf_mon. apply H.
      intros. apply gpaco2_gupaco. apply gf_mon.
      eapply gupaco2_mon. apply PR.
      intros. apply gpaco2_step. apply gf_mon.
      eapply gf_mon. destruct PR0 as [X|X]; apply X.
      intros. apply gpaco2_base, PR1.
  - eapply gf_mon, gpaco2_gupaco, gf_mon.
    apply WCMP. eapply WCMP. apply IN.
    intros. apply H, PR.
Qed.

Lemma wcompat2_union clo1 clo2
      (WCMP1: wcompatible2 clo1)
      (WCMP2: wcompatible2 clo2):
  wcompatible2 (clo1 \3/ clo2).
Proof.
  econstructor.
  - apply monotone2_union. apply WCMP1. apply WCMP2.
  - intros. destruct PR.
    + apply WCMP1 in H. eapply gf_mon. apply H.
      intros. eapply gupaco2_mon_gen. apply PR. apply gf_mon.
      intros; apply PR0. left; apply PR0. intros; apply PR0.
    + apply WCMP2 in H. eapply gf_mon. apply H.
      intros. eapply gupaco2_mon_gen. apply PR. apply gf_mon.
      intros; apply PR0. right; apply PR0. intros; apply PR0.
Qed.

End Compatibility.

Section Soundness.

Variable gf: rel -> rel.
Hypothesis gf_mon: monotone2 gf.

Lemma gpaco2_compat_init clo
      (CMP: compatible2 gf clo):
  gpaco2 gf clo bot2 bot2 <2= paco2 gf bot2.
Proof.
  intros. destruct PR. revert x0 x1 IN.
  pcofix CIH. intros.
  pstep. eapply gf_mon; [| right; apply CIH, rclo2_rclo, PR].
  apply compat2_compat with (gf:=gf). apply rclo2_compat. apply gf_mon. apply CMP.
  eapply rclo2_mon. apply IN.
  intros. destruct PR; [|contradiction]. _punfold H; [..|apply gpaco2_def_mon, gf_mon].
  eapply gpaco2_def_mon. apply gf_mon. apply H.
  intros. destruct PR; [|destruct H0; contradiction]. left. apply H0.
Qed.

Lemma gpaco2_init clo
      (WCMP: wcompatible2 gf clo):
  gpaco2 gf clo bot2 bot2 <2= paco2 gf bot2.
Proof.
  intros. eapply gpaco2_compat_init.
  - apply wcompat2_compat, WCMP. apply gf_mon.
  - eapply gpaco2_mon_bot. apply PR. apply gf_mon. intros; apply PR0.
    intros. apply gpaco2_clo, PR0.
Qed.

Lemma gpaco2_unfold_bot clo
      (WCMP: wcompatible2 gf clo):
  gpaco2 gf clo bot2 bot2 <2= gf (gpaco2 gf clo bot2 bot2).
Proof.
  intros. apply gpaco2_init in PR; [|apply WCMP].
  _punfold PR; [..|apply gf_mon].
  eapply gf_mon. apply PR.
  intros. destruct PR0; [|contradiction]. apply gpaco2_final. apply gf_mon. right. apply H.
Qed.

End Soundness.

Section Distributivity.

Variable gf: rel -> rel.
Hypothesis gf_mon: monotone2 gf.

Lemma gpaco2_dist clo r rg
      (CMP: wcompatible2 gf clo)
      (DIST: forall r1 r2, clo (r1 \2/ r2) <2= (clo r1 \2/ clo r2)):
  gpaco2 gf clo r rg <2= (paco2 gf (rclo2 clo (rg \2/ r)) \2/ rclo2 clo r).
Proof.
  intros. apply gpaco2_unfold in PR; [|apply gf_mon].
  apply rclo2_dist in PR; [|apply CMP|apply DIST].
  destruct PR; [|right; apply H].
  left. revert x0 x1 H.
  pcofix CIH; intros.
  apply rclo2_wcompat in H0; [|apply gf_mon|apply CMP].
  pstep. eapply gf_mon. apply H0. clear  x0 x1 H0. intros.
  apply gpaco2_unfold in PR; [|apply gf_mon].
  apply rclo2_compose in PR.
  apply rclo2_dist in PR; [|apply CMP|apply DIST].
  destruct PR.
  - right. apply CIH.
    eapply rclo2_mon. apply H. intros.
    eapply gf_mon. apply PR. intros.
    apply gpaco2_gupaco. apply gf_mon.
    apply gpaco2_gen_rclo. apply gf_mon.
    eapply gupaco2_mon. apply PR0. intros.
    destruct PR1; apply H0.
  - assert (REL: @rclo2 clo (rclo2 clo (gf (gupaco2 gf clo ((rg \2/ r) \2/ (rg \2/ r))) \2/ (rg \2/ r))) x0 x1).
    { eapply rclo2_mon. apply H. intros. apply gpaco2_unfold in PR. apply PR. apply gf_mon. }
    apply rclo2_rclo in REL.
    apply rclo2_dist in REL; [|apply CMP|apply DIST].
    right. destruct REL; cycle 1.
    + apply CIH0, H0.
    + apply CIH.
      eapply rclo2_mon. apply H0. intros.
      eapply gf_mon. apply PR. intros.
      eapply gupaco2_mon. apply PR0. intros.
      destruct PR1; apply H1.
Qed.

Lemma gpaco2_dist_reverse clo r rg:
  (paco2 gf (rclo2 clo (rg \2/ r)) \2/ rclo2 clo r) <2= gpaco2 gf clo r rg.
Proof.
  intros. destruct PR; cycle 1.
  - eapply gpaco2_rclo. apply H.
  - econstructor. apply rclo2_base. left.
    revert x0 x1 H. pcofix CIH; intros.
    _punfold H0; [|apply gf_mon]. pstep.
    eapply gf_mon. apply H0. intros.
    destruct PR.
    + apply rclo2_base. right. apply CIH, H.
    + eapply rclo2_mon. apply H. intros.
      right. apply CIH0. apply PR.
Qed.

End Distributivity.

Section Companion.

Variable gf: rel -> rel.
Hypothesis gf_mon: monotone2 gf.

Inductive cpn2 (r: rel) x0 x1 : Prop :=
| cpn2_intro
    clo
    (COM: compatible2 gf clo)
    (CLO: clo r x0 x1)
.

Lemma cpn2_mon: monotone2 cpn2.
Proof.
  red. intros.
  destruct IN. exists clo.
  - apply COM.
  - eapply compat2_mon; [apply COM|apply CLO|apply LE].
Qed.

Lemma cpn2_greatest: forall clo (COM: compatible2 gf clo), clo <3= cpn2.
Proof. intros. econstructor;[apply COM|apply PR]. Qed.

Lemma cpn2_compat: compatible2 gf cpn2.
Proof.
  econstructor; [apply cpn2_mon|intros].
  destruct PR; eapply gf_mon with (r:=clo r).
  - eapply (compat2_compat COM); apply CLO.
  - intros. econstructor; [apply COM|apply PR].
Qed.

Lemma cpn2_wcompat: wcompatible2 gf cpn2.
Proof. apply compat2_wcompat, cpn2_compat. apply gf_mon. Qed.

Lemma cpn2_gupaco:
  gupaco2 gf cpn2 <3= cpn2.
Proof.
  intros. eapply cpn2_greatest, PR. apply wcompat2_compat. apply gf_mon. apply cpn2_wcompat.
Qed.

Lemma cpn2_cpn r:
  cpn2 (cpn2 r) <2= cpn2 r.
Proof.
  intros. apply cpn2_gupaco, gpaco2_gupaco, gpaco2_clo. apply gf_mon.
  eapply cpn2_mon, gpaco2_clo. apply PR.
Qed.

Lemma cpn2_base r:
  r <2= cpn2 r.
Proof.
  intros. apply cpn2_gupaco. apply gpaco2_base, PR.
Qed.

Lemma cpn2_clo
      r clo (LE: clo <3= cpn2):
  clo (cpn2 r) <2= cpn2 r.
Proof.
  intros. apply cpn2_cpn, LE, PR.
Qed.

Lemma cpn2_step r:
  gf (cpn2 r) <2= cpn2 r.
Proof.
  intros. apply cpn2_gupaco. apply gpaco2_step. apply gf_mon.
  eapply gf_mon, gpaco2_clo. apply PR.
Qed.

Lemma cpn2_uclo uclo
      (MON: monotone2 uclo)
      (WCOM: forall r, uclo (gf r) <2= gf (gupaco2 gf (uclo \3/ cpn2) r)):
  uclo <3= gupaco2 gf cpn2.
Proof.
  intros. apply gpaco2_clo.
  exists (gupaco2 gf (uclo \3/ cpn2)).
  - apply wcompat2_compat. apply gf_mon.
    econstructor.
    + apply monotone2_union. apply MON. apply cpn2_mon.
    + intros. destruct PR0.
      * apply WCOM, H.
      * apply compat2_compat with (gf:=gf) in H; [| apply cpn2_compat].
        eapply gf_mon. apply H. intros.
        apply gpaco2_clo. right. apply PR0.
  - apply gpaco2_clo. left. apply PR.
Qed.

End Companion.

Section Respectful.

Variable gf: rel -> rel.
Hypothesis gf_mon: monotone2 gf.

Structure wrespectful2 (clo: rel -> rel) : Prop :=
  wrespect2_intro {
      wrespect2_mon: monotone2 clo;
      wrespect2_respect :
        forall l r
               (LE: l <2= r)
               (GF: l <2= gf r),
        clo l <2= gf (rclo2 clo r);
    }.

Structure prespectful2 (clo: rel -> rel) : Prop :=
  prespect2_intro {
      prespect2_mon: monotone2 clo;
      prespect2_respect :
        forall l r
               (LE: l <2= r)
               (GF: l <2= gf r),
        clo l <2= paco2 gf (r \2/ clo r);
    }.

Structure grespectful2 (clo: rel -> rel) : Prop :=
  grespect2_intro {
      grespect2_mon: monotone2 clo;
      grespect2_respect :
        forall l r
               (LE: l <2= r)
               (GF: l <2= gf r),
        clo l <2= rclo2 (cpn2 gf) (gf (rclo2 (clo \3/ gupaco2 gf (cpn2 gf)) r));
    }.

Definition gf'2 := id /3\ gf.

Definition compatible'2 := compatible2 gf'2.

Lemma wrespect2_compatible'
      clo (RES: wrespectful2 clo):
  compatible'2 (rclo2 clo).
Proof.
  intros. econstructor. apply rclo2_mon.
  intros. destruct RES. split.
  { eapply rclo2_mon. apply PR. intros. apply PR0. }
  induction PR; intros.
  - eapply gf_mon. apply IN.
    intros. apply rclo2_base, PR.
  - eapply gf_mon.
    + eapply wrespect2_respect0; [|apply H|apply IN].
      intros. eapply rclo2_mon; intros; [apply LE, PR|apply PR0].
    + intros. apply rclo2_rclo, PR.
Qed.

Lemma prespect2_compatible'
      clo (RES: prespectful2 clo):
  compatible'2 (fun r => upaco2 gf (r \2/ clo r)).
Proof.
  econstructor.
  { red; intros. eapply upaco2_mon. apply IN.
    intros. destruct PR.
    - left. apply LE, H.
    - right. eapply RES. apply H. intros. apply LE, PR. }

  intros r.
  assert (LEM: (gf'2 r \2/ clo (gf'2 r)) <2= (r \2/ clo r)).
  { intros. destruct PR.
    - left. apply H.
    - right. eapply RES. apply H. intros. apply PR.
  }

  intros. destruct PR.
  - split.
    + left. eapply paco2_mon. apply H. apply LEM.
    + apply paco2_unfold; [apply gf_mon|].
      eapply paco2_mon. apply H. apply LEM.
  - split.
    + right. apply LEM. apply H.
    + destruct H.
      * eapply gf_mon. apply H. intros. right. left. apply PR.
      * apply paco2_unfold; [apply gf_mon|].
        eapply RES, H; intros; apply PR.
Qed.

Lemma grespect2_compatible'
      clo (RES: grespectful2 clo):
  compatible'2 (rclo2 (clo \3/ cpn2 gf)).
Proof.
  apply wrespect2_compatible'.
  econstructor.
  { red; intros. destruct IN.
    - left. eapply RES; [apply H|]. apply LE.
    - right. eapply cpn2_mon; [apply H|]. apply LE. }
  intros. destruct PR.
  - eapply RES.(grespect2_respect) in H; [|apply LE|apply GF].
    apply (@compat2_compat gf (rclo2 (cpn2 gf))) in H.
    2: { apply rclo2_compat; [apply gf_mon|]. apply cpn2_compat. apply gf_mon. }
    eapply gf_mon; [apply H|].
    intros. apply rclo2_clo. right.
    exists (rclo2 (cpn2 gf)).
    { apply rclo2_compat; [apply gf_mon|]. apply cpn2_compat. apply gf_mon. }
    eapply rclo2_mon; [eapply PR|].
    intros. eapply rclo2_mon_gen; [eapply PR0|..].
    + intros. destruct PR1.
      * left. apply H0.
      * right. apply cpn2_gupaco; [apply gf_mon|apply H0].
    + intros. apply PR1.
  - eapply gf_mon.
    + apply (@compat2_compat gf (rclo2 (cpn2 gf))).
      { apply rclo2_compat; [apply gf_mon|]. apply cpn2_compat. apply gf_mon. }
      eapply rclo2_clo_base. eapply cpn2_mon; [apply H|apply GF].
    + intros. eapply rclo2_mon_gen; [eapply PR|..].
      * intros. right. apply PR0.
      * intros. apply PR0.
Qed.

Lemma compat2_compatible'
      clo (COM: compatible2 gf clo):
  compatible'2 clo.
Proof.
  destruct COM. econstructor; [apply compat2_mon0|].
  intros. split.
  - eapply compat2_mon0; intros; [apply PR| apply PR0].
  - apply compat2_compat0.
    eapply compat2_mon0; intros; [apply PR| apply PR0].
Qed.

Lemma compatible'2_companion
      clo (RES: compatible'2 clo):
  clo <3= cpn2 gf.
Proof.
  assert (MON: monotone2 gf'2).
  { econstructor. apply LE, IN.
    eapply gf_mon, LE. apply IN.
  }
  assert (CPN: clo <3= cpn2 gf'2).
  { intros. econstructor. apply RES. apply PR.
  }
  intros. apply CPN in PR.
  econstructor; [|apply PR].
  econstructor; [apply cpn2_mon|]; intros.
  assert (PR1: cpn2 gf'2 (gf r) <2= cpn2 gf'2 (gf'2 (cpn2 gf r))).
  { intros. eapply cpn2_mon. apply PR1.
    intros. assert (TMP: gf (cpn2 gf r) <2= (cpn2 gf r /2\ gf (cpn2 gf r))).
    { split; [apply cpn2_step; [apply gf_mon|]|]; assumption. }
    apply TMP.
    eapply gf_mon. apply PR2. intros. apply cpn2_base; assumption.
  }
  apply PR1 in PR0. clear PR1.
  eapply compat2_compat with (gf:=gf'2) in PR0; [|apply cpn2_compat, MON].
  eapply gf_mon; [apply PR0|].
  intros. eapply cpn2_cpn; [apply MON|].
  eapply cpn2_mon; [apply PR1|].
  intros. econstructor; [|apply PR2].
  apply compat2_compatible', cpn2_compat, gf_mon.
Qed.

Lemma wrespect2_companion
      clo (RES: wrespectful2 clo):
  clo <3= cpn2 gf.
Proof.
  intros. eapply wrespect2_compatible' in RES.
  eapply (@compatible'2_companion (rclo2 clo)) in RES; [apply RES|].
  eapply rclo2_clo_base, PR.
Qed.

Lemma prespect2_companion
      clo (RES: prespectful2 clo):
  clo <3= cpn2 gf.
Proof.
  intros. eapply compatible'2_companion. apply prespect2_compatible'. apply RES.
  right. right. apply PR.
Qed.

Lemma grespect2_companion
      clo (RES: grespectful2 clo):
  clo <3= cpn2 gf.
Proof.
  intros. eapply grespect2_compatible' in RES.
  eapply (@compatible'2_companion (rclo2 (clo \3/ cpn2 gf))); [apply RES|].
  apply rclo2_clo_base. left. apply PR.
Qed.

Lemma wrespect2_uclo
      clo (RES: wrespectful2 clo):
  clo <3= gupaco2 gf (cpn2 gf).
Proof.
  intros. eapply gpaco2_clo, wrespect2_companion, PR. apply RES.
Qed.

Lemma prespect2_uclo
      clo (RES: prespectful2 clo):
  clo <3= gupaco2 gf (cpn2 gf).
Proof.
  intros. eapply gpaco2_clo, prespect2_companion, PR. apply RES.
Qed.

Lemma grespect2_uclo
      clo (RES: grespectful2 clo):
  clo <3= gupaco2 gf (cpn2 gf).
Proof.
  intros. eapply gpaco2_clo, grespect2_companion, PR. apply RES.
Qed.

End Respectful.

End GeneralizedPaco2.

#[export] Hint Resolve gpaco2_def_mon : paco.
#[export] Hint Unfold gupaco2 : paco.
#[export] Hint Resolve gpaco2_base : paco.
#[export] Hint Resolve gpaco2_step : paco.
#[export] Hint Resolve gpaco2_final : paco.
#[export] Hint Resolve rclo2_base : paco.
#[export] Hint Constructors gpaco2 : paco.
#[export] Hint Resolve wrespect2_uclo : paco.
#[export] Hint Resolve prespect2_uclo : paco.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext.
Require Import machine_int.
Import MachineInt.
Require Import mips_cmd.
Export mips_cmd.

Declare Scope mips_hoare_scope.

Local Close Scope positive_scope.
Local Open Scope heap_scope.
Import expr_m.
Local Open Scope mips_expr_scope.
Import assert_m.
Local Open Scope mips_assert_scope.
Local Open Scope mips_cmd_scope.
Local Open Scope machine_int_scope.

(** * Separation Logic *)

(** Predicate transformers *)

Local Open Scope zarith_ext_scope.

(** The effect of executing %\coqdocvar{add rd rs rt}%#add rd rs rt# is
to update the contents of the register %\coqdocvar{rd}%#rd# with the result of the
operation %\coqdocvar{vrs}\ensuremath{\boxplus}\coqdocvar{vrt}%#vrs `+ vrt# (where %vrs%#vrs# and %vrt%#vrt# are the contents of the registers rs and rt), provided the addition in
two's complement does not overflow: *)
Definition wp_add rd rs rt P : assert := fun s h =>
  - 2 ^^ 31 <=  s2Z [rs]_s + s2Z [rt]_s < 2 ^^ 31 /\
  P (store.upd rd ([rs]_s `+ [rt]_s) s) h.

Definition wp_addi rt rs (imm : immediate) P : assert := fun s h =>
  - 2 ^^ 31 <= s2Z ([rs]_s) + s2Z (sext 16 imm) < 2 ^^ 31 /\
  P (store.upd rt ([rs]_s `+ sext 16 imm) s) h.

Definition wp_addiu rt rs (imm : immediate) P : assert := fun s =>
  P (store.upd rt ([rs]_s `+ sext 16 imm) s).

Definition wp_addu rd rs rt P : assert := fun s =>
  P (store.upd rd ([rs]_s `+ [rt]_s) s).

Definition wp_and rd rs rt P : assert := fun s =>
  P (store.upd rd ([rs]_s `& [rt]_s) s).

Definition wp_andi rt rs (imm : immediate) P : assert := fun s =>
  P (store.upd rt ([rs]_s `& zext 16 imm) s).

(** The function wp_lw checks that the access is word-aligned and the cell-contents
specified: *)
Definition wp_lw rt (off : immediate) base P : assert := fun s h =>
 exists p, u2Z (eval (var_e base) s `+ sext 16 off) = 4 * Z_of_nat p /\
  exists z, heap.get p h = Some z /\ P (store.upd rt z s) h.

Definition wp_lwxs rt idx base P : assert := fun s h =>
 exists l, u2Z ([base]_s `+ shl 2 [idx]_s) = 4 * Z_of_nat l /\
  exists z, heap.get l h = Some z /\ P (store.upd rt z s) h.

Definition wp_maddu rs rt P : assert := fun s h =>
  P (store.maddu_op ([rs]_s `* [rt]_s) s) h .

Definition wp_mfhi rd P : assert := fun s h =>
  P (store.upd rd (store.hi s) s) h.

Definition wp_mflhxu rd P : assert := fun s h =>
  P (store.mflhxu_op (store.upd rd (store.lo s) s)) h.

Definition wp_mflo rd P : assert := fun s h =>
  P (store.upd rd (store.lo s) s) h.

Definition wp_movn rd rs rt (P : assert) : assert := fun s h =>
  ([rt]_s <> zero32 -> P (store.upd rd [rs]_s s) h) /\
  ([rt]_s = zero32 -> P s h).

Definition wp_movz rd rs rt (P : assert) : assert := fun s h =>
  ([rt]_s = zero32 -> P (store.upd rd [rs]_s s) h) /\
  ([rt]_s <> zero32 -> P s h).

Definition wp_msubu rs rt P : assert := fun s h =>
  P (store.msubu_op ([rs]_s `* [rt]_s) s) h.

Definition wp_mthi rs P : assert := fun s h =>
  P (store.mthi_op [rs]_s s) h.

Definition wp_mtlo rs P : assert := fun s h =>
  P (store.mtlo_op [rs]_s s) h.

Definition wp_multu rs rt P : assert := fun s h =>
  P (store.multu_op ([rs]_s `* [rt]_s) s) h.

Definition wp_nor rd rs rt P : assert := fun s =>
  P (store.upd rd (int_not (int_or [rs]_s [rt]_s)) s).

Definition wp_or rd rs rt P : assert := fun s =>
  P (store.upd rd (int_or [rs]_s [rt]_s) s).

Definition wp_sll rx ry (sa : shifta) P : assert := fun s =>
  P (store.upd rx (shl '|u2Z sa| [ry]_s) s).

Definition wp_sllv rd rt rs P : assert := fun s =>
  P (store.upd rd ([rt]_s `<< '| u2Z ([rs]_s `% 5)|) s).

Definition wp_sltu rd rs rt P : assert := fun s =>
  P (store.upd rd (if (u2Z [rs]_s <? u2Z [rt]_s) then one32 else zero32) s).

Definition wp_sra rd rt (sa : shifta) P : assert := fun s =>
  P (store.upd rd (shra '|u2Z sa| [rt]_s) s).

Definition wp_srl rd rt (sa : shifta) P : assert := fun s =>
  P (store.upd rd ([rt]_s `>> '|u2Z sa|) s).

Definition wp_srlv rd rt rs P : assert := fun s =>
  P (store.upd rd ([rt]_s `>> '|u2Z ([rs]_s `% 5)|) s).

Definition wp_subu rd rs rt P : assert := fun s =>
  P (store.upd rd ([rs]_s `+ cplt2 [rt]_s) s).

Definition wp_sw rt (off : immediate) base P : assert := fun s h =>
  exists l, u2Z ([base]_s `+ sext 16 off) = 4 * Z_of_nat l /\
    (exists z, heap.get l h = Some z) /\
    P s (heap.upd l [rt]_s h).

Definition wp_xor rd rs rt P : assert := fun s =>
  P (store.upd rd (int_xor [rs]_s [rt]_s) s).

Definition wp_xori rt rs imm P : assert := fun s =>
  P (store.upd rt (int_xor [rs]_s (zext 16 imm)) s).

Definition wp0 (c : cmd0) (Q : assert) : assert :=
match c with
  | nop => Q
  | add rd rs rt => wp_add rd rs rt Q
  | addi rt rs imm => wp_addi rt rs imm Q
  | addiu rt rs imm => wp_addiu rt rs imm Q
  | addu rd rs rt => wp_addu rd rs rt Q
  | cmd_and rd rs rt => wp_and rd rs rt Q
  | andi rt rs imm => wp_andi rt rs imm Q
  | lw rt offset base => wp_lw rt offset base Q
  | lwxs rt index base => wp_lwxs rt index base Q
  | maddu rs rt => wp_maddu rs rt Q
  | mfhi rd => wp_mfhi rd Q
  | mflhxu rd  => wp_mflhxu rd Q
  | mflo rd => wp_mflo rd Q
  | movn rd rs rt => wp_movn rd rs rt Q
  | movz rd rs rt => wp_movz rd rs rt Q
  | mthi rs => wp_mthi rs Q
  | mtlo rs => wp_mtlo rs Q
  | msubu rs rt => wp_msubu rs rt Q
  | multu rs rt => wp_multu rs rt Q
  | nor rd rs rt => wp_nor rd rs rt Q
  | cmd_or rd rs rt => wp_or rd rs rt Q
  | sll rx ry sa => wp_sll rx ry sa Q
  | sllv rd rs rt => wp_sllv rd rs rt Q
  | sltu rd rs rt => wp_sltu rd rs rt Q
  | sra rd rt sa => wp_sra rd rt sa Q
  | srl rd rt sa => wp_srl rd rt sa Q
  | srlv rd rt rs => wp_srlv rd rt rs Q
  | subu rd rs rt => wp_subu rd rs rt Q
  | sw rt offset base => wp_sw rt offset base Q
  | xor rd rs rt => wp_xor rd rs rt Q
  | xori rt rs imm => wp_xori rt rs imm Q
end.

Lemma wp0_no_err : forall s h c P,
  wp0 c P s h -> ~ (Some (s,h) -- c ----> None).
Proof.
move=> s h c P Hwp0 Hexec; inversion Hexec as [ | |
(* addi_err *)s' h' rt rs imm Hcond Hs Hc HNone | |
(* add_err *)s' h' rt rs imm Hcond Hs Hc HNone | | | | | |
(* lw_err *)s' h' rt off base Hcond | |
(* lwxs_err *)s' h' rt off base Hcond | | | | | | | | | | | | | | | | | | | | | | |
(* sw_err *)s' h' rt off base Hcond | | ]; subst.
- by case: Hwp0 => Hwp0 _ //.
- by case: Hwp0 => Hwp0 _ //.
- case: Hwp0 => x [Hx [z [Hz _]]].
  rewrite [eval _ _]/= in Hx.
  by apply Hcond; exists x; split => //; exists z.
- case: Hwp0 => x [Hx [z [Hz _]]].
  by apply Hcond; exists x; split => //; exists z.
- case: Hwp0 => x [Hx [[z Hz] _]].
  by apply Hcond; exists x; split => //; exists z.
Qed.

Lemma exec0_from_wp0 : forall ST (c : cmd0) ST', ST -- c ----> ST' ->
  forall P s h s' h', ST = Some (s, h) -> ST' = Some (s', h') ->
    wp0 c P s h -> P s' h'.
Proof.
move=> ST c ST'; elim => //; clear ST c ST'.
- (* nop *) by move=> st P s h0 s' h' -> [] <- <- ?.
- move=> s h rd rs rt H P s1 h1 s' h' [] X Y; subst.
  case=> X Y; subst; rewrite /= /wp_add; tauto.
- move=> s h rt rs imm H P s1 h1 s' h' [] X Y; subst.
  case=> X Y; subst; rewrite /= /wp_addi; tauto.
- (* addiu *) by move=> s h rd rs rt P s1 h1 s' h' [] <- <- [] <- <-.
- (* addu *) by move=> s h rt rs imm P s1 h1 s' h' [] <- <- [] <- <-.
- (* cmd_and *) by move=> s h rd rs rt P s1 h1 s' h' [] <- <- [] <- <-.
- (* andi *) by move=> s h rt rs imm P s1 h1 s' h' [] <- <- [] <- <-.
- (* lw *) move=> s h rt offst base p z Hp Hz P s0 h0 s' h' [] X Y; subst.
  case=> X Y; subst; case=> p' [Hp' [z' [Hz' HP]]].
suff : z = z' by move=> ->.
  have X : p = p' by rewrite [eval _ _]/= in Hp'; by lia.
  subst; rewrite Hz' in Hz; by case: Hz.
- (* lwxs *) move=> s h rt index base p z Hp Hz P s0 eh0 s' h' [] X Y; subst.
  case=> X Y; subst; case=> p' [Hp' [z' [Hz' HP]]].
  suff : z = z' by move=> ->.
  have X : p = p' by lia.
  subst; rewrite Hz' in Hz; by case: Hz.
- (* maddu *) by move=> s h rs rt P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* mfhi *) by move=> s h rd P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* mflhxu *) by move=> s h rd P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* mflo *) by move=> s h rd P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* movn true *) move=> s h rd rs rt H P s0  h0 s1 h1 [] X Y; subst.
  case=> X Y; subst; rewrite /= /wp_movn; tauto.
- (* movn false *) move=> s h rd rs rt H P s0 h0 s1 h1 [] X Y; subst.
  case=> X Y; subst; rewrite /= /wp_movn; tauto.
- (* movz true *) move=> s h rd rs rt H P s0 h0 s1 h1 [] X Y; subst.
  case=> X Y; subst; rewrite /= /wp_movz; tauto.
- (* movz false *) move=> s h rd rs rt H P s0 h0 s1 h1 [] X Y; subst.
  case=> X Y; subst; rewrite /= /wp_movz; tauto.
- (* msubu *) by move=> s h rs rt P s1 h1 s' h' [] <- <- [] <- <-.
- (* mthi *) by move=> s h rs P s1 h1 s' h' [] <- <- [] <- <-.
- (* mtlo *) by move=> s h rs P s1 h1 s' h' [] <- <- [] <- <-.
- (* multu *) by move=> s h rs rt P s1 h1 s' h' [] <- <- [] <- <-.
- (* no *) by move=> s h rd rs rt P s1 h1 s' h' [] <- <- [] <- <-.
- (* cmd_or *) by move=> s h rd rs rt P s1 h1 s' h' [] <- <- [] <- <-.
- (* sll *) by move=> s h rx ry sa P s0 h0 s' h' [] <- <- [] <- <-.
- (* sllv *) by move=> s h rd rs rt P s0 h0 s' h' [] <- <- [] <- <-.
- (* sltu *) move=> s h rd rs rt flag H P s0 h0 s1 h1 [] X Y; subst.
  case=> X Y; subst => //.
- (* sra *) by move=> s h rd rt sa P s0 h0 s' h' [] <- <- [] <- <-.
- (* srl *) by move=> s h rd rt sa P s0 h0 s' h' [] <- <- [] <- <-.
- (* srlv *) by move=> s h rd rt rs P s0 h0 s' h' [] <- <- [] <- <-.
- (* subu *) by move=> s h rd rs rt P s1 h1 s' h' [] <- <- [] <- <-.
- (* sw *) move => s h rt off base p H [z Hz] P s1 h1 s' h' [] X Y; subst.
  case=> X Y; subst; case=> l [Hl [z' Hz']].
  suff : p = l by move=> ->.
  lia.
- (* xor *) by move=> s h rd rs rt P s1 h1 s' h' [] <- <- [] <- <-.
- (* xori *) by move=> s h rt rs imm P s1 h1 s' h' [] <- <- [] <- <-.
Qed.

Lemma exec0_to_wp0 : forall ST (c : cmd0) ST', ST -- c ----> ST' ->
  forall (P: assert) s h s' h', ST = Some (s,h) -> ST' = Some (s',h') ->
    P s' h' -> wp0 c P s h.
Proof.
move=> ST c ST'; elim => //; clear ST c ST'.
- (* nop *) by move=> st P s h s' h' -> [] <- <- ?.
- (* add *) by move=> s h rd rs rt H P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* addi *) by move=> s h rt rs imm H P s1 h2 s' h' [] <- <- [] <- <-.
- (* addiu *) by move=> s h rt rs imm P s1 h2 s' h' [] <- <- [] <- <-.
- (* addu *) by move=> s h rd rs rt P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* cmd_and *) by move=> s h rd rs rt P s0 h0 s' h' [] <- <- [] <- <-.
- (* andi *) by move=> s h rt rs imm P s0 h0 s' h' [] <- <- [] <- <-.
- (* lw *) move=> s h rt offset base p z H Hz P s0 h0 s1 h1 [] X Y; subst.
  case=> X Y; subst; rewrite /wp0 /wp_lw // => H'.
  by exists p; split => //; exists z => //.
- (* lwxs *) move=> s h rt index base p z Hp Hz P s0 h0 s1 h1 [] X Y; subst.
  case=> X Y; subst; rewrite /= /wp0 /wp_lwxs => H'.
  by exists p; split => //; exists z => //.
- (* maddu *) by move=> s h rs rt P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* mfhi *) by move=> s h rd P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* mflhxu *) by move=> s h rd P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* mflo *) by move=> s h rd P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* movn true *) by move=> s h rd rs rt H P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* movn false *) by move=> s h rd rs rt H P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* movz true *) by move=> s h rd rs rt H P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* movz false *) by move=> s h rd rs rt H P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* msubu *) by move=> s h rs rt P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* mthi *) by move=> s h rs P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* mtlo *) by move=> s h rs P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* multu *) by move=> s h rs rt P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* nor *) by move=> s h rd rs rt P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* cmd_or *) by move=> s h rd rs rt P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* sll *) by move=> s h rd rt sa P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* sllv *) by move=> s h rd rs rt P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* sltu *) move=> s h rd rs rt flag Hflag P s0 h0 s1 h1 [] X Y; subst.
  case=> X Y; subst => //.
- (* sra *) by move=> s h rd rt sa P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* shrl *) by move=> s h rd rt sa P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* srlv *) by move=> s h rd rt rs P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* sw *) by move=> s h rd rs rt P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* subu *) move=> s h rt offset base p H [z Hz] P s1 h1 s' h' [] X Y; subst.
  case=> X Y; subst => H'.
  rewrite /wp0 /wp_sw.
  by exists p; split => //; split => //; exists z.
- (* xor *) by move=> s h rd rs rt P s0 h0 s1 h1 [] <- <- [] <- <-.
- (* xori *) by move=> s h rt rs imm P s0 h0 s1 h1 [] <- <- [] <- <-.
Qed.

Lemma exec0_wp0 : forall s h (c : cmd0) s' h', Some (s, h) -- c ----> Some (s', h') ->
  forall P, wp0 c P s h <-> P s' h'.
Proof.
move=> s h c s' h' H P; split=> H'.
eapply exec0_from_wp0; [by apply H | reflexivity | reflexivity | exact H'].
eapply exec0_to_wp0; [by apply H | reflexivity | reflexivity | exact H'].
Qed.

(* dummy *)
Notation "'_assert'" := assert : mips_hoare_scope.
Local Open Scope mips_hoare_scope.

(** Separation Logic (Partial Correctness) *)

(** Separation logic triples are formalized as an inductive relation
$\{ P \} c \{ Q \}$#{{ P }} c {{ Q }}# between commands and pre/post-conditions
encoded as assertions: *)
Reserved Notation "{{[ P ]}} c {{[ Q ]}}" (at level 82, no associativity).
Inductive hoare0 : assert -> cmd0 -> assert -> Prop :=
| hoare0_nop: forall P, {{[ P ]}} nop {{[ P ]}}
| hoare0_add: forall Q rs rt rd, {{[ wp_add rd rs rt Q ]}} add rd rs rt {{[ Q ]}}
| hoare0_addi : forall Q rt rs imm, {{[ wp_addi rt rs imm Q ]}} addi rt rs imm {{[ Q ]}}
| hoare0_addiu : forall Q rt rs imm, {{[ wp_addiu rt rs imm Q ]}} addiu rt rs imm {{[ Q ]}}
| hoare0_addu: forall Q rs rt rd , {{[ wp_addu rd rs rt Q ]}} addu rd rs rt {{[ Q ]}}
| hoare0_and : forall Q rd rs rt, {{[ wp_and rd rs rt Q ]}} cmd_and rd rs rt {{[ Q ]}}
| hoare0_andi : forall Q rt rs imm, {{[ wp_andi rt rs imm Q ]}} andi rt rs imm {{[ Q ]}}
| hoare0_lw : forall Q rt off base, {{[ wp_lw rt off base Q ]}} lw rt off base {{[ Q ]}}
| hoare0_lwxs : forall rt idx base Q, {{[ wp_lwxs rt idx base Q ]}} lwxs rt idx base {{[ Q ]}}
| hoare0_maddu : forall Q rs rt, {{[ wp_maddu rs rt Q ]}} maddu rs rt {{[ Q ]}}
| hoare0_mfhi : forall Q rd, {{[ wp_mfhi rd Q ]}} mfhi rd {{[ Q ]}}
| hoare0_mflhxu : forall rd Q, {{[ wp_mflhxu rd Q ]}} mflhxu rd {{[ Q ]}}
| hoare0_mflo : forall Q rd, {{[ wp_mflo rd Q ]}} mflo rd {{[ Q ]}}
| hoare0_movn : forall Q rd rs rt, {{[ wp_movn rd rs rt Q ]}} movn rd rs rt {{[ Q ]}}
| hoare0_movz : forall Q rd rs rt, {{[ wp_movz rd rs rt Q ]}} movz rd rs rt {{[ Q ]}}
| hoare0_msubu : forall Q rs rt, {{[ wp_msubu rs rt Q ]}} msubu rs rt {{[ Q ]}}
| hoare0_mthi : forall Q rs, {{[ wp_mthi rs Q ]}} mthi rs {{[ Q ]}}
| hoare0_mtlo : forall Q rs, {{[ wp_mtlo rs Q ]}} mtlo rs {{[ Q ]}}
| hoare0_multu : forall Q rs rt, {{[ wp_multu rs rt Q ]}} multu rs rt {{[ Q ]}}
| hoare0_nor : forall Q rd rs rt, {{[ wp_nor rd rs rt Q ]}} nor rd rs rt {{[ Q ]}}
| hoare0_or : forall Q rd rs rt, {{[ wp_or rd rs rt Q ]}} cmd_or rd rs rt {{[ Q ]}}
| hoare0_sll : forall Q rx ry sa, {{[ wp_sll rx ry sa Q ]}} sll rx ry sa {{[ Q ]}}
| hoare0_sllv : forall Q rd rs rt, {{[ wp_sllv rd rs rt Q ]}} sllv rd rs rt {{[ Q ]}}
| hoare0_sltu : forall Q rd rs rt, {{[ wp_sltu rd rs rt Q ]}} sltu rd rs rt {{[ Q ]}}
| hoare0_sra : forall Q rd rt sa, {{[ wp_sra rd rt sa Q ]}} sra rd rt sa {{[ Q ]}}
| hoare0_srl : forall Q rd rt sa, {{[ wp_srl rd rt sa Q ]}} srl rd rt sa {{[ Q ]}}
| hoare0_srlv : forall Q rd rt rs, {{[ wp_srlv rd rt rs Q ]}} srlv rd rt rs {{[ Q ]}}
| hoare0_subu: forall Q rs rt rd , {{[ wp_subu rd rs rt Q ]}} subu rd rs rt {{[ Q ]}}
| hoare0_sw : forall rt off base Q, {{[ wp_sw rt off base Q ]}} sw rt off base {{[ Q ]}}
| hoare0_xor : forall Q rd rs rt, {{[ wp_xor rd rs rt Q ]}} xor rd rs rt {{[ Q ]}}
| hoare0_xori : forall Q rt rs imm, {{[ wp_xori rt rs imm Q ]}} xori rt rs imm {{[ Q ]}}
where "{{[ P ]}} c {{[ Q ]}}" := (hoare0 P c Q) : mips_hoare_scope.

(** Semantics for total correctness *)
Notation "'hoare_semantics_total'" := (@while.hoare_semantics_total store.t heap.t _ exec0 _
  (fun eb s => eval_b eb (fst s)))
  : mips_hoare_scope.

Lemma soundness0_total : forall (P Q : assert) c, {{[ P ]}} c {{[ Q ]}} ->
  hoare_semantics_total P c Q.
Proof.
move=> P Q c; elim => //; clear P Q c; rewrite /hoare_semantics_total.
- (* nop *) move=> P s h HP.
  exists s; exists h; split=> //.
  by do 2 constructor.
- (* add *) move=> P rt rs rd s h; rewrite /wp_add; case=> H1 H2.
  move: (exec0_add s h rd rt rs H1).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* addi *) move=> P rt rs imm s h; rewrite /wp_addi; case=> H1 H2.
  move: (exec0_addi s h rt rs imm H1).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* addiu *) move=> P rt rs imm s h; rewrite /wp_addiu; move=> H1.
  move: (exec0_addiu s h rt rs imm).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* addu *) move=> Q rs rt rd s h; rewrite /wp_addu; move=> H1.
  move: (exec0_addu s h rd rs rt).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* and *) move=> Q rd rs rt s h; rewrite /wp_and; move=> H1.
  move: (exec0_and s h rd rs rt).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* andi *) move=> Q rt rs imm s h; rewrite /wp_andi; move=> H1.
  move: (exec0_andi s h rt rs imm).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* lw *) move=> P rt off base s h; rewrite /wp_lw; case=> p [H1 [z [H2 H3]]].
  move: (exec0_lw s h rt off base p z H1 H2).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [ constructor; auto | auto] end.
- (* lwxs *) move=> rt idx base P s h; rewrite /wp_lwxs; case=> p [H1 [z [H2 H3]]].
  move: (exec0_lwxs s h rt idx base p z H1 H2).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [ constructor; auto | auto] end.
- (* maddu *) move=> Q rs rt s h H1.
  move: (exec0_maddu s h rs rt).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* mfhi *) move=> Q rd s h H1.
  move: (exec0_mfhi s h rd).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* mflhxu *) move=> rd P s h H1.
  move: (exec0_mflhxu s h rd).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* mflo *) move=> Q rd s h H1.
  move: (exec0_mflo s h rd).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* movn *) move=> Q rd rs rt s h H1.
  case: (MachineInt.dec_int [rt]_s zero32) => X.
  move: (exec0_movn_false s h rd rs rt X).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | apply H1 => //] end.
  move: (exec0_movn_true s h rd rs rt X).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | apply H1 => // ] end.
- (* movz *) move=> Q rd rs rt s h H1.
  case: (MachineInt.dec_int [rt]_s zero32) => X.
  move: (exec0_movz_true s h rd rs rt X).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | apply H1 => //] end.
  move: (exec0_movz_false s h rd rs rt X).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | apply H1 => // ] end.
- (* msubu *) move=> Q rs rt s h H1.
  move: (exec0_msubu s h rs rt).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* mthi *) move=> Q rs s h H1.
  move: (exec0_mthi s h rs).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* mtlo *) move=> Q rs s h H1.
  move: (exec0_mtlo s h rs).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* multu *) move=> Q rs rt s h H1.
  move: (exec0_multu s h rs rt).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* nor *) move=> Q rd rs rt s h; rewrite /wp_nor => H1.
  move: (exec0_nor s h rd rs rt).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* or *) move=> Q rd rs rt s h; rewrite /wp_or => H1.
  move: (exec0_or s h rd rs rt).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* sll *) move=> Q rx ry sa s h; rewrite /wp_sll; move=> H1.
  move: (exec0_sll s h rx ry sa).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* sllv *) move=> Q rd rs rt s h; rewrite /wp_sll; move=> H1.
  move: (exec0_sllv s h rd rs rt).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* sltu *) move=> Q rd rs rt s h; rewrite /wp_sltu; move=> H1.
  move: H1 (exec0_sltu s h rd rs rt).
  move X : (Zlt_bool (u2Z [rs]_s) (u2Z [rt]_s)) => t HQ Y.
  destruct t.
  + exists (store.upd rd one32 s), h.
    split => //; by apply while.exec_cmd0, Y.
  + exists (store.upd rd zero32 s), h.
    split => //; by apply while.exec_cmd0, Y.
- (* sra *) move=> Q rd rt sa s h; rewrite /wp_sra; move=> H1.
  move: (exec0_sra s h rd rt sa).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* srl *) move=> Q rd rt sa s h; rewrite /wp_srl; move=> H1.
  move: (exec0_srl s h rd rt sa).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* srlv *) move=> Q rd rt rs s h; rewrite /wp_srlv; move=> H1.
  move: (exec0_srlv s h rd rt rs).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* subu *) move=> Q rs rt rd s h; rewrite /wp_subu; move=> H1.
  move: (exec0_subu s h rd rs rt).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* sw *) move=> rt offset base P s h; rewrite /wp_sw; case=> l [H1 [z H2]].
  move: (exec0_sw s h rt offset base l H1) => X.
  exists s; exists (heap.upd l [rt]_s h); split=> //.
  by apply while.exec_cmd0, X.
- (* xor *) move=> Q rd rs rt s h; rewrite /wp_xor => H1.
  move: (exec0_xor s h rd rs rt).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
- (* xori *) move=> Q rt rs imm s h; rewrite /wp_xor => H1.
  move: (exec0_xori s h rt rs imm).
  match goal with | _ : _ |- _ -- _ ----> Some (?s', ?h') ->  _ => move=> Htmp;
  exists s', h'; split; [do 2 constructor; auto | auto ] end.
Qed.

(** Semantics for partial correctness *)
Notation "'hoare_semantics'" := (@while.hoare_semantics store.t heap.t _ exec0 _
  (fun eb s => eval_b eb (fst s))) : mips_hoare_scope.

(** Soundness for partial correctness *)
Lemma soundness0 : forall P Q c, {{[ P ]}} c {{[ Q ]}} -> hoare_semantics P c Q.
Proof.
move=> P Q c; move/soundness0_total.
rewrite /hoare_semantics_total => H s h HP; split=> [|s' h' exec_Some].
- case: (H s h HP) => // s' [h' [exec_Some HQ]] exec_None.
  move/semop_prop_m.exec_cmd0_inv : exec_Some => exec_Some.
  move/semop_prop_m.exec_cmd0_inv : exec_None => exec_None.
  (* TODO: shouldn't we call exec0_deter indirectly by the interface in while.v? *)
  by move: (mips_cmd.exec0_deter _ _ _ exec_Some _ exec_None).
- case: (H s h HP) => // s'_ [h'_ [exec_Some' HQ]].
  move/semop_prop_m.exec_cmd0_inv : exec_Some' => exec_Some'.
  move/semop_prop_m.exec_cmd0_inv : exec_Some => exec_Some.
  by case: (mips_cmd.exec0_deter _ _ _ exec_Some _ exec_Some')=> -> ->.
Qed.

(** * Completeness for Partial Correctness *)

Notation "'wp_semantics'" := (@while.wp_semantics store.t heap.t _ exec0 _
  (fun eb s => eval_b eb (fst s)))
  : mips_hoare_scope.

Notation "{{ P }} c {{ Q }}" := (@while.hoare store.t heap.t cmd0 _
  (fun eb s => eval_b eb (fst s)) hoare0 P c Q)
  (at level 82, no associativity) : mips_hoare_scope.

Lemma wp_semantics_sound0 : forall (c : cmd0) Q, {{ wp_semantics c Q }} c {{ Q }}.
Proof.
induction c => Q; match goal with |- {{ ?P }} ?c {{ ?Q }} => eapply while.hoare_conseq with (Q' := Q); [done | idtac | do 3 constructor] end.
- (* nop *) red; intros.
  inversion_clear H.
  apply H1.
  by do 2 constructor.
- (* add *) move=> s h H.
  rewrite /wp_add.
  rewrite /wp_semantics in H.
  case: H => [H1 H2].
  move/exec0_not_None_to_exec_not_None : H1.
  move/exec0_add_not_None => H1.
  split; first by exact H1.
  apply H2; by do 2 constructor.
- (* addi *) move=> s h H.
  rewrite /wp_addi.
  rewrite /wp_semantics in H.
  case: H => H1 H2.
  move/exec0_not_None_to_exec_not_None : H1.
  move/exec0_addi_not_None => H1.
  split; first by exact H1.
  apply H2; by do 2 constructor.
- (* addiu *) move=> s h.
  inversion_clear 1.
  rewrite /wp_addiu.
  apply H1; by do 2 constructor.
- (* addu *) move=> s h.
  inversion_clear 1.
  rewrite /wp_addu.
  apply H1; by do 2 constructor.
- (* cmd_and *) move=> s h.
  inversion_clear 1.
  rewrite /wp_and.
  apply H1; by do 2 constructor.
- (* andi *) move=> s h.
  inversion_clear 1.
  rewrite /wp_andi.
  apply H1; by do 2 constructor.
- (* lw *) move=> s h.
  inversion_clear 1.
  rewrite /wp_lw.
  move/exec0_not_None_to_exec_not_None : H0.
  case/exec0_lw_not_None => x [H [x0 H2]].
  exists x; split => //; exists x0; split => //.
  apply H1; constructor.
  by econstructor; eauto.
- (* lwxs *) move=> s h.
  inversion_clear 1.
  rewrite /wp_lwxs.
  move/exec0_not_None_to_exec_not_None : H0.
  case/exec0_lwxs_not_None => x [H [ x0 H2]].
  exists x; split => //; exists x0; split => //.
  apply H1; constructor.
  by econstructor; eauto.
- (* maddu *) move=> s h.
  inversion_clear 1.
  rewrite /wp_maddu.
  apply H1; by do 2 constructor.
- (* mfhi *) red; intros.
  inversion_clear H.
  red; intros.
  apply H1; by do 2 constructor.
- (* mflhxu *) move=> s h.
  inversion_clear 1.
  rewrite /wp_mflhxu.
  apply H1; by do 2 constructor.
- (* mflo *) move=> s h.
  inversion_clear 1.
  rewrite /wp_mflo.
  apply H1; by do 2 constructor.
- (* movn *) move=> s h.
  inversion_clear 1.
  rewrite /wp_movn.
  split => H2.
  apply H1; by do 2 constructor.
  apply H1; by do 2 constructor.
- (* movz *) red; intros.
  inversion_clear H.
  red; intros.
  split => H2.
  apply H1; by do 2 constructor.
  apply H1; by do 2 constructor.
- (* msubu *) red; intros.
  inversion_clear H.
  rewrite /wp_msubu.
  apply H1; by do 2 constructor.
- (* mtlhi *) red; intros.
  inversion_clear H.
  red; intros.
  apply H1; by do 2 constructor.
- (* mtlo *) red; intros.
  inversion_clear H.
  red; intros.
  apply H1; by do 2 constructor.
- (* multu *) red; intros.
  inversion_clear H.
  rewrite /wp_multu.
  apply H1; by do 2 constructor.
- (* nor *) red; intros.
  inversion_clear H.
  red; intros.
  apply H1; by do 2 constructor.
- (* cmd_or *) red; intros.
  inversion_clear H.
  red; intros.
  apply H1; by do 2 constructor.
- (* sll *) red; intros.
  inversion_clear H.
  red; intros.
  apply H1; by do 2 constructor.
- (* sllv *) red; intros.
  inversion_clear H.
  red; intros.
  apply H1; by do 2 constructor.
- (* sltu *) red; intros.
  inversion_clear H.
  red; intros.
  apply H1; by do 2 constructor.
- (* sra *) red; intros.
  inversion_clear H.
  red; intros.
  apply H1; by do 2 constructor.
- (* srl *) red; intros.
  inversion_clear H.
  red; intros.
  apply H1; by do 2 constructor.
- (* srlv *) red; intros.
  inversion_clear H.
  red; intros.
  apply H1; by do 2 constructor.
- (* subu *) red; intros.
  inversion_clear H.
  red; intros.
  apply H1; by do 2 constructor.
- (* sw *) red; intros.
  inversion_clear H.
  red; intros.
  move/exec0_not_None_to_exec_not_None : H0.
  case/exec0_sw_not_None => x [H [x0 H2]].
  exists x; split => //; split.
  exists x0 => //.
  apply H1.
  constructor.
  by econstructor; eauto.
- (* xor *) red; intros.
  inversion_clear H.
  red; intros.
  apply H1; by do 2 constructor.
- (* xori *) red; intros.
  inversion_clear H.
  rewrite /wp_xori.
  apply H1; by do 2 constructor.
Qed.

(** * Semantics of Separation Logic *)

Module WMIPS_Hoare <: while.WHILE_HOARE_DETER.

Include WMIPS_Semop.

Definition assert := store -> heap -> Prop.

Definition wp0 : cmd0 -> assert -> assert := wp0.
Definition wp0_no_err : forall s h c P,
  wp0 c P s h -> ~ (Some (s,h) -- c ----> None) := wp0_no_err.
Definition exec0_wp0 : forall s h (c : cmd0) s' h', Some (s, h) -- c ----> Some (s', h') ->
  forall P, wp0 c P s h <-> P s' h' := exec0_wp0.

Definition hoare0 : assert -> cmd0 -> assert -> Prop := hoare0.
Definition hoare : assert -> cmd -> assert -> Prop := @while.hoare store heap cmd0 _ eval_b hoare0.

Definition soundness0 : forall P Q c, hoare0 P c Q -> hoare_semantics P c Q := soundness0.

Definition wp_semantics_sound0 : forall (c : cmd0) P, {{ wp_semantics c P }} c {{ P }} :=
  wp_semantics_sound0.

Definition exec0_deter : forall (st : option state) (c : cmd0) (st' : option state),
  st -- c ----> st' ->
  forall st'', st -- c ----> st'' -> st' = st'' := exec0_deter.

End WMIPS_Hoare.

(*Local Close Scope temp_mips_hoare_scope.*)

(*Notation "'wp_semantics'" := (@while.wp_semantics store.t heap.t _ exec0 _
  (fun eb s => eval_b eb (fst s))) : mips_hoare_scope.*)

(*Notation "{{ P }} c {{ Q }}" := (@while.hoare store.t heap.t cmd0 _
  (fun eb s => eval_b eb (fst s)) hoare0 P c Q)
  (at level 82, no associativity) : mips_hoare_scope.*)

(*Notation "'hoare_semantics'" := (@while.hoare_semantics store.t heap.t _ exec0 _
  (fun eb s => eval_b eb (fst s))) : mips_hoare_scope.*)

Module hoare_prop_m := while.While_Hoare_Prop WMIPS_Hoare.

Lemma soundness : forall P Q c, {{ P }} c {{ Q }} -> hoare_semantics P c Q.
Proof. exact hoare_prop_m.soundness. Qed.

Lemma wp_semantics_sound: forall c Q, {{ wp_semantics c Q }} c {{ Q }}.
Proof. exact hoare_prop_m.wp_semantics_sound. Qed.

Lemma hoare_complete : forall P Q c, hoare_semantics P c Q -> {{ P }} c {{ Q }}.
Proof. exact hoare_prop_m.hoare_complete. Qed.

(** * Total Correctness and its Soundness *)

Notation "{{{ P }}} c {{{ Q }}}" := (@while.hoare_total store.t heap.t cmd0 _
  (fun eb s => eval_b eb (fst s)) hoare0 P c Q) (at level 82, no associativity) : mips_hoare_scope.

Lemma hoare_total_sound : forall P Q c, {{{ P }}} c {{{ Q }}} -> hoare_semantics_total P c Q.
Proof. move=> P Q c H. by apply (hoare_prop_m.hoare_total_sound' soundness0_total). Qed.

Lemma hoare_ifte_bang P Q t c d :
  {{ P ** !(eval_b t) }} c {{ Q }} ->
  {{ P ** !(fun s => ~~ eval_b t s) }} d {{ Q }} ->
  {{ P }} If t Then c Else d {{ Q }}.
Proof.
move=> H1 H2.
apply while.hoare_ifte.
- eapply hoare_prop_m.hoare_stren; last by apply H1.
  move=> s h /= H.
  exists h, heap.emp.
  split; first by apply heap.disjhe.
  split; first by rewrite heap.unionhe.
  rewrite /bang.
  tauto.
- eapply hoare_prop_m.hoare_stren; last by apply H2.
  move=> s h /= H.
  exists h, heap.emp.
  split; first by apply heap.disjhe.
  split; first by rewrite heap.unionhe.
  rewrite /bang.
  tauto.
Qed.


(*
  vim: filetype=coq
*)
(*
Copyright (C) 2016-2018 Philip H. Smith

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.
*)

Require Import Way.StaleAtoms.
Require Import Way.Tactics.

Require Import Way.Beta.
Require Import Way.Context.
Require Import Way.Conversion.
Require Import Way.Open.
Require Import Way.Preterm.
Require Import Way.Relation.
Require Import Way.Subtyping.

(* Typings are proofs that under a given context, a given term has the given type.

Since types are terms, this emerges as a ternary relation between a context and two terms.

An interesting twist appears in the definition of contexts.  A context is a list that that
identifies the types of free variables in a term.  Since types are terms, the types
appearing in the context must themselves be well-typed, and can have free variables.  This
circular dependency is accounted for with a pair of mutually recursive definitions (or
"judgements").

The first kind of judgement is the typing of terms.
*)
Inductive typing : context -> preterm -> preterm -> Set :=

(* The type of a sort is the next sort in the hierarchy. *)
| type :
  forall (c : context), well_formed c -> forall (n : nat),
  typing c (Preterm.type n) (Preterm.type (S n))

(* The type of a free variable is that which it is bound to in a well-formed context. *)
| free_variable :
  forall (c : context), well_formed c -> forall (a : atom) (T : preterm), has (a, T) c ->
  typing c (Preterm.free_variable a) T

(* The type of a product is a sort, shared with its domain and codomain after opening.

Since the codomain can depend on the domain, we only require it to type after opening it
with the domain (using a sufficiently fresh free variable.)
*)
| product :
  forall (l : list atom) (c : context) (n : nat) (T U : preterm),
  typing c T (Preterm.type n) ->
  (fresh (a : l), typing ((a, T) :: c) (open_free a U) (Preterm.type n)) ->
  typing c (Preterm.product T U) (Preterm.type n)

(* The type of an abstraction is a well-typed product.

The abstraction body must have the product codomain as its type, after each has been
opened with the product's domain type (using a sufficiently fresh free variable.)
*)
| abstraction :
  forall (l : list atom) (n : nat) (c : context) (T U : preterm),
  typing c (Preterm.product T U) (Preterm.type n) ->
  forall (t : preterm),
  (fresh (a : l), typing ((a, T) :: c) (open_free a t) (open_free a U)) ->
  typing c (Preterm.abstraction T t) (Preterm.product T U)

(* The type of an application is its abstraction's codomain type opened with the argument.

The abstraction must have a product as its type, and the argument must be well-typed.
The equation involving open is required to allow proof search to match the head.
*)
| application :
  forall (T U : preterm) (c : context) (u : preterm),
  typing c u (Preterm.product T U) ->
  forall (t : preterm), typing c t T ->
  forall (v : preterm), v = open 0 t U ->
  typing c (Preterm.application u t) v

| subtyping :
  forall (T : preterm) (n : nat) (U : preterm), Subtyping.subtyping T U ->
  forall (c : context) (t : preterm), typing c t T ->
  typing c U (Preterm.type n) ->
  typing c t U

(* The second kind of judgement is the well-formation of contexts. *)
with well_formed : context -> Set :=

(* Empty contexts are well-formed. *)
| empty : well_formed []

(* A context that types a term as a type can be extended by it with a fresh variable. *)
| extend :
  forall (n : nat) (c : context) (T : preterm), typing c T (Preterm.type n) ->
  fresh (a : (domain c)), well_formed ((a, T) :: c).

Hint Resolve type free_variable empty : way.

Hint Extern 7 (typing _ (Preterm.product _ _) (Preterm.type _)) =>
  let stale := stale_atoms in apply (Typing.product stale) : way.

(* TODO(phs): hint extern for abstraction application subtyping extend *)

Module Examples.

Import Aliases.

(* TODO(phs): Use the type checker once it exists *)
Example polymorphic_identity :
  typing []
    Preterm.Examples.polymorphic_identity
    (prod (type 0) (prod (bvar 0) (bvar 1))).
Proof.
  unfold Preterm.Examples.polymorphic_identity;
  apply (Typing.abstraction [] 1);
  [ apply (Typing.product []);
    [ infer
    | intros a Ha; unfold open_free;
      apply (Typing.subtyping (type 1) 2);
      [ infer
      | apply (Typing.product [a]);
        [ apply (Typing.subtyping (type 0) 2);
          infer from (Typing.extend 1)
        | intros b Hb; unfold open_free;
          apply (Typing.subtyping (type 0) 2);
          [ infer
          | apply Typing.free_variable;
            [ apply (Typing.extend 0);
              [ apply Typing.free_variable;
                infer from (Typing.extend 1)
              | infer
              ]
            | infer
            ]
          | apply Typing.type;
            apply (Typing.extend 0);
            [ apply Typing.free_variable;
              infer from (Typing.extend 1)
            | infer
            ]
          ]
        ]
      | infer from (Typing.extend 1)
      ]
    ]
  | intros a Ha; unfold open_free;
    apply (Typing.abstraction [a] 0);
    [ apply (Typing.product [a]);
      [ infer from (Typing.extend 1)
      | intros b Hb; unfold open_free;
        apply Typing.free_variable;
        [ apply (Typing.extend 0);
          [ apply Typing.free_variable;
            infer from (Typing.extend 1)
          | infer
          ]
        | infer
        ]
      ]
    | intros b Hb; unfold open_free;
      apply Typing.free_variable;
      [ apply (Typing.extend 0);
        [ apply Typing.free_variable;
          infer from (Typing.extend 1)
        | infer
        ]
      | infer
      ]
    ]
  ].
Defined.

(* TODO(phs): Demonstrate polymorphic identity application *)
(* You chose type 0 in the definition of the identity.  This is tricky without base types
or the polymorphism allowing us to elide universe indices.
Example apply_polymorphic_identity :
  typing []
    (app Preterm.Examples.polymorphic_identity (abs (type 0) (bvar 0)))
    (prod (type 0) (type 0))
*)

Example type_of_sort_is_next_sort : typing [] (type 3) (type 4).
Proof.
  infer.
Defined.

Example type_of_free_variable_is_in_context :
  forall (a : atom), typing [(a, (type 7))] (fvar a) (type 7).
Proof.
  infer from (Typing.extend 8).
Defined.

Example type_of_product_is_sort : typing [] (prod (type 1) (type 1)) (type 2).
Proof.
  infer from (Typing.extend 2).
Defined.

Example type_of_abstraction_is_product :
  typing [] (abs (type 3) (bvar 0)) (prod (type 3) (type 3)).
Proof.
  infer from
    (Typing.abstraction [] 4)
    (Typing.extend 4).
Defined.

Example type_of_application_is_product_codomain :
  typing [] (app (abs (type 1) (bvar 0)) (type 0)) (type 1).
Proof.
  infer from
    (Typing.application (type 1) (type 1))
    (Typing.abstraction [] 2)
    (Typing.extend 2).
Defined.

Example terms_of_subtype_are_terms_of_supertype :
  typing []
    (type 0)
    (app (abs (type 2) (bvar 0)) (type 1)).
Proof.
  apply (Typing.subtyping (type 1) 2);
  [ apply Subtyping.conversion;
    apply Equivalence.symmetry
  | | ];
  infer from
    (Typing.application (type 2) (type 2))
    (Typing.abstraction [] 3)
    (Typing.extend 3).
Defined.

Example empty_context_is_well_formed : well_formed [].
Proof.
  infer.
Defined.

Example context_extended_with_fresh_name_is_well_formed :
  forall (a b : atom), a <> b -> well_formed [(a, (type 0)); (b, (type 0))].
Proof.
  infer from (Typing.extend 1).
Defined.

End Examples.


Require Import EnvLibA.
Require Import PRelLibA.
Require Import IdModTypeA.

Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Export Coq.Arith.PeanoNat.
Require Import Coq.Arith.EqNat.

Module ModLEnv <: IdModType.

  Definition Id := string.

  Definition IdEqDec := string_dec.

  Instance IdEq2 : DEq Id :=
  {
  dEq := IdEqDec
  }.

  Definition IdEq := IdEq2.

  Definition W := list (Id * nat).

  Definition Loc_PI := valTyp_irrelevance.

  Definition BInit := @nil (Id * nat).

  Instance WP2 : PState W :=
  {
  loc_pi := Loc_PI;

  b_init := BInit
  }.

  Definition WP := WP2.

End ModLEnv.


Require Import Algebra.SetoidCat Algebra.SetoidCat.MaybeUtils Tactics Utils SetoidUtils Algebra.SetoidCat.NatUtils.
Require Import Coq.Structures.DecidableTypeEx List SetoidClass PeanoNat FMapWeakList Basics Coq.Arith.Compare_dec.

Definition ltMaybe a b :=
  caseMaybeS
    @ (ltS @ a)
    @ False
    @ b.

Instance ltMaybe_Proper : Proper (equiv ==> equiv ==> equiv) ltMaybe.
Proof.
  solve_properS ltMaybe.
Qed.

Definition ltMaybeS := injF2 ltMaybe _.


Add LoadPath "../metatheory".
Require Export PLC_init.
Require Export PLC_other.
Add LoadPath "../lib".
Require Export Rel.

(* Lemmas about canonize *)
Lemma can_renaming : forall e1 e2 x y,
  e1 ↓ = e2 →
  (subst_term (term_var_f y) x e1) ↓ = (subst_term (term_var_f y) x e2).
Proof.
assert (forall n e1, size_term e1 <= n → forall e2 (x y: termvar),
  can e1 e2 → can (subst_term (term_var_f y) x e1) (subst_term (term_var_f y) x e2)) as Th.
intro n; induction n; intros e1 Hsize e2 x y H.
size_term_absurd e1.
destruct H; simpl in *.
Case "var". destruct (x0 == x); subst; auto.
Case "abs". apply can_abs with (L := L `union` {{ x }}); intros.
  replace (term_var_f x0) with (subst_term (term_var_f y) x (term_var_f x0)) by auto with lngen.
  repeat rewrite <- subst_term_open_term_wrt_term; auto.
  apply IHn; auto; autorewrite with lngen; omega.
Case "app1". apply can_app1; try solve [apply IHn; auto; omega].
  intro; destruct e1; simpl; try congruence. destruct (t == x); congruence.
Case "app2".
  rewrite subst_term_open_term_wrt_term; auto.
  apply can_app2 with (L := L `union` {{x}}); intros.
  replace (term_var_f x0) with (subst_term (term_var_f y) x (term_var_f x0)) by auto with lngen.
  repeat rewrite <- subst_term_open_term_wrt_term; auto.
  apply IHn; auto; autorewrite with lngen; omega.
  apply IHn; auto; omega.

intros e1 e2 x y H; apply Th with (n := size_term e1); auto.
Qed.

Lemma can_deterministic : forall e e1 e2,
  e↓ = e1 → e↓ = e2 → e1 = e2.
Proof.
intros e e1 e2 H. generalize dependent e2. induction H; intros.
inversion H; reflexivity.
inversion H1; subst; f_equal; pick fresh x;
  apply open_term_wrt_term_inj with (x1 := x); auto.
inversion H2; subst.
  erewrite IHcan1; eauto; erewrite IHcan2; eauto.
  edestruct H; eauto.
inversion H2; subst.
  edestruct H5; eauto.
  f_equal; auto.
  pick fresh x; eauto using open_term_wrt_term_inj.
Qed.

Lemma can_total : forall e1, lc_term e1 → exists e2, e1↓ = e2.
Proof.
intros e1 Hlc; induction Hlc; eauto.
Case "abs". pick fresh x; destruct (H0 x) as [e2 H2].
  exists (term_abs (close_term_wrt_term x e2)).
  apply can_abs with (L := {{x}}); intros.
  rewrite <- (close_term_wrt_term_open_term_wrt_term e x); auto.
  repeat rewrite <- subst_term_spec.
  auto using can_renaming.
Case "app". destruct IHHlc1 as [e1' H1]. destruct IHHlc2 as [e2' H2].
destruct Hlc1; try solve [exists (term_app e1' e2'); apply can_app1; auto; congruence].
SCase "abs".
inversion H1; subst. exists (e' ^^ e2'). apply can_app2 with (L := L); auto.
Qed.

(*
Lemma can_fv : forall e1 e2, e1↓ = e2 → fv_term e2 [<=] fv_term e1.
Proof.
intros e1 e2 H; induction H; simpl; try fsetdec.
Case "app1".
  pick fresh x.
  assert (fv_term (e' ^ x) [<=]
    fv_term (e ^ x)) by auto.
  assert (fv_term (e ^ x) [<=]
    fv_term (term_var_f x) `union` fv_term e) by auto with lngen.
  assert (fv_term e' [<=] fv_term (e' ^ x))
    by auto with lngen.
  simpl in *; fsetdec.
Case "app2".
  assert (fv_term (e1' ^^ e2')
    [<=] union (fv_term e2') (fv_term e1')) by auto with lngen.
  intros y Hy. pick fresh x.
  assert (fv_term e1' [<=] fv_term (e1' ^ x)) as H3 by auto with lngen.
  assert (fv_term (e1 ^ x) [<=] fv_term (term_var_f x) `union` fv_term e1) as H4 by auto with lngen.
  assert (fv_term (e1' ^ x) [<=] fv_term (e1 ^ x)) as H5 by auto.
  assert (fv_term e1' [<=] fv_term (term_var_f x) `union` fv_term e1) as H6 by fsetdec; clear H3 H4 H5.
  assert (y `in` fv_term (term_var_f x) `union` fv_term e1 `union` fv_term e2) as H3 by fsetdec; clear H6.
  simpl in *; fsetdec.
Qed.
Hint Resolve can_fv.
*)

(* Lemmas about para_red *)
Lemma para_red_refl : forall e, lc_term e → e ⇒ e.
Proof.
intros e H. induction H; try solve [constructor; auto].
apply para_red_abs with (L := fv_term e); auto.
Qed.
Hint Resolve para_red_refl.

Lemma red0_para_red : forall e1 e2, red0 e1 e2 → e1 ⇒ e2.
Proof.
intros e1 e2 H. inversion H; subst.
apply para_red_app2 with (L := fv_term e0); eauto.
Qed.
Hint Resolve red0_para_red.

Lemma red1_para_red : forall e1 e2, e1 ⇝ e2 → e1 ⇒ e2.
Proof.
intros e1 e2 H. induction H; auto.
apply para_red_abs with (L := L); auto.
Qed.

Lemma para_red_subst : forall e1 e1' e2 e2' x,
  e1 ⇒ e1' → e2 ⇒ e2' →
  (subst_term e2 x e1) ⇒ (subst_term e2' x e1').
Proof.
intros e1 e1' e2 e2' x H.
assert (lc_term e1) as Hlc by eauto.
generalize dependent e1'.
generalize dependent e2.
generalize dependent e2'.
generalize dependent x.
induction Hlc; intros y f2' f2 e1' Htt' Huu'; inversion Htt'; subst; simpl.
destruct (x == y); auto.
apply para_red_abs with (L := L `union` singleton y); intros.
  assert (term_var_f x = subst_term f2 y (term_var_f x)) as H3. autorewrite with lngen; reflexivity.
  assert (term_var_f x = subst_term f2' y (term_var_f x)) as H4. autorewrite with lngen; reflexivity.
  rewrite H3 at 1; clear H3.
  rewrite H4 at 2; clear H4.
  repeat rewrite <- subst_term_open_term_wrt_term; eauto.
apply para_red_app1; auto.
rewrite subst_term_open_term_wrt_term; eauto.
  assert (para_red (subst_term f2 y (term_abs e0)) (subst_term f2' y (term_abs e1'0))) as Ht.
    apply IHHlc1; auto;
    apply para_red_abs with (L := L); auto.
  simpl in Ht; inversion Ht; subst; clear Ht.
  apply para_red_app2 with (L := L `union` L0 `union` {{y}}); auto.
Qed.

Lemma para_red_canonize : forall e1 e2 e1',
  e1 ⇒ e2 → e1 ↓ = e1' → e2 ⇒ e1'.
Proof.
intros e1 e2 e1' Hpara Hcan. generalize dependent e1'.
induction Hpara; intros v Hcan.
inversion Hcan; subst; constructor.
inversion Hcan; subst; apply para_red_abs with (L := L `union` L0); intros; auto.
inversion Hcan; subst.
  constructor; auto.
  inversion Hpara1; subst; pick fresh x; assert (para_red (term_abs e') (term_abs e1'0)) as H by eauto.
    inversion H; subst; apply para_red_app2 with (L := L1); intros; auto.
inversion Hcan; subst.
  absurdity with congruence.
  pick fresh x for (fv_term e1' `union` fv_term e1'0 `union` L `union` L0).
  rewrite <- (close_term_wrt_term_open_term_wrt_term e1' x); auto.
  rewrite <- (close_term_wrt_term_open_term_wrt_term e1'0 x); auto.
  repeat rewrite <- subst_term_spec.
  apply para_red_subst; auto.
Qed.

Lemma para_red_diamond : diamond (para_red⁻¹).
Proof.
intros e1 e2 [e [H1 H2]]. unfold transp in *|-.
destruct (can_total e) as [e' H']; eauto.
exists e'; unfold transp; split; eauto using para_red_canonize.
Qed.

Lemma para_red_plus_diamond : diamond (para_red⁻¹⁺).
Proof.
auto using diamond_plus, para_red_diamond.
Qed.

Lemma para_red_red_star : forall e1 e2, e1 ⇒ e2 → e1 ⇝⋆ e2.
Proof.
intros e1 e2 H.
assert (lc_term e1) as Hlc by eauto.
generalize dependent e2.
induction Hlc; intros e0 Hpara; inversion Hpara; subst; eauto.
apply rt_refl.
apply rt_trans with (y := term_app (term_abs e1') e2'); eauto.
apply rt_step; apply red1_empty; apply red0_beta; eauto.
Qed.

Lemma red_star_para_red_plus_equiv : forall t t',
  (lc_term t ∧ t ⇝⋆ t') ↔ t ⇒⁺ t'.
Proof.
intros t t'; split; intro H.
destruct H. induction H0.
  eauto using t_step, red1_para_red.
  eauto using t_step, para_red_refl.
  eauto using t_trans.
induction H; split; eauto.
  auto using para_red_red_star.
  intuition auto.
  intuition eauto using rt_trans.
Qed.

Theorem church_rosser : forall t t1 t2,
  lc_term t → t ⇝⋆ t1 → t ⇝⋆ t2 →
  exists t', t1 ⇝⋆ t' ∧ t2 ⇝⋆ t'.
Proof.
intros t t1 t2 Hlc H1 H2.
assert (t ⇒⁺ t1) as H3. rewrite <- red_star_para_red_plus_equiv; auto.
assert (t ⇒⁺ t2) as H4. rewrite <- red_star_para_red_plus_equiv; auto.
clear H1 H2.
edestruct (para_red_plus_diamond t1 t2) as [t' [H1' H2']].
exists t; split.
  rewrite (transp_plus_commute _ _ _); auto.
  unfold transp at 1; rewrite (transp_plus_commute _ _ _); auto.
unfold transp at 1 in H1'; rewrite (transp_plus_commute _ _ _) in H1'.
rewrite (transp_plus_commute _ _ _) in H2'.
unfold transp in *|-.
rewrite <- red_star_para_red_plus_equiv in *|-.
intuition eauto.
Qed.


(* It's for a person who thinks we shouldn't use
  the Coq automation process.
*)

Require Import Auxiliaries.
Require Import Nat List Bool Arith Omega.
Import ListNotations.

Require Import Coq.Structures.Equalities.

Parameter A: Type.

Module AType <: Typ with Definition t := A.
Definition t := A.
End AType.

Module NARemover := (NthInserterRemover AType).
Import NARemover.

Lemma nth_remove_overflow: forall n l,
  n >= length l <->
  nth_remove n l = l.
Proof.
  induction n; destruct l; intros; split; intros.
  - reflexivity. (* 1 *)
  - apply le_n. (* 2 *)
  - inversion H. (* 3 *)
  - apply not_lt. unfold not. intros. (* 4 *)
    apply f_equal with (f:=@length A) in H. simpl in H.
    induction (length l).
    + inversion H.
    + inversion H. apply IHn in H2.
      apply H2.
  - reflexivity. (* 5 *)
  - apply le_0_n. (* 6 *)
  - simpl in *. apply le_S_n in H. apply IHn in H. (* 7 *)
    rewrite H. reflexivity.
  - inversion H. apply IHn in H1. (* 8 *)
    apply f_equal with (B := list A) (f:=@tl A) in H. simpl in H.
    rewrite <- H in H1.
    apply le_n_S. apply H1.
Qed.

Lemma nth_remove_overflow2: forall n l,
  n >= length l <->
  nth_remove n l = l.
Proof.
  induction n; destruct l; intros; simpl in *; intuition.
  - easy.
  - apply f_equal with (B := nat) (f:=@length A) in H. simpl in H.
    intuition.
  - assert (e: n >= length l) by omega; apply (IHn _) in e; rewrite e.
    auto.
  - inversion H as [H']; rewrite H'; apply IHn in H'. omega.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e256m4294968273_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Theorem long_theorem :
  forall (a b c d e : nat),
    a = b ->
    b = c ->
    a < c ->
    e = S e ->
    c = d.


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

End FOFProblem.


(* Are recursively non-uniform params correctly treated? *)
Inductive list (A:nat -> Type) n := cons : A n -> list A (S n) -> list A n.
Inductive term n := app (l : list term n).
Definition term_list :=
  fix term_size n (t : term n) (acc : nat) {struct t} : nat :=
    match t with
    | app l =>
      (fix term_list_size n (l : list term n) (acc : nat) {struct l} : nat :=
      match l with
      | cons t q => term_list_size (S n) q (term_size n t acc)
      end) n l (S acc)
    end.


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 B C U : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (col_ O E O /\ (col_ O E B /\ (col_ O E C /\ (col_ O E O /\ (col_ O E U /\ col_ O U Eprime))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.