(*
  Adapted from SfLib.v,
  from the Software Foulndations library
  https://softwarefoundations.cis.upenn.edu/
*)

Require Omega.
Require Export Bool.
Require Export List.
Export ListNotations.
Require Import LibTactics.
Require Export Arith.
Require Export Arith.EqNat.
Require Export Ensembles.

Require Export String.
Open Scope string_scope.

(*Require String. Open Scope string_scope.*)

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => ble_nat n' m'
      end
  end.

Theorem andb_true_elim1 : forall b c,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    reflexivity.
  Case "b = false".
    rewrite <- H. reflexivity.  Qed.

Theorem andb_true : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  intros b c H.
  destruct b.
    destruct c.
      apply conj. reflexivity. reflexivity.
      inversion H.
    inversion H.  Qed.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.  Qed.

Inductive appears_in (n : nat) : list nat -> Prop :=
| ai_here : forall l, appears_in n (n::l)
| ai_later : forall m l, appears_in n l -> appears_in n (m::l).

Inductive next_nat (n:nat) : nat -> Prop :=
  | nn : next_nat n (S n).

Inductive total_relation : nat -> nat -> Prop :=
  tot : forall n m : nat, total_relation n m.

Inductive empty_relation : nat -> nat -> Prop := .

(** * From Later Files *)

Definition relation (X:Type) := X -> X -> Prop.

