(******************************************************************************)
(*   Copyright (c) 2019--2022 - Paulo Torrens <paulotorrens AT gnu DOT org>   *)
(******************************************************************************)

Set Implicit Arguments.
Require Import Arith.
Require Import Equality.
Require Export Relations.
Require Import Local.Prelude.

(** ** Relations *)

Notation "'r(' R )" := (clos_refl _ R)
  (format "'r(' R )"): type_scope.

Notation "'t(' R )" := (clos_trans _ R)
  (format "'t(' R )"): type_scope.

Notation "'rt(' R )" := (clos_refl_trans _ R)
  (format "'rt(' R )"): type_scope.

Notation "'rst(' R )" := (clos_refl_sym_trans _ R)
  (format "'rst(' R )"): type_scope.

Global Hint Constructors clos_refl: cps.
Global Hint Constructors clos_trans: cps.
Global Hint Constructors clos_refl_trans: cps.
Global Hint Constructors clos_refl_sym_trans: cps.

Arguments transp {A}.

Global Hint Unfold transp: cps.

Arguments union {A}.

Global Hint Unfold union: cps.

Arguments same_relation {A}.

Global Hint Unfold same_relation: cps.

Arguments inclusion {A}.

Global Hint Unfold inclusion: cps.

Arguments reflexive {A}.

Global Hint Unfold reflexive: cps.

Arguments symmetric {A}.

Global Hint Unfold symmetric: cps.

Arguments transitive {A}.

Global Hint Unfold transitive: cps.

Arguments equivalence {A}.

Global Hint Resolve equiv_refl: cps.
Global Hint Resolve equiv_sym: cps.
Global Hint Resolve equiv_trans: cps.
Global Hint Constructors equivalence: cps.

Definition commutes {T} (R: relation T) (S: relation T): Prop :=
  forall x y,
  R x y ->
  forall z,
  S x z ->
  exists2 w,
  S y w & R z w.

Global Hint Unfold commutes: cps.

Definition diamond {T} R: Prop :=
  @commutes T R R.

Global Hint Unfold diamond: cps.

Definition comp {A} {B} {C} R S: A -> C -> Prop :=
  fun a c =>
    exists2 b: B,
    R a b & S b c.

Global Hint Unfold comp: cps.

Section Relations.

  Variable T: Type.
  Variable R: relation T.

  Lemma clos_t_clos_rt:
    inclusion t(R) rt(R).
  Proof.
    induction 1; eauto with cps.
  Qed.

  Hint Resolve clos_t_clos_rt: cps.

  Lemma rt_characterization:
    same_relation rt(R) r(t(R)).
  Proof.
    unfold same_relation, inclusion; split; intros.
    - induction H.
      + eauto with cps.
      + eauto with cps.
      + destruct IHclos_refl_trans1;
        destruct IHclos_refl_trans2;
        eauto with cps.
    - destruct H; eauto with cps.
  Qed.

  Lemma r_and_t_closures_commute:
    same_relation r(t(R)) t(r(R)).
  Proof.
    split; intros x y ?.
    - destruct H.
      + induction H; eauto with cps.
      + auto with cps.
    - induction H.
      + destruct H; auto with cps.
      + destruct IHclos_trans1; destruct IHclos_trans2; eauto with cps.
  Qed.

  Lemma rt_unequal_implies_t:
    forall a b,
    a <> b ->
    rt(R) a b -> t(R) a b.
  Proof.
    intros.
    apply rt_characterization in H0.
    destruct H0.
    - assumption.
    - exfalso.
      contradiction.
  Qed.

  Inductive clos_trans_cnt: nat -> relation T :=
    | tc_step x y:
      R x y -> clos_trans_cnt 1 x y
    | tc_trans x y z n m:
      clos_trans_cnt n x y ->
      clos_trans_cnt m y z ->
      clos_trans_cnt (n + m) x z.

  (*
  Inductive clos_trans_1n_cnt: nat -> relation T :=
    | t1nc_step x y:
      R x y ->
      clos_trans_1n_cnt 1 x y
    | t1nc_trans x y z n:
      R x y ->
      clos_trans_1n_cnt n y z ->
      clos_trans_1n_cnt (S n) x z.

  Inductive clos_trans_n1_cnt: nat -> relation T :=
    | tn1c_step x y:
      R x y ->
      clos_trans_n1_cnt 1 x y
    | tn1c_trans x y z n:
      R y z ->
      clos_trans_n1_cnt n x y ->
      clos_trans_n1_cnt (S n) x z.
  *)

  Lemma clos_trans_trans_cnt_iff:
    forall a b,
    t(R) a b <-> (exists n, clos_trans_cnt n a b).
  Proof.
    split; intros.
    - induction H.
      + exists 1.
        constructor; auto.
      + destruct IHclos_trans1 as (n, ?H).
        destruct IHclos_trans2 as (m, ?H).
        exists (n + m).
        econstructor 2; eauto.
    - destruct H.
      induction H.
      + constructor; auto.
      + econstructor 2; eauto.
  Qed.

  (*
  Lemma clos_t1n_trans_cnt:
    forall n x y,
    clos_trans_1n_cnt n x y -> clos_trans_cnt n x y.
  Proof.
    induction 1.
    - constructor; auto.
    - replace (S n) with (1 + n); auto.
      econstructor 2.
      + constructor; eauto.
      + assumption.
  Qed.

  Lemma clos_trans_t1n_cnt:
    forall n x y,
    clos_trans_cnt n x y -> clos_trans_1n_cnt n x y.
  Proof.
    induction 1.
    - constructor; auto.
    - clear H H0.
      generalize dependent m.
      induction IHclos_trans_cnt1; intros.
      + econstructor 2; eauto.
      + replace (S n + m) with (1 + (n + m)); auto.
        econstructor 2; eauto.
  Qed.

  Lemma clos_trans_t1n_cnt_iff:
    forall n x y,
    clos_trans_cnt n x y <-> clos_trans_1n_cnt n x y.
  Proof.
    split.
    - apply clos_trans_t1n_cnt.
    - apply clos_t1n_trans_cnt.
  Qed.

  Lemma clos_tn1_trans_cnt:
    forall n x y,
    clos_trans_n1_cnt n x y -> clos_trans_cnt n x y.
  Proof.
    induction 1.
    - constructor; auto.
    - replace (S n) with (1 + n); auto.
      replace (1 + n) with (n + 1); auto with arith.
      econstructor 2.
      + eassumption.
      + constructor; auto.
  Qed.

  Lemma clos_trans_tn1_cnt:
    forall n x y,
    clos_trans_cnt n x y -> clos_trans_n1_cnt n x y.
  Proof.
    induction 1.
    - constructor; auto.
    - clear H H0.
      generalize dependent n.
      induction IHclos_trans_cnt2; intros.
      + rewrite Nat.add_comm.
        econstructor 2; eauto.
      + rename n0 into m.
        replace (m + S n) with (1 + (m + n)); auto with arith.
        econstructor 2; eauto.
  Qed.

  Lemma clos_trans_tn1_cnt_iff:
    forall n x y,
    clos_trans_cnt n x y <-> clos_trans_n1_cnt n x y.
  Proof.
    split.
    - apply clos_trans_tn1_cnt.
    - apply clos_tn1_trans_cnt.
  Qed.

  Goal
    forall P: nat -> T -> T -> Prop,
    (forall x y, R x y -> P 1 x y) ->
    (forall x y z n,
       R x y -> clos_trans_cnt n y z -> P n y z -> P (S n) x z) ->
    forall n x y,
    clos_trans_cnt n x y -> P n x y.
  Proof.
    intros.
    apply clos_trans_t1n_cnt_iff in H1.
    induction H1.
    - apply H.
      assumption.
    - eapply H0.
      + eassumption.
      + apply clos_trans_t1n_cnt_iff in H2.
        assumption.
      + assumption.
  Qed.

  Goal
    forall P : nat -> T -> T -> Prop,
    (forall x y, R x y -> P 1 x y) ->
    (forall x y z n,
       R y z -> clos_trans_cnt n x y -> P n x y -> P (S n) x z) ->
    forall n x y,
    clos_trans_cnt n x y -> P n x y.
  Proof.
    intros.
    apply clos_trans_tn1_cnt_iff in H1.
    induction H1.
    - apply H.
      assumption.
    - eapply H0.
      + eassumption.
      + apply clos_trans_tn1_cnt_iff in H2.
        assumption.
      + assumption.
  Qed.
  *)

End Relations.

Section Confluency.

  Variable T: Type.

  Lemma strip_lemma:
    forall R: relation T,
    forall S: relation T,
    commutes R S -> commutes t(R) S.
  Proof.
    induction 2; intros.
    (* Case: step. *)
    - destruct H with x y z as (w, ?, ?); auto.
      exists w; auto with cps.
    (* Case: trans. *)
    - rename z0 into w.
      destruct IHclos_trans1 with w as (v, ?, ?); auto.
      destruct IHclos_trans2 with v as (u, ?, ?); auto.
      exists u; eauto with cps.
  Qed.

  Lemma transitive_closure_preserves_commutation:
    forall R: relation T,
    forall S: relation T,
    commutes R S -> commutes t(R) t(S).
  Proof.
    induction 2; intros.
    (* Case: step. *)
    - destruct strip_lemma with S R x z y as (w, ?, ?).
      + intros a b ? c ?.
        destruct H with a c b as (d, ?, ?); auto.
        exists d; auto.
      + assumption.
      + assumption.
      + exists w; auto with cps.
    (* Case: trans. *)
    - rename z0 into w.
      destruct IHclos_trans1 with w as (v, ?, ?); auto.
      destruct IHclos_trans2 with v as (u, ?, ?); auto.
      exists u; eauto with cps.
  Qed.

  Lemma reflexive_closure_preserves_commutation:
    forall R: relation T,
    forall S: relation T,
    commutes R S -> commutes r(R) r(S).
  Proof.
    intros R S ? x y ? z ?.
    destruct H0; destruct H1.
    - rename y0 into z.
      destruct H with x y z as (w, ?, ?); auto.
      exists w; auto with cps.
    - exists y; auto with cps.
    - exists y; auto with cps.
    - exists x; auto with cps.
  Qed.

  Variable R: relation T.

  Definition confluent: Prop :=
    diamond rt(R).

  Definition church_rosser: Prop :=
    forall x y,
    rst(R) x y ->
    exists2 z,
    rt(R) x z & rt(R) y z.

  Lemma confluence_implies_church_rosser:
    confluent -> church_rosser.
  Proof.
    induction 2.
    (* Case: step. *)
    - exists y; auto with cps.
    (* Case: refl. *)
    - exists x; auto with cps.
    (* Case: sym. *)
    - destruct IHclos_refl_sym_trans as (z, ?, ?).
      exists z; auto.
    (* Case: trans. *)
    - destruct IHclos_refl_sym_trans1 as (w, ?, ?).
      destruct IHclos_refl_sym_trans2 as (v, ?, ?).
      destruct H with y w v as (u, ?, ?); auto with cps.
      exists u; eauto with cps.
  Qed.

End Confluency.

Section HindleyRosen.

  Variable T: Type.

  Variable R: relation T.
  Variable S: relation T.

  Hypothesis R_is_confluent: confluent R.
  Hypothesis S_is_confluent: confluent S.
  Hypothesis R_and_S_commute: commutes rt(R) rt(S).

  Local Lemma rt_union_characterization:
    same_relation rt(union R S) rt(union rt(R) rt(S)).
  Proof.
    split; induction 1.
    - destruct H; auto with cps.
    - auto with cps.
    - eauto with cps.
    - destruct H.
      + induction H; eauto with cps.
      + induction H; eauto with cps.
    - eauto with cps.
    - eauto with cps.
  Qed.

  Lemma hindley_rosen:
    confluent (union R S).
  Proof.
    (* The proof follows by diagram chasing. *)
    assert (diamond (union rt(R) rt(S))).
    - intros x y ? z ?.
      destruct H; destruct H0.
      + destruct R_is_confluent with x y z as (w, ?, ?); auto.
        exists w; auto with cps.
      + destruct R_and_S_commute with x y z as (w, ?, ?); auto.
        exists w; auto with cps.
      + destruct R_and_S_commute with x z y as (w, ?, ?); auto.
        exists w; auto with cps.
      + destruct S_is_confluent with x y z as (w, ?, ?); auto.
        exists w; auto with cps.
    - apply transitive_closure_preserves_commutation in H.
      apply reflexive_closure_preserves_commutation in H.
      intros x y ? z ?.
      destruct H with x y z as (w, ?, ?).
      + apply rt_characterization.
        apply rt_union_characterization.
        assumption.
      + apply rt_characterization.
        apply rt_union_characterization.
        assumption.
      + exists w.
        * apply rt_union_characterization.
          apply rt_characterization.
          assumption.
        * apply rt_union_characterization.
          apply rt_characterization.
          assumption.
  Qed.

  (* TODO: check if this is the correct name. *)

  Definition strong_commutation: Prop :=
    forall x y,
    R x y ->
    forall z,
    S x z ->
    exists2 w,
    rt(S) y w & r(R) z w.

  Hypothesis strongly_commutes: strong_commutation.

  Local Lemma strong_strip_lemma:
    commutes r(R) rt(S).
  Proof.
    intros x y ? z ?.
    generalize dependent y.
    apply clos_rt_rt1n_iff in H0.
    induction H0; intros.
    - destruct H.
      + exists y; auto with cps.
      + exists x; auto with cps.
    - rename y0 into w.
      destruct H1.
      + rename y0 into w.
        destruct strongly_commutes with x w y as (u, ?, ?); auto.
        destruct IHclos_refl_trans_1n with u as (v, ?, ?); auto.
        exists v; eauto with cps.
      + destruct IHclos_refl_trans_1n with y as (w, ?, ?); auto with cps.
        exists w; eauto with cps.
  Qed.

  Lemma strong_commutation_implies_commutation:
    commutes rt(R) rt(S).
  Proof.
    intros until 1.
    apply clos_rt_rt1n_iff in H.
    induction H; intros.
    - exists z; auto with cps.
    - rename z0 into w.
      destruct strong_strip_lemma with x y w as (u, ?, ?); eauto with cps.
      destruct IHclos_refl_trans_1n with u as (v, ?, ?); auto.
      exists v; destruct H3; eauto with cps.
  Qed.

End HindleyRosen.

