(* Do not edit this file, it was generated automatically *)
Require Import VST.floyd.proofauto.
Require Import VST.progs64.revarray.
Require Import VST.floyd.sublist.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition reverse_spec :=
 DECLARE _reverse
  WITH a0: val, sh : share, contents : list int, size: Z
  PRE [ _a OF (tptr tint), _n OF tint ]
          PROP (0 <= size <= Int.max_signed; writable_share sh)
          LOCAL (temp _a a0; temp _n (Vint (Int.repr size)))
          SEP (data_at sh (tarray tint size) (map Vint contents) a0)
  POST [ tvoid ]
     PROP() LOCAL()
     SEP(data_at sh (tarray tint size) (map Vint (rev contents)) a0).

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog nil gv
  POST [ tint ] main_post prog nil gv.

Definition Gprog : funspecs :=   ltac:(with_library prog [reverse_spec; main_spec]).

Definition flip_ends {A} lo hi (contents: list A) :=
  sublist 0 lo (rev contents)
  ++ sublist lo hi contents
  ++ sublist hi (Zlength contents) (rev contents).

Definition reverse_Inv a0 sh contents size :=
 (EX j:Z,
  (PROP  (0 <= j; j <= size-j)
   LOCAL  (temp _a a0; temp _lo (Vint (Int.repr j)); temp _hi (Vint (Int.repr (size-j))))
   SEP (data_at sh (tarray tint size) (flip_ends j (size-j) contents) a0)))%assert.

Lemma Zlength_flip_ends:
 forall A i j (al: list A),
 0 <= i  -> i<=j -> j <= Zlength al ->
 Zlength (flip_ends i j al) = Zlength al.
Proof.
intros.
unfold flip_ends.
autorewrite with sublist. omega.
Qed.
Hint Rewrite @Zlength_flip_ends using (autorewrite with sublist; omega) : sublist.

Lemma flip_fact_1: forall A size (contents: list A) j,
  Zlength contents = size ->
  0 <= j ->
  size - j - 1 <= j <= size - j ->
  flip_ends j (size - j) contents = rev contents.
Proof.
  intros.
  unfold flip_ends.
  rewrite <- (Zlen_le_1_rev (sublist j (size-j) contents))
      by (autorewrite with sublist; omega).
  rewrite !sublist_rev by (autorewrite with sublist; omega).
 rewrite <- !rev_app_distr, ?H.
 autorewrite with sublist; auto.
Qed.

Lemma flip_fact_3:
 forall A (al: list A) j size,
  size = Zlength al ->
  0 <= j < size - j - 1 ->
sublist 0 j (flip_ends j (size - j) al) ++
sublist (size - j - 1) (size - j) al ++
sublist (j + 1) size
  (sublist 0 (size - j - 1) (flip_ends j (size - j) al) ++
   sublist j (j + 1) (flip_ends j (size - j) al) ++
   sublist (size - j) size (flip_ends j (size - j) al)) =
flip_ends (j + 1) (size - (j + 1)) al.
Proof.
intros.
unfold flip_ends.
rewrite <- H.
autorewrite with sublist.
rewrite (sublist_split 0 j (j+1)) by (autorewrite with sublist; omega).
rewrite !app_ass.
f_equal. f_equal.
rewrite !sublist_rev, <- ?H by omega.
rewrite Zlen_le_1_rev by (autorewrite with sublist; omega).
f_equal; omega.
rewrite (sublist_app2 (size-j) size)
 by (autorewrite with sublist; omega).
autorewrite with sublist.
rewrite sublist_app'
 by (autorewrite with sublist; omega).
autorewrite with sublist.
f_equal.
f_equal; omega.
autorewrite with sublist.
  rewrite <- (Zlen_le_1_rev (sublist j (1+j) al))
      by (autorewrite with sublist; omega).
rewrite !sublist_rev, <- ?H by omega.
 rewrite <- !rev_app_distr, <- ?H.
 autorewrite with sublist.
 f_equal; f_equal; omega.
Qed.

Lemma flip_ends_map:
  forall A B (F: A -> B) lo hi (al: list A),
  flip_ends lo hi (map F al) = map F (flip_ends lo hi al).
Proof.
intros.
unfold flip_ends.
rewrite !map_app.
rewrite !map_sublist, !map_rev, Zlength_map.
auto.
Qed.

Lemma flip_fact_2:
  forall {A}{d: Inhabitant A} (al: list A) size j,
 Zlength al = size ->
  j < size - j - 1 ->
   0 <= j ->
  Znth (size - j - 1) al =
  Znth (size - j - 1) (flip_ends j (size - j) al).
Proof.
intros.
unfold flip_ends.
autorewrite with sublist. auto.
Qed.

Lemma body_reverse: semax_body Vprog Gprog f_reverse reverse_spec.
Proof.
start_function.
forward.  (* lo = 0; *)
forward. (* hi = n; *)

assert_PROP (Zlength (map Vint contents) = size)
    as ZL by entailer!.
forward_while (reverse_Inv a0 sh (map Vint contents) size).
* (* Prove that current precondition implies loop invariant *)
Exists 0.
entailer!.
unfold flip_ends; autorewrite with sublist; auto.
* (* Prove that loop invariant implies typechecking condition *)
entailer!.
* (* Prove that loop body preserves invariant *)
forward. (* t = a[lo]; *)
{
  entailer!.
  clear - H0 HRE.
  autorewrite with sublist in *|-*.
  rewrite flip_ends_map.
  rewrite Znth_map by list_solve.
  apply I.
}
forward.  (* s = a[hi-1]; *)
{
  entailer!.
  clear - H H0 HRE.
  autorewrite with sublist in *|-*.
  rewrite flip_ends_map.
  rewrite Znth_map by list_solve.
  apply I.
}
rewrite <- flip_fact_2 by (rewrite ?Zlength_flip_ends; omega).
forward. (*  a[hi-1] = t; *)
forward. (* a[lo] = s; *)
forward. (* lo++; *)
forward. (* hi--; *)
(* Prove postcondition of loop body implies loop invariant *)
 Exists (Z.succ j).
 entailer!.
 f_equal; f_equal; omega.
 simpl.
 apply derives_refl'.
 unfold data_at.    f_equal.
 clear - H0 HRE H1.
 unfold Z.succ.
 rewrite <- flip_fact_3 by auto.
 rewrite <- (Znth_map (Zlength (map Vint contents)-j-1) Vint) by (autorewrite with sublist in *; list_solve).
 forget (map Vint contents) as al. clear contents.
 remember (Zlength al) as size.
 repeat match goal with |- context [reptype ?t] => change (reptype t) with val end.
 unfold upd_Znth.
 rewrite !Znth_cons_sublist by (repeat rewrite Zlength_flip_ends; try omega).
 rewrite ?Zlength_app, ?Zlength_firstn, ?Z.max_r by omega.
 rewrite ?Zlength_flip_ends by omega.
 rewrite ?Zlength_sublist by (rewrite ?Zlength_flip_ends ; omega).
 unfold Z.succ. rewrite <- Heqsize. autorewrite with sublist.
 replace (size - j - 1 + (1 + j)) with size by (clear; omega).
 reflexivity.
* (* after the loop *)
forward. (* return; *)
rewrite map_rev. rewrite flip_fact_1; try omega; auto.
cancel.
Qed.

Definition four_contents := [Int.repr 1; Int.repr 2; Int.repr 3; Int.repr 4].

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
name four _four.
start_function.

forward_call  (*  revarray(four,4); *)
  (gv _four, Ews, four_contents, 4).
   split; [computable | auto].
forward_call  (*  revarray(four,4); *)
    (gv _four,Ews, rev four_contents,4).
   split; [computable | auto].
rewrite rev_involutive.
forward. (* return s; *)
Qed.

Existing Instance NullExtension.Espec.

Lemma prog_correct:
  semax_prog prog Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons body_reverse.
semax_func_cons body_main.
Qed.


Require Export SystemFR.SwapTypeHoles.
Require Export SystemFR.SwapTermHoles.

Require Import Psatz.

(* measure for ensuring termination of reducible_values *)
(* see file ReducibilityMeasure for the full measure *)
Fixpoint type_nodes T: nat :=
  match T with
  | T_unit => 0
  | T_bool => 0
  | T_nat => 0
  | T_refine A p => 1 + type_nodes A
  | T_type_refine A B => 1 + type_nodes A + type_nodes B
  | T_arrow A B => 1 + type_nodes A + type_nodes B
  | T_prod A B => 1 + type_nodes A + type_nodes B
  | T_sum A B => 1 + type_nodes A + type_nodes B
  | T_intersection A B => 1 + type_nodes A + type_nodes B
  | T_union A B => 1 + type_nodes A + type_nodes B
  | T_top => 0
  | T_bot => 0
  | T_equiv _ _ => 0
  | T_forall A B => 1 + type_nodes A + type_nodes B
  | T_exists A B => 1 + type_nodes A + type_nodes B
  | T_abs T => 1 + type_nodes T
  | T_rec _ T0 Ts => 1 + type_nodes T0 + type_nodes Ts

  | _ => 0
  end.

Lemma type_nodes_term:
  forall t,
    is_erased_term t ->
    type_nodes t = 0.
Proof.
  induction t; steps.
Qed.

Lemma type_nodes_opening:
  forall T k rep,
    is_erased_type T ->
    is_erased_term rep ->
    type_nodes (open k T rep) = type_nodes T.
Proof.
  induction T; repeat step || rewrite_any || apply type_nodes_term_form;
    try lia.
Qed.

#[export] Hint Rewrite type_nodes_opening: bsize.

Lemma type_nodes_opening_var:
  forall T k X, type_nodes (open k T (fvar X type_var)) = type_nodes T.
Proof.
  induction T; steps.
Qed.

#[export] Hint Rewrite type_nodes_opening_var: bsize.

Lemma type_nodes_topening_var:
  forall T k X, type_nodes (topen k T (fvar X type_var)) = type_nodes T.
Proof.
  induction T; steps.
Qed.

#[export] Hint Rewrite type_nodes_topening_var: bsize.

Lemma type_nodes_swap_type_holes:
  forall t i j, type_nodes (swap_type_holes t i j) = type_nodes t.
Proof.
  induction t; steps.
Qed.

#[export] Hint Rewrite type_nodes_swap_type_holes: bsize.

Lemma type_nodes_swap_term_holes:
  forall t i j, type_nodes (swap_term_holes t i j) = type_nodes t.
Proof.
  induction t; steps.
Qed.

#[export] Hint Rewrite type_nodes_swap_term_holes: bsize.


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

 Kleisli objects in bicategories

 Contents
 1. Kleisli objects via universal mapping properties
 2. It is a proposition
 3. Bicategories with Kleisli objects

 *******************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.TransportLaws.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.Examples.OpMorBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax.

Local Open Scope cat.

