(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Greatest Common Divisor *)

Require Import NZAxioms NZMulOrder.

(** Interface of a gcd function, then its specification on naturals *)

Module Type Gcd (Import A : Typ).
 Parameter Inline gcd : t -> t -> t.
End Gcd.

Module Type NZGcdSpec (A : NZOrdAxiomsSig')(B : Gcd A).
 Import A B.
 Definition divide n m := exists p, n*p == m.
 Local Notation "( n | m )" := (divide n m) (at level 0).
 Axiom gcd_divide_l : forall n m, (gcd n m | n).
 Axiom gcd_divide_r : forall n m, (gcd n m | m).
 Axiom gcd_greatest : forall n m p, (p | n) -> (p | m) -> (p | gcd n m).
 Axiom gcd_nonneg : forall n m, 0 <= gcd n m.
End NZGcdSpec.

Module Type DivideNotation (A:NZOrdAxiomsSig')(B:Gcd A)(C:NZGcdSpec A B).
 Import A B C.
 Notation "( n | m )" := (divide n m) (at level 0).
End DivideNotation.

Module Type NZGcd (A : NZOrdAxiomsSig) := Gcd A <+ NZGcdSpec A.
Module Type NZGcd' (A : NZOrdAxiomsSig) :=
 Gcd A <+ NZGcdSpec A <+ DivideNotation A.

(** Derived properties of gcd *)

Module NZGcdProp
 (Import A : NZOrdAxiomsSig')
 (Import B : NZGcd' A)
 (Import C : NZMulOrderProp A).

(** Results concerning divisibility*)

Instance divide_wd : Proper (eq==>eq==>iff) divide.
Proof.
 unfold divide. intros x x' Hx y y' Hy.
 setoid_rewrite Hx. setoid_rewrite Hy. easy.
Qed.

Lemma divide_1_l : forall n, (1 | n).
Proof.
 intros n. exists n. now nzsimpl.
Qed.

Lemma divide_0_r : forall n, (n | 0).
Proof.
 intros n. exists 0. now nzsimpl.
Qed.

Hint Rewrite divide_1_l divide_0_r : nz.

Lemma divide_0_l : forall n, (0 | n) -> n==0.
Proof.
 intros n (m,Hm). revert Hm. now nzsimpl.
Qed.

Lemma eq_mul_1_nonneg : forall n m,
 0<=n -> n*m == 1 -> n==1 /\ m==1.
Proof.
 intros n m Hn H.
 le_elim Hn.
 destruct (lt_ge_cases m 0) as [Hm|Hm].
 generalize (mul_pos_neg n m Hn Hm). order'.
 le_elim Hm.
 apply le_succ_l in Hn. rewrite <- one_succ in Hn.
 le_elim Hn.
 generalize (lt_1_mul_pos n m Hn Hm). order.
 rewrite <- Hn, mul_1_l in H. now split.
 rewrite <- Hm, mul_0_r in H. order'.
 rewrite <- Hn, mul_0_l in H. order'.
Qed.

Lemma divide_1_r_nonneg : forall n, 0<=n -> (n | 1) -> n==1.
Proof.
 intros n Hn (m,Hm). now apply (eq_mul_1_nonneg n m).
Qed.

Lemma divide_refl : forall n, (n | n).
Proof.
 intros n. exists 1. now nzsimpl.
Qed.

Lemma divide_trans : forall n m p, (n | m) -> (m | p) -> (n | p).
Proof.
 intros n m p (q,Hq) (r,Hr). exists (q*r).
 now rewrite mul_assoc, Hq.
Qed.

Instance divide_reflexive : Reflexive divide := divide_refl.
Instance divide_transitive : Transitive divide := divide_trans.

(** Due to sign, no general antisymmetry result *)

Lemma divide_antisym_nonneg : forall n m,
 0<=n -> 0<=m -> (n | m) -> (m | n) -> n == m.
Proof.
 intros n m Hn Hm (q,Hq) (r,Hr).
 le_elim Hn.
 destruct (lt_ge_cases q 0) as [Hq'|Hq'].
 generalize (mul_pos_neg n q Hn Hq'). order.
 rewrite <- Hq, <- mul_assoc in Hr.
 apply mul_id_r in Hr; [|order].
 destruct (eq_mul_1_nonneg q r) as [H _]; trivial.
 now rewrite H, mul_1_r in Hq.
 rewrite <- Hn, mul_0_l in Hq. now rewrite <- Hn.
Qed.

Lemma mul_divide_mono_l : forall n m p, (n | m) -> (p * n | p * m).
Proof.
 intros n m p (q,Hq). exists q. now rewrite <- mul_assoc, Hq.
Qed.

Lemma mul_divide_mono_r : forall n m p, (n | m) -> (n * p | m * p).
Proof.
 intros n m p (q,Hq). exists q. now rewrite mul_shuffle0, Hq.
Qed.

Lemma mul_divide_cancel_l : forall n m p, p ~= 0 ->
 ((p * n | p * m) <-> (n | m)).
Proof.
 intros n m p Hp. split.
 intros (q,Hq). exists q. now rewrite <- mul_assoc, mul_cancel_l in Hq.
 apply mul_divide_mono_l.
Qed.

Lemma mul_divide_cancel_r : forall n m p, p ~= 0 ->
 ((n * p | m * p) <-> (n | m)).
Proof.
 intros. rewrite 2 (mul_comm _ p). now apply mul_divide_cancel_l.
Qed.

Lemma divide_add_r : forall n m p, (n | m) -> (n | p) -> (n | m + p).
Proof.
 intros n m p (q,Hq) (r,Hr). exists (q+r).
 now rewrite mul_add_distr_l, Hq, Hr.
Qed.

Lemma divide_mul_l : forall n m p, (n | m) -> (n | m * p).
Proof.
 intros n m p (q,Hq). exists (q*p). now rewrite mul_assoc, Hq.
Qed.

Lemma divide_mul_r : forall n m p, (n | p) -> (n | m * p).
Proof.
 intros n m p. rewrite mul_comm. apply divide_mul_l.
Qed.

Lemma divide_factor_l : forall n m, (n | n * m).
Proof.
 intros. apply divide_mul_l, divide_refl.
Qed.

Lemma divide_factor_r : forall n m, (n | m * n).
Proof.
 intros. apply divide_mul_r, divide_refl.
Qed.

Lemma divide_pos_le : forall n m, 0 < m -> (n | m) -> n <= m.
Proof.
 intros n m Hm (q,Hq).
 destruct (le_gt_cases n 0) as [Hn|Hn]. order.
 rewrite <- Hq.
 destruct (lt_ge_cases q 0) as [Hq'|Hq'].
 generalize (mul_pos_neg n q Hn Hq'). order.
 le_elim Hq'.
 rewrite <- (mul_1_r n) at 1. apply mul_le_mono_pos_l; trivial.
 now rewrite one_succ, le_succ_l.
 rewrite <- Hq', mul_0_r in Hq. order.
Qed.

(** Basic properties of gcd *)

Lemma gcd_unique : forall n m p,
 0<=p -> (p|n) -> (p|m) ->
 (forall q, (q|n) -> (q|m) -> (q|p)) ->
 gcd n m == p.
Proof.
 intros n m p Hp Hn Hm H.
 apply divide_antisym_nonneg; trivial. apply gcd_nonneg.
 apply H. apply gcd_divide_l. apply gcd_divide_r.
 now apply gcd_greatest.
Qed.

Instance gcd_wd : Proper (eq==>eq==>eq) gcd.
Proof.
 intros x x' Hx y y' Hy.
 apply gcd_unique.
 apply gcd_nonneg.
 rewrite Hx. apply gcd_divide_l.
 rewrite Hy. apply gcd_divide_r.
 intro. rewrite Hx, Hy. apply gcd_greatest.
Qed.

Lemma gcd_divide_iff : forall n m p,
  (p | gcd n m) <-> (p | n) /\ (p | m).
Proof.
 intros. split. split.
 transitivity (gcd n m); trivial using gcd_divide_l.
 transitivity (gcd n m); trivial using gcd_divide_r.
 intros (H,H'). now apply gcd_greatest.
Qed.

Lemma gcd_unique_alt : forall n m p, 0<=p ->
 (forall q, (q|p) <-> (q|n) /\ (q|m)) ->
 gcd n m == p.
Proof.
 intros n m p Hp H.
 apply gcd_unique; trivial.
 apply H. apply divide_refl.
 apply H. apply divide_refl.
 intros. apply H. now split.
Qed.

Lemma gcd_comm : forall n m, gcd n m == gcd m n.
Proof.
 intros. apply gcd_unique_alt; try apply gcd_nonneg.
 intros. rewrite and_comm. apply gcd_divide_iff.
Qed.

Lemma gcd_assoc : forall n m p, gcd n (gcd m p) == gcd (gcd n m) p.
Proof.
 intros. apply gcd_unique_alt; try apply gcd_nonneg.
 intros. now rewrite !gcd_divide_iff, and_assoc.
Qed.

Lemma gcd_0_l_nonneg : forall n, 0<=n -> gcd 0 n == n.
Proof.
 intros. apply gcd_unique; trivial.
 apply divide_0_r.
 apply divide_refl.
Qed.

Lemma gcd_0_r_nonneg : forall n, 0<=n -> gcd n 0 == n.
Proof.
 intros. now rewrite gcd_comm, gcd_0_l_nonneg.
Qed.

Lemma gcd_1_l : forall n, gcd 1 n == 1.
Proof.
 intros. apply gcd_unique; trivial using divide_1_l, le_0_1.
Qed.

Lemma gcd_1_r : forall n, gcd n 1 == 1.
Proof.
 intros. now rewrite gcd_comm, gcd_1_l.
Qed.

Lemma gcd_diag_nonneg : forall n, 0<=n -> gcd n n == n.
Proof.
 intros. apply gcd_unique; trivial using divide_refl.
Qed.

Lemma gcd_eq_0_l : forall n m, gcd n m == 0 -> n == 0.
Proof.
 intros.
 generalize (gcd_divide_l n m). rewrite H. apply divide_0_l.
Qed.

Lemma gcd_eq_0_r : forall n m, gcd n m == 0 -> m == 0.
Proof.
 intros. apply gcd_eq_0_l with n. now rewrite gcd_comm.
Qed.

Lemma gcd_eq_0 : forall n m, gcd n m == 0 <-> n == 0 /\ m == 0.
Proof.
 intros. split. split.
 now apply gcd_eq_0_l with m.
 now apply gcd_eq_0_r with n.
 intros (EQ,EQ'). rewrite EQ, EQ'. now apply gcd_0_r_nonneg.
Qed.

Lemma gcd_mul_diag_l : forall n m, 0<=n -> gcd n (n*m) == n.
Proof.
 intros n m Hn. apply gcd_unique_alt; trivial.
 intros q. split. split; trivial. now apply divide_mul_l.
 now destruct 1.
Qed.

Lemma divide_gcd_iff : forall n m, 0<=n -> ((n|m) <-> gcd n m == n).
Proof.
 intros n m Hn. split. intros (q,Hq). rewrite <- Hq.
 now apply gcd_mul_diag_l.
 intros EQ. rewrite <- EQ. apply gcd_divide_r.
Qed.

End NZGcdProp.


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

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*            Lemmas on sets, finite sets, totally ordered sets             *)
(*                            Coq V5.10                                     *)
(*                                                                          *)
(*   Some definitions and lemmas are borrowed from Floyd.v and Dijkstra.v   *)
(*                        in $COQTH/PROGRAMS                                *)
(*                                                                          *)
(*       E. Ledinot                                                         *)
(*       Dassault-Aviation                                                  *)
(*       March 1993                                                         *)
(*                                                                          *)
(****************************************************************************)
(*                               Finite_sets.v                              *)
(****************************************************************************)

(* Warning : Two axioms are introduced:
    Axiom V_decidable : (x,y:V){x=y}+{~x=y}.
    Axiom extensionality: (V,W:set)(set_eq V W) -> (P:set->Prop)(P V) -> (P W).
*)

Require Import Prelude0.
Require Import Gt.
Require Import Lt.

Section sets.

Variable V : Set. (* The Universe of discourse *)

Axiom V_decidable : forall x y : V, {x = y} + {x <> y}.

Definition set := V -> Prop.

Definition In (P : set) (x : V) := P x.

Definition incl (P Q : set) := forall x : V, In P x -> In Q x.

Definition incl_st (P Q : set) :=
  incl P Q /\ (exists x : V, ~ In P x /\ In Q x).

Lemma incl_refl : forall U : set, incl U U.
Proof.
intro U; unfold incl, In in |- *; auto with arith.
Qed.
Hint Resolve incl_refl.

Lemma incl_trans : forall W X Y : set, incl W X -> incl X Y -> incl W Y.
Proof.
unfold incl in |- *; auto with arith.
Qed.

Inductive set_eq : set -> set -> Prop :=
    Def_set_eq : forall U W : set, incl U W -> incl W U -> set_eq U W.
Hint Resolve Def_set_eq.

Lemma set_eq_inv : forall U W : set, set_eq U W -> incl U W /\ incl W U.
Proof.
simple induction 1; auto with arith.
Qed.

Lemma set_eq_refl : forall U : set, set_eq U U.
Proof.
auto with arith.
Qed.
Hint Resolve set_eq_refl.

Lemma set_eq_sym : forall V1 V2 : set, set_eq V1 V2 -> set_eq V2 V1.
Proof.
simple induction 1; auto with arith.
Qed.
Hint Immediate set_eq_sym: bdd.

Lemma set_eq_trans :
 forall V1 V2 V3 : set, set_eq V1 V2 -> set_eq V2 V3 -> set_eq V1 V3.
Proof.
intros V1 V2 V3 V1_eq_V2 V2_eq_V3.
cut (incl V1 V2 /\ incl V2 V1); try (apply set_eq_inv; trivial with arith).
cut (incl V2 V3 /\ incl V3 V2); try (apply set_eq_inv; trivial with arith).
simple induction 1; intros H23 H32.
simple induction 1; intros H12 H21.
apply Def_set_eq; apply incl_trans with (X := V2); trivial with arith.
Qed.

Axiom
  extensionality :
    forall U W : set, set_eq U W -> forall P : set -> Prop, P U -> P W.

Inductive inhabited (S : set) : Prop :=
    Def_inh : forall v : V, In S v -> inhabited S.

Definition empty : set := fun x : V => False.

Definition all_ : set := fun x : V => True.

Section Add.

Variable Q : set.
Variable x : V.

Definition add : set := fun y : V => In Q y \/ x = y.

Variable y : V.

Lemma in_Q_add : In Q y -> In add y.
Proof.
intro.
unfold In, add in |- *.
auto with arith.
Qed.

Lemma eq_add : x = y -> In add y.
Proof.
intro.
unfold In, add in |- *.
auto with arith.
Qed.

End Add.
Hint Resolve in_Q_add eq_add.

Lemma singlx : forall x y : V, In (add empty x) y -> x = y.
Proof.
intros x y.
unfold add, empty, In in |- *.
simple induction 1; auto with arith.
simple induction 1; auto with arith.
Qed.

(****************************)
(* Lemmas about sets        *)
(****************************)

Lemma in_empty : forall x : V, ~ In empty x.
Proof.
unfold not, In, empty in |- *; trivial with arith.
Qed.
Hint Resolve in_empty.

Lemma in_allV : forall x : V, In all_ x.
Proof.
unfold In, all_ in |- *; trivial with arith.
Qed.
Hint Resolve in_allV.

Lemma incl_allV : forall W : set, incl W all_.
Proof.
red in |- *; auto with arith.
Qed.
Hint Resolve incl_allV.

Lemma incl_empty : forall W : set, incl empty W.
Proof.
red in |- *; intros W x H.
elim H.
Qed.
Hint Resolve incl_empty.

Lemma incl_Q_add : forall (Q : set) (x : V), incl Q (add Q x).
Proof.
exact in_Q_add.
Qed.
Hint Resolve incl_Q_add.

Lemma in_add_x : forall (Q : set) (x : V), In (add Q x) x.
Proof.
unfold In, add in |- *; auto with arith.
Qed.
Hint Resolve in_add_x.

Lemma add_in_or_eq :
 forall (Q : set) (x y : V), In (add Q x) y -> In Q y \/ x = y.
Proof.
auto with arith.
Qed.

Lemma incl_add :
 forall (Q Q' : set) (y : V), incl Q Q' -> incl (add Q y) (add Q' y).
Proof.
red in |- *; intros.
red in |- *; red in |- *.
elim H0; auto with arith.
Qed.
Hint Resolve incl_add.

Lemma In_not_In : forall (Q : set) (x y : V), In Q x -> ~ In Q y -> x <> y.
Proof.
red in |- *; intros.
apply H0; elim H1; auto with arith.
Qed.

Lemma In_not_In_sym :
 forall (Q : set) (x y : V), In Q x -> ~ In Q y -> y <> x.
Proof.
intros; apply sym_not_equal; apply (In_not_In Q); auto with arith.
Qed.

Lemma add_inh : forall (S : set) (x : V), inhabited (add S x).
Proof.
intros S x.
apply Def_inh with x; auto with arith.
Qed.
Hint Resolve add_inh.

Lemma incl_add_x :
 forall (S1 S2 : set) (x : V),
 ~ In S1 x -> incl (add S1 x) (add S2 x) -> incl S1 S2.
Proof.
intros S1 S2 x x_out_S1.
unfold incl, add, In in |- *.
intros H y y_in_S1.
elim (H y); auto with arith.
intro H_abs.
unfold In in x_out_S1.
absurd (S1 x); auto with arith.
rewrite H_abs; trivial with arith.
Qed.

Lemma incl_st_add_x :
 forall (S1 S2 : set) (x : V),
 ~ In S1 x -> incl_st (add S1 x) (add S2 x) -> incl_st S1 S2.
Proof.
intros S1 S2 x x_out_S1.
unfold incl_st in |- *.
simple induction 1.
intro H_incl.
simple induction 1.
intros y Def_y.
split.
apply incl_add_x with (x := x); trivial with arith.
exists y.
elim Def_y; intros H1 H2.
split.
apply Contra with (In (add S1 x) y); auto with arith.
unfold add, In at 1 in H2.
elim H2; auto with arith.
intro H_abs.
absurd (In (add S1 x) x); auto with arith.
Qed.

(********************************)
(*     Operations on sets       *)
(********************************)

Definition inter (P Q : set) (x : V) := In P x /\ In Q x.

Definition union (P Q : set) (x : V) := In P x \/ In Q x.

Definition soustr (Q : set) (x y : V) := In Q y /\ x <> y.

Lemma inter_incl_l : forall P Q : set, incl (inter P Q) P.
Proof.
red in |- *; intros P Q x H; elim H; auto with arith.
Qed.
Hint Resolve inter_incl_l.

Lemma inter_incl_r : forall P Q : set, incl (inter P Q) Q.
Proof.
red in |- *; intros P Q x H; elim H; auto with arith.
Qed.
Hint Resolve inter_incl_r.

Lemma inter_intro :
 forall (P Q : set) (x : V), In P x -> In Q x -> In (inter P Q) x.
Proof.
red in |- *; red in |- *; auto with arith.
Qed.
Hint Resolve inter_intro.

Lemma notP_notinterPQ :
 forall (P Q : set) (x : V), ~ In P x -> ~ In (inter P Q) x.
Proof.
intros P Q x.
unfold not, inter, In in |- *; auto with arith.
intros H1 H2; apply H1; elim H2; auto with arith.
Qed.
Hint Resolve notP_notinterPQ.

Lemma notQ_notinterPQ :
 forall (P Q : set) (x : V), ~ In Q x -> ~ In (inter P Q) x.
Proof.
intros P Q x.
unfold not, inter, In in |- *; auto with arith.
intros H1 H2; apply H1; elim H2; auto with arith.
Qed.
Hint Resolve notQ_notinterPQ.

Lemma union_sym : forall P Q : set, set_eq (union P Q) (union Q P).
Proof.
intros P Q.
apply Def_set_eq; unfold union, incl, In in |- *; simple induction 1;
 auto with arith.
Qed.
Hint Immediate union_sym: bdd.

Lemma P_union_empty : forall P : set, set_eq (union P empty) P.
Proof.
intro P.
apply Def_set_eq; unfold union, incl, In in |- *; try simple induction 1;
 auto with arith.
unfold empty in |- *; contradiction.
Qed.
Hint Resolve P_union_empty.

Lemma empty_union_P : forall P : set, set_eq (union empty P) P.
Proof.
intro P.
apply Def_set_eq; unfold union, incl, In in |- *; try simple induction 1;
 auto with arith.
unfold empty in |- *; contradiction.
Qed.
Hint Resolve empty_union_P.

Lemma union_add :
 forall (P Q : set) (x : V), set_eq (union (add P x) Q) (add (union P Q) x).
Proof.
intros P Q x.
apply Def_set_eq; unfold incl, union, add, In in |- *; simple induction 1;
 try simple induction 1; auto with arith.
Qed.

Lemma incl_soustr_in :
 forall (M : set) (y : V), In M y -> incl (soustr M y) M.
Proof.
red in |- *; intros.
elim H0; auto with arith.
Qed.
Hint Resolve incl_soustr_in.

Lemma incl_soustr :
 forall (M M' : set) (y : V), incl M M' -> incl (soustr M y) (soustr M' y).
Proof.
unfold soustr in |- *; red in |- *; red in |- *; intros.
elim H0; intros.
apply conj; auto with arith.
Qed.
Hint Resolve incl_soustr.

Lemma not_In_soustr :
 forall (M : set) (y z : V), ~ In M y -> ~ In (soustr M z) y.
Proof.
red in |- *; intros.
elim H0; intros; apply H; auto with arith.
Qed.
Hint Resolve not_In_soustr.

Lemma not_In_soustr_eq : forall (M : set) (y : V), ~ In (soustr M y) y.
Proof.
red in |- *; intros.
elim H; intros.
apply H1; auto with arith.
Qed.
Hint Resolve not_In_soustr_eq.

Lemma still_in_soustr :
 forall (M : set) (x : V),
 In M x -> forall y : V, x <> y -> In (soustr M y) x.
Proof.
intros M x x_in_M y x_ne_y.
unfold In, soustr in |- *; auto with arith.
Qed.

Lemma incl_soustr_add_l :
 forall (M : set) (y : V), incl (soustr (add M y) y) M.
Proof.
red in |- *; intros.
elim H; intros.
elim H0; intros; auto with arith.
absurd (y = x); auto with arith.
Qed.
Hint Resolve incl_soustr_add_l.

Lemma incl_soustr_add_r :
 forall (M : set) (y : V), ~ In M y -> incl M (soustr (add M y) y).
Proof.
red in |- *; intros.
red in |- *; red in |- *.
apply conj; auto with arith.
red in |- *; intro; absurd (In M x); auto with arith.
elim H1; auto with arith.
Qed.
Hint Resolve incl_soustr_add_r.

Lemma add_soustr_2 :
 forall (Q : set) (y : V), In Q y -> incl Q (add (soustr Q y) y).
Proof.
intros.
red in |- *; intros.
red in |- *; red in |- *.
unfold In, soustr in |- *.
elim (V_decidable y x); intro; auto with arith.
Qed.
Hint Resolve add_soustr_2.

Lemma add_soustr_1 :
 forall (Q : set) (y : V), In Q y -> incl (add (soustr Q y) y) Q.
Proof.
intros.
red in |- *; intros.
elim H0; intros.
elim H1; auto with arith.
elim H1; assumption.
Qed.
Hint Resolve add_soustr_1.

Lemma add_soustr_xy :
 forall (Q : set) (x y : V),
 x <> y -> set_eq (soustr (add Q x) y) (add (soustr Q y) x).
Proof.
intros Q x y x_diff_y.
apply Def_set_eq; unfold incl, soustr, add, In in |- *; intros z Def_z.
elim Def_z; intros H1 H2.
elim H1; auto with arith.
elim Def_z; try (simple induction 1; auto with arith).
Qed.
Hint Resolve add_soustr_xy.

Lemma incl_st_add_soustr :
 forall (E1 E2 : set) (x : V),
 ~ In E1 x -> incl_st (add E1 x) E2 -> incl_st E1 (soustr E2 x).
Proof.
intros E1 E2 x x_not_in_E1 H.
unfold incl_st in |- *.
unfold incl_st in H.
elim H; intros H_incl H_Ex.
split.
apply incl_trans with (soustr (add E1 x) x); auto with arith.
elim H_Ex; intros y Def_y.
exists y.
split; elim Def_y; intros H1 H2.
apply Contra with (In (add E1 x) y); auto with arith.
apply still_in_soustr; auto with arith.
Qed.

Lemma addQxinterS_addQinterSx :
 forall (Q S : set) (x : V),
 ~ In Q x -> In S x -> incl (inter (add Q x) S) (add (inter Q S) x).
Proof.
intros Q S x x_not_in_Q x_in_S.
unfold incl, inter, add, In in |- *.
intros y H_y.
elim H_y; intros Qy_or_xeqy y_in_S.
elim Qy_or_xeqy; auto with arith.
Qed.
Hint Resolve addQxinterS_addQinterSx.

Lemma addQinterSx_addQxinterS :
 forall (Q S : set) (x : V),
 ~ In Q x -> In S x -> incl (add (inter Q S) x) (inter (add Q x) S).
Proof.
intros Q S x x_not_in_Q x_in_S.
unfold incl, inter, add, In in |- *.
intros y H_y.
elim H_y.
intro Qy_and_Sy; split; elim Qy_and_Sy; auto with arith.
simple induction 1; auto with arith.
Qed.
Hint Resolve addQinterSx_addQxinterS.

Lemma addQxinterS_QinterS :
 forall (Q S : set) (x : V),
 ~ In Q x -> ~ In S x -> incl (inter (add Q x) S) (inter Q S).
Proof.
intros Q S x x_not_in_Q x_not_in_S.
unfold incl, inter, add, In in |- *.
intro y; simple induction 1.
simple induction 1; auto with arith.
intros Exy Sy; split; auto with arith.
absurd (S y); trivial with arith.
elim Exy; trivial with arith.
Qed.
Hint Resolve addQxinterS_QinterS.

Lemma QinterS_addQxinterS :
 forall (Q S : set) (x : V),
 ~ In Q x -> ~ In S x -> incl (inter Q S) (inter (add Q x) S).
Proof.
intros Q S x x_not_in_Q x_not_in_S.
unfold incl, inter, add, In in |- *.
intros y.
simple induction 1; intros.
split; auto with arith.
Qed.
Hint Resolve QinterS_addQxinterS.

(**************************)
(*   Image by functions   *)
(**************************)

Definition Im (Q : set) (f : V -> V) : set :=
  fun y : V => exists x : V, In Q x /\ f x = y.

Lemma Im_add :
 forall (Q : set) (y : V) (f : V -> V),
 set_eq (Im (add Q y) f) (add (Im Q f) (f y)).
Proof.
intros Q y f.
apply Def_set_eq; unfold incl, Im, add, In in |- *; intro fx.
simple induction 1; intro x.
do 2 simple induction 1; intros.
elim H1. (* H1 : (Q x)\/y=x *)
left.
exists x; auto with arith.
right.
rewrite H4; trivial with arith. (* H4 : y=x *)
right.
rewrite H2; trivial with arith. (* H2 : y=x *)
do 2 simple induction 1.
intro x.
simple induction 1.
intros.
exists x; auto with arith.
exists y; auto with arith.
Qed.

(*********************)
(*    Finite sets    *)
(*********************)

Inductive finite : set -> Prop :=
  | finite_empty : finite empty
  | finite_add :
      forall (y : V) (Q : set), ~ In Q y -> finite Q -> finite (add Q y).
Hint Resolve finite_empty finite_add.

Inductive cardinal : set -> nat -> Prop :=
  | card_empty : cardinal empty 0
  | card_add :
      forall (E : set) (k : nat) (x : V),
      cardinal E k -> ~ In E x -> cardinal (add E x) (S k).
Hint Resolve card_empty card_add.

Let inv_card (E : set) (k : nat) : Prop :=
  match k with
  | O => set_eq E empty
  | S _ => True
  end.
(* O  *)
(* Sp *)

Lemma cardinal_inv : forall (E : set) (n : nat), cardinal E n -> inv_card E n.
Proof.
simple induction 1; unfold inv_card in |- *; auto with arith.
Qed.

Lemma cardinalO_empty : forall E : set, cardinal E 0 -> set_eq E empty.
Proof.
intros E CardO.
change (inv_card E 0) in |- *.
apply cardinal_inv; trivial with arith.
Qed.

Lemma inh_card_gt_O :
 forall E : set, inhabited E -> forall c : nat, cardinal E c -> c > 0.
intros E HE.
elim HE.
intros e Def_e c Def_c.
elim (gt_O_eq c); auto with arith.
intro c_eq_O.
absurd (In E e); auto with arith.
pattern E in |- *.
apply extensionality with empty;
 try (unfold empty, In, not in |- *; contradiction).
apply set_eq_sym; apply cardinalO_empty.
rewrite c_eq_O; trivial with arith.
Qed.

Inductive decidable (S : set) : Prop :=
    Def_dec : (forall x : V, In S x \/ ~ In S x) -> decidable S.

Inductive decidable_on (Q S : set) : Prop :=
    Def_dec_on :
      (forall x : V, In Q x -> In S x \/ ~ In S x) -> decidable_on Q S.

Lemma inv_dec_on :
 forall Q S : set,
 decidable_on Q S -> forall x : V, In Q x -> In S x \/ ~ In S x.
Proof.
simple induction 1; auto with arith.
Qed.

Lemma dec_addQx_dec_Q :
 forall (Q : set) (P : V -> Prop) (x : V),
 decidable_on (add Q x) P -> decidable_on Q P.
Proof.
intros Q P x.
simple induction 1.
intro P_dec_on_addQx.
apply Def_dec_on; auto with arith.
Qed.

Lemma finite_cardinal :
 forall S : set, finite S -> exists k : nat, cardinal S k.
Proof.
intros E HE.
elim HE.
exists 0; trivial with arith.
intros y Q y_not_inQ Q_finite Ex_CardQ.
elim Ex_CardQ.
intros k Def_k.
exists (S k); auto with arith.
Qed.

Lemma cardinal_finite : forall (S : set) (c : nat), cardinal S c -> finite S.
Proof.
intros S c.
simple induction 1; auto with arith.
Qed.

Lemma decidable_finite :
 finite all_ -> forall S : set, decidable S -> finite S.
Proof.
intros V_finite S S_dec.
apply (extensionality (inter all_ S) S).
apply Def_set_eq; auto with arith.
unfold incl, inter, In, all_ in |- *; simpl in |- *; auto with arith.
elim V_finite.
apply (extensionality empty (inter empty S)); auto with arith.
intros x Q x_not_in_Q Q_finite Q_inter_S_finite.
elim S_dec.
intro Def_S_decidable.
elim (Def_S_decidable x).
(*   Case x in S  *)
intro x_in_S.
apply (extensionality (add (inter Q S) x) (inter (add Q x) S));
 auto with arith.
(*   Case x out of S *)
intro x_not_in_S.
apply (extensionality (inter Q S) (inter (add Q x) S)); auto with arith.
Qed.

Lemma finite_decidable : forall S : set, finite S -> decidable S.
Proof.
intro S.
simple induction 1.
apply Def_dec.
unfold empty in |- *; auto with arith.
intros y Q y_not_in_Q Q_finite Q_dec.
apply Def_dec.
unfold In, add in |- *.
elim Q_dec.
intros Def_Q_dec x.
elim (Def_Q_dec x); auto with arith.
intro not_in_Q_x.
elim (V_decidable x y); auto with arith.
intro x_ne_y.
right.
apply Morgan_or; auto with arith.
Qed.

Lemma card_soustr_1 :
 forall (Q : set) (n : nat),
 cardinal Q n -> forall y : V, In Q y -> cardinal (soustr Q y) (pred n).
Proof.
intros Q n.
simple induction 1.
intro y; unfold empty, In in |- *; contradiction.
clear H n Q.
intros Q n x Def_n H_n x_not_in_Q y y_in_addQx.
cut (In Q y \/ ~ In Q y).
simple induction 1.
(* subcase (In Q y) *)
intro H_in.
pattern (soustr (add Q x) y) in |- *.
apply (extensionality (add (soustr Q y) x) (soustr (add Q x) y)).
   (* Proof of set_eq *)
elim (V_decidable x y).
intro x_eq_y.
absurd (In Q y); auto with arith.
elim x_eq_y; auto with arith.
intro x_diff_y.
apply set_eq_sym; auto with arith.
cut (S (pred n) = pred (S n)).
intro H_pred.
elim H_pred.
apply card_add; auto with arith.
(* Use: H_n not_In_soustr *)
unfold pred at 2 in |- *; symmetry  in |- *.
apply S_pred with (m := 0).
change (n > 0) in |- *.
apply inh_card_gt_O with Q; auto with arith.
apply Def_inh with y; trivial with arith.
(* subcase ~(In Q y) *)
intro H_out.
elim (V_decidable x y).
intro x_eq_y.
elim x_eq_y.
pattern (soustr (add Q x) x) in |- *.
apply extensionality with Q; auto with arith.
intro x_diff_y.
absurd (In (add Q x) y); auto with arith.
unfold add, In at 1 in |- *.
apply Morgan_or; trivial with arith.
  (* (In Q y)\/(~(In Q y)) *)
cut (decidable Q).
simple induction 1; auto with arith.
apply finite_decidable.
apply cardinal_finite with n; trivial with arith.
Qed.

Lemma incl_st_card_lt :
 forall (E1 : set) (c1 : nat),
 cardinal E1 c1 ->
 forall (E2 : set) (c2 : nat), cardinal E2 c2 -> incl_st E1 E2 -> c2 > c1.
Proof.
simple induction 1.
(* E1 empty *)
simple induction 1.
   (* E2 empty *)
unfold incl_st in |- *.
simple induction 1.
intro empty_incl_empty.
simple induction 1.
intro e.
simple induction 1; intros; absurd (In empty e); auto with arith.
   (* E2 -> (add E2 x) *)
auto with arith.
(* E1 -> (add E1 x) *)
clear H E1 c1.
intros E1 c1 x1 Def_c1 H_E1 x1_not_in_E1 E2 c2 Def_c2.
elim Def_c2.
   (* E2 empty *)
unfold incl_st in |- *.
simple induction 1; intro H_abs1.
simple induction 1; intro e.
simple induction 1; intros; absurd (In empty e); auto with arith.
   (*  E2 -> (add E2 x) *)
clear Def_c2 c2 E2.
intros E2 c2 x2 Def_c2 H_E1x x2_not_in_E2 H.
elimtype (In E2 x1 \/ ~ In E2 x1); try intro Hx1.
(* subcase (In E2 x1) *)
apply gt_n_S.
apply H_E1 with (E2 := soustr (add E2 x2) x1);
 try (apply incl_st_add_soustr; auto with arith).
elimtype (pred (S c2) = c2); auto with arith.
apply card_soustr_1; auto with arith.
(* subcase ~(In E2 x1) *)
elim (V_decidable x1 x2); intro Hx1x2.
   (* x1 = x2 *)
apply gt_n_S.
apply H_E1 with (E2 := E2); try trivial with arith.
apply incl_st_add_x with (x := x1); auto with arith.
pattern x1 at 2 in |- *; rewrite Hx1x2; trivial with arith.
    (* x1 =/= x2 *)
absurd (In (add E2 x2) x1).
unfold add, In at 1 in |- *.
apply Morgan_or; auto with arith.
unfold incl_st in H.
elim H.
intros H_incl H_Ex.
unfold incl in H_incl; auto with arith.
(* Proof of Cut (In E2 x1) \/ ~(In E2 x1) *)
cut (decidable E2).
simple induction 1; auto with arith.
apply finite_decidable.
apply cardinal_finite with (c := c2); trivial with arith.
Qed.

Lemma finite_union :
 forall E1 E2 : set, finite E1 -> finite E2 -> finite (union E1 E2).
Proof.
intros E1 E2.
simple induction 1.
intro E2_finite.
apply (extensionality E2 (union empty E2)); auto with arith bdd.
intros y Q y_not_in_Q Q_finite HQ E2_finite.
apply (extensionality (add (union Q E2) y) (union (add Q y) E2));
 try (apply set_eq_sym; apply union_add; auto with arith).
elimtype (In E2 y \/ ~ In E2 y).
(* (In E2 y)->(finite (add (union Q E2) y)) *)
intro y_in_E2.
apply (extensionality (union Q E2) (add (union Q E2) y)); auto with arith.
apply Def_set_eq; unfold incl, union, add, In in |- *; auto with arith.
unfold In in y_in_E2.
do 3 (simple induction 1; auto with arith).
(*  (~(In E2 y))->(finite (add (union Q E2) y)) *)
intro y_notin_E2.
apply finite_add; auto with arith.
unfold union, In in |- *.
apply Morgan_or; auto with arith.
cut (decidable E2); try (apply finite_decidable; auto with arith).
simple induction 1; auto with arith.
Qed.

Lemma finite_image :
 forall (E : set) (f : V -> V), finite E -> finite (Im E f).
Proof.
intros E f.
simple induction 1.
(* (finite (Im empty f)) *)
apply (extensionality empty (Im empty f)); auto with arith.
apply Def_set_eq; unfold Im, empty, In in |- *; auto with arith.
unfold incl, In in |- *; do 2 simple induction 1; auto with arith.
(* (finite (Im Q f))->(finite (Im (add Q y) f)) *)
intros y Q y_notin_Q Q_finite ImQ_finite.
apply (extensionality (add (Im Q f) (f y)) (Im (add Q y) f));
 try (apply set_eq_sym; apply Im_add).
cut (decidable (Im Q f)); try (apply finite_decidable; auto with arith).
simple induction 1.
intro ImQ_dec.
elim (ImQ_dec (f y)); auto with arith.
intro fy_in_ImQ.
apply (extensionality (Im Q f) (add (Im Q f) (f y))); auto with arith.
apply Def_set_eq; unfold incl, add in |- *; auto with arith.
unfold In at 2 in |- *; auto with arith.
intro x.
unfold In at 1 in |- *; simple induction 1; auto with arith;
 simple induction 1; auto with arith.
Qed.

Lemma inv_inh_addQx :
 forall (Q : set) (x : V),
 finite Q -> inhabited (add Q x) -> inhabited Q \/ set_eq Q empty.
Proof.
intros Q' x'.
simple induction 1; auto with arith.
Qed.

Lemma notall_addQx_notall_Q :
 forall (Q : set) (P : V -> Prop) (x : V),
 P x ->
 ~ (forall y : V, In (add Q x) y -> P y) -> ~ (forall y : V, In Q y -> P y).
Proof.
intros Q P x H_Px.
unfold not in |- *.
intros H1 H2.
apply H1.
intros y; unfold In, add in |- *; simple induction 1; auto with arith.
simple induction 1; assumption.
Qed.

Lemma notall_existnot_singleton :
 forall (P : V -> Prop) (x : V),
 decidable_on (add empty x) P ->
 ~ (forall y : V, In (add empty x) y -> P y) -> ~ P x.
Proof.
intros P x singlx_dec singlx_notall.
cut (In P x \/ ~ In P x); try apply inv_dec_on with (add empty x);
 auto with arith.
simple induction 1; unfold In in |- *; auto with arith.
intro Px.
absurd (forall y : V, In (add empty x) y -> P y); auto with arith.
intros y y_in_singlx.
elim (singlx x y); auto with arith.
Qed.

Lemma onQ_not_All_Exist_not :
 forall (Q : set) (P : V -> Prop),
 finite Q ->
 inhabited Q ->
 decidable_on Q P ->
 ~ (forall x : V, In Q x -> P x) -> exists x : V, In Q x /\ ~ P x.
Proof.
intros Q' P'.
simple induction 1. (*---- Q = empty ------*)
intros H_inh H_dec H_notall.
absurd (inhabited empty); auto with arith.
unfold not in |- *; simple induction 1; unfold In in |- *; auto with arith.
(*---- Q -> (add Q x) -----*)
intros x Q x_not_in_Q Q_finite H_Q addQx_inh addQx_dec addQx_notall.
elim (inv_inh_addQx Q x); auto with arith.
      (* Q inhabited  *)
intro Q_inh.
elimtype (P' x \/ ~ P' x).
         (* case  (P' x) *)
intro H_P'x.
elim H_Q; auto with arith.
intro t; simple induction 1.
intros t_in_Q not_P't.
exists t; auto with arith.
apply dec_addQx_dec_Q with x; trivial with arith.
apply notall_addQx_notall_Q with x; trivial with arith.
         (* case ~(P' x) *)
intro H_not_P'x.
exists x; auto with arith.
   (* Proof of (P' x)\/~(P' x) *)
change (In P' x \/ ~ In P' x) in |- *; apply inv_dec_on with (add Q x);
 trivial with arith.
(*-----  Q uninhabited  -----*)
intro Q_eq_empty.
exists x; split; auto with arith.
apply notall_existnot_singleton; pattern empty in |- *;
 apply extensionality with Q; auto with arith; elim Q_eq_empty;
 auto with arith.
Qed.

(*---------------------------------------------------------------------------*)
  Lemma not_Exist_All_not
   : (*  Trivial with arith for any set V even infinite *)
   forall P : V -> Prop, ~ (exists x : V, P x) -> forall x : V, ~ P x.
(*---------------------------------------------------------------------------*)
Proof.
unfold not in |- *; intros P not_exist x H_Px.
apply not_exist; exists x; auto with arith.
Qed.

(*---------------------------------------------------------------------------*)
  Lemma not_All_Exist_not :
   forall P : V -> Prop,
   finite all_ ->
   inhabited all_ ->
   decidable P -> ~ (forall x : V, P x) -> exists x : V, ~ P x.
(*---------------------------------------------------------------------------*)
Proof.
intros P V_finite V_inhabited P_dec not_all_P.
elim (onQ_not_All_Exist_not all_ P); auto with arith.
intro x; simple induction 1.
intros Triv not_Px.
exists x; auto with arith.
apply Def_dec_on.
change (forall x : V, True -> In P x \/ ~ In P x) in |- *.
elim P_dec; auto with arith.
Qed.

Lemma P_dec_on_Q_AllP_dec_on_Q :
 forall Q : set,
 finite Q ->
 forall P : V -> Prop,
 decidable_on Q P ->
 (forall x : V, In Q x -> P x) \/ ~ (forall x : V, In Q x -> P x).
Proof.
simple induction 1.
(*  Q = empty  *)
intros P P_dec.
left.
intro x; unfold In, empty in |- *; contradiction.
(*  Q -> (add Q x) *)
clear H Q.
intros x Q x_not_in_Q Q_finite H_Q P P_dec_addQx.
elim (H_Q P).
   (* Case P(x) for all x in Q *)
intro AllP_onQ.
elimtype (P x \/ ~ P x);
 [ idtac
 | idtac
 | change (In P x \/ ~ In P x) in |- *; apply inv_dec_on with (Q := add Q x);
    auto with arith ].
intro Px.
left.
intro v.
unfold add, In in |- *; simple induction 1; auto with arith.
simple induction 1; trivial with arith.
right.
unfold not in |- *.
intro H_absurde.
absurd (P x); auto with arith.
   (* Case not P(x) for all x in Q *)
intro not_AllP_onQ.
right.
unfold not in not_AllP_onQ.
unfold not in |- *.
intro H.
apply not_AllP_onQ.
intros v v_in_Q.
apply H; auto with arith.
(* (decidable_on Q P) *)
apply dec_addQx_dec_Q with (x := x); trivial with arith.
Qed.

(*--------------------------------------------------------------------------*)
 Lemma P_dec_AllP_dec :
  finite all_ ->
  forall P : V -> Prop,
  decidable P -> (forall x : V, P x) \/ ~ (forall x : V, P x).
(*--------------------------------------------------------------------------*)
Proof.
intros V_finite P P_dec.
elim (P_dec_on_Q_AllP_dec_on_Q all_ V_finite P); auto with arith.
(* (decidable_on all_ P) *)
apply Def_dec_on.
change (forall x : V, True -> In P x \/ ~ In P x) in |- *.
elim P_dec; auto with arith.
Qed.

(*****************************)
(*       Ordered sets        *)
(*****************************)

Variable R : V -> V -> Prop.
Variable V_eq : V -> V -> Prop.
Definition reflexivity := forall x : V, R x x.
Definition anti_symetry := forall x y : V, R x y -> R y x -> V_eq x y.
Definition transitivity := forall x y z : V, R x y -> R y z -> R x z.

Definition order := reflexivity /\ anti_symetry /\ transitivity.

Definition totality := forall x y : V, R x y \/ R y x.
Definition total_order := order /\ totality.

Inductive greatest (E : set) (g : V) : Prop :=
    Def_greatest : In E g -> (forall y : V, In E y -> R y g) -> greatest E g.

Lemma inv_greatest_In : forall (E : set) (g : V), greatest E g -> In E g.
Proof.
simple induction 1; auto with arith.
Qed.
Hint Resolve inv_greatest_In.

Lemma inv_greatest_R :
 forall (E : set) (g : V), greatest E g -> forall y : V, In E y -> R y g.
Proof.
simple induction 1; auto with arith.
Qed.

Section Greatest.
 Hypothesis R_total_order : total_order.

(*---------------------------------------------------------------------------*)
  Lemma Card_gtO_exist_greatest :
   forall (E : set) (c : nat),
   cardinal E c -> c > 0 -> exists g : V, greatest E g.
(*---------------------------------------------------------------------------*)
Proof.
simple induction 1.
(* c = O *)
intro Habs.
absurd (0 > 0); auto with arith.
(* E ->(add E x) *)
clear H c E.
intros E cE x Def_cE H_E x_not_in_E H_triv.
elim (gt_O_eq cE).
  (* subcase cE > O *)
intro cE_gt_O.
elim H_E; auto with arith.
intros gE Def_gE.
elim R_total_order.
intros R_order R_total.
unfold totality in R_total.
elim (R_total x gE).
(* (R x gE) -> (Ex([g:V](greatest (add E x) g))) *)
intro x_R_gE.
exists gE; apply Def_greatest.
unfold add, In in |- *; left; change (In E gE) in |- *; auto with arith.
intro y; unfold add in |- *; unfold In at 1 in |- *.
simple induction 1.
intro y_in_E; apply inv_greatest_R with (E := E); auto with arith.
simple induction 1; trivial with arith.
(*  (R gE x) -> (Ex([g:V](greatest (add E x) g))) *)
intro gE_R_x.
exists x; apply Def_greatest; auto with arith.
intro y; unfold add in |- *; unfold In at 1 in |- *.
unfold order in R_order.
elim R_order.
intros R_refl Rasym_and_trans.
unfold reflexivity in R_refl.
elim Rasym_and_trans.
intros R_asym R_trans.
unfold transitivity in R_trans.
simple induction 1; try simple induction 1; auto with arith.
intro y_in_E.
apply R_trans with (y := gE); auto with arith.
apply inv_greatest_R with (E := E); auto with arith.
  (* subcase cE=O *)
intro cE_eq_O.
exists x.
apply Def_greatest; auto with arith.
pattern E in |- *; apply extensionality with (U := empty).
apply set_eq_sym.
change (inv_card E 0) in |- *.
apply cardinal_inv.
rewrite cE_eq_O; trivial with arith.
intro y.
unfold add, empty, In in |- *.
elim R_total_order.
intros R_order R_total.
elim R_order.
intros Rrefl Rasym_and_trans.
unfold reflexivity in Rrefl.
simple induction 1; [ contradiction | simple induction 1; auto with arith ].
Qed.

End Greatest.
End sets.

Hint Resolve in_empty in_allV incl_allV incl_empty incl_Q_add in_add_x
  finite_empty finite_add set_eq_refl.


Require Export ZArith.
Require Export MapSignatures.

Section TabTree.

Variable A : Type.
Variable bot : A.

Inductive tree : Type :=
  | leaf : tree
  | node : A -> tree -> tree -> tree.

Fixpoint apply_tree (t : tree) (p : positive) {struct t} : A :=
  match t with
  | leaf => bot
  | node a tO tI =>
      match p with
      | xH => a
      | xO p => apply_tree tO p
      | xI p => apply_tree tI p
      end
  end.

Fixpoint subst_leaf (p : positive) (v : A) {struct p} : tree :=
  match p with
  | xH => node v leaf leaf
  | xO p' => node bot (subst_leaf p' v) leaf
  | xI p' => node bot leaf (subst_leaf p' v)
  end.

Lemma apply_subst_leaf1 :
 forall (p : positive) (v : A), apply_tree (subst_leaf p v) p = v.
Proof.
  induction p; auto.
Qed.

Fixpoint apply_subst_leaf1'
  (p : positive) (v : A) {struct p} : apply_tree (subst_leaf p v) p = v :=
  match p return apply_tree (subst_leaf p v) p = v with
  | xH => refl_equal _
  | xO p' => (apply_subst_leaf1' p' v)
  | xI p' => (apply_subst_leaf1' p' v)
  end.

Lemma xI_diff : forall p1 p2, xI p1 <> xI p2 -> p1 <> p2.
Proof.
  red; intros.
  elim H; rewrite H0; auto.
Qed.

Lemma xO_diff : forall p1 p2, xO p1 <> xO p2 -> p1 <> p2.
Proof.
  red; intros.
  elim H; rewrite H0; auto.
Qed.

Hint Resolve xI_diff xO_diff.

Lemma apply_subst_leaf2 :
 forall (p1 p2 : positive) (v : A),
 p2 <> p1 -> apply_tree (subst_leaf p1 v) p2 = bot.
Proof.
  induction p1; destruct p2; simpl; auto || intuition.
Qed.

Hint Resolve apply_subst_leaf1 apply_subst_leaf2.

Fixpoint modify_tree (t : tree) (p : positive)
 (f : A -> A) {struct t} : tree :=
  match t with
  | leaf => subst_leaf p (f bot)
  | node a tO tI =>
      match p with
      | xH => node (f a) tO tI
      | xO p' => node a (modify_tree tO p' f) tI
      | xI p' => node a tO (modify_tree tI p' f)
      end
  end.

Lemma apply_modify_tree1 :
 forall (t : tree) (p : positive) (f : A -> A),
 apply_tree (modify_tree t p f) p = f (apply_tree t p).
Proof.
  induction t; intros; simpl; auto.
  case p; simpl; auto.
Qed.

Lemma apply_modify_tree2 :
 forall (t : tree) (p x : positive) (f : A -> A),
 x <> p -> apply_tree (modify_tree t p f) x = apply_tree t x.
Proof.
  induction t; intros; simpl; auto.
  destruct x; destruct p; simpl; auto || intuition.
Qed.

End TabTree.

Module BinMapBot_Base : MAP_BOT_BASE with Definition key := positive.

  Definition t := tree.
  Definition key := positive.
  Lemma key_dec : forall k1 k2:key, {k1=k2}+{~k1=k2}.
  Proof.
    decide equality.
  Qed.

  Definition get := apply_tree.
  Definition modify := modify_tree.

  Definition get_modify1 : forall A bot t k f,
    get A bot (modify A bot t k f) k = f (get A bot t k) :=
    apply_modify_tree1.
  Lemma get_modify2 : forall A bot t k1 k2 f,
    k1 <> k2 ->
    get A bot (modify A bot t k2 f) k1 = get A bot t k1.
  Proof.
    intros; apply apply_modify_tree2; auto.
  Qed.

  Definition init (A:Type)(bot:A) := leaf A.
  Lemma get_init : forall A bot k, get A bot (init A bot) k = bot.
  Proof.
    unfold init, get; simpl; intros; reflexivity.
  Qed.

End BinMapBot_Base.

Module BinMapBot : MAP_BOT  with Definition key := positive :=
  MapBot_Of_MapBotBase BinMapBot_Base.

Module BinNatMapBot_Base : MAP_BOT_BASE with Definition key := N.

  Definition t A := (A*BinMapBot_Base.t A)%type.
  Definition key := N.
  Lemma key_dec : forall k1 k2:key, {k1=k2}+{~k1=k2}.
  Proof.
    decide equality.
    apply BinMapBot_Base.key_dec.
  Qed.

  Definition get (A:Type)(bot:A)(m:t A)(k:key) :=
    match k with
      N0 => fst m
    | Npos p => BinMapBot_Base.get A bot (snd m) p
    end.
  Definition modify (A:Type)(bot:A)(m:t A)(k:key)(f:A->A) :=
    let (v',m') := m in
    match k with
      N0 => (f v',m')
    | Npos p => (v',BinMapBot_Base.modify A bot m' p f)
    end.
  Lemma get_modify1 : forall A bot t k f,
    get A bot (modify A bot t k f) k = f (get A bot t k).
  Proof.
    destruct k; destruct t0; simpl; intros; auto.
    apply BinMapBot_Base.get_modify1.
  Qed.
  Lemma get_modify2 : forall A bot t k1 k2 f,
    k1 <> k2 ->
    get A bot (modify A bot t k2 f) k1 = get A bot t k1.
  Proof.
    destruct k1; destruct k2; destruct t0; simpl; intros; auto.
    elim H; auto.
    apply BinMapBot_Base.get_modify2.
    intro; elim H; subst; auto.
  Qed.

  Definition init (A:Type)(bot:A) := (bot,BinMapBot_Base.init A bot).
  Lemma get_init : forall A bot k, get A bot (init A bot) k = bot.
  Proof.
    unfold init, get; destruct k; intros; simpl.
    reflexivity.
    apply BinMapBot_Base.get_init.
  Qed.

End BinNatMapBot_Base.

Module BinNatMapBot : MAP_BOT  with Definition key := N :=
  MapBot_Of_MapBotBase BinNatMapBot_Base.

Module MapBotPair_Base (M1 M2:MAP_BOT_BASE) : MAP_BOT_BASE
  with Definition key := (M1.key * M2.key)%type.

  Definition t (A:Type) := M1.t (M2.t A).
  Definition key := (M1.key*M2.key)%type.
  Definition get (A:Type)(bot:A)(m:t A)(k:key) :=
    M2.get _ bot (M1.get _ (M2.init _ bot) m (fst k)) (snd k).
  Definition modify  (A:Type)(bot:A)(m:t A)(k:key)(f:A->A) :=
    M1.modify _ (M2.init _ bot) m (fst k)
     (fun m => M2.modify _ bot m (snd k) f).
  Definition init (A:Type) (bot:A) := M1.init _ (M2.init A bot).

  Lemma get_modify1 : forall A bot t k f,
    get A bot (modify A bot t k f) k = f (get A bot t k).
  Proof.
    intros; unfold get, modify.
    rewrite M1.get_modify1.
    rewrite M2.get_modify1; auto.
  Qed.

  Lemma get_modify2 : forall A bot t k1 k2 f,
    k1 <> k2 ->
    get A bot (modify A bot t k2 f) k1 = get A bot t k1.
  Proof.
    intros; unfold get, modify.
    destruct (M1.key_dec (fst k1) (fst k2)).
    rewrite e.
    rewrite M1.get_modify1; auto.
    rewrite M2.get_modify2; auto.
    intro; elim H.
    destruct k1; destruct k2; simpl in *; congruence.
    rewrite M1.get_modify2; auto.
  Qed.

  Lemma get_init : forall A bot k, get A bot (init A bot) k = bot.
  Proof.
    intros; unfold get, init.
    rewrite M1.get_init.
    rewrite M2.get_init.
    reflexivity.
  Qed.

  Lemma key_dec : forall k1 k2:key, {k1=k2}+{~k1=k2}.
  Proof.
    decide equality.
    apply M2.key_dec.
    apply M1.key_dec.
  Qed.

End MapBotPair_Base.


Set Warnings "-notation-overridden,-parsing".
Require Export indprop.
Require Export lists.
Require Export Coq.Strings.Ascii.

Definition string := list ascii.

Lemma provable_equiv_true:
  forall (P: Prop), P -> (P <-> True).
Proof.
  intros P HP.
  split.
  - intros _. apply I.
  - intros _. apply HP.
Qed.

Lemma not_equiv_false:
  forall (P: Prop), ~P -> (P <-> False).
Proof.
  intros P HNP.
  split.
  - intros HP. destruct (HNP HP).
  - intros F. destruct F.
Qed.

Lemma null_matches_none:
  forall (s: string), (s =~ EmptySet) <-> False.
Proof.
  intros s.
  apply not_equiv_false.
  unfold not. intros. inversion H.

  (* split.
  - intros Hs. inversion Hs.
  - intros F. destruct F. *)
Qed.

Lemma empty_matches_eps:
  forall (s: string), s =~ EmptyStr <-> s = [ ].
Proof.
  split.
  - intros. inversion H. reflexivity.
  - intros. rewrite H. apply MEmpty.
Qed.

Lemma empty_nomatch_ne:
  forall (a: ascii) s, (a :: s =~ EmptyStr) <-> False.
Proof.
  intros.
  apply not_equiv_false.
  unfold not. intros. inversion H.
Qed.

Lemma char_nomatch_char:
  forall (a b: ascii) s,
    b <> a -> (b :: s =~ Char a <-> False).
Proof.
  intros.
  apply not_equiv_false.
  unfold not.
  intros.
  apply H.
  inversion H0.
  reflexivity.
Qed.

Lemma char_eps_suffix:
  forall (a: ascii) s, a :: s =~ Char a <-> s = [ ].
Proof.
  split.
  - intros. inversion H. reflexivity.
  - intros. rewrite H. apply MChar.
Qed.

Lemma app_exists:
  forall (s: string) re0 re1,
    s =~ App re0 re1 <->
    exists s0 s1, s = s0 ++ s1 /\ s0 =~ re0 /\ s1 =~ re1.
Proof.
  intros s re0 re1.
  split.
  - intros H.
    inversion H.
    exists s1, s2.
    split. reflexivity.
    split. apply H3. apply H4.
  - intros [s0 [s1 [H1 [H2 H3]]]].
    rewrite H1.
    apply MApp. apply H2. apply H3.
Qed.

(* Exercise 1 *)
Lemma app_ne:
  forall (a: ascii) s re0 re1,
    a :: s =~ (App re0 re1) <->
    ([] =~ re0 /\ a :: s =~ re1) \/
    exists s0 s1, s = s0 ++ s1 /\ a :: s0 =~ re0 /\ s1 =~ re1.
Proof.
  intros a s re0 re1.
  split.
  - intros H.
    apply app_exists in H.
    destruct H as [s0 [s1 H]].
    destruct s0 as [|a' s0'].
    + simpl in H.
      destruct H as [H0 [H1 H2]].
      left. split. apply H1. rewrite H0. apply H2.
    + simpl in H.
      destruct H as [H0 [H1 H2]].
      right. exists s0', s1.
      inversion H0.
      split. reflexivity.
      split. apply H1.
      apply H2.
  - intros [[H0 H1] | [s0 [s1 [H0 [H1 H2]]]]].
    + apply (MApp [] re0 (a :: s) re1 H0 H1).
    + rewrite H0.
      assert (H': a :: s0 ++ s1 = (a :: s0) ++ s1).
      { reflexivity. }
      rewrite H'.
      apply MApp. apply H1. apply H2.
Qed.

Lemma union_disj:
  forall (s: string) re0 re1,
    s =~ Union re0 re1 <-> s =~ re0 \/ s =~ re1.
Proof.
  intros. split.
  - intros. inversion H.
    + left. apply H2.
    + right. apply H1.
  - intros [ H | H ].
    + apply MUnionL. apply H.
    + apply MUnionR. apply H.
Qed.


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

Import ListNotations.

Require Import Omega. (* for omega tactic *)

(* Syntax of Clock-based Dynamic Logic *)

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

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

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

(* Arith Expression `e'*)

Inductive Var := var : nat -> Var.
(* in this version, I try to understand variables as identifications numbered by natural numbers,
which we believe is more convenient than considering them as strings in practical derivations*)

Inductive e_exp :=
  enumC : nat -> e_exp |
  evarC : Var -> 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).
Coercion evarC : Var >-> e_exp.
Notation "e1 '/ e2" := (edivC e1 e2) (at level 21, right associativity).
Check (enumC 4) '/ (enumC 4).

Coercion enumC : nat >-> e_exp.
Definition x : Var := (var 1).
Definition y : Var := (var 2).
Definition z : Var := (var 3).
Definition k : Var := (var 4).

Check 4 '* (5 '+ 2).
Check (5 '+ 4) '* 8.
Check x '- 3.
Compute 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.
Compute 5 '+ x '>= 5 '-> 3 '> 7.

(* Evaluation *)
Definition state := Var -> 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 : Var -> e_exp -> EvtElement | (* Signal *)
  assC : Var -> 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 : Var := (var 5).
Definition d : Var := (var 6).
Definition c1 : Var  := (var 7).
Definition c2 : Var  := (var 8).
Definition c3 : Var  := (var 9).
Definition c4 : Var  := (var 10).

Check x :=' 4.
Compute 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 : Var -> Var -> CRel |
  crExclC : Var -> Var -> CRel |
  crPrecC : Var -> Var -> CRel |
  crCausC : Var -> Var -> 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.
Compute c1 << 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 : Var -> E_exp |
  ECntClkC : Var -> E_exp | (* define a map that maps each clock/signal to a variable that records the number it has ticked in history. *)
  EStClkC : Var -> 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.

(* define two functions at the interpretation level for ECntClkC and EStClkC. *)
Variable fn : nat -> nat.
Variable gn : nat -> nat.

Coercion EvarC : Var >-> 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.
Compute 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 : Var -> 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 |
  cdl_existsC : Var -> CDL_exp -> CDL_exp
.

Notation "'tt''" := cdl_trueC (at level 9). (* previous setting is 65, but I don't why it does not work sometimes *)
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 9).
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, p at level 51, r at level 51).
(* must be higher than the precedence of <<, which is 52 *)
Notation "<< p >> e" := (cdl_dia2C p e) (at level 63, p at level 51, e at level 51).
Notation "e1 \/' e2" := (cdl_orC e1 e2) (at level 71, right associativity).
Notation "e1 ->' e2" := (cdl_impC e1 e2) (at level 72, right associativity).
Notation "'ext' x , e" := (cdl_existsC x e) (at level 68, x at level 67).

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.
Check ext 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)
  | cdl_existsC x e' => (CheckPureFOL e')
  end.

(* build a type for distinguishing pure FOL (i.e. Prop) or non-pure FOL *)
Inductive FOLF :=
  pureC : Prop -> FOLF |
  noPureC : FOLF
.

(* transform an E_exp to a FOL exp under a given state st. *)
(* here the functionality of st is to link the concept of `variable' in CDL we define to
the `nat' domain in Coq *)

Fixpoint Eexp_2_exp (e : E_exp) (st : state) : nat :=
  match e with
  | EvarC v => st v
  | ECntClkC c => fn (st c)
  | EStClkC c => gn (st c)
  | EnumC n => n
  | EplusC e1 e2 => (Eexp_2_exp e1 st) + (Eexp_2_exp e2 st)
  | EmulC e1 e2 => (Eexp_2_exp e1 st) * (Eexp_2_exp e2 st)
  | EminusC e1 e2 => (Eexp_2_exp e1 st) - (Eexp_2_exp e2 st)
  | EdivC e1 e2 => (Eexp_2_exp e1 st) / (Eexp_2_exp e2 st)
  end
.

(* transform a CDL exp to a FOLF formula *)
Fixpoint CDLexp_2_FOLF (e : CDL_exp) (st : state) : FOLF :=
  match e with
  | cdl_trueC => pureC True
  | cdl_ltC e1 e2 => pureC ((Eexp_2_exp e1 st) < (Eexp_2_exp e2 st))
  | cdl_box1C p r => noPureC (*once met dynamic operators, it is not a pure FOL formula *)
  | cdl_box2C p e' => noPureC
  | cdl_negC e' => match (CDLexp_2_FOLF e' st) with
                    | noPureC => noPureC
                    | pureC f => pureC (~ f)
                   end
  | cdl_andC e1 e2 => match (CDLexp_2_FOLF e1 st), (CDLexp_2_FOLF e2 st) with
                        | noPureC , _ => noPureC
                        | _ , noPureC => noPureC
                        | (pureC f1) , (pureC f2) => pureC (f1 /\ f2)
                      end
  | cdl_forallC x e' => match (CDLexp_2_FOLF e' st) with
                          | noPureC => noPureC
                          | pureC f => pureC (forall (x : nat), f)
                        end
  | cdl_falseC => pureC False
  | cdl_lteC e1 e2 => pureC ((Eexp_2_exp e1 st) <= (Eexp_2_exp e2 st))
  | cdl_gtC e1 e2 => pureC ((Eexp_2_exp e1 st) > (Eexp_2_exp e2 st))
  | cdl_gteC e1 e2 => pureC ((Eexp_2_exp e1 st) >= (Eexp_2_exp e2 st))
  | cdl_eqC e1 e2 => pureC ((Eexp_2_exp e1 st) = (Eexp_2_exp e2 st))
  | cdl_dia1C p r => noPureC (*once met dynamic operators, it is not a pure FOL formula *)
  | cdl_dia2C p e' => noPureC
  | cdl_orC e1 e2 => match (CDLexp_2_FOLF e1 st), (CDLexp_2_FOLF e2 st) with
                        | noPureC , _ => noPureC
                        | _ , noPureC => noPureC
                        | (pureC f1) , (pureC f2) => pureC (f1 \/ f2)
                     end
  | cdl_impC e1 e2 => match (CDLexp_2_FOLF e1 st), (CDLexp_2_FOLF e2 st) with
                        | noPureC , _ => noPureC
                        | _ , noPureC => noPureC
                        | (pureC f1) , (pureC f2) => pureC (f1 -> f2)
                      end
  | cdl_existsC x e' => match (CDLexp_2_FOLF e' st) with
                          | noPureC => noPureC
                          | pureC f => pureC (exists (x : nat), f)
                        end
  end.

Variable st0 : state.
Compute (CDLexp_2_FOLF tt' st0).
Compute (CDLexp_2_FOLF (tt' /\' x >=' 5) st0).
Compute (CDLexp_2_FOLF (tt' /\' (x >=' 5 ->' [ skip ] x >' 5 )) st0).
Compute (CDLexp_2_FOLF (tt' /\' (x >=' 5 ->' n(c) >' 5 )) st0).

(* transform a CDL_exp to Prop formula, if CDL_exp is not pure, simply return False, otherwise,
return the Prop formula corresponding to it. *)

Definition CDLexp_2_Prop (e : CDL_exp) (st : state) : Prop :=
  match (CDLexp_2_FOLF e st) with
    | noPureC => False
    | pureC f => f
  end.

Compute CDLexp_2_Prop (tt' /\' (x >=' 5 ->' [ skip ] x >' 5 )) st0.
Compute CDLexp_2_Prop (tt' /\' (x >=' 5 ->' n(c) >' 5 )) st0.

(* 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, or expression P_exp
to expression CDL_exp, 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.

Fixpoint Pexp_2_CDLexp (P : P_exp) : CDL_exp :=
  match P with
  | PtrueC => cdl_trueC
  | PlteC e1 e2 => cdl_lteC (e_2_E e1) (e_2_E e2)
  | PnegC P' => cdl_negC (Pexp_2_CDLexp P')
  | PandC P1 P2 => cdl_andC (Pexp_2_CDLexp P1) (Pexp_2_CDLexp P2)
  | PfalseC => cdl_falseC
  | PltC e1 e2 => cdl_ltC (e_2_E e1) (e_2_E e2)
  | PgtC e1 e2 => cdl_gtC (e_2_E e1) (e_2_E e2)
  | PgteC e1 e2 => cdl_gteC (e_2_E e1) (e_2_E e2)
  | PeqC e1 e2 => cdl_eqC (e_2_E e1) (e_2_E e2)
  | PorC P1 P2 => cdl_orC (Pexp_2_CDLexp P1) (Pexp_2_CDLexp P2)
  | PimpC P1 P2 => cdl_impC (Pexp_2_CDLexp P1) (Pexp_2_CDLexp P2)
  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.
***)

(* compare the id of two variables *)
Definition eqv (x : Var) (y: Var) : bool :=
  match x, y with
  | var n, var m => if n =? m then true else false
  end.

(* this function check whether a variable (i.e. a string) belongs to a list of variables (list of string) *)
Fixpoint NotIn_bool (s : Var) (vec : list Var) : bool :=
  match vec with
  | nil => true
  | v :: vec' => if (eqv 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 : Var) (vec : list Var) : Prop :=
  match vec with
  | nil => True
  | v :: vec' => if (eqv 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 : Var) (vec : list Var) : Prop :=
  match vec with
  | nil => False
  | v :: vec' => if (eqv s v) then True else In s vec'
  end.

Fixpoint E_exp_FV (e : E_exp) (bv : list Var) : list Var := (*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 Var) : list Var :=
  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 Var) : list Var :=
  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 Var) : list Var :=
  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 Var) : list Var :=
  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 Var) : list Var :=
  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 Var) : list Var := (*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)
  | cdl_existsC x1 e' => cdl_FV e' (x1 :: bv) (* x1 is a bounded variable *)
  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).
Compute cdl_FV ([ (@ { x :=' 5}; x '> 2 ? { y :=' y '- z} U skip) ] x >' 0 /\' ( ext y , y =' 7 ) ) (y :: nil).

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

Check nat.

(* compute FV for a function *)
(* here we do a trick. We pass to phi a variable with a variable id that we will never use in the context
(i.e., the var 0), and we add this variable to the bounded variable list bv, so that the final FV set of
phi will definitely not contain var 0.
Note that var 0 must not be used anywhere, or it would be dangerous since it is possible var 0
has already existed in the formul phi *)

Definition cdl_FV_f (phi : E_exp -> CDL_exp) (bv : list Var) : list Var :=
  cdl_FV (phi (var 0)) ((var 0) :: bv).

(* generate a new variable id *)
Fixpoint MaxId (FVSet : list Var) : nat :=
  match FVSet with
  | nil => 0 (* when there is no variables in the current environment FVSet, just start from the number 0 *)
  | v :: FVSet' => let n := MaxId FVSet' in (
                      match v with | var m =>
                        if le_lt_dec n m then m else (MaxId FVSet') (* le_lt_dec : <= *)
                      end
                      )
  end
.

Compute MaxId (var 1 :: var 3 :: var 5 :: var 6 :: nil).

Definition NewId (FVSet : list Var) : nat := (S (MaxId FVSet)).

Compute NewId (var 7 :: var 1 :: var 3 :: var 3 :: var 5 :: var 6 :: nil).
Compute NewId nil.

(* -------------------------------substitution for single variable----------------------------------------*)
Fixpoint E_exp_subs (e : E_exp) (x' : Var) (x : Var) : E_exp :=
  match e with
  | EvarC v => if (eqv 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' : Var) (x : Var) : e_exp :=
  match e with
  | enumC n => enumC n
  | evarC s => if (eqv 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 (z '- 5) '* x '+ z.
Compute e_exp_subs ((z '- 5) '* x '+ z) y z.

Fixpoint P_exp_subs (P : P_exp) (x' : Var) (x : Var) : 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 'tt '/\ '~ (x '< 5).
Compute P_exp_subs ('tt '/\ '~ (x '< 5)) z x.

Fixpoint EvtE_subs (e : EvtElement) (x' : Var) (x : Var) : 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' : Var) (x : Var) : Evt :=
  match evt with
  | nil => nil
  | e :: evt' => (EvtE_subs e x' x) :: (Evt_subs evt' x' x)
  end
.

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

Fixpoint SEP_exp_subs (e : SEP_exp) (x' : Var) (x : Var) : 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 @ { c ! x '+ 5 | x :=' 5 '* x '+ 3 '/ y }.
Compute SEP_exp_subs ( @ { c ! x '+ 5 | x :=' 5 '* x '+ 3 '/ y }) z x.

Fixpoint cdl_subs (e : CDL_exp) (x' : Var) (x : Var) : 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 (eqv 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)
  | cdl_existsC x1 e' => if (eqv x1 x) then cdl_forallC x1 e' else (cdl_subs e' 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.
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' : Var) (x : Var) : 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).

(* hbar Function : translate a relation to a FOL formula*)
Definition hbar_Rel (r : CRel) : CDL_exp :=
  match r with
  | crSubClC c1 c2 => (s(c1) =' 1 ->' s(c2) =' 1)
  | crExclC c1 c2 => (s(c1) =' 0 \/' s(c2) =' 1)
  | crPrecC c1 c2 => (n(c1) >' n(c2) \/' (n(c1) =' n(c2) ->' s(c1) =' 0))
  | crCausC c1 c2 => (n(c1) >=' n(c2))
  end.

Fixpoint hbar_l_conj (l : list CRel) : CDL_exp :=
  match l with
  | nil => tt'
  | r :: l' => (hbar_Rel r) /\' (hbar_l_conj l')
  end.

Definition hbar (r : rel) : CDL_exp :=
  match r with
  | rRelC R => hbar_Rel R
  | rConjC l => hbar_l_conj l
  end.

(* ====================================================== 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 & FV }" (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**)

(*DEL
Inductive tstSeq2 : Gamma -> place -> place -> Delta -> (list Var) -> Prop :=
  tst2 : forall (T : Gamma) (D : Delta) (e : e_exp) (phi : CDL_exp) (FV : list Var) (x : Var) (A : Evt),
          ( let n := NewId FV in
          (tstSeq2 ((x =' (e_2_E e) [(var n) subs-E x]) :: (T [ (var n) subs-l x ]))
                   empty
                  (exp ([ @ A ] phi))
                  (D [ (var n) subs-l x ])
                  (var n :: FV) )
        ) ->
    (tstSeq2 T empty (exp ([ @ ((x :=' e) :: A) ] phi)) D FV)
  |
  tst3 : forall (T : Gamma) (D : Delta) (phi : CDL_exp) (FV : list Var),
          (
          tstSeq2 T
                   empty
                  (exp phi)
                  D
                  FV
        ) ->
    (tstSeq2 T empty (exp ([ @ idle ] phi)) D FV)
where "{ T , p1 ==> p2 , D & FV }" := (tstSeq2 T p1 p2 D FV)
.

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

(*&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&  end of test &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&*)

(* =========================================== some auxiliary funcions ================= *)
(* transform a sequent to a CDL exp, which we will need to implement Rule (o) below *)
Fixpoint Gamma_2_CDLexp (T : Gamma) : CDL_exp :=
  match T with
  | nil => tt'
  | e :: T' => e /\' (Gamma_2_CDLexp T')
  end.

Fixpoint Delta_2_CDLexp (D : Gamma) : CDL_exp :=
  match D with
  | nil => ff'
  | e :: D' => e \/' (Delta_2_CDLexp D')
  end.

Definition place_2_CDLexp_L (p : place) : CDL_exp :=
  match p with
  | empty => tt'
  | exp e => e
  end.

Definition place_2_CDLexp_R (p : place) : CDL_exp :=
  match p with
  | empty => ff'
  | exp e => e
  end.

Definition Seq_2_CDLexp (T : Gamma) (p1 : place) (p2 : place) (D : Delta) : CDL_exp :=
  ((Gamma_2_CDLexp T) /\' (place_2_CDLexp_L p1))
  ->'
  ((place_2_CDLexp_R p2) \/' (Delta_2_CDLexp D))
.

Compute Seq_2_CDLexp ((x =' 1) :: (y >' 1) :: nil) empty (exp (z =' 3)) nil.

(* =========================================== construction of the proof system ================================================= *)

(* currently we do not consider the other direction of the rules and rules for the dual operator of `[p]'. *)

Inductive Seq : Gamma -> place -> place -> Delta -> (list Var) -> Prop :=
  (* ****************************** rules for atomic events and formula [p]rel *********************** *)
(* Rule (Phi) *)
  r_Phi_all_int1 : forall (T : Gamma) (D : Delta) (FV : list Var) (x : Var) (e : e_exp) (A : Evt) (phi : CDL_exp),
          let n := NewId FV in
          (
            Seq ((x =' (e_2_E e) [(var n) subs-E x]) :: (T [ (var n) subs-l x ]))
                      empty
                        (exp ([ @ A ] phi))
                          (D [ (var n) subs-l x ])
                            (var n :: FV)
          )
          ->
          (
            Seq T empty (exp ([ @ ((x :=' e) :: A) ] phi)) D FV
          )
|

  r_Phi_all_int2 : forall (T : Gamma) (D : Delta) (FV : list Var) (phi : CDL_exp),
          (
            Seq T empty (exp phi) D FV
          )
          ->
          (
            Seq T empty (exp ([ @ idle ] phi)) D FV
          )
|

(* Rule (Pi) *)
  r_Pi_all_int1 : forall (T : Gamma) (D : Delta) (FV : list Var) (x : Var) (e : e_exp) (A : Evt) (r : rel),
          let n := NewId FV in
          (
            Seq ((x =' (e_2_E e) [(var n) subs-E x]) :: (T [ (var n) subs-l x ]))
                      empty
                        (exp ([ @ A ]' r))
                          (D [ (var n) subs-l x ])
                            (var n :: FV)
          )
          ->
          (
            Seq T empty (exp ([ @ ((x :=' e) :: A) ]' r)) D FV
          )
|
  r_Pi_all_int2 : forall (T : Gamma) (D : Delta) (FV : list Var) (r : rel),
          (
            Seq T empty (exp (hbar r)) D FV
          )
          ->
          (
            Seq T empty (exp ([ @ idle ]' r)) D FV
          )
|

(* Rule P? *)
  r_Test_all_phi_int : forall (T : Gamma) (D : Delta) (FV : list Var) (P : P_exp) (A : Evt) (phi : CDL_exp),
          (
            Seq T empty (exp ((Pexp_2_CDLexp P) ->' [ @ A ] phi )) D FV
          )
          ->
          (
            Seq T empty (exp ([ P ? A ] phi)) D FV
          )
|
  r_Test_all_rel_int : forall (T : Gamma) (D : Delta) (FV : list Var) (P : P_exp) (A : Evt) (r : rel),
          (
            Seq T empty (exp ((Pexp_2_CDLexp P) ->' [ @ A ]' r )) D FV
          )
          ->
          (
            Seq T empty (exp ([ P ? A ]' r)) D FV
          )
|

(* Rule \pi\epsilon *)
  r_PiEp_all_int : forall (T : Gamma) (D : Delta) (FV : list Var) (r : rel),
          (
            Seq T empty ( exp (tt') ) D FV
          )
          ->
          (
            Seq T empty (exp ([ skip ]' r)) D FV
          )
|

(* Rule \epsilon *)
  r_Ep_all_int : forall (T : Gamma) (D : Delta) (FV : list Var) (phi : CDL_exp),
          (
            Seq T empty ( exp phi ) D FV
          )
          ->
          (
            Seq T empty (exp ([ skip ] phi)) D FV
          )
|

(* Rule \pi[;] *)
  r_PiSeq_all_int : forall (T: Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (q : SEP_exp) (r : rel),
          (
            Seq T empty
                    (exp ([ p ]' r /\' [ p ] ([ q ]' r)))
                      D FV
          )
          ->
          (
            Seq T empty (exp ([ p;q ]' r)) D FV
          )
|

(* Rule \pi[\cup] *)
  r_PiCho_all_int : forall (T: Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (q : SEP_exp) (r : rel),
          (
            Seq T empty
                    (exp ([ p ]' r /\' [ q ]' r))
                      D FV
          )
          ->
          (
            Seq T empty (exp ([ p U q ]' r)) D FV
          )
|

(* Rule \pi[*]u *)
  r_PiLoopU_all_int : forall (T: Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (r : rel),
          (
            Seq T empty
                    (exp ([ p ; p ** ]' r))
                      D FV
          )
          ->
          (
            Seq T empty (exp ([ p ** ]' r)) D FV
          )
|

(* Rule \pi[*]i *)
  r_PiLoopI_all_int : forall (T: Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (r : rel),
          (
            Seq T empty
                    (exp ([ p ** ] ([ p ]' r)))
                      D FV
          )
          ->
          (
            Seq T empty (exp ([ p ** ]' r)) D FV
          )
|

(* ****************************** rules for formula [p]\phi inherited from FODL *********************** *)
(* Rule [;] *)
  r_Seq_all_int : forall (T: Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (q : SEP_exp) (phi : CDL_exp),
          (
            Seq T empty
                    (exp ([ p ] ([ q ] phi)))
                      D FV
          )
          ->
          (
            Seq T empty (exp ([ p ; q ] phi)) D FV
          )
|

(* Rule [U] *)
  r_Cho_all_int : forall (T: Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (q : SEP_exp) (phi : CDL_exp),
          (
            Seq T empty
                    (exp ([ p ] phi /\' [ q ] phi))
                      D FV
          )
          ->
          (
            Seq T empty (exp ([ p U q ] phi)) D FV
          )
|

(* Rule [*]u *)
  r_LoopU_all_Int : forall (T: Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (phi : CDL_exp),
          (
            Seq T empty
                    (exp (phi /\' [ p ; p ** ] phi))
                      D FV
          )
          ->
          (
            Seq T empty (exp ([ p ** ] phi)) D FV
          )
|

(*** here we also omit the rules ([]gen), (<>gen), ([*]ind), (<*>con) temporally since we actually do NOT
need them for derivatiion, they are just necessary for the relative completeness of the proof system. ***)

(* Rule [*]i *)
  r_LoopI_all : forall (T : Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (phi : CDL_exp),
          (
            exists (inv : CDL_exp), (* invariant has to be manually provided *)
              (
                Seq T empty (exp inv) D (FV ++ (cdl_FV inv nil))
              )
              /\
              (
                Seq nil empty
                          (exp (inv ->' [ p ] inv))
                            nil
                              (cdl_FV (inv ->' [ p ] inv) nil)
              )
              /\
              (
                Seq nil empty
                          (exp (inv ->' phi))
                            nil
                              (cdl_FV (inv ->' phi) nil)
              )
          )
          ->
          (
            Seq T empty
                    (exp ([ p ** ] phi)) D FV
          )
|

(* Rule <*>i *)
  r_LoopI_dia : forall (T : Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (phi : CDL_exp),
          (
            exists (inv : E_exp -> CDL_exp), (* invariant has to be manually provided *)
              (
                let X := var (NewId (FV ++ (cdl_FV_f inv nil))) in
                (
                Seq T empty
                        (exp (ext X , (X >=' 0 /\' (inv X))))
                            D
                              (FV ++ (cdl_FV (ext X , (X >=' 0 /\' (inv X))) nil))
                )
              )
              /\
              (
                let X := var (NewId (cdl_FV_f inv nil)) in
                (
                Seq nil empty
                          (exp (
                                  all X, X >' 0 ->' ((inv X) ->' << p >> (inv (X -' 1)))
                               )
                          )
                            nil
                              (cdl_FV (all X, X >' 0 ->' ((inv X) ->' << p >> (inv (X -' 1)))) nil)
                )
              )
              /\
              (
                let X := var (NewId (cdl_FV_f inv nil)) in
                (
                Seq nil empty
                          (exp (
                                  ext X, X <=' 0 /\' ((inv X) ->' phi)
                               )
                          )
                            nil
                              (cdl_FV (ext X, X <=' 0 /\' ((inv X) ->' phi)) nil)
                )
              )
          )
          ->
          (
            Seq T empty
                    (exp (<< p ** >> phi)) D FV
          )
|

(* ****************************** rules of FOL *********************** *)
(* Rule (o) *)
  r_o_int : forall (T : Gamma) (D : Delta) (FV : list Var),
        (
          let fof := (Seq_2_CDLexp T empty empty D) in
          (
            forall (st : state), (CDLexp_2_Prop fof st)
            (* the Prop formula corresponding to the sequent: `Seq T empty empty D FV' *)
          )
        )
        ->
        (
          Seq T empty empty D FV
        )
|

(* Rule (ax) *)
  r_ax_int : forall (T : Gamma) (D : Delta) (FV : list Var) (phi : CDL_exp),
        (
          True
        )
        ->
        (
          Seq T (exp phi) (exp phi) D FV
        )
|

(* Rule (cut) *)
  r_cut_int : forall (T : Gamma) (D : Delta) (FV : list Var),
        (
          forall (phi : CDL_exp),
            (
              Seq T empty (exp phi) D (FV ++ (cdl_FV phi nil))
            )
            /\
            (
              Seq T (exp phi) empty D (FV ++ (cdl_FV phi nil))
            )
        )
        ->
        (
          Seq T empty empty D FV
        )
|

(* Rule (~ r) *)
  r_negR_int : forall (T : Gamma) (D : Delta) (FV : list Var) (phi : CDL_exp),
        (
          Seq T (exp (~' phi)) empty D FV
        )
        ->
        (
          Seq T empty (exp phi) D FV
        )
|

(* Rule (~ l) *)
  r_negL_int : forall (T : Gamma) (D : Delta) (FV : list Var) (phi : CDL_exp),
        (
          Seq T empty (exp (~' phi)) D FV
        )
        ->
        (
          Seq T (exp phi) empty D FV
        )
|

(* Rule (/\ r) *)
  r_andR_int : forall (T : Gamma) (D : Delta) (FV : list Var) (phi1 : CDL_exp) (phi2 : CDL_exp),
        (
          (
            Seq T empty (exp phi1) D FV
          )
          /\
          (
            Seq T empty (exp phi2) D FV
          )
        )
        ->
        (
          Seq T empty (exp (phi1 /\' phi2)) D FV
        )
|

(* Rule (/\ l) *)
  r_andL_int : forall (T : Gamma) (D : Delta) (FV : list Var) (phi1 : CDL_exp) (phi2 : CDL_exp),
        (
          (
            Seq T (exp phi1) empty D FV
          )
          \/
          (
            Seq T (exp phi2) empty D FV
          )
        )
        ->
        (
          Seq T (exp (phi1 /\' phi2)) empty D FV
        )
|

(* Rule (all r) *)
  r_allR_int : forall (T : Gamma) (D : Delta) (FV : list Var) (phi : CDL_exp) (x : Var),
        (
          let n := NewId FV in
          (
            Seq T empty
                    (
                      exp (phi [(var n) subs x])
                    )
                        D
                          ((var n) :: FV)
          )
        )
        ->
        (
          Seq T empty (exp (all x , phi)) D FV
        )
(* define the notation at the end *)
where "{ T , p1 ==> p2 , D & FV }" := (Seq T p1 p2 D FV)
.

Theorem tst1 : { nil, (exp tt') ==> (exp tt') , nil & nil }.
Proof.
apply r_ax_int.
auto.
Qed.


(** * %V\'erification% de programmes avec la logique de Hoare *)

(** ** Syntaxe des expressions %arithm\'etiques% et %bool\'eennes%

*)

Definition var := nat.

Inductive exp :=
| exp_var : var -> exp
| cst : nat -> exp
| mul : exp -> exp -> exp
| sub : exp -> exp -> exp.

Inductive bexp :=
| equa : exp -> exp -> bexp
| neg : bexp -> bexp.

(** ** Un langage %imp\'eratif% minimal
*)

Inductive cmd : Type :=
| assign : var -> exp -> cmd
| seq : cmd -> cmd -> cmd
| while : bexp -> cmd -> cmd.

(** ** %S\'emantique% des expressions *)

(** %\'Etat% d'un programme: *)

Definition state := var -> nat.

Definition sample_state : state :=
  fun x =>
    match x with
    | O => 4
    | 1 => 5
    | _ => O
    end.

Require Import Arith.

Definition upd (v : var) (a : nat) (s : state) : state :=
  fun x => match Nat.eq_dec x v with
           | left _ (* x = y *) => a
           | right _ => s x
           end.

(** %\'Evaluation% des expressions: *)

Fixpoint eval e s :=
  match e with
  | exp_var v => s v
  | cst n => n
  | mul v1 v2 => eval v1 s * eval v2 s
  | sub v1 v2 => eval v1 s - eval v2 s
  end.

Fixpoint beval b s :=
  match b with
    | equa e1 e2 => eval e1 s = eval e2 s
    | neg b => ~ beval b s
  end.

(** Exemple d'expression: *)

Definition ret : var := O.
Definition x : var := 1.

Compute eval (mul (exp_var ret) (exp_var x)) sample_state.

(* begin hide *)
Lemma eval_upd_same str v s : eval (exp_var str) (upd str v s) = v.
Proof.
simpl.
unfold upd.
destruct Nat.eq_dec.
apply eq_refl.
tauto.
Qed.

Lemma eval_upd_diff str str' v s : str <> str' -> eval (exp_var str) (upd str' v s) = eval (exp_var str) s.
Proof.
intros H.
simpl.
unfold upd.
destruct Nat.eq_dec.
  tauto.
apply eq_refl.
Qed.
(* end hide*)

(** ** R%\'e%presentation de la logique de Hoare *)

(** %D\'efinition% des %pr\'e/post%-conditions: *)

Definition assert := state -> Prop.

Definition imp (P Q : assert) := forall s, P s -> Q s.

(** Les %r\`egles% d'%inf\'erence%: *)

Inductive hoare : assert -> cmd -> assert -> Prop :=
| hoare_assign : forall (Q : assert) v e,
  hoare (fun s => Q (upd v (eval e s) s)) (assign v e) Q
| hoare_seq : forall Q P R c d,
  hoare P c Q -> hoare Q d R ->
  hoare P (seq c d) R
| hoare_conseq : forall (P' Q' P Q : assert) c,
  imp P P' -> imp Q' Q -> hoare P' c Q' ->
  hoare P c Q
| hoare_while : forall P b c,
  hoare (fun s => P s /\ beval b s) c P ->
  hoare P (while b c) (fun s => P s /\ ~ (beval b s)).

(* begin hide*)
Lemma hoare_stren : forall (P' P Q : assert) c,
  imp P P' -> hoare P' c Q -> hoare P c Q.
Proof.
intros P' P Q c PP' H.
apply (hoare_conseq P' Q).
auto.
unfold imp.
auto.
auto.
Qed.
(* end hide *)

(* begin hide *)
Definition facto (x ret : var) :=
  while (neg (equa (exp_var x) (cst O)))
    (seq
       (assign ret (mul (exp_var ret) (exp_var x)))
       (assign x (sub (exp_var x) (cst 1)))).

Require Import Omega.
Require Import Factorial.

Lemma fact_fact n : 1 <= n -> fact (n - 1) * n = fact n.
Proof.
destruct n as [|n].
omega.
intros _.
simpl.
rewrite Nat.sub_0_r.
rewrite Nat.mul_succ_r.
rewrite Nat.mul_comm.
omega.
Qed.
(* end hide *)