(* -*- mode: coq; coq-prog-args: ("-nois" "-indices-matter" "-R" "." "Top" "-top" "bug_oog_looping_rewrite_01") -*- *)
(* File reduced by coq-bug-finder from original input, then from 2553 lines to 1932 lines, then from 1946 lines to 1932 lines, then from 2467 lines to 1002 lines, then from 1016 lines to 1002 lines *)
(* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0
   coqtop version 8.5 (January 2016) *)
Declare ML Module "ltac_plugin".
Inductive False := .
Axiom proof_admitted : False.
Tactic Notation "admit" := case proof_admitted.
Require Coq.Init.Datatypes.

Import Coq.Init.Notations.

Global Set Universe Polymorphism.

Notation "A -> B" := (forall (_ : A), B) : type_scope.
Global Set Primitive Projections.

Inductive sum (A B : Type) : Type :=
  | inl : A -> sum A B
  | inr : B -> sum A B.
Notation nat := Coq.Init.Datatypes.nat.
Notation O := Coq.Init.Datatypes.O.
Notation S := Coq.Init.Datatypes.S.
Notation "x + y" := (sum x y) : type_scope.

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

Notation "x * y" := (prod x y) : type_scope.
Module Export Specif.

Set Implicit Arguments.

Record sig {A} (P : A -> Type) := exist { proj1_sig : A ; proj2_sig : P proj1_sig }.
Arguments proj1_sig {A P} _ / .

Notation sigT := sig (only parsing).
Notation existT := exist (only parsing).

Notation "{ x : A  & P }" := (sigT (fun x:A => P)) : type_scope.

Notation projT1 := proj1_sig (only parsing).
Notation projT2 := proj2_sig (only parsing).

End Specif.
Module Export HoTT_DOT_Basics_DOT_Overture.
Module Export HoTT.
Module Export Basics.
Module Export Overture.

Global Set Keyed Unification.

Global Unset Strict Universe Declaration.

Notation Type0 := Set.

Definition Type1@{i} := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}.

Definition Type2@{i j} := Eval hnf in let gt := (Type1@{j} : Type@{i}) in Type@{i}.

Definition Type2le@{i j} := Eval hnf in let gt := (Set : Type@{i}) in
                                        let ge := ((fun x => x) : Type1@{j} -> Type@{i}) in Type@{i}.

Notation idmap := (fun x => x).
Delimit Scope function_scope with function.
Delimit Scope path_scope with path.
Delimit Scope fibration_scope with fibration.
Delimit Scope trunc_scope with trunc.

Open Scope trunc_scope.
Open Scope path_scope.
Open Scope fibration_scope.
Open Scope nat_scope.
Open Scope function_scope.

Notation "( x ; y )" := (existT _ x y) : fibration_scope.

Notation pr1 := projT1.
Notation pr2 := projT2.

Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope.
Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope.

Notation compose := (fun g f x => g (f x)).

Notation "g 'o' f" := (compose g%function f%function) (at level 40, left associativity) : function_scope.

Inductive paths {A : Type} (a : A) : A -> Type :=
  idpath : paths a a.

Arguments idpath {A a} , [A] a.

Notation "x = y :> A" := (@paths A x y) : type_scope.
Notation "x = y" := (x = y :>_) : type_scope.

Definition inverse {A : Type} {x y : A} (p : x = y) : y = x
  := match p with idpath => idpath end.

Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z :=
  match p, q with idpath, idpath => idpath end.

Notation "1" := idpath : path_scope.

Notation "p @ q" := (concat p%path q%path) (at level 20) : path_scope.

Notation "p ^" := (inverse p%path) (at level 3, format "p '^'") : path_scope.

Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
  match p with idpath => u end.

Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope.

Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
  := match p with idpath => idpath end.

Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x)
  := forall x:A, f x = g x.

Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope.

Definition Sect {A B : Type} (s : A -> B) (r : B -> A) :=
  forall x : A, r (s x) = x.

Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
  equiv_inv : B -> A ;
  eisretr : Sect equiv_inv f;
  eissect : Sect f equiv_inv;
  eisadj : forall x : A, eisretr (f x) = ap f (eissect x)
}.

Arguments eisretr {A B}%type_scope f%function_scope {_} _.

Record Equiv A B := BuildEquiv {
  equiv_fun : A -> B ;
  equiv_isequiv : IsEquiv equiv_fun
}.

Coercion equiv_fun : Equiv >-> Funclass.

Global Existing Instance equiv_isequiv.

Notation "A <~> B" := (Equiv A B) (at level 85) : type_scope.

Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : function_scope.

Class Contr_internal (A : Type) := BuildContr {
  center : A ;
  contr : (forall y : A, center = y)
}.

Arguments center A {_}.

Inductive trunc_index : Type :=
| minus_two : trunc_index
| trunc_S : trunc_index -> trunc_index.

Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope.
Notation "-2" := minus_two (at level 0) : trunc_scope.
Notation "-1" := (-2.+1) (at level 0) : trunc_scope.
Notation "0" := (-1.+1) : trunc_scope.

Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
  match n with
    | -2 => Contr_internal A
    | n'.+1 => forall (x y : A), IsTrunc_internal n' (x = y)
  end.

Class IsTrunc (n : trunc_index) (A : Type) : Type :=
  Trunc_is_trunc : IsTrunc_internal n A.

Global Instance istrunc_paths (A : Type) n `{H : IsTrunc n.+1 A} (x y : A)
: IsTrunc n (x = y)
  := H x y.

Notation Contr := (IsTrunc -2).
Notation IsHProp := (IsTrunc -1).

Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances.

Monomorphic Axiom dummy_funext_type : Type0.
Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }.

Inductive Unit : Type1 :=
    tt : Unit.

Class IsPointed (A : Type) := point : A.

Arguments point A {_}.

Record pType :=
  { pointed_type : Type ;
    ispointed_type : IsPointed pointed_type }.

Coercion pointed_type : pType >-> Sortclass.

Global Existing Instance ispointed_type.

Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }.

Ltac revert_opaque x :=
  revert x;
  match goal with
    | [ |- forall _, _ ] => idtac
    | _ => fail 1 "Reverted constant is not an opaque variable"
  end.

End Overture.

End Basics.

End HoTT.

End HoTT_DOT_Basics_DOT_Overture.
Module Export HoTT_DOT_Basics_DOT_PathGroupoids.
Module Export HoTT.
Module Export Basics.
Module Export PathGroupoids.

Local Open Scope path_scope.

Definition concat_p1 {A : Type} {x y : A} (p : x = y) :
  p @ 1 = p
  :=
  match p with idpath => 1 end.

Definition concat_1p {A : Type} {x y : A} (p : x = y) :
  1 @ p = p
  :=
  match p with idpath => 1 end.

Definition concat_p_pp {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) :
  p @ (q @ r) = (p @ q) @ r :=
  match r with idpath =>
    match q with idpath =>
      match p with idpath => 1
      end end end.

Definition concat_pp_p {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) :
  (p @ q) @ r = p @ (q @ r) :=
  match r with idpath =>
    match q with idpath =>
      match p with idpath => 1
      end end end.

Definition concat_pV {A : Type} {x y : A} (p : x = y) :
  p @ p^ = 1
  :=
  match p with idpath => 1 end.

Definition moveR_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) :
  p = r @ q -> r^ @ p = q.
admit.
Defined.

Definition moveL_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) :
  r @ q = p -> q = r^ @ p.
admit.
Defined.

Definition moveR_M1 {A : Type} {x y : A} (p q : x = y) :
  1 = p^ @ q -> p = q.
admit.
Defined.

Definition ap_pp {A B : Type} (f : A -> B) {x y z : A} (p : x = y) (q : y = z) :
  ap f (p @ q) = (ap f p) @ (ap f q)
  :=
  match q with
    idpath =>
    match p with idpath => 1 end
  end.

Definition ap_V {A B : Type} (f : A -> B) {x y : A} (p : x = y) :
  ap f (p^) = (ap f p)^
  :=
  match p with idpath => 1 end.

Definition ap_compose {A B C : Type} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) :
  ap (g o f) p = ap g (ap f p)
  :=
  match p with idpath => 1 end.

Definition concat_pA1 {A : Type} {f : A -> A} (p : forall x, x = f x) {x y : A} (q : x = y) :
  (p x) @ (ap f q) =  q @ (p y)
  :=
  match q as i in (_ = y) return (p x @ ap f i = i @ p y) with
    | idpath => concat_p1 _ @ (concat_1p _)^
  end.

End PathGroupoids.

End Basics.

End HoTT.

End HoTT_DOT_Basics_DOT_PathGroupoids.
Module Export HoTT_DOT_Basics_DOT_Equivalences.
Module Export HoTT.
Module Export Basics.
Module Export Equivalences.

Definition isequiv_commsq {A B C D}
           (f : A -> B) (g : C -> D) (h : A -> C) (k : B -> D)
           (p : k o f == g o h)
           `{IsEquiv _ _ f} `{IsEquiv _ _ h} `{IsEquiv _ _ k}
: IsEquiv g.
admit.
Defined.

Section Adjointify.

  Context {A B : Type} (f : A -> B) (g : B -> A).
  Context (isretr : Sect g f) (issect : Sect f g).

  Let issect' := fun x =>
    ap g (ap f (issect x)^)  @  ap g (isretr (f x))  @  issect x.

  Let is_adjoint' (a : A) : isretr (f a) = ap f (issect' a).
  Proof.
    unfold issect'.
    apply moveR_M1.
    repeat rewrite ap_pp, concat_p_pp; rewrite <- ap_compose.
    rewrite (concat_pA1 (fun b => (isretr b)^) (ap f (issect a)^)).
    repeat rewrite concat_pp_p; rewrite ap_V; apply moveL_Vp; rewrite concat_p1.
    rewrite concat_p_pp, <- ap_compose.
    rewrite (concat_pA1 (fun b => (isretr b)^) (isretr (f a))).
    rewrite concat_pV, concat_1p; reflexivity.
  Qed.

  Definition isequiv_adjointify : IsEquiv f
    := BuildIsEquiv A B f g isretr issect' is_adjoint'.

End Adjointify.

End Equivalences.

End Basics.

End HoTT.

End HoTT_DOT_Basics_DOT_Equivalences.
Module Export HoTT_DOT_Basics_DOT_Trunc.
Module Export HoTT.
Module Export Basics.
Module Export Trunc.
Generalizable Variables A B m n f.

Definition trunc_equiv A {B} (f : A -> B)
  `{IsTrunc n A} `{IsEquiv A B f}
  : IsTrunc n B.
admit.
Defined.

Record TruncType (n : trunc_index) := BuildTruncType {
  trunctype_type : Type ;
  istrunc_trunctype_type : IsTrunc n trunctype_type
}.

Arguments BuildTruncType _ _ {_}.

Coercion trunctype_type : TruncType >-> Sortclass.

Notation "n -Type" := (TruncType n) (at level 1) : type_scope.
Notation hProp := (-1)-Type.

Notation BuildhProp := (BuildTruncType -1).

End Trunc.

End Basics.

End HoTT.

End HoTT_DOT_Basics_DOT_Trunc.
Module Export HoTT_DOT_Types_DOT_Unit.
Module Export HoTT.
Module Export Types.
Module Export Unit.

Notation unit_name x := (fun (_ : Unit) => x).

End Unit.

End Types.

End HoTT.

