(* Unit-free MLL following Yalla schemas *)
(* Basic results on proof nets *)

From Coq Require Import Bool Wellfounded.
From OLlibs Require Import dectype Permutation_Type_more.
Set Warnings "-notation-overridden". (* to ignore warnings due to the import of ssreflect *)
From mathcomp Require Import all_ssreflect zify.
Set Warnings "notation-overridden".
From GraphTheory Require Import preliminaries mgraph setoid_bigop structures bij.
From HB Require Import structures.

From Yalla Require Export mll_prelim graph_more graph_uconnected_nb mgraph_dag mll_def.

Import EqNotations.

Set Mangle Names.
Set Mangle Names Light.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

Section Atoms.

(** A set of atoms for building formulas *)
Context { atom : DecType }.
(* TODO meilleur moyen de récupérer les notations *)
Notation formula := (@formula atom).
Notation sequent := (@sequent atom).
Notation base_graph := (graph (flat rule) (flat (formula * bool))).
Notation graph_data := (@graph_data atom).
Notation proof_structure := (@proof_structure atom).
Notation proof_net := (@proof_net atom).
Notation switching := (@switching atom).
Notation switching_left := (@switching_left atom).

(** No selfloop in a proof_structure *)
Lemma no_selfloop (G : proof_structure) (e : edge G) : source e <> target e.
Proof.
  intro H.
  assert (W := walk_edge e). rewrite H in W.
  now assert (F := ps_acyclic W).
Qed.

(** * Properties on switching & switching_left *)
Lemma switching_eq (G : base_graph) (a b : edge G) :
  switching a = switching b -> target a = target b.
Proof.
  unfold switching => /eqP; cbn => /eqP.
  case: ifP; case: ifP; by move => // _ _ /eqP; cbn => /eqP ->.
Qed.

Lemma switching_None (G : base_graph) (p : @upath _ _ G) :
  None \notin [seq switching e.1 | e <- p].
Proof. by induction p. Qed.

Lemma switching_left_sinj {G : base_graph} :
  {in ~: (@switching_left G) @^-1 None &, injective switching_left}.
Proof.
  move => a b; rewrite !in_set => A B /eqP; revert A B.
  unfold switching_left; case_if.
Qed.

Lemma swithching_to_left_eq {G : proof_structure} (a b : edge G) :
  switching_left a <> None -> switching_left b <> None ->
  switching a = switching b -> switching_left a = switching_left b.
Proof.
  move => A B S.
  assert (T := switching_eq S).
  apply /eqP; revert S A B => /eqP.
  rewrite /switching/switching_left T; cbn.
  case_if; apply /eqP.
  assert (Bl : vlabel (target b) = ⅋) by by apply /eqP.
  transitivity (left_parr Bl); [ | symmetry];
  by apply left_eq.
Qed.

Lemma supath_switching_from_leftK {G : proof_structure} (u v : G) p :
  supath switching_left u v p ->
  supath switching u v p.
Proof.
  move => /andP[/andP[? U] N].
  splitb; last by apply switching_None.
  destruct p as [ | e p]; trivial.
  apply /(uniqP (Some (inl (e.1)))) => a f A F.
  revert U => /(uniqP (Some e.1)) /(_ a f).
  rewrite_all size_map; rewrite !(nth_map e) // => /(_ A F) U Heq.
  apply U, swithching_to_left_eq; trivial.
  - intro Hc.
    contradict N; apply /negP/negPn/mapP.
    exists (nth e (e :: p) a); try by [].
    by apply mem_nth.
  - intro Hc.
    contradict N; apply /negP/negPn/mapP.
    exists (nth e (e :: p) f); try by [].
    by apply mem_nth.
Qed.

Definition supath_switching_from_left {G : proof_structure} (s t : G) (p : Supath switching_left s t) :=
  {| upval := _ ; upvalK := supath_switching_from_leftK (upvalK p) |}.

Lemma uacyclic_swithching_left {G : proof_structure} :
  uacyclic (@switching G) -> uacyclic (@switching_left G).
Proof.
  move => A u P.
  specialize (A _ (supath_switching_from_left P)).
  cbnb. by revert A => /eqP; cbn => /eqP.
Qed.

Lemma switching_left_edges_None (G : base_graph) :
  (@switching_left G) @^-1 None = [set e | (vlabel (target e) == ⅋) && (~~llabel e)].
Proof.
  apply /setP => e.
  rewrite !in_set; symmetry.
  destruct (switching_left e \in pred1 None) eqn:E.
  all: revert E => /eqP.
  all: unfold switching_left; case_if.
Qed.

Lemma switching_left_edges_None_nb (G : proof_structure) :
  #|[set e : edge G | (vlabel (target e) == ⅋) && (~~llabel e)]| = #|[set v : G | vlabel v == ⅋]|.
Proof.
  rewrite -!card_set_subset.
  assert (Hf : forall E : [finType of {e : edge G | (vlabel (target e) == ⅋) && (~~llabel e)}],
    (vlabel (target (val E)) == ⅋)).
  { by intros [e E]; cbn; revert E => /andP[E _]. }
  set f : [finType of {e : edge G | (vlabel (target e) == ⅋) && (~~llabel e)}] ->
    [finType of {v | vlabel v == ⅋}] :=
    fun e => Sub (target (val e)) (Hf e).
  assert (Hg : forall E : [finType of {v : G | vlabel v == ⅋}],
    (vlabel (target (right_parr (eqP (valP E)))) == ⅋) && (~~llabel (right_parr (eqP (valP E))))).
  { intros [e E]; splitb.
    - by rewrite right_e.
    - apply right_l. }
  set g : [finType of {v | vlabel v == ⅋}] ->
    [finType of {e : edge G | (vlabel (target e) == ⅋) && (~~llabel e)}] :=
    fun V => Sub (right_parr (eqP (valP V))) (Hg V).
  apply (bij_card_eq (f := f)), (Bijective (g := g)).
  - move => [e E].
    rewrite /f/g; cbnb.
    symmetry; apply right_eq; simpl.
    by revert E => /andP[_ /negP-?].
  - move => [v V].
    rewrite /f/g; cbnb.
    apply right_e.
Qed.

Lemma switching_left_edges_nb (G : proof_structure) :
  #|[set v : G | vlabel v == ⅋]| + #|~: (@switching_left G) @^-1 None| = #|edge G|.
Proof. by rewrite -switching_left_edges_None_nb -switching_left_edges_None cardsC. Qed.

Lemma switching_left_uconnected_nb {G : proof_structure} :
  uacyclic (@switching G) ->
  uconnected_nb (@switching_left G) + #|edge G| = #|G| + #|[set v : G | vlabel v == ⅋]|.
