Require Import Extractions.
Require Import syntax lang Integers.
Open Scope hdl_type_scope.
Open Scope hdl_exp_scope.
Open Scope hdl_stmt_scope.
(* Definition w : interp_ty (tarr 64<<<tvec32>>>). *)
(*   refine (arr_init _ _). *)
(*   apply (Int.repr 63). *)
(*   intros. *)
(*   inversion H. *)
(*   apply (Int.repr (Z_of_nat' n)). *)
(*   apply (Int.repr (Z_of_nat' n)). *)
(* Defined. *)

Definition m : interp_ty (tarr 16<<<tvec32>>>).
  refine (arr_init _ _).
  apply (Int.repr 0).
  intros.
  inversion H.
  apply (Int.repr (Z_of_nat' n)).
  apply (Int.repr (Z_of_nat' n)).
  Defined.

Definition loop : prog.
  (* refine (@ADecl Output 64 TVec32 "w" _ ). *)
  refine (@ADecl Input 16 TVec32 "m" _).
  refine (Output vec "x" ::== Int.repr 0;;; _).
  refine (iter 0 16 (fun i => _ )).
  refine (SAssign Blocking "x" _ ).
  refine ((EBinop OAdd (EVar "x") _)).
  refine (EDeref _ _).
  exact i.
  apply ("m").
Defined.

Definition loop_print_tb : verilog :=
  pretty_print_tb "looper" loop.
(* Definition loop_print : verilog :=  *)
(*   pretty_print "looper" loop. *)

Extract Constant main => "Prelude.putStrLn loop_print_tb".

Extraction "looper.hs" loop_print_tb main.


(** * NOT instruction *)
Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype tuple.
Require Import procstate procstatemonad bitsops bitsprops bitsopsprops.
Require Import spec SPred septac spec safe triple basic basicprog spectac.
Require Import instr instrcodec eval monad monadinst reader pointsto cursor.
Require Import Setoid RelationClasses Morphisms.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import Relations.
Require Import instrsyntax.

Local Open Scope instr_scope.

Require Import x86.instrrules.core.

Lemma NOT_rule d (src:RegMem d) v:
  |-- specAtRegMemDst src (fun V => basic (V v) (UOP d OP_NOT src) (V (invB v))).
Proof. do_instrrule_triple. Qed.

Ltac basicNOT :=
  rewrite /makeUOP;
  let R := lazymatch goal with
             | |- |-- basic ?p (@UOP ?d OP_NOT ?a) ?q => constr:(@NOT_rule d a)
           end in
  basicapply R.

(** We open a section in order to localize the hints *)
Section InstrRules.

Hint Unfold
  specAtDstSrc specAtSrc specAtRegMemDst specAtMemSpec specAtMemSpecDst
  DWORDRegMemR BYTERegMemR DWORDRegMemM DWORDRegImmI fromSingletonMemSpec
  DWORDorBYTEregIs natAsDWORD BYTEtoDWORD
  makeMOV makeBOP makeUOP
  : basicapply.
Hint Rewrite
  addB0 low_catB : basicapply.

(** Special case for not *)
Lemma NOT_R_rule (r:Reg) (v:DWORD):
  |-- basic (r~=v) (NOT r) (r~=invB v).
Proof. basicNOT. Qed.

Corollary NOT_M_rule (r:Reg) (offset:nat) (v pbase:DWORD):
  |-- basic (r~=pbase ** pbase +# offset :-> v) (NOT [r + offset])
            (r~=pbase ** pbase +# offset :-> invB v).
Proof. basicNOT. Qed.
End InstrRules.


Require Import RRR.Lebesgue.Lebesgue.
Require Import RRR.Lang.Lang.
Require Import RRR.Rel.Relations.
Require Import RRR.Rel.Compatibility.
Require Import RRR.Rel.Fundamental.
Require Import RRR.Rel.Adequacy.
Require Import Omega.

Section section_congruence.

Hint Constructors wf_exp wf_val wf_ctx : core.

Fixpoint congruence V (e₁ e₂ : exp V)
(Γ : V → ty) (T T₀ : ty) (C : ctx V)
(W : wf_ctx C Γ T T₀) {struct W} :
ERel_open Γ T e₁ e₂ →
ERel_open ∅→ T₀ (ctx_plug C e₁) (ctx_plug C e₂).
Proof.
intro He.
specialize He as Wf_e. destruct Wf_e as [[Wf_e₁ Wf_e₂] _].
destruct W ; simpl.
+ apply He.
+ eapply congruence; eauto.
  apply compat_exp_val.
  2:{ constructor; assumption.  }
  1:{ constructor; assumption.  }
  apply compat_val_fun; auto.
+ eapply congruence; eauto.
  apply compat_exp_val.
  2:{ constructor; assumption.  }
  1:{ constructor; assumption.  }
  apply compat_val_fix; auto.
+ eapply congruence; eauto.
  apply compat_exp_val.
  2:{ constructor; assumption.  }
  1:{ constructor; assumption.  }
  apply compat_val_query; assumption.
+ eapply congruence; eauto.
  eapply compat_exp_app.
  2:{ apply exp_fundamental. eassumption. }
  apply He.
+ eapply congruence; eauto.
  eapply compat_exp_app.
  1:{ apply exp_fundamental. eassumption. }
  apply He.
+ eapply congruence; eauto.
  eapply compat_exp_let.
  2:{ apply exp_fundamental. eassumption. }
  apply He.
+ eapply congruence; eauto.
  eapply compat_exp_let.
  1:{ apply exp_fundamental. eassumption. }
  apply He.
+ eapply congruence; eauto.
  eapply compat_exp_binop.
  2:{ apply exp_fundamental. eassumption. }
  apply He.
+ eapply congruence; eauto.
  eapply compat_exp_binop.
  1:{ apply exp_fundamental. eassumption. }
  apply He.
+ eapply congruence; eauto.
  apply compat_exp_proj. apply He.
+ eapply congruence; eauto.
  apply compat_exp_if. apply He.
  eapply exp_fundamental; assumption.
  eapply exp_fundamental; assumption.
  + eapply congruence; eauto.
    apply compat_exp_if.
    eapply exp_fundamental; assumption.
    assumption.
    eapply exp_fundamental; assumption.
  + eapply congruence; eauto.
    apply compat_exp_if.
    eapply exp_fundamental; assumption.
    eapply exp_fundamental; assumption.
    assumption.
+ eapply congruence; eauto.
  apply compat_exp_sample. apply He.
+ eapply congruence; eauto.
  apply compat_exp_score. apply He.
Qed.

End section_congruence.

Theorem soundness (V : Set) (Γ : V → ty) T e₁ e₂ :
ERel_open Γ T e₁ e₂ →
ctx_approx Γ T e₁ e₂.
Proof.
intro He.
intros C W.
apply adequacy.
eapply congruence; eassumption.
Qed.

Definition Ciu_equiv (V : Set) (Γ : V → 𝕋) (τ : 𝕋) (e₁ e₂ : exp V) :=
(wf_exp Γ e₁ τ ∧ wf_exp Γ e₂ τ) ∧
∀ γ K, wf_env γ Γ →
μNS_inf (ktx_plug K (V_bind_exp γ e₁)) = μNS_inf (ktx_plug K (V_bind_exp γ e₂)) ∧
μTV_sup (ktx_plug K (V_bind_exp γ e₁)) = μTV_sup (ktx_plug K (V_bind_exp γ e₂)).

Lemma Ciu_open_antisym :
∀ (V : Set) (Γ : V → 𝕋) (τ : 𝕋) (e₁ e₂ : exp V),
Ciu_equiv V Γ τ e₁ e₂ →
Ciu_open Γ τ e₁ e₂ ∧ Ciu_open Γ τ e₂ e₁.
Proof.
  intros V Γ τ e₁ e₂ H.
  destruct H.
  split.
  + split.
    - tauto.
    - intros n γ wf_env.
      split; specialize H0 with (γ := γ) (K := K);
      apply H0 in wf_env; destruct wf_env.
      * eapply ennr_le_trans.
        2:{
          apply μNS_inf_le_μNS.
        }
        rewrite H1.
        auto.
      * intro Ev.
        eapply ennr_le_trans.
        1:{
          apply μTV_sup_ge_μTV.
        }
        rewrite H2.
        auto.
  + split.
    - tauto.
    - intros n γ wf_env.
      split; specialize H0 with (γ := γ) (K := K);
      apply H0 in wf_env; destruct wf_env.
      * eapply ennr_le_trans.
        2:{
          apply μNS_inf_le_μNS.
        }
        rewrite H1.
        auto.
      * intro Ev.
        eapply ennr_le_trans.
        1:{
          apply μTV_sup_ge_μTV.
        }
        rewrite H2.
        auto.
Qed.

Lemma Ciu_equiv_ctx_equiv :
∀ V Γ τ e₁ e₂,
@Ciu_equiv V Γ τ e₁ e₂ → ctx_equiv Γ τ e₁ e₂.
Proof.
  intros V Γ τ e₁ e₂ H.
  apply ctx_approx_antisym.
  split;
  apply soundness;
  apply Ciu_in_ERel;
  apply Ciu_open_antisym in H;
  tauto.
Qed.


(**
    VerifiedDSP
    Copyright (C) {2015}  {Jeremy L Rubin}

    This program 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 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 General Public License along
    with this program; if not, write to the Free Software Foundation, Inc.,
    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

**)
(* Copyright (c) 2011. Greg Morrisett, Gang Tan, Joseph Tassarotti,
   Jean-Baptiste Tristan, and Edward Gan.

   This file is part of RockSalt.

   This file 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.
*)

(** VerifierDFA.v:
    This file contains definitions of the parsers used to build the DFAs
    used in FastVerifier.
*)
Add LoadPath "../Model".
Require Import Coqlib.
Require Import Parser.
Require Import Ascii.
Require Import String.
Require Import List.
Require Import Bits.
Require Import Hex.
Require Import Decode.
Require Import Eqdep.
Require Import Int32.
Unset Automatic Introduction.
Set Implicit Arguments.
Open Scope char_scope.
Require ExtrOcamlString.
Require ExtrOcamlNatBigInt.
Require ExtrOcamlNatInt.
Import i8051_PARSER_ARG.
Import i8051_PARSER.
Import i8051_BASE_PARSER.

Require Import i8051Syntax.

(* In NaCl, ChunkSize is either 16 or 32 *)
Definition logChunkSize := 5%nat.
Definition chunkSize := two_power_nat logChunkSize.
Notation int8_of_nat n := (@repr 7 (Z_of_nat n)).
Definition safeMask := shl (Word.mone 7) (int8_of_nat logChunkSize).

Fixpoint int2bools_aux (bs : Z -> bool) (n: nat) : list bool :=
  match n with
    | O => bs 0 :: nil
    | S n' => bs (Z_of_nat n) :: int2bools_aux bs n'
  end.

Definition int_to_bools {s} (x: Word.int s) : list bool :=
  int2bools_aux (Word.bits_of_Z (s+1) (Word.unsigned x)) s.

Definition nat2bools(n:nat) : list bool :=
  let bs := Word.bits_of_Z 8 (Z_of_nat n) in
    (bs 7)::(bs 6)::(bs 5)::(bs 4)::(bs 3)::(bs 2)::(bs 1)::(bs 0)::nil.

Definition make_dfa t (p:parser t) := build_dfa 256 nat2bools 400 (par2rec p).
Implicit Arguments make_dfa [t].

Definition non_cflow_instrs : list (parser instruction_t) :=
    SETB_p::CLR_p::NOP_p::ANL_p::ADD_p::nil.

Definition instrs : list (parser instruction_t) :=
    LJMP_p::JMP_p::SETB_p::CLR_p::NOP_p::ANL_p::ADD_p::nil.
Definition non_cflow_instr i :=
  match i with
      | SETB _ | CLR _ | NOP  | ANL _ _ | ADD _ _ => true
      | _ => false
  end.
(** The list of valid prefix and instruction parsers for non-control-flow
    operations. *)

Definition non_cflow_parser := alts non_cflow_instrs.
Definition all_parsers := alts instrs.

Definition non_cflow_parser_list :=
  (List.map (fun (p:parser instruction_t) =>  p)
            non_cflow_instrs).
    (* Direct jumps. Destinations will be checked to see if
   they are known, valid starts of instructions. *)

(* We only want to allow "near" jumps to direct, relative offsets *)

Definition dir_cflow : list (parser instruction_t) :=
 LJMP_p :: JMP_p ::nil. (* dir_near_JMP_p :: dir_near_Jcc_p :: dir_near_CALL_p :: nil.*)
Import i8051Syntax.
Lemma register_to_Z_identity1: forall r, Z_to_register (register_to_Z r) = r.
Proof. destruct r; auto.
Qed.

Definition register_to_bools (r: register) :=
  let bs := Word.bits_of_Z 3 (register_to_Z r) in
    (bs 2) :: (bs 1) :: (bs 0) :: nil.

Fixpoint bitslist (bs: list bool) : parser unit_t :=
  match bs with
    | nil => Eps_p
    | b::bs' => Cat_p (Char_p b) (bitslist bs') @ (fun _ => tt %% unit_t)
  end.

Fixpoint bitslist' (bs: list bool) : string :=
  match bs with
    | nil => EmptyString
    | true::bs' => append "1" (bitslist' bs')
    | false::bs' => append "0" (bitslist' bs')
  end.

Definition b8 := true::false::false::false::nil.
Definition b3 := false::false::true::true::nil.
Definition be := true::true::true::false::nil.
Definition b0 := false::false::false::false::nil.
Definition bf := true::true::true::true::nil.

Definition mybits := b8 ++ b3 ++ be ++ b0 ++ be ++ b0 ++ bf ++ bf ++ be ++ b0.

(* These are akin to the NaCl "pseudo-instruction" nacljmp. We will
   check if the jump destination is appropriately masked by the
   preceding AND *)

  Fixpoint parseloop ps bytes :=
    match bytes with
      | nil => None
      | b::bs => match Decode.i8051_PARSER.parse_byte ps b with
                   | (ps', nil) => parseloop ps' bs
                     (* JGM: FIX!  What to do with prefix? *)
                   | (ps',(LJMP  (Imm_op disp) )::_) =>
                     match bs with
                       | nil => Some disp
                       | _ => None
                     end
                   | (ps', _) => None
                 end
    end.

(** Next, we define a boolean-valued test that tells whether an instruction
    is a valid non-control-flow instruction.  We should have the property
    that the [non_cflow_parser] only builds instructions that satisfy this
    predicate (as shown below.)  Furthermore, we should be able to argue
    that for each of these instructions, the NaCL SFI invariants are preserved.
*)
Definition no_imm_op(op1:operand) : bool :=
  match op1 with
    | Imm_op _ => false
    | _ => true
  end.

Definition no_prefix (p : prefix) : bool :=  true.

(** We rule out JMPs and CALLs that are far (i.e., not near), that
    are absolute instead of relative, that don't have an immediate
    operand, or that have a selector. *)
Definition dir_cflow_instr (pre:prefix) (ins: instr) : bool :=
  match ins with
    | LJMP (Imm_op _)  => true
    | _ => false
  end.

(** This predicate is defined on a pair of prefixes and instructions and
    captures the legal masked indirect jumps. *)
Definition nacljmp_mask_instr (pfx1:prefix) (ins1:instr) (pfx2:prefix) (ins2:instr) :=
  no_prefix pfx1 && no_prefix pfx2 &&
  match ins1 with
    | ANL (Reg_op r1) (Imm_op wd) =>
      zeq (Word.signed wd) (Word.signed safeMask) &&
      (if register_eq_dec r1 r1 then false else true)
    | _ => false
  end.
Definition nacl_MASK_p : parser (pair_t instruction_t instruction_t):=
  let imMask := (Imm_op (Word.repr hF0)) in
  ( bits ("01010100"++"11110000") @ (fun _ => ANL Acc_op imMask %% instruction_t))
    $ (("01010011") $$ bitslist' (int_to_bools (@Word.repr 7 Alias.DPL)) $$ bits "11110000" @ (fun _ => ANL (Direct_op (Word.repr Alias.DPL)) imMask %% instruction_t)).

Definition nacl_JMP_p  :=
  JMP_p.

Definition nacljmp_p  :
  parser (pair_t (pair_t instruction_t instruction_t) instruction_t) :=
    nacl_MASK_p $ (nacl_JMP_p).
Definition nacljmp_mask :
  list (parser (pair_t (pair_t instruction_t instruction_t) instruction_t))
  := nacljmp_p :: nil.

Definition dfas := (make_dfa non_cflow_parser, make_dfa (alts dir_cflow), make_dfa (alts nacljmp_mask)).
(* Extraction "tables.ml" dfas.*)


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
(** * Implementation of simply-typed interface of the parser *)
Require Import Coq.ZArith.ZArith.
Require Export Fiat.Parsers.ParserInterface.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.Properties.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.BooleanRecognizer Fiat.Parsers.BooleanRecognizerCorrect.
Require Import Fiat.Parsers.RecognizerPreOptimized.
Require Fiat.Parsers.SimpleRecognizer.
Require Fiat.Parsers.SimpleRecognizerExt.
Require Fiat.Parsers.SimpleBooleanRecognizerEquality.
Require Fiat.Parsers.SimpleRecognizerCorrect.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.BaseTypes Fiat.Parsers.CorrectnessBaseTypes.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.MinimalParseOfParse.
Require Import Fiat.Common.

Set Implicit Arguments.

Local Open Scope list_scope.

Section implementation.
  Context {Char}
          {G : pregrammar' Char}.

  Context (splitter : Splitter G).

  Let predata := @rdp_list_predata _ G.
  Local Existing Instance predata.

  Let parser_presplit_data : @split_dataT Char (string_type_min splitter) _.
  Proof.
    refine {| split_string_for_production idx str
              := splits_for splitter str idx |}.
  Defined.

  Local Instance parser_split_data : @split_dataT Char splitter predata
    := @optsplitdata _ _ _ parser_presplit_data.

  Local Instance preparser_data : @boolean_parser_dataT Char _ :=
    { predata := rdp_list_predata (G := G);
      split_data := parser_presplit_data }.

  Local Instance parser_data : @boolean_parser_dataT Char _ :=
    { predata := rdp_list_predata (G := G);
      split_data := parser_split_data }.

  Local Arguments split_string_for_production : simpl never.

  Local Obligation Tactic := intros.

  Local Program Instance parser_precompleteness_data : @boolean_parser_completeness_dataT' Char _ _ G preparser_data
    := { split_string_for_production_complete len0 valid str offset len pf nt Hvalid := _ }.
  Next Obligation.
    apply initial_nonterminals_correct in Hvalid.
    generalize (fun it its idx offset len Hvalid' Heqb n pf pf' pit pits prefix H' => @splits_for_complete Char G splitter str idx offset len Hvalid' Heqb it its n pf pf' (ex_intro _ nt (ex_intro _ prefix (conj Hvalid H'))) pit pits).
    clear Hvalid.
    induction (G nt) as [ | x xs IHxs ].
    { intros; constructor. }
    { intros H'.
      simpl.
      split;
        [ clear IHxs
        | apply IHxs; trivial;
          intros; eapply H'; try eassumption; [ right; eassumption ] ].
      specialize (fun prefix idx it its H Hvalid' n offset len Heqb pf pf' pit pits => H' it its idx offset len Hvalid' Heqb n pf pf' pit pits prefix (or_introl H)).
      clear -H' H.
      induction x as [ | it its IHx ].
      { simpl; constructor. }
      { simpl.
        split;
          [ clear IHx
          | apply IHx;
            intros; subst; eapply (H' (_::_)); try eassumption; reflexivity ].
        intros idx Hvalid Heqb.
        specialize (H' nil idx _ _ eq_refl).
        specialize_by assumption.
        specialize (H' _ _ H).
        hnf.
        intros [ n [ pit pits ] ]; simpl in * |- .
        destruct (Compare_dec.le_ge_dec n (length (substring offset len str))).
        { exists n; repeat split; eauto.
          specialize (fun pf =>
                        H' _ pf
                           (parse_of_item__of__minimal_parse_of_item pit)
                           (parse_of_production__of__minimal_parse_of_production pits)).
          specialize_by assumption.
          rewrite Min.min_r by assumption.
          apply H'; eauto. }
        { exists (length (substring offset len str)).
          specialize (H' _ (reflexivity _)).
          rewrite Min.min_idempotent.
          rewrite !substring_length_no_min in * by assumption.
          repeat match goal with
                   | [ H : context[length (substring _ _ _)] |- _ ] => rewrite !substring_length_no_min in H by assumption
                 end.
          pose proof (fun H => expand_minimal_parse_of_item (str' := take len (substring offset len str)) (or_introl (reflexivity _)) (reflexivity _) (or_introl (reflexivity _)) H pit) as pit'; clear pit.
          pose proof (fun H => expand_minimal_parse_of_production (str' := drop len (substring offset len str)) (or_introl (reflexivity _)) (reflexivity _) (or_introl (reflexivity _)) H pits) as pits'; clear pits.
          set (s := substring offset len str) in *.
          specialize_by
                 (first [ rewrite ?take_long, ?drop_long
                          by first [ subst s; reflexivity
                                   | subst s; rewrite substring_length_no_min by assumption; omega ];
                          reflexivity
                        | apply bool_eq_empty; rewrite ?drop_length; subst s;
                          rewrite substring_length_no_min by assumption;
                          omega ]).
          specialize_by assumption.
          repeat split; try assumption.
          apply H'.
          { eapply (@parse_of_item__of__minimal_parse_of_item Char splitter _ _ _ _); eassumption. }
          { eapply (@parse_of_production__of__minimal_parse_of_production Char splitter _ _ _ _ _); eassumption. } } } }
  Qed.

  Local Instance parser_completeness_data : @boolean_parser_completeness_dataT' Char _ _ G parser_data
    := optsplitdata_correct.

  Local Obligation Tactic := program_simpl.

  Program Definition parser : Parser G splitter
    := {| has_parse str := parse_nonterminal (data := parser_data) str (Start_symbol G);
          parse str := option_map (SimpleParseNonTerminal (Start_symbol G)) (SimpleRecognizer.parse_nonterminal (data := parser_data) str (Start_symbol G));
          has_parse_sound str Hparse := parse_nonterminal_sound (data := parser_data) _ _ Hparse;
          has_parse_complete str p := _;
          parse_sound str p := _ |}.
  Next Obligation.
  Proof.
    dependent destruction p.
    pose proof (fun pf => @parse_of_nonterminal_complete Char splitter _ _ G _ _ rdp_list_rdata' str (Start_symbol G) pf p) as H'.
    apply H'; assumption.
  Qed.
  Next Obligation.
  Proof.
    erewrite SimpleBooleanRecognizerEquality.parse_nonterminal_eq; simpl;
    unfold option_map.
    destruct SimpleRecognizer.parse_nonterminal; reflexivity.
  Qed.
  Next Obligation.
  Proof.
    eapply SimpleRecognizerCorrect.parse_item_correct.
    unfold option_map in *; simpl in *.
    unfold SimpleRecognizer.parse_nonterminal, GenericRecognizer.parse_nonterminal in *; simpl in *.
    rewrite <- H; clear H p.
    repeat match goal with
           | _ => reflexivity
           | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
           | _ => progress simpl in *
           end.
    unfold SimpleRecognizer.parse_nonterminal', SimpleRecognizer.parse_nonterminal_or_abort, GenericRecognizer.parse_nonterminal', GenericRecognizer.parse_nonterminal_or_abort in *.
    let H := match goal with H : context[Fix] |- _ => H end in
    rewrite Common.Wf1.Fix5_eq
      in H
      by (intros; eapply SimpleRecognizerExt.parse_nonterminal_step_ext; assumption);
      unfold GenericRecognizer.parse_nonterminal_step at 1 in H.
    simpl in *.
    edestruct Compare_dec.lt_dec; simpl in *; try omega; [].
    edestruct dec; simpl in *; try congruence; [].
    edestruct negb; simpl in *; congruence.
    Unshelve.
    assumption.
    assumption.
  Qed.
End implementation.


Require Export Iron.Language.SystemF2Effect.Type.
Require Export Iron.Language.SystemF2Effect.Value.Exp.
Require Export Iron.Language.SystemF2Effect.Value.Relation.Wf.
Require Export Iron.Language.SystemF2Effect.Value.Operator.LiftX.
Require Export Iron.Language.SystemF2Effect.Store.Prop.

(* Store Environment holds the types of locations. *)
Definition stenv := list ty.

(* Types of primops.
   We keep this separate from the main typing judgement to make it easy
   to add new primops. *)
Fixpoint typeOfOp1 (op : op1) : ty
 := match op with
    | OSucc    => TFun TNat TNat  (TBot KEffect)
    | OIsZero  => TFun TNat TBool (TBot KEffect)
    end.

(* Types of Value expressions *)
Inductive
  TYPEV : kienv -> tyenv -> stenv -> stprops
        -> val  -> ty    -> ty
        -> Prop :=

  (* Variables.
     We get the type of a variable from the type environment. *)
  | TvVar
    :  forall ke te se sp i t
    ,  get i te = Some t
    -> KindT  ke sp t KData
    -> TYPEV  ke te se sp (VVar i) t (TDeepUse t)

  (* Store locations.
     We get the type of a location from the store typing.
     The type of a location must be a Reference because we need somewhere
     to attach the region variable. Our primitive types don't have region
     annotations themselves. *)
  | TvLoc
    :  forall ke te se sp i r t
    ,  get i se = Some (TRef r t)
    -> KindT  ke sp       (TRef r t) KData
    -> TYPEV  ke te se sp
              (VLoc i) (TRef r t) (TSum KClosure (TUse r) (TDeepUse t))

  (* Value abstraction.
     The body is checked in an environment extended with the type of
     of the formal parameter. *)
  | TvLam
    :  forall ke te se sp t1 t2 x2 e2
    ,  KindT   ke sp t1 KData
    -> TYPEX  ke (te :> t1) se sp x2 t2 TPure TEmpty
    -> TYPEV  ke te         se sp (VLam t1 x2) (TFun t1 t2) TEmpty

  (* Type abstraction.
     The body is checked in an environemnt extended with the kind of
     the formal parameter. As the parameter kind is pushed onto the base
     of the kind environment we need to lift any references to kinds
     higher in the stack across the new one. The body expression must
     be pure because we don't have anywhere to store the effect of the
     body in the type of the overall abstraction. This is different for
     value abstractions, where the function constructor has an effect
     annotation. *)
  | TvLAM
    :  forall ke te se sp k1 t2 x2
    ,  TYPEX (ke :> k1) (liftTE 0 te) (liftTE 0 se) sp x2 t2 TPure TEmpty
    -> TYPEV ke te se sp (VLAM k1 x2) (TForall k1 t2) TEmpty

  (* Primitive constants.
     We get the types of these from the 'typeOfConst' function so we can
     add new sorts of constants without changing the proof. *)
  | TvConst
    :  forall ke te se sp c t
    ,  t = typeOfConst c
    -> TYPEV  ke te se sp (VConst c) t

  with TYPEX :  kienv -> tyenv -> stenv -> stprops
             -> exp   -> ty -> ty -> ty
             -> Prop :=

  (* Embed values in the expression language.
     All values are pure because they can't be stepped further, which
     in turn means they can't perform any more effectful actions. *)
  | TxVal
    :  forall ke te se sp v1 t1
    ,  TYPEV  ke te se sp v1 t1
    -> TYPEX  ke te se sp (XVal v1) t1 (TBot KEffect)

  (* Let-bindings. *)
  | TxLet
    :  forall ke te se sp t1 x1 t2 x2 e1 e2
    ,  KindT  ke sp t1 KData
    -> TYPEX  ke te         se sp x1 t1 e1
    -> TYPEX  ke (te :> t1) se sp x2 t2 e2
    -> TYPEX  ke te         se sp (XLet t1 x1 x2) t2 (TSum e1 e2)

  (* Value application. *)
  | TxApp
    :  forall ke te se sp t11 t12 v1 v2 e1
    ,  TYPEV  ke te se sp v1 (TFun t11 e1 t12)
    -> TYPEV  ke te se sp v2 t11
    -> TYPEX  ke te se sp (XApp v1 v2) t12 e1

  (* Type application. *)
  | TvAPP
    :  forall ke te se sp v1 k11 t12 t2
    ,  TYPEV  ke te se sp v1 (TForall k11 t12)
    -> KindT  ke sp t2 k11
    -> TYPEX  ke te se sp (XAPP v1 t2) (substTT 0 t2 t12) (TBot KEffect)

  (* Store Operators ******************)
  (* Create a new region. *)
  | TxNew
    :  forall ke te se sp x t tL e eL
    ,  lowerTT 0 t               = Some tL
    -> lowerTT 0 (maskOnVarT 0 e) = Some eL
    -> TYPEX (ke :> KRegion) (liftTE 0 te) (liftTE 0 se) sp x        t  e
    -> TYPEX ke              te             se           sp (XNew x) tL eL

  (* Allocate a new heap binding. *)
  | TxOpAlloc
    :  forall ke te se sp r1 v2 t2
    ,  KindT  ke sp r1 KRegion
    -> TYPEV  ke te se sp v2 t2
    -> TYPEX  ke te se sp (XAlloc r1 v2) (TRef r1 t2) (TAlloc r1)

  (* Read a value from a heap binding. *)
  | TxOpRead
    :  forall ke te se sp v1 r1 t2
    ,  KindT  ke sp r1 KRegion
    -> TYPEV  ke te se sp v1 (TRef r1 t2)
    -> TYPEX  ke te se sp (XRead r1 v1)     t2    (TRead r1)

  (* Write a value to a heap binding. *)
  | TxOpWrite
    :  forall ke te se sp v1 v2 r1 t2
    ,  KindT  ke sp r1 KRegion
    -> TYPEV  ke te se sp v1 (TRef r1 t2)
    -> TYPEV  ke te se sp v2 t2
    -> TYPEX  ke te se sp (XWrite r1 v1 v2) TUnit (TWrite r1)

  (* Primtive Operators ***************)
  | TxOpPrim
    :  forall ke te se sp op v1 t11 t12 e
    ,  typeOfOp1 op = TFun t11 t12 e
    -> TYPEV  ke te se sp v1 t11
    -> TYPEX  ke te se sp (XOp1 op v1) t12 e.

(*
  | TxCastEffect
    :  TYPEX  ke te se sp x t1 e1
    -> SubsT  ke te se sp x e2 e1          (* also use to fix equiv of effect *)
    -> TYPEX  ke te se sp x (casteff e2 t1) e2
*)
Hint Constructors TYPEV.
Hint Constructors TYPEX.

(* Invert all hypothesis that are compound typing statements. *)
Ltac inverts_type :=
 repeat
  (match goal with
   | [ H: TYPEV _ _ _ _ (VVar   _)     _    |- _ ] => inverts H
   | [ H: TYPEV _ _ _ _ (VLoc   _)     _    |- _ ] => inverts H
   | [ H: TYPEV _ _ _ _ (VLam   _ _)   _    |- _ ] => inverts H
   | [ H: TYPEV _ _ _ _ (VLAM   _ _)   _    |- _ ] => inverts H
   | [ H: TYPEV _ _ _ _ (VConst _)     _    |- _ ] => inverts H
   | [ H: TYPEX _ _ _ _ (XVal   _)     _ _  |- _ ] => inverts H
   | [ H: TYPEX _ _ _ _ (XLet   _ _ _) _ _  |- _ ] => inverts H
   | [ H: TYPEX _ _ _ _ (XApp   _ _)   _ _  |- _ ] => inverts H
   | [ H: TYPEX _ _ _ _ (XAPP   _ _)   _ _  |- _ ] => inverts H
   | [ H: TYPEX _ _ _ _ (XNew   _)     _ _  |- _ ] => inverts H
   | [ H: TYPEX _ _ _ _ (XAlloc _ _)   _ _  |- _ ] => inverts H
   | [ H: TYPEX _ _ _ _ (XRead  _ _)   _ _  |- _ ] => inverts H
   | [ H: TYPEX _ _ _ _ (XWrite _ _ _) _ _  |- _ ] => inverts H
   | [ H: TYPEX _ _ _ _ (XOp1   _ _)   _ _  |- _ ] => inverts H
   end).


Require Export IGrammar.
Require Import MyUtils.
Require Import IGrammarTheorems.

Section IGrammarBonusTheorems.

Create HintDb IGrammar.
Hint Resolve CPrio1 : IGrammar.
Hint Resolve CPrio2 : IGrammar.
Hint Resolve CLeft : IGrammar.
Hint Resolve CRight : IGrammar.
Hint Resolve HMatch : IGrammar.
Hint Resolve InfixMatch : IGrammar.

Definition safe_cpatterns {O} (pr : drules O) : Prop :=
  forall (o1 o2 : O), (conflict_pattern pr (CR o1 o2) /\ conflict_pattern pr (CL o2 o1) -> False).

Lemma safe_cpatterns_pr {O} (pr : drules O) :
  safe_cpatterns pr ->
  safe_pr pr.
Proof.
  unfold safe_cpatterns. unfold safe_pr. intros.
  destruct H0; destruct H1; eapply H; eauto with IGrammar.
Qed.

Lemma safe_filter_cpatterns {L O} (pr : drules O) :
  (exists (l : L), True) ->
  safe L pr ->
  safe_cpatterns pr.
Proof.
  unfold safe, safe_cpatterns. intros. destruct H as [l].
  inv H1.
  specialize H0 with [inl l; inr o1; inl l; inr o2; inl l].
  assert (language [inl l; inr o1; inl l; inr o2; inl l]). {
    unfold language. exists (InfixNode (InfixNode (AtomicNode l) o1 (AtomicNode l)) o2 (AtomicNode l)).
    reflexivity.
  }
  apply H0 in H1. unfold dlanguage in H1. destruct H1 as [t]. inv H1.
  destruct t; simplify_list_eq.
  destruct t1; simplify_list_eq.
  - destruct t2; simplify_list_eq.
    destruct t2_1; simplify_list_eq.
    + destruct t2_2; simplify_list_eq.
      * inv H5. destruct H7. eexists. eauto with IGrammar.
      * destruct (yield t2_2_1); simplify_list_eq. destruct w; simplify_list_eq.
    + destruct (yield t2_1_1); simplify_list_eq.
      destruct w; simplify_list_eq.
      * destruct (yield t2_1_2); simplify_list_eq.
        destruct w; simplify_list_eq.
      * destruct w; simplify_list_eq.
        destruct w; simplify_list_eq.
  - destruct t1_1; simplify_list_eq.
    + destruct t1_2; simplify_list_eq.
      * destruct t2; simplify_list_eq.
        **inv H5. destruct H7. eexists. eauto with IGrammar.
        **destruct (yield t2_1); simplify_list_eq.
          destruct w; simplify_list_eq.
      * destruct (yield t1_2_1); simplify_list_eq.
        destruct w; simplify_list_eq.
        **destruct (yield t1_2_2); simplify_list_eq.
          destruct w; simplify_list_eq.
        **destruct w; simplify_list_eq.
          destruct w; simplify_list_eq.
    + destruct (yield t1_1_1); simplify_list_eq.
      destruct w; simplify_list_eq.
      * destruct (yield t1_1_2); simplify_list_eq.
        destruct w; simplify_list_eq.
        **destruct (yield t1_2); simplify_list_eq.
          destruct w; simplify_list_eq.
        **destruct w; simplify_list_eq.
          destruct w; simplify_list_eq.
      * destruct w; simplify_list_eq.
        destruct w; simplify_list_eq.
        **destruct (yield t1_1_2); simplify_list_eq.
          destruct w; simplify_list_eq.
        **destruct w; simplify_list_eq.
          destruct w; simplify_list_eq.
Qed.

Record complete_cpatterns {O} (pr : drules O) := mkCompleteCpatterns {
  com1 : forall o1 o2, (conflict_pattern pr (CR o1 o2) \/ conflict_pattern pr (CL o2 o1));
  com2 : forall o1 o2 o3, conflict_pattern pr (CR o1 o2) ->
                          conflict_pattern pr (CR o2 o3) ->
                          conflict_pattern pr (CR o1 o3);
  com3 : forall o1 o2 o3, conflict_pattern pr (CL o1 o2) ->
                          conflict_pattern pr (CL o2 o3) ->
                          conflict_pattern pr (CL o1 o3)
}.

Record wf_drules {O} (pr : drules O) := mkWfDrules {
  wf_drules1 : forall o1 o2 : O, left_a pr o1 o2 /\ right_a pr o1 o2 -> False;
  wf_drules2 : forall o1 o2 : O, left_a pr o1 o2 /\ prio pr o1 o2 -> False;
  wf_drules3 : forall o1 o2 : O, prio pr o1 o2 /\ right_a pr o1 o2 -> False;
}.

Lemma complete_cpatterns_pr {O} (pr : drules O) :
  wf_drules pr ->
  safe_cpatterns pr ->
  complete_cpatterns pr ->
  complete_pr pr.
Proof.
  intros. apply mkComplete_pr; intros.
  - inv H1. specialize com4 with o1 o2. destruct com4.
    + inv H1; auto.
    + inv H1; auto.
  - inv H1. specialize com5 with o1 o2 o3. specialize com6 with o1 o2 o3.
    apply CPrio1 in H2 as ?. apply CPrio2 in H2 as ?. apply CPrio1 in H3 as ?. apply CPrio2 in H3 as ?.
    apply com5 in H4; auto. apply com6 in H1; auto.
    inv H1; auto. inv H4; auto.
    exfalso. eapply H; eauto.
  - apply CPrio1 in H2 as ?. apply CPrio2 in H2 as ?. apply CLeft in H3.
    inv H1. eapply com5 in H3 as ?; eauto.
    inv H1; eauto.
    specialize com4 with o3 o1. destruct com4.
    + eapply com5 in H1; eauto. exfalso. eapply H0; eauto.
    + inv H1; auto.
      exfalso. eapply H; eauto.
  - apply CPrio1 in H2 as ?. apply CPrio2 in H2 as ?. apply CRight in H3.
    inv H1. eapply com6 in H3 as ?; eauto.
    inv H1; eauto.
    specialize com4 with o1 o3. destruct com4.
    + inv H1; auto.
      exfalso. eapply H; eauto.
    + eapply com6 in H1; eauto. exfalso. eapply H0; eauto.
  - apply CLeft in H2. apply CPrio1 in H3 as ?. apply CPrio2 in H3.
    inv H1. eapply com5 in H3 as ?; eauto.
    inv H1; eauto.
    specialize com4 with o3 o1. destruct com4.
    + exfalso. eauto.
    + inv H1; eauto. exfalso. eapply H. eauto.
  - apply CLeft in H2 as ?. apply CLeft in H3 as ?. inv H1.
    eapply com5 in H5 as ?; eauto. inv H1; auto. apply CPrio1 in H7 as ?.
    exfalso.
    specialize com4 with o2 o1 as ?. destruct H6.
    + specialize com4 with o3 o2 as ?. destruct H8.
      * eapply com5 in H6; eauto.
      * inv H. inv H8; eauto.
    + inv H. inv H6; eauto.
  - apply CLeft in H2 as ?. apply CRight in H3 as ?.
    inv H1. specialize com4 with o1 o3 as ?. destruct H1; eauto.
    inv H. apply H0 with o2 o3. split; auto.
    + apply com5 with o1; auto.
      specialize com4 with o2 o1. destruct com4; auto. exfalso. inv H; eauto.
    + specialize com4 with o2 o3. destruct com4; auto. exfalso. inv H; eauto.
Qed.

Ltac cp_cases H := eapply conflict_pattern_cases in H; try eassumption; intros; subst.

Lemma complete_filter_cpatterns {L O} (pr : drules O) :
  safe_cpatterns pr ->
  (exists (l : L), True) ->
  complete L pr ->
  complete_cpatterns pr.
Proof.
  intros. destruct H0 as [l]. unfold complete in H1.
  apply mkCompleteCpatterns; intros.
  - specialize H1 with
      (InfixNode (AtomicNode l) o1 (InfixNode (AtomicNode l) o2 (AtomicNode l)))
      (InfixNode (InfixNode (AtomicNode l) o1 (AtomicNode l)) o2 (AtomicNode l)).
    simpl in H1.
    destruct (is_conflict_pattern pr (CR o1 o2)) eqn:E1; try apply is_conflict_pattern_true in E1; auto.
    apply is_conflict_pattern_false in E1.
    destruct (is_conflict_pattern pr (CL o2 o1)) eqn:E2; try apply is_conflict_pattern_true in E2; auto.
    apply is_conflict_pattern_false in E2.
    assert ([inl l; inr o1; inl l; inr o2; inl l] = [inl l; inr o1; inl l; inr o2; inl l]). {
      reflexivity.
    }
    apply H1 in H2.
    + inv H2.
    + apply Infix_cf; auto using Atomic_cf.
      * intro. inv H3. inv H4. cp_cases H3; inv H5.
        **inv H7.
        **inv H12. contradiction.
      * apply Infix_cf; auto using Atomic_cf.
        intro. inv H3. inv H4. cp_cases H3; inv H5.
        **inv H7.
        **inv H12.
    + apply Infix_cf; auto using Atomic_cf.
      * intro. inv H3. inv H4. cp_cases H3.
        **inv H5. inv H7. contradiction.
        **inv H5. inv H12.
      * apply Infix_cf; auto using Atomic_cf.
        intro. inv H3. inv H4. cp_cases H3; inv H5.
        **inv H7.
        **inv H12.
  - specialize H1 with
      (InfixNode (InfixNode (InfixNode (AtomicNode l) o1 (AtomicNode l)) o2 (AtomicNode l)) o3 (AtomicNode l))
      (InfixNode (AtomicNode l) o1 (InfixNode (InfixNode (AtomicNode l) o2 (AtomicNode l)) o3 (AtomicNode l))).
    simpl in H1.
    destruct (is_conflict_pattern pr (CR o1 o3)) eqn:E; try apply is_conflict_pattern_true in E; auto.
    apply is_conflict_pattern_false in E. exfalso.
    unfold safe_cpatterns in H.
    assert (~ conflict_pattern pr (CL o2 o1)); eauto.
    assert (~ conflict_pattern pr (CL o3 o2)); eauto.
    assert ([inl l; inr o1; inl l; inr o2; inl l; inr o3; inl l]
            = [inl l; inr o1; inl l; inr o2; inl l; inr o3; inl l]); auto.
    apply H1 in H6.
    + inv H6.
    + apply Infix_cf; auto using Atomic_cf.
      * intro. inv H7. inv H8. cp_cases H7; inv H9. inv H11. contradiction. inv H16.
      * apply Infix_cf; auto using Atomic_cf.
        **intro. inv H7. inv H8. cp_cases H7; inv H9. inv H11. contradiction. inv H16.
        **apply Infix_cf; auto using Atomic_cf.
          intro. inv H7. inv H8. cp_cases H7; inv H9. inv H11. inv H16.
    + apply Infix_cf; auto using Atomic_cf.
      * intro. inv H7. inv H8. cp_cases H7; inv H9. inv H11. inv H16. contradiction.
      * apply Infix_cf; auto using Atomic_cf.
        **intro. inv H7. inv H8. cp_cases H7; inv H9. inv H11. contradiction. inv H16.
        **apply Infix_cf; auto using Atomic_cf.
          intro. inv H7. inv H8. cp_cases H7; inv H9. inv H11. inv H16.
  - specialize H1 with
      (InfixNode (AtomicNode l) o3 (InfixNode (AtomicNode l) o2 (InfixNode (AtomicNode l) o1 (AtomicNode l))))
      (InfixNode (InfixNode (AtomicNode l) o3 (InfixNode (AtomicNode l) o2 (AtomicNode l))) o1 (AtomicNode l)).
    simpl in H1.
    destruct (is_conflict_pattern pr (CL o1 o3)) eqn:E; try apply is_conflict_pattern_true in E; auto.
    apply is_conflict_pattern_false in E. exfalso.
    unfold safe_cpatterns in H.
    assert (~ conflict_pattern pr (CR o2 o1)); eauto.
    assert (~ conflict_pattern pr (CR o3 o2)); eauto.
    assert ([inl l; inr o3; inl l; inr o2; inl l; inr o1; inl l]
            = [inl l; inr o3; inl l; inr o2; inl l; inr o1; inl l]); auto.
    apply H1 in H6.
    + inv H6.
    + apply Infix_cf; auto using Atomic_cf.
      * intro. inv H7. inv H8. cp_cases H7; inv H9. inv H11. inv H16. contradiction.
      * apply Infix_cf; auto using Atomic_cf.
        **intro. inv H7. inv H8. cp_cases H7; inv H9. inv H11. inv H16. contradiction.
        **apply Infix_cf; auto using Atomic_cf.
          intro. inv H7. inv H8. cp_cases H7; inv H9. inv H11. inv H16.
    + apply Infix_cf; auto using Atomic_cf.
      * intro. inv H7. inv H8. cp_cases H7; inv H9. inv H11. contradiction. inv H16.
      * apply Infix_cf; auto using Atomic_cf.
        **intro. inv H7. inv H8. cp_cases H7; inv H9. inv H11. inv H16. contradiction.
        **apply Infix_cf; auto using Atomic_cf.
          intro. inv H7. inv H8. cp_cases H7; inv H9. inv H11. inv H16.
Qed.

End IGrammarBonusTheorems.


(* 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                                                     *)

Require Import List.
Require Import DistributedReferenceCounting.machine2.invariant8.

Unset Standard Proposition Elimination Names.

(**

Here, we study liveness of the algorithm.
We prove

1. If there is a message in a queue, there always exists a transition
   that can consume that message.

2. We can define notion of measure and prove that every transition
   (except copy) decrease the mesure.

3. Then, the idea was to use the notion of well_found relation so
   a to prove that if we prevent copy transitions, we always reach
   a final configuration where no message can be processed.

   There was a bit of 'coding' to use these well-founded relations.

   I needed to talk about configuration which were legal.  So
   I defined a inductive type (a strong dependent sum), legal_config,
   which contains a configuration and a proof that it is legal.

   I then reached two problems, one easy to solve (I think), and
   more difficult.

   a.  I need to convert Z numbers into nat, and I don;t know
       how to do it.
      I had to assume the existence of the following axiom:
     Axiom Z_nat_axiom:
    (x,y:Z)  `0<=x` -> `0<=y` -> `y<x` -> (lt (convert_to_nat y) (convert_to_nat x)).

   b.  Well founded relations must be decidable:
      Definition decidable_relation:=
      [E:Set] [R:E->E->Prop] (x:E){y:E | (R y x)}+{((y:E)~(R y x))}.

     In order to prove that, I had to eliminate H in lemma decidable_no_copy_succ.

     H : (EX t:(class_trans c) | ~(copy_p c t)/\(legal (transition c t)))
          \/((t:(class_trans c))(copy_p c t))

     Unfortunately, H is a propositition and  and the Well founded
     relation is a set.  Therefore, we cannot perform an elimination.

     So I assumed I has axioms ex_rec and or_rec.
     Why was legal defined as a Config->Prop and not a set?
     Why not do everything with set?

  BUT, HAVE I PROVED that all no_copy sequences terminate?

There are still more things to prove:
- what's happening when we introduce copy, can we say
  anything about infinite transitions?

*)

Lemma always_process_messages :
 forall c : Config,
 legal c ->
 forall (s1 s2 : Site) (m : Message),
 first Message (bm c s1 s2) = value Message m ->
 exists t : class_trans c,
   legal (transition c t) /\
   bm (transition c t) s1 s2 = first_out Message (bm c s1 s2).
Proof.
  intros c H.
  generalize H.
  elim H.
  simpl in |- *.
  intros; discriminate.

  intros c0 t H0 H1 H2 s1 s2 m.
  case m.

  (* dec *)

  intro.
  split with (receive_dec (transition c0 t) s1 s2 H3).
  split.
  apply after.
  auto.

  simpl in |- *.
  rewrite collect_here.
  auto.

  (* inc_dec *)

  intros.
  case (eq_site_dec s2 owner); intro.
  rewrite e in H3.
  split with (receive_inc (transition c0 t) s1 s H3).
  split.
  apply after.
  auto.

  simpl in |- *.
  rewrite post_elsewhere.
  rewrite e.
  rewrite collect_here.
  auto.

  left; unfold not in |- *; intro.
  generalize H3; rewrite H4; rewrite empty_q_to_me.
  simpl in |- *.
  intro; discriminate.

  auto.

  generalize (inc_dec_owner3 (transition c0 t) s1 s2 H2 n); intro.
  elim (H4 s).
  apply first_in.
  auto.

  (* copy *)

  elim (decide_rt (transition c0 t) s2); intro.
  case (eq_site_dec s1 owner); intro.
  intro.
  rewrite e in H3.
  split with (receive_copy2 (transition c0 t) s2 a H3).
  split.
  apply after.
  auto.

  simpl in |- *.
  rewrite e; rewrite collect_here; auto.

  intro.
  cut (s2 <> owner).
  intro.
  split with (receive_copy3 (transition c0 t) s1 s2 a n H4 H3).
  split.
  apply after.
  auto.

  simpl in |- *.
  rewrite post_elsewhere.
  rewrite collect_here; auto.
  left. (* (Left; Auto). *)
  unfold not in |- *; intro; generalize H3.
  rewrite H5; rewrite empty_q_to_me.
  simpl in |- *; intro.
  discriminate.

  auto.

  unfold not in |- *; intro; generalize a.
  rewrite H4; rewrite owner_rt_true.
  auto with bool.

  auto.

  intro.
  split with (receive_copy1 (transition c0 t) s1 s2 b H3).
  split.
  apply after; auto.

  simpl in |- *.
  rewrite post_elsewhere.
  rewrite collect_here.
  auto.

  case (eq_site_dec s1 s2); intro.
  generalize H3; rewrite e; rewrite empty_q_to_me.
  simpl in |- *; intro; discriminate.

  auto.

  auto.
Qed.

(* copy predicate *)

Definition copy_p (c : Config) (t : class_trans c) :=
  match t with
  | make_copy s1 s2 h1 h2 => True
  | _ => False
  end.

Section LEGAL_NO_COPY.

(** this inductive definition defines legal_no_copy
   as a predicate over a configuration c, which is accessible
   with legal transitions from a legal config c0,
   without using any copy transition *)

Variable c0 : Config.

Inductive legal_no_copy : Config -> Prop :=
  | no_copy_init : legal c0 -> legal_no_copy c0
  | after_no_copy :
      forall (c : Config) (t : class_trans c),
      ~ copy_p c t -> legal_no_copy c -> legal_no_copy (transition c t).

End LEGAL_NO_COPY.

Lemma legal_no_copy_is_legal :
 forall c c0 : Config, legal_no_copy c0 c -> legal c.
Proof.
  intros.
  elim H.
  auto.
  intros.
  apply after.
  auto.
Qed.

Lemma decide_empty_queue :
 forall (c : Config) (s1 s2 : Site),
 {bm c s1 s2 = empty Message} + {bm c s1 s2 <> empty Message}.
Proof.
  intros.
  elim (bm c s1 s2).
  left; auto.

  simpl in |- *; right.
  discriminate.
Qed.

Definition no_message (c : Config) :=
  forall s1 s2 : Site, In s1 LS -> In s2 LS -> bm c s1 s2 = empty Message.

Lemma decide_no_message :
 forall c : Config, {no_message c} + {~ no_message c}.
Proof.
  intros.
  unfold no_message in |- *.
  simpl in |- *.
  pattern LS at 1 3 in |- *.
  elim LS.
  simpl in |- *.
  left; intros; contradiction.

  simpl in |- *.
  intros.
  elim H.
  clear H.
  elim LS.
  simpl in |- *.
  intro.
  left.
  intros; contradiction.

  intros.
  elim H.
  intros.
  elim (decide_empty_queue c a a0); intro.
  left.
  simpl in |- *.
  intros.
  elim H0; intro.
  elim H1; intro.
  rewrite <- H2; rewrite <- H3; auto.

  apply a2.
  auto.

  auto.

  elim H1; intro.
  apply a1.
  auto.

  simpl in |- *.
  auto.

  apply a2.
  auto.

  auto.

  right.
  unfold not in |- *.
  intro.
  generalize (H0 a a0).
  intro.
  elim b.
  apply H1.
  auto.

  simpl in |- *; auto.

  intro.
  right.
  unfold not in |- *; intro.
  elim b.
  intros.
  apply H0.
  auto.

  simpl in |- *; auto.

  intros.
  apply a1.
  auto.

  simpl in |- *; auto.

  intro.
  right.
  unfold not in |- *; intro.
  elim b.
  intros.
  apply H0.
  auto.

  auto.
Qed.

Lemma decide_exist_non_empty_queue1 :
 forall (c : Config) (a : Site),
 legal c ->
 {(forall s2 : Site, In s2 LS -> bm c a s2 = empty Message)} +
 {~ (forall s2 : Site, In s2 LS -> s2 <> a -> bm c a s2 = empty Message)}.
Proof.
  intros.
  elim LS.
  simpl in |- *.
  left; intros; contradiction.

  simpl in |- *.
  intros.
  elim (decide_empty_queue c a a0); intro.
  case (eq_site_dec a a0); intro.
  elim H0; intro.
  left; intros.
  elim H1; intros.
  rewrite <- H2.
  auto.

  apply a2.
  auto.

  right.
  unfold not in |- *; intros.
  elim b; intros.
  unfold not in |- *.
  apply H1.
  auto.

  intro.
  elim H3; auto.

  elim H0; intros.
  left; intros.
  case (eq_site_dec s2 a0); intro.
  rewrite e; auto.

  elim H1; intro.
  elim n0; auto.

  apply a2; auto.

  right.
  unfold not in |- *; intros.
  elim b; intros.
  unfold not in |- *.
  apply H1.
  auto.

  intro; elim H3; auto.

  elim H0; intros.
  case (eq_site_dec a a0); intro.
  elim b.
  rewrite e.
  rewrite empty_q_to_me.
  auto.

  auto.

  right.
  unfold not in |- *; intros.
  generalize (H1 a0); intro.
  cut (a0 = a0 \/ In a0 l).
  intro.
  generalize (H2 H3); intro.
  decompose [and] H4.
  elim b; auto.

  auto.

  right.
  unfold not in |- *; intro.
  elim b0.
  unfold not in |- *; intros.
  apply H1.
  auto.

  auto.

Qed.

Lemma exist_non_empty_queue :
 forall c : Config,
 legal c ->
 ~ no_message c ->
 exists s1 : Site,
   (exists s2 : Site, s1 <> s2 /\ bm c s1 s2 <> empty Message).

Proof.
  unfold no_message in |- *.
  intro.
  pattern LS at 1 in |- *.
  elim LS.
  simpl in |- *.
  intros.
  elim H0.
  intros; contradiction.

  simpl in |- *.
  intros a l H HLeg.
  elim (decide_exist_non_empty_queue1 c a HLeg); intro.
  intro.
  apply H.
  auto.

  unfold not in |- *; intro.
  elim H0; intros.
  elim H2; intro.
  rewrite <- H4.
  apply a0.
  auto.

  apply H1.
  auto.

  auto.

  intros.
  split with a.
  generalize b.
  elim LS.
  simpl in |- *.
  intro.
  elim b0; intros; contradiction.

  clear H.
  clear H0.
  clear b.
  simpl in |- *.
  intros.
  elim (decide_empty_queue c a a0); intro.
  apply H.
  unfold not in |- *; intros.
  elim b; intros.
  elim H1; intro.
  rewrite <- H3; auto.

  apply H0.
  auto.

  auto.

  case (eq_site_dec a a0); intro.
  elim b0; rewrite e; rewrite empty_q_to_me; auto.

  split with a0.
  split; auto.
Qed.

(**

Define a measure:
  for instance: 2 for inc_dec
                1 for dec.
                2 for rt=true
  Show that any legal_no_copy transition
  decreases the measure.
  By induction, there is a minimum.
*)

Definition termination_count (m : Message) :=
  match m with
  | copy => 5%Z
  | dec => 1%Z
  | inc_dec s3 => 2%Z
  end.

Definition termination_q_count (s1 s2 : Site) (q : queue Message) :=
  reduce Message termination_count q.

Definition termination_q_measure (bm : Bag_of_message) :=
  sigma2_table Site LS LS (queue Message) termination_q_count bm.
Definition termination_rt_count (b : bool) := if b then 2%Z else 0%Z.

Definition termination_rt_measure (t : Site -> bool) :=
  sigma_table Site LS Z (Z_id Site)
    (fun s : Site => termination_rt_count (t s)).

Definition termination_measure (c : Config) :=
  (termination_rt_measure (rt c) + termination_q_measure (bm c))%Z.

Inductive legal_no_copy2 : Config -> Config -> Prop :=
  | no_copy_init2 : forall c : Config, legal c -> legal_no_copy2 c c
  | after_no_copy2 :
      forall (c c0 : Config) (t : class_trans c),
      ~ copy_p c t ->
      legal_no_copy2 c c0 -> legal_no_copy2 (transition c t) c0.

Lemma legal_no_copy_transitive2 :
 forall c0 : Config,
 legal c0 ->
 forall c1 c2 : Config,
 legal_no_copy2 c1 c0 -> legal_no_copy2 c2 c1 -> legal_no_copy2 c2 c0.
Proof.
  intros.
  generalize H0.
  elim H1.
  auto.

  intros.
  apply after_no_copy2.
  auto.

  apply H4.
  auto.
Qed.

Remark add_reduce2 :
 forall x y z a : Z, x = a -> (x + (y + z))%Z = (a + y + z)%Z.
Proof.
intros; omega.
Qed.

Remark add_reduce3 :
 forall x y z a : Z, x = a -> y = z -> (x + y)%Z = (a + z)%Z.
Proof.
intros; omega.
Qed.

Remark add_reduce10 :
 forall x y w z a : Z,
 w = y -> (a > 0)%Z -> (x + (y + (z - a)) < x + (w + z))%Z.
Proof.
intros; omega.
Qed.

Remark add_reduce11 :
 forall x1 x2 y w z a b : Z,
 x1 = x2 ->
 w = y -> (b - a < 0)%Z -> (x1 + b + (y + (z - a)) < x2 + (w + z))%Z.
Proof.
intros; omega.
Qed.

Remark add_reduce12 : forall x y : Z, x = y -> x = (y + 0)%Z.
Proof.
intros; omega.
Qed.

Remark add_reduce13 :
 forall x1 x2 y w z a b : Z,
 x1 = x2 ->
 w = y -> (b + a < 0)%Z -> (x1 + b + (y + (z + a)) < x2 + (w + z))%Z.
Proof.
intros; omega.
Qed.

Remark add_reduce14 :
 forall x1 x2 x3 y w z a b : Z,
 x1 = x2 ->
 w = y -> (b + a < x3)%Z -> (x1 + b + (y + (z + a)) < x2 + x3 + (w + z))%Z.
Proof.
intros; omega.
Qed.

Remark add_reduce15 : forall x y a : Z, (x < y)%Z -> (a + x < a + y)%Z.
Proof.
intros; omega.
Qed.

Remark add_reduce16 :
 forall x1 x2 y b : Z,
 x1 = x2 -> (1 - b < 0)%Z -> (x1 - b + (y + 1) < x2 + y)%Z.
Proof.
intros; omega.
Qed.

Remark add_reduce17 : forall x y a : Z, x = y -> (x + a)%Z = (y + a)%Z.
Proof.
intros; omega.
Qed.

Remark add_reduce18 : forall x y a : Z, x = y -> a = 0%Z -> x = (y + a)%Z.
Proof.
intros; omega.
Qed.

Remark add_reduce19 :
 forall x1 x2 x3 y1 y2 y3 y4 : Z,
 x1 = y1 ->
 (y2 - y4 + (y3 + 1) < x2 + x3)%Z ->
 (y1 + (y2 - y4) + (y3 + 1) < x1 + x2 + x3)%Z.
Proof.
intros; omega.
Qed.

Remark add_reduce22 :
 forall a b x0 y0 x1 x2 x3 y1 y2 y3 y4 : Z,
 x1 = y1 ->
 a = b ->
 (x0 + (y2 - y4) + (y3 + 2) < y0 + x2 + x3)%Z ->
 (a + x0 + (y1 + (y2 - y4) + (y3 + 2)) < b + y0 + (x1 + x2 + x3))%Z.
Proof.
intros; omega.
Qed.

Remark add_reduce23 :
 forall x y : Z, (x >= 0)%Z -> (y >= 0)%Z -> (0 <= x + y)%Z.
Proof.
intros; omega.
Qed.

(*
Section BUT_XY.

Variable Data: Set.
Local Table2:=  Site ->  Site -> Data.
Variable f: Site -> Site -> Data->Z.

Lemma sigma2_sigma2_but_x_y:
 (s0,s1:Site) (t:Table2)
 (sigma2_table Site LS LS Data f t) = `(sigma2_but_table Site eq_site_dec LS LS Data s0 s1 f t)
                                       + (f s0 s1 (t s0 s1))`.
Proof.
  Intro.
  Intro.
  Intro.
  Generalize (finite_site s1).
  Generalize (finite_site s0).
  (Pattern 1 3 5 LS; Elim LS).
  Simpl.
  (Intros; Contradiction).

  Intros.
  Unfold sigma2_table sigma2_but_table.
  Simpl.
  (Case (eq_site_dec a s0); Intro).
  Unfold sigma_table.
  Rewrite (sigma_sigma_but Site a eq_site_dec).
  Rewrite (sigma_sigma_but Site a eq_site_dec) with l:=(cons a l).
  Simpl.
  Case (eq_site_dec a a).
  Intro.
  Case (eq_site_dec a s0).
  Intro.
  Rewrite <- sigma_sigma_but_not_in with x0:=a.
  Rewrite <- sigma_sigma_but_not_in with x0:=a.
  Rewrite (sigma_sigma_but Site s1 eq_site_dec) with l:=LS.
  Unfold sigma_but_table.
  Rewrite e1.
  Unfold Z_id.
  Apply add_reduce2.
  Apply sigma_simpl.
  Intros.
  Case (eq_site_dec x s0).
  Intro.
  (Generalize H0; Rewrite e1).
  Simpl.
  (Case (eq_site_dec s0 s0); Intro).
  Intro.
  (Elim H3; Rewrite <- e2; Auto).

  (Elim n; Auto).

  Intro.
  Auto.

  Auto.

  (Generalize H0; Simpl).
  Rewrite e.
  (Case (eq_site_dec s0 s0); Intro).
  Auto.

  (Elim n; Auto).

  (Generalize H0; Simpl).
  (Case (eq_site_dec s0 a); Intro).
  (Rewrite e; Auto).

  (Elim n; Auto).

  Intro.
  (Elim n; Auto).

  Intro.
  (Elim n; Auto).

  (Rewrite e; Auto).
  (Generalize H0; Rewrite e; Auto).

  (Generalize H0; Rewrite e).
  Auto.

  (Unfold sigma_table; Simpl).
  Generalize H.
  Unfold sigma2_table.
  Unfold sigma_table.
  Intro.
  Rewrite H2.
  (Unfold Z_id; Simpl).
  (Case (eq_site_dec a s0); Intro).
  (Elim n; Auto).

  Unfold sigma2_but_table.
  Unfold sigma_table.
  Unfold Z_id.
  Omega.

  (Generalize H0; Simpl).
  (Case (eq_site_dec s0 a); Intro).
  (Elim n; Auto).

  Auto.

  Auto.

Save.

Lemma sigma2_but_simpl : (s0,s1:Site) (t:Table2) (f,g:Site->Site->Data->Z)
 ((x,y:Site) ~((x=s0)/\(y=s1))->(f x y (t x y))=(g x y (t x y)))->
  (sigma2_but_table Site eq_site_dec LS LS Data s0 s1 f t)
  =
  (sigma2_but_table Site eq_site_dec LS LS Data s0 s1 g t ).
Proof.
  Intros.
  Generalize (finite_site s1).
  Generalize (finite_site s0).
  (Pattern 1 3 5 LS; Elim LS).
  Simpl.
  (Intros; Contradiction).

  Simpl.
  Intros a l.
  (Case (eq_site_dec s0 a); Intro).
  Rewrite e.
  Simpl.
  Intros.
  Unfold sigma2_but_table.
  (Unfold sigma_table; Simpl).
  Unfold Z_id.
  (Case (eq_site_dec a a); Intro).
  Apply add_reduce3.
  Generalize H2.
  (Elim LS; Simpl).
  (Intro; Contradiction).

  Intros.
  (Unfold sigma_but_table; Simpl).
  Generalize H4.
  (Case (eq_site_dec a0 s1); Intro).
  Rewrite e1.
  (Case (eq_site_dec s1 s1); Intros).
  Rewrite <- (sigma_sigma_but_not_in Site s1 eq_site_dec).
  Rewrite <- (sigma_sigma_but_not_in Site s1 eq_site_dec).
  Apply sigma_simpl.
  Intros.
  Apply H.
  (Unfold not; Intro).
  Decompose [and] H7.
  (Elim H5; Rewrite <- H10; Auto).

  Auto.

  Exact H5.

  (Elim n; Auto).

  (Case (eq_site_dec s1 a0); Intro).
  (Elim n; Auto).

  Intros.
  Apply add_reduce3.
  Apply H.
  (Unfold not; Intro).
  Decompose [and] H6.
  (Elim n; Auto).

  Generalize H3.
  Unfold sigma_but_table.
  Auto.

  Apply sigma_simpl.
  Intros.
  (Case (eq_site_dec x a); Intro).
  (Elim H1; Rewrite <- e1; Auto).

  Apply sigma_simpl.
  Intros.
  Apply H.
  (Unfold not; Intro).
  (Decompose [and] H5; Elim n; Rewrite <- e; Auto).

  (Elim n; Auto).

  Unfold sigma2_but_table.
  (Unfold sigma_table; Simpl).
  Intros.
  (Case (eq_site_dec a s0); Intro).
  (Elim n; Auto).

  Rewrite H0.
  Apply add_reduce3.
  Unfold Z_id.
  Apply sigma_simpl.
  Intros.
  Apply H.
  (Unfold not; Intro; Elim n0).
  (Decompose [and] H4; Auto).

  Auto.

  Auto.

  Auto.

Save.

(* Interestingly, the proof of the following Lemma is exactly the same
as the proof of the previous lemma *)

Lemma sigma2_but_simpl2 : (s0,s1:Site) (t1,t2:Table2) (f:Site->Site->Data->Z)
 ((x,y:Site) ~((x=s0)/\(y=s1))->(f x y (t1 x y))=(f x y (t2 x y)))->
  (sigma2_but_table Site eq_site_dec LS LS Data s0 s1 f t1)
  =
  (sigma2_but_table Site eq_site_dec LS LS Data s0 s1 f t2 ).
Proof.
  Intros.
  Generalize (finite_site s1).
  Generalize (finite_site s0).
  (Pattern 1 3 5 LS; Elim LS).
  Simpl.
  (Intros; Contradiction).

  Simpl.
  Intros a l.
  (Case (eq_site_dec s0 a); Intro).
  Rewrite e.
  Simpl.
  Intros.
  Unfold sigma2_but_table.
  (Unfold sigma_table; Simpl).
  Unfold Z_id.
  (Case (eq_site_dec a a); Intro).
  Apply add_reduce3.
  Generalize H2.
  (Elim LS; Simpl).
  (Intro; Contradiction).

  Intros.
  (Unfold sigma_but_table; Simpl).
  Generalize H4.
  (Case (eq_site_dec a0 s1); Intro).
  Rewrite e1.
  (Case (eq_site_dec s1 s1); Intros).
  Rewrite <- (sigma_sigma_but_not_in Site s1 eq_site_dec).
  Rewrite <- (sigma_sigma_but_not_in Site s1 eq_site_dec).
  Apply sigma_simpl.
  Intros.
  Apply H.
  (Unfold not; Intro).
  Decompose [and] H7.
  (Elim H5; Rewrite <- H10; Auto).

  Auto.

  Exact H5.

  (Elim n; Auto).

  (Case (eq_site_dec s1 a0); Intro).
  (Elim n; Auto).

  Intros.
  Apply add_reduce3.
  Apply H.
  (Unfold not; Intro).
  Decompose [and] H6.
  (Elim n; Auto).

  Generalize H3.
  Unfold sigma_but_table.
  Auto.

  Apply sigma_simpl.
  Intros.
  (Case (eq_site_dec x a); Intro).
  (Elim H1; Rewrite <- e1; Auto).

  Apply sigma_simpl.
  Intros.
  Apply H.
  (Unfold not; Intro).
  (Decompose [and] H5; Elim n; Rewrite <- e; Auto).

  (Elim n; Auto).

  Unfold sigma2_but_table.
  (Unfold sigma_table; Simpl).
  Intros.
  (Case (eq_site_dec a s0); Intro).
  (Elim n; Auto).

  Rewrite H0.
  Apply add_reduce3.
  Unfold Z_id.
  Apply sigma_simpl.
  Intros.
  Apply H.
  (Unfold not; Intro; Elim n0).
  (Decompose [and] H4; Auto).

  Auto.

  Auto.

  Auto.
Save.

End BUT_XY.

*)

(* another way of defining sigma_but:

   On the one hand, it is less convenient, because the functional
   argument is changed, which later, if we use sigma2_simpl, will
   imply a tedious case analysis.

   On the other hand, it is more convenient, because I can
   apply sigma2_but several times, there are transformed into
   a sigma2_table.
*)
(*
Lemma new_sigma2_sigma2_but_x_y:
 (s0,s1:Site)(Data:Set) (f:Site->Site->Data->Z)
 (t:Site ->  Site -> Data)
 (sigma2_table Site LS LS Data f t) = `(new_sigma2_but_table Site eq_site_dec LS LS Data s0 s1 f t)
                                       + (f s0 s1 (t s0 s1))`.
Proof.
  Intros.
  Unfold new_sigma2_but_table.
  Rewrite sigma2_sigma2_but_x_y with s0:=s0 s1:=s1.
  Apply add_reduce17.
  Rewrite sigma2_sigma2_but_x_y with s0:=s0 s1:=s1.
  Apply add_reduce18.
  Apply sigma2_but_simpl.
  Intros.
  (Case (eq_site_dec x s0); Intro).
  (Case (eq_site_dec y s1); Intro).
  (Elim H; Auto).
  Auto.
  Auto.
  Rewrite case_eq.
  Rewrite case_eq.
  Auto.
Save.

*)

Lemma termination_measure_decreases :
 forall (c : Config) (t : class_trans c),
 legal c ->
 ~ copy_p c t ->
 (termination_measure (transition c t) < termination_measure c)%Z.

Proof.
  simple induction t; simpl in |- *;
   unfold termination_measure, termination_rt_measure, termination_q_measure
    in |- *; simpl in |- *; intros.

  (* 1 *)

  elim H0; auto.

  (* 2 *)

  rewrite
   sigma2_sigma2_but_x_y
                         with
                         (s0 := s1)
                        (s1 := s2)
                        (eq_site_dec := eq_site_dec).
  rewrite collect_here.
  unfold termination_q_count in |- *.
  rewrite reduce_first_out with (m := dec).
  rewrite
   sigma2_sigma2_but_x_y
                         with
                         (s0 := s1)
                        (s1 := s2)
                        (eq_site_dec := eq_site_dec).
  apply add_reduce10.
  apply sigma2_but_simpl2.
  intros.
  rewrite collect_elsewhere.
  auto.

  case (eq_queue_dec s1 x s2 y); intro.
  elim H1; auto.
  decompose [and] a; split; auto.

  auto.
  apply finite_site.
  apply finite_site.

  unfold termination_count in |- *; simpl in |- *.
  omega.
  apply finite_site.
  apply finite_site.

  auto.
  apply finite_site.
  apply finite_site.

  (* 3 *)

  apply add_reduce15.
  rewrite
   new_sigma2_sigma2_but_x_y
                             with
                             (s0 := owner)
                            (s1 := s3)
                            (eq_site_dec := eq_site_dec).
  rewrite
   new_sigma2_sigma2_but_x_y
                             with
                             (s0 := owner)
                            (s1 := s3)
                            (eq_site_dec := eq_site_dec).
  unfold new_sigma2_but_table in |- *.
  rewrite post_here.
  unfold termination_q_count in |- *; simpl in |- *.
  rewrite collect_elsewhere.
  rewrite
   new_sigma2_sigma2_but_x_y
                             with
                             (s0 := s1)
                            (s1 := owner)
                            (eq_site_dec := eq_site_dec).
  rewrite
   new_sigma2_sigma2_but_x_y
                             with
                             (s0 := s1)
                            (s1 := owner)
                            (eq_site_dec := eq_site_dec).
  unfold new_sigma2_but_table in |- *.
  case (eq_site_dec s1 owner); intro.
  generalize e; rewrite e0.
  rewrite empty_q_to_me; simpl in |- *.
  intro; discriminate.
  auto.
  rewrite post_elsewhere.
  rewrite collect_here.
  rewrite reduce_first_out with (m := inc_dec s3).
  apply add_reduce19.
  unfold sigma2_table in |- *.
  apply sigma_table_simpl.
  apply funct_eq.
  intro.
  unfold sigma_table in |- *.
  apply sigma_simpl.
  intros.
  case (eq_site_dec e0 s1); intro.
  case (eq_site_dec x owner); intro.
  auto.
  case (eq_site_dec e0 owner); intro.
  case (eq_site_dec x s3); intro.
  auto.
  rewrite post_elsewhere.
  rewrite collect_elsewhere; auto.
  auto.
  rewrite post_elsewhere.
  rewrite collect_elsewhere; auto.
  auto.
  case (eq_site_dec e0 owner); intro.
  case (eq_site_dec x s3); intro.
  auto.
  rewrite post_elsewhere.
  rewrite collect_elsewhere; auto.
  auto.
  rewrite post_elsewhere.
  rewrite collect_elsewhere; auto.
  auto.
  unfold termination_count in |- *; simpl in |- *.
  omega.
  auto.
  auto.
  apply finite_site.
  apply finite_site.
  apply finite_site.
  apply finite_site.
  left; unfold not in |- *; intro.
  generalize e; rewrite H1; rewrite empty_q_to_me.
  simpl in |- *; intro; discriminate.
  auto.
  apply finite_site.
  apply finite_site.
  apply finite_site.
  apply finite_site.

  (* 4 *)

  apply add_reduce15.
  rewrite
   new_sigma2_sigma2_but_x_y
                             with
                             (s0 := s2)
                            (s1 := s1)
                            (eq_site_dec := eq_site_dec).
  rewrite
   new_sigma2_sigma2_but_x_y
                             with
                             (s0 := s2)
                            (s1 := s1)
                            (eq_site_dec := eq_site_dec).
  unfold new_sigma2_but_table in |- *.
  rewrite post_here.
  unfold termination_q_count in |- *; simpl in |- *.
  rewrite collect_elsewhere.
  rewrite
   new_sigma2_sigma2_but_x_y
                             with
                             (s0 := s1)
                            (s1 := s2)
                            (eq_site_dec := eq_site_dec).
  rewrite
   new_sigma2_sigma2_but_x_y
                             with
                             (s0 := s1)
                            (s1 := s2)
                            (eq_site_dec := eq_site_dec).
  unfold new_sigma2_but_table in |- *.
  case (eq_site_dec s1 s2); intro.
  generalize e0; rewrite e1; rewrite empty_q_to_me; simpl in |- *.
  intro; discriminate.
  auto.
  rewrite post_elsewhere.
  rewrite collect_here.
  rewrite reduce_first_out with (m := copy).
  apply add_reduce19.
  unfold sigma2_table in |- *.
  apply sigma_table_simpl.
  apply funct_eq.
  intro.
  unfold sigma_table in |- *.
  apply sigma_simpl.
  intros.
  case (eq_site_dec e1 s1); intro.
  case (eq_site_dec x s2); intro.
  auto.
  case (eq_site_dec e1 s2); intro.
  case (eq_site_dec x s1); intro.
  auto.
  rewrite post_elsewhere.
  rewrite collect_elsewhere; auto.
  auto.
  rewrite post_elsewhere.
  rewrite collect_elsewhere; auto.
  auto.
  case (eq_site_dec e1 s2); intro.
  case (eq_site_dec x s1); intro.
  auto.
  rewrite post_elsewhere.
  rewrite collect_elsewhere; auto.
  auto.
  rewrite post_elsewhere.
  rewrite collect_elsewhere; auto.
  auto.
  unfold termination_count in |- *; simpl in |- *.
  omega.
  auto.
  auto.
  apply finite_site.
  apply finite_site.
  apply finite_site.
  apply finite_site.
  left; unfold not in |- *; intro.
  generalize e0; rewrite H1; rewrite empty_q_to_me; simpl in |- *.
  intro; discriminate.
  auto.
  apply finite_site.
  apply finite_site.
  apply finite_site.
  apply finite_site.

  (* 5 *)

  rewrite
   sigma2_sigma2_but_x_y
                         with
                         (s0 := owner)
                        (s1 := s2)
                        (eq_site_dec := eq_site_dec).
  rewrite collect_here.
  unfold termination_q_count in |- *.
  rewrite reduce_first_out with (m := copy).
  unfold sigma_table in |- *.
  rewrite (sigma_sigma_but Site s2 eq_site_dec).
  unfold Z_id in |- *.
  rewrite
   sigma2_sigma2_but_x_y
                         with
                         (s0 := owner)
                        (s1 := s2)
                        (eq_site_dec := eq_site_dec).
  apply add_reduce11.
  rewrite (sigma_sigma_but Site s2 eq_site_dec).
  rewrite e; unfold termination_rt_count in |- *.
  simpl in |- *.
  apply add_reduce12.
  apply sigma_but_simpl.
  intros.
  unfold Set_rec_table in |- *.
  cut (change_site bool (rt c) s2 true s = rt c s).
  intro.
  rewrite H2.
  auto.

  rewrite other_site.
  auto.
  auto.
  apply finite_site.
  apply sigma2_but_simpl2.
  intros.
  case (eq_queue_dec owner x s2 y); intro.
  elim H1; decompose [and] a.
  split; auto.
  rewrite collect_elsewhere.
  auto.
  auto.
 apply finite_site.
 apply finite_site.
  unfold termination_rt_count in |- *; unfold Set_rec_table in |- *.
  unfold termination_count in |- *; simpl in |- *.
  cut (change_site bool (rt c) s2 true s2 = true).
  intro.
  rewrite H1.
  omega.
  rewrite that_site; auto.
  apply finite_site.
  apply finite_site.
  apply finite_site.
  auto.
  apply finite_site.
  apply finite_site.

  (* 6 *)

  unfold sigma_table in |- *.
  rewrite (sigma_sigma_but Site s2 eq_site_dec).
  unfold Z_id in |- *.
  rewrite
   new_sigma2_sigma2_but_x_y
                             with
                             (s0 := s2)
                            (s1 := owner)
                            (eq_site_dec := eq_site_dec).
  rewrite
   new_sigma2_sigma2_but_x_y
                             with
                             (s0 := s2)
                            (s1 := owner)
                            (eq_site_dec := eq_site_dec).
  unfold new_sigma2_but_table in |- *.
  rewrite post_here.
  unfold termination_q_count in |- *; simpl in |- *.
  rewrite collect_elsewhere.
  rewrite
   new_sigma2_sigma2_but_x_y
                             with
                             (s0 := s1)
                            (s1 := s2)
                            (eq_site_dec := eq_site_dec).
  rewrite
   new_sigma2_sigma2_but_x_y
                             with
                             (s0 := s1)
                            (s1 := s2)
                            (eq_site_dec := eq_site_dec).
  unfold new_sigma2_but_table in |- *.
  case (eq_site_dec s1 s2); intro.
  generalize e0; rewrite e1; rewrite empty_q_to_me; simpl in |- *.
  intro; discriminate.
  auto.
  rewrite post_elsewhere.
  rewrite collect_here.
  rewrite reduce_first_out with (m := copy).
  rewrite (sigma_sigma_but Site s2 eq_site_dec).
  apply add_reduce22.
  unfold sigma2_table in |- *.
  apply sigma_table_simpl.
  apply funct_eq.
  intro.
  unfold sigma_table in |- *.
  apply sigma_simpl.
  intros.
  case (eq_site_dec e1 s1); intro.
  case (eq_site_dec x s2); intro.
  auto.
  case (eq_site_dec e1 s2); intro.
  case (eq_site_dec x owner); intro.
  auto.
  rewrite post_elsewhere.
  rewrite collect_elsewhere; auto.
  auto.
  rewrite post_elsewhere.
  rewrite collect_elsewhere; auto.
  auto.
  case (eq_site_dec e1 s2); intro.
  case (eq_site_dec x owner); intro.
  auto.
  rewrite post_elsewhere.
  rewrite collect_elsewhere; auto.
  auto.
  rewrite post_elsewhere.
  rewrite collect_elsewhere; auto.
  auto.
  apply sigma_but_simpl.
  intros.
  unfold Set_rec_table in |- *; rewrite other_site.
  auto.
  auto.
  unfold Set_rec_table in |- *; rewrite that_site.
  rewrite e.
  unfold termination_rt_count in |- *.
  cut (termination_count copy > 4)%Z.
  intro.
  omega.
  simpl in |- *.
  omega.
  apply finite_site.
  auto.
  auto.
  apply finite_site.
  apply finite_site.
  apply finite_site.
  apply finite_site.
  left; unfold not in |- *; intro; generalize e0.
  rewrite H1; rewrite empty_q_to_me.
  simpl in |- *; intro; discriminate.
  auto.
  apply finite_site.
  apply finite_site.
  apply finite_site.
  apply finite_site.
  apply finite_site.

  (* 7 *)

  rewrite
   sigma2_sigma2_but_x_y
                         with
                         (s0 := s)
                        (s1 := owner)
                        (eq_site_dec := eq_site_dec).
  rewrite post_here.
  rewrite
   sigma2_sigma2_but_x_y
                         with
                         (s0 := s)
                        (s1 := owner)
                        (eq_site_dec := eq_site_dec).
  unfold termination_q_count in |- *.
  simpl in |- *.
  unfold sigma_table in |- *.
  rewrite (sigma_sigma_but Site s eq_site_dec).
  unfold Z_id in |- *.
  unfold sigma_table in |- *.
  rewrite (sigma_sigma_but Site s eq_site_dec).
  apply add_reduce14.
  apply sigma_but_simpl.
  intros.
  unfold Reset_rec_table in |- *.
  rewrite other_site.
  auto.
  auto.
  apply sigma2_but_simpl2.
  intros.
  case (eq_queue_dec s x owner y); intro.
  elim H1; decompose [and] a.
  split; auto.
  rewrite post_elsewhere; auto.
  apply finite_site.
  apply finite_site.
 unfold Reset_rec_table in |- *; rewrite that_site.
  rewrite e0.
  unfold termination_rt_count in |- *; simpl in |- *.
  omega.
  apply finite_site.
  apply finite_site.
  apply finite_site.
  apply finite_site.
  apply finite_site.
  apply finite_site.
Qed.

Lemma termination_measure_positive :
 forall c : Config, (0 <= termination_measure c)%Z.
Proof.
  unfold termination_measure in |- *.
  unfold termination_rt_measure, termination_q_measure in |- *.
  intros.
  apply add_reduce23.
  unfold sigma_table in |- *.
  apply sigma_pos.
  intros.
  unfold Z_id in |- *.
  unfold termination_rt_count in |- *.
  case (rt c x_).
  omega.

  omega.

  unfold sigma2_table in |- *.
  unfold sigma_table in |- *.
  apply sigma_pos.
  intros.
  unfold Z_id in |- *.
  apply sigma_pos.
  intros.
  unfold termination_q_count in |- *.
  apply reduce_positive_or_null.
  intros.
  unfold termination_count in |- *.
  case a.
  omega.

  intro; omega.

  omega.
Qed.

Definition no_rt (c : Config) :=
  forall s1 : Site, In s1 LS -> s1 <> owner -> rt c s1 = false.

Lemma decide_no_rt :
 forall c : Config,
 {no_rt c} + {(exists s1 : Site, s1 <> owner /\ rt c s1 = true)}.
Proof.
  intros.
  unfold no_rt in |- *.
  elim LS.
  simpl in |- *.
  left; contradiction.

  intros.
  case (eq_site_dec a owner); intro.
  elim H; intro.
  left.
  intros.
  generalize H0; simpl in |- *.
  case (eq_site_dec s1 a); intro.
  elim H1; rewrite e0; auto.

  intro.
  elim H2; auto.
  intro; elim n; auto.

  right; auto.

  elim (decide_rt c a); intro.
  elim H; intro.
  left; intros.
  case (eq_site_dec s1 a); intro.
  rewrite e; auto.

  apply a1.
  generalize H0; simpl in |- *; intro.
  elim H2; intro; auto.
  elim n0; auto.

  auto.

  right; auto.

  right.
  split with a.
  auto.
Qed.

(** to be complete, we might represent explicitly a local gc!
and we could try to prove something like this.
 If there is a s1, it means that the gc is has kicked in

Variable local_gc: Config -> Site -> bool.

Lemma decide_no_rt_gc:
  (c:Config)
   {(s1:Site) (In s1 LS) -> ~(s1=owner) ->  (rt c s1)=true -> (local_gc c s1)=false}
   +
   {(EX s1:Site |  (In s1 LS) -> ~(s1=owner) /\ (rt c s1)=true /\ (local_gc c s1)=true)}.

*)

Lemma blocked_config :
 forall c : Config,
 legal c ->
 no_message c -> no_rt c -> ~ (exists t : class_trans c, ~ copy_p c t).
Proof.
  unfold no_message, no_rt in |- *.
  intros.
  unfold not in |- *; intro.
  elim H2.
  simple induction x; simpl in |- *; intros.
  apply H3; auto.
  generalize e.
  rewrite H0.
  simpl in |- *.
  intro; discriminate.
  apply in_s_LS.
  apply in_s_LS.
  generalize e.
  rewrite H0.
  simpl in |- *.
  intro; discriminate.
  apply in_s_LS.
  apply in_s_LS.
  generalize e0.
  rewrite H0.
  simpl in |- *.
  intro; discriminate.
  apply in_s_LS.
  apply in_s_LS.
  generalize e0.
  rewrite H0.
  simpl in |- *.
  intro; discriminate.
  apply in_s_LS.
  apply in_s_LS.
  generalize e0.
  rewrite H0.
  simpl in |- *.
  intro; discriminate.
  apply in_s_LS.
  apply in_s_LS.
  generalize e0; rewrite H1.
  discriminate.
  apply in_s_LS.
  auto.
Qed.

Lemma blocked_config2 :
 forall c : Config,
 legal c -> no_message c -> no_rt c -> forall t : class_trans c, copy_p c t.
Proof.
  unfold no_message, no_rt in |- *.
  simple induction t; simpl in |- *; intros; auto.
  generalize e.
  rewrite H0.
  simpl in |- *.
  intro; discriminate.
  apply in_s_LS.
  apply in_s_LS.
  generalize e.
  rewrite H0.
  simpl in |- *.
  intro; discriminate.
  apply in_s_LS.
  apply in_s_LS.
  generalize e0.
  rewrite H0.
  simpl in |- *.
  intro; discriminate.
  apply in_s_LS.
  apply in_s_LS.
  generalize e0.
  rewrite H0.
  simpl in |- *.
  intro; discriminate.
  apply in_s_LS.
  apply in_s_LS.
  generalize e0.
  rewrite H0.
  simpl in |- *.
  intro; discriminate.
  apply in_s_LS.
  apply in_s_LS.
  generalize e0; rewrite H1.
  discriminate.
  apply in_s_LS.
  auto.
Qed.

Section LOGIC.
Variable U : Set.

Lemma ex_not_not_all :
 forall P : U -> Prop, (exists n : U, ~ P n) -> ~ (forall n : U, P n).
Proof.
unfold not in |- *; intros P exnot allP.
elim exnot; auto.
Qed.

Lemma ex_not_not_all2 :
 forall P : U -> Prop, (exists n : U, P n) -> ~ (forall n : U, ~ P n).
Proof.
  unfold not in |- *; intros P exnot allP.
  elim exnot; auto.
Qed.

Lemma PNNP : forall p : Prop, p -> ~ ~ p.
Proof.
intros.
auto.
Qed.

End LOGIC.

Lemma sigma_f_null :
 forall (E : Set) (f : E -> Z) (l : list E),
 (forall x_ : E, f x_ = 0%Z) -> sigma E l f = 0%Z.
Proof.
 intros; elim l; simpl in |- *.
 omega.

 intros; generalize (H a); omega.
Qed.

Lemma null_st :
 forall (c0 : Config) (s0 : Site),
 legal c0 -> s0 <> owner -> no_message c0 -> st c0 s0 = 0%Z.
Proof.
  intros.
  rewrite invariant2.
  unfold sigma_rooted in |- *.
  unfold sigma2_table in |- *.
  unfold sigma_table in |- *.
  unfold Z_id in |- *.
  apply sigma_f_null.
  intros.
  apply sigma_f_null.
  intros.
  generalize H1; unfold no_message in |- *.
  intro.
  rewrite H2.
  simpl in |- *.
  auto.
  apply in_s_LS.
  apply in_s_LS.
  auto.
  auto.
Qed.

Lemma not_empty_implies_last :
 forall (E : Set) (q : queue E),
 q <> empty E -> exists x : E, first E q = value E x.
Proof.
  intro.
  simple induction q.
  auto.
  intros.
  elim H; auto.
  intros d q0.
  case q0.
  simpl in |- *.
  intros.
  split with d.
  auto.
  simpl in |- *.
  intros.
  apply H.
  discriminate.
Qed.

Lemma different_queue1 :
 forall (E : Set) (q : queue E) (m : E), input E m q <> first_out E q.
Proof.
  intro.
  simple induction q.
  simpl in |- *.
  intros.
  discriminate.
  intros.
  simpl in |- *.
  generalize H.
  case q0.
  simpl in |- *.
  intros.
  discriminate.
  intros.
  cut (input E d (input E e q1) <> first_out E (input E e q1)).
  intro.
  injection.
  intros.
  elim H1; auto.
  auto.
Qed.

Lemma different_queue2 :
 forall (E : Set) (q : queue E) (m : E),
 first E q = value E m -> q <> first_out E q.
Proof.
  intro.
  simple induction q.
  simpl in |- *; intros; discriminate.

  intro; intro.
  case q0.
  simpl in |- *.
  intros.
  discriminate.

  intros.
  cut
   (first_out E (input E d (input E e q1)) =
    input E d (first_out E (input E e q1))).
  intro.
  rewrite H1.
  injection.
  generalize H; unfold not in |- *; intro.
  intro.
  apply (H3 m).
  auto.

  auto.

  simpl in |- *; auto.
Qed.

(** decide if there is a legal successor
   Ideally, I should have introduce a decidable predicate
   to decide if Delete transitions were permitted. *)

Lemma decide_no_copy_successor :
 forall c : Config,
 legal c ->
 (exists t : class_trans c, ~ copy_p c t /\ legal (transition c t)) \/
 (forall t : class_trans c, copy_p c t).

Proof.
  intros.
  elim (decide_no_message c); intro.
  elim (decide_no_rt c); intro.
  right.
  intros.
  apply blocked_config2.
  auto.
  auto.
  auto.
  elim b.
  intros.
  decompose [and] H0.
  generalize (null_st c x H H1 a).
  intro.
  left.
  split with (delete_entry c x H3 H2 H1).
  split.
  unfold copy_p in |- *.
  unfold not in |- *; contradiction.

  apply after.
  auto.

  elim (exist_non_empty_queue c H b).
  intros.
  elim H0.
  intros.
  decompose [and] H1.
  generalize (not_empty_implies_last Message (bm c x x0) H3).
  intro.
  elim H4.
  intros.
  generalize (always_process_messages c H x x0 x1 H5).
  intro.
  elim H6.
  intros.
  decompose [and] H7.
  left.
  split with x2.
  split.
  unfold copy_p in |- *.
  generalize H9.
  case x2.
  simpl in |- *.
  intros.
  generalize H10.
  case (eq_queue_dec s1 x s2 x0); intro.
  decompose [and] a0.
  rewrite H11; rewrite H12.
  rewrite post_here.
  generalize (different_queue1 Message (bm c x x0) copy).
  intros.
  elim H11; auto.

  rewrite post_elsewhere.
  generalize (different_queue2 Message (bm c x x0) x1 H5).
  intros.
  elim H11; auto.

  auto.

  intros; unfold not in |- *; auto.

  intros; unfold not in |- *; auto.

  intros; unfold not in |- *; auto.

  intros; unfold not in |- *; auto.

  intros; unfold not in |- *; auto.

  intros; unfold not in |- *; auto.

  auto.
Qed.

Section ROOT_SUCC.

Inductive legal_as_set : Config -> Set :=
    intro_leg : forall c : Config, legal c -> legal_as_set c.

Definition legal_config := sigS legal_as_set.

Definition get_c (lc : sigS legal_as_set) :=
  match lc with
  | existS c L => c
  end.

(* WATCH OUT: successor is first argument, predecessor is second *)
Definition no_copy_succ (lc2 lc1 : legal_config) :=
  exists t : class_trans (get_c lc1),
    get_c lc2 = transition (get_c lc1) t /\ ~ copy_p (get_c lc1) t.

Definition convert_to_nat (n : Z) :=
  match n with
  | Zpos x => nat_of_P x
  | _ => 0
  end.

Definition no_copy_measure (lc : legal_config) :=
  match lc with
  | existS c _ => convert_to_nat (termination_measure c)
  end.

Definition decidable_relation (E : Set) (R : E -> E -> Prop) :=
  forall x : E, {y : E | R y x} + {(forall y : E, ~ R y x)}.

Axiom
  or_rec : forall (A B : Prop) (P : Set), (A -> P) -> (B -> P) -> A \/ B -> P.
Axiom
  ex_rec :
    forall (A : Set) (P : A -> Prop) (P0 : Set),
    (forall x : A, P x -> P0) -> ex P -> P0.

Lemma decidable_no_copy_succ : decidable_relation legal_config no_copy_succ.
Proof.
  unfold decidable_relation in |- *.
  intro.
  elim x.
  intros.
  elim p.
  intros.
  generalize (decide_no_copy_successor c l).
  intro.
  elim H.
  intro.
  elim H0.
  intros.
  left.
  decompose [and] H1.
  split
   with
     (existS legal_as_set (transition c x1) (intro_leg (transition c x1) H3)).
  unfold no_copy_succ in |- *.
  unfold get_c in |- *.
  split with x1.
  split; auto.
  intro.
  right.
  intro.
  unfold no_copy_succ in |- *.
  unfold get_c in |- *.
  unfold not in |- *; intro.
  elim H1.
  intros.
  decompose [and] H2.
  apply H4.
  auto.
Qed.

Definition relation_decreases (E : Set) (R : E -> E -> Prop)
  (f : E -> nat) := forall x y : E, R x y -> f x < f y.

Lemma Z_nat_business :
 forall x y : positive, nat_of_P y < nat_of_P x -> (Zpos y < Zpos x)%Z.
Proof.
  intros.
  unfold Zlt in |- *.
  unfold Zcompare in |- *.
  apply nat_of_P_lt_Lt_compare_complement_morphism.
  auto.
Qed.

Lemma Z_nat_business1 :
 forall x y : positive, (Zpos y < Zpos x)%Z -> nat_of_P y < nat_of_P x.
Proof.
  intros.
  apply nat_of_P_lt_Lt_compare_morphism.
  generalize H.
  unfold Zlt in |- *.
  unfold Zcompare in |- *.
  auto.
Qed.

Axiom
  Z_nat_axiom :
    forall x y : Z,
    (0 <= x)%Z ->
    (0 <= y)%Z -> (y < x)%Z -> convert_to_nat y < convert_to_nat x.

(*  What I want to prove.
Lemma Z_nat_business2:
 (x:Z)  `0<=x` -> `0<x` -> (lt (0) (convert_to_nat `x`)).

Lemma Z_nat_business3:
 (x,y:Z)  `0<=x` -> `0<=y` -> `y<x` -> (lt (convert y) (convert x)).

Lemma Z_nat_business4:
 (x,y:positive)  (lt (convert y) (convert x)) -> (lt (convert y) (convert x)).

*)
(* use Theorem bij1 : (m:nat) (convert (anti_convert m)) = (S m). *)

Lemma no_copy_succ_decreases :
 relation_decreases legal_config no_copy_succ no_copy_measure.
Proof.
  unfold relation_decreases in |- *.
  intro.
  elim x.
  intro.
  intro.
  elim p.
  intro; intro; intro.
  elim y.
  intro; intro.
  elim p0.
  intro; intro.
  unfold no_copy_succ in |- *.
  unfold get_c in |- *.
  intro.
  unfold no_copy_measure in |- *.
  elim H.
  intros.
  decompose [and] H0.
  generalize (termination_measure_decreases c0 x2 l0 H2).
  rewrite <- H1.
  intro.
  apply Z_nat_axiom.
  apply termination_measure_positive.
  apply termination_measure_positive.
  auto.
Qed.

Definition last_successor :=
  root legal_config no_copy_measure no_copy_succ decidable_no_copy_succ
    no_copy_succ_decreases.

Lemma last_successor_is_last :
 forall y0 y : legal_config, ~ no_copy_succ y (last_successor y0).
Proof.
  intros.
  unfold last_successor in |- *.
  apply root_no_R.
Qed.

(* QUESTION:  What does the following lemma mean?
  That there is a given transition sequence that terminates
  or that all of them terminate?
*)

Lemma last_successor_has_no_message :
 forall y0 : legal_config, no_message (get_c (last_successor y0)).
Proof.
  intros.
  generalize (last_successor_is_last y0).
  intro.
  elim (decide_no_message (get_c (last_successor y0))).
  auto.

  generalize H.
  elim (last_successor y0).
  simpl in |- *.
  intro; intro.
  elim p.
  intros.
  generalize (exist_non_empty_queue c l b).
  intro.
  elim H1; intro.
  intro.
  elim H2.
  intro.
  intros.
  decompose [and] H3.
  generalize (not_empty_implies_last Message (bm c x0 x1) H5); intro.
  elim H6.
  intros.
  generalize (always_process_messages c l x0 x1 x2 H7); intro.
  elim H8; intro.
  intro.
  decompose [and] H9.
  elim
   (H0
      (existS legal_as_set (transition c x3)
         (intro_leg (transition c x3) H10))).
  unfold no_copy_succ in |- *.
  unfold get_c in |- *.
  split with x3.
  split.
  auto.

  unfold copy_p in |- *.
  generalize H11.
  elim x3; simpl in |- *; intros.
  generalize H12.
  case (eq_queue_dec s1 x0 s2 x1); intro.
  decompose [and] a0.
  rewrite H13; rewrite H14.
  rewrite post_here.
  generalize (different_queue1 Message (bm c x0 x1) copy).
  intros.
  elim H13; auto.
  rewrite post_elsewhere.
  generalize (different_queue2 Message (bm c x0 x1) x2 H7).
  intros.
  elim H13; auto.
  auto.
  tauto.
  tauto.
  tauto.
  tauto.
  tauto.
  tauto.
Qed.

End ROOT_SUCC.


Require Import List.
Import ListNotations.
Require Import String.

(* Borrow from CompCert *)
Require Import Cryptol.Coqlib.
Require Import Cryptol.Bitvectors.

Require Import Cryptol.AST.
Require Import Cryptol.Semantics.
Require Import Cryptol.Utils.
Require Import Cryptol.Builtins.
Require Import Cryptol.BuiltinSem.
Require Import Cryptol.BuiltinSyntax.
Require Import Cryptol.Values.

Require Import Cryptol.EvalTac.

Import HaskellListNotations.
Open Scope string.

Require Import CryptolVerif.Comp.
Require Import Cryptol.Eager.

Lemma eval_t1 :
  eager_eval_expr ge tempty sempty (EVar t1) (sbit true).
Proof.
  init_globals ge.
  g. e. e. e. g.
  repeat e. e.
  e. e. e. e. e. g.
  e.
  e. e. e. g.
  e.
  ec. congruence.
  ec. congruence. e.
  e. e. fg.
  repeat e. e. e. reflexivity.
  e. e. fg. e.
  e. e. reflexivity. reflexivity.
  ec.
  e. e. e. fg. e. e. e.
  reflexivity.
  e. e. fg.
  e. e. e. reflexivity. reflexivity.
  ec. ec.
  congruence.
  e. e. e. fg.
  e. e. e. reflexivity.
  e. e. fg. e. e. e.
  reflexivity. reflexivity.
  ec. e. e. e. fg.
  e. e. e. reflexivity.
  e. e. fg.
  e. e. e. reflexivity.
  e. e. fg.
  e. e. e. reflexivity. reflexivity.
  f2; try e; try lv.
  e. e. e. fg.
  e. e. e. reflexivity.
  e. lv. lv.

  (* TODO: model At *)

Admitted.

(*
Lemma eval_t1 :
  eval_expr ge empty (EVar t1) (bit true).
Proof.
  assert (Hdemote : ge (0,"demote") = Some (mb 2 0 Demote)) by reflexivity.
  assert (Heq : ge (17,"==") = (Some (mb 1 2 Eq))) by reflexivity.
  assert (Hat : ge (40, "@") = Some (mb 3 2 At)) by reflexivity.
  g. e.
  e. e. e. unfold mb. simpl. e.
  repeat e.
  repeat e.
  repeat e; simpl; repeat e.
  g. e. e.
  e. eapply idx_first. eapply idx_last. e. e. e.
  repeat (simpl; e).
  repeat e.

  e. e. e. e. e. e. e.
  simpl. e. e. e. e. e.

  e.
  repeat e; simpl; repeat e.
  repeat e. reflexivity.
  e.
  eapply idx_first. eapply idx_last.
  repeat e; simpl; repeat e.

  repeat e; simpl; repeat e.
  repeat e.
  repeat e.
  instantiate (2 := O). reflexivity.
  repeat e.
  repeat e.
  repeat e.
  repeat e.
Qed.
*)


Require Import Metalib.Metatheory.

Require Import Stlc.Definitions.
Require Import LJm.Definitions.

Require Import FragmentLambda.

Module S := Stlc.Definitions.
Module L := LJm.Definitions.

Import L.LJmNotations.

(*********
 * Term to Exp using option
 *********)

Definition option_bind {A B} (x:option A) (f:A -> option B) : option B :=
  match x with
  | None => None
  | Some x => f x
  end.

Fixpoint term_to_exp3 t : option exp :=
  match t with
  | var_b n => Some (S.var_b n)
  | var_f x => Some (S.var_f x)
  | abs t => option_bind (term_to_exp3 t) (fun x => Some (S.abs x))
  | app t (args u anil (cabs (var_b 0))) =>
    option_bind (term_to_exp3 t) (fun t =>
    option_bind (term_to_exp3 u) (fun u =>
    Some (S.app t u)))
  | _ => None
  end.

Lemma term_to_exp3_correct t : is_lambda t -> exists e, term_to_exp3 t = Some e.
  intro.
  induction H; simpl; try (eexists; now eauto).
  - destruct IHis_lambda. rewrite H0. simpl. eauto.
  - destruct IHis_lambda1, IHis_lambda2. rewrite H1, H2. simpl. eauto.
Qed.

(* identity proof 1 v3: *)

(* option seems like a bad idea after all, since it deeply changes the
formulation of the lemmas *)

Lemma term_to_exp_id_l3 t (H : is_lambda t) :
  option_bind (term_to_exp3 t) (fun x => Some (exp_to_terms x)) = Some t.
  induction H; simpl; auto.
  (* I give up! *)
Abort.

(*********
 ** Append in locally nameless style.
 ** The function is not structually recursive anymore; how to make it accept?
 *********)

Definition fresh_in (L : atoms) : atom :=
  match atom_fresh L with exist _ x P => x end.

Fixpoint app_args_args (a1:gmargs) (a2:gmargs) {struct a1}: gmargs :=
  match a1 with
  | (args t l c)  => args t l (app_cont_args c a2)
  end
with app_cont_args (c:cont) (a:gmargs) : cont :=
  match c with
  | cabs v =>
    let x := fresh_in (fvT v) in
    cabs (closeT x (app_term_x_args x (openT v (var_f x)) a))
  end
with app_term_x_args (x:atom) (v:term) (a:gmargs) {struct v}: term :=
  match v with
  | (app (var_b 0) a1) => if (AtomSetImpl.mem x (fvA a))   (* if 0 is in a1 *)
                         then app v a
                         else app (var_b 0) (app_args_args a1 a)
  | _                  => app v a
  end.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrnat.
Require Import seq.
Require Import cfmap.
Require Import cfreducible.
Require Import configurations.

Lemma red238to253 : reducible_in_range 238 253 the_configs.
Proof. CheckReducible. Qed.


Require Import Lexicals.
Require Import String.
Require Import List.
Require Import Exceptions.
Require Import MyUtils.
Require Import Monad.
Require Import ZArith.

Module Type PARSE.

  Parameter position : Set.
  Parameter element : Set.
  Parameter token : Set.
  Parameter M : Type -> Type.
  Definition Parse A (l:list token) := (A*{l' : list token | Suffix l' l})%type.
  Definition Parser A := forall l, M (Parse A l).
  Parameter id : Parser string.
  Parameter num : Parser nat.
  Parameter con : Parser string.
  Parameter str : forall (s:string), Parser string.
  Parameter alt : forall (A:Type), Parser A -> Parser A -> Parser A.
  Parameter must : forall (A:Type), Parser A -> Parser A.
  Parameter pair : forall (A B:Type), Parser A -> Parser B -> Parser (A * B).
  Parameter s_pair : forall (A:Type), string -> Parser A -> Parser A.
  Parameter pair_s : forall (A:Type), Parser A -> string -> Parser A.
  Parameter appl : forall (A B:Type), Parser A -> (A -> B) -> Parser B.
  Parameter repeat : forall (A:Type), Parser A -> Parser (list A).
  Parameter wrap : forall (A:Type), Parser A -> Parser (list A).
  (*
  Parameter infixes : forall (A:Set), Parser A -> (string -> Z) -> (string -> A -> A -> A) -> Parser A.
  *)
  Parameter reader : forall (A:Type), Parser A -> string -> M A.
End PARSE.

Module Parse (Lex : LEXICAL) <: PARSE.

  Definition position := Lex.Position.
  Definition element := Lex.Element.
  Definition token := Lex.Token.

  Definition M := ExceptionM.

  Definition SyntaxErr := "SyntaxErr"%string.
  Definition Fail := "Fail"%string.

  Definition report_position r :=
    ("(line,character): ("++(string_of_nat (Lex.pos_lnum r))++
     ","++(string_of_nat (Lex.pos_cnum r))++")")%string.

  Definition Parse A (l:list token) := (A*{l' : list token | length l' < length l})%type.
  Definition Parser (A:Type) := forall l, M (Parse A l).

  (*Phrase consisting of an identifier*)
  Definition id : Parser string.
    unfold Parser.
    refine
      (fun l : list token =>
        match l return M (Parse string l) with
          | nil => raise SyntaxErr "Identifier expected, but at end of input."
          | cons (Lex.Id a,_) toks => ret (a,(exist _ toks _))
          | cons (_,pos) _ =>
            raise SyntaxErr ("Identifier expected at "++(report_position pos))%string
        end). simpl ; auto.
  Defined.

  (*Phrase consisting of an number*)
  (* Definition num (l:list token) : Parse nat l := *)
  Definition num : Parser nat.
    unfold Parser.
    refine
      (fun l : list token =>
        match l return M (Parse nat l) with
          | nil => raise SyntaxErr "Number expected, but at end of input."
          | cons (Lex.Num n,_) toks => ret (n,(exist _ toks _))
          | cons (_,pos) _ =>
            raise SyntaxErr ("Number expected at "++(report_position pos))
        end). simpl ; auto.
  Defined.

  (* Phrase consisting of a constructor *)
  Definition con : Parser string.
    unfold Parser.
    refine
      (fun l : list token =>
        match l return M (Parse string l) with
          | nil => raise SyntaxErr "Constructor expected, but at end of input."
          | cons (Lex.Con c,_) toks => ret (c,(exist _ toks _))
          | cons (_,pos) _ =>
            raise SyntaxErr ("Constructor expected at "++(report_position pos))
        end). simpl ; auto.
  Defined.

  (*Phrase consisting of the keyword 'a' *)
  Definition str (a:string) : Parser string.
    unfold Parser.
    refine
      (fun (a:string) (l : list token) =>
        match l return M (Parse string l) with
          | nil => raise SyntaxErr (a++" expected, but at end of input.")
          | cons (Lex.Key b,pos) toks =>
            if string_dec a b then ret (a,(exist _ toks _))
              else raise SyntaxErr (a++" expected, "++b++" found at "++(report_position pos))
          | cons (_,pos) toks =>
            raise SyntaxErr ("Keyword expected: "++a++" at "++(report_position pos))
        end). simpl ; auto.
  Defined.

  (* parsing disjunction *)
  Definition alt `A` (ph1: Parser A) (ph2: Parser A) : Parser A :=
    (fun toks =>
      ph1 toks
      |:| SyntaxErr, msg => ph2 toks).
  Infix "|+|" := alt.

  (* fail if we can't parse with ph.  This is like prolog's cut and pretty nasty for the same reasons. *)
  Definition must `A` (ph: Parser A) : Parser A :=
    (fun toks =>
      ph toks
      |:| SyntaxErr, msg => raise Fail msg).
  Notation "|!| ph" := (must ph) (at level 0).

  (*One phrase then another*)
  Definition pair `A B` (ph1 : Parser A) (ph2 : Parser B) : Parser (A*B).
    unfold Parser.
    refine
      (fun (A B : Type) (ph1 : Parser A) (ph2 : Parser B) (toks : list token) =>
        px <- ph1 toks ;;
        (match px with
           | (x,(exist toks2 Hx)) =>
             py <- ph2 toks2 ;;
             (match py with
                | (y,(exist toks3 Hy)) => ret ((x,y),exist _ toks3 _)
              end)
         end)) ; eapply suffix_trans ; eauto.
  Defined.
  Infix "--" := pair (at level 55).

  (*Application of f to the result of a phrase*)
  Definition appl `A B` (ph : Parser A) (f : A -> B) : Parser B.
    unfold Parser.
    refine
      (fun (A B : Type) (ph : Parser A) (f : A -> B) (toks : list token) =>
        px <- ph toks ;;
        (match px with
           | (x,(exist toks2 Hx)) =>
             ret (f x,exist _ toks2 _)
         end)) ; auto.
  Defined.
  Infix "|>|" := appl (at level 55).

  Definition s_pair `A` (a:string) (ph: Parser A) : Parser A :=
    (str a) -- |!|ph |>| (fun (x:string*A) => snd x).
  Infix "@--" := s_pair (at level 50).

  Definition pair_s `A` (ph: Parser A) (a:string) : Parser A :=
    |!|ph -- (str a) |>| (fun (x:A*string) => fst x).
  Infix "--@" := pair_s (at level 50).

  Require Import Recdef.
  (* We don't use the ML definition of repeat because it doesn't necessarily make progress *)
  Function repeat_aux (A:Type) (ph : Parser A) (toks : list token) {measure length toks} : M (Parse (list A) toks) :=
    match ph toks with
      | exn e => exn _ e
      | no_exn (a,exist toks' Htoks') =>
        match repeat_aux A ph toks' with
          | exn e => ret (cons a nil,exist _ toks' Htoks')
          | no_exn (b,exist toks'' Htoks'') => ret ((cons a b), exist _ toks'' (suffix_trans _ toks toks' toks'' Htoks' Htoks''))
        end
    end. intros. apply suffix_smaller. auto.
  Defined.

  (* this just gives us implicit A and makes the type more readable. [Function is a bit ugly in that it changes the names of parameters] *)
  Definition repeat `A` (ph:Parser A) : Parser (list A) := repeat_aux A ph.

  Definition wrap `A` (ph:Parser A) : Parser (list A).
    unfold Parser.
    refine
      (fun (A:Type) (ph:Parser A) (toks:list token) =>
        (px <- ph toks ;;
          (match px with
             | (a,exist toks' Htoks') => ret (cons a nil, exist _ toks' Htoks')
           end))).
  Defined.

  (*
  fun infixes (ph,prec_of,apply) =
    let fun over k toks = next k (ph toks)
        and next k (x, (Lex.Key(a),pos)::toks) =
              if prec_of a < k then (x, (Lex.Key a,pos) :: toks)
              else next k ((over (prec_of a) >> apply a x) toks)
          | next k (x, toks) = (x, toks)
    in  over 0  end;

    *)

  (*Scan and parse, checking that no tokens remain*)
  Definition reader `A` (ph : Parser A) str : M A :=
    (px <- ph (Lex.scan str) ;;
      (match px with
         | (x,exist nil H1) => ret x
         | (_,exist (cons tok _) _) =>
           raise SyntaxErr ("Extra characters in phrase: " ++ (Lex.showToken tok)
             ++ "..." ++ "near "++(report_position (snd tok)))
       end))
    (* Turn failures back into syntax errors *)
    |:| Fail, msg => raise SyntaxErr msg.

End Parse.