From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D P Q R Aprime Dprime Pprime Qprime Rprime Y : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ C D /\ (wd_ P Q /\ (wd_ Q R /\ (wd_ D Dprime /\ (wd_ C Dprime /\ (wd_ A Aprime /\ (wd_ B Aprime /\ (wd_ B D /\ (wd_ C A /\ (wd_ Pprime Qprime /\ (wd_ Qprime Rprime /\ (wd_ Y C /\ (wd_ Y B /\ (col_ C D Dprime /\ (col_ B A Aprime /\ (col_ C Dprime Y /\ col_ B Aprime Y)))))))))))))))))) -> col_ C D Y)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

(***
Modulus : 2^382 - 105
Base: 47.75
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 47 + 3/4;
    bitwidth := 64;
    s := 2^382;
    c := [(1, 105)];
    carry_chains := Some [seq 0 (pred 8); [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 Fiat.Parsers.Reflective.Syntax Fiat.Parsers.Reflective.ParserSyntax.
Require Import Fiat.Parsers.Reflective.Semantics.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.GenericRecognizer.
Require Import Fiat.Common.Wf Fiat.Common.Wf2.
Set Implicit Arguments.

Definition step_option_rec
           {T}
           (is_valid_nonterminal : list nat -> nat -> bool)
           (len0 valid_len0 : nat)
           (parse_nt : forall len0' valid_len : nat,
               Wf.prod_relation lt lt (len0', valid_len) (len0, valid_len0) ->
               list nat -> nat -> forall len : nat, len <= len0' -> nat -> T)
           (G_length : nat)
           (up_to_G_length : list nat)
           (valids : list nat) (offset len : nat)
           (nt : nat)
  : option (nat -> nat -> nat -> T).
Proof.
  refine (sumbool_rect (fun _ => option (nat -> nat -> nat -> T))
                       (fun pf =>
                          Some
                            (fun offset' len0_minus_len'
                             => parse_nt len G_length
                                         (or_introl pf)
                                         up_to_G_length
                                         offset'
                                         (len - len0_minus_len') (Minus.le_minus len len0_minus_len')))
                       (fun _
                        => _)
                       (Compare_dec.lt_dec len len0)).
  refine (sumbool_rect
            (fun _ => option (nat -> nat -> nat -> T))
            (fun is_valid
             => _)
            (fun _ => None)
            (Sumbool.sumbool_of_bool (negb (EqNat.beq_nat valid_len0 0) && is_valid_nonterminal valids nt))%bool).
  refine (Some
            (fun offset' len0_minus_len' =>
               parse_nt len0 (pred valid_len0)
                        (or_intror (conj eq_refl (GenericRecognizer.pred_lt_beq _)))
                        (RDPList.filter_out_eq nt valids) offset'
                        (len0 - len0_minus_len') (Minus.le_minus len0 len0_minus_len'))).
  apply (proj1 (proj1 (Bool.andb_true_iff _ _) is_valid)).
Defined.

Definition interp_has_parse_term'
           {T}
           (interp_Term : forall {T}, Term interp_TypeCode T -> interp_TypeCode T)
           (is_valid_nonterminal : list nat -> nat -> bool)
           (strlen : nat)
           (char_at_matches_interp : nat -> Reflective.RCharExpr Ascii.ascii -> bool)
           (split_string_for_production : nat * (nat * nat) -> nat -> nat -> list nat)
           (t : has_parse_term interp_TypeCode T) : interp_TypeCode T
  := match t with
     | RFix2 G_length up_to_G_length f default valid_len valids nt_idx
       => Wf2.Fix2
            (Wf.well_founded_prod_relation Wf_nat.lt_wf Wf_nat.lt_wf)
            (fun aa' : nat * nat =>
               list nat -> nat -> forall a1 : nat, a1 <= fst aa' -> nat -> interp_TypeCode T)
            (fun (len0 valid_len0 : nat)
                 (parse_nt : forall len0' valid_len : nat,
                     Wf.prod_relation lt lt (len0', valid_len) (len0, valid_len0) ->
                     list nat -> nat -> forall len : nat, len <= len0' -> nat -> interp_TypeCode T)
                 (valids : list nat) (offset len : nat)
                 (pf : len <= len0)
                 (nt : nat)
             => option_rect
                  (fun _ : option (interp_TypeCode (cnat --> cnat --> cnat --> T)) => interp_TypeCode T)
                  (fun parse_nt
                   => interp_Term
                        f
                        (fun n : interp_TypeCode cnat => char_at_matches_interp n (*str*))
                        (fun n : interp_TypeCode (cnat * (cnat * cnat)) => split_string_for_production n (*str*))
                        len0 valid_len parse_nt valids offset len nt)
                  (interp_Term default)
                  (@step_option_rec (interp_TypeCode T) is_valid_nonterminal len0 valid_len0 parse_nt G_length up_to_G_length valids offset len nt))
            strlen
            valid_len
            valids
            0
            strlen
            (le_n _)
            nt_idx
     end.

Definition interp_has_parse_term {T}
  := Eval cbv [interp_has_parse_term'] in @interp_has_parse_term' T (@interp_Term).


Require Import Vec.
Require Import Target.
Require Import TargetAux.

(*****************************************************************)
(*                       TARGET LOOKUPS                          *)
(*****************************************************************)

(* TODO: WRITE THESE *)
Axiom FcAxIn : nat -> FcAx -> FcTyEnv -> Prop.
Axiom FcTmVarIn : nat -> FcTy -> FcTyEnv -> Prop.
Axiom FcTyVarIn : nat -> FcTyEnv -> Prop.
Axiom FcTyFamIn : nat -> FcTyEnv -> Prop.
Axiom FcDataIn : nat -> FcTyEnv -> FcData -> Prop.
Axiom FcConIn : nat -> FcTyEnv -> Prop.
(* TODO: ALSO ADD MORE *)

(*
(* TODO: THIS IS PLAIN WRONG. WE NEED TO SHIFT STUFF *)
Inductive FcAxIn : nat -> FcAx -> FcTyEnv -> Prop :=
  | FcAxInAxHere Δ ax
      : FcAxIn 0 ax (fcConsAx Δ ax)
  | FcAxInAxThere n ax Δ ax' (there : FcAxIn n ax Δ)
      : FcAxIn (S n) ax (fcConsAx Δ ax')
  | FcAxInTyThere n ax Δ (there : FcAxIn n ax Δ)       (* IT IS THE AX THAT SHOULD BE SHIFTED *)
      : FcAxIn n ax (fcConsTy Δ)
  | FcAxInTmThere n ax Δ υ (there : FcAxIn n ax Δ)
      : FcAxIn n ax (fcConsTm Δ υ)
  | FcAxInCnThere n ax Δ ctx m scs md (there : FcAxIn n ax Δ)   (* IT IS THE AX THAT SHOULD BE SHIFTED *)
      : FcAxIn n ax (fcConsTc Δ ctx m scs md).
*)

(*****************************************************************)
(*                      TYPE WELL-FORMEDNESS                     *)
(*****************************************************************)

(* System FC Type Well-formedness *)
Inductive FcTcTy (Δ : FcTyEnv) : FcTy -> Prop :=
  | FcTcTyVar a (ainΔ : FcTyVarIn a Δ)
    : FcTcTy Δ (FcTyVar a)
  | FcTcTyArr υ₁ υ₂ (wfυ₁ : FcTcTy Δ υ₁) (wfυ₂ : FcTcTy Δ υ₂)
    : FcTcTy Δ (FcTyArr υ₁ υ₂)
  | FcTcTyAll υ (wfυ : FcTcTy (FcConsTy Δ) υ)
    : FcTcTy Δ (FcTyAll υ)
  | FcTcTyCon tc υ (tcinΔ : FcConIn tc Δ) (wfυ : FcTcTy Δ υ)
    : FcTcTy Δ (FcTyCon tc υ)
  | FcTcTyFam fn υ (fninΔ : FcTyFamIn fn Δ) (wfυ : FcTcTy Δ υ)
    : FcTcTy Δ (FcTyFam fn υ)
  | FcTcTyTup n υs (wfυs : FcTcTys Δ n υs)
    : FcTcTy Δ (FcTyTup n υs)
with FcTcTys (Δ : FcTyEnv) : forall n, Vec FcTy n -> Prop :=
  | FcTcTysNil  : FcTcTys Δ 0 (VN FcTy)
  | FcTcTysCons υ n υs (wfυ : FcTcTy Δ υ) (wfυs : FcTcTys Δ n υs) : FcTcTys Δ (S n) (VC FcTy υ n υs).

(*****************************************************************)
(*                        COERCION TYPING                        *)
(*****************************************************************)

(* System FC Coercion Typing *)
Inductive FcTcCo (Δ : FcTyEnv) : Co -> FcTy -> FcTy -> Prop :=
  | FcTcCoRefl υ (wfυ : FcTcTy Δ υ)
      : FcTcCo Δ (CoRefl υ) υ υ
  | FcTcCoSym γ υ₁ υ₂ (tcγ : FcTcCo Δ γ υ₁ υ₂)
      : FcTcCo Δ (CoSym γ) υ₂ υ₁
  | FcTcCoTrans γ₁ γ₂ υ₁ υ₂ υ₃ (tcγ₁ : FcTcCo Δ γ₁ υ₁ υ₂) (tcγ₂ : FcTcCo Δ γ₂ υ₂ υ₃)
      : FcTcCo Δ (CoTrans γ₁ γ₂) υ₁ υ₃
  | FcTcCoAxiom n g fn υs υ m rυs (fninΔ : FcTyFamIn fn Δ)
                (ginΔ : FcAxIn g (MkFcAx n fn υ m rυs) Δ) (wfυs : FcTcTys Δ n υs)
      : FcTcCo Δ (CoAxiom g n υs)
             (FcTyFam fn (fcSubstTysInTy n υs υ)) (FcTyTup m (fcSubstTysInTys n m υs rυs)).

(*****************************************************************)
(*                          TERM TYPING                          *)
(*****************************************************************)

(* System FC Term Typing *)
Inductive FcTcTm (Δ : FcTyEnv) : FcTm -> FcTy -> Prop :=
  | FcTcTmVar x υ (xinΔ : FcTmVarIn x υ Δ)
      : FcTcTm Δ (FcTmVar x) υ
  | FcTcTmAbs υ₁ t υ₂ (wfυ : FcTcTy Δ υ₁) (tct : FcTcTm (FcConsTm Δ υ₁) t υ₂)
      : FcTcTm Δ (FcTmAbs υ₁ t) (FcTyArr υ₁ υ₂) (* TODO: No shifting I guess, it's a tmvar? *)
  | FcTcTmApp t₁ t₂ υa υb (tct₁ : FcTcTm Δ t₁ (FcTyArr υa υb)) (tct₂ : FcTcTm Δ t₂ υa)
      : FcTcTm Δ (FcTmApp t₁ t₂) υb
  | FcTcTmTup n ts υs (tcts : FcTcTms Δ n ts υs)
      : FcTcTm Δ (FcTmTup n ts) (FcTyTup n υs)
  | FcTcTyAbs t υ (tct : FcTcTm (FcConsTy Δ) t υ)
      : FcTcTm Δ (FcTyAbs t) (FcTyAll υ)
  | FcTcTyApp t υ υ₁
      (tct : FcTcTm Δ t (FcTyAll υ₁))
      (wfυ : FcTcTy Δ υ)
      :  FcTcTm Δ (FcTyApp t υ) (fcSubstTyInTy υ υ₁)
  | FcTcCast t γ υ₁ υ₂
      (tct : FcTcTm Δ t υ₁)
      (tcγ : FcTcCo Δ γ υ₁ υ₂)
    : FcTcTm Δ (FcCast t γ) υ₂
  | FcTcTmCon dc υ ctx n scs md υctx υscs υmd
      (dcinΔ : FcDataIn dc Δ (MkFcData υctx n υscs υmd))
      (wfυ   : FcTcTy Δ υ)
      (tcctx : FcTcTm Δ ctx (fcSubstTyInTy υ υctx))
      (tcscs : FcTcTms Δ n scs (fcSubstTyInTys n υ υscs))
      (tcmd : FcTcTm Δ md (fcSubstTyInTy υ υmd))
    : FcTcTm Δ (FcCon dc υ ctx n scs md) (FcTyCon dc υ)
  | FcTcDCase scr rhs tc υ n υctx υscs υmd υrhs
      (tcscr : FcTcTm Δ scr (FcTyCon tc υ))
      (dcinΔ : FcDataIn tc Δ (MkFcData υctx n υscs υmd))
      (tcrhs : FcTcTm (FcConsTm (fcBindTmVars n (fcSubstTyInTys n υ υscs)
                                              (FcConsTm Δ (fcSubstTyInTy υ υctx))
                                ) (fcSubstTyInTy υ υmd)) rhs υrhs)
    : FcTcTm Δ (FcDCase scr rhs) υrhs
  | FcTcTCase scr n υs rhs υrhs
      (tcscr : FcTcTm Δ scr (FcTyTup n υs))
      (tcrhs : FcTcTm (fcBindTmVars n υs Δ) rhs υrhs)
      : FcTcTm Δ (FcTCase scr rhs) υrhs

with FcTcTms (Δ : FcTyEnv) : forall n, Vec FcTm n -> Vec FcTy n -> Prop :=
  | FcTcTmsNil
    : FcTcTms Δ 0 (VN FcTm) (VN FcTy)
  | FcTcTmsCons n t ts υ υs (tct : FcTcTm Δ t υ) (tcts : FcTcTms Δ n ts υs)
    : FcTcTms Δ (S n) (VC FcTm t n ts) (VC FcTy υ n υs).

(*****************************************************************)
(*                       DECLARATION TYPING                      *)
(*****************************************************************)

(* System FC Top-level Value Binding || TODO: NON-RECURSIVE *)
(* Just return the type, to extend the environment with *)
Inductive FcTcVal (Δ : FcTyEnv) : FcVal -> FcTy -> Prop :=
  | FcTcMkVal t υ
      (tct : FcTcTm Δ t υ)
    : FcTcVal Δ (MkFcVal t υ) υ.

(* System FC Type Family Declaration || TODO: REMOVE EVENTUALLY *)
Inductive FcTcFam (Δ : FcTyEnv) : FcFam -> Prop :=
  | FcTcMkFam
    : FcTcFam Δ MkFcFam.

(* System FC Datatype Declaration *)
Inductive FcTcData (Δ : FcTyEnv) : FcData -> Prop :=
  | FcTcMkData ctx n scs md
      (tcctx : FcTcTy  (FcConsTy Δ) ctx)
      (tcscs : FcTcTys (FcConsTy Δ) n scs)
      (tcmd  : FcTcTy  (FcConsTy Δ) md)
    : FcTcData Δ (MkFcData ctx n scs md).

(* System FC Equality Axiom *)
Inductive FcTcAx (Δ : FcTyEnv) : FcAx -> Prop :=
  | FcTcMkAx bs fn υ m υs
      (fninΔ : FcTyFamIn fn Δ)
      (wfυ  : FcTcTy  (fcBindTyVars bs Δ) υ)
      (wfυs : FcTcTys (fcBindTyVars bs Δ) m υs)
    : FcTcAx Δ (MkFcAx bs fn υ m υs).

(*****************************************************************)
(*                        PROGRAM TYPING                         *)
(*****************************************************************)

Inductive FcTcPgm (Δ : FcTyEnv) : FcPgm -> Prop :=
  | FcTcPgmEmpty
    : FcTcPgm Δ FcPgmEmpty
  | FcTcPgmVal fcval fcpgm υ
      (tcfcval : FcTcVal Δ fcval υ)
      (fcfcpgm : FcTcPgm (FcConsTm Δ υ) fcpgm)
    : FcTcPgm Δ (FcPgmVal fcval fcpgm)
  | FcTcPgmData fcdata fcpgm
      (tcfcdata : FcTcData Δ fcdata)
      (tcfcpgm  : FcTcPgm (FcConsDt Δ fcdata) fcpgm)
    : FcTcPgm Δ (FcPgmData fcdata fcpgm)
  | FcTcPgmFam fcfam fcpgm
      (tcfcfam : FcTcFam Δ fcfam)
      (fcfcpgm : FcTcPgm (FcConsFn Δ) fcpgm)
    : FcTcPgm Δ (FcPgmFam fcfam fcpgm)
  | FcTcPgmAx fcax fcpgm
      (tcfcax  : FcTcAx Δ fcax)
      (fcfcpgm : FcTcPgm (FcConsAx Δ fcax) fcpgm)
    : FcTcPgm Δ (FcPgmAx fcax fcpgm).


Require Import ListAux.
Require Import Arith.
Require Import Tactics.
Lemma bankersq2consistent_BankersqConcat0 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((list_order  il_2 u_1 u_0)/\(list_member  il_0 u_1)) -> (list_member  il_2 u_0)).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat1 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((list_order  il_2 u_1 u_0)/\(list_member  il_0 u_1)) -> (list_member  il_2 u_1)).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat2 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_member  il_1 u_0))/\(u_1 = u_0)/\(list_order  il_2 u_1 u_0)/\(list_member  il_0 u_1)) -> (list_order  il_0 u_0 u_0)).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat3 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_member  il_0 u_0))/\(list_order  il_2 u_0 u_1)/\(list_member  il_1 u_1)/\(not (u_1 = u_0))/\(list_order  il_2 u_1 u_0)/\(list_member  il_0 u_1)) -> (not (list_order  il_0 u_0 u_1))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat4 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_order  il_2 u_0 u_1))/\(list_member  il_1 u_1)/\(not (u_1 = u_0))/\(list_order  il_2 u_1 u_0)/\(list_member  il_0 u_1)) -> (list_order  il_1 u_1 u_0)).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat5 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_order  il_2 u_0 u_1))/\(list_member  il_1 u_1)/\(not (u_1 = u_0))/\(list_order  il_2 u_1 u_0)/\(list_member  il_0 u_1)) -> (not (list_order  il_1 u_0 u_1))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat6 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_order  il_0 u_0 u_1))/\(not (list_member  il_1 u_1))/\(not (u_1 = u_0))/\(list_order  il_2 u_1 u_0)/\(list_member  il_0 u_1)) -> (not (list_order  il_2 u_0 u_1))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat7 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_order  il_0 u_0 u_1))/\(not (list_order  il_0 u_1 u_0))/\(not (list_member  il_1 u_1))/\(not (u_1 = u_0))/\(list_order  il_2 u_1 u_0)/\(list_member  il_0 u_1)) -> (not (list_member  il_0 u_0))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat8 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_order  il_2 u_1 u_0))/\(list_member  il_0 u_1)) -> (not (list_member  il_1 u_0))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat9 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_order  il_2 u_1 u_0))/\(list_member  il_0 u_1)) -> (list_member  il_2 u_1)).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat10 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_order  il_0 u_0 u_1))/\(not (list_order  il_2 u_1 u_0))/\(list_member  il_0 u_1)) -> (not (list_order  il_2 u_0 u_1))).
Proof.
    intro pushspec;
  inversion pushspec as [a b c Hhd Hmem Hord Honce]; subst;
  try setoid_rewrite Hhd; try setoid_rewrite Hmem; try setoid_rewrite Hord; try setoid_rewrite Honce;
  clear Hhd Hmem Hord Honce;
  repeat ((repeat setoid_rewrite rewrite_not_conj);
          (repeat setoid_rewrite rewrite_not_disj);
          (repeat setoid_rewrite rewrite_not_not)).
    intros. destruct H. destruct H0. destruct H0. destruct H2. destruct H3.
    - exfalso. eauto.
    - split; auto. split; eauto.
      + destruct (Nat.eqb_spec u_0 u_1).
        subst. right. eauto.
        left. intro. eauto.