Section Normalization.

  Variable T: Type.

  Definition SN (R: relation T) :=
    (Acc (transp R)).

  Variable R: relation T.

  Definition normal a: Prop :=
    forall b, ~R a b.

  Definition WN a: Prop :=
    exists2 b, rt(R) a b & normal b.

  Lemma SN_preimage:
    forall f,
    (forall a b, R a b -> R (f a) (f b)) ->
    forall e,
    SN R (f e) -> SN R e.
  Proof.
    intros.
    (* The dependent induction tactic seems to generalize variables... *)
    remember (f e) as x.
    generalize dependent e.
    induction H0; intros.
    constructor; intros.
    eapply H1; eauto.
    rewrite Heqx.
    apply H.
    assumption.
  Qed.

  Lemma SN_R_t_R:
    forall e,
    SN R e <-> SN t(R) e.
  Proof.
    split; induction 1.
    - clear H.
      constructor; intros.
      induction H.
      + apply H0.
        assumption.
      + apply IHclos_trans2; intros.
        apply IHclos_trans1; auto with cps.
    - clear H.
      constructor; intros.
      apply H0.
      auto with cps.
  Qed.

  Lemma SN_subset:
    forall S,
    inclusion S R ->
    forall e,
    SN R e -> SN S e.
  Proof.
    intros.
    induction H0.
    constructor; intros.
    fold (SN R) in H0; fold (SN S).
    unfold transp in H0, H1, H2.
    apply H1.
    apply H.
    assumption.
  Qed.

End Normalization.

