(**

- the notion of strong monads w.r.t. monoidal actions (a generalization of the notion w.r.t. a monad)
- an instantiation to strong monads in monoidal categories

see https://ncatlab.org/nlab/show/strong+monad for a general bicategorical formulation and for the one w.r.t. a monad,
the present notion is intermediately abstract/general and only sketched on that page

author: Ralph Matthes 2022

 *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Functors.
Require Import UniMath.CategoryTheory.Actegories.Actegories.
Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories.
Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.

Local Open Scope cat.

Import BifunctorNotations.
Import MonoidalNotations.
Import ActegoryNotations.

Section A.

Context {V : category} {Mon_V : monoidal V} {C : category} (Act : actegory Mon_V C).

Definition ηandμlinear {M: Monad C} (Ml : lineator_lax Mon_V Act Act M) : UU :=
  is_linear_nat_trans (identity_lineator_lax Mon_V Act) Ml (η M) ×
    is_linear_nat_trans (comp_lineator_lax Mon_V Ml Ml) Ml (μ M).

Definition ηandμlinearnicer {M: Monad C} (Ml : lineator_lax Mon_V Act Act M) : UU :=
  ∏ (v : V) (x : C), η M (v ⊗_{Act} x) = v ⊗^{Act}_{l} η M x · Ml v x
                   × v ⊗^{Act}_{l} μ M x · Ml v x = Ml v (M x) · #M (Ml v x) · μ M (v ⊗_{Act} x).

Lemma ηandμlinearimpliesnicer {M: Monad C} (Ml : lineator_lax Mon_V Act Act M) (ηandμlin : ηandμlinear Ml) : ηandμlinearnicer Ml.
Proof.
  split.
  - etrans.
    2: { apply ηandμlin. }
    apply pathsinv0, id_left.
  - apply pathsinv0, ηandμlin.
Qed.

Lemma ηandμlinearfollowsfromnicer {M: Monad C} (Ml : lineator_lax Mon_V Act Act M) (ηandμlinn : ηandμlinearnicer Ml) : ηandμlinear Ml.
Proof.
  split.
  - red; intros.
    etrans.
    2: { apply ηandμlinn. }
    apply id_left.
  - red; intros.
    apply pathsinv0, ηandμlinn.
Qed.

Definition actionbasedstrongmonads_cat_disp : disp_cat (category_Monad C).
Proof.
  use tpair.
  - use tpair.
    + use make_disp_cat_ob_mor.
      * intro M.
        exact (∑ Ml : lineator_lax Mon_V Act Act (M: Monad C), ηandμlinear Ml).
      * intros M N [Ml islinM] [Nl islinN] α.
        exact (is_linear_nat_trans Ml Nl (nat_trans_from_monad_mor _ _ _ α)).
    + split.
      * intros M [Ml [islinMη islimMμ]]. cbn.
        apply is_linear_nat_trans_identity.
      * intros M N O α α' Mll Nll Oll islntα islntβ.
        exact (is_linear_nat_trans_comp (pr1 Mll) (pr1 Nll) (pr1 Oll) islntα islntβ).
  - repeat split; intros; try apply isaprop_is_linear_nat_trans.
    apply isasetaprop; apply isaprop_is_linear_nat_trans.
Defined.

Definition actionbasedstrongmonads_cat_total : category := total_category actionbasedstrongmonads_cat_disp.

End A.

Section StrongMonads.

  Context {C : category} (M : monoidal C).

Definition strongmonads_cat_disp : disp_cat (category_Monad C) :=
  actionbasedstrongmonads_cat_disp (actegory_with_canonical_self_action M).

Definition strongmonads_cat_total : category := total_category strongmonads_cat_disp.

End StrongMonads.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj19synthconj1 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus (mult lv0 lv1) lv1) (plus (mult lv0 lv1) lv1)).
Admitted.
QuickChick conj19synthconj1.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Natural.Transformation.
Require Import Category.Structure.Closed.
Require Import Category.Construction.Opposite.
Require Import Category.Construction.Product.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Program Definition InternalHomFunctor `(C : Category)
        {E : @Cartesian C} {O : @Closed C _} : C^op ∏ C ⟶ C := {|
  fobj := fun p => @exponent_obj C E O (fst p) (snd p);
  fmap := fun x y f => _
|}.
Next Obligation.
  exact (curry (h0 ∘ eval ∘ (second h))).
Defined.
Next Obligation.
  unfold InternalHomFunctor_obligation_1.
  proper; simpl.
  rewrites.
  reflexivity.
Qed.
Next Obligation. unfold second; simpl; cat. Qed.
Next Obligation.
  unfold InternalHomFunctor_obligation_1; simpl.
  rewrite <- !comp_assoc.
  rewrite curry_comp.
  symmetry.
  rewrite curry_comp.
  rewrite <- comp_assoc.
  apply compose_respects.
    reflexivity.
  symmetry.
  rewrite curry_comp_l.
  rewrite <- !comp_assoc.
  rewrite <- first_second.
  rewrite !comp_assoc.
  rewrite ump_exponents.
  rewrite <- !comp_assoc.
  rewrite second_comp.
  reflexivity.
Qed.

Notation "a ≈> b":= (InternalHomFunctor _ (a, b))
  (at level 89) : category_scope.
Notation "a ≈{ C }≈> b":= (InternalHomFunctor C (a, b))
  (at level 89) : category_scope.


Require Import TestSuite.admit.
(* Test on definitions referring to section variables that are not any
   longer in the current context *)

Section x.

  Hypothesis h : forall(n : nat), n < S n.

  Definition f(n m : nat)(less : n < m) : nat := n + m.

  Lemma a : forall(n : nat), f n (S n) (h n) = 1 + 2 * n.
  Proof.
    (* XXX *) admit.
  Qed.

  Lemma b : forall(n : nat), n < 3 + n.
  Proof.
    clear.
    intros n.
    Fail assert (H := a n).
  Abort.

  Let T := True.
  Definition p := I : T.

  Lemma paradox : False.
  Proof.
    clear.
    set (T := False).
    Fail pose proof p as H.
  Abort.


Require Import SMTCoq.SMTCoq.
Local Open Scope Z_scope.

Import FArray.
Local Open Scope farray_scope.

Instance oZord: OrdType (option Z) := {|
  lt o1 o2 := match o1, o2 with
                | Some z1, Some z2 => z1 < z2
                | None, Some z2 => True
                | Some z1, None => False
                | None, None => False
              end;
|}.
all: intros.
- destruct x; destruct y; destruct z; try omega. auto.
- destruct x; destruct y; intro; try omega.
  + inversion H0.
    omega.
  + discriminate.
Defined.

Instance oZcomp: Comparable (option Z) := {|
  compare o1 o2 := match o1, o2 with
                   | Some z1, Some z2 => _
                   | None, Some z2 => _
                   | Some z1, None => _
                   | None, None => _
                   end;
|}.
- destruct (z1 ?= z2) eqn: E.
  + apply OrderedType.EQ.
    apply Z.compare_eq in E.
    congruence.
  + apply OrderedType.LT.
    rewrite Z.compare_lt_iff in E.
    simpl.
    assumption.
  + apply OrderedType.GT.
    rewrite Z.compare_gt_iff in E.
    simpl.
    assumption.
- apply OrderedType.GT. simpl. auto.
- apply OrderedType.LT. simpl. auto.
- apply OrderedType.EQ. simpl. auto.
Defined.

Instance ioz: Inhabited (option Z) := {|
  default_value := None;
|}.

Goal forall (a b c d: farray Z Z),
    b[0 <- (4)] = c  ->
    d = b[0 <- (4)][1 <- (4)]  ->
    a = d[1 <- b[1]]  ->
    a <> c.
Proof.
  (* cvc4. *)
(*
In nested Ltac calls to "cvc4" and "cvc4_bool", last call failed.
Error:
CVC4 returned sat. Here is the model:

a := (const_farray 0)[0 <- 4][1 <- -1]
b := (const_farray 0)[1 <- -1]
c := (const_farray 0)[0 <- 4][1 <- -1]
d := (const_farray 0)[0 <- 4][1 <- 4]
*)
Abort.

Goal forall (a b c d: farray Z (option Z)),
    b[0 <- (Some 4)] = c  ->
    d = b[0 <- (Some 4)][1 <- (Some 4)]  ->
    a = d[1 <- b[1]]  ->
    a <> c.
Proof.
  cvc4.

(*
In nested Ltac calls to "cvc4" and "cvc4_bool", last call failed.
Error:
CVC4 returned sat. Here is the model:

a := (const_farray (option Z)#0)[0 <- (option Z)#1]
b := (const_farray (option Z)#0)
c := (const_farray (option Z)#0)[0 <- (option Z)#1]
d := (const_farray (option Z)#0)[0 <- (option Z)#1][1 <- (option Z)#1]
Z := Set#0
(@Some) := fun _ _ => (option Z)#1
*)
Abort.

Goal forall (a b c d: farray Z (option Z)),
    b[0 <- (Some 4)] = c  ->
    d = b[0 <- (Some 4)][1 <- (Some 4)]  ->
    a = d[1 <- b[1]]  ->
    a = c.
Proof.
  (* cvc4. *)
(*
In nested Ltac calls to "cvc4" and "cvc4_bool", last call failed.
System error: "/home/sam/Documents/git/otherprojects/counterexamples/SMTCoq/sat.plf: No such file or directory"
*)
Abort.

Goal forall (a b c d: farray Z Z),
    b[0 <- (4)] = c  ->
    d = b[0 <- (4)][1 <- (4)]  ->
    a = d[1 <- b[1]]  ->
    a = c.
Proof.
  (* cvc4. *)
(*
In nested Ltac calls to "cvc4" and "cvc4_bool", last call failed.
System error: "/home/sam/Documents/git/otherprojects/counterexamples/SMTCoq/sat.plf: No such file or directory"
 *)
Abort.


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

(***
Modulus : 2^158 - 15
Base: 52 + 2/3
***)

Definition curve : CurveParameters :=
  {|
    sz := 3%nat;
    base := 52 + 2/3;
    bitwidth := 64;
    s := 2^158;
    c := [(1, 15)];
    carry_chains := Some [seq 0 (pred 3); [0; 1]]%nat;

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

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

    mul_code := None;

    square_code := None;

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

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


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import bedrock2.Array.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Syntax.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import coqutil.Word.Interface.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Bignum.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Operation.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.UnsaturatedSolinas.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.Tactics.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.UnsaturatedSolinas.
Require Import Crypto.Bedrock.Field.Synthesis.Examples.X25519_64.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.UnsaturatedSolinasHeuristics.
Require Import bedrock2.Semantics.
Import ListNotations.
Import Syntax.Coercions.
Local Open Scope Z_scope.

Existing Instances
         Defaults64.default_parameters names
         curve25519_bedrock2_funcs curve25519_bedrock2_specs
         curve25519_bedrock2_correctness.
Local Open Scope string_scope.

(* Notations to make spec more readable *)
Local Notation n := X25519_64.n.
Local Notation s := X25519_64.s.
Local Notation c := X25519_64.c.
Local Notation machine_wordsize := X25519_64.machine_wordsize.
Local Notation M := (UnsaturatedSolinas.m s c).
Local Notation weight :=
  (ModOps.weight (QArith_base.Qnum
                    (UnsaturatedSolinasHeuristics.limbwidth n s c))
                 (Z.pos (QArith_base.Qden
                           (UnsaturatedSolinasHeuristics.limbwidth n s c)))).
Local Notation eval := (Positional.eval weight n).
Local Notation loose_bounds := (UnsaturatedSolinasHeuristics.loose_bounds n s c).
Local Notation tight_bounds := (UnsaturatedSolinasHeuristics.tight_bounds n s c).
Local Infix "*" := sep : sep_scope.
Delimit Scope sep_scope with sep.

(* test function; computes x * y * y *)
Definition mul_twice : func :=
  let x := "x" in
  let y := "y" in
  let xy := "xy" in
  let out := "out" in
  ("mul_twice",
   ([out; x; y], [],
    (cmd.seq
       (cmd.call [] "curve25519_carry_mul" [expr.var out; expr.var x; expr.var y])
       (cmd.call [] "curve25519_carry_mul" [expr.var out; expr.var out; expr.var y])))).

(* TODO: update to have three separation-logic preconditions, one for each input
   and one for output *)
Instance spec_of_mul_twice : spec_of mul_twice :=
  fun functions =>
    forall x y old_out px py pout t m
           (R : Interface.map.rep
                  (map:=Semantics.mem) -> Prop),
      let xz := map word.unsigned x in
      let yz := map word.unsigned y in
      list_Z_bounded_by loose_bounds xz ->
      list_Z_bounded_by loose_bounds yz ->
      (Bignum n px x * Bignum n py y * Bignum n pout old_out * R)%sep m ->
      WeakestPrecondition.call
        (p:=Types.semantics)
        functions mul_twice t m
        (pout :: px :: py ::  nil)
        (fun t' m' rets =>
           t = t' /\
           rets = []%list /\
           exists out,
             let outz := map word.unsigned out in
             eval outz mod M
             = (eval xz * eval yz * eval yz) mod M
             /\ list_Z_bounded_by tight_bounds outz
             /\ (Bignum n px x * Bignum n py y
                 * Bignum n pout out * R)%sep m').

Instance spec_of_curve25519_carry_mul :
  spec_of "curve25519_carry_mul" := spec_of_carry_mul.

Ltac prove_bounds :=
  match goal with
  | H : list_Z_bounded_by tight_bounds ?x
    |- list_Z_bounded_by loose_bounds ?x =>
    apply UnsaturatedSolinas.relax_correct; apply H
  | H : list_Z_bounded_by ?b ?x |- list_Z_bounded_by ?b ?x =>
    apply H
  end.
Ltac prove_length :=
  match goal with
  | |- length _ = _ => rewrite ?map_length; solve [eauto]
  | |- length _ = n =>
    apply bounded_by_loose_bounds_length
      with (s:=s) (c:=c); prove_bounds
  end.
Ltac prove_preconditions :=
  lazymatch goal with
  | |- length _ = _ => prove_length
  | |- list_Z_bounded_by _ _ => prove_bounds
  end.

Lemma mul_twice_correct :
  program_logic_goal_for_function! mul_twice.
Proof.
  straightline_init_with_change.

  repeat straightline.
  handle_call; [ prove_preconditions .. | ].
  repeat straightline.
  handle_call; [ prove_preconditions .. | ].

  repeat split; try reflexivity.
  sepsimpl_hyps.
  eexists; sepsimpl;
    lazymatch goal with
    | |- sep _ _ _ => ecancel_assumption
    | _ => idtac
    end.
  all: try prove_bounds.
  repeat match goal with
         | H : eval _ mod _ = (eval _ * eval _) mod _ |- _ =>
           rewrite H
         | _ => progress Modulo.push_Zmod
         end.
  reflexivity.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime A B C D : Universe, ((wd_ C O /\ (wd_ A O /\ (wd_ B O /\ (wd_ D O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ Eprime C /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ col_ O Eprime B))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B X Y P Q R Rprime : Universe, ((wd_ A B /\ (wd_ X Y /\ (wd_ R Rprime /\ (wd_ P Q /\ (wd_ R Q /\ (wd_ Rprime Q /\ (wd_ B R /\ (wd_ A R /\ (col_ P Q R /\ (col_ A B P /\ (col_ A B Q /\ (col_ A B Rprime /\ (col_ P Q Rprime /\ col_ A P Q))))))))))))) -> col_ B P Q)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Structure.Cartesian.
Require Import Category.Structure.Cocartesian.
Require Import Category.Construction.Opposite.

Generalizable All Variables.

Section Bicartesian.

Context {C : Category}.
Context `{@Cartesian C}.
Context `{@Cocartesian C}.

Corollary fork_merge {x y z w : C}
          (f : x ~> y) (g : x ~> z) (h : w ~> y) (i : w ~> z) :
  (f △ g) ▽ (h △ i) ≈ (f ▽ h) △ (g ▽ i).
Proof.
  rewrite <- id_left.
  rewrite <- fork_exl_exr.
  rewrite <- fork_comp.
  apply fork_respects;
  rewrite <- merge_comp; cat;
  apply (@fork_respects (C^op)); cat.
Qed.

End Bicartesian.


(** Coq coding by choukh, Aug 2021 **)

(* 哥德尔本体论公理的本地版本在固定论域KB系统中不一致 *)

Require Import CM.Logic.Classical.
Require Import CM.Logic.Modal.
Require Import CM.Logic.Entity.
Require Import CM.Logic.LocalWorld.
Import Modal.KB.

Parameter 积极 : 泛性质 性质.
Definition 消极 := λ Φ, ¬ 积极 Φ.

Axiom 积极性质的反面消极 : ⌜∀ Φ, 积极 Φ → 消极 (反 Φ)⌟.

Axiom 积极的必然后果也积极 : ⌜∀ Φ Ψ : 性质, 积极 Φ → (Φ ⇒ Ψ) → 积极 Ψ⌟.

Theorem 积极性质可能存在实例 : ⌜∀ Φ, 积极 Φ → 一致 Φ⌟.
Proof.
  intros Φ H. 反证.
  apply (爆炸原理 w₀ Φ (反 Φ)) in 反设.
  apply (积极性质的反面消极 Φ). apply H.
  now apply (积极的必然后果也积极 Φ).
Qed.

(* P是x的本性，当且仅当x的任意性质都是P的必然后果 *)
Definition 本性 : 性质 → 实体 → 命题 :=
  λ Φ x, ∀ Ψ, Ψ x → Φ ⇒ Ψ.

(* 实体实在，当且仅当该实体的任意本性都必然存在实例 *)
Definition 实在性 : 性质 := λ x, ∀ Φ, 本性 Φ x → □ ∃ x, Φ x.

Axiom 实在性积极 : ⌜积极 实在性⌟.

Lemma 实在性可能存在实例 : ⌜一致 实在性⌟.
Proof. apply 积极性质可能存在实例. apply 实在性积极. Qed.

Lemma 可能必然存在反同一性实体 : ⌜◇ □ ∃ x, 反同一性 x⌟.
Proof.
  eapply 可能性三段论1. apply 实在性可能存在实例.
  apply 𝗡. 证明. intros []. apply H. firstorder.
Qed.

Fact 公理不一致 : False.
Proof.
  pose proof 可能必然存在反同一性实体.
  firstorder using 对称框架.
Qed.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal40.

From lfind Require Import LFind.
Require Import Arith.
Lemma lfind_state  (n:natural) (x:lst) (y:lst):@eq bool (lst_subset x (append y (Cons n x))) true.
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal40_subset_append_81_append_cons/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for bool.

              Derive Arbitrary for bool.

              Instance Dec_Eq_bool : Dec_Eq bool.

              Proof. dec_eq. Qed.
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (x:lst) (y:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  x y.
QuickChick collect_data.
Success.


From stdpp Require Import tactics.
From discprob.basic Require Import base order nify.
Require Import Ranalysis5.
Require Import Reals Fourier FunctionalExtensionality.
From Coquelicot Require Export Rcomplements Rbar Series Lim_seq Hierarchy Markov Continuity ElemFct.
Require Import List.
Require Import Psatz Omega.

Local Notation "x ≤ y" := (Rle x y) (at level 70, no associativity).
Local Notation "x ≥ y" := (Rge x y) (at level 70, no associativity).

Lemma Rmult_eq_0_inv_r: ∀ r r1 r2 : R, (r ≠ 0 → r1 = r2) → r * r1 = r * r2.
Proof.
  intros r r1 r2; case (Req_dec r 0).
  - intros ->. by rewrite !Rmult_0_l.
  - intros Hneq Heq. rewrite Heq //.
Qed.

Lemma Rmult_eq_0_inv_l: ∀ r r1 r2 : R, (r ≠ 0 → r1 = r2) → r1 * r = r2 * r.
Proof.
  intros r r1 r2; case (Req_dec r 0).
  - intros ->. by rewrite !Rmult_0_r.
  - intros Hneq Heq. rewrite Heq //.
Qed.

Lemma Rmult_neq_0_compat: ∀ r1 r2 : R, r1 ≠ 0 → r2 ≠ 0 → r1 * r2 ≠ 0.
Proof. intros r1 r2 ?? [?|?]%Rmult_integral; congruence. Qed.

Lemma Rdiv_le_compat_contra: ∀ r1 r2 r3 r4 : R,
    0 ≤ r1 → 0 < r4 → r1 ≤ r2 → r4 ≤ r3 → r1 / r3 ≤ r2 / r4.
Proof.
  intros. rewrite /Rdiv. apply Rmult_le_compat; auto.
  rewrite -(Rmult_1_l (/ r3)). apply Rle_mult_inv_pos; fourier.
    by apply Rinv_le_contravar.
Qed.

Lemma Rmult_le_0_compat x y: 0 ≤ x → 0 ≤ y → 0 ≤ x * y.
Proof.
  intros. rewrite -[a in a ≤ _](Rmult_0_l 0).
  apply Rmult_le_compat; eauto; try reflexivity.
Qed.

Lemma fold_right_plus_mult (l: list R) v :
  (fold_right Rplus 0 l) * v = fold_right Rplus 0 (map (λ x, x * v) l).
Proof.
  induction l => //=; first nra.
  ring_simplify. rewrite IHl. done.
Qed.

Lemma fold_right_map_Rmult_le {A} (l: list A) f f':
  (∀ x, In x l → 0 <= f x ∧ f x <= f' x) →
  fold_right Rmult 1 (map f l) <= fold_right Rmult 1 (map f' l).
Proof.
  intros Hin.
  cut (0 <= fold_right Rmult 1 (map f l) ∧
       fold_right Rmult 1 (map f l) <= fold_right Rmult 1 (map f' l)).
  { intros [? ?]; done. }
  induction l.
  - rewrite //=; intros; nra.
  - rewrite //=. destruct IHl.
    { intros a' Hin'. apply Hin. by right. }
    split.
    * apply Rmult_le_0_compat; eauto.
      edestruct (Hin a); eauto; first by left.
    * apply Rmult_le_compat; auto.
      ** edestruct (Hin a); eauto; first by left.
      ** edestruct (Hin a); eauto; first by left.
Qed.

Hint Resolve Rabs_pos Rle_ge.

Lemma Rabs_case r (P : R → Type):
  (0 <= r → P r) → (0 <= -r → P (-r)) → P (Rabs r).
Proof.
  intros Hcase1 Hcase2.
  destruct (Rle_dec 0 r) as [?|?%Rnot_le_gt].
  * rewrite Rabs_right //=; eauto; try nra.
  * rewrite Rabs_left1 //=.
    ** eapply Hcase2. apply Ropp_le_cancel.
       rewrite Ropp_0 Ropp_involutive. left. auto.
    ** left. auto.
Qed.

Lemma open_interval_open x y :
  open (open_interval x y).
Proof.
  rewrite /open => z [? ?].
  rewrite /locally.
  unshelve (eexists).
  { exists (Rmin (z - x) (y - z)). abstract (apply Rmin_pos; nra).  }
  intros z' => //=. rewrite /ball//=/AbsRing_ball//=/abs//=.
  apply Rmin_case_strong; apply Rabs_case;
    rewrite /open_interval/minus//=/plus//=/opp//=; intros; split; nra.
Qed.

Lemma disc_ball z Δ x:
  disc z Δ x ↔ ball z Δ x.
Proof. rewrite /disc/ball//=. Qed.

Lemma open_included_disc U z:
  open U → U z → ∃ delta : posreal, included (disc z delta) U.
Proof.
  intros Hopen Hz. edestruct Hopen as (delta&Hdelta); eauto.
  exists delta. intros ??. apply Hdelta; eauto.
Qed.

Lemma open_open_set U:
  open U → open_set U.
Proof. done. Qed.

Lemma disc_neighbourhood x (δ: posreal):
  neighbourhood (disc x δ) x.
Proof.
  rewrite /neighbourhood; exists δ. rewrite /included. done.
Qed.

Lemma ball_neighbourhood x (δ: R):
  δ > 0 →
  neighbourhood (ball x δ) x.
Proof.
  rewrite /neighbourhood. unshelve (eexists).
  { exists δ.  nra. }
  rewrite //=.
Qed.

Lemma pos_INR': ∀ n : nat, (0 < n)%nat → 0 < INR n.
Proof. intros n Hlt. replace 0 with (INR 0) by auto. by apply lt_INR.  Qed.

Lemma archimed_rat_dense1 eps r:
  0 < eps →
  0 <= r →
  ∃ n m, r < INR n / INR m < r + eps ∧ (0 < m)%nat.
Proof.
  intros Hpos1 Hpos2.
  edestruct (archimed_cor1 eps) as (m&Hm1&Hm2); auto.
  edestruct (archimed (r * (INR m))) as (Hup1&Hup2).
  assert (0 < INR m) by (apply pos_INR'; done).
  assert (0 <= r * INR m).
  { apply (pos_INR') in Hm2. rewrite /Rdiv.
    apply Rmult_le_pos; auto. nra.
  }
  assert (0 <= up (r * INR m))%Z.
  { apply le_IZR. nra. }
  exists (Z.to_nat (up (r * INR m))).
  exists m.
  split; first split; auto.
  *  rewrite INR_IZR_INZ.
     rewrite Z2Nat.id //=. apply (Rmult_lt_reg_r (INR m)); auto.
     rewrite /Rdiv Rmult_assoc. rewrite Rinv_l; last by nra.
     rewrite Rmult_1_r. done.
  *  rewrite INR_IZR_INZ.
     rewrite Z2Nat.id //=. apply (Rmult_lt_reg_r (INR m)); auto.
     rewrite /Rdiv Rmult_assoc. rewrite Rinv_l; last by nra.
     rewrite Rmult_1_r. rewrite Rmult_plus_distr_r.
     apply (Rle_lt_trans _ (r * INR m + 1)); first by nra.
     cut (1 < eps * INR m); first by nra.
     rewrite -(Rinv_l (INR m)); last by nra. apply Rmult_lt_compat_r; nra.
Qed.

Lemma archimed_rat_dense2 eps r:
  0 < eps →
  r < 0 →
  ∃ n m, r < - INR n / INR m < r + eps ∧ (0 < m)%nat.
Proof.
  intros Hpos Hneg.
  assert (∃ eps', 0 < eps' <= eps ∧ r + eps' < 0) as (eps'&Hr&?).
  { destruct (Rlt_dec eps (-r)) as [Hlt|Hnlt].
    { exists eps; split; auto; try nra. }
    apply Rnot_lt_ge in Hnlt.
    exists (-r / 2); split; nra.
  }
  cut (∃ n m, r < - INR n / INR m < r + eps' ∧ (0 < m)%nat).
  { intros (n&m&?&?). exists n, m; split; auto. nra. }
  set (r' := -r - eps').
  edestruct (archimed_rat_dense1 eps' (-r - eps')) as (n&m&?&?); try nra.
  exists n, m; split; auto; try nra.
Qed.

Lemma is_lim_seq_plus_inv un vn u v:
  is_lim_seq (λ n, un n + vn n) (u + v) →
  is_lim_seq (λ n, vn n) v →
  is_lim_seq (λ n, un n) u.
Proof.
  intros Hlim1 Hlim2.
  apply (is_lim_seq_scal_l _ (-1)) in Hlim2. rewrite //= in Hlim2.
  eapply is_lim_seq_plus' in Hlim1; eauto.
  replace (-1 * v + (u + v)) with u in Hlim1 by nra.
  eapply is_lim_seq_ext; last by apply Hlim1.
  intros. nra.
Qed.

Lemma is_lim_seq_opp_inv un u:
  is_lim_seq (λ n, - un n) (- u) →
  is_lim_seq (λ n, un n) u.
Proof.
  intros Hlim.
  apply (is_lim_seq_scal_l _ (-1)) in Hlim. rewrite //= in Hlim.
  replace (-1 * -u) with u in Hlim by nra.
  eapply is_lim_seq_ext; try eassumption.
  intros n; nra.
Qed.

Lemma Rmin_diff_eq x y:
  Rmin x y = (x + y) / 2 - Rabs(x - y) / 2.
Proof.
  apply Rmin_case_strong; apply Rabs_case; nra.
Qed.

Lemma Rmax_diff_eq x y:
  Rmax x y = (x + y) / 2 + Rabs(x - y) / 2.
Proof.
  apply Rmax_case_strong; apply Rabs_case; nra.
Qed.

Lemma continuous_Rmin_l x y: continuous (Rmin x) y.
Proof.
  eapply continuous_ext.
  { intros x'. rewrite Rmin_diff_eq; done. }
  apply: continuous_minus.
  * apply: continuous_scal.
    ** apply: continuous_plus.
       *** apply: continuous_const.
       *** apply: continuous_id.
    ** apply: continuous_const.
  * apply: continuous_scal.
    ** apply: continuous_comp.
       *** apply: continuous_minus.
           **** apply: continuous_const.
           **** apply: continuous_id.
       *** apply: continuous_abs.
    ** apply: continuous_const.
Qed.

Lemma continuous_Rmax_l x y: continuous (Rmax x) y.
Proof.
  eapply continuous_ext.
  { intros x'. rewrite Rmax_diff_eq; done. }
  apply: continuous_plus.
  * apply: continuous_scal.
    ** apply: continuous_plus.
       *** apply: continuous_const.
       *** apply: continuous_id.
    ** apply: continuous_const.
  * apply: continuous_scal.
    ** apply: continuous_comp.
       *** apply: continuous_minus.
           **** apply: continuous_const.
           **** apply: continuous_id.
       *** apply: continuous_abs.
    ** apply: continuous_const.
Qed.

Lemma archimed_pos r: 0 <= r → ∃ n, INR n <= r < INR (S n).
Proof.
  intros Hpos. exists (Z.to_nat (up r - 1)).
  cut (INR (Z.to_nat (up r - 1)) = IZR (up r)- 1).
  { rewrite S_INR => ->. specialize (archimed r). nra. }
  rewrite Z2Nat.inj_sub; last omega.
  rewrite minus_INR.
  * rewrite //=. f_equal.
    rewrite INR_IZR_INZ.  f_equal.
    apply Z2Nat.id.
    apply le_IZR. specialize (archimed r); nra.
  * apply Z2Nat.inj_le; try omega.
    ** apply le_IZR. specialize (archimed r); nra.
    ** apply le_IZR. specialize (archimed r). intros (Hgt&?).
       assert (0 < up r)%Z.
       { apply lt_IZR. nra. }
       apply IZR_le. omega.
Qed.

Lemma pow_INR n k: INR (n^k) = INR n^k.
Proof.
  induction k => //=. rewrite ?plus_INR mult_INR -IHk.
  replace (INR 0) with 0 by auto. nra.
Qed.

Lemma INR_diff_lt_1_eq n k: 0 <= INR n - INR k < 1 → n = k.
Proof.
  intros (?&Hdiff).
  assert (Hpos:INR k <= INR n) by nra.
  apply INR_le in Hpos.
  rewrite -minus_INR in Hdiff; auto.
  replace 1 with (INR 1) in Hdiff; auto.
  apply INR_lt in Hdiff.
  omega.
Qed.

Lemma Sup_seq_const k: Sup_seq (λ n, k) = k.
Proof.
  rewrite Rbar_sup_eq_lub.
  apply Lub.Rbar_is_lub_unique => //=.
  split.
  * intros ? (?&->) => //=. apply Rbar_le_refl.
  * intros ? Hub. apply Hub; exists O; eauto.
Qed.

Lemma Sup_seq_real (xn: nat → R): Rbar_lt m_infty (Sup_seq xn).
Proof.
  apply (Rbar_lt_trans _ (xn O - 1)); first done.
  apply Sup_seq_minor_lt. exists O => //=. nra.
Qed.

Lemma Sup_seq_real_p_infty (xn: nat → R):
  Sup_seq xn = p_infty ↔ ∀ k, ∃ n, k <= xn n.
Proof.
  split.
  - rewrite /Sup_seq. destruct (ex_sup_seq) as (v&Hsup) => //=.
    apply is_sup_seq_lub in Hsup. intros; subst.
    destruct Hsup as (Hub&Hlub).
    apply Classical_Pred_Type.not_all_not_ex => Hall.
    cut (Rbar_le p_infty k); first done.
    apply Hlub. intros ? (n&->). rewrite //=.
    specialize (Hall n). nra.
  - intros Hunbounded. specialize (Sup_seq_real xn).
    rewrite /Sup_seq. destruct (ex_sup_seq) as ([ | |]&His) => //=.
    exfalso. apply is_sup_seq_lub in His.
    destruct His as (Hub&?).
    destruct (Hunbounded (r+1)) as (n&Hle).
    feed pose proof (Hub (xn n)) as Hle'.
    { exists n. auto. }
    rewrite //= in Hle'. nra.
Qed.

Definition Rbar_max (x y: Rbar) : Rbar :=
  match x, y with
  | Finite x', Finite y' => Rmax x' y'
  | m_infty, _ => y
  | _, m_infty => x
  | p_infty, _ => p_infty
  | _, p_infty => p_infty
  end.

Lemma Rbar_max_l: ∀ x y : Rbar, Rbar_le x (Rbar_max x y).
Proof.
  destruct x, y => //=; try apply Rmax_l; reflexivity.
Qed.

Lemma Rbar_max_r: ∀ x y : Rbar, Rbar_le y (Rbar_max x y).
  destruct x, y => //=; try apply Rmax_r; reflexivity.
Qed.

Lemma Rbar_max_comm: ∀ x y : Rbar, Rbar_max x y = Rbar_max y x.
Proof. destruct x, y => //=; by rewrite Rmax_comm. Qed.

Lemma Rbar_max_case: ∀ (x y : Rbar) (P : Rbar → Type), P x → P y → P (Rbar_max x y).
Proof. destruct x, y => //=; by apply Rmax_case. Qed.

Lemma Rbar_max_case_strong:
  ∀ (x y : Rbar) (P : Rbar → Type),
  (Rbar_le y x → P x) → (Rbar_le x y → P y) → P (Rbar_max x y).
Proof. destruct x, y => //=; try apply Rmax_case_strong; eauto. Qed.

Lemma norm_Rabs r: norm r = Rabs r.
Proof.
  rewrite /norm//=/abs.
Qed.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Export Ensembles.
Require Export My_Finite_sets_facts.

Section Sets.

Variable U V: Type.

Definition Product (B:Ensemble U) (C:Ensemble V) : Ensemble(U*V) :=
fun (u:U*V) => let (x,y):=u in B x /\ C y.

End Sets.


Require Import Reals Qreals Psatz.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat ssrfun.
Require Import Rstruct.
From mf Require Import mf_set.
From Coquelicot Require Import Coquelicot.

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

Local Open Scope R_scope.
Section mean_value_theorem.
  Arguments limit_in {X} {X'}.
  Lemma derivable_pt_lim_id x: derivable_pt_lim id x 1.
  Proof.
    move => eps eg0; exists (mkposreal _ eg0) => h neq /= ineq.
    have ->: (x + h - x) / h = 1 by field.
    by split_Rabs; lra.
  Qed.

  Lemma derive_pt_unique f x P Q: derive_pt f x P = derive_pt f x Q.
  Proof. by apply/derive_pt_eq; move: Q => [f'x lim]. Qed.

  Definition cnst_ext f a b x: R :=
    match Rleb x a with
    | true => f a
    | false => match Rleb x b with
               | true => f x
               | false => f b
               end
    end.

  Lemma cont_cext (f: Base R_met -> Base R_met) a b x:
    a <= b ->
    limit_in f (fun c => a <= c <= b) x (f x) ->
    continuity_pt (cnst_ext f a b) x.
  Proof.
    move => alb lmt eps eg0; rewrite /cnst_ext.
    case: (total_order_T a x) => [xla | alx]; last first.
    - exists (a - x); split => [ | y [[_ neq]]]; first by lra.
      rewrite /dist /=/R_dist/= => dst.
      have ->: Rleb x a = true by apply/RlebP; lra.
      have ->: Rleb y a = true by apply/RlebP; split_Rabs; lra.
      split_Rabs; lra.
    case: (total_order_T x b) => [blx | xlb]; last first.
    - exists (x - b); split => [ | y [[_ neq]]]; first by lra.
      rewrite /dist /=/R_dist/= => dst.
      have ->: Rleb x a = false by apply/RlebP; lra.
      have ->: Rleb y a = false by apply/RlebP; split_Rabs; lra.
      have ->: Rleb x b = false by apply/RlebP; lra.
      have ->: Rleb y b = false by apply/RlebP; split_Rabs; lra.
      by split_Rabs; lra.
    have [delta [dg0 prp]]:= lmt eps eg0.
    exists delta; split => // y [[_ neq]].
    rewrite /dist/=/R_dist/= => dst.
    case: xla => [ineq | eq]; last first.
    - rewrite -eq; rewrite /dist/=/R_dist/= -eq in prp.
      have ->: (Rleb a a) by apply/RlebP; lra.
      case: ifP => [ | /RlebP ineq]; first by split_Rabs; lra.
      by case: ifP => /RlebP ineq'; apply/prp; split_Rabs; lra.
    have ->: Rleb x a = false by apply/RlebP; lra.
    case: ifP => /RlebP ineq'.
    - case: ifP => [/RlebP ineq'' | /RlebP/Rnot_le_lt]; last by case: blx; lra.
      by apply/prp; rewrite /dist/=/R_dist/=; split_Rabs; try lra.
    have ->: (Rleb x b = true) by apply/RlebP; case: blx; lra.
    case: ifP => [/RlebP ineq'' | /RlebP/Rnot_le_lt ineq'']; apply/prp.
    - by split; [case: blx; lra | apply/dst].
    split; first by case: blx; lra.
    have: x <= b by case: blx; lra.
    by rewrite /dist/=/R_dist/=; split_Rabs; lra.
  Qed.

  Lemma diff_cext f a b x y:
    a < x < b -> derivable_pt_lim f x y -> derivable_pt_lim (cnst_ext f a b) x y.
  Proof.
    move => ineqs diff eps eg0.
    have [[/=delta dg0] cnd]:= diff eps eg0.
    have ineq : 0 < (Rmin (Rmin delta (x - a)) (b - x)).
    - by apply/Rmin_pos; first apply/Rmin_pos; lra.
    exists (mkposreal _ ineq) => h hneq /= hl.
    rewrite /cnst_ext.
    have hlbx: Rabs h < b - x by apply/Rlt_le_trans; [apply/hl | apply/Rmin_r].
    have hlxa: Rabs h < x - a.
    - apply/Rlt_le_trans; first exact/hl.
      apply/Rle_trans; first exact/Rmin_l.
      exact/Rmin_r.
    have hld: Rabs h < delta.
    - apply/Rlt_le_trans; first exact/hl.
      apply/Rle_trans; first exact/Rmin_l.
      exact/Rmin_l.
    have ->: Rleb x a = false by apply/RlebP; lra.
    have ->: Rleb x b = true by apply/RlebP; lra.
    have -> : Rleb (x + h) a = false by apply/RlebP/Rlt_not_le; split_Rabs; lra.
    have ->: Rleb (x + h) b = true by apply/RlebP;split_Rabs; lra.
    exact/cnd.
  Qed.

  Theorem mean_value_theorem (f: Base R_met -> Base R_met) a b: a < b ->
    (forall c, a < c < b -> derivable_pt f c) ->
    (forall x, limit_in f (fun c => a <= c <= b) x (f x)) ->
    exists c, a < c < b /\ forall y, derivable_pt_lim f c y -> (f b - f a) = y * (b - a).
  Proof.
    move => alb deriv cont.
    have cont': forall x, a <= x <= b -> continuity_pt (cnst_ext f a b) x.
    - by move => x ineq; apply/cont_cext/cont; lra.
    have diff: forall x, a < x < b -> derivable_pt (cnst_ext f a b) x.
    - by move => x ineqs; have [f'x diff]:= deriv x ineqs; exists f'x; apply/diff_cext.
    have diff': forall x, a < x < b -> derivable_pt id x.
    - by move => x ineqs; exists 1; apply/derivable_pt_lim_id.
    have [ | | | x [ineqs eq]]//:= MVT (cnst_ext f a b) id a b diff diff'.
    - by move => x ineqs; apply/derivable_continuous_pt; exists 1; apply/derivable_pt_lim_id.
    exists x; split => // y deriv'.
    have <-: derive_pt (cnst_ext f a b) x (diff x ineqs) = y.
    - by apply/derive_pt_eq/diff_cext.
    rewrite Rmult_comm eq.
    have ->: derive_pt id x (diff' x ineqs) = 1.
    - by apply/derive_pt_eq/derivable_pt_lim_id.
    rewrite Rmult_1_r /cnst_ext.
    by do 3 (case: ifP => /RlebP; intros; try lra).
  Qed.
End mean_value_theorem.


(** * Binary tries using a GADT to enforce extensionality *)

(* Author: Xavier Leroy, Collège de France and Inria.
   Copyright: Inria.
   License: BSD-3-Clause. *)

From Coq Require Import PArith.

Set Implicit Arguments.

Module PTree.

(** ** Representation of tries *)

(** We start with the two-constructor representation of binary tries
    from module [Original] and add a parameter of type [kind] to the datatype,
    indicating whether the binary trie is empty or nonempty. *)

Inductive kind : Type := Empty | Nonempty.

(** As in the [Sigma] implementation, we want to exclude trivially empty nodes
    [Node l None r] where both subtrees [l] and [r] are empty.
    Unlike in the [Sigma] implementation, we express this criterion
    indirectly, using the kinds [kl] of [l] and [kr] of [r]. *)

Definition not_trivially_empty {A} (kl: kind) (o: option A) (kr: kind) :=
  match kl, o, kr with
  | Empty, None, Empty => False
  | _, _, _ => True
  end.

Lemma not_trivially_empty_left: forall A (o: option A) (kr: kind),
  not_trivially_empty Nonempty o kr.
Proof.
  intros; red; auto.
Qed.

Lemma not_trivially_empty_val: forall A (kl: kind) (a: A) (kr: kind),
  not_trivially_empty kl (Some a) kr.
Proof.
  intros; red. destruct kl; auto.
Qed.

Lemma not_trivially_empty_right: forall A (kl: kind) (o: option A),
  not_trivially_empty kl o Nonempty.
Proof.
  intros; red. destruct kl; auto. destruct o; auto.
Qed.

(** The representation type for tries, with the extra parameter of
    type kind that classifies tries as empty or nonempty.  In the
    [Node] case, we add a proof that the node is not trivially empty. *)

Inductive tree (A : Type) : kind -> Type :=
  | Leaf : tree A Empty
  | Node : forall (kl kr: kind) (l: tree A kl) (o: option A) (r: tree A kr),
                  not_trivially_empty kl o kr -> tree A Nonempty.

Arguments Leaf {A}.
Arguments Node [A kl kr].

(** The type of tries (empty or nonempty) is a dependent sum of
    an empty/nonempty kind and a representation of that kind.
    In other words, we quantify existentially over the kind. *)

Definition t (A: Type) := { k : kind & tree A k }.

(** ** Basic operations: [empty], [get], [set], [remove] *)

Definition empty (A : Type) : t A := existT _ Empty (@Leaf A).

(** Operations such as [get] are typically split in two functions:
    a function [get'] that works over type [tree A k] and is polymorphic
    over the kind [k], and a wrapper function [get] that deals with the
    existential quantification over the kind [k]. *)

Fixpoint get' (A : Type) (k: kind) (i : positive) (m : tree A k) {struct i} : option A :=
    match m with
    | Leaf => None
    | Node l o r _ =>
        match i with
        | xH => o
        | xO ii => get' ii l
        | xI ii => get' ii r
        end
    end.

Definition get (A: Type) (i : positive) (m : t A) : option A :=
  match m with existT _ k m => get' i m end.

(** [set'] has a lovely result type [tree A Nonempty], proving that the result
    is never the empty trie. *)

Fixpoint set' (A : Type) (k: kind) (i : positive) (v : A) (m : tree A k) {struct i} : tree A Nonempty :=
    match m with
    | Leaf =>
        match i with
        | xH => Node Leaf (Some v) Leaf (not_trivially_empty_val _ _ _)
        | xO ii => Node (set' ii v Leaf) None Leaf (not_trivially_empty_left _ _)
        | xI ii => Node Leaf None (set' ii v Leaf) (not_trivially_empty_right _ _)
        end
    | Node l o r _ =>
        match i with
        | xH => Node l (Some v) r (not_trivially_empty_val _ _ _)
        | xO ii => Node (set' ii v l) o r (not_trivially_empty_left _ _)
        | xI ii => Node l o (set' ii v r) (not_trivially_empty_right _ _)
        end
    end.

Definition set (A: Type) (i: positive) (v: A) (m: t A) : t A :=
  match m with existT _ _ m => existT _ Nonempty (set' i v m) end.

(** This is the smart constructor [Node'] that combines any two subtrees
    and optional value into a well-formed value of type [t A]. *)

Definition Node' (A: Type) (kl kr: kind) (l: tree A kl) (o: option A) (r: tree A kr) : t A :=
  match o with
  | Some v as o' => existT _ Nonempty (Node l o' r (not_trivially_empty_val _ _ _))
  | None =>
      match l with
      | Node _ _ _ _ as l' =>
          existT _ Nonempty (Node l' None r (not_trivially_empty_left _ _))
      | Leaf =>
          match r with
          | Node _ _ _ _ as r' =>
              existT _ Nonempty (Node Leaf None r' (not_trivially_empty_right _ _))
          | Leaf =>
              existT _ Empty Leaf
          end
      end
  end.

(** Sometimes, one of the subtrees has type [t A] instead of [tree A k]. *)

Definition Node'l (A: Type) kr (l: t A) (o: option A) (r: tree A kr) : t A :=
  match l with existT _ _ ll => Node' ll o r end.

Definition Node'r (A: Type) kl (l: tree A kl) (o: option A) (r: t A) : t A :=
  match r with existT _ _ rr => Node' l o rr end.

(** The [remove] function makes good use of these smart constructors. *)

Fixpoint remove' (A : Type) (k: kind) (i : positive) (m : tree A k) {struct i} : t A :=
  match i with
  | xH =>
      match m with
      | Leaf => empty A
      | Node l o r _ => Node' l None r
      end
  | xO ii =>
      match m with
      | Leaf => empty A
      | Node l o r _ => Node'l (remove' ii l) o r
      end
  | xI ii =>
      match m with
      | Leaf => empty A
      | Node l o r _ => Node'r l o (remove' ii r)
      end
end.

Definition remove (A : Type) (i : positive) (m : t A) : t A :=
  match m with existT _ _ m => remove' i m end.

(** ** Good variable properties for the basic operations *)

Lemma gleaf:
  forall (A : Type) (i : positive), get' i (Leaf : tree A Empty) = None.
Proof. destruct i; auto. Qed.

Theorem gempty:
  forall (A: Type) (i: positive), get i (empty A) = None.
Proof. intros. apply gleaf. Qed.

Lemma gss':
  forall (A: Type) (i: positive) (x: A)  (k: kind) (m: tree A k),
  get' i (set' i x m) = Some x.
Proof.
  induction i; destruct m; simpl; auto.
Qed.

Theorem gss:
  forall (A: Type) (i: positive) (x: A) (m: t A), get i (set i x m) = Some x.
Proof.
  intros. destruct m as [k m]; simpl. apply gss'.
Qed.

Lemma gso':
  forall (A: Type) (i j: positive) (x: A) k (m: tree A k),
  i <> j -> get' i (set' j x m) = get' i m.
Proof.
  induction i; intros; destruct j; destruct m; simpl;
  try rewrite <- (gleaf A i); auto; try apply IHi; congruence.
Qed.

Theorem gso:
  forall (A: Type) (i j: positive) (x: A) (m: t A),
  i <> j -> get i (set j x m) = get i m.
Proof.
  intros. destruct m as [k m]; simpl. apply gso'; auto.
Qed.

Lemma gnode':
  forall (A: Type) kl (l: tree A kl) kr (r: tree A kr) o i,
  get i (Node' l o r) =
  match i with xH => o | xO i => get' i l | xI i => get' i r end.
Proof.
  intros. unfold Node'.
  destruct o; [ | destruct l; [ destruct r | ]];
  destruct i; simpl; rewrite ? gleaf; auto.
Qed.

Lemma gnode'l:
  forall (A: Type) (l: t A) kr (r: tree A kr) o i,
  get i (Node'l l o r) =
  match i with xH => o | xO i => get i l | xI i => get' i r end.
Proof.
  intros. destruct l as [kl l]; simpl. apply gnode'.
Qed.

Lemma gnode'r:
  forall (A: Type) kl (l: tree A kl) (r: t A) o i,
  get i (Node'r l o r) =
  match i with xH => o | xO i => get' i l | xI i => get i r end.
Proof.
  intros. destruct r as [kr r]; simpl. apply gnode'.
Qed.

Lemma grs':
  forall (A: Type) (i: positive) k (m: tree A k), get i (remove' i m) = None.
Proof.
Local Opaque Node'.
  induction i; destruct m; simpl remove'; auto; rewrite ?gleaf, ?gnode', ?gnode'l, ?gnode'r; auto.
Qed.

Theorem grs:
  forall (A: Type) (i: positive) (m: t A), get i (remove i m) = None.
Proof.
  intros. destruct m as [k m]. apply grs'.
Qed.

Lemma gro':
  forall (A: Type) (i j: positive) k (m: tree A k),
  i <> j -> get i (remove' j m) = get' i m.
Proof.
  induction i; intros; destruct j; destruct m; simpl remove';
  rewrite ?gnode', ?gnode'l, ?gnode'r, ?gleaf; auto; simpl.
  apply IHi; congruence.
  apply IHi; congruence.
  congruence.
Qed.

Theorem gro:
  forall (A: Type) (i j: positive) (m: t A),
  i <> j -> get i (remove j m) = get i m.
Proof.
  intros. destruct m as [k m]. apply gro'; auto.
Qed.

(** ** The extensionality property *)

(** This is the key lemma to show extensionality: a value of type [tree A k]
    that contains no data (all [get'] queries return [None])
    is equal to [Leaf], and moreover its kind [k] is [Empty]. *)

Lemma extensionality_empty:
  forall (A: Type) k (m: tree A k),
    (forall i, get' i m = None) ->
    exists E: k = Empty, eq_rect _ _ m _ E = Leaf.
Proof.
  induction m; intros G.
- exists refl_equal; auto.
- destruct IHm1 as (E1 & F1). { intros; apply (G (xO i)). }
  destruct IHm2 as (E2 & F2). { intros; apply (G (xI i)). }
  assert (o = None). { apply (G xH). }
  subst kl kr o. elim n.
Qed.

(** As in the [Sigma] implementation, we also need the "uniqueness of
    proofs" property for the [not_trivially_empty] predicate.  We
    could assume the proof irrelevance axiom and get it for free, but
    it's not hard to show the property without using axioms. *)

Lemma not_trivially_empty_unique_proofs:
  forall A kl (o: option A) kr (p1 p2: not_trivially_empty kl o kr),
  p1 = p2.
Proof.
  unfold not_trivially_empty; intros.
  destruct kl, o, kr, p1, p2; auto.
Qed.

(** It follows that two trees that are equivalent (all [get'] queries agree)
    have the same kind and are equal.  The subtle point here is that the
    two trees cannot be assumed to have the same kind, otherwise the
    induction does not go through.  *)

Lemma extensionality_rec:
  forall (A: Type) k1 (m1: tree A k1) k2 (m2: tree A k2),
    (forall i, get' i m1 = get' i m2) ->
    exists E: k1 = k2, eq_rect _ _ m1 _ E = m2.
Proof.
  induction m1 as [ | kl1 kr1 l1 LREC o1 r1 RREC NT1].
  - intros. destruct (extensionality_empty m2) as (E1 & E2).
    { intros. rewrite <- H. apply gleaf. }
    subst k2. simpl in E2. subst m2. exists refl_equal; auto.
  - destruct m2 as [ | kl2 kr2 l2 o2 r2 NT2]; intros SAME.
    + apply extensionality_empty.
      intros. rewrite SAME. apply gleaf.
    + destruct (LREC kl2 l2) as (EL & FL).  { intros. apply (SAME (xO i)). }
      destruct (RREC kr2 r2) as (ER & FR).  { intros. apply (SAME (xI i)). }
      assert (o1 = o2). { apply (SAME xH). }
      subst kl2 kr2. simpl in FL. simpl in FR. subst l2 o2 r2.
      assert (NT1 = NT2). { apply not_trivially_empty_unique_proofs. }
      subst NT2.
      exists refl_equal; auto.
  Qed.

Theorem extensionality:
  forall (A: Type) (m1: t A) (m2: t A),
  (forall i, get i m1 = get i m2) ->
  m1 = m2.
Proof.
  intros. destruct m1 as [k1 m1], m2 as [k2 m2]; simpl in *.
  destruct (extensionality_rec m1 m2) as (E1 & E2). auto.
  subst k2. simpl in E2. subst m2. auto.
Qed.

End PTree.


Require Import
  Coq.Lists.List
  Coq.Strings.String
  CPPSynth.SExpression
  CPPSynth.StringUtil.

Module name.
  Definition t := String.string.

  Definition to_string (name : t) : String.string :=
    name.

  Definition eqb (x y : t) : bool :=
    String.eqb x y.

  Definition eq_dec : forall (x y : t), { x = y } + { x <> y }.
    intros x y ; case_eq (eqb x y) ; intros H.
      apply eqb_eq in H ; left ; auto.
      apply eqb_neq in H ; right ; auto.
  Defined.

  Definition from_sexpr_literal (e : sexpr.t) : option String.string :=
    match e with
      | sexpr.terminal arg => Some arg
      | _ => None
    end.

  (** Given an s-expression of form ("Name", x) with x being a terminal
  symbol, returns x. *)
  Definition from_sexpr (e : sexpr.t) : option String.string :=
    match e with
      | sexpr.expr "Name" (sexpr.list_cons e' sexpr.list_nil) => from_sexpr_literal e'
      | _ => None
    end.

  Definition uniquify (name : t) (l : list t) : t :=
    let n := StringUtil.unique_nat_suffix name 0 l in
    (name ++ StringUtil.make_underscores n) % string.

  Lemma uniquify_spec :
      forall name l,
      ~ In (uniquify name l) l.
    unfold uniquify ; intros ; apply StringUtil.unique_nat_suffix_spec with (k := 0) ; auto.
  Qed.

  (* generate a renaming function that remaps every name in "names" to
  a new name if it would otherwise collide with "taboo" *)
  Fixpoint make_rename_fn (names : list t) (taboo : list t) : (t -> t) :=
    match names with
      | nil => @id t
      | n :: names' =>
        let new_n :=
          if In_dec eq_dec n taboo
          then uniquify n taboo
          else n in
        let fn := make_rename_fn names' (new_n :: taboo) in
        (fun (x : t) => if eqb x n then new_n else fn x)
    end.

End name.


Require Import POCS.

Require Import TwoDiskAPI.
Require Import Common.OneDiskAPI.

(**
ReplicatedDisk provides a single-disk API on top of two disks, handling disk
failures with replication.

Your job will be to implement the core of the recovery procedure for the
replicated disk, and prove that the entire implementation is correct using your
recovery procedure. This lab is split into several parts. Unlike in previous
labs, the exercises do not proceed in order in the file; you'll first write
specifications and admit the correctness proof, and then you'll come back and
finish the proof.
*)

(** Stolen Ltac helpers. **)
Ltac destruct_all :=
  repeat match goal with
         | _ => solve [ auto ]
         | [ i: diskId |- _ ] => destruct i
         | [ |- context[match ?s with
                       | BothDisks _ _ => _
                       | OnlyDisk0 _ => _
                       | OnlyDisk1 _ => _
                       end] ] => destruct s
         | _ => simpl in *
         end.

Ltac inv_step :=
  match goal with
  | [ H: op_step _ _ _ _ |- _ ] =>
    inversion H; subst; clear H;
    repeat sigT_eq;
    safe_intuition
  end.

Ltac inv_bg :=
  match goal with
  | [ H: bg_failure _ _ |- _ ] =>
    inversion H; subst; clear H
  end.

Theorem maybe_holds_stable : forall state state' F0 F1,
    disk0 state ?|= F0 ->
    disk1 state ?|= F1 ->
    bg_failure state state' ->
    disk0 state' ?|= F0 /\
    disk1 state' ?|= F1.
Proof.
  intros.
  inv_bg; simpl in *; eauto.
Qed.

Ltac cleanup :=
  repeat match goal with
         | [ |- forall _, _ ] => intros
         | |- _ /\ _ => split; [ solve [ eauto || congruence ] | ]
         | |- _ /\ _ => split; [ | solve [ eauto || congruence ] ]
         | [ H: Working _ = Working _ |- _ ] => inversion H; subst; clear H
         | [ H: bg_failure _ _ |- _ ] =>
           eapply maybe_holds_stable in H;
           [ | solve [ eauto ] | solve [ eauto ] ]; destruct_ands
         | [ H: _ ?|= eq _, H': _ = Some _ |- _ ] =>
           pose proof (holds_some_inv_eq _ H' H); clear H
         | [ H: ?A * ?B |- _ ] => destruct H
         | [ H: DiskResult _ |- _ ] => destruct H
         | _ => deex
         | _ => destruct_tuple
         | _ => progress unfold pre_step in *
         | _ => progress autounfold in *
         | _ => progress simpl in *
         | _ => progress subst
         | _ => progress safe_intuition
         | _ => solve [ eauto ]
         | _ => congruence
         | _ => inv_step
         | H: context[match ?expr with _ => _ end] |- _ =>
           destruct expr eqn:?; [ | solve [ repeat cleanup ] ]
         | H: context[match ?expr with _ => _ end] |- _ =>
           destruct expr eqn:?; [ solve [ repeat cleanup ] | ]
         end.

Ltac prim :=
  intros;
  eapply proc_spec_weaken; [ eauto | unfold spec_impl ]; exists tt;
  intuition eauto; cleanup;
  intuition eauto; cleanup.

Module ReplicatedDisk (td : TwoDiskAPI) <: OneDiskAPI.

  (* EXERCISE (4a): implement read (DONE) *)
  Definition read (a:addr) : proc block :=
    r1 <- td.read d0 a;
    match r1 with
    | Working v => Ret v
    | Failed => (
        r2 <- td.read d1 a;
          match r2 with
          | Working v => Ret v
          | Failed => Ret block0 (* impossible *)
          end
      )
    end.

  Definition write (a:addr) (b:block) : proc unit :=
    _ <- td.write d0 a b;
    _ <- td.write d1 a b;
    Ret tt.

  Definition size : proc nat :=
    msz <- td.size d0;
    match msz with
    | Working sz => Ret sz
    | Failed =>
      msz <- td.size d1;
      match msz with
      | Working sz => Ret sz
      | Failed => Ret 0
      end
    end.

  (** [sizeInit] computes the size during initialization; it may return None if
  the sizes of the underlying disks differ. *)
  Definition sizeInit : proc (option nat) :=
    sz1 <- td.size d0;
    sz2 <- td.size d1;
    match sz1 with
    | Working sz1 =>
      match sz2 with
      | Working sz2 =>
        if sz1 == sz2 then Ret (Some sz1) else Ret None
      | Failed => Ret (Some sz1)
      end
    | Failed =>
      match sz2 with
      | Working sz2 => Ret (Some sz2)
      | Failed => Ret None
      end
    end.

  (* Recursively initialize block a and below. For simplicity, we make the disks
  match by setting every block to [block0]. *)
  Fixpoint init_at (a:nat) : proc unit :=
    match a with
    | 0 => Ret tt
    | S a =>
      _ <- td.write d0 a block0;
      _ <- td.write d1 a block0;
      init_at a
    end.

  (* Initialize every disk block *)
  Definition init' : proc InitResult :=
    size <- sizeInit;
    match size with
    | Some sz =>
      _ <- init_at sz;
      Ret Initialized
    | None =>
      Ret InitFailed
    end.

  Definition init := then_init td.init init'.

  (**
   * Helper theorems and tactics for proofs.
   *)

  Theorem exists_tuple2 : forall A B (P: A * B -> Prop),
      (exists a b, P (a, b)) ->
      (exists p, P p).
  Proof.
    intros.
    repeat deex; eauto.
  Qed.

  (* The [simplify] tactic performs a number of steps that should simplify and
  clean up your goals. *)
  Ltac simplify :=
    repeat match goal with
           | |- forall _, _ => intros
           | _ => deex
           | _ => destruct_tuple
           | [ u: unit |- _ ] => destruct u
           | |- _ /\ _ => split; [ solve [auto] | ]
           | |- _ /\ _ => split; [ | solve [auto] ]
           | |- exists (_: disk*_), _ => apply exists_tuple2
           | _ => progress simpl in *
           | _ => progress safe_intuition
           | _ => progress subst
           | _ => progress autorewrite with upd in *
           end.

  (* The [finish] tactic tries a number of techniques to solve the goal. *)
  Ltac finish :=
    repeat match goal with
           | _ => solve_false
           | _ => congruence
           | _ => solve [ intuition ]
           | _ =>
             (* if we can solve all the side conditions automatically, then it's
             safe to run descend and create existential variables *)
             descend; (intuition eauto);
             lazymatch goal with
             | |- proc_spec _ _ _ _ => idtac
             | _ => fail
             end
           end.

  Ltac step :=
    step_proc; simplify; finish.

  (**
   * Specifications and proofs about our implementation of the replicated disk API,
   * without considering our recovery.
   *
   * These intermediate specifications separate reasoning about the
   * implementations from recovery behavior.
   *)

  Theorem both_disks_not_missing : forall (state: TwoDiskBaseAPI.State),
      two_disks_are state missing missing ->
      False.
  Proof.
    unfold two_disks_are.
    destruct state; unfold missing; simpl; intuition auto.
  Qed.

  Hint Resolve both_disks_not_missing : false.

  Theorem missing0_implies_any : forall (state: TwoDiskBaseAPI.State) P F,
      two_disks_are state missing F ->
      two_disks_are state P F.
  Proof.
    unfold two_disks_are.
    destruct state; unfold missing; simpl; intuition auto.
  Qed.

  Theorem missing1_implies_any : forall (state: TwoDiskBaseAPI.State) P F,
      two_disks_are state F missing ->
      two_disks_are state F P.
  Proof.
    unfold two_disks_are.
    destruct state; unfold missing; simpl; intuition auto.
  Qed.

  Hint Resolve missing0_implies_any : core.
  Hint Resolve missing1_implies_any : core.

  (* EXERCISE (4a): prove this specification for read (DONE) *)
  Theorem read_int_ok : forall a,
      proc_spec
        (fun d state =>
           {|
             pre := two_disks_are state (eq d) (eq d);
             post :=
               fun r state' =>
                 two_disks_are state' (eq d) (eq d) /\
                 diskGet d a =?= r;
             recovered :=
               fun _ state' =>
                 two_disks_are state' (eq d) (eq d);
           |})
        (read a)
        td.recover
        td.abstr.
  Proof.
    unfold read.
    step.
    repeat (destruct r; step).
  Qed.

  Hint Resolve read_int_ok : core.

  (* EXERCISE (4a): complete and prove this specification for write (DONE) *)
  Theorem write_int_ok : forall a b,
      proc_spec
        (fun d state =>
           {|
             pre := two_disks_are state (eq d) (eq d);
             post :=
               fun r state' =>
                 r = tt /\
                 two_disks_are state' (eq (diskUpd d a b)) (eq (diskUpd d a b));
             recovered :=
               fun _ state' =>
                 (* EXERCISE (4a): write the recovered condition for write. Note
                 that this is the two-disk API's recovery, not the replicated
                 disk's recovery, so it should cover all the crash cases for
                 write *)
                 two_disks_are state' (eq d) (eq d) \/
                 two_disks_are state' (eq (diskUpd d a b)) (eq d) \/
                 two_disks_are state' (eq (diskUpd d a b)) (eq (diskUpd d a b))
             ;
           |})
        (write a b)
        td.recover
        td.abstr.
  Proof.
    unfold write.
    step.
    repeat (destruct r; step).
  Qed.

  Hint Resolve write_int_ok : core.

  (* EXERCISE (4a): prove this specification for size (DONE) *)
  Theorem size_int_ok :
    proc_spec
      (fun '(d_0, d_1) state =>
         {|
           pre := two_disks_are state (eq d_0) (eq d_1) /\
             diskSize d_0 = diskSize d_1;
           post :=
             fun r state' =>
               r = diskSize d_0 /\
               r = diskSize d_1 /\
               two_disks_are state' (eq d_0) (eq d_1);
           recovered :=
             fun _ state' =>
               two_disks_are state' (eq d_0) (eq d_1);
         |})
      (size)
      td.recover
      td.abstr.
  Proof.
    unfold size.
    step.
    repeat (destruct r; step).
  Qed.

  Hint Resolve size_int_ok : core.

  (* We provide a proof for [init]. *)

  Definition equal_after a (d_0 d_1: disk) :=
    diskSize d_0 = diskSize d_1 /\
    forall a', a <= a' -> diskGet d_0 a' = diskGet d_1 a'.

  Theorem le_eq_or_S_le : forall n m,
      n <= m ->
      n = m \/
      S n <= m /\ n <> m.
  Proof.
    intros.
    lia.
  Qed.

  Theorem equal_after_diskUpd : forall a d_0 d_1 b,
      equal_after (S a) d_0 d_1 ->
      equal_after a (diskUpd d_0 a b) (diskUpd d_1 a b).
  Proof.
    unfold equal_after; intuition.
    - autorewrite with upd; eauto.
    - apply le_eq_or_S_le in H1; intuition subst.
      { destruct (lt_dec a' (diskSize d_0)); autorewrite with upd.
        + assert (a' < diskSize d_1) by congruence; autorewrite with upd; auto.
        + assert (~a' < diskSize d_1) by congruence; autorewrite with upd; auto.
      }
      autorewrite with upd; eauto.
  Qed.

  Hint Resolve equal_after_diskUpd : core.

  Theorem init_at_ok : forall a,
      proc_spec
        (fun '(d_0, d_1) state =>
           {| pre :=
                two_disks_are state (eq d_0) (eq d_1) /\
                equal_after a d_0 d_1;
              post :=
                fun _ state' =>
                  exists d_0' d_1': disk,
                    two_disks_are state' (eq d_0') (eq d_1') /\
                    equal_after 0 d_0' d_1';
              recovered :=
                fun _ state' => True;
           |})
        (init_at a)
        td.recover
        td.abstr.
  Proof.
    induction a; simpl; intros.
    - step.
    - step.
      step.
      destruct r; finish.
      + step.
        destruct r; simplify; finish.
      + step.
        destruct r; simplify.
        * exists (diskUpd d_0 a block0).
          exists (diskUpd d_1 a block0).
          finish.
        * finish.
  Qed.

  Hint Resolve init_at_ok : core.

  Theorem sizeInit_ok :
    proc_spec
      (fun '(d_0, d_1) state =>
         {| pre :=
              two_disks_are state (eq d_0) (eq d_1);
            post :=
              fun r state' =>
                exists d_0' d_1',
                  two_disks_are state' (eq d_0') (eq d_1') /\
                  match r with
                  | Some sz => diskSize d_0' = sz /\ diskSize d_1' = sz
                  | None => True
                  end;
            recovered :=
              fun _ state' => True;
         |})
      (sizeInit)
      td.recover
      td.abstr.
  Proof.
    unfold sizeInit.
    step.
    destruct r.
    - step.
      destruct r.
      + destruct (diskSize d_0 == v).
        * step.
        * step.
      + step.
    - step.
      destruct r.
      + step.
      + step.
  Qed.

  Hint Resolve sizeInit_ok : core.

  Theorem equal_after_0_to_eq : forall d_0 d_1,
      equal_after 0 d_0 d_1 ->
      d_0 = d_1.
  Proof.
    unfold equal_after; intuition.
    eapply disk_ext_eq; intros.
    eapply H0; lia.
  Qed.

  Theorem equal_after_size : forall d_0 d_1,
      diskSize d_0 = diskSize d_1 ->
      equal_after (diskSize d_0) d_0 d_1.
  Proof.
    unfold equal_after; intuition.
    assert (~a' < diskSize d_0) by lia.
    assert (~a' < diskSize d_1) by congruence.
    autorewrite with upd; eauto.
  Qed.

  Hint Resolve equal_after_size : core.
  Hint Resolve equal_after_0_to_eq : core.

  Theorem init'_ok :
    proc_spec
      (fun '(d_0, d_1) state =>
         {| pre :=
              two_disks_are state (eq d_0) (eq d_1);
            post :=
              fun r state' =>
                match r with
                | Initialized =>
                  exists d_0' d_1',
                  two_disks_are state' (eq d_0') (eq d_1') /\
                  d_0' = d_1'
                | InitFailed =>
                  True
                end;
            recovered :=
              fun _ state' => True;
         |})
      (init')
      td.recover
      td.abstr.
  Proof.
    unfold init'.
    step.
    destruct r; step.
    step.
  Qed.

  Hint Resolve init'_ok : core.

  (**
   * Recovery implementation.
   *
   * We provide the general structure for recovery: essentially, it consists of
   * a loop around [fixup] that terminates after either fixing an out-of-sync
   * disk block or when a disk has failed.
  *)

  (* [fixup] returns a [RecStatus] to implement early termination in [recovery_at]. *)
  Inductive RecStatus :=
  (* continue working, nothing interesting has happened *)
  | Continue
  (* some address has been repaired (or the recovery has exhausted the
     addresses) - only one address can be out of sync and thus only it must be
     recovered. *)
  (* OR, one of the disks has failed, so don't bother continuing recovery since
     the invariant is now trivially satisfied *)
  | RepairDoneOrFailed.

  (* EXERCISE (4c): implement [fixup], which should perform recovery for a
  single address and indicate whether to continue or not. (DONE) *)
  Definition fixup (a:addr) : proc RecStatus :=
    r0 <- td.read d0 a;
    match r0 with
      | Failed => Ret RepairDoneOrFailed
      | Working r0 =>
        _ <- td.write d1 a r0;
          Ret Continue
    end.

  (* recursively performs recovery at [a-1], [a-2], down to 0 *)
  Fixpoint recover_at (a:addr) : proc unit :=
    match a with
    | 0 => Ret tt
    | S n =>
      vv <- fixup n;
      match vv with
      | Continue => recover_at n
      | RepairDoneOrFailed => Ret tt
      end
    end.

  Definition Recover : proc unit :=
    sz <- size;
    _ <- recover_at sz;
    Ret tt.

  (**
   * Theorems and recovery proofs.
   *)

  Theorem if_lt_dec : forall A n m (a a':A),
      n < m ->
      (if lt_dec n m then a else a') = a.
  Proof.
    intros.
    destruct (lt_dec n m); auto.
  Qed.

  Theorem disks_eq_inbounds : forall (d: disk) a v v',
      a < diskSize d ->
      diskGet d a =?= v ->
      diskGet d a =?= v' ->
      v = v'.
  Proof.
    intros.
    case_eq (diskGet d a); intros.
    - rewrite H2 in *. simpl in *. congruence.
    - exfalso.
      eapply disk_inbounds_not_none; eauto.
  Qed.

  (* To make these specifications precise while also covering both the already
   * synced and diverged disks cases, we keep track of which input state we're
   * in from the input and use it to give an exact postcondition. *)
  Inductive DiskStatus :=
  | FullySynced
  | OutOfSync (a:addr) (b:block).

  Theorem diskUpd_maybe_same : forall (d:disk) a b,
      diskGet d a =?= b ->
      diskUpd d a b = d.
  Proof.
    intros.
    destruct (diskGet d a) eqn:?; simpl in *; subst;
      autorewrite with upd;
      auto.
  Qed.

  Hint Rewrite diskUpd_maybe_same using (solve [ auto ]) : upd.
  Hint Resolve PeanoNat.Nat.lt_neq : core.
  Hint Resolve disks_eq_inbounds : core.

  Theorem diskUpd_noop : forall d a b,
      diskGet d a ?|= eq b ->
      diskUpd d a b = d.
  Proof.
    intros.
    destruct (diskGet d a) as [b' |] eqn:Heq.
    - simpl in H. rewrite H in *.
      rewrite diskUpd_same by assumption.
      trivial.
    - apply disk_none_oob in Heq. rewrite diskUpd_oob_noop by assumption.
      trivial.
  Qed.

  (* EXERCISE (4c): write and admit a specification for [fixup]. (DONE) *)
  Theorem fixup_ok : forall a,
      proc_spec
        ((fun '(d, s) state =>
           {|
             pre :=
               a < diskSize d /\
               match s with
               | FullySynced => two_disks_are state (eq d) (eq d)
               | OutOfSync a' b => two_disks_are state (eq (diskUpd d a' b)) (eq d)
               end;
             post :=
               fun r state' =>
                 match r with
                 | RepairDoneOrFailed => two_disks_are state' missing (eq d)
                 | Continue =>
                   match s with
                   | FullySynced =>
                     two_disks_are state' (eq d) (eq d)
                   | OutOfSync a' b =>
                     if a == a' then
                       (two_disks_are state' (eq (diskUpd d a' b)) (eq (diskUpd d a' b)))
                     else
                       two_disks_are state' (eq (diskUpd d a' b)) (eq d)
                   end
                 end;
             recovered :=
               fun _ state' =>
                 match s with
                 | FullySynced => two_disks_are state' (eq d) (eq d)
                 | OutOfSync a' b =>
                   if a == a' then
                     (two_disks_are state' (eq (diskUpd d a' b)) (eq (diskUpd d a' b))) \/
                     two_disks_are state' (eq (diskUpd d a' b)) (eq d)
                   else
                     two_disks_are state' (eq (diskUpd d a' b)) (eq d)
                 end;
           |}) : (prod disk DiskStatus) -> _ -> _)
        (fixup a)
        td.recover
        td.abstr.
  Proof.
    (* EXERCISE (4d): prove [fixup_ok] (DONE) *)
    intros.
    step.
    destruct s.
    {
      (* Fully synced. *)
      exists d, (eq d).
      intuition.
      destruct r as [r|]; step.
      exists d, (eq d).
      intuition.
      { rewrite diskUpd_noop in H3 by assumption. assumption. }
      step; destruct r0; simplify.
    }
    {
      (* Not synced. *)
      exists (diskUpd d a0 b), (eq d).
      intuition.
      - destruct (equal_dec a a0); intuition.
      - destruct r as [r|]; step.
        + exists d, (eq (diskUpd d a0 b)); destruct (a == a0); intuition.
          * rewrite diskUpd_eq in H2 by lia. simpl in H2.
            rewrite <- H2 in *. simplify.
          * step; destruct r0 as [r0|]; try destruct (r == r0); simplify.
          * assert (diskUpd d a r = d).
            { simplify. }
            rewrite H5 in H3.
            assumption.
          * step; destruct r0 as [r0|]; try destruct (r == r0);
              try replace (diskUpd d a r) with d in H3 by simplify;
              finish.
        + destruct (equal_dec a a0); intuition.
    }
  Qed.

  Hint Resolve fixup_ok : core.

  Hint Resolve Lt.lt_n_Sm_le : core.

  Definition DEBUG_POST_CONDITION := True.
  Definition DEBUG_RECOVER_CONDITION := True.

  (* EXERCISE (4c): specify and prove recover_at *)
  (* Hint: use [induction a] *)

  (* recover_at recursively performs recovery at [a-1], [a-2], down to 0 *)

  (* recover goes down; the base case is the bottom of the disk.
     we need to show that, if the borked block was below the current iteration,
     it has been stamped out.
   *)
  Theorem recover_at_ok : forall a,
      proc_spec
        (fun '(d, s) state =>
           {|
             pre :=
               a <= diskSize d /\
               match s with
               | FullySynced => two_disks_are state (eq d) (eq d)
               | OutOfSync a' b => two_disks_are state (eq (diskUpd d a' b)) (eq d) /\ a' < a
               end;
             post :=
               fun _ state' =>
                 DEBUG_POST_CONDITION /\
                 match s with
                 | FullySynced => two_disks_are state' (eq d) (eq d)
                 | OutOfSync a' b => two_disks_are state'
                                                  (eq (diskUpd d a' b))
                                                  (eq (diskUpd d a' b)) \/
                                    two_disks_are state'
                                                  (missing)
                                                  (eq d)
                 end;
             recovered :=
               fun _ state' =>
                 DEBUG_RECOVER_CONDITION /\
                 match s with
                 | FullySynced => two_disks_are state' (eq d) (eq d)
                 | OutOfSync a' b => two_disks_are state'
                                                  (eq (diskUpd d a' b))
                                                  (eq d) \/
                                    two_disks_are state'
                                                  (eq (diskUpd d a' b))
                                                  (eq (diskUpd d a' b)) \/
                                    two_disks_are state'
                                                  (missing)
                                                  (eq d)
                 end;
           |})
        (recover_at a)
        td.recover
        td.abstr.
  Proof.
    induction a; unfold recover_at.

    {
      (* base case: straightforward *)
      unfold DEBUG_RECOVER_CONDITION in *; unfold DEBUG_POST_CONDITION in *.
      step; destruct s; intuition; lia.
    }

    (* inductive case. *)

    (* call fixup. *)
    step.

    (* check the ghost variables. *)
    destruct s.
    {
      (* We're fully synced. Everything is straightforward. *)
      exists d, FullySynced.
      unfold DEBUG_RECOVER_CONDITION in *; unfold DEBUG_POST_CONDITION in *.
      intuition; simplify.
      destruct r; step.
      exists d, FullySynced.
      intuition; simplify.
    }
    {
      (* We're out of sync! *)
      intuition.

      exists d, (OutOfSync a0 b).
      intuition; unfold DEBUG_RECOVER_CONDITION; try trivial.
      {
        (* fixup's recovery condition -> ours *)
        destruct (equal_dec a a0); intuition.
      }

      (* What did fixup return? *)
      destruct r.
      {
        (* fixup returned Continue. *)

        (* make the recursive call to recover_at. *)
        step.

        (* this is useless now. *)
        clear IHa.

        destruct (equal_dec a a0).
        {
          (* we've just overwritten the bad block. *)
          exists (diskUpd d a0 b), FullySynced.
          intuition.
          rewrite diskUpd_size.
          lia.
        }
        {
          (* we haven't overwritten the bad block. *)
          exists d, (OutOfSync a0 b).
          intuition.
          lia.
        }
      }
      {
        (* fixup returned RepairDoneOrFailed. *)
        step; unfold DEBUG_POST_CONDITION; try trivial.
      }
    }
  Qed.

  Hint Resolve recover_at_ok : core.

  (* EXERCISE (4b): write a spec for recovery (DONE) *)
  Definition Recover_spec : Specification _ unit unit TwoDiskBaseAPI.State :=
    fun '(d, a, v) state =>
      (* note: you can just put a out of bounds
         if you don't need the write.*)
      let d' := diskUpd d a v in
      {|
        pre := two_disks_are state (eq d') (eq d') \/ two_disks_are state (eq d') (eq d);
        post := fun _ state' => two_disks_are state' (eq d') (eq d') \/ two_disks_are state' (missing) (eq d);
        recovered := fun _ state' => two_disks_are state' (eq d') (eq d') \/ two_disks_are state' (eq d') (eq d);
      |}.

  (* EXERCISE (4c): prove recovery correct *)
  Theorem Recover_rok :
    proc_spec
      Recover_spec
      (Recover)
      td.recover
      td.abstr.
  Proof.
    unfold Recover.
    unfold Recover_spec.
    step.
    intuition.
    (* this is a bit weird because I wrote the Recover spec in a different style... *)
    {
      exists (diskUpd d a v), (diskUpd d a v).
      intuition.
      step.
      exists (diskUpd d a v), FullySynced.
      intuition.
      { rewrite diskUpd_size. lia. }
      step.
    }
    {
      destruct (lt_dec a (diskSize d)).
      2: {
        (* degenerate case: the disk update is outside, so the disks
        aren't actually different. *)
        replace (diskUpd d a v) with d in *.
        2: {
          rewrite diskUpd_oob_noop by lia. trivial.
        }
        exists d, d. intuition; step.
        exists d, FullySynced. intuition;step.
      }

      exists (diskUpd d a v), d.
      intuition.
      { rewrite diskUpd_size. lia. }
      step.
      exists d, (OutOfSync a v).
      intuition.
      step.
    }
  Qed.

  (* EXERCISE (4b): prove that your recovery specification is idempotent; that
  is, its recovered condition implies its precondition. (DONE) *)
  Theorem Recover_spec_idempotent :
    idempotent Recover_spec.
  Proof.
    unfold idempotent.
    intuition; simplify.
    exists a.
    destruct a as [a b].
    destruct a as [d a].
    simpl in *.
    intuition.
  Qed.

  (* This proof combines your proof that recovery is correct and that its
  specification is idempotent to show recovery is correct even if re-run on
  every crash. *)
  Theorem Recover_ok :
    proc_loopspec
      Recover_spec
      (Recover)
      td.recover
      td.abstr.
  Proof.
    eapply idempotent_loopspec; simpl.
    - apply Recover_rok.
    - apply Recover_spec_idempotent.
  Qed.

  Hint Resolve Recover_ok : core.

  Definition recover: proc unit :=
    _ <- td.recover;
    Recover.

  (* As the final step in giving the correctness of the replicated disk
  operations, we prove recovery specs that include the replicated disk Recover
  function. *)

  Definition rd_abstraction (state: TwoDiskBaseAPI.State) (d:OneDiskAPI.State) : Prop :=
    two_disks_are state (eq d) (eq d).

  Definition abstr : Abstraction OneDiskAPI.State :=
    abstraction_compose td.abstr {| abstraction := rd_abstraction; |}.

  Theorem init_ok : init_abstraction init recover abstr inited_any.
  Proof.
    intros.
    eapply then_init_compose; eauto.
    eapply proc_spec_weaken; eauto.
    unfold spec_impl; intros.
    destruct state; simpl in *.

    - exists (d_0, d_1); simpl; intuition.
      { unfold two_disks_are; simpl; intuition. }
      unfold rd_abstraction.
      destruct v; simplify; finish.
    - exists (d_0, d_0); simplify; intuition.
      { unfold two_disks_are; simpl; intuition. }
      unfold rd_abstraction.
      destruct v; simplify; finish.
    - exists (d_1, d_1); simplify; finish; intuition.
      { unfold two_disks_are; simpl; intuition. }
      unfold rd_abstraction.
      destruct v; simplify; finish.
  Qed.

  (* EXERCISE (4b): prove that read, write, and size are correct when combined
  with your recovery (using your specification but admitted proof). (DONE) *)

  Definition recover_ghost_noop (state : disk) :=
    (state, diskSize state, block0).

  Ltac exists_recover_ghost_noop state :=
      exists (recover_ghost_noop state);
      simpl;
      rewrite diskUpd_oob_noop by lia.

  Theorem read_ok : forall a, proc_spec (read_spec a) (read a) recover abstr.
  Proof.
    intros.
    apply spec_abstraction_compose; simpl.
    eapply compose_recovery; eauto; simplify.
    unfold rd_abstraction in H0.
    exists state2.
    simplify.
    split.
    {
      intros.
      exists state2.
      simplify.
    }
    {
      intros.
      exists_recover_ghost_noop state2.
      intuition.
      {
        exists state2. intuition.
      }
      {
        exists state2.
        unfold rd_abstraction.
        intuition.
      }
    }
  Qed.

  Theorem write_ok : forall a v, proc_spec (write_spec a v) (write a v) recover abstr.
  Proof.
    intros.
    apply spec_abstraction_compose; simpl.
    eapply compose_recovery; eauto; simplify.
    unfold rd_abstraction in *.
    intuition.
    exists state2. intuition.
    (* post *)
    { exists (diskUpd state2 a v). intuition. }
    (* recovery: no write *)
    { exists_recover_ghost_noop state2. intuition; exists state2; intuition. }
    all: (exists (state2, a, v); simpl; intuition; [
              exists (diskUpd state2 a v); intuition |
                exists state2; intuition
         ]).
  Qed.

  Theorem size_ok : proc_spec size_spec size recover abstr.
  Proof.
    intros.
    apply spec_abstraction_compose; simpl.
    (* simplify is a bit too aggressive about existential variables here, so we
    provide some manual simplification here *)
    eapply compose_recovery; eauto.
    intros; apply exists_tuple2.
    destruct a; simpl in *.
    exists s. exists s.
    unfold rd_abstraction in H.
    intuition.
    - exists s. intuition.
    - exists_recover_ghost_noop s. intuition.
      + exists s. intuition.
      + exists s. intuition. unfold rd_abstraction. finish.
  Qed.

  (* This theorem shows that Ret does not modify the abstract state exposed by
  the replicated disk; the interesting part is that if recovery runs, then the
  only effect should be the wipe relation (the trivial relation [no_wipe] in
  this case) *)
  (* EXERCISE (4b): prove this theorem using your recovery spec (DONE) *)
  Theorem recover_wipe : rec_wipe recover abstr no_wipe.
  Proof.
    eapply rec_wipe_compose; eauto; simpl.
    autounfold; unfold rd_abstraction, Recover_spec; simplify.
    exists_recover_ghost_noop state0'.
    intuition; exists state0'; intuition.
  Qed.

End ReplicatedDisk.


Require Import Morphisms Setoid Coq.Vectors.Fin.
Require Import Utf8.

Add LoadPath "../../theories" as CatQ.
From CatQ.Structures Require Import Structures.
Require Import CatQ.Categories.Concrete.

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

Set Universe Polymorphism.

Program Definition const {C D : Category} (a : C) : Functor D C :=
  [fmap: fun _ _ _ => identity with fun _ => a ].
Next Obligation.
  unfold Proper, respectful.
  intros.
  reflexivity.
Defined.
Next Obligation.
  reflexivity.
Defined.
Next Obligation.
  rewrite left_id_of.
  reflexivity.
Defined.

Definition const_one {C : Category} (a : C) : Functor One C := const a.

Notation "Δ[ D ]( a )" := (@const _ D a).
Notation "Δ( a )" := (const_one a).

Program Definition One_lift {D} {F G : Functor One D} (h : F tt ⟶ G tt in D) : Nat F G
  := [Nat: fun t => match t with
                   | tt => h
                   end ].
Next Obligation.
  constructor.
  intros.
  destruct a, b.

  assert (f == identity).
  destruct f.
  reflexivity.

  rewrite H.
  rewrite fmap_identity, fmap_identity.
  rewrite right_id_of, left_id_of.
  reflexivity.
Defined.

Lemma functor_to_One_unique {C} {F : Functor C One} : F ==f Δ[C](tt : One).
Proof.
  assert (forall x, F x = tt).
  { intro; destruct (F x); exact eq_refl. }

  exists H.
  intros.
  destruct (fmap F f).
  reflexivity.
Qed.

Program Definition op_trf {C D} (F : Functor (opposite C) D) : Functor C (opposite D) :=
  [fmap: fun a b f => opposite_hom_to (fmap F (opposite_hom_to f)) with fun a => opposite_obj_to (F a) as C to opposite D].
Next Obligation.
  unfold opposite_hom_to, opposite_obj_to.
  solve_proper.
Defined.
Next Obligation.
  assert (forall a, opposite_hom_to (@identity C a) = @identity (opposite C) a).
  reflexivity.

  rewrite (H _).
  unfold opposite_hom_to.
  apply fmap_identity.
Defined.
Next Obligation.
  refine
    (`begin
      opposite_hom_to (fmap F (opposite_hom_to (g ∘{C} f)))
     =⟨ _ ⟩
      opposite_hom_to (fmap F (opposite_hom_to f ∘{opposite C} opposite_hom_to g))
     =⟨ _ ⟩
      opposite_hom_to (fmap F (opposite_hom_to f) ∘{D} fmap F (opposite_hom_to g))
     =⟨ _ ⟩
      opposite_hom_to (fmap F (opposite_hom_to g)) ∘{opposite D} opposite_hom_to (fmap F (opposite_hom_to f))
     `end).

  - apply (@is_setoid (@morphism (opposite D) _ _)).
  - unfold opposite_hom_to.
    simpl.
    apply fmap_compose.
  - apply (@is_setoid (@morphism (opposite D) _ _)).
Defined.

Program Definition opopf {C} : Functor C (opposite (opposite C)) :=
  [fmap: fun _ _ f => (opposite_hom_to (opposite_hom_to f)) with fun a => opposite_obj_to (opposite_obj_to a)].
Next Obligation.
  unfold opposite_obj_to, opposite_hom_to.
  solve_proper.
Defined.
Next Obligation.
  reflexivity.
Defined.
Next Obligation.
  reflexivity.
Defined.

Program Definition opop_invf {C} : Functor (opposite (opposite C)) C :=
  [fmap: fun _ _ f => (opposite_hom (opposite_hom f)) with fun a => opposite_obj (opposite_obj a)].
Next Obligation.
  unfold opposite_obj_to, opposite_hom_to.
  solve_proper.
Defined.
Next Obligation.
  reflexivity.
Defined.
Next Obligation.
  reflexivity.
Defined.

Definition opf {C D} (F : Functor C D) : Functor (opposite C) (opposite D) := @op_trf (opposite C) D (F ∘f opop_invf).


(** Typing rules for standard PTS.*)
Require Import ut_term.
Require Import ut_red.
Require Import ut_env.
Require Import base.
Require Import List.
Require Import Peano_dec.
Require Import Compare_dec.
Require Import Lt Le Gt Plus Minus.

Unset Standard Proposition Elimination Names.

Module ut_typ_mod (X:term_sig) (Y:pts_sig X) (TM: ut_term_mod X) (EM: ut_env_mod X TM) (RM: ut_red_mod X TM).
  Import X Y TM EM RM.

(** Typing judgements:*)
Reserved Notation "Γ ⊢ t : T" (at level 80, t, T at level 30, no associativity) .
Reserved Notation "Γ ⊣ " (at level 80, no associativity).

Inductive wf : Env -> Prop :=
 | wf_nil  : nil ⊣
 | wf_cons : forall Γ A s, Γ ⊢ A : !s -> A::Γ ⊣
where "Γ ⊣" := (wf Γ) : UT_scope
with typ : Env -> Term -> Term -> Prop :=
 | cSort : forall Γ s t, Ax s t -> Γ ⊣ -> Γ  ⊢ !s : !t
 | cVar  : forall Γ A v, Γ ⊣ -> A ↓ v  ⊂ Γ -> Γ ⊢ #v : A
 | cPi   : forall Γ A B s t u, Rel s t u -> Γ ⊢ A : !s -> A::Γ ⊢ B : !t ->
   Γ ⊢  Π(A), B : !u
 | cLa   : forall Γ A B M s1 s2 s3, Rel s1 s2 s3 -> Γ ⊢ A : !s1 ->
   A::Γ ⊢ B : !s2 -> A::Γ ⊢ M : B -> Γ ⊢ λ[A], M : Π(A), B
 | cApp  : forall Γ M N A B , Γ ⊢ M : Π(A), B -> Γ ⊢ N : A -> Γ ⊢ M · N : B[←N]
 | Cnv   : forall Γ M A B s, A ≡ B  -> Γ ⊢ M : A -> Γ ⊢ B : !s -> Γ ⊢ M : B
where "Γ ⊢ t : T" := (typ Γ t T) : UT_scope.

Hint Constructors wf typ.

Open Scope UT_scope.

(* begin hide *)
Scheme typ_ind' := Induction for typ Sort Prop
      with wf_ind' := Induction for wf Sort Prop.

Combined Scheme typ_induc from typ_ind', wf_ind'.
(* end hide *)

(** Basic properties of PTS.
  Context Validity: if a judgment is valid, its context is well-formed.*)
Lemma wf_typ : forall Γ t T, Γ ⊢ t : T -> Γ ⊣.
induction 1; eauto.
Qed.

Hint Resolve wf_typ.

(** Inversion Lemmas , one for each kind of term
  from a typing derivation of some particular term, we can
infer informations about its type and subterms.*)

Lemma gen_sort : forall Γ s T, Γ ⊢ !s : T -> exists t, T ≡ !t /\ Ax s t.
intros. remember !s as S. revert s HeqS. induction H; intros; subst; try discriminate.
injection HeqS; intros; subst; clear HeqS. exists t; intuition.
destruct (IHtyp1 s0) as (t & ? & ?); trivial. exists t; split.
eauto. trivial.
Qed.

Lemma gen_var : forall Γ x A, Γ ⊢ #x : A -> exists A', A ≡ A' /\ A' ↓ x ⊂ Γ .
intros. remember #x as X. revert x HeqX. induction H; intros; subst; try discriminate.
injection HeqX; intros; subst; clear HeqX.
exists A; intuition.
destruct (IHtyp1 x) as (A' & ? & ?); trivial. exists A'; split. eauto. trivial.
Qed.

Lemma gen_pi : forall Γ A B T, Γ ⊢ Π(A),B : T -> exists s1, exists s2, exists s3,
    T ≡ !s3 /\ Rel s1 s2 s3 /\ Γ ⊢ A : !s1  /\ A::Γ ⊢ B : !s2 .
intros. remember (Π(A),B) as P. revert A B HeqP. induction H; intros; subst; try discriminate.
clear IHtyp1 IHtyp2. injection HeqP; intros; subst; clear HeqP.
exists s; exists t; exists u; intuition.
destruct (IHtyp1 A0 B0) as (a & b & c & ? & ? & ? &  ?); trivial. exists a; exists b; exists c; split.
eauto. intuition.
Qed.

Lemma gen_la : forall Γ A M T, Γ ⊢ λ[A],M : T -> exists s1, exists s2, exists s3, exists B,
    T ≡ Π(A), B /\ Rel s1 s2 s3 /\ Γ ⊢ A : !s1 /\ A::Γ ⊢ M : B /\ A::Γ ⊢ B : !s2.
intros. remember (λ[A],M) as L. revert A M HeqL. induction H; intros ; subst; try discriminate.
clear IHtyp1 IHtyp2 IHtyp3. injection HeqL; intros; subst; clear HeqL.
exists s1; exists s2; exists s3; exists B; intuition.
destruct (IHtyp1 A0 M0) as (a & b & c & D &? &? & ? & ? & ?); trivial.
exists a; exists b; exists c; exists D; split. eauto. intuition.
Qed.

Lemma gen_app : forall Γ M N T, Γ ⊢ M · N : T -> exists A, exists B, T ≡ B[← N] /\ Γ ⊢ M : Π(A),B /\ Γ ⊢ N : A.
intros. remember (M·N) as A. revert M N HeqA. induction H; intros; subst; try discriminate.
clear IHtyp1 IHtyp2. injection HeqA; intros; subst; clear HeqA.
exists A; exists B; intuition.
destruct (IHtyp1 M0 N) as (K & L & ? & ?& ?); trivial. exists K; exists L; split.
eauto. intuition.
Qed.

(** Weakening Property: if a judgement is valid, we can insert a well-typed term
  in the context, it will remain valid. This is where the type checking for
  inserting items in a context is done.*)
Theorem weakening: (forall Δ M T, Δ ⊢ M : T -> forall Γ A s n Δ', ins_in_env Γ A n Δ Δ' ->   Γ ⊢ A : !s ->
                 Δ' ⊢ M ↑ 1 # n : T ↑ 1 # n ) /\
(forall Γ, Γ ⊣ -> forall Δ Γ' n A , ins_in_env Δ A n Γ Γ' -> forall s, Δ ⊢ A : !s -> Γ' ⊣).
apply typ_induc; simpl in *; intros.
(*1*)
eauto.
(*2*)
destruct (le_gt_dec n v).
constructor. eapply H; eauto. destruct i as (AA & ?& ?). exists AA; split. rewrite H2.
change (S (S v)) with (1+ S v). rewrite liftP3; simpl; intuition. eapply ins_item_ge. apply H0. trivial. trivial.
constructor. eapply H; eauto.  eapply ins_item_lift_lt. apply H0. trivial. trivial.
(*3*)
econstructor. apply r. eauto. eapply H0. constructor; apply H1. apply H2.
(*4*)
econstructor. apply r. eapply H; eauto. eapply H0; eauto. eapply H1; eauto.
(*5*)
change n with (0+n). rewrite substP1. simpl.
econstructor. eapply H; eauto. eapply H0; eauto.
(*6*)
apply Cnv with (A↑ 1 # n) s; intuition.
eapply H; eauto. eapply H0; eauto.
(* wf *)
inversion H; subst; clear H.
apply wf_cons with s; trivial.
(**)
inversion  H0; subst; clear H0.
apply wf_cons with s0; trivial.
apply wf_cons with s; trivial. change !s with !s ↑ 1 # n0.
eapply H.  apply H6. apply H1.
Qed.

Theorem thinning :
   forall Γ M T A s,
      Γ ⊢ M : T ->
   Γ ⊢ A : !s ->
   A::Γ ⊢ M ↑ 1 : T ↑ 1.
intros.
destruct weakening.
eapply H1. apply H. constructor. apply H0.
Qed.

Theorem thinning_n : forall n Δ Δ',
   trunc n Δ Δ' ->
   forall M T , Δ' ⊢ M : T  -> Δ ⊣ ->
               Δ ⊢ M ↑ n : T ↑ n.
intro n; induction n; intros.
inversion H; subst; clear H.
rewrite 2! lift0; trivial.
inversion H; subst; clear H.
change (S n) with (1+n).
replace (M ↑ (1+n)) with ((M ↑ n )↑ 1) by (apply lift_lift).
replace (T ↑ (1+n)) with ((T ↑ n) ↑ 1) by (apply lift_lift).
inversion H1; subst; clear H1.
apply thinning with s; trivial.
eapply IHn. apply H3. trivial. eauto.
Qed.

(** Substitution Property: if a judgment is valid and we replace a variable by a
  well-typed term of the same type, it will remain valid.*)
(* begin hide *)
Lemma sub_trunc : forall Δ a A n Γ Γ', sub_in_env Δ a A n Γ Γ' -> trunc n Γ' Δ.
induction 1.
apply trunc_O.
apply trunc_S. trivial.
Qed.
(* end hide *)

Theorem substitution : (forall Γ M T , Γ  ⊢ M : T  -> forall Δ P A, Δ  ⊢ P : A ->
 forall Γ' n , sub_in_env Δ P A n Γ Γ' -> Γ ⊣  -> Γ' ⊢ M [ n ←P ]  : T [ n ←P ] ) /\
                       (forall Γ ,  Γ ⊣ -> forall Δ P A n Γ' , Δ ⊢ P : A ->
  sub_in_env  Δ P A n Γ Γ' ->  Γ' ⊣).
apply typ_induc; simpl; intros.
(*1*)
eauto.
(*2*)
destruct lt_eq_lt_dec as [ [] | ].
constructor. eapply H; eauto. eapply nth_sub_item_inf. apply H1. intuition. trivial.
destruct i as (AA & ?& ?). subst. rewrite substP3; intuition.
rewrite <- (nth_sub_eq H1 H4). eapply thinning_n. eapply sub_trunc. apply H1. trivial.
eapply H; eauto. constructor. eapply H; eauto. destruct i as (AA & ? &?). subst.
rewrite substP3; intuition. exists AA; split. replace (S (v-1)) with v. trivial.
rewrite minus_Sn_m. intuition. destruct v. apply lt_n_O in l; elim l. intuition.
eapply nth_sub_sup. apply H1. destruct v. apply lt_n_O in l; elim l. simpl. rewrite <- minus_n_O.
intuition. rewrite <- pred_of_minus. rewrite <- (S_pred v n l). trivial.
(*4*)
econstructor. apply r. eapply H; eauto. eapply H0; eauto.
(*5*)
econstructor. apply r. eapply H; eauto. eapply H0; eauto. eapply H1; eauto.
(*6*)
rewrite subst_travers. econstructor.
replace (n+1) with (S n) by (rewrite plus_comm; trivial). eapply H; eauto.
replace (n+1) with (S n) by (rewrite plus_comm; trivial). eapply H0; eauto.
(*7*)
econstructor.  apply Betac_subst2. apply b. eapply H; eauto. eapply H0; eauto.
(* wf *)
inversion H0.
inversion H1; subst; clear H1. eauto.
econstructor. eapply H. apply H0. trivial. eauto.
Qed.

(** Well-formation of contexts: if a context is valid, every term inside
  is well-typed by a sort.*)
Lemma wf_item : forall Γ A n, A ↓ n ∈ Γ ->
   forall  Γ', Γ ⊣ ->  trunc (S n) Γ Γ' -> exists s, Γ' ⊢ A : !s.
induction 1; intros.
inversion H0; subst; clear H0.
inversion H5; subst; clear H5.
inversion H; subst.
exists s; trivial.
inversion H1; subst; clear H1.
inversion H0; subst.
apply IHitem; trivial. eauto.
Qed.

Lemma wf_item_lift : forall Γ A n ,Γ ⊣  -> A ↓ n ⊂ Γ ->
  exists s,  Γ ⊢ A  : !s.
intros.
destruct H0 as (u & ? & ?).
subst.
assert (exists Γ' , trunc (S n) Γ Γ') by (apply item_trunc with u; trivial).
destruct H0 as (Γ' & ?).
destruct (wf_item Γ u n H1 Γ' H H0) as (t &  ?).
exists t. change !t with (!t ↑(S n)).
eapply thinning_n. apply H0. trivial. trivial.
Qed.

(** Type Correction: if a judgment is valid, the type is either welltyped
  itself, or syntacticaly a sort. This distinction comes from the fact
  that we abstracted the typing of sorts with [Ax] and that they may be some
  untyped sorts (also called top-sorts).*)
Theorem TypeCorrect : forall Γ M T, Γ ⊢ M : T  ->
 (exists s, T = !s) \/ (exists s, Γ ⊢ T : !s).
intros; induction H.
(*1*)
left; exists t; reflexivity.
(*2*)
apply wf_item_lift in H0. right; trivial. trivial.
(*4*)
left; exists u; trivial.
(*5*)
right; exists s3; apply cPi with s1 s2; trivial.
(*6*)
destruct IHtyp1. destruct H1; discriminate. destruct H1 as (u & ?).
apply gen_pi in H1 as (s1 & s2 & s3 & h); decompose [and] h; clear h.
right; exists s2.
change (!s2) with (!s2 [← N]). eapply substitution. apply H5. apply H0. constructor.
eauto.
(*8*)
right; exists s; trivial.
Qed.

(** Equivalence with traditional presentation of PTS *)
Reserved Notation "Γ ⊢' t : T"
  (at level 80, t, T at level 30, no associativity) .

Inductive legacy_typ : Env -> Term -> Term -> Prop :=
 | lcSort : forall s t, Ax s t -> nil ⊢' !s : !t
 | lcVar  : forall Γ A s, Γ ⊢' A : !s -> A :: Γ ⊢' #0 : A ↑ 1
 | lcWeak : forall Γ M T A s, Γ ⊢' M : T -> Γ ⊢' A : !s ->
                              A :: Γ ⊢' M ↑ 1 : T ↑ 1
 | lcPi   : forall Γ A B s t u, Rel s t u -> Γ ⊢' A : !s ->
   A :: Γ ⊢' B : !t -> Γ ⊢' Π(A), B : !u
 | lcLa : forall Γ A B M s t u, Rel s t u -> Γ ⊢' A : !s ->
   A :: Γ ⊢' B : !t -> A :: Γ ⊢' M : B -> Γ ⊢' λ[A],M : Π(A),B
 | lcApp : forall Γ A B M N, Γ ⊢' M : Π(A),B -> Γ ⊢' N : A ->
   Γ ⊢' M · N : B [ ← N]
 | lCnv : forall Γ M A B s, Γ ⊢' M : A -> Γ ⊢' B : !s ->
   A ≡ B -> Γ ⊢' M : B
where "Γ ⊢' M : T" := (legacy_typ Γ M T) : UT_scope.

Lemma legacy2typ : forall Γ M T, Γ ⊢' M : T -> (Γ ⊢ M : T /\ Γ ⊣).
Proof.
induction 1; intros.
(**)
split; now constructor.
(**)
destruct IHlegacy_typ.
split.
  constructor.
  econstructor; now apply H0.
  now exists A; split.
econstructor; now apply H0.
(**)
destruct IHlegacy_typ1, IHlegacy_typ2.
split.
  eapply weakening.
  now apply H1.
  now constructor.
  now apply H3.
econstructor; now apply H3.
(**)
destruct IHlegacy_typ1, IHlegacy_typ2.
split; trivial.
now apply cPi with (s:=s) (t:=t).
(**)
destruct IHlegacy_typ1, IHlegacy_typ2, IHlegacy_typ3.
split; trivial.
now apply cLa with (s1:=s) (s2:=t) (s3:=u).
(**)
destruct IHlegacy_typ1, IHlegacy_typ2.
split; trivial.
now apply cApp with (A := A).
(**)
destruct IHlegacy_typ1, IHlegacy_typ2.
split; trivial.
now apply Cnv with (A := A) (s:= s).
Qed.

Reserved Notation "Γ ⊣' " (at level 80, no associativity).

Inductive legacy_wf : Env -> Prop :=
 | lwf_nil  : nil ⊣'
 | lwf_cons : forall Γ A s, Γ ⊢' A : !s -> A::Γ ⊣'
where "Γ ⊣'" := (legacy_wf Γ) : UT_scope.

Lemma wf_ltyp : forall Γ M T, Γ ⊢' M : T -> Γ ⊣'.
Proof.
induction 1; intros; trivial.
(**)
now constructor.
(**)
now apply lwf_cons with (s:=s).
(**)
now apply lwf_cons with (s:=s).
Qed.

Lemma legacy_extend : forall Γ M T, Γ ⊣' -> nil ⊢' M : T ->
  Γ  ⊢' (M ↑ (length Γ)) : (T ↑ (length Γ)).
Proof.
intros Γ; induction Γ; intros; simpl.
(**)
rewrite !lift0.
assumption.
(**)
replace (M ↑ (S (length Γ))) with (M ↑ (length Γ)) ↑ 1 by apply lift_lift.
replace (T ↑ (S (length Γ))) with (T ↑ (length Γ)) ↑ 1 by apply lift_lift.
inversion H; subst; clear H.
apply lcWeak with (s:=s); trivial.
apply IHΓ; trivial.
now apply wf_ltyp in H2.
Qed.

Lemma legacy_var : forall Γ A v, Γ ⊣' -> A ↓ v ⊂ Γ -> Γ ⊢' #v : A.
Proof.
intros Γ; induction Γ; intros; simpl.
(**)
destruct H0 as ( x & ? & ?).
now inversion H1.
(**)
inversion H; subst; clear H.
destruct H0 as (x & ? & ?).
inversion H0; subst; clear H0.
  subst.
  now apply lcVar with (s:=s).
replace (x ↑ (S (S n))) with (x ↑ (S n)) ↑ 1 by apply lift_lift.
change (#(S n)) with (#n)↑1.
apply lcWeak with (s := s); trivial.
apply IHΓ.
  now apply wf_ltyp in H2.
now exists x; split.
Qed.

Lemma typ2legacy : (forall Γ M T, Γ ⊢ M : T -> Γ ⊢' M : T ) /\
  (forall Γ, Γ ⊣ -> Γ ⊣').
Proof.
apply typ_induc; intros.
(**)
change !s with (!s ↑ (length Γ)); change !t with (!t ↑ (length Γ)).
apply legacy_extend; trivial.
now constructor.
(**)
now apply legacy_var.
(**)
now apply lcPi with (s:=s) (t:=t) (u:=u).
(**)
now apply lcLa with (s:=s1) (t:=s2) (u:=s3).
(**)
now apply lcApp with (A:=A).
(**)
now apply lCnv with (A:=A) (s:=s).
(**)
now constructor.
(**)
now apply lwf_cons with (s:=s).
Qed.

End ut_typ_mod.