From RelationAlgebra Require Import lattice boolean.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From mathcomp Require Import eqtype choice order finmap fintype fingraph.
From mathcomp Require Import generic_quotient zify.
From mathcomp.tarjan Require Import extra acyclic kosaraju acyclic_tsorted.
From eventstruct Require Import pomset utils rel_algebra order rel.
From eventstruct Require Import inhtype ident lposet.

(******************************************************************************)
(* This file provides a theory of prime event structures.                     *)
(* Prime event structure inherits partial causality order from pomset and     *)
(* also has binary conflict relation (symmetric and irreflexive).             *)
(*                                                                            *)
(*       Prime.eventStruct E == the type of prime event structures with       *)
(*                              binary conflict, consisting of                *)
(*                              a causality relation <= (a partial order),    *)
(*                              and a binary conflict relation # (irreflexive *)
(*                              and symmetric).                               *)
(*       Prime.eventType d   == a type of events, i.e. a type equipped with   *)
(*                              prime event structure instance.               *)
(*       Prime.cfg d es x    == a predicate asserting that subset of events x *)
(*                              given as decidable predicate) forms a         *)
(*                              configuration of the event structure es.      *)
(*                              Configuration is a causally-closed and        *)
(*                              conflict-free subset of events.               *)
(*       PrimeG.eventStruct E == the type of prime event structures with      *)
(*                               general conflict, consisting of              *)
(*                               a causality relation <= (a partial order),   *)
(*                               and a general conflict predice gcf over      *)
(*                               finite subset of events.                     *)
(*                               and symmetric).                              *)
(*       PrimeG.eventType d   == a type of events, i.e. a type equipped with  *)
(*                               prime event structure instance.              *)
(*       PrimeG.cfg d es x    == a predicate asserting that subset of events  *)
(*                               x (given as decidable predicate) forms a     *)
(*                               configuration of the event structure es.     *)
(*                               Configuration is a causally-closed and       *)
(*                               conflict-free subset of events.              *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import Order.LTheory.
Local Open Scope order_scope.
Local Open Scope fset_scope.
Local Open Scope quotient_scope.

(* a hack to bypass a shadowing problem caused by relation-algebra import *)
Local Notation symmetric  := Coq.ssr.ssrbool.symmetric.
Local Notation transitive := Coq.ssr.ssrbool.transitive.

Declare Scope prime_eventstruct_scope.
Delimit Scope prime_eventstruct_scope with prime_es.
Local Open Scope prime_eventstruct_scope.

Reserved Notation "x \# y" (at level 75, no associativity).

Definition hereditary {T : Type} (ca cf : rel T) :=
  forall x y z : T, cf x y -> ca y z -> cf x z.

Module PrimeC.

Module EventStruct.
Section ClassDef.

Record mixin_of (E0 : Type) (L : Type) (b : lPoset.lPoset.class_of E0 L)
                (E := lPoset.lPoset.Pack b) := Mixin {
  cons : pred {fset E};

  _ : cons fset0;
  (* TODO: remove single-event consistency axiom? *)
  _ : forall (e : E), cons [fset e];
  _ : forall (X Y : {fset E}), X `<=` Y -> cons Y -> cons X;
  _ : forall X e e', e <= e' -> cons (e' |` X) -> cons (e |` X)
}.

Set Primitive Projections.
Record class_of (E L : Type) := Class {
  (* TODO: use lDwFinPoset.class_of *)
  (* TODO: simplify hierarchy? make lPoset subclass
   *   with Ident type inheritance
   *)
  base   : lPoset.lPoset.class_of E L;
  mixin1 : DwFinPOrder.DwFinPOrder.mixin_of base;
  mixin2 : Countable.mixin_of E;
  mixin3 : Ident.mixin_of (Countable.Class base mixin2);
  mixin4 : mixin_of base;
}.
Unset Primitive Projections.

Local Coercion base : class_of >-> lPoset.lPoset.class_of.

Local Coercion base2 E L (c : class_of E L) :
  DwFinPOrder.DwFinPOrder.class_of E :=
    DwFinPOrder.DwFinPOrder.Class (mixin1 c).

Local Coercion base3 E L (c : class_of E L) :
  Ident.class_of E := Ident.Class (mixin3 c).

Structure type (L : Type) := Pack { sort; _ : class_of sort L }.

Local Coercion sort : type >-> Sortclass.

Variables (E : Type) (L : Type) (cT : type L).

Definition class := let: Pack _ c as cT' := cT return class_of (sort cT') L in c.
Definition clone c of phant_id class c := @Pack E L c.
(* Definition clone_with disp' c of phant_id class c := @Pack disp' T c. *)

Definition pack :=
  fun bE b & phant_id (@lPoset.lPoset.class L bE) b =>
  fun m1 m2 m3 m4 => Pack (@Class E L b m1 m2 m3 m4).

Definition eqType := @Equality.Pack cT class.
Definition choiceType := @Choice.Pack cT class.
(* TODO: countType missing *)
Definition identType := @Ident.Pack cT class.
Definition porderType := @Order.POrder.Pack tt cT class.
Definition dwFinPOrderType := @DwFinPOrder.DwFinPOrder.Pack cT class.
Definition lposetType := @lPoset.lPoset.Pack L cT class.
End ClassDef.

Module Export Exports.
Coercion base : class_of >-> lPoset.lPoset.class_of.
Coercion base2 : class_of >-> DwFinPOrder.DwFinPOrder.class_of.
Coercion base3 : class_of >-> Ident.class_of.
Coercion mixin1 : class_of >-> DwFinPOrder.DwFinPOrder.mixin_of.
Coercion mixin2 : class_of >-> Countable.mixin_of.
Coercion mixin3 : class_of >-> Ident.mixin_of.
Coercion mixin4 : class_of >-> mixin_of.
Coercion sort : type >-> Sortclass.
Coercion eqType : type >-> Equality.type.
Coercion choiceType : type >-> Choice.type.
Coercion porderType : type >-> Order.POrder.type.
Coercion dwFinPOrderType : type >-> DwFinPOrder.DwFinPOrder.type.
Coercion lposetType : type >-> lPoset.eventType.
Coercion identType  : type >-> Ident.type.
Canonical eqType.
Canonical choiceType.
Canonical identType.
Canonical porderType.
Canonical dwFinPOrderType.
Canonical lposetType.
End Exports.

End EventStruct.

Export EventStruct.Exports.

Notation eventType := EventStruct.type.
Notation eventStruct := EventStruct.class_of.
Notation EventType E L m := (@EventStruct.pack E L _ _ id m).

Module Export Def.
Section Def.

Variable (L : Type) (E : eventType L).

Definition cons : pred {fset E} :=
  EventStruct.cons (EventStruct.class E).

Definition gcf : pred {fset E} :=
  fun C => ~~ cons C.

Definition cf : rel E :=
  fun e1 e2 => gcf [fset e1; e2].

Definition cf_free (p : pred E) :=
  forall (s : {fset E}), {subset s <= p} -> cons s.

Definition cfg (p : pred E) :=
  dw_closed p /\ cf_free p.

(* TODO: rename? *)
Definition wcons : pred {fset E} :=
  [pred X | cons X && (#|` X| != 1)%N].

End Def.
End Def.

Prenex Implicits cons gcf cf.

Module Export Syntax.
Notation "x \# y" := (cf x y) : prime_eventstruct_scope.
End Syntax.

Module Export Theory.
Section Theory.
Context {L : Type} {E : eventType L}.
Implicit Types (e : E) (X Y : {fset E}).

Lemma cons_self e : cons [fset e].
Proof. by move: e; case: E => ? [?] ??? []. Qed.

Lemma cons0 : cons (fset0 : {fset E}).
Proof. by case: E => ? [?] ??? []. Qed.

(* TODO: rename `cons_contra`? *)
Lemma cons_contra X Y : X `<=` Y -> cons Y -> cons X.
Proof. by move: X Y; case: E => ? [?] ??? []. Qed.

Lemma cons_prop X e1 e2 :
  e1 <= e2 -> cons (e2 |` X) -> cons (e1 |` X).
Proof. by move: X e1 e2; case: E => ? [?] ??? []. Qed.

Lemma gcf_self e : ~~ (gcf [fset e]).
Proof. rewrite /gcf negbK; exact/cons_self. Qed.

Lemma gcf_ext X Y : X `<=` Y -> gcf X -> gcf Y.
Proof. by rewrite /gcf=> /cons_contra /contra. Qed.

Lemma gcf_hered X e1 e2 :
  e1 <= e2 -> gcf (e1 |` X) -> gcf (e2 |` X).
Proof. by rewrite /gcf=> /cons_prop /contra /[apply]. Qed.

Lemma cf_irrefl : irreflexive (cf : rel E).
Proof.
  move=> e; rewrite /cf fsetUid; apply/eqP.
  rewrite eqbF_neg; exact/gcf_self.
Qed.

Lemma cf_sym : symmetric (cf : rel E).
Proof. by move=> e1 e2; rewrite /cf fsetUC. Qed.

Lemma cf_hered : hereditary (<=%O) (cf : rel E).
Proof.
  move=> e1 e2 e3 /[swap]; rewrite /cf.
  rewrite [in [fset e1; e2]]fsetUC [in [fset e1; e3]]fsetUC.
  exact/gcf_hered.
Qed.

(* TODO: better name? *)
Lemma cf_hered2 e1 e1' e2 e2' :
  e1 \# e2 -> e1 <= e1' -> e2 <= e2' -> e1' \# e2'.
Proof.
  move=> cf12 ca1 ca2; apply/(cf_hered _ ca2).
  rewrite cf_sym; apply/(cf_hered _ ca1).
  by rewrite cf_sym.
Qed.

Lemma cf_gcf X e1 e2 :
  e1 \in X -> e2 \in X -> e1 \# e2 -> gcf X.
Proof.
  move=> in1 in2 cf12.
  apply/(gcf_ext _ cf12).
  rewrite fsubUset !fsub1set; exact/andP.
Qed.

Lemma cons_ca_contra (X Y : {fset E}) :
  {subsumes X <= Y : x y / x <= y} -> cons Y -> cons X.
Proof.
  move: X {2}(X `\` Y) (@erefl _ (X `\` Y))=> /[swap].
  elim/fset_ind=> [?/eqP/[! fsetD_eq0]/cons_contra//|].
  move=> x ?? IHxy X XYE /[dup] S + cY; rewrite -(@fsetD1K _ x X); last first.
  - move/fsetP/(_ x): XYE; rewrite ?inE eqxx andbC /=; by case: (x \in X).
  case/(_ x)=> [/[! (inE, eqxx)]//|y ? /cons_prop]; apply.
  apply: IHxy=> // [|?]; last first.
  - rewrite ?inE=> /orP[/eqP->|/andP[_ /S //]]; by exists y.
  rewrite fsetDUl fsetDDl [x |` _]fsetUC -fsetDDl XYE fsetDUl.
  have/eqP->: ([fset y] `\` Y == fset0) by rewrite fsetD_eq0 fsub1set.
  by rewrite fsetDv ?fset0U mem_fsetD1.
Qed.

Lemma prefix_ca_closed (e : E) : dw_closed (<= e).
Proof. move=> e1 e2 /=; exact: le_trans. Qed.

Lemma prefix_cf_free e : cf_free (<= e).
Proof.
  move=> X S; apply/(@cons_ca_contra _ [fset e])/cons_self.
  move=> x i; exists e; rewrite ?inE //; exact/S.
Qed.

Lemma prefix_cfg e : cfg (<= e).
Proof. split; [exact/prefix_ca_closed | exact/prefix_cf_free]. Qed.

Lemma cf_free_fset (X : {fset E}) : reflect (cf_free (mem X)) (cons X).
Proof. apply/(iffP idP)=> [?? /fsubsetP/cons_contra|]; exact. Qed.

Lemma cfg0 : cfg (mem (fset0 : {fset E})).
Proof.
  split=> [> /=|]; first by rewrite inE.
  apply/cf_free_fset/cons0.
Qed.

End Theory.
End Theory.

Module Export Lang.

(* TODO: restructure submodules/sections *)
Section lFsPrePosetOf.

(* TODO: (L bot E) order of arguments contradicts (E L bot) in pomset.v *)
Context {L : botType} {E : eventType L}.
Context (X : {fset E}).
Implicit Types (e : E).

Hypothesis lab_def : [forall x : X, lab (val x) != bot].

Definition lfspreposet_of :=
  @lFsPrePoset.build_cov E L X lab (<=%O : rel E).

Lemma lfspreposet_of_finsupp :
  lfsp_eventset lfspreposet_of = X.
Proof. exact/lFsPrePoset.build_eventset/forallP. Qed.

Lemma lfspreposet_of_mixin :
  supp_closed lfspreposet_of && acyclic (fin_ica lfspreposet_of).
Proof.
  apply/andP; split.
  - by apply/lFsPrePoset.supp_closed_build/forallP.
  apply/lFsPrePoset.build_cov_acyclic; last first.
  - move=> /=; exact/le_trans.
  - move=> /=; exact/le_anti.
  - move=> /=; exact/le_refl.
  exact/forallP.
Qed.

End lFsPrePosetOf.

Section lFsPosetOf.
Context {L : botType}.

Definition lfsposet_of (E : eventType L) (X : {fset E}) : lfsposet E L :=
  if eqP is ReflectT p then
    mklFsPoset (@lfspreposet_of_mixin L E X p)
  else (lFsPoset.empty E L).

Context (E : eventType L) (X : {fset E}).

Lemma lfsposet_of0 :
  lfsposet_of (fset0 : {fset E}) = lFsPoset.empty E L.
Proof.
  rewrite /lfsposet_of /lfspreposet_of; case: eqP=> // ?.
  apply/eqP/lfspreposet_eqP; split=>>; rewrite /lFsPoset.empty /=.
  - rewrite lFsPrePoset.fs_lab_empty lFsPrePoset.build_lab /sub_lift.
    by case: insubP.
  rewrite lFsPrePoset.fs_ica_empty lFsPrePoset.build_ica /sub_rel_lift /=.
  by case: insubP.
Qed.

Lemma lfsposet_of_emp :
  [forall x : X, lab (val x) != bot] <> true ->
  lfsposet_of X = (lFsPoset.empty E L).
Proof. by rewrite /lfsposet_of; case: eqP. Qed.

Hypothesis lab_def : [forall x : X, lab (val x) != bot].

Lemma lfsposet_of_val :
  lfsposet_of X = lfspreposet_of X :> lfspreposet E L.
Proof. by rewrite /lfsposet_of; case: eqP=> // *. Qed.

Lemma lfsposet_of_eventset :
  lfsp_eventset (lfsposet_of X) = X.
Proof. by rewrite lfsposet_of_val lfspreposet_of_finsupp. Qed.

Lemma lfsposet_of_lab :
  {in X, fs_lab (lfsposet_of X) =1 lab}.
Proof.
  rewrite lfsposet_of_val=> ??.
  rewrite /lfspreposet_of /= lFsPrePoset.build_lab /sub_lift.
  by case: insubP=> //= [??->|/negP].
Qed.

Lemma lfsposet_of_fin_ca :
  fin_ca (lfsposet_of X) =2 relpre val (<=%O : rel E).
Proof.
  rewrite lfsposet_of_val /lfspreposet_of=> ??.
  rewrite lFsPrePoset.build_cov_fin_ca //; last first.
  - move=> /=; exact/le_trans.
  - move=> /=; exact/le_anti.
  exact/forallP.
Qed.

End lFsPosetOf.

Lemma lfsposet_of0_eventset {L : botType} (E : eventType L) :
  lfsp_eventset (@lfsposet_of L E (fset0 : {fset E})) = fset0.
Proof.
  rewrite lfsposet_of_val; last (apply/forallP; case)=> //.
  by rewrite lFsPrePoset.build_eventset //; case.
Qed.

Definition pomset_lang {L : botType} (E : eventType L) :=
  fun (p : pomset E L) =>
    exists2 X : {fset E}, cfg (mem X) & p = \pi (lfsposet_of X).

End Lang.

Module Export Hom.

Module Hom.
Section ClassDef.
(* TODO: homomorphism between pomsets labelled by different labels? *)
Context {L : Type} (E1 E2 : eventType L).
Implicit Types (f : E1 -> E2).

Definition axiom f :=
  [/\ { mono f : e / lab e }
    , { homo pideal f }
    & { homo (@!f) : X / wcons X }
  ].

Structure type := Pack { apply ; _ : axiom apply }.

Local Coercion apply : type >-> Funclass.

Definition mk h mkH : type :=
  mkH (let: Pack _ c := h return @axiom h in c).

Definition type_of (_ : phant (E1 -> E2)) := type.

End ClassDef.

Module Export Exports.
Coercion apply : type >-> Funclass.
End Exports.

End Hom.

Export Hom.Exports.

Module Export Syntax.
Notation hom := Hom.type.
Notation "{ 'hom' T }" :=
  (@Hom.type_of _ _ _ (Phant T)) : prime_eventstruct_scope.
Notation "[ 'hom' 'of' f ]" :=
  (Hom.mk (fun hCls => @Hom.Pack _ _ _ f hCls))
  (at level 0, format "[ 'hom'  'of'  f ]") : prime_eventstruct_scope.
End Syntax.

Module Build.
Section Build.
Context {L : Type} {E E1 E2 E3 : eventType L}.
Implicit Types (f : {hom E2 -> E3}) (g : {hom E1 -> E2}).

Lemma id_axiom : Hom.axiom (@idfun E).
Proof. split=> //= e; rewrite ?imfset_id //. Qed.

Lemma comp_axiom f g : Hom.axiom (comp f g).
Proof.
  case f=> {}f [] labf idlf consf.
  case g=> {}g [] labg idlg consg.
  split=> //=.
  - by move=> e; rewrite labf labg.
  - exact/homo_pideal_comp.
  by move=> X; rewrite imfset_comp=> /consg /consf.
Qed.

End Build.

Module Export Exports.
Section Exports.
Context {L : Type} {E E1 E2 E3 : eventType L}.
Implicit Types (f : {hom E2 -> E3}) (g : {hom E1 -> E2}).

Canonical id_hom := Hom.Pack (@id_axiom L E).
Canonical comp_hom f g := Hom.Pack (comp_axiom f g).

End Exports.
End Exports.

End Build.

Module Export Theory.
Section Theory.
Context {L : botType} {E1 E2 : eventType L}.
Implicit Types (f : {hom E1 -> E2}).
Implicit Types (X : {fset E1}).

Lemma lab_preserving f :
  { mono f : e / lab e }.
Proof. by case: f=> ? [] /=. Qed.

Lemma wcons_mon f X :
  wcons X -> wcons (f @` X).
Proof. case: f=> ? [] /= ??; exact. Qed.

Lemma cons_mon f X :
  cons X -> cons (f @` X).
Proof.
  move=> c; case: (boolP (wcons X))=> [/(wcons_mon f)/andP[]|] //.
  rewrite /wcons /= negb_and c /= negbK=>/cardfs1P[?->].
  by rewrite imfset1 cons_self.
Qed.

Lemma gcf_mon f X :
  gcf (f @` X) -> gcf X.
Proof. exact/contra/cons_mon. Qed.

Lemma cf_mon f e1 e2 :
  f e1 \# f e2 -> e1 \# e2.
Proof.
  rewrite /cf=> ?; apply/(@gcf_mon f).
  by rewrite imfsetU !imfset1=> /=.
Qed.

(* TODO: move to order.v *)
Lemma hom_prefix f e1 e2 :
  e1 <= f e2 -> exists2 e, e1 = f e & e <= e2.
Proof.
  case: f=> {}f [] ? + ? /=.
  rewrite homo_pidealE=> /(_ e2).
  rewrite /dw_surjective_le surj_rstE.
  by move=> /[apply] [[]] /= e ??; exists e.
Qed.

Lemma hom_cons_inj f X :
  cons X -> {in X & X, injective f}.
Proof.
  move=> c e1 e2 ??.
  case: (boolP (wcons [fset e1; e2]))=> [/(wcons_mon f)/[swap] Ef|].
  - by rewrite imfsetU ?imfset1 /wcons /= cardfs2 Ef eqxx /= andbF.
  rewrite /wcons /= negb_and negbK cardfs2.
  case: (e1 =P e2)=> //= ? /orP[]// /negP[].
  by apply/(cons_contra _ c)/fsubsetP=>>; rewrite ?inE=>/orP[]/eqP->.
Qed.

(* TODO: try to change direction of arrows/morphisms to get rid of anti? *)
Lemma in_cons_ca_anti f X :
  cons X -> {in X & X, forall e1 e2, f e1 <= f e2 -> e1 <= e2}.
Proof.
  (* TODO: use dw_surj_le_in_ahomo_in lemma *)
  move=> c e1 e2 i ? /hom_prefix[x /[swap] l /(@hom_cons_inj f (x |` X))-> //].
  - by apply/(cons_prop l); rewrite mem_fset1U.
  all: by rewrite ?inE (i, eqxx).
Qed.

(* TODO: prove first on the level of `lfsposet_of`,
 *   use subsumption notation
 *)
Lemma pomset_lang_sub f (p : pomset E1 L) :
  (forall x : E2, lab x != bot) ->
  pomset_lang p ->
  exists2 q : pomset E2 L, pomset_lang q & bhom_le p q.
Proof.
  move=> ld2 [X [ccX cfX]].
  case: ([forall x : X, lab (val x) != bot] =P true); first last.
  - move/lfsposet_of_emp=>->->.
    exists (\pi (lFsPoset.empty E2 L)).
    + exists fset0; first exact/cfg0; by rewrite lfsposet_of0.
    rewrite pom_bhom_le -?lfsposet_of0; apply/lFinPoset.bHom.bhom_leP.
    (* have g: forall E E' : eventType L, *)
    (*         [FinEvent of @lfsposet_of L bot E  fset0] -> *)
    (*         [FinEvent of @lfsposet_of L bot E' fset0]. *)
    have g: forall E E' : eventType L,
            (* TODO: make arguments of (@lfsposet_of L bot E) implicit *)
            (lfsp_eventset (@lfsposet_of L E  (fset0 : {fset E}))) ->
            (lfsp_eventset (@lfsposet_of L E' (fset0 : {fset E'}))) .
    + by move=> ??; rewrite ?lfsposet_of0_eventset=> [[]].
    exists=> /=; exists (g E2 E1); do ? split=> /=.
    1,2: by move=> /[dup]; rewrite {1}lfsposet_of0_eventset=> [[]].
    by exists (g E1 E2)=> /[dup] /=; rewrite {1}lfsposet_of0_eventset=> [[]].
  move=> ld1 pE; exists (\pi (@lfsposet_of L E2 (f @` X))).
  - exists (f @` X)=> //; split; last exact/cf_free_fset/cons_mon/cfX.
    move=>> /[swap]/imfsetP[] /= x' /[swap]-> /[swap] /hom_prefix.
    case=> y' -> /ccX/[apply] ?; by apply/imfsetP; exists y'.
  rewrite pE pom_bhom_le.
  have ?: [forall x : (f @` X), lab (val x) != bot] by exact/forallP.
  have In: forall x : (lfsp_eventset (@lfsposet_of L E1 X)),
    f (val x) \in (lfsp_eventset (@lfsposet_of L E2 (f @` X))).
  - case=> /= x; rewrite ?lfsposet_of_eventset //.
    by move=> ?; rewrite in_imfset.
  set g :
    [FinEvent of (@lfsposet_of L E1 X)] ->
    [FinEvent of (@lfsposet_of L E2 (f @` X))] := fun x => [` (In x)].
  (* TODO: use bhom_leP lemma? *)
  apply/lFinPoset.bHom.bhom_leP; exists=> /=.
  have bijg : bijective g.
  - apply/inj_card_bij=> /=; last first.
    + rewrite -?cardfE !lfsposet_of_eventset //.
      exact/(leq_trans (leq_imfset_card _ _ _)).
    rewrite /g; case=> ? in1 [? in2 /=] /(congr1 val) /= /hom_cons_inj.
    move/(_ _ _ in1 in2)=> ev; apply/val_inj/ev/cfX=> ?.
    by rewrite lfsposet_of_eventset.
  exists (invFh bijg); split=> //; last exact/injFh_bij.
  - case=> /= e /[dup]; rewrite {1}lfsposet_of_eventset // => ef ein.
    rewrite /g !fin_labE -?fin_lab_mono.
    move: ef=> /imfsetP[e'] /= ein' eqe'.
    have ein'': e' \in lfsp_eventset (lfsposet_of X : lfsposet E1 L).
    + by rewrite @lfsposet_of_eventset.
    have->: [` ein] = g [` ein''].
    + by rewrite /g; apply/val_inj.
    rewrite invFh_f /= !lfsposet_of_lab ?eqe' ?lab_preserving //.
    by apply/imfsetP; exists e'.
  apply/(cancel_le_ahomo_homo (f_invFh _)).
  case=> ? /[dup] + ? [? /[dup]+?].
  rewrite {1 2}lfsposet_of_eventset // => ??.
  rewrite /g ?/(_ <= _) /=.
  rewrite !lfsposet_of_fin_ca //.
  move=> /(@in_cons_ca_anti f X).
  apply=> //; exact/cfX.
Qed.

End Theory.
End Theory.

End Hom.

Module Export Iso.

Module Iso.
Section ClassDef.
Context {L : Type} (E1 E2 : PrimeC.eventType L).
Implicit Types (f : E1 -> E2).

Definition axiom f :=
  [/\ { mono f : e / lab e }
    , { mono f : e1 e2 / e1 <= e2 }
    , { mono (@!f) : X / wcons X }
    & bijective f
  ].

Structure type := Pack { apply ; _ : axiom apply }.

Local Coercion apply : type >-> Funclass.

Definition mk h mkH : type :=
  mkH (let: Pack _ c := h return @axiom h in c).

Definition type_of (_ : phant (E1 -> E2)) := type.

Lemma hom_axiom_of f : axiom f -> Hom.axiom f.
Proof.
  move=> [] labf lef consf bijf; split=> //; last exact/monoW.
  apply/homo_pidealE/ahomo_dw_surj_le.
  - exact/mono2aW.
  exact/surj_dw_surj/bij_surj.
Qed.

Lemma lposet_iso_axiom_of f : axiom f -> lPoset.Iso.Iso.axiom f.
Proof. by move=> []. Qed.

Lemma iso_axiom_of f : lPoset.Iso.Iso.axiom f ->
  { mono (@!f) : X / wcons X } -> axiom f.
Proof. by move=> [] *; split=> //. Qed.

Variables (cT : type).

Lemma homAxiom : Hom.axiom cT.
Proof. by case: cT=> /= ? /hom_axiom_of. Qed.

Lemma lposet_homAxiom : lPoset.Hom.Hom.axiom cT.
Proof.
  case: cT=> /= ? /lposet_iso_axiom_of.
  exact/lPoset.Iso.Iso.hom_axiom_of.
Qed.

Lemma lposet_ihomAxiom : lPoset.iHom.iHom.axiom cT.
Proof.
  case: cT=> /= ? /lposet_iso_axiom_of.
  exact/lPoset.Iso.Iso.ihom_axiom_of.
Qed.

Lemma lposet_bhomAxiom : lPoset.bHom.bHom.axiom cT.
Proof.
  case: cT=> /= ? /lposet_iso_axiom_of.
  exact/lPoset.Iso.Iso.bhom_axiom_of.
Qed.

Lemma lposet_embAxiom : lPoset.Emb.Emb.axiom cT.
Proof.
  case: cT=> /= ? /lposet_iso_axiom_of.
  exact/lPoset.Iso.Iso.emb_axiom_of.
Qed.

Lemma lposet_isoAxiom : lPoset.Iso.Iso.axiom cT.
Proof. by case: cT=> /= ? /lposet_iso_axiom_of. Qed.

Definition homType         := Hom.Pack homAxiom.
Definition lposet_homType  := lPoset.Hom.Hom.Pack lposet_homAxiom.
Definition lposet_ihomType := lPoset.iHom.iHom.Pack lposet_ihomAxiom.
Definition lposet_bhomType := lPoset.bHom.bHom.Pack lposet_bhomAxiom.
Definition lposet_embType  := lPoset.Emb.Emb.Pack lposet_embAxiom.
Definition lposet_isoType  := lPoset.Iso.Iso.Pack lposet_isoAxiom.

End ClassDef.

Module Export Exports.
Coercion apply : type >-> Funclass.
Coercion  homType : type >-> Hom.type.
Coercion lposet_homType  : type >-> lPoset.Hom.Hom.type.
Coercion lposet_ihomType : type >-> lPoset.iHom.iHom.type.
Coercion lposet_bhomType : type >-> lPoset.bHom.bHom.type.
Coercion lposet_embType  : type >-> lPoset.Emb.Emb.type.
Coercion lposet_isoType  : type >-> lPoset.Iso.Iso.type.
Canonical  homType.
Canonical lposet_homType.
Canonical lposet_ihomType.
Canonical lposet_bhomType.
Canonical lposet_embType.
Canonical lposet_isoType.
End Exports.

End Iso.

Export Iso.Exports.

Module Export Syntax.
Notation iso := Iso.type.
Notation "{ 'iso' T }" := (@Iso.type_of _ _ _ (Phant T)) : prime_eventstruct_scope.
Notation "[ 'iso' 'of' f ]" :=
  (Iso.mk (fun hCls => @Iso.Pack _ _ _ f hCls))
  (at level 0, format "[ 'iso'  'of'  f ]") : prime_eventstruct_scope.
End Syntax.

Module Export Theory.
Section Theory.
Context {L : Type} {E1 E2 : PrimeC.eventType L} (f : {iso E1 -> E2}).

Lemma wcons_mono :
  { mono (@!f) : X / wcons X }.
Proof. by case: f=> ? []. Qed.

End Theory.
End Theory.

Module Build.
Section Build.
Context {L : Type} {E E1 E2 E3 : eventType L}.
Implicit Types (f : {iso E2 -> E3}) (g : {iso E1 -> E2}).

Lemma id_axiom : Iso.axiom (@idfun E).
Proof.
  constructor=> //=; last by exists id.
  by move=> X; rewrite imfset_id.
Qed.

Lemma comp_axiom f g : Iso.axiom (f \o g).
Proof.
  apply/Iso.iso_axiom_of.
  - exact/lPoset.Iso.Build.comp_axiom.
  by move=> X /=; rewrite imfset_comp !wcons_mono.
Qed.

End Build.

Module Export Exports.
Section Exports.
Context {L : Type} {E E1 E2 E3 : eventType L}.
Implicit Types (f : {iso E2 -> E3}) (g : {iso E1 -> E2}).

Canonical id_bhom := Iso.Pack (@id_axiom L E).
Canonical comp_bhom f g := Iso.Pack (comp_axiom f g).

End Exports.
End Exports.

End Build.

End Iso.

End PrimeC.

Export PrimeC.EventStruct.Exports.
Export PrimeC.Def.
Export PrimeC.Theory.
Export PrimeC.Syntax.

Export PrimeC.Hom.Hom.Exports.
Export PrimeC.Iso.Iso.Exports.

Export PrimeC.Hom.Build.Exports.
Export PrimeC.Iso.Build.Exports.

Export PrimeC.Hom.Theory.
Export PrimeC.Iso.Theory.

Module Prime.

Module Export EventStruct.
Section ClassDef.

Record mixin_of (E0 : Type) (L : Type) (b : lPoset.lPoset.class_of E0 L)
                (E := lPoset.lPoset.Pack b) := Mixin {
  (* TODO: better name *)
  bcf : rel E;
  _   : irreflexive bcf;
  _   : symmetric bcf;
  _   : hereditary ca bcf;
}.

Set Primitive Projections.
Record class_of (E L : Type) := Class {
  base   : lPoset.lPoset.class_of E L;
  mixin1 : DwFinPOrder.DwFinPOrder.mixin_of base;
  mixin2 : Countable.mixin_of E;
  mixin3 : Ident.mixin_of (Countable.Class base mixin2);
  mixin4 : mixin_of base;
}.
Unset Primitive Projections.

Local Coercion base : class_of >-> lPoset.lPoset.class_of.

Local Coercion base2 E L (c : class_of E L) :
  DwFinPOrder.DwFinPOrder.class_of E :=
    DwFinPOrder.DwFinPOrder.Class (mixin1 c).

Local Coercion base3 E L (c : class_of E L) :
  Ident.class_of E := Ident.Class (mixin3 c).

Structure type (L : Type) := Pack { sort; _ : class_of sort L }.

Local Coercion sort : type >-> Sortclass.

Variables (E : Type) (L : Type) (cT : type L).

Definition class := let: Pack _ c as cT' := cT return class_of (sort cT') L in c.
Definition clone c of phant_id class c := @Pack E L c.
(* Definition clone_with disp' c of phant_id class c := @Pack disp' T c. *)

Definition pack :=
  fun bE b & phant_id (@lPoset.lPoset.class L bE) b =>
  fun m1 m2 m3 m4 => Pack (@Class E L b m1 m2 m3 m4).

Definition eqType := @Equality.Pack cT class.
Definition choiceType := @Choice.Pack cT class.
(* TODO: countType missing *)
Definition identType := @Ident.Pack cT class.
Definition porderType := @Order.POrder.Pack tt cT class.
Definition dwFinPOrderType := @DwFinPOrder.DwFinPOrder.Pack cT class.
Definition lposetType := @lPoset.lPoset.Pack L cT class.
End ClassDef.

Module Export Exports.
Coercion base : class_of >-> lPoset.lPoset.class_of.
Coercion base2 : class_of >-> DwFinPOrder.DwFinPOrder.class_of.
Coercion mixin1 : class_of >-> DwFinPOrder.DwFinPOrder.mixin_of.
Coercion mixin2 : class_of >-> Countable.mixin_of.
Coercion mixin3 : class_of >-> Ident.mixin_of.
Coercion mixin4 : class_of >-> mixin_of.
Coercion sort : type >-> Sortclass.
Coercion eqType : type >-> Equality.type.
Coercion choiceType : type >-> Choice.type.
Coercion identType  : type >-> Ident.type.
Coercion porderType : type >-> Order.POrder.type.
Coercion dwFinPOrderType : type >-> DwFinPOrder.DwFinPOrder.type.
Coercion lposetType : type >-> lPoset.eventType.
Canonical eqType.
Canonical choiceType.
Canonical identType.
Canonical porderType.
Canonical dwFinPOrderType.
Canonical lposetType.
End Exports.

End EventStruct.

Export EventStruct.Exports.

Notation eventType := EventStruct.type.
Notation eventStruct := EventStruct.class_of.
Notation EventType E L m := (@EventStruct.pack E L _ _ id m).

Module Export Def.
Section Def.

Variable (L : Type) (E : eventType L).

Definition bcf : rel E :=
  EventStruct.bcf (EventStruct.class E).

End Def.
End Def.

Prenex Implicits bcf.

Module Instances.
Section Instances.
Context {L : Type} {E : eventType L}.
Implicit Types (e : E) (X Y : {fset E}).

Definition cons X :=
  ~~ [exists e1 : X, exists e2 : X, bcf (val e1) (val e2)].

Lemma bcf_irr : irreflexive (bcf : rel E).
Proof. by case: E => ? [?] ??? []. Qed.

Lemma bcf_sym : symmetric (bcf : rel E).
Proof. by case: E => ? [?] ??? []. Qed.

Lemma bcf_hered : hereditary ca (bcf : rel E).
Proof. by case: E => ? [?] ??? []. Qed.

Lemma cons_self e : cons [fset e].
Proof.
  apply /fset_exists2P=> [] [] x [] y [].
  by move=> /fset1P -> /fset1P ->; rewrite bcf_irr.
Qed.

Lemma cons0 : cons fset0.
Proof. by apply/fset_exists2P=>[[>[>[]]]]. Qed.

(* TODO: rename cons_of_contra? *)
Lemma cons_contra (X Y : {fset E}) : X `<=` Y -> cons Y -> cons X.
Proof.
  move=> sub /= /fset_exists2P nCF.
  apply/fset_exists2P=> [[]] x [] y [].
  move=> /(fsubsetP sub) ? /(fsubsetP sub) ??.
  by apply /nCF; exists x, y.
Qed.

Lemma cons_prop (X : {fset E}) (e1 e2 : E) :
  e1 <= e2 -> cons (e2 |` X) -> cons (e1 |` X).
Proof.
  move => ca12 /fset_exists2P ncf.
  apply/fset_exists2P=> [[]] e3 [] e4 [].
  rewrite !inE=> /orP [/eqP->|/[swap]]/orP[/eqP->|].
  - by rewrite bcf_irr.
  - move=> inX cf14; apply/ncf.
    exists e4, e2; rewrite !inE; split.
    + by apply/orP; right.
    + by apply/orP; left.
    by apply/(bcf_hered _ ca12); rewrite bcf_sym.
  - move=> inX cf31; apply/ncf.
    exists e3, e2; rewrite !inE; split.
    + by apply/orP; right.
    + by apply/orP; left.
    by apply/(bcf_hered _ ca12).
  move=> ???; apply/ncf.
  exists e3, e4; rewrite !inE.
  by split=> //; apply/orP; right.
Qed.

Definition primeCMixin :=
  PrimeC.EventStruct.Mixin
    cons0
    cons_self
    cons_contra
    cons_prop.

Definition primeCeventType :=
  PrimeC.EventStruct.Pack
  (PrimeC.EventStruct.Class (class E) (mixin3 (class E)) primeCMixin).

End Instances.

Module Export Exports.
Coercion primeCeventType : type >-> PrimeC.EventStruct.type.
Canonical primeCeventType.
End Exports.

End Instances.

Export Instances.Exports.

Module Export Theory.
Section Theory.
Context {L : Type} {E : eventType L}.
Implicit Types (e : E) (X Y : {fset E}).

Lemma bcfE :
  (bcf : rel E) =2 cf.
Proof.
  rewrite /cf /gcf /cons /= => e1 e2 /=.
  rewrite negbK; apply/idP/idP.
  - move=> ?; apply/fset_exists2P.
    by exists e1, e2; rewrite !inE !eq_refl orbT; split=> //.
  move=> /fset_exists2P[] e [] e' [].
  rewrite !inE=> /orP[/eqP->|/eqP->] /orP[/eqP->|/eqP->] //;
    try by rewrite Instances.bcf_irr.
  by rewrite Instances.bcf_sym.
Qed.

Lemma bgcfP X :
  reflect (exists e1 e2, [/\ e1 \in X, e2 \in X & cf e1 e2]) (gcf X).
Proof.
  apply/(equivP idP); split; last first.
  - move=> [e1] [e2] []; exact/cf_gcf.
  rewrite /gcf /cons /=.
  rewrite negbK=> /fset_exists2P [] e1 [] e2 [].
  by rewrite bcfE=> ???; exists e1, e2.
Qed.

Lemma bgcfE X :
  gcf X = [exists e1 : X, exists e2 : X, cf (val e1) (val e2)].
Proof. apply/(sameP (bgcfP X)); exact/fset_exists2P. Qed.

End Theory.
End Theory.

End Prime.

Export Prime.EventStruct.Exports.
Export Prime.Instances.Exports.
Export Prime.Theory.

(* Section Test. *)

(* Context {L : Type} {E : Prime.eventType L}. *)
(* Variable (e1 e2 : E) (s : {fset E}). *)

(* Check (e1 <= e2 : bool). *)
(* Check (e1 \# e2 : bool). *)
(* Check (PrimeG.gcf s : bool). *)

(* End Test. *)


(* Show that Varieties with homomorphisms between them form a category.

Hm, this file is almost identical to categories/algebra because the morphism are the same. There must be some way to
factor out the commonality.

 *)
Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.universal_algebra MathClasses.theory.ua_homomorphisms.

Record Object (et: EquationalTheory) : Type := object
  { variety_carriers:> sorts et → Type
  ; variety_equiv: ∀ a, Equiv (variety_carriers a)
  ; variety_ops: AlgebraOps et variety_carriers
  ; variety_proof: InVariety et variety_carriers }.
Arguments object _ _ {variety_equiv variety_ops variety_proof}.

(* Avoid Coq trying to apply variety_equiv to find arbitrary Equiv instances *)
#[global]
Hint Extern 0 (Equiv (variety_carriers _ _ _)) => eapply @variety_equiv : typeclass_instances.
#[global]
Existing Instance variety_ops.
#[global]
Existing Instance variety_proof.

Section contents.
  Variable et: EquationalTheory.

  Global Instance: Arrows (Object et) := λ X Y, sig (HomoMorphism et X Y).

  Program Definition arrow `{InVariety et A} `{InVariety et B}
    f `{!HomoMorphism et A B f}: object et A ⟶ object et B := f.

  Global Program Instance: CatId (Object et) := λ _ _, id.

  Global Program Instance: CatComp (Object et) := λ _ _ _ f g v, f v ∘ g v.

  Global Program Instance: ∀ (x y: Object et), Equiv (x ⟶ y)
    := λ _ _ x y, ∀ b, pointwise_relation _ (=) (x b) (y b).

  Global Instance: ∀ (x y: Object et), Setoid (x ⟶ y).
  Proof.
   constructor.
     repeat intro. reflexivity.
    intros ? ? E ? ?. symmetry. apply E.
   intros ? ? ? E F ? ?. rewrite (E _ _). apply F.
  Qed.
  Instance: ∀ (x y z: Object et), Proper ((=) ==> (=) ==> (=)) (comp x y z).
  Proof.

   intros ??? ? ? E ? ? F ? ?. simpl.
   unfold compose. rewrite (F _ _), (E _ _). reflexivity.
  Qed.

  Global Instance: Category (Object et).
  Proof. constructor; try apply _; repeat intro; reflexivity. Qed.
End contents.


Require Export GeoCoq.Elements.OriginalProofs.proposition_29.

Section Euclid.

Context `{Ax:euclidean_euclidean}.

Lemma proposition_29B :
   forall A D G H,
   Par A G H D -> TS A G H D ->
   CongA A G H G H D.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists a d g h m, (neq A G /\ neq H D /\ Col A G a /\ Col A G g /\ neq a g /\ Col H D h /\ Col H D d /\ neq h d /\ ~ Meet A G H D /\ BetS a m d /\ BetS h m g)) by (conclude_def Par );destruct Tf as [a[d[g[h[m]]]]];spliter.
assert (neq D H) by (conclude lemma_inequalitysymmetric).
assert (~ eq H G).
 {
 intro.
 assert (eq H H) by (conclude cn_equalityreflexive).
 assert (Col H D H) by (conclude_def Col ).
 assert (eq G G) by (conclude cn_equalityreflexive).
 assert (Col A G G) by (conclude_def Col ).
 assert (Col A G H) by (conclude cn_equalitysub).
 assert (Meet A G H D) by (conclude_def Meet ).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists B, (BetS A G B /\ Cong G B A G)) by (conclude lemma_extension);destruct Tf as [B];spliter.
let Tf:=fresh in
assert (Tf:exists C, (BetS D H C /\ Cong H C D H)) by (conclude lemma_extension);destruct Tf as [C];spliter.
let Tf:=fresh in
assert (Tf:exists E, (BetS H G E /\ Cong G E H G)) by (conclude lemma_extension);destruct Tf as [E];spliter.
assert (neq A B) by (forward_using lemma_betweennotequal).
assert (neq B A) by (conclude lemma_inequalitysymmetric).
assert (neq D C) by (forward_using lemma_betweennotequal).
assert (neq C D) by (conclude lemma_inequalitysymmetric).
assert (Col A G B) by (conclude_def Col ).
assert (Col G A B) by (forward_using lemma_collinearorder).
assert (Col G A a) by (forward_using lemma_collinearorder).
assert (neq G A) by (conclude lemma_inequalitysymmetric).
assert (Col A B a) by (conclude lemma_collinear4).
assert (Col G A g) by (forward_using lemma_collinearorder).
assert (Col A B g) by (conclude lemma_collinear4).
assert (Col D H C) by (conclude_def Col ).
assert (Col H D C) by (forward_using lemma_collinearorder).
assert (Col D C h) by (conclude lemma_collinear4).
assert (Col C D h) by (forward_using lemma_collinearorder).
assert (Col D d C) by (conclude lemma_collinear4).
assert (Col C D d) by (forward_using lemma_collinearorder).
assert (~ Meet A B C D).
 {
 intro.
 let Tf:=fresh in
 assert (Tf:exists M, (neq A B /\ neq C D /\ Col A B M /\ Col C D M)) by (conclude_def Meet );destruct Tf as [M];spliter.
 assert (Col B A G) by (forward_using lemma_collinearorder).
 assert (Col B A M) by (forward_using lemma_collinearorder).
 assert (Col A G M) by (conclude lemma_collinear4).
 assert (Col C D H) by (forward_using lemma_collinearorder).
 assert (Col D H M) by (conclude lemma_collinear4).
 assert (Col H D M) by (forward_using lemma_collinearorder).
 assert (Meet A G H D) by (conclude_def Meet ).
 contradict.
 }
assert (Par A B C D) by (conclude_def Par ).
assert (BetS C H D) by (conclude axiom_betweennesssymmetry).
assert (BetS E G H) by (conclude axiom_betweennesssymmetry).
assert ((CongA A G H G H D /\ CongA E G B G H D /\ RT B G H G H D)) by (conclude proposition_29).
close.
Qed.

End Euclid.


(* This file is part of the Linear Logic formalization in Coq:
https://github.com/brunofx86/LL *)

(** ** Focusing: Basic Definitions
In this file we define the polarity of the formulas and some results
about them. These definitions are needed for the specification of the
focused system.
 *)

Require Export LL.MultisetLL.
Require Export Syntax.
Require Export LL.MetaTheory.StrongInduction.
Require Import Coq.Arith.EqNat.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Import Omega.
Require Export LL.myTactics.
Require Export List.
Export ListNotations.
Require Import Coq.Program.Equality.

Set Implicit Arguments.

(** Asynchronous formulas *)

Definition AsynchronousF (F :lexp) :=
  match F with
  | Atom _ => false
  | Perp _ => false
  | Top => true
  | Bot => true
  | Zero => false
  | One => false
  | Tensor _ _ => false
  | Par _ _ => true
  | Plus _ _ => false
  | With _ _ => true
  | Bang _ => false
  | Quest _ => true
  end.

Inductive Asynchronous : lexp -> Prop :=
| ATop :   Asynchronous Top
| ABot :   Asynchronous Bot
| APar :   forall F G, Asynchronous (Par F G)
| AWith :  forall F G, Asynchronous (With F G)
| AQuest : forall F  , Asynchronous (Quest F).

Hint Constructors Asynchronous.

Theorem AsyncEqR : forall F:lexp, AsynchronousF F = true -> Asynchronous F.
Proof.
  intros.
  destruct F;auto;try (inversion H).
Qed.

Theorem AsyncEqL : forall F:lexp, Asynchronous F -> AsynchronousF F = true.
Proof.
  intros.
  destruct F;inversion H;reflexivity.
Qed.

(** Negative Atoms *)
Inductive IsNegativeAtom : lexp -> Prop :=
  IsNA : forall v, IsNegativeAtom (Perp v).

Hint Constructors IsNegativeAtom.

Definition IsNegativeAtomF (F:lexp) :=
  match F with
  | Perp _ => true
  | _ => false
  end.

(** Complexity for list of formulas *)
Fixpoint exp_weight (P:lexp) : nat :=
  match P with
  | Atom X => 1
  | Perp X => 1
  | One => 1
  | Bot => 1
  | Zero => 1
  | Top => 1
  | Tensor X Y => 1 + (exp_weight X) + (exp_weight Y)
  | Par X Y => 1 + (exp_weight X) + (exp_weight Y)
  | Plus X Y => 1 + (exp_weight X) + (exp_weight Y)
  | With X Y  => 1 + (exp_weight X) + (exp_weight Y)
  | Bang X => 1 + exp_weight X
  | Quest X  => 1 + exp_weight X
  end.

Theorem exp_weight0 : forall  F:lexp, exp_weight F > 0.
Proof.
  intro.
  induction F;simpl;omega.
Qed.

Theorem exp_weight0F : forall  F:lexp, exp_weight F = 0%nat -> False.
Proof.
  intros.
  generalize(exp_weight0 F).
  intro.
  rewrite H in H0.
  inversion H0.
Qed.

(* Complexity of list of formulas  *)
Fixpoint L_weight (L: list lexp) : nat :=
  match L with
  | nil => 0
  | H :: L' => (exp_weight H) + (L_weight L')
  end.

Theorem exp_weight0LF : forall l L, 0%nat = exp_weight l + L_weight L -> False.
Proof.
  intros.
  assert(exp_weight l > 0%nat) by (apply exp_weight0).
  omega.
Qed.

Theorem L_weightApp : forall L M, L_weight (L ++M) = L_weight L + L_weight M.
Proof.
  intros.
  induction L; auto.
  simpl.
  rewrite IHL.
  omega.
Qed.

Lemma GtZero : forall n, n >0 -> exists n', n = S n'.
Proof.
  intros.
  destruct n.
  inversion H.
  exists n;auto.
Qed.

(** Lists of positive formulas *)
Fixpoint lexpPos (l: list lexp) : Prop :=
  match l with
  | nil => True
  | H :: T => (AsynchronousF H = false) /\ lexpPos(T)
  end.

Fixpoint BlexpPos (l: list lexp) : bool :=
  match l with
  | nil => true
  | H :: T => andb (negb (AsynchronousF H)) ( BlexpPos T)
  end.

Theorem PosBool : forall l, BlexpPos l = true <-> lexpPos l.
Proof.
  intros.
  split;induction l;simpl;auto.
  - intro.
    split.
    rewrite andb_true_iff in H.
    destruct H.
    auto.
    rewrite negb_true_iff in H.
    auto.
    rewrite andb_true_iff in H.
    destruct H.
    auto.
  - intro.
    destruct H.
    apply IHl in H0.
    rewrite H.
    simpl.
    auto.
Qed.

Inductive lexpPos' : list lexp -> Prop :=
| l_nil : lexpPos' []
| l_sin : forall a, (AsynchronousF a = false) -> lexpPos' [a]
| l_cos : forall a l, lexpPos' [a] -> lexpPos' l -> lexpPos' (a::l).

Hint Resolve l_nil l_sin l_cos.

(* Properties of lexpPos *)
Lemma lexpPosUnion a L: lexpPos [a] -> lexpPos L -> lexpPos ([a] ++ L).
Proof.
  intros.
  simpl; firstorder.
Qed.

Lemma lexpPosUnion_inv a L: lexpPos ([a] ++ L) -> lexpPos [a] /\ lexpPos L.
Proof.
  intros.
  simpl in H.
  split; firstorder.
Qed.

Lemma lexpPos_lexpPos' M: lexpPos' M <-> lexpPos M.
Proof.
  split; intros.
  * induction H;
      try solve [simpl; auto].
    apply lexpPosUnion; auto.
  * induction M; intros; auto.
    apply lexpPosUnion_inv in H.
    destruct H.
    apply l_cos; auto.
    apply l_sin; firstorder.
Qed.

Lemma LPos1 L M: L =mul= M -> lexpPos L -> lexpPos M.
Proof.
  intros P H.
  apply lexpPos_lexpPos'.
  apply lexpPos_lexpPos' in H.
  apply Permutation_meq in P.
  induction P; subst.
  * apply l_nil.
  * inversion H; subst.
    apply l_cos; auto.
    apply l_cos; auto.
  * inversion_clear H.
    inversion_clear H1.
    apply l_cos; auto.
    apply l_cos; auto.
  * apply IHP2.
    apply IHP1;auto.
Qed.

Instance lexpPos_morph : Proper (meq ==> iff) (lexpPos).
Proof.
  intros L M Heq .
  split;intro.
  + eapply LPos1;eauto.
  + apply LPos1 with (L:=M);auto.

Qed.

Lemma LPos2 : forall M N L, L =mul= M ++ N -> lexpPos L -> lexpPos M.
Proof.
  induction M;intros;simpl;auto.
  assert (L =mul= M ++ (a::N)) by ( rewrite H; eauto).
  apply IHM in H1;auto.
  firstorder.
  apply LPos1 in H;auto.
  inversion H;auto.
Qed.

Lemma LPos3:  forall M N L, L =mul= M ++ N -> lexpPos L -> lexpPos N .
Proof.
  intros.
  rewrite union_comm_app in H.
  eapply LPos2 ;eassumption.
Qed.

Lemma WeightLeq: forall w l L, S w = L_weight (l :: L) -> L_weight L <= w.
Proof.
  intros.
  simpl in H.
  generalize (exp_weight0 l);intro.
  apply GtZero in H0.
  destruct H0.
  rewrite H0 in H.
  omega.
Qed.

Lemma AsynchronousFlexpPos : forall  l, AsynchronousF l = false -> lexpPos [l].
Proof.
  intros.
  constructor;auto.
  constructor.
Qed.

(** Arrows: Arrow [UP]  is used to denote the negative
phase. Arrow [DW]  is used to mark the positive phase *)

Inductive Arrow : Set :=
| UP : list lexp -> Arrow
| DW : lexp -> Arrow.

Fixpoint eqArrow (exp_1 exp_2 : Arrow) :=
  match exp_1, exp_2 with
  | DW a, DW b =>  a = b
  | UP A, UP B =>  A = B
  | _, _ => False
  end.

Lemma eqArrow_refl: forall x, eqArrow x x.
Proof.
  induction x; simpl; auto.
Qed.

Lemma eqArrow_symm: forall x y, eqArrow x y -> eqArrow y x.
Proof.
  induction x ; induction y; intros; simpl; auto.
Qed.

Lemma eqArrow_trans: forall x y z, eqArrow x y -> eqArrow y z -> eqArrow x z.
Proof.
  induction x ; induction y; induction z; intros; simpl in *; auto; subst; auto.
  contradiction.
  contradiction.
Qed.

Hint Resolve eqArrow_refl eqArrow_symm eqArrow_trans.

Add Parametric Relation : Arrow eqArrow
    reflexivity proved by eqArrow_refl
    symmetry proved by eqArrow_symm
    transitivity proved by eqArrow_trans as eq_arrow.

Declare Instance eqArrow_Equivalence : Equivalence eqArrow.

Lemma Arrow_eq_dec : forall A B: Arrow, {A = B} + {A <> B}.
Proof.
  intros A B; decide equality.
  apply list_eq_dec.
  apply LExp_eq_dec.
  apply LExp_eq_dec.
Qed.

Definition Arrow2LL (A: Arrow) : list lexp :=
  match A with
  | UP l => l
  | DW f => [f]
  end.

(* We assume a positive bias in the encodings *)
(** Definition of when a formula can be relased (from a positive phase to a negative phase *)
Definition ReleaseF (F:lexp ) :=
  match F with
  | Atom _ => false (* due to the bias *)
  | Perp _ => true
  | Top => true
  | Bot => true
  | Zero => false
  | One => false
  | Tensor _ _ => false
  | Par _ _ => true
  | Plus _ _ => false
  | With _ _ => true
  | Bang _ => false
  | Quest _ => true
  end.

Inductive Release : lexp-> Prop :=
| RelNA : forall v, Release (Perp v)
| RelTop : Release Top
| RelBot : Release Bot
| RelPar : forall F G, Release (Par F G)
| RelWith : forall F G, Release (With F G)
| RelQuest : forall F, Release (Quest F).

Hint Constructors Release.
Theorem ReleaseR : forall F:lexp, ReleaseF F = true -> Release F.
Proof.
  intros.
  destruct F;auto;try (inversion H).
Qed.
Theorem ReleaseL : forall F:lexp, Release F -> ReleaseF F = true.
Proof.
  intros.
  destruct F;inversion H;reflexivity.
Qed.

(** Some definitions for the proof of completeness *)
Inductive NotAsynchronous : lexp -> Prop :=
| NAAtomP :  forall v,  NotAsynchronous (Atom v)
| NAAtomN :  forall v,  NotAsynchronous (Perp v)
| NAZero :  NotAsynchronous Zero
| NAOne :  NotAsynchronous One
| NATensor : forall F G,  NotAsynchronous ( F ** G)
| NAPlus : forall F G,  NotAsynchronous ( Plus F  G)
| NABang : forall F,  NotAsynchronous ( ! F ).

Hint Constructors NotAsynchronous.

Theorem AsynchronousEquiv : forall F, NotAsynchronous F <-> ~ Asynchronous F.
Proof.
  intros.
  split.
  + destruct F; intros H Hn; try(inversion Hn) ; try (inversion H).
  + intro H.
    destruct F;auto; (try  contradict H; auto).
Qed.

Inductive PosOrPosAtom : lexp -> Prop :=
| PPAtom :  forall v,  PosOrPosAtom (Atom v)
| PPZero :  PosOrPosAtom Zero
| PPOne :  PosOrPosAtom One
| PPTensor : forall F G,  PosOrPosAtom ( F ** G)
| PPPlus : forall F G,  PosOrPosAtom ( Plus F  G)
| PPBang : forall F,  PosOrPosAtom ( ! F ).

Hint Constructors PosOrPosAtom.

Inductive NotPosOrPosAtom : lexp -> Prop :=
| NPPAtom :  forall v,  NotPosOrPosAtom (Perp v)
| NPPTop : NotPosOrPosAtom Top
| NPPBot : NotPosOrPosAtom Bot
| NPPPar : forall F G, NotPosOrPosAtom (Par F G)
| NPPWith : forall F G, NotPosOrPosAtom (With F G)
| NPPQuest : forall F , NotPosOrPosAtom (Quest F).

Hint Constructors NotPosOrPosAtom.

Lemma DecPosOrPosAtom1 : forall F, PosOrPosAtom F -> ~ NotPosOrPosAtom F.
Proof.
  intros F H Hn .
  destruct F;try (inversion H);try(inversion Hn).
Qed.

Lemma DecPosOrPosAtom : forall F, NotPosOrPosAtom F \/ PosOrPosAtom F.
Proof.
  intros.
  destruct F; [right | left   | left |left|right |right| right|left| right|left|right|left];auto.
Qed.

Lemma NotPosOrPosAtomRelease : forall F, NotPosOrPosAtom F -> ReleaseF F = true.
Proof.
  intros.
  destruct H;reflexivity.
Qed.

Lemma PosOrPosAtomAsync : forall F, PosOrPosAtom F ->  AsynchronousF F = false.
Proof.
  intros.
  destruct F;(try inversion H); reflexivity.
Qed.

Lemma plus_le_reg_r: forall n m p : nat, n + p <= m + p -> n <= m.
Proof.
  intros.
  assert (n+p = p + n) by (apply plus_comm).
  assert (m+p = p + m) by (apply plus_comm).
  rewrite H0 in H. rewrite H1 in H.
  eapply plus_le_reg_l in H.
  assumption.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(* Revised and adapted to use Coq V6.1 features by the author               *)
(* February 1997                                                            *)
(****************************************************************************)
(*   script coq V5.8.3                                                      *)
(*                                                                          *)
(*                                                                          *)
(*   An exercise on groups                                                  *)
(*                                                                          *)
(*                                                                          *)
(*   Pierre Casteran.                                                       *)
(*   LaBRI [casteran@labri.u-bordeaux.fr]                                   *)
(*                                                                          *)
(*                                                                          *)
(*  This file presents a development in Coq of the following lemma:         *)
(*  "Let E be a non-empty set, o an associative law on E,                   *)
(*   such that for each x:E, the functions [y:E](o x y) and                 *)
(*   [y:E](o y x) are onto.                                                 *)
(*   Then E is a group"                                                     *)
(*                                                                          *)
(*  See groups.ps.gz in this directory                                      *)
(*                                                                          *)
(****************************************************************************)
(*                                 Groups.v                                 *)
(****************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.

Section General_definitions.
 Variable E : Set.
 Definition onto (f : E -> E) := forall y : E, {x : E | f x = y}.

 Variable o : E -> E -> E.
 Variable e : E.
 Variable s : E -> E.
 Definition associative := forall x y z : E, o x (o y z) = o (o x y) z.
 Definition left_neutral := forall x : E, o e x = x.
 Definition right_neutral := forall x : E, o x e = x.
 Definition left_symmetric := forall x : E, o (s x) x = e.
 Definition right_symmetric := forall x : E, o x (s x) = e.
End General_definitions.

(* what is a group on E ? *)

Record group (E : Set) : Set := mkgroup
  {group_law : E -> E -> E;
    (* composition law *)
    group_assoc : associative group_law;
   group_neutral : E;
    (* neutral element *)
    group_sym : E -> E;
    (* symmetric *)
    group_l_neutral : left_neutral group_law group_neutral;
   group_r_neutral : right_neutral group_law group_neutral;
   group_l_sym : left_symmetric group_law group_neutral group_sym;
   group_r_sym : right_symmetric group_law group_neutral group_sym}.

Section some_properties_of_groups.

 Variable E : Set.
 Variable G : group E.

 Let o := group_law G.
 Let s := group_sym G.
 Let e := group_neutral G.
 Let assoc := group_assoc G.
 Let l_neutral := group_l_neutral G.
 Let r_neutral := group_r_neutral G.
 Let l_sym := group_l_sym G.
 Let r_sym := group_r_sym G.
 Hint Resolve assoc l_sym l_neutral r_sym r_neutral.
 Hint Unfold o s e.

 (**************************************************)
 Lemma solve_equation : forall x y : E, o x y = e -> y = s x.
 (**************************************************)
  Proof.
   intros x y H.
   transitivity (o e y).
   symmetry  in |- *; auto.
   transitivity (o (s x) (o x y)).
   transitivity (o (o (s x) x) y).
   unfold o, e, s in |- *; rewrite (l_sym x); auto.
   auto.
   rewrite H; auto.
  Qed.
 Hint Resolve solve_equation.

 (***************************)
 Lemma ssx : forall x : E, x = s (s x).
 (***************************)
  Proof.
   auto.
  Qed.

End some_properties_of_groups.

Section The_exercise_itself.

Variable E : Set.
Variable a : E.
Variable o : E -> E -> E.
Hypothesis o_assoc : associative o.
Hypothesis o_onto_r : forall x : E, onto (fun y : E => o x y).
Hypothesis o_onto_l : forall x : E, onto (fun y : E => o y x).
Hint Resolve o_assoc o_onto_r o_onto_l.

(**********************************
 Building the neutral element ...
************************************)

(*****************************)
Lemma Ea : {ea : E | o a ea = a}.
(*****************************)
Proof.
case (o_onto_r a a); intros x H; exists x; auto.
(*
  Realizer (o_onto_r a a).
  Program_all.
*)
Qed.

(* A right neutral element *)

Definition e := let (e, _) := Ea in e.

(***********************************)
Lemma r_neutral : right_neutral o e.
(***********************************)
Proof.
  unfold right_neutral, e in |- *; case Ea.
  intros e0 eg x.
  (*
  e0 : E
  eg : (o a e0)=a
  x : E
  ============================
  (o x e0)=x
  *)
  case (o_onto_l a x); intros u eg'.
  rewrite <- eg'. (* (o (o u a) e0)=(o u a) *)
  rewrite <- (o_assoc u a e0).
  rewrite eg; auto.
Qed.

Hint Resolve r_neutral.

(*******************************)
Lemma E'a : {e'a : E | o e'a a = a}.
(*******************************)
Proof.
 case (o_onto_l a a); intros x H; exists x; auto.

(*
  Realizer (o_onto_l a a).
  Program_all.
*)

Qed.

Definition e' := let (e', _) := E'a in e'.

(***************************************)
Lemma e'_l_neutral : left_neutral o e'.
(**************************************)
Proof.
  unfold left_neutral, e' in |- *; case E'a.
 intros e'0 eg x.
 case (o_onto_r a x); intros u eg'.
 rewrite <- eg'.
 rewrite (o_assoc e'0 a u).
 rewrite eg; auto.
Qed.

Hint Resolve e'_l_neutral.

(*******************)
Lemma e_eq_e' : e = e'.
(*******************)
Proof.
 transitivity (o e' e).
 symmetry  in |- *; auto.
 auto.
Qed.

(*********************************)
Lemma l_neutral : left_neutral o e.
(*********************************)
Proof.
 rewrite e_eq_e'; auto.
Qed.
Hint Resolve l_neutral.

(***********************************************************
 we can now use the new element e to study the symmetrical
***********************************************************)

(*********************************)
Lemma lsym : forall x : E, {y : E | o y x = e}.
(*********************************)
Proof.
 intro x.
 case (o_onto_l x e); intros u H; exists u; auto.
Qed.

Definition s (x : E) := let (y, _) return E := lsym x in y.

(*********************************)
Lemma l_sym : left_symmetric o e s.
(*********************************)
Proof.
  unfold left_symmetric, s in |- *; intros.
  case (lsym x); auto.
Qed.
Hint Resolve l_sym.

(*********************************)
Lemma rsym : forall x : E, {y : E | o x y = e}.
(*********************************)
Proof.
 intro x.
 case (o_onto_r x e); intros u H; exists u; auto.
Qed.

(* provisional right symmetrical *)

Definition s' (x : E) := let (y, _) return E := rsym x in y.

(******************************)
Lemma s_eq_s' : forall x : E, s x = s' x.
(******************************)
Proof.
 intro x; unfold s, s' in |- *; case (rsym x); case (lsym x).
 intros y eg y' eg'.
 transitivity (o y e). auto.
 rewrite <- eg'.
 rewrite (o_assoc y x y').
 rewrite eg; auto.
Qed.

(**********************************)
Lemma r_sym : right_symmetric o e s.
(**********************************)
Proof.
 unfold right_symmetric in |- *; intro x.
 rewrite s_eq_s'.
 unfold s' in |- *; case (rsym x); auto.
Qed.

Hint Resolve r_sym.

(******************************)
Theorem E_is_a_group : group E.
(******************************)
Proof.
 apply mkgroup with o e s; auto.
Qed.

End The_exercise_itself.


Require Import coqutil.sanity.
Unset Universe Minimization ToSet.
Require Export riscv.Utility.PowerFunc.

Section RunsTo.

  Context {State: Type}.
  Variable step: State -> (State -> Prop) -> Prop.

  Inductive runsTo(initial: State)(P: State -> Prop): Prop :=
    | runsToDone:
        P initial ->
        runsTo initial P
    | runsToStep: forall midset,
        step initial midset ->
        (forall mid, midset mid -> runsTo mid P) ->
        runsTo initial P.

  Hint Constructors runsTo : runsTo_hints.

  Lemma runsTo_trans: forall P Q initial,
    runsTo initial P ->
    (forall middle, P middle -> runsTo middle Q) ->
    runsTo initial Q.
  Proof.
    induction 1; eauto with runsTo_hints.
  Qed.

  Hint Resolve runsTo_trans : runsTo_hints.

  Lemma runsTo_weaken: forall (P Q : State -> Prop) initial,
    runsTo initial P ->
    (forall final, P final -> Q final) ->
    runsTo initial Q.
  Proof.
    eauto with runsTo_hints.
  Qed.

  Lemma runsTo_det_step : forall initialL midL P,
    step initialL (eq midL) ->
    runsTo midL P ->
    runsTo initialL P.
  Proof.
    intros.
    eapply runsToStep; [eassumption|].
    intros. subst.
    assumption.
  Qed.

  Lemma runsToStep_cps initial P (H : step initial (fun s => runsTo s P))
    : runsTo initial P.
  Proof. eapply runsToStep; eauto. Qed.

  Lemma runsTo_trans_cps: forall (Q : State -> Prop) (initial : State),
      runsTo initial (fun middle => runsTo middle Q) ->
      runsTo initial Q.
  Proof.
    intros. eapply runsTo_trans; eauto.
  Qed.
End RunsTo.


From FOL Require Import FullSyntax Arithmetics Theories.
From Undecidability.Shared Require Import ListAutomation.
From FOL.Tennenbaum Require Import NumberUtils Formulas SyntheticInType Peano.

(* Require Import FOL Tarski Deduction Peano Formulas NumberTheory Synthetic DecidabilityFacts. *)
Require Import Lia.
From Equations Require Import Equations.

Import Vector.VectorNotations.

Notation "x 'el' A" := (List.In x A) (at level 70).
Notation "A '<<=' B" := (List.incl A B) (at level 70).
Notation "x ∣ y" := (exists k, x * k = y) (at level 50).

Definition unary α := bounded 1 α.
Definition binary α := bounded 2 α.

Section ChurchThesis.

Instance ff : falsity_flag := falsity_on.
Context {Δ1 : Delta1}.

(** * Church's Thesis *)

(** ** CT_Q  *)

(*  CT_Q internalizes computability, by claiming that every function
    nat -> nat is computable in a model of computation. In this case,
    the model of computaion is based on arithmetic: It represents
    functions by formulas in the language of PA in such a way that a
    weak fragment (Q <<= PA) can prove the agreement of the formula
    with the function on every input.
 *)

Definition represents ϕ f := forall x, Q ⊢I ∀ ϕ[up (num x)..] ↔ $0 == num (f x).
Definition CT_Q := forall f : nat -> nat, exists ϕ, bounded 3 ϕ /\ inhabited(delta1 ϕ) /\ represents (∃ ϕ) f.

(*  Weaker Version of CT_Q, where the existence of the formula
    is only given potentially (i.e. behing a double negation).
 *)
Definition WCT_Q := forall f : nat -> nat, ~ ~ exists ϕ, bounded 3 ϕ /\ inhabited(delta1 ϕ) /\ represents (∃ ϕ) f.

(** Strong Representability *)

Definition strong_repr ϕ (p : nat -> Prop) := (forall x, p x -> Q ⊢I ϕ[(num x)..]) /\ (forall x, ~ p x -> Q ⊢I ¬ϕ[(num x)..]).
Definition RT_strong := forall p : nat -> Prop, Dec p -> exists ϕ, bounded 2 ϕ /\ inhabited(delta1 ϕ) /\ strong_repr (∃ ϕ) p.
Definition WRT_strong := forall p : nat -> Prop, Dec p ->  ~ ~ exists ϕ, bounded 2 ϕ /\ inhabited(delta1 ϕ) /\ strong_repr (∃ ϕ) p.

(** Weak Representability *)

Definition weak_repr ϕ (p : nat -> Prop) := (forall x, p x <-> Q ⊢I ϕ[(num x)..]).
Definition RT_weak := forall p : nat -> Prop, enumerable p -> exists ϕ, bounded 3 ϕ /\ inhabited(delta1 ϕ) /\ weak_repr (∃∃ ϕ) p.
Definition WRT_weak := forall p : nat -> Prop, enumerable p -> ~ ~ exists ϕ, bounded 3 ϕ /\ inhabited(delta1 ϕ) /\ weak_repr (∃∃ ϕ) p.

Definition RT := RT_strong /\ RT_weak.

Lemma prv_split {p : peirce} α β Gamma :
  Gamma ⊢ α ↔ β <-> Gamma ⊢ (α → β) /\ Gamma ⊢ (β → α).
Proof.
  split; intros H.
  - split.
    + eapply CE1. apply H.
    + eapply CE2. apply H.
  - now constructor.
Qed.

Lemma up_switch ϕ s t :
  ϕ[up (num s)..][up (num t)..] = ϕ[up (up (num t)..)][up (num s)..].
Proof.
  rewrite !subst_comp. apply subst_ext.
  intros [|[|[]]]; cbn; now rewrite ?num_subst.
Qed.

Lemma CT_WCT :
  CT_Q -> WCT_Q.
Proof. intros ct f. specialize (ct f). tauto. Qed.

(** ** Strong part of the representability theorem.  *)
Lemma CT_RTs :
  CT_Q -> RT_strong.
Proof.
  intros ct p Dec_p.
  destruct (Dec_decider_nat _ Dec_p) as [f Hf].
  destruct (ct f) as [ϕ [b2 [[s1] H]]].
  pose (Φ := ϕ[up (num 0)..]).
  exists Φ. split; unfold Φ.
  { asimpl. eapply subst_bound; eauto.
    intros [|[|[]]] G; cbn; try lia. all: solve_bounds. }
  split.
  { constructor. now apply delta1_subst. }
  repeat split.
  all: intros x; specialize (H x).
  all: eapply AllE with (t := num 0) in H; cbn -[Q] in H.
  all: apply prv_split in H; destruct H as [H1 H2].
  - intros px%Hf. symmetry in px.
    eapply num_eq with (Gamma := Q)(p := intu) in px; [|firstorder].
    eapply IE. cbn -[Q num]. rewrite up_switch.
    apply H2. now rewrite num_subst.
  - intros npx. assert (0 <> f x) as E by firstorder.
    apply num_neq with (Gamma := Q)(p := intu) in E; [|firstorder].
    apply II. eapply IE.
    {eapply Weak; [apply E|now right]. }
    eapply IE; [|apply Ctx; now left].
    rewrite num_subst in H1. eapply Weak.
    + cbn -[Q num]. rewrite up_switch. apply H1.
    + now right.
Qed.

Lemma WCT_WRTs :
  WCT_Q -> WRT_strong.
Proof.
  intros wct p Dec_p.
  destruct (Dec_decider_nat _ Dec_p) as [f Hf].
  apply (DN_chaining (wct f)), DN. intros [ϕ [b2 [[s1] H]]].
  pose (Φ := ϕ[up (num 0)..]).
  exists Φ. split; unfold Φ.
  { eapply subst_bound; eauto.
    intros [|[|[]]] ?; cbn; try lia. all: solve_bounds. }
  split.
  { constructor. now apply delta1_subst. }
  repeat split.
  all: intros x; specialize (H x).
  all: eapply AllE with (t := num 0) in H; cbn -[Q] in H.
  all: apply prv_split in H; destruct H as [H1 H2].
  - intros px%Hf. symmetry in px.
    eapply num_eq with (Gamma := Q)(p := intu) in px; [|firstorder].
    eapply IE. cbn -[Q num]. rewrite up_switch.
    apply H2. now rewrite num_subst.
  - intros npx. assert (0 <> f x) as E by firstorder.
    apply num_neq with (Gamma := Q)(p := intu) in E; [|firstorder].
    apply II. eapply IE.
    {eapply Weak; [apply E|now right]. }
    eapply IE; [|apply Ctx; now left].
    rewrite num_subst in H1. eapply Weak.
    + cbn -[Q num]. rewrite up_switch. apply H1.
    + now right.
Qed.

(** ** Weak part of the representability theorem.  *)
Lemma CT_RTw :
  CT_Q -> RT_weak.
Proof.
  intros ct p [f Hf]%enumerable_nat.
  destruct (ct f) as [ϕ [b2 [[s1] H]]].
  pose (Φ := ϕ[up (σ $1)..] ).
  exists Φ; split. 2: split.
  - unfold Φ. eapply subst_bound; eauto.
    intros [|[|[]]] ?; try lia; repeat solve_bounds.
  - constructor. now apply delta1_subst.
  - intros x. rewrite Hf. split.
    + intros [n Hn]. symmetry in Hn.
      apply sigma1_ternary_complete.
      { unfold Φ. eapply subst_bound; eauto.
      intros [|[|[]]] ?; try lia; repeat solve_bounds. }
      {unfold Φ. now apply delta1_subst. }
      exists n. specialize (H n).
      apply soundness in H.
      unshelve refine (let H := (H nat (extensional_model interp_nat) (fun _ => 0)) _ in _ ).
      {apply Q_std_axioms. }
      cbn in H. specialize (H (S x)) as [_ H2].
      rewrite eval_num, inu_nat_id in *.
      apply H2 in Hn. destruct Hn as [d Hd].
      exists d.
      unfold Φ. rewrite !sat_comp in *.
      eapply bound_ext with (N:=3).
      apply b2. 2: apply Hd.
      intros [|[|[]]]; cbn; rewrite ?num_subst, ?eval_num, ?inu_nat_id in *.
      all: try lia.
    + intros HQ%soundness. specialize (HQ nat (extensional_model interp_nat) (fun _ => 0)). cbn in HQ.
      destruct HQ as [n [d Hnd]].
      {apply Q_std_axioms. }
      exists n. specialize (H n).
      apply soundness in H.
      unshelve refine (let H := (H nat (extensional_model interp_nat) (fun _ => 0)) _ in _ ).
      apply Q_std_axioms.
      cbn in H. specialize (H (S x)) as [H1 _].
      rewrite eval_num, inu_nat_id in *.
      symmetry. apply H1. exists d.
      rewrite !sat_comp in Hnd.
      unfold Φ in Hnd. rewrite sat_comp in *.
      eapply bound_ext.
      apply b2. 2: apply Hnd.
      intros [|[|[]]]; cbn; rewrite ?num_subst, ?eval_num, ?inu_nat_id in *.
      all: try lia; reflexivity.
Qed.

Lemma WCT_WRTw :
  WCT_Q -> WRT_weak.
Proof.
  intros wct p [f Hf]%enumerable_nat.
  apply (DN_chaining (wct f)), DN.
  intros [ϕ [b2 [[s1] H]]].
  pose (Φ := ϕ[up (σ $1)..] ).
  exists Φ; split. 2: split.
  - unfold Φ. eapply subst_bound; eauto.
    intros [|[|[]]] ?; try lia; repeat solve_bounds.
  - constructor. now apply delta1_subst.
  - intros x. rewrite Hf. split.
    + intros [n Hn]. symmetry in Hn.
      apply sigma1_ternary_complete.
      { unfold Φ. eapply subst_bound; eauto.
        intros [|[|[]]] ?; try lia; repeat solve_bounds. }
      {unfold Φ. now apply delta1_subst. }
      exists n. specialize (H n).
      apply soundness in H.
      unshelve refine (let H := (H nat (extensional_model interp_nat) (fun _ => 0)) _ in _ ).
      {apply Q_std_axioms. }
      cbn in H. specialize (H (S x)) as [_ H2].
      rewrite eval_num, inu_nat_id in *.
      apply H2 in Hn. destruct Hn as [d Hd].
      exists d.
      unfold Φ. rewrite !sat_comp in *.
      eapply bound_ext with (N:=3).
      apply b2. 2: apply Hd.
      intros [|[|[]]]; cbn; rewrite ?num_subst, ?eval_num, ?inu_nat_id in *.
      all: try lia; reflexivity.
    + intros HQ%soundness. specialize (HQ nat (extensional_model interp_nat) (fun _ => 0)). cbn in HQ.
      destruct HQ as [n [d Hnd]].
      {apply Q_std_axioms. }
      exists n. specialize (H n).
      apply soundness in H.
      unshelve refine (let H := (H nat (extensional_model interp_nat) (fun _ => 0)) _ in _ ).
      apply Q_std_axioms.
      cbn in H. specialize (H (S x)) as [H1 _].
      rewrite eval_num, inu_nat_id in *.
      symmetry. apply H1. exists d.
      rewrite !sat_comp in Hnd.
      unfold Φ in Hnd. rewrite sat_comp in *.
      eapply bound_ext.
      apply b2. 2: apply Hnd.
      intros [|[|[]]]; cbn; rewrite ?num_subst, ?eval_num, ?inu_nat_id in *.
      all: try lia; reflexivity.
Qed.

End ChurchThesis.


Require Import Verdi.Verdi.
Require Import Verdi.NameOverlay.
Require Import StructTact.Fin.

Module Type Adjacency (Import NT : NameType)
 (NOT : NameOrderedType NT) (NSet : MSetInterface.S with Module E := NOT)
 (Import ANT : AdjacentNameType NT).

  Definition NS := NSet.t.

  Definition adjacency (n : name) (ns : list name) : NS :=
    fold_right (fun n' fs => NSet.add n' fs) NSet.empty (filter_rel adjacent_to_dec n ns).

  Parameter adjacent_to_node_adjacency :
  forall n n' ns, In n' (filter_rel adjacent_to_dec n ns) <-> NSet.In n' (adjacency n ns).

  Parameter not_adjacent_self : forall n ns, ~ NSet.In n (adjacency n ns).

  Parameter adjacency_mutual_in :
    forall n n' ns, In n' ns -> NSet.In n (adjacency n' ns) -> NSet.In n' (adjacency n ns).

  Parameter adjacency_mutual :
    forall n n', NSet.In n (adjacency n' nodes) -> NSet.In n' (adjacency n nodes).
End Adjacency.

Module NameTypeAdjacency (Import NT : NameType)
 (NOT : NameOrderedType NT) (NSet : MSetInterface.S with Module E := NOT)
 (Import ANT : AdjacentNameType NT) <: Adjacency NT NOT NSet ANT.

  Definition NS := NSet.t.

  Definition adjacency (n : name) (ns : list name) : NS :=
    fold_right (fun n' fs => NSet.add n' fs) NSet.empty (filter_rel adjacent_to_dec n ns).

  Require Import mathcomp.ssreflect.ssreflect.

  Lemma adjacent_to_node_adjacency :
    forall n n' ns, In n' (filter_rel adjacent_to_dec n ns) <-> NSet.In n' (adjacency n ns).
  Proof.
    move => n n' ns.
    split.
    elim: ns => //=.
    move => n0 ns IH.
    rewrite /adjacency /=.
    case adjacent_to_dec => //= H_dec H_in.
    case: H_in => H_in.
    rewrite H_in.
    apply NSet.add_spec.
      by left.
      apply NSet.add_spec.
      right.
      exact: IH.
      elim: ns => //=; first by rewrite /adjacency /=; exact: NSet.empty_spec.
      move => n0 ns IH.
      rewrite /adjacency /=.
      case adjacent_to_dec =>  //= H_dec H_ins.
      apply NSet.add_spec in H_ins.
      case: H_ins => H_ins; first by left.
      right.
      exact: IH.
  Qed.

  Lemma not_adjacent_self :
    forall n ns, ~ NSet.In n (adjacency n ns).
  Proof.
    move => n ns H_ins.
    apply adjacent_to_node_adjacency in H_ins.
    apply filter_rel_related in H_ins.
    move: H_ins => [H_in H_adj].
    contradict H_adj.
    exact: adjacent_to_irreflexive.
  Qed.

  Lemma adjacency_mutual_in :
    forall n n' ns,
      In n' ns ->
      NSet.In n (adjacency n' ns) ->
      NSet.In n' (adjacency n ns).
  Proof.
    move => n n' ns H_in H_ins.
    apply adjacent_to_node_adjacency.
    apply adjacent_to_node_adjacency in H_ins.
    apply filter_rel_related in H_ins.
    move: H_ins => [H_in' H_adj].
    apply adjacent_to_symmetric in H_adj.
    exact: related_filter_rel.
  Qed.

  Lemma adjacency_mutual :
    forall (n n' : name),
      NSet.In n (adjacency n' nodes) ->
      NSet.In n' (adjacency n nodes).
  Proof.
    move => n n' H_ins.
    have H_in: In n' nodes by exact: all_names_nodes.
    exact: adjacency_mutual_in.
  Qed.
End NameTypeAdjacency.

Module FinAdjacency (N : NatValue) (FNT : FinNameType N)
 (NOT : NameOrderedType FNT) (NSet : MSetInterface.S with Module E := NOT)
 (ANT : AdjacentNameType FNT) <: Adjacency FNT NOT NSet ANT :=
NameTypeAdjacency FNT NOT NSet ANT.