Require Import Privilege.
Require Import Axioms.

Require Import Ctl.BinaryRelations.
Require Import Glib.Glib.

Open Scope string_scope.

(* Dynamic environments (partial maps from variables to arbitrary types) *)

(* TODO: abstract as a section variable? *)
Definition var  := string.
Definition comp := string.

Definition env := var -> option (access × Σ V, V).

Declare Scope env_scope.
(* Delimit Scope env_scope with env. *)
Bind Scope env_scope with env.
Open Scope env_scope.

Definition env_empty: env := λ _, None.
Notation "•" := env_empty : env_scope.

Definition env_singleton {V} var (acc: access) (v: V): env := λ lookup,
  if lookup =? var then Some (acc, existT _ V v) else None.
Notation "var ↦ v" := (env_singleton var allAcc v)
  (at level 55, right associativity) : env_scope.

Definition map_access (Γ: env) (acc: access): env := λ lookup,
  match Γ lookup with
  | Some (_, v) => Some (acc, v)
  | None => None
  end.
Notation "acc ? Γ" := (map_access Γ acc)
  (at level 60) : env_scope.
  (* (at level 60, format "acc ?  Γ") : env_scope. *)

(* First env shadows definitions in second *)
Definition env_concat (Γ1 Γ2: env) : env := λ lookup,
  match Γ1 lookup with
  | Some v => Some v
  | None => Γ2 lookup
  end.
Notation "Γ1 ;; Γ2" := (env_concat Γ1 Γ2)
  (at level 65, right associativity) : env_scope.

Definition read {V} (Γ: env) (c: comp) (name: var) (v: V) : Prop :=
  exists! acc: access,
    Γ name = Some (acc, existT _ V v) /\
    acc c p_read.

