Require Import List.

Inductive last(A : Set) : list A -> A -> Prop :=
  single : forall a : A, last A (a :: nil) a
| compound : forall (l : list A)(a b : A), last A l a -> last A (b :: l) a.

Fixpoint last_fun(A : Set)(l : list A) : option A :=
  match l with
  | nil => None
  | a :: nil => Some a
  | a :: b => last_fun A b
  end.

Goal forall(A : Set)(l : list A)(a : A), last A l a -> last_fun A l = Some a.
  intros.
  elim H.
  reflexivity.
  intros.
  rewrite <- H1.
  simpl.
  destruct l0.
  inversion H1.
  reflexivity.
Qed.

Inductive permutation(A : Set) : list A -> list A -> Prop :=
  transpose :
    forall (l r : A)(lis : list A),
      permutation A (l :: r :: lis) (r :: l :: lis)
| trans : forall a b c, permutation A a b -> permutation A b c -> permutation A a c
| id : forall a, permutation A a a.

Require Import Relations.

Theorem equiv_perm : forall A : Set, equiv _ (permutation A).
  intros.
  repeat split.
  unfold reflexive.
  constructor.
  unfold transitive.
  intros.
  apply (trans A x y z);assumption.
  unfold symmetric.
  intros.
  elim H.
  intros.
  constructor.
  intros.
  econstructor.
  eassumption.
  assumption.
  constructor.
Qed.

Require Import JMeq.
Require Import Arith.

Lemma plus_assoc_JM :
  forall n p q:nat,
    JMeq (n+(p+q)) (n+p+q).
  intros.
  rewrite plus_assoc.
  constructor.
Qed.

Inductive even : nat -> Prop :=
| O_even : even 0
| plus_2_even : forall n:nat, even n -> even (S (S n)).

Hint Resolve O_even plus_2_even.

Fixpoint mult2 (n:nat) : nat :=
  match n with
  | O => 0
  | S p => S (S (mult2 p))
  end.

Goal forall n, even (n * 2).
  intros.
  induction n.
  auto.
  rewrite mult_succ_l.
  rewrite plus_comm.
  simpl.
  auto.
Qed.

Goal forall n, even n -> exists x, x * 2 = n.
  intros.
  induction H.
  exists 0.
  auto.
  destruct IHeven.
  exists (S x).
  rewrite mult_succ_l.
  rewrite plus_comm.
  simpl.
  auto with arith.
Qed.

Lemma even_plus : forall n m, even n -> even m -> even (n + m).
  intros.
  induction H.
  auto.
  simpl.
  auto.
Qed.

Goal forall n, even n -> even (n * n).
  intros.
  induction H.
  auto.
  repeat rewrite mult_succ_l.
  repeat rewrite mult_succ_r.
  repeat apply even_plus;auto.
Qed.

Theorem lt_le : forall n p:nat, n < p -> n <= p.
  intros n p H.
  apply (le_ind (S n)).
  repeat constructor.
  intros.
  constructor.
  assumption.
  assumption.
Qed.

Definition my_le (n p:nat) :=
  forall P:nat->Prop,
    P n ->
      (forall q:nat, P q -> P (S q)) ->
        P p.

Lemma my_le_n : forall n:nat, my_le n n.
  unfold my_le.
  intros.
  assumption.
Qed.

Lemma my_le_S : forall n p:nat, my_le n p -> my_le n (S p).
  unfold my_le.
  intros.
  apply H.
  auto.
  intros.
  auto.
Qed.

Lemma my_le_inv : forall n p:nat, my_le n p -> n=p \/ my_le (S n) p.
  unfold my_le.
  intros.
  apply H.
  left.
  auto.
  intros.
  destruct H0.
  right.
  intros.
  rewrite <- H0.
  auto.
  right.
  intros.
  apply H2.
  apply H0;
  auto.
Qed.

Lemma my_le_inv2 :
  forall n p:nat, my_le (S n) p ->
    exists q, p=(S q) /\ my_le n q.
  unfold my_le.
  intros.
  apply H.
  exists n.
  split;
  auto.
  intros.
  destruct H0.
  destruct H0.
  exists (S x).
  split.
  auto with arith.
  intros.
  apply H3.
  apply H1;
  auto.
Qed.

Lemma my_le_n_O : forall n:nat, my_le n 0 -> n = 0.
  intros.
  destruct n.
  auto.
  ecase my_le_inv2.
  eassumption.
  intros.
  destruct H0.
  discriminate H0.
Qed.

Lemma my_le_le : forall n p:nat, my_le n p -> le n p.
  intros.
  apply H;
  auto.
Qed.

Lemma le_my_le : forall n p:nat, le n p -> my_le n p.
  unfold my_le.
  intros.
  induction H;
  auto.
Qed.
Require Export Program.
Inductive par := open | close.
Inductive wp : list par -> Prop :=
| wp_nil : wp []
| wp_par l : wp l -> wp (open :: (l ++ [close]))
| wp_app l r : wp l -> wp r -> wp (l ++ r).
Hint Constructors wp.

Theorem cons_app { A } (l : A) r : l :: r = [l] ++ r.
  trivial.
Qed.

Theorem wp_oc : wp [open;close].
  rewrite (cons_app open); repeat constructor.
Qed.

Theorem wp_o_head_c l1 l2 : wp l1 -> wp l2 -> wp (open :: l1 ++ close :: l2).
  intros; rewrite (cons_app open), (cons_app close).
  rewrite !app_assoc; apply wp_app; simpl; auto.
Qed.

Theorem wp_o_tail_c l1 l2 : wp l1 -> wp l2 -> wp (l1 ++ open :: l2 ++ [close]).
  intros; rewrite (cons_app open).
  apply wp_app; simpl; auto.
Qed.

Fixpoint recognize n (l : list par) : bool :=
  match l, n with
  | [], 0 => true
  | open :: l', _ => recognize (S n) l'
  | close :: l', S n' => recognize n' l'
  | _, _ => false
  end.

Theorem repeat_shift { A } (e : A) n : repeat e n ++ [e] = e :: repeat e n.
  induction n; simpl in *; f_equal; auto.
Qed.

Theorem get_last { A } (l : list A) : l = [] \/ exists l' e, l = l' ++ [e].
  induction l; intuition idtac; program_simpl.
  right; exists (@nil A) a; trivial.
  right; exists (a :: H) H0; trivial.
Qed.
Hint Resolve wp_oc.

Inductive wp' : list par -> Prop :=
| wp'_nil : wp' []
| wp'_cons l r : wp' l -> wp' r -> wp' (open :: l ++ close :: r).
Hint Constructors wp'.
Theorem wp'_app l r : wp' l -> wp' r -> wp' (l ++ r).
  intros HL HR; induction HL; simpl in *; auto.
  rewrite <- app_assoc, <- app_comm_cons; auto.
Qed.
Hint Resolve wp'_app.
Theorem wp_wp' l : wp l -> wp' l.
  induction 1; simpl in *; auto.
Qed.

Theorem wp'_wp l : wp' l -> wp l.
  induction 1; auto.
  replace (open :: l ++ close :: r) with ((open :: l ++ [close]) ++ r); auto.
  simpl; f_equal; rewrite <- app_assoc; trivial.
Qed.

Hint Resolve wp_wp' wp'_wp.

Require Export Omega.

Theorem wp_close_false l : wp (close :: l) -> False.
  intros H; dependent induction H.
  destruct l0; inversion x; simpl in *; subst; eauto.
Qed.

Theorem wp_open_false l : wp (l ++ [open]) -> False.
  intros H; dependent induction H; destruct l; program_simpl.
  destruct l0; program_simpl.
  apply app_inj_tail in H2; intuition congruence.
  destruct l0, r; program_simpl.
  specialize(IHwp2 []); program_simpl.
  destruct l0; specialize(IHwp1 []); program_simpl.
  destruct l0, p0; program_simpl.
  destruct (get_last r); program_simpl; rewrite ?app_nil_r in *; subst; eauto.
  rewrite app_assoc in *; apply app_inj_tail in x; intuition; program_simpl; eauto.
Qed.

Hint Resolve wp_close_false wp_open_false.

Theorem wp_app_inv n l : length l < n -> wp (open :: close :: l) -> wp l.
  revert l; induction n; intros; [omega|].
  apply wp_wp' in H0; inversion H0; clear H0; simpl in *.
  destruct l0; simpl in *; program_simpl.
  apply wp'_wp in H2; exfalso; eauto.
Qed.

Ltac invcs s := inversion s; clear s; subst.
Theorem par_destruct_aux n l : length l < n -> head l = Some open ->
  (exists n, l = repeat open n) \/ (exists n li, l = repeat open n ++ close :: li).
  revert l; induction n; intros; simpl in *; [omega|].
  destruct l as [|[]]; simpl in *; invcs H0.
  destruct l as [|[]]; simpl in *.
  left; exists 1; trivial.
  destruct (IHn (open :: l)) as [[]|[? []]]; simpl in *; omega || trivial;
  destruct x; simpl in *; invcs H0.
  left; exists (S (S x)); trivial.
  right; exists (S (S x)) x0; trivial.
  right; exists 1 l; trivial.
Qed.

Theorem par_destruct l :
  (exists n, l = repeat open n) \/ (exists n li, l = repeat open n ++ close :: li).
  destruct l as [|[]].
  left; exists 0; trivial.
  destruct (par_destruct_aux (S (S (length l))) (open :: l));
  simpl in *; program_simpl; omega || trivial.
  destruct H; invcs H0.
  left; exists (S H); trivial.
  destruct H; simpl in *; invcs H1.
  right; exists (S H) H0; trivial.
  right; exists 0 l; trivial.
Qed.

Theorem length_eq { A } { l r : list A } (H : l = r) : length l = length r.
  subst; trivial.
Qed.

Theorem app_eq { A } { ll lr rl rr : list A } :
  ll ++ lr = rl ++ rr -> exists l, ll = rl ++ l \/ rl = ll ++ l.
  revert lr rl rr.
  induction ll; program_simpl; eauto.
  destruct rl; simpl in *; invcs H; eauto.
  specialize(IHll _ _ _ H2); program_simpl; intuition idtac; subst; eauto.
Qed.

Theorem wp_remove_aux n : forall l r, length l + length r < n ->
  wp (l ++ [open; close] ++ r) -> wp (l ++ r).
  induction n; simpl in *; intros; [omega|].
  apply wp_wp' in H0; invcs H0.
  destruct l; simpl in *; congruence.
  destruct l; simpl in *; invcs H1.
  destruct l0; simpl in *; invcs H4; eauto with *.
  destruct (app_eq H5) as [? []]; subst;
  rewrite <- app_assoc in *;
  apply app_inv_head in H5.
  destruct x; invcs H5.
  destruct x; invcs H4; try solve [exfalso; eauto].
  apply wp'_wp in H2; eapply IHn in H2;
  repeat (simpl in *; rewrite ?app_length in *); try omega.
  replace
    (open :: l ++ x ++ close :: r0) with
    ((open :: l ++ x ++ [close]) ++ r0) by
    (simpl; f_equal; rewrite <- app_assoc; f_equal; rewrite <- app_assoc; trivial).
  apply wp_app; auto.
  rewrite app_assoc; auto.
  destruct x; simpl in *; invcs H5.
  replace
    (open :: l0 ++ close :: x ++ r) with
    ((open :: l0 ++ [close]) ++ x ++ r) by
    (simpl; f_equal; rewrite <- app_assoc; f_equal).
  apply wp_app; auto.
  eapply IHn; repeat (simpl in *; rewrite ?app_length in *); omega || auto.
Qed.

Theorem wp_remove l r : wp (l ++ open :: close :: r) -> wp (l ++ r).
  intros; eapply wp_remove_aux; auto.
Qed.

Theorem recognize_complete_aux l : wp l -> forall n l', recognize n (l ++ l') = recognize n l'.
  induction 1; intros; simpl in *; rewrite <- ?app_assoc, ?IHwp, ?IHwp1, ?IHwp2; trivial.
Qed.

Theorem recognize_complete l : wp l -> recognize 0 l = true.
  induction 1; simpl in *; rewrite ?recognize_complete_aux; trivial.
Qed.

Theorem wp_destruct l : wp l ->
  l = [] \/
  (exists l1 l2, l = l1 ++ l2 /\ wp l1 /\ wp l2 /\ l1 <> [] /\ l2 <> []) \/
  (exists l1, l = open :: l1 ++ [close] /\ wp l1).
  induction 1; intros; try solve [intuition idtac].
  right; right; exists l; intuition.
  destruct IHwp1; program_simpl; simpl in *; trivial.
  destruct IHwp2; program_simpl; simpl in *; rewrite ?app_nil_r in *; eauto.
  right; left; exists l r; intuition idtac; program_simpl;
  match goal with H : ?X ++ ?Y = [] |- _ => destruct X; simpl in *; congruence end.
Qed.

Theorem wp_insert : forall n a b c,
  length a + length b + length c < n -> wp (a ++ c) -> wp b -> wp (a ++ b ++ c).
  induction n; intros; simpl in *; [omega|].
  apply wp_destruct in H0; intuition idtac; program_simpl.
  + destruct a, c; simpl in *; rewrite ?app_nil_r; congruence.
  + destruct (app_eq H3); intuition idtac; subst; rewrite <- app_assoc in *;
    apply app_inv_head in H3; subst; repeat (simpl in *; rewrite ?app_length in *).
    - apply wp_app; eauto.
      eapply IHn; eauto.
      destruct H0; simpl in *; congruence || omega.
    - rewrite !app_assoc; apply wp_app; eauto.
      rewrite <- app_assoc; eapply IHn; eauto.
      destruct H2; simpl in *; congruence || omega.
  + destruct a; simpl in *; invcs H2; eauto.
    destruct (get_last c); program_simpl;
    repeat (rewrite ?app_nil_r, ?app_length, <- ?plus_n_O in *; subst; simpl in *).
    - rewrite app_comm_cons; eauto.
    - rewrite app_assoc in H6; apply app_inj_tail in H6; intuition idtac; subst.
      rewrite !app_assoc; apply wp_par; rewrite <- app_assoc; eapply IHn; eauto; omega.
Qed.

Theorem recognize_sound n l : recognize n l = true -> wp ((repeat open n) ++ l).
  revert n; induction l; intros; simpl in *.
  destruct n; simpl; congruence || auto.
  destruct a, n; simpl in *; try specialize (IHl _ H); simpl in *; congruence || auto.
  rewrite (cons_app _ l), app_assoc, repeat_shift; simpl; trivial.
  rewrite app_comm_cons, <- repeat_shift, <- app_assoc, (cons_app _ l), (app_assoc _ _ l).
  eapply wp_insert; eauto.
Qed.


Theorem contrapositive : forall (P Q : Prop),
  (P -> Q) -> (~Q -> ~P).
Proof.
  intros P Q H1 contra.
  unfold not.
  unfold not in contra.
  intros HP.
  apply contra in H1.
  apply H1.
  apply HP.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Arith.Arith.
Require Import Coq.Strings.String.

Import ListNotations.

(* Syntax of Clock-based Dynamic Logic *)

(* Syntax of SEP_exp (Synchonous Event Program) *)

(* ========================= Syntax of SEP_exp ========================*)

(* =============== Syntax of Expressions ===================*)