Qed.

Lemma bankersq2consistent_BankersqConcat11 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_order  il_0 u_0 u_1))/\(list_member  il_2 u_0)/\(not (list_order  il_2 u_1 u_0))/\(list_member  il_0 u_1)) -> (u_1 = u_0)).
Proof.
  intro pushspec;
    inversion pushspec as [a b c Hhd Hmem Hord Honce]; subst;
      try setoid_rewrite Hhd; try setoid_rewrite Hmem; try setoid_rewrite Hord; try setoid_rewrite Honce;
        clear Hhd Hmem Hord Honce;
        repeat ((repeat setoid_rewrite rewrite_not_conj);
                (repeat setoid_rewrite rewrite_not_disj);
                (repeat setoid_rewrite rewrite_not_not));
        intros; destruct_pairs; auto with core;
          try (match goal with
               | u: nat, v: nat |- _ => destruct (Nat.eqb_spec u v); subst; auto with core
               end).
  destruct H0. exfalso. eauto. destruct H4. exfalso. eauto. exfalso. eauto.
Qed.

Lemma bankersq2consistent_BankersqConcat12 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_member  il_0 u_1))) -> (not (list_order  il_0 u_1 u_0))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat13 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_member  il_0 u_1))) -> (not (list_order  il_0 u_0 u_1))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat14 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((list_order  il_1 u_0 u_1)/\(list_member  il_1 u_1)/\(list_member  il_1 u_0)/\(list_member  il_2 u_0)/\(not (list_member  il_0 u_1))) -> (list_order  il_2 u_0 u_1)).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat15 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (u_1 = u_0))/\(list_order  il_1 u_1 u_0)/\(list_member  il_0 u_0)/\(list_order  il_1 u_0 u_1)/\(list_member  il_1 u_1)/\(list_member  il_1 u_0)/\(list_member  il_2 u_0)/\(not (list_member  il_0 u_1))) -> (list_order  il_2 u_1 u_0)).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat16 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (u_1 = u_0))/\(not (list_order  il_1 u_1 u_0))/\(not (list_member  il_0 u_0))/\(list_order  il_1 u_0 u_1)/\(list_member  il_1 u_1)/\(list_member  il_1 u_0)/\(list_member  il_2 u_0)/\(not (list_member  il_0 u_1))) -> (not (list_order  il_2 u_1 u_0))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat17 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((list_order  il_2 u_0 u_1)/\(not (list_order  il_1 u_0 u_1))/\(list_member  il_1 u_1)/\(list_member  il_1 u_0)/\(list_member  il_2 u_0)/\(not (list_member  il_0 u_1))) -> (list_member  il_0 u_0)).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat18 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((list_order  il_2 u_0 u_1)/\(not (list_order  il_1 u_0 u_1))/\(list_member  il_1 u_1)/\(list_member  il_1 u_0)/\(list_member  il_2 u_0)/\(not (list_member  il_0 u_1))) -> (list_order  il_2 u_1 u_0)).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat19 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_member  il_1 u_1))/\(list_member  il_1 u_0)/\(list_member  il_2 u_0)/\(not (list_member  il_0 u_1))) -> (not (list_order  il_2 u_1 u_0))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat20 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_member  il_0 u_0))/\(not (list_member  il_1 u_1))/\(list_member  il_1 u_0)/\(list_member  il_2 u_0)/\(not (list_member  il_0 u_1))) -> (not (list_order  il_1 u_1 u_0))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat21 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_member  il_0 u_0))/\(not (list_member  il_1 u_1))/\(list_member  il_1 u_0)/\(list_member  il_2 u_0)/\(not (list_member  il_0 u_1))) -> (not (list_order  il_1 u_0 u_1))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat22 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_member  il_1 u_0))/\(list_member  il_2 u_0)/\(not (list_member  il_0 u_1))) -> (list_member  il_0 u_0)).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat23 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_member  il_1 u_0))/\(list_member  il_2 u_0)/\(not (list_member  il_0 u_1))) -> (not (list_order  il_2 u_1 u_0))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat24 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_member  il_1 u_0))/\(list_member  il_2 u_0)/\(not (list_member  il_0 u_1))) -> (not (list_order  il_1 u_0 u_1))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat25 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_member  il_1 u_0))/\(list_member  il_2 u_0)/\(not (list_member  il_0 u_1))) -> (not (u_1 = u_0))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat26 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((list_member  il_1 u_1)/\(not (list_member  il_1 u_0))/\(list_member  il_2 u_0)/\(not (list_member  il_0 u_1))) -> (list_member  il_2 u_1)).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat27 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_member  il_1 u_1))/\(not (list_member  il_1 u_0))/\(list_member  il_2 u_0)/\(not (list_member  il_0 u_1))) -> (not (list_member  il_2 u_1))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat28 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_member  il_2 u_0))/\(not (list_member  il_0 u_1))) -> (not (list_member  il_1 u_0))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat29 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (list_member  il_2 u_0))/\(not (list_member  il_0 u_1))) -> (not (list_order  il_1 u_1 u_0))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat30 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (u_1 = u_0))/\(not (list_member  il_2 u_0))/\(not (list_member  il_0 u_1))) -> (not (list_order  il_1 u_0 u_1))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat31 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (u_1 = u_0))/\(not (list_member  il_2 u_0))/\(not (list_member  il_0 u_1))) -> (not (list_member  il_0 u_0))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat32 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (u_1 = u_0))/\(not (list_member  il_2 u_0))/\(not (list_member  il_0 u_1))) -> (not (list_order  il_2 u_0 u_1))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat33 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (u_1 = u_0))/\(list_member  il_1 u_1)/\(not (list_member  il_2 u_0))/\(not (list_member  il_0 u_1))) -> (list_member  il_2 u_1)).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_BankersqConcat34 (il_0:list nat) (il_1:list nat) (il_2:list nat) (u_0:nat) (u_1:nat) : (concat_spec  il_0 il_1 il_2) -> (((not (u_1 = u_0))/\(not (list_member  il_1 u_1))/\(not (list_member  il_2 u_0))/\(not (list_member  il_0 u_1))) -> (not (list_member  il_2 u_1))).
Proof. solve_concat; try (assert (u_0 = u_1); subst; eauto). Qed.


(*
  Autor(s):
    Dominique Larchey-Wendling (1)
    Andrej Dudenhefner (2)
    Johannes Hostert (2)
  Affiliation(s):
    (1) LORIA -- CNRS
    (2) Saarland University, Saarbrücken, Germany
*)

(* ** H10C_SAT, H10SQC_SAT, and H10UC_SAT are undecidable *)

(*
  Undecidability Result(s):
    Diophantine Constraint Solvability (H10C_SAT)
    Square Diophantine Constraint Solvability (H10SQC_SAT)
    Uniform Diophantine Constraint Solvability (H10UC_SAT)
    Uniform Diophantine Pair Constraint Solvability (H10UPC_SAT)
*)

Require Import Undecidability.Synthetic.Undecidability.
Require Import Undecidability.Synthetic.ReducibilityFacts.
Require Import Undecidability.DiophantineConstraints.H10C.

(* For the reduction chain to complement_HaltL_undec *)
From Undecidability.FRACTRAN  Require Import FRACTRAN Reductions.MM_FRACTRAN.
From Undecidability.MinskyMachines Require Import MM Reductions.BSM_MM.
From Undecidability.StackMachines Require Import BSM Reductions.SBTM_HALT_to_HaltBSM.
Require Import Undecidability.TM.SBTM_undec.

From Undecidability.DiophantineConstraints.Reductions Require
  FRACTRAN_to_H10C_SAT H10C_SAT_to_H10SQC_SAT H10SQC_SAT_to_H10UC_SAT H10UC_SAT_to_H10UPC_SAT.

From Undecidability.FRACTRAN Require Import FRACTRAN FRACTRAN_undec.

