Require Import String.
Require Import Coq.Structures.Equalities.
Require Import Coq.MSets.MSetInterface.
Require Import Arith.
Require Import Setoid.
Require Import SystemF.
Require Import Coq.Program.Equality.
Require Import Disjointness.

Module MTyping
       (Import VarTyp : UsualDecidableTypeFull)
       (Import set : MSetInterface.S).

Module MDisjointness := MDisjointness(VarTyp)(set).
Export MDisjointness.

(* Well-formed types *)

Inductive WFTyp : context TyEnvSource -> PTyp -> Prop :=
  | WFInt : forall Gamma, WFEnv Gamma -> WFTyp Gamma PInt
  | WFFun : forall Gamma t1 t2, WFTyp Gamma t1 -> WFTyp Gamma t2 -> WFTyp Gamma (Fun t1 t2)
  | WFAnd : forall Gamma t1 t2, WFTyp Gamma t1 -> WFTyp Gamma t2 -> Ortho Gamma t1 t2 -> WFTyp Gamma (And t1 t2)
  | WFVar : forall Gamma x ty, List.In (x,TyDis ty) Gamma -> WFEnv Gamma -> WFTyp Gamma (PFVarT x)
  | WFForAll : forall L Gamma d t,
                 (forall x, not (In x L) -> WFTyp (extend x (TyDis d) Gamma) (open_typ_source t (PFVarT x))) ->
                 PType d ->
                 WFTyp Gamma (ForAll d t)
  | WFTop : forall Gamma, WFEnv Gamma -> WFTyp Gamma Top
  | WFRec : forall Gamma l t, WFTyp Gamma t -> WFTyp Gamma (Rec l t).

Hint Constructors WFTyp.

Inductive Dir := Inf | Chk.

(* bidirection type-system (algorithmic):

T |- e => t ~> E     (inference mode: infers the type of e producing target E) (use Inf)
T |- e <= t ~> E     (checking mode: checks the type of e producing target E) (use Chk)

Inspiration for the rules:

https://www.andres-loeh.de/LambdaPi/LambdaPi.pdf

 *)

Inductive has_type_source_alg : context TyEnvSource -> PExp -> Dir -> PTyp -> (SExp var) -> Prop :=
  (* Inference rules *)
  | ATyTop : forall Gamma, WFEnv Gamma -> has_type_source_alg Gamma PUnit Inf Top (STUnit _)
  | ATyVar : forall Gamma x ty, WFEnv Gamma -> List.In (x,TermV ty) Gamma -> WFTyp Gamma ty ->
                      has_type_source_alg Gamma (PFVar x) Inf ty (STFVar _ x)
  | ATyLit : forall Gamma x, WFEnv Gamma -> has_type_source_alg Gamma (PLit x) Inf PInt (STLit _ x)
  | ATyApp : forall Gamma A B t1 t2 E1 E2,
              has_type_source_alg Gamma t1 Inf (Fun A B) E1 ->
              has_type_source_alg Gamma t2 Chk A E2 ->
              has_type_source_alg Gamma (PApp t1 t2) Inf B (STApp _ E1 E2)
  | ATyMerge : forall Gamma A B t1 t2 E1 E2,
                has_type_source_alg Gamma t1 Inf A E1 ->
                has_type_source_alg Gamma t2 Inf B E2 ->
                Ortho Gamma A B ->
                has_type_source_alg Gamma (PMerge t1 t2) Inf (And A B) (STPair _ E1 E2)
  | ATyAnn : forall Gamma t1 A E, has_type_source_alg Gamma t1 Chk A E ->
                         has_type_source_alg Gamma (PAnn t1 A) Inf A E
  | ATyTApp : forall Gamma t A ty d E,
                WFTyp Gamma A ->
                has_type_source_alg Gamma t Inf (ForAll d ty) E ->
                Ortho Gamma A d ->
                has_type_source_alg Gamma (PTApp t A) Inf (open_typ_source ty A) (STTApp _ E (|A|))
  | ATyRec : forall Gamma l t A E,
               has_type_source_alg Gamma t Inf A E ->
               has_type_source_alg Gamma (PRec l t) Inf (Rec l A) E
  | ATyProjR : forall Gamma l t A E,
                 has_type_source_alg Gamma t Inf (Rec l A) E ->
                 has_type_source_alg Gamma (PProjR t l) Inf A E
  (* Checking rules: TODO move ATyTLam here*)
  | ATyLam : forall L Gamma t A B E,
               (forall x, not (In x L) ->
                     has_type_source_alg (extend x (TermV A) Gamma) (open_source t (PFVar x)) Chk B (open E (STFVar _ x))) ->
               WFTyp Gamma A ->
               has_type_source_alg Gamma (PLam t) Chk (Fun A B) (STLam _ E)
  | ATySub : forall Gamma t A B C E,
               has_type_source_alg Gamma t Inf A E ->
               sub A B C ->
               WFTyp Gamma B ->
               has_type_source_alg Gamma t Chk B (STApp _ C E)
  | ATyTLam : forall L Gamma t A d E,
               PType d ->
               (forall x, not (In x L) ->
                     has_type_source_alg (extend x (TyDis d) Gamma)
                                         (open_typ_term_source t (PFVarT x))
                                         Inf
                                         (open_typ_source A (PFVarT x))
                                         (open_typ_term E (STFVarT x))) ->
               has_type_source_alg Gamma (PTLam d t) Inf (ForAll d A) (STTLam _ E).

Hint Constructors has_type_source_alg.

(** Well-formedness of types **)

Lemma wf_gives_wfenv : forall Gamma ty, WFTyp Gamma ty -> WFEnv Gamma.
Proof.
  intros Gamma ty H; induction H; auto.
  pick_fresh x.
  assert (Ha : ~ In x L) by not_in_L x.
  apply H0 in Ha; now inversion Ha.
Qed.

Hint Resolve wf_gives_wfenv.

Lemma wf_weaken_source : forall G E F ty,
   WFTyp (E ++ G) ty ->
   WFEnv (E ++ F ++ G) ->
   WFTyp (E ++ F ++ G) ty.
Proof.
  intros.
  generalize dependent H0.
  remember (E ++ G) as H'.
  generalize dependent HeqH'.
  generalize dependent E.
  dependent induction H; intros; eauto.
  - subst; apply WFAnd.
    apply IHWFTyp1; auto.
    apply IHWFTyp2; auto.
    apply ortho_weaken; auto.
  (* Var *)
  - subst.
    apply WFVar with (ty := ty).
    apply in_app_or in H.
    inversion H.
    apply in_or_app; left; assumption.
    apply in_or_app; right; apply in_or_app; right; assumption.
    assumption.
  (* ForAll *)
  - apply_fresh WFForAll as x.
    intros.
    intros.
    unfold open in *; simpl in *.
    subst.
    unfold extend; simpl.
    rewrite app_comm_cons.
    apply H0.
    not_in_L x.
    unfold extend; simpl; reflexivity.
    rewrite <- app_comm_cons.
    apply WFPushV.
    auto.
    not_in_L x.
    not_in_L x.
    rewrite dom_union in H8.
    rewrite union_spec in H8.
    inversion H8; contradiction.
    auto.
Qed.

Lemma wf_strengthen_source : forall z U E F ty,
  not (In z (fv_ptyp ty)) ->
  WFTyp (E ++ ((z,U) :: nil) ++ F) ty ->
  WFTyp (E ++ F) ty.
Proof.
  intros.
  remember (E ++ ((z,U) :: nil) ++ F).

  generalize dependent Heql.
  generalize dependent E.

  induction H0; intros; auto.
  - apply WFInt.
    subst.
    now apply wfenv_remove in H0.
  - eapply WFFun.
    subst.
    apply IHWFTyp1; simpl in *; not_in_L z; reflexivity.
    subst.
    apply IHWFTyp2; simpl in *; not_in_L z; reflexivity.
  - eapply WFAnd.
    subst.
    apply IHWFTyp1; simpl in *; not_in_L z; reflexivity.
    subst.
    apply IHWFTyp2; simpl in *; not_in_L z; reflexivity.
    subst; eauto.
  - subst; eapply WFVar.
    apply in_or_app.
    repeat apply in_app_or in H0.
    inversion H0.
    left; apply H2.
    apply in_app_or in H2.
    inversion H2.
    inversion H3.
    inversion H4.
    subst.
    exfalso; apply H; simpl.
    left; reflexivity.
    inversion H4.
    auto.
    now apply wfenv_remove in H1.
  - subst.
    apply_fresh WFForAll as x.
    unfold extend in *; simpl in *; intros.
    rewrite app_comm_cons.
    eapply H1.
    not_in_L x.
    not_in_L z.
    apply fv_open_rec_typ_source in H.
    rewrite union_spec in H.
    inversion H.
    auto.
    assert (NeqXZ : not (In x (singleton z))) by (not_in_L x).
    simpl in H5.
    exfalso; apply NeqXZ.
    apply MSetProperties.Dec.F.singleton_2.
    apply MSetProperties.Dec.F.singleton_1 in H5.
    symmetry; assumption.
    rewrite app_comm_cons.
    reflexivity.
    auto.
  - apply WFTop.
    subst.
    now apply wfenv_remove in H0.
  - eapply WFRec; subst; apply IHWFTyp; simpl in *; not_in_L z; reflexivity.
Qed.

Lemma wf_env_comm_source : forall E F G H ty,
              WFTyp (E ++ F ++ G ++ H) ty ->
              WFTyp (E ++ G ++ F ++ H) ty.
Proof.
  intros.
  remember (E ++ F ++ G ++ H).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  generalize dependent G.
  dependent induction H0; intros; subst; auto.
  - apply WFInt.
    now apply wfenv_middle_comm.
  - apply WFAnd; auto.
    now apply ortho_middle_comm.
  - eapply WFVar.
    apply in_app_or in H0.
    inversion H0.
    apply in_or_app; left; apply H2.
    apply in_or_app; right.
    apply in_app_or in H2.
    inversion H2.
    apply in_or_app.
    right; apply in_or_app; left.
    assumption.
    apply in_app_or in H3.
    inversion H3.
    apply in_or_app; auto.
    apply in_or_app; right; apply in_or_app; auto.
    now apply wfenv_middle_comm.
  - apply_fresh WFForAll as x.
    unfold extend.
    intros.
    simpl.
    rewrite app_comm_cons.
    apply H1.
    not_in_L x.
    unfold extend; now simpl.
    auto.
  - apply WFTop.
    now apply wfenv_middle_comm in H0.
Qed.

Lemma wf_env_comm_extend_source : forall Gamma x y v1 v2 ty,
              WFTyp (extend x v1 (extend y v2 Gamma)) ty ->
              WFTyp (extend y v2 (extend x v1 Gamma)) ty.
Proof.
  unfold extend.
  intros.
  rewrite <- app_nil_l with (l := ((x, v1) :: nil) ++ ((y, v2) :: nil) ++ Gamma) in H.
  apply wf_env_comm_source in H.
  now rewrite app_nil_l in H.
Qed.

Lemma wf_weaken_extend_source_tydis : forall ty x v Gamma,
   WFTyp Gamma ty ->
   not (M.In x (union (dom Gamma) (fv_ptyp v))) ->
   WFTyp ((x,TyDis v) :: Gamma) ty.
Proof.
  intros.
  induction H; eauto.
  - apply WFInt.
    apply WFPushV; auto.
    not_in_L x.
    not_in_L x.
  - apply WFAnd; auto.
    rewrite <- app_nil_l with (l := ((x, TyDis v) :: Gamma)).
    change ((x, TyDis v) :: Gamma) with (((x, TyDis v) :: nil) ++ Gamma).
    apply ortho_weaken.
    now rewrite app_nil_l.
  - eapply WFVar.
    apply in_cons; apply H.
    apply WFPushV; auto.
    not_in_L x.
    not_in_L x.
  - apply_fresh WFForAll as x; cbn.
    unfold extend in H1.
    intros.
    apply wf_env_comm_extend_source.
    apply H1.
    not_in_L y.
    simpl; not_in_L x.
    apply MSetProperties.Dec.F.add_iff in H0.
    destruct H0.
    not_in_L y.
    not_in_L x.
    auto.
  - apply WFTop.
    apply WFPushV; auto.
    not_in_L x.
    not_in_L x.
Qed.

Lemma wf_weaken_extend_source_termv : forall ty x v Gamma,
   WFTyp Gamma ty ->
   not (M.In x (union (dom Gamma) (fv_ptyp v))) ->
   WFTyp ((x,TermV v) :: Gamma) ty.
Proof.
  intros.
  induction H; eauto.
  - apply WFInt.
    apply WFPushT; auto.
    not_in_L x.
  - apply WFAnd; auto.
    rewrite <- app_nil_l with (l := ((x, TermV v) :: Gamma)).
    change ((x, TermV v) :: Gamma) with (((x, TermV v) :: nil) ++ Gamma).
    apply ortho_weaken.
    now rewrite app_nil_l.
  - eapply WFVar.
    apply in_cons; apply H.
    apply WFPushT; auto.
    not_in_L x.
  - apply_fresh WFForAll as x; cbn.
    unfold extend in H1.
    intros.
    apply wf_env_comm_extend_source.
    apply H1.
    not_in_L y.
    simpl; not_in_L x.
    apply MSetProperties.Dec.F.add_iff in H0.
    destruct H0.
    not_in_L y.
    not_in_L x.
    auto.
  - apply WFTop.
    apply WFPushT; auto.
    not_in_L x.
Qed.

Lemma wf_gives_types_source : forall Gamma ty, WFTyp Gamma ty -> PType ty.
Proof.
  intros.
  induction H; auto.
  - apply_fresh PType_ForAll as x.
    auto.
    apply H0.
    not_in_L x.
Qed.

Hint Resolve wf_gives_types_source.

Lemma subst_source_wf_typ_not_in :
  forall Gamma z t u, WFEnv (subst_env Gamma z u) ->
             WFTyp Gamma u ->
             WFTyp Gamma t ->
             ~ In z (fv_ptyp t) ->
             WFTyp (subst_env Gamma z u) t.
Proof.
  intros Gamma z t u HWFEnv HWFu HWFt HNotIn.
  induction HWFt; auto.
  - simpl in HNotIn; apply WFFun; [ apply IHHWFt1 | apply IHHWFt2 ];
    auto; not_in_L z.
  - simpl in HNotIn; apply WFAnd.
    apply IHHWFt1; auto; not_in_L z.
    apply IHHWFt2; auto; not_in_L z.
    apply ortho_subst_not_in; eauto.
  - apply WFVar with (ty := subst_typ_source z u ty); auto.
    now apply in_persists_subst_env.
  - rewrite <- subst_typ_source_fresh with (x := z) (u := u) (t := d).
    apply_fresh WFForAll as x.
    apply H0.
    not_in_L x.
    simpl; apply WFPushV; auto.
    unfold not; intros HH; apply fv_subst_source in HH;
    rewrite union_spec in HH; destruct HH as [HH | HH]; not_in_L x.
    rewrite dom_subst_id; not_in_L x.
    apply wf_weaken_extend_source_tydis; auto.
    not_in_L x.
    unfold not; intros HH; apply fv_open_rec_typ_source in HH; simpl in *.
    rewrite union_spec in HH; destruct HH as [HH | HH].
    not_in_L z.
    not_in_L x.
    apply H9; apply MSetProperties.Dec.F.singleton_iff;
    apply MSetProperties.Dec.F.singleton_iff in HH; auto.
    rewrite subst_typ_source_fresh.
    auto.
    not_in_L z; simpl; rewrite union_spec; auto.
    not_in_L z; simpl; rewrite union_spec; auto.
  - simpl in HNotIn; apply WFRec; apply IHHWFt; auto; not_in_L z.