End HoTT_DOT_Types_DOT_Unit.
Module Export HoTT_DOT_Types_DOT_Sigma.
Module Export HoTT.
Module Export Types.
Module Export Sigma.
Local Open Scope path_scope.

Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P)
           (pq : {p : u.1 = v.1 & p # u.2 = v.2})
: u = v
  := match pq.2 in (_ = v2) return u = (v.1; v2) with
       | 1 => match pq.1 as p in (_ = v1) return u = (v1; p # u.2) with
                | 1 => 1
              end
     end.

Definition path_sigma {A : Type} (P : A -> Type) (u v : sigT P)
           (p : u.1 = v.1) (q : p # u.2 = v.2)
: u = v
  := path_sigma_uncurried P u v (p;q).

Definition path_sigma' {A : Type} (P : A -> Type) {x x' : A} {y : P x} {y' : P x'}
           (p : x = x') (q : p # y = y')
: (x;y) = (x';y')
  := path_sigma P (x;y) (x';y') p q.

Global Instance isequiv_pr1_contr {A} {P : A -> Type}
         `{forall a, Contr (P a)}
: IsEquiv (@pr1 A P) | 100.
Proof.
  refine (isequiv_adjointify (@pr1 A P)
                             (fun a => (a ; center (P a))) _ _).
  -
 intros a; reflexivity.
  -
 intros [a p].
    refine (path_sigma' P 1 (contr _)).
Defined.

Definition path_sigma_hprop {A : Type} {P : A -> Type}
           `{forall x, IsHProp (P x)}
           (u v : sigT P)
: u.1 = v.1 -> u = v
  := path_sigma_uncurried P u v o pr1^-1.

End Sigma.

End Types.

End HoTT.

End HoTT_DOT_Types_DOT_Sigma.
Module Export HoTT_DOT_Extensions.
Module Export HoTT.
Module Export Extensions.

Section Extensions.

  Definition ExtensionAlong {A B : Type} (f : A -> B)
             (P : B -> Type) (d : forall x:A, P (f x))
    := { s : forall y:B, P y & forall x:A, s (f x) = d x }.

  Fixpoint ExtendableAlong@{i j k l}
           (n : nat) {A : Type@{i}} {B : Type@{j}}
           (f : A -> B) (C : B -> Type@{k}) : Type@{l}
    := match n with
         | O => Unit@{l}
         | S n => (forall (g : forall a, C (f a)),
                     ExtensionAlong@{i j k l l} f C g) *
                  forall (h k : forall b, C b),
                    ExtendableAlong n f (fun b => h b = k b)
       end.

  Definition ooExtendableAlong@{i j k l}
             {A : Type@{i}} {B : Type@{j}}
             (f : A -> B) (C : B -> Type@{k}) : Type@{l}
    := forall n, ExtendableAlong@{i j k l} n f C.

End Extensions.

End Extensions.

End HoTT.

End HoTT_DOT_Extensions.
Module Export HoTT.
Module Export Modalities.
Module Export ReflectiveSubuniverse.

Module Type ReflectiveSubuniverses.

  Parameter ReflectiveSubuniverse@{u a} : Type2@{u a}.

  Parameter O_reflector@{u a i} : forall (O : ReflectiveSubuniverse@{u a}),
                            Type2le@{i a} -> Type2le@{i a}.

  Parameter In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}),
                   Type2le@{i a} -> Type2le@{i a}.

  Parameter O_inO@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}),
                               In@{u a i} O (O_reflector@{u a i} O T).

  Parameter to@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}),
                   T -> O_reflector@{u a i} O T.

  Parameter inO_equiv_inO@{u a i j k} :
      forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j})
             (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f),

        let gei := ((fun x => x) : Type@{i} -> Type@{k}) in
        let gej := ((fun x => x) : Type@{j} -> Type@{k}) in
        In@{u a j} O U.

  Parameter hprop_inO@{u a i}
  : Funext -> forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}),
                IsHProp (In@{u a i} O T).

  Parameter extendable_to_O@{u a i j k}
  : forall (O : ReflectiveSubuniverse@{u a}) {P : Type2le@{i a}} {Q : Type2le@{j a}} {Q_inO : In@{u a j} O Q},
      ooExtendableAlong@{i i j k} (to O P) (fun _ => Q).

End ReflectiveSubuniverses.

Module ReflectiveSubuniverses_Theory (Os : ReflectiveSubuniverses).
Export Os.

Module Export Coercions.

  Coercion O_reflector : ReflectiveSubuniverse >-> Funclass.

End Coercions.

End ReflectiveSubuniverses_Theory.

Module Type ReflectiveSubuniverses_Restriction_Data (Os : ReflectiveSubuniverses).

  Parameter New_ReflectiveSubuniverse@{u a} : Type2@{u a}.

  Parameter ReflectiveSubuniverses_restriction@{u a}
  : New_ReflectiveSubuniverse@{u a} -> Os.ReflectiveSubuniverse@{u a}.

End ReflectiveSubuniverses_Restriction_Data.

Module ReflectiveSubuniverses_Restriction
       (Os : ReflectiveSubuniverses)
       (Res : ReflectiveSubuniverses_Restriction_Data Os)
<: ReflectiveSubuniverses.

  Definition ReflectiveSubuniverse := Res.New_ReflectiveSubuniverse.

  Definition O_reflector@{u a i} (O : ReflectiveSubuniverse@{u a})
    := Os.O_reflector@{u a i} (Res.ReflectiveSubuniverses_restriction O).
  Definition In@{u a i} (O : ReflectiveSubuniverse@{u a})
    := Os.In@{u a i} (Res.ReflectiveSubuniverses_restriction O).
  Definition O_inO@{u a i} (O : ReflectiveSubuniverse@{u a})
    := Os.O_inO@{u a i} (Res.ReflectiveSubuniverses_restriction O).
  Definition to@{u a i} (O : ReflectiveSubuniverse@{u a})
    := Os.to@{u a i} (Res.ReflectiveSubuniverses_restriction O).
  Definition inO_equiv_inO@{u a i j k} (O : ReflectiveSubuniverse@{u a})
    := Os.inO_equiv_inO@{u a i j k} (Res.ReflectiveSubuniverses_restriction O).
  Definition hprop_inO@{u a i} (H : Funext) (O : ReflectiveSubuniverse@{u a})
    := Os.hprop_inO@{u a i} H (Res.ReflectiveSubuniverses_restriction O).
  Definition extendable_to_O@{u a i j k} (O : ReflectiveSubuniverse@{u a})
    := @Os.extendable_to_O@{u a i j k} (Res.ReflectiveSubuniverses_restriction@{u a} O).

End ReflectiveSubuniverses_Restriction.

Module ReflectiveSubuniverses_FamUnion
       (Os1 Os2 : ReflectiveSubuniverses)
<: ReflectiveSubuniverses.

  Definition ReflectiveSubuniverse@{u a} : Type2@{u a}
    := Os1.ReflectiveSubuniverse@{u a} + Os2.ReflectiveSubuniverse@{u a}.

  Definition O_reflector@{u a i} : forall (O : ReflectiveSubuniverse@{u a}),
                             Type2le@{i a} -> Type2le@{i a}.
admit.
Defined.

  Definition In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}),
                             Type2le@{i a} -> Type2le@{i a}.
  Proof.
    intros [O|O]; [ exact (Os1.In@{u a i} O)
                  | exact (Os2.In@{u a i} O) ].
  Defined.

  Definition O_inO@{u a i}
  : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}),
      In@{u a i} O (O_reflector@{u a i} O T).
admit.
Defined.

  Definition to@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}),
                   T -> O_reflector@{u a i} O T.
admit.
Defined.

  Definition inO_equiv_inO@{u a i j k} :
      forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j})
             (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f),
        In@{u a j} O U.
  Proof.
    intros [O|O]; [ exact (Os1.inO_equiv_inO@{u a i j k} O)
                  | exact (Os2.inO_equiv_inO@{u a i j k} O) ].
  Defined.

  Definition hprop_inO@{u a i}
  : Funext -> forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}),
                IsHProp (In@{u a i} O T).
admit.
Defined.

  Definition extendable_to_O@{u a i j k}
  : forall (O : ReflectiveSubuniverse@{u a}) {P : Type2le@{i a}} {Q : Type2le@{j a}} {Q_inO : In@{u a j} O Q},
      ooExtendableAlong@{i i j k} (to O P) (fun _ => Q).
admit.
Defined.

End ReflectiveSubuniverses_FamUnion.

End ReflectiveSubuniverse.

End Modalities.

End HoTT.

Module Type Modalities.

  Parameter Modality@{u a} : Type2@{u a}.

  Parameter O_reflector@{u a i} : forall (O : Modality@{u a}),
                            Type2le@{i a} -> Type2le@{i a}.

  Parameter In@{u a i} : forall (O : Modality@{u a}),
                            Type2le@{i a} -> Type2le@{i a}.

  Parameter O_inO@{u a i} : forall (O : Modality@{u a}) (T : Type@{i}),
                               In@{u a i} O (O_reflector@{u a i} O T).

  Parameter to@{u a i} : forall (O : Modality@{u a}) (T : Type@{i}),
                   T -> O_reflector@{u a i} O T.

  Parameter inO_equiv_inO@{u a i j k} :
      forall (O : Modality@{u a}) (T : Type@{i}) (U : Type@{j})
             (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f),

        let gei := ((fun x => x) : Type@{i} -> Type@{k}) in
        let gej := ((fun x => x) : Type@{j} -> Type@{k}) in
        In@{u a j} O U.

  Parameter hprop_inO@{u a i}
  : Funext -> forall (O : Modality@{u a}) (T : Type@{i}),
                IsHProp (In@{u a i} O T).

End Modalities.

Module Modalities_to_ReflectiveSubuniverses
       (Os : Modalities) <: ReflectiveSubuniverses.

  Import Os.

  Fixpoint O_extendable@{u a i j k} (O : Modality@{u a})
           (A : Type@{i}) (B : O_reflector O A -> Type@{j})
           (B_inO : forall a, In@{u a j} O (B a)) (n : nat)
  : ExtendableAlong@{i i j k} n (to O A) B.
admit.
Defined.

  Definition ReflectiveSubuniverse := Modality.

  Definition O_reflector@{u a i} := O_reflector@{u a i}.

  Definition In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}),
                   Type2le@{i a} -> Type2le@{i a}
    := In@{u a i}.
  Definition O_inO@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}),
                               In@{u a i} O (O_reflector@{u a i} O T)
    := O_inO@{u a i}.
  Definition to@{u a i} := to@{u a i}.
  Definition inO_equiv_inO@{u a i j k} :
      forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j})
             (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f),
        In@{u a j} O U
    := inO_equiv_inO@{u a i j k}.
  Definition hprop_inO@{u a i}
  : Funext -> forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}),
                IsHProp (In@{u a i} O T)
    := hprop_inO@{u a i}.

  Definition extendable_to_O@{u a i j k} (O : ReflectiveSubuniverse@{u a})
             {P : Type2le@{i a}} {Q : Type2le@{j a}} {Q_inO : In@{u a j} O Q}
  : ooExtendableAlong@{i i j k} (to O P) (fun _ => Q)
    := fun n => O_extendable O P (fun _ => Q) (fun _ => Q_inO) n.

End Modalities_to_ReflectiveSubuniverses.

