Require Import SpecCert.Address.Address.
Require Import SpecCert.Equality.

Inductive LogicalMap :=
| lm: LogicalMap.

Lemma lm_singleton
      (l l': LogicalMap)
  : l = l'.
Proof.
  induction l; induction l'.
  reflexivity.
Qed.

Instance lmSingleton
  : Singleton LogicalMap := { singleton := lm_singleton }.

Instance lmMapEq
  : Eq LogicalMap
  := singletonEq LogicalMap.

Definition LogicalAddress := Address LogicalMap.


(*===========================================================================
   Embedding of total states (ProcState) into partial states (PState)
   and associate lemmas regarding SPreds
  ===========================================================================*)
Require Import Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool Ssreflect.ssrnat Ssreflect.eqtype Ssreflect.tuple Ssreflect.seq Ssreflect.fintype.
Require Import x86proved.bitsrep x86proved.bitsprops x86proved.bitsops x86proved.bitsopsprops x86proved.x86.procstate x86proved.x86.procstatemonad x86proved.pmapprops.
Require Import x86proved.monad x86proved.monadinst x86proved.reader x86proved.spred x86proved.septac x86proved.pointsto x86proved.pfun x86proved.cursor x86proved.writer.

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

Transparent ILFun_Ops.

(* A full machine state can be interpreted as a partial state *)
Definition toPState (s:ProcState) : PState :=
  fun f:Frag =>
  match f return fragDom f -> option (fragTgt f) with
  | Registers => fun rp => let: AnyRegPiece r ix := rp in Some (getRegPiece (registers s r) ix)
  | Flags => fun f => Some (flags s f)
  | Memory => fun p => Some (memory s p)
  end.

Coercion toPState : ProcState >-> PState.

Lemma totalProcState (s: ProcState) : isTotalPState s.
Proof. move => f x. destruct f; destruct x => //.  Qed.

Require Import Coq.Logic.FunctionalExtensionality x86proved.charge.csetoid.

Lemma toPState_inj s1 s2 : toPState s1 === toPState s2 -> s1 = s2.
Proof. move => H.
destruct s1 as [s1r s1f s1m].
destruct s2 as [s2r s2f s2m].
unfold "===", toPState in H.
simpl in H.
have E1: s1r = s2r. extensionality x.
have H0 := H Registers (AnyRegPiece x RegIx0).
have H1 := H Registers (AnyRegPiece x RegIx1).
have H2 := H Registers (AnyRegPiece x RegIx2).
have H3 := H Registers (AnyRegPiece x RegIx3).
clear H.
apply getRegPiece_ext; congruence.

have E2: s1f = s2f.
extensionality x. specialize (H Flags x). by injection H.
have E3: s1m = s2m.
apply extensional_PMAP => x. specialize (H Memory x). by injection H.
by rewrite E1 E2 E3.
Qed.

Lemma eqPredProcState_sepSP (s: ProcState) R :
  eq_pred s ** R |-- eq_pred s.
Proof. rewrite (eqPredTotal_sepSP_trueR _); last by apply totalProcState. by ssimpl. Qed.

Definition isClosed (P: SPred) :=
  forall s s', stateIncludedIn s s' -> P s -> P s'.

Local Transparent lentails sepILogicOps.
Lemma isClosed_sepSP_ltrue P:
  isClosed P -> P ** ltrue -|- P.
Proof.
  move=> HClosed. split.
  - move=> s [s1 [s2 [Hs [HPs _]]]]. eapply HClosed; [|eassumption].
    edestruct stateSplitsAsIncludes; [eapply Hs | assumption].
  - rewrite <-empSPR at 1. cancel2.
Qed.

Lemma eq_pred_aux (s1 s2 s3: ProcState) R :
  ((eq_pred s1 ** R) ** ltrue) s2 ->
  ((eq_pred s3 ** R) ** ltrue) s3.
Proof. move => H0.
apply lentails_eq. ssimpl.
apply lentails_eq in H0.
rewrite -> sepSPC in H0. rewrite <-sepSPA in H0. rewrite ->(sepSPC ltrue) in H0.
rewrite <- (eqPredTotal_sepSP_trueR) in H0; last by apply totalProcState.
apply eqPredTotal_sepSP in H0; last by apply totalProcState.
rewrite -> H0. by ssimpl.
Qed.

Lemma eq_pred_aux2 (s1 s2: ProcState) R :
  ((eq_pred s1 ** R) ** ltrue) s2 -> s1 = s2.
Proof. move => H0.
apply lentails_eq in H0. rewrite -> sepSPA in H0.
  rewrite -> eqPredProcState_sepSP in H0.
  apply lentails_eq in H0. simpl in H0. by apply toPState_inj in H0.
Qed.


(** * Push-Button Synthesis of Bitcoin Multiplication: Reification Cache *)
Require Import Coq.derive.Derive.
Require Import Crypto.PushButtonSynthesis.ReificationCache.
Require Import Crypto.Arithmetic.DettmanMultiplication.

Local Set Keyed Unification. (* needed for making [autorewrite] fast, c.f. COQBUG(https://github.com/coq/coq/issues/9283) *)

Module Export DettmanMultiplication.
  Import dettman_multiplication_mod_ops.
  Derive reified_mul_gen
         SuchThat (is_reification_of reified_mul_gen mulmod)
         As reified_mul_gen_correct.
  Proof. Time cache_reify (). Time Qed.
#[global]
  Hint Extern 1 (_ = _) => apply_cached_reification mulmod (proj1 reified_mul_gen_correct) : reify_cache_gen.
#[global]
  Hint Immediate (proj2 reified_mul_gen_correct) : wf_gen_cache.
#[global]
  Hint Rewrite (proj1 reified_mul_gen_correct) : interp_gen_cache.
  Local Opaque reified_mul_gen. (* needed for making [autorewrite] not take a very long time *)

  Derive reified_square_gen
         SuchThat (is_reification_of reified_square_gen squaremod)
         As reified_square_gen_correct.
  Proof. Time cache_reify (). Time Qed.
#[global]
  Hint Extern 1 (_ = _) => apply_cached_reification squaremod (proj1 reified_square_gen_correct) : reify_cache_gen.
#[global]
  Hint Immediate (proj2 reified_square_gen_correct) : wf_gen_cache.
#[global]
  Hint Rewrite (proj1 reified_square_gen_correct) : interp_gen_cache.
  Local Opaque reified_square_gen. (* needed for making [autorewrite] not take a very long time *)
End DettmanMultiplication.


Require Import Ascii Bool String List Lia.
Require Import Lib.CommonTactics Lib.Indexer Lib.ilist Lib.Word Lib.Struct.
Require Import Kami.Syntax Kami.Notations.
Require Import Kami.Semantics Kami.Specialize Kami.Duplicate.
Require Import Kami.Wf Kami.Tactics.
Require Import Ex.MemTypes.

Set Implicit Arguments.

(* The SC module is defined as follows: SC = n * Pinst + Minst,
 * where Pinst denotes an instantaneous processor core
 * and Minst denotes an instantaneous memory.
 *)

(* Abstract ISA *)
Section DecExec.
  Variables opIdx addrSize iaddrSize instBytes dataBytes rfIdx: nat.

  Definition Pc := Bit addrSize.

  (* opcode-related *)
  Definition OpcodeK := SyntaxKind (Bit opIdx).
  Definition OpcodeE (ty: Kind -> Type) := Expr ty OpcodeK.
  Definition OpcodeT := forall ty, fullType ty (SyntaxKind (Data instBytes)) -> OpcodeE ty.

  Definition opLd := WO~0~0.
  Definition opSt := WO~0~1.
  Definition opNm := WO~1~1.

  Definition OptypeK := SyntaxKind (Bit 2).
  Definition OptypeE (ty: Kind -> Type) := Expr ty OptypeK.
  Definition OptypeT := forall ty, fullType ty (SyntaxKind (Data instBytes)) -> OptypeE ty.

  (* load-related *)
  Definition LdDstK := SyntaxKind (Bit rfIdx).
  Definition LdDstE (ty: Kind -> Type) := Expr ty LdDstK.
  Definition LdDstT := forall ty, fullType ty (SyntaxKind (Data instBytes)) -> LdDstE ty.

  Definition LdAddrK := SyntaxKind (Bit addrSize).
  Definition LdAddrE (ty: Kind -> Type) := Expr ty LdAddrK.
  Definition LdAddrT := forall ty, fullType ty (SyntaxKind (Data instBytes)) -> LdAddrE ty.

  Definition LdSrcK := SyntaxKind (Bit rfIdx).
  Definition LdSrcE (ty: Kind -> Type) := Expr ty LdSrcK.
  Definition LdSrcT := forall ty, fullType ty (SyntaxKind (Data instBytes)) -> LdSrcE ty.

  Definition f3Lb := WO~0~0~0.
  Definition f3Lh := WO~0~0~1.
  Definition f3Lw := WO~0~1~0.
  Definition f3Lbu := WO~1~0~0.
  Definition f3Lhu := WO~1~0~1.

  Definition LdTypeK := SyntaxKind (Bit 3).
  Definition LdTypeE (ty: Kind -> Type) := Expr ty LdTypeK.
  Definition LdTypeT := forall ty, fullType ty (SyntaxKind (Data instBytes)) -> LdTypeE ty.

  Definition LdAddrCalcT :=
    forall ty,
      fullType ty (SyntaxKind (Bit addrSize)) -> (* base address *)
      fullType ty (SyntaxKind (Data dataBytes)) -> (* offset value *)
      Expr ty (SyntaxKind (Bit addrSize)).

  Definition LdValCalcT :=
    forall ty,
      fullType ty (SyntaxKind (Bit addrSize)) -> (* requested address *)
      fullType ty (SyntaxKind (Data dataBytes)) (* loaded value *) ->
      fullType ty LdTypeK -> (* load type: lb, lh, lw, lbu, or lhu *)
      Expr ty (SyntaxKind (Data dataBytes)). (* calculated value *)

  (* store-related *)
  Definition StAddrK := SyntaxKind (Bit addrSize).
  Definition StAddrE (ty: Kind -> Type) := Expr ty StAddrK.
  Definition StAddrT := forall ty, fullType ty (SyntaxKind (Data instBytes)) -> StAddrE ty.

  Definition StSrcK := SyntaxKind (Bit rfIdx).
  Definition StSrcE (ty: Kind -> Type) := Expr ty StSrcK.
  Definition StSrcT := forall ty, fullType ty (SyntaxKind (Data instBytes)) -> StSrcE ty.

  Definition StAddrCalcT :=
    forall ty,
      fullType ty (SyntaxKind (Bit addrSize)) -> (* base address *)
      fullType ty (SyntaxKind (Data dataBytes)) -> (* offset value *)
      Expr ty (SyntaxKind (Bit addrSize)).
  Definition StByteEnCalcT :=
    forall ty, fullType ty (SyntaxKind (Data instBytes)) ->
               Expr ty (SyntaxKind (Array Bool dataBytes)).

  Definition StVSrcK := SyntaxKind (Bit rfIdx).
  Definition StVSrcE (ty: Kind -> Type) := Expr ty StVSrcK.
  Definition StVSrcT := forall ty, fullType ty (SyntaxKind (Data instBytes)) -> StVSrcE ty.

  (* general sources *)
  Definition Src1K := SyntaxKind (Bit rfIdx).
  Definition Src1E (ty: Kind -> Type) := Expr ty Src1K.
  Definition Src1T := forall ty, fullType ty (SyntaxKind (Data instBytes)) -> Src1E ty.

  Definition Src2K := SyntaxKind (Bit rfIdx).
  Definition Src2E (ty: Kind -> Type) := Expr ty Src2K.
  Definition Src2T := forall ty, fullType ty (SyntaxKind (Data instBytes)) -> Src2E ty.

  (* general destination *)
  Definition DstK := SyntaxKind (Bit rfIdx).
  Definition DstE (ty: Kind -> Type) := Expr ty DstK.
  Definition DstT := forall ty, fullType ty (SyntaxKind (Data instBytes)) -> DstE ty.

  (* execution *)
  Definition StateK := SyntaxKind (Vector (Data dataBytes) rfIdx).
  Definition StateT (ty : Kind -> Type) := fullType ty StateK.
  Definition StateE (ty : Kind -> Type) := Expr ty StateK.

  Definition ExecT := forall ty, fullType ty (SyntaxKind (Data dataBytes)) -> (* val1 *)
                                 fullType ty (SyntaxKind (Data dataBytes)) -> (* val2 *)
                                 fullType ty (SyntaxKind Pc) -> (* pc *)
                                 fullType ty (SyntaxKind (Data instBytes)) -> (* rawInst *)
                                 Expr ty (SyntaxKind (Data dataBytes)). (* executed value *)
  Definition NextPcT := forall ty, StateT ty -> (* rf *)
                                   fullType ty (SyntaxKind Pc) -> (* pc *)
                                   fullType ty (SyntaxKind (Data instBytes)) -> (* rawInst *)
                                   Expr ty (SyntaxKind Pc). (* next pc *)
  Definition ToIAddrT := forall ty, fullType ty (SyntaxKind (Bit addrSize)) ->
                                    Expr ty (SyntaxKind (Bit iaddrSize)).
  Definition ToAddrT := forall ty, fullType ty (SyntaxKind (Bit iaddrSize)) ->
                                   Expr ty (SyntaxKind (Bit addrSize)).
  Definition AlignInstT := forall ty, fullType ty (SyntaxKind (Data dataBytes)) -> (* loaded word *)
                                      Expr ty (SyntaxKind (Data instBytes)). (* aligned inst. *)

  Class AbsFetch :=
    { toIAddr: ToIAddrT;
      toAddr: ToAddrT;
      alignInst: AlignInstT
    }.

  Class AbsDec :=
    { getOptype: OptypeT;
      getLdDst: LdDstT;
      getLdAddr: LdAddrT;
      getLdSrc: LdSrcT;
      calcLdAddr: LdAddrCalcT;
      getLdType: LdTypeT;
      getStAddr: StAddrT;
      getStSrc: StSrcT;
      calcStAddr: StAddrCalcT;
      calcStByteEn: StByteEnCalcT;
      getStVSrc: StVSrcT;
      getSrc1: Src1T;
      getSrc2: Src2T;
      getDst: DstT
    }.

  Class AbsExec :=
    { calcLdVal: LdValCalcT;
      doExec: ExecT;
      getNextPc: NextPcT
    }.

  Class AbsIsa :=
    { fetch: AbsFetch;
      dec: AbsDec;
      exec: AbsExec
    }.

End DecExec.

#[global] Hint Unfold Pc OpcodeK OpcodeE OpcodeT OptypeK OptypeE OptypeT opLd opSt opNm
     LdDstK LdDstE LdDstT LdAddrK LdAddrE LdAddrT LdSrcK LdSrcE LdSrcT LdAddrCalcT
     LdTypeK LdTypeE LdTypeT f3Lb f3Lh f3Lw f3Lbu f3Lhu LdValCalcT
     StAddrK StAddrE StAddrT StSrcK StSrcE StSrcT StAddrCalcT StByteEnCalcT
     StVSrcK StVSrcE StVSrcT Src1K Src1E Src1T Src2K Src2E Src2T
     StateK StateE StateT ExecT NextPcT ToIAddrT ToAddrT AlignInstT : MethDefs.

Section MemInst.
  Variables (addrSize maddrSize dataBytes: nat)
            (Hdb: {pdb & dataBytes = S pdb}).

  Definition RqFromProc := RqFromProc dataBytes (Bit addrSize).
  Definition RsToProc := RsToProc dataBytes.

  Definition MemInit := ConstT (Vector (Bit BitsPerByte) maddrSize).

  Variable (memInit: MemInit).

  Definition memOp := MethodSig "memOp"(Struct RqFromProc) : Struct RsToProc.

  (* NOTE: it's little endian *)
  Fixpoint memLoadBytes {ty} (n: nat) (addr: Expr ty (SyntaxKind (Bit addrSize)))
           (mem: Expr ty (SyntaxKind (Vector (Bit BitsPerByte) maddrSize))):
    Expr ty (SyntaxKind (Bit (n * BitsPerByte))) :=
    (match n with
     | 0 => $$WO
     | S n' => {memLoadBytes n' (addr + $1) mem, mem@[_zeroExtend_ addr]}
     end)%kami_expr.

  (* NOTE: it's little endian as well *)
  Fixpoint memStoreBytes {ty} (n: nat) (addr: Expr ty (SyntaxKind (Bit addrSize)))
           (val: Expr ty (SyntaxKind (Bit (n * BitsPerByte))))
           (sz: nat) (byteEn: Expr ty (SyntaxKind (Array Bool (S sz))))
           (mem: Expr ty (SyntaxKind (Vector (Bit BitsPerByte) maddrSize))):
    Expr ty (SyntaxKind (Vector (Bit BitsPerByte) maddrSize)) :=
    (match n as n0 return
           ((Bit (n0 * BitsPerByte))@ty -> (Vector (Bit BitsPerByte) maddrSize)@ty)
     with
     | 0 => fun _ => mem
     | S n' =>
       fun val0 =>
         let nmem := memStoreBytes
                       n' (addr + $1)
                       (UniBit (TruncLsb BitsPerByte (n' * BitsPerByte)) val0) byteEn
                       mem in
         (IF byteEn#[$$(natToWord (Nat.log2 sz + 1) (sz - n'))]
          then nmem@[_zeroExtend_ addr <- UniBit (Trunc BitsPerByte (n' * BitsPerByte)) val0]
          else nmem)
     end val)%kami_expr.

  Definition memStoreBytes' {ty} (n: nat) (addr: Expr ty (SyntaxKind (Bit addrSize)))
             (val: Expr ty (SyntaxKind (Bit (n * BitsPerByte))))
             (sz: nat) (Hsz: {sz' & sz = S sz'})
             (byteEn: Expr ty (SyntaxKind (Array Bool sz)))
             (mem: Expr ty (SyntaxKind (Vector (Bit BitsPerByte) maddrSize))):
    Expr ty (SyntaxKind (Vector (Bit BitsPerByte) maddrSize)) :=
    eq_rect_r (fun sz => (Array Bool sz)@ty -> _)
              (fun byteEn => memStoreBytes n addr val byteEn mem) (projT2 Hsz) byteEn.

  (* For semantic uses *)
  Fixpoint combineBytes (n: nat) (addr: word addrSize)
           (mem: word maddrSize -> word BitsPerByte): word (n * BitsPerByte) :=
    match n with
    | 0 => WO
    | S n' => combine (mem (evalZeroExtendTrunc _ addr)) (combineBytes n' (addr ^+ $1) mem)
    end.

  Fixpoint updateBytes (n: nat) (addr: word addrSize) (val: word (n * BitsPerByte))
           (sz: nat) (byteEn: Fin.t (S sz) -> bool)
           (mem: word maddrSize -> word BitsPerByte): word maddrSize -> word BitsPerByte :=
    (match n as n0 return
           (word (n0 * BitsPerByte) -> (word maddrSize -> word BitsPerByte))
     with
     | 0 => fun _ => mem
     | S n' => fun val0 =>
                 let nmem := updateBytes
                               n' (addr ^+ $1)
                               (split2 BitsPerByte (n' * BitsPerByte) val0) byteEn
                               mem in
                 if byteEn (natToFin _ (sz - n'))
                 then (fun w =>
                         if weq w (evalZeroExtendTrunc _ addr)
                         then (split1 BitsPerByte (n' * BitsPerByte) val0)
                         else nmem w)
                 else nmem
     end) val.

  Definition memInst :=
    MODULE {
      Register "mem" : Vector (Bit BitsPerByte) maddrSize <- memInit

      with Method "memOp" (a : Struct RqFromProc) : Struct RsToProc :=
        If !(#a!RqFromProc@."op") then (* load *)
          Read memv <- "mem";
          LET addr <- #a!RqFromProc@."addr";
          LET ldval <- memLoadBytes dataBytes #addr #memv;
          Ret (STRUCT { "data" ::= #ldval } :: Struct RsToProc)
        else (* store *)
          Read memv <- "mem";
          LET addr <- #a!RqFromProc@."addr";
          LET val <- #a!RqFromProc@."data";
          LET byteEn <- #a!RqFromProc@."byteEn";
          Write "mem" <- memStoreBytes' dataBytes #addr #val Hdb #byteEn #memv;
          Ret (STRUCT { "data" ::= $$Default } :: Struct RsToProc)
        as na;
        Ret #na
    }.

  Definition IsMMIOE (ty: Kind -> Type) := Expr ty (SyntaxKind Bool).
  Definition IsMMIOT :=
    forall ty, fullType ty (SyntaxKind (Bit addrSize)) -> IsMMIOE ty.

  Class AbsMMIO :=
    { isMMIO: IsMMIOT }.

  Variable (ammio: AbsMMIO).

  Definition mmioExec :=
    MethodSig "mmioExec"(Struct RqFromProc): Struct RsToProc.

  Definition mm :=
    MODULE {
      Register "mem" : Vector (Bit BitsPerByte) maddrSize <- memInit

      with Method "memOp" (a : Struct RqFromProc): Struct RsToProc :=
        LET addr <- #a!RqFromProc@."addr";

        If (isMMIO _ addr) then (** mmio *)
          Call rs <- mmioExec(#a);
          Ret #rs
        else
          If !(#a!RqFromProc@."op") then (* load *)
            Read memv <- "mem";
            LET addr <- #a!RqFromProc@."addr";
            LET ldval <- memLoadBytes dataBytes #addr #memv;
            Ret (STRUCT { "data" ::= #ldval } :: Struct RsToProc)
          else (* store *)
            Read memv <- "mem";
            LET addr <- #a!RqFromProc@."addr";
            LET val <- #a!RqFromProc@."data";
            LET byteEn <- #a!RqFromProc@."byteEn";
            Write "mem" <- memStoreBytes' dataBytes #addr #val Hdb #byteEn #memv;
            Ret (STRUCT { "data" ::= $$Default } :: Struct RsToProc)
          as na;
          Ret #na
        as na;
        Ret #na
    }.

End MemInst.

#[global] Hint Unfold RqFromProc RsToProc memOp IsMMIOE IsMMIOT mmioExec: MethDefs.
#[global] Hint Unfold memInst mm: ModuleDefs.

(* The module definition for Pinst *)
Section ProcInst.
  Variables addrSize maddrSize iaddrSize instBytes dataBytes rfIdx : nat.

  Variables (fetch: AbsFetch addrSize iaddrSize instBytes dataBytes)
            (dec: AbsDec addrSize instBytes dataBytes rfIdx)
            (exec: AbsExec addrSize instBytes dataBytes rfIdx).

  Definition nextPc {ty} ppc st rawInst :=
    (Write "pc" <- getNextPc ty st ppc rawInst;
     Retv)%kami_action.

  Record ProcInit := { pcInit : ConstT (Pc addrSize);
                       rfInit : ConstT (Vector (Data dataBytes) rfIdx)
                     }.
  Definition procInitDefault :=
    {| pcInit := Default; rfInit := Default |}.

  Local Notation memOp := (memOp addrSize dataBytes).

  Variables (procInit: ProcInit).

  Definition procInst := MODULE {
    Register "pc" : Pc addrSize <- (pcInit procInit)
    with Register "rf" : Vector (Data dataBytes) rfIdx <- (rfInit procInit)

    with Register "pinit" : Bool <- Default
    with Register "pinitOfs" : Bit iaddrSize <- Default
    with Register "pgm" : Vector (Data instBytes) iaddrSize <- Default

    (** Phase 1: initialize the program [pinit == false] *)

    with Rule "pgmInit" :=
      Read pinit : Bool <- "pinit";
      Read pinitOfs : Bit iaddrSize <- "pinitOfs";
      Read pgm : Vector (Data instBytes) iaddrSize <- "pgm";
      Assert !#pinit;
      Assert ((UniBit (Inv _) #pinitOfs) != $0);

      Call ldData <- memOp(STRUCT { "addr" ::= toAddr _ pinitOfs;
                                    "op" ::= $$false;
                                    "byteEn" ::= $$Default;
                                    "data" ::= $$Default });
      LET ldVal <- #ldData!(RsToProc dataBytes)@."data";
      LET inst <- alignInst _ ldVal;
      Write "pgm" <- #pgm@[#pinitOfs <- #inst];
      Write "pinitOfs" <- #pinitOfs + $1;
      Retv

    with Rule "pgmInitEnd" :=
      Read pinit : Bool <- "pinit";
      Read pinitOfs : Bit iaddrSize <- "pinitOfs";
      Read pgm : Vector (Data instBytes) iaddrSize <- "pgm";
      Assert !#pinit;
      Assert ((UniBit (Inv _) #pinitOfs) == $0);
      Call ldData <- memOp(STRUCT { "addr" ::= toAddr _ pinitOfs;
                                    "op" ::= $$false;
                                    "byteEn" ::= $$Default;
                                    "data" ::= $$Default });
      LET ldVal <- #ldData!(RsToProc dataBytes)@."data";
      LET inst <- alignInst _ ldVal;
      Write "pgm" <- #pgm@[#pinitOfs <- #inst];
      Write "pinit" <- !#pinit;
      Write "pinitOfs" : Bit iaddrSize <- $0;
      Retv

    (** Phase 2: execute the program [pinit == true] *)

    with Rule "execLd" :=
      Read ppc : Pc addrSize <- "pc";
      Read rf : Vector (Data dataBytes) rfIdx <- "rf";
      Read pinit : Bool <- "pinit";
      Read pgm : Vector (Data instBytes) iaddrSize <- "pgm";
      Assert #pinit;
      LET rawInst <- #pgm@[toIAddr _ ppc];
      Assert (getOptype _ rawInst == $$opLd);
      LET dstIdx <- getLdDst _ rawInst;
      Assert (#dstIdx != $0);
      LET addr <- getLdAddr _ rawInst;
      LET srcIdx <- getLdSrc _ rawInst;
      LET srcVal <- #rf@[#srcIdx];
      LET laddr <- calcLdAddr _ addr srcVal;
      Call ldRep <- memOp(STRUCT { "addr" ::= #laddr;
                                   "op" ::= $$false;
                                   "byteEn" ::= $$Default;
                                   "data" ::= $$Default });
      LET ldValWord <- #ldRep!(RsToProc dataBytes)@."data";
      LET ldType <- getLdType _ rawInst;
      LET ldVal <- calcLdVal _ laddr ldValWord ldType;
      Write "rf" <- #rf@[#dstIdx <- #ldVal];
      nextPc ppc rf rawInst

    with Rule "execLdZ" :=
      Read ppc : Pc addrSize <- "pc";
      Read rf : Vector (Data dataBytes) rfIdx <- "rf";
      Read pinit : Bool <- "pinit";
      Read pgm : Vector (Data instBytes) iaddrSize <- "pgm";
      Assert #pinit;
      LET rawInst <- #pgm@[toIAddr _ ppc];
      Assert (getOptype _ rawInst == $$opLd);
      LET regIdx <- getLdDst _ rawInst;
      (* NOTE: no register update when the dst register is r0,
       * but the memory call should be made. *)
      Assert (#regIdx == $0);
      LET addr <- getLdAddr _ rawInst;
      LET srcIdx <- getLdSrc _ rawInst;
      LET srcVal <- #rf@[#srcIdx];
      LET laddr <- calcLdAddr _ addr srcVal;
      Call memOp(STRUCT { "addr" ::= #laddr;
                          "op" ::= $$false;
                          "byteEn" ::= $$Default;
                          "data" ::= $$Default });
      nextPc ppc rf rawInst

    with Rule "execSt" :=
      Read ppc : Pc addrSize <- "pc";
      Read rf : Vector (Data dataBytes) rfIdx <- "rf";
      Read pinit : Bool <- "pinit";
      Read pgm : Vector (Data instBytes) iaddrSize <- "pgm";
      Assert #pinit;
      LET rawInst <- #pgm@[toIAddr _ ppc];
      Assert (getOptype _ rawInst == $$opSt);
      LET addr <- getStAddr _ rawInst;
      LET srcIdx <- getStSrc _ rawInst;
      LET srcVal <- #rf@[#srcIdx];
      LET vsrcIdx <- getStVSrc _ rawInst;
      LET stVal <- #rf@[#vsrcIdx];
      LET saddr <- calcStAddr _ addr srcVal;
      LET byteEn <- calcStByteEn _ rawInst;
      Call memOp(STRUCT { "addr" ::= #saddr;
                          "op" ::= $$true;
                          "byteEn" ::= #byteEn;
                          "data" ::= #stVal });
      nextPc ppc rf rawInst

    with Rule "execNm" :=
      Read ppc : Pc addrSize <- "pc";
      Read rf : Vector (Data dataBytes) rfIdx <- "rf";
      Read pinit : Bool <- "pinit";
      Read pgm : Vector (Data instBytes) iaddrSize <- "pgm";
      Assert #pinit;
      LET rawInst <- #pgm@[toIAddr _ ppc];
      Assert (getOptype _ rawInst == $$opNm);
      LET src1 <- getSrc1 _ rawInst;
      LET val1 <- #rf@[#src1];
      LET src2 <- getSrc2 _ rawInst;
      LET val2 <- #rf@[#src2];
      LET dst <- getDst _ rawInst;
      Assert (#dst != $0);
      LET execVal <- doExec _ val1 val2 ppc rawInst;
      Write "rf" <- #rf@[#dst <- #execVal];
      nextPc ppc rf rawInst

    with Rule "execNmZ" :=
      Read ppc : Pc addrSize <- "pc";
      Read rf : Vector (Data dataBytes) rfIdx <- "rf";
      Read pinit : Bool <- "pinit";
      Read pgm : Vector (Data instBytes) iaddrSize <- "pgm";
      Assert #pinit;
      LET rawInst <- #pgm@[toIAddr _ ppc];
      Assert (getOptype _ rawInst == $$opNm);
      LET dst <- getDst _ rawInst;
      Assert (#dst == $0);
      nextPc ppc rf rawInst
  }.

End ProcInst.

#[global] Hint Unfold nextPc procInitDefault : MethDefs.
#[global] Hint Unfold procInst : ModuleDefs.

Section SC.
  Variables (addrSize maddrSize iaddrSize instBytes dataBytes rfIdx: nat)
            (Hdb: {pdb & dataBytes = S pdb}).

  Variables (fetch: AbsFetch addrSize iaddrSize instBytes dataBytes)
            (dec: AbsDec addrSize instBytes dataBytes rfIdx)
            (exec: AbsExec addrSize instBytes dataBytes rfIdx)
            (ammio: AbsMMIO addrSize).

  Variable n: nat.

  Variables (procInit: ProcInit addrSize dataBytes rfIdx)
            (memInit: MemInit maddrSize).

  Definition pinst := procInst fetch dec exec procInit.

  Definition scmm := ConcatMod pinst (mm Hdb memInit ammio).

End SC.

#[global] Hint Unfold pinst scmm : ModuleDefs.

Section Facts.
  Variables (addrSize maddrSize iaddrSize instBytes dataBytes rfIdx: nat)
            (Hdb: {pdb & dataBytes = S pdb}).

  Variables (fetch: AbsFetch addrSize iaddrSize instBytes dataBytes)
            (dec: AbsDec addrSize instBytes dataBytes rfIdx)
            (exec: AbsExec addrSize instBytes dataBytes rfIdx)
            (ammio: AbsMMIO addrSize).

  Lemma memLoadBytes_combineBytes:
    forall n (addr: (Bit addrSize)@type)
           (mem: (Vector (Bit BitsPerByte) maddrSize)@type),
      evalExpr (memLoadBytes n addr mem) =
      combineBytes n (evalExpr addr) (evalExpr mem).
  Proof.
    induction n.
    - intros; reflexivity.
    - intros; simpl.
      rewrite IHn; reflexivity.
  Qed.

  Lemma memStoreBytes_updateBytes:
    forall n (addr: (Bit addrSize)@type)
           (val: (Bit (n * BitsPerByte))@type)
           (mem: (Vector (Bit BitsPerByte) maddrSize)@type)
           (sz: nat) (byteEn: (Array Bool (S sz))@type),
      evalExpr (memStoreBytes n addr val byteEn mem) =
      updateBytes n (evalExpr addr) (evalExpr val) (evalExpr byteEn) (evalExpr mem).
  Proof.
    induction n.
    - intros; reflexivity.
    - intros; simpl.
      rewrite IHn by assumption; simpl.
      rewrite wordToNat_natToWord_idempotent'.
      + reflexivity.
      + apply PeanoNat.Nat.le_lt_trans with (m:= sz).
        * lia.
        * rewrite PeanoNat.Nat.add_1_r.
          destruct sz.
          { simpl; lia. }
          { apply PeanoNat.Nat.log2_spec; lia. }
  Qed.

  Lemma memStoreBytes'_updateBytes:
    forall n (addr: (Bit addrSize)@type)
           (val: (Bit (n * BitsPerByte))@type)
           (mem: (Vector (Bit BitsPerByte) maddrSize)@type)
           (sz: nat) (byteEn: (Array Bool (S sz))@type),
      evalExpr (memStoreBytes' n addr val (existT _ _ eq_refl) byteEn mem) =
      updateBytes n (evalExpr addr) (evalExpr val) (evalExpr byteEn) (evalExpr mem).
  Proof.
    intros; cbn.
    apply memStoreBytes_updateBytes.
  Qed.

  Lemma pinst_ModEquiv:
    forall init,
      ModPhoasWf (pinst fetch dec exec init).
  Proof.
    kequiv.
  Qed.
  #[local] Hint Resolve pinst_ModEquiv.

  Lemma memInst_ModEquiv:
    forall (init: MemInit maddrSize),
      ModPhoasWf (memInst addrSize Hdb init).
  Proof.
    kequiv.
  Qed.
  #[local] Hint Resolve memInst_ModEquiv.

  Lemma mm_ModEquiv:
    forall (init: MemInit maddrSize),
      ModPhoasWf (mm Hdb init ammio).
  Proof.
    kequiv.
  Qed.
  #[local] Hint Resolve mm_ModEquiv.

  Lemma scmm_ModEquiv:
    forall procInit (memInit: MemInit maddrSize),
      ModPhoasWf (scmm Hdb fetch dec exec ammio procInit memInit).
  Proof.
    kequiv.
  Qed.

End Facts.

#[global] Hint Resolve pinst_ModEquiv memInst_ModEquiv mm_ModEquiv scmm_ModEquiv.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 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 per_props_uni.
Require Export per_props_equality.

Lemma mkc_pertype_equality_in_uni {p} :
  forall lib (R1 R2 : @CTerm p) i,
    equality lib (mkc_pertype R1) (mkc_pertype R2) (mkc_uni i)
    <=> (forall x y, member lib (mkc_apply2 R1 x y) (mkc_uni i))
      # (forall x y, member lib (mkc_apply2 R2 x y) (mkc_uni i))
      # (forall x y,
           inhabited_type lib (mkc_apply2 R1 x y)
           <=>
           inhabited_type lib (mkc_apply2 R2 x y))
      # is_per_type lib R1.
Proof.
  introv; split; intro equ; repnd.

  - unfold equality, nuprl in equ; exrepnd.
    inversion equ1; subst; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in equ0; exrepnd.
    inversion equ2; subst; try not_univ.
    dest_per.
    allfold (@nuprl p); allfold (@nuprli p lib j0).
    computes_to_value_isvalue.

    dands; introv.

    generalize (typ1 x y); intro k.
    unfold member, equality.
    exists eq; sp.
    allrw.
    exists (eq1 x y); sp.

    generalize (typ2 x y); intro k.
    unfold member, equality.
    exists eq; sp.
    allrw.
    exists (eq2 x y); sp.

    generalize (typ1 x y); intro k1.
    generalize (typ2 x y); intro k2.
    allapply @nuprli_implies_nuprl.

    generalize (inhabited_type_iff lib (mkc_apply2 R0 x y) (mkc_apply2 R3 x y) (eq1 x y) (eq2 x y)); intro iff; repeat (dest_imp iff hyp).
    rw <- iff; sp.

    generalize (is_per_type_iff_is_per lib R0 eq1); introv iff.
    dest_imp iff hyp.
    intros.
    generalize (typ1 x y); intro k1.
    allapply @nuprli_implies_nuprl; sp.
    rw <- iff; sp.

  - repnd.
    unfold equality, nuprl.

    exists (fun A A' => {eqa : per(p) , close lib (univi lib i) A A' eqa}); sp.
    apply CL_init.
    exists (S i); simpl; left; sp; spcast; try computes_to_value_refl.

    fold (@nuprli p lib i).

    assert (forall x y : CTerm,
              {eq : per
               , nuprli lib i (mkc_apply2 R1 x y) (mkc_apply2 R1 x y) eq}) as f1.
    (* begin proof of the assert *)
    intros.
    unfold member, equality in equ0.
    generalize (equ0 x y); intro k; exrepnd.
    inversion k1; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in k0; exrepnd.
    allfold (@nuprli p lib j0).
    exists eqa; sp.
    (* end of proof of the assert *)

    assert (forall x y : CTerm,
              {eq : per
               , nuprli lib i (mkc_apply2 R2 x y) (mkc_apply2 R2 x y) eq}) as f2.
    (* begin proof of the assert *)
    intros.
    unfold member, equality in equ1.
    generalize (equ1 x y); intro k; exrepnd.
    inversion k1; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in k0; exrepnd.
    allfold (@nuprli p lib j0).
    exists eqa; sp.
    (* end of proof of the assert *)

    generalize (choice_spteqi lib i (mkc_apply2 R1) (mkc_apply2 R1)); intro fn1.
    generalize (choice_spteqi lib i (mkc_apply2 R2) (mkc_apply2 R2)); intro fn2.
    dest_imp fn1 hyp.
    dest_imp fn2 hyp.
    exrepnd.

    exists (fun t t' => inhabited (f0 t t')).
    apply CL_pertype.
    fold (@nuprli p lib i).
    unfold per_pertype.
    exists R1 R2
           (fun t t' => f0 t t')
           (fun t t' => f t t');
      sp; try (spcast; computes_to_value_refl); try (fold nuprl).

    generalize (fn0 x y); intro n1.
    generalize (fn2 x y); intro n2.
    allapply @nuprli_implies_nuprl.
    generalize (inhabited_type_iff lib (mkc_apply2 R1 x y) (mkc_apply2 R2 x y) (f0 x y) (f x y)); intro iff; repeat (dest_imp iff hyp).
    rw iff; sp.

    generalize (is_per_type_iff_is_per lib R1 f0); introv iff.
    dest_imp iff hyp.
    intros.
    generalize (fn2 x y); intro k1.
    allapply @nuprli_implies_nuprl; sp.
    rw iff; sp.
Qed.

Lemma mkc_ipertype_equality_in_uni {p} :
  forall lib (R1 R2 : @CTerm p) i,
    equality lib (mkc_ipertype R1) (mkc_ipertype R2) (mkc_uni i)
    <=> (forall x y, equality lib (mkc_apply2 R1 x y) (mkc_apply2 R2 x y) (mkc_uni i))
        # is_per_type lib R1.
Proof.
  introv; split; intro equ; repnd.

  - unfold equality, nuprl in equ; exrepnd.
    inversion equ1; subst; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in equ0; exrepnd.
    inversion equ2; subst; try not_univ.
    dest_per.
    allfold (@nuprl p lib); allfold (@nuprli p lib j0).
    computes_to_value_isvalue.

    dands; introv.

    generalize (eqtyps x y); intro k.
    exists eq; sp; allrw.
    exists (eq1 x y); sp.

    generalize (is_per_type_iff_is_per lib R0 eq1); introv iff.
    dest_imp iff hyp.
    intros.
    generalize (eqtyps x y); intro k1.
    allapply @nuprli_implies_nuprl; sp.
    apply nuprl_refl in k1; sp.
    rw <- iff; sp.

  - repnd.
    unfold equality, nuprl.

    exists (fun A A' => {eqa : per(p) , close lib (univi lib i) A A' eqa}); sp.
    apply CL_init.
    exists (S i); simpl; left; sp; spcast; try computes_to_value_refl.

    fold (@nuprli p lib i).

    assert (forall x y : CTerm,
              {eq : per
               , nuprli lib i (mkc_apply2 R1 x y) (mkc_apply2 R2 x y) eq}) as f1.
    (* begin proof of the assert *)
    intros.
    unfold member, equality in equ0.
    generalize (equ0 x y); intro k; exrepnd.
    inversion k1; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in k0; exrepnd.
    allfold (@nuprli p lib j0).
    exists eqa; sp.
    (* end of proof of the assert *)

    generalize (choice_spteqi lib i (mkc_apply2 R1) (mkc_apply2 R2)); intro fn1.
    dest_imp fn1 hyp.
    exrepnd.

    exists (pertype_eq f).
    apply CL_ipertype.
    fold (@nuprli p lib i).
    unfold per_ipertype.
    exists R1 R2 f;
      sp; try (spcast; computes_to_value_refl); try (fold nuprl).

    generalize (is_per_type_iff_is_per lib R1 f); introv iff.
    dest_imp iff hyp.
    intros.
    generalize (fn0 x y); intro k1.
    allapply @nuprli_implies_nuprl; sp.
    apply nuprl_refl in k1; sp.
    rw iff; sp.
Qed.

Lemma mkc_spertype_equality_in_uni {p} :
  forall lib (R1 R2 : @CTerm p) i,
    equality lib (mkc_spertype R1) (mkc_spertype R2) (mkc_uni i)
    <=> (forall x y, equality lib (mkc_apply2 R1 x y) (mkc_apply2 R2 x y) (mkc_uni i))
        # (forall x y z,
             inhabited_type lib (mkc_apply2 R1 x z)
             -> equality lib (mkc_apply2 R1 x y) (mkc_apply2 R1 z y) (mkc_uni i))
        # (forall x y z,
             inhabited_type lib (mkc_apply2 R1 y z)
             -> equality lib (mkc_apply2 R1 x y) (mkc_apply2 R1 x z) (mkc_uni i))
        # is_per_type lib R1.
Proof.
  introv; split; intro equ; repnd.

  - unfold equality, nuprl in equ; exrepnd.
    inversion equ1; subst; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in equ0; exrepnd.
    inversion equ2; subst; try not_univ.
    dest_per.
    allfold (@nuprl p); allfold (@nuprli p lib j0).
    computes_to_value_isvalue.

    dands; introv.

    generalize (eqtyps1 x y); intro k.
    exists eq; sp; allrw.
    exists (eq1 x y); sp.

    intro inh.
    generalize (eqtyps1 x z); intro n.
    apply inhabited_if_inhabited_type_i in n; auto.
    generalize (eqtyps2 x y z n); intro ni.
    exists eq; sp.
    allrw; exists (eq1 x y); sp.

    intro inh.
    generalize (eqtyps1 y z); intro n.
    apply inhabited_if_inhabited_type_i in n; auto.
    generalize (eqtyps3 x y z n); intro ni.
    exists eq; sp.
    allrw; exists (eq1 x y); sp.

    generalize (is_per_type_iff_is_per lib R0 eq1); introv iff.
    dest_imp iff hyp.
    intros.
    generalize (eqtyps1 x y); intro k1.
    allapply @nuprli_implies_nuprl; sp.
    apply nuprl_refl in k1; sp.
    rw <- iff; sp.

  - repnd.
    unfold equality, nuprl.

    exists (fun A A' => {eqa : per(p) , close lib (univi lib i) A A' eqa}); sp.
    apply CL_init.
    exists (S i); simpl; left; sp; spcast; try computes_to_value_refl.

    fold (@nuprli p lib i).

    assert (forall x y : CTerm,
              {eq : per
               , nuprli lib i (mkc_apply2 R1 x y) (mkc_apply2 R2 x y) eq}) as f1.
    (* begin proof of the assert *)
    intros.
    unfold member, equality in equ0.
    generalize (equ0 x y); intro k; exrepnd.
    inversion k1; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in k0; exrepnd.
    allfold (@nuprli p lib j0).
    exists eqa; sp.
    (* end of proof of the assert *)

    generalize (choice_spteqi lib i (mkc_apply2 R1) (mkc_apply2 R2)); intro fn1.
    dest_imp fn1 hyp.
    exrepnd.

    exists (pertype_eq f).
    apply CL_spertype.
    fold (@nuprli p lib i).
    unfold per_spertype.
    exists R1 R2 f;
      dands; introv;
      try (spcast; computes_to_value_refl);
      try (fold nuprl);
      try (complete sp).

    intro inh.
    generalize (fn0 x z); intro ni.
    apply inhabited_type_if_inhabited_i in ni; auto.
    generalize (equ1 x y z ni); intro e.
    generalize (fn0 x y); intro n.
    apply equality_nuprli with (C := mkc_apply2 R2 x y); auto.

    intro inh.
    generalize (fn0 y z); intro ni.
    apply inhabited_type_if_inhabited_i in ni; auto.
    generalize (equ2 x y z ni); intro e.
    generalize (fn0 x y); intro n.
    apply equality_nuprli with (C := mkc_apply2 R2 x y); auto.

    generalize (is_per_type_iff_is_per lib R1 f); introv iff.
    dest_imp iff hyp.
    intros.
    generalize (fn0 x y); intro k1.
    allapply @nuprli_implies_nuprl; sp.
    apply nuprl_refl in k1; sp.
    rw iff; sp.
Qed.

Lemma tequality_mkc_pertype {p} :
  forall lib (R1 R2 : @CTerm p),
    tequality lib (mkc_pertype R1) (mkc_pertype R2)
    <=> (forall x y, type lib (mkc_apply2 R1 x y))
      # (forall x y, type lib (mkc_apply2 R2 x y))
      # (forall x y,
           inhabited_type lib (mkc_apply2 R1 x y)
           <=>
           inhabited_type lib (mkc_apply2 R2 x y))
      # is_per_type lib R1.
Proof.
  introv.
  split; intro i.

  - unfold tequality, nuprl in i; exrepnd.
    inversion i0; subst; try not_univ.
    dest_per; allfold (@nuprl p lib).
    computes_to_value_isvalue.

    dands; intros.

    unfold type, tequality; exists (eq1 x y); sp.
    unfold type, tequality; exists (eq2 x y); sp.

    generalize (inhabited_type_iff lib (mkc_apply2 R0 x y) (mkc_apply2 R3 x y) (eq1 x y) (eq2 x y)); intro iff; repeat (dest_imp iff hyp).
    rw <- iff; sp.

    generalize (is_per_type_iff_is_per lib R0 eq1); introv iff.
    dest_imp iff hyp.
    rw <- iff; sp.

  - repnd.
    unfold tequality, nuprl.
    generalize (i0 mkc_axiom mkc_axiom); intro k.

    generalize (choice_spteq lib (mkc_apply2 R1) (mkc_apply2 R1)); intro fn1.
    generalize (choice_spteq lib (mkc_apply2 R2) (mkc_apply2 R2)); intro fn2.
    dest_imp fn1 hyp; exrepnd.
    dest_imp fn2 hyp; exrepnd.
    exists (fun t t' => inhabited (f t t')).
    apply CL_pertype.
    unfold per_pertype.
    exists R1 R2 f f0; sp;
    try (spcast; computes_to_value_refl);
    try (fold nuprl).

    generalize (inhabited_type_iff lib (mkc_apply2 R1 x y) (mkc_apply2 R2 x y) (f x y) (f0 x y)); intro iff; repeat (dest_imp iff hyp).
    rw iff; sp.

    generalize (is_per_type_iff_is_per lib R1 f); introv iff.
    dest_imp iff hyp.
    rw iff; sp.
Qed.

Lemma tequality_mkc_ipertype {p} :
  forall lib (R1 R2 : @CTerm p),
    tequality lib (mkc_ipertype R1) (mkc_ipertype R2)
    <=> (forall x y, tequality lib (mkc_apply2 R1 x y) (mkc_apply2 R2 x y))
        # is_per_type lib R1.
Proof.
  introv.
  split; intro i.

  - unfold tequality, nuprl in i; exrepnd.
    inversion i0; subst; try not_univ.
    dest_per; allfold (@nuprl p lib).
    computes_to_value_isvalue.

    dands; intros.

    generalize (eqtyps x y); intro i.
    apply tequality_if_nuprl in i; sp.

    generalize (is_per_type_iff_is_per1 lib R0 R3 eq1 eqtyps); intro k; apply k; auto.

  - repnd.
    generalize (i0 mkc_axiom mkc_axiom); intro k.

    generalize (choice_spteq lib (mkc_apply2 R1) (mkc_apply2 R2)); intro fn.
    dest_imp fn hyp; exrepnd.
    exists (fun t t' => inhabited (f t t')).
    apply CL_ipertype.
    unfold per_ipertype.
    exists R1 R2 f; sp;
    try (spcast; computes_to_value_refl);
    try (fold nuprl).

    generalize (is_per_type_iff_is_per1 lib R1 R2 f fn0); introv iff.
    rw iff; sp.
Qed.

Lemma tequality_mkc_spertype {p} :
  forall lib (R1 R2 : @CTerm p),
    tequality lib (mkc_spertype R1) (mkc_spertype R2)
    <=> (forall x y, tequality lib (mkc_apply2 R1 x y) (mkc_apply2 R2 x y))
        # (forall x y z,
             inhabited_type lib (mkc_apply2 R1 x z)
             -> tequality lib (mkc_apply2 R1 x y) (mkc_apply2 R1 z y))
        # (forall x y z,
             inhabited_type lib (mkc_apply2 R1 y z)
             -> tequality lib (mkc_apply2 R1 x y) (mkc_apply2 R1 x z))
        # is_per_type lib R1.
Proof.
  introv.
  split; intro i.

  - unfold tequality, nuprl in i; exrepnd.
    inversion i0; subst; try not_univ.
    dest_per; allfold (@nuprl p lib).
    computes_to_value_isvalue.

    dands; intros.

    generalize (eqtyps1 x y); intro i.
    apply tequality_if_nuprl in i; sp.

    generalize (eqtyps2 x y z); intro i; autodimp i hyp.
    eapply inhabited_if_inhabited_type with (T := mkc_apply2 R0 x z) (U := mkc_apply2 R3 x z); eauto.
    apply tequality_if_nuprl in i; sp.

    generalize (eqtyps3 x y z); intro i; autodimp i hyp.
    eapply inhabited_if_inhabited_type with (T := mkc_apply2 R0 y z) (U := mkc_apply2 R3 y z); eauto.
    apply tequality_if_nuprl in i; sp.

    generalize (is_per_type_iff_is_per1 lib R0 R3 eq1 eqtyps1); intro k; apply k; auto.

  - repnd.
    generalize (i0 mkc_axiom mkc_axiom); intro k.

    generalize (choice_spteq lib (mkc_apply2 R1) (mkc_apply2 R2)); intro fn.
    dest_imp fn hyp; exrepnd.
    exists (fun t t' => inhabited (f t t')).
    apply CL_spertype.
    unfold per_spertype.
    exists R1 R2 f; dands; spcast; introv;
    try (spcast; computes_to_value_refl);
    try (fold (@nuprl p lib)); try (complete sp).

    introv inh.
    generalize (fn0 x z); intro e.
    apply inhabited_type_if_inhabited in e; auto.
    apply i1 with (y := y) in e.
    rw <- @tequality_iff_nuprl in e; exrepnd.
    generalize (fn0 x y); intro n.
    generalize (nuprl_uniquely_valued lib (mkc_apply2 R1 x y) eq (f x y));
      intro eqs; repeat (autodimp eqs hyp).
    apply nuprl_refl in e0; auto.
    apply nuprl_refl in n; auto.
    apply nuprl_ext with (eq1 := eq); auto.

    introv inh.
    generalize (fn0 y z); intro e.
    apply inhabited_type_if_inhabited in e; auto.
    apply i2 with (x := x) in e.
    rw <- @tequality_iff_nuprl in e; exrepnd.
    generalize (fn0 x y); intro n.
    generalize (nuprl_uniquely_valued lib (mkc_apply2 R1 x y) eq (f x y));
      intro eqs; repeat (autodimp eqs hyp).
    apply nuprl_refl in e0; auto.
    apply nuprl_refl in n; auto.
    apply nuprl_ext with (eq1 := eq); auto.

    generalize (is_per_type_iff_is_per1 lib R1 R2 f fn0); introv iff.
    rw iff; sp.
Qed.

(*
Lemma mkc_ipertype_equality_in_uni :
  forall R1 R2 i,
    equality lib (mkc_ipertype R1) (mkc_ipertype R2) (mkc_uni i)
    <=> (forall x y, equality lib (mkc_apply2 R1 x y) (mkc_apply2 R2 x y) (mkc_uni i))
      # is_per_type lib R1.
Proof.
  introv; split; intro equ; repnd.

  - unfold equality, nuprl in equ; exrepnd.
    inversion equ1; subst; try not_univ.
    inversion X; exrepd.
    allrw univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rename x into i.
    rw X1 in equ0; exrepnd.
    inversion equ2; subst; try not_univ.
    allunfold per_ipertype; exrepnd.
    allfold nuprl; allfold (nuprli j).
    computes_to_value_isvalue.

    dands; intros.

    generalize (X5 x y); intro k.
    unfold member, equality.
    exists eq; sp.
    rw X1.
    exists (eq1 x y); sp.

    allunfold is_per; repnd; allunfold is_per_type; dands.

    unfold sym_type; introv inh.
    apply inhabited_type_if_inhabited with (U := mkc_apply2 R0 y x) (eq := eq1 y x); sp.
    generalize (X5 y x); intro p; apply nuprli_implies_nuprl in p; sp; allapply nuprl_refl; sp.
    apply X2.
    apply inhabited_if_inhabited_type with (U := mkc_apply2 R0 x y) (T := mkc_apply2 R0 x y); sp.
    generalize (X5 x y); intro p; apply nuprli_implies_nuprl in p; sp; allapply nuprl_refl; sp.

    unfold trans_type; introv inh1 inh2.
    apply inhabited_type_if_inhabited with (U := mkc_apply2 R0 x z) (eq := eq1 x z); sp.
    generalize (X5 x z); intro p; apply nuprli_implies_nuprl in p; sp; allapply nuprl_refl; sp.
    apply X6 with (y := y).
    apply inhabited_if_inhabited_type with (U := mkc_apply2 R0 x y) (T := mkc_apply2 R0 x y); sp.
    generalize (X5 x y); intro p; apply nuprli_implies_nuprl in p; sp; allapply nuprl_refl; sp.
    apply inhabited_if_inhabited_type with (U := mkc_apply2 R0 y z) (T := mkc_apply2 R0 y z); sp.
    generalize (X5 y z); intro p; apply nuprli_implies_nuprl in p; sp; allapply nuprl_refl; sp.

  - repnd.
    unfold equality, nuprl.

    exists (fun A A' => {eqa : per & close (univi i) A A' eqa}); sp.
    apply CL_init.
    exists (S i); simpl; left; sp; try computes_to_value_refl.

    fold (nuprli i).

    assert (forall x y : CTerm,
              {eq : per
               & nuprli i (mkc_apply2 R1 x y) (mkc_apply2 R2 x y) eq}) as f1.
    intros.
    unfold member, equality in equ0.
    generalize (equ0 x y); intro k; exrepnd.
    inversion k1; try not_univ.
    inversion X.
    allrw univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rename x0 into i.
    rw X1 in k0; exrepnd.
    allfold (nuprli j).
    exists eqa; sp.
    (* end of proof of the assert *)

    exists (fun t t' => inhabited (projT1 (f1 t t'))).
    apply CL_ipertype.
    fold (nuprli i).
    unfold per_ipertype.
    exists R1 R2
           (fun t t' => projT1 (f1 t t'));
      sp; try (computes_to_value_refl); try (fold nuprl).

    generalize (f1 x y); intro h; exrepnd; allsimpl; sp.

    unfold is_per_type in equ; unfold sym_type, trans_type in equ; repnd.
    unfold is_per; dands; introv.

    generalize (f1 x y); generalize (f1 y x); intros h1 h2 inh; exrepnd; allsimpl.
    apply inhabited_if_inhabited_type with (U := mkc_apply2 R1 y x) (T := mkc_apply2 R1 y x); sp;
    try (complete (allapply nuprli_implies_nuprl; sp; allapply nuprl_refl; sp)).
    apply equ1.
    apply inhabited_type_if_inhabited with (U := mkc_apply2 R1 x y) (eq := eq); sp;
    try (complete (allapply nuprli_implies_nuprl; sp; allapply nuprl_refl; sp)).

    generalize (f1 x y); generalize (f1 y z); generalize (f1 x z); intros h1 h2 h3 inh1 inh2; exrepnd; allsimpl.
    apply inhabited_if_inhabited_type with (U := mkc_apply2 R1 x z) (T := mkc_apply2 R1 x z); sp;
    try (complete (allapply nuprli_implies_nuprl; sp; allapply nuprl_refl; sp)).
    apply equ with (y := y).
    apply inhabited_type_if_inhabited with (U := mkc_apply2 R1 x y) (eq := eq); sp;
    try (complete (allapply nuprli_implies_nuprl; sp; allapply nuprl_refl; sp)).
    apply inhabited_type_if_inhabited with (U := mkc_apply2 R1 y z) (eq := eq0); sp;
    try (complete (allapply nuprli_implies_nuprl; sp; allapply nuprl_refl; sp)).
(*Error: Universe inconsistency.*)
[Admitted.]
*)

Lemma type_mkc_pertype {p} :
  forall lib (R : @CTerm p),
    type lib (mkc_pertype R)
    <=> (forall x y, type lib (mkc_apply2 R x y))
      # is_per_type lib R.
Proof.
  introv.
  unfold type.
  rw @tequality_mkc_pertype; split; sp.
  rw @fold_type; sp.
  unfold type; sp.
  unfold type; sp.
Qed.

Lemma type_mkc_ipertype {p} :
  forall lib (R : @CTerm p),
    type lib (mkc_ipertype R)
    <=> (forall x y, type lib (mkc_apply2 R x y))
      # is_per_type lib R.
Proof.
  introv.
  unfold type.
  rw @tequality_mkc_ipertype; split; sp.
Qed.

Lemma type_mkc_spertype {p} :
  forall lib (R : @CTerm p),
    type lib (mkc_spertype R)
    <=> (forall x y, type lib (mkc_apply2 R x y))
        # (forall x y z,
             inhabited_type lib (mkc_apply2 R x z)
             -> tequality lib (mkc_apply2 R x y) (mkc_apply2 R z y))
        # (forall x y z,
             inhabited_type lib (mkc_apply2 R y z)
             -> tequality lib (mkc_apply2 R x y) (mkc_apply2 R x z))
        # is_per_type lib R.
Proof.
  introv.
  unfold type.
  rw @tequality_mkc_spertype; split; sp.
Qed.

Lemma iff_inhabited_type_if_pertype_eq_or_ceq {p} :
  forall lib (R1 R2 : @CTerm p) i,
    (equality lib (mkc_pertype R1) (mkc_pertype R2) (mkc_uni i)
     [+] cequivc lib (mkc_pertype R1) (mkc_pertype R2))
    -> forall x y,
         inhabited_type lib (mkc_apply2 R1 x y)
          <=> inhabited_type lib (mkc_apply2 R2 x y).
Proof.
  introv or.
  introv.
  split; intro inh; repdors.

  apply equality_in_uni in or0.
  rw @tequality_mkc_pertype in or0; repnd.
  rw <- or3; sp.

  generalize (cequivc_mkc_pertype lib (mkc_pertype R1) (mkc_pertype R2) R1);
    intro j; repeat (dest_imp j hyp); try (complete computes_to_value_refl); exrepnd.
  computes_to_value_isvalue.
  assert (cequivc lib (mkc_apply2 R1 x y) (mkc_apply2 b x y))
         as ceq
         by (repeat (rw @mkc_apply2_eq); repeat (apply sp_implies_cequivc_apply); sp).
  apply inhabited_type_cequivc with (a := mkc_apply2 R1 x y); sp.

  apply equality_in_uni in or0.
  rw @tequality_mkc_pertype in or0; repnd.
  rw or3; sp.

  generalize (cequivc_mkc_pertype lib (mkc_pertype R1) (mkc_pertype R2) R1);
    intro j; repeat (dest_imp j hyp); try (complete computes_to_value_refl); exrepnd.
  computes_to_value_isvalue.
  assert (cequivc lib (mkc_apply2 R1 x y) (mkc_apply2 b x y))
         as ceq
         by (repeat (rw @mkc_apply2_eq); repeat (apply sp_implies_cequivc_apply); sp).
  apply inhabited_type_cequivc with (a := mkc_apply2 b x y); sp.
  apply cequivc_sym; sp.
Qed.

(*
Lemma tequality_mkc_apply2_if_pertype_eq_or_ceq :
  forall R1 R2 i,
    (equality lib (mkc_ipertype R1) (mkc_ipertype R2) (mkc_uni i)
     [+] cequivc (mkc_ipertype R1) (mkc_ipertype R2))
    -> forall x y : CTerm,
         (type lib (mkc_apply2 R1 x y) [+] type lib (mkc_apply2 R2 x y))
         -> tequality lib (mkc_apply2 R1 x y)
                      (mkc_apply2 R2 x y).
Proof.
  introv eq.
  introv typ.
  destruct eq.

  apply equality_in_uni in e.
  rw tequality_mkc_ipertype in e; sp.

  generalize (cequivc_mkc_ipertype lib (mkc_ipertype R1) (mkc_ipertype R2) R1);
    intro j; repeat (dest_imp j hyp); try (complete computes_to_value_refl); exrepnd.
  computes_to_value_isvalue.
  assert (cequivc (mkc_apply2 R1 x y) (mkc_apply2 b x y))
         as ceq
         by (repeat (rw mkc_apply2_eq); repeat (apply sp_implies_cequivc_apply); sp).
  destruct typ.
  apply type_respects_cequivc_right; sp.
  apply type_respects_cequivc_left; sp.
  apply cequivc_sym; sp.
Qed.
*)

Lemma equality_in_mkc_pertype {p} :
  forall lib (t1 t2 R : @CTerm p),
    equality lib t1 t2 (mkc_pertype R)
    <=> (inhabited_type lib (mkc_apply2 R t1 t2)
         # is_per_type lib R
         # (forall x y, type lib (mkc_apply2 R x y))).
Proof.
  intros; unfold inhabited_type; split; intro i; exrepnd.

  - unfold equality, nuprl in i; exrepnd.
    inversion i1; subst; try not_univ.
    dest_per.
    allfold (@nuprl p lib).
    computes_to_value_isvalue.
    rw pereq in i0.
    clear typ2 inhiff eq2.
    unfold inhabited in i0; exrepnd.
    dands.

    exists t; unfold member, equality; exists (eq1 t1 t2); sp.

    generalize (is_per_type_iff_is_per lib R1 eq1); introv iff.
    dest_imp iff hyp.
    rw <- iff; sp.

    introv.
    unfold type, tequality.
    exists (eq1 x y); sp.

  - unfold member, equality in i2; exrepnd.
    generalize (choice_spteq lib (mkc_apply2 R) (mkc_apply2 R)); intro fn.
    dest_imp fn hyp; exrepnd.
    generalize (fn0 t1 t2); intro n.
    pose proof (nuprl_uniquely_valued lib (mkc_apply2 R t1 t2) eq (f t1 t2)) as eqt.
    repeat (dest_imp eqt hyp).

    exists (fun a b => inhabited (f a b)); sp;
    try (complete (rw eqt in i0; exists t; sp)).

    apply CL_pertype; unfold per_pertype.
    allfold (@nuprl p lib).
    exists R R f f; sp;
    try (spcast; complete computes_to_value_refl).

    generalize (is_per_type_iff_is_per lib R f); introv iff.
    dest_imp iff hyp.
    rw iff; sp.
Qed.

Lemma equality_in_mkc_pertype2 {p} :
  forall lib (t1 t2 R : @CTerm p),
    equality lib t1 t2 (mkc_pertype R)
    <=> (inhabited_type lib (mkc_apply2 R t1 t2) # type lib (mkc_pertype R)).
Proof.
  introv.
  rw @equality_in_mkc_pertype.
  rw @type_mkc_pertype; split; sp.
Qed.

Lemma equality_in_mkc_ipertype {p} :
  forall lib (t1 t2 R : @CTerm p),
    equality lib t1 t2 (mkc_ipertype R)
    <=> (inhabited_type lib (mkc_apply2 R t1 t2)
         # is_per_type lib R
         # (forall x y, type lib (mkc_apply2 R x y))).
Proof.
  intros; unfold inhabited_type; split; intro i; exrepnd.

  - unfold equality, nuprl in i; exrepnd.
    inversion i1; subst; try not_univ.
    dest_per.
    allfold (@nuprl p lib).
    computes_to_value_isvalue.
    rw pereq in i0.
    unfold pertype_eq, inhabited in i0; exrepnd.
    dands.

    exists t; unfold member, equality; exists (eq1 t1 t2); sp.

    generalize (is_per_type_iff_is_per lib R1 eq1 eqtyps); introv iff.
    apply iff; auto.

    introv; exists (eq1 x y); sp.

  - unfold member, equality, nuprl in i2; exrepnd.
    allfold (@nuprl p lib).
    generalize (choice_spteq lib (mkc_apply2 R) (mkc_apply2 R) i); intro fn; exrepnd.
    generalize (fn0 t1 t2); intro n.
    pose proof (nuprl_uniquely_valued lib (mkc_apply2 R t1 t2) eq (f t1 t2)) as eqt.
    repeat (autodimp eqt hyp).

    exists (fun a b => inhabited (f a b)); sp;
    try (complete (rw eqt in i0; exists t; sp)).

    apply CL_ipertype; unfold per_ipertype.
    allfold (@nuprl p lib).
    exists R R f; sp;
    try (spcast; complete computes_to_value_refl).

    generalize (is_per_type_iff_is_per lib R f fn0); introv iff.
    rw iff; sp.
Qed.

Lemma equality_in_mkc_ipertype2 {p} :
  forall lib (t1 t2 R : @CTerm p),
    equality lib t1 t2 (mkc_ipertype R)
    <=> (inhabited_type lib (mkc_apply2 R t1 t2) # type lib (mkc_ipertype R)).
Proof.
  introv.
  rw @equality_in_mkc_ipertype.
  rw @type_mkc_ipertype; split; sp.
Qed.

Lemma equality_in_mkc_spertype {p} :
  forall lib (t1 t2 R : @CTerm p),
    equality lib t1 t2 (mkc_spertype R)
    <=> (inhabited_type lib (mkc_apply2 R t1 t2)
         # (forall x y, type lib (mkc_apply2 R x y))
         # (forall x y z,
              inhabited_type lib (mkc_apply2 R x z)
              -> tequality lib (mkc_apply2 R x y) (mkc_apply2 R z y))
         # (forall x y z,
              inhabited_type lib (mkc_apply2 R y z)
              -> tequality lib (mkc_apply2 R x y) (mkc_apply2 R x z))
         # is_per_type lib R).
Proof.
  intros.
  rw <- @type_mkc_spertype.
  split; intro i; exrepnd.

  - applydup @inhabited_implies_tequality in i as ty; dands; auto.
    unfold equality, nuprl in i; exrepnd.
    inversion i1; subst; try not_univ.
    dest_per.
    allfold (@nuprl p lib).
    computes_to_value_isvalue.
    rw pereq in i0.
    unfold pertype_eq, inhabited in i0; exrepnd.

    exists t; unfold member, equality; exists (eq1 t1 t2); sp.

  - rw @type_mkc_spertype in i; repnd.
    unfold inhabited_type in i0; exrepnd.
    unfold member, equality, nuprl in i4; exrepnd.
    allfold (@nuprl p lib).
    generalize (choice_spteq lib (mkc_apply2 R) (mkc_apply2 R) i1); intro fn; exrepnd.
    generalize (fn0 t1 t2); intro n.
    pose proof (nuprl_uniquely_valued lib (mkc_apply2 R t1 t2) eq (f t1 t2)) as eqt.
    repeat (autodimp eqt hyp).

    exists (fun a b => inhabited (f a b)); sp;
    try (complete (rw eqt in i0; exists t; sp)).

    apply CL_spertype; unfold per_spertype.
    allfold (@nuprl p lib).
    exists R R f; dands; introv;
    try (spcast; complete computes_to_value_refl);
    try (complete sp).

    introv inh.
    generalize (fn0 x z); intro e.
    apply inhabited_type_if_inhabited in e; auto.
    apply i2 with (y := y) in e.
    rw <- @tequality_iff_nuprl in e; exrepnd.
    generalize (fn0 x y); intro nu.
    generalize (nuprl_uniquely_valued lib (mkc_apply2 R x y) eq0 (f x y));
      intro eqs; repeat (autodimp eqs hyp).
    apply nuprl_refl in e0; auto.
    apply nuprl_ext with (eq1 := eq0); auto.

    introv inh.
    generalize (fn0 y z); intro e.
    apply inhabited_type_if_inhabited in e; auto.
    apply i3 with (x := x) in e.
    rw <- @tequality_iff_nuprl in e; exrepnd.
    generalize (fn0 x y); intro nu.
    generalize (nuprl_uniquely_valued lib (mkc_apply2 R x y) eq0 (f x y));
      intro eqs; repeat (autodimp eqs hyp).
    apply nuprl_refl in e0; auto.
    apply nuprl_ext with (eq1 := eq0); auto.

    generalize (is_per_type_iff_is_per lib R f fn0); introv iff.
    rw iff; sp.
Qed.

Lemma equality_in_mkc_spertype2 {p} :
  forall lib (t1 t2 R : @CTerm p),
    equality lib t1 t2 (mkc_spertype R)
    <=> (inhabited_type lib (mkc_apply2 R t1 t2)
         # type lib (mkc_spertype R)).
Proof.
  intros.
  rw @equality_in_mkc_spertype.
  rw @type_mkc_spertype; sp.
Qed.

Lemma iff_inhabited_type_if_pertype_cequorsq {p} :
  forall lib (R1 R2 : @CTerm p) i,
    equorsq lib (mkc_pertype R1) (mkc_pertype R2) (mkc_uni i)
    -> forall x y,
         inhabited_type lib (mkc_apply2 R1 x y)
          <=> inhabited_type lib (mkc_apply2 R2 x y).
Proof.
  unfold equorsq; introv or.
  introv.
  split; intro inh; repdors.

  apply equality_in_uni in or0.
  rw @tequality_mkc_pertype in or0; repnd.
  rw <- or3; sp.

  spcast.
  generalize (cequivc_mkc_pertype lib (mkc_pertype R1) (mkc_pertype R2) R1);
    intro j; repeat (dest_imp j hyp); try (complete computes_to_value_refl); exrepnd.
  computes_to_value_isvalue.
  assert (cequivc lib (mkc_apply2 R1 x y) (mkc_apply2 b x y))
         as ceq
         by (repeat (rw @mkc_apply2_eq); repeat (apply sp_implies_cequivc_apply); sp).
  apply inhabited_type_cequivc with (a := mkc_apply2 R1 x y); sp.

  apply equality_in_uni in or0.
  rw @tequality_mkc_pertype in or0; repnd.
  rw or3; sp.

  spcast.
  generalize (cequivc_mkc_pertype lib (mkc_pertype R1) (mkc_pertype R2) R1);
    intro j; repeat (dest_imp j hyp); try (complete computes_to_value_refl); exrepnd.
  computes_to_value_isvalue.
  assert (cequivc lib (mkc_apply2 R1 x y) (mkc_apply2 b x y))
         as ceq
         by (repeat (rw @mkc_apply2_eq); repeat (apply sp_implies_cequivc_apply); sp).
  apply inhabited_type_cequivc with (a := mkc_apply2 b x y); sp.
  apply cequivc_sym; sp.
Qed.

Lemma iff_inhabited_type_if_ipertype_cequorsq {p} :
  forall lib (R1 R2 : @CTerm p) i,
    (forall x y : CTerm, type lib (mkc_apply2 R1 x y))
    -> equorsq lib (mkc_ipertype R1) (mkc_ipertype R2) (mkc_uni i)
    -> forall x y, tequality lib (mkc_apply2 R1 x y) (mkc_apply2 R2 x y).
Proof.
  unfold equorsq; introv istype or; introv.
  repdors.

  apply equality_in_uni in or0.
  rw @tequality_mkc_ipertype in or0; repnd; sp.

  spcast.
  generalize (cequivc_mkc_ipertype lib (mkc_ipertype R1) (mkc_ipertype R2) R1);
    intro j; repeat (dest_imp j hyp); try (complete computes_to_value_refl); exrepnd.
  computes_to_value_isvalue.
  assert (cequivc lib (mkc_apply2 R1 x y) (mkc_apply2 b x y))
         as ceq
         by (repeat (rw @mkc_apply2_eq); repeat (apply sp_implies_cequivc_apply); sp).
  generalize (istype x y); intro t.
  apply cequivc_sym in ceq; rwg ceq; sp.
Qed.

Lemma iff_inhabited_type_if_spertype_cequorsq {p} :
  forall lib (R1 R2 : @CTerm p) i,
    (forall x y : CTerm, type lib (mkc_apply2 R1 x y))
    -> equorsq lib (mkc_spertype R1) (mkc_spertype R2) (mkc_uni i)
    -> forall x y, tequality lib (mkc_apply2 R1 x y) (mkc_apply2 R2 x y).
Proof.
  unfold equorsq; introv istype or; introv.
  repdors.

  apply equality_in_uni in or0.
  rw @tequality_mkc_spertype in or0; repnd; sp.

  spcast.
  generalize (cequivc_mkc_spertype lib (mkc_spertype R1) (mkc_spertype R2) R1);
    intro j; repeat (dest_imp j hyp); try (complete computes_to_value_refl); exrepnd.
  computes_to_value_isvalue.
  assert (cequivc lib (mkc_apply2 R1 x y) (mkc_apply2 b x y))
         as ceq
         by (repeat (rw @mkc_apply2_eq); repeat (apply sp_implies_cequivc_apply); sp).
  generalize (istype x y); intro t.
  apply cequivc_sym in ceq; rwg ceq; sp.
Qed.