(* Arith Expression `e'*)

Inductive e_exp :=
  enumC : nat -> e_exp |
  evarC : string -> e_exp |
  eplusC : e_exp -> e_exp -> e_exp |
  (*non-necessary expression*)
  eminusC : e_exp -> e_exp -> e_exp |
  emulC : e_exp -> e_exp -> e_exp |
  edivC : e_exp -> e_exp -> e_exp
.
Print e_exp.

Notation "e1 '+ e2" := (eplusC e1 e2) (at level 31, right associativity).
Locate "'+".
Notation "e1 '- e2" := (eminusC e1 e2) (at level 31, right associativity).

Notation "e1 '* e2" := (emulC e1 e2) (at level 21, right associativity).

(*** Open Scope e_exp_scope. ***)

Locate "*".
Check (enumC 4) '* (enumC 5 '+ enumC 6).

Notation "e1 '/ e2" := (edivC e1 e2) (at level 21, right associativity).
Check (enumC 4) '/ (enumC 4).

Coercion enumC : nat >-> e_exp.
Coercion evarC : string >-> e_exp.
Definition x : string := "x".
Definition y : string := "y".
Definition z : string := "z".
Definition k : string := "k".

Check 4 '* (5 '+ 2).
Check (5 '+ 4) '* 8.
Check x '- 3.
Check 5 '+ 4 '* 5.

(* Boolean Expression `P'*)
Inductive P_exp :=
  PtrueC : P_exp |
  PlteC : e_exp -> e_exp -> P_exp |
  PnegC : P_exp -> P_exp |
  PandC : P_exp -> P_exp -> P_exp |
  (*non-necesarry expression*)
  PfalseC : P_exp |
  PltC : e_exp -> e_exp -> P_exp |
  PgtC : e_exp -> e_exp -> P_exp |
  PgteC : e_exp -> e_exp -> P_exp |
  PeqC : e_exp -> e_exp -> P_exp |
  PorC : P_exp -> P_exp -> P_exp |
  PimpC : P_exp -> P_exp -> P_exp
.
Print P_exp.

(* 33 - 41 *)
Notation "''tt'" := PtrueC (at level 35).
Notation "e1 '<= e2" := (PlteC e1 e2) (at level 33).
Notation "'~ P" := (PnegC P) (at level 36).
Notation "P1 '/\ P2" := (PandC P1 P2) (at level 37, right associativity).
Notation "''ff'" := PfalseC (at level 35).
Notation "e1 '< e2" := (PltC e1 e2) (at level 33).
Notation "e1 '> e2" := (PgtC e1 e2) (at level 33).
Notation "e1 '>= e2" := (PgteC e1 e2) (at level 33).
Notation "e1 '= e2" := (PeqC e1 e2) (at level 33).
Notation "P1 '\/ P2" := (PorC P1 P2) (at level 37, right associativity).
Notation "P1 '-> P2" := (PimpC P1 P2) (at level 38, right associativity).

Locate "'/\".
Check 'tt '-> 'ff.
Check 5 '+ x '>= 5 '-> 3 '> 7.

(* Evaluation *)
Definition state := string -> nat.

(***
  Definging the evaluation for expressions is for checking the validation of FOL formulas after
  transformation.
***)

Fixpoint eval_e_exp (e : e_exp) (st : state) : nat :=
(* st maps each var name to a value --- it is a state *)
  match e with
  | enumC n => n
  | evarC s => st s
  | eplusC e1 e2 => (eval_e_exp e1 st) + (eval_e_exp e2 st)
  | eminusC e1 e2 => (eval_e_exp e1 st) - (eval_e_exp e2 st)
  | emulC e1 e2 => (eval_e_exp e1 st) * (eval_e_exp e2 st)
  | edivC e1 e2 => (eval_e_exp e1 st) / (eval_e_exp e2 st)
  end.

Fixpoint eval_P_exp (P : P_exp) (st : state) : Prop :=
  match P with
  | PtrueC => True
  | PlteC e1 e2 => (eval_e_exp e1 st) <= (eval_e_exp e2 st)
  | PnegC P' => ~ (eval_P_exp P' st)
  | PandC P1 P2 => (eval_P_exp P1 st) /\ (eval_P_exp P1 st)
  | PfalseC => False
  | PltC e1 e2 => (eval_e_exp e1 st) < (eval_e_exp e2 st)
  | PgtC e1 e2 => (eval_e_exp e1 st) > (eval_e_exp e2 st)
  | PgteC e1 e2 => (eval_e_exp e1 st) >= (eval_e_exp e2 st)
  | PeqC e1 e2 => (eval_e_exp e1 st) = (eval_e_exp e2 st)
  | PorC P1 P2 => (eval_P_exp P1 st) \/ (eval_P_exp P1 st)
  | PimpC P1 P2 => (eval_P_exp P1 st) -> (eval_P_exp P1 st)
  end.

(* =============== Syntax of Event ===================*)

(* Event *)
Inductive EvtElement :=
  sigC : string -> e_exp -> EvtElement | (* Signal *)
  assC : string -> e_exp -> EvtElement  (* Assignment *)
.
Check EvtElement.

Notation "s ! e" := (sigC s e) (at level 45).
Notation "x :=' e" := (assC x e) (at level 45).

(* currently we do not make distinguish between variable and clock names, both are strings*)
Definition c : string := "c".
Definition d : string := "d".
Definition c1 : string := "c1".
Definition c2 : string := "c2".
Definition c3 : string := "c3".
Definition c4 : string := "c4".

Check x :=' 4.
Check c ! (x '+ 4).

Definition Evt := list EvtElement.

Check Evt.
Check (x :=' 4) :: (c!(x '+ 4)) :: nil.

(* ========================= Syntax of program ========================*)
Inductive SEP_exp : Type :=
  skip : SEP_exp | (* skip program $\varepsilon$ *)
  evtC : Evt -> SEP_exp | (* Event *)
  tstC : P_exp -> Evt -> SEP_exp | (* Test *)
  seqC : SEP_exp -> SEP_exp -> SEP_exp | (* sequence *)
  choC : SEP_exp -> SEP_exp -> SEP_exp | (* choice *)
  loopC : SEP_exp -> SEP_exp (* loop *)
.

Coercion evtC : Evt >-> SEP_exp.
Notation "{ a1 | .. | an }" := (cons a1 .. (cons an nil) .. ) (at level 45).
Notation "@ a" := (evtC a) (at level 46).
Definition idle : Evt := nil.
Notation "P ? a" := (tstC P a) (at level 48).
Notation "P1 ; P2" := (seqC P1 P2) (at level 49, left associativity).
Notation "P1 'U' P2" := (choC P1 P2) (at level 51, left associativity).
Notation "P **" := (loopC P) (at level 47, left associativity).

