(*
This exercise introduces the basic Iris Proof Mode tactics by proving a simple
example: a function that swaps the contents of two pointers. We will use this
function to implement two other functions.
*)
From iris.heap_lang Require Import proofmode notation.

(* The swap function, defined as a heap-lang value. This looks like an ordinary
Coq function, but it is not: heap-lang is a deeply embedded language in Coq. It
uses strings for name binding and notations close to Coq's (but typically
augmented with a colon to avoid ambiguity) to make it easy to read and write
programs. *)
Definition swap : val := λ: "x" "y",
  let: "tmp" := !"x" in
  "x" <- !"y";;
  "y" <- "tmp".

(* Using swap, we can define functions that rotate three pointers in left and
right direction. *)
Definition rotate_r : val := λ: "x" "y" "z",
  swap "y" "z";; swap "x" "y".

Definition rotate_l : val := λ: "x" "y" "z",
  swap "x" "y";; swap "y" "z".

Section proof.
(* Iris is parameterized by the type of ghost state that is needed to carry out
a proof. As such, the type of Iris propositions [iProp] is indexed by a [Σ]: a
list of cameras (actually, functors from OFEs to cameras). To make our proofs
generic, we abstract over any such [Σ] and use type classes to ensure that the
necessary cameras are present in [Σ].

For this proof, we do not need any special ghost state (i.e. cameras) apart from
the ghost state that's the heap-lang uses internally for modeling the [l ↦ v]
connective. The cameras for this ghost state is provided by the class [heapG].
*)
Context `{!heapG Σ}.

Lemma swap_spec x y v1 v2 :
  {{{ x ↦ v1 ∗ y ↦ v2 }}} swap #x #y {{{ RET #(); x ↦ v2 ∗ y ↦ v1 }}}.

  (* The "Texan triple" [ {{{ P }}} e {{{ RET v, Q }}} ] is syntactic sugar for:

         ∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e {{ v, Φ v }}

     Which is logically equivalent to [ P -∗ WP e {{ x, x = v ∗ Q }} ]

     In practice, the "Texan triple" is not more difficult to prove, but usually
     easier to use other proofs, because the post-condition does not have to
     syntactically match [Q]. Using this way of stating specifications, the
     consequence and framing rule is implicitly applied on the post-condition.

     Note that [ # v ] is the embedding of values ([bool], [Z], [loc]) into
     heap-lang values.*)
Proof.
  iIntros (Φ) "[Hx Hy] Post".
  unfold swap.
  wp_lam. wp_lam.
  wp_load. wp_let.
  wp_load. wp_store.
  wp_store.
  iApply "Post".
  iSplitL "Hx".
  - iApply "Hx".
  - iApply "Hy".
Qed.

(* Same lemma, but using a bit of automation to shorten the proof. *)
Lemma swap_spec_2 x y v1 v2 :
  {{{ x ↦ v1 ∗ y ↦ v2 }}} swap #x #y {{{ RET #(); x ↦ v2 ∗ y ↦ v1 }}}.
Proof.
  iIntros (Φ) "[??] Post".
  wp_lam. wp_lam. wp_load. wp_let. wp_load. wp_store. wp_store.
  iApply "Post". iFrame.
Qed.

(* We can further automate the lemma by defining a simple Ltac tactic for
symbolic executing. *)
Ltac wp_exec := repeat (wp_pure _ || wp_load || wp_store).

(* This tactic repeatedly tries to symbolically execute pure redexes, loads and
stores. It makes use of the tactic [wp_pure t], which tries to find the redex
[t] in the goal, and executes that redex. The redex [t] may contain holes, and
as such, tactics like [wp_seq] are actually defined as [wp_pure (_ ;; _)%E]. By
using [wp_pure _] it will symbolically execute *any* pure redex. *)

(* Same lemma again, but now using the tactic we just defined. *)
Lemma swap_spec_2_more_automation x y v1 v2 :
  {{{ x ↦ v1 ∗ y ↦ v2 }}} swap #x #y {{{ RET #(); x ↦ v2 ∗ y ↦ v1 }}}.
Proof.
  iIntros (Φ) "[??] Post". wp_exec.
  iApply "Post". iFrame.
Qed.

Lemma rotate_r_spec x y z v1 v2 v3 :
  {{{ x ↦ v1 ∗ y ↦ v2 ∗ z ↦ v3 }}}
    rotate_r #x #y #z
  {{{ RET #(); x ↦ v3 ∗ y ↦ v1 ∗ z ↦ v2 }}}.
Proof.
  (* As in Coq, the IPM introduction pattern (p1 & p2 & .. & pn) ] is syntactic
  sugar for [ [p1 [p2 [... pn]]] ]. *)
  iIntros (Φ) "(Hx & Hy & Hz) Post".
  unfold rotate_r. do 3 wp_lam.
  wp_bind (swap _ _).
  iApply (swap_spec with "[Hy Hz]").
  { iFrame. }
  (* Inspired by ssreflect, the IPM introduction pattern [ /= ] performs
  [simpl]. *)
  iNext. iIntros "[Hy Hz] /=". wp_seq.
  (* We can also immediately frame hypothesis when using a lemma: *)
  iApply (swap_spec with "[$Hx $Hy]"); iNext; iIntros "[Hx Hy]".
  iApply "Post". iFrame.
Qed.

Lemma rotate_r_spec_again x y z v1 v2 v3 :
  {{{ x ↦ v1 ∗ y ↦ v2 ∗ z ↦ v3 }}}
    rotate_r #x #y #z
  {{{ RET #(); x ↦ v3 ∗ y ↦ v1 ∗ z ↦ v2 }}}.
Proof.
  iIntros (Φ) "(Hx & Hy & Hz) Post". do 3 wp_lam.
  (* We can shorten the above a bit: Instead of using the [iApply] tactic, we
  can use [wp_apply] which automatically uses [wp_bind] first. Also, it strips
  the later [▷] by calling [iNext] afterwards. *)
  wp_apply (swap_spec with "[$Hy $Hz]"); iIntros "[Hy Hz] /="; wp_seq.
  wp_apply (swap_spec with "[$Hx $Hy]"); iIntros "[Hx Hy] /=".
  iApply "Post". iFrame.
Qed.

(* *Exercise*: Do this proof yourself. Try a couple of variations of the tactics
we have seen before:
- Do the whole proof explicitly by proving [swap] inline,
- Use the specification of [swap] in combination with [iApply],
- Use the specification of [swap] in combination with [wp_apply]
*)
Lemma rotate_l_spec x y z v1 v2 v3 :
  {{{ x ↦ v1 ∗ y ↦ v2 ∗ z ↦ v3 }}}
    rotate_l #x #y #z
  {{{ RET #(); x ↦ v2 ∗ y ↦ v3 ∗ z ↦ v1 }}}.
Proof.
  iIntros (Φ) "(Hx & Hy & Hz) Post". unfold rotate_l. do 3 wp_lam.
  wp_apply (swap_spec with "[$Hx $Hy]"); iIntros "[Hx Hy]"; wp_seq.
  wp_apply (swap_spec with "[$Hy $Hz]"); iIntros "[Hy Hz]".
  iApply ("Post" with "[$]").
Qed.
End proof.


Require Import NArith.
Require Import GeoCoq.Utils.sets.
Require Import GeoCoq.Meta_theory.Models.tarski_to_col_theory.
Require Import GeoCoq.Tactics.Coinc.ColR.

Ltac add_to_distinct_list x xs :=
  match xs with
    | nil     => constr:(x::xs)
    | x::_    => fail 1
    | ?y::?ys => let zs := add_to_distinct_list x ys in constr:(y::zs)
  end.

Ltac collect_points_list Tpoint xs :=
  match goal with
    | N : Tpoint |- _ => let ys := add_to_distinct_list N xs in
                           collect_points_list Tpoint ys
    | _               => xs
  end.

Ltac collect_points Tpoint := collect_points_list Tpoint (@nil Tpoint).

Ltac number_aux Tpoint lvar cpt :=
  match constr:(lvar) with
    | nil          => constr:(@nil (prodT Tpoint positive))
    | cons ?H ?T => let scpt := eval vm_compute in (Pos.succ cpt) in
                    let lvar2 := number_aux Tpoint T scpt in
                      constr:(cons (@pairT  Tpoint positive H cpt) lvar2)
  end.

Ltac number Tpoint lvar := number_aux Tpoint lvar (1%positive).

Ltac build_numbered_points_list Tpoint := let lvar := collect_points Tpoint in number Tpoint lvar.

Ltac List_assoc Tpoint elt lst :=
  match constr:(lst) with
    | nil => fail
    | (cons (@pairT Tpoint positive ?X1 ?X2) ?X3) =>
      match constr:(elt = X1) with
        | (?X1 = ?X1) => constr:(X2)
        | _ => List_assoc Tpoint elt X3
      end
  end.

Definition Tagged P : Prop := P.

Lemma PropToTagged : forall P : Prop, P -> Tagged P.
Proof. trivial. Qed.

Ltac assert_ss_ok Tpoint Col lvar :=
  repeat
  match goal with
    | HCol : Col ?A ?B ?C, HOK : ss_ok ?SS ?Interp |- _ =>
        let pa := List_assoc Tpoint A lvar in
        let pb := List_assoc Tpoint B lvar in
        let pc := List_assoc Tpoint C lvar in
         apply PropToTagged in HCol;
         apply (collect_cols A B C HCol pa pb pc SS Interp) in HOK; try reflexivity
  end.

Ltac assert_sp_ok Tpoint Col lvar :=
  repeat
  match goal with
    | HDiff : ?A <> ?B, HOK : sp_ok ?SP ?Interp |- _ =>
        let pa := List_assoc Tpoint A lvar in
        let pb := List_assoc Tpoint B lvar in
          apply PropToTagged in HDiff;
          apply (collect_diffs A B HDiff pa pb SP Interp) in HOK; try reflexivity
  end.

Ltac subst_in_cols Tpoint Col :=
  repeat
  match goal with
    | HOKSS : ss_ok ?SS ?Interp, HOKSP : sp_ok ?SP ?Interp, HL : eq_tagged ?Lvar, HEQ : ?A = ?B |- _ =>
      let pa := List_assoc Tpoint A Lvar in
      let pb := List_assoc Tpoint B Lvar in
        apply (subst_ss_ok A B HEQ pa pb SS Interp) in HOKSS; try reflexivity;
        apply (subst_sp_ok A B HEQ pa pb SP Interp) in HOKSP; try reflexivity;
        subst B
  end.

Ltac clear_cols_aux Tpoint Col :=
  repeat
  match goal with
    | HOKSS : ss_ok ?SS ?Interp, HOKSP : sp_ok ?SP ?Interp, HL : eq_tagged ?Lvar |- _ =>
      clear HOKSS; clear HOKSP; clear HL
  end.

Ltac tag_hyps_gen Tpoint Col :=
  repeat
  match goal with
    | HDiff : ?A <> ?B |- _ => apply PropToTagged in HDiff
    | HCol : Col ?A ?B ?C |- _ => apply PropToTagged in HCol
  end.

Ltac untag_hyps_gen Tpoint Col := unfold Tagged in *.

Ltac show_all' :=
  repeat
  match goal with
    | Hhidden : Something |- _ => show Hhidden
  end.

Ltac clear_cols_gen Tpoint Col := show_all'; clear_cols_aux Tpoint Col.

Ltac Col_refl Tpoint Col :=
  match goal with
    | Default : Tpoint |- Col ?A ?B ?C =>
        let lvar := build_numbered_points_list Tpoint in
        let pa := List_assoc Tpoint A lvar in
        let pb := List_assoc Tpoint B lvar in
        let pc := List_assoc Tpoint C lvar in
        let c := ((vm_compute;reflexivity) || fail 2 "Can not be deduced") in
        let HSS := fresh in
          assert (HSS := @ss_ok_empty Tpoint Col (interp lvar Default)); assert_ss_ok Tpoint Col lvar;
        let HSP := fresh in
          assert (HSP := @sp_ok_empty Tpoint (interp lvar Default)); assert_sp_ok Tpoint Col lvar;
          match goal with
            | HOKSS : ss_ok ?SS ?Interp, HOKSP : sp_ok ?SP ?Interp |- _ =>
              apply (test_col_ok SS SP Interp pa pb pc HOKSS HOKSP); c
          end
  end.

(*
Ltac deduce_cols_aux Tpoint Col :=
  match goal with
    | Default : Tpoint |- _ =>
        let lvar := build_numbered_points_list Tpoint in
        let HSS := fresh in
          assert (HSS := @ss_ok_empty Tpoint Col (interp lvar Default)); assert_ss_ok Tpoint Col lvar;
        let HSP := fresh in
          assert (HSP := @sp_ok_empty Tpoint (interp lvar Default)); assert_sp_ok Tpoint Col lvar;
        let HL := fresh in
          assert (HL : lvar = lvar) by reflexivity;
          apply (@eq_eq_tagged Tpoint) in HL
  end.

Ltac deduce_cols Tpoint Col := deduce_cols_aux Tpoint Col.
*)

Ltac deduce_cols_hide_aux Tpoint Col :=
  match goal with
    | Default : Tpoint |- _ =>
        let lvar := build_numbered_points_list Tpoint in
        let HSS := fresh in
          assert (HSS := @ss_ok_empty Tpoint Col (interp lvar Default)); assert_ss_ok Tpoint Col lvar;
        let HSP := fresh in
          assert (HSP := @sp_ok_empty Tpoint (interp lvar Default)); assert_sp_ok Tpoint Col lvar;
        let HL := fresh in
          assert (HL : lvar = lvar) by reflexivity;
          apply (@eq_eq_tagged Tpoint) in HL;
          hide HSS; hide HSP; hide HL
  end.

Ltac deduce_cols_hide_gen Tpoint Col := deduce_cols_hide_aux Tpoint Col.

Ltac update_cols_aux Tpoint Col :=
  match goal with
    | HOKSS : ss_ok ?SS ?Interp, HOKSP : sp_ok ?SP ?Interp, HEQ : eq_tagged ?Lvar |- _ =>
      assert_ss_ok Tpoint Col Lvar; assert_sp_ok Tpoint Col Lvar; subst_in_cols Tpoint Col; hide HOKSS; hide HOKSP; hide HEQ
  end.

Ltac update_cols_gen Tpoint Col := show_all'; update_cols_aux Tpoint Col.

Ltac cols_aux Tpoint Col :=
  match goal with
    | HOKSS : ss_ok ?SS ?Interp, HOKSP : sp_ok ?SP ?Interp, HL : eq_tagged ?Lvar |- Col ?A ?B ?C =>
      let pa := List_assoc Tpoint A Lvar in
      let pb := List_assoc Tpoint B Lvar in
      let pc := List_assoc Tpoint C Lvar in
      let c := ((vm_compute;reflexivity) || fail 1 "Can not be deduced") in
        apply (test_col_ok SS SP Interp pa pb pc ); [assumption|assumption|c];
        hide HOKSS; hide HOKSP; hide HL
  end.

Ltac cols_gen Tpoint Col := show_all'; cols_aux Tpoint Col.

Ltac Col_refl_test Tpoint Col := deduce_cols_hide_gen Tpoint Col; cols_gen Tpoint Col.


Require Import Coqlib.
Require Import Errors.
Require Import Integers.
Require Import Tree.
Require Import String.
Require Import Asm.

Require Extractor.
Require TransUtil.
Require TransLayerStatement.
Require TransBranchInfo.

Local Open Scope error_monad_scope.

Set Implicit Arguments.

Fixpoint calculate_length (e : expression) (pil : list pin_info) : res int :=
  match e with
  | Length_Expression id =>
    do proto_info <- TransUtil.find_protocol_info_in_pin_list id pil;
    OK (proto_length proto_info)
  | Binary_Expression bin_op bin_expr1 bin_expr2 =>
    do len1 <- calculate_length bin_expr1 pil;
    do len2 <- calculate_length bin_expr2 pil;
    OK (Int.add len1 len2)
  | Constant_Expression con =>
    TransUtil.to_int con
  | _ =>
    Error (msg "invalid expression type b0!")
  end.

Definition trans_cell_zero_pc_item
  (b_index : int)
  (bi : branch_info)
  (pil : list pin_info) : res zero_pc_item :=
  do stmt_list <- OK (stmt bi);
  OK (Zero_Pc_Item b_index Int.one)
  .

Fixpoint trans_cell_zero_pc_item_list
  (b_index : int)
  (bil : list branch_info)
  (pil : list pin_info) : res (list zero_pc_item) :=
  match bil with
  | nil =>
    OK nil
  | hd :: tl =>
    do v1 <- trans_cell_zero_pc_item b_index hd pil;
    do v2 <- trans_cell_zero_pc_item_list (Int.add b_index Int.one) tl pil;
    OK (v1 :: v2)
  end.

Definition trans_cell_zero_pc
  (bil : list branch_info)
  (pil : list pin_info) : res zero_pc :=
  do zero_pc_item_list <- trans_cell_zero_pc_item_list Int.one bil pil;
  OK (Zero_Pc zero_pc_item_list)
  .

Fixpoint trans_cell_zero_pb_item
  (l_index : int)
  (b_index : int)
  (bi : branch_info)
  (pil : list pin_info)
  (ps : protocol_set) : res zero_pb_item :=
  OK (Zero_Pb_Item l_index (cond bi) b_index ).

Fixpoint trans_cell_zero_pb_item_list
  (l_index : int)
  (b_index : int)
  (ibl : list branch_info)
  (pil : list pin_info)
  (ps : protocol_set) : res (list zero_pb_item) :=
  match ibl with
  | nil =>
    OK nil
  | hd :: tl =>
    do v1 <- trans_cell_zero_pb_item l_index b_index hd pil ps;
    do v2 <- trans_cell_zero_pb_item_list l_index (Int.add b_index Int.one) tl pil ps;
    OK (v1 :: v2)
  end.

Definition trans_cell_zero_pb
  (l_index : int)
  (bil : list branch_info)
  (pil : list pin_info)
  (ps : protocol_set) : res zero_pb :=
  do zero_pb_item_list <- trans_cell_zero_pb_item_list  l_index Int.one bil pil ps;
  OK (Zero_Pb zero_pb_item_list)
  .

Definition translate
  (l_index : int)
  (cba : cell_b0_action)
  (cbr : cell_b0_register)
  (pil : list pin_info)
  (ps : protocol_set) : res cell_zero :=
  match cba with
  | Cell_B0_Action layer_stmt =>
    match layer_stmt with
    | Layer_Statement stmt_list =>
      do layer_branch_info_list <- TransLayerStatement.translate stmt_list pil;
      do zero_pb <- trans_cell_zero_pb l_index layer_branch_info_list pil ps;
      do zero_pc <- trans_cell_zero_pc layer_branch_info_list pil;
      OK (Cell_Zero zero_pb zero_pc)
    end
  end.


(**
  [TypeTheory.RelUniv.RelUniv_Cat]

  Part of the [TypeTheory] library (Ahrens, Lumsdaine, Voevodsky, 2015–present).
*)

(**
This module defines two categories of relative J-universe structures:
- [reluniv_cat] — with "simple" (or naive) morphisms (simple commutative squares);
- [reluniv_with_ϕ_cat] — with "full" morphisms (with explicit ϕ component and corresponding axioms).

ϕ component is completely determined by the remaining parts of a morphisms when J is fully faithful.
This result is reflected in [reluniv_mor_ϕ_of] and futher developed into an isomorphism of
categories in [TypeTheory.RelUniv.RelUniv_Cat_Iso].

An isomorphism between a (simple) category of CwF structures and
(simple) category of relative universe structures over the Yoneda embedding functor
is also demonstrated in [TypeTheory.CwF_RelUniv_Cat_Yo_CwF_Iso].

Other important definitions:
- [iscontr_reluniv_mor_ϕ] — proof that ϕ component is contractible when J is fully faithful;
- [isaprop_reluniv_mor_ϕ] — proof that ϕ component is proposition when J is faithful.

TODO: document/update Comm_Squares and Functor_Squares sections.

*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.

Require Import UniMath.CategoryTheory.DisplayedCats.Codomain.
Require Import UniMath.CategoryTheory.limits.pullbacks.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.Auxiliary.TypeOfMorphisms.

Require Import TypeTheory.RelUniv.RelativeUniverses.
Require Import TypeTheory.RelUniv.RelUniv_Cat_Simple.

Section RelUniv.

  Context {C D : category}.
  Context (J : functor C D).

Section RelUniv_ϕ_Cat.

  Local Definition Ũ (u : relative_universe J) := source (pr1 u).
  Local Definition U (u : relative_universe J) := target (pr1 u).

  Definition relative_universe_mor_data := gen_reluniv_mor_data J rel_universe_structure.
  Definition relative_universe_mor := gen_reluniv_mor J rel_universe_structure.

  Coercion reluniv_mor_to_data
           (u1 u2 : relative_universe J)
           (mor : relative_universe_mor u1 u2)
    : relative_universe_mor_data u1 u2
    := pr1 mor.

  Local Definition F_Ũ
        {u1 u2 : relative_universe J}
        (mor : relative_universe_mor_data u1 u2)
    : Ũ u1 --> Ũ u2
    := pr1 mor.
  Local Definition F_U
        {u1 u2 : relative_universe J}
        (mor : relative_universe_mor_data u1 u2)
    : U u1 --> U u2
    := pr2 mor.

  Local Definition Xf (u : relative_universe J)
        (X : C) (f : J X --> U u) : C
    := pr1 (pr1 (pr2 u X f)).
  Local Definition π (u : relative_universe J)
        (X : C) (f : J X --> U u) : C ⟦ Xf u X f, X ⟧
    := pr1 (pr2 (pr1 (pr2 u X f))).
  Local Definition Q (u : relative_universe J)
        (X : C) (f : J X --> U u) : D ⟦ J (Xf u X f), Ũ u ⟧
    := pr2 (pr2 (pr1 (pr2 u X f))).
  Local Definition u_commutes (u : relative_universe J)
        (X : C) (f : J X --> U u)
    : # J (fp (pr1 (pr2 u X f)));; f = fq (pr1 (pr2 u X f));; pr1 u
    := pr1 (pr2 (pr2 u X f)).
  Local Definition u_isPullback (u : relative_universe J)
        (X : C) (f : J X --> U u)
    : isPullback (*f (pr1 u) (# J (fp (pr1 (pr2 u X f))))
                 (fq (pr1 (pr2 u X f)))*) (pr1 (pr2 (pr2 u X f)))
    := pr2 (pr2 (pr2 u X f)).

  Definition reluniv_mor_ϕ_data
             {u1 u2 : relative_universe J}
             (mor : relative_universe_mor u1 u2)
             (X : C) (f : J X --> U u1)
    : UU
    := Xf u1 X f --> Xf u2 X (f ;; F_U mor).

  Definition has_reluniv_mor_axiom_ϕ_π
             {u1 u2 : relative_universe J}
             (mor : relative_universe_mor u1 u2)
             (X : C) (f : J X --> U u1)
             (ϕ : reluniv_mor_ϕ_data mor X f)
    : UU
    := ϕ ;; π u2 X (F_U mor ∘ f) = π u1 X f.

  Definition has_reluniv_mor_axiom_ϕ_Q
             {u1 u2 : relative_universe J}
             (mor : relative_universe_mor u1 u2)
             (X : C) (f : J X --> U u1)
             (ϕ : reluniv_mor_ϕ_data mor X f)
    : UU
    := # J ϕ ;; Q u2 X (F_U mor ∘ f) = Q u1 X f ;; F_Ũ mor.

  Definition reluniv_mor_ϕ
             {u1 u2 : relative_universe J}
             (mor : relative_universe_mor u1 u2)
             (X : C) (f : J X --> U u1)
    : UU
    := ∑ (ϕ : reluniv_mor_ϕ_data mor X f),
       has_reluniv_mor_axiom_ϕ_π mor X f ϕ ×
         has_reluniv_mor_axiom_ϕ_Q mor X f ϕ.

  Definition reluniv_mor_J_ϕ_data_of
             {u1 u2 : relative_universe J}
             (mor : relative_universe_mor u1 u2)
    : ∏ (X : C) (f : J X --> U u1),
      J (Xf u1 X f) --> J (Xf u2 X (f ;; F_U mor)).
  Proof.
    intros X f.
    apply (u_isPullback u2 X (f ;; F_U mor)
                        _ (# J (π u1 X f)) (Q u1 X f ;; F_Ũ mor)).
    etrans. apply assoc.
    etrans. apply maponpaths_2, (u_commutes u1 X f).
    etrans. apply assoc'.
    apply pathsinv0.
    etrans. apply assoc'.
    apply maponpaths.
    apply (pr2 mor).
  Defined.

  Definition reluniv_mor_ϕ_data_of
             (ff_J : fully_faithful J)
             {u1 u2 : relative_universe J}
             (mor : relative_universe_mor u1 u2)
    : ∏ (X : C) (f : J X --> U u1),
      reluniv_mor_ϕ_data mor X f.
  Proof.
    intros X f.
    apply ff_J.
    apply reluniv_mor_J_ϕ_data_of.
  Defined.

  Definition reluniv_mor_axiom_ϕ_π
             (ff_J : fully_faithful J)
             {u1 u2 : relative_universe J}
             (mor : relative_universe_mor u1 u2)
    : ∏ (X : C) (f : J X --> U u1),
      has_reluniv_mor_axiom_ϕ_π mor X f
        (reluniv_mor_ϕ_data_of ff_J mor X f).
  Proof.
    intros X f.
    apply (invmaponpathsweq (# J ,, ff_J _ _)).
    etrans. apply functor_comp.
    etrans. apply maponpaths_2, (homotweqinvweq (# J ,, ff_J _ _) _).
    simpl.
    set (u2_Pullback
         := make_Pullback
             _
              (u_isPullback u2 X (f ;; F_U mor))).
    apply (PullbackArrow_PullbackPr1 u2_Pullback).
  Defined.

  Definition reluniv_mor_axiom_ϕ_Q
             (ff_J : fully_faithful J)
             {u1 u2 : relative_universe J}
             (mor : relative_universe_mor u1 u2)
    : ∏ (X : C) (f : J X --> U u1),
      has_reluniv_mor_axiom_ϕ_Q mor X f
        (reluniv_mor_ϕ_data_of ff_J mor X f).
  Proof.
    intros X f.
    set (u2_Pullback
         := make_Pullback
            _
              (u_isPullback u2 X (f ;; F_U mor))).
    etrans. apply maponpaths_2, (homotweqinvweq (# J ,, ff_J _ _) _).
    apply (PullbackArrow_PullbackPr2 u2_Pullback).
  Defined.

  Definition reluniv_mor_ϕ_of
             (ff_J : fully_faithful J)
             {u1 u2 : relative_universe J}
             (mor : relative_universe_mor u1 u2)
    : ∏ (X : C) (f : J X --> U u1),
      reluniv_mor_ϕ mor X f.
  Proof.
    intros X f.
    exists (reluniv_mor_ϕ_data_of ff_J mor X f).
    use make_dirprod.
    - apply reluniv_mor_axiom_ϕ_π.
    - apply reluniv_mor_axiom_ϕ_Q.
  Defined.

  Definition isaprop_reluniv_mor_ϕ
             (f_J : faithful J)
             {u1 u2 : relative_universe J}
             (mor : relative_universe_mor u1 u2)
             (X : C) (f : J X --> U u1)
    : isaprop (reluniv_mor_ϕ mor X f).
  Proof.
    apply invproofirrelevance.
    intros ϕ ϕ'.
    use total2_paths_f.
    + apply (invmaponpathsincl (# J) (f_J _ _)).
      set (P := PullbackArrowUnique
               _
               (u_isPullback u2 X (f ;; F_U mor))
               _ (# J (π u1 X f)) (Q u1 X f ;; F_Ũ mor)
            ).
      assert (# J (π u1 X f) ;; (f ;; F_U mor) =
              Q u1 X f ;; F_Ũ mor ;; pr1 u2) as Hcomm.
      {
        etrans. apply assoc.
        etrans. apply maponpaths_2, (u_commutes u1 X f).
        etrans. apply assoc'.
        etrans. apply maponpaths, pathsinv0, (pr2 mor).
        apply assoc.
      }
      etrans. apply (P Hcomm).
      * etrans. apply pathsinv0, functor_comp.
        apply maponpaths, (pr1 (pr2 ϕ)).
      * apply (pr2 (pr2 ϕ)).
      * apply pathsinv0, P.
        -- etrans. apply pathsinv0, functor_comp.
          apply maponpaths, (pr1 (pr2 ϕ')).
        -- apply (pr2 (pr2 ϕ')).
    + apply dirprod_paths.
      * apply homset_property.
      * apply homset_property.
  Defined.

  Definition iscontr_reluniv_mor_ϕ
             (ff_J : fully_faithful J)
             {u1 u2 : relative_universe J}
             (mor : relative_universe_mor u1 u2)
             (X : C) (f : J X --> U u1)
    : iscontr (reluniv_mor_ϕ mor X f).
  Proof.
    apply iscontraprop1.
    apply isaprop_reluniv_mor_ϕ.
    - apply fully_faithful_implies_full_and_faithful, ff_J.
    - apply reluniv_mor_ϕ_of, ff_J.
  Defined.

  Definition reluniv_mor_with_ϕ
             (u1 u2 : relative_universe J)
    : UU
    := ∑ (mor : relative_universe_mor u1 u2),
       ∏ (X : C) (f : J X --> U u1), reluniv_mor_ϕ mor X f.

  Lemma reluniv_ϕ_π_eq_π
        {C' : category}
        {X : C'} {F : Type} {P : F → C'}
        (f g : F)
        (π : ∏ (k : F), P k --> X)
        (ϕ : ∏ (k : F) (fk : f = k), P f --> P k)
        (ϕ_f : ϕ f (idpath f) = identity _)
    : ∏ (fg : f = g), ϕ g fg ;; π g = π f.
  Proof.
    intros gf.
    use (paths_rect _ _ (λ k fk, ϕ k fk ;; π k = π f) _ _ gf). simpl.
    etrans. apply maponpaths_2, ϕ_f.
    apply id_left.
  Defined.

  Definition reluniv_mor_with_ϕ_id
             (u : relative_universe J)
    : reluniv_mor_with_ϕ u u.
  Proof.
    use tpair.
    - apply gen_reluniv_mor_id.
    - intros X f.
      use tpair.
      + apply idtoiso.
        apply maponpaths, pathsinv0, id_right.
      + use make_dirprod.
        * apply (reluniv_ϕ_π_eq_π _ _ _ (λ _ fk, pr1 (idtoiso (maponpaths (Xf u X) fk)))).
          apply idpath.
        * unfold has_reluniv_mor_axiom_ϕ_Q.
          apply pathsinv0. etrans. apply id_right. apply pathsinv0.
          apply (reluniv_ϕ_π_eq_π _ _ _ (λ _ fk, # J (pr1 (idtoiso (maponpaths (Xf u X) fk))))).
          apply functor_id.
  Defined.

  Definition reluniv_mor_with_ϕ_comp
             (a b c : relative_universe J)
             (g : reluniv_mor_with_ϕ a b)
             (h : reluniv_mor_with_ϕ b c)
    : reluniv_mor_with_ϕ a c.
  Proof.
    use tpair.
    - apply (gen_reluniv_mor_comp _ _ _ _ _ (pr1 g) (pr1 h)).
    - intros X f.
      use tpair.
      + unfold reluniv_mor_ϕ_data.
        set (ϕ1 := pr1 (pr2 g X f)).
        set (ϕ2 := pr1 (pr2 h X (f ;; F_U (pr1 g)))).
        eapply compose. apply (ϕ1 ;; ϕ2).
        apply idtoiso.
        apply maponpaths, assoc'.
      + use make_dirprod.
        * set (ϕ_π1 := pr1 (pr2 (pr2 g X f))).
          set (ϕ_π2 := pr1 (pr2 (pr2 h X (f ;; F_U (pr1 g))))).
          etrans. apply assoc'.
          etrans. apply maponpaths.
          apply (reluniv_ϕ_π_eq_π _ _ _ (λ _ fk, pr1 (idtoiso (maponpaths (Xf _ X) fk)))).
          apply idpath.
          etrans. apply assoc'.
          etrans. apply maponpaths, ϕ_π2.
          apply ϕ_π1.
        * set (ϕ_Q1 := pr2 (pr2 (pr2 g X f))).
          set (ϕ_Q2 := pr2 (pr2 (pr2 h X (f ;; F_U (pr1 g))))).
          unfold has_reluniv_mor_axiom_ϕ_Q in *.
          etrans. apply maponpaths_2, functor_comp.
          etrans. apply maponpaths_2, maponpaths_2, functor_comp.
          etrans. apply assoc'.
          etrans. apply maponpaths.
          apply (reluniv_ϕ_π_eq_π _ _ _ (λ _ fk, # J (pr1 (idtoiso (maponpaths (Xf _ X) fk))))).
          apply functor_id.
          etrans. apply assoc'.
          etrans. apply maponpaths, ϕ_Q2.
          etrans. apply assoc.
          etrans. apply maponpaths_2, ϕ_Q1.
          apply assoc'.
  Defined.

  Definition reluniv_mor_with_ϕ_eq_faithful
             (u1 u2 : relative_universe J)
             (g h : reluniv_mor_with_ϕ u1 u2)
             (e_Ũ : F_Ũ (pr1 g) = F_Ũ (pr1 h))
             (e_U : F_U (pr1 g) = F_U (pr1 h))
             (f_J : faithful J)
    : g = h.
  Proof.
    use total2_paths_f.
    - use gen_reluniv_mor_eq.
      + apply e_Ũ.
      + apply e_U.
    - apply impred_isaprop. intros X.
      apply impred_isaprop. intros f.
      apply isaprop_reluniv_mor_ϕ.
      apply f_J.
  Defined.

  Definition reluniv_with_ϕ_Xf_compat
             {u1 u2 : relative_universe J}
             {g h : relative_universe_mor u1 u2}
             (e_U : F_U g = F_U h)
    : ∏ (X : C) (f : J X --> U u1),
      Xf u2 X (f ;; F_U g) --> Xf u2 X (f ;; F_U h).
  Proof.
    intros X f.
    apply idtoiso, maponpaths, maponpaths.
    apply e_U.
  Defined.

  Definition reluniv_mor_with_ϕ_eq
             (u1 u2 : relative_universe J)
             (g h : reluniv_mor_with_ϕ u1 u2)
             (e_Ũ : F_Ũ (pr1 g) = F_Ũ (pr1 h))
             (e_U : F_U (pr1 g) = F_U (pr1 h))
             (e_ϕ : ∏ (X : C) (f : J X --> U u1),
                    pr1 (pr2 g X f) ;; reluniv_with_ϕ_Xf_compat e_U X f
                    = pr1 (pr2 h X f))
    : g = h.
  Proof.
    use total2_paths_f.
    - use gen_reluniv_mor_eq.
      + apply e_Ũ.
      + apply e_U.
    - etrans. use transportf_forall. apply funextsec. intros X.
      etrans. use transportf_forall. apply funextsec. intros f.
      use total2_paths_f.
      + etrans.

        set (A := relative_universe_mor u1 u2).
        set (B := λ (a : A), reluniv_mor_ϕ_data a X f).
        set (P := λ (a : A) (b : B a),
                  has_reluniv_mor_axiom_ϕ_π a X f b
                    × has_reluniv_mor_axiom_ϕ_Q a X f b).
        apply (pr1_transportf _ _ P).

        etrans. unfold reluniv_mor_ϕ_data.
        apply (@functtransportf
                 _ _
                 (λ (m : relative_universe_mor u1 u2), Xf u2 X (f ;; F_U m))
                 (λ (c : C), C ⟦ Xf u1 X f, c ⟧)
              ).

        etrans. apply pathsinv0, idtoiso_postcompose.

        apply pathsinv0.
        etrans. apply pathsinv0, e_ϕ.
        apply maponpaths.

        unfold reluniv_with_ϕ_Xf_compat.
        apply pathsinv0.
        etrans. apply maponpaths, maponpaths.
        apply pathsinv0.
        apply (@maponpathscomp
               _ _ _ _ _
               (λ (m : relative_universe_mor u1 u2), f ;; F_U m)
               (Xf u2 X)
            ).
        apply maponpaths, maponpaths, maponpaths.
        etrans. apply pathsinv0.
        apply (@maponpathscomp
                 _ _ _ _ _
                 (λ (m : relative_universe_mor u1 u2), F_U m)
              (compose f)).
        apply maponpaths.
        apply homset_property.
      + apply dirprod_paths.
        * apply homset_property.
        * apply homset_property.
  Defined.

  Definition reluniv_with_ϕ_ob_mor : precategory_ob_mor
    := make_precategory_ob_mor
         (relative_universe J) reluniv_mor_with_ϕ.

  Definition reluniv_with_ϕ_precategory_data : precategory_data.
  Proof.
    apply (make_precategory_data reluniv_with_ϕ_ob_mor).
    - apply reluniv_mor_with_ϕ_id.
    - apply reluniv_mor_with_ϕ_comp.
  Defined.

  Definition reluniv_ϕ_idtoiso_pre_post
             (u1 u2 : relative_universe J)
             (mor : relative_universe_mor u1 u2)
             (ϕ : ∏ (X : C) (f : J X --> U u1), reluniv_mor_ϕ mor X f)
             (X : C)
             (f g : J X --> U u1)
             (e_fg : f = g)
             (e_fg' : f ;; F_U mor = g ;; F_U mor)
    : idtoiso (! maponpaths (Xf u1 X) e_fg)
              ;; pr1 (ϕ X f)
              ;; idtoiso (maponpaths (Xf u2 X) e_fg')
      = pr1 (ϕ X g).
  Proof.
    assert (e_e : e_fg' = maponpaths (postcompose (F_U mor)) e_fg). { apply homset_property. }
    rewrite e_e. (* FIXME: is this ok? *)
    use (paths_rect
           _ _
           (λ k e_fk,
            idtoiso (! maponpaths (Xf u1 X) e_fk)
              ;; pr1 (ϕ X f)
              ;; idtoiso (maponpaths (Xf u2 X) (maponpaths (postcompose (F_U mor)) e_fk))
            = pr1 (ϕ X k)) _ _ e_fg).
    simpl.
    etrans. apply id_right.
    apply id_left.
  Defined.

  Definition reluniv_with_ϕ_precategory_axioms
    : is_precategory reluniv_with_ϕ_precategory_data.
  Proof.
    use make_is_precategory_one_assoc.
    - intros u1 u2 mor.
      use reluniv_mor_with_ϕ_eq.
      + apply id_left.
      + apply id_left.
      + intros X f. cbn.
        unfold reluniv_with_ϕ_Xf_compat.
        etrans. apply assoc'.
        etrans. apply maponpaths, pathsinv0, idtoiso_concat_pr.
        etrans. apply maponpaths_2, maponpaths_2.
        apply maponpaths, maponpaths, maponpathsinv0.
        etrans. apply maponpaths, maponpaths, maponpaths.
        apply pathsinv0, maponpathscomp0.
        apply reluniv_ϕ_idtoiso_pre_post.
    - intros u1 u2 mor.
      use reluniv_mor_with_ϕ_eq.
      + apply id_right.
      + apply id_right.
      + intros X f. cbn.
        etrans. apply assoc'.
        etrans. apply maponpaths, pathsinv0, idtoiso_concat_pr.
        etrans. apply assoc'.
        etrans. apply maponpaths, pathsinv0, idtoiso_concat_pr.

        etrans. 2: apply id_right.
        apply maponpaths.
        apply idtoiso_eq_idpath.

        etrans. apply pathsinv0, maponpaths, maponpathscomp0.
        etrans. apply pathsinv0, maponpathscomp0.
        apply pathsinv0.
        etrans. apply pathsinv0. apply PartA.maponpaths_idpath.
        apply maponpaths.
        apply homset_property.
    - intros a b c d g h k.
      use reluniv_mor_with_ϕ_eq.
      + apply assoc.
      + apply assoc.
      + intros X f. cbn.

        (* Oversimplified version of the equation:

           g f ; ( h (f;g) ; k ((f;g);h) ; idtoiso ) ; idtoiso ; compat
           =
           g f ; h (f;g) ; idtoiso ; k (f;(g;h)) ; idtoiso
        *)

        (* Step 1: get rid of (g h) *)
        etrans. apply assoc'.
        etrans. apply assoc'.
        apply pathsinv0.
        etrans. apply assoc'.
        etrans. apply assoc'.
        etrans. apply assoc'.
        apply maponpaths.

        (* Oversimplified version of the equation:

           h (f;g) ; k (f;g;h) ; idtoiso ; idtoiso ; compat
           =
           h (f;g) ; idtoiso ; (k (f;(g;h)) ; idtoiso)
        *)

        (* Step 2: get rid of h (f;g) *)
        apply pathsinv0.
        etrans. apply assoc'.
        etrans. apply assoc'.
        apply maponpaths.

        (* Oversimplified version of the equation:

           k (f;g;h) ; idtoiso ; idtoiso ; compat
           =
           idtoiso ; (k (f;(g;h)) ; idtoiso)
        *)

        (* Step 3: change k (f;(g;h)) to k (f;g;h) *)
        apply pathsinv0.
        etrans. apply maponpaths, maponpaths_2, pathsinv0.
        apply (reluniv_ϕ_idtoiso_pre_post
                 _ _ _ _ X _ _
                 (assoc' _ _ _)
                 (maponpaths (λ k, k ;; _) (assoc' _ _ _))).

        (* Oversimplified version of the equation:

           idtoiso ; (idtoiso ; k (f;g;h) ; idtoiso ; idtoiso)
           =
           k (f;g;h) ; idtoiso ; idtoiso ; compat
        *)

        (* Step 4: get rid of idtoiso on the left of k *)
        etrans. apply maponpaths, assoc'.
        etrans. apply maponpaths, assoc'.
        etrans. apply assoc.
        etrans. apply maponpaths_2, pathsinv0, idtoiso_concat_pr.
        etrans. apply maponpaths_2, idtoiso_eq_idpath.
        apply pathsinv0r.
        etrans. apply id_left.

        (* Oversimplified version of the equation:

           k (f;g;h) ; (idtoiso ; idtoiso)
           =
           k (f;g;h) ; idtoiso ; idtoiso ; compat
        *)

        (* Step 5: get rid of k *)
        apply maponpaths.

        (* Oversimplified version of the equation:

           idtoiso ; idtoiso
           =
           idtoiso ; idtoiso ; compat
        *)

        (* Step 6: reduce equality of idtoiso to equality of paths *)
        etrans. apply pathsinv0, idtoiso_concat_pr.
        etrans. 2: { apply maponpaths, idtoiso_concat_pr. }
        etrans. 2: { apply idtoiso_concat_pr. }
        apply maponpaths, maponpaths, pathsinv0.

        (* Step 7: factor out Xf d X *)
        etrans. apply pathsinv0, maponpaths, maponpathscomp0.
        etrans. apply pathsinv0, maponpathscomp0.
        apply pathsinv0.
        etrans. apply pathsinv0, maponpathscomp0.
        apply maponpaths.

        (* Step 8: complete the proof *)
        apply homset_property.
  Defined.

  Definition reluniv_with_ϕ_precat : precategory
    := ( reluniv_with_ϕ_precategory_data ,, reluniv_with_ϕ_precategory_axioms ).

  Definition isaset_reluniv_mor_with_ϕ
             (u1 u2 : relative_universe J)
    : isaset (reluniv_mor_with_ϕ u1 u2).
  Proof.
    apply isaset_total2.
    - apply isaset_gen_reluniv_mor.
    - intros mor.
      apply impred_isaset. intros X.
      apply impred_isaset. intros f.
      apply isaset_total2.
      + apply homset_property.
      + intros ϕ.
        apply isasetaprop.
        apply isapropdirprod.
        * apply homset_property.
        * apply homset_property.
  Defined.

  Definition reluniv_with_ϕ_has_homsets : has_homsets reluniv_with_ϕ_precat.
  Proof.
    unfold has_homsets.
    intros a b.
    apply isaset_reluniv_mor_with_ϕ.
  Defined.

  Definition reluniv_with_ϕ_cat : category
    := ( reluniv_with_ϕ_precat ,, reluniv_with_ϕ_has_homsets ).

End RelUniv_ϕ_Cat.

End RelUniv.

(** * Functors of relative universe categories *)

(** ** Lax commutative squares *)

Section Comm_Squares.
(* TODO: perhaps it would be better to unify this with the displayed arrow category. *)

Context {C : precategory}.

Definition comm_square
      {c c' : C} (f : c --> c')
      {d d' : C} (g : d --> d')
  := ∑ (hk : c --> d × c' --> d'), (pr1 hk ;; g = f ;; pr2 hk).

Definition dom_comm_square
      {c c' : C} {f : c --> c'}
      {d d' : C} {g : d --> d'}
    : comm_square f g -> c --> d
  := (@funcomp _ _ (fun _ => _) pr1 pr1).

Definition cod_comm_square
      {c c' : C} {f : c --> c'}
      {d d' : C} {g : d --> d'}
    : comm_square f g -> c' --> d'
  := (@funcomp _ _ _ pr1 (@pr2 _ (fun _ => _))).

Definition commutes_comm_square
      {c c' : C} {f : c --> c'}
      {d d' : C} {g : d --> d'}
    (hk : comm_square f g)
  : dom_comm_square hk ;; g = f ;; cod_comm_square hk
:= pr2 hk.

End Comm_Squares.

Section Functor_Squares.

(* Start by defining “pre-functor-squares”, with no commutativity,
  so that we can have a single pair of access functions [dom_functor],
  [cod_functor] which can (via coercions) be used for lax-, colax-, and
  pseudo-commutative squares alike. *)

Definition pre_functor_square
    {C D : precategory} (J : C ⟶ D)
    {C' D' : precategory} (J' : C' ⟶ D')
  : UU
:= (functor C C' × functor D D').

Definition dom_functor
    {C D : precategory} {J : C ⟶ D}
    {C' D' : precategory} {J' : C' ⟶ D'}
  : pre_functor_square J J' -> C ⟶ C'
:= pr1.

Definition cod_functor
    {C D : precategory} {J : C ⟶ D}
    {C' D' : precategory} {J' : C' ⟶ D'}
  : pre_functor_square J J' -> D ⟶ D'
:= pr2.

Definition lax_functor_square
    {C D : precategory} (J : functor C D)
    {C' D' : precategory} (J' : functor C' D')
  : UU
:= ∑ (FG : pre_functor_square J J'),
     nat_trans ((dom_functor FG) ∙ J')
               (J ∙ (cod_functor FG)).

Coercion pre_functor_square_of_lax_functor_square
    {C D : precategory} {J : functor C D}
    {C' D' : precategory} {J' : functor C' D'}
  : lax_functor_square J J' -> pre_functor_square J J'
:= pr1.

Definition make_lax_functor_square
    {C D : precategory} {J : C ⟶ D}
    {C' D' : precategory} {J' : C' ⟶ D'}
    (F : C ⟶ C') (G : D ⟶ D') (α : nat_trans (F ∙ J') (J ∙ G))
  : lax_functor_square J J'
:= ((F,G) ,, α).

Definition commutes_lax_functor_square
    {C D : precategory} {J : C ⟶ D}
    {C' D' : precategory} {J' : C' ⟶ D'}
    (FG : lax_functor_square J J')
  : nat_trans _ _
:= pr2 FG.

End Functor_Squares.

Section Relative_Universe_Functor.

Context {C D : category} {J : functor C D} (U : relative_universe J)
        {C' D' : category} {J' : functor C' D'} (U' : relative_universe J')
        (FGα : lax_functor_square J J').

Definition relative_universe_functor : UU.
Proof.
  set (F := dom_functor FGα).
  set (G := cod_functor FGα).
  set (α := commutes_lax_functor_square FGα).
  simple refine ((∑ (t : _) (ϕ : _), _ × _) × _).
  - (* t : comparison square between the universes *)
    exact (comm_square (# G (mor U)) (mor U')).
  - (* ϕ : comparison maps between “context extensions” *)
    refine (forall (X:C) (f : J X --> base U), F _ --> _).
    + exact (fpb_ob (U X f)).
    + refine (fpb_ob (U' (F X) _)).
      refine (_ ;; cod_comm_square t).
      refine (_ ;; # G f).
      exact (α _).
  - refine (forall (X:C) (f : J X --> base U), _ × _).
    + (* ϕ is over the base *)
      exact (ϕ X f ;; fp _ = # F (fp _)).
    + (* ϕ commutes with the canonical pullback morphism *)
      exact (#J' (ϕ X f) ;; (fq _)
             = α (fpb_ob (U X f)) ;; #G (fq _) ;; dom_comm_square t).
  - (* ϕ is natural *)
    (* TODO: give this, once we have added the missing functoriality condition in the definition of relative universes. *)
    exact unit.
  - (* G preserves the canonical pullbacks *)
    refine (forall (X:C) (f : J X --> base U),
                isPullback (functor_on_square _ _ G _)).
    exact (pr1 (pr2 (U X f))). (* TODO: access functions for [commutes_and_is_pullback] and [fpullback] ! *)
Defined.

End Relative_Universe_Functor.


Set Primitive Projections.
Set Universe Polymorphism.

Record Pack (A : nat -> Type) := mkPack {
  wit : nat;
  val : A wit;
}.

Arguments wit {_} _.
Arguments val {_} _.

Record prod (A B : Type) := pair { fst : A; snd : B }.

Arguments pair {_ _} _ _.
Arguments fst {_ _} _.
Arguments snd {_ _} _.

Fixpoint nTYPE (A : Type) (n : nat) := match n with
| 0 => A
| S n => prod A (nTYPE A n)
end.

Definition TYPE := Pack (nTYPE Type).

Definition El (T : TYPE) : Type :=
  (fix F (n : nat) {struct n} :=
  match n as wit return nTYPE Type wit -> Type with
  | 0 => fun T => Pack (nTYPE T)
  | S n => fun T => prod (Pack (nTYPE (fst T))) (F n (snd T))
  end)
    T.(wit) T.(val)
.

Definition Typeᴸ : TYPE := mkPack (nTYPE Type) 0 Type.

Check Typeᴸ : El Typeᴸ.

Definition Prodᴸ (A : TYPE) (B : El A -> TYPE) : TYPE :=
  mkPack _ 0 (forall x : El A, El (B x)).

Definition Lamᴸ {A : TYPE} {B : forall x : El A, TYPE}
  (f : forall x : El A, El (B x)) : El (Prodᴸ A B) :=
  mkPack _ 0 f.

Definition union (A : Type) (x y : Pack (nTYPE A)) : Pack (nTYPE A) := {|
  wit := S (x.(wit) + y.(wit));
  val :=
    (fix F (n : nat) :=
    match n return nTYPE A n -> forall m, nTYPE A m -> nTYPE A (S n + m) with
    | 0 => fun T m U => pair T U
    | S n => fun T m U => pair T.(fst) (F n T.(snd) m U)
    end) x.(wit) x.(val) y.(wit) y.(val)
|}.

Definition ambᴸ (A : TYPE) (x y : El A) : El A.
Proof.
destruct A as [n A]; unfold El in *.
revert A x y; induction n as [|n F]; intros A x y; cbn in *.
+ exact (union A x y).
+ refine (pair (union _ (fst x) (fst y)) _).
  apply (F (snd A) (snd x) (snd y)).
Defined.

Definition Appᴸ {A : TYPE} {B : forall x : El A, TYPE}
  (f : El (Prodᴸ A B)) (x : El A) : El (B x) :=
  (fix F (n : nat) : nTYPE (forall x : El A, El (B x)) n -> El (B x) :=
  match n with
  | 0 => fun f => f x
  | S n => fun f => ambᴸ _ (f.(fst) x) (F n f.(snd))
  end)
    f.(wit) f.(val)
.

Check eq_refl : (fun A B f x => @Appᴸ A B (Lamᴸ f) x) = (fun A B f x => f x).

Lemma consistent : El (Prodᴸ Typeᴸ (fun A => A)) -> False.
Proof.
intros [n F].
unfold Prodᴸ in F; cbn [val] in F.
cut ((forall x : Pack (nTYPE Type), El x) -> False).
+ intros H; destruct n.
  - cbn in F; apply H, F.
  - destruct F as [F _].
    cbn in F; apply H, F.
+ clear; intros f.
  specialize (f (mkPack _ 0 False)).
  cbn in f.
  destruct f as [[|] f]; cbn in *; intuition.
Qed.

Definition boolᴸ : TYPE := mkPack _ 0 bool.
Definition trueᴸ : El boolᴸ := mkPack _ 0 true.
Definition falseᴸ : El boolᴸ := mkPack _ 0 false.


From BV Require Import BVList.
Require Import List Bool NArith Psatz (*Int63*) ZArith Nnat.

From Hammer Require Import Hammer Reconstr.

 Include RAW2BITVECTOR(RAWBITVECTOR_LIST).

(*------------------------------Addition------------------------------*)
Theorem bvadd_dep: forall (n : N), forall (s t : bitvector n),
    iff
    (exists (x : bitvector n), bv_eq (bv_add x s) t = true)
    True.
Proof. intros n s t.
        split; intro A.
        - easy.
        - exists (bv_subt' t s).
          now rewrite bv_add_subst_opp.
Qed.

(* (exists x, (s >>a s) <u t) => ((s <u t \/ s >=s 0) /\ t != 0) *)
Theorem bvashr_ult2_ltr : forall (n : N), forall (s t : bitvector n),
    (exists (x : bitvector n), (bv_ult (bv_ashr_a s x) t = true)) ->
    (((bv_ult s t = true) \/ (bv_slt s (zeros n)) = false) /\
    (bv_eq t (zeros n)) = false).
Proof. intros. split.
        destruct H as (x, H2).
        destruct s as (s, H).
        destruct t as (t, H0).
        destruct x as (x, H1).
        unfold bv_ult, bv_slt, bv_ashr_a, bv in *. cbn in *.
        rewrite RAWBITVECTOR_LIST.bv_ult_nat in *.
        unfold RAWBITVECTOR_LIST.bv_ashr_a in *.
        rewrite H, H1, N.eqb_refl in H2.
        unfold RAWBITVECTOR_LIST.ashr_aux_a,
        RAWBITVECTOR_LIST.list2nat_be_a, RAWBITVECTOR_LIST.ashr_n_bits_a in *.
        case_eq ((N.to_nat (RAWBITVECTOR_LIST.list2N x) <? length s)%nat); intros.
        - rewrite H3 in H2.
          case_eq (eqb (last s false) false); intros.
          + rewrite H4 in H2.
            assert ((last s false) = false).
            { destruct ((last s false)); intros; cbn in H4; easy. }
            unfold RAWBITVECTOR_LIST.zeros.
            specialize (RAWBITVECTOR_LIST.last_mk_list_false (N.to_nat (RAWBITVECTOR_LIST.size s))); intros.
            rewrite RAWBITVECTOR_LIST.bv_slt_ult_last_eq with (d := false). (*[ | now rewrite H5, H6].*)
            rewrite RAWBITVECTOR_LIST.bv_ult_nat in *.
            right.
            unfold RAWBITVECTOR_LIST.bv2nat_a, RAWBITVECTOR_LIST.list2nat_be_a, RAWBITVECTOR_LIST.size
            in *. rewrite <- H.
            now rewrite Nat2N.id, RAWBITVECTOR_LIST.list_lt_false.
	          Reconstr.reasy (@Coq.NArith.BinNat.N.eqb_refl,
              @RAWBITVECTOR_LIST.length_mk_list_false,
              @Coq.NArith.Nnat.N2Nat.id) (@RAWBITVECTOR_LIST.size).
            Reconstr.reasy Reconstr.Empty Reconstr.Empty.
          + rewrite H4 in H2.
            unfold RAWBITVECTOR_LIST.bv2nat_a, RAWBITVECTOR_LIST.list2nat_be_a,
             RAWBITVECTOR_LIST.zeros, RAWBITVECTOR_LIST.size in *.
            left.
            destruct (RAWBITVECTOR_LIST.n_cases_all (N.to_nat (RAWBITVECTOR_LIST.list2N x))).
            * rewrite H5 in *.
              rewrite RAWBITVECTOR_LIST.skip0 in H2.
              assert (RAWBITVECTOR_LIST.mk_list_true 0 = nil) by easy.
              now rewrite H6, app_nil_r in H2.
            * destruct (RAWBITVECTOR_LIST.list_cases_all_true s).
              ** rewrite H6 in H2.
                 rewrite RAWBITVECTOR_LIST.skipn_nm in H2; [ | easy].
                 now rewrite H6.
              ** specialize (@RAWBITVECTOR_LIST.skipn_gt (N.to_nat (RAWBITVECTOR_LIST.list2N x)) s H5 H3 H6); intros.
                 apply Nat.ltb_lt.
                 apply Nat.ltb_lt in H2.
                 apply Nat.ltb_lt in H7.
                 lia.
        - rewrite H3 in H2.
          case_eq (eqb (last s false) false); intros.
          + rewrite H4 in H2.
            assert ((last s false) = false).
            { destruct ((last s false)); intros; cbn in H4; easy. }
            unfold zeros.
            specialize (RAWBITVECTOR_LIST.last_mk_list_false (N.to_nat (RAWBITVECTOR_LIST.size s))); intros.
            rewrite RAWBITVECTOR_LIST.bv_slt_ult_last_eq with (d := false).
            rewrite RAWBITVECTOR_LIST.bv_ult_nat in *.
            right. unfold RAWBITVECTOR_LIST.bv2nat_a, RAWBITVECTOR_LIST.list2nat_be_a,
            RAWBITVECTOR_LIST.zeros,
            RAWBITVECTOR_LIST.size in *.
            rewrite <- H.
            now rewrite Nat2N.id, RAWBITVECTOR_LIST.list_lt_false.
            Reconstr.reasy (@RAWBITVECTOR_LIST.zeros_size, @Coq.NArith.BinNat.N.eqb_refl) Reconstr.Empty.
            	Reconstr.reasy Reconstr.Empty (@RAWBITVECTOR_LIST.zeros).
          + rewrite H4 in H2. unfold RAWBITVECTOR_LIST.bv_slt, RAWBITVECTOR_LIST.slt_list.
            unfold RAWBITVECTOR_LIST.bv2nat_a, RAWBITVECTOR_LIST.list2nat_be_a, RAWBITVECTOR_LIST.size in *.
            left.
            destruct (RAWBITVECTOR_LIST.list_cases_all_true s).
            * now rewrite H5.
            * specialize (@RAWBITVECTOR_LIST.pow_ltb s H5); intros.
              apply Nat.ltb_lt.
              apply Nat.ltb_lt in H2.
              apply Nat.ltb_lt in H6.
              lia.
        - unfold RAWBITVECTOR_LIST.bv_ashr_a.
          rewrite H, H1, N.eqb_refl.
          specialize (@RAWBITVECTOR_LIST.length_ashr_aux_a s x (N.to_nat n)); intros.
          unfold RAWBITVECTOR_LIST.size in *.
          rewrite <- H3.
          Reconstr.reasy (@NBoolEqualityFacts.eqb_refl, @Coq.NArith.Nnat.N2Nat.id) Reconstr.Empty.
	        Reconstr.reasy (@Coq.NArith.Nnat.Nat2N.id) (@RAWBITVECTOR_LIST.bitvector).
	        Reconstr.reasy (@Coq.NArith.Nnat.Nat2N.id) (@RAWBITVECTOR_LIST.bitvector).
        - Reconstr.reasy (@Coq.NArith.BinNat.N.eqb_refl) Reconstr.Empty.
        - destruct H as (x, H2).
          destruct s as (s, H).
          destruct t as (t, H0).
          destruct x as (x, H1).
          unfold bv_eq, bv_ult, bv_slt, bv_ashr_a, bv in *. cbn in *.

          unfold RAWBITVECTOR_LIST.bv_eq. rewrite H0.
          unfold RAWBITVECTOR_LIST.zeros, RAWBITVECTOR_LIST.size.
          rewrite RAWBITVECTOR_LIST.length_mk_list_false, N2Nat.id, N.eqb_refl.
          unfold RAWBITVECTOR_LIST.bits.
          rewrite RAWBITVECTOR_LIST.bv_ult_nat in *.
          unfold RAWBITVECTOR_LIST.bv_ashr_a in *.
          rewrite H, H1, N.eqb_refl in H2.
          specialize (@RAWBITVECTOR_LIST.bv2nat_gt0 t (RAWBITVECTOR_LIST.bv2nat_a (RAWBITVECTOR_LIST.ashr_aux_a s x)) H2); intros.
          rewrite <- H0. unfold RAWBITVECTOR_LIST.size.
          rewrite Nat2N.id.
          now apply RAWBITVECTOR_LIST.List_neq2 in H3.
          unfold RAWBITVECTOR_LIST.bv_ashr_a.
          rewrite H, H1, N.eqb_refl.
          specialize (@RAWBITVECTOR_LIST.length_ashr_aux_a s x (N.to_nat n)); intros.
          unfold RAWBITVECTOR_LIST.size in *.
          rewrite <- H3.
          Reconstr.reasy (@NBoolEqualityFacts.eqb_refl, @Coq.NArith.Nnat.N2Nat.id) Reconstr.Empty.
          lia. lia.
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import String Lists.List.
Import ListNotations.
Open Scope string.
Open Scope list.
From Utils Require Import Utils.
From Pyrosome Require Import Theory.Core Elab.Elab Tools.Matches Lang.SimpleVSubst.
Import Core.Notations.

Require Coq.derive.Derive.

Definition stlc_def : lang :=
  {[l/subst
  [:| "t" : #"ty", "t'": #"ty"
      -----------------------------------------------
      #"->" "t" "t'" : #"ty"
  ];
  [:| "G" : #"env",
       "A" : #"ty",
       "B" : #"ty",
       "e" : #"exp" (#"ext" "G" "A") "B"
       -----------------------------------------------
       #"lambda" "A" "e" : #"val" "G" (#"->" "A" "B")
  ];
  [:| "G" : #"env",
       "A" : #"ty",
       "B" : #"ty",
       "e" : #"exp" "G" (#"->" "A" "B"),
       "e'" : #"exp" "G" "A"
       -----------------------------------------------
       #"app" "e" "e'" : #"exp" "G" "B"
  ];
  [:= "G" : #"env",
      "A" : #"ty",
      "B" : #"ty",
      "e" : #"exp" (#"ext" "G" "A") "B",
      "v" : #"val" "G" "A"
      ----------------------------------------------- ("STLC-beta")
      #"app" (#"ret" (#"lambda" "A" "e")) (#"ret" "v")
      = #"exp_subst" (#"snoc" #"id" "v") "e"
      : #"exp" "G" "B"
  ]
  ]}.

Derive stlc
       SuchThat (elab_lang_ext (exp_subst++value_subst) stlc_def stlc)
       As stlc_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve stlc_wf : elab_pfs.


From Undecidability.L Require Import L Tactics.LTactics AbstractMachines.LargestVar.

From Complexity.L Require Import AbstractHeapMachineDef UnfoldTailRec AbstractHeapMachine.
From Complexity.L.AbstractMachines.Computable Require Import Unfolding HeapMachine Shared EvalForTime.

From Undecidability.L.Datatypes Require Import Lists LProd.
From Complexity.L.Datatypes Require Import LBinNums.
From Undecidability.L.Functions Require Import UnboundIteration Proc.
From Complexity.L.Functions Require Import BinNums BinNumsCompare.

Definition evalForTimeBool (checkFor:bool) (fuel : N) (s:term) := match evalForTime fuel s with
                                                   Some (g,H) => match unfoldBoolean H g with
                                                                  None => false
                                                                | Some b => if checkFor then b else negb b
                                                                end
                                                 | None => false
                                                 end.

Definition t__evalForTimeBool (largestVar size:nat) fuel := t__evalForTime largestVar size fuel+ unfoldBool_time (4*fuel+1) largestVar + 22.

Lemma evalForTimeBool_spec (checkFor :bool) (s:term) (fuel : N):
  reflect (closed s /\ s ⇓(<= N.to_nat fuel) (enc checkFor)) (evalForTimeBool checkFor fuel s).
Proof.
  unfold evalForTimeBool.
  eassert (H':=evalForTime_spec _ _).
  destruct evalForTime as [[]|] eqn:eq;rewrite eq.
  2:{ econstructor. easy. }
  destruct H' as (?&_&H').
  destruct unfoldBoolean eqn:eq'.
  -eapply iff_reflect.  destruct H' as (?&eq''&?).
   eapply unfoldBoolean_sound in eq'.
   replace x with (enc b) in *.
   2:{ eapply reprC_functional. all:easy. }
   (destruct b,checkFor;cbn).
   all:intuition. all:eapply inj_enc,eval_unique. all:eapply evalLe_eval_subrelation;easy.
  -econstructor. intros (_&H'').
   destruct H' as (?&H'&?).
   replace x with (enc checkFor) in *.
   2:{  all:eapply eval_unique. all:eapply evalLe_eval_subrelation;easy. }
   eapply unfoldBoolean_complete in H'. easy.
Qed.

#[export]
Instance evalForTimeBool__comp : computableTime' evalForTimeBool (fun _ _ => (1,fun fuel _ => (1,fun s _ => (t__evalForTimeBool (largestVar s) (size s) (N.to_nat fuel),tt)))).
Proof.
  unfold evalForTimeBool. extract. solverec.
  all:unfold t__evalForTimeBool. 4:lia.
  all:eassert (H':=evalForTime_spec _ _).
  all:rewrite H in H'.
  all:destruct H' as (?&(?&?&R)&?).
  all:rewrite unfoldBool_time_mono with (l':=(4 * N.to_nat x0 + 1)) (n':=(largestVar x1));[try lia | |].
  all:try (etransitivity;[eapply AbstractHeapMachine.length_H;eassumption|lia]).
  all:rewrite largestVarH_leq with (1:=R).
  all:rewrite largestVarC_V_leq with (1:=R);[|easy].
  all:now rewrite Nat.max_id.
Qed.


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

(* ** CM1_HALT is undecidable *)

(*
  Undecidability Results(s):
    One Counter Machine Halting with Denominators at most 4 (CM1_HALT)
*)

Require Import Undecidability.Synthetic.Undecidability.

Require Import Undecidability.CounterMachines.CM1.
Require Import Undecidability.CounterMachines.Reductions.CM2_HALT_to_CM1_HALT.

Require Import Undecidability.CounterMachines.CM2_undec.

(* Undecidability of The One Counter Machine (with Denominators at most 4) Halting Problem *)
Lemma CM1_HALT_undec : undecidable CM1_HALT.
Proof.
  apply (undecidability_from_reducibility CM2_HALT_undec).
  exact CM2_HALT_to_CM1_HALT.reduction.
Qed.

Check CM1_HALT_undec.


Require Import List.
Require Import ListSet.
Require Import Coqlib.
Require Import Metatheory.
Require Import Maps.
Require Import cfg.
Require Import Dipaths.

Require Import syntax.
Require Import infrastructure.
Require Import infrastructure_props.
Import LLVMsyntax.
Import LLVMinfra.

(* This file proves more properties of reachability. *)
Lemma reachable_has_entry: forall f l1 (Hrd: reachable f l1),
  getEntryBlock f <> None.
Proof.
  intros.
  unfold reachable in Hrd.
  intro EQ. rewrite EQ in Hrd. inv Hrd.
Qed.

Lemma reachable_dec: forall (f:fdef) (l1:l), reachable f l1 \/ ~ reachable f l1.
Proof.
  unfold reachable.
  intros.
  destruct (getEntryBlock f) as [[]|].
    apply ACfg.reachable_dec.
    right. intro H. inv H.
Qed.

Lemma reachable_entrypoint:
  forall (f:fdef) l0 s0,
    getEntryBlock f = Some (l0, s0) ->
    reachable f l0.
Proof.
  intros f l0 s0 Hentry. unfold reachable.
  rewrite Hentry. exists V_nil. exists A_nil. apply DW_null.
  eapply entry_in_vertexes; eauto.
Qed.

Module DecRD.

Section RdSucc.

Variable f:fdef.

Lemma reachable_successors:
  forall l0 cs ps tmn l1 (Hinvx: vertexes_fdef f (index l1)),
  uniqFdef f ->
  blockInFdefB (l0, stmts_intro cs ps tmn) f ->
  In l1 (successors_terminator tmn) ->
  reachable f l0 ->
  reachable f l1.
Proof.
  intros l0 cs ps tmn l1 Hinvx HuniqF HbInF Hin.
  unfold reachable. intro Hreach.
  remember (getEntryBlock f) as R.
  destruct R; auto.
  destruct b as [le ? ? ?].
  destruct Hreach as [vl [al Hreach]].
  exists (index l0::vl). exists (A_ends (index l1) (index l0)::al).
  apply DW_step; auto.
    eapply successor_in_arcs; eauto.
Qed.

End RdSucc.

End DecRD.


(** * Variables *)

From Coq Require Import FMaps FSets ZArith.
From mathcomp Require Import ssreflect ssrbool eqtype.
From Common Require Import FMaps FSets ZAriths.

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

Open Scope N_scope.

Definition var : Set := N.

Module VarOrder := NOrder.

(* Variable sets. *)

Module VS.
  Module S := FSets.Make(NOrder).
  Include S.

  (* Generate a new variable. *)
  Definition new_var (s : t) : var :=
    match max_elt s with
    | Some v => v + 1
    | None => 0
    end.

  Lemma new_var_is_new :
    forall (s : t), ~~ mem (new_var s) s.
  Proof.
    move=> s.
    apply/negP => Hmem.
    move: (mem_2 Hmem) => {Hmem}.
    rewrite /new_var.
    case H: (max_elt s).
    - move=> Hin.
      move: (max_elt_2 H Hin) => Hfalse.
      apply: Hfalse.
      exact: NltnSn.
    - move: (max_elt_3 H) => {H} H Hin.
      move: (H 0) => Hnotin; apply: Hnotin; exact: Hin.
  Qed.

End VS.

Module VSLemmas := FSetLemmas VS.

(* Variable maps. *)

Module VM.
   Module M := FMapList.Make(NOrder).
   Module Lemmas := FMapLemmas(M).
   Include M.

   Section Aux.

     Variable elt : Type.

     (* Convert a variable map to a variable set. *)
     Definition vset (m : M.t elt) : VS.t :=
       fold (fun x _ s => VS.add x s) m VS.empty.

     Lemma mem_vset E :
       forall x, mem x E -> VS.mem x (vset E).
     Proof.
       rewrite /vset.
       eapply Lemmas.P.fold_rec.
       - move=> m Hempty x Hmem.
         apply: False_ind.
         exact: (Lemmas.empty_mem Hempty Hmem).
       - move=> x e m E1 E2 _ _ Hadd Hind y Hmem.
         case Hyx: (y == x).
         + exact: (VSLemmas.mem_add_eq _ Hyx).
         + move/negP: Hyx => Hyx.
           rewrite (VSLemmas.mem_add_neq _ Hyx).
           apply: Hind.
           move: (Hadd y) => {Hadd}.
           rewrite (VM.Lemmas.find_add_neq _ _ Hyx) => {Hyx} Hfind.
           rewrite -(VM.Lemmas.find_eq_mem_eq Hfind).
           exact: Hmem.
     Qed.

     (* Generate a new variable. *)
     Definition new_var (m : t elt) : var :=
       match Lemmas.max_elt m with
       | Some (v, _) => v + 1
       | None => 0
       end.

     Lemma new_var_is_new :
       forall (m : t elt), ~~ mem (new_var m) m.
     Proof.
       move=> m.
       apply/negP => Hmem.
       move: (mem_2 Hmem) => {Hmem}.
       rewrite /new_var.
       move: (refl_equal (Lemmas.max_elt m)).
       move: {2}(Lemmas.max_elt m) => x.
       destruct x.
       - destruct p as [x ty].
         move=> Hmax; rewrite Hmax => Hin.
         move: (Lemmas.max_elt_Above Hmax) => Habove.
         have: In (x + 1) (remove x m).
         + case: Hin => ty1 Hmapsto.
           exists ty1.
           apply: (remove_2 _ Hmapsto).
           move=> {Hmax Habove Hmapsto ty ty1 m} Heq.
           move: (NltnSn x).
           rewrite {1}(eqP Heq).
           rewrite Nltnn.
           discriminate.
         + move=> Hin1.
           move: (Habove _ Hin1) => Hlt.
           move: (Nltn_trans Hlt (NltnSn x)).
           rewrite Nltnn.
           discriminate.
       - move=> Hmax; rewrite Hmax => Hin.
         move: (Lemmas.max_elt_Empty Hmax) => Hempty.
         case: Hin => ty Hmapsto.
         move: (Hempty 0 ty).
         apply; assumption.
     Qed.

   End Aux.

End VM.

Close Scope N_scope.

(** Variables for SSA *)

From Common Require Import SsrOrdered.

Module SSAVarOrder := (MakeProdOrdered VarOrder NOrder).

Module SSAVS := FSets.Make SSAVarOrder.

Module SSAVSLemmas := FSetLemmas SSAVS.

Definition svar (x : SSAVarOrder.t) := fst x.

Definition sidx (x : SSAVarOrder.t) := snd x.

Hint Unfold svar sidx.

Definition svar_notin v vs : Prop := forall i, ~~ SSAVS.mem (v, i) vs.

Lemma svar_notin_singleton1 v x :
  svar_notin v (SSAVS.singleton x) -> v != svar x.
Proof.
  destruct x as [x i]. move=> /= H; move: (SSAVSLemmas.not_mem_singleton1 (H i)).
  move=> Hne; apply/negP => Heq; apply: Hne. rewrite (eqP Heq).
  exact: SSAVS.E.eq_refl.
Qed.

Lemma svar_notin_singleton2 v x :
  v != svar x -> svar_notin v (SSAVS.singleton x).
Proof.
  move/negP=> Hne i. apply/negP => Heq; apply: Hne.
  move: (SSAVSLemmas.mem_singleton1 Heq) => {Heq}. destruct x as [x j] => /=.
  move/eqP => [Hv Hi]. by rewrite Hv.
Qed.

Lemma svar_notin_union1 v vs1 vs2 :
  svar_notin v (SSAVS.union vs1 vs2) -> svar_notin v vs1.
Proof.
  move=> H i. move: (H i) => {H} H. exact: (proj1 (SSAVSLemmas.not_mem_union1 H)).
Qed.

Lemma svar_notin_union2 v vs1 vs2 :
  svar_notin v (SSAVS.union vs1 vs2) -> svar_notin v vs2.
Proof.
  move=> H i. move: (H i) => {H} H. exact: (proj2 (SSAVSLemmas.not_mem_union1 H)).
Qed.

Lemma svar_notin_union3 v vs1 vs2 :
  svar_notin v vs1 -> svar_notin v vs2 ->
  svar_notin v (SSAVS.union vs1 vs2).
Proof.
  move=> H1 H2 i. move: (H1 i) (H2 i) => {H1 H2} H1 H2.
  exact: (SSAVSLemmas.not_mem_union2 H1 H2).
Qed.

Lemma svar_notin_add1 v x vs :
  svar_notin v (SSAVS.add x vs) -> v != svar x.
Proof.
  destruct x as [x i] => /= H. move: (H i) => {H} H.
  move: (SSAVSLemmas.not_mem_add1 H) => {H}. move=> [H _]; apply/negP => Heq.
  apply: H. rewrite (eqP Heq); exact: eqxx.
Qed.

Lemma svar_notin_add2 v x vs :
  svar_notin v (SSAVS.add x vs) -> svar_notin v vs.
Proof.
  move=> H i. move: (H i) => {H} H. move: (SSAVSLemmas.not_mem_add1 H) => {H}.
  move=> [_ H]; exact: H.
Qed.

Lemma svar_notin_replace v vs1 vs2 :
  SSAVS.Equal vs1 vs2 -> svar_notin v vs1 -> svar_notin v vs2.
Proof.
  move=> H H1 x. rewrite -H. exact: H1.
Qed.

Lemma svar_notin_subset v vs1 vs2 :
  SSAVS.subset vs1 vs2 -> svar_notin v vs2 -> svar_notin v vs1.
Proof.
  move=> H H2 x. apply/negP => H1. move: (SSAVSLemmas.mem_subset H1 H) => Hmem.
  move/negP: (H2 x). apply. exact: Hmem.
Qed.

(** Generate new SSA variables *)

From Common Require Import Nats.

Definition max_svar (vs : SSAVS.t) : VarOrder.t :=
  match SSAVS.max_elt vs with
  | Some v => svar v
  | None => 0%N
  end.

Definition new_svar (vs : SSAVS.t) : VarOrder.t :=
  N.succ (max_svar vs).

Lemma N_ltb_succ v : (v <? N.succ v)%N.
Proof.
  apply: (proj2 (N.ltb_lt v (N.succ v))). exact: N.lt_succ_diag_r.
Qed.

Lemma V_ltb_succ v i j : SSAVarOrder.ltb (v, j) ((N.succ v), i).
Proof.
  rewrite /SSAVarOrder.ltb /SSAVarOrder.M.lt /VarOrder.ltb /NOrderMinimal.lt /=.
  rewrite N_ltb_succ. exact: is_true_true.
Qed.

Lemma new_svar_notin vs : svar_notin (new_svar vs) vs.
Proof.
  rewrite /new_svar /max_svar. set x := SSAVS.max_elt vs.
  have: SSAVS.max_elt vs = x by reflexivity. case x.
  - move=> v Hmax i. apply/negP => Hmem. apply: (SSAVSLemmas.max_elt2 Hmax Hmem).
    exact: V_ltb_succ.
  - move=> Hnone i. apply: SSAVSLemmas.is_empty_mem.
    exact: (SSAVSLemmas.max_elt3 Hnone).
Qed.


Section ml.
Variables A B:Prop.
Theorem Andelr: and A B -> B.
Proof.
    intro Hab.
    case Hab.
    intros Ha Hb.
    assumption.
    (* destruct Hab.
    assumption. *)
Qed.
End ml.

Check Andelr.


From iris.proofmode Require Import tactics.
From iris.program_logic Require Export weakestpre.
From iris_examples.logrel.F_mu Require Export lang typing.
From iris.algebra Require Import list.
Import uPred.

(** interp : is a unary logical relation. *)
Section logrel.
  Context `{irisG F_mu_lang Σ}.
  Notation D := (valO -n> iPropO Σ).
  Implicit Types τi : D.
  Implicit Types Δ : listO D.
  Implicit Types interp : listO D → D.

  Program Definition ctx_lookup (x : var) : listO D -n> D := λne Δ,
    from_option id (cconst True)%I (Δ !! x).
  Solve Obligations with solve_proper.

  Definition interp_unit : listO D -n> D := λne Δ w, (⌜w = UnitV⌝)%I.

  Program Definition interp_prod
      (interp1 interp2 : listO D -n> D) : listO D -n> D := λne Δ w,
    (∃ w1 w2, ⌜w = PairV w1 w2⌝ ∧ interp1 Δ w1 ∧ interp2 Δ w2)%I.
  Solve Obligations with repeat intros ?; simpl; solve_proper.

  Program Definition interp_sum
      (interp1 interp2 : listO D -n> D) : listO D -n> D := λne Δ w,
    ((∃ w1, ⌜w = InjLV w1⌝ ∧ interp1 Δ w1) ∨ (∃ w2, ⌜w = InjRV w2⌝ ∧ interp2 Δ w2))%I.
  Solve Obligations with repeat intros ?; simpl; solve_proper.

  Program Definition interp_arrow
      (interp1 interp2 : listO D -n> D) : listO D -n> D := λne Δ w,
    (□ ∀ v, interp1 Δ v → WP App (# w) (# v) {{ interp2 Δ }})%I.
  Solve Obligations with repeat intros ?; simpl; solve_proper.

  Program Definition interp_forall
      (interp : listO D -n> D) : listO D -n> D := λne Δ w,
    (□ ∀ τi : D,
      ⌜∀ v, Persistent (τi v)⌝ → WP TApp (# w) {{ interp (τi :: Δ) }})%I.
  Solve Obligations with repeat intros ?; simpl; solve_proper.

  Definition interp_rec1
      (interp : listO D -n> D) (Δ : listO D) (τi : D) : D := λne w,
    (□ (∃ v, ⌜w = FoldV v⌝ ∧ ▷ interp (τi :: Δ) v))%I.

  Global Instance interp_rec1_contractive
    (interp : listO D -n> D) (Δ : listO D) : Contractive (interp_rec1 interp Δ).
  Proof. by solve_contractive. Qed.

  Lemma fixpoint_interp_rec1_eq (interp : listO D -n> D) Δ x :
    fixpoint (interp_rec1 interp Δ) x ≡ interp_rec1 interp Δ (fixpoint (interp_rec1 interp Δ)) x.
  Proof. exact: (fixpoint_unfold (interp_rec1 interp Δ) x). Qed.

  Program Definition interp_rec (interp : listO D -n> D) : listO D -n> D := λne Δ,
    fixpoint (interp_rec1 interp Δ).
  Next Obligation.
    intros interp n Δ1 Δ2 HΔ; apply fixpoint_ne => τi w. solve_proper.
  Qed.

  Fixpoint interp (τ : type) : listO D -n> D :=
    match τ return _ with
    | TUnit => interp_unit
    | TProd τ1 τ2 => interp_prod (interp τ1) (interp τ2)
    | TSum τ1 τ2 => interp_sum (interp τ1) (interp τ2)
    | TArrow τ1 τ2 => interp_arrow (interp τ1) (interp τ2)
    | TVar x => ctx_lookup x
    | TForall τ' => interp_forall (interp τ')
    | TRec τ' => interp_rec (interp τ')
    end%I.
  Notation "⟦ τ ⟧" := (interp τ).

  Definition interp_env (Γ : list type)
      (Δ : listO D) (vs : list val) : iProp Σ :=
    (⌜length Γ = length vs⌝ ∗ [∗] zip_with (λ τ, ⟦ τ ⟧ Δ) Γ vs)%I.
  Notation "⟦ Γ ⟧*" := (interp_env Γ).

  Definition interp_expr (τ : type) (Δ : listO D) (e : expr) : iProp Σ :=
    WP e {{ ⟦ τ ⟧ Δ }}%I.

  Class env_Persistent Δ :=
    ctx_persistent : Forall (λ τi, ∀ v, Persistent (τi v)) Δ.
  Global Instance ctx_persistent_nil : env_Persistent [].
  Proof. by constructor. Qed.
  Global Instance ctx_persistent_cons τi Δ :
    (∀ v, Persistent (τi v)) → env_Persistent Δ → env_Persistent (τi :: Δ).
  Proof. by constructor. Qed.
  Global Instance ctx_persistent_lookup Δ x v :
    env_Persistent Δ → Persistent (ctx_lookup x Δ v).
  Proof. intros HΔ; revert x; induction HΔ=>-[|?] /=; apply _. Qed.
  Global Instance interp_persistent τ Δ v :
    env_Persistent Δ → Persistent (⟦ τ ⟧ Δ v).
  Proof.
    revert v Δ; induction τ=> v Δ HΔ; simpl; try apply _.
    rewrite /Persistent fixpoint_interp_rec1_eq /interp_rec1 /= intuitionistically_into_persistently.
    by apply persistently_intro'.
  Qed.
  Global Instance interp_env_base_persistent Δ Γ vs :
  env_Persistent Δ → TCForall Persistent (zip_with (λ τ, ⟦ τ ⟧ Δ) Γ vs).
  Proof.
    intros HΔ. revert vs.
    induction Γ => vs; simpl; destruct vs; constructor; apply _.
  Qed.
  Global Instance interp_env_persistent Γ Δ vs :
    env_Persistent Δ → Persistent (⟦ Γ ⟧* Δ vs) := _.

  Lemma interp_weaken Δ1 Π Δ2 τ :
    ⟦ τ.[upn (length Δ1) (ren (+ length Π))] ⟧ (Δ1 ++ Π ++ Δ2)
    ≡ ⟦ τ ⟧ (Δ1 ++ Δ2).
  Proof.
    revert Δ1 Π Δ2. induction τ=> Δ1 Π Δ2; simpl; auto.
    - intros w; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - intros w; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - intros w; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - apply fixpoint_proper=> τi w /=.
      properness; auto. apply (IHτ (_ :: _)).
    - rewrite iter_up; destruct lt_dec as [Hl | Hl]; simpl.
      { by rewrite !lookup_app_l. }
      (* FIXME: Ideally we wouldn't have to do this kinf of surgery. *)
      change (bi_ofeO (uPredI (iResUR Σ))) with (uPredO (iResUR Σ)).
      rewrite !lookup_app_r; [|lia ..]. do 2 f_equiv. lia.
    - intros w; simpl; properness; auto. apply (IHτ (_ :: _)).
  Qed.

  Lemma interp_subst_up Δ1 Δ2 τ τ' :
    ⟦ τ ⟧ (Δ1 ++ interp τ' Δ2 :: Δ2)
    ≡ ⟦ τ.[upn (length Δ1) (τ' .: ids)] ⟧ (Δ1 ++ Δ2).
  Proof.
    revert Δ1 Δ2; induction τ=> Δ1 Δ2; simpl.
    - done.
    - intros w; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - intros w; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - intros w; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - apply fixpoint_proper=> τi w /=.
      properness; auto. apply (IHτ (_ :: _)).
    - rewrite iter_up; destruct lt_dec as [Hl | Hl]; simpl.
      { by rewrite !lookup_app_l. }
      (* FIXME: Ideally we wouldn't have to do this kinf of surgery. *)
      change (bi_ofeO (uPredI (iResUR Σ))) with (uPredO (iResUR Σ)).
      rewrite !lookup_app_r; [|lia ..].
      case EQ: (x - length Δ1) => [|n]; simpl.
      { symmetry. asimpl. apply (interp_weaken [] Δ1 Δ2 τ'). }
      change (bi_ofeO (uPredI (iResUR Σ))) with (uPredO (iResUR Σ)).
      rewrite !lookup_app_r; [|lia ..]. do 2 f_equiv. lia.
    - intros w; simpl; properness; auto. apply (IHτ (_ :: _)).
  Qed.

  Lemma interp_subst Δ2 τ τ' v : ⟦ τ ⟧ (⟦ τ' ⟧ Δ2 :: Δ2) v ≡ ⟦ τ.[τ'/] ⟧ Δ2 v.
  Proof. apply (interp_subst_up []). Qed.

  Lemma interp_env_length Δ Γ vs : ⟦ Γ ⟧* Δ vs ⊢ ⌜length Γ = length vs⌝.
  Proof. by iIntros "[% ?]". Qed.

  Lemma interp_env_Some_l Δ Γ vs x τ :
    Γ !! x = Some τ → ⟦ Γ ⟧* Δ vs ⊢ ∃ v, ⌜vs !! x = Some v⌝ ∧ ⟦ τ ⟧ Δ v.
  Proof.
    iIntros (?) "[Hlen HΓ]"; iDestruct "Hlen" as %Hlen.
    destruct (lookup_lt_is_Some_2 vs x) as [v Hv].
    { by rewrite -Hlen; apply lookup_lt_Some with τ. }
    iExists v; iSplit. done. iApply (big_sepL_elem_of with "HΓ").
    apply elem_of_list_lookup_2 with x.
    rewrite lookup_zip_with; by simplify_option_eq.
  Qed.

  Lemma interp_env_nil Δ : (⟦ [] ⟧* Δ [])%I.
  Proof. iSplit; rewrite ?zip_with_nil_r; auto. Qed.
  Lemma interp_env_cons Δ Γ vs τ v :
    ⟦ τ :: Γ ⟧* Δ (v :: vs) ⊣⊢ ⟦ τ ⟧ Δ v ∗ ⟦ Γ ⟧* Δ vs.
  Proof.
    rewrite /interp_env /= (assoc _ (⟦ _ ⟧ _ _)) -(comm _ ⌜(_ = _)⌝%I) -assoc.
    by apply sep_proper; [apply pure_proper; lia|].
  Qed.

  Lemma interp_env_ren Δ (Γ : list type) (vs : list val) τi :
    ⟦ subst (ren (+1)) <$> Γ ⟧* (τi :: Δ) vs ⊣⊢ ⟦ Γ ⟧* Δ vs.
  Proof.
    apply sep_proper; [apply pure_proper; by rewrite fmap_length|].
    revert Δ vs τi; induction Γ=> Δ [|v vs] τi; csimpl; auto.
    apply sep_proper; auto. apply (interp_weaken [] [τi] Δ).
  Qed.
End logrel.

Notation "⟦ τ ⟧" := (interp τ).
Notation "⟦ τ ⟧ₑ" := (interp_expr τ).
Notation "⟦ Γ ⟧*" := (interp_env Γ).


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)
(* $Id: OrderedTypeAlt.v 12384 2009-10-13 14:39:51Z letouzey $ *)

Require Import OrderedType.

(** * An alternative (but equivalent) presentation for an Ordered Type
   inferface. *)

(** NB: [comparison], defined in [Datatypes.v] is [Eq|Lt|Gt]
whereas [compare], defined in [OrderedType.v] is [EQ _ | LT _ | GT _ ]
*)

Module Type OrderedTypeAlt.

 Parameter t : Type.

 Parameter compare : t -> t -> comparison.

 Infix "?=" := compare (at level 70, no associativity).

 Parameter compare_sym :
   forall x y, (y?=x) = CompOpp (x?=y).
 Parameter compare_trans :
   forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c.

End OrderedTypeAlt.

(** From this new presentation to the original one. *)

Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType.
 Import O.

 Definition t := t.

 Definition eq x y := (x?=y) = Eq.
 Definition lt x y := (x?=y) = Lt.

 Lemma eq_refl : forall x, eq x x.
 Proof.
 intro x.
 unfold eq.
 assert (H:=compare_sym x x).
 destruct (x ?= x); simpl in *; try discriminate; auto.
 Qed.

 Lemma eq_sym : forall x y, eq x y -> eq y x.
 Proof.
 unfold eq; intros.
 rewrite compare_sym.
 rewrite H; simpl; auto.
 Qed.

 Definition eq_trans := (compare_trans Eq).

 Definition lt_trans := (compare_trans Lt).

 Lemma lt_not_eq : forall x y, lt x y -> ~eq x y.
 Proof.
 unfold eq, lt; intros.
 rewrite H; discriminate.
 Qed.

 Definition compare : forall x y, Compare lt eq x y.
 Proof.
 intros.
 case_eq (x ?= y); intros.
 apply EQ; auto.
 apply LT; auto.
 apply GT; red.
 rewrite compare_sym; rewrite H; auto.
 Defined.

 Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }.
 Proof.
 intros; unfold eq.
 case (x ?= y); [ left | right | right ]; auto; discriminate.
 Defined.

End OrderedType_from_Alt.

(** From the original presentation to this alternative one. *)

Module OrderedType_to_Alt (O:OrderedType) <: OrderedTypeAlt.
 Import O.
 Module MO:=OrderedTypeFacts(O).
 Import MO.

 Definition t := t.

 Definition compare x y := match compare x y with
   | LT _ => Lt
   | EQ _ => Eq
   | GT _ => Gt
  end.

 Infix "?=" := compare (at level 70, no associativity).

 Lemma compare_sym :
   forall x y, (y?=x) = CompOpp (x?=y).
 Proof.
 intros x y; unfold compare.
 destruct O.compare; elim_comp; simpl; auto.
 Qed.

 Lemma compare_trans :
   forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c.
 Proof.
 intros c x y z.
 destruct c; unfold compare;
 do 2 (destruct O.compare; intros; try discriminate);
 elim_comp; auto.
 Qed.

End OrderedType_to_Alt.