Proof.
  move => *.
  rewrite -switching_left_edges_nb.
  transitivity (uconnected_nb (@switching_left G) +
    #|~: (@switching_left G) @^-1 None| + #|[set v : G | vlabel v == ⅋]|); [lia | ].
  rewrite uacyclic_uconnected_nb //.
  - apply switching_left_sinj.
  - by apply uacyclic_swithching_left.
Qed.

Lemma correct_from_weak (G : base_graph) :
  #|G| <> 0 -> correct_weak G -> correct G.
Proof. intros ? [? ?]. split; trivial. by apply uconnected_to_nb1. Qed.

Lemma correct_to_weak (G : base_graph) :
  correct G -> correct_weak G.
Proof. intros [? ?]. split; trivial. by apply uconnected_from_nb1. Qed.

Lemma correct_not_empty (G : base_graph) :
  correct G -> #|G| <> 0.
Proof. intros [_ C]. by apply (nb1_not_empty C). Qed.

Lemma exists_node (G : proof_net) : {v : G & vlabel v <> c}.
Proof.
  assert (N := correct_not_empty (p_correct G)).
  revert N => /eqP. rewrite -cardsT cards_eq0 => /set0Pn/sigW[v _].
  destruct (vlabel v) eqn:V;
  try by (exists v; rewrite V).
  exists (source (edge_of_concl V)).
  intros U.
  assert (F : source (edge_of_concl V) = source (edge_of_concl V)) by trivial.
  contradict F. by apply no_source_c.
Qed.

Lemma supath_from_induced_switching (G : base_graph) (S : {set G}) s t (p : Supath (@switching (induced S)) s t) :
  supath (@switching G) (val s) (val t) [seq (val a.1, a.2) | a <- upval p].
Proof.
  apply supath_from_induced.
  - intros ? ? _. case_if.
  - move => ? ? ? ? /eqP-F. apply /eqP. revert F. unfold switching. case_if.
Qed.

Lemma uacyclic_induced (G : base_graph) (S : {set G}) :
  uacyclic (@switching G) -> uacyclic (@switching (induced S)).
Proof.
  intros U ? p.
  specialize (U _ {| upvalK := supath_from_induced_switching p |}).
  destruct p as [p ?]. cbnb. by destruct p.
Qed.

Lemma supath_from_induced_switching_left (G : base_graph) (S : {set G}) s t
  (p : Supath (@switching_left (induced S)) s t) :
  supath (@switching_left G) (val s) (val t) [seq (val a.1, a.2) | a <- upval p].
Proof.
  apply supath_from_induced.
  - move => ? ?. unfold switching_left. case_if.
  - move => ? ? ? ? /eqP. unfold switching_left. case_if; cbnb.
Qed.

Lemma switching_left_induced_None_to (G : base_graph) (S : {set G}) e (E : e \in edge_set S) :
  None <> @switching_left G e -> None <> @switching_left (induced S) (Sub e E).
Proof. unfold switching_left. case_if. Qed.

Lemma switching_left_induced_eq_to (G : base_graph) (S : {set G}) e a (E : e \in edge_set S)
  (A : a \in edge_set S) :
  @switching_left (induced S) (Sub e E) = @switching_left (induced S) (Sub a A) ->
  switching_left e = switching_left a.
Proof. move => /eqP. unfold switching_left. case_if; simpl in *; by subst. Qed.

(** * Isomorphism for each strata *)
(** Correction is preserved by isomorphism on base graphs *)
Definition switching_map (F G : base_graph) (h : F ≃ G) :=
  fun e => match e with
  | Some (inl a) => Some (inl (h.e a))
  | Some (inr a) => Some (inr (h a))
  | None => None
 end.

Lemma iso_switching (F G : base_graph) (h : F ≃ G) e :
  switching (h.e e) = switching_map h (switching e).
Proof.
  cbnb. rewrite !endpoint_iso iso_noflip vlabel_iso; cbn.
  by destruct (vlabel (target e)) eqn:Hl; rewrite Hl; case_if.
Qed.

Lemma iso_switching_left (F G : base_graph) (h : F ≃ G) e :
  switching_left (h.e e) = option_map h.e (switching_left e).
Proof.
  rewrite /switching_left/switching_left endpoint_iso iso_noflip vlabel_iso llabel_iso.
  case_if.
Qed.

Lemma iso_path_switchingK (F G : base_graph) (h : F ≃ G) p s t :
  supath switching s t p -> supath switching (h s) (h t) (iso_path h p).
Proof.
  move => /andP[/andP[W U] N]. splitb.
  - apply iso_walk; trivial. apply iso_noflip.
  - rewrite -map_comp /comp; cbn.
    assert (map _ p = [seq switching_map h (switching x.1) | x <- p]) as ->
      by (apply eq_map; move => *; by rewrite iso_switching).
    rewrite /switching map_comp map_inj_uniq // in U.
    rewrite (map_comp (fun e => match e with | inl _1 => _ | inr _1 => _ end) _ _) map_inj_uniq //.
    move => [a | a] [b | b] /eqP; cbn => // /eqP-Eq; cbnb.
    all: by revert Eq; apply bij_injective.
  - apply switching_None.
Qed.

Definition iso_path_switching (F G : base_graph) (h : F ≃ G) (s t : F) :
  Supath switching s t -> Supath switching (h s) (h t) :=
  fun p => {| upval := _ ; upvalK := iso_path_switchingK h (upvalK p) |}.

Lemma iso_path_switching_inj (F G : base_graph) (h : F ≃ G) s t :
  injective (@iso_path_switching _ _ h s t).
Proof.
  move => [p P] [q Q] /eqP; cbn => /eqP Heq; cbnb.
  revert Heq; apply inj_map => [[e b] [f c]] /eqP; cbn => /andP[/eqP Heq /eqP ->].
  apply /eqP; splitb; cbn; apply /eqP.
  by revert Heq; apply bij_injective.
Qed.

Lemma iso_path_nil (F G : base_graph) (h : F ≃ G) (s : F) :
  iso_path_switching h (supath_nil switching s) = supath_nil switching (h s).
Proof. by apply /eqP. Qed.

Lemma iso_path_switching_leftK (F G : base_graph) (h : F ≃ G) p s t :
  supath switching_left s t p -> supath switching_left (h s) (h t) (iso_path h p).
Proof.
  move => /andP[/andP[W U] N].
  splitb.
  - apply iso_walk; trivial. apply iso_noflip.
  - rewrite -map_comp /comp; cbn.
    enough ([seq switching_left (h.e x.1) | x <- p] = [seq Some (h.e x.1) | x <- p] /\
      [seq switching_left e.1 | e <- p] = [seq Some x.1 | x <- p]) as [Hr' Hr].
    { rewrite Hr map_comp map_inj_uniq // in U.
      by rewrite Hr' map_comp map_inj_uniq // map_comp map_inj_uniq. }
    split; apply eq_in_map; intros (e, b) E.
    all: rewrite ?iso_switching_left /switching_left.
    all: case_if.
    all: contradict N; apply /negP/negPn.
    all: enough (Hn : None = switching_left (e, b).1) by
      (rewrite Hn; by apply (map_f (fun a => switching_left a.1))).
    all: rewrite /switching_left /=.
    all: by replace (vlabel (target e) == ⅋) with true; replace (~~llabel e) with true.
  - rewrite -map_comp /comp; cbn.
    apply /(nthP None); move => [n Hc] Hf.
    rewrite size_map in Hc.
    enough (nth None [seq switching_left x.1 | x <- p] n = None).
    { contradict N; apply /negP/negPn/(nthP None). rewrite size_map. by exists n. }
    revert Hf.
    destruct p as [ | (e, b) p]; try by [].
    rewrite !(nth_map (e, b) None) // iso_switching_left.
    unfold switching_left; case_if.
Qed.

Definition iso_path_switching_left (F G : base_graph) (h : F ≃ G) (s t : F) :
  Supath switching_left s t -> Supath switching_left (h s) (h t) :=
  fun p => {| upval := _ ; upvalK := iso_path_switching_leftK h (upvalK p) |}.

Lemma iso_uacyclic (F G : base_graph) :
  F ≃ G -> uacyclic switching (G := G) -> uacyclic switching (G := F).
Proof.
  intros h A ? ?.
  apply (@iso_path_switching_inj _ _ h).
  rewrite iso_path_nil.
  apply A.
Qed.

Lemma iso_uconnected (F G : base_graph) :
  F ≃ G -> uconnected switching_left (G := G) -> uconnected switching_left (G := F).
Proof.
  intros h C u v. destruct (C (h u) (h v)) as [p _].
  set h' := iso_sym h.
  rewrite -(bijK' h' u) -(bijK' h' v).
  by exists (iso_path_switching_left h' p).
Qed.

(*
Lemma iso_uconnectednb (F G : base_graph) :
  F ≃ G -> uconnected_nb switching_left (G := G) = uconnected_nb switching_left (G := F).
Proof.
Abort. (* TODO if useful, but it is stronger than what we need *)*)

Lemma iso_correct_weak (F G : base_graph) : F ≃ G -> correct_weak G -> correct_weak F.
Proof.
  intros h [? ?]; split.
  - by apply (iso_uacyclic h).
  - by apply (iso_uconnected h).
Qed.

Lemma iso_correct (F G : base_graph) : F ≃ G -> correct G -> correct F.
Proof.
  intros h C.
  apply correct_from_weak.
  - rewrite (card_iso h). by apply correct_not_empty.
  - by apply (iso_correct_weak h), correct_to_weak.
Qed.

(** * Isomorphism on graph data preserves being a proof structure *)

(* Equivalence relation *)
Definition iso_data_id (G : graph_data) : G ≃d G.
Proof. exists (iso_id (G:=G)). symmetry; apply map_id. Defined.

Definition iso_data_sym (F G : graph_data) : F ≃d G -> G ≃d F.
Proof.
  move => f.
  exists (iso_sym f).
  rewrite -(map_id (order F)) (order_iso f) -map_comp /=.
  apply eq_map => v /=.
  symmetry; apply bijK.
Defined.

Definition iso_data_comp (F G H : graph_data) : F ≃d G -> G ≃d H -> F ≃d H.
Proof.
  move => f g.
  exists (iso_comp f g).
  by rewrite (order_iso g) (order_iso f) -map_comp.
Defined.

Global Instance iso_data_Equivalence: CEquivalence (@iso_data atom).
Proof. constructor; [exact @iso_data_id | exact @iso_data_sym | exact @iso_data_comp]. Defined.

Lemma sequent_iso_data F G : F ≃d G -> sequent F = sequent G.
Proof.
  intros [h O].
  rewrite /sequent O -map_comp.
  apply eq_map => e /=.
  by rewrite flabel_iso.
Qed.

(* Properties making a graph a proof structure are transported *)
Lemma p_deg_iso (F G : base_graph) : F ≃ G -> proper_degree G -> proper_degree F.
Proof.
  intros h H b v.
  specialize (H b (h v)).
  rewrite ->vlabel_iso in H.
  rewrite -H edges_at_outin_iso ?card_imset //.
  apply iso_noflip.
Qed.

Lemma p_ax_cut_iso (F G : base_graph) : F ≃ G -> proper_ax_cut G -> proper_ax_cut F.
Proof.
  move => h H b v Hl.
  rewrite <-(vlabel_iso h v) in Hl.
  revert H => /(_ b _ Hl) [el [er H]].
  exists (h.e^-1 el), (h.e^-1 er).
  rewrite -(bijK h v) (@edges_at_outin_iso _ _ _ _ (iso_sym h)) ?(bij_imset_f (iso_sym h).e)
    ?(flabel_iso (iso_sym h)) //.
  apply iso_noflip.
Qed.

Lemma p_tens_parr_iso (F G : base_graph) : F ≃ G -> proper_tens_parr G -> proper_tens_parr F.
Proof.
  move => h H b /= v Hl.
  rewrite <-(vlabel_iso h v) in Hl.
  revert H => /(_ b _ Hl) [el [er [ec H]]].
  exists (h.e^-1 el), (h.e^-1 er), (h.e^-1 ec).
  rewrite -(bijK h v) !(@edges_at_outin_iso _ _ _ _ (iso_sym h)) ?(bij_imset_f (iso_sym h).e)
    ?(flabel_iso (iso_sym h)) ?(llabel_iso (iso_sym h)) //.
  all: apply iso_noflip.
Qed.

Lemma p_noleft_iso (F G : base_graph) : F ≃ G -> proper_noleft G -> proper_noleft F.
Proof.
  intros h H e Hl.
  assert (Hl' : vlabel (target (h.e e)) = ax \/ vlabel (target (h.e e)) = cut \/
    vlabel (target (h.e e)) = c) by by rewrite endpoint_iso iso_noflip vlabel_iso.
  specialize (H (h.e e) Hl').
  by rewrite llabel_iso in H.
Qed.

Lemma p_order_iso (F G : graph_data) : F ≃d G -> proper_order G -> proper_order F.
Proof.
  intros h [In U].
  split.
  - intro e.
    specialize (In (h.e e)). rewrite ->endpoint_iso, ->vlabel_iso, iso_noflip in In. simpl in In.
    symmetry; symmetry in In. apply (@iff_stepl _ _ _ In).
    by rewrite (order_iso h) mem_map.
  - by rewrite (order_iso h) map_inj_uniq in U.
Qed.

Lemma order_iso_weak (F G : proof_structure) (h : F ≃ G) e :
  e \in order F <-> h.e e \in order G.
Proof.
  destruct (p_order F) as [? _].
  destruct (p_order G) as [? _].
  transitivity (vlabel (target e) = c); [by symmetry | ].
  by replace (vlabel (target e)) with (vlabel (target (h.e e)))
    by by rewrite endpoint_iso iso_noflip vlabel_iso.
Qed.

Definition order_iso_perm (F G : proof_structure) (h : F ≃ G) :
  Permutation_Type (order G) [seq h.e e | e <- order F].
Proof.
  destruct (p_order F) as [_ ?], (p_order G) as [_ ?].
  by apply Permutation_Type_bij_uniq, order_iso_weak.
Defined.

Lemma sequent_iso_weak (F G : proof_structure) (h : F ≃ G) :
  sequent F = [seq flabel e | e <- [seq h.e e | e <- order F]].
Proof. rewrite /sequent -map_comp. apply eq_map => ? /=. by rewrite flabel_iso. Qed.

Definition sequent_iso_perm (F G : proof_structure) : F ≃ G ->
  Permutation_Type (sequent G) (sequent F).
Proof.
  intro h.
  rewrite (sequent_iso_weak h).
  exact (Permutation_Type_map_def _ (order_iso_perm h)).
Defined.

Lemma perm_of_sequent_iso_perm (F G : proof_structure) (h : F ≃ G) :
  perm_of (sequent_iso_perm h) (order G) = [seq h.e e | e <- order F].
Proof.
  by rewrite -(perm_of_consistent (order_iso_perm _)) perm_of_rew_r
    perm_of_Permutation_Type_map.
Qed.
(* TODO lemma iso_to_isod ici ? Necessite d'y mettre perm_graph aussi *)
(* TODO si besoin de proprietes comme left (h ) = h left, les mettre ici *)

(** * Some results about rule carninality rcard *)(*
Lemma rset_bij {F G : base_graph} (h : F ≃ G) :
  [set h v | v : F & vlabel v == c] = [set v | vlabel v == c].
Proof. apply setP => v. by rewrite -[in LHS](bijK' h v) bij_imset_f !in_set (vlabel_iso (iso_sym h)). Qed.

Lemma rset_bij_in {F G : base_graph} (h : F ≃ G)
  (v : sig_finType (pred_of_set (~: [set v : F | vlabel v == c]))) :
  h (val v) \in ~: [set v : G | vlabel v == c].
Proof. destruct v. by rewrite -(rset_bij h) bij_imsetC bij_imset_f. Qed.

Lemma rcard_iso (F G : base_graph) :
  F ≃ G -> r#|F| = r#|G|.
Proof.
  intro h.
  rewrite /rcard -card_sig -[in RHS]card_sig.
  set f : sig_finType (pred_of_set (~: [set v : F | vlabel v == c])) ->
    sig_finType (pred_of_set (~: [set v : G | vlabel v == c])) :=
    fun v => Sub (h (val v)) (rset_bij_in h v).
  set g : sig_finType (pred_of_set (~: [set v : G | vlabel v == c])) ->
    sig_finType (pred_of_set (~: [set v : F | vlabel v == c])) :=
    fun v => Sub (h^-1 (val v)) (rset_bij_in (iso_sym h) v).
  apply (bij_card_eq (f := f)), (Bijective (g := g)); unfold f, g.
  - intros [v V]. cbnb. apply bijK.
  - intros [v V]. cbnb. apply bijK'.
Qed.

Lemma union_rcard (F G : base_graph) : r#|F ⊎ G| = r#|F| + r#|G|.
Proof.
  rewrite /rcard.
  assert (~: [set v : F ⊎ G | vlabel v == c] = ~: [set v : F ⊎ G | match v with | inl v => vlabel v == c | inr _ => true end]
    :|: ~: [set v : F ⊎ G | match v with | inr v => vlabel v == c | inl _ => true end]) as ->.
  { apply /setP. by intros [? | ?]; rewrite !in_set ?orb_false_r. }
  rewrite cardsU.
  assert (~: [set v : F ⊎ G | match v with | inl v => vlabel v == c | inr _ => true end]
    :&: ~: [set v : F ⊎ G | match v with | inl _ => true | inr v => vlabel v == c end] = set0) as ->.
  { apply /setP. by intros [? | ?]; rewrite !in_set ?andb_false_r. }
  rewrite cards0.
  enough ((~: [set v : F ⊎ G | match v with | inl v => vlabel v == c | inr _ => true end] =
    inl @: ~: [set v : F | vlabel v == c]) /\
    ~: [set v : F ⊎ G | match v with | inr v => vlabel v == c | inl _ => true end] =
    inr @: ~: [set v : G | vlabel v == c]) as [-> ->].
  { rewrite !card_imset; try by (apply inl_inj || apply inr_inj). lia. }
  split; apply /setP; intros [v | v].
  all: rewrite ?mem_imset ?in_set //; try by (apply inl_inj || apply inr_inj).
  all: symmetry; simpl.
  all: apply /imsetP; by move => [? _ /eqP-Hf].
Qed.

Lemma add_edge_rcard (G : base_graph) u v A :
  r#|G ∔ [u, A, v]| = r#|G|.
Proof. trivial. Qed.

Lemma unit_graph_rset R :
  R <> c -> [set v : (unit_graph R : base_graph) | vlabel v == c] = set0.
Proof.
  intros. apply /setP => v.
  rewrite !in_set. destruct v; by apply /eqP.
Qed.

Lemma unit_graph_rcard R :
  R <> c -> r#|(unit_graph R : base_graph)| = 1.
Proof. intros. by rewrite /rcard cardsCs setCK unit_graph_rset // cards0 /= card_unit. Qed.

Lemma two_graph_rset R :
  R <> c -> [set v : (two_graph R c : base_graph) | vlabel v == c] = [set inr tt].
Proof.
  intros. apply /setP => v.
  rewrite !in_set /=. destruct v as [[] | []]; by apply /eqP.
Qed.

Lemma two_graph_rcard R :
  R <> c -> r#|(two_graph R c : base_graph)| = 1.
Proof. intros. by rewrite /rcard cardsCs setCK /= card_sum card_unit two_graph_rset // cards1. Qed.

Lemma rem_rcard (G : base_graph) (v : G) S :
  vlabel v = c -> r#|induced (S :\ v)| = r#|induced S|.
Proof.
  intro V.
  rewrite /rcard -card_sig -[in RHS]card_sig.
  assert (Hf : forall (u : sig_finType (pred_of_set (~: [set u : induced (S :\ v) | vlabel u == c]))),
    val (val u) \in S).
  { move => [[u I] /= _]. revert I. by rewrite in_set => /andP[_ I]. }
  assert (Hf' : forall (u : sig_finType (pred_of_set (~: [set u : induced (S :\ v) | vlabel u == c]))),
    Sub (val (val u)) (Hf u) \in ~: [set u : induced S | vlabel u == c]).
  { move => [[u I] U] /=.
    rewrite !in_set /=. by rewrite -in_set finset_of_pred_of_set !in_set /= in U. }
  set f : sig_finType (pred_of_set (~: [set u : induced (S :\ v) | vlabel u == c])) ->
    sig_finType (pred_of_set (~: [set u : induced S | vlabel u == c])) :=
    fun u => Sub (Sub (val (val u)) (Hf u)) (Hf' u).
  assert (Hg : forall (u : sig_finType (pred_of_set (~: [set u : induced S | vlabel u == c]))),
    val (val u) \in S :\ v).
  { move => [[u I] U] /=.
    rewrite !in_set /=. rewrite -in_set finset_of_pred_of_set !in_set /= in U.
    splitb. apply /eqP => ?; subst u. contradict V. by apply /eqP. }
  assert (Hg' : forall (u : sig_finType (pred_of_set (~: [set u : induced S | vlabel u == c]))),
    Sub (val (val u)) (Hg u) \in ~: [set u : induced (S :\ v) | vlabel u == c]).
  { move => [[u I] U] /=.
    rewrite !in_set /=. by rewrite -in_set finset_of_pred_of_set !in_set /= in U. }
  set g : sig_finType (pred_of_set (~: [set u : induced S | vlabel u == c])) ->
    sig_finType (pred_of_set (~: [set u : induced (S :\ v) | vlabel u == c])) :=
    fun u => Sub (Sub (val (val u)) (Hg u)) (Hg' u).
  apply (bij_card_eq (f := f)), (Bijective (g := g)); intros [[u I] U]; cbnb.
Qed.*)

(** * About strong paths *)(* TODO need its own file? *)
(* A switching path is strong if it does not start from a ⅋-vertex through
   one of its switch edges *)
(* More general definition on path for it to be more simply manipulated *)
Definition strong {G : base_graph} (p : @upath _ _ G) : bool :=
  match p with
  | [::] => true
  | e :: _ => (vlabel (usource e) != ⅋) || e.2
  end.
(* TODO or := head true [seq (vlabel (utarget e) != ⅋) || e.2 | e <- p]. ? *)

Lemma concat_strong {G : base_graph} (p q : @upath _ _ G) :
  strong p -> strong q -> strong (p ++ q).
Proof. by destruct p. Qed.

Lemma supath_prefixK {G : base_graph} (s t : G) (p q : upath) :
  supath switching s t (p ++ q) -> supath switching s (upath_target s p) p.
Proof. apply supath_subKK. Defined.

Definition supath_prefix {G : base_graph} (s t : G) (p q : upath) (H : supath switching s t (p ++ q)) :=
  {| upval := p ; upvalK := supath_prefixK H |}. (* TODO can be generalized *)

Lemma prefix_strong {G : base_graph} (p q : @upath _ _ G) :
  strong (p ++ q) -> strong p.
Proof. by destruct p. Qed.
(*
Definition strong {G : base_graph} {u v : G} (P : Supath switching u v) : bool :=
  match upval P with
  | [::] => true
  | e :: _ => (vlabel (usource e) != ⅋) || e.2
  end.

Lemma concat_strong {G : base_graph} {s i t : G} (P : Supath switching s i)
  (Q : Supath switching i t) (D : upath_disjoint switching P Q) :
  strong P -> strong Q -> strong (supath_cat D).
Proof. by destruct P as [[ | ? ?] ?], Q as [[ | ? ?] ?]. Qed.

Lemma prefix_strong {G : base_graph} {s t : G} (p q : upath) (H : supath switching s t (p ++ q)) :
  strong {| upvalK := H |} -> strong (supath_prefix H).
Proof. by destruct p. Qed.
*)

(** * Useful results for sequentialization *)
Lemma has_ax (G : proof_net) : { v : G & vlabel v = ax }.
Proof.
  enough (E : { v : G & vlabel v == ax }).
  { destruct E as [v V]. revert V => /eqP-V. by exists v. }
  apply /sigW.
  apply (well_founded_ind (R := @is_connected_strict_rev _ _ G)).
  { apply (@well_founded_dam_rev _ _ G). }
  2:{ apply exists_node. }
  intros v H.
  destruct (vlabel v) eqn:V.
  - exists v. by apply /eqP.
  - apply (H (source (left_tens V))).
    unfold is_connected_strict_rev, is_connected_strict.
    exists [:: left_tens V]. splitb; apply /eqP.
    apply left_e.
  - apply (H (source (left_parr V))).
    unfold is_connected_strict_rev, is_connected_strict.
    exists [:: left_parr V]. splitb; apply /eqP.
    apply left_e.
  - destruct (p_cut V) as [e [_ [E _]]].
    rewrite !in_set in E.
    apply (H (source e)).
    unfold is_connected_strict_rev, is_connected_strict.
    exists [:: e]. splitb.
  - apply (H (source (edge_of_concl V))).
    unfold is_connected_strict_rev, is_connected_strict.
    exists [:: edge_of_concl V]. splitb; apply /eqP.
    apply concl_e.
Qed.

Lemma card_edge_proof_net (G : proof_net) : #|edge G| >= 2.
Proof.
  destruct (has_ax G) as [v V].
  assert (C := pre_proper_ax V).
  assert (#|edges_at_out v| <= #|edge G|)
    by apply subset_leq_card, subset_predT.
  lia.
Qed.

Definition terminal (G : base_graph) (v : G) : bool :=
  match vlabel v with
  | c => false
  | _ => [forall e, (source e == v) ==> (vlabel (target e) == c)]
  end.

Lemma terminal_not_c (G : base_graph) (v : G) :
  vlabel v <> c ->
  terminal v = [forall e, (source e == v) ==> (vlabel (target e) == c)].
Proof. unfold terminal. by destruct (vlabel v). Qed.

Lemma not_terminal (G : base_graph) (v : G) :
  vlabel v <> c -> ~~ terminal v ->
  {e : edge G & source e = v /\ vlabel (target e) <> c}.
Proof.
  intros V T.
  enough (E : {e : edge G & (source e == v) && (vlabel (target e) != c)}).
  { destruct E as [e E]. revert E; introb. by exists e. }
  apply /sigW.
  rewrite terminal_not_c // in T.
  revert T => /forallPn[e]. rewrite negb_imply => /andP[/eqP-Se /eqP-E].
  exists e. splitb; by apply /eqP.
Qed.

Lemma terminal_source (G : proof_structure) (v : G) :
  terminal v -> forall e, source e = v -> vlabel (target e) = c.
Proof.
  intros T e E.
  rewrite terminal_not_c in T.
  2:{ intro F. contradict E. by apply no_source_c. }
  revert T => /forallP/(_ e) /implyP-T.
  by apply /eqP; apply T; apply /eqP.
Qed.

Lemma terminal_cut (G : proof_structure) (v : G) (H : vlabel v = cut) :
  terminal v.
Proof.
  rewrite /terminal H.
  apply /forallP => e. apply /implyP => /eqP-E.
  contradict E.
  by apply no_source_cut.
Qed.

Lemma terminal_tens_parr (G : proof_structure) (v : G) (H : vlabel v = ⊗ \/ vlabel v = ⅋) :
  terminal v = (vlabel (target (ccl H)) == c).
Proof.
  transitivity [forall e, (source e == v) ==> (vlabel (target e) == c)].
  { rewrite /terminal. by destruct H as [-> | ->]. }
  destruct (vlabel (target (ccl H)) == c) eqn:C.
  - apply /forallP => e. apply /implyP => /eqP-E.
    enough (e = ccl H) by by subst e.
    by apply ccl_eq.
  - apply /negP => /forallP/(_ (ccl H))/implyP-P.
    rewrite ccl_e in P.
    revert C => /eqP-C. contradict C. apply /eqP.
    by apply P.
Qed.

Lemma has_terminal (G : proof_net) : { v : G & terminal v }.
Proof.
  apply /sigW.
  apply (well_founded_induction (wf_inverse_image _ _ _
    (@projT1 _ (fun v => vlabel v <> c)) (@well_founded_dam _ _ G))).
  2:{ exact (exists_node G). }
  move => [v V] /= H.
  destruct (terminal v) eqn:T.
  { by exists v. }
  revert T => /negP/negP-T.
  elim: (not_terminal V T) => {T} [e [? E]]. subst v.
  apply (H (existT _ (target e) E)).
  rewrite /is_connected_strict /=.
  exists [:: e]. splitb.
Qed.

Lemma in_upath_of_path {Lv Le : Type} {G : graph Lv Le} (p : path) (e : edge G) (b : bool) :
  (e, b) \in upath_of_path p = (e \in p) && b.
Proof.
  destruct b; [destruct (e \in p) eqn:E | ]; rewrite /= ?andb_false_r; apply /mapP.
  - by exists e.
  - move => [a A AE]. inversion AE. subst a. by rewrite A in E.
  - by move => [? _ ?].
Qed.

Lemma walk_is_supath {G : proof_structure} {s t : G} {p : path} :
  walk s t p -> supath switching s t p.
Proof.
  revert s t. induction p as [ | p e IH] using last_ind => s t /=.
  { by rewrite supath_of_nil. }
  rewrite walk_rcons => /andP[W /eqP-?]. subst t.
  specialize (IH _ _ W).
  replace (upath_of_path (rcons p e)) with (rcons (upath_of_path p) (forward e)).
  2:{ clear. induction p as [ | ? ? IH]; trivial. by rewrite /= IH. }
  rewrite supath_rcons /= {}IH eq_refl /= andb_true_r.
  enough (Ain : forall a, a \in p -> target a <> target e).
  { clear W.
    apply /mapP. move => [[a b] A EA].
    revert A. rewrite in_upath_of_path => /andP[A B]. destruct b; try by []. clear B.
    specialize (Ain _ A). clear A.
    revert EA. move => /eqP. unfold switching. case_if.
    contradict Ain. by symmetry. }
  intros a A AE.
  apply in_elt_sub in A. destruct A as [n A].
  revert W.
  rewrite A.
  replace (take n p ++ a :: drop n.+1 p) with ((take n p ++ [:: a]) ++ drop n.+1 p)
    by by rewrite -catA cat_cons.
  intro W.
  apply walk_subK in W. destruct W as [_ W].
  revert W => /= /andP[_ W].
  rewrite AE in W.
  assert (W' : walk (source e) (source e) (e :: drop n.+1 p)) by splitb.
  by assert (F := @acy _ _ G _ _ W').
Qed.

Lemma descending_couple (G : proof_net) (s : G) :
  vlabel s <> c -> { '(t, p) : G * path & walk s t p & terminal t }.
Proof.
  intro S.
  apply (well_founded_induction_type (wf_inverse_image _ _ _
    (@projT1 _ (fun v => {p : path & walk s v p /\ vlabel v <> c})) (@well_founded_dam _ _ G))).
  2:{ exists s, [::]. by simpl. }
  move => [t [p [W C]]] H.
  destruct (terminal t) eqn:T.
  { now exists (t, p). }
  revert T => /negP/negP-T.
  elim: (not_terminal C T) => {T} [e [? E]]. subst t.
  assert (W' : walk s (target e) (rcons p e : path)).
  { rewrite walk_rcons. splitb. }
  apply (H ⟨ target e, ⟨ rcons p e, conj W' E ⟩ ⟩).
  exists [:: e]. splitb.
Qed.

(* Terminal node below the node s *)
Definition descending_node (G : proof_net) (s : G) (S : vlabel s <> c) :=
  let (tp, _, _) := descending_couple S in let (t, _) := tp in t.

Lemma descending_node_terminal (G : proof_net) (s : G) (S : vlabel s <> c) :
  terminal (descending_node S).
Proof. unfold descending_node. by destruct (descending_couple _) as [[? _] _ ?]. Qed.

Definition descending_path (G : proof_net) (s : G) (S : vlabel s <> c) :=
  let (tp, _, _) := descending_couple S in let (_, p) := tp in p.

Lemma descending_supath {G : proof_net} {s : G} (S : vlabel s <> c) :
  supath switching s (descending_node S) (descending_path S).
Proof.
  unfold descending_path, descending_node. destruct (descending_couple _) as [[? ?] ? _].
  by apply walk_is_supath.
Qed.

(* A descending path is a strong path *)
Lemma descending_path_strong {G : proof_net} {s : G} (S : vlabel s <> c) :
  strong {| upvalK := descending_supath S |}.
Proof. unfold strong. simpl. destruct (descending_path S); caseb. Qed.

Lemma descending_path_nil (G : proof_net) (s : G) (S : vlabel s <> c) :
  (descending_path S == [::]) = (descending_node S == s).
Proof.
  unfold descending_path, descending_node.
  destruct (descending_couple _) as [[t p] W _].
  destruct (eq_comparable t s) as [ | Hneq]; [subst t | ].
  - by rewrite (ps_acyclic W) !eq_refl.
  - transitivity false; last by symmetry; apply /eqP.
    destruct p; last by by [].
    contradict Hneq. by revert W => /= /eqP-->.
Qed.

Lemma descending_path_terminal (G : proof_net) (s : G) (S : vlabel s <> c) :
  terminal s = (descending_node S == s).
Proof.
  rewrite -descending_path_nil.
  unfold descending_path, descending_node.
  destruct (descending_couple _) as [[t p] W T].
  destruct p as [ | e p].
  { revert W => /= /eqP-?. by subst s. }
  destruct (terminal s) eqn:Ts; last by by [].
  revert W => /= /andP[/eqP-E W].
  assert (H := terminal_source Ts E).
  destruct p as [ | f p].
  - revert W => /= /eqP-?. subst t.
    contradict T. by rewrite /terminal H.
  - revert W => /= /andP[/eqP-F _].
    contradict F. by apply no_source_c.
Qed.

Lemma descending_node_ax (G : proof_net) (s : G) (S : vlabel s <> c) :
  vlabel (descending_node S) = ax -> terminal s.
Proof.
  intro V.
  rewrite descending_path_terminal -descending_path_nil.
  assert (W := descending_supath S). revert W => /andP[/andP[W _] _]. rewrite uwalk_walk in W.
  revert W. set p := descending_path S. case/lastP: p => [ | p e] //.
  rewrite walk_rcons => /andP[_ /eqP-TS].
  contradict TS. by apply no_target_ax.
Qed.

Lemma descending_not_ax (G : proof_net) (s : G) (S : vlabel s <> c) :
  vlabel s <> ax -> vlabel (descending_node S) <> ax.
Proof.
  intros S' F. contradict S'.
  assert (H := descending_node_ax F).
  revert H. by rewrite descending_path_terminal => /eqP-<-.
Qed.

Lemma terminal_only_ax (G : proof_net) :
  (forall (v : G), vlabel v = ax \/ vlabel v = c) ->
  { t : G & terminal t /\ vlabel t = ax}.
Proof.
Abort. (* TODO if needed *)

(** * About axiom expansion *)
Lemma ax_formula_pos (G : proof_structure) (v : G) (V : vlabel v = ax) :
  { x | ax_formula V = var x } + { '(A, B) | ax_formula V = A ⊗ B }.
Proof.
  destruct (ax_formula V) as [x | x | A B | A B] eqn:Hv.
  - left. by exists x.
  - contradict Hv.
    unfold ax_formula, ax_formula_edge.
    destruct (p_ax_type V) as [[e e'] [? [? ?]]]. simpl.
    destruct (flabel e) eqn:E, (flabel e') eqn:E'; by rewrite // ?E ?E'.
  - right. by exists (A, B).
  - contradict Hv.
    unfold ax_formula, ax_formula_edge.
    destruct (p_ax_type V) as [[e e'] [? [? ?]]]. simpl.
    destruct (flabel e) eqn:E, (flabel e') eqn:E'; by rewrite // ?E ?E'.
Qed.

Lemma ax_cut_formula_edge_in (G : proof_structure) (b : bool) (v : G)
  (V : vlabel v = if b then cut else ax) :
  endpoint b (ax_cut_formula_edge V) = v.
Proof.
  unfold ax_cut_formula_edge.
  destruct (p_ax_cut_type V) as [[e e'] [? [? ?]]]. simpl.
  by destruct (flabel e).
Qed.

Lemma ax_cut_formula_endpoint (G : proof_structure) (b : bool) (v : G)
  (V : vlabel v = if b then cut else ax) :
  vlabel (endpoint b (ax_cut_formula_edge V)) = if b then cut else ax.
Proof. rewrite -V. f_equal. apply ax_cut_formula_edge_in. Qed.

(* About upath_disjoint2 *)
(* TODO un fichier strong et upath_disjoint2 ? *)
Lemma strong_upath_disjoint_switching {G : proof_net} {s i t : G} (P : Supath switching s i)
  (Q : Supath switching i t) :
  (t \notin [seq usource e | e <- (upval P)]) || (vlabel t != ⅋) ->
  strong P -> strong Q -> upath_disjoint2 P Q -> forall a b, a \in upval P -> b \in upval Q ->
  switching a.1 <> switching b.1.
Proof.
(* The first hypothesis is really needed, unless we replace edge-disjoint (upath_disjoint2) by
vertex-disjoint. *)
(* Proof sketch :
Otherwise, we take a the last edge of P and b the first of Q with the same image by switching,
with P' and Q' respectively P from a to its end, and Q from its start to b.
Then P' Q' is a switching cycle, non empty as P and Q are strong. *)
  move => T SP SQ D [a ab] [e eb] Ain Ein /= AE.
  destruct P as [p P], Q as [q Q]. simpl in *.
  assert (Ra : (fun f => [exists f', (f'\in q) && (switching f.1 == switching f'.1)]) (a, ab)).
  { apply /existsP. exists (e, eb). by rewrite Ein /= AE !eq_refl. }
  destruct (in_elt_sub_last Ra Ain) as [k [[ke keb] [PK [Ke Kl']]]]. clear Ra a ab e eb Ain Ein AE.
  revert Ke => /existsP[ke' /andP[Ke Tke]].
  assert (Rb : (fun f => switching ke == switching f.1) ke') by assumption.
  destruct (in_elt_sub_fst Rb Ke) as [n [[ne neb] [QN [Ne Nf]]]]. clear ke' Rb Ke Tke.
  revert Ne => /= /eqP-Ne.
  set p' := (if keb then [::] else [:: backward ke]) ++ drop k.+1 p.
  set q' := take n q ++ (if neb then [:: forward ne] else [::]).
  assert (KN : ke <> ne).
  { intros ?. subst ne.
    revert D. unfold upath_disjoint2 => /disjointP/(_ ke)-D. apply D.
    - change ke with (ke, keb).1. apply map_f.
      rewrite PK mem_cat in_cons. caseb.
    - change ke with (ke, neb).1. apply map_f.
      rewrite QN mem_cat in_cons. caseb. }
  assert (Teq := switching_eq Ne).
  revert Ne. unfold switching. rewrite -Teq. case:ifP => /eqP-Vtke; last by cbnb. move => _.
  assert (K_or_N : keb || ~~neb).
 (* idée : c'est le cas où les 2 utilisent les aretes entrantes du parr ; dq = ccl de parr, qui est aussi dans P car P est strong et sort par une arete de ce parr, contradict disjoint *)
  { destruct keb, neb; try by [].
    contradict T. apply /negP/norP. rewrite !negb_involutive.
    enough (t = usource (backward ke)) as ->.
    { split.
      - apply (@map_f _ _ (fun e => usource e)).
        rewrite PK mem_cat in_cons. caseb.
      - by rewrite /= Vtke. }
    simpl.
    destruct (drop n.+1 q) as [ | d dq] eqn:DQ; rewrite DQ in QN.
    { rewrite QN cats1 in Q.
      destruct (supath_endpoint {| upvalK := Q |}) as [_ <-].
      by rewrite /= map_rcons last_rcons -Teq. }
    assert (d = forward (ccl_parr Vtke)).
    { assert (QN' : q = take n q ++ [:: forward ne ; d] ++ dq) by by rewrite {1}QN.
      clear QN. rewrite {}QN' in Q. apply supath_subK in Q.
      revert Q. rewrite !supath_cons supath_of_nil /= in_cons in_nil !andb_true_r orb_false_r -Teq
        => /andP[/andP[/andP[_ /eqP-Sd] _]].
      rewrite /switching -Teq Vtke /= => S.
      destruct d as [d []]; simpl in Sd.
      - f_equal. by apply ccl_eq.
      - revert S. by rewrite /= Sd Vtke /= eq_refl. }
    subst d.
    destruct (take k p) as [ | tp d _] eqn:TP using last_ind; rewrite TP in PK.
    { contradict SP. apply /negP. by rewrite /strong PK /= Vtke. }
    rewrite cat_rcons in PK.
    assert (d = backward (ccl_parr Vtke)).
    { assert (PK' : p = tp ++ [:: d ; backward ke] ++ drop k.+1 p) by by rewrite {1}PK.
      clear PK. rewrite {}PK' in P. apply supath_subK in P.
      revert P. rewrite !supath_cons supath_of_nil /= in_cons in_nil !andb_true_r orb_false_r
        => /andP[/andP[/andP[_ /eqP-Sd] _]].
      rewrite /switching Vtke /= => S.
      destruct d as [d []]; simpl in Sd.
      - revert S. by rewrite /= -Sd Vtke /= eq_refl.
      - f_equal. by apply ccl_eq. }
    subst d.
    contradict D. unfold upath_disjoint2. apply /negP/disjointP => /(_ (ccl_parr Vtke))-D.
    apply D.
    * change (ccl_parr Vtke) with (backward (ccl_parr Vtke)).1.
      apply map_f. rewrite PK mem_cat !in_cons. caseb.
    * change (ccl_parr Vtke) with (forward (ccl_parr Vtke)).1.
      apply map_f. rewrite QN mem_cat !in_cons. caseb. }
  assert (Kl : forall z f', z \in p' -> f' \in q' -> switching z.1 <> switching f'.1).
  { intros z f Z F.
    revert F Z. rewrite /p' /q' !mem_cat => /orP-F /orP[Z | Z].
    - destruct keb; try by [].
      revert Z. rewrite in_cons in_nil orb_false_r => /eqP-?; subst z. simpl.
      destruct F as [F | F].
      + apply /eqP. by apply Nf.
      + by destruct neb.
    - revert Kl' => /(_ z Z)/existsPn/(_ f)/nandP[F' | /eqP-? //].
      contradict F'. apply /negP/negPn.
      rewrite QN mem_cat in_cons.
      destruct F as [-> | F]; first by [].
      destruct neb; last by [].
      revert F. rewrite in_cons in_nil orb_false_r => /eqP-?; subst f. caseb. }
  clear T SP D Kl'.
  assert (Nf' : forall z, z \in q' -> switching ke <> switching z.1 \/ z = forward ne).
  { intro z. rewrite /p' mem_cat => /orP[Z | Z]; [left | right].
    - apply /eqP. by apply Nf.
    - destruct neb; try by [].
      revert Z. by rewrite in_cons in_nil orb_false_r => /eqP-->. }
  clear Nf.
  assert (P' : supath switching (target ke) i p').
  { rewrite /p'. destruct keb; simpl.
    - assert (PK' : p = rcons (take k p) (forward ke) ++ drop k.+1 p ++ [::])
        by by rewrite cats0 cat_rcons.
      rewrite {}PK' in P. apply supath_subK in P. by rewrite /= map_rcons last_rcons in P.
    - assert (PK' : p = take k p ++ (backward ke :: drop k.+1 p) ++ [::]) by by rewrite cats0.
      rewrite {}PK' in P. apply supath_subK in P. simpl in P.
      destruct (supath_endpoint {| upvalK := P |}) as [Hr _]. simpl in Hr.
      by rewrite /= -{}Hr /= in P. }
  clear P PK.
  assert (Q' : supath switching i (target ke) q').
  { rewrite /q'. destruct neb.
    - rewrite cats1.
      assert (QN' : q = [::] ++ rcons (take n q) (forward ne) ++ drop n.+1 q)
        by by rewrite /= cat_rcons.
      rewrite {}QN' in Q. apply supath_subK in Q. simpl in Q.
      destruct (supath_endpoint {| upvalK := Q |}) as [_ Hr]. rewrite /= map_rcons last_rcons /= in Hr.
      by rewrite /= -{}Hr /= -Teq in Q.
    - rewrite cats0.
      assert (QN' : q = [::] ++ take n q ++ backward ne :: drop n.+1 q) by by [].
      rewrite {}QN' in Q. apply supath_subK in Q. by rewrite /= -Teq in Q. }
  clear Q.
  assert (PQ : p' ++ q' <> [::]).
  { rewrite /p' /q'. destruct keb, neb, (take n q) eqn:TQ, (drop k.+1 p) eqn:DP; try by [].
    rewrite TQ /= in QN.
    contradict SQ. apply /negP.
    by rewrite /strong QN /= -Teq Vtke. }
  clear SQ QN.
  revert P' Q'  Nf' Kl PQ. generalize p' q'. clear p' q' p q. intros p q P Q Nf Kl PQ.
  enough (D : upath_disjoint switching {| upvalK := P |} {| upvalK := Q |}). (* TODO define upath_disjoint on path instead of supath *)
  { destruct (p_correct G) as [Ac _].
    assert (F := Ac _ (supath_cat D)). contradict F.
    cbnb. }
  rewrite /upath_disjoint /=.
  apply /disjointP => f /mapP[x Xq ?] /mapP[y Yp]. subst f.
  by apply Kl.
Qed.

(* If two strong path are edge-disjoint, and the target of the second is not
a ⅋-vertex inside the first, then they are switching-disjoint, meaning
we can concatenate them to obtain a switching path. *)
Lemma strong_upath_disjoint2 {G : proof_net} {s i t : G} (P : Supath switching s i)
  (Q : Supath switching i t) :
  (t \notin [seq usource e | e <- (upval P)]) || (vlabel t != ⅋) ->
  strong P -> strong Q -> upath_disjoint2 P Q -> upath_disjoint switching P Q.
Proof.
  intros T SP SQ D.
  rewrite /upath_disjoint.
  apply /disjointP.
  move => E /mapP[a A AE] /mapP[b B BE]. subst E.
  contradict BE. by apply (strong_upath_disjoint_switching T SP SQ).
Qed.

Lemma strong_rev {G : base_graph} (p : @upath _ _ G) :
  strong (upath_rev p) = last true [seq (vlabel (utarget e) != ⅋) || ~~e.2 | e <- p].
Proof.
  case: (lastP p) => {p} [ // | p e].
  by rewrite upath_rev_rcons map_rcons last_rcons /= negb_involutive.
Qed.

End Atoms.

Notation ax_formula_edge_in := (@ax_cut_formula_edge_in _ _ false).
Notation cut_formula_edge_in := (@ax_cut_formula_edge_in _ _ true).
Notation ax_formula_endpoint := (@ax_cut_formula_endpoint _ _ false).
Notation cut_formula_endpoint := (@ax_cut_formula_endpoint _ _ true).


From solutions Require Export sem_typed.
From solutions Require Import symbol_ghost two_state_ghost.

Section unsafe.
  Context `{!heapG Σ}.

  (** Recall the following function we defined in the file [language.v]:
  <<
  Definition unsafe_pure : val := λ: <>,
    if: #true then #13 else #13 #37.
  >>
  *)
  Lemma sem_typed_unsafe_pure : ⊢ ∅ ⊨ unsafe_pure : (() → sem_ty_int).
  Proof.
    iIntros (vs) "!# HΓ /=". iApply wp_value.
    iIntros "!#" (? ->). wp_lam. wp_if.
    rewrite /sem_ty_car /=.
    by iExists 13.
  Qed.

  (** * Exercise (unsafe_ref, easy) *)
  (** Recall the following function we defined in the file [language.v]:
  <<
  Definition unsafe_ref : val := λ: <>,
    let: "l" := ref #0 in "l" <- #true;; !"l".
  >> *)
  Lemma sem_typed_unsafe_ref : ⊢ ∅ ⊨ unsafe_ref : (() → sem_ty_bool).
  Proof.
    iIntros (vs) "!# HΓ /=". iApply wp_value.
    iIntros "!#" (? ->). wp_lam.
    wp_alloc l as "Hl".
    wp_store. wp_load.
    rewrite /sem_ty_car /=.
    by iExists true.
  Qed.

  (** * Exercise (unsafe_ref_ne_0, moderate) *)
  Definition unsafe_ref_ne_0 : val := λ: <>,
    let: "l" := ref #1 in
    ((λ: "x", if: "x" ≠ #0 then "l" <- "x" else #()),
     (λ: <>, assert: !"l" ≠ #0)).

  Lemma sem_typed_unsafe_ref_ne_0 :
    ⊢ ∅ ⊨ unsafe_ref_ne_0 : (() → (sem_ty_int → ()) * (() → ())).
  Proof.
    iIntros (vs) "!# HΓ /=". iApply wp_value.
    iIntros "!#" (? ->).
    wp_lam. wp_alloc l as "Hl". wp_let.
    pose (I := (∃ n : Z, ⌜#n ≠ #0⌝ ∗ l ↦ #n)%I).
    iMod (inv_alloc (nroot .@ "inv") _ I with "[Hl]")%I as "#Hinv".
    { by iNext; iExists 1; iFrame. }
    wp_pures. iModIntro.
    iExists _, _. iSplit; first done.
    iSplit.
    - iIntros "!#" (? [n ->]).
      wp_lam.
      wp_op.
      destruct (decide (n = 0%Z)); simplify_eq/=.
      + wp_op.
        wp_if.
        done.
      + rewrite bool_decide_eq_false_2; last congruence.
        wp_op.
        wp_if.
        iInv (nroot .@ "inv") as (m) ">[% Hl]".
        wp_store.
        iModIntro. iSplit.
        * iExists n; auto with congruence.
        * done.
    - iIntros "!#" (? ->).
      wp_lam.
      wp_pures.
      iApply wp_assert.
      (* Need because of atomic expression *)
      wp_bind (! _)%E.
      iInv (nroot .@ "inv") as (m) ">[% Hl]".
      wp_load.
      iModIntro. iSplitL "Hl".
      { iExists m; auto. }
      wp_op.
      rewrite bool_decide_eq_false_2; last done.
      by wp_op.
  Qed.

  (** * Exercise (unsafe_ref_reuse, hard) *)
  Definition unsafe_ref_reuse : val :=
    λ: <>, let: "l" := ref #0 in λ: <>, "l" <- #true;; !"l".

  Lemma sem_typed_unsafe_ref_reuse `{!two_stateG Σ}:
    ⊢ ∅ ⊨ unsafe_ref_reuse : (() → (() → sem_ty_bool)).
  Proof.
    iIntros (vs) "!# HΓ /=". iApply wp_value.
    iIntros "!#" (? ->). wp_lam.
    wp_alloc l as "Hl".
    iMod two_state_init as (γ) "Ho".
    pose (I := (∃ b, two_state_auth γ b ∗ l ↦ (if b then #true else #0))%I).
    iMod (inv_alloc (nroot .@ "inv") _ I with "[Hl Ho]") as "#Hinv".
    { iNext. iExists false. iFrame. }
    wp_pures.
    iIntros "!> !>" (? ->).
    wp_lam.
    (* Need because of atomic expression *)
    wp_bind (_ <- _)%E.
    iInv (nroot .@ "inv") as (o) ">[Ho Hl]".
    wp_store.
    iMod (two_state_update with "Ho") as "[Ho Hf]".
    iModIntro. iSplitL "Hl Ho".
    { iNext. iExists true. iFrame. }
    wp_pures.
    iInv (nroot .@ "inv") as (o') ">[Ho Hl]".
    iDestruct (two_state_agree with "Ho Hf") as %->.
    wp_load.
    iModIntro. iSplitL "Hl Ho".
    { iNext. iExists true. iFrame. }
    rewrite /sem_ty_car /=. by iExists _.
  Qed.

  (** * Exercise (unsafe_symbol_adt, hard) *)
  (** Semantic typing of a symbol ADT (taken from Dreyer's POPL'18 talk) *)
  Definition symbol_adt_inc : val := λ: "x" <>, FAA "x" #1.
  Definition symbol_adt_check : val := λ: "x" "y", assert: "y" < !"x".
  Definition symbol_adt : val := λ: <>,
    let: "x" := Alloc #0 in
    pack: (symbol_adt_inc "x", symbol_adt_check "x").

  Definition symbol_adt_ty : sem_ty Σ :=
    (() → ∃ A, (() → A) * (A → ())).

  Section sem_typed_symbol_adt.
    Context `{!symbolG Σ}.

    Definition symbol_adtN := nroot .@ "symbol_adt".

    Definition symbol_inv (γ : gname) (l : loc) : iProp Σ :=
      (∃ n : nat, l ↦ #n ∗ counter γ n)%I.

    Definition sem_ty_symbol (γ : gname) : sem_ty Σ := SemTy (λ w,
      ∃ n : nat, ⌜w = #n⌝ ∧ symbol γ n)%I.

    Lemma sem_typed_symbol_adt Γ : ⊢ Γ ⊨ symbol_adt : symbol_adt_ty.
    Proof.
      iIntros (vs) "!# _ /=". iApply wp_value.
      iIntros "!#" (v ->). wp_lam. wp_alloc l as "Hl"; wp_pures.
      iMod (counter_alloc 0) as (γ) "Hc".
      iMod (inv_alloc symbol_adtN _ (symbol_inv γ l) with "[Hl Hc]") as "#?".
      { iExists 0%nat. by iFrame. }
      do 2 (wp_lam; wp_pures). wp_lam. iModIntro.
      iExists (sem_ty_symbol γ), _, _; repeat iSplit=> //.
      - repeat rewrite /sem_ty_car /=. iIntros "!#" (? ->). wp_pures.
        iInv symbol_adtN as (n) ">[Hl Hc]". wp_faa.
        iMod (counter_inc with "Hc") as "[Hc #Hs]".
        iModIntro; iSplitL; last eauto.
        iExists (S n). rewrite Nat2Z.inj_succ -Z.add_1_r. iFrame.
      - repeat rewrite /sem_ty_car /=. iIntros "!#" (v).
        iDestruct 1 as (n ->) "#Hs". wp_pures. iApply wp_assert.
        wp_bind (!_)%E. iInv symbol_adtN as (n') ">[Hl Hc]". wp_load.
        iDestruct (symbol_obs with "Hc Hs") as %?. iModIntro. iSplitL.
        { iExists n'. iFrame. }
        wp_op. rewrite bool_decide_true; last lia. eauto.
    Qed.
  End sem_typed_symbol_adt.
End unsafe.


Require Import ExtLib.Structures.Maps.
Require Import List.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Monads.

Set Implicit Arguments.
Set Strict Implicit.

Section keyed.
  Variable K : Type.
  Variable K_le : K -> K -> Prop.
  Variable RD_K : K -> K -> comparison.

  Inductive twothree (T : Type) : Type :=
  | Leaf
  | Two : twothree T -> K -> T -> twothree T -> twothree T
  | Three : twothree T -> K -> T -> twothree T -> K -> T -> twothree T -> twothree T.

  Arguments Leaf {T}.
  Arguments Two {T} _ _ _ _.
  Arguments Three {T} _ _ _ _ _ _ _.

  Section modify.
    Variable V : Type.
    Variable k : K.
    Variable upd : V -> option V.
    Variable def : option V.

    Fixpoint remove_greatest (m : twothree V) {T} (k_oops : unit -> T) (k_ok : K -> V -> twothree V -> T) : T :=
      match m with
        | Leaf => k_oops tt
        | Two l k v r =>
          remove_greatest r (fun _ => k_ok k v l) (fun k' v' r' => k_ok k' v' (Two l k v r'))
        | Three l k v m k' v' r =>
          remove_greatest r (fun _ => k_ok k' v' (Two l k v m)) (fun k'' v'' r'' => k_ok k'' v'' (Three l k v m k' v' r''))
      end.

    Fixpoint twothree_modify (m : twothree V) {T} (k_ok : twothree V -> T) (k_splice_up : twothree V -> K -> V -> twothree V -> T) {struct m} : T :=
      match m with
        | Leaf =>
          match def with
            | Some v => k_splice_up Leaf k v Leaf
            | None => k_ok Leaf
          end
        | Two l k' v' r =>
          match RD_K k k' with
            | Eq =>
              match upd v' with
                | Some v' => k_ok (Two l k v' r)
                | None => remove_greatest l (fun _ => k_ok r) (fun k v l => k_ok (Two l k v r))
              end
            | Lt =>
              twothree_modify l (fun l => k_ok (Two l k' v' r))
                                (fun l'' k'' v'' r'' => k_ok (Three l'' k'' v'' r'' k' v' r))
            | Gt =>
              twothree_modify r (fun r => k_ok (Two l k' v' r))
                                (fun l'' k'' v'' r'' => k_ok (Three l k' v' l'' k'' v'' r''))
          end
        | Three l k1 v1 m k2 v2 r =>
          match RD_K k k1 with
            | Eq =>
              match upd v1 with
                | Some v' => k_ok (Three l k v' m k2 v2 r)
                | None =>
                  remove_greatest l (fun _ => k_ok (Two m k2 v2 r)) (fun k1 v1 l => k_ok (Three l k1 v2 m k2 v2 r))
              end
            | Lt =>
              twothree_modify l (fun l' => k_ok (Three l' k1 v1 m k2 v2 r))
                                (fun l' k' v' r' => k_splice_up (Two l' k' v' r') k1 v1 (Two m k2 v2 r))
            | Gt =>
              match RD_K k k2 with
                | Eq =>
                  match upd v2 with
                    | Some v2 => k_ok (Three l k1 v1 m k v2 r)
                    | None =>
                      remove_greatest m (fun _ => k_ok (Two l k1 v1 r))
                                        (fun k' v' m' => k_ok (Three l k1 v1 m' k' v' r))
                  end
                | Lt =>
                  twothree_modify m (fun m' => k_ok (Three l k1 v1 m' k2 v2 r))
                                    (fun l' k' v' r' => k_splice_up (Two l k1 v1 l') k' v' (Two r' k2 v2 r))
                | Gt =>
                  twothree_modify r (fun r' => k_ok (Three l k1 v1 m k2 v2 r'))
                                    (fun l' k' v' r' => k_splice_up (Two l k1 v1 m) k2 v2 (Two l' k' v' r'))
              end
          end
      end.

  End modify.

  Definition twothree_add {V} (k : K) (v : V) (m : twothree V) : twothree V :=
    twothree_modify k (fun _ => Some v) (Some v) m (fun m => m) Two.

  Definition twothree_remove {V} (k : K) (m : twothree V) : twothree V :=
    twothree_modify k (fun _ => None) None m (fun m => m) Two.

  Fixpoint twothree_find {V} (k : K) (m : twothree V) : option V :=
    match m with
      | Leaf => None
      | Two l k' v' r =>
        match RD_K k k' with
          | Eq => Some v'
          | Lt => twothree_find k l
          | Gt => twothree_find k r
        end
      | Three l k1 v1 m k2 v2 r =>
        match RD_K k k1 with
          | Eq => Some v1
          | Lt => twothree_find k l
          | Gt => match RD_K k k2 with
                    | Eq => Some v2
                    | Lt => twothree_find k m
                    | Gt => twothree_find k r
                  end
        end
    end.

  Section fold.
    Import MonadNotation.
    Local Open Scope monad_scope.

    Variables V T : Type.
    Variable f : K -> V -> T -> T.

    Fixpoint twothree_fold (acc : T) (map : twothree V) : T :=
      match map with
        | Leaf => acc
        | Two l k v r =>
          let acc := twothree_fold acc l in
          let acc := f k v acc in
          twothree_fold acc r
        | Three l k1 v1 m k2 v2 r =>
          let acc := twothree_fold acc l in
          let acc := f k1 v1 acc in
          let acc := twothree_fold acc m in
          let acc := f k2 v2 acc in
          twothree_fold acc m
      end.

  End fold.

  Definition twothree_union {V} (m1 m2 : twothree V) : twothree V :=
    twothree_fold twothree_add m2 m1.

  Global Instance Map_twothree V : Map K V (twothree V) :=
  { empty  := Leaf
  ; add    := twothree_add
  ; remove := twothree_remove
  ; lookup := twothree_find
  ; union  := twothree_union
  }.

  Require Import ExtLib.Structures.Reducible.

  Global Instance Foldable_twothree V : Foldable (twothree V) (K * V) :=
    fun _ f b x => twothree_fold (fun k v => f (k,v)) b x.

End keyed.

(** Performance Test **)
(*
Module TEST.
  Definition m := twothree nat nat.
  Instance Map_m : Map nat (twothree nat).
    apply Map_twothree.
    apply Compare_dec.nat_compare.
  Defined.

  Definition z : m :=
    (fix fill n acc : m :=
      let acc := add n n acc in
      match n with
        | 0 => acc
        | S n => fill n acc
      end) 500 empty.

  Time Eval vm_compute in
    let z := z in
    (fix find_all n : unit :=
      let _ := lookup n z in
      match n with
        | 0 => tt
        | S n => find_all n
      end) 500.
End TEST.
*)


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__3__7a.
Require Export lemma__3__7b.
Require Export lemma__betweennotequal.
Require Export lemma__congruenceflip.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export lemma__equalitysymmetric.
Require Export lemma__extension.
Require Export lemma__inequalitysymmetric.
Require Export lemma__layoff.
Require Export lemma__layoffunique.
Require Export lemma__lessthancongruence.
Require Export lemma__lessthancongruence2.
Require Export lemma__lessthannotequal.
Require Export lemma__ondiameter.
Require Export lemma__ray4.
Require Export lemma__ray5.
Require Export lemma__subtractequals.
Require Export lemma__together.
Require Export lemma__trichotomy2.
Require Export logic.
Definition lemma__togethera : forall A B C D F G P Q a b c, (euclidean__defs.TG A a B b C c) -> ((euclidean__axioms.Cong D F A a) -> ((euclidean__axioms.Cong F G B b) -> ((euclidean__axioms.BetS D F G) -> ((euclidean__axioms.Cong P Q C c) -> (euclidean__defs.Lt P Q D G))))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro F.
intro G.
intro P.
intro Q.
intro a.
intro b.
intro c.
intro H.
intro H0.
intro H1.
intro H2.
intro H3.
assert (* Cut *) ((euclidean__defs.TG A a B b C c) -> ((euclidean__axioms.Cong D F A a) -> ((euclidean__axioms.Cong F G B b) -> ((euclidean__axioms.BetS D F G) -> ((euclidean__axioms.Cong P Q C c) -> (euclidean__defs.Lt P Q D G)))))) as H4.
- intro __.
intro __0.
intro __1.
intro __2.
intro __3.
assert (* AndElim *) ((euclidean__defs.Lt P Q D G) /\ ((euclidean__axioms.neq A a) /\ ((euclidean__axioms.neq B b) /\ (euclidean__axioms.neq C c)))) as __4.
-- apply (@lemma__together.lemma__together A B C D F G P Q a b c __ __0 __1 __2 __3).
-- destruct __4 as [__4 __5].
exact __4.
- apply (@H4 H H0 H1 H2 H3).
Qed.
Definition proposition__22 : forall A B C E F a b c, (euclidean__defs.TG A a B b C c) -> ((euclidean__defs.TG A a C c B b) -> ((euclidean__defs.TG B b C c A a) -> ((euclidean__axioms.neq F E) -> (exists X Y, (euclidean__axioms.Cong F X B b) /\ ((euclidean__axioms.Cong F Y A a) /\ ((euclidean__axioms.Cong X Y C c) /\ ((euclidean__defs.Out F E X) /\ (euclidean__axioms.Triangle F X Y)))))))).
Proof.
intro A.
intro B.
intro C.
intro E.
intro F.
intro a.
intro b.
intro c.
intro H.
intro H0.
intro H1.
intro H2.
assert (exists P, (euclidean__axioms.BetS A a P) /\ ((euclidean__axioms.Cong a P B b) /\ (euclidean__defs.Lt C c A P))) as H3 by exact H.
destruct H3 as [P H4].
destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
assert (* Cut *) (euclidean__axioms.neq A a) as H9.
- assert (* Cut *) ((euclidean__axioms.neq a P) /\ ((euclidean__axioms.neq A a) /\ (euclidean__axioms.neq A P))) as H9.
-- apply (@lemma__betweennotequal.lemma__betweennotequal A a P H5).
-- destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
exact H12.
- assert (* Cut *) (euclidean__axioms.neq a P) as H10.
-- assert (* Cut *) ((euclidean__axioms.neq a P) /\ ((euclidean__axioms.neq A a) /\ (euclidean__axioms.neq A P))) as H10.
--- apply (@lemma__betweennotequal.lemma__betweennotequal A a P H5).
--- destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
exact H11.
-- assert (* Cut *) (euclidean__axioms.neq B b) as H11.
--- apply (@euclidean__axioms.axiom__nocollapse a P B b H10 H7).
--- assert (* Cut *) (euclidean__axioms.neq C c) as H12.
---- assert (* Cut *) ((euclidean__axioms.neq C c) /\ (euclidean__axioms.neq A P)) as H12.
----- apply (@lemma__lessthannotequal.lemma__lessthannotequal C c A P H8).
----- destruct H12 as [H13 H14].
exact H13.
---- assert (* Cut *) (exists G, (euclidean__defs.Out F E G) /\ (euclidean__axioms.Cong F G B b)) as H13.
----- apply (@lemma__layoff.lemma__layoff F E B b H2 H11).
----- destruct H13 as [G H14].
destruct H14 as [H15 H16].
assert (* Cut *) (euclidean__axioms.Cong B b F G) as H17.
------ apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B F G b H16).
------ assert (* Cut *) (euclidean__axioms.neq F G) as H18.
------- apply (@euclidean__axioms.axiom__nocollapse B b F G H11 H17).
------- assert (* Cut *) (euclidean__axioms.neq G F) as H19.
-------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric F G H18).
-------- assert (* Cut *) (exists H20, (euclidean__axioms.BetS F G H20) /\ (euclidean__axioms.Cong G H20 C c)) as H20.
--------- apply (@lemma__extension.lemma__extension F G C c H18 H12).
--------- destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
assert (* Cut *) (exists D, (euclidean__axioms.BetS G F D) /\ (euclidean__axioms.Cong F D A a)) as H25.
---------- apply (@lemma__extension.lemma__extension G F A a H19 H9).
---------- destruct H25 as [D H26].
destruct H26 as [H27 H28].
assert (* Cut *) (euclidean__axioms.Cong D F A a) as H29.
----------- assert (* Cut *) ((euclidean__axioms.Cong D F a A) /\ ((euclidean__axioms.Cong D F A a) /\ (euclidean__axioms.Cong F D a A))) as H29.
------------ apply (@lemma__congruenceflip.lemma__congruenceflip F D A a H28).
------------ destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
exact H32.
----------- assert (* Cut *) (euclidean__axioms.BetS D F G) as H30.
------------ apply (@euclidean__axioms.axiom__betweennesssymmetry G F D H27).
------------ assert (* Cut *) (euclidean__axioms.neq F D) as H31.
------------- assert (* Cut *) ((euclidean__axioms.neq F D) /\ ((euclidean__axioms.neq G F) /\ (euclidean__axioms.neq G D))) as H31.
-------------- apply (@lemma__betweennotequal.lemma__betweennotequal G F D H27).
-------------- destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
exact H32.
------------- assert (* Cut *) (euclidean__axioms.neq G H21) as H32.
-------------- assert (* Cut *) ((euclidean__axioms.neq G H21) /\ ((euclidean__axioms.neq F G) /\ (euclidean__axioms.neq F H21))) as H32.
--------------- apply (@lemma__betweennotequal.lemma__betweennotequal F G H21 H23).
--------------- destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
exact H33.
-------------- assert (* Cut *) (exists L, euclidean__axioms.CI L F F D) as H33.
--------------- apply (@euclidean__axioms.postulate__Euclid3 F D H31).
--------------- destruct H33 as [L H34].
assert (* Cut *) (exists R, euclidean__axioms.CI R G G H21) as H35.
---------------- apply (@euclidean__axioms.postulate__Euclid3 G H21 H32).
---------------- destruct H35 as [R H36].
assert (* Cut *) (euclidean__axioms.Cong G H21 G H21) as H37.
----------------- apply (@euclidean__axioms.cn__congruencereflexive G H21).
----------------- assert (* Cut *) (euclidean__axioms.OnCirc H21 R) as H38.
------------------ exists G.
exists H21.
exists G.
split.
------------------- exact H36.
------------------- exact H37.
------------------ assert (* Cut *) (euclidean__defs.Lt D F F H21) as H39.
------------------- assert (* Cut *) (forall A0 B0 C0 D0 F0 G0 P0 Q a0 b0 c0, (euclidean__defs.TG A0 a0 B0 b0 C0 c0) -> ((euclidean__axioms.Cong D0 F0 A0 a0) -> ((euclidean__axioms.Cong F0 G0 B0 b0) -> ((euclidean__axioms.BetS D0 F0 G0) -> ((euclidean__axioms.Cong P0 Q C0 c0) -> (euclidean__defs.Lt P0 Q D0 G0)))))) as H39.
-------------------- intro A0.
intro B0.
intro C0.
intro D0.
intro F0.
intro G0.
intro P0.
intro Q.
intro a0.
intro b0.
intro c0.
intro __.
intro __0.
intro __1.
intro __2.
intro __3.
assert (* AndElim *) ((euclidean__defs.Lt P0 Q D0 G0) /\ ((euclidean__axioms.neq A0 a0) /\ ((euclidean__axioms.neq B0 b0) /\ (euclidean__axioms.neq C0 c0)))) as __4.
--------------------- apply (@lemma__together.lemma__together A0 B0 C0 D0 F0 G0 P0 Q a0 b0 c0 __ __0 __1 __2 __3).
--------------------- destruct __4 as [__4 __5].
exact __4.
-------------------- apply (@H39 B C A F G H21 D F b c a H1 H16 H24 H23 H29).
------------------- assert (exists M, (euclidean__axioms.BetS F M H21) /\ (euclidean__axioms.Cong F M D F)) as H40 by exact H39.
destruct H40 as [M H41].
destruct H41 as [H42 H43].
assert (* Cut *) (euclidean__axioms.Cong F M A a) as H44.
-------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive F M D F A a H43 H29).
-------------------- assert (* Cut *) (euclidean__axioms.Cong A a F M) as H45.
--------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A F M a H44).
--------------------- assert (* Cut *) (euclidean__axioms.Cong A a F D) as H46.
---------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A F D a H28).
---------------------- assert (* Cut *) (euclidean__axioms.Cong F M F D) as H47.
----------------------- apply (@euclidean__axioms.cn__congruencetransitive F M F D A a H45 H46).
----------------------- assert (* Cut *) (euclidean__axioms.OutCirc H21 L) as H48.
------------------------ exists M.
exists F.
exists F.
exists D.
split.
------------------------- exact H34.
------------------------- split.
-------------------------- exact H42.
-------------------------- exact H47.
------------------------ assert (* Cut *) (euclidean__axioms.Cong C c C c) as H49.
------------------------- apply (@euclidean__axioms.cn__congruencereflexive C c).
------------------------- assert (* Cut *) (euclidean__defs.Lt C c D G) as H50.
-------------------------- apply (@proposition__22.lemma__togethera A B C D F G C c a b c H H29 H16 H30 H49).
-------------------------- assert (* Cut *) (euclidean__axioms.Cong D G G D) as H51.
--------------------------- apply (@euclidean__axioms.cn__equalityreverse D G).
--------------------------- assert (* Cut *) (euclidean__defs.Lt C c G D) as H52.
---------------------------- apply (@lemma__lessthancongruence.lemma__lessthancongruence C c D G G D H50 H51).
---------------------------- assert (exists N, (euclidean__axioms.BetS G N D) /\ (euclidean__axioms.Cong G N C c)) as H53 by exact H52.
destruct H53 as [N H54].
destruct H54 as [H55 H56].
assert (* Cut *) (euclidean__axioms.BetS D F H21) as H57.
----------------------------- apply (@lemma__3__7b.lemma__3__7b D F G H21 H30 H23).
----------------------------- assert (* Cut *) (euclidean__axioms.BetS D F M) as H58.
------------------------------ apply (@euclidean__axioms.axiom__innertransitivity D F M H21 H57 H42).
------------------------------ assert (* Cut *) (euclidean__axioms.Cong F D A a) as H59.
------------------------------- assert (* Cut *) ((euclidean__axioms.Cong N G c C) /\ ((euclidean__axioms.Cong N G C c) /\ (euclidean__axioms.Cong G N c C))) as H59.
-------------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip G N C c H56).
-------------------------------- destruct H59 as [H60 H61].
destruct H61 as [H62 H63].
exact H28.
------------------------------- assert (* Cut *) (euclidean__axioms.BetS D N G) as H60.
-------------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry G N D H55).
-------------------------------- assert (* Cut *) (euclidean__axioms.neq F M) as H61.
--------------------------------- assert (* Cut *) ((euclidean__axioms.neq F M) /\ ((euclidean__axioms.neq D F) /\ (euclidean__axioms.neq D M))) as H61.
---------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal D F M H58).
---------------------------------- destruct H61 as [H62 H63].
destruct H63 as [H64 H65].
exact H62.
--------------------------------- assert (* Cut *) (exists J, (euclidean__axioms.BetS F M J) /\ (euclidean__axioms.Cong M J C c)) as H62.
---------------------------------- apply (@lemma__extension.lemma__extension F M C c H61 H12).
---------------------------------- destruct H62 as [J H63].
destruct H63 as [H64 H65].
assert (* Cut *) (euclidean__axioms.BetS D F J) as H66.
----------------------------------- apply (@lemma__3__7b.lemma__3__7b D F M J H58 H64).
----------------------------------- assert (* Cut *) ((euclidean__defs.Lt F G F J) /\ ((euclidean__axioms.neq A a) /\ ((euclidean__axioms.neq C c) /\ (euclidean__axioms.neq B b)))) as H67.
------------------------------------ apply (@lemma__together.lemma__together A C B F M J F G a c b H0 H44 H65 H64 H16).
------------------------------------ assert (* Cut *) (exists Q, (euclidean__axioms.BetS F Q J) /\ (euclidean__axioms.Cong F Q F G)) as H68.
------------------------------------- destruct H67 as [H68 H69].
destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
exact H68.
------------------------------------- destruct H68 as [Q H69].
destruct H69 as [H70 H71].
destruct H67 as [H72 H73].
destruct H73 as [H74 H75].
destruct H75 as [H76 H77].
assert (* Cut *) (euclidean__axioms.neq F J) as H78.
-------------------------------------- assert (* Cut *) ((euclidean__axioms.neq Q J) /\ ((euclidean__axioms.neq F Q) /\ (euclidean__axioms.neq F J))) as H78.
--------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal F Q J H70).
--------------------------------------- destruct H78 as [H79 H80].
destruct H80 as [H81 H82].
exact H82.
-------------------------------------- assert (* Cut *) (euclidean__defs.Out F J Q) as H79.
--------------------------------------- apply (@lemma__ray4.lemma__ray4 F J Q).
----------------------------------------left.
exact H70.

---------------------------------------- exact H78.
--------------------------------------- assert (* Cut *) (euclidean__defs.Out F G J) as H80.
---------------------------------------- exists D.
split.
----------------------------------------- exact H66.
----------------------------------------- exact H30.
---------------------------------------- assert (* Cut *) (euclidean__defs.Out F J G) as H81.
----------------------------------------- apply (@lemma__ray5.lemma__ray5 F G J H80).
----------------------------------------- assert (* Cut *) (Q = G) as H82.
------------------------------------------ apply (@lemma__layoffunique.lemma__layoffunique F J Q G H79 H81 H71).
------------------------------------------ assert (* Cut *) (G = Q) as H83.
------------------------------------------- apply (@lemma__equalitysymmetric.lemma__equalitysymmetric G Q H82).
------------------------------------------- assert (* Cut *) (euclidean__axioms.BetS F G J) as H84.
-------------------------------------------- apply (@eq__ind euclidean__axioms.Point Q (fun G0 => (euclidean__defs.Out F E G0) -> ((euclidean__axioms.Cong F G0 B b) -> ((euclidean__axioms.Cong B b F G0) -> ((euclidean__axioms.neq F G0) -> ((euclidean__axioms.neq G0 F) -> ((euclidean__axioms.BetS F G0 H21) -> ((euclidean__axioms.Cong G0 H21 C c) -> ((euclidean__axioms.BetS G0 F D) -> ((euclidean__axioms.BetS D F G0) -> ((euclidean__axioms.neq G0 H21) -> ((euclidean__axioms.CI R G0 G0 H21) -> ((euclidean__axioms.Cong G0 H21 G0 H21) -> ((euclidean__defs.Lt C c D G0) -> ((euclidean__axioms.Cong D G0 G0 D) -> ((euclidean__defs.Lt C c G0 D) -> ((euclidean__axioms.BetS G0 N D) -> ((euclidean__axioms.Cong G0 N C c) -> ((euclidean__axioms.BetS D N G0) -> ((euclidean__defs.Lt F G0 F J) -> ((euclidean__axioms.Cong F Q F G0) -> ((euclidean__defs.Out F G0 J) -> ((euclidean__defs.Out F J G0) -> ((G0 = Q) -> (euclidean__axioms.BetS F G0 J))))))))))))))))))))))))) with (y := G).
---------------------------------------------intro H84.
intro H85.
intro H86.
intro H87.
intro H88.
intro H89.
intro H90.
intro H91.
intro H92.
intro H93.
intro H94.
intro H95.
intro H96.
intro H97.
intro H98.
intro H99.
intro H100.
intro H101.
intro H102.
intro H103.
intro H104.
intro H105.
intro H106.
assert (Q = Q) as H107 by exact H106.
exact H70.

--------------------------------------------- exact H82.
--------------------------------------------- exact H15.
--------------------------------------------- exact H16.
--------------------------------------------- exact H17.
--------------------------------------------- exact H18.
--------------------------------------------- exact H19.
--------------------------------------------- exact H23.
--------------------------------------------- exact H24.
--------------------------------------------- exact H27.
--------------------------------------------- exact H30.
--------------------------------------------- exact H32.
--------------------------------------------- exact H36.
--------------------------------------------- exact H37.
--------------------------------------------- exact H50.
--------------------------------------------- exact H51.
--------------------------------------------- exact H52.
--------------------------------------------- exact H55.
--------------------------------------------- exact H56.
--------------------------------------------- exact H60.
--------------------------------------------- exact H72.
--------------------------------------------- exact H71.
--------------------------------------------- exact H80.
--------------------------------------------- exact H81.
--------------------------------------------- exact H83.
-------------------------------------------- assert (* Cut *) (euclidean__axioms.BetS D G J) as H85.
--------------------------------------------- apply (@lemma__3__7a.lemma__3__7a D F G J H30 H84).
--------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong C c M J) as H86.
---------------------------------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric C M J c H65).
---------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong G N M J) as H87.
----------------------------------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive G N C c M J H56 H86).
----------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong N G M J) as H88.
------------------------------------------------ assert (* Cut *) ((euclidean__axioms.Cong N G J M) /\ ((euclidean__axioms.Cong N G M J) /\ (euclidean__axioms.Cong G N J M))) as H88.
------------------------------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip G N M J H87).
------------------------------------------------- destruct H88 as [H89 H90].
destruct H90 as [H91 H92].
exact H91.
------------------------------------------------ assert (* Cut *) (euclidean__axioms.BetS D M J) as H89.
------------------------------------------------- apply (@lemma__3__7a.lemma__3__7a D F M J H58 H64).
------------------------------------------------- assert (* Cut *) (euclidean__axioms.BetS D N M) as H90.
-------------------------------------------------- apply (@lemma__subtractequals.lemma__subtractequals D N G M J H60 H89 H88 H85).
-------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong F D F D) as H91.
--------------------------------------------------- apply (@euclidean__axioms.cn__congruencereflexive F D).
--------------------------------------------------- assert (* Cut *) (euclidean__axioms.InCirc N L) as H92.
---------------------------------------------------- apply (@lemma__ondiameter.lemma__ondiameter D F L M N F D H34 H91 H47 H58 H90).
---------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong C c G H21) as H93.
----------------------------------------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric C G H21 c H24).
----------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong C c G N) as H94.
------------------------------------------------------ apply (@lemma__congruencesymmetric.lemma__congruencesymmetric C G N c H56).
------------------------------------------------------ assert (* Cut *) (euclidean__axioms.Cong G N G H21) as H95.
------------------------------------------------------- apply (@euclidean__axioms.cn__congruencetransitive G N G H21 C c H94 H93).
------------------------------------------------------- assert (* Cut *) (euclidean__axioms.OnCirc N R) as H96.
-------------------------------------------------------- exists G.
exists H21.
exists G.
split.
--------------------------------------------------------- exact H36.
--------------------------------------------------------- exact H95.
-------------------------------------------------------- assert (* Cut *) (exists K, (euclidean__axioms.OnCirc K L) /\ (euclidean__axioms.OnCirc K R)) as H97.
--------------------------------------------------------- apply (@euclidean__axioms.postulate__circle__circle F G G H21 L R N H21 F D H34 H92 H48 H36 H96 H38).
--------------------------------------------------------- destruct H97 as [K H98].
destruct H98 as [H99 H100].
assert (* Cut *) (euclidean__axioms.Cong F K F D) as H101.
---------------------------------------------------------- apply (@euclidean__axioms.axiom__circle__center__radius F F D L K H34 H99).
---------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong F K A a) as H102.
----------------------------------------------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive F K F D A a H101 H59).
----------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong G K G H21) as H103.
------------------------------------------------------------ apply (@euclidean__axioms.axiom__circle__center__radius G G H21 R K H36 H100).
------------------------------------------------------------ assert (* Cut *) (euclidean__axioms.Cong G K C c) as H104.
------------------------------------------------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive G K G H21 C c H103 H24).
------------------------------------------------------------- assert (* Cut *) (~(euclidean__axioms.Col F G K)) as H105.
-------------------------------------------------------------- intro H105.
assert ((F = G) \/ ((F = K) \/ ((G = K) \/ ((euclidean__axioms.BetS G F K) \/ ((euclidean__axioms.BetS F G K) \/ (euclidean__axioms.BetS F K G)))))) as H106 by exact H105.
assert (* Cut *) (euclidean__axioms.nCol F G K) as H107.
--------------------------------------------------------------- assert ((F = G) \/ ((F = K) \/ ((G = K) \/ ((euclidean__axioms.BetS G F K) \/ ((euclidean__axioms.BetS F G K) \/ (euclidean__axioms.BetS F K G)))))) as H107 by exact H106.
assert ((F = G) \/ ((F = K) \/ ((G = K) \/ ((euclidean__axioms.BetS G F K) \/ ((euclidean__axioms.BetS F G K) \/ (euclidean__axioms.BetS F K G)))))) as __TmpHyp by exact H107.
destruct __TmpHyp as [H108|H108].
---------------------------------------------------------------- assert (* Cut *) (~(euclidean__axioms.Col F G K)) as H109.
----------------------------------------------------------------- intro H109.
apply (@H18 H108).
----------------------------------------------------------------- apply (@euclidean__tactics.nCol__notCol F G K H109).
---------------------------------------------------------------- destruct H108 as [H109|H109].
----------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong A a F K) as H110.
------------------------------------------------------------------ apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A F K a H102).
------------------------------------------------------------------ assert (* Cut *) (~(euclidean__axioms.Col F G K)) as H111.
------------------------------------------------------------------- intro H111.
assert (* Cut *) (euclidean__axioms.neq F K) as H112.
-------------------------------------------------------------------- apply (@euclidean__axioms.axiom__nocollapse A a F K H74 H110).
-------------------------------------------------------------------- apply (@H112 H109).
------------------------------------------------------------------- apply (@euclidean__tactics.nCol__notCol F G K H111).
----------------------------------------------------------------- destruct H109 as [H110|H110].
------------------------------------------------------------------ assert (* Cut *) (euclidean__axioms.Cong C c G K) as H111.
------------------------------------------------------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric C G K c H104).
------------------------------------------------------------------- assert (* Cut *) (~(euclidean__axioms.Col F G K)) as H112.
-------------------------------------------------------------------- intro H112.
assert (* Cut *) (euclidean__axioms.neq G K) as H113.
--------------------------------------------------------------------- apply (@euclidean__axioms.axiom__nocollapse C c G K H76 H111).
--------------------------------------------------------------------- apply (@H113 H110).
-------------------------------------------------------------------- apply (@euclidean__tactics.nCol__notCol F G K H112).
------------------------------------------------------------------ destruct H110 as [H111|H111].
------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.BetS K F G) as H112.
-------------------------------------------------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry G F K H111).
-------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong K F A a) as H113.
--------------------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Cong K F a A) /\ ((euclidean__axioms.Cong K F A a) /\ (euclidean__axioms.Cong F K a A))) as H113.
---------------------------------------------------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip F K A a H102).
---------------------------------------------------------------------- destruct H113 as [H114 H115].
destruct H115 as [H116 H117].
exact H116.
--------------------------------------------------------------------- assert (exists S, (euclidean__axioms.BetS A a S) /\ ((euclidean__axioms.Cong a S B b) /\ (euclidean__defs.Lt C c A S))) as H114 by exact H.
destruct H114 as [S H115].
destruct H115 as [H116 H117].
destruct H117 as [H118 H119].
assert (* Cut *) (euclidean__axioms.Cong A a K F) as H120.
---------------------------------------------------------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A K F a H113).
---------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong a S F G) as H121.
----------------------------------------------------------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive a S B b F G H118 H17).
----------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong A S K G) as H122.
------------------------------------------------------------------------ apply (@euclidean__axioms.cn__sumofparts A a S K F G H120 H121 H116 H112).
------------------------------------------------------------------------ assert (* Cut *) (euclidean__axioms.Cong A S G K) as H123.
------------------------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Cong S A G K) /\ ((euclidean__axioms.Cong S A K G) /\ (euclidean__axioms.Cong A S G K))) as H123.
-------------------------------------------------------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip A S K G H122).
-------------------------------------------------------------------------- destruct H123 as [H124 H125].
destruct H125 as [H126 H127].
exact H127.
------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Lt C c G K) as H124.
-------------------------------------------------------------------------- apply (@lemma__lessthancongruence.lemma__lessthancongruence C c A S G K H119 H123).
-------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong C c G K) as H125.
--------------------------------------------------------------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric C G K c H104).
--------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Lt G K G K) as H126.
---------------------------------------------------------------------------- apply (@lemma__lessthancongruence2.lemma__lessthancongruence2 C c G K G K H124 H125).
---------------------------------------------------------------------------- assert (* Cut *) (~(euclidean__axioms.Col F G K)) as H127.
----------------------------------------------------------------------------- intro H127.
assert (* Cut *) (~(euclidean__defs.Lt G K G K)) as H128.
------------------------------------------------------------------------------ apply (@lemma__trichotomy2.lemma__trichotomy2 G K G K H126).
------------------------------------------------------------------------------ apply (@H128 H126).
----------------------------------------------------------------------------- apply (@euclidean__tactics.nCol__notCol F G K H127).
------------------------------------------------------------------- destruct H111 as [H112|H112].
-------------------------------------------------------------------- assert (exists S, (euclidean__axioms.BetS B b S) /\ ((euclidean__axioms.Cong b S C c) /\ (euclidean__defs.Lt A a B S))) as H113 by exact H1.
destruct H113 as [S H114].
destruct H114 as [H115 H116].
destruct H116 as [H117 H118].
assert (* Cut *) (euclidean__axioms.Cong C c b S) as H119.
--------------------------------------------------------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric C b S c H117).
--------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong G K b S) as H120.
---------------------------------------------------------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive G K C c b S H104 H119).
---------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong F K B S) as H121.
----------------------------------------------------------------------- apply (@euclidean__axioms.cn__sumofparts F G K B b S H16 H120 H112 H115).
----------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong A a F K) as H122.
------------------------------------------------------------------------ apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A F K a H102).
------------------------------------------------------------------------ assert (* Cut *) (euclidean__defs.Lt F K B S) as H123.
------------------------------------------------------------------------- apply (@lemma__lessthancongruence2.lemma__lessthancongruence2 A a B S F K H118 H122).
------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong B S F K) as H124.
-------------------------------------------------------------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B F K S H121).
-------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Lt F K F K) as H125.
--------------------------------------------------------------------------- apply (@lemma__lessthancongruence.lemma__lessthancongruence F K B S F K H123 H124).
--------------------------------------------------------------------------- assert (* Cut *) (~(euclidean__axioms.Col F G K)) as H126.
---------------------------------------------------------------------------- intro H126.
assert (* Cut *) (~(euclidean__defs.Lt F K F K)) as H127.
----------------------------------------------------------------------------- apply (@lemma__trichotomy2.lemma__trichotomy2 F K F K H125).
----------------------------------------------------------------------------- apply (@H127 H125).
---------------------------------------------------------------------------- apply (@euclidean__tactics.nCol__notCol F G K H126).
-------------------------------------------------------------------- assert (exists S, (euclidean__axioms.BetS A a S) /\ ((euclidean__axioms.Cong a S C c) /\ (euclidean__defs.Lt B b A S))) as H113 by exact H0.
destruct H113 as [S H114].
destruct H114 as [H115 H116].
destruct H116 as [H117 H118].
assert (* Cut *) (euclidean__defs.Lt F G A S) as H119.
--------------------------------------------------------------------- apply (@lemma__lessthancongruence2.lemma__lessthancongruence2 B b A S F G H118 H17).
--------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong C c a S) as H120.
---------------------------------------------------------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric C a S c H117).
---------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong G K a S) as H121.
----------------------------------------------------------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive G K C c a S H104 H120).
----------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong K G a S) as H122.
------------------------------------------------------------------------ assert (* Cut *) ((euclidean__axioms.Cong K G S a) /\ ((euclidean__axioms.Cong K G a S) /\ (euclidean__axioms.Cong G K S a))) as H122.
------------------------------------------------------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip G K a S H121).
------------------------------------------------------------------------- destruct H122 as [H123 H124].
destruct H124 as [H125 H126].
exact H125.
------------------------------------------------------------------------ assert (* Cut *) (euclidean__axioms.Cong F G A S) as H123.
------------------------------------------------------------------------- apply (@euclidean__axioms.cn__sumofparts F K G A a S H102 H122 H112 H115).
------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong A S F G) as H124.
-------------------------------------------------------------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A F G S H123).
-------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Lt F G F G) as H125.
--------------------------------------------------------------------------- apply (@lemma__lessthancongruence.lemma__lessthancongruence F G A S F G H119 H124).
--------------------------------------------------------------------------- assert (* Cut *) (~(euclidean__axioms.Col F G K)) as H126.
---------------------------------------------------------------------------- intro H126.
assert (* Cut *) (~(euclidean__defs.Lt F G F G)) as H127.
----------------------------------------------------------------------------- apply (@lemma__trichotomy2.lemma__trichotomy2 F G F G H125).
----------------------------------------------------------------------------- apply (@H127 H125).
---------------------------------------------------------------------------- apply (@euclidean__tactics.nCol__notCol F G K H126).
--------------------------------------------------------------- apply (@euclidean__tactics.Col__nCol__False F G K H107 H106).
-------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Triangle F G K) as H106.
--------------------------------------------------------------- apply (@euclidean__tactics.nCol__notCol F G K H105).
--------------------------------------------------------------- exists G.
exists K.
split.
---------------------------------------------------------------- exact H16.
---------------------------------------------------------------- split.
----------------------------------------------------------------- exact H102.
----------------------------------------------------------------- split.
------------------------------------------------------------------ exact H104.
------------------------------------------------------------------ split.
------------------------------------------------------------------- exact H15.
------------------------------------------------------------------- exact H106.
Qed.


From stdpp Require Import countable numbers gmap.
From iris.prelude Require Export prelude.
From iris.prelude Require Import options.

Record loc := Loc { loc_car : Z }.

Add Printing Constructor loc.

Global Instance loc_eq_decision : EqDecision loc.
Proof. solve_decision. Defined.

Global Instance loc_inhabited : Inhabited loc := populate {|loc_car := 0 |}.

Global Instance loc_countable : Countable loc.
Proof. by apply (inj_countable' loc_car Loc); intros []. Defined.

#[global] Program Instance loc_infinite : Infinite loc :=
  inj_infinite (λ p, {| loc_car := p |}) (λ l, Some (loc_car l)) _.
Next Obligation. done. Qed.

Definition loc_add (l : loc) (off : Z) : loc :=
  {| loc_car := loc_car l + off|}.

Notation "l +ₗ off" :=
  (loc_add l off) (at level 50, left associativity) : stdpp_scope.

Lemma loc_add_assoc l i j : l +ₗ i +ₗ j = l +ₗ (i + j).
Proof. destruct l; rewrite /loc_add /=; f_equal; lia. Qed.

Lemma loc_add_0 l : l +ₗ 0 = l.
Proof. destruct l; rewrite /loc_add /=; f_equal; lia. Qed.

Global Instance loc_add_inj l : Inj eq eq (loc_add l).
Proof. destruct l; rewrite /Inj /loc_add /=; intros; simplify_eq; lia. Qed.

Definition fresh_locs (ls : gset loc) : loc :=
  {| loc_car := set_fold (λ k r, (1 + loc_car k) `max` r)%Z 1%Z ls |}.

Lemma fresh_locs_fresh ls i :
  (0 ≤ i)%Z → fresh_locs ls +ₗ i ∉ ls.
Proof.
  intros Hi. cut (∀ l, l ∈ ls → loc_car l < loc_car (fresh_locs ls) + i)%Z.
  { intros help Hf%help. simpl in *. lia. }
  apply (set_fold_ind_L (λ r ls, ∀ l, l ∈ ls → (loc_car l < r + i)%Z));
    set_solver by eauto with lia.
Qed.

Global Opaque fresh_locs.


Require Import MirrorCore.Lemma.
Require Import MirrorCore.Lambda.Expr.

Set Implicit Arguments.
Set Strict Implicit.

(* This code purposefully does not use the reification mechanism so that it
 * can remain agnostic to the underlying implementation.
 *)
Section cancel_lemmas.
  Context {typ func : Type}.
  Variable T : typ.
  Variable R P U : expr typ func.

  Let p (a b : expr typ func) : expr typ func :=
    App (App P a) b.
  Let r (a b : expr typ func) : expr typ func :=
    App (App R a) b.

  Definition lem_plus_unit_c : Lemma.lemma typ (expr typ func) (expr typ func) :=
  {| vars := T :: T :: nil;
     premises := App (App R (ExprCore.Var 0)) (ExprCore.Var 1) :: nil;
     concl := App (App R (ExprCore.Var 0))  (App (App P U) (ExprCore.Var 1)) |}.
  Definition lem_plus_assoc_c1 : Lemma.lemma typ (expr typ func) (expr typ func) :=
  {| vars := T :: T :: T :: T :: nil;
     premises := App (App R (ExprCore.Var 3))
                     (App (App P (ExprCore.Var 0))
                          (App (App P (ExprCore.Var 1)) (ExprCore.Var 2))) :: nil;
     concl := App (App R (ExprCore.Var 3))
                  (App (App P (App (App P (ExprCore.Var 0)) (ExprCore.Var 1)))
                       (ExprCore.Var 2)) |}.
  Definition lem_plus_assoc_c2 : Lemma.lemma typ (expr typ func) (expr typ func) :=
  {| vars := T :: T :: T :: T :: nil;
     premises := App (App R (ExprCore.Var 3))
                     (App (App P (ExprCore.Var 1))
                          (App (App P (ExprCore.Var 0)) (ExprCore.Var 2))) :: nil;
     concl := App (App R (ExprCore.Var 3))
                  (App (App P (App (App P (ExprCore.Var 0)) (ExprCore.Var 1)))
                       (ExprCore.Var 2)) |}.
  Definition lem_plus_comm_c : Lemma.lemma typ (expr typ func) (expr typ func) :=
  {| vars := T :: T :: T :: nil;
     premises := App (App R (ExprCore.Var 2))
                     (App (App P (ExprCore.Var 0)) (ExprCore.Var 1)) :: nil;
     concl := App (App R (ExprCore.Var 2))
                  (App (App P (ExprCore.Var 1)) (ExprCore.Var 0)) |}.
  Definition lem_plus_cancel : Lemma.lemma typ (expr typ func) (expr typ func) :=
  {| vars := T :: T :: T :: T :: nil;
     premises := App (App R (ExprCore.Var 0)) (ExprCore.Var 2)
                     :: App (App R (ExprCore.Var 1)) (ExprCore.Var 3)
                     :: nil;
     concl := App
                (App R (App (App P (ExprCore.Var 0)) (ExprCore.Var 1)))
                (App (App P (ExprCore.Var 2)) (ExprCore.Var 3)) |}.

  Definition lem_plus_unit_p : Lemma.lemma typ (expr typ func) (expr typ func) :=
  {| vars := T :: T :: nil;
     premises := App (App R (ExprCore.Var 0)) (ExprCore.Var 1) :: nil;
     concl := App (App R (App (App P U) (ExprCore.Var 0)))
                  (ExprCore.Var 1) |}.
  Definition lem_plus_assoc_p1 : Lemma.lemma typ (expr typ func) (expr typ func) :=
  {| vars := T :: T :: T :: T :: nil;
     premises := App
                   (App R
                        (App (App P (ExprCore.Var 0))
                             (App (App P (ExprCore.Var 1)) (ExprCore.Var 2))))
                   (ExprCore.Var 3) :: nil;
     concl := App
                (App R
                     (App (App P (App (App P (ExprCore.Var 0)) (ExprCore.Var 1)))
                          (ExprCore.Var 2))) (ExprCore.Var 3) |}.
  Definition lem_plus_assoc_p2 : Lemma.lemma typ (expr typ func) (expr typ func) :=
  {| vars := T :: T :: T :: T :: nil;
     premises := App
                   (App R
                        (App (App P (ExprCore.Var 1))
                             (App (App P (ExprCore.Var 0)) (ExprCore.Var 2))))
                   (ExprCore.Var 3) :: nil;
     concl := App
                (App R
                     (App (App P (App (App P (ExprCore.Var 0)) (ExprCore.Var 1)))
                          (ExprCore.Var 2))) (ExprCore.Var 3) |}.
  Definition lem_plus_comm_p : Lemma.lemma typ (expr typ func) (expr typ func) :=
  {| vars := T :: T :: T :: nil;
     premises := App
                   (App R
                        (App (App P (ExprCore.Var 0)) (ExprCore.Var 1)))
                   (ExprCore.Var 2) :: nil;
     concl := App
                (App R (App (App P (ExprCore.Var 1)) (ExprCore.Var 0)))
                (ExprCore.Var 2) |}.
End cancel_lemmas.