Module Type EasyModalities.

  Parameter Modality@{u a} : Type2@{u a}.

  Parameter O_reflector@{u a i} : forall (O : Modality@{u a}),
                            Type2le@{i a} -> Type2le@{i a}.

  Parameter to@{u a i} : forall (O : Modality@{u a}) (T : Type@{i}),
                   T -> O_reflector@{u a i} O T.

  Parameter minO_pathsO@{u a i}
  : forall (O : Modality@{u a}) (A : Type@{i})
           (z z' : O_reflector@{u a i} O A),
      IsEquiv (to@{u a i} O (z = z')).

End EasyModalities.

Module EasyModalities_to_Modalities (Os : EasyModalities)
<: Modalities.

  Import Os.

  Definition Modality := Modality.

  Definition O_reflector@{u a i} := O_reflector@{u a i}.
  Definition to@{u a i} := to@{u a i}.

  Definition In@{u a i}
  : forall (O : Modality@{u a}), Type@{i} -> Type@{i}
  := fun O A => IsEquiv@{i i} (to O A).

  Definition hprop_inO@{u a i} `{Funext} (O : Modality@{u a})
             (T : Type@{i})
  : IsHProp (In@{u a i} O T).
admit.
Defined.

  Definition O_ind_internal@{u a i j k} (O : Modality@{u a})
             (A : Type@{i}) (B : O_reflector@{u a i} O A -> Type@{j})
             (B_inO : forall oa, In@{u a j} O (B oa))
  : let gei := ((fun x => x) : Type@{i} -> Type@{k}) in
    let gej := ((fun x => x) : Type@{j} -> Type@{k}) in
    (forall a, B (to O A a)) -> forall oa, B oa.
admit.
Defined.

  Definition O_ind_beta_internal@{u a i j k} (O : Modality@{u a})
             (A : Type@{i}) (B : O_reflector@{u a i} O A -> Type@{j})
             (B_inO : forall oa, In@{u a j} O (B oa))
             (f : forall a : A, B (to O A a)) (a:A)
  : O_ind_internal@{u a i j k} O A B B_inO f (to O A a) = f a.
admit.
Defined.

  Definition O_inO@{u a i} (O : Modality@{u a}) (A : Type@{i})
  : In@{u a i} O (O_reflector@{u a i} O A).
admit.
Defined.

  Definition inO_equiv_inO@{u a i j k} (O : Modality@{u a}) (A : Type@{i}) (B : Type@{j})
    (A_inO : In@{u a i} O A) (f : A -> B) (feq : IsEquiv f)
  : In@{u a j} O B.
  Proof.
    simple refine (isequiv_commsq (to O A) (to O B) f
             (O_ind_internal O A (fun _ => O_reflector O B) _ (fun a => to O B (f a))) _).
    -
 intros; apply O_inO.
    -
 intros a; refine (O_ind_beta_internal@{u a i j k} O A (fun _ => O_reflector O B) _ _ a).
    -
 apply A_inO.
    -
 simple refine (isequiv_adjointify _
               (O_ind_internal O B (fun _ => O_reflector O A) _ (fun b => to O A (f^-1 b))) _ _);
        intros x.
      +
 apply O_inO.
      +
 pattern x; refine (O_ind_internal O B _ _ _ x); intros.
        *
 apply minO_pathsO.
        *
 simpl; admit.
      +
 pattern x; refine (O_ind_internal O A _ _ _ x); intros.
        *
 apply minO_pathsO.
        *
 simpl; admit.
  Defined.

End EasyModalities_to_Modalities.

Module Modalities_Theory (Os : Modalities).

Export Os.
Module Export Os_ReflectiveSubuniverses
  := Modalities_to_ReflectiveSubuniverses Os.
Module Export RSU
  := ReflectiveSubuniverses_Theory Os_ReflectiveSubuniverses.

Module Export Coercions.
  Coercion modality_to_reflective_subuniverse
    := idmap : Modality -> ReflectiveSubuniverse.
End Coercions.

Class IsConnected (O : Modality@{u a}) (A : Type@{i})

  := isconnected_contr_O : IsTrunc@{i} -2 (O A).

Class IsConnMap (O : Modality@{u a})
      {A : Type@{i}} {B : Type@{j}} (f : A -> B)
  := isconnected_hfiber_conn_map

     : forall b:B, IsConnected@{u a k} O (hfiber@{i j} f b).

End Modalities_Theory.

Private Inductive Trunc (n : trunc_index) (A :Type) : Type :=
  tr : A -> Trunc n A.
Arguments tr {n A} a.

Global Instance istrunc_truncation (n : trunc_index) (A : Type@{i})
: IsTrunc@{j} n (Trunc@{i} n A).
Admitted.

Definition Trunc_ind {n A}
  (P : Trunc n A -> Type) {Pt : forall aa, IsTrunc n (P aa)}
  : (forall a, P (tr a)) -> (forall aa, P aa)
:= (fun f aa => match aa with tr a => fun _ => f a end Pt).

Definition Truncation_Modality := trunc_index.

Module Truncation_Modalities <: Modalities.

  Definition Modality : Type2@{u a} := Truncation_Modality.

  Definition O_reflector (n : Modality@{u u'}) A := Trunc n A.

  Definition In (n : Modality@{u u'}) A := IsTrunc n A.

  Definition O_inO (n : Modality@{u u'}) A : In n (O_reflector n A).
admit.
Defined.

  Definition to (n : Modality@{u u'}) A := @tr n A.

  Definition inO_equiv_inO (n : Modality@{u u'})
             (A : Type@{i}) (B : Type@{j}) Atr f feq
  : let gei := ((fun x => x) : Type@{i} -> Type@{k}) in
    let gej := ((fun x => x) : Type@{j} -> Type@{k}) in
    In n B
  := @trunc_equiv A B f n Atr feq.

  Definition hprop_inO `{Funext} (n : Modality@{u u'}) A
  : IsHProp (In n A).
admit.
Defined.

End Truncation_Modalities.

Module Import TrM := Modalities_Theory Truncation_Modalities.

Definition merely (A : Type@{i}) : hProp := BuildhProp (Trunc -1 A).

Notation IsSurjection := (IsConnMap -1).

Definition BuildIsSurjection {A B} (f : A -> B) :
  (forall b, merely (hfiber f b)) -> IsSurjection f.
admit.
Defined.

Ltac strip_truncations :=

  progress repeat match goal with
                    | [ T : _ |- _ ]
                      => revert_opaque T;
                        refine (@Trunc_ind _ _ _ _ _);

                        [];
                        intro T
                  end.
Local Open Scope trunc_scope.

Global Instance conn_pointed_type {n : trunc_index} {A : Type} (a0:A)
 `{IsConnMap n _ _ (unit_name a0)} : IsConnected n.+1 A | 1000.
admit.
Defined.

Definition loops (A : pType) : pType :=
  Build_pType (point A = point A) idpath.

Record pMap (A B : pType) :=
  { pointed_fun : A -> B ;
    point_eq : pointed_fun (point A) = point B }.

Arguments point_eq {A B} f : rename.
Coercion pointed_fun : pMap >-> Funclass.

Infix "->*" := pMap (at level 99) : pointed_scope.
Local Open Scope pointed_scope.

Definition pmap_compose {A B C : pType}
           (g : B ->* C) (f : A ->* B)
: A ->* C
  := Build_pMap A C (g o f)
                (ap g (point_eq f) @ point_eq g).

Record pHomotopy {A B : pType} (f g : pMap A B) :=
  { pointed_htpy : f == g ;
    point_htpy : pointed_htpy (point A) @ point_eq g = point_eq f }.
Arguments pointed_htpy {A B f g} p x.

Infix "==*" := pHomotopy (at level 70, no associativity) : pointed_scope.

Definition loops_functor {A B : pType} (f : A ->* B)
: (loops A) ->* (loops B).
Proof.
  refine (Build_pMap (loops A) (loops B)
            (fun p => (point_eq f)^ @ (ap f p @ point_eq f)) _).
  apply moveR_Vp; simpl.
  refine (concat_1p _ @ (concat_p1 _)^).
Defined.

Definition loops_functor_compose {A B C : pType}
           (g : B ->* C) (f : A ->* B)
: (loops_functor (pmap_compose g f))
   ==* (pmap_compose (loops_functor g) (loops_functor f)).
admit.
Defined.

Local Open Scope path_scope.

Record ooGroup :=
  { classifying_space : pType@{i} ;
    isconn_classifying_space : IsConnected@{u a i} 0 classifying_space
  }.

Local Notation B := classifying_space.

Definition group_type (G : ooGroup) : Type
  := point (B G) = point (B G).

Coercion group_type : ooGroup >-> Sortclass.

Definition group_loops (X : pType)
: ooGroup.
Proof.

  pose (x0 := point X);
  pose (BG := (Build_pType
               { x:X & merely (x = point X) }
               (existT (fun x:X => merely (x = point X)) x0 (tr 1)))).

  cut (IsConnected 0 BG).
  {
 exact (Build_ooGroup BG).
}
  cut (IsSurjection (unit_name (point BG))).
  {
 intros; refine (conn_pointed_type (point _)).
}
  apply BuildIsSurjection; simpl; intros [x p].
  strip_truncations; apply tr; exists tt.
  apply path_sigma_hprop; simpl.
  exact (p^).
Defined.

Definition loops_group (X : pType)
: loops X <~> group_loops X.
admit.
Defined.

Definition ooGroupHom (G H : ooGroup)
  := pMap (B G) (B H).

Definition grouphom_fun {G H} (phi : ooGroupHom G H) : G -> H
  := loops_functor phi.

Coercion grouphom_fun : ooGroupHom >-> Funclass.

Definition group_loops_functor
           {X Y : pType} (f : pMap X Y)
: ooGroupHom (group_loops X) (group_loops Y).
Proof.
  simple refine (Build_pMap _ _ _ _); simpl.
  -
 intros [x p].
    exists (f x).
    strip_truncations; apply tr.
    exact (ap f p @ point_eq f).
  -
 apply path_sigma_hprop; simpl.
    apply point_eq.
Defined.

Definition loops_functor_group
           {X Y : pType} (f : pMap X Y)
: loops_functor (group_loops_functor f) o loops_group X
  == loops_group Y o loops_functor f.
admit.
Defined.

Definition grouphom_compose {G H K : ooGroup}
           (psi : ooGroupHom H K) (phi : ooGroupHom G H)
: ooGroupHom G K
  := pmap_compose psi phi.

Definition group_loops_functor_compose
           {X Y Z : pType}
           (psi : pMap Y Z) (phi : pMap X Y)
: grouphom_compose (group_loops_functor psi) (group_loops_functor phi)
  == group_loops_functor (pmap_compose psi phi).
Proof.
  intros g.
  unfold grouphom_fun, grouphom_compose.
  refine (pointed_htpy (loops_functor_compose _ _) g @ _).
  pose (p := eisretr (loops_group X) g).
  change (loops_functor (group_loops_functor psi)
            (loops_functor (group_loops_functor phi) g)
          = loops_functor (group_loops_functor
                                 (pmap_compose psi phi)) g).
  rewrite <- p.
  Fail Timeout 1 Time rewrite !loops_functor_group.
  (* 0.004 s in 8.5rc1, 8.677 s in 8.5 *)
  Timeout 1 do 3 rewrite loops_functor_group.
Abort.


(*

  Copyright 2016 University of Luxembourg

  This file is part of our formalization of Platzer's
    "A Complete Uniform Substitution Calculus for Differential Dynamic Logic"
  available here: http://arxiv.org/pdf/1601.06183.pdf (July 27, 2016).
  We refer to this formalization as DdlCoq here.

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

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

  You should have received a copy of the GNU General Public License
  along with DdlCoq.  If not, see <http://www.gnu.org/licenses/>.

  authors:
    Vincent Rahli
    Marcus Völp
    Ivana Vukotic

 *)

Require Export symbol.
Require Export list_util.
Require Export tactics_util.
Require Export reals_util.

(**

  In this file conversion between KAssignables, variables and strings is introduced, as well as symbol decidability.
  Also, this file introduces definition of state, and implements some lemmas about states.
  Beside that, this file includes some useful definitions which we used in order to define syntax and semantics of ddl.

*)

(** some useful conversions between KAssignables, variables and strings *)

(* Used in definition of interpretation of primed terms *)
(** extract variable form KAssignable *)
Fixpoint KAssignable2variable (a : KAssignable) : KVariable :=
  match a with
  | KAssignVar x => x
  | KAssignDiff a => KAssignable2variable a
  end.
Coercion KAssignable2variable : KAssignable >-> KVariable.

Coercion KAssignVar : KVariable >-> KAssignable.

(** converts KVariable to string *)
Definition KVariable2string (v : KVariable) : String.string :=
  match v with
  | variable name => name
  end.
Coercion KVariable2string : KVariable >-> String.string.

(** converts KAssignable to string *)
Definition KAssignable2string (a : KAssignable) : String.string := a.

(* Used in definition of interpretation of theta prime *)
(** extracts variables form KAssignable *)
Definition KVar_of_KAssignable (a : KAssignable) : list KVariable :=
  match a with
  | KAssignVar x => [x]
  | KAssignDiff _ => []
  end.

(** Decidability for symbols *)

(* used in definition of interpretation of teta prime *)
(** decidability for variables *)
Lemma KVariable_dec :
  forall a b : KVariable, {a = b} + {a <> b}.
Proof.
  destruct a as [x], b as [y]; prove_dec.
  destruct (string_dec x y); subst; prove_dec.
Defined.

(* decidability for channels *)
Lemma KChannel_dec :
  forall a b : KChannel, {a = b} + {a <> b}.
Proof.
  destruct a as [x], b as [y]; prove_dec.
  destruct (string_dec x y); subst; prove_dec.
Defined.

(** decidability for function symbols *)
Lemma FunctionSymbol_dec : forall (t u : FunctionSymbol), {t = u} + {t <> u}.
Proof.
  destruct t as [n1], u as [n2].
  destruct (string_dec n1 n2); subst; prove_dec.
Defined.

(** decidability for predicate symbols *)
Lemma PredicateSymbol_dec : forall (t u : PredicateSymbol), {t = u} + {t <> u}.
Proof.
  destruct t as [n1], u as [n2].
  destruct (string_dec n1 n2); subst; prove_dec.
Defined.

(** decidability for quantifier symbol *)
Lemma QuantifierSymbol_dec : forall (t u : QuantifierSymbol), {t = u} + {t <> u}.
Proof.
  destruct t as [n1], u as [n2].
  destruct (string_dec n1 n2); subst; prove_dec.
Defined.

(** decidability for constants *)
Lemma ProgramConstName_dec : forall (t u : ProgramConstName), {t = u} + {t <> u}.
Proof.
  destruct t as [n1], u as [n2].
  destruct (string_dec n1 n2); subst; prove_dec.
Defined.

(** decidability for constants *)
Lemma ODEConst_dec : forall (t u : ODEConst), {t = u} + {t <> u}.
Proof.
  destruct t as [n1], u as [n2].
  destruct (string_dec n1 n2); subst; prove_dec.
Defined.

(** decidability for KAssignables *)
Lemma KAssignable_dec : forall (t u : KAssignable), {t = u} + {t <> u}.
Proof.
  induction t as [v1|d1], u as [v2|d2]; prove_dec.
  { destruct (KVariable_dec v1 v2) as [d|d]; subst; prove_dec. }
  { destruct (IHd1 d2) as [d|d]; subst; prove_dec. }
Defined.

(** returns differential of some variable x *)
Definition DVar (x : KVariable) : KAssignable :=
  KAssignDiff (KAssignVar x).

Definition remove_var v l := remove_elt KVariable_dec v l.

Lemma not_in_remove_var :
  forall v l, ~ In v (remove_var v l).
Proof.
  introv; unfold remove_var; eauto with core.
Qed.
Hint Resolve not_in_remove_var : core.


Require Import bedrock2.NotationsCustomEntry.

Import Syntax Syntax.Coercions BinInt String List List.ListNotations.
Local Open Scope string_scope. Local Open Scope Z_scope. Local Open Scope list_scope.

Definition memequal := func! (x,y,n) ~> r {
  r = $0;
  while n {
    r = r | (load1(x) ^ load1(y));
    x = x + $1;
    y = y + $1;
    n = n - $1
  };
  r = r == $0
}.

Require Import bedrock2.WeakestPrecondition bedrock2.Semantics bedrock2.ProgramLogic.
Require Import coqutil.Word.Interface coqutil.Word.Bitwidth.
Require Import coqutil.Map.Interface bedrock2.Map.SeparationLogic.
Require Import bedrock2.ZnWords.
Import Coq.Init.Byte coqutil.Byte.
Local Notation string := String.string.

(*Require Import bedrock2.ptsto_bytes.*)
Local Notation "xs $@ a" := (Array.array ptsto (word.of_Z 1) a xs) (at level 10, format "xs $@ a").
Local Notation "m =* P" := ((P%sep) m) (at level 70, only parsing) (* experiment*).

Section WithParameters.
  Context {width} {BW: Bitwidth width}.
  Context {word: word.word width} {mem: map.map word byte} {locals: map.map string word}.
  Context {ext_spec: ExtSpec}.
  Import ProgramLogic.Coercions.

  Global Instance spec_of_memequal : spec_of "memequal" :=
    fnspec! "memequal" (x y n : word) / (xs ys : list byte) (Rx Ry : mem -> Prop) ~> r,
    { requires t m := m =* xs$@x * Rx /\ m =* ys$@y * Ry /\
                      length xs = n :>Z /\ length ys = n :>Z;
      ensures t' m' := m=m' /\ t=t' /\ (r = 0 :>Z \/ r = 1 :>Z) /\
                       (r  = 1 :>Z <-> xs  = ys) }.

  Context {word_ok: word.ok word} {mem_ok: map.ok mem} {locals_ok : map.ok locals}
    {env : map.map string (list string * list string * Syntax.cmd)} {env_ok : map.ok env}
    {ext_spec_ok : ext_spec.ok ext_spec}.

  Import coqutil.Tactics.letexists coqutil.Tactics.Tactics coqutil.Tactics.autoforward.
  Import coqutil.Word.Properties coqutil.Map.Properties.

  Local Ltac ZnWords := destruct width_cases; bedrock2.ZnWords.ZnWords.
  Lemma memequal_ok : program_logic_goal_for_function! memequal.
  Proof.
    repeat straightline.

    refine ((Loops.tailrec
      (HList.polymorphic_list.cons _
      (HList.polymorphic_list.cons _
      (HList.polymorphic_list.cons _
      (HList.polymorphic_list.cons _
      HList.polymorphic_list.nil))))
      ["x";"y";"n";"r"])
      (fun (v:nat) xs Rx ys Ry t m x y n r => PrimitivePair.pair.mk (
        m =* xs$@x * Rx /\  m =* ys$@y * Ry /\
        v=n :> Z /\ length xs = n :> Z /\ length ys = n :> Z
      )
      (fun                     T M (X Y N R : word) => m = M /\ t = T /\
        exists z, R = Z.lor r z :> Z /\ (z  = 0 :>Z <-> xs  = ys)
      ))
      lt
      _ _ _ _ _ _ _ _ _);
      (* TODO wrap this into a tactic with the previous refine *)
      cbn [HList.hlist.foralls HList.tuple.foralls
           HList.hlist.existss HList.tuple.existss
           HList.hlist.apply  HList.tuple.apply
           HList.hlist
           List.repeat Datatypes.length
           HList.polymorphic_list.repeat HList.polymorphic_list.length
           PrimitivePair.pair._1 PrimitivePair.pair._2] in *.
      { cbv [Loops.enforce]; cbn.
        subst l l0.
        repeat (rewrite ?map.get_put_dec, ?map.get_remove_dec; cbn); split.
        { exact eq_refl. }
        { eapply map.map_ext; intros k.
          repeat (rewrite ?map.get_put_dec, ?map.get_remove_dec, ?map.get_empty; cbn -[String.eqb]).
          repeat (destruct String.eqb; trivial). } }
      { eapply Wf_nat.lt_wf. }
      { cbn; ssplit; eauto. }
      { intros ?v ?xs ?Rx ?ys ?Ry ?t ?m ?x ?y ?n ?r.
        repeat straightline.
        cbn in localsmap.
        eexists n0; split; cbv [expr expr_body localsmap get].
        { rewrite ?Properties.map.get_put_dec. exists n0; cbn. auto. }
        split; cycle 1.
        { intros Ht; rewrite Ht in *.
          intuition idtac; destruct xs0, ys0; cbn in *; try discriminate; [].
          exists 0; intuition eauto. rewrite Z.lor_0_r. trivial. }

        intros Ht.
        destruct xs0 as [|hxs xs0] in *, ys0 as [|hys ys0] in *;
          cbn [length Array.array] in *; try (cbn in *; congruence); [];

        repeat straightline.
        eapply WeakestPreconditionProperties.dexpr_expr.

        repeat straightline.
        letexists; split.
        { rewrite ?Properties.map.get_put_dec; exact eq_refl. }
        repeat straightline.
        letexists; split.
        { rewrite ?Properties.map.get_put_dec; cbn. exact eq_refl. }
        repeat straightline.

        repeat straightline.
        repeat straightline.
        letexists; split.
        { rewrite ?Properties.map.get_put_dec; exact eq_refl. }
        repeat straightline.

        repeat straightline.
        eapply WeakestPreconditionProperties.dexpr_expr.
        letexists; split.
        { subst l. rewrite ?Properties.map.get_put_dec; cbn. exact eq_refl. }

        repeat straightline.
        eapply WeakestPreconditionProperties.dexpr_expr.
        letexists; split.
        { subst l l0. rewrite ?Properties.map.get_put_dec; cbn. exact eq_refl. }

        repeat straightline.
        eapply WeakestPreconditionProperties.dexpr_expr.
        letexists; split.
        { subst l l0 l1. rewrite ?Properties.map.get_put_dec; cbn. exact eq_refl. }

        repeat straightline.

        eexists _, _, _, _.
        split.
        { cbv [Loops.enforce l l0 l1 l2]; cbn.
          repeat (rewrite ?map.get_put_dec, ?map.get_remove_dec; cbn); split.
          { exact eq_refl. }
          { eapply map.map_ext; intros k.
            repeat (rewrite ?map.get_put_dec, ?map.get_remove_dec, ?map.get_empty; cbn -[String.eqb]).
            repeat (destruct String.eqb; trivial). } }
        eexists _, _, _, _, (length xs0); split; ssplit.
        { ecancel_assumption. }
        { ecancel_assumption. }
        { ZnWords. }
        { ZnWords. }
        { ZnWords. }
        split.
        { cbn in *; ZnWords. }
        intuition idtac; repeat straightline_cleanup.
        rewrite H10, word.unsigned_or_nowrap, <-Z.lor_assoc.
        eexists; split; trivial.
        transitivity (hxs = hys /\ xs0 = ys0); [|intuition congruence].
        rewrite <-H11. rewrite Z.lor_eq_0_iff. eapply and_iff_compat_r.
        subst v0 v1. rewrite word.unsigned_xor_nowrap, Z.lxor_eq_0_iff.
        split; [|intros;subst;trivial].
        intro HH.
        pose proof byte.unsigned_range hxs;
        pose proof byte.unsigned_range hys.
        eapply word.unsigned_inj in HH; eapply word.of_Z_inj_small in HH; try ZnWords.
        eapply byte.unsigned_inj in HH; trivial. }

      intuition idtac. case H6 as (?&?&?). subst. subst r.
      eapply WeakestPreconditionProperties.dexpr_expr.
      letexists; split; cbn.
      { rewrite ?Properties.map.get_put_dec; cbn; exact eq_refl. }
      eexists; split; cbn.
      { rewrite ?Properties.map.get_put_dec; cbn; exact eq_refl. }

      rewrite word.unsigned_of_Z_0, Z.lor_0_l in H5; subst x4 v.
      setoid_rewrite word.unsigned_eqb; setoid_rewrite word.unsigned_of_Z_0.
      eexists; ssplit; eauto; destr Z.eqb; autoforward with typeclass_instances in E;
        rewrite ?word.unsigned_of_Z_1, ?word.unsigned_of_Z_0; eauto.
      all : intuition eauto; discriminate.
  Qed.
End WithParameters.


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*   Author: Yu Guo <guoyu@ustc.edu.cn>                                       *)
(*                          School of Computer Science and Technology, USTC   *)
(*                                                                            *)
(*           Bihong Zhang <sa614257@mail.ustc.edu.cn>                         *)
(*                                     School of Software Engineering, USTC   *)
(*                                                                            *)
(* ************************************************************************** *)

(*

*)

(* ************* ************************************* *****)
(* ftl interface *)

Require Import ListEx.
Require Import Monad.
Require Import Data.
Require Import Params.
Require Import Nand.

(*
Cache mapping table

The cmt_record is (lpn,ppn,flag,time).The init cmt is all the cmt_empty.
*)

Inductive flag :Set :=
 | dirty:flag
 | clean:flag.

Inductive cmt_record: Set :=
| cmt_empty
| cmt_trans(lpn:page_no)(pbn:block_no)(offset:nat)(is_dirty:flag).

Definition cache_mapping_table := list cmt_record.

Fixpoint  find_empty_cmt(cmt:cache_mapping_table) (i:nat): option nat :=
  match cmt with
  | nil => None
  | cons a cmt' => match a with
                     | cmt_empty => Some i
                     | _ => find_empty_cmt cmt' (S i)
                   end
end.

Definition cmt_get(cmt : cache_mapping_table) (loc: nat) : option cmt_record :=
  list_get cmt loc.

Definition cmt_set(cmt: cache_mapping_table) (loc: nat) (newrecord:cmt_record): option cache_mapping_table :=
  list_set cmt loc newrecord.

Definition cmt_get_trans(record:cmt_record) : option (prod (prod block_no page_no) flag)  :=
  match record with
      | cmt_empty => None
      | cmt_trans lpn pbn off f => ret((pbn,off),f)
end.

Fixpoint cmt_in (cmt:cache_mapping_table) (lpn:page_no) :bool :=
  match cmt with
      | nil => false
      | cons a cmt' => match a with
                           | (cmt_trans lpn' _ _ _) => if beq_nat lpn lpn' then true else cmt_in cmt' lpn
                           | _ => cmt_in cmt' lpn
                       end
  end.

Fixpoint find_cmtrecord(cmt:cache_mapping_table)(lpn:page_no)(i:nat) : option nat :=
  match cmt with
    | nil => None
    | cons a cmt' => match a with
                         |(cmt_trans lpn' _ _ _) =>if beq_nat lpn' lpn then Some i else find_cmtrecord cmt' lpn (S i)
                         | _ => find_cmtrecord cmt' lpn (S i)
                     end
end.

Fixpoint remove_cmt(cmt:cache_mapping_table) (lpn:page_no):  cache_mapping_table :=
  match cmt with
    | nil => nil
    | cons a cmt' => match a with
                         |(cmt_trans lpn' _  _ _) =>if beq_nat lpn' lpn then cmt' else cons a (remove_cmt cmt' lpn)
                         | _ => cons a (remove_cmt cmt' lpn)
                     end
end.

Fixpoint insert_cmt (cmt:cache_mapping_table) (record:cmt_record) (num:nat) :cache_mapping_table :=
  match num with
      | O => cons record cmt
      | S i => match cmt with
                 | nil => nil
                 | cons a cmt' => (cons a (insert_cmt cmt' record i ) )
                end
   end.

Definition remove_head(cmt:cache_mapping_table) : option cache_mapping_table :=
  match cmt with
      | nil => None
      | cons a cmt' => Some cmt'
end.

Fixpoint append_tail(cmt:cache_mapping_table)(newrecord:cmt_record) : cache_mapping_table :=
  match cmt with
      | nil => cons newrecord nil
      | cons a nil => cons a (cons newrecord nil)
      | cons a cmt' => cons a (append_tail cmt' newrecord)
end.

(*Init the cache mapping table *)
Fixpoint init_cmt(cmt:cache_mapping_table)(i:nat): option cache_mapping_table :=
  match i with
|  O => None
|  S O => Some cmt
|  S i' => init_cmt (list_append cmt cmt_empty) i'
end.

Definition blank_cmt : cache_mapping_table :=
  list_repeat_list CMT_LENGTH cmt_empty.

(*
Global translation table

The length of the gtd is fixed.The record is(index,ppn).
*)

Inductive gtd_record: Set :=
| gtd_empty
| gtd_trans (pbn:block_no) (offset:nat ).

Definition global_mapping_directory := list gtd_record.

(* Definition gtd_len(gtd:global_mapping_directory) : nat :=  *)
(*   length gtd. *)

Definition gtd_get(gtd:global_mapping_directory)(loc: nat) : option gtd_record :=
  list_get gtd loc.

Definition gtd_set(gtd:global_mapping_directory) (loc: nat) (newrecord:gtd_record): option global_mapping_directory :=
  list_set gtd loc newrecord.

(* SearchAbout andb. *)
Fixpoint gtd_look_by_record(gtd:global_mapping_directory)(lbn:block_no) (off:nat) (num:nat) : option nat :=
  match gtd with
      | nil  => None
      | cons record' gtd' => match record' with
                                 | gtd_empty => gtd_look_by_record gtd' lbn off (S num)
                                 | gtd_trans lbn' off' => if andb (beq_nat lbn lbn') (beq_nat off off')  then Some num else gtd_look_by_record gtd' lbn off (S num)

                             end
end.

Fixpoint gtd_look_by_lpn (gtd:global_mapping_directory) (lpn:page_no) (num:nat):option nat :=
  match gtd with
      | nil => None
      | cons record' l => if ble_nat lpn (pred ((S num) * RECORD_PER_TRANS)) then Some num else gtd_look_by_lpn l lpn (S num)
 end.

Definition  gtd_get_trans_by_lpn(gtd:global_mapping_directory)(lpn:page_no):option (prod nat nat) :=
  do gtd_loc <-- gtd_look_by_lpn gtd lpn 0;
  do record <-- gtd_get gtd gtd_loc;
  match record with
      | gtd_empty => None
      | gtd_trans pbn off => ret (pbn,off)
end.

Fixpoint init_gtd(gtd:global_mapping_directory)(i:nat): option global_mapping_directory :=
  match i with
|  O => None
|  S O => Some gtd
|  S i' => init_gtd (list_append gtd gtd_empty) i'
end.

Definition blank_gtd : global_mapping_directory :=
  list_repeat_list GTD_LENGTH gtd_empty.

(* Compute ( *)
(*  do gtd <-- Some blank_gtd; *)
(*  do i <-- gtd_look_by_lpn gtd 7 0; *)
(*  ret i *)
(* ). *)
(*
Trans_page data

The data of trans_page is (lpn,ppn)
*)

(* Inductive trans_record: Set := *)
(*   | trans_empty *)
(*   | trans_data(lpn:page_no)(ppn:page_no). *)

(* Definition trans_page := list trans_record. *)

(* Definition trans_len(trans:trans_page) : nat :=  *)
(*   length trans. *)

(* Definition trans_get(trans:trans_page)(loc: nat) : option trans_record := *)
(*   list_get trans loc. *)

(* Definition trans_set(trans:trans_page) (loc: nat) (newrecord:trans_record): option trans_page := *)
(*   list_set trans loc newrecord. *)

(*
FTL block state
*)

Inductive ftl_block_state : Set :=
  | bs_invalid
  | bs_erased
  | bs_data
  | bs_trans.

Inductive ftl_page_state : Set :=
  | ps_invalid
  | ps_erased
  | ps_data  (lpn:page_no)
  | ps_trans (gtd_loc:nat).

Definition page_state_table := list ftl_page_state.

Definition pst_get(pst:page_state_table)(loc: nat) : option ftl_page_state :=
  list_get pst loc.

Definition pst_set(pst:page_state_table) (loc: nat) (newstate:ftl_page_state): option page_state_table :=
  list_set pst loc newstate.

Definition pst_set_all (state:ftl_page_state):page_state_table  :=
  list_repeat_list  PAGES_PER_BLOCK state.

(*
Block_info_table
*)

Record block_info : Set :=
  mk_bi {
      bi_state: ftl_block_state;
      bi_used_pages: nat;
      bi_erase_count: nat;
      bi_page_state: page_state_table
    }.

Definition block_info_table :=  list block_info.

Definition bi_set_state (bi : block_info) (bi_state : ftl_block_state) : block_info :=
  mk_bi bi_state (bi_used_pages bi) (bi_erase_count bi) (bi_page_state bi).

(* set both the block and page state *)
Definition pi_set_state (bi : block_info) (bi_state : ftl_block_state) (bi_page_state:page_state_table) : block_info :=
  mk_bi bi_state (bi_used_pages bi) (bi_erase_count bi) bi_page_state.

Definition bit_get (bit: block_info_table) (b: block_no)
     : option block_info :=
  list_get bit b.

Definition bit_update (bit: block_info_table) (b: block_no) (bi: block_info)
      : option block_info_table :=
  list_set bit b bi.

(* In FTL, a block is initialized to be 'bs_invalid' *)
Definition blank_bi : block_info :=
  mk_bi bs_erased 0 0 (pst_set_all ps_erased).

(*
Free block queue

Free blocks are those not used, and each of them can be invalid or
erased (filled with \og{0xFF}). All the free blocks are put into a
queue, where a new allocated block is get from the head.
*)

Definition block_queue := list block_no.

Definition fbq_enq (fbq : block_queue) (b : block_no) : option (block_queue) :=
  Some (list_append fbq b).

Definition fbq_deq (fbq : block_queue) : option (prod block_no (block_queue)) :=
  match fbq with
    | nil => None
    | cons b fbq' => Some (b, fbq')
  end.

Definition fbq_in (fbq: list block_no) (pbn: block_no) : bool := list_inb beq_nat fbq pbn.

Definition fbq_get (fbq: list block_no) (i: nat) : option block_no := list_get fbq i.

Definition check_block_is_full (bi: block_info) : bool :=
  match blt_nat (bi_used_pages bi) PAGES_PER_BLOCK with
    | true => false
    | false => true
  end.

(*

Currnt data/translation block

*)

(* Definition current_data_block := block_no. *)

(* Definition current_trans_block := block_no. *)

(*
FTL structure
*)

Record FTL : Set :=
  mk_FTL {
      ftl_bi_table: block_info_table;
      ftl_free_blocks: block_queue;
      ftl_cmt_table:cache_mapping_table;
      ftl_gtd_table:global_mapping_directory;
      current_data_block:block_no;
      current_trans_block:block_no
    }.

Definition ftl_update_bit (f: FTL) (bit: block_info_table) : option FTL :=
  ret mk_FTL bit (ftl_free_blocks f) (ftl_cmt_table f) (ftl_gtd_table f) (current_data_block f) (current_trans_block f).

Definition ftl_update_fbq (f: FTL) (fbq: block_queue) : option FTL :=
  ret mk_FTL (ftl_bi_table f) fbq  (ftl_cmt_table f) (ftl_gtd_table f) (current_data_block f) (current_trans_block f).

Definition ftl_update_cmt (f: FTL) (cmt: cache_mapping_table) : option FTL :=
  ret mk_FTL (ftl_bi_table f)  (ftl_free_blocks f) cmt (ftl_gtd_table f) (current_data_block f) (current_trans_block f).

Inductive freebq_state : Set :=
  | fbqs_abundant
  (* | fbqs_needgc *)
  | fbqs_scarce.

(* IMPORTANT !!! *)
Definition check_freebq_count (freebq: block_queue): freebq_state :=
  match (ble_nat MIN_FREE_BLOCKS (length freebq)) with
    | false => fbqs_scarce
    | true => fbqs_abundant
  end.

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

   * ReadBlock/WriteBlock Operations
*)

Definition read_block (c: chip) (pbn: block_no) (off: page_off) : option data :=
  (* read the page from "off" in pbn_data *)
  do [d, o] <-- (nand_read_page c pbn off);

  (* return the data in the page *)
  ret d.

Definition read_block_oob (c: chip) (pbn: block_no) (off: page_off) : option (prod data page_oob_nat) :=
  (* read the page from "off" in pbn_data *)
  do [d, o] <-- (nand_read_page c pbn off);
  ret (d,o).

Definition write_data_block (c: chip) (pbn_bi: block_info) (pbn: block_no)
           (loc: page_off) (d: data) (oob:page_oob_nat)(page_state:ftl_page_state): option (prod chip block_info) :=
  (* write the data to "pbn#loc", return c' *)
  let pst := bi_page_state pbn_bi in
  do c' <-- (nand_write_page c pbn loc d oob);
  do pst' <-- pst_set pst loc page_state;
  (* return bi := <bi_state, used+1, ec> *)
  let bi' := mk_bi (bi_state pbn_bi) ((bi_used_pages pbn_bi)+1) (bi_erase_count pbn_bi) pst' in

  ret  (c', bi').

(* Definition read_trans_block (c: chip) (bi: block_info) (pbn_log: block_no) (off: page_off) : option data := *)
(*   (* find the lastest log page for "poff" in 'bk' , return the log-location *) *)
(*   do loc <-- (find_page_in_log_block bi off); *)

(*   (* read the page from "loc" in pbn_log *) *)
(*   do [d, o] <-- (nand_read_page c pbn_log loc);  *)

(*   (* return the data in the page *) *)
(*   ret d. *)

(* Definition write_trans_block *)

(*
FTL read algorithm

*)

(* ****************************************************
* Alloc_Block

Allocation block routine, no GC yet. But I believe that it will be
not difficult to add a simple GC.

*)

Definition alloc_block (c: chip) (f: FTL) : option (prod block_no (prod chip FTL)) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  match (check_freebq_count fbq) with
    | fbqs_abundant =>
        do [b, fbq'] <-- fbq_deq fbq;
        do bi_free <-- bit_get bit b;
        match bi_state bi_free with
          | bs_erased =>
              (* TODO:  we don't need to update bit. No,we need,we set the used_pages and pages_state *)
              do bit' <-- bit_update bit b (mk_bi bs_erased 0 (bi_erase_count bi_free) (pst_set_all ps_erased));
              ret (b, (c, (mk_FTL bit'  fbq' (ftl_cmt_table f) (ftl_gtd_table f) (current_data_block f) (current_trans_block f) )))
          | bs_invalid =>
              do c' <-- nand_erase_block c b;
              do bit' <-- bit_update bit b (mk_bi bs_erased 0 (1 + bi_erase_count bi_free) (pst_set_all ps_erased));
              ret (b, (c',(mk_FTL bit' fbq' (ftl_cmt_table f) (ftl_gtd_table f) (current_data_block f) (current_trans_block f) )))

          | bs_data => None

          | bs_trans => None
        end

    | _ => None
  end.

Definition bit_set_state (bit: block_info_table) (pbn: block_no) (st: ftl_block_state) (pst:page_state_table)
  : option block_info_table :=
  do bi <-- bit_get bit pbn;
  do bi' <-- Some (mk_bi st (bi_used_pages bi) (bi_erase_count bi) pst);
  do bit' <-- bit_update bit pbn bi';
  ret bit'.

Definition bit_get_bstate (f: FTL) (pbn: block_no) : option ftl_block_state :=
  do bi <-- bit_get (ftl_bi_table f) pbn;
  ret (bi_state bi).

(* ****************************************************
* Auxiliary Routines for update Meta-Data
*)

Definition free_block (bit: block_info_table) (fbq: block_queue) (pbn: block_no)
  : option (prod block_info_table block_queue) :=
  do bi <-- bit_get bit pbn;
  do pst <-- Some (pst_set_all ps_invalid);
  do bi' <-- Some (mk_bi bs_invalid (bi_used_pages bi) (bi_erase_count bi) pst);
  do bit' <-- bit_update bit pbn bi';
  do fbq' <-- fbq_enq fbq pbn;
  ret (bit', fbq').

Definition zero_page := (zero_data PAGE_DATA_SIZE).

(*
* Check the current_data_block and current_trans_block
*)

Definition check_current_block(bit:block_info_table) (pbn: block_no):option bool :=
  do bi <-- bit_get bit pbn;
  match check_block_is_full bi with
     | false => Some false
     | true => Some true
  end.

Fixpoint find_trans_in_metatrans(l:meta_trans_record_list) (lpn:page_off) : option (prod nat nat) :=
  match l with
      | nil => None
      | cons record l' =>match record with
                             | trans_empty => find_trans_in_metatrans l' lpn
                             | trans_data lpn' pbn' off' => if beq_nat lpn lpn' then Some (pbn',off') else find_trans_in_metatrans l' lpn
                          end
end.

(* Definition div (n1:nat)(n2:nat):nat := 1. *)

(* Definition mod (n1:nat)(n2:nat):nat := 1. *)

Definition check_block_full(bi:block_info): bool :=
  do num <<-- (bi_used_pages bi);
  match blt_nat num PAGES_PER_BLOCK with
      | true =>  false
      | false => true
 end.

(**********************************************************************)

(*
Init the ftl and nand
*)
Definition bit_init : block_info_table :=
  list_repeat_list BLOCKS blank_bi.

Definition cmt_init :cache_mapping_table := blank_cmt.

Definition gtd_init_empty : global_mapping_directory := blank_gtd.

Definition fbq_init : block_queue :=
  list_make_nat_list BLOCKS.

Definition bit_init_current:option block_info_table :=
  do bit <-- Some bit_init;
  do bit' <-- bit_update bit 0 (mk_bi bs_data 0 0 (pst_set_all ps_erased) );
  do bit'' <-- bit_update bit' 1 (mk_bi bs_trans 0 0  (pst_set_all ps_erased) );
  ret bit''.

Definition fbq_init_current:option block_queue :=
  do [_,fbq'] <-- fbq_deq fbq_init;
  do [_,fbq''] <-- fbq_deq fbq';
  ret fbq''.

Definition ftl_init : option FTL :=
   do bit <-- bit_init_current;
   do fbq <-- fbq_init_current;
   ret (mk_FTL bit fbq cmt_init gtd_init_empty 0 1).

(* Fixpoint gtd_init_trans(c:chip) (f:FTL) (gtd:global_mapping_table) (num:nat):option FTL := *)
(*   match num with *)
(*       | O => ret f *)
(*       | S i => do cur_trans <-- Some (current_trans_block f); *)
(*                do bit <-- ftl_bi_table f; *)
(*                do cur_trans_bi <-- bit_get bit cur_trans; *)
(*                match  check_block_full cur_trans_bi with *)
(*                    | false => do off <-- Some (bi_used_pages cur_trans_bi); *)
(*                               do gtd' <-- gtd_set gtd (minus 32 num) (gtd_trans cur_trans off); *)
(*                               do bit' <-- bit_update bit'; *)
(*                               do f' <-- (mk_FTL ( *)

(*
The meta_trans_data Definition && Operations

*)
Definition data_metatrans_get(dmt : meta_trans_record_list) (loc: nat) : option trans_record :=
  list_get dmt loc.

Definition data_metatrans_set(dmt: meta_trans_record_list) (loc: nat) (newrecord:trans_record): option meta_trans_record_list :=
  list_set dmt loc newrecord.

Definition blank_dmt :meta_trans_record_list  :=
  list_repeat_list RECORD_PER_TRANS trans_empty.

Fixpoint find_meta_trans_record(l:meta_trans_record_list)(lpn:page_no)(i:nat) :option nat :=
  match l with
      | nil =>None
      | cons record l' =>  match record with
                           | trans_empty => find_meta_trans_record l' lpn (S i)
                           | trans_data lpn' _ _ => if beq_nat lpn lpn' then Some i else find_meta_trans_record l' lpn (S i)
                          end
end.

Fixpoint find_meta_trans_empty(l:meta_trans_record_list)(lpn:page_no)(i:nat) :option nat :=
  match l with
      | nil =>None
      | cons record l' =>  match record with
                           | trans_empty => Some i
                           | trans_data lpn' _ _ => find_meta_trans_empty l' lpn (S i)
                          end
end.

Fixpoint get_meta_trans_record (l:meta_trans_record_list)(lpn:page_no)(i:nat) : option (prod block_no page_no) :=
  (* do i <-- find_meta_trans_record l lpn 0; *)
  do record <-- data_metatrans_get l i;
  match record with
      | trans_data lpn pbn off => ret (pbn,off)
      | _ => None
  end.

Fixpoint copy_data_trans(l:meta_trans_record_list) (lpn:page_no) (newrecord:trans_record) : option meta_trans_record_list :=
  match find_meta_trans_record l lpn 0 with
      | Some loc => do l' <-- data_metatrans_set l loc newrecord;
                    ret l'
      | None => do empty_loc <-- find_meta_trans_empty l lpn 0;
                do l' <-- data_metatrans_set l empty_loc newrecord;
                ret l'
   end.

(*
Invalid the block page
*)
Definition invalid_old_page(bit:block_info_table)(pbn:block_no)(off:nat) :option block_info_table :=
  do bi <-- bit_get bit pbn;
  do pst <-- Some (bi_page_state bi);
  do pst' <--  pst_set pst off ps_invalid;
  do bi' <-- Some (pi_set_state bi (bi_state bi) pst');
  do bit' <-- bit_update bit pbn bi';
  ret bit'.

(*
copy the trans_page_data(trans_pbn,trans_off) to current block  page or new allock page
for updating the pbn off
*)

Definition copy_trans_page(c:chip)(f:FTL)(lpn:page_no)(trans_pbn:block_no)(trans_off:nat)(pbn:block_no)(off:nat): option (prod chip FTL) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  let cur_trans := current_trans_block f in
  let cur_data := current_data_block f in
  do d <-- read_block c trans_pbn trans_off;
  match d with
    | metabyte _ => None
    | metarecord meta_list => do new_list <-- copy_data_trans meta_list lpn (trans_data lpn pbn off);
                              do cur_bi <-- bit_get bit cur_trans;
                              do gtd_loc <-- gtd_look_by_lpn gtd lpn 0;
                              match check_block_full cur_bi with
                                | true =>(* If it is full *)
                                         do [new_trans,cfx] <-- alloc_block c f;
                                         do [c',f'] <-- Some cfx;
                                         do bi <-- bit_get (ftl_bi_table f') new_trans;
                                         do bi' <-- Some (bi_set_state bi bs_trans);
                                         (* Repeat *)
                                         do [c'',bi''] <-- write_data_block c' bi' new_trans 0 (metarecord new_list) (Some (gtd_loc, 0)) (ps_trans gtd_loc);
                                         do bit' <-- bit_update (ftl_bi_table f') new_trans bi'';
                                         (*Invalidate the old trans one*)
                                         do bit'' <-- invalid_old_page bit' trans_pbn trans_off;
                                         (*Invalidate the old data one*)
                                         match find_meta_trans_record meta_list lpn 0 with
                                             | None =>  (* update the gtd *)
                                                        do gtd' <-- gtd_set gtd gtd_loc (gtd_trans new_trans 0) ;
                                                        ret(c'',(mk_FTL bit'' (ftl_free_blocks f') (ftl_cmt_table f') gtd' cur_data new_trans) )

                                             | Some i => do [old_data,old_off] <--  get_meta_trans_record meta_list lpn i;
                                                         do bit''' <-- invalid_old_page bit'' old_data old_off;
                                                         do gtd' <-- gtd_set gtd gtd_loc (gtd_trans new_trans 0) ;
                                                         ret(c'',(mk_FTL bit''' (ftl_free_blocks f') (ftl_cmt_table f') gtd' cur_data new_trans) )
                                        end

                                | false =>
                                           do cur_off <-- Some (bi_used_pages cur_bi);
                                           do [c',bi'] <-- write_data_block c cur_bi cur_trans cur_off (metarecord new_list) (Some(gtd_loc, 0)) (ps_trans gtd_loc);
                                           do bit' <-- bit_update bit cur_trans bi';
                                           (*Invalide the old trans page*)
                                           do bit'' <-- invalid_old_page bit' trans_pbn trans_off;
                                           (*Invalidate the old data one*)
                                           match find_meta_trans_record meta_list lpn 0 with
                                             | None =>  (* update the gtd,find the gtd_loc *)
                                                        do gtd' <-- gtd_set gtd gtd_loc (gtd_trans cur_trans cur_off);
                                                        ret (c',(mk_FTL bit'' fbq cmt  gtd' cur_data cur_trans ) )

                                             | Some i => do [old_data,old_off] <--  get_meta_trans_record meta_list lpn i;
                                                         do bit''' <-- invalid_old_page bit'' old_data old_off;
                                                         (* update the gtd,find the gtd_loc *)
                                                         do gtd' <-- gtd_set gtd gtd_loc (gtd_trans cur_trans cur_off);
                                                         ret (c',(mk_FTL bit''' fbq cmt  gtd' cur_data cur_trans ) )
                                            end
                               end
end.

Definition write_trans_page(c:chip)(f:FTL)(lpn:page_no) (pbn:block_no)(off:nat): option (prod chip FTL) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  let cur_trans := current_trans_block f in
  let cur_data := current_data_block f in
  do meta_list <-- Some (blank_dmt);
  do new_list <-- copy_data_trans meta_list lpn (trans_data lpn pbn off);
  do cur_bi <-- bit_get bit cur_trans;
  do gtd_loc <-- gtd_look_by_lpn gtd lpn 0;
  match check_block_full cur_bi with
       | true =>(* If it is full *)
             do [new_trans,cfx] <-- alloc_block c f;
             do [c',f'] <-- Some cfx;
             do bi <-- bit_get (ftl_bi_table f') new_trans;
             do bi' <-- Some (bi_set_state bi bs_trans);
             (* Repeat *)
             do [c'',bi''] <-- write_data_block c' bi' new_trans 0 (metarecord new_list) (Some (gtd_loc, 0)) (ps_trans gtd_loc);
             do bit' <-- bit_update (ftl_bi_table f') new_trans bi'';
             do gtd' <-- gtd_set gtd gtd_loc (gtd_trans new_trans 0) ;
             ret(c'',(mk_FTL bit' (ftl_free_blocks f') (ftl_cmt_table f') gtd' cur_data new_trans) )

       | false =>
            do cur_off <-- Some (bi_used_pages cur_bi);
            do [c',bi'] <-- write_data_block c cur_bi cur_trans cur_off (metarecord new_list) (Some (gtd_loc, 0)) (ps_trans gtd_loc);
            do bit' <-- bit_update bit cur_trans bi';
            do gtd' <-- gtd_set gtd gtd_loc (gtd_trans cur_trans cur_off);
            ret (c',(mk_FTL bit' fbq cmt  gtd' cur_data cur_trans ) )
end.

Definition FTL_read(c:chip)(f:FTL)(lpn:page_no) : option (prod data (prod chip FTL) ) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  (* test valid_page_off off; *)
  (* If the lpn in the cmt *)
  match find_cmtrecord cmt lpn 0 with
      | Some num =>
                  (* Do the read change the priitoty *)
                  do record <-- cmt_get cmt num;
                  match record with
                   | cmt_empty => None
                   | cmt_trans lpn' pbn' off' flag' =>
                                              match find_empty_cmt cmt 0 with
                                                  | None =>  do cmt' <-- Some (remove_cmt cmt lpn);
                                                             do cmt'' <-- Some (append_tail cmt' record);
                                                             do d <-- read_block c pbn' off';
                                                             ret (d,(c,mk_FTL (ftl_bi_table f) (ftl_free_blocks f) cmt'' (ftl_gtd_table f) (current_data_block f) (current_trans_block f) ) )
                                                  | Some i => do cmt' <-- Some (remove_cmt cmt lpn);
                                                              do cmt'' <-- Some (insert_cmt cmt' record (pred i) );
                                                              do d <-- read_block c pbn' off';
                                                              ret (d,(c,mk_FTL (ftl_bi_table f) (ftl_free_blocks f) cmt'' (ftl_gtd_table f) (current_data_block f) (current_trans_block f) ) )
                                               end
                  end
      | None => do gtd_loc <-- gtd_look_by_lpn gtd lpn 0;
                do gtd_record <-- gtd_get gtd gtd_loc;
                match gtd_record with
                   | gtd_empty => None
                   | gtd_trans trans_lbn trans_offset =>
                             do [data,oob] <-- nand_read_page c trans_lbn trans_offset;
                             match data with
                                   | metabyte _ => None
                                   | metarecord meta_trans_list =>do [data_pbn,data_off] <-- find_trans_in_metatrans meta_trans_list lpn;
                                                                  match find_empty_cmt cmt 0 with
                                                                    | Some i =>(* Thec cmt is not full ,still have empty location *)
                                                                               (* If find the empty the empty must in the end,cmt_set and append_tail is both ok *)
                                                                               do newcmt <-- cmt_set cmt i (cmt_trans lpn data_pbn data_off clean);
                                                                               do d <-- read_block c data_pbn data_off;
                                                                               ret (d,(c,mk_FTL (ftl_bi_table f) (ftl_free_blocks f) newcmt (ftl_gtd_table f) (current_data_block f) (current_trans_block f)))

                                                                    | None =>  (*If it doesn't find the empty,the cmt is full *)
                                                                               do head <-- cmt_get cmt 0;
                                                                               match head with
                                                                                | cmt_trans h_lpn h_pbn h_off flag'' =>
                                                                                match flag'' with
                                                                                | clean =>
                                                                                do newcmt' <-- remove_head cmt;
                                                                                do newcmt'' <-- Some (append_tail newcmt' (cmt_trans lpn data_pbn data_off clean) );
                                                                                do d <-- read_block c data_pbn data_off;
                                                                                ret (d,(c,mk_FTL (ftl_bi_table f) (ftl_free_blocks f) newcmt'' (ftl_gtd_table f) (current_data_block f) (current_trans_block f)))
                                                                                | drity =>
                                                                                (* it is dirty *)
                                                                                (*find the the trans_page for h_lpn *)
                                                                                do newcmt' <-- remove_head cmt;
                                                                                do newcmt'' <-- Some (append_tail newcmt' (cmt_trans lpn data_pbn data_off clean) );
                                                                                do newf <-- ftl_update_cmt f newcmt'';
                                                                                do d <-- read_block c data_pbn data_off;
                                                                                match gtd_get_trans_by_lpn gtd h_lpn with
                                                                                | Some _ =>
                                                                                do [h_trans_pbn,h_trans_off] <-- gtd_get_trans_by_lpn gtd h_lpn;
                                                                                do [c',f'] <-- copy_trans_page c newf h_lpn h_trans_pbn h_trans_off h_pbn h_off;
                                                                                ret (d,(c', f'))
                                                                                | None =>
                                                                                do [c',f'] <-- write_trans_page c newf h_lpn h_pbn h_off;
                                                                                ret (d,(c',f'))
                                                                                end
                                                                                end
                                                                                | cmt_empty => None
                                                                               end

                                                                    end

                                end
                  end
end.

(* Definition gtd_set_trans(c:chip) (f:FTL) (lpn:nat) :option (prod FTL) := *)
(*   let bit := ftl_bi_table f in *)
(*   let fbq := ftl_free_blocks f in *)
(*   let cmt := ftl_cmt_table f in *)
(*   let gtd := ftl_gtd_table f in *)
(*   let cur_trans := current_trans_block f in *)
(*   let cur_data := current_data_block f in *)
(*   do loc <-- gtd_look_by_lpn gtd lpn;  *)
(*   do cur_trans_bi <-- bit_get bit cur_trans; *)
(*   match check_block_full cur_trans_bi with *)
(*       | false => do off <-- Some (bi_used_pages cur_trans_bi); *)
(*                  do gtd'<-- gtd_set gtd loc (gtd_trans cur_trans off); *)
(*                  do pst <-- Some (bi_page_state cur_trans_bi); *)
(*                  do pst' <-- pst_set pst off (ps_trans loc); *)
(*                  do new_bi <-- Some (mk_bi (bi_state cur_trans) ((bi_used_pages cur_trans) + 1) (bi_erase_count cur_trans) pst'); *)
(*                  do bit' <-- bit_update bit cur_trans new_bi; *)
(*                  ret (mk_FTL bit' fbq cmt gtd' cur_data cur_trans); *)

(*       | true => do [c',f'] <-- alloc c f; *)

Definition cmt_update_when_ftl_write(c:chip) (f:FTL) (lbn:block_no) (loff:nat):option (prod chip FTL) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  let cur_trans := current_trans_block f in
  let cur_data := current_data_block f in
  let lpn := lbn * PAGES_PER_BLOCK + loff in
  do bi <-- bit_get bit cur_data;
  do poff <-- Some (pred (bi_used_pages bi) );
  match find_cmtrecord cmt lpn 0 with
                     (* The cmt don't have the record *)
                     | None =>
                           match find_empty_cmt cmt 0 with
                                (* find the cmt is not full *)
                               | Some i => do cmt' <-- cmt_set cmt i (cmt_trans lpn cur_data poff dirty);
                                           ret (c,mk_FTL bit fbq cmt' gtd cur_data cur_trans)
                               | None  =>  do record <-- cmt_get cmt 0;
                                           match record with
                                               | cmt_empty => None
                                               | cmt_trans h_lpn h_pbn h_off h_flag =>
                                                       do cmt' <-- remove_head cmt;
                                                       do cmt'' <-- Some (append_tail cmt' (cmt_trans lpn cur_data poff dirty) );
                                                       match h_flag with
                                                           | clean =>  ret (c,mk_FTL bit fbq cmt'' gtd cur_data cur_trans)
                                                           | dirty =>  (*TO DO-->Done,This is not the invalid data*)
                                                                      match gtd_get_trans_by_lpn gtd h_lpn with
                                                                          | Some _ =>
                                                                                do [h_trans_pbn,h_trans_off] <-- gtd_get_trans_by_lpn gtd h_lpn;
                                                                                do new_f <-- Some (mk_FTL bit fbq cmt'' gtd cur_data cur_trans);
                                                                                do [c'',new_f'] <-- copy_trans_page c new_f  h_lpn h_trans_pbn h_trans_off h_pbn h_off;
                                                                                ret (c'',new_f')
                                                                          | None => (* The gtd loc is empty *)
                                                                                do f' <-- ftl_update_cmt f cmt'';
                                                                                do [c',f''] <-- write_trans_page c f' h_lpn h_pbn h_off;
                                                                                ret (c',f'')
                                                                       end
                                                       end
                                           end

                           end
                     (* It is in the cmt *)
                     | Some i => do record <-- cmt_get cmt i;
                                 do [old_pbn_off,f] <-- cmt_get_trans record;
                                 (* The old data_one *)
                                 do [old_pbn,old_off] <-- Some old_pbn_off;
                                 (* do cmt' <-- cmt_set cmt i (cmt_trans lpn cur_data poff dirty); *)
                                 match find_empty_cmt cmt 0 with
                                     | None => do cmt' <-- Some (remove_cmt cmt lpn);
                                               do cmt'' <-- Some (append_tail cmt' (cmt_trans lpn cur_data poff dirty) );
                                               match f with
                                                 | dirty => do bit' <-- invalid_old_page bit old_pbn old_off;
                                                           do new_f <-- Some (mk_FTL bit' fbq cmt'' gtd cur_data cur_trans);
                                                           ret (c,new_f)
                                                 | clean => (*TO DO-->Done,invalid is lazy*)
                                                            do new_f <-- Some (mk_FTL bit fbq cmt'' gtd cur_data cur_trans);
                                                            ret(c,new_f)
                                               end
                                    | Some empty_loc =>  do cmt' <-- Some (remove_cmt cmt  lpn);
                                                         do cmt'' <-- Some (insert_cmt cmt' (cmt_trans lpn cur_data poff dirty) (pred empty_loc) );
                                                          match f with
                                                            | dirty => do bit' <-- invalid_old_page bit old_pbn old_off;
                                                                      do new_f <-- Some (mk_FTL bit' fbq cmt'' gtd cur_data cur_trans);
                                                                      ret (c,new_f)
                                                            | clean => (*TO DO-->Done,invalid is lazy*)
                                                                      do new_f <-- Some (mk_FTL bit fbq cmt'' gtd cur_data cur_trans);
                                                                      ret(c,new_f)
                                                           end
                                 end

    end.

Fixpoint get_lbnandoff_by_lpn (lpn:page_no) (num:nat) : option (prod nat nat) :=
 match num with
      | O  => None
      | S i'  => if ble_nat (i' * PAGES_PER_BLOCK) lpn then Some (i',(minus lpn (i' * PAGES_PER_BLOCK) ) ) else get_lbnandoff_by_lpn lpn i'
 end.

Definition FTL_write (c:chip) (f:FTL) (lpn:page_no) (d:data):option (prod chip FTL) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  let cur_trans := current_trans_block f in
  let cur_data := current_data_block f in
  (* let lpn := lbn * PAGES_PER_BLOCK + loff in *)
  do [lbn,loff] <-- get_lbnandoff_by_lpn lpn BLOCKS;
  do bi <-- bit_get bit cur_data;
  do poff <-- Some (bi_used_pages bi);
  match check_block_is_full bi with
      (*It is not full*)
      | false => do [c',bi'] <-- write_data_block c bi cur_data poff d (Some (lbn,loff)) (ps_data lpn);
                 (* update the page_state in the bit *)
                 do bit' <-- bit_update bit cur_data bi';
                 do new_f <-- ftl_update_bit f bit';
                 do [new_c',new_f'] <-- cmt_update_when_ftl_write c' new_f lbn loff;
                 ret (new_c',new_f')
      | true  =>  do [new_data,cfx] <-- alloc_block c f;
                  do [c',f'] <-- Some cfx;
                  do bi' <-- bit_get (ftl_bi_table f') new_data;
                  do bi'' <-- Some (bi_set_state bi' bs_data);
                  do [c'',bi'''] <-- write_data_block c' bi'' new_data 0 d (Some (lbn, loff)) (ps_data lpn);
                  do bit' <-- bit_update (ftl_bi_table f') new_data bi''';
                  do new_f <-- Some (mk_FTL bit' (ftl_free_blocks f') (ftl_cmt_table f') (ftl_gtd_table f') new_data (current_trans_block f') );
                  (* update the cmt *)
                  do [new_c',new_f'] <-- cmt_update_when_ftl_write c'' new_f lbn loff;
                  ret (new_c',new_f')
 end.

(*

The Garbge Collection

*)

Definition gc_copy_trans_page (c:chip) (f:FTL) (pbn:block_no) (off:nat)(gtd_loc:nat) : option (prod chip FTL) :=
  let bit := ftl_bi_table f in
  let gtd := ftl_gtd_table f in
  let fbq := ftl_free_blocks f in
  let cur_trans := current_trans_block f in
  let cur_data := current_data_block f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  do cur_trans_info <-- bit_get bit cur_trans;
  do cur_trans_off <-- Some (bi_used_pages cur_trans_info);
  do [trans_d,oob] <-- read_block_oob c pbn off;
  (* Also it can look from the page_status *)
  (* do gtd_loc <-- gtd_look_by_record gtd pbn off 0; *)
  match check_block_full cur_trans_info with
     | false  => do [c',cur_bi'] <-- write_data_block c cur_trans_info cur_trans cur_trans_off trans_d oob (ps_trans gtd_loc) ;
                 do bit' <-- bit_update bit cur_trans cur_bi';
                 (* update the gtd *)
                 do gtd' <-- gtd_set gtd gtd_loc (gtd_trans cur_trans cur_trans_off);
                 do new_f <-- Some (mk_FTL bit'  fbq cmt gtd' cur_data cur_trans);
                 ret(c',new_f)

     | true =>  do [new_trans,cfx] <-- alloc_block c f;
                do [c',f'] <-- Some cfx;
                do new_trans_info <-- bit_get (ftl_bi_table f') new_trans;
                do [c',cur_bi'] <-- write_data_block c' new_trans_info new_trans 0 trans_d oob (ps_trans gtd_loc);
                do bit' <-- bit_update bit new_trans cur_bi';
                (* update the gtd *)
                do gtd' <-- gtd_set gtd gtd_loc (gtd_trans new_trans 0);
                do new_f <-- Some (mk_FTL bit' (ftl_free_blocks f') cmt gtd' cur_data new_trans);
                ret(c',new_f)
 end.

Definition invalid_old_block(bit:block_info_table)(pbn:block_no) :option block_info_table :=
  do bi <-- bit_get bit pbn;
  do pst <-- Some (pst_set_all ps_invalid);
  do bi' <-- Some (pi_set_state bi (bs_invalid) pst);
  do bit' <-- bit_update bit pbn bi';
  ret bit'.

Fixpoint  gc_trans(c:chip) (f:FTL) (pbn:block_no) (i:nat) :option (prod chip FTL) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  let cur_trans := current_trans_block f in
  let cur_data := current_data_block f in
  do bi <-- bit_get bit pbn;
  do pst <-- Some ( bi_page_state bi );
  do ps <-- pst_get pst i;
  match i with
      | O => (* free_block also will do this *)
             do bit' <-- invalid_old_block bit pbn;
             ret(c,(mk_FTL bit' fbq cmt gtd cur_data cur_trans) )

      | S i' =>  match ps with
                    | ps_trans gtd_loc =>  do [c',f'] <-- gc_copy_trans_page c f pbn i' gtd_loc;
                                           gc_trans c' f' pbn i'

                    | _ =>  gc_trans c f pbn i'

                 end
   end.

(*
TO DO Invalid the old_data,but copy_trans_page do this
*)

Definition gc_copy_data_page (c:chip) (f:FTL) (pbn:block_no) (off:nat) (lpn:page_no): option (prod (prod nat  nat) (prod chip FTL) ) :=
  let bit := ftl_bi_table f in
  let gtd := ftl_gtd_table f in
  let fbq := ftl_free_blocks f in
  let cur_trans := current_trans_block f in
  let cur_data := current_data_block f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  do cur_data_info <-- bit_get bit cur_data;
  do cur_data_off <-- Some (bi_used_pages cur_data_info);
  do [data_d,oob] <-- read_block_oob c pbn off;
  match check_block_full cur_data_info with
     | false  => do [c',cur_bi'] <-- write_data_block c cur_data_info cur_data cur_data_off data_d oob (ps_data lpn) ;
                 do bit' <-- bit_update bit cur_data cur_bi';
                 do new_f <-- Some (mk_FTL bit'  fbq cmt gtd cur_data cur_trans);
                 ret((cur_data,cur_data_off),(c',new_f))

     | true =>  do [new_data,cfx] <-- alloc_block c f;
                do [c',f'] <-- Some cfx;
                do new_data_info <-- bit_get (ftl_bi_table f') new_data;
                do [c',cur_bi'] <-- write_data_block c' new_data_info new_data 0 data_d oob (ps_data lpn);
                do bit' <-- bit_update bit new_data cur_bi';
                do new_f <-- Some (mk_FTL bit' (ftl_free_blocks f') cmt gtd new_data cur_trans);
                ret((new_data,0),(c',new_f))

 end.

Definition gc_data_copy_and_update (c:chip) (f:FTL) (pbn:block_no) (off:nat) (lpn:page_no): option (prod chip FTL) :=
  let gtd := ftl_gtd_table f in
  let cmt := ftl_cmt_table f in
  do [old_trans,old_off] <-- gtd_get_trans_by_lpn gtd lpn;
  do [pbn_off,cf] <-- gc_copy_data_page c f pbn off lpn;
  do [c',f'] <-- Some cf;
  do [new_data,new_off] <-- Some pbn_off;
  (*update the corrsponding trans_page and gtd *)
  do [c'',f''] <-- copy_trans_page c' f' lpn old_trans old_off new_data new_off;
  (* update the cmt *)
  do cmt <-- Some (ftl_cmt_table f'');
  match cmt_in cmt lpn with
      | false =>   ret (c'',f'')
      | true => do loc <-- find_cmtrecord cmt lpn 0;
                do cmt' <-- cmt_set cmt loc (cmt_trans lpn new_data new_off clean);
                do f''' <-- (ftl_update_cmt f'' cmt');
                ret (c'',f''')
   end.

Fixpoint  gc_data(c:chip) (f:FTL) (pbn:block_no) (i:nat) :option (prod chip FTL) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  let cur_trans := current_trans_block f in
  let cur_data := current_data_block f in
  do bi <-- bit_get bit pbn;
  do pst <-- Some ( bi_page_state bi );
  do ps <-- pst_get pst i;
  match i with
      | O => do bit' <-- invalid_old_block bit pbn;
             ret(c,(mk_FTL bit fbq cmt gtd cur_data cur_trans) )

      | S i' =>  match ps with
                    | ps_data lpn =>  do [c',f'] <-- gc_data_copy_and_update c f pbn i' lpn;
                                      gc_data c' f' pbn i'

                    | _ =>  gc_data c f pbn i'

                 end
   end.
(*

The GC Opertions

The pbn has 3 limits:

1)it can't be cur_trans

2)it can't be cur_data

3)it can't be in the fbq

*)

Definition gc(c:chip) (f:FTL) (pbn:block_no) :option (prod chip FTL) :=
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  let cmt := ftl_cmt_table f in
  let gtd := ftl_gtd_table f in
  let cur_trans := current_trans_block f in
  let cur_data := current_data_block f in
  do bi <-- bit_get bit pbn;
  do bs <-- Some (bi_state bi);
  match bs with
      | bs_trans => do [c',f'] <-- gc_trans c f pbn PAGES_PER_BLOCK;
                    do [bit',fbq'] <-- free_block (ftl_bi_table f') (ftl_free_blocks f') pbn;
                    do f''<-- ftl_update_bit f' bit';
                    do f''' <-- ftl_update_fbq f'' fbq';
                    ret(c',f''')

      | bs_data =>  do [c',f'] <-- gc_data c f pbn PAGES_PER_BLOCK;
                    do [bit',fbq'] <-- free_block (ftl_bi_table f') (ftl_free_blocks f') pbn;
                    do f''<-- ftl_update_bit f' bit';
                    do f''' <-- ftl_update_fbq f'' fbq';
                    ret(c',f''')

      | bs_erased => None

      | bs_invalid => None
  end.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University
  Copyright 2018 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

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

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

 *)

Require Export usquash.
Require Export per_props_psquash.

Lemma member_iff_inhabited_mkc_apply2_mkc_usquash_per {o} :
  forall lib (t1 t2 T : @CTerm o),
    inhabited_type lib (mkc_apply2 (mkc_usquash_per nvarx nvary T) t1 t2)
    <=> inhabited_type lib T.
Proof.
  introv.

  split; introv inh.

  - eapply inhabited_type_respects_cequivc in inh;
    [|apply cequivc_beta2].
    rw @mkcv_lam_substc in inh; try (complete (intro xx; ginv)).

    eapply inhabited_type_respects_cequivc in inh;
      [|apply cequivc_beta].

    autorewrite with slow in *; auto.

  - eapply inhabited_type_respects_cequivc;
    [apply cequivc_sym;apply cequivc_beta2|].
    rw @mkcv_lam_substc; try (complete (intro xx; ginv)).

    eapply inhabited_type_respects_cequivc;
      [apply cequivc_sym;apply cequivc_beta|].

    autorewrite with slow in *; auto.
Qed.

Lemma implies_tequality_mkc_usquash {o} :
  forall lib (t1 t2 : @CTerm o),
    type lib t1
    -> type lib t2
    -> (inhabited_type lib t1 <=> inhabited_type lib t2)
    -> tequality lib (mkc_usquash t1) (mkc_usquash t2).
Proof.
  introv tt1 tt2 tiff.
  unfold mkc_usquash.
  rw @tequality_mkc_pertype.
  dands.

  - (* type 1 *)
    introv.
    unfold mkc_usquash_per.

    eapply type_respects_cequivc;
      [apply cequivc_sym;apply cequivc_beta2|].
    rw @mkcv_lam_substc; try (complete (intro xx; ginv)).

    eapply type_respects_cequivc;
      [apply cequivc_sym;apply cequivc_beta|].

    autorewrite with slow in *; auto.

  - (* type 2 *)
    introv.
    unfold mkc_psquash_per.

    eapply type_respects_cequivc;
      [apply cequivc_sym;apply cequivc_beta2|].
    rw @mkcv_lam_substc; try (complete (intro xx; ginv)).

    eapply type_respects_cequivc;
      [apply cequivc_sym;apply cequivc_beta|].

    autorewrite with slow in *; auto.

  - (* extensional eq *)
    introv.
    allrw @member_iff_inhabited_mkc_apply2_mkc_usquash_per; tcsp.

  - (* PER *)
    unfold is_per_type; dands.

    (* symmetry *)
    + introv inh.
      allrw @member_iff_inhabited_mkc_apply2_mkc_usquash_per; sp.

    (* transitivity *)
    + introv inh1 inh2.
      allrw @member_iff_inhabited_mkc_apply2_mkc_usquash_per; sp.
Qed.

Lemma tequality_mkc_usquash {o} :
  forall lib (t1 t2 : @CTerm o),
    tequality lib (mkc_usquash t1) (mkc_usquash t2)
    <=> (type lib t1
         # type lib t2
         # (inhabited_type lib t1 <=> inhabited_type lib t2)).
Proof.
  introv; split; intro k; try (apply implies_tequality_mkc_usquash; tcsp);[].

  unfold mkc_usquash in k.
  rw @tequality_mkc_pertype in k; repnd.

  (* let's get that t1 is a type *)
  pose proof (k0 mkc_axiom mkc_axiom) as tt1.
  unfold mkc_usquash_per in tt1.

  eapply type_respects_cequivc in tt1;[|apply cequivc_beta2].
  rw @mkcv_lam_substc in tt1; try (complete (intro xx; ginv)).
  eapply type_respects_cequivc in tt1;[|apply cequivc_beta].
  autorewrite with slow in *.

  (* let's get that t2 is a type *)
  pose proof (k1 mkc_axiom mkc_axiom) as tt2.
  unfold mkc_usquash_per in tt2.

  eapply type_respects_cequivc in tt2;[|apply cequivc_beta2].
  rw @mkcv_lam_substc in tt2; try (complete (intro xx; ginv)).
  eapply type_respects_cequivc in tt2;[|apply cequivc_beta].
  autorewrite with slow in *.

  dands; auto;[].

  pose proof (k2 mkc_axiom mkc_axiom) as k2.
  allrw @member_iff_inhabited_mkc_apply2_mkc_usquash_per; tcsp.
Qed.

Lemma sp_implies_tequality_mkc_usquash {o} :
  forall lib (t1 t2 : @CTerm o),
    tequality lib t1 t2
    -> tequality lib (mkc_usquash t1) (mkc_usquash t2).
Proof.
  introv teq.
  apply tequality_mkc_usquash.
  dands; eauto 3 with slow.

  - apply tequality_refl in teq; auto.

  - apply tequality_sym in teq; apply tequality_refl in teq; auto.

  - introv; split; intro mem; eapply inhabited_type_tequality; eauto.
    apply tequality_sym; auto.
Qed.

Lemma implies_equality_in_mkc_usquash {o} :
  forall lib (a b T : @CTerm o),
    inhabited_type lib T
    -> equality lib a b (mkc_usquash T).
Proof.
  introv inh.
  unfold mkc_usquash.

  apply equality_in_mkc_pertype2; dands.

  - apply member_iff_inhabited_mkc_apply2_mkc_usquash_per; sp.

  - apply sp_implies_tequality_mkc_usquash.
    unfold inhabited_type in inh; exrepnd.
    apply inhabited_implies_tequality in inh0; auto.
Qed.

Lemma equality_in_mkc_usquash {o} :
  forall lib (a b T : @CTerm o),
    equality lib a b (mkc_usquash T)
    <=> inhabited_type lib T.
Proof.
  introv; split; introv k; try (apply implies_equality_in_mkc_usquash; sp);[].
  unfold mkc_usquash in k.

  apply equality_in_mkc_pertype2 in k; repnd.
  apply member_iff_inhabited_mkc_apply2_mkc_usquash_per in k0; sp.
Qed.

Lemma equality_mkc_usquash_in_uni {o} :
  forall lib (t1 t2 : @CTerm o) i,
    equality lib (mkc_usquash t1) (mkc_usquash t2) (mkc_uni i)
    <=> (member lib t1 (mkc_uni i)
         # member lib t2 (mkc_uni i)
         # (inhabited_type lib t1 <=> inhabited_type lib t2)).
Proof.
  introv.
  sp_iff Case; introv h; repnd.

  - Case "->".
    apply mkc_pertype_equality_in_uni in h; repnd.

    pose proof (h0 mkc_axiom mkc_axiom) as h0.
    eapply member_respects_cequivc in h0;[|apply cequivc_beta2].
    repeat (rw @mkcv_lam_substc in h0; try (complete (intro xx; ginv));[]).
    eapply member_respects_cequivc in h0;[|apply cequivc_beta].
    autorewrite with slow in *.

    pose proof (h1 mkc_axiom mkc_axiom) as h1.
    eapply member_respects_cequivc in h1;[|apply cequivc_beta2].
    repeat (rw @mkcv_lam_substc in h1; try (complete (intro xx; ginv));[]).
    eapply member_respects_cequivc in h1;[|apply cequivc_beta].
    autorewrite with slow in *.

    dands; auto.

    pose proof (h2 mkc_axiom mkc_axiom) as h2.
    allrw @member_iff_inhabited_mkc_apply2_mkc_usquash_per; tcsp.

  - unfold mkc_usquash.
    apply mkc_pertype_equality_in_uni.
    dands; introv;
      [| | |].

    { eapply member_respects_cequivc;[apply cequivc_sym;apply cequivc_beta2|].
      repeat (rw @mkcv_lam_substc; try (complete (intro xx; ginv));[]).
      eapply member_respects_cequivc;[apply cequivc_sym;apply cequivc_beta|].
      autorewrite with slow in *; auto. }

    { eapply member_respects_cequivc;[apply cequivc_sym;apply cequivc_beta2|].
      repeat (rw @mkcv_lam_substc; try (complete (intro xx; ginv));[]).
      eapply member_respects_cequivc;[apply cequivc_sym;apply cequivc_beta|].
      autorewrite with slow in *; auto. }

    { repeat rw @member_iff_inhabited_mkc_apply2_mkc_usquash_per; tcsp. }

    { unfold is_per_type; dands.

      + introv inh.
        allrw @member_iff_inhabited_mkc_apply2_mkc_usquash_per; sp.

      + introv inh1 inh2.
        allrw @member_iff_inhabited_mkc_apply2_mkc_usquash_per; sp. }
Qed.