Section KleisliObject.
  Context {B : bicat}
          (m : mnd (op1_bicat B)).

  Let z : B := ob_of_mnd m.
  Let h : z --> z := endo_of_mnd m.
  Let η : id₁ _ ==> h := unit_of_mnd m.
  Let μ : h · h ==> h := mult_of_mnd m.

  (**
   1. Kleisli objects via universal mapping properties
   *)
  Definition kleisli_cocone
    : UU
    := ∑ (x : B)
         (f : z --> x)
         (γ : h · f ==> f),
       (η ▹ f • γ = lunitor _)
       ×
       (rassociator _ _ _ • (_ ◃ γ) • γ = (μ ▹ f) • γ).

  Definition make_kleisli_cocone
             {x : B}
             (f : z --> x)
             (γ : h · f ==> f)
             (fη : η ▹ f • γ = lunitor _)
             (fμ : rassociator _ _ _ • (_ ◃ γ) • γ = (μ ▹ f) • γ)
    : kleisli_cocone
    := x ,, f ,, γ ,, fη ,, fμ.

  Coercion kleisli_cocone_ob (q : kleisli_cocone) : B := pr1 q.

  Section Projections.
    Context (q : kleisli_cocone).

    Definition mor_of_kleisli_cocone
      : z --> q
      := pr12 q.

    Definition cell_of_kleisli_cocone
      : h · mor_of_kleisli_cocone
        ==>
        mor_of_kleisli_cocone
      := pr122 q.

    Definition kleisli_cocone_unit
      : (η ▹ _) • cell_of_kleisli_cocone = lunitor _
      := pr1 (pr222 q).

    Definition kleisli_cocone_mult
      : rassociator _ _ _
        • (_ ◃ cell_of_kleisli_cocone)
        • cell_of_kleisli_cocone
        =
        (μ ▹ _) • cell_of_kleisli_cocone
      := pr2 (pr222 q).
  End Projections.

  Definition kleisli_cocone_mor
             (q₁ q₂ : kleisli_cocone)
    : UU
    := ∑ (f : q₁ --> q₂)
         (α : mor_of_kleisli_cocone q₁ · f ==> mor_of_kleisli_cocone q₂),
       ((_ ◃ α) • cell_of_kleisli_cocone q₂
        =
        lassociator _ _ _
        • (cell_of_kleisli_cocone q₁ ▹ _)
        • α)
       ×
       is_invertible_2cell α.

  Definition make_kleisli_cocone_mor
             {q₁ q₂ : kleisli_cocone}
             (f : q₁ --> q₂)
             (α : mor_of_kleisli_cocone q₁ · f ==> mor_of_kleisli_cocone q₂)
             (p : (_ ◃ α) • cell_of_kleisli_cocone q₂
                  =
                  lassociator _ _ _
                  • (cell_of_kleisli_cocone q₁ ▹ _)
                  • α)
             (Hα : is_invertible_2cell α)
    : kleisli_cocone_mor q₁ q₂
    := f ,, α ,, p ,, Hα.

  Coercion mor_of_kleisli_cocone_mor
           {q₁ q₂ : kleisli_cocone}
           (f : kleisli_cocone_mor q₁ q₂)
    : q₁ --> q₂
    := pr1 f.

  Definition cell_of_kleisli_cocone_mor
             {q₁ q₂ : kleisli_cocone}
             (f : kleisli_cocone_mor q₁ q₂)
    : mor_of_kleisli_cocone q₁ · f ==> mor_of_kleisli_cocone q₂
    := pr12 f.

  Definition kleisli_cocone_mor_endo
             {q₁ q₂ : kleisli_cocone}
             (f : kleisli_cocone_mor q₁ q₂)
    : (_ ◃ cell_of_kleisli_cocone_mor f) • cell_of_kleisli_cocone q₂
      =
      lassociator _ _ _
      • (cell_of_kleisli_cocone q₁ ▹ _)
      • cell_of_kleisli_cocone_mor f
    := pr122 f.

  Definition cell_of_kleisli_cocone_mor_is_invertible
             {q₁ q₂ : kleisli_cocone}
             (f : kleisli_cocone_mor q₁ q₂)
    : is_invertible_2cell (cell_of_kleisli_cocone_mor f)
    := pr222 f.

  Definition inv2cell_of_kleisli_cocone_mor
             {q₁ q₂ : kleisli_cocone}
             (f : kleisli_cocone_mor q₁ q₂)
    : invertible_2cell
        (mor_of_kleisli_cocone q₁ · f)
        (mor_of_kleisli_cocone q₂).
  Proof.
    use make_invertible_2cell.
    - exact (cell_of_kleisli_cocone_mor f).
    - exact (cell_of_kleisli_cocone_mor_is_invertible f).
  Defined.

  Definition path_kleisli_cocone_mor
             (HB : is_univalent_2_1 B)
             {q₁ q₂ : kleisli_cocone}
             {f₁ f₂ : kleisli_cocone_mor q₁ q₂}
             (α : invertible_2cell f₁ f₂)
             (p : (mor_of_kleisli_cocone q₁ ◃ α) • cell_of_kleisli_cocone_mor f₂
                  =
                  cell_of_kleisli_cocone_mor f₁)
    : f₁ = f₂.
  Proof.
    use total2_paths_f.
    - exact (isotoid_2_1 HB α).
    - use subtypePath.
      {
        intro.
        apply isapropdirprod ; [ apply cellset_property | apply isaprop_is_invertible_2cell ].
      }
      rewrite pr1_transportf.
      rewrite transport_two_cell_FlFr.
      rewrite maponpaths_for_constant_function.
      cbn.
      rewrite id2_right.
      use vcomp_move_R_pM ; [ is_iso | ].
      cbn.
      rewrite <- idtoiso_2_1_lwhisker.
      rewrite idtoiso_2_1_isotoid_2_1.
      exact (!p).
  Qed.

  Definition has_kleisli_ump_1
             (k : kleisli_cocone)
    : UU
    := ∏ (q : kleisli_cocone), kleisli_cocone_mor k q.

  Definition has_kleisli_ump_2
             (k : kleisli_cocone)
    : UU
    := ∏ (x : B)
         (g₁ g₂ : k --> x)
         (α : mor_of_kleisli_cocone k · g₁ ==> mor_of_kleisli_cocone k · g₂)
         (p : lassociator _ _ _
              • (cell_of_kleisli_cocone k ▹ _)
              • α
              =
              (_ ◃ α)
              • lassociator _ _ _
              • (cell_of_kleisli_cocone k ▹ _)),
       ∃! (β : g₁ ==> g₂), _ ◃ β = α.

  Definition has_kleisli_ump
             (k : kleisli_cocone)
    : UU
    := has_kleisli_ump_1 k × has_kleisli_ump_2 k.

  Section Projections.
    Context {k : kleisli_cocone}
            (Hk : has_kleisli_ump k).

    Definition kleisli_ump_mor
               {a : B}
               {g : z --> a}
               (γ : h · g ==> g)
               (p₁ : (η ▹ g) • γ = lunitor g)
               (p₂ : (rassociator h h g • (h ◃ γ)) • γ = (μ ▹ g) • γ)
      : k --> a
      := pr1 Hk (make_kleisli_cocone g γ p₁ p₂).

    Definition kleisli_ump_mor_cell
               {a : B}
               {g : z --> a}
               (γ : h · g ==> g)
               (p₁ : (η ▹ g) • γ = lunitor g)
               (p₂ : (rassociator h h g • (h ◃ γ)) • γ = (μ ▹ g) • γ)
      : mor_of_kleisli_cocone k · kleisli_ump_mor γ p₁ p₂ ==> g
      := cell_of_kleisli_cocone_mor (pr1 Hk (make_kleisli_cocone g γ p₁ p₂)).

    Definition kleisli_ump_mor_cell_endo
               {a : B}
               {g : z --> a}
               (γ : h · g ==> g)
               (p₁ : (η ▹ g) • γ = lunitor g)
               (p₂ : (rassociator h h g • (h ◃ γ)) • γ = (μ ▹ g) • γ)
      : (h ◃ kleisli_ump_mor_cell γ p₁ p₂) • γ
        =
        lassociator _ _ _
        • (cell_of_kleisli_cocone k ▹ _)
        • kleisli_ump_mor_cell γ p₁ p₂
      := kleisli_cocone_mor_endo (pr1 Hk (make_kleisli_cocone g γ p₁ p₂)).

    Definition kleisli_ump_mor_cell_is_invertible
               {a : B}
               {g : z --> a}
               (γ : h · g ==> g)
               (p₁ : (η ▹ g) • γ = lunitor g)
               (p₂ : (rassociator h h g • (h ◃ γ)) • γ = (μ ▹ g) • γ)
      : is_invertible_2cell (kleisli_ump_mor_cell γ p₁ p₂)
      := cell_of_kleisli_cocone_mor_is_invertible
           (pr1 Hk (make_kleisli_cocone g γ p₁ p₂)).

    Definition kleisli_ump_mor_inv2cell
               {a : B}
               {g : z --> a}
               (γ : h · g ==> g)
               (p₁ : (η ▹ g) • γ = lunitor g)
               (p₂ : (rassociator h h g • (h ◃ γ)) • γ = (μ ▹ g) • γ)
      : invertible_2cell
          (mor_of_kleisli_cocone k · kleisli_ump_mor γ p₁ p₂) g.
    Proof.
      use make_invertible_2cell.
      - exact (kleisli_ump_mor_cell γ p₁ p₂).
      - exact (kleisli_ump_mor_cell_is_invertible γ p₁ p₂).
    Defined.

    Definition kleisli_ump_cell
               {x : B}
               {g₁ g₂ : k --> x}
               (α : mor_of_kleisli_cocone k · g₁ ==> mor_of_kleisli_cocone k · g₂)
               (p : lassociator _ _ _
                    • (cell_of_kleisli_cocone k ▹ _)
                    • α
                    =
                    (_ ◃ α)
                    • lassociator _ _ _
                    • (cell_of_kleisli_cocone k ▹ _))
      : g₁ ==> g₂
      := pr11 (pr2 Hk x g₁ g₂ α p).

    Definition kleisli_ump_cell_eq
               {x : B}
               {g₁ g₂ : k --> x}
               (α : mor_of_kleisli_cocone k · g₁ ==> mor_of_kleisli_cocone k · g₂)
               (p : lassociator _ _ _
                    • (cell_of_kleisli_cocone k ▹ _)
                    • α
                    =
                    (_ ◃ α)
                    • lassociator _ _ _
                    • (cell_of_kleisli_cocone k ▹ _))
      : _ ◃ kleisli_ump_cell α p = α
      := pr21 (pr2 Hk x g₁ g₂ α p).

    Definition kleisli_ump_eq
               {x : B}
               {g₁ g₂ : k --> x}
               (α : mor_of_kleisli_cocone k · g₁ ==> mor_of_kleisli_cocone k · g₂)
               (p : lassociator _ _ _
                    • (cell_of_kleisli_cocone k ▹ _)
                    • α
                    =
                    (_ ◃ α)
                    • lassociator _ _ _
                    • (cell_of_kleisli_cocone k ▹ _))
               {β₁ β₂ : g₁ ==> g₂}
               (q₁ : _ ◃ β₁ = α)
               (q₂ : _ ◃ β₂ = α)
      : β₁ = β₂.
    Proof.
      exact (maponpaths
               pr1
               (proofirrelevance
                  _
                  (isapropifcontr (pr2 Hk x g₁ g₂ α p))
                  (β₁ ,, q₁)
                  (β₂ ,, q₂))).
    Qed.

    Section Invertible.
      Context {x : B}
              {g₁ g₂ : k --> x}
              (α : invertible_2cell
                     (mor_of_kleisli_cocone k · g₁)
                     (mor_of_kleisli_cocone k · g₂))
              (p : lassociator _ _ _
                   • (cell_of_kleisli_cocone k ▹ _)
                   • α
                   =
                   (_ ◃ α)
                   • lassociator _ _ _
                   • (cell_of_kleisli_cocone k ▹ _)).

      Definition kleisi_ump_cell_inv
        : g₂ ==> g₁.
      Proof.
        refine (kleisli_ump_cell (α^-1) _).
        abstract
          (use vcomp_move_R_Mp ; [ is_iso | ] ;
           rewrite !vassocl ;
           use vcomp_move_L_pM ; [ is_iso | ] ;
           cbn ;
           rewrite !vassocr ;
           exact (!p)).
      Defined.

      Definition kleisi_ump_cell_inv_left
        : kleisli_ump_cell α p • kleisi_ump_cell_inv = id₂ _.
      Proof.
        use kleisli_ump_eq.
        - exact (id2 _).
        - rewrite id2_right.
          rewrite lwhisker_id2, id2_left.
          apply idpath.
        - rewrite <- !lwhisker_vcomp.
          unfold kleisi_ump_cell_inv.
          rewrite !kleisli_ump_cell_eq.
          apply vcomp_rinv.
        - apply lwhisker_id2.
      Qed.

      Definition kleisi_ump_cell_inv_right
        : kleisi_ump_cell_inv • kleisli_ump_cell α p = id₂ _.
      Proof.
        use kleisli_ump_eq.
        - exact (id2 _).
        - rewrite id2_right.
          rewrite lwhisker_id2, id2_left.
          apply idpath.
        - rewrite <- !lwhisker_vcomp.
          unfold kleisi_ump_cell_inv.
          rewrite !kleisli_ump_cell_eq.
          apply vcomp_linv.
        - apply lwhisker_id2.
      Qed.

      Definition kleisi_ump_cell_is_invertible
        : is_invertible_2cell (kleisli_ump_cell α p).
      Proof.
        use make_is_invertible_2cell.
        - exact kleisi_ump_cell_inv.
        - exact kleisi_ump_cell_inv_left.
        - exact kleisi_ump_cell_inv_right.
      Defined.
    End Invertible.

    Definition kleisli_ump_inv2cell
               {x : B}
               {g₁ g₂ : k --> x}
               (α : invertible_2cell
                      (mor_of_kleisli_cocone k · g₁)
                      (mor_of_kleisli_cocone k · g₂))
               (p : lassociator _ _ _
                    • (cell_of_kleisli_cocone k ▹ _)
                    • α
                    =
                    (_ ◃ α)
                    • lassociator _ _ _
                    • (cell_of_kleisli_cocone k ▹ _))
      : invertible_2cell g₁ g₂.
    Proof.
      use make_invertible_2cell.
      - exact (kleisli_ump_cell α p).
      - exact (kleisi_ump_cell_is_invertible α p).
    Defined.
  End Projections.

  (**
   2. It is a proposition
   *)
  Definition isaprop_has_kleisli_ump
             (HB : is_univalent_2_1 B)
             (k : kleisli_cocone)
    : isaprop (has_kleisli_ump k).
  Proof.
    use invproofirrelevance.
    intros φ₁ φ₂.
    use subtypePath.
    {
      intro.
      repeat (use impred ; intro).
      apply isapropiscontr.
    }
    use funextsec ; intro.
    use (path_kleisli_cocone_mor HB).
    - use (kleisli_ump_inv2cell φ₁).
      + exact (comp_of_invertible_2cell
                 (inv2cell_of_kleisli_cocone_mor (pr1 φ₁ x))
                 (inv_of_invertible_2cell
                    (inv2cell_of_kleisli_cocone_mor (pr1 φ₂ x)))).
      + abstract
          (cbn ;
           rewrite <- !lwhisker_vcomp ;
           rewrite !vassocr ;
           rewrite <- (kleisli_cocone_mor_endo (pr1 φ₁ x)) ;
           rewrite !vassocl ;
           apply maponpaths ;
           use vcomp_move_L_pM ; [ is_iso | ] ; cbn ;
           rewrite !vassocr ;
           use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ;
           exact (kleisli_cocone_mor_endo (pr1 φ₂ x))).
    - cbn.
      rewrite kleisli_ump_cell_eq.
      rewrite !vassocl.
      rewrite vcomp_linv.
      apply id2_right.
  Qed.
