(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work 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 General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(** printing FSum0 %\ensuremath{\sum_0}% #∑0# *)
(** printing FSum %\ensuremath{\sum}% #∑# *)
(** printing FSumx %\ensuremath{\sum'}% #∑'&*)

Require Export CoRN.reals.CSumsReals.
Require Export CoRN.ftc.PartFunEquality.
Set Automatic Introduction.

(**
* Sums of Functions

In this file we define sums are defined of arbitrary families of
partial functions.

Given a countable family of functions, their sum is defined on the
intersection of all the domains.  As is the case for groups, we will
define three different kinds of sums.

We will first consider the case of a family
$\{f_i\}_{i\in\NN}$#{fi}# of functions; we can both define
$\sum_{i=0}^{n-1}f_i$#the sum of the first n functions# ( [FSum0]) or
$\sum_{i=m}^nf_i$#the sum of fm through fn#
( [FSum]).
*)

Definition FSum0 (n : nat) (f : nat -> PartIR) : PartIR.
Proof.
 intros.
 apply Build_PartFunct with (fun x : IR => forall n : nat, Dom (f n) x)
   (fun (x : IR) (Hx : forall n : nat, Dom (f n) x) => Sum0 n (fun n : nat => Part (f n) x (Hx n))).
  intros x y H H0 n0.
  apply (dom_wd _ (f n0) x).
   apply H.
  assumption.
 intros x y Hx Hy H.
 elim (Sum0_strext' _ _ _ _ H); intros i Hi.
 apply pfstrx with (f i) (Hx i) (Hy i); assumption.
Defined.

Definition FSum (m n : nat) (f : nat -> PartIR) : PartIR.
Proof.
 intros.
 apply Build_PartFunct with (fun x : IR => forall n : nat, Dom (f n) x)
   (fun (x : IR) (Hx : forall n : nat, Dom (f n) x) => Sum m n (fun n : nat => Part (f n) x (Hx n))).
  intros x y H H0 n0.
  apply (dom_wd _ (f n0) x).
   apply H.
  assumption.
 intros x y Hx Hy H.
 elim (Sum_strext' _ _ _ _ _ H); intros i Hi.
 apply pfstrx with (f i) (Hx i) (Hy i); assumption.
Defined.

(**
Although [FSum] is here defined directly, it has the same relationship
to the [FSum0] operator as [Sum] has to [Sum0].  Also, all the results
for [Sum] and [Sum0] hold when these operators are replaced by their
functional equivalents.  This is an immediate consequence of the fact
that the partial functions form a group; however, as we already
mentioned, their forming too big a type makes it impossible to use
those results.
*)

Lemma FSum_FSum0 : forall m n (f : nat -> PartIR) x Hx Hx' Hx'',
 FSum m n f x Hx [=] FSum0 (S n) f x Hx'[-]FSum0 m f x Hx''.
Proof.
 intros.
 simpl in |- *; unfold Sum, Sum1 in |- *; simpl in |- *.
 apply cg_minus_wd; try apply bin_op_wd_unfolded; try apply Sum0_wd; intros; algebra.
Qed.

Lemma FSum0_wd : forall m (f g : nat -> PartIR),
 (forall x HxF HxG i, f i x (HxF i) [=] g i x (HxG i)) ->
 forall x HxF HxG, FSum0 m f x HxF [=] FSum0 m g x HxG.
Proof.
 intros.
 simpl in |- *.
 apply Sum0_wd.
 intros; simpl in |- *; algebra.
Qed.

Lemma FSum_one : forall n (f : nat -> PartIR) x Hx Hx',
 FSum n n f x Hx' [=] f n x Hx.
Proof.
 intros.
 simpl in |- *.
 eapply eq_transitive_unfolded.
  apply Sum_one.
 simpl in |- *; rational.
Qed.

Lemma FSum_FSum : forall l m n (f : nat -> PartIR) x Hx Hx' Hx'',
 FSum l m f x Hx[+]FSum (S m) n f x Hx' [=] FSum l n f x Hx''.
Proof.
 intros.
 simpl in |- *.
 eapply eq_transitive_unfolded.
  2: apply Sum_Sum with (l := l) (m := m).
 apply bin_op_wd_unfolded; apply Sum_wd; intros; rational.
Qed.

Lemma FSum_first : forall m n (f : nat -> PartIR) x Hx Hx' Hx'',
 FSum m n f x Hx [=] f m x Hx'[+]FSum (S m) n f x Hx''.
Proof.
 intros.
 simpl in |- *.
 eapply eq_transitive_unfolded.
  apply Sum_first.
 apply bin_op_wd_unfolded; try apply Sum_wd; intros; rational.
Qed.

Lemma FSum_last : forall m n (f : nat -> PartIR) x Hx Hx' Hx'',
 FSum m (S n) f x Hx [=] FSum m n f x Hx'[+]f (S n) x Hx''.
Proof.
 intros.
 simpl in |- *.
 eapply eq_transitive_unfolded.
  apply Sum_last.
 apply bin_op_wd_unfolded; try apply Sum_wd; intros; rational.
Qed.

Lemma FSum_last' : forall m n (f : nat -> PartIR) x Hx Hx' Hx'',
 0 < n -> FSum m n f x Hx [=] FSum m (pred n) f x Hx'[+]f n x Hx''.
Proof.
 intros.
 simpl in |- *.
 eapply eq_transitive_unfolded.
  apply Sum_last'.
  assumption.
 apply bin_op_wd_unfolded; try apply Sum_wd; intros; rational.
Qed.

Lemma FSum_wd : forall m n (f g : nat -> PartIR),
 (forall x HxF HxG i, f i x (HxF i) [=] g i x (HxG i)) ->
 forall x HxF HxG, FSum m n f x HxF [=] FSum m n g x HxG.
Proof.
 intros.
 simpl in |- *.
 apply Sum_wd.
 algebra.
Qed.

Lemma FSum_plus_FSum : forall (f g : nat -> PartIR) m n x Hx HxF HxG,
 FSum m n (fun i => f i{+}g i) x Hx [=] FSum m n f x HxF[+]FSum m n g x HxG.
Proof.
 intros.
 simpl in |- *.
 eapply eq_transitive_unfolded.
  2: apply Sum_plus_Sum.
 apply Sum_wd; intros; rational.
Qed.

Lemma inv_FSum : forall (f : nat -> PartIR) m n x Hx Hx',
 FSum m n (fun i => {--} (f i)) x Hx [=] [--] (FSum m n f x Hx').
Proof.
 intros.
 simpl in |- *.
 eapply eq_transitive_unfolded.
  2: apply inv_Sum.
 apply Sum_wd; intros; rational.
Qed.

Lemma FSum_minus_FSum : forall (f g : nat -> PartIR) m n x Hx HxF HxG,
 FSum m n (fun i => f i{-}g i) x Hx [=] FSum m n f x HxF[-]FSum m n g x HxG.
Proof.
 intros.
 simpl in |- *.
 eapply eq_transitive_unfolded.
  2: apply Sum_minus_Sum.
 apply Sum_wd; intros; rational.
Qed.

Lemma FSum_wd' : forall m n, m <= S n -> forall f g : nat -> PartIR,
 (forall x HxF HxG i, m <= i -> i <= n -> f i x (HxF i) [=] g i x (HxG i)) ->
 forall x HxF HxG, FSum m n f x HxF [=] FSum m n g x HxG.
Proof.
 intros.
 simpl in |- *.
 apply Sum_wd'; try assumption.
 algebra.
Qed.

Lemma FSum_resp_less : forall (f g : nat -> PartIR) m n, m <= n ->
 (forall x HxF HxG i, m <= i -> i <= n -> f i x (HxF i) [<] g i x (HxG i)) ->
 forall x HxF HxG, FSum m n f x HxF [<] FSum m n g x HxG.
Proof.
 intros f g m n H H0 x HxF HxG.
 simpl in |- *.
 apply Sum_resp_less; try assumption.
 intros; apply H0; assumption.
Qed.

Lemma FSum_resp_leEq : forall (f g : nat -> PartIR) m n, m <= S n ->
 (forall x HxF HxG i, m <= i -> i <= n -> f i x (HxF i) [<=] g i x (HxG i)) ->
 forall x HxF HxG, FSum m n f x HxF [<=] FSum m n g x HxG.
Proof.
 intros f g m n H H0 x HxF HxG.
 simpl in |- *.
 apply Sum_resp_leEq; try assumption.
 intros; apply H0; assumption.
Qed.

Lemma FSum_comm_scal : forall (f : nat -> PartIR) c m n x Hx Hx',
 FSum m n (fun i => f i{*} [-C-]c) x Hx [=] (FSum m n f{*} [-C-]c) x Hx'.
Proof.
 intros.
 simpl in |- *.
 eapply eq_transitive_unfolded.
  2: apply (Sum_comm_scal (fun n : nat => f n x (ProjIR1 Hx' n)) c m n).
 apply Sum_wd; intros; rational.
Qed.

Lemma FSum_comm_scal' : forall (f : nat -> PartIR) c m n x Hx Hx',
 FSum m n (fun i => [-C-]c{*}f i) x Hx [=] ( [-C-]c{*}FSum m n f) x Hx'.
Proof.
 intros.
 simpl in |- *.
 eapply eq_transitive_unfolded.
  2: apply (Sum_comm_scal' (fun n : nat => f n x (ProjIR2 Hx' n)) c m n).
 apply Sum_wd; intros; rational.
Qed.

(**
Also important is the case when we have a finite family
$\{f_i\}_{i=0}^{n-1}$ of #exactly n# functions; in this case we need
to use the [FSumx] operator.
*)

Fixpoint FSumx (n : nat) : (forall i, i < n -> PartIR) -> PartIR :=
  match n return ((forall i, i < n -> PartIR) -> PartIR) with
  | O   => fun _ => [-C-][0]
  | S p => fun f => FSumx p (fun i l => f i (lt_S i p l)) {+} f p (lt_n_Sn p)
  end.

(**
This operator is well defined, as expected.
*)

Lemma FSumx_wd : forall n (f g : forall i, i < n -> PartIR),
 (forall i Hi x HxF HxG, f i Hi x HxF [=] g i Hi x HxG) ->
 forall x HxF HxG, FSumx n f x HxF [=] FSumx n g x HxG.
Proof.
 intro; case n.
  intros; simpl in |- *; algebra.
 clear n.
 simple induction n.
  intros; simpl in |- *; algebra.
 clear n; intro.
 cut {p : nat | S n = p}; [ intro H | exists (S n); auto ].
 elim H; intros p Hp.
 rewrite Hp; intros.
 simpl in |- *.
 apply bin_op_wd_unfolded.
  apply H0.
  intros; apply H1.
 apply H1.
Qed.

Lemma FSumx_wd' : forall (P : IR -> CProp) n (f g : forall i, i < n -> PartIR),
 (forall i H H', Feq P (f i H) (g i H')) -> Feq P (FSumx n f) (FSumx n g).
Proof.
 intros; induction  n as [| n Hrecn].
  simpl in |- *; apply Feq_reflexive; apply included_IR.
 simpl in |- *; apply Feq_plus; auto.
Qed.

(**
As was already the case for [Sumx], in many cases we will need to
explicitly assume that $f_i$#f1# is independent of the proof that
[i [<] n].  This holds both for the value and the domain of the partial
function $f_i$#fi#.
*)

Definition ext_fun_seq n (f : forall i, i < n -> PartIR) := forall i j, i = j ->
  forall Hi Hj x y, x [=] y -> forall Hx Hy, f i Hi x Hx [=] f j Hj y Hy.

Definition ext_fun_seq' n (f : forall i, i < n -> PartIR) := forall i j, i = j ->
  forall Hi Hj x y, x [=] y -> Dom (f i Hi) x -> Dom (f j Hj) y.

Arguments ext_fun_seq [n].
Arguments ext_fun_seq' [n].

(**
Under these assumptions, we can characterize the domain and the value of the sum function from the domains and values of the summands:
*)

Lemma FSumx_pred : forall n (f : forall i, i < n -> PartIR),
 ext_fun_seq' f -> forall x, Dom (FSumx n f) x -> forall i Hi, Dom (f i Hi) x.
Proof.
 intros n f H x H0 i Hi; red in H; induction  n as [| n Hrecn].
  exfalso; inversion Hi.
 elim (le_lt_eq_dec _ _ Hi); intro.
  cut (i < n); [ intro | auto with arith ].
  set (g := fun i Hi => f i (lt_S _ _ Hi)) in *.
  apply H with i (lt_S _ _ H1) x.
    auto.
   algebra.
  change (Dom (g i H1) x) in |- *.
  apply Hrecn.
   unfold g in |- *; intros.
   apply H with i0 (lt_S i0 n Hi0) x0; auto.
  inversion_clear H0; assumption.
 elim H0; intros H1 H2; clear H0 H1.
 apply H with n (lt_n_Sn n) x; auto.
  symmetry  in |- *; auto.
 algebra.
Qed.

Lemma FSumx_pred' : forall n (f : forall i, i < n -> PartIR),
 ext_fun_seq' f -> forall x, (forall i Hi, Dom (f i Hi) x) -> Dom (FSumx n f) x.
Proof.
 intros n f H x H0; induction  n as [| n Hrecn].
  simpl in |- *; auto.
 split.
  apply Hrecn.
   red in |- *; intros.
   red in H.
   exact (H _ _ H1 _ _ _ _ H2 X).
  intros; auto.
 apply H0.
Qed.

Lemma FSumx_char : forall n f x Hx Hf,
 FSumx n f x Hx [=] Sumx (fun i Hi => f i Hi x (FSumx_pred n f Hf x Hx i Hi)).
Proof.
 intro; induction  n as [| n Hrecn].
  algebra.
 intros; simpl in |- *.
 apply bin_op_wd_unfolded; algebra.
 cut (ext_fun_seq' (fun i Hi => f i (lt_S i n Hi))).
  intro H.
  eapply eq_transitive_unfolded.
   apply Hrecn with (Hf := H).
  apply Sumx_wd; intros; simpl in |- *; algebra.
 intros i j H H0 H' x0 y H1 H2.
 apply Hf with i (lt_S i n H0) x0; auto.
Qed.

(**
As we did for arbitrary groups, it is often useful to rewrite this sums as ordinary sums.
*)

Definition FSumx_to_FSum n : (forall i, i < n -> PartIR) -> nat -> PartIR.
Proof.
 intros f i.
 elim (le_lt_dec n i); intro.
  apply ( [-C-][0]:PartIR).
 apply (f i b).
Defined.

Lemma FSumx_lt : forall n (f : forall i, i < n -> PartIR), ext_fun_seq f ->
 forall i Hi x Hx Hx', FSumx_to_FSum n f i x Hx [=] f i Hi x Hx'.
Proof.
 do 6 intro.
 unfold FSumx_to_FSum in |- *.
 elim (le_lt_dec n i); intro; simpl in |- *.
  exfalso; apply (le_not_lt n i); auto.
 intros; apply H; auto.
 algebra.
Qed.

Lemma FSumx_le : forall n (f : forall i, i < n -> PartIR), ext_fun_seq f ->
 forall i x Hx, n <= i -> FSumx_to_FSum n f i x Hx [=] [0].
Proof.
 do 5 intro.
 unfold FSumx_to_FSum in |- *.
 elim (le_lt_dec n i); intro; simpl in |- *.
  intro; algebra.
 intros; exfalso; apply (le_not_lt n i); auto.
Qed.

Lemma FSum_FSumx_to_FSum : forall n (f : forall i, i < S n -> PartIR),
 ext_fun_seq f -> ext_fun_seq' f ->
 forall x Hx Hx', FSum 0 n (FSumx_to_FSum _ f) x Hx [=] FSumx _ f x Hx'.
Proof.
 simple induction n.
  intros; simpl in |- *.
  eapply eq_transitive_unfolded.
   apply Sum_one.
  simpl in |- *.
  cut (0 < 1); [ intro | apply lt_n_Sn ].
  astepr (Part (f 0 (lt_n_Sn 0)) x (ProjIR2 Hx')).
  apply FSumx_lt; assumption.
 clear n; intros n H f H0 H1 x Hx Hx'.
 simpl in |- *.
 eapply eq_transitive_unfolded.
  apply Sum_last.
 apply bin_op_wd_unfolded.
  set (g := fun i (l : i < S n) => f i (lt_S _ _ l)) in *.
  cut (ext_fun_seq g); intros.
   cut (ext_fun_seq' g).
    intro H3.
    astepr (FSumx n (fun i (l : i < n) => g i (lt_S _ _ l)) x
      (ProjIR1 (ProjIR1 Hx')) [+]g n (lt_n_Sn n) x (ProjIR2 (ProjIR1 Hx'))).
    cut (Dom (FSumx _ g) x).
     intro H4; cut (forall m : nat, Dom (FSumx_to_FSum (S n) g m) x).
      intro Hx''.
      simpl in H.
      apply eq_transitive_unfolded with (Sum 0 n (fun m : nat => FSumx_to_FSum (S n) g m x (Hx'' m))).
       2: apply H with (f := g); try assumption.
      apply Sum_wd'.
       auto with arith.
      intros.
      cut (i < S (S n)); [ intro | auto with arith ].
      apply eq_transitive_unfolded with (f i H7 x (FSumx_pred _ _ H1 x Hx' i H7)).
       apply FSumx_lt; assumption.
      cut (i < S n); [ intro | auto with arith ].
      apply eq_transitive_unfolded with (g i H8 x (FSumx_pred _ _ H3 x H4 i H8)).
       2: apply eq_symmetric_unfolded; apply FSumx_lt; assumption.
      unfold g in |- *; apply H0; auto.
      algebra.
     intro.
     simpl in Hx.
     generalize (Hx m); clear H4 H3 H2 Hx.
     unfold FSumx_to_FSum in |- *.
     elim (le_lt_dec (S n) m); elim (le_lt_dec (S (S n)) m); do 2 intro; simpl in |- *; intro.
        auto.
       auto.
      unfold g in |- *; apply FSumx_pred with (n := S (S n)); assumption.
     unfold g in |- *; apply FSumx_pred with (n := S (S n)); assumption.
    simpl in Hx'.
    unfold g in |- *; inversion_clear Hx'; intros; assumption.
   unfold g in |- *; red in |- *; intros.
   red in H1; apply H1 with i (lt_S _ _ Hi) x0; auto.
  unfold g in |- *; red in |- *; intros.
  red in H0; apply H0; auto.
 apply FSumx_lt; auto.
Qed.

(**
Some useful lemmas follow.
*)

Lemma FSum0_0 : forall P f, (forall n, included P (Dom (f n))) -> Feq P [-C-][0] (FSum0 0 f).
Proof.
 intros P f H.
 FEQ.
 simpl in |- *.
 red in |- *; intros; apply (H n); auto.
Qed.

Lemma FSum0_S : forall P f n, (forall m, included P (Dom (f m))) ->
 Feq P (FSum0 n f{+}f n) (FSum0 (S n) f).
Proof.
 intros P f n H.
 FEQ.
   apply included_FPlus; auto.
   simpl in |- *; red in |- *; intros.
   apply (H n0); auto.
  simpl in |- *.
  red in |- *; intros; apply (H n0); auto.
 simpl in |- *; apply bin_op_wd_unfolded; algebra.
 apply Sum0_wd; algebra.
Qed.

Lemma FSum_0 : forall P f n, (forall i, included P (Dom (f i))) -> Feq P (f n) (FSum n n f).
Proof.
 intros P f n H.
 FEQ.
  simpl in |- *.
  red in |- *; intros; apply (H n0); auto.
 simpl in |- *.
 apply eq_symmetric_unfolded.
 eapply eq_transitive_unfolded.
  apply Sum_one.
 algebra.
Qed.

Lemma FSum_S : forall P f m n, (forall i, included P (Dom (f i))) ->
 Feq P (FSum m n f{+}f (S n)) (FSum m (S n) f).
Proof.
 intros P f m n H.
 apply eq_imp_Feq.
   apply included_FPlus; auto.
   simpl in |- *.
   red in |- *; intros; apply (H n0); auto.
  simpl in |- *.
  red in |- *; intros; apply (H n0); auto.
 intros; simpl in |- *; apply eq_symmetric_unfolded.
 eapply eq_transitive_unfolded.
  apply Sum_last.
 algebra.
Qed.

Lemma FSum_FSum0' : forall P f m n, (forall i, included P (Dom (f i))) ->
 Feq P (FSum m n f) (FSum0 (S n) f{-}FSum0 m f).
Proof.
 intros P f m n H.
 apply eq_imp_Feq.
   red in |- *; intros; intro; apply (H n0); auto.
  apply included_FMinus; red in |- *; intros; intro; apply (H n0); auto.
 intros.
 apply eq_transitive_unfolded with (Part _ _ (ProjIR1 Hx') [-]FSum0 m f _ (ProjIR2 Hx')).
  apply FSum_FSum0.
 simpl in |- *; rational.
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export sequents2.
Require Export sequents_tacs.
Require Export sequents_equality.

Lemma lsubstc_eq_nil {o} :
  forall (t : @NTerm o) w s c c',
    lsubstc t w s c = lsubstc t w [] c'.
Proof.
  introv.
  apply cterm_eq; simpl.
  rewrite csubst_nil.
  rewrite csubst_trivial; auto.
  rw @cover_vars_eq in c'; simpl in c'.
  rw subvars_eq in c'.
  introv i j; apply c' in j; simpl in j; tcsp.
Qed.

(*
   H |- C ext t

     By closedConclusion

     |- C ext t
 *)
Definition rule_closed_conclusion {o}
           (H : @bhyps o)
           (C t : NTerm) :=
  mk_rule
    (mk_baresequent H (mk_concl C t))
    [
      mk_baresequent [] (mk_concl C t)
    ]
    [].

Lemma rule_closed_conclusion_true3 {o} :
  forall lib (H : @bhyps o) C t,
    rule_true3 lib (rule_closed_conclusion H C t).
Proof.
  intros.
  unfold rule_closed_conclusion, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destruct Hyp  as [ ws1 hyp1 ].
  destseq; allsimpl; proof_irr; GC.

  match goal with
  | [ |- sequent_true2 _ ?s ] => assert (wf_csequent s) as wfc
  end.
  { clear hyp1.
    unfold wf_csequent, closed_type, closed_extract, wf_sequent, wf_concl; simpl.
    dwfseq.
    rw @vswf_hypotheses_nil_eq.
    dands; tcsp.
    introv i; tcsp.
    apply ce in i; tcsp. }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 [] []) as h; clear hyp1; exrepnd.
  repeat (autodimp h hyp); try (apply sim_nil);[].
  exrepnd.
  lsubst_tac.
  proof_irr.
  rewrite (lsubstc_eq_nil _ _ s1 _ pC0).
  rewrite (lsubstc_eq_nil _ _ s2 _ pC0).
  rewrite (lsubstc_eq_nil _ _ s1 _ pt0).
  rewrite (lsubstc_eq_nil _ _ s2 _ pt0).
  auto.
Qed.


Require Import List.

Fixpoint foo (xs : list nat) : list nat :=
  match xs with
    | nil => nil
    | x :: xs' => x :: foo (rev xs')
  end.

(* Error: Only structural decreasing is supported for a non-Program Fixpoint *)


Require Import Axioms.

Require Import sepcomp. Import SepComp.
Require Import simulations.

Require Import pos.
Require Import stack.
Require Import cast.
Require Import compcert_linking.
Require Import compcert_threads.

Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun.
Set Implicit Arguments.

Require Import AST.    (*for typ*)
Require Import Values. (*for val*)
Require Import Globalenvs.
Require Import Memory.
Require Import Integers.

Require Import ZArith.

Module ThreadInv. Section ThreadInv.

Variables semS semT : Modsem.t.

Variable pS : ThreadPool.t semS.

Variable pT : ThreadPool.t semT.

Import ThreadPool.

Import SM_simulation.

Notation SIM semS semT geS geT := (SM_simulation_inject semS semT geS geT).

Variable sim :
  SIM (Modsem.sem semS) (Modsem.sem semT) (Modsem.ge semS) (Modsem.ge semT).

Variable mu : SM_Injection.

Variables mS mT : mem.

Notation MATCH cd c d := (match_state sim cd mu c mS d mT).

Lemma ord_eq (j k : pos) : j = k -> 'I_j = 'I_k.
Proof. by move=> ->. Qed.

Record t : Prop := mk
  { num_threads_eq :
      num_threads pS = num_threads pT

  ; krun_inv :
      forall (tid : 'I_(num_threads pS)) c,
      pool pS tid = Krun c ->
      exists d,
        pool pT (cast_ty (ord_eq num_threads_eq) tid) = Krun d
        /\ exists cd, MATCH cd c d

  ; kstage_inv :
      forall (tid : 'I_(num_threads pS)) ef argsS c,
      pool pS tid = Kstage ef argsS c ->
      exists d argsT,
        pool pT (cast_ty (ord_eq num_threads_eq) tid) = Kstage ef argsT d
        /\ val_list_inject (as_inj mu) argsS argsT
        /\ at_external (Modsem.sem semS) c = Some (ef, ef_sig ef, argsS)
        /\ exists cd, MATCH cd c d
  }.

End ThreadInv. End ThreadInv.


(* The Well-Ordering Theorem of E. Zermelo. *)

From set_theory Require Import lib fn set wo.

Section Well_ordering_theorem.

Variable X : Type.
Variable f : P X -> X.

(* f is a choice function for X. *)
Hypothesis f_choice : ∀V, V (f V).

(* Define a notation for sigma sub-sets of X. *)
Notation "& U" := ({x : X | U x}) (at level 5, format "& U").

(* Define the notion 'X without the initial segment A↾x' *)
Definition after {U : P X} {_0} (A : wos &U _0) x y :=
  ¬∃y', y = sig1 y' /\ y' <_0` x.

(* Define the notion 'f well-ordening'. *)
Definition f_wo {U : P X} {_0} (A : wos &U _0) :=
  ∀x : &U, sig1 x = f (after A x).

(* Define all subsets of X with an f well-ordering. *)
Definition W V := ∃R, ∃A : wos &V R, f_wo A.

Lemma f_wo_iso U V {_0 _1} (A : wos &U _0) (B : wos &V _1) g :
  f_wo A -> f_wo B -> WOSIsomorphism A B g -> ∀x, sig1 (g x) = sig1 x.
Proof.
intros fA fB [[g_inv [_ g_bi]] g_iso]; apply (wos_ind A); intros x IH.
rewrite fA, fB. replace (after A x) with (after B (g x)). easy.
extensionality y; apply propositional_extensionality.
split; apply contra; intros [z [H1z H2z]].
- apply g_iso in H2z as H3z; apply IH in H2z.
  destruct (g z) as [z' Hz']; simpl in *; subst.
  now exists (exist (sig1 z) Hz').
- rewrite <-g_bi in H2z at 1; apply g_iso in H2z.
  apply IH in H2z as H3z; rewrite g_bi in H3z.
  destruct (g_inv z) as [z' Hz']; simpl in *; subst.
  now exists (exist (sig1 z) Hz').
Qed.

Lemma f_wo_incl U V {_0 _1} (A : wos &U _0) (B : wos &V _1) :
  f_wo A -> f_wo B -> U ⊆ V \/ V ⊆ U.
Proof.
Abort.

Theorem WOT :
  ∃R, wos X R.
Proof.
Abort.

End Well_ordering_theorem.


Axiom em : forall P : Prop, (P) \/ (~P).
Axiom proof_irrelevance : forall (P : Prop) (q p : P), p = q.
Theorem iff_eq : forall P Q : Prop, (P -> Q) -> (Q -> P) -> P = Q.
intros.
destruct (em P).

(* See classicalfacts.v *)

auto.
red.
elimtype P.
elim H.


(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*              Solange Coupet-Grimal & Catherine Nouvet                    *)
(*                                                                          *)
(*                                                                          *)
(*       Laboratoire d'Informatique Fondamentale de Marseille               *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           Contact :Solange.Coupet@cmi.univ-mrs.fr                        *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V7.0                                  *)
(*                             Septembre 2002                               *)
(*                                                                          *)
(****************************************************************************)
(*                              white_card.v                                *)
(****************************************************************************)

Section white_card.

Require Export card_facts.
Require Export parameters_card.
Require Export lemme_arith.
Require Export lemma_step.
Require Export Arith.
Require Export Peano_dec.
Require Export Bool.
Require Export safety.

Notation Card := (card _ _) (only parsing).

Lemma init_white :
 forall s : state, init_state s -> card_color white (mk s) 0.

intros s init; elim init; clear init.
intros ctls init; elim init; clear init.
intros mark heap; elim mark; clear mark.
intros mksrt mark; constructor.
intro n; elim (eq_dec_node n rt).
intro neqrt; rewrite neqrt; rewrite mksrt; discriminate.
intro ndifrt; rewrite (mark n ndifrt); discriminate.
Qed.

Hint Resolve init_white.

Lemma ex_init_white :
 forall s : state, init_state s -> exists w : nat, card_color white (mk s) w.

intros s init; exists 0; eauto.
Qed.

Lemma add_white :
 forall (s t : state) (w : nat),
 card_color white (mk s) w ->
 add_edge s t ->
 card_color white (mk t) w \/ card_color white (mk t) (pred w).

intros s t w card_s addedge; elim addedge; clear addedge.
intros n1 n2 acces_n1_s acces_n2_s ctls ctlt add mark.
elim mark; clear mark.
intro cas1; elim cas1; clear cas1.
intros mksn1 eqmk; left; rewrite eqmk; assumption.
intro cas; elim cas; clear cas.
intro cas2; elim cas2; clear cas2.
intros mksn1 eqmk; elim eqmk; clear eqmk.
intros mksn2 eqmk; left; rewrite eqmk; assumption.
intro cas3; elim cas3; clear cas3.
intros mksn1 mk2; elim mk2; clear mk2.
intros mksn2 upd_col; elim upd_col; clear upd_col.
intros H_col mktn2.
right.
unfold card_color in |- *.
apply card_rem with (M1 := mk s) (a0 := n2); auto.
rewrite mktn2; discriminate.
Qed.

Hint Resolve add_white.

Lemma ex_add_white :
 forall s t : state,
 (exists w : nat, card_color white (mk s) w) ->
 add_edge s t -> exists w : nat, card_color white (mk t) w.

intros s t card_s addedge; elim addedge; clear addedge.
intros n1 n2 acces_n1_s acces_n2_s ctls ctlt add mark.
elim card_s; clear card_s.
intros w card_s; elim add; clear add.
intros H_heap1 H_heap2; elim H_heap2; clear H_heap2.
intros H_heap2 htn1n2; elim mark; clear mark.
intro cas1; elim cas1; clear cas1.
intros mksn1 eqmk; rewrite eqmk; exists w; assumption.
intro cas; elim cas; clear cas.
intro cas2; elim cas2; clear cas2.
intros mksn1 eqmk; elim eqmk; clear eqmk.
intros mksn2 eqmk; rewrite eqmk; exists w; assumption.
intro cas3; elim cas3; clear cas3.
intros mksn1 mk2; elim mk2; clear mk2.
intros mksn2 upd_col; elim upd_col; clear upd_col.
intros H_col mktn2; exists (pred w); unfold card_color in |- *.
apply card_rem with (M1 := mk s) (a0 := n2); auto.
rewrite mktn2; discriminate.
Qed.

Lemma remove_white :
 forall (s t : state) (w : nat),
 card_color white (mk s) w -> remove_edge s t -> card_color white (mk t) w.

intros s t w card_s removeedge.
elim removeedge; clear removeedge.
intros n1 n2 acces_n1_s acces_n2_s ctls ctlt remove mark.
rewrite mark; assumption.
Qed.

Hint Resolve remove_white.

Lemma ex_remove_white :
 forall s t : state,
 (exists w : nat, card_color white (mk s) w) ->
 remove_edge s t -> exists w : nat, card_color white (mk t) w.

intros s t card_s removeedge.
elim card_s; clear card_s.
intros w card_s; exists w; eauto.
Qed.

Lemma alloc_white :
 forall (s t : state) (w : nat),
 card_color white (mk s) w -> alloc s t -> card_color white (mk t) w.

intros s t w card_s alloc; unfold card_color in |- *.
apply card_inv with (M1 := mk s); auto.
intros n mksn.
apply (alloc_notwhites_notwhitet s t); assumption.
intros n mksn.
apply (alloc_whites_whitet s t); assumption.
Qed.

Hint Resolve alloc_white.

Lemma ex_alloc_white :
 forall s t : state,
 (exists w : nat, card_color white (mk s) w) ->
 alloc s t -> exists w : nat, card_color white (mk t) w.

intros s t card_s alloc; elim card_s; clear card_s.
intros w card_s; exists w; eauto.
Qed.

Lemma initcol_white :
 forall (s t : state) (b : nat),
 rt_grey_or_black s ->
 init_color (mk s) (mk t) ->
 card_color black (mk s) b ->
 (forall n : node, mk s n = black \/ mk s n = free) ->
 card_color white (mk t) (pred b).

unfold rt_grey_or_black in |- *.
intros s t b H_rt init cardb_s H_col.
elim init; clear init.
intros mktrt mark; elim mark; clear mark.
intros mark1 mark2; elim (exist_updated node color (mk t rt) (mk s) rt).
intros mk' mark; elim mark; clear mark.
intros mark mk'rt.
cut (card_color black mk' (pred b)).
intro card_mk'.
cut (exists nb' : nat, card_color white (mk t) nb' /\ nb' <= pred b).
intro H_nb'; elim H_nb'; clear H_nb'.
intros nb' H_nb'; elim H_nb'; clear H_nb'.
intros card_mkt le_nb'_predb.
cut (exists nb'' : nat, card_color black mk' nb'' /\ nb'' <= nb').
intro H_nb''; elim H_nb''; clear H_nb''.
intros nb'' H_nb''; elim H_nb''; clear H_nb''.
intros cardb_mk' le_nb''_nb'.
cut (nb'' = pred b).
intro nb''_eq_predb; rewrite nb''_eq_predb in le_nb''_nb'.
cut (nb' = pred b); auto with arith.
intro nb'_eq_predb; rewrite <- nb'_eq_predb; assumption.
unfold card_color in card_mk'; unfold card_color in cardb_mk'.
apply
 unicity_card
  with
    (M := mk')
    (nb' := pred b)
    (nb := nb'')
    (P := fun c : color => c = black); assumption.
unfold card_color in |- *.
apply include_card_bis with (P := fun c : color => c = white) (M := mk t);
 auto.
exists grey; discriminate.
unfold prop_dec2 in |- *.
intro c; apply (eq_dec_color c black).
intro n; elim (eq_dec_node n rt).
intro neqrt; rewrite neqrt.
intro mk'rt2.
absurd (mk' rt = black); try assumption.
rewrite mk'rt; rewrite mktrt; discriminate.
intros ndifrt mk'n; rewrite <- (mark n ndifrt) in mk'n.
apply mark1; assumption.
unfold card_color in |- *.
apply include_card_bis with (P := fun c : color => c = black) (M := mk');
 auto.
exists grey; discriminate.
unfold prop_dec2 in |- *; intro c.
apply (eq_dec_color c white).
intros n mktn; elim (eq_dec_node n rt).
intro neqrt.
rewrite neqrt in mktn.
absurd (mk t rt = white); try assumption.
rewrite mktrt; discriminate.
intro ndifrt.
rewrite <- (mark n ndifrt).
elim (eq_dec_color (mk s n) black); auto.
intro mksn.
absurd (mk t n = white); try assumption.
replace (mk t n) with free.
discriminate.
rewrite (mark2 n); try assumption.
elim (H_col n); intro mksn2; auto.
absurd (mk s n = black); assumption.
unfold card_color in |- *.
apply card_rem with (M1 := mk s) (a0 := rt); auto.
elim H_rt; auto.
intro mksrt; absurd (mk s rt = grey); auto.
elim (H_col rt); intro mksrt2; rewrite mksrt2; discriminate.
rewrite mk'rt; rewrite mktrt; discriminate.
Qed.

Hint Resolve initcol_white.

Lemma card_white_marknode :
 forall (nb : nat) (m1 : marking) (h1 : heap) (n0 : node),
 card_sons n0 white m1 h1 nb ->
 forall (m2 : marking) (h2 : heap) (w : nat),
 card_color white m1 w ->
 m1 n0 = grey ->
 m2 n0 = black ->
 grey_white_sons m1 m2 h1 h2 n0 -> card_color white m2 (w - nb).

simple induction nb; clear nb.
intros m1 h1 n0 H_cardsons_m1 m2 h2 w H_card_m1 m1n0 m2n0 H_grey.
rewrite <- (minus_n_O w).
elim H_grey; clear H_grey.
intros heap H_col1 H_col2.
unfold card_color in |- *.
apply card_inv with (nb := w) (M1 := m1); auto.
intros n m1n.
elim (eq_dec_node n n0).
intro neqn0.
rewrite neqn0; rewrite m2n0; discriminate.
intro ndifn0.
elim (sumbool_of_bool (h1 n0 n)); intro h1n0n.
replace (m2 n) with (m1 n); auto.
replace (m2 n) with (m1 n); auto.
intros n m1n; elim (eq_dec_node n0 n).
intro neqn0; rewrite <- neqn0 in m1n; absurd (m1 n0 = white); auto.
rewrite m1n0; discriminate.
intro ndifn0.
elim (sumbool_of_bool (h1 n0 n)); intro h1n0n.
elim H_cardsons_m1; clear H_cardsons_m1.
intros M Mn H_cardsons_m1.
inversion_clear H_cardsons_m1.
absurd (h1 n0 n = true /\ m1 n = white); auto.
apply (not_true_and_white M m1 h1 n n0); auto.
replace (m2 n) with (m1 n); auto.
intros nb H_ind m1' h1' n0 H_cardsons_1 m2' h2' w H_card_1 m1n0 m2n0 H_grey.
inversion_clear H_cardsons_1; inversion_clear H0.
elim (exist_updated node color (snd (M1 a0)) m1' a0).
intros m1 mark; elim mark; clear mark.
intros H_m1_m1' m1a0.
elim (exist_updated_heap (fst (M1 a0)) h1' n0 a0); intros h1 H6; elim H6;
 clear H6.
intros H_h1_h1' H6; elim H6; clear H6.
intros H_h1_h1'_bis h1n0a0.
elim (exist_updated node color (m1 a0) m2' a0); intros m2 mark; elim mark;
 clear mark.
intros H_m2_m2' m2a0.
elim (exist_updated_heap (h1 n0 a0) h2' n0 a0); intros h2 H6; elim H6;
 clear H6.
intros H_h2_h2' H6.
elim H6; clear H6.
intros H_h2_h2'_bis h2n0a0.
elim H_grey; clear H_grey.
intros heap H_heap1 H_heap2.
elim (eq_dec_color (m1 a0) white); intro m1_a0.
rewrite (minus_pred w nb).
unfold card_color in |- *.
apply card_rem with (M1 := m2) (a0 := a0).
unfold card_color in H_ind.
apply H_ind with (m1 := m1) (h1 := h1) (h2 := h2) (n0 := n0); auto.
apply CS with (M := M1); auto.
intro n; elim (eq_dec_node n a0).
intro neqa0.
rewrite neqa0.
generalize (refl_equal (M1 a0)); pattern (M1 a0) at -1 in |- *; case (M1 a0);
 intros b c M1a0.
replace b with (fst (M1 a0)).
replace c with (snd (M1 a0)).
rewrite <- m1a0; rewrite <- h1n0a0; trivial.
rewrite M1a0; auto.
rewrite M1a0; auto.
intro ndifa0.
rewrite (H2 n ndifa0); rewrite <- (H_h1_h1'_bis n ndifa0);
 rewrite <- (H_m1_m1' n ndifa0); auto.
apply card_inv with (M1 := m1'); auto.
intros n m1'n; elim (eq_dec_node n a0).
intro neqa0; rewrite neqa0 in m1'n.
absurd (m1' a0 = white); auto.
apply (is_white M h1' m1' a0 n0); auto.
intro ndifa0; rewrite <- (H_m1_m1' n ndifa0); auto.
intros n m1'n; elim (eq_dec_node n a0).
intro neqa0; rewrite neqa0; assumption.
intro ndifa0; rewrite <- (H_m1_m1' n ndifa0); auto.
rewrite <- (H_m1_m1' n0); auto.
intro n0eqa0; absurd (m2' a0 = grey).
rewrite <- n0eqa0; rewrite m2n0; discriminate.
apply (H_heap1 a0).
split.
apply (is_true M h1' m1' a0 n0); auto.
apply (is_white M h1' m1' a0 n0); auto.
rewrite <- (H_m2_m2' n0); auto.
intro n0eqa0; absurd (m2' a0 = grey).
rewrite <- n0eqa0; rewrite m2n0; discriminate.
apply (H_heap1 a0).
split.
apply (is_true M h1' m1' a0 n0); auto.
apply (is_white M h1' m1' a0 n0); auto.
constructor.
intros n m; elim (eq_dec_node n n0).
intro neqn0; rewrite neqn0; elim (eq_dec_node m a0).
intro meqa0; rewrite meqa0; auto.
intro mdifa0.
rewrite <- (H_h1_h1'_bis m mdifa0).
rewrite <- (H_h2_h2'_bis m mdifa0).
auto.
intro ndifn0.
rewrite <- (H_h1_h1' n m ndifn0).
rewrite <- (H_h2_h2' n m ndifn0).
auto.
intro m; elim (eq_dec_node m a0).
intros meqa0.
rewrite meqa0.
intro H_m.
absurd (h1 n0 m = true /\ m1 m = white); auto.
elim H3.
generalize (refl_equal (M1 a0)); pattern (M1 a0) at -1 in |- *; case (M1 a0).
intros b c M1a0; elim H_m; clear H_m.
intros h1n0a0_bis m1a0_bis; split.
replace b with (fst (M1 a0)).
rewrite <- h1n0a0; assumption.
rewrite M1a0; auto.
replace c with (snd (M1 a0)).
rewrite <- m1a0; assumption.
rewrite M1a0; auto.
rewrite meqa0; assumption.
intros mdifa0 H6; elim H6; clear H6.
intros h1n0m m1m.
rewrite <- (H_m2_m2' m mdifa0).
apply (H_heap1 m).
rewrite (H_h1_h1'_bis m mdifa0).
rewrite (H_m1_m1' m mdifa0).
split; assumption.
intros m H6; elim H6; clear H6.
intros mdifn0 H6; elim H6; clear H6.
intro H6; elim H6; clear H6.
intros h1n0m m1m; elim (eq_dec_node m a0).
intro meqa0; rewrite meqa0 in m1m.
absurd (m1 a0 = white); assumption.
intro mdifa0.
rewrite <- (H_m1_m1' m mdifa0).
rewrite <- (H_m2_m2' m mdifa0).
apply (H_heap2 m).
split; auto.
left.
rewrite (H_h1_h1'_bis m mdifa0).
rewrite (H_m1_m1' m mdifa0).
split; assumption.
intro h1n0m; elim (eq_dec_node m a0).
intro meqa0; rewrite meqa0; auto.
intro mdifa0.
rewrite <- (H_m1_m1' m mdifa0).
rewrite <- (H_m2_m2' m mdifa0).
apply (H_heap2 m).
split; auto.
right; rewrite (H_h1_h1'_bis m mdifa0); assumption.
intros n ndifa0.
symmetry  in |- *; apply (H_m2_m2' n); assumption.
rewrite m2a0; assumption.
rewrite (H_heap1 a0); auto.
discriminate.
split.
apply (is_true M h1' m1' a0 n0); auto.
apply (is_white M h1' m1' a0 n0); auto.
unfold card_color in |- *; apply card_inv with (M1 := m2).
rewrite (pred_S_minus w nb).
unfold card_color in H_ind.
apply H_ind with (m1 := m1) (h1 := h1) (h2 := h2) (n0 := n0); auto.
apply CS with (M := M1); auto.
intro n; elim (eq_dec_node n a0).
intro neqa0; rewrite neqa0.
generalize (refl_equal (M1 a0)); pattern (M1 a0) at -1 in |- *; case (M1 a0).
intros b c M1a0.
replace b with (fst (M1 a0)).
replace c with (snd (M1 a0)).
rewrite <- m1a0; rewrite <- h1n0a0; trivial.
rewrite M1a0; auto.
rewrite M1a0; auto.
intro ndifa0.
rewrite (H2 n ndifa0).
rewrite <- (H_h1_h1'_bis n ndifa0).
rewrite <- (H_m1_m1' n ndifa0).
auto.
apply card_rem with (M1 := m1') (a0 := a0); auto.
apply (is_white M h1' m1' a0 n0); auto.
rewrite <- (H_m1_m1' n0); auto.
intro n0eqa0; absurd (m2' a0 = grey).
rewrite <- n0eqa0; rewrite m2n0; discriminate.
apply (H_heap1 a0).
split.
apply (is_true M h1' m1' a0 n0); auto.
apply (is_white M h1' m1' a0 n0); auto.
rewrite <- (H_m2_m2' n0); auto.
intro n0eqa0; absurd (m2' a0 = grey).
rewrite <- n0eqa0; rewrite m2n0; discriminate.
apply (H_heap1 a0).
split.
apply (is_true M h1' m1' a0 n0); auto.
apply (is_white M h1' m1' a0 n0); auto.
constructor.
intros n m.
elim (eq_dec_node n n0).
intro neqn0; rewrite neqn0; elim (eq_dec_node m a0).
intro meqa0; rewrite meqa0; auto.
intro mdifa0; rewrite <- (H_h1_h1'_bis m mdifa0);
 rewrite <- (H_h2_h2'_bis m mdifa0); auto.
intro ndifn0; rewrite <- (H_h1_h1' n m ndifn0);
 rewrite <- (H_h2_h2' n m ndifn0); auto.
intro m; elim (eq_dec_node m a0).
intro meqa0; rewrite meqa0; intro H6; elim H6; clear H6.
intros h1n0a0_bis m1a0_bis; absurd (m1 a0 = white); auto.
intros mdifa0 H_m; rewrite <- (H_m2_m2' m mdifa0).
apply (H_heap1 m).
rewrite (H_h1_h1'_bis m mdifa0); rewrite (H_m1_m1' m mdifa0); assumption.
intros m H6; elim (eq_dec_node m a0).
intro meqa0; rewrite meqa0; auto.
intro mdifa0; elim H6; clear H6.
intros mdifn0 H6; elim H6; clear H6.
intro H6; elim H6; clear H6.
intros h1n0m m1m; rewrite <- (H_m1_m1' m mdifa0);
 rewrite <- (H_m2_m2' m mdifa0); apply (H_heap2 m).
split; auto.
left; rewrite (H_h1_h1'_bis m mdifa0); rewrite (H_m1_m1' m mdifa0); split;
 auto.
intro h1n0m; rewrite <- (H_m1_m1' m mdifa0); rewrite <- (H_m2_m2' m mdifa0);
 apply (H_heap2 m).
split; auto.
right; rewrite (H_h1_h1'_bis m mdifa0); assumption.
intros n m2n.
elim (eq_dec_node n a0).
intro neqa0; rewrite neqa0; replace (m2' a0) with grey.
discriminate.
symmetry  in |- *; apply (H_heap1 a0).
split.
apply (is_true M h1' m1' a0 n0); auto.
apply (is_white M h1' m1' a0 n0); auto.
intro ndifa0; rewrite (H_m2_m2' n ndifa0); assumption.
intros n m2n; elim (eq_dec_node n a0).
intro neqa0; rewrite neqa0 in m2n; absurd (m2 a0 = white); auto.
rewrite m2a0; assumption.
intro ndifa0; rewrite (H_m2_m2' n ndifa0); assumption.
Qed.

Lemma greynode_card_white :
 forall s t : state,
 (exists w : nat, card_color white (mk s) w) ->
 hp s = hp t ->
 grey_node_case (mk s) (mk t) (hp s) ->
 exists w : nat, card_color white (mk t) w.

intros s t card_s heap H_grey; elim H_grey; clear H_grey.
intros g mksg mktg H_mark1 H_mark2.
cut
 (exists M : node -> bool * color,
    (forall n : node, M n = (hp s g n, mk s n))).
intro H2; elim H2; clear H2.
intros M H_M; elim card_s; clear card_s.
intros w card_s.
cut
 (exists nb : nat,
    card _ _
      (fun p : bool * color =>
       match p with
       | (b, c) => b = true /\ c = white
       end) M nb /\ nb <= w).
intro H2; elim H2; clear H2.
intros nbsons H_nbsons; elim H_nbsons; clear H_nbsons.
intros H_cardsons le_nbsons_w.
cut (card_sons g white (mk s) (hp s) nbsons).
intro card_sons.
exists (w - nbsons).
apply
 card_white_marknode
  with (m1 := mk s) (h1 := hp s) (h2 := hp t) (nb := nbsons) (n0 := g);
 auto.
constructor; auto.
rewrite heap; auto.
apply CS with (M := M); auto.
apply
 include_card_bis
  with (P := fun c : color => c = white) (M := mk s) (nb := w);
 auto.
exists (hp s rt g, mk s g).
intro H2; elim H2; clear H2.
intros hrtg mksg2; absurd (mk s g = white); auto.
rewrite mksg; discriminate.
unfold prop_dec2 in |- *.
intro c; case c; intros b c0; elim (sumbool_of_bool b).
elim (eq_dec_color c0 white).
intros c0_w b_t; left; auto.
intros c0_notw b_t; right; intro H2; elim H2; clear H2.
intros bt c0w; absurd (c0 = white); auto.
intro b_f; right; intro H2; elim H2; clear H2.
intros b_t c0_w; apply (eq_true_false_abs b); auto.
intros n; generalize (refl_equal (M n)); pattern (M n) at -1 in |- *;
 case (M n); intros b c M_n.
intro H2; elim H2; clear H2.
intros b_t c_w; replace (mk s n) with c; auto.
replace c with (snd (M n)).
rewrite (H_M n); auto.
rewrite M_n; auto.
exists (fun n : node => (hp s g n, mk s n)); auto.
Qed.

Hint Resolve greynode_card_white.

Lemma ex_gccall_white :
 forall s t : state,
 rt_grey_or_black s ->
 (exists b : nat, card_color black (mk s) b) ->
 (exists w : nat, card_color white (mk s) w) ->
 gc_call s t -> exists w : nat, card_color white (mk t) w.

intros s t safety_prop cardb_s cardw_s gccall; elim cardb_s; clear cardb_s.
intros b0 cardb_s; elim gccall; clear gccall.
intros ctls ctlt heap H_col init; exists (pred b0); eauto.
intros ctls ctlt heap H_grey; eauto.
intros ctls ctlt heap H_col m mksm upd_col; elim upd_col; clear upd_col.
intros mark mktm; elim cardw_s; clear cardw_s.
intros w cardw_s; exists (pred w); unfold card_color in |- *.
apply card_rem with (M1 := mk s) (a0 := m); auto.
rewrite mktm; discriminate.
Qed.

Lemma ex_marknode_white :
 forall s t : state,
 (exists w : nat, card_color white (mk s) w) ->
 mark_node s t -> exists w : nat, card_color white (mk t) w.

intros s t card_s marknode; elim marknode; clear marknode.
intros ctls ctlt heap H_grey; eauto.
Qed.

Lemma gcstop_white :
 forall (s t : state) (w : nat),
 card_color white (mk s) w -> gc_stop s t -> card_color white (mk t) w.

intros s t w card_s gcstop; elim gcstop; clear gcstop.
intros ctls ctlt heap mark; rewrite mark; assumption.
Qed.

Hint Resolve gcstop_white.

Lemma ex_gcstop_white :
 forall s t : state,
 (exists w : nat, card_color white (mk s) w) ->
 gc_stop s t -> exists w : nat, card_color white (mk t) w.

intros s t card_s gcstop; elim card_s; clear card_s.
intros w card_s; exists w; eauto.
Qed.

Lemma gcfree_white :
 forall (s t : state) (w : nat),
 card_color white (mk s) w -> gc_free s t -> card_color white (mk t) (pred w).

intros s t w card_s gcfree; elim gcfree; clear gcfree.
intros ctls ctlt H_col heap m mksm upd_col; elim upd_col; clear upd_col.
intros mark mktm; unfold card_color in |- *;
 apply card_rem with (M1 := mk s) (a0 := m); auto.
rewrite mktm; discriminate.
Qed.

Hint Resolve gcfree_white.

Lemma ex_gcfree_white :
 forall s t : state,
 (exists w : nat, card_color white (mk s) w) ->
 gc_free s t -> exists w : nat, card_color white (mk t) w.

intros s t card_s gcfree; elim card_s; clear card_s.
intros w card_s; eauto.
Qed.

Lemma gcfree1_white :
 forall (s t : state) (w : nat),
 card_color white (mk s) w ->
 gc_free1 s t -> card_color white (mk t) (pred w).

intros s t w card_s gcfree1; elim gcfree1; clear gcfree1.
intros ctls ctlt heap n mksn upd_col; elim upd_col; clear upd_col.
intros mark mktn; unfold card_color in |- *.
apply card_rem with (M1 := mk s) (a0 := n); auto.
rewrite mktn; discriminate.
Qed.

Hint Resolve gcfree1_white.

Lemma ex_gcfree1_white :
 forall s t : state,
 (exists w : nat, card_color white (mk s) w) ->
 gc_free1 s t -> exists w : nat, card_color white (mk t) w.

intros s t card_s gcfree1; elim card_s; clear card_s.
intros w card_s; exists (pred w); eauto.
Qed.

Lemma gcend_white :
 forall (s t : state) (w : nat),
 card_color white (mk s) w -> gc_end s t -> card_color white (mk t) w.

intros s t w card_s gcend; elim gcend; clear gcend.
intros ctls ctlt heap mark; rewrite mark; assumption.
Qed.

Hint Resolve gcend_white.

Lemma ex_gcend_white :
 forall s t : state,
 (exists w : nat, card_color white (mk s) w) ->
 gc_end s t -> exists w : nat, card_color white (mk t) w.

intros s t card_s gcend; elim card_s; clear card_s.
intros w card_s; exists w; eauto.
Qed.

End white_card.

Hint Immediate init_white.
Hint Immediate add_white.
Hint Immediate remove_white.
Hint Immediate alloc_white.
Hint Immediate gcstop_white.
Hint Immediate gcfree_white.
Hint Immediate gcfree1_white.
Hint Immediate gcend_white.
Hint Immediate ex_init_white.
Hint Immediate ex_add_white.
Hint Immediate ex_remove_white.
Hint Immediate ex_alloc_white.
Hint Immediate ex_gccall_white.
Hint Immediate ex_marknode_white.
Hint Immediate ex_gcstop_white.
Hint Immediate ex_gcfree_white.
Hint Immediate ex_gcfree1_white.
Hint Immediate ex_gcend_white.
Hint Resolve initcol_white.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall X A C D U V : Universe, ((wd_ A X /\ (wd_ C D /\ (wd_ D X /\ (col_ X A X /\ (col_ X C D /\ (col_ U A X /\ col_ V C D)))))) -> col_ V D X)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*   Assia.Mahboubi@inria.fr, Laurence.Rideau@inria.fr       *)
(*  Laurent.Thery@inria.fr  &all    2006                     *)
(*************************************************************)

Unset Boxed Definitions.
Unset Boxed Values.

Require Import Qabs.
Require Import Utils.
Require Import CAD_types.

Module MK_ONE_DIM(Q:RAT_STRUCT).

  Module QFUNS:= RAT_FUNS Q.
  Module QINT := RAT_INT_OPS Q.

  Import Q.
  Import QFUNS.
  Import QINT.

Section ONE_DIM.

(* Initialization for the loading of Gen_functor *)

  Let Coef:= Rat.
  Let c0 := r0.
  Let c1 := r1.
  Let cadd :=  radd .
  Let copp :=  ropp .
  Let cmul :=  rprod .
  Let csub := rsub .
  Let cdiv := rdiv .
  Let czero_test := rzero_test .
  Let cpow := rpow .
  Let cof_pos(p:positive):=rof_pos p.
  Let cof_Rat(r:Rat) := r.
  Let cbase_cst_sign := fun x:Coef => (Some (rsign  x)).

  Let cgcd_gcd_free :=
    fun x y:Coef => let m:= rmax x y in (m, rdiv x m, rdiv y m).
  Let cis_Rat := fun x:Rat => true.
  Let cmult_base_cst := cmul.
  Let cdiv_base_cst := cdiv.
  Let path := unit.
  Let cvalue_bound(x:unit)(y:Rat):=(y,y).
  Let ccell_point_up_refine(x:unit):=x.
  Let csign_at(x:Coef)(u:unit)(n:nat):=(u,(x,Some (rsign  x))).
  Let cdeg(x:Coef):=N0.
  Let ccell_refine(u:unit)(n:nat):=Some u.
  Let cInfo := Coef.
  Let cInfo_of_Pol(s:Sign)(c:Coef):=c.
  Let cPol_of_Info(c:Rat):=c.
  Let cmk_Info(a b:Rat)(n:N)(s1 s2:Sign):= a.

Load Pol_on_Coef.
Load Pol_on_Coef_on_Rat.
Load Bern.
Load Alg.

(*  Load Gen_functor.*)

  (*Are now available:
     Pol_add :Pol -> Pol->Pol
     Pol_mul :Pol->Pol->Pol
     Pol_sub :Pol->Pol->Pol
     Pol_opp :Pol->Pol
     Pol_div:Pol->Pol->Pol
     Pol_zero_test : Pol->bool
     mk_PX := Pol ->positive -> Coef -> Pol
     Pol_of_pos := positive -> Pol
     Pol_pow := Pol -> N -> Pol
     Pol_subres_list := Pol -> Pol-> list Pol
     Pol_subres_coef_list := Pol -> Pol -> list Coef
     Pol_gcd := Pol -> Pol -> Pol
     Pol_square_free := Pol -> Pol
     Pol_deriv := Pol -> Pol
     Pol_eval := Pol -> Coef -> Coef.
     Pol_trunc : Pol  -> list Pol
     Pol_mk_coef :
     Pol_mkPc :=
     Pol_is_base_cst
     Pol_mult_base_cst
     Pol_div_base_cst
     Pol_partial_eval
     Pol_trunc
     Pol_bern_coefs
     Pol_bern_split....*)

  (************************************************************)
  (***             Real root isolation                      ***)
  (************************************************************)

  (** sum of abs values of the coefs of P **)
  Definition  sum_abs_val_coef:=
  fix sum_abs_val_coef (P:Pol):Rat:=
    match P with
      |Pc p => rabs_val p
      |PX P' i p => (rabs_val p) +r sum_abs_val_coef P'
    end.

  (** Cauchy upper bound for the real roots of P **)
  Definition  Pol_up_bound(P:Pol):=
  let p:= Pol_dom P in
    ((sum_abs_val_coef P)//(rabs_val p))+r r1.

  (**idem, but fits the type in the CAD record **)
  Definition Pol_up_bound_tt(P:Pol)(u:unit):=Pol_up_bound P.

  (** Cauchy lower bound for the real roots of P **)
  Definition root_low_bound1:=
  fix root_low_bound1(P:Pol)(sum:Rat){struct P}:Rat :=
    match P with
      |Pc p => sum // p
      |PX P' i p' =>
	if (rzero_test p')
	  then root_low_bound1 P' sum
	  else sum // (rabs_val p')
    end.

  Definition  Pol_low_bound (P:Pol) :=
    ropp ((root_low_bound1 P (sum_abs_val_coef P))+r r1).

  (**idem, but fits the type in the CAD record **)
  Definition Pol_low_bound_tt(P:Pol)(u:unit):=Pol_low_bound P.

  (** Sign of P at -infty **)

  Definition Pol_low_sign(P:Pol):=
  Some (rsign (Pol_eval P (Pol_low_bound P))).

  (**idem, but fits the type in the CAD record **)
  Definition Pol_low_sign_info(u:unit)(P Pbar:Pol)(n:nat):=
  (tt,Pol_low_sign P).

  (** Builds an Info from a Pol P **)
  Definition Info_of_Pol(info_sign:Sign)(P:Pol):=
    let Pbar := Pol_square_free P in
    let dPbar := Pol_deg Pbar in
      match info_sign with
	|Some _ => Five P Pbar dPbar info_sign info_sign
	|_ =>
	  let low := Pol_low_sign P in
	    Five P Pbar dPbar low None
      end.

  (**isolates roots of P over ]c d[ **)
  Definition root_isol1(P:Pol)(Pbar:Pol)(degPbar:N):=
  fix root_isol1(res:list (Rpoint*(list (Pol*Sign))))
    (c d:Rat)(blist: list Rat)(n:nat){struct n}:
    list (Rpoint*(list (Pol* Sign))):=
    if rlt d c
      then nil
      else
	let Vb := sign_changes (map rsign blist) in
	  match Vb  with
	    |O => res
	    |1 =>
	      if negb (rzero_test ((Pol_eval P c) *r (Pol_eval P d)))
		then (Alg_root (Five c d P Pbar blist), (P, Some Eq)::nil)::res
		else
		  match n with
		    |O => (Alg_root (Five c d P Pbar blist),(P, None)::nil)::res
		    |S n' =>
		      let mid := (d +r c) // (2 # 1) in
		      let (b', b''):= Pol_bern_split blist c d mid in
		      let res':= root_isol1 res c  mid  b' n' in
			if (rzero_test (Pol_eval Pbar mid))
			  then
			    root_isol1 ((Root Coef cInfo mid,(P, (Some Eq))::nil)::res')
			    mid d b'' n'
			  else
			    root_isol1 res'  mid d b'' n'
		  end
	    |_ =>
	      match n with
		|O => (Alg_root (Five c d P Pbar blist), (P,None)::nil)::res
		|S n' =>
		  let mid := (d +r c) // (2 # 1) in
		  let (b', b''):= Pol_bern_split blist c d mid in
		  let res':= root_isol1 res c  mid  b' n' in
		    if rzero_test (Pol_eval Pbar mid)
		      then
			root_isol1 ((Root Coef cInfo mid, (P,(Some Eq))::nil)::res') mid d b'' n'
		      else
			root_isol1 res'  mid d b'' n'
	      end
	  end.

  (** isolation of the roots of P over the real line **)
  Definition root_isol
    (Pinfo:Info)(lbound ubound:Rat)(n:nat):=
    let (P, Pbar, degPbar,low_sign,info_sign):=Pinfo in
      match info_sign with
	|Some s => (Between Coef cInfo lbound, (P, info_sign)::nil)::nil
	|None =>
	  root_isol1 P Pbar degPbar
	  ((Between Coef cInfo lbound,(P, low_sign)::nil)::nil)
	  lbound ubound (Pol_bern_coefs Pbar lbound ubound degPbar) n
      end.

  (** isolation of the roots of P over ]c d[
  WARNING, do not add Minf, and so returns the  empty list if P has a cst sign over ]cd[**)
  Definition root_isol_int(Pinfo:Info)(c d:Rat)(n:nat) :=
    let (P, Pbar, degPbar,low_sign,info_sign):=Pinfo in
      match info_sign with
	|Some _ => nil
	|None =>
	  root_isol1  P Pbar degPbar nil c d (Pol_bern_coefs Pbar c d degPbar) n
      end.

  (** Sign of Q at a root of P which is not a root of Q
       None means n was not large enough **)
  Definition sign_at_non_com(Q Qbar:Pol):=
    fix sign_at_non_com(a b:Rat)(P Pbar:Pol)(bern bernQ:list Rat)
      (n:nat){struct n}: (Rpoint* Sign):=
      let test := sign_changes (map rsign bernQ) in
	match test with
	  |O => (Alg_root (Five a b P Pbar bern), (Some (rsign (Pol_eval Q a))))
	  |S _ =>
	    let mid := (a +r b) // (2 # 1) in
	    let Pbar_mid := Pol_eval Pbar mid in
	      if rzero_test Pbar_mid
		then (Root Coef cInfo mid , (Some (rsign (Pol_eval Q mid))))
		else
		  match n with
		    |O => (Alg_root (Five a b P Pbar bern), None)
		    |S m =>
		      match rsign (Pbar_mid *r (Pol_eval Pbar a)) with
			| Lt  =>
			  let (bern',_) := Pol_bern_split bern a b mid in
			  let (bernQ',_) := Pol_bern_split bernQ a b mid in
			    sign_at_non_com a mid P Pbar bern' bernQ' m
			|_ =>
			  let (_,bern'') := Pol_bern_split bern a b mid in
			  let (_,bernQ'') := Pol_bern_split bernQ a b mid in
			    sign_at_non_com mid b P Pbar bern'' bernQ'' m
		      end
		  end
	end.

    (** refines [ab] which contains a unique root of P and G=gcd P Q
      to a intervalle which isolates for Q **)

  Definition sign_at_com :=
  fix sign_at_com(a b:Rat)(P Pbar G Gbar:Pol)
    (bernG bernQ:list Rat)(n:nat){struct n}:
    Rpoint*Sign:=
    let VbQ := sign_changes (map rsign bernQ) in
      match VbQ with
	|O => (Alg_root (Five a b G Gbar bernG), None) (*never!*)
	|S O => (Alg_root (Five a b G Gbar bernG), (Some Eq))
	|S _ =>
	  let mid := (a +r b) // (2 # 1) in
	    let Pbar_mid := (Pol_eval Pbar mid) in
	      if rzero_test Pbar_mid
		then
		  (Root Coef cInfo mid, (Some Eq))
		else
		  match n with
		    |O => (Alg_root (Five a b G Gbar bernG), None)
		    |S n' =>
		      match rsign (Pbar_mid *r (Pol_eval Pbar a)) with
			|Lt =>
			  let (bernG',_):=Pol_bern_split bernG a b mid in
			    let (bernQ',_):= Pol_bern_split bernQ a b mid in
			      sign_at_com a mid P Pbar G Gbar bernG' bernQ' n'
			|_ =>
			  let (_,bernG''):=Pol_bern_split bernG a b mid in
			    let (_,bernQ''):=Pol_bern_split bernQ a b mid in
			      sign_at_com mid b P Pbar G Gbar bernG'' bernQ'' n'
		      end
		  end
      end.

  (** refines an AlgRoot of P to determine the sign of Q
     ie up to the point where G=gcd P Q has either a unique root or no root **)

  Definition pair_refine (Q Qbar:Pol)(dQbar:N):=
  fix pair_refine(a b:Rat)(P Pbar G:Pol)
    (bern bernG:list Rat)(n:nat){struct n}:
    Rpoint*Sign:=
    let VbG := sign_changes (map rsign bernG) in
      match VbG with
	|O =>
	  let bernQ := Pol_bern_coefs Qbar a b dQbar in
	    sign_at_non_com Q Qbar (*dQbar *)a b P Pbar bern bernQ n
	|S O =>
	  let bernQ := Pol_bern_coefs Qbar a b dQbar in
	  let Gbar := Pol_square_free G in
	      sign_at_com a b P Pbar G Gbar bernG bernQ n
	|_ =>
	  let mid := (a +r b) // (2 # 1) in
	  let Pbar_mid := (Pol_eval Pbar mid) in
	      if rzero_test Pbar_mid
		then
		  (Root Coef cInfo mid, Some (rsign (Pol_eval Q mid)))
		else
		  match n with
		    |O => (Alg_root (Five a b P Pbar bern), None)
		    |S m =>
		      match rsign (Pbar_mid *r (Pol_eval Pbar a)) with
			|Lt =>
			  let (bern',_):=Pol_bern_split bern a b mid in
			  let (bernG',_):=Pol_bern_split bernG a b mid in
			      pair_refine
			      a mid P Pbar G bern' bernG' m
			|_ =>
			  let (_,bern''):=Pol_bern_split bern a b mid in
			  let (_,bernG''):=Pol_bern_split bernG a b mid in
			      pair_refine
			      mid b P Pbar G bern'' bernG'' m
		      end
		  end
      end.

  (** Sign of Q at a cell_point_up, previous failures are propagated **)
  Definition sign_at(t:Rpoint)(n:nat)(Qinfo:Info):=
    let (Q,Qbar,dQbar,low,infosign) := Qinfo in
      match infosign with
	|Some s => (t,(Q,infosign))
	|None =>
	  match t with
	      |Minf m => (Between Coef cInfo m, (Q,low))
	      |Root r =>
		(Root Coef cInfo r, (Q,Some (rsign (Pol_eval Q r))))
	      |Between b =>
		(Between Coef cInfo b, (Q,Some (rsign (Pol_eval Q b))))
	      |Alg_root (Five a b P Pbar bern) =>
		let G := Pol_gcd Q P in
		let dG := Pol_deg G in
		let bernG := Pol_bern_coefs G a b dG in
		let (t,s) :=
		  pair_refine Q Qbar dQbar a b P Pbar G bern bernG  n in
		  (t,(P,s))
	    end
      end.

  (**idem, but fits the type in the CAD record **)
  Definition Pol_sign_at(c:Info)(z:cell_point_up)(n:nat):=
    let(_,t):= z in
    let (r, u):= sign_at t n c in ((tt,r),u).

  (* t is the current column : a root and the signs already computed,
  sign_list_at_root adds the sign of Q on top of these signs, and has
  possibly refined the root encoding for this purpose **)

  Definition  sign_list_at_root(Qinfo:Info)(t:Rpoint*(list (Pol*Sign)))(n:nat):  Rpoint*(list (Pol*Sign)) :=
  let (root, sign_list) :=  t in
    match sign_list with
      | nil =>
 	let (root_res, sign_res):= sign_at root n Qinfo in
	  (root_res, sign_res::nil)
      | ( _ ,None) :: _ => (root, ((Pol_of_Info Qinfo),None) :: sign_list)
      | _ :: _ =>
	let (root_res, sign_res):= sign_at  root n Qinfo in
	  (root_res, sign_res::sign_list)
    end.

  (** finds the sign colon at b, b is between two roots and the sign column
  correspond to the root just smaller than b is lsign.
   evaluates only if necessary  **)

  Definition fill_sign_between :=
    fix fill_sign_between(b:Rat)(lsign:list (Pol*Sign))
      {struct lsign}:list(Pol* Sign) :=
      match lsign with
	|nil => nil
	|shd::stl =>
	  match shd with
	    | (_ , None) => shd ::(fill_sign_between b stl)
	    | (P,Some s) =>
	      match s with
		|Eq =>
		  (P, Some (rsign (Pol_eval P b)))::(fill_sign_between b stl)
		|_ => shd :: (fill_sign_between b stl)
	      end
	  end
      end.

  (** Sign table for the family P::lP,  over ]low,up[
     P(low) has sign lowsign, P(up) has sign upsign
     l contains the relevant sign table for lP **)

  Definition add_roots(Pinfo:Info)(lP:list Info) :=
    let (P, freeP, dfreeP, low_sign, info_sign):= Pinfo in
      match info_sign with
	|Some s =>
	  fun l:list (Rpoint* (list (Pol * Sign)))=>fun low up:Rat=>fun lowsign upsign:Sign=>fun n:nat =>
	    map (fun x => (fst x, (P, info_sign)::(snd x))) l
	|None =>
	  fix add_roots(l:list (Rpoint* (list (Pol * Sign))))
	    (low up:Rat)(lowsign upsign:Sign)
	    (n:nat){struct l}:list (Rpoint * (list (Pol* Sign))) :=
	    match l with
	      |nil => nil
	      |hd :: tl =>
		let tag := fst hd in
		let prev_slist := snd hd in
		    match tag with
		      |Between b =>
			let resP := root_isol_int Pinfo low up n in
			  ((add_to_cst_list resP prev_slist)@
			    ((Between Coef cInfo b, (P,(Some (rsign (Pol_eval P low ))))::prev_slist))::nil)

		      |Minf  m =>
			let resP := root_isol_int Pinfo low up n in
			  ((add_to_cst_list resP prev_slist)@
			    ((Between Coef cInfo m, (P,(Some (rsign (Pol_eval P low ))))::prev_slist))::nil)
		      |Root  r =>
			if orb (rlt up r) (rzero_test (r  -r  up))
			  then
			    (tag, (P, upsign)::prev_slist)::
			    (add_roots tl low r lowsign upsign n)
			  else
			    let signP_r := rsign (Pol_eval P r) in
			      let resP := root_isol_int Pinfo r up n in
				let prev_next_sign := fill_sign_between ((r+r up)//(2 # 1))
				  prev_slist in
				  let res_r_up := (add_to_cst_list resP prev_next_sign) in
				    res_r_up @
				    ((Root Coef cInfo r, (P, (Some signP_r)):: prev_slist)::
				      (add_roots tl low r  lowsign (Some signP_r) n))
		      |Alg_root (Five a b Q Qbar bern) =>
			let refine := sign_list_at_root Pinfo hd n in
			  match (fst refine) with
			    |Between b => (*dummy*)(Between Coef cInfo b, (P,None) :: prev_slist)::tl
			    |Minf  m => (Between Coef cInfo m, (P,None) :: prev_slist):: tl (*should never happen*)
			    |Root r =>
			      if orb (rlt up r) (rzero_test (r  -r  up))
				then
				  refine::
				    (add_roots  tl low r lowsign upsign n)
				else
				  let signP_r :=
				    match snd refine with
				      |nil => None
				      |s :: tl => snd s
				    end in
				    let prev_next_sign :=
				      fill_sign_between ((r+rup)//(2#1)) prev_slist  in
				      let resP := (root_isol_int Pinfo r up n) in
					let res_r_up := (add_to_cst_list resP prev_next_sign) in
					  res_r_up @
					  (refine::
					    (add_roots tl low r  lowsign
					      signP_r n))
			    |Alg_root (Five a' b' Q' Qbar' bern') =>
			      if orb (rlt up a') (rzero_test (a'  -r  up))
				then
				  refine::
				    (add_roots tl  low a' lowsign upsign n)
				else
				  let Pa' := Pol_eval P a' in
				    let Pb' := Pol_eval P b' in
				      let prev_next_sign :=
					fill_sign_between ((b'+rup)//(2#1)) prev_slist  in
					let resP := (root_isol_int Pinfo b' up n) in
					  let res_b'_up := (add_to_cst_list resP prev_next_sign) in
					    match (rzero_test Pb'), (rzero_test Pa') with
					      |true, false =>
						res_b'_up @
						((Root Coef cInfo b', (P,(Some Eq))::prev_next_sign)::
						  refine::
						    (add_roots  tl low a'
						      lowsign (Some (rsign Pa')) n))
					      |false, true =>
						let prev_a'_sign :=
						  map (fun x => snd (sign_at (Between Coef cInfo a') n x)) lP in
						(*  map (fun P =>(P, Some (rsign (Pol_eval P a')))) lP in*)
						  res_b'_up@
						  (refine ::
						    (Root Coef cInfo a', (P,(Some Eq))::prev_a'_sign)::
						    (add_roots  tl low a'
						      lowsign (Some (rsign Pa')) n))
					      |true, true =>
						let prev_a'_sign :=
						  map (fun x => snd (sign_at (Between Coef cInfo a') n x)) lP in
						  (*map (fun P => (P,Some (rsign (Pol_eval P a')))) lP in*)
						  res_b'_up @
						  ((Root Coef cInfo b', (P,(Some Eq))::prev_next_sign)::
						    refine ::
						      (Root Coef cInfo a', (P,(Some Eq))::prev_a'_sign)::
						      (add_roots tl low a'
							lowsign (Some (rsign Pa')) n))
					      |false, false =>
						res_b'_up @
						(refine::
						  (add_roots tl low a'
						    lowsign (Some (rsign Pa')) n))
					    end
			  end
		    end
	    end
      end.

  (**head is the biggest root, computes the isolating list*)

  Definition family_root(global_low global_up:Rat)(n:nat) :=
  fix family_roots(Pol_list : list Info):list ( Rpoint * (list (Pol*Sign))):=
    match Pol_list with
      |nil => nil
      |Pinfo :: tl =>
	let (P, Pbar, dPbar, low_sign, info_sign):=Pinfo in
	let upsign := rsign (Pol_eval P global_up) in
	  match tl with
	    |nil => root_isol Pinfo global_low global_up n
	    |_ =>
	      let prev := family_roots tl in
		add_roots
		Pinfo tl prev global_low global_up low_sign (Some upsign) n
	  end
    end.

    (** sign table for the family up to "up",included.
      up is not a root
       head corresponds to the smallest root
       gup and glow are the points considered as +infty and -infty for
       the whole family.*)

  Definition sign_table1 (glow gup:Rat):=
  fix sign_table1(Pol_list : list Pol)
    (isol_list : list (Rpoint*(list (Pol*Sign))))
    (up:Rat)(res:list (Rpoint*(list (Pol*Sign)))){struct isol_list}:
    list (Rpoint*(list (Pol*Sign))):=
    let Sign_eval := (fun x P =>
      (x, Some (rsign (Pol_eval P x)))) in
    match isol_list with
      |nil => res
      |hd::tl =>
	let hdTag := fst hd in
	let hdSign := snd hd in
	  match hdTag with
	    |Between b => (*dummy*)(Between Coef cInfo b, hdSign)::res
	    |Minf m=> (Between Coef cInfo glow, hdSign)::res
	    |Root   r =>
	      let bet := (r +r up)//(2 # 1) in
		match res with
		  |nil =>sign_table1 Pol_list tl r
		    (( hdTag, hdSign) ::
			((Between Coef cInfo up, fill_sign_between bet hdSign)::res))
		  |_ =>
		    sign_table1 Pol_list tl r
		    ((hdTag, hdSign) ::
		      ((Between Coef cInfo bet,fill_sign_between bet hdSign)::res))
		end
	    |Alg_root (Five a b _ _ _) =>
	      let bet := (b +r up)//(2#1) in
		match res with
		  |nil =>
		    sign_table1 Pol_list tl a
		    ((hdTag, hdSign)
		      ::((Between Coef cInfo gup,fill_sign_between bet hdSign) ::res))
		    |_ =>
		      sign_table1 Pol_list tl a
		      ((hdTag, hdSign)
			::(( Between Coef cInfo bet,fill_sign_between bet hdSign) ::res))
		end
	  end
    end.

(* information sur le polynome : P, Pbar, dP, lowsign(P), cst_tag(P). cst_tag(P) vaut None si P n'estpas constant, vaut le signe de P sinon*)

  Definition Info_init(low :Rat)(P:Pol):=
    let Pbar := Pol_square_free P in
    let dPbar := Pol_deg Pbar in
      match P with
	|Pc r =>
	  let s := Some (rsign r) in
	    Five P Pbar dPbar s s
	|_ =>
	  let lowsign := Some (rsign (Pol_eval P low)) in
	    Five P Pbar dPbar lowsign None
      end.

  Definition sign_table(Pol_list:list Pol)(n:nat):=
    let up := rmax_list (map Pol_up_bound Pol_list)in
    let low := rmin_list (map Pol_low_bound Pol_list) in
    let Pol_info_list := map (Info_init low) Pol_list in
    let roots := family_root low up n Pol_info_list in
	(sign_table1 low up Pol_list roots up nil).

(* dummy function to convert Rpoint into cell_point_up. pour l'instant on separe ca de sign_table1 vu que c'est provisoire *)

 Definition Rpoint_to_cell_point_up(rcol:Rpoint*(list (Pol *Sign))):=
    let (r,col):= rcol in
      (build_next_path tt r,col).

(*
  Definition Pol_cad(Pol_list:list Pol)(n:nat):=
  (tt,(sign_table Pol_list n)).
*)
  Definition Pol_base_cst_sign(P:Pol):=
    match P with
      |Pc p => Some (rsign p)
      |_ => None
    end.

  Definition CAD(A:Set):= A.

  Definition One_dim_cad := @mk_cad Rat Rat cInfo unit CAD
    P0 P1
    Pol_add Pol_mult_base_cst Pol_mul Pol_sub Pol_opp
    Pol_of_Rat Pol_is_base_cst
    Pol_zero_test  Pol_base_cst_sign Pol_pow Pol_div_base_cst Pol_div
    Pol_gcd_gcd_free   Pol_square_free
    cell_refine
    Pol_low_bound_tt
    Pol_value_bound Info_of_Pol
    Pol_low_sign_info Pol_sign_at
    sign_table.

End ONE_DIM.

End MK_ONE_DIM.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
(*Require Import depoolContract.Lib.CommonCommon.*)
(* Require Import depoolContract.Lib.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.

Require Export depoolContract.Scenarios.Common.CommonDefinitions.
Require Export depoolContract.Scenarios.Common.RotateRoundsCondition.

Definition resultedUnfreeze (l : Ledger) (r : RoundsBase_ι_Round) :=
    if andb
        (andb   (negb (currentValidator l =? RoundsBase_ι_Round_ι_vsetHashInElectionPhase r))
                (negb (prevValidator l =? RoundsBase_ι_Round_ι_vsetHashInElectionPhase r)))
        (RoundsBase_ι_Round_ι_unfreeze r =? MAX_INT l)
    then validationStart l + RoundsBase_ι_Round_ι_stakeHeldFor r
    else RoundsBase_ι_Round_ι_unfreeze r.

Definition shouldBeUnfrozen (l : Ledger) (r : RoundsBase_ι_Round) :=
    resultedUnfreeze l r + ELECTOR_UNFREEZE_LAG l <= now l.


Require Import Base.
Require Import Circuit.
Require Import StateSpace.
Require Import StateSpace.MarkedGraphs.
Require Import StateSpace.RelateTrace.
Require Import Monad.

Require Import List.
Import ListNotations.
Open Scope list_scope.

Require Import MarkedGraph.
Require Import Click.Definitions.
Require Import Click.Invariants.
Require Import Click.MG.

Require Import Omega.

Import EnsembleNotation.
Open Scope ensemble_scope.
Require Import Coq.Program.Equality.
Require Import Coq.Logic.FunctionalExtensionality.

Module Type PropMarkedType.
  Declare Module ClickInvariant : ClickInvariant.
  Export ClickInvariant.
  Module ClickMG := ClickMG(ClickInvariant).
  Export ClickMG.
  Export ClickTactics.

  Definition latch_in_flag (l : latch even odd) := swap_token_flag (latch_to_token_flag l).
  Definition latch_out_flag (l : latch even odd) := latch_to_token_flag l.
  Definition latch_stage_MG l := stage_MG (latch_in_flag l) (latch_out_flag l).
  Definition latch_transition_event l := transition_event l (latch_in_flag l).
  Definition latch_stage_MG_SS l := stage_MG_SS l (latch_in_flag l).

  (** Intuitively, [prop_marked p σ] is a property that holds on a state σ
  whenever a related marking m satisfies [m(p) > 0]. *)

  Inductive prop_marked (l : latch even odd) : forall {t1 t2} (p : stage_place t1 t2) (σ : state name), Prop :=

  (* left_ack -> left_req *)
  | lack_lreq_marked σ :
    σ (ack (latch_input l)) = σ (req (latch_input l)) -> prop_marked l left_ack_left_req σ

  (* right_req -> right_ack *)
  | rreq_rack_marked σ :
    σ (req (latch_output l)) = neg_value (σ (ack (latch_output l))) ->
    prop_marked l right_req_right_ack σ (* right_req -> right_ack *)

  (* clk- -> left_ack *)
  | clk_fall_left_ack_marked σ :
    σ (latch_clk l) = Bit0 ->
(*    σ (latch_old_clk l) = Bit0 -> (* i.e. flop component is stable *) *)
    (* The left_ack component is unstable *)
    σ (ack (latch_input l)) = match latch_to_token_flag l with
                              | Token => σ (latch_state0 l)
                              | Nontoken => neg_value (σ (latch_state0 l))
                              end ->
(*    σ (req (latch_input l)) = σ (ack (latch_input l)) -> (* left environment is stable *)*)
    prop_marked l clk_fall_left_ack σ

(*
  | clk_fall_left_ack_state0_marked σ :
    σ (latch_clk l) = Bit0 ->
    σ (latch_old_clk l) = Bit1 ->
    prop_marked l clk_fall_left_ack σ
*)

  (* clk+ -> right_req *)
  | clk_rise_right_req_marked σ :
    σ (latch_clk l) = Bit1 ->
    σ (latch_old_clk l) = Bit0 ->
    prop_marked l clk_rise_right_req σ
  | clk_rise_right_req_marked_state0 σ :
    σ (req (latch_output l)) <> σ (latch_state0 l) ->
(*    σ (ack (latch_output l)) <> σ (req (latch_output l)) -> *)
    prop_marked l clk_rise_right_req σ

  (* clk+ -> clk- *)
  | clock_fall_flop_marked σ : (* the clk has just risen, and hasn't propogated through the flop yet *)
    σ (latch_clk l) = Bit1 ->
    σ (latch_old_clk l) = Bit0 ->
    stable (latch_clk_component l) σ ->
    prop_marked l clock_fall σ
  | clock_fall_state0_marked σ : (* the clk has propogated through the flop, updating state0 *)
    σ (latch_clk l) = Bit1 ->
    σ (latch_old_clk l) = Bit1 ->
    ~ stable (latch_clk_component l) σ ->
    prop_marked l clock_fall σ

  (* left_req -> clk+ *)
  | left_req_clk_rise_marked σ :
    σ (req (latch_input l)) = neg_value (σ (ack (latch_input l))) -> (* left component is stable *)
    σ (req (latch_input l)) = if_token l (σ (latch_state0 l)) -> (* left ack is stable *)
    σ (latch_clk l) = Bit0 -> (* clk is 0 since we have to wait for the delayy*)
(*    σ (latch_old_clk l) = Bit0 -> (* need extra info *) *)
    prop_marked l left_req_clk_rise σ

  (* right_ack -> clk+ *)
  | right_ack_clk_rise_marked σ :
    σ (ack (latch_output l)) = σ (latch_state0 l) ->
    σ (ack (latch_output l)) = σ (req (latch_output l)) ->
    (latch_clk_function l σ = Bit1 -> σ (latch_clk l) = Bit0) ->
    prop_marked l right_ack_clk_rise σ
  .

End PropMarkedType.

Module PropMarkedTactics (Import PropMarked : PropMarkedType).

  Lemma init_relate_implies_marked : forall {l t1 t2} (p : stage_place t1 t2),
    prop_marked l p (σR l) ->
    init_marking (latch_stage_MG l) _ _ p > 0.
  Proof.
    intros l t1 t2 p Hp.
    dependent destruction Hp;
      try (simpl; unfold init_marking_flag; simpl;
      unfold σR in *; simpl in *; reduce_eqb;
      try (destruct l; simpl in *; find_contradiction; auto; fail);
    fail).
  Qed.

(************)
(** Lemmas **)
(************)

  Lemma stage_eps_decide_state0 : forall l σ σ0,
    wf_stage_state l σ ->

    latch_stage_with_env l ⊢ σ →{None} Some σ0 ->
    σ (latch_state0 l) <> σ0 (latch_state0 l) ->
    σ (latch_old_clk l) = Bit1 \/ σ (latch_clk l) = Bit1.
  Proof.
    intros l σ σ' Hwf Hstep Hstate0.
    apply step_implies_stage_eps in Hstep; auto.
    inversion Hstep as [ v Hclk Hold_clk Hv Hclk_function Hl_ack Hr_req Hnot_state0 Hequiv
                       | Hnot_state0 Hclk Hequiv
                       ]; subst; clear Hstep.

    * right; auto.

    * contradict Hstate0.
      rewrite_state_equiv. 2:{ solve_in_dom. }
      simpl; auto.
  Qed.

(************)
(** Tactics *)
(************)

Arguments wf_scoped {name} S {S_wf} σ e σ' Hstep x : rename.

Ltac rewrite_back_wf_scoped :=
  match goal with
  | [ Hstep : ?S ⊢ ?σ →{ ?e } Some ?σ' |- context[ ?σ ?x ] ] =>
    erewrite <- (@wf_scoped _ S _ σ e σ' Hstep x);
    [ | try (intro; inversion 1; find_contradiction; fail)
    | rewrite latch_stage_with_env_input, latch_stage_with_env_output;
          solve_space_set
    ]
  end.

Ltac distinguish_events :=
  match goal with
  | [ |- context[ Some (latch_transition_event _ ?t _) <> Some (Event _ _) ] ] =>
    intros; destruct t; auto; inversion 1; fail
  | [ |- context[ None <> Some _ ] ] => intros; inversion 1
  | [ |- context[ Some _ <> None ] ] => intros; inversion 1
  end.

End PropMarkedTactics.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Require Export common.lhs_sha_sel_reduce.rhs_con_reduce.
Require Export common.lhs_sha_sel_reduce.rhs_nil_reduce.

Require Export common.lhs_sha_sel_reduce.rhs_sel_low_reduce.
Require Export common.lhs_sha_sel_reduce.rhs_sel_equ_reduce.

Require Export common.lhs_sha_sel_reduce.rhs_low_reduce.
Require Export common.lhs_sha_sel_reduce.rhs_equ_reduce.
Require Export common.lhs_sha_sel_reduce.rhs_upp_reduce.
Require Export common.lhs_sha_sel_reduce.rhs_nom_reduce.

Require Export common.lhs_sha_sel_reduce.rhs_other_reduce.

Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sha_sel_reduce :
  forall T1 x1 L1 ss1 T1', T1 = t_sha_sel x1 L1 ss1 T1' ->
                      forall T2, subtype T1 T2 = match T2 with
                                            | t_top => true
                                            | t_sel_low x2 L2 T2' => orb (subtype T1 T2')
                                                                        (subtype T1' T2)
                                            | t_sel_equ x2 L2 T2' => orb (subtype T1 T2')
                                                                        (subtype T1' T2)
                                            | t_upp _ _ => false
                                            | t_low _ _ => false
                                            | t_equ _ _ => false
                                            | t_nom _ _ => false
                                            | t_nil => false
                                            | t_con _ _ => false

                                            | _ => subtype T1' T2
                                            end.
Proof.
  intros; subst; destruct T2.

  apply subtype_top; crush.

  apply subtype_sha_sel_other_reduce with (x:=x1)(L:=L1)(ss1:=ss1); crush.

  apply subtype_sha_sel_other_reduce with (x:=x1)(L:=L1)(ss1:=ss1); crush.

  eapply subtype_sha_sel_sel_low_reduce; crush.

  eapply subtype_sha_sel_sel_equ_reduce; crush.

  apply subtype_sha_sel_other_reduce with (x:=x1)(L:=L1)(ss1:=ss1); crush.

  apply subtype_sha_sel_other_reduce with (x:=x1)(L:=L1)(ss1:=ss1); crush.

  apply subtype_sha_sel_other_reduce with (x:=x1)(L:=L1)(ss1:=ss1); crush.

  apply subtype_sha_sel_other_reduce with (x:=x1)(L:=L1)(ss1:=ss1); crush.

  apply subtype_sha_sel_other_reduce with (x:=x1)(L:=L1)(ss1:=ss1); crush.

  apply subtype_sha_sel_other_reduce with (x:=x1)(L:=L1)(ss1:=ss1); crush.

  apply subtype_sha_sel_other_reduce with (x:=x1)(L:=L1)(ss1:=ss1); crush.

  apply subtype_sha_sel_upp_reduce
    with
      (x1:=x1)(L1:=L1)(ss1:=ss1)
      (T1':=T1')(L2:=l)(T2':=T2);
    crush.

  apply subtype_sha_sel_low_reduce
    with
      (x1:=x1)(L1:=L1)(ss1:=ss1)
      (T1':=T1')(L2:=l)(T2':=T2);
    crush.

  apply subtype_sha_sel_equ_reduce
    with
      (x1:=x1)(L1:=L1)(ss1:=ss1)
      (T1':=T1')(L2:=l)(T2':=T2);
    crush.

  apply subtype_sha_sel_nom_reduce
    with
      (x1:=x1)(L1:=L1)(ss1:=ss1)
      (T1':=T1')(L2:=l)(T2':=T2);
    crush.

  apply subtype_sha_sel_nil_reduce
    with
      (x1:=x1)(L1:=L1)
      (T1':=T1')(ss1:=ss1);
    crush.

  apply subtype_sha_sel_con_reduce
    with
      (x1:=x1)(L1:=L1)(ss1:=ss1)
      (T1':=T1')(T2':=T2_1)(Ts2:=T2_2);
    crush.
Qed.


Set Primitive Projections.

CoInductive Stream : Type := Cons { tl : Stream }.

Fixpoint Str_nth_tl (n:nat) (s:Stream) : Stream :=
  match n with
  | O => s
  | S m => Str_nth_tl m (tl s)
  end.

CoInductive EqSt (s1 s2: Stream) : Prop := eqst {
  eqst_tl : EqSt (tl s1) (tl s2);
}.

Axiom EqSt_reflex : forall (s : Stream), EqSt s s.

CoFixpoint map (s:Stream) : Stream := Cons (map (tl s)).

Lemma Str_nth_tl_map : forall n s, EqSt (Str_nth_tl n (map s)) (map (Str_nth_tl n s)).
Proof.
induction n.
+ intros; apply EqSt_reflex.
+ cbn; intros s; apply IHn.
Qed.

Definition boom : forall s, tl (map s) = map (tl s) := fun s => eq_refl.


Require Import Undecidability.Synthetic.Undecidability.

Require Import Undecidability.StringRewriting.SSTS.
Require Import Undecidability.CounterMachines.CM2_undec.

Require Undecidability.StringRewriting.Reductions.CM2_HALT_to_SSTS01.

(* Simple Semi-Thue System 01 Rewriting is undecidable. *)
Lemma SSTS01_undec : undecidable SSTS01.
Proof.
  apply (undecidability_from_reducibility CM2_HALT_undec).
  apply CM2_HALT_to_SSTS01.reduction.
Qed.

Check SSTS01_undec.