From iris Require Import program_logic.weakestpre.
From iris.proofmode Require Import tactics.
From st.prelude Require Import autosubst.
From st.STLCmuVS Require Import lang virt_steps typing tactics logrel.definitions logrel.generic.lift reducibility.
From st.STLCmu Require Import types.
From st Require Import resources.

Section VirtStep_no_op.

  Context `{Σ : !gFunctors} `{semΣ_inst : !semΣ Σ}.

  Context (s : stuckness).

  Lemma VirtStep_no_op_help :
    ∀ τ v v', valrel_typed s τ v v' ⊢ valrel_typed s τ v (VirtStepped v').
  Proof.
    iLöb as "IHlob".
    iIntros (τ).
    iInduction τ as [] "IH";
      iIntros (v v') "#Hvv'".
    - rewrite !valrel_typed_TUnit_unfold.
      by iDestruct "Hvv'" as "[-> ->]/=".
    - rewrite !valrel_typed_TBool_unfold.
      iDestruct "Hvv'" as (b) "[-> ->]/=". by iExists _.
    - rewrite !valrel_typed_TInt_unfold.
      iDestruct "Hvv'" as (z) "[-> ->]/=". by iExists _.
    - rewrite !valrel_typed_TProd_unfold.
      iDestruct "Hvv'" as (v1 v2 v1' v2') "(-> & -> & #H1 & #H2)/=".
      repeat iExists _; repeat iSplit; auto; [by iApply "IH"| by iApply "IH1"].
    - rewrite !valrel_typed_TSum_unfold.
      iDestruct "Hvv'" as (vi vi') "[(-> & -> & #H) | (-> & -> & #H)]/=".
      + repeat iExists _. iLeft. repeat iSplit; auto. by iApply "IH".
      + repeat iExists _. iRight. repeat iSplit; auto. by iApply "IH1".
    - rewrite !valrel_typed_TArrow_unfold.
      iModIntro. iIntros (w w') "#Hww'".
      iSpecialize ("IH" $! w w' with "Hww'"). iSpecialize ("Hvv'" $! w (VirtStepped w') with "IH").
      iApply (wp_wand with "Hvv'"). iIntros (r) "Hdes". iDestruct "Hdes" as (r') "[%Hsteps #Hrr']".
      iSpecialize ("IH1" $! r r' with "Hrr'").
      iExists (VirtStepped r'). iFrame "IH1".
      iPureIntro.
      destruct (dec_expr_reducibility (v' (VirtStepped w'))) as [ vl eq | red | stuck ]; [inversion eq| |].
      * assert (head_reducible (v' (VirtStepped w')) ()).
        { apply prim_head_reducible; auto.
          apply ectxi_language_sub_redexes_are_values.
          intros. destruct Ki; simpl in H; try by inversion H.
          inversion H. subst. eexists _. by rewrite /= to_of_val.
          inversion H. subst. eexists _. by rewrite /= to_of_val. }
        assert (STLCmuVS_head_reducible (v' (VirtStepped w'))). by apply STLCmuVS_prim_head_red.
        destruct H0 as [p hd].
        inversion hd; subst. assert (LamV e1 = v') as <-. by apply of_val_inj.
        eapply rtc_l. auto_STLCmuVS_step. simplify_custom.
        change (Lam e1) with (of_val (LamV e1)).
        eapply rtc_transitive. apply (rtc_STLCmuVS_step_ctx (fill [AppRCtx _; VirtStepCtx])). apply VirtStep_eval. simpl.
        eapply rtc_transitive. by apply (rtc_STLCmuVS_step_ctx (fill [VirtStepCtx])).
        apply VirtStep_eval.
      * exfalso. inversion Hsteps; subst.
        -- assert (abs : to_val (v' (VirtStepped w')) = Some r'). by rewrite -to_of_val H1. inversion abs.
        -- destruct stuck. eapply H2. apply H.
    - rewrite !valrel_typed_TRec_unfold.
      iDestruct "Hvv'" as (w w') "(-> & -> & #Hww')".
      iExists _,_. repeat iSplit; auto. by iApply "IHlob".
    - by rewrite !valrel_typed_TVar_unfold.
  Qed.

  Lemma VirtStep_no_op :
    ∀ τ v v', valrel_typed s τ v v' ⊢ exprel_typed s τ v (VirtStep v').
  Proof. iIntros (τ v v') "Hvv'". iApply lift_rtc_steps. apply VirtStep_eval. iApply lift_val. by iApply VirtStep_no_op_help. Qed.

  Lemma VirtStep_no_op_expr :
    ∀ τ e e', exprel_typed s τ e e' ⊢ exprel_typed s τ e (VirtStep e').
  Proof. iIntros (τ e e') "Hee'". iApply (lift_bind'' _ [] [VirtStepCtx] with "Hee'"). iIntros (v v') "Hvv'". by iApply VirtStep_no_op. Qed.

End VirtStep_no_op.


(**
SimSoC-Cert, a toolkit for generating certified processor simulators.

See the COPYRIGHTS and LICENSE files.

Formalization of the ARM architecture version 6 following the:

ARM Architecture Reference Manual, Issue I, July 2005.

Page numbers refer to ARMv6.pdf.

Exception handling. Step functions are taken from the generated file
arm6exn.v. *)

Require Import Arm6_Config List ZArith Bitvec Arm6 Arm6_SCC Arm6_State
  Arm6_Functions Util Arm6_Message.
Import Arm6_Functions.Semantics.

Definition set_cpsr_bits s0 p n v :=
  set_cpsr (set_bits p n v (cpsr s0)).

Definition set_cpsr_bit s0 n v :=
  set_cpsr (set_bit n v (cpsr s0)).

Definition set_cpsr_bit_9 s0 :=
  set_cpsr (set_bit 9 ((CP15_reg1 s0)[EEbit]) (cpsr s0)).

Definition set_reg_mode_adr (s0 : state) e f :=
  set_reg_mode (exn e) LR (f s0).

Module InstSem (Import C : CONFIG).

(* A2.6.2 Reset *)
Definition Reset_step : semfun unit := <s0>
  block (
    set_reg_mode (exn svc) LR (repr 0) ::
    let SPSR_svc := repr 0 in
    set_cpsr_bits s0 4 0 (repr (Zpos 1~0~0~1~1)) ::
    set_cpsr_bit s0 5 (repr 0) ::
    set_cpsr_bit s0 6 (repr 1) ::
    set_cpsr_bit s0 7 (repr 1) ::
    set_cpsr_bit s0 8 (repr 1) ::
    set_cpsr_bit_9 s0 ::
    if_then_else (high_vectors_configured s0)
      (set_reg PC (repr (Zpos 4294901760)))
      (set_reg PC (repr (Z0))) ::
    nil).

(* A2.6.3 UndIns *)
Definition UndIns_step : semfun unit := <s0>
  block (
    set_reg_mode_adr s0 und address_of_next_instruction ::
    (*let SPSR_und := cpsr s0 in*)
    set_cpsr_bits s0 4 0 (repr (Zpos 1~1~0~1~1)) ::
    set_cpsr_bit s0 5 (repr 0) ::
    set_cpsr_bit s0 7 (repr 1) ::
    set_cpsr_bit_9 s0 ::
    if_then_else (high_vectors_configured s0)
      (set_reg PC (repr (Zpos 4294901764)))
      (set_reg PC (repr (Zpos 4))) ::
    nil).

(* A2.6.4 SoftInt *)
Definition SoftInt_step : semfun unit := <s0>
  block (
    set_reg_mode_adr s0 svc address_of_next_instruction ::
    (*let SPSR_svc := cpsr s0 in*)
    set_cpsr_bits s0 4 0 (repr (Zpos 1~0~0~1~1)) ::
    set_cpsr_bit s0 5 (repr 0) ::
    set_cpsr_bit s0 7 (repr 1) ::
    set_cpsr_bit_9 s0 ::
    if_then_else (high_vectors_configured s0)
      (set_reg PC (repr (Zpos 4294901768)))
      (set_reg PC (repr (Zpos 8))) ::
    nil).

(* A2.6.5 PFAbort *)
Definition PFAbort_step : semfun unit := <s0>
  block (
    set_reg_mode_adr s0 abt (fun s0 => add (address_of_current_instruction s0) (repr 4)) ::
    (*let SPSR_abt := cpsr s0 in*)
    set_cpsr_bits s0 4 0 (repr (Zpos 1~0~1~1~1)) ::
    set_cpsr_bit s0 5 (repr 0) ::
    set_cpsr_bit s0 7 (repr 1) ::
    set_cpsr_bit s0 8 (repr 1) ::
    set_cpsr_bit_9 s0 ::
    if_then_else (high_vectors_configured s0)
      (set_reg PC (repr (Zpos 4294901772)))
      (set_reg PC (repr (Zpos 12))) ::
    nil).

(* A2.6.6 DataAbort *)
Definition DataAbort_step : semfun unit := <s0>
  block (
    set_reg_mode_adr s0 abt (fun s0 => add (address_of_current_instruction s0) (repr 8)) ::
    (*let SPSR_abt := cpsr s0 in*)
    set_cpsr_bits s0 4 0 (repr (Zpos 1~0~1~1~1)) ::
    set_cpsr_bit s0 5 (repr 0) ::
    set_cpsr_bit s0 7 (repr 1) ::
    set_cpsr_bit s0 8 (repr 1) ::
    set_cpsr_bit_9 s0 ::
    if_then_else (high_vectors_configured s0)
      (set_reg PC (repr (Zpos 4294901776)))
      (set_reg PC (repr (Zpos 16))) ::
    nil).

(* A2.6.8 IRQ *)
Definition IRQ_step : semfun unit := <s0>
  block (
    set_reg_mode_adr s0 irq (fun s0 => add (address_of_next_instruction s0) (repr 4)) ::
    (*let SPSR_irq := cpsr s0 in*)
    set_cpsr_bits s0 4 0 (repr (Zpos 1~0~0~1~0)) ::
    set_cpsr_bit s0 5 (repr 0) ::
    set_cpsr_bit s0 7 (repr 1) ::
    set_cpsr_bit s0 8 (repr 1) ::
    set_cpsr_bit_9 s0 ::
    if_then_else (zeq ((CP15_reg1 s0)[VEbit]) 0)
      (if_then_else (high_vectors_configured s0)
        (set_reg PC (repr (Zpos 4294901784)))
        (set_reg PC (repr (Zpos 24))))
      (set_reg PC (VE_IRQ_address)) ::
    nil).

(* A2.6.9 FIQ *)
Definition FIQ_step : semfun unit := <s0>
  block (
    set_reg_mode_adr s0 fiq (fun s0 => add (address_of_next_instruction s0) (repr 4)) ::
    (*let SPSR_fiq := cpsr s0 in*)
    set_cpsr_bits s0 4 0 (repr (Zpos 1~0~0~0~1)) ::
    set_cpsr_bit s0 5 (repr 0) ::
    set_cpsr_bit s0 6 (repr 1) ::
    set_cpsr_bit s0 7 (repr 1) ::
    set_cpsr_bit s0 8 (repr 1) ::
    set_cpsr_bit_9 s0 ::
    if_then_else (zeq ((CP15_reg1 s0)[VEbit]) 0)
      (if_then_else (high_vectors_configured s0)
        (set_reg PC (repr (Zpos 4294901788)))
        (set_reg PC (repr (Zpos 28))))
      (set_reg PC (VE_FIQ_address)) ::
    nil).

Definition step : semfun unit :=
  <s>
  match exns s with
    | nil => conjure_up_false
    | e :: _ =>
      do_then conjure_up_true;
      match e with
        | Reset => Reset_step
        | UndIns => UndIns_step
        | SoftInt => SoftInt_step
        | PFAbort => PFAbort_step
        | DataAbort => DataAbort_step
        | ImpAbort => do_then conjure_up_false ; todo ImpreciseDataAbort
        | IRQ => IRQ_step
        | FIQ => FIQ_step
      end
  end.

End InstSem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


(** Concurrent bag specification from the HOCAP paper.
    "Modular Reasoning about Separation of Concurrent Data Structures"
    <http://www.kasv.dk/articles/hocap-ext.pdf>

Coarse-grained implementation of a bag
*)
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode notation.
From iris.algebra Require Import cmra agree frac.
From iris.heap_lang.lib Require Import lock spin_lock.
From iris_examples.hocap Require Import abstract_bag.
Set Default Proof Using "Type".

(** Coarse-grained bag implementation using a spin lock *)
Definition newBag : val := λ: <>,
  let: "r" := ref NONE in
  let: "l" := newlock #() in
  ("r", "l").
Definition pushBag : val := λ: "b" "v",
  let: "l" := Snd "b" in
  let: "r" := Fst "b" in
  acquire "l";;
  let: "t" := !"r" in
  "r" <- SOME ("v", "t");;
  release "l".
Definition popBag : val := λ: "b",
  let: "l" := Snd "b" in
  let: "r" := Fst "b" in
  acquire "l";;
  let: "v" := match: !"r" with
                NONE => NONE
              | SOME "s" =>
                "r" <- Snd "s";;
                SOME (Fst "s")
              end in
  release "l";;
  "v".

Canonical Structure valmultisetO := leibnizO (gmultiset valO).
Class bagG Σ := BagG
{ bag_bagG :> inG Σ (prodR fracR (agreeR valmultisetO));
  lock_bagG :> lockG Σ
}.

(** Generic specification for the bag, using view shifts. *)
Section proof.
  Context `{heapG Σ, bagG Σ}.
  Variable N : namespace.

  Fixpoint bag_of_val (ls : val) : gmultiset val :=
    match ls with
    | NONEV => ∅
    | SOMEV (v1, t) => {[v1]} ⊎ bag_of_val t
    | _ => ∅
    end.
  Fixpoint val_of_list (ls : list val) : val :=
    match ls with
    | [] => NONEV
    | x::xs => SOMEV (x, val_of_list xs)
    end.

  Definition bag_inv (γb : gname) (b : loc) : iProp Σ :=
    (∃ ls : list val, b ↦ (val_of_list ls) ∗ own γb ((1/2)%Qp, to_agree (list_to_set_disj ls)))%I.
  Definition is_bag (γb : gname) (x : val) :=

    (∃ (lk : val) (b : loc) (γ : gname),
        ⌜x = PairV #b lk⌝ ∗ is_lock N γ lk (bag_inv γb b))%I.
  Definition bag_contents (γb : gname) (X : gmultiset val) : iProp Σ :=
    own γb ((1/2)%Qp, to_agree X).

  Global Instance is_bag_persistent γb x : Persistent (is_bag γb x).
  Proof. apply _. Qed.
  Global Instance bag_contents_timeless γb X : Timeless (bag_contents γb X).
  Proof. apply _. Qed.

  Lemma bag_contents_agree γb X Y :
    bag_contents γb X -∗ bag_contents γb Y -∗ ⌜X = Y⌝.
  Proof.
    rewrite /bag_contents. apply bi.wand_intro_r.
    rewrite -own_op own_valid uPred.discrete_valid.
    f_equiv=> /=. rewrite -pair_op.
    by intros [_ ?%agree_op_invL'].
  Qed.

  Lemma bag_contents_update γb X X' Y :
    bag_contents γb X ∗ bag_contents γb X' ==∗ bag_contents γb Y ∗ bag_contents γb Y.
  Proof.
    iIntros "[Hb1 Hb2]".
    iDestruct (bag_contents_agree with "Hb1 Hb2") as %<-.
    iMod (own_update_2 with "Hb1 Hb2") as "Hb".
    { rewrite -pair_op frac_op'.
      assert ((1 / 2 + 1 / 2)%Qp = 1%Qp) as -> by apply Qp_div_2.
      by apply (cmra_update_exclusive (1%Qp, to_agree Y)). }
    iDestruct "Hb" as "[Hb1 Hb2]".
    rewrite /bag_contents. by iFrame.
  Qed.

  Lemma newBag_spec :
    {{{ True }}}
      newBag #()
    {{{ x γ, RET x; is_bag γ x ∗ bag_contents γ ∅ }}}.
  Proof.
    iIntros (Φ) "_ HΦ".
    unfold newBag. wp_rec.
    wp_alloc r as "Hr". wp_let.
    iMod (own_alloc (1%Qp, to_agree ∅)) as (γb) "[Ha Hf]"; first done.
    wp_apply (newlock_spec N (bag_inv γb r) with "[Hr Ha]").
    { iExists []. iFrame. }
    iIntros (lk γ) "#Hlk". wp_pures. iApply "HΦ".
    rewrite /is_bag /bag_contents. iFrame.
    iExists _,_,_. by iFrame "Hlk".
  Qed.

  Local Opaque acquire release. (* so that wp_pure doesn't stumble *)
  Lemma pushBag_spec (P Q : iProp Σ) γ (x v : val)  :
    □ (∀ (X : gmultiset val), bag_contents γ X ∗ P
                     ={⊤∖↑N}=∗ ▷ (bag_contents γ ({[v]} ⊎ X) ∗ Q)) -∗
    {{{ is_bag γ x ∗ P }}}
      pushBag x (of_val v)
    {{{ RET #(); Q }}}.
  Proof.
    iIntros "#Hvs".
    iIntros (Φ). iAlways. iIntros "[#Hbag HP] HΦ".
    unfold pushBag. wp_rec. wp_let.
    rewrite /is_bag /bag_inv.
    iDestruct "Hbag" as (lk b γl) "[% #Hlk]"; simplify_eq/=.
    repeat wp_pure _.
    wp_apply (acquire_spec with "Hlk"). iIntros "[Htok Hb1]".
    iDestruct "Hb1" as (ls) "[Hb Ha]".
    wp_seq. wp_load. wp_let.
    wp_bind (_ <- _)%E.
    iApply (wp_mask_mono _ (⊤∖↑N)); first done.
    iMod ("Hvs" with "[$Ha $HP]") as "[Hbc HQ]".
    wp_store. wp_seq.
    wp_apply (release_spec with  "[$Hlk $Htok Hbc Hb]").
    { iExists (v::ls); iFrame. }
    iIntros "_". by iApply "HΦ".
  Qed.

  Lemma popBag_spec (P : iProp Σ) (Q : val → iProp Σ) γ x :
    □ (∀ (X : gmultiset val) (y : val),
               bag_contents γ ({[y]} ⊎ X) ∗ P
               ={⊤∖↑N}=∗ ▷ (bag_contents γ X ∗ Q (SOMEV y))) -∗
    □ (bag_contents γ ∅ ∗ P ={⊤∖↑N}=∗ ▷ (bag_contents γ ∅ ∗ Q NONEV)) -∗
    {{{ is_bag γ x ∗ P }}}
      popBag x
    {{{ v, RET v; Q v }}}.
  Proof.
    iIntros "#Hvs1 #Hvs2".
    iIntros (Φ). iAlways. iIntros "[#Hbag HP] HΦ".
    unfold popBag. wp_rec.
    rewrite /is_bag /bag_inv.
    iDestruct "Hbag" as (lk b γl) "[% #Hlk]"; simplify_eq/=.
    repeat wp_pure _.
    wp_apply (acquire_spec with "Hlk"). iIntros "[Htok Hb1]".
    iDestruct "Hb1" as (ls) "[Hb Ha]".
    wp_seq. wp_bind (!#b)%E.
    iApply (wp_mask_mono _ (⊤∖↑N)); first done.
    destruct ls as [|v ls]; simpl.
    - iMod ("Hvs2" with "[$Ha $HP]") as "[Hbc HQ]".
      wp_load. repeat wp_pure _.
      wp_apply (release_spec with  "[$Hlk $Htok Hbc Hb]").
      { iExists []; iFrame. }
      iIntros "_". repeat wp_pure _. by iApply "HΦ".
    - iMod ("Hvs1" with "[$Ha $HP]") as "[Hbc HQ]".
      wp_load. repeat wp_pure _. wp_store. do 2 wp_pure _.
      wp_apply (release_spec with  "[$Hlk $Htok Hbc Hb]").
      { iExists ls; iFrame. }
      iIntros "_". repeat wp_pure _. by iApply "HΦ".
  Qed.

End proof.

Typeclasses Opaque bag_contents is_bag.

Canonical Structure cg_bag `{!heapG Σ, !bagG Σ} : bag Σ :=
  {| abstract_bag.is_bag := is_bag;
     abstract_bag.is_bag_persistent := is_bag_persistent;
     abstract_bag.bag_contents_timeless := bag_contents_timeless;
     abstract_bag.bag_contents_agree := bag_contents_agree;
     abstract_bag.bag_contents_update := bag_contents_update;
     abstract_bag.newBag_spec := newBag_spec;
     abstract_bag.pushBag_spec := pushBag_spec;
     abstract_bag.popBag_spec := popBag_spec |}.


(** Author: Alexander Anisimov *)
From mathcomp Require Import ssreflect ssrbool eqtype seq choice.
From CompDecModal.libs Require Import edone bcase base fset.

Set Default Proof Using "Type".

Set Implicit Arguments.
(*Unset Strict Implicit.*)

(** * Automation for finite Sets *)

Section TabRules.

  Variable T: choiceType.

  (** Simplification rules **)

  (** composite set operations and relations **)
  Lemma properSub (A B : {fset T}): A `<` B = (A `<=` B) && ~~ (B `<=` A).
  Proof. rewrite properEneq eqEsub. by case (A`<=`B), (B`<=`A). Qed.
  Lemma sepI (A B : {fset T}) : A `&` B = [fset x in A | x \in B].
  Proof. by rewrite /fsetI. Qed.
  Lemma sepD (A B : {fset T}) : A `\` B = [fset x in A | x \notin B].
  Proof. by rewrite /fsetD. Qed.

  Definition compSetOps := (sepI, sepD, properSub).

  (** ** Tableau rules **)

  (** nonbranching *)

  (** one premise*)
  Lemma prop_dn s : ~~ ~~ s -> s. (*P7*)
  Proof. exact (@ negbNE s). Qed.

  Lemma prop_conj s t : s && t -> s /\ t. (*P1*)
  Proof. apply: andP. Qed.

  Lemma prop_negDisj s t : ~~ (s || t) -> ~~ s /\ ~~ t. (*P5*)
  Proof. rewrite negb_or. apply: andP. Qed.

  Lemma prop_negImpl s t : ~~ (s ==> t) -> s /\ ~~ t. (*P6*)
  Proof. rewrite negb_imply. apply: andP. Qed.

  Lemma satr_eqSym (a b : T) : a == b -> b == a. (*S8*)
  Proof. by rewrite eq_sym. Qed.

  Lemma satr_memSgt (a b : T) : a \in [fset b] -> a == b. (*S9*)
  Proof. by rewrite in_fset1. Qed.

  Lemma satr_nmemSgt (a b : T) : a \notin [fset b] -> a != b. (*S10*)
  Proof. by rewrite in_fset1. Qed.

  Lemma satr_sgtSub (a:T) (A : {fset T}) : [fset a] `<=` A -> a \in A. (*S11*)
  Proof. by rewrite fsub1. Qed.

  Lemma satr_eqP (A B : {fset T}) : A == B -> (A `<=` B) /\ (B `<=` A). (*S4*)
  Proof. rewrite eqEsub. apply: andP. Qed.

  Lemma satr_nmemU (a:T) (A B : {fset T}) : a \notin A `|` B -> a \notin A /\ a \notin B. (*S13*)
  Proof. rewrite in_fsetU negb_or. apply: andP. Qed.

  Lemma pow_mem (A B : {fset T}) : A \in (powerset B) -> A `<=` B. (*Q1*)
  Proof. by rewrite powersetE. Qed.

  (** several premises *)
  Lemma satr_memSub (a:T) (A B : {fset T}) : a \in A -> A `<=` B -> a \in B. (*S1*)
  Proof. move => P Q. apply: (@subP T A) => //. Qed.

  Lemma satr_nmemSup (a:T) (A B : {fset T}) : a \notin A -> B `<=` A -> a \notin B. (*S2*)
  Proof. move => P Q. case R: (a \in B) => //. by rewrite (subP Q) in P. Qed.

  Lemma satr_eqMem (a b : T) (A : {fset T}) : a == b -> b \in A -> a \in A. (*S6*)
  Proof. intros P Q. by rewrite -(eqP P) in Q. Qed.

  Lemma satr_eqTrans (a b c : T) : a == b -> b == c -> a == c. (*S7*)
  Proof. intros P Q. by rewrite -(eqP P) in Q. Qed.

  (** fresh variable generation *)
  Lemma satr_notSub (A B : {fset T}) : ~~ (A `<=` B) -> exists a, (a \in A) /\ (a \notin B). (*S3*)
  Proof. move => P. move: (subPn A B P) => {P} [a P Q]. by exists a. Qed.

  Lemma pow_nmem (A B : {fset T}) : A \notin (powerset B) -> exists x, (x \in A) /\ (x \notin B). (*Q2*)
  Proof. rewrite powersetE => P. apply (satr_notSub A B P). Qed.

  (** branching *)

  Lemma prop_disj s t : s || t -> s \/ t. (*P2*)
  Proof. apply: orP. Qed.

  Lemma prop_impl s t : s ==> t -> ~~ s \/ t. (*P3*)
  Proof. rewrite implybE. apply: orP. Qed.

  Lemma prop_negConj s t : ~~ (s && t) -> ~~ s \/ ~~ t. (*P4*)
  Proof. rewrite negb_and. apply: orP. Qed.

  Lemma satr_memU (a:T) (A B : {fset T}) : a \in A `|` B -> a \in A \/ a \in B. (*S12*)
  Proof. rewrite in_fsetU. apply: orP. Qed.

  Lemma satr_neqP (A B : {fset T}) :
    A != B -> exists x, (x \in A /\ x \notin B) \/ (x \in B /\ x \notin A). (*S5*)
  Proof.
    rewrite eqEsub negb_and => P. move: (orP P) => {P} [P|P].
    - move: (satr_notSub A B P) => {P} [x [P Q]]. exists x; by left.
    - move: (satr_notSub B A P) => {P} [x [P Q]]. exists x; by right.
  Qed.

  (** branch closing *)

  Lemma clos_posNeg (s : bool) : s -> ~~ s -> False. (*D1*)
  Proof. by case s. Qed.

  Lemma clos_neqxx (a : T) : a != a -> False. (*D2*)
  Proof. by rewrite eqxx. Qed.

  Lemma clos_memEmp (a : T) : a \in fset0 -> False. (*D3*)
  Proof. by rewrite in_fset0. Qed.

  (** substitution *)

  Lemma subst_memSep (y:T) (A : {fset T}) (p : T -> bool) : y \in sep A p -> (y \in A) /\ (p y). (*R1*)
  Proof. rewrite in_sep. apply: andP. Qed.

  Lemma subst_nmemSep (y:T) (A : {fset T}) (p : T -> bool):
    y \notin [ fset x in A | p x] -> y \notin A \/ ~~ p y. (*R2*)
  Proof. rewrite in_sep => P . apply: orP. by rewrite -negb_and. Qed.

  (** cut *)

  Lemma cut_eq (a b : T) : a == b \/ a != b.
  Proof. case (a == b); first by left. right. by apply negbT. Qed. (*C1*)

  Lemma cut_mem a (A: {fset T}) : a \in A \/ a \notin A. (*C2*)
  Proof. case (a \in A); first by left. right. by apply negbT. Qed.

  Lemma cut_sub (A B : {fset T}) : A `<=` B \/ ~~ (A `<=` B). (*C3*)
  Proof. case (A `<=` B); first by left. right. by apply negbT. Qed.

End TabRules.

(** ** Implementation of the Tactic *)

(** adding conclusions of diffrerent rule types *)

Ltac extend X PX :=
  let V := fresh "H" in
  let X := constr:(is_true X) in
  match goal with
    | _:  X |- _ => fail 1
    | _ => have V: X by apply PX
  end.

Ltac extend_conj A B PX :=
  let U := fresh "H" in
  let V := fresh "H" in
  let A := (eval simpl in (is_true A)) in
  let B := (eval simpl in (is_true B)) in
  match goal with
    | _: A, _: B |- _ => fail 1
    | _ => have [U V]: A /\ B by apply PX
  end.

Ltac extend_disj A B PX :=
  let V := fresh "H" in
  let A := (eval simpl in (is_true A)) in
  let B := (eval simpl in (is_true B)) in
  match goal with
    | _: A |- _ => fail 1
    | _: B |- _ => fail 1
    | _ => have [V | V]: A \/ B by apply PX
  end.

Ltac extend_conj_ex A B PX :=
  let X := fresh "x" in
  let U := fresh "H" in
  let V := fresh "H" in
  match goal with
    | _: is_true(?x \in A), _: is_true (?x \notin B) |- _ => fail 1
    | _ => have [X [U V]]: exists x, (x \in A) /\ (x \notin B) by apply PX
  end.

Ltac extend_disconj_ex A B PX :=
  let X := fresh "x" in
  let U := fresh "H" in
  let V := fresh "H" in
  match goal with
    | _: is_true(?x \in A), _: is_true(?x \notin B) |- _ => fail 1
    | _: is_true(?x \in B), _: is_true(?x \notin A) |- _ => fail 1
    | _ => have [X [[U V] | [U V]]]:
             exists x, (x \in A /\ x \notin B) \/ (x \in B /\ x \notin A)
               by apply PX
  end.

(** saturation *)

Ltac closebranch :=
  match goal with
  | H0: is_true (?s), H1: is_true(~~ ?s) |- _ => apply (@ clos_posNeg s); first exact H0; exact H1
  | H0: is_true (?a != ?a)               |- _ => apply (@ clos_neqxx _ a); exact H0
  | H0: is_true (?a \in fset0)           |- _ => apply (@ clos_memEmp _ a); exact H0
  end.

Ltac nonbranching :=
  match goal with
  (* one premiss *)
  | _: is_true(~~ ~~ ?s)             |- _ => extend s (prop_dn s)
  | _: is_true(?s && ?t)             |- _ => extend_conj s t (prop_conj s t)
  | _: is_true(~~ (?s || ?t))        |- _ => extend_conj (~~ s) (~~ t) (prop_negDisj s t)
  | _: is_true(~~ (?s ==> ?t))       |- _ => extend_conj s (~~ t) (prop_negImpl s t)
  | _: is_true(?a == ?b)             |- _ => extend (b == a) (satr_eqSym a b)
  | _: is_true(?a \in [fset ?b])     |- _ => extend (a == b) (satr_memSgt _ a b)
  | _: is_true(?a \notin [fset ?b])  |- _ => extend (a != b) (satr_nmemSgt _ a b)
  | _: is_true([fset ?a] `<=` ?A)    |- _ => extend (a \in A) (satr_sgtSub a A)
  | _: is_true(?A == ?B)             |- _ => extend_conj (A `<=` B) (B `<=` A) (satr_eqP A B)
  | _: is_true(?a \notin ?A `|` ?B)  |- _ => extend_conj (a \notin A) (a \notin B) (satr_nmemU a A B)
  | _: is_true(?A \in (powerset ?B)) |- _ => extend (A `<=` B) (pow_mem A B)
  (* several premises *)
  | _: is_true(?a \in ?A), _: is_true(?A `<=` ?B)    |- _ => extend (a \in B) (satr_memSub a A B)
  | _: is_true(?a \notin ?A), _: is_true(?B `<=` ?A) |- _ => extend (a \notin B) (satr_nmemSup a A B)
  | _: is_true(?a == ?b), _: is_true(?b \in ?A)      |- _ => extend (a \in A) (satr_eqMem a b A)
  | _: is_true(?a == ?b), _: is_true(?b == ?c)       |- _ => extend (a == c) (satr_eqTrans _ a b c)
  (* freshvar *)
  | _: is_true(~~ (?A `<=` ?B))         |- _ => extend_conj_ex A B (satr_notSub A B)
  | _: is_true(?A \notin (powerset ?B)) |- _ => extend_conj_ex A B (pow_nmem A B)
  (* substitution *)
  | _: is_true(?a \in sep ?A ?p) |- _ => extend_conj (a \in A) (p a) (subst_memSep a A p)
  end.

Ltac branching :=
  match goal with
  | _: is_true(?s || ?t)            |- _ => extend_disj s t (prop_disj s t)
  | _: is_true(?s ==> ?t)           |- _ => extend_disj (~~ s) t (prop_impl s t)
  | _: is_true(~~ (?s && ?t))       |- _ => extend_disj (~~ s) (~~ t) (prop_negConj s t)
  (* basic saturation *)
  | _: is_true(?a \in ?A `|` ?B)    |- _ => extend_disj (a \in A) (a \in B) (satr_memU a A B)
  | _: is_true(?A != ?B)            |- _ => extend_disconj_ex A B (satr_neqP A B)
  (*substitution *)
  | _: is_true(?a \notin sep ?A ?p) |- _ => extend_disj (a \notin A) (~~ (p a)) (subst_nmemSep a A p)
  end.

Ltac cutrules :=
  match goal with
  | _: context[?a], _: context[?A] |- _ => extend_disj (a \in A) (a \notin A) (cut_mem a A)
  | _: context[?A], _: context[?B] |- _ => extend_disj (A `<=` B) (~~(A `<=` B)) (cut_sub A B)
  | _: context[?A], _: context[?B] |- _ => extend_disj (A == B) (A != B) (cut_eq _ A B)
  end.

(** form control *)

Ltac reverywhere X :=
  repeat rewrite X;
  repeat match goal with
           | H: _ |- _ => rewrite X in H
         end.

Ltac genSubst :=
  repeat (
      let V := fresh "su" in
      match goal with
        | H: is_true(?x == ?y) |- _ =>
          match goal with
            | _: x = y |- _ => fail 1
            | _ => move: (eqP H) => V
          end
        | x := _ |- _ => subst x
      end
    ); subst.

Ltac clearNonbools :=
  repeat(
      match goal with
      | H : _ |- _ =>
        match type of H with
        | is_true _ => fail 1
        | _ = _ => fail 1
        | _ => clear H
        end
      end
    ).

(** preprocessing *)

Lemma semiDN (b:bool) : ~ ~~ b -> b.
Proof. case: b => _ //. Qed.

Lemma eq2bool (T : eqType) (a b : T) : a = b -> a == b.
Proof. move => H. by rewrite H. Qed.

Ltac oDN :=
  let V := fresh "H" in
  match goal with
  | |- is_true _ => apply semiDN; hnf => V
  | |- _ = _ => apply:eqP; apply semiDN; hnf => V
  | |- False => idtac
  end.

Ltac eq2bool :=
  let V := fresh "H" in
  match goal with
  | H: _ = _ |- _ => move:(eq2bool _ H) => V
  | _ => idtac
  end.

Ltac preproc :=
  repeat (let V := fresh "H" in move => V);
  oDN;
  eq2bool;
  reverywhere compSetOps;
  clearNonbools.

(** automated saturation without cuts *)

Ltac core :=
  repeat(
      genSubst;
      repeat nonbranching;
      try closebranch;
      genSubst;
      try branching;
      try closebranch
    ).

(** ** User-level Tactics *)

Ltac fset_dec :=
  preproc;
  repeat(
      try closebranch;
      core;
      try cutrules
    ).

(** omits cut rules *)
Ltac fset_nocut := preproc; try closebranch; core.

Ltac invert X :=
  match X with
    | (?x, ?y) =>
      match x with
        | (?x0, ?x1) => let z := invert (x0, (x1, y)) in constr:(z)
      end
    | _ => constr:(X)
  end.

(** unfolds all definitions given in a tuple before applying fset_dec *)
Ltac fset_decu X :=
  let Y := invert X in
  match Y with
    | (?x, ?xs) => unfold x in *; fset_decu xs
    | ?x => unfold x in *; fset_dec
  end.

(** omits cut rules and unfolds definitions *)
Ltac fset_nocutu X :=
  let Y := invert X in
  match Y with
    | (?x, ?xs) => unfold x in *; fset_nocutu xs
    | ?x => unfold x in *; fset_nocut
  end.


(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *)
(* File reduced by coq-bug-finder from original input, then from 17950 lines to 11826 lines, then from 10956 lines to 10214 lines, then from 10225 lines to 6285 lines, then from 6300 lines to 901 lines, then from 833 lines to 552 lines, then from 529 lines to 478 lines *)
Axiom proof_admitted : False.
Tactic Notation "admit" := case proof_admitted.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Axiom admit : forall {T}, T.
Reserved Infix "o" (at level 40, left associativity).
Definition relation (A : Type) := A -> A -> Type.
Class Symmetric {A} (R : relation A) := symmetry : forall x y, R x y -> R y x.
Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
Arguments idpath {A a} , [A] a.
Delimit Scope path_scope with path.
Local Open Scope path_scope.
Definition inverse {A : Type} {x y : A} (p : x = y) : y = x := match p with idpath => idpath end.
Instance symmetric_paths {A} : Symmetric (@paths A) | 0 := @inverse A.
Notation "1" := idpath : path_scope.
Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) := forall x:A, f x = g x.
Hint Unfold pointwise_paths : typeclass_instances.
Class Contr_internal (A : Type) := { center : A ; contr : (forall y : A, center = y) }.
Inductive trunc_index : Type := minus_two | trunc_S (x : trunc_index).
Fixpoint nat_to_trunc_index (n : nat) : trunc_index
  := match n with
       | 0 => trunc_S (trunc_S minus_two)
       | S n' => trunc_S (nat_to_trunc_index n')
     end.
Coercion nat_to_trunc_index : nat >-> trunc_index.
Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
  match n with
    | minus_two => Contr_internal A
    | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y)
  end.
Class IsTrunc (n : trunc_index) (A : Type) : Type :=
  Trunc_is_trunc : IsTrunc_internal n A.
Notation IsHSet := (IsTrunc 0).
Axiom dummy_funext_type : Type.
Class Funext := { dummy_funext_value_for_speed : dummy_funext_type }.
Global Instance trunc_forall `{P : A -> Type} `{forall a, IsTrunc n (P a)} : IsTrunc n (forall a, P a) | 100.
admit.
Defined.
Definition path_prod_uncurried {A B : Type} (z z' : A * B)
           (pq : (fst z = fst z') * (snd z = snd z'))
: (z = z')
  := match pq with (p,q) =>
                   match z, z' return
                         (fst z = fst z') -> (snd z = snd z') -> (z = z') with
                     | (a,b), (a',b') => fun p q =>
                                           match p, q with
                                               idpath, idpath => 1
                                           end
                   end p q
     end.
Definition path_prod {A B : Type} (z z' : A * B) :
  (fst z = fst z') -> (snd z = snd z') -> (z = z')
  := fun p q => path_prod_uncurried z z' (p,q).
Definition path_prod' {A B : Type} {x x' : A} {y y' : B}
: (x = x') -> (y = y') -> ((x,y) = (x',y'))
  := fun p q => path_prod (x,y) (x',y') p q.
Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}.
Global Existing Instance iss.
Delimit Scope morphism_scope with morphism.
Delimit Scope category_scope with category.
Delimit Scope object_scope with object.
Record PreCategory :=
  Build_PreCategory' {
      object :> Type;
      morphism : object -> object -> Type;

      identity : forall x, morphism x x;
      compose : forall s d d',
                  morphism d d'
                  -> morphism s d
                  -> morphism s d'
                              where "f 'o' g" := (compose f g);

      associativity : forall x1 x2 x3 x4
                             (m1 : morphism x1 x2)
                             (m2 : morphism x2 x3)
                             (m3 : morphism x3 x4),
                        (m3 o m2) o m1 = m3 o (m2 o m1);

      associativity_sym : forall x1 x2 x3 x4
                                 (m1 : morphism x1 x2)
                                 (m2 : morphism x2 x3)
                                 (m3 : morphism x3 x4),
                            m3 o (m2 o m1) = (m3 o m2) o m1;

      left_identity : forall a b (f : morphism a b), identity b o f = f;
      right_identity : forall a b (f : morphism a b), f o identity a = f;

      identity_identity : forall x, identity x o identity x = identity x;

      trunc_morphism : forall s d, IsHSet (morphism s d)
    }.

Bind Scope category_scope with PreCategory.
Arguments identity [!C%category] x%object : rename.
Arguments compose [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename.

Definition Build_PreCategory
           object morphism compose identity
           associativity left_identity right_identity
  := @Build_PreCategory'
       object
       morphism
       compose
       identity
       associativity
       (fun _ _ _ _ _ _ _ => symmetry _ _ (associativity _ _ _ _ _ _ _))
       left_identity
       right_identity
       (fun _ => left_identity _ _ _).

Existing Instance trunc_morphism.
Infix "o" := compose : morphism_scope.
Notation "1" := (identity _) : morphism_scope.

Delimit Scope functor_scope with functor.

Local Open Scope morphism_scope.

Section Functor.

  Record Functor (C D : PreCategory) :=
    {
      object_of :> C -> D;
      morphism_of : forall s d, morphism C s d
                                -> morphism D (object_of s) (object_of d);
      composition_of : forall s d d'
                              (m1 : morphism C s d) (m2: morphism C d d'),
                         morphism_of _ _ (m2 o m1)
                         = (morphism_of _ _ m2) o (morphism_of _ _ m1);
      identity_of : forall x, morphism_of _ _ (identity x)
                              = identity (object_of x)
    }.
End Functor.

Bind Scope functor_scope with Functor.
Arguments morphism_of [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch.
Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope.

Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := { morphism_inverse : morphism C d s ;
                                                                      foo : morphism_inverse = morphism_inverse }.

Section opposite.
  Definition opposite (C : PreCategory) : PreCategory
    := @Build_PreCategory'
         C
         (fun s d => morphism C d s)
         (identity (C := C))
         (fun _ _ _ m1 m2 => m2 o m1)
         (fun _ _ _ _ _ _ _ => @associativity_sym _ _ _ _ _ _ _ _)
         (fun _ _ _ _ _ _ _ => @associativity _ _ _ _ _ _ _ _)
         (fun _ _ => @right_identity _ _ _)
         (fun _ _ => @left_identity _ _ _)
         (@identity_identity C)
         _.
End opposite.
Notation "C ^op" := (opposite C) (at level 3) : category_scope.

Section prod.

  Definition prod (C D : PreCategory) : PreCategory.
    refine (@Build_PreCategory
              (C * D)%type
              (fun s d => (morphism C (fst s) (fst d)
                           * morphism D (snd s) (snd d))%type)
              (fun x => (identity (fst x), identity (snd x)))
              (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1))
              _
              _
              _
              _); admit.
  Defined.
End prod.
Infix "*" := prod : category_scope.

Section composition.
  Variable C : PreCategory.
  Variable D : PreCategory.
  Variable E : PreCategory.
  Variable G : Functor D E.
  Variable F : Functor C D.

  Definition composeF : Functor C E
    := Build_Functor
         C E
         (fun c => G (F c))
         (fun _ _ m => morphism_of G (morphism_of F m))
         admit
         admit.
End composition.
Infix "o" := composeF : functor_scope.

Module Export HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Core.

  Section NaturalTransformation.
    Variable C : PreCategory.
    Variable D : PreCategory.
    Variables F G : Functor C D.

    Record NaturalTransformation :=
      Build_NaturalTransformation' {
          components_of :> forall c, morphism D (F c) (G c);
          commutes : forall s d (m : morphism C s d),
                       components_of d o F _1 m = G _1 m o components_of s;

          commutes_sym : forall s d (m : C.(morphism) s d),
                           G _1 m o components_of s = components_of d o F _1 m
        }.
  End NaturalTransformation.

  Section composition.

    Section compose.
      Variable C : PreCategory.
      Variable D : PreCategory.
      Variables F F' F'' : Functor C D.

      Variable T' : NaturalTransformation F' F''.
      Variable T : NaturalTransformation F F'.

      Local Notation CO c := (T' c o T c).

      Definition composeT
      : NaturalTransformation F F''
        := Build_NaturalTransformation' F F''
                                        (fun c => CO c)
                                        admit
                                        admit.
    End compose.

  End composition.
  Infix "o" := composeT : natural_transformation_scope.

  Section path_natural_transformation.

    Global Instance trunc_natural_transformation C D (F G : Functor C D)
    : IsHSet (NaturalTransformation F G).
    admit.
    Defined.

  End path_natural_transformation.
  Local Open Scope natural_transformation_scope.

  Section associativity.

    Section nt.

      Definition associativityT `{H0 : Funext}
                 C D F G H I
                 (V : @NaturalTransformation C D F G)
                 (U : @NaturalTransformation C D G H)
                 (T : @NaturalTransformation C D H I)
      : (T o U) o V = T o (U o V).
        admit.
      Defined.
    End nt.
  End associativity.

  Section functor_category.

    Definition functor_category `{Funext} (C D : PreCategory) : PreCategory
      := @Build_PreCategory (Functor C D)
                            (@NaturalTransformation C D)
                            admit
                            (@composeT C D)
                            (@associativityT _ C D)
                            admit
                            admit
                            _.
  End functor_category.

  Local Notation "C -> D" := (functor_category C D) : category_scope.
  Module Export ExponentialLaws.
    Module Export Law4.
      Module Export Functors.

        Section law4.
          Context `{Funext}.
          Variable C1 : PreCategory.
          Variable C2 : PreCategory.
          Variable D : PreCategory.

          Section inverse.

            Section object_of.
              Variable F : Functor (C1 * C2) D.

              Definition inverse_object_of_object_of
              : C1 -> (C2 -> D)%category.
              Proof.
                intro c1.
                refine (Build_Functor
                          C2 D
                          (fun c2 => F (c1, c2))
                          (fun s2 d2 m2 => morphism_of
                                             F
                                             (s := (c1, s2))
                                             (d := (c1, d2))
                                             (identity c1, m2))
                          _
                          _);
                  admit.
              Defined.

              Definition inverse_object_of_morphism_of
                         s d (m : morphism C1 s d)
              : morphism (C2 -> D)
                         (inverse_object_of_object_of s)
                         (inverse_object_of_object_of d).
                admit.
              Defined.

              Definition inverse_object_of
              : (C1 -> (C2 -> D))%category.
              Proof.
                refine (Build_Functor
                          C1 (C2 -> D)
                          inverse_object_of_object_of
                          inverse_object_of_morphism_of
                          _
                          _); admit.
              Defined.
            End object_of.

            Section morphism_of.

              Definition inverse_morphism_of
                         s d (m : morphism (C1 * C2 -> D) s d)
              : morphism (C1 -> (C2 -> D))
                         (inverse_object_of s)
                         (inverse_object_of d).
                admit.
              Defined.
            End morphism_of.

            Definition inverse
            : Functor (C1 * C2 -> D) (C1 -> (C2 -> D)).
            Proof.
              refine (Build_Functor
                        (C1 * C2 -> D) (C1 -> (C2 -> D))
                        inverse_object_of
                        inverse_morphism_of
                        _
                        _);
              admit.
            Defined.
          End inverse.
        End law4.

        Section opposite.

          Definition opposite C D (F : Functor C D) : Functor C^op D^op
            := Build_Functor (C^op) (D^op)
                             (object_of F)
                             (fun s d => morphism_of F (s := d) (d := s))
                             (fun d' d s m1 m2 => composition_of F s d d' m2 m1)
                             (identity_of F).
        End opposite.
        Notation "F ^op" := (opposite F) : functor_scope.

        Module ProdF.

          Section proj.

            Definition fst {C D} : Functor (C * D) C
              := Build_Functor (C * D) C
                               (@fst _ _)
                               (fun _ _ => @fst _ _)
                               (fun _ _ _ _ _ => idpath)
                               (fun _ => idpath).

            Definition snd {C D} : Functor (C * D) D
              := Build_Functor (C * D) D
                               (@snd _ _)
                               (fun _ _ => @snd _ _)
                               (fun _ _ _ _ _ => idpath)
                               (fun _ => idpath).
          End proj.

          Section prod.

            Definition prod C D D' (F : Functor C D) (F' : Functor C D')
            : Functor C (D * D')
              := Build_Functor
                   C (D * D')
                   (fun c => (F c, F' c))
                   (fun s d m => (F _1 m, F' _1 m))
                   (fun _ _ _ _ _ => path_prod' (composition_of F _ _ _ _ _)
                                                (composition_of F' _ _ _ _ _))
                   (fun _ => path_prod' (identity_of F _) (identity_of F' _)).
          End prod.

          Local Infix "*" := prod : functor_scope.

          Section pair.
            Definition pair C D C' D' (F : Functor C D) (F' : Functor C' D') : Functor (C * C') (D * D')
              := (F o fst) * (F' o snd).
          End pair.

          Module Export FunctorProdNotations.
            Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : functor_scope.
          End FunctorProdNotations.

        End ProdF.

        Notation cat_of obj :=
          (@Build_PreCategory obj
                              (fun x y => x -> y)
                              (fun _ x => x)
                              (fun _ _ _ f g => fun x => f (g x))
                              (fun _ _ _ _ _ _ _ => idpath)
                              (fun _ _ _ => idpath)
                              (fun _ _ _ => idpath)
                              _).
        Definition set_cat `{Funext} : PreCategory := cat_of hSet.

        Section hom_functor.
          Context `{Funext}.
          Variable C : PreCategory.

          Local Notation obj_of c'c :=
            (@BuildhSet
               (morphism
                  C
                  (fst (c'c : object (C^op * C)))
                  (snd (c'c : object (C^op * C))))
               _).

          Definition hom_functor : Functor (C^op * C) set_cat.
            refine (Build_Functor (C^op * C) set_cat
                                  (fun c'c => obj_of c'c)
                                  admit
                                  admit
                                  admit).
          Defined.
        End hom_functor.
        Import ProdF.

        Section full_faithful.
          Context `{Funext}.
          Variable C : PreCategory.
          Variable D : PreCategory.
          Variable F : Functor C D.

          Definition induced_hom_natural_transformation
          : NaturalTransformation (hom_functor C) (hom_functor D o (F^op, F)).
            admit.
          Defined.

          Class IsFullyFaithful
            := is_fully_faithful
               : forall x y : C,
                   IsIsomorphism (induced_hom_natural_transformation (x, y)).
        End full_faithful.

        Definition coyoneda `{Funext} A : Functor A^op (A -> set_cat)
          := ExponentialLaws.Law4.Functors.inverse _ _ _ (hom_functor A).

        Definition coyoneda_lemma_morphism `{Funext} A (F : object (A -> set_cat)) (a : A)
        : morphism set_cat
                   (@BuildhSet
                      (morphism (A -> set_cat) (coyoneda A a) F)
                      _)
                   (F a)
          := fun phi => phi a 1%morphism.
        Context `{Funext}.
        Variable A : PreCategory.

        Definition coyoneda_embedding : IsFullyFaithful (coyoneda A).
        Proof.
          intros a b.
          pose (coyoneda_lemma_morphism (F := coyoneda A b) (a := a)) as X.
          exists X.
          Undo.
          Typeclasses eauto := debug.
          Time exists (@coyoneda_lemma_morphism _ A (@coyoneda _ A b) a).
(** Matthieu says:

This is an unfortunate situation indeed. What happens currently is
that the exists tries to unify the type of the coyoneda application
with the hnf of the [morphism _ _ _ ] argument of Build_IsIsomorphism,
which is:

  (let
   (object, morphism, identity, compose, _, _, _, _, _, _) as p
   return (p -> p -> Type) := ?M216 in
   morphism) ?M218 ?M217

This fails. The typeclass resolution is launched during unification
([Typeclass Resolution for Conversion] is on), figuring out the funext
instances, but again the unification fails and we forget about these
instantiations. Then the goal is unified with
[IsIsomorphism ?M216 ?M217 ?M218] and that sets the metavariables to
the right terms. We try again the coercion of the coyoneda application
with the refined (let (objec... ) term which now unfolds and unifies
correctly, but as the existentials for the typeclass instances are not
filled, we must resort to doing the unfolding in unification and the
(unsound) first-order approximation rule of w_unify fires, which tries
to compare two terms of different types, namely Buildhset and:
Eval compute in @object_of
               (Top.prod (Top.opposite (Top.opposite A)) (Top.opposite A))
               (@set_cat H).
Forcing unification to compute a normal form of the latter, which
expands to a very large term. This explains the slowdown. In the case
of the pose, no unification is needed, only conversion, which does not
try this first-order unification, because no metavariables appear
anymore in the type of the coyoneda application.

I'm surprised by the remark of PMP though, I couldn't reproduce a
noticeable speedup by deactivating universe hconsing, how did you do
it? *)


Require Import UNIVERSE.
Require Import Events.
Require Import Classical.
Require Import ClassicalEpsilon.
Require Import CoqlibC.
Require Import Smallstep.
(** newly added **)
Require Export Behaviors.
Require Import Simulation.

Set Implicit Arguments.

Definition improves (L1 L2: semantics): Prop := forall beh2
    (BEH: program_behaves L2 beh2),
    exists beh1, <<BEH: program_behaves L1 beh1>> /\ <<IMPRV: behavior_improves beh1 beh2>>.

Global Program Instance improves_PreOrder: PreOrder improves.
Next Obligation.
  ii. esplits; eauto. eapply behavior_improves_refl.
Qed.
Next Obligation.
  ii. r in H. r in H0. repeat spc H0. des. specialize (H _ BEH0). des.
  esplits; eauto. eapply behavior_improves_trans; eauto.
Qed.

Lemma bsim_improves
      L1 L2
      (BSIM: backward_simulation L1 L2):
    <<IMRPV: improves L1 L2>>.
Proof.
  ii. eapply backward_simulation_behavior_improves; eauto.
  eapply backward_to_compcert_backward_simulation; eauto.
Qed.

Lemma back_propagate_ub_behav
      beh0
      (INITUB: behavior_improves beh0 (Goes_wrong E0)):
    <<INITUB: beh0 = Goes_wrong E0>>.
Proof.
  rr in INITUB. des; clarify; et.
  rr in INITUB0. des. unfold behavior_app in *. des_ifs. destruct t; ss.
Qed.

Lemma back_propagate_ub_program
      sem0 sem1
      (IMPR: improves sem0 sem1)
      (INITUB: program_behaves sem1 (Goes_wrong E0)):
    <<INITUB: program_behaves sem0 (Goes_wrong E0)>>.
Proof.
  exploit IMPR; eauto. i; des.
  hexploit back_propagate_ub_behav; et. i ;des. clarify.
Qed.

Lemma improves_free_theorem
      L1 L2
      (IMPRV: forall
          (INITSAFE: exists st, <<INIT: Smallstep.initial_state L1 st>>)
          (INITSAFE: forall st (INIT: Smallstep.initial_state L1 st),
              <<SAFE: safe L1 st>>)
        ,
          improves L1 L2)
  :
    <<IMPRV: improves L1 L2>>
.
Proof.
  destruct (classic (exists st, <<INIT: Smallstep.initial_state L1 st>>)); cycle 1.
  { clear - H.
    ii.
    exists (Goes_wrong []). esplits; ss; eauto using behavior_improves_bot.
    econs 2; eauto.
  }
  destruct (classic (forall st (INIT: Smallstep.initial_state L1 st), <<SAFE: safe L1 st>>)); cycle 1.
  { clear - H0. rename H0 into H.
    ii.
    exists (Goes_wrong []). esplits; ss; eauto.
    - apply Classical_Pred_Type.not_all_ex_not in H. des.
      apply Classical_Prop.imply_to_and in H. des.
      econs 1; eauto.
      clear - H0.
      apply Classical_Pred_Type.not_all_ex_not in H0. des.
      repeat (apply_all_once Classical_Prop.imply_to_and; des).
      apply Classical_Prop.not_or_and in H1. des.
      econs 4; eauto.
      ii. eapply H2; eauto.
    - eapply behavior_improves_bot; eauto.
  }
  eauto.
Qed.


Require Import FJ_tactics.
Require Import List.
Require Import Functors.
Require Import Names.
Require Import PNames.
Require Import FunctionalExtensionality.
Require Import Bool.
Require Import Lambda.

Section PLambda_Bool.

  Variable D : Set -> Set.
  Context {Fun_D : Functor D}.
  Definition DType := DType D.
  Context {Sub_BType_D : BType :<: D}.
  Context {Sub_LType_D : LType :<: D}.
  Context {WF_Sub_BType_D : WF_Functor _ _ Sub_BType_D}.
  Context {WF_Sub_LType_D : WF_Functor _ _ Sub_LType_D}.
  Context {eq_DType_D : forall T, FAlgebra eq_DTypeName T (eq_DTypeR D) D}.
  Context {eq_TArrow_D : forall T, FAlgebra eq_TArrowName T (eq_TArrowR D) D}.

  Definition BType_eq_TArrow (R : Set) (rec : R -> eq_TArrowR D)
    (e : BType R) : eq_TArrowR D := (fun _ _ => false, tbool' D).

  Global Instance MAlgebra_eq_TArrow_BType T:
    FAlgebra eq_TArrowName T (eq_TArrowR D) BType | 4 :=
      {| f_algebra := BType_eq_TArrow T|}.

  Context {WF_TArrow_eq_DT : forall T, @WF_FAlgebra eq_TArrowName T _ _ _
    Sub_BType_D (MAlgebra_eq_TArrow_BType T) (eq_TArrow_D _)}.

  Global Instance PAlgebra_eq_TArrow_eq_BType :
    PAlgebra eq_TArrow_eqName (sig (UP'_P (eq_TArrow_eq_P D))) BType.
  Proof.
    constructor; unfold Algebra; intros.
    eapply ind_alg_BType.
    unfold UP'_P; econstructor.
    unfold eq_TArrow_eq_P; intros.
    unfold eq_DType, mfold, tbool, tbool', inject' in H; simpl in H;
      repeat rewrite wf_functor in H; simpl in H; unfold in_t in H.
    simpl.
    unfold eq_TArrow, mfold, tbool; simpl; rewrite wf_functor; simpl;
      unfold in_t at 1; simpl; unfold BType_fmap.
    rewrite (wf_algebra (WF_FAlgebra := WF_TArrow_eq_DT _)); simpl.
    rewrite wf_functor; simpl; unfold BType_fmap; split; auto.
    simpl; intros.
    unfold in_t in H0; rewrite (wf_algebra (WF_FAlgebra := WF_TArrow_eq_DT _)) in H0;
      simpl in H0; discriminate.
    exact H.
  Defined.

  Global Instance WF_BType_eq_TArrow_eq
    {Sub_BType_D' : BType :<: D} :
    (forall a, inj (Sub_Functor := Sub_BType_D) a =
      inj (A := Fix D) (Sub_Functor := Sub_BType_D') a) ->
    WF_Ind (sub_F_E := Sub_BType_D') PAlgebra_eq_TArrow_eq_BType.
  Proof.
    constructor; destruct e; simpl; intros.
    unfold tbool, tbool'; simpl; rewrite wf_functor; simpl;
      unfold BType_fmap; auto.
    rewrite H; reflexivity.
  Defined.

  Variable E : Set -> Set -> Set.
  Context {Fun_E : forall A, Functor (E A)}.
  Context {Sub_Bool_E : forall A, Bool :<: (E A)}.
  Context {Typeof_F : forall T, FAlgebra TypeofName T (typeofR D) (E (typeofR D))}.
  Variable EQV_E : forall A B, (eqv_i E A B -> Prop) -> eqv_i E A B -> Prop.
  Context {funEQV_E : forall A B, iFunctor (EQV_E A B)}.

  Variable V : Set -> Set.
  Context {Fun_V : Functor V}.
  Context {Sub_BoolValue_V : BoolValue :<: V}.
  Context {Sub_BotValue_V : BotValue :<: V}.
  Context {Sub_ClosValue_V : ClosValue E :<: V}.
  Context {Sub_StuckValue_V : StuckValue :<: V}.
  Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop.
  Context {funWFV : iFunctor WFV}.

  Context {Sub_WFV_VB_WFV : Sub_iFunctor (WFValue_VB D V) WFV}.
  Context {Sub_WFV_Bot_WFV : Sub_iFunctor (WFValue_Bot D V) WFV}.
  Context {Dis_Clos_Bot : Distinct_Sub_Functor LType BType D}.

  Context {Dis_VB_Clos : Distinct_Sub_Functor BoolValue (ClosValue E) V}.
  Context {WF_Sub_ClosValue_V : WF_Functor (ClosValue E) V Sub_ClosValue_V}.
  Context {WF_Sub_BoolValue_V : WF_Functor BoolValue V Sub_BoolValue_V}.

  Global Instance PAlgebra_WF_invertClos_VB typeof_rec :
    iPAlgebra WF_invertClos_Name (WF_invertClos_P D E V EQV_E WFV typeof_rec) (WFValue_VB D V).
  Proof.
    econstructor; intros.
    unfold iAlgebra; intros; unfold WF_invertClos_P.
    inversion H; subst; simpl; intros.
    split.
    apply (inject_i (subGF := Sub_WFV_VB_WFV)); econstructor; eauto.
    intros; rewrite H2 in H1.
    discriminate_inject H1.
  Defined.

  Global Instance PAlgebra_WF_invertClos'_VB typeof_rec :
    iPAlgebra WF_invertClos'_Name (WF_invertClos'_P D E V EQV_E WFV typeof_rec) (WFValue_VB D V).
  Proof.
    econstructor; intros.
    unfold iAlgebra; intros; unfold WF_invertClos_P.
    inversion H; subst; simpl; intros.
    split.
    apply (inject_i (subGF := Sub_WFV_VB_WFV)); econstructor; eauto.
    simpl in *|-*; intros; rewrite H2 in H0.
    discriminate_inject H0.
  Defined.

  (* ============================================== *)
  (* EQUIVALENCE OF BOOLEAN EXPRESSIONS             *)
  (* ============================================== *)

  Inductive Bool_eqv (A B : Set) (C : eqv_i E A B -> Prop) : eqv_i E A B -> Prop :=
  | BLit_eqv : forall (gamma : Env _) gamma' n e e',
    proj1_sig e = blit (E A) n ->
    proj1_sig e' = blit (E B) n ->
    Bool_eqv A B C (mk_eqv_i _ _ _ gamma gamma' e e')
  | If_eqv : forall (gamma : Env _) gamma' i t el i' t' el' e e',
    C (mk_eqv_i _ _ _ gamma gamma' i i') ->
    C (mk_eqv_i _ _ _ gamma gamma' t t') ->
    C (mk_eqv_i _ _ _ gamma gamma' el el') ->
    proj1_sig e = proj1_sig (cond' _ i t el) ->
    proj1_sig e' = proj1_sig (cond' _ i' t' el') ->
    Bool_eqv A B C (mk_eqv_i _ _ _ gamma gamma' e e').

  Lemma Bool_eqv_impl_NP_eqv : forall A B C i,
    Bool_eqv A B C i -> NP_Functor_eqv E Bool A B C i.
  Proof.
    intros; destruct H.
    unfold blit, blit in *; simpl in *.
    constructor 1 with (np := fun D => BLit D n); auto.
    econstructor 4 with (np := fun D => If D); eauto.
    simpl; congruence.
  Defined.

End PLambda_Bool.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Export MicroBFTprops2.
Require Export MicroBFTsame.
Require Export MicroBFTass_mon.
Require Export MicroBFTass_tlearn.
Require Export MicroBFTass_uniq.
Require Export MicroBFTass_new.
Require Export MicroBFTass_tknew.
Require Export ComponentAxiom.

Section MicroBFTagreement.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext          }.
  Context { microbft_context    : MicroBFT_context      }.
  Context { m_initial_keys      : MicroBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys     }.
  Context { usig_hash           : USIG_hash             }.
  Context { microbft_auth       : MicroBFT_auth         }.

  Lemma not_primary_implies :
    forall {eo : EventOrdering} (e : Event),
      not_primary (loc e) = true
      -> loc e = MicroBFT_backup1 \/ loc e = MicroBFT_backup2.
  Proof.
    introv h; unfold not_primary, is_primary in h; smash_microbft.
    remember (loc e) as q; destruct q; tcsp.
  Qed.
  Hint Resolve not_primary_implies : microbft.

  Lemma agreement :
    forall (eo : EventOrdering) (e1 e2 : Event) (r1 r2 : nat) i l1 l2,
      AXIOM_authenticated_messages_were_sent_or_byz eo MicroBFTsys
      -> In (send_accept (accept r1 i) l1) (M_output_sys_on_event MicroBFTsys e1)
      -> In (send_accept (accept r2 i) l2) (M_output_sys_on_event MicroBFTsys e2)
      -> r1 = r2.
  Proof.
    introv sendbyz send1 send2.

    unfold M_output_sys_on_event in send1.
    unfold M_output_sys_on_event in send2.

    applydup @accepted_counter_if_know_UI_primary in send1 as statea.
    applydup @accepted_counter_if_know_UI_primary in send2 as stateb.
    exrepnd.

    applydup M_run_ls_on_event_MicroBFT_to_compoments in statea1; repnd; auto;[].
    applydup M_run_ls_on_event_MicroBFT_to_compoments in stateb1; repnd; auto;[].

    pose proof (request_was_verified e1 s4 s3 rq0) as ka.
    repeat (autodimp ka hyp); try (complete (eexists; eauto)); exrepnd; eauto 3 with microbft;[].

    pose proof (request_was_verified e2 s2 s1 rq) as kb.
    repeat (autodimp kb hyp); try (complete (eexists; eauto)); exrepnd; eauto 3 with microbft;[].

    assert (ex_node_e e1) as ex1 by (unfold ex_node_e; allrw; simpl; eauto).
    assert (ex_node_e e2) as ex2 by (unfold ex_node_e; allrw; simpl; eauto).

    pose proof (DERIVED_RULE_trusted_knowledge_unique3_ex_true
                  (MkEventN e1 ex1) (MkEventN e2 ex2) (MkEventN e2 ex2)
                  [] []
                  (MicroBFT_primary)
                  ui0
                  ui
                  (ui2counter ui0)
                  (ui2counter ui)
                  (microbft_data_rdata rq0)
                  (microbft_data_rdata rq)) as knc.
    unfold rule_true in knc; simpl in knc.
    repeat (autodimp knc hyp); eauto 2 with microbft;[|].

    { Opaque ASSUMPTION_trusted_learns_if_gen.
      Opaque ASSUMPTION_trusted_knew_or_learns_or_gen.
      Opaque ASSUMPTION_monotonicity.
      Opaque ASSUMPTION_generates_new_ex.
      Opaque ASSUMPTION_disseminate_unique.
      introv vt vd vc vn xx yy zz.
      induction es using Vector.caseS'; simpl in *.
      clear vt vd vc vn es.
      repndors; subst; unfold seq_concl, seq_event in *;
        simpl in *; introv; simpl in *; microbft_simp; tcsp;
          try (complete (apply ASSUMPTION_trusted_learns_if_gen_true; auto; destruct h0; auto));
          try (complete (apply ASSUMPTION_trusted_knew_or_learns_or_gen_true; auto; destruct h0; auto));
          try (complete (apply ASSUMPTION_monotonicity_true; auto; destruct h0; auto));
          try (complete (apply ASSUMPTION_disseminate_unique_true; auto; destruct h0; auto));
          try (complete (apply ASSUMPTION_generates_new_true; auto; destruct h0; auto));
          try (complete (unfold ui_has_counter in *; subst; simpl in *; auto));
          try (complete (eexists; simpl;allrw; simpl; eauto));
          try (complete (repeat (eexists; dands; eauto)));
          try (complete (dands; tcsp; erewrite state_usig_same_keys in ka; eauto));
          try (complete (dands; tcsp; erewrite state_usig_same_keys in kb; eauto)). }

    unfold sequent_true in knc; simpl in knc; repeat (autodimp knc hyp); tcsp;[].
    inversion knc; subst; subst; auto.
  Qed.

End MicroBFTagreement.


Require Import Coq.Strings.String.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.NArith.BinNat.
Require Import Poulet4.P4light.Syntax.Typed.
Require Import Poulet4.P4light.Syntax.Syntax.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import Poulet4.P4light.Syntax.Value.
Require Import ProD3.core.Coqlib.
Require Import ProD3.core.Hoare.
Require Import ProD3.core.SvalRefine.
Require Import ProD3.core.ExtPred.
Require Import ProD3.core.AssertionLang.
Require Import ProD3.core.AssertionNotations.
Require Import ProD3.core.Implies.
Require Import Hammer.Plugin.Hammer.
Open Scope type_scope.

Section ExtExtract.

Context {tags_t: Type} {tags_t_inhabitant : Inhabitant tags_t}.
Notation Val := (@ValueBase bool).
Notation Sval := (@ValueBase (option bool)).
Notation Lval := ValueLvalue.

Notation ident := (string).
Notation path := (list ident).
Notation P4Int := (P4Int.t tags_t).
Notation P4String := (P4String.t tags_t).
Notation P4Type := (@P4Type tags_t).
Notation mem := Semantics.mem.

Context {target : @Target tags_t (@Expression tags_t)}.

Fixpoint replace_nth {A} (n : nat) (al : list A) (x : A) {struct n} : list A :=
  match n, al with
  | O, a :: al => x :: al
  | S n', a :: al' => a :: replace_nth n' al' x
  | _, nil => nil
  end.

Lemma extract_nth_ext_ex : forall n a_ext {A} (S : A -> ext_pred) ep H,
  nth n a_ext (ExtPred.prop True) = (ExtPred.ex S ep H) ->
  EXT a_ext =
    (fun es => exists x, EXT (replace_nth n a_ext (S x)) es).
Proof.
  intros.
  f_equal.
  clear -H0.
  generalize dependent n; induction a_ext; intros.
  + extensionality es.
    apply prop_ext.
    split; only 2 : hauto lq: on.
    intros _.
    replace (nth n [] (ExtPred.prop True)) with (ExtPred.prop True) in H0. 2 : {
      destruct n; auto.
    }
    assert (exists x, S x es). {
      change (ExtPred.ex S ep H es).
      rewrite <- H0.
      exact I.
    }
    destruct H1 as [x ?].
    exists x. unfold replace_nth; destruct n;
      (* sauto q: on should solve it, but it has some bug. *)
      cbn; auto.
  + destruct n.
    * simpl in H0. rewrite H0.
      clear.
      extensionality es.
      apply prop_ext.
      simpl. (* hammer should solve here. *)
      split; intros.
      --destruct H0.
        destruct H0.
        sfirstorder.
      --destruct H0.
        destruct H0.
        split; sfirstorder.
    * specialize (IHa_ext _ H0).
      change (EXT (a :: a_ext)) with (fun es => a es /\ EXT a_ext es).
      rewrite IHa_ext.
      clear.
      extensionality es.
      apply prop_ext.
      simpl. fcrush.
Qed.

Lemma extract_nth_ext_ex' : forall n a_mem a_ext A (S : A -> ext_pred) ep H,
  nth n a_ext (ExtPred.prop True) = (ExtPred.ex S ep H) ->
  MEM a_mem (EXT a_ext) =
    (EX (x : A), MEM a_mem (EXT (replace_nth n a_ext (S x))))%assr.
Proof.
  intros.
  erewrite extract_nth_ext_ex; eauto.
  clear.
  extensionality st.
  apply prop_ext.
  (* hammer should solve here *)
  split; intros.
  - destruct st.
    destruct H.
    destruct H0.
    sfirstorder.
  - destruct st.
    destruct H.
    sfirstorder.
Qed.

Lemma extract_nth_ext_ex_ext_implies_pre : forall n a_ext post A (S : A -> ext_pred) ep H,
  nth n a_ext (ExtPred.prop True) = (ExtPred.ex S ep H) ->
  (forall x, ext_implies (replace_nth n a_ext (S x)) post) ->
  ext_implies a_ext post.
Proof.
  intros.
  unfold ext_implies in *.
  change ext_denote with EXT in *.
  erewrite extract_nth_ext_ex with (a_ext := a_ext) by eauto.
  intros.
  destruct H2.
  eauto.
Qed.

Lemma extract_nth_ext_ex_ext_implies_post : forall n pre a_ext A (S : A -> ext_pred) ep H,
  nth n a_ext (ExtPred.prop True) = (ExtPred.ex S ep H) ->
  (exists x, ext_implies pre (replace_nth n a_ext (S x))) ->
  ext_implies pre a_ext.
Proof.
  intros.
  destruct H1.
  unfold ext_implies in *.
  change ext_denote with EXT in *.
  erewrite extract_nth_ext_ex with (a_ext := a_ext) by eauto.
  eauto.
Qed.

Fixpoint remove_nth {A} (n : nat) (al : list A) {struct n} : list A :=
  match n, al with
  | O, a :: al => al
  | S n', a :: al' => a :: remove_nth n' al'
  | _, nil => nil
  end.

Lemma extract_nth_ext_prop : forall n a_ext (S : Prop),
  nth n a_ext (ExtPred.prop True) = (ExtPred.prop S) ->
  ext_assertion_equiv a_ext (ExtPred.prop S :: remove_nth n a_ext).
Proof.
  intros.
  generalize dependent n; induction a_ext; intros.
  + replace (nth n [] (ExtPred.prop True)) with (ExtPred.prop True) in H. 2 : {
      destruct n; auto.
    }
    rewrite <- H.
    hnf.
    extensionality es.
    apply prop_ext.
    cbn. (* sauto lq: on. *)
    replace (remove_nth n []) with (@nil ext_pred). 2 : {
      destruct n; auto.
    }
    split; auto.
  + destruct n.
    * simpl in H. rewrite H.
      clear.
      reflexivity.
    * specialize (IHa_ext _ H).
      unfold ext_assertion_equiv in *.
      cbn.
      change (ext_denote (a :: a_ext)) with (fun es => a es /\ ext_denote a_ext es).
      rewrite IHa_ext.
      clear.
      extensionality es.
      apply prop_ext.
      fcrush.
Qed.

Lemma ext_implies_pre_prop : forall (P : Prop) pre_ext post_ext,
  (P -> ext_implies pre_ext post_ext) ->
  ext_implies (ExtPred.prop P :: pre_ext) post_ext.
Proof.
  unfold ext_implies.
  intros.
  destruct H0.
  eauto.
Qed.

Lemma hoare_block_pre_ext_prop : forall ge p (P : Prop) pre_mem pre_ext stmt post,
  (P -> hoare_block ge p (MEM pre_mem (EXT pre_ext)) stmt post) ->
  hoare_block ge p (MEM pre_mem (EXT (ExtPred.prop P :: pre_ext))) stmt post.
Proof.
  unfold hoare_block; intros.
  destruct st.
  destruct H0, H2.
  eapply H; try eassumption.
  split; eassumption.
Qed.

Lemma hoare_func_pre_ext_prop : forall ge p (P : Prop) pre_arg pre_mem pre_ext func targs post,
  (P -> hoare_func ge p (ARG pre_arg (MEM pre_mem (EXT pre_ext))) func targs post) ->
  hoare_func ge p (ARG pre_arg (MEM pre_mem (EXT (ExtPred.prop P :: pre_ext)))) func targs post.
Proof.
  unfold hoare_func; intros.
  destruct st.
  destruct H0, H2, H3.
  eapply H; try eassumption.
  split; only 2 : split; eassumption.
Qed.

Lemma hoare_block_assert_Prop : forall ge p pre_mem pre_ext stmt post P,
  ext_implies pre_ext [ExtPred.prop P] ->
  (P -> hoare_block ge p (MEM pre_mem (EXT pre_ext)) stmt post) ->
  hoare_block ge p (MEM pre_mem (EXT pre_ext)) stmt post.
Proof.
  unfold hoare_block; intros.
  assert P. {
    destruct st as [m es].
    destruct H1.
    specialize (H es ltac:(eauto)).
    exact (proj1 H).
  }
  eauto.
Qed.

Lemma ext_implies_assert_Prop : forall pre_ext post_ext P,
  ext_implies pre_ext [ExtPred.prop P] ->
  (P -> ext_implies pre_ext post_ext) ->
  ext_implies pre_ext post_ext.
Proof.
  unfold ext_implies; intros.
  assert P. {
    specialize (H es ltac:(eauto)).
    exact (proj1 H).
  }
  eauto.
Qed.

End ExtExtract.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

Set Implicit Arguments.

Require Import ZArith.
Require Import BigNumPrelude.
Require Import DoubleType.
Require Import DoubleBase.

Local Open Scope Z_scope.

Section DoubleSub.
 Variable w : Type.
 Variable w_0 : w.
 Variable w_Bm1 : w.
 Variable w_WW : w -> w -> zn2z w.
 Variable ww_Bm1 : zn2z w.
 Variable w_opp_c : w -> carry w.
 Variable w_opp_carry : w -> w.
 Variable w_pred_c : w -> carry w.
 Variable w_sub_c : w -> w -> carry w.
 Variable w_sub_carry_c : w -> w -> carry w.
 Variable w_opp : w -> w.
 Variable w_pred : w -> w.
 Variable w_sub : w -> w -> w.
 Variable w_sub_carry : w -> w -> w.

 (* ** Opposites ** *)
 Definition ww_opp_c x :=
  match x with
  | W0 => C0 W0
  | WW xh xl =>
    match w_opp_c xl with
    | C0 _ =>
      match w_opp_c xh with
      | C0 h => C0 W0
      | C1 h => C1 (WW h w_0)
      end
    | C1 l => C1 (WW (w_opp_carry xh) l)
    end
  end.

 Definition ww_opp x :=
  match x with
  | W0 => W0
  | WW xh xl =>
    match w_opp_c xl with
    | C0 _ => WW (w_opp xh) w_0
    | C1 l => WW (w_opp_carry xh) l
    end
  end.

 Definition ww_opp_carry x :=
  match x with
  | W0 => ww_Bm1
  | WW xh xl => w_WW (w_opp_carry xh) (w_opp_carry xl)
  end.

 Definition ww_pred_c x :=
  match x with
  | W0 => C1 ww_Bm1
  | WW xh xl =>
    match w_pred_c xl with
    | C0 l => C0 (w_WW xh l)
    | C1 _ =>
      match w_pred_c xh with
      | C0 h => C0 (WW h w_Bm1)
      | C1 _ => C1 ww_Bm1
      end
    end
  end.

 Definition ww_pred x :=
  match x with
  | W0 => ww_Bm1
  | WW xh xl =>
    match w_pred_c xl with
    | C0 l => w_WW xh l
    | C1 l => WW (w_pred xh) w_Bm1
    end
  end.

 Definition ww_sub_c x y :=
  match y, x with
  | W0, _ => C0 x
  | WW yh yl, W0 => ww_opp_c (WW yh yl)
  | WW yh yl, WW xh xl =>
    match w_sub_c xl yl with
    | C0 l =>
      match w_sub_c xh yh with
      | C0 h => C0 (w_WW h l)
      | C1 h => C1 (WW h l)
      end
    | C1 l =>
      match w_sub_carry_c xh yh with
      | C0 h => C0 (WW h l)
      | C1 h => C1 (WW h l)
      end
    end
  end.

 Definition ww_sub x y :=
  match y, x with
  | W0, _ => x
  | WW yh yl, W0 => ww_opp (WW yh yl)
  | WW yh yl, WW xh xl =>
    match w_sub_c xl yl with
    | C0 l => w_WW (w_sub xh yh) l
    | C1 l => WW (w_sub_carry xh yh) l
    end
  end.

 Definition ww_sub_carry_c x y :=
  match y, x with
  | W0, W0 => C1 ww_Bm1
  | W0, WW xh xl => ww_pred_c (WW xh xl)
  | WW yh yl, W0 => C1 (ww_opp_carry (WW yh yl))
  | WW yh yl, WW xh xl =>
    match w_sub_carry_c xl yl with
    | C0 l =>
      match w_sub_c xh yh with
      | C0 h => C0 (w_WW h l)
      | C1 h => C1 (WW h l)
      end
    | C1 l =>
      match w_sub_carry_c xh yh with
      | C0 h => C0 (w_WW h l)
      | C1 h => C1 (w_WW h l)
      end
    end
  end.

 Definition ww_sub_carry x y :=
  match y, x with
  | W0, W0 => ww_Bm1
  | W0, WW xh xl => ww_pred (WW xh xl)
  | WW yh yl, W0 => ww_opp_carry (WW yh yl)
  | WW yh yl, WW xh xl =>
    match w_sub_carry_c xl yl with
    | C0 l => w_WW (w_sub xh yh) l
    | C1 l => w_WW (w_sub_carry xh yh) l
    end
  end.

 (*Section DoubleProof.*)
  Variable w_digits : positive.
  Variable w_to_Z : w -> Z.

  Notation wB  := (base w_digits).
  Notation wwB := (base (ww_digits w_digits)).
  Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
  Notation "[+| c |]" :=
   (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99).
  Notation "[-| c |]" :=
   (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99).

  Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
  Notation "[+[ c ]]" :=
   (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c)
   (at level 0, c at level 99).
  Notation "[-[ c ]]" :=
   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
   (at level 0, c at level 99).

  Variable spec_w_0   : [|w_0|] = 0.
  Variable spec_w_Bm1   : [|w_Bm1|] = wB - 1.
  Variable spec_ww_Bm1   : [[ww_Bm1]] = wwB - 1.
  Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.
  Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|].

  Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|].
  Variable spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB.
  Variable spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1.

  Variable spec_pred_c : forall x, [-|w_pred_c x|] = [|x|] - 1.
  Variable spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|].
  Variable spec_sub_carry_c :
   forall x y, [-|w_sub_carry_c x y|] = [|x|] - [|y|] - 1.

  Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB.
  Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB.
  Variable spec_sub_carry :
	 forall x y, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB.

  Lemma spec_ww_opp_c : forall x, [-[ww_opp_c x]] = -[[x]].
  Proof.
   destruct x as [ |xh xl];simpl. reflexivity.
   rewrite Z.opp_add_distr;generalize (spec_opp_c xl);destruct (w_opp_c xl)
   as [l|l];intros H;unfold interp_carry in H;rewrite <- H;
   rewrite <- Z.mul_opp_l.
   assert ([|l|] = 0).
    assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega.
   rewrite H0;generalize (spec_opp_c xh);destruct (w_opp_c xh)
   as [h|h];intros H1;unfold interp_carry in *;rewrite <- H1.
   assert ([|h|] = 0).
    assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega.
   rewrite H2;reflexivity.
   simpl ww_to_Z;rewrite wwB_wBwB;rewrite spec_w_0;ring.
   unfold interp_carry;simpl ww_to_Z;rewrite wwB_wBwB;rewrite spec_opp_carry;
   ring.
  Qed.

  Lemma spec_ww_opp : forall x, [[ww_opp x]] = (-[[x]]) mod wwB.
  Proof.
   destruct x as [ |xh xl];simpl. reflexivity.
   rewrite Z.opp_add_distr, <- Z.mul_opp_l.
   generalize (spec_opp_c xl);destruct (w_opp_c xl)
   as [l|l];intros H;unfold interp_carry in H;rewrite <- H;simpl ww_to_Z.
   rewrite spec_w_0;rewrite Z.add_0_r;rewrite wwB_wBwB.
   assert ([|l|] = 0).
    assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega.
   rewrite H0;rewrite Z.add_0_r; rewrite Z.pow_2_r;
    rewrite Zmult_mod_distr_r;try apply lt_0_wB.
   rewrite spec_opp;trivial.
   apply Zmod_unique with (q:= -1).
   exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW (w_opp_carry xh) l)).
   rewrite spec_opp_carry;rewrite wwB_wBwB;ring.
  Qed.

  Lemma spec_ww_opp_carry : forall x, [[ww_opp_carry x]] = wwB - [[x]] - 1.
  Proof.
   destruct x as [ |xh xl];simpl. rewrite spec_ww_Bm1;ring.
   rewrite spec_w_WW;simpl;repeat rewrite spec_opp_carry;rewrite wwB_wBwB;ring.
  Qed.

  Lemma spec_ww_pred_c : forall x, [-[ww_pred_c x]] = [[x]] - 1.
  Proof.
   destruct x as [ |xh xl];unfold ww_pred_c.
   unfold interp_carry;rewrite spec_ww_Bm1;simpl ww_to_Z;ring.
   simpl ww_to_Z;replace (([|xh|]*wB+[|xl|])-1) with ([|xh|]*wB+([|xl|]-1)).
   2:ring. generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l];
   intros H;unfold interp_carry in H;rewrite <- H. simpl;apply spec_w_WW.
   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
   assert ([|l|] = wB - 1).
     assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega.
   rewrite H0;change ([|xh|] + -1) with ([|xh|] - 1).
   generalize (spec_pred_c xh);destruct (w_pred_c xh) as [h|h];
   intros H1;unfold interp_carry in H1;rewrite <- H1.
   simpl;rewrite spec_w_Bm1;ring.
   assert ([|h|] = wB - 1).
     assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega.
   rewrite H2;unfold interp_carry;rewrite spec_ww_Bm1;rewrite wwB_wBwB;ring.
  Qed.

  Lemma spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]].
  Proof.
   destruct y as [ |yh yl];simpl. ring.
   destruct x as [ |xh xl];simpl. exact (spec_ww_opp_c (WW yh yl)).
   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]))
   with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|])). 2:ring.
   generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl) as [l|l];intros H;
   unfold interp_carry in H;rewrite <- H.
   generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1;
   unfold interp_carry in H1;rewrite <- H1;unfold interp_carry;
   try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring.
   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
   change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1).
   generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h];
   intros H1;unfold interp_carry in *;rewrite <- H1;simpl ww_to_Z;
   try rewrite wwB_wBwB;ring.
  Qed.

  Lemma spec_ww_sub_carry_c :
     forall x y, [-[ww_sub_carry_c x y]] = [[x]] - [[y]] - 1.
  Proof.
   destruct y as [ |yh yl];simpl.
   unfold Z.sub;simpl;rewrite Z.add_0_r;exact (spec_ww_pred_c x).
   destruct x as [ |xh xl].
   unfold interp_carry;rewrite spec_w_WW;simpl ww_to_Z;rewrite wwB_wBwB;
   repeat rewrite spec_opp_carry;ring.
   simpl ww_to_Z.
   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1)
   with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|]-1)). 2:ring.
   generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl)
   as [l|l];intros H;unfold interp_carry in H;rewrite <- H.
   generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1;
   unfold interp_carry in H1;rewrite <- H1;unfold interp_carry;
   try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring.
   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
   change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1).
   generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h];
   intros H1;unfold interp_carry in *;rewrite <- H1;try rewrite spec_w_WW;
   simpl ww_to_Z; try rewrite wwB_wBwB;ring.
  Qed.

  Lemma spec_ww_pred : forall x, [[ww_pred x]] = ([[x]] - 1) mod wwB.
  Proof.
   destruct x as [ |xh xl];simpl.
   apply Zmod_unique with (-1). apply spec_ww_to_Z;trivial.
   rewrite spec_ww_Bm1;ring.
   replace ([|xh|]*wB + [|xl|] - 1) with ([|xh|]*wB + ([|xl|] - 1)). 2:ring.
   generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l];intro H;
   unfold interp_carry in H;rewrite <- H;simpl ww_to_Z.
   rewrite Zmod_small. apply spec_w_WW.
   exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh l)).
   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
   change ([|xh|] + -1) with ([|xh|] - 1).
   assert ([|l|] = wB - 1).
    assert (H1:= spec_to_Z l);assert (H2:= spec_to_Z xl);omega.
   rewrite (mod_wwB w_digits w_to_Z);trivial.
   rewrite spec_pred;rewrite spec_w_Bm1;rewrite <- H0;trivial.
  Qed.

  Lemma spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB.
  Proof.
   destruct y as [ |yh yl];simpl.
   ring_simplify ([[x]] - 0);rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial.
   destruct x as [ |xh xl];simpl. exact (spec_ww_opp (WW yh yl)).
   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]))
   with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|])). 2:ring.
   generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl)as[l|l];intros H;
   unfold interp_carry in H;rewrite <- H.
   rewrite spec_w_WW;rewrite (mod_wwB w_digits w_to_Z spec_to_Z).
   rewrite spec_sub;trivial.
   simpl ww_to_Z;rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
   rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial.
  Qed.

  Lemma spec_ww_sub_carry :
	 forall x y, [[ww_sub_carry x y]] = ([[x]] - [[y]] - 1) mod wwB.
  Proof.
   destruct y as [ |yh yl];simpl.
   ring_simplify ([[x]] - 0);exact (spec_ww_pred x).
   destruct x as [ |xh xl];simpl.
   apply Zmod_unique with (-1).
   apply spec_ww_to_Z;trivial.
   fold (ww_opp_carry (WW yh yl)).
   rewrite (spec_ww_opp_carry (WW yh yl));simpl ww_to_Z;ring.
   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1)
   with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|] - 1)). 2:ring.
   generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl)as[l|l];
   intros H;unfold interp_carry in H;rewrite <- H;rewrite spec_w_WW.
   rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub;trivial.
   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
   rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial.
  Qed.