Definition deterministic {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Inductive multi `(X:Type) (R: relation X)
                            : X -> X -> Prop :=
  | Multi_refl  : forall (x : X),
                 multi X R x x
  | Multi_step : forall (x y z : X),
                    R x y ->
                    multi X R y z ->
                    multi X R x z.
(* Implicit Arguments multi [[X]]. *)
Arguments multi : default implicits.

Tactic Notation "multi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "multi_refl" | Case_aux c "multi_step" ].

(*
Theorem multi_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> multi R x y.
Proof.
  intros X R x y r.
  apply multi_step with y. apply r. apply multi_refl. Qed.
*)

Lemma multi_back :
  forall (X : Type) (R : relation X) x y z,
    multi R x y -> R y z -> multi R x z.
Proof.
  introv; intro H_multi.
  remember R as rel in H_multi; remember x as xx in H_multi; remember y as yy in H_multi.
  gen x y z.
  multi_cases (induction H_multi) Case; intros; subst.
  Case "multi_refl". eapply Multi_step; eauto; apply Multi_refl.
  Case "multi_step". specialize (IHH_multi y (eq_refl _) y0 (eq_refl _) z0 H0).
  eapply Multi_step; eauto.
Qed.

Inductive k_R `(X:Type) (R: relation X) : nat -> X -> X -> Prop :=
| Zero_R : forall (x : X), k_R X R 0 x x
| Suc_R : forall (x x'' x' : X) k,
    R x x'' -> k_R X R k x'' x' -> k_R X R (S k) x x'.

Tactic Notation "k_R_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "k_R_zero" | Case_aux c "k_R_inc" ].

Lemma k_back :
  forall (X : Type) (R : relation X) k x y z,
    k_R _ R k x y -> R y z -> k_R _ R (S k) x z.
Proof.
  intros.
  remember R as rel in H.
  remember k as num in H.
  remember x as xx in H.
  remember y as yy in H.
  gen k. gen x.
  k_R_cases (induction H) Case.
  Case "k_R_zero".
  intros. rewrite <- Heqnum.
  econstructor; eauto.
  rewrite <- Heqxx.  rewrite Heqyy.
  eauto.
  constructor.
  Case "k_R_inc".
  intros.
  specialize (IHk_R Heqyy x'' (eq_refl x'') k (eq_refl k)).
  rewrite Heqrel in H.
  rewrite Heqxx in *.
  rewrite Heqnum in *.
  econstructor; eauto.
Qed.

(*SearchAbout "relation". *)


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

(* File created for Coq V5.10.14b, Oct 1995, by duplication of
   Classical_Pred_Type.v *)

(** This file is obsolete, use Classical_Pred_Type.v via Classical.v
instead *)

(** Classical Predicate Logic on Set*)

Require Import Classical_Pred_Type.

Section Generic.
Variable U : Set.

(** de Morgan laws for quantifiers *)

Lemma not_all_ex_not :
 forall P:U -> Prop, ~ (forall n:U, P n) ->  exists n : U, ~ P n.
Proof (Classical_Pred_Type.not_all_ex_not U).

Lemma not_all_not_ex :
 forall P:U -> Prop, ~ (forall n:U, ~ P n) ->  exists n : U, P n.
Proof (Classical_Pred_Type.not_all_not_ex U).

Lemma not_ex_all_not :
 forall P:U -> Prop, ~ (exists n : U, P n) -> forall n:U, ~ P n.
Proof (Classical_Pred_Type.not_ex_all_not U).

Lemma not_ex_not_all :
 forall P:U -> Prop, ~ (exists n : U, ~ P n) -> forall n:U, P n.
Proof (Classical_Pred_Type.not_ex_not_all U).

Lemma ex_not_not_all :
 forall P:U -> Prop, (exists n : U, ~ P n) -> ~ (forall n:U, P n).
Proof (Classical_Pred_Type.ex_not_not_all U).

Lemma all_not_not_ex :
 forall P:U -> Prop, (forall n:U, ~ P n) -> ~ (exists n : U, P n).
Proof (Classical_Pred_Type.all_not_not_ex U).

End Generic.


Require Export CatSem.CAT.cat_TYPE_option.
Require Export CatSem.CAT.rmonad.
Require Export CatSem.CAT.rmodule_TYPE.
Require Export CatSem.ULC.ULC_semantics.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Automatic Introduction.

Obligation Tactic := fin.

Program Instance ULCBETA_s : RMonad_struct (SM_po) ULCBETA := {
   rweta := VAR;
   rkleisli a b f := SUBST f
}.
Next Obligation.
Proof.
  unfold Proper;
  red;
  fin.
Qed.

Definition ULCBETA : RMonad (SM_po) := Build_RMonad ULCBETA_s.

Lemma rename_lift V (v : ULC V) W (f : V ---> W) :
       v //- f = rlift ULCBETA f v.
Proof.
  unfold lift;
  fin.
Qed.

Section app_po.

Obligation Tactic := idtac.

Program Instance app_po_mors c : PO_mor_struct
  (a := PO_product (ULCBETA c )  (ULCBETA c))
  (b := ULCBETA c)
  (fun z => App (fst z) (snd z)).
Next Obligation.
Proof.
  intros c.
  unfold Proper;
  red.
  intros x y H.
  destruct H.
  simpl in *.
  transitivity (App v' w).
    apply cp_App1; auto.
    apply cp_App2; auto.
Qed.

Definition app_po_mor c := Build_PO_mor (app_po_mors c).

Obligation Tactic := fin.

Program Instance ulc_app_s  : RModule_Hom_struct
  (M:=product (C:=RMOD _ Ord) ULCBETA ULCBETA)
  (N:=ULCBETA) (app_po_mor).

Definition ulc_app := Build_RModule_Hom ulc_app_s.

End app_po.

Section abs_po.

Obligation Tactic := unfold Proper; red;
        simpl; intros; apply cp_Abs; auto.

Program Instance abs_po_mors c : PO_mor_struct
  (a := (ULCBETA (option c)))
  (b := (ULCBETA c)) (@Abs _ ).

Definition abs_po_mor c := Build_PO_mor (abs_po_mors c).

Obligation Tactic := idtac.

Program Instance ulc_abs_s : RModule_Hom_struct
 (M:= DER_RMOD_not _ _  ULCBETA)
 (N:=ULCBETA) abs_po_mor.
Next Obligation.
Proof.
  fin.
  apply f_equal.
  apply subst_eq.
  intros.
  match goal with [H:option _ |- _ ]=> destruct H end;
  simpl; fin.
Qed.

Definition ulc_abs := Build_RModule_Hom ulc_abs_s.

End abs_po.


From Coq Require Import String.

From Coq Require Import ssreflect ssrfun ssrbool. (* <- needed for mlAssert *)
From stdpp Require Import list. (* <- needed for mlRevertLast *)
From MatchingLogic Require Import
    Logic
    DerivedOperators_Syntax
    ProofSystem
    ProofMode.MLPM
.

Import
  MatchingLogic.Logic.Notations
  MatchingLogic.DerivedOperators_Syntax.Notations
.

Open Scope string_scope.
Open Scope list_scope.
Open Scope ml_scope.

From Coq Require Import ssreflect ssrfun ssrbool.

Open Scope string_scope.
Open Scope list_scope.
Open Scope ml_scope.

Local Lemma Private_revert_forall_iter {Σ : Signature} (Γ : Theory) :
  forall (l : list Pattern) (ϕ : Pattern) x,
  Pattern.wf l ->
  well_formed ϕ ->
  Γ ⊢i foldr patt_imp (all , ϕ^{{evar: x ↦ 0}}) l ---> foldr patt_imp ϕ l
    using BasicReasoning.
Proof.
  intros l ϕ x Wfl Wfϕ. apply prf_weaken_conclusion_iter_meta. 1-3: wf_auto2.
  mlIntro "H".
  mlSpecialize "H" with x.
  rewrite evar_open_evar_quantify. wf_auto2.
  mlAssumption.
Qed.

Section compute.
  From MatchingLogic.Theories Require Import Definedness_Syntax
                                             Definedness_Semantics
                                             Sorts_Syntax
                                             Sorts_Semantics
                                             Definedness_ProofSystem.
  From stdpp Require Import base fin_sets sets propset finite.

  Inductive Symbols :=
    | sym_import_definedness (d : Definedness_Syntax.Symbols)
    | Zero | Succ (* constructors for Nats *)
    | TT | FF
    | even
  .

  Instance Symbols_eqdec : EqDecision Symbols.
  Proof. solve_decision. Defined.

  #[local]
  Program Instance Symbols_fin : Finite Symbols :=
  {|
    enum := [Zero; Succ; TT ; FF; even;
      sym_import_definedness Definedness_Syntax.definedness] ;
  |}.
  Next Obligation.
    repeat constructor; set_solver.
  Qed.
  Next Obligation.
    destruct x; try set_solver.
    destruct d; set_solver.
  Qed.

  Instance signature : Signature :=
    {| variables := StringMLVariables ;
       ml_symbols := {|
          symbols := Symbols ;
        |}
    |}.

  Instance definedness_syntax : Definedness_Syntax.Syntax :=
    {|
       Definedness_Syntax.inj := sym_import_definedness;
    |}.

  Open Scope string_scope.
  Let X0 := patt_free_evar "X0".
  Let X := patt_free_evar "X".
  Let sym_even := patt_sym even.
  Let sym_succ := patt_sym Succ.
  Let sym_zero := patt_sym Zero.
  Let sym_tt := patt_sym TT.
  Let sym_ff := patt_sym FF.
  (* axioms *)
  Definition defined : Pattern := Definedness_Syntax.axiom AxDefinedness.

  Definition A : Pattern :=
    sym_zero.
  Definition B : Pattern :=
    patt_app sym_succ sym_zero.

Definition private_test_revert_1 :=
  (Private_revert_forall_iter ∅ [] patt_bott (fresh_evar patt_bott)
    ltac:(wf_auto2) ltac:(wf_auto2)).
Definition private_test_revert_2 :=
  (revert_forall_iter ∅ [] patt_bott (fresh_evar patt_bott)
    ltac:(wf_auto2) ltac:(wf_auto2)).
Definition private_test_revert_3 :=
  (Private_revert_forall_iter ∅ [A;B;A;B;A;B] patt_bott (fresh_evar patt_bott)
    ltac:(wf_auto2) ltac:(wf_auto2)).
Definition private_test_revert_4 :=
  (revert_forall_iter ∅ [A;B;A;B;A;B] patt_bott (fresh_evar patt_bott)
    ltac:(wf_auto2) ltac:(wf_auto2)).

    (*
  Compute proof_size_info (ex1_low ∅ A B ltac:(wf_auto2) ltac:(wf_auto2)).
  Compute proof_size_info (ex1_pm ∅ A B ltac:(wf_auto2) ltac:(wf_auto2)). *)

End compute.


From trillium.traces Require Export trace infinite_trace.
From trillium.program_logic Require Import language.

Import InfListNotations.

Definition execution_trace Λ := finite_trace (cfg Λ) (option (locale Λ)).

Record Model : Type := MkModel {
  mstate:> Type;
  mlabel: Type;
  mtrans: mstate -> mlabel -> mstate -> Prop;
}.

Arguments mtrans {_} _ _ _.

Notation olocale Λ := (option (locale Λ)).

Notation auxiliary_trace m := (finite_trace m.(mstate) m.(mlabel)).

Section execution_trace.
  Context {Λ : language}.

  Implicit Types c : cfg Λ.

  Definition valid_exec (ex : execution_trace Λ) : Prop := trace_steps locale_step ex.

  Lemma valid_singleton_exec c : valid_exec (trace_singleton c).
  Proof. constructor. Qed.

  Lemma extend_valid_exec ex c ζ c':
    valid_exec ex →
    trace_ends_in ex c →
    locale_step c ζ c' →
    valid_exec (ex :tr[ζ]: c').
  Proof. econstructor; done. Qed.

  Lemma valid_exec_exec_extend_inv ex ζ c':
    valid_exec (trace_extend ex ζ c') →
    valid_exec ex ∧
    ∃ c, trace_ends_in ex c ∧ locale_step c ζ c'.
  Proof. apply trace_steps_step_inv. Qed.

End execution_trace.

Section system_trace.
  Context {Λ : language} {M : Model}.

  Implicit Types ex : execution_trace Λ.
  Implicit Types atr : auxiliary_trace M.
  Implicit Types ζ : olocale Λ.
  Implicit Types ℓ : mlabel M.

  Inductive valid_system_trace : execution_trace Λ → auxiliary_trace M → Prop :=
  | valid_system_trace_singleton c δ :
      valid_system_trace (trace_singleton c) (trace_singleton δ)
  | valid_system_trace_step ex atr c c' δ' ζ ℓ:
      trace_ends_in ex c →
      locale_step c ζ c' →
      valid_system_trace ex atr →
      valid_system_trace (trace_extend ex ζ c') (trace_extend atr ℓ δ').

  Lemma valid_system_trace_valid_exec_trace ex atr :
    valid_system_trace ex atr → valid_exec ex.
  Proof. induction 1; econstructor; eauto. Qed.

  Lemma valid_system_trace_singletons c δ :
    valid_system_trace (trace_singleton c) (trace_singleton δ).
  Proof. constructor. Qed.

  Lemma valid_system_trace_extend ex atr c c' δ' ζ ℓ:
    valid_system_trace ex atr →
    trace_ends_in ex c →
    locale_step c ζ c' →
    valid_system_trace (trace_extend ex ζ c') (trace_extend atr ℓ δ').
  Proof.
    intros Heatr; revert c c' δ' ζ ℓ.
    induction ex; econstructor; eauto.
  Qed.

  Lemma valid_system_trace_extend_inv ex atr c' δ' ζ ℓ:
    valid_system_trace (trace_extend ex ζ c') (trace_extend atr ℓ δ') →
    ∃ c,
      valid_system_trace ex atr ∧
      trace_ends_in ex c ∧
      locale_step c ζ c'.
  Proof. inversion 1; eauto. Qed.

  Lemma valid_system_trace_ends_in ex atr :
    valid_system_trace ex atr → ∃ c δ, trace_ends_in ex c ∧ trace_ends_in atr δ.
  Proof.
    inversion 1;
      eauto using trace_extend_ends_in, trace_singleton_ends_in,
      trace_extend_ends_in, trace_singleton_ends_in.
  Qed.

  Lemma trace_steps2_trace_steps (R : M -> mlabel M -> M -> Prop) :
    (∀ ex atr c δ c' δ' ζ ℓ,
        trace_ends_in ex c →
        trace_ends_in atr δ →
        locale_step c ζ c' →
        R δ ℓ δ') →
    ∀ ex atr, valid_system_trace ex atr → valid_exec ex ∧ trace_steps R atr.
  Proof.
    intros HR ex ex' Hexs.
    induction Hexs as [|?????????? []].
    - split; constructor.
    - split; econstructor; [done|done|done|done|eapply HR=>//|done].
  Qed.

End system_trace.

Section simulation.
  Context {Λ : language} {M : Model}.
  Variable (labels_match : olocale Λ → mlabel M → Prop).

  Implicit Types ex : execution_trace Λ.
  Implicit Types atr : auxiliary_trace M.

  Definition continued_simulation_pre
             (φ : execution_trace Λ → auxiliary_trace M → Prop)
             (continued_simulation :
                execution_trace Λ → auxiliary_trace M → Prop) :
    execution_trace Λ → auxiliary_trace M → Prop :=
    λ ex atr,
      φ ex atr ∧
      ∀ c c' ζ,
        trace_ends_in ex c →
        locale_step c ζ c' →
        ∃ δ' ℓ, continued_simulation (trace_extend ex ζ c') (trace_extend atr ℓ δ').

  Local Definition continued_simulation_pre_curried
        (φ : execution_trace Λ → auxiliary_trace M → Prop) :
    (execution_trace Λ * auxiliary_trace M → Prop) →
    (execution_trace Λ * auxiliary_trace M → Prop) :=
    λ ψ (exatr : execution_trace Λ * auxiliary_trace M),
    (continued_simulation_pre φ (λ ex atr, ψ (ex, atr)) exatr.1 exatr.2).

  Lemma continued_simulation_pre_curried_mono
        (φ : execution_trace Λ → auxiliary_trace M → Prop) :
    monotone (continued_simulation_pre_curried φ).
  Proof.
    intros P Q HPQ [ex atr].
    intros [? HP]. split; [done|].
    intros ?????.
    edestruct HP as (?&?&?); eauto.
  Qed.

  Definition continued_simulation (φ : execution_trace Λ → auxiliary_trace M → Prop) :=
    λ ex atr, GFX (continued_simulation_pre_curried φ) (ex, atr).

  Lemma continued_simulation_unfold
        (φ : execution_trace Λ → auxiliary_trace M → Prop) ex atr :
    continued_simulation φ ex atr ↔
    continued_simulation_pre φ (continued_simulation φ) ex atr.
  Proof.
    symmetry; rewrite /continued_simulation /=.
    apply (λ H, GFX_fixpoint (continued_simulation_pre_curried φ) H (_, _)).
    apply continued_simulation_pre_curried_mono.
  Qed.

  Lemma continued_simulation_rel Φ ex tr:
    continued_simulation Φ ex tr → Φ ex tr.
  Proof.
    rewrite continued_simulation_unfold /continued_simulation_pre; intuition.
  Qed.

  Lemma continued_simulation_next_aux_state_exists
             (φ : execution_trace Λ → auxiliary_trace M → Prop)
             (ex : execution_trace Λ) (atr : auxiliary_trace M)
             (c : cfg Λ) ζ:
    continued_simulation φ ex atr →
    valid_exec (trace_extend ex ζ c) →
    ∃ δℓ, continued_simulation φ (trace_extend ex ζ c) (trace_extend atr δℓ.2 δℓ.1).
  Proof.
    rewrite continued_simulation_unfold /continued_simulation_pre.
    intros (HΦ & Hext) Hvex.
    apply valid_exec_exec_extend_inv in Hvex as [Hvex (c1 & Hc1 & Hstep)].
    edestruct Hext as (?&?&?); [done..|].
    by eexists (_,_).
  Qed.

  Lemma simulation_does_continue e σ δ φ :
    continued_simulation φ (trace_singleton ([e], σ)) (trace_singleton δ) →
    ∀ ex, trace_starts_in ex ([e], σ) →
          valid_exec ex →
          ∃ atr, trace_starts_in atr δ ∧ continued_simulation φ ex atr.
  Proof.
    intros Hsm ex Hexstr Hex.
    induction Hex as [|? ? ? ? ? ? ? IHex].
    - apply trace_singleton_starts_in_inv in Hexstr as ->.
      exists (trace_singleton δ). done.
    - destruct IHex as [atr [Hstarts Hsim]].
      { eapply trace_extend_starts_in_inv; eauto. }
      edestruct (continued_simulation_next_aux_state_exists φ ex atr) as ([??]&?);
        [done| |].
      { econstructor; eauto. }
      eexists. split; [|done].
      by apply trace_extend_starts_in.
  Qed.

  Lemma continued_simulation_impl (Φ Ψ: execution_trace Λ → auxiliary_trace M → Prop) ex tr:
    (∀ ex tr, Φ ex tr → Ψ ex tr) →
    continued_simulation Φ ex tr → continued_simulation Ψ ex tr.
  Proof.
    intros Himpl Hphi.
    rewrite /continued_simulation /GFX.
    exists (λ '(ex, atr), continued_simulation Φ ex atr).
    split; [done|].
    intros [? ?] ?.
    rewrite /continued_simulation_pre_curried /continued_simulation_pre /=.
    split.
    { by eapply Himpl, continued_simulation_rel. }
    intros c c' ζ ? ?.
    move: H.
    rewrite continued_simulation_unfold /continued_simulation_pre.
    intros [? ?]. eauto.
  Qed.

End simulation.

Definition inf_execution_trace Λ := inflist (olocale Λ * cfg Λ).

Section inf_execution_trace.
  Context {Λ : language}.

  Definition inf_exec_prepend ζ (c : cfg Λ)
             (iex : inf_execution_trace Λ) : inf_execution_trace Λ :=
    ((ζ, c) :: iex)%inflist.

  CoInductive valid_inf_exec :
    execution_trace Λ → inf_execution_trace Λ → Prop :=
  | valid_inf_exec_singleton ex :
      valid_exec ex → valid_inf_exec ex []%inflist
  | valid_inf_exec_step ex c c' iex ζ:
      valid_exec ex →
      trace_ends_in ex c →
      locale_step c ζ c' →
      valid_inf_exec (trace_extend ex ζ c') iex →
      valid_inf_exec ex (inf_exec_prepend ζ c' iex).

End inf_execution_trace.

Definition inf_auxiliary_trace (M : Model) := inflist ((mlabel $ M) * M).

Definition inf_auxtr_prepend {M : Model} ℓ (δ : M) (atr : inf_auxiliary_trace M) :=
  infcons (ℓ,δ) atr.

CoInductive valid_inf_system_trace {Λ M}
            (Ψ : execution_trace Λ → auxiliary_trace M → Prop) :
  execution_trace Λ → auxiliary_trace M →
  inf_execution_trace Λ → inf_auxiliary_trace M → Prop :=
| valid_inf_system_trace_singleton ex atr :
    Ψ ex atr →
    valid_inf_system_trace Ψ ex atr []%inflist []%inflist
| valid_inf_system_trace_step ex atr c c' δ' iex iatr ζ ℓ:
    Ψ ex atr →
    trace_ends_in ex c →
    locale_step c ζ c' →
    valid_inf_system_trace
      Ψ (trace_extend ex ζ c') (trace_extend atr ℓ δ') iex iatr →
    valid_inf_system_trace
      Ψ ex atr (inf_exec_prepend ζ c' iex) (inf_auxtr_prepend ℓ δ' iatr).

Lemma valid_inf_system_trace_inv {Λ M}
      (Ψ : execution_trace Λ → auxiliary_trace M → Prop) ex atr iex itr :
  valid_inf_system_trace Ψ ex atr iex itr →
  Ψ ex atr.
Proof. by inversion 1. Qed.

Section simulation.
  Context {Λ : language} {M : Model}
          (φ : execution_trace Λ → auxiliary_trace M → Prop).

  Implicit Types ex : execution_trace Λ.
  Implicit Types iex : inf_execution_trace Λ.
  Implicit Types atr : auxiliary_trace M.
  Implicit Types ζ : olocale Λ.
  Implicit Types ℓ : mlabel M.

  Lemma valid_system_trace_start_or_contract ex atr :
    valid_system_trace ex atr →
    (ex = {tr[trace_first ex]} ∧ atr = {tr[trace_first atr]}) ∨
    (∃ ex' atr' oζ ℓ, trace_contract ex oζ ex' ∧ trace_contract atr ℓ atr').
  Proof. rewrite /trace_contract; inversion 1; simplify_eq; eauto 10. Qed.

  Lemma valid_inf_exec_prepend_valid_exec_extend ex c iex ζ:
    valid_inf_exec ex (inf_exec_prepend ζ c iex) →
    valid_exec (trace_extend ex ζ c).
  Proof.
    inversion 1 as [|???????? Hex]; simplify_eq.
    inversion Hex; done.
  Qed.

  Lemma produce_inf_aux_trace_next_aux_state_exists
        (ex : execution_trace Λ) (atr : auxiliary_trace M)
        (Hcsm : continued_simulation φ ex atr)
        (c : cfg Λ)
        (ζ: olocale Λ)
        (iex : inf_execution_trace Λ)
        (Hvex : valid_inf_exec ex (inf_exec_prepend ζ c iex)) :
    ∃ δℓ, continued_simulation φ (trace_extend ex ζ c) (trace_extend atr δℓ.2 δℓ.1).
  Proof.
    eapply continued_simulation_next_aux_state_exists; first done.
    eapply valid_inf_exec_prepend_valid_exec_extend; eauto.
  Qed.

  Definition produce_inf_aux_trace_next_aux_state
             (ex : execution_trace Λ) (atr : auxiliary_trace M)
             (Hcsm : continued_simulation φ ex atr)
             (c : cfg Λ)
             (ζ: olocale Λ)
             (iex : inf_execution_trace Λ)
             (Hvex : valid_inf_exec ex (inf_exec_prepend ζ c iex))
    : (M * mlabel M)%type :=
    epsilon
      (produce_inf_aux_trace_next_aux_state_exists ex atr Hcsm c ζ iex Hvex).

  Definition trace_extend_uncurry (tr: auxiliary_trace M) xy := trace_extend tr xy.2 xy.1.

  Lemma produce_inf_aux_trace_next_aux_state_continued_simulation
        (ex : execution_trace Λ) (atr : auxiliary_trace M)
        (Hcsm : continued_simulation φ ex atr)
        (c : cfg Λ)
        (ζ: olocale Λ)
        (iex : inf_execution_trace Λ)
        (Hvex : valid_inf_exec ex (inf_exec_prepend ζ c iex)) :
    continued_simulation
      φ
      (trace_extend ex ζ c)
      (trace_extend_uncurry
         atr (produce_inf_aux_trace_next_aux_state ex atr Hcsm c ζ iex Hvex)).
  Proof.
    rewrite /produce_inf_aux_trace_next_aux_state.
    apply epsilon_correct.
  Qed.

  Local Lemma valid_inf_exec_adjust {ex c iex ζ} :
    valid_inf_exec ex ((ζ, c) :: iex)%inflist →
    valid_inf_exec (trace_extend ex ζ c) iex.
  Proof. inversion 1; done. Qed.

  Lemma valid_inf_exe_valid_exec ex iex :
    valid_inf_exec ex iex → valid_exec ex.
  Proof. by destruct 1. Qed.
  Lemma valid_inf_exe_take_drop ex iex n :
    valid_inf_exec ex iex → valid_inf_exec (ex +trl+ inflist_take n iex) (inflist_drop n iex).
  Proof.
    revert ex iex; induction n as [|n IHn]; intros ex iex Hvl; simpl; first done.
    destruct iex as [|[??]]; simpl; first done.
    apply IHn.
    apply valid_inf_exec_adjust; done.
  Qed.

  CoFixpoint produce_inf_aux_trace
          (ex : execution_trace Λ) (atr : auxiliary_trace M)
          (Hcsm : continued_simulation φ ex atr)
          (iex : inf_execution_trace Λ)
          (Hvex : valid_inf_exec ex iex) :
    inf_auxiliary_trace M :=
    match iex as l return valid_inf_exec ex l → inf_auxiliary_trace M with
    | [] => λ _, []
    | (ζ, c) :: iex' =>
      λ Hvex',
      let δℓ :=
          produce_inf_aux_trace_next_aux_state ex atr Hcsm c ζ iex' Hvex'
      in
      (δℓ.2, δℓ.1) :: (produce_inf_aux_trace
              (trace_extend ex ζ c)
              (trace_extend atr δℓ.2 δℓ.1)
              (produce_inf_aux_trace_next_aux_state_continued_simulation
                 ex atr Hcsm c ζ iex' Hvex')
              iex'
              (valid_inf_exec_adjust Hvex'))
    end%inflist Hvex.

  Theorem produced_inf_aux_trace_valid_inf
          (ex : execution_trace Λ) (atr : auxiliary_trace M)
          (Hst : valid_system_trace ex atr)
          (Hcsm : continued_simulation φ ex atr)
          (iex : inf_execution_trace Λ)
          (Hvex : valid_inf_exec ex iex)
    : valid_inf_system_trace
        (continued_simulation φ)
        ex atr
        iex
        (produce_inf_aux_trace ex atr Hcsm iex Hvex).
  Proof.
    revert ex atr Hcsm Hst iex Hvex; cofix CIH; intros ex atr Hcsm Hst iex Hvex.
    destruct iex as [|[ζ c] iex].
    - rewrite [produce_inf_aux_trace _ _ _ _ _]inflist_unfold_fold /=.
      constructor; trivial.
    - rewrite [produce_inf_aux_trace _ _ _ _ _]inflist_unfold_fold /=.
      pose proof (produce_inf_aux_trace_next_aux_state_continued_simulation
                    ex atr Hcsm c ζ iex Hvex) as Hcsm'.
      assert (valid_system_trace
                (ex :tr[ζ]: c)
                (trace_extend_uncurry
                   atr (produce_inf_aux_trace_next_aux_state ex atr Hcsm c ζ iex Hvex)))
             as Hst'.
      { inversion Hvex; simplify_eq.
        econstructor; try done. }
      apply valid_system_trace_extend_inv in Hst' as (?&?&?&?).
      econstructor; eauto using valid_system_trace_step.
  Qed.

End simulation.


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

Require Export Parser.Structures.
Require Export Parser.ProductiveFun.
Require Export Parser.ProductiveInd.
Require Export Parser.NullableFun.
Require Export Parser.HasConflictInd.
Require Export Parser.ShouldNotFollowFun.
Require Export Parser.SubSyntax.
Require Export Parser.Prefix.

Opaque nullable_fun.
Opaque productive_fun.
Opaque should_not_follow_fun.
Opaque first_fun.

Inductive visitable (x: id): forall A, Syntax A -> Prop :=
| VDisjL:
    forall A (s1 s2: Syntax A),
      visitable x A s1 ->
      visitable x A (Disjunction s1 s2)
| VDisjR:
    forall A (s1 s2: Syntax A),
      visitable x A s2 ->
      visitable x A (Disjunction s1 s2)
| VSeqL:
    forall A1 A2 (s1: Syntax A1) (s2: Syntax A2) ts v,
      visitable x A1 s1 ->
      matches s2 ts v ->
      visitable x (A1 * A2) (Sequence s1 s2)
| VSeqR:
    forall A1 A2 (s1: Syntax A1) (s2: Syntax A2) v,
      matches s1 [] v ->
      visitable x A2 s2 ->
      visitable x (A1 * A2) (Sequence s1 s2)
| VMap:
    forall A B (f: A -> B) g (s: Syntax A),
      visitable x A s ->
      visitable x B (Map f g s)
| VVar:
    visitable x (get_type x) (Var x)
| VRec:
    forall y,
      visitable x (get_type y) (e y) ->
      visitable x (get_type y) (Var y)
.

Arguments visitable x { A }.

Hint Constructors visitable: visitable.

Definition left_recursive (x: id) := visitable x (e x).

Program Definition visitable_inversion { A } x (s: Syntax A) (H: visitable x s) :=
  match H in visitable _ s' return
    match s' return Prop with
    | Disjunction s1' s2' => visitable x s1' \/ visitable x s2'
    | Sequence s1' s2' =>
      (visitable x s1' /\ exists ts v, matches s2' ts v) \/
      (exists v, matches s1' [] v /\ visitable x s2')
    | Map f g s' => visitable x s'
    | Var y => x = y \/ visitable x (e y)
    | _ => True
    end
  with
  | VDisjL _ _ _ _ _ => _
  | _ => _
  end.

Solve Obligations with eauto 6.

Fail Next Obligation. (* no more obligations visitable_inversion *)

Ltac visitable_inversion :=
  match goal with
  | H: visitable _ (Disjunction _ _) |- _ =>
    poseNew (Mark H "visitable_inversion");
    pose proof (visitable_inversion _ _ H)
  | H: visitable _ (Sequence _ _) |- _ =>
    poseNew (Mark H "visitable_inversion");
    pose proof (visitable_inversion _ _ H)
  | H: visitable _ (Map _ _ _) |- _ =>
    poseNew (Mark H "visitable_inversion");
    pose proof (visitable_inversion _ _ H)
  | H: visitable _ (Var _) |- _ =>
    poseNew (Mark H "visitable_inversion");
    pose proof (visitable_inversion _ _ H)
  end.

Lemma visitable_extend:
  forall A (s: Syntax A) x ts v,
    visitable x s ->
    matches (e x) ts v ->
    exists ts' v, matches s (ts ++ ts') v.
Proof.
  intros.
  revert v ts H0.
  induction H;
    repeat light || instantiate_any ||
      options || destruct_match;
    eauto 6 with matches.
Qed.

Ltac visitable_extend :=
  match goal with
  | H1: visitable ?x ?s,
    H2: matches (e ?x) _ _ |- _ =>
    poseNew (Mark s "visitable_extend");
    pose proof (visitable_extend _ _ _ _ _ H1 H2)
  end.

Lemma visitable_non_empty_conflict':
  forall x A (s: Syntax A),
    visitable x s ->
    forall t ts v tsx vx,
      matches_without [ x ] s (t :: ts) v ->
      matches (e x) (t :: tsx) vx ->
      has_conflict_ind s.
Proof.
  induction 1;
    repeat light || visitable_inversion || inversion_solve || invert_constructor_equalities ||
           visitable_extend || invert_matches || app_cons_destruct;
    eauto with has_conflict_ind.

  - eapply has_conflict_disj_first;
      repeat light || options || eapply first_fun_complete || destruct_match;
      eauto using matches_incl, incl_nil.

  - eapply has_conflict_disj_first;
      repeat light || options || eapply first_fun_complete || destruct_match;
      eauto using matches_incl, incl_nil.

  - eapply has_conflict_seq_follow;
      repeat light || eapply first_fun_complete;
      eauto using should_not_follow_fun_first, matches_incl, incl_nil.

  - repeat light || invert_constructor_equalities || rewrite <- app_assoc in * ||
           options || nullable_fun_spec || destruct_match;
     eauto using
       should_not_follow_fun_first,
       first_fun_complete,
       has_conflict_seq_follow,
       matches_incl, incl_nil.
Qed.

Lemma visitable_prefix_conflict:
  forall x A (s: Syntax A) t ts v,
    visitable x s ->
    prefix s (e x) ->
    matches_without [ x ] s (t :: ts) v ->
    has_conflict_ind s.
Proof.
  intros.
  repeat prefix || light;
    eauto using visitable_non_empty_conflict';
    eauto using matches_incl, incl_nil.
Qed.

Lemma visitable_not_nullable_conflict':
  forall x A (s: Syntax A),
    visitable x s ->
    forall t ts v1 v2,
      prefix s (e x) ->
      matches s (t :: ts) v1 ->
      (forall v, ~ matches s [] v) ->
      matches (e x) [] v2 ->
      has_conflict_ind s.
Proof.
  induction 1;
    repeat light || invert_matches || prefix_sub || nullable_fun_spec || options || destruct_match ||
           visitable_extend || prefix || app_cons_destruct || invert_constructor_equalities;
    eauto with has_conflict_ind matches.

  - pose proof (visitable_extend _ _ _ _ _ H H7); lights.
    apply has_conflict_disj_first with (get_kind t);
    repeat light || eapply first_fun_complete || eapply should_not_follow_fun_first;
      eauto.

  - pose proof (visitable_extend _ _ _ _ _ H H8); lights.
    apply has_conflict_disj_first with (get_kind t);
    repeat light || eapply first_fun_complete || eapply should_not_follow_fun_first;
      eauto.

  - pose proof (visitable_extend _ _ _ _ _ H H13); lights.
    apply has_conflict_seq_follow with (get_kind t);
      repeat light || eapply first_fun_complete || eapply should_not_follow_fun_first;
      eauto.

  - destruct xs2 eqn:XS2; lights;
      eauto with has_conflict_ind matches.
    destruct ts' eqn:TSP; repeat light || prefix_sub || prefix.
    + pose proof (visitable_extend _ _ _ _ _ H H5); lights.
      apply has_conflict_seq_follow with (get_kind t);
        repeat light || eapply first_fun_complete || eapply should_not_follow_fun_first;
        eauto.
    + destruct (nullable_fun s1) eqn:N1;
        repeat light || nullable_fun_spec || prefix_sub || prefix.
      * pose proof (visitable_extend _ _ _ _ _ H H5); lights.
        apply has_conflict_seq_follow with (get_kind t);
          repeat light || eapply first_fun_complete || eapply should_not_follow_fun_first;
          eauto.
      * apply has_conflict_seq_l.
        eapply_any;
          repeat light || nullable_fun_spec; eauto.

  - destruct (nullable_fun s1) eqn:N1;
      repeat light || nullable_fun_spec || prefix_sub || prefix.
    destruct (nullable_fun s2) eqn:N2;
      repeat light || nullable_fun_spec || prefix_sub || prefix;
      eauto with matches exfalso.
    destruct ts'; repeat light || nullable_fun_spec.
    apply has_conflict_seq_r.
    eapply_any;
      repeat light || nullable_fun_spec; eauto.

  - eauto with matches exfalso.
  - apply has_conflict_var.
    eapply_any; lights;
      eauto using prefix_var with matches.
Qed.

Lemma visitable_not_nullable_conflict:
  forall x A (s: Syntax A) v,
    visitable x s ->
    prefix s (e x) ->
    (forall v, ~ matches s [] v) ->
    matches (e x) [] v ->
    has_conflict_ind s.
Proof.
  repeat light || visitable_extend.
  destruct ts';
    repeat light; eauto using visitable_not_nullable_conflict' with exfalso.
Qed.

Lemma visitable_not_first_conflict':
  forall x A (s: Syntax A),
    visitable x s ->
    forall k ts v,
      prefix s (e x) ->
      matches s ts v ->
      ~ In k (first_fun s) ->
      In k (first_fun (e x)) ->
      has_conflict_ind s.
Proof.
  induction 1;
    repeat light || invert_matches || prefix_sub || options || destruct_match || nullable_fun_spec ||
           visitable_extend || prefix || app_cons_destruct || invert_constructor_equalities;
    eauto with has_conflict_ind matches first_fun exfalso;
    eauto 6 with has_conflict_ind prefix first_fun.
Qed.

Lemma visitable_not_first_conflict:
  forall x A (s: Syntax A),
    visitable x s ->
    forall t ts v,
      prefix s (e x) ->
      ~ In (get_kind t) (first_fun s) ->
      matches (e x) (t :: ts) v ->
      has_conflict_ind s.
Proof.
  repeat light || visitable_extend;
    eauto using first_fun_complete, visitable_not_first_conflict'.
Qed.

Lemma subsyntax_prefix:
  forall A1 A2 (s1: Syntax A1) (s2: Syntax A2),
    subsyntax s1 s2 ->
    prefix s1 s2.
Proof.
  unfold subsyntax, prefix, accepts;
    repeat light || exists [] || lists; eauto.
Qed.

Lemma subsyntax_prefix_seq_l:
  forall A1 A2 A (s1: Syntax A1) (s2: Syntax A2) (s: Syntax A) ts v,
    subsyntax (Sequence s1 s2) s ->
    matches s2 ts v ->
    prefix s1 s.
Proof.
  unfold subsyntax, accepts, prefix; lights;
    eauto with matches.
Qed.

Lemma visitable_subsyntax_conflict:
  forall x A (s: Syntax A),
    visitable x s ->
    forall ts v,
      matches_without [ x ] s ts v ->
      subsyntax s (e x) ->
      has_conflict_ind s.
Proof.
  induction 1;
    repeat light || invert_matches || inversion_solve || nullable_fun_spec ||
           prefix_sub || invert_constructor_equalities;
    eauto with has_conflict_ind subsyntax.

  - destruct ts; lights.
    + decide_nullable_one s1;
        repeat light || nullable_fun_spec.
      * eapply has_conflict_disj_nullable;
          repeat light || options || destruct_match || nullable_fun_spec;
          eauto using matches_incl, incl_nil.
      * apply has_conflict_disj_l.
        unshelve epose proof (H1 [] _);
          unfold accepts in *; eauto using matches_incl, incl_nil with matches;
            lights.
        apply visitable_not_nullable_conflict with x v0;
          repeat light; eauto using subsyntax_prefix with subsyntax.
    + destruct (in_dec kind_eq_dec (get_kind t) (first_fun s1)).
      * eapply has_conflict_disj_first;
          repeat light || apply_anywhere first_fun_sound || rewrite first_fun_spec ||
                 invert_constructor_equalities;
          eauto 6 using matches_incl, incl_nil with lights.
      * apply has_conflict_disj_l.
        unshelve epose proof (H1 (t :: ts) _);
          unfold accepts in *; eauto using matches_incl, incl_nil with matches;
            lights.
        eapply visitable_not_first_conflict;
          eauto using subsyntax_prefix with subsyntax.

  - destruct ts; lights.
    + decide_nullable_one s2;
        repeat light || nullable_fun_spec.
      * eapply has_conflict_disj_nullable;
          repeat light || options || destruct_match || nullable_fun_spec;
          eauto using matches_incl, incl_nil.
      * apply has_conflict_disj_r.
        unshelve epose proof (H1 [] _);
          unfold accepts in *; eauto using matches_incl, incl_nil with matches;
            lights.
        apply visitable_not_nullable_conflict with x v0;
          repeat light; eauto using subsyntax_prefix with subsyntax.
    + destruct (in_dec kind_eq_dec (get_kind t) (first_fun s2)).
      * eapply has_conflict_disj_first;
          repeat light || apply_anywhere first_fun_sound || rewrite first_fun_spec ||
                 invert_constructor_equalities;
          eauto 6 using matches_incl, incl_nil with lights.
      * apply has_conflict_disj_r.
        unshelve epose proof (H1 (t :: ts) _);
          unfold accepts in *; eauto using matches_incl, incl_nil with matches;
            lights.
        eapply visitable_not_first_conflict;
          eauto using subsyntax_prefix with subsyntax.

  - decide_nullable_one s2;
      repeat light || nullable_fun_spec || unshelve eauto with has_conflict_ind subsyntax.

    destruct xs2; lights; eauto using matches_incl, incl_nil with exfalso.
    destruct xs1; lights; eauto using matches_incl, incl_nil with exfalso.

    + unshelve epose proof (H2 (t :: xs2) _);
        unfold accepts in *; lights; eauto using matches_incl, incl_nil with matches.

      visitable_extend; lights.
      eapply has_conflict_seq_follow;
        repeat light || eapply first_fun_complete || eapply should_not_follow_fun_first;
        eauto with matches.

    + repeat light || productive_fun_spec.
      apply has_conflict_seq_l.
      eapply visitable_prefix_conflict;
        eauto using subsyntax_prefix_seq_l.
Qed.

Lemma self_visitable_conflict:
  forall x ts v,
    matches (Var x) ts v ->
    visitable x (e x) ->
    has_conflict_ind (Var x).
Proof.
  repeat light || invert_matches || matches_forget_x.
  eauto using has_conflict_var, visitable_subsyntax_conflict
    with visitable matches subsyntax has_conflict_ind.
Qed.

Lemma productive_left_recursive_not_ll1:
  forall x,
    productive_ind (Var x) ->
    left_recursive x ->
    ~ ll1_ind (Var x).
Proof.
  unfold ll1_ind, left_recursive; repeat light || rewrite productive_ind_correct in *;
    eauto using self_visitable_conflict.
Qed.


(*|
###########################################
Unable to find an instance for the variable
###########################################

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

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

Context: I'm working on exercises in `Software Foundations
<http://www.cis.upenn.edu/~bcpierce/sf/>`__.

.. coq:: none
|*)

Fixpoint evenb (n : nat) : bool :=
  match n with
  | 0 => true
  | 1 => false
  | S (S m) => evenb m
  end.

(*||*)

Theorem neg_move : forall x y : bool,
    x = negb y -> negb x = y.
Proof. Admitted.

Theorem evenb_n__oddb_Sn : forall n : nat,
    evenb n = negb (evenb (S n)).
Proof.
  intros n. induction n as [| n'].
  - simpl. reflexivity.
  - Fail rewrite -> neg_move. (* .fails *)

(*| Before the last line, my subgoal is this: |*)

    Show. (* .unfold .goals *)

(*| And I want to transform it into this: |*)

    symmetry. (* .none *) apply neg_move. (* .none *) symmetry. (* .none *)
    Show. (* .unfold .goals *)
    Undo 3. (* .none *)

(*|
When I try to step through ``rewrite -> neg_move``, however, it
produces this error:
|*)

    Fail rewrite -> neg_move. (* .unfold .messages *)

(*|
I'm sure this is really simple, but what am I doing wrong? (Please
don't give anything away for solving ``evenb_n__oddb_Sn``, unless I'm
doing it completely wrong).
|*)

(*|
Answer
******

As danportin mentioned, Coq is telling you that it does not know how
to instantiate ``y``. Indeed, when you do ``rewrite -> neg_move``, you
ask it to replace some ``negb x`` by a ``y``. Now, what ``y`` is Coq
supposed to use here? It cannot figure it out.

One option is to instantiate ``y`` explicitly upon rewriting:

.. code-block:: coq

    rewrite -> neg_move with (y:=some_term).

This will perform the rewrite and ask you to prove the premises, here
it will add a subgoal of the form ``x = negb some_term``.

Another option is to specialize ``neg_move`` upon rewriting:

.. code-block:: coq

    rewrite -> (neg_move _ _ H)

Here ``H`` must be a term of type ``some_x = negb some_y``. I put two
wildcards for the ``x`` and the ``y`` parameters of ``neg_move`` since
Coq is able to infer them from ``H`` as being ``some_x`` and
``some_y`` respectively. Coq will then try to rewrite an occurence of
``negb some_x`` in your goal with ``some_y``. But you first need to
get this ``H`` term in your hypotheses, which might be some additional
burden...

(Note that the first option I gave you should be equivalent to
``rewrite -> (neg_move _ some_term)``)

Another option is ``erewrite -> negb_move``, which will add
uninstantiated variables that will look like ``?x`` and ``?y``, and
try to do the rewrite. You will then have to prove the premise, which
will look like ``(evenb (S (S n'))) = negb ?y``, and hopefully in the
process of solving this subgoal, Coq will find out what ``?y`` should
have been from the start (there are some restrictions though, and some
problems may arise is Coq solves the goal without figuring out what
``?y`` must be).

----

However, for your particular problem, it is quite easier:
|*)

    Show. (* .unfold .goals *)
    symmetry.
    Show. (* .unfold .goals *)
    apply neg_move.
    Show. (* .unfold .goals *)

(*|
And that's what you wanted (backwards, do another ``symmetry.`` if you
care).
|*)


(* ------------------------------------------------------- *)
(** #

#
A lew lemmas for common reduction case
used several times in the global lemmas

          Dmitry Burlyaev - Pascal Fradet - 2015
#
#                                           *)
(* ------------------------------------------------------- *)

Add LoadPath "..\..\Common\".
Add LoadPath "..\..\TMRProof\".
Add LoadPath "..\Transf\".
Add LoadPath "..\controlBlock\".
Add LoadPath "..\inputBuffers\".
Add LoadPath "..\outputBuffers\".
Add LoadPath "..\memoryBlocks\".

Require Import dtrTransform relationPred globalInv globalStep inputLib controlLib outputLib memoryLib.

Set Implicit Arguments.

(* ------------------------------------------------------- *)

(* At least 2 buses in a triplicated version are correct (equal to the bus argument) *)
(* Used in the main lemmas and the final correctness property                        *)

Inductive atleast2 : forall S, {|S|} -> {|S#(S#S)|} -> Prop :=
| Al2_1 : forall S (s t:{|S|}), atleast2 s {s,{s,t}}
| Al2_2 : forall S (s t:{|S|}), atleast2 s {s,{t,s}}
| Al2_3 : forall S (s t:{|S|}), atleast2 s {t,{s,s}}.
Hint Constructors atleast2.

(* Cases of reduction occurring several times in step(g) reduction of the complete transformed circuit *)

Lemma case1_df : forall S T (i1 i2 i3 i4 i5: {|S|}) (o1 o2 o3 o4 o5 y z: {|T|})
                             oo3 oo4 oo5 oo6 oo7 oo8 oo9
                            (c1 c2 c3 c4 c5 c6: circuit S T)
                        (cc2' cc3 cc3' cc4 cc4' cc5 cc5' cc6: circuit S (T # (T # T))),
                 pure_bset {i1,i2,i3,i4,i5,o1,o2,o3,o4,o5,y,z}
              -> Dtr1_df (ibs1 i2 i1) (dtrOB_T z o1 z o1 y) c1 c2 c3 cc2'
              -> step c1 i1 o1 c2
              -> step c2 i2 o2 c3
              -> step c3 i3 o3 c4
              -> step c4 i4 o4 c5
              -> step c5 i5 o5 c6
              -> step cc2' i2 oo3 cc3
              -> step cc3  i3 oo4 cc3'
              -> step cc3' i3 oo5 cc4
              -> step cc4  i4 oo6 cc4'
              -> step cc4' i4 oo7 cc5
              -> step cc5  i5 oo8 cc5'
              -> step cc5' i5 oo9 cc6
              -> atleast2 o1 oo3
              /\ atleast2 o2 oo5
              /\ atleast2 o3 oo7
              /\ atleast2 o4 oo9
              /\  Dtrs0 (ibs0 i5) (obs0 o5 o4) c5 c6 cc6.
Proof.
introv P D S2 S3 S4 S5 S6.
introv SS4 SS5 SS6 SS7 SS8 SS9 SS10. SimpS.
Apply step_Dtr1_df with S2 S3 SS4 in D. SimpS.
Apply step_Dtr2_d'rr'' with S3 S4 SS5 in H12. SimpS.
Apply step_Dtr3_d'rr'' with S4 SS6 in H12. SimpS.
Apply step_Dtr4_d'rr' with S5 SS7 in H12. SimpS.
Apply step_Dtr5_d'rr' with SS8 in H12. SimpS.
Apply step_Dtr0_r' with S6 SS9 in H12. SimpS.
Apply step_Dtr1_r' with SS10 in H12. SimpS. split; easy.
Qed.

Lemma case3_d'rr' : forall S T (i1 i2 i3 i4 i5: {|S|}) (o0 o1 o2 o3 o4 o5 x: {|T|})
                             oo3 oo4 oo5 oo6 oo7 oo8 oo9
                            (c1 c2 c3 c4 c5 c6: circuit S T)
                        (cc2' cc3 cc3' cc4 cc4' cc5 cc5' cc6: circuit S (T # (T # T))),
                 pure_bset {i1,i2,i3,i4,i5,o0,o1,o2,o3,o4,o5,x}
              -> Dtr3_d'rr' (ibs1 i2 i1) (dtrOB_T o1 o0 o1 o0 x) c1 c2 cc2'
              -> step c1 i1 o1 c2
              -> step c2 i2 o2 c3
              -> step c3 i3 o3 c4
              -> step c4 i4 o4 c5
              -> step c5 i5 o5 c6
              -> step cc2' i2 oo3 cc3
              -> step cc3  i3 oo4 cc3'
              -> step cc3' i3 oo5 cc4
              -> step cc4  i4 oo6 cc4'
              -> step cc4' i4 oo7 cc5
              -> step cc5  i5 oo8 cc5'
              -> step cc5' i5 oo9 cc6
              -> atleast2 o1 oo3
              /\ atleast2 o2 oo5
              /\ atleast2 o3 oo7
              /\ atleast2 o4 oo9
              /\  Dtrs0 (ibs0 i5) (obs0 o5 o4) c5 c6 cc6.
Proof.
introv P D S2 S3 S4 S5 S6.
introv SS4 SS5 SS6 SS7 SS8 SS9 SS10. SimpS.
Apply step_Dtr3_d'rr'' with S3 SS4 in D. SimpS.
Apply step_Dtr4_d'rr' with S4 SS5 in H12. SimpS.
Apply step_Dtr5_d'rr' with S4 SS6 in H12. SimpS.
Apply step_Dtr0_r' with S5 SS7 in H12. SimpS.
Apply step_Dtr1_r' with S5 SS8 in H12. SimpS.
Apply step_Dtrs0 with S6 SS9 in H12. SimpS.
Apply step_Dtrs1 with S6 SS10 in H12. SimpS.
split; easy.
Qed.

Lemma case0_dr : forall S T (i0 i1 i2 i3 i4: {|S|})
                           (o o0 o1 o2 o3 o4 z1 z2: {|T|})
                           (oo1 oo2 oo3 oo4 oo5 oo6 oo7 oo8:{|T # (T # T)|})
                           (c0 c1 c2 c3 c4 c5: circuit S T)
                           (cc1' cc2 cc2' cc3 cc3' cc4 cc4' cc5: circuit S (T # (T # T))) cc1 f f' f'',
                pure_bset {i0,i1,i2,i3,i4,o,o0,o1,o2,o3,o4,z1,z2}
             -> dtr0_dr c0 c1 cc1
             -> step c0 i0 o0 c1
             -> step c1 i1 o1 c2
             -> step c2 i2 o2 c3
             -> step c3 i3 o3 c4
             -> step c4 i4 o4 c5
             -> step (-{f}-(-{f'}-(-{f''}-dtrcore (ibs0 i0) cbs0 cc1 (dtrOB_T z1 o0 z2 o0 o)))) i1 oo1 cc1'
             -> step cc1' i1 oo2 cc2
             -> step cc2  i2 oo3 cc2'
             -> step cc2' i2 oo4 cc3
             -> step cc3  i3 oo5 cc3'
             -> step cc3' i3 oo6 cc4
             -> step cc4  i4 oo7 cc4'
             -> step cc4' i4 oo8 cc5
             -> atleast2 o0 oo2
             /\ atleast2 o1 oo4
             /\ atleast2 o2 oo6
             /\ atleast2 o3 oo8
             /\ Dtrs0 (ibs0 i4) (obs0 o4 o3) c4 c5 cc5.
Proof.
introv P D S1 S2 S3 S4 S5.
introv SS1 SS2 SS3 SS4 SS5 SS6 SS7 SS8. SimpS.
Apply invstepDTRc in SS1. SimpS.
Apply step0_tcbv in H13. SimpS.
Apply step_ibs in H12; try apply pure_buildBus. SimpS.
Apply step0_mb_dr_F with D S2 in H14.
destruct H14 as [X1|X1]; SimpS.
- Apply step_obs_sf in H15. SimpS.
  rewrite rew_orS2 in H16. Inverts H16.
  assert (D1: Dtr1_d'rf (ibs1 i1 i0) (dtrOB_T o1 z1 o1 z2 o0) c0 c1 c2
                     (globcir (true,true,true) cbs1 (ibs1 i1 i0) x40 (dtrOB_T o1 z1 o1 z2 o0)))
      by (constructor; try easy).
  Apply step_Dtr1_d'rf with SS2 in D1. SimpS.
  Apply step_Dtr2_d'rr' with S2 S3 SS3 in H14. SimpS.
  Apply step_Dtr3_d'rr' with S3 SS4 in H14. SimpS.
  Apply step_Dtr4_d'rr' with S4 SS5 in H14. SimpS.
  Apply step_Dtr5_d'rr' with SS6 in H14. SimpS.
  Apply step_Dtr0_r' with S5 SS7 in H14. SimpS.
  Apply step_Dtr1_r' with S5 SS8 in H14. SimpS.
  split; easy.
- Apply step_obs_sf in H15. SimpS.
  case_eq (beq_buset_t z2 o0); intro E; rewrite E in H16; Inverts H16.
  + apply beq_buset_imp_eq in E. subst.
    assert (D1: Dtr1_r (ibs1 i1 i0) (dtrOB_T o1 z1 o1 o0 o0) c0 c1 c2
                     (globcir (false,false,false) cbs1 (ibs1 i1 i0) x40 (dtrOB_T o1 z1 o1 o0 o0)))
        by (constructor; try easy).
    Apply step_Dtr1_r with SS2 in D1. SimpS.
    Apply step_Dtr0_r' with S3 SS3 in H14. SimpS.
    Apply step_Dtr1_r' with SS4 in H12. SimpS.
    Apply step_Dtrs0 with S4 SS5 in H12. SimpS.
    Apply step_Dtrs1 with SS6 in H12. SimpS.
    Apply step_Dtrs0 with S5 SS7 in H12. SimpS.
    Apply step_Dtrs1 with SS8 in H12. SimpS.
    split; easy.
  + apply dtr1_r_imp_d'r in H13.
    assert (D1: Dtr1_d'rf (ibs1 i1 i0) (dtrOB_T o1 z1 o1 z2 o0) c0 c1 c2
                     (globcir (true,true,true) cbs1 (ibs1 i1 i0) x40 (dtrOB_T o1 z1 o1 z2 o0)))
        by (constructor; try easy).
    Apply step_Dtr1_d'rf with SS2 in D1. SimpS.
    Apply step_Dtr2_d'rr' with S3 SS3 in H14. SimpS.
    Apply step_Dtr3_d'rr' with S3 SS4 in H14. SimpS.
    Apply step_Dtr4_d'rr' with S4 SS5 in H14. SimpS.
    Apply step_Dtr5_d'rr' with SS6 in H14. SimpS.
    Apply step_Dtr0_r' with S5 SS7 in H14. SimpS.
    Apply step_Dtr1_r' with S5 SS8 in H14. SimpS.
    split; easy.
Qed.

Lemma foursteps: forall S T (i3 i4 i5: {|S|})
                           (o2 o3 o4 o5: {|T|})
                           (oo6 oo7 oo8 oo9:{|T # (T # T)|})
                           (c3 c4 c5 c6: circuit S T)
                           (cc4 cc4' cc5 cc5' cc6: circuit S (T # (T # T))),
                pure_bset {i3,i4,i5,o2,o3,o4,o5}
             -> Dtrs0 (ibs0 i3) (obs0 o3 o2) c3 c4 cc4
             -> step c4 i4 o4 c5
             -> step c5 i5 o5 c6
             -> step cc4  i4 oo6 cc4'
             -> step cc4' i4 oo7 cc5
             -> step cc5  i5 oo8 cc5'
             -> step cc5' i5 oo9 cc6
             -> atleast2 o3 oo7
             /\ atleast2 o4 oo9
             /\ Dtrs0 (ibs0 i5) (obs0 o5 o4) c5 c6 cc6.
Proof.
introv P D S5 S6.
introv SS6 SS7 SS8 SS9. SimpS.
Apply step_Dtrs0 with S5 SS6 in D. SimpS.
Apply step_Dtrs1 with S5 SS7 in H7. SimpS.
Apply step_Dtrs0 with S6 SS8 in H7. SimpS.
Apply step_Dtrs1 with S6 SS9 in H7. SimpS.
easy.
Qed.

Lemma sixsteps: forall S T (i2 i3 i4 i5: {|S|})
                           (o1 o2 o3 o4 o5: {|T|})
                           (oo4 oo5 oo6 oo7 oo8 oo9:{|T # (T # T)|})
                           (c2 c3 c4 c5 c6: circuit S T)
                           (cc3 cc3' cc4 cc4' cc5 cc5' cc6: circuit S (T # (T # T))),
                pure_bset {i2,i3,i4,i5,o1,o2,o3,o4,o5}
             -> Dtrs0 (ibs0 i2) (obs0 o2 o1) c2 c3 cc3
             -> step c3 i3 o3 c4
             -> step c4 i4 o4 c5
             -> step c5 i5 o5 c6
             -> step cc3  i3 oo4 cc3'
             -> step cc3' i3 oo5 cc4
             -> step cc4  i4 oo6 cc4'
             -> step cc4' i4 oo7 cc5
             -> step cc5  i5 oo8 cc5'
             -> step cc5' i5 oo9 cc6
             -> atleast2 o2 oo5
             /\ atleast2 o3 oo7
             /\ atleast2 o4 oo9
             /\ Dtrs0 (ibs0 i5) (obs0 o5 o4) c5 c6 cc6.
Proof.
introv P D S4 S5 S6.
introv SS4 SS5 SS6 SS7 SS8 SS9. SimpS.
Apply step_Dtrs0 with S4 SS4 in D. SimpS.
Apply step_Dtrs1 with S4 SS5 in H9. SimpS.
split. easy.
eapply foursteps. 2: exact H9. 2: exact S5. 2: exact S6. 2: exact SS6.
                  2: exact SS7. 2: exact SS8. 2: exact SS9. CheckPure.
Qed.

Lemma eightsteps: forall S T (i1 i2 i3 i4 i5: {|S|})
                           (o0 o1 o2 o3 o4 o5: {|T|})
                           (oo2 oo3 oo4 oo5 oo6 oo7 oo8 oo9:{|T # (T # T)|})
                           (c1 c2 c3 c4 c5 c6: circuit S T)
                           (cc2 cc2' cc3 cc3' cc4 cc4' cc5 cc5' cc6: circuit S (T # (T # T))),
                pure_bset {i1,i2,i3,i4,i5,o0,o1,o2,o3,o4,o5}
             -> Dtrs0 (ibs0 i1) (obs0 o1 o0) c1 c2 cc2
             -> step c2 i2 o2 c3
             -> step c3 i3 o3 c4
             -> step c4 i4 o4 c5
             -> step c5 i5 o5 c6
             -> step cc2  i2 oo2 cc2'
             -> step cc2' i2 oo3 cc3
             -> step cc3  i3 oo4 cc3'
             -> step cc3' i3 oo5 cc4
             -> step cc4  i4 oo6 cc4'
             -> step cc4' i4 oo7 cc5
             -> step cc5  i5 oo8 cc5'
             -> step cc5' i5 oo9 cc6
             -> atleast2 o1 oo3
             /\ atleast2 o2 oo5
             /\ atleast2 o3 oo7
             /\ atleast2 o4 oo9
             /\ Dtrs0 (ibs0 i5) (obs0 o5 o4) c5 c6 cc6.
Proof.
introv P D S3 S4 S5 S6.
introv SS2 SS3 SS4 SS5 SS6 SS7 SS8 SS9. SimpS.
eapply foursteps in D. 3: exact S3. 3: exact S4. 3: exact SS2. 3: exact SS3.
                       3: exact SS4. 3: exact SS5. 2: CheckPure. SimpS.
split. easy. split. easy.
eapply foursteps. 2: exact H12. 2: exact S5. 2: exact S6. 2: exact SS6.
                  2: exact SS7. 2: exact SS8. 2: exact SS9. CheckPure.
Qed.


Require Import ImperativeOp Lists.List.
Import ListNotations.

Definition P :=
    Int const 0 :=: (VInt 1);;
    Int  var 1;;
    Bool var 2;;
    (Var 1) ::= Num (VInt 0);;

    While (Op (Var 1) neq  (Num (VInt 1)))
      (Var 1) ::= (Op (Var 1) plus (Const 0)).

  Definition E := [(2, VarType 1 Bool);
                   (1, VarType 0 Int);
                   (0, ConstType Int (VInt 1))].

  Definition M := [(1, VBool false); (0, VInt 1)].

  Example e : ([],[]) {{P}} (E,M).
   Proof. eapply EvSeq.
     - apply EvDeclC.
     - eapply EvSeq.
       * apply EvDecl.
       * eapply EvSeq.
         + apply EvDecl.
         + eapply EvSeq.
           -- apply EvAss.
              ** eapply EvVarL. reflexivity.
              ** apply EvNumR.
           -- eapply EvWhileT.
                ** eapply EvNeqTR.
                   ++ eapply EvVarR.
                      --- reflexivity.
                      --- reflexivity.
                   ++ apply EvNumR.
                   ++ intros H. inversion H.
                ** eapply EvSeq.
                   ++ apply EvAss.
                      --- eapply EvVarL. reflexivity.
                      --- eapply EvPlusR.
                          *** eapply EvVarR. reflexivity. reflexivity.
                          *** eapply EvConstR. reflexivity.
                          *** reflexivity.
                   ++ eapply EvWhileF.
                     --- eapply EvNeqFR.
                         *** eapply EvVarR.
                             +++ reflexivity.
                             +++ reflexivity.
                         *** apply EvNumR.
                         *** reflexivity.
  Qed.

  Example e2 : ([],[]) {{P}} (E,M).
  Proof. repeat econstructor. auto. Qed.


Require Import core core_axioms unscoped.
Import UnscopedNotations.

(** Eta laws. *)
Lemma scons_eta_id {n : nat} : var_zero .: shift = id :> (nat -> nat).
Proof. fext. intros [|x]; reflexivity. Qed.

Lemma scons_eta {T} (f : nat -> T) :
  f var_zero .: shift >> f = f.
Proof. fext. intros [|x]; reflexivity. Qed.

Lemma scons_comp (T: Type) U (s: T) (sigma: nat -> T) (tau: T -> U ) :
  (s .: sigma) >> tau = scons (tau s) (sigma >> tau) .
Proof.
  fext. intros [|x]; reflexivity.
Qed.

(** Generic fsimpl tactic: simplifies the above primitives in a goal. *)
Ltac fsimpl :=
  unfold up_ren; repeat match goal with
         | [|- context[id >> ?f]] => change (id >> f) with f (* AsimplCompIdL *)
         | [|- context[?f >> id]] => change (f >> id) with f (* AsimplCompIdR *)
         | [|- context [id ?s]] => change (id s) with s
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((?f >> ?g) >> ?h) with (f >> (g >> h)) (* AsimplComp *)
         | [|- context[(?s.:?sigma) var_zero]] => change ((s.:sigma)var_zero) with s
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((f >> g) >> h) with (f >> (g >> h))
        | [|- context[?f >> (?x .: ?g)]] =>
           change (f >> (x .: g)) with g
         | [|- context[var_zero]] =>  change var_zero with 0
         | [|- context[?x2 .: shift >> ?f]] =>
           change x2 with (f 0); rewrite (@scons_eta _ _ f)
         | [|- context[(?v .: ?g) 0]] =>
           change ((v .: g) 0) with v
         | [|- context[(?v .: ?g) (S ?n)]] =>
           change ((v .: g) (S n)) with (g n)
         | [|- context[?f 0 .: ?g]] =>
           change g with (shift >> f); rewrite scons_eta
         | _ => first [progress (rewrite ?scons_comp) | progress (rewrite ?scons_eta_id)]
 end.

(** Generic fsimpl tactic: simplifies the above primitives in the context *)
Ltac fsimplc :=
  unfold up_ren; repeat match goal with
         | [H : context[id >> ?f] |- _] => change (id >> f) with f in H(* AsimplCompIdL *)
         | [H: context[?f >> id] |- _] => change (f >> id) with f in H(* AsimplCompIdR *)
         | [H: context [id ?s] |- _]  => change (id s) with s in H
         | [H:  context[(?f >> ?g) >> ?h]  |- _] =>
           change ((?f >> ?g) >> ?h) with (f >> (g >> h)) in H(* AsimplComp *)
         | [H : context[(?s.:?sigma) var_zero]  |- _] => change ((s.:sigma)var_zero) with s in H
         | [H: context[(?f >> ?g) >> ?h]  |- _] =>
           change ((f >> g) >> h) with (f >> (g >> h)) in H
        | [H: context[?f >> (?x .: ?g)]  |- _] =>
           change (f >> (x .: g)) with g in H
         | [H: context[var_zero]  |- _] =>  change var_zero with 0 in H
         | [H: context[?x2 .: shift >> ?f]  |- _] =>
           change x2 with (f 0) in H; rewrite (@scons_eta _ _ f) in H
         | [H: context[(?v .: ?g) 0]  |- _] =>
           change ((v .: g) 0) with v in H
         | [H: context[(?v .: ?g) (S ?n)]  |- _] =>
           change ((v .: g) (S n)) with (g n) in H
         | [H: context[?f 0 .: ?g]  |- _] =>
           change g with (shift >> f); rewrite scons_eta in H
         | _ => first [progress (rewrite ?scons_comp in *)  | progress (rewrite ?scons_eta_id in *) ]
 end.

(** Simplification in both the goal and the context *)
Tactic Notation "fsimpl" "in" "*" :=
  fsimpl; fsimplc.


(* Test the behaviour of hnf and simpl introduced in revision *)

Parameter n:nat.
Definition a:=0.

Eval simpl in (fix plus (n m : nat) {struct n} : nat :=
  match n with
  | 0 => m
  | S p => S (p + m)
  end) a a.

Eval hnf in match (plus (S n) O) with S n => n | _ => O end.


(**
  [TypeTheory.Initiality.Typing]

  Part of the [Initiality] package for the [UniMath.TypeTheory] library

  This file sets up the contexts, judgements, and derivations of the toy type theory under consideration.
*)

Require Import UniMath.MoreFoundations.All.
Require Import TypeTheory.Initiality.Syntax.

Section Contexts.
  (** Note: for now, we take the type expressions of a context to be over _all_ variables of the context, not just the earlier ones — so-called _flat_ contexts, as opposed to _stratified_.  We will add stratification later, in [SplitTypeCat_Contextual].

  See Bauer–Lumsdaine–Hasselwarter 2020 on general type theories for a discussion of the philosophy of this choice. Also note how in the present proof of initiality, it works nicely: the main interpretation proof never mentions stratification, nor context equality, working entirely with naturality in typed flat contexts. *)
  Definition context_of_length n := dB_vars n -> ty_expr n.
  Identity Coercion id_context_of_length : context_of_length >-> Funclass.

  Definition context
    := ∑ (n : nat), context_of_length n.

  Definition context_length : context -> nat := pr1.
  Coercion context_length : context >-> nat.

  Definition context_types : forall Γ : context, _ := pr2.
  Coercion context_types : context >-> context_of_length.

  Definition make_context {n} : context_of_length n -> context
    := fun Γ => (n,,Γ).
  Coercion make_context : context_of_length >-> context.

  Definition empty_context : context
    := make_context (dB_0_rect _).

  Definition context_extend (Γ : context) (A : ty_expr Γ) : context.
  Proof.
    exists (S (context_length Γ)).
    refine (rename_ty dB_next ∘ _).
    refine (dB_Sn_rect _ _ _).
    - exact A.
    - intros i. exact (Γ i).
  Defined.

End Contexts.

Arguments context_extend : simpl never.

Delimit Scope context_scope with context.
Bind Scope context_scope with context.
Bind Scope context_scope with context_of_length.
Notation "[: :]" := (empty_context) (format "[: :]") : context_scope.
Notation "Γ ;; A"
  := (context_extend Γ A) (at level 50, left associativity) : context_scope.
(* TODO: not sure what level to use here; try it and see… *)
Notation "[: A ; .. ; Z :] "
  := (context_extend .. (context_extend (empty_context) A) .. Z) : context_scope.

Section Judgements.

(** NOTE: we take as primitive just the four main hypothetical judgements.

Other judgements, such as well-formed contexts and context maps, will be “auxiliary” judgements defined in terms of these afterwards.

The inductive definition of derivability involves only the primitive judgements. *)
  Polymorphic Inductive judgement
  :=
    | ty_judgement (Γ : context) (A : ty_expr Γ)
    | tyeq_judgement (Γ : context) (A A' : ty_expr Γ)
    | tm_judgement (Γ : context) (A : ty_expr Γ) (a : tm_expr Γ)
    | tmeq_judgement (Γ : context) (A : ty_expr Γ) (a a' : tm_expr Γ).

End Judgements.

Delimit Scope judgement_scope with judgement.
Bind Scope judgement_scope with judgement.
Open Scope judgement_scope.

Notation "[! Γ |- A === B !]" := (tyeq_judgement Γ A B) (format "[!  Γ  |-  A  ===  B  !]")  : judgement_scope.
Notation "[! Γ |- A !]" := (ty_judgement Γ A) (format "[!  Γ  |-  A  !]")  : judgement_scope.
Notation "[! Γ |- a ::: A !]" := (tm_judgement Γ A a) (format "[!  Γ  |-  a  :::  A  !]")  : judgement_scope.
Notation "[! Γ |- a === a' ::: A !]" := (tmeq_judgement Γ A a a') (format "[!  Γ  |-  a  ===  a'  :::  A  !]")  : judgement_scope.
(* NOTE: these [===], [:::] are horrible!  But I can’t make it work with just e.g. [=], since parsing fails as [=] is already a binary notation (even if the scope of that notation is closed).  Is it possible to use better scoping to allow just [=] here, and so on? *)

Section Derivations.

  Inductive derivation : judgement -> UU
  :=
    (** variable rule *)
    | derive_var (Γ : context) (i : Γ)
      :    derivation [! Γ |- Γ i !]
      -> derivation [! Γ |- (var_expr i) ::: Γ i !]
    (** structural rules for equality: equiv rels, plus type-conversion *)
    | derive_tyeq_refl (Γ : context) (A : _)
      :    derivation [! Γ |- A !]
      -> derivation [! Γ |- A === A !]
    | derive_tyeq_sym (Γ : context) (A A' : _)
      :    derivation [! Γ |- A === A' !]
      -> derivation [! Γ |- A' === A !]
    | derive_tyeq_trans (Γ : context) (A0 A1 A2 : _)
      :    derivation [! Γ |- A0 !]
        -> derivation [! Γ |- A1 !]
        -> derivation [! Γ |- A2 !]
        -> derivation [! Γ |- A0 === A1 !]
        -> derivation [! Γ |- A1 === A2 !]
      -> derivation [! Γ |- A0 === A2 !]
    | derive_tmeq_refl (Γ : context) (A : _) (a : _)
      :    derivation [! Γ |- a ::: A !]
      -> derivation [! Γ |- a === a ::: A !]
    | derive_tmeq_sym (Γ : context) (A : _) (a a' : _)
      :    derivation [! Γ |- a === a' ::: A !]
      -> derivation [! Γ |- a' === a ::: A !]
    | derive_tmeq_trans (Γ : context) (A : _) (a0 a1 a2 : _)
      :    derivation [! Γ |- a0 ::: A !]
        -> derivation [! Γ |- a1 ::: A !]
        -> derivation [! Γ |- a2 ::: A !]
        -> derivation [! Γ |- a0 === a1 ::: A !]
        -> derivation [! Γ |- a1 === a2 ::: A !]
      -> derivation [! Γ |- a0 === a2 ::: A !]
    | derive_tm_conv (Γ : context) (A A' : _) (a : _)
      :    derivation [! Γ |- A !]
        -> derivation [! Γ |- A' !]
        -> derivation [! Γ |- A === A' !]
        -> derivation [! Γ |- a ::: A !]
      -> derivation [! Γ |- a ::: A' !]
    | derive_tmeq_conv (Γ : context) (A A' : _) (a a' : _)
      :    derivation [! Γ |- A !]
        -> derivation [! Γ |- A' !]
        -> derivation [! Γ |- A === A' !]
        -> derivation [! Γ |- a === a' ::: A !]
      -> derivation [! Γ |- a === a' ::: A' !]

    (** logical rules  *)
    | derive_U (Γ : context)
      : derivation [! Γ |- U_expr !]
    | derive_El (Γ : context) (a : _)
      :    derivation [! Γ |- a ::: U_expr !]
      -> derivation [! Γ |- El_expr a !]
    | derive_Pi (Γ : context) (A : _) (B : _)
      :    derivation [! Γ |- A !]
        -> derivation [! Γ ;; A |- B !]
      -> derivation [! Γ |- Pi_expr A B !]
    | derive_lam (Γ : context) A B b
      :    derivation [! Γ |- A !]
        -> derivation [! Γ ;; A |- B !]
        -> derivation [! Γ ;; A |- b ::: B !]
      -> derivation [! Γ |- lam_expr A B b ::: Pi_expr A B !]
    | derive_app (Γ : context) A B f a
      :    derivation [! Γ |- A !]
        -> derivation [! Γ ;; A |- B !]
        -> derivation [! Γ |- f ::: Pi_expr A B !]
        -> derivation [! Γ |- a ::: A !]
      -> derivation [! Γ |- app_expr A B f a ::: subst_top_ty a B !]
    | derive_beta (Γ : context) A B b a
      :    derivation [! Γ |- A !]
        -> derivation [! Γ ;; A |- B !]
        -> derivation [! Γ ;; A |- b ::: B !]
        -> derivation [! Γ |- a ::: A !]
      -> derivation
             [! Γ |- app_expr A B (lam_expr A B b) a === subst_top_tm a b
                                                     ::: subst_top_ty a B !]

    (** congruence rules for constructors *)
    (* no congruence rule needed for U *)
    | derive_El_cong (Γ : context) (a a' : _)
      :    derivation [! Γ |- a === a' ::: U_expr !]
      -> derivation [! Γ |- El_expr a === El_expr a' !]
    | derive_Pi_cong (Γ : context) (A A' : _) (B B' : _)
      :    derivation [! Γ |- A !]
        -> derivation [! Γ |- A === A' !]
        -> derivation [! Γ ;; A |- B === B' !]
      -> derivation [! Γ |- Pi_expr A B === Pi_expr A' B' !]
    | derive_lam_cong (Γ : context) A A' B B' b b'
      :    derivation [! Γ |- A !]
        -> derivation [! Γ |- A === A' !]
        -> derivation [! Γ ;; A |- B === B' !]
        -> derivation [! Γ ;; A |- b === b' ::: B !]
      -> derivation [! Γ |- lam_expr A B b === lam_expr A' B' b'
                                                 ::: Pi_expr A B !]
    | derive_app_cong (Γ : context) A A' B B' f f' a a'
      :    derivation [! Γ |- A !]
        -> derivation [! Γ |- A === A' !]
        -> derivation [! Γ ;; A |- B === B' !]
        -> derivation [! Γ |- f === f' ::: Pi_expr A B !]
        -> derivation [! Γ |- a === a' ::: A !]
      -> derivation [! Γ |- app_expr A B f a === app_expr A' B' f' a'
                                                   ::: subst_top_ty a B !]
  .

  Coercion derivation : judgement >-> UU.

End Derivations.

Section Derivation_Helpers.
(** Some utility functions to make inductions over derivations more manageable.*)

  Local Open Scope context_scope.

  Context (P : forall J:judgement, derivation J -> Type).
  Local Arguments P {_} _.

  Definition case_for_var_rule
  := forall (Γ : context) (i : Γ)
            (d_Γi : [! Γ |- Γ i !]) (p_Γi : P d_Γi),
    P (derive_var Γ i d_Γi).

  Record cases_for_equiv_rel_rules
  := {
    case_tyeq_refl
    : forall (Γ : context) (A : ty_expr Γ)
             (d : [! Γ |- A !]) (p : P d),
        P (derive_tyeq_refl Γ A d)
  ; case_teq_sym
    : forall (Γ : context) (A A' : ty_expr Γ)
             (d : [! Γ |- A === A' !]) (p : P d),
      P (derive_tyeq_sym Γ A A' d)
  ; case_tyeq_trans
    : forall (Γ : context) (A0 A1 A2 : ty_expr Γ)
             (d0 : [! Γ |- A0 !]) (p0 : P d0)
             (d1 : [! Γ |- A1 !]) (p1 : P d1)
             (d2 : [! Γ |- A2 !]) (p2 : P d2)
             (d01 : [! Γ |- A0 === A1 !]) (p01 : P d01)
             (d12 : [! Γ |- A1 === A2 !]) (p12 : P d12),
      P (derive_tyeq_trans Γ A0 A1 A2 d0 d1 d2 d01 d12)
  ; case_tmeq_refl
    : forall (Γ : context) (A : ty_expr Γ) (a : tm_expr Γ)
             (d : [! Γ |- a ::: A !]) (p : P d),
      P (derive_tmeq_refl Γ A a d)
  ; case_tmeq_sym
    : forall (Γ : context) (A : ty_expr Γ) (a a' : tm_expr Γ)
             (d : [! Γ |- a === a' ::: A !]) (p : P d),
      P (derive_tmeq_sym Γ A a a' d)
  ; case_tmeq_trans
    : forall (Γ : context) (A : ty_expr Γ) (a0 a1 a2 : tm_expr Γ)
             (d0 : [! Γ |- a0 ::: A !]) (p0 : P d0)
             (d1 : [! Γ |- a1 ::: A !]) (p1 : P d1)
             (d2 : [! Γ |- a2 ::: A !]) (p2 : P d2)
             (d01 : [! Γ |- a0 === a1 ::: A !]) (p01 : P d01)
             (d12 : [! Γ |- a1 === a2 ::: A !]) (p12 : P d12),
      P (derive_tmeq_trans Γ A a0 a1 a2 d0 d1 d2 d01 d12)
  }.

  Record cases_for_conv_rules
  := {
    case_tm_conv
    : forall (Γ : context) (A A' : ty_expr Γ) (a : tm_expr Γ)
             (d_A : [! Γ |- A !]) (p_A : P d_A)
             (d_A' : [! Γ |- A' !]) (p_A' : P d_A')
             (d_AA' : [! Γ |- A === A' !]) (p_AA' : P d_AA')
             (d_a : [! Γ |- a ::: A !]) (p_a : P d_a),
        P (derive_tm_conv Γ A A' a d_A d_A' d_AA' d_a)
  ; case_tmeq_conv
    : forall (Γ : context) (A A' : ty_expr Γ) (a a' : tm_expr Γ)
             (d_A : [! Γ |- A !]) (p_A : P d_A)
             (d_A' : [! Γ |- A' !]) (p_A' : P d_A')
             (d_AA' : [! Γ |- A === A' !]) (p_AA' : P d_AA')
             (d_aa' : [! Γ |- a === a' ::: A !]) (p_aa' : P d_aa'),
      P (derive_tmeq_conv Γ A A' a a' d_A d_A' d_AA' d_aa')
  }.

  Record cases_for_universe_rules
  := {
    case_for_U
    : forall (Γ : context),
        P (derive_U Γ)
  ; case_for_El
    : forall (Γ : context) (a : tm_expr Γ)
             (d_a : [! Γ |- a ::: U_expr !]) (p_a : P d_a),
      P (derive_El Γ a d_a)
  ; case_for_El_cong
    : forall (Γ : context) (a a' : tm_expr Γ)
             (d_aa' : [! Γ |- a === a' ::: U_expr !]) (p_aa' : P d_aa'),
      P (derive_El_cong Γ a a' d_aa')
  }.

  Record cases_for_pi_rules
  := {
    case_for_Pi
    : forall (Γ : context) (A : ty_expr Γ) (B : ty_expr (Γ ;; A))
             (d_A : [! Γ |- A !]) (p_A : P d_A)
             (d_B : [! Γ ;; A |- B !]) (p_B : P d_B),
      P (derive_Pi Γ A B d_A d_B)
  ; case_for_lam
    : forall (Γ : context) (A : ty_expr Γ) (B : ty_expr (Γ ;; A))
             (b : tm_expr (Γ ;; A))
             (d_A : [! Γ |- A !]) (p_A : P d_A)
             (d_B : [! Γ ;; A |- B !]) (p_B : P d_B)
             (d_b : [! Γ ;; A |- b ::: B !]) (p_b : P d_b),
      P (derive_lam Γ A B b  d_A d_B d_b)
  ; case_for_app
    : forall (Γ : context) (A : ty_expr Γ) (B : ty_expr (Γ ;; A))
             (f a : tm_expr Γ)
             (d_A : [! Γ |- A !]) (p_A : P d_A)
             (d_B : [! Γ ;; A |- B !]) (p_B : P d_B)
             (d_f : [! Γ |- f ::: Pi_expr A B !]) (p_f : P d_f)
             (d_a : [! Γ |- a ::: A !]) (p_a : P d_a),
      P (derive_app Γ A B f a d_A d_B d_f d_a)
  ; case_for_beta
    : forall (Γ : context) (A : ty_expr Γ) (B : ty_expr (Γ ;; A))
             (b : tm_expr (Γ ;; A)) (a : tm_expr Γ)
             (d_A : [! Γ |- A !]) (p_A : P d_A)
             (d_B : [! Γ ;; A |- B !]) (p_B : P d_B)
             (d_b : [! Γ ;; A |- b ::: B !]) (p_b : P d_b)
             (d_a : [! Γ |- a ::: A !]) (p_a : P d_a),
      P (derive_beta Γ A B b a d_A d_B d_b d_a)
  }.

  Record cases_for_pi_cong_rules
  := {
    case_for_Pi_cong
    : forall (Γ : context) (A A' : ty_expr Γ) (B B' : ty_expr (Γ ;; A))
        (d_A : [! Γ |- A !]) (p_A : P d_A)
        (d_AA : [! Γ |- A === A' !]) (p_AA : P d_AA)
        (d_BB : [! Γ ;; A |- B === B' !]) (p_BB : P d_BB),
      P (derive_Pi_cong Γ A A' B B' d_A d_AA d_BB)
  ; case_for_lam_cong
    : forall (Γ : context) (A A' : ty_expr Γ) (B B' : ty_expr (Γ ;; A))
        (b b' : tm_expr (Γ ;; A))
        (d_A : [! Γ |- A !]) (p_A : P d_A)
        (d_AA : [! Γ |- A === A' !]) (p_AA : P d_AA)
        (d_BB : [! Γ ;; A |- B === B' !]) (p_BB : P d_BB)
        (d_bb : [! Γ ;; A |- b === b' ::: B !]) (p_bb : P d_bb),
      P (derive_lam_cong Γ A A' B B' b b' d_A d_AA d_BB d_bb)
  ; case_for_app_cong
    : forall (Γ : context) (A A' : ty_expr Γ) (B B' : ty_expr (Γ ;; A))
        (f f' a a' : tm_expr Γ)
        (d_A : [! Γ |- A !]) (p_A : P d_A)
        (d_AA : [! Γ |- A === A' !]) (p_AA : P d_AA)
        (d_BB : [! Γ ;; A |- B === B' !]) (p_BB : P d_BB)
        (d_ff : [! Γ |- f === f' ::: Pi_expr A B !]) (p_ff : P d_ff)
        (d_aa : [! Γ |- a === a' ::: A !]) (p_aa : P d_aa),
      P (derive_app_cong Γ A A' B B' f f' a a' d_A d_AA d_BB d_ff d_aa)
    }.

  Definition derivation_rect_grouped
      (H_var_rule : case_for_var_rule)               (* 1 case *)
      (H_equiv_rel_rules : cases_for_equiv_rel_rules) (* 6 cases *)
      (H_conv_rules : cases_for_conv_rules)           (* 2 cases *)
      (H_universe_rules : cases_for_universe_rules)   (* 3 cases *)
      (H_pi_rules : cases_for_pi_rules)               (* 4 cases *)
      (H_pi_cong_rules : cases_for_pi_cong_rules)     (* 3 cases *)
    : forall J (d : derivation J), P d.
  Proof.
    destruct H_equiv_rel_rules, H_conv_rules,
      H_universe_rules, H_pi_rules, H_pi_cong_rules.
    apply derivation_rect; eauto.
  Defined.

End Derivation_Helpers.


(* Check that "where" clause behaves as if given independently of the  *)
(* definition (variant of bug #1132 submitted by Assia Mahboubi) *)

Fixpoint plus1 (n m:nat) {struct n} : nat :=
   match n with
   | O => m
   | S p => S (p+m)
   end
 where "n + m" := (plus1 n m) : nat_scope.

(* Check behaviour wrt yet empty levels (see Stephane's bug #1850) *)

Parameter P : Type -> Type -> Type -> Type.
Notation "e |= t --> v" := (P e t v)     (at level 100, t at level 54).
Check (nat |= nat --> nat).

(* Check that first non empty definition at an empty level can be of any
   associativity *)

Definition marker := O.
Notation "x +1" := (S x) (at level 8, left associativity).
Reset marker.
Notation "x +1" := (S x) (at level 8, right associativity).

(* Check that empty levels (here 8 and 2 in pattern) are added in the
   right order *)

Notation "' 'C_' G ( A )" := (A,G) (at level 8, G at level 2).

(* Check import of notations from within a section *)

Notation "+1 x" := (S x) (at level 25, x at level 9).
Section A. Require Import make_notation. End A.

(* Check use of "$" (see bug #1961) *)

Notation "$ x" := (id x) (at level 30).
Check ($ 5).

(* Check regression of bug #2087 *)

Notation "'exists' x , P" := (x, P)
   (at level 200, x ident, right associativity,	only parsing).

Definition foo P := let '(exists x, Q) := P in x = Q :> nat.

(* Check empty levels when extending binder_constr *)

Notation "'exists' x >= y , P" := (exists x, x >= y /\ P)%nat
   (at level 200, x ident, right associativity, y at level 69).

(* This used to loop at some time before r12491 *)

Notation R x := (@pair _ _ x).
Check (fun x:nat*nat => match x with R x y => (x,y) end).

(* Check multi-tokens recursive notations *)

Local Notation "[ a  # ; ..  # ; b ]" := (a + .. (b + 0) ..).
Check [ 0 ].
Check [ 0 # ; 1 ].

(* Check well-scoping of alpha-renaming of private binders *)
(* see bug #2248 (thanks to Marc Lasson) *)

Notation "{ q , r | P }" := (fun (p:nat*nat) => let (q, r) := p in P).
Check (fun p => {q,r| q + r = p}).


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

(* Utilities methods used for defining the semantics of the operators *)

Require Import List.
Require Import String.
Require Import Utils.
Require Import ZArith.
Require Import BrandRelation.
Require Import ForeignData.
Require Import Data.
Require Import DataLift.
Require Import Iterators.

Section OperatorsUtils.
  Context {fdata:foreign_data}.

  Definition string_sort := insertion_sort StringOrder.le_dec.

  Fixpoint dsum (ns:list data) : option Z
    := match ns with
         | nil => Some 0%Z
         | dnat n::ls => lift (Zplus n) (dsum ls)
         | _ => None
       end.

  Lemma dsum_nil :
    dsum nil = Some (0%Z).
  Proof.
    reflexivity.
  Qed.

  Lemma Zquot_zero n :
    Z.quot n 0%Z = 0%Z.
  Proof.
    now apply Z.quot_0_r_ext.
  Qed.

  Definition darithmean_alt (ns:list data) : option Z
    := match ns with
       | nil  => Some (0%Z) (* Unneeded betwen Z.quot 0 0 = 0 , see Zquot.Zquot_0_r *)
       | _ => lift (fun x => Z.quot x (Z_of_nat (List.length ns))) (dsum ns)
       end.

  Definition darithmean (ns:list data) : option Z
    := lift (fun x => Z.quot x (Z_of_nat (List.length ns))) (dsum ns).

  Lemma darithmean_alt_correct (ns:list data):
    darithmean_alt ns = darithmean ns.
  Proof.
    destruct ns; reflexivity.
  Qed.

  Definition lifted_stringbag (l : list data) : option (list string) :=
    lift_map (ondstring (fun x => x)) l.
  Definition lifted_zbag (l : list data) : option (list Z) :=
    lift_map (ondnat (fun x => x)) l.
  Definition lifted_min (l : list data) : option data :=
    lift dnat (lift bnummin (lifted_zbag l)).
  Definition lifted_max (l : list data) : option data :=
    lift dnat (lift bnummax (lifted_zbag l)).

  Definition lifted_fbag (l : list data) : option (list float) :=
    lift_map (ondfloat (fun x => x)) l.

  Definition lifted_fsum (l:list data) : option data :=
    lift dfloat (lift float_list_sum (lifted_fbag l)).
  Definition lifted_farithmean (l:list data) : option data :=
    lift dfloat (lift float_list_arithmean (lifted_fbag l)).
  Definition lifted_fmin (l : list data) : option data :=
    lift dfloat (lift float_list_min (lifted_fbag l)).
  Definition lifted_fmax (l : list data) : option data :=
    lift dfloat (lift float_list_max (lifted_fbag l)).

  Definition lifted_join (sep : string) (l : list data) : option data :=
    lift dstring (lift (concat sep) (lifted_stringbag l)).

End OperatorsUtils.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.StringOperations.

Global Set Implicit Arguments.

Lemma nat_of_ascii_small x
: Ascii.nat_of_ascii x < 256.
Proof.
  apply Compare_dec.leb_complete.
  revert x.
  intros [[] [] [] [] [] [] [] []]; lazy; reflexivity.
Qed.

Lemma substring_correct3 {s : string} m (H : length s <= m)
  : substring 0 m s = s.
Proof.
  revert m H.
  induction s; simpl.
  { intros; destruct m; trivial. }
  { intros; destruct m.
    { apply Lt.lt_n_0 in H.
      destruct H. }
    { rewrite IHs; trivial.
      apply Le.le_S_n; trivial. } }
Qed.

Lemma substring_correct3' {s : string}
  : substring 0 (length s) s = s.
Proof.
  apply substring_correct3; reflexivity.
Qed.

Lemma substring_correct0 {s : string} {n}
  : substring n 0 s = ""%string.
Proof.
  revert n; induction s; intro n; destruct n; simpl; trivial.
Qed.

Lemma substring_correct0' {s : string} {n m} (H : length s <= n)
  : substring n m s = ""%string.
Proof.
  revert n m H; induction s; simpl; intros n m H.
  { destruct n, m; trivial. }
  { destruct n, m; trivial.
    { apply le_Sn_0 in H; destruct H. }
    { rewrite IHs; eauto with arith. }
    { rewrite IHs; eauto with arith. } }
Qed.

Lemma substring_correct4 {s : string} {n m m'}
      (H : length s <= n + m) (H' : length s <= n + m')
  : substring n m s = substring n m' s.
Proof.
  revert n m m' H H'.
  induction s; simpl in *.
  { intros; destruct m, m', n; trivial. }
  { intros; destruct m, m', n; trivial; simpl in *;
    try (apply Lt.lt_n_0 in H; destruct H);
    try (apply Lt.lt_n_0 in H'; destruct H');
    try apply Le.le_S_n in H;
    try apply Le.le_S_n in H';
    try solve [ try rewrite plus_comm in H;
                try rewrite plus_comm in H';
                simpl in *;
                rewrite !substring_correct0' by auto with arith; trivial ].
    { apply f_equal.
      apply IHs; trivial. }
    { apply IHs; trivial. } }
Qed.

Lemma string_concat_empty_r {s} : (s ++ "" = s)%string.
Proof.
  induction s; simpl; f_equal; trivial.
Qed.

Lemma string_concat_empty_l {s} : ("" ++ s = s)%string.
Proof.
  reflexivity.
Qed.

Lemma substring_concat {x y z} {s : string}
  : (substring x y s ++ substring (x + y) z s)%string = substring x (y + z) s.
Proof.
  revert x y z.
  induction s; simpl; intros.
  { destruct (y + z), x, y, z; reflexivity. }
  { destruct x, y, z; try reflexivity; simpl;
    rewrite ?plus_0_r, ?substring_correct0, ?string_concat_empty_r;
    try reflexivity.
    { apply f_equal.
      apply IHs. }
    { rewrite IHs; simpl; reflexivity. } }
Qed.

Lemma substring_concat' {y z} {s : string}
  : (substring 0 y s ++ substring y z s)%string = substring 0 (y + z) s.
Proof.
  rewrite <- substring_concat; reflexivity.
Qed.

Lemma substring_concat0 {s1 s2 : string}
  : substring 0 (length s1) (s1 ++ s2) = s1.
Proof.
  induction s1; simpl.
  { rewrite substring_correct0; trivial. }
  { rewrite IHs1; trivial. }
Qed.

Lemma concat_length {s1 s2 : string}
  : length (s1 ++ s2) = length s1 + length s2.
Proof.
  induction s1.
  { reflexivity. }
  { simpl.
    rewrite IHs1; reflexivity. }
Qed.

Lemma substring_concat_length {s1 s2 : string}
  : substring (length s1) (length s2) (s1 ++ s2) = s2.
Proof.
  induction s1; simpl.
  { rewrite substring_correct3'; trivial. }
  { erewrite substring_correct4.
    { exact IHs1. }
    { rewrite concat_length; reflexivity. }
    { rewrite concat_length; reflexivity. } }
Qed.

Lemma substring_length {s n m}
  : length (substring n m s) = (min (length s) (m + n)) - n.
Proof.
  revert n m; induction s; intros.
  { destruct n, m; reflexivity. }
  { simpl.
    destruct n, m; simpl; trivial; rewrite IHs; simpl;
    try omega;
    rewrite (plus_comm m (S n)); simpl;
    rewrite (plus_comm n m); simpl;
    reflexivity. }
Qed.

Lemma substring_substring {s n m n' m'}
  : substring n m (substring n' m' s) = substring (n + n') (min m (m' - n)) s.
Proof.
  revert n m n' m'.
  induction s; intros.
  { destruct n, m, n', m'; reflexivity. }
  { destruct n', m';
    rewrite <- ?plus_n_O, <- ?minus_n_O, ?Min.min_0_r, ?Min.min_0_l;
    destruct n, m;
    trivial; simpl;
    rewrite ?IHs, ?substring_correct0, <- ?plus_n_O, <- ?minus_n_O;
    simpl;
    try reflexivity.
    rewrite (plus_comm _ (S _)); simpl.
    rewrite (plus_comm n n').
    reflexivity. }
Qed.

Lemma substring1_get {n str}
  : substring n 1 str
    = option_rect (fun _ => String.string) (fun a => String.String a ""%string) ""%string (get n str).
Proof.
  revert n; induction str; intro n.
  { destruct n; reflexivity. }
  { destruct n; simpl.
    { destruct str; reflexivity. }
    { rewrite <- IHstr; reflexivity. } }
Qed.

Lemma substring_min {x x' y y' z str} (H : substring x y str = substring x' y' str)
  : substring x (min y z) str = substring x' (min y' z) str.
Proof.
  pose proof (fun y x => @substring_substring str 0 z x y) as H'; simpl in *.
  setoid_rewrite Nat.sub_0_r in H'.
  setoid_rewrite Min.min_comm in H'.
  rewrite <- !H', H; reflexivity.
Qed.

Lemma get_string_of_list str n
: String.get n (string_of_list str) = List.nth_error str n.
Proof.
  revert n; induction str as [|ch str IHstr]; intros;
  destruct n as [|n]; simpl in *; auto.
Qed.

Lemma length_list_of_string str
: List.length (list_of_string str) = String.length str.
Proof.
  induction str; simpl; rewrite ?IHstr; reflexivity.
Qed.

Lemma length_string_of_list ls
: String.length (string_of_list ls) = List.length ls.
Proof.
  induction ls; simpl; rewrite ?IHls; reflexivity.
Qed.

Lemma list_of_string_substring n m str
: StringOperations.list_of_string (String.substring n m str) = List.take m (List.drop n (StringOperations.list_of_string str)).
Proof.
  revert n m; induction str as [|?? IHstr];
  intros [|?] [|?];
  simpl;
  rewrite ?IHstr;
  reflexivity.
Qed.

Lemma list_of_string_of_list ls
: list_of_string (string_of_list ls) = ls.
Proof.
  induction ls; simpl; rewrite ?IHls; reflexivity.
Qed.

Lemma string_of_list_of_string str
: string_of_list (list_of_string str) = str.
Proof.
  induction str; simpl; rewrite ?IHstr; reflexivity.
Qed.

Lemma get_list_of_string str n
: List.nth_error (list_of_string str) n = String.get n str.
Proof.
  rewrite <- get_string_of_list, string_of_list_of_string; reflexivity.
Qed.

Lemma substring_min_length str x y
: substring x (min y (length str)) str = substring x y str.
Proof.
  apply Min.min_case_strong; try reflexivity.
  intro H.
  apply substring_correct4; omega.
Qed.

Lemma string_copy_length n ch
: String.length (string_copy n ch) = n.
Proof.
  induction n; simpl; eauto.
Qed.

Fixpoint split_string (s : string) : (string * string) :=
  match s with
  | EmptyString => ("", "")
  | String a s' => if Ascii.ascii_dec a "." then ("", s')
                   else (let (s1, s2) := split_string s' in
                         (String a s1, s2))
  end%string.

Lemma split_string_ValidDomainName_length :
  forall d,
    d <> ""%string
    -> lt (String.length (snd (split_string d))) (String.length d).
Proof.
  induction d; simpl; intros; try congruence.
  destruct (Ascii.ascii_dec a "."); simpl; eauto.
  destruct d; simpl in *; eauto.
  destruct (if Ascii.ascii_dec a0 "." then (""%string, d)
               else (let (s1, s2) := split_string d in (String a0 s1, s2))).
  simpl in *.
  etransitivity.
  apply IHd.
  congruence.
  eauto with arith.
Qed.

Lemma well_founded_string_length
  : well_founded (fun y r : string => lt (String.length y) (String.length r)%nat).
Proof.
  unfold well_founded; intro; induction a; econstructor.
  - destruct y; simpl; omega.
  - intros; destruct y; simpl; intros.
    + econstructor; destruct y; simpl; omega.
    + econstructor; intros.
      eapply IHa; simpl in *; omega.
Qed.