(* Expanding axioms in a proof net *)
(* TODO remove unused imports *)
From Coq Require Import Bool Wf_nat.
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 Yalla Require Export graph_more mll_prelim mll_def mll_basic mll_seq_to_pn mll_correct.

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 ll := (@ll 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).

(** ** The substitution in a proof net/structure of an atom by a proof net/structure
       yields a proof net/structure *)

(** Results on a proof structure with two conclusions *)
Lemma subst_ax_conc_H_neq (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  c1 <> c2.
Proof. destruct (p_order H) as [_ U]. revert U. rewrite Ho /= !in_cons. introb. Qed.

Lemma subst_ax_conc_H_c (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  vlabel (target c1) = c /\ vlabel (target c2) = c.
Proof. destruct (p_order H) as [O _]. split; apply O; rewrite /= Ho !in_cons; caseb. Qed.

Lemma subst_ax_target_conc_H_neq (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  target c1 <> target c2.
Proof.
  intros ?.
  enough (F : c1 = c2) by by apply subst_ax_conc_H_neq in F.
  apply one_target_c; trivial.
  apply (subst_ax_conc_H_c Ho).
Qed.

(* Graph where we replaced the axiom node v by the proof structure H *)
(* Lemmas to simplify the definition by keeping their proofs opaque *)
Lemma subst_ax_graph_0 (G : proof_structure) (v : G) (V : vlabel v = ax) (e : edge G) :
  source e = source (ax_formula_edge V) -> target e \in [set~ v].
Proof.
  intro E.
  rewrite !in_set -(ax_formula_edge_in V) -E.
  apply /eqP. apply nesym, no_selfloop.
Qed.

Lemma subst_ax_graph_01 (G : proof_structure) (v : G) (V : vlabel v = ax) :
  target (ax_formula_edge V) \in [set~ v].
Proof. exact (subst_ax_graph_0 erefl). Qed.
Lemma subst_ax_graph_02 (G : proof_structure) (v : G) (V : vlabel v = ax) :
  target ((other_ax (ax_formula_endpoint V))) \in [set~ v].
Proof. exact (subst_ax_graph_0 (other_ax_e (ax_formula_endpoint V))). Qed.

Lemma subst_ax_graph_1 (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  source c1 \in setT :\ target c1 :\ target c2 /\
  source c2 \in setT :\ target c1 :\ target c2.
Proof.
  rewrite !in_set. splitb; apply /eqP.
  - apply no_source_c, (subst_ax_conc_H_c Ho).
  - apply no_selfloop.
  - apply no_selfloop.
  - apply no_source_c, (subst_ax_conc_H_c Ho).
Qed.

Lemma subst_ax_graph_11 (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  source c1 \in setT :\ target c1 :\ target c2.
Proof. by destruct (subst_ax_graph_1 Ho). Qed.
Lemma subst_ax_graph_12 (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  source c2 \in setT :\ target c1 :\ target c2.
Proof. by destruct (subst_ax_graph_1 Ho). Qed.

Definition subst_ax_graph (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) : base_graph :=
  (remove_vertex v ⊎ induced (setT :\ target c1 :\ target c2))
  ∔ [inr (Sub (source c1) (subst_ax_graph_11 Ho)), elabel (ax_formula_edge V),
    inl (Sub (target (ax_formula_edge V)) (subst_ax_graph_01 V))]
  ∔ [inr (Sub (source c2) (subst_ax_graph_12 Ho)), elabel (other_ax (ax_formula_endpoint V)),
    inl (Sub (target (other_ax (ax_formula_endpoint V))) (subst_ax_graph_02 V))].

Lemma subst_ax_G_removed (G : proof_structure) (v : G) (V : vlabel v = ax) :
  edges_at v = [set ax_formula_edge V ; other_ax (ax_formula_endpoint V)].
Proof.
  apply /setP => e.
  rewrite edges_at_eq -other_ax_set.
  replace (target e == v) with false by by (symmetry; apply /eqP; apply no_target_ax).
  by rewrite !in_set orb_false_r ax_cut_formula_edge_in.
Qed.

Lemma subst_ax_H_removed (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  edge_set (setT :\ target c1 :\ target c2) = setT :\ c1 :\ c2.
Proof.
  apply /setP => e.
  rewrite !in_set !andb_true_r.
  destruct (eq_comparable e c1) as [? | Neq1];
  [ | destruct (eq_comparable e c2) as [? | Neq2]];
  try (subst e; by rewrite !eq_refl /= !andb_false_r).
  transitivity true; last by (symmetry; splitb; apply /eqP).
  destruct (subst_ax_conc_H_c Ho).
  splitb; apply /eqP.
  - by apply no_source_c.
  - by apply no_source_c.
  - intros ?. contradict Neq2. by apply one_target_c.
  - intros ?. contradict Neq1. by apply one_target_c.
Qed.

(* Inclusion of edges from G *)
Definition subst_ax_incl_EG (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  edge G -> edge (subst_ax_graph V Ho) :=
  fun e => if @boolP (e \in ~: edges_at v) is AltTrue p then Some (Some (inl (Sub e p)))
           else if e == ax_formula_edge V then Some None
           else None.

(* Last case in subst_ax_incl_EG *)
Lemma subst_ax_incl_EG_other_edge (G : proof_structure) (v : G) (V : vlabel v = ax) (e : edge G) :
  e \notin ~: edges_at v -> e <> ax_formula_edge V -> e = other_ax (ax_formula_endpoint V).
Proof.
  intros H ?.
  apply other_ax_eq. split; trivial.
  rewrite ax_formula_edge_in.
  revert H. rewrite !in_set => /negPn/existsP[[] /eqP-H] //.
  contradict H.
  by apply no_target_ax.
Qed.

Lemma subst_ax_incl_EG_SS (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2])
  (e : edge G) (E : e \in ~: edges_at v) :
  subst_ax_incl_EG V Ho e = Some (Some (inl (Sub e E))).
Proof. unfold subst_ax_incl_EG. case: {-}_ /boolP => [? | /negP-? //]. cbnb. Qed.

Lemma subst_ax_incl_EG_SN (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  subst_ax_incl_EG V Ho (ax_formula_edge V) = Some None.
Proof.
  unfold subst_ax_incl_EG.
  case: {-}_ /boolP => [In | ?]; [ | case_if].
  contradict In. apply /negP.
  rewrite subst_ax_G_removed !in_set.
  apply /negPn. caseb.
Qed.

Lemma subst_ax_incl_EG_N (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  subst_ax_incl_EG V Ho (other_ax (ax_formula_endpoint V)) = None.
Proof.
  unfold subst_ax_incl_EG.
  case: {-}_ /boolP => [In | In].
  - contradict In. apply /negP.
    rewrite subst_ax_G_removed !in_set.
    apply /negPn. caseb.
  - case_if.
    by assert (other_ax (ax_formula_endpoint V) <> ax_formula_edge V) by apply other_ax_neq.
Qed.

Lemma subst_ax_incl_EG_inj (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  injective (subst_ax_incl_EG V Ho).
Proof.
  intros e f.
  unfold subst_ax_incl_EG.
  case: {-}_ /boolP => [E | E];
  case: {-}_ /boolP => [F | F].
  { intro Eq. by inversion Eq. }
  all: case_if.
  transitivity (other_ax (ax_formula_endpoint V)); [ | symmetry];
  by apply subst_ax_incl_EG_other_edge.
Qed.

Lemma subst_ax_incl_EG_elabel (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) (e : edge G) :
  elabel (subst_ax_incl_EG V Ho e) = elabel e.
Proof.
  unfold subst_ax_incl_EG.
  case: {-}_ /boolP => [// | In].
  case_if.
  f_equal.
  symmetry. apply other_ax_eq. split; trivial.
  rewrite ax_formula_edge_in.
  revert In. rewrite !in_set => /negPn/existsP[[] /eqP-In] //.
  contradict In.
  by apply no_target_ax.
Qed.

Lemma subst_ax_incl_EG_flabel (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) (e : edge G) :
  flabel (subst_ax_incl_EG V Ho e) = flabel e.
Proof. by rewrite /flabel subst_ax_incl_EG_elabel. Qed.

Lemma subst_ax_incl_EG_llabel (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) (e : edge G) :
  llabel (subst_ax_incl_EG V Ho e) = llabel e.
Proof. by rewrite /llabel subst_ax_incl_EG_elabel. Qed.

Lemma subst_ax_incl_EG_edges_at (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2])
  (b : bool) (u : G) (U : u \in [set~ v]) :
  edges_at_outin b (inl (Sub u U) : subst_ax_graph V Ho) =
  [set subst_ax_incl_EG V Ho e | e in edges_at_outin b u].
Proof.
  apply setP => e.
  rewrite in_set.
  destruct (eq_comparable (endpoint b e) (inl (Sub u U))) as [Heq | Hneq]; symmetry.
  - rewrite Heq eq_refl.
    apply /imsetP.
    destruct e as [[[[e E] | ?] | ] | ]; try by [].
    + exists e.
      * inversion Heq. apply endpoint_in_edges_at_outin.
      * symmetry. apply subst_ax_incl_EG_SS.
    + exists (ax_formula_edge V).
      * destruct b; simpl in Heq; try by [].
        inversion Heq. apply endpoint_in_edges_at_outin.
      * symmetry. apply subst_ax_incl_EG_SN.
    + exists (other_ax (ax_formula_endpoint V)).
      * destruct b; simpl in Heq; try by [].
        inversion Heq. apply endpoint_in_edges_at_outin.
      * symmetry. apply subst_ax_incl_EG_N.
  - transitivity false; last by (symmetry; by apply /eqP).
    apply /imsetP.
    intros [f F ?]. subst e.
    revert F. rewrite in_set => /eqP-?. subst u.
    revert Hneq.
    unfold subst_ax_incl_EG.
    case: {-}_ /boolP => [In | ]; [ | case_if].
    + by move => /eqP; cbn; simpl => /eqP.
    + destruct b.
      * by replace U with (subst_ax_graph_01 V) in * by apply eq_irrelevance.
      * clear - U. contradict U. apply /negP.
        rewrite !in_set. apply /negPn/eqP.
        apply ax_formula_edge_in.
    + assert (f = other_ax (ax_formula_endpoint V)) by by apply subst_ax_incl_EG_other_edge.
      subst f.
      destruct b.
      * by replace U with (subst_ax_graph_02 V) in * by apply eq_irrelevance.
      * clear - U. contradict U. apply /negP.
        rewrite !in_set other_ax_e. apply /negPn/eqP.
        apply ax_formula_edge_in.
Qed.

(* Inclusion of edges from H *)
Definition subst_ax_incl_EH (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  edge H -> edge (subst_ax_graph V Ho) :=
  fun e => if @boolP (e \in edge_set (setT :\ target c1 :\ target c2))
    is AltTrue p then Some (Some (inr (Sub e p)))
    else if e == c1 then Some None
    else None.

(* Last case in subst_ax_incl_EH *)
Lemma subst_ax_incl_EH_other_edge (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2])
  (e : edge H) :
  e \notin edge_set (setT :\ target c1 :\ target c2) -> e <> c1 -> e = c2.
Proof. rewrite subst_ax_H_removed // !in_set. introb. Qed.

Lemma subst_ax_incl_EH_SS (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2])
  (e : edge H) (E : e \in edge_set (setT :\ target c1 :\ target c2)) :
  subst_ax_incl_EH V Ho e = Some (Some (inr (Sub e E))).
Proof. unfold subst_ax_incl_EH. case: {-}_ /boolP => [? | /negP-? //]. cbnb. Qed.

Lemma subst_ax_incl_EH_SN (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  subst_ax_incl_EH V Ho c1 = Some None.
Proof.
  unfold subst_ax_incl_EH.
  case: {-}_ /boolP => [In | ?]; [ | case_if].
  contradict In. apply /negP.
  rewrite subst_ax_H_removed // !in_set. caseb.
Qed.

Lemma subst_ax_incl_EH_N (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  subst_ax_incl_EH V Ho c2 = None.
Proof.
  unfold subst_ax_incl_EH.
  case: {-}_ /boolP => [In | In].
  - contradict In. apply /negP.
    rewrite !in_set. caseb.
  - case_if.
    by assert (c1 <> c1) by apply (subst_ax_conc_H_neq Ho).
Qed.

Lemma subst_ax_incl_EH_inj (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  injective (subst_ax_incl_EH V Ho).
Proof.
  intros e f.
  unfold subst_ax_incl_EH.
  case: {-}_ /boolP => [E | E];
  case: {-}_ /boolP => [F | F].
  { intro Eq. by inversion Eq. }
  all: case_if.
  transitivity c2; [ | symmetry];
  by apply (subst_ax_incl_EH_other_edge Ho).
Qed.

Lemma subst_ax_incl_EH_edges_at (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2])
  (b : bool) (u : H) (U : u \in (setT :\ target c1 :\ target c2)) :
  edges_at_outin b (inr (Sub u U) : subst_ax_graph V Ho) =
  [set subst_ax_incl_EH V Ho e | e in edges_at_outin b u].
Proof.
  apply setP => e.
  rewrite in_set.
  destruct (eq_comparable (endpoint b e) (inr (Sub u U))) as [Heq | Hneq]; symmetry.
  - rewrite Heq eq_refl.
    apply /imsetP.
    destruct e as [[[? | [e E]] | ] | ]; try by [].
    + exists e.
      * inversion Heq. apply endpoint_in_edges_at_outin.
      * symmetry. apply subst_ax_incl_EH_SS.
    + exists c1.
      * destruct b; simpl in Heq; try by [].
        inversion Heq. apply endpoint_in_edges_at_outin.
      * symmetry. apply subst_ax_incl_EH_SN.
    + exists c2.
      * destruct b; simpl in Heq; try by [].
        inversion Heq. apply endpoint_in_edges_at_outin.
      * symmetry. apply subst_ax_incl_EH_N.
  - transitivity false; last by (symmetry; by apply /eqP).
    apply /imsetP.
    intros [f F ?]. subst e.
    revert F. rewrite in_set => /eqP-?. subst u.
    revert Hneq.
    unfold subst_ax_incl_EH.
    case: {-}_ /boolP => [In | ]; [ | case_if].
    + by move => /eqP; cbn; simpl => /eqP.
    + destruct b.
      * clear - U. contradict U. apply /negP.
        rewrite !in_set. caseb.
      * by replace U with (subst_ax_graph_11 Ho) in * by apply eq_irrelevance.
    + assert (f = c2) by by apply (subst_ax_incl_EH_other_edge Ho).
      subst f.
      destruct b.
      * clear - U. contradict U. apply /negP.
        rewrite !in_set. caseb.
      * by replace U with (subst_ax_graph_12 Ho) in * by apply eq_irrelevance.
Qed.

Lemma subst_ax_incl_EH_flabel (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) (e : edge H) :
  flabel c1 = flabel (ax_formula_edge V) ->
  flabel c2 = (flabel (ax_formula_edge V))^ ->
  flabel (subst_ax_incl_EH V Ho e) = flabel e.
Proof.
  intros F1 F2.
  unfold subst_ax_incl_EH.
  case: {-}_ /boolP => [// | In].
  case_if.
  assert (e = c2) as -> by by apply (subst_ax_incl_EH_other_edge Ho).
  enough (F : flabel (other_ax (ax_formula_endpoint V)) = (flabel (ax_formula_edge V))^)
    by by revert F; unfold flabel => ->.
  apply other_ax_flabel.
Qed.

Lemma subst_ax_incl_EH_llabel (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) (e : edge H) :
  target e \in setT :\ target c1 :\ target c2 ->
  llabel (subst_ax_incl_EH V Ho e) = llabel e.
Proof.
  intro E.
  unfold subst_ax_incl_EH.
  case: {-}_ /boolP => [// | In].
  contradict In. apply /negP/negPn.
  rewrite in_set E !in_set. splitb; apply /eqP.
  all: apply no_source_c, (subst_ax_conc_H_c Ho).
Qed.

(* TODO Pour H et G : gros copié collé, comment factoriser ça ? fonction incl avec i : bool en param ? *)

(** Graph data of an expanded axiom *)
Definition subst_ax_graph_data (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) : graph_data := {|
  graph_of := _;
  order := [seq subst_ax_incl_EG V Ho e | e <- order G];
  |}.

(** Proof structure of an expanded axiom *)
Lemma subst_ax_p_deg (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  proper_degree (subst_ax_graph V Ho).
Proof.
  unfold proper_degree.
  intros b [[u U] | [u U]].
  - rewrite -(p_deg b u) subst_ax_incl_EG_edges_at.
    apply card_imset, subst_ax_incl_EG_inj.
  - rewrite -(p_deg b u) subst_ax_incl_EH_edges_at.
    apply card_imset, subst_ax_incl_EH_inj.
Qed.

Lemma subst_ax_p_ax_cut (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  flabel c1 = flabel (ax_formula_edge V) ->
  flabel c2 = (flabel (ax_formula_edge V))^ ->
  proper_ax_cut (subst_ax_graph V Ho).
Proof.
  intros.
  unfold proper_ax_cut.
  move => b [[u U] | [u U]] /= Hl.
  - destruct (p_ax_cut Hl) as [l [r [L [R LR]]]].
    exists (subst_ax_incl_EG V Ho l), (subst_ax_incl_EG V Ho r).
    rewrite !subst_ax_incl_EG_edges_at !subst_ax_incl_EG_flabel.
    splitb; by apply imset_f.
  - destruct (p_ax_cut Hl) as [l [r [L [R LR]]]].
    exists (subst_ax_incl_EH V Ho l), (subst_ax_incl_EH V Ho r).
    rewrite !subst_ax_incl_EH_edges_at !subst_ax_incl_EH_flabel //.
    splitb; by apply imset_f.
Qed.

Lemma subst_ax_p_tens_parr (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  flabel c1 = flabel (ax_formula_edge V) ->
  flabel c2 = (flabel (ax_formula_edge V))^ ->
  proper_tens_parr (subst_ax_graph V Ho).
Proof.
  intros F1 F2.
  unfold proper_tens_parr.
  move => b [[u U] | [u U]] /= Hl.
  - destruct (p_tens_parr Hl) as [l [r [c [? [? [? [? [? ?]]]]]]]].
    exists (subst_ax_incl_EG V Ho l), (subst_ax_incl_EG V Ho r), (subst_ax_incl_EG V Ho c).
    rewrite !subst_ax_incl_EG_edges_at !subst_ax_incl_EG_flabel !subst_ax_incl_EG_llabel.
    splitb; by apply imset_f.
  - destruct (p_tens_parr Hl) as [l [r [c [L [? [R [? [? ?]]]]]]]].
    exists (subst_ax_incl_EH V Ho l), (subst_ax_incl_EH V Ho r), (subst_ax_incl_EH V Ho c).
    rewrite !subst_ax_incl_EH_edges_at !subst_ax_incl_EH_flabel //.
    splitb; try by apply imset_f.
    all: rewrite subst_ax_incl_EH_llabel //.
    + by revert L; rewrite in_set => /eqP-->.
    + by revert R; rewrite in_set => /eqP-->.
Qed.

Lemma subst_ax_p_noleft (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  proper_noleft (subst_ax_graph V Ho).
Proof.
  intros [[[? | ?] | ] | ].
  - apply p_noleft.
  - apply p_noleft.
  - rewrite /= -subst_ax_incl_EG_SN subst_ax_incl_EG_llabel.
    apply p_noleft.
  - rewrite /= -subst_ax_incl_EG_N subst_ax_incl_EG_llabel.
    apply p_noleft.
Qed.

Lemma subst_ax_p_order (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  proper_order (subst_ax_graph_data V Ho).
Proof.
  unfold proper_order. simpl order. split.
  - intros [[[[e E] | [e E]] | ] | ]; simpl.
    + rewrite -(subst_ax_incl_EG_SS V Ho) mem_map; last by apply subst_ax_incl_EG_inj.
      apply p_order.
    + assert (forall i, Some (Some (inr i)) \in [seq subst_ax_incl_EG V Ho u | u <- order G] = false)
        as ->.
      { intros ?.
        apply /negP => /mapP[? _].
        unfold subst_ax_incl_EG.
        case: {-}_ /boolP; case_if. }
      split => C //.
      apply p_order in C.
      contradict E. apply /negP.
      revert C.
      rewrite Ho /= !in_cons in_nil !in_set.
      introb; caseb.
    + rewrite -subst_ax_incl_EG_SN mem_map; last by apply subst_ax_incl_EG_inj.
      apply p_order.
    + rewrite -subst_ax_incl_EG_N mem_map; last by apply subst_ax_incl_EG_inj.
      apply p_order.
  - rewrite map_inj_uniq; last by apply subst_ax_incl_EG_inj.
    apply p_order.
Qed.

Definition subst_ax_ps (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2])
  (F1 : flabel c1 = flabel (ax_formula_edge V))
  (F2 : flabel c2 = (flabel (ax_formula_edge V))^) : proof_structure := {|
  graph_data_of := subst_ax_graph_data V Ho;
  p_deg := @subst_ax_p_deg _ _ _ _ _ _ _;
  p_ax_cut := @subst_ax_p_ax_cut _ _ _ _ _ _ _ F1 F2;
  p_tens_parr := @subst_ax_p_tens_parr _ _ _ _ _ _ _ F1 F2;
  p_noleft := @subst_ax_p_noleft _ _ _ _ _ _ _;
  p_order := subst_ax_p_order _ _;
  |}.

Fixpoint subst_ax_upath_bwd_G (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2])
  (p : @upath _ _ (subst_ax_graph V Ho)) : @upath _ _ G :=
  match p with
  | [::] => [::]
  | (e, b) :: p' => match e with
    | Some (Some (inl (exist e' _))) => [:: (e', b)]
    | Some (Some (inr _)) => [::]
    | Some None => [:: (ax_formula_edge V, b)]
    | None => [:: (other_ax (ax_formula_endpoint V), b)]
  end ++ subst_ax_upath_bwd_G p'
end.

(* méthode : si cycle c dans graph,
alors expanse_ax_upath_bwd c cycle dans G;
si expanse_ax_upath_bwd p vide, alors p inclut dans expanded_ax (ie p = Some Some inr p'
et p' chem entre antécédents)
donc si cycle c, alors cycle c' dans expanded, absurde *)

Definition subst_ax_u_G (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2])
  (u : subst_ax_graph V Ho) : G :=
  match u with
  | inl (exist u _) => u
  | _ => v
  end.

Lemma subst_ax_switching_eq (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2])
  (e f : edge G) :
  switching e = switching f ->
  switching (subst_ax_incl_EG V Ho e) = switching (subst_ax_incl_EG V Ho f).
Proof.
  move => /eqP.
  unfold subst_ax_incl_EG.
  case: {-}_ /boolP => [E | E];
  case: {-}_ /boolP => [F | F];
  unfold switching; case_if; cbnb; simpl in *.
  all: try ((assert (f = other_ax (ax_formula_endpoint V)) by by apply subst_ax_incl_EG_other_edge);
    subst f); try by [].
  all: try ((assert (e = other_ax (ax_formula_endpoint V)) by by apply subst_ax_incl_EG_other_edge);
    subst e); try by [].
  all: try by assert (~ eqb_rule (vlabel (target (ax_formula_edge V))) (⅋)) by by apply /negP.
  all: try by assert (~ eqb_rule (vlabel (target (other_ax (ax_formula_endpoint V)))) (⅋)) by by apply /negP.
  all: try by contradict E; apply /negP.
  all: try by contradict F; apply /negP.
Qed.
(* TODO 100 cas, long *)

Lemma subst_ax_image_in (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2])
  (p : upath) (e : edge G) (b : bool) :
  (e, b) \in subst_ax_upath_bwd_G p -> (subst_ax_incl_EG V Ho e, b) \in p.
Proof.
  revert e b. induction p as [ | (f, fb) p IH] => e eb //=.
  rewrite in_cons mem_cat.
  move => /orP[In | ?]; apply /orP; [left | right; by apply IH].
  destruct f as [[[[f F] | f] | ] | ].
  all: revert In; rewrite ?in_cons in_nil ?orb_false_r => /eqP-In //.
  all: inversion In; clear In; subst e eb.
  - by rewrite subst_ax_incl_EG_SS.
  - by rewrite subst_ax_incl_EG_SN.
  - by rewrite subst_ax_incl_EG_N.
Qed.

Lemma subst_ax_switching_notin (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2])
  (p : upath) (e : edge G) :
  switching (subst_ax_incl_EG V Ho e) \notin [seq switching f.1 | f <- p] ->
  switching e \notin [seq switching f.1 | f <- subst_ax_upath_bwd_G p].
Proof.
  intro Nin.
  apply /mapP.
  intros [(f, b) F EF].
  contradict Nin. apply /negP/negPn/mapP.
  exists (subst_ax_incl_EG V Ho f, b).
  - by apply subst_ax_image_in.
  - by apply subst_ax_switching_eq.
Qed.

Lemma subst_ax_switching_eq_SSR (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2])
  (e f : edge H)
  (E : e \in edge_set (setT :\ target c1 :\ target c2))
  (F : f \in edge_set (setT :\ target c1 :\ target c2)) :
  switching e = switching f ->
  switching (Some (Some (inr (Sub e E))) : edge (subst_ax_graph V Ho)) =
    switching (Some (Some (inr (Sub f F))) : edge (subst_ax_graph V Ho)).
Proof. move => /eqP. unfold switching; case_if; cbnb. Qed.

Lemma subst_ax_supath_bwd (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2])
  (p : upath) (s t : subst_ax_graph V Ho) :
  supath switching s t p ->
  supath switching (subst_ax_u_G s) (subst_ax_u_G t) (subst_ax_upath_bwd_G p).
Proof.
  revert s t. induction p as [ | (e, b) p IH] => s t.
  { move => /andP[/andP[/eqP-? _] _]. subst. apply supath_nilK. }
  rewrite /supath /= !in_cons !map_cat cat_uniq mem_cat !negb_orb.
  move => /andP[/andP[/andP[/eqP-? W] /andP[u U]] /andP[/eqP-n N]]. subst s.
  assert (P : supath switching (endpoint b e) t p) by splitb.
  revert IH => /(_ _ _ P) {W U N P} /andP[/andP[W2 ->] ->]. splitb.
  - eapply (uwalk_cat _ W2). Unshelve.
    destruct e as [[[[e E] | e] | ] | ], b; simpl; splitb;
    by rewrite ?other_ax_e ax_formula_edge_in.
  - by destruct e as [[[[e E] | e] | ] | ].
  - destruct e as [[[[e E] | e] | ] | ];
    rewrite has_sym //= orb_false_r;
    apply subst_ax_switching_notin.
    + by rewrite subst_ax_incl_EG_SS.
    + by rewrite subst_ax_incl_EG_SN.
    + by rewrite subst_ax_incl_EG_N.
  - by destruct e as [[[[? ?] | ?] | ] | ].
Qed.

Lemma subst_ax_upath_bwd_empty (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2])
  (p : @upath _ _ (subst_ax_graph V Ho)) :
  subst_ax_upath_bwd_G p = [::] ->
  {p' | p = [seq (Some (Some (inr e.1)), e.2) | e <- p']}.
Proof.
  induction p as [ | (e, b) p IH].
  { intros _. by exists [::]. }
  move => /= /eqP. rewrite cat_nil => /andP[/eqP-E /eqP-P].
  destruct (IH P) as [p' ?]. subst p. clear IH P.
  destruct e as [[[[? ?] | e] | ] | ]; try by []. clear E.
  by exists ((e, b) :: p').
Qed.

Definition subst_ax_upath_bwd_empty' (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2])
  (p : @upath _ _ (subst_ax_graph V Ho)) (P : subst_ax_upath_bwd_G p = [::]) : upath :=
  [seq (val e.1,e.2) | e <- projT1 (subst_ax_upath_bwd_empty P)].

Lemma subst_ax_supath_bwd_empty (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2])
  (p : upath) (P : subst_ax_upath_bwd_G p = [::]) (s t : subst_ax_graph V Ho) :
  supath switching s t p -> p <> [::] ->
  { '(s', t') | s = inr s' /\ t = inr t' /\ supath switching (val s') (val t') (subst_ax_upath_bwd_empty' P)}.
Proof.
  unfold subst_ax_upath_bwd_empty'.
  destruct (subst_ax_upath_bwd_empty P) as [p' ?]. clear P. subst p. simpl.
  destruct s as [s | s].
  { by destruct p'. }
  destruct t as [t | t].
  { move => /andP[/andP[W _] _]. contradict W.
    case/lastP: p' => [// | ? ?]. by rewrite map_rcons uwalk_rcons => /andP[_ ?]. }
  intros P' _.
  exists (s, t). split; [ | split]; trivial.
  revert s t P'. induction p' as [ | ([e E], b) p' IH] => // [[s S] t].
  rewrite /supath /= in_cons SubK'. cbn. rewrite SubK => /andP[/andP[/andP[/eqP-? ?] /andP[u' ?]] ?].
  subst s.
  assert (P' : supath switching (inr (Sub (endpoint b e) (induced_proof b E)) : subst_ax_graph V Ho)
    (inr t) [seq (Some (Some (inr e.1)), e.2) | e <- p']) by splitb.
  revert IH => /(_ _ _ P') {P'} /andP[/andP[-> ->] ->].
  clear - u'. splitb.
  rewrite -map_comp {b}.
  apply /negP. move => /mapP[f Fin EF].
  contradict u'. apply /negP/negPn.
  rewrite -map_comp. apply /mapP.
  exists f; trivial.
  revert EF. simpl.
  destruct f as ([f F], bf).
  apply subst_ax_switching_eq_SSR.
Qed.

Lemma subst_ax_uacyclic (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  uacyclic (@switching _ G) -> uacyclic (@switching _ H) ->
  uacyclic (@switching _ (subst_ax_graph V Ho)).
Proof.
  move => AG AH u [p P]. cbnb. apply /eqP/negPn/negP => /eqP-?.
  revert AG => /(_ _ {| upval := _ ; upvalK := subst_ax_supath_bwd P |}) /eqP. cbn =>/eqP-AG.
  destruct (subst_ax_supath_bwd_empty AG P) as [[s' t'] [S [T P']]]; first by by [].
  subst u. inversion T. clear T. subst t'.
  unfold subst_ax_upath_bwd_empty' in P'.
  destruct (subst_ax_upath_bwd_empty AG) as [p' ?]. subst p. simpl in P'.
  revert AH => /(_ _ {| upval := _ ; upvalK := P' |}) /eqP. cbn => /eqP/eqP.
  rewrite map_nil => /eqP-?. by subst p'.
Qed.

Lemma subst_ax_nb_vertices (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  #|G| + #|H| = #|subst_ax_graph V Ho| + 3.
Proof.
  rewrite /subst_ax_graph /= card_sum card_set_subset card_set_subset !setE cardsC1.
  rewrite -(cardsE H) (cardsD1 (target c1)) (cardsD1 (target c2)) cardsE.
  rewrite !in_set /=.
  replace (target c2 != target c1) with true
    by (symmetry; apply /eqP; apply nesym, (subst_ax_target_conc_H_neq Ho)).
  assert (#|G| <> 0) by by apply fintype0.
  simpl in *. lia.
Qed.

Lemma subst_ax_nb_edges (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  #|edge G| + #|edge H| = #|edge (subst_ax_graph V Ho)| + 2.
Proof.
  rewrite /= !card_option card_sum /= subst_ax_G_removed subst_ax_H_removed // !card_set_subset
    !setE setC2.
  rewrite -cardsT (cardsD1 (ax_formula_edge V)) (cardsD1 (other_ax (ax_formula_endpoint V))).
  rewrite -cardsT (cardsD1 c1) (cardsD1 c2).
  rewrite !in_set /=.
  replace (other_ax (ax_formula_endpoint V) != ax_formula_edge V) with true
    by by (symmetry; apply /eqP; apply other_ax_neq).
  replace (c2 != c1) with true
    by by (symmetry; apply /eqP; apply nesym, subst_ax_conc_H_neq).
  lia.
Qed.

Lemma subst_ax_nb_parr (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  #|[set u : G | vlabel u == ⅋]| + #|[set u : H | vlabel u == ⅋]| = #|[set u : subst_ax_graph V Ho | vlabel u == ⅋]|.
Proof.
  rewrite cards_sum_pred. f_equal.
  - by rewrite (cards_subgraph_pred _ (fun x => vlabel x == ⅋)) set1CI (cardsD1 v) in_set V.
  - rewrite (cards_subgraph_pred (@induced_proof _ _ _ _) (fun x => vlabel x == ⅋)) !setIDA setIT.
    rewrite (cardsD1 (target c1)) (cardsD1 (target c2)) !in_set.
    destruct (subst_ax_conc_H_c Ho) as [-> ->].
    replace (target c2 != target c1) with true
      by (symmetry; apply /eqP; apply nesym, (subst_ax_target_conc_H_neq Ho)).
    simpl. lia.
Qed.

Lemma subst_ax_uconnected_nb (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  flabel c1 = flabel (ax_formula_edge V) ->
  flabel c2 = (flabel (ax_formula_edge V))^ ->
  uacyclic (@switching _ G) -> uacyclic (@switching _ H) ->
  uconnected_nb (@switching_left _ (subst_ax_graph V Ho)) + 1 =
  uconnected_nb (@switching_left _ G) + uconnected_nb (@switching_left _ H).
Proof.
  move => F1 F2 AG AH.
  assert (NG := switching_left_uconnected_nb AG).
  assert (NH := switching_left_uconnected_nb AH).
  assert (N := @switching_left_uconnected_nb atom (subst_ax_ps Ho F1 F2) (subst_ax_uacyclic AG AH)).
  assert (X0 := subst_ax_nb_vertices V Ho).
  assert (X1 := subst_ax_nb_edges V Ho).
  assert (X2 := subst_ax_nb_parr V Ho).
  simpl in *. lia.
Qed.

Lemma subst_ax_correct (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  flabel c1 = flabel (ax_formula_edge V) ->
  flabel c2 = (flabel (ax_formula_edge V))^ ->
  correct G -> correct H -> correct (subst_ax_graph V Ho).
Proof.
  intros F1 F2 [AG CG] [AH CH]. split.
  - by apply subst_ax_uacyclic.
  - assert (N := subst_ax_uconnected_nb Ho F1 F2 AG AH). lia.
Qed.

Definition subst_ax_pn (G : proof_net)(v : G) (V : vlabel v = ax)
  (H : proof_net) (c1 c2 : edge H) (Ho : order H = [:: c1; c2])
  (F1 : flabel c1 = flabel (ax_formula_edge V))
  (F2 : flabel c2 = (flabel (ax_formula_edge V))^) : proof_net := {|
  ps_of := subst_ax_ps Ho F1 F2;
  p_correct := subst_ax_correct Ho F1 F2 (p_correct G) (p_correct H);
  |}.

(** Sequent of an expanded axiom *)
Lemma subst_ax_sequent (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (c1 c2 : edge H) (Ho : order H = [:: c1; c2]) :
  sequent (subst_ax_graph_data V Ho) = sequent G.
Proof.
  rewrite /sequent -map_comp.
  apply eq_map => e.
  by rewrite /= subst_ax_incl_EG_flabel.
Qed.

Lemma subst_ax_proofs (H : graph_data) (A B : formula) :
  sequent H = [:: A ; B] ->
  {'(c1, c2) | order H = [:: c1; c2] /\ flabel c1 = A /\ flabel c2 = B}.
Proof.
  unfold sequent.
  destruct (order H) as [ | c1 [ | c2 [ | ? ?]]];
  cbn; rewrite ?andb_false_r //.
  intro Ho. inversion Ho.
  by exists (c1, c2).
Qed.

Definition subst_ax_ps_seq (G : proof_structure) (v : G) (V : vlabel v = ax)
  (H : proof_structure) (Hs : sequent H = [:: flabel (ax_formula_edge V) ; (flabel (ax_formula_edge V))^]) :
  proof_structure.
Proof. destruct (subst_ax_proofs Hs) as [(c1, c2) [Ho [F1 F2]]]. exact (subst_ax_ps Ho F1 F2). Defined.

(** ** Graph of an expanded axiom - all steps at once *)
Lemma ax_expanded_all_0 (G : proof_structure) (v : G) (V : vlabel v = ax) (A B : formula) :
  ax_formula V = A ⊗ B ->
  sequent (pn (ax_exp (B^ ⅋ A^))) = [:: flabel (ax_formula_edge V) ; (flabel (ax_formula_edge V))^].
Proof. by rewrite ps_consistent /= !bidual /ax_formula => ->. Qed.

Definition ax_expanded_all (G : proof_structure) (v : G) (V : vlabel v = ax) (A B : formula) (F : ax_formula V = A ⊗ B) :
  proof_structure := subst_ax_ps_seq (ax_expanded_all_0 F).

(** ** Graph of an expanded axiom - one step *)
Definition Permutation_Type_2_def {A : Type} (a b : A) : Permutation_Type [:: a; b] [:: b; a] :=
  Permutation_Type_swap b a [::].

Definition Permutation_Type_3_def {A : Type} (a b c : A) : Permutation_Type [:: a; b; c] [:: b; c; a].
Proof.
  etransitivity. apply Permutation_Type_swap.
  apply Permutation_Type_skip, Permutation_Type_swap.
Defined.

Lemma expanded_ax_step0 (A B : formula) :
  exists e0 l0 e1 l1,
  order (ax_pn (A^)) = e0 :: l0 /\ order (ax_pn (B^)) = e1 :: l1.
Proof. simpl. by exists ord0, [:: ord1], ord0, [:: ord1]. Qed.

(** * Graph of two axioms A B linked by a tensor A ⊗ B *)
Definition ax_expanded_tens (A B : formula) : proof_net :=
  add_node_pn_tens (expanded_ax_step0 A B).
Lemma ax_expanded_tens_sequent (A B : formula) :
  sequent (ax_expanded_tens A B) = [:: A ⊗ B; B^; A^].
Proof. rewrite (@add_node_sequent atom). cbn. by rewrite !bidual. Qed.

Definition ax_expanded_tens_perm (A B : formula) :=
  perm_pn (Permutation_Type_3_def (A ⊗ B) (B^) (A^)) (ax_expanded_tens A B).
Lemma ax_expanded_tens_perm_sequent (A B : formula) :
  sequent (ax_expanded_tens_perm A B) = [:: B^; A^; A ⊗ B].
Proof. apply perm_sequent, ax_expanded_tens_sequent. Qed.

Lemma expanded_ax_step1' (A B : formula) :
  { '(e0, e1, e2) | order (ax_expanded_tens_perm A B) = [:: e0; e1; e2]
  /\ val e0 = Some (Some (inl (inr ord1))) /\ val e1 = Some (Some (inl (inl ord1)))
  /\ val e2 = Some (Some (inr None))}.
Proof.
  rewrite /= /add_node_order.
  destruct (all_sigP _) as [l L].
  assert (Hr : sval (exist (fun _ => _) l L) = l) by cbnb. (* TODO ce lemme doit exister *)
  rewrite Hr {Hr}.
  revert L. rewrite /add_node_order_2 /add_node_type_order /add_node_order_1 /=.
  destruct l as [ | [l0 L0] [ | [l1 L1] [ | [l2 L2] [ | ? ?]]]]; try by []; simpl.
  intro L. inversion L. subst.
  by exists ((Sub _ L1), (Sub _ L2), (Sub _ L0)).
Qed.

Lemma expanded_ax_step1 (A B : formula) :
  exists e0 e1 l, order (ax_expanded_tens_perm A B) = [:: e0, e1 & l].
Proof.
  destruct (expanded_ax_step1' A B) as [[[e0 e1] e2] [? _]].
  by exists e0, e1, [:: e2].
Qed.

Definition ax_expanded (A B : formula) := perm_pn
  (Permutation_Type_2_def (B^ ⅋ A^) (A ⊗ B)) (add_node_pn_parr (expanded_ax_step1 A B)).
Lemma ax_expanded_sequent (A B : formula) :
  sequent (ax_expanded A B) = [:: A ⊗ B; B^ ⅋ A^].
Proof.
  rewrite perm_sequent // add_node_sequent.
  destruct (expanded_ax_step1' A B) as [[[[? ?] [? ?]] [? ?]] [O [? [? ?]]]].
  rewrite !O {O} ax_expanded_tens_perm_sequent. simpl in *. by subst.
Qed.

Lemma ax_expanded_one_0 (G : proof_structure) (v : G) (V : vlabel v = ax) (A B : formula) :
  ax_formula V = A ⊗ B ->
  sequent (ax_expanded A B) = [:: flabel (ax_formula_edge V) ; (flabel (ax_formula_edge V))^].
Proof. by rewrite ax_expanded_sequent /ax_formula => ->. Qed.

Definition ax_expanded_one (G : proof_structure) (v : G) (V : vlabel v = ax) (A B : formula) (F : ax_formula V = A ⊗ B) :
  proof_structure := subst_ax_ps_seq (ax_expanded_one_0 F).

(* TODO définir transformation rendant un réseau ax_atomic : par induction
sur ax_formula *)

(** Rewriting to expanse axioms *)
Definition is_atomicb (A : formula) :=
  if A is var _ then true else false.

Definition is_ax_atomic (G : proof_structure) (v : G) :=
  if @boolP (vlabel v == ax) is AltTrue V then is_atomicb (ax_formula (eqP V))
  else true.

Lemma expanse_term (G : proof_structure) :
  {ax_atomic G} + {exists v : G, ~~ is_ax_atomic v}.
Proof.
  destruct [exists v : G, ~~ is_ax_atomic v] eqn:H.
  { right. apply /existsP. exact H. }
  left.
  intros v V.
  revert H => /existsPn/(_ v)/negPn.
  unfold is_ax_atomic.
  case: {-}_ /boolP => [H | H].
  2:{ contradict H. by apply /negP/negPn/eqP. }
  replace (eqP H) with V by apply eq_irrelevance. clear H.
  unfold is_atomic, is_atomicb.
  by destruct (ax_formula V) eqn:F.
Qed.

(* TODO define the quantity which decrease: sum of the size of formulas on axioms ? *)
(* Show it decrease when expanding *)(*
Lemma expanse_one_nb (G : proof_structure) (v : G) (V : vlabel v = ax) (A B : formula)
  (VAB : flabel (ax_formula_edge V) = A ⊗ B) :
  #|expanse_ax_ps VAB| < #|G|.
Proof. (* TODO with good measure *)
Admitted.*)

(** All steps *)(*
Lemma expanse_all (G : proof_structure) :
  {P : proof_structure | correct G -> correct P & sequent P = sequent G /\ ax_atomic P}.
(* TODO these properties are sufficient? *)
Proof.
  revert G.
  enough (Hm : forall n (G : proof_structure), #|G| = n ->
    {P : proof_structure | correct G -> correct P & sequent P = sequent G /\ ax_atomic P})
    by (intro G; by apply (Hm #|G|)).
  intro n; induction n as [n IH] using lt_wf_rect; intros G Hc.
  have [/has_cutP/existsP/sigW[v /eqP-Hcut] | /has_cutP-?] := altP (has_cutP G).
  2:{ by exists G. }
  assert (N : (#|red_one_ps Hcut| < n)%coq_nat) by (rewrite -Hc; apply /leP; apply red_one_nb).
  specialize (IH _ N _ erefl). destruct IH as [P CC [S C]].
  exists P; [ | split; trivial].
  - move => ?. by apply CC, red_one_correct.
  - rewrite S. apply red_one_sequent.
Qed.

Definition red (G : proof_structure) : proof_structure := proj1_sig (red_all G).

Lemma red_correct (G : proof_structure) : correct G -> correct (red G).
Proof. by destruct (proj2_sig (red_all G)) as [? _]. Qed.

Definition red_pn (G : proof_net) : proof_net := {|
  ps_of := red G;
  p_correct := red_correct (p_correct G);
  |}.

Lemma red_sequent (G : proof_structure) : sequent (red G) = sequent G.
Proof. by destruct (proj2_sig (red_all G)) as [_ [? _]]. Qed.

Lemma red_has_cut (G : proof_structure) : ~ has_cut (red G).
Proof. by destruct (proj2_sig (red_all G)) as [_ [_ ?]]. Qed.

(* TODO et definir une etape, puis repetition, idem cut *)
*)
End Atoms.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition table_map1_spec0 (g_rd: Pointer) (map_addr: Z64) (level: Z64) (adt: RData) : option (RData * Z64) :=
    match g_rd, map_addr, level with
    | (_g_rd_base, _g_rd_ofst), VZ64 _map_addr, VZ64 _level =>
      rely is_int64 _map_addr;
      rely is_int64 _level;
      when' _t'1, adt == table_map_spec (_g_rd_base, _g_rd_ofst) (VZ64 _map_addr) (VZ64 _level) adt;
      rely is_int64 _t'1;
      Some (adt, (VZ64 _t'1))
     end
    .

End SpecLow.


(****************************************************************************)
(*                                                                          *)
(*                                   Menhir                                 *)
(*                                                                          *)
(*           Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud         *)
(*                                                                          *)
(*  Copyright Inria. All rights reserved. This file is distributed under    *)
(*  the terms of the GNU Lesser General Public License as published by the  *)
(*  Free Software Foundation, either version 3 of the License, or (at your  *)
(*  option) any later version, as described in the file LICENSE.            *)
(*                                                                          *)
(****************************************************************************)

From Coq Require Import List Syntax Derive.
From Coq.ssr Require Import ssreflect.
Import ListNotations.
Require Automaton.
Require Import Alphabet Validator_classes.

Module Make(Import A:Automaton.T).

(** We instantiate some sets/map. **)
Module TerminalComparableM <: ComparableM.
  Definition t := terminal.
  Instance tComparable : Comparable t := _.
End TerminalComparableM.
Module TerminalOrderedType := OrderedType_from_ComparableM TerminalComparableM.
Module StateProdPosComparableM <: ComparableM.
  Definition t := (state*production*nat)%type.
  Instance tComparable : Comparable t := _.
End StateProdPosComparableM.
Module StateProdPosOrderedType :=
  OrderedType_from_ComparableM StateProdPosComparableM.

Module TerminalSet := FSetAVL.Make TerminalOrderedType.
Module StateProdPosMap := FMapAVL.Make StateProdPosOrderedType.

(** Nullable predicate for symbols and list of symbols. **)
Definition nullable_symb (symbol:symbol) :=
  match symbol with
  | NT nt => nullable_nterm nt
  | _ => false
  end.

Definition nullable_word (word:list symbol) :=
  forallb nullable_symb word.

(** First predicate for non terminal, symbols and list of symbols, given as FSets. **)
Definition first_nterm_set (nterm:nonterminal) :=
  fold_left (fun acc t => TerminalSet.add t acc)
    (first_nterm nterm) TerminalSet.empty.

Definition first_symb_set (symbol:symbol) :=
  match symbol with
  | NT nt => first_nterm_set nt
  | T t => TerminalSet.singleton t
  end.

Fixpoint first_word_set (word:list symbol) :=
  match word with
  | [] => TerminalSet.empty
  | t::q =>
    if nullable_symb t then
      TerminalSet.union (first_symb_set t) (first_word_set q)
    else
      first_symb_set t
  end.

(** Small helper for finding the part of an item that is after the dot. **)
Definition future_of_prod prod dot_pos : list symbol :=
  (fix loop n lst :=
    match n with
    | O => lst
    | S x => match loop x lst with [] => [] | _::q => q end
    end)
  dot_pos (rev' (prod_rhs_rev prod)).

(** We build a fast map to store all the items of all the states. **)
Definition items_map (_:unit): StateProdPosMap.t TerminalSet.t :=
  fold_left (fun acc state =>
    fold_left (fun acc item =>
      let key := (state, prod_item item, dot_pos_item item) in
        let data := fold_left (fun acc t => TerminalSet.add t acc)
          (lookaheads_item item) TerminalSet.empty
        in
        let old :=
          match StateProdPosMap.find key acc with
          | Some x => x | None => TerminalSet.empty
          end
        in
        StateProdPosMap.add key (TerminalSet.union data old) acc
    ) (items_of_state state) acc
  ) all_list (StateProdPosMap.empty TerminalSet.t).

(** We need to avoid computing items_map each time we need it. To that
  purpose, we declare a typeclass specifying that some map is equal to
  items_map. *)
Class IsItemsMap m := is_items_map : m = items_map ().

(** Accessor. **)
Definition find_items_map items_map state prod dot_pos : TerminalSet.t :=
  match StateProdPosMap.find (state, prod, dot_pos) items_map with
  | None => TerminalSet.empty
  | Some x => x
  end.

Definition state_has_future state prod (fut:list symbol) (lookahead:terminal) :=
  exists dot_pos:nat,
    fut = future_of_prod prod dot_pos /\
    TerminalSet.In lookahead (find_items_map (items_map ()) state prod dot_pos).

(** Iterator over items. **)
Definition forallb_items items_map (P:state -> production -> nat -> TerminalSet.t -> bool): bool:=
  StateProdPosMap.fold (fun key set acc =>
    match key with (st, p, pos) => (acc && P st p pos set)%bool end
  ) items_map true.

(** Typeclass instances for synthetizing the validator. *)

Instance is_validator_subset S1 S2 :
  IsValidator (TerminalSet.Subset S1 S2) (TerminalSet.subset S1 S2).
Proof. intros ?. by apply TerminalSet.subset_2. Qed.

(* While the specification of the validator always quantify over
   possible lookahead tokens individually, the validator usually
   handles lookahead sets directly instead, for better performances.

   For instance, the validator for [state_has_future], which speaks
   about one single lookahead token is a subset operation:
*)
Lemma is_validator_state_has_future_subset st prod pos lookahead lset im fut :
  TerminalSet.In lookahead lset ->
  fut = future_of_prod prod pos ->
  IsItemsMap im ->
  IsValidator (state_has_future st prod fut lookahead)
              (TerminalSet.subset lset (find_items_map im st prod pos)).
Proof.
  intros ? -> -> HSS%TerminalSet.subset_2. exists pos. split=>//. by apply HSS.
Qed.
(* We do not declare this lemma as an instance, and use [Hint Extern]
   instead, because the typeclass mechanism has trouble instantiating
   some evars if we do not explicitely call [eassumption]. *)
Hint Extern 2 (IsValidator (state_has_future _ _ _ _) _) =>
  eapply is_validator_state_has_future_subset; [eassumption|eassumption || reflexivity|]
: typeclass_instances.

(* As said previously, we manipulate lookahead terminal sets instead of
  lookahead individually. Hence, when we quantify over a lookahead set
  in the specification, we do not do anything in the executable
  validator.

  This instance is used for [non_terminal_closed]. *)
Instance is_validator_forall_lookahead_set lset P b:
  (forall lookahead, TerminalSet.In lookahead lset -> IsValidator (P lookahead) b) ->
  IsValidator (forall lookahead, TerminalSet.In lookahead lset -> P lookahead) b.
Proof. unfold IsValidator. firstorder. Qed.

(* Dually, we sometimes still need to explicitelly iterate over a
  lookahead set. This is what this lemma allows.
  Used only in [end_reduce]. *)
Lemma is_validator_iterate_lset P b lookahead lset :
  TerminalSet.In lookahead lset ->
  IsValidator P (b lookahead) ->
  IsValidator P (TerminalSet.fold (fun lookahead acc =>
    if acc then b lookahead else false) lset true).
Proof.
  intros Hlset%TerminalSet.elements_1 Hval Val. apply Hval.
  revert Val. rewrite TerminalSet.fold_1. generalize true at 1. clear -Hlset.
  induction Hlset as [? l <-%compare_eq|? l ? IH]=> /= b' Val.
  - destruct (b lookahead). by destruct b'. exfalso. by induction l; destruct b'.
  - eauto.
Qed.
Hint Extern 100 (IsValidator _ _) =>
  match goal with
  | H : TerminalSet.In ?lookahead ?lset |- _ =>
    eapply (is_validator_iterate_lset _ (fun lookahead => _) _ _ H); clear H
  end
: typeclass_instances.

(* We often quantify over all the items of all the states of the
   automaton. This lemma and the accompanying [Hint Resolve]
   declaration allow generating the corresponding executable
   validator.

   Note that it turns out that, in all the uses of this pattern, the
   first thing we do for each item is pattern-matching over the
   future. This lemma also embbed this pattern-matching, which makes
   it possible to get the hypothesis [fut' = future_of_prod prod (S pos)]
   in the non-nil branch.

   Moreover, note, again, that while the specification quantifies over
   lookahead terminals individually, the code provides lookahead sets
   instead. *)
Lemma is_validator_forall_items P1 b1 P2 b2 im :
  IsItemsMap im ->

  (forall st prod lookahead lset pos,
      TerminalSet.In lookahead lset ->
      [] = future_of_prod prod pos ->
      IsValidator (P1 st prod lookahead) (b1 st prod pos lset)) ->

  (forall st prod pos lookahead lset s fut',
      TerminalSet.In lookahead lset ->
      fut' = future_of_prod prod (S pos) ->
      IsValidator (P2 st prod lookahead s fut') (b2 st prod pos lset s fut')) ->

  IsValidator (forall st prod fut lookahead,
                  state_has_future st prod fut lookahead ->
                  match fut with
                  | [] => P1 st prod lookahead
                  | s :: fut' => P2 st prod lookahead s fut'
                  end)
              (forallb_items im (fun st prod pos lset =>
                 match future_of_prod prod pos with
                 | [] => b1 st prod pos lset
                 | s :: fut' => b2 st prod pos lset s fut'
                 end)).
Proof.
  intros -> Hval1 Hval2 Val st prod fut lookahead (pos & -> & Hlookahead).
  rewrite /forallb_items StateProdPosMap.fold_1 in Val.
  assert (match future_of_prod prod pos with
          | [] => b1 st prod pos (find_items_map (items_map ()) st prod pos)
          | s :: fut' => b2 st prod pos (find_items_map (items_map ()) st prod pos) s fut'
          end = true).
  - unfold find_items_map in *.
    assert (Hfind := @StateProdPosMap.find_2 _ (items_map ()) (st, prod, pos)).
    destruct StateProdPosMap.find as [lset|]; [|by edestruct (TerminalSet.empty_1); eauto].
    specialize (Hfind _ eq_refl). apply StateProdPosMap.elements_1 in Hfind.
    revert Val. generalize true at 1.
    induction Hfind as [[? ?] l [?%compare_eq ?]|??? IH]=>?.
    + simpl in *; subst.
      match goal with |- _ -> ?X = true => destruct X end; [done|].
      rewrite Bool.andb_false_r. clear. induction l as [|[[[??]?]?] l IH]=>//.
    + apply IH.
  - destruct future_of_prod eqn:EQ. by eapply Hval1; eauto.
    eapply Hval2 with (pos := pos); eauto; [].
    revert EQ. unfold future_of_prod=>-> //.
Qed.
(* We need a hint for expplicitely instantiating b1 and b2 with lambdas. *)
Hint Extern 0 (IsValidator
                 (forall st prod fut lookahead,
                     state_has_future st prod fut lookahead -> _)
                 _) =>
    eapply (is_validator_forall_items _ (fun st prod pos lset => _)
                                      _ (fun st prod pos lset s fut' => _))
  : typeclass_instances.

(* Used in [start_future] only. *)
Instance is_validator_forall_state_has_future im st prod :
  IsItemsMap im ->
  IsValidator
    (forall look, state_has_future st prod (rev' (prod_rhs_rev prod)) look)
    (let lookaheads := find_items_map im st prod 0 in
     forallb (fun t => TerminalSet.mem t lookaheads) all_list).
Proof.
  move=> -> /forallb_forall Val look.
  specialize (Val look (all_list_forall _)). exists 0. split=>//.
  by apply TerminalSet.mem_2.
Qed.

(** * Validation for completeness **)

(** The nullable predicate is a fixpoint : it is correct. **)
Definition nullable_stable :=
  forall p:production,
    if nullable_word (prod_rhs_rev p) then
      nullable_nterm (prod_lhs p) = true
    else True.

(** The first predicate is a fixpoint : it is correct. **)
Definition first_stable:=
  forall (p:production),
    TerminalSet.Subset (first_word_set (rev' (prod_rhs_rev p)))
                       (first_nterm_set (prod_lhs p)).

(** The initial state has all the S=>.u items, where S is the start non-terminal **)
Definition start_future :=
  forall (init:initstate) (p:production),
    prod_lhs p = start_nt init ->
  forall (t:terminal),
    state_has_future init p (rev' (prod_rhs_rev p)) t.

(** If a state contains an item of the form A->_.av[[b]], where a is a
    terminal, then reading an a does a [Shift_act], to a state containing
    an item of the form A->_.v[[b]]. **)
Definition terminal_shift :=
  forall (s1:state) prod fut lookahead,
    state_has_future s1 prod fut lookahead ->
    match fut with
    | T t::q =>
      match action_table s1 with
      | Lookahead_act awp =>
        match awp t with
        | Shift_act s2 _ =>
          state_has_future s2 prod q lookahead
        | _ => False
        end
      | _ => False
      end
    | _ => True
    end.

(** If a state contains an item of the form A->_.[[a]], then either we do a
    [Default_reduce_act] of the corresponding production, either a is a
    terminal (ie. there is a lookahead terminal), and reading a does a
    [Reduce_act] of the corresponding production. **)
Definition end_reduce :=
  forall (s:state) prod fut lookahead,
    state_has_future s prod fut lookahead ->
    match fut with
    | [] =>
      match action_table s with
      | Default_reduce_act p => p = prod
      | Lookahead_act awt =>
        match awt lookahead with
        | Reduce_act p => p = prod
        | _ => False
        end
      end
    | _ => True
    end.

Definition is_end_reduce items_map :=
  forallb_items items_map (fun s prod pos lset =>
    match future_of_prod prod pos with
    | [] =>
      match action_table s with
      | Default_reduce_act p => compare_eqb p prod
      | Lookahead_act awt =>
        TerminalSet.fold (fun lookahead acc =>
          match awt lookahead with
          | Reduce_act p => (acc && compare_eqb p prod)%bool
          | _ => false
          end) lset true
      end
    | _ => true
    end).

(** If a state contains an item of the form A->_.Bv[[b]], where B is a
    non terminal, then the goto table says we have to go to a state containing
    an item of the form A->_.v[[b]]. **)
Definition non_terminal_goto :=
  forall (s1:state) prod fut lookahead,
    state_has_future s1 prod fut lookahead ->
    match fut with
    | NT nt::q =>
      match goto_table s1 nt with
      | Some (exist _ s2 _) =>
        state_has_future s2 prod q lookahead
      | None => False
      end
    | _ => True
    end.

Definition start_goto :=
  forall (init:initstate),
    match goto_table init (start_nt init) with
    | None => True
    | Some _ => False
    end.

(** Closure property of item sets : if a state contains an item of the form
    A->_.Bv[[b]], then for each production B->u and each terminal a of
    first(vb), the state contains an item of the form B->_.u[[a]] **)
Definition non_terminal_closed :=
  forall s1 prod fut lookahead,
    state_has_future s1 prod fut lookahead ->
    match fut with
    | NT nt::q =>
      forall p, prod_lhs p = nt ->
        (if nullable_word q then
           state_has_future s1 p (future_of_prod p 0) lookahead
         else True) /\
        (forall lookahead2,
           TerminalSet.In lookahead2 (first_word_set q) ->
             state_has_future s1 p (future_of_prod p 0) lookahead2)
      | _ => True
    end.

(** The automaton is complete **)
Definition complete :=
  nullable_stable /\ first_stable /\ start_future /\ terminal_shift
  /\ end_reduce /\ non_terminal_goto /\ start_goto /\ non_terminal_closed.

Derive is_complete_0
SuchThat (forall im, IsItemsMap im -> IsValidator complete (is_complete_0 im))
As complete_0_is_validator.
Proof. intros im. subst is_complete_0. instantiate (1:=fun im => _). apply _. Qed.

Definition is_complete (_:unit) := is_complete_0 (items_map ()).
Lemma complete_is_validator : IsValidator complete (is_complete ()).
Proof. by apply complete_0_is_validator. Qed.

End Make.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* To strictly import the omega tactic *)

Require ZArith_base.
Require OmegaLemmas.
Require PreOmega.

Declare ML Module "omega_plugin".