(* Modular Specifications for Concurrent Modules. *)

From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang proofmode notation.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import agree frac frac_auth.

From iris.bi.lib Require Import fractional.

From iris.heap_lang.lib Require Import par.

Definition cntCmra : cmra := prodR fracR (agreeR ZO).

Class cntG Σ := CntG { CntG_inG :> inG Σ cntCmra }.
Definition cntΣ : gFunctors := #[GFunctor cntCmra ].

Instance subG_cntΣ {Σ} : subG cntΣ Σ → cntG Σ.
Proof. solve_inG. Qed.

Definition newcounter : val :=
  λ: "m", ref "m".

Definition read : val := λ: "ℓ", !"ℓ".

Definition incr: val :=
  rec: "incr" "l" :=
     let: "oldv" := !"l" in
     if: CAS "l" "oldv" ("oldv" + #1)
       then "oldv" (* return old value if success *)
       else "incr" "l".

Definition wk_incr : val :=
    λ: "l", let: "n" := !"l" in
            "l" <- "n" + #1.

Section cnt_model.
  Context `{!cntG Σ}.

  Definition makeElem (q : Qp) (m : Z) : cntCmra := (q, to_agree m).
  Typeclasses Opaque makeElem.

  Notation "γ ⤇[ q ] m" := (own γ (makeElem q m))
    (at level 20, q at level 50, format "γ ⤇[ q ]  m") : bi_scope.
  Notation "γ ⤇½ m" := (own γ (makeElem (1/2) m))
    (at level 20, format "γ ⤇½  m") : bi_scope.

  Global Instance makeElem_fractional γ m: Fractional (λ q, γ ⤇[q] m)%I.
  Proof.
    intros p q. rewrite /makeElem.
    rewrite -own_op; f_equiv.
    split; first done.
    by rewrite /= agree_idemp.
  Qed.

  Global Instance makeElem_as_fractional γ m q:
    AsFractional (own γ (makeElem q m)) (λ q, γ ⤇[q] m)%I q.
  Proof.
    split. done. apply _.
  Qed.

  Global Instance makeElem_Exclusive m: Exclusive (makeElem 1 m).
  Proof.
    rewrite /makeElem. intros [y ?] [H _]. apply (exclusive_l _ _ H).
  Qed.

  Lemma makeElem_op p q n:
    makeElem p n ⋅ makeElem q n ≡ makeElem (p + q) n.
  Proof.
    rewrite /makeElem; split; first done.
    by rewrite /= agree_idemp.
  Qed.

  Lemma makeElem_eq γ p q (n m : Z):
    γ ⤇[p] n -∗ γ ⤇[q] m -∗ ⌜n = m⌝.
  Proof.
    iIntros "H1 H2".
    iDestruct (own_valid_2 with "H1 H2") as %HValid.
    destruct HValid as [_ H2].
    iIntros "!%"; by apply to_agree_op_inv_L.
  Qed.

  Lemma makeElem_entail γ p q (n m : Z):
    γ ⤇[p] n -∗ γ ⤇[q] m -∗ γ ⤇[p + q] n.
  Proof.
    iIntros "H1 H2".
    iDestruct (makeElem_eq with "H1 H2") as %->.
    iCombine "H1" "H2" as "H".
    by rewrite makeElem_op.
  Qed.

  Lemma makeElem_update γ (n m k : Z):
    γ ⤇½ n -∗ γ ⤇½ m ==∗ γ ⤇[1] k.
  Proof.
    iIntros "H1 H2".
    iDestruct (makeElem_entail with "H1 H2") as "H".
    rewrite Qp_div_2.
    iApply (own_update with "H"); by apply cmra_update_exclusive.
  Qed.
End cnt_model.

Notation "γ ⤇[ q ] m" := (own γ (makeElem q m))
  (at level 20, q at level 50, format "γ ⤇[ q ]  m") : bi_scope.
Notation "γ ⤇½ m" := (own γ (makeElem (1/2) m))
  (at level 20, format "γ ⤇½  m") : bi_scope.

Section cnt_spec.
  Context `{!heapGS Σ, !cntG Σ} (N : namespace).

  Definition cnt_inv ℓ γ := (∃ (m : Z), ℓ ↦ #m ∗ γ ⤇½ m)%I.

  Definition Cnt (ℓ : loc) (γ : gname) : iProp Σ :=
    inv (N .@ "internal") (cnt_inv ℓ γ).

  Lemma Cnt_alloc (E : coPset) (m : Z) (ℓ : loc):
    (ℓ ↦ #m) ={E}=∗ ∃ γ, Cnt ℓ γ ∗ γ ⤇½ m.
  Proof.
    iIntros "Hpt".
    iMod (own_alloc (makeElem 1 m)) as (γ) "[Hown1 Hown2]"; first done.
    iMod (inv_alloc (N.@ "internal") _ (cnt_inv ℓ γ)%I with "[Hpt Hown1]") as "#HInc".
    { iExists _; iFrame. }
    iModIntro; iExists _; iFrame "# Hown2".
  Qed.

  Theorem newcounter_spec (E : coPset) (m : Z):
    ↑(N .@ "internal") ⊆ E →
    {{{ True }}} newcounter #m @ E {{{ (ℓ : loc), RET #ℓ; ∃ γ, Cnt ℓ γ ∗ γ ⤇½ m}}}.
  Proof.
    iIntros (Hsubset Φ) "#Ht HΦ".
    wp_lam.
    wp_alloc ℓ as "Hl".
    iApply "HΦ".
    by iApply Cnt_alloc.
  Qed.

  Theorem read_spec (γ : gname) (E : coPset) (P : iProp Σ) (Q : Z → iProp Σ) (ℓ : loc):
    ↑(N .@ "internal") ⊆ E →
    (∀ m, □ (γ ⤇½ m ∗ P ={E ∖ ↑(N .@ "internal")}=∗ γ ⤇½ m ∗ Q m)) ⊢
    {{{ Cnt ℓ γ ∗ P}}} read #ℓ @ E {{{ (m : Z), RET #m; Cnt ℓ γ ∗ Q m }}}.
  Proof.
    iIntros (Hsubset) "#HVS".
    iIntros (Φ) "!# [#HInc HP] HCont".
    wp_rec.
    rewrite /Cnt.
    iInv (N .@ "internal") as (m) "[>Hpt >Hown]" "HClose".
    iMod ("HVS" $! m with "[Hown HP]") as "[Hown HQ]"; first by iFrame.
    wp_load.
    iMod ("HClose" with "[Hpt Hown]") as "_".
    { iNext; iExists _; iFrame. }
    iApply "HCont".
    iModIntro.
    iFrame.
    done.
  Qed.

  Theorem incr_spec (γ : gname) (E : coPset) (P : iProp Σ) (Q : Z → iProp Σ) (ℓ : loc):
    ↑(N .@ "internal") ⊆ E →
    (∀ (n : Z), □ (γ ⤇½ n ∗ P  ={E ∖ ↑(N .@ "internal")}=∗ γ ⤇½ (n+1) ∗ Q n)) ⊢
    {{{ Cnt ℓ γ ∗ P }}} incr #ℓ @ E {{{ (m : Z), RET #m; Cnt ℓ γ ∗ Q m}}}.
  Proof.
    iIntros (Hsubset) "#HVS".
    iIntros (Φ) "!# [#HInc HP] HCont".
    iLöb as "IH".
    wp_rec.
    wp_bind (! _)%E.
    iInv (N .@ "internal") as (m) "[>Hpt >Hown]" "HClose".
    wp_load.
    iMod ("HClose" with "[Hpt Hown]") as "_".
    { iNext; iExists _; iFrame. }
    iModIntro.
    wp_let.
    wp_op.
    wp_bind (CmpXchg _ _ _)%E.
    iInv (N .@ "internal") as (m') "[>Hpt >Hown]" "HClose".
    destruct (decide (m = m')); simplify_eq.
    - wp_cmpxchg_suc.
      iMod ("HVS" $! m' with "[Hown HP]") as "[Hown HQ]"; first iFrame.
      iMod ("HClose" with "[Hpt Hown]") as "_".
      { iNext; iExists _; iFrame. }
      iModIntro.
      wp_pures.
      iApply "HCont"; by iFrame.
    - wp_cmpxchg_fail.
      iMod ("HClose" with "[Hpt Hown]") as "_".
      { iNext; iExists _; iFrame. }
      iModIntro.
      wp_pures.
      iApply ("IH" with "HP HCont").
  Qed.

  Theorem wk_incr_spec (γ : gname) (E : coPset) (P Q : iProp Σ) (ℓ : loc) (n : Z) (q : Qp):
    ↑(N .@ "internal") ⊆ E →
    □ (γ ⤇½ n ∗ γ ⤇[q] n ∗ P ={E ∖ ↑(N .@ "internal")}=∗ γ ⤇½ (n+1) ∗ Q) -∗
    {{{ Cnt ℓ γ ∗ γ ⤇[q] n ∗ P}}} wk_incr #ℓ @ E {{{ RET #(); Cnt ℓ γ ∗ Q}}}.
  Proof.
    iIntros (Hsubset) "#HVS".
    iIntros (Φ) "!# [#HInc [Hγ HP]] HCont".
    wp_lam.
    wp_bind (! _)%E.
    iInv (N .@ "internal") as (m) "[>Hpt >Hown]" "HClose".
    wp_load.
    iDestruct (makeElem_eq with "Hγ Hown") as %->.
    iMod ("HClose" with "[Hpt Hown]") as "_".
    { iNext; iExists _; iFrame. }
    iModIntro.
    wp_let.
    wp_op.
    iInv (N .@ "internal") as (k) "[>Hpt >Hown]" "HClose".
    iDestruct (makeElem_eq with "Hγ Hown") as %->.
    iMod ("HVS" with "[$Hown $HP $Hγ]") as "[Hown HQ]".
    wp_store.
    iMod ("HClose" with "[Hpt Hown]") as "_".
    { iNext; iExists _; iFrame. }
    iModIntro.
    iApply "HCont"; by iFrame.
  Qed.

  Theorem wk_incr_spec' (γ : gname) (E : coPset) (P Q : iProp Σ) (ℓ : loc) (n : Z) (q : Qp):
    ↑(N .@ "internal") ⊆ E →
    □ (γ ⤇½ n ∗ γ ⤇[q] n ∗ P ={E ∖ ↑(N .@ "internal")}=∗ γ ⤇½ (n+1) ∗  γ ⤇[q] (n + 1) ∗ Q) -∗
    {{{ Cnt ℓ γ ∗ γ ⤇[q] n ∗ P}}} wk_incr #ℓ @ E {{{ RET #(); Cnt ℓ γ ∗  γ ⤇[q] (n + 1) ∗ Q}}}.
  Proof.
    iIntros (Hsubset) "#HVS".
    iApply wk_incr_spec; done.
Qed.

End cnt_spec.
Global Opaque newcounter incr read wk_incr.

Section incr_twice.
  Context `{!heapGS Σ, !cntG Σ} (N : namespace).
  Definition incr_twice : val := λ: "ℓ", incr "ℓ" ;; incr "ℓ".

  Theorem incr_twice_spec (γ : gname) (E : coPset) (P : iProp Σ) (Q Q' : Z → iProp Σ) (ℓ : loc):
    ↑(N .@ "internal") ⊆ E →
    (∀ (n : Z), □ (γ ⤇½ n ∗ P  ={E ∖ ↑(N .@ "internal")}=∗ γ ⤇½ (n+1) ∗ Q n))
      -∗
      (∀ (n : Z), □ (γ ⤇½ n ∗ (∃ m, Q m)  ={E ∖ ↑(N .@ "internal")}=∗ γ ⤇½ (n+1) ∗ Q' n))
      -∗
      {{{ Cnt N ℓ γ ∗ P }}} incr_twice #ℓ @ E {{{ (m : Z), RET #m; Cnt N ℓ γ ∗ Q' m}}}.
  Proof.
    iIntros (?) "#HVS1 #HVS2 !#".
    iIntros (Φ) "HPre HΦ".
    wp_lam. wp_bind (incr _)%E.
    wp_apply (incr_spec with "HVS1 HPre"); auto.
    iIntros (m) "[HCnt HPre]".
    wp_seq.
    wp_apply (incr_spec with "HVS2 [$HCnt HPre]"); auto.
  Qed.
End incr_twice.

Section example_1.
  Context `{!heapGS Σ, !spawnG Σ, !cntG Σ} (N : namespace).

  Definition incr_2 : val :=
    λ: "x",
       let: "l" := newcounter "x" in
       incr "l" ||| incr "l";;
       read "l".

  (* Prove that incr is safe w.r.t. data race. TODO: prove a stronger post-condition *)
  Lemma incr_2_safe:
    ∀ (x: Z), ⊢ WP incr_2 #x {{ _, True }}.
  Proof.
    iIntros (x).
    rewrite /incr_2 /=.
    wp_lam.
    wp_bind (newcounter _)%E.
    wp_apply newcounter_spec; auto; iIntros (ℓ) "H".
    iDestruct "H" as (γ) "[#HInc Hown2]".
    iMod (inv_alloc (N.@ "external") _ (∃m, own γ (makeElem (1/2) m))%I with "[Hown2]") as "#Hinv".
    { iNext; iExists _; iFrame. }
    iDestruct (incr_spec N γ ⊤ True%I (λ _, True)%I with "[]") as "#HIncr"; eauto.
    { iIntros (n) "!# [Hown _]".
      iInv (N .@ "external") as (m) ">Hownm" "H2".
      iMod (makeElem_update _ _ _ (n + 1) with "Hown Hownm") as "[Hown Hown']".
      iMod ("H2" with "[Hown]") as "_".
      { iExists _; iFrame. }
      iModIntro; iFrame.
    }
    wp_let.
    wp_bind (_ ||| _)%E.
    let tac := iApply ("HIncr" with "[$HInc]"); iNext; by iIntros (?) "_" in
    wp_smart_apply (wp_par (λ _, True%I) (λ _, True%I)); [tac | tac | ].
    { iIntros (v1 v2) "_ !>".
      wp_seq.
      wp_apply (read_spec _ _ _ True%I (λ _, True%I)); auto.
    }
  Qed.
End example_1.


Require Import ExtLib.Core.RelDec.

Require Import MirrorCore.RTac.RTac.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.Red.
Require Import MirrorCore.TypesI.

Require Import MirrorCharge.ModularFunc.ILogicFunc.

Section IntroTac.
	Context {typ func subst : Type}.
	Context {HIL : ILogicFunc typ func}.
	Context {RType_typ : RType typ}.
    Context {Typ0_tyProp : Typ0 RType_typ Prop}.
    Context {Heq : RelDec (@eq typ)}.
    Context {EV : ExprVar (expr typ func)}.
    Context {EU : ExprUVar (expr typ func)}.

    Let tyProp : typ := @typ0 _ _ _ _.

	Definition fintro e : option (@OpenAs typ (expr typ func)) :=
		match e with
			| App (Inj f) P =>
				match ilogicS f with
				  | Some (ilf_forall t t') =>
				  	if t' ?[ eq ] tyProp then
				  		Some (AsAl t (fun x => beta (App P x)))
				  	else
				  		None
				  | Some (ilf_exists t t') =>
				  	if t' ?[ eq ] tyProp then
				  		Some (AsEx t (fun x => beta (App P x)))
				  	else
				  		None
				  | _ => None
				end
			| App (App (Inj f) P) Q =>
				match ilogicS f with
				  | Some (ilf_impl t') =>
				  	if t' ?[ eq ] tyProp then
				  		Some (AsHy P Q)
				  	else
				  		None
(*				  | Some (ilf_entails t) =>
				    match Q with
				      | App (Inj g) Q' =>
				        match ilogicS g with
				          | Some (ilf_exists t' t'') =>
				            Some (AsEx t' (fun x => mkEntails t (lift 0 1 P) (beta (App Q' x))))
				          | _ => None
				        end
				      | _ => None
				    end*)
				  | _ => None
				end
			| _ => None
		end.

	Definition INTRO := @INTRO typ (expr typ func) EV EU fintro.

End IntroTac.

Implicit Arguments INTRO [[HIL] [RType_typ] [Typ0_tyProp] [Heq] [EU] [EV]].


Require Import Coq.ZArith.ZArith.
Require Import coqutil.Map.Interface.
Require Import coqutil.Map.SortedList.
Require Import coqutil.Z.Lia.
Require Import riscv.Utility.Utility.
Require Import riscv.Spec.CSRField.
Local Open Scope Z_scope.

Definition CSRField_to_Z(f: CSRField): Z :=
  match f with
  | MXL => 0
  | Extensions => 1
  | SXL => 2
  | UXL => 3
  | TSR => 4
  | TW => 5
  | TVM => 6
  | MXR => 7
  | SUM => 8
  | MPRV => 9
  | XS => 10
  | FS => 11
  | MPP => 12
  | SPP => 13
  | MPIE => 14
  | SPIE => 15
  | UPIE => 16
  | MIE => 17
  | SIE => 18
  | UIE => 19
  | SD => 20
  | MTVecBase => 21
  | MTVecMode => 22
  | MEDeleg => 23
  | MIDeleg => 24
  | MEIP => 25
  | SEIP => 26
  | UEIP => 27
  | MTIP => 28
  | STIP => 29
  | UTIP => 30
  | MSIP => 31
  | SSIP => 32
  | USIP => 33
  | MEIE => 34
  | SEIE => 35
  | UEIE => 36
  | MTIE => 37
  | STIE => 38
  | UTIE => 39
  | MSIE => 40
  | SSIE => 41
  | USIE => 42
  | MCycle => 43
  | MInstRet => 44
  | MHPM => 45
  | MIR => 46
  | MTM => 47
  | MCY => 48
  | MScratch => 49
  | MEPC => 50
  | MCauseInterrupt => 51
  | MCauseCode => 52
  | MTVal => 53
  | STVecBase => 54
  | STVecMode => 55
  | SHPM => 56
  | SIR => 57
  | STM => 58
  | SCY => 59
  | SScratch => 60
  | SEPC => 61
  | SCauseInterrupt => 62
  | SCauseCode => 63
  | STVal => 64
  | MODE => 65
  | ASID => 66
  | PPN => 67
  | FFlags => 68
  | FRM => 69
  end.

Lemma CSRField_to_Z_inj: forall f1 f2,
    CSRField_to_Z f1 = CSRField_to_Z f2 ->
    f1 = f2.
Proof. intros. destruct f1; destruct f2; simpl in *; congruence. Qed.

Definition CSRField_ltb(f1 f2: CSRField): bool := Z.ltb (CSRField_to_Z f1) (CSRField_to_Z f2).

#[global] Instance CSRField_ltb_strictorder: SortedList.parameters.strict_order CSRField_ltb.
Proof.
  constructor; unfold CSRField_ltb; intros.
  - apply Z.ltb_irrefl.
  - rewrite ?Z.ltb_lt in *. blia.
  - apply CSRField_to_Z_inj.
    rewrite Z.ltb_ge in *.
    blia.
Qed.

#[global] Instance CSRFile_map_params: SortedList.parameters := {|
  parameters.key := CSRField;
  parameters.value := MachineInt;
  parameters.ltb := CSRField_ltb;
|}.

#[global] Instance CSRFile: map.map CSRField MachineInt :=
  SortedList.map CSRFile_map_params CSRField_ltb_strictorder.

#[global] Instance CSRFile_ok: map.ok CSRFile.
Proof. apply (@SortedList.map_ok CSRFile_map_params CSRField_ltb_strictorder). Qed.


Require Import Rupicola.Lib.Api.

Definition F {n} p : if lt_dec p n then Fin.t n else unit :=
  match lt_dec p n as cmp return (if cmp then Fin.t n else unit) with
  | left pr => Fin.of_nat_lt pr
  | _ => tt
  end.

Definition byte_of_fin_lt {n} (Hle: (n <= 256)%nat) (f: Fin.t n) : byte :=
  let (n, Hlt) := Fin.to_nat f in
  match Byte.of_nat n as b return Byte.of_nat n = b -> byte with
  | Some b => fun _ => b
  | None => fun HNone =>
             ltac:(apply Byte.of_nat_None_iff in HNone;
                   exfalso; eapply Nat.lt_irrefl;
                   eauto using Nat.lt_irrefl, Nat.le_lt_trans, Nat.lt_le_trans)
  end eq_refl.

Lemma Fin_to_nat_lt {n} (f: Fin.t n) m:
  (n <= m)%nat -> (proj1_sig (Fin.to_nat f) < m)%nat.
Proof. intros; pose proof proj2_sig (Fin.to_nat f); simpl in *; lia. Qed.

Instance Convertible_Fin_byte {n} (Hle: (n <= 256)%nat) : Convertible (Fin.t n) byte :=
  byte_of_fin_lt Hle.
Instance Convertible_Fin_byte_5: Convertible (Fin.t 5) byte :=
  Convertible_Fin_byte (n := 5) ltac:(lia).

Section __.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word byte}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.

  Lemma word_of_byte_of_fin {n} H (f: Fin.t n):
    word_of_byte (byte_of_fin_lt H f) =
      word.of_Z (word := word) (Z.of_nat (proj1_sig (Fin.to_nat f))).
  Proof.
    unfold byte_of_fin_lt.
    destruct Fin.to_nat as (bn & Hf).
    generalize (eq_refl (Byte.of_nat bn)).
    destruct (Byte.of_nat bn) as [b|] at 2 3;
      cbn -[word.of_Z]; intros Hb.
    - apply Byte.to_of_nat in Hb; subst bn.
      rewrite Byte.to_nat_via_N, N_nat_Z; reflexivity.
    - destruct Nat.lt_irrefl.
  Qed.

  Lemma word_of_byte_sru_lt b:
    (Z.to_nat (word.unsigned (word.sru (word := word) (word_of_byte b) (word.of_Z 3))) < 32)%nat .
  Proof.
    pose proof width_at_least_32 as H32.
    pose proof Z.pow_le_mono_r 2 _ _ ltac:(lia) H32.
    pose proof word.unsigned_range (word.sru (word_of_byte b) (word.of_Z 3)).
    apply (Z2Nat.inj_lt _ (Z.of_nat 32)); [lia..|].
    rewrite word.unsigned_sru_shamtZ, Z.shiftr_div_pow2 by lia.
    pose proof word.word_of_byte_range b; apply Z.div_lt_upper_bound; lia.
  Qed.
End __.

Require Export bedrock2.BasicC32Semantics.

Coercion co_word_of_Z := word.of_Z (word := word).
Coercion co_word_of_byte (b: byte) : word := word_of_byte b.
Coercion co_word_of_Fin {n} (f: Fin.t n) : word :=
  word.of_Z (Z.of_nat (proj1_sig (Fin.to_nat f))).

#[export] Hint Unfold Convertible_Fin_byte : compiler_side_conditions.
#[export] Hint Unfold Convertible_Fin_byte_5 : compiler_side_conditions.
#[export] Hint Unfold co_word_of_Z co_word_of_byte co_word_of_Fin : compiler_side_conditions.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


Definition cong_refl :=
fun (A1 A2 : Type) (u1 : A1) (u2 : A2) (pA : A1 ≅ A2) (pu : u1 ≅ u2) =>
match pA with
| @heqPair _ _ _ _ pT pA0 =>
    let pA1 : transport eq_refl A1 = A2 :=
      Logic.eq_ind pT (fun pT0 : Type = Type => transport pT0 A1 = A2) pA0 eq_refl (K pT) in
    match pA1 in (_ = y) return (forall u3 : y, u1 ≅ u3 -> eq_refl ≅ eq_refl) with
    | eq_refl =>
        fun (u3 : A1) (pu0 : u1 ≅ u3) =>
        match pu0 with
        | @heqPair _ _ _ _ pA2 pu1 =>
            let pu2 : transport eq_refl u1 = u3 :=
              Logic.eq_ind pA2 (fun pA3 : A1 = A1 => transport pA3 u1 = u3) pu1 eq_refl (K pA2) in
            match pu2 in (_ = y) return (eq_refl ≅ eq_refl) with
            | eq_refl => heq_refl eq_refl
            end
        end
    end u2 pu
end
     : forall (A1 A2 : Type) (u1 : A1) (u2 : A2), A1 ≅ A2 -> u1 ≅ u2 -> eq_refl ≅ eq_refl.


(** * SimplifyArith: Remove things like (_ * 1), (_ + 0), etc *)
Require Import Coq.ZArith.ZArith.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.Rewriter.
Require Import Crypto.Reflection.Z.Syntax.

Section language.
  Local Notation exprf := (@exprf base_type op).
  Local Notation Expr := (@Expr base_type op).

  Section with_var.
    Context {var : base_type -> Type}.

    Fixpoint interp_as_expr_or_const {t} (x : exprf (var:=var) t)
      : option (interp_flat_type (fun t => Z + (exprf (var:=var) (Tbase t)))%type t)
      := match x in Syntax.exprf _ _ t return option (interp_flat_type _ t) with
         | Op t1 (Tbase _) opc args
           => Some (match opc with
                    | OpConst _ z => fun _ => inl z
                    | _ => fun x => x
                    end (inr (Op opc args)))
         | TT => Some tt
         | Var t v => Some (inr (Var v))
         | Op _ _ _ _
         | LetIn _ _ _ _
           => None
         | Pair tx ex ty ey
           => match @interp_as_expr_or_const tx ex, @interp_as_expr_or_const ty ey with
              | Some vx, Some vy => Some (vx, vy)
              | _, None | None, _ => None
              end
         end.

    Definition simplify_op_expr {src dst} (opc : op src dst)
      : exprf (var:=var) src -> exprf (var:=var) dst
      := match opc in op src dst return exprf src -> exprf dst with
         | Add TZ TZ TZ as opc
           => fun args
              => match interp_as_expr_or_const args with
                 | Some (inl l, inl r)
                   => Op (OpConst (interp_op _ _ opc (l, r))) TT
                 | Some (inl v, inr e)
                 | Some (inr e, inl v)
                   => if (v =? 0)%Z
                      then e
                      else Op opc args
                 | _ => Op opc args
                 end
         | Sub TZ TZ TZ as opc
           => fun args
              => match interp_as_expr_or_const args with
                 | Some (inl l, inl r)
                   => Op (OpConst (interp_op _ _ opc (l, r))) TT
                 | Some (inr e, inl v)
                   => if (v =? 0)%Z
                      then e
                      else Op opc args
                 | _ => Op opc args
                 end
         | Mul TZ TZ TZ as opc
           => fun args
              => match interp_as_expr_or_const args with
                 | Some (inl l, inl r)
                   => Op (OpConst (interp_op _ _ opc (l, r))) TT
                 | Some (inl v, inr e)
                 | Some (inr e, inl v)
                   => if (v =? 0)%Z
                      then Op (OpConst 0%Z) TT
                      else if (v =? 1)%Z
                           then e
                           else Op opc args
                 | _ => Op opc args
                 end
         | Shl TZ TZ TZ as opc
         | Shr TZ TZ TZ as opc
           => fun args
              => match interp_as_expr_or_const args with
                 | Some (inl l, inl r)
                   => Op (OpConst (interp_op _ _ opc (l, r))) TT
                 | Some (inr e, inl v)
                   => if (v =? 0)%Z
                      then e
                      else Op opc args
                 | _ => Op opc args
                 end
         | Land TZ TZ TZ as opc
           => fun args
              => match interp_as_expr_or_const args with
                 | Some (inl l, inl r)
                   => Op (OpConst (interp_op _ _ opc (l, r))) TT
                 | Some (inl v, inr e)
                 | Some (inr e, inl v)
                   => if (v =? 0)%Z
                      then Op (OpConst 0%Z) TT
                      else Op opc args
                 | _ => Op opc args
                 end
         | Lor TZ TZ TZ as opc
           => fun args
              => match interp_as_expr_or_const args with
                 | Some (inl l, inl r)
                   => Op (OpConst (interp_op _ _ opc (l, r))) TT
                 | Some (inl v, inr e)
                 | Some (inr e, inl v)
                   => if (v =? 0)%Z
                      then e
                      else Op opc args
                 | _ => Op opc args
                 end
         | Add _ _ _ as opc
         | Sub _ _ _ as opc
         | Mul _ _ _ as opc
         | Shl _ _ _ as opc
         | Shr _ _ _ as opc
         | Land _ _ _ as opc
         | Lor _ _ _ as opc
         | OpConst _ _ as opc
         | Neg _ _ _ as opc
         | Cmovne _ _ _ _ _ as opc
         | Cmovle _ _ _ _ _ as opc
           => Op opc
         end.
  End with_var.

  Definition SimplifyArith {t} (e : Expr t) : Expr t
    := @RewriteOp base_type op (@simplify_op_expr) t e.
End language.


Require Export Arrow Init.

Parameter fi' : indiv_choice_func.
Axiom R'D : (profile fi' H) ∈ D.
Axiom fi'_prop :
  forall (fi : indiv_choice_func) top bot x i,
  i ∈ H -> (bot,top) ∈ (P (fi' i)) /\
  ((forall y, y ∈ X -> (x,y) ∈ (fi i) <-> (x,y) ∈ (fi' i)) /\
   (forall y, y ∈ X -> (y,x) ∈ (fi i) <->  (y,x) ∈ (fi' i))).

Lemma extreme :
  forall f, U f -> WP f -> IIA f ->
  (forall x (fi : indiv_choice_func), x ∈ X -> (profile fi H) ∈ D ->
  (forall i, i ∈ H ->
    (forall y, y ∈ X -> (x,y) ∈ (fi i)) \/
    (forall y, y ∈ X -> (y,x) ∈ (fi i))) ->
  (forall y, y ∈ X -> (x,y) ∈ (f (profile fi H))) \/
  (forall y, y ∈ X -> (y,x) ∈ (f (profile fi H) ))).
Proof.
  move => f Uf WPf IIAf x fi xX RD H0.

  (* order (f (profile fi H)) *)
  move : (Uf fi RD)  => Uf_.
  rewrite in_set in Uf_.
  case /andP : Uf_ => [_ ord].
  move /orderP : ord => [refl [comp trans]].

  (* order (f (profile fi' H)) *)
  move : (Uf fi' R'D) => Uf'.
  rewrite in_set in Uf'.
  case /andP : Uf' => [_ ord].
  move /orderP : ord => [refl' [comp' trans']].

  (* Assume existstance top and bot  *)
  apply NNPP => F.
  move /not_or_and : F => [L R].
  move /not_all_ex_not : L => [top L].
  move /not_all_ex_not : R => [bot R].
  move /(imply_to_and (top ∈ X) _) : L => [topX _xRtop].
  move /(imply_to_and (bot ∈ X) _) : R => [botX _botRx].

  (* property of fi' *)
  move : (fi'_prop fi top bot x) => fi'_p.

  (* x <> top, x <> bot, top <> bot *)
  have _xtop : top <> x.
    move => F; subst top.
    case (_xRtop (refl x)).
  have _xbot : x <> bot.
    move => F; subst bot.
    case (_botRx (refl x)).
  have _topbot : top <> bot.
    move => F; subst bot.
    move : (comp top x _xtop).
    case /orP => F.
    case (_botRx F).
    case (_xRtop F).

  (* (top, x) ∈ (f (profile fi H)) *)
  have top_x_R : (top, x) ∈ (f (profile fi H)).
    move : (comp top x _xtop).
    case /orP => //.

  (* (top, x) ∈ (f (profile fi H)) *)
  have x_bot_R : (x,bot) ∈ (f (profile fi H)).
    move : (comp x bot _xbot).
    case /orP => //.

  (* (bot,top) ∈ (f (profile fi' H)) *)
  have bot_top_R' : (bot,top) ∈ (P (f (profile fi' H))).
    apply : (WPf fi' bot top R'D botX topX).
    move => i iH.
    apply  (fi'_p i iH).

  (* (top,x) ∈ (f (profile fi' H)) *)
  have top_x_R' : (top,x) ∈ (f (profile fi' H)).
    suff H2 : ((top,x) ∈ (f (profile fi H)) <-> (top,x) ∈ (f (profile fi' H))) /\
              ((x,top) ∈ (f (profile fi H)) <-> (x,top) ∈ (f (profile fi' H))).
      move : H2 => [H2 _].
      rewrite -H2 => //.
    apply:  (IIAf fi fi' top x RD R'D topX xX).
    move => i iH.
    move : (fi'_p i iH) => [bot_top_PRi' [max min]].
    move : (max top topX).
    move : (min top topX).
    done.

  (* (x,bot) ∈ (f (profile fi' H)) *)
  have x_bot_R' : (x,bot) ∈ (f (profile fi' H)).
    suff H2 : ((bot,x) ∈ (f (profile fi H)) <-> (bot,x) ∈ (f (profile fi' H))) /\
              ((x,bot) ∈ (f (profile fi H)) <-> (x,bot) ∈ (f (profile fi' H))).
      move : H2 => [_ H2].
      rewrite -H2 => //.
    apply:  (IIAf fi fi' bot x RD R'D botX xX).
    move => i iH.
    move : (fi'_p i iH) => [bot_top_PRi' [max min]].
    move : (max bot botX).
    move : (min bot botX).
    done.

  rewrite in_set in bot_top_R'.
  move /andP : bot_top_R' => /= [_ F].
  move : (trans' top x bot top_x_R' x_bot_R') => top_bot_R'.
  rewrite top_bot_R' in F.
  apply negb_true_iff in F.
  apply diff_true_false => //.
Qed.


Require Export SystemFR.Judgments.
Require Export SystemFR.AnnotatedTactics.
Require Export SystemFR.PolarityErase.
Require Export SystemFR.ErasedRecPos.

Opaque reducible_values.

Lemma annotated_subtype_rec:
  forall Θ Γ n1 n2 T0 Ts,
    [[ Θ; Γ ⊨ n1 ≡ n2 ]] ->
    [[ Θ; Γ ⊨ T_rec n1 T0 Ts <: T_rec n2 T0 Ts ]].
Proof.
  unfold open_subtype, open_equivalent;
    repeat step;
    eauto using reducible_values_rec_equivalent.
Qed.

Lemma annotated_subtype_rec_pos:
  forall X Θ Γ n1 n2 T0 Ts,
    wf T0 0 ->
    wf Ts 0 ->
    twf T0 0 ->
    twf Ts 1 ->
    subset (fv T0) (support Γ) ->
    subset (fv Ts) (support Γ) ->
    is_annotated_type T0 ->
    is_annotated_type Ts ->
    ~(X ∈ pfv T0 type_var) ->
    ~(X ∈ pfv Ts type_var) ->
    ~(X ∈ Θ) ->
    has_polarities (topen 0 Ts (fvar X type_var)) ((X, Positive) :: nil) ->
    [[ Θ; Γ ⊨ binary_primitive Lt n1 (succ n2) ≡ ttrue ]] ->
    [[ Θ; Γ ⊨ n1 : T_nat ]] ->
    [[ Θ; Γ ⊨ topen 0 Ts (T_rec zero T0 Ts) <: T0 ]] ->
    [[ Θ; Γ ⊨ T_rec n2 T0 Ts <: T_rec n1 T0 Ts ]].
Proof.
  unfold open_subtype, open_equivalent;
    repeat step.

  apply reducible_values_rec_pos with (psubstitute (erase_term n2) l term_var) X;
    eauto with erased;
      repeat step || side_conditions || t_instantiate_sat3 || t_pfv_in_subst || t_substitutions ||
             rewrite tlt_erase in * ||
             rewrite psubstitute_tlt in * ||
             erase_open ||
             apply_any;
      eauto using has_polarities_subst_erase;
      side_conditions;
      eauto with twf wf fv.

  - apply fv_nils2; eauto with fv.
    eapply subset_same_support; eauto; repeat step || t_subset_erase || rewrite erased_context_support.

  - apply fv_nils2; eauto with fv.
    eapply subset_same_support; eauto; repeat step || t_subset_erase || rewrite erased_context_support.
Qed.


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

Fine-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".

(** Fine-grained bag implementation using CAS *)
Definition newBag : val := λ: <>,
  ref NONE.
Definition pushBag : val := rec: "push" "b" "v" :=
  let: "oHead" := !"b" in
  if: CAS "b" "oHead" (SOME (ref ("v", "oHead")))
  then #()
  else "push" "b" "v".

Definition popBag : val := rec: "pop" "b" :=
  match: !"b" with
    NONE => NONE
  | SOME "l" =>
    let: "hd" := !"l" in
    let: "v" := Fst "hd" in
    let: "tl" := Snd "hd" in
    if: CAS "b" (SOME "l") "tl"
    then SOME "v"
    else "pop" "b"
  end.

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

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

  Definition rown (l : loc) (v : val) :=
    (∃ q, l ↦{q} v)%I.
  Lemma rown_duplicate l v : rown l v -∗ rown l v ∗ rown l v.
  Proof. iDestruct 1 as (q) "[Hl Hl']". iSplitL "Hl"; iExists _; eauto. Qed.

  Definition oloc_to_val (ol: option loc) : val :=
    match ol with
    | None => NONEV
    | Some loc => SOMEV (#loc)
    end.
  Local Instance oloc_to_val_inj : Inj (=) (=) oloc_to_val.
  Proof. intros [|][|]; simpl; congruence. Qed.

  Fixpoint is_list (hd : option loc) (xs : list val) : iProp Σ :=
    match xs, hd with
    | [], None => True
    | x::xs, Some l => ∃ (tl : option loc),
                   rown l (x, oloc_to_val tl) ∗ is_list tl xs
    | _, _ => False
    end%I.

  Lemma is_list_duplicate hd xs : is_list hd xs -∗ is_list hd xs ∗ is_list hd xs.
  Proof.
    iInduction xs as [ | x xs ] "IH" forall (hd); simpl; eauto.
    destruct hd; last by auto.
    iDestruct 1 as (tl) "[Hro Htl]".
    rewrite rown_duplicate. iDestruct "Hro" as "[Hro Hro']".
    iDestruct ("IH" with "Htl") as "[Htl Htl']".
    iSplitL "Hro Htl"; iExists _; iFrame; eauto.
  Qed.

  Lemma is_list_agree hd xs ys : is_list hd xs -∗ is_list hd ys -∗ ⌜xs = ys⌝.
  Proof.
    iInduction xs as [ | x xs ] "IH" forall (hd ys); simpl; eauto.
    - destruct hd; first by auto.
      destruct ys; eauto.
    - destruct hd; last by auto.
      destruct ys as [| y ys]; eauto. simpl.
      iDestruct 1 as (tl) "(Hro & Hls)".
      iDestruct 1 as (tl') "(Hro' & Hls')".
      iDestruct "Hro" as (q) "Hro".
      iDestruct "Hro'" as (q') "Hro'".
      iDestruct (mapsto_agree l q q' (PairV x (oloc_to_val tl)) (PairV y (oloc_to_val tl'))
                with "Hro Hro'") as %?. simplify_eq/=.
      iDestruct ("IH" with "Hls Hls'") as %->. done.
  Qed.

  Definition bag_inv (γb : gname) (b : loc) : iProp Σ :=
    (∃ (hd : option loc) (ls : list val),
        b ↦ oloc_to_val hd ∗ is_list hd ls ∗ own γb ((1/2)%Qp, to_agree (list_to_set_disj ls)))%I.
  Definition is_bag (γb : gname) (x : val) :=
    (∃ (b : loc), ⌜x = #b⌝ ∗ inv N (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. iApply wp_fupd.
    wp_alloc r as "Hr".
    iMod (own_alloc (1%Qp, to_agree ∅)) as (γb) "[Ha Hf]"; first done.
    iMod (inv_alloc N _ (bag_inv γb r) with "[Ha Hr]") as "#Hinv".
    { iNext. iExists None,[]. simpl. iFrame. }
    iModIntro. iApply "HΦ".
    rewrite /is_bag /bag_contents. iFrame.
    iExists _. by iFrame "Hinv".
  Qed.

  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.
    iLöb as "IH". wp_rec. wp_pures.
    rewrite /is_bag.
    iDestruct "Hbag" as (b) "[% #Hinv]"; simplify_eq/=.
    wp_bind (! #b)%E.
    iInv N as (o ls) "[Ho [Hls >Hb]]" "Hcl".
    wp_load.
    iMod ("Hcl" with "[Ho Hls Hb]") as "_".
    { iNext. iExists _,_. iFrame. } clear ls.
    iModIntro.
    wp_alloc n as "Hn".
    wp_pures. wp_bind (CmpXchg _ _ _).
    iInv N as (o' ls) "[Ho [Hls >Hb]]" "Hcl".
    destruct (decide (o = o')) as [->|?].
    - wp_cmpxchg_suc. { destruct o'; left; done. }
      iMod ("Hvs" with "[$Hb $HP]") as "[Hb HQ]".
      iMod ("Hcl" with "[Ho Hn Hls Hb]") as "_".
      { iNext. iExists (Some _),(v::ls). iFrame "Ho Hb".
        simpl. iExists _. iFrame. by iExists 1%Qp. }
      iModIntro. wp_pures. by iApply "HΦ".
    - wp_cmpxchg_fail.
      { destruct o, o'; simpl; congruence. }
      { destruct o'; left; done. }
      iMod ("Hcl" with "[Ho Hls Hb]") as "_".
      { iNext. iExists _,ls. by iFrame "Ho Hb". }
      iModIntro. wp_proj. wp_if.
      by iApply ("IH" with "HP [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.
    iLöb as "IH". wp_rec.
    rewrite /is_bag.
    iDestruct "Hbag" as (b) "[% #Hinv]"; simplify_eq/=.
    wp_bind (!#b)%E.
    iInv N as (o ls) "[Ho [Hls >Hb]]" "Hcl".
    wp_load.
    destruct ls as [|x ls]; simpl.
    - destruct o; first done.
      iMod ("Hvs2" with "[$Hb $HP]") as "[Hb HQ]".
      iMod ("Hcl" with "[Ho Hb]") as "_".
      { iNext. iExists _,[]. by iFrame. }
      iModIntro. repeat wp_pure _.
      by iApply "HΦ".
    - destruct o as [hd|]; last done.
      iDestruct "Hls" as (tl) "(Hhd & Hls)"; simplify_eq/=.
      rewrite rown_duplicate. iDestruct "Hhd" as "[Hhd Hhd']".
      rewrite is_list_duplicate. iDestruct "Hls" as "[Hls Hls']".
      iMod ("Hcl" with "[Ho Hb Hhd Hls]") as "_".
      { iNext. iExists (Some _),(x::ls). simpl; iFrame; eauto.
        iExists _; eauto. by iFrame. }
      iModIntro. repeat wp_pure _.
      iDestruct "Hhd'" as (q) "Hhd".
      wp_load. wp_pures.
      wp_bind (CmpXchg _ _ _).
      iInv N as (o' ls') "[Ho [Hls >Hb]]" "Hcl".
      destruct (decide (o' = (Some hd))) as [->|?].
      + wp_cmpxchg_suc.
        (* The list is still the same *)
        rewrite (is_list_duplicate tl). iDestruct "Hls'" as "[Hls' Htl]".
        iAssert (is_list (Some hd) (x::ls)) with "[Hhd Hls']" as "Hls'".
        { simpl. iExists tl. iFrame. iExists q. iFrame. }
        iDestruct (is_list_agree with "Hls Hls'") as %?. simplify_eq.
        iClear "Hls'".
        iDestruct "Hls" as (tl') "(Hro' & Htl')".
        iMod ("Hvs1" with "[$Hb $HP]") as "[Hb HQ]".
        iMod ("Hcl" with "[Ho Htl Hb]") as "_".
        { iNext. iExists _,ls. by iFrame "Ho Hb". }
        iModIntro. wp_pures. by iApply "HΦ".
      + wp_cmpxchg_fail. { destruct o'; simpl; congruence. }
        iMod ("Hcl" with "[Ho Hls Hb]") as "_".
        { iNext. iExists _,ls'. by iFrame "Ho Hb". }
        iModIntro. wp_proj. wp_if.
        by iApply ("IH" with "HP [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 |}.


(** * Definition and classification of the [Σ] Type, with primitive projections *)
(** In this file, we classify the basic structure of Σ types ([sigT]
    in Coq).  In particular, we classify equalities of dependent pairs
    (inhabitants of Σ types), so that when we have an equality between
    two such pairs, or when we want such an equality, we have a
    systematic way of reducing such equalities to equalities at
    simpler types. *)
Require Import Coq.Classes.Morphisms.
Require Import Rewriter.Util.IffT.
Require Import Rewriter.Util.Equality.
Require Import Rewriter.Util.GlobalSettings.
Require Import Rewriter.Util.Notations.

Local Set Primitive Projections.

Declare Scope primproj_type_scope.
Declare Scope primproj_scope.
Delimit Scope primproj_type_scope with primproj_type.
Delimit Scope primproj_scope with primproj.

Import EqNotations.
Module Import Primitive.
  Record sigT {A} P := existT { projT1 : A ; projT2 : P projT1 }.
  Global Arguments existT {_} _ _ _.
  Global Arguments projT1 {_ _} _.
  Global Arguments projT2 {_ _} _.

  Module Export Notations.
    Notation "{ x  &  P }" := (sigT (fun x => P)) : type_scope.
    Notation "{ x : A  & P }" := (sigT (A:=A) (fun x => P)) : type_scope.
    Add Printing Let sigT.
  End Notations.

  Add Printing Let sigT.

  Local Set Implicit Arguments.

  Definition sigT_beq A P (eq_A : A -> A -> bool) (eq_P : forall a a', P a -> P a' -> bool) (X Y : @sigT A P) : bool
    := let (a, b) := X in let (a', b') := Y in (eq_A a a' && eq_P _ _ b b')%bool.
  Global Arguments sigT_beq / .
  Lemma sigT_dec_bl A P eq_A eq_P
        (A_bl : forall x y : A, eq_A x y = true -> x = y)
        (P_bl : forall a a' x y (pf : eq_A a a' = true), eq_P a a' x y = true -> rew [P] (A_bl _ _ pf) in x = y)
        (x y : @sigT A P)
    : sigT_beq eq_A eq_P x y = true -> x = y.
  Proof.
    destruct x as [a b], y as [a' b'].
    specialize (P_bl a a' b b'); cbn.
    generalize dependent (A_bl a a'); clear A_bl; intros A_bl P_bl H.
    edestruct eq_A; cbn in *;
      destruct (eq_A a a');
      first [ specialize (P_bl eq_refl); generalize dependent (A_bl eq_refl)
            | specialize (P_bl H); generalize dependent (A_bl H) ];
      clear A_bl; intros A_bl P_bl; try specialize (P_bl H); subst;
        cbn [eq_rect] in *;
        try reflexivity.
    all: edestruct eq_P; first [ specialize (P_bl eq_refl) | specialize (P_bl H) ]; subst;
      reflexivity.
  Defined.
  Lemma sigT_dec_bl_nd A P eq_A eq_P
        (A_bl : forall x y : A, eq_A x y = true -> x = y)
        (P_bl : forall a a' x y (pf : a = a'), rew [P] pf in x = y)
        (x y : @sigT A P)
    : sigT_beq eq_A eq_P x y = true -> x = y.
  Proof.
    apply (@sigT_dec_bl A P eq_A eq_P A_bl); intros; apply P_bl.
  Defined.

  Lemma sigT_dec_lb A P eq_A (eq_P : forall a a', P a -> P a' -> bool)
        (A_lb : forall x y : A, x = y -> eq_A x y = true)
        (P_lb : forall a (x y : P a), x = y -> eq_P a a x y = true)
        (x y : @sigT A P)
    : x = y -> sigT_beq eq_A eq_P x y = true.
  Proof.
    intro; subst y; specialize (A_lb _ _ (eq_refl (projT1 x))); specialize (P_lb _ _ _ (eq_refl (projT2 x))); cbn in *.
    edestruct eq_A, eq_P; (reflexivity + assumption).
  Defined.
  Definition sigT_eq_dec A P eq_A eq_P
             (A_bl : forall x y : A, eq_A x y = true -> x = y)
             (P_bl : forall a a' x y (pf : eq_A a a' = true), eq_P a a' x y = true -> rew [P] (A_bl _ _ pf) in x = y)
             (A_lb : forall x y : A, x = y -> eq_A x y = true)
             (P_lb : forall a (x y : P a), x = y -> eq_P a a x y = true)
             (x y : @sigT A P)
    : {x = y} + {x <> y}.
  Proof.
    refine (let H := let b := @sigT_beq A P eq_A eq_P x y in if b as b0 return ({b0 = true} + {b0 = false}) then left eq_refl else right eq_refl in
            match H with
            | left e => left (@sigT_dec_bl A P eq_A eq_P A_bl P_bl x y e)
            | right H' => right (fun e => _ (@sigT_dec_lb A P eq_A eq_P A_lb P_lb x y e))
            end).
    congruence.
  Defined.
End Primitive.
Notation "{ x  &  P }" := (sigT (fun x => P%primproj_type)) : primproj_type_scope.
Notation "{ x : A  & P }" := (sigT (A:=A%primproj_type) (fun x => P%primproj_type)) : primproj_type_scope.
Add Printing Let sigT.

Local Arguments f_equal {_ _} _ {_ _} _.

Definition projT1_existT {A B} (a:A) (b:B a) : projT1 (existT B a b) = a := eq_refl.
Definition projT2_existT {A B} (a:A) (b:B a) : projT2 (existT B a b) = b := eq_refl.
Create HintDb cancel_primsig discriminated. #[global] Hint Rewrite @projT1_existT @projT2_existT : cancel_primsig.

(** ** Equality for [sigT] *)
Section sigT.

  (** *** Projecting an equality of a pair to equality of the first components *)
  Definition pr1_path {A} {P : A -> Type} {u v : sigT P} (p : u = v)
  : projT1 u = projT1 v
    := f_equal (@projT1 _ _) p.

  (** *** Projecting an equality of a pair to equality of the second components *)
  Definition pr2_path {A} {P : A -> Type} {u v : sigT P} (p : u = v)
    : eq_rect _ _ (projT2 u) _ (pr1_path p) = projT2 v.
  Proof.
    destruct p; reflexivity.
  Defined.

  (** *** Equality of [sigT] is itself a [sigT] *)
  Definition path_sigT_uncurried {A : Type} {P : A -> Type} (u v : sigT P)
             (pq : sigT (fun p : projT1 u = projT1 v => eq_rect _ _ (projT2 u) _ p = projT2 v))
    : u = v.
  Proof.
    destruct u as [u1 u2], v as [v1 v2]; simpl in *.
    destruct pq as [p q].
    destruct q; simpl in *.
    destruct p; reflexivity.
  Defined.

  (** *** Curried version of proving equality of sigma types *)
  Definition path_sigT {A : Type} {P : A -> Type} (u v : sigT P)
             (p : projT1 u = projT1 v) (q : eq_rect _ _ (projT2 u) _ p = projT2 v)
  : u = v
    := path_sigT_uncurried u v (existT _ p q).

  (** *** Equality of [sigT] when the property is an hProp *)
  Definition path_sigT_hprop {A P} (P_hprop : forall (x : A) (p q : P x), p = q)
             (u v : @sigT A P)
             (p : projT1 u = projT1 v)
    : u = v
    := path_sigT u v p (P_hprop _ _ _).

  (** *** Equivalence of equality of [sigT] with a [sigT] of equality *)
  (** We could actually use [IsIso] here, but for simplicity, we
      don't.  If we wanted to deal with proofs of equality of Σ types
      in dependent positions, we'd need it. *)
  Definition path_sigT_uncurried_iff {A P}
             (u v : @sigT A P)
    : u = v <-> (sigT (fun p : projT1 u = projT1 v => eq_rect _ _ (projT2 u) _ p = projT2 v)).
  Proof.
    split; [ intro; subst; exists eq_refl; reflexivity | apply path_sigT_uncurried ].
  Defined.

  (** *** Induction principle for [@eq (sigT _)] *)
  Definition path_sigT_rect {A P} {u v : @sigT A P} (Q : u = v -> Type)
             (f : forall p q, Q (path_sigT u v p q))
    : forall p, Q p.
  Proof. intro p; specialize (f (pr1_path p) (pr2_path p)); destruct p; exact f. Defined.
  Definition path_sigT_rec {A P u v} (Q : u = v :> @sigT A P -> Set) := path_sigT_rect Q.
  Definition path_sigT_ind {A P u v} (Q : u = v :> @sigT A P -> Prop) := path_sigT_rec Q.

  (** *** Equivalence of equality of [sigT] involving hProps with equality of the first components *)
  Definition path_sigT_hprop_iff {A P} (P_hprop : forall (x : A) (p q : P x), p = q)
             (u v : @sigT A P)
    : u = v <-> (projT1 u = projT1 v)
    := conj (f_equal projT1) (path_sigT_hprop P_hprop u v).

  (** *** Non-dependent classification of equality of [sigT] *)
  Definition path_sigT_nondep {A B : Type} (u v : @sigT A (fun _ => B))
             (p : projT1 u = projT1 v) (q : projT2 u = projT2 v)
  : u = v
    := @path_sigT _ _ u v p (eq_trans (transport_const _ _) q).

  (** *** Classification of transporting across an equality of [sigT]s *)
  Lemma eq_rect_sigT {A x} {P : A -> Type} (Q : forall a, P a -> Prop) (u : sigT (Q x)) {y} (H : x = y)
  : eq_rect x (fun a => sigT (Q a)) u y H
    = existT
        (Q y)
        (eq_rect x P (projT1 u) y H)
        match H in (_ = y) return Q y (eq_rect x P (projT1 u) y H) with
          | eq_refl => projT2 u
        end.
  Proof.
    destruct H; reflexivity.
  Defined.

  (** *** η Principle for [sigT] *)
  Definition sigT_eta {A P} (p : { a : A & P a })
    : p = existT _ (projT1 p) (projT2 p)
    := eq_refl.
End sigT.

(** ** Useful Tactics *)
(** *** [inversion_sigma] *)
(** The built-in [inversion] will frequently leave equalities of
    dependent pairs.  When the first type in the pair is an hProp or
    otherwise simplifies, [inversion_sigma] is useful; it will replace
    the equality of pairs with a pair of equalities, one involving a
    term casted along the other.  This might also prove useful for
    writing a version of [inversion] / [dependent destruction] which
    does not lose information, i.e., does not turn a goal which is
    provable into one which requires axiom K / UIP.  *)
Ltac simpl_proj_exist_in H :=
  repeat match type of H with
         | context G[projT1 (existT _ ?x ?p)]
           => let G' := context G[x] in change G' in H
         | context G[projT2 (existT _ ?x ?p)]
           => let G' := context G[p] in change G' in H
         end.
Ltac induction_sigma_in_as_using H H0 H1 rect :=
  induction H as [H0 H1] using (rect _ _ _ _);
  simpl_proj_exist_in H0;
  simpl_proj_exist_in H1.
Ltac induction_sigma_in_using H rect :=
  let H0 := fresh H in
  let H1 := fresh H in
  induction_sigma_in_as_using H H0 H1 rect.
Ltac inversion_sigma_step :=
  match goal with
  | [ H : _ = existT _ _ _ |- _ ]
    => induction_sigma_in_using H @path_sigT_rect
  | [ H : existT _ _ _ = _ |- _ ]
    => induction_sigma_in_using H @path_sigT_rect
  end.
Ltac inversion_sigma := repeat inversion_sigma_step.


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Tactics.

Require Import MirrorCore.TypesI.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.Ptrns.
Require Import MirrorCore.Lambda.Red.
Require Import MirrorCore.Lambda.RedAll.
Require Import MirrorCore.Lambda.AppN.
Require Import MirrorCore.Views.Ptrns.
Require Import MirrorCore.Views.FuncView.
Require Import MirrorCore.Lib.NatView.
Require Import MirrorCore.Lib.ProdView.
Require Import MirrorCore.Lib.ListView.

Set Implicit Arguments.
Set Strict Implicit.
Set Maximal Implicit Insertion.
Set Printing Universes.

Inductive listOp_func (typ : Set) : Set :=
| pLength : typ -> listOp_func typ
| pNoDup : typ -> listOp_func typ
| pIn : typ -> listOp_func typ
| pMap : typ -> typ -> listOp_func typ
| pFold : typ -> typ -> listOp_func typ
| pCombine : typ -> typ -> listOp_func typ.

Section ListOpFuncInst.
  Context {typ : Set} {RType_typ : RType typ}.
  Context {func : Set}.
  Context {Heq : RelDec (@eq typ)} {HC : RelDec_Correct Heq}.

  Context {Typ2_tyArr : Typ2 _ RFun}.
  Context {Typ2_tyProd : Typ2 _ prod}.
  Context {Typ1_tyList : Typ1 _ list}.
  Context {Typ0_tyProp : Typ0 _ Prop}.
  Context {Typ0_tyNat : Typ0 _ nat}.

  Context {Typ0_tyPropOk : Typ0Ok Typ0_tyProp}.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ Typ2_tyArr.
  Let tyProd : typ -> typ -> typ := @typ2 _ _ _ Typ2_tyProd.
  Let tyList : typ -> typ := @typ1 _ _ _ Typ1_tyList.
  Let tyProp : typ := @typ0 _ _ _ Typ0_tyProp.
  Let tyNat : typ := @typ0 _ _ _ Typ0_tyNat.

  Definition typeof_listOp_func lf :=
    match lf with
    | pLength t => Some (tyArr (tyList t) tyNat)
    | pNoDup t => Some (tyArr (tyList t) tyProp)
    | pIn t => Some (tyArr t (tyArr (tyList t) tyProp))
    | pMap t1 t2 => Some (tyArr (tyArr t1 t2) (tyArr (tyList t1) (tyList t2)))
    | pFold t1 t2 =>
      Some (tyArr (tyArr t2 (tyArr t1 t1)) (tyArr t1 (tyArr (tyList t2) t1)))
    | pCombine t1 t2 =>
      Some (tyArr (tyList t1) (tyArr (tyList t2) (tyList (tyProd t1 t2))))
    end.

  Definition listOp_func_eq (a b : listOp_func typ) : option bool :=
    match a , b with
      | pLength t1, pLength t2 => Some (t1 ?[ eq ] t2)
      | pNoDup t1, pNoDup t2 => Some (t1 ?[ eq ] t2)
      | pIn t1, pIn t2 => Some (t1 ?[ eq ] t2)
      | pMap t1 t2, pMap t3 t4 => Some (t1 ?[ eq ] t3 &&
	      				   t2 ?[ eq ] t4)%bool
      | pFold t1 t2, pFold t3 t4 => Some (t1 ?[ eq ] t3 &&
	      				     t2 ?[ eq ] t4)%bool
      | pCombine t1 t2, pCombine t3 t4 => Some (t1 ?[ eq ] t3 &&
	      				   t2 ?[ eq ] t4)%bool
      | _, _ => None
    end.

  Global Instance RelDec_list_func : RelDec (@eq (listOp_func typ)) :=
    {
      rel_dec a b := match listOp_func_eq a b with
    	  	       | Some b => b
    		       | None => false
    		     end
    }.

  Definition lengthR t : typD (tyArr (tyList t) tyNat) :=
    castR id (RFun (list (typD t)) nat) (@length (typD t)).

  Definition NoDupR t : typD (tyArr (tyList t) tyProp) :=
    castR id (RFun (list (typD t)) Prop) (@NoDup (typD t)).

  Definition InR t : typD (tyArr t (tyArr (tyList t) tyProp)) :=
    castR id (RFun (typD t) (RFun (list (typD t)) Prop)) (@In (typD t)).

  Definition mapR t u : typD (tyArr (tyArr t u) (tyArr (tyList t) (tyList u))) :=
    castR id (RFun (RFun (typD t) (typD u)) (RFun (list (typD t)) (list (typD u))))
          (@map (typD t) (typD u)).

  Definition foldR t u : typD (tyArr (tyArr u (tyArr t t)) (tyArr t (tyArr (tyList u) t))) :=
    castR id (RFun (RFun (typD u) (RFun (typD t) (typD t)))
                  (RFun (typD t) (RFun (list (typD u)) (typD t))))
          (@fold_right (typD t) (typD u)).

  Definition combineR t u : typD (tyArr (tyList t) (tyArr (tyList u) (tyList (tyProd t u)))) :=
    castR id (RFun (list (typD t)) (RFun (list (typD u)) (list ((typD t) * (typD u)))))
          (@combine (typD t) (typD u)).

  Definition listOp_func_symD lf :=
    match lf as lf return match typeof_listOp_func lf return Type@{Urefl} with
			    | Some t => typD t
			    | None => unit
			  end with
      | pLength t => lengthR t
      | pNoDup t => NoDupR t
      | pIn t => InR t
      | pMap t1 t2 => mapR t1 t2
      | pFold t1 t2 => foldR t1 t2
      | pCombine t1 t2 => combineR t1 t2
    end.

  Global Instance RSym_ListOpFunc : SymI.RSym (listOp_func typ) :=
    {
      typeof_sym := typeof_listOp_func;
      symD := listOp_func_symD;
      sym_eqb := listOp_func_eq
    }.

  Global Instance RSymOk_ListOpFunc : SymI.RSymOk RSym_ListOpFunc.
  Proof.
    split; intros.
    destruct a, b; simpl; try apply I.
    + consider (t ?[ eq ] t0); intuition congruence.
    + consider (t ?[ eq ] t0); intuition congruence.
    + consider (t ?[ eq ] t0); intuition congruence.
    + consider (t ?[ eq ] t1 && t0 ?[ eq ] t2)%bool; intuition congruence.
    + consider (t ?[ eq ] t1 && t0 ?[ eq ] t2)%bool; intuition congruence.
    + consider (t ?[ eq ] t1 && t0 ?[ eq ] t2)%bool; intuition congruence.
  Qed.

End ListOpFuncInst.

Section MakeListOp.
  Context {typ func : Set} {FV : PartialView func (listOp_func typ)}.

  Definition fLength t := f_insert (pLength t).
  Definition fNoDup t := f_insert (pNoDup t).
  Definition fIn t := f_insert (pIn t).
  Definition fMap t u := f_insert (pMap t u).
  Definition fFold t u := f_insert (pFold t u).
  Definition fCombine t u := f_insert (pCombine t u).

  Definition mkLength t (lst : expr typ func) : expr typ func :=
    App (Inj (fLength t)) lst.

  Definition mkNoDup t (lst : expr typ func) : expr typ func :=
    App (Inj (fNoDup t)) lst.

  Definition mkIn t (lst : expr typ func) : expr typ func :=
    App (Inj (fIn t)) lst.

  Definition mkMap t u (f lst : expr typ func) : expr typ func :=
    App (App (Inj (fMap t u)) f) lst.

  Definition mkFold t u (f acc lst : expr typ func) : expr typ func :=
    App (App (App (Inj (fFold t u)) f) acc) lst.

  Definition mkCombine t u (xs ys : expr typ func) : expr typ func :=
    App (App (Inj (fCombine t u)) xs) ys.

  Definition fptrnLength {T : Type} (p : Ptrns.ptrn typ T) : ptrn (listOp_func typ) T :=
    fun f U good bad =>
      match f with
        | pLength t => p t U good (fun x => bad f)
        | _ => bad f
      end.

  Definition fptrnNoDup {T : Type} (p : Ptrns.ptrn typ T) : ptrn (listOp_func typ) T :=
    fun f U good bad =>
      match f with
        | pNoDup t => p t U good (fun x => bad f)
        | _ => bad f
      end.

  Definition fptrnIn {T : Type} (p : Ptrns.ptrn typ T) : ptrn (listOp_func typ) T :=
    fun f U good bad =>
      match f with
        | pIn t => p t U good (fun x => bad f)
        | _ => bad f
      end.

  Definition fptrnMap {T : Type} (p : ptrn (typ * typ) T) :
    ptrn (listOp_func typ) T :=
    fun f V good bad =>
      match f with
        | pMap t u => p (t, u) V good (fun x => bad f)
        | _ => bad f
      end.

  Definition fptrnFold {T : Type} (p : ptrn (typ * typ) T) :
    ptrn (listOp_func typ) T :=
    fun f V good bad =>
      match f with
        | pFold t u => p (t, u) V good (fun x => bad f)
        | _ => bad f
      end.

  Definition fptrnCombine {T : Type} (p : ptrn (typ * typ) T) :
    ptrn (listOp_func typ) T :=
    fun f V good bad =>
      match f with
        | pCombine t u => p (t, u) V good (fun x => bad f)
        | _ => bad f
      end.

  Global Instance fptrnLength_ok {T : Type} {p : ptrn typ T} {Hok : ptrn_ok p} :
    ptrn_ok (fptrnLength p).
  Proof.
    red; intros.
    destruct x; simpl;
    try (right; unfold Fails; reflexivity).
    destruct (Hok t).
    { left. destruct H; exists x. revert H. compute; intros.
      rewrite H. reflexivity. }
    { right; unfold Fails in *; intros; simpl; rewrite H; reflexivity. }
  Qed.

  Global Instance fptrnNoDup_ok {T : Type} {p : ptrn typ T} {Hok : ptrn_ok p} :
    ptrn_ok (fptrnNoDup p).
  Proof.
    red; intros.
    destruct x; simpl;
    try (right; unfold Fails; reflexivity).
    destruct (Hok t).
    { left. destruct H; exists x. revert H. compute; intros.
      rewrite H. reflexivity. }
    { right; unfold Fails in *; intros; simpl; rewrite H; reflexivity. }
  Qed.

  Global Instance fptrnIn_ok {T : Type} {p : ptrn typ T} {Hok : ptrn_ok p} :
    ptrn_ok (fptrnIn p).
  Proof.
    red; intros.
    destruct x; simpl;
    try (right; unfold Fails; reflexivity).
    destruct (Hok t).
    { left. destruct H; exists x. revert H. compute; intros.
      rewrite H. reflexivity. }
    { right; unfold Fails in *; intros; simpl; rewrite H; reflexivity. }
  Qed.

  Global Instance fptrnMap_ok {T : Type} {p : ptrn (typ * typ) T} {Hok : ptrn_ok p} :
    ptrn_ok (fptrnMap p).
  Proof.
    red; intros; destruct x; try (right; unfold Fails; reflexivity).
    destruct (Hok (t, t0)).
    { left. destruct H; exists x. revert H. compute; intros.
      rewrite H. reflexivity. }
    { right; unfold Fails in *; intros; simpl; rewrite H; reflexivity. }
  Qed.

  Global Instance fptrnFold_ok {T : Type} {p : ptrn (typ * typ) T} {Hok : ptrn_ok p} :
    ptrn_ok (fptrnFold p).
  Proof.
    red; intros; destruct x; try (right; unfold Fails; reflexivity).
    destruct (Hok (t, t0)).
    { left. destruct H; exists x. revert H. compute; intros.
      rewrite H. reflexivity. }
    { right; unfold Fails in *; intros; simpl; rewrite H; reflexivity. }
  Qed.

  Global Instance fptrnCombine_ok {T : Type} {p : ptrn (typ * typ) T} {Hok : ptrn_ok p} :
    ptrn_ok (fptrnCombine p).
  Proof.
    red; intros; destruct x; try (right; unfold Fails; reflexivity).
    destruct (Hok (t, t0)).
    { left. destruct H; exists x. revert H. compute; intros.
      rewrite H. reflexivity. }
    { right; unfold Fails in *; intros; simpl; rewrite H; reflexivity. }
  Qed.

  Lemma Succeeds_fptrnLength {T : Type} (f : listOp_func typ) (p : ptrn typ T) (res : T)
        {pok : ptrn_ok p} (H : Succeeds f (fptrnLength p) res) :
    exists t, Succeeds t p res /\ f = pLength t.
  Proof.
    unfold Succeeds, fptrnLength in H.
    unfold ptrn_ok in pok.
    specialize (H (option T) Some (fun _ => None)).
    destruct f; try congruence.
    specialize (pok t).
    destruct pok; [|rewrite H0 in H; congruence].
    destruct H0.
    rewrite H0 in H; inv_all; subst.
    exists t; split; [assumption | reflexivity].
  Qed.

  Lemma Succeeds_fptrnNoDup {T : Type} (f : listOp_func typ) (p : ptrn typ T) (res : T)
        {pok : ptrn_ok p} (H : Succeeds f (fptrnNoDup p) res) :
    exists t, Succeeds t p res /\ f = pNoDup t.
  Proof.
    unfold Succeeds, fptrnNoDup in H.
    unfold ptrn_ok in pok.
    specialize (H (option T) Some (fun _ => None)).
    destruct f; try congruence.
    specialize (pok t).
    destruct pok; [|rewrite H0 in H; congruence].
    destruct H0.
    rewrite H0 in H; inv_all; subst.
    exists t; split; [assumption | reflexivity].
  Qed.

  Lemma Succeeds_fptrnIn {T : Type} (f : listOp_func typ) (p : ptrn typ T) (res : T)
        {pok : ptrn_ok p} (H : Succeeds f (fptrnIn p) res) :
    exists t, Succeeds t p res /\ f = pIn t.
  Proof.
    unfold Succeeds, fptrnIn in H.
    unfold ptrn_ok in pok.
    specialize (H (option T) Some (fun _ => None)).
    destruct f; try congruence.
    specialize (pok t).
    destruct pok; [|rewrite H0 in H; congruence].
    destruct H0.
    rewrite H0 in H; inv_all; subst.
    exists t; split; [assumption | reflexivity].
  Qed.

  Lemma Succeeds_fptrnMap {T : Type} (f : listOp_func typ) (p : ptrn (typ * typ) T) (res : T)
        {pok : ptrn_ok p} (H : Succeeds f (fptrnMap p) res) :
    exists t u, Succeeds (t, u) p res /\ f = pMap t u.
  Proof.
    unfold Succeeds, fptrnMap in H.
    unfold ptrn_ok in pok.
    specialize (H (option T) Some (fun _ => None)).
    destruct f; try congruence.
    specialize (pok (t, t0)).
    destruct pok; [|rewrite H0 in H; congruence].
    destruct H0.
    rewrite H0 in H; inv_all; subst.
    exists t, t0; split; [assumption | reflexivity].
  Qed.

  Lemma Succeeds_fptrnFold {T : Type} (f : listOp_func typ) (p : ptrn (typ * typ) T) (res : T)
        {pok : ptrn_ok p} (H : Succeeds f (fptrnFold p) res) :
    exists t u, Succeeds (t, u) p res /\ f = pFold t u.
  Proof.
    unfold Succeeds, fptrnFold in H.
    unfold ptrn_ok in pok.
    specialize (H (option T) Some (fun _ => None)).
    destruct f; try congruence.
    specialize (pok (t, t0)).
    destruct pok; [|rewrite H0 in H; congruence].
    destruct H0.
    rewrite H0 in H; inv_all; subst.
    exists t, t0; split; [assumption | reflexivity].
  Qed.

  Lemma Succeeds_fptrnCombine {T : Type} (f : listOp_func typ) (p : ptrn (typ * typ) T) (res : T)
        {pok : ptrn_ok p} (H : Succeeds f (fptrnCombine p) res) :
    exists t u, Succeeds (t, u) p res /\ f = pCombine t u.
  Proof.
    unfold Succeeds, fptrnCombine in H.
    unfold ptrn_ok in pok.
    specialize (H (option T) Some (fun _ => None)).
    destruct f; try congruence.
    specialize (pok (t, t0)).
    destruct pok; [|rewrite H0 in H; congruence].
    destruct H0.
    rewrite H0 in H; inv_all; subst.
    exists t, t0; split; [assumption | reflexivity].
  Qed.

  Global Instance fptrnLength_SucceedsE {T : Type} {f : listOp_func typ}
         {p : ptrn typ T} {res : T} {pok : ptrn_ok p} :
    SucceedsE f (fptrnLength p) res := {
      s_result := exists t, Succeeds t p res /\ f = pLength t;
      s_elim := @Succeeds_fptrnLength T f p res pok
    }.

  Global Instance fptrnNoDup_SucceedsE {T : Type} {f : listOp_func typ}
         {p : ptrn typ T} {res : T} {pok : ptrn_ok p} :
    SucceedsE f (fptrnNoDup p) res := {
      s_result := exists t, Succeeds t p res /\ f = pNoDup t;
      s_elim := @Succeeds_fptrnNoDup T f p res pok
    }.

  Global Instance fptrnIn_SucceedsE {T : Type} {f : listOp_func typ}
         {p : ptrn typ T} {res : T} {pok : ptrn_ok p} :
    SucceedsE f (fptrnIn p) res := {
      s_result := exists t, Succeeds t p res /\ f = pIn t;
      s_elim := @Succeeds_fptrnIn T f p res pok
    }.

  Global Instance fptrnMap_SucceedsE {T : Type} {f : listOp_func typ}
         {p : ptrn (typ * typ) T} {res : T} {pok : ptrn_ok p} :
    SucceedsE f (fptrnMap p) res := {
      s_result := exists t u, Succeeds (t, u) p res /\ f = pMap t u;
      s_elim := @Succeeds_fptrnMap T f p res pok
    }.

  Global Instance fptrnFold_SucceedsE {T : Type} {f : listOp_func typ}
         {p : ptrn (typ * typ) T} {res : T} {pok : ptrn_ok p} :
    SucceedsE f (fptrnFold p) res := {
      s_result := exists t u, Succeeds (t, u) p res /\ f = pFold t u;
      s_elim := @Succeeds_fptrnFold T f p res pok
    }.

  Global Instance fptrnCombine_SucceedsE {T : Type} {f : listOp_func typ}
         {p : ptrn (typ * typ) T} {res : T} {pok : ptrn_ok p} :
    SucceedsE f (fptrnCombine p) res := {
      s_result := exists t u, Succeeds (t, u) p res /\ f = pCombine t u;
      s_elim := @Succeeds_fptrnCombine T f p res pok
    }.

End MakeListOp.

Section PtrnListOp.
  Context {typ func : Set} {RType_typ : RType typ}.
  Context {FV : PartialView func (listOp_func typ)}.

(* Putting this in the previous sectioun caused universe inconsistencies
  when calling '@mkLength typ func' in JavaFunc (with typ and func instantiated) *)

  Definition ptrnLength {T A : Type}
             (p : ptrn typ T) (a : ptrn (expr typ func) A) : ptrn (expr typ func) (T * A) :=
    app (inj (ptrn_view _ (fptrnLength p))) a.

  Definition ptrnNoDup {T A : Type}
             (p : ptrn typ T) (a : ptrn (expr typ func) A) : ptrn (expr typ func) (T * A) :=
    app (inj (ptrn_view _ (fptrnNoDup p))) a.

  Definition ptrnIn {T A B : Type}
             (p : ptrn typ T) (a : ptrn (expr typ func) A) (b : ptrn (expr typ func) B) :
    ptrn (expr typ func) (T * A * B) :=
    app (app (inj (ptrn_view _ (fptrnIn p))) a) b.

  Definition ptrnMap {T A B : Type}
             (p : ptrn (typ * typ) T) (a : ptrn (expr typ func) A)
             (b : ptrn (expr typ func) B) : ptrn (expr typ func) (T * A * B) :=
    app (app (inj (ptrn_view _ (fptrnMap p))) a) b.

  Definition ptrnFold {T A B C : Type}
             (p : ptrn (typ * typ) T) (a : ptrn (expr typ func) A)
             (b : ptrn (expr typ func) B) (c : ptrn (expr typ func) C) :
    ptrn (expr typ func) (T * A * B * C) :=
    app (app (app (inj (ptrn_view _ (fptrnFold p))) a) b) c.

  Definition ptrnCombine {T A B : Type}
             (p : ptrn (typ * typ) T) (a : ptrn (expr typ func) A)
             (b : ptrn (expr typ func) B) : ptrn (expr typ func) (T * A * B) :=
    app (app (inj (ptrn_view _ (fptrnCombine p))) a) b.

End PtrnListOp.

Require Import MirrorCore.Reify.ReifyClass.

Section ReifyListOp.

  Polymorphic Context {typ func : Set} {FV : PartialView func (listOp_func typ)}.
  Polymorphic Context {t : Reify typ}.

  Polymorphic Definition reify_length : Command (expr typ func) :=
    CPattern (ls := (typ:Type)::nil)
             (RApp (RExact (@length)) (RGet 0 RIgnore))
             (fun (x : function (CCall (reify_scheme typ))) => Inj (fLength x)).

  Polymorphic Definition reify_NoDup : Command (expr typ func) :=
    CPattern (ls := (typ:Type)::nil)
             (RApp (RExact (@NoDup)) (RGet 0 RIgnore))
             (fun (x : function (CCall (reify_scheme typ))) => Inj (fNoDup x)).

  Polymorphic Definition reify_In : Command (expr typ func) :=
    CPattern (ls := (typ:Type)::nil)
             (RApp (RExact (@In)) (RGet 0 RIgnore))
             (fun (x : function (CCall (reify_scheme typ))) => Inj (fIn x)).

  Polymorphic Definition reify_map : Command (expr typ func) :=
    CPattern (ls := (typ:Type)::(typ:Type)::nil)
             (RApp (RApp (RExact (@map)) (RGet 0 RIgnore)) (RGet 1 RIgnore))
             (fun (x y : function (CCall (reify_scheme typ))) => Inj (fMap x y)).

  Polymorphic Definition reify_fold : Command (expr typ func) :=
    CPattern (ls := (typ:Type)::(typ:Type)::nil)
             (RApp (RApp (RExact (@fold_right)) (RGet 0 RIgnore)) (RGet 1 RIgnore))
             (fun (x y : function (CCall (reify_scheme typ))) => Inj (fFold x y)).

  Polymorphic Definition reify_combine : Command (expr typ func) :=
    CPattern (ls := (typ:Type)::(typ:Type)::nil)
             (RApp (RApp (RExact (@combine)) (RGet 0 RIgnore)) (RGet 1 RIgnore))
             (fun (x y : function (CCall (reify_scheme typ))) => Inj (fCombine x y)).

  Polymorphic Definition reify_listOp : Command (expr typ func) :=
    CFirst (reify_length :: reify_NoDup :: reify_In ::
            reify_map :: reify_fold :: reify_combine :: nil).

End ReifyListOp.

Arguments reify_listOp _ _ {_ _}.


(**************************************************************************)
(*                                                                        *)
(*     CoqParam                                                           *)
(*     Copyright (C) 2012                                                 *)
(*                                                                        *)
(*     Chantal Keller                                                     *)
(*     Marc Lasson                                                        *)
(*                                                                        *)
(*     INRIA - École Polytechnique - ÉNS de Lyon                          *)
(*                                                                        *)
(*   This file is distributed under the terms of the GNU Lesser General   *)
(*   Public License                                                       *)
(*                                                                        *)
(**************************************************************************)

Add LoadPath "..".

(* This commands loads the Coq plugin *)

Declare ML Module "abstraction".

(* [Abstraction] is a vernacular command that takes as arguments:
     - a constant, an inductive or a term n
     - a list of identifiers of length:
       - 0 or 1 in the case of a constant
       - 0 or (number of inductives and constructors) in the case of an
       inductive
       - 1 in the case of a term.
   It computes the parametricity relation generated by the type of n,
   and a proof that n satifies it. The proof is placed in the
   identifiers if some are given, or in arbitrary identifiers otherwise.
   *)

Definition unit := forall A:Prop,A -> A.
Abstraction unit unit_R.
Print unit_R.

Definition id : unit := (fun (A:Prop) (x:A) => x).
Abstraction id.
Check id_R.

Abstraction (forall A:Prop, A) false_R.
Check false_R.

Abstraction nat.
Print nat_R.

Abstraction nat nat_R2 O_R2 S_R2.
Print nat_R2.

(* This section is an example of the [param] tactic. Its syntax is
   [param t as n], and it behaves like [Abstraction t n], inside a Coq
   proof. *)

Section Church.

  Fixpoint iter k (α : Set) f z : α :=
    match k with
      | 0 => z
      | S p => f (iter p α f z)
    end.

  Lemma church_exists :
    let f := (fun (A:Set) (f:A -> A) (z:A) => f (f z)) in
      exists k:nat,
      forall (α : Set) (g : α -> α) z,
        iter k α g z = f α g z.
    intro f.
    exists (f nat S O).
    param (fun (A:Set) (f:A -> A) (z:A) => f (f z)) as H.
    intros α g z; apply (H α nat).
    intros H0 H1 H2; simpl; rewrite H2; reflexivity.
    reflexivity.
  Qed.

  Print church_exists.

  Print Assumptions church_exists.

End Church.


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 I : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ B D /\ (wd_ A D /\ (wd_ C D /\ (wd_ B I /\ (wd_ I A /\ (wd_ B A /\ (wd_ C I /\ (col_ A B C /\ (col_ B I A /\ (col_ C D I /\ col_ A B D))))))))))))) -> col_ A C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


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 M : Universe, ((wd_ A C /\ (wd_ B D /\ (wd_ M B /\ (wd_ M A /\ (wd_ M C /\ (wd_ M D /\ (col_ A B C /\ (col_ A M C /\ (col_ B M D /\ (col_ A B M /\ col_ M D C)))))))))) -> col_ A B D)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj10synthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus lv0 lv1) lv2) (plus (plus lv2 lv0) lv1)).
Admitted.
QuickChick conj10synthconj1.


From HoTT Require Import Basics.
From HoTT Require Import Categories.
From HoTT Require Import Categories.Category.Morphisms.
From HoTT Require Import Spaces.Finite.
From HoTT Require Import Categories.InitialTerminalCategory.Functors.
From HoTT Require Import Categories.Adjoint.UnitCounit.
Require Import Misc.
Require Import Limits.Graph.
Require Import Limits.Product.
Require Import Limits.Terminal.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope morphism.
Local Open Scope object.

Section ExponentialObject.
  Context {HF : Funext}.
  Context {C : PreCategory}.
  Context {x y : object C}.
  Context {P : forall z, Product z y}.
  Let F := ProdRFunctor y P.

  Record ExponentialObject :=
    { eobject : object C
    ; ev : morphism C (F _0 eobject) x
    ; currying {z : object C} :
       forall(e : morphism C (prod_obj (P z)) x),
         Contr { u : morphism C z eobject
                     & ev o (F _1 u) = e }
    }.
  Definition curry {z : object C} (E : ExponentialObject) :
    morphism C (prod_obj (P z)) x -> morphism C z (eobject E) :=
    fun e => proj1 (@center _ (currying E e)).
  Lemma curry_comm {z : object C} (E : ExponentialObject) :
    forall(e : morphism C (prod_obj (P z)) x),
      ev E o (F _1 (curry E e)) = e.
  Proof. intro e. exact (proj2 (@center _ (currying E e))). Qed.
  Lemma curry_uniq {z : object C} (E : ExponentialObject) :
    forall(e : morphism C (prod_obj (P z)) x),
    forall(u : morphism C z (eobject E)),
      ev E o (F _1 u) = e -> curry E e = u.
  Proof.
    intros e u H. unfold curry. destruct (currying E e) as [ [ u' Hcomm ] Huniq ]; simpl.
    apply (ap proj1 (Huniq (u;H))).
  Qed.

  Definition curry_inv {z : object C} (E : ExponentialObject) :
    morphism C z (eobject E) -> morphism C (prod_obj (P z)) x := fun g => ev E o (F _1 g).
  Lemma curry_inv_L {z : object C} (E : ExponentialObject) :
    forall(e : morphism C (prod_obj (P z)) x), curry_inv E (curry E e) = e.
  Proof. apply curry_comm. Qed.
  Lemma curry_inv_R {z : object C} (E : ExponentialObject) :
    forall(e : morphism C z (eobject E)), curry E (curry_inv E e) = e.
  Proof. intro e. apply curry_uniq. reflexivity. Qed.

  Definition curry_mph (z : object C) (E : ExponentialObject) :
    morphism set_cat
             (Build_HSet (morphism C (prod_obj (P z)) x))
             (Build_HSet (morphism C z (eobject E))) :=
    fun e => curry E e.
  Definition curry_inv_mph (z : object C) (E : ExponentialObject) :
    morphism set_cat
             (Build_HSet (morphism C z (eobject E)))
             (Build_HSet (morphism C (prod_obj (P z)) x)) :=
    fun e => curry_inv E e.
End ExponentialObject.

Arguments ExponentialObject {C} (x y) P.
Global Instance curryIso `{Funext} {C : PreCategory} {x y z : object C}
       {P : forall z, Product z y} (E : ExponentialObject x y P)
  : IsIsomorphism (curry_mph z E).
Proof.
  srapply Build_IsIsomorphism; [ exact (curry_inv_mph z E) | | ];
    apply path_forall; intro e;
    [ apply curry_inv_L | apply curry_inv_R ].
Defined.

Definition AllExponentials {C : PreCategory} (P : AllProducts C) :=
  forall(x y : object C), ExponentialObject x y (fun z => P z y).

Module ExpFunctor.
  Section ExponentialFunctor.
    Context {D C : PreCategory}.
    Context (F : Functor D (C * C^op)).
    Context (P : forall(d : object D), forall(x : object C), Product x (snd (F _0 d))).
    Context (E : forall(d : object D), ExponentialObject (fst (F _0 d)) (snd (F _0 d)) (P d)).
    Let G (d : object D) : Functor C C.
    Proof. refine (ProdRFunctor _ (P d)). Defined.

    Definition ExponentialFunctor : Functor D C.
    Proof.
      srapply Build_Functor.
      - intro d. exact (eobject (E d)).
      - intros s d m; simpl. refine (curry (E d) _). refine (_ o ev (E s) o _).
        + exact (fst (F _1 m)).
        + refine (proj1 (product_ex (P s (eobject (E s))) _ (pi1 _) (_ o pi2 (P d (eobject (E s)))))).
          exact (snd (F _1 m)).
      - intros s d1 d2 m1 m2; simpl. apply curry_uniq.
        rewrite (composition_of (G d2)).
        rewrite <- associativity. rewrite (curry_comm (E d2)).
        rewrite associativity. unfold G; unfold ProdRFunctor; simpl.
        rewrite <- (left_identity _ _ _ (pi1 (P d2 (eobject (E d1))))).
        rewrite product_ex_comm. rewrite left_identity. rewrite left_identity.
        rewrite <- (left_identity C _ _ (_ o pi2 (P d2 (eobject (E s))))).
        erewrite <- product_ex_comm. rewrite left_identity.
        instantiate (1 := P d1 (eobject (E s))). rewrite <- associativity.
        rewrite (associativity _ _ _ _ _ _ (ev (E d1))).
        pose (Hcomm := curry_comm (E d1)
                                  (fst (F _1 m1) o ev (E s)
                                      o (product_ex (P s (eobject (E s))) _
                                                    (pi1 (P d1 (eobject (E s))))
                                                    ((snd (F _1 m1) : morphism C _ _) o pi2 (P d1 (eobject (E s))))).1)).
        unfold ProdRFunctor in Hcomm; simpl in Hcomm. rewrite left_identity in Hcomm.
        rewrite Hcomm. clear Hcomm.
        rewrite <- associativity. rewrite <- associativity. rewrite (composition_of F); simpl.
        rewrite <- (left_identity _ _ _ (pi1 (P d2 (eobject (E s))))).
        rewrite (associativity _ _ _ _ _ _
                              (snd (F _1 m2) : morphism C _ _) (snd (F _1 m1) : morphism C _ _)).
        rewrite <- (product_ex_comm (P d1 (eobject (E s))) (P s (eobject (E s)))).
        rewrite <- associativity. repeat rewrite left_identity. reflexivity.
      - intro x; simpl. apply curry_uniq.
        rewrite (identity_of F). simpl. repeat rewrite left_identity. reflexivity.
    Defined.
  End ExponentialFunctor.
End ExpFunctor.

Definition ExponentialFunctor {C : PreCategory} {P : AllProducts C} (E : AllExponentials P) :
  Functor (C * C^op) C :=
  ExpFunctor.ExponentialFunctor 1%functor (fun d x => P x (snd d)) (fun d => E (fst d) (snd d)).
Definition ExponentiateFunctor {C : PreCategory} (Y : object C)
           {P : forall X, Product X Y} (E : forall X, ExponentialObject X Y P) :
  Functor C C :=
  ExpFunctor.ExponentialFunctor
    ((1, !(Y : object C^op)) o ProductLaws.Law1.inverse C)%functor
    (fun d => P) E.
Definition ExponentiatingFunctor {C : PreCategory} (X : object C)
           {P : AllProducts C} (E : forall Y, ExponentialObject X Y (fun X => P X Y)) :
  Functor C^op C :=
  ExpFunctor.ExponentialFunctor
    ((!X,1) o ProductLaws.Law1.inverse' C^op)%functor
    (fun d x => P x d) E.

Section ExponentialAdjunction.
  Context {C : PreCategory}.
  Context (Y : object C).
  Context {P : forall X, Product X Y}.
  Context (E : forall X, ExponentialObject X Y P).

  Let Fe := ExponentiateFunctor E.
  Let Fp := ProdRFunctor Y P.

  Lemma curry_comp {a b c : object C} :
    forall(m1 : morphism C (prod_obj (P a)) b),
    forall(m2 : morphism C b c),
      curry (E c) (m2 o ev (E b)) o curry (E b) m1 = curry (E c) (m2 o m1).
  Proof.
    intros m1 m2. symmetry. apply curry_uniq.
    rewrite (composition_of (ProdRFunctor Y P)). rewrite <- associativity.
    rewrite curry_comm. rewrite associativity. rewrite curry_comm.
    reflexivity.
  Qed.

  Definition exp_unit : NaturalTransformation 1 (Fe o Fp).
  Proof.
    srapply Build_NaturalTransformation.
    - intro c; simpl. apply curry. exact 1.
    - intros s d m; simpl. repeat rewrite left_identity.
      rewrite product_ex_id. rewrite right_identity.
      rewrite curry_comp. rewrite right_identity.
      symmetry. apply curry_uniq. rewrite composition_of.
      rewrite <- associativity. rewrite curry_comm.
      simpl. repeat rewrite left_identity. reflexivity.
  Defined.
  Definition exp_counit : NaturalTransformation (Fp o Fe) 1.
  Proof.
    srapply Build_NaturalTransformation.
    - intro c; simpl. apply ev.
    - intros s d m; simpl. rewrite left_identity.
      rewrite product_ex_id. rewrite right_identity.
      pose (Hcomm := curry_comm (E d) (m o ev (E s))). simpl in Hcomm.
      rewrite left_identity in Hcomm. rewrite Hcomm. reflexivity.
  Defined.

  Theorem ExponentialAdjunction : Fp -| Fe.
  Proof.
    refine {| unit := exp_unit; counit := exp_counit; |}.
    - intro c; simpl. rewrite curry_comm. reflexivity.
    - intro c; simpl. rewrite left_identity. rewrite product_ex_id.
      rewrite right_identity. rewrite curry_comp. rewrite right_identity.
      apply curry_uniq. rewrite identity_of. apply right_identity.
  Qed.

End ExponentialAdjunction.

Section ExponentialFromAdjunction.
  Context {C : PreCategory}.
  Context (Y : object C).
  Context {P : forall X, Product X Y}.
  Context {F : Functor C C}.
  Let Fp := ProdRFunctor Y P.
  Context (Adj : Fp -| F).

  Theorem ExponentialFromAdjunction : forall X, ExponentialObject X Y P.
  Proof.
    intro X. simple refine {| eobject := F _0 X; ev := counit Adj X; |}.
    intros z e. simpl in e. srapply Build_Contr.
    - exists (F _1 e o unit Adj z). rewrite composition_of. rewrite <- associativity.
      rewrite (commutes (counit Adj)). rewrite associativity.
      rewrite (unit_counit_equation_1 Adj). simpl. apply right_identity.
    - intros [ u Hu ]; simpl.
      assert (u = F _1 e o unit Adj z) as Heq.
      { rewrite <- Hu. rewrite composition_of.
        rewrite associativity. rewrite <- (commutes (unit Adj)).
        rewrite <- associativity. rewrite (unit_counit_equation_2 Adj).
        rewrite left_identity. reflexivity. }
      generalize dependent Hu. rewrite Heq. intro Hu. f_ap. apply hset_has_UIP.
      apply trunc_morphism.
  Qed.

End ExponentialFromAdjunction.


Require Import ExtLib.Core.RelDec.

Require Import MirrorCore.RTac.RTac.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.Red.
Require Import MirrorCore.TypesI.

Require Import Charge.ModularFunc.ILogicFunc.

Section IntroTac.
	Context {typ func subst : Type}.
	Context {HIL : ILogicFunc typ func}.
	Context {RType_typ : RType typ}.
    Context {Typ0_tyProp : Typ0 RType_typ Prop}.
    Context {Heq : RelDec (@eq typ)}.
    Context {EV : ExprVar (expr typ func)}.
    Context {EU : ExprUVar (expr typ func)}.

    Let tyProp : typ := @typ0 _ _ _ _.

	Definition fintro e : option (@OpenAs typ (expr typ func)) :=
		match e with
			| App (Inj f) P =>
				match ilogicS f with
				  | Some (ilf_forall t t') =>
				  	if t' ?[ eq ] tyProp then
				  		Some (AsAl t (fun x => beta (App P x)))
				  	else
				  		None
				  | Some (ilf_exists t t') =>
				  	if t' ?[ eq ] tyProp then
				  		Some (AsEx t (fun x => beta (App P x)))
				  	else
				  		None
				  | _ => None
				end
			| App (App (Inj f) P) Q =>
				match ilogicS f with
				  | Some (ilf_impl t') =>
				  	if t' ?[ eq ] tyProp then
				  		Some (AsHy P Q)
				  	else
				  		None
(*				  | Some (ilf_entails t) =>
				    match Q with
				      | App (Inj g) Q' =>
				        match ilogicS g with
				          | Some (ilf_exists t' t'') =>
				            Some (AsEx t' (fun x => mkEntails t (lift 0 1 P) (beta (App Q' x))))
				          | _ => None
				        end
				      | _ => None
				    end*)
				  | _ => None
				end
			| _ => None
		end.

	Definition INTRO := @INTRO typ (expr typ func) EV EU fintro.

End IntroTac.

Implicit Arguments INTRO [[HIL] [RType_typ] [Typ0_tyProp] [Heq] [EU] [EV]].


From Coq.Logic Require Import FunctionalExtensionality ProofIrrelevance.
From mathcomp Require Import ssreflect ssrfun eqtype bigop choice path seq fintype.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
    From mathcomp Require Import ssrbool.
Set Warnings "parsing".
Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Require Export Path ntPathPairs PathAlgebraMul PathAlgebra.
Require Export Algebras Basis Submodule FreeModules Quiver FormalLC.
Open Scope ring_scope.
Set Implicit Arguments.
Unset Strict Implicit.

Module PAlgBasis.
Include ntPath.NTPath.Exports.

  Section Def.
    Variable (R : comRingType) (Q : finQuiverType).

    Definition pathAlgBasis := formalLC.basis R (Path.eqType Q).

    Section Element.
      Definition elem : pathType Q -> pathAlgType R Q
      := pathAlgBasis.

    Lemma idemR : forall (p : pathType Q),
      (elem p) * (elem \e_(Path.tail p)) = (elem p).
    Proof. move=>p; rewrite /(GRing.mul _)=>/=.
    rewrite /PAMul.Mul/elem=>/=.
    rewrite /formalLC.elem=>/=.
    apply functional_extensionality=>p'.
    case (p' == p) as []eqn:E.
      apply (rwP eqP) in E; rewrite E.
      case p as [i|r]eqn:P.
      by rewrite /Path.BuildPairs big_cons big_nil eq_refl GRing.mul1r GRing.addr0=>/=.

      destruct r as [[a r] H].
      clear P E.
    Admitted.

    Lemma idemL : forall (p : pathType Q),
      (elem \e_(Path.head p)) * (elem p) = (elem p).
    Proof. move=> p. Admitted.

    Lemma idem : forall (i : \V_Q),
      (elem \e_i) * (elem \e_i) = (elem \e_i).
    Proof. move=>i; apply(idemR \e_i). Qed.
  End Element.

(*    Definition pathAlgBasisSet := formalLC.genSet R (Path.Path_eqType Q).
    Definition pathAlgBasis := lmodBasisSet.Pack (lmodBasisSet.Class
      (lmodBasisSet.Mixin
        (fun p : pathAlgBasisSet => @formalLC.pathApplyLin R (Path.Path_eqType Q) p)
      )).*)
    Definition freePathAlgType := freeLmod.Build pathAlgBasis.
  End Def.

  Lemma OneIsFiniteSum (R : comRingType) {Q : finQuiverType} :
    1%R = \big[+%R/0%R]_(i : \V_Q)(elem R \e_i).
  Proof.
    rewrite/(GRing.one _)=>/=.
    apply functional_extensionality=>p.
    assert(formalLC.pathApplyLin p (PAMul.One R Q) = formalLC.pathApplyLin p(\big[+%R/0]_i elem R \e_ (i))). {
    rewrite GRing.raddf_sum=>/=.
    rewrite /formalLC.pathApply/PAMul.One/elem.
    case p as [a|a]. {
    rewrite -big_mkcond=>/=.
    rewrite (eq_bigl _ _ (inj_eq _ a)).
    by rewrite (eq_bigl _ _ (eq_sym _)) big_pred1_eq.
    by move=>x y H; inversion H. } {
    rewrite big_mkcond=>/=.
    by rewrite big1_eq. } }
    by rewrite /formalLC.pathApply in H.
  Qed.

  Module Exports.
  Notation "\B[ R ]( p )" := (elem R p) (at level 0).
  Notation pathAlgBasis := pathAlgBasis.
  Notation freePathAlgType := freePathAlgType.
  End Exports.
End PAlgBasis.
Export PAlgBasis.Exports.

Module PAlgSub.
  Module Rmul.
    Section Def.
      Variable (R : comRingType) (Q : finQuiverType) (i : \V_Q).
      Definition inSet
       := fun x : (lmods.ringMod (pathAlgType R Q)) => x == (x*\B[R](\e_i)).

      Lemma subModule
       : GRing.submod_closed (subLmod.qualSubElem inSet).
      Proof. split=>[|a x y];rewrite qualifE !unfold_in.
      by rewrite GRing.mul0r eq_refl.
      rewrite -!(rwP eqP)=>Hx Hy;
      by rewrite Hx Hy GRing.mulrDl -!GRing.mulrA !PAlgBasis.idem.
      Qed.
      Canonical lmodType := subLmod.Pack subModule.
    End Def.
    Section Basis.
      Variable (R : comRingType) (Q : finQuiverType) (i : \V_Q).
      Definition elem (p : {p : pathType Q | (Path.tail p == i)}) : pathAlgType R Q
       := fun p' => if p' == (sval p) then 1 else 0.

      Lemma elem_inj : injective elem. Proof.
        move=> x y. destruct x as [x Hx], y as [y Hy]=>H.
        refine (eq_sig_hprop _ _ _ _).
        move=> x' p' q'; apply proof_irrelevance=>/=.
        rewrite /elem in H. simpl in H.
        assert (A := equal_f H x); rewrite eq_refl in A.
        case(x == y) as []eqn:E; [by apply (rwP eqP) in E|apply (rwP eqP) in A].
        assert (P := GRing.oner_eq0 R).
        by rewrite A in P.
      Qed.

      Lemma elem_nondeg : non_degenerate elem. Proof.
        rewrite /elem=> x.
        apply (rwP negP); rewrite /not -(rwP eqP)=>H.
        destruct x as [x Hx].
        assert (A := equal_f H x); rewrite eq_refl in A.
        rewrite /(GRing.zero _) in A; simpl in A.
        rewrite /formalLC.Zero in A.
        apply (rwP eqP) in A.
        by rewrite (GRing.oner_eq0 R) in A. Qed.
(*
      Lemma elem_li : lmodBasis.LISet.axiom (lmodSet.Build elem_inj elem_nondeg).
      Proof. rewrite /elem=> f coef =>H finb; move:H.
        rewrite -(rwP eqP)=>H. Admitted.

    Lemma span : @inf_spanning _ _ (lmodSet.Build elem_inj elem_nondeg) (fun x => (@PAlgBasis.pathApplyLin R Q (sval x))).
    Proof. move=>el. Admitted.
*)
(*
    Lemma coef_one : lmodBasis.axiom_coef_one (infGenSet.Mixin span).
    Proof. move=>b; rewrite/infGenCoef=>/=; by rewrite/PAlgBasis.pathApply/elem !eq_refl. Qed.

    Lemma coef_zero : infBasis.axiom_coef_zero (infGenSet.Mixin span).
    Proof. move=>b1 b2; rewrite/infGenCoef=>/=; rewrite/PAlgBasis.pathApply/elem/not=>H.
      case (sval b1 == sval b2) as []eqn:E; [apply (rwP eqP) in E | rewrite eq_refl].
Admitted.
*)
(*      by contradict(H (@eq_sig_hprop _ _ 5 b1 b2 E)).
    Qed.

    Lemma pathApplyLin_one : forall b, PAlgBasis.pathApplyLin R (sval b) (elem b) == 1.
      Proof. simpl; rewrite /PAlgBasis.pathApply/elem=>b/=; by rewrite !eq_refl. Qed.
    Lemma pathApplyLin_zero : forall b1 b2, b1 <> b2 -> PAlgBasis.pathApplyLin R (sval b1) (elem b2) == 0.
    Proof. rewrite /PAlgBasis.pathApply/elem=>b1 b2/=; rewrite /not=> H.
      case(b1 == b2) as []eqn:E=>//.
      by apply (rwP eqP) in E.
       rewrite /PAlgBasis.pathApply.
Admitted.
*) (*
      Definition basis : lmodBasisType _
       := lmodBasis.Build elem_li span.*)
    End Basis.
  End Rmul.

  Close Scope ring_scope.

  Module Exports.
    Canonical Rmul.lmodType.
    (*Notation AlgModToRingMod := AlgModToRingMod.*)
    Notation Rmul := Rmul.lmodType.
    Notation "'[alg ' R Q '\e_' i ']'" := (Rmul.lmodType R Q i) (at level 0).
  End Exports.

End PAlgSub.
Export PAlgSub.Exports.


(* coproducts are computed pointwise in the category of left modules
This is redundant with LModulesColims, but maybye more convenient to use ? Cf HArityCoproducts
to compare both uses
(inspired by LModulesColims )
commutation with pullbacks [coprod_pbm_to_pbm_coprod] TODO en faire un iso
 *)

Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.
Local Open Scope cat.

Section ColimsModule.
  Context
          {C : category}
          {O : UU} (cpC : Coproducts O C)
          {B : category} {R:Monad B}.
  Local Notation cpFunc := (Coproducts_functor_precat _ B _ cpC).
  Local Notation MOD := (category_LModule R C).
  Variable (d : O -> MOD).
  (* Local Notation FORGET := (forget_LMod R (C ,, hsC)). *)
  Local Notation d'  := ( fun x => (d x : LModule _ _) : functor _ _).
  (* [B , C , hsC] ). *)
  (* The natural candidate *)
  Local Notation F := (CoproductObject  _ _ (cpFunc d') : functor _ _).
  (* Local Notation F' := (lim (limFunc d') : functor _ _). *)
  (* Local Notation BP := (binproduct_functor bpC). *)

  (* Is there a lemma that state the existence of a natural transformation
  (A x B) o R --> A o R x B o R  ? *)
  (* TODO define it without nat_trans *)
  Definition LModule_coproduct_mult_data (x : B) : C ⟦ (R ∙ F) x, F x ⟧.
    use CoproductOfArrows.
    - intro v.
      cbn.
      use lm_mult.
  Defined.

  Lemma LModule_coproduct_mult_is_nat_trans : is_nat_trans _ _  LModule_coproduct_mult_data.
  Proof.
    intros x y f.
    etrans; [use CoproductOfArrows_comp|].
    apply pathsinv0.
    etrans; [use CoproductOfArrows_comp|].
    use maponpaths.
    apply funextsec.
    intro i.
    apply pathsinv0.
    apply (nat_trans_ax (lm_mult R _)).
  Qed.

  Definition LModule_coproduct_mult : R ∙ F ⟹ F :=
    (_ ,, LModule_coproduct_mult_is_nat_trans).

  Definition LModule_coproduct_data : LModule_data R C :=
    (F ,, LModule_coproduct_mult).

  Lemma LModule_coproduct_laws : LModule_laws _ LModule_coproduct_data.
  Proof.
    split.
    - intro x.
      etrans; [use CoproductOfArrows_comp|].
      cbn.
      apply pathsinv0            .
      apply CoproductArrowUnique.
      (* etrans; [use precompWithColimOfArrows|]. *)
      intro u.
      cbn.
      rewrite id_right.
      apply pathsinv0.
      etrans;[|apply id_left].
      apply cancel_postcomposition.
      apply LModule_law1.
    - intro x.
      etrans; [use CoproductOfArrows_comp|].
      apply pathsinv0.
      etrans; [use CoproductOfArrows_comp|].
      use maponpaths.
      apply funextsec.
      intro i.
      apply pathsinv0.
      apply LModule_law2.
  Qed.

  Definition LModule_coproduct : LModule R C := (_ ,, LModule_coproduct_laws).

  Lemma LModule_coproductIn_laws v :
    LModule_Mor_laws R
                     (T := (d v : LModule _ _)) (T' := LModule_coproduct)
      ((CoproductIn  _ _ ( (cpFunc d')) v : nat_trans _ _) ).
  Proof.
    intro c.

    cbn.
    unfold LModule_coproduct_mult_data.
    set (CC1 := cpC _ ).
    set (CC2 := cpC _ ).
    use (CoproductOfArrowsIn _ _ CC1 CC2).
  Defined.

  Definition LModule_coproductIn v : MOD ⟦ d v, LModule_coproduct ⟧ :=
    _ ,, LModule_coproductIn_laws v.

  Definition LModule_coproductArrow_laws {M : LModule R C} (cc : ∏ o, MOD ⟦ d o, M ⟧) :
    LModule_Mor_laws
      _ (T := LModule_coproduct) (T' := M)
      (CoproductArrow _ _ (cpFunc d') (c := M : functor _ _) (fun o => ((cc o : LModule_Mor _ _ _) :
                                                                    nat_trans _ _))).
  Proof.
    intro c.
    apply pathsinv0.
    cbn.
    unfold LModule_coproduct_mult_data.
    cbn.
    unfold coproduct_nat_trans_data.
    etrans;[apply precompWithCoproductArrow|].
    apply pathsinv0.
    etrans.
    apply postcompWithCoproductArrow.
    apply maponpaths.
    apply funextsec.
    intro i.
    apply LModule_Mor_σ.
  Qed.

  Definition LModule_coproductArrow {M : LModule R C} (cc : ∏ o, MOD ⟦ d o, M ⟧) :
    LModule_Mor _ LModule_coproduct M := _ ,, LModule_coproductArrow_laws  cc.

  Lemma LModule_isCoproduct : isCoproduct _ _  _ _ LModule_coproductIn.
    intros M cc.
    use unique_exists.
    - exact (LModule_coproductArrow cc).
    - intro v.
      apply LModule_Mor_equiv;[exact C|].
      apply (CoproductInCommutes _ _ _ (cpFunc d')).
    - intro y.
      cbn -[isaprop].
      apply  impred_isaprop.
      intro u.
      use has_homsets_LModule.
    - cbn.
      intros y h.
      apply LModule_Mor_equiv;[exact C|].
      apply (CoproductArrowUnique _ _ _ (cpFunc d')).
      intro u.
      exact (  maponpaths pr1 (h u)).
  Defined.

  Definition LModule_Coproduct : Coproduct _ _ d :=
    make_Coproduct  _ _ _ _ _ LModule_isCoproduct.

End ColimsModule.

Definition LModule_Coproducts (C : category) {B : category}
           {O : UU}
           (R : Monad B)
           (cpC : Coproducts O C)
  (* (colims_g : Colims_of_shape g C) *)
           (d : O → category_LModule R C)
            : Coproduct O (category_LModule R C) d :=
   LModule_Coproduct  cpC d.

Section pullback_coprod.
  Context {C : category} {B : category}.
  Context {R : Monad B}{S : Monad B} (f : Monad_Mor R S).

  Context {O : UU}.
  Context {cpC : Coproducts O C}.

  Let cpLM (X : Monad B) := LModule_Coproducts C  X cpC.
  Let cpFunc := Coproducts_functor_precat _ B _ cpC .

  Context (α : O -> LModule S C ).

  Let αF : O -> functor B C := fun o => α o.
  Let pbm_α : O -> LModule R C := fun o => pb_LModule f (α o).

  Definition pbm_coprod := pb_LModule f (CoproductObject _ _ (cpLM _ α)).
  Definition coprod_pbm : LModule _ _ := CoproductObject _ _ (cpLM _ pbm_α).

  Lemma coprod_pbm_to_pbm_coprod_aux :
    ∏ c : B,
          (LModule_coproduct_mult cpC pbm_α) c =
          (pb_LModule_σ f (CoproductObject O (category_LModule S C) (cpLM S α))) c.
  Proof.
    intro b.
    apply pathsinv0.
    apply CoproductOfArrows_comp.
  Defined.

  Definition coprod_pbm_to_pbm_coprod : LModule_Mor  _ coprod_pbm pbm_coprod :=
    LModule_same_func_Mor coprod_pbm_to_pbm_coprod_aux  _ _.

End pullback_coprod.


From stdpp Require Import prelude fin_maps.

Section refresh_map.

Context
  `{Infinite K}
  `{FinMap K M}.

Fixpoint refresh_map' `{Fresh K C, Union C, Singleton K C}
    (orig : list K) (X : C) : M K :=
  match orig with
  | [] => empty
  | x :: orig => let x' := fresh X in insert x x' (refresh_map' orig ({[ x' ]} ∪ X))
  end.

Definition refresh_map `{Fresh K C, FinSet K C} (orig : list K) (X : C) : M K :=
  refresh_map' orig (X ∪ list_to_set orig).

End refresh_map.


From mathcomp Require Import ssreflect ssrfun.
From mathcomp Require Import eqtype fintype choice.
From mathcomp Require Import generic_quotient bigop seq.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool.
Set Warnings "parsing".
Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Set Implicit Arguments.
Unset Strict Implicit.

Module TensorSubGroupGenerators.
  Section Def.
  Variable (R : ringType) (M N : lmodType R).
    Open Scope ring_scope.
    Inductive PosGen :=
      |gen1 : M -> N -> N -> PosGen
      |gen2 : M -> M -> N -> PosGen
      |gen3 : M -> R -> N -> PosGen.

    Definition PosGenVal
      (gen : PosGen) := match gen with
        |gen1 m n n' => (m,n) + (m,n') - (m, n + n')
        |gen2 m m' n => (m,n) + (m',n) - (m - m', n)
        |gen3 m r n => (r *: m, n) - (m, r *: n)
      end.

    Definition Gen := (PosGen + PosGen)%type.
    Definition GenVal (gen : Gen) :=
      match gen with
        |inl g => PosGenVal g
        |inr g => -PosGenVal g
      end.

  Definition negateGen (gen : Gen) :=
    match gen with inl t => inr t | inr t => inl t end.
  End Def.
End TensorSubGroupGenerators.

Require Import FreeModules Quotient Submodule Algebras FormalLC.
Module Tensor.
  Section Def.
    Variable (R : comRingType) (M N : lmodType R).

    Definition freeModule := formalLCType R (M*N).

    Lemma tensorP : forall m : freeModule, reflect (exists L : seq (R * Gen)%type, (\sum_(t <- L) t.1 *: ?f t.2)%R == m) (?inSub m).
    Definition subModule := subLmodGen 4.

    Axiom getGens : forall (p : M*N), option {L : seq (TensorSubGroupGenerators.Gen M N) | p == \big[+%R/0%R]_(l <- L)(TensorSubGroupGenerators.GenVal l)}.
    Definition isIn (p : M*N) := if getGens p is None then false else true.
    Axiom closedSubMod : submod_closed (subLmod.qualSubElem isIn).
    Definition Subgroup := subLmod.Pack closedSubMod.
    Definition type := quotLmod Subgroup.
  End Def.

  Section AlgDef.
  Open Scope ring_scope.
  Variable (R : ringType) (A : lalgType R) (M : lmodType A) (N : lmodType R).

  Definition Scale (a : A) (x : type (lmods.AtoRmod M) N) : type (lmods.AtoRmod M) N
    := \pi (a *: (repr x).1, (repr x).2).

  Lemma scale_axiom : forall (a b : A) (v : type (lmods.AtoRmod M) N),
    Scale a (Scale b v) = Scale (a * b) v.
  Proof. rewrite/Scale=> a b x=>/=. Admitted.

  Lemma scale_left_id : left_id 1 Scale.
  Proof. rewrite/Scale=> x=>/=; rewrite GRing.scale1r=>/=. destruct x. destruct erepr. Admitted.

  Lemma scale_right_d : right_distributive Scale +%R.
  Proof. rewrite/Scale=> a y z=>/=. Admitted.

  Axiom algMixin : GRing.Lmodule.mixin_of A (type (lmods.AtoRmod M) N). (* := LmodMixin scale_axiom scale_left_id scale_right_d . *)

  Definition algType := LmodType A (type (lmods.AtoRmod M) N) (algMixin).
  End AlgDef.

  Module Exports.
    Infix "\(x)\" := type (at level 80, right associativity).
    Infix "\\(x)\\" := (algType _) (at level 80, right associativity).
  End Exports.
End Tensor.
Export Tensor.Exports.
Close Scope ring_scope.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.