(* Undecidability of Diophantine Constraint Solvability *)
Theorem H10C_SAT_undec : undecidable H10C_SAT.
Proof.
  apply (undecidability_from_reducibility FRACTRAN_undec).
  apply (reduces_transitive FRACTRAN_DIO.FRACTRAN_HALTING_DIO_LOGIC_SAT).
  apply (reduces_transitive FRACTRAN_DIO.DIO_LOGIC_ELEM_SAT).
  exact FRACTRAN_to_H10C_SAT.DIO_ELEM_H10C_SAT.
Qed.

(* Undecidability of Square Diophantine Constraint Solvability *)
Theorem H10SQC_SAT_undec : undecidable H10SQC_SAT.
Proof.
  apply (undecidability_from_reducibility H10C_SAT_undec).
  exact H10C_SAT_to_H10SQC_SAT.reduction.
Qed.

(* Undecidability of Uniform Diophantine Constraint Solvability *)
Theorem H10UC_SAT_undec : undecidable H10UC_SAT.
Proof.
  apply (undecidability_from_reducibility H10SQC_SAT_undec).
  exact H10SQC_SAT_to_H10UC_SAT.reduction.
Qed.

Theorem H10UPC_SAT_undec : undecidable H10UPC_SAT.
Proof.
  apply (undecidability_from_reducibility H10UC_SAT_undec).
  exact H10UC_SAT_to_H10UPC_SAT.reduction.
Qed.
Locate complement_SBTM_HALT_undec.
Theorem H10UPC_SAT_compl_undec : undecidable (complement H10UPC_SAT).
Proof.
  apply (undecidability_from_reducibility complement_SBTM_HALT_undec).
  apply reduces_complement.
  eapply reduces_transitive; last apply H10UC_SAT_to_H10UPC_SAT.reduction.
  eapply reduces_transitive; last apply H10SQC_SAT_to_H10UC_SAT.reduction.
  eapply reduces_transitive; last apply H10C_SAT_to_H10SQC_SAT.reduction.
  eapply reduces_transitive; last apply FRACTRAN_to_H10C_SAT.DIO_ELEM_H10C_SAT.
  eapply reduces_transitive; last apply FRACTRAN_DIO.DIO_LOGIC_ELEM_SAT.
  eapply reduces_transitive; last apply FRACTRAN_DIO.FRACTRAN_HALTING_DIO_LOGIC_SAT.
  eapply reduces_transitive; last apply FRACTRAN_REG_FRACTRAN_HALTING.
  eapply reduces_transitive; last apply MM_FRACTRAN_REG_HALTING.
  eapply reduces_transitive; last apply BSM_MM_HALTING.
  exact SBTM_HALT_to_HaltBSM.reduction.
Qed.


From Array Require Export MultiAssign.
From RecoveryRefinement Require Import Lib.
Require Import Spec.HoareTactics.

Require Import Examples.Logging.Impl.
Require Import Examples.Logging.LogLayout.

Import EqualDecNotation.

Opaque plus.
Opaque lt.
Opaque D.ODLayer.

Implicit Types (d: disk) (log: list (addr*block)).

Record LogicalState :=
  { ls_committed : bool;
    ls_log : list (addr * block);
    ls_disk : disk; }.

Inductive LogDecode : PhysicalState -> LogicalState -> Prop :=
| log_decode hdr (desc: Descriptor) (log_values: LogValues) log
             commit data_region data :
    forall (Hloglen: length log = hdr.(log_length))
      (Hlogcontents:
         forall i, i < hdr.(log_length) ->
              index log i = Some (sel desc i, sel log_values i))
      (Hcommitted: hdr.(committed) = commit)
      (Hdisk: data_region = data),
      LogDecode {| p_hdr := hdr;
                   p_desc := desc;
                   p_log_values := log_values;
                   p_data_region := data_region; |}
                {| ls_committed := commit;
                   ls_log := log;
                   ls_disk := data; |}.

Local Notation proc_hspec := (Hoare.proc_hspec D.ODLayer.(sem)).

Local Hint Resolve data_read_ok : core.

Ltac match_abs ::=
  match goal with
  | [ H: PhyDecode ?d _ |- PhyDecode ?d _ ] => exact H
  | [ H: PhyDecode ?d ?ps |- context[PhyDecode ?d _] ] =>
    match goal with
    | |- exists _, _ => solve [ destruct ps; descend; eauto ]
    end
  | [ H: LogDecode ?d _ |- LogDecode ?d _ ] => exact H
  | [ H: PhyDecode ?d ?ps |- exists ps, PhyDecode ?d ps /\ _ ] =>
    exists ps; split; [ exact H | ]
  | [ H: LogDecode ?ps ?ls |- context[LogDecode ?ps _] ] =>
    match goal with
    | |- exists _, _ => solve [ destruct ls; descend; eauto ]
    end
  end.

Lemma logd_disk ps ls :
  LogDecode ps ls ->
  ps.(p_data_region) = ls.(ls_disk).
Proof.
  inversion 1; auto.
Qed.

Global Hint Resolve logd_disk : core.

Lemma logd_loglen ps ls :
  LogDecode ps ls ->
  ps.(p_hdr).(log_length) = length ls.(ls_log).
Proof.
  inversion 1; auto.
Qed.

Lemma logd_committed ps ls :
  LogDecode ps ls ->
  ps.(p_hdr).(committed) = ls.(ls_committed).
Proof.
  inversion 1; auto.
Qed.

Global Hint Resolve logd_committed : core.

Lemma logd_log_contents ps ls :
  LogDecode ps ls ->
  forall i, i < ps.(p_hdr).(log_length) ->
       index ls.(ls_log) i =
       Some (sel ps.(p_desc) i, sel ps.(p_log_values) i).
Proof.
  inversion 1; auto.
Qed.

Lemma logd_log_value ps ls :
  LogDecode ps ls ->
  forall i, i < length ls.(ls_log) ->
       index ls.(ls_log) i =
       Some (sel ps.(p_desc) i, sel ps.(p_log_values) i).
Proof.
  intros.
  erewrite logd_log_contents; eauto.
  erewrite logd_loglen by eauto.
  auto.
Qed.

Lemma logd_log_bounds ps ls :
  LogDecode ps ls ->
  length ls.(ls_log) <= LOG_LENGTH.
Proof.
  inversion 1; simpl.
  pose proof hdr.(log_length_ok).
  congruence.
Qed.

Theorem log_read_ok ps ls a :
  proc_hspec
    (log_read a)
    (fun state =>
       {| pre := PhyDecode state ps /\
                 LogDecode ps ls /\
                 ls.(ls_committed) = false;
          post state' r :=
            state' = state /\
            index ls.(ls_disk) a ?|= eq r;
          alternate state' _ :=
            state' = state; |}).
Proof.
  unfold log_read.
  spec_impl; split_cases; simplify; finish.
  rewrite (logd_disk ltac:(eassumption)) in *; auto.
Qed.

Local Hint Resolve log_write_ok : core.

Lemma length_descriptor (desc:Descriptor) :
  length desc = LOG_LENGTH.
Proof.
  destruct desc; auto.
Qed.

#[export] Hint Rewrite length_descriptor : length.

Lemma log_decode_app:
  forall (ps : PhysicalState) (ls : LogicalState)
    (a : addr) (v : block) (s : D.ODLayer.(State)),
    PhyDecode s ps ->
    LogDecode ps ls ->
    ls.(ls_committed) = false ->
    forall pf : ps.(p_hdr).(log_length) < LOG_LENGTH,
      LogDecode
        {|
          p_hdr := hdr_inc ps.(p_hdr) pf;
          p_desc := desc_assign ps.(p_desc) ps.(p_hdr).(log_length) a;
          p_log_values := log_assign ps.(p_log_values) ps.(p_hdr).(log_length) v;
          p_data_region := ps.(p_data_region) |}
        {| ls_committed := false;
           ls_log := ls.(ls_log) ++ (a, v) :: nil;
           ls_disk := ls.(ls_disk) |}.
Proof.
  intros ps ls a v s Hphy Hlog Hcommit_false pf.
  pose proof (logd_log_bounds Hlog).
  constructor; simpl; eauto.
  - rewrite app_length; simpl.
    rewrite (logd_loglen ltac:(eassumption)); auto.
  - intros.
    pose proof (logd_log_contents Hlog (i:=i)).
    rewrite (logd_loglen ltac:(eassumption)) in *.
    destruct (i == length ls.(ls_log)); subst; array.
    + rewrite Nat.sub_diag; simpl; auto.
    + apply H1; lia.
Qed.

Global Hint Resolve log_decode_app : core.

Fixpoint zip A B (l1: list A) (l2: list B) : list (A*B) :=
  match l1, l2 with
  | x::xs, y::ys => (x, y) :: zip xs ys
  | _, _ => nil
  end.

Theorem zip_index A B {defA: Default A} {defB: Default B} (l1: list A) (l2: list B) :
  forall i, i < length l1 ->
       i < length l2 ->
       index (zip l1 l2) i = Some (sel l1 i, sel l2 i).
Proof.
  generalize dependent l2.
  induction l1; simpl; intros.
  - lia.
  - destruct l2; simpl in *; try lia.
    destruct i; simpl.
    + reflexivity.
    + rewrite IHl1 by lia.
      reflexivity.
Qed.

Theorem zip_length1 A B (l1: list A) (l2: list B) :
  length l1 <= length l2 ->
  length (zip l1 l2) = length l1.
Proof.
  generalize dependent l2.
  induction l1; simpl; intros; auto.
  destruct l2; simpl in *; try lia.
  rewrite IHl1 by lia; auto.
Qed.

Lemma log_decode_some_log:
  forall (ps : PhysicalState) (ls : LogicalState) (s : D.ODLayer.(State)),
    PhyDecode s ps ->
    LogDecode ps ls ->
    ls.(ls_committed) = false ->
    forall (hdr : LogHdr) (desc : Descriptor) (log_values : LogValues),
      hdr.(committed) = ps.(p_hdr).(committed) ->
      exists log : list (addr * block),
        LogDecode
          {|
            p_hdr := hdr;
            p_desc := desc;
            p_log_values := log_values;
            p_data_region := ps.(p_data_region) |}
          {|
            ls_committed := false;
            ls_log := log;
            ls_disk := ls.(ls_disk) |}.
Proof.
  intros ps ls s Hphy Hlog Hcommit_false hdr desc log_values Hcommit.
  exists (firstn hdr.(log_length) (zip desc log_values)).
  constructor; eauto.
  - rewrite firstn_length.
    rewrite zip_length1; autorewrite with length; auto.
    rewrite Nat.min_l; auto.
    apply hdr.(log_length_ok).
  - intros.
    rewrite index_firstn by auto.
    pose proof hdr.(log_length_ok).
    erewrite zip_index; eauto; autorewrite with length; try lia.
Qed.

Global Hint Resolve log_decode_some_log : core.

Theorem log_write_ok ps ls a v :
  proc_hspec
    (log_write a v)
    (fun state =>
       {| pre := PhyDecode state ps /\
                 LogDecode ps ls /\
                 ls.(ls_committed) = false;
          post state' r :=
            match r with
            | TxnD.WriteOK =>
              exists ps', PhyDecode state' ps' /\
                     LogDecode ps'
                               {| ls_committed := false;
                                  ls_log := ls.(ls_log) ++ (a,v)::nil;
                                  ls_disk := ls.(ls_disk); |}
            | TxnD.WriteErr =>
              exists ps', PhyDecode state' ps' /\
                     LogDecode ps' ls
            end;
          alternate state' _ :=
            exists ps',
              PhyDecode state' ps' /\
              exists log,
                (LogDecode ps' {| ls_committed := false;
                                  ls_log := log;
                                  ls_disk := ls.(ls_disk); |});
       |}).
Proof.
  spec_impl; split_cases; simplify; finish.
  destruct v0; simplify; finish.
Qed.

Lemma log_decode_apply_one:
  forall (len : nat) (ps : PhysicalState) (ls : LogicalState) (i : nat) (state : D.ODLayer.(State)),
    PhyDecode state ps ->
    LogDecode ps ls ->
    i + S len = length ls.(ls_log) ->
    ls.(ls_committed) = true ->
    LogDecode
      {|
        p_hdr := ps.(p_hdr);
        p_desc := ps.(p_desc);
        p_log_values := ps.(p_log_values);
        p_data_region := assign ps.(p_data_region) (sel ps.(p_desc) i) (sel ps.(p_log_values) i) |}
      {|
        ls_committed := true;
        ls_log := ls.(ls_log);
        ls_disk := assign ps.(p_data_region) (sel ps.(p_desc) i) (sel ps.(p_log_values) i) |}.
Proof.
  intros len ps ls i state Hphy Hlog H H0.
  constructor;
    try erewrite logd_loglen by eauto;
    try erewrite logd_committed by eauto;
    intros;
    array.
  erewrite logd_log_value by eauto; auto.
Qed.

Global Hint Resolve log_decode_apply_one : core.

Theorem log_apply_one_more : forall d log i a v len,
    index log i = Some (a, v) ->
    i + 1 + len = length log ->
    massign (subslice log (i + 1) len) (assign d a v) =
    massign (subslice log i (S len)) d.
Proof.
  intros.
  replace (i + 1) with (S i) in * by lia.
  erewrite subslice_one_more; eauto; try lia.
  simpl; auto.
Qed.

Theorem log_apply_reapply_one : forall log i d a v,
    index log i = Some (a, v) ->
    massign log d =
    massign log (assign d a v).
Proof.
  induction log; simpl; intros.
  - congruence.
  - destruct a as [a v'].
    destruct i; simpl.
    + inv_clear H.
      array.
    + destruct (a == a0); subst; array.
      erewrite IHlog; eauto.
      rewrite assign_assign_ne by auto; auto.
Qed.

Global Hint Resolve logd_log_value : core.
Global Hint Extern 3 (_ < _) => lia : core.
Global Hint Extern 3 (_ <= _) => lia : core.
Global Hint Extern 3 (@eq nat _ _) => lia : core.

Definition applied_after log i d0 :=
  massign (subslice log i (length log - i)) d0.

Definition fully_applied log d0 :=
  massign log d0.

Section ApplyAtRespec.
  Hint Resolve apply_at_ok : core.

  Theorem log_apply_at_ok ps ls d0 desc i :
    proc_hspec
      (apply_at desc i)
      (fun state =>
         {| pre := PhyDecode state ps /\
                   LogDecode ps ls /\
                   desc = ps.(p_desc) /\
                   i < length ls.(ls_log) /\
                   ls.(ls_committed) = true /\
                   applied_after ls.(ls_log) i ls.(ls_disk) = fully_applied ls.(ls_log) d0 /\
                   fully_applied ls.(ls_log) ls.(ls_disk) = fully_applied ls.(ls_log) d0;
            post state' r :=
              r = tt /\
              exists ps',
                PhyDecode state' ps' /\
                ps'.(p_desc) = desc /\
                exists a v,
                  index ls.(ls_log) i = Some (a, v) /\
                  LogDecode ps' {| ls_committed := true;
                                   ls_log := ls.(ls_log);
                                   ls_disk := assign ls.(ls_disk) a v; |};
            alternate state' _ :=
              exists ps',
                PhyDecode state' ps' /\
                ps'.(p_desc) = desc /\
                exists disk,
                  (disk = ls.(ls_disk) \/
                   exists a v,
                     index ls.(ls_log) i = Some (a, v) /\
                     disk = assign ls.(ls_disk) a v) /\
                  LogDecode ps' {| ls_committed := true;
                                   ls_log := ls.(ls_log);
                                   ls_disk := disk; |};
         |}).
  Proof.
    spec_impl; split_cases; simplify; finish.
    - pose proof (logd_log_bounds ltac:(eassumption)).
      lia.
    - destruct (index_dec ls.(ls_log) i); propositional; try lia.
      destruct (sel ls.(ls_log) i) as [a v].
      descend; intuition eauto.
      erewrite logd_log_value in * by eauto; eauto.
      inv_clear H7.
      erewrite logd_disk in * by eauto.
      destruct H0; econstructor; simpl in *; eauto.
    - exists ls.(ls_disk); intuition eauto.
      destruct ps, ls; simpl in *; congruence.
    - eexists; split.
      { right; eauto. }
      erewrite logd_disk in * by eauto.
      destruct H0; econstructor; simpl in *; eauto.
  Qed.