Qed.

Lemma subst_source_wf_typ :
  forall t z u Gamma d, not (In z (fv_ptyp u)) ->
               MapsTo Gamma z d ->
               WFEnv (subst_env Gamma z u) ->
               Ortho Gamma u d ->
               WFTyp Gamma u ->
               WFTyp Gamma t ->
               WFTyp (subst_env Gamma z u) (subst_typ_source z u t).
Proof.
  intros t z u Gamma d HNotIn HMapsTo HForAll HOrtho HWFu HWFt.
  induction HWFt; simpl; auto.
  - apply WFAnd; auto.
    eapply ortho_subst; eauto.
  - assert (Ha : sumbool (x = z) (not (x = z))) by apply VarTyp.eq_dec.
    destruct Ha as [Ha | Ha].
    + subst; rewrite EqFacts.eqb_refl; auto.
      apply subst_source_wf_typ_not_in; auto.
    + apply EqFacts.eqb_neq in Ha.
      rewrite Ha.
      apply WFVar with (ty := subst_typ_source z u ty); auto.
      apply in_persists_subst_env; auto.
  -
    apply_fresh WFForAll as x.
    simpl in H0.
    rewrite subst_typ_source_open_source_var.
    apply H0.
    not_in_L x.
    eapply MapsTo_extend; auto.
    not_in_L x.
    apply WFPushV; auto.
    unfold not; intros HH; apply fv_subst_source in HH;
    rewrite union_spec in HH; destruct HH as [HH | HH]; not_in_L x.
    rewrite dom_subst_id; not_in_L x.
    rewrite <- app_nil_l with (l := (extend x (TyDis d0) Gamma)).
    apply ortho_weaken.
    now simpl.
    apply wf_weaken_extend_source_tydis.
    auto.
    not_in_L x.
    not_in_L x.
    now apply wf_gives_types_source in HWFu.
    apply subst_source_lc; auto.
    now apply wf_gives_types_source in HWFu.
Qed.

Hint Resolve wf_gives_wfenv wf_weaken_source wf_gives_types_source.

Definition body_wf_typ t d Gamma :=
  exists L, forall x, not (In x L) ->
            WFTyp (extend x (TyDis d) Gamma) (open_typ_source t (PFVarT x)).

Lemma forall_to_body_wf_typ : forall d t1 Gamma,
  WFTyp Gamma (ForAll d t1) -> body_wf_typ t1 d Gamma.
Proof. intros. unfold body_wf_typ. inversion H; subst; eauto. Qed.

Lemma open_body_wf_type :
  forall t d u Gamma, body_wf_typ t d Gamma -> Ortho Gamma u d -> WFTyp Gamma u ->
             WFTyp Gamma (open_typ_source t u).
Proof.
  intros. destruct H. pick_fresh y.
  assert (Ha : not (In y x)) by not_in_L y.
  apply H in Ha; auto.
  rewrite <- app_nil_l with (l := Gamma).
  apply wf_strengthen_source with (z := y) (U := TyDis d).
  unfold not; intros HH.
  apply fv_open_rec_typ_source in HH.
  rewrite union_spec in HH.
  destruct HH; not_in_L y.
  rewrite subst_typ_source_intro with (x := y); eauto.
  change (nil ++ ((y, TyDis d) :: nil) ++ Gamma) with (nil ++ extend y (TyDis d) Gamma).
  assert (Ha1 : nil ++ (extend y (TyDis d) Gamma) =
                subst_env (nil ++ (extend y (TyDis d) Gamma)) y u).
  rewrite subst_env_codom_fresh. reflexivity.
  not_in_L y.
  simpl in H4; rewrite union_spec in H4; destruct H4; contradiction.
  rewrite Ha1.
  apply subst_source_wf_typ with (d := d); eauto.
  not_in_L y.
  unfold MapsTo; simpl; now rewrite EqFacts.eqb_refl.
  rewrite <- Ha1.
  now apply wf_gives_wfenv in Ha.
  apply ortho_weaken.
  auto.
  apply wf_weaken_extend_source_tydis; auto.
  not_in_L y.
  not_in_L y.
Qed.

Lemma WFTyp_to_WFType : forall Gamma ty, WFTyp Gamma ty -> WFType (∥ Gamma ∥) (| ty |).
Proof.
  intros Gamma ty H.
  induction H; simpl; auto.
  - apply wfenv_to_ok in H0.
    apply WFType_Var; auto.
    now apply in_persists in H.
  - apply_fresh WFType_ForAll as x.
    simpl in *.
    assert (Ha : not (In x L)) by (not_in_L x).
    apply H0 in Ha.
    unfold extend; simpl.
    unfold open_typ_source in Ha.
    now rewrite open_rec_typ_eq_source in Ha.
Qed.

Hint Resolve WFTyp_to_WFType.

End MTyping.


Definition sym (A:Type) (x y :A) (p:x=y) : y = x :=
	eq_ind x (fun y0 => y0=x) eq_refl y p.

Definition trans (A:Type) (x y z:A) (p1:x=y) (p2:y=z) : x = z :=
	eq_ind y (fun x0 => x=x0) p1 z p2.

Definition cong (A B:Type) (f:A->B) (x y:A) (p:x=y) : f x = f y :=
	eq_ind x (fun x0 => f x = f x0) eq_refl y p.

Definition P := Prop.
Definition T := Type.

Check (forall p:P, p ) : P.
Fail Check (forall p:T, p ) : T.


Require Import graph.
Require Import ZArith.
Set Implicit Arguments.

Require Import String.
Require Import schorr_waite.

(* may need new representation predicate storing also the address of the node? *)

Inductive tree :=
  | Node : Z -> tree -> tree -> tree
  | Leaf.
Inductive ltree :=
  | LNode : Z -> Z -> ltree -> ltree -> ltree
  | LLeaf.
Definition ltree_addr t :=
  match t with
    | LNode p _ _ _ => p
    | LLeaf => 0
  end.

Fixpoint rep_ltree (t : ltree) : MapPattern k k :=
  match t with
  | LLeaf => emptyP
  | LNode p v l r =>
      (constraint (p <> 0) :* p h|-> tree_node v (ltree_addr l) (ltree_addr r)
       :* rep_ltree l :* rep_ltree r)%pattern
  end.

Fixpoint isConst v t :=
  match t with
    | LLeaf => True
    | LNode _ n l r => n = v /\ isConst v l /\ isConst v r
  end.

Fixpoint mark m t :=
  match t with
    | LLeaf => LLeaf
    | LNode p _ l r => LNode p m (mark m l) (mark m r)
  end.

Inductive isWellMarkedPath : ltree -> Prop :=
  | path1 : forall p l r,
     isConst 0 l -> isWellMarkedPath r -> isWellMarkedPath (LNode p 1 l r)
  | path2 : forall p l r,
     isConst 3 r -> isWellMarkedPath l -> isWellMarkedPath (LNode p 2 l r)
  | path_leaf : isWellMarkedPath LLeaf
  .

Inductive isWellMarked' (q : ltree) : ltree -> Prop :=
  | marked0 : forall p l r, isConst 0 l -> isConst 0 r ->
       isWellMarkedPath q -> isWellMarked' q (LNode p 0 l r)
  | marked1 : forall p l r, isConst 3 q -> isConst 0 l ->
       isWellMarkedPath r -> isWellMarked' q (LNode p 1 l r)
  | marked2 : forall p l r, isConst 3 r -> isConst 3 q ->
       isWellMarkedPath l -> isWellMarked' q (LNode p 2 l r)
  | marked_leaf : isConst 3 q -> isWellMarked' q LLeaf
  .

Definition isWellMarked a t := isWellMarked' t a.

Fixpoint proj0 t :=
  match t with
    | LLeaf => Leaf
    | LNode p _ l r => Node p (proj0 l) (proj0 r)
  end.
Fixpoint mark3 t :=
  match t with
    | Leaf => LLeaf
    | Node p l r => LNode p 3 (mark3 l) (mark3 r)
  end.

Fixpoint restorePathPointers t q :=
  match q with
    | LNode p 1 l r => restorePathPointers (Node p t (proj0 l)) r
    | LNode p 2 l r => restorePathPointers (Node p (proj0 r) t) l
    | LNode _ _ _ _ => Leaf (* An error, I think *)
    | LLeaf => t
  end.