End KleisliObject.

(**
 3. Bicategories with Kleisli objects
 *)
Definition has_kleisli
           (B : bicat)
  : UU
  := ∏ (m : mnd (op1_bicat B)),
     ∑ (k : kleisli_cocone m),
     has_kleisli_ump m k.


From Hammer Require Import Hammer.

Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import ExtLib.Core.Type.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Reducible.
Require Import ExtLib.Structures.Traversable.
Require Import ExtLib.Structures.Applicative.
Require Import ExtLib.Structures.Functor.
Require Import ExtLib.Structures.FunctorLaws.
Require Import ExtLib.Structures.Proper.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Tactics.Injection.
Require Import ExtLib.Tactics.Consider.

Set Implicit Arguments.
Set Strict Implicit.

Global Instance Foldable_option {T} : Foldable (option T) T :=
fun _ f d v =>
match v with
| None => d
| Some x => f x d
end.

Global Instance Traversable_option : Traversable option :=
{| mapT := fun F _ _ _ f o =>
match o with
| None => pure None
| Some o => ap (pure (@Some _)) (f o)
end
|}.

Global Instance Applicative_option : Applicative option :=
{| pure := @Some
; ap := fun _ _ f x =>
match f , x with
| Some f , Some x => Some (f x)
| _ , _ => None
end
|}.

Global Instance Functor_option : Functor option :=
{| fmap := fun _ _ f x => match x with
| None => None
| Some x => Some (f x)
end |}.

Section relation.
Context {T : Type}.
Variable (R : relation T).

Inductive Roption : Relation_Definitions.relation (option T) :=
| Roption_None : Roption None None
| Roption_Some : forall x y, R x y -> Roption (Some x) (Some y).

Lemma Reflexive_Roption : Reflexive R -> Reflexive Roption.
Proof. hammer_hook "Option" "Option.Reflexive_Roption". clear. compute. destruct x; try constructor; auto. Qed.

Lemma Symmetric_Roption : Symmetric R -> Symmetric Roption.
Proof. hammer_hook "Option" "Option.Symmetric_Roption". clear. compute. intros.
destruct H0; constructor. auto.
Qed.

Lemma Transitive_Roption : Transitive R -> Transitive Roption.
Proof. hammer_hook "Option" "Option.Transitive_Roption".
clear. compute. intros.
destruct H0; auto.
inversion H1. constructor; auto. subst. eapply H; eassumption.
Qed.

Global Instance Injective_Roption_None
: Injective (Roption None None).
refine {| result := True |}.
auto.
Defined.

Global Instance Injective_Roption_None_Some a
: Injective (Roption None (Some a)).
refine {| result := False |}.
inversion 1.
Defined.

Global Instance Injective_Roption_Some_None a
: Injective (Roption (Some a) None).
refine {| result := False |}.
inversion 1.
Defined.

Global Instance Injective_Roption_Some_Some a b
: Injective (Roption (Some a) (Some b)).
refine {| result := R a b |}.
inversion 1. auto.
Defined.

Global Instance Injective_Proper_Roption_Some x
: Injective (Proper Roption (Some x)).
refine {| result := R x x |}.
abstract (inversion 1; assumption).
Defined.

End relation.

Section type.
Variable T : Type.
Variable tT : type T.

Global Instance type_option : type (option T) :=
{ equal := Roption equal
; proper := fun x => match x with
| None => True
| Some y => proper y
end }.

Variable tTOk : typeOk tT.

Global Instance typeOk_option : typeOk type_option.
Proof. hammer_hook "Option" "Option.typeOk_option".
constructor.
{ inversion 1.
split; constructor.
split; simpl; eapply only_proper; eauto. symmetry; eauto. }
{ red. destruct x; simpl. constructor.
eapply preflexive; [ | eapply H ].
eapply equiv_prefl; auto. constructor. }
{ red. destruct 1. constructor. constructor. symmetry. assumption. }
{ red. destruct 1; inversion 1; subst. assumption.
constructor. etransitivity; eauto. }
Qed.

Global Instance proper_Some : proper (@Some T).
Proof. hammer_hook "Option" "Option.proper_Some". constructor; assumption. Qed.

Global Instance proper_None : proper (@None T).
Proof. hammer_hook "Option" "Option.proper_None". constructor. Qed.

End type.

Global Instance Injective_Some (T : Type) (a b : T) : Injective (Some a = Some b) :=
{ result := a = b
; injection :=
fun P : Some a = Some b =>
match P with
| eq_refl => eq_refl
end
}.

Require ExtLib.Core.EquivDec.

Global Instance EqDec_option (T : Type) (EDT : EquivDec.EqDec T (@eq T)) : EquivDec.EqDec (option T) (@eq _).
Proof. hammer_hook "Option" "Option.EqDec_option".
red. unfold Equivalence.equiv, RelationClasses.complement. intros.
change (x = y -> False) with (x <> y).
decide equality. apply EDT.
Qed.

Section OptionEq.
Variable T : Type.
Variable EDT : RelDec (@eq T).

Global Instance RelDec_eq_option : RelDec (@eq (option T)) :=
{ rel_dec := fun x y =>
match x , y with
| None , None => true
| Some x , Some y => eq_dec x y
| _ , _ => false
end }.

Variable EDCT : RelDec_Correct EDT.

Global Instance RelDec_Correct_eq_option : RelDec_Correct RelDec_eq_option.
Proof. hammer_hook "Option" "Option.RelDec_Correct_eq_option".
constructor; destruct x; destruct y; split; simpl in *; intros; try congruence;
f_equal; try match goal with
| [ H : context [ eq_dec ?X ?Y ] |- _ ] =>
consider (eq_dec X Y)
| [ |- context [ eq_dec ?X ?Y ] ] =>
consider (eq_dec X Y)
end; auto; congruence.
Qed.

End OptionEq.

Lemma eq_option_eq
: forall T (a b : T) (pf : a = b) (F : _ -> Type) val,
match pf in _ = x return option (F x) with
| eq_refl => val
end = match val with
| None => None
| Some val => Some match pf in _ = x return F x with
| eq_refl => val
end
end.
Proof. hammer_hook "Option" "Option.eq_option_eq".
destruct pf. destruct val; reflexivity.
Defined.

