Require Import RL.Utilities.Rpos.
Require Import RL.hmr.term.
Require Import RL.hmr.semantic.
Require Import RL.hmr.hseq.
Require Import RL.hmr.hmr.
Require Import RL.hmr.interpretation.
Require Import RL.hmr.completeness.
Require Import RL.hmr.soundness.
Require Import RL.hmr.can_elim.

Require Import List.

Require Import RL.OLlibs.Permutation_Type.
Require Import RL.OLlibs.Permutation_Type_more.
Require Import RL.OLlibs.Permutation_Type_solve.

(** F is a Riesz space term. *)
Definition F := (((plus_pos One One) *S HMR_var 0) +S ((plus_pos One One) *S HMR_covar 1)) \/S (HMR_var 1 +S HMR_covar 0).

(** A proof that F is positive using equational reasonning. The proof uses some lemmas defined in soundness, but the derived tree is actually quite big. *)
Lemma F_is_pos : HMR_zero <== F.
Proof.
  unfold F.
  rewrite <- mul_distri_term.
  rewrite leq_pos_max_mul_l_inv; auto.
  rewrite commu_plus.
  apply zero_leq_abs.
Qed.

(** A proof that the sequent |- 1.F is derivable using the soundness of the HMR and the positivity of F. *)
Lemma F_is_provable_from_soundness : HMR_full (((One, F) :: nil) :: nil).
Proof.
  apply HMR_le_frag with hmr_frag_M_can; [ repeat split; auto | ].
  apply hmr_complete; [intros  H; inversion H | ].
  simpl; rewrite mul_1; rewrite neutral_plus.
  apply F_is_pos.
Qed.

(** An other derivation for the sequent |- 1.F *)
Lemma F_is_provable : HMR_full (((One, F) :: nil) :: nil).
Proof.
  change ((One, F) :: nil) with (vec (One :: nil) F ++ nil).
  unfold F.
  apply hmrr_max.
  eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | ].
  apply hmrr_plus.
  apply hmrr_mul.
  rewrite app_assoc.
  eapply hmrr_ex_seq ; [ apply Permutation_Type_app ; [ apply Permutation_Type_app_swap | reflexivity ] | ].
  rewrite <- app_assoc.
  apply hmrr_mul.
  eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | ].
  apply hmrr_plus.
  apply hmrr_T with (plus_pos One One); [reflexivity | ].
  apply hmrr_S.
  rewrite ? seq_mul_app.
  rewrite ? seq_mul_vec_mul_vec.
  apply hmrr_ex_seq with (vec (time_pos (plus_pos One One) One :: nil) (HMR_covar 0) ++ vec (time_pos (plus_pos One One) One :: nil) (HMR_var 0) ++ vec (time_pos (plus_pos One One) One :: nil) (HMR_covar 1) ++ vec (time_pos (plus_pos One One) One :: nil) (HMR_var 1) ++ nil).
  { simpl.
    Permutation_Type_solve. }
  apply hmrr_ID ; [ reflexivity | ].
  apply hmrr_ID ; [ reflexivity | ].
  apply hmrr_INIT.
Qed.

(** We can use the soundness of HMR to have a proof that F is positive. *)
Lemma F_is_pos_from_soundness : HMR_zero <== F.
Proof.
  apply leq_cong_r with (sem_hseq (((One, F) :: nil) :: nil)).
  { simpl.
    rewrite mul_1; rewrite neutral_plus; reflexivity. }
  apply hmr_sound with hmr_frag_full.
  apply F_is_provable.
Qed.

(** Finally, we can have a CAN-free proof of |- 1.F with the can elimination theorem. *)
Lemma F_is_provable_without_CAN : HMR_T_M (((One, F) :: nil) :: nil).
Proof.
  apply hmrr_can_elim.
  apply F_is_provable.
Qed.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Require Import common.lhs_sel_low_reduce.lhs_sel_low_reduce.
Require Import common.lhs_sel_upp_reduce.lhs_sel_upp_reduce.
Require Import common.lhs_sel_equ_reduce.lhs_sel_equ_reduce.
Require Import common.lhs_sel_nom_reduce.lhs_sel_nom_reduce.
Require Import common.lhs_sel_bnd_reduce.lhs_sel_bnd_reduce.
Require Import common.lhs_all_reduce.lhs_all_reduce.
Require Import common.lhs_rfn_top_reduce.lhs_rfn_top_reduce.
Require Import common.lhs_rfn_sel_reduce.lhs_rfn_sel_reduce.
Require Import common.lhs_sha_top_reduce.lhs_sha_top_reduce.
Require Import common.lhs_sha_sel_reduce.lhs_sha_sel_reduce.
Require Import common.lhs_upp_reduce.lhs_upp_reduce.
Require Import common.lhs_low_reduce.lhs_low_reduce.
Require Import common.lhs_equ_reduce.lhs_equ_reduce.
Require Import common.lhs_nom_reduce.lhs_nom_reduce.
Require Import common.lhs_nil_reduce.lhs_nil_reduce.
Require Import common.lhs_con_reduce.lhs_con_reduce.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_rhs_sel_low_reduce :
  forall T2 x L T2', T2 = t_sel_low x L T2' ->
                forall T1, subtype T1 T2' = true ->
                      (T1 <> t_nil) ->
                      (forall T1' Ts1, T1 <> t_con T1' Ts1) ->
                      (forall L1 T1', T1 <> t_upp L1 T1') ->
                      (forall L1 T1', T1 <> t_low L1 T1') ->
                      (forall L1 T1', T1 <> t_equ L1 T1') ->
                      (forall L1 T1', T1 <> t_nom L1 T1') ->
                      subtype T1 T2 = true.
Proof.
  intros.

  subst T2.

  destruct T1.

  unfold subtype, subtype_func;
    simpl;
    rewrite fix_sub_eq_ext;
    simpl;
    fold subtype_func;
    auto.

  rewrite subtype_bot; auto;
    try solve [intros; intros Hcontra; inversion Hcontra].

  erewrite subtype_sel_upp_sel_low_reduce; eauto;
    rewrite H0;
    repeat rewrite orb_true_r;
    auto.

  erewrite subtype_sel_low_sel_low_reduce; eauto;
    rewrite H0;
    repeat rewrite orb_true_r;
    auto.

  erewrite subtype_sel_equ_sel_low_reduce; eauto;
    rewrite H0;
    repeat rewrite orb_true_r;
    auto.

  erewrite subtype_sel_nom_sel_low_reduce; eauto;
    rewrite H0;
    repeat rewrite orb_true_r;
    auto.

  erewrite subtype_sel_bnd_sel_low_reduce; eauto;
    rewrite H0;
    repeat rewrite orb_true_r;
    auto.

  erewrite subtype_rfn_top_sel_low_reduce; eauto.

  erewrite subtype_rfn_sel_sel_low_reduce; eauto;
    rewrite H0;
    repeat rewrite orb_true_r;
    auto.

  erewrite subtype_sha_top_sel_low_reduce; eauto.

  erewrite subtype_sha_sel_sel_low_reduce; eauto;
    rewrite H0;
    repeat rewrite orb_true_r;
    auto.

  erewrite subtype_all_sel_low_reduce; eauto.

  contradiction (H3 l T1); auto.
  contradiction (H4 l T1); auto.
  contradiction (H5 l T1); auto.
  contradiction (H6 l T1); auto.
  contradiction (H1); auto.
  contradiction (H2 T1_1 T1_2); auto.
Qed.


(* This file is for lemmas that
  (a) are used in the proof that the functional prog = functional spec
  AND (b) are used in the proof about the C program.
This file DOES NOT IMPORT anything about C or CompCert
  (except the CompCert Integers module)
*)
Require Import compcert.lib.Coqlib.
Require Import msl.Coqlib2.
Require Import sha.general_lemmas.
Require Import sha.SHA256.

Lemma length_Round:
  forall regs f n,
   length regs = 8%nat ->
   length (Round regs f n) = 8%nat.