End ApplyAtRespec.

Global Hint Resolve log_apply_at_ok : core.

Theorem apply_upto_ok ps ls d0 desc len i :
  proc_hspec
    (apply_upto desc i len)
    (fun state =>
       {| pre := PhyDecode state ps /\
                 LogDecode ps ls /\
                 desc = ps.(p_desc) /\
                 i + len = length ls.(ls_log) /\
                 ls.(ls_committed) = true /\
                 massign (subslice ls.(ls_log) i len) ls.(ls_disk) =
                 massign ls.(ls_log) d0 /\
                 massign ls.(ls_log) ls.(ls_disk) =
                 massign ls.(ls_log) d0;
          post state' r :=
            r = tt /\
            exists ps',
              PhyDecode state' ps' /\
              LogDecode ps' {| ls_committed := true;
                               ls_log := ls.(ls_log);
                               ls_disk := massign ls.(ls_log) d0; |};
          alternate state' _ :=
            exists ps',
              PhyDecode state' ps' /\
              ps'.(p_desc) = desc /\
              exists disk,
                LogDecode ps' {| ls_committed := true;
                                 ls_log := ls.(ls_log);
                                 ls_disk := disk; |} /\
                (* re-applying the entire log to the crashed disk... *)
                massign ls.(ls_log) disk =
                (* will finish what we started *)
                massign ls.(ls_log) d0;
       |}).
Proof.
  gen ps ls d0 desc i.
  induction len; simpl; intros.
  - step; split_cases; simplify; finish.
    + destruct ls; simpl in *; congruence.
    + exists ls.(ls_disk).
      intuition eauto.
      destruct ls; simpl in *; congruence.
  - step; split_cases; simplify; finish.
    + unfold applied_after, fully_applied.
      replace (length ls.(ls_log) - i) with (S len) by lia.
      auto.

    + spec_intros; simplify.
      lazymatch goal with
      | [ H: PhyDecode _ ?ps' |- _ ] =>
        eapply proc_hspec_impl;
          [ unfold spec_impl |
            apply (IHlen ps' {| ls_committed := true;
                                 ls_log := ls.(ls_log);
                                  ls_disk := ps'.(p_data_region) |}) ]
      end; simpl; split_cases; simplify;
        try erewrite logd_disk in * by eauto;
        finish;
        simpl in *.
      { fold addr block in *.
        rewrite log_apply_one_more; eauto.
        fold addr block in *.
        rewrite H4.
        rewrite <- H5.
        erewrite <- log_apply_reapply_one by eauto; auto. }
      { erewrite <- log_apply_reapply_one in * by eauto.
        congruence. }
      { eexists; intuition eauto.
        replace (massign ls.(ls_log) disk).
        erewrite <- log_apply_reapply_one by eauto; auto. }
    + eexists; intuition eauto.
      erewrite <- log_apply_reapply_one by eauto; auto.
Qed.

Local Hint Resolve gethdr_ok : core.
Local Hint Resolve getdesc_ok : core.
Local Hint Resolve apply_upto_ok : core.
Local Hint Resolve writehdr_ok : core.

Lemma LogDecode_clear_hdr:
  forall desc log_values data_region d',
    data_region = d' ->
    LogDecode
      {|
        p_hdr := empty_hdr;
        p_desc := desc;
        p_log_values := log_values;
        p_data_region := data_region |}
      {| ls_committed := false; ls_log := nil; ls_disk := d' |}.
Proof.
  intros; subst.
  constructor; simpl; intros; array.
  lia.
Qed.

Global Hint Resolve LogDecode_clear_hdr : core.

Definition log_apply_spec ps ls d0 is_commit : Specification unit unit disk :=
    (fun state =>
       {| pre := PhyDecode state ps /\
                 LogDecode ps ls /\
                 massign ls.(ls_log) ls.(ls_disk) =
                 massign ls.(ls_log) d0 /\
                 ls.(ls_committed) = is_commit;
          post state' r :=
            exists ps', PhyDecode state' ps' /\
                   if is_commit then
                     LogDecode ps' {| ls_committed := false;
                                      ls_log := nil;
                                      ls_disk := massign ls.(ls_log) d0; |}
                   else
                     LogDecode ps' {| ls_committed := false;
                                      ls_log := nil;
                                      ls_disk := ls.(ls_disk); |};
          alternate state' _ :=
            exists ps',
              PhyDecode state' ps' /\
              match is_commit with
              | true =>
                ( (* still working *)
                  exists disk,
                    LogDecode ps' {| ls_committed := true;
                                     ls_log := ls.(ls_log);
                                     ls_disk := disk; |} /\
                    (* ...but would finish (identical to precondition) *)
                    massign ls.(ls_log) disk =
                    massign ls.(ls_log) d0 ) \/
                ( (* done, applied the whole log *)
                  LogDecode ps' {| ls_committed := false;
                                   ls_log := nil;
                                   ls_disk := massign ls.(ls_log) d0; |} )
              | false =>
                (* never had to commit, but may or may not have cleared the log
                by writing the header *)
                exists log,
                LogDecode ps' {| ls_committed := false;
                                 ls_log := log;
                                 ls_disk := ls.(ls_disk); |}
              end;
       |}).

Theorem log_apply_ok ps ls is_commit :
  proc_hspec
    (log_apply)
    (log_apply_spec ps ls ls.(ls_disk) is_commit).
Proof.
  unfold log_apply, log_apply_spec.
  step; split_cases; simplify; finish.
  - destruct_with_eqn (r.(committed)).
    + step; split_cases; simplify; finish;
      erewrite logd_committed in * by eauto;
      repeat simpl_match.
      { step; split_cases; simplify; finish.
        - erewrite logd_loglen by eauto; lia.
        - rewrite subslice_whole; eauto.
          erewrite logd_loglen by eauto; lia.

        - spec_intros; simplify.
          spec_impl; split_cases; simplify; finish.

          + erewrite logd_disk in * by eauto; simpl in *; auto.
          + left.
            eexists; intuition eauto.
            rewrite massign_idempotent; auto.
          + right.
            erewrite logd_disk in * by eauto; simpl in *; auto. }
      left.
      exists ls.(ls_disk); intuition eauto.
      destruct ls; simpl in *; congruence.

    + monad_simpl.
      spec_impl; split_cases; simplify; finish;
        erewrite logd_committed in * by eauto;
        repeat simpl_match;
        eauto.

      exists ls.(ls_log).
      destruct ls; simpl in *; congruence.

  - destruct_with_eqn (ls.(ls_committed)); eauto.
    + left.
      exists ls.(ls_disk); intuition eauto.
      destruct ls; simpl in *; congruence.
    + exists ls.(ls_log).
      destruct ls; simpl in *; congruence.
Qed.

Theorem recovery_ok ps ls is_commit :
  proc_hspec
    (recovery)
    (log_apply_spec ps ls ls.(ls_disk) is_commit).
Proof.
  unfold recovery.
  apply log_apply_ok.
Qed.

Inductive Recghost (restrict:LogicalState -> Prop) :=
| recghost (ps:PhysicalState) (ls:LogicalState) (pf:restrict ls).

Arguments recghost {restrict}.