Fixpoint restorePointers p q :=
  match p with
  | LNode i 0 l r => restorePathPointers (Node i (proj0 l) (proj0 r)) q
  | LNode i 1 l r => restorePathPointers (Node i (proj0 q) (proj0 l)) r
  | LNode i 2 l r => restorePathPointers (Node i (proj0 r) (proj0 q)) l
  | LNode i 3 l r => restorePathPointers (Node i (proj0 l) (proj0 r)) q
  | LNode _ _ _ _ => Leaf (* shouldn't hit this *)
  | LLeaf => proj0 q
  end.

(* Overall claim:
   rule <k> $ => return; ...</k>
         <heap>... swtree(root)(T) => swtree(root)(?T) ...</heap>
    if isConst(0, marks(T)) /\ isConst(3, marks(?T))
       /\ pointers(T) = pointers(?T) *)
(* Loop invariant:
   inv <heap>... swtree(p)(?TP), swtree(q)(?TQ) ...</heap>
          /\ isWellMarked(?TP, ?TQ)
          /\ pointers(T) = restorePointers(?TP, ?TQ) *)

Inductive schorr_waite_spec : Spec kcfg :=
  schorr_waite_claim : forall c,
  kcell c = kra schorr_waite_code kdot ->
  forall t, store c ~= "root" s|-> KInt (ltree_addr t) ->
  forall hframe, heap c |= rep_ltree t :* hframe ->
    isConst 0 t ->
  schorr_waite_spec c (fun c' => exists rest,
          kcell c' = kra SReturnVoid rest
          /\ stk_equiv (stack c) (stack c')
          /\ functions c ~= functions c'
          /\ heap c' |= rep_ltree (mark 3 t) :* hframe)
| schorr_waite_loop_claim :
  forall c rest, kcell c = kra schorr_waite_loop rest ->
  forall r t p q, store c ~= "root" s|-> r :* "t" s|-> t
                  :* "p" s|-> KInt (ltree_addr p) :* "q" s|-> KInt (ltree_addr q) ->
  isWellMarked p q ->
  forall hframe, heap c |= rep_ltree p :* rep_ltree q :* hframe ->
  schorr_waite_spec c (fun c' =>
          kcell c' = rest
          /\ stk_equiv (stack c) (stack c')
          /\ functions c ~= functions c'
          /\ heap c' |= rep_ltree (mark3 (restorePointers p q)) :* hframe).

Lemma schorr_waite_proof : sound kstep schorr_waite_spec.
start_proving;(eapply sstep;[step_solver|]).

* (* Overall goal *)

graph_run.

+ (* Early exit at zero tree *)
destruct t; simpl in * |- *;simplify_pat_hyps.
exfalso.
  exfalso; tauto.
  clear e.
 apply ddone. done_solver.

+ (* With nonzero value, have nonempty tree *)
eapply dtrans.
trans_solver.
instantiate (1:=LLeaf).
equate_maps.
(* bash on the isWellMarked precondition *)
  destruct t. simpl in * |- *. intuition. subst.
  constructor. assumption. assumption. constructor.
  constructor. simpl. constructor.
pat_solver.

simpl. intros. repeat use_graph_cfg_assumptions; simpl in * |- *.

eapply dstep. step_solver.
eapply ddone. done_solver.

match goal with
  [H : context [mark3 (restorePointers t LLeaf)] |- _] =>
  replace (mark3 (restorePointers t LLeaf)) with (mark3 (proj0 t)) in H;
  [replace (mark3 (proj0 t)) with (mark 3 t) in H|]
end.

assumption.

clear. induction t;simpl;congruence.

revert H2. clear.
induction t;simpl;intuition;subst;simpl;congruence.

* (* Loop goal *)

graph_run.

+ (* exits loop *)
destruct p;simpl in *|-*;simplify_pat_hyps;subst.
congruence.
clear e.
inversion_clear H1.

apply ddone;done_solver.
Lemma mark_id : forall t, isConst 3 t -> mark3 (proj0 t) = t.
induction t;simpl;intuition;congruence.
Qed.
rewrite mark_id by assumption.
break_join;[eassumption|eassumption|equate_maps].

+
(* progress into loop, needs help seeing that p
  is not a non-leaf tree so load can succeed *)

destruct p;simpl in n;[|congruence].
simpl in *|-*;simplify_pat_hyps.

graph_run.

- (* in true case because mark reached 3 *)
assert (z0 = 2) by auto with zarith.
subst z0; clear e.
inversion_clear H1.

simpl Zplus.
eapply dtrans. trans_solver.
equate_maps. instantiate (1:=(LNode z 3 p2 q)). equate_maps.

Lemma well_marked_from_path : forall p q,
  isWellMarkedPath p -> isConst 3 q -> isWellMarked p q.                             intros.
inversion_clear H;constructor;try assumption.
Qed.
apply well_marked_from_path;simpl;tauto.

pat_solver.

(* Now need to finish up after passing things ... *)
simpl.

intros. apply ddone.
progress decompose record H1;clear H1.
repeat split;try assumption.

match goal with
[H : context [(restorePointers p1 (LNode z 3 p2 q))] |- _] =>
replace (restorePointers p1 (LNode z 3 p2 q))
   with (restorePathPointers (Node z (proj0 p2) (proj0 q)) p1)
     in H
end.
assumption.

clear -H6 H7 H8.
destruct p1;[|simpl;auto].
inversion_clear H8;reflexivity.

- (* In false case because left subtree was leaf *)

destruct p1;
[exfalso;simpl in H4;simplify_pat_hyps;simpl in e;tauto
|].
simpl in * |- *. clear e. progress simplify_pat_hyps.

eapply dtrans.
eapply schorr_waite_loop_claim with (q:=LLeaf);simpl.
reflexivity.
equate_maps. instantiate (1:=r). instantiate (1:=LNode z (z0+1) p2 q).
equate_maps.

unfold isWellMarked.
inversion H1;subst.
unfold isWellMarked in H1.
constructor;trivial.
constructor;trivial.
destruct n0;reflexivity.

simpl. pat_solver.

(* Now we need to use the transitivity result *)
simpl.

intros.
apply ddone.
progress decompose record H6;clear H6.
done_solver.

inversion H1;subst;simpl in H12;assumption.

- { (* Counter not 3, left not null.
       Need to help it realize the tree exists so we
       can load the subtree mark *)

destruct p1;[|destruct n1;reflexivity].
simpl in * |- *.
simplify_pat_hyps.

graph_run.
(* In true branch because left subtree exists and has key zero *)

- eapply dtrans.
  eapply schorr_waite_loop_claim;simpl.

reflexivity.

equate_maps.
instantiate (1:=LNode z1 z2 p1_1 p1_2).
instantiate (1:=LNode z (z0+1) p2 q).
equate_maps.

unfold isWellMarked. inversion H1;subst;simpl in *|-*.
decompose record H11. constructor;try assumption;constructor;assumption.
decompose record H13. constructor;try assumption;constructor;assumption.
destruct n0;reflexivity.

pat_solver.

(* Now use result *)
simpl in * |- *. intros. apply ddone.
progress decompose record H8;clear H8.
done_solver.

inversion H1;subst;simpl in H14.
assumption.
assumption.
destruct n0;reflexivity.

- (* Last case - false branch of if because left child mark not 0,
     even though root still 3 *)

(* Um, shouldn't this be impossible on a tree? *)
exfalso.

inversion H1;subst;simpl in *|-*.
decompose record H11. congruence.
decompose record H13. congruence.
congruence.
}

Qed.


Module MarkedAsTypeclass.

  Class Map(K V map: Type) := {
    empty: map;
    get: map -> K -> option V;
    put: map -> K -> V -> map;
  }.

  Inductive GoodMap{K M: Type}{MI: Map K nat M}: M -> Prop :=
  | GMEmpty: GoodMap empty
  | GMAddSmall: forall k n m,
      n < 10 ->
      GoodMap m ->
    GoodMap (put m k n)
  | GMDouble: forall k n m,
      get m k = Some n ->
      GoodMap m ->
      GoodMap (put m k n).

End MarkedAsTypeclass.

Module NotMarkedAsTypeclass.

  Inductive MapFunctions(K V map: Type): Type :=
  | Build_MapFunctions(empty: map)
                      (get: map -> K -> option V)
                      (put: map -> K -> V -> map).

  Definition empty{K V map}(mf: MapFunctions K V map): map :=
    match mf with
    | Build_MapFunctions _ _ _ res _ _ => res
    end.

  Definition get{K V map}(mf: MapFunctions K V map): map -> K -> option V :=
    match mf with
    | Build_MapFunctions _ _ _ _ res _ => res
    end.

  Definition put{K V map}(mf: MapFunctions K V map): map -> K -> V -> map :=
    match mf with
    | Build_MapFunctions _ _ _ _ _ res => res
    end.

  Inductive GoodMap{K M: Type}{mf: MapFunctions K nat M}: M -> Prop :=
  | GMEmpty: GoodMap (empty mf)
  | GMAddSmall: forall k n m,
      n < 10 ->
      GoodMap m ->
    GoodMap (put mf m k n)
  | GMDouble: forall k n m,
      get mf m k = Some n ->
      GoodMap m ->
      GoodMap (put mf m k n).

End NotMarkedAsTypeclass.


(* This file tests:
    forward_for_simple_bound on 64-bit long integers,
    forward load with 64-bit integer array subscript, and
    forward store with 64-bit integer array subscript.
*)

Require Import VST.floyd.proofauto.
Require Import VST.progs.min64.
#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Require Import ZArith.
Require Import List.
Import ListNotations.
Open Scope Z.

Theorem fold_min_general:
  forall (al: list Z)(i: Z),
  In i (al) ->
  forall x, List.fold_right Z.min x al <= i.
Proof.
induction al; intros.
inversion H.
destruct H.
subst a.
simpl.
apply Z.le_min_l.
simpl. rewrite Z.le_min_r.
apply IHal.
apply H.
Qed.

Theorem fold_min:
  forall (al: list Z)(i: Z),
  In i (al) ->
  List.fold_right Z.min (hd 0 al) al <= i.
Proof.
intros.
apply fold_min_general.
apply H.
Qed.

Lemma Forall_fold_min:
  forall (f: Z -> Prop) (x: Z) (al: list Z),
    f x -> Forall f al -> f (fold_right Z.min x al).
Proof.
 intros.
 induction H0.
 simpl. auto.
 simpl.
 unfold Z.min at 1.
 destruct (Z.compare x0 (fold_right Z.min x l)) eqn:?; auto.
Qed.

Lemma fold_min_another:
  forall x al y,
    fold_right Z.min x (al ++ [y]) = Z.min (fold_right Z.min x al) y.
Proof.
 intros.
 revert x; induction al; simpl; intros.
 apply Z.min_comm.
 rewrite <- Z.min_assoc. f_equal.
 apply IHal.
Qed.

Lemma is_int_I32_Znth_map_Vint:
 forall i s al,
  0 <= i < Zlength al ->
  is_int I32 s (Znth i (map Vint al)).
Proof.
intros. rewrite Znth_map; auto.
Qed.
#[export] Hint Extern 3 (is_int I32 _ (Znth _ (map Vint _))) =>
  (apply  is_int_I32_Znth_map_Vint; rewrite ?Zlength_map; lia) : core.

Definition minimum_spec :=
 DECLARE _minimum
  WITH a: val, n: Z, al: list Z
  PRE [ tptr tint , tlong ]
    PROP  (1 <= n <= Int64.max_signed; Forall repable_signed al)
    PARAMS (a; Vlong (Int64.repr n))
    SEP   (data_at Ews (tarray tint n) (map Vint (map Int.repr al)) a)
  POST [ tint ]
    PROP ()
    RETURN (Vint (Int.repr (fold_right Z.min (hd 0 al) al)))
    SEP   (data_at Ews (tarray tint n) (map Vint (map Int.repr al)) a).

Definition Gprog : funspecs :=
      ltac:(with_library prog [minimum_spec]).

(* First approach from "Modular Verification for Computer Security",
  proved using forward_for_simple_bound *)

Lemma body_min: semax_body Vprog Gprog f_minimum minimum_spec.
Proof.
start_function.
assert_PROP (Zlength al = n) by (entailer!; list_solve).
forward.  (* min = a[0]; *)
forward_for_simple_bound n
  (EX i:Z,
    PROP()
    LOCAL(temp _min (Vint (Int.repr (fold_right Z.min (Znth 0 al) (sublist 0 i al))));
          temp _a a;
          temp _n (Vlong (Int64.repr n)))
    SEP(data_at Ews (tarray tint n) (map Vint (map Int.repr al)) a)).
* (* Prove that the precondition implies the loop invariant *)
  entailer!!.
* (* Prove that the loop body preserves the loop invariant *)
 forward. (* j = a[i]; *)
 forward. (* a[i] = j; *)
 assert (repable_signed (Znth i al))
     by (apply Forall_Znth; auto; lia).
 assert (repable_signed (fold_right Z.min (Znth 0 al) (sublist 0 i al)))
   by (apply Forall_fold_min;
          [apply Forall_Znth; auto; lia
          |apply Forall_sublist; auto]).
 autorewrite with sublist.
 subst POSTCONDITION; unfold abbreviate.
 rewrite (sublist_split 0 i (i+1)) by lia.
 rewrite (sublist_one i (i+1) al) by lia.
 rewrite fold_min_another.
 replace  (upd_Znth i (map Vint (map Int.repr al)) (Vint (Int.repr (Znth i al))))
  with (map Vint (map Int.repr al))
  by list_solve.
 forward_if.
 +
 forward. (* min = j; *)
 entailer!.
 rewrite Z.min_r; auto; lia.
 +
 forward. (* skip; *)
 entailer!.
 rewrite Z.min_l; auto; lia.
* (* After the loop *)
 forward. (* return *)
 entailer!!.
 autorewrite with sublist.
 destruct al; simpl; auto.
Qed.


(*===========================================================================
    Macro for multiplication by a constant
  ===========================================================================*)
Require Import ssreflect ssrbool ssrnat eqtype seq fintype.
Require Import procstate procstatemonad bitsrep bitsops bitsprops bitsopsprops.
Require Import SPred septac spec spectac safe basic basicprog program.
Require Import instr instrsyntax instrcodec instrrules reader pointsto cursor basic macros.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* Generate a sequence that computes r1 + r2*m with result in r1 and r2 trashed *)
Open Scope instr_scope.
(*=add_mulc *)
Fixpoint add_mulc nbits (r1 r2: Reg) (m: nat) :=
  if nbits is nbits'.+1
  then if odd m
       then ADD r1, r2;; SHL r2, 1;; add_mulc nbits' r1 r2 m./2
       else SHL r2, 1;;              add_mulc nbits' r1 r2 m./2
  else prog_skip.
(*=End *)

(*=add_mulcCorrect *)
Lemma add_mulcCorrect nbits : forall (r1 r2: Reg) m, m < 2^nbits ->
  |-- Forall v, Forall w,
      basic
      (r1 ~= v ** r2 ~= w ** OSZCP?)
      (add_mulc nbits r1 r2 m)
      (r1 ~= addB v (mulB w (fromNat m)) ** r2? ** OSZCP?).
(*=End *)
Proof.
  induction nbits => r1 r2 m LT; rewrite /add_mulc; fold add_mulc; specintros => v w.

  (* nbits = 0 *)
  destruct m => //. autorewrite with bitsHints push_at.
  apply: basic_roc_post; last apply basic_skip.
  rewrite /stateIsAny. sbazooka.

  (* nbits != 0 *)
  have H: m./2 < 2 ^nbits.
  rewrite expnS mul2n in LT.
  rewrite -(odd_double_half m) in LT.
  rewrite -ltn_double.
  apply (ltn_addl (odd m)) in LT.
  by rewrite -(ltn_add2l (odd m)).

  autorewrite with push_at.

  case ODD: (odd m).

(* lsb is 1 *)
  (* ADD r1, r2 *)
  basicapply ADD_RR_ruleNoFlags.
  basicapply SHL_RI_rule => //.
  try_basicapply IHnbits => //.

  rewrite /iter -addBA shlB_asMul -mulB_muln mul2n.
  rewrite -{2}(odd_double_half m).
  by rewrite ODD mulB_addn mulB1.

  basicapply SHL_RI_rule => //.
  try_basicapply IHnbits => //.

  by rewrite /iter shlB_asMul -mulB_muln mul2n -{2}(odd_double_half m) ODD add0n.
Qed.

(* More efficient version that does multi-bit shifts *)
Fixpoint add_mulcAux nbits (c:nat) (r1 r2: Reg) (m: nat) : program :=
  (if nbits is nbits'.+1
  then if odd m
       then
         if c == 0
         then ADD r1, r2;; add_mulcAux nbits' 1 r1 r2 m./2
         else SHL r2, c;; ADD r1, r2;; add_mulcAux nbits' 1 r1 r2 m./2
       else add_mulcAux nbits' c.+1 r1 r2 m./2
  else prog_skip)%asm.

Lemma add_mulcAuxCorrect nbits : forall (c:nat) (r1 r2: Reg) (m:nat),
  c+nbits <= 32 ->
  m < 2^nbits ->
  |-- Forall v, Forall w,
  basic
  (r1 ~= v ** r2 ~= w)
  (add_mulcAux nbits c r1 r2 m)
  (r1 ~= addB v (w *# (m*2^c)) ** r2?) @ OSZCP?.
Proof.
  induction nbits => c r1 r2 m LT1 LT3;
  rewrite /add_mulcAux; fold add_mulcAux; specintros => v w.

  (* nbits = 0 *)
  destruct m => //. autorewrite with bitsHints push_at.
  apply: basic_roc_post; last apply basic_skip.
  rewrite /stateIsAny. sbazooka.

  (* nbits != 0 *)
  have H: m./2 < 2 ^nbits.
  rewrite expnS mul2n in LT3.
  rewrite -(odd_double_half m) in LT3.
  rewrite -ltn_double.
  apply (ltn_addl (odd m)) in LT3.
  by rewrite -(ltn_add2l (odd m)).

  autorewrite with push_at.

  case ODD: (odd m).

(* lsb is 1 *)

  case ZERO: (c == 0).
  (* c is 0 *)

  (* ADD r1, r2 *)
  basicapply ADD_RR_ruleNoFlags.

  basicapply IHnbits => //.
  rewrite (eqP ZERO).  rewrite expn0 muln1 expn1.
  rewrite muln2. rewrite -{2}(odd_double_half m) ODD.  rewrite mulB_addn mulB1. rewrite -> addBA.
  sbazooka.

  rewrite (eqP ZERO) add0n in LT1. by rewrite add1n.

  (* c is not 0 *)

  (* SHL r2, c *)
  basicapply SHL_RI_rule => //.

  (* ADD r1, r2 *)
  basicapply ADD_RR_ruleNoFlags.

  basicapply IHnbits => //.

  rewrite expn1 -{2}(odd_double_half m) ODD. rewrite muln2. rewrite -addBA.
  rewrite mulnDl mul1n. rewrite mulB_addn. rewrite mulnC.
  rewrite shlB_mul2exp mulB_muln. sbazooka.

  rewrite add1n. rewrite -addn1 addnA addn1 addnC in LT1.
  apply (ltn_addr c) in LT1. by rewrite -(ltn_add2r c).

  rewrite -(addn1) addnA addn1 in LT1.
  apply (ltn_addr nbits) in LT1. by rewrite -(ltn_add2r nbits).

(* lsb is 0 *)

  basicapply IHnbits => //.
  rewrite expnS.
  rewrite -{2}(odd_double_half m) ODD add0n.
  rewrite mulnA. rewrite muln2.
  sbazooka.
  by rewrite -(addn1 c) -addnA add1n.
Qed.

(* Now a peephole optimization, using LEA for special cases *)
Definition add_mulcOpt (r1 r2: NonSPReg) (m:nat) : program :=
  (if m == 2
  then LEA r1, [r1 + r2*2]
  else
  if m == 4
  then LEA r1, [r1 + r2*4]
  else
  if m == 8
  then LEA r1, [r1 + r2*8]
  else add_mulcAux 32 0 r1 r2 m)%asm.

Lemma add_mulcOptCorrect (r1 r2: NonSPReg) (m:nat):
  m < 2^32 ->
  |-- Forall v, Forall w,
  basic
  (r1 ~= v ** r2 ~= w)
  (add_mulcOpt r1 r2 m)
  (r1 ~= addB v (w *# m) ** r2?) @ OSZCP?.
Proof.
rewrite /add_mulcOpt.
move => LT. specintros => v w.
autorewrite with push_at.

case EQ2: (m == 2).

basicapply LEA_ruleSameBase => //.
rewrite /eval.scaleBy shlB_asMul. rewrite -> addB0. rewrite /stateIsAny (eqP EQ2).
sbazooka.

case EQ4: (m == 4).

basicapply LEA_ruleSameBase => //.
rewrite /eval.scaleBy !shlB_asMul. rewrite -> addB0. rewrite /stateIsAny (eqP EQ4) -mulB_muln.
replace (2*2) with 4 by done. sbazooka.

case EQ8: (m == 8).
basicapply LEA_ruleSameBase => //.
rewrite /eval.scaleBy !shlB_asMul. rewrite -> addB0. rewrite /stateIsAny (eqP EQ8) -!mulB_muln.
replace (2*_) with 8 by done. sbazooka.

try_basicapply add_mulcAuxCorrect => //.
by rewrite expn0 muln1.
Qed.

(* More efficient version that does multi-bit shifts.
   Also with clever use of LEA where possible, iterated *)
(*=add_mulcFast *)
Fixpoint gen nb (c:nat) (r1:Reg) (r2: NonSPReg) m :=
  if nb is nb'.+1
  then if odd m then
    match c with
    | 0 => ADD r1, r2;;             gen nb' 1 r1 r2 m./2
    | 1 => LEA r1, [r1 + r2*2];;    gen nb' 2 r1 r2 m./2
    | 2 => LEA r1, [r1 + r2*4];;    gen nb' 3 r1 r2 m./2
    | 3 => LEA r1, [r1 + r2*8];;    gen nb' 4 r1 r2 m./2
    | _ => SHL r2, c;; ADD r1, r2;; gen nb' 1 r1 r2 m./2
    end else                        gen nb' c.+1 r1 r2 m./2
  else prog_skip.
Definition add_mulcFast (r1:Reg) (r2: NonSPReg) (d:DWORD) :=
  gen 32 0 r1 r2 (toNat d).
(*=End *)

Lemma genCorrect nbits : forall (c:nat) (r1:Reg) (r2:NonSPReg) (m:nat),
  c+nbits <= 32 ->
  m < 2^nbits ->
  |-- Forall v, Forall w,
  basic
  (r1 ~= v ** r2 ~= w)
  (gen nbits c r1 r2 m)
  (r1 ~= addB v (w *# (m*2^c)) ** r2?) @ OSZCP?.
Proof.
  induction nbits => c r1 r2 m LT1 LT3;
  rewrite /gen; fold gen; specintros => v w.
  autorewrite with push_at.

  (* nbits = 0 *)
  destruct m => //. autorewrite with bitsHints.
  apply: basic_roc_post; last apply basic_skip.
  rewrite /stateIsAny. sbazooka.

  (* nbits != 0 *)
  have H: m./2 < 2 ^nbits.
  rewrite expnS mul2n in LT3.
  rewrite -(odd_double_half m) in LT3.
  rewrite -ltn_double.
  apply (ltn_addl (odd m)) in LT3.
  by rewrite -(ltn_add2l (odd m)).

  autorewrite with push_at.

  case ODD: (odd m).

(* lsb is 1 *)

  destruct c.
  (* c is 0 *)

  (* ADD r1, r2 *)

  basicapply ADD_RR_ruleNoFlags.

  try_basicapply IHnbits => //.
  rewrite expn0 muln1 expn1.
  rewrite muln2. rewrite -{2}(odd_double_half m) ODD. by rewrite mulB_addn mulB1; rewrite -> addBA.

  destruct c.

  (* c is 1 *)
  basicapply LEA_ruleSameBase.
  rewrite -> addB0. rewrite /eval.scaleBy shlB_asMul.

  try_basicapply IHnbits => //.
  rewrite expn1 -{2}(odd_double_half m) ODD. rewrite muln2. rewrite -addBA.
  replace (2^2) with (2*2) by done. rewrite mulnA. rewrite -mulB_addn. rewrite !muln2.
  rewrite -(odd_double_half m). by rewrite ODD mulB_addn.

  destruct c.

  (* c is 2 *)
  basicapply LEA_ruleSameBase.
  rewrite -> addB0. rewrite /eval.scaleBy shlB_asMul.

  try_basicapply IHnbits => //.
  rewrite shlB_asMul.
  rewrite -addBA. rewrite <-mulBA. rewrite <- (mulBDr w).
  rewrite 3!expnS expn0 muln1 mulnA.
  rewrite fromNat_mulBn. rewrite fromNat_addBn. rewrite mulnA. rewrite -mulnDl.
  replace (2+m./2 * 2 *2) with (true*2 + m./2 * 2 * 2) by done.
  rewrite -mulnDl.
  rewrite -ODD. rewrite !muln2. rewrite -> (odd_double_half m).
  rewrite -!muln2. by rewrite mulnA.

  destruct c.

  (* c is 3 *)
  basicapply LEA_ruleSameBase.
  rewrite -> addB0. rewrite /eval.scaleBy !shlB_asMul.

  try_basicapply IHnbits => //.
  rewrite -addBA. rewrite <-!mulBA. rewrite <- (mulBDr w).
  rewrite 4!expnS expn0 muln1 mulnA.
  rewrite 2!fromNat_mulBn. rewrite fromNat_addBn. rewrite 2!mulnA. rewrite -mulnDl.
  rewrite 2!mulnA.
  rewrite -mulnDl.
  replace (2+m./2 * 2 *2) with (true*2 + m./2 * 2 * 2) by done.
  rewrite -mulnDl.
  rewrite -ODD. rewrite !muln2. rewrite -> (odd_double_half m).
  rewrite -!muln2. by rewrite mulnA.

  (* c is something else *)

  (* SHL r2, c *)
  basicapply SHL_RI_rule => //.

  (* ADD r1, r2 *)
  basicapply ADD_RR_ruleNoFlags.

  try_basicapply IHnbits => //.
  rewrite expn1 -{2}(odd_double_half m) ODD. rewrite muln2. rewrite -addBA.
  rewrite mulnDl mul1n. rewrite mulB_addn. rewrite mulnC.
  by rewrite shlB_mul2exp mulB_muln.

  rewrite -(add1n nbits) in LT1.
  apply: leq_trans LT1.
  rewrite -{1}(add0n (1+nbits)). by rewrite leq_add2r.
  apply: leq_trans LT1.
  rewrite -addn1. by rewrite leq_add2l.
(* lsb is 0 *)

  basicapply IHnbits.
  rewrite expnS.
  rewrite -{2}(odd_double_half m) ODD add0n.
  rewrite mulnA. rewrite muln2.
  sbazooka.
  by rewrite -(addn1 c) -addnA add1n.
  done.
Qed.

Lemma add_mulcFastCorrect (r1 r2: NonSPReg) (d:DWORD):
  |-- Forall v, Forall w,
  basic
  (r1 ~= v ** r2 ~= w)
  (add_mulcFast r1 r2 d)
  (r1 ~= addB v (mulB w d) ** r2?) @ OSZCP?.
Proof.
rewrite /add_mulcFast.
specintros => v w.

have LT: toNat d < 2^32 by apply toNatBounded.
autorewrite with push_at.
try_basicapply genCorrect => //. by rewrite expn0 muln1 toNatK.
Qed.

Definition screenWidth:DWORD := Eval compute in #160.
Eval showinstr in linearize (add_mulcFast EDI EDX screenWidth).


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

Require Import Reals.
Require Import Psatz.
Require Import Tactiques.
Require Import Rbase_operations.

Open Scope R_scope.

Lemma Rlt_gt : forall x y : R, x < y -> y > x.
Proof.
auto with *.
Qed.
Hint Resolve Rlt_gt: real.

Lemma Rge_minus : forall x y z : R, y <= z -> x - y >= x - z.
Proof.
intros; lra.
Qed.
Hint Resolve Rge_minus: real.

Lemma Rlt_add_compatibility : forall x y z : R, x < y + z -> x - y < z.
Proof.
intros; lra.
Qed.
Hint Resolve Rlt_add_compatibility: real.

Lemma Rlt_add_compatibility2 : forall x y z : R, x - z < y -> x < y + z.
Proof.
intros; lra.
Qed.
Hint Resolve Rlt_add_compatibility2: real.

Lemma Rle_add_compatibility : forall x y z : R, x + y <= z -> x <= z - y.
Proof.
intros; lra.
Qed.
Hint Resolve Rle_add_compatibility: real.

Lemma Rle_sub_compatibility : forall x y z : R, x <= z + y -> x - y <= z.
Proof.
intros; lra.
Qed.
Hint Resolve Rle_sub_compatibility: real.

Lemma Rle_sub_compatibility2 : forall x y z : R, x - y <= z -> x <= z + y.
Proof.
intros; lra.
Qed.
Hint Resolve Rle_sub_compatibility2: real.

Lemma Rlt_add_compatibility3 : forall x y z : R, x < z - y -> x + y < z.
Proof.
intros; lra.
Qed.
Hint Resolve Rlt_add_compatibility3: real.

Lemma Rlt_sub_compatibility : forall x y z : R, x + y < z -> x < z - y.
Proof.
intros; lra.
Qed.
Hint Resolve Rlt_sub_compatibility: real.

Lemma Rlt_add_compatibility4 : forall x y z : R, x - y < z -> x < y + z.
Proof.
intros; lra.
Qed.
Hint Resolve Rlt_add_compatibility4: real.

Lemma Rle_sub_r : forall r r1 r2 : R, r2 <= r1 -> r - r1 <= r - r2.
Proof.
intros; lra.
Qed.
Hint Resolve Rle_sub_r: real.

Lemma Rmult_le :
 forall r1 r2 r3 r4 : R,
 r3 >= 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4.
Proof.
intros.
apply Rle_lt_trans with (r2 * r3);
 [ apply Rmult_le_compat_r; [ apply Rge_le; auto | auto ]
 | apply Rmult_lt_compat_l; auto ].
apply Rlt_le; auto.
Qed.
Hint Resolve Rmult_le: real.

Lemma Rlt_r_O : forall r1 r2 r : R, r = 0 -> r1 < r2 + r -> r1 < r2.
Proof.
intros.
generalize H0; rewrite H; rewrite Rplus_0_r; auto.
Qed.
Hint Resolve Rlt_r_O: real.

Lemma Rlt_sub_O : forall r1 r2 : R, 0 < r1 - r2 -> r2 < r1.
Proof.
intros; lra.
Qed.
Hint Resolve Rlt_sub_O: real.

Lemma mega_nul : forall r r1 r2 : R, 0 < r -> r1 < r * r2 -> r1 * / r < r2.
Proof.
intros.
apply Rmult_lt_reg_l with r; [ assumption | idtac ].
rewrite Rmult_comm; rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
rewrite RIneq.Rmult_1_r; assumption.
apply Rgt_not_eq; apply Rlt_gt; assumption.
Qed.
Hint Resolve mega_nul: real.

Lemma Rle_Rinv_monotony :
 forall r r1 r2 : R, 0 < r -> r1 <= r * r2 -> / r * r1 <= r2.
Proof.
intros.
apply Rmult_le_reg_l with r; auto.
rewrite <- Rmult_assoc; replace (r * / r) with 1.
rewrite Rmult_comm; rewrite RIneq.Rmult_1_r; auto.
rewrite Rmult_comm; apply Rinv_l_sym; apply Rgt_not_eq; apply Rlt_gt; auto.
Qed.
Hint Resolve Rle_Rinv_monotony: real.

Lemma Rlt_Rinv_l_to_r :
 forall r r1 r2 : R, 0 < r -> r1 * r < r2 -> r1 < r2 * / r.
Proof.
intros.
apply Rmult_lt_reg_l with r; auto.
rewrite Rmult_comm.
apply Rgt_lt.
rewrite <- Rmult_assoc; rewrite Rmult_comm; rewrite <- Rmult_assoc;
 rewrite <- Rinv_l_sym.
rewrite Rmult_comm; rewrite RIneq.Rmult_1_r; apply Rlt_gt; auto.
apply Rgt_not_eq; apply Rlt_gt; auto.
Qed.
Hint Resolve Rlt_Rinv_l_to_r: real.

Lemma Rmult_lt_pos_bis : forall x y : R, 0 > x -> 0 > y -> 0 < x * y.
Proof.
intros.
RingReplace (x * y) (- x * - y); auto with real.
apply Rmult_lt_0_compat; auto with real.
Qed.
Hint Resolve Rmult_lt_pos_bis: real.

Lemma Rinv_le : forall r r1 : R, 0 < r -> 0 < r1 -> r1 <= r -> / r <= / r1.
Proof.
intros.
apply Rmult_le_reg_l with r1; auto.
apply Rmult_le_reg_l with r; auto.
rewrite Rmult_comm; rewrite Rmult_assoc.
replace (/ r * r) with 1;
 [ idtac | apply Rinv_l_sym; apply Rgt_not_eq; apply Rlt_gt; auto ].
replace (r1 * / r1) with 1;
 [ idtac | apply Rinv_r_sym; apply Rgt_not_eq; apply Rlt_gt; auto ].
do 2 rewrite RIneq.Rmult_1_r; auto.
Qed.
Hint Resolve Rinv_le: real.

Lemma Rle_mult_inv :
 forall r r1 r2 : R, r > 0 -> r1 * r <= r2 -> r1 <= r2 * / r.
Proof.
intros.
apply Rmult_le_reg_l with r; auto.
rewrite <- Rmult_assoc.
replace (r * r2 * / r) with r2;
 [ rewrite Rmult_comm; auto
 | symmetry  in |- *; apply Rinv_r_simpl_m; apply Rgt_not_eq; auto ].
Qed.
Hint Resolve Rle_mult_inv: real.


Require Import Streams.

Print Stream.

CoFixpoint from n := Cons n (from (n+1)).

Require Import List.

Print list.

Fixpoint take {A:Type} n (xs : Stream A) :=
  match (n, xs) with
    | (0, _) => nil
    | (S n', Cons x xs) => x :: take n' xs
  end.

Eval compute in take 10 (from 0).
Eval compute in from 0.

(*
Inductive が引数のときには Fixpoint
CoInductive が返り値のときには CoFixpoint
 *)

(* Inductive MyStream (A : Type) : Type := *)
(*   SCons : A -> MyStream A -> MyStream A. *)


Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Export Coq.Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Lists.List.
Import ListNotations.

Definition beq_string x y :=
  if string_dec x y then true else false.

Theorem beq_string_refl : forall s, true = beq_string s s.
Proof.
  intros s. unfold beq_string. destruct (string_dec s s) as [|Hs].
  { reflexivity. }
  { destruct Hs. reflexivity. }
Qed.

Theorem beq_string_true_iff :
  forall (x y : string), beq_string x y = true <-> x = y.
Proof.
  intros x y. unfold beq_string.
  destruct (string_dec x y) as [|Hs].
  { subst. split; reflexivity. }
  { split. { intros H. inversion H. }
           { intros H. subst. destruct Hs. reflexivity. }
}
Qed.

Theorem beq_string_false_iff : forall x y : string,
  beq_string x y = false <-> x <> y.
Proof.
  intros x y. rewrite <- beq_string_true_iff.
  rewrite not_true_iff_false. reflexivity.
Qed.

Theorem false_beq_string :
  forall x y : string, x <> y -> beq_string x y = false.
Proof.
  intros x y. rewrite beq_string_false_iff. intros H. apply H.
Qed.

Definition total_map (A : Type) := string -> A.

Definition t_empty {A: Type} (v : A) : total_map A :=
  (fun _ => v).

Definition t_update {A : Type}
  (m : total_map A) (x : string) (v : A) :=
fun x' => if beq_string x x' then v else m x'.

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true) "bar" true.

Notation "{ --> d }" := (t_empty d) (at level 0).

Notation "m '&' { a --> x }" :=
  (t_update m a x) (at level 20).
Notation "m '&' { a --> x ; b --> y }" :=
  (t_update (m & { a --> x }) b y) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z }" :=
  (t_update (m & { a --> x ; b --> y }) c z) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z ; d --> t }" :=
    (t_update (m & { a --> x ; b --> y ; c --> z }) d t) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z ; d --> t ; e --> u }" :=
    (t_update (m & { a --> x ; b --> y ; c --> z ; d --> t }) e u) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z ; d --> t ; e --> u ; f --> v }" :=
    (t_update (m & { a --> x ; b --> y ; c --> z ; d --> t ; e --> u }) f v) (at level 20).

Definition examplemap' :=
  { --> false } & { "foo" --> true ; "bar" --> true }.

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
  { --> v } x = v.
Proof.
  intros A x v. unfold t_empty. reflexivity.
Qed.

Lemma t_update_eq : forall A (m : total_map A) x v,
  (m & {x --> v}) x = v.
Proof.
  intros A m x v. unfold t_update.
  rewrite <- beq_string_refl. reflexivity.
Qed.

Theorem t_update_neq : forall (X : Type) v x1 x2 (m : total_map X),
 x1 <> x2 -> (m & {x1 --> v}) x2 = m x2.
Proof.
  intros X v x1 x2 m H. unfold t_update.
  rewrite false_beq_string.
  - reflexivity.
  - apply H.
Qed.

Theorem nested_ifs :
  forall (P: bool) (A : Type) (X Y Z : A),
    (if P then X else (if P then Y else Z)) =
    (if P then X else Z).
Proof.
  intros P X Y Z. destruct P; reflexivity.
Qed.

Theorem t_update_shadow : forall A (m : total_map A) v1 v2 x,
  m & {x --> v1 ; x --> v2} = m & {x --> v2}.
Proof.
  intros A m v1 v2 x. unfold t_update.
  extensionality i. destruct (beq_string x i); reflexivity.
Qed.

Lemma beq_stringP : forall x y, reflect (x = y) (beq_string x y).
Proof.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

Require Export Decidable.
Require Export NAxioms.
Require Import NZProperties.

Module NBaseProp (Import N : NAxiomsMiniSig').
(** First, we import all known facts about both natural numbers and integers. *)
Include NZProp N.

(** From [pred_0] and order facts, we can prove that 0 isn't a successor. *)

Theorem neq_succ_0 : forall n, S n ~= 0.
Proof.
 intros n EQ.
 assert (EQ' := pred_succ n).
 rewrite EQ, pred_0 in EQ'.
 rewrite <- EQ' in EQ.
 now apply (neq_succ_diag_l 0).
Qed.

Theorem neq_0_succ : forall n, 0 ~= S n.
Proof.
intro n; apply neq_sym; apply neq_succ_0.
Qed.

(** Next, we show that all numbers are nonnegative and recover regular
    induction from the bidirectional induction on NZ *)

Theorem le_0_l : forall n, 0 <= n.
Proof.
nzinduct n.
now apply eq_le_incl.
intro n; split.
apply le_le_succ_r.
intro H; apply le_succ_r in H; destruct H as [H | H].
assumption.
symmetry in H; false_hyp H neq_succ_0.
Qed.

Theorem induction :
  forall A : N.t -> Prop, Proper (N.eq==>iff) A ->
    A 0 -> (forall n, A n -> A (S n)) -> forall n, A n.
Proof.
intros A A_wd A0 AS n; apply right_induction with 0; try assumption.
intros; auto; apply le_0_l. apply le_0_l.
Qed.

(** The theorems [bi_induction], [central_induction] and the tactic [nzinduct]
refer to bidirectional induction, which is not useful on natural
numbers. Therefore, we define a new induction tactic for natural numbers.
We do not have to call "Declare Left Step" and "Declare Right Step"
commands again, since the data for stepl and stepr tactics is inherited
from NZ. *)

Ltac induct n := induction_maker n ltac:(apply induction).

Theorem case_analysis :
  forall A : N.t -> Prop, Proper (N.eq==>iff) A ->
    A 0 -> (forall n, A (S n)) -> forall n, A n.
Proof.
intros; apply induction; auto.
Qed.

Ltac cases n := induction_maker n ltac:(apply case_analysis).

Theorem neq_0 : ~ forall n, n == 0.
Proof.
intro H; apply (neq_succ_0 0). apply H.
Qed.

Theorem neq_0_r : forall n, n ~= 0 <-> exists m, n == S m.
Proof.
cases n. split; intro H;
[now elim H | destruct H as [m H]; symmetry in H; false_hyp H neq_succ_0].
intro n; split; intro H; [now exists n | apply neq_succ_0].
Qed.

Theorem zero_or_succ : forall n, n == 0 \/ exists m, n == S m.
Proof.
cases n.
now left.
intro n; right; now exists n.
Qed.

Theorem eq_pred_0 : forall n, P n == 0 <-> n == 0 \/ n == 1.
Proof.
cases n.
rewrite pred_0. now split; [left|].
intro n. rewrite pred_succ.
split. intros H; right. now rewrite H, one_succ.
intros [H|H]. elim (neq_succ_0 _ H).
apply succ_inj_wd. now rewrite <- one_succ.
Qed.

Theorem succ_pred : forall n, n ~= 0 -> S (P n) == n.
Proof.
cases n.
intro H; exfalso; now apply H.
intros; now rewrite pred_succ.
Qed.

Theorem pred_inj : forall n m, n ~= 0 -> m ~= 0 -> P n == P m -> n == m.
Proof.
intros n m; cases n.
intros H; exfalso; now apply H.
intros n _; cases m.
intros H; exfalso; now apply H.
intros m H2 H3. do 2 rewrite pred_succ in H3. now rewrite H3.
Qed.

(** The following induction principle is useful for reasoning about, e.g.,
Fibonacci numbers *)

Section PairInduction.

Variable A : N.t -> Prop.
Hypothesis A_wd : Proper (N.eq==>iff) A.

Theorem pair_induction :
  A 0 -> A 1 ->
    (forall n, A n -> A (S n) -> A (S (S n))) -> forall n, A n.
Proof.
rewrite one_succ.
intros until 3.
assert (D : forall n, A n /\ A (S n)); [ |intro n; exact (proj1 (D n))].
induct n; [ | intros n [IH1 IH2]]; auto.
Qed.

End PairInduction.

(** The following is useful for reasoning about, e.g., Ackermann function *)

Section TwoDimensionalInduction.

Variable R : N.t -> N.t -> Prop.
Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R.

Theorem two_dim_induction :
   R 0 0 ->
   (forall n m, R n m -> R n (S m)) ->
   (forall n, (forall m, R n m) -> R (S n) 0) -> forall n m, R n m.
Proof.
intros H1 H2 H3. induct n.
induct m.
exact H1. exact (H2 0).
intros n IH. induct m.
now apply H3. exact (H2 (S n)).
Qed.

End TwoDimensionalInduction.

Section DoubleInduction.

Variable R : N.t -> N.t -> Prop.
Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R.

Theorem double_induction :
   (forall m, R 0 m) ->
   (forall n, R (S n) 0) ->
   (forall n m, R n m -> R (S n) (S m)) -> forall n m, R n m.
Proof.
intros H1 H2 H3; induct n; auto.
intros n H; cases m; auto.
Qed.

End DoubleInduction.

Ltac double_induct n m :=
  try intros until n;
  try intros until m;
  pattern n, m; apply double_induction; clear n m;
  [solve_proper | | | ].

End NBaseProp.


Require Export D.

Lemma evenb_S : forall n,
    evenb (S n) = negb (evenb n).
Proof.
  intros n. induction n as [| n'].
  - simpl. reflexivity.
  - rewrite IHn'. simpl. destruct (evenb n') eqn:Heq.
    + simpl. reflexivity.
    + simpl. reflexivity.
Qed.

Lemma evenb_double_true : forall n,
    evenb (double n) = true.
Proof.
  intros n. induction n.
  - reflexivity.
  - assumption.
Qed.

Theorem evenb_double_conv : forall n,
  exists k, n = if evenb n then double k
                else S (double k).
Proof.
  intros. induction n.
  - simpl. exists 0. reflexivity.
  - destruct evenb.
    + destruct IHn. subst. exists x. rewrite evenb_S. rewrite evenb_double_true. reflexivity.
    + destruct IHn. subst. exists (S x). simpl. rewrite evenb_double_true. reflexivity.
Qed.


Require Export XR_R.
Require Export XR_Rle.
Require Export XR_total_order_T.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rle_lt_dec : forall r1 r2, {r1 <= r2} + {r2 < r1}.
Proof.
  intros x y.
  destruct (total_order_T x y) as [ [ hxy | heq ] | hyx ].
  {
    left.
    unfold "<=".
    left.
    exact hxy.
  }
  {
    subst y.
    left.
    unfold "<=".
    right.
    reflexivity.
  }
  {
    right.
    exact hyx.
  }
Qed.


Definition N := 12.

Inductive tree : Type :=
| Leaf : tree
| Node : nat -> tree -> tree -> tree.

Fixpoint binary_tree c n :=
  match n with
  | 0 => Leaf
  | S n =>
    let t := binary_tree c n in
    Node c t t
  end.

Definition t0 := Eval vm_compute in binary_tree 0 N.
Definition t1 := Eval vm_compute in binary_tree 1 N.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (x : natural) (y : natural) (lf1 : natural) : natural := Succ y.


(* (c) Copyright Microsoft Corporation and Inria. You may distribute   *)
(* under the terms of either the CeCILL-B License or the CeCILL        *)
(* version 2 License, as specified in the README file.                 *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype.
Require Import bigops ssralg matrix poly.

(*****************************************************************************)
(* This file contains the definitions of:                                    *)
(*  - char_poly A  : Characteristic polynomial of A                          *)
(*  - phi : the isomorphism between the rings  M(R[X]) and M(R)[X]           *)
(*    with R a commutative and                                               *)
(*     M(R[X]) : matrices with coefficients in the polynomial ring of R      *)
(*     M(R)[X] : polynomials with coefficients in the matrix ring of R       *)
(*  - Zpoly : the injection from the polynomial ring to M(R)[X]              *)
(* In addition to the lemmas relevant to these definitions, this file also   *)
(* contains a proof of the Cayley-Hamilton Theorem.                          *)
(*****************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Import GRing.Theory.
Import Monoid.Theory.

Open Local Scope ring_scope.

Section Cayley.

Variable R : comRingType.

Variable n : pos_nat.

Notation Local nn := (pos_nat_val n) (only parsing).
Notation Local "'R'" := R
  (at level 0, format "'R'").
Notation Local "'R' [ 'X' ]" := {poly R}
  (at level 0, format "'R' [ 'X' ]").
Notation Local "'M' ( 'R' )" := (matrix R nn nn)
  (at level 0, format "'M' ( 'R' )").
Notation Local "'M' ( 'R' [ 'X' ] )" :=
  (matrix (poly_ringType R) nn nn)
  (at level 0, format "'M' ( 'R' [ 'X' ] )").
Notation Local "'M' ( 'R' ) [ 'X' ]" := {poly (matrix R n n)}
  (at level 0, format "'M' ( 'R' ) [ 'X' ]").

(* The characteristic polynomial *)
Open Scope matrix_scope.
Definition matrixC (A : M(R)) : M(R[X]) := \matrix_(i, j) (A i j)%:P.

Definition char_poly (A : M(R)) : R[X] := \det ('X%:M - matrixC A).

(* The isomorhism phi : M(R[X]) <-> M(R)[X] *)

Definition phi (A : M(R[X])) : M(R)[X] :=
  \poly_(k < \max_i \max_j size (A i j)) \matrix_(i, j) (A i j)`_k.

Lemma coef_phi : forall A i j k, (phi A)`_k i j = (A i j)`_k.
Proof.
move=> A i j k; rewrite coef_poly.
case: (ltnP k _) => le_m_k; rewrite mxE // nth_default //.
apply: leq_trans (leq_trans (leq_bigmax i) le_m_k); exact: (leq_bigmax j).
Qed.

Lemma phi_polyC : forall A, phi (matrixC A) = A%:P.
Proof.
move=> A; apply/polyP=> k; apply/matrixP=> i j.
by rewrite coef_phi !mxE !coefC; case k; last rewrite /= mxE.
Qed.

Lemma phi_zero : phi 0 = 0.
Proof.
apply/polyP=> k; apply/matrixP=> i j.
by rewrite coef_phi mxE !coef0 mxE.
Qed.

Lemma phi_add : forall (A1 A2 : M(R[X])), phi (A1 + A2) = (phi A1) + (phi A2).
Proof.
move=> A1 A2; apply/polyP => k; apply/matrixP=> i j.
by rewrite coef_phi !mxE !coef_add_poly mxE !coef_phi.
Qed.

Lemma phi_opp : forall A, phi (- A) = - phi A.
Proof.
move=> A; apply/polyP=> k; apply/matrixP=> i j.
by rewrite coef_phi mxE coef_opp mxE coef_phi coef_opp.
Qed.

Lemma phi_one : phi 1 = 1.
Proof.
apply/polyP=> k; apply/matrixP=> i j.
rewrite coef_phi mxE (fun_if (fun p : {poly _} => p`_k)) coef0 !coefC.
by case: k => [|k]; rewrite /= !mxE // if_same.
Qed.

Lemma phi_mul : forall (A1 A2 : M(R[X])), phi (A1 * A2) = (phi A1) * (phi A2).
Proof.
move=> A1 A2; apply/polyP=> k; apply/matrixP=> i j.
rewrite !coef_phi !mxE !coef_mul summxE coef_sum.
pose F k1 k2 := (A1 i k1)`_k2 * (A2 k1 j)`_(k - k2).
transitivity (\sum_k1 \sum_(k2 < k.+1) F k1 k2); rewrite {}/F.
  by apply: eq_bigr=> k1 _; rewrite coef_mul.
rewrite exchange_big /=; apply: eq_bigr=> k2 _.
by rewrite mxE; apply: eq_bigr=> k1 _; rewrite !coef_phi.
Qed.

(* Writing a polynomial as a polynomial on matrices *)

Definition Zpoly (p : R[X]) : M(R)[X] := \poly_(i < size p) (p`_i)%:M.

Lemma coef_Zpoly : forall p k, (Zpoly p)`_k = (p`_k)%:M.
Proof.
move=> p k; rewrite coef_poly; case: (ltnP k _) => // le_p_k.
by rewrite nth_default // scalar_mx0.
Qed.

Lemma ZpolyX : Zpoly 'X = 'X.
Proof.
apply/polyP=> k; apply/matrixP=> i j; rewrite coef_Zpoly !coefX.
by case: (k == _); rewrite !mxE ?if_same.
Qed.

Lemma phi_Zpoly : forall p, phi p%:M = Zpoly p.
Proof.
move=> p; apply/polyP=> k; apply/matrixP=> i j.
by rewrite coef_phi coef_Zpoly !mxE; case: (i == j); rewrite ?coef0.
Qed.

(* The theorem in three lines! *)

Theorem Cayley_Hamilton : forall A, (Zpoly (char_poly A)).[A] = 0.
Proof.
move=> A; apply/eqP; apply/factor_theorem.
rewrite -phi_Zpoly -mulmx_adjl phi_mul; move: (phi _) => q; exists q.
by rewrite phi_add phi_opp phi_Zpoly phi_polyC ZpolyX.
Qed.

End Cayley.


Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype.
Require Import ssralg bigops matrix.

Open Local Scope ring_scope.
Open Local Scope matrix_scope.
Import GRing.Theory.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Section GaussianElimination.
Variable F : fieldType.
Variables m n : nat.
Notation Local "''M_' ( m , n )" := (matrix F m n) : type_scope.
Implicit Type A B C : 'M_(m, n).

(* Row Operations *)
Definition row_scale A i0 c :=
 \matrix_(i, j) if i == i0 then c * A i j else A i j.

Definition row_exch A i1 i2 :=
 \matrix_(i, j) if i == i1 then A i2 j else if i== i2 then A i1 j else A i j.

Definition row_repl A i1 i2 c :=
 \matrix_(i, j) if i == i1 then A i j + c * A i2 j else A i j.

(* RREF operations *)
(* annihilate all element of a colum expect the pivot *)
Definition annihilate_col_fun i j x A :=
 if i != x then row_repl A x i (-(A x j) * (A i j)^-1) else A.

Lemma annihilate_col_funE : forall A i j x k l,
  (annihilate_col_fun i j x A) k l =
  if (i != x) && (k == x) then A k l - (A k j) * (A i j)^-1 * A i l else A k l.
Proof.
move=> A i j x k l; case: ifP; rewrite /annihilate_col_fun.
  by case/andP=> ->; move/eqP<-; rewrite mxE eq_refl !mulNr.
by case/nandP; [move/negbTE-> | case: ifP => // _; rewrite mxE; move/negbTE->].
Qed.

Definition annihilate_col A i j :=
 foldr (annihilate_col_fun i j) A (take m (enum 'I_m)).

Lemma annihilate_colE : forall A i j k l,
 (annihilate_col A i j) k l =
 if (k != i) then A k l - (A k j) * (A i j)^-1 * A i l else A k l.
Proof.
move=> /= A i j k l; rewrite /annihilate_col.
elim: {1 4 10}m (leqnn m) (ltn_ord k) A => [// | m' Rm' Lm' Lk A].
rewrite (take_nth k) 1?size_enum_ord // -cats1 (nth_ord_enum _ (Ordinal Lm')).
rewrite foldr_cat /=; rewrite ltnS leq_eqVlt orbC in Lk; case/orP: Lk => Lk.
  rewrite (Rm' (ltnW Lm')) // !annihilate_col_funE.
  suff -> : k == Ordinal Lm' = false; first by rewrite andbF andNb.
  apply/eqP; move/(congr1 (@nat_of_ord _)); move/eqP.
  by rewrite /= eqn_leq andbC leqNgt Lk.
suff <- : k = (Ordinal Lm'); [| apply: val_inj]; rewrite /= -(eqP Lk) //{Rm' Lk}.
elim: {-2}(val k) {m' Lm'} (leqnn k) A => /= [| k' Rk'] Lk A.
  by rewrite take0 /= annihilate_col_funE eq_refl andbT eq_sym.
have Hk' : k' < m by apply (ltn_trans Lk).
rewrite (take_nth k) 1?size_enum_ord // -cats1 foldr_cat.
rewrite (nth_ord_enum _ (Ordinal Hk')) /=.
have -> : annihilate_col_fun i j (Ordinal Hk') (annihilate_col_fun i j k A) =
 annihilate_col_fun i j k (annihilate_col_fun i j (Ordinal Hk') A).
  apply/matrixP=> ? ?; rewrite !annihilate_col_funE !andNb.
  by case: ifP => -> //; case: ifP => ->.
rewrite (Rk' (ltnW Lk)) !annihilate_col_funE andNb //.
suff -> : k == (Ordinal Hk') = false; [by rewrite andbF | apply/eqP].
by move/(congr1 (@nat_of_ord _)) => /=; move/eqP; rewrite eqn_leq leqNgt Lk.
Qed.

Definition rref_pred (r : nat) A j :=
 let P := [pred k | forallb l : 'I_m, (r <= l < k) ==> (A l j == 0)] in
 [pred k | [&& (A k j != 0), (r <= k) & P k]].

Lemma rref_predP : forall r A j,
 reflect (forall x : 'I_m, r <= x -> A x j = 0) (pred0b (rref_pred r A j)).
Proof.
move=> /= r A j; apply: (iffP idP) => H; rewrite /rref_pred; last first.
  apply/pred0P => /= k /=; case: (leqP r k) => rk; rewrite /= 1?andbF //.
  by move: (H _ rk); move/eqP->.
move/negPn: H; rewrite negb_exists; move/forallP => H /= k.
elim: {1}(val k) {1 3 4}k (leqnn k) => [| k' Rk'] l Hl Lrl.
  move: (H l); move: (leq_trans Lrl Hl); move: Hl; rewrite !leqn0; move/eqP->.
  by move/eqP => -> /=; case/nandP; [move/negPn; move/eqP | case/pred0P => ?].
rewrite leq_eqVlt ltnS in Hl; case/orP: Hl; last by move=> ?; apply: Rk'.
move=> Hl; move: (H l); rewrite Lrl; case/nandP; first by move/negPn; move/eqP.
case/existsP => /= l'; rewrite negb_imply (eqP Hl) ltnS; case/andP.
by case/andP => ? ?; rewrite (Rk' l') 1?eq_refl.
Qed.

Definition rref_fun (x : nat * 'M_(m, n)) (j : 'I_n) : nat * 'M_(m, n) :=
 let s_i := pick (rref_pred x.1 x.2 j) in
 if (insub x) : option {y | (x.1 < m) } is Some (exist _ Hx) then
  if s_i is Some i then
   let A1 := row_exch x.2 (Ordinal Hx) i in
   let A2 := row_scale A1 (Ordinal Hx) (A1 (Ordinal Hx) j)^-1 in
   let A3 := annihilate_col A2 (Ordinal Hx) j in
    ((x.1).+1, A3)
  else x
 else x.

(* Compute the rref form of a given matrix and it's rank *)
Definition rref A j := foldl rref_fun (0%N, A) (take j (enum 'I_n)).

Definition rank A := (rref A n).1.
Definition rref_mx A := (rref A n).2.

(* Definition of rref predicate *)
Definition zrow A i j := (forallb k : 'I_n, (k < j) ==> (A i k == 0)).

Lemma zrowP : forall A i j,
 reflect (forall k : 'I_n, k < j -> (A i k = 0)) (zrow A i j).
Proof.
move=> /= A i j.
apply: (iffP idP) => H; last by apply/forallP=> ?; apply/implyP; move/H->.
by move=> /= k Hk; move/forallP: H; move/(_ k); rewrite Hk /=; move/eqP.
Qed.

(* getting the pivot *)
Definition pivot A i j :=
 pick [pred l | [&& (A i l != 0), (l < j) & (zrow A i l)]].

Definition zrows_in_bottom A j :=
 forallb i, (zrow A i j) ==> (forallb i' : 'I_m, ((i <= i') ==> zrow A i' j)).

Definition pivot_eq1 A j :=
 forallb i, if (pivot A i j) is Some l then A i l == 1 else zrow A i j.

Definition pivot_zcol A j := forallb i,
 if (pivot A i j) is Some l then (forallb k, (k != i) ==> (A k l == 0))
 else true.

Definition pivot_mono A j := forallb i1,
 if (pivot A i1 j) is Some j1 then
  forallb i2, if pivot A i2 j is Some j2 then (i1 < i2) ==> (j1 < j2) else true
 else true.

Definition is_rref A j :=
 [&& zrows_in_bottom A j, pivot_eq1 A j, pivot_zcol A j & pivot_mono A j].

Section InvariantLemmas.

Lemma rank_rref_mono : forall A j j', j <= j' -> (rref A j).1 <= (rref A j').1.
Proof.
move=> A j; elim=> [| j' Rj']; first by rewrite leqn0; move/eqP->.
rewrite leq_eqVlt ltnS; case/orP => Ljj'; first by move/eqP: Ljj' ->.
rewrite (leq_trans (Rj' Ljj')) // /rref.
case: (leqP n j') => H; last rewrite (take_nth (Ordinal H)) 1?size_enum_ord //.
  by rewrite !take_oversize 1?size_enum_ord 1?(leq_trans H).
rewrite -cats1 foldl_cat /= (nth_ord_enum _ (Ordinal H)) {2}/rref_fun.
by case: insubP => //= [] [] _ ? _ _; case: pickP => [| ?] /=.
Qed.

Lemma rank_rref_leq : forall A j, (rref A j).1 <= minn m j.
Proof.
move=> A; elim=> [| j]; rewrite /rref 1?take0 //=.
case: (leqP n j) => Hj.
  rewrite !take_oversize 1?size_enum_ord 1?(leq_trans Hj) // !leq_minr.
  by case/andP=> -> /= H; apply: (leq_trans H).
rewrite (take_nth (Ordinal Hj)) 1?size_enum_ord // -cats1 foldl_cat /=.
rewrite (nth_ord_enum _ (Ordinal Hj)) {2}/rref_fun /=.
case: insubP => //= [[] [] _ _ Hm _ _ /=| _]; last first.
  by rewrite !leq_minr; case/andP => -> /= H; apply: (leq_trans H).
case: pickP => [/= k | _]; last first.
  by rewrite !leq_minr; case/andP => -> /= H; apply: (leq_trans H).
by case/and3P=> H1 H2 _; rewrite !leq_minr ltnS Hm; case/andP=> _ ->.
Qed.

Lemma rref_mx_zcols : forall A (i : 'I_m) (j : 'I_n) j',
 j < j' -> (rref A j').1 <= i -> (rref A j').2 i j = 0.
Proof.
move=> A i j j'; elim: j' i j => // j' Rj' i j; rewrite ltnS leq_eqVlt => Ljj'.
case: (leqP n j') => Hj'; first move: (Rj' i j (leq_trans (ltn_ord j) Hj')).
  by rewrite /rref !take_oversize 1?size_enum_ord 1?(leq_trans Hj').
rewrite /rref (take_nth j) 1?size_enum_ord // -cats1 foldl_cat.
rewrite (nth_ord_enum _ (Ordinal Hj')) /= {1 3}/rref_fun /=.
case: insubP => // [[] [] _ _ H0 _ _ |]; last first.
  by move=> H1 ?; move: H1; rewrite (leq_ltn_trans _ (ltn_ord i)).
case: pickP => /= [k |]; first case/and3P=> H1 H2 _; last first.
  case/orP: Ljj' => [| ? ? ?]; last by apply: Rj'.
  move/eqP=> jj'; move/pred0P; move/rref_predP=> H1 H2.
  by suff -> : j = Ordinal Hj'; [apply: H1 | apply: val_inj].
rewrite annihilate_colE !mxE eqxx mulVf // !invr1 !mulr1.
case: ifP; [move/negbTE=> -> H3 | by move/eqP->; rewrite ltnn].
case/orP: Ljj' => Ljj'; first move/eqP: Ljj' => Ljj' ; last first.
  by rewrite !(Rj' _ j) 1?(ltnW H3) // !mulr0 oppr0 addr0 if_same.
by suff -> : j = (Ordinal Hj'); [ rewrite mulVf // mulr1 addrN | apply: val_inj].
Qed.

Lemma rref_mxE : forall A i j, (rref_mx A) i j = (rref A j.+1).2 i j.
Proof.
move=> /= A i j; rewrite /rref_mx.
elim: {1 5 8}n (leqnn n) j (ltn_ord j) => // n' Rn' Ln j; rewrite ltnS leq_eqVlt.
case/orP => [| Ljm']; last rewrite -Rn' // 1?ltnW //; first by move/eqP->.
rewrite /rref (take_nth j) 1?size_enum_ord // -cats1 foldl_cat.
rewrite (nth_ord_enum _ (Ordinal Ln)) /= {1}/rref_fun /=.
case: insubP=> //= [] [] _ H0 _ _; case: pickP => //= k; case/and3P=> H1 H2 H3.
rewrite !annihilate_colE !mxE /= eqxx (rref_mx_zcols Ljm') // !mulr0 oppr0 addr0.
case: ifP; last by move/eqP->; rewrite eqxx mulr0 rref_mx_zcols.
by move/negbTE->; case: ifP => //; move/eqP->; rewrite !rref_mx_zcols.
Qed.

Lemma zrow_rank_leq : forall A i j, zrow (rref_mx A) i j -> (rref A j).1 <= i.
Proof.
move=> /= A i; elim=> [| j]; rewrite /rref 1?take0 // => Rj Zj.
have : zrow (rref_mx A) i j.
  by apply/zrowP => k Hk; move/zrowP: Zj => -> //; apply: (ltn_trans Hk).
case : (leqP n j) => Hj; move/Rj.
  by rewrite !take_oversize 1?size_enum_ord // (leq_trans Hj).
move/zrowP: Zj; move/(_ (Ordinal Hj) (ltnSn j)); rewrite rref_mxE /rref.
rewrite (take_nth (Ordinal Hj)) 1?size_enum_ord // -cats1 foldl_cat.
rewrite (nth_ord_enum _ (Ordinal Hj)) /= {1 4}/rref_fun /=.
case: insubP => //= [] [] _ H0 _ _; case: pickP => //= l; case/and3P=> H1 H2 _.
rewrite ltn_neqAle andbC annihilate_colE !mxE eqxx mulVf // !invr1 !mulr1.
case: ifP; last by move/eqP->; move/eqP; rewrite !eqxx mulVf // oner_eq0.
by move/negbTE=> H _ -> /=; apply/eqP=> ?; case/eqP: H; apply: val_inj.
Qed.

End InvariantLemmas.

Lemma zrows_in_bottom_rref : forall A n', zrows_in_bottom (rref_mx A) n'.
Proof.
move=> A n'; apply/forallP => /= i; apply/implyP; move/zrowP => Zrn.
apply/forallP => /= i'; apply/implyP => l_ii'; apply/zrowP=> k Hk.
rewrite rref_mxE rref_mx_zcols 1?(leq_trans _ l_ii') //; apply: zrow_rank_leq.
by apply/zrowP => ? ?; apply: Zrn; apply: (leq_ltn_trans _ Hk).
Qed.

Lemma pivot_eq1_rref : forall A n', pivot_eq1 (rref_mx A) n'.
Proof.
move=> A n'; apply/forallP => /= i; rewrite /pivot.
case: pickP => /= [j | Pz]; last apply/zrowP => j Hj; last first.
  elim: n' j Hj Pz => // n' Rn' j Hj Pz; move: (Pz j) => /=.
  suff -> : zrow (rref_mx A) i j; first by rewrite Hj //= andbT; move/eqP.
  apply/zrowP=> k Hk; apply: Rn' => [| l /=]; first by rewrite (leq_trans Hk).
  move: (Pz l); rewrite /= ltnS leq_eqVlt andb_orl andb_orr.
  by case/norP=> _; move/negbTE.
rewrite rref_mxE /rref; case/and3P => H1 Hj Zj; move: H1.
rewrite (take_nth j) 1?size_enum_ord // (nth_ord_enum _ j) -cats1 foldl_cat /=.
rewrite {1 3}/rref_fun /=; case: insubP => /= [[] [] _ _ H0 _ _|]; last first.
  by rewrite (leq_ltn_trans _ (ltn_ord i)) => //; apply: zrow_rank_leq.
case: pickP => //= [k |]; last move/pred0P; last first.
  by move/rref_predP; move/(_ i)->; rewrite 1?eq_refl //; apply: zrow_rank_leq.
case/and3P => H1 H2 _; rewrite annihilate_colE !mxE eqxx mulVf // !invr1 !mulr1.
by case: ifP; [move/negbTE-> | move/eqP->]; rewrite 1?addrN eqxx 1?mulVf.
Qed.

Lemma pivot_zcol_rref : forall A n', pivot_zcol (rref_mx A) n'.
Proof.
move=> A n'; apply/forallP=> /= i; rewrite /pivot.
case: pickP => //= j; case/and3P => Hj1 Hj Hj2; apply/forallP=> /= k.
apply/implyP=> Hk; move: Hj1; rewrite !rref_mxE /rref.
rewrite (take_nth j) 1?size_enum_ord // -cats1 (nth_ord_enum _ j) foldl_cat /=.
rewrite {1 3}/rref_fun; case: insubP=> /= [[] [] _ _ H0 _ _ |]; last first.
  by rewrite (leq_ltn_trans _ (ltn_ord i)) //; apply: zrow_rank_leq.
case: pickP=> /= [l |]; last move/pred0P; last first.
  by move/rref_predP; move/(_ i)->; rewrite 1?eq_refl //; apply: zrow_rank_leq.
case/and3P=> H1 H2 H3; rewrite !annihilate_colE !mxE eqxx mulVf // !invr1 !mulr1.
by case: ifP; [move/negbTE-> | move/eqP<-]; rewrite 1?addrN eqxx 1?mulVf 1?Hk.
Qed.

Lemma pivot_mono_rref : forall A, pivot_mono (rref_mx A) n.
Proof.
move=> A; apply/forallP=> /= i; rewrite /pivot.
case: pickP=> //= j; case/and3P=> Hj1 Hj Hj2; apply/forallP=> /= k.
case: pickP=> //= l; case/and3P=> Hl1 Hl Hl2; apply/implyP=> ik.
case: (ltngtP j l)=> // lj.
  case/eqP: Hl1; suff : zrow (rref_mx A) k j; first by move/zrowP->.
  apply/zrowP=> y ?; rewrite rref_mxE rref_mx_zcols 1?(leq_trans _ (ltnW ik)) //.
  by apply: (leq_trans _ (zrow_rank_leq Hj2)); apply: rank_rref_mono.
suff : rref_mx A k l == 0; first by rewrite (negbTE Hl1).
suff <- : j = l :> 'I_n; first apply/eqP; last by apply: val_inj.
move: Hj1; rewrite !rref_mxE /rref (take_nth j) 1?size_enum_ord // -cats1.
rewrite (nth_ord_enum _ j) foldl_cat /= {1 3}/rref_fun /=.
case: insubP=> //= [[] [] _ _ H0 _ _ |]; last first.
  by rewrite (leq_ltn_trans _ (ltn_ord i)) //; apply: zrow_rank_leq.
case: pickP=> //= [l' |]; last move/pred0P; last first.
  by move/rref_predP; move/(_ i)->; rewrite 1?eq_refl //; apply: zrow_rank_leq.
case/and3P=> H1 H2 H3; rewrite !annihilate_colE !mxE eqxx mulVf // !invr1 !mulr1.
by case: ifP; [move/negbTE-> | move/eqP<-]; rewrite addrN eqxx neq_ltn orbC 1?ik.
Qed.

Lemma is_rref_rref : forall A, is_rref (rref_mx A) n.
Proof.
move=> A; rewrite /is_rref.
by rewrite zrows_in_bottom_rref pivot_eq1_rref pivot_zcol_rref pivot_mono_rref.
Qed.

Lemma rank_min : forall A, rank A <= minn m n.
Proof. by move=> A; apply: rank_rref_leq. Qed.

End GaussianElimination.

Section LinearSystem.
Variable F : fieldType.
Notation Local "''M_' ( m , n )" := (matrix F m n) : type_scope.

Definition system_sol m n (A : 'M_(m, n)) (v : 'M_(m, 1)) :=
 exists u, A *m u == v.

(* equivalent system lemmas : row operations preserves system solution set *)

(* row_scale *)
Lemma rscale_pastemxK : forall m n (A : 'M_(m, n)) (v : 'M_(m, 1)) k c,
 (row_scale (pastemx A v) k c) = pastemx (row_scale A k c) (row_scale v k c).
Proof.
by move=> *; apply/matrixP=> i j; rewrite !mxE; case: splitP => *; rewrite !mxE.
Qed.

Lemma rscale_sys_equiv : forall m n (A : 'M_(m, n)) v k c,
 let A' := (row_scale (pastemx A v) k c) in c != 0 ->
 (system_sol A v <-> (system_sol (lcutmx A') (rcutmx A'))).
Proof.
move=> /= m n A v k c Hc; split; case=> u; move/eqP=> Hu; exists u; apply/eqP.
  rewrite rscale_pastemxK pastemxKl pastemxKr; apply/matrixP=> i j.
  rewrite !mxE -{2}(mul1r (v i j)) -(fun_if ( *%R^~ (v i j))); move/matrixP: Hu.
  move/(_ i j)<-; rewrite mxE big_distrr /=; apply: eq_bigr => /= l _.
  by rewrite mxE -{2}(mul1r (A i l)) -(fun_if ( *%R^~ (A i l))) mulrA.
rewrite rscale_pastemxK pastemxKl pastemxKr in Hu; apply/matrixP=> i j.
move/matrixP: Hu; move/(_ i j); rewrite !mxE -{2}(mul1r (v i j)).
rewrite -(fun_if ( *%R^~ (v i j))); set c' := if i == k then c else 1.
move/(congr1 ( *%R c'^-1)); rewrite mulrA mulVf 1?mul1r => [<- |]; last first.
  by rewrite /c'; case: ifP => // *; apply: nonzero1r.
rewrite big_distrr /=; apply: eq_bigr => /= l _; rewrite !mxE.
rewrite -{3}(mul1r (A i l)) -(fun_if ( *%R^~ (A i l))) !mulrA mulVf 1?mul1r //.
by rewrite /c'; case: ifP => // *; apply: nonzero1r.
Qed.

(* row exchange *)
Lemma rexchange_pastemxK : forall m n (A : 'M_(m, n)) (v : 'M_(m, 1)) k l,
 (row_exch (pastemx A v) k l) = pastemx (row_exch A k l) (row_exch v k l).
Proof.
by move=> *; apply/matrixP=> i j; rewrite !mxE; case: splitP => *; rewrite !mxE.
Qed.

Lemma rexchange_sys_equiv : forall m n (A : 'M_(m, n)) v k l,
 let A' := (row_exch (pastemx A v) k l) in
 (system_sol A v <-> (system_sol (lcutmx A') (rcutmx A'))).
Proof.
move=> /= m n A v k l; split; case=> u; move/eqP=> Hu; exists u; apply/eqP.
  rewrite rexchange_pastemxK pastemxKl pastemxKr; apply/matrixP=> i j.
  move/matrixP: Hu => Hu; rewrite !mxE -!Hu !mxE.
  case: ifP => Pik; first by apply: eq_bigr => x _; rewrite mxE Pik.
  by case: ifP => Pil; apply: eq_bigr => x _; rewrite mxE Pik Pil.
rewrite rexchange_pastemxK pastemxKl pastemxKr in Hu; apply/matrixP=> i j.
move/matrixP: Hu => Hu; case Pil: (i == l).
  move: (Hu l j); rewrite !mxE (eqP Pil) eqxx; case: ifP => [Plk <- | Plk _].
  - by apply: eq_bigr => x _; rewrite mxE Plk.
  by move: (Hu k j); rewrite !mxE eqxx => <-; apply: eq_bigr => *; rewrite mxE eqxx.
move: (Hu i j); rewrite !mxE Pil; case: ifP => [Pik _ | Pik <-]; last first.
  by apply: eq_bigr => x _; rewrite mxE Pik Pil.
move: (Hu l j); rewrite !mxE eqxx -(eqP Pik) eq_sym Pil => <-.
by apply: eq_bigr => *; rewrite mxE eqxx eq_sym Pil.
Qed.

Lemma rrepl_pastemxK : forall m n (A : 'M_(m, n)) (v : 'M_(m, 1)) k l c,
 (row_repl (pastemx A v) k l c) = pastemx (row_repl A k l c) (row_repl v k l c).
Proof.
by move=> *; apply/matrixP=> i j; rewrite !mxE; case: splitP => *; rewrite !mxE.
Qed.

Lemma rrepl_sys_equiv : forall m n (A : 'M_(m, n)) v k l c,
 let A' := (row_repl (pastemx A v) k l c) in l != k ->
 (system_sol A v <-> (system_sol (lcutmx A') (rcutmx A'))).
Proof.
move=> /= m n A v k l c Hkl; split; case=> u; move/eqP=> Hu; exists u; apply/eqP.
  rewrite rrepl_pastemxK pastemxKl pastemxKr; apply/matrixP=> i j.
  move/matrixP: Hu => Hu; rewrite !mxE -{2}(addr0 (v i j)) -{2}(mulr1 c).
  rewrite -{2}(mulr0 c) -{2}(mul0r (v l j)) -mulrA -(fun_if ( +%R (v i j))).
  rewrite -(fun_if ( *%R c)) -(fun_if ( *%R^~ (v l j))) -!Hu !mxE.
  rewrite !big_distrr -big_split /=; apply: eq_bigr => x _; rewrite mxE.
  by case: ifP => ->; rewrite ?mul0r ?mulr0 1?addr0 // mul1r mulrA mulr_addl.
rewrite rrepl_pastemxK pastemxKl pastemxKr in Hu; apply/matrixP=> i j.
move/matrixP: Hu => Hu; move: (Hu i j); rewrite !mxE.
case: ifP => [ik | ik <-]; last by apply: eq_bigr => /= x _; rewrite mxE ik.
move/(congr1 ( +%R^~ (- (c * v l j)))); rewrite -addrA addrN addr0 => <-.
move: (Hu l j); rewrite !mxE (negbTE Hkl) => <-; rewrite big_distrr -sumr_sub /=.
apply: eq_bigr => /= *.
by rewrite !mxE ik (negbTE Hkl) mulr_addl -addrA mulrA addrN addr0.
Qed.

Lemma anil_col_sys_equiv : forall m n (A : 'M_(m, n)) v k l,
 let A' := (annihilate_col (pastemx A v) k (lshift 1 l)) in
 (system_sol A v) <-> (system_sol (lcutmx A') (rcutmx A')).
Proof.
move=> /= m n A v k l; rewrite /annihilate_col.
elim: {3 13 23}m A v (leqnn m) => [A v | m' Rm' A v Hm'].
  by rewrite take0 /= pastemxKl pastemxKr.
rewrite (take_nth (Ordinal Hm')) 1?size_enum_ord // -cats1.
rewrite (nth_ord_enum _ (Ordinal Hm')) foldr_cat /= {2 4}/annihilate_col_fun.
case: ifP => [Ik | ?]; last by apply: Rm'; apply: ltnW.
rewrite rrepl_pastemxK -Rm' 1?ltnW // !pastemxEl.
rewrite (rrepl_sys_equiv _ _ (- A (Ordinal Hm') l / A k l) Ik) rrepl_pastemxK.
by rewrite pastemxKl pastemxKr.
Qed.

Lemma rref_sys_equiv : forall m n (A : 'M_(m, n)) v,
 let A' := (rref (pastemx A v) n).2 in
 (system_sol A v) <-> (system_sol (lcutmx A') (rcutmx A')).
Proof.
move=> m n A v /=; elim: {1 9 14}n (leqnn n) => [| n' Rn'] Hn; rewrite /rref.
  by rewrite take0 /= pastemxKl pastemxKr.
move: (Rn' (ltnW Hn)) => {Rn'} Rn'.
have Hn' : n' < n + 1 by apply: (ltn_trans Hn); rewrite addn1.
rewrite (take_nth (Ordinal Hn')) 1?size_enum_ord // -cats1.
rewrite (nth_ord_enum _ (Ordinal Hn')) foldl_cat /= {1 3}/rref_fun /=.
case: insubP=> //= [] [] _ H0 _ _; case: pickP => //= k; case/and3P=> Hk1 Hk Hk2.
set A' := (rref (pastemx A v) n').2 in Rn' Hk1 Hk2 *.
set r := (rref (pastemx A v) n').1 in H0 Hk Hk2 *.
rewrite Rn' (rexchange_sys_equiv _ _ (Ordinal H0) k) cutmxK.
have Z1 : ((row_exch A' (Ordinal H0) k) (Ordinal H0) (Ordinal Hn'))^-1 != 0.
  by rewrite mxE eqxx invr_neq0.
rewrite (rscale_sys_equiv _ _ (Ordinal H0) Z1) cutmxK.
rewrite (anil_col_sys_equiv _ _ (Ordinal H0) (Ordinal Hn)) cutmxK.
by suff -> : (lshift 1 (Ordinal Hn)) = (Ordinal Hn') => //; apply: val_inj.
Qed.

End LinearSystem.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW.Utils Require Import utils.
From Undecidability.Shared.Libs.DLW.Code Require Import subcode sss compiler.

Import ListNotations.

(* ** Semantic Correctness of Compiled Code *)

Set Implicit Arguments.
Set Default Goal Selector "!".

Section comp.

  (* This is an abstract proof of compiler soundness & completeness

      The principle of this compiler is to map every source individual
      instruction into a list of target instructions that simulate the
      source instruction. We describe our assumptions later on ...

    *)

  Variable (X Y : Set)                                  (* X is a small type of source instructions and
                                                           Y of destination instructions *)
           (icomp : (nat -> nat) -> nat -> X -> list Y) (* instruction compiler w.r.t. a given linker & a position
                                                           icomp lnk i x compiles instruction x at position i
                                                           using linker lnk into a list of target instructions
                                                         *)
           (ilen  : X -> nat)                           (* compiled code length does not depend on linker or position,
                                                           it only depends on the original instruction
                                                           whether this assumption is strong or not is debatable
                                                           but we only encountered cases which satisfy this assuption
                                                         *)
           (Hilen : forall lnk n x, length (icomp lnk n x) = ilen x)
           (*Hilen2  : forall x, 1 <= ilen x*).           (* compiled code should not be empty, even if the source
                                                           instruction is something like NO-OP, to ensure progress
                                                           in the simulation as source code executes
                                                           also not a strong requirement

                                                           This can be removed because it can be deduced (where it
                                                           is used) from Hilen & step_X_tot & Hicomp
                                                         *)

  (* Semantics for X and Y instructions *)

  Variables (state_X state_Y : Type)
            (step_X : X -> (nat*state_X) -> (nat*state_X) -> Prop)
            (step_Y : Y -> (nat*state_Y) -> (nat*state_Y) -> Prop).

  Notation "ρ '/X/' s -1> t" := (step_X ρ s t) (at level 70, no associativity).
  Notation "P '/X/' s '-[' k ']->' t" := (sss_steps step_X P k s t) (at level 70, no associativity).
  Notation "P '/X/' s '-+>' t" := (sss_progress step_X P s t) (at level 70, no associativity).
  Notation "P '/X/' s ->> t" := (sss_compute step_X P s t) (at level 70, no associativity).
  Notation "P '/X/' s '~~>' t" := (sss_output step_X P s t) (at level 70, no associativity).
  Notation "P '/X/' s ↓" := (sss_terminates step_X P s)(at level 70, no associativity).

  Notation "ρ '/Y/' s -1> t" := (step_Y ρ s t) (at level 70, no associativity).
  Notation "P '/Y/' s '-[' k ']->' t" := (sss_steps step_Y P k s t) (at level 70, no associativity).
  Notation "P '/Y/' s '-+>' t" := (sss_progress step_Y P s t) (at level 70, no associativity).
  Notation "P '/Y/' s ->> t" := (sss_compute step_Y P s t) (at level 70, no associativity).
  Notation "P '/Y/' s '~~>' t" := (sss_output step_Y P s t) (at level 70, no associativity).
  Notation "P '/Y/' s ↓" := (sss_terminates step_Y P s)(at level 70, no associativity).

  (* We assume totality of X semantics, i.e. no instruction can block the computation
      and functionality of Y semantics

      Totality is not necessary achieved ... think of a HALT instruction
      what should we do in that case ? It should not be too difficult to
      embed a partial model of computation into a total one by transforming
      blocking cases into jumps at a PC value outside of the code.
    *)

  Hypothesis (step_X_tot : forall I st1, exists st2, I /X/ st1 -1> st2)
             (step_Y_fun : forall I st st1 st2, I /Y/ st -1> st1 -> I /Y/ st -1> st2 -> st1 = st2).

 (* simul is an invariant: simul st_X st_Y means that st_X is simulated by st_Y *)

  Variable (simul : state_X -> state_Y -> Prop).

  Infix "⋈" := simul (at level 70, no associativity).

  (* Simulation is preserved by compiled instructions
      this of course ensures the *semantic correctness of
      the compilation of individual instructions*

      Notice the important hypothesis of preservation of the +1
      relative address by the linker otherwise it might not be
      possible to establish the below predicate.

      If the source language involves other relative addresses like
      +2 or +d or -d, the present compiler might have to be substantially
      updated.

      +1 is very likely to be used even implicitly because every instruction
      that does not branch (like INC or PUSH) implicitly jumps at +1 ...
    *)

  Definition instruction_compiler_sound := forall lnk I i1 v1 i2 v2 w1,
                     I /X/ (i1,v1) -1> (i2,v2)
                  -> lnk (1+i1) = length (icomp lnk i1 I) + lnk i1
                  -> v1 ⋈ w1
       -> exists w2, (lnk i1,icomp lnk i1 I) /Y/ (lnk i1,w1) -+> (lnk i2,w2)
                  /\ v2 ⋈ w2.

  Hypothesis Hicomp : instruction_compiler_sound.

  Section correctness.

    (* We assume each instruction in P is compiled in Q according to the individual
        instruction compiler combined with what the linker says for branching.
        This is a *syntactic correctness criterion* for the whole compiled program Q
      *)

    Variables (linker : nat -> nat)
              (P : nat * list X)
              (Q : nat * list Y)
              (HPQ : forall i ρ, (i,[ρ]) <sc P
                              -> (linker i, icomp linker i ρ) <sc Q
                               /\ linker (1+i) = ilen ρ + linker i).

    (* From semantic correctness of individually compiled instructions and
        syntactic correctness of the whole compiled program, we derive
        soundness and completeness of the compiled program Q wrt the
        source program P *)

    Definition compiled_sound := forall i₁ v₁ i₂ v₂ w₁,
                      v₁ ⋈ w₁ /\ P /X/ (i₁,v₁) ->> (i₂,v₂)
        -> exists w₂, v₂ ⋈ w₂ /\ Q /Y/ (linker i₁,w₁) ->> (linker i₂,w₂).

    Theorem compiler_sound : compiled_sound.
    Proof using HPQ Hilen Hicomp.
      intros i1 v1 i2 v2 w1.
      change i1 with (fst (i1,v1)) at 2; change v1 with (snd (i1,v1)) at 1.
      change i2 with (fst (i2,v2)) at 2; change v2 with (snd (i2,v2)) at 2.
      generalize (i1,v1) (i2,v2); clear i1 v1 i2 v2.
      intros st1 st2 (H1 & q & H2); revert H2 w1 H1.
      induction 1 as [ (i1,v1) | q (i1,v1) (i2,v2) st3 H1 H2 IH2]; simpl; intros w1 H0.
      + exists w1; split; auto; exists 0; constructor.
      + destruct H1 as (k & l & I & r & v' & G1 & G2 & G3).
        inversion G2; subst v' i1; clear G2.
        destruct (Hicomp linker) with (1 := G3) (3 := H0)
          as (w2 & G4 & G5).
        * rewrite Hilen; apply HPQ; subst; exists l, r; auto.
        * destruct (IH2 _ G5) as (w3 & G6 & G7).
          exists w3; split; auto.
          apply sss_compute_trans with (2 := G7); simpl.
          apply sss_progress_compute.
          revert G4; apply subcode_sss_progress.
          apply HPQ; subst; exists l, r; auto.
    Qed.

    (* When still inside of P, the computation in Q simulates
       a computation in P *)

    Local Lemma compiler_complete_step p st1 w1 w3 :
           snd st1 ⋈ snd w1
        -> linker (fst st1) = fst w1
        -> in_code (fst st1) P
        -> out_code (fst w3) Q
        -> Q /Y/ w1 -[p]-> w3
        -> exists q st2 w2, snd st2 ⋈ snd w2
                        /\ linker (fst st2) = fst w2
                        /\ P /X/ st1 ->> st2
                        /\ Q /Y/ w2 -[q]-> w3
                        /\ q < p.
    Proof using HPQ Hicomp Hilen step_Y_fun step_X_tot.
      revert st1 w1 w3; intros (i1,v1) (j1,w1) (j3,w3); simpl fst; simpl snd.
      intros H1 H2 H3 H4 H5.
      destruct (in_code_subcode H3) as (I & HI).
      destruct HPQ with (1 := HI) as (H6 & H7).
      assert (out_code j3 (linker i1, icomp linker i1 I)) as G2.
      { revert H4; apply subcode_out_code; auto. }
      assert (H8 : ilen I <> 0).
      { intros H.
        destruct (step_X_tot I (i1,v1)) as ((i2,v2) & Hst).
        apply (Hicomp linker) with (3 := H1) in Hst; auto.
        2: rewrite Hilen; auto.
        destruct Hst as (w2 & (q & Hq1 & Hq2) & _).
        rewrite <- (Hilen linker i1) in H.
        destruct (icomp linker i1 I); try discriminate.
        apply sss_steps_stall, proj1 in Hq2; simpl; lia. }
      assert (in_code (linker i1) (linker i1, icomp linker i1 I)) as G3.
      { simpl; rewrite (Hilen linker i1 I); lia. }
      rewrite <- H2 in H5.
      destruct (step_X_tot I (i1,v1)) as ((i2,v2) & G4).
      destruct (Hicomp linker) with (1 := G4) (3 := H1) as (w2 & G5 & G6).
      * rewrite H7, Hilen; auto.
      * apply subcode_sss_progress_inv with (3 := H6) (4 := G5) in H5; auto.
        destruct H5 as (q & H5 & G7).
        exists q, (i2,v2), (linker i2, w2); simpl; repeat (split; auto).
        apply subcode_sss_compute with (1 := HI).
        exists 1; apply sss_steps_1.
        exists i1, nil, I, nil, v1; repeat (split; auto).
        f_equal; simpl; lia.
    Qed.

    (* Termination in Q simulates termination in P *)

    Theorem compiler_complete i1 v1 w1 :
          v1 ⋈ w1 -> Q /Y/ (linker i1,w1) ↓ -> P /X/ (i1,v1) ↓.
    Proof using HPQ Hicomp Hilen step_Y_fun step_X_tot.
      intros H1 (st & (q & H2) & H3).
      revert i1 v1 w1 H1 H2 H3.
      induction q as [ q IHq ] using (well_founded_induction lt_wf).
      intros i1 v1 w1 H1 H2 H3.
      destruct (in_out_code_dec i1 P) as [ H4 | H4 ].
      + destruct compiler_complete_step with (5 := H2) (st1 := (i1,v1))
          as (p & (i2,v2) & (j2,w2) & G1 & G2 & G3 & G4 & G5); auto; simpl in *; subst j2.
        destruct IHq with (1 := G5) (2 := G1) (3 := G4)
          as ((i3 & v3) & F3 & F4); auto.
        exists (i3,v3); repeat (split; auto).
        apply sss_compute_trans with (1 := G3); auto.
      + exists (i1,v1); repeat (split; auto).
        exists 0; constructor.
    Qed.

    Corollary compiler_complete' : forall i₁ v₁ w₁ st,
                            v₁ ⋈ w₁ /\ Q /Y/ (linker i₁,w₁) ~~> st
        -> exists i₂ v₂ w₂, v₂ ⋈ w₂ /\ P /X/ (i₁,v₁) ~~> (i₂,v₂)
                                    /\ Q /Y/ (linker i₂,w₂) ~~> st.
    Proof using HPQ Hicomp Hilen step_Y_fun step_X_tot.
      intros i1 v1 w1 st (H1 & H2).
      destruct compiler_complete with (1 := H1) (2 := ex_intro (fun x => Q /Y/ (linker i1, w1) ~~> x) _ H2)
        as ((i2,v2) & H3 & H4).
      exists i2, v2.
      destruct (compiler_sound (conj H1 H3)) as (w2 & H5 & H6).
      exists w2; do 2 (split; auto).
      1: split; auto.
      destruct H2 as (H2 & H0); split; auto.
      apply sss_compute_inv with (3 := H6); auto.
    Qed.

    Definition compiled_complete := forall i₁ v₁ w₁ j₂ w₂,
                         v₁ ⋈ w₁ /\ Q /Y/ (linker i₁,w₁) ~~> (j₂,w₂)
        -> exists i₂ v₂, v₂ ⋈ w₂ /\ P /X/ (i₁,v₁) ~~> (i₂,v₂) /\ j₂ = linker i₂.

  End correctness.

  Record compiler_t := MkGenComp {
    gc_link     : (nat*list X) -> nat -> nat -> nat;
    gc_code     : (nat*list X) -> nat -> list Y;
    gc_fst      : forall P i, gc_link P i (fst P) = i;
    gc_out      : forall P i j, out_code j P -> gc_link P i j = code_end (i,gc_code P i);
    gc_sound    : forall P i, compiled_sound (gc_link P i) P (i,gc_code P i);
    gc_complete : forall P i, compiled_complete (gc_link P i) P (i,gc_code P i);
  }.

  Section compiler.

    (* We build a compiler *)

    Implicit Type P : nat*list X.

    Let err P iQ  := iQ+length_compiler ilen (snd P).
    Let link P iQ := linker ilen P iQ (err P iQ).
    Let code P iQ := compiler icomp ilen P iQ (err P iQ).

    Local Fact fst_ok : forall P i, link P i (fst P) = i.
    Proof. intros [] ?; apply linker_code_start. Qed.

    Local Fact out_ok : forall P i j, out_code j P -> link P i j = code_end(i,code P i).
    Proof using Hilen.
      intros (iP,cP) iQ j H.
      unfold link, code_end.
      rewrite linker_out_err; unfold err; simpl; auto.
      * unfold code; rewrite compiler_length; auto.
      * lia.
    Qed.

    Local Fact sound : forall P i, compiled_sound (link P i) P (i,code P i).
    Proof using Hilen Hicomp.
      intros (iP,cP) iQ; apply compiler_sound.
      intros; apply compiler_subcode; auto.
    Qed.

    Local Fact complete : forall P i, compiled_complete (link P i) P (i,code P i).
    Proof using Hilen Hicomp step_Y_fun step_X_tot.
      intros (iP,cP) iQ; unfold link, code.
      intros i1 v1 w1 j2 w2 H1.
      destruct compiler_complete' with (2 := H1) (P := (iP,cP))
        as (i2 & v2 & w2' & H2 & H3 & H4 & H5); auto.
      + intros; apply compiler_subcode; auto.
      + exists i2, v2.
        match type of H4 with _ /Y/ (?a,?b) ->> (?c,?d) => assert (a = c /\ b = d) as E end.
        1:{ apply sss_compute_stop in H4.
            * inversion H4; auto.
            * simpl fst.
              apply linker_out_code; auto.
              - right; unfold err; lia.
              - apply H3. }
        destruct E as [ E -> ]; auto.
    Qed.

    Hint Resolve fst_ok out_ok sound complete : core.

    Theorem generic_compiler : compiler_t.
    Proof using Hilen Hicomp step_Y_fun step_X_tot.
      exists link code; auto.
    Defined.

  End compiler.

  Theorem compiler_t_output_sound c P i i₁ v₁ i₂ v₂ w₁ :
                    v₁ ⋈ w₁ /\ P /X/ (i₁,v₁) ~~> (i₂,v₂)
      -> exists w₂, v₂ ⋈ w₂ /\ (i,gc_code c P i) /Y/ (gc_link c P i i₁,w₁) ~~> (gc_link c P i i₂,w₂).
  Proof using .
    destruct c as [ lnk code first out sound complete ]; simpl.
    intros (H1 & H2 & H3).
    destruct (sound P i i₁ v₁ i₂ v₂ w₁) as (w2 & H4 & H5); auto.
    exists w2; split; auto; split; auto.
    apply out with (i := i) in H3.
    unfold fst in H3 |- *.
    rewrite H3; right; simpl; lia.
  Qed.

  Theorem compiler_t_output_sound' c P i v w i' v' :
              v ⋈ w
           -> P /X/ (fst P,v) ~~> (i',v')
           -> exists w', (i,gc_code c P i) /Y/ (i,w) ~~> (code_end (i,gc_code c P i),w')
                       /\ v' ⋈ w'.
  Proof using .
    intros H H1.
    destruct (@compiler_t_output_sound c P i) with (1 := conj H H1) as (w1 & H2 & H3).
    exists w1; split; auto.
    rewrite gc_fst, gc_out in H3; auto.
    apply H1.
  Qed.

  Theorem compiler_t_term_correct (c : compiler_t) P i j v w :
         v ⋈ w -> P /X/ (j,v) ↓ <-> (i,gc_code c P i) /Y/ (gc_link c P i j,w) ↓.
  Proof using .
    destruct c as [ lnk code first out sound complete ]; simpl.
    intros H; split.
    + intros ((j',v') & H1 & H2).
      destruct sound with (1 := conj H H1) (i := i)
        as (w' & H3 & H4).
      exists (lnk P i j', w'); split; auto.
      simpl fst in H2 |- *; rewrite out; simpl; auto.
    + intros ((j',w') & H1).
      unfold compiled_complete in complete.
      generalize (conj H H1); intros H2.
      apply complete in H2 as (i' & v' & H3 & H4 & H5).
      exists (i',v'); auto.
  Qed.

  Theorem compiler_t_term_equiv (c : compiler_t) P i v w :
         v ⋈ w -> P /X/ (fst P,v) ↓ <-> (i,gc_code c P i) /Y/ (i,w) ↓.
  Proof using .
    rewrite <- (gc_fst c P i) at 3.
    apply compiler_t_term_correct.
  Qed.

End comp.

Section compiler_t_simul_equiv.

  Variables (X Y : Set) (state_X state_Y : Type)
            (step_X : X -> (nat*state_X) -> (nat*state_X) -> Prop)
            (step_Y : Y -> (nat*state_Y) -> (nat*state_Y) -> Prop)
            (sim1 sim2 : state_X -> state_Y -> Prop).

  Theorem compiler_t_simul_equiv :
            (forall x y, sim1 x y <-> sim2 x y)
         -> compiler_t step_X step_Y sim1
         -> compiler_t step_X step_Y sim2.
  Proof.
    intros E [ gc_link gc_code gc_fst gc_out gc_sound gc_complete ].
    exists gc_link gc_code; auto.
    + intros P i i1 v1 i2 v2 w1 H1.
      rewrite <- E in H1.
      apply (gc_sound _ i) in H1 as (w2 & ?).
      now exists w2; rewrite <- E.
    + intros P i i1 v1 w1 j2 w2 H1.
      rewrite <- E in H1.
      apply (gc_complete _ i) in H1 as (i2 & v2 & ?).
      now exists i2, v2; rewrite <- E.
  Qed.

End compiler_t_simul_equiv.