Locate "**".
Check x :=' 4 :: nil.
Check evtC (x :=' 4 :: nil).
Check { x :=' 4 }.
Check { x :=' 4 | c1 ! 5}.
Check @ { x :=' 4 | c1 ! 5 }.
Check idle.
Check x '> 0 ? {c!4}.

(* ========================================= Syntax of CDL Formula ===============================================*)

(* ================== CCSL ======================== *)
(* clock relation *)
(***
  Currently, we model clocks as `strings', becuase now we don't need to give its semantics.
  It won't work anymore if we consider its semantics later.
***)

Inductive CRel :=
  crSubClC : string -> string -> CRel |
  crExclC : string -> string -> CRel |
  crPrecC : string -> string -> CRel |
  crCausC : string -> string -> CRel
.
Check CRel.

Notation "c1 'sub' c2" := (crSubClC c1 c2) (at level 52).
Notation "c1 # c2" := (crExclC c1 c2) (at level 52).
Notation "c1 << c2" := (crPrecC c1 c2) (at level 52).
Notation "c1 <<= c2" := (crCausC c1 c2) (at level 52).

Check c1 << c2.
Check c1 # c2.
Check c1 sub c2.

(* ================== CDL Formula ======================== *)
(* Clock relation in formula *)
Inductive rel :=
  rRelC : CRel -> rel |
  rConjC : list CRel -> rel
.
Print rel.

Coercion rRelC : CRel >-> rel.
Check c1 << c2.

Notation "/\{ c1 , .. , cn }" := (rConjC (cons c1 .. (cons cn nil) ..)).
Check /\{ c1 << c2 , c2 sub c3 , c1 <<= c3}.

(* Arith Expression `E' *)
(*DEL
(* define a map that maps each clock/signal to a variable that records the number it has ticked in history. *)
Definition CntClk := string -> string.

(* define a map that maps each clock/signal to a variable that records the current state of this clock. *)
Definition StClk := string -> string.
DEL*)

Inductive E_exp :=
  EvarC : string -> E_exp |
  ECntClkC : string -> E_exp | (* define a map that maps each clock/signal to a variable that records the number it has ticked in history. *)
  EStClkC : string -> E_exp | (* define a map that maps each clock/signal to a variable that records the current state of this clock. *)
  EnumC : nat -> E_exp |
  EplusC : E_exp -> E_exp -> E_exp |
  (* unecessary expression *)
  EmulC : E_exp -> E_exp -> E_exp |
  EminusC : E_exp -> E_exp -> E_exp |
  EdivC : E_exp -> E_exp -> E_exp
.
Print E_exp.

Coercion EvarC : string >-> E_exp.
Notation "n( c )" := (ECntClkC c) (at level 52). (* the only DIFFERENCE between e_exp and E_exp *)
Notation "s( c )" := (EStClkC c) (at level 52).
Coercion EnumC : nat >-> E_exp.
Notation "e1 +' e2" := (EplusC e1 e2) (at level 55, right associativity).
Notation "e1 *' e2" := (EmulC e1 e2) (at level 53, right associativity).
Notation "e1 -' e2" := (EminusC e1 e2) (at level 55, right associativity).
Notation "e1 /' e2" := (EdivC e1 e2) (at level 53, right associativity).

Check 5 +' 3.
Check 5 '+ 3.
Check 5 *' (3 +' 5).
Check n(c) *' 4.

(* CDL Formula *)
Inductive CDL_exp :=
  cdl_trueC : CDL_exp |
  cdl_ltC : E_exp -> E_exp -> CDL_exp |
  cdl_box1C : SEP_exp -> rel -> CDL_exp |
  cdl_box2C : SEP_exp -> CDL_exp -> CDL_exp |
  cdl_negC : CDL_exp -> CDL_exp |
  cdl_andC : CDL_exp -> CDL_exp -> CDL_exp |
  cdl_forallC : string -> CDL_exp -> CDL_exp |
  (* unnecessary expressions *)
  cdl_falseC : CDL_exp |
  cdl_lteC : E_exp -> E_exp -> CDL_exp |
  cdl_gtC : E_exp -> E_exp -> CDL_exp |
  cdl_gteC : E_exp -> E_exp -> CDL_exp |
  cdl_eqC : E_exp -> E_exp -> CDL_exp |
  cdl_dia1C : SEP_exp -> rel -> CDL_exp |
  cdl_dia2C : SEP_exp -> CDL_exp -> CDL_exp |
  cdl_orC : CDL_exp -> CDL_exp -> CDL_exp |
  cdl_impC : CDL_exp -> CDL_exp -> CDL_exp
.

Notation "'tt''" := cdl_trueC (at level 65).
Notation "e1 <' e2" := (cdl_ltC e1 e2) (at level 61).
Notation "[ p ]' r" := (cdl_box1C p r) (at level 63, p at level 62, r at level 62).
Notation "[ p ] e" := (cdl_box2C p e) (at level 63, p at level 62, e at level 62).
Notation "~' e" := (cdl_negC e) (at level 67).
Notation "e1 /\' e2" := (cdl_andC e1 e2) (at level 69, right associativity).
Notation "'all' x , e" := (cdl_forallC x e) (at level 68, x at level 67).
(* unnecessary expressions *)
Notation "'ff''" := cdl_falseC (at level 65).
Notation "e1 <=' e2" := (cdl_lteC e1 e2) (at level 61).
Notation "e1 >' e2" := (cdl_gtC e1 e2) (at level 61).
Notation "e1 >=' e2" := (cdl_gteC e1 e2) (at level 61).
Notation "e1 =' e2" := (cdl_eqC e1 e2) (at level 61).
Notation "< p >' r" := (cdl_dia1C p r) (at level 63).
Notation "< p > e" := (cdl_dia2C p e) (at level 63).
Notation "e1 \/' e2" := (cdl_orC e1 e2) (at level 71, right associativity).
Notation "e1 ->' e2" := (cdl_impC e1 e2) (at level 72, right associativity).

Check tt'.
Check ff'.
Check (5 -' 3) <' 2.
Check ([ skip ]' c1 << c2) /\' 2 >' 5 /\' tt'.
Check [ @ {x :=' 4 | c1 ! 5} ; (x '> 0) ? {c2!4} ; @ idle; skip] n(c) >' 0.
Check [(@ {x :=' 4 | c1 ! 5} ; (x '> 0) ? {c2!4} ; @ idle; skip)** ]' c1<<c2.
Check [ skip ]' c1 << c2 .
Check all x , 4 =' 5.

(* ===================================================== CDL Calculus ======================================*)

(*************************** Auxiliary Functions ***************************)
(*check if a dynamic formula is a pure FOL formula *)

Fixpoint CheckPureFOL (e : CDL_exp) : Prop :=
  match e with
  | cdl_trueC => True
  | cdl_ltC e1 e2 => True
  | cdl_box1C p r => False
  | cdl_box2C p e' => False
  | cdl_negC e' => CheckPureFOL e'
  | cdl_andC e1 e2 => (CheckPureFOL e1) /\ (CheckPureFOL e2)
  | cdl_forallC x e' => (CheckPureFOL e')
  | cdl_falseC => True
  | cdl_lteC e1 e2 => True
  | cdl_gtC e1 e2 => True
  | cdl_gteC e1 e2 => True
  | cdl_eqC e1 e2 => True
  | cdl_dia1C p r => False
  | cdl_dia2C p e' => False
  | cdl_orC e1 e2 => (CheckPureFOL e1) /\ (CheckPureFOL e2)
  | cdl_impC e1 e2 => (CheckPureFOL e1) /\ (CheckPureFOL e2)
  end.

(* a structure of (true, false, `undefined') *)
Inductive Bool :=
  bBoolC : Prop -> Bool |
  bUndefC : Bool
.

(*
Notation "[ b ]" := (bBoolC b) (at level 74).
Notation "_|_" := bUndefC (at level 74).
*)

(* evaluate a pure FOL formula in CDL formula *)

(* during the derivation we need to translate expression e to expression E. In the semantics of dynamic logic, their
corresponding arithmetical opertors have the same meanings *)

Fixpoint e_2_E (e : e_exp) : E_exp :=
  match e with
  | enumC n => EnumC n
  | evarC s => EvarC s
  | eplusC e1 e2 => EplusC (e_2_E e1) (e_2_E e2)
  | eminusC e1 e2 => EminusC (e_2_E e1) (e_2_E e2)
  | emulC e1 e2 => EmulC (e_2_E e1) (e_2_E e2)
  | edivC e1 e2 => EdivC (e_2_E e1) (e_2_E e2)
  end.

(* -------------------------------computation of free variables in cdl formula----------------------------------------*)
(***
Note that actually here we compute all occurrences of free variables in a cdl formula, not really all free variables, because
here we use `list' as the structure to `store' each appearance of free variables.
It is enough for us to check whether a variable is a free variable or not in a formula checking if it does not equal to
each occurrence of variables.
***)

(* this function check whether a variable (i.e. a string) belongs to a list of variables (list of string) *)
Fixpoint NotIn_bool (s : string) (vec : list string) : bool :=
  match vec with
  | nil => true
  | v :: vec' => if (string_dec s v) then false else NotIn_bool s vec'
  end.

Compute NotIn_bool x (x :: y :: z :: nil).
Compute NotIn_bool c (x :: y :: z :: nil).

(* this is another version for Prop type, just in case we need it in building the proof system*)
Fixpoint NotIn (s : string) (vec : list string) : Prop :=
  match vec with
  | nil => True
  | v :: vec' => if (string_dec s v) then False else NotIn s vec'
  end.

Compute NotIn x (x :: y :: z :: nil).
Compute NotIn c (x :: y :: z :: nil).

Fixpoint In (s : string) (vec : list string) : Prop :=
  match vec with
  | nil => False
  | v :: vec' => if (string_dec s v) then True else In s vec'
  end.

Fixpoint E_exp_FV (e : E_exp) (bv : list string) : list string := (*bv : list of bounded variables at current time *)
  match e with
  | EvarC v => if (NotIn_bool v bv) then (v :: nil) else nil
  | ECntClkC c => nil
  | EStClkC c => nil
  | EnumC n => nil
  | EplusC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | EmulC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | EminusC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | EdivC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  end
.

Compute E_exp_FV (x +' 3 *' n(c)) nil.
Compute E_exp_FV (x +' 3 *' z) nil.
Compute E_exp_FV (x +' 3 *' z) (x :: nil).

Fixpoint e_exp_FV (e : e_exp) (bv : list string) : list string :=
  match e with
  | enumC n => nil
  | evarC s => if (NotIn_bool s bv) then (s :: nil) else nil
  | eplusC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | eminusC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | emulC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | edivC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  end
.

Compute e_exp_FV (x '+ 3 '* 5) nil.
Compute e_exp_FV (x '+ 3 '* z) nil.
Compute e_exp_FV (x '+ 3 '/ z) (x :: nil).

Fixpoint P_exp_FV (P : P_exp) (bv : list string) : list string :=
  match P with
  | PtrueC => nil
  | PlteC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | PnegC P' => P_exp_FV P' bv
  | PandC P1 P2 => (P_exp_FV P1 bv) ++ (P_exp_FV P2 bv)
  | PfalseC => nil
  | PltC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | PgtC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | PgteC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | PeqC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | PorC P1 P2 => (P_exp_FV P1 bv) ++ (P_exp_FV P2 bv)
  | PimpC P1 P2 => (P_exp_FV P1 bv) ++ (P_exp_FV P2 bv)
  end
.

Compute P_exp_FV ('tt '/\ (3 '= 5 '* x)) nil.
Compute P_exp_FV ('tt '/\ (3 '= 5 '* x)) (x :: nil).
Compute P_exp_FV (y '<= 5 '/\ (3 '= 5 '* x)) (z :: nil).

Fixpoint EvtE_FV (e : EvtElement) (bv : list string) : list string :=
  match e with
  | sigC s e' => e_exp_FV e' bv
  | assC s e' => e_exp_FV e' bv
  end
.

Fixpoint Evt_FV (evt : Evt) (bv : list string) : list string :=
  match evt with
  | nil => nil
  | e :: evt' => (EvtE_FV e bv) ++ (Evt_FV evt' bv)
  end
.

Compute Evt_FV ({ x:='y '+ 2 | c ! (z '* 38)}) nil.
Compute Evt_FV ({ x:='y '+ 2 | c ! (z '* 38)}) (y :: nil).

Fixpoint SEP_exp_FV (e : SEP_exp) (bv : list string) : list string :=
  match e with
  | skip => nil
  | evtC evt => (Evt_FV evt bv)
  | tstC P evt => (P_exp_FV P bv) ++ (Evt_FV evt bv)
  | seqC e1 e2 => (SEP_exp_FV e1 bv) ++ (SEP_exp_FV e2 bv)
  | choC e1 e2 => (SEP_exp_FV e1 bv) ++ (SEP_exp_FV e2 bv)
  | loopC e' => (SEP_exp_FV e' bv)
  end
.

Check x '> 2 ? { y :=' y '- z}.
Compute SEP_exp_FV ((@ { x :=' 5}; x '> 2 ? { y :=' y '- z} U skip) **) nil.

Fixpoint cdl_FV (e : CDL_exp) (bv : list string) : list string := (*bv : list of bounded variables at current time *)
  match e with
  | cdl_trueC => nil
  | cdl_ltC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | cdl_box1C p r => SEP_exp_FV p bv
  | cdl_box2C p e' => (SEP_exp_FV p bv) ++ (cdl_FV e' bv)
  | cdl_negC e' => cdl_FV e' bv
  | cdl_andC e1 e2 => (cdl_FV e1 bv) ++ (cdl_FV e2 bv)
  | cdl_forallC x1 e' => cdl_FV e' (x1 :: bv) (* x1 is a bounded variable *)
  | cdl_falseC => nil
  | cdl_lteC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | cdl_gtC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | cdl_gteC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | cdl_eqC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | cdl_dia1C p r => SEP_exp_FV p bv
  | cdl_dia2C p e' => (SEP_exp_FV p bv) ++ (cdl_FV e' bv)
  | cdl_orC e1 e2 => (cdl_FV e1 bv) ++ (cdl_FV e2 bv)
  | cdl_impC e1 e2 => (cdl_FV e1 bv) ++ (cdl_FV e2 bv)
  end
.

Check ( all y , y =' 7 ) .
Compute cdl_FV ([ (@ { x :=' 5}; x '> 2 ? { y :=' y '- z} U skip) ] x >' 0 /\' ( all y , y =' 7 ) ) nil.
Compute cdl_FV ([ (@ { x :=' 5}; x '> 2 ? { y :=' y '- z} U skip) ] x >' 0 /\' ( all y , y =' 7 ) ) (y :: nil).

(* for list *)
Fixpoint cdl_FV_l (T : list CDL_exp) (bv : list string) : list string :=
  match T with
  | nil => nil
  | e :: T' => (cdl_FV e bv) ++ (cdl_FV_l T' bv)
  end.

(* -------------------------------substitution for single variable----------------------------------------*)
Fixpoint E_exp_subs (e : E_exp) (x' : string) (x : string) : E_exp :=
  match e with
  | EvarC v => if (string_dec v x) then EvarC x' else EvarC v
  | ECntClkC c => ECntClkC c (* do not consider replacing a clock-related variable *)
  | EStClkC c => EStClkC c
  | EnumC n => EnumC n
  | EplusC e1 e2 => EplusC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | EmulC e1 e2 => EmulC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | EminusC e1 e2 => EminusC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | EdivC e1 e2 => EdivC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  end
.

Compute E_exp_subs (x +' y) y x.
Compute E_exp_subs (x *' z) y c.
Compute E_exp_subs (n(c) *' z) y z.

Notation "e [ x' 'subs-E' x ]" := (E_exp_subs e x' x) (at level 9).

Fixpoint e_exp_subs (e : e_exp) (x' : string) (x : string) : e_exp :=
  match e with
  | enumC n => enumC n
  | evarC s => if (string_dec s x) then evarC x' else evarC s
  | eplusC e1 e2 => eplusC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | eminusC e1 e2 => eminusC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | emulC e1 e2 => emulC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | edivC e1 e2 => edivC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  end
.

Compute e_exp_subs ((z '- 5) '* x '+ z) y z.

Fixpoint P_exp_subs (P : P_exp) (x' : string) (x : string) : P_exp :=
  match P with
  | PtrueC => PtrueC
  | PlteC e1 e2 => PlteC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | PnegC P' => PnegC (P_exp_subs P' x' x)
  | PandC P1 P2 => PandC (P_exp_subs P1 x' x) (P_exp_subs P2 x' x)
  | PfalseC => PfalseC
  | PltC e1 e2 => PltC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | PgtC e1 e2 => PgtC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | PgteC e1 e2 => PgteC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | PeqC e1 e2 => PeqC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | PorC P1 P2 => PorC (P_exp_subs P1 x' x) (P_exp_subs P2 x' x)
  | PimpC P1 P2 => PimpC (P_exp_subs P1 x' x) (P_exp_subs P2 x' x)
  end
.

Compute P_exp_subs ('tt '/\ '~ (x '< 5)) z x.

Fixpoint EvtE_subs (e : EvtElement) (x' : string) (x : string) : EvtElement :=
  match e with
  | sigC s e' => sigC s (e_exp_subs e' x' x)
  | assC s e' => assC s (e_exp_subs e' x' x)
  end
.

Compute EvtE_subs (c ! x '+ 5) y x.
Compute EvtE_subs (x :=' (5 '* x '+ 3 '/ y)) z x.

Fixpoint Evt_subs (evt : Evt) (x' : string) (x : string) : Evt :=
  match evt with
  | nil => nil
  | e :: evt' => (EvtE_subs e x' x) :: (Evt_subs evt' x' x)
  end
.

Compute Evt_subs ( { c ! x '+ 5 | x :=' 5 '* x '+ 3 '/ y }) z x.

Fixpoint SEP_exp_subs (e : SEP_exp) (x' : string) (x : string) : SEP_exp :=
  match e with
  | skip => skip
  | evtC evt => evtC (Evt_subs evt x' x)
  | tstC P evt => tstC (P_exp_subs P x' x) (Evt_subs evt x' x)
  | seqC e1 e2 => seqC (SEP_exp_subs e1 x' x) (SEP_exp_subs e2 x' x)
  | choC e1 e2 => choC (SEP_exp_subs e1 x' x) (SEP_exp_subs e2 x' x)
  | loopC e' => loopC (SEP_exp_subs e' x' x)
  end
.

Compute SEP_exp_subs ( @ { c ! x '+ 5 | x :=' 5 '* x '+ 3 '/ y }) z x.

Fixpoint cdl_subs (e : CDL_exp) (x' : string) (x : string) : CDL_exp := (* e[x' // x] *)
  match e with
  | cdl_trueC => cdl_trueC
  | cdl_ltC e1 e2 => cdl_ltC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | cdl_box1C p r => cdl_box1C (SEP_exp_subs p x' x) r (* do not consider replacing a clock-related variable *)
  | cdl_box2C p e' => cdl_box2C (SEP_exp_subs p x' x) (cdl_subs e' x' x)
  | cdl_negC e' => cdl_negC (cdl_subs e' x' x)
  | cdl_andC e1 e2 => cdl_andC (cdl_subs e1 x' x) (cdl_subs e2 x' x)
  | cdl_forallC x1 e' => if (string_dec x1 x) then cdl_forallC x1 e' else (cdl_subs e' x' x)
  | cdl_falseC => cdl_falseC
  | cdl_lteC e1 e2 => cdl_lteC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | cdl_gtC e1 e2 => cdl_gtC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | cdl_gteC e1 e2 => cdl_gteC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | cdl_eqC e1 e2 => cdl_eqC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | cdl_dia1C p r => cdl_dia1C (SEP_exp_subs p x' x) r (* do not consider replacing a clock-related variable *)
  | cdl_dia2C p e' => cdl_dia2C (SEP_exp_subs p x' x) (cdl_subs e' x' x)
  | cdl_orC e1 e2 => cdl_orC (cdl_subs e1 x' x) (cdl_subs e2 x' x)
  | cdl_impC e1 e2 => cdl_impC (cdl_subs e1 x' x) (cdl_subs e2 x' x)
  end.

Notation "e [ x' 'subs' x ]" := (cdl_subs e x' x) (at level 9).
Check [ skip ]' c1 << c2 .
Locate "/".
Locate "//".
Compute ([ y '> 1 ? { x :=' x '+ 1 }; skip ; @ { x :=' x '+ 1 }]' c1 << c2) [ y subs x ] .

(* substitution for list *)
Fixpoint cdl_subs_l (T : list CDL_exp) (x' : string) (x : string) : list CDL_exp := (* T [x' // x] *)
  match T with
  | nil => nil
  | e :: T' => (cdl_subs e x' x) :: (cdl_subs_l T' x' x)
  end.

Notation "T [ x' 'subs-l' x ]" := (cdl_subs_l T x' x) (at level 9).

(* ====================================================== CDL Rules =============================================*)

Definition Gamma := list CDL_exp.
Definition Delta := list CDL_exp.

(***DEL Definition SequentL : Gamma -> CDL_exp -> Delta -> Prop.*)

(* we arrange a place special for the dynamic formula we want to verify in the sequent, other formulas in Gamma
and Delta are pure FOL formulas.

We define two types of sequent: sequentL and sequentR, where L and R indicate the verifiying formula is on the left
or right side of the sequent.
*)

Inductive place :=
  exp : CDL_exp -> place |
  empty : place
.

(*
Notation "'<<' e '>>'" := (exp e) (at level 74, e at level 72).
Notation "<< >>" := empty (at level 74).
Check << x <=' y >> .
Check << >>.
Locate "<< >>".
*)

Reserved Notation "{ T , p1 ==> p2 , D }" (at level 75).
(*Reserved Notation "T ==> p , D" (at level 75).*)

Locate "==>".

(*&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& a simple test &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&*)

(*** as a test, we firstly implement a simple rule here, to check if everything in my mind would work well,
we first realize the rule:
    T[x'/x],x = e[x'/x] => E, D[x'/x]
    ---------------------------------
    T => [x := e] E, D

It is equavalent to realize the rule:
    forall x'. (x' not free in T, e, D) -> (T[x'/x],x = e[x'/x] => E, D[x'/x]) -> (T => [x := e] E, D)
***)

(* To be simple, we firstly define a sequent as a triple (\Gamma, formula, \Delta), where \Gamma and \Delta are the context of
the formula that we are going to transform. *)

(**DEL
Inductive tstSeq : Gamma -> place -> place -> Delta -> Type :=
  tst1 : forall (T : Gamma) (D : Delta) (e : e_exp) (phi : CDL_exp) (x : string),
          (
          forall (z : string),
          (tstSeq ((x =' (e_2_E e) [z subs-E x]) :: (T [ z subs-l x ]))
                   empty
                  (exp phi)
                  (D [ z subs-l x ]) )
        ) ->
    (tstSeq T empty (exp ([ @ {x :=' e} ] phi)) D)
where "{ T , p1 ==> p2 , D }" := (tstSeq T p1 p2 D)
.

(* Theorem thm1 : (x =' 1) :: nil , empty ==> [ @ {x :=' x '+ 1}] x >' 2 , nil .*)

Theorem thm1 : tstSeq ((y =' 1) :: nil) empty (exp ([ @ {y :=' y '+ z}] y >' 2)) nil .
Proof.
apply tst1.
intros. simpl.
Abort.

Theorem thm2 : { ((y =' 1):: nil) , empty ==> exp ([ @ {y :=' y '+ z}] y >' 2) , nil }.
DEL**)

Inductive tstSeq2 : Gamma -> place -> place -> Delta -> Type :=
  tst2 : forall (T : Gamma) (D : Delta) (e : e_exp) (phi : CDL_exp) (x : string) (A : Evt),
          (
          forall (z : string),
          (forall (n : string), (In n ((cdl_FV_l T nil) ++ (cdl_FV_l D nil) ++ (e_exp_FV e nil) ++ (Evt_FV A nil) ++ (cdl_FV phi nil)))
                                  -> (n <> z)
          ) ->
          (tstSeq2 ((x =' (e_2_E e) [z subs-E x]) :: (T [ z subs-l x ]))
                   empty
                  (exp ([ @ A ] phi))
                  (D [ z subs-l x ]) )
        ) ->
    (tstSeq2 T empty (exp ([ @ ((x :=' e) :: A) ] phi)) D)
  |
  tst3 : forall (T : Gamma) (D : Delta) (phi : CDL_exp),
          (
          tstSeq2 T
                   empty
                  (exp phi)
                  D
        ) ->
    (tstSeq2 T empty (exp ([ @ idle ] phi)) D)
where "{ T , p1 ==> p2 , D }" := (tstSeq2 T p1 p2 D)
.

Locate "<>".

Compute x = y.

Theorem thm2 : { ((y =' 1):: nil) , empty ==> exp ([ @ {y :=' y '+ z | y :=' y '+ 1}] y >' 2) , nil }.
Proof.
apply tst2.
intros. simpl.
apply tst2.
intros. simpl.
apply tst3. simpl.
simpl H.
Abort.

(*DEL
Inductive E_expt :=
  tvarC : Type -> E_expt |
  tCntClkC : Type -> E_expt |
  tStClkC : Type -> E_expt |
  tnumC : nat -> E_expt |
  tplusC : E_expt -> E_expt -> E_expt |
  (* unecessary expression *)
  tmulC : E_expt -> E_expt -> E_expt |
  tminusC : E_expt -> E_expt -> E_expt |
  tdivC : E_expt -> E_expt -> E_expt
.
Print E_expt.

Variable X : Type.
Variable Y : Type.

Fixpoint E_expt_subs (e : E_expt) (x' : Type) (x : Type) : E_expt :=
  match e with
  | tvarC x => tvarC x
  | tCntClkC c => tCntClkC c (* do not consider replacing a clock-related variable *)
  | tStClkC c => tStClkC c
  | tnumC n => tnumC n
  | tplusC e1 e2 => tplusC (E_expt_subs e1 x' x) (E_expt_subs e2 x' x)
  | tmulC e1 e2 => tmulC (E_expt_subs e1 x' x) (E_expt_subs e2 x' x)
  | tminusC e1 e2 => tminusC (E_expt_subs e1 x' x) (E_expt_subs e2 x' x)
  | tdivC e1 e2 => tdivC (E_expt_subs e1 x' x) (E_expt_subs e2 x' x)
  end
.
Print E_expt_subs.
***DEL*)

(*** exploring how the `apply' works and how the pattern matching works in Coq ***)
Inductive ev : nat -> Prop :=
  ev_0 : ev 0 |
  ev_SS : forall (n : nat), ev n -> ev ( S (S n))
.

Theorem ev_4 : ev 4.
Proof.
apply ev_SS. apply ev_SS. apply ev_0.
Qed.

Theorem ev_plus4 : forall n, ev n -> ev (4 + n).
Proof.
  intros n. simpl. intros Hn.
  apply ev_SS. apply ev_SS. apply Hn.
Qed.

Inductive month : Set :=
  Jan | Feb | Mar
.

(*&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&  end of test &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&*)
Inductive validSeq : sequent -> Type :=
  tst : forall (T : Gamma) (p : CDL_exp) (D : Delta), (CheckPureFOL p) -> validSeq ( T ==> p , D ).


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling    [*]              *)
(*             Jean-François Monin           [+]              *)
(*                                                            *)
(*           [*] Affiliation Univ. Lorraine - CNRS - LORIA    *)
(*           [+] Affiliation VERIMAG - Univ. Grenoble Alpes   *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*        CeCILL v2.1 FREE SOFTWARE LICENSE AGREEMENT         *)
(**************************************************************)

From Coq Require Import Utf8.

From MuRec Require Import relations arith_mini.

Section btwn.

  Variable P : nat → Prop.

  (* Weak between formulated in FO arithmetic *)
  Local Definition wbtwn n m := ∀ i, n ≤ i → i < m → P i.

  (* Simulated constructors for weak between *)
  Local Fact wbtwn_refl n : wbtwn n n.
  Proof. intros ? H₁ H₂; destruct (lt_irrefl (le_lt_trans H₁ H₂)). Qed.

  Local Fact wbtwn_next {n m} : wbtwn n m → P m → wbtwn n (S m).
  Proof.
    intros Bnm Hm i H₁ H₂.
    destruct (le_S_n H₂); trivial.
    apply Bnm; trivial.
    now apply le_n_S.
  Qed.

  (* Between formulated in FO arithmetic *)
  Definition btwn n m := n ≤ m ∧ wbtwn n m.

  (* Simulated constructors for between *)
  Fact btwn_refl n : btwn n n.
  Proof. split; [apply le_n | apply wbtwn_refl]. Qed.

  Fact btwn_next n m : btwn n m → P m → btwn n (S m).
  Proof. intros [b w] p; split; [apply le_S, b | apply (wbtwn_next w p)]. Qed.

End btwn.

Arguments btwn_refl {P n}.
Arguments btwn_next {P n m}.

(* Monotonicity *)
Local Fact wbtwn_monotonic (P Q : nat → Prop) : P ⊆₁ Q → wbtwn P ⊆₂ wbtwn Q.
Proof. now intros M ? ? Hnm ? ? ?; apply M, Hnm. Qed.

Fact btwn_monotonic (P Q : nat → Prop) : P ⊆₁ Q → btwn P ⊆₂ btwn Q.
Proof.
  intros ? ? ? [? H]; split; trivial.
  revert H; now apply wbtwn_monotonic.
Qed.

Fact btwn_monotonic₁ {P Q : nat → Prop} s : P ⊆₁ Q → btwn P s ⊆₁ btwn Q s.
Proof. exact (λ i_pq, btwn_monotonic P Q i_pq s). Qed.

(* Choice property for between *)
Fact btwn_eq_or_holds {P a n m} : btwn P a n → btwn P a m → n = m ∨ P n ∨ P m.
Proof.
  intros [an wn] [am wm].
  destruct (lt_eq_lt_dec n m).
  + right; left; now apply wm.
  + now left.
  + right; right; now apply wn.
Qed.

(* A useful interval reverse induction principle for nat,
   suitable for btwn, see below *)
Local Definition nat_interval_rev_ind {P : nat → Prop} :
  ∀{a b}, a ≤ b → (∀n, a <= n → n < b → P (S n) → P n) → P b → P a :=
  fix loop {a b} (Hab : a <= b) :=
    match Hab with
      | le_n     => λ _  Pa,  Pa
      | le_S Hab => λ HP PSb, loop Hab (λ n Ha Hb, HP _ Ha (le_n_S (lt_le_weak Hb)))
                                       (HP _ Hab le_n PSb)
    end.

(* (Reverse) induction principle for between *)
Corollary btwn_ind (P : nat → Prop) a b : btwn (λ n, P (S n) → P n) a b → P b → P a.
Proof. intros [Hab HP]; exact (nat_interval_rev_ind Hab HP). Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (z : natural) (y : natural) (lf1 : natural) (lf2 : natural)
  : natural := plus (mult y z) z.


(** Anthony Bordg, June 2017 ********************************************

Contents:

- Bilinear morphisms between modules over a ring ([bilinearfun])
- Algebras over a commutative ring ([algebra]) and associative, commutative, unital algebras ([assoc_comm_unital_algebra]), see Serge Lang,
Algebra, III.1, p.121 in the revised third edition.
- Morphisms between (non-associative) algebras aver a commutative ring ([algebrafun])
- The opposite algebra ([algebra_opp])
- Subalgebras of an algebra ([subalgebra])

 ***********************************************)

Require Import UniMath.Algebra.Rigs_and_Rings.
Require Import UniMath.Algebra.Modules.
Require Import Types_and_groups_with_operators.

(** * Bilinear morphims between modules over a ring *)

Definition isbilinear {R : rng} {M N P : module R} (f : M -> N -> P) : UU :=
  (∏ x : M, ismodulefun (λ y : N, f x y) ) × (∏ y : N, ismodulefun (λ x : M, f x y)).

Definition bilinearfun {R : rng} (M N P : module R) : UU := ∑ f : M -> N -> P, isbilinear f.

Definition pr1bilinearfun {R : rng} {M N P : module R} (f : bilinearfun M N P) : M -> N -> P := pr1 f.

Coercion pr1bilinearfun : bilinearfun >-> Funclass.

(** * Algebras over a commutative ring *)

Section algebras.
Variable R : commrng.

(** Non-associative algebras over a commutative ring *)

Definition algebra : UU := ∑ M : module R, bilinearfun M M M.

Definition pr1algebra (A : algebra) : module R := pr1 A.

Coercion pr1algebra : algebra >-> module.

Definition algebra_pair (M : module R) (f : bilinearfun M M M) : algebra := tpair (λ X : module R, bilinearfun X X X) M f.

Definition mult_algebra (A : algebra) : binop A := pr1 (pr2 A).

Definition isbilinear_mult_algebra (A : algebra) : isbilinear (mult_algebra A) := pr2 (pr2 A).

Notation "x * y" := (mult_algebra _ x y) : algebras_scope.

Delimit Scope algebras_scope with algebras.

(** Commutative algebras over a commutative ring *)

Definition iscomm_algebra (A : algebra) : UU := iscomm (mult_algebra A).

Definition commalgebra : UU := ∑ A : algebra, iscomm_algebra A.

Definition commalgebra_pair (A : algebra) (is : iscomm_algebra A) : commalgebra := tpair _ A is.

Definition commalgebra_to_algebra (A : commalgebra) : algebra := pr1 A.

Coercion commalgebra_to_algebra : commalgebra >-> algebra.

(** Associative  algebras over a commutative ring *)

Definition isassoc_algebra (A : algebra) : UU := isassoc (mult_algebra A).

Definition assocalgebra : UU := ∑ A : algebra, isassoc_algebra A.

Definition assocalgebra_pair (A : algebra) (is : isassoc_algebra A) : assocalgebra := tpair _ A is.

Definition assocalgebra_to_algebra (A : assocalgebra) : algebra := pr1 A.

Coercion assocalgebra_to_algebra : assocalgebra >-> algebra.

(** Unital algebras over a commutative ring *)

Definition isunital_algebra (A : algebra) : UU := isunital (mult_algebra A).

Definition unitalalgebra : UU := ∑ A : algebra, isunital_algebra A.

Definition unitalalgebra_pair (A : algebra) (is : isunital_algebra A) : unitalalgebra := tpair _ A is.

Definition unitalalgebra_to_algebra (A : unitalalgebra) : algebra := pr1 A.

Coercion unitalalgebra_to_algebra : unitalalgebra >-> algebra.

(** Unital associative algebras over a commutative ring *)

Definition unital_assoc_algebra : UU := ∑ A : algebra, (isassoc_algebra A) × (isunital_algebra A).

Definition unital_assoc_algebra_to_algebra (A : unital_assoc_algebra) : algebra := pr1 A.

Coercion unital_assoc_algebra_to_algebra : unital_assoc_algebra >-> algebra.

(** Associative, commutative, unital algebras over a ring *)

Definition assoc_comm_unital_algebra : UU := ∑ A : unital_assoc_algebra, iscomm_algebra A.

(** Morphisms between (non-associative) algebras over a commutative ring *)

Local Open Scope algebras.

Definition algebrafun (A B : algebra) : UU := ∑ f : modulefun A B, ∏ x y : A, f (x * y) = f x * f y.

(** * The opposite algebra  *)

Definition mult_opp (A : algebra) : A -> A -> A := λ x y : A, y * x.

Definition isbilinear_mult_opp (A : algebra) : isbilinear (mult_opp A).
Proof.
  apply dirprodpair.
  - intro a. apply dirprodpair.
    + intros x x'. apply (pr1 (pr2 (isbilinear_mult_algebra A) a) x x').
    + intros r b. apply (pr2 (pr2  (isbilinear_mult_algebra A) a) r b).
  - intro a. apply dirprodpair.
    + intros x x'. apply (pr1 (pr1 (isbilinear_mult_algebra A) a) x x').
    + intros r b. apply (pr2 (pr1  (isbilinear_mult_algebra A) a) r b).
Defined.

Definition bilinear_mult_opp (A : algebra) : bilinearfun A A A := tpair _ (mult_opp A) (isbilinear_mult_opp A).

Definition algebra_opp (A : algebra) : algebra := tpair (λ X : module R, bilinearfun X X X) A (bilinear_mult_opp A).

(** * Subalgebras of an algebra *)

Definition subalgebra (A : algebra) : UU := ∑ B : submodule (pr1 A), isstable_by_action (mult_algebra A) (pr1 B).

Definition subalgebra_to_module {A : algebra} (B : subalgebra A) : module R := submodule_to_module (pr1 B).

Definition subalgebra_to_mult {A : algebra} (B : subalgebra A) : binop (subalgebra_to_module B).
Proof.
  intros x y.
  split with (mult_algebra A (pr1 x) (pr1 y)).
  exact (pr2 B (pr1 x) (pr1 y) (pr2 y)).
Defined.

Definition isbilinear_subalgebra_to_mult {A : algebra } (B : subalgebra A) : isbilinear (subalgebra_to_mult B).
Proof.
  apply dirprodpair.
  - intro x. unfold ismodulefun.
    apply dirprodpair.
    +  unfold isbinopfun. intros x0 x'.
       use total2_paths2_f.
       apply (dirprod_pr1 (pr2 (pr2 A))).
       apply propproperty.
    +  intros r y.
       use total2_paths2_f.
       apply (dirprod_pr1 (pr2 (pr2 A))).
       apply propproperty.
  - intro y. apply dirprodpair.
    + intros x x'.
      use total2_paths2_f.
      apply (dirprod_pr2 (pr2 (pr2 A))).
      apply propproperty.
    + intros r x.
      use total2_paths2_f.
      apply (dirprod_pr2 (pr2 (pr2 A))).
      apply propproperty.
Defined.

Definition subalgebra_to_bilinearfun {A : algebra} (B : subalgebra A) :
  bilinearfun (subalgebra_to_module B) (subalgebra_to_module B) (subalgebra_to_module B) :=
    tpair _ (subalgebra_to_mult B) (isbilinear_subalgebra_to_mult B).

Definition subalgebra_to_algebra {A : algebra} (B : subalgebra A) : algebra :=
  algebra_pair (subalgebra_to_module B) (subalgebra_to_bilinearfun B).

End algebras.


Definition my_False : Prop := forall P:Prop, P.

Definition my_not (P:Prop) : Prop := P -> my_False.

Definition my_and (P Q:Prop) : Prop := forall R:Prop, (P -> Q -> R) -> R.

Definition my_or (P Q:Prop) : Prop :=
  forall R:Prop, (P -> R) -> (Q -> R) -> R.

Definition my_ex (A:Set) (P:A -> Prop) : Prop :=
  forall R:Prop, (forall x:A, P x -> R) -> R.

Theorem my_and_left : forall P Q:Prop, my_and P Q -> P.
Proof.
 intros P Q H; apply H; auto.
Qed.

Theorem my_and_right : forall P Q:Prop, my_and P Q -> Q.
Proof.
 intros P Q H; apply H; auto.
Qed.

Theorem my_and_ind : forall P Q R:Prop, (P -> Q -> R) -> my_and P Q -> R.
Proof.
  intros P Q R H H0; apply H0; assumption.
Qed.

Theorem my_or_introl : forall P Q:Prop, P -> my_or P Q.
Proof.
  unfold my_or; auto.
Qed.

Theorem my_or_intror : forall P Q:Prop, Q -> my_or P Q.
Proof.
  unfold my_or; auto.
Qed.

Theorem my_or_ind : forall P Q R:Prop, (P -> R) -> (Q -> R) -> my_or P Q -> R.
Proof.
  intros P Q R H H0 H1; apply H1; assumption.
Qed.

Theorem my_or_False : forall P:Prop, my_or P my_False -> P.
Proof.
 unfold my_False; intros P H; apply H; intro H0; apply H0.
Qed.

Theorem my_or_comm : forall P Q:Prop, my_or P Q -> my_or Q P.
Proof.
 intros P Q H; apply H; intros H0 R; auto.
Qed.

Theorem my_ex_intro : forall (A:Set) (P:A -> Prop) (a:A), P a -> my_ex A P.
Proof.
 intros A P a Ha R H; eapply H; eauto.
Qed.

Theorem my_not_ex_all :
 forall (A:Set) (P:A -> Prop), my_not (my_ex A P) -> forall a:A, my_not (P a).
Proof.
 intros A P H a H'.
 apply H; eapply my_ex_intro; eauto.
Qed.

Theorem my_ex_ex : forall (A:Set) (P:A -> Prop), my_ex A P -> ex P.
Proof.
 intros A P H; apply H.
 intros x Hx; exists x; assumption.
Qed.

Theorem ex_my_ex : forall (A:Set) (P:A -> Prop), ex P -> my_ex _ P.
Proof.
 intros A P H; elim H; intros x Hx R.
 intros H0; eapply H0; eapply Hx.
Qed.


(* De Morgan Algebra *)

(** A De Morgan algebra is an algebraic structure ([A], [∨], [∧], [¬]) consisting of:
    - a set [A].
    - three binary operations [∨], [∧] and [¬] on [A], such that
      - ([A], [∨], [∧]) is a bounded distributive lattice.
      - [¬] is a De Morgan involution.
 *)

Parameter A : Set.

Parameter O : A.
Parameter I : A.

Parameter join : A -> A -> A.
Infix "∨" := join (left associativity, at level 50): type_scope.

Parameter meet : A -> A -> A.
Infix "∧" := meet (left associativity, at level 50): type_scope.

Parameter involution : A -> A.
Notation "¬ x" := (involution x) (at level 50): type_scope.

Axiom join_commutativity : forall a b, a ∨ b = b ∨ a.
Axiom meet_commutativity : forall a b, a ∧ b = b ∧ a.

Axiom join_associativity : forall a b c, a ∨ (b ∨ c) = (a ∨ b) ∨ c.
Axiom meet_associativity : forall a b c, a ∧ (b ∧ c) = (a ∧ b) ∧ c.

Axiom join_absorptivity : forall a b, a ∨ (a ∧ b) = a.
Axiom meet_absorptivity : forall a b, a ∧ (a ∨ b) = a.

(* bounded lattice *)
Axiom join_identity_element_existence : forall a, a ∨ O = a /\ O ∨ a = a.
Axiom meet_identity_element_existence : forall a, a ∧ I = a /\ I ∧ a = a.

(* distributive lattice *)
Axiom left_distributivity : forall a b c, a ∨ (b ∧ c) = (a ∨ b) ∧ (a ∨ c).
(* right_distributivity follows from join_commutativity and left_distributivity:
   (a ∧ b) ∨ c = c ∨ (a ∧ b) = (c ∨ a) ∧ (c ∨ b) = (a ∨ c) ∧ (b ∨ c).
 *)
Theorem right_distributivity: forall a b c, (a ∧ b) ∨ c = (a ∨ c) ∧ (b ∨ c).
Proof.
  intros a b c.
  rewrite <- join_commutativity.
  rewrite -> left_distributivity.
  pattern (c ∨ a); rewrite <- join_commutativity.
  pattern (c ∨ b); rewrite <- join_commutativity.
  trivial.
Qed.

(* De Morgan's laws *)
Axiom de_morgan_1 : forall a b, ¬(a ∧ b) = ¬a ∨ ¬b.
Axiom de_morgan_2 : forall a, ¬(¬a) = a.


(* gcd a b with computation of a/gcd a b and b/gcd a b on the fly *)

Require Import Utf8 Arith Psatz.
Require Import Main.Misc Misc.

Set Nested Proofs Allowed.

Tactic Notation "flia" hyp_list(Hs) := clear - Hs; lia.

Fixpoint ggcdn it a b :=
  match it with
  | 0 => (0, (0, 0))
  | S it' =>
      match a with
      | 0 => (b, (0, b / b))
      | _ =>
          match Nat.compare a b with
          | Eq => (a, (1, 1))
          | Lt =>
              let '(g, (a', b')) := ggcdn it' (b - a) a in
              (g, (b', a' + b'))
          | Gt =>
              let '(g, (a', b')) := ggcdn it' b (a - b) in
              (g, (a' + b', a'))
          end
      end
  end.
Definition ggcd a b := ggcdn (a + b + 1) a b.

Theorem ggcdn_gcd : ∀ a b n, a + b + 1 ≤ n → fst (ggcdn n a b) = Nat.gcd a b.
Proof.
intros * Hab.
revert a b Hab.
induction n; intros.
-now apply Nat.le_0_r, Nat.eq_add_0 in Hab.
-simpl.
 destruct a; [ easy | ].
 simpl in Hab.
 apply Nat.succ_le_mono in Hab.
 remember (Nat.compare (S a) b) as c eqn:Hc; symmetry in Hc.
 destruct c.
 +apply Nat.compare_eq_iff in Hc; rewrite Hc.
  now rewrite Nat.gcd_diag.
 +apply Nat.compare_lt_iff in Hc.
  specialize (IHn (b - S a) (S a)) as H1.
  assert (H : b - S a + S a + 1 ≤ n) by flia Hab Hc.
  specialize (H1 H); clear H.
  remember (ggcdn n (b - S a) (S a)) as gab eqn:Hgab.
  symmetry in Hgab.
  destruct gab as (g, (a', b')).
  rewrite Nat.gcd_comm, Nat.gcd_sub_diag_r in H1; [ easy | flia Hc ].
 +apply Nat.compare_gt_iff in Hc.
  destruct b.
  *destruct n; [ now rewrite Nat.add_comm in Hab | simpl ].
   now rewrite Nat.sub_diag.
  *specialize (IHn (S b) (S a - S b)) as H1.
   assert (H : S b + (S a - S b) + 1 ≤ n) by flia Hab Hc.
   specialize (H1 H); clear H.
   remember (ggcdn n (S b) (S a - S b)) as gab eqn:Hgab.
   symmetry in Hgab.
   destruct gab as (g, (a', b')).
   rewrite Nat.gcd_sub_diag_r in H1; [ | flia Hc ].
   now rewrite Nat.gcd_comm in H1.
Qed.

Theorem ggcd_gcd : ∀ a b, fst (ggcd a b) = Nat.gcd a b.
Proof. now intros; apply ggcdn_gcd. Qed.

Theorem ggcdn_correct_divisors : ∀ a b n,
  a + b + 1 ≤ n
  → let '(g, (aa, bb)) := ggcdn n a b in
     a = g * aa ∧ b = g * bb.
Proof.
intros * Hn.
remember (ggcdn n a b) as g eqn:Hg.
destruct g as (g, (aa, bb)).
revert a b g aa bb (*Hb*) Hn Hg.
induction n; intros; [ flia Hn | ].
simpl in Hg.
destruct a.
-injection Hg; clear Hg; intros; subst g aa bb.
 destruct b; [ easy | ].
 rewrite Nat.div_same; [ flia | easy ].
-remember (S a ?= b) as c1 eqn:Hc1; symmetry in Hc1.
 destruct c1.
 +apply Nat.compare_eq_iff in Hc1.
  subst b.
  injection Hg; clear Hg; intros; subst g aa bb; flia.
 +apply Nat.compare_lt_iff in Hc1.
  remember (ggcdn n (b - S a) (S a)) as g1 eqn:Hg1.
  destruct g1 as (g1, (aa1, bb1)).
  injection Hg; clear Hg; intros; subst g1 bb1 bb.
  specialize (IHn (b - S a) (S a) g aa1 aa (*Nat.neq_succ_0 a*)) as H1.
  assert (H : b - S a + S a + 1 ≤ n) by flia Hn Hc1.
  specialize (H1 H Hg1) as (H1, H2); clear H.
  split; [ easy | ].
  apply Nat.add_sub_eq_nz in H1; [ flia H1 H2 | ].
  intros H.
  apply Nat.eq_mul_0 in H.
  destruct H as [H| H]; [ now subst g | subst aa1; flia Hc1 H1 ].
 +apply Nat.compare_gt_iff in Hc1.
  remember (ggcdn n b (S a - b)) as g1 eqn:Hg1.
  destruct g1 as (g1, (aa1, bb1)).
  injection Hg; clear Hg; intros; subst g1 aa1 aa.
  destruct b.
  *rewrite Nat.sub_0_r in Hg1.
   destruct n; [ flia Hn | ].
   remember (S a) as aa; simpl in Hg1; subst aa.
   rewrite Nat.div_same in Hg1; [ | easy ].
   injection Hg1; clear Hg1; intros; subst g bb bb1.
   now rewrite Nat.add_0_l, Nat.mul_1_r, Nat.mul_0_r.
  *specialize (IHn (S b) (S a - S b) g bb bb1) as H1.
   assert (H : S b + (S a - S b) + 1 ≤ n) by flia Hn Hc1.
   specialize (H1 H Hg1) as (H1, H2); clear H.
   split; [ | easy ].
   apply Nat.add_sub_eq_nz in H2; [ flia H1 H2 | ].
   intros H.
   apply Nat.eq_mul_0 in H.
   destruct H as [H| H]; [ now subst g | subst bb1; flia Hc1 H2 ].
Qed.

Theorem ggcd_correct_divisors : ∀ a b,
  let '(g, (aa, bb)) := ggcd a b in
  a = g * aa ∧ b = g * bb.
Proof. now intros; apply ggcdn_correct_divisors. Qed.

Theorem ggcd_fst_snd : ∀ a b, fst (snd (ggcd a b)) = a / Nat.gcd a b.
Proof.
intros.
specialize (ggcd_correct_divisors a b) as H.
remember (ggcd a b) as g eqn:Hg.
destruct g as (g, (aa, bb)).
destruct H as (H1, H2); simpl.
destruct g.
-simpl in H1, H2; subst a b; simpl.
 unfold ggcd in Hg; simpl in Hg.
 now injection Hg; intros; subst aa.
-subst a b.
 specialize (ggcd_gcd (S g * aa) (S g * bb)) as H1.
 rewrite <- Hg in H1.
 rewrite <- H1.
 rewrite Nat.mul_comm, Nat.div_mul; [ easy | ].
 now intros H; simpl in H.
Qed.

Theorem ggcd_snd_snd : ∀ a b, snd (snd (ggcd a b)) = b / Nat.gcd a b.
Proof.
intros.
specialize (ggcd_correct_divisors a b) as H.
remember (ggcd a b) as g eqn:Hg.
destruct g as (g, (aa, bb)).
destruct H as (H1, H2); simpl.
destruct g.
-simpl in H1, H2; subst a b; simpl.
 unfold ggcd in Hg; simpl in Hg.
 now injection Hg; intros; subst bb.
-subst a b.
 specialize (ggcd_gcd (S g * aa) (S g * bb)) as H1.
 rewrite <- Hg in H1.
 rewrite <- H1.
 rewrite Nat.mul_comm, Nat.div_mul; [ easy | ].
 now intros H; simpl in H.
Qed.

Theorem ggcd_swap : ∀ a b g aa bb,
  ggcd a b = (g, (aa, bb)) → ggcd b a = (g, (bb, aa)).
Proof.
intros * Hab.
specialize (ggcd_fst_snd a b) as H1.
specialize (ggcd_snd_snd a b) as H2.
specialize (ggcd_fst_snd b a) as H3.
specialize (ggcd_snd_snd b a) as H4.
rewrite Hab in H1; simpl in H1.
rewrite Hab in H2; simpl in H2.
rewrite Nat.gcd_comm, <- H2 in H3.
rewrite Nat.gcd_comm, <- H1 in H4.
remember (ggcd b a) as g1 eqn:Hg1.
destruct g1 as (g1, (aa1, bb1)).
simpl in H3, H4; subst aa1 bb1; f_equal.
specialize (ggcd_gcd a b) as H3.
specialize (ggcd_gcd b a) as H4.
rewrite Hab in H3; simpl in H3.
rewrite <- Hg1 in H4; simpl in H4.
now rewrite Nat.gcd_comm, <- H3 in H4.
Qed.

Theorem ggcd_succ_l_neq_0 : ∀ a b, fst (snd (ggcd (S a) b)) ≠ 0.
Proof.
intros.
rewrite ggcd_fst_snd.
intros H1.
apply Nat.div_small_iff in H1.
+apply Nat.nle_gt in H1; apply H1.
 now apply Nat_gcd_le_l.
+intros H2.
 now apply Nat.gcd_eq_0_l in H2.
Qed.

Theorem ggcd_split : ∀ a b g,
  g = Nat.gcd a b → ggcd a b = (g, (a / g, b / g)).
Proof.
intros * Hg.
remember (ggcd a b) as g1 eqn:Hg1.
destruct g1 as (g1, (aa1, bb1)).
specialize (ggcd_gcd a b) as H1.
rewrite <- Hg1, <- Hg in H1; simpl in H1; subst g1.
specialize (ggcd_fst_snd a b) as H1.
rewrite <- Hg1, <- Hg in H1; simpl in H1; subst aa1.
specialize (ggcd_snd_snd a b) as H1.
rewrite <- Hg1, <- Hg in H1; simpl in H1; subst bb1.
easy.
Qed.

Theorem snd_ggcd_mul_mono_l : ∀ a b c,
  c ≠ 0
  → snd (ggcd (c * a) (c * b)) = snd (ggcd a b).
Proof.
intros * Hc.
remember (Nat.gcd (c * a) (c * b)) as g eqn:Hg.
rewrite (ggcd_split _ _ g); [ | easy ].
rewrite Nat.gcd_mul_mono_l in Hg.
remember (Nat.gcd a b) as g1 eqn:Hg1.
destruct g1.
-rewrite Nat.mul_0_r in Hg; subst g.
 symmetry in Hg1.
 apply Nat.gcd_eq_0 in Hg1.
 now destruct Hg1; subst a b.
-subst g.
 rewrite Nat.div_mul_cancel_l; [ | easy | easy ].
 rewrite Nat.div_mul_cancel_l; [ | easy | easy ].
 now rewrite (ggcd_split _ _ (S g1)).
Qed.

Theorem ggcd_mul_mono_l : ∀ a b c,
  c ≠ 0
  → ggcd (c * a) (c * b) = (c * Nat.gcd a b, snd (ggcd a b)).
Proof.
intros * Hc.
specialize (snd_ggcd_mul_mono_l a b c Hc) as H.
remember (ggcd (c * a) (c * b)) as g eqn:Hg.
destruct g as (g, (aa, bb)).
simpl in H; rewrite H; f_equal.
specialize (ggcd_gcd (c * a) (c * b)) as H1.
rewrite <- Hg in H1; simpl in H1.
now rewrite Nat.gcd_mul_mono_l in H1.
Qed.

Theorem ggcd_succ_l : ∀ a b g aa bb,
  ggcd (S a) b = (g, (aa, bb)) → g ≠ 0 ∧ aa ≠ 0.
Proof.
intros * Hg.
erewrite ggcd_split in Hg; [ | easy ].
remember S as f; simpl.
injection Hg; clear Hg; intros; subst g aa bb.
subst f.
split.
-now intros H; apply Nat.gcd_eq_0_l in H.
-intros H.
 apply Nat.div_small_iff in H.
 +apply Nat.nle_gt in H; apply H.
  now apply Nat_gcd_le_l.
 +now intros H1; apply Nat.gcd_eq_0_l in H1.
Qed.

Theorem ggcd_succ_r : ∀ a b g aa bb,
  ggcd a (S b) = (g, (aa, bb)) → g ≠ 0 ∧ bb ≠ 0.
Proof.
intros * Hg.
erewrite ggcd_split in Hg; [ | easy ].
remember S as f; simpl.
injection Hg; clear Hg; intros; subst g aa bb.
subst f.
split.
-now intros H; apply Nat.gcd_eq_0_r in H.
-intros H.
 apply Nat.div_small_iff in H.
 +apply Nat.nle_gt in H; apply H.
  now apply Nat_gcd_le_r.
 +now intros H1; apply Nat.gcd_eq_0_r in H1.
Qed.

Theorem ggcd_1_l : ∀ n, ggcd 1 n = (1, (1, n)).
Proof.
intros.
erewrite ggcd_split; [ | easy ].
rewrite Nat.gcd_1_l.
now do 2 rewrite Nat.div_1_r.
Qed.

Theorem ggcd_1_r : ∀ n, ggcd n 1 = (1, (n, 1)).
Proof.
intros.
erewrite ggcd_split; [ | easy ].
rewrite Nat.gcd_1_r.
now do 2 rewrite Nat.div_1_r.
Qed.

Theorem ggcd_diag : ∀ a, a ≠ 0 → ggcd a a = (a, (1, 1)).
Proof.
intros.
unfold ggcd.
rewrite Nat.add_1_r; simpl.
destruct a; [ easy | ].
now rewrite Nat.compare_refl.
Qed.


Require Export bbv.BinNotation.
Require Import Coq.ZArith.BinInt.

Notation "'Ob' a" := (Z.of_N (bin a)) (at level 50).

Goal Ob"01000001" = 65%Z.
Proof. reflexivity. Qed.


From mathcomp Require Import all_ssreflect.
Require Import extra.

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

Section tarjan.

Variable (V : finType) (successors : V -> seq V).
Notation infty := #|V|.

(**********************************************************)
(*               Tarjan 72 algorithm,                     *)
(* rewritten in a functional style by JJ Levy & Ran Chen  *)
(**********************************************************)

Definition split_after (T :eqType) (x : T) (s : seq T) :=
  let i := index x s in (rcons (take i s) x, drop i.+1 s).

Fixpoint rank (x : V) stack : nat :=
  if stack isn't y :: s then infty
  else if (x == y) && (x \notin s) then size s else rank x s.

Record env := Env {blacks : {set V}; stack : seq V; esccs : {set {set V}}}.
Definition grays (e : env) := [set x in stack e] :\: blacks e.
Definition whites (e : env) := ~: (grays e :|: blacks e).

Definition add_stack x e := Env (blacks e) (x :: stack e) (esccs e).
Definition add_blacks x e := Env (x |: blacks e) (stack e) (esccs e).
Definition add_sccs x e := let (s2, s3) := split_after x (stack e) in
                            Env (x |: blacks e) s3 ([set y in s2] |: esccs e).

Definition dfs1 (dfs' : {set V} -> env -> nat * env) (x : V) e :=
    let m := rank x (x :: stack e) in
    let: (m1, e1) := dfs' [set y in successors x] (add_stack x e) in
    if m1 < m then (m1, add_blacks x e1) else (infty, add_sccs x e1).

Definition dfs' dfs1 dfs' (roots : {set V}) e :=
  if [pick x in roots] isn't Some x then (infty, e)
  else let roots' := roots :\ x in
       let: (m1, e1) :=
         if x \in stack e then (rank x (stack e), e)
         else if x \in blacks e then (infty, e)
         else dfs1 x e in
       let: (m2, e2) := dfs' roots' e1 in (minn m1 m2, e2).

Fixpoint tarjan_rec n : {set V} -> env -> nat * env :=
  if n is n.+1 then dfs' (dfs1 (tarjan_rec n)) (tarjan_rec n)
  else fun r e => (infty, e).

Let N := #|V| * #|V|.+1 + #|V|.
Definition e0 := (Env set0 [::] set0).
Definition tarjan := esccs (tarjan_rec N setT e0).2.

(*****************)
(* Abbreviations *)
(*****************)

Notation edge := (grel successors).
Notation gconnect := (connect edge).
Notation gsymconnect := (symconnect edge).
Notation gsccs := (sccs edge).
Notation gscc_of := (pblock gsccs).

(**************************************************************)
(* Well formed environements and operations on environements. *)
(**************************************************************)

Inductive wf_env e := WfEnv {
   wf_stack : [set x in stack e] =
              grays e :|: (blacks e :\: cover (esccs e));
   wf_sccs : cover (esccs e) \subset blacks e;
   wf_stack_uniq : uniq (stack e)
}.

Inductive color_spec x e : bool -> bool -> bool -> bool -> bool -> Type :=
| ColorGray of x \in grays e : color_spec x e false true false true false
| ColorSccs of x \in cover (esccs e) :
                       color_spec x e true false true false false
| ColorWhite of x \in whites e : color_spec x e false false false false true
| ColorBlackStack of x \in blacks e & x \in stack e :
                        color_spec x e true true false false false.

Lemma colorP x e : wf_env e ->
                   color_spec x e (x \in blacks e) (x \in stack e)
                              (x \in cover (esccs e))
                              (x \in grays e) (x \in whites e).
Proof.
move=> [/setP /(_ x) s_def] /subsetP /(_ x) /implyP.
move: s_def; rewrite /grays /whites !inE.
case x_black: (_ \in blacks _) => /=;
case x_stack : (_ \in stack _) => /=;
case x_sccs : (_ \in cover _) => //=; do ?by constructor.
  by constructor=> //; rewrite /grays !inE x_black.
by constructor; rewrite /whites !inE x_black x_stack.
Qed.

Lemma grays0 : grays e0 = set0.
Proof. by apply/setP=> x; rewrite !inE /=. Qed.

Lemma cover0 : cover set0 = set0 :> {set V}.
Proof.
by apply/setP=> x; rewrite !inE; apply/negP=> /bigcupP[?]; rewrite inE.
Qed.

Lemma whites_blacksF x e : x \in whites e -> x \in blacks e = false.
Proof. by rewrite !inE; case: (x \in blacks _). Qed.

Lemma whites_stackF x e : x \in whites e -> x \in stack e = false.
Proof. by rewrite !inE andbC; case: (x \in stack _); rewrite //= orNb. Qed.

Lemma whites_graysF x e : x \in whites e -> x \in grays e = false.
Proof. by rewrite !inE andbC; case: (x \in stack _); rewrite //= orNb. Qed.

Lemma grays_stack x e : x \in grays e -> x \in stack e.
Proof. by rewrite !inE andbC; case: (x \in stack _). Qed.

Lemma grays_sccsF x e : wf_env e -> x \in grays e ->
   x \in cover (esccs e) = false.
Proof. by case/colorP. Qed.

Lemma sccs_stackF x e : wf_env e ->
  x \in cover (esccs e) -> x \in stack e = false.
Proof. by case/colorP. Qed.

Lemma whites_add_stack x e : whites (add_stack x e) = whites e :\ x.
Proof.
apply/setP=> y; rewrite !inE /=.
by case: (_ \in _) (_ \in _) (_ == _) => [] [] [].
Qed.

Lemma grays_add_stack x e : x \in whites e ->
  grays (add_stack x e) = x |: grays e.
Proof.
move=> x_whites; apply/setP=> y; move: x_whites; rewrite !inE.
by case: eqP => [->|]; case: (_ \in _) (_ \in _)=> [] [].
Qed.

Lemma stack_add_stack x e : stack (add_stack x e) = x :: stack e.
Proof. by []. Qed.

Lemma add_stack_ewf x e : x \in whites e -> wf_env e -> wf_env (add_stack x e).
Proof.
move=> x_white [s_def sccs_blacks s_uniq]; split => //=;
  last by rewrite whites_stackF.
apply/setP=> y; rewrite !inE.
by have [->|] := altP (y =P x); case: colorP=> //=; case: colorP x_white.
Qed.

Lemma add_blacks_ewf x e : x \in grays e -> wf_env e -> wf_env (add_blacks x e).
Proof.
move=> x_gray [s_def sccs_blacks s_uniq]; split => //=; last first.
  by rewrite subsetU // sccs_blacks orbT.
apply/setP=> y; rewrite !inE.
by have [->|] := altP (y =P x); case: colorP=> //=; case: colorP x_gray.
Qed.

Hint Resolve wf_stack_uniq : core.

Lemma add_sccs_wf x e :
  take (index x (stack e)) (stack e) \subset blacks e ->
  x \in grays e -> wf_env e -> wf_env (add_sccs x e).
Proof.
move=> /subsetP new_blacks x_gray e_wf.
have [s_def /subsetP sccs_blacks s_uniq] := e_wf.
split => //=; last first.
- by rewrite (subseq_uniq (drop_subseq _ _)).
- apply/subsetP=> y; rewrite !inE.
  rewrite /cover bigcup_setU inE big_set1 !inE /= => /orP[|/sccs_blacks->];
    last by rewrite !orbT.
  by rewrite mem_rcons !inE; case: eqP => //= _ /new_blacks.
apply/setP=> y; rewrite !inE /cover bigcup_setU inE big_set1 !inE !negb_or.
have [->|neq_xy] //= := altP (y =P x); rewrite ?(andbT, andbF).
  case: path.splitP new_blacks s_uniq => //=; first by rewrite grays_stack.
  move=> s1 s2 s1x_blacks s_uniq; rewrite grays_sccsF // andbT.
  by rewrite (uniq_catRL s_uniq) // mem_cat mem_rcons mem_head.
case: colorP; rewrite ?(andbT, andbF, orbT, orbF) //=.
  by move=> y_sccs; apply: contraTF y_sccs => /mem_drop; case: colorP.
move=> y_blacks; case: path.splitP s_uniq; first by rewrite grays_stack.
by move=> s1 s2 s_uniq y_in; apply: uniq_catRL.
Qed.

Lemma grays_add_blacks e x : grays (add_blacks x e) = grays e :\ x.
Proof. by apply/setP=> y; rewrite !inE /= negb_or andbA. Qed.

Lemma whites_add_blacks e x : whites (add_blacks x e) = whites e :\ x.
Proof.
by apply/setP=> y; rewrite !inE; case: (_ == _) (_ \in _) (_ \in _) => [] [].
Qed.

Lemma grays_add_sccs e x :
  let s := take (index x (stack e)) (stack e) in
  uniq (stack e) -> s \subset blacks e -> x \in grays e ->
  grays (add_sccs x e) = grays e :\ x.
Proof.
move=> /= se_uniq sb x_gray; rewrite /add_sccs /grays /=.
case: path.splitP sb se_uniq; first by rewrite grays_stack.
move=> s s' sb sxs'_uniq.
apply/setP=> y; rewrite !inE mem_cat mem_rcons in_cons.
have [->|] //= := altP eqP; rewrite orbC ![(y \notin _) && _]andbC.
have [|yNs' neq_yx] //= := boolP (y \in s').
by have [y_s|] //= := boolP (y \in s); rewrite (subsetP sb).
Qed.

Lemma whites_add_sccs e x :
  let s := take (index x (stack e)) (stack e) in
  x \in grays e -> uniq (stack e) -> s \subset blacks e ->
  whites (add_sccs x e) = whites e.
Proof.
move=> /= x_gray se_uniq sb; rewrite /whites grays_add_sccs //=.
by rewrite setUCA setUA setD1K.
Qed.

Lemma blacks_add_sccs e x : blacks (add_sccs x e) = x |: blacks e.
Proof. by []. Qed.

Lemma sccs_add_sccs e x :
  let s := take (index x (stack e)) (stack e) in
  esccs (add_sccs x e) = [set y in rcons s x] |: esccs e.
Proof. by []. Qed.

Lemma stack_add_sccs e x :
  let s := drop (index x (stack e)).+1 (stack e) in
  stack (add_sccs x e) = s.
Proof. by []. Qed.

(***************)
(* Rank Theory *)
(***************)

Lemma rankE x stack :
  rank x stack = if x \in stack then index x (rev stack) else infty.
Proof.
elim: stack => [|a s /= ->] //.
have [->|neq_xa] /= := altP eqP; rewrite rev_cons -cats1.
  by rewrite mem_head index_cat mem_rev /= eqxx addn0 size_rev; case: in_mem.
by rewrite in_cons (negPf neq_xa) /= index_cat /= mem_rev; case: in_mem.
Qed.

Lemma rank_cons x y s : rank x (y :: s) =
  if (x == y) && (x \notin s) then size s else rank x s.
Proof. by []. Qed.

Lemma rank_catl x s s' : x \in s' -> rank x (s ++ s') = rank x s'.
Proof.
by move=> x_s; rewrite !rankE rev_cat mem_cat x_s orbT index_cat mem_rev x_s.
Qed.

Lemma rank_catr x s s' :
  x \in s -> x \notin s' -> rank x (s ++ s') = size s' + rank x s.
Proof.
move=> x_s xNs'; rewrite !rankE rev_cat mem_cat x_s /=.
by rewrite index_cat mem_rev (negPf xNs') size_rev.
Qed.

Lemma rank_small x s : uniq s -> (rank x s < size s) = (x \in s).
Proof.
move=> s_uniq; rewrite rankE; case: (boolP (x \in s)) => [xNs|_].
  by rewrite -size_rev index_mem mem_rev.
apply: negbTE; rewrite -ltnNge ltnS cardE uniq_leq_size //.
by move=> y; rewrite mem_enum.
Qed.

Arguments rank : simpl never.

Lemma rank_le x (s : seq V) : uniq s -> rank x s <= infty.
Proof.
move=> s_uniq; rewrite rankE; case: ifP => // x_s.
by rewrite (leq_trans (index_size _ _)) ?size_rev -?(card_uniqP _) // max_card.
Qed.

Lemma rank_lt x (s : seq V) : uniq s -> (rank x s < infty) = (x \in s).
Proof.
rewrite rankE; case: ifPn; rewrite ?ltnn // => x_s s_uniq.
rewrite (@leq_trans (size (rev s))) ?index_mem ?mem_rev ?size_rev //.
by rewrite -?(card_uniqP _) // max_card.
Qed.

Lemma rank_infty x (s : seq V) : x \notin s -> rank x s = infty.
Proof. by rewrite rankE => /negPf->. Qed.

Lemma rank_mem x s : x \in s -> rank x s < size s.
Proof. by move=> x_s; rewrite rankE x_s -size_rev index_mem mem_rev. Qed.

Lemma rank_le_head s z x : x \notin s -> z \in s ->
  rank z (x :: s) < rank x (x :: s).
Proof.
by move=> xNs z_s; rewrite !rank_cons z_s andbF eqxx xNs /= rank_mem.
Qed.

(********************)
(*   Main Proof !   *)
(********************)

Definition noblack_to_white e :=
  forall x, x \in blacks e -> [disjoint successors x & whites e].

Inductive wf_graph e := WfGraph {
  wf_grays_to_stack : {in grays e & stack e, forall x y,
         (rank x (stack e) <= rank y (stack e)) -> gconnect x y};
  wf_stack_to_grays : forall y, y \in stack e ->
                      exists x, [/\ x \in grays e,
     (rank x (stack e) <= rank y (stack e)) & gconnect y x]
  }.

Definition access_to e (roots : {set V}) :=
  (forall x, x \in grays e ->
   forall y, y \in roots -> gconnect x y).

Definition black_gsccs e := [set scc in gsccs | scc \subset blacks e].

Inductive pre_dfs (roots : {set V}) (e : env) := PreDfs {
  pre_access_to : access_to e roots;
  pre_wf_env : wf_env e;
  pre_wf_graph : wf_graph e;
  wf_noblack_towhite : noblack_to_white e;
  pre_sccs : esccs e = black_gsccs e;
}.

Lemma add_stack_gwf e w :
  access_to e [set w] -> wf_env e -> w \in whites e -> wf_graph e ->
  wf_graph (add_stack w e).
Proof.
move=> grays_to e_wf w_white [gs sg]; split.
- rewrite grays_add_stack //= => x y; rewrite rank_cons !inE.
  move=> /orP[/eqP->|/andP[xNb xs]] /orP[/eqP->|/=ys];
  rewrite ?rank_cons ?eqxx ?(@whites_stackF w) ?xs ?ys ?(andbF, andbT) //=.
  + by rewrite leqNgt rank_small ?wf_stack_uniq // ys.
  + by move=> _; rewrite grays_to ?inE //= xNb.
  + by apply: gs; rewrite ?inE ?xNb.
- move=> y; rewrite inE => /predU1P [->|].
    exists w; rewrite ?grays_add_stack ?inE ?eqxx //.
    by rewrite whites_blacksF ?whites_stackF.
  move=> y_stack; have /sg [x [x_gray le_xy y_to_x]] := y_stack.
  exists x; split=> //.
    by rewrite grays_add_stack // inE x_gray orbT.
  rewrite stack_add_stack !rank_cons [x == w]negbTE /= 1?[y == w]negbTE //=.
    by apply: contraTneq y_stack => ->; rewrite whites_stackF.
  by apply: contraTneq x_gray => ->; rewrite whites_graysF.
Qed.

Lemma add_stack_pre e w :
  access_to e [set w] -> wf_env e -> w \in whites e -> wf_graph e ->
  access_to (add_stack w e) [set x in successors w].
Proof.
move=> grays_to e_wf w_white e_gwf.
move=> x; rewrite grays_add_stack // 2?inE => /predU1P [->|].
  by move=> y; rewrite inE => y_succ_w; rewrite connect1.
move=> /grays_to x_to_y y; rewrite inE => y_succ_w.
by rewrite (connect_trans _ (connect1 y_succ_w)) // x_to_y ?inE.
Qed.

Definition xedges (new old : seq V) :=
  [set y in old | [exists x in new, (x \notin old) && edge x y]].

Definition rank_of_reachable m x s :=
  exists2 y, y \in gconnect x & m = rank y s.

Definition post_dfs (roots : {set V}) (e e' : env) (m : nat) :=
[/\ [/\ wf_env e', wf_graph e', noblack_to_white e',
    grays e' = grays e & esccs e' = black_gsccs e'],

   [/\
    exists2 s, stack e' = s ++ stack e & s \subset (blacks e'),
    blacks e \subset blacks e'  & esccs e \subset esccs e' ]&

   [/\
    forall x, x \in roots -> m <= rank x (stack e'),
    m = infty \/ exists2 x, x \in roots & rank_of_reachable m x (stack e') &
    forall y, y \in xedges (stack e') (stack e) -> m <= rank y (stack e')
   ]
  ].

Definition dfs1_correct (dfs1 : V -> env -> nat * env) x e :=
  (x \in whites e) -> pre_dfs [set x] e ->
  let (m, e') := dfs1 x e in
  (x \in blacks e') /\ post_dfs [set x] e e' m.

Definition dfs'_correct (dfs' : {set V} -> env -> nat * env) roots e :=
  pre_dfs roots e ->
  let (m, e') := dfs' roots e in
  roots \subset blacks e' :|: grays e' /\ post_dfs roots e e' m.

Lemma pre_dfs_subroots (roots roots' : {set V}) e : roots' \subset roots ->
  pre_dfs roots e -> pre_dfs roots' e.
Proof.
move=> sub_roots [to_roots e_wf e_gwf black_sccs Nbw]; split=> //.
by move=> x x_gray y y_roots'; rewrite to_roots //; apply: subsetP y_roots'.
Qed.

Lemma dfs'_is_correct dfs1 dfsrec' (roots : {set V}) e :
  (forall x, x \in roots -> dfs1_correct dfs1 x e) ->
  (forall x, x \in roots -> forall e1, whites e1 \subset whites e ->
         dfs'_correct dfsrec' (roots :\ x) e1) ->
  dfs'_correct (dfs' dfs1 dfsrec') roots e.
Proof.
move=> dfs1_is_correct dfs'_is_correct; rewrite /dfs'_correct /dfs'.
case: pickP => [x|no_roots]; last first.
  move=> [gto_roots e_wf e_gwf black_sccs]; split=> //.
    by apply/subsetP=> x; rewrite !inE no_roots.
  split=> //; first by split=> //; first by exists [::] => //; apply/subsetP.
  split=> //; first by move=> x; rewrite no_roots.
    by left.
  by move=> y; rewrite inE => /andP[_ /existsP [x /and3P[->]]].
move=> x_root; have := dfs'_is_correct _ x_root; rewrite /dfs'_correct.
case: ifPn=> [x_stack|xNstack].
  move=> /(_ _ (subxx _)); case: (dfsrec' _ _) => [m2 e'].
  move=> e'_correct [to_roots e_wf e_gwf Nbw black_sccs].
  have e_uniq := wf_stack_uniq e_wf.
  case: e'_correct; first exact: (pre_dfs_subroots (subD1set _ _)).
  move=> change_color [invariants monotony [pc1 pc2 pc3]].
  split=> //.
  - rewrite -(setD1K x_root) subUset change_color sub1set !inE.
    have [//|xNblack /=] := boolP (x \in blacks _).
    by have [[s ->]] := monotony; rewrite mem_cat x_stack orbT.
  split=> //; split=> //.
  - move=> y y_root; have [->|neq_yx]:= eqVneq y x; last first.
      by rewrite geq_min pc1 ?orbT // !inE neq_yx.
    by have [[s -> _ _ _]] := monotony; rewrite rank_catl // geq_min leqnn.
  - right; case: (leqP (rank x (stack e)) m2) => [rx_small|/ltnW rx_big].
      exists x => //; exists x; rewrite ?inE ?connect0 //.
      by have [[s ->]] := monotony; rewrite rank_catl.
    case: pc2 rx_big=> [->|[y]]; first by rewrite leqNgt rank_lt ?x_stack.
    rewrite !inE => /andP[neq_yx y_roots [z y_to_z m_def]].
    by move=> m_small; exists y => //; exists z.
  - by move=> y y_xedge; rewrite (@leq_trans m2) ?pc3 // geq_min leqnn orbT.
case: ifPn=> [x_black|xNblack] //=.
  move=> /(_ _ (subxx _)); case: (dfsrec' _ _) => [m2 e'].
  move=> e'_correct [to_roots e_wf e_gwf Nbw black_sccs].
  case: e'_correct; first exact: (pre_dfs_subroots (subD1set _ _)).
  move=> change_color [[e'_wf e'_gwf keep_gray Nbw' sccs'_black]
                       [mon1 mon2 mon3] [pc1 pc2 pc3]].
  have e'_uniq := wf_stack_uniq e'_wf.
  split=> //.
    by rewrite -(setD1K x_root) subUset change_color sub1set !inE (subsetP mon2).
  have m2_rank: m2 <= infty by case: pc2=> [->|[?? [??->]]]; rewrite ?rank_le.
  split=> //; split=> //.
  - move=> y y_root; have [->{y y_root}|neq_yx]:= eqVneq y x; last first.
      by rewrite geq_min pc1 ?orbT // !inE neq_yx.
    rewrite rank_infty ?geq_min ?leqnn // sccs_stackF //.
    by apply: (subsetP (subset_cover mon3)); case: colorP x_black xNstack.
  - rewrite (minn_idPr _) //; case: pc2 => [->//|]; first by left.
    by move=> [y]; rewrite !inE => /andP[_ ?]; right; exists y.
  - by move=> y y_xedge; rewrite (@leq_trans m2) ?pc3 // geq_min leqnn orbT.
have := dfs1_is_correct _ x_root; rewrite /dfs1_correct.
case: (dfs1 _ _) => [m1 e1] post_dfs1.
move=> /(_ e1); case: (dfsrec' _ _) => [m2 e2] post_dfs'.
move=> pre {dfs1_is_correct dfs'_is_correct}.
have [e_access_to e_wf e_gwf Nbw sccs_black] := pre.
have e_uniq := wf_stack_uniq e_wf.
have x_white : x \in whites e by case: colorP xNstack xNblack.
have := post_dfs1 x_white (pre_dfs_subroots _ pre).
rewrite sub1set x_root => /(_ isT) {post_dfs1}.
case=> [x_black [[e1_wf e1_gwf Nbw1 keep_gray sccs_e1]
       [[s1 s1_def s1b] mo_b1 mo_sccs1] [pc1 pc2 pc3]]].
have e1_uniq := wf_stack_uniq e1_wf.
case: post_dfs'.
- by rewrite subCset setCK setUSS // keep_gray.
- split=> // y; rewrite !inE s1_def mem_cat.
  case: (y \in s1) (subsetP s1b y) => //= [->//|_ /andP[yNb ys]].
  move=> z; rewrite inE => /andP[_ z_roots]; rewrite e_access_to //.
  by rewrite !inE ys andbT; apply: contraNN yNb; apply/subsetP.
move=> rootsDx_subset [[e2_wf e2_gwf Nbw2 keep_gray2 sccs_e2]
  [[s2 s2_def s2b] mo_b2 mo_sccs2] [pc21 pc22 pc23]].
have e2_uniq := wf_stack_uniq e2_wf.
split.
  rewrite -(setD1K x_root) subUset rootsDx_subset andbT sub1set.
  by rewrite inE (subsetP mo_b2).
split; first by rewrite keep_gray2 keep_gray.
  split.
  + exists (s2 ++ s1); first by rewrite s2_def s1_def catA.
    apply/subsetP=> y; rewrite mem_cat => /orP [/(subsetP s2b) //|].
    by apply/subsetP/(subset_trans s1b).
  + exact/(subset_trans mo_b1).
  + exact/(subset_trans mo_sccs1).
have m1_rank: m1 <= infty by case: pc2=> [->|[?? [??->]]]; rewrite ?rank_le.
have m2_rank: m2 <= infty by case: pc22=> [->|[?? [??->]]]; rewrite ?rank_le.
split.
- move=> y y_roots; have [->|neq_yx] := eqVneq y x; last first.
    by rewrite (@leq_trans m2) ?geq_minr // pc21 // !inE neq_yx.
  have [xs|xNs] := boolP (x \in stack e1).
    by rewrite s2_def rank_catl // (@leq_trans m1) ?geq_minl // pc1 ?inE.
  have x_sccs2 : x \in cover (esccs e2).
    apply: (subsetP (subset_cover mo_sccs2)).
    by case: colorP xNs x_black.
  by rewrite rank_infty ?geq_min ?m1_rank //; case: colorP x_sccs2.
- case: pc22 => [->|m2_reachable].
  + rewrite (minn_idPl _) //; case: pc2=> [->|pc2]; [by left|].
    case: ltngtP m1_rank => // [m1_lt _|]; last by left.
    right; exists x => //.
    case: pc2=> z; rewrite inE => /eqP -> [t x_to_t m1_def].
    by exists t => //; rewrite s2_def rank_catl // -rank_lt -?m1_def.
  + case: (leqP m1 m2) => [m12|/ltnW m21]; last first.
      case: m2_reachable => y; rewrite !inE => /andP[_ y_root] [z y_to_z m2_def].
      by right; exists y => //; exists z => //.
    case: ltngtP m1_rank => // [m1_lt _|]; last by left.
    right; exists x => //; case: pc2=> [m1_infty|[z]].
      by rewrite m1_infty ltnn in m1_lt.
    rewrite inE => /eqP -> [t x_to_t m1_def].
    by exists t => //; rewrite s2_def rank_catl // -rank_lt -?m1_def.
- move=> y.
  rewrite !inE => /andP [y_s0 /existsP[z /and3P [z_s2 zNs0 z_to_y]]].
  move: z_s2; rewrite s2_def mem_cat orbC.
  have [z_s1 _|/= zNs1 z_s2] := boolP (z \in stack e1).
    rewrite rank_catl; last by rewrite s1_def mem_cat y_s0 orbT.
    rewrite (@leq_trans m1) ?geq_minl // pc3 // inE y_s0.
    by apply/existsP; exists z; rewrite z_s1 zNs0.
  rewrite -s2_def (@leq_trans m2) ?geq_minr // pc23 // inE.
  rewrite s1_def mem_cat y_s0 orbT /=.
  apply/existsP; exists z; rewrite s2_def mem_cat z_s2 /= [X in _ && X]z_to_y.
  by rewrite -s1_def zNs1.
Qed.

Lemma path_xset_xedge x y (s : pred V) :
  gconnect x y -> x \in s -> y \notin s ->
  exists x' y', [/\ x' \in s, y' \notin s,
                    gconnect x x', edge x' y' & gconnect y' y].
Proof.
move=> /connectP [p path_xp ->] xs yNs.
pose n := find (predC s) p.
have hasNs_p : has (predC s) p.
  apply/hasP; exists (last x p) => //=.
  have := mem_last x p; rewrite in_cons => /predU1P [eq_x|//].
  by rewrite eq_x xs in yNs.
have n_small : n < size p by rewrite -has_find.
exists (nth x (x :: p) n), (nth x p n).
rewrite [_ \notin s](@nth_find _ _ (predC s)) ?(pathP _ _) //.
have [->|n_gt0] := posnP n.
  rewrite ?nth0 /= xs connect0; split=> //.
    by case: (p) yNs path_xp => [|? ? _ /andP[]]; rewrite //= xs.
  case: p {yNs n hasNs_p n_small} path_xp => //= z p.
  by move=> /andP [xz zp]; rewrite (appP connectP idP) //; exists p.
rewrite -{1 2}[n]prednK //= -[_ \in s]negbK.
rewrite [_ \notin s](@before_find _ _ (predC s)) ?prednK //=.
split=> //.
  - apply/connectP; exists (take n p).
      by move: path_xp; rewrite -{1}[p](@cat_take_drop n) cat_path=> /andP[].
    rewrite (last_nth x) size_take n_small.
    by case: (n) n_gt0 => //= k _; rewrite nth_take.
  - by have /pathP/(_ _ n_small) :=  path_xp => /(_ x).
apply/connectP; exists (drop n.+1 p).
  move: path_xp; rewrite -{1}[p](@cat_take_drop n.+1) cat_path=> /andP[_].
  rewrite (last_nth x) /= size_take ltn_neqAle n_small andbT.
   by have [->|] := altP eqP; rewrite /= ?drop_size ?nth_take.
rewrite !(last_nth x) size_drop.
move: n_small; rewrite leq_eqVlt => /predU1P[<-|]; rewrite ?subnn //.
case: (size p) => //= - [|k] //; rewrite !ltnS => n_small.
by rewrite subSS subSn // [RHS]/= nth_drop addSn subnKC.
Qed.

Lemma dfs1_is_correct dfs' (x : V) e :
  (dfs'_correct dfs' [set y in successors x] (add_stack x e)) ->
  dfs1_correct (dfs1 dfs') x e.
Proof.
rewrite /dfs1 /dfs1_correct /dfs'_correct; case: (dfs' _ _) => m1 e1.
move=> post_dfs'; set m := rank x _.
move=> x_white [access_to_x e_wf e_gwf Nbw black_sccs].
have e_uniq := wf_stack_uniq e_wf.
case: post_dfs' => //=.
  split => //; do?[exact: add_stack_ewf|exact: add_stack_gwf]; last first.
     move=> y /Nbw; rewrite whites_add_stack.
     rewrite ![[disjoint successors _ & _]]disjoint_sym.
     by apply/disjointWl/subsetDl.
  move=> y; rewrite grays_add_stack // => /setU1P [->|]; last first.
    move=> y_gray z; rewrite inE => /(@connect1 _ edge).
    by apply/connect_trans/access_to_x; rewrite ?set11.
  by move=> z; rewrite inE => /(@connect1 _ edge).
move=> succ_bVg [[e1_wf e1_gwf Nbw1 keep_gray black_sccs1]
                   [[s/= s_def sb] mo_b mo_sccs] [pc1 pc2 pc3]].
set s2 := rcons s x.
have e1_uniq := wf_stack_uniq e1_wf.
have xe_uniq : uniq (x :: stack e).
  by have := e1_uniq; rewrite s_def cat_uniq => /and3P [].
have x_stack : x \in stack e1 by rewrite s_def mem_cat mem_head orbT.
have x_grays : x \in grays e1 by rewrite keep_gray grays_add_stack ?setU11.
have sx_subscc : is_subscc edge [set y in rcons s x].
  apply: (@is_subscc1 _ _ x); first by rewrite inE mem_rcons mem_head.
  move=> y; rewrite !inE mem_rcons in_cons => /predU1P [->//|y_s]; split.
    apply: (@wf_grays_to_stack e1) => //; first by rewrite s_def mem_cat y_s.
    rewrite s_def rank_catl ?mem_head // rank_catr //=; last first.
       by rewrite -(@uniq_catLR _ _ s) ?mem_cat ?y_s // -?s_def //.
    rewrite rankE mem_head (leq_trans (index_size _ _)) //.
    by rewrite size_rev leq_addr.
  have [] := @wf_stack_to_grays _ e1_gwf y; first by rewrite s_def mem_cat y_s.
  move=> z [z_gray rank_z] /connect_trans; apply.
  rewrite (@wf_grays_to_stack e1) // s_def.
  have := z_gray; rewrite !(inE, s_def) mem_cat.
  case: (boolP (z \in s)) => [/(subsetP sb)->//|_ /= /andP [_ z_xe]].
  rewrite !rank_catl ?mem_head //.
  move: z_xe; rewrite in_cons.
  have [->//|neq_zx /= z_s] := altP eqP.
  rewrite ltnW // rank_le_head //.
  rewrite -(@uniq_catLR _ _ (rcons s x)) ?mem_rcons ?mem_head //.
    by rewrite cat_rcons -s_def wf_stack_uniq.
  by rewrite mem_cat mem_rcons mem_head.
case: ltnP => [m1_small|m1_big] //=; rewrite !inE eqxx /=; split=> //.
  have [x1 rank_x1 x_to_x1] : exists2 x1,
    rank x1 (stack e1) = m1 & gconnect x x1.
    case: pc2 m1_small => [->|]; first by rewrite /m ltnNge ?rank_le.
    move=> [y]; rewrite inE => /(@connect1 _ edge) x_to_y.
    move=> [x1 y_to_x1 rank_x1 _]; exists x1 => //.
    by rewrite (connect_trans x_to_y).
  have [x' [rank_x' x'_gray x_to_x' ]] : exists x',
    [/\ rank x' (stack e1) < rank x (stack e1), x' \in grays e1 & gconnect x x'].
    move: m1_small; rewrite -{}rank_x1 => rank_x1.
    have x1_stack : x1 \in stack e1.
      by rewrite -rank_lt ?(leq_trans rank_x1) // rank_le.
    have [z [z_gray rank_z y_to_z]] := wf_stack_to_grays e1_gwf x1_stack.
    exists z; split=> //; rewrite 2?inE ?z_gray ?andbT.
    - rewrite (leq_ltn_trans rank_z) // (leq_trans rank_x1) // /m.
      by rewrite s_def rank_catl ?mem_head.
    - by rewrite (connect_trans x_to_x1).
  have neq_x'x : x' != x by apply: contraTneq rank_x' => ->; rewrite -ltnNge.
  split=> //.
  - split=> //; first exact: add_blacks_ewf.
    + split => //.
        move=> y z /=; rewrite grays_add_blacks => y_gray z_stack.
        apply: wf_grays_to_stack => //; apply: subsetP y_gray.
        by rewrite subD1set.
      move=> y /= y_stack; rewrite grays_add_blacks.
      have [z] // := wf_stack_to_grays e1_gwf y_stack.
      have [->{z} [_ rank_x y_to_x]|] := eqVneq z x; last first.
        move=> neq_zx [z_gray rank_z y_to_z].
        by exists z; split=> //; rewrite 2!inE neq_zx.
      exists x'; split; rewrite 2?inE ?x'_gray ?andbT //.
      - by rewrite (leq_trans _ rank_x) 1?ltnW // {2}s_def rank_catl ?mem_head.
      - by rewrite (connect_trans y_to_x).
    + move=> y; rewrite !inE whites_add_blacks.
      move=> /predU1P [->{y}|y_black]; last first.
        apply/pred0P=> z /=; rewrite 2!inE.
        have /pred0P /(_ z) /= := Nbw1 _ y_black.
        by apply: contraFF=> /and3P[->_->].
      apply/pred0P=> z /=; rewrite 2!inE.
      have /subsetP /(_ z) := succ_bVg.
      rewrite 2!inE => /implyP.
      by case: (_ \in successors _) (_ == _) colorP => [] [] [].
    + rewrite grays_add_blacks keep_gray grays_add_stack //.
      by rewrite setU1K // whites_graysF.
    + rewrite /= black_sccs1; apply/setP=> scc; rewrite !inE /=.
      have [scc_gsccs|] //= := boolP (scc \in gsccs).
      apply/idP/idP; first by move=> /subset_trans; apply; rewrite subsetU1.
      move=> /subsetP scc_sub; apply/subsetP => y y_scc.
      have /setU1P [eq_yx|//] := scc_sub y y_scc.
      rewrite eq_yx in y_scc.
      have x'_scc : (x' \in scc).
        rewrite -(def_scc scc_gsccs y_scc) // mem_scc /symconnect /= x_to_x' /=.
        by rewrite (wf_grays_to_stack e1_gwf) // ltnW.
      have /scc_sub := x'_scc.
      rewrite !inE (negPf neq_x'x) /=.
      by case: colorP x'_gray.
  - split=> //=.
    + exists (rcons s x); first by rewrite cat_rcons.
      apply/subsetP=> y; rewrite !inE mem_rcons in_cons=> /predU1P [->|].
        by rewrite eqxx.
      by move=> y_s; rewrite (subsetP sb) ?orbT.
    + by rewrite subsetU // mo_b orbT.
  - split=> //=.
    + move=> y; rewrite inE => /eqP->.
      by rewrite s_def rank_catl ?mem_head // ltnW.
    + by right; exists x; rewrite ?set11 //; exists x1.
    + move=> y; rewrite inE => /andP [y_stack /existsP].
      move=> [z /and3P[z_stack1 zNstack zy]].
      have [eq_zx|neq_zx] := eqVneq z x.
        by rewrite pc1 // -eq_zx inE.
      apply: pc3; rewrite inE in_cons y_stack orbT /=.
      apply/existsP; exists z.
      by rewrite z_stack1 in_cons negb_or neq_zx zNstack.
have scc_max : gscc_of x \subset [set y in s2].
  apply/subsetP=> y; rewrite inE=> y_sccx; apply: contraTT isT => yNs2.
  have xy : gconnect x y.
    by have := y_sccx; rewrite mem_scc /= => /andP[].
  have x_s2 : x \in s2 by rewrite mem_rcons mem_head.
  have [x' [y' [x'_s2 y'Ns xx' x'y' y'y]]] := path_xset_xedge xy x_s2 yNs2.
  apply: contraNN y'Ns => _.
  have: y' \in ([set y in stack e1] :|:
               (\bigcup_(scc in esccs e1) scc :|: whites e1)).
    by rewrite !inE; case: colorP.
  rewrite 3!inE => /or3P[].
  - rewrite s_def -cat_rcons mem_cat => /orP[//|y'_stack].
    have xNstack: x \notin stack e.
      rewrite -(@uniq_catLR _ x s2) ?mem_cat ?x_s2 //.
      by rewrite cat_rcons -s_def wf_stack_uniq.
    have x'Nstack: x' \notin stack e.
      rewrite -(@uniq_catLR _ x' s2) ?mem_cat ?x'_s2 //.
      by rewrite cat_rcons -s_def wf_stack_uniq.
    have rank_y': rank y' (x :: stack e) < rank x (x :: stack e).
      by rewrite rank_le_head //.
    have neq_y'x : y' != x by apply: contraTneq rank_y' => ->; rewrite ltnn.
    have [eq_x'x|neq_x'x] := eqVneq x' x.
      have := pc1 y'; rewrite inE -eq_x'x => /(_ x'y').
      rewrite leqNgt (leq_trans _ m1_big) // /m.
      by rewrite s_def rank_catl ?in_cons ?y'_stack ?orbT.
    apply: contraTT rank_y' => y'Ns2; rewrite -leqNgt.
    rewrite [rank y' _]rank_cons (negPf neq_y'x) /=.
    have := pc3 y'; rewrite inE in_cons y'_stack orbT /=.
    rewrite {2}s_def -cat_rcons rank_catl // => /(_ _) /(leq_trans _) -> //.
    apply/existsP; exists x'; rewrite s_def -cat_rcons mem_cat x'_s2 /=.
    by rewrite in_cons (negPf neq_x'x) /= x'Nstack.
  - move=> /bigcupP [scc'].
    rewrite black_sccs1 inE => /andP[scc'_gsccs scc'_black].
    move=> /def_scc - /(_ _ scc'_gsccs) eq_scc'; rewrite -eq_scc' in scc'_black.
    have : x \in gscc_of y'.
      have:= y_sccx; rewrite /= !mem_scc /symconnect /= andbC => /andP[yx _].
      by rewrite (connect_trans y'y) //= (connect_trans xx') //= connect1.
    by move=> /(subsetP scc'_black); case: colorP x_grays.
  - move: x'_s2; rewrite mem_rcons in_cons => /predU1P [eq_x'x|x_s].
      have /subsetP /(_ y') := succ_bVg.
      by rewrite 2!inE -eq_x'x => /(_ x'y'); case: colorP.
    have /(_ x') := Nbw1; rewrite (subsetP sb) => // /(_ isT).
    by move=> /pred0P /(_ y') /=; rewrite [_ \in _]x'y' /= => ->.
have take_s : take (index x (stack e1)) (stack e1) = s.
  rewrite s_def index_cat /= eqxx addn0.
  rewrite (@uniq_catLR _ _ _ (x :: stack e)) -?s_def ?wf_stack_uniq //.
  by rewrite mem_head /= ?s_def take_cat ltnn subnn take0 cats0.
have drop_s : drop (index x (stack e1)).+1 (stack e1) = stack e.
  rewrite s_def index_cat /= eqxx addn0.
  rewrite (@uniq_catLR _ _ _ (x :: stack e)) -?s_def ?wf_stack_uniq //.
  rewrite mem_head /= ?s_def drop_cat ltnNge leqW //.
  by rewrite subSn // subnn //= drop0.
have g1Nx : grays e1 :\ x = grays e.
  by rewrite keep_gray grays_add_stack // setU1K // whites_graysF.
split=> //.
- split=> //.
  + by apply: add_sccs_wf=> //; rewrite take_s //.
  + split=> //; rewrite ?grays_add_sccs ?stack_add_sccs ?take_s ?drop_s// ?g1Nx.
      exact: wf_grays_to_stack.
      exact: wf_stack_to_grays.
  + move=> y; rewrite !inE whites_add_sccs ?take_s //.
    move=> /predU1P [->|/Nbw1//]; apply/pred0P=> z //=.
    rewrite 2!inE; have /subsetP /(_ z) := succ_bVg.
    by rewrite 2!inE => /implyP; rewrite -negb_imply orbC => ->.
  + by rewrite grays_add_sccs ?take_s ?g1Nx.
  + rewrite sccs_add_sccs take_s //=; apply/setP=> scc.
    rewrite !inE blacks_add_sccs ?take_s//= black_sccs1 !inE.
    have x_s2 : x \in [set y in s2] by rewrite inE mem_rcons mem_head.
    have s2_gsccs : [set y in rcons s x] \in gsccs.
       apply/imsetP => /=; exists x => //.
      rewrite -[RHS](@def_scc _ edge _ x); last 2 first.
      * by apply/imsetP; exists x.
      * by rewrite !inE /symconnect ?connect0.
      apply/eqP; rewrite eqEsubset scc_max.
      have [scc' scc'_gsccs sub'] := is_subscc_in_scc sx_subscc.
      by rewrite (@def_scc _ edge scc') ?sub' //; apply: (subsetP sub').
    have [scc_gsccs|] //= := boolP (scc \in gsccs); last first.
      by apply: contraNF; rewrite orbF => /eqP->.
    apply/idP/idP.
      move=> /predU1P [->|].
        apply/subsetP => y; rewrite !inE mem_rcons in_cons.
        by case: eqP=> [->|] //= _ => /(subsetP sb).
      by move=> /subset_trans; apply; rewrite subsetU1.
    have [x_scc|xNscc] := boolP (x \in scc).
      by move=> _; rewrite -(def_scc scc_gsccs x_scc) // (def_scc s2_gsccs) ?eqxx.
    rewrite -subDset (setDidPl _); first by move->; rewrite orbT.
    by rewrite disjoint_sym (@eq_disjoint1 _ x) // => y; rewrite !inE.
- split=> //.
  + rewrite stack_add_sccs drop_s; exists [::] => //.
    by apply/subsetP=> y; rewrite inE.
  + by rewrite blacks_add_sccs ?take_s// (subset_trans mo_b) ?subsetU1.
  + by rewrite sccs_add_sccs take_s (subset_trans mo_sccs) ?subsetU1.
- split=> //; do ?by [left].
  + move=> y; rewrite inE => /eqP->.
    by rewrite stack_add_sccs drop_s leqNgt rank_lt ?whites_stackF.
  + move=> y; rewrite inE stack_add_sccs drop_s => /andP[_ /existsP].
    by move=> [z /and3P[->]].
Qed.

Theorem tarjan_rec_terminates n (roots : {set V}) e :
  n >= #|whites e| * #|V|.+1 + #|roots| ->
  dfs'_correct (tarjan_rec n) roots e.
Proof.
move=> n_ge; wlog ->: e n roots {n_ge} / roots = set0 => [noroot|]; last first.
  have := @dfs'_is_correct (dfs1 (tarjan_rec 0)) (tarjan_rec 0) set0 e.
  rewrite /tarjan_rec /dfs'_correct /dfs' /=.
  case: n=> [|n /=]; case: pickP => [x|_/=]; rewrite ?inE //;
  by apply => ?; rewrite inE.
have [V0|VN0] := posnP #|V|.
  have := max_card (mem roots).
  by rewrite V0 leqn0 cards_eq0 => /eqP /noroot; apply.
elim: n => [|n IHn] in roots e n_ge *.
  move: n_ge; rewrite leqn0 addn_eq0 cards_eq0.
  by move=> /andP [_ /eqP/noroot]; apply.
move=> pre; rewrite /dfs'_correct /=.
apply: dfs'_is_correct => //= x x_root.
  move=> x_white; apply: dfs1_is_correct => //; apply: IHn.
  rewrite whites_add_stack cardsDS ?sub1set // cards1 subn1.
  rewrite -ltnS (leq_trans _ n_ge) //.
  rewrite (@ltn_div2r #|V|.+1) ?divnMDl ?divn_small ?addn0 ?ltnS ?max_card //=.
  by rewrite prednK //; apply/card_gt0P; exists x.
move=> e1 whites_e1; apply: IHn; rewrite -ltnS (leq_trans _ n_ge) //.
have /subset_leq_card := whites_e1.
rewrite leq_eqVlt => /predU1P [->|lt_wh]; last first.
  by rewrite (@ltn_div2r #|V|.+1) ?divnMDl ?divn_small ?addn0 ?ltnS ?max_card.
by rewrite ltn_add2l [X in _ < X](cardsD1 x) x_root.
Qed.

Lemma tarjan_rec_is_correct :
  tarjan_rec N setT e0 = (infty, Env setT [::] gsccs).
Proof.
have := @tarjan_rec_terminates N setT e0; rewrite /dfs'_correct.
case: tarjan_rec => [m e] [].
- by rewrite ?leq_add ?leq_mul ?max_card.
- split=> //.
  + by move=> x; rewrite grays0 inE.
  + by split=> //; rewrite /= ?cover0 ?grays0 ?set0D ?setU0.
  + by move=> x; rewrite inE.
  + apply/setP=> y; rewrite !inE /= subset0 andbC; case: eqP => //= ->.
    by have /and3P [_ _ /negPf->] := sccs_partition edge.
rewrite subTset => /eqP blackse [[[stack_wf _ _] _ _]].
rewrite grays0 => grayse; rewrite grayse setU0 in blackse.
rewrite /black_gsccs /= blackse => sccse _ [_ minfty _].
have {}sccse: esccs e = gsccs.
  by apply/setP=> scc; rewrite sccse inE subsetT andbT.
have stacke : stack e = [::].
  have := stack_wf; rewrite grayse blackse sccse cover_sccs set0U setDv.
  by case: stack => // x s /setP /(_ x); rewrite !inE eqxx.
congr (_, _); first by case: minfty => // [[x _ [y xy]]]; rewrite stacke.
by case: e blackse sccse stacke {stack_wf grayse minfty} => //= *; congr Env.
Qed.

Theorem tarjan_correct : tarjan = gsccs.
Proof. by rewrite /tarjan tarjan_rec_is_correct. Qed.

End tarjan.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (y : natural) : natural := mult lf1 y.


Require Import Logic_and_Set_Theory.
Require Import EoM_Zorns_Lemma.
Require Import L_1_4_10_EoM_Intro.
From Coq Require Import Powerset_facts.
From Coq Require Import Finite_sets.
From Coq Require Import Powerset_Classical_facts.
From Coq Require Import Finite_sets_facts.
From Coq Require Import Constructive_sets.

Lemma Strong_Weakening: forall (Pi : Ensemble Formula) (f : Formula), ND Pi f -> forall (Gamma : Ensemble Formula), Inc Pi Gamma -> ND Gamma f.
Proof.
    intros Pi f H. induction H; intros.
    -apply ax. apply H0. apply H.
    -apply conjE1 with (f2:=f2). apply IHND. apply H0.
    -apply conjE2 with (f1:=f1). apply IHND. apply H0.
    -apply conjI.
        +apply IHND1. apply H1.
        +apply IHND2. apply H1.
    -apply disjE with (f1:=f1) (f2:=f2).
        +apply IHND1. apply incl_add. apply H2.
        +apply IHND2. apply incl_add. apply H2.
        +apply IHND3. apply H2.
    -apply disjI1. apply IHND. apply H0.
    -apply disjI2. apply IHND. apply H0.
    -apply impE with (f1:=f1).
        +apply IHND1. apply H1.
        +apply IHND2. apply H1.
    -apply impI. apply IHND. apply incl_add. apply H0.
    -apply negE with (f:=f).
        +apply IHND1. apply H1.
        +apply IHND2. apply H1.
    -apply negI. apply IHND. apply incl_add. apply H0.
    -apply botE. apply IHND. apply H0.
    -apply RAA. apply IHND. apply incl_add. apply H0.
    Qed.