(** **********************************************************

Ralph Matthes

2022
*)

(** **********************************************************

Contents :

- defines a notion of binary products for displayed categories that gives binary products on its total category
- same programme for terminal objects

 ************************************************************)

Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.MoreFoundations.Tactics.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.

Local Open Scope cat.
Local Open Scope mor_disp.

Section FixDispCat.

  Context {C : category} (D : disp_cat C).

  Definition is_dispBinProduct_naive (c d p : C) (p1 : p --> c) (p2 : p --> d) (cc : D c)
    (dd : D d) (pp : D p) (pp1 : pp -->[p1] cc) (pp2 : pp -->[p2] dd) : UU :=
    ∏ (a : C) (f : a --> c) (g : a --> d) (aa : D a) (ff : aa -->[f] cc) (gg : aa -->[g] dd),
      ∃! (fg : a --> p) (fgfg : aa -->[fg] pp),
      ∑ fgok : ((fg · p1 = f) × (fg · p2 = g)),
        (fgfg ;; pp1 = transportb _ (pr1 fgok) ff) × (fgfg ;; pp2 = transportb _ (pr2 fgok) gg).

  Definition is_dispBinProduct (c d : C) (P : BinProduct C c d)
    (cc : D c) (dd : D d) (pp : D (BinProductObject _ P))
    (pp1 : pp -->[BinProductPr1 _ P] cc) (pp2 : pp -->[BinProductPr2 _ P] dd) : UU :=
    ∏ (a : C) (f : a --> c) (g : a --> d) (aa : D a) (ff : aa -->[f] cc) (gg : aa -->[g] dd),
      ∃! (fgfg : aa -->[BinProductArrow _ P f g] pp),
      (fgfg ;; pp1 = transportb _ (BinProductPr1Commutes _ _ _ P _ f g) ff) ×
      (fgfg ;; pp2 = transportb _ (BinProductPr2Commutes _ _ _ P _ f g) gg).

  Definition dispBinProduct (c d : C) (P : BinProduct C c d) (cc : D c) (dd : D d) : UU :=
    ∑ pppp1pp2 : (∑ pp : D (BinProductObject _ P),
                     (pp -->[BinProductPr1 _ P] cc) × (pp -->[BinProductPr2 _ P] dd)),
        is_dispBinProduct c d P cc dd (pr1 pppp1pp2) (pr1 (pr2 pppp1pp2)) (pr2 (pr2 pppp1pp2)).

  Definition dispBinProductObject {c d : C} (P : BinProduct C c d) {cc : D c} {dd : D d}
    (dP : dispBinProduct c d P cc dd) : D (BinProductObject _ P) := pr1 (pr1 dP).

  Definition dispBinProductPr1 {c d : C} (P : BinProduct C c d) {cc : D c} {dd : D d}
    (dP : dispBinProduct c d P cc dd) : dispBinProductObject P dP -->[BinProductPr1 _ P] cc :=
    pr1 (pr2 (pr1 dP)).

  Definition dispBinProductPr2 {c d : C} (P : BinProduct C c d) {cc : D c} {dd : D d}
    (dP : dispBinProduct c d P cc dd) : dispBinProductObject P dP -->[BinProductPr2 _ P] dd :=
    pr2 (pr2 (pr1 dP)).

  Definition is_dispBinProduct_dispBinProduct {c d : C} (P : BinProduct C c d) {cc : D c} {dd : D d}
    (dP : dispBinProduct c d P cc dd) :
    is_dispBinProduct c d P cc dd (dispBinProductObject P dP) (dispBinProductPr1 P dP) (dispBinProductPr2 P dP).
  Proof.
    exact (pr2 dP).
  Defined.

  Definition dispBinProductArrow {c d : C} (P : BinProduct C c d) {cc : D c} {dd : D d}
    (dP : dispBinProduct c d P cc dd) {a : C} {f : a --> c} {g : a --> d} {aa : D a} (ff : aa -->[f] cc) (gg : aa -->[g] dd) :
       aa -->[BinProductArrow _ P f g] dispBinProductObject P dP.
  Proof.
    exact (pr1 (pr1 (is_dispBinProduct_dispBinProduct P dP _ _ _ _ ff gg))).
  Defined.

  Lemma dispBinProductPr1Commutes {c d : C} (P : BinProduct C c d) (cc : D c) (dd : D d) (dP : dispBinProduct c d P cc dd):
    ∏ (a : C) (f : a --> c) (g : a --> d) (aa : D a) (ff : aa -->[f] cc) (gg : aa -->[g] dd),
      dispBinProductArrow P dP ff gg ;; dispBinProductPr1 P dP = transportb _ (BinProductPr1Commutes _ _ _ P _ f g) ff.
  Proof.
    intros a f g aa ff gg.
    exact (pr1 (pr2 (pr1 (is_dispBinProduct_dispBinProduct P dP _ _ _ _ ff gg)))).
  Qed.

  Lemma dispBinProductPr2Commutes {c d : C} (P : BinProduct C c d) (cc : D c) (dd : D d) (dP : dispBinProduct c d P cc dd):
    ∏ (a : C) (f : a --> c) (g : a --> d) (aa : D a) (ff : aa -->[f] cc) (gg : aa -->[g] dd),
      dispBinProductArrow P dP ff gg ;; dispBinProductPr2 P dP = transportb _ (BinProductPr2Commutes _ _ _ P _ f g) gg.
  Proof.
    intros a f g aa ff gg.
    exact (pr2 (pr2 (pr1 (is_dispBinProduct_dispBinProduct P dP _ _ _ _ ff gg)))).
  Qed.

  Lemma dispBinProductArrowUnique  {c d : C} (P : BinProduct C c d) (cc : D c) (dd : D d)
    (dP : dispBinProduct c d P cc dd) {x : C} (xx : D x) (f : x --> c) (g : x --> d) (ff : xx -->[f] cc) (gg : xx -->[g] dd)
    (kk : xx -->[BinProductArrow _ P f g] dispBinProductObject P dP) :
    kk ;; dispBinProductPr1 P dP = transportb _ (BinProductPr1Commutes _ _ _ P _ f g) ff ->
    kk ;; dispBinProductPr2 P dP = transportb _ (BinProductPr2Commutes _ _ _ P _ f g) gg ->
    kk = dispBinProductArrow P dP ff gg.
  Proof.
    intros H1 H2.
    apply path_to_ctr; split; assumption.
  Qed.

  (* transparent proofs for the standard binary products -- upstream?
  Definition BinProductArrowUnique' (c d : C) (P : BinProduct C c d) (x : C)
    (f : x --> c) (g : x --> d) (k : x --> BinProductObject C P) :
    k · BinProductPr1 C P = f -> k · BinProductPr2 C P = g ->
    k = BinProductArrow C P f g.
  Proof.
    intros; apply path_to_ctr; split; assumption.
  Defined.

  Definition BinProductArrowEta' (c d : C) (P : BinProduct C c d) (x : C)
    (f : x --> BinProductObject C P) :
    f = BinProductArrow C P (f · BinProductPr1 C P) (f · BinProductPr2 C P).
  Proof.
    apply BinProductArrowUnique'; apply idpath.
  Defined.
*)

  Lemma dispBinProductArrowEta {c d : C} (P : BinProduct C c d) (cc : D c) (dd : D d)
    (dP : dispBinProduct c d P cc dd) {x : C} (xx : D x) {fg : x --> BinProductObject C P }
    (fgfg : xx -->[ fg] dispBinProductObject P dP) :
    fgfg =
      transportb (mor_disp xx (dispBinProductObject P dP)) (BinProductArrowEta C c d P x fg)
        (dispBinProductArrow P dP (fgfg ;; dispBinProductPr1 P dP) (fgfg ;; dispBinProductPr2 P dP)).
  Proof.
    apply transportf_transpose_right.
    apply dispBinProductArrowUnique.
    - etrans.
      { apply mor_disp_transportf_postwhisker. }
      unfold transportb.
      apply (maponpaths (fun z => transportf (mor_disp xx cc) z (fgfg ;; dispBinProductPr1 P dP))).
      apply C.
    - etrans.
      { apply mor_disp_transportf_postwhisker. }
      unfold transportb.
      apply (maponpaths (fun z => transportf (mor_disp xx dd) z (fgfg ;; dispBinProductPr2 P dP))).
      apply C.
  Qed.

  Lemma dispBinProduct_endo_is_identity {a b : C} (aa : D a) (bb : D b)
    (P : BinProduct _ a b) (dP : dispBinProduct a b P aa bb)
    {k : BinProductObject _ P --> BinProductObject _ P} (kk: dispBinProductObject P dP -->[k] dispBinProductObject P dP)
    (H1 : k · BinProductPr1 _ P = BinProductPr1 _ P) (dH1 : kk ;; dispBinProductPr1 P dP = transportb _ H1 (dispBinProductPr1 P dP))
    (H2 : k · BinProductPr2 _ P = BinProductPr2 _ P) (dH2 : kk ;; dispBinProductPr2 P dP = transportb _ H2 (dispBinProductPr2 P dP))
    : transportf _ (BinProduct_endo_is_identity C a b P k H1 H2) (id_disp (dispBinProductObject P dP)) = kk.
  Proof.
    apply pathsinv0.
    etrans.
    { apply dispBinProductArrowEta. }
    apply pathsinv0, transportf_comp_lemma.
    apply dispBinProductArrowUnique.
    - etrans.
      { apply mor_disp_transportf_postwhisker. }
      rewrite id_left_disp.
      rewrite transport_f_b.
      apply transportf_comp_lemma.
      etrans.
      2: { apply pathsinv0; exact dH1. }
      apply transportf_comp_lemma.
      apply transportf_comp_lemma_hset;
        try apply homset_property; apply idpath.
    - etrans.
      { apply mor_disp_transportf_postwhisker. }
      rewrite id_left_disp.
      rewrite transport_f_b.
      apply transportf_comp_lemma.
      etrans.
      2: { apply pathsinv0; exact dH2. }
      apply transportf_comp_lemma.
      apply transportf_comp_lemma_hset;
        try apply homset_property; apply idpath.
  Qed.

  Definition dispBinProductOfArrows {c d : C} {Pcd : BinProduct C c d}
    {cc : D c} {dd : D d}
    (dPcd : dispBinProduct c d Pcd cc dd)
    {a b : C} {Pab : BinProduct C a b}
    {aa : D a} {bb : D b}
    (dPab : dispBinProduct a b Pab aa bb)
    {f : a --> c} {g : b --> d}
    (ff : aa -->[f] cc) (gg : bb -->[g] dd)
    : dispBinProductObject Pab dPab -->[BinProductOfArrows C Pcd Pab f g] dispBinProductObject Pcd dPcd :=
    dispBinProductArrow Pcd dPcd (dispBinProductPr1 Pab dPab ;; ff) (dispBinProductPr2 Pab dPab ;; gg).

  Lemma dispBinProductOfArrowsPr1 {c d : C} {Pcd : BinProduct C c d}
    {cc : D c} {dd : D d}
    (dPcd : dispBinProduct c d Pcd cc dd)
    {a b : C} {Pab : BinProduct C a b}
    {aa : D a} {bb : D b}
    (dPab : dispBinProduct a b Pab aa bb)
    {f : a --> c} {g : b --> d}
    (ff : aa -->[f] cc) (gg : bb -->[g] dd) :
    dispBinProductOfArrows dPcd dPab ff gg ;; dispBinProductPr1 Pcd dPcd =
      transportb _ (BinProductOfArrowsPr1 _ Pcd Pab f g) (dispBinProductPr1 Pab dPab ;; ff).
  Proof.
    unfold dispBinProductOfArrows.
    etrans.
    { apply dispBinProductPr1Commutes. }
    apply (maponpaths (fun z => transportb (mor_disp (dispBinProductObject Pab dPab) cc) z (dispBinProductPr1 Pab dPab ;; ff))).
    apply C.
  Qed.

  Lemma dispBinProductOfArrowsPr2 {c d : C} {Pcd : BinProduct C c d}
    {cc : D c} {dd : D d}
    (dPcd : dispBinProduct c d Pcd cc dd)
    {a b : C} {Pab : BinProduct C a b}
    {aa : D a} {bb : D b}
    (dPab : dispBinProduct a b Pab aa bb)
    {f : a --> c} {g : b --> d}
    (ff : aa -->[f] cc) (gg : bb -->[g] dd) :
    dispBinProductOfArrows dPcd dPab ff gg ;; dispBinProductPr2 Pcd dPcd =
      transportb _ (BinProductOfArrowsPr2 _ Pcd Pab f g) (dispBinProductPr2 Pab dPab ;; gg).
  Proof.
    unfold dispBinProductOfArrows.
    etrans.
    { apply dispBinProductPr2Commutes. }
    apply (maponpaths (fun z => transportb (mor_disp (dispBinProductObject Pab dPab) dd) z (dispBinProductPr2 Pab dPab ;; gg))).
    apply C.
  Qed.

  Lemma dispPostcompWithBinProductArrow {c d : C} {Pcd : BinProduct C c d} {cc : D c} {dd : D d} (dPcd : dispBinProduct c d Pcd cc dd)
    {a b : C} {Pab : BinProduct C a b} {aa : D a} {bb : D b} (dPab : dispBinProduct a b Pab aa bb)
    {f : a --> c} {g : b --> d} (ff : aa -->[f] cc) (gg : bb -->[g] dd)
    {x : C} {xx : D x} {k : x --> a} {h : x --> b} (kk: xx -->[k] aa) (hh: xx -->[h] bb) :
    dispBinProductArrow Pab dPab kk hh ;; dispBinProductOfArrows dPcd dPab ff gg =
      transportb _ (postcompWithBinProductArrow C Pcd Pab f g k h) (dispBinProductArrow Pcd dPcd (kk ;; ff) (hh ;; gg)).
  Proof.
    apply transportb_transpose_right.
    apply dispBinProductArrowUnique.
    - etrans.
      { apply mor_disp_transportf_postwhisker. }
      rewrite assoc_disp_var.
      rewrite dispBinProductOfArrowsPr1.
      rewrite transport_f_f.
      apply pathsinv0, transportf_comp_lemma.
      etrans.
      2: { apply pathsinv0, mor_disp_transportf_prewhisker. }
      rewrite assoc_disp.
      rewrite dispBinProductPr1Commutes.
      rewrite transport_f_b.
      apply transportf_comp_lemma.
      unfold transportb.
      etrans.
      2: { apply pathsinv0, mor_disp_transportf_postwhisker. }
      apply transportf_comp_lemma.
      apply transportf_comp_lemma_hset;
        try apply homset_property; apply idpath.
    - etrans.
      { apply mor_disp_transportf_postwhisker. }
      rewrite assoc_disp_var.
      rewrite dispBinProductOfArrowsPr2.
      rewrite transport_f_f.
      apply pathsinv0, transportf_comp_lemma.
      etrans.
      2: { apply pathsinv0, mor_disp_transportf_prewhisker. }
      rewrite assoc_disp.
      rewrite dispBinProductPr2Commutes.
      rewrite transport_f_b.
      apply transportf_comp_lemma.
      unfold transportb.
      etrans.
      2: { apply pathsinv0, mor_disp_transportf_postwhisker. }
      apply transportf_comp_lemma.
      apply transportf_comp_lemma_hset;
        try apply homset_property; apply idpath.
  Qed.

  Lemma dispPrecompWithBinProductArrow {c d : C} {Pcd : BinProduct C c d}
    {cc : D c} {dd : D d} (dPcd : dispBinProduct c d Pcd cc dd)
    {a : C} {aa : D a}
    {f : a --> c} {g : a --> d} (ff: aa -->[f] cc) (gg: aa -->[g] dd)
    {x : C} {xx : D x} {k : x --> a} (kk: xx -->[k] aa) :
    kk ;; dispBinProductArrow Pcd dPcd ff gg  =
      transportb _ (precompWithBinProductArrow C Pcd f g k) (dispBinProductArrow Pcd dPcd (kk ;; ff) (kk ;; gg)).
  Proof.
    apply transportb_transpose_right.
    apply dispBinProductArrowUnique.
    - rewrite mor_disp_transportf_postwhisker.
      rewrite assoc_disp_var.
      rewrite dispBinProductPr1Commutes.
      rewrite transport_f_f.
      etrans.
      { apply maponpaths.
        apply mor_disp_transportf_prewhisker. }
      rewrite transport_f_f.
      apply transportf_comp_lemma.
      apply transportf_comp_lemma_hset;
        try apply homset_property; apply idpath.
    - rewrite mor_disp_transportf_postwhisker.
      rewrite assoc_disp_var.
      rewrite dispBinProductPr2Commutes.
      rewrite transport_f_f.
      etrans.
      { apply maponpaths.
        apply mor_disp_transportf_prewhisker. }
      rewrite transport_f_f.
      apply transportf_comp_lemma.
      apply transportf_comp_lemma_hset;
        try apply homset_property; apply idpath.
  Qed.

  Definition dispBinProducts (Ps : BinProducts C)  : UU := ∏ (c d : C) (cc : D c) (dd : D d),
      dispBinProduct c d (Ps c d) cc dd.

  Lemma dispBinProductOfArrows_comp { Ps : BinProducts C } (dPs : dispBinProducts Ps) {a b c d x y : C}
    {aa : D a} {bb : D b} {cc : D c} {dd: D d} {xx : D x} {yy : D y}
    {f : a --> c} {f' : b --> d} {g : c --> x} {g' : d --> y}
    (ff : aa -->[f] cc) (ff' : bb -->[f'] dd) (gg : cc -->[g] xx) (gg' : dd -->[g'] yy) :
    dispBinProductOfArrows (dPs _ _ _ _) (dPs _ _ _ _) ff ff' ;; dispBinProductOfArrows (dPs _ _ _ _) (dPs _ _ _ _) gg gg' =
      transportb _ (BinProductOfArrows_comp _ _ _ _ _ _ _ _ f f' g g') (dispBinProductOfArrows (dPs _ _ _ _) (dPs _ _ _ _) (ff;;gg) (ff';;gg')).
  Proof.
    apply transportb_transpose_right.
    apply dispBinProductArrowUnique.
    - etrans.
      { apply mor_disp_transportf_postwhisker. }
      rewrite assoc_disp_var.
      rewrite dispBinProductOfArrowsPr1.
      rewrite transport_f_f.
      apply pathsinv0, transportf_comp_lemma.
      etrans.
      2: { apply pathsinv0, mor_disp_transportf_prewhisker. }
      do 2 rewrite assoc_disp.
      rewrite dispBinProductOfArrowsPr1.
      do 2 rewrite transport_f_b.
      apply pathsinv0, transportf_comp_lemma.
      etrans.
      { apply maponpaths.
        apply mor_disp_transportf_postwhisker. }
      rewrite transport_f_f.
      apply transportf_comp_lemma_hset;
        try apply homset_property; apply idpath.
    - etrans.
      { apply mor_disp_transportf_postwhisker. }
      rewrite assoc_disp_var.
      rewrite dispBinProductOfArrowsPr2.
      rewrite transport_f_f.
      apply pathsinv0, transportf_comp_lemma.
      etrans.
      2: { apply pathsinv0, mor_disp_transportf_prewhisker. }
      do 2 rewrite assoc_disp.
      rewrite dispBinProductOfArrowsPr2.
      do 2 rewrite transport_f_b.
      apply pathsinv0, transportf_comp_lemma.
      etrans.
      { apply maponpaths.
        apply mor_disp_transportf_postwhisker. }
      rewrite transport_f_f.
      apply transportf_comp_lemma_hset;
        try apply homset_property; apply idpath.
  Qed.

  Definition total_category_Binproducts_data (Ps : BinProducts C) (dPs : dispBinProducts Ps) (ccc ddd : total_category D) :
    ∑ p : total_category D, total_category D ⟦ p, ccc ⟧ × total_category D ⟦ p, ddd ⟧.
  Proof.
    induction ccc as [c cc].
    induction ddd as [d dd].
    - exists (BinProductObject _ (Ps c d) ,, dispBinProductObject (Ps c d) (dPs c d cc dd)).
      split.
      + use tpair.
        * apply BinProductPr1.
        * apply dispBinProductPr1.
      + use tpair.
        * apply BinProductPr2.
        * apply dispBinProductPr2.
  Defined.

  Definition total_category_Binproducts_mediating_morphism (Ps : BinProducts C) (dPs : dispBinProducts Ps)
    {c d x : C} {cc : D c} {dd: D d} {xx : D x} {f : x --> c} (ff: xx -->[f] cc) {g : x --> d} (gg: xx -->[g] dd) :
     ∑ h : x --> BinProductObject C (Ps c d), xx -->[h] dispBinProductObject (Ps c d) (dPs c d cc dd).
  Proof.
    use tpair.
    - apply BinProductArrow; assumption.
    - apply dispBinProductArrow; assumption.
  Defined.

  Local Lemma total_category_Binproducts_mediating_morphism_ok (Ps : BinProducts C) (dPs : dispBinProducts Ps)
    {c d x : C} {cc : D c} {dd: D d} {xx : D x} {f : x --> c} (ff: xx -->[f] cc) {g : x --> d} (gg: xx -->[g] dd) :
    BinProductArrow C (Ps c d) f g · BinProductPr1 C (Ps c d),, dispBinProductArrow (Ps c d) (dPs c d cc dd) ff gg ;; dispBinProductPr1 (Ps c d) (dPs c d cc dd) = f,, ff ×
    BinProductArrow C (Ps c d) f g · BinProductPr2 C (Ps c d),, dispBinProductArrow (Ps c d) (dPs c d cc dd) ff gg ;; dispBinProductPr2 (Ps c d) (dPs c d cc dd) = g,, gg.
  Proof.
    split.
    - use total2_paths_f; cbn.
      + apply BinProductPr1Commutes.
      + apply transportf_pathsinv0.
        apply pathsinv0.
        apply dispBinProductPr1Commutes.
    - use total2_paths_f; cbn.
      + apply BinProductPr2Commutes.
      + apply transportf_pathsinv0.
        apply pathsinv0.
        apply dispBinProductPr2Commutes.
  Qed.

  Local Lemma total_category_Binproducts_mediating_morphism_unique (Ps : BinProducts C) (dPs : dispBinProducts Ps)
    {c d x : C} {cc : D c} {dd: D d} {xx : D x} {f : x --> c} (ff: xx -->[f] cc) {g : x --> d} (gg: xx -->[g] dd)
    {fg : x --> BinProductObject C (Ps c d)} (fgfg : xx -->[fg] dispBinProductObject (Ps c d) (dPs c d cc dd)) :
    fg · BinProductPr1 C (Ps c d),, fgfg ;; dispBinProductPr1 (Ps c d) (dPs c d cc dd) = f,, ff ×
    fg · BinProductPr2 C (Ps c d),, fgfg ;; dispBinProductPr2 (Ps c d) (dPs c d cc dd) = g,, gg →
    fg,, fgfg = total_category_Binproducts_mediating_morphism Ps dPs ff gg.
  Proof.
    intro H.
    induction H as [H1 H2].
    cbn in *.
    induction (total2_paths_equiv _ _ _ H1) as [H1l H1r].
    induction (total2_paths_equiv _ _ _ H2) as [H2l H2r].
    clear H1 H2.
    use total2_paths_f; cbn.
    - use path_to_ctr; split; assumption.
    - cbn in *.
      rewrite <- H1r, <- H2r.
      clear H1r H2r ff gg.
      induction H1l.
      induction H2l.
      (* apply dispBinProductArrowEta. would work with [BinProductArrowEta'] *)
      (* we proceed as follows: *)
      cbn.
      etrans.
      2: { assert (aux := dispBinProductArrowEta (Ps c d) cc dd (dPs _ _ cc dd) xx fgfg).
           apply transportf_transpose_left in aux.
           exact aux. }
      apply (maponpaths (fun z => transportf (mor_disp xx (dispBinProductObject (Ps c d) (dPs c d cc dd))) z fgfg)).
      apply C.
  Qed.

  Definition total_category_Binproducts (Ps : BinProducts C) (dPs : dispBinProducts Ps) : BinProducts (total_category D).
  Proof.
    intros ccc ddd.
    use tpair.
    - apply (total_category_Binproducts_data Ps dPs).
    - induction ccc as [c cc].
      induction ddd as [d dd].
      intros aaa fff ggg.
      destruct aaa as [a aa]; destruct fff as [f ff]; destruct ggg as [g gg].
      cbn.
      use unique_exists.
      + exact (total_category_Binproducts_mediating_morphism Ps dPs ff gg).
      + exact (total_category_Binproducts_mediating_morphism_ok Ps dPs ff gg).
      + intro y.
        apply isapropdirprod.
        * apply (homset_property (total_category D) (a ,, aa) (c ,, cc)).
        * apply (homset_property (total_category D) (a ,, aa) (d ,, dd)).
      + intro fgfgfg.
        induction fgfgfg as [fg fgfg].
        exact (total_category_Binproducts_mediating_morphism_unique Ps dPs ff gg fgfg).
  Defined.

(** ** analogously for terminal objects *)

  Definition is_dispTerminal (P : Terminal C) (pp : D (TerminalObject P)) : UU :=
    ∏ (a : C) (aa : D a), iscontr (aa -->[TerminalArrow P a] pp).

  Definition dispTerminal (P : Terminal C) : UU :=
    ∑ pp :  D (TerminalObject P), is_dispTerminal P pp.

  Definition dispTerminalObject {P : Terminal C} (dP : dispTerminal P) : D (TerminalObject P) := pr1 dP.

  Definition is_dispTerminal_dispTerminal (P : Terminal C) (dP : dispTerminal P) :
    is_dispTerminal P (dispTerminalObject dP) := pr2 dP.

  Definition dispTerminalArrow (P : Terminal C) (dP : dispTerminal P) {a : C} (aa : D a) :
    aa -->[TerminalArrow P a] dispTerminalObject dP := pr1 (is_dispTerminal_dispTerminal P dP a aa).

  Lemma dispTerminalArrowUnique  (P : Terminal C)
    (dP : dispTerminal P) {x : C} (xx : D x)
    (kk : xx -->[TerminalArrow P x] dispTerminalObject dP) :
    kk = dispTerminalArrow P dP xx.
  Proof.
    apply (pr2 (pr2 dP x xx)).
  Qed.

  Lemma dispTerminalArrowUnique'  (P : Terminal C)
    (dP : dispTerminal P) {x : C} (xx : D x) (f: x --> TerminalObject P)
    (kk : xx -->[f] dispTerminalObject dP) :
    kk = transportb _ (TerminalArrowUnique P x f) (dispTerminalArrow P dP xx).
  Proof.
    apply transportf_transpose_right.
    apply dispTerminalArrowUnique.
  Qed.

  Lemma dispTerminalArrowEq {T : Terminal C} {TT: dispTerminal T} {a : C} {aa : D a} {f g : a --> T}
    (ff: aa -->[f] dispTerminalObject TT) (gg: aa -->[g] dispTerminalObject TT) :
    ff = transportb _ (TerminalArrowEq f g) gg.
  Proof.
    induction (TerminalArrowEq f g).
    cbn.
    rewrite (dispTerminalArrowUnique' _ _ _ _ ff).
    rewrite (dispTerminalArrowUnique' _ _ _ _ gg).
    apply idpath.
  Qed.

  Definition total_category_Terminal (P : Terminal C) (dP : dispTerminal P) : Terminal (total_category D).
  Proof.
    use tpair.
    - exists (TerminalObject P).
      exact (dispTerminalObject dP).
    - intros aaa.
      destruct aaa as [a aa].
      cbn.
      use tpair.
      + exact (TerminalArrow P a,, dispTerminalArrow P dP aa).
      + intro fff.
        induction fff as [f ff].
        use total2_paths_f; cbn.
        * apply TerminalArrowUnique.
        * apply dispTerminalArrowUnique.
  Defined.

End FixDispCat.


Require Import Toy.Imp Toy.Language_noderef.
Require Import Toy.UnifySL.implementation.
Import T.

Module Assertion_Shallow.
Import Denote_Aexp.
Import Denote_Bexp.
Import Denote_Com.

Definition exp {A : Type} (P : A -> Assertion) : Assertion := fun st => exists a, P a st.

Definition inj (b : bexp) : Assertion := fun st => true_set (beval b) (fst st).

Definition eqp (a : aexp) (v : Z) : Assertion := fun st => (aeval a) (fst st) = Some v.

Definition safea (a : aexp) : Assertion := fun st => ~ (aeval a) (fst st) = None.

Definition safeb (b : bexp) : Assertion := fun st => ~ error_set (beval b) (fst st).

Definition mapsto_ (p : addr) : Assertion := fun st => (exists v, (snd st) p = Some v) /\ (forall p', p <> p' -> (snd st) p' = None).

Definition mapsto (p : addr) (v : Z) : Assertion := fun st => (snd st) p = Some v /\ (forall p', p <> p' -> (snd st) p' = None).

Definition derives : Assertion -> Assertion -> Prop := fun P Q => forall st, P st -> Q st.

Definition store_update (s : store) (X : var) (v : option Z) : store :=
  match v with
  | Some n => fun Y => if (Nat.eq_dec Y X) then n else s Y
  | None => fun Y => 0
  end.

Definition heap_update (h : heap) (p : addr) (v : option Z) : heap :=
  fun q => if (Z.eq_dec p q) then v else h q.

Definition subst_set (P : Assertion) (X : var) (v : Z) : Assertion :=
  fun st => P (store_update (fst st) X (Some v), snd st).

Definition subst_load (P : Assertion) (X : var) (v : Z) : Assertion :=
  fun st => P (store_update (fst st) X (Some v), snd st).

(* Definition join_heap : heap -> heap -> heap -> Prop :=
  fun h1 h2 h3 =>
    forall p : Z,
      (exists v, h1 p = Some v /\ h2 p = None /\ h3 p = Some v) \/
      (exists v, h1 p = None /\ h2 p = Some v /\ h3 p = Some v) \/
      (h1 p = None /\ h2 p = None /\ h3 p = None).

Definition join : state -> state -> state -> Prop :=
  fun st1 st2 st3 => fst st1 = fst st2 /\ fst st2 = fst st3 /\ join_heap (snd st1) (snd st2) (snd st3).

Definition sepcon (P Q : Assertion) : Assertion :=
  fun st => exists st1 st2, join st1 st2 st /\ P st1 /\ Q st2. *)
End Assertion_Shallow.

Module Validity.
Import Assertion_Shallow.
Import Denote_Com.

Definition valid (P : Assertion) (c : com) (Q Rb Rc : Assertion) : Prop :=
  forall st1 st2, P st1 ->
    (~ com_error (ceval c) st1) /\
    (com_normal (ceval c) st1 st2 -> Q st2) /\
    (com_break (ceval c) st1 st2 -> Rb st2) /\
    (com_cont (ceval c) st1 st2 -> Rc st2).

End Validity.

Module tacticforOSA.

Ltac UFsepcon := unfold sepcon in *;
                 unfold WeakSemantics.WeakSemantics.sepcon in *;
                 unfold SeparationAlgebra.join in *.

Ltac UFjoin := unfold stateJ in *; unfold stateJoin in *;
               unfold OSAGenerators.prod_Join in *;
               unfold SeparationAlgebra.join in *;
               unfold store_join in *;
               unfold OSAGenerators.equiv_Join in *.

Ltac UFheapjoin := unfold heap_join in *;
                   unfold OSAExamples.Heap_Join in *;
                   unfold OSAGenerators.fun_Join in *;
                   unfold SeparationAlgebra.join in *;
                   unfold OSAGenerators.option_Join in *.

Lemma osajoin : forall (st1 st2 st : state),
  (forall x, @OSAGenerators.option_join Z (@OSAGenerators.trivial_Join Z)
          (snd st1 x) (snd st2 x) (snd st x)) <->
  (forall p, (exists v, snd st1 p = Some v /\ snd st2 p = None /\ snd st p = Some v) \/
             (exists v, snd st1 p = None /\ snd st2 p = Some v /\ snd st p = Some v) \/
             (snd st1 p = None ) /\ (snd st2 p = None) /\ (snd st p = None)).
Proof.
  intros.
  unfold iff; split.
  + intros.
    specialize (H p).
    destruct (snd st1 p), (snd st2 p), (snd st p).
    - inversion H. tauto.
    - inversion H.
    - inversion H. rewrite <- H0.
      left. exists z. tauto.
    - inversion H.
    - inversion H.
      right. left. exists z0. tauto.
    - inversion H.
    - inversion H.
    - right. right. tauto.
  + intros.
    specialize (H x).
    destruct (snd st1 x), (snd st2 x), (snd st x).
    - destruct H as [? | [? | ?]].
      * destruct H as [v [? [? ?]]]. inversion H0.
      * destruct H as [v [? [? ?]]]. inversion H.
      * destruct H as [? [? ?]]. inversion H.
    - destruct H as [? | [? | ?]].
      * destruct H as [v [? [? ?]]]. inversion H0.
      * destruct H as [v [? [? ?]]]. inversion H.
      * destruct H as [? [? ?]]. inversion H.
    - destruct H as [? | [? | ?]].
      * destruct H as [v [? [? ?]]].
        inversion H. inversion H1. subst. constructor.
      * destruct H as [v [? [? ?]]]. inversion H0.
      * destruct H as [? [? ?]]. inversion H.
    - destruct H as [? | [? | ?]].
      * destruct H as [v [? [? ?]]]. inversion H1.
      * destruct H as [v [? [? ?]]]. inversion H.
      * destruct H as [? [? ?]]. inversion H.
    - destruct H as [? | [? | ?]].
      * destruct H as [v [? [? ?]]]. inversion H.
      * destruct H as [v [? [? ?]]].
        inversion H0. inversion H1. subst. constructor.
      * destruct H as [? [? ?]]. inversion H0.
    - destruct H as [? | [? | ?]].
      * destruct H as [v [? [? ?]]]. inversion H.
      * destruct H as [v [? [? ?]]]. inversion H1.
      * destruct H as [? [? ?]]. inversion H0.
    - destruct H as [? | [? | ?]].
      * destruct H as [v [? [? ?]]]. inversion H.
      * destruct H as [v [? [? ?]]]. inversion H0.
      * destruct H as [? [? ?]]. inversion H1.
    - destruct H as [? | [? | ?]].
      * destruct H as [v [? [? ?]]]. inversion H.
      * destruct H as [v [? [? ?]]]. inversion H0.
      * constructor.
Qed.

End tacticforOSA.


Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Local Open Scope logic.

Lemma wand_frame_intro {A} {ND: NatDed A} {SL: SepLog A}: forall (P Q: A),
  Q |-- P -* P * Q.
Proof.
  intros.
  apply wand_sepcon_adjoint.
  rewrite sepcon_comm; auto.
Qed.

Lemma wand_frame_intro' {A} {ND: NatDed A} {SL: SepLog A}: forall (P Q R: A),
  P * Q |-- R ->
  Q |-- P -* R.
Proof.
  intros.
  apply wand_sepcon_adjoint.
  rewrite sepcon_comm; auto.
Qed.

Lemma wand_frame_elim {A} {ND: NatDed A} {SL: SepLog A}: forall (P Q: A),
  P * (P -* Q) |-- Q.
Proof.
  intros.
  rewrite sepcon_comm.
  apply wand_sepcon_adjoint; auto.
Qed.

Lemma wand_frame_elim' {A} {ND: NatDed A} {SL: SepLog A}: forall (P P' Q: A),
  P |-- P' -> P * (P' -* Q) |-- Q.
Proof.
  intros.
  rewrite sepcon_comm.
  apply wand_sepcon_adjoint; auto.
  apply wand_derives; auto.
Qed.

Lemma wand_frame_ver {A} {ND: NatDed A} {SL: SepLog A}: forall (P Q R: A),
  (P -* Q) * (Q -* R) |-- P -* R.
Proof.
  intros.
  apply -> wand_sepcon_adjoint.
  rewrite (sepcon_comm _ P), <- sepcon_assoc.
  eapply derives_trans.
  + eapply sepcon_derives; [apply wand_frame_elim | apply derives_refl].
  + apply wand_frame_elim.
Qed.

Lemma wand_frame_hor {A} {ND: NatDed A} {SL: SepLog A}: forall (P1 P2 Q1 Q2: A),
  (P1 -* Q1) * (P2 -* Q2) |-- P1 * P2 -* Q1 * Q2.
Proof.
  intros.
  apply -> wand_sepcon_adjoint.
  rewrite <- (sepcon_assoc _ P1), (sepcon_comm _ P1), <- (sepcon_assoc P1), (sepcon_assoc _ _ P2), (sepcon_comm _ P2).
  apply sepcon_derives; apply wand_frame_elim.
Qed.

Lemma wand_frame_frame {A} {ND: NatDed A} {SL: SepLog A}: forall (P Q F: A),
  P -* Q |-- P * F -* Q * F.
Proof.
  intros.
  apply -> wand_sepcon_adjoint.
  rewrite <- sepcon_assoc, (sepcon_comm _ P).
  apply sepcon_derives; [apply wand_frame_elim | auto].
Qed.


Require Import Coq.Strings.String Coq.Classes.RelationClasses.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Wf.
Require Import Crypto.Compilers.Relations.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.Sigma.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.RewriteHyp.
Require Import Crypto.Util.Notations.
Local Open Scope ctype_scope.
Local Open Scope expr_scope.

Section language.
  Context {base_type_code : Type}
          {interp_base_type : base_type_code -> Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          (interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst).

  Local Notation exprf := (@exprf base_type_code op interp_base_type).
  Local Notation expr := (@expr base_type_code op interp_base_type).
  Local Notation Expr := (@Expr base_type_code op).
  Local Notation interpf := (@interpf base_type_code interp_base_type op interp_op).
  Local Notation interp := (@interp base_type_code interp_base_type op interp_op).
  Local Notation Interp := (@Interp base_type_code interp_base_type op interp_op).

  Lemma eq_in_flatten_binding_list
        {t x x' T e}
        (HIn : List.In (existT (fun t : base_type_code => (interp_base_type t * interp_base_type t)%type) t (x, x')%core)
                       (flatten_binding_list (t:=T) e e))
    : x = x'.
  Proof using Type.
    induction T; simpl in *; [ | | rewrite List.in_app_iff in HIn ];
      repeat first [ progress destruct_head or
                   | progress destruct_head False
                   | progress destruct_head and
                   | progress inversion_sigma
                   | progress inversion_prod
                   | progress subst
                   | solve [ eauto ] ].
  Qed.

  Local Hint Resolve List.in_app_or List.in_or_app eq_in_flatten_binding_list.

  Section wf.
    Lemma interpf_wff
             {t} {e1 e2 : exprf t}
             {G}
             (HG : forall t x x',
                 List.In (existT (fun t : base_type_code => (interp_base_type t * interp_base_type t)%type) t (x, x')%core) G
                 -> x = x')
             (Rwf : wff G e1 e2)
    : interpf e1 = interpf e2.
    Proof using Type.
      induction Rwf; simpl; auto;
        specialize_by auto; try congruence.
      rewrite_hyp !*; auto.
      repeat match goal with
             | [ H : context[List.In _ (_ ++ _)] |- _ ]
               => setoid_rewrite List.in_app_iff in H
             end.
      match goal with
      | [ H : _ |- _ ]
        => apply H; intros; destruct_head' or; solve [ eauto ]
      end.
    Qed.

    Local Hint Resolve interpf_wff.

    Lemma interp_wf
             {t} {e1 e2 : expr t}
             (Rwf : wf e1 e2)
    : forall x, interp e1 x = interp e2 x.
    Proof using Type.
      destruct Rwf; simpl; eauto.
    Qed.
  End wf.
End language.


(** We test memory usage of typeclass resification of let-binders to HOAS *)
Require Import PerformanceExperiments.Harness.
Generalizable All Variables.
Axiom Let_In : forall {A P} (v : A) (f : forall x : A, P x), P v.
Fixpoint nested_lets (n : nat) (init : nat) : nat
  := match n with
     | O => init + init
     | S n => Let_In (init + init) (fun x => nested_lets n x)
     end.

Inductive expr :=
| Zero
| Succ (n : expr)
| Plus (x y : expr)
| LetIn (x : expr) (f : nat -> expr)
| Var (v : nat)
.

Axiom P : expr -> Prop.
Axiom p : forall e, P e.

Class reified_of (v : nat) (e : expr) := dummy : True.
Global Hint Mode reified_of ! - : typeclass_instances.
Global Instance reify_plus {x ex y ey} {_:reified_of x ex} {_:reified_of y ey}
  : reified_of (x + y) (Plus ex ey) := I.
Global Instance reify_LetIn {x ex f ef} {_:reified_of x ex} {_:forall v ev, reified_of v (Var ev) -> reified_of (f v) (ef ev)}
  : reified_of (Let_In x f) (LetIn ex ef) := I.
Global Instance reify_0 : reified_of 0 Zero := I.
Global Instance reify_S {n en} {_:reified_of n en} : reified_of (S n) (Succ en) := I.
Definition reify (v : nat) {ev : expr} {_ : reified_of v ev} := ev.
Global Hint Extern 1 (reified_of _ ?ev) => progress cbv [ev] : typeclass_instances.
Global Hint Extern 0 (reified_of _ _) => progress cbv [nested_lets] : typeclass_instances.
Notation reified v := (match _ with e => match _ : reified_of v e with _ => e end end) (only parsing).

Ltac mkgoal n := constr:(True).
Ltac redgoal _ := idtac.
Ltac time_solve_goal0 n :=
  restart_timer;
  assert (P (reified (nested_lets n 0)));
  [ finish_timing ("Tactic call reify-regression-cubic");
    time "abstract-regression-linear" abstract apply p
  | ].

Definition args_of_size (s : size) : list nat
  := match s with
     | Sanity => seq 1 3
     | SuperFast => seq 1 100
     | Fast => List.map (fun x => x * 10) (seq 1 20)
     | Medium => []
     | Slow => []
     | VerySlow => []
     end.

Ltac run0 sz := Harness.runtests args_of_size default_describe_goal mkgoal redgoal time_solve_goal0 sz.

(*
Goal True. run0 Fast.
*)


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

(** %\subsection*{ extras :  before\_after.v }%*)
Set Implicit Arguments.
Unset Strict Implicit.
Require Export omit_facts.

(** - Some stuff I thought would be useful some day but wasn't *)

Definition before (N N' : nat) (i : fin N) (j : fin N') := index i < index j.
Definition after (N N' : nat) (i : fin N) (j : fin N') := index i > index j.

Definition notbefore (N N' : nat) (i : fin N) (j : fin N') :=
  index i = index j \/ after i j.
Definition notafter (N N' : nat) (i : fin N) (j : fin N') :=
  before i j \/ index i = index j.

Lemma decide_fin :
 forall (N N' : nat) (i : fin N) (i' : fin N'),
 before i i' \/ index i = index i' \/ after i i'.
simpl in |- *.
unfold before, after in |- *.
intros.
case i; case i'.
simpl in |- *.
intros x l x0 l0.
clear l0 l i' i N N'.
induction  x as [| x Hrecx]; induction  x0 as [| x0 Hrecx0];
 unfold gt in |- *; auto with arith.
case Hrecx.
auto with arith.
intro.
unfold gt in |- *; case H.
intro; left.
rewrite H0.
auto.
unfold gt in |- *.
intro.
right.
case H0.
auto.
intros.
cut (S x < S m \/ S x = S m).
intro.
case H2.
auto.
auto.
left.
auto with arith.
Qed.

Lemma decide_before :
 forall (N N' : nat) (i : fin N) (j : fin N'), before i j \/ notbefore i j.
unfold notbefore in |- *.
apply decide_fin.
Qed.

Lemma decide_after :
 forall (N N' : nat) (i : fin N) (j : fin N'), after i j \/ notafter i j.
unfold notafter in |- *.
intros.
case (decide_before i j).
auto.
unfold notbefore in |- *.
tauto.
Qed.

Lemma seq_properties_split_before_eq_after :
 forall (A : Setoid) (n : nat) (v : seq n A) (i : fin n) (P : Predicate A),
 (forall j : fin n, before j i -> Pred_fun P (v j)) ->
 Pred_fun P (v i) ->
 (forall j : fin n, after j i -> Pred_fun P (v j)) ->
 forall j : fin n, Pred_fun P (v j).
intros.
case (decide_fin j i); auto.
intro.
case H2; auto.
generalize H0.
elim P.
simpl in |- *.
unfold pred_compatible in |- *.
intros.
apply Pred_compatible_prf with (v i); auto with algebra.
Qed.

Lemma predicate_split_seq_before_notbefore :
 forall (A : Setoid) (n : nat) (v : seq n A) (i : fin n) (P : Predicate A),
 (forall j : fin n, before j i -> Pred_fun P (v j)) ->
 (forall j : fin n, notbefore j i -> Pred_fun P (v j)) ->
 forall j : fin n, Pred_fun P (v j).
intros.
case (decide_before j i); auto.
Qed.

Lemma predicate_split_seq_after_notafter :
 forall (A : Setoid) (n : nat) (v : seq n A) (i : fin n) (P : Predicate A),
 (forall j : fin n, after j i -> Pred_fun P (v j)) ->
 (forall j : fin n, notafter j i -> Pred_fun P (v j)) ->
 forall j : fin n, Pred_fun P (v j).
intros.
case (decide_after j i); auto.
Qed.

Lemma seq_properties_split_before_notbefore :
 forall (A : Setoid) (n : nat) (v : seq n A) (i : fin n) (P : A -> Prop),
 (forall j : fin n, before j i -> P (v j)) ->
 (forall j : fin n, notbefore j i -> P (v j)) -> forall j : fin n, P (v j).
intros.
case (decide_before j i); auto.
Qed.

Lemma seq_properties_split_after_notafter :
 forall (A : Setoid) (n : nat) (v : seq n A) (i : fin n) (P : A -> Prop),
 (forall j : fin n, after j i -> P (v j)) ->
 (forall j : fin n, notafter j i -> P (v j)) -> forall j : fin n, P (v j).
intros.
case (decide_after j i); auto.
Qed.

Definition next (n : nat) (i : fin n) : fin (S n) :=
  match i with
  | Build_finiteT ni Hi => Build_finiteT (lt_n_S _ _ Hi)
  end.
Definition prev :
  forall (n : nat) (i : fin (S n)),
  ~ i =' Build_finiteT (lt_O_Sn n) in _ -> fin n.
intros n i; case i.
intro x; case x.
simpl in |- *.
intros.
absurd (0 = 0); auto.
intros.
exact (Build_finiteT (lt_S_n _ _ in_range_prf)).
Defined.


From Hammer Require Import Hammer.

From Coq Require Import Arith.Arith.

From PLF Require Import Maps.
From PLF Require Import Smallstep.
From PLF Require Import Stlc.
From PLF Require Import LibTactics.

From PLF Require Imp.

From Coq Require Import Lists.List.
Import ListNotations.

Lemma solving_by_reflexivity :
2 + 3 = 5.
Proof. hammer_hook "UseAuto" "UseAuto.solving_by_reflexivity". auto. Qed.

Lemma solving_by_apply : forall (P Q : nat->Prop),
(forall n, Q n -> P n) ->
(forall n, Q n) ->
P 2.
Proof. hammer_hook "UseAuto" "UseAuto.solving_by_apply". auto. Qed.

Lemma solving_by_eapply : forall (P Q : nat->Prop),
(forall n m, Q m -> P n) ->
Q 1 ->
P 2.
Proof. hammer_hook "UseAuto" "UseAuto.solving_by_eapply". auto. eauto. Qed.

Lemma solving_conj_goal : forall (P : nat->Prop) (F : Prop),
(forall n, P n) ->
F ->
F /\ P 2.
Proof. hammer_hook "UseAuto" "UseAuto.solving_conj_goal". auto. Qed.

Lemma solving_conj_hyp : forall (F F' : Prop),
F /\ F' ->
F.
Proof. hammer_hook "UseAuto" "UseAuto.solving_conj_hyp". auto. eauto. jauto.  Qed.

Lemma solving_conj_hyp' : forall (F F' : Prop),
F /\ F' ->
F.
Proof. hammer_hook "UseAuto" "UseAuto.solving_conj_hyp'". intros. jauto_set. eauto. Qed.

Lemma solving_conj_more : forall (P Q R : nat->Prop) (F : Prop),
(F /\ (forall n m, (Q m /\ R n) -> P n)) ->
(F -> R 2) ->
Q 1 ->
P 2 /\ F.
Proof. hammer_hook "UseAuto" "UseAuto.solving_conj_more". jauto.  Qed.

Lemma solving_conj_hyp_forall : forall (P Q : nat->Prop),
(forall n, P n /\ Q n) ->
P 2.
Proof. hammer_hook "UseAuto" "UseAuto.solving_conj_hyp_forall".
auto. eauto. iauto. jauto.

intros. destruct (H 2). auto.
Qed.

Lemma solved_by_jauto : forall (P Q : nat->Prop) (F : Prop),
(forall n, P n) /\ (forall n, Q n) ->
P 2.
Proof. hammer_hook "UseAuto" "UseAuto.solved_by_jauto". jauto.  Qed.

Lemma solving_disj_goal : forall (F F' : Prop),
F ->
F \/ F'.
Proof. hammer_hook "UseAuto" "UseAuto.solving_disj_goal". auto. Qed.

Lemma solving_disj_hyp : forall (F F' : Prop),
F \/ F' ->
F' \/ F.
Proof. hammer_hook "UseAuto" "UseAuto.solving_disj_hyp". auto. eauto. jauto. iauto. Qed.

Lemma solving_tauto : forall (F1 F2 F3 : Prop),
((~F1 /\ F3) \/ (F2 /\ ~F3)) ->
(F2 -> F1) ->
(F2 -> F3) ->
~F2.
Proof. hammer_hook "UseAuto" "UseAuto.solving_tauto". iauto. Qed.

Lemma solving_exists_goal : forall (f : nat->Prop),
f 2 ->
exists x, f x.
Proof. hammer_hook "UseAuto" "UseAuto.solving_exists_goal".
auto.
eauto.
Qed.

Lemma solving_exists_hyp : forall (f g : nat->Prop),
(forall x, f x -> g x) ->
(exists a, f a) ->
(exists a, g a).
Proof. hammer_hook "UseAuto" "UseAuto.solving_exists_hyp".
auto. eauto. iauto.
jauto.

Qed.

Lemma negation_study_1 : forall (P : nat->Prop),
P 0 ->
(forall x, ~ P x) ->
False.
Proof. hammer_hook "UseAuto" "UseAuto.negation_study_1".
intros P H0 HX.
eauto.
unfold not in *. eauto.
Qed.

Lemma negation_study_2 : forall (P : nat->Prop),
P 0 ->
(forall x, ~ P x) ->
False.
Proof. hammer_hook "UseAuto" "UseAuto.negation_study_2". jauto.  Qed.

Lemma equality_by_auto : forall (f g : nat->Prop),
(forall x, f x = g x) ->
g 2 = f 2.
Proof. hammer_hook "UseAuto" "UseAuto.equality_by_auto". auto. Qed.

Lemma search_depth_0 :
True /\ True /\ True /\ True /\ True /\ True.
Proof. hammer_hook "UseAuto" "UseAuto.search_depth_0".
auto.
Abort.

Lemma search_depth_1 : forall (P : nat->Prop),
P 0 ->
(P 0 -> P 1) ->
(P 1 -> P 2) ->
(P 2).
Proof. hammer_hook "UseAuto" "UseAuto.search_depth_1".
auto 0.
auto 1.
auto 2.
auto 3.

Qed.

Lemma search_depth_3 : forall (P : nat->Prop),
(P 0) ->
(forall k, P (k-1) -> P k) ->
(P 4).
Proof. hammer_hook "UseAuto" "UseAuto.search_depth_3". auto. Qed.

Lemma search_depth_4 : forall (P : nat->Prop),
(P 0) ->
(forall k, P (k-1) -> P k) ->
(P 5).
Proof. hammer_hook "UseAuto" "UseAuto.search_depth_4". auto. auto 6. Qed.

Lemma search_depth_5 : forall (P : nat->Prop),
(P 0) ->
(forall k, P (k-1) -> P k) ->
(P 4 /\ P 4).
Proof. hammer_hook "UseAuto" "UseAuto.search_depth_5". auto. auto 6. Qed.

Lemma working_of_auto_1 : forall (P : nat->Prop),
(P 0) ->
(forall k, P (k-1) -> P k) ->
(forall k, P (k+1) -> P k) ->
(P 2).

Proof. hammer_hook "UseAuto" "UseAuto.working_of_auto_1". intros P H1 H2 H3.  eauto. Qed.

Lemma working_of_auto_2 : forall (P : nat->Prop),
(P 0) ->
(forall k, P (k+1) -> P k) ->
(forall k, P (k-1) -> P k) ->
(P 2).
Proof. hammer_hook "UseAuto" "UseAuto.working_of_auto_2". intros P H1 H3 H2.  eauto. Qed.

Lemma nat_le_refl : forall (x:nat), x <= x.
Proof. hammer_hook "UseAuto" "UseAuto.nat_le_refl". apply le_n. Qed.

Hint Resolve nat_le_refl.

Ltac auto_star ::= try solve [ jauto ].

Ltac auto_tilde ::= auto.

Module DeterministicImp.
Import Imp.

Theorem ceval_deterministic: forall c st st1 st2,
st =[ c ]=> st1 ->
st =[ c ]=> st2 ->
st1 = st2.
Proof. hammer_hook "UseAuto" "UseAuto.DeterministicImp.ceval_deterministic".
intros c st st1 st2 E1 E2.
generalize dependent st2.
(induction E1); intros st2 E2; inversion E2; subst.
-  reflexivity.
-  reflexivity.
-
assert (st' = st'0) as EQ1.
{  apply IHE1_1; assumption. }
subst st'0.
apply IHE1_2. assumption.

-
apply IHE1. assumption.
-
rewrite H in H5. inversion H5.

-
rewrite H in H5. inversion H5.
-
apply IHE1. assumption.

-
reflexivity.
-
rewrite H in H2. inversion H2.

-
rewrite H in H4. inversion H4.
-
assert (st' = st'0) as EQ1.
{  apply IHE1_1; assumption. }
subst st'0.
apply IHE1_2. assumption.
Qed.

Theorem ceval_deterministic': forall c st st1 st2,
st =[ c ]=> st1 ->
st =[ c ]=> st2 ->
st1 = st2.
Proof. hammer_hook "UseAuto" "UseAuto.DeterministicImp.ceval_deterministic'".
admit.
Admitted.

Theorem ceval_deterministic'': forall c st st1 st2,
st =[ c ]=> st1 ->
st =[ c ]=> st2 ->
st1 = st2.
Proof. hammer_hook "UseAuto" "UseAuto.DeterministicImp.ceval_deterministic''".
introv E1 E2. gen st2.
induction E1; intros; inverts E2; tryfalse.
- auto.
- auto.
- assert (st' = st'0). auto. subst. auto.
- auto.
- auto.
- auto.
- assert (st' = st'0). auto. subst. auto.
Qed.

Theorem ceval_deterministic''': forall c st st1 st2,
st =[ c ]=> st1 ->
st =[ c ]=> st2 ->
st1 = st2.
Proof. hammer_hook "UseAuto" "UseAuto.DeterministicImp.ceval_deterministic'''".

introv E1 E2. gen st2.
induction E1; intros; inverts E2; tryfalse.
- auto.
- auto.

- dup 4.

+ assert (st' = st'0). apply IHE1_1. apply H1.
skip.

+ forwards: IHE1_1. apply H1.
skip.

+ forwards: IHE1_1. eauto.
skip.

+ forwards*: IHE1_1.
skip.

Abort.

Theorem ceval_deterministic'''': forall c st st1 st2,
st =[ c ]=> st1  ->
st =[ c ]=> st2 ->
st1 = st2.
Proof. hammer_hook "UseAuto" "UseAuto.DeterministicImp.ceval_deterministic''''".
introv E1 E2. gen st2.
induction E1; intros; inverts* E2; tryfalse.
- forwards*: IHE1_1. subst*.
- forwards*: IHE1_1. subst*.
Qed.

End DeterministicImp.

Set Warnings "-notation-overridden,-parsing".
From PLF Require Import StlcProp.
Module PreservationProgressStlc.
Import STLC.
Import STLCProp.

Theorem preservation : forall t t' T,
has_type empty t T  ->
t --> t'  ->
has_type empty t' T.
Proof with eauto. hammer_hook "UseAuto" "UseAuto.PreservationProgressStlc.preservation".
remember (@empty ty) as Gamma.
intros t t' T HT. generalize dependent t'.
(induction HT); intros t' HE; subst Gamma.
-
inversion HE.
-
inversion HE.
-
inversion HE; subst...

+
apply substitution_preserves_typing with T11...
inversion HT1...
-
inversion HE.
-
inversion HE.
-
inversion HE; subst...
Qed.

Theorem preservation' : forall t t' T,
has_type empty t T  ->
t --> t'  ->
has_type empty t' T.
Proof. hammer_hook "UseAuto" "UseAuto.PreservationProgressStlc.preservation'".
admit.
Admitted.

Theorem progress : forall t T,
has_type empty t T ->
value t \/ exists t', t --> t'.
Proof with eauto. hammer_hook "UseAuto" "UseAuto.PreservationProgressStlc.progress".
intros t T Ht.
remember (@empty ty) as Gamma.
(induction Ht); subst Gamma...
-
inversion H.
-
right. destruct IHHt1...
+
destruct IHHt2...
*
inversion H; subst; try solve_by_invert.
exists ([x0:=t2]t)...
*
destruct H0 as [t2' Hstp]. exists (app t1 t2')...
+
destruct H as [t1' Hstp]. exists (app t1' t2)...
-
right. destruct IHHt1...
destruct t1; try solve_by_invert...
inversion H. exists (test x0 t2 t3)...
Qed.

Theorem progress' : forall t T,
has_type empty t T ->
value t \/ exists t', t --> t'.
Proof. hammer_hook "UseAuto" "UseAuto.PreservationProgressStlc.progress'".
admit.
Admitted.

End PreservationProgressStlc.

From PLF Require Import Smallstep.
Require Import Program.
Module Semantics.

Theorem multistep__eval : forall t v,
normal_form_of t v -> exists n, v = C n /\ t ==> n.
Proof. hammer_hook "UseAuto" "UseAuto.Semantics.multistep__eval".
intros t v Hnorm.
unfold normal_form_of in Hnorm.
inversion Hnorm as [Hs Hnf]; clear Hnorm.
rewrite nf_same_as_value in Hnf. inversion Hnf. clear Hnf.
exists n. split. reflexivity.
induction Hs; subst.
-
apply E_Const.
-
eapply step__eval. eassumption. apply IHHs. reflexivity.
Qed.

Theorem multistep_eval_ind : forall t v,
t -->* v -> forall n, C n = v -> t ==> n.
Proof. hammer_hook "UseAuto" "UseAuto.Semantics.multistep_eval_ind".
admit.
Admitted.

Theorem multistep__eval' : forall t v,
normal_form_of t v -> exists n, v = C n /\ t ==> n.
Proof. hammer_hook "UseAuto" "UseAuto.Semantics.multistep__eval'".
admit.
Admitted.

Theorem multistep__eval'' : forall t v,
normal_form_of t v -> exists n, v = C n /\ t ==> n.
Proof. hammer_hook "UseAuto" "UseAuto.Semantics.multistep__eval''".
admit.
Admitted.

End Semantics.

From Coq Require Import omega.Omega.
From PLF Require Import References.
Import STLCRef.
Require Import Program.
Module PreservationProgressReferences.
Hint Resolve store_weakening extends_refl.

Theorem preservation : forall ST t t' T st st',
has_type empty ST t T ->
store_well_typed ST st ->
t / st --> t' / st' ->
exists ST',
(extends ST' ST /\
has_type empty ST' t' T /\
store_well_typed ST' st').
Proof. hammer_hook "UseAuto" "UseAuto.PreservationProgressReferences.preservation".

remember (@empty ty) as Gamma. introv Ht. gen t'.
(induction Ht); introv HST Hstep;

subst Gamma; inverts Hstep; eauto.

-

exists ST. inverts Ht1. splits*. applys* substitution_preserves_typing.

-

forwards: IHHt1. eauto. eauto. eauto.

jauto_set_hyps; intros.

jauto_set_goal; intros.

eauto. eauto. eauto.

-

forwards*: IHHt2.

- forwards*: IHHt.
- forwards*: IHHt.
- forwards*: IHHt1.
- forwards*: IHHt2.
- forwards*: IHHt1.

-
+

exists (ST ++ T1::nil). inverts keep HST. splits.

apply extends_app.

applys_eq T_Loc 1.

rewrite app_length. simpl. omega.

unfold store_Tlookup. rewrite <- H. rewrite* app_nth2.

rewrite minus_diag. simpl. reflexivity.
apply* store_well_typed_app.

- forwards*: IHHt.

-
+

exists ST. splits*.

lets [_ Hsty]: HST.

applys_eq* Hsty 1.

inverts* Ht.

- forwards*: IHHt.

-
+

exists ST. splits*. applys* assign_pres_store_typing. inverts* Ht1.

- forwards*: IHHt1.
- forwards*: IHHt2.
Qed.

Lemma nth_eq_last' : forall (A : Type) (l : list A) (x d : A) (n : nat),
n = length l -> nth n (l ++ x::nil) d = x.
Proof. hammer_hook "UseAuto" "UseAuto.PreservationProgressReferences.nth_eq_last'". intros. subst. apply nth_eq_last. Qed.

Lemma preservation_ref : forall (st:store) (ST : store_ty) T1,
length ST = length st ->
Ref T1 = Ref (store_Tlookup (length st) (ST ++ T1::nil)).
Proof. hammer_hook "UseAuto" "UseAuto.PreservationProgressReferences.preservation_ref".
intros. dup.

unfold store_Tlookup. rewrite* nth_eq_last'.

fequal. symmetry. apply* nth_eq_last'.
Qed.

Theorem preservation' : forall ST t t' T st st',
has_type empty ST t T ->
store_well_typed ST st ->
t / st --> t' / st' ->
exists ST',
(extends ST' ST /\
has_type empty ST' t' T /\
store_well_typed ST' st').
Proof. hammer_hook "UseAuto" "UseAuto.PreservationProgressReferences.preservation'".
remember (@empty ty) as Gamma. introv Ht. gen t'.
induction Ht; introv HST Hstep; subst Gamma; inverts Hstep; eauto.
- exists ST. inverts Ht1. splits*. applys* substitution_preserves_typing.
- forwards*: IHHt1.
- forwards*: IHHt2.
- forwards*: IHHt.
- forwards*: IHHt.
- forwards*: IHHt1.
- forwards*: IHHt2.
- forwards*: IHHt1.
- exists (ST ++ T1::nil). inverts keep HST. splits.
apply extends_app.
applys_eq T_Loc 1.
rewrite app_length. simpl. omega.
unfold store_Tlookup. rewrite* nth_eq_last'.
apply* store_well_typed_app.
- forwards*: IHHt.
- exists ST. splits*. lets [_ Hsty]: HST.
applys_eq* Hsty 1. inverts* Ht.
- forwards*: IHHt.
- exists ST. splits*. applys* assign_pres_store_typing. inverts* Ht1.
- forwards*: IHHt1.
- forwards*: IHHt2.
Qed.

Theorem progress : forall ST t T st,
has_type empty ST t T ->
store_well_typed ST st ->
(value t \/ exists t' st', t / st --> t' / st').
Proof. hammer_hook "UseAuto" "UseAuto.PreservationProgressReferences.progress".
introv Ht HST. remember (@empty ty) as Gamma.
induction Ht; subst Gamma; tryfalse; try solve [left*].
- right. destruct* IHHt1 as [K|].
inverts K; inverts Ht1.
destruct* IHHt2.
- right. destruct* IHHt as [K|].
inverts K; try solve [inverts Ht]. eauto.
- right. destruct* IHHt as [K|].
inverts K; try solve [inverts Ht]. eauto.
- right. destruct* IHHt1 as [K|].
inverts K; try solve [inverts Ht1].
destruct* IHHt2 as [M|].
inverts M; try solve [inverts Ht2]. eauto.
- right. destruct* IHHt1 as [K|].
inverts K; try solve [inverts Ht1]. destruct* n.
- right. destruct* IHHt.
- right. destruct* IHHt as [K|].
inverts K; inverts Ht as M.
inverts HST as N. rewrite* N in M.
- right. destruct* IHHt1 as [K|].
destruct* IHHt2.
inverts K; inverts Ht1 as M.
inverts HST as N. rewrite* N in M.
Qed.

End PreservationProgressReferences.

From PLF Require Sub.
Module SubtypingInversion.
Import Sub.

Lemma abs_arrow : forall x S1 s2 T1 T2,
has_type empty (abs x S1 s2) (Arrow T1 T2) ->
subtype T1 S1
/\ has_type (update empty x S1) s2 T2.
Proof with eauto. hammer_hook "UseAuto" "UseAuto.SubtypingInversion.abs_arrow".
intros x S1 s2 T1 T2 Hty.
apply typing_inversion_abs in Hty.
destruct Hty as [S2 [Hsub Hty]].
apply sub_inversion_arrow in Hsub.
destruct Hsub as [U1 [U2 [Heq [Hsub1 Hsub2]]]].
inversion Heq; subst...
Qed.

Lemma abs_arrow' : forall x S1 s2 T1 T2,
has_type empty (abs x S1 s2) (Arrow T1 T2) ->
subtype T1 S1
/\ has_type (update empty x S1) s2 T2.
Proof. hammer_hook "UseAuto" "UseAuto.SubtypingInversion.abs_arrow'".
admit.
Admitted.

End SubtypingInversion.

Lemma order_matters_1 : forall (P : nat->Prop),
(forall n m, P m -> m <> 0 -> P n) ->
P 2 ->
P 1.
Proof. hammer_hook "UseAuto" "UseAuto.order_matters_1".
eauto.

Qed.

Lemma order_matters_2 : forall (P : nat->Prop),
(forall n m, m <> 0 -> P m -> P n) ->
P 5 ->
P 1.
Proof. hammer_hook "UseAuto" "UseAuto.order_matters_2".
eauto.

intros P H K.
eapply H.

eauto.

Abort.

Axiom P : nat -> Prop.

Definition myFact := forall x, x <= 3 -> P x.

Lemma demo_hint_unfold_goal_1 :
(forall x, P x) ->
myFact.
Proof. hammer_hook "UseAuto" "UseAuto.demo_hint_unfold_goal_1".
auto.
unfold myFact. auto.
Qed.

Hint Unfold myFact.

Lemma demo_hint_unfold_goal_2 :
(forall x, P x) ->
myFact.
Proof. hammer_hook "UseAuto" "UseAuto.demo_hint_unfold_goal_2". auto. Qed.

Lemma demo_hint_unfold_context_1 :
(True -> myFact) ->
P 3.
Proof. hammer_hook "UseAuto" "UseAuto.demo_hint_unfold_context_1".
intros.
auto.
unfold myFact in *. auto.
Qed.

Lemma demo_hint_unfold_context_2 :
myFact ->
P 3.
Proof. hammer_hook "UseAuto" "UseAuto.demo_hint_unfold_context_2". auto. Qed.

Parameter le_not_gt : forall x,
(x <= 3) ->
~ (x > 3).

Parameter gt_not_le : forall x,
(x > 3) ->
~ (x <= 3).

Parameter le_gt_false : forall x,
(x <= 3) ->
(x > 3) ->
False.

Section DemoAbsurd1.

Hint Resolve le_not_gt.

Lemma demo_auto_absurd_1 :
(exists x, x <= 3 /\ x > 3) ->
False.
Proof. hammer_hook "UseAuto" "UseAuto.demo_auto_absurd_1".
intros. jauto_set.
eauto.
eapply le_not_gt. eauto. eauto.
Qed.

Hint Resolve le_gt_false.

Lemma demo_auto_absurd_2 :
(exists x, x <= 3 /\ x > 3) ->
False.
Proof. hammer_hook "UseAuto" "UseAuto.demo_auto_absurd_2".
dup.

intros. jauto_set.  eauto.

jauto.
Qed.

End DemoAbsurd1.

Lemma demo_false : forall x,
(x <= 3) ->
(x > 3) ->
4 = 5.
Proof. hammer_hook "UseAuto" "UseAuto.demo_false".
intros. dup 4.

- false. eapply le_gt_false.
+ auto.

+ skip.

- false. eapply le_gt_false.
+ eauto.
+ eauto.

- false le_gt_false. eauto. eauto.

- false le_not_gt. eauto. eauto.

Abort.

Parameter typ : Type.

Parameter subtype : typ -> typ -> Prop.

Parameter subtype_refl : forall T,
subtype T T.

Parameter subtype_trans : forall S T U,
subtype S T -> subtype T U -> subtype S U.

Hint Resolve subtype_refl.

Section HintsTransitivity.

Hint Resolve subtype_trans.

Lemma transitivity_bad_hint_1 : forall S T,
subtype S T.
Proof. hammer_hook "UseAuto" "UseAuto.transitivity_bad_hint_1".
intros.  eauto.
Abort.

End HintsTransitivity.

Hint Extern 1 (subtype ?S ?U) =>
match goal with
| H: subtype S ?T |- _ => apply (@subtype_trans S T U)
| H: subtype ?T U |- _ => apply (@subtype_trans S T U)
end.

Lemma transitivity_workaround_1 : forall T1 T2 T3 T4,
subtype T1 T2 ->
subtype T2 T3 ->
subtype T3 T4 ->
subtype T1 T4.
Proof. hammer_hook "UseAuto" "UseAuto.transitivity_workaround_1".
intros.  eauto.
Qed.

Lemma transitivity_workaround_2 : forall S T,
subtype S T.
Proof. hammer_hook "UseAuto" "UseAuto.transitivity_workaround_2".
intros.  eauto.
Abort.

Require Import Omega.

Lemma omega_demo_1 : forall (x y : nat),
(y <= 4) ->
(x + x + 1 <= y) ->
(x <> 0) ->
(x = 1).
Proof. hammer_hook "UseAuto" "UseAuto.omega_demo_1". intros. omega. Qed.

Lemma omega_demo_2 : forall (x y z : nat),
(x + y = z + z) ->
(x - y <= 4) ->
(x - z <= 2).
Proof. hammer_hook "UseAuto" "UseAuto.omega_demo_2". intros. omega. Qed.

Lemma omega_demo_3 : forall (x y : nat),
(x + 5 <= y) ->
(y - x < 3) ->
False.
Proof. hammer_hook "UseAuto" "UseAuto.omega_demo_3". intros. omega. Qed.

Lemma omega_demo_4 : forall (x y : nat) (P : Prop),
(x + 5 <= y) ->
(y - x < 3) ->
P.
Proof. hammer_hook "UseAuto" "UseAuto.omega_demo_4".
intros.

false. omega.
Qed.

Require Import ZArith.
Module RingDemo.
Open Scope Z_scope.

Lemma ring_demo : forall (x y z : Z),
x * (y + z) - z * 3 * x
= x * y - 2 * x * z.
Proof. hammer_hook "UseAuto" "UseAuto.RingDemo.ring_demo". intros. ring. Qed.

End RingDemo.

Lemma congruence_demo_1 :
forall (f : nat->nat->nat) (g h : nat->nat) (x y z : nat),
f (g x) (g y) = z ->
2 = g x ->
g y = h z ->
f 2 (h z) = z.
Proof. hammer_hook "UseAuto" "UseAuto.congruence_demo_1". intros. congruence. Qed.

Lemma congruence_demo_2 :
forall (f : nat->nat->nat) (g h : nat->nat) (x y z : nat),
(forall a, g a = h a) ->
f (g x) (g y) = z ->
g x = 2 ->
f 2 (h y) = z.
Proof. hammer_hook "UseAuto" "UseAuto.congruence_demo_2". congruence. Qed.

Lemma congruence_demo_4 : forall (f g : nat->nat),
(forall a, f a = g a) ->
f (g (g 2)) = g (f (f 2)).
Proof. hammer_hook "UseAuto" "UseAuto.congruence_demo_4". congruence. Qed.

Lemma congruence_demo_3 :
forall (f g h : nat->nat) (x : nat),
(forall a, f a = h a) ->
g x = f x ->
g x <> h x ->
False.
Proof. hammer_hook "UseAuto" "UseAuto.congruence_demo_3". congruence. Qed.


Require compcert.backend.Tunnelingproof.
Require LTLX.

Import Coqlib.
Import Globalenvs.
Import Events.
Import Smallstep.
Import LTLX.
Import Tunneling.
Export Tunnelingproof.

Section WITHCONFIG.
Context `{external_calls_prf: ExternalCalls}.

Variable prog: program.
Let tprog := tunnel_program prog.
Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.

Let MATCH_PROG: match_prog prog tprog.
Proof.
  apply transf_program_match.
Qed.

Lemma transf_initial_states:
  forall init_ls i sg args m,
  forall st1, initial_state init_ls prog i sg args m st1 ->
  exists st2, initial_state init_ls tprog i sg args m st2 /\ match_states st1 st2.
Proof.
  intros. inversion H.
  econstructor; split.
  econstructor.
  unfold tprog. erewrite symbols_preserved; eauto.
  unfold tprog. erewrite function_ptr_translated; eauto.
  subst. rewrite sig_preserved. auto.
  assumption.
  constructor; auto. constructor.
Qed.

Lemma transf_final_states:
  forall init_ls,
  forall sg,
  forall st1 st2 r,
  match_states st1 st2 -> final_state init_ls sg st1 r -> final_state init_ls sg st2 r.
Proof.
  intros. inv H0. inv H. inv H4. econstructor; eauto.
Qed.

Theorem transf_program_correct:
  forall init_ls i sg args m,
  forward_simulation (semantics init_ls prog i sg args m) (semantics init_ls tprog i sg args m).
Proof.
  intros.
  eapply forward_simulation_opt.
  eapply senv_preserved; eauto.
  apply transf_initial_states.
  apply transf_final_states.
  apply tunnel_step_correct; auto.
Qed.

End WITHCONFIG.


(* Transfer between N and nat *)
(* Copyright Théo Zimmermann 2015
 * This Source Code Form is subject to the terms of the Mozilla Public License, v.2.0.
 * If a copy of the MPL was not distributed with this file, You can obtain one at
 * http://mozilla.org/MPL/2.0/.
 *)

From Coq Require Import BinNatDef Nnat CMorphisms Program.Basics.
Require Import Transfer.

Definition natN x x' := N.of_nat x = x'.

Instance natN_nb : forall n : nat, Related natN n (N.of_nat n) | 10.
Proof. reflexivity. Qed.

Instance natN_nb' : forall n : N, Related natN (N.to_nat n) n | 10.
Proof. apply N2Nat.id. Qed.

(* Totality of natN *)

Instance natN_bitotal :
  Related ((natN ##> iffT) ##> iffT) forall_def forall_def.
Proof.
  unfold natN.
  intros ? ? HP.
  split; intros ? ?; eapply HP; trivial using N2Nat.id.
Qed.

Module N2Nat_transfer.

(* Preliminaries *)

Lemma natN_bis x x' : natN x x' -> N.to_nat x' = x.
Proof.
  intros <-.
  apply Nat2N.id.
Qed.

Lemma natN_bis_recip x x' : N.to_nat x' = x -> natN x x'.
Proof.
  intros <-.
  apply N2Nat.id.
Qed.

Import N2Nat.

Ltac solve thm :=
  intros;
  unfold arrow, impl;
  repeat (intros ? ? <-%natN_bis);
  try (apply natN_bis_recip);
  (apply thm || symmetry ; apply thm).

(* This symmetry is required for some theorem which
   we translate with eq when we should really have used
   flip eq *)

(* Rewrite all theorems from N2Nat *)

Instance inj : Related (natN ##> natN ##> arrow) eq eq.
Proof.
  solve inj.
Qed.

Instance inj_iff : Related (natN ##> natN ##> iff) eq eq.
Proof.
  solve inj_iff.
Qed.

Instance inj_iffT : Related (natN ##> natN ##> iffT) eq eq.
Proof.
  intros ? ? reln ? ? relm.
  split;
  unfold natN in *.
  - rewrite <- reln.
    intros -> .
    assumption.
  - rewrite <- relm.
    intros -> .
    now apply Nat2N.inj.
Qed.

(* inj_double, inj_succ_double *)

Instance inj_succ : Related (natN ##> natN) S N.succ.
Proof.
  solve inj_succ.
Qed.

Instance inj_add : Related (natN ##> natN ##> natN) Nat.add N.add.
Proof.
  solve inj_add.
Qed.

Instance inj_mul : Related (natN ##> natN ##> natN) Nat.mul N.mul.
Proof.
  solve inj_mul.
Qed.

Instance inj_sub : Related (natN ##> natN ##> natN) Nat.sub N.sub.
Proof.
  solve inj_sub.
Qed.

Instance inj_pred : Related (natN ##> natN) Nat.pred N.pred.
Proof.
  solve inj_pred.
Qed.

Instance inj_div2 : Related (natN ##> natN) Nat.div2 N.div2.
Proof.
  solve inj_div2.
Qed.

Instance inj_compare :
  Related (natN ##> natN ##> eq) Nat.compare N.compare.
Proof.
  solve inj_compare.
Qed.

Instance inj_max : Related (natN ##> natN ##> natN) Nat.max N.max.
Proof.
  solve inj_max.
Qed.

Instance inj_min : Related (natN ##> natN ##> natN) Nat.min N.min.
Proof.
  solve inj_min.
Qed.

Instance inj_iter :
  forall {A} (f : A -> A) (x : A),
  Related (natN ##> eq)
    (fun n => Nat.iter n f x) (fun n => N.iter n f x).
Proof.
  solve inj_iter.
Qed.

End N2Nat_transfer.

Module Nat2N_transfer.

Import Nat2N.

(* Preliminaries *)

Ltac solve thm :=
  intros;
  unfold arrow, impl, flip;
  repeat (intros ? ? <-);
  try (rewrite natN);
  apply thm.

Instance inj : Related (natN ##> natN ##> flip impl) eq eq.
Proof.
  solve inj.
Qed.

(* The rest would mean proving all the same theorems again,
   so we won't do it although that can be done. *)

(* Etc *)

End Nat2N_transfer.


(** Monoidal functors *)

(** behaviour w.r.t. to swapped tensor products added by Ralph Matthes in 2019, then iso changed to z_iso in 2021 *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored.
Require Import UniMath.CategoryTheory.whiskering.

Local Open Scope cat.

Section Monoidal_Functor.

Context (Mon_C Mon_D : monoidal_cat).

Local Definition tensor_C := monoidal_cat_tensor Mon_C.
Notation "X ⊗_C Y" := (tensor_C (X , Y)) (at level 31).
Notation "f #⊗_C g" := (# tensor_C (f #, g)) (at level 31).
Local Definition I_C := monoidal_cat_unit Mon_C.
Local Definition α_C := monoidal_cat_associator Mon_C.
Local Definition λ_C := monoidal_cat_left_unitor Mon_C.
Local Definition ρ_C := monoidal_cat_right_unitor Mon_C.

Local Definition tensor_D := monoidal_cat_tensor Mon_D.
Notation "X ⊗_D Y" := (tensor_D (X , Y)) (at level 31).
Notation "f #⊗_D g" := (# tensor_D (f #, g)) (at level 31).
Local Definition I_D := monoidal_cat_unit Mon_D.
Local Definition α_D := monoidal_cat_associator Mon_D.
Local Definition λ_D := monoidal_cat_left_unitor Mon_D.
Local Definition ρ_D := monoidal_cat_right_unitor Mon_D.

Section Monoidal_Functor_Conditions.

Context (F : Mon_C ⟶ Mon_D).

Definition monoidal_functor_map_dom : category_binproduct Mon_C Mon_C ⟶ Mon_D :=
  functor_composite (pair_functor F F) tensor_D.

Lemma monoidal_functor_map_dom_ok: functor_on_objects monoidal_functor_map_dom =
  λ c, F (ob1 c) ⊗_D F (ob2 c).
Proof.
  apply idpath.
Qed.

Definition monoidal_functor_map_codom : category_binproduct Mon_C Mon_C ⟶ Mon_D :=
  functor_composite tensor_C F.

Lemma monoidal_functor_map_codom_ok: functor_on_objects monoidal_functor_map_codom =
  λ c, F (ob1 c ⊗_C ob2 c).
Proof.
  apply idpath.
Qed.

Definition monoidal_functor_map :=
  monoidal_functor_map_dom ⟹ monoidal_functor_map_codom.

Definition monoidal_functor_map_funclass (μ : monoidal_functor_map) :
  ∏ x : ob (Mon_C ⊠ Mon_C), monoidal_functor_map_dom x -->  monoidal_functor_map_codom x
  := pr1 μ.
Coercion monoidal_functor_map_funclass : monoidal_functor_map >-> Funclass.

Definition monoidal_functor_associativity (μ : monoidal_functor_map) :=
  ∏ (x y z : Mon_C),
  μ (x, y) #⊗_D id F(z) · μ (x ⊗_C y, z) · #F (α_C ((x, y), z))
  =
  α_D ((F x, F y), F z) · id (F x) #⊗_D μ (y, z) · μ (x, y ⊗_C z).

Definition monoidal_functor_unitality (ϵ : I_D --> F I_C) (μ : monoidal_functor_map) :=
  ∏ (x : Mon_C),
  (λ_D (F x) = ϵ #⊗_D (id (F x)) · μ (I_C, x) · #F (λ_C x))
  ×
  (ρ_D (F x) = (id (F x)) #⊗_D ϵ · μ (x, I_C) · #F (ρ_C x)).

End Monoidal_Functor_Conditions.

Definition lax_monoidal_functor : UU :=
  ∑ F : Mon_C ⟶ Mon_D, ∑ ϵ : I_D --> F I_C, ∑ μ : monoidal_functor_map F,
  (monoidal_functor_associativity F μ) × (monoidal_functor_unitality F ϵ μ).

Definition make_lax_monoidal_functor (F : Mon_C ⟶ Mon_D) (ϵ : I_D --> F I_C)
  (μ : monoidal_functor_map F) (Hass: monoidal_functor_associativity F μ)
  (Hunit: monoidal_functor_unitality F ϵ μ): lax_monoidal_functor :=
  (F,, (ϵ,, (μ,, (Hass,, Hunit)))).

Definition lax_monoidal_functor_functor (lmF : lax_monoidal_functor) : Mon_C ⟶ Mon_D := pr1 lmF.
Coercion lax_monoidal_functor_functor : lax_monoidal_functor >-> functor.

Definition lax_monoidal_functor_ϵ (lmF : lax_monoidal_functor) :
  I_D -->  lax_monoidal_functor_functor lmF I_C
  := pr1 (pr2 lmF).

Definition lax_monoidal_functor_μ (lmF : lax_monoidal_functor) :
  monoidal_functor_map (lax_monoidal_functor_functor lmF)
  := pr1 (pr2 (pr2 lmF)).

Definition lax_monoidal_functor_assoc (lmF : lax_monoidal_functor) :
  monoidal_functor_associativity (lax_monoidal_functor_functor lmF) (lax_monoidal_functor_μ lmF)
  := pr1 (pr2 (pr2 (pr2 lmF))).

Definition lax_monoidal_functor_unital (lmF : lax_monoidal_functor) :
  monoidal_functor_unitality (lax_monoidal_functor_functor lmF) (lax_monoidal_functor_ϵ lmF) (lax_monoidal_functor_μ lmF)
  := pr2 (pr2 (pr2 (pr2 lmF))).

Definition strong_monoidal_functor : UU :=
  ∑ lmF : lax_monoidal_functor,
  (is_z_isomorphism (lax_monoidal_functor_ϵ lmF)) (* ϵ is an iso *)
  ×
  (is_nat_z_iso (lax_monoidal_functor_μ lmF)). (* μ is an iso *)

Definition strong_monoidal_functor_lax_monoidal_functor (smF : strong_monoidal_functor) : lax_monoidal_functor
  := pr1 smF.
Coercion strong_monoidal_functor_lax_monoidal_functor : strong_monoidal_functor >-> lax_monoidal_functor.

Definition strong_monoidal_functor_ϵ_is_z_iso (smF : strong_monoidal_functor) :
  is_z_isomorphism (lax_monoidal_functor_ϵ smF)
  := pr1 (pr2 smF).

Definition strong_monoidal_functor_μ_is_nat_z_iso (smF : strong_monoidal_functor) :
  is_nat_z_iso (lax_monoidal_functor_μ smF)
  := pr2 (pr2 smF).

Definition strong_monoidal_functor_ϵ (smF : strong_monoidal_functor) :
  z_iso I_D (lax_monoidal_functor_functor smF I_C)
  := make_z_iso _ _ (strong_monoidal_functor_ϵ_is_z_iso smF).

Definition strong_monoidal_functor_ϵ_inv (smF : strong_monoidal_functor) :
  lax_monoidal_functor_functor smF I_C  --> I_D
  := inv_from_z_iso (strong_monoidal_functor_ϵ smF).

Definition strong_monoidal_functor_μ (smF : strong_monoidal_functor) :
  nat_z_iso (monoidal_functor_map_dom smF) (monoidal_functor_map_codom smF)
  := make_nat_z_iso _ _
                    (lax_monoidal_functor_μ smF)
                    (strong_monoidal_functor_μ_is_nat_z_iso smF).

Definition strong_monoidal_functor_μ_inv (smF : strong_monoidal_functor)
  : monoidal_functor_map_codom smF ⟹ monoidal_functor_map_dom smF
  := nat_z_iso_to_trans_inv (strong_monoidal_functor_μ smF).

End Monoidal_Functor.

Arguments lax_monoidal_functor_ϵ {_ _} _ .
Arguments lax_monoidal_functor_μ {_ _} _ .
Arguments lax_monoidal_functor_assoc {_ _} _ .
Arguments lax_monoidal_functor_unital {_ _} _ .
Arguments strong_monoidal_functor_ϵ_is_z_iso {_ _} _ .
Arguments strong_monoidal_functor_μ_is_nat_z_iso {_ _} _ .
Arguments strong_monoidal_functor_ϵ {_ _} _ .
Arguments strong_monoidal_functor_ϵ_inv {_ _} _ .
Arguments strong_monoidal_functor_μ {_ _} _ .
Arguments strong_monoidal_functor_μ_inv {_ _} _ .

Section swapped_tensor.

  Context {Mon Mon' : monoidal_cat}.

  Local Definition tensor := monoidal_cat_tensor Mon.
  Local Definition tensor' := monoidal_cat_tensor Mon'.

Lemma swapping_of_lax_monoidal_functor_assoc (lmF: lax_monoidal_functor Mon Mon'):
  monoidal_functor_associativity (swapping_of_monoidal_cat Mon) (swapping_of_monoidal_cat Mon') lmF
                                 (pre_whisker binswap_pair_functor (lax_monoidal_functor_μ lmF)).
Proof.
  induction lmF as [F [ϵ [μ [Hass Hunit]]]].
  red. intros x y z.
  set (Hass_inst := Hass z y x).
  apply pathsinv0. rewrite <- assoc.
  cbn.
  set (f := nat_z_iso_pointwise_z_iso (monoidal_cat_associator Mon') ((F z, F y), F x)).
  apply (z_iso_inv_on_right _ _ _ f).
  transparent assert (is : (is_z_isomorphism (# F (monoidal_cat_associator Mon ((z, y), x))))).
  { apply functor_on_is_z_isomorphism.
    apply monoidal_cat_associator.
  }
  set (Hass_inst' := z_iso_inv_on_left _ _ _ _ (_,, is) _ (! Hass_inst)).
  etrans.
  { exact Hass_inst'. }
  clear Hass_inst Hass_inst'.
  do 2 rewrite assoc.
  apply cancel_precomposition.
  apply idpath.
Qed.

Definition swapping_of_lax_monoidal_functor: lax_monoidal_functor Mon Mon' ->
  lax_monoidal_functor (swapping_of_monoidal_cat Mon)
                       (swapping_of_monoidal_cat Mon').
Proof.
  intro lmF.
  induction lmF as [F [ϵ [μ [Hass Hunit]]]].
  use make_lax_monoidal_functor.
  - exact F.
  - exact ϵ.
  - exact (pre_whisker binswap_pair_functor μ).
  - apply (swapping_of_lax_monoidal_functor_assoc (F,, (ϵ,, (μ,, (Hass,, Hunit))))).
  - abstract ( red; intro x; induction (Hunit x) as [Hunit1 Hunit2]; split; assumption ).
Defined.

Definition swapping_of_strong_monoidal_functor: strong_monoidal_functor Mon Mon' ->
  strong_monoidal_functor (swapping_of_monoidal_cat Mon)
                          (swapping_of_monoidal_cat Mon').
Proof.
  intro smF.
  induction smF as [lmF [Hϵ Hμ]].
  apply (tpair _ (swapping_of_lax_monoidal_functor lmF)).
  split.
  - exact Hϵ.
  - exact (pre_whisker_on_nat_z_iso binswap_pair_functor (lax_monoidal_functor_μ lmF) Hμ).
Defined.

Lemma swapping_of_strong_monoidal_functor_on_objects (smF: strong_monoidal_functor Mon Mon')(a: Mon): swapping_of_strong_monoidal_functor smF a = smF a.
Proof.
  apply idpath.
Qed.

End swapped_tensor.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^448 - 2^224 - 1
Base: 56
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 56;
    bitwidth := 64;
    s := 2^448;
    c := [(1, 1); (2^224, 1)];
    carry_chains := Some [[3; 7]; [4; 0; 5; 1; 6; 2; 7; 3]; [4; 0]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := Some true;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime P A B C A1 B1 C1 C1prime M D1prime N : Universe, ((wd_ O E /\ (wd_ A C /\ (wd_ B P /\ (wd_ A B /\ (wd_ O M /\ (wd_ O C1 /\ (wd_ C1 C1prime /\ (wd_ O C1prime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ P A /\ (wd_ P C /\ (wd_ O A1 /\ (wd_ O B1 /\ (wd_ M C1 /\ (wd_ M C1prime /\ (wd_ A1 Eprime /\ (wd_ A1 C1prime /\ (col_ P A B /\ (col_ P C P /\ (col_ C B P /\ (col_ O E A1 /\ (col_ O E B1 /\ (col_ O E C1 /\ (col_ O E O /\ (col_ O M N /\ (col_ N O D1prime /\ col_ M C1 C1prime))))))))))))))))))))))))))) -> col_ P A C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Category.Lib.
Require Import Category.Theory.Category.

Generalizable All Variables.

Reserved Infix "~>⁻" (at level 90, right associativity).
Reserved Infix "∘⁻" (at level 40, left associativity).

Class RawCategory := {
  r_obj : Type;

  r_uhom := Type : Type;
  r_hom : r_obj → r_obj → r_uhom where "a ~>⁻ b" := (r_hom a b);

  r_id {x} : r_hom x x;
  r_compose {x y z} (f: r_hom y z) (g : r_hom x y) : r_hom x z
    where "f ∘⁻ g" := (r_compose f g);
}.

Declare Scope raw_category_scope.
Declare Scope raw_object_scope.
Declare Scope raw_morphism_scope.

Bind Scope raw_category_scope with RawCategory.
Bind Scope raw_object_scope with r_obj.

Delimit Scope raw_category_scope with raw_category.
Delimit Scope raw_object_scope with raw_object.
Delimit Scope raw_morphism_scope with raw_morphism.

Notation "x ~>⁻ y" := (@r_hom _%raw_category x%raw_object y%raw_object)
  (at level 90, right associativity) : type_scope.
Notation "f ∘⁻ g" :=
  (@r_compose _%raw_category _%raw_object _%raw_object _%raw_object f%raw_morphism g%raw_morphism)
  : raw_morphism_scope.

Coercion r_obj : RawCategory >-> Sortclass.

Definition From_RawCategory
           (raw : RawCategory)
           {homset} {compose_respects}
           {id_left id_right comp_assoc} : Category :=
  {| obj              := r_obj;
     hom              := r_hom;
     homset           := homset;
     id               := @r_id raw;
     compose          := @r_compose raw;
     compose_respects := compose_respects;
     id_left          := id_left;
     id_right         := id_right;
     comp_assoc       := comp_assoc;
     comp_assoc_sym   :=
       fun _ _ _ _ _ _ _ => symmetry (@comp_assoc _ _ _ _ _ _ _) |}.

Open Scope raw_morphism_scope.

(** A [Denotation] is a Functor from a lawless "category" to a lawful
    category. This is enough to establish the laws of the source category via
    the homomorphisms [h_id] and [h_compose], so long as equivalence of
    morphisms in the source category is defined in terms of [denote].

    See [DerivedEquivalence] below. *)
Class Denotation {C : RawCategory} {D : Category} := {
  dobj : C → D;
  denote {x y : C} (f : x ~>⁻ y) : dobj x ~> dobj y;

  h_id (x : C) : @denote x x r_id ≈ id;
  h_compose (x y z : C) (f : y ~>⁻ z) (g : x ~>⁻ y) :
    denote (f ∘⁻ g) ≈ denote f ∘ denote g
}.

Coercion dobj : Denotation >-> Funclass.

Notation "C ⟶⁻ D" := (@Denotation C%raw_category D%category)
  (at level 90, right associativity) : type_scope.

Program Definition DerivedEquivalence
        `(F : C ⟶⁻ D) : ∀ X Y, Setoid (X ~>⁻ Y) := fun X Y =>
  {| equiv := fun f g => denote f ≈ denote g
   ; setoid_equiv := _ |}.

(** Given a lawless "category", a lawful category, and a denotation from the
    former to the latter, return a re-definition of the source as a lawful
    category, by way of that denotation. *)
Program Definition LawfulCategory `{F : C ⟶⁻ D} : Category :=
  @From_RawCategory C (DerivedEquivalence F) _ _ _ _.
Next Obligation. proper; now rewrite !h_compose, X, X0. Qed.
Next Obligation. rewrite h_compose, h_id; now cat. Qed.
Next Obligation. rewrite h_compose, h_id; now cat. Qed.
Next Obligation. rewrite !h_compose; now cat. Qed.