Section ListNormalization.

  Variable T: Type.
  Variable R: relation T.

  Inductive step_in_list: relation (list T) :=
    | step_in_env_car:
      forall g t u,
      R t u -> step_in_list (t :: g) (u :: g)
    | step_in_env_cdr:
      forall g h t,
      step_in_list g h -> step_in_list (t :: g) (t :: h).

  (* Still not sure we'll be needing this, but just in case... *)

  Lemma step_in_list_is_well_founded:
    forall xs,
    Forall (SN R) xs ->
    SN step_in_list xs.
  Proof.
    induction xs; intros.
    (* Case: nil. *)
    - constructor; intros.
      exfalso.
      inversion H0.
    (* Case: cons. *)
    - dependent destruction H.
      apply IHxs in H0; clear IHxs.
      induction H; clear H.
      induction H0.
      constructor; intros.
      unfold transp in H2.
      dependent destruction H2.
      + apply H1.
        assumption.
      + apply H0; intros.
        * assumption.
        * eapply H1; eauto.
          constructor.
          assumption.
  Qed.

End ListNormalization.

Section ObservationalRelations.

  Variable T: Type.
  Variable L: Type.
  Variable C: Type.

  Variable R: relation T.
  Variable P: T -> L -> Prop.

  Hypothesis apply: C -> T -> T.

  Definition observational_equivalence a b: Prop :=
    forall l,
    comp rt(R) P a l <-> comp rt(R) P b l.

  Definition observational_congruence a b: Prop :=
    forall h,
    observational_equivalence (apply h a) (apply h b).

  Lemma observational_equivalence_refl:
    reflexive observational_equivalence.
  Proof.
    firstorder.
  Qed.

  Lemma observational_equivalence_sym:
    symmetric observational_equivalence.
  Proof.
    firstorder.
  Qed.

  Lemma observational_equivalence_trans:
    transitive observational_equivalence.
  Proof.
    split; intros.
    - apply H0; apply H; auto.
    - apply H; apply H0; auto.
  Qed.

  Lemma observational_congruence_refl:
    reflexive observational_congruence.
  Proof.
    intros x h.
    apply observational_equivalence_refl.
  Qed.

  Lemma observational_congruence_sym:
    symmetric observational_congruence.
  Proof.
    intros x y ? h.
    apply observational_equivalence_sym; auto.
  Qed.

  Lemma observational_congruence_trans:
    transitive observational_congruence.
  Proof.
    intros x y z ? ? h.
    eapply observational_equivalence_trans; eauto.
  Qed.

End ObservationalRelations.

(* TODO: move this one. It might be useful, specially for reasoning about extra
   reductions on the call-by-value calculus. *)

Goal
  forall T L,
  forall R S: relation T,
  forall P: T -> L -> Prop,
  inclusion R S ->
  inclusion S (observational_equivalence R P) ->
  same_relation (observational_equivalence R P) (observational_equivalence S P).
Proof.
  intros.
  assert (inclusion rt(S) (observational_equivalence R P)).
  - do 3 intro.
    induction H1.
    + apply H0.
      assumption.
    + apply observational_equivalence_refl.
    + apply observational_equivalence_trans with y; auto.
  - clear H0.
    split; split; intro.
    + destruct H2 as (x', ?, ?).
      assert (comp rt(R) P x' l); eauto with cps.
      apply H1 in H2.
      apply H2 in H4.
      apply H0 in H4.
      destruct H4 as (y', ?, ?).
      exists y'; auto.
      clear H0 H2 H5.
      induction H4; eauto with cps.
    + destruct H2 as (y', ?, ?).
      assert (comp rt(R) P y' l); eauto with cps.
      apply H1 in H2.
      apply H2 in H4.
      apply H0 in H4.
      destruct H4 as (x', ?, ?).
      exists x'; auto.
      clear H0 H2 H5.
      induction H4; eauto with cps.
    + assert (comp rt(S) P x l).
      * destruct H2 as (x', ?, ?).
        exists x'; auto.
        clear H0 H3.
        induction H2; eauto with cps.
      * apply H0 in H3.
        destruct H3 as (y', ?, ?).
        apply H1 in H3.
        apply H3.
        exists y'; auto with cps.
    + assert (comp rt(S) P y l).
      * destruct H2 as (y', ?, ?).
        exists y'; auto.
        clear H0 H3.
        induction H2; eauto with cps.
      * apply H0 in H3.
        destruct H3 as (x', ?, ?).
        apply H1 in H3.
        apply H3.
        exists x'; auto with cps.
Qed.

Section BarbedRelations.

  Variable T: Type.
  Variable L: Type.
  Variable C: Type.

  Variable R: relation T.
  Variable P: T -> L -> Prop.

  Hypothesis apply: C -> T -> T.

  (* Set-theoretic definition of barbed relations. *)

  Definition reduction_closed (S: relation T): Prop :=
    forall a b,
    S a b ->
    forall c,
    R a c ->
    exists2 d,
    rt(R) b d & S c d.

  Definition barb_preserving (S: relation T): Prop :=
    forall a b,
    S a b ->
    forall n,
    P a n -> comp rt(R) P b n.

  Definition barbed_simulation (S: relation T): Prop :=
    reduction_closed S /\ barb_preserving S.

  Definition barbed_bisimulation (S: relation T): Prop :=
    barbed_simulation S /\ barbed_simulation (transp S).

  Definition barbed_bisimilarity a b: Prop :=
    exists2 S, barbed_bisimulation S & S a b.

  Definition barbed_congruence a b: Prop :=
    forall h,
    barbed_bisimilarity (apply h a) (apply h b).

  Lemma symmetric_barbed_simulation_is_bisimulation:
    forall S,
    barbed_simulation S ->
    symmetric S ->
    barbed_bisimulation S.
  Proof.
    intros; split.
    - assumption.
    - destruct H; split.
      + unfold reduction_closed, transp; intros.
        destruct H with a b c; firstorder.
      + unfold barb_preserving, transp; intros.
        firstorder.
  Qed.

  (* TODO: we could fix the type of this definition. *)

  Lemma multistep_reduction_closed:
    forall S,
    reduction_closed S ->
    forall a b,
    S a b ->
    forall c,
    rt(R) a c ->
    exists2 d,
    rt(R) b d & S c d.
  Proof.
    intros.
    generalize b H0; clear b H0.
    induction H1; simpl; intros.
    - eapply H; eauto.
    - exists b; auto with cps.
    - destruct IHclos_refl_trans1 with b as (w, ?, ?); auto.
      destruct IHclos_refl_trans2 with w as (v, ?, ?); auto.
      exists v; eauto with cps.
  Qed.

  Lemma barbed_bisimilarity_refl:
    reflexive barbed_bisimilarity.
  Proof.
    (* We can show that identity is a barbed bisimulation. *)
    exists eq.
    - apply symmetric_barbed_simulation_is_bisimulation.
      + split; do 5 intro.
        * destruct H; eauto with cps.
        * destruct H; eauto with cps.
      + firstorder.
    - reflexivity.
  Qed.

  Lemma barbed_bisimilarity_sym:
    symmetric barbed_bisimilarity.
  Proof.
    (* Since there's a bisimulation S, its inverse is one as well. *)
    destruct 1 as (S, (?, ?), ?).
    exists (transp S); auto.
    firstorder.
  Qed.

  Lemma barbed_bisimilarity_trans:
    transitive barbed_bisimilarity.
  Proof.
    (* Given S1 and S2 that are bisimulations, so is (S1; S2). *)
    destruct 1 as (S1, (?, ?), ?).
    destruct 1 as (S2, (?, ?), ?).
    exists (comp S1 S2).
    - clear x y z H1 H4.
      split; split; do 5 intro.
      + destruct H1 as (d, ?, ?).
        destruct H as (?, _).
        destruct H2 as (?, _).
        destruct H with a d c as (x, ?, ?); auto.
        edestruct multistep_reduction_closed as (y, ?, ?); eauto.
        exists y; auto.
        exists x; auto.
      + destruct H1 as (d, ?, ?).
        destruct H as (_, ?).
        destruct H2 as (?, ?).
        destruct H with a d n as (x, ?, ?); auto.
        edestruct multistep_reduction_closed as (y, ?, ?); eauto.
        destruct H6 with x y n as (z, ?, ?); auto.
        exists z; eauto with cps.
      + destruct H1 as (d, ?, ?).
        destruct H0 as (?, _).
        destruct H3 as (?, _).
        destruct H3 with a d c as (x, ?, ?); auto.
        edestruct multistep_reduction_closed with (S := transp S1) as (y, ?, ?);
          eauto.
        exists y; auto.
        exists x; auto.
      + destruct H1 as (d, ?, ?).
        destruct H0 as (?, ?).
        destruct H3 as (_, ?).
        destruct H3 with a d n as (x, ?, ?); auto.
        edestruct multistep_reduction_closed with (S := transp S1) as (y, ?, ?);
          eauto.
        destruct H6 with x y n as (z, ?, ?); auto.
        exists z; eauto with cps.
    - exists y; auto.
  Qed.

  Lemma barbed_bisimilarity_is_a_bisimulation:
    barbed_bisimulation barbed_bisimilarity.
  Proof.
    apply symmetric_barbed_simulation_is_bisimulation.
    - split; do 5 intro.
      + destruct H as (S, ((?, ?), ?), ?).
        destruct H with a b c as (d, ?, ?); auto.
        firstorder.
      + destruct H as (S, ((?, ?), ?), ?).
        firstorder.
    - apply barbed_bisimilarity_sym.
  Qed.

  Lemma barbed_congruence_refl:
    reflexive barbed_congruence.
  Proof.
    intros x h.
    apply barbed_bisimilarity_refl.
  Qed.

  Lemma barbed_congruence_sym:
    symmetric barbed_congruence.
  Proof.
    intros x y ? h.
    apply barbed_bisimilarity_sym; auto.
  Qed.

  Lemma barbed_congruence_trans:
    transitive barbed_congruence.
  Proof.
    intros x y z ? ? h.
    eapply barbed_bisimilarity_trans; eauto.
  Qed.

  Goal
    inclusion barbed_bisimilarity (observational_equivalence R P).
  Proof.
    intros x y ?H l; split; intros.
    - destruct H as (S, ((?, ?), _), ?).
      destruct H0 as (z, ?, ?).
      destruct multistep_reduction_closed with S x y z as (w, ?, ?); auto.
      destruct H1 with z w l as (v, ?, ?); auto.
      exists v; eauto with cps.
    - destruct H as (S, (_, (?, ?)), ?).
      destruct H0 as (z, ?, ?).
      destruct multistep_reduction_closed with (transp S) y x z as (w, ?, ?);
        auto.
      destruct H1 with z w l as (v, ?, ?); auto.
      exists v; eauto with cps.
  Qed.

  Goal
    confluent R ->
    barb_preserving rt(R) ->
    barbed_bisimulation (observational_equivalence R P).
  Proof.
    unfold inclusion; intros.
    apply symmetric_barbed_simulation_is_bisimulation.
    - split; do 5 intro.
      + exists b; auto with cps.
        split; intro.
        * apply H1.
          destruct H3.
          destruct H with a x c as (y, ?, ?); eauto with cps.
        * apply H1 in H3.
          destruct H3 as (x, ?, ?).
          destruct H with a x c as (y, ?, ?); eauto with cps.
          destruct H0 with x y l as (w, ?, ?); eauto.
          exists w; eauto with cps.
      + apply H1.
        eauto with cps.
    - apply observational_equivalence_sym.
  Qed.

End BarbedRelations.

Section WeakBisimulation.

  Variable T: Type.
  Variable L: Type.

  Variable R: L -> relation T.

  Variable tau: L.

  Hypothesis is_tau_dec: forall l, { l = tau } + { l <> tau }.

  Definition weak_transition (l: L): relation T :=
    if is_tau_dec l then
      rt(R tau)
    else
      comp rt(R tau) (R l).

  Definition simulation (S: relation T): Prop :=
    forall a b,
    S a b ->
    forall c l,
    R l a c ->
    exists2 d,
    weak_transition l b d & S c d.

  Definition bisimulation (S: relation T): Prop :=
    simulation S /\ simulation (transp S).

  Definition bisimilarity a b: Prop :=
    exists2 S, bisimulation S & S a b.

  Lemma weak_transition_immediate:
    forall l,
    inclusion (R l) (weak_transition l).
  Proof.
    intros l a b ?H.
    unfold weak_transition.
    destruct is_tau_dec with l.
    - destruct e; auto with cps.
    - exists a; auto with cps.
  Qed.

  Lemma symmetric_simulation_is_bisimulation:
    forall S,
    simulation S ->
    symmetric S ->
    bisimulation S.
  Proof.
    split.
    - assumption.
    - do 6 intro.
      destruct H with a b c l as (d, ?, ?); auto.
      exists d; firstorder.
  Qed.

  Lemma weak_transition_silent:
    forall l,
    l = tau ->
    weak_transition l = rt(R tau).
  Proof.
    unfold weak_transition; intros.
    destruct is_tau_dec with l.
    - reflexivity.
    - firstorder.
  Qed.

  Lemma weak_transition_nonsilent:
    forall l,
    l <> tau ->
    weak_transition l = comp rt(R tau) (R l).
  Proof.
    intros.
    unfold weak_transition.
    destruct is_tau_dec with l.
    - firstorder.
    - reflexivity.
  Qed.

  Lemma weak_transition_closed:
    forall S,
    simulation S ->
    forall a b,
    S a b ->
    forall c l,
    weak_transition l a c ->
    exists2 d,
    weak_transition l b d & S c d.
  Proof.
    intros until l.
    assert (forall c, rt(R tau) a c ->
      exists2 d, rt(R tau) b d & S c d).
    - clear c; intros.
      generalize dependent b.
      induction H1; intros.
      + destruct H with x b y tau as (z, ?, ?); auto.
        rewrite weak_transition_silent in H2; auto.
        exists z; eauto.
      + exists b; auto with cps.
      + edestruct IHclos_refl_trans1 as (w, ?, ?); eauto.
        edestruct IHclos_refl_trans2 as (v, ?, ?); eauto.
        exists v; eauto with cps.
    - unfold weak_transition.
      destruct is_tau_dec with l; intros.
      + eapply H1; eauto.
      + destruct H2 as (d, ?, ?).
        edestruct H1 as (x, ?, ?); eauto.
        destruct H with d x c l as (y, ?, ?); eauto.
        rewrite weak_transition_nonsilent in H6; auto.
        destruct H6 as (z, ?, ?).
        exists y; auto.
        exists z; eauto with cps.
  Qed.

  Lemma bisimilarity_refl:
    reflexive bisimilarity.
  Proof.
    (* Same reasoning as for reflexivity on the barbed bisimilarity above. *)
    exists eq; auto.
    split; do 6 intro.
    - destruct H.
      exists c; auto.
      apply weak_transition_immediate; auto.
    - destruct H.
      exists c; auto with cps.
      apply weak_transition_immediate; auto.
  Qed.

  Lemma bisimilarity_sym:
    symmetric bisimilarity.
  Proof.
    (* Same reasoning as for symmetry on the barbed bisimilarity above. *)
    destruct 1 as (S, ?, ?).
    exists (transp S); auto.
    firstorder.
  Qed.

  Lemma bisimilarity_trans:
    transitive bisimilarity.
  Proof.
    (* Same reasoning as for transitivity on the barbed bisimilarity above. *)
    destruct 1 as (S1, (?, ?), ?).
    destruct 1 as (S2, (?, ?), ?).
    exists (comp S1 S2).
    - split; do 6 intro.
      + destruct H5 as (d, ?, ?).
        destruct H with a d c l as (w, ?, ?); auto.
        destruct weak_transition_closed with S2 d b w l as (v, ?, ?); auto.
        exists v; auto.
        exists w; auto.
      + destruct H5 as (d, ?, ?).
        destruct H3 with a d c l as (w, ?, ?); auto.
        destruct weak_transition_closed with (transp S1) d b w l as (v, ?, ?);
          auto.
        exists v; auto.
        exists w; auto.
    - exists y; auto.
  Qed.

  Lemma bisimilarity_is_a_bisimulation:
    bisimulation bisimilarity.
  Proof.
    apply symmetric_simulation_is_bisimulation.
    - do 6 intro.
      destruct H as (S, (?, ?), ?).
      destruct H with a b c l as (d, ?, ?); auto.
      exists d; auto.
      firstorder.
    - apply bisimilarity_sym.
  Qed.

End WeakBisimulation.

Section StrongBisimulation.

  Variable T: Type.
  Variable L: Type.

  Variable R: L -> relation T.

  Definition strong_simulation (S: relation T): Prop :=
    forall a b,
    S a b ->
    forall c l,
    R l a c ->
    exists2 d,
    R l b d & S c d.

  Goal
    forall S,
    strong_simulation S <-> (forall l, commutes (R l) S).
  Proof.
    split; intros.
    - intros x y ? z ?.
      destruct H with x z y l as (w, ?, ?); auto.
      exists w; auto.
    - intros x y ? z l ?.
      destruct H with l x z y as (w, ?, ?); auto.
      exists w; auto.
  Qed.

  Definition strong_bisimulation (S: relation T): Prop :=
    strong_simulation S /\ strong_simulation (transp S).

  (* TODO: take a look at the definitions below. *)

  Variable l: L.
  Variable S: relation T.

  Hypothesis S_is_bisim: strong_bisimulation S.

  Goal
    forall a1 b1,
    rst(S) a1 b1 ->
    (exists a2, R l a1 a2) <-> (exists b2, R l b1 b2).
  Proof.
    induction 1.
    - split; intros.
      + destruct H0 as (a2, ?H).
        destruct S_is_bisim.
        edestruct H1; eauto.
      + destruct H0 as (b2, ?H).
        destruct S_is_bisim.
        edestruct H2; eauto.
    - firstorder.
    - firstorder.
    - firstorder.
  Qed.

  Goal
    forall x y,
    S x y ->
    forall n z,
    clos_trans_cnt (R l) n x z ->
    exists2 w,
    clos_trans_cnt (R l) n y w & S z w.
  Proof.
    intros.
    generalize dependent y.
    induction H0; intros.
    - rename y0 into y, y into z.
      destruct S_is_bisim as ((w, ?, ?), _).
      + eassumption.
      + eassumption.
      + exists w; auto.
        constructor; auto.
    - rename y0 into a.
      edestruct IHclos_trans_cnt1 as (b, ?, ?); eauto.
      edestruct IHclos_trans_cnt2 as (w, ?, ?); eauto.
      exists w; auto.
      econstructor 2; eauto.
  Qed.

  Goal
    forall x y,
    S x y ->
    SN (R l) x <-> SN (R l) y.
  Proof.
    split; intros.
    - generalize dependent y.
      induction H0; intros.
      constructor; intros w ?H.
      fold (SN (R l)) in H |- *.
      unfold transp in H, H0, H2.
      destruct S_is_bisim as (_, (a, ?, ?)).
      + eassumption.
      + eassumption.
      + eapply H0; eauto.
    - generalize dependent x.
      induction H0; intros.
      constructor; intros w ?H.
      fold (SN (R l)) in H |- *.
      unfold transp in H, H0, H2.
      destruct S_is_bisim as ((a, ?, ?), _).
      + eassumption.
      + eassumption.
      + eapply H0; eauto.
  Qed.

End StrongBisimulation.

Section Modulo.

  Variable T: Type.

  Variable R: relation T.
  Variable S: relation T.

  Definition modulo: relation T :=
    fun a d =>
      exists b c,
      S a b /\ R b c /\ S c d.

  Hint Unfold modulo: cps.

  Hypothesis S_is_equiv: equivalence S.
  Hypothesis S_is_bisimulation: strong_bisimulation (fun _: unit => R) S.

  Lemma modulo_bisimulation_postponement:
    same_relation t(modulo) (comp t(R) S).
  Proof.
    destruct S_is_equiv.
    split; intros x y ?.
    - apply clos_trans_tn1_iff in H.
      induction H.
      + destruct H as (b, (c, (?, (?, ?)))).
        destruct S_is_bisimulation as (_, (d, ?, ?)).
        * exact H.
        * easy.
        * exact H0.
        * exists d; eauto with cps.
      + apply clos_trans_tn1_iff in H0.
        destruct IHclos_trans_n1 as (a, ?, ?).
        destruct H as (b, (c, (?, (?, ?)))).
        destruct S_is_bisimulation as (_, (d, ?, ?)).
        * apply equiv_trans with y; eauto.
        * easy.
        * eassumption.
        * exists d; eauto with cps.
    - destruct H as (z, ?, ?).
      generalize dependent y.
      apply clos_trans_tn1_iff in H.
      induction H; intros.
      + rename y0 into z.
        apply t_step.
        exists x, y; eauto.
      + rename y0 into w.
        apply clos_trans_tn1_iff in H0.
        apply t_trans with y.
        * eauto with cps.
        * apply t_step.
          exists y, z; eauto.
  Qed.

  Lemma modulo_bisimulation_diamond:
    diamond R -> diamond modulo.
  Proof.
    destruct S_is_equiv.
    intros ? x y ? z ?.
    unfold transp in H1 |- *.
    destruct H0 as (a, (b, (?, (?, ?)))).
    destruct H1 as (c, (d, (?, (?, ?)))).
    destruct S_is_bisimulation as (_, (e, ?, ?)).
    - exact H0.
    - easy.
    - exact H2.
    - destruct S_is_bisimulation as (_, (f, ?, ?)).
      + exact H1.
      + easy.
      + exact H4.
      + destruct H with x e f as (g, ?, ?); eauto.
        exists g; do 2 eexists; eauto.
  Qed.

  Lemma modulo_bisimulation_transitive_diamond:
    diamond t(R) -> diamond t(modulo).
  Proof.
    intros ? x y ? z ?.
    destruct S_is_equiv.
    apply modulo_bisimulation_postponement in H0.
    apply modulo_bisimulation_postponement in H1.
    destruct H0 as (y', ?, ?).
    destruct H1 as (z', ?, ?).
    destruct H with x y' z' as (w, ?, ?); auto.
    exists w.
    - clear H0 H1 H3 H5.
      apply clos_trans_t1n_iff in H4.
      destruct H4.
      + apply t_step.
        exists y', y0; eauto.
      + apply clos_trans_t1n_iff in H4.
        apply t_trans with y0.
        * apply t_step.
          exists y', y0; eauto.
        * apply modulo_bisimulation_postponement.
          exists z0; eauto.
    - clear H0 H1 H2 H4.
      apply clos_trans_t1n_iff in H5.
      destruct H5.
      + apply t_step.
        exists z', y0; eauto.
      + apply clos_trans_t1n_iff in H5.
        apply t_trans with y0.
        * apply t_step.
          exists z', y0; eauto.
        * apply modulo_bisimulation_postponement.
          exists z0; eauto.
  Qed.

  Lemma modulo_bisimulation_strong_normalization:
    forall e,
    SN R e -> SN modulo e.
  Proof.
    intros x ?.
    destruct S_is_equiv.
    (* We need to generalize the induction a bit... *)
    assert (exists2 y, S x y & SN R y) as (y, ?, ?); eauto.
    apply SN_R_t_R in H1.
    apply SN_R_t_R.
    clear H; generalize dependent x.
    (* There we go, now we can proceed. *)
    induction H1.
    clear H; intros x' ?.
    constructor; intros y' ?.
    fold (SN t(modulo)).
    unfold transp in H.
    assert (t(modulo) x y').
    - apply clos_trans_t1n_iff in H.
      destruct H.
      + apply t_step.
        destruct H as (a, (b, (?, (?, ?)))).
        exists a, b; eauto.
      + apply clos_trans_t1n_iff in H2.
        apply t_trans with y.
        * apply t_step.
          destruct H as (a, (b, (?, (?, ?)))).
          exists a, b; eauto.
        * assumption.
    - apply modulo_bisimulation_postponement in H2.
      destruct H2 as (y, ?, ?).
      eapply H0; eauto.
  Qed.

End Modulo.


(**
Contents (with the example of lambda-calculus modulo β and η)
- Equational theory and models
- Syntax for an equational theory (as a quotient)
- Initiality of this syntax
*)

Require Import Arith.
Require Import Basics.
Require Import micromega.Lia.
 (* for composition *)
Open Scope program_scope.
Open Scope list_scope.

Require Import Lib.
Require Import Quot.
Require Import syntaxdb.

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

(* substitution in the quotiented syntax *)
Reserved Notation "x [ s ]ₘ" (at level 30).
(* mixed substitution in the syntax *)
Reserved Notation "x ⟦ s ⟧" (at level 30).

Record half_equation (S1 : signature)(S2 : signature) :=
  {
    lift_ops :> forall (m : model S1), forall (o : O S2), vec m (ar o) -> m;
    lift_ops_subst :
      forall (m : model S1) (o : O S2),
        binding_condition (variables m) (substitution (m := m))
                          (@lift_ops m o) ;
    lift_ops_natural : forall (m1 m2 : model S1) (f : model_mor m1 m2)
                         (o : O S2)(v : vec m1 (ar o)),
        lift_ops (vec_map (fun _ => f) v)  = f (lift_ops v)

  }.

Arguments lift_ops [S1 S2] h [m] o.

Record equational_theory :=
  { metavariables : signature ;
    main_signature : signature ;
    left_handside : half_equation main_signature metavariables ;
    right_handside : half_equation main_signature metavariables
  }.

Inductive LCβη_metavariables_O := Beta | Eta.
Definition LCβη_metavariables : signature :=
  {|
    O := LCβη_metavariables_O ;
    ar := fun o => match o with
                  Beta =>
                  (* two metavariables in (λx) y = x[y],
                     with x binding a variable *)
                    1 :: 0 :: nil
                | Eta => 0 :: nil
                  (* one metavariable: t = (λ(t[n ↦ n+1] 0) *)
                end
  |}.

Definition LCβη_left_handside_data (m : model LC_sig)(o : LCβη_metavariables_O)
  : vec m (ar (s := LCβη_metavariables) o) -> m :=
  match o with
    Beta => fun v =>
             let x := vec_hd v in
             let y := vec_hd (vec_tl v) in
             app (abs x) y
  | Eta => fun v => vec_hd v
  end.

Definition LCβη_right_handside_data (m : model LC_sig)(o : LCβη_metavariables_O)
  : vec m (ar (s := LCβη_metavariables) o) -> m :=
  match o with
    Beta => fun v =>
             let x := vec_hd v in
             let y := vec_hd (vec_tl v) in
             x [ fun n => match n with 0 => y | S p => variables m p end ]
  | Eta => fun v =>
            let t := vec_hd v in
            (abs (app (t [ fun n => variables m (1 + n) ]) (variables m 0)))
  end.

Program Example LCβη_sig : equational_theory :=
  {|
  main_signature := LC_sig;
  metavariables := LCβη_metavariables ;
  left_handside :=
    {|
      lift_ops := LCβη_left_handside_data
    |} ;
  right_handside :=
    {|
      lift_ops := LCβη_right_handside_data
    |} ;

  |}.
(**
Next come the proofs that the left handside and the right handside
are indeed half-equations.
 *)

Next Obligation .
  red.
  destruct o; cbn;intros f v.
  -  rewrite vec_tl_map, !vec_hd_map.
     unfold app, abs.
     do 2 (rewrite (ops_subst (mod_laws m)); cbn).
     reflexivity.
  - rewrite vec_hd_map.
    reflexivity.
Qed.
Next Obligation.
  destruct o; cbn.
  - rewrite vec_tl_map, !vec_hd_map.
    unfold app, abs.
    do 2 (rewrite (ops_mor (mor_laws f)); cbn).
    reflexivity.
  - rewrite vec_hd_map.
    reflexivity.
Qed.
Next Obligation .
  red.
  destruct o; cbn;intros f v.
  -  rewrite vec_tl_map, !vec_hd_map.
     do 2 rewrite (assoc (mod_laws m)); cbn.
     apply (substitution_ext (mod_laws m)).
     intro n.
     destruct n; cbn.
     + rewrite (variables_subst (mod_laws m)).
       reflexivity.
     + rewrite (variables_subst (mod_laws m)).
       rewrite (assoc (mod_laws m)); cbn.
       etransitivity.
       symmetry; apply (id_neutral (mod_laws m)).
       apply (substitution_ext (mod_laws m)).
       intro p.
       rewrite (variables_subst (mod_laws m)).
       reflexivity.
  - rewrite !vec_hd_map.
    unfold app, abs.
     do 2 (rewrite (ops_subst (mod_laws m)); cbn).
     rewrite (variables_subst (mod_laws m)).
     cbn.
     f_equal.
     f_equal.
     f_equal.
     f_equal.
     do 2 rewrite (assoc (mod_laws m)); cbn.
     apply (substitution_ext (mod_laws m)).
     intro n.
     destruct n; cbn.
     + rewrite (variables_subst (mod_laws m)).
       reflexivity.
     + rewrite (variables_subst (mod_laws m)).
       reflexivity.
Qed.
Next Obligation.

  destruct o; cbn.
  - rewrite vec_tl_map, !vec_hd_map.
    rewrite (substitution_mor (mor_laws f)); cbn.
    apply (substitution_ext (mod_laws _)).
    unfold compose.
    intro n.
     destruct n; cbn.
     + reflexivity.
     + rewrite (variables_mor (mor_laws _)).
       reflexivity.
  - rewrite !vec_hd_map.
    unfold app, abs.
    do 2 (rewrite (ops_mor (mor_laws f)); cbn).
    rewrite (variables_mor (mor_laws _)).
    f_equal.
    f_equal.
    f_equal.
    f_equal.
    rewrite (substitution_mor (mor_laws f)); cbn.
    apply (substitution_ext (mod_laws _)).
    unfold compose.
    auto using (variables_mor (mor_laws _)).
Qed.

Record model_equational (E : equational_theory) :=
  { main_model :> model (main_signature E) ;
    model_eq : forall o (v : vec main_model (ar o)),
        left_handside E main_model o v = right_handside E main_model o v
  }.

Section LC_βη.
End LC_βη.

(** Equivalence relation on the main signature of an equational theory *)
Inductive rel_Z (E : equational_theory) : Z (main_signature E) -> Z (main_signature E) -> Prop :=
| eqE : forall o v, rel_Z (left_handside E (ZModel _) o v) (right_handside E (ZModel _) o v)
| reflE : forall z, rel_Z z z
| symE : forall a b, rel_Z b a -> rel_Z a b
| transE : forall a b c, rel_Z a b -> rel_Z b c -> rel_Z a c
| congrE : forall (o : O (main_signature E)) (v v' : vec _ (ar o)),
    rel_vec (@rel_Z E)  v v' -> rel_Z (Op o v) (Op o v').

Definition ZEr (E : equational_theory) : Eqv (Z (main_signature E)) :=
  Build_Eqv (@rel_Z E) (@reflE E) (@symE E)(@transE E) .

(** Syntax for a quotiented signature *)
Definition ZE(E : equational_theory) := Z (main_signature E) // (ZEr E).

Example LCβη := ZE LCβη_sig.

Definition  projE{E : equational_theory} (z : Z (main_signature E)) : ZE E :=
  z / ZEr E.

Definition ZE_ops (E : equational_theory) (o : O (main_signature E)) (v : vec (ZE E) (ar o)) :
  ZE E.
  revert v.
  unshelve eapply (vec_quot_out).
  - intro v.
    apply projE.
    revert v.
    apply Op.
  - intro v.
    cbn.
    intros v' rv.
    apply class_eq.
    apply congrE.
    assumption.
Defined.

Lemma ZE_ops_projE (E : equational_theory)
       (o : O (main_signature E)) (v : vec (Z (main_signature E)) (ar o)) :
  ZE_ops (vec_map (fun _ => projE) v) = projE (Op o v).

Proof.
  apply vec_quot_out_proj.
Qed.

Lemma lift_ops_Z_ren {S V : signature} (h : half_equation S V)
   (f : nat -> nat) (o : O V) v :
  Z_ren f (h (ZModel S) o v) = h (ZModel S) o (vec_map (fun n t => Z_ren (derivₙ n f) t) v).
Proof.
  etransitivity ; [apply Z_ren_subst_eq|].
  etransitivity ; [apply (lift_ops_subst _ (m := ZModel _) )|].
  f_equal.
  apply vec_map_ext.
  intros.
  symmetry.
  etransitivity ; [apply Z_ren_subst_eq|].
  apply Z_subst_ext.
  intro n.
  cbn.
  apply var_derivₙ.
  reflexivity.
Qed.

Fixpoint Z_ren_compat {E}(f : nat -> nat)(x y : Z (main_signature E))(r :  ZEr E x y) :
  ZEr E (Z_ren f x) (Z_ren f y).
Proof.
 destruct r.
 - cbn.
   rewrite 2 lift_ops_Z_ren.
   constructor.
 - constructor.
 - apply symE.
   apply Z_ren_compat.
   assumption.
 - eapply transE; apply Z_ren_compat; eassumption.
 - cbn.
   apply congrE.
   induction H.
   + cbn.
     constructor.
   + cbn.
     constructor.
     * apply IHrel_vec.
     * apply Z_ren_compat.
       assumption.
Qed.

Definition ZE_ren {E : equational_theory} (f : nat -> nat) (x : ZE E) : ZE E.
  revert x .
  unshelve eapply (factor1 _ _ (Z_ren f)).
  apply Z_ren_compat.
Defined.

Lemma ZE_ren_proj{E : equational_theory} (f : nat -> nat) (z : Z (main_signature E)):
  projE (Z_ren f z) = ZE_ren f (projE z).
Proof.
  symmetry.
  apply factorize1.
Qed.

Definition VarE {E : equational_theory} (n : nat) : ZE E := Var _ n / ZEr E.

Fixpoint ZE_mixed_subst {E : equational_theory}
         (f : nat -> ZE E) (z : Z (main_signature E)) : ZE E :=
  match z with
    Var _ n => f n
  | Op op v => ZE_ops
                 (vec_map
                    (fun n x =>
                       x ⟦ derivₙₛ VarE ZE_ren n f ⟧
                    ) v)
  end where "t ⟦ s ⟧" := (ZE_mixed_subst s t).

Fixpoint max_fv {S : signature} (z : Z S) : nat :=
  match z with
    Var _ n => n
  | Op op  v => vec_max (vec_map (fun n x => n + max_fv x) v)
  end.

Fixpoint ZE_mixed_subst_ext {E} (f g : nat -> ZE E)(z : Z _)
         (hfg : forall n, n <= max_fv z -> f n = g n) {struct z} :
  z ⟦ f ⟧ = z ⟦ g ⟧.
Proof.
  destruct z.
  - cbn in hfg.
    cbn.
    apply hfg.
    reflexivity.
  - cbn.
    f_equal.
    cbn in hfg.
    revert hfg.
    induction v.
    + reflexivity.
    + cbn.
      intro hfg.
      f_equal.
      * apply ZE_mixed_subst_ext.
        intros.
        apply derivₙₛ_ext.
        reflexivity.
        intros.
        apply hfg.
        lia.
      * apply IHv.
        cbn.
        intros.
        apply hfg.
        lia.
Qed.

Fixpoint Z_subst_quot {E : equational_theory}
      (f : nat -> Z (main_signature E)) (z : Z (main_signature E)) :
  (z [ f ]ₛ) / ZEr E = z ⟦ @projE E ∘ f ⟧.
Proof.
  destruct z.
  - reflexivity.
  - cbn.
    etransitivity; [ symmetry; apply ZE_ops_projE|].
    f_equal.
    etransitivity;[apply vec_map_map|].
    cbn.
    apply vec_map_ext.
    intros n z.
    etransitivity;[ apply Z_subst_quot| ].
    cbn.
    apply ZE_mixed_subst_ext.
    intros m hm.
    unfold compose.
    apply derivₙₛ_natural.
    + reflexivity.
    + cbn.
      apply ZE_ren_proj.
Qed.

Fixpoint ZE_mixed_subst_compat
  (E : equational_theory)
      (f : nat -> ZE E)(z z' : Z (main_signature E))(rz :ZEr E z z'): z ⟦ f ⟧ = z' ⟦ f ⟧.
Proof.
  destruct rz.
  - cbn.
    revert f.
    refine (finitary_seq_quot_ind _ (n := 1 + Nat.max (max_fv(left_handside E (ZModel (main_signature E)) o v))
                                  (max_fv (right_handside E (ZModel (main_signature E)) o v))) _ _).
    + intros f g hfg.
      erewrite 2 (ZE_mixed_subst_ext (f := f)(g := g)).
      * tauto.
      * intros; apply hfg; lia.
      * intros; apply hfg; lia.
    + intro h.
      do 2 rewrite <- (Z_subst_quot h).
      etransitivity.
      {
        apply (f_equal projE).
        apply  (lift_ops_subst _ (m := ZModel _) h v).
      }
      etransitivity;revgoals.
      {
        symmetry.
        apply (f_equal projE).
        apply  (lift_ops_subst _ (m := ZModel _) h v).
      }
      apply class_eq.
      constructor.
  - reflexivity.
  - symmetry.
    apply ZE_mixed_subst_compat.
    assumption.
  - etransitivity; apply ZE_mixed_subst_compat; eassumption.
  - cbn.
    f_equal.
    induction H.
    + cbn.
      constructor.
    + cbn.
      f_equal.
      * apply ZE_mixed_subst_compat.
        assumption.
      * apply IHrel_vec.
Qed.
Definition ZE_subst {E : equational_theory}  (f : nat -> ZE E) (x : ZE E) : ZE E.
  revert x f.
  unshelve refine (factor _ _ _).
  - exact (fun z f => ZE_mixed_subst f z).
  - intros z z' rz.
    cbn.
    apply extensionality.
    intro f.
    apply ZE_mixed_subst_compat.
    assumption.
Defined.

Notation "x [ f ]ₘ" := (ZE_subst f x) (at level 30).

Lemma ZE_subst_proj {E : equational_theory} f z  :
  projE (E := E) z [ f ]ₘ = z ⟦ f ⟧.
Proof.
  unfold ZE_subst, projE.
  rewrite factorize.
  reflexivity.
Qed.
Lemma ZE_subst_proj_proj {E : equational_theory} f z  :
  projE (E := E) z [ projE ∘ f ]ₘ = projE (z [ f ]ₛ).
Proof.
  etransitivity; [apply ZE_subst_proj|].
  symmetry.
  apply Z_subst_quot.
Qed.

Lemma ZE_subst_ext {E}(f g : nat -> ZE E) (fg : forall n : nat, f n = g n) : forall x : ZE E, x [ f ]ₘ = x [ g ]ₘ.
Proof.
  apply class_ind.
  intro z.
  rewrite  2 (ZE_subst_proj _ z).
  apply ZE_mixed_subst_ext.
  auto.
Qed.

Lemma ZE_ren_var {E}(f : nat -> nat) (n : nat): ZE_ren (E := E) f (VarE n) = VarE (f n).
Proof.
  unfold ZE_ren, VarE.
  rewrite factorize1.
  reflexivity.
Qed.

Lemma ZE_subst_var {E} x f :
  VarE (E := E) x [ f ]ₘ = f x.
Proof.
  unfold ZE_subst, VarE.
  rewrite factorize.
  reflexivity.
Qed.
Lemma derivₛ_projE {E} n f x :
  derivₛ (VarE (E := E)) ZE_subst n (projE ∘ f) x =
  projE (derivₛ (Var _) Z_subst n f x).
Proof.
  symmetry.
  apply (derivₙₛ_natural (g:= projE)).
  - reflexivity.
  - intros g z.
    symmetry.
    apply ZE_subst_proj_proj.
Qed.

Lemma ZE_ren_subst_eq {E} (f : nat -> nat) (x : ZE E) :
  ZE_ren f x = x [ fun n => VarE (f n) ]ₘ.
Proof.
  revert x.
  apply class_ind.
  intro z.
  fold (projE z).
  symmetry.
  etransitivity;[|apply  ZE_ren_proj].
  etransitivity;[apply ZE_subst_proj_proj|].
  f_equal.
  symmetry.
  apply Z_ren_subst_eq.
Qed.

Lemma ZE_ops_ren
  {E : equational_theory} (o : O (main_signature E)) (v : vec (ZE E) (ar o)) (f : nat -> nat) :
    ZE_ren f (ZE_ops v) = ZE_ops (vec_map (fun (n : nat) (t : ZE E) => ZE_ren (derivₙ n f) t) v).
Proof.
  revert v.
  refine (vec_quot_ind _ _).
  intro v.
  rewrite ZE_ops_projE.
  rewrite <- ZE_ren_proj.
  cbn.
  rewrite <- ZE_ops_projE.
  f_equal.
  rewrite vec_map_map.
  rewrite vec_map_map.

  apply vec_map_ext.
  intros.
  apply ZE_ren_proj.
Qed.

Lemma ZE_ops_subst
  {E : equational_theory} (o : O (main_signature E)) (f : nat -> ZE E)(v : vec (ZE E) (ar o))  :
    ZE_ops v [f ]ₘ = ZE_ops (vec_map (fun (n : nat) (t : ZE E) => t [derivₛ VarE ZE_subst n f ]ₘ) v).
Proof.
  revert v.
  refine (vec_quot_ind _ _).
  intro v.
  rewrite ZE_ops_projE.
  rewrite ZE_subst_proj.
  cbn.
  f_equal.
  rewrite vec_map_map.
  apply vec_map_ext.
  intros.
  symmetry.
  etransitivity.
  apply ZE_subst_proj.
  apply ZE_mixed_subst_ext.
  intros n hn.
  apply derivₙₛ_ext.
  -  intros. symmetry.
     apply ZE_ren_subst_eq.
  - reflexivity.
Qed.

Definition ZEModel_data (E : equational_theory) : model_data (main_signature E) :=
  {|
  carrier := ZE E;
  variables := VarE  ;
  ops := @ZE_ops E ;
  substitution := ZE_subst
  |}.

Fixpoint ZE_ren_mixed_subst {E} (g : nat -> nat) (f : nat -> ZE E) (z : Z _) :
  Z_ren g z ⟦ f ⟧ = z ⟦ fun n : nat => f (g n) ⟧.
Proof.
  destruct z.
  - reflexivity.
  - cbn.
    f_equal.
    rewrite vec_map_map.
    apply vec_map_ext.
    intros.
    cbn.
    etransitivity;[apply ZE_ren_mixed_subst|].
    apply ZE_mixed_subst_ext.
    intros n hn.
    apply derivₙₛ_derivₙ.
Qed.

Lemma ZE_ren_subst {E} (g : nat -> nat) (f : nat -> ZE E) (z : ZE E) :
ZE_ren g z [f ]ₘ = z [fun n : nat => f (g n) ]ₘ.
Proof.
  revert z.
  apply class_ind.
  intro z.
  fold (projE z).
  rewrite <- ZE_ren_proj.
  rewrite ZE_subst_proj.
  rewrite ZE_subst_proj.
  apply ZE_ren_mixed_subst.
Qed.
Lemma ZE_ren_ren {E} g f (z : ZE E) :
ZE_ren g (ZE_ren f z) = ZE_ren (g ∘ f) z.
  rewrite ZE_ren_subst_eq at 1.
  rewrite ZE_ren_subst.
  symmetry.
  apply ZE_ren_subst_eq.
Qed.
Fixpoint ZE_mixed_subst_ren
  {E} (g : nat -> nat) (f : nat -> ZE E) z :
  ZE_ren g (z ⟦ f ⟧) = z ⟦ fun n : nat => ZE_ren g (f n) ⟧.
Proof.
  destruct z.
  - reflexivity.
  - cbn.
    rewrite ZE_ops_ren.
    f_equal.
    rewrite vec_map_map.
    apply vec_map_ext.
    intros.
    etransitivity.
    { apply ZE_mixed_subst_ren. }
    apply ZE_mixed_subst_ext.
    intros n hn.
    apply ren_derivₙ_derivₙₛ.
    + intros; apply ZE_ren_var.
    + intros; apply ZE_ren_ren.
Qed.
Lemma ZE_subst_ren
  {E} (g : nat -> nat) (f : nat -> ZE E) (z : ZE E) :
  ZE_ren g (z [f ]ₘ) = z [fun n : nat => ZE_ren g (f n) ]ₘ.
Proof.
  revert z.
  apply class_ind.
  intro z.
  fold (projE z).
  rewrite ZE_subst_proj.
  rewrite ZE_subst_proj.
  apply ZE_mixed_subst_ren.
  Qed.

Fixpoint ZE_mixed_subst_subst {E : equational_theory}
      (f g : nat -> ZE E) (z : Z _) :
  (z ⟦ g ⟧) [f ]ₘ = z ⟦ fun n : nat => g n [f ]ₘ ⟧.
Proof.
  destruct z.
  - reflexivity.
  - cbn.
    rewrite ZE_ops_subst.
    f_equal.
    rewrite vec_map_map.
    apply vec_map_ext.
    intros a z.
    etransitivity.
    { apply ZE_mixed_subst_subst. }
    apply ZE_mixed_subst_ext.
    intros n hn.
    etransitivity.
    {
    apply ZE_subst_ext.
    intro.
    apply (derivₛ_eq (ren := ZE_ren)).
    apply ZE_ren_subst_eq.
    }
    cbn.
    eapply subst_derivₙₛ.
    + intros; apply ZE_subst_var.
    + intros; apply ZE_ren_subst.
    + intros; apply ZE_subst_ren.
Qed.
    (* ah mais c'est comme avant.. *)
Lemma ZE_subst_subst {E : equational_theory}
      (f g : nat -> ZE E) (x : ZE E) :
  (x [g]ₘ) [f]ₘ = x [fun n : nat => g n [f]ₘ]ₘ.
Proof.
  revert x.
  apply class_ind.
  intro z.
  fold (projE (E := E) z).
  rewrite ZE_subst_proj.
  rewrite ZE_subst_proj.
  apply ZE_mixed_subst_subst.
Qed.
Fixpoint ZE_mixed_subst_id {E}(z : Z _): z ⟦ VarE ⟧ = z / ZEr E.
Proof.
  destruct z.
  - reflexivity.
  - cbn.
    etransitivity;revgoals.
    apply ZE_ops_projE.
    f_equal.
    apply vec_map_ext.
    intros n z.
    etransitivity;[|apply ZE_mixed_subst_id].
    apply ZE_mixed_subst_ext.
    intros m hm.
    apply derivₙₛ_var.
    apply ZE_ren_var.
Qed.

Lemma ZE_subst_id {E} (z : ZE E) : z [VarE ]ₘ = z.
Proof.
  revert z.
  apply class_ind.
  intro z.
  etransitivity.
  apply ZE_subst_proj.
  apply ZE_mixed_subst_id.
Qed.
Program Definition ZEModel ( E : equational_theory) : model (main_signature E) :=
  {| mod_carrier := ZEModel_data E ;
     mod_laws := {|
              substitution_ext := @ZE_subst_ext E ;
              variables_subst := @ZE_subst_var E ;
              ops_subst := @ZE_ops_subst E ;
              assoc := @ZE_subst_subst E ;
              id_neutral := @ZE_subst_id E
            |}
  |}.

Program Definition projE_is_model_mor {E} :
  @is_model_mor _ (ZModel (main_signature E)) (ZEModel E) projE :=
  {|
  substitution_mor := fun f z => eq_sym (ZE_subst_proj_proj f z) ;
  variables_mor := fun _ => eq_refl _  ;
  ops_mor := fun o v => eq_sym (ZE_ops_projE v) |}.

Definition projE_mor {E} : model_mor (ZModel _) (ZEModel E) :=
  {| mor_carrier := (projE : ZModel _ -> ZEModel E) ;
     mor_laws := projE_is_model_mor
  |}.

Lemma ZE_model_eq
  (E : equational_theory)
  (o : O (metavariables E))
  (v : vec (ZE E) (ar o))
  :
  left_handside E (ZEModel E) o v = right_handside E (ZEModel E) o v.
Proof.
  revert v.
  refine (vec_quot_ind _ _).
  intro v.
  rewrite 2 (lift_ops_natural _ (projE_mor (E := E))).
  apply class_eq.
  constructor.
Qed.
Definition  ZEModel_equational ( E : equational_theory) : model_equational E :=
  {| main_model := ZEModel E ;
     model_eq :=  @ZE_model_eq E
  |}.

Fixpoint ini_mor_compat {E} (m : model_equational E)( x y : Z (main_signature E))(r :  ZEr E x y) :
  ini_mor m x = ini_mor m y.
Proof.
  induction r; try congruence.
  - cbn.
    etransitivity; revgoals.
    apply (lift_ops_natural _ (initial_morphism m)).
    etransitivity; revgoals.
    apply model_eq.
    symmetry.
    apply (lift_ops_natural _ (initial_morphism m)).
  - cbn.
    f_equal.
    induction H.
    + reflexivity.
    + cbn.
      f_equal.
      * apply ini_mor_compat; assumption.
      * assumption.
Qed.
Definition ini_morE {E} (m : model_equational E)(z : ZE E) : m.
  revert z.
  unshelve eapply factor.
  - apply (ini_mor).
  - apply ini_mor_compat.
Defined.

Lemma ini_morE_proj {E} (m : model_equational E) x :
  ini_morE m (x / ZEr E) = ini_mor m x.
Proof.
  apply factorize.
Qed.

Fixpoint ini_mor_subst_ext {S : signature}(m : model S)(z : Z S)(f g : nat -> m)
  (fgeq: forall n, n <= max_fv z -> f n = g n) {struct z} : ini_mor m z [ f ] =
                                         ini_mor m z [ g ].
Proof.
  destruct z.
  - cbn.
    rewrite 2 variables_subst ; try apply mod_laws.
    apply fgeq.
    cbn.
    reflexivity.
  - cbn.
    rewrite 2 ops_subst; try apply mod_laws.
    revert fgeq.
    cbn.
    intros.
    f_equal.
    rewrite 2 vec_map_map.
    induction v.
    + reflexivity.
    + cbn.
      f_equal.
      * apply ini_mor_subst_ext.
        intros.
        apply derivₙₛ_ext.
        -- reflexivity.
        -- intros.
           apply fgeq.
           cbn.
           lia.
      * apply IHv.
        cbn.
        intros.
        apply fgeq.
        cbn.
        lia.
Qed.

Lemma ini_morE_is_model_mor {E} (m : model_equational E)
      : @is_model_mor _ (ZEModel E) m (ini_morE m).
Proof.
  split; cbn.
  - intro n.
    etransitivity.
    apply ini_morE_proj.
    reflexivity.
  - intros.
    revert x.
    apply class_ind.
    intro x.
    revert f.
    rewrite ini_morE_proj.
    fold (projE x).
    refine (finitary_seq_quot_ind _ (n := 1 + max_fv x) _ _ ).
    + intros f g hfg.
      rewrite 2 ZE_subst_proj.
      rewrite (ZE_mixed_subst_ext (f := f)(g := g)); [| intros; apply hfg; lia].
      rewrite (ini_mor_subst_ext (S := main_signature E)(m := m) (z := x)
                                    (f := ini_morE m ∘ f)
                                    (g := ini_morE m ∘ g)).
      * tauto.
      * intros.
        unfold compose.
        rewrite hfg.
        reflexivity.
        lia.
    + intros.
      change (fun n => f n / ZEr E) with (compose (projE (E := E)) f).
      rewrite ZE_subst_proj_proj.
      etransitivity; revgoals.
      {
        apply substitution_ext;[apply mod_laws|].
        intro.
        symmetry.
        apply ini_morE_proj.
      }
      etransitivity; [apply ini_morE_proj|].
      apply ini_mor_subst.
  - intros.
    cbn.
    revert v.
    eapply (vec_quot_ind).
    intro v.
    rewrite ZE_ops_projE.
    etransitivity.
    apply ini_morE_proj.
    cbn.
    rewrite vec_map_map.
    f_equal.
    apply vec_map_ext.
    intros.
    symmetry.
    apply ini_morE_proj.
Qed.

Program Definition ini_morE_model_mor {E} (m : model_equational E)
  : model_mor (ZEModel E) m :=
  {| mor_carrier := ini_morE m ;
     mor_laws := ini_morE_is_model_mor m;
  |}.

Lemma ini_morE_unique {E} (m : model_equational E)(f : model_mor (ZEModel E) m)(z : ZE E) :
f z = ini_morE m z.
  revert z.
  apply class_ind.
  intro x.
  cbn.
  rewrite ini_morE_proj.
  apply (initial_morphism_unique (f := f ∘ projE_mor)).
  apply is_model_mor_compose; apply mor_laws.
Qed.


Require Import Core.Basics.
Require Import Core.Tagged.
Require Import Core.HVec.

Record Signature := {
  Sorts : Type ;
  Funcs : Tagged (list Sorts * Sorts) ;
  Preds : Tagged (list Sorts) ;
}.

Lemma eq_signature (Σ Σ' : Signature)
  (p : Sorts Σ = Sorts Σ')
  (q : tagged_mkeq (rew [λ x, Tagged (list x * x)] p in Funcs Σ) (Funcs Σ'))
  (r : tagged_mkeq (rew [Tagged ∘ list] p in Preds Σ) (Preds Σ'))
  : Σ = Σ'.
Proof.
  rewrite tagged_eq_iff in q.
  rewrite tagged_eq_iff in r.
  destruct Σ, Σ'; cbn in *.
  now destruct p, q, r.
Qed.

Definition Arity Σ := list (Sorts Σ).

Notation ar F := (fst (get_tag F)) (only parsing).
Notation res F := (snd (get_tag F)) (only parsing).
Notation arP P := (get_tag P) (only parsing).

Definition lift_sig [A B] (f : A -> B) x := (map f (fst x), f (snd x)).

Lemma lift_sig_compose [A B C] (g : B -> C) (f : A -> B) x :
lift_sig g (lift_sig f x) = lift_sig (g ∘ f) x.
Proof.
  induction x; unfold lift_sig; cbn; rewrite map_map; reflexivity.
Qed.

Record SignatureMorphism (Σ Σ' : Signature) := {
  on_sorts :> Sorts Σ -> Sorts Σ' ;
  on_funcs : tagged_morphism (lift_sig on_sorts) (Funcs Σ) (Funcs Σ') ;
  on_preds : tagged_morphism (map on_sorts) (Preds Σ) (Preds Σ') ;
}.

Arguments on_sorts {Σ Σ'} σ s : rename.
Arguments on_funcs {Σ Σ'} σ : rename.
Arguments on_preds {Σ Σ'} σ : rename.

Lemma eq_signature_morphism (Σ Σ' : Signature) (σ σ' : SignatureMorphism Σ Σ')
  (p : on_sorts σ = on_sorts σ')
  (q : rew [λ os, tagged_morphism (lift_sig os) (Funcs Σ) (Funcs Σ')] p
        in (@on_funcs _ _ σ) = @on_funcs _ _ σ')
  (r : rew [λ os, tagged_morphism (map os) (Preds Σ) (Preds Σ')] p
        in (@on_preds _ _ σ) = @on_preds _ _ σ')
  : σ = σ'.
Proof.
  destruct σ, σ'.
  cbn in *.
  now destruct p, q, r.
Qed.

Lemma arityF_commutes [Σ Σ'] (σ : SignatureMorphism Σ Σ') F :
  map σ (fst (Funcs Σ F)) = fst (Funcs Σ' (on_funcs σ F)).
Proof.
  rewrite tagged_morphism_commutes; reflexivity.
Defined.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              Nov 25th 1994                               *)
(*                                                                          *)
(****************************************************************************)
(*                              Z_succ_pred.v                               *)
(****************************************************************************)
Require Export Arith.
Require Export Zbase.

(* Succ and Pred on Z *)

(**************)
Definition succZ (x : Z) :=
  match x return Z with
  | OZ =>
      (* OZ *)  IZ
      (* pos n *)
  | pos n => pos (S n)
      (* neg n *)
  | neg n =>
      match n return Z with
      | O =>
          (* O *)  OZ
          (* S m *)
      | S m => neg m
      end
  end.

(**************)
Definition predZ (x : Z) :=
  match x return Z with
  | OZ =>
      (* OZ *)  neg 0
      (* pos n *)
  | pos n =>
      match n return Z with
      | O =>
          (* O *)  OZ
          (* S m *)
      | S m => pos m
      end
      (* neg n *)
  | neg n => neg (S n)
  end.

(***************)
Lemma pred_succZ : forall x : Z, predZ (succZ x) = x.

Proof.
intros; pattern x in |- *; elim x.
(* OZ *)
simpl in |- *; reflexivity.
(* pos n *)
simpl in |- *; reflexivity.
(* neg n *)
intros; elim n.
simpl in |- *; reflexivity.
intros; simpl in |- *; reflexivity.
Qed.

(***************)
Lemma succ_predZ : forall x : Z, succZ (predZ x) = x.

Proof.
intros; pattern x in |- *; elim x.
(* OZ *)
simpl in |- *; reflexivity.
(* pos n *)
intros; elim n.
simpl in |- *; reflexivity.
intros; simpl in |- *; reflexivity.
(* neg n *)
simpl in |- *; reflexivity.
Qed.

(*************************)
Lemma succ_pred_pred_succZ : forall x : Z, succZ (predZ x) = predZ (succZ x).

Proof.
intros; rewrite (pred_succZ x); exact (succ_predZ x).
Qed.

(******************)
Lemma tech_pred_posZ : forall n : nat, 0 < n -> predZ (pos n) = pos (pred n).

Proof.
intro; elim n; intro. elim (lt_n_O 0); exact H. intros; simpl in |- *; reflexivity.
Qed.

(********************)
Lemma tech_succ_posOZ : forall n : nat, succZ (posOZ n) = pos n.

Proof.
intros; elim n; simpl in |- *; reflexivity; simpl in |- *; reflexivity.
Qed.


Require Import Coq.Strings.String.

Inductive aexp : Type :=
  | ANum (n : nat)
  | AVar (x : string)
  | APlus (a a' : aexp).

Coercion ANum : nat >-> aexp.
Coercion AVar : string >-> aexp.
Notation "a1 +' a2" := (APlus a1 a2) (at level 50).

Definition X : string := "X".
Definition Y : string := "Y".
Definition Z : string := "Z".
Definition W : string := "W".

Definition state : Type := string -> nat.
Definition update (x : string)(i : nat)(s : state) : state := fun y =>
  if eqb x y then i else s y.
Definition empty : state := fun _ => 0.

Inductive fstep : aexp * state -> nat -> Prop :=
  | num (n : nat)(s : state) : fstep (ANum n , s) n
  | var (x : string)(s : state) : fstep (AVar x , s) (s x)
  | fplusr (n i : nat)(a2 : aexp)(s : state) :
          fstep (a2 , s) i ->
          fstep (n +' a2 , s) (n + i).

Notation "w f=> i" := (fstep w i) (at level 50).

Example ex1 : (3 +' 4 , empty) f=> 7.
Check (fplusr 3 4). apply (fplusr 3). apply num. Qed.

Example ex2 : (AVar X , update X 3 empty) f=> 3.
apply var. Qed.

Example ex3 : (ANum 3 , empty) f=> 3.
apply num. Qed.

Inductive step : aexp * state -> aexp * state -> Prop :=
  | plusl (a1 a2 a1' : aexp)(s : state) :
          step (a1 , s) (a1' , s) ->
          step (a1 +' a2 , s) (a1' +' a2 , s)
  | fplusl (a1 a2 : aexp)(s : state)(i : nat) :
           (a1 , s) f=> i ->
           step (a1 +' a2 , s) (i +' a2 , s)
  | plusr (a2 a2' : aexp)(s : state)(n : nat) :
          step (a2 , s) (a2' , s) ->
          step (n +' a2 , s) (n +' a2' , s).

Notation "w => w'" := (step w w') (at level 50).

Definition st : state := update Y 12 (update Z 34 empty).

Example ex4a : ((Y +' 5) +' Z , st) => ((12 +' 5) +' Z , st).
apply plusl. apply fplusl. apply var. Qed.

Example ex4b : ((12 +' 5) +' Z , st) => (17 +' Z , st).
apply fplusl. apply (fplusr 12). apply num. Qed.

Example ex4c : (17 +' Z , st) f=> 51.
apply (fplusr 17). apply var. Qed.

Lemma determ (a : aexp)(s : state)(i j : nat)
  (p : (a , s) f=> i)(p' : (a , s) f=> j) : i = j.
generalize dependent j.
induction p.
intros. inversion p'. reflexivity.
intros. inversion p'. reflexivity.
intros. inversion p'. rewrite (IHp i0 H3). reflexivity. Qed.

(* use inversion *)

Inductive fstept : aexp * state -> nat -> Prop :=
  | numt (n : nat)(s : state) : fstept (ANum n , s) n
  | vart (x : string)(s : state) : fstept (AVar x , s) (s x)
  | fplusrt (n i : nat)(a2 : aexp)(s : state) :
            fstept (a2 , s) i ->
            fstept (n +' a2 , s) (n + i)
  | ftranst (w1 w2 : aexp * state)(i : nat) :
            stept w1 w2 -> fstept w2 i -> fstept w1 i
with stept : aexp * state -> aexp * state -> Prop :=
  | pluslt (a1 a2 a1t : aexp)(s : state) :
           stept (a1 , s) (a1t , s) ->
           stept (a1 +' a2 , s) (a1t +' a2 , s)
  | fpluslt (a1 a2 : aexp)(s : state)(i : nat) :
            fstept (a1 , s) i ->
            stept (a1 +' a2 , s) (i +' a2 , s)
  | plusrt (a2 a2t : aexp)(s : state)(n : nat) :
           stept (a2 , s) (a2t , s) ->
           stept (n +' a2 , s) (n +' a2t , s)
  | transt (w1 w2 w3 : aexp * state) :
           stept w1 w2 -> stept w2 w3 -> stept w1 w3.

Notation "w f=>t i" := (fstept w i) (at level 50).
Notation "w =>t w'" := (stept w w') (at level 50).

Example ex4 : ((Y +' 5) +' Z , st) f=>t 51.
apply (ftranst _ (17 +' Z, st)).
apply fpluslt. apply (ftranst _ (12 +' 5, st)). apply (fpluslt). apply vart.
apply (fplusrt 12 5 5 st). apply numt.
(apply (fplusrt 17 34 Z st)). apply vart. Qed.

(*https://en.wikipeapply (fplusrt 17 34 Z st).
dia.org/wiki/Feit%E2%80%93Thompson_theorem  coq*)

(*
FELADAT: atirni ugy, hogy a jobb oldal legyen eloszor kiertekelve
*)


From Cat Require Import Imports Category Preorder Monoid Poset Isomorphism
Terminal Dual Initial Product CoProduct Exponential CCC IPL STLC Functor.
Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.
Require Import JMeq.
Set Universe Polymorphism.

(* Arguments Compose_Functors {_} {_} {_} _ _. *)
Arguments fmap {_} {_} _ {_} {_} _.
Arguments fobj {_} {_} _ _.

Check fobj.
Class NaturalTransformation (C D: Category)
                            (F  : Functor C D)
                            (G  : Functor C D): Type :=
  mk_nt
  {
    trans    : forall (a: @obj C), (@arrow D (fobj G a) (fobj F a));
    comm_diag: forall {a b: @obj C} (f: arrow  b a), fmap G f o trans a  = trans b o fmap F f;
  }.
Check NaturalTransformation.

Arguments NaturalTransformation {_} {_} _ _.
Arguments trans {_} {_} {_} {_} _ _.

Example NT1: NaturalTransformation (@IdFunctor SetCat) (Compose_Functors FreeMonoidFunctor Forgetful1).
Proof. unshelve econstructor.
       - simpl. unfold id. intros X x.
         exact (eta x).
       - simpl. intros X Y f.
         unfold eta. reflexivity.
Defined.

(** sameness of natural transformations *)
Lemma Nt_split: forall (C D: Category)
                       (F  : @Functor C D)
                       (G  : @Functor C D)
                       (nt1: NaturalTransformation F G)
                       (nt2: NaturalTransformation F G), trans nt1 = trans nt2 <-> nt1 = nt2.
Proof. intros. split. intros. destruct nt1, nt2, F, G.
       simpl in *. revert comm_diag0. rewrite H. intros.
       specialize (proof_irrelevance (forall (a b : @obj C) (f : arrow b a),
             fmap0 a b f o trans1 a = trans1 b o fmap a b f) comm_diag0 comm_diag1).
       now destruct (proof_irrelevance _ comm_diag0 comm_diag1).
       intros. rewrite H. easy.
Qed.

Program Definition Compose_NaturalTransformations
                      (C D: Category)
                      (F  : @Functor C D)
                      (G  : @Functor C D)
                      (H  : @Functor C D)
                      (nt1: NaturalTransformation F G)
                      (nt2: NaturalTransformation G H): `(NaturalTransformation F H) :=
{|
    trans := fun a: @obj C =>  trans nt2 a o trans nt1 a;
|}.
Next Obligation.
      rewrite assoc.
      rewrite (@comm_diag C D G H nt2 a).
      do 2 rewrite <- assoc.
      rewrite (@comm_diag C D F G nt1 a).
      reflexivity.
Defined.

(** composing natural transformations *)
Program Definition Compose_NaturalTransformations_H
                          (C D E: Category)
                          (F    : Functor C D)
                          (G    : Functor C D)
                          (H    : Functor D E)
                          (I    : Functor D E)
                          (nt1  : NaturalTransformation F G)
                          (nt2  : NaturalTransformation H I):
                                `(NaturalTransformation (Compose_Functors F H)
                                                        (Compose_Functors G I)).
Proof. unshelve econstructor.
       - destruct F, G, H, I, nt1, nt2. simpl in *.
         intros. exact (((fmap2 _ _ (trans0 a)) o trans1 (fobj  a))).
       - destruct F, G, H, I, nt1, nt2. simpl in *.
         intros. rewrite !comm_diag1. rewrite assoc.
         rewrite comm_diag1. rewrite <- assoc.
         rewrite <- !preserve_comp1.
         rewrite <- assoc.
         rewrite <- !preserve_comp1. now rewrite comm_diag0.
Defined.

(** the identity natural transformation *)
Definition IdNt (C D: Category)
                (F  : Functor C D): NaturalTransformation F F.
Proof. unshelve econstructor.
       - intros. exact (fmap _(@identity C a)).
       - intros. destruct F. simpl. rewrite !preserve_id.
         now rewrite identity_f, f_identity.
Defined.

Arguments Compose_NaturalTransformations {_} {_} {_} {_} {_} _ _.

Lemma Compose_NaturalTransformations_Assoc: forall (C D: Category) (F G H I: Functor C D)
  (nt1: NaturalTransformation F G) (nt2: NaturalTransformation G H) (nt3: NaturalTransformation H I),
  @Compose_NaturalTransformations _ _ _ _ _ (@Compose_NaturalTransformations C D F G H nt1 nt2) nt3 =
  @Compose_NaturalTransformations _ _ _ _ _ nt1 (@Compose_NaturalTransformations C D G H I nt2 nt3).
Proof. intros.
       apply Nt_split.
       simpl.
       extensionality x.
       rewrite assoc.
       reflexivity.
Qed.

(** the category of all functors defined from the same source to
the same target category *)
Definition FunctorCategory (C D: Category): Category.
Proof.
       unshelve econstructor.
       - exact (Functor C D).
       - intros F G. exact (NaturalTransformation G F).
       - intros. exact (@IdNt C D a).
       - intros F G H nt1 nt2.
         exact (Compose_NaturalTransformations nt2 nt1).
       - repeat intro. now rewrite H, H0.
       - intros. apply Nt_split. simpl.
         destruct f, g, h. simpl.
         extensionality a0. now rewrite assoc.
       - intros. apply Nt_split. simpl.
         destruct f, a, b. simpl.
         extensionality a0.
         now rewrite preserve_id0, identity_f.
       - intros. apply Nt_split. simpl.
         destruct f, a, b. simpl.
         extensionality a0.
         now rewrite preserve_id, f_identity.
Defined.

Class CatEquivalence (C D: Category): Type :=
{
   lfunctor: Functor C D;
   rfunctor: Functor D C;
   eq_obl  : @Isomorphic (FunctorCategory C C) (Compose_Functors lfunctor rfunctor) (@IdFunctor C);
   eq_obr  : @Isomorphic (FunctorCategory D D) (Compose_Functors rfunctor lfunctor) (@IdFunctor D)
}.

Class CatEquivalenceA (C D: Category) (lfunctorA: Functor C D): Type :=
{
   rfunctorA: Functor D C;
   eq_oblA  : @Isomorphic (FunctorCategory C C) (Compose_Functors lfunctorA rfunctorA) (@IdFunctor C);
   eq_obrA  : @Isomorphic (FunctorCategory D D) (Compose_Functors rfunctorA lfunctorA) (@IdFunctor D)
}.

Definition appFunctor (C D: Category): Functor ((ProductCategory (FunctorCategory C D) C)) D.
Proof. unshelve econstructor.
       - intros (F, X).
         exact (fobj F X).
       - intros (F, X) (G, Y) (nt, f).
         exact (trans nt Y o (fmap F f)).
       - repeat intro. now subst.
       - intros (F, X).
         unfold IdNt.
         simpl.
         rewrite preserve_id, f_identity.
         reflexivity.
       - intros (F, X) (G, Y) (H, Z) (nt1, f) (nt2, g).
         unfold Compose_NaturalTransformations.
         simpl.
         rewrite preserve_comp.
         rewrite assoc.
         setoid_rewrite <- assoc at 2.
         rewrite <- comm_diag.
         rewrite assoc.
         rewrite assoc.
         reflexivity.
Defined.

Definition curFunctor {C D E: Category} (F: Functor (ProductCategory E C) D): Functor E (FunctorCategory C D).
Proof. unshelve econstructor.
       - intro Z.
         unshelve econstructor.
         + intro X.
           exact (fobj F (Z, X)).
         + intros X X' f.
           exact (@fmap (ProductCategory E C) D F (Z, X) (Z, X') (identity Z, f)).
         + repeat intro. now subst.
         + intro X.
           simpl.
           rewrite (@preserve_id).
           reflexivity.
         + intros X Y T g f.
           simpl.
           rewrite <- (@preserve_comp).
           simpl. rewrite f_identity.
           reflexivity.
       - intros Z Z' g.
         unshelve econstructor.
         + intro X.
           exact (@fmap (ProductCategory E C) D F (Z, X) (Z', X) (g, identity X)).
         + intros X Y f.
           simpl.
           rewrite <- !(@preserve_comp).
           simpl.
           rewrite !f_identity, !identity_f.
           reflexivity.
       - repeat intro. now subst.
       - intro X. unfold IdNt.
         apply Nt_split. reflexivity.
       - unfold Compose_NaturalTransformations.
         intros X Y Z g f.
         apply Nt_split.
         extensionality x.
         simpl.
         rewrite <- preserve_comp.
         simpl.
         rewrite f_identity.
         reflexivity.
Defined.

Lemma arrowRW: forall {C: Category} (X Y Z T: @obj C),
  X = Z -> Y = T -> arrow Y X = arrow T Z.
Proof. intros. subst. easy. Qed.

Require Import Coq.Program.Equality.

Arguments fmap {_} {_} _ {_} {_} _.
Arguments fobj {_} {_} _ _.

Lemma fmapFcurF: forall (C D E: Category)
                   (F: Functor (ProductCategory E C) D)
                   (a1 b1: @obj E) (a2 b2: @obj C)
                   (f1: arrow b1 a1) (f2: arrow b2 a2),
  trans (fmap (curFunctor F) f1) b2 o fmap (fobj (curFunctor F) a1) f2 =
  @fmap (ProductCategory E C) D F (a1, a2) (b1, b2) (f1, f2).
Proof. intros C D E a1 b1 a2 b2 f1 f2 F.
       simpl.
       rewrite <- preserve_comp.
       simpl.
       rewrite f_identity, identity_f.
       reflexivity.
Qed.

Lemma fmap_dist: forall {C D E: Category} {X Y: @obj C} {f: arrow Y X} (F: Functor C D) (G: Functor D E),
  fmap (Compose_Functors F G) f = fmap G (fmap F f).
Proof. simpl. easy. Defined.

Lemma commDiagExp: forall (C D E: Category) (F: Functor (ProductCategory E C) D),
  Compose_Functors (ProductFunctor (curFunctor F) (@IdFunctor C)) (appFunctor C D) = F.
Proof. intros.
       assert (fobj (Compose_Functors (ProductFunctor (curFunctor F) IdFunctor) (appFunctor C D)) = fobj F).
       {
         extensionality a.
         destruct a as (a, b).
         simpl. reflexivity.
       }
(*        simpl in H. *)
(*        pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H) as H';
       cbv beta in H'. *)
       eapply F_splitA with (ObjEq := H).
       extensionality a.
       extensionality b.
       extensionality f.
       destruct a as (a1, a2).
       destruct b as (b1, b2).
       destruct f as (f1, f2).
       specialize (fmapFcurF C D E F); intro HH.
       simpl in HH.
       destruct (curFunctor F) as (CF, CFM, cfn, cfpid, cfpcomp).
       destruct F as (FO, FM, fn, fpid, fpcomp).
       simpl in *.
       subst.
       unfold id in *.
       subst.
       simpl.

       destruct (CFM a1 b1 f1).
       simpl in *.
       rewrite <- comm_diag0.
       simpl.
       cbn in CF.
Admitted.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Orders BinPos Pnat POrderedType GenericMinMax.

(** * Maximum and Minimum of two positive numbers *)

Local Open Scope positive_scope.

(** The functions [Pmax] and [Pmin] implement indeed
    a maximum and a minimum *)

Lemma Pmax_l : forall x y, y<=x -> Pmax x y = x.
Proof.
 unfold Ple, Pmax. intros x y.
 rewrite (ZC4 y x). generalize (Pcompare_eq_iff x y).
 destruct ((x ?= y) Eq); intuition.
Qed.

Lemma Pmax_r : forall x y, x<=y -> Pmax x y = y.
Proof.
 unfold Ple, Pmax. intros x y. destruct ((x ?= y) Eq); intuition.
Qed.

Lemma Pmin_l : forall x y, x<=y -> Pmin x y = x.
Proof.
 unfold Ple, Pmin. intros x y. destruct ((x ?= y) Eq); intuition.
Qed.

Lemma Pmin_r : forall x y, y<=x -> Pmin x y = y.
Proof.
 unfold Ple, Pmin. intros x y.
 rewrite (ZC4 y x). generalize (Pcompare_eq_iff x y).
 destruct ((x ?= y) Eq); intuition.
Qed.

Module PositiveHasMinMax <: HasMinMax Positive_as_OT.
 Definition max := Pmax.
 Definition min := Pmin.
 Definition max_l := Pmax_l.
 Definition max_r := Pmax_r.
 Definition min_l := Pmin_l.
 Definition min_r := Pmin_r.
End PositiveHasMinMax.

Module P.
(** We obtain hence all the generic properties of max and min. *)

Include UsualMinMaxProperties Positive_as_OT PositiveHasMinMax.

(** * Properties specific to the [positive] domain *)

(** Simplifications *)

Lemma max_1_l : forall n, Pmax 1 n = n.
Proof.
 intros. unfold Pmax. rewrite ZC4. generalize (Pcompare_1 n).
 destruct (n ?= 1); intuition.
Qed.

Lemma max_1_r : forall n, Pmax n 1 = n.
Proof. intros. rewrite P.max_comm. apply max_1_l. Qed.

Lemma min_1_l : forall n, Pmin 1 n = 1.
Proof.
 intros. unfold Pmin. rewrite ZC4. generalize (Pcompare_1 n).
 destruct (n ?= 1); intuition.
Qed.

Lemma min_1_r : forall n, Pmin n 1 = 1.
Proof. intros. rewrite P.min_comm. apply min_1_l. Qed.

(** Compatibilities (consequences of monotonicity) *)

Lemma succ_max_distr :
 forall n m, Psucc (Pmax n m) = Pmax (Psucc n) (Psucc m).
Proof.
 intros. symmetry. apply max_monotone.
 intros x x'. unfold Ple.
 rewrite 2 Pcompare_nat_compare, 2 Psucc_S.
 simpl; auto.
Qed.

Lemma succ_min_distr : forall n m, Psucc (Pmin n m) = Pmin (Psucc n) (Psucc m).
Proof.
 intros. symmetry. apply min_monotone.
 intros x x'. unfold Ple.
 rewrite 2 Pcompare_nat_compare, 2 Psucc_S.
 simpl; auto.
Qed.

Lemma plus_max_distr_l : forall n m p, Pmax (p + n) (p + m) = p + Pmax n m.
Proof.
 intros. apply max_monotone.
 intros x x'. unfold Ple.
 rewrite 2 Pcompare_nat_compare, 2 Pplus_plus.
 rewrite <- 2 Compare_dec.nat_compare_le. auto with arith.
Qed.

Lemma plus_max_distr_r : forall n m p, Pmax (n + p) (m + p) = Pmax n m + p.
Proof.
 intros. rewrite (Pplus_comm n p), (Pplus_comm m p), (Pplus_comm _ p).
 apply plus_max_distr_l.
Qed.

Lemma plus_min_distr_l : forall n m p, Pmin (p + n) (p + m) = p + Pmin n m.
Proof.
 intros. apply min_monotone.
 intros x x'. unfold Ple.
 rewrite 2 Pcompare_nat_compare, 2 Pplus_plus.
 rewrite <- 2 Compare_dec.nat_compare_le. auto with arith.
Qed.

Lemma plus_min_distr_r : forall n m p, Pmin (n + p) (m + p) = Pmin n m + p.
Proof.
 intros. rewrite (Pplus_comm n p), (Pplus_comm m p), (Pplus_comm _ p).
 apply plus_min_distr_l.
Qed.

End P.


(** * HoareAsLogic: Hoare Logic as a Logic *)

(* $Date: 2011-04-16 14:56:54 -0400 (Sat, 16 Apr 2011) $ *)

Require Export Hoare.

(** The presentation of Hoare logic in chapter [Hoare] could be
    described as "model-theoretic": the proof rules for each of the
    constructors were presented as _theorems_ about the evaluation
    behavior of programs, and proofs of program correctness (validity
    of Hoare triples) were constructed by combining these theorems
    directly in Coq.

    Another way of presenting Hoare logic is to define a completely
    separate proof system -- a set of axioms and inference rules that
    talk about commands, Hoare triples, etc. -- and then say that a
    proof of a Hoare triple is a valid derivation in _that_ logic.  We
    can do this by giving an inductive definition of _valid
    derivations_ in this new logic. *)

Inductive hoare_proof : Assertion -> com -> Assertion -> Type :=
  | H_Skip : forall P,
      hoare_proof P (SKIP) P
  | H_Asgn : forall Q V a,
      hoare_proof (assn_sub V a Q) (V ::= a) Q
  | H_Seq  : forall P c Q d R,
      hoare_proof P c Q -> hoare_proof Q d R -> hoare_proof P (c;d) R
  | H_If : forall P Q b c1 c2,
    hoare_proof (fun st => P st /\ bassn b st) c1 Q ->
    hoare_proof (fun st => P st /\ ~(bassn b st)) c2 Q ->
    hoare_proof P (IFB b THEN c1 ELSE c2 FI) Q
  | H_While : forall P b c,
    hoare_proof (fun st => P st /\ bassn b st) c P ->
    hoare_proof P (WHILE b DO c END) (fun st => P st /\ ~ (bassn b st))
  | H_Consequence  : forall (P Q P' Q' : Assertion) c,
    hoare_proof P' c Q' ->
    (forall st, P st -> P' st) ->
    (forall st, Q' st -> Q st) ->
    hoare_proof P c Q
  | H_Consequence_pre  : forall (P Q P' : Assertion) c,
    hoare_proof P' c Q ->
    (forall st, P st -> P' st) ->
    hoare_proof P c Q
  | H_Consequence_post  : forall (P Q Q' : Assertion) c,
    hoare_proof P c Q' ->
    (forall st, Q' st -> Q st) ->
    hoare_proof P c Q.

Tactic Notation "hoare_proof_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "H_Skip" | Case_aux c "H_Asgn" | Case_aux c "H_Seq"
  | Case_aux c "H_If" | Case_aux c "H_While" | Case_aux c "H_Consequence"
  | Case_aux c "H_Consequence_pre" | Case_aux c "H_Consequence_post" ].

(** For example, let's construct a proof object representing a
    derivation for the hoare triple
      {{assn_sub X (X+1) (assn_sub X (X+2) (X=3))}} X::=X+1; X::=X+2 {{X=3}}.
    We can use Coq's tactics to help us construct the proof object. *)

Example sample_proof
             : hoare_proof
                 (assn_sub X (APlus (AId X) (ANum 1))
                   (assn_sub X (APlus (AId X) (ANum 2))
                     (fun st => st X = 3) ))
                 (X ::= APlus (AId X) (ANum 1); (X ::= APlus (AId X) (ANum 2)))
                 (fun st => st X = 3).
Proof.
  apply H_Seq with (assn_sub X (APlus (AId X) (ANum 2))
                     (fun st => st X = 3)).
  apply H_Asgn. apply H_Asgn.
Qed.

(*
Print sample_proof.
====>
  H_Seq
    (assn_sub X (APlus (AId X) (ANum 1))
       (assn_sub X (APlus (AId X) (ANum 2)) (fun st : state => st X = VNat 3)))
    (X ::= APlus (AId X) (ANum 1))
    (assn_sub X (APlus (AId X) (ANum 2)) (fun st : state => st X = VNat 3))
    (X ::= APlus (AId X) (ANum 2)) (fun st : state => st X = VNat 3)
    (H_Asgn
       (assn_sub X (APlus (AId X) (ANum 2)) (fun st : state => st X = VNat 3))
       X (APlus (AId X) (ANum 1)))
    (H_Asgn (fun st : state => st X = VNat 3) X (APlus (AId X) (ANum 2)))
*)

(** **** Exercise: 2 stars *)
(** Prove that such proof objects represent true claims. *)

Theorem hoare_proof_sound : forall P c Q,
  hoare_proof P c Q -> {{P}} c {{Q}}.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** We can also use Coq's reasoning facilities to prove metatheorems
    about Hoare Logic.  For example, here are the analogs of two
    theorems we saw in chapter [Hoare] -- this time expressed in terms
    of the syntax of Hoare Logic derivations (provability) rather than
    directly in terms of the semantics of Hoare triples.

    The first one says that, for every [P] and [c], the assertion
    [{{P}} c {{True}}] is _provable_ in Hoare Logic.  Note that the
    proof is more complex than the semantic proof in [Hoare]: we
    actually need to perform an induction over the structure of the
    command [c]. *)

Theorem H_Post_True_deriv:
  forall c P, hoare_proof P c (fun _ => True).
Proof.
  intro c.
  com_cases (induction c) Case; intro P.
  Case "SKIP".
    eapply H_Consequence_pre.
    apply H_Skip.
    (* Proof of True *)
    intros. apply I.
  Case "::=".
    eapply H_Consequence_pre.
    apply H_Asgn.
    intros. apply I.
  Case ";".
    eapply H_Consequence_pre.
    eapply H_Seq.
    apply (IHc1 (fun _ => True)).
    apply IHc2.
    intros. apply I.
  Case "IFB".
    apply H_Consequence_pre with (fun _ => True).
    apply H_If.
    apply IHc1.
    apply IHc2.
    intros. apply I.
  Case "WHILE".
    eapply H_Consequence.
    eapply H_While.
    eapply IHc.
    intros; apply I.
    intros; apply I.
Qed.

(** Similarly, we can show that [{{False}} c {{Q}}] is provable for
    any [c] and [Q]. *)

Lemma False_and_P_imp: forall P Q,
  False /\ P -> Q.
Proof.
  intros P Q [CONTRA HP].
  destruct CONTRA.
Qed.

Tactic Notation "pre_false_helper" constr(CONSTR) :=
  eapply H_Consequence_pre;
    [eapply CONSTR | intros ? CONTRA; destruct CONTRA].

Theorem H_Pre_False_deriv:
  forall c Q, hoare_proof (fun _ => False) c Q.
Proof.
  intros c.
  com_cases (induction c) Case; intro Q.
  Case "SKIP". pre_false_helper H_Skip.
  Case "::=". pre_false_helper H_Asgn.
  Case ";". pre_false_helper H_Seq. apply IHc1. apply IHc2.
  Case "IFB".
    apply H_If; eapply H_Consequence_pre.
    apply IHc1. intro. eapply False_and_P_imp.
    apply IHc2. intro. eapply False_and_P_imp.
  Case "WHILE".
    eapply H_Consequence_post.
    eapply H_While.
    eapply H_Consequence_pre.
      apply IHc.
      intro. eapply False_and_P_imp.
    intro. simpl. eapply False_and_P_imp.
Qed.

(** This style of presentation gives a clearer picture of what it
    means to "give a proof in Hoare logic."  However, it is not
    entirely satisfactory from the point of view of writing down such
    proofs in practice: it is quite verbose.  The section of chapter
    [Hoare] on formalizing decorated programs shows how we can do even
    better. *)


Require Import Coq.ZArith.BinInt.
Require Import riscv.Utility.Encode.
Require Import coqutil.Z.BitOps.
Require Import coqutil.Z.prove_Zeq_bitwise.

Local Open Scope bool_scope.

Lemma invert_encode_I_shift_66: forall {bitwidth opcode rd rs1 shamt6 funct3 funct6},
  verify_I_shift_66 bitwidth opcode rd rs1 shamt6 funct3 funct6 ->
  forall inst,
  encode_I_shift_66  opcode rd rs1 shamt6 funct3 funct6 = inst ->
  opcode = bitSlice inst 0 7 /\
  funct3 = bitSlice inst 12 15 /\
  funct6 = bitSlice inst 26 32 /\
  rd = bitSlice inst 7 12 /\
  rs1 = bitSlice inst 15 20 /\
  shamt6 = bitSlice inst 20 26 /\
  true = ((Z.eqb (bitSlice inst 25 26) 0) || (Z.eqb bitwidth 64)).
Proof.
  intros. unfold encode_I_shift_66, verify_I_shift_66 in *.
  assert ((true = (bitSlice inst 25 26 =? 0)%Z || (bitwidth =? 64)%Z)
          <-> (bitSlice inst 25 26 =? 0)%Z = true \/ (bitwidth =? 64)%Z = true) as E. {
    split; intro.
    - rewrite <- Bool.orb_true_iff. congruence.
    - symmetry. rewrite Bool.orb_true_iff. assumption.
  }
  rewrite E.
  rewrite? Z.eqb_eq.
  (intuition idtac); prove_Zeq_bitwise.
Qed.


(* $Id: RealFuncts.v,v 1.7 2003/03/11 13:36:18 lcf Exp $ *)

Require Export CReals1.

(* Tex_Prose
\chapter{Functions on Reals}
*)

Implicit Arguments On.

Section Continuity.
Variable  f: (CSetoid_un_op IR).
Variable  f2: (CSetoid_bin_op IR).

(* Tex_Prose
\section{Continuity}
Let \verb!f! be a unary setoid operation on \verb!IR! and
let \verb!f2! be a binary setoid operation on \verb!IR!.

We use the following notations for intervals. \verb!Intclr a b! for the
closed interval $[a,b]$, \verb!Intolr a b! for the
open interval ${<}a,b{>}$, \verb!Intcl a! for the
left-closed interval $[a,\infty{>}$, \verb!Intol a! for the
left-open interval ${<}a,\infty{>}$, \verb!Intcr b! for the
right-closed interval ${<}-\infty,b]$.

Intervals like $[a,b]$ are defined for arbitrary reals $a,b$ (being
$\emptyset$ for $a>b$).
*)

(* Begin_Tex_Verb *)
Definition Intclr [a,b:IR; x:IR] : Prop :=
  (a [<=] x) /\ (x [<=] b).
Definition Intolr [a,b:IR; x:IR] : CProp :=
  (a [<] x) * (x [<] b).
Definition Intol [a:IR; x:IR] : CProp :=
  (a [<] x).
Definition Intcl [a:IR; x:IR] : Prop :=
  (a [<=] x).
Definition Intcr [b:IR; x:IR] : Prop :=
   (x [<=] b).
(* End_Tex_Verb *)

(* Tex_Prose
The limit of $f(x)$ as $x$ goes to $p = l$, for both unary and binary
functions:\\
The limit of $f$ in $p$ is $l$ if $\forall e\in\RR (0< e) \rightarrow
\exists d\in\RR (0< d) /\
 \forall x\in\RR(-d<p-x < d<) \rightarrow(AbsSmall -e <l-f(x) <e)$
*)

(* Begin_Tex_Verb *)
Definition funLim [p,l:IR] : CProp :=
  (e:IR)(Zero [<] e)->
    { d:IR & (Zero [<] d) |
             (x:IR)(AbsSmall d (p[-]x)) -> (AbsSmall e (l[-](f x)))}.
(* End_Tex_Verb *)

(* Tex_Prose
The definition of limit of $f$ in $p$ using Cauchy sequences.
*)

(* Begin_Tex_Verb *)
Definition funLim_Cauchy [p,l:IR] : CProp :=
  (s:CauchySeqR)((Lim s)[=] p) ->
    	(e:IR)(Zero [<] e) -> { N:nat | (m:nat)(le N m)
			   -> (AbsSmall e ((f(s m))[-]l))}.
(* End_Tex_Verb *)

(* Tex_Prose
The first definition implies the second one.

*)

(*
Ax_iom funLim_prop1 :(p,l:IR)(funLim p l)->(funLim_Cauchy p l).
*)
(*
Intros. Unfold funLim_Cauchy. Unfold funLim in H. Intros.
Elim (H e H1). Intros.
Elim s. Intros s_seq s_proof.
Decompose [and] H2.
Cut (Zero[<] x[/]TwoNZ).
Intro Hx2.
Elim (s_proof (x[/]TwoNZ) Hx2).
Intros N HN.
Exists N.
Intros.
Apply AbsSmall_minus.
Apply H5.
Generalize (HN m H3).
Intro HmN.
*)

(* Tex_Prose
The limit of $f$ in $(p,p')$ is $l$ if $\forall e\in\RR (0< e) \rightarrow
\exists d\in\RR (0< d) /\ \forall x\in\RR(-d<p-x < d<) \rightarrow
(-d<p'-y < d<) \rightarrow(AbsSmall -e <l-f(x,y) <e)$.
*)

(* Begin_Tex_Verb *)
Definition funLim2 [p,p',l:IR] : CProp :=
  (e:IR)(Zero [<] e)->
    {d:IR & (Zero [<] d) |
               (x,y:IR)(AbsSmall d (p[-]x)) -> (AbsSmall d (p'[-]y))
                        ->(AbsSmall e (l[-](f2 x y)))}.
(* End_Tex_Verb *)

(* Tex_Prose
The function $f$ is continuous at $p$ if the limit of $f(x)$ as $x$ goes to $p$
is $f(p)$.  This is the $\epsilon/\delta$ definition.
We also give the defintion with limits of Cauchy sequences.
*)

(* Begin_Tex_Verb *)
Definition continAt [p:IR]: CProp := (funLim p (f p)).
Definition continAtCauchy [p:IR]: CProp := (funLim_Cauchy p (f p)).
Definition continAt2 [p,q:IR]: CProp := (funLim2 p q (f2 p q)).
(* End_Tex_Verb *)

(*
Ax_iom continAt_prop1 :(p:IR)(continAt p)->(continAtCauchy p).
*)

(* Begin_Tex_Verb *)
Definition contin : CProp :=      (x:IR)(continAt x).
Definition continCauchy :CProp := (x:IR)(continAtCauchy x).
Definition contin2 :CProp :=      (x,y:IR)(continAt2 x y).
(* End_Tex_Verb *)

(* Tex_Prose
Continuous on a closed, resp.\ open, resp.\ left open, resp.\ left closed
interval
*)

(* Begin_Tex_Verb *)
Definition continOnc [a,b:IR]: CProp :=
  (x:IR)(Intclr a b x) -> (continAt x).
Definition continOno [a,b:IR]: CProp :=
  (x:IR)(Intolr a b x) -> (continAt x).
Definition continOnol [a:IR]: CProp :=
  (x:IR)(Intol a x) -> (continAt x).
Definition continOncl [a:IR]: CProp :=
  (x:IR)(Intcl a x) -> (continAt x).
(* End_Tex_Verb *)

(*
Section Sequence_and_function_limits.

(* _Tex_Prose
If $\lim_{x->p} (f x) = l$, then for every sequence $p_n$ whose
limit is $p$, $\lim_{n->\infty} f (p_n) =l$.
 *)
(* _Begin_Tex_Verb *)
Lemma funLim_SeqLimit:
  (p,l:IR)(fl:(funLim p l))
    (pn:nat->IR)(sl:(SeqLimit pn p)) (SeqLimit ([n:nat](f (pn n))) l).
(* _End_Tex_Verb *)
Proof.
Intros; Unfold seqLimit.
Intros eps epos.
Elim (fl ? epos); Intros del dh; Elim dh; Intros H0 H1.
Elim (sl ? H0); Intros N Nh.
Exists N. Intros m leNm.
Apply AbsSmall_minus.
Apply H1.
Apply AbsSmall_minus.
Apply (Nh ? leNm).
Qed.

(**** Is the converse constructively provable? **
Lemma SeqLimit_funLim:
  (p,l:IR)((pn:nat->IR)(sl:(SeqLimit pn p)) (SeqLimit ([n:nat](f (pn n))) l)) ->
    (funLim p l).
****)

(* _Tex_Prose
Now the same Lemma in terms of Cauchy sequences: if $\lim_{x->p} (f x) = l$,
then for every Cauchy sequence $s_n$ whose
limit is $p$, $\lim_{n->\infty} f (s_n) =l$.
 *)
(* _Begin_Tex_Verb *)
Ax_iom funLim_isCauchy:
  (p,l:IR)(funLim p l)->(s:CauchySeqR)((Lim s)[=] p) ->
	(e:IR)(Zero [<] e) -> (Ex [N:nat](m:nat)(le N m)
			   -> (AbsSmall e ((s m)[-](s N)))).
(* _End_Tex_Verb *)

End Sequence_and_function_limits.

Section Monotonic_functions.
(* _Begin_Tex_Verb *)
Definition str_monot  := (x,y:IR)(x[<]y)->((f x)[<](f y)).

Definition str_monotOnc  := [a,b:IR]
         (x,y:IR)(Intclr a b x)->(Intclr a b y)
                  ->(x[<]y)->((f x)[<](f y)).

Definition str_monotOncl  := [a:IR]
         (x,y:IR)(Intcl a x)->(Intcl a y)
                  ->(x[<]y)->((f x)[<](f y)).

Definition str_monotOnol  := [a:IR]
         (x,y:IR)(Intol a x)->(Intol a y)
                  ->(x[<]y)->((f x)[<](f y)).
(* _End_Tex_Verb *)

(* Following probably not needed for the FTA proof;
it stated that strong monotonicity on a closed interval implies that the
intermediate value theorem holds on this interval. For FTA we need IVT on
$[0,\infty>$.
*)
Ax_iom strmonc_imp_ivt :(a,b:IR)(str_monotOnc a b)
             -> (x,y:IR)(x[<]y)->(Intclr a b x)->(Intclr a b y)
                 -> ((f x)[<]Zero) -> (Zero [<] (f y))
                     -> (EX z:IR | (Intclr x y z)/\((f z)[=]Zero)).
(* _Tex_Prose
$\forall c\in\RR (f\mbox{ strongly monotonic on }[c,\infty>)
\rightarrow \forall a,b\in\RR(c <a)\rightarrow( c< b)\rightarrow\ (f (a)<0)
\rightarrow\ (0:<f(b))
         \rightarrow \forall x,y\in\RR (a\leq x\leq b)\rightarrow
	(a\leq y\leq b)\rightarrow (x<y)
                \rightarrow \exists z\in\RR(x\leq z\leq y)\wedge(f(z)\noto 0))$
*)
(* _Begin_Tex_Verb *)
Ax_iom strmon_ivt_prem : (c:IR)(str_monotOncl c) ->
  (a,b:IR)(Intcl c a)->(Intcl c b)-> ((f a)[<] Zero) -> (Zero [<](f b))
         -> (x,y:IR)(Intclr a b x)->(Intclr a b y) -> (x[<]y)
                ->(EX z:IR | (Intclr x y z)/\((f z)[#]Zero)).
(* _End_Tex_Verb *)

(* The following is lemma 5.8 from the skeleton *)
(* _Tex_Prose
$\forall c\in\RR (f\mbox{ strongly monotonic on }[c,\infty>)
\rightarrow \forall a,b\in\RR(a<b) \rightarrow(c <a)\rightarrow( c< b)
\rightarrow(f (a)<0)\rightarrow (0:<f(b))
         \rightarrow \exists z\in\RR(a\leq z\leq b)\wedge(f(z)= 0))$
*)
(* _Begin_Tex_Verb *)
Ax_iom strmoncl_imp_ivt : (c:IR)(str_monotOncl c)
             -> (a,b:IR)(a[<]b)->(Intcl c a)->(Intcl c b)
                 -> ((f a)[<]Zero) -> (Zero [<] (f b))
                     -> (EX z:IR | (Intclr a b z)/\ ((f z)[=]Zero)).
(* _End_Tex_Verb *)
End Monotonic_functions.

*)
End Continuity.

Implicit Arguments Off.


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

(** ** Object-level encoding of bounded universal quantification II *)

Require Import Arith Nat Omega List Bool Setoid.
Require Import utils_tac gcd prime binomial sums bool_nat luca.
Require Import cipher dio_logic dio_expo dio_binary.

Set Implicit Arguments.

Local Infix "≲" := binary_le (at level 70, no associativity).
Local Notation power := (mscal mult 1).
Local Notation "∑" := (msum plus 0).
Local Infix "⇣" := nat_meet (at level 40, left associativity).
Local Infix "⇡" := nat_join (at level 50, left associativity).

Theorem seqs_of_ones_diophantine l q u u1 : 𝔻P l -> 𝔻P q -> 𝔻P u -> 𝔻P u1
          -> 𝔻R (fun v => seqs_of_ones (l v) (q v) (u v) (u1 v)).
Proof.
  intros.
  apply dio_rel_equiv with (1 := fun v => seqs_of_ones_dio (l v) (q v) (u v) (u1 v)).
  dio_rel_auto.
Defined.

Hint Resolve seqs_of_ones_diophantine.

(* a is the q-cipher of some l-tuple *)

Theorem Code_diophantine l q a : 𝔻P l -> 𝔻P q -> 𝔻P a
                              -> 𝔻R (fun v => Code (l v) (q v) (a v)).
Proof.
  intros.
  apply dio_rel_equiv with (1 := fun v => Code_dio (l v) (q v) (a v)).
  dio_rel_auto.
Defined.

Hint Resolve Code_diophantine.

(* c is the q-cipher of the l-tuple <x,...,x> *)

Theorem Const_diophantine l q c x : 𝔻P l -> 𝔻P q -> 𝔻P c -> 𝔻P x
                                 -> 𝔻R (fun v => Const (l v) (q v) (c v) (x v)).
Proof.
  intros.
  apply dio_rel_equiv with (1 := fun v => Const_dio (l v) (q v) (c v) (x v)).
  dio_rel_auto.
Defined.

Hint Resolve Const_diophantine.

(* a is the q-cipher of the l-tuple <0,...,l-1> *)

Theorem CodeNat_diophantine l q a : 𝔻P l -> 𝔻P q -> 𝔻P a -> 𝔻R (fun v => CodeNat (l v) (q v) (a v)).
Proof.
  intros.
  apply dio_rel_equiv with (1 := fun v => CodeNat_dio (l v) (q v) (a v)).
  dio_rel_auto.
Defined.

Hint Resolve CodeNat_diophantine.

(* Testing whether a is the q cipher of the sum of the tuples of q-ciphers b and c *)

Theorem Code_plus_diophantine a b c : 𝔻P a -> 𝔻P b -> 𝔻P c
                                   -> 𝔻R (fun v => Code_plus (a v) (b v) (c v)).
Proof. intros; unfold Code_plus; dio_rel_auto. Defined.

(* Testing whether a is the q cipher of the product of the tuples of q-ciphers b and c *)

Theorem Code_mult_diophantine l q a b c : 𝔻P l -> 𝔻P q -> 𝔻P a -> 𝔻P b -> 𝔻P c
                                       -> 𝔻R (fun v => Code_mult (l v) (q v) (a v) (b v) (c v)).
Proof. intros; unfold Code_mult; dio_rel_auto. Defined.

Hint Resolve Code_plus_diophantine Code_mult_diophantine.

(** Now we have diophantine representations of q-cipher of the following l-tuple

    1) <x,...,x>  (for x < 2^q)
    2) <0,...,l-1>
    3) testing whether some code is a q-cipher of some tuple
    4) testing sum and product equality among q-ciphers

*)