Require Import lang_spec.
Require Import lang_ops.
Require Import lang_rels.
Require Import logic.
Require Import typing_rels.
Require Import EvalContexts.
Require Import TypingContexts.
Require Import VarSet.

Require Import List.
Import ListNotations.

Theorem config_gammas_disjoint
  : forall G G' : ty_ctx,
    forall C : config,
    forall prf : config_has_type G C G',
      disj_vars G G'.
Proof.
  intros G G' C prf.
  induction prf.
    + unfold ctx_union in *.
      pose (prf := mutuallydisjoint_gets g1 g2 g g1_g2 (disj_vars_sym g g1 g_g1)).
      apply disj_vars_sym in prf.
      exact prf.
      pose (prf3 := disj_vars_sym g g2 g_g2).
      exact prf3.
    + unfold disj_vars in *.
      simpl in *.
      rewrite -> (union_with_empty (VarSet.singleton x)).
      rewrite -> axiom_inter_sym.
      exact disj_prf.
    + unfold disj_vars in *.
      simpl.
      pose (subset_prf := restriction_makes_subset g' x).
      pose (bound_subset := inter_with_subset (bound_variables g)
                                              (bound_variables g')
                                              (bound_variables (g' -- x))
                                              subset_prf).
      exact (subset_of_empty (VarSet.inter (bound_variables g) (bound_variables g'))
                             (VarSet.inter (bound_variables g) (bound_variables (g' -- x)))
                             IHprf bound_subset).
    + unfold coerce_judgement_to_ty_ctx in *.
      simpl.
      unfold disj_vars in *.
      rewrite -> (union_with_empty (VarSet.singleton x)).
      rewrite -> axiom_inter_sym.
      exact x_gfree.
    + simpl. rewrite -> union_with_empty.
      pose (disj_xy := neq_means_disjoint x y x_not_y).
      unfold disj_vars in *.
      rewrite -> axiom_inter_sym in x_gfree.
      rewrite -> axiom_inter_sym in y_gfree.
      exact (mdisj_rassoc g (VarSet.singleton x) (VarSet.singleton y)
                          x_gfree y_gfree disj_xy).
    + unfold disj_vars in *.
      simpl in *.
      rewrite -> (union_with_empty (VarSet.singleton y)).
      rewrite -> axiom_inter_sym.
      exact y_gfree.
Qed.

Theorem typing_describes_declvars :
  forall g g': ty_ctx,
  forall c : config,
  forall ty_prf : config_has_type g c g',
    (bound_variables g') = (config_declvars c).
Proof.
  intros.
  induction ty_prf.
  +simpl.
    rewrite -> (bound_of_union_is_union_of_bound g1 g2 g1_g2).
    rewrite -> IHty_prf1.
    rewrite -> IHty_prf2.
    rewrite -> (axiom_union_sym (config_declvars c2) (config_declvars c1)).
    reflexivity.
  + simpl. apply union_with_empty.
  + simpl. rewrite -> bound_of_restr. rewrite -> IHty_prf. reflexivity.
  + simpl. apply union_with_empty.
  + simpl. rewrite -> union_with_empty. rewrite -> axiom_union_sym. reflexivity.
  + simpl. rewrite -> union_with_empty. reflexivity.
Qed.

Theorem typed_means_freevar :
  forall g g' : ty_ctx,
  forall c : config,
  forall typing_proof : config_has_type g c g',
  forall v : var,
  forall v_in_g' : VarSet.In v (bound_variables g'),
    VarSet.In v (config_freevars c).
Proof.
  intros g g' c ty_prf v.
  generalize dependent g.
  generalize dependent g'.
  induction c.
  + intros.
    inversion ty_prf as [g0 g1 g2 c0 c3 disj_01 disj_02 disj_12 prf_g2 prf_g1
                        | | | | | ].
    rewrite <- H2 in *.
    clear H H0 H1 H2 c0 c3.
    simpl.
    destruct (in_union_means_in_one g1 g2 v disj_12 v_in_g') as [inl | inr].
    {
      pose (foo := IHc2 g1 (ctx_union g g2 disj_02) prf_g1 inl).
      rewrite -> axiom_union_sym.
      exact (inl_means_in_union v (config_freevars c2) (config_freevars c1) foo).
    }
    {
      pose (foo := IHc1 g2 (ctx_union g g1 disj_01) prf_g2 inr).
      exact (inl_means_in_union v (config_freevars c1) (config_freevars c2) foo).
    }
  + intros.
    simpl.
    rename g' into g'x.
    rename v_in_g' into v_in_g'x.
    inversion ty_prf as [ | | g0 g' c0 x0 prf_g' | | | ].
    rewrite <- H2 in *.
    clear H0 H1 H2 x0 H g0.
    assert (v_eq_x
            : (v = x)
              -> VarSet.In v (VarSet.diff (config_freevars c) (VarSet.singleton x))). {
      intros v_eq_x.
      rewrite -> v_eq_x in *.
      pose (v_notin_g'x := restriction_makes_variable_notin g' x).
      contradiction.
    }
    assert (v_neq_x
            : ~(v = x)
              -> VarSet.In v (VarSet.diff (config_freevars c) (VarSet.singleton x))). {
      clear v_eq_x.
      intros v_neq_x.
      destruct (in_restr_ifnot_same v x v_neq_x g') as [a1 _].
      pose (arg := a1 v_in_g'x).
      pose (arg2 := IHc g' g prf_g' arg).
      destruct (in_diff_ifnot_same v x v_neq_x (config_freevars c)) as [f1 _].
      exact (f1 arg2).
    }
    (* TODO: I have A -> goal, ~A -> goal. I just need to figure out how to compose those
       to get the goal *)
    admit.
  + intros. simpl.
    inversion ty_prf as [ | g0 x0 t val | | | | ].
    rewrite <- H1 in *.
    rewrite <- H2 in *.
    clear H H0 H1 v0 g0 x0 H2 disj_prf vprf ty_prf.
    pose (v_eq_x := var_in_singletonctx_means_equal v x (Ref t) v_in_g').
    rewrite -> v_eq_x.
    exact (inl_means_in_union x (VarSet.singleton x) (expr_freevars val) (in_singleton x)).
  + intros.
    simpl.
    inversion ty_prf as [ | | | g0 x0 t e0 x_gfree _ | | ].
    rewrite <- H2 in *.
    clear H H0 H1 H2 g0 x0 e0.
    pose (v_eq_x := var_in_singletonctx_means_equal v x t v_in_g').
    rewrite -> v_eq_x.
    rewrite -> axiom_union_sym.
    exact (inl_means_in_union x (VarSet.singleton x) (expr_freevars e) (in_singleton x)).
  + intros. simpl.
    inversion ty_prf as [| | | | g0 x0 y0 t x_not_y x_gfree y_gfree H0 H1 H2 |].
    rewrite <- H2 in *.
    clear H H1 H0 x0 y0 g0 x_gfree y_gfree x_not_y ty_prf H2.
    destruct (var_in_doubletonctx_means_equal_oneof v x y t (t >> Unit) v_in_g') as [v_eq_x | v_eq_y].
    {
      rewrite -> axiom_union_sym. rewrite -> v_eq_x.
      exact (inl_means_in_union x (VarSet.singleton x) (VarSet.singleton y) (in_singleton x)).
    }
    {
      rewrite -> v_eq_y.
      exact (inl_means_in_union y (VarSet.singleton y) (VarSet.singleton x) (in_singleton y)).
    }
  + intros. simpl.
    inversion ty_prf as [| | | | | g0 y0 t _].
    clear H H0 H1 ty_prf.
    pose (v_eq_y := var_in_singletonctx_means_equal v y (t >> Unit) v_in_g').
    rewrite -> v_eq_y.
    exact (in_singleton y).
Admitted.

Theorem var_in_doubletonctx_means_equal_oneof :
  forall v v1 v2 : var,
  forall t1 t2 : type,
  forall v_in_doubleton : VarSet.In v (bound_variables (ctxu (judge v1 t1) (judge v2 t2))),
    (v = v1) \/ (v = v2).
Proof. Admitted.

Theorem Congruence_Preserves_Typing
  : forall g g': ty_ctx, forall c1 c2 : config,
    forall ty_prf : config_has_type g c1 g', forall cong_prf : structcong c1 c2,
    (config_has_type g c2 g').
Proof.

  intros G G'.
  intros C_Orig C_Final ty_prf cong_prf.
  destruct cong_prf.
  + inversion ty_prf as [g0 g1 g2 cc0 cc1
                            disj_01 disj_02 disj_12
                            prf_c1 prf_c2  is_g0_G
                            tr1 tr2
                        | | | | | ].
    clear tr1 tr2 H is_g0_G.
    pose (witness := ty_config_par G g2 g1 c2 c1 disj_02 disj_01
                                   (disj_vars_sym g1 g2 disj_12)
                                   prf_c2 prf_c1).
    unfold ctx_union in *.
    rewrite -> ctxu_sym.
    assumption.
  + inversion ty_prf as [g0 g1 g2 c0 c4
                            disj_g01 disj_g02 disj_g12
                            prf_g2 prf_g1
                        | | | | |].
    clear g0 c0 c4 H H0 H1 H2 ty_prf.

    inversion prf_g2 as [ g g2a g2b
                            c0 c4
                            disj_g01_2a disj_g01_2b disj_g2a2b
                            prf_g2b prf_g2a
                        | | | | |].

    clear g c0 c4 H H0 H1.
    rename H2 into g2_is_join2a2b.
    unfold ctx_union in *. rewrite <- g2_is_join2a2b.
    symmetry in g2_is_join2a2b.
    rewrite -> g2_is_join2a2b in prf_g1. rewrite -> (ctxu_sym g2a g2b) in prf_g1.
        rewrite -> ctxu_assoc in prf_g1.
    rewrite <- (ctxu_assoc) in prf_g2a. rewrite -> (ctxu_sym g1 g2b) in prf_g2a.
        rewrite -> (ctxu_assoc) in prf_g2a.

    pose (g2_is_join2b2a := g2_is_join2a2b). rewrite -> ctxu_sym in g2_is_join2b2a.
    pose (disj_g1_2b := ctxu_subset g1 g2 g2b g2a g2_is_join2b2a disj_g12).
    pose (disj_g0_2b := ctxu_subset G g2 g2b g2a g2_is_join2b2a disj_g02).
    pose (disj_g_g2b_g1 := mutuallydisjoint_gets G g2b g1 disj_g0_2b disj_g01
                                                  (disj_vars_sym g1 g2b disj_g1_2b)).

    pose (disj_g1_2a := ctxu_subset g1 g2 g2a g2b g2_is_join2a2b disj_g12).
    pose (disj_g0_2a := ctxu_subset G g2 g2a g2b g2_is_join2a2b disj_g02).
    pose (disj_g_g2b_g2a := mutuallydisjoint_gets G g2b g2a disj_g0_2b disj_g0_2a
                                                  (disj_vars_sym g2a g2b disj_g2a2b)).

    pose (new_prf' := ty_config_par (ctxu G g2b) g1 g2a c2 c3
                                   disj_g_g2b_g1 disj_g_g2b_g2a
                                   disj_g1_2a).
    unfold ctx_union in new_prf'.
    pose (new_prf := new_prf' prf_g2a prf_g1). unfold new_prf' in new_prf. clear new_prf'.

    pose (arg1 := (mutuallydisjoint_getsv2 G g1 g2a disj_g01 disj_g0_2a disj_g1_2a)).
    pose (arg2 := (mutuallydisjoint_gets g1 g2a g2b disj_g1_2a disj_g1_2b disj_g2a2b)).
    rewrite <- ctxu_assoc in prf_g2b.
    pose (final_prf := ty_config_par G (ctxu g1 g2a) g2b c1 (c2 $$ c3)
                                     arg1 disj_g0_2b arg2 prf_g2b new_prf).
    unfold ctx_union in final_prf.
    rewrite <- ctxu_assoc in final_prf.
    exact final_prf.
  + inversion ty_prf as [ | | g gx c0 x ty_prf_v2 H H0 | | | ].
    clear H H0 H1 c0.
    rewrite <- H2 in *. clear H2.
    inversion ty_prf_v2 as [ | | g2 g' c02 x2 ty_prf_all H2 H02 | | | ].
    rewrite <- H1 in *.
    clear H H1 c02 H2 H02 x2 g2 G' g gx x ty_prf.

    pose (ty_prf_v1 := ty_config_reserveplace G g' c v1 ty_prf_all).
    pose (ty_prf_v1_v2 := ty_config_reserveplace G (g' -- v1) (v1 ** c) v2 ty_prf_v1).

    rewrite -> restriction_commutative in ty_prf_v1_v2.
    exact ty_prf_v1_v2.

  + inversion ty_prf as [g0 g1 g2v c0 c3 disj_01 disj_02v disj_12v prf_g2v prf_g1 | | | | | ].
    clear H H0 H1 H2 c0 c3 ty_prf G' g0.
    inversion prf_g2v as [ | | g g2 c x prf_g2 | | | ].
    clear H H0 H1 g x c.

    assert (v_notin_g1
            : ~ (VarSet.In v (bound_variables g1))). {
        pose (contrap := typed_means_freevar (ctx_union G g2v disj_02v) g1 c2 prf_g1 v).
        destruct (contrapositive (VarSet.In v g1) (VarSet.In v (config_freevars c2))) as [prop  _].
        pose (almost := prop contrap).
        Set Printing Coercions.
        unfold var_to_varset in vfree.
        destruct (disj_var_singleton_means_notin v (config_freevars c2)) as [_ notin_fn].
        exact (almost (notin_fn vfree)).
    }

    assert (if_v_in_g2
            : (VarSet.In v g2)
              -> config_has_type G (v ** (c1 $$ c2)) (ctx_union g1 g2v disj_12v)).
    {
      intros v_in_g2.
      pose (new_disj := config_gammas_disjoint (ctx_union G g1 disj_01) g2 c1 prf_g2).
      pose (v_notin_union := in_only_one_of_disjoint (ctx_union G g1 disj_01)
                                                     g2 v v_in_g2 new_disj).
      rewrite -> bound_of_union_is_union_of_bound in v_notin_union.
      pose (v_notin := notin_union_means_notin_either (bound_variables G) (bound_variables g1)
                                                      v v_notin_union).
      destruct v_notin as [v_notin_G _].
      clear new_disj v_notin_union.
      pose (newprf_g1_int := prf_g1).
      symmetry in H2.
      pose (disj_02 := disj_notin_means_disj_with_added G g2 g2v v
                                                         v_notin_G disj_02v H2).
      pose (disj_12 := disj_notin_means_disj_with_added g1 g2 g2v v
                                                        v_notin_g1 disj_12v H2).
      pose (rw_util := (ctx_union_with_restriction G g2 g2v v v_notin_G H2 disj_02v
                                                   disj_02)).
      rewrite -> rw_util in newprf_g1_int.
      pose (new_prf_g1 := config_ty_weakening (ctxu G g2) g1 c2 v newprf_g1_int).

      pose (new_config_par := ty_config_par G g1 g2 c1 c2 disj_01 disj_02 disj_12
                                            prf_g2 new_prf_g1).
      pose (finalprf := ty_config_reserveplace G (ctx_union g1 g2 disj_12) (c1 $$ c2) v
                                               new_config_par).
      pose (new_disj12v := disj_12v).
      rewrite -> H2 in new_disj12v.
      pose (restr_cfgs_same := restriction_from_union_where_notin_one g1 g2 v v_notin_g1
                                                                      disj_12 new_disj12v).
      rewrite -> restr_cfgs_same in finalprf.
      clear restr_cfgs_same rw_util.
      (* TODO At this point the proof is actually done but for unfolding the definition
         of g2subv... Unfortunately the way I've set up disjoint proofs is really difficult
         to work with, so I'm going to leave this for later

         But anyways, I really should be able to just do an "exact finalprf" here
       *)
      admit.
    }

    assert (if_v_notin_g2
            : ~(VarSet.In v g2)
              -> config_has_type G (v ** (c1 $$ c2)) (ctx_union g1 g2v disj_12v)). {
      clear if_v_in_g2.
      intros v_notin_g2.
      rewrite <- H2 in *.
      pose (eq_g2_g2v := restr_of_notin_makes_equal g2 v v_notin_g2).
      rewrite -> H2 in *. clear H2.

      pose (disj_02 := disj_02v).
      pose (disj_12 := disj_12v).
      rewrite <- eq_g2_g2v in disj_02.
      rewrite <- eq_g2_g2v in disj_12.

      pose (new_prf := ty_config_par G g1 g2 c1 c2 disj_01 disj_02 disj_12 prf_g2).
      (* TODO The proof is so close to being done: the fact that
         (v /in g1, v/in g2 -> (ctx_union g1 (g2 --v) disj_12v) = (ctx_union g1 g2 disj_12))

         Along with the fact that (g2 = g2v) applied in the first argument of new_prf.

        Anyways, these complete the proof. However, manipulating the
        disjointness proofs continues to be a huge source of pain so I'm going
        to admit it for now :|
       *)
      admit.

Admitted.

Theorem Subject_Reduction :
  forall G G' : ty_ctx,
  forall C1 C2 : config,
  forall G_C1_G' : config_has_type G C1 G',
  forall C1_StepsTo_C2 : OperationalStepsTo C1 C2,
    config_has_type G C2 G'.
Proof.
  Admitted.


(** * Category of flds *)
(** ** Contents
- Precategory of flds
- Category of flds
 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.Foundations.UnivalenceAxiom.

Require Import UniMath.Algebra.BinaryOperations.
Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.RigsAndRings.
Require Import UniMath.Algebra.Domains_and_Fields.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Local Open Scope cat.

(** * Precategory of flds *)
Section def_fld_precategory.

  Definition fld_fun_space (A B : fld) : hSet := make_hSet (ringfun A B) (isasetrigfun A B).

  Definition fld_precategory_ob_mor : precategory_ob_mor :=
    tpair (λ ob : UU, ob -> ob -> UU) fld (λ A B : fld, fld_fun_space A B).

  Definition fld_precategory_data : precategory_data :=
    make_precategory_data
      fld_precategory_ob_mor (λ (X : fld), (rigisotorigfun (idrigiso X)))
      (fun (X Y Z : fld) (f : ringfun X Y) (g : ringfun Y Z) => rigfuncomp f g).

  Local Lemma fld_id_left (X Y : fld) (f : ringfun X Y) :
    rigfuncomp (rigisotorigfun (idrigiso X)) f = f.
  Proof.
    use rigfun_paths. apply idpath.
  Defined.
  Opaque fld_id_left.

  Local Lemma fld_id_right (X Y : fld) (f : ringfun X Y) :
    rigfuncomp f (rigisotorigfun (idrigiso Y)) = f.
  Proof.
    use rigfun_paths. apply idpath.
  Defined.
  Opaque fld_id_right.

  Local Lemma fld_assoc (X Y Z W : fld) (f : ringfun X Y) (g : ringfun Y Z) (h : ringfun Z W) :
    rigfuncomp f (rigfuncomp g h) = rigfuncomp (rigfuncomp f g) h.
  Proof.
    use rigfun_paths. apply idpath.
  Defined.
  Opaque fld_assoc.

  Lemma is_precategory_fld_precategory_data : is_precategory fld_precategory_data.
  Proof.
    use make_is_precategory_one_assoc.
    - intros a b f. use fld_id_left.
    - intros a b f. use fld_id_right.
    - intros a b c d f g h. use fld_assoc.
  Qed.

  Definition fld_precategory : precategory :=
    make_precategory fld_precategory_data is_precategory_fld_precategory_data.

  Lemma has_homsets_fld_precategory : has_homsets fld_precategory.
  Proof.
    intros X Y. use isasetrigfun.
  Qed.

End def_fld_precategory.

(** * Category of flds *)
Section def_fld_category.

  Definition fld_category : category := make_category _ has_homsets_fld_precategory.

  (** ** (rigiso X Y) ≃ (z_iso X Y) *)

  Lemma fld_iso_is_equiv (A B : ob fld_category) (f : z_iso A B) : isweq (pr1 (pr1 f)).
  Proof.
    use isweq_iso.
    - exact (pr1rigfun _ _ (inv_from_z_iso f)).
    - intros x.
      use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_inv_after_z_iso f)) x).
      intros x0. use isapropisrigfun.
    - intros x.
      use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_after_z_iso_inv f)) x).
      intros x0. use isapropisrigfun.
  Defined.
  Opaque fld_iso_is_equiv.

  Lemma fld_iso_equiv (X Y : ob fld_category) : z_iso X Y -> ringiso (X : fld) (Y : fld).
  Proof.
    intro f.
    use make_ringiso.
    - exact (make_weq (pr1 (pr1 f)) (fld_iso_is_equiv X Y f)).
    - exact (pr2 (pr1 f)).
  Defined.

  Lemma fld_equiv_is_z_iso (X Y : ob fld_category) (f : ringiso (X : fld) (Y : fld)) :
    @is_z_isomorphism fld_category X Y (ringfunconstr (pr2 f)).
  Proof.
    exists (ringfunconstr (pr2 (invrigiso f))).
    use make_is_inverse_in_precat.
    - use rigfun_paths. use funextfun. intros x. use homotinvweqweq.
    - use rigfun_paths. use funextfun. intros y. use homotweqinvweq.
  Defined.
  Opaque fld_equiv_is_z_iso.

  Lemma fld_equiv_iso (X Y : ob fld_category) : ringiso (X : fld) (Y : fld) -> z_iso X Y.
  Proof.
    intros f. exact (_,,fld_equiv_is_z_iso X Y f).
  Defined.

  Lemma fld_iso_equiv_is_equiv (X Y : fld_category) : isweq (fld_iso_equiv X Y).
  Proof.
    use isweq_iso.
    - exact (fld_equiv_iso X Y).
    - intros x. use z_iso_eq. use rigfun_paths. apply idpath.
    - intros y. use rigiso_paths. use subtypePath.
      + intros x0. use isapropisweq.
      + apply idpath.
  Defined.
  Opaque fld_iso_equiv_is_equiv.

  Definition fld_iso_equiv_weq (X Y : ob fld_category) :
    weq (z_iso X Y) (ringiso (X : fld) (Y : fld)).
  Proof.
    use make_weq.
    - exact (fld_iso_equiv X Y).
    - exact (fld_iso_equiv_is_equiv X Y).
  Defined.

  Lemma fld_equiv_iso_is_equiv (X Y : ob fld_category) : isweq (fld_equiv_iso X Y).
  Proof.
    use isweq_iso.
    - exact (fld_iso_equiv X Y).
    - intros y. use rigiso_paths. use subtypePath.
      + intros x0. use isapropisweq.
      + apply idpath.
    - intros x. use z_iso_eq. use rigfun_paths. apply idpath.
  Defined.
  Opaque fld_equiv_iso_is_equiv.

  Definition fld_equiv_weq_iso (X Y : ob fld_category) :
    (ringiso (X : fld) (Y : fld)) ≃ (z_iso X Y).
  Proof.
    use make_weq.
    - exact (fld_equiv_iso X Y).
    - exact (fld_equiv_iso_is_equiv X Y).
  Defined.

  (** ** Category of flds *)

  Definition fld_category_isweq (X Y : ob fld_category) : isweq (λ p : X = Y, idtoiso p).
  Proof.
    use (@isweqhomot
           (X = Y) (z_iso X Y)
           (pr1weq (weqcomp (fld_univalence X Y) (fld_equiv_weq_iso X Y)))
           _ _ (weqproperty (weqcomp (fld_univalence X Y) (fld_equiv_weq_iso X Y)))).
    intros e. induction e.
    use (pathscomp0 weqcomp_to_funcomp_app).
    use total2_paths_f.
    - apply idpath.
    - use proofirrelevance. use isaprop_is_z_isomorphism.
  Defined.
  Opaque fld_category_isweq.

  Definition fld_category_is_univalent : is_univalent fld_category.
  Proof.
    intros X Y. exact (fld_category_isweq X Y).
  Defined.

  Definition fld_univalent_category : univalent_category
    := make_univalent_category fld_category fld_category_is_univalent.

End def_fld_category.


(*|
###################################
Step by step simplification in Coq?
###################################

:Link: https://stackoverflow.com/q/39355817
|*)

(*|
Question
********

Is there a way to simplify one step at a time?

Say you have ``f1 (f2 x)`` both of which can be simplified in turn via
a single ``simpl``, is it possible to simplify ``f2 x`` as a first
step, examine the intermediate result and then simplify ``f1``?

Take for example the theorem:
|*)

Theorem pred_length : forall n : nat, forall l : list nat,
    pred (length (n :: l)) = length l.
Proof.
  intros. simpl. reflexivity.
Qed.

(*|
The ``simpl`` tactic simplifies ``Nat.pred (length (n :: l))`` to
``length l``. Is there a way to break that into a two step
simplification i.e:

.. code-block:: coq

    Nat.pred (length (n :: l)) --> Nat.pred (S (length l)) --> length l
|*)

(*|
Answer (ichistmeinname)
***********************

You can also use ``simpl`` for a specific pattern.
|*)

Reset pred_length. (* .none *)
Theorem pred_length : forall n : nat, forall l : list nat,
    pred (length (n :: l)) = length l.
Proof.
 intros. simpl length. simpl pred. reflexivity.
Qed.

(*|
In case you have several occurrences of a pattern like ``length`` that
could be simplified, you can further restrict the outcome of the
simplification by giving a position of that occurrence (from left to
right), e.g. ``simpl length at 1`` or ``simpl length at 2`` for the
first or second occurrence.

----

**Q:** That's very useful! But I see that this simplifies all what it
is within the pattern. For example ``f (g x)`` with ``simpl f.`` will
also simplify using ``g`` definition. Is is possible to instruct coq,
in this example case, to just use ``f`` definition to simplify, and
let ``g x`` as it is?
|*)

(*|
Answer (Anton Trunov)
*********************

We can turn simplification for ``pred`` off, simplify its argument and
turn it back on:
|*)

Reset pred_length. (* .none *)
Theorem pred_length : forall n : nat, forall l : list nat,
    pred (length (n :: l)) = length l.
Proof.
  intros.
  Arguments pred : simpl never. (* do not unfold pred *)
  simpl.
  Arguments pred : simpl nomatch. (* unfold if extra simplification is possible *)
  simpl.
  reflexivity.
Qed.

(*|
See `§8.7.4
<https://coq.inria.fr/distrib/current/refman/Reference-Manual010.html#Conversion-tactics>`__
of the Reference Manual for more details.
|*)


From Coq Require Import
     ssreflect
.

From ExtensibleCompiler.Theory Require Import
     IndexedAlgebra
     IndexedFunctor
     IndexedSubFunctor
     IndexedSum1
     UniversalProperty
.

Local Open Scope SubFunctor.
Local Open Scope Sum1.

Class IndexedProofAlgebra (* cf. [iPAlgebra] *)
      (Tag : Set) {I} F `{IndexedFunctor I F} A :=
  {
    indexedProofAlgebra (* cf. [ip_algebra] *)
    : IndexedAlgebra F A;
  }.

Definition indexedProofAlgebra'
           {Tag I F A}
           `{IndexedFunctor I F}
           (PA : IndexedProofAlgebra Tag F A)
  : IndexedAlgebra F A
  := indexedProofAlgebra (IndexedProofAlgebra := PA).

Global Instance
       IndexedProofAlgebra__Sum1
       {Tag I} F G {A}
       `{IndexedFunctor I F} `{IndexedFunctor I G}
       {FAlg : IndexedProofAlgebra Tag F A}
       {GAlg : IndexedProofAlgebra Tag G A}
  : IndexedProofAlgebra Tag (F + G) A
  :=
    {|
      indexedProofAlgebra :=
        fun i fg =>
          match fg with
          | iinl1 f => indexedProofAlgebra i f
          | iinr1 g => indexedProofAlgebra i g
          end
      ;
    |}.

Class WellFormedIndexedProofAlgebra (* cf. [iWF_Ind] *)
      {Tag I F G}
      `{IndexedFunctor I F} `{IndexedFunctor I G}
      `{S : ! IndexedSubFunctor F G}
      {P : forall i, IndexedFix G i -> Prop}
      `(PA : ! IndexedProofAlgebra Tag F (fun i => sig (P i)))
  :=
    {
      indexedProjEq
      : forall i e,
        proj1_sig (indexedProofAlgebra (IndexedProofAlgebra := PA) i e)
        =
        iWrapF i (iInj (IndexedSubFunctor := S) (indexedFmap i (fun i => proj1_sig (P := P i)) e));
    }.

(** TODO: document why we need this *)
Class WellFormedIndexedProofAlgebra2 (* cf. [WF_Ind2] *)
      {Tag I F G H}
      `{IndexedFunctor I F} `{IndexedFunctor I G} `{IndexedFunctor I H}
      `{SG : ! IndexedSubFunctor F G} `{SH : ! IndexedSubFunctor F H}
      {P : forall i, (IndexedFix G i * IndexedFix H i) -> Prop}
      `(PA : ! IndexedProofAlgebra Tag F (fun i => sig (P i)))
  :=
    {
      proj1Eq
      : forall i e,
        fst (proj1_sig (indexedProofAlgebra (IndexedProofAlgebra := PA) i e))
        =
        iWrapF i (iInj (IndexedSubFunctor := SG)
                       (indexedFmap i (fun i e => fst (proj1_sig (P := P i) e)) e));
      proj2Eq
      : forall i e,
        snd (proj1_sig (indexedProofAlgebra (IndexedProofAlgebra := PA) i e))
        =
        iWrapF i (iInj (IndexedSubFunctor := SH)
                       (indexedFmap i (fun i e => snd (proj1_sig (P := P i) e)) e));
    }.


(** * MoreCoq: More About Coq *)

Require Export Poly.

Definition list2pair : forall {X:Type} (x:X), list X -> X*bool :=
  fun X x list =>
     match list with
     | []   => (x, false)
     | a::_ => (a, true)
     end.

Theorem inEqual : forall (x y : nat), [x] = [y] -> x = y.
Proof.
  intros.
  assert ((x, true) = (y, true)).
    apply (f_equal (@list2pair nat x) H).
  apply (f_equal fst H0).
Qed.


Require Import SyntaxProp.
Require Import WellFormednessProp.

Theorem datarace_freedom :
  forall H n id1 id2 this1 this2 L1 L2 Q1 Q2 l1 l2,
    wf_cfg (H, n) ->
    id1 <> id2 ->
    heapLookup H id1 = Some (this1, L1, Q1, EMut (ELoc l1)) ->
    heapLookup H id2 = Some (this2, L2, Q2, EMut (ELoc l2)) ->
    l1 <> l2.
Proof with eauto.
  introv wfCfg Hneq Hlookup1 Hlookup2.
  inverts wfCfg as wfH Hfresh.
  inverts wfH as Hdisj wfActors.
  eapply wfActors in Hlookup1 as wfActor1.
  eapply wfActors in Hlookup2 as wfActor2.
  inverts wfActor1 as _ _ _ Hloc1 _ _.
  inverts wfActor2 as _ _ _ Hloc2 _ _.
  simpls.
  assert (In l1 L1) as HIn1...
  assert (In l2 L2) as HIn2...
  assert (LH H id1 = Some L1) as HLH1
      by (unfolds; rewrite Hlookup1; eauto).
  assert (LH H id2 = Some L2) as HLH2
      by (unfolds; rewrite Hlookup2; eauto).
  specializes Hdisj id1 id2 L1 L2 Hneq.
Qed.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

Set Implicit Arguments.

Require Import FCF.FCF.
Require Import FCF.Admissibility.

Local Open Scope nat_scope.

Class function_cost_model(cost: FunctionCostModel) :={

  cost_ident :
  forall (A : Type),
    cost _ _ (fun (a : A) => a) 0;

  cost_ext :
    forall (A B : Type)(f1 f2 : A -> B) n,
      (forall a, f1 a = f2 a) ->
      cost _ _ f2 n ->
      cost _ _ f1 n;

  cost_const :
    forall (A B : Type)(b : B),
      cost _ _ (fun (_ : A) => b) 0;

  cost_le :
    forall A B (f : A -> B) c1 c2,
      cost _ _ f c1 ->
      c1 <= c2  ->
      cost _ _ f c2;

  cost_compose :
    forall (A B C : Type)
      (f1 : A -> B)(f2 : A -> B -> C) c1 c2 c3,
      cost _ _ f1 c1 ->
      cost _ _ f2 c2 ->
      (forall a, cost _ _ (f2 a) c3) ->
      cost _ _ (fun a => f2 a (f1 a)) (c1 + c2 + c3);

  cost_uncurry_1 :
    forall (A B C : Type)(f : A -> B -> C) n,
      cost _ _ (fun a => f (fst a) (snd a)) n ->
      cost _ _ f n;

  cost_uncurry_2 :
    forall (A B C : Type)(f : A -> B -> C) n,
      cost _ _ (fun a => f (fst a) (snd a)) n ->
      forall a, cost _ _ (f a) n;

  cost_curry :
    forall (A B C : Type)(f : A -> B -> C) c1 c2,
      cost _ _ f c1 ->
      (forall a, cost _ _ (f a) c2) ->
      cost _ _ (fun p => f (fst p) (snd p)) (c1 + c2);

  cost_fst :
    forall (A B : Type),
      cost _ _ (@fst A B) 0;

  cost_snd :
    forall (A B : Type),
      cost _ _ (@snd A B) 0;

  cost_BVxor :
    forall n,
      cost _ _ (fun p => @BVxor n (fst p) (snd p)) n;

  cost_vec_head :
    forall (A : Type) n,
      cost _ _ (@Vector.hd A n) 0;

  cost_eqb_bool :
    cost _ _ (fun (p : bool * bool) => eqb (fst p) (snd p)) 1;

  cost_if_bool :
    forall (A B : Type) (f : A -> bool) (f_so f_not : A -> B) c1 c2 c3,
      cost _ _ f c1 ->
      cost _ _ f_so c2 ->
      cost _ _ f_not c3 ->
      cost _ _ (fun p => if (f p) then (f_so p) else (f_not p)) (c1 + c2 + c3);

  cost_Ret :
    forall (A : Set)(eqd : eq_dec A),
      cost _ _ (Ret eqd) 0;

  cost_OC_Ret :
    forall (A B C: Set),
      cost _ _ (@OC_Ret A B C) 0;

  cost_OC_Bind :
    forall (A B C C' : Set),
      cost _ _ (fun p => (@OC_Bind A B C C' (fst p) (snd p))) 0;

  cost_OC_Query :
    forall (A B : Set),
      cost _ _ (@OC_Query A B) 0;

  cost_OC_Run_1 :
    forall (A B C A' B' S : Set)(eqds : EqDec S)(eqda : EqDec A)(eqdb : EqDec B),
      cost _ _
      (@OC_Run A B C A' B' S eqds eqdb eqda)
      0;

  cost_OC_Run_2 :
    forall (A B C A' B' S : Set)(eqds : EqDec S)(eqda : EqDec A)(eqdb : EqDec B) c,
      cost _ _
      (@OC_Run A B C A' B' S eqds eqdb eqda c)
      0;

  cost_OC_Run_3 :
    forall (A B C A' B' S : Set)(eqds : EqDec S)(eqda : EqDec A)(eqdb : EqDec B) c o,
      cost _ _
      (@OC_Run A B C A' B' S eqds eqdb eqda c o)
      0

}.

Inductive comp_cost(fm : FunctionCostModel) : CompCostModel :=
| comp_cost_Ret :
  forall (A : Set)(eqd : eq_dec A)(a : A),
    comp_cost fm (Ret eqd a) 0
| comp_cost_Bind :
  forall (A B : Set)(c : Comp A)(f : A -> Comp B) x1 x2 x3,
    comp_cost fm c x1 ->
    fm _ _ f x2 ->
    (forall a, comp_cost fm (f a) x3) ->
    comp_cost fm (Bind c f) (x1 + x2 + x3)
| comp_cost_Rnd :
  forall n,
    comp_cost fm (Rnd n) n.

Inductive oc_cost(fm : FunctionCostModel)(cm : CompCostModel) : OC_CostModel :=
| oc_cost_Query :
  forall (A B : Set)(a : A),
    oc_cost fm cm (OC_Query B a) (fun n => n)
| oc_cost_Run :
  forall (A B C : Set)(c : OracleComp A B C) f1,
    oc_cost fm cm c f1 ->
    forall (A' B' S : Set)(eqds : EqDec S)(eqdb : EqDec B)(eqda : EqDec A)
      (o : S -> A -> OracleComp A' B' (B * S)) x1 x2 f2,
      fm _ _ o x1 ->
      (forall x, fm _ _ (o x) x2) ->
      (forall x y, oc_cost fm cm (o x y) f2) ->
      forall s,
        oc_cost fm cm (OC_Run _ _ _ c o s) (fun n => f1 (x1 + x2 + (f2 n)))
| oc_cost_Ret :
  forall (A B C : Set)(c : Comp C) n,
    cm _ c n ->
    oc_cost fm cm (OC_Ret A B c) (fun _ => n)
| oc_cost_Bind :
  forall (A B C C' : Set)(c : OracleComp A B C)(f : C -> OracleComp A B C') f1 x f2,
    oc_cost fm cm c f1 ->
    fm _ _ f x->
    (forall y, oc_cost fm cm (f y) f2) ->
    oc_cost fm cm (OC_Bind c f) (fun n => (f1 n) + x + (f2 n))
| oc_cost_le :
  forall (A B C : Set)(c : OracleComp A B C) f1 f2,
    oc_cost fm cm c f1 ->
    (forall x, f1 x <= f2 x) ->
    oc_cost fm cm c f2.

Section CostTheory.

  Context `{function_cost_model}.

  Theorem cost_compose_unary :
    forall (A B C: Type)
      (f1 : A -> B)(f2 : B ->C) c1 c2,
      cost f1 c1 ->
      cost f2 c2 ->
      cost (fun a => f2 (f1 a)) (c1 + c2).

    intuition.
    eapply cost_le.
    eapply (cost_compose f1 _ ).
    eauto.
    intuition.
    eapply cost_const.
    intuition.
    eauto.
    lia.

  Qed.

  Theorem cost_compose_binary :
    forall (A B C D: Type)
      (f1 : A -> B)(f2 : A ->C)(f3 : B -> C -> D) c1 c2 c3 c4,
      cost f1 c1 ->
      cost f2 c2 ->
      cost f3 c3 ->
      (forall a, cost (f3 a) c4) ->
      cost (fun a => f3 (f1 a) (f2 a)) (c1 + c2 + c3 + c4).

    intuition.
    eapply cost_le.
    eapply (cost_compose f2 (fun a x => f3 (f1 a) x)).
    eauto.
    intuition.
    eapply (cost_compose f1 (fun a => f3)).
    eauto.
    intuition.
    eapply cost_const.
    intuition.
    eauto.
    intuition.

    lia.

  Qed.

  Theorem cost_pair_1 :
    forall (A B : Type),
      cost (@pair A B) 0.

    intuition.
    eapply cost_uncurry_1.
    eapply cost_ext.
    2:{
      eapply cost_ident.
    }
    intuition.
  Qed.

  Theorem cost_pair_2 :
    forall (A B : Type) a,
      cost (@pair A B a) 0.

    intuition.
    eapply cost_uncurry_2.
    eapply cost_ext.
    2:{
      eapply cost_ident.
    }
    intuition.
  Qed.

  Theorem cost_OC_Bind_1 : forall (A B C C' : Set),
    cost (@OC_Bind A B C C') 0.

    intuition.
    eapply cost_uncurry_1.
    eapply cost_OC_Bind.

  Qed.

  Theorem cost_OC_Bind_2 : forall (A B C C' : Set) (c : OracleComp A B C),
    cost (@OC_Bind A B C C' c) 0.

    intuition.
    eapply cost_uncurry_2.
    eapply cost_OC_Bind.

  Qed.

End CostTheory.

Ltac costtac_one :=
  match goal with
(* function cost *)
    | [|- _ ] => eapply cost_const
    | [|- ?f (Ret _ ) _ ] => eapply cost_Ret
    | [|- ?f (@fst _ _ ) _ ] => eapply cost_fst
    | [|- ?f (@snd _ _) _ ] => eapply cost_snd
    | [|- ?f (@OC_Query _ _) _ ] => eapply cost_OC_Query
    | [|- ?f (@OC_Ret _ _ _) _ ] => eapply cost_OC_Ret
    | [|- ?f (@OC_Bind _ _ _ _) _ ] => eapply cost_OC_Bind_1
    | [|- forall a, ?f (OC_Bind a) _ ] => eapply cost_OC_Bind_2
    | [|- ?f (fun a => (?f1 a, ?f2 a)) _ ] => eapply cost_compose_binary
    | [|- ?f (@pair _ _ ) _ ] => eapply cost_pair_1
    | [|- forall a, ?f (@pair _ _ a) _ ] => eapply cost_pair_2
    | [|- ?f (fun a => ?f1 (?f2 a)) _ ] => eapply cost_compose_unary
    | [|- ?f (fun a => ?f1 (?f2 (?f3 a)))  _ ] => eapply cost_compose_unary
    | [|- ?f (fun a => ?f1 (?f2 (?f3 (?f4 a))))  _ ] => eapply cost_compose_unary
    | [|- ?f (fun a => ?f1 (?f2 (?f3 (?f4 (?f5 a)))))  _ ] => eapply cost_compose_unary
    | [|- ?f (fun a => ?f1 (?f2 (?f3 (?f4 (?f5 (?f6 a))))))  _ ] => eapply cost_compose_unary

(* Comp cost *)
    | [|- ?f1 ?f2 (Rnd _ ) _ ] => econstructor
    | [|- ?f1 ?f2 (Ret _ _ ) _ ] => econstructor
    | [|- ?f1 ?f2 (Bind _ _) _ ] => econstructor

(* OracleComp cost *)
    | [|- ?f1 ?f2 ?f3 (OC_Bind _ _) _ ] => econstructor
    | [|- ?f1 ?f2 ?f3 (OC_Run _ _ _ _ _ _ ) _ ] => econstructor
    | [|- ?f1 ?f2 ?f3 (@OC_Ret _ _ _ _  ) _ ] => econstructor
    | [|- ?f1 ?f2 ?f3 (OC_Query _ _ ) _ ] => econstructor

  end.

Ltac costtac := repeat (costtac_one).

Require Import FCF.Asymptotic.

Definition poly_time_nonuniform_oc(cost : FunctionCostModel)(A B C : nat -> Set)(c : forall n, OracleComp (A n) (B n) (C n)) :=
  exists (f : nat -> nat -> nat),
    (forall o, polynomial o ->
      polynomial (fun n => f n (o n))) /\
    forall n, (oc_cost cost (comp_cost cost)) _ _ _ (c n) (f n).

Definition polynomial_queries_oc(A B C : nat -> Set)(c : forall n, OracleComp (A n) (B n) (C n)) :=
  exists q,
    polynomial q /\
    forall n, queries_at_most (c n) (q n).

Definition admissible_oc(cost : FunctionCostModel)(A B C : nat -> Set)(c : forall n, OracleComp (A n) (B n) (C n)) :=
  (forall n, well_formed_oc (c n)) /\
  poly_time_nonuniform_oc cost _ _ _ c /\
  polynomial_queries_oc _ _ _ c.

Definition poly_time_nonuniform_oc_func_2(cost : FunctionCostModel)(A B C D E: nat -> Set)(c : forall n, A n -> B n -> OracleComp (C n) (D n) (E n)) :=
  exists (f1 : nat -> nat -> nat),
    exists (f2 : nat -> nat),
    (forall o, polynomial o ->
      polynomial (fun n => f1 n (o n))) /\
    polynomial f2 /\
    forall n,
      cost _ _ (fun p => @c n (fst p) (snd p)) (f2 n) /\
      (forall x y, (oc_cost cost (comp_cost cost)) _ _ _ (@c n x y) (f1 n)).

Definition polynomial_queries_oc_func_2(A B C D E : nat -> Set)(c : forall n, A n -> B n -> OracleComp (C n) (D n) (E n)) :=
  exists q,
    polynomial q /\
    forall n a b, queries_at_most (c n a b) (q n).

Definition admissible_oc_func_2(cost : FunctionCostModel)(A B C D E : nat -> Set)(c : forall n, A n -> B n -> OracleComp (C n) (D n) (E n)) :=
  (forall n a b, well_formed_oc (c n a b)) /\
  poly_time_nonuniform_oc_func_2 cost _ _ _ _ _ c /\
  polynomial_queries_oc_func_2 _ _ _ _ _ c.


From Coq Require Import Lia NArith.NArith Program.Basics ssr.ssreflect.
From Equations Require Export Equations.

#[local]
Obligation Tactic := idtac.

Section Context.

Import N.

Local Open Scope N_scope.

Context (f : N -> N) (mono : forall (a b : N) (l : a < b), f a < f b).

Equations f_bogus (n : N) : positive :=
  f_bogus n :=
    let m := f (succ n) - f n in
    match m with
    | N0 => _
    | Npos p => p
    end.
Next Obligation. intros n m. apply xH. Qed.

Equations f_inspect (n : N) : positive :=
  f_inspect n :=
    let m := f (succ n) - f n in
    match exist _ m (eq_refl m) with
    | exist _ N0 e => @const _ (m = N0) _ e
    | exist _ (Npos p) e => @const _ (m = Npos p) p e
    end.
Next Obligation. intros n m _ _ e. pose proof mono n (succ n) as l. lia. Qed.

Lemma eq_f (n : N) : f_bogus n = f_inspect n.
Proof.
  Fail funelim f_bogus.
Abort.
End Context.


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Undecidability Result(s):
    Uniform Boundedness of Deterministic, Length-preserving Stack Machines (SMNdl_UB)
*)

Require Import Undecidability.Synthetic.Undecidability.

Require Import Undecidability.StackMachines.SMN.

Require Undecidability.StackMachines.Reductions.CM1_HALT_to_SMNdl_UB.
Require Import Undecidability.CounterMachines.CM1_undec.

(* Undecidability of Uniform Boundedness of Deterministic, Length-preserving Stack Machines *)
Theorem SMNdl_UB_undec : undecidable SMNdl_UB.
Proof.
  apply (undecidability_from_reducibility CM1_HALT_undec).
  exact CM1_HALT_to_SMNdl_UB.reduction.
Qed.


Require Import Coqlib.
Require Import Asm.
Require Import PeekTactics.
Require Import PeepsLib.
Require Import PregTactics.
Require Import StepIn.
Require Import AsmBits.
Require Import Values.
Require Import ValEq.
Require Import Integers.
Require Import PeepsTactics.

(* 599 hw bonus problem *)

(*
        xorl    %eax, %eax
        subl    %esi, %eax
        leal    0(%ebx,%eax,1) %eax

==>
        subl    %esi, %ebx
        movl    %ebx, %eax

*)

Definition peep_zero_sub_example : code :=
  Pxor_r EAX :: Psub_rr EAX EAX :: Plea EAX (Addrmode None None (inl Int.one)) :: nil.

Section ZERO_SUB.

  Variable concrete : code.

  Variable r1 : ireg.
  Variable r2 : ireg.
  Variable r3 : ireg.

  Definition a1 := Addrmode (Some r3) (Some (r1, Int.one)) (inl Int.zero).

  Hypothesis neq12 : r1 <> r2.
  Hypothesis neq23 : r2 <> r3.
  Hypothesis neq13 : r1 <> r3.

  Definition peep_zero_sub_defs : rewrite_defs :=
    {|
      fnd :=
        Pxor_r r1 ::
        Psub_rr r1 r2 ::
        Plea r1 a1 ::
        nil
      ; rpl :=
          Psub_rr r3 r2 ::
          Pmov_rr r1 r3 ::
          Pnop ::
          nil
      ; lv_in := IR r2 :: IR r3 :: PC :: nil
      ; lv_out := IR r1 :: IR r2 :: PC :: nil
      ; clobbered := IR r3 :: flags
    |}.

  Lemma sub_no_pointer :
    forall x y,
      (forall b ofs, x <> Vptr b ofs) ->
      (forall b ofs, y <> Vptr b ofs) ->
      (forall b ofs, Val.sub x y <> Vptr b ofs).
  Proof.
    intros.
    destruct x; destruct y; simpl; congruence.
  Qed.

  Lemma peep_zero_sub_selr :
    StepEquiv.step_through_equiv_live (fnd peep_zero_sub_defs) (rpl peep_zero_sub_defs) (lv_in peep_zero_sub_defs) (lv_out peep_zero_sub_defs).
  Proof.
    prep_l.
    step_l.
    step_l.
    step_l.
    prep_r.
    step_r.
    step_r.
    step_r.
    finish_r.
    prep_eq.
    split.
    2: eq_mem_tac.
    intros.
    simpl_and_clear.
    Focus 2. rewrite Int.eq_true in Heqb0. congruence.
    clear H39. subst.
    repeat break_or; try inv_false;
    preg_simpl.

    (* r1 *)
    *
      clear -H0 H4.
      destruct (rsl r2) eqn:?;
               destruct (rsl r3) eqn:?;
               simpl in *;
        try solve [eapply sub_no_pointer; eauto];
        try solve [
              destruct (rsr r2) eqn:?;
               destruct (rsr r3) eqn:?;
               simpl in *;
              congruence].

      rewrite <- H4.
      rewrite <- H0.
      simpl. f_equal.
      ring.

    (* r2 *)
    * assumption.
    (* PC *)
    * clear -H2 H16.
      rewrite H2. rewrite H16.
      repeat (eapply val_eq_add);
        solve [simpl; auto].

  Qed.

  Definition peep_zero_sub_proofs : rewrite_proofs :=
    {|
      defs := peep_zero_sub_defs
      ; selr := peep_zero_sub_selr
    |}.

  Definition peep_zero_sub :
    concrete = fnd peep_zero_sub_defs ->
    StepEquiv.rewrite.
  Proof.
    intros.
    peep_tac_mk_rewrite peep_zero_sub_defs peep_zero_sub_proofs.
  Qed.

End ZERO_SUB.

Definition peep_zero_sub_rewrite (c : code) : option StepEquiv.rewrite.
  name peep_zero_sub p.
  unfold peep_zero_sub_defs in p.
  simpl in p.
  specialize (p c).
  set_code_cons c.
  set_code_cons c.
  set_code_cons c.
  set_code_nil c.
  set_instr_eq i 0%nat peep_zero_sub_example.
  set_instr_eq i0 1%nat peep_zero_sub_example.
  set_instr_eq i1 2%nat peep_zero_sub_example.
  destruct a. unfold a1 in p.
  destruct base; [ | exact None].
  destruct ofs; [ | exact None].
  destruct const; [ | exact None].
  set_int_eq i0 Int.zero.
  destruct p0.
  specialize (p rd r1 i).
  set_ireg_eq rd rd0.
  set_ireg_eq rd0 rd1.
  set_ireg_eq rd1 i0.
  set_int_eq i1 Int.one.
  set_ireg_neq i0 r1.
  set_ireg_neq r1 i.
  set_ireg_neq i0 i.
  specialize (p n n0 n1 eq_refl).
  exact (Some p).
Defined.

Definition zero_sub (c : code) : list StepEquiv.rewrite :=
  collect (map peep_zero_sub_rewrite (ParamSplit.matched_pat peep_zero_sub_example c)).


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

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

Print Assumptions add.


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

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

Print Assumptions add.


Set Warnings "-notation-overridden".
From Equations Require Import Equations.
Require Import Utf8 Arith Compare_dec List Lia.
Require Import Relation_Operators.
Arguments clos_trans [A].
Import Sigma_Notations.
Set Equations Transparent.

Require Import fin.

Equations lift_fin {n} (k : nat) (f : fin n) : fin (S n) :=
  lift_fin 0 f := fs f;
  lift_fin (S k) fz := fz;
  lift_fin (S k) (fs f) := fs (lift_fin k f).
Open Scope list_scope.
Derive Signature for Forall2.
#[local] Hint Constructors Forall2 : core.
Local Open Scope program_scope.
Local Open Scope equations_scope.
Arguments map {A B}.
(* end hide *)

Require Import Equations.Prop.Subterm.

Derive Subterm for nat.

(* Hint Extern 30 (@NoCycle ?A (NoCycle_WellFounded ?R ?wfr) _ _) => *)
(*   hnf ; typeclasses eauto with subterm_relation : typeclass_instances. *)

Lemma nocycle_nat x : S x = x -> False.
  simplify ?.
Qed.

Goal forall x, S (S x) = x -> False.
  intros x.
  simplify ?.
Qed.

Inductive tree := leaf : tree | node : tree -> tree -> tree.
Derive NoConfusion Subterm for tree.

Goal forall x y, node x y = x -> False.
  intros x y.
  simplify ?.
Qed.

Goal forall x y, node y (node y x) = x -> False.
  intros x y.
  simplify ?.
Qed.

Goal forall x y, node y (node y x) = x -> False.
  intros x y.
  simplify ?.
Qed.

Goal forall x y, x = node y (node y x) -> False.
  intros x y.
  simplify ?. Show Proof.
Qed.

Goal forall x y z, x = node (node y z) (node y x) -> False.
  intros x y z.
  simplify ?.
Qed.

(** It would be hard to come up with an example for vector, but for indexed terms
    in some language, yes *)
Derive NoConfusion Subterm for list.

Reserved Notation " x ∈ s " (at level 70, s at level 10).
Polymorphic Inductive In {A} (x : A) : list A -> Type :=
| here {xs} : x ∈ (x :: xs)
| there {y xs} : x ∈ xs -> x ∈ (y :: xs)
(* begin hide *)
  where "x ∈ s" := (In x s).
Derive Signature NoConfusion for In.
Arguments here {A x xs}.
Arguments there {A x y xs} _.
(* end hide *)

Set Equations With UIP.

Set Universe Polymorphism.
Section InNoconfusion.

  Context {A} {hset : UIP A}.

  Global Instance list_UIP: UIP (list A).
  Proof.
    intros inx inx' e. depelim e. induction inx.
    - now simplify *.
    - simplify $. simpl. simplify ?.
      intros. specialize (IHinx e). simpl. destruct IHinx.
      reflexivity.
  Defined.

  Instance In_UIP (x : A) l : UIP (x ∈ l).
  Abort. (* Impossible! As defined, x ∈ l is not proof irrelevant, it contains an index into the list *)
End InNoconfusion.
Unset Universe Polymorphism.
(* end hide *)

Inductive type : Set :=
| tbool | tunit | tarrow : type -> type -> type.
Derive NoConfusion Subterm for type.

#[export]
Instance type_uip : UIP type.
Proof.
  red. intros x y ->. induction y; try repeat (simplify ?; simpl); trivial.
  intros. specialize (IHy1 e'). specialize (IHy2 e). destruct IHy1. destruct IHy2.
  reflexivity.
Qed.

Inductive term : forall (ctx : list type), type -> Set :=
| ttrue {ctx} : term ctx tbool
| tfalse{ctx} : term ctx tbool
| tvar {ctx} {τ} (x : τ ∈ ctx) : term ctx τ
| tapp {ctx} {τ τ'} (f : term ctx (tarrow τ τ')) (a : term ctx τ) : term ctx τ
| tlam {ctx} {τ τ'} (abs : term (τ :: ctx) τ') : term ctx (tarrow τ τ').

Derive Signature for term.
Derive NoConfusionHom for term.

(* FIXME subterm and non-uniform indices and universe issue... *)
(*
Derive Subterm for term.

Lemma wft : WellFounded term_subterm.
  solve_subterm. destruct index. simpl in *.
  revert H. simplify *.
  destruct index. simpl in *. revert H. simplify *.
Defined.

Existing Instance wft.

Goal forall ctx τ (f : term ctx (tarrow τ τ)) (a : term ctx τ), signature_pack (tapp f a) = signature_pack a -> False.
Proof.
  intros *.
  simplify <>.
Qed.

Goal forall ctx τ (f : term ctx (tarrow τ τ)) (a : term ctx τ), tapp f a = a -> False.
Proof.
  intros *.
  refine (simplify_ind_pack (A:=Σ ctx : list type, type) (fun x => term x.1 x.2) (ctx, τ) _ _ (fun _ => False) _).
  simplify <>.
Defined.

*)


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

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

Print Assumptions add.


Require Import R_sqrt.
Require Import Raxioms.
Require Import QArith.
Require Import R_Ifp.

Definition Result (z:Z) : R :=
  (Rdiv
    (Rminus
      (sqrt (8 * (IZR z) + 1))
       1)
     2).

Theorem w_is_floor : forall (w:R) (w_Z t x y z : Z),
  w = (IZR (Zplus x y)) ->
  w_Z = (Zplus x y) ->
  t = (Zdiv (Zplus (Zmult w_Z w_Z) w_Z) 2) ->
  z = (Zplus t y) ->
  Rle w (Result z) ->
  Rlt (Result z) (w + 1) ->
  w_Z = Int_part (Result z).
Proof.
  intros.
  subst.
  unfold Result.
  unfold Int_part.
  unfold Result in H3.
  unfold Result in H4.
Admitted.


(***
 * Oqarina
 * Copyright 2021 Carnegie Mellon University.
 *
 * NO WARRANTY. THIS CARNEGIE MELLON UNIVERSITY AND SOFTWARE ENGINEERING
 * INSTITUTE MATERIAL IS FURNISHED ON AN "AS-IS" BASIS. CARNEGIE MELLON
 * UNIVERSITY MAKES NO WARRANTIES OF ANY KIND, EITHER EXPRESSED OR
 * IMPLIED, AS TO ANY MATTER INCLUDING, BUT NOT LIMITED TO, WARRANTY OF
 * FITNESS FOR PURPOSE OR MERCHANTABILITY, EXCLUSIVITY, OR RESULTS
 * OBTAINED FROM USE OF THE MATERIAL. CARNEGIE MELLON UNIVERSITY DOES NOT
 * MAKE ANY WARRANTY OF ANY KIND WITH RESPECT TO FREEDOM FROM PATENT,
 * TRADEMARK, OR COPYRIGHT INFRINGEMENT.
 *
 * Released under a BSD (SEI)-style license, please see license.txt or
 * contact permission@sei.cmu.edu for full terms.
 *
 * [DISTRIBUTION STATEMENT A] This material has been approved for public
 * release and unlimited distribution.  Please see Copyright notice for
 * non-US Government use and distribution.
 *
 * This Software includes and/or makes use of the following Third-Party
 * Software subject to its own license:
 *
 * 1. Coq theorem prover (https://github.com/coq/coq/blob/master/LICENSE)
 * Copyright 2021 INRIA.
 *
 * 2. Coq JSON (https://github.com/liyishuai/coq-json/blob/comrade/LICENSE)
 * Copyright 2021 Yishuai Li.
 *
 * DM21-0762
***)

(*| .. coq:: none |*)
(* Coq Library *)
Require Import List.
Import ListNotations. (* from List *)
Require Import Floats. Open Scope float_scope.

(* Oqarina Library *)
Require Import Oqarina.formalisms.FaultTrees.all.
Require Import Oqarina.formalisms.Expressions.Propositions.
(*| .. coq:: |*)

(*|

Static Fault Tree Analysis
==========================

In this section, we illustrate some aspects of the Fault Tree Analsis capabilities. We present mapping of boolean expressions to cutset (:ref:`NUREG Example VII-10`), mapping of fault trees to cutset and proof of correctness (:ref:`Sample IMA Architecture` and :ref:`NUREG Example VIII-14`).

Note: in the following, we use Coq primitive floats (see :cite:t:`DBLP:conf/itp/BertholonMR19` for details) to represent the probability of occurence of some basic events. The rounding algorithms used to parse float values like 0.1 introduces some numerical discrepencies. We instruct Coq to silence those warnings and report differences from the original examples we used as a comparison.
|*)

Set Warnings "-inexact-float".

(*|

NUREG Example VII-10
--------------------

In this module, we analyze the example from
:cite:`w.e.FaultTreeHandbook1981`, figure VII-10, pVII-16.

We model it as a boolean propositions and compute its minimal cutset.

|*)

(*| .. coq:: none |*)
Module NUREG_Example_VII_10.
(*| .. coq:: |*)

(*| The definition os a fault tree requires a few steps

First, we define the basic events formally, as a collection of labels. We use Coq's notations to provide a nicer display.

|*)

Inductive NUREG_Vars : Set := VarA | VarB | VarC.
Scheme Equality for NUREG_Vars.

Notation A := (Var VarA).
Notation B := (Var VarB).
Notation C := (Var VarC).

Import PropF_Notations. (* Notations for boolean propositions *)

(*|  We define the gates for the fault tree from figure VII-10. Gate :coq:`T` is the top event. |*)

Definition E4 := A ∧ B.
Definition E2 := C ∨ E4.
Definition E3 := B ∨ C.
Definition E1 := A ∨ E3.
Definition T := E1 ∧ E2.

Compute T. (* = (A ∨ B ∨ C) ∧ (C ∨ A ∧ B) *)

(*| :coq:`T` is neither in DNF form nor in cutset. We compute these forms as intermediate steps. |*)

Compute To_DNF T.
(* = A ∧ C ∨ A ∧ A ∧ B ∨ B ∧ C ∨ B ∧ A ∧ B ∨ C ∧ C ∨ C ∧ A ∧ B *)

Compute PropF_to_cutset NUREG_Vars_beq T.
(* A ∧ B ∨ C *)

(*| We check this is consistent with the result provided p VIi-17.|*)

Lemma T_cutset_OK:
    (PropF_to_cutset NUREG_Vars_beq T) = (A ∧ B ∨ C).
Proof. trivial. Qed.

(* result : C ∨ (A ∧ B)*)

(*| .. coq:: none |*)
End NUREG_Example_VII_10.
(*| .. coq:: |*)

(*|

Sample IMA Architecture
-----------------------

This example is from the technical report
:cite:`siuSafeOptimalTechniques2019`, p12, section 4.1.1 "Example 1 – Sample IMA Architecture". |*)

(*| .. coq:: none |*)
Module Sample_IMA_Architecture.
(*| .. coq:: |*)

(*| In this example, we first define the fault tree of the system as a collection of basic events. :coq:`Basic_event_event_value` maps a basic_event to its probability of occurence. |*)

Open Scope float_scope.
Import PropF_Notations.

Inductive basic_event : Set :=
    IRU1 | IRU2 | IRU3 | RIU2 | RIU6 | RIU7 | NCD | GCD.

(*| We define helper function for equality. |*)
Scheme Equality for basic_event.

Lemma basic_event_reflect: forall x y : basic_event,
    Bool.reflect (x = y) (basic_event_beq x y).
Proof.
    induction x, y ; simpl ; intuition.
Qed.

(*| Actual definition of the basic event propability values and the fault tree. |*)

Definition basic_event_value ( p : basic_event) :=
    match p with
    | IRU1 | IRU2 | IRU3 | RIU2 | RIU6 | RIU7 => 1.0e-6
    | NCD | GCD => 2.0e-10
    end.

Definition iru1 := ltree_cons (BASIC IRU1) [].
Definition iru2 := ltree_cons (BASIC IRU2) [].
Definition iru3 := ltree_cons (BASIC IRU3) [].

Definition riu2 := ltree_cons (BASIC RIU2) [].
Definition riu6 := ltree_cons (BASIC RIU6) [].
Definition riu7 := ltree_cons (BASIC RIU7) [].

Definition ncd := ltree_cons (BASIC NCD) [].
Definition gcd := ltree_cons (BASIC GCD) [].

Definition e2n1 := ltree_cons (OR _) [ riu2; riu6; riu7 ].
Definition e2n2 := ltree_cons (OR _) [ iru1; e2n1 ].
Definition e2n3 := ltree_cons (OR _) [ riu2; riu6; riu7 ].
Definition e2n4 := ltree_cons (OR _) [ iru2; e2n3 ].
Definition e2n5 := ltree_cons (OR _) [ riu2; riu6; riu7 ].
Definition e2n6 := ltree_cons (OR _) [ iru3; e2n5].

Definition mg := ltree_cons (K_OUT_OF_N _ 2) [e2n2 ;e2n4 ; e2n6].
Definition slide165 := ltree_cons (OR _) [mg; ncd; gcd].

Compute slide165.

(*| This fault tree has a K_OUT_OF_N gate, we eliminate it. |*)

Definition slide165' := Expand_Fault_Tree' slide165.

(*| We check that the fault tree is syntactically valid. |*)

Fact slide165_OK : valid_static_fault_tree' slide165'.
Proof.
    prove_valid_static_fault_tree.
Qed.

(*| We map it to the corresponding boolean expressions |*)

Definition slide165_bool := Map_Fault_Tree_to_BoolExpr slide165'.
Compute slide165_bool.

(*| We can compute and display the corresponding cutset either as a boolean expression or as a fault tree. |*)

Definition slide165_cs_bool :=
    Map_Fault_Tree_to_Cutset_PropF basic_event_beq slide165'.
Compute slide165_cs_bool.
(* = Var IRU1 ∧ Var IRU2
    ∨ Var IRU1 ∧ Var IRU3
        ∨ Var IRU2 ∧ Var IRU3
        ∨ Var RIU2 ∨ Var RIU6 ∨ Var RIU7 ∨ Var NCD ∨ Var GCD *)

Definition slide165_cs :=
    Map_Fault_Tree_to_Cutset basic_event_beq slide165.
Compute slide165_cs.

Lemma slide165_cs_ok: slide165_cs =
ltree_cons (OR _)
    [ltree_cons (AND _)
    [ltree_cons (BASIC IRU1) []; ltree_cons (BASIC IRU2) []];
    ltree_cons (AND _)
    [ltree_cons (BASIC IRU1) []; ltree_cons (BASIC IRU3) []];
    ltree_cons (AND _)
    [ltree_cons (BASIC IRU2) []; ltree_cons (BASIC IRU3) []];
    ltree_cons (BASIC RIU2) []; ltree_cons (BASIC RIU6) [];
    ltree_cons (BASIC RIU7) []; ltree_cons (BASIC NCD) [];
    ltree_cons (BASIC GCD) []].
 Proof. trivial. Qed.

(*| Finally, we check that the computed probability value is consistent.
*Note: we do not get the exact same value due to rounding introduced by Coq.* |*)

Lemma slide165_ok:
    Compute_Fault_Tree'' slide165_cs basic_event_value =
    Some 3.0004029999999996e-06.
Proof. trivial. Qed.

(*| .. coq:: none |*)
End Sample_IMA_Architecture.
(*| .. coq:: |*)

(*|

NUREG Example VIII-14
---------------------

This example is derived from the Pressure Tank Example from the Fault Tree Handbook (NUREG-0492) :cite:`w.e.FaultTreeHandbook1981`, chapter VIII, figure VIII-14.

|*)

(*| .. coq:: none |*)
Module NUREG0492_Example_VIII_14.
(*| .. coq:: |*)

Open Scope float_scope.
Import PropF_Notations.

Inductive basic_event := VarT | VarK2 | VarS | VarK1 | VarR | VarS1.

(*| We define helper function for equality. |*)
Scheme Equality for basic_event.

Lemma basic_event_reflect: forall x y : basic_event,
    Bool.reflect (x = y) (basic_event_beq x y).
Proof.
    induction x, y ; simpl ; intuition.
Qed.

(*| Actual definition of the basic event propability values and the fault tree. |*)
Definition basic_event_values (b : basic_event) :=
    match b with
        | VarT  => 5e-6
        | VarK2  => 3e-5
        | VarS  => 1e-4
        | VarK1  => 3e-5
        | VarR  => 1e-4
        | VarS1  => 3e-5
    end.

Definition T := ltree_cons (BASIC VarT) [].
Definition K2 := ltree_cons (BASIC VarK2) [].
Definition S := ltree_cons (BASIC VarS) [].
Definition K1 := ltree_cons (BASIC VarK1) [].
Definition R := ltree_cons (BASIC VarR) [].
Definition S1 := ltree_cons (BASIC VarS1) [].

Definition E5 := ltree_cons (OR _) [ K1 ; R].
Definition E4 := ltree_cons (OR _) [ S1 ; E5].
Definition E3 := ltree_cons (AND _) [ S ; E4].
Definition E2 := ltree_cons (OR _) [ E3 ; K2].
Definition E1 := ltree_cons (OR _) [ T ; E2].

(*| We prove that the fault tree is valid in :coq:`E1_OK`, map to its cutset and the cutset is correct (:coq:`E1_cs_OK`). |*)

Fact E1_OK : valid_static_fault_tree' E1.
Proof.
    prove_valid_static_fault_tree.
Qed.

Definition E1_cs :=
    Map_Fault_Tree_to_Cutset basic_event_beq E1.
Compute E1_cs.

Lemma E1_cs_OK: forall (v: basic_event -> bool),
    Compute_Fault_Tree_2 E1 v= Compute_Fault_Tree_2 E1_cs v.
Proof.
    unfold E1_cs.
    intros.
    apply Map_Fault_Tree_to_Cutset_sound.
    apply basic_event_eq_dec.
    apply basic_event_reflect.
    apply E1_OK.
Qed.

(*| The authors in  :cite:`w.e.FaultTreeHandbook1981` use some simplification heuristics and provide an approximation value of 3.4e-05. This example is also evaluated in :cite:`siuSafeOptimalTechniques2019`, section 4.1.2, p16. It conforms to the value we compute below. |*)

Lemma E1_value_OK : Compute_Fault_Tree'' E1_cs basic_event_values
                = Some 3.5016000000000005e-05.
Proof. trivial. Qed.

(*| .. coq:: none |*)
End NUREG0492_Example_VIII_14.
(*| .. coq:: |*)


(** Coq coding by choukh, Oct 2021 **)

Require Import BBST.Axiom.Meta.
Require Import BBST.Axiom.Extensionality.
Require Import BBST.Axiom.Separation.
Require Import BBST.Axiom.Pairing.
Require Import BBST.Axiom.Union.
Require Import BBST.Axiom.Power.
Require Import BBST.Definition.Include.
Require Import BBST.Definition.Emptyset.
Require Import BBST.Definition.BinaryUnion.
Require Export BBST.Definition.OrderedPair.
Require Export BBST.Definition.Product.

Notation 关系类型 := (集合 → 集合 → Prop).
Definition 关系 := λ A B P, {'<a, b> ∊ A × B | P a b}.

Lemma 关系介入 : ∀ A B (P : 关系类型), ∀a ∈ A, ∀b ∈ B, P a b → <a, b> ∈ 关系 A B P.
Proof. intros. 序偶分离-|; auto. Qed.

Lemma 关系除去1 : ∀ A B P a b, <a, b> ∈ 关系 A B P → a ∈ A ∧ b ∈ B ∧ P a b.
Proof. intros. 序偶分离|-H. 直积|-Hp. easy. Qed.

Lemma 关系除去2 : ∀ A B P x, x ∈ 关系 A B P → ∃a ∈ A, ∃b ∈ B, x = <a, b> ∧ P a b.
Proof.
  intros. 序偶分离|-H.
  apply 直积除去2 in Hp as [c [Hc [d [Hd Heq]]]].
  apply 序偶相等 in Heq as []; subst; firstorder.
Qed.

Tactic Notation "关系" "|-" ident(H) "for" simple_intropattern(a) simple_intropattern(Ha) simple_intropattern(b) simple_intropattern(Hb) :=
  let Heq := fresh "Heq" in apply 关系除去2 in H as [a [Ha [b [Hb [Heq H]]]]]; rewrite Heq in *; clear Heq; 化简.
Tactic Notation "关系" "|-" ident(H) "for" simple_intropattern(Ha) simple_intropattern(Hb) :=
  first[关系|-H for ?a Ha ?b Hb|apply 关系除去1 in H as [Ha [Hb H]]].
Tactic Notation "关系" "|-" ident(H) :=
  first[关系|-H for ?a ?Ha ?b ?Hb|apply 关系除去1 in H as [?Ha [?Hb H]]].
Tactic Notation "关系" "-|" constr(a) constr(b) := 序偶分离-|a b; [直积-||].
Tactic Notation "关系" "-|" := 序偶分离-|.

Definition 为关系 := λ A B R, R ⊆ A × B.

Fact 直积为关系 : ∀ A B, 为关系 A B (A × B).
Proof. firstorder. Qed.

Fact 直积之分离为关系 : ∀ A B P, 为关系 A B {p ∊ A × B | P p}.
Proof. intros * x Hx. apply 分离之父集 in Hx. auto. Qed.

Fact 关系为之 : ∀ A B P, 为关系 A B (关系 A B P).
Proof. intros. apply 直积之分离为关系. Qed.

Global Hint Immediate 直积为关系 直积之分离为关系 关系为之 : core.

Definition 定义域 := λ R, {x ∊ ⋃⋃R | ∃ y, <x, y> ∈ R}.
Notation dom := 定义域.

Definition 值域 := λ R, {y ∊ ⋃⋃R | ∃ x, <x, y> ∈ R}.
Notation ran := 值域.

Definition 全域 := λ R, dom R ∪ ran R.
Notation fld := 全域.

Lemma 定义域介入 : ∀ R x y, <x, y> ∈ R → x ∈ dom R.
Proof with auto.
  intros. apply 分离介入.
  - apply 并集介入 with {x, y}...
    apply 并集介入 with <x, y>... apply 右配对介入.
  - exists y...
Qed.

Lemma 值域介入 : ∀ R x y, <x, y> ∈ R → y ∈ ran R.
Proof with auto.
  intros. apply 分离介入.
  - apply 并集介入 with {x, y}...
    apply 并集介入 with <x, y>... apply 右配对介入.
  - exists x...
Qed.

Lemma 定义域除去 : ∀ R, ∀x ∈ dom R, ∃ y, <x, y> ∈ R.
Proof. intros R x Hx. now apply 分离之条件 in Hx. Qed.

Lemma 值域除去 : ∀ R, ∀y ∈ ran R, ∃ x, <x, y> ∈ R.
Proof. intros R x Hx. now apply 分离之条件 in Hx. Qed.

Global Opaque 定义域 值域.

Tactic Notation "定" "-|" constr(y) := apply 定义域介入 with y.
Tactic Notation "值" "-|" constr(x) := apply 值域介入 with x.
Tactic Notation "定" "|-" ident(H) "as" simple_intropattern(L) := apply 定义域除去 in H as L.
Tactic Notation "值" "|-" ident(H) "as" simple_intropattern(L) := apply 值域除去 in H as L.
Tactic Notation "定" ident(H) := apply 定义域介入 in H.
Tactic Notation "值" ident(H) := apply 值域介入 in H.
Tactic Notation "域" := match goal with
  | H: <?x, ?y> ∈ ?f |- ?x ∈ dom ?f => apply 定义域介入 with y; apply H
  | H: <?x, ?y> ∈ ?f |- ?y ∈ ran ?f => apply 值域介入 with x; apply H end.

Fact 关系之定义域 : ∀ A B P, dom (关系 A B P) ⊆ A.
Proof. intros * x H. 定|-H as [y H]. now 关系|-H. Qed.

Fact 关系之值域 : ∀ A B P, ran (关系 A B P) ⊆ B.
Proof. intros * x H. 值|-H as [w H]. now 关系|-H. Qed.

Fact 为序偶集即为关系: ∀ A, 为序偶集 A ↔ 为关系 (dom A) (ran A) A.
Proof.
  split; intros H x Hx.
  - apply H in Hx as Hp. destruct Hp as [a [b Hp]]. subst. 直积-|; 域.
  - apply H in Hx. 直积|-Hx; auto.
Qed.

Definition 恒等关系 := λ A, 关系 A A (λ x y, x = y).

Fact 空集上的恒等关系为空集 : 恒等关系 ∅ = ∅.
Proof. 外延. 关系|-H. 空集归谬. 空集归谬. Qed.

Fact 恒等关系之定义域 : ∀ A, dom (恒等关系 A) = A.
Proof. intros. 外延. - 定|-H as [y H]. now 关系|-H. - 定-|x. 关系-|; auto. Qed.

Fact 恒等关系之值域 : ∀ A, ran (恒等关系 A) = A.
Proof. intros. 外延 y H. - 值|-H as [x H]. now 关系|-H. - 值-|y. 关系-|; auto. Qed.


From Undecidability.TM.Code Require Import ProgrammingTools.

(* * Constructor and Deconstructor Machines for Natural Numbers *)

Lemma tl_length (X : Type) (xs : list X) :
  length (tl xs) = pred (length xs).
Proof. destruct xs; auto. Qed.

Hint Rewrite tl_length : list.

Section CaseNat.

  (* ** Deconstructor *)

  Definition CaseNat_Rel : Rel (tapes sigNat^+ 1) (bool * tapes sigNat^+ 1) :=
    Mk_R_p
      (fun tin '(yout, tout) =>
         forall (n : nat) (sn : nat),
           tin ≃(;sn) n ->
           match yout, n with
           | false, O => tout ≃(;sn) 0
           | true, S n' => tout ≃(;S sn) n'
           | _, _ => False
           end).

  Definition CaseNat : pTM sigNat^+ bool 1 :=
    Move Rmove;;
    Switch (ReadChar)
          (fun o => match o with
                 | Some (inr sigNat_S) => Return (Write (inl START)) true (* S *)
                 | Some (inr sigNat_O) => Return (Move Lmove) false (* O *)
                 | _ => Return (Nop) default (* invalid input *)
                 end).

  Definition CaseNat_steps := 5.

  Lemma CaseNat_Sem : CaseNat ⊨c(CaseNat_steps) CaseNat_Rel.
  Proof.
    unfold CaseNat_steps. eapply RealiseIn_monotone.
    { unfold CaseNat. TM_Correct. }
    { Unshelve. 4,8: reflexivity. all: lia. }
    {
      intros tin (yout&tout) H. intros n s HEncN. TMSimp.
      destruct HEncN as (r1&HEncN&Hs). TMSimp.
      destruct n; cbn in *; TMSimp.
      - repeat econstructor; auto.
      - hnf. eexists. split. f_equal. cbn. lia.
    }
  Qed.

  (* ** Constructors *)
  Section NatConstructor.

    Definition S_Rel : Rel (tapes sigNat^+ 1) (unit * tapes sigNat^+ 1) :=
      Mk_R_p (ignoreParam (fun tin tout => forall n sn : nat, tin ≃(;sn) n -> tout ≃(;pred sn) S n)).

    Definition Constr_S : pTM sigNat^+ unit 1 :=
      WriteMove (inr sigNat_S) Lmove;; Write (inl START).

    Definition Constr_S_steps := 3.

    Lemma Constr_S_Sem : Constr_S ⊨c(Constr_S_steps) S_Rel.
    Proof.
      unfold Constr_S_steps. eapply RealiseIn_monotone.
      { unfold Constr_S. TM_Correct. }
      { cbn. lia. }
      {
        intros tin (yout, tout) H. intros n sn HEncN.
        TMSimp. clear all except HEncN.
        destruct HEncN as (r1&->&Hs). cbn. simpl_tape.
        hnf. eexists. split. f_equal. simpl_list. lia.
      }
    Qed.

    Definition Constr_O_size := pred >> pred.

    Definition O_Rel : Rel (tapes sigNat^+ 1) (unit * tapes sigNat^+ 1) :=
      fun tin '(_, tout) => forall sn, isVoid_size tin[@Fin0] sn -> tout[@Fin0] ≃(;Constr_O_size sn) O.

    Definition Constr_O : pTM sigNat^+ unit 1 := WriteValue 0.

    Goal Constr_O = WriteMove (inl STOP) Lmove;; WriteMove (inr sigNat_O) Lmove;; Write (inl START).
    Proof. unfold Constr_O, WriteValue, WriteString.WriteString, encode, Encode_map, map, rev, Encode_nat, encode, repeat, app. reflexivity. Qed.
    Definition Constr_O_steps := 5.

    Lemma Constr_O_Sem : Constr_O ⊨c(Constr_O_steps) O_Rel.
    Proof.
      unfold Constr_O_steps. eapply RealiseIn_monotone.
      { unfold Constr_O. TM_Correct. }
      { cbn. reflexivity. }
      { intros tin (yout, tout) H. intros s HRight. cbn in H. unfold Constr_O_size in *.
        specialize (H _ HRight). contains_ext. unfold WriteValue_size. cbn. lia.
      }
    Qed.

  End NatConstructor.

End CaseNat.

(* ** Tactic Support *)

Ltac smpl_TM_CaseNat :=
  once lazymatch goal with
  | [ |- CaseNat ⊨ _ ] => eapply RealiseIn_Realise; apply CaseNat_Sem
  | [ |- CaseNat ⊨c(_) _ ] => apply CaseNat_Sem
  | [ |- projT1 (CaseNat) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply CaseNat_Sem
  | [ |- Constr_O ⊨ _ ] => eapply RealiseIn_Realise; apply Constr_O_Sem
  | [ |- Constr_O ⊨c(_) _ ] => apply Constr_O_Sem
  | [ |- projT1 (Constr_O) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply Constr_O_Sem
  | [ |- Constr_S ⊨ _ ] => eapply RealiseIn_Realise; apply Constr_S_Sem
  | [ |- Constr_S ⊨c(_) _ ] => apply Constr_S_Sem
  | [ |- projT1 (Constr_S) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply Constr_S_Sem
  end.

Smpl Add smpl_TM_CaseNat : TM_Correct.

From Undecidability.TM.Hoare Require Import HoareLogic HoareRegister HoareTactics.

Lemma Constr_O_SpecT_size (ss : Vector.t nat 1) :
  TripleT (≃≃(([], withSpace  [|Void |] ss))) Constr_O_steps Constr_O (fun _ => ≃≃(([], withSpace  [|Contains _ 0|] (appSize [|Constr_O_size|] ss)))).
Proof.  unfold withSpace.
  eapply RealiseIn_TripleT.
  - apply Constr_O_Sem.
  - intros tin [] tout H1 H2. cbn in *. specialize (H2 Fin0). simpl_vector in *; cbn in *. modpon H1. tspec_solve.
Qed.

Lemma Constr_S_SpecT_size :
  forall (y : nat) ss,
    TripleT (≃≃(([], withSpace  [|Contains _ y |] ss))) Constr_S_steps Constr_S
            (fun _ => ≃≃(([], withSpace  [|Contains _ (S y)|] (appSize [|S|] ss)))).
Proof.  unfold withSpace.
  intros y ss.
  eapply RealiseIn_TripleT.
  - apply Constr_S_Sem.
  - intros tin [] tout H HEnc. cbn in *.
    specialize (HEnc Fin0). simpl_vector in *; cbn in *. modpon H. tspec_solve.
Qed.

Definition CaseNat_size (n : nat) : Vector.t (nat->nat) 1 :=
  match n with
  | O => [|id|]
  | S n' => [|S|]
  end.

Lemma CaseNat_SpecT_size (y : nat) (ss : Vector.t nat 1) :
  TripleT
    ≃≃([], withSpace  [|Contains _ y |] ss)
    CaseNat_steps
    CaseNat
    (fun yout =>
       ≃≃([if yout then y <> 0 else y = 0],withSpace ([|Contains _ (pred y)|])
            (appSize (CaseNat_size y) ss))).
Proof.  unfold withSpace.
  eapply RealiseIn_TripleT.
  - apply CaseNat_Sem.
  - intros tin yout tout H HEnc. specialize (HEnc Fin0). simpl_vector in *; cbn in *. modpon H.
    destruct yout, y; cbn in *; auto.
    + tspec_solve. easy.
    + tspec_solve. easy.
Qed.

Ltac hstep_Nat :=
  lazymatch goal with
  | [ |- TripleT ?P ?k Constr_O ?Q ] => eapply Constr_O_SpecT_size
  | [ |- TripleT ?P ?k Constr_S ?Q ] => eapply Constr_S_SpecT_size
  | [ |- TripleT ?P ?k CaseNat ?Q ] => eapply CaseNat_SpecT_size
  end.

Smpl Add hstep_Nat : hstep_Spec.


Require Import Coq.Lists.List.
Require Import Coq.Numbers.BinNums.
Require Import Coq.PArith.BinPosDef.

Module PTree.

  Inductive tree (A : Type) : Type :=
    | Leaf : tree A
    | Node : tree A -> option A -> tree A -> tree A.

  Arguments Leaf {A}.
  Arguments Node [A].

  Definition empty {A : Type} := (Leaf : tree A).

  Fixpoint get_rec' (A : Type) (i : positive) (m : tree A) (f : tree A -> tree A) : tree A :=
    match i with
    | xH => f m
    | xO ii => get_rec' A ii m (fun m0 : tree A => match f m0 with
                                      | Leaf => Leaf
                                      | Node l o r => l
                                      end)
    | xI ii => get_rec' A ii m (fun m0 : tree A => match f m0 with
                                      | Leaf => Leaf
                                      | Node l o r => r
                                      end)
    end.
  Definition get_rec (A : Type) (i : positive) (m : tree A) : option A :=
    match get_rec' A i m (fun m0 : tree A => m0) with
    | Leaf => None
    | Node l o r => o
    end.

  Fixpoint set_rec' (A : Type) (i : positive) (v : A) (m : tree A) (f : tree A -> tree A) : tree A :=
    match m with
    | Leaf =>
        match i with
        | xH => f (Node Leaf (Some v) Leaf)
        | xO ii => set_rec' A ii v Leaf (fun hole : tree A => f (Node hole None Leaf))
        | xI ii => set_rec' A ii v Leaf (fun hole : tree A => f (Node Leaf None hole))
        end
    | Node l o r =>
        match i with
        | xH => f (Node l (Some v) r)
        | xO ii => set_rec' A ii v l (fun hole : tree A => f (Node hole o r))
        | xI ii => set_rec' A ii v r (fun hole : tree A => f (Node l o hole))
        end
    end.
  Definition set_rec (A : Type) (i : positive) (v : A) (m : tree A) : tree A :=
    set_rec' A i v m (fun hole : tree A => hole).

  Fixpoint xelements (A : Type) (m : tree A) (k : list A) {struct m} : list A :=
  match m with
  | Leaf => k
  | Node l None r =>
    xelements A l (xelements A r k)
  | Node l (Some x) r =>
    xelements A l (x :: xelements A r k)
  end.
  Definition elements (A : Type) (m : tree A) :=
  xelements A m nil.

  Lemma get_empty : forall A p,
  get_rec A p empty = None.
Proof.
  intros.
  unfold get_rec, empty.
  set (f := fun  m0 : tree A => m0).
  assert (f Leaf = Leaf).
  subst; auto.
  clearbody f.
  revert f H.
  induction p; intros.
  - apply IHp. rewrite H. auto.
  - apply IHp. rewrite H. auto.
  - compute. rewrite H. auto.
Qed.

  Lemma elements_set_empty : forall A p x,
  elements A (set_rec A p x empty) = x :: nil.
Proof.
  intros.
  unfold set_rec.
  set (f := fun hole : tree A => hole).
  assert (forall t, elements A t = elements A (f t)).
  subst; auto.
  clearbody f.
  revert f H.
  induction p; intros.
  - apply IHp.
    intros; rewrite <- H.
    subst; auto.
  - apply IHp.
    intros; rewrite <- H.
    subst; auto.
  - unfold set_rec', empty.
    rewrite <- H.
    subst; auto.
Qed.

  Lemma get_node0 : forall A p m1 o m2,
  (get_rec A p~0 (Node m1 o m2)) = (get_rec A p m1).
Proof.
  intros.
  unfold get_rec, get_rec'; fold get_rec'.
  set (f1 := fun m0 : tree A => match m0 with
                        | Leaf => Leaf
                        | Node l _ _ => l
                        end).
  set (f2 := fun m0 : tree A => m0).
  assert (forall m1 o m2, f1 (Node m1 o m2) = f2 m1).
  subst; auto.
  clearbody f1 f2.
  revert f1 f2 H.
  induction p; intros.
  - unfold get_rec'; fold get_rec'.
    apply IHp.
    intros; rewrite H. auto.
  - unfold get_rec'; fold get_rec'.
    apply IHp.
    intros; rewrite H. auto.
  - compute. rewrite H. auto.
Qed.

  Lemma get_node1 : forall A p m1 o m2,
  (get_rec A p~1 (Node m1 o m2)) = (get_rec A p m2).
Proof.
  intros.
  unfold get_rec, get_rec'; fold get_rec'.
  set (f1 := fun m0 : tree A => match m0 with
                        | Leaf => Leaf
                        | Node _ _ r => r
                        end).
  set (f2 := fun m0 : tree A => m0).
  assert (forall m1 o m2, f1 (Node m1 o m2) = f2 m2).
  subst; auto.
  clearbody f1 f2.
  revert f1 f2 H.
  induction p; intros.
  - unfold get_rec'; fold get_rec'.
    apply IHp.
    intros; rewrite H. auto.
  -unfold get_rec'; fold get_rec'.
    apply IHp.
    intros; rewrite H. auto.
  - compute. rewrite H. auto.
Qed.

  Lemma set_node0 : forall A p x m1 o m2,
  (set_rec A p~0 x (Node m1 o m2)) = Node (set_rec A p x m1) o m2.
Proof.
  intros.
  unfold set_rec, set_rec'; fold set_rec'.
  set (f1 := fun hole : tree A => Node hole o m2) at 1.
  set (f2 := fun hole : tree A => hole).
  assert (forall t, f1 t = Node (f2 t) o m2).
  subst; auto.
  clearbody f1 f2.
  revert m1 f1 f2 H.
  induction p; intros.
  - unfold set_rec'; fold set_rec'.
    destruct m1.
    + apply IHp. intros; apply H.
    + apply IHp. intros; apply H.
  - unfold set_rec'; fold set_rec'.
    destruct m1.
    + apply IHp. intros; apply H.
    + apply IHp. intros; apply H.
  - unfold set_rec'; fold set_rec'.
    destruct m1.
    + apply H.
    + apply H.
Qed.

  Lemma set_node1 : forall A p x m1 o m2,
  (set_rec A p~1 x (Node m1 o m2)) = Node m1 o (set_rec A p x m2).
Proof.
  intros.
  unfold set_rec, set_rec'; fold set_rec'.
  set (f1 := fun hole : tree A => Node m1 o hole) at 1.
  set (f2 := fun hole : tree A => hole).
  assert (forall t, f1 t = Node m1 o (f2 t)).
  subst; auto.
  clearbody f1 f2.
  revert m2 f1 f2 H.
  induction p; intros.
  - unfold set_rec'; fold set_rec'.
    destruct m2.
    + apply IHp. intros; apply H.
    + apply IHp. intros; apply H.
  - unfold set_rec'; fold set_rec'.
    destruct m2.
    + apply IHp. intros; apply H.
    + apply IHp. intros; apply H.
  - unfold set_rec'; fold set_rec'.
    destruct m2.
    + apply H.
    + apply H.
Qed.

  Lemma xelements_append : forall A m l1 l2,
    xelements A m (l1 ++ l2) = xelements A m l1 ++ l2.
Proof.
    induction m; intros; simpl.
  - auto.
  - destruct o; rewrite IHm2; rewrite <- IHm1; auto.
  Qed.

  Lemma elements_set_none : forall A p x m,
  get_rec A p m = None ->
  exists l1 l2, elements A m = l1 ++ l2 /\
  elements A (set_rec A p x m) = l1 ++ (x :: l2).
Proof.
  intros.
  revert p H.
  induction m.
  - exists nil, nil.
    split; simpl.
    + auto.
    + apply elements_set_empty.
  - destruct p.
    + rewrite get_node1; intros.
      apply IHm2 in H; unfold elements in H.
      destruct H as [s1]; destruct H as [s2]; destruct H as [H1 H2].
      rewrite set_node1.
      destruct o; unfold elements; unfold xelements; fold xelements.
      * rewrite H1, H2.
        exists (xelements A m1 (a :: s1)), s2.
        split. apply (xelements_append A m1 (a :: s1) s2).
        apply (xelements_append A m1 (a :: s1) (x :: s2)).
      * rewrite H1, H2.
        exists (xelements A m1 s1), s2.
        split. apply (xelements_append A m1 s1 s2).
        apply (xelements_append A m1 s1 (x :: s2)).
    + rewrite get_node0; intros.
      apply IHm1 in H; unfold elements in H.
      destruct H as [s1]; destruct H as [s2]; destruct H as [H1 H2].
      rewrite set_node0.
      destruct o; unfold elements; unfold xelements; fold xelements.
      * exists s1, (s2 ++ a :: xelements A m2 nil).
        rewrite app_comm_cons. repeat rewrite app_assoc. rewrite <- H1, <- H2.
        split.
        apply (xelements_append A m1 nil (a :: xelements A m2 nil)).
        apply (xelements_append A (set_rec A p x m1) nil (a :: xelements A m2 nil)).
      * exists s1, (s2 ++ xelements A m2 nil).
        rewrite app_comm_cons. repeat rewrite app_assoc. rewrite <- H1, <- H2.
        split.
        apply (xelements_append A m1 nil (xelements A m2 nil)).
        apply (xelements_append A (set_rec A p x m1) nil (xelements A m2 nil)).
    + unfold get_rec, get_rec', set_rec, set_rec'.
      intros. rewrite H.
      unfold elements; unfold xelements; fold xelements.
      exists (xelements A m1 nil), (xelements A m2 nil).
      split.
      apply (xelements_append A m1 nil (xelements A m2 nil)).
      apply (xelements_append A m1 nil (x :: xelements A m2 nil)).
Qed.

  Lemma elements_set_some : forall A p x x' m,
  get_rec A p m = Some x ->
  exists l1 l2, elements A m = l1 ++ (x :: l2) /\
  elements A (set_rec A p x' m) = l1 ++ (x' :: l2).
Proof.
  intros.
  revert p H.
  induction m.
  - intros.
    pose proof get_empty A p; unfold empty in H0.
    congruence.
  - destruct p.
    + rewrite get_node1; intros.
      apply IHm2 in H; unfold elements in H.
      destruct H as [s1]; destruct H as [s2]; destruct H as [H1 H2].
      rewrite set_node1.
      destruct o; unfold elements; unfold xelements; fold xelements.
      * rewrite H1, H2.
        exists (xelements A m1 (a :: s1)), s2.
        split. apply (xelements_append A m1 (a :: s1) (x :: s2)).
        apply (xelements_append A m1 (a :: s1) (x' :: s2)).
      * rewrite H1, H2.
        exists (xelements A m1 s1), s2.
        split. apply (xelements_append A m1 s1 (x :: s2)).
        apply (xelements_append A m1 s1 (x' :: s2)).
    + rewrite get_node0; intros.
      apply IHm1 in H; unfold elements in H.
      destruct H as [s1]; destruct H as [s2]; destruct H as [H1 H2].
      rewrite set_node0.
      destruct o; unfold elements; unfold xelements; fold xelements.
      * exists s1, (s2 ++ a :: xelements A m2 nil).
        repeat rewrite app_comm_cons. repeat rewrite app_assoc.
        rewrite <- H1, <- H2.
        split.
        apply (xelements_append A m1 nil (a :: xelements A m2 nil)).
        apply (xelements_append A (set_rec A p x' m1) nil (a :: xelements A m2 nil)).
      * exists s1, (s2 ++ xelements A m2 nil).
        repeat rewrite app_comm_cons. repeat rewrite app_assoc.
        rewrite <- H1, <- H2.
        split.
        apply (xelements_append A m1 nil (xelements A m2 nil)).
        apply (xelements_append A (set_rec A p x' m1) nil (xelements A m2 nil)).
    + unfold get_rec, get_rec', set_rec, set_rec'.
      intros. rewrite H.
      unfold elements; unfold xelements; fold xelements.
      exists (xelements A m1 nil), (xelements A m2 nil).
      split.
      apply (xelements_append A m1 nil (x :: xelements A m2 nil)).
      apply (xelements_append A m1 nil (x' :: xelements A m2 nil)).
Qed.

End PTree.


(** * Equalizers defined in terms of limits *)
(** ** Contents
- Definition of equalizers
- Coincides with the direct definition
*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.Combinatorics.StandardFiniteSets.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.equalizers.

Local Open Scope cat.

(** * Definition of equalizers in terms of limits *)
Section def_equalizers.

  Variable C : category.
  Let hs: has_homsets C := homset_property C.

  Open Scope stn.
  Definition One : two := ● 0.
  Definition Two : two := ● 1.
  Close Scope stn.

  Definition Equalizer_graph : graph.
  Proof.
    exists two.
    use (@two_rec (two -> UU)).
    - apply two_rec.
      + apply empty.
      + apply (unit ⨿ unit).
    - apply (λ _, empty).
  Defined.

  Definition Equalizer_diagram {a b : C} (f g : C⟦a, b⟧) : diagram Equalizer_graph C.
  Proof.
    exists (two_rec a b).
    use two_rec_dep.
    - use two_rec_dep; simpl.
      + apply fromempty.
      + intro x. induction x.
        exact f. exact g.
    - intro. apply fromempty.
  Defined.

  Definition Equalizer_cone {a b : C} (f g : C⟦a, b⟧) (d : C) (h : C⟦d, a⟧) (H : h · f = h · g) :
    cone (Equalizer_diagram f g) d.
  Proof.
    use make_cone.
    - use two_rec_dep.
      + exact h.
      + exact (h · f).
    - use two_rec_dep; use two_rec_dep.
      + exact (empty_rect _).
      + intro e. induction e.
        * apply idpath.
        * apply (! H).
      + exact (empty_rect _).
      + exact (empty_rect _).
  Defined.

  Definition isEqualizer {a b : C} (f g : C⟦a, b⟧) (d : C) (h : C⟦d, a⟧) (H : h · f = h · g) :
    UU := isLimCone (Equalizer_diagram f g) d (Equalizer_cone f g d h H).

  Definition make_isEqualizer {a b : C} (f g : C⟦a, b⟧) (d : C) (h : C⟦d, a⟧) (H : h · f = h · g) :
    (∏ e (h' : C⟦e, a⟧) (H' : h' · f = h' · g),
     iscontr (total2 (fun hk : C⟦e, d⟧ => hk · h = h'))) -> isEqualizer f g d h H.
  Proof.
    intros H' x cx.
    assert (H1 : coneOut cx One · f = coneOut cx One · g).
    {
      use (pathscomp0 (coneOutCommutes cx One Two (ii1 tt))).
      use (pathscomp0 _ (!(coneOutCommutes cx One Two (ii2 tt)))).
      apply idpath.
    }
    set (H2 := (H' x (coneOut cx One) H1)).
    use tpair.
    - use (tpair _ (pr1 (pr1 H2)) _).
      use two_rec_dep.
      + apply (pr2 (pr1 H2)).
      + use (pathscomp0 _ (coneOutCommutes cx One Two (ii1 tt))).
        change (coneOut (Equalizer_cone f g d h H) (● 1)%stn) with (h · f).
        rewrite assoc.
        apply cancel_postcomposition, (pr2 (pr1 H2)).
    - abstract (intro t; apply subtypePath;
                [ intros y; apply impred; intros t0; apply hs
                | induction t as [t p]; apply path_to_ctr, (p One)]).
  Defined.

  Definition Equalizer {a b : C} (f g : C⟦a, b⟧) := LimCone (Equalizer_diagram f g).

  Definition make_Equalizer {a b : C} (f g : C⟦a, b⟧) (d : C) (h : C⟦d, a⟧)
             (H : h · f = h · g) (isEq : isEqualizer f g d h H) :
    Equalizer f g.
  Proof.
    use tpair.
    - use tpair.
      + exact d.
      + use Equalizer_cone.
        * exact h.
        * exact H.
    - exact isEq.
  Defined.

  Definition Equalizers : UU := ∏ (a b : C) (f g : C⟦a, b⟧), Equalizer f g.

  Definition hasEqualizers : UU := ∏ (a b : C) (f g : C⟦a, b⟧), ishinh (Equalizer f g).

  Definition EqualizerObject {a b : C} {f g : C⟦a, b⟧} : Equalizer f g -> C := λ H, lim H.

  Definition EqualizerArrow {a b : C} {f g : C⟦a, b⟧} (E : Equalizer f g) :
    C⟦lim E, a⟧ := limOut E One.

  Definition EqualizerArrowEq {a b : C} {f g : C⟦a, b⟧} (E : Equalizer f g) :
    EqualizerArrow E · f = EqualizerArrow E · g.
  Proof.
    use (pathscomp0 (limOutCommutes E One Two (ii1 tt))).
    use (pathscomp0 _ (!(limOutCommutes E One Two (ii2 tt)))).
    apply idpath.
  Qed.

  Definition EqualizerIn {a b : C} {f g : C⟦a, b⟧} (E : Equalizer f g) (e : C) (h : C⟦e, a⟧)
             (H : h · f = h · g) : C⟦e, lim E⟧.
  Proof.
    now use limArrow; use Equalizer_cone.
  Defined.

  Lemma EqualizerArrowComm {a b : C} {f g : C⟦a, b⟧} (E : Equalizer f g) (e : C) (h : C⟦e, a⟧)
        (H : h · f = h · g) : EqualizerIn E e h H · EqualizerArrow E = h.
  Proof.
    exact (limArrowCommutes E e _ One).
  Qed.

  Lemma EqualizerInUnique {a b : C} {f g : C⟦a, b⟧} (E : Equalizer f g) (e : C) (h : C⟦e, a⟧)
        (H : h · f = h · g) (w : C⟦e, lim E⟧) (H' : w · EqualizerArrow E = h) :
    w = EqualizerIn E e h H.
  Proof.
    apply path_to_ctr.
    use two_rec_dep.
    - apply H'.
    - set (X := limOutCommutes E One Two (ii1 tt)).
      apply (maponpaths (λ h : _, w · h)) in X.
      use (pathscomp0 (!X)); rewrite assoc.
      change (dmor _ _) with f.
      change (coneOut _ _) with (h · f).
      apply cancel_postcomposition, H'.
  Qed.

  Definition isEqualizer_Equalizer {a b : C} {f g : C⟦a, b⟧} (E : Equalizer f g) :
    isEqualizer f g (EqualizerObject E) (EqualizerArrow E) (EqualizerArrowEq E).
  Proof.
    apply make_isEqualizer.
    intros e h H.
    use (unique_exists (EqualizerIn E e h H)).
    (* Commutativity *)
    - exact (EqualizerArrowComm E e h H).
    (* Equality on equalities of morphisms *)
    - intros y. apply hs.
    (* Uniqueness *)
    - intros y t. cbn in t.
      use EqualizerInUnique.
      exact t.
  Qed.

  (** ** Equalizers to equalizers *)

  Definition identity_is_Equalizer_input {a b : C} {f g : C⟦a, b⟧} (E : Equalizer f g) :
    total2 (fun hk : C⟦lim E, lim E⟧ => hk · EqualizerArrow E = EqualizerArrow E).
  Proof.
    use tpair.
    exact (identity _).
    apply id_left.
  Defined.

  Lemma EqualizerEndo_is_identity  {a b : C} {f g : C⟦a, b⟧} (E : Equalizer f g)
        (k : C⟦lim E, lim E⟧) (kH : k · EqualizerArrow E = EqualizerArrow E) :
    identity (lim E) = k.
  Proof.
    apply lim_endo_is_identity.
    unfold limOut.
    use two_rec_dep; cbn.
    + apply kH.
    + set (X := (coneOutCommutes (limCone E) One Two (ii1 tt))).
      use (pathscomp0 (! (maponpaths (λ h' : _, k · h') X))).
      use (pathscomp0 _ X).
      rewrite assoc; change (dmor _ _) with f.
      apply cancel_postcomposition, kH.
  Qed.

  Definition from_Equalizer_to_Equalizer {a b : C} {f g : C⟦a, b⟧} (E1 E2 : Equalizer f g) :
    C⟦lim E1, lim E2⟧.
  Proof.
    apply (EqualizerIn E2 (lim E1) (EqualizerArrow E1)).
    exact (EqualizerArrowEq E1).
  Defined.

  Lemma are_inverses_from_Equalizer_to_Equalizer {a b : C} {f g : C⟦a, b⟧} (E1 E2 : Equalizer f g) :
    is_inverse_in_precat (from_Equalizer_to_Equalizer E2 E1)
                         (from_Equalizer_to_Equalizer E1 E2).
  Proof.
    split; apply pathsinv0.
    - apply EqualizerEndo_is_identity.
      rewrite <- assoc.
      unfold from_Equalizer_to_Equalizer.
      repeat rewrite EqualizerArrowComm.
      apply idpath.
    - apply EqualizerEndo_is_identity.
      rewrite <- assoc.
      unfold from_Equalizer_to_Equalizer.
      repeat rewrite EqualizerArrowComm.
      apply idpath.
  Qed.

  Lemma isiso_from_Equalizer_to_Equalizer {a b : C} {f g : C⟦a, b⟧} (E1 E2 : Equalizer f g) :
    is_iso (from_Equalizer_to_Equalizer E1 E2).
  Proof.
    apply (is_iso_qinv _ (from_Equalizer_to_Equalizer E2 E1)).
    apply are_inverses_from_Equalizer_to_Equalizer.
  Qed.

  Definition iso_from_Equalizer_to_Equalizer {a b : C} {f g : C⟦a, b⟧} (E1 E2 : Equalizer f g) :
    iso (lim E1) (lim E2) := tpair _ _ (isiso_from_Equalizer_to_Equalizer E1 E2).

  Lemma inv_from_iso_iso_from_Pullback {a b : C} {f g : C⟦a , b⟧} (E1 E2 : Equalizer f g):
    inv_from_iso (iso_from_Equalizer_to_Equalizer E1 E2) = from_Equalizer_to_Equalizer E2 E1.
  Proof.
    apply pathsinv0.
    apply inv_iso_unique'.
    apply (pr1 (are_inverses_from_Equalizer_to_Equalizer E2 E1)).
  Qed.

  (** ** Connections to other limits *)

  Lemma Equalizers_from_Lims :
    Lims C -> Equalizers.
  Proof.
    intros H a b f g. apply H.
  Defined.

End def_equalizers.

(** * Definitions coincide
  In this section we show that the definition of equalizer as a limit
  coincides with the direct definition. *)
Section equalizers_coincide.

  Variable C : category.
  Let hs: has_homsets C := homset_property C.

  (** ** isEqualizers *)

  Lemma equiv_isEqualizer1 {a b : C} {f g : C⟦a, b⟧} (e : C) (h : C⟦e, a⟧) (H : h · f = h · g) :
    limits.equalizers.isEqualizer f g h H -> isEqualizer C f g e h H.
  Proof.
    intros X.
    set (E := limits.equalizers.make_Equalizer f g h H X).
    use (make_isEqualizer C).
    intros e' h' H'.
    use (unique_exists (limits.equalizers.EqualizerIn E e' h' H')).
    (* Commutativity *)
    - exact (limits.equalizers.EqualizerCommutes E e' h' H').
    (* Equality on equalities of morphisms *)
    - intros y. apply hs.
    (* Uniqueness *)
    - intros y T. cbn in T.
      use (limits.equalizers.EqualizerInsEq E).
      use (pathscomp0 T).
      exact (!(limits.equalizers.EqualizerCommutes E e' h' H')).
  Qed.

  Lemma equiv_isEqualizer2 {a b : C} (f g : C⟦a, b⟧) (e : C) (h : C⟦e, a⟧) (H : h · f = h · g) :
    limits.equalizers.isEqualizer f g h H <- isEqualizer C f g e h H.
  Proof.
    intros X.
    set (E := make_Equalizer C f g e h H X).
    intros e' h' H'.
    use (unique_exists (EqualizerIn C E e' h' H')).
    (* Commutativity *)
    - exact (EqualizerArrowComm C E e' h' H').
    (* Equality on equalities of morphisms *)
    - intros y. apply hs.
    (* Uniqueness *)
    - intros y T. cbn in T.
      use (EqualizerInUnique C E).
      exact T.
  Qed.

  (** ** Equalizers *)

  Definition equiv_Equalizer1 {a b : C} (f g : C⟦a, b⟧) :
    limits.equalizers.Equalizer f g -> Equalizer C f g.
  Proof.
    intros E.
    exact (make_Equalizer
             C f g _ _ _
             (equiv_isEqualizer1
                (limits.equalizers.EqualizerObject E)
                (limits.equalizers.EqualizerArrow E)
                (limits.equalizers.EqualizerEqAr E)
                (limits.equalizers.isEqualizer_Equalizer E))).
  Defined.

  Definition equiv_Equalizers1 : @limits.equalizers.Equalizers C -> Equalizers C.
  Proof.
    intros E' a b f g.
    set (E := E' a b f g).
    exact (make_Equalizer
             C f g _ _ _
             (equiv_isEqualizer1
                (limits.equalizers.EqualizerObject E)
                (limits.equalizers.EqualizerArrow E)
                (limits.equalizers.EqualizerEqAr E)
                (limits.equalizers.isEqualizer_Equalizer E))).
  Defined.

  Definition equiv_Equalizer2 {a b : C} (f g : C⟦a, b⟧) :
    limits.equalizers.Equalizer f g <- Equalizer C f g.
  Proof.
    intros E.
    exact (@limits.equalizers.make_Equalizer
             C (EqualizerObject C E) a b f g
             (EqualizerArrow C E)
             (EqualizerArrowEq C E)
             (@equiv_isEqualizer2
                a b f g (EqualizerObject C E)
                (EqualizerArrow C E)
                (EqualizerArrowEq C E)
                (isEqualizer_Equalizer C E))).
  Defined.

  Definition equiv_Equalizers2 : @limits.equalizers.Equalizers C <- Equalizers C.
  Proof.
    intros E' a b f g.
    set (E := E' a b f g).
    exact (@limits.equalizers.make_Equalizer
             C (EqualizerObject C E) a b f g
             (EqualizerArrow C E)
             (EqualizerArrowEq C E)
             (@equiv_isEqualizer2
                a b f g (EqualizerObject C E)
                (EqualizerArrow C E)
                (EqualizerArrowEq C E)
                (isEqualizer_Equalizer C E))).
  Defined.

End equalizers_coincide.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.model.structures.Qsec.
Require Import CoRN.algebra.CSetoidFun.

(**
** Example of a setoid: [Q]
*** Setoid
*)
Lemma ap_Q_irreflexive1 : irreflexive (A:=Q) Qap.
Proof.
 red in |- *.
 apply ap_Q_irreflexive0.
Qed.

Lemma ap_Q_symmetric1 : Csymmetric Qap.
Proof.
 red in |- *.
 apply ap_Q_symmetric0.
Qed.

Lemma ap_Q_cotransitive1 : cotransitive (A:=Q) Qap.
Proof.
 red in |- *.
 apply ap_Q_cotransitive0.
Qed.

Lemma ap_Q_tight1 : tight_apart (A:=Q) Qeq Qap.
Proof.
 red in |- *.
 apply ap_Q_tight0.
Qed.

Definition ap_Q_is_apartness := Build_is_CSetoid Q Qeq Qap
 ap_Q_irreflexive1 ap_Q_symmetric1 ap_Q_cotransitive1 ap_Q_tight1.

Definition Q_as_CSetoid := Build_CSetoid _ _ _ ap_Q_is_apartness.
Canonical Structure Q_as_CSetoid.
Canonical Structure Q_is_Setoid := (cs_crr Q_as_CSetoid).

(**
*** Addition
*)

Lemma Qplus_wd : bin_fun_wd Q_as_CSetoid Q_as_CSetoid Q_as_CSetoid Qplus.
Proof. repeat intro. apply Qplus_comp; trivial. Qed.

Lemma Qplus_strext1 : bin_fun_strext Q_as_CSetoid Q_as_CSetoid Q_as_CSetoid Qplus.
Proof. repeat intro. apply Qplus_strext0; trivial. Qed.

Definition Qplus_is_bin_fun := Build_CSetoid_bin_fun _ _ _ _ Qplus_strext1.
(* Canonical Structure Qplus_is_bin_fun. *)

(** It is associative and commutative.
*)

Lemma Qplus_is_assoc : associative Qplus_is_bin_fun.
Proof Qplus_assoc.

Lemma Qplus_is_commut1 : commutes Qplus_is_bin_fun.
Proof Qplus_comm.

(**
*** Opposite
*)

Lemma Qopp_wd : fun_wd (S1:=Q_as_CSetoid) (S2:=Q_as_CSetoid) Qopp.
Proof. repeat intro. apply Qopp_comp; trivial. Qed.

Lemma Qopp_strext : fun_strext (S1:=Q_as_CSetoid) (S2:=Q_as_CSetoid) Qopp.
Proof. firstorder using Qopp_comp. Qed.

Definition Qopp_is_fun := Build_CSetoid_fun _ _ _ Qopp_strext.
(* Canonical Structure Qopp_is_fun. *)

(**
*** Multiplication
*)

Lemma Qmult_wd : bin_fun_wd Q_as_CSetoid Q_as_CSetoid Q_as_CSetoid Qmult.
Proof. repeat intro. apply Qmult_comp; trivial. Qed.

Lemma Qmult_strext1 : bin_fun_strext Q_as_CSetoid Q_as_CSetoid Q_as_CSetoid Qmult.
Proof. repeat intro. apply Qmult_strext0; trivial. Qed.

Definition Qmult_is_bin_fun := Build_CSetoid_bin_fun _ _ _ _ Qmult_strext1.
(* Canonical Structure Qmult_is_bin_fun. *)

(** It is associative and commutative.
*)

Lemma Qmult_is_assoc : associative Qmult_is_bin_fun.
Proof. repeat intro. apply Qmult_assoc. Qed.

Lemma Qmult_is_commut : commutes Qmult_is_bin_fun.
Proof. repeat intro. apply Qmult_comm. Qed.

(**
*** Less-than
*)

Lemma Qlt_strext : Crel_strext Q_as_CSetoid Qlt.
Proof.
 red in |- *.
 apply Qlt_strext_unfolded.
Qed.

Definition Qlt_is_CSetoid_relation := Build_CCSetoid_relation _ _ Qlt_strext.
Canonical Structure Qlt_is_CSetoid_relation.


Require Import List.
Import ListNotations.

Require Import BinInt ZArith_dec.
Require Export Id State Expr Stmt SmallStep.

From hahn Require Import HahnBase.

Inductive cont : Type :=
| KEmpty : cont
| KStmt  : stmt -> cont.

Definition Kapp (l r : cont) : cont :=
  match (l, r) with
  | (KStmt ls, KStmt rs) => KStmt (ls ;; rs)
  | (KEmpty  , _       ) => r
  | (_       , _       ) => l
  end.

Notation "'!' s" := (KStmt s) (at level 0).
Notation "s1 @ s2" := (Kapp s1 s2) (at level 0).

Reserved Notation "k '|-' c1 '--' s '-->' c2" (at level 0).

Inductive cps_int : cont -> cont -> conf -> conf -> Prop :=
| cps_Empty       : forall (c : conf), KEmpty |- c -- KEmpty --> c
| cps_Skip        : forall (c c' : conf) (k : cont)
                           (CSTEP : KEmpty |- c -- k --> c'),
    k |- c -- !SKIP --> c'
| cps_Assign      : forall (s : state Z) (i o : list Z) (c' : conf)
                           (k : cont) (x : id) (e : expr) (n : Z)
                           (CVAL : [| e |] s => n)
                           (CSTEP : KEmpty |- (s [x <- n], i, o) -- k --> c'),
    k |- (s, i, o) -- !(x ::= e) --> c'
| cps_Read        : forall (s : state Z) (i o : list Z) (c' : conf)
                           (k : cont) (x : id) (z : Z)
                      (CSTEP : KEmpty |- (s [x <- z], i, o) -- k --> c'),
    k |- (s, z::i, o) -- !(READ x) --> c'
| cps_Write       : forall (s : state Z) (i o : list Z) (c' : conf)
                           (k : cont) (e : expr) (z : Z)
                      (CVAL : [| e |] s => z)
                      (CSTEP : KEmpty |- (s, i, z::o) -- k --> c'),
    k |- (s, i, o) -- !(WRITE e) --> c'
| cps_Seq         : forall (c c' : conf) (k : cont) (s1 s2 : stmt)
                           (CSTEP : !s2 @ k |- c -- !s1 --> c'),
    k |- c -- !(s1 ;; s2) --> c'
| cps_If_True     : forall (s : state Z) (i o : list Z) (c' : conf)
                           (k : cont) (e : expr) (s1 s2 : stmt)
                      (CVAL : [| e |] s => Z.one)
                      (CSTEP : k |- (s, i, o) -- !s1 --> c'),
    k |- (s, i, o) -- !(COND e THEN s1 ELSE s2 END) --> c'
| cps_If_False    : forall (s : state Z) (i o : list Z) (c' : conf)
                           (k : cont) (e : expr) (s1 s2 : stmt)
                      (CVAL : [| e |] s => Z.zero)
                      (CSTEP : k |- (s, i, o) -- !s2 --> c'),
    k |- (s, i, o) -- !(COND e THEN s1 ELSE s2 END) --> c'
| cps_While_True  : forall (st : state Z) (i o : list Z) (c' : conf)
                           (k : cont) (e : expr) (s : stmt)
                      (CVAL : [| e |] st => Z.one)
                      (CSTEP : !(WHILE e DO s END) @ k |- (st, i, o) -- !s --> c'),
    k |- (st, i, o) -- !(WHILE e DO s END) --> c'
| cps_While_False : forall (st : state Z) (i o : list Z) (c' : conf)
                           (k : cont) (e : expr) (s : stmt)
                      (CVAL : [| e |] st => Z.zero)
                      (CSTEP : KEmpty |- (st, i, o) -- k --> c'),
    k |- (st, i, o) -- !(WHILE e DO s END) --> c'
where "k |- c1 -- s --> c2" := (cps_int k s c1 c2).

Ltac cps_bs_gen_helper k H EXEC :=
  destruct k eqn:K; subst; inv H;
  [inv EXEC | eapply bs_Seq; eauto];
  econstructor; eauto.

Lemma cps_bs_gen (S : stmt) (c c' : conf) (S1 k : cont)
      (EXEC : k |- c -- S1 --> c') (DEF : !S = S1 @ k):
  c == S ==> c'.
Proof. admit. Admitted.

Lemma cps_bs (s1 s2 : stmt) (c c' : conf) (STEP : !s2 |- c -- !s1 --> c'):
   c == s1 ;; s2 ==> c'.
Proof. admit. Admitted.

Lemma cps_int_to_bs_int (c c' : conf) (s : stmt)
      (STEP : KEmpty |- c -- !(s) --> c') :
  c == s ==> c'.
Proof. admit. Admitted.

Lemma cps_cont_to_seq c1 c2 k1 k2 k3
      (STEP : (k2 @ k3 |- c1 -- k1 --> c2)) :
  (k3 |- c1 -- k1 @ k2 --> c2).
Proof. admit. Admitted.

Lemma bs_int_to_cps_int_cont c1 c2 c3 s k
      (EXEC : c1 == s ==> c2)
      (STEP : k |- c2 -- !(SKIP) --> c3) :
  k |- c1 -- !(s) --> c3.
Proof. admit. Admitted.

Lemma bs_int_to_cps_int st i o c' s (EXEC : (st, i, o) == s ==> c') :
  KEmpty |- (st, i, o) -- !s --> c'.
Proof. admit. Admitted.