Definition write {V} (Γ: env) (c: comp) (name: var) (v: V) (Γ': env) : Prop :=
  exists! (acc: access) curr,
    Γ name = Some (acc, curr) /\
    acc c p_write /\
    Γ' = acc ? name ↦ v ;; Γ.

Definition remove_var (Γ: env) var : env := λ lookup,
  if lookup =? var then None else Γ lookup.

Lemma map_acc_env_singleton : forall acc x V (v: V),
  (acc ? x ↦ v) = env_singleton x acc v.
Proof using.
  intros *.
  extensionality y.
  unfold env_singleton.
  replace (
    acc ? (λ lookup,
      if lookup =? x
      then Some (allAcc, existT _ V v)
      else None))
  with
    (λ lookup,
      if lookup =? x
      then Some (acc, existT _ V v)
      else None
  ).
  - reflexivity.
  - extensionality lookup.
    unfold map_access.
    now destruct (lookup =? x).
Qed.

Lemma refl_string_eq : forall x y,
  x =? y ->
  x = y.
Proof using.
  intros * ?.
  now destruct (eqb_spec x y).
Qed.

Theorem env_singleton_inv : forall acc x y V (v: V) v',
  (acc ? x ↦ v) y = Some v' ->
  x = y /\ v' = (acc, existT _ V v).
Proof using.
  intros * H.
  rewrite map_acc_env_singleton in H.
  unfold env_singleton in H.
  destruct (y =? x) eqn:case; [|discriminate].
  apply refl_string_eq in case as ->.
  now inv H.
Qed.

Theorem env_prepend_singleton_unchanged : forall (Γ: env) x y acc V (v: V),
  x <> y ->
  Γ y = (acc ? x ↦ v ;; Γ) y.
Proof using.
  intros * Hneq.
  unfold env_concat.
  destruct ((acc ? x ↦ v) y) eqn:case.
  - apply env_singleton_inv in case as [-> _].
    contradiction.
  - reflexivity.
Qed.

Theorem write_unchanged : forall Γ Γ' x y c V (v: V),
  write Γ c x v Γ' ->
  x <> y ->
  Γ y = Γ' y.
Proof using.
  intros * Hwrite Hneq.
  destruct Hwrite as [acc [[curr [(Hwrite1 & Hwrite2 & ->) _]] _]].
  now apply env_prepend_singleton_unchanged.
Qed.

Theorem write_unchanged_read : forall Γ Γ' x y c c' V (v: V) V' (v': V'),
  write Γ c x v Γ' ->
  x <> y ->
  read Γ c' y v' ->
  read Γ' c' y v'.
Proof using.
  intros * Hwrite Hneq Hread.
  unfold read in *.
  destruct Hread as (acc & (Hlookup & Hacc) & Hunique).
  exists acc.
  max split.
  - rewrite <- Hlookup.
    symmetry.
    enow eapply write_unchanged.
  - assumption.
  - intros * [H _].
    erewrite <- write_unchanged in H; [|eassumption|eassumption].
    rewrite Hlookup in H.
    now inv H.
Qed.

Theorem write_unchanged_read' : forall Γ Γ' x y c c' V (v: V) V' (v': V'),
  write Γ c x v Γ' ->
  x <> y ->
  read Γ' c' y v' ->
  read Γ c' y v'.
Proof using.
  intros * Hwrite Hneq Hread.
  unfold read in *.
  destruct Hread as (acc & (Hlookup & Hacc) & Hunique).
  exists acc.
  max split.
  - rewrite <- Hlookup.
    enow eapply write_unchanged.
  - assumption.
  - intros * [H _].
    erewrite <- write_unchanged in Hlookup; [|eassumption|eassumption].
    rewrite Hlookup in H.
    now inv H.
Qed.

Theorem no_lookup_no_read : forall Γ c x V (v: V),
  Γ x = None -> ~ read Γ c x v.
Proof using.
  intros * Heq Hread.
  destruct Hread as (acc & (Heq' & _) & _).
  rewrite Heq in Heq'.
  discriminate Heq'.
Qed.

Close Scope env_scope.
Close Scope string_scope.


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

(***
Modulus : 2^189 - 25
Base: 27
***)

Definition curve : CurveParameters :=
  {|
    sz := 7%nat;
    base := 27;
    bitwidth := 32;
    s := 2^189;
    c := [(1, 25)];
    carry_chains := Some [seq 0 (pred 7); [0; 1]]%nat;

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

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

    mul_code := None;

    square_code := None;

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

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


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

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

Local Open Scope struct_scope.

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

Require Import depoolContract.NewProofs.ProofHelpers.
Require Import depoolContract.DePoolFunc.

(* Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Require Import depoolContract.Lib.CommonStateProofs.

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

Require Import depoolContract.DePoolConsts.
Module DePoolContract_Ф_setValidatorRewardFraction (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Module ProofHelpers := ProofHelpers dc.

Import dc.
Import ProofHelpers.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo deleteListPair.

(* function setValidatorRewardFraction(uint8 fraction) public {
     require(msg.pubkey() == tvm.pubkey(), Errors.IS_NOT_OWNER);
     require(fraction < m_validatorRewardFraction, Errors.NEW_VALIDATOR_FRACTION_MUST_BE_GREATER_THAN_OLD);
     require(fraction > 0, Errors.FRACTION_MUST_NOT_BE_ZERO);
     tvm.accept();

     m_validatorRewardFraction = fraction;
     m_participantRewardFraction = 100 - m_validatorRewardFraction;
     emit RewardFractionsChanged(m_validatorRewardFraction, m_participantRewardFraction);
  } *)

Lemma DePoolContract_Ф_setValidatorRewardFraction_exec : forall ( Л_fraction : XInteger8 )
                                                                (l: Ledger) ,
let req1 : bool := eval_state msg_pubkey l =? eval_state tvm_pubkey l in
let req2 : bool := Л_fraction <? (eval_state ( ↑12 ε DePoolContract_ι_m_validatorRewardFraction ) l) in
let req3 : bool := Л_fraction >? 0 in
let l_tvm_accept := exec_state ( tvm_accept ) l in
let m_validatorRewardFraction := Л_fraction in
let m_participantRewardFraction := 100 - m_validatorRewardFraction in
let oldEvents := eval_state (↑16 ε VMState_ι_events) l in
let newEvent  := RewardFractionsChanged m_validatorRewardFraction m_participantRewardFraction in

let l' := if req1 then
            if req2 then
              if req3 then {$ l_tvm_accept With ( DePoolContract_ι_m_validatorRewardFraction , m_validatorRewardFraction ) ;
                                                ( DePoolContract_ι_m_participantRewardFraction , m_participantRewardFraction ) ;
                                                (VMState_ι_events ,  newEvent :: oldEvents ) $}
              else l
            else l
          else l  in
exec_state ( ↓ DePoolContract_Ф_setValidatorRewardFraction Л_fraction ) l = l' .
Proof.
  intros.
  destructLedger l.
  compute. idtac.

  Time repeat destructIf_solve2.
Qed.

Lemma DePoolContract_Ф_setValidatorRewardFraction_eval : forall ( Л_fraction : XInteger8 )
                                                                (l: Ledger) ,
let req1 : bool := eval_state msg_pubkey l =? eval_state tvm_pubkey l in
let req2 : bool := Л_fraction <? (eval_state ( ↑12 ε DePoolContract_ι_m_validatorRewardFraction ) l) in
let req3 : bool := Л_fraction >? 0 in

let ret' := if req1 then
            if req2 then
              if req3 then Value I
              else Error Errors_ι_FRACTION_MUST_NOT_BE_ZERO
            else Error Errors_ι_NEW_VALIDATOR_FRACTION_MUST_BE_GREATER_THAN_OLD
          else Error Errors_ι_IS_NOT_OWNER in
eval_state ( ↓ DePoolContract_Ф_setValidatorRewardFraction Л_fraction ) l = ret' .
Proof.
  intros.
  destructLedger l.
  compute. idtac.

  Time repeat destructIf_solve2.
Qed.

End DePoolContract_Ф_setValidatorRewardFraction.


Require Import Coq.omega.Omega.
Require Import Bedrock.Platform.tests.Thread0 Bedrock.Platform.Bootstrap.

Module Type HIDE.
  Parameter heapSize4 : N -> N.
  Axiom heapSize4_eq : forall n, heapSize4 n = (n * 4)%N.

  Parameter to_nat : N -> nat.
  Axiom to_nat_eq : to_nat = N.to_nat.
End HIDE.

Module Hide : HIDE.
  Definition heapSize4 n := (n * 4)%N.
  Theorem heapSize4_eq : forall n, heapSize4 n = (n * 4)%N.
    auto.
  Qed.

  Definition to_nat := N.to_nat.
  Theorem to_nat_eq : to_nat = N.to_nat.
    auto.
  Qed.
End Hide.

Module Type S.
  Parameter heapSize : N.
End S.

Module Make(M : S).
Import M.

Module M'.
  Definition globalSched : W := ((heapSize + 50) * 4)%N.
End M'.
Import M'.

Module T := Thread0.Make(M').

Section boot.
  Definition heapSize' := Hide.to_nat heapSize.

  Hypothesis heapSizeLowerBound : (3 <= heapSize)%N.

  Let heapSizeLowerBound' : (3 <= heapSize')%nat.
    intros; unfold heapSize'; rewrite Hide.to_nat_eq.
    assert (heapSize >= 3)%N by (apply N.le_ge; auto); nomega.
  Qed.

  Definition size := heapSize' + 50 + 2.
  (* The reserved heap slots are:
   * 1) scheduler
   * 2) saved Bedrock stack pointer for current thread *)

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize' * 4).
    goodSize.
  Qed.

  Lemma heapSizeLowerBound'' : natToW 3 <= NToW heapSize.
    hnf; intros.
    red in H.
    pre_nomega.
    rewrite wordToNat_natToWord_idempotent in H by reflexivity.
    unfold heapSize' in *.
    rewrite Hide.to_nat_eq in *.
    unfold NToW in *.
    rewrite NToWord_nat in *.
    rewrite wordToNat_natToWord_idempotent in H.
    omega.
    rewrite N2Nat.id.
    eapply goodSize_weaken in mem_size.
    2: instantiate (1 := N.to_nat heapSize); unfold size.
    Transparent goodSize.
    unfold goodSize in *.
    rewrite N2Nat.id in *.
    assumption.
    unfold heapSize'.
    rewrite Hide.to_nat_eq.
    omega.
  Qed.

  Hint Immediate heapSizeLowerBound''.

  Definition appmainS := SPEC reserving 49
    PREonly[_] mallocHeap 0.

  Definition bootS := bootS heapSize' 2.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "app"!"main" @ [appmainS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%N;;

        Assert [PREmain[_] globalSched =?> 2 * 0 =?> heapSize'];;

        Call "malloc"!"init"(0, heapSize)
        [PREmain[_] globalSched =?> 2 * mallocHeap 0];;

        Goto "app"!"main"
      end
    }}.

  Lemma bootstrap_Sp_nonzero : forall sp : W,
    sp = 0
    -> sp = (heapSize' * 4)%nat
    -> goodSize (heapSize' * 4)
    -> False.
    intros; eapply bootstrap_Sp_nonzero; try eassumption; eauto.
  Qed.

  Lemma bootstrap_Sp_freeable : forall sp : W,
    sp = (heapSize' * 4)%nat
    -> freeable sp 50.
    intros; eapply bootstrap_Sp_freeable; try eassumption; eauto.
  Qed.

  Lemma noWrap : noWrapAround 4 (wordToNat (NToW heapSize) - 1).
    intros.
    unfold NToW; rewrite NToWord_nat by auto.
    unfold heapSize' in *; rewrite Hide.to_nat_eq in *.
    rewrite wordToNat_natToWord_idempotent.
    apply noWrap; eauto.
    eapply goodSize_weaken.
    2: instantiate (1 := (heapSize' * 4)%nat).
    unfold heapSize'; rewrite Hide.to_nat_eq; auto.
    unfold heapSize'; rewrite Hide.to_nat_eq; auto.
  Qed.

  Local Hint Immediate bootstrap_Sp_nonzero bootstrap_Sp_freeable noWrap.

  Lemma break : NToW ((heapSize + 50) * 4)%N = ((heapSize' + 50) * 4)%nat.
    intros.
    unfold NToW; rewrite NToWord_nat by auto.
    unfold heapSize'; rewrite N2Nat.inj_mul; auto.
    rewrite Hide.to_nat_eq; rewrite N2Nat.inj_add; auto.
  Qed.

  Lemma times4 : (Hide.heapSize4 heapSize : W) = (heapSize' * 4)%nat.
    rewrite Hide.heapSize4_eq; intros.
    unfold NToW; rewrite NToWord_nat by auto.
    unfold heapSize'; rewrite N2Nat.inj_mul; auto.
    rewrite Hide.to_nat_eq; auto.
  Qed.

  Lemma wordToNat_heapSize : wordToNat (NToW heapSize) = heapSize'.
    unfold heapSize'; rewrite Hide.to_nat_eq.
    unfold NToW.
    rewrite NToWord_nat.
    apply wordToNat_natToWord_idempotent.
    eapply goodSize_weaken.
    2: instantiate (1 := (heapSize' * 4)%nat).
    auto.
    unfold heapSize'; rewrite Hide.to_nat_eq; auto.
  Qed.

  Hint Rewrite break times4 wordToNat_heapSize : sepFormula.

  Ltac t := unfold globalSched, localsInvariantMain, globalSched; genesis.

  Theorem ok0 : moduleOk boot.
    unfold boot; rewrite <- Hide.heapSize4_eq; vcgen; abstract t.
  Qed.

  Global Opaque heapSize'.

  Definition m := link boot T.T.m.

  Theorem ok : moduleOk m.
    link ok0 T.T.ok.
  Qed.

  (* No final proof here, because that crucial app.main() function is outside the
   * scope of Bedrock! *)
End boot.

End Make.


From Coq Require Import
     ssreflect
.

From ExtensibleCompiler.Theory Require Import
     Algebra
     Eval
     Functor
     ProgramAlgebra
     SubFunctor
     Sum1
     Types
     UniversalProperty
.

Local Open Scope SubFunctor.

Inductive Bool (A: Set) : Set :=
| MkBool (boolean : bool)
.
Arguments MkBool {A}.

Global Instance Functor__Bool
  : Functor Bool.
Proof.
  refine
    {|
      fmap := fun A B f '(MkBool b) => MkBool b;
    |}.
  - move => ? [] //.
  - move => ????? [] //.
Defined.

Section Bool.

  Context
    {E}
    `{Functor E}
    `{E supports Bool}
  .

  Definition boolean
             (b : bool)
    : WellFormedValue E
    := injectUP' (MkBool b).

  Definition booleanF
             (b : bool)
    : Fix E
    := proj1_sig (boolean b).

  Definition isBoolean
    : Fix E -> option bool
    := fun typ =>
         match projectUP' typ with
         | Some (MkBool b) => Some b
         | None            => None
         end.

  Definition InductionAlgebra__Bool
             (P : forall (e : Fix E), FoldUP' e -> Prop)
             (IH__boolean :
                forall b,
                  UniversalPropertyP P (booleanF b))
    : Algebra Bool (sig (UniversalPropertyP P))
    := fun '(MkBool b) => exist _ _ (IH__boolean b).

End Bool.

Section Bool.

  Context
    {E}
    `{Functor E}
    `{E supports Bool}

    {F}
    `{Functor F}
    `{F supports Bool}
  .

  Definition Induction2Algebra__Bool
             (P :
                forall (e : Fix E * Fix F),
                  FoldUP' (fst e) /\ FoldUP' (snd e) -> Prop)
             (IH__boolean :
                forall b,
                  UniversalPropertyP2 P (booleanF b, booleanF b))
    : Algebra Bool (sig (UniversalPropertyP2 P))
    := fun '(MkBool b) => exist _ _ (IH__boolean b).

End Bool.


Require Export Iron.Language.SystemF2Cap.Type.
Require Export Iron.Language.SystemF2Cap.Value.Exp.
Require Export Iron.Language.SystemF2Cap.Value.Operator.LiftX.
Require Export Iron.Language.SystemF2Cap.Value.Relation.TyJudge.

(********************************************************************)
(* Substitution of Types in Exps *)
Fixpoint substTV (d: nat) (u: ty) (vv: val) : val :=
  match vv with
  | VVar _          => vv
  | VLoc _          => vv
  | VBox   x        => VBox   (substTX d u x)
  | VLam t x        => VLam   (substTT d u t) (substTX d u x)
  | VLAM k x        => VLAM k (substTX (S d) (liftTT 1 0 u) x)
  | VConst c        => vv
  end
 with    substTX (d: nat) (u: ty) (xx: exp) : exp :=
  match xx with
  | XVal v          => XVal   (substTV d u v)
  | XLet t x1 x2    => XLet   (substTT d u t)  (substTX d u x1) (substTX d u x2)
  | XApp v1 v2      => XApp   (substTV d u v1) (substTV d u v2)
  | XAPP v1 t2      => XAPP   (substTV d u v1) (substTT d u t2)

  | XOp1 op1 v      => XOp1   op1 (substTV d u v)

  | XPrivate ts x   => XPrivate ts (substTX (S d) (liftTT 1 0 u) x)

  | XExtend  t  x   => XExtend  (substTT d u t) (substTX (S d) (liftTT 1 0 u) x)

  | XRun v          => XRun     (substTV d u v)

  | XAlloc  t v     => XAlloc   (substTT d u t) (substTV d u v)
  | XRead   t v     => XRead    (substTT d u t) (substTV d u v)
  | XWrite  t v1 v2 => XWrite   (substTT d u t) (substTV d u v1) (substTV d u v2)
  end.

(********************************************************************)
(* Substitution of types in exps. *)
Lemma subst_type_exp_ix
 :  forall ix ke te se sp x1 t1 e1 t2 o2 k2
 ,  get ix ke = Some (o2, k2)
 -> TypeX ke te se sp x1 t1 e1
 -> KindT (delete ix ke) sp t2 k2
 -> TypeX (delete ix ke)     (substTE ix t2 te)  (substTE ix t2 se) sp
          (substTX ix t2 x1) (substTT ix t2 t1)  (substTT ix t2 e1).
Proof.
 intros. gen ix ke te se sp t1 t2 e1. gen o2 k2.
 induction x1 using exp_mutind with
  (PV := fun v => forall ix ke te se sp t1 t2 o3 k3
      ,  get ix ke = Some (o3, k3)
      -> TypeV ke te se sp v t1
      -> KindT (delete ix ke) sp t2 k3
      -> TypeV (delete ix ke)   (substTE ix t2 te) (substTE ix t2 se) sp
               (substTV ix t2 v)(substTT ix t2 t1));
  intros; simpl; inverts_type; eauto.

 - Case "VVar".
   apply TvVar; auto.
   unfold substTE. auto.
   eauto using subst_type_type_ix.

 - Case "VLoc".
   eapply TvLoc; fold substTT;
   rrwrite ( TRef (substTT ix t2 r) (substTT ix t2 t)
           = substTT ix t2 (TRef r t)).
   unfold substTE; eauto.
   eauto using subst_type_type_ix.

 - Case "VBox".
   eapply TvBox; fold substTT.
    eauto using subst_type_type_ix.

 - Case "VLam".
   simpl. apply TvLam.
   eapply subst_type_type_ix; eauto.
   unfold substTE at 1. rewrite map_rewind.
   rrwrite ( map (substTT ix t2) (te :> t)
           = substTE ix t2 (te :> t)).
   eauto.

 - Case "VLAM".
   simpl. apply TvLAM.
   rewrite delete_rewind.
   rewrite (liftTE_substTE 0 ix).
   rewrite (liftTE_substTE 0 ix).
   rrwrite ( TBot KEffect
           = substTT (S ix) (liftTT 1 0 t2) (TBot KEffect)).
   eauto using kind_kienv_weaken.

 - Case "VConst".
   destruct c; burn.

 - Case "XLet".
   simpl. apply TxLet.
    eapply subst_type_type_ix; eauto.
    eauto.
    unfold substTE at 1. rewrite map_rewind.
     rrwrite ( map (substTT ix t2) (te :> t)
             = substTE ix t2 (te :> t)).
    eauto.

 - Case "XApp".
   eapply TxApp.
    eapply IHx1 in H8; eauto.
     simpl in H8. burn.
    eapply IHx0 in H11; eauto.

 - Case "XAPP".
   rrwrite ( TBot KEffect
           = substTT 0 t (TBot KEffect)).
   rewrite (substTT_substTT 0 ix).
   rewrite (substTT_substTT 0 ix).
   eapply TvAPP.
    simpl. eapply (IHx1 ix) in H8; eauto.
    simpl. eauto using subst_type_type_ix.

 - Case "XOp1".
   eapply TxOpPrim.
   destruct o; simpl in *.
    inverts H8. rrwrite (TNat  = substTT ix t2 TNat); eauto.
    inverts H8. rrwrite (TNat  = substTT ix t2 TNat); eauto.

   destruct o; simpl in *.
    inverts H8.
    spec IHx1 H11; eauto.
    spec IHx1 H11; eauto.
    inverts H8.
    spec IHx1 H1; eauto.

 - Case "XPrivate".
   apply TxPrivate
    with (t := substTT (S ix) (liftTT 1 0 t2) t)
         (e := substTT (S ix) (liftTT 1 0 t2) e).
   + rrwrite (ix = 0 + ix).
     eapply lowerTT_substTT_liftTT. auto.

   + rrwrite (S ix = 1 + ix + 0).
     erewrite maskOnVarT_substTT.

     * have    (~FreeT 0 (liftTT 1 0 t2)).

       rrwrite (maskOnVarT 0 (liftTT 1 0 t2) = liftTT 1 0 t2)
        by (apply maskOnVarT_freeT_id; eauto).

       rrwrite (1 + ix + 0 = 1 + 0 + ix).
       erewrite lowerTT_substTT_liftTT; eauto.

     * have    (~FreeT 0 (liftTT 1 0 t2)).
       auto.

   + auto.

   + rewrite delete_rewind.
     rewrite (liftTE_substTE 0 ix).
     rewrite (liftTE_substTE 0 ix).

     rrwrite (ts = substTE (1 + 0 + ix) (liftTT 1 0 t2) (liftTE 0 ts))
      by admit. (* fine. ts has only 1 free var, so subst above this is identity. *)

     unfold substTE at 1.
     unfold substTE at 1.
     rewrite <- map_app.
     rrwrite ( map (substTT (1 + 0 + ix) (liftTT 1 0 t2)) (liftTE 0 te >< liftTE 0 ts)
             = substTE (1 + 0 + ix) (liftTT 1 0 t2) (liftTE 0 te >< liftTE 0 ts)).
     eapply IHx1.
     eauto.
     eauto using kind_kienv_weaken.
     admit.    (* fine. ts has only 1 free var, so subst above this is identity. *)

 - Case "XExtend".
   have H0: (ix = 0 + ix).
   rewrite H0 at 4.
    rewrite (substTT_substTT 0 ix). simpl.
   clear H0.
   apply TxExtend
    with (e := substTT (S ix) (liftTT 1 0 t2) e).
   + rrwrite (ix = 0 + ix).
     eapply lowerTT_substTT_liftTT
      with (d' := ix) (t2 := t2) in H4; eauto.
     simpl in H4.
     rrwrite (S (0 + ix) = 1 + ix + 0).
     erewrite maskOnVarT_substTT; eauto.
     simpl.
     erewrite maskOnVarT_freeT_id; eauto.
     rrwrite (ix + 0 = ix); eauto.
   + eauto using subst_type_type_ix.

   + rewrite delete_rewind.
     rewrite (liftTE_substTE 0 ix).
     rewrite (liftTE_substTE 0 ix).
     eapply IHx1.
     * eauto.
     * simpl.
       rrwrite ( delete ix ke :> (OCon, KRegion)
               = insert 0 (OCon, KRegion) (delete ix ke)).
       eapply kind_kienv_insert. auto.
     * eauto.

 - Case "XRun".
   eapply TxRun; fold substTT.

   rrwrite ( TSusp (substTT ix t2 e1) (substTT ix t2 t1)
           = substTT ix t2 (TSusp e1 t1)).
    eauto using subst_type_type_ix.

 - Case "XAlloc".
   eapply TxOpAlloc; fold substTT.
    eauto using subst_type_type_ix.
    eauto.

 - Case "XRead".
   eapply TxOpRead; fold substTT.
    eauto using subst_type_type_ix.
    rrwrite ( TRef (substTT ix t2 r) (substTT ix t2 t1)
            = substTT ix t2 (TRef r t1)).
    eauto.

 - Case "XWrite".
   eapply TxOpWrite; fold substTT.
    eauto using subst_type_type_ix.
    eapply IHx1 in H12; eauto. snorm. eauto.
Qed.

Lemma subst_type_exp
 :  forall ke te se sp x1 t1 e1 t2 o2 k2
 ,  TypeX (ke :> (o2, k2)) te se sp x1 t1 e1
 -> KindT  ke sp t2 k2
 -> TypeX  ke (substTE 0 t2 te) (substTE 0 t2 se) sp
              (substTX 0 t2 x1) (substTT 0 t2 t1) (substTT 0 t2 e1).
Proof.
 intros.
 rrwrite (ke = delete 0 (ke :> (o2, k2))).
 eapply subst_type_exp_ix; burn.
Qed.


Require Import Coq.Program.Equality. (* for dependent induction *)

Require Export CatSem.CAT.orders.
Require Export CatSem.CAT.cat_INDEXED_TYPE.
(*Require Export subcategories.*)
Require Export CatSem.CAT.SO.
Require Export CatSem.CAT.initial_terminal.
Require Export CatSem.CAT.monad_haskell.
Require Export CatSem.CAT.monad_h_module.

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

Section base_cats.

Variable T : Type.

Class io_struct (A : T -> Type) := {
  IRel : forall t, relation (A t);
  IPOprf :> forall t, PreOrder (@IRel t)
}.

Notation "y <<< z" := (IRel y z) (at level 60).

Record io_obj := {
  ipo_obj_carrier :> T -> Type ;
  ipo_obj_s :> io_struct ipo_obj_carrier
}.

Existing Instance ipo_obj_s.

Instance IRel_Trans (A : io_obj) t : Transitive (IRel (A:=A) (t:=t)).
Proof.
  intros.
  apply IPOprf.
Qed.

Lemma IRel_refl (V : io_obj) t (x : V t) : x <<< x.
Proof.
  intros V t x.
  assert (H:=IPOprf (A:= V) t).
  destruct H.
  apply PreOrder_Reflexive.
Qed.

Lemma IRel_trans (V : io_obj) t (x y z : V t) :
       x <<< y -> y <<< z -> x <<< z.
Proof.
  intros V t x y z.
  assert (H:=IPOprf (A:= V) t).
  destruct H.
  apply PreOrder_Transitive.
Qed.

(*Definition io_smap (a b : io_obj) := forall t, a t -> b t.*)

(*
Definition io_map (a b : io_obj)
     (f : io_smap a b) :=
      forall t, Proper (IRel (t:=t) ==> IRel (t:=t)) (f t).
*)

Lemma smap_equiv (A B: io_obj) :
     Equivalence (A:= forall t, A t -> B t)
          (fun p q => forall t:T, forall x: A t, p t x = q t x).
Proof.
  intros A B;
  constructor;
  unfold Reflexive,Symmetric,Transitive;
  intros; simpl; try etransitivity; auto.
Qed.

Definition smap_oid A B :=
         Build_Setoid (smap_equiv A B).

Ltac t := cat; unf_Proper ;
     mauto; repeat rew_all; mauto.

Obligation Tactic := t.

Program Instance IO_SMAP_s : Cat_struct (fun a b : io_obj =>
     forall t, a t -> b t) := {
  mor_oid := smap_oid;
  comp A B C f g := fun t => fun x => g t (f t x);
  id A := fun t x => x
}.

Definition IO := Build_Cat IO_SMAP_s.

(*Notation "'IP'" := IO_SMAP (at level 4).*)

Class iMonotone (a b : IO)
     (f : a ---> b) :=
  imonotone : forall t, Proper (IRel (t:=t) ==> IRel (t:=t)) (f t).

Obligation Tactic := unfold iMonotone; unfold Proper, respectful; t.

Program Instance IO_MAP_SubCat : SubCat_compat IO
      (fun x => True) (fun a b f => iMonotone f).

Definition IO_MAP := SubCat IO_MAP_SubCat.
(*
Inductive opt_T (u : T) (A : ITYPE) : (ITYPE) :=
| Some_T : forall (t : T), (A t) -> opt_T u A t
| None_T : opt_T u A u.
*)
Inductive optrelT (u:T) (V: IO) :
  forall t,relation (opt u V t):=
  | optrelTP_none :  optrelT (none u V) (none u V)
  | optrelTP_some : forall t (y z:V t), y <<< z ->
          optrelT (some u y) (some u z).

Obligation Tactic := idtac.

Program Instance opt_TP_preorder (u:T)(A:IO):
     io_struct (opt u A) := {
 IRel := @optrelT u A
}.
Next Obligation.
Proof.
  intros.
  constructor;
  unfold Reflexive, Transitive.
  intro z; induction z;
  constructor. apply IPOprf.

  intros r y z H. generalize dependent z.
  induction H.
  intros z Hz.
  induction Hz.
  constructor.
  constructor. auto.

  intros x H'.
  generalize dependent y.
  dependent destruction H'. (* dep ind in 8.3rc1 *)
  intros y H'.
  constructor.
  transitivity z;
  auto.
Qed.

Definition opt_TP u A : IO := Build_io_obj (opt_TP_preorder u A).

Notation "V *" := (opt_TP _ V) (at level 5).

Section IND_PO_init_term.

Program Instance IO_SMAP_term_struct : io_struct (fun t => unit) := {
  IRel t := fun _ _ => True
}.
Next Obligation.
Proof.
  constructor;
  auto.
Qed.

Definition IO_SMAP_term := Build_io_obj IO_SMAP_term_struct.

Definition IO_SMAP_term_mor (a: IO) : a ---> IO_SMAP_term :=
              (fun _ _ => tt).

Instance IO_SMAP_term_mor_monotone a :
    iMonotone (a:=a) (b:= IO_SMAP_term) (@IO_SMAP_term_mor a).
Proof.
  unfold iMonotone.
  simpl;
  intros a.
  unfold Proper; red.
  auto.
Qed.

(*
Program Instance IP_Terminal : Terminal IP := {
  Term :=  IP_term;
  TermMor := IP_term_mor
}.
Next Obligation.
Proof.
  elim (f t z).
  auto.
Qed.

Program Instance IP_init_struct : ipo_obj_struct (fun t => TEMPTY) := {
  IRel t := fun _ _ => True
}.
Next Obligation.
Proof.
  constructor;
  auto.
Qed.

Definition IP_init := Build_ipo_obj IP_init_struct.

Program Instance IP_init_mor_struct (a: OB) :
     ipo_mor_struct (a:=IP_init)(b:=a)(fun t => InitMor (a t)).
Next Obligation.
Proof.
  unfold Proper; red.
  intro z; elim z.
Qed.

Definition IP_init_mor (a:OB) := Build_ipo_mor (IP_init_mor_struct a).

Program Instance IP_Initial : Initial IP := {
  Init := IP_init;
  InitMor := IP_init_mor
}.
Next Obligation.
Proof.
  elim z.
Qed.
*)
End IND_PO_init_term.

Definition Some_TP (u : T) (A : IO) : A ---> A* :=
           (@some _ u _).

Instance Some_TP_monotone (u:T) (A:IO):
     iMonotone (a:=A) (b:= A*) (@Some_TP u A) .
Proof.
  unfold iMonotone.
  intros.
  unfold Proper;
  red.
  constructor.
  auto.
Qed.

Definition opt_TP_default (u:T) (V W : IO)
      (f: V ---> W) (w:W u): V* ---> W := @opt_default _ u V W f w.

Instance opt_TP_default_monotone (u:T) (V W : IO)
      (f: V ---> W) (H' : iMonotone f) (w:W u) :
    iMonotone (@opt_TP_default u V W f w).
Proof.
  unfold iMonotone.
  unfold Proper;  red.
  intros u V W f H' w t q y H;
  induction H; simpl.
  apply IPOprf.
  apply H'.
  auto.
Qed.

Definition opt_TP_kl (u:T)(V W : IO)(f : V ---> W* )
      t (v: V* t) : W* t :=
 match v with
 | none => none u _
 | some t' v' => f t' v'
 end.

Instance opt_TP_kl_monotone (u:T) (V W : IO)
       (f: V ---> opt_TP u W) (H : iMonotone f) :
       iMonotone (opt_TP_kl f).
Proof.
  intros.
  unfold iMonotone.
  unfold Proper;
  repeat red; intros.
  induction H0; simpl.
  constructor.
  apply H; auto.
Qed.

Obligation Tactic := simpl; intros; unfold Proper;
     unfold respectful; intros; elim_opt;
               try app_all; mauto.

Program Instance opt_TP_monad_struct (u:T) :
   Monad_struct (fun V => opt_TP u V) := {
  weta V := @Some_TP u V;
  kleisli V W f := opt_TP_kl (u:=u)  f
}.

Canonical Structure opt_TP_monad (u:T):=
     Build_Monad (opt_TP_monad_struct u).

Instance opt_TP_lift_monotone (u : T) V W (f : V ---> W) (H : iMonotone f) :
      iMonotone (lift (M:= opt_TP_monad u) f).
Proof.
  intros u V W f H.
  unfold lift.
  simpl.
  apply opt_TP_kl_monotone.
  assert (H':=sub_comp (SubCat_compat:=IO_MAP_SubCat)).
  simpl in *.
  apply H';
  auto.
  apply Some_TP_monotone.
Qed.

Section proj.

Program Instance io_proj_struct (t : T) (A : IO) :
    PO_obj_struct (A t) := {
  Rel := IRel (t:=t)
}.

Definition io_proj t A : wOrd := Build_PO_obj (io_proj_struct t A).

Definition io_proj_mor t A B (f : A ---> B) :
          io_proj t A ---> io_proj t B := f t.

End proj.

End base_cats.

(*

Program Instance proj_Func (t:T) :
     Functor_struct (C:=IO) (D:=SO) (*(Fobj:= fun a : IO => a t) *)
                        (@io_proj_mor t).
Next Obligation.
Proof.
  unfold Proper; red.
  intros f g H x.
  unfold io_proj_mor.
  auto.
Qed.

Canonical Structure proj (t : T) := Build_Functor (IT_proj_Func t).
End proj.

Section PostComp_w_Monad.

Variable P : Monad IO.

Definition opt_TP_def_varinj (u:T) (V W: IO) (f:V ---> P W) :
          opt_TP u V ---> P (opt_TP u W):=
 (opt_TP_default (u:=u) (V:=V) (W:=P (opt_TP u W))
 (f ;; lift (weta (Monad_struct := (opt_TP_monad u)) W))
 (weta (Monad_struct := P) (opt_TP u W) u (none u W))).

(** needed for module property of the derivative *)

Lemma opt_TP_def_varinj_weta (u:T)(V:IO) :
      opt_TP_def_varinj (u:=u) (weta V) == weta _.
Proof.
  unfold opt_TP_def_varinj.
  simpl.
  intros u V t z;
  destruct z;
  simpl; auto.
  set (H:= lift_weta P).
  simpl in H.
  simpl.
  rewrite H. auto.
Qed.

Lemma opt_TP_def_varinj_weta_f (u:T) (V V':IO) (f: V' ---> V) :
    opt_TP_def_varinj (u:=u) (f ;; weta V) ==
              lift (M :=opt_TP_monad u) f ;; weta _ .
Proof.
  intros u V V' f t z.
  simpl.
  intros.
  destruct z; simpl.
    set (H:= lift_weta P).
    simpl in H.
    rewrite H.  auto.
    auto.
Qed.

(** for module M, we define [IPO_Der_Mod M], the derived module *)

Section Der_Module.

(*
Variable obD : Type.
Variable morD : obD -> obD -> Type.
Variable D: Cat morD.
*)
Variable D : Cat.
Section Der_Module_def.

Variable M : MOD P D.
(*
Definition der_mkl (u:T) (V W:IP) (f: V ---> P W) :
   morD (M (opt_TP u V))  (M (opt_TP u W)) :=
        (mkleisli (opt_TP_def_varinj u f)).
*)
Program Instance IO_Der_Mod_struct (u:T) :
        Module_struct P (D:=D) (fun V => M (opt_TP u V)) := {
  mkleisli a b f := (mkleisli (M:=M)(opt_TP_def_varinj (u:=u) f))
}.
Next Obligation.
Proof.
  intros u c d.
  unfold Proper; red.
  intros z y H.
  apply mkleisli_oid.
  simpl.
  intros r s;
  destruct s;
  simpl;
  try rewrite H;
  auto.
Qed.

Obligation 3.
Proof.
  simpl in *.
  intros u c.
  assert (H:=mkleisli_oid(Module_struct:=M)).
  unfold Proper in H. red in H.
  rewrite (H _ _ _ _ (@opt_TP_def_varinj_weta u c)).
  mod.
Qed.

Next Obligation.
Proof.
  intros u c d e f g.
  rewrite mkl_mkl.
  apply mkleisli_oid.
  unfold opt_TP_def_varinj.

  (*intros t x; destruct x;
  simpl.*)
  assert (H:= lift_kleisli (M:=P)).
  simpl in H.
  (*rewrite H.*)
  assert (H':= kleisli_lift (M:=P)).
  simpl in H'.
   (*rewrite H'.*)
  assert (H'':= kleisli_oid (Monad_struct:=P)).
   unfold Proper in H''. repeat red in H''.
   simpl in H''.
(*   apply H''.*)
  intros t z. destruct z; simpl.
  rewrite H.
  rewrite H'.
  apply H''.
  intros t0 z. simpl. auto.

  assert (H3:= eta_kl (Monad_struct := P)).
  simpl in H3.
  rewrite H3. simpl.
  auto.
Qed.

Canonical Structure IO_Der_Mod (u:T) : MOD P D :=
      Build_Module (IO_Der_Mod_struct u).

End Der_Module_def.

(** deriving a module wrt u:T yields a functor *)

Section Der_Module_Functor.

Section Der_Mod_Hom.

Variables M N: MOD P D.
Variable TT : M ---> N.

Program Instance Der_Mod_Hom_struct (u:T) :
  Module_Hom_struct (S:=IO_Der_Mod M u) (T:=IO_Der_Mod N u)
            (fun _ => TT (*opt_TP u x*) _ ) .
Next Obligation.
Proof.
  mod; try apply TT.
Qed.

Canonical Structure Der_Mod_Hom (u:T) :
     IO_Der_Mod M u ---> IO_Der_Mod N u :=
           Build_Module_Hom
           (Der_Mod_Hom_struct u).

End Der_Mod_Hom.

Program Instance Der_Mod_Func (u:T) :
   Functor_struct (C:=MOD P D) (D:=MOD P D)
        (Fobj:= fun z => IO_Der_Mod z u)
        (fun M N TT => Der_Mod_Hom (M:=M) (N:=N) TT u).
Next Obligation.
Proof.
  unfold Proper; red.
  unfold Der_Mod_Hom;
  simpl. auto.
Qed.
Next Obligation.
Proof.
  unfold Id_Mod.
  simpl. cat.
Qed.
Next Obligation.
Proof.
  unfold CompMod.
  simpl. cat.
Qed.

Canonical Structure DER_MOD (u:T) := Build_Functor (Der_Mod_Func u).

End Der_Module_Functor.

End Der_Module.

End PostComp_w_Monad.

(** Fibre Module:
     - P monad over IO
     - M module with codomain IO
     - M_u the u-fibre of M is a module with codomain SO *)

Section Fibre_module.

Variable P: Monad IO.

Section Fibre_Module_def.

Variable M : MOD P IO.

Program Instance Fibre_Mod_struct (u:T) :
       Module_struct P (D:=SO) (fun c => io_proj u (M c)) := {
  mkleisli a b f := #(proj u) (@mkleisli IO P  IO M M  a b f)
}.
Next Obligation.
Proof.
  intros u c d.
  assert (H := mkleisli_oid (P:=P) (M:=M)).
  unfold Proper in *; red; simpl in H.
  simpl in *.
  intros z y H'.
  apply H.
  auto.
Qed.
Next Obligation.
Proof.
  intros.
  assert (H:=mkl_mkl (P:=P)(M:=M)).
  simpl in H.
  apply H.
Qed.
Next Obligation.
Proof.
  intros.
  assert (H:= mkl_weta (P:=P)(M:=M)).
  simpl in H.
  apply H.
Qed.

Canonical Structure Fibre_Mod (u:T) : MOD P SO :=
           Build_Module (Fibre_Mod_struct u).

End Fibre_Module_def.

Section Fibre_Module_Hom.
Variables M N : MOD P IO.
Variable TT : M ---> N.

Program Instance Fib_Mod_Hom_struct (u:T) :
   Module_Hom_struct (S:= Fibre_Mod M u )(T:= Fibre_Mod N u)
    (fun z => #(proj u) (TT z) ).
Next Obligation.
Proof.
  intros u c d f x.
  destruct TT as [T1 T2].
  destruct T2 as [t1].
  assert (H:= t1 c d f).
  simpl in *.
  apply H.
Qed.

Canonical Structure Fib_Mod_Hom (u:T) :
     Fibre_Mod M u ---> Fibre_Mod N u :=
        Build_Module_Hom (Fib_Mod_Hom_struct u).

End Fibre_Module_Hom.

Program Instance Fib_Mod_Func (u:T) :
   Functor_struct (C:=MOD P IO) (D:=MOD P SO)
        (Fobj:= fun x => Fibre_Mod x u)
        (fun M N TT => Fib_Mod_Hom (M:=M) (N:=N) TT u).
Next Obligation.
Proof.
  unfold Proper; red.
  unfold Fib_Mod_Hom.
  simpl.
  auto.
Qed.

Canonical Structure FIB_MOD (u:T) := Build_Functor (Fib_Mod_Func u).

End Fibre_module.

Section DER_PB.
Notation "Sig '*' M" := (PB_MOD Sig _ M).
Variables R S: Monad IO.
Variable Sig: Monad_Hom R S.
(*
Variable obD: Type.
Variable morD: obD -> obD -> Type.
Variable D: Cat morD.
*)
Variable D : Cat.
Variable M: MOD S D.

Program Instance PB_DER_struct (u:T) :
      Module_Hom_struct (S:= (PB_MOD Sig _ (DER_MOD _ _ u M)))
                                     (T:= DER_MOD _ _ u (PB_MOD Sig _ M))
          (fun e => id _) .
Next Obligation.
Proof.
  intros u c d f.
  rewrite idl;
  rewrite idr.
  simpl.
  apply mkleisli_oid.
  simpl.
  intros t x.
  simpl.
  destruct x; simpl.
  assert (H:= monad_hom_lift Sig (@Some_TP u d)).
  simpl in H.
  rewrite H; auto.
  assert (H':= monad_hom_weta (Monad_Hom_struct:=Sig)).
  simpl in H'.
  rewrite H'.
  auto.
Qed.

Definition PB_DER (u:T) : PB_MOD Sig _ (DER_MOD _ _ u M) --->
                            DER_MOD _ _ u (PB_MOD Sig _ M) :=
         Build_Module_Hom (PB_DER_struct u).

Program Instance DER_PB_struct (u:T) :
      Module_Hom_struct (T:= (PB_MOD Sig _ (DER_MOD _ _ u M)))
                                     (S:= DER_MOD _ _ u (PB_MOD Sig _ M))
          (fun e => id _) .
Next Obligation.
Proof.
  intros u c d f.
  rewrite idl;
  rewrite idr.
  simpl.
  apply mkleisli_oid.
  simpl.
  intros t x.
  simpl.
  destruct x; simpl.
  assert (H:= monad_hom_lift Sig (@Some_TP u d)).
  simpl in H.
  rewrite H; auto.
  assert (H':= monad_hom_weta (Monad_Hom_struct:=Sig)).
  simpl in H'.
  rewrite H'.
  auto.
Qed.

Definition DER_PB (u:T) : DER_MOD _ _ u (PB_MOD Sig _ M) --->
                  PB_MOD Sig _ (DER_MOD _ _ u M) :=
         Build_Module_Hom (DER_PB_struct u).

Lemma DER_PB_PB_DER (u:T) : DER_PB u ;; PB_DER u == id _ .
Proof.
  intro u; simpl.
  simpl.
  cat.
Qed.

Lemma PB_DER_DER_PB (u:T) : PB_DER u ;; DER_PB u == id _.
Proof.
  intro u; simpl.
  simpl.
  cat.
Qed.

End DER_PB.

Section FIB_PB.

Notation "Sig '*' M" := (PB_MOD Sig _ M).
Variables R S: Monad IO.
Variable Sig: Monad_Hom R S.
(*
Variable obD: Type.
Variable morD: obD -> obD -> Type.
Variable D: Cat morD.
*)
(*
Variable D : Cat.
*)
Variable M: MOD S IO.

Program Instance PB_FIB_struct (u:T) :
      Module_Hom_struct (S:= (PB_MOD Sig _ (FIB_MOD _ u M)))
                                     (T:= FIB_MOD _ u (PB_MOD Sig _ M))
          (fun e => id _) .

Definition PB_FIB (u:T) :
      (PB_MOD Sig _ (FIB_MOD _ u M)) ---> FIB_MOD _ u (PB_MOD Sig _ M) :=
          Build_Module_Hom (PB_FIB_struct u).

Program Instance FIB_PB_struct (u:T) :
      Module_Hom_struct (T:= (PB_MOD Sig _ (FIB_MOD _ u M)))
                                     (S:= FIB_MOD _ u (PB_MOD Sig _ M))
          (fun e => id _) .

Definition FIB_PB (u:T) :
        FIB_MOD _ u (PB_MOD Sig _ M) ---> PB_MOD Sig _ (FIB_MOD _ u M) :=
          Build_Module_Hom (FIB_PB_struct u).

Lemma FIB_PB_PB_FIB (u:T) :
          FIB_PB u ;; PB_FIB u == id _ .
Proof.
  intro u;
  simpl.
  simpl.
  auto.
Qed.

Lemma PB_FIB_FIB_PB (u:T) :
          PB_FIB u ;; FIB_PB u == id _ .
Proof.
  intro u;
  simpl; auto.
Qed.

End FIB_PB.

(** for a monad R over IP, we define substitution of *u
    in terms of (kleisli R) *)
Section substitution.

Variable R: Monad IO.

Section subst_kleisli_arg.

Variable V: IO.
Variable r: T.
Variable W : R V r.

Definition IPsubst_map := opt_TP_default (weta (Monad_struct:=R) _ ) W.

End subst_kleisli_arg.

Definition IOsubstar (r:T) (V:IO) (W:R V r) := kleisli (IPsubst_map W).

End substitution.

End base_cats.

(*Notation "x <<< y" := (IRel x y) (at level 60).*)

(*Existing Instance IO_Initial.*)
(*Existing Instance IO_Terminal.*)
Existing Instance Fib_Mod_Func.
Existing Instance IO_SMAP_s.
Existing Instance ipo_obj_s.
Existing Instance IRel_Trans.

*)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Export Coq.Classes.SetoidTactics.

Export Morphisms.ProperNotations.

(** For backward compatibility *)

Definition Setoid_Theory := @Equivalence.
Definition Build_Setoid_Theory := @Build_Equivalence.

Definition Seq_refl A Aeq (s : Setoid_Theory A Aeq) : forall x:A, Aeq x x.
Proof.
  unfold Setoid_Theory in s. intros ; reflexivity.
Defined.

Definition Seq_sym A Aeq (s : Setoid_Theory A Aeq) : forall x y:A, Aeq x y -> Aeq y x.
Proof.
  unfold Setoid_Theory in s. intros ; symmetry ; assumption.
Defined.

Definition Seq_trans A Aeq (s : Setoid_Theory A Aeq) : forall x y z:A, Aeq x y -> Aeq y z -> Aeq x z.
Proof.
  unfold Setoid_Theory in s. intros ; transitivity y ; assumption.
Defined.

(** Some tactics for manipulating Setoid Theory not officially
    declared as Setoid. *)

Ltac trans_st x :=
  idtac "trans_st on Setoid_Theory is OBSOLETE";
  idtac "use transitivity on Equivalence instead";
  match goal with
    | H : Setoid_Theory _ ?eqA |- ?eqA _ _ =>
      apply (Seq_trans _ _ H) with x; auto
  end.

Ltac sym_st :=
  idtac "sym_st on Setoid_Theory is OBSOLETE";
  idtac "use symmetry on Equivalence instead";
  match goal with
    | H : Setoid_Theory _ ?eqA |- ?eqA _ _ =>
      apply (Seq_sym _ _ H); auto
  end.

Ltac refl_st :=
  idtac "refl_st on Setoid_Theory is OBSOLETE";
  idtac "use reflexivity on Equivalence instead";
  match goal with
    | H : Setoid_Theory _ ?eqA |- ?eqA _ _ =>
      apply (Seq_refl _ _ H); auto
  end.

Definition gen_st : forall A : Set, Setoid_Theory _ (@eq A).
Proof.
  constructor; congruence.
Qed.


(*
 * Coq code for "Certified Assembly Programming with Embedded Code Pointers"
 *
 * Set level mapping library
 *
 * (for Coq version 8)
 *)

Section Map.

Variable A B : Set.

Set Implicit Arguments.
Unset Strict Implicit.

Definition Map := A -> option B.

Definition lookup (M : Map) a b := M a = Some b.

Definition in_dom (M : Map) a := exists b : _, M a = Some b.

Definition not_in_dom (M : Map) a := M a = None.

Definition empty_map : Map := fun _ => None.

Definition merge (M1 M2 : Map) a :=
  match M1 a with
  | None => M2 a
  | _ => M1 a
  end.

Definition disjoint (M1 M2 : Map) :=
  forall a : A,
  match M1 a, M2 a with
  | Some _, Some _ => False
  | _, _ => True
  end.

Definition subseteq (M1 M2 : Map) :=
  forall a, match M1 a with
            | None => True
            | Some _ => M1 a = M2 a
            end.

Definition meq (M1 M2 : Map) := forall a, M1 a = M2 a.

Lemma mergelookup :
 forall (M1 M2 : Map) a b,
 lookup (merge M1 M2) a b -> lookup M1 a b \/ lookup M2 a b.
unfold lookup, merge in |- *.
intros.
destruct (M1 a).
 left.
   auto.
 right.
   auto.
Qed.

Lemma lookup_meq_lookup :
  forall M1 M2 a b, lookup M1 a b -> meq M1 M2 -> lookup M2 a b.
unfold lookup, meq. intros. rewrite <- (H0 a). auto.
Qed.

Lemma lookup_disj_merge_lookup_1 :
  forall M1 M2 a b, lookup M1 a b -> disjoint M1 M2 -> lookup (merge M1 M2) a b.
unfold lookup, disjoint, merge. intros. generalize (H0 a). clear H0. intros.
destruct (M1 a). auto. inversion H.
Qed.

Lemma lookup_disj_merge_lookup_2 :
  forall M1 M2 a b, lookup M2 a b -> disjoint M1 M2 -> lookup (merge M1 M2) a b.
unfold lookup, disjoint, merge. intros. generalize (H0 a). clear H0. intros.
destruct (M1 a). rewrite H in H0. tauto. auto.
Qed.

Lemma indom_meq_indom :
  forall M1 M2 a, in_dom M1 a -> meq M1 M2 -> in_dom M2 a.
unfold in_dom, meq. intros. rewrite <- (H0 a). auto.
Qed.

Lemma indom_disj_merge_indom_1 :
  forall M1 M2 a, in_dom M1 a -> disjoint M1 M2 -> in_dom (merge M1 M2) a.
unfold in_dom, disjoint, merge. intros. generalize (H0 a). clear H0. intros.
destruct (M1 a). auto. inversion H. inversion H1.
Qed.

Lemma indom_disj_merge_indom_2 :
  forall M1 M2 a, in_dom M2 a -> disjoint M1 M2 -> in_dom (merge M1 M2) a.
unfold in_dom, disjoint, merge. intros. generalize (H0 a). clear H0. intros.
destruct (M1 a). destruct H. rewrite H in H0. tauto. auto.
Qed.

Lemma indom_disj_notindom :
  forall M1 M2 a, in_dom M1 a -> disjoint M1 M2 -> not_in_dom M2 a.
unfold in_dom, disjoint, not_in_dom. intros. destruct H. generalize (H0 a).
rewrite H. destruct (M2 a). tauto. auto.
Qed.

Lemma disj_sym : forall M1 M2, disjoint M1 M2 -> disjoint M2 M1.
intros. unfold disjoint. intros. generalize (H a). clear H.
intros. destruct (M1 a). auto. destruct (M2 a). auto. auto.
Qed.

Lemma meq_refl : forall M, meq M M.
unfold meq. auto.
Qed.

Lemma meq_sym : forall M1 M2, meq M1 M2 -> meq M2 M1.
unfold meq. auto.
Qed.

Lemma meq_trans : forall M1 M2 M3, meq M1 M2 -> meq M2 M3 -> meq M1 M3.
unfold meq. intros. rewrite (H a). auto.
Qed.

Lemma meq_merge_meq :
  forall M1 M2 M3 M4, meq M1 M2 -> meq M3 M4 -> meq (merge M1 M3) (merge M2 M4).
unfold meq, merge. intros. rewrite (H a). rewrite (H0 a). auto.
Qed.

Lemma disj_merge_sym :
  forall M1 M2, disjoint M1 M2 -> meq (merge M1 M2) (merge M2 M1).
unfold meq, merge, disjoint. intros. generalize (H a). clear H. intros.
destruct (M1 a). destruct (M2 a). tauto. auto.
destruct (M2 a). auto. auto.
Qed.

Lemma disj_meq_disj :
  forall M1 M2 M3, disjoint M1 M2 -> meq M2 M3 -> disjoint M1 M3.
unfold disjoint, meq. intros. generalize (H a). clear H. intros.
rewrite <- (H0 a). auto.
Qed.

Lemma disj_merge_disj :
  forall M1 M2 M3, disjoint M1 M3 -> disjoint M2 M3 -> disjoint (merge M1 M2) M3.
unfold disjoint. intros. generalize (H a) (H0 a). clear H H0. intros.
unfold merge. destruct (M1 a). auto. auto.
Qed.

Lemma merge_assoc_L :
  forall M1 M2 M3, meq (merge (merge M1 M2) M3) (merge M1 (merge M2 M3)).
unfold merge, meq. intros. destruct (M1 a). auto. auto.
Qed.

Lemma merge_assoc_R :
  forall M1 M2 M3, meq (merge M1 (merge M2 M3)) (merge (merge M1 M2) M3).
intros. apply meq_sym. apply merge_assoc_L.
Qed.

Lemma merge_disj_disj_1 :
  forall M1 M2 M3, disjoint M1 (merge M2 M3) -> disjoint M1 M2.
unfold disjoint, merge. intros. generalize (H a). clear H. intros.
destruct (M1 a). destruct (M2 a). auto. auto. auto.
Qed.

Lemma merge_disj_disj_2 :
  forall M1 M2 M3, disjoint M1 (merge M2 M3) -> disjoint M1 M3.
unfold disjoint, merge. intros. generalize (H a). clear H. intros.
destruct (M1 a). destruct (M2 a). tauto. auto. auto.
Qed.

End Map.


Local Set Primitive Projections. Local Unset Printing Primitive Projection Parameters.
Record ex {A} (P:A->Type) : Type := ex_intro { ex_x : A; ex_pf : P ex_x }.
Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..)) : type_scope.
Ltac destruct_primex H :=
  lazymatch type of H with @ex ?A (fun x => ?P) =>
  let Hx := fresh in
  let Hpf := fresh in
  pose (@ex_x A (fun x => P) H) as Hx;
  (* pose (@ex_pf A (fun x => P) H : match Hx with x => P end) as Hpf; *)
  assert (match Hx with x => P end) as Hpf by exact (@ex_pf A (fun x => P) H);
  clearbody Hx; try clear H
  end.

Fixpoint exn (n:nat) : Type :=
  match n with O => False | S n => exists tt:unit, exn n end.

Goal exn 125 -> False. intro H. cbv in H.
  Time (repeat match goal with H:exists _, _ |-_=> destruct_primex H end; assumption).
Time Qed.
(* Finished transaction in 0.328 secs (0.237u,0.089s) (successful) *)
(* Finished transaction in 0.068 secs (0.064u,0.002s) (successful) *)

Goal exn 250 -> False. intro H. cbv in H.
  idtac "".
  Time (repeat match goal with H:exists _, _ |-_=> destruct_primex H end; assumption).
Time Qed.
(* Finished transaction in 1.196 secs (1.179u,0.01s) (successful) *)
(* Finished transaction in 0.253 secs (0.252u,0.s) (successful) *)

Goal exn 500 -> False. intro H. cbv in H.
  idtac "".
  Time (repeat match goal with H:exists _, _ |-_=> destruct_primex H end; assumption).
Time Qed.
(* Finished transaction in 7.028 secs (6.967u,0.026s) (successful) *)
(* Finished transaction in 1.011 secs (1.004u,0.s) (successful) *)

Goal exn 1000 -> False. intro H. cbv in H.
  idtac "".
  Time (repeat match goal with H:exists _, _ |-_=> destruct_primex H end; assumption).
Time Qed.
(* Finished transaction in 46.185 secs (45.762u,0.205s) (successful) *)
(* Finished transaction in 3.957 secs (3.931u,0.s) (successful) *)

Goal exn 2000 -> False. intro H. cbv in H.
  idtac "".
  Time (repeat match goal with H:exists _, _ |-_=> destruct_primex H end; assumption).
Time Qed.
(* Finished transaction in 331.19 secs (329.098u,0.622s) (successful) *)
(* Finished transaction in 16.489 secs (16.377u,0.009s) (successful) *)

(* coqc destruct_primex.v  470.79s user 1.21s system 99% cpu 7:54.14 total *)
(* 3GB RAM *)