Theorem log_apply_spec_idempotent :
  idempotent
    (fun '(ps, ls) => log_apply_spec ps ls ls.(ls_disk) ls.(ls_committed)).
Proof.
  unfold idempotent; intuition eauto; simplify.
  simpl in H0; propositional.
  destruct_with_eqn (b.(ls_committed)); split_cases;
    match goal with
    | [ H: PhyDecode state' ?ps',
           H': LogDecode ?ps' ?ls' |- _ ] =>
      exists (ps', ls')
    end;
    simpl in *;
    repeat simpl_match;
    simplify; finish.
Qed.

Theorem log_apply_spec_idempotent' ls0 :
  idempotent
    (fun (a: Recghost (fun ls =>
                       if ls.(ls_committed) then
                         massign ls.(ls_log) ls.(ls_disk) =
                         massign ls0.(ls_log) ls0.(ls_disk)
                       else ls.(ls_disk) = ls0.(ls_disk) \/
                            ls.(ls_disk) = massign ls0.(ls_log) ls0.(ls_disk))) =>
       let 'recghost ps ls _ := a in
       log_apply_spec ps ls ls.(ls_disk) ls.(ls_committed)).
Proof.
  unfold idempotent; intuition eauto; simplify.
  destruct a.
  simpl in *; propositional.
  destruct_with_eqn (ls.(ls_committed)); split_cases;
    lazymatch goal with
    | [ H: PhyDecode state' ?ps',
           H': LogDecode ?ps' ?ls' |- _ ] =>
      unshelve eexists (recghost ps' ls' _)
    end; simpl; simplify; finish.
Qed.

Theorem log_apply_spec_idempotent_notxn' ls0 :
  idempotent
    (fun (a: Recghost (fun ls => ls.(ls_disk) = ls0.(ls_disk))) =>
       let 'recghost ps ls _ := a in
       log_apply_spec ps ls ls.(ls_disk) false).
Proof.
  unfold idempotent; intuition eauto; simplify.
  destruct a.
  simpl in H0; propositional.
  destruct_with_eqn (ls.(ls_committed)); split_cases;
    match goal with
    | [ H: PhyDecode _ ?ps,
           H': LogDecode ?ps ?ls |- _ ] =>
      unshelve eexists (recghost ps ls _)
    end; simpl in *; repeat simpl_match; simplify; finish.
Qed.

Local Hint Resolve phy_log_size_ok : core.

Theorem log_size_ok ps ls :
  proc_hspec
    (log_size)
    (fun state =>
       {| pre := PhyDecode state ps /\
                 LogDecode ps ls /\
                 ls.(ls_committed) = false;
          post state' r :=
            r = length ls.(ls_disk) /\
            state' = state;
          alternate state' _ :=
            state' = state |}).
Proof.
  spec_impl; split_cases; simplify.
  erewrite logd_disk by eauto; auto.
Qed.

Local Hint Resolve phy_log_init_ok : core.

Theorem log_init_ok :
  proc_hspec
    (log_init)
    (fun state =>
       {| pre := True;
          post state' r :=
            match r with
            | Initialized =>
              exists ps ls,
              PhyDecode state' ps /\
              LogDecode ps ls /\
              ls.(ls_committed) = false /\
              ls.(ls_log) = nil
            | InitFailed => True
            end;
          alternate state' _ := True |}).
Proof.
  spec_impl; simplify.
  destruct v; simplify; finish.
  exists ps, {| ls_committed := false;
           ls_log := nil;
           ls_disk := ps.(p_data_region); |};
    simpl;
    intuition eauto.
  destruct ps; simpl in *.
  constructor; intros; array; eauto.
  lia.
Qed.

Global Hint Resolve log_apply_ok : core.

Lemma LogDecode_setcommit:
  forall (ps : PhysicalState) (ls : LogicalState),
    LogDecode ps ls ->
    LogDecode
      {|
        p_hdr := hdr_setcommit ps.(p_hdr);
        p_desc := ps.(p_desc);
        p_log_values := ps.(p_log_values);
        p_data_region := ps.(p_data_region) |}
      {| ls_committed := true;
         ls_log := ls.(ls_log);
         ls_disk := ls.(ls_disk) |}.
Proof.
  intros ps ls H0.
  destruct H0; constructor; simpl; propositional; array.
Qed.

Global Hint Resolve LogDecode_setcommit : core.

Theorem log_commit_ok ps ls :
  proc_hspec
    (commit)
    (fun state =>
       {| pre := PhyDecode state ps /\
                 LogDecode ps ls /\
                 ls.(ls_committed) = false;
          post state' r :=
            exists ps' ls',
              PhyDecode state' ps' /\
              LogDecode ps' ls' /\
              ls'.(ls_committed) = false /\
              ls'.(ls_log) = nil /\
              ls'.(ls_disk) = massign ls.(ls_log) ls.(ls_disk);
          alternate state' _ :=
            exists ps',
              PhyDecode state' ps' /\
              (* copy of log_apply crash condition *)
              ((( (* still working *)
                  exists disk,
                    LogDecode ps' {| ls_committed := true;
                                     ls_log := ls.(ls_log);
                                     ls_disk := disk; |} /\
                    (* ...but would finish (identical to precondition) *)
                    massign ls.(ls_log) disk =
                    massign ls.(ls_log) ls.(ls_disk) ) \/
                ( (* done, applied the whole log *)
                  LogDecode ps' {| ls_committed := false;
                                   ls_log := nil;
                                   ls_disk := massign ls.(ls_log) ls.(ls_disk); |} )) \/
              ((* never had to commit, but may or may not have cleared the log
                by writing the header *)
                exists log,
                LogDecode ps' {| ls_committed := false;
                                 ls_log := log;
                                 ls_disk := ls.(ls_disk); |}))
       |}).
Proof.
  step; split_cases; simplify; finish.
  - step; split_cases; simplify; finish.
    + spec_impl; simpl; split_cases; simplify; finish.
      simpl in *.
      descend; intuition eauto.

    + right.
      exists ls.(ls_log).
      destruct ls; simpl in *; congruence.
    + left; left; eauto.
  - right.
    exists ls.(ls_log).
    destruct ls; simpl in *; congruence.
Qed.


Require Import Coqlib.
Require Import Maps.
Require Import maps_ext.
Require Import syntax.
Require Import infrastructure.
Require Import dom_tree.
Require Import dom_list.
Require Import dom_list_tree.
Require Import dom_libs.
Require Import dfs.
Require Import push_iter.
Import LLVMsyntax.
Import LLVMinfra.

(* This file constructs domination frontiers.

  We follow an algorithm that approaches the problem from the opposite direction,
  and tends to run faster than Cytron et al.’s algorithm in practice. The
  algorithm is based on three observations. First, nodes in a dominance frontier
  represent join points in the graph, nodes into which control flows from
  multiple predecessors. Second, the predecessors of any join point, j, must have
  j in their respective dominancefrontier sets, unless the predecessor dominates
  j. This is a direct result of the defnition of dominance frontiers, above.
  Finally, the dominators of j’s predecessors must themselves have j in their
  dominance frontier sets unless they also dominate j.

  These observations lead to a simple algorithm. First, we identify each join
  point, j—any node with more than one incoming edge is a join point. We then
  examine each predecessor, p, of j and walk up the dominator tree starting at p.
  We stop the walk when we reach j’s immediate dominator—j is in the dominance
  frontier of each of the nodes in the walk, except for j’s immediate dominator.
  Intuitively, all of the rest of j’s dominators are shared by j’s predecessors
  as well. Since they dominate j, they will not have j in their dominance
  frontiers.

  This approach tends to run faster than Cytron et al..’s algorithm in practice,
  almost certainly for two reasons. First, the iterative algorithm has already
  built the dominator tree. Second, the algorithm uses no more comparisons than
  are strictly necessary. Section 9.5.2 will revisit the implementation of the
  algorithm. *)
Definition idom_of (dts: PMap.t LDoms.t) (p:positive) : option positive :=
match PMap.get p dts with
| Some (idom::_) => Some idom
| _ => None
end.

Definition doms_of (dts: PMap.t LDoms.t) (p:positive) : list positive :=
match PMap.get p dts with
| Some sdoms => p::sdoms
| _ => nil
end.

(* given curr, idom is the immediate dom of curr, and
   ps doms curr's predecesssors *)
Fixpoint who_has_dom_frontier_aux (curr idom:positive)
  (acc:PTree.t (list positive)) (ps:list positive) : PTree.t (list positive) :=
match ps with
| nil => acc
| p::ps' =>
  if (positive_eq_dec idom p) then acc
  else who_has_dom_frontier_aux curr idom (PTree.set p (curr::acc???p) acc) ps'
end.

(* given curr, idom is the immediate dom of curr, and
   pred is one of curr's predecesssors *)
Definition who_has_dom_frontier (dts: PMap.t LDoms.t) (curr idom:positive)
  (acc:PTree.t (list positive)) (pred:positive) : PTree.t (list positive) :=
who_has_dom_frontier_aux curr idom acc (doms_of dts pred).

Definition pdom_frontier_fun (dts: PMap.t LDoms.t) (acc:PTree.t (list positive))
  (p:positive) (preds: list positive) : PTree.t (list positive) :=
match preds with
| p1::p2::_ =>
  match idom_of dts p with
  | None => acc
  | Some idom => fold_left (who_has_dom_frontier dts p idom) preds acc
  end
| _ => acc
end.

Definition pdom_frontier (ppreds: PTree.t (list positive))
  (dts: PMap.t LDoms.t) : PTree.t (list positive) :=
PTree.fold (pdom_frontier_fun dts) ppreds (PTree.empty _).

Definition dom_frontier (f: fdef) (gen_tree: bool)
  : ATree.t (list l) * option DTree :=
  let asuccs := cfg.successors f in
  match LLVMinfra.getEntryLabel f with
  | Some le =>
      let '(mkPO _ a2p) := dfs asuccs le 1%positive in
      let psuccs := asuccs_psuccs a2p asuccs in
      match ATree.get le a2p with
      | Some pe =>
         let dts := pdom_analyze psuccs pe (num_iters f) in
         let ppreds := XPTree.make_predecessors psuccs in
         let dfs := pdom_frontier ppreds dts in
         let p2a := a2p_p2a a2p in
         let odt :=
           if gen_tree then
             let res := fun p:positive => PMap.get p dts in
             let pdt := create_dtree pe (get_reachable_nodes (bound_fdef f) a2p) res in
             DTreeConv.sdtree_tdtree p2a pdt
           else None in
         let df := PTree.fold
           (fun acc p0 df0 =>
            match p2a ? p0 with
            | None => acc
            | Some a0 => ATree.set a0 (ps2as p2a df0) acc
            end) dfs (ATree.empty _) in
         (df, odt)
      | None => (ATree.empty _, None)
      end
  | None => (ATree.empty _, None)
  end.


(*Require Import Coq.Logic.FunctionalExtensionality.*)
Require Import Coq.Logic.Eqdep.

Require Import CatSem.AXIOMS.functional_extensionality.

Require Export CatSem.RPCF.RPCF_rep_cat.
Require Export CatSem.RPCF.RPCF_syntax_init.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Section unique.

Variable R : REP.

Variable g : PCFE_rep ---> R.

Lemma initR_unique : g == initR R.
Proof.
  simpl.
  assert (H : forall t, Sorts_map (initR R) t = Sorts_map g t).
  simpl.
  induction t; simpl;
  destruct g; simpl in *;
  try rerew_all; auto.
  repeat rew_all; auto.
  apply (eq_rep (H:=H)).

  intros V t y.
  destruct y as [t y];
  simpl in *.
(*  generalize (H t). *)
  assert (H' : Init_Sorts_map R = Sorts_map g).
   apply functional_extensionality; intros.
   destruct g.
   rew_all. auto.
  destruct g as [f garrow gnat gbool gM gMs];
  simpl in *.
  generalize (H t).
  generalize H.
  generalize dependent gM.
  clear H.
  generalize dependent gnat.
  generalize dependent gbool.
  generalize dependent garrow.
  rewrite <- H'.
  intros; simpl.
  rewrite (UIP_refl _ _ _ ).
  simpl.
  clear g.
  assert (Hl := rlift_transp_id (Q:=R) H).
  simpl in *.
  rewrite Hl.
  clear Hl.
  clear e H.
    induction y;
  simpl.

  assert (Hb:=bottom_hom (PCFPO_rep_Hom_struct := gMs)
            t (c:=V) tt).
  simpl in *.
  auto.

  destruct c.

    assert (Hb:=nats_hom n (PCFPO_rep_Hom_struct :=
            gMs)  (c:=V) tt).
    simpl in *.
    rewrite (UIP_refl _ _ _) in Hb.
    simpl in * ; auto.

    assert (Hb:=ttt_hom (PCFPO_rep_Hom_struct :=
            gMs)  (c:=V) tt).
    simpl in *.
    rewrite (UIP_refl _ _ _) in Hb.
    simpl in * ; auto.

    assert (Hb:=fff_hom (PCFPO_rep_Hom_struct :=
            gMs)  (c:=V) tt).
    simpl in *.
    rewrite (UIP_refl _ _ _) in Hb.
    simpl in * ; auto.

    assert (Hb:=Succ_hom (PCFPO_rep_Hom_struct :=
            gMs) (c:=V) tt).
    simpl in *.
    rewrite (UIP_refl _ _ _ ) in Hb.
    simpl in Hb.
    auto.

    assert (Hb:=Pred_hom (PCFPO_rep_Hom_struct :=
            gMs)  (c:=V) tt).
    simpl in *.
    rewrite (UIP_refl _ _ _ ) in Hb.
    simpl in Hb.
    auto.

    assert (Hb:=Zero_hom (PCFPO_rep_Hom_struct :=
            gMs)  (c:=V) tt).
    simpl in *.
    rewrite (UIP_refl _ _ _ ) in Hb.
    simpl in Hb.
    auto.

    assert (Hb:=CondN_hom (PCFPO_rep_Hom_struct :=
            gMs)  (c:=V) tt).
    simpl in *.
    rewrite (UIP_refl _ _ _ ) in Hb.
    simpl in Hb.
    auto.

    assert (Hb:=CondB_hom (PCFPO_rep_Hom_struct :=
            gMs)  (c:=V) tt).
    simpl in *.
    rewrite (UIP_refl _ _ _ ) in Hb.
    simpl in Hb.
    auto.

     (*1*)
  assert (Hw:=gen_rmonad_hom_rweta
     ((*gen_RMonad_Hom_struct := *)gM)).
     simpl in Hw.
  assert (Hw' := Hw _ _ (ctype _ v)).
  simpl in Hw'.
  auto.
  (*2*)
  simpl.
  rewrite <- IHy1.
  rewrite <- IHy2.
  assert (Happ:=app_hom (PCFPO_rep_Hom_struct :=
            gMs) (u:=s) (v:=t) (y1,y2)).
  simpl in *.
  rewrite <- Happ.
  clear Happ.
  apply f_equal.
  simpl.
  apply injective_projections;
  simpl;
  auto.
  rewrite (UIP_refl _ _ (garrow s t)).
  auto.

  (*3*)
  simpl.
  rewrite <- IHy.
  clear IHy.
  assert (Habs:=abs_hom (PCFPO_rep_Hom_struct :=
            gMs) (u:=t) (v:=s)  y ).
  simpl in *.
  rewrite Habs.
  rewrite (UIP_refl _ _ _ ).
  reflexivity.

  simpl.
  rewrite <- IHy.
  assert (Happ:=rec_hom (PCFPO_rep_Hom_struct :=
            gMs) (t:=t) y).
  simpl in *.
  rewrite Happ.
  rewrite (UIP_refl _ _ _ ).
  reflexivity.
Qed.

End unique.

Hint Resolve initR_unique : fin.

Program Instance PCF_initial : Initial REP := {
  Init := PCFE_rep ;
  InitMor R := initR R ;
  InitMorUnique R := @initR_unique R
}.

(* Print Assumptions PCF_initial. *)


From iris.program_logic Require Export ectx_language ectxi_language.
From iris_logrel.prelude Require Export base.
From iris.algebra Require Export cofe.
From iris.prelude Require Import gmap.

Module lang.
  Definition loc := positive.

  Instance loc_dec_eq (l l' : loc) : Decision (l = l') := _.

  Inductive binop := Add | Sub | Eq | Le | Lt.

  Instance binop_dec_eq (op op' : binop) : Decision (op = op').
  Proof. solve_decision. Defined.

  Inductive expr :=
  | Var (x : var)
  | Rec (e : {bind 2 of expr})
  | App (e1 e2 : expr)
  (* Base Types *)
  | Unit
  | Nat (n : nat)
  | Bool (b : bool)
  | BinOp (op : binop) (e1 e2 : expr)
  (* If then else *)
  | If (e0 e1 e2 : expr)
  (* Products *)
  | Pair (e1 e2 : expr)
  | Fst (e : expr)
  | Snd (e : expr)
  (* Sums *)
  | InjL (e : expr)
  | InjR (e : expr)
  | Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr})
  (* Recursive Types *)
  | Fold (e : expr)
  | Unfold (e : expr)
  (* Polymorphic Types *)
  | TLam (e : expr)
  | TApp (e : expr)
  (* Concurrency *)
  | Fork (e : expr)
  (* Reference Types *)
  | Loc (l : loc)
  | Alloc (e : expr)
  | Load (e : expr)
  | Store (e1 : expr) (e2 : expr)
  (* Compare and swap used for fine-grained concurrency *)
  | CAS (e0 : expr) (e1 : expr) (e2 : expr).

  Instance Ids_expr : Ids expr. derive. Defined.
  Instance Rename_expr : Rename expr. derive. Defined.
  Instance Subst_expr : Subst expr. derive. Defined.
  Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.

  (* Notation for bool and nat *)
  Notation "#♭ b" := (Bool b) (at level 20).
  Notation "#n n" := (Nat n) (at level 20).

  Instance expr_dec_eq (e e' : expr) : Decision (e = e').
  Proof. solve_decision. Defined.

  Inductive val :=
  | RecV (e : {bind 1 of expr})
  | TLamV (e : {bind 1 of expr})
  | UnitV
  | NatV (n : nat)
  | BoolV (b : bool)
  | PairV (v1 v2 : val)
  | InjLV (v : val)
  | InjRV (v : val)
  | FoldV (v : val)
  | LocV (l : loc).

  (* Notation for bool and nat *)
  Notation "'#♭v' b" := (BoolV b) (at level 20).
  Notation "'#nv' n" := (NatV n) (at level 20).

  Fixpoint binop_eval (op : binop) : nat → nat → val :=
    match op with
    | Add => λ a b, #nv(a + b)
    | Sub => λ a b, #nv(a - b)
    | Eq => λ a b, if (eq_nat_dec a b) then #♭v true else #♭v false
    | Le => λ a b, if (le_dec a b) then #♭v true else #♭v false
    | Lt => λ a b, if (lt_dec a b) then #♭v true else #♭v false
    end.

  Instance val_dec_eq (v v' : val) : Decision (v = v').
  Proof. solve_decision. Defined.

  Instance val_inh : Inhabited val := populate UnitV.

  Fixpoint of_val (v : val) : expr :=
    match v with
    | RecV e => Rec e
    | TLamV e => TLam e
    | UnitV => Unit
    | NatV v => Nat v
    | BoolV v => Bool v
    | PairV v1 v2 => Pair (of_val v1) (of_val v2)
    | InjLV v => InjL (of_val v)
    | InjRV v => InjR (of_val v)
    | FoldV v => Fold (of_val v)
    | LocV l => Loc l
    end.

  Fixpoint to_val (e : expr) : option val :=
    match e with
    | Rec e => Some (RecV e)
    | TLam e => Some (TLamV e)
    | Unit => Some UnitV
    | Nat n => Some (NatV n)
    | Bool b => Some (BoolV b)
    | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
    | InjL e => InjLV <$> to_val e
    | InjR e => InjRV <$> to_val e
    | Fold e => v ← to_val e; Some (FoldV v)
    | Loc l => Some (LocV l)
    | _ => None
    end.

  (** Evaluation contexts *)
  Inductive ectx_item :=
  | AppLCtx (e2 : expr)
  | AppRCtx (v1 : val)
  | TAppCtx
  | PairLCtx (e2 : expr)
  | PairRCtx (v1 : val)
  | BinOpLCtx (op : binop) (e2 : expr)
  | BinOpRCtx (op : binop) (v1 : val)
  | FstCtx
  | SndCtx
  | InjLCtx
  | InjRCtx
  | CaseCtx (e1 : {bind expr}) (e2 : {bind expr})
  | IfCtx (e1 : {bind expr}) (e2 : {bind expr})
  | FoldCtx
  | UnfoldCtx
  | AllocCtx
  | LoadCtx
  | StoreLCtx (e2 : expr)
  | StoreRCtx (v1 : val)
  | CasLCtx (e1 : expr)  (e2 : expr)
  | CasMCtx (v0 : val) (e2 : expr)
  | CasRCtx (v0 : val) (v1 : val).

  Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
    match Ki with
    | AppLCtx e2 => App e e2
    | AppRCtx v1 => App (of_val v1) e
    | TAppCtx => TApp e
    | PairLCtx e2 => Pair e e2
    | PairRCtx v1 => Pair (of_val v1) e
    | BinOpLCtx op e2 => BinOp op e e2
    | BinOpRCtx op v1 => BinOp op (of_val v1) e
    | FstCtx => Fst e
    | SndCtx => Snd e
    | InjLCtx => InjL e
    | InjRCtx => InjR e
    | CaseCtx e1 e2 => Case e e1 e2
    | IfCtx e1 e2 => If e e1 e2
    | FoldCtx => Fold e
    | UnfoldCtx => Unfold e
    | AllocCtx => Alloc e
    | LoadCtx => Load e
    | StoreLCtx e2 => Store e e2
    | StoreRCtx v1 => Store (of_val v1) e
    | CasLCtx e1 e2 => CAS e e1 e2
    | CasMCtx v0 e2 => CAS (of_val v0) e e2
    | CasRCtx v0 v1 => CAS (of_val v0) (of_val v1) e
    end.

  Definition state : Type := gmap loc val.

  Inductive head_step : expr → state → expr → state → list expr → Prop :=
  (* β *)
  | BetaS e1 e2 v2 σ :
      to_val e2 = Some v2 →
      head_step (App (Rec e1) e2) σ e1.[(Rec e1), e2/] σ []
  (* Products *)
  | FstS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Fst (Pair e1 e2)) σ e1 σ []
  | SndS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Snd (Pair e1 e2)) σ e2 σ []
  (* Sums *)
  | CaseLS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjL e0) e1 e2) σ e1.[e0/] σ []
  | CaseRS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjR e0) e1 e2) σ e2.[e0/] σ []
    (* nat bin op *)
  | BinOpS op a b σ :
      head_step (BinOp op (#n a) (#n b)) σ (of_val (binop_eval op a b)) σ []
  (* If then else *)
  | IfFalse e1 e2 σ :
      head_step (If (#♭ false) e1 e2) σ e2 σ []
  | IfTrue e1 e2 σ :
      head_step (If (#♭ true) e1 e2) σ e1 σ []
  (* Recursive Types *)
  | Unfold_Fold e v σ :
      to_val e = Some v →
      head_step (Unfold (Fold e)) σ e σ []
  (* Polymorphic Types *)
  | TBeta e σ :
      head_step (TApp (TLam e)) σ e σ []
  (* Concurrency *)
  | ForkS e σ:
      head_step (Fork e) σ Unit σ [e]
  (* Reference Types *)
  | AllocS e v σ l :
     to_val e = Some v → σ !! l = None →
     head_step (Alloc e) σ (Loc l) (<[l:=v]>σ) []
  | LoadS l v σ :
     σ !! l = Some v →
     head_step (Load (Loc l)) σ (of_val v) σ []
  | StoreS l e v σ :
     to_val e = Some v → is_Some (σ !! l) →
     head_step (Store (Loc l) e) σ Unit (<[l:=v]>σ) []
  (* Compare and swap *)
  | CasFailS l e1 v1 e2 v2 vl σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     σ !! l = Some vl → vl ≠ v1 →
     head_step (CAS (Loc l) e1 e2) σ (#♭ false) σ []
  | CasSucS l e1 v1 e2 v2 σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     σ !! l = Some v1 →
     head_step (CAS (Loc l) e1 e2) σ (#♭ true) (<[l:=v2]>σ) [].

  (** Basic properties about the language *)
  Lemma to_of_val v : to_val (of_val v) = Some v.
  Proof. by induction v; simplify_option_eq. Qed.

  Lemma of_to_val e v : to_val e = Some v → of_val v = e.
  Proof.
    revert v; induction e; intros; simplify_option_eq; auto with f_equal.
  Qed.

  Instance of_val_inj : Inj (=) (=) of_val.
  Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

  Lemma fill_item_val Ki e :
    is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
  Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.

  Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
  Proof. destruct Ki; intros ???; simplify_eq; auto with f_equal. Qed.

  Lemma val_stuck e1 σ1 e2 σ2 ef :
    head_step e1 σ1 e2 σ2 ef → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma head_ctx_step_val Ki e σ1 e2 σ2 ef :
    head_step (fill_item Ki e) σ1 e2 σ2 ef → is_Some (to_val e).
  Proof. destruct Ki; inversion_clear 1; simplify_option_eq; eauto. Qed.

  Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
    to_val e1 = None → to_val e2 = None →
    fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
  Proof.
    destruct Ki1, Ki2; intros; try discriminate; simplify_eq;
    repeat match goal with
           | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
           end; auto.
  Qed.

  Lemma alloc_fresh e v σ :
    let l := fresh (dom _ σ) in
    to_val e = Some v → head_step (Alloc e) σ (Loc l) (<[l:=v]>σ) [].
  Proof. by intros; apply AllocS, (not_elem_of_dom (D:=gset _)), is_fresh. Qed.

  Canonical Structure stateC := leibnizC state.
  Canonical Structure valC := leibnizC val.
  Canonical Structure exprC := leibnizC expr.
End lang.

(** Language *)
Program Instance heap_ectxi_lang :
  EctxiLanguage
    (lang.expr) lang.val lang.ectx_item lang.state := {|
  of_val := lang.of_val; to_val := lang.to_val;
  fill_item := lang.fill_item; head_step := lang.head_step
|}.
Solve Obligations with eauto using lang.to_of_val, lang.of_to_val,
  lang.val_stuck, lang.fill_item_val, lang.fill_item_no_val_inj,
  lang.head_ctx_step_val.

Canonical Structure lang := ectx_lang (lang.expr).

Export lang.

Definition is_atomic (e : expr) : Prop :=
  match e with
  | Alloc e => is_Some (to_val e)
  | Load e =>  is_Some (to_val e)
  | Store e1 e2 => is_Some (to_val e1) ∧ is_Some (to_val e2)
  | CAS e0 e1 e2 => is_Some (to_val e0) ∧ is_Some (to_val e1) ∧ is_Some (to_val e2)
  | _ => False
  end.
Lemma is_atomic_correct e : is_atomic e → language.atomic e.
Proof.
  intros ?; apply ectx_language_atomic.
  - destruct 1; simpl; by eauto using to_of_val.
  - intros [|Ki K] e' -> Hval%eq_None_not_Some; [done|].
    destruct Hval; apply (fill_val K e'). destruct Ki; naive_solver.
Qed.

Ltac solve_atomic :=
  apply is_atomic_correct; simpl; repeat split;
    rewrite ?to_of_val; eapply mk_is_Some; fast_done.

Hint Extern 0 (language.atomic _) => solve_atomic.
Hint Extern 0 (language.atomic _) => solve_atomic : typeclass_instances.


Require Import List Map Envs AllInRel Exp MoreList.
Require Import IL Annotation.
Require Import ExpVarsBounded SpillSound SpillUtil.
Require Import PartialOrder.

Set Implicit Arguments.

Definition is_live_min k ZL Λ s sl LV
  := forall R M, spill_sound k ZL Λ (R,M) s sl
                 -> LV ⊆ R ∪ M.

Inductive live_min (k:nat)
  : list params -> list (⦃var⦄ * ⦃var⦄) -> ⦃var⦄ -> stmt -> spilling -> ann ⦃var⦄ -> Prop :=
| RMinLet ZL Λ x e s an sl LV lv G
  : live_min k ZL Λ (singleton x) s sl lv
    -> is_live_min k ZL Λ (stmtLet x e s) (ann1 an sl) (LV \ G)
    -> live_min k ZL Λ G (stmtLet x e s) (ann1 an sl) (ann1 LV lv)
| RMinIf ZL Λ e s1 s2 an sl1 sl2 LV lv1 lv2 G
  : live_min k ZL Λ ∅ s1 sl1 lv1
    -> live_min k ZL Λ ∅ s2 sl2 lv2
    -> is_live_min k ZL Λ (stmtIf e s1 s2) (ann2 an sl1 sl2) (LV \ G)
    -> live_min k ZL Λ G (stmtIf e s1 s2) (ann2 an sl1 sl2) (ann2 LV lv1 lv2)
| RMinReturn ZL Λ e an LV G
  : is_live_min k ZL Λ (stmtReturn e) (ann0 an) (LV \ G)
    -> live_min k ZL Λ G (stmtReturn e) (ann0 an) (ann0 LV)
| RMinApp ZL Λ f Y an LV G
  : is_live_min k ZL Λ (stmtApp f Y) (ann0 an) (LV \ G)
    -> live_min k ZL Λ G (stmtApp f Y) (ann0 an) (ann0 LV)
| RSpillFun ZL Λ G F t spl rms sl_F sl_t LV lv_F lv_t
  : (forall n Zs sl_s lv_s rm,
        get F n Zs
        -> get sl_F n sl_s
        -> get lv_F n lv_s
        -> get rms n rm
        -> live_min k (fst ⊝ F ++ ZL) (rms ++ Λ) (fst rm) (snd Zs) sl_s lv_s)
    -> live_min k (fst ⊝ F ++ ZL) (rms ++ Λ) ∅ t sl_t lv_t
    -> is_live_min k ZL Λ (stmtFun F t) (annF (spl, rms) sl_F sl_t) (LV \ G)
    -> live_min k ZL Λ G (stmtFun F t) (annF (spl, rms) sl_F sl_t) (annF LV lv_F lv_t)
.

Lemma live_min_G_anti k ZL Λ G G' s sl lv
  : live_min k ZL Λ G s sl lv
    -> G ⊆ G'
    -> live_min k ZL Λ G' s sl lv.
Proof.
  intros RLM Incl.
  general induction RLM; econstructor; intros; eauto;
    hnf; intros; rewrite <- Incl; eauto.
Qed.

Lemma live_min_getAnn k ZL Λ s sl lv R M :
  live_min k ZL Λ ∅ s sl lv
  -> spill_sound k ZL Λ (R,M) s sl
  -> getAnn lv ⊆ R ∪ M
.
Proof.
  intros rliveMin spillSnd. general induction rliveMin; cbn; unfold is_live_min in H;
                              rewrite <-minus_empty; try eapply H; eauto.
Qed.

Lemma live_min_getAnn_G k ZL Λ G s sl lv :
  live_min k ZL Λ G s sl lv
  -> (forall R M, spill_sound k ZL Λ (R,M) s sl -> getAnn lv ⊆ R ∪ M)
  -> live_min k ZL Λ ∅ s sl lv
.
Proof.
  intros rliveMin isMin.
  general induction rliveMin; econstructor; cbn in *; eauto;
    unfold is_live_min; intros; rewrite minus_empty; eapply isMin; eauto.
Qed.

Lemma live_min_incl_R k ZL Λ s sl lv R M G :
  G ⊆ R ∪ M
  -> spill_sound k ZL Λ (R, M) s sl
  -> live_min k ZL Λ G s sl lv
  -> getAnn lv ⊆ R ∪ M
.
Proof.
  intros Geq spillSnd rlive.
  general induction rlive; cbn;
    unfold is_live_min in *; rewrite <-union_subset_equal with (s':=R ∪ M); eauto;
      apply incl_minus_incl_union; [| | | |eapply H1;eauto]; eapply H; eauto.
Qed.

Lemma is_live_min_ext Λ Λ' k ZL s sl LV :
  poEq Λ Λ'
  -> is_live_min k ZL Λ  s sl LV
  -> is_live_min k ZL Λ' s sl LV
.
Proof.
  intros pir2 H. unfold is_live_min in *.
  intros. eapply spill_sound_ext in H0; eauto.
Qed.

Lemma live_min_ext Λ Λ' k ZL G s sl lv :
  poEq Λ Λ'
  -> live_min k ZL Λ  G s sl lv
  -> live_min k ZL Λ' G s sl lv
.
Proof.
  intros Λeq lvMin. general induction lvMin; unfold is_live_min;
                      econstructor; eauto using is_live_min_ext.
Qed.

Lemma is_live_min_monotone Λ Λ' k ZL s sl LV :
  poLe Λ Λ'
  -> is_live_min k ZL Λ  s sl LV
  -> is_live_min k ZL Λ' s sl LV
.
Proof.
  intros pir2 H. unfold is_live_min in *.
  intros. eapply spill_sound_monotone in H0; eauto.
Qed.

Lemma live_min_monotone Λ Λ' k ZL G s sl lv :
  poLe Λ Λ'
  -> live_min k ZL Λ  G s sl lv
  -> live_min k ZL Λ' G s sl lv
.
Proof.
  intros Λeq lvMin. general induction lvMin; unfold is_live_min;
                      econstructor; eauto using is_live_min_monotone.
Qed.


(*
  [TypeTheory.TypeCat_CompCat.TypeCat_ComprehensionCat]

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

(**
This module defines a comprehension category induced by a (non-split) type category.

Main definition is

- [typecat_ff_comprehension_cat_weq] - (non-split) type categories are fully faithful comprehension categories;

Important parts are:

- [typecat_obj_ext_structure_disp_ff_functor_to_codomain_weq]
  - object extension structures of type category are displayed functors into displayed codomain category; this equivalence is computationally friendly and maps object extension structures to an inclusion functor (specifically [target_disp_inclusion_functor]) from a subcategory of codomain displayed category.

*)

Require Import UniMath.MoreFoundations.PartA.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.TypeCat.TypeCat.
Require Import TypeTheory.CompCats.FullyFaithfulDispFunctor.
Require Import TypeTheory.TypeCat_CompCat.TypeCat_ComprehensionCat.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.
Require Import UniMath.CategoryTheory.DisplayedCats.Codomain.
Require Import UniMath.CategoryTheory.DisplayedCats.ComprehensionC.

Section Auxiliary.

  (* TODO: move upstream? *)
  Definition weqforall_comm
             {X Y : UU}
             (P : X → Y → UU)
    : (∏ (x : X) (y : Y), P x y) ≃ (∏ (y : Y) (x : X), P x y).
  Proof.
    use weq_iso.
    - intros f. exact (λ y x, f x y).
    - intros f. exact (λ y x, f x y).
    - apply idpath.
    - apply idpath.
  Defined.

End Auxiliary.

Local Notation "'π' A" := (dpr_typecat_obj_ext A) (at level 5).

Section TypeCat_ComprehensionCat_Equiv.

  Definition typecat_obj_ext_structure_disp_ff_functor_to_codomain_weq
             (C : category)
    : typecat_obj_ext_structure C ≃ ff_disp_functor (disp_codomain C).
  Proof.
    use weq_iso.
    - intros tc.
      exists (pr1 tc).
      intros Γ A.
      exists (obj_ext_typecat Γ A).
      apply (pr2 tc).
    - intros F.
      exists (pr1 F).
      use tpair.
      + intros Γ A.
        exact (pr1 (pr2 F Γ A)).
      + intros Γ A.
        exact (pr2 (pr2 F Γ A)).
    - intros ?. apply idpath.
    - intros ?. apply idpath.
  Defined.

  Definition typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq
             (C : category)
    : typecat_obj_ext_structure C ≃ ff_disp_functor_explicit (disp_codomain C).
  Proof.
    eapply weqcomp. apply typecat_obj_ext_structure_disp_ff_functor_to_codomain_weq.
    apply ff_disp_functor_weq2.
  Defined.

  Definition typecat_structure2' {C : category}
             (TC : typecat_obj_ext_structure C)
    : UU
    := ∑ (reind : ∏ Γ (A : TC Γ) Γ' (f : Γ' --> Γ), TC Γ')
         (q : ∏ Γ (A : TC Γ) Γ' (f : Γ' --> Γ), (obj_ext_typecat Γ' (reind _ A _ f)) --> obj_ext_typecat Γ A )
         (dpr_q : ∏ Γ (A : TC Γ) Γ' (f : Γ' --> Γ),
                  (q _ A _ f) ;; (dpr_typecat_obj_ext A) = (dpr_typecat_obj_ext (reind _ A _ f)) ;; f),
       ∏ Γ (A : TC Γ) Γ' (f : Γ' --> Γ),
       isPullback (!dpr_q _ A _ f).

  Definition typecat_structure' (C : category) : UU
    := ∑ (TC : typecat_obj_ext_structure C),
         typecat_structure2' TC.

  Definition typecat_structure_typecat_structure'_weq
             (C : category)
    : typecat_structure C ≃ typecat_structure' C.
  Proof.
    eapply weqcomp. apply weqtotal2asstor.
    apply invweq.
    eapply weqcomp. apply weqtotal2asstor.
    apply (weqtotal2 (idweq _)). intros Ty.

    eapply weqcomp. apply weqtotal2asstor.
    apply invweq. eapply weqcomp. apply weqtotal2asstor.
    apply (weqtotal2 (idweq _)). intros ext.

    eapply weqcomp. unfold typecat_structure2. simpl.
    apply (@WeakEquivalences.weqtotal2comm
             _ _
             (λ reind dpr,
              ∑ (q : ∏ Γ (A : Ty Γ) Γ' (f : Γ' --> Γ), (ext Γ' (reind _ A _ f)) --> ext Γ A )
                (dpr_q : ∏ Γ (A : Ty Γ) Γ' (f : Γ' --> Γ),
                         (q _ A _ f) ;; (dpr _ A) = (dpr _ (reind _ A _ f)) ;; f),
              _)).
    apply idweq.
  Defined.

  Definition typecat_structure2'' {C : category}
             (TC : typecat_obj_ext_structure C)
    : UU
    := ∏ Γ (A : TC Γ) Γ' (f : Γ' --> Γ),

      ∑ (reind : TC Γ')
         (q : obj_ext_typecat Γ' reind --> obj_ext_typecat Γ A )
         (dpr_q : q ;; (dpr_typecat_obj_ext A)
                  = dpr_typecat_obj_ext reind ;; f),
       isPullback (!dpr_q).

  Definition typecat_structure'' (C : category) : UU
    := ∑ (TC : typecat_obj_ext_structure C),
         typecat_structure2'' TC.

  Definition typecat_structure'_typecat_structure''_weq
             (C : category)
    : typecat_structure' C ≃ typecat_structure'' C.
  Proof.
    apply (weqtotal2 (idweq _)). intros TC.
    eapply weqcomp.

    apply (weqtotaltoforall4
             (λ Γ, TC Γ → ∏ Γ' : C, C ⟦ Γ', Γ ⟧ → TC Γ')
             (λ (Γ : C) reind, ∏ (A : TC Γ) (Γ' : C) (f : C ⟦ Γ', Γ ⟧),
              C ⟦ obj_ext_typecat Γ' (reind A Γ' f), obj_ext_typecat Γ A ⟧)
             (λ (Γ : C) reind q, ∏ (A : TC Γ) (Γ' : C) (f : C ⟦ Γ', Γ ⟧),
              (q A Γ' f;; π A)%mor = (π (reind A Γ' f);; f)%mor)
             (λ (Γ : C) reind q dpr_q, ∏ (A : TC Γ) (Γ' : C) (f : C ⟦ Γ', Γ ⟧),
              isPullback (! dpr_q A Γ' f))).
    apply weqonsecfibers. intros Γ.

    eapply weqcomp.
    apply (weqtotaltoforall4
             (λ A, ∏ Γ' : C, C ⟦ Γ', Γ ⟧ → TC Γ')
             (λ A reind, ∏ (Γ' : C) (f : C ⟦ Γ', Γ ⟧),
              C ⟦ obj_ext_typecat Γ' (reind Γ' f), obj_ext_typecat Γ A ⟧)
             (λ A reind q, ∏ (Γ' : C) (f : C ⟦ Γ', Γ ⟧),
              (q Γ' f;; π A)%mor = (π (reind Γ' f);; f)%mor)
             (λ (A : TC Γ) reind q dpr_q, ∏ (Γ' : C) (f : C ⟦ Γ', Γ ⟧),
              isPullback (! dpr_q Γ' f))).
    apply weqonsecfibers. intros A.

    eapply weqcomp.
    apply (weqtotaltoforall4
             (λ Γ', C ⟦ Γ', Γ ⟧ → TC Γ')
             (λ Γ' reind, ∏ (f : C ⟦ Γ', Γ ⟧),
              C ⟦ obj_ext_typecat Γ' (reind f), obj_ext_typecat Γ A ⟧)
             (λ Γ' reind q, ∏ (f : C ⟦ Γ', Γ ⟧),
              (q f;; π A)%mor = (π (reind f);; f)%mor)
             (λ Γ' reind q dpr_q, ∏ (f : C ⟦ Γ', Γ ⟧),
              isPullback (! dpr_q f))).
    apply weqonsecfibers. intros Γ'.

    apply (weqtotaltoforall4
             (λ f, TC Γ')
             (λ f reind, C ⟦ obj_ext_typecat Γ' reind, obj_ext_typecat Γ A ⟧)
             (λ f reind q, (q ;; π A)%mor = (π reind ;; f)%mor)
             (λ f reind q dpr_q, isPullback (! dpr_q))).
  Defined.

  Definition ff_comprehension_cat_structure (C : category) : UU
    := ∑ (F : ∑ (D : disp_cat C)
                (F : disp_functor (functor_identity _) D (disp_codomain C))
              , disp_functor_ff F),
       cleaving (pr1 F) × is_cartesian_disp_functor (pr1 (pr2 F)).

  (* TODO: move upstream? *)
  Definition isaprop_is_cartesian_image_of_cleaving
        {C C' : category} {F : functor C C'}
        {D : disp_cat C} {D' : disp_cat C'} {FF : disp_functor F D D'}
        (cleaving_D : cleaving D)
    : isaprop (∏ (c c' : C) (f : c' --> c) (d : D c),
               is_cartesian (#FF (cleaving_D c c' f d))).
  Proof.
    apply impred_isaprop. intros c.
    apply impred_isaprop. intros c'.
    apply impred_isaprop. intros f.
    apply impred_isaprop. intros d.
    apply isaprop_is_cartesian.
  Qed.

  (* TODO: move upstream? *)
  Definition isaprop_is_cartesian_disp_functor
        {C C' : category} {F : functor C C'}
        {D : disp_cat C} {D' : disp_cat C'} {FF : disp_functor F D D'}
    : isaprop (is_cartesian_disp_functor FF).
  Proof.
    apply impred_isaprop. intros c.
    apply impred_isaprop. intros c'.
    apply impred_isaprop. intros f.
    apply impred_isaprop. intros d.
    apply impred_isaprop. intros d'.
    apply impred_isaprop. intros ff.
    apply impred_isaprop. intros ff_is_cartesian.
    apply isaprop_is_cartesian.
  Qed.

  (* TODO: move upstream? *)
  Lemma cartesian_functor_from_fibration_weq
        {C C' : category} {F : functor C C'}
        {D : disp_cat C} {D' : disp_cat C'} {FF : disp_functor F D D'}
        (cleaving_D : cleaving D)
    : (∏ (c c' : C) (f : c' --> c) (d : D c),
       is_cartesian (#FF (cleaving_D c c' f d)))
        ≃ is_cartesian_disp_functor FF.
  Proof.
    use weqimplimpl.
    - intros is_cartesian_image_of_cleaving.
      apply cartesian_functor_from_fibration.
      intros c c' f d.
      apply hinhpr.
      exists (cleaving_D c c' f d).
      apply is_cartesian_image_of_cleaving.
    - intros FF_is_cartesian.
      intros c c' f d.
      apply FF_is_cartesian.
      apply cartesian_lift_is_cartesian.
    - apply isaprop_is_cartesian_image_of_cleaving.
    - apply isaprop_is_cartesian_disp_functor.
  Defined.

  (* TODO: generalize to any functor into codomain? *)
  Definition pullback_is_cartesian
             {C : category}
             {TC : typecat_obj_ext_structure C}
             {Γ Γ' : C} {f : Γ' --> Γ}
             {A : pr1 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq _ TC) Γ}
             {A' : pr1 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq _ TC) Γ'}
             (ff : A' -->[f] A)
    : (isPullback (! pr2 ff)) -> is_cartesian ff.
  Proof.
    - intros pb.
      intros Δ g B ggff.
      eapply iscontrweqf.
      2: {
        use pb.
        - exact (obj_ext_typecat Δ B).
        - exact (dpr_typecat_obj_ext B ;; g).
        - exact (pr1 ggff).
        - etrans. apply assoc'.
          apply pathsinv0, (pr2 ggff).
      }

      eapply weqcomp.
      2: apply weqtotal2asstol.
      apply weq_subtypes_iff.
      -- intro. apply isapropdirprod; apply homset_property.
      -- intro. apply (isofhleveltotal2 1).
         ++ apply homset_property.
         ++ intros. apply homsets_disp.
      -- intros gg; split; intros H.
         ++ exists (pr1 H).
            apply subtypePath.
            intro; apply homset_property.
            exact (pr2 H).
         ++ split.
            ** exact (pr1 H).
            ** exact (maponpaths pr1 (pr2 H)).
  Defined.

  Definition pullback_is_cartesian'
             {C : category}
             {TC : typecat_obj_ext_structure C}
             {Γ Γ' : C} {f : Γ' --> Γ}
             {A : pr1 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq _ TC) Γ}
             {A' : pr1 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq _ TC) Γ'}
             (ff : A' -->[f] A)
    : isPullback (! pr2 ff) ->
      is_cartesian (# (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq _ TC) ff).
  Proof.
    intros pb.
    intros Δ g k hh.
    use iscontrweqf.
    3: {
      use pb.
      - exact (pr1 k).
      - exact (pr2 k ;; g).
      - exact (pr1 hh).
      - etrans. apply assoc'.
        apply pathsinv0, (pr2 hh).
    }

    eapply weqcomp.
    2: apply weqtotal2asstol.
    apply weq_subtypes_iff.
    -- intro. apply isapropdirprod; apply homset_property.
    -- intro. apply (isofhleveltotal2 1).
       ++ apply homset_property.
       ++ intros. apply homsets_disp.
    -- intros gg; split; intros H.
       ++ exists (pr1 H).
          apply subtypePath.
          intro; apply homset_property.
          exact (pr2 H).
       ++ split.
          ** exact (pr1 H).
          ** exact (maponpaths pr1 (pr2 H)).
  Defined.

  Definition typecat_structure2''_cleaving_weq
             {C : category} (TC : typecat_obj_ext_structure C)
    : typecat_structure2'' TC
    ≃ ( cleaving (pr1 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq _ TC))
      × is_cartesian_disp_functor (pr1 (pr2 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq _ TC)))).
  Proof.
    (* Step 0: relax is_cartesian_disp_functor property *)
     eapply weqcomp.
     2: apply (weqtotal2 (idweq _) cartesian_functor_from_fibration_weq).

      (* Step 1: introduces context (while exchanging ∏ and × on the right) *)
     apply invweq. unfold cleaving.
     eapply weqcomp.
     apply (weqtotaltoforall
              (λ c, ∏ (c' : C) (f : C ⟦ c', c ⟧)
                     (d : pr1 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq C TC) c),
               cartesian_lift d f)
              (λ c x, ∏ (c' : C) (f : C ⟦ c', c ⟧)
                      (d : pr1 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq C TC) c),
               is_cartesian
                 (# (pr1 (pr2 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq C TC)))
                    (x c' f d)))).
     apply weqonsecfibers. intros Γ.
     eapply weqcomp.
     apply (weqtotaltoforall
              (λ c', ∏ (f : C ⟦ c', Γ ⟧)
                     (d : pr1 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq C TC) Γ),
               cartesian_lift d f)
              (λ c' x, ∏ (f : C ⟦ c', Γ ⟧)
                      (d : pr1 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq C TC) Γ),
               is_cartesian
                 (# (pr1 (pr2 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq C TC)))
                    (x f d)))).
     eapply weqcomp. 2: apply weqforall_comm.
     apply weqonsecfibers. intros Γ'.
     eapply weqcomp.
     apply (weqtotaltoforall
              (λ (f : C ⟦ Γ', Γ ⟧), ∏ (d : pr1 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq C TC) Γ),
               cartesian_lift d f)
              (λ (f : C ⟦ Γ', Γ ⟧) x,
               ∏ (d : pr1 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq C TC) Γ),
               is_cartesian
                 (# (pr1 (pr2 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq C TC)))
                    (x d)))).
     eapply weqcomp. 2: apply weqforall_comm.
     apply weqonsecfibers. intros f.
     eapply weqcomp.
     apply (weqtotaltoforall
              (λ (d : pr1 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq C TC) Γ),
               cartesian_lift d f)
              (λ (d : pr1 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq C TC) Γ) x,
               is_cartesian
                 (# (pr1 (pr2 (typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq C TC)))
                    x))).
     apply weqonsecfibers. intros A.

    (* Step 2: object part of cartesian lift is trivial *)
    apply invweq.
    eapply weqcomp. 2: apply weqtotal2asstol.
    apply (weqtotal2 (idweq _)). intros A'.

    (* Step 3: morphism part of cartesian lift
     * is available through equivalence of morphisms *)
    eapply weqcomp. 2: apply weqtotal2asstol.
    eapply weqcomp.
    apply (weqtotal2asstol
             (λ q, (q ;; π A)%mor = (π A' ;; f)%mor)
             (λ qq, isPullback (! pr2 qq))
          ).
    set (FF := typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq _ TC).
    use (weqtotal2 (idweq _)).
    intros qq.

    (* Step 4: equivalence of pullback and cleaving *)
    apply weqimplimpl.
    3: apply isaprop_isPullback.
    3: {
      use isofhleveltotal2.
      - apply isaprop_is_cartesian.
      - intros ?. apply isaprop_is_cartesian.
    }

    - intros pb.
      use tpair.
      + apply pullback_is_cartesian. apply pb.
      + intros ? ? ?. apply pullback_is_cartesian'. apply pb.

    - intros Hcart.
      intros Δ g k H.
      eapply iscontrweqf.
      2: {
        use (pr2 Hcart).
        - exact Γ'.
        - exact (identity _).
        - exact (Δ,,g).
        - exists k. etrans. apply pathsinv0, H.
          apply maponpaths.
          apply pathsinv0, id_left.
      }

      apply invweq.
      eapply weqcomp.
      2: apply weqtotal2asstol.
      apply weq_subtypes_iff.
      + intro. apply isapropdirprod; apply homset_property.
      + intro. apply (isofhleveltotal2 1).
        * apply homset_property.
        * intros. apply homsets_disp.
    + intros gg; split; intros H'.
      * use tpair.
        -- etrans. apply (pr1 H').
          apply pathsinv0, id_right.
        -- apply subtypePath.
          intro; apply homset_property.
          exact (pr2 H').
      * split.
        -- etrans. apply (pr1 H'). apply id_right.
        -- etrans.
           apply (maponpaths pr1 (pr2 H')).
           apply idpath.
  Defined.

  Definition typecat_structure''_ff_comprehension_cat_structure_weq
             (C : category)
    : typecat_structure'' C ≃ ff_comprehension_cat_structure C.
  Proof.
    use weqtotal2.
    - apply typecat_obj_ext_structure_ff_disp_functor_to_codomain_weq.
    - intros TC.
      apply typecat_structure2''_cleaving_weq.
  Defined.

  Definition typecat_ff_comprehension_cat_structure_weq (C : category)
    : typecat_structure C ≃ ff_comprehension_cat_structure C.
  Proof.
    eapply weqcomp. apply typecat_structure_typecat_structure'_weq.
    eapply weqcomp. apply typecat_structure'_typecat_structure''_weq.
    apply typecat_structure''_ff_comprehension_cat_structure_weq.
  Defined.

  Definition ff_comprehension_cat : UU
    := ∑ (C : category), ff_comprehension_cat_structure C.

  Definition typecat_ff_comprehension_cat_weq
    : typecat ≃ ff_comprehension_cat.
  Proof.
    use weqtotal2. apply idweq. intros C.
    apply typecat_ff_comprehension_cat_structure_weq.
  Defined.

End TypeCat_ComprehensionCat_Equiv.


Require Import List Arith.
Require Import IL Annotation AutoIndTac Exp RenamedApart Util.
Require Import SetOperations Sim Var.
Require Import SMT NoFun.
Require Import Guards ILFtoSMT GuardProps ComputeProps.

(** Definitons **)
Definition combineEnv D (E1:onv val) E2 :=
  fun x => if [x ∈ D] then E1 x else E2 x.

(** Lemmata **)

Lemma combineEnv_agree D E E'
  : agree_on eq D (combineEnv D E E') E.
Proof.
  hnf; intros. unfold combineEnv. cases; eauto; isabsurd.
Qed.

Lemma combineEnv_agree_meet D D' Es Et
  : agree_on eq (D' ∩ D) Es Et
    -> agree_on eq D' (combineEnv D Es Et) Et.
Proof.
 intros.
 - hnf. cset_tac'. unfold combineEnv. cases; eauto.
   rewrite H; eauto. cset_tac.
Qed.

Lemma combineEnv_agree_minus D D' Es Et
  : agree_on eq (D' \ D) Es Et
    -> agree_on eq D' (combineEnv D Es Et) Es.
Proof.
 intros.
 - hnf. cset_tac'. unfold combineEnv. cases; eauto.
   rewrite H; eauto. cset_tac.
Qed.

Lemma combineEnv_models F s D Es Et
  : freeVars s ⊆  D
    -> (models F (to_total Es) s  <-> models F (to_total (combineEnv D Es Et)) s).
Proof.
  intros. eapply models_agree. eapply (agree_on_incl (lv:=D)); eauto; symmetry.
  eapply agree_on_total.
  eapply combineEnv_agree.
Qed.

Lemma combineEnv_omap_exp_eval_left el D Es Et
  : list_union (List.map Ops.freeVars el) ⊆ D
    -> omap (op_eval (combineEnv D Es Et)) el = omap (op_eval Es) el.
Proof.
  intros.
  erewrite omap_op_eval_agree; [reflexivity | | reflexivity].
  symmetry. eapply agree_on_incl; eauto using combineEnv_agree.
Qed.

Lemma combineEnv_omap_exp_eval_right el D Es Et
  : agree_on eq (list_union (List.map Ops.freeVars el) ∩ D) Es Et
    -> omap (op_eval (combineEnv D Es Et)) el = omap (op_eval Et) el.
Proof.
  intros.
  erewrite omap_op_eval_agree; [reflexivity | | reflexivity].
  symmetry. eapply combineEnv_agree_meet; eauto.
Qed.

Lemma renamedApart_contained L E s t Es D
: star nc_step (L, E, s) (L, Es, t)
  -> noFun s
  -> renamedApart s D
  -> IL.freeVars t ⊆ fst (getAnn D) ∪ snd (getAnn D).
Proof.
  intros Star nf_s ssa_s.
  general induction Star.
  - rewrite renamedApart_freeVars; eauto; eauto with cset.
  - destruct H; simpl in *. hnf in H.
    invt noFun; invt renamedApart; try invt F.step; simpl;
      rewrite IHStar; eauto; pe_rewrite.
    + rewrite H9. clear; cset_tac.
    + rewrite <- H8. clear; cset_tac.
    + rewrite <- H8. clear; cset_tac.
      Grab Existential Variables. eauto. eauto.
Qed.

Lemma nc_step_agree_combine D D' L E s t Es Et es et
  : renamedApart s D
    -> renamedApart t D'
    -> fst (getAnn D) [=] fst (getAnn D')
    -> disj (snd (getAnn D)) (snd (getAnn D'))
    -> noFun s
    -> noFun t
    -> star nc_step (L, E, s) (L, Es, stmtReturn es)
    -> star nc_step (L, E, t) (L, Et, stmtReturn et)
    -> (agree_on eq (Ops.freeVars et) Et (combineEnv (fst(getAnn D) ∪ snd(getAnn D)) Es Et)
       /\ agree_on eq (Ops.freeVars es) Es (combineEnv (fst(getAnn D) ∪ snd(getAnn D)) Es Et)).
Proof.
  intros ssa_s ssa_t agree_fv disj_dv nf_s nf_t sterm tterm.
  split.
  - exploit nc_step_agree; try eapply sterm; eauto.
    exploit nc_step_agree; try eapply tterm; eauto.
    exploit (renamedApart_contained L E t (stmtReturn et) Et D') as fv_dv; eauto.
    simpl in *. symmetry.
    eapply agree_on_incl; [ eapply combineEnv_agree_meet | reflexivity ].
    rewrite fv_dv. rewrite <- agree_fv.
    rewrite <- agree_fv in H0. rewrite H in H0; clear H.
    hnf; intros; cset_tac.
  - symmetry.
    eapply agree_on_incl; [eapply combineEnv_agree_minus | reflexivity ].
    exploit (renamedApart_contained L E s (stmtReturn es) Es D) as fv_dv; eauto.
    simpl in *.
    rewrite fv_dv. hnf; intros; cset_tac.
Qed.


Require Import Utf8.
Require Import Cpdt.CpdtTactics.

Set Implicit Arguments.

(* Implicit Types V: Set. *)

Inductive inc (V: Set) : Set :=
  | VZ : inc V
  | VS : V -> inc V.

Arguments VZ {V}.
Arguments VS {V}.

Inductive ty : Set :=
  | ty_bool : ty
  | ty_arrow : ty -> ty -> ty.

Inductive val (V: Set) : Set :=
  | v_var  : V -> val V
  | v_true : val V
  | v_false : val V
  | v_abs  : ty -> exp (inc V) -> val V
with exp (V : Set) : Set :=
  | e_val  : val V -> exp V
  | e_if   : exp V -> exp V -> exp V -> exp V
  | e_app  : exp V -> exp V -> exp V.

Arguments v_true {V}.
Arguments v_false {V}.
Arguments e_val {V}.
Arguments e_if {V}.
Arguments e_app {V}.

Notation "∅" := (Empty_set).

Definition empty_fun {T} : ∅ → T :=
  λ y, match y with end.

Notation exp0 := (exp Empty_set).
Notation val0 := (val Empty_set).