Hint Rewrite eq_option_eq : eq_rw.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal11.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons (Succ (Succ Zero)) (Cons Zero Nil)).
Definition lfind_example_2  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_3  := ( Cons (Succ Zero)         (Cons Zero            (Cons Zero (Cons (Succ (Succ (Succ (Succ (Succ Zero))))) Nil)))).
Definition lfind_example_4  := ( Cons Zero (Cons Zero (Cons (Succ Zero) (Cons Zero Nil)))).
Definition lfind_example_5  := ( Cons Zero Nil).
Definition lfind_example_6  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_7  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_8  := ( Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_9  := ( Cons Zero (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_10  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_11  := ( Cons (Succ Zero)         (Cons (Succ Zero)            (Cons (Succ (Succ (Succ (Succ Zero))))               (Cons (Succ (Succ (Succ (Succ Zero)))) Nil)))).
Definition lfind_example_12  := ( Cons Zero (Cons (Succ (Succ (Succ (Succ (Succ Zero))))) Nil)).
Definition lfind_example_13  := ( Cons (Succ Zero) Nil).
Definition lfind_example_14  := ( Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal11_theorem0_57_lem3/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 .


Set Universe Polymorphism.
Set Printing Universes.
(* Unset Strict Universe Declaration. *)

(* universe binders on inductive types and record projections *)
Inductive Empty@{u} : Type@{u} := .
Print Empty.

Set Primitive Projections.
Record PWrap@{u} (A:Type@{u}) := pwrap { punwrap : A }.
Print PWrap.
Print punwrap.

Unset Primitive Projections.
Record RWrap@{u} (A:Type@{u}) := rwrap { runwrap : A }.
Print RWrap.
Print runwrap.

(* universe binders also go on the constants for operational typeclasses. *)
Class Wrap@{u} (A:Type@{u}) := wrap : A.
Print Wrap.
Print wrap.

(* Instance in lemma mode used to ignore the binders. *)
Instance bar@{u} : Wrap@{u} Set. Proof. exact nat. Qed.
Print bar.

Unset Strict Universe Declaration.
(* The universes in the binder come first, then the extra universes in
   order of appearance. *)
Definition foo@{u +} := Type -> Type@{v} -> Type@{u}.
Print foo.

Check Type@{i} -> Type@{j}.

Eval cbv in Type@{i} -> Type@{j}.

Set Strict Universe Declaration.

(* Binders even work with monomorphic definitions! *)
Monomorphic Definition mono@{u} := Type@{u}.
Print mono.
Check mono.
Check Type@{mono.u}.

Module mono.
  Fail Monomorphic Universe u.
  Monomorphic Universe MONOU.

  Monomorphic Definition monomono := Type@{MONOU}.
  Check monomono.

  Monomorphic Inductive monoind@{i} : Type@{i} := .
  Monomorphic Record monorecord@{i} : Type@{i} := mkmonorecord {}.
End mono.
Check mono.monomono. (* qualified MONOU *)
Import mono.
Check monomono. (* unqualified MONOU *)
Check mono. (* still qualified mono.u *)

Monomorphic Constraint Set < Top.mono.u.

Module mono2.
  Monomorphic Universe u.
End mono2.

Fail Monomorphic Definition mono2@{u} := Type@{u}.

Module SecLet.
  Unset Universe Polymorphism.
  Section foo.
    (* Fail Let foo@{} := Type@{u}. (* doesn't parse: Let foo@{...} doesn't exist *) *)
    Unset Strict Universe Declaration.
    Let tt : Type@{u} := Type@{v}. (* names disappear in the ether *)
    Let ff : Type@{u}. Proof. exact Type@{v}. Qed. (* if Set Universe Polymorphism: universes are named ff.u and ff.v. Otherwise names disappear into space *)
    Definition bobmorane := tt -> ff.
  End foo.
  Print bobmorane. (*
                     bobmorane@{Top.15 Top.16 ff.u ff.v} =
                     let tt := Type@{Top.16} in let ff := Type@{ff.v} in tt -> ff
                     : Type@{max(Top.15,ff.u)}
                     (* Top.15 Top.16 ff.u ff.v |= Top.16 < Top.15
                     ff.v < ff.u
                    *)

                    bobmorane is universe polymorphic
                    *)
End SecLet.

(* fun x x => foo is nonsense with local binders *)
Fail Definition fo@{u u} := Type@{u}.

(* Using local binders for printing. *)
Print foo@{E M N}.
(* Underscores discard the name if there's one. *)
Print foo@{_ _ _}.

(* Also works for inductives and records. *)
Print Empty@{E}.
Print PWrap@{E}.

(* Also works for About. *)
About punwrap@{K}.

(* Instance length check. *)
Fail Print foo@{E}.
Fail Print mono@{E}.

(* Not everything can be printed with custom universe names. *)
Fail Print Coq.Init.Logic@{E}.

(* Nice error when constraints are impossible. *)
Monomorphic Universes gU gV. Monomorphic Constraint gU < gV.
Fail Lemma foo@{u v|u < gU, gV < v, v < u} : nat.

(* Universe binders survive through compilation, sections and modules. *)
Require TestSuite.bind_univs.
Print bind_univs.mono.
Print bind_univs.poly.

Section SomeSec.
  Universe u.
  Definition insec@{v} := Type@{u} -> Type@{v}.
  Print insec.
End SomeSec.
Print insec.

Module SomeMod.
  Definition inmod@{u} := Type@{u}.
  Print inmod.
End SomeMod.
Print SomeMod.inmod.
Import SomeMod.
Print inmod.

Module Type SomeTyp. Definition inmod := Type. End SomeTyp.
Module SomeFunct (In : SomeTyp).
  Definition infunct@{u v} := In.inmod@{u} -> Type@{v}.
End SomeFunct.
Module Applied := SomeFunct(SomeMod).
Print Applied.infunct.

(* Multi-axiom declaration

   In polymorphic mode the domain Type gets separate universes for the
   different axioms, but all axioms have to declare all universes. In
   polymorphic mode they get the same universes, ie the type is only
   interpd once. *)
Axiom axfoo@{i+} axbar : Type -> Type@{i}.
Monomorphic Axiom axfoo'@{i+} axbar' : Type -> Type@{i}.

About axfoo. About axbar. About axfoo'. About axbar'.

Fail Axiom failfoo failbar@{i} : Type.


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

(****************************************************************************)
(*                          Signes Project                                  *)
(*                            2002-2003                                     *)
(*                           Houda ANOUN                                    *)
(*                          Pierre Casteran                                 *)
(*                           LaBRI/INRIA                                    *)
(****************************************************************************)

Require Export NaturalDeduction.

(* Some examples *)

Require Import Sequent.

Inductive Atoms : Set :=
  | sn : Atoms
  | n : Atoms
  | s : Atoms.

Definition Ex1 :
  natDed NL_Sequent (OneForm (Dot (Slash (At sn) (At n)) (At n)))
    (At sn).
 eapply DotElim.
 constructor 1.
 constructor 1.
 eapply SlashElim.
 constructor 1.
 constructor 1.
Defined.

Definition Ex2 :
  natDed NL_Sequent
    (OneForm
       (Dot (At sn) (Dot (Slash (Backslash (At sn) (At n)) (At s)) (At s))))
    (At n).
eapply DotElim.
constructor 1.
constructor 1.
eapply DotElim.
constructor 3.
constructor 1.
constructor 1.
eapply BackSlashElim.
constructor 1.
eapply SlashElim; [ idtac | constructor 1 ].
constructor 1.
Defined.


From Coq Require Import
     Morphisms
.

From ITree Require Import
     Axioms
     ITree
     ITreeFacts
     Eq.Rutt
     Props.Infinite
     Props.EuttNoRet.

From ITree.Extra Require Import
     ITrace.ITraceDefinition
     ITrace.ITraceFacts
.

From Paco Require Import paco.

Import Monads.
Import MonadNotation.
#[local] Open Scope monad_scope.

Set Implicit Arguments.

(* Defines and explores a notion of traces being prefixes of other traces *)

Inductive trace_prefixF {E : Type -> Type} {R S : Type} (F : itrace E R -> itrace E S -> Prop) : itrace' E R -> itrace' E S ->  Prop :=
| ret_prefix (r : R) (b : itrace E S) : trace_prefixF F (RetF r) (observe b)
| tau_prefix (br : itrace E R) (bs : itrace E S) : F br bs -> trace_prefixF F (TauF br) (TauF bs)
| tau_r_prefix (br : itrace E R) (obs : itrace' E S) : trace_prefixF F (observe br) obs -> trace_prefixF F (TauF br) obs
| tau_l_prefix (obr : itrace' E R) (bs : itrace E S) : trace_prefixF F (obr) (observe bs) -> trace_prefixF F (obr) (TauF bs)
| tau_vis_empty {A : Type} (e : E A) (H: A -> void) (kr : void -> itrace E R) (ks : void -> itrace E S) :
  trace_prefixF F (VisF (evempty A H e) kr) (VisF (evempty A H e) ks )
| tau_vis_ans {A : Type} (e : E A) (ans : A) (kr : unit -> itrace E R) (ks : unit -> itrace E S) :
  F (kr tt) (ks tt) -> trace_prefixF F (VisF (evans A e ans) kr ) (VisF (evans A e ans) ks)
.

#[global] Hint Constructors trace_prefixF : itree.

Definition trace_prefix_ {E R S} F (br : itrace E R) (bs : itrace E S) := trace_prefixF F (observe br) (observe bs).

#[global] Hint Unfold trace_prefix_ : itree.

Lemma trace_prefix_monot {E R S} : monotone2 (@trace_prefix_ E R S).
Proof.
  repeat intro. red. red in IN. induction IN; eauto with itree.
Qed.

#[global] Hint Resolve trace_prefix_monot : paco.

Definition trace_prefix {E R S} : itrace E R -> itrace E S -> Prop := paco2 trace_prefix_ bot2.

Lemma prefix_vis : forall E R S A (e : E A) (ans : A) (k : unit -> itrace E R) (t : itrace E S),
    trace_prefix (Vis (evans _ e ans) k ) t -> exists k', (t ≈ Vis (evans _ e ans) k' )%itree.
Proof.
  intros E R S A e ans k t Hbp. punfold Hbp. red in Hbp. cbn in *.
  dependent induction Hbp.
  - apply simpobs in x. enough (exists k', bs ≈ (Vis (evans A e ans) k' ))%itree.
    + destruct H as [k' Hk']. exists k'. rewrite x. rewrite tau_eutt. auto.
    + eapply IHHbp; eauto.
  - exists ks. apply simpobs in x. rewrite x. reflexivity.
Qed.

Lemma trace_prefix_ret : forall E R S F (ob : itrace' E S) (r : R), trace_prefixF F (RetF r) ob.
Proof.
  intros. remember (go ob) as b. assert (observe b = ob).
  { subst. auto. }
  rewrite <- H. auto with itree.
Qed.

Lemma trace_prefix_proper_aux_vis: forall (E : Type -> Type) (S R : Type)
                                     (t1 : itree (EvAns E) R) (b2 : itrace E R),
    eqitF eq true true id
          (upaco2 (eqit_ eq true true id) bot2)
          (observe t1) (observe b2) ->
    forall (r : itrace E R -> itrace E S -> Prop)
      (X : Type) (e : EvAns E X)
      (k : X -> itree (EvAns E) S),
      trace_prefixF (upaco2 trace_prefix_ bot2)
                    (observe t1) (VisF e k) ->
      (forall (b1 b2 : itrace E R)
         (b : itrace E S),
          (b1 ≈ b2) ->
          trace_prefix b1 b -> r b2 b) ->
      trace_prefixF (upaco2 trace_prefix_ r)
                    (observe b2) (VisF e k).
Proof.
  intros E S R t1 b2 Heutt r X e k H0 CIH.
  dependent induction H0.
  - rewrite <- x0 in Heutt. dependent induction Heutt.
    + rewrite <- x. apply trace_prefix_ret.
    + rewrite <- x. constructor. eapply IHHeutt; eauto.
  - eapply IHtrace_prefixF; auto.
    apply simpobs in x. assert (t1 ≈ b2); auto with itree.
    rewrite x in H. rewrite tau_eutt in H. punfold H.
  - rewrite <- x in Heutt. dependent induction Heutt.
    + rewrite <- x. constructor.
    + rewrite <- x. constructor. eapply IHHeutt; eauto.
  - pclearbot. rewrite <- x in Heutt. dependent induction Heutt.
    + rewrite <- x. constructor. right. pclearbot. eapply CIH; eauto with itree.
    + rewrite <- x. constructor. eapply IHHeutt; eauto.
Qed.

Lemma trace_prefix_tau_inv:
  forall (E : Type -> Type) (S R : Type)
    (m1 : itree (EvAns E) R) (t : itree (EvAns E) S),
    trace_prefixF (upaco2 trace_prefix_ bot2)
                  (TauF m1) (TauF t) -> trace_prefix m1 t.
Proof.
  intros E S R m1 t Hbp.
  dependent induction  Hbp.
  - pclearbot. auto.
  - pfold. red. clear IHHbp. dependent induction Hbp.
    + rewrite <- x0. auto with itree.
    + rewrite <- x. constructor. pclearbot. punfold H.
    + rewrite <- x. constructor. eapply IHHbp; eauto.
    + auto.
  - pfold. red. clear IHHbp. dependent induction Hbp.
    + rewrite <- x. constructor. pclearbot. punfold H.
    + auto.
    + rewrite <- x. constructor. eapply IHHbp; eauto.
Qed.

Lemma trace_prefix_proper_l : forall E R S (b1 b2 : itrace E R) (b : itrace E S),
    (b1 ≈ b2) -> trace_prefix b1 b -> trace_prefix b2 b.
Proof.
  intros E R S. pcofix CIH. intros b1 b2 b Heutt Hbp.
  pfold. red. punfold Heutt. red in Heutt. punfold Hbp. red in Hbp.
  dependent induction Heutt.
  - rewrite <- x. constructor.
  - rewrite <- x. rewrite <- x0 in Hbp. clear x0 x. pclearbot.
    destruct (observe b) eqn : Heqb.
    + inv Hbp. constructor. dependent induction  H0.
      * apply simpobs in x0. assert (m1 ≈ m2); auto.
        rewrite x0 in H. clear x x0 Heqb CIH REL.
        punfold H. red in H. cbn in *. dependent induction H.
        ++ rewrite <- x. apply trace_prefix_ret.
        ++ rewrite <- x. constructor. eapply IHeqitF; eauto.
      * eapply IHtrace_prefixF; auto.
        apply simpobs in x. assert (m1 ≈ m2); auto.
        rewrite x in H. rewrite tau_eutt in H. auto.
    + constructor. right. eapply CIH; eauto. eapply trace_prefix_tau_inv; eauto.
    + constructor. clear Heqb. inv Hbp. dependent induction H0.
      * apply simpobs in x0. assert (m1 ≈ m2); auto.
        rewrite x0 in H. punfold H. red in H. cbn in *.
        dependent induction H.
        ++ rewrite <- x. apply trace_prefix_ret.
        ++ rewrite <- x. constructor. eapply IHeqitF; eauto.
           assert (m1 ≈ m2); auto.
           apply simpobs in x. rewrite x in H0. rewrite tau_eutt in H0. auto.
      * eapply IHtrace_prefixF; auto.
        assert (m1 ≈ m2); auto. apply simpobs in x.
        rewrite x in H. rewrite tau_eutt in H. auto.
      * assert (m1 ≈ m2); auto. apply simpobs in x.
        rewrite x in H0.
        punfold H0. red in H0. cbn in *.
        dependent induction H0.
        ++ rewrite <- x. constructor.
        ++ rewrite <- x. constructor. eapply IHeqitF; eauto.
           assert (m1 ≈ m2); auto.
           apply simpobs in x. rewrite x in H1. rewrite tau_eutt in H1. auto.
      * pclearbot. apply simpobs in x. assert (m1 ≈ m2); auto.
        rewrite x in H0. punfold H0. red in H0. cbn in *.
        dependent induction H0.
        ++ rewrite <- x. constructor. right. pclearbot. eapply CIH; eauto with itree.
        ++ rewrite <- x. constructor. eapply IHeqitF; eauto.
           assert (m1 ≈ m2); auto.
           apply simpobs in x. rewrite x in H1. rewrite tau_eutt in H1. auto.
  - rewrite <- x. rewrite <- x0 in Hbp. clear x x0. pclearbot.
    dependent induction Hbp.
    + rewrite <- x. constructor. eapply IHHbp; eauto.
    + rewrite <- x. constructor.
    + rewrite <- x. pclearbot. constructor. right. eapply CIH; eauto with itree.
  - rewrite <- x in Hbp.
    destruct (observe b) eqn : Heqb.
    + clear IHHeutt. inv Hbp. clear Heqb x.
      dependent induction H0.
      * rewrite <- x0 in Heutt. clear CIH x0 x.
        dependent induction  Heutt.
        ++ rewrite <- x. apply trace_prefix_ret.
        ++ rewrite <- x. constructor. eapply IHHeutt; eauto.
      * eapply IHtrace_prefixF; auto.
        assert (t1 ≈ b2); auto with itree.
        apply simpobs in x. rewrite x in H. rewrite tau_eutt in H. punfold H.
    + constructor. eapply IHHeutt; eauto. pstep_reverse. eapply trace_prefix_tau_inv; eauto.
    + clear IHHeutt. inv Hbp. eapply trace_prefix_proper_aux_vis; eauto.
  - rewrite <- x. constructor. eapply IHHeutt; eauto.
Qed.

Lemma trace_prefixF_tau_inv_r:
  forall (E : Type -> Type) (S R : Type)
         (t1 : itree (EvAns E) S) (b : itrace E R),
    trace_prefixF (upaco2 trace_prefix_ bot2)
                  (observe b) (TauF t1) ->
    trace_prefixF (upaco2 trace_prefix_ bot2)
                  (observe b) (observe t1).
Proof.
  intros E S R t1 b Hbp.
  dependent induction  Hbp.
  - rewrite <- x0. apply trace_prefix_ret.
  - pclearbot. rewrite <- x. constructor. punfold H.
  - rewrite <- x. constructor. eapply IHHbp; eauto.
  - auto.
Qed.

Lemma trace_prefixF_vis_l:
  forall (E : Type -> Type) (S R : Type)
         (m1 m2 : itree (EvAns E) S),
    paco2 (eqit_ eq true true id) bot2 m1 m2 ->
    forall (r : itrace E R -> itrace E S -> Prop)
           (X : Type) (e : EvAns E X)
           (k : X -> itree (EvAns E) R),
      trace_prefixF (upaco2 trace_prefix_ bot2)
                    (VisF e k) (observe m1) ->
      (forall (b : itrace E R)
              (b1 b2 : itrace E S),
          (b1 ≈ b2) ->
          trace_prefix b b1 -> r b b2 ) ->
      trace_prefixF (upaco2 trace_prefix_ r)
                    (VisF e k) (observe m2).
Proof.
  intros E S R m1 m2 REL r X e k H1 CIH.
  punfold REL. red in REL.
  dependent induction H1.
  - eapply IHtrace_prefixF; auto. rewrite <- x in REL.
    assert (Tau bs ≈ m2).
    { pfold. auto. }
    rewrite tau_eutt in H. punfold H.
  - rewrite <- x in REL. dependent induction REL.
    + rewrite <- x. constructor.
    + rewrite <- x. constructor. eapply IHREL; eauto.
  - pclearbot. rewrite <- x in REL. dependent induction REL.
    + rewrite <- x. constructor. right. pclearbot. eapply CIH; eauto with itree.
    + rewrite <- x. constructor. eapply IHREL; eauto.
Qed.

Lemma trace_prefix_proper_r : forall E R S (b : itrace E R) (b1 b2 : itrace E S),
    (b1 ≈ b2) -> trace_prefix b b1 -> trace_prefix b b2.
Proof.
  intros E R S. pcofix CIH. intros b b1 b2 Heutt Hbp.
  punfold Heutt. red in Heutt. punfold Hbp. red in Hbp.
  pfold. red. dependent induction Heutt.
  - rewrite <- x. rewrite <- x0 in Hbp. clear x0 x. induction Hbp; auto with itree.
    + pclearbot. constructor. right. eapply CIH; eauto. reflexivity.
    + constructor. pclearbot. left. eapply paco2_mon; eauto. intuition.
  - pclearbot. rewrite <- x0 in Hbp. rewrite <- x. clear x0 x.
    destruct (observe b).
    + apply trace_prefix_ret.
    + constructor. right. pclearbot. eapply CIH; eauto. apply trace_prefix_tau_inv. auto.
    + inv Hbp. constructor. eapply trace_prefixF_vis_l; eauto.
  - rewrite <- x. rewrite <- x0 in Hbp. pclearbot. clear x x0. dependent induction Hbp.
    + rewrite <- x0. apply trace_prefix_ret.
    + rewrite <- x. constructor. eapply IHHbp; eauto.
    + rewrite <- x. constructor.
    + rewrite <- x. constructor. right. pclearbot. eapply CIH; eauto with itree.
  - eapply IHHeutt; auto. rewrite <- x in Hbp. eapply trace_prefixF_tau_inv_r; eauto.
  - rewrite <- x. constructor. eapply IHHeutt; eauto.
Qed.

#[global] Instance trace_prefix_proper {E R S} : Proper (eutt eq ==> eutt eq ==> iff) (@trace_prefix E R S).
Proof.
  repeat intro. split; intros.
  - eapply trace_prefix_proper_l; eauto.
    eapply trace_prefix_proper_r; eauto.
  - symmetry in H. symmetry in H0.
    eapply trace_prefix_proper_l; eauto.
    eapply trace_prefix_proper_r; eauto.
Qed.

Inductive ind_comb {E R S} : itrace E R -> itrace E S -> itrace E S -> Prop :=
| left_ret_comb (r : R) b1 b2 b : (b1 ≈ Ret r)%itree -> (b2 ≈ b)%itree -> ind_comb b1 b2 b
| left_vis_comb {A : Type} (e : E A) (ans : A) (k1 : unit -> itrace E R) (k2 : unit -> itrace E S) b1 b2 b
  : (b1 ≈ Vis (evans _ e ans) k1) -> (b ≈ (Vis (evans _ e ans) k2 ))%itree -> ind_comb (k1 tt) b2 (k2 tt) ->
    ind_comb b1 b2 b.

Lemma ind_comb_bind : forall E R S (b1 : itrace E R) (b2 : itrace E S) (b : itrace E S),
    ind_comb b1 b2 b -> (ITree.bind b1 (fun x => b2) ≈ b)%itree.
Proof.
  intros E R S b1 b2 b Hind. induction Hind.
  - rewrite H. rewrite bind_ret_l. auto.
  - rewrite H. rewrite H0. rewrite bind_vis. pfold. red. constructor. intros.
    left. destruct v. apply IHHind.
Qed.

Inductive trace_prefix_ind {E R S} : itrace E R -> itrace E S -> Prop :=
| left_ret_bp (r : R) b1 b2 : (b1 ≈ Ret r)%itree -> trace_prefix_ind b1 b2
| left_vis_bp {A : Type} (e : E A) (ans : A) (k1 : unit -> itrace E R) (k2 : unit -> itrace E S) b1 b2 :
  (b1 ≈ Vis (evans _ e ans) k1)%itree -> (b2 ≈ Vis (evans _ e ans) k2 )%itree -> trace_prefix_ind (k1 tt) (k2 tt) ->
  trace_prefix_ind b1 b2
.

Lemma trace_prefix_ind_comb : forall E R S (b1 : itrace E R) (b2 : itrace E S),
    trace_prefix_ind b1 b2 ->
    exists b3, ind_comb b1 b3 b2.
Proof.
  intros E R S b1 b2 Hpre. induction Hpre.
  - exists b2. econstructor; eauto. reflexivity.
  - destruct IHHpre as [b3 Hb3].
    exists b3. eapply left_vis_comb; eauto.
Qed.

Lemma trace_prefix_ind_bind : forall E R S (b1 : itrace E R) (b2 : itrace E S),
    trace_prefix_ind b1 b2 ->
    exists g, (ITree.bind b1 g ≈ b2)%itree.
Proof.
  intros. apply trace_prefix_ind_comb in H. destruct H as [b3 Hb3].
  apply ind_comb_bind in Hb3. exists (fun _ => b3). auto.
Qed.

Lemma converge_trace_prefix : forall E R S (b1 : itrace E R) (b2 : itrace E S) (r : R),
    trace_prefix b1 b2 -> may_converge r b1 -> trace_prefix_ind b1 b2.
Proof.
  intros E R S b1 b2 r Hbp Hconv. generalize dependent b2. induction Hconv; intros.
  - eapply left_ret_bp; eauto.
  - rewrite H in Hbp. destruct e; try contradiction.
    apply prefix_vis in Hbp as Hb2.
    destruct Hb2 as [k' Hk']. rewrite Hk' in Hbp.
    eapply left_vis_bp; eauto. destruct b. apply IHHconv.
    punfold Hbp. red in Hbp. cbn in *. inversion Hbp. subst; ddestruction; subst.
    pclearbot. auto.
Qed.

Lemma trace_prefix_div : forall E R S (b1 : itrace E R) (b2 : itrace E S),
    all_infinite b1 -> trace_prefix b1 b2 -> euttNoRet b1 b2.
Proof.
  intros E R S. pcofix CIH. intros b1 b2 Hdiv Hbf. pfold. red.
  punfold Hbf. red in Hbf. punfold Hdiv. red in Hdiv. induction Hbf.
  - inv Hdiv.
  - constructor. inv Hdiv. pclearbot. right. apply CIH; auto.
  - constructor; auto. apply IHHbf. pstep_reverse. inv Hdiv. pclearbot. auto.
  - constructor; auto.
  - constructor. intuition.
  - pclearbot. constructor. intros. right. pclearbot. inv Hdiv. ddestruction; subst.
    pclearbot. destruct v. apply CIH; auto. apply H1.
Qed.

Lemma trace_prefix_bind : forall E R S (b1 : itrace E R) (b2 : itrace E S),
    trace_prefix b1 b2 -> exists g, (ITree.bind b1 g ≈ b2).
Proof.
  intros. destruct (classic_converge b1).
  - destruct H0 as [r Hconv]. eapply converge_trace_prefix in Hconv; eauto.
    apply trace_prefix_ind_bind. auto.
  - eapply trace_prefix_div in H0 as Heuttdiv; eauto.
    exists (fun _ => ITree.spin). apply euttNoRet_subrel. apply euttNoRet_sym.
    eapply noret_bind_nop with (f := (fun _ => ITree.spin) ) in H0 as H1.
    eapply euttNoRet_trans; try apply H1. apply euttNoRet_sym. auto.
Qed.


Require Import Quote List Ergo Containers.OrderedType.
Require Import BinPos LLazy Semantics.
Require Import Containers.Sets.
Require TermUtils.

Delimit Scope sem_scope with sem.
Open Scope sem_scope.

Module SEMLAZY <: SEM_INTERFACE LLAZY.
  Import LLAZY.
  Definition model := varmaps.

  Definition model_as_fun_l : model -> LITINDEX.t -> Prop :=
    LITINDEX.interp.
  Definition model_as_fun : model -> LLAZY.t -> Prop :=
    LLAZY.interp.
  Coercion model_as_fun : model >-> Funclass.

  Local Notation "M [ l ]" := (model_as_fun M l)(at level 0).

  Property full :
    forall (M : model) (l : LLAZY.t), ~~(~(M[l]) -> M[LLAZY.mk_not l]).
  Proof.
    intros; simpl.
    generalize (LLAZY.mk_not_interp M l).
    tauto.
  Qed.
  Property consistent : forall (M : model) l, M[l] -> ~(M[LLAZY.mk_not l]).
  Proof.
    intros; simpl.
    generalize (LLAZY.mk_not_interp M l).
    tauto.
  Qed.
  Property morphism : forall (M : model) l l', l === l' -> (M[l] <-> M[l']).
  Proof.
    intros M l l' H; destruct l; destruct l'; simpl in *.
    change (this0 = this1) in H.
    unfold model_as_fun, interp; simpl.
    subst; reflexivity.
  Qed.
  Property wf_true : forall (M : model), M[LLAZY.ltrue].
  Proof.
    intros; exact I.
  Qed.

  Property wf_expand_ : forall (M : model) l, RAW.interp M l ->
    (forall c, List.In c (RAW.expand l) -> exists l',
      List.In l' c /\ RAW.interp M l').
  Proof.
    intros M l; pattern l.
    apply RAW.literal_ind2 with
      (Pl := fun c =>  l_interp (RAW.interp M) c ->
        exists l', List.In l' c /\ RAW.interp M l')
      (Pp := fun p => ll_interp (RAW.interp M) p ->
        forall c, List.In c p ->
          exists l', List.In l' c /\ RAW.interp M l'); intros; simpl in *.
    contradiction.
    auto.
    contradiction.
    destruct H1; subst.
    exists a; tauto.
    destruct (H0 H1) as [l' Hl']; exists l'; intuition.
    contradiction.
    destruct H2; subst.
    tauto.
    exact (H0 (proj2 H1) c H2).
  Qed.
  Property wf_expand_lift : forall M L EL,
    eqlistA (eqlistA RAW.eq) (map (map this) L) EL ->
    (forall c, List.In c EL -> exists l', List.In l' c /\ RAW.interp M l') ->
    (forall c, List.In c L -> exists l', List.In l' c /\ M[l']).
  Proof.
    intro M; induction L; intros; inversion_clear H1.
    destruct EL; inversion_clear H; clear H3 IHL; subst.
    assert (Hl := H0 l (or_introl _ (refl_equal _))); clear EL H0 L.
    revert c H1 Hl; induction l; intros; destruct c; inversion_clear H1.
    destruct Hl as [? [abs _]]; contradiction abs.
    destruct Hl as [l' [Hl' HMl]].
    destruct Hl'; subst.
    exists t0; split; [left; auto|].
    unfold model_as_fun, interp; simpl; rewrite H; assumption.
    destruct (IHl c H0) as [l'' Hl''].
    exists l'; split; assumption.
    exists l''; split; intuition.
    destruct EL; inversion_clear H.
    refine (IHL EL H3 _ c H2).
    intros; apply H0; right; auto.
  Qed.
  Corollary wf_expand : forall (M : model) l, M[l] ->
    (forall c, List.In c (expand l) -> exists l', List.In l' c /\ M[l']).
  Proof.
    intros M [l wfl] Hl c Hexp.
    assert (Hexp_map := expand_map_map (mk_literal l wfl)).
    set (L := expand (mk_literal l wfl)) in *; clearbody  L.
    refine (wf_expand_lift _ _ _ Hexp_map _ _ Hexp).
    exact (wf_expand_ _ _ Hl).
  Qed.

(*   Section Creation. *)
(*     Parameter model_of :  *)
(*       forall (m : LLAZY.t -> Prop) *)
(*         (Hfull : forall l, ~~(~(m l) -> m (LLAZY.mk_not l))) *)
(*         (Hconsistent : forall l, m l -> ~(m (LLAZY.mk_not l))) *)
(*         (Hmorphism : forall l l', l === l' -> (m l <-> m l')) *)
(*         (Htrue : m ltrue) *)
(*         (Hexpand : forall l, m l ->  *)
(*           (forall c, List.In c (expand l) ->  *)
(*             exists l', List.In l' c /\ m l')), model. *)

(*     Axiom model_as_model_of :  *)
(*       forall m Hfull Hconsistent Hmorphism Htrue Hexpand l, *)
(*         model_as_fun  *)
(*         (model_of m Hfull Hconsistent Hmorphism Htrue Hexpand) l = m l. *)
(*   End Creation. *)

  Definition sat_clause (M : model) (C : clause) :=
    exists l, M[l] /\ l \In C.

  Definition sat_goal (M : model) (D : cset) :=
    forall C, C \In D -> sat_clause M C.

  Definition submodel (G : lset) (M : model) :=
    forall l, l \In G -> M[l].

  Definition incompatible (G : lset) (D : cset) :=
    forall (M : model), submodel G M -> ~sat_goal M D.

  Definition sat_clause_p (M : lset) (C : clause) :=
    exists l, l \In M /\ l \In C.

  Definition sat_goal_p (M : lset) (D : cset) :=
    forall C, C \In D -> sat_clause_p M C.

  (** Extra definitions and facts about equalities, only for SEMLAZY *)
  Import TermUtils.
  Definition equation (a b : term) : LLAZY.t :=
    LLAZY.mk_literal (LLAZY.RAW.Lit (Some (LITINDEX.Equation a b), true))
    (LLAZY.wf_lit_lit _).
  Definition disequation (a b : term) : LLAZY.t :=
    LLAZY.mk_literal (LLAZY.RAW.Lit (Some (LITINDEX.Equation a b), false))
    (LLAZY.wf_lit_lit _).

  (** [M] models a = b if [M (a = b)] *)
  Definition models_eq (M : model) (a b : term) := M (equation a b).
  Definition models_neq (M : model) (a b : term) := M (disequation a b).
  Notation "M |= a = b" := (models_eq M a b)
    (at level 25, a at next level) : sem_scope.
  Notation "M |= a <> b" := (models_neq M a b)
    (at level 25, a at next level) : sem_scope.

  (** This notion of truth for (dis)equalities has the intended properties *)
  Notation "t :> M" := (
    has_type (varmaps_vty M) (varmaps_vsy M) t
    (type_of (varmaps_vty M) (varmaps_vsy M) t) = true)(at level 0).
  Property models_eq_iff : forall M a b, a :> M -> b :> M ->
    (M |= a = b <-> eq (varmaps_vty M) (varmaps_vsy M) a b).
  Proof.
    intros.
    exact (ModelsRingExt.eq_wt_iff M a b H H0).
  Qed.
  Property models_neq_iff : forall M a b, a :> M -> b :> M ->
    (M |= a <> b <-> (~eq (varmaps_vty M) (varmaps_vsy M) a b)).
  Proof.
    intros.
    rewrite <- (ModelsRingExt.eq_wt_iff M a b H H0); reflexivity.
  Qed.

  Property models_eq_refl : forall M a, M |= a = a.
  Proof. exact ModelsRingExt.eq_refl. Qed.
  Property models_eq_sym : forall M a b, (M |= a = b) -> (M |= b = a).
  Proof.
    intros M a b; exact (ModelsRingExt.eq_sym M b a).
  Qed.
  Property models_eq_trans : forall M a b c,
    M |= a = b -> M |= b = c -> M |= a = c.
  Proof. exact ModelsRingExt.eq_trans. Qed.

  Property models_neq_irrefl : forall M a, ~(M |= a <> a).
  Proof.
    intros; intro abs; exact (abs (models_eq_refl M a)).
  Qed.
  Property models_neq_sym : forall M a b,
    M |= a <> b -> M |= b <> a.
  Proof.
    repeat intro; apply H.
    exact (models_eq_sym M b a H0).
  Qed.

  (** [M] models a list of equations if it is a model of
     every equation in the list *)
  Inductive models_list (M : model) : list (term * term) -> Prop :=
  | models_list_nil : models_list M nil
  | models_list_cons :
    forall l a b, M |= a=b -> models_list M l -> models_list M ((a,b)::l).

  Definition models_list_iff :
    forall M l, models_list M l <->
      (forall e, List.In e l -> M |= (fst e) = (snd e)).
  Proof.
    intro M; induction l; split.
    intros; contradiction.
    intros; constructor.
    intro H; inversion_clear H; intros [u v] Huv;
      inversion_clear Huv; subst; simpl.
    inversion H; subst; auto.
    rewrite IHl in H1; apply (H1 (u, v) H).
    intros; destruct a as [u v]; constructor.
    apply (H (u, v)); left; reflexivity.
    rewrite IHl; intros; apply H; right; auto.
  Qed.
  Corollary models_list_in :
    forall M l u v, models_list M l ->
      List.In (u, v) l -> M |= u = v.
  Proof.
    intros; rewrite models_list_iff in H; apply (H (u, v) H0).
  Qed.

  Property models_eq_congr : forall M f l l',
    list_eq (models_eq M) l l' -> M |= (app f l) = (app f l').
  Proof.
    intros; refine (ModelsRingExt.eq_congr M f l l' _).
    induction H; constructor; auto.
  Qed.

  (** Finally, entailment is defined as usual *)
  Definition entails (E : list (term * term)) (a b : term) :=
    forall M, models_list M E -> M |= a = b.
  Notation "E |- a = b" := (entails E a b)
    (at level 25, a at next level) : sem_scope.
End SEMLAZY.


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

(***
Modulus : 2^256 - 189
Base: 21 + 1/3
***)

Definition curve : CurveParameters :=
  {|
    sz := 12%nat;
    base := 21 + 1/3;
    bitwidth := 32;
    s := 2^256;
    c := [(1, 189)];
    carry_chains := Some [seq 0 (pred 12); [0; 1]]%nat;

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

    goldilocks := None;
    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.


Require Import syntax.
Require Import partial.
Require Import heap.
Require Import classTable.
Require Import sframe.
Require Import reductions.
Require Import typing.
Require Import namesAndTypes.

Import ConcreteEverything.

Section WF_Env.

  Import Coq.Lists.List.

  Definition gamma_env_subset (gamma: Gamma_type) (L: Env_type) :=
    forall x,
      In x (p_Γ.domain gamma) ->
      In x (p_env.domain L).

  Theorem in_dec_equivalence (A: Type) (eq_dec: forall (x y: A),
                                                 {x = y} + {x <> y}
                                      ) :
    forall x l1 l2,
      (@In A x l1 <-> In x l2) <-> (~ In x l1 <-> ~ In x l2).
    intros.
    set (leml1 := in_dec eq_dec x l1).
    set (leml2 := in_dec eq_dec x l2).
    firstorder.
  Defined.

  Theorem subset_preserved gamma L x sigma envVal :
    gamma_env_subset gamma L ->
    gamma_env_subset (p_Γ.updatePartFunc gamma x sigma )
                     (p_env.updatePartFunc L x envVal).
    intros subset x'.
    intro.
    set (lem_gamma := p_Γ.updatedFuncProp gamma x sigma x').
    set (lem_env := p_env.updatedFuncProp L x envVal x').

    elim (v_eq_dec x' x).
    intro; rewrite a in *; clear a.
    set (lem_env_x := (proj1 lem_env) (eq_refl x)).
    set (lem_upd_env := proj1 (p_env.fDomainCompat (p_env.updatePartFunc L x envVal) x)).
    set (in_or_not := in_dec v_eq_dec x (p_env.domain (p_env.updatePartFunc L x envVal))).
    elim in_or_not.
    auto.
    intro.
    set (not_in := lem_upd_env b).
    rewrite not_in in lem_env_x; discriminate.

    (* x != x'
     * Proof structure:
     *    Then x' in dom(Gamma) <--> x' in dom(Gamma[x |-> sigma])
     *         x' in dom(L) <--> x' in dom(L[x |-> envVal])
     *)
    intro x_neq.
    assert (In x' (p_Γ.domain gamma) <-> In x' (p_Γ.domain
                                                      (p_Γ.updatePartFunc gamma x sigma))).
    apply (proj2 (in_dec_equivalence p_Γ.A v_eq_dec x' _ _)).
    set (lem_gamma' := (proj2 lem_gamma) x_neq).
    set (lem_gamma_upd_equiv
         := proj2 (p_Γ.fDomainCompat (p_Γ.updatePartFunc gamma x sigma) x')).
    set (lem_gamma_equiv := proj2 (p_Γ.fDomainCompat gamma x')).
    firstorder.

    assert (In x' (p_env.domain L) <-> In x' (p_env.domain
                                                      (p_env.updatePartFunc L x envVal))).
    apply (proj2 (in_dec_equivalence p_env.A v_eq_dec x' _ _)).
    set (lem_env' := (proj2 lem_env) x_neq).
    set (lem_env_upd_equiv
         := proj2 (p_env.fDomainCompat (p_env.updatePartFunc L x envVal) x')).
    set (lem_env_equiv := proj2 (p_env.fDomainCompat L x')).
    firstorder.
    firstorder.
  Qed.

  Import Coq.Lists.List.

  Variable P: Program.

  Definition subtypeP := subtype P.

  Definition TypeChecksP := TypeChecksTerm P.

  Local Open Scope type_scope.

  Definition WF_Var (H: Heap_type) (Gamma: Gamma_type) (L: Env_type) (x: VarName_type):=
    (p_env.func L x = Some envNull) +
    {C_o : _ &
     match C_o with
       | (C, o) => {witn : _&
                    (p_env.func L x = Some (envRef o)) *
                    (p_Γ.func Gamma x = Some (typt_class C)) *
                    (subtypeP (typt_class (heap_typeof H o witn)) (typt_class C))
                   }
     end} +
    {C_o : _ &
     match C_o with
       | (C, o) => {witn : _ &
                    (p_env.func L x = Some (envBox o)) *
                    (p_Γ.func Gamma x = Some (typt_box C)) *
                    (subtypeP (typt_class (heap_typeof H o witn)) (typt_class C))
                   }
     end}.

  Definition WF_Env H Gamma L :=
    gamma_env_subset Gamma L *
    forall x sigma,
      p_Γ.func Gamma x = Some sigma ->
      WF_Var H Gamma L x.

  Inductive WF_Frame : Heap_type -> ann_frame_type -> typecheck_type -> Type :=
  | t_frame1 : forall H Gamma eff t L ann sigma,
                 TypeChecksP Gamma eff t sigma ->
                WF_Env H Gamma L ->
                WF_Frame H (ann_frame (sframe L t) ann) sigma.

  Inductive WF_Frame_ann : Heap_type -> ann_frame_type -> typecheck_type -> VarName_type ->
                           typecheck_type -> Type :=
  | t_frame2 : forall H Gamma eff t L ann sigma x tau,
                 TypeChecksP (p_Γ.updatePartFunc Gamma x tau) eff t sigma ->
                 WF_Env H Gamma L ->
                 WF_Frame_ann H (ann_frame (sframe L t) ann) sigma x tau.

  Notation "( H , x , tau ## F @@ sigma )" := (WF_Frame_ann H F sigma x tau).

  Definition FS_ann_type := option (VarName_type * typecheck_type).

  Inductive WF_FS : FS_ann_type -> Heap_type -> list (ann_frame_type) -> Type :=

  | T_EmpFS : forall H, WF_FS None H nil

  | T_FS_NA : forall H F FS sigma,
                WF_Frame H (ann_frame F ann_epsilon) sigma ->
                WF_FS None H FS ->
                WF_FS None H ((ann_frame F ann_epsilon) :: FS)

  | T_FS_NA2 : forall H F FS sigma x tau,
                 ( H , x , tau ## (ann_frame F ann_epsilon) @@ sigma ) ->
                 WF_FS None H FS ->
                 WF_FS (Some (x, tau)) H ((ann_frame F ann_epsilon) :: FS)

  | T_FS_A : forall H F FS x tau ,
                WF_Frame H (ann_frame F (ann_var x)) tau ->
                WF_FS (Some (x, tau)) H FS ->
                WF_FS None H ((ann_frame F (ann_var x)) :: FS)

  | T_FS_A2 : forall H F FS y sigma x tau,
                ( H, y, sigma ## (ann_frame F (ann_var x)) @@ tau) ->
                WF_FS (Some (x, tau)) H FS ->
                WF_FS (Some (y, sigma)) H ((ann_frame F (ann_var x)) :: FS).

  (* Notation "[ ! H , x , tau ## FS ]" := (WF_FS (Some (x, tau)) H FS) (at level 0). *)
  (* Notation "[ ! H ## FS ]" := (WF_FS None H FS) (at level 0). *)

End WF_Env.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e226m5_4limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


(** * A Fancy Machine with 256-bit registers *)
Require Import Coq.ZArith.ZArith Coq.Lists.List.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Reflection.Named.Syntax.
Require Import Crypto.Reflection.Named.DeadCodeElimination.
Require Import Crypto.Reflection.CountLets.
Require Import Crypto.Reflection.Named.ContextOn.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Util.Tuple.

Local Open Scope type_scope.
Local Open Scope Z_scope.

Class decoder (n : Z) W :=
  { decode : W -> Z }.
Coercion decode : decoder >-> Funclass.
Global Arguments decode {n W _} _.

Class is_decode {n W} (decode : decoder n W) :=
  decode_range : forall x, 0 <= decode x < 2^n.

Class bounded_in_range_cls (x y z : Z) := is_bounded_in_range : x <= y < z.
Ltac bounded_solver_tac :=
  solve [ eassumption | typeclasses eauto | omega ].
Hint Extern 0 (bounded_in_range_cls _ _ _) => unfold bounded_in_range_cls; bounded_solver_tac : typeclass_instances.
Global Arguments bounded_in_range_cls / .
Global Instance decode_range_bound {n W} {decode : decoder n W} {H : is_decode decode}
  : forall x, bounded_in_range_cls 0 (decode x) (2^n)
  := H.

(** This is required for typeclass resolution to be fast. *)
Typeclasses Opaque decode.

Section InstructionGallery.
  Context (n : Z) (* bit-width of width of [W] *)
          {W : Type} (* bounded type, [W] for word *)
          (Wdecoder : decoder n W).
  Local Notation imm := Z (only parsing). (* immediate (compile-time) argument *)

  Class load_immediate := { ldi : imm -> W }.
  Global Coercion ldi : load_immediate >-> Funclass.

  Class shift_right_doubleword_immediate := { shrd : W -> W -> imm -> W }.
  Global Coercion shrd : shift_right_doubleword_immediate >-> Funclass.

  Class shift_left_immediate := { shl : W -> imm -> W }.
  Global Coercion shl : shift_left_immediate >-> Funclass.

  Class shift_right_immediate := { shr : W -> imm -> W }.
  Global Coercion shr : shift_right_immediate >-> Funclass.

  Class spread_left_immediate := { sprl : W -> imm -> tuple W 2 (* [(low, high)] *) }.
  Global Coercion sprl : spread_left_immediate >-> Funclass.

  Class mask_keep_low := { mkl :> W -> imm -> W }.
  Global Coercion mkl : mask_keep_low >-> Funclass.

  Local Notation bit b := (if b then 1 else 0).

  Class add_with_carry := { adc : W -> W -> bool -> bool * W }.
  Global Coercion adc : add_with_carry >-> Funclass.

  Class sub_with_carry := { subc : W -> W -> bool -> bool * W }.
  Global Coercion subc : sub_with_carry >-> Funclass.

  Class multiply := { mul : W -> W -> W }.
  Global Coercion mul : multiply >-> Funclass.

  Class multiply_low_low := { mulhwll : W -> W -> W }.
  Global Coercion mulhwll : multiply_low_low >-> Funclass.
  Class multiply_high_low := { mulhwhl : W -> W -> W }.
  Global Coercion mulhwhl : multiply_high_low >-> Funclass.
  Class multiply_high_high := { mulhwhh : W -> W -> W }.
  Global Coercion mulhwhh : multiply_high_high >-> Funclass.
  Class multiply_double := { muldw : W -> W -> tuple W 2 }.
  Global Coercion muldw : multiply_double >-> Funclass.

  Class select_conditional := { selc : bool -> W -> W -> W }.
  Global Coercion selc : select_conditional >-> Funclass.

  Class add_modulo := { addm : W -> W -> W (* modulus *) -> W }.
  Global Coercion addm : add_modulo >-> Funclass.

End InstructionGallery.

Global Arguments load_immediate : clear implicits.
Global Arguments shift_right_doubleword_immediate : clear implicits.
Global Arguments shift_left_immediate : clear implicits.
Global Arguments shift_right_immediate : clear implicits.
Global Arguments spread_left_immediate : clear implicits.
Global Arguments mask_keep_low : clear implicits.
Global Arguments add_with_carry : clear implicits.
Global Arguments sub_with_carry : clear implicits.
Global Arguments multiply : clear implicits.
Global Arguments multiply_low_low : clear implicits.
Global Arguments multiply_high_low : clear implicits.
Global Arguments multiply_high_high : clear implicits.
Global Arguments multiply_double : clear implicits.
Global Arguments select_conditional : clear implicits.
Global Arguments add_modulo : clear implicits.
Global Arguments ldi {_ _} _.
Global Arguments shrd {_ _} _ _ _.
Global Arguments shl {_ _} _ _.
Global Arguments shr {_ _} _ _.
Global Arguments sprl {_ _} _ _.
Global Arguments mkl {_ _} _ _.
Global Arguments adc {_ _} _ _ _.
Global Arguments subc {_ _} _ _ _.
Global Arguments mul {_ _} _ _.
Global Arguments mulhwll {_ _} _ _.
Global Arguments mulhwhl {_ _} _ _.
Global Arguments mulhwhh {_ _} _ _.
Global Arguments muldw {_ _} _ _.
Global Arguments selc {_ _} _ _ _.
Global Arguments addm {_ _} _ _ _.

Module fancy_machine.
  Local Notation imm := Z (only parsing).

  Class instructions (n : Z) :=
    {
      W : Type (* [n]-bit word *);
      decode :> decoder n W;
      ldi :> load_immediate W;
      shrd :> shift_right_doubleword_immediate W;
      shl :> shift_left_immediate W;
      shr :> shift_right_immediate W;
      mkl :> mask_keep_low W;
      adc :> add_with_carry W;
      subc :> sub_with_carry W;
      mulhwll :> multiply_low_low W;
      mulhwhl :> multiply_high_low W;
      mulhwhh :> multiply_high_high W;
      selc :> select_conditional W;
      addm :> add_modulo W
    }.

End fancy_machine.

Open Scope Z_scope.
Local Notation eta x := (fst x, snd x).
Local Notation eta3 x := (eta (fst x), snd x).
Local Notation eta3' x := (fst x, eta (snd x)).

(** ** Reflective Assembly Syntax *)
Section reflection.
  Context (ops : fancy_machine.instructions (2 * 128)).
  Local Set Boolean Equality Schemes.
  Local Set Decidable Equality Schemes.
  Inductive base_type := TZ | Tbool | TW.
  Global Instance dec_base_type : DecidableRel (@eq base_type)
    := base_type_eq_dec.
  Definition interp_base_type (v : base_type) : Type :=
    match v with
    | TZ => Z
    | Tbool => bool
    | TW => fancy_machine.W
    end.
  Local Notation tZ := (Tbase TZ).
  Local Notation tbool := (Tbase Tbool).
  Local Notation tW := (Tbase TW).
  Local Open Scope ctype_scope.
  Inductive op : flat_type base_type -> flat_type base_type -> Type :=
  | OPldi     : op tZ tW
  | OPshrd    : op (tW * tW * tZ) tW
  | OPshl     : op (tW * tZ) tW
  | OPshr     : op (tW * tZ) tW
  | OPmkl     : op (tW * tZ) tW
  | OPadc     : op (tW * tW * tbool) (tbool * tW)
  | OPsubc    : op (tW * tW * tbool) (tbool * tW)
  | OPmulhwll : op (tW * tW) tW
  | OPmulhwhl : op (tW * tW) tW
  | OPmulhwhh : op (tW * tW) tW
  | OPselc    : op (tbool * tW * tW) tW
  | OPaddm    : op (tW * tW * tW) tW.
End reflection.

(** ** Raw Syntax Trees *)
(** These are used solely for pretty-printing the expression tree in a
    form that can be basically copy-pasted into other languages which
    can be compiled for the Fancy Machine.  Hypothetically, we could
    add support for custom named identifiers, by carrying around
    [string] identifiers and using them for pretty-printing...  It
    might also be possible to verify this layer, too, by adding a
    partial interpretation function... *)

Local Set Decidable Equality Schemes.
Local Set Boolean Equality Schemes.

Inductive Register :=
| RegPInv | RegMod | RegMuLow | RegZero
| y | t1 | t2 | lo | hi | out | src1 | src2 | tmp | q | qHigh | x | xHigh
| scratch | scratchplus (n : nat).

Notation "'scratch+' n" := (scratchplus n) (format "'scratch+' n", at level 10).

Definition pos_of_Register (r : Register) :=
  match r with
  | RegPInv => 1
  | RegMod => 2
  | RegMuLow => 3
  | RegZero => 4
  | y => 5
  | t1 => 6
  | t2 => 7
  | lo => 8
  | hi => 9
  | out => 10
  | src1 => 11
  | src2 => 12
  | tmp => 13
  | q => 14
  | qHigh => 15
  | x => 16
  | xHigh => 17
  | scratch => 18
  | scratchplus n => 18 + Pos.of_nat (S n)
  end%positive.

Global Instance RegisterContext {var : base_type -> Type} : Context Register var
  := ContextOn pos_of_Register (RegisterAssign.pos_context var).

Definition syntax {ops : fancy_machine.instructions (2 * 128)}
  := Named.expr base_type (interp_base_type ops) op Register.

(** Assemble a well-typed easily interpretable expression into a
    syntax tree we can use for pretty-printing. *)
Section assemble.
  Context {ops : fancy_machine.instructions (2 * 128)}.

  Definition AssembleSyntax' {t} (e : Expr base_type (interp_base_type _) op t) (ls : list Register)
    : option (syntax t)
    := CompileAndEliminateDeadCode e ls.
  Definition AssembleSyntax {t} e ls (res := @AssembleSyntax' t e ls)
    := match res return match res with None => _ | _ => _ end with
       | Some v => v
       | None => I
       end.

  Definition dummy_registers (n : nat) : list Register
    := List.map scratchplus (seq 0 n).
  Definition DefaultRegisters {t} (e : Expr base_type (interp_base_type _) op t) : list Register
    := dummy_registers (CountBinders e).

  Definition DefaultAssembleSyntax {t} e := @AssembleSyntax t e (DefaultRegisters e).
End assemble.


Require compcert.common.Smallstep.
Require MemoryX.
Require ValuesX.

Import Coqlib.
Import AST.
Import MemoryX.
Import Events.
Export Smallstep.

(** Language semantics up to memory extension or injection for final states. *)

(** We create those two classes because we need to have two instances of extends and inject, one for values, another for lists of values (for low-level languages where functions may return lists of values encoding int64) *)

Class ValLessdefInjectOps (val: Type): Type :=
  {
    val_lessdef: val -> val -> Prop;
    val_inject:  Values.meminj -> val -> val -> Prop
  }.

Class ValLessdefInject (val: Type) `{val_ops: ValLessdefInjectOps val}: Prop :=
  {
    val_lessdef_refl: forall v, val_lessdef v v;
    val_lessdef_trans: forall v1 v2 v3, val_lessdef v1 v2 -> val_lessdef v2 v3 -> val_lessdef v1 v3;
    val_inject_compose: forall i12 i23 v1 v2 v3, val_inject i12 v1 v2 -> val_inject i23 v2 v3 -> val_inject (Values.compose_meminj i12 i23) v1 v3;
    val_inject_lessdef_compose: forall i12 v1 v2 v3, val_inject i12 v1 v2 -> val_lessdef v2 v3 -> val_inject i12 v1 v3;
    val_lessdef_inject_compose: forall i23 v1 v2 v3, val_lessdef v1 v2 -> val_inject i23 v2 v3 -> val_inject i23 v1 v3
  }.

Instance val_lessdef_inject_val_ops: ValLessdefInjectOps Values.val.
Proof.
  constructor.
  exact Values.Val.lessdef.
  exact Values.val_inject.
Defined.

Instance val_lessdef_inject_val: ValLessdefInject Values.val.
Proof.
  constructor.
  apply Values.Val.lessdef_refl.
  apply Values.Val.lessdef_trans.
  apply Values.val_inject_compose.
  intros; eapply ValuesX.val_inject_lessdef_compose; eauto.
  intros; eapply ValuesX.val_lessdef_inject_compose; eauto.
Qed.

Instance val_lessdef_inject_list_ops: ValLessdefInjectOps (list Values.val).
Proof.
  constructor.
  exact Values.Val.lessdef_list.
  exact Values.val_list_inject.
Defined.

Instance val_lessdef_inject_list: ValLessdefInject (list Values.val).
Proof.
  constructor; simpl.
  induction v; constructor; auto.
  intros until 1; revert v3; induction H; inversion 1; subst; constructor; eauto using Values.Val.lessdef_trans.
  intros until 1; revert i23 v3; induction H; inversion 1; subst; constructor; eauto using Values.val_inject_compose.
  intros until 1; revert v3; induction H; inversion 1; subst; constructor; eauto using ValuesX.val_inject_lessdef_compose.
  intros until 1; revert i23 v3; induction H; inversion 1; subst; constructor; eauto using ValuesX.val_lessdef_inject_compose.
Qed.

Section WITHMEM.
Context `{memory_model_x: Mem.MemoryModelX}.

Section WITHVAL.
Context `{val_lessdef_inject: ValLessdefInject}.

Section FinalStates.
  Context {state: Type} (final_state: state -> (val * mem) -> Prop).

Inductive final_state_with_extends (s: state): val * mem -> Prop :=
| final_state_extends_intro
    v' m'
    (Hfinal: final_state s (v', m'))
    m (MEXT: Mem.extends m m')
    v (LESSDEF: val_lessdef v v')
  :
    final_state_with_extends s (v, m)
.

Lemma final_state_extends_strict:
  forall s v,
    final_state s v ->
    final_state_with_extends s v.
Proof.
  destruct v. econstructor. eassumption. apply Mem.extends_refl. apply val_lessdef_refl.
Qed.

Lemma final_state_extends_weak:
  forall s v' m'
    (Hfinal: final_state_with_extends s (v', m'))
    m (MEXT: Mem.extends m m')
    v (LESSDEF: val_lessdef v v')
  ,
    final_state_with_extends s (v, m)
.
Proof.
  inversion 1; subst. econstructor; eauto using Mem.extends_extends_compose, val_lessdef_trans.
Qed.

Inductive final_state_with_inject (m_init: mem) (s: state): val * mem -> Prop :=
| final_state_inject_intro
    v' m'
    (Hfinal: final_state s (v', m'))
    j (Hincr: Values.inject_incr (Mem.flat_inj (Mem.nextblock m_init)) j)
    (Hsep: inject_separated (Mem.flat_inj (Mem.nextblock m_init)) j m_init m_init)
    m (MINJ: Mem.inject j m m')
    v (VINJ: val_inject j v v')
  :
    final_state_with_inject m_init s (v, m)
.

Lemma final_state_inject_from_extends:
  forall
    s v' m'
    (Hfinal: final_state_with_extends s (v', m'))
    m_init j (Hincr: Values.inject_incr (Mem.flat_inj (Mem.nextblock m_init)) j)
    (Hsep: inject_separated (Mem.flat_inj (Mem.nextblock m_init)) j m_init m_init)
    m (MINJ: Mem.inject j m m')
    v (VINJ: val_inject j v v')
  ,
    final_state_with_inject m_init s (v, m)
.
Proof.
  intros. inv Hfinal.
  econstructor.
  eassumption.
  eassumption.
  assumption.
  eapply Mem.inject_extends_compose.
  eassumption.
  assumption.
  eapply val_inject_lessdef_compose.
  eassumption.
  assumption.
Qed.

Lemma final_state_inject_weak:
  forall
    s v' m_init m'
    (Hfinal: final_state_with_inject m_init s (v', m'))
    j (Hincr: Values.inject_incr (Mem.flat_inj (Mem.nextblock m_init)) j)
    (Hsep: inject_separated (Mem.flat_inj (Mem.nextblock m_init)) j m_init m_init)
    m (MINJ: Mem.inject j m m')
    v (VINJ: val_inject j v v')
  ,
    final_state_with_inject m_init s (v, m)
.
Proof.
  inversion 1; subst.
  intros.
  econstructor.
  eassumption.
  3: eapply Mem.inject_compose; eauto.
  unfold Values.inject_incr in *.
  unfold Values.compose_meminj.
  intros until delta.
  intros.
  generalize H.
  unfold Mem.flat_inj.
  destruct (plt b (Mem.nextblock m_init)); try discriminate.
  intro. inv H0.
  erewrite Hincr0; eauto.
  erewrite Hincr; eauto.
  reflexivity.
  unfold inject_separated, Values.inject_incr, Values.compose_meminj in *. intros.
  destruct (j0 b1) eqn:?; try discriminate.
  destruct p.
  destruct (j b) eqn:?; try discriminate.
  destruct p.
  inv H0.
  exploit Hsep0; eauto.
  destruct 1.
  split; auto.
  assert (Mem.flat_inj (Mem.nextblock m_init) b = None).
   unfold Mem.flat_inj. destruct (plt b (Mem.nextblock m_init)). contradiction. reflexivity.
  exploit Hsep; eauto.
  tauto.
  eapply val_inject_compose; eauto.
Qed.

End FinalStates.

Section FinalStatesMatch.

Context {state1: Type} (final_state1: state1 -> (val * mem) -> Prop)
        {state2: Type} (final_state2: state2 -> (val * mem) -> Prop)
        (match_states: state1 -> state2 -> Prop).

Lemma match_final_states_extends_right:
  (forall S R r,
     match_states S R -> final_state1 S r -> final_state_with_extends final_state2 R r) ->
  (forall S R r,
     match_states S R -> final_state_with_extends final_state1 S r -> final_state_with_extends final_state2 R r).
Proof.
  inversion 3; subst; eauto using final_state_extends_weak.
Qed.

Corollary match_final_states_extends:
  (forall S R r,
     match_states S R -> final_state1 S r -> final_state2 R r) ->
  (forall S R r,
     match_states S R -> final_state_with_extends final_state1 S r -> final_state_with_extends final_state2 R r).
Proof.
  intros; eauto using match_final_states_extends_right, final_state_extends_strict.
Qed.

Lemma match_final_states_extends_inject:
  (forall S R r,
     match_states S R -> final_state_with_extends final_state1 S r -> final_state_with_extends final_state2 R r) ->
  (forall j S R r,
     match_states S R -> final_state_with_inject final_state1 j S r -> final_state_with_inject final_state2 j R r)
.
Proof.
  intros.
  inv H1.
  eauto using final_state_inject_from_extends, final_state_extends_strict.
Qed.

Lemma match_final_states_extends_right_inject:
  (forall S R r,
     match_states S R -> final_state1 S r -> final_state_with_extends final_state2 R r) ->
  (forall j S R r,
     match_states S R -> final_state_with_inject final_state1 j S r -> final_state_with_inject final_state2 j R r)
.
Proof.
  eauto using match_final_states_extends_inject, match_final_states_extends_right.
Qed.

Lemma match_final_states_inject:
  (forall S R r,
     match_states S R -> final_state1 S r -> final_state2 R r) ->
  (forall j S R r,
     match_states S R -> final_state_with_inject final_state1 j S r -> final_state_with_inject final_state2 j R r)
.
Proof.
  intros; eauto using match_final_states_extends_right_inject, final_state_extends_strict.
Qed.

Lemma match_final_states_inject_right:
  forall m_init,
  (forall S R r,
     match_states S R -> final_state1 S r -> final_state_with_inject final_state2 m_init R r) ->
  (forall S R r,
     match_states S R -> final_state_with_inject final_state1 m_init S r -> final_state_with_inject final_state2 m_init R r).
Proof.
  inversion 3; subst; eauto using final_state_inject_weak.
Qed.

Lemma match_final_states_extends_left_inject:
  forall m,
    (forall S R r,
       match_states S R -> final_state1 S r -> final_state_with_inject final_state2 m R r) ->
    (forall S R r,
       match_states S R -> final_state_with_extends final_state1 S r -> final_state_with_inject final_state2 m R r)
.
Proof.
  intros.
  inv H1.
  exploit H; eauto.
  inversion 1; subst.
  econstructor.
  eassumption.
  eassumption.
  assumption.
  eapply Mem.extends_inject_compose.
  eassumption.
  assumption.
  eapply val_lessdef_inject_compose; eauto.
Qed.

End FinalStatesMatch.

Definition semantics_with_extends (sem: semantics (val * mem)%type) : semantics (val * mem).
Proof.
  econstructor.
   eexact (step sem).
   exact (initial_state sem).
   apply final_state_with_extends. exact (final_state sem).
   apply (globalenv sem).
Defined.

Lemma forward_simulation_extends_right:
  forall s1 s2,
    forward_simulation s1 (semantics_with_extends s2) ->
    forward_simulation (semantics_with_extends s1) (semantics_with_extends s2)
.
Proof.
  inversion 1; subst.
  econstructor.
   eassumption.
   eassumption.
   intro i. apply match_final_states_extends_right. apply fsim_match_final_states.
   assumption.
   assumption.
Defined.

Lemma forward_simulation_extends:
  forall s1 s2,
    forward_simulation s1 s2 ->
    forward_simulation (semantics_with_extends s1) (semantics_with_extends s2)
.
Proof.
  inversion 1; subst.
  econstructor.
   eassumption.
   eassumption.
   intro i. apply match_final_states_extends. apply fsim_match_final_states.
   assumption.
   assumption.
Defined.

Definition semantics_with_inject (sem: semantics (val * mem)%type) (m_init: mem) : semantics (val * mem).
Proof.
  econstructor.
   eexact (step sem).
   exact (initial_state sem).
   apply final_state_with_inject. exact (final_state sem). assumption.
   apply (globalenv sem).
Defined.

Lemma forward_simulation_extends_inject:
  forall s1 s2,
    forward_simulation (semantics_with_extends s1) (semantics_with_extends s2) ->
    forall m_init,
      forward_simulation (semantics_with_inject s1 m_init) (semantics_with_inject s2 m_init).
Proof.
  inversion 1; subst.
  econstructor.
   eassumption.
   eassumption.
   intro i. apply match_final_states_extends_inject. apply fsim_match_final_states.
   assumption.
   assumption.
Defined.

Corollary forward_simulation_extends_right_inject:
  forall s1 s2,
    forward_simulation s1 (semantics_with_extends s2) ->
    forall m_init,
      forward_simulation (semantics_with_inject s1 m_init) (semantics_with_inject s2 m_init).
Proof.
  eauto using forward_simulation_extends_inject, forward_simulation_extends_right.
Defined.

Corollary forward_simulation_inject:
  forall s1 s2,
    forward_simulation s1 s2 ->
    forall m_init,
      forward_simulation (semantics_with_inject s1 m_init) (semantics_with_inject s2 m_init).
Proof.
  eauto using forward_simulation_extends_inject, forward_simulation_extends.
Defined.

Lemma forward_simulation_inject_right:
  forall s1 s2 m_init,
    forward_simulation s1 (semantics_with_inject s2 m_init) ->
    forward_simulation (semantics_with_inject s1 m_init) (semantics_with_inject s2 m_init).
Proof.
  inversion 1; subst.
  econstructor.
   eassumption.
   eassumption.
   intro i. apply match_final_states_inject_right; eauto.
   apply fsim_match_final_states.
   assumption.
   assumption.
Defined.

Lemma forward_simulation_extends_left_inject:
  forall m_init s1 s2,
    forward_simulation s1 (semantics_with_inject s2 m_init) ->
    forward_simulation (semantics_with_extends s1) (semantics_with_inject s2 m_init).
Proof.
  inversion 1; subst.
  econstructor.
   eassumption.
   eassumption.
   intros. eapply match_final_states_extends_left_inject.
    intros. eapply fsim_match_final_states. 2: eassumption. eassumption. eassumption. assumption.
    assumption.
    assumption.
Defined.

End WITHVAL.

(** Encoding longs.

    We wrap a C-like semantics (one return value, long long int64
    pre-decided) into an Asm-like semantics (a list of return values,
    long long int64 not pre-decided), following
    compcert.common.Events.external_call'
 *)

Section ENCODE_LONGS.

  Context {state: Type}
          (initial_state: signature -> list Values.val -> state -> Prop)
          (final_state: signature -> state -> (Values.val * mem) -> Prop).

  Inductive initial_state_decode_longs
            (sg: signature)
            (args: list Values.val)
            (s: state)
  : Prop :=
  | initial_state_decode_longs_intro
      (INIT: initial_state sg (decode_longs (sig_args sg) args) s)
  .

  Inductive final_state_encode_long
            (sg: signature)
            (s: state)
  : (list Values.val * mem) -> Prop :=
  | final_state_encode_long_intro
      v m
      (FIN: final_state sg s (v, m))
      v'
      (Hv': v' = encode_long (sig_res sg) v)
    :
      final_state_encode_long sg s (v', m)
  .

End ENCODE_LONGS.

Record csemantics `{memory_model_ops: Mem.MemoryModelOps mem}: Type := CSemantics
{
  state: Type;
  funtype: Type;
  vartype: Type;
  step: Globalenvs.Genv.t funtype vartype ->
           state -> trace -> state -> Prop;
  initial_state: signature -> list Values.val -> state -> Prop;
  final_state: signature -> state -> (Values.val * mem) -> Prop;
  globalenv: Globalenvs.Genv.t funtype vartype
}.
Global Arguments CSemantics {_} [_ _ _] _ _ _ _.

Definition semantics_as_c (s: csemantics) (sg: signature) (args: list Values.val) :=
  Semantics (step s) (initial_state s sg args) (final_state s sg) (globalenv s).

Definition semantics_as_asm (s: csemantics) (sg: signature) (args: list Values.val) :=
  Semantics (step s) (initial_state_decode_longs (initial_state s) sg args) (final_state_encode_long (final_state s) sg) (globalenv s).

Theorem semantics_injects_c_to_asm:
  forall s1 s2 sg m args,
    forward_simulation
      (semantics_as_c s1 sg (decode_longs (sig_args sg) args))
         (semantics_with_inject (semantics_as_c s2 sg (decode_longs (sig_args sg) args)) m)
  ->
  forward_simulation
    (semantics_as_asm s1 sg args)
    (semantics_with_inject (semantics_as_asm s2 sg args) m)
.
Proof.
  inversion 1; subst.
  simpl in *.
  econstructor.
  eassumption.
  3: eassumption.
  simpl in *. inversion 1; subst.
  exploit fsim_match_initial_states; eauto.
  destruct 1 as [? [? [? ?]]].
  esplit. esplit. split; eauto.
  econstructor; eauto.
  simpl in *.
  inversion 2; subst.
  exploit fsim_match_final_states; eauto.
  inversion 1; subst.
  econstructor.
  econstructor.
  eassumption.
  reflexivity.
  eassumption.
  assumption.
  assumption.
  apply encode_long_inject.
  assumption.
  assumption.
Defined.

End WITHMEM.