(* End DoubleProof. *)

End DoubleSub.


Require Import
        Fiat.Narcissus.Common.Specs.

Require Export
        Fiat.Narcissus.Formats.Base.SequenceFormat
        Fiat.Narcissus.Formats.Base.FMapFormat
        Fiat.Narcissus.Formats.Base.StrictTerminalFormat
        Fiat.Narcissus.Formats.Base.LaxTerminalFormat
        Fiat.Narcissus.Formats.Base.FixFormat
        Fiat.Narcissus.Formats.Base.EnqueueFormat
        Fiat.Narcissus.Formats.Base.UnionFormat.

(* Aliases of Correct Decoder for deriving partial views of data. *)
Definition CorrectRefinedDecoder
           {S T : Type}
           {store : Cache}
           {V : Type}
           (monoid : Monoid T)
           (Source_Predicate : S -> Prop)
           (View_Predicate : V -> Prop)
           (view : S -> V -> Prop)
           (format subformat : FormatM S T)
           (decode : T -> CacheDecode -> option (V * T * CacheDecode))
           (decode_inv : CacheDecode -> Prop)
           (view_format : V -> CacheFormat -> Comp (T * CacheFormat)) :=
  CorrectDecoder monoid Source_Predicate View_Predicate view
                 subformat decode decode_inv
                 (fun v env t =>
                    view_format v env t
                    /\ forall s,
                      Source_Predicate s ->
                        subformat s env ∋ t
                        -> view s v).