Proof.
intros.
destruct (zlt n 0).
rewrite Round_equation.
rewrite if_true by auto; auto.
replace n with (n+1-1) by omega.
rewrite <- (Z2Nat.id (n+1)) by omega.
revert regs H; induction (Z.to_nat (n+1)); intros.
rewrite Round_equation.
change (Z.of_nat 0 - 1) with (-1).
rewrite if_true by omega. auto.
clear n g. rename n0 into n.
rewrite Round_equation.
rewrite inj_S.
unfold Z.succ.
rewrite Z.add_simpl_r.
rewrite if_false by omega.
specialize (IHn0 _ H).
clear - IHn0.
rename f into f'.
destruct (Round regs f' (Z.of_nat n - 1))
  as [ | a [ | b [ | c [ | d [ | e [ | f [ | g [ | h [ | ]]]]]]]]]; try inv IHn0.
reflexivity.
Qed.

Lemma length_hash_block:
 forall regs block,
   length regs = 8%nat ->
   length block = 16%nat ->
   length (hash_block regs block) = 8%nat.
Proof.
intros.
unfold hash_block.
rewrite (length_map2 _ _ _ _ _ _ 8%nat); auto.
apply length_Round; auto.
Qed.

(* END COMMON LEMMAS *)


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Category.
Require Import Blech.Functor.
Require Blech.Reflect.

Import CategoryNotations.
Import FunctorNotations.

Open Scope category_scope.
Open Scope bishop_scope.

Close Scope nat.

Reserved Notation "A # B" (at level 80, right associativity).

#[local]
Obligation Tactic := Reflect.category_simpl.

#[program]
 Definition Prod (C D: Category): Category := {|
  Obj := C * D ;
  Mor A B := (fst A ~> fst B) * (snd A ~> snd B) ;
  Mor_Setoid _ _ := {| equiv x y := fst x == fst y ∧ snd x == snd y |} ;

  id _ := (id _, id _) ;
  compose _ _ _ f g := (fst f ∘ fst g, snd f ∘ snd g) ;
|}.

Next Obligation.
Proof.
Admitted.

Next Obligation.
Proof.
  intros ? ? p ? ? q.
  destruct p as [p p'], q as [q q'].
  cbn in *.
  rewrite p, p', q, q'.
  split.
  all: reflexivity.
Qed.

#[program]
Definition fanout [A B C] (F: Functor C A) (G: Functor C B): Functor C (Prod A B) := {|
  op x := (F x, G x) ;
  map _ _ x := (map F x, map G x) ;
|}.

Next Obligation.
Proof.
  exists.
  - intros.
    all: cbn.
    split.
    all: apply map_composes.
  - intros.
    all: cbn.
    split.
    all: apply map_id.
  - intros ? ? ? ? p.
    all: cbn.
    rewrite p.
    split.
    all: reflexivity.
Qed.

Instance fst_Functoral A B: @Functoral (Prod A B) A fst (λ _ _, fst).
Proof.
  exists.
  - cbn.
    intros.
    reflexivity.
  - cbn.
    intros.
    reflexivity.
  - cbn.
    intros ? ? ? ? [? ?].
    auto.
Qed.

Instance snd_Functoral A B: @Functoral (Prod A B) B snd (λ _ _, snd).
Proof.
  exists.
  - cbn.
    intros.
    reflexivity.
  - cbn.
    intros.
    reflexivity.
  - cbn.
    intros ? ? ? ? [? ?].
    auto.
Qed.

#[program]
Definition fst {A B}: Functor (Prod A B) A := {|
  op := fst ;
  map _ _ := fst ;
|}.

#[program]
 Definition snd {A B}: Functor (Prod A B) B := {|
  op := snd ;
  map _ _ := snd ;
|}.

Module Export ProdNotations.
  Infix "#" := fanout.
  Infix "*" := Prod : category_scope.
End ProdNotations.


Section program.

  Variable instr: Set -> Type.

  CoInductive program : Set -> Type :=
    | Then : forall A B:Set, instr A -> (A -> program B) -> program B
    | Return : forall A:Set, A -> program A.

  Implicit Arguments Then [A B].
  Implicit Arguments Return [A].

  CoFixpoint bind (A:Set) (B:Set) (m : program A) : (A -> program B) -> program B :=
    match m with
      | Return A a   => fun (g : A -> program B) => g a
      | Then C D i f =>
        fun (g : D -> program B) =>
          Then i (fun (c:C) => bind D _ (f c) g)
    end.

izero = \ x . { True | False } x

not = \ x . { False | True } x

\y. not (iszero y)

not (izero x)

{False | True} ({ True | False } x)

  CoFixpoint bind (A : Set) (B:Set) (m : program A) :=
    match m in (program A) return ((A -> program B) -> program B) with
      | Return A0 a   => fun (g : A0 -> program B) => g a
      | Then C D i f => fun (g : D -> program B) => Then i (fun (c:C) => bind D B (f c) g)
    end.

End program.

 Definition bind : forall (A:Set) (B:Set) (m : program A), (A -> program B) -> program B.
  Proof.
    refine
      (cofix bind (A:Set) (B:Set) (m : program A) : ((A -> program B) -> program B) :=
        match m in (program A) return ((A -> program B) -> program B) with
          | Return _ a   => _ (* fun (g : A -> program B) => g a *)
          | Then C D i f =>
            fun (g : D -> program B) =>
              Then i (fun (c:C) => bind D _ (f c) g)

        end).
    intro g. apply g in a. exact a.
  Defined.

  Print bind.

End program.


From Coq Require Import
    ssreflect
    ssrsearch
    Lia

    Reals

    Utf8
.

From Coquelicot Require Import
    Hierarchy
    Continuity
.

Require Import
    sigma_algebra_R_Rbar_new
    measurable_fun
    simpl_fun
    sigma_algebra
    hierarchy_notations
.

Section US_measurable_gen2_open.

    Context {U : UniformSpace}.

    Lemma measurable_gen2_open_implies_open :
        ∀ P : U * U -> Prop,
        measurable (gen2 open open) P -> measurable open P.
    Proof.
        move => P.
        move => H; induction H.
        apply measurable_gen => x Ax.
        case: H => P1; case => P2 [HP1 [HP2 HA]].
        assert (open P1) as HP1'.
            case: HP1 => //.
            move => ->; apply open_true.
        assert (open P2) as HP2'.
            case: HP2 => //.
            move => ->; apply open_true.
        clear HP1 HP2.
        case_eq x => x1 x2 Eqx.
        move: Ax => /HA; move => [/HP1' Hlocx1 /HP2' Hlocx2].
        case: Hlocx1; move => [ɛ1 Hɛ1] Hlocx1.
        case: Hlocx2; move => [ɛ2 Hɛ2] Hlocx2.
        pose ɛ := Rmin ɛ1 ɛ2.
        assert (0 < ɛ)%R as Hɛ.
        apply: Rmin_Rgt_r; split => //.
        pose sigɛ := {| RIneq.pos := ɛ; RIneq.cond_pos := Hɛ |}.
        exists sigɛ; move => [y1 y2] Hxy.
        apply HA; split; apply [Hlocx1, Hlocx2].
        1, 2 : rewrite Eqx /=; case Hxy => /= [Hball1 Hball2].
        1, 2 : apply ball_le with ɛ.
        1, 3 : apply [Rmin_l, Rmin_r].
        1, 2 : assumption.

        apply measurable_empty.
        apply measurable_compl => //.
        apply measurable_union_countable => //.
    Qed.

End US_measurable_gen2_open.

Section NM_measurable_fun_op.

    Context {X : Set}.
    Context (gen : (X -> Prop) -> Prop).

    Context {A : AbsRing}.
    Context {E : NormedModule A}.

    Open Scope hy_scope.

    Lemma NM_measurable_fun_plus_op :
        measurable_fun open open (λ c : E * E, fst c + snd c).
    Proof.
        apply measurable_fun_continuous => x.
        apply continuous_plus.
        apply continuous_fst.
        apply continuous_snd.
    Qed.

End NM_measurable_fun_op.


From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.
Import GenLow GenHigh.
Set Warnings "-extraction-opaque-accessed,-extraction".

From Coq Require Import
     ZArith
     String
     List.

From Vellvm Require Import
     Numeric.Integers
     Utils.Util.

From Cofq.SystemF Require Import
     SystemFDefinitions
     SystemFSemantics
     SystemFTyping
     SystemFUtils
     SystemFShow.

From Cofq.Utils Require Import
     Utils.

From Cofq.BaseExpressions Require Import
     IntegersShow
     BaseExpressionTests.

From Cofq.Test Require Import TestUtils.

Require Import Lia.

From ExtLib Require Import
     Structures.Monads
     Structures.MonadZero
     Structures.Functor
     Eqv.

Import ListNotations.
Import MonadNotation.
Local Open Scope monad_scope.

From ITree Require Import
     ITree
     Interp.Recursion
     Events.Exception.

Section Generators.
  Program Fixpoint genFType' (ftv : nat) (sz : nat) {measure sz} : G FType
    := match sz with
       | O => elems_fail (IntType :: map TVar (map N.of_nat (seq 0 ftv)))
       | S n' =>
         oneOf_ failGen
                [ genFType' ftv 0;
                a <- genFType' ftv (sz / 6);; b <- genFType' ftv (sz / 4);; ret (Arrow a b);
                a <- genFType' (S ftv) (sz - 1);; ret (TForall a);
                ts <- listOf (genFType' ftv (sz / 2));; ret (Prod ts)
                ]
       end.
  Next Obligation.
  Admitted.
  Next Obligation.
  Admitted.
  Next Obligation.
  Admitted.

  Definition genFType (ftv : nat) : G FType
    := sized (genFType' ftv).

  Definition genIfType {A} (τ1 τ2 : FType) (g : G A) : list (G A)
    := if ftype_eq τ1 τ2 then [g] else [].

  (* Randomly fetch a subterm of a type *)
  Fixpoint fetch_sub_type (τ : FType) : G FType
    :=
      oneOf_ failGen
             ((assert (is_closed τ);; [returnGen τ]) ++
                                                    (match τ with
                                                     | Arrow τ1 τ2 => [fetch_sub_type τ1 ; fetch_sub_type τ2]
                                                     | Prod τs => map fetch_sub_type τs
                                                     | TForall τ => [fetch_sub_type τ]
                                                     | _ => []
                                                     end)).

  (* Replace (some occurrences of) closed type s in type t by (TVar n) *)
  Fixpoint replace_sub_type (n : VarInd) (τ arg_τ : FType) : G FType
    := oneOf_ failGen
              ([ returnGen τ ] ++
                               (assert (ftype_eq τ arg_τ);; [returnGen (TVar n)]) ++
                               match τ with
                               | Arrow τ1 τ2 =>
                                 [τ1' <- replace_sub_type n τ1 arg_τ;;
                                  τ2' <- replace_sub_type n τ2 arg_τ;;
                                  returnGen (Arrow τ1' τ2')
                                 ]
                               | Prod τs =>
                                 [τs' <- map_monad (fun τ => replace_sub_type n τ arg_τ) τs;;
                                  returnGen (Prod τs)
                                 ]
                               | TForall τ =>
                                 (* TODO: make sure this is right *)
                                 assert (ftype_eq τ arg_τ);;
                                 [τ' <- replace_sub_type (n+1) τ arg_τ;;
                                  returnGen (TForall τ')
                                 ]
                               | _ => []
                               end).

  (* Generate t1 t2 such that t1{0:=t2} = t *)
  Definition genT1T2 (τ : FType) : G (FType * FType)
    := let τ' := type_lift 0 τ
       in τ2 <- fetch_sub_type τ';;
          (* τ1 <- replace_sub_type 0 τ' τ2;; *)
          returnGen (TForall τ', τ2).

  (* Probably want a variant of this that won't make recursive calls *)
  Program Fixpoint genTerm' (ftv : nat) (Γ : list FType) (τ : FType) (sz : nat) {measure sz} : G Term
    :=
      match sz with
      | 0 =>
        oneOf_ failGen
               ( (assert (ftype_eq IntType τ);; ret (fmap Num genInt64)) ++
                                                                        (* Generate variables from the context with the same type *)
                                                                        ('(i,τ') <- addIndices Γ;; assert (ftype_eq τ' τ);; ret (returnGen (Var i))) ++
                                                                        (* Generate fixpoints... Need a way of ruling out recursive applications *)
                                                                        (match τ with
                                                                         | Arrow τ1 τ2 =>
                                                                           [arg <- genTerm' ftv ((Arrow τ1 τ2) :: τ1 :: Γ) τ2 0;;
                                                                            returnGen (Fix (Arrow τ1 τ2) τ1 arg)
                                                                           ]
                                                                         | TForall τ1 =>
                                                                           [e <- genTerm' (ftv+1) (map (type_lift 0) Γ) τ1 0;;
                                                                            returnGen (TAbs e)
                                                                           ]
                                                                         | Prod τs =>
                                                                           [τs' <- map_monad (fun τ => genTerm' ftv Γ τ 0) τs;;
                                                                            returnGen (Tuple τs')
                                                                           ]
                                                                         | _ => []
                                                                         end)
               )
      | S x =>
        cut
          (freq_ failGen
                 ([(6, genTerm' ftv Γ τ 0);
                  (* Applications *)
                  (8, τ2 <- backTrack 2 (resize 10 (genFType ftv));;
                      nr <- choose (1,2);;
                      me1 <- backTrack nr (genTerm' ftv Γ (Arrow τ2 τ) (sz / 2));;
                      me2 <- genTerm' ftv Γ τ2 (sz / 2);;
                      returnGen (App me1 me2));
                  (* Type applications *)
                  (4, '(τ1, τ2) <- genT1T2 τ;;
                      me1 <- genTerm' ftv Γ τ1 (sz - 1);;
                      returnGen (TApp me1 τ2));
                  (* If0 *)
                  (1, c <- genTerm' ftv Γ IntType (sz / 3);;
                      e1 <- genTerm' ftv Γ τ (sz / 3);;
                      e2 <- genTerm' ftv Γ τ (sz / 3);;
                      returnGen (If0 c e1 e2))
                    (* TODO: unimplemented *)
                    (* Tuple projections *)
                    (* Annotated terms *)
                  ] ++
                    (match τ with
                     | Arrow τ1 τ2 =>
                       [(8, (arg <- genTerm' ftv ((Arrow τ1 τ2) :: τ1 :: Γ) τ2 (sz-1);;
                             returnGen (Fix (Arrow τ1 τ2) τ1 arg)))]
                     | TForall τ1 =>
                       [(4, (e <- genTerm' (ftv+1) (map (type_lift 0) Γ) τ1 (sz-1);;
                             returnGen (TAbs e)))]
                     | Prod τs =>
                       [(1, (τs' <- map_monad (fun τ => genTerm' ftv Γ τ (sz / (length τs))) τs;;
                             returnGen (Tuple τs')))]
                     | IntType =>
                       [(* Operators *)
                         (1, op <- genPrimOp;;
                             e1 <- genTerm' ftv Γ IntType (sz / 2);;
                             e2 <- genTerm' ftv Γ IntType (sz / 2);;
                             returnGen (Op op e1 e2))]
                     | _ => []
                     end)
                 )
          )
      end.
  Admit Obligations.

  Definition genTerm (ftv : nat) (Γ : list FType) (τ : FType) : G Term
    := sized (genTerm' ftv Γ τ).

  (* inl means it's a fixpoint variable *)
  Program Fixpoint genTerm_terminating' (ftv : nat) (Γ : list (FType + FType)) (τ : FType) (sz : nat) {measure sz} : G Term
    :=
      match sz with
      | 0 =>
        oneOf_ failGen
               ( (assert (ftype_eq IntType τ);; ret (fmap Num genInt64)) ++
                                                                        (* Generate variables from the context with the same type *)
                                                                        ('(i,mτ) <- addIndices Γ;;
                                                                         match mτ with
                                                                         | inr τ' =>
                                                                           assert (ftype_eq τ' τ);; ret (returnGen (Var i))
                                                                         | _ => [] (* Exclude fixpoint variables in general *)
                                                                         end) ++
                                                                        (match τ with
                                                                         | Arrow τ1 τ2 =>
                                                                           [arg <- genTerm_terminating' ftv (inl (Arrow τ1 τ2) :: inr τ1 :: Γ) τ2 0;;
                                                                            returnGen (Fix (Arrow τ1 τ2) τ1 arg)
                                                                           ]
                                                                         | TForall τ1 =>
                                                                           [e <- genTerm_terminating' (ftv+1) (map (map_both (type_lift 0)) Γ) τ1 0;;
                                                                            returnGen (TAbs e)
                                                                           ]
                                                                         | Prod τs =>
                                                                           [τs' <- map_monad (fun τ => genTerm_terminating' ftv Γ τ 0) τs;;
                                                                            returnGen (Tuple τs')
                                                                           ]
                                                                         | _ => []
                                                                         end)
               )
      | S x =>
        cut
          (freq_ failGen
                 ([(6, genTerm_terminating' ftv Γ τ 0);
                  (* Applications *)
                  (8, τ2 <- backTrack 2 (resize 10 (genFType ftv));;
                      nr <- choose (1,2);;
                      me1 <- backTrack nr (genTerm_terminating' ftv Γ (Arrow τ2 τ) (sz / 2));;
                      me2 <- genTerm_terminating' ftv Γ τ2 (sz / 2);;
                      returnGen (App me1 me2));
                  (* Generate simple loops *)
                  (1, loop_count <- choose (1%Z,5%Z);;

                      (* Loop counter *)
                      let loop_start := Num (Int64.repr loop_count) in
                      (* count_dec : IntType *)
                      let count_dec := (Op Sub (Var 1) (Num (Int64.repr 1))) in

                      (* Gamma for under fix *)
                      let Γ' := (inl (Arrow IntType τ)::inr IntType::Γ) in

                      nr <- choose (1,2);;
                      loop_done <- backTrack nr (genTerm_terminating' ftv Γ' τ (sz / 2));;

                      nr <- choose (1,2);;
                      main_body <- backTrack nr (genTerm_terminating' ftv Γ' (Arrow τ τ) (sz / 2));;
                      let loop_main := App main_body (App (Var 0) count_dec) in

                      let f := Fix (Arrow IntType τ) IntType
                                   (If0 (Var 1)
                                        loop_done
                                        loop_main) in

                      returnGen (App f loop_start));
                  (* Type applications *)
                  (4, '(τ1, τ2) <- genT1T2 τ;;
                      me1 <- genTerm_terminating' ftv Γ τ1 (sz - 1);;
                      returnGen (TApp me1 τ2));
                  (* If0 *)
                  (1, c <- genTerm_terminating' ftv Γ IntType (sz / 3);;
                      e1 <- genTerm_terminating' ftv Γ τ (sz / 3);;
                      e2 <- genTerm_terminating' ftv Γ τ (sz / 3);;
                      returnGen (If0 c e1 e2))
                    (* TODO: unimplemented *)
                    (* Tuple projections *)
                    (* Annotated terms *)
                  ] ++
                    (match τ with
                     | Arrow τ1 τ2 =>
                       [(8, (arg <- genTerm_terminating' ftv (inl (Arrow τ1 τ2) :: inr τ1 :: Γ) τ2 (sz-1);;
                             returnGen (Fix (Arrow τ1 τ2) τ1 arg)))]
                     | TForall τ1 =>
                       [(4, (e <- genTerm_terminating' (ftv+1) (map (map_both (type_lift 0)) Γ) τ1 (sz-1);;
                             returnGen (TAbs e)))]
                     | Prod τs =>
                       [(1, (τs' <- map_monad (fun τ => genTerm_terminating' ftv Γ τ (sz / (length τs))) τs;;
                             returnGen (Tuple τs')))]
                     | IntType =>
                       [(* Operators *)
                         (1, op <- genPrimOp;;
                             e1 <- genTerm_terminating' ftv Γ IntType (sz / 2);;
                             e2 <- genTerm_terminating' ftv Γ IntType (sz / 2);;
                             returnGen (Op op e1 e2))]
                     | _ => []
                     end)
                 )
          )
      end.
  Admit Obligations.

  Definition genTerm_terminating (ftv : nat) (Γ : list (FType + FType)) (τ : FType) : G Term
    := sized (genTerm_terminating' ftv Γ τ).

  Instance GenFType : GenSized FType :=
    {| arbitrarySized n := genFType' 0 n |}.

  Definition genTypedTerm (n : nat) : G Term :=
    bindGen (genFType' 0 n) (fun τ => genTerm' 0 [] τ n).

  Instance GenTerm : GenSized Term :=
    {| arbitrarySized n := genTypedTerm n |}.
End Generators.

Section Shrinking.
  Fixpoint shrink_ftype (τ : FType) : list FType
    := match τ with
       | Arrow τ1 τ2 =>
         [IntType; τ1; τ2] ++
                           (τ1' <- shrink_ftype τ1;;
                            ret (Arrow τ1' τ2)) ++
                           (τ2' <- shrink_ftype τ2;;
                            ret (Arrow τ1 τ2'))
       | Prod τs => (IntType :: τs) ++ (τs' <- map_monad shrink_ftype τs;; ret (Prod τs'))
       | TForall τ' =>
         [IntType; τ'] ++ (τ'' <- shrink_ftype τ';; ret (TForall τ''))
       | TVar x => IntType :: (x' <- shrink x;; ret (TVar x'))
       | IntType => []
       end.

  (* Shrink, but without preserving well typedness *)
  Fixpoint shrink_term' {I} `{FInt I} (e : Term) : list Term
    := match e with
       | Var x =>
         Num zero :: (x' <- shrink x;; ret (Var x'))
       | Ann e τ =>
         Num zero :: e :: ((τ' <- shrink_ftype τ;; ret (Ann e τ')) ++ (e' <- shrink_term' e;; ret (Ann e' τ)))
       | Fix fτ aτ body =>
         Num zero :: body :: ((fτ' <- shrink_ftype fτ;; ret (Fix fτ' aτ body)) ++
                                                                            (aτ' <- shrink_ftype aτ;; ret (Fix fτ aτ' body)) ++
                                                                            (body' <- shrink_term' body;; ret (Fix fτ aτ body')))
       | App e1 e2 =>
         Num zero :: e1 :: e2 :: ((e1' <- shrink_term' e1;; ret (App e1' e2)) ++
                                                                          (e2' <- shrink_term' e2;; ret (App e1 e2')))
       | TAbs body => Num zero :: body :: (body' <- shrink_term' body;; ret (TAbs body'))
       | TApp e τ =>
         Num zero :: e :: ((τ' <- shrink_ftype τ;; ret (TApp e τ')) ++ (e' <- shrink_term' e;; ret (TApp e' τ)))
       | Tuple es =>
         Num zero :: es ++ (es' <- map_monad shrink_term' es;; ret (Tuple es'))
       | ProjN i e =>
         Num zero :: e :: (i' <- shrink i;; ret (ProjN i' e)) ++ (e' <- shrink_term' e;; ret (ProjN i e'))
       | Num x => []
       | If0 c e1 e2 =>
         Num zero :: c :: e1 :: e2 :: ((c' <- shrink_term' c;; ret (If0 c' e1 e2)) ++
                                                                              (e1' <- shrink_term' e1;; ret (If0 c e1' e2)) ++
                                                                              (e2' <- shrink_term' e2;; ret (If0 c e1 e2')))
       | Op op e1 e2 =>
         Num zero :: e1 :: e2 :: ((e1' <- shrink_term' e1;; ret (Op op e1' e2)) ++
                                                                            (e2' <- shrink_term' e2;; ret (Op op e1 e2')))
       end.

  Definition shrink_term_preserve_type {I} `{FInt I} (e : Term) : list Term
    := match step e with
       | inr e' =>
         if (term_size e') <? (term_size e)
         then [e']
         else []
       | inl _ => []
       end ++
           (let e' := multistep 500 e in
            if (term_size e') <? (term_size e)
            then [e']
            else []).

  Definition shrink_term {I} `{FInt I} (e : Term) : list Term
    := (e' <- shrink_term' e;; assert (well_typed e');; ret e') ++
                                                              (* Double shrinks in case first step isn't well_typed *)
                                                              (e' <- shrink_term' e;; e'' <- shrink_term' e';; assert (well_typed e'');; ret e'') ++
                                                              shrink_term_preserve_type e.

  (* Preserves typeof *)
  Definition shrink_term_filtered {I} `{FInt I} (e : Term) : list Term
    := filter (fun e' =>
                 match typeof e', typeof e with
                 | Some x, Some y => ftype_eq x y
                 | None, None => true
                 | _, _ => false
                 end) (shrink_term e).

  Instance shrFType : Shrink FType :=
    {| shrink := shrink_ftype |}.

  Instance shrTerm {I} `{FInt I} : Shrink Term :=
    {| shrink := shrink_term |}.
End Shrinking.

(* *** Testing *** *)
Definition factorial : @Term Int64.int FInt64
  := Fix (Arrow IntType IntType) IntType
         (If0 (Var 1)
              (Num (Int64.repr 1))
              (Op Mul (App (Var 0) (Op Sub (Var 1) (Num (Int64.repr 1)))) (Var 1))).

Unset Guard Checking.
Fixpoint run_eval (t : ITreeDefinition.itree Failure Term) : MlResult Term string
  := match observe t with
     | RetF x => MlOk _ string x
     | TauF t => run_eval t
     | VisF _ (Throw msg) k => MlError _ string msg
     end.
Set Guard Checking.

(* ** FType Tests ** *)
Definition ftype_eq_refl (τ : FType) : bool
  := ftype_eq τ τ.

QuickCheck (forAll (genFType 0) (well_formed_type 0)).
QuickCheck (forAll (genFType 10) ftype_eq_refl).

(* Generated terms have types *)
QuickCheck (forAll (genFType 0) (fun τ => forAll (genTerm 0 [] τ)
                                              (fun e => match typeof e with
                                                     | Some τ' =>
                                                       ftype_eq τ τ'
                                                     | _ => false
                                                     end))).

QuickCheck (forAll (genFType 0) (fun τ => forAllShrink (genTerm_terminating 0 [] τ) shrink_term_filtered
                                              (fun e => match typeof e with
                                                     | Some τ' =>
                                                       whenFail
                                                         ("Bad type: " ++ show τ')
                                                         (ftype_eq τ τ')
                                                     | _ =>
                                                       whenFail
                                                         "No type"
                                                         false
                                                     end))).

(* Test for preservation *)
QuickCheck (forAll (genFType 0) (fun τ => forAll (genTerm 0 [] τ)
                                              (fun e => match step e with
                                                     | inr e' =>
                                                       match typeof e', typeof e with
                                                       | Some τ1, Some τ2 => ftype_eq τ1 τ2
                                                       | _, _ => true
                                                       end
                                                     | _ => true
                                                     end))).

(* Test that we evaluate without failing *)
QuickCheck (forAll (genFType 0) (fun τ => forAllShrink (genTerm_terminating 0 [] τ) shrink_term_filtered
                                              (fun e => match run_eval (eval e) with
                                                     | MlOk _ =>
                                                       checker true
                                                     | MlError x =>
                                                       whenFail x
                                                       false
                                                     end))).

(* Eval preserves types *)
QuickCheck (forAll (genFType 0) (fun τ => forAll (genTerm_terminating 0 [] τ)
                                              (fun e => match run_eval (eval e) with
                                                     | MlOk e' =>
                                                       match typeof e', typeof e with
                                                       | Some τ1, Some τ2 =>
                                                         whenFail
                                                           (show ((e', τ1), (e, τ2)))
                                                           (ftype_eq τ1 τ2)
                                                       | _, _ => checker true
                                                       end
                                                     | MlError x =>
                                                       whenFail x
                                                       false
                                                     end))).

(* Eval gives a value *)
QuickCheck (forAll (genFType 0) (fun τ => forAll (genTerm_terminating 0 [] τ)
                                              (fun e => match run_eval (eval e) with
                                                     | MlOk e' =>
                                                       whenFail
                                                         ("Not a value: " ++ show e')
                                                         (is_value e')
                                                     | MlError x =>
                                                       whenFail x
                                                       false
                                                     end))).

(* Eval matches multistep *)
(* Fails because of tuples *)
(* QuickCheck (forAll (genFType 0) (fun τ => forAllShrink (genTerm_terminating 0 [] τ) shrink_term_preserve_type *)
(*                                               (fun e => match run_eval (eval e) with *)
(*                                                      | MlOk x => *)
(*                                                        match multistep' 10000 e with *)
(*                                                        | Some y => whenFail (show (x,y)) (term_eq x y) *)
(*                                                        | None => checker true (* Should probably make this a discard *) *)
(*                                                        end *)
(*                                                      | MlError x => *)
(*                                                        whenFail x *)
(*                                                        false *)
(*                                                      end))). *)


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

(******************************************************************************)
(* This file contains the definitions of:                                     *)
(*   choiceType == interface for types with a choice operator                 *)
(*    countType == interface for countable types                              *)
(* subCountType == interface for types that are both subType and countType.   *)
(*  xchoose exP == a standard x such that P x, given exP : exists x : T, P x  *)
(*                 when T is a choiceType. The choice depends only on the     *)
(*                 extent of P (in particular, it is independent of exP).     *)
(*   choose P x0 == if P x0, a standard x such that P x.                      *)
(*      pickle x == a nat encoding the value x : T, where T is a countType.   *)
(*    unpickle n == a partial inverse to pickle: unpickle (pickle x) = Some x *)
(*  pickle_inv n == a sharp partial inverse to pickle pickle_inv n = Some x   *)
(*                  if and only if pickle x = n.                              *)
(* [choiceType of T for cT] == clone for T of the choiceType cT.              *)
(*        [choiceType of T] == clone for T of the choiceType inferred for T.  *)
(*  [countType of T for cT] == clone for T of the countType cT.               *)
(*        [count Type of T] == clone for T of the countType inferred for T.   *)
(* [choiceMixin of T by <:] == Choice mixin for T when T has a subType p      *)
(*                        structure with p : pred cT and cT has a Choice      *)
(*                        structure; the corresponding structure is Canonical.*)
(*  [countMixin of T by <:] == Count mixin for a subType T of a countType.    *)
(*  PcanChoiceMixin fK == Choice mixin for T, given f : T -> cT where cT has  *)
(*                        a Choice structure, a left inverse partial function *)
(*                        g and fK : pcancel f g.                             *)
(*   CanChoiceMixin fK == Choice mixin for T, given f : T -> cT, g and        *)
(*                        fK : cancel f g.                                    *)
(*   PcanCountMixin fK == Count mixin for T, given f : T -> cT where cT has   *)
(*                        a Countable structure, a left inverse partial       *)
(*                        function g and fK : pcancel f g.                    *)
(*    CanCountMixin fK == Count mixin for T, given f : T -> cT, g and         *)
(*                        fK : cancel f g.                                    *)
(*      GenTree.tree T == generic n-ary tree type with nat-labeled nodes and  *)
(*                        T-labeled nodes. It is equipped with canonical      *)
(*                        eqType, choiceType, and countType instances, and so *)
(*                        can be used to similarly equip simple datatypes     *)
(*                        by using the mixins above.                          *)
(* In addition to the lemmas relevant to these definitions, this file also    *)
(* contains definitions of a Canonical choiceType and countType instances for *)
(* all basic datatypes (e.g., nat, bool, subTypes, pairs, sums, etc.).        *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Technical definitions about coding and decoding of nat sequances, which    *)
(* are used below to define various Canonical instances of the choice and     *)
(* countable interfaces.                                                      *)

Module CodeSeq.

(* Goedel-style one-to-one encoding of seq nat into nat.                      *)
(* The code for [:: n1; ...; nk] has binary representation                    *)
(*          1 0 ... 0 1 ... 1 0 ... 0 1 0 ... 0                               *)
(*            <----->         <----->   <----->                               *)
(*             nk 0s           n2 0s     n1 0s                                *)

Definition code := foldr (fun n m => 2 ^ n * m.*2.+1) 0.

Fixpoint decode_rec (v q r : nat) {struct q} :=
  match q, r with
  | 0, _         => [:: v]
  | q'.+1, 0     => v :: [rec 0, q', q']
  | q'.+1, 1     => [rec v.+1, q', q']
  | q'.+1, r'.+2 => [rec v, q', r']
  end where "[ 'rec' v , q , r ]" := (decode_rec v q r).

Definition decode n := if n is 0 then [::] else [rec 0, n.-1, n.-1].

Lemma decodeK : cancel decode code.
Proof.
have m2s: forall n, n.*2 - n = n by move=> n; rewrite -addnn addnK.
case=> //= n; rewrite -[n.+1]mul1n -(expn0 2) -{3}[n]m2s.
elim: n {2 4}n {1 3}0 => [|q IHq] [|[|r]] v //=; rewrite {}IHq ?mul1n ?m2s //.
by rewrite expnSr -mulnA mul2n.
Qed.

Lemma codeK : cancel code decode.
Proof.
elim=> //= v s IHs; rewrite -[_ * _]prednK ?muln_gt0 ?expn_gt0 //=.
rewrite -{3}[v]addn0; elim: v {1 4}0 => [|v IHv {IHs}] q.
  rewrite mul1n /= -{1}addnn -{4}IHs; move: (_ s) {IHs} => n.
  by elim: {1 3}n => //=; case: n.
rewrite expnS -mulnA mul2n -{1}addnn -[_ * _]prednK ?muln_gt0 ?expn_gt0 //.
by rewrite doubleS addSn /= addSnnS; elim: {-2}_.-1 => //=.
Qed.

Lemma ltn_code s : all (fun j => j < code s) s.
Proof.
elim: s => //= i s IHs; rewrite -[_.+1]muln1 leq_mul 1?ltn_expl //=.
apply: sub_all IHs => j /leqW lejs; rewrite -[j.+1]mul1n leq_mul ?expn_gt0 //.
by rewrite ltnS -[j]mul1n -mul2n leq_mul.
Qed.

Lemma gtn_decode n : all (ltn^~ n) (decode n).
Proof. by rewrite -{1}[n]decodeK ltn_code. Qed.

End CodeSeq.

Section OtherEncodings.
(* Miscellaneous encodings: option T -c-> seq T, T1 * T2 -c-> {i : T1 & T2}   *)
(* T1 + T2 -c-> option T1 * option T2, unit -c-> bool; bool -c-> nat is       *)
(* already covered in ssrnat by the nat_of_bool coercion, the odd predicate,  *)
(* and their "cancellation" lemma oddb. We use these encodings to propagate   *)
(* canonical structures through these type constructors so that ultimately    *)
(* all Choice and Countable instanced derive from nat and the seq and sigT    *)
(* constructors.                                                              *)

Variables T T1 T2 : Type.

Definition seq_of_opt := @oapp T _ (nseq 1) [::].
Lemma seq_of_optK : cancel seq_of_opt ohead. Proof. by case. Qed.

Definition tag_of_pair (p : T1 * T2) := @Tagged T1 p.1 (fun _ => T2) p.2.
Definition pair_of_tag (u : {i : T1 & T2}) := (tag u, tagged u).
Lemma tag_of_pairK : cancel tag_of_pair pair_of_tag. Proof. by case. Qed.
Lemma pair_of_tagK : cancel pair_of_tag tag_of_pair. Proof. by case. Qed.

Definition opair_of_sum (s : T1 + T2) :=
  match s with inl x => (Some x, None) | inr y => (None, Some y) end.
Definition sum_of_opair p :=
  oapp (some \o @inr T1 T2) (omap (@inl _ T2) p.1) p.2.
Lemma opair_of_sumK : pcancel opair_of_sum sum_of_opair. Proof. by case. Qed.

Lemma bool_of_unitK : cancel (fun _ => true) (fun _ => tt).
Proof. by case. Qed.

End OtherEncodings.

(* Generic variable-arity tree type, providing an encoding target for         *)
(* miscellaneous user datatypes. The GenTree.tree type can be combined with   *)
(* a sigT type to model multi-sorted concrete datatypes.                      *)
Module GenTree.

Section Def.

Variable T : Type.

Unset Elimination Schemes.
Inductive tree := Leaf of T | Node of nat & seq tree.

Definition tree_rect K IH_leaf IH_node :=
  fix loop t : K t := match t with
  | Leaf x => IH_leaf x
  | Node n f0 =>
    let fix iter_pair f : foldr (fun t => prod (K t)) unit f :=
      if f is t :: f' then (loop t, iter_pair f') else tt in
    IH_node n f0 (iter_pair f0)
  end.
Definition tree_rec (K : tree -> Set) := @tree_rect K.
Definition tree_ind K IH_leaf IH_node :=
  fix loop t : K t : Prop := match t with
  | Leaf x => IH_leaf x
  | Node n f0 =>
    let fix iter_conj f : foldr (fun t => and (K t)) True f :=
        if f is t :: f' then conj (loop t) (iter_conj f') else Logic.I
      in IH_node n f0 (iter_conj f0)
    end.

Fixpoint encode t : seq (nat + T) :=
  match t with
  | Leaf x => [:: inr _ x]
  | Node n f => inl _ n.+1 :: rcons (flatten (map encode f)) (inl _ 0)
  end.

Definition decode_step c fs :=
  match c with
  | inr x => (Leaf x :: fs.1, fs.2)
  | inl 0 => ([::], fs.1 :: fs.2)
  | inl n.+1 => (Node n fs.1 :: head [::] fs.2, behead fs.2)
  end.

Definition decode c := ohead (foldr decode_step ([::], [::]) c).1.

Lemma codeK : pcancel encode decode.
Proof.
move=> t; rewrite /decode; set fs := (_, _).
suffices ->: foldr decode_step fs (encode t) = (t :: fs.1, fs.2) by [].
elim: t => //= n f IHt in (fs) *; elim: f IHt => //= t f IHf [].
by rewrite rcons_cat foldr_cat => -> /= /IHf[-> -> ->].
Qed.

End Def.

End GenTree.
Implicit Arguments GenTree.codeK [].

Definition tree_eqMixin (T : eqType) := PcanEqMixin (GenTree.codeK T).
Canonical tree_eqType (T : eqType) := EqType (GenTree.tree T) (tree_eqMixin T).

(* Structures for Types with a choice function, and for Types with countably  *)
(* many elements. The two concepts are closely linked: we indeed make         *)
(* Countable a subclass of Choice, as countable choice is valid in CiC. This  *)
(* apparent redundancy is needed to ensure the consistency of the Canonical   *)
(* inference, as the canonical Choice for a given type may differ from the    *)
(* countable choice for its canonical Countable structure, e.g., for options. *)
(*   The Choice interface exposes two choice functions; for T : choiceType    *)
(* and P : pred T, we provide:                                                *)
(*    xchoose : (exists x, P x) -> T                                          *)
(*    choose : pred T -> T -> T                                               *)
(*   While P (xchoose exP) will always hold, P (choose P x0) will be true if  *)
(* and only if P x0 holds. Both xchoose and choose are extensional in P and   *)
(* do not depend on the witness exP or x0 (provided P x0 holds). Note that    *)
(* xchoose is slightly more powerful, but less convenient to use.             *)
(*   However, neither choose nor xchoose are composable: it would not be      *)
(* be possible to extend the Choice structure to arbitrary pairs using only   *)
(* these functions, for instance. Internally, the interfaces provides a       *)
(* subtly stronger operation, Choice.InternalTheory.find, which performs a    *)
(* limited search using an integer parameter only rather than a full value as *)
(* [x]choose does. This is not a restriction in the constructive setting      *)
(* (where all types are concrete and hence countable). In the case of         *)
(* axiomatizations, like for the Coq reals library, postulating a suitable    *)
(* axiom of choice suppresses the need for guidance. Nevertheless this        *)
(* operation is just what is needed to make the Choice interface compose.     *)
(*   The Countable interface provides three functions; for T : countType we   *)
(* geth pickle : T -> nat, and unpickle, pickle_inv : nat -> option T.        *)
(* The functions provide an effective embedding of T in nat: unpickle is a    *)
(* left inverse to pickle, which satisfies pcancel pickle unpickle, i.e.,     *)
(* unpickle \o pickle =1 some; pickle_inv is a more precise inverse for which *)
(* we also have ocancel pickle_inv pickle. Both unpickle and pickle need to   *)
(* partial functions, to allow for possibly empty types such as {x | P x}.    *)
(*   The names of these functions underline the correspondence with the       *)
(* notion of "Serializable" types in programming languages.                   *)
(*   Finally, we need to provide a join class to let type inference unify     *)
(* subType and countType class constraints, e.g., for a countable subType of  *)
(* an uncountable choiceType (the issue does not arise earlier with eqType or *)
(* choiceType because in practice the base type of an Equality/Choice subType *)
(* is always an Equality/Choice Type).                                        *)

Module Choice.

Section ClassDef.

Record mixin_of T := Mixin {
  find : pred T -> nat -> option T;
  _ : forall P n x, find P n = Some x -> P x;
  _ : forall P : pred T, (exists x, P x) -> exists n, find P n;
  _ : forall P Q : pred T, P =1 Q -> find P =1 find Q
}.

Record class_of T := Class {base : Equality.class_of T; mixin : mixin_of T}.
Local Coercion base : class_of >->  Equality.class_of.

Structure type := Pack {sort; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.
Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c T.
Let xT := let: Pack T _ _ := cT in T.
Notation xclass := (class : class_of xT).

Definition pack m :=
  fun b bT & phant_id (Equality.class bT) b => Pack (@Class T b m) T.

(* Inheritance *)
Definition eqType := @Equality.Pack cT xclass xT.

End ClassDef.

Module Import Exports.
Coercion base : class_of >-> Equality.class_of.
Coercion sort : type >-> Sortclass.
Coercion eqType : type >-> Equality.type.
Canonical eqType.
Notation choiceType := type.
Notation choiceMixin := mixin_of.
Notation ChoiceType T m := (@pack T m _ _ id).
Notation "[ 'choiceType' 'of' T 'for' cT ]" :=  (@clone T cT _ idfun)
  (at level 0, format "[ 'choiceType'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'choiceType' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'choiceType'  'of'  T ]") : form_scope.

End Exports.

Module InternalTheory.
Section InternalTheory.
(* Inner choice function. *)
Definition find T := find (mixin (class T)).

Variable T : choiceType.
Implicit Types P Q : pred T.

Lemma correct P n x : find P n = Some x -> P x.
Proof. by case: T => _ [_ []] //= in P n x *. Qed.

Lemma complete P : (exists x, P x) -> (exists n, find P n).
Proof. by case: T => _ [_ []] //= in P *. Qed.

Lemma extensional P Q : P =1 Q -> find P =1 find Q.
Proof. by case: T => _ [_ []] //= in P Q *. Qed.

Fact xchoose_subproof P exP : {x | find P (ex_minn (@complete P exP)) = Some x}.
Proof.
by case: (ex_minnP (complete exP)) => n; case: (find P n) => // x; exists x.
Qed.

End InternalTheory.
End InternalTheory.

End Choice.
Export Choice.Exports.

Section ChoiceTheory.

Implicit Type T : choiceType.
Import Choice.InternalTheory CodeSeq.
Local Notation dc := decode.

Section OneType.

Variable T : choiceType.
Implicit Types P Q : pred T.

Definition xchoose P exP := sval (@xchoose_subproof T P exP).

Lemma xchooseP P exP : P (@xchoose P exP).
Proof. by rewrite /xchoose; case: (xchoose_subproof exP) => x /= /correct. Qed.

Lemma eq_xchoose P Q exP exQ : P =1 Q -> @xchoose P exP = @xchoose Q exQ.
Proof.
rewrite /xchoose => eqPQ.
case: (xchoose_subproof exP) => x; case: (xchoose_subproof exQ) => y /=.
case: ex_minnP => n; case: ex_minnP => m.
rewrite -(extensional eqPQ) {1}(extensional eqPQ).
move=> Qm minPm Pn minQn; suffices /eqP->: m == n by move=> -> [].
by rewrite eqn_leq minQn ?minPm.
Qed.

Lemma sigW P : (exists x, P x) -> {x | P x}.
Proof. by move=> exP; exists (xchoose exP); exact: xchooseP. Qed.

Lemma sig2W P Q : (exists2 x, P x & Q x) -> {x | P x & Q x}.
Proof.
move=> exPQ; have [|x /andP[]] := @sigW (predI P Q); last by exists x.
by have [x Px Qx] := exPQ; exists x; exact/andP.
Qed.

Lemma sig_eqW (vT : eqType) (lhs rhs : T -> vT) :
  (exists x, lhs x = rhs x) -> {x | lhs x = rhs x}.
Proof.
move=> exP; suffices [x /eqP Ex]: {x | lhs x == rhs x} by exists x.
by apply: sigW; have [x /eqP Ex] := exP; exists x.
Qed.

Lemma sig2_eqW (vT : eqType) (P : pred T) (lhs rhs : T -> vT) :
  (exists2 x, P x & lhs x = rhs x) -> {x | P x & lhs x = rhs x}.
Proof.
move=> exP; suffices [x Px /eqP Ex]: {x | P x & lhs x == rhs x} by exists x.
by apply: sig2W; have [x Px /eqP Ex] := exP; exists x.
Qed.

Definition choose P x0 :=
  if insub x0 : {? x | P x} is Some (exist x Px) then
    xchoose (ex_intro [eta P] x Px)
  else x0.

Lemma chooseP P x0 : P x0 -> P (choose P x0).
Proof. by move=> Px0; rewrite /choose insubT xchooseP. Qed.

Lemma choose_id P x0 y0 : P x0 -> P y0 -> choose P x0 = choose P y0.
Proof. by move=> Px0 Py0; rewrite /choose !insubT /=; exact: eq_xchoose. Qed.

Lemma eq_choose P Q : P =1 Q -> choose P =1 choose Q.
Proof.
rewrite /choose => eqPQ x0.
do [case: insubP; rewrite eqPQ] => [[x Px] Qx0 _| ?]; last by rewrite insubN.
by rewrite insubT; exact: eq_xchoose.
Qed.

Section CanChoice.

Variables (sT : Type) (f : sT -> T).

Lemma PcanChoiceMixin f' : pcancel f f' -> choiceMixin sT.
Proof.
move=> fK; pose liftP sP := [pred x | oapp sP false (f' x)].
pose sf sP := [fun n => obind f' (find (liftP sP) n)].
exists sf => [sP n x | sP [y sPy] | sP sQ eqPQ n] /=.
- by case Df: (find _ n) => //= [?] Dx; have:= correct Df; rewrite /= Dx.
- have [|n Pn] := @complete T (liftP sP); first by exists (f y); rewrite /= fK.
  exists n; case Df: (find _ n) Pn => //= [x] _.
  by have:= correct Df => /=; case: (f' x).
by congr (obind _ _); apply: extensional => x /=; case: (f' x) => /=.
Qed.

Definition CanChoiceMixin f' (fK : cancel f f') :=
  PcanChoiceMixin (can_pcan fK).

End CanChoice.

Section SubChoice.

Variables (P : pred T) (sT : subType P).

Definition sub_choiceMixin := PcanChoiceMixin (@valK T P sT).
Definition sub_choiceClass := @Choice.Class sT (sub_eqMixin sT) sub_choiceMixin.
Canonical sub_choiceType := Choice.Pack sub_choiceClass sT.

End SubChoice.

Fact seq_choiceMixin : choiceMixin (seq T).
Proof.
pose r f := [fun xs => fun x : T => f (x :: xs) : option (seq T)].
pose fix f sP ns xs {struct ns} :=
  if ns is n :: ns1 then let fr := r (f sP ns1) xs in obind fr (find fr n)
  else if sP xs then Some xs else None.
exists (fun sP nn => f sP (dc nn) nil) => [sP n ys | sP [ys] | sP sQ eqPQ n].
- elim: {n}(dc n) nil => [|n ns IHs] xs /=; first by case: ifP => // sPxs [<-].
  by case: (find _ n) => //= [x]; apply: IHs.
- rewrite -(cats0 ys); elim/last_ind: ys nil => [|ys y IHs] xs /=.
    by move=> sPxs; exists 0; rewrite /= sPxs.
  rewrite cat_rcons => /IHs[n1 sPn1] {IHs}.
  have /complete[n]: exists z, f sP (dc n1) (z :: xs) by exists y.
  case Df: (find _ n)=> // [x] _; exists (code (n :: dc n1)).
  by rewrite codeK /= Df /= (correct Df).
elim: {n}(dc n) nil => [|n ns IHs] xs /=; first by rewrite eqPQ.
rewrite (@extensional _ _ (r (f sQ ns) xs)) => [|x]; last by rewrite IHs.
by case: find => /=.
Qed.
Canonical seq_choiceType := Eval hnf in ChoiceType (seq T) seq_choiceMixin.

End OneType.

Section TagChoice.

Variables (I : choiceType) (T_ : I -> choiceType).

Fact tagged_choiceMixin : choiceMixin {i : I & T_ i}.
Proof.
pose mkT i (x : T_ i) := Tagged T_ x.
pose ft tP n i := omap (mkT i) (find (tP \o mkT i) n).
pose fi tP ni nt := obind (ft tP nt) (find (ft tP nt) ni).
pose f tP n := if dc n is [:: ni; nt] then fi tP ni nt else None.
exists f => [tP n u | tP [[i x] tPxi] | sP sQ eqPQ n].
- rewrite /f /fi; case: (dc n) => [|ni [|nt []]] //=.
  case: (find _ _) => //= [i]; rewrite /ft.
  by case Df: (find _ _) => //= [x] [<-]; have:= correct Df.
- have /complete[nt tPnt]: exists y, (tP \o mkT i) y by exists x.
  have{tPnt}: exists j, ft tP nt j by exists i; rewrite /ft; case: find tPnt.
  case/complete=> ni tPn; exists (code [:: ni; nt]); rewrite /f codeK /fi.
  by case Df: find tPn => //= [j] _; have:= correct Df.
rewrite /f /fi; case: (dc n) => [|ni [|nt []]] //=.
rewrite (@extensional _ _ (ft sQ nt)) => [|i].
  by case: find => //= i; congr (omap _ _); apply: extensional => x /=.
by congr (omap _ _); apply: extensional => x /=.
Qed.
Canonical tagged_choiceType :=
  Eval hnf in ChoiceType {i : I & T_ i} tagged_choiceMixin.

End TagChoice.

Fact nat_choiceMixin : choiceMixin nat.
Proof.
pose f := [fun (P : pred nat) n => if P n then Some n else None].
exists f => [P n m | P [n Pn] | P Q eqPQ n] /=; last by rewrite eqPQ.
  by case: ifP => // Pn [<-].
by exists n; rewrite Pn.
Qed.
Canonical nat_choiceType := Eval hnf in ChoiceType nat nat_choiceMixin.

Definition bool_choiceMixin := CanChoiceMixin oddb.
Canonical bool_choiceType := Eval hnf in ChoiceType bool bool_choiceMixin.
Canonical bitseq_choiceType := Eval hnf in [choiceType of bitseq].

Definition unit_choiceMixin := CanChoiceMixin bool_of_unitK.
Canonical unit_choiceType := Eval hnf in ChoiceType unit unit_choiceMixin.

Definition option_choiceMixin T := CanChoiceMixin (@seq_of_optK T).
Canonical option_choiceType T :=
  Eval hnf in ChoiceType (option T) (option_choiceMixin T).

Definition sig_choiceMixin T (P : pred T) : choiceMixin {x | P x} :=
   sub_choiceMixin _.
Canonical sig_choiceType T (P : pred T) :=
 Eval hnf in ChoiceType {x | P x} (sig_choiceMixin P).

Definition prod_choiceMixin T1 T2 := CanChoiceMixin (@tag_of_pairK T1 T2).
Canonical prod_choiceType T1 T2 :=
  Eval hnf in ChoiceType (T1 * T2) (prod_choiceMixin T1 T2).

Definition sum_choiceMixin T1 T2 := PcanChoiceMixin (@opair_of_sumK T1 T2).
Canonical sum_choiceType T1 T2 :=
  Eval hnf in ChoiceType (T1 + T2) (sum_choiceMixin T1 T2).

Definition tree_choiceMixin T := PcanChoiceMixin (GenTree.codeK T).
Canonical tree_choiceType T := ChoiceType (GenTree.tree T) (tree_choiceMixin T).

End ChoiceTheory.

Prenex Implicits xchoose choose.
Notation "[ 'choiceMixin' 'of' T 'by' <: ]" :=
  (sub_choiceMixin _ : choiceMixin T)
  (at level 0, format "[ 'choiceMixin'  'of'  T  'by'  <: ]") : form_scope.

Module Countable.

Record mixin_of (T : Type) : Type := Mixin {
  pickle : T -> nat;
  unpickle : nat -> option T;
  pickleK : pcancel pickle unpickle
}.

Definition EqMixin T m := PcanEqMixin (@pickleK T m).
Definition ChoiceMixin T m := PcanChoiceMixin (@pickleK T m).

Section ClassDef.

Record class_of T := Class { base : Choice.class_of T; mixin : mixin_of T }.
Local Coercion base : class_of >-> Choice.class_of.

Structure type : Type := Pack {sort : Type; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.
Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c T.
Let xT := let: Pack T _ _ := cT in T.
Notation xclass := (class : class_of xT).

Definition pack m :=
  fun bT b & phant_id (Choice.class bT) b => Pack (@Class T b m) T.

Definition eqType := @Equality.Pack cT xclass xT.
Definition choiceType := @Choice.Pack cT xclass xT.

End ClassDef.

Module Exports.
Coercion base : class_of >-> Choice.class_of.
Coercion mixin : class_of >-> mixin_of.
Coercion sort : type >-> Sortclass.
Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.
Notation countType := type.
Notation CountType T m := (@pack T m _ _ id).
Notation CountMixin := Mixin.
Notation CountChoiceMixin := ChoiceMixin.
Notation "[ 'countType' 'of' T 'for' cT ]" := (@clone T cT _ idfun)
 (at level 0, format "[ 'countType'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'countType' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'countType'  'of'  T ]") : form_scope.

End Exports.

End Countable.
Export Countable.Exports.

Definition unpickle T := Countable.unpickle (Countable.class T).
Definition pickle T := Countable.pickle (Countable.class T).
Implicit Arguments unpickle [T].
Prenex Implicits pickle unpickle.

Section CountableTheory.

Variable T : countType.

Lemma pickleK : @pcancel nat T pickle unpickle.
Proof. exact: Countable.pickleK. Qed.

Definition pickle_inv n :=
  obind (fun x : T => if pickle x == n then Some x else None) (unpickle n).

Lemma pickle_invK : ocancel pickle_inv pickle.
Proof.
by rewrite /pickle_inv => n; case def_x: (unpickle n) => //= [x]; case: eqP.
Qed.

Lemma pickleK_inv : pcancel pickle pickle_inv.
Proof. by rewrite /pickle_inv => x; rewrite pickleK /= eqxx. Qed.

Lemma pcan_pickleK sT f f' :
  @pcancel T sT f f' -> pcancel (pickle \o f) (pcomp f' unpickle).
Proof. by move=> fK x; rewrite /pcomp pickleK /= fK. Qed.

Definition PcanCountMixin sT f f' (fK : pcancel f f') :=
  @CountMixin sT _ _ (pcan_pickleK fK).

Definition CanCountMixin sT f f' (fK : cancel f f') :=
  @PcanCountMixin sT _ _ (can_pcan fK).

Definition sub_countMixin P sT := PcanCountMixin (@valK T P sT).

Definition pickle_seq s := CodeSeq.code (map (@pickle T) s).
Definition unpickle_seq n := Some (pmap (@unpickle T) (CodeSeq.decode n)).
Lemma pickle_seqK : pcancel pickle_seq unpickle_seq.
Proof. by move=> s; rewrite /unpickle_seq CodeSeq.codeK (map_pK pickleK). Qed.

Definition seq_countMixin := CountMixin pickle_seqK.
Canonical seq_countType := Eval hnf in CountType (seq T) seq_countMixin.

End CountableTheory.

Notation "[ 'countMixin' 'of' T 'by' <: ]" :=
    (sub_countMixin _ : Countable.mixin_of T)
  (at level 0, format "[ 'countMixin'  'of'  T  'by'  <: ]") : form_scope.

Section SubCountType.

Variables (T : choiceType) (P : pred T).
Import Countable.

Structure subCountType : Type :=
  SubCountType {subCount_sort :> subType P; _ : mixin_of subCount_sort}.

Coercion sub_countType (sT : subCountType) :=
  Eval hnf in pack (let: SubCountType _ m := sT return mixin_of sT in m) id.
Canonical sub_countType.

Definition pack_subCountType U :=
  fun sT cT & sub_sort sT * sort cT -> U * U =>
  fun b m   & phant_id (Class b m) (class cT) => @SubCountType sT m.

End SubCountType.

(* This assumes that T has both countType and subType structures. *)
Notation "[ 'subCountType' 'of' T ]" :=
    (@pack_subCountType _ _ T _ _ id _ _ id)
  (at level 0, format "[ 'subCountType'  'of'  T ]") : form_scope.

Section TagCountType.

Variables (I : countType) (T_ : I -> countType).

Definition pickle_tagged (u : {i : I & T_ i}) :=
  CodeSeq.code [:: pickle (tag u); pickle (tagged u)].
Definition unpickle_tagged s :=
  if CodeSeq.decode s is [:: ni; nx] then
    obind (fun i => omap (@Tagged I i T_) (unpickle nx)) (unpickle ni)
  else None.
Lemma pickle_taggedK : pcancel pickle_tagged unpickle_tagged.
Proof.
by case=> i x; rewrite /unpickle_tagged CodeSeq.codeK /= pickleK /= pickleK.
Qed.

Definition tag_countMixin := CountMixin pickle_taggedK.
Canonical tag_countType := Eval hnf in CountType {i : I & T_ i} tag_countMixin.

End TagCountType.

(* The remaining Canonicals for standard datatypes. *)
Section CountableDataTypes.

Implicit Type T : countType.

Lemma nat_pickleK : pcancel id (@Some nat). Proof. by []. Qed.
Definition nat_countMixin := CountMixin nat_pickleK.
Canonical nat_countType := Eval hnf in CountType nat nat_countMixin.

Definition bool_countMixin := CanCountMixin oddb.
Canonical bool_countType := Eval hnf in CountType bool bool_countMixin.
Canonical bitseq_countType :=  Eval hnf in [countType of bitseq].

Definition unit_countMixin := CanCountMixin bool_of_unitK.
Canonical unit_countType := Eval hnf in CountType unit unit_countMixin.

Definition option_countMixin T := CanCountMixin (@seq_of_optK T).
Canonical option_countType T :=
  Eval hnf in CountType (option T) (option_countMixin T).

Definition sig_countMixin T (P : pred T) := [countMixin of {x | P x} by <:].
Canonical sig_countType T (P : pred T) :=
  Eval hnf in CountType {x | P x} (sig_countMixin P).
Canonical sig_subCountType T (P : pred T) :=
  Eval hnf in [subCountType of {x | P x}].

Definition prod_countMixin T1 T2 := CanCountMixin (@tag_of_pairK T1 T2).
Canonical prod_countType T1 T2 :=
  Eval hnf in CountType (T1 * T2) (prod_countMixin T1 T2).

Definition sum_countMixin T1 T2 := PcanCountMixin (@opair_of_sumK T1 T2).
Canonical sum_countType T1 T2 :=
  Eval hnf in CountType (T1 + T2) (sum_countMixin T1 T2).

Definition tree_countMixin T := PcanCountMixin (GenTree.codeK T).
Canonical tree_countType T := CountType (GenTree.tree T) (tree_countMixin T).

End CountableDataTypes.


From st.STLCmuST Require Import lang contexts.
From st.STLCmuVS Require Import lang contexts typing.
From st.backtranslations.st_sem Require Import expressions contexts.
From st.embedding Require Import expressions contexts.

Lemma retraction Γ (e : STLCmuVS.lang.expr) τ : Γ ⊢ₙₒ e : τ → back_expr (embd_expr e) = e.
Proof.
  intro d.
  induction d; simpl; repeat match goal with
                             | H : _ = _ |- _ => rewrite H
                             end; try done.
Qed.

Lemma retraction_ctx_item (Ci : STLCmuVS.contexts.ctx_item) Γ τ Γ' τ' (dCi : typed_ctx_item Ci Γ τ Γ' τ') : back_ctx_item (embd_ctx_item Ci) = [Ci].
Proof. destruct dCi; simpl; try done; by erewrite !retraction. Qed.

Lemma retraction_ctx (C : STLCmuVS.contexts.ctx) Γ τ Γ' τ' (dC : typed_ctx C Γ τ Γ' τ') : back_ctx (embd_ctx C) = C.
Proof. induction dC; simpl; first done. erewrite retraction_ctx_item; eauto. by rewrite IHdC. Qed.


(** A simple "ghost variable" of arbitrary type with fractional ownership.
Can be mutated when fully owned. *)
From iris.bi.lib Require Import fractional.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac_agree.
From iris.base_logic.lib Require Export own.
From iris Require Import options.

(** The CMRA we need. *)
Class ghost_varG Σ (A : Type) := GhostVarG {
  ghost_var_inG :> inG Σ (frac_agreeR $ leibnizO A);
}.
Definition ghost_varΣ (A : Type) : gFunctors := #[ GFunctor (frac_agreeR $ leibnizO A) ].

Instance subG_ghost_varΣ Σ A : subG (ghost_varΣ A) Σ → ghost_varG Σ A.
Proof. solve_inG. Qed.

Section definitions.
  Context `{!ghost_varG Σ A} (γ : gname).

  Definition ghost_var (q : Qp) (a : A) : iProp Σ :=
    own γ (to_frac_agree (A:=leibnizO A) q a).
End definitions.

Section lemmas.
  Context `{!ghost_varG Σ A}.
  Implicit Types (a : A) (q : Qp).

  Global Instance ghost_var_timeless γ q a : Timeless (ghost_var γ q a).
  Proof. apply _. Qed.

  Global Instance ghost_var_fractional γ a : Fractional (λ q, ghost_var γ q a).
  Proof. intros q1 q2. rewrite /ghost_var -own_op -frac_agree_op //. Qed.
  Global Instance ghost_var_as_fractional γ a q :
    AsFractional (ghost_var γ q a) (λ q, ghost_var γ q a) q.
  Proof. split. done. apply _. Qed.

  Lemma ghost_var_alloc_strong a (P : gname → Prop) :
    pred_infinite P →
    ⊢ |==> ∃ γ, ⌜P γ⌝ ∗ ghost_var γ 1 a.
  Proof. intros. iApply own_alloc_strong; done. Qed.
  Lemma ghost_var_alloc a :
    ⊢ |==> ∃ γ, ghost_var γ 1 a.
  Proof. iApply own_alloc. done. Qed.

  Lemma ghost_var_valid_2 γ a1 q1 a2 q2 :
    ghost_var γ q1 a1 -∗ ghost_var γ q2 a2 -∗ ⌜✓ (q1 + q2)%Qp ∧ a1 = a2⌝.
  Proof.
    iIntros "Hvar1 Hvar2".
    iDestruct (own_valid_2 with "Hvar1 Hvar2") as %[Hq Ha]%frac_agree_op_valid.
    done.
  Qed.
  (** Almost all the time, this is all you really need. *)
  Lemma ghost_var_agree γ a1 q1 a2 q2 :
    ghost_var γ q1 a1 -∗ ghost_var γ q2 a2 -∗ ⌜a1 = a2⌝.
  Proof.
    iIntros "Hvar1 Hvar2".
    iDestruct (ghost_var_valid_2 with "Hvar1 Hvar2") as %[_ ?]. done.
  Qed.

  (** This is just an instance of fractionality above, but that can be hard to find. *)
  Lemma ghost_var_split γ a q1 q2 :
    ghost_var γ (q1 + q2) a -∗ ghost_var γ q1 a ∗ ghost_var γ q2 a.
  Proof. iIntros "[$$]". Qed.

  (** Update the ghost variable to new value [b]. *)
  Lemma ghost_var_update b γ a :
    ghost_var γ 1 a ==∗ ghost_var γ 1 b.
  Proof.
    iApply own_update. apply cmra_update_exclusive. done.
  Qed.
  Lemma ghost_var_update_2 b γ a1 q1 a2 q2 :
    (q1 + q2 = 1)%Qp →
    ghost_var γ q1 a1 -∗ ghost_var γ q2 a2 ==∗ ghost_var γ q1 b ∗ ghost_var γ q2 b.
  Proof.
    iIntros (Hq) "H1 H2".
    iDestruct (ghost_var_valid_2 with "H1 H2") as %[_ ->].
    iDestruct (fractional_merge with "H1 H2") as "H". simpl. rewrite Hq.
    iMod (ghost_var_update with "H") as "H".
    rewrite -Hq. iApply ghost_var_split. done.
  Qed.
  Lemma ghost_var_update_halves b γ a1 a2 :
    ghost_var γ (1/2) a1 -∗
    ghost_var γ (1/2) a2 ==∗
    ghost_var γ (1/2) b ∗ ghost_var γ (1/2) b.
  Proof. iApply ghost_var_update_2. apply Qp_half_half. Qed.

End lemmas.

Typeclasses Opaque ghost_var.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
(*Require Import depoolContract.Lib.CommonCommon.*)
(* Require Import depoolContract.Lib.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.
Require Export Coq.micromega.Lia.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.

Require Export depoolContract.Scenarios.Common.CommonDefinitions.
Require Export depoolContract.Scenarios.Correctness.StakeValueCorrect.

Lemma sv_vesting_not_negative : forall l s,
    StakeValueCorrectLocally l s ->
    0 <= RoundsBase_ι_InvestParams_ι_amount
        (maybeGet (RoundsBase_ι_StakeValue_ι_vesting s)).
Proof.
intros. unfold StakeValueCorrectLocally in H. inversion_clear H.
inversion_clear H1. unfold _StakeValueCorrectVestingLocally in H.
inversion H. destruct (RoundsBase_ι_StakeValue_ι_vesting s). inversion_clear H1.
simpl. unfold xInt0. lia. inversion H1. inversion_clear H4. inversion_clear H6.
inversion_clear H7. setoid_rewrite <- H6. lia. apply Z.le_trans with (m := m_minStake l).
inversion H3. unfold _ledgerCorrectPositive in H7. decompose [and] H7. lia. assumption.
Qed.

Lemma sv_lock_not_negative : forall l s,
    StakeValueCorrectLocally l s ->
    0 <= RoundsBase_ι_InvestParams_ι_amount
        (maybeGet (RoundsBase_ι_StakeValue_ι_lock s)).
Proof.
intros. unfold StakeValueCorrectLocally in H. inversion_clear H.
inversion_clear H1. unfold _StakeValueCorrectLockLocally in H2.
inversion H2. destruct (RoundsBase_ι_StakeValue_ι_lock s). inversion_clear H1. inversion H4.
inversion_clear H4. decompose [and] H5. unfold _investParamsAmountMinStake in H8.
inversion_clear H8. setoid_rewrite <- H6. lia. apply Z.le_trans with (m := m_minStake l).
unfold ledgerCorrectLocally in H1. unfold _ledgerCorrectPositive in H1. decompose [and] H1. lia.
assumption. compute. intros. discriminate.
Qed.

Lemma stakeSum_not_negative : forall l s,
    StakeValueCorrectLocally l s ->
    0 <= stakeSum s.
Proof.
intros. unfold stakeSum. repeat apply Z.add_nonneg_nonneg. unfold StakeValueCorrectLocally in H.
inversion_clear H. assumption. apply sv_vesting_not_negative with (l := l). assumption.
apply sv_lock_not_negative with (l := l). assumption.
Qed.


Record hoge := { foo : nat; bar : bool }.

Definition x := {| foo := 3; bar := true |}.


Require Import
  FormTopC.FormTop
  Algebra.SetsC
  Algebra.OrderC.

Module JoinTop.

Section JoinTop.
(** We assume we have some type [S] equipped
    with a partial order. *)
(** NO! This context gives us two (different) preorders on S.
    Will need to fix this. *)
Context {S : PreSpace.t} {ops : JoinLat.Ops S} {JL : JoinLat.t S ops}.

Variable bot : S.

Local Open Scope FT.

Class t : Type :=
  { FT :> FormTop.t S
  ; bot_ok : @PreO.bottom _ JoinLat.le bot
  ; bot_Cov : forall U, bot <| U
  ; join_left : forall a b U, a <| U -> b <| U -> JoinLat.max a b <| U
  }.

Hypothesis FTS : t.
(** Check properties we expect to hold *)

Definition singleton (s s' : S) : Prop := s = s'.

Lemma join_right : forall a b c, a <| (singleton b)
  -> a <| singleton (JoinLat.max b c).
Proof.
intros. eapply FormTop.trans. apply X. clear X. clear a.
intros a sba. unfold singleton in sba. subst.
apply FormTop.le_left with (JoinLat.max a c).
apply JoinLat.max_ok.
apply FormTop.refl. unfold In in *. subst. reflexivity.
Qed.

End JoinTop.

(** Given a formal topology, we can always produce a join-closed formal
    topology by taking "free join" elements (i.e., the free monoid, a list)
    and interpreting the cover relation accordingly.
*)
Require Import Coq.Lists.List Types.List.
Section Joinify.
Context {S} {le : S -> Subset S} {PO : PreO.t le}.

Definition leL (xs ys : list S) := forall x,
  member x xs -> { y : S & (le x y * member y ys)%type }.

Definition eqL (xs ys : list S) : Type := leL xs ys * leL ys xs.

Definition joinL (xs ys : list S) : list S := xs ++ ys.

Definition ops' : JoinLat.Ops (list S) :=
  {| JoinLat.le := leL
  ;  JoinLat.eq := eqL
  ;  JoinLat.max := joinL
  |}.

Instance ops : JoinLat.Ops (list S) := ops'.

Require Import CMorphisms.

Instance joinPreO : @PreO.t (list S) leL.
Proof.
constructor; intros.
- simpl. unfold leL. intros. exists x0.
  split. apply PreO.le_refl. assumption.
- simpl in *. unfold leL in *. intros.
  destruct (X x0 X1). destruct p.
  destruct (X0 x1 m). destruct p.
  exists x2. split. eapply PreO.le_trans; eassumption.
  assumption.
Qed.

Instance joinPO : @PO.t (list S) leL JoinLat.eq.
Proof.
constructor.
- apply joinPreO.
- repeat intro.
  destruct X, X0. split; intros.
  transitivity x. assumption. transitivity x0; eassumption.
  transitivity y; try assumption. transitivity y0; eassumption.
- intros. split; assumption.
Qed.

Lemma joinLE (xs ys xs' ys' : list S) : leL xs xs' -> leL ys ys'
  -> leL (xs ++ ys) (xs' ++ ys').
Proof.
unfold leL in *.
intros H H0 x H1.
apply member_app in H1.
destruct H1 as [In1 | In2].
- destruct (H x In1). exists x0. destruct p.
  split. assumption. apply member_app. left. assumption.
- destruct (H0 x In2). exists x0. destruct p.
  split. assumption. apply member_app. right. assumption.
Qed.

Theorem JL : JoinLat.t (list S) ops.
Proof.
constructor.
- apply joinPO.
- repeat intro. simpl in *. unfold joinL.
  unfold eqL in *. destruct X, X0.
  auto using joinLE.
- intros. simpl. unfold joinL. constructor; unfold leL; intros.
  + exists x. split. apply PreO.le_refl. apply member_app. auto.
  + exists x. split. apply PreO.le_refl. apply member_app. auto.
  + apply member_app in X1. destruct X1; [apply X | apply X0]; assumption.
Qed.

Variable Cov : S -> (Subset S) -> Prop.

Definition LCov (a : list S) (U : Subset (list S)) :=
  forall s : S, member s a -> Cov s (fun s' => { xs : list S & (member s' xs * U xs)%type }).

Instance joinify : FormTop.t le Cov -> t nil LCov.
Proof.
intros FTS.
constructor.
- constructor.
  + unfold LCov. intros. apply FormTop.refl.
    exists a. split; assumption.
  + unfold LCov. intros. eapply FormTop.trans.
    eapply H. assumption. simpl.
    clear s X. intros.
    destruct X as (xs & Inxs & Uxs).
    eapply H0. eassumption. assumption.
  + simpl. unfold LCov. intros. unfold leL in *.
    specialize (X s X0). destruct X as (y & sy & Inyb).
    apply FormTop.le_left with y. assumption.
    apply H. assumption.
  + unfold LCov. intros.
    pose proof (fun (s' : S) (insa : member s' a) =>
      @FormTop.le_right _ _ _ _ s' _ _ (H s' insa) (H0 s' insa)).
    eapply FormTop.monotone. 2: apply (H1 s X). simpl.
    unfold Included, pointwise_rel, arrow; intros.
    destruct X0. destruct d, d0. unfold flip, SetsC.In in *.
    destruct i as (xs & Inxs & Uxs).
    destruct i0 as (ys & Inys & Vys).
    exists (cons a0 nil). split. left.
    constructor; (econstructor; [eassumption|]);
    unfold flip, leL; intros x' inx; simpl in inx; inv inx; subst;
    match goal with
    | [ H: member ?z ?xs  |- { y : _ & (_ * member y ?xs)%type } ] => exists z; split; auto
    end.
    inv X0. inv X0.
- unfold PreO.bottom. simpl. unfold leL. intros.
  inv X.
- unfold LCov. intros. inv X.
- unfold LCov. simpl. unfold joinL. intros.
  apply member_app in X. destruct X.
  + apply H; assumption.
  + apply H0; assumption.
Qed.

End Joinify.

End JoinTop.


(**********************************************************************)
(* Equations                                                          *)
(* Copyright (c) 2009-2020 Matthieu Sozeau <matthieu.sozeau@inria.fr> *)
(**********************************************************************)
(* This file is distributed under the terms of the                    *)
(* GNU Lesser General Public License Version 2.1                      *)
(**********************************************************************)
Set Warnings "-notation-overridden".
From Equations Require Import Init.
Require Import Equations.Type.Logic Equations.Type.Classes Equations.Type.DepElim
        Equations.Type.Tactics Equations.Type.EqDec.
Local Open Scope equations_scope.
Import Id_Notations Sigma_Notations.

Set Universe Polymorphism.

#[export]
Instance eqdec_hset (A : Type) `(EqDec A) : HSet A.
Proof.
  red. red. apply eq_proofs_unicity.
Defined.

(** Standard instances. *)

#[export]
Instance unit_eqdec : EqDec unit.
Proof. eqdec_proof. Defined.

#[export]
Instance bool_eqdec : EqDec bool.
Proof. eqdec_proof. Defined.

#[export]
Instance nat_eqdec : EqDec nat.
Proof. eqdec_proof. Defined.

#[export]
Instance prod_eqdec {A B} `(EqDec A) `(EqDec B) : EqDec (prod A B).
Proof. eqdec_proof. Defined.

#[export]
Instance sum_eqdec {A B} `(EqDec A) `(EqDec B) : EqDec (A + B).
Proof. eqdec_proof. Defined.

#[export]
Instance list_eqdec {A} `(EqDec A) : EqDec (list A).
Proof. eqdec_proof. Defined.

(** Any signature made up entirely of decidable types is decidable. *)

Polymorphic Definition eqdec_sig_Id@{i} {A : Type@{i}} {B : A -> Type@{i}}
            `(EqDec A) `(forall a, EqDec (B a)) :
  EqDec@{i} (sigma B).
Proof.
  Set Printing Universes.
  intros. intros [xa xb] [ya yb].
  case (eq_dec xa ya). intros Hxya. destruct Hxya. case (eq_dec xb yb).
  + intros He; destruct He. apply inl@{i}. reflexivity.
  + intros. apply inr@{i}. apply simplification_sigma2_uip@{i i}. apply e.
  + intros. apply inr@{i}. refine (simplification_sigma1_dep@{i i} _ _ _ _ _).
    intros He _; revert He. apply e.
Defined.

#[export]
Existing Instance eqdec_sig_Id.


(** * Mapas: Completos y parciales *)
(* ################################################################# *)
(** * Libreria estandar de Coq *)

From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.

Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

Theorem eqb_string_refl : forall s : string, true = eqb_string s s.
Proof.
  intros s. unfold eqb_string.
  destruct (string_dec s s) as [Hs_eq | Hs_not_eq].
  - reflexivity.
  - destruct Hs_not_eq. reflexivity.
Qed.

Theorem eqb_string_true_iff : forall x y : string,
    eqb_string x y = true <-> x = y.
Proof.
   intros x y.
   unfold eqb_string.
   destruct (string_dec x y) as [Hs_eq | Hs_not_eq].
   - rewrite Hs_eq. split. reflexivity. reflexivity.
   - split.
     + intros contra. discriminate contra.
     + intros H. exfalso. apply Hs_not_eq. apply H.
Qed.

Theorem eqb_string_false_iff : forall x y : string,
    eqb_string x y = false <-> x <> y.
Proof.
  intros x y. rewrite <- eqb_string_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

Theorem false_eqb_string : forall x y : string,
   x <> y -> eqb_string x y = false.
Proof.
  intros x y. rewrite eqb_string_false_iff.
  intros H. apply H. Qed.
(* ################################################################# *)
(** * Mapas completos *)
Definition total_map (A : Type) := string -> A.

Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).

Definition t_update {A : Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if eqb_string x x' then v else m x'.

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true)
           "bar" true.

Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).

Example example_empty := (_ !-> false).

Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

Definition examplemap' :=
  ( "bar" !-> true;
    "foo" !-> true;
    _     !-> false
  ).

Example update_example1 : examplemap' "baz" = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap' "foo" = true.
Proof. reflexivity. Qed.

Example update_example3 : examplemap' "quux" = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap' "bar" = true.
Proof. reflexivity. Qed.

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
    (_ !-> v) x = v.
Proof.
  intros A x v. unfold t_empty.
  reflexivity.
Qed.

Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
    (x !-> v ; m) x = v.
Proof.
  intros A m x v. unfold t_update.
  rewrite <- eqb_string_refl. reflexivity.
Qed.

Theorem t_update_neq : forall (A : Type) (m : total_map A) x1 x2 v,
    x1 <> x2 ->
    (x1 !-> v ; m) x2 = m x2.
Proof.
  intros X v x1 x2 m H. unfold t_update.
  apply eqb_string_false_iff in H. rewrite H.
  reflexivity.
Qed.

Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
    (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof.
   intros A m v1 v2 x.
   apply functional_extensionality. unfold t_update.
   unfold eqb_string.
Admitted.

Lemma eqb_stringP : forall x y : string,
    reflect (x = y) (eqb_string x y).
Proof.
  intros x y. apply iff_reflect.
  rewrite eqb_string_true_iff.
  reflexivity.
Qed.

Theorem t_update_same : forall (A : Type) (m : total_map A) x,
    (x !-> m x ; m) = m.
Proof.
Admitted.

Theorem t_update_permute : forall (A : Type) v1 v2 x1 x2
                                        (m : total_map A),
    x2 <> x1 ->
    (x1 !-> v1 ; x2 !-> v2 ; m)
    =
    (x2 !-> v2 ; x1 !-> v1 ; m).
Proof.
  intros X v1 v2 x1 x2 m Hneq.
  apply functional_extensionality. intros x.
  unfold t_update. destruct (eqb_string x1 x) eqn: H1.
  - apply eqb_string_true_iff in H1. rewrite <- H1.
    rewrite <- eqb_string_false_iff in Hneq.
    rewrite Hneq. reflexivity.
  - reflexivity.
Qed.

(* ################################################################# *)
(** * Mapas parciales*)
Definition partial_map (A : Type) := total_map (option A).

Definition empty {A : Type} : partial_map A :=
  t_empty None.

Definition update {A : Type} (m : partial_map A)
           (x : string) (v : A) :=
  (x !-> Some v ; m).

Notation "x '|->' v ';' m" := (update m x v)
  (at level 100, v at next level, right associativity).

Notation "x '|->' v" := (update empty x v)
  (at level 100).

Example examplepmap :=
  ("Church" |-> true ; "Turing" |-> false).

Lemma apply_empty : forall (A : Type) (x : string),
    @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall (A : Type) (m : partial_map A) x v,
    (x |-> v ; m) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (A : Type) (m : partial_map A) x1 x2 v,
    x2 <> x1 ->
    (x2 |-> v ; m) x1 = m x1.
Proof.
  intros A m x1 x2 v H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall (A : Type) (m : partial_map A) x v1 v2,
    (x |-> v2 ; x |-> v1 ; m) = (x |-> v2 ; m).
Proof.
  intros A m x v1 v2. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall (A : Type) (m : partial_map A) x v,
    m x = Some v ->
    (x |-> v ; m) = m.
Proof.
  intros A m x v H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (A : Type) (m : partial_map A)
                                x1 x2 v1 v2,
    x2 <> x1 ->
    (x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
Proof.
  intros A m x1 x2 v1 v2. unfold update.
  apply t_update_permute.
Qed.

Definition inclusion {A : Type} (m m' : partial_map A) :=
  forall x v, m x = Some v -> m' x = Some v.

Lemma inclusion_update : forall (A : Type) (m m': partial_map A)
                              x vx,
  inclusion m m' ->
  inclusion (x |-> vx ; m) (x |-> vx ; m').
Proof.
  unfold inclusion.
  intros A m m' x vx H.
  intros y vy.
  destruct (eqb_stringP x y) as [Hxy | Hxy].
  - rewrite Hxy.
    rewrite update_eq. rewrite update_eq. intro H1. apply H1.
  - rewrite update_neq. rewrite update_neq.
    + apply H.
    + apply Hxy.
    + apply Hxy.
Qed.


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

 The category of strict categories

 Strict categories are the categories in which the type of objects forms a set. As such,
 the type of functors between them is a set as well, and this allows us to construct a
 category whose objects are strict categories and whose morphisms are functors.

 ******************************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Setcategories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.

Local Open Scope cat.

Definition precat_ob_mor_of_setcategory
  : precategory_ob_mor.
Proof.
  use make_precategory_ob_mor.
  - exact setcategory.
  - exact (λ C₁ C₂, C₁ ⟶ C₂).
Defined.

Definition precat_data_of_setcategory
  : precategory_data.
Proof.
  use make_precategory_data.
  - exact precat_ob_mor_of_setcategory.
  - exact (λ C, functor_identity _).
  - exact (λ C₁ C₂ C₃ F G, F ∙ G).
Defined.

Definition is_precategory_of_setcategory
  : is_precategory precat_data_of_setcategory.
Proof.
  use make_is_precategory_one_assoc.
  - intros C₁ C₂ F.
    use functor_eq.
    {
      apply homset_property.
    }
    use functor_data_eq ; cbn.
    + intro ; apply idpath.
    + intros x y f ; cbn.
      apply idpath.
  - intros C₁ C₂ F.
    use functor_eq.
    {
      apply homset_property.
    }
    use functor_data_eq ; cbn.
    + intro ; apply idpath.
    + intros x y f ; cbn.
      apply idpath.
  - intros C₁ C₂ C₃ C₄ F G H.
    use functor_eq.
    {
      apply homset_property.
    }
    use functor_data_eq ; cbn.
    + intro ; apply idpath.
    + intros x y f ; cbn.
      apply idpath.
Qed.

Definition precat_of_setcategory
  : precategory.
Proof.
  use make_precategory.
  - exact precat_data_of_setcategory.
  - exact is_precategory_of_setcategory.
Defined.

Definition has_homsets_cat_of_setcategory
  : has_homsets precat_of_setcategory.
Proof.
  intros C₁ C₂.
  use functor_isaset.
  - apply homset_property.
  - apply C₂.
Qed.

Definition cat_of_setcategory
  : category.
Proof.
  use make_category.
  - exact precat_of_setcategory.
  - exact has_homsets_cat_of_setcategory.
Defined.


(* Exercise 2: Definiți o funcție de egalitate peste acest tip de date. *)

(* Define the 'Day' data type. *)

Inductive Day :=

  | Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday
  | Sunday.

(* Define the 'equality' function. *)

Definition equality (firstDay secondDay : Day) : bool :=

  match firstDay, secondDay with

    | Monday, Monday => true
    | Tuesday, Tuesday => true
    | Wednesday, Wednesday => true
    | Thursday, Thursday => true
    | Friday, Friday => true
    | Saturday, Saturday => true
    | Sunday, Sunday => true
    | _, _ => false

  end.

(* Test the 'equality' function. *)

Compute equality Monday Monday.
Compute equality Tuesday Tuesday.
Compute equality Wednesday Wednesday.
Compute equality Thursday Thursday.
Compute equality Friday Friday.
Compute equality Saturday Saturday.
Compute equality Sunday Sunday.
Compute equality Monday Friday.
Compute equality Thursday Sunday.
Compute equality Tuesday Sunday.
Compute equality Thursday Monday.
Compute equality Friday Saturday.


From iris.proofmode Require Import base tactics.
From Perennial.base_logic Require Import base_logic.
Import interface.bi.
Import derived_laws.bi.
Import derived_laws_later.bi.
Import base_logic.bi.uPred.

Section uPred_laws.
Context {M: ucmra}.
Implicit Types φ : Prop.
Implicit Types P Q R : (uPred M).
Implicit Types Ps : list (uPred M).
Implicit Types A : Type.

Notation "P ⊢ Q" := (P ⊢@{uPredI M} Q).
Notation "P ⊣⊢ Q" := (P ⊣⊢@{uPredI M} Q).

Lemma laterN_hold_minus n a x (P: uPred M) :
  ✓{n} x →
  a ≤ n →
  uPred_holds (▷^a P) n x →
  uPred_holds P (n - a) x.
Proof.
  revert x n.
  induction a.
  - repeat (rewrite //= || uPred.unseal).
    intros. replace (n - 0) with n by lia. auto.
  - intros x n Hval Hle. destruct n; first by lia.
    replace (S n - S a) with (n - a) by lia.
    intros. eapply IHa; eauto using cmra_validN_S.
    { lia. }
    move: H. uPred.unseal => //=.
Qed.

Lemma laterN_soundness P k: (⊢ ▷^k P) → ⊢ P.
Proof.
  intros HP. split => n x Hx _.
  apply uPred_mono with n ε; eauto using ucmra_unit_leastN.
  replace n with ((n + k) - k) by lia.
  apply laterN_hold_minus; eauto using ucmra_unit_validN.
  - lia.
  - apply HP; eauto using ucmra_unit_validN.
    uPred.unseal => //=.
Qed.

Lemma laterN_big n a x φ: ✓{n} x →  a ≤ n → uPred_holds (▷^a ⌜φ⌝ : uPred M)%I n x → φ.
Proof.
  induction 2 as [| ?? IHle].
  - induction a; repeat (rewrite //= || uPred.unseal).
    intros Hlater. apply IHa; auto using cmra_validN_S.
    move:Hlater; repeat (rewrite //= || uPred.unseal).
  - intros. apply IHle; auto using cmra_validN_S.
    eapply uPred_mono; eauto using cmra_validN_S.
Qed.

Lemma laterN_small n a x P: ✓{n} x →  n < a → uPred_holds (▷^a P) n x.
Proof.
  induction 2.
  - induction n as [| n IHn]; [| move: IHn];
      repeat (rewrite //= || uPred.unseal).
    naive_solver eauto using cmra_validN_S.
  - induction n as [| n IHn]; [| move: IHle];
      repeat (rewrite //= || uPred.unseal).
    red; rewrite //=. intros.
    eapply (uPred_mono _ _ (S n)); eauto using cmra_validN_S.
Qed.

Lemma laterN_exist_big_inhabited A (Φ: A → uPred M) k n x:
  ✓{n} x →  k ≤ n → uPred_holds (▷^k upred.uPred_exist_def (λ a : A, Φ a)) n x →
  ∃ a : A, True.
Proof.
  induction 2 as [| ?? IHle].
  - induction k; repeat (rewrite //= || uPred.unseal).
    { destruct 1; eauto. }
    intros Hlater. apply IHk; auto using cmra_validN_S.
  - intros. apply IHle; auto using cmra_validN_S.
    eapply uPred_mono; eauto using cmra_validN_S.
Qed.

Local Hint Resolve or_elim or_intro_l' or_intro_r' True_intro False_elim : core.
Local Hint Resolve and_elim_l' and_elim_r' and_intro forall_intro : core.

Lemma laterN_exist_false A (Φ : A → uPred M) k:
  ▷^k (∃ a : A, Φ a) -∗ ▷^k False ∨ (∃ a : A, ▷^k Φ a).
Proof.
  split => n x Hval Hall.
  destruct (decide (n < k)).
  - uPred.unseal. left. apply laterN_small; eauto.
  - move: Hall. uPred.unseal. right.
    edestruct (laterN_exist_big_inhabited A Φ k) as (a&_); eauto.
    { lia. }
    assert (Inhabited A).
    { by econstructor. }
    specialize (laterN_exist k Φ).
    uPred.unseal. intros Hequiv. eapply Hequiv; eauto.
Qed.

Lemma laterN_ownM (a: M) k: ▷^k uPred_ownM a -∗ ∃ b, uPred_ownM b ∧ ▷^k (a ≡ b).
Proof.
  revert a. induction k as [| k IH] => a; iIntros "H".
  - eauto.
  - iAssert (▷^k ∃ b, uPred_ownM b ∧ ▷ (a ≡ b))%I with "[H]" as "H".
    { iNext. by iApply later_ownM. }
    assert (Inhabited M) by (eexists; eauto).
    iDestruct "H" as (b) "(Hown&#Hequiv)".
    iPoseProof (IH with "Hown") as (b') "(Hown&#Hequiv')".
    iExists b'. iFrame. rewrite -later_laterN laterN_later. iNext.
    iNext. iRewrite "Hequiv". eauto.
Qed.
End uPred_laws.