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

(***** System TCG: Train || Controller || Gate  "the Railroad Crossing Example" *****)
(*                                                                                *)
(* Temporal Automatas:                                                              *)
(*                                                                                *)
(*          TRAIN:          CONTROLLER:	             GATE:                          *)
(*                                                                                *)
(*                                 App y:=0                  Lower z:=0             *)
(*          --> Far         -->Sc1 -------> Sc2      -->Open ---------> Lowering    *)
(*            /    \            |            |           |               |          *)
(*          Exit   App         Raise        Lower       Up              Down        *)
(*          x<kt2  x:=0        y<kc2        y=kc1       kg2<=z<kg3      z<kg        *)
(*         /          \         |            |           |               |          *)
(*   Inside <-------- Near     Sc4 <------- Sc3      Raising <--------- Closed      *)
(*         In kt1<x<kt2            Exit y:=0                 Raise z:=0             *)
(*                                                                                *)
(************************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.

Require Import time_clocks. (* Temporal notions for discrete time *)

Section Automatas_TCG.

(* System TCG: Especification *)

  (* Set of Labels *)

  Inductive Label : Set :=
    | Approach : Label
    | In : Label
    | Exit : Label
    | Lower : Label
    | Raise : Label
    | Up : Label
    | Down : Label
    | Tick : Label.

  (* Tick represent temporal transitions *)

  (* Locations: ST (Train), SC (Controller) and SG (Gate) *)

  Inductive ST : Set :=
    | Far : ST
    | Near : ST
    | Inside : ST.
  Inductive SC : Set :=
    | Sc1 : SC
    | Sc2 : SC
    | Sc3 : SC
    | Sc4 : SC.
  Inductive SG : Set :=
    | Open : SG
    | Lowering : SG
    | Closed : SG
    | Raising : SG.

  (* States with one clock *)

  Definition S_Ck (S : Set) := (S * Clock)%type.

  (* TCG constants *)

  Definition kt1 : Instant := 8.
  Definition kt2 : Instant := 20.
  Definition kc1 : Instant := 4.
  Definition kc2 : Instant := 4.
  Definition kg1 : Instant := 4.
  Definition kg2 : Instant := 4.
  Definition kg3 : Instant := 8.

  (* Invariants of locations for the Train *)

  Inductive InvT : S_Ck ST -> Prop :=
    | Ifar : forall x : Clock, InvT (Far, x)
    | Inear : forall x : Clock, lt_Ck x kt2 -> InvT (Near, x)
    | Iinside : forall x : Clock, lt_Ck x kt2 -> InvT (Inside, x).

  (* Invariants of locations for the Controller *)

  Inductive InvC : S_Ck SC -> Prop :=
    | Isc1 : forall y : Clock, InvC (Sc1, y)
    | Isc2 : forall y : Clock, le_Ck y kc1 -> InvC (Sc2, y)
    | Isc3 : forall y : Clock, InvC (Sc3, y)
    | Isc4 : forall y : Clock, lt_Ck y kc2 -> InvC (Sc4, y).

   (* Invariants of locations for the Gate *)

  Inductive InvG : S_Ck SG -> Prop :=
    | Iopen : forall z : Clock, InvG (Open, z)
    | Ilowering : forall z : Clock, lt_Ck z kg1 -> InvG (Lowering, z)
    | Iclosed : forall z : Clock, InvG (Closed, z)
    | Iraising : forall z : Clock, lt_Ck z kg3 -> InvG (Raising, z).

  (* Train transitions *)

  Inductive TrT : S_Ck ST -> Label -> S_Ck ST -> Prop :=
    | ttApproach : forall x : Clock, TrT (Far, x) Approach (Near, Reset)
    | ttIn :
        forall x : Clock,
        gt_Ck x kt1 -> lt_Ck x kt2 -> TrT (Near, x) In (Inside, x)
    | ttExit : forall x : Clock, lt_Ck x kt2 -> TrT (Inside, x) Exit (Far, x)
    | ttTick :
        forall (x : Clock) (s : ST),
        InvT (s, Inc x) -> TrT (s, x) Tick (s, Inc x).

  (* Controller transitions *)

  Inductive TrC : S_Ck SC -> Label -> S_Ck SC -> Prop :=
    | tcApproach : forall y : Clock, TrC (Sc1, y) Approach (Sc2, Reset)
    | tcLower : forall y : Clock, eq_Ck y kc1 -> TrC (Sc2, y) Lower (Sc3, y)
    | tcExit : forall y : Clock, TrC (Sc3, y) Exit (Sc4, Reset)
    | tcRaise : forall y : Clock, lt_Ck y kc2 -> TrC (Sc4, y) Raise (Sc1, y)
    | tcTick :
        forall (y : Clock) (s : SC),
        InvC (s, Inc y) -> TrC (s, y) Tick (s, Inc y).

  (* Gate transitions *)

  Inductive TrG : S_Ck SG -> Label -> S_Ck SG -> Prop :=
    | tgLower : forall z : Clock, TrG (Open, z) Lower (Lowering, Reset)
    | tgDown :
        forall z : Clock, lt_Ck z kg1 -> TrG (Lowering, z) Down (Closed, z)
    | tgRaise : forall z : Clock, TrG (Closed, z) Raise (Raising, Reset)
    | tgUp :
        forall z : Clock,
        ge_Ck z kg2 -> lt_Ck z kg3 -> TrG (Raising, z) Up (Open, z)
    | tgTick :
        forall (z : Clock) (s : SG),
        InvG (s, Inc z) -> TrG (s, z) Tick (s, Inc z).

  (* States for the system: train||controller||gate *)

  Definition StGlobal := (S_Ck ST * (S_Ck SC * S_Ck SG))%type.

  (* Transitions for the system: train||controller||gate *)

  Inductive TrGlobal : StGlobal -> Label -> StGlobal -> Prop :=
    | tGl_In :
        forall st1 st2 : S_Ck ST,
        TrT st1 In st2 ->
        forall (sc : S_Ck SC) (sg : S_Ck SG),
        TrGlobal (st1, (sc, sg)) In (st2, (sc, sg))
    | tGl_Down :
        forall sg1 sg2 : S_Ck SG,
        TrG sg1 Down sg2 ->
        forall (st : S_Ck ST) (sc : S_Ck SC),
        TrGlobal (st, (sc, sg1)) Down (st, (sc, sg2))
    | tGl_Up :
        forall sg1 sg2 : S_Ck SG,
        TrG sg1 Up sg2 ->
        forall (st : S_Ck ST) (sc : S_Ck SC),
        TrGlobal (st, (sc, sg1)) Up (st, (sc, sg2))
    | tGl_Approach :
        forall (st1 st2 : S_Ck ST) (sc1 sc2 : S_Ck SC),
        TrT st1 Approach st2 ->
        TrC sc1 Approach sc2 ->
        forall sg : S_Ck SG,
        TrGlobal (st1, (sc1, sg)) Approach (st2, (sc2, sg))
    | tGl_Exit :
        forall (st1 st2 : S_Ck ST) (sc1 sc2 : S_Ck SC),
        TrT st1 Exit st2 ->
        TrC sc1 Exit sc2 ->
        forall sg : S_Ck SG, TrGlobal (st1, (sc1, sg)) Exit (st2, (sc2, sg))
    | tGl_Lower :
        forall (sc1 sc2 : S_Ck SC) (sg1 sg2 : S_Ck SG),
        TrC sc1 Lower sc2 ->
        TrG sg1 Lower sg2 ->
        forall st : S_Ck ST, TrGlobal (st, (sc1, sg1)) Lower (st, (sc2, sg2))
    | tGl_Raise :
        forall (sc1 sc2 : S_Ck SC) (sg1 sg2 : S_Ck SG),
        TrC sc1 Raise sc2 ->
        TrG sg1 Raise sg2 ->
        forall st : S_Ck ST, TrGlobal (st, (sc1, sg1)) Raise (st, (sc2, sg2))
    | tGl_Tick :
        forall (st1 st2 : S_Ck ST) (sc1 sc2 : S_Ck SC) (sg1 sg2 : S_Ck SG),
        TrT st1 Tick st2 ->
        TrC sc1 Tick sc2 ->
        TrG sg1 Tick sg2 -> TrGlobal (st1, (sc1, sg1)) Tick (st2, (sc2, sg2)).

  (* Initial states *)

  Definition ini_CkT := 0.
  Definition ini_CkC := 0.
  Definition ini_CkG := 0.

  Definition SiniT : S_Ck ST := (Far, ini_CkT).
  Definition SiniC : S_Ck SC := (Sc1, ini_CkC).
  Definition SiniG : S_Ck SG := (Open, ini_CkG).

  Definition SiniTCG : StGlobal := (SiniT, (SiniC, SiniG)).

End Automatas_TCG.

Hint Constructors InvT: sysTCG.
Hint Constructors InvC: sysTCG.
Hint Constructors InvG: sysTCG.
Hint Constructors TrT: sysTCG.
Hint Constructors TrC: sysTCG.
Hint Constructors TrG: sysTCG.
Hint Constructors TrGlobal: sysTCG.

(****************************************************************************)
(*                               System TCG: Analysis                       *)
(****************************************************************************)

Load "TemporalOperators.v".
(* Temporal operators. CTL -computation tree logic- and TCTL -timed computation tree logic- *)

(* Elemental properties of clocks and constants of the System TCG *)

Lemma Trivial1 : eq_Ck ini_CkT ini_CkC.
Proof.
  unfold eq_Ck, ini_CkT, ini_CkC in |- *; trivial.
Qed.

Lemma Trivial2 : forall x : Clock, eq_Ck x x.
Proof.
  unfold eq_Ck in |- *; trivial.
Qed.

Lemma Trivial3 : forall x y : Clock, eq_Ck x y -> eq_Ck (Inc x) (Inc y).
Proof.
  unfold eq_Ck, Inc in |- *; intros x y eq_x_y; rewrite eq_x_y; trivial.
Qed.

Lemma Trivial4 :
 forall x y z : Clock,
 eq_Ck x (plus_Ck y z) -> eq_Ck (Inc x) (plus_Ck (Inc y) z).
Proof.
  unfold eq_Ck, Inc, plus_Ck in |- *; intros.
  rewrite H; rewrite (plus_assoc_reverse y z tick);
   rewrite (plus_comm z tick); auto with *.
Qed.

Lemma Trivial5 : forall x : Clock, ge_Ck x Reset.
Proof.
  unfold Clock, ge_Ck, Reset in |- *; auto with *.
Qed.

Lemma Trivial6 : forall x y : Clock, ge_Ck x y -> ge_Ck (Inc x) (Inc y).
Proof.
  unfold Clock, ge_Ck, Inc, plus_Ck in |- *; auto with *.
Qed.

Lemma Trivial7 : forall x y : Clock, eq_Ck x y -> ge_Ck x y.
Proof.
  unfold Clock, ge_Ck, eq_Ck in |- *; intros.
  rewrite H; auto with *.
Qed.

Lemma Trivial8 : forall x y : Clock, ge_Ck x y -> ge_Ck (Inc x) y.
Proof.
  unfold Clock, ge_Ck, Inc, plus_Ck, tick, plus in |- *; auto with *.
Qed.

Lemma Trivial9 : forall x y : Clock, gt_Ck x y -> gt_Ck (Inc x) y.
Proof.
  unfold Clock, gt_Ck, Inc, plus_Ck in |- *; auto with *.
Qed.

Lemma Trivial10 : forall x : Clock, gt_Ck x kt1 -> gt_Ck x kc1.
Proof.
  unfold Clock, gt_Ck, kt1, kc1 in |- *; intros.
  apply (gt_trans x 8 4 H).
  unfold gt in |- *; repeat apply lt_n_S; apply lt_O_Sn.
Qed.

Lemma Trivial11 : forall x : Clock, ~ gt_Ck Reset x.
Proof.
  unfold Clock, gt_Ck, Reset in |- *; auto with *.
Qed.

Lemma Trivial12 :
 forall x y : Clock, gt_Ck (Inc x) y -> eq_Ck x y \/ gt_Ck x y.
Proof.
  unfold Clock, Inc, eq_Ck, gt_Ck, plus_Ck, tick in |- *; intros x y.
  rewrite (plus_comm x 1); simpl in |- *; intros.
  elim (le_lt_or_eq y x (gt_S_le y x H)); auto with *.
Qed.

Lemma Trivial13 :
 forall x y z : Clock, gt_Ck (Inc x) z -> eq_Ck x y -> ~ le_Ck (Inc y) z.
Proof.
  unfold Clock, Inc, plus_Ck, tick, eq_Ck, le_Ck, gt_Ck in |- *; intros x y z.
  rewrite (plus_comm x 1); rewrite (plus_comm y 1); simpl in |- *; intros.
  rewrite <- H0; apply gt_not_le; assumption.
Qed.

Lemma Trivial14 : forall x : Clock, gt_Ck x kt1 \/ eq_Ck x kt1 -> gt_Ck x kc1.
Proof.
  unfold Clock, kt1, kc1, tick, eq_Ck, gt_Ck in |- *; intros.
  elim H; intro H1; [ apply (gt_trans x 8 4 H1) | rewrite H1 ];
   unfold gt in |- *; repeat apply lt_n_S; apply lt_O_Sn.
Qed.

Lemma Trivial15 :
 forall x y z : Clock,
 eq_Ck x kt1 -> eq_Ck x y -> eq_Ck y (plus_Ck z kc1) -> ~ lt_Ck (Inc z) kg1.
Proof.
  unfold Clock, kt1, kc1, kg1, Inc, plus_Ck, tick, eq_Ck, lt_Ck in |- *;
   intros.
  rewrite H in H0; rewrite <- H0 in H1.
  apply lt_asym.
  rewrite (plus_comm z 4) in H1; rewrite (plus_comm z 1); simpl in |- *.
  rewrite (plus_minus 8 4 z H1); simpl in |- *.
  repeat apply lt_n_S; apply lt_O_Sn.
Qed.

Lemma Trivial16 :
 forall x y : Clock, lt_Ck x kc2 -> ~ eq_Ck x (plus_Ck y kc1).
Proof.
  unfold Clock, kc1, kc2, eq_Ck, plus_Ck, tick, lt_Ck, not in |- *; intros.
  rewrite H0 in H; elim (le_not_lt 4 (y + 4) (le_plus_r y 4) H).
Qed.

Lemma Trivial17 :
 forall x y z : Clock, eq_Ck x y -> eq_Ck x z -> ~ le_Ck (Inc z) y.
Proof.
  unfold Clock, eq_Ck, Inc, plus_Ck, tick, le_Ck in |- *; intros.
  rewrite <- H0; rewrite <- H.
  rewrite plus_comm; simpl in |- *; unfold not in |- *; intro.
  elim (n_Sn x (le_antisym x (S x) (le_n_Sn x) H1)).
Qed.

Lemma Trivial18 : lt_Ck (Inc Reset) kc2.
Proof.
  unfold lt_Ck, Inc, tick, plus_Ck, Reset, kc2 in |- *.
  rewrite (plus_comm 0 1); simpl in |- *.
  apply lt_n_S; apply lt_O_Sn.
Qed.

Lemma Trivial19 :
 forall x y z : Clock,
 lt_Ck x kg1 -> eq_Ck y (plus_Ck x kc1) -> eq_Ck z y -> lt_Ck (Inc z) kt2.
Proof.
  unfold Clock, lt_Ck, eq_Ck, Inc, tick, plus_Ck, kg1, kc1, kt2 in |- *;
   intros.
  rewrite H0 in H1; rewrite H1.
  rewrite (plus_comm x 4); rewrite (plus_comm (4 + x) 1); simpl in |- *.
  repeat apply lt_n_S.
  apply (lt_le_trans x 4 15 H).
  repeat apply le_n_S; apply le_O_n.
Qed.

Lemma Trivial20 :
 forall x y z : Clock,
 lt_Ck x kg1 -> eq_Ck y (plus_Ck x kc1) -> eq_Ck z y -> ~ gt_Ck z kt1.
Proof.
  unfold Clock, gt_Ck, lt_Ck, eq_Ck, plus_Ck, kg1, kc1, kt1, gt in |- *;
   intros.
  apply le_not_lt.
  rewrite <- H1 in H0; rewrite H0.
  generalize (plus_lt_compat_r x 4 4 H); simpl in |- *; intro.
  apply (lt_le_weak (x + 4) 8 (plus_lt_compat_r x 4 4 H)).
Qed.

Lemma Trivial21 : lt_Ck (Inc Reset) kg3.
Proof.
  unfold lt_Ck, Inc, tick, plus_Ck, Reset, kg3 in |- *.
  rewrite (plus_comm 0 1); simpl in |- *.
  apply lt_n_S; apply lt_O_Sn.
Qed.

Lemma Trivial22 : forall x y : Clock, le_Ck x y -> lt_Ck x y \/ eq_Ck x y.
Proof.
  unfold Clock, le_Ck, lt_Ck, eq_Ck in |- *; intros.
  apply (le_lt_or_eq x y H).
Qed.

Lemma Trivial23 : forall x y : Clock, lt_Ck x kc1 -> eq_Ck y x -> Inc y < kt2.
Proof.
  unfold Clock, lt_Ck, eq_Ck, Inc, tick, plus_Ck, kc1, kt2 in |- *; intros.
  rewrite <- H0 in H; rewrite (plus_comm y 1); simpl in |- *.
  apply lt_n_S.
  apply (lt_le_trans y 4 19 H).
  repeat apply le_n_S; apply le_O_n.
Qed.

Lemma Trivial24 : forall x y : Clock, lt_Ck x y -> le_Ck (Inc x) y.
Proof.
  unfold Clock, lt_Ck, le_Ck, Inc, tick, plus_Ck in |- *; intros.
  rewrite (plus_comm x 1); simpl in |- *.
  apply (lt_le_S x y H).
Qed.

Lemma Trivial25 :
 forall x y : Clock, eq_Ck y kc1 -> eq_Ck x y -> lt_Ck (Inc x) kt2.
Proof.
  unfold Clock, eq_Ck, lt_Ck, Inc, tick, plus_Ck, kc1, kt2 in |- *; intros.
  rewrite (plus_comm x 1); simpl in |- *.
  apply lt_n_S.
  rewrite H in H0; rewrite H0.
  repeat apply lt_n_S; apply lt_O_Sn.
Qed.

Lemma Trivial26 : lt_Ck (Inc Reset) kg1.
Proof.
  unfold lt_Ck, Inc, plus_Ck, tick, kg1, Reset in |- *.
  rewrite (plus_comm 0 1); simpl in |- *.
  apply lt_n_S; apply lt_O_Sn.
Qed.

Lemma Trivial27 : lt_Ck (Inc Reset) kt2.
Proof.
  unfold lt_Ck, Inc, plus_Ck, tick, kt2, Reset in |- *.
  rewrite (plus_comm 0 1); simpl in |- *.
  apply lt_n_S; apply lt_O_Sn.
Qed.

Lemma Trivial28 : le_Ck (Inc Reset) kc1.
Proof.
  unfold le_Ck, Inc, plus_Ck, tick, kc1, Reset in |- *.
  rewrite (plus_comm 0 1); simpl in |- *.
  apply le_n_S; apply le_O_n.
Qed.

Lemma Trivial29 :
 forall x : Clock, lt_Ck x kg3 -> lt_Ck x kg2 \/ ge_Ck x kg2 /\ lt_Ck x kg3.
Proof.
  unfold Clock, lt_Ck, ge_Ck, kg2, kg3, ge in |- *; intros.
  elim (le_or_lt 4 x); auto with *.
Qed.

Lemma Trivial30 : forall x : Clock, lt_Ck x kg2 -> lt_Ck (Inc x) kg3.
Proof.
  unfold Clock, lt_Ck, Inc, plus_Ck, tick, kg2, kg3 in |- *; intros.
  rewrite (plus_comm x 1); simpl in |- *.
  apply lt_n_S.
  apply (lt_le_trans x 4 7 H).
  repeat apply le_n_S; apply le_O_n.
Qed.

Lemma Trivial31 : forall x y : Clock, eq_Ck x kc1 -> ge_Ck y x -> ge_Ck y kg2.
Proof.
  unfold Clock, ge_Ck, eq_Ck, kc1, kg2, ge in |- *; intros.
  rewrite H in H0; assumption.
Qed.

Lemma not_lt_le : forall x y : nat, ~ x < y -> y <= x.
Proof.
  unfold not in |- *; intros x y no_lt_x_y.
  elim (le_or_lt y x); [ trivial | intro lt_x_y; elim (no_lt_x_y lt_x_y) ].
Qed.

Lemma Trivial32 :
 forall x : Clock, lt_Ck x kt2 -> ~ lt_Ck (Inc x) kt2 -> gt_Ck x kt1.
Proof.
  unfold Clock, lt_Ck, gt_Ck, Inc, plus_Ck, tick, kt1, kt2, gt in |- *;
   intros.
  generalize (not_lt_le H0); rewrite (plus_comm x 1); simpl in |- *; intro.
  generalize (le_antisym 19 x (le_S_n 19 x H1) (lt_n_Sm_le x 19 H)); intro H4;
   rewrite <- H4.
  repeat apply lt_n_S; apply lt_O_Sn.
Qed.

Axiom not_le_lt : forall x y : nat, ~ x <= y -> y < x.
Lemma Trivial33 :
 forall x : Clock, le_Ck x kc1 -> ~ le_Ck (Inc x) kc1 -> eq_Ck x kc1.
Proof.
  unfold Clock, le_Ck, eq_Ck, Inc, plus_Ck, tick, kc1 in |- *; intros.
  generalize (not_le_lt H0); rewrite (plus_comm x 1); simpl in |- *; intro.
  apply (le_antisym x 4 H (lt_n_Sm_le 4 x H1)).
Qed.

Lemma Trivial34 :
 forall x : Clock, lt_Ck x kg3 -> ~ lt_Ck (Inc x) kg3 -> ge_Ck x kg2.
Proof.
  unfold Clock, lt_Ck, ge_Ck, Inc, plus_Ck, tick, kg3, kg2 in |- *; intros.
  generalize (not_lt_le H0); rewrite (plus_comm x 1); simpl in |- *; intro.
  generalize (le_antisym 7 x (le_S_n 7 x H1) (lt_n_Sm_le x 7 H)); intro H4;
   rewrite <- H4.
  unfold ge in |- *; repeat apply le_n_S; apply le_O_n.
Qed.

Lemma trivial_inv_1 : lt_Ck Reset kt2.
Proof.
  unfold lt_Ck, Reset, kt2 in |- *; auto with *.
Qed.

Lemma trivial_inv_2 : forall x : Clock, le_Ck Reset x.
Proof.
  unfold Clock, le_Ck, Reset in |- *; auto with *.
Qed.

Lemma trivial_inv_3 : lt_Ck Reset kc2.
  unfold lt_Ck, Reset, kc2 in |- *; auto with *.
Qed.

Lemma trivial_inv_4 : lt_Ck Reset kg1.
Proof.
  unfold lt_Ck, Reset, kg1 in |- *; auto with *.
Qed.

Lemma trivial_inv_5 : lt_Ck Reset kg3.
Proof.
  unfold lt_Ck, Reset, kg3 in |- *; auto with *.
Qed.

(* Invertion principles for transitions and location invariants *)

Derive Inversion_clear cl_TRT_APPROACH with
 (forall st1 st2 : S_Ck ST, TrT st1 Approach st2) Sort Prop.
Derive Inversion_clear cl_TRT_IN with
 (forall st1 st2 : S_Ck ST, TrT st1 In st2) Sort Prop.
Derive Inversion_clear cl_TRT_EXIT with
 (forall st1 st2 : S_Ck ST, TrT st1 Exit st2) Sort Prop.
Derive Inversion_clear cl_TRT_INC_TIME with
 (forall st1 st2 : S_Ck ST, TrT st1 Tick st2) Sort Prop.

Derive Inversion_clear cl_TRC_APPROACH with
 (forall sc1 sc2 : S_Ck SC, TrC sc1 Approach sc2) Sort Prop.
Derive Inversion_clear cl_TRC_LOWER with
 (forall sc1 sc2 : S_Ck SC, TrC sc1 Lower sc2) Sort Prop.
Derive Inversion_clear cl_TRC_EXIT with
 (forall sc1 sc2 : S_Ck SC, TrC sc1 Exit sc2) Sort Prop.
Derive Inversion_clear cl_TRC_RAISE with
 (forall sc1 sc2 : S_Ck SC, TrC sc1 Raise sc2) Sort Prop.
Derive Inversion_clear cl_TRC_INC_TIME with
 (forall sc1 sc2 : S_Ck SC, TrC sc1 Tick sc2) Sort Prop.

Derive Inversion_clear cl_TRG_LOWER with
 (forall sg1 sg2 : S_Ck SG, TrG sg1 Lower sg2) Sort Prop.
Derive Inversion_clear cl_TRG_DOWN with
 (forall sg1 sg2 : S_Ck SG, TrG sg1 Down sg2) Sort Prop.
Derive Inversion_clear cl_TRG_RAISE with
 (forall sg1 sg2 : S_Ck SG, TrG sg1 Raise sg2) Sort Prop.
Derive Inversion_clear cl_TRG_UP with
 (forall sg1 sg2 : S_Ck SG, TrG sg1 Up sg2) Sort Prop.
Derive Inversion_clear cl_TRG_INC_TIME with
 (forall sg1 sg2 : S_Ck SG, TrG sg1 Tick sg2) Sort Prop.

Derive Inversion_clear cl_Ifar with (forall x : Clock, InvT (Far, x)) Sort
 Prop.
Derive Inversion_clear cl_Inear with (forall x : Clock, InvT (Near, x)) Sort
 Prop.
Derive Inversion_clear cl_Iinside with (forall x : Clock, InvT (Inside, x))
 Sort Prop.

Derive Inversion_clear cl_Isc1 with (forall y : Clock, InvC (Sc1, y)) Sort
 Prop.
Derive Inversion_clear cl_Isc2 with (forall y : Clock, InvC (Sc2, y)) Sort
 Prop.
Derive Inversion_clear cl_Isc3 with (forall y : Clock, InvC (Sc3, y)) Sort
 Prop.
Derive Inversion_clear cl_Isc4 with (forall y : Clock, InvC (Sc4, y)) Sort
 Prop.

Derive Inversion_clear cl_Iopen with (forall z : Clock, InvG (Open, z)) Sort
 Prop.
Derive Inversion_clear cl_Ilowering with
 (forall z : Clock, InvG (Lowering, z)) Sort Prop.
Derive Inversion_clear cl_Iclosed with (forall z : Clock, InvG (Closed, z))
 Sort Prop.
Derive Inversion_clear cl_Iraising with (forall z : Clock, InvG (Raising, z))
 Sort Prop.

(* Some tactics *)

Ltac Easy := try discriminate; auto with *.

Ltac Easy2 := intros; try discriminate; auto with *.

Ltac Simpl_or eq := elim eq; intro; Easy.

Ltac Simpl_and eq := elim eq; intros; Easy.

Ltac Generalize_Easy eq := generalize eq; intro; Easy.

Ltac Split3_Trivial := split; [ auto with * | split; auto with * ].

Ltac BeginForAll :=
  unfold ForAll in |- *; simple induction 1;
   [ simpl in |- *; intros; Easy | idtac ].

Ltac SplitTrans :=
  intros s1 s2 l rs_s1 p_s1 tr_gl; generalize rs_s1; clear rs_s1;
   generalize p_s1; clear p_s1; elim tr_gl.

Ltac SplitTrans_Simpl :=
  SplitTrans;
   [ Simpl_In
   | Simpl_Down
   | Simpl_Up
   | Simpl_Approach
   | Simpl_Exit
   | Simpl_Lower
   | Simpl_Raise
   | Simpl_Tick ]
 with Simpl_In :=
  intros st1 st2 trt_In; inversion trt_In using cl_TRT_IN;
   intros x gt_x_kt1 lt_x_kt2 sc sg; elim sc; elim sg;
   simpl in |- *; intros; Easy
 with Simpl_Down :=
  intros sg1 sg2 trg_Down; inversion trg_Down using cl_TRG_DOWN;
   intros z lt_z_kg1 st sc; elim st; elim sc; simpl in |- *;
   intros; Easy
 with Simpl_Up :=
  intros sg1 sg2 trg_Up; inversion trg_Up using cl_TRG_UP;
   intros z ge_z_kg2 lt_z_kg3 st sc; elim st; elim sc;
   simpl in |- *; intros; Easy
 with Simpl_Approach :=
  intros st1 st2 sc1 sc2 trt_Approach trc_Approach;
   inversion trt_Approach using cl_TRT_APPROACH;
   inversion trc_Approach using cl_TRC_APPROACH; intros y x sg;
   elim sg; simpl in |- *; intros; Easy
 with Simpl_Exit :=
  intros st1 st2 sc1 sc2 trt_Exit trc_Exit;
   inversion trt_Exit using cl_TRT_EXIT; inversion trc_Exit using cl_TRC_EXIT;
   intros y x lt_x_kt2 sg; elim sg; simpl in |- *;
   intros; Easy
 with Simpl_Lower :=
  intros sc1 sc2 sg1 sg2 trc_Lower trg_Lower;
   inversion trc_Lower using cl_TRC_LOWER;
   inversion trg_Lower using cl_TRG_LOWER; intros z y eq_y_kc1 st;
   elim st; simpl in |- *; intros; Easy
 with Simpl_Raise :=
  intros sc1 sc2 sg1 sg2 trc_Raise trg_Raise;
   inversion trc_Raise using cl_TRC_RAISE;
   inversion trg_Raise using cl_TRG_RAISE; intros z y lt_y_kc2 st;
   elim st; simpl in |- *; intros; Easy
 with Simpl_Tick :=
  intros st1 st2 sc1 sc2 sg1 sg2 trt_Tick trc_Tick trg_Tick;
   inversion trt_Tick using cl_TRT_INC_TIME;
   inversion trc_Tick using cl_TRC_INC_TIME;
   inversion trg_Tick using cl_TRG_INC_TIME; simpl in |- *;
   intros; Easy.

Notation InvTCG :=
  (fun s : StGlobal =>
   match s with
   | (st_x, (sc_y, sg_z)) => InvT st_x /\ InvC sc_y /\ InvG sg_z
   end) (only parsing).

Notation ForAll_TCG := (ForAll TrGlobal) (only parsing).

Notation Exists_TCG := (Exists TrGlobal) (only parsing).

(* The initial state of the system TCG satisfy the location invariants *)

Lemma Inv_SiniTCG :
 (fun s : StGlobal =>
  match s with
  | (st_x, (sc_y, sg_z)) => InvT st_x /\ InvC sc_y /\ InvG sg_z
  end) SiniTCG.
Proof.
  simpl in |- *; unfold SiniT, SiniC, SiniG in |- *; Split3_Trivial.
Qed.

(* Some invariants of the system TCG *)

Definition Inv1 (s : StGlobal) :=
  match s with
  | ((st, _), ((sc, _), (sg, _))) =>
      st = Near \/ st = Inside -> sc = Sc3 -> sg = Closed \/ sg = Lowering
  end.

Lemma lema_Inv1 : ForAll TrGlobal SiniTCG Inv1.
Proof.
  BeginForAll.
  SplitTrans_Simpl.
  Simpl_or (p_s1 H0 H1).
Qed.

Definition Inv2 (s : StGlobal) :=
  match s with
  | ((st, _), ((sc, _), (sg, _))) =>
      st = Far -> sg = Open \/ sg = Raising -> sc = Sc1
  end.

Lemma lema_Inv2 : ForAll TrGlobal SiniTCG Inv2.
Proof.
  BeginForAll.
  SplitTrans_Simpl.
  Simpl_or H1.
  elim
   (lema_Inv1 rs_s1 (or_intror (Inside = Near) (refl_equal Inside))
      (refl_equal Sc3)); intro H2; rewrite H2 in H1;
   Simpl_or H1.
  Simpl_or H1.
Qed.

Definition Inv3 (s : StGlobal) :=
  match s with
  | ((st, x), ((_, y), _)) => st = Near \/ st = Inside -> eq_Ck x y
  end.

Lemma lema_Inv3 : ForAll TrGlobal SiniTCG Inv3.
Proof.
  BeginForAll.
  apply Trivial1.
  SplitTrans_Simpl.
  Simpl_or H0.
  apply (Trivial3 (p_s1 H3)).
Qed.

Definition Inv4 (s : StGlobal) :=
  match s with
  | ((st, _), ((sc, _), _)) => st = Near -> sc = Sc2 \/ sc = Sc3
  end.

Lemma lema_Inv4 : ForAll TrGlobal SiniTCG Inv4.
Proof.
  BeginForAll.
  SplitTrans_Simpl.
  Simpl_or (p_s1 H0).
Qed.

Definition Inv5 (s : StGlobal) :=
  match s with
  | ((st, _), ((sc, y), (_, z))) =>
      st = Near -> sc = Sc3 -> eq_Ck y (plus_Ck z kc1)
  end.

Lemma lema_Inv5 : ForAll TrGlobal SiniTCG Inv5.
Proof.
  BeginForAll.
  SplitTrans_Simpl.
  apply (Trivial4 (p_s1 H3 H4)).
Qed.

Definition Inv6 (s : StGlobal) :=
  match s with
  | ((st, x), ((sc, _), _)) =>
      st = Near /\ gt_Ck x kc1 \/ st = Inside -> sc = Sc3
  end.

Lemma lema_Inv6 : ForAll TrGlobal SiniTCG Inv6.

Proof.
  BeginForAll.
  decompose [and or] H0; discriminate.
  SplitTrans_Simpl.
  apply p_s1; left; split; [ auto with * | apply (Trivial10 gt_x_kt1) ].
  decompose [and or] H0; [ elim (Trivial11 H3) | discriminate ].
  decompose [and or] H0; discriminate.
  Generalize_Easy (p_s1 H0).
  decompose [and or] H3; [ elim (Trivial12 H6) | auto with * ].
  elim (lema_Inv4 rs_s1 H5); auto with *.
    generalize (lema_Inv3 rs_s1 (or_introl (s4 = Inside) H5)); intros.
  rewrite H7 in H1. inversion H1 using cl_Isc2; intro H9. elim (Trivial13 H6 H4 H9).
  intro H7; apply p_s1; left; split;
   [ assumption | Generalize_Easy (Trivial9 H7) ].
Qed.

Definition Inv7 (s : StGlobal) :=
  match s with
  | ((st, _), ((sc, _), (sg, _))) =>
      st = Near \/ st = Inside -> sc = Sc3 -> sg = Lowering \/ sg = Closed
  end.

Lemma lema_Inv7 : ForAll TrGlobal SiniTCG Inv7.
Proof.
  BeginForAll.
  SplitTrans_Simpl.
  Simpl_or (p_s1 H0 H1).
Qed.

Definition Inv8 (s : StGlobal) :=
  match s with
  | ((st, x), ((sc, _), (sg, _))) =>
      st = Near /\ gt_Ck x kt1 \/ st = Inside -> sg = Closed
  end.

Lemma lema_Inv8 : ForAll TrGlobal SiniTCG Inv8.
Proof.
  BeginForAll.
  decompose [and or] H0; discriminate.
  SplitTrans_Simpl.
  Generalize_Easy (p_s1 H0).
  decompose [and or] H0; [ elim (Trivial11 H3) | discriminate ].
  Generalize_Easy (p_s1 H0).
  generalize (lema_Inv6 rs_s1); simpl in |- *; intro.
  decompose [and or] H0.
  Generalize_Easy
   (H1
      (or_introl (a = Inside)
         (conj H3 (Trivial14 (or_introl (eq_Ck b kt1) H4))))).
  Generalize_Easy (H1 (or_intror (a = Near /\ gt_Ck b kc1) H2)).
  decompose [and or] H3; [ Simpl_or (Trivial12 H6) | auto with * ].
  generalize
   (lema_Inv6 rs_s1
      (or_introl (s4 = Inside)
         (conj H5 (Trivial14 (or_intror (gt_Ck x kt1) H4)))));
   intro.
  Simpl_or (lema_Inv1 rs_s1 (or_introl (s4 = Inside) H5) H7).
  rewrite H8 in H0; inversion H0 using cl_Ilowering; intro.
  elim
   (Trivial15 H4 (lema_Inv3 rs_s1 (or_introl (s4 = Inside) H5))
      (lema_Inv5 rs_s1 H5 H7) H9).
Qed.

Definition safeTCG (s : StGlobal) :=
  match s with
  | ((st, _), (_, (sg, _))) => st = Inside -> sg = Closed
  end.

(* The safety property of the system TCG *)

Lemma lema_safeTCG : ForAll TrGlobal SiniTCG safeTCG.
  Proof.
  apply Mon_I with (Pg := Inv8) (Pp := safeTCG);
   [ exact lema_Inv8 | unfold Inv8, safeTCG in |- *; simpl in |- * ].
  unfold Inv8, safeTCG in |- *; simpl in |- *; intro s; elim s.
  intros y y0; elim y; elim y0.
  intros y1 y2 y3 y4; elim y1; elim y2; auto with *.
Qed.

Definition Inv9 (s : StGlobal) :=
  match s with
  | ((st, x), ((_, y), (_, z))) =>
      st = Near /\ gt_Ck x kc1 \/ st = Inside -> eq_Ck y (plus_Ck z kc1)
  end.

Lemma lema_Inv9 : ForAll TrGlobal SiniTCG Inv9.
Proof.
  BeginForAll.
  decompose [and or] H0; discriminate.
  SplitTrans_Simpl.
  apply p_s1; left; split; [ auto with * | apply (Trivial10 gt_x_kt1) ].
  decompose [and or] H0; [ elim (Trivial11 H3) | discriminate ].
  decompose [and or] H0; discriminate.
  elim (Trivial16 lt_y_kc2 (p_s1 H0)).
  decompose [and or] H3.
  elim (Trivial12 H6); intro.
  elim (lema_Inv4 rs_s1 H5); intro.
  rewrite H7 in H1; inversion H1 using cl_Isc2; intro.
  generalize (lema_Inv3 rs_s1 (or_introl (s4 = Inside) H5)); intro.
  elim (Trivial17 H4 H9 H8).
  apply (Trivial4 (lema_Inv5 rs_s1 H5 H7)).
  apply Trivial4; apply p_s1; left; split; assumption.
  apply (Trivial4 (p_s1 (or_intror (s4 = Near /\ gt_Ck x kc1) H4))).
Qed.

Definition Inv10 (s : StGlobal) :=
  match s with
  | (_, ((sc, _), (sg, _))) =>
      sc = Sc1 \/ sc = Sc2 -> sg = Open \/ sg = Raising
  end.

Lemma lema_Inv10 : ForAll TrGlobal SiniTCG Inv10.
Proof.
  BeginForAll.
  SplitTrans_Simpl.
  Simpl_or (p_s1 H0).
  Simpl_or H0.
  Simpl_or H0.
Qed.

Definition Inv11 (s : StGlobal) :=
  match s with
  | (_, ((sc, _), (sg, _))) =>
      sg = Lowering \/ sg = Closed -> sc = Sc3 \/ sc = Sc4
  end.

Lemma lema_Inv11 : ForAll TrGlobal SiniTCG Inv11.
Proof.
  generalize (Mon_I (tr:=TrGlobal) (Sini:=SiniTCG) (Pg:=Inv10) (Pp:=Inv11));
   unfold ForAll in |- *; intros.
  apply H; [ exact lema_Inv10 | idtac | assumption ].
  unfold Inv10, Inv11 in |- *; simpl in |- *; intro.
  elim s0; intros y y0; elim y; elim y0; intros y1 y2 y3 y4; elim y1; elim y2.
  intros sg ck sc; elim sg.
  intros ck1 H1 H2; Simpl_or H2.
  elim sc; intros ck1 H1;
   [ elim H1; Easy2
   | elim H1; Easy2
   | left; auto with *
   | right; auto with * ].
  elim sc; intros ck1 H1;
   [ elim H1; Easy2
   | elim H1; Easy2
   | left; auto with *
   | right; auto with * ].
  intros ck1 H1 H2; Simpl_or H2.
Qed.

Definition Inv12 (s : StGlobal) :=
  match s with
  | (_, ((sc, y), (_, z))) => sc = Sc2 -> ge_Ck z y
  end.

Lemma lema_Inv12 : ForAll TrGlobal SiniTCG Inv12.
Proof.
  BeginForAll.
  SplitTrans_Simpl.
  apply Trivial5.
  apply (Trivial6 (p_s1 H3)).
Qed.

Definition Inv13 (s : StGlobal) :=
  match s with
  | ((st, _), ((sc, _), _)) => sc = Sc2 -> st = Near
  end.

Lemma lema_Inv13 : ForAll TrGlobal SiniTCG Inv13.
Proof.
  BeginForAll.
  SplitTrans_Simpl.
  generalize (lema_Inv6 rs_s1); simpl in |- *.
  rewrite H0.
  intro H1;
   Generalize_Easy
    (H1
       (or_introl (Near = Inside)
          (conj (refl_equal Near) (Trivial10 gt_x_kt1)))).
Qed.

Definition Inv14 (s : StGlobal) :=
  match s with
  | ((st, _), ((sc, _), (sg, _))) => sc = Sc4 -> st = Far /\ sg = Closed
  end.

Lemma lema_Inv14 : ForAll TrGlobal SiniTCG Inv14.
Proof.
  BeginForAll.
  SplitTrans_Simpl.
  Simpl_and (p_s1 H0).
  Simpl_and (p_s1 H0).
  Simpl_and (p_s1 H0).
  split; [ auto with * | apply (lema_safeTCG rs_s1 (refl_equal Inside)) ].
Qed.

Definition InvSc3 (s : StGlobal) :=
  match s with
  | (_, ((sc, y), _)) => sc = Sc3 -> ge_Ck y kc1
  end.

Lemma lema_InvSc3 : ForAll TrGlobal SiniTCG InvSc3.
Proof.
  BeginForAll.
  SplitTrans_Simpl.
  apply (Trivial7 eq_y_kc1).
  apply (Trivial8 (p_s1 H3)).
Qed.

Definition InvInside (s : StGlobal) :=
  match s with
  | ((st, x), _) => st = Inside -> gt_Ck x kt1
  end.

Lemma lema_InvInside : ForAll TrGlobal SiniTCG InvInside.
Proof.
  BeginForAll.
  SplitTrans_Simpl.
  apply (Trivial9 (p_s1 H3)).
Qed.

(* Lemmas, definitions and auxiliar tactics for the NonZeno property *)

Lemma InvT' :
 forall s : S_Ck ST,
 match s with
 | (st, x) =>
     st = Far \/ st = Near /\ lt_Ck x kt2 \/ st = Inside /\ lt_Ck x kt2 ->
     InvT s
 end.
Proof.
  intro s; elim s.
  intros.
  elim H;
   [ intro st; rewrite st; auto with *
   | intro n_i; elim n_i; intro H1; elim H1; intros st cond; rewrite st;
      [ apply Inear | apply Iinside ]; auto with * ].
Qed.

Lemma InvC' :
 forall s : S_Ck SC,
 match s with
 | (sc, y) =>
     sc = Sc1 \/
     sc = Sc2 /\ le_Ck y kc1 \/ sc = Sc3 \/ sc = Sc4 /\ lt_Ck y kc2 ->
     InvC s
 end.
Proof.
  intro s; elim s.
  intros.
  elim H;
   [ intro sc; rewrite sc; auto with *
   | intro sc2_4; elim sc2_4;
      [ intro H1; elim H1; intros sc cond; rewrite sc; apply Isc2;
         auto with *
      | intro sc3_4; elim sc3_4;
         [ intro sc; rewrite sc; auto with *
         | intro H1; elim H1; intros sc cond; rewrite sc; apply Isc4;
            auto with * ] ] ].
Qed.

Lemma InvG' :
 forall s : S_Ck SG,
 match s with
 | (sg, z) =>
     sg = Open \/
     sg = Lowering /\ lt_Ck z kg1 \/
     sg = Closed \/ sg = Raising /\ lt_Ck z kg3 ->
     InvG s
 end.
Proof.
  intro s; elim s.
  intros.
  elim H;
   [ intro sg; rewrite sg; auto with *
   | intro sg2_4; elim sg2_4;
      [ intro H1; elim H1; intros sg cond; rewrite sg; apply Ilowering;
         auto with *
      | intro sg3_4; elim sg3_4;
         [ intro sg; rewrite sg; auto with *
         | intro H1; elim H1; intros sg cond; rewrite sg; apply Iraising;
            auto with * ] ] ].
Qed.

Lemma NoImpl : forall A B : Prop, (A -> B) -> ~ B -> ~ A.
Proof.
  unfold not in |- *; auto with *.
Qed.

Lemma not_3_and :
 forall A B C : Prop, ~ (A /\ B /\ C) -> ~ A \/ A /\ ~ B \/ A /\ B /\ ~ C.
Proof.
  intros.
  elim (not_and_or _ _ H); intro H2;
   [ idtac | elim (not_and_or _ _ H2); intro ].
  auto with *.
  elim (classic A); auto with *.
  elim (classic A); elim (classic B); auto with *.
Qed.

Notation no_invT :=
  (fun s : S_Ck ST =>
   match s with
   | (st, x) => st = Near /\ ~ lt_Ck x kt2 \/ st = Inside /\ ~ lt_Ck x kt2
   end) (only parsing).

Lemma No_invT :
 forall s : S_Ck ST,
 ~ InvT s ->
 (fun s : S_Ck ST =>
  match s with
  | (st, x) => st = Near /\ ~ lt_Ck x kt2 \/ st = Inside /\ ~ lt_Ck x kt2
  end) s.
Proof.
  intro s; elim s.
  intros st x inv.
  generalize (not_or_and _ _ (NoImpl (InvT' (st, x)) inv)); elim st; intro H0;
   elim H0; intros H1 H2; elim (not_or_and _ _ H2);
   intros.
  absurd (Far = Far); auto with *.
  elim (not_and_or _ _ H); intros;
   [ absurd (Near = Near); auto with * | auto with * ].
  elim (not_and_or _ _ H3); intros;
   [ absurd (Inside = Inside); auto with * | auto with * ].
Qed.

Notation no_invC :=
  (fun s : S_Ck SC =>
   match s with
   | (sc, y) => sc = Sc2 /\ ~ le_Ck y kc1 \/ sc = Sc4 /\ ~ lt_Ck y kc2
   end) (only parsing).

Lemma No_invC :
 forall s : S_Ck SC,
 ~ InvC s ->
 (fun s : S_Ck SC =>
  match s with
  | (sc, y) => sc = Sc2 /\ ~ le_Ck y kc1 \/ sc = Sc4 /\ ~ lt_Ck y kc2
  end) s.
Proof.
  intro s; elim s.
  intros sc y inv.
  generalize (not_or_and _ _ (NoImpl (InvC' (sc, y)) inv)); elim sc; intro H0;
   elim H0; intros H1 H2; elim (not_or_and _ _ H2);
   intros.
  absurd (Sc1 = Sc1); auto with *.
  elim (not_and_or _ _ H); intros;
   [ absurd (Sc2 = Sc2); auto with * | auto with * ].
  elim (not_or_and _ _ H3); intros; absurd (Sc3 = Sc3); auto with *.
  elim (not_or_and _ _ H3); intros H4 H5; elim (not_and_or _ _ H5); intros;
   [ absurd (Sc4 = Sc4); auto with * | auto with * ].
Qed.

Notation no_invG :=
  (fun s : S_Ck SG =>
   match s with
   | (sg, z) =>
       sg = Lowering /\ ~ lt_Ck z kg1 \/ sg = Raising /\ ~ lt_Ck z kg3
   end) (only parsing).

Lemma No_invG :
 forall s : S_Ck SG,
 ~ InvG s ->
 (fun s : S_Ck SG =>
  match s with
  | (sg, z) =>
      sg = Lowering /\ ~ lt_Ck z kg1 \/ sg = Raising /\ ~ lt_Ck z kg3
  end) s.
Proof.
  intro s; elim s.
  intros sc y inv.
  generalize (not_or_and _ _ (NoImpl (InvG' (sc, y)) inv)); elim sc; intro H0;
   elim H0; intros H1 H2; elim (not_or_and _ _ H2);
   intros.
  absurd (Open = Open); auto with *.
  elim (not_and_or _ _ H); intros;
   [ absurd (Lowering = Lowering); auto with * | auto with * ].
  elim (not_or_and _ _ H3); intros; absurd (Closed = Closed); auto with *.
  elim (not_or_and _ _ H3); intros H4 H5; elim (not_and_or _ _ H5); intros;
   [ absurd (Raising = Raising); auto with * | auto with * ].
Qed.

Lemma INV_TCG_general :
 forall s : StGlobal,
 (fun s : StGlobal =>
  match s with
  | (st_x, (sc_y, sg_z)) => InvT st_x /\ InvC sc_y /\ InvG sg_z
  end) s ->
 ForAll TrGlobal s
   (fun s : StGlobal =>
    match s with
    | (st_x, (sc_y, sg_z)) => InvT st_x /\ InvC sc_y /\ InvG sg_z
    end).
Proof.
  intros.
  BeginForAll.
  SplitTrans_Simpl; elim p_s1; intros H1 H2; elim H2; intros; auto with *;
   (split; [ auto with * | split; auto with * ]).
  apply Inear; apply trivial_inv_1.
  apply Isc2; apply trivial_inv_2.
  apply Isc4; apply trivial_inv_3.
  apply Ilowering; apply trivial_inv_4.
  apply Iraising; apply trivial_inv_5.
Qed.

Lemma INV_T_general :
 forall s1 s2 : StGlobal,
 (fun s : StGlobal =>
  match s with
  | (st_x, (sc_y, sg_z)) => InvT st_x /\ InvC sc_y /\ InvG sg_z
  end) s1 -> RState TrGlobal s1 s2 -> InvT (fst s2).
Proof.
  intros.
  generalize (INV_TCG_general H H0).
  elim s2; simpl in |- *.
  intros st sc_sg.
  elim sc_sg; intros.
  elim H1; auto with *.
Qed.

Lemma INV_C_general :
 forall s1 s2 : StGlobal,
 (fun s : StGlobal =>
  match s with
  | (st_x, (sc_y, sg_z)) => InvT st_x /\ InvC sc_y /\ InvG sg_z
  end) s1 -> RState TrGlobal s1 s2 -> InvC (fst (snd s2)).
Proof.
  intros.
  generalize (INV_TCG_general H H0).
  elim s2; simpl in |- *.
  intros st sc_sg.
  elim sc_sg; simpl in |- *; intros.
  elim H1; intros inv_T inv_C_G; elim inv_C_G; auto with *.
Qed.

Lemma INV_G_general :
 forall s1 s2 : StGlobal,
 (fun s : StGlobal =>
  match s with
  | (st_x, (sc_y, sg_z)) => InvT st_x /\ InvC sc_y /\ InvG sg_z
  end) s1 -> RState TrGlobal s1 s2 -> InvG (snd (snd s2)).
Proof.
  intros.
  generalize (INV_TCG_general H H0).
  elim s2; simpl in |- *.
  intros st sc_sg.
  elim sc_sg; simpl in |- *; intros.
  elim H1; intros inv_T inv_C_G; elim inv_C_G; auto with *.
Qed.

Definition InvTick (s : StGlobal) :=
  match s with
  | ((st, x), ((sc, y), (sg, z))) =>
      (fun s : StGlobal =>
       match s with
       | (st_x, (sc_y, sg_z)) => InvT st_x /\ InvC sc_y /\ InvG sg_z
       end) (st, Inc x, (sc, Inc y, (sg, Inc z)))
  end.

Definition noInvTick (s : StGlobal) :=
  match s with
  | ((st, x), ((sc, y), (sg, z))) =>
      ~ InvTick (st, x, (sc, y, (sg, z))) ->
      RState TrGlobal SiniTCG (st, x, (sc, y, (sg, z))) ->
      (st = Near /\ gt_Ck x kt1 \/ st = Inside) \/
      InvT (st, Inc x) /\ (sc = Sc2 /\ eq_Ck y kc1 \/ sc = Sc4) \/
      InvT (st, Inc x) /\
      InvC (sc, Inc y) /\ (sg = Lowering \/ sg = Raising /\ ge_Ck z kg2)
  end.

Lemma NoInvTick : forall s : StGlobal, noInvTick s.
Proof.
  intro s; elim s.
  intros st sc_sg; elim sc_sg; intros sc sg; elim st; elim sc; elim sg;
   intros.
  simpl in |- *; intros.
  elim (not_3_and H); [ intro no_invt | intro H1; decompose [and or] H1 ].
  elim (No_invT no_invt); intro H1; elim H1; intros st' x; rewrite st';
   rewrite st' in H0.
  generalize (INV_T_general (s1:=SiniTCG) Inv_SiniTCG H0); simpl in |- *;
   intro inv_near; inversion inv_near using cl_Inear;
   intro lt_x_kt2.
  left; left; split; [ auto with * | apply (Trivial32 lt_x_kt2 x) ].
  auto with *.
  elim (No_invC H4); intro H5; elim H5; intros sc' y'; rewrite sc';
   rewrite sc' in H0.
  generalize (INV_C_general (s1:=SiniTCG) Inv_SiniTCG H0); simpl in |- *;
   intro inv_sc2; inversion inv_sc2 using cl_Isc2;
   intro le_y_kc1.
  generalize (Trivial33 le_y_kc1 y'); intro.
  right; left; auto with *.
  auto with *.
  elim (No_invG H5); intro H6; elim H6; intros sg' z; rewrite sg';
   rewrite sg' in H0.
  right; right; auto with *.
  generalize (INV_G_general (s1:=SiniTCG) Inv_SiniTCG H0); simpl in |- *;
   intro inv_raising; inversion inv_raising using cl_Iraising;
   intro lt_z_kg3.
  generalize (Trivial34 lt_z_kg3 z); intro.
  right; right; auto with *.
Qed.

Notation rsNext_In :=
  (fun (x : Clock) (gt_x_kt1 : gt_Ck x kt1) (lt_x_kt2 : lt_Ck x kt2)
     (sc_y : S_Ck SC) (sg_z : S_Ck SG) =>
   rsNext (rsIni TrGlobal (Near, x, (sc_y, sg_z)))
     (tGl_In (ttIn (x:=x) gt_x_kt1 lt_x_kt2) sc_y sg_z))
  (only parsing).

Notation rsNext_Down :=
  (fun (z : Clock) (lt_z_kg1 : lt_Ck z kg1) (st_x : S_Ck ST) (sc_y : S_Ck SC) =>
   rsNext (rsIni TrGlobal (st_x, (sc_y, (Lowering, z))))
     (tGl_Down (tgDown lt_z_kg1) st_x sc_y)) (only parsing).

Notation rsNext_Up :=
  (fun (z : Clock) (ge_z_kg2 : ge_Ck z kg2) (lt_z_kg3 : lt_Ck z kg3)
     (st_x : S_Ck ST) (sc_y : S_Ck SC) =>
   rsNext (rsIni TrGlobal (st_x, (sc_y, (Raising, z))))
     (tGl_Up (tgUp ge_z_kg2 lt_z_kg3) st_x sc_y)) (only parsing).

Notation rs_Next_Approach :=
  (fun (x y : Clock) (sg_z : S_Ck SG) =>
   rsNext StGlobal (rsIni StGlobal TrGlobal (Far, x, (Sc1, y, sg_z)))
     (tGl_Approach (ttApproach x) (tcApproach y) sg_z))
  (only parsing).

Notation rsNext_Exit :=
  (fun (x y : Clock) (lt_x_kt2 : lt_Ck x kt2) (sg_z : S_Ck SG) =>
   rsNext (rsIni TrGlobal (Inside, x, (Sc3, y, sg_z)))
     (tGl_Exit (ttExit lt_x_kt2) (tcExit y) sg_z))
  (only parsing).

Notation rsNext_Lower :=
  (fun (y z : Clock) (eq_y_kc1 : eq_Ck y kc1) (st_x : S_Ck ST) =>
   rsNext (rsIni TrGlobal (st_x, (Sc2, y, (Open, z))))
     (tGl_Lower (tcLower eq_y_kc1) (tgLower z) st_x))
  (only parsing).

Notation rsNext_Raise :=
  (fun (y z : Clock) (lt_y_kc2 : lt_Ck y kc2) (st_x : S_Ck ST) =>
   rsNext (rsIni TrGlobal (st_x, (Sc4, y, (Closed, z))))
     (tGl_Raise (tcRaise lt_y_kc2) (tgRaise z) st_x))
  (only parsing).

Ltac SplitTrans' :=
  intros s1 s2 l rs_s1 p_s1 tr_gl; generalize (rsNext rs_s1 tr_gl);
   generalize rs_s1; clear rs_s1; generalize p_s1;
   clear p_s1; elim tr_gl.

Ltac SplitTrans'_Simpl :=
  SplitTrans';
   [ Simpl_In
   | Simpl_Down
   | Simpl_Up
   | Simpl_Approach
   | Simpl_Exit
   | Simpl_Lower
   | Simpl_Raise
   | Simpl_Tick ].

Ltac ExistsHere_ITick s :=
  apply exists_ with (tr := TrGlobal) (P := InvTick) (1 := rsIni TrGlobal s).

(* NonZeno proof for the system TCG *)

Lemma NonZeno :
 ForAll TrGlobal SiniTCG (fun s : StGlobal => Exists TrGlobal s InvTick).
Proof.
  BeginForAll.
  ExistsHere_ITick SiniTCG.
  Split3_Trivial.
  SplitTrans'_Simpl; generalize H0.
  rewrite
   (lema_Inv6 H0
      (or_intror (Inside = Near /\ gt_Ck x kc1) (refl_equal Inside)))
   .
  rewrite (lema_safeTCG H0 (refl_equal Inside)); intro rs_s2.
  apply StepsEX with (s2 := (Far, x, (Sc4, Reset, (Closed, b)))).
  apply
   ((fun (x y : Clock) (lt_x_kt2 : lt_Ck x kt2) (sg_z : S_Ck SG) =>
     rsNext (rsIni TrGlobal (Inside, x, (Sc3, y, sg_z)))
       (tGl_Exit (ttExit lt_x_kt2) (tcExit y) sg_z)) x b0 lt_x_kt2
      (Closed, b)).
  ExistsHere_ITick (Far, x, (Sc4, Reset, (Closed, b))).
  Split3_Trivial; (apply Isc4; apply Trivial18).
  elim (lema_Inv11 H0 (or_intror (Closed = Lowering) (refl_equal Closed)));
   intro sc_closed; rewrite sc_closed.
  elim a0; intro rs_s2.
  ExistsHere_ITick (Far, b0, (Sc3, b, (Closed, z))).
  Split3_Trivial.
  ExistsHere_ITick (Near, b0, (Sc3, b, (Closed, z))).
  Split3_Trivial.
  apply Inear.
  apply
   (Trivial19 lt_z_kg1 (lema_Inv5 rs_s2 (refl_equal Near) (refl_equal Sc3))
      (lema_Inv3 rs_s2 (or_introl (Near = Inside) (refl_equal Near)))).
  elim
   (Trivial20 lt_z_kg1
      (lema_Inv9 rs_s2
         (or_intror (Inside = Near /\ gt_Ck b0 kc1) (refl_equal Inside)))
      (lema_Inv3 rs_s2 (or_intror (Inside = Near) (refl_equal Inside)))
      (lema_InvInside rs_s2 (refl_equal Inside))).
  elim a0; intro rs_s2.
  generalize (INV_C_general (s1:=SiniTCG) Inv_SiniTCG rs_s2); simpl in |- *;
   intro inv_sc4; inversion inv_sc4 using cl_Isc4;
   intro le_y0_kc2.
  apply StepsEX with (s2 := (Far, b0, (Sc1, b, (Raising, Reset)))).
  apply
   ((fun (y z : Clock) (lt_y_kc2 : lt_Ck y kc2) (st_x : S_Ck ST) =>
     rsNext (rsIni TrGlobal (st_x, (Sc4, y, (Closed, z))))
       (tGl_Raise (tcRaise lt_y_kc2) (tgRaise z) st_x)) b z le_y0_kc2
      (Far, b0)).
  ExistsHere_ITick (Far, b0, (Sc1, b, (Raising, Reset))).
  Split3_Trivial; (apply Iraising; apply Trivial21).
  elim (lema_Inv4 rs_s2 (refl_equal Near)); intro sc_near;
   rewrite sc_near in sc_closed; discriminate.
  elim
   (Trivial20 lt_z_kg1
      (lema_Inv9 rs_s2
         (or_intror (Inside = Near /\ gt_Ck b0 kc1) (refl_equal Inside)))
      (lema_Inv3 rs_s2 (or_intror (Inside = Near) (refl_equal Inside)))
      (lema_InvInside rs_s2 (refl_equal Inside))).
  elim a0.
  intro rs_s2; generalize rs_s2;
   rewrite
    (lema_Inv2 rs_s2 (refl_equal Far)
       (or_introl (Open = Raising) (refl_equal Open)))
    ; intro rs_s2fin.
  ExistsHere_ITick (Far, b0, (Sc1, b, (Open, z))).
  Split3_Trivial.
  intro rs_s2; generalize rs_s2; elim (lema_Inv4 rs_s2 (refl_equal Near));
   intro sc_near; rewrite sc_near.
  intro rs_s2'; generalize (INV_C_general (s1:=SiniTCG) Inv_SiniTCG rs_s2');
   simpl in |- *; intro inv_sc2; inversion inv_sc2 using cl_Isc2;
   intro le_y0_kc1.
  elim (Trivial22 le_y0_kc1); intro.
  ExistsHere_ITick (Near, b0, (Sc2, b, (Open, z))).
  split; [ apply Inear | split; [ apply Isc2 | auto with * ] ].
  apply
   (Trivial23 H1
      (lema_Inv3 rs_s2' (or_introl (Near = Inside) (refl_equal Near)))).
  apply (Trivial24 H1).
  apply StepsEX with (s2 := (Near, b0, (Sc3, b, (Lowering, Reset)))).
  apply
   ((fun (y z : Clock) (eq_y_kc1 : eq_Ck y kc1) (st_x : S_Ck ST) =>
     rsNext (rsIni TrGlobal (st_x, (Sc2, y, (Open, z))))
       (tGl_Lower (tcLower eq_y_kc1) (tgLower z) st_x)) b z H1
      (Near, b0)).
  ExistsHere_ITick (Near, b0, (Sc3, b, (Lowering, Reset))).
  split; [ apply Inear | split; [ auto with * | apply Ilowering ] ].
  apply
   (Trivial25 H1
      (lema_Inv3 rs_s2' (or_introl (Near = Inside) (refl_equal Near)))).
  apply Trivial26.
  intro rs_s2fin;
   elim
    (lema_Inv1 rs_s2fin (or_introl (Near = Inside) (refl_equal Near))
       (refl_equal Sc3)); intro; discriminate.
  intro rs_s2; Generalize_Easy (lema_safeTCG rs_s2 (refl_equal Inside)).
  elim (lema_Inv10 H0 (or_intror (Sc2 = Sc1) (refl_equal Sc2))); intros H1;
   rewrite H1; intro rs_s2.
  ExistsHere_ITick (Near, Reset, (Sc2, Reset, (Open, b))).
  split;
   [ apply Inear; apply Trivial27
   | split; [ apply Isc2; apply Trivial28 | auto with * ] ].
  generalize (INV_G_general (s1:=SiniTCG) Inv_SiniTCG rs_s2); simpl in |- *;
   intro inv_raising; inversion inv_raising using cl_Iraising;
   intro lt_y1_kg3.
  elim (Trivial29 lt_y1_kg3); intro.
  ExistsHere_ITick (Near, Reset, (Sc2, Reset, (Raising, b))).
  split;
   [ apply Inear; apply Trivial27
   | split;
      [ apply Isc2; apply Trivial28 | apply Iraising; apply (Trivial30 H2) ] ].
  apply StepsEX with (s2 := (Near, Reset, (Sc2, Reset, (Open, b)))).
  elim H2; intros H3 H4.
  apply
   ((fun (z : Clock) (ge_z_kg2 : ge_Ck z kg2) (lt_z_kg3 : lt_Ck z kg3)
       (st_x : S_Ck ST) (sc_y : S_Ck SC) =>
     rsNext (rsIni TrGlobal (st_x, (sc_y, (Raising, z))))
       (tGl_Up (tgUp ge_z_kg2 lt_z_kg3) st_x sc_y)) b H3 H4
      (Near, Reset) (Sc2, Reset)).
  ExistsHere_ITick (Near, Reset, (Sc2, Reset, (Open, b))).
  split;
   [ apply Inear; apply Trivial27
   | split; [ apply Isc2; apply Trivial28 | auto with * ] ].
  elim a; intro rs_s2.
  ExistsHere_ITick (Far, x, (Sc4, Reset, (Open, b))).
  Split3_Trivial.
  apply Isc4; apply Trivial18.
  generalize (INV_G_general (s1:=SiniTCG) Inv_SiniTCG rs_s2); simpl in |- *;
   intro inv_lowering; inversion inv_lowering using cl_Ilowering;
   intro lt_y1_kg1.
  apply StepsEX with (s2 := (Far, x, (Sc4, Reset, (Closed, b)))).
  apply
   ((fun (z : Clock) (lt_z_kg1 : lt_Ck z kg1) (st_x : S_Ck ST)
       (sc_y : S_Ck SC) =>
     rsNext (rsIni TrGlobal (st_x, (sc_y, (Lowering, z))))
       (tGl_Down (tgDown lt_z_kg1) st_x sc_y)) b lt_y1_kg1
      (Far, x) (Sc4, Reset)).
  ExistsHere_ITick (Far, x, (Sc4, Reset, (Closed, b))).
  Split3_Trivial.
  apply Isc4; apply Trivial18.
  ExistsHere_ITick (Far, x, (Sc4, Reset, (Closed, b))).
  Split3_Trivial.
  apply Isc4; apply Trivial18.
  Generalize_Easy
   (lema_Inv2 rs_s2 (refl_equal Far)
      (or_intror (Raising = Open) (refl_equal Raising))).
  intro rs_s2; ExistsHere_ITick (a, b, (Sc3, y, (Lowering, Reset))).
  split;
   [ generalize rs_s2; elim a; intro rs_s2'
   | split; [ auto with * | apply Ilowering; apply Trivial26 ] ].
  auto with *.
  apply Inear;
   apply
    (Trivial25 eq_y_kc1
       (lema_Inv3 rs_s2' (or_introl (Near = Inside) (refl_equal Near)))).
  Generalize_Easy (lema_safeTCG rs_s2' (refl_equal Inside)).
  intro rs_s2; ExistsHere_ITick (a, b, (Sc1, y, (Raising, Reset))).
  split;
   [ generalize rs_s2; elim a; intro rs_s2'
   | split; [ auto with * | apply Iraising; apply Trivial21 ] ].
  auto with *.
  Simpl_or (lema_Inv4 rs_s2' (refl_equal Near)).
  Generalize_Easy (lema_safeTCG rs_s2' (refl_equal Inside)).
  intro; elim (classic (InvTick (s4, Inc x, (s3, Inc y, (s0, Inc z)))));
   intro inv_tick.
  ExistsHere_ITick (s4, Inc x, (s3, Inc y, (s0, Inc z))); auto with *.
  generalize H3;
   elim (NoInvTick (s4, Inc x, (s3, Inc y, (s0, Inc z))) inv_tick H3).
  intro no_st; decompose [and or] no_st; [ rewrite H6 | rewrite H5 ].
  intro rs_near; generalize (INV_T_general (s1:=SiniTCG) Inv_SiniTCG rs_near);
   simpl in |- *; intro inv_near; inversion inv_near using cl_Inear;
   intro lt_incx_kt2.
  generalize
   ((fun (x : Clock) (gt_x_kt1 : gt_Ck x kt1) (lt_x_kt2 : lt_Ck x kt2)
       (sc_y : S_Ck SC) (sg_z : S_Ck SG) =>
     rsNext (rsIni TrGlobal (Near, x, (sc_y, sg_z)))
       (tGl_In (ttIn (x:=x) gt_x_kt1 lt_x_kt2) sc_y sg_z))
      (Inc x) H7 lt_incx_kt2 (s3, Inc y) (s0, Inc z));
   intro rs_inside.
  generalize rs_near; generalize rs_inside;
   rewrite
    (lema_Inv6 (RState_Trans rs_near rs_inside)
       (or_intror (Inside = Near /\ gt_Ck (Inc x) kc1) (refl_equal Inside)))
    .
  rewrite (lema_safeTCG (RState_Trans rs_near rs_inside) (refl_equal Inside)).
  intros;
   apply StepsEX with (s2 := (Far, Inc x, (Sc4, Reset, (Closed, Inc z)))).
  apply
   (RState_Trans rs_inside0
      ((fun (x y : Clock) (lt_x_kt2 : lt_Ck x kt2) (sg_z : S_Ck SG) =>
        rsNext (rsIni TrGlobal (Inside, x, (Sc3, y, sg_z)))
          (tGl_Exit (ttExit lt_x_kt2) (tcExit y) sg_z))
         (Inc x) (Inc y) lt_incx_kt2 (Closed, Inc z))).
  ExistsHere_ITick (Far, Inc x, (Sc4, Reset, (Closed, Inc z))).
  Split3_Trivial; apply Isc4; apply Trivial18.
  intro rs_inside; generalize rs_inside;
   rewrite (lema_safeTCG rs_inside (refl_equal Inside));
   intro rs_inside0.
  generalize rs_inside0;
   rewrite
    (lema_Inv6 rs_inside0
       (or_intror (Inside = Near /\ gt_Ck (Inc x) kc1) (refl_equal Inside)))
    ; intro rs_inside1.
  apply StepsEX with (s2 := (Far, Inc x, (Sc4, Reset, (Closed, Inc z)))).
  generalize (INV_T_general (s1:=SiniTCG) Inv_SiniTCG rs_inside0);
   simpl in |- *; intro inv_inside; inversion inv_inside using cl_Iinside;
   intro lt_incx_kt2.
  apply
   ((fun (x y : Clock) (lt_x_kt2 : lt_Ck x kt2) (sg_z : S_Ck SG) =>
     rsNext (rsIni TrGlobal (Inside, x, (Sc3, y, sg_z)))
       (tGl_Exit (ttExit lt_x_kt2) (tcExit y) sg_z))
      (Inc x) (Inc y) lt_incx_kt2 (Closed, Inc z)).
  ExistsHere_ITick (Far, Inc x, (Sc4, Reset, (Closed, Inc z))).
  Split3_Trivial; apply Isc4; apply Trivial18.
  intro no_sc_sg; elim no_sc_sg;
   [ intro st_no_sc; decompose [and or] st_no_sc | intro no_sg ].
  rewrite H6; rewrite H6 in rs_s1.
  elim (lema_Inv10 rs_s1 (or_intror (Sc2 = Sc1) (refl_equal Sc2))); intro sg';
   rewrite sg'.
  intro rs_s2;
   apply StepsEX with (s2 := (s4, Inc x, (Sc3, Inc y, (Lowering, Reset)))).
  apply
   ((fun (y z : Clock) (eq_y_kc1 : eq_Ck y kc1) (st_x : S_Ck ST) =>
     rsNext (rsIni TrGlobal (st_x, (Sc2, y, (Open, z))))
       (tGl_Lower (tcLower eq_y_kc1) (tgLower z) st_x))
      (Inc y) (Inc z) H8 (s4, Inc x)).
  ExistsHere_ITick (s4, Inc x, (Sc3, Inc y, (Lowering, Reset))).
  Split3_Trivial; apply Ilowering; apply Trivial26.
  intro rs_s2;
   apply StepsEX with (s2 := (s4, Inc x, (Sc2, Inc y, (Open, Inc z)))).
  generalize (lema_Inv12 rs_s2 (refl_equal Sc2)); intro ge_incz_incy.
  generalize (INV_G_general (s1:=SiniTCG) Inv_SiniTCG rs_s2); simpl in |- *;
   intro inv_raising; inversion inv_raising using cl_Iraising;
   intro lt_incz_kg3.
  apply
   ((fun (z : Clock) (ge_z_kg2 : ge_Ck z kg2) (lt_z_kg3 : lt_Ck z kg3)
       (st_x : S_Ck ST) (sc_y : S_Ck SC) =>
     rsNext (rsIni TrGlobal (st_x, (sc_y, (Raising, z))))
       (tGl_Up (tgUp ge_z_kg2 lt_z_kg3) st_x sc_y))
      (Inc z) (Trivial31 H8 ge_incz_incy) lt_incz_kg3
      (s4, Inc x) (Sc2, Inc y)).
  apply StepsEX with (s2 := (s4, Inc x, (Sc3, Inc y, (Lowering, Reset)))).
  apply
   ((fun (y z : Clock) (eq_y_kc1 : eq_Ck y kc1) (st_x : S_Ck ST) =>
     rsNext (rsIni TrGlobal (st_x, (Sc2, y, (Open, z))))
       (tGl_Lower (tcLower eq_y_kc1) (tgLower z) st_x))
      (Inc y) (Inc z) H8 (s4, Inc x)).
  ExistsHere_ITick (s4, Inc x, (Sc3, Inc y, (Lowering, Reset))).
  Split3_Trivial; apply Ilowering; apply Trivial26.
  rewrite H7; intro rs_s2; generalize rs_s2;
   generalize (lema_Inv14 rs_s2 (refl_equal Sc4));
   intro far_closed; elim far_closed; intros far closed;
   rewrite closed.
  intro rs_s2';
   apply StepsEX with (s2 := (s4, Inc x, (Sc1, Inc y, (Raising, Reset)))).
  generalize (INV_C_general (s1:=SiniTCG) Inv_SiniTCG rs_s2'); simpl in |- *;
   intro inv_sc4; inversion inv_sc4 using cl_Isc4;
   intro le_incy_kc2.
  apply
   ((fun (y z : Clock) (lt_y_kc2 : lt_Ck y kc2) (st_x : S_Ck ST) =>
     rsNext (rsIni TrGlobal (st_x, (Sc4, y, (Closed, z))))
       (tGl_Raise (tcRaise lt_y_kc2) (tgRaise z) st_x))
      (Inc y) (Inc z) le_incy_kc2 (s4, Inc x)).
  ExistsHere_ITick (s4, Inc x, (Sc1, Inc y, (Raising, Reset))).
  Split3_Trivial; apply Iraising; apply Trivial21.
  decompose [and or] no_sg.
  rewrite H6; intro rs_s2;
   generalize (INV_G_general (s1:=SiniTCG) Inv_SiniTCG rs_s2);
   simpl in |- *; intro inv_lowering;
   inversion inv_lowering using cl_Ilowering; intro lt_incz_kg1.
  apply StepsEX with (s2 := (s4, Inc x, (s3, Inc y, (Closed, Inc z)))).
  apply
   ((fun (z : Clock) (lt_z_kg1 : lt_Ck z kg1) (st_x : S_Ck ST)
       (sc_y : S_Ck SC) =>
     rsNext (rsIni TrGlobal (st_x, (sc_y, (Lowering, z))))
       (tGl_Down (tgDown lt_z_kg1) st_x sc_y)) (Inc z) lt_incz_kg1
      (s4, Inc x) (s3, Inc y)).
  ExistsHere_ITick (s4, Inc x, (s3, Inc y, (Closed, Inc z))).
  Split3_Trivial.
  rewrite H8; intro rs_s2;
   apply StepsEX with (s2 := (s4, Inc x, (s3, Inc y, (Open, Inc z)))).
  generalize (INV_G_general (s1:=SiniTCG) Inv_SiniTCG rs_s2); simpl in |- *;
   intro inv_raising; inversion inv_raising using cl_Iraising;
   intro lt_incz_kg3.
  apply
   ((fun (z : Clock) (ge_z_kg2 : ge_Ck z kg2) (lt_z_kg3 : lt_Ck z kg3)
       (st_x : S_Ck ST) (sc_y : S_Ck SC) =>
     rsNext (rsIni TrGlobal (st_x, (sc_y, (Raising, z))))
       (tGl_Up (tgUp ge_z_kg2 lt_z_kg3) st_x sc_y))
      (Inc z) H9 lt_incz_kg3 (s4, Inc x) (s3, Inc y)).
  ExistsHere_ITick (s4, Inc x, (s3, Inc y, (Open, Inc z))).
  Split3_Trivial.
Qed.

(*
Other specification of NonZeno:

Definition S_true := [s:StGlobal] True.
Lemma NonZeno : (ForAll_TCG SiniTCG ([s:StGlobal] (Exists_T TrGlobal s S_true (eq_Ck tick)))).
*)


(*|
####################################
Removing trivial match clause in Coq
####################################

:Link: https://stackoverflow.com/q/66179133
|*)

(*|
Question
********

Consider the following example:
|*)

Definition cast {A : Set} (B : Set) (prf : A = B) (x : A) : B.
  rewrite prf in x.
  refine x.
Defined.

Lemma castLemma0 {A : Set} : forall (x : A) prf, cast A prf x = x.
Proof.
  intros. compute. (* ??? *)

(*|
After the compute step, we are left with the following context and
subgoal
|*)

  Show. (* .unfold .messages *)

(*|
Clearly the left hand side and right hand side are equal. But I am not
sure how to get rid of the annoying ``match`` clause on the left hand
side. In particular, trying to ``destruct prf`` yields the following
error
|*)

  Fail destruct prf. (* .unfold .fails .messages *)

(*| Is there a way to get rid of this match clause? |*)

(*|
Answer
******

This is not provable in Coq without assuming an extra axiom, usually
``eq_rect_eq`` or something equivalent (Uniqueness of Identity Proofs
(UIP) or Axiom K).

If you restrict ``castLemma0`` to the ``eq_refl`` case, that is
``forall (x : A), cast A eq_refl x = x``, this is provable by
reflexivity.

One way to understand why this is not provable, is to accept that it
is consistant to assume an axiom ``bool_eq_not : bool = bool`` such
that ``cast bool bool_eq_not x = not x``. Plugging in ``bool_eq_not``
for ``prf`` in ``castLemma0`` would imply that ``not x = x``, which is
certainly wrong.

Proving that this is possible requires demonstrating a model of type
theory where ``bool_eq_nat`` is constructible. This was first done in
the paper "The groupoid interpretation of type theory", by Martin
Hofmann and Thomas Streicher. There have since been several other
models, including a model in simplicial sets by Voevodsky, and several
constructive models in cubical sets. These investigations are one
aspect of the field of Homotopy Type Theory (HoTT).

----

As a side note, there is a somewhat recently added (and still
experimental) feature `SProp (documentation)
<https://coq.inria.fr/refman/addendum/sprop.html>`__ that if you also
``Set Definitional UIP`` lets you prove this.
|*)


From Undecidability.TM Require Import TM_facts.
From Undecidability.L.TM Require Import TMEncoding.
From Complexity.L.TM Require Import TMflat TMflatEnc TMflatFun TapeDecode TMunflatten TMflatten.
From Complexity.NP Require Import TMGenNP_fixed_mTM SingleTMGenNP.
From Undecidability.L.Functions Require Import EqBool.

From Undecidability.L.Tactics Require Import LTactics GenEncode.
From Complexity.Libs.CookPrelim Require Import PolyBounds FlatFinTypes MorePrelim.
From Undecidability.L.Datatypes Require Import LProd LOptions LBool LSum LNat Lists LFinType.

(** * Reduction of TMGenNP with fixed TM to TMGenNP with variable TM *)

Lemma execFlatTM_isValidFlatTapes M tp steps c' tp' :
  execFlatTM M tp steps = Some (c', tp') -> isValidFlatTapes (sig M) (tapes M) tp' = true.
Proof.
  intros H%execFlatTM_correct.
  destruct H as (sig & n & M' & c0 & c0' & H0 & H1 & H2 & H).
  inv H. apply flatteningTapeIsValid in Ht.
  destruct H0. rewrite eq__tapes, eq__sig. apply Ht.
Qed.

Section fixTM.
  Variable (sig : finType).
  Variable (M : TM sig 1).

  Variable (reg__sig : encodable sig).
  Variable (index__comp : {c & computableTime' (index (F:=sig)) (fun _ _ => (c,tt))}).

  Definition index_const_Time : computableTime _ _:=  projT2 index__comp.
#[export]
Existing Instance index_const_Time.

  Definition flatM := flattenTM M.

  Definition reduction (p : list sig * nat * nat) :=
    let '(ts, maxSize, steps) := p in (flatM, map index (ts : list sig), maxSize, steps).

  Definition c__reduction := (16 + c__map + projT1 index__comp).
  Definition reduction_time (ts : list sig) := (|ts| + 1) * c__reduction.
#[export]
Instance term_reduction : computableTime' reduction (fun p _ => (let '(ts, maxSize, steps) := p in reduction_time ts, tt)).
  Proof.
    extract. solverec.
    rewrite map_time_const. unfold reduction_time, c__reduction. ring_simplify.  nia.
  Qed.

  Lemma reduction_correct p : TMGenNP_fixed M p <-> FlatFunSingleTMGenNP (reduction p).
  Proof.
    unfold TMGenNP_fixed, FlatFunSingleTMGenNP. destruct p as ((ts & maxSize) & steps). split.
    - intros (certfin & H1 & (res & H2)).
      cbn. split; [ | split; [easy | ]].
      { unfold list_ofFlatType. intros a (a' & <- & H4)%in_map_iff. apply index_le. }
      unfold execTM in H2.
      destruct loopM eqn:H3; [ | cbn in H2; congruence].
      exists (map index certfin), (flattenConfig m). split; [ |split].
      + intros a (a' & <- & H4)%in_map_iff. apply index_le.
      + now rewrite map_length.
      + apply execFlatTM_correct.
        exists sig, 1, M, (initc M [|initTape_singleTapeTM (ts ++ certfin)|]), m.
        split; [apply flattenTM_isFlatteningTMOf | split; [ | split; [apply H3 | apply flattenConfig_isFlatteningConfigOf]]].
        rewrite <- map_app. apply isFlatteningConfigOf_iff.
        exists [initTape_singleTapeTM (map index (ts ++ certfin))]. split.
        * apply isFlatteningTapesOf_iff. cbn. generalize (ts ++ certfin). intros l. destruct l; cbn; easy.
        * cbn. easy.
    - cbn. intros (_ & _ & (cert & f & H1 & H2 & H3)).
      destruct (finRepr_exists_list ltac:(reflexivity) H1) as (fincert & H4).
      exists fincert. split.
      { rewrite H4, map_length in H2. apply H2. }
      unfold execFlatTM in H3. destruct isValidFlatTM, isValidFlatTapes; cbn in H3; try congruence.
      assert (isFlatteningConfigOf (index (TM.start M), [initTape_singleTapeTM (map index ts ++ cert)]) (initc M [|initTape_singleTapeTM (ts ++ fincert)|])) as Hconf.
      {
        apply isFlatteningConfigOf_iff.
        exists [initTape_singleTapeTM (map index ts ++ cert)]. cbn. split; [ | easy].
        apply isFlatteningTapesOf_iff. cbn. rewrite H4, <- map_app.
        generalize (ts ++ fincert). intros l. destruct l; cbn; easy.
      }
      specialize (loopMflat_correct steps (flattenTM_isFlatteningTMOf M) Hconf) as H5.
      unfold flatM in H3. rewrite H3 in H5.
      destruct loopM eqn:H6; [ | cbn in H5; tauto].
      exists (ctapes m). unfold execTM. rewrite H6. cbn. easy.
  Qed.

  (*We use that the finType is constant so that only the length of ts is relevant for our analysis. *)
  Definition c__sizeInputIndex := ((|elem sig|) * c__natsizeS + c__natsizeO + c__listsizeCons).
  Proposition size_input_index (ts : list sig) : size (enc (map index ts)) <= c__sizeInputIndex * size (enc ts) + c__listsizeNil.
  Proof.
    rewrite list_size_of_el.
    2: { intros a (a' & <- & H)%in_map_iff. rewrite size_nat_enc. rewrite index_leq. reflexivity.  }
    rewrite map_length. setoid_rewrite list_size_length at 2. setoid_rewrite list_size_length at 2.
    unfold c__sizeInputIndex. nia.
  Qed.

  Lemma TMGenNP_fixed_singleTapeTM_to_FlatFunSingleTMGenNP :
    TMGenNP_fixed M ⪯p  FlatFunSingleTMGenNP.
  Proof using index__comp.
    apply reducesPolyMO_intro with (f := reduction).
    - evar (f : nat -> nat). exists f.
      + eexists. eapply computesTime_timeLeq. 2: apply term_reduction.
        cbn. intros ((ts & ?) & ?) _. split; [ | easy].
        unfold reduction_time. rewrite list_size_length.
        replace_le (size (enc ts)) with (size (enc (ts, n, n0))) by (rewrite !size_prod; cbn; nia).
        generalize (size (enc (ts, n, n0))). intros n'.
        [f]: intros n. subst f. cbn. reflexivity.
      + subst f. smpl_inO.
      + subst f. smpl_inO.
      + evar (g : nat -> nat). exists g.
        * intros ((ts & maxSize) & steps). cbn.
          rewrite !size_prod. cbn. rewrite size_input_index.
          instantiate (g := fun n => size (enc flatM) + c__listsizeNil + 8 + (c__sizeInputIndex + 1) * n).
          subst g. cbn. nia.
        * subst g. smpl_inO.
        * subst g. smpl_inO.
    - apply reduction_correct.
  Qed.
End fixTM.


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

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*                   Two Left Adjoints of a Functor are Iso                  *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export Adjunction1.

Set Implicit Arguments.
Unset Strict Implicit.

Section ladj_iso_def.

Variables (C D : Category) (G : Functor C D) (la la' : LeftAdj G).

Let F := Adjoint la.

Let F' := Adjoint la'.

Let LAdj_unit (a : D) := Unit la a.

Let LAdj_unit' (a : D) := Unit la' a.

Definition LAdj_tau_iso (a : D) := UA_iso (LAdj_unit a) (LAdj_unit' a).

Definition LAdj_tau (a : D) := Iso_mor (LAdj_tau_iso a).

Lemma LAdj_nt_law : NT_law LAdj_tau.
Proof.
unfold NT_law in |- *; intros a b f.
apply Trans with (UA_diese (LAdj_unit a) (f o UA_mor (LAdj_unit' b))).
apply (UA_unic (u:=LAdj_unit a)).
apply
 Trans
  with ((UA_mor (LAdj_unit a) o FMor G (FMor F f)) o FMor G (LAdj_tau b)).
apply
 Trans with (UA_mor (LAdj_unit a) o FMor G (FMor F f) o FMor G (LAdj_tau b)).
apply Comp_l; apply FComp.
apply Ass.
apply Trans with ((f o UA_mor (LAdj_unit b)) o FMor G (LAdj_tau b)).
apply Comp_r; apply Sym; apply (Prf_NT_law (Unit_NT la) f).
apply Trans with (f o UA_mor (LAdj_unit b) o FMor G (LAdj_tau b)).
apply Ass1.
apply Comp_l; apply (UA_diag (LAdj_unit b) (UA_mor (LAdj_unit' b))).
apply (UA_unic1 (u:=LAdj_unit a)).
apply
 Trans with (UA_mor (LAdj_unit a) o FMor G (LAdj_tau a) o FMor G (FMor F' f)).
apply Comp_l; apply FComp.
apply
 Trans
  with ((UA_mor (LAdj_unit a) o FMor G (LAdj_tau a)) o FMor G (FMor F' f)).
apply Ass.
apply Trans with (UA_mor (LAdj_unit' a) o FMor G (FMor F' f)).
apply Comp_r; apply (UA_diag (LAdj_unit a) (UA_mor (LAdj_unit' a))).
apply Sym; apply (Prf_NT_law (Unit_NT la') f).
Qed.

Canonical Structure LAdj_nt := Build_NT LAdj_nt_law.

Lemma LAdj_iso : NatIso F F'.
Proof.
apply (NT_Iso (T:=LAdj_nt) (h:=fun a : D => Inv_iso (LAdj_tau_iso a))).
intro a; exact (UA_iso_law1 (LAdj_unit a) (LAdj_unit' a)).
Qed.

End ladj_iso_def.


Set Nested Proofs Allowed.

Require Export Coq.Logic.Decidable.
Require Export Coq.Classes.EquivDec.
Require Export Coq.Bool.Bool.
Require Export Lists.List.
Require Export Coq.Program.Equality Coq.Program.Utils.

(*Require Import finiteTypes.External.
Require Import finiteTypes.BasicDefinitions.*)

Require Export FinTypes.

Require Export Graph SimplDec.

(*  Notation "p '-->*' q" := (exists π, Path p q π) (at level 55, right associativity).*)

(** * Definition of the reducible CFG **)

Reserved Infix "-->b" (at level 55).
Reserved Infix "-a>" (at level 55).
Reserved Infix "-a>*" (at level 55).

Definition is_true2 (A B : Type) := fun (f : A -> B -> bool) (a : A) (b : B) => is_true (f a b).

Class redCFG
      (Lab : finType)
      (edge : Lab -> Lab -> bool)
      (root : Lab)
      (a_edge : Lab -> Lab -> bool)
  :=
    {
      edge__P := is_true2 edge;
      a_edge__P := is_true2 a_edge;
      back_edge := minus_edge edge__P a_edge__P
                   where "p --> q" := ((is_true2 edge) p q);
      (* reducibility *)
      loop_head_dom : forall ql qh, back_edge ql qh -> Dom edge__P root qh ql
      where "p -a> q" := (a_edge p q = true);
      a_edge_incl : sub_graph a_edge__P edge__P
      where "p '-a>*' q" := (exists π, Path a_edge__P p q π);
      a_edge_acyclic : acyclic a_edge__P;
      a_reachability : forall q, (exists π, Path a_edge__P root q π);
      (* useful definitions *)
      loop_head h := exists p, back_edge p h;
      loop_contains qh q := exists p π, back_edge p qh /\ Path edge__P q p π /\ qh ∉ tl (rev π);
      exit_edge h p q := loop_contains h p /\ ~ loop_contains h q /\ p --> q;
      (* the following restrictions can be easily be met by introducing new blocks *)
      single_exit : forall h p q, exit_edge h p q -> forall h', exit_edge h' p q -> h = h';
      no_exit_head : forall h p q, exit_edge h p q -> ~ loop_head q;
      exit_pred_loop : forall h q qe e, exit_edge h qe e -> q --> e -> loop_contains h q;
      no_self_loops : forall q p, edge q p = true -> q <> p;
      root_no_pred : forall p, edge p root <> true
    }.

Hint Resolve loop_head_dom a_edge_incl a_edge_acyclic a_reachability : core.

(** ** Notations for paths **)

  Definition CPath `{redCFG} := Path edge__P.
  Definition APath `{redCFG} := Path a_edge__P.
  Infix "↪" := back_edge (at level 55).
  Notation "p '-->*' q" := (exists π, CPath p q π) (at level 55, right associativity).
  Notation "p '-a>*' q" := (exists π, APath p q π) (at level 55).

Section cfg.
  Context `{C : redCFG}.

  Notation "p '-a>b' q" := (a_edge p q) (at level 55).
  Notation "p '-a>' q" := (p -a>b q = true) (at level 55).
  Notation "p '-->b' q" := (edge p q) (at level 55).
  Notation "p '-->' q" := (p -->b q = true) (at level 55, right associativity).

  (** ** Definitions for loop exits and entrys **)

  Definition entry_edge (p h : Lab) := loop_head h /\ ~ loop_contains h p /\ edge p h = true.

  Definition exiting (h p : Lab) : Prop :=
    exists q, exit_edge h p q.

  Definition exited (h q : Lab) : Prop :=
    exists p, exit_edge h p q.

  (** * Decidable properties on redCFG **)

  Global Instance Lab_dec : EqDec Lab eq.
  Proof.
    intros x y. destruct (decide_eq x y).
    - left. rewrite e. reflexivity.
    - right. eauto.
  Qed.

  Instance loop_head_dec p : dec (loop_head p).
    eauto.
  Qed.

  (* This could also be proven, but it is not trivial non-classical. *)
  Parameter loop_contains_dec : forall qh q, dec (loop_contains qh q).
  Global Existing Instance loop_contains_dec.

  Hint Resolve loop_contains_dec : core.

  Global Instance exit_edge_dec : forall h p q, dec (exit_edge h p q).
  Proof.
    eauto.
  Qed.

  Global Instance exited_dec (h q : Lab) : dec (exited h q).
  Proof.
    eauto.
  Qed.

  Lemma back_edge_dec p q : dec (p ↪ q).
  Proof.
    eauto.
  Qed.

  Hint Resolve back_edge_dec : core.

  (** * Definition of depth **)

  Definition depth (p : Lab) := length (filter (DecPred (fun h => loop_contains h p)) (elem Lab)).

  (** * Some basic facts **)

  Lemma reachability (q : Lab) : exists π : list Lab, Path edge__P root q π.
  Proof.
    specialize (a_reachability q) as Hreach. destructH. exists π. eapply subgraph_path';eauto.
  Qed.

  Lemma back_edge_incl (p q : Lab) (Hback : p ↪ q) : edge__P p q.
  Proof.
    unfold back_edge in Hback. eapply minus_subgraph. eauto.
  Qed.

  Lemma acyclic_path_NoDup p q π
        (Hπ : Path a_edge__P p q π)
    : NoDup π.
  Proof.
    induction Hπ.
    - econstructor;eauto. econstructor.
    - cbn. econstructor;auto.
      intro N. specialize a_edge_acyclic as Hacy. unfold acyclic in Hacy.
      eapply path_from_elem in N;eauto. destructH. apply Hacy in N0;eauto.
  Qed.

  Lemma edge_destruct p q
        (Hedge : p --> q)
    : p -a> q \/ p ↪ q.
  Proof.
    decide (p -a> q);[left;auto|right].
    unfold back_edge. unfold minus_edge. conv_bool. split; auto.
  Qed.

End cfg.

(** * Generalizations of properties on CFGs for non-redCFG graphs **)

Open Scope prg.

Definition restrict_edge (A : finType) (f : A -> A -> Prop) (p : decPred A)
  : let L' := finType_sub p (decide_pred p) in L' -> L' -> Prop
  := fun x y => (f (`x) (`y)).

Definition restrict_edge' (A : Type) (f : A -> A -> Prop) (p : decPred A)
  := f ∩ ((fun a _ => p a)
            ∩ (fun _ b => p b)).

Definition loop_contains' (L : Type) (edge a_edge : L -> L -> Prop) (qh q : L)
  := exists (p : L)  π, (edge ∖ a_edge) p qh
                   /\ Path edge q p π
                   /\ qh ∉ tl (rev π).

Definition exit_edge' (L : finType) (edge a_edge : L -> L -> Prop) (h p q : L)
  := loop_contains' edge a_edge h p /\ ~ loop_contains' edge a_edge h q /\ edge p q.

Definition back_edge'  (L : Type) (edge a_edge : L -> L -> Prop) (p q : L)
  := (edge ∖ a_edge) p q.

Definition loop_head' (L : Type) (edge a_edge : L -> L -> Prop) (h : L)
  := exists p, ((edge) ∖ (a_edge)) p h.


Require Import SepLogic.Cancel.

Import PredNotations.
Local Open Scope pred.

Section Tests.
  Context (A V:Type).
  Notation pred := (pred A V).
  Implicit Type (p:pred).
  Implicit Types (P Q:Prop).

  Theorem test_assoc p1 p2 p3 :
    p1 * p2 * p3 ===> p1 * (p2 * p3).
  Proof.
    cancel.
  Qed.

  Theorem test_reorder p1 p2 p3 :
    p1 * p2 * p3 ===> p1 * (p3 * p2).
  Proof.
    cancel.
  Qed.

  Theorem test_collapse_emp p1 :
    emp * p1 ===> p1 * emp * emp.
  Proof.
    cancel.
  Qed.

  Theorem test_lift_prop p1 p2 p3 Q :
    p1 * p2 * p3 * [Q] ===> p1 * (p3 * p2).
  Proof.
    norm.
    match goal with
    | [ H: Q |- _ ] => reflexivity
    end.
  Qed.

  Theorem test_norm_repeat p1 p2 :
    p1 * p2 ===> p2 * p1.
  Proof.
    norm.
    try (progress norm; fail 1 "norm should do nothing if repeated").
    reflexivity.
  Qed.

  Theorem test_norm_nice_goals p1 p2 p3 p (P Q: Prop) :
    (P -> p1 * p2 * p3 ===> p) ->
    p1 * [Q] * p2 * p3 * [P] ===> p.
  Proof.
    intros Himpl.
    norm.
    exact (Himpl ltac:(assumption)).
  Qed.

  Theorem test_cancel_extra_prop p1 (P Q:Prop) :
    (P -> Q) ->
    p1 * [P] ===> p1 * [Q].
  Proof.
    cancel.
    (* cancel only solves the most trivial extra props *)
    auto.
  Qed.

  Theorem test_cancel_exact_prop p1 (P:Prop) :
    p1 * [P] ===> p1 * [P].
  Proof.
    cancel.
  Qed.

  Theorem test_cancel_hyp p1 p2 p3 p4 :
    p4 * p1 ===> p3 ->
    p1 * p2 * p4 ===> p2 * p3.
  Proof.
    intros.
    (* norm_with ensures normalization prefers the hypothesis terms *)
    norm_with H.
    rewrite H.
    reflexivity.
  Qed.

  Theorem test_cancel_hyp2 p1 p2 p3 p4 :
    p3 ===> p4 * p1 ->
    p2 * p3 ===> p1 * p2 * p4.
  Proof.
    intros.
    norm_with H.
    rewrite <- H.
    reflexivity.
  Qed.

  Theorem test_lift_hyp1 (P: Prop) p m :
    predApply ([P] * p) m ->
    P.
  Proof.
    intro H.
    norm_hyp H.
    assumption.
  Qed.

  Theorem test_lift_hyp2 (P Q: Prop) p1 p2 m :
    predApply (p1 * [P] * [Q] * p2) m ->
    Q.
  Proof.
    intro H.
    norm_hyp H.
    assumption.
  Qed.

End Tests.

Module GitHubIssues.
  Inductive perm := Public | Private.
  Definition value : Type := perm * nat.
  Theorem test_issue_4 (F: pred nat value) v v1 v2 :
    F * 0 |-> (Public, v) * 1 |-> v1 * 2 |-> v2 ===>
    F * 1 |-> v1 * 2 |-> v2 * 0 |-> (Public, v).
  Proof.
    cancel.
  Qed.
End GitHubIssues.

Module Demo.

  Arguments Atom {A V}.
  Arguments LiftedProp {A V}.

  Import Norm.
  Import Varmap.VarmapNotations.
  Local Open Scope vm.

  Theorem test_demo A V (p1 p2 p3: pred A V) (P Q:Prop) :
    P ->
    p1 * (p2 * p3 * emp) * [Q] ===> [P] * p1 * emp * (p3 * p2).
  Proof.
    Demo.norm.
    Demo.simpl_flatten.
    (* flatten doesn't even keep the [emp]s *)
    Demo.simpl_sorting.
    (* sorting reorders all lifted props to the front, and orders atoms by their
    index (which in practice will be the order from the left hand side) *)
    Demo.simpl_grab_props.
    (* finally, flatten_props1 and interpret_l make sure to produce the correct
    associativity and for non-empty lists do not leave an extra True or emp at
    the end *)
    simpl.
    cleanup_normed_goal; normed_cancellation.
  Qed.

End Demo.


Require Import Program.Tactics.
From Paco Require Export paconotation.
From Paco Require Import pacotac_internal pacoall.
Set Implicit Arguments.

Ltac under_forall tac := generalize _paco_mark_cons; intros; tac; paco_revert_hyp _paco_mark.

Definition get_paco_cls {A} {cls: paco_class A} (a: A) := cls.

Ltac paco_class TGT method :=
  let typ := fresh "_typ_" in let lem := fresh "_lem_" in
  let TMP := fresh "_tmp_" in let X := fresh "_X_" in
  let CLS := fresh "_CLS_" in
  evar (typ: Type); evar (lem: typ);
  assert(TMP: TGT -> True) by (
    intros X; set (CLS := method _ (get_paco_cls X));
    repeat red in CLS; clear X; revert lem;
    match goal with [CLS := ?v |-_] => instantiate (1:= v) end;
    clear CLS; exact I);
  clear TMP; unfold typ in *; clear typ; revert lem.

(** ** pfold tactic
  - [pfold] = [pstep]
*)

Tactic Notation "pfold_" := let x := fresh "_x_" in
  repeat red;
  match goal with [|- ?G] => paco_class G (@pacofold) end;
  intro x; match goal with [x:=?lem|-_] => clear x; eapply lem end.
Ltac pfold := under_forall ltac:(pfold_).
Ltac pstep := pfold.

(** ** punfold tactic
  - [punfold H]
*)

Ltac _punfold H := let x := fresh "_x_" in
  repeat red in H;
  let G := type of H in paco_class G (@pacounfold);
  intro x; match goal with [x:=?lem|-_] => clear x; eapply lem in H end.
Ltac punfold H := _punfold H; eauto with paco.

(** ** pmult tactic
  - [pmult]
*)

Ltac pmult := let x := fresh "_x_" in
  repeat red;
  match goal with [|- ?G] => paco_class G (@pacomult) end;
  intro x; match goal with [x:=?lem|-_] => clear x; eapply lem end.

(** ** pcofix tactic
  - [pcofix CIH [with r]]
*)

Tactic Notation "pcofix" ident(CIH) "with" ident(r) :=
  let x := fresh "_x_" in
  generalize _paco_mark_cons; repeat intro; repeat red;
  match goal with [|- ?G] =>
  paco_class G (@pacoacc); intro x;
  match goal with [x:=?lem|-_] => clear x;
    paco_revert_hyp _paco_mark;
    pcofix CIH using lem with r
  end end.

Tactic Notation "pcofix" ident(CIH) := pcofix CIH with r.

(** ** [pclearbot] simplifies all hypotheses of the form [upaco{n} gf bot{n}] to [paco{n} gf bot{n}].
*)

Definition pclearbot_orL (P Q: Prop) := P.
Definition pclearbot_orR (P Q: Prop) := Q.

Ltac pclearbot :=
  generalize _paco_mark_cons;
  repeat(
    let H := match goal with
             | [H: context [bot0] |- _] => H
             | [H: context [bot1] |- _] => H
             | [H: context [bot2] |- _] => H
             | [H: context [bot3] |- _] => H
             | [H: context [bot4] |- _] => H
             | [H: context [bot5] |- _] => H
             | [H: context [bot6] |- _] => H
             | [H: context [bot7] |- _] => H
             | [H: context [bot8] |- _] => H
             | [H: context [bot9] |- _] => H
             | [H: context [bot10] |- _] => H
             | [H: context [bot11] |- _] => H
             | [H: context [bot12] |- _] => H
             | [H: context [bot13] |- _] => H
             | [H: context [bot14] |- _] => H
             end in
    let NH := fresh H in
    revert_until H;
    repeat (
      repeat red in H;
      match goal with [Hcrr: context f [or] |- _] =>
        match Hcrr with H =>
        first[(
          let P := context f [pclearbot_orL] in
          assert (NH: P) by (repeat intro; edestruct H ; [eassumption|repeat (match goal with [X: _ \/ _ |- _] => destruct X end); contradiction]);
          clear H; rename NH into H; unfold pclearbot_orL in H
        ) | (
          let P := context f [pclearbot_orR] in
          assert (NH: P) by (repeat intro; edestruct H ; [repeat (match goal with [X: _ \/ _ |- _] => destruct X end); contradiction|eassumption]);
          clear H; rename NH into H; unfold pclearbot_orR in H
        )]
        end
      end);
    revert H);
  intros; paco_revert_hyp _paco_mark.

(** ** [pdestruct H] and [pinversion H]
*)

Ltac pdestruct H := punfold H; destruct H; pclearbot.

Ltac pinversion H := punfold H; inversion H; pclearbot.

(** ** pmonauto tactic
  - [pmonauto]
*)

Ltac pmonauto :=
  let IN := fresh "IN" in try (repeat intro; destruct IN; eauto with paco; fail).

(** ** [pfold_reverse] = [pstep_reverse]
*)

Tactic Notation "pfold_reverse_" :=
  match goal with
  | [|- _ (upaco0 ?gf _)] => eapply (paco0_unfold (gf := gf))
  | [|- _ (upaco1 ?gf _) _] => eapply (paco1_unfold (gf := gf))
  | [|- _ (upaco2 ?gf _) _ _] => eapply (paco2_unfold (gf := gf))
  | [|- _ (upaco3 ?gf _) _ _ _] => eapply (paco3_unfold (gf := gf))
  | [|- _ (upaco4 ?gf _) _ _ _ _] => eapply (paco4_unfold (gf := gf))
  | [|- _ (upaco5 ?gf _) _ _ _ _ _] => eapply (paco5_unfold (gf := gf))
  | [|- _ (upaco6 ?gf _) _ _ _ _ _ _] => eapply (paco6_unfold (gf := gf))
  | [|- _ (upaco7 ?gf _) _ _ _ _ _ _ _] => eapply (paco7_unfold (gf := gf))
  | [|- _ (upaco8 ?gf _) _ _ _ _ _ _ _ _] => eapply (paco8_unfold (gf := gf))
  | [|- _ (upaco9 ?gf _) _ _ _ _ _ _ _ _ _] => eapply (paco9_unfold (gf := gf))
  | [|- _ (upaco10 ?gf _) _ _ _ _ _ _ _ _ _ _] => eapply (paco10_unfold (gf := gf))
  | [|- _ (upaco11 ?gf _) _ _ _ _ _ _ _ _ _ _ _] => eapply (paco11_unfold (gf := gf))
  | [|- _ (upaco12 ?gf _) _ _ _ _ _ _ _ _ _ _ _ _] => eapply (paco12_unfold (gf := gf))
  | [|- _ (upaco13 ?gf _) _ _ _ _ _ _ _ _ _ _ _ _ _] => eapply (paco13_unfold (gf := gf))
  | [|- _ (upaco14 ?gf _) _ _ _ _ _ _ _ _ _ _ _ _ _ _] => eapply (paco14_unfold (gf := gf))
  end;
  eauto with paco.
Ltac pfold_reverse := under_forall ltac:(pfold_reverse_).
Ltac pstep_reverse := pfold_reverse.

(** ** punfold_reverse H
*)

Ltac punfold_reverse H :=
  let PP := type of H in
  match PP with
  | _ (upaco0 ?gf _) => eapply (paco0_fold gf) in H
  | _ (upaco1 ?gf _) _ => eapply (paco1_fold gf) in H
  | _ (upaco2 ?gf _) _ _ => eapply (paco2_fold gf) in H
  | _ (upaco3 ?gf _) _ _ _ => eapply (paco3_fold gf) in H
  | _ (upaco4 ?gf _) _ _ _ _ => eapply (paco4_fold gf) in H
  | _ (upaco5 ?gf _) _ _ _ _ _ => eapply (paco5_fold gf) in H
  | _ (upaco6 ?gf _) _ _ _ _ _ _ => eapply (paco6_fold gf) in H
  | _ (upaco7 ?gf _) _ _ _ _ _ _ _ => eapply (paco7_fold gf) in H
  | _ (upaco8 ?gf _) _ _ _ _ _ _ _ _ => eapply (paco8_fold gf) in H
  | _ (upaco9 ?gf _) _ _ _ _ _ _ _ _ _ => eapply (paco9_fold gf) in H
  | _ (upaco10 ?gf _) _ _ _ _ _ _ _ _ _ _ => eapply (paco10_fold gf) in H
  | _ (upaco11 ?gf _) _ _ _ _ _ _ _ _ _ _ _ => eapply (paco11_fold gf) in H
  | _ (upaco12 ?gf _) _ _ _ _ _ _ _ _ _ _ _ _ => eapply (paco12_fold gf) in H
  | _ (upaco13 ?gf _) _ _ _ _ _ _ _ _ _ _ _ _ _ => eapply (paco13_fold gf) in H
  | _ (upaco14 ?gf _) _ _ _ _ _ _ _ _ _ _ _ _ _ _ => eapply (paco14_fold gf) in H
  end;
  eauto with paco.