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 Bprime X Dprime : Universe, ((wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ D O /\ (wd_ Eprime A /\ (wd_ X O /\ (wd_ D Dprime /\ (wd_ Bprime X /\ (wd_ B Bprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O Eprime Bprime /\ (col_ O E X /\ (col_ O Eprime D /\ col_ O Eprime Dprime))))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import list_examples.

Definition dealloc_def := FunDef "dealloc" ["x"]
 {{Decl "y"
  ;SWhile ("x" <> 0)
    {{"y"<-arr_next "x";HDealloc "x";"x"<-"y"}}
  ;SReturn 0}}.

Inductive dealloc_spec : Spec kcfg :=
  dealloc_claim : forall l x, heap_fun dealloc_spec nil
  dealloc_def [Int x] (rep_list l x) (fun r => emptyP)
 |loop_claim  : forall l xv yv, heap_loop dealloc_spec
  dealloc_def 0 ("x" s|-> KInt xv :* "y" s|-> yv)
    (rep_list l xv) (fun r => emptyP).

Lemma dealloc_proof : sound kstep dealloc_spec.
Proof. list_solver. Qed.


Require Import Homotopy.

Declare ML Module "ltac_plugin".

Set Default Proof Mode "Classic".

Definition K : Type
  := forall (A : Type) (x : A) (P : paths x x -> Type),
    P idpath -> forall p, P p .

Definition UIP : Type
  := forall (A : Type) (x y : A) (p q : paths x y),
    paths p q .

Definition UIP_refl : Type
  := forall (A : Type) (x : A) (p : paths x x),
    paths p idpath .

Inductive JMeq (A : Type) (a : A) : forall B, B -> Type
  :=
  | JMeq_refl : JMeq A a A a
  .

Definition JMeq_elim_nodep
  (A : Type) (a : A) (P : forall B, B -> Type)
  (case_JMeq_refl : P A a)
  (B : Type) (b : B) (x : JMeq A a B b) : P B b
  := match x with JMeq_refl _ _ => case_JMeq_refl end .

Definition JMeq_elim
  (A : Type) (a : A) (P : forall B b, JMeq A a B b -> Type)
  (case_JMeq_refl : P A a (JMeq_refl A a))
  (B : Type) (b : B) (x : JMeq A a B b) : P B b x
  := match x with JMeq_refl _ _ => case_JMeq_refl end .

Arguments JMeq {_} _ {_} _ .
Arguments JMeq_refl {_ _}, [_] _ .
Arguments JMeq_elim_nodep {_ _ _} _ {_ _} _ .
Arguments JMeq_elim {_ _ _} _ {_ _} _ .

Definition JMeq_inverse
  {A B : Type} {a : A} {b : B}
  (x : JMeq a b) : JMeq b a
  := JMeq_elim_nodep (P := fun B' b' => JMeq b' a) JMeq_refl x .

Definition JMeq_concat
  {A B C : Type} {a : A} {b : B} {c : C}
  (x : JMeq a b) (y : JMeq b c) : JMeq a c
  := JMeq_elim_nodep (JMeq_elim_nodep JMeq_refl x) y .

Definition JMeq_transport
  {P : forall T, T -> Type} {A B : Type}
  {a : A} {b : B} (x : JMeq a b)
  (u : P A a) : P B b
  := JMeq_elim_nodep u x .

Definition JMeq_ap
  {P : forall T, T -> Type} {A B : Type}
  {a : A} {b : B} (f : forall T t, P T t)
  (x : JMeq a b) : JMeq (f A a) (f B b)
  := JMeq_elim_nodep (P := fun B' b' => JMeq (f A a) (f B' b')) JMeq_refl x .

Definition ap_dep_JMeq
  {A : Type} {B : A -> Type}
  (f : forall a, B a)
  {x y : A} (p : paths x y)
  : JMeq (f x) (f y)
  := paths_elim_nodep (P := fun y' => JMeq (f x) (f y')) JMeq_refl p .

Definition paths_JMeq
  {A : Type} {x y : A}
  (p : paths x y) : JMeq x y
  := paths_elim_nodep JMeq_refl p .

Definition JMeq_paths : Type
  := forall (A : Type) (x y : A), JMeq x y -> paths x y .

Definition JMeq_elim_nodep_eqlike : Type
  := forall (A : Type) (a : A) (P : A -> Type),
    P a -> forall a', JMeq a a' -> P a' .

Definition JMeq_elim_eqlike : Type
  := forall (A : Type) (a : A) (P : forall a', JMeq a a' -> Type),
    P a JMeq_refl -> forall a' x, P a' x .

Definition JMeq_K : Type
  := forall (A : Type) (x : A) (P : JMeq x x -> Type),
    P JMeq_refl -> forall p, P p .

Definition JMeq_UIP : Type
  := forall (A B : Type) (a : A) (b : B) (p : JMeq a b) (q : JMeq a b),
    paths p q .

Definition JMeq_UIP_refl : Type
  := forall (A : Type) (x : A) (p : JMeq x x),
    paths p JMeq_refl .

Definition UIP_JMeq
  {A : Type} {x y : A} (p q : paths x y) : JMeq p q .
Proof.
 refine (paths_elim (P := fun y' p' => JMeq p' q) _ p) .
 refine (paths_elim (P := fun y' q' => JMeq idpath q') _ q) .
 exact JMeq_refl .
Defined.

Definition UIP_JMeq_hetero
  {A : Type} {x y z : A} (p : paths x y) (q : paths x z) : JMeq p q .
Proof.
 refine (paths_elim (P := fun y' p' => JMeq p' q) _ p) .
 refine (paths_elim (P := fun z' q' => JMeq idpath q') _ q) .
 exact JMeq_refl .
Defined.

Definition UIP_refl_JMeq
  {A : Type} {x : A} (p : paths x x) : JMeq p (idpath x) .
Proof.
 refine (paths_elim (P := fun x' p' => JMeq p' idpath) _ p) .
 exact JMeq_refl .
Defined.

Definition UIP_refl_JMeq_hetero
  {A : Type} {x y : A} (p : paths x y) : JMeq p (idpath x) .
Proof.
 refine (paths_elim (P := fun y' p' => JMeq p' idpath) _ p) .
 exact JMeq_refl .
Defined.

Definition JMeq_UIP_JMeq
  {A B : Type} {a : A} {b : B} (p q : JMeq a b) : JMeq p q .
Proof.
 refine (JMeq_elim (P := fun B' b' p' => JMeq p' q) _ p) .
 refine (JMeq_elim (P := fun B' b' q' => JMeq JMeq_refl q') _ q) .
 exact JMeq_refl .
Defined.

Definition JMeq_UIP_JMeq_hetero
  {A B C : Type} {a : A} {b : B} {c : C} (p : JMeq a b) (q : JMeq a c)
  : JMeq p q .
Proof.
 refine (JMeq_elim (P := fun B' b' p' => JMeq p' q) _ p) .
 refine (JMeq_elim (P := fun C' c' q' => JMeq JMeq_refl q') _ q) .
 exact JMeq_refl .
Defined.

Definition JMeq_UIP_refl_JMeq
  {A : Type} {x : A} (p : JMeq x x) : JMeq p (JMeq_refl x) .
Proof.
 refine (JMeq_elim (P := fun A' x' p' => JMeq p' JMeq_refl) _ p) .
 exact JMeq_refl .
Defined.

Definition JMeq_UIP_refl_JMeq_hetero
  {A B : Type} {a : A} {b : B} (p : JMeq a b) : JMeq p (JMeq_refl a) .
Proof.
 refine (JMeq_elim (P := fun B' b' p' => JMeq p' JMeq_refl) _ p) .
 exact JMeq_refl .
Defined.

Inductive eq_dep
  {A : Type} {B : A -> Type} (x : A) (xh : B x) : forall y, B y -> Type
  :=
  | eq_dep_refl : eq_dep x xh x xh
  .

Definition eq_dep_elim_nodep
  {A : Type} {B : A -> Type}
  (x : A) (xh : B x) (P : forall y, B y -> Type)
  (case_eq_dep_refl : P x xh)
  (y : A) (yh : B y)
  (x : eq_dep x xh y yh) : P y yh
  := match x with eq_dep_refl _ _ => case_eq_dep_refl end .

Definition eq_dep_elim
  {A : Type} {B : A -> Type}
  (x : A) (xh : B x) (P : forall y yh, eq_dep x xh y yh -> Type)
  (case_eq_dep_refl : P x xh (eq_dep_refl x xh))
  (y : A) (yh : B y)
  (x : eq_dep x xh y yh) : P y yh x
  := match x with eq_dep_refl _ _ => case_eq_dep_refl end .

Arguments eq_dep {_ _ _} _ {_} _ .
Arguments eq_dep_refl {_ _ _ _}, {_ _} [_] _ .
Arguments eq_dep_elim_nodep {_ _ _ _ _} _ {_ _} _ .
Arguments eq_dep_elim {_ _ _ _ _} _ {_ _} .

Definition eq_dep_inverse
  {A : Type} {B : A -> Type}
  {x : A} {xh : B x} {y : A} {yh : B y}
  (p : eq_dep xh yh) : eq_dep yh xh
  := eq_dep_elim_nodep (P := fun y' yh' => eq_dep yh' xh) eq_dep_refl p .

Definition eq_dep_concat
  {A : Type} {B : A -> Type}
  {x : A} {xh : B x} {y : A} {yh : B y} {z : A} {zh : B z}
  (p : eq_dep xh yh) (q : eq_dep yh zh) : eq_dep xh zh
  := eq_dep_elim_nodep (eq_dep_elim_nodep eq_dep_refl p) q .

Definition paths_eq_dep
  {A : Type} {B : A -> Type}
  {x : A} {h i : B x} (p : paths h i) : eq_dep h i
  := paths_elim_nodep eq_dep_refl p .

Definition eq_dep_paths_shallow
  {A : Type} {B : A -> Type}
  {x y : A} {xh : B x} {yh : B y} (p : eq_dep xh yh) : paths x y
  := eq_dep_elim_nodep (P := fun y' _ => paths x y') idpath p .

Definition eq_dep_paths : Type
  := forall (A : Type) (B : A -> Type) (x : A) (xh : B x),
    paths xh xh .

Definition eq_dep_JMeq
  {A : Type} {B : A -> Type}
  {x y : A} {xh : B x} {yh : B y} (p : eq_dep xh yh) : JMeq xh yh
  := eq_dep_elim_nodep (P := fun y' yh' => JMeq xh yh') JMeq_refl p .

Definition JMeq_eq_dep : Type
  := forall (A : Type) (B : A -> Type) (x y : A) (xh : B x) (yh : B y),
    JMeq xh yh -> eq_dep xh yh .

Definition JMeq_eq_dep_weak : Type
  := forall (A : Type) (B : A -> Type) (x y : A) (xh : B x) (yh : B y),
    paths x y -> JMeq xh yh -> eq_dep xh yh .

Definition JMeq_eq_dep_id
  {A B : Type} (a : A) (b : B) (p : JMeq a b)
  : eq_dep (B := idmap) a b
  := JMeq_elim_nodep eq_dep_refl p .

Definition eq_dep_id_JMeq
  {A B : Type} (a : A) (b : B)
  (p : eq_dep (B := idmap) a b) : JMeq a b
  := eq_dep_elim_nodep JMeq_refl p .

Definition K_UIP (axiom_K : K) : UIP .
Proof.
 refine (fun A x y p => _) .
 refine (paths_elim (P := fun y' p' => forall q : paths x y', paths p' q) _ p) .
 refine (fun q => _) .
 refine (axiom_K A x (fun q' => paths idpath q') _ q) .
 exact idpath .
Defined.

Definition K_UIP_refl (axiom_K : K) : UIP_refl .
Proof.
 refine (fun A x p => _) .
 refine (axiom_K A x (fun p' => paths p' idpath) _ p) .
 exact idpath .
Defined.

Definition UIP_K (axiom_UIP : UIP) : K .
Proof.
 refine (fun A x P c p => _) .
 refine (paths_elim_nodep (P := fun p' => P p') c _) .
 exact (axiom_UIP A x x idpath p) .
Defined.

Definition UIP_UIP_refl (axiom_UIP : UIP) : UIP_refl .
Proof.
 refine (fun A x p => _) .
 exact (axiom_UIP A x x p idpath) .
Defined.

Definition UIP_refl_K (axiom_UIP_refl : UIP_refl) : K .
Proof.
 refine (fun A x P c p => _) .
 refine (paths_elim_nodep (P := fun p' => P p') c _) .
 refine (inverse _) .
 exact (axiom_UIP_refl A x p) .
Defined.

Definition UIP_refl_UIP (axiom_UIP_refl : UIP_refl) : UIP .
Proof.
 refine (fun A x y p => _) .
 refine (paths_elim (P := fun y' p' => forall q : paths x y', paths p' q) _ p) .
 refine (fun q => _) .
 refine (inverse _) .
 exact (axiom_UIP_refl A x q) .
Defined.

Definition JMeq_paths_K (axiom_JMeq_paths : JMeq_paths) : K .
Proof.
 refine (fun A x P c p => _) .
 refine (transport _ c) .
 refine (axiom_JMeq_paths (paths x x) idpath p _) .
 refine (JMeq_inverse _) .
 exact (UIP_refl_JMeq p) .
Defined.

Definition JMeq_paths_UIP (axiom_JMeq_paths : JMeq_paths) : UIP .
Proof.
 refine (fun A x y p q => _) .
 refine (axiom_JMeq_paths (paths x y) p q _) .
 exact (UIP_JMeq p q) .
Defined.

Definition not_JMeq_eq_dep
  (A : Type) (x y : A) (D : A -> Type)
  (Dx : paths (D x) unit) (Dy : paths (D y) empty)
  (axiom_JMeq_eq_dep : JMeq_eq_dep) : empty .
Proof.
 pose (B := const unit : A -> Type) .
 pose (xh := tt : B x) .
 pose (yh := tt : B y) .
 pose (H := axiom_JMeq_eq_dep A B x y xh yh) .
 pose (p := JMeq_refl : JMeq xh yh) .
 pose (q := H p : eq_dep xh yh) .
 refine (cast (A := unit) (B := empty) _ tt) .
 refine (concat (inverse _) (y := D x) (concat _ (y := D y) _)) .
 -
  exact Dx .
 -
  refine (ap D _) .
  refine (eq_dep_paths_shallow (xh := xh) (yh := yh) _) .
  exact q .
 -
  exact Dy .
Defined.


From iris.algebra Require Export view frac.
From iris.algebra Require Import proofmode_classes big_op.
From iris.prelude Require Import options.

(** The authoritative camera with fractional authoritative elements *)
(** The authoritative camera has 2 types of elements: the authoritative element
[●{dq} a] and the fragment [◯ b] (of which there can be several). To enable
sharing of the authoritative element [●{dq} a], it is equiped with a
discardable fraction [dq]. Updates are only possible with the full
authoritative element [● a] (syntax for [●{#1} a]]), while fractional
authoritative elements have agreement, i.e., [✓ (●{dq1} a1 ⋅ ●{dq2} a2) → a1 ≡
a2]. *)

(** * Definition of the view relation *)
(** The authoritative camera is obtained by instantiating the view camera. *)
Definition auth_view_rel_raw {A : ucmra} (n : nat) (a b : A) : Prop :=
  b ≼{n} a ∧ ✓{n} a.
Lemma auth_view_rel_raw_mono (A : ucmra) n1 n2 (a1 a2 b1 b2 : A) :
  auth_view_rel_raw n1 a1 b1 →
  a1 ≡{n2}≡ a2 →
  b2 ≼{n2} b1 →
  n2 ≤ n1 →
  auth_view_rel_raw n2 a2 b2.
Proof.
  intros [??] Ha12 ??. split.
  - trans b1; [done|]. rewrite -Ha12. by apply cmra_includedN_le with n1.
  - rewrite -Ha12. by apply cmra_validN_le with n1.
Qed.
Lemma auth_view_rel_raw_valid (A : ucmra) n (a b : A) :
  auth_view_rel_raw n a b → ✓{n} b.
Proof. intros [??]; eauto using cmra_validN_includedN. Qed.
Lemma auth_view_rel_raw_unit (A : ucmra) n :
  ∃ a : A, auth_view_rel_raw n a ε.
Proof. exists ε. split; [done|]. apply ucmra_unit_validN. Qed.
Canonical Structure auth_view_rel {A : ucmra} : view_rel A A :=
  ViewRel auth_view_rel_raw (auth_view_rel_raw_mono A)
          (auth_view_rel_raw_valid A) (auth_view_rel_raw_unit A).

Lemma auth_view_rel_unit {A : ucmra} n (a : A) : auth_view_rel n a ε ↔ ✓{n} a.
Proof. split; [by intros [??]|]. split; auto using ucmra_unit_leastN. Qed.
Lemma auth_view_rel_exists {A : ucmra} n (b : A) :
  (∃ a, auth_view_rel n a b) ↔ ✓{n} b.
Proof.
  split; [|intros; exists b; by split].
  intros [a Hrel]. eapply auth_view_rel_raw_valid, Hrel.
Qed.

Global Instance auth_view_rel_discrete {A : ucmra} :
  CmraDiscrete A → ViewRelDiscrete (auth_view_rel (A:=A)).
Proof.
  intros ? n a b [??]; split.
  - by apply cmra_discrete_included_iff_0.
  - by apply cmra_discrete_valid_iff_0.
Qed.

(** * Definition and operations on the authoritative camera *)
(** The type [auth] is not defined as a [Definition], but as a [Notation].
This way, one can use [auth A] with [A : Type] instead of [A : ucmra], and let
canonical structure search determine the corresponding camera instance. *)
Notation auth A := (view (A:=A) (B:=A) auth_view_rel_raw).
Definition authO (A : ucmra) : ofe := viewO (A:=A) (B:=A) auth_view_rel.
Definition authR (A : ucmra) : cmra := viewR (A:=A) (B:=A) auth_view_rel.
Definition authUR (A : ucmra) : ucmra := viewUR (A:=A) (B:=A) auth_view_rel.

Definition auth_auth {A: ucmra} : dfrac → A → auth A := view_auth.
Definition auth_frag {A: ucmra} : A → auth A := view_frag.

Typeclasses Opaque auth_auth auth_frag.

Global Instance: Params (@auth_auth) 2 := {}.
Global Instance: Params (@auth_frag) 1 := {}.

Notation "● dq a" := (auth_auth dq a)
  (at level 20, dq custom dfrac at level 1, format "● dq  a").
Notation "◯ a" := (auth_frag a) (at level 20).

(** * Laws of the authoritative camera *)
(** We omit the usual [equivI] lemma because it is hard to state a suitably
general version in terms of [●] and [◯], and because such a lemma has never
been needed in practice. *)
Section auth.
  Context {A : ucmra}.
  Implicit Types a b : A.
  Implicit Types x y : auth A.
  Implicit Types q : frac.
  Implicit Types dq : dfrac.

  Global Instance auth_auth_ne dq : NonExpansive (@auth_auth A dq).
  Proof. rewrite /auth_auth. apply _. Qed.
  Global Instance auth_auth_proper dq : Proper ((≡) ==> (≡)) (@auth_auth A dq).
  Proof. rewrite /auth_auth. apply _. Qed.
  Global Instance auth_frag_ne : NonExpansive (@auth_frag A).
  Proof. rewrite /auth_frag. apply _. Qed.
  Global Instance auth_frag_proper : Proper ((≡) ==> (≡)) (@auth_frag A).
  Proof. rewrite /auth_frag. apply _. Qed.

  Global Instance auth_auth_dist_inj n : Inj2 (=) (dist n) (dist n) (@auth_auth A).
  Proof. rewrite /auth_auth. apply _. Qed.
  Global Instance auth_auth_inj : Inj2 (=) (≡) (≡) (@auth_auth A).
  Proof. rewrite /auth_auth. apply _. Qed.
  Global Instance auth_frag_dist_inj n : Inj (dist n) (dist n) (@auth_frag A).
  Proof. rewrite /auth_frag. apply _. Qed.
  Global Instance auth_frag_inj : Inj (≡) (≡) (@auth_frag A).
  Proof. rewrite /auth_frag. apply _. Qed.

  Global Instance auth_ofe_discrete : OfeDiscrete A → OfeDiscrete (authO A).
  Proof. apply _. Qed.
  Global Instance auth_auth_discrete dq a :
    Discrete a → Discrete (ε : A) → Discrete (●{dq} a).
  Proof. rewrite /auth_auth. apply _. Qed.
  Global Instance auth_frag_discrete a : Discrete a → Discrete (◯ a).
  Proof. rewrite /auth_frag. apply _. Qed.
  Global Instance auth_cmra_discrete : CmraDiscrete A → CmraDiscrete (authR A).
  Proof. apply _. Qed.

  (** Operation *)
  Lemma auth_auth_dfrac_op dq1 dq2 a : ●{dq1 ⋅ dq2} a ≡ ●{dq1} a ⋅ ●{dq2} a.
  Proof. apply view_auth_dfrac_op. Qed.
  Global Instance auth_auth_dfrac_is_op dq dq1 dq2 a :
    IsOp dq dq1 dq2 → IsOp' (●{dq} a) (●{dq1} a) (●{dq2} a).
  Proof. rewrite /auth_auth. apply _. Qed.

  Lemma auth_frag_op a b : ◯ (a ⋅ b) = ◯ a ⋅ ◯ b.
  Proof. apply view_frag_op. Qed.
  Lemma auth_frag_mono a b : a ≼ b → ◯ a ≼ ◯ b.
  Proof. apply view_frag_mono. Qed.
  Lemma auth_frag_core a : core (◯ a) = ◯ (core a).
  Proof. apply view_frag_core. Qed.
  Lemma auth_both_core_discarded a b :
    core (●□ a ⋅ ◯ b) ≡ ●□ a ⋅ ◯ (core b).
  Proof. apply view_both_core_discarded. Qed.
  Lemma auth_both_core_frac q a b :
    core (●{#q} a ⋅ ◯ b) ≡ ◯ (core b).
  Proof. apply view_both_core_frac. Qed.

  Global Instance auth_auth_core_id a : CoreId (●□ a).
  Proof. rewrite /auth_auth. apply _. Qed.
  Global Instance auth_frag_core_id a : CoreId a → CoreId (◯ a).
  Proof. rewrite /auth_frag. apply _. Qed.
  Global Instance auth_both_core_id a1 a2 : CoreId a2 → CoreId (●□ a1 ⋅ ◯ a2).
  Proof. rewrite /auth_auth /auth_frag. apply _. Qed.
  Global Instance auth_frag_is_op a b1 b2 :
    IsOp a b1 b2 → IsOp' (◯ a) (◯ b1) (◯ b2).
  Proof. rewrite /auth_frag. apply _. Qed.
  Global Instance auth_frag_sep_homomorphism :
    MonoidHomomorphism op op (≡) (@auth_frag A).
  Proof. rewrite /auth_frag. apply _. Qed.

  Lemma big_opL_auth_frag {B} (g : nat → B → A) (l : list B) :
    (◯ [^op list] k↦x ∈ l, g k x) ≡ [^op list] k↦x ∈ l, ◯ (g k x).
  Proof. apply (big_opL_commute _). Qed.
  Lemma big_opM_auth_frag `{Countable K} {B} (g : K → B → A) (m : gmap K B) :
    (◯ [^op map] k↦x ∈ m, g k x) ≡ [^op map] k↦x ∈ m, ◯ (g k x).
  Proof. apply (big_opM_commute _). Qed.
  Lemma big_opS_auth_frag `{Countable B} (g : B → A) (X : gset B) :
    (◯ [^op set] x ∈ X, g x) ≡ [^op set] x ∈ X, ◯ (g x).
  Proof. apply (big_opS_commute _). Qed.
  Lemma big_opMS_auth_frag `{Countable B} (g : B → A) (X : gmultiset B) :
    (◯ [^op mset] x ∈ X, g x) ≡ [^op mset] x ∈ X, ◯ (g x).
  Proof. apply (big_opMS_commute _). Qed.

  (** Validity *)
  Lemma auth_auth_dfrac_op_invN n dq1 a dq2 b : ✓{n} (●{dq1} a ⋅ ●{dq2} b) → a ≡{n}≡ b.
  Proof. apply view_auth_dfrac_op_invN. Qed.
  Lemma auth_auth_dfrac_op_inv dq1 a dq2 b : ✓ (●{dq1} a ⋅ ●{dq2} b) → a ≡ b.
  Proof. apply view_auth_dfrac_op_inv. Qed.
  Lemma auth_auth_dfrac_op_inv_L `{!LeibnizEquiv A} dq1 a dq2 b :
    ✓ (●{dq1} a ⋅ ●{dq2} b) → a = b.
  Proof. by apply view_auth_dfrac_op_inv_L. Qed.

  Lemma auth_auth_dfrac_validN n dq a : ✓{n} (●{dq} a) ↔ ✓ dq ∧ ✓{n} a.
  Proof. by rewrite view_auth_dfrac_validN auth_view_rel_unit. Qed.
  Lemma auth_auth_validN n a : ✓{n} (● a) ↔ ✓{n} a.
  Proof. by rewrite view_auth_validN auth_view_rel_unit. Qed.

  Lemma auth_auth_dfrac_op_validN n dq1 dq2 a1 a2 :
    ✓{n} (●{dq1} a1 ⋅ ●{dq2} a2) ↔  ✓ (dq1 ⋅ dq2) ∧ a1 ≡{n}≡ a2 ∧ ✓{n} a1.
  Proof. by rewrite view_auth_dfrac_op_validN auth_view_rel_unit. Qed.
  Lemma auth_auth_op_validN n a1 a2 : ✓{n} (● a1 ⋅ ● a2) ↔ False.
  Proof. apply view_auth_op_validN. Qed.

  (** The following lemmas are also stated as implications, which can be used
  to force [apply] to use the lemma in the right direction. *)
  Lemma auth_frag_validN n b : ✓{n} (◯ b) ↔ ✓{n} b.
  Proof. by rewrite view_frag_validN auth_view_rel_exists. Qed.
  Lemma auth_frag_validN_1 n b : ✓{n} (◯ b) → ✓{n} b.
  Proof. apply auth_frag_validN. Qed.
  Lemma auth_frag_validN_2 n b : ✓{n} b → ✓{n} (◯ b).
  Proof. apply auth_frag_validN. Qed.
  Lemma auth_frag_op_validN n b1 b2 : ✓{n} (◯ b1 ⋅ ◯ b2) ↔ ✓{n} (b1 ⋅ b2).
  Proof. apply auth_frag_validN. Qed.
  Lemma auth_frag_op_validN_1 n b1 b2 : ✓{n} (◯ b1 ⋅ ◯ b2) → ✓{n} (b1 ⋅ b2).
  Proof. apply auth_frag_op_validN. Qed.
  Lemma auth_frag_op_validN_2 n b1 b2 : ✓{n} (b1 ⋅ b2) → ✓{n} (◯ b1 ⋅ ◯ b2).
  Proof. apply auth_frag_op_validN. Qed.

  Lemma auth_both_dfrac_validN n dq a b :
    ✓{n} (●{dq} a ⋅ ◯ b) ↔ ✓ dq ∧ b ≼{n} a ∧ ✓{n} a.
  Proof. apply view_both_dfrac_validN. Qed.
  Lemma auth_both_validN n a b : ✓{n} (● a ⋅ ◯ b) ↔ b ≼{n} a ∧ ✓{n} a.
  Proof. apply view_both_validN. Qed.

  Lemma auth_auth_dfrac_valid dq a : ✓ (●{dq} a) ↔ ✓ dq ∧ ✓ a.
  Proof.
    rewrite view_auth_dfrac_valid !cmra_valid_validN.
    by setoid_rewrite auth_view_rel_unit.
  Qed.
  Lemma auth_auth_valid a : ✓ (● a) ↔ ✓ a.
  Proof.
    rewrite view_auth_valid !cmra_valid_validN.
    by setoid_rewrite auth_view_rel_unit.
  Qed.

  Lemma auth_auth_dfrac_op_valid dq1 dq2 a1 a2 :
    ✓ (●{dq1} a1 ⋅ ●{dq2} a2) ↔ ✓ (dq1 ⋅ dq2) ∧ a1 ≡ a2 ∧ ✓ a1.
  Proof.
    rewrite view_auth_dfrac_op_valid !cmra_valid_validN.
    setoid_rewrite auth_view_rel_unit. done.
  Qed.
  Lemma auth_auth_op_valid a1 a2 : ✓ (● a1 ⋅ ● a2) ↔ False.
  Proof. apply view_auth_op_valid. Qed.

  (** The following lemmas are also stated as implications, which can be used
  to force [apply] to use the lemma in the right direction. *)
  Lemma auth_frag_valid b : ✓ (◯ b) ↔ ✓ b.
  Proof.
    rewrite view_frag_valid cmra_valid_validN.
    by setoid_rewrite auth_view_rel_exists.
  Qed.
  Lemma auth_frag_valid_1 b : ✓ (◯ b) → ✓ b.
  Proof. apply auth_frag_valid. Qed.
  Lemma auth_frag_valid_2 b : ✓ b → ✓ (◯ b).
  Proof. apply auth_frag_valid. Qed.
  Lemma auth_frag_op_valid b1 b2 : ✓ (◯ b1 ⋅ ◯ b2) ↔ ✓ (b1 ⋅ b2).
  Proof. apply auth_frag_valid. Qed.
  Lemma auth_frag_op_valid_1 b1 b2 : ✓ (◯ b1 ⋅ ◯ b2) → ✓ (b1 ⋅ b2).
  Proof. apply auth_frag_op_valid. Qed.
  Lemma auth_frag_op_valid_2 b1 b2 : ✓ (b1 ⋅ b2) → ✓ (◯ b1 ⋅ ◯ b2).
  Proof. apply auth_frag_op_valid. Qed.

  (** These lemma statements are a bit awkward as we cannot possibly extract a
  single witness for [b ≼ a] from validity, we have to make do with one witness
  per step-index, i.e., [∀ n, b ≼{n} a]. *)
  Lemma auth_both_dfrac_valid dq a b :
    ✓ (●{dq} a ⋅ ◯ b) ↔  ✓ dq ∧ (∀ n, b ≼{n} a) ∧ ✓ a.
  Proof.
    rewrite view_both_dfrac_valid. apply and_iff_compat_l. split.
    - intros Hrel. split.
      + intros n. by destruct (Hrel n).
      + apply cmra_valid_validN=> n. by destruct (Hrel n).
    - intros [Hincl Hval] n. split; [done|by apply cmra_valid_validN].
  Qed.
  Lemma auth_both_valid a b :
    ✓ (● a ⋅ ◯ b) ↔ (∀ n, b ≼{n} a) ∧ ✓ a.
  Proof. rewrite auth_both_dfrac_valid. split; [naive_solver|done]. Qed.

  (* The reverse direction of the two lemmas below only holds if the camera is
  discrete. *)
  Lemma auth_both_dfrac_valid_2 dq a b : ✓ dq → ✓ a → b ≼ a → ✓ (●{dq} a ⋅ ◯ b).
  Proof.
    intros. apply auth_both_dfrac_valid.
    naive_solver eauto using cmra_included_includedN.
  Qed.
  Lemma auth_both_valid_2 a b : ✓ a → b ≼ a → ✓ (● a ⋅ ◯ b).
  Proof. intros ??. by apply auth_both_dfrac_valid_2. Qed.

  Lemma auth_both_dfrac_valid_discrete `{!CmraDiscrete A} dq a b :
    ✓ (●{dq} a ⋅ ◯ b) ↔ ✓ dq ∧ b ≼ a ∧ ✓ a.
  Proof.
    rewrite auth_both_dfrac_valid. setoid_rewrite <-cmra_discrete_included_iff.
    naive_solver eauto using O.
  Qed.
  Lemma auth_both_valid_discrete `{!CmraDiscrete A} a b :
    ✓ (● a ⋅ ◯ b) ↔ b ≼ a ∧ ✓ a.
  Proof. rewrite auth_both_dfrac_valid_discrete. split; [naive_solver|done]. Qed.

  (** Inclusion *)
  Lemma auth_auth_dfrac_includedN n dq1 dq2 a1 a2 b :
    ●{dq1} a1 ≼{n} ●{dq2} a2 ⋅ ◯ b ↔ (dq1 ≼ dq2 ∨ dq1 = dq2) ∧ a1 ≡{n}≡ a2.
  Proof. apply view_auth_dfrac_includedN. Qed.
  Lemma auth_auth_dfrac_included dq1 dq2 a1 a2 b :
    ●{dq1} a1 ≼ ●{dq2} a2 ⋅ ◯ b ↔ (dq1 ≼ dq2 ∨ dq1 = dq2) ∧ a1 ≡ a2.
  Proof. apply view_auth_dfrac_included. Qed.
  Lemma auth_auth_includedN n a1 a2 b :
    ● a1 ≼{n} ● a2 ⋅ ◯ b ↔ a1 ≡{n}≡ a2.
  Proof. apply view_auth_includedN. Qed.
  Lemma auth_auth_included a1 a2 b :
    ● a1 ≼ ● a2 ⋅ ◯ b ↔ a1 ≡ a2.
  Proof. apply view_auth_included. Qed.

  Lemma auth_frag_includedN n dq a b1 b2 :
    ◯ b1 ≼{n} ●{dq} a ⋅ ◯ b2 ↔ b1 ≼{n} b2.
  Proof. apply view_frag_includedN. Qed.
  Lemma auth_frag_included dq a b1 b2 :
    ◯ b1 ≼ ●{dq} a ⋅ ◯ b2 ↔ b1 ≼ b2.
  Proof. apply view_frag_included. Qed.

  (** The weaker [auth_both_included] lemmas below are a consequence of the
  [auth_auth_included] and [auth_frag_included] lemmas above. *)
  Lemma auth_both_dfrac_includedN n dq1 dq2 a1 a2 b1 b2 :
    ●{dq1} a1 ⋅ ◯ b1 ≼{n} ●{dq2} a2 ⋅ ◯ b2 ↔
      (dq1 ≼ dq2 ∨ dq1 = dq2) ∧ a1 ≡{n}≡ a2 ∧ b1 ≼{n} b2.
  Proof. apply view_both_dfrac_includedN. Qed.
  Lemma auth_both_dfrac_included dq1 dq2 a1 a2 b1 b2 :
    ●{dq1} a1 ⋅ ◯ b1 ≼ ●{dq2} a2 ⋅ ◯ b2 ↔
      (dq1 ≼ dq2 ∨ dq1 = dq2) ∧ a1 ≡ a2 ∧ b1 ≼ b2.
  Proof. apply view_both_dfrac_included. Qed.
  Lemma auth_both_includedN n a1 a2 b1 b2 :
    ● a1 ⋅ ◯ b1 ≼{n} ● a2 ⋅ ◯ b2 ↔ a1 ≡{n}≡ a2 ∧ b1 ≼{n} b2.
  Proof. apply view_both_includedN. Qed.
  Lemma auth_both_included a1 a2 b1 b2 :
    ● a1 ⋅ ◯ b1 ≼ ● a2 ⋅ ◯ b2 ↔ a1 ≡ a2 ∧ b1 ≼ b2.
  Proof. apply view_both_included. Qed.

  (** Updates *)
  Lemma auth_update a b a' b' :
    (a,b) ~l~> (a',b') → ● a ⋅ ◯ b ~~> ● a' ⋅ ◯ b'.
  Proof.
    intros Hup. apply view_update=> n bf [[bf' Haeq] Hav].
    destruct (Hup n (Some (bf ⋅ bf'))); simpl in *; [done|by rewrite assoc|].
    split; [|done]. exists bf'. by rewrite -assoc.
  Qed.

  Lemma auth_update_alloc a a' b' : (a,ε) ~l~> (a',b') → ● a ~~> ● a' ⋅ ◯ b'.
  Proof. intros. rewrite -(right_id _ _ (● a)). by apply auth_update. Qed.
  Lemma auth_update_dealloc a b a' : (a,b) ~l~> (a',ε) → ● a ⋅ ◯ b ~~> ● a'.
  Proof. intros. rewrite -(right_id _ _ (● a')). by apply auth_update. Qed.
  Lemma auth_update_auth a a' b' : (a,ε) ~l~> (a',b') → ● a ~~> ● a'.
  Proof.
    intros. etrans; first exact: auth_update_alloc.
    exact: cmra_update_op_l.
  Qed.
  Lemma auth_update_auth_persist dq a : ●{dq} a ~~> ●□ a.
  Proof. apply view_update_auth_persist. Qed.

  Lemma auth_update_dfrac_alloc dq a b `{!CoreId b} :
    b ≼ a → ●{dq} a ~~> ●{dq} a ⋅ ◯ b.
  Proof.
    intros Ha%(core_id_extract _ _). apply view_update_dfrac_alloc=> n bf [??].
    split; [|done]. rewrite Ha (comm _ a). by apply cmra_monoN_l.
  Qed.

  Lemma auth_local_update a b0 b1 a' b0' b1' :
    (b0, b1) ~l~> (b0', b1') → b0' ≼ a' → ✓ a' →
    (● a ⋅ ◯ b0, ● a ⋅ ◯ b1) ~l~> (● a' ⋅ ◯ b0', ● a' ⋅ ◯ b1').
  Proof.
    intros. apply view_local_update; [done|]=> n [??]. split.
    - by apply cmra_included_includedN.
    - by apply cmra_valid_validN.
  Qed.
End auth.

(** * Functor *)
Program Definition authURF (F : urFunctor) : urFunctor := {|
  urFunctor_car A _ B _ := authUR (urFunctor_car F A B);
  urFunctor_map A1 _ A2 _ B1 _ B2 _ fg :=
    viewO_map (urFunctor_map F fg) (urFunctor_map F fg)
|}.
Next Obligation.
  intros F A1 ? A2 ? B1 ? B2 ? n f g Hfg.
  apply viewO_map_ne; by apply urFunctor_map_ne.
Qed.
Next Obligation.
  intros F A ? B ? x; simpl in *. rewrite -{2}(view_map_id x).
  apply (view_map_ext _ _ _ _)=> y; apply urFunctor_map_id.
Qed.
Next Obligation.
  intros F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x; simpl in *.
  rewrite -view_map_compose.
  apply (view_map_ext _ _ _ _)=> y; apply urFunctor_map_compose.
Qed.
Next Obligation.
  intros F A1 ? A2 ? B1 ? B2 ? fg; simpl.
  apply view_map_cmra_morphism; [apply _..|]=> n a b [??]; split.
  - by apply (cmra_morphism_monotoneN _).
  - by apply (cmra_morphism_validN _).
Qed.

Global Instance authURF_contractive F :
  urFunctorContractive F → urFunctorContractive (authURF F).
Proof.
  intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg.
  apply viewO_map_ne; by apply urFunctor_map_contractive.
Qed.

Program Definition authRF (F : urFunctor) : rFunctor := {|
  rFunctor_car A _ B _ := authR (urFunctor_car F A B);
  rFunctor_map A1 _ A2 _ B1 _ B2 _ fg :=
    viewO_map (urFunctor_map F fg) (urFunctor_map F fg)
|}.
Solve Obligations with apply authURF.

Global Instance authRF_contractive F :
  urFunctorContractive F → rFunctorContractive (authRF F).
Proof. apply authURF_contractive. Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.

(* Why3 assumption *)
Definition unit  := unit.

Parameter qtmark : Type.

Parameter at1: forall (a:Type), a -> qtmark -> a.
Implicit Arguments at1.

Parameter old: forall (a:Type), a -> a.
Implicit Arguments old.

(* Why3 assumption *)
Definition implb(x:bool) (y:bool): bool := match (x,
  y) with
  | (true, false) => false
  | (_, _) => true
  end.

Parameter map : forall (a:Type) (b:Type), Type.

Parameter get: forall (a:Type) (b:Type), (map a b) -> a -> b.
Implicit Arguments get.

Parameter set: forall (a:Type) (b:Type), (map a b) -> a -> b -> (map a b).
Implicit Arguments set.

Axiom Select_eq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (a1 = a2) -> ((get (set m a1 b1)
  a2) = b1).

Axiom Select_neq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1)
  a2) = (get m a2)).

Parameter const: forall (b:Type) (a:Type), b -> (map a b).
Set Contextual Implicit.
Implicit Arguments const.
Unset Contextual Implicit.

Axiom Const : forall (b:Type) (a:Type), forall (b1:b) (a1:a),
  ((get (const b1:(map a b)) a1) = b1).

(* Why3 assumption *)
Inductive ref (a:Type) :=
  | mk_ref : a -> ref a.
Implicit Arguments mk_ref.

(* Why3 assumption *)
Definition contents (a:Type)(v:(ref a)): a :=
  match v with
  | (mk_ref x) => x
  end.
Implicit Arguments contents.

(* Why3 assumption *)
Inductive color  :=
  | Blue : color
  | White : color
  | Red : color .

(* Why3 assumption *)
Definition monochrome(a:(map Z color)) (i:Z) (j:Z) (c:color): Prop :=
  forall (k:Z), ((i <= k)%Z /\ (k < j)%Z) -> ((get a k) = c).

Parameter nb_occ: (map Z color) -> Z -> Z -> color -> Z.

Axiom nb_occ_null : forall (a:(map Z color)) (i:Z) (j:Z) (c:color),
  (j <= i)%Z -> ((nb_occ a i j c) = 0%Z).

Axiom nb_occ_add_eq : forall (a:(map Z color)) (i:Z) (j:Z) (c:color),
  ((i < j)%Z /\ ((get a (j - 1%Z)%Z) = c)) -> ((nb_occ a i j c) = ((nb_occ a
  i (j - 1%Z)%Z c) + 1%Z)%Z).

Axiom nb_occ_add_neq : forall (a:(map Z color)) (i:Z) (j:Z) (c:color),
  ((i < j)%Z /\ ~ ((get a (j - 1%Z)%Z) = c)) -> ((nb_occ a i j c) = (nb_occ a
  i (j - 1%Z)%Z c)).

Axiom nb_occ_split : forall (a:(map Z color)) (i:Z) (j:Z) (k:Z) (c:color),
  ((i <= j)%Z /\ (j <= k)%Z) -> ((nb_occ a i k c) = ((nb_occ a i j
  c) + (nb_occ a j k c))%Z).

Open Scope Z_scope.
Require Import Why3.
Ltac ae := why3 "alt-ergo" timelimit 3.

(* Why3 goal *)
Theorem nb_occ_store_outside_up : forall (a:(map Z color)) (i:Z) (j:Z) (k:Z)
  (c:color), ((i <= j)%Z /\ (j <= k)%Z) -> ((nb_occ (set a k c) i j
  c) = (nb_occ a i j c)).
intros a i j k c (h1 & h2).
generalize h2 ; generalize h1.
pattern j; apply Zlt_lower_bound_ind with (z:=i); auto.
ae.
Qed.


Require Import Iron.Language.SimpleData.Step.
Require Import Iron.Language.SimpleData.TyJudge.
Require Import Iron.Language.SimpleData.Exp.

(* A well typed expression is either a well formed value,
   or can transition to the next state. *)
Theorem progress
 :  forall ds x t
 ,  TYPE ds nil x t
 -> value x \/ (exists x', STEP x x').
Proof.
 intros. gen t.
 induction x using exp_mutind with
  (PA := fun a => a = a); rip; burn.

 Case "XApp".
  right.
  inverts_type.
  edestruct IHx1; eauto.
  SCase "value x1".
   edestruct IHx2; eauto.
    SSCase "value x2".
     have HF: (exists t x, x1 = XLam t x).
     destruct HF as [t11].
     destruct H1 as [x12].
     subst.
     exists (substX 0 x2 x12).
     eauto.
    SSCase "x2 steps".
     destruct H0 as [x2'].
     exists (XApp x1 x2'). auto.
  SCase "x1 steps".
   destruct H  as [x1'].
   exists (XApp x1' x2).
   eapply (EsContext (fun xx => XApp xx x2)); auto.

 Case "XCon".
  inverts_type.

  (* All ctor args are either wnf or can step *)
  assert (Forall (fun x => wnfX x \/ (exists x', STEP x x')) xs) as HWS.
   norm. rip.
   have (exists t, TYPE ds nil x t). dest t.
   have (value x \/ (exists x', STEP x x')).
   inverts H2; burn.

  (* All ctor args are wnf, or there is a context where one can step *)
  lets D: (@exps_ctx_run exp exp) HWS.
  inverts D.
   (* All ctor args are wnf *)
   left. eauto 6.
   (* There is a context where one ctor arg can step *)
   right.
    dest C. dest x'.
    rip.
    lets D: step_context_XCon_exists H1 H5.
    destruct D as [x'']. eauto.

 Case "XCase".
  right.
  inverts_type.
  have HS: (value x \/ (exists x', STEP x x')).
  inverts HS. clear IHx.
  SCase "x value".
   destruct x; nope.
    SSCase "XCon".
     inverts_type.
     rrwrite (dcs0 = dcs).
     have HG: (exists ts x, getAlt d aa = Some (AAlt d ts x))
      by burn using getAlt_exists.
     dest ts. dest x.
     exists (substXs 0 l x).
     burn.

  SCase "x steps".
   destruct H0 as [x'].
   exists (XCase x' aa).
   lets D: EsContext XcCase; eauto.
Qed.


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 A1 A2 B1 B2 A1prime A3 B3 B3prime : Universe, ((wd_ A1prime A3 /\ (wd_ A1 A2 /\ (wd_ A3 B3 /\ (wd_ B1 A1prime /\ (wd_ A3 B3prime /\ (wd_ B1 B2 /\ (wd_ A1prime B3prime /\ (wd_ A3 B1 /\ (wd_ B1 B3prime /\ (wd_ A1 B1 /\ (wd_ A1 B2 /\ (wd_ A2 B1 /\ (wd_ A2 B2 /\ (col_ A1 A2 A1prime /\ (col_ A1 A2 A3 /\ col_ B1 B2 B3))))))))))))))) -> col_ A1prime A3 A1)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

End FOFProblem.


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

End FOFProblem.


(** This file implements "monads decorated by monoid <<W>>." *)
From Tealeaves Require Export
  Classes.Monoid
  Classes.Decorated.Functor
  Classes.Monad
  Functors.Writer.

Import Monoid.Notations.

#[local] Generalizable Variable W.

(** * Decorated monads *)
(******************************************************************************)
Section DecoratedMonad.

  Context
    (W : Type)
    (T : Type -> Type)
    `{Fmap T} `{Return T} `{Join T} `{Decorate W T}
    `{Monoid_op W} `{Monoid_unit W}.

  Class DecoratedMonad:=
    { dmon_functor :> DecoratedFunctor W T;
      dmon_monad :> Monad T;
      dmon_monoid :> Monoid W;
      dmon_ret : forall (A : Type),
        dec T ∘ ret T = ret T ∘ pair Ƶ (B:=A);
      dmon_join : forall (A : Type),
        dec T ∘ join T (A:=A) =
          join T ∘ fmap T (shift T) ∘ dec T ∘ fmap T (dec T);
    }.

End DecoratedMonad.

(** * Decorated right modules *)
(******************************************************************************)
Section DecoratedModule.

  Context
    (W : Type)
    (F T : Type -> Type)
    `{Fmap T} `{Return T} `{Join T} `{Decorate W T}
    `{Fmap F} `{RightAction F T} `{Decorate W F}
    `{Monoid_op W} `{Monoid_unit W}.

  Class DecoratedRightModule :=
    { dmod_monad :> DecoratedMonad W T;
      dmod_functor :> DecoratedFunctor W T;
      dmon_module :> RightModule F T;
      dmod_action : forall (A : Type),
        dec F ∘ right_action F (A := A) =
          right_action F ∘ fmap F (shift T) ∘ dec F ∘ fmap F (dec T);
    }.

End DecoratedModule.

(** * Algebraic decorated monad to Kleisli decorated monad *)
(******************************************************************************)

From Tealeaves Require Classes.Kleisli.Decorated.Monad.

(** ** Kleisli laws *)
(******************************************************************************)
Module ToKleisli.

  #[local] Generalizable Variables A B C.

  Import Classes.Kleisli.Decorated.Monad.
  Import Classes.Kleisli.Decorated.Monad.Notations.

  Section operation.

    Context
      (W : Type)
      (T : Type -> Type)
      `{Fmap T} `{Join T} `{Decorate W T}.

    #[export] Instance Bindd_dec : Bindd W T T :=
      fun A B f => join T ∘ fmap T f ∘ dec T.

  End operation.

  Section with_monad.

    Context
      (T : Type -> Type)
      `{DecoratedMonad W T}.

    (** *** Identity law *)
    (******************************************************************************)
    Lemma bindd_id :
      `(bindd T (ret T ∘ extract (prod W)) = @id (T A)).
    Proof.
      intros. unfold_ops @Bindd_dec.
      rewrite <- (fun_fmap_fmap T).
      reassociate <-.
      rewrite (mon_join_fmap_ret T).
      reassociate ->.
      rewrite (dfun_dec_extract W T).
      reflexivity.
    Qed.

    (** *** Composition law *)
    (******************************************************************************)
    Lemma bindd_bindd : forall `(g : W * B -> T C) `(f : W * A -> T B),
        bindd T g ∘ bindd T f = bindd T (g ⋆dm f).
    Proof.
      intros. unfold bindd at 1 2, Bindd_dec.
      (* change (join T ∘ fmap T ?f) with (bind T f).*)
      do 2 reassociate <-.
      reassociate -> near (join T). rewrite (dmon_join W T).
      repeat reassociate <-.
      reassociate -> near (fmap T f).
      rewrite (fun_fmap_fmap T).
      change (?g ∘ dec T ∘ fmap T (dec T ∘ f) ∘ dec T)
        with (g ∘ (dec T ∘ fmap T (dec T ∘ f) ∘ dec T)).
      rewrite <- (cobind_dec T).
      reassociate <-.
      change (?g ∘ fmap T (shift T) ∘ fmap T (cobind (prod W) (dec T ∘ f)) ∘ ?h)
        with (g ∘ (fmap T (shift T) ∘ fmap T (cobind (prod W) (dec T ∘ f))) ∘ h).
      rewrite (fun_fmap_fmap T).
      unfold bindd.
      change (?h ∘ fmap T g ∘ join T ∘ fmap T (shift T ∘ cobind (prod W) (dec T ∘ f)) ∘ ?i)
        with (h ∘ (fmap T g ∘ join T ∘ fmap T (shift T ∘ cobind (prod W) (dec T ∘ f))) ∘ i).
      fequal.
      unfold kcompose_dm, bindd, preincr.
      rewrite natural.
      reassociate ->. unfold_ops @Fmap_compose. unfold_compose_in_compose.
      rewrite (fun_fmap_fmap T).
      replace (fun '(w, a) => (join T ∘ fmap T (g ∘ incr w) ∘ dec T) (f (w, a)))
        with (join T ∘ (fun '(w, a) => (fmap T (g ∘ incr w) ∘ dec T) (f (w, a))))
        by (ext [? ?]; reflexivity).
      reassociate <-.
      #[local] Set Keyed Unification.
      rewrite (mon_join_join T).
      #[local] Unset Keyed Unification.
      reassociate ->.
      fequal. unfold_compose_in_compose.
      rewrite (fun_fmap_fmap T).
      fequal. fequal. ext [w a].
      unfold shift, compose; cbn.
      compose near (dec T (f (w, a))) on left.
      rewrite (fun_fmap_fmap T).
      compose near (dec T (f (w, a))) on left.
      rewrite (fun_fmap_fmap T).
      fequal. ext [w' b].
      reflexivity.
    Qed.

    (** *** Unit law *)
    (******************************************************************************)
    Lemma bindd_comp_ret `(f : W * A -> T B) :
      bindd T f ∘ ret T = f ∘ pair Ƶ.
    Proof.
      intros. unfold_ops Bindd_dec.
      reassociate -> on left.
      rewrite (dmon_ret W T).
      reassociate <- on left.
      reassociate -> near (ret T).
      rewrite (natural (G := T) (ϕ := @ret T _)).
      reassociate <-. rewrite (mon_join_ret T).
      reflexivity.
    Qed.

    #[export] Instance: Kleisli.Decorated.Monad.Monad T :=
      {| kmond_bindd0 := @bindd_comp_ret;
        kmond_bindd1 := @bindd_id;
        kmond_bindd2 := @bindd_bindd;
      |}.

  End with_monad.

End ToKleisli.

(** * Basic properties of [shift] on monads *)
(******************************************************************************)
Section shift_monad_lemmas.

  #[local] Generalizable Variables T A.

  Context
    `{Monad T}
    `{Monoid W}.

  (** [shift] applied to a singleton simplifies to a singleton. *)
  Lemma shift_return `(a : A) (w1 w2 : W) :
    shift T (w2, ret T (w1, a)) = ret T (w2 ● w1, a).
  Proof.
    unfold shift, compose. rewrite strength_return.
    compose near (w2, (w1, a)) on left.
    now rewrite (natural (F := fun A => A)).
  Qed.

  Lemma shift_join `(t : T (T (W * A))) (w : W) :
    shift T (w, join T t) = join T (fmap T (fun t => shift T (w, t)) t).
  Proof.
    rewrite (shift_spec T). compose near t on left.
    rewrite natural. unfold compose; cbn.
    fequal. unfold_ops @Fmap_compose.
    fequal. ext x. now rewrite (shift_spec T).
  Qed.

  (*
  Lemma shift_bind `(t : T (W * A)) (w : W) `(f : W * A -> T (W * B)) :
    shift T (w, bind T f t) = bind T (fun p => shift T (w, f p)) t.
  Proof.
    unfold_ops @Bind_Join. unfold compose.
    rewrite shift_join. fequal.
    compose near t on left.
    now rewrite (fun_fmap_fmap T).
  Qed.
  *)

End shift_monad_lemmas.

(** * Helper lemmas for proving instances *)
(******************************************************************************)
Section helper_lemmas.

  #[local] Generalizable Variables T.

  Context
    `{Monad T}
    `{Decorate W T}
    `{Monoid W}.

  (** This lemmas is useful for proving the decoration-join law. *)
  Lemma dec_helper_4 {A} : forall (t : T (T A)) (w : W),
      dec T (join T t) =
        join T (fmap T (shift T) (dec T (fmap T (dec T) t))) ->
      shift T (w, dec T (join T t)) =
        join T (fmap T (shift T) (shift T (w, dec T (fmap T (dec T) t)))).
  Proof.
    introv IH. rewrite !(shift_spec T) in *. rewrite IH.
    compose near (dec T (fmap T (dec T) t)) on right.
    rewrite (fun_fmap_fmap T). rewrite (shift_increment T).
    rewrite <- (fun_fmap_fmap T).
    change (fmap T (fmap T ?f)) with (fmap (T ∘ T) f).
    compose near (dec T (fmap T (dec T) t)).
    reassociate <-.
    #[local] Set Keyed Unification.
    now rewrite <- (natural (ϕ := @join T _)).
    #[local] Unset Keyed Unification.
  Qed.

End helper_lemmas.

#[local] Generalizable Variables E F ϕ A B.

(** * Pushing decorations through a monoid homomorphism *)
(** If a functor is readable by a monoid, it is readable by any target
    of a homomorphism from that monoid too. *)
(******************************************************************************)
Section DecoratedFunctor_monoid_homomorphism.

  Import Product.Notations.

  Context
    (Wsrc Wtgt : Type)
    `{Monoid_Morphism Wsrc Wtgt ϕ}
    `{Decorate Wsrc F} `{Fmap F} `{Return F} `{Join F}
    `{! DecoratedMonad Wsrc F}.

  Instance Decorate_homomorphism :
    Decorate Wtgt F := fun A => fmap F (map_fst ϕ) ∘ dec F.

  Instance Natural_read_morphism : Natural (@dec Wtgt F Decorate_homomorphism).
  Proof.
    constructor.
    - typeclasses eauto.
    - typeclasses eauto.
    - intros. unfold_ops @Decorate_homomorphism.
      unfold_ops @Fmap_compose.
      reassociate <- on left.
      rewrite (fun_fmap_fmap F).
      rewrite (product_fmap_commute).
      rewrite <- (fun_fmap_fmap F).
      reassociate -> on left.
      change (fmap F (fmap (prod Wsrc) f)) with
          (fmap (F ∘ prod Wsrc) f).
      now rewrite (natural (ϕ := @dec Wsrc F _ )).
  Qed.

  Instance DecoratedFunctor_morphism : DecoratedFunctor Wtgt F.
  Proof.
    constructor; try typeclasses eauto.
    - intros. unfold dec, Decorate_homomorphism.
      reassociate <-. reassociate -> near (fmap F (map_fst ϕ)).
      rewrite <- (natural (ϕ := @dec Wsrc F _) (map_fst ϕ)).
      reassociate <-. unfold_ops @Fmap_compose. rewrite (fun_fmap_fmap F).
      reassociate -> near (@dec Wsrc F _ A).
      rewrite (dfun_dec_dec Wsrc F).
      reassociate <-. rewrite (fun_fmap_fmap F).
      reassociate <-. rewrite (fun_fmap_fmap F).
      fequal. fequal. ext [w a]. reflexivity.
    - intros. unfold dec, Decorate_homomorphism.
      reassociate <-. rewrite (fun_fmap_fmap F).
      replace (extract (Wtgt ×) ∘ map_fst ϕ)
        with (@extract (Wsrc ×) _ A) by now ext [w a].
      now rewrite (dfun_dec_extract Wsrc F).
  Qed.

  Instance DecoratedMonad_morphism : DecoratedMonad Wtgt F.
  Proof.
    inversion H3.
    constructor; try typeclasses eauto.
    - intros. unfold dec, Decorate_homomorphism.
      reassociate ->. rewrite (dmon_ret Wsrc F).
      reassociate <-. rewrite (natural (ϕ := @ret F _)).
      ext a. unfold compose; cbn.
      now rewrite (monmor_unit).
    - intros. unfold dec, Decorate_homomorphism.
      reassociate ->. rewrite (dmon_join Wsrc F).
      repeat reassociate <-.
      rewrite (natural (ϕ := @join F _)).
      reassociate -> near (fmap F (shift F)).
      unfold_ops @Fmap_compose.
      unfold_compose_in_compose.
      rewrite (fun_fmap_fmap F _ _ _ (shift F) (fmap F (map_fst ϕ))).
      reassociate -> near (fmap F (map_fst ϕ)). rewrite (fun_fmap_fmap F).
      rewrite <- (fun_fmap_fmap F _ _ _ (dec F) (fmap F (map_fst ϕ))).
      reassociate <-. reassociate -> near (fmap F (fmap F (map_fst ϕ))).
      rewrite <- (natural (ϕ := @dec Wsrc F _)).
      reassociate <-. unfold_ops @Fmap_compose.
      reassociate -> near (fmap F (fmap (prod Wsrc) (fmap F (map_fst ϕ)))).
      rewrite (fun_fmap_fmap F).
      repeat fequal. ext [w t].
      unfold compose; cbn.
      change (id ?f) with f. unfold shift.
      unfold compose; cbn.
      do 2 (compose near t;
            repeat rewrite (fun_fmap_fmap F)).
      fequal. ext [w' a].
      unfold compose; cbn. rewrite monmor_op.
      reflexivity.
  Qed.

End DecoratedFunctor_monoid_homomorphism.

(** * Decorated monads in terms of monad homomorphisms *)
(******************************************************************************)
Section DecoratedMonad_characterization.

  Generalizable Variables T.

  Context
    `{Monad T} `{Decorate W T} `{Monoid W}
    `{! DecoratedFunctor W T}.

  (** <<ret T>> commutes with decoration if and only if <<dec T>> maps
     <<ret T>> to <<ret (T ∘ W)>> *)
  Lemma dec_ret_iff {A} :
    (dec T ∘ ret T = ret T ∘ dec (fun x => x) (A:=A)) <->
    (dec T ∘ ret T = ret (T ∘ prod W) (A:=A)).
  Proof with auto.
    split...
  Qed.

  (** <<join T>> commutes with decoration if and only if <<dec T>>
     maps <<join T>> to <<join (T ∘ prod W)>> of <<dec T ∘ fmap T (dec T)>>
     (in other words iff <<dec T>> commutes with <<join>>). *)
  Lemma dec_join_iff {A} :
    `(dec T ∘ join T = join T ∘ dec (T ∘ T) (A := A)) <->
    `(dec T ∘ join T = join (T ∘ prod W) ∘ dec T ∘ fmap T (dec T (A:=A))).
  Proof.
    enough (Heq : join T ∘ dec (A := A) (T ∘ T)
                  = join (T ∘ prod W) ∘ dec T ∘ fmap T (dec T))
      by (split; intro hyp; now rewrite hyp).
    unfold_ops @Join_Beck @Decorate_compose @BeckDistribution_strength.
    repeat reassociate <-. fequal. fequal.
    rewrite (natural (ϕ := @join T _)).
    unfold_ops @Fmap_compose. reassociate -> on right.
    now unfold_compose_in_compose; rewrite (fun_fmap_fmap T).
  Qed.

  Theorem decorated_monad_compatibility_spec :
    Monad_Hom T (T ∘ prod W) (@dec W T _) <->
    DecoratePreservingTransformation (@ret T _) /\
    DecoratePreservingTransformation (@join T _).
  Proof with auto.
    split.
    - introv mhom. inverts mhom. inverts mhom_domain. split.
      + constructor...
        introv. symmetry. rewrite dec_ret_iff. apply mhom_ret.
      + constructor...
        introv. symmetry. rewrite dec_join_iff. apply mhom_join.
    - intros [h1 h2]. inverts h1. inverts h2.
      constructor; try typeclasses eauto.
      + introv. rewrite <- dec_ret_iff...
      + introv. rewrite <- dec_join_iff...
  Qed.

  Theorem decorated_monad_spec :
    DecoratedMonad W T <-> Monad_Hom T (T ∘ prod W) (@dec W T _).
  Proof with try typeclasses eauto.
    rewrite decorated_monad_compatibility_spec.
    split; intro hyp.
    - inversion hyp. constructor...
      + constructor... intros. now rewrite (dmon_ret W T).
      + constructor... intros. now rewrite (dmon_join W T).
    - destruct hyp as [hyp1 hyp2]. constructor...
      + intros. inversion hyp1. now rewrite dectrans_commute.
      + intros. inversion hyp2. now rewrite <- dectrans_commute.
  Qed.

End DecoratedMonad_characterization.