Definition Prefix_Format
           {S T : Type}
           {store : Cache}
           (monoid : Monoid T)
           (format subformat : FormatM S T)
  := forall s t env env',
    format s env ∋ (t, env') ->
    exists t1 t2 env'',
      t = mappend t1 t2
      /\ subformat s env ∋ (t1, env'').

(*Lemma  CorrectRefinedDecoder_decode_partial
       {S T : Type}
       {store : Cache}
       {V : Type}
       (monoid' : Monoid T)
       (Source_Predicate : S -> Prop)
       (View_Predicate : V -> Prop)
       (view : S -> V -> Prop)
       (format subformat : FormatM S T)
       (decode : T -> CacheDecode -> option (V * T * CacheDecode))
       (decode_inv : CacheDecode -> Prop)
       (view_format : V -> CacheFormat -> Comp (T * CacheFormat))
  : CorrectRefinedDecoder monoid' Source_Predicate View_Predicate view
                          format subformat decode decode_inv view_format
    -> forall s t env env',
      format s env ∋ (t, env') ->
      exists t1 t2 env'',
        t = mappend t1 t2 /\
        subformat s env ∋ (t1, env'').
Proof.
  intro.
  eapply H; eauto.
  (* apply proj2 in H. *)
  (* eapply H. *)
  (* eapply H in H0. *)

  (* intros [? [? ?] ] * ?. *)
  (* eapply H0 in H1. *)
  (* unfold sequence_Format, ComposeOpt.compose, Bind2 in H1. *)
  (* computes_to_inv; destruct v; destruct v0; simpl in *; eauto. *)
  (* injections. *)
  (* eexists _, _, _; intuition eauto. *)
Qed. *)

Lemma CorrectRefinedDecoder_decode_impl
       {S T : Type}
       {store : Cache}
       (monoid' : Monoid T)
       (Source_Predicate : S -> Prop)
       (format : FormatM S T)
       (decode : T -> CacheDecode -> option (S * T * CacheDecode))
       (decode_inv : CacheDecode -> Prop)
  : CorrectRefinedDecoder monoid' Source_Predicate Source_Predicate eq
                          format format decode decode_inv format
    -> CorrectDecoder monoid' Source_Predicate Source_Predicate eq
                      format decode decode_inv format.
Proof.
  intros.
  eapply weaken_view_pred.
  intros; subst; eauto.
  2: apply H.
  intros.
  simpl in H1; intuition eauto.
Qed.

Add Parametric Morphism
    S T V
    (cache : Cache)
    (monoid : Monoid T)
    (Source_Predicate : S -> Prop)
    (View_Predicate : V -> Prop)
    (view : S -> V -> Prop)
    (decode : DecodeM (V * T) T)
    (decode_inv : CacheDecode -> Prop)
    (subformat : FormatM S T)
    (view_format : FormatM V T)
  : (fun format =>
       @CorrectRefinedDecoder S T cache V monoid Source_Predicate View_Predicate
                       view format subformat decode decode_inv view_format)
    with signature (EquivFormat --> impl)
      as format_decode_refined_correct_refineEquiv.
Proof.
  unfold EquivFormat, impl, pointwise_relation; intros.
  - unfold CorrectRefinedDecoder in *.
    apply H0.
Qed.

Add Parametric Morphism
    {S T : Type}
    {cache : Cache}
    (monoid : Monoid T)
  : (fun format subformat =>
       @Prefix_Format S T cache monoid format subformat)
    with signature (EquivFormat --> EquivFormat --> impl)
      as prefix_format_refineEquiv.
Proof.
  unfold EquivFormat, impl, pointwise_relation; unfold Prefix_Format; intros.
  edestruct H1. apply H. eauto. destruct_conjs.
  eexists _, _, _. intuition eauto. apply H0. eauto.
Qed.


Require Export compcert.lib.Coqlib.
Require Export msl.seplog.
Require Export msl.log_normalize.
Require Export msl.ramification_lemmas.
Require Export Coq.Logic.JMeq.

Parameter ident: Type.
Parameter ident_eq: forall (a b: ident), {a = b} + {a <> b}.
Parameter val: Type.
Parameter Vundef: val.

Inductive type: Type :=
| Tint: type
| Tstruct: forall (id: ident) (fs: fieldlist), type
with fieldlist: Type :=
| Fnil: fieldlist
| Fcons: forall (hd: ident * type) (tl: fieldlist), fieldlist.

Parameter sizeof: forall (t: type), Z.

Fixpoint in_members (id: ident) (fs: fieldlist) : Prop :=
  match fs with
  | Fnil => False
  | Fcons (id', t) fs_tl => (id = id') \/ in_members id fs_tl
  end.

Fixpoint field_type (id: ident) (fs: fieldlist) : type :=
  match fs with
  | Fnil => Tint (* default return value *)
  | Fcons (id', t) fs_tl =>
      if ident_eq id id'
      then t
      else field_type id fs_tl
  end.

Fixpoint field_offset (id: ident) (fs: fieldlist) : Z :=
  match fs with
  | Fnil => 0 (* default return value *)
  | Fcons (id', t) fs_tl =>
      if ident_eq id id'
      then 0
      else field_offset id fs_tl + sizeof t
  end.

Fixpoint members_no_replicate (fs: fieldlist): Prop :=
  match fs with
  | Fnil => True
  | Fcons (i, t) fs_tl =>
      ~ in_members i fs_tl /\ members_no_replicate fs_tl
  end.

Parameter Pred: Type.
Parameter NPred: NatDed Pred.
Parameter SPred: SepLog Pred.
Parameter CPred: ClassicalSep Pred.
Parameter CSLPred: CorableSepLog Pred.

Parameter mapsto: val -> val -> Pred.
Parameter offset_val: Z -> val -> val.

Axiom offset_offset_val: forall ofs1 ofs2 p, offset_val ofs2 (offset_val ofs1 p) = offset_val (ofs1 + ofs2) p.
(*
Fixpoint sizeof (t: type): Z :=
  match t with
  | Tint => 1
  | Tstruct _ fs => sizeof_fieldlist fs
  end
with sizeof_fieldlist (fs: fieldlist) : Z :=
  match fs with
  | Fnil => 0
  | Fcons (_, t) fs_tl => sizeof t + sizeof_fieldlist fs_tl
  end.

*)


(* TODO: ressurect this file later *)
From iris.base_logic Require Import invariants.
From iris_ni.logrel Require Import types interp.
From iris_ni.program_logic Require Import dwp heap_lang_lifting.
From iris.proofmode Require Import proofmode.
From iris_ni.proofmode Require Import dwp_tactics.
From iris.heap_lang Require Import lang array proofmode.
From iris.algebra Require Import excl.

From iris_ni.examples Require Import lock.

Definition allocator_alloc : val :=
  λ: "arr" "i" "sz" "v",
  let: "pos" := !"i" in
  if: ("sz" ≤ "pos")
  then NONE
  else "i" <- "pos" + #1;;
       let: "c" := "arr" +ₗ "pos" in
       "c" <- "v";;
       SOME "c".

Definition new_allocator : val :=
  λ: "z",
  let: "arr" := AllocN "z" NONE in
  let: "i" := ref #0 in
  let: "lk" := newlock #() in
  (λ: "v", acquire "lk";;
           let: "c" := allocator_alloc "arr" "i" "z" "v" in
           release "lk";; "c").

Section proof.
  Context `{!heapDG Σ, !lockG Σ}.

  Definition aN := nroot.@"allocator".

  Definition allocator_inv l1 l2 i1 i2 sz : iProp Σ :=
    (∃ i : Z, ⌜0 ≤ i ≤ sz⌝ ∗
               (l1 +ₗ i) ↦ₗ∗ replicate (Z.to_nat (sz-i)) NONEV ∗
               (l2 +ₗ i) ↦ᵣ∗ replicate (Z.to_nat (sz-i)) NONEV ∗
               i1 ↦ₗ #i ∗ i2 ↦ᵣ #i)%I.

  Lemma new_allocator_spec (sz : Z) ξ Φ :
    0 < sz →
    (∀ (a1 a2 : val),
        (∀ (α : slevel), ⟦ tarrow (tint α) (toption (tref (tint α))) Low ⟧ ξ a1 a2) -∗
        Φ a1 a2) -∗
    DWP new_allocator #sz & new_allocator #sz : Φ.
  Proof.
    iIntros (Hsz) "H".
    dwp_rec. dwp_pures.
    dwp_bind (AllocN _ _) (AllocN _ _).
    (* allocN spec *)
    set (meta_token1 := @meta_token _ _ _ _ _ heapDG_gen_heapG1).
    set (meta_token2 := @meta_token _ _ _ _ _ heapDG_gen_heapG2).
    pose (Ψ1 := (λ v, ∃ l : loc, ⌜v = #l⌝ ∗ l ↦ₗ∗ replicate (Z.to_nat sz) NONEV ∗
                 ([∗ list] i ∈ seq 0 (Z.to_nat sz), meta_token1 (l +ₗ Z.of_nat i) ⊤))%I).
    pose (Ψ2 := (λ v, ∃ l : loc, ⌜v = #l⌝ ∗ l ↦ᵣ∗ replicate (Z.to_nat sz) NONEV ∗
                 ([∗ list] i ∈ seq 0 (Z.to_nat sz), meta_token2 (l +ₗ Z.of_nat i) ⊤))%I).
    iApply (dwp_atomic_lift_wp Ψ1 Ψ2).
    - iApply twp_allocN; try done.
      iIntros (l) "[Hl Hmeta]". iExists l.
      iSplit; eauto. iSplitL "Hl". iExact "Hl". iFrame.
    - iApply twp_allocN; try done.
      iIntros (l) "[Hl Hmeta]". iExists l.
      iSplit; eauto. iSplitL "Hl". iExact "Hl". iFrame.
    - iIntros (? ?). iDestruct 1 as (l1) "[-> [Hl1 Hmeta1]]".
      iDestruct 1 as (l2) "[-> [Hl2 Hmeta2]]".
      (* / allocN spec *)
      iClear "Hmeta1 Hmeta2".

      iNext. dwp_pures.
      dwp_bind (ref _)%E (ref _)%E.
      iApply dwp_alloc. iIntros (i1 i2) "Hi1 Hi2". iNext. dwp_pures.

      dwp_bind (newlock #()) (newlock #()).
      iApply (newlock_spec aN (allocator_inv l1 l2 i1 i2 sz) with "[Hl1 Hl2 Hi1 Hi2]").
      { iExists 0. rewrite !loc_add_0. assert (sz - 0 = sz) as -> by lia.
        iFrame. iPureIntro. lia. }
      iIntros (γ lk1 lk2) "#Hlk". dwp_pures.

      iApply dwp_value. iModIntro. iApply "H". iIntros (α).
      rewrite interp_eq. iModIntro. iIntros (v1 v2) "#Hv".
      dwp_pures.

      dwp_bind (acquire _)%E (acquire _)%E.
      iApply (acquire_spec with "Hlk"). iIntros "Hlocked".
      iDestruct 1 as (i Hi) "(Hl1&Hl2&Hi1&Hi2)".

      dwp_pures. dwp_rec. dwp_pures.
      dwp_bind (! _)%E (! _)%E. iApply (dwp_load with "Hi1 Hi2").
      iIntros "Hi1 Hi2". iNext. dwp_pures.
      case_bool_decide; dwp_pures.
      + dwp_bind (release _)%E (release _)%E.
        iApply (release_spec with "Hlk Hlocked [Hl1 Hl2 Hi1 Hi2]").
        { iExists i. iSplit. done. iFrame. }
        dwp_pures. iApply logrel_none.
      + dwp_bind (_ <- _)%E (_ <- _)%E.
        iApply (dwp_store with "Hi1 Hi2"). iIntros "Hi1 Hi2".
        iNext. dwp_pures.
        assert (Z.to_nat (sz - i) = S (Z.to_nat (sz - (i + 1)))) as ->.
        { destruct Hi. rewrite -Z2Nat.inj_succ; last by lia.
          f_equal. lia. }
        simpl. rewrite array1_cons array2_cons.
        iDestruct "Hl1" as "[Hcell1 Hl1]".
        iDestruct "Hl2" as "[Hcell2 Hl2]".
        dwp_bind (_ <- _)%E (_ <- _)%E.
        iApply (dwp_store with "Hcell1 Hcell2").
        iIntros "Hcell1 Hcell2". iNext. dwp_pures.

        dwp_bind (release _) (release _).
        iApply (release_spec with "Hlk Hlocked [Hl1 Hl2 Hi1 Hi2]").
        { iExists (i+1). iSplit.
          - iPureIntro; lia.
          - iFrame. rewrite !loc_add_assoc. iFrame. }
        dwp_pures. iApply logrel_some.
        iMod (interp_ref_alloc with "Hcell1 Hcell2 Hv") as "#Hcell".
        iApply dwp_value. eauto.
  Qed.

End proof.


(** * Definition of minimal parse trees *)
Require Import Coq.Strings.String Coq.Lists.List.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.Reachable.MaybeEmpty.Minimal.
Require Import Fiat.Parsers.BaseTypes.

Local Coercion is_true : bool >-> Sortclass.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Section cfg.
  Context {Char} {HSLM : StringLikeMin Char} {G : grammar Char}.
  Context {predata : @parser_computational_predataT Char}
          {rdata' : @parser_removal_dataT' _ G predata}.

  Context (valid0 : nonterminals_listT) (ch : Char).

  Inductive minimal_reachable_from_productions : nonterminals_listT -> productions Char -> Type :=
  | MinReachableHead : forall valid pat pats, minimal_reachable_from_production valid pat
                                              -> minimal_reachable_from_productions valid (pat::pats)
  | MinReachableTail : forall valid pat pats, minimal_reachable_from_productions valid pats
                                              -> minimal_reachable_from_productions valid (pat::pats)
  with minimal_reachable_from_production : nonterminals_listT -> production Char -> Type :=
  | MinReachableProductionHead : forall valid it its, minimal_reachable_from_item valid it
                                                      -> minimal_reachable_from_production valid (it::its)
  | MinReachableProductionTail : forall valid it its, minimal_maybe_empty_item (G := G) valid0 it
                                                      -> minimal_reachable_from_production valid its
                                                      -> minimal_reachable_from_production valid (it::its)
  with minimal_reachable_from_item : nonterminals_listT -> item Char -> Type :=
  | MinReachableTerminal : forall valid P, is_true (P ch) -> minimal_reachable_from_item valid (Terminal P)
  | MinReachableNonTerminal : forall valid nt, is_valid_nonterminal valid (of_nonterminal nt)
                                               -> minimal_reachable_from_productions (remove_nonterminal valid (of_nonterminal nt)) (Lookup G nt)
                                               -> minimal_reachable_from_item valid (NonTerminal nt).

End cfg.


(** * Adjunction **)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Generalizable All Variables.

Set Primitive Projections.
Set Universe Polymorphism.

Require Import COC.Base.Main COC.Cons.Product COC.Adj.Adjunction.

(** naturality of adj_lr **)
Program Definition adj_lr_natrans_1 (C D: Category)(F: C --> D)(G: D --> C)(adj: F -| G)(c: C)
  : Hom(F c, -) ==> (Hom(c, -) \o G) :=
  [d :=> [f :-> adj_lr adj f]].
Next Obligation.
  now intros f g Heq; rewrite Heq.
Qed.
Next Obligation.
  rewrite <- (cat_comp_id_dom (fmap G f \o _)), cat_comp_assoc.
  rewrite <- adj_lr_naturality.
  now rewrite fmap_id, cat_comp_id_dom.
Qed.

Program Definition op_functor (C D: Category)(F: C --> D)
  : C^op --> D^op :=
  [Functor by f :-> fmap F f ].
Next Obligation.
  - now apply fmap_proper.
  - now apply fmap_comp.
  - now apply fmap_id.
Qed.
Notation "F ^opF" := (op_functor F) (at level 0, format "F ^opF").

Program Definition adj_lr_natrans_2 (C D: Category)(F: C --> D)(G: D --> C)(adj: F -| G)(d: D)
  : (Hom(-, d) \o F^opF) ==> Hom(-, G d) :=
  [c :=> [f :-> adj_lr adj f]].
Next Obligation.
  now intros f g Heq; rewrite Heq.
Qed.
Next Obligation.
  rewrite <- (cat_comp_id_cod (_ \o f)).
  rewrite <- fmap_id.
  rewrite <- adj_lr_naturality.
  now rewrite cat_comp_id_cod.
Qed.

(** naturality of adj_lr, adj_rl **)
Program Definition prod_functor (C D C' D': Category)(F: C --> D)(F': C' --> D'): (product_category C C') --> (product_category D D') :=
  [ F \* F' with product_of_Cat].
Notation "[ F 'xF' G ]" := (prod_functor F G).

Program Definition hom_functor (C: Category): (product_category C^op C) --> Setoids :=
  [Functor by fh :-> [ g :-> fh.2 \o{C} g \o{C} fh.1]
   with XY :-> C XY.1 XY.2].
Next Obligation.
  now intros g g' Heq; rewrite Heq.
Qed.
Next Obligation.
  intros f f' [Heqf1 Heqf2] g; simpl.
  - now rewrite Heqf1, Heqf2.
  - now rewrite !cat_comp_assoc.
  - now rewrite cat_comp_id_dom, cat_comp_id_cod.
Qed.
Notation "'HomF' C" := (hom_functor C) (at level 40, no associativity).

(**
#$Hom_D(-,-)\circ F\times Id_D$#
 **)
Definition adj_lrF (C D: Category)(F: C --> D): (product_category C^op D) --> Setoids :=
  hom_functor D \o [F^opF xF (Id D)].

(**
#$Hom_C(-,-)\circ Id_{C^op}\times G$#
 **)
Definition adj_rlF (C D: Category)(G: D --> C): (product_category C^op D) --> Setoids :=
  hom_functor C \o [(Id C^op) xF G].

Program Definition adj_lr_Natrans
        (C D: Category)(F: C --> D)(G: D --> C)(adj: F -| G)
  : (adj_lrF F) ==> (adj_rlF G):=
  [ cd :=> match cd with (c,d) => adj_lr adj (c:=c)(d:=d) end].
Next Obligation.
  destruct Y as [c' d'], X as [c d]; simpl in *.
  now rewrite adj_lr_naturality.
Qed.

Program Definition adj_rl_Natrans
        (C D: Category)(F: C --> D)(G: D --> C)(adj: F -| G)
  : (adj_rlF G) ==> (adj_lrF F):=
  [ cd :=> match cd with (c,d) => adj_rl adj (c:=c)(d:=d) end].
Next Obligation.
  destruct Y as [c' d'], X as [c d]; simpl in *.
  now rewrite adj_rl_naturality.
Qed.