(*

  Copyright 2016 University of Luxembourg

  This file is part of our formalization of Platzer's
    "A Complete Uniform Substitution Calculus for Differential Dynamic Logic"
  available here: http://arxiv.org/pdf/1601.06183.pdf (July 27, 2016).
  We refer to this formalization as DdlCoq here.

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

  DdlCoq 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 DdlCoq.  If not, see <http://www.gnu.org/licenses/>.

  authors:
    Vincent Rahli
    Marcus Völp
    Ivana Vukotic

 *)

Require Export soundness.

(**

   This file implements renaming of variables using swapping.

   More might be able to reuse some stuff from here:
     - https://github.com/vrahli/NuprlInCoq/blob/master/terms/swap.v
     - https://github.com/vrahli/NuprlInCoq/blob/master/terms/swap_props.v
 *)

Record swapping :=
  MkSwapping
    {
      swap_left : KVariable;
      swap_right : KVariable
    }.

(**

   swapping operation on variables
   [swap a b v] applies the swapping (a,b) to the assignable v.

 *)
Definition swap (sw : swapping) (v : KVariable) : KVariable :=
  if KVariable_dec v (swap_left sw) then swap_right sw
  else if KVariable_dec v (swap_right sw) then swap_left sw
       else v.

(**

  [swap_assgn] generalizes [swap] to assignables.

 *)

Fixpoint swap_assgn (sw : swapping) (a : Assign) : Assign :=
  match a with
  | KAssignVar v => KAssignVar (swap sw v)
  | KAssignDiff d => KAssignDiff (swap_assgn sw d)
  end.

(**

  [swap_vars] generalizes [swap] to a list of variables.

 *)

Definition swap_vars (sw : swapping) (l : list Var) : list Var :=
  map (swap sw) l.

(**

  [swap_assgns] generalizes [swap_assgn] to a list of variables.

 *)

Definition swap_assgns (sw : swapping) (l : list Assign) : list Assign :=
  map (swap_assgn sw) l.

(**

  Swapping on terms: it applies the swapping (a,b) to term [t]

 *)
Fixpoint swap_term (sw : swapping) (t : Term) : Term :=
  match t with
  | KTdot n            => KTdot n
  | KTfuncOf f n args  => KTfuncOf f n (Vector.map (swap_term sw) args)
  | KTnumber r         => KTnumber r
  | KTread asgn        => KTread (swap_assgn sw asgn)
  | KTneg t            => KTneg    (swap_term sw t)
  | KTplus   l r       => KTplus   (swap_term sw l) (swap_term sw r)
  | KTminus  l r       => KTminus  (swap_term sw l) (swap_term sw r)
  | KTtimes  l r       => KTtimes  (swap_term sw l) (swap_term sw r)
  | KTdifferential t   => KTdifferential (swap_term sw t)
  end.

(**

 Swaping on AtomicODE

 *)
Definition swap_atomic_ode (sw : swapping) (o : AtomicODE) : AtomicODE :=
  match o with
  | ODEconst c   => ODEconst c (* undefined in Rose's implementation *)
  | ODEsing xp t => ODEsing  (swap_assgn sw xp) (swap_term sw t)
  end.

(**

 Swaping on ODE

 *)
Fixpoint swap_ode (sw : swapping) (o : ODE) : ODE :=
  match o with
  | ODEatomic c => ODEatomic (swap_atomic_ode sw c)
  | ODEprod l r => ODEprod (swap_ode sw l) (swap_ode sw r)
  end.

(**

 Swaping on Formulas

 *)
Fixpoint swap_formula  (sw : swapping) (F : Formula) : Formula :=
  match F with
  | KFdot                   => KFdot
  | KFtrue                  => KFtrue
  | KFfalse                 => KFfalse

  | KFequal        l r      => KFequal        (swap_term sw l) (swap_term sw r)
  | KFnotequal     l r      => KFnotequal     (swap_term sw l) (swap_term sw r)
  | KFgreaterEqual l r      => KFgreaterEqual (swap_term sw l) (swap_term sw r)
  | KFgreater      l r      => KFgreater      (swap_term sw l) (swap_term sw r)
  | KFlessEqual    l r      => KFlessEqual    (swap_term sw l) (swap_term sw r)
  | KFless         l r      => KFless         (swap_term sw l) (swap_term sw r)

  | KFpredOf p n args       => KFpredOf p n (Vector.map (swap_term sw) args)

  | KFquantifier q t        => KFquantifier q (swap_formula sw t)

  | KFnot   f               => KFnot   (swap_formula sw f)
  | KFand   l r             => KFand   (swap_formula sw l) (swap_formula sw r)
  | KFor    l r             => KFor    (swap_formula sw l) (swap_formula sw r)
  | KFimply l r             => KFimply (swap_formula sw l) (swap_formula sw r)
  | KFequiv l r             => KFequiv (swap_formula sw l) (swap_formula sw r)

  | KFforallVars lv f       => KFforallVars (swap_vars sw lv) (swap_formula sw f)
  | KFexistsVars lv f       => KFexistsVars (swap_vars sw lv) (swap_formula sw f)

  | KFbox     p f           => KFbox     (swap_program sw p) (swap_formula sw f)
  | KFdiamond p f           => KFdiamond (swap_program sw p) (swap_formula sw f)
  end

(**

 Swaping on Programs

 *)
  with swap_program  (sw : swapping) (P : Program) : Program :=
         match P with
         | KPconstant c           => KPconstant c
         | KPassign x t           => KPassign (swap_assgn sw x) (swap_term sw t)
         | KPassignAny x          => KPassignAny (swap_assgn sw x)
         | KPtest f               => KPtest (swap_formula sw f)

         | KPchoice l r           => KPchoice (swap_program sw l) (swap_program sw r)

         | KPcompose l r          => KPcompose (swap_program sw l) (swap_program sw r)

         | KPloop p               => KPloop (swap_program sw p)

         | KPodeSystem ode f     => KPodeSystem (swap_ode sw ode) (swap_formula sw f)
         end.

Definition swap_state (sw : swapping) (s : state) : state :=
  fun a => s (swap_assgn sw a).

Lemma swap_twice :
  forall sw v,
    swap sw (swap sw v) = v.
Proof.
  introv.
  unfold swap; repeat dest_cases w.
Qed.
Hint Rewrite swap_twice : core.

Lemma swap_assgn_twice :
  forall sw a,
    swap_assgn sw (swap_assgn sw a) = a.
Proof.
  induction a; simpl; autorewrite with core; auto.
  rewrite IHa; auto.
Qed.
Hint Rewrite swap_assgn_twice : core.

Lemma swap_state_twice :
  forall sw v, swap_state sw (swap_state sw v) = v.
Proof.
  introv; apply functional_extensionality; introv.
  unfold swap_state; autorewrite with core; auto.
Qed.

Lemma map_vec_flatten :
  forall {n A B} (v : Vector.t (list A) n) (g : A -> B),
    map g (vec_flatten v)
    = vec_flatten (Vector.map (map g) v).
Proof.
  induction n; introv.

  { apply Vector.case0 with (v := v); simpl; auto. }

  apply (Vector.caseS' v); introv; clear v; simpl.
  rewrite map_app, IHn; auto.
Qed.

Lemma term_variables_swap_term_eq :
  forall t sw,
    term_variables (swap_term sw t)
    = map (swap sw) (term_variables t).
Proof.
  term_ind t Case; introv; simpl; auto;
    try (complete (rewrite IHt; auto));
    try (complete (rewrite IHt1, IHt2; rewrite map_app; auto)).

  { Case "KTfuncOf".
    rewrite map_vec_flatten.
    repeat (rewrite vec_map_map; unfold compose).
    f_equal.
    apply eq_vec_map; introv i; tcsp. }

  { Case "KTread".
    destruct var; simpl; auto. }
Qed.

Lemma free_vars_term_swap_term_eq :
  forall t sw,
    free_vars_term (swap_term sw t)
    = map (swap_assgn sw) (free_vars_term t).
Proof.
  term_ind t Case; introv; simpl; auto;
    try (complete (rewrite IHt; auto));
    try (complete (rewrite IHt1, IHt2; rewrite map_app; auto)).

  { Case "KTfuncOf".
    rewrite map_vec_flatten.
    repeat (rewrite vec_map_map; unfold compose).
    f_equal.
    apply eq_vec_map; introv i; tcsp. }

  { Case "KTdifferential".
    rewrite map_app.
    f_equal; auto.
    rewrite IHt.
    unfold KD.
    allrw map_map; unfold compose; simpl; auto. }
Qed.

Lemma eq_swap_implies_eq :
  forall sw v1 v2,
    swap sw v1 = swap sw v2 -> v1 = v2.
Proof.
  introv h.
  destruct sw.
  unfold swap in *; simpl.
  repeat (dest_cases w; simpl in *; try subst; tcsp).
Qed.

Lemma eq_swap_assgn_implies_eq :
  forall sw v1 v2,
    swap_assgn sw v1 = swap_assgn sw v2 -> v1 = v2.
Proof.
  induction v1; destruct v2; simpl; introv h; ginv; f_equal.
  { apply (eq_swap_implies_eq sw); inversion h; auto. }
  { apply IHv1; inversion h; auto. }
Qed.

Lemma swap_state_upd_state_KAssignVar :
  forall sw v x t,
    swap_state sw (upd_state v (KAssignVar (swap sw x)) t)
    = upd_state (swap_state sw v) (KAssignVar x) t.
Proof.
  introv.
  apply functional_extensionality; introv.
  unfold swap_state.
  unfold upd_state, swap_assgn; simpl.
  destruct x0 as [var|diff]; repeat (dest_cases w).
  destruct n; f_equal; apply (eq_swap_implies_eq sw).
  inversion e; auto.
Qed.

Lemma map_remove_duplicates_if_inj :
  forall {A B} (l : list A) (f : A -> B) decA decB,
    (forall a b, f a = f b -> a = b)
    -> map f (remove_duplicates decA l)
       = remove_duplicates decB (map f l).
Proof.
  induction l; introv imp; simpl in *; auto.
  repeat (dest_cases w); simpl in *; auto.

  { rewrite in_map_iff in n; destruct n; eexists; dands; eauto. }

  { rewrite in_map_iff in i; exrepnd.
    apply imp in i1; subst; tcsp. }

  { rewrite (IHl _ decA decB); auto. }
Qed.

Lemma term_variables_nodup_swap_term_eq :
  forall t sw,
    term_variables_nodup (swap_term sw t)
    = map (swap sw) (term_variables_nodup t).
Proof.
  introv.
  unfold term_variables_nodup.
  rewrite term_variables_swap_term_eq.
  symmetry.
  apply map_remove_duplicates_if_inj.
  introv.
  apply eq_swap_implies_eq.
Qed.

Lemma big_sum_map_ext :
  forall {T}
         (l : list T)
         (f1 f2 : T -> R)
         (f : T -> T)
         (dec : Deq T),
    (forall a b, f a = f b -> a = b)
    -> (forall v : T, In v l -> f1 (f v) = f2 v)
    -> big_sum (remove_duplicates dec (map f l)) f1
       = big_sum (remove_duplicates dec l) f2.
Proof.
  induction l; introv inj imp; simpl; auto.
  repeat (dest_cases w; simpl in *).

  { rewrite in_map_iff in i; exrepnd.
    apply inj in i1; subst; tcsp. }

  { rewrite in_map_iff in n; destruct n; exists a; dands; auto. }

  { f_equal; auto. }
Qed.

Lemma swap_state_as_apply_diff_swap :
  forall v sw x,
    swap_state sw v (KD x)
    = v (KD (swap_assgn sw x)).
Proof.
  introv.
  unfold swap_state; simpl; auto.
Qed.

Lemma swap_state_as_apply_swap_assgn :
  forall v sw x,
    swap_state sw v x
    = v (swap_assgn sw x).
Proof.
  introv.
  unfold swap_state; simpl; auto.
Qed.

Lemma swap_state_swap_assgn :
  forall sw v a,
    swap_state sw v (swap_assgn sw a)
    = v a.
Proof.
  introv.
  unfold swap_state.
  rewrite swap_assgn_twice; auto.
Qed.

Lemma swap_state_inj :
  forall sw v w,
    swap_state sw v = swap_state sw w -> v = w.
Proof.
  introv h.
  unfold swap_state in h.
  apply functional_extensionality; introv.
  pose proof (equal_f h (swap_assgn sw x)) as q; simpl in q.
  autorewrite with core in *; auto.
Qed.

Lemma length_swap_vars :
  forall sw vars, length (swap_vars sw vars) = length vars.
Proof.
  introv.
  unfold swap_vars.
  rewrite map_length; auto.
Qed.
Hint Rewrite length_swap_vars : core.

Lemma length_swap_assgns :
  forall sw vars, length (swap_assgns sw vars) = length vars.
Proof.
  introv.
  unfold swap_assgns.
  rewrite map_length; auto.
Qed.
Hint Rewrite length_swap_assgns : core.

Lemma upd_list_state_swap_state :
  forall sw v vars rs a,
    upd_list_state (swap_state sw v) (combine vars rs) a
    = swap_state sw (upd_list_state v (combine (swap_vars sw vars) rs)) a.
Proof.
  induction vars; introv; simpl; auto.
  destruct rs; simpl; auto.
  unfold upd_state at 1.
  rewrite IHvars.
  rewrite swap_state_upd_state_KAssignVar; auto.
Qed.

Lemma interp_swap_ext :
  forall (I : interpretation) C sw,
    interpQuantExt
      (fun f s =>
         interp_quant_f
           (I (SymbolQuantifier C))
           (fun s => f (swap_state sw s))
           (swap_state sw s)).
Proof.
  introv h q.
  remember (I (SymbolQuantifier C)) as c; simpl in c.
  destruct c as [F cond]; clear Heqc; simpl.
  apply cond; auto.
  introv.
  unfold swap_state.
  apply h; auto.
Qed.

Lemma interpOdeExt_swap :
  forall sw (I : interpretation) c,
    interpOdeExt
      (swap_assgns sw (interp_ode_bv (I (SymbolODE c))))
      (fun s =>
         swap_state
           sw
           (interp_ode_dm
              (I (SymbolODE c))
              (swap_state sw s))).
Proof.
  introv h.
  remember (I (SymbolODE c)) as C; destruct C as [bv sem ext]; simpl; clear HeqC.
  apply ext; introv.
  unfold swap_state.
  apply h.
Qed.

Definition swap_interp (sw : swapping) (I : interpretation) : interpretation :=
  fun f : Symbol =>
    match f with
    | SymbolFunction g n => I (SymbolFunction g n)
    | SymbolDotTerm n => I (SymbolDotTerm n)
    | SymbolPredicate p n => I (SymbolPredicate p n)
    | SymbolQuantifier C =>
      MkInterpQuant
        (fun f s =>
           interp_quant_f
             (I (SymbolQuantifier C))
             (fun s => f (swap_state sw s))
             (swap_state sw s))
        (interp_swap_ext I C sw)

    | SymbolDotForm => fun s => I SymbolDotForm (swap_state sw s)

    | SymbolODE c =>
      MkInterpODE
        (swap_assgns sw (interp_ode_bv (I (SymbolODE c))))
        (fun s =>
           swap_state
             sw
             (interp_ode_dm
                (I (SymbolODE c))
                (swap_state sw s)))
        (interpOdeExt_swap sw I c)

    | SymbolProgramConst a =>
      fun v w => I (SymbolProgramConst a) (swap_state sw v) (swap_state sw w)
    end.

Lemma eq_maps3 :
  forall (A B C : Type) (f : A -> B) (g  : C -> B) (la : list A) (lc : list C),
    length la = length lc
    -> (forall a c,  List.In (a,c) (combine la lc) -> f a = g c)
    -> map f la = map g lc.
Proof.
  induction la; destruct lc; introv len imp; allsimpl; tcsp; tcsp.
  f_equal; auto.
Qed.

Lemma length_ode_vars_swap_interp :
  forall sw I ode,
    length (ode_assign (swap_interp sw I) ode)
    = length (ode_assign I ode).
Proof.
  induction ode; simpl.

  { destruct child; simpl; auto.
    autorewrite with core; auto. }

  { allrw app_length.
    rewrite IHode1, IHode2; auto. }
Qed.
Hint Rewrite length_ode_vars_swap_interp : core.

Lemma length_ode_vars_swap_ode :
  forall I sw ode,
    length (ode_assign I (swap_ode sw ode))
    = length (ode_assign I ode).
Proof.
  induction ode; simpl.

  { destruct child; simpl; auto. }

  { allrw app_length.
    rewrite IHode1, IHode2; auto. }
Qed.
Hint Rewrite length_ode_vars_swap_ode : core.

Lemma map_ode_vars_swap_ode :
  forall sw I ode,
    map (swap_assgn sw) (ode_assign I (swap_ode sw ode))
    = ode_assign (swap_interp sw I) ode.
Proof.
  induction ode; simpl.

  { destruct child; simpl; auto.
    rewrite swap_assgn_twice; auto. }

  { allrw map_app.
    rewrite IHode1, IHode2; auto. }
Qed.

Lemma combine_map_l :
  forall {A B} (f : A -> B) (l : list A),
    combine (map f l) l = map (fun a : A => (f a, a)) l.
Proof.
  induction l; simpl; auto.
  f_equal; auto.
Qed.

Lemma combine_map_r :
  forall {A B} (f : A -> B) l,
    combine l (map f l)
    = map (fun a => (a, f a)) l.
Proof.
  induction l; simpl; auto.
  rw IHl; sp.
Qed.

Lemma ode_footprint_diff_swap_interp :
  forall ode sw I,
    ode_footprint_diff (swap_interp sw I) ode
    = map (swap_assgn sw) (ode_footprint_diff I (swap_ode sw ode)).
Proof.
  introv.
  unfold ode_footprint_diff.
  allrw map_map; unfold compose.
  apply eq_maps3.

  { autorewrite with core; auto. }

  { introv i.
    simpl.
    unfold KD; f_equal.
    rewrite <- map_ode_vars_swap_ode in i.
    rewrite combine_map_l in i.
    apply in_map_iff in i; exrepnd; ginv; auto.
  }
Qed.

Lemma ode_footprint_vars_swap_interp :
  forall ode sw I,
    ode_footprint_vars (swap_interp sw I) ode
    = map (swap_assgn sw) (ode_footprint_vars I (swap_ode sw ode)).
Proof.
  introv.
  unfold ode_footprint_vars.
  rewrite map_ode_vars_swap_ode; auto.
Qed.

Lemma ode_footprint_swap_interp :
  forall ode sw I,
    ode_footprint (swap_interp sw I) ode
    = map (swap_assgn sw) (ode_footprint I (swap_ode sw ode)).
Proof.
  introv.
  unfold ode_footprint.
  rewrite ode_footprint_diff_swap_interp.
  rewrite ode_footprint_vars_swap_interp.
  rewrite map_app; auto.
Qed.

Lemma swap_state_upd_state_swap_assgn :
  forall sw v x t,
    swap_state sw (upd_state v (swap_assgn sw x) t)
    = upd_state (swap_state sw v) x t.
Proof.
  introv.
  apply functional_extensionality; introv.
  unfold swap_state.
  unfold upd_state; simpl.
  repeat (dest_cases w; subst; tcsp).
  apply eq_swap_assgn_implies_eq in e; subst; tcsp.
Qed.

Lemma swap_term_dynamic_semantics_term :
  forall t I v sw,
    dynamic_semantics_term I v (swap_term sw t)
    = dynamic_semantics_term (swap_interp sw I) (swap_state sw v) t.
Proof.
  term_ind t Case; introv; simpl; auto;
    try (complete (rewrite IHt; auto));
    try (complete (rewrite IHt1, IHt2; auto)).

  { Case "KTfuncOf".
    f_equal.
    rewrite vec_map_map; unfold compose; simpl.
    apply eq_vec_map; introv i; tcsp.
  }

  { Case "KTdifferential".
    unfold term_assignables_nodup.
    rewrite free_vars_term_swap_term_eq.
    apply big_sum_map_ext; auto; try (apply eq_swap_assgn_implies_eq);[].

    introv i.
    rewrite swap_state_as_apply_diff_swap.
    rewrite swap_state_as_apply_swap_assgn.
    f_equal.
    apply Derive_ext; introv.

    rewrite IHt.
    rewrite swap_state_upd_state_swap_assgn; auto.
  }
Qed.

Lemma dynamic_semantics_ode_fun_swap_ode :
  forall ode I sw s a,
    dynamic_semantics_ode_fun I (swap_ode sw ode) s a
    = dynamic_semantics_ode_fun
          (swap_interp sw I) ode
          (swap_state sw s) (swap_assgn sw a).
Proof.
  induction ode; introv; simpl.

  { destruct child; simpl; auto.

    { rewrite swap_state_twice.
      remember (I (SymbolODE name)) as C; simpl in C.
      destruct C as [bv sem ext]; clear HeqC; simpl.
      unfold swap_state; simpl.
      rewrite swap_assgn_twice; auto. }

    { repeat (dest_cases w; subst; simpl in *; GC); autorewrite with core in *; ginv.
      { apply swap_term_dynamic_semantics_term. }
      { unfold KD in n; tcsp. }
      { destruct a; simpl in *; ginv.
        fold KD in *; ginv.
        rewrite swap_assgn_twice in n; tcsp. }
    }
  }

  { rewrite IHode1, IHode2; auto. }
Qed.

Lemma dynamic_semantics_ode_swap_ode :
  forall ode I sw r phi,
    dynamic_semantics_ode I (swap_ode sw ode) r phi
    <-> dynamic_semantics_ode
          (swap_interp sw I) ode r
          (fun x : R => swap_state sw (phi x)).
Proof.
  introv; split; introv h i; simpl in *; autorewrite with core.

  { rewrite <- map_ode_vars_swap_ode in i.
    rewrite in_map_iff in i; exrepnd; subst.
    apply (h zeta) in i0; repnd.
    dands; auto.

    { eapply ex_derive_ext;[|exact i1]; introv; simpl; auto.
      unfold swap_state; simpl.
      rewrite swap_assgn_twice; auto. }

    { unfold swap_state; simpl.
      rewrite swap_assgn_twice.
      fold KD in *.
      rewrite i2; auto. }

    { unfold swap_state; simpl in *.
      rewrite swap_assgn_twice.
      fold KD in *.
      rewrite i0; auto.
      apply dynamic_semantics_ode_fun_swap_ode. }
  }

  { pose proof (h zeta (swap_assgn sw v)) as q.
    rewrite <- map_ode_vars_swap_ode in q.
    rewrite in_map_iff in q; autodimp q hyp.
    { eexists; dands; eauto. }
    simpl in *.
    repnd; dands; auto.

    { eapply ex_derive_ext;[|exact q0]; introv; simpl; auto.
      unfold swap_state; simpl.
      rewrite swap_assgn_twice; auto. }

    { unfold swap_state in q1; simpl in q1.
      rewrite swap_assgn_twice in q1; auto. }

    { unfold swap_state in q; simpl in q.
      rewrite swap_assgn_twice in q.
      fold KD in *.
      rewrite q.
      symmetry.
      apply dynamic_semantics_ode_fun_swap_ode. }
  }
Qed.

Lemma swap_dynamic_semantics_formula_program :
  (forall f sw I v,
      dynamic_semantics_formula I (swap_formula sw f) v
      <->
      dynamic_semantics_formula (swap_interp sw I) f (swap_state sw v)
  )
  /\
  (forall p sw I v w,
      dynamic_semantics_program I (swap_program sw p) v w
      <->
      dynamic_semantics_program (swap_interp sw I) p (swap_state sw v) (swap_state sw w)
  ).
Proof.
  form_prog_ind Case;
    introv;
    simpl in *; tcsp; auto;
      try (complete (repeat (rewrite swap_term_dynamic_semantics_term); tcsp));
      try (complete (introv ih; introv; rewrite ih; tcsp));
      try (complete (introv ih1 ih2; split; introv h; repnd;
                     try (rewrite <- ih1, <- ih2; tcsp);
                     try (rewrite ih1, ih2; tcsp))).

  { Case "KFdot".
    rewrite swap_state_twice; tcsp. }

  { Case "KFpredOf".
    rewrite vec_map_map; unfold compose.
    match goal with
    | [ |- _ _ ?x <-> _ _ ?y ] => assert (x = y) as xx;[|rewrite xx;tcsp];[]
    end.
    apply eq_vec_map; introv i.
    rewrite swap_term_dynamic_semantics_term; auto.
  }

  { Case "KFquantifier".
    introv ih; introv.
    remember (I (SymbolQuantifier f)) as C; simpl in C.
    destruct C as [C ext]; simpl in *; clear HeqC.
    apply ext; introv; tcsp.
    rewrite swap_state_twice; auto.
  }

  { Case "KFforallVars".
    introv ih; introv.
    split; intro h; introv len; autorewrite with core in *.

    { applydup h in len.
      rewrite ih in len0.
      eapply ext_dynamic_semantics_formula;[| |exact len0].
      { introv; apply upd_list_state_swap_state. }
      { apply ext_interpretations_refl. }
    }

    { applydup h in len.
      rewrite ih.
      eapply ext_dynamic_semantics_formula;[| |exact len0].
      { introv; symmetry; apply upd_list_state_swap_state. }
      { apply ext_interpretations_refl. }
    }
  }

  { Case "KFexistsVars".
    introv ih; introv.
    split; intro h; introv; exrepnd; exists rs; autorewrite with core in *; dands; auto.

    { apply ih in h0.
      eapply ext_dynamic_semantics_formula;[| |exact h0].
      { introv; apply upd_list_state_swap_state. }
      { apply ext_interpretations_refl. }
    }

    { apply ih.
      eapply ext_dynamic_semantics_formula;[| |exact h0].
      { introv; symmetry; apply upd_list_state_swap_state. }
      { apply ext_interpretations_refl. }
    }
  }

  { Case "KFbox".
    introv ihp ihf; introv.
    split; introv h dsp.

    {
      pose proof (ihf sw I (swap_state sw w)) as q.
      rewrite swap_state_twice in q; apply q; clear q.
      apply h; clear h.
      apply ihp.
      rewrite swap_state_twice; auto.
    }

    {
      apply ihf; clear ihf.
      apply h; clear h.
      apply ihp; auto.
    }
  }

  { Case "KFdiamond".
    introv ihp ihf; introv.
    split; introv h; exrepnd.

    {
      exists (swap_state sw w); dands; auto.
      { apply ihf; auto. }
      { apply ihp; auto. }
    }

    {
      exists (swap_state sw w); dands.
      { apply ihf; rewrite swap_state_twice; auto. }
      { apply ihp; rewrite swap_state_twice; auto. }
    }
  }

  { Case "KPconstant".
    repeat (rewrite swap_state_twice); tcsp.
  }

  { Case "KPassign".
    rewrite swap_term_dynamic_semantics_term.
    split; introv h; unfold differ_state_except in *;
      repnd; dands; auto; introv i.

    { unfold swap_state.
      apply h0; intro xx.
      apply eq_swap_assgn_implies_eq in xx; tcsp. }

    { pose proof (h0 (swap_assgn sw y)) as q.
      autodimp q hyp.
      { intro xx; subst.
        autorewrite with core in *; tcsp. }
      repeat (rewrite swap_state_swap_assgn in q); auto. }
  }

  { Case "KPassignAny".
    split; intro h; exrepnd; exists r; unfold differ_state_except in *;
      repnd; dands; auto; introv i.

    { unfold swap_state.
      apply h1; intro xx.
      apply eq_swap_assgn_implies_eq in xx; tcsp. }

    { pose proof (h1 (swap_assgn sw y)) as q.
      autodimp q hyp.
      { intro xx; subst.
        autorewrite with core in *; tcsp. }
      repeat (rewrite swap_state_swap_assgn in q); auto. }
  }

  { Case "KPtest".
    introv ihf; introv.
    split; intro h; repnd; subst.

    { rewrite <- ihf; dands; auto. }

    { rewrite <- ihf in h; dands; auto.
      apply swap_state_inj in h0; auto. }
  }

  { Case "KPcompose".
    introv ih1 ih2; introv.
    split; intro h; exrepnd.
    { rewrite ih1 in h1.
      rewrite ih2 in h0.
      eexists; dands; eauto. }
    { pose proof (ih1 sw I v (swap_state sw s)) as q.
      rewrite swap_state_twice in q.
      apply q in h1; clear q.

      pose proof (ih2 sw I (swap_state sw s) w) as q.
      rewrite swap_state_twice in q.
      apply q in h0; clear q.

      exists (swap_state sw s); dands; auto.
    }
  }

  { Case "KPloop".
    introv ih; introv; split; introv h;
      allrw program_close_implies_all; exrepnd; exists n.

    {
      revert w h0.
      induction n; introv dsp; simpl in *; repnd; subst; dands; auto.
      exrepnd.
      exists (swap_state sw s).
      apply IHn in dsp1; clear IHn.
      apply ih in dsp0; clear ih.
      dands; auto.
    }

    {
      revert w h0.
      induction n; introv dsp; simpl in *; repnd; subst; dands; auto.

      { apply swap_state_inj in dsp0; auto. }

      exrepnd.
      pose proof (IHn (swap_state sw s)) as q; clear IHn.
      rewrite swap_state_twice in q; apply q in dsp1; clear q.
      pose proof (ih sw I (swap_state sw s) w) as q; clear ih.
      rewrite swap_state_twice in q; apply q in dsp0; clear q.
      exists (swap_state sw s); dands; auto.
    }
  }

  { Case "KPodeSystem".
    introv ih; introv.
    split; intro h; exrepnd; subst.

    { exists r (fun x => swap_state sw (phi x)).
      dands; auto.

      { introv i.
        unfold swap_state.
        apply h0.
        rewrite ode_footprint_diff_swap_interp in i.
        intro j; destruct i; rewrite in_map_iff.
        eexists; dands;[|eauto].
        rewrite swap_assgn_twice; auto. }

      { apply dynamic_semantics_ode_swap_ode; auto. }

      { introv; pose proof (h1 zeta) as q; clear h1; repnd.
        unfold swap_state; simpl.
        rewrite ih in q0; clear ih.
        unfold swap_state in q0; dands; auto.

        introv i.
        apply q.
        rewrite ode_footprint_swap_interp in i.
        intro j; destruct i; rewrite in_map_iff.
        eexists; dands;[|eauto].
        rewrite swap_assgn_twice; auto. }
    }

    { exists r (fun x => swap_state sw (phi x)).
      unfold swap_state in *; simpl in *.
      dands; auto.

      { introv i.
        pose proof (h0 (swap_assgn sw x)) as q.
        rewrite ode_footprint_diff_swap_interp in q.
        autodimp q hyp.
        { rewrite in_map_iff.
          introv xx; destruct i; exrepnd.
          apply eq_swap_assgn_implies_eq in xx1; subst; auto. }
        rewrite swap_assgn_twice in q; auto. }

      { rewrite <- h2.
        apply functional_extensionality; introv.
        rewrite swap_assgn_twice; auto. }

      { apply dynamic_semantics_ode_swap_ode; auto.
        unfold swap_state; simpl.
        assert ((fun (x : R) (a : KAssignable) => phi x (swap_assgn sw (swap_assgn sw a)))
                = phi) as xx.
        { apply functional_extensionality; introv.
          apply functional_extensionality; introv.
          rewrite swap_assgn_twice; auto. }
        rewrite xx; clear xx; auto. }

      { introv; pose proof (h1 zeta) as q; clear h1; repnd.
        rewrite ih; clear ih.
        assert ((fun (a : KAssignable) => phi zeta (swap_assgn sw (swap_assgn sw a)))
                = phi zeta) as xx.
        { apply functional_extensionality; introv.
          rewrite swap_assgn_twice; auto. }
        rewrite xx; clear xx; dands; auto.

        introv i.
        apply q.
        rewrite ode_footprint_swap_interp.
        intro j; destruct i; rewrite in_map_iff in j; exrepnd.
        apply eq_swap_assgn_implies_eq in j1; subst; auto. }
    }
  }
Qed.

Lemma swap_dynamic_semantics_formula :
  forall f sw I v,
    dynamic_semantics_formula I (swap_formula sw f) v
    <->
    dynamic_semantics_formula (swap_interp sw I) f (swap_state sw v).
Proof.
  pose proof swap_dynamic_semantics_formula_program; tcsp.
Qed.

Definition swap_rule (f : Formula) (sw : swapping) : rule :=
  MkRule
    [f]
    (swap_formula sw f).

Lemma swap_rule_true :
  forall f sw, rule_true (swap_rule f sw).
Proof.
  introv h; simpl in *.
  dLin_hyp q.
  repeat introv.
  apply swap_dynamic_semantics_formula.
  apply q.
Qed.

Lemma swap_vars_twice :
  forall sw l,
    swap_vars sw (swap_vars sw l) = l.
Proof.
  induction l; simpl; auto.
  rewrite IHl.
  rewrite swap_twice; auto.
Qed.
Hint Rewrite swap_vars_twice : core.

Lemma swap_assgns_twice :
  forall sw l,
    swap_assgns sw (swap_assgns sw l) = l.
Proof.
  induction l; simpl; auto.
  rewrite IHl.
  rewrite swap_assgn_twice; auto.
Qed.
Hint Rewrite swap_assgns_twice : core.

Lemma ext_interpretations_at_swap_interp_twice :
  forall sw I s,
    ext_interpretations_at
      (swap_interp sw (swap_interp sw I))
      I
      s.
Proof.
  repeat introv.
  destruct s; simpl; tcsp.

  { introv h q.
    remember (I (SymbolQuantifier f)) as F.
    destruct F as [F cond]; clear HeqF; simpl in *.
    apply cond; clear cond; introv;
      rewrite swap_state_twice; auto. }

  { introv h.
    rewrite swap_state_twice.
    assert (v = w) as xx by (apply functional_extensionality; auto).
    subst; tcsp. }

  { rewrite swap_assgns_twice; dands; auto.
    introv h.
    rewrite swap_state_twice.
    remember (I (SymbolODE c)) as C.
    destruct C as [bv sem ext]; simpl in *; clear HeqC.
    apply ext; clear ext.
    introv.
    rewrite swap_state_twice; auto. }

  { introv h1 h2.
    repeat (rewrite swap_state_twice).
    assert (v1 = v2) as xx1 by (apply functional_extensionality; auto).
    assert (w1 = w2) as xx2 by (apply functional_extensionality; auto).
    subst; tcsp. }
Qed.
Hint Resolve ext_interpretations_at_swap_interp_twice : core.

Lemma swap_interp_twice :
  forall sw I,
    ext_interpretations
      (swap_interp sw (swap_interp sw I))
      I.
Proof.
  repeat introv.
  apply ext_interpretations_at_swap_interp_twice.
Qed.
Hint Resolve swap_interp_twice : core.

Lemma equal_interpretations_on_ext_swap_interp_twice :
  forall sw I l,
    equal_interpretations_on_ext
      (swap_interp sw (swap_interp sw I))
      I
      l.
Proof.
  introv i.
  apply ext_interpretations_at_swap_interp_twice.
Qed.
Hint Resolve equal_interpretations_on_ext_swap_interp_twice : core.


Require Import Vector List Lia.

Require Import Coq.Vectors.Vector.
Definition vec := t.

Require Import Equations.Equations.

(** * Definition of First Order Logic in Coq *)

(**

Renaming table w.r.t. the three existing developments

new name     | TRAKH name     | completeness name
--------------------------------------------------
syms         | syms           | Funcs
ar_syms      | ar_syms        | fun_ar
var          | in_var         | var_term
func         | in_fot         | Func
preds        | rels           | Preds
ar_preds     | ar_rels        | pred_ar
binop        | fol_bop        | -
quantop      | fol_qop        | -
fal          | fol_false      | Fal
atom         | fol_atom       | Pred
bin          | fol_bin        | Impl / ...
quant        | fol_quant      | All / ...

 *)

(* Some preliminary definitions for substitions  *)
Definition scons {X: Type} (x : X) (xi : nat -> X) :=
  fun n => match n with
        | 0 => x
        | S n => xi n
        end.

Definition funcomp {X Y Z} (g : Y -> Z) (f : X -> Y)  :=
  fun x => g (f x).

(* Signatures are a record to allow for easier definitions of general transformations on signatures *)

Class funcs_signature :=
  { syms : Type; ar_syms : syms -> nat }.

Coercion syms : funcs_signature >-> Sortclass.

Class preds_signature :=
  { preds : Type; ar_preds : preds -> nat }.

Coercion preds : preds_signature >-> Sortclass.

Section fix_signature.

  Context {Σ_funcs : funcs_signature}.

  (* We use the stdlib definition of vectors to be maximally compatible  *)

  Unset Elimination Schemes.

  Inductive term  : Type :=
  | var : nat -> term
  | func : forall (f : syms), vec term (ar_syms f) -> term.

  Set Elimination Schemes.

  Fixpoint subst_term (σ : nat -> term) (t : term) : term :=
    match t with
    | var t => σ t
    | func f v => func f (map (subst_term σ) v)
    end.

  Context {Σ_preds : preds_signature}.

  (* We use a flag to switch on and off a constant for falisity *)

  Inductive falsity_flag := falsity_off | falsity_on.
  Existing Class falsity_flag.
  Existing Instance falsity_on | 1.
  Existing Instance falsity_off | 0.

  (* Syntax is parametrised in binary operators and quantifiers.
      Most developments will fix these types in the beginning and never change them.
   *)
  Class operators := {binop : Type ; quantop : Type}.
  Context {ops : operators}.

  (* Formulas have falsity as fixed constant -- we could parametrise against this in principle *)
  Inductive form : falsity_flag -> Type :=
  | falsity : form falsity_on
  | atom {b} : forall (P : preds), vec term (ar_preds P) -> form b
  | bin {b} : binop -> form b -> form b -> form b
  | eq {b} : term -> term -> form b
  | quant {b} : quantop -> form b -> form b.
  Arguments form {_}.

  Lemma form_ind_falsity_on :
    forall f : form -> Type,
      f falsity ->
      (forall P (t : vec term (ar_preds P)), f (atom P t)) ->
      (forall (b : binop) (φ : form), f φ -> forall ψ : form, f ψ -> f (bin b φ ψ)) ->
      (forall t s, f (eq t s) ) ->
      (forall (q : quantop) (φ : form), f φ -> f (quant q φ)) ->
      forall (φ : form), f φ.
  Proof.
    intros. specialize (form_rect (fun ff => match ff with falsity_on => f | _ => fun _ => True end)).
    intros H'. apply H' with (f5 := falsity_on); clear H'. all: intros; try destruct b; trivial.
    all: intuition eauto 2.
  Qed.

  Definition up (σ : nat -> term) := scons (var 0) (funcomp (subst_term (funcomp var S)) σ).

  Fixpoint subst_form `{falsity_flag} (σ : nat -> term) (phi : form) : form :=
    match phi with
    | falsity => falsity
    | atom P v => atom P (map (subst_term σ) v)
    | bin op phi1 phi2 => bin op (subst_form σ phi1) (subst_form σ phi2)
    | eq s t => eq (subst_term σ s) (subst_term σ t)
    | quant op phi => quant op (subst_form (up σ) phi)
    end.

  Fixpoint form_depth `{falsity_flag} phi :=
    match phi with
    | falsity => 0
    | atom P v => 0
    | bin op phi1 phi2 => S (form_depth phi1 + form_depth phi2)
    | eq s t => 0
    | quant op phi => S (form_depth phi)
    end.

  (* Induction principle for terms *)

  Inductive Forall {A : Type} (P : A -> Type) : forall {n}, t A n -> Type :=
  | Forall_nil : Forall P (@Vector.nil A)
  | Forall_cons : forall n (x : A) (l : t A n), P x -> Forall P l -> Forall P (@Vector.cons A x n l).

  Inductive vec_in {A : Type} (a : A) : forall {n}, t A n -> Type :=
  | vec_inB {n} (v : t A n) : vec_in a (cons A a n v)
  | vec_inS a' {n} (v : t A n) : vec_in a v -> vec_in a (cons A a' n v).
  Hint Constructors vec_in : core.

  Lemma term_rect' (p : term -> Type) :
    (forall x, p (var x)) -> (forall F v, (Forall p v) -> p (func F v)) -> forall (t : term), p t.
  Proof.
    intros f1 f2. fix strong_term_ind' 1. destruct t as [n|F v].
    - apply f1.
    - apply f2. induction v.
      + econstructor.
      + econstructor. now eapply strong_term_ind'. eauto.
  Qed.

  Lemma term_rect (p : term -> Type) :
    (forall x, p (var x)) -> (forall F v, (forall t, vec_in t v -> p t) -> p (func F v)) -> forall (t : term), p t.
  Proof.
    intros f1 f2. eapply term_rect'.
    - apply f1.
    - intros. apply f2. intros t. induction 1; inversion X; subst; eauto.
      apply Eqdep_dec.inj_pair2_eq_dec in H2; subst; eauto. decide equality.
  Qed.

  Lemma term_ind (p : term -> Prop) :
    (forall x, p (var x)) -> (forall F v (IH : forall t, In t v -> p t), p (func F v)) -> forall (t : term), p t.
  Proof.
    intros f1 f2. eapply term_rect'.
    - apply f1.
    - intros. apply f2. intros t. induction 1; inversion X; subst; eauto.
      apply Eqdep_dec.inj_pair2_eq_dec in H3; subst; eauto. decide equality.
  Qed.

End fix_signature.

(* Setting implicit arguments is crucial  *)
(* We can write term both with and without arguments, but printing is without. *)
Arguments term _, {_}.
Arguments var _ _, {_} _.
Arguments func _ _ _, {_} _ _.
Arguments subst_term {_} _ _.

(* Formulas can be written with the signatures explicit or not.
    If the operations are explicit, the signatures are too.
 *)
Arguments form  _ _ _ _, _ _ {_ _}, {_ _ _ _}, {_ _ _} _.
Arguments atom  _ _ _ _, _ _ {_ _}, {_ _ _ _}.
Arguments bin   _ _ _ _, _ _ {_ _}, {_ _ _ _}.
Arguments quant _ _ _ _, _ _ {_ _}, {_ _ _ _}.

Arguments up         _, {_}.
Arguments subst_form _ _ _ _, _ _ {_ _}, {_ _ _ _}.

(* Substitution Notation *)

Declare Scope subst_scope.
Open Scope subst_scope.

Notation "$ x" := (var x) (at level 3, format "$ '/' x") : subst_scope.
Notation "t `[ sigma ]" := (subst_term sigma t) (at level 7, left associativity, format "t '/' `[ sigma ]") : subst_scope.
Notation "phi [ sigma ]" := (subst_form sigma phi) (at level 7, left associativity, format "phi '/' [ sigma ]") : subst_scope.
Notation "s .: sigma" := (scons s sigma) (at level 70, right associativity) : subst_scope.
Notation "f >> g" := (funcomp g f) (at level 50) : subst_scope.
Notation "s '..'" := (scons s var) (at level 4, format "s ..") : subst_scope.
Notation "↑" := (S >> var) : subst_scope.

(** Substituion lemmas *)

Ltac cbns :=
    cbn; repeat (match goal with [ |- context f[subst_form ?sigma ?phi] ] => change (subst_form sigma phi) with (phi[sigma]) end).

Section Subst.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {ops : operators}.

  Lemma subst_term_ext (t : term) sigma tau :
    (forall n, sigma n = tau n) -> t`[sigma] = t`[tau].
  Proof.
    intros H. induction t; cbn.
    - now apply H.
    - f_equal. now apply map_ext_in.
  Qed.

  Lemma subst_term_id (t : term) sigma :
    (forall n, sigma n = var n) -> t`[sigma] = t.
  Proof.
    intros H. induction t; cbn.
    - now apply H.
    - f_equal. now erewrite map_ext_in, map_id.
  Qed.

  Lemma subst_term_var (t : term) :
    t`[var] = t.
  Proof.
    now apply subst_term_id.
  Qed.

  Lemma subst_term_comp (t : term) sigma tau :
    t`[sigma]`[tau] = t`[sigma >> subst_term tau].
  Proof.
    induction t; cbn.
    - reflexivity.
    - f_equal. rewrite map_map. now apply map_ext_in.
  Qed.

  Lemma subst_term_shift (t : term) s :
    t`[↑]`[s..] = t.
  Proof.
    rewrite subst_term_comp. apply subst_term_id. now intros [|].
  Qed.

  Lemma up_term (t : term) xi :
    t`[↑]`[up xi] = t`[xi]`[↑].
  Proof.
    rewrite !subst_term_comp. apply subst_term_ext. reflexivity.
  Qed.

  Lemma up_ext sigma tau :
    (forall n, sigma n = tau n) -> forall n, up sigma n = up tau n.
  Proof.
    destruct n; cbn; trivial.
    unfold funcomp. now rewrite H.
  Qed.

  Lemma up_var sigma :
    (forall n, sigma n = var n) -> forall n, up sigma n = var n.
  Proof.
    destruct n; cbn; trivial.
    unfold funcomp. now rewrite H.
  Qed.

  Lemma up_funcomp sigma tau :
    forall n, (up sigma >> subst_term (up tau)) n = up (sigma >> subst_term tau) n.
  Proof.
    intros [|]; cbn; trivial.
    setoid_rewrite subst_term_comp.
    apply subst_term_ext. now intros [|].
  Qed.

  Lemma subst_ext {ff : falsity_flag} (phi : form) sigma tau :
    (forall n, sigma n = tau n) -> phi[sigma] = phi[tau].
  Proof.
    induction phi in sigma, tau |- *; cbns; intros H.
    - reflexivity.
    - f_equal. apply map_ext. intros s. now apply subst_term_ext.
    - now erewrite IHphi1, IHphi2.
    - f_equal; now apply subst_term_ext.
    - erewrite IHphi; trivial. now apply up_ext.
  Qed.

  Lemma subst_id {ff : falsity_flag} (phi : form) sigma :
    (forall n, sigma n = var n) -> phi[sigma] = phi.
  Proof.
    induction phi in sigma |- *; cbns; intros H.
    - reflexivity.
    - f_equal. erewrite map_ext; try apply map_id. intros s. now apply subst_term_id.
    - now erewrite IHphi1, IHphi2.
    - f_equal; now apply subst_term_id.
    - erewrite IHphi; trivial. now apply up_var.
  Qed.

  Lemma subst_var {ff : falsity_flag} (phi : form) :
    phi[var] = phi.
  Proof.
    now apply subst_id.
  Qed.

  Lemma subst_comp {ff : falsity_flag} (phi : form) sigma tau :
    phi[sigma][tau] = phi[sigma >> subst_term tau].
  Proof.
    induction phi in sigma, tau |- *; cbns.
    - reflexivity.
    - f_equal. rewrite map_map. apply map_ext. intros s. apply subst_term_comp.
    - now rewrite IHphi1, IHphi2.
    - f_equal; now apply subst_term_comp.
    - rewrite IHphi. f_equal. now apply subst_ext, up_funcomp.
  Qed.

  Lemma subst_shift {ff : falsity_flag} (phi : form) s :
    phi[↑][s..] = phi.
  Proof.
    rewrite subst_comp. apply subst_id. now intros [|].
  Qed.

  Lemma up_form {ff : falsity_flag} xi psi :
    psi[↑][up xi] = psi[xi][↑].
  Proof.
    rewrite !subst_comp. apply subst_ext. reflexivity.
  Qed.

  Fixpoint iter {X: Type} f n (x : X) :=
    match n with
      0 => x
    | S m => f (iter f m x)
    end.

  Lemma iter_switch {X} f n (x : X) :
    f (iter f n x) = iter f n (f x).
  Proof.
    induction n. reflexivity.
    cbn. now rewrite IHn.
  Qed.

  Lemma up_decompose {ff : falsity_flag} sigma phi :
    phi[up (S >> sigma)][(sigma 0)..] = phi[sigma].
  Proof.
    rewrite subst_comp. apply subst_ext.
    intros [].
    - reflexivity.
    - apply subst_term_shift.
  Qed.

End Subst.

(** Bounded formulas *)

Section Bounded.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {ops : operators}.

  Inductive bounded_t n : term -> Prop :=
  | bounded_var x : n > x -> bounded_t n $x
  | bouded_func f v : (forall t, Vector.In t v -> bounded_t n t) -> bounded_t n (func f v).

  Inductive bounded : forall {ff}, nat -> form ff -> Prop :=
  | bounded_atom ff n P v : (forall t, Vector.In t v -> bounded_t n t) -> @bounded ff n (atom P v)
  | bounded_bin binop ff n phi psi : @bounded ff n phi -> @bounded ff n psi -> @bounded ff n (bin binop phi psi)
  | bounded_eq ff n s t : bounded_t n s -> bounded_t n t -> @bounded ff n (eq s t)
  | bounded_quant quantop ff n phi : @bounded ff (S n) phi -> @bounded ff n (quant quantop phi)
  | bounded_falsity n : @bounded falsity_on n falsity.

  Arguments bounded {_} _ _.

  Definition bounded_L {ff : falsity_flag} n A :=
    forall phi, List.In phi A -> bounded n phi.

  Lemma bounded_subst_t n t sigma tau :
    (forall k, n > k -> sigma k = tau k) -> bounded_t n t -> t`[sigma] = t`[tau].
  Proof.
    intros H. induction 1; cbn; auto.
    f_equal. now apply Vector.map_ext_in.
  Qed.

  Lemma bounded_subst {ff : falsity_flag} {n phi sigma tau} :
    bounded n phi -> (forall k, n > k -> sigma k = tau k) -> phi[sigma] = phi[tau].
  Proof.
    induction 1 in sigma, tau |- *; cbn; intros HN; trivial.
    - f_equal. apply Vector.map_ext_in. intros t Ht.
      eapply bounded_subst_t; try apply HN. now apply H.
    - now rewrite (IHbounded1 sigma tau), (IHbounded2 sigma tau).
    - f_equal; eapply bounded_subst_t; eauto.
    - f_equal. apply IHbounded. intros [|k] Hk; cbn; trivial.
      unfold funcomp. rewrite HN; trivial. lia.
  Qed.

  Lemma bounded_up_t {n t k} :
    bounded_t n t -> k >= n -> bounded_t k t.
  Proof.
    induction 1; intros Hk; constructor; try lia. firstorder.
  Qed.

  Lemma bounded_up {ff : falsity_flag} {n phi k} :
    bounded n phi -> k >= n -> bounded k phi.
  Proof.
    induction 1 in k |- *; intros Hk; constructor; eauto.
    - intros t Ht. eapply bounded_up_t; eauto.
    - eapply bounded_up_t; eauto.
    - eapply bounded_up_t; eauto.
    - apply IHbounded. lia.
  Qed.

  Derive Signature for In.

  Lemma find_bounded_step n (v : vec term n) :
    (forall t : term, vec_in t v -> {n : nat | bounded_t n t}) -> { n | forall t, In t v -> bounded_t n t }.
  Proof.
    induction v; cbn; intros HV.
    - exists 0. intros t. inversion 1.
    - destruct IHv as [k Hk], (HV h) as [l Hl]; try left.
      + intros t Ht. apply HV. now right.
      + exists (k + l). intros t H. depelim H; cbn in *.
        * injection H. intros _ <-. apply (bounded_up_t Hl). lia.
        * injection H0. intros -> % Eqdep_dec.inj_pair2_eq_dec _; try decide equality.
          apply (bounded_up_t (Hk t H)). lia.
  Qed.

  Lemma find_bounded_t t :
    { n | bounded_t n t }.
  Proof.
    induction t using term_rect.
    - exists (S x). constructor. lia.
    - apply find_bounded_step in X as [n H]. exists n. now constructor.
  Qed.

  Lemma find_bounded {ff : falsity_flag} phi :
    { n | bounded n phi }.
  Proof.
    induction phi.
    - exists 0. constructor.
    - destruct (find_bounded_step _ v) as [n Hn].
      + eauto using find_bounded_t.
      + exists n. now constructor.
    - destruct IHphi1 as [n Hn], IHphi2 as [k Hk]. exists (n + k).
      constructor; eapply bounded_up; try eassumption; lia.
    - destruct (find_bounded_t t) as [n Hn], (find_bounded_t t0) as [l Hl].
      exists (n + l). constructor; eapply bounded_up_t; eauto; lia.
    - destruct IHphi as [n Hn]. exists n. constructor. apply (bounded_up Hn). lia.
  Qed.

  Lemma find_bounded_L {ff : falsity_flag} A :
    { n | bounded_L n A }.
  Proof.
    induction A; cbn.
    - exists 0. intros phi. inversion 1.
    - destruct IHA as [k Hk], (find_bounded a) as [l Hl].
      exists (k + l). intros t [<-|H]; eapply bounded_up; try eassumption; try (now apply Hk); lia.
  Qed.

  Ltac invert_bounds :=
    inversion 1; subst;
    repeat match goal with
             H : existT _ _ _ = existT _ _ _ |- _ => apply Eqdep_dec.inj_pair2_eq_dec in H; try decide equality
           end; subst.

  Lemma vec_cons_inv X n (v : Vector.t X n) x y :
    In y (Vector.cons X x n v) -> (y = x) \/ (In y v).
  Proof.
    inversion 1; subst.
    - now left.
    - apply EqDec.inj_right_pair in H3 as ->. now right.
  Qed.

  Definition dec (P : Prop) := {P} + {~P}.

  Lemma vec_all_dec X n (v : vec X n) (P : X -> Prop) :
    (forall x, vec_in x v -> dec (P x)) -> dec (forall x, In x v -> P x).
  Proof.
    induction v; intros H.
    - left. intros x. inversion 1.
    - destruct (H h) as [H1|H1], IHv as [H2|H2]; try now left.
      + intros x Hx. apply H. now right.
      + intros x Hx. apply H. now right.
      + left. intros x [<-| Hx] % vec_cons_inv; intuition.
      + right. contradict H2. intros x Hx. apply H2. now right.
      + intros x Hx. apply H. now right.
      + right. contradict H1. apply H1. now left.
      + right. contradict H1. apply H1. now left.
  Qed.

  Context {sig_funcs_dec : EqDec Σ_funcs}.
  Context {sig_preds_dec : EqDec Σ_preds}.

  Lemma bounded_t_dec n t :
    dec (bounded_t n t).
  Proof.
    pattern t; revert t. apply term_rect.
    - intros x. destruct (Compare_dec.gt_dec n x) as [H|H].
      + left. now constructor.
      + right. inversion 1; subst. tauto.
    - intros F v X. apply vec_all_dec in X as [H|H].
      + left. now constructor.
      + right. inversion 1; subst. apply EqDec.inj_right_pair in H3 as ->. tauto.
  Qed.

End Bounded.

Ltac solve_bounds :=
  repeat constructor; try lia; try inversion X; intros;
  match goal with
  | H : Vector.In ?x (@Vector.cons _ ?y _ ?v) |- _ => repeat apply vec_cons_inv in H as [->|H]; try inversion H
  | H : Vector.In ?x (@Vector.nil _) |- _ => try inversion H
  | _ => idtac
  end.


(* Pentru string *)
Require Import Strings.String.
Local Open Scope string_scope.
Local Open Scope list_scope.
Scheme Equality for string.

(* Tipuri de date boolean/int/string*)
Inductive natv :=
  | errorNt: natv
  | natV: nat -> natv.

Inductive boolv :=
  | errorB: boolv
  | boolV: bool -> boolv.

Inductive strv :=
  | errorS: strv
  | strV: string -> strv.

Coercion natV : nat >-> natv.
Coercion boolV : bool >-> boolv.
Coercion strV : string >-> strv.

Inductive Result :=
  | err_undecl : Result
  | err_assign : Result
  | default : Result
  | res_nat : natv -> Result
  | res_bool :boolv -> Result
  | res_str: strv -> Result.

Scheme Equality for Result.

Definition Env := string -> Result.

Definition env : Env := fun x => err_undecl.
Definition env_notdecl : Env :=
    fun v => err_assign.

(*Verificarea existentei variabilei*)
Definition CheckVariable (a : Result) (b : Result) : bool :=
  match a with
  | err_undecl => match b with
                   | err_undecl => true
                   | _ => false
                   end
  | err_assign => match b with
                   | err_assign => true
                   | _ => false
                   end
  | res_nat n1 => match b with
                   | res_nat n2 => true
                   | _ => false
                   end
  | res_bool b1 => match b with
                   | res_bool b2 => true
                   | _ => false
                   end
  | res_str s1 => match b with
                   | res_str s2 => true
                   | _ => false
                   end
  | default => match b with
                   | default => true
                   | _ => false
                   end
end.
Compute CheckVariable (res_nat 15) (res_nat 25).

Definition update (env : Env) ( s: string ) ( v : Result ) : Env :=
fun y =>
 if(string_beq s y) then
     if ( andb( CheckVariable (env y) err_undecl) true )
                     then  v
         else if (andb( CheckVariable (env y) v) true ) then v else err_assign
      else (env y).
Check (env "x").
Notation "S [ V /' X ]" := (update S X V) ( at level 0).
Check (update env "x" (res_nat 5)).
Inductive SExp:=
  | string_var: string -> SExp
  | string_error: strv ->SExp
  | conc: strv -> strv -> SExp
  | cmp: strv -> strv -> SExp.
Coercion string_var : string >-> SExp.

Inductive AExp:=
  | avar: string -> AExp
  | anum: natv -> AExp
  | aadd: AExp -> AExp -> AExp
  | asub: AExp -> AExp -> AExp
  | amul: AExp -> AExp -> AExp
  | adiv: AExp -> AExp -> AExp
  | amod: AExp -> AExp -> AExp
  | amax:  AExp -> AExp -> AExp
  | amin:   AExp -> AExp -> AExp
 | len: strv -> AExp.

Coercion anum : natv >-> AExp.
Coercion avar : string >-> AExp.
(*Notatii operatii tip nat *)
Notation "A +' B" := (aadd A B)(at level 33, left associativity).
Notation "A -' B" := (asub A B)(at level 33, left associativity).
Notation "A *' B" := (amul A B)(at level 33, left associativity).
Notation "A /' B" := (adiv A B)(at level 31, left associativity).
Notation "A %' B" := (amod A B)(at level 31, left associativity).
Notation "A []' B" := (amax A B)(at level 31, left associativity).
Notation "A ][' B" := (amin A B)(at level 31, left associativity).

Compute 5 +' 3.
Compute "x" -' 2.

Definition plus_ErrorNat (n1 n2 : natv) : natv :=
  match n1, n2 with
    | errorNt, _ => errorNt
    | _, errorNt => errorNt
    | natV v1, natV v2 => natV (v1 + v2)
    end.
Compute plus_ErrorNat (natV 9) (natV 15).
Definition sub_ErrorNat (n1 n2 : natv) :natv :=
  match n1, n2 with
    | errorNt, _ => errorNt
    | _, errorNt => errorNt
    | natV n1, natV n2 => if Nat.ltb n1 n2
                        then errorNt
                        else natV (n1 - n2)
    end.
Compute sub_ErrorNat (natV 8) (natV 3).
Definition mul_ErrorNat (n1 n2 : natv) : natv :=
  match n1, n2 with
    | errorNt, _ => errorNt
    | _, errorNt => errorNt
    | natV v1, natV v2 => natV (v1 * v2)
    end.
Compute mul_ErrorNat (natV 2) (natV 5).
Definition div_ErrorNat (n1 n2 : natv) : natv :=
  match n1, n2 with
    | errorNt, _ => errorNt
    | _, errorNt => errorNt
    | _, natV 0 => errorNt
    | natV v1, natV v2 => natV (Nat.div v1 v2)
    end.
Compute div_ErrorNat (natV 10) (natV 2).
Definition mod_ErrorNat (n1 n2 : natv) : natv :=
  match n1, n2 with
    | errorNt, _ => errorNt
    | _, errorNt => errorNt
    | _, natV 0 => errorNt
    | natV v1, natV v2 => natV (v1 - v2 * (Nat.div v1 v2))
    end.

Definition max_ErrorNat (n1 n2 : natv) : natv :=
  match n1, n2 with
    | errorNt, _ => errorNt
    | _, errorNt => errorNt
    | natV v1, natV v2 => if( Nat.leb v1  v2)
                                       then v2
                                       else v1
    end.

Compute max_ErrorNat 19 15.

Definition min_ErrorNat (n1 n2 : natv) : natv :=
  match n1, n2 with
    | errorNt, _ => errorNt
    | _, errorNt => errorNt
    | natV v1, natV v2 => if( Nat.leb v1  v2)
                                       then v1
                                       else v2
    end.

Compute min_ErrorNat 19 15.

(* Bool *)
Inductive BExp:=
  | bool: string -> BExp
  | berror: BExp
  | btrue: BExp
  | bfalse: BExp
  | bnot: BExp -> BExp
  | band: BExp -> BExp -> BExp
  | or: BExp -> BExp -> BExp
  | lthan: AExp -> AExp -> BExp
  | greater: AExp-> AExp -> BExp.

Coercion bool : string >-> BExp.

(*Notatii operatii tip boolean *)
Notation "! A" := (bnot A) (at level 30, right associativity).
Notation "A &&' B" := (band A B) (at level 33, left associativity).
Notation "A ||' B" := (or A B) (at level 32, left associativity).
Notation "A <' B" := (lthan A B) (at level 32, left associativity).
Notation "A >' B" := (greater A B) (at level 32, left associativity).

Definition ltthan_ErrorBool (n1 n2 : natv) : boolv :=
  match n1, n2 with
    | errorNt, _ => errorB
    | _, errorNt => errorB
    | natV v1, natV v2 =>  boolV (Nat.ltb v1 v2)
    end.

Definition ltgreater_ErrorBool (n1 n2 : natv) : boolv :=
  match n1, n2 with
    | _, errorNt => errorB
    | errorNt, _ => errorB
    | natV v1, natV v2 =>  boolV(Nat.ltb v1 v2)
    end.
Check( ltgreater_ErrorBool 5 6).

Definition not_ErrorBool (n :boolv) : boolv :=
  match n with
    | errorB => errorB
    | boolV v => boolV (negb v)
    end.

Definition and_ErrorBool (n1 n2 : boolv) : boolv :=
  match n1, n2 with
    | errorB, _ => errorB
    | _, errorB => errorB
    | boolV v1, boolV v2 =>  boolV (andb v1 v2)
    end.

Definition or_ErrorBool (n1 n2 : boolv) : boolv :=
  match n1, n2 with
    | errorB, _ => errorB
    | _, errorB => errorB
    | boolV v1, boolV v2 =>  boolV (orb v1 v2)
    end.

(*Notatii operatii tip string *)
 Notation "A +\' B" := (conc A B) (at level 31, left associativity).
Notation " @' A  ":=(len A) (at level 30).
Notation " A ()' B":=(cmp A B) (at level 30).

Compute "andrei +\' are mere".

Definition slength (strin : strv) : natv :=
  match strin with
    | errorS => errorNt
    | strV  str=> length str
end.

Compute slength "text5".

Definition sconcat (str1 : strv) (str2 : strv) : strv :=
    match str1,str2 with
    | errorS, _ => errorS
    | _, errorS => errorS
    | strV s1, strV s2 => strV( s1 ++ s2)
end.

Definition conv (st: strv) : string :=
  match st with
  | errorS => ""
  | strV s' => s'
  end.

Compute sconcat "Ana " "are mere".

Definition scmp (str1 : strv) (str2 : strv) : strv :=
    match str1,str2 with
    | errorS, _ => errorS
    | _, errorS => errorS
    | strV s1 , strV s2 =>if (Nat.leb(length s1) (length s2))
                                then s2
                                else s1
end.

Inductive Stmt :=
| nat_dec : string  -> Stmt
| bool_dec : string  -> Stmt
| string_dec : string -> Stmt
| natass: string -> AExp -> Stmt
| boolass : string -> BExp -> Stmt
| stringass : string -> SExp -> Stmt
| sequence : Stmt -> Stmt -> Stmt
| ifthen : BExp -> Stmt -> Stmt
| ifthenelse : BExp -> Stmt -> Stmt -> Stmt
| while : BExp -> Stmt -> Stmt
| FOR : Stmt -> BExp -> Stmt -> Stmt
| comm: string -> Stmt
| read : string -> Stmt
| write : SExp -> Stmt.

(*Notatii Statement *)
Notation "A :n= B" := (natass A B)(at level 70).
Check "var" :n= "i" +' 10.

Notation "A :b= B" := (boolass A B)(at level 70).
Check "var1" :b= bfalse.

Notation "A :s= B" := (stringass A B)(at level 70).
Check "var2" :s= "mama".

Notation "'Nat' A " := (nat_dec A)(at level 70).
Check Nat "var" .

Notation "'Bool' A " := (bool_dec A)(at level 70).
Check Bool "var1" .

Notation "'Str' A " := (string_dec A)(at level 70).
Check Str "var2" .

Notation "\cin>> A ":=(write A) (at level 70).
Check \cin>>( "A").

Notation "\cout<<(' A )":=(read A) (at level 70).
Check \cout<<(' "A").

Notation "'If' B 'then' S  'end" := (ifthen B S) (at level 71).

Notation "'If' B 'then' S1 'else' S2 'end" := (ifthenelse B S1 S2) (at level 71).

Notation "'While' ( A ) B" := (while A B)(at level 71).

Notation "A ;; B" := (sequence A B) (at level 71).

Notation "'For' ( A \ B \ C ) D " := (A ;; while B ( D ;; C ))(at level 71).
(*Comentarii *)
Notation " ||* a *|| " := (comm a ) (at level 72).

Check ( Nat "n"  ;; Str "y" ).
Check env "v1".
Check (4 *' 9).
Reserved Notation "B ~{ S }~> B'" (at level 70).
Inductive seval: SExp -> Env -> strv -> Prop :=
| s_var: forall v sigma, string_var v ~{ sigma }~>  match (sigma v) with
                                              | res_str x => x
                                              | _ => errorS
                                              end
| s_error: forall n sigma, string_error n ~{ sigma }~> n
| s_cat: forall a1 a2 i1 i2 sigma b,
    a1 ~{  sigma }~> i1 ->
    a2 ~{  sigma }~> i2 ->
    b = (sconcat i1 i2) ->
    i1 +\' i2 ~{ sigma }~> b
| s_cmp: forall a1 a2 i1 i2 sigma b,
    a1 ~{  sigma }~> i1 ->
    a2 ~{  sigma }~> i2 ->
    b = (scmp i1 i2) ->
    i1 ()' i2 ~{ sigma }~> b
where "B ~{ S }~> B'" := (seval B S B').

Reserved Notation "A =[ S ]=> N" (at level 60).
(* Big step pentru operatii cu nat *)
Inductive aeval : AExp -> Env -> natv -> Prop :=
| const : forall n sigma, anum n =[ sigma ]=> n
| var : forall v sigma, avar v =[ sigma ]=>  match (sigma v) with
                                              | res_nat x => x
                                              | _ => errorNt
                                              end
| add : forall a1 a2 i1 i2 n sigma,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (plus_ErrorNat i1 i2) ->
    a1 +' a2 =[sigma]=> n
| times : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (mul_ErrorNat i1 i2) ->
    a1 *' a2 =[sigma]=> n
| substract : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (sub_ErrorNat i1 i2) ->
    a1 -' a2 =[sigma]=> n
| division : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (div_ErrorNat  i1 i2) ->
    a1 /' a2 =[sigma]=> n
| modulo : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (mod_ErrorNat i1 i2) ->
    a1 %' a2 =[sigma]=> n
| max : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (max_ErrorNat i1 i2) ->
    a1 []' a2 =[sigma]=> n
| min : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (min_ErrorNat i1 i2) ->
    a1 ][' a2 =[sigma]=> n
(*| len : forall a1 i1  sigma n,
    a1 =  (slength i1) ->
    @' a1 =[sigma]=> n
*)

where "a =[ sigma ]=> n" := (aeval a sigma n).

Check ( 5 ][' 7).

Reserved Notation "B -{ S }-> B'" (at level 70).
(* Big step pentru Boolean *)
Inductive beval : BExp -> Env -> boolv -> Prop :=
| b_error: forall sigma, berror  -{ sigma }-> errorB
| b_true : forall sigma, btrue -{ sigma }-> true
| b_false : forall sigma, bfalse -{ sigma }-> false
| b_var : forall v sigma, bool v -{ sigma }->  match (sigma v) with
                                                | res_bool x => x
                                                | _ => errorB
                                                end
| b_lessthan : forall a1 a2 i1 i2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    b = (ltthan_ErrorBool i1 i2) ->
    a1 <' a2 -{ sigma }-> b
| b_greater : forall a1 a2 i1 i2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    b = (ltgreater_ErrorBool i1 i2) ->
    a1 >' a2 -{ sigma }-> b
| b_not : forall a1 i1 sigma b,
    a1 -{ sigma }-> i1 ->
    b = (not_ErrorBool i1) ->
    ! a1 -{ sigma }-> b
| b_and : forall a1 a2 i1 i2 sigma b,
    a1 -{ sigma }-> i1 ->
    a2 -{ sigma }-> i2 ->
    b = (and_ErrorBool i1 i2) ->
    (a1 &&' a2) -{ sigma }-> b
| b_or : forall a1 a2 i1 i2 sigma b,
    a1 -{ sigma }-> i1 ->
    a2 -{ sigma }-> i2 ->
    b = (or_ErrorBool i1 i2) ->
    (a1 ||' a2) -{ sigma }-> b
where "B -{ S }-> B'" := (beval B S B').

Reserved Notation "S --{ sigm }-> sigm'" (at level 80).
(* Big step pentru Statements *)
Inductive eval : Stmt -> Env -> Env -> Prop :=
| e_nat_decl: forall x sigma sigma',
   sigma' = update sigma x (res_nat 0) ->
   (Nat x) --{ sigma }-> sigma'
| e_nat_assign: forall a i x sigma sigma',
   a =[ sigma ]=> i ->
    sigma' = update sigma x (res_nat i) ->
    (x :n= a) --{ sigma }-> sigma'
| e_bool_decl: forall x sigma sigma',
   sigma' = update sigma x (res_bool true) ->
   (Bool x) --{ sigma }-> sigma'
| e_bool_assign: forall a i x sigma sigma',
    a -{ sigma }-> i ->
    sigma' = update sigma x (res_bool i) ->
    (x :b= a) --{ sigma }-> sigma'
| e_str_decl: forall x sigma sigma',
   sigma' = update sigma x (res_str "") ->
   (Str x) --{ sigma }-> sigma'
| e_str_assign: forall a i x sigma sigma',
    a ~{ sigma }~> i ->
    sigma' = (update sigma x (res_str i)) ->
    (x :s= a) --{ sigma }-> sigma'
| e_seq : forall s1 s2 sigma sigma1 sigma2,
    s1 --{ sigma }-> sigma1 ->
    s2 --{ sigma1 }-> sigma2 ->
    (s1 ;; s2) --{ sigma }-> sigma2
| e_if_then : forall b s sigma,
    ifthen b s --{ sigma }-> sigma
| e_if_then_elsetrue : forall b s1 s2 sigma sigma',
    b -{ sigma }-> true ->
    s1 --{ sigma }-> sigma' ->
    ifthenelse b s1 s2 --{ sigma }-> sigma'
| e_if_then_elsefalse : forall b s1 s2 sigma sigma',
    b -{ sigma }-> false ->
    s2 --{ sigma }-> sigma' ->
    ifthenelse b s1 s2 --{ sigma }-> sigma'
| e_whilefalse : forall b s sigma,
    b -{ sigma }-> false ->
    while b s --{ sigma }-> sigma
| e_com : forall s sigma1 sigma2 ,
    ||* s *|| --{ sigma1 }-> sigma2
| e_whiletrue : forall b s sigma sigma',
    b -{ sigma }-> true ->
    (s ;; while b s) --{ sigma }-> sigma' ->
    while b s --{ sigma }-> sigma'
where "sm --{ sigm }-> sigm'" := (eval sm sigm sigm').

Hint Constructors aeval : my_hints.
Hint Constructors beval : my_hints.
Hint Constructors eval : my_hints.
Hint Unfold update : my_hints.

(* Exemple *)
Check ( 9 <' ("x" /' 5) ) .
Check (12 %' 3).
Check( "@' text").
Check(" andrei () gelu").

Example dec :=
 Bool "a" ;;
 Bool "b" ;;
 "a" :b= btrue;;
 "b" :b= bfalse.
Example dec_ev :
  exists state, dec --{ env }-> state.
Proof.
eexists.
unfold dec.
eapply e_seq.
eapply e_seq.
eapply e_seq.
eapply e_bool_decl.
reflexivity.
eapply e_bool_decl.
reflexivity.
eapply e_bool_assign.
eapply b_true.
reflexivity.
eapply e_bool_assign.
eapply b_false.
reflexivity.
Qed.

Example dec2 :=
 Str "a" ;;
 Str "b" ;;
 "a" :s= "test1";;
 "b" :s= " test2".
Example dec2_ev :
  exists state, dec2 --{ env }-> state.
Proof.
eexists.
unfold dec.
eapply e_seq.
eapply e_seq.
eapply e_seq.
eapply e_str_decl.
reflexivity.
eapply e_str_decl.
reflexivity.
eapply e_str_assign.
eapply s_var.
reflexivity.
eapply e_str_assign.
eapply s_var.
reflexivity.
Qed.
Example dec3 :=
 Str "a" ;;
 Str "b" ;;
 "a" :s= "test1";;
 "b" :s= " test2" ;;
  Str "c";;
 "c" :s= "a" +\' "b".
Example dec3_ev :
  exists state, dec3 --{ env }-> state.
Proof.
eexists.
unfold dec.
eapply e_seq.
eapply e_seq.
eapply e_seq.
eapply e_seq.
eapply e_seq.
eapply e_str_decl.
reflexivity.
eapply e_str_decl.
reflexivity.
eapply e_str_assign.
eapply s_var.
reflexivity.
eapply e_str_assign.
eapply s_var.
reflexivity.
eapply e_str_decl.
reflexivity.
eapply e_str_assign.
eapply s_cat.
eapply s_error.
simpl.
eapply s_error.
simpl.
reflexivity.
reflexivity.
Qed.

Example ex1 : bnot (100 <' "n") -{ env }-> errorB.
Proof.
  eapply b_not.
  eapply b_lessthan.
  - eapply const.
  - eapply var.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Example ex2 : bnot (100 <' ("n" /' 0)) -{ env }-> errorB.
Proof.
  eapply b_not.
  eapply b_lessthan.
  - eapply const.
  - eapply division.
    * eapply var.
    * eapply const.
    * simpl. reflexivity.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.
Example ex3 : 1 -' 5 =[ env ]=> errorNt.
Proof.
  eapply substract.
  - apply const.
  - apply const.
  - simpl. reflexivity.
Qed.

Example ex4 : 3 /' 0 =[ env ]=> errorNt.
Proof.
  eapply division.
  - apply const.
  - apply const.
  - simpl. reflexivity.
Qed.

Example ex5 : 3 %' 0 =[ env ]=> errorNt.
Proof.
  eapply modulo.
  - apply const.
  - apply const.
  - simpl. reflexivity.
Qed.

Example ex6 : 9 <' 12 -{ env }-> true .
eapply b_lessthan.
eapply const.
eapply const.
simpl.
reflexivity.
Qed.

Example ex7 : 12 +' 3 =[ env ]=>15.
Proof.
eapply add.
eapply const.
eapply const.
simpl.
reflexivity.
Qed.

Example ex8 : 12 +' 3 =[ env ]=>15.
Proof.
eapply add.
eapply const.
eapply const.
simpl.
reflexivity.
Qed.

Example ex9 : "a" =[ env ]=> errorNt.
Proof.
  eapply var.
Qed.
Example ex10 : "x" *' "x" =[update env "x" (res_nat 10)]=> 100.
Proof.
  eapply times.
   eauto.
  eapply var.
  eapply var.
  simpl.
  reflexivity.
Qed.

Example ex11 : btrue &&' btrue -{ env }-> true .
eapply b_and.
eapply b_true.
eapply b_true.
simpl.
reflexivity.
Qed.

Example ex13 :=
 Nat "a" ;;
 Nat "b" ;;
 Nat "s";;
 "a" :n= 5;;
 "b" :n=3;;
 "s" :n= "a" +' "b".

Example ex13_res :
  exists state, ex13 --{ env }-> state /\ state "s" = res_nat 8.
Proof.
eexists.
split.
unfold ex13.
eapply e_seq.
eapply e_seq.
eapply e_seq.
eapply e_seq.
eapply e_seq.
eapply e_nat_decl.
reflexivity.
eapply e_nat_decl.
reflexivity.
eapply e_nat_decl.
reflexivity.
eapply e_nat_assign.
eapply const.
eauto.
eapply e_nat_assign.
eapply const.
reflexivity.
eapply e_nat_assign.
eapply add.
eauto.
eapply var.
eapply var.
simpl.
reflexivity.
reflexivity.
eauto.
Qed.

Example ex14 :=
 Nat "a"  ;;
 Nat "b"  ;;
 Nat "s" ;;
 "a" :n=4 ;;
 "b" :n=4 ;;
while ( "a" <' 6 )
( "s" :n= ("s" +' 20) ;;
    "a" :n="a" +' 1
    ).

Example ex14_ev :
  exists state, ex14 --{ env }-> state /\ state "s" =res_nat 40.
Proof.
eexists.
split.
unfold ex14.
eapply e_seq.
eapply e_seq.
eapply e_seq.
eapply e_seq.
eapply e_seq.
eapply e_nat_decl.
eauto.
eapply e_nat_decl.
eauto.
eapply e_nat_decl.
eauto.
eapply e_nat_assign.
eauto.
eapply const.
eauto.
eapply e_nat_assign.
eauto.
eapply const.
eauto.
eapply e_whiletrue.
eapply b_lessthan.
eapply var.
eapply const.
reflexivity.
eapply e_seq.
eapply e_seq.
eapply e_nat_assign.
eapply add.
eapply var.
eapply const.
simpl.
reflexivity.
reflexivity.
eapply e_nat_assign.
eapply add.
eapply var.
eapply const.
simpl.
reflexivity.
reflexivity.
eapply e_whiletrue.
eapply b_lessthan.
eapply var.
eapply const.
reflexivity.
eapply e_seq.
eapply e_seq.
eapply e_nat_assign.
eapply add.
eapply var.
eapply const.
simpl.
reflexivity.
reflexivity.
eapply e_nat_assign.
eapply add.
eapply var.
eapply const.
reflexivity.
eauto.
eapply e_whilefalse.
eapply b_lessthan.
eapply var.
eapply const.
reflexivity.
simpl.
reflexivity.
Qed.

Example ex15 :=
 Nat "a"  ;;
 Nat "b"  ;;
 "a" :n=4 ;;
 "b" :n=4 ;;
||* "Acesta este un comentariu" *|| ;;
  If ( "b" <' 5) then
 "a" :n=8
  'end.
Example ex15_ev :
  exists state, ex15 --{ env }-> state.
Proof.
eexists.
unfold ex15.
eapply e_seq.
eapply e_seq.
eapply e_seq.
eapply e_seq.
eapply e_nat_decl.
eauto.
eapply e_nat_decl.
eauto.
eapply e_nat_assign.
eauto.
eapply const.
eauto.
eapply e_nat_assign.
eauto.
eapply const.
eauto.
eapply e_seq.
eapply e_com.
eapply e_if_then.
Qed.


(**  Module defining the programming languages:
     - Values
     - Expressions
     - Statements **)

Add LoadPath "vst".
Require Import Arith.
Require Import List.
Require Import msl.eq_dec.
Import Relations.

Delimit Scope lang_scope with lang.

Definition var := nat.

Inductive value : Set :=
  | int_v  : nat -> value
  | bool_v : bool -> value.

(* Inductive bop := *)
(*   | plus_o : bop. *)

(* (** First we will need a notion of expressions in the language **) *)
(* Inductive expr :=  *)
(*   | value_e : value -> expr *)
(*   | var_e   : var -> expr *)
(*   | bop_e   : expr -> bop -> expr -> expr. *)

(* Fixpoint subst_expr (x:var) (e':expr) (e:expr) :=  *)
(*   match e with *)
(*     | var_e x' =>  *)
(*       if eq_dec x' x then e' else e *)
(*     | bop_e e1 o e2 =>  *)
(*       bop_e (subst_expr x e' e1) o (subst_expr x e' e2) *)
(*     | _ => e *)
(*   end. *)

(** Statements: all the fun stuff *)
Inductive stmt :=
  | skip_s   : stmt
  (* | assign_s : var -> expr -> stmt *)
  | seq_s    : stmt -> stmt -> stmt.

Coercion int_v: nat >-> value.
Coercion value_e: value >-> expr.
Coercion var_e: var >-> expr.
Notation "x .+ y" := (bop_e x plus_o y) (at level 57, right associativity).

(**** Semantics ****)
(*** a la Appel, PLFCC ***)
Definition table (A B : Type) := list (A * B).
Fixpoint table_get {A B}{H: EqDec A} (rho: table A B) (x: A) : option B :=
  match rho with
  | (y,v)::ys => if eq_dec x y then Some v else table_get ys x
  | nil => None
 end.

Definition table_set {A B}{H: EqDec A} (x: A) (v: B) (rho: table A B)  : table A B := (x,v)::rho.

Lemma table_gss {A B}{H: EqDec A}: forall rho x (v: B), table_get (table_set x v rho) x = Some v.
Proof.
intros.
simpl. destruct (eq_dec x x); auto. contradiction n; auto.
Qed.

Lemma table_gso {A B}{H: EqDec A}: forall rho x y (v:B), x<>y -> table_get (table_set x v rho) y = table_get rho y.
Proof.
intros.
simpl. destruct (eq_dec y x); auto.  contradiction H0; auto.
Qed.

Definition state := table var value.

Definition apply_op' o v1 v2 :=
  match (o, v1, v2) with
    | (plus_o, int_v v1', int_v v2') =>
      Some (int_v (v1' + v2'))
    | _ =>
      None
  end.

Definition apply_op o v1 v2 :=
  match (v1, v2) with
    | (Some v1', Some v2') => apply_op' o v1' v2'
    | _ => None
  end.

Fixpoint eval s e :=
  match e with
  | value_e v       => Some v
  | var_e   x       => s x
  | bop_e   e1 o e2 => apply_op o (eval s e1) (eval s e2)
  end.

Inductive step : relation (list stmt * state) :=
  | step_skip :
      forall k s,
        step (skip_s :: k, s) (k, s)
  | step_assign :
      forall k s x e v,
      Some v = eval (table_get s) e ->
      step (assign_s x e :: k, s) (k, table_set x v s)
  | step_seq :
      forall k s c1 c2 cs',
        step (c1 :: c2 :: k, s) cs' ->
        step (seq_s c1 c2 :: k, s) cs'.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype.
From mathcomp Require Import div tuple bigop ssralg poly polydiv.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory.

Section MoreBigop.

Lemma big_morph_in (R1 R2 : Type)
  (f : R2 -> R1) (id1 : R1) (op1 : R1 -> R1 -> R1)
  (id2 : R2) (op2 : R2 -> R2 -> R2) (D : pred R2) :
  (forall x y, x \in D -> y \in D -> op2 x y \in D) ->
  id2 \in D ->
  {in D &, {morph f : x y / op2 x y >-> op1 x y}} ->
  f id2 = id1 ->
  forall  (I : Type) (r : seq I) (P : pred I) (F : I -> R2),
  all D [seq F x | x <- r & P x] ->
  f (\big[op2/id2]_(i <- r | P i) F i) = \big[op1/id1]_(i <- r | P i) f (F i).
Proof.
move=> Dop2 Did2 f_morph f_id I r P F.
elim: r => [|x r ihr /= DrP]; rewrite ?(big_nil, big_cons) //.
set b2 := \big[_/_]_(_ <- _ | _) _; set b1 := \big[_/_]_(_ <- _ | _) _.
have fb2 : f b2 = b1 by rewrite ihr; move: (P x) DrP => [/andP[]|].
case: (boolP (P x)) DrP => //= Px /andP[Dx allD].
rewrite f_morph ?fb2 // /b2 {b2 fb2 ihr b1 x Px Dx f_morph f_id}.
elim: r allD => [|x r ihr /=]; rewrite ?(big_nil, big_cons) //.
by case: (P x) => //= /andP [??]; rewrite Dop2 // ihr.
Qed.

Variables (R : Type) (idx : R).

Fact big_ord_exchange_cond {op : Monoid.law idx} {a b : nat}
   (P : pred nat) (F : nat -> R) :
  \big[op/idx]_(i < a | P i && (i < b)) F i =
  \big[op/idx]_(i < b | P i && (i < a)) F i.
Proof.
wlog le_b_a : a b / b <= a => [hwlog|].
  have /orP [le_a_b|le_b_a] := leq_total a b; last exact: hwlog.
  by symmetry; apply: hwlog.
rewrite big_ord_narrow_cond /=; apply: eq_big => // i.
by rewrite (leq_trans _ le_b_a) ?andbT.
Qed.

Fact big_ord_exchange {op : Monoid.law idx} {a b : nat} (F : nat -> R) :
  \big[op/idx]_(i < a | i < b) F i =
  \big[op/idx]_(i < b | i < a) F i.
Proof. exact: (big_ord_exchange_cond xpredT). Qed.

Fact big_ord1 (op : Monoid.law idx) (F : nat -> R) :
  \big[op/idx]_(i < 1) F i = F 0.
Proof. by rewrite big_ord_recl big_ord0 Monoid.mulm1. Qed.

Lemma big_nat_widen_l (op : Monoid.law idx)
     (m1 m2 n : nat) (P : pred nat) (F : nat -> R) :
   m2 <= m1 ->
   \big[op/idx]_(m1 <= i < n | P i) F i =
   \big[op/idx]_(m2 <= i < n | P i && (m1 <= i)) F i.
Proof.
move=> le_m2m1; have [ltn_m1n|geq_m1n] := ltnP m1 n; last first.
  rewrite big_geq // big_nat_cond big_pred0 // => i.
  by apply/negP => /and3P[/andP [_ /leq_trans]]; rewrite leqNgt => ->.
rewrite [RHS](@big_cat_nat _ _ _ m1) // 1?ltnW //.
rewrite [X in op X]big_nat_cond [X in op X]big_pred0; last first.
  by move=> i; have [] := ltnP i m1; rewrite ?(andbT, andbF).
rewrite Monoid.mul1m [LHS]big_nat_cond [RHS]big_nat_cond.
by apply/eq_bigl => i; have [] := ltnP i m1; rewrite ?(andbT, andbF).
Qed.

Lemma big_mknat  (op : Monoid.law idx)  (a b : nat) (F : nat -> R) :
  \big[op/idx]_(i < b | a <= i) F i = \big[op/idx]_(a <= i < b) F i.
Proof.
rewrite -(big_mkord (fun i => a <= i) F).
by rewrite -(big_nat_widen_l _ _ predT) ?leq0n.
Qed.

End MoreBigop.

Section MoreCoef.

Open Scope ring_scope.

Lemma coefMD_wid (R : ringType) (p q : {poly R}) (m n i : nat) :
  i < m -> i < n ->
  (p * q)`_i = \sum_(j1 < m) \sum_(j2 < n | (j1 + j2)%N == i) p`_j1 * q`_j2.
Proof.
move=> m_big n_big; rewrite pair_big_dep.
pose tom := widen_ord m_big; pose ton := widen_ord n_big.
rewrite (reindex (fun j : 'I_i.+1 => (tom j, ton (rev_ord j)))) /=.
  rewrite coefM; apply: eq_big => //= j.
  by rewrite -maxnE (maxn_idPr _) ?eqxx ?leq_ord.
exists (fun k : 'I__ * 'I__ => insubd ord0 k.1) => /=.
  by move=> j _; apply/val_inj; rewrite val_insubd ltn_ord.
move=> [k1 k2] /=; rewrite inE /= {}/ton eq_sym => /eqP i_def.
apply/eqP; rewrite xpair_eqE -!val_eqE /= ?val_insubd i_def !ltnS.
by rewrite leq_addr eqxx /= subSS addKn.
Qed.

Lemma coefMD (R : ringType) (p q : {poly R}) (i : nat) :
 (p * q)`_i = \sum_(j1 < size p)
              \sum_(j2 < size q | (j1 + j2)%N == i) p`_j1 * q`_j2.
Proof.
rewrite (@coefMD_wid _ _ _ i.+1 i.+1) //=.
rewrite (bigID (fun j1 :'I__ => j1 < size p)) /=.
rewrite [X in _ + X]big1 ?addr0; last first.
  move=> j1; rewrite -ltnNge => j1_big.
  by rewrite big1 // => j2 _; rewrite nth_default ?mul0r.
rewrite (big_ord_exchange
 (fun j1 => \sum_(j2 < i.+1 | (j1 + j2)%N == i) p`_j1 * q`_j2)) /=.
rewrite big_mkcond /=; apply: eq_bigr => j1 _; rewrite ltnS.
have [j1_small|j1_big] := leqP; last first.
  rewrite big1 // => j2; rewrite eq_sym => /eqP i_def.
  by rewrite i_def -ltn_subRL subnn ltn0 in j1_big.
rewrite (bigID (fun j2 :'I__ => j2 < size q)) /=.
rewrite [X in _ + X]big1 ?addr0; last first.
  move=> j2; rewrite -ltnNge => /andP[_ j2_big].
  by rewrite [q`__]nth_default ?mulr0.
rewrite (big_ord_exchange_cond
 (fun j2 => (j1 + j2)%N == i) (fun j2 => p`_j1 * q`_j2)) /=.
rewrite big_mkcondr /=; apply: eq_bigr => k; rewrite ltnS.
have [//|j2_big] := leqP; rewrite eq_sym=> /eqP i_def.
by rewrite i_def addnC -ltn_subRL subnn ltn0 in j2_big.
Qed.

End MoreCoef.

Local Open Scope ring_scope.

Section MoreComUnitRingTheory.
Variable (R : comUnitRingType).

Lemma eq_divr (a b c d : R) : b \is a GRing.unit -> d \is a GRing.unit ->
  (a / b == c / d) = (a * d == c * b).
Proof.
move=> b_unit d_unit; pose canM := (can2_eq (mulrVK _) (mulrK _)).
by rewrite canM // mulrAC -canM ?unitrV ?invrK.
Qed.

Lemma mulr_div (x1 y1 x2 y2 : R) :
  (y1 \is a GRing.unit) ->
  (y2 \is a GRing.unit) -> x1 / y1 * (x2 / y2) = x1 * x2 / (y1 * y2).
Proof. by move=> y1_unit y2_unit; rewrite mulrACA -invrM ?[y2 * _]mulrC. Qed.

Lemma addr_div (x1 y1 x2 y2 : R) :
  y1 \is a GRing.unit -> y2 \is a GRing.unit ->
  x1 / y1 + x2 / y2 = (x1 * y2 + x2 * y1) / (y1 * y2).
Proof.
move => y1_unit y2_unit.
by rewrite mulrDl [X in (_ * y1) / X]mulrC -!mulr_div ?divrr // !mulr1.
Qed.

End MoreComUnitRingTheory.

Section MoreFieldTheory.

Variable (K : fieldType).

Lemma eq_divf (a b c d : K) : b != 0 -> d != 0 ->
  (a / b == c / d) = (a * d == c * b).
Proof. by move=> b_neq0 d_neq0; rewrite eq_divr ?unitfE. Qed.

Lemma eq_divfC (a b c d : K) : a != 0 -> c != 0 ->
  (a / b == c / d) = (a * d == c * b).
Proof.
move=> ??; rewrite -invf_div -[c / d]invf_div (inj_eq (can_inj (@invrK _))).
by rewrite eq_divf // eq_sym [a * d]mulrC [b * c]mulrC.
Qed.

Lemma eq_divf_mul (a b c d : K) : a / b != 0 -> a / b = c / d -> a * d = c * b.
Proof.
have [->| d_neq0 ab0 /eqP] := eqVneq d 0.
  by rewrite !invr0 !mulr0 => /negPf ab0 /eqP; rewrite ab0.
rewrite eq_divf //; first by move/eqP.
by apply: contraNneq ab0 => ->; rewrite invr0 mulr0.
Qed.

End MoreFieldTheory.

Local Notation "p ^ f" := (map_poly f p).

Lemma map_poly_injective (R S : ringType) (f : {rmorphism R -> S}) :
  injective f -> injective (map_poly f).
Proof.
move=> finj p q /polyP eq_pq; apply/polyP=> i; have := eq_pq i.
rewrite !coef_map; exact: finj.
Qed.

Section AuxiliaryResults.

Variable (R : ringType).
Implicit Types (p : {poly R}).

Lemma map_poly_mul (c : R) p : p ^ ( *%R c) = c *: p.
Proof. by apply/polyP => i; rewrite coefZ coef_map_id0 ?mulr0. Qed.

Lemma lead_coefMXn p (n : nat) : lead_coef (p * 'X^n) = lead_coef p.
Proof. by rewrite lead_coef_Mmonic ?monicXn //. Qed.

Lemma size_polyMXn p (n : nat) : p != 0 -> size (p * 'X^n) = (size p + n)%N.
Proof. by move=> ?; rewrite size_Mmonic ?monicXn // size_polyXn addnS. Qed.

Lemma widen_poly (E : nat -> R) (a b : nat) : a <= b ->
  (forall j, a <= j < b -> E j = 0) ->
  \poly_(i < a) E i = \poly_(i < b) E i.
Proof.
move=> leq_a_b E_eq0; apply/polyP => k; rewrite !coef_poly.
have [lt_ka|le_ak] := ltnP k a; first by rewrite (leq_trans lt_ka).
by have [lt_kb|//] := ifPn; rewrite E_eq0 // le_ak lt_kb.
Qed.

Lemma deriv_sum (T : Type) (s : seq T) (F : T -> {poly R}) (P : pred T):
  deriv (\sum_(i <- s | P i) F i) = \sum_(i <- s | P i) deriv (F i).
Proof. by apply: big_morph; [exact: derivD|exact: deriv0]. Qed.

End AuxiliaryResults.


(** Automatically Synthesized by Autosubst. Considered preliminaries **)
Require Import std.std.
Require Export unscoped.

Section Terms.

  Inductive type  : Type :=
  | typevar  : nat  -> type
  | arr  : type  -> type  -> type .

  Structure Const :=
  {
    const_type:> Type;
    const_dis: Dis const_type;
    ctype: const_type -> type
  }.

  Context {X: Const}.

Lemma congr_typevar  { s0 : nat  } { t0 : nat  } : s0 = t0 -> typevar s0 = typevar t0 .
Proof. congruence. Qed.

Lemma congr_arr  { s0 : type  } { s1 : type  } { t0 : type  } { t1 : type  } : s0 = t0 -> s1 = t1 -> arr s0 s1 = arr t0 t1 .
Proof. congruence. Qed.

Inductive exp  : Type :=
  | var_exp  : fin  -> exp
  | const  : X  -> exp
  | lam  : exp  -> exp
  | app  : exp  -> exp  -> exp .

Lemma congr_const  { s0 : X  } { t0 : X  } : s0 = t0 -> const  s0 = const  t0 .
Proof. congruence. Qed.

Lemma congr_lam  { s0 : exp  } { t0 : exp  } : s0 = t0 -> lam  s0 = lam  t0 .
Proof. congruence. Qed.

Lemma congr_app  { s0 : exp  } { s1 : exp  } { t0 : exp  } { t1 : exp  } : s0 = t0 -> s1 = t1 -> app  s0 s1 = app  t0 t1 .
Proof. congruence. Qed.

Definition upRen_exp_exp   (xi : fin  -> fin ) : _ :=
  up_ren xi.

Fixpoint ren_exp   (xiexp : fin  -> fin ) (s : exp ) : _ :=
    match s with
    | var_exp  s => (var_exp ) (xiexp s)
    | const  s0 => const  s0
    | lam  s0 => lam  (ren_exp (upRen_exp_exp xiexp) s0)
    | app  s0 s1 => app  (ren_exp xiexp s0) (ren_exp xiexp s1)
    end.

Definition up_exp_exp   (sigma : fin  -> exp ) : _ :=
  scons ((var_exp ) var_zero) (funcomp (ren_exp shift) sigma).

Fixpoint subst_exp   (sigmaexp : fin  -> exp ) (s : exp ) : _ :=
    match s with
    | var_exp  s => sigmaexp s
    | const  s0 => const  s0
    | lam  s0 => lam  (subst_exp (up_exp_exp sigmaexp) s0)
    | app  s0 s1 => app  (subst_exp sigmaexp s0) (subst_exp sigmaexp s1)
    end.

Definition upId_exp_exp  (sigma : fin  -> exp ) (Eq : forall x, sigma x = (var_exp ) x) : forall x, (up_exp_exp sigma) x = (var_exp ) x :=
  fun n => match n with
  | S n => ap (ren_exp shift) (Eq n)
  | 0 => eq_refl
  end.

Fixpoint idSubst_exp  (sigmaexp : fin  -> exp ) (Eqexp : forall x, sigmaexp x = (var_exp ) x) (s : exp ) : subst_exp sigmaexp s = s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (idSubst_exp (up_exp_exp sigmaexp) (upId_exp_exp (_) Eqexp) s0)
    | app  s0 s1 => congr_app (idSubst_exp sigmaexp Eqexp s0) (idSubst_exp sigmaexp Eqexp s1)
    end.

Definition upExtRen_exp_exp   (xi : fin  -> fin ) (zeta : fin  -> fin ) (Eq : forall x, xi x = zeta x) : forall x, (upRen_exp_exp xi) x = (upRen_exp_exp zeta) x :=
  fun n => match n with
  | S n => ap shift (Eq n)
  | 0 => eq_refl
  end.

Fixpoint extRen_exp   (xiexp : fin  -> fin ) (zetaexp : fin  -> fin ) (Eqexp : forall x, xiexp x = zetaexp x) (s : exp ) : ren_exp xiexp s = ren_exp zetaexp s :=
    match s with
    | var_exp  s => ap (var_exp ) (Eqexp s)
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (extRen_exp (upRen_exp_exp xiexp) (upRen_exp_exp zetaexp) (upExtRen_exp_exp (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (extRen_exp xiexp zetaexp Eqexp s0) (extRen_exp xiexp zetaexp Eqexp s1)
    end.

Definition upExt_exp_exp   (sigma : fin  -> exp ) (tau : fin  -> exp ) (Eq : forall x, sigma x = tau x) : forall x, (up_exp_exp sigma) x = (up_exp_exp tau) x :=
  fun n => match n with
  | S n => ap (ren_exp shift) (Eq n)
  | 0 => eq_refl
  end.

Fixpoint ext_exp   (sigmaexp : fin  -> exp ) (tauexp : fin  -> exp ) (Eqexp : forall x, sigmaexp x = tauexp x) (s : exp ) : subst_exp sigmaexp s = subst_exp tauexp s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (ext_exp (up_exp_exp sigmaexp) (up_exp_exp tauexp) (upExt_exp_exp (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (ext_exp sigmaexp tauexp Eqexp s0) (ext_exp sigmaexp tauexp Eqexp s1)
    end.

Fixpoint compRenRen_exp    (xiexp : fin  -> fin ) (zetaexp : fin  -> fin ) (rhoexp : fin  -> fin ) (Eqexp : forall x, (funcomp zetaexp xiexp) x = rhoexp x) (s : exp ) : ren_exp zetaexp (ren_exp xiexp s) = ren_exp rhoexp s :=
    match s with
    | var_exp  s => ap (var_exp ) (Eqexp s)
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (compRenRen_exp (upRen_exp_exp xiexp) (upRen_exp_exp zetaexp) (upRen_exp_exp rhoexp) (up_ren_ren (_) (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (compRenRen_exp xiexp zetaexp rhoexp Eqexp s0) (compRenRen_exp xiexp zetaexp rhoexp Eqexp s1)
    end.

Definition up_ren_subst_exp_exp    (xi : fin  -> fin ) (tau : fin  -> exp ) (theta : fin  -> exp ) (Eq : forall x, (funcomp tau xi) x = theta x) : forall x, (funcomp (up_exp_exp tau) (upRen_exp_exp xi)) x = (up_exp_exp theta) x :=
  fun n => match n with
  | S n => ap (ren_exp shift) (Eq n)
  | 0 => eq_refl
  end.

Fixpoint compRenSubst_exp    (xiexp : fin  -> fin ) (tauexp : fin  -> exp ) (thetaexp : fin  -> exp ) (Eqexp : forall x, (funcomp tauexp xiexp) x = thetaexp x) (s : exp ) : subst_exp tauexp (ren_exp xiexp s) = subst_exp thetaexp s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (compRenSubst_exp (upRen_exp_exp xiexp) (up_exp_exp tauexp) (up_exp_exp thetaexp) (up_ren_subst_exp_exp (_) (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (compRenSubst_exp xiexp tauexp thetaexp Eqexp s0) (compRenSubst_exp xiexp tauexp thetaexp Eqexp s1)
    end.

Definition up_subst_ren_exp_exp    (sigma : fin  -> exp ) (zetaexp : fin  -> fin ) (theta : fin  -> exp ) (Eq : forall x, (funcomp (ren_exp zetaexp) sigma) x = theta x) : forall x, (funcomp (ren_exp (upRen_exp_exp zetaexp)) (up_exp_exp sigma)) x = (up_exp_exp theta) x :=
  fun n => match n with
  | S n => eq_trans (compRenRen_exp shift (upRen_exp_exp zetaexp) (funcomp shift zetaexp) (fun x => eq_refl) (sigma n)) (eq_trans (eq_sym (compRenRen_exp zetaexp shift (funcomp shift zetaexp) (fun x => eq_refl) (sigma n))) (ap (ren_exp shift) (Eq n)))
  | 0 => eq_refl
  end.

Fixpoint compSubstRen__exp    (sigmaexp : fin  -> exp ) (zetaexp : fin  -> fin ) (thetaexp : fin  -> exp ) (Eqexp : forall x, (funcomp (ren_exp zetaexp) sigmaexp) x = thetaexp x) (s : exp ) : ren_exp zetaexp (subst_exp sigmaexp s) = subst_exp thetaexp s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (compSubstRen__exp (up_exp_exp sigmaexp) (upRen_exp_exp zetaexp) (up_exp_exp thetaexp) (up_subst_ren_exp_exp (_) (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (compSubstRen__exp sigmaexp zetaexp thetaexp Eqexp s0) (compSubstRen__exp sigmaexp zetaexp thetaexp Eqexp s1)
    end.

Definition up_subst_subst_exp_exp    (sigma : fin  -> exp ) (tauexp : fin  -> exp ) (theta : fin  -> exp ) (Eq : forall x, (funcomp (subst_exp tauexp) sigma) x = theta x) : forall x, (funcomp (subst_exp (up_exp_exp tauexp)) (up_exp_exp sigma)) x = (up_exp_exp theta) x :=
  fun n => match n with
  | S n => eq_trans (compRenSubst_exp shift (up_exp_exp tauexp) (funcomp (up_exp_exp tauexp) shift) (fun x => eq_refl) (sigma n)) (eq_trans (eq_sym (compSubstRen__exp tauexp shift (funcomp (ren_exp shift) tauexp) (fun x => eq_refl) (sigma n))) (ap (ren_exp shift) (Eq n)))
  | 0 => eq_refl
  end.

Fixpoint compSubstSubst_exp    (sigmaexp : fin  -> exp ) (tauexp : fin  -> exp ) (thetaexp : fin  -> exp ) (Eqexp : forall x, (funcomp (subst_exp tauexp) sigmaexp) x = thetaexp x) (s : exp ) : subst_exp tauexp (subst_exp sigmaexp s) = subst_exp thetaexp s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (compSubstSubst_exp (up_exp_exp sigmaexp) (up_exp_exp tauexp) (up_exp_exp thetaexp) (up_subst_subst_exp_exp (_) (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (compSubstSubst_exp sigmaexp tauexp thetaexp Eqexp s0) (compSubstSubst_exp sigmaexp tauexp thetaexp Eqexp s1)
    end.

Definition rinstInst_up_exp_exp   (xi : fin  -> fin ) (sigma : fin  -> exp ) (Eq : forall x, (funcomp (var_exp ) xi) x = sigma x) : forall x, (funcomp (var_exp ) (upRen_exp_exp xi)) x = (up_exp_exp sigma) x :=
  fun n => match n with
  | S n => ap (ren_exp shift) (Eq n)
  | 0 => eq_refl
  end.

Fixpoint rinst_inst_exp   (xiexp : fin  -> fin ) (sigmaexp : fin  -> exp ) (Eqexp : forall x, (funcomp (var_exp ) xiexp) x = sigmaexp x) (s : exp ) : ren_exp xiexp s = subst_exp sigmaexp s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (rinst_inst_exp (upRen_exp_exp xiexp) (up_exp_exp sigmaexp) (rinstInst_up_exp_exp (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (rinst_inst_exp xiexp sigmaexp Eqexp s0) (rinst_inst_exp xiexp sigmaexp Eqexp s1)
    end.

Lemma instId_exp  : subst_exp (var_exp ) = id .
Proof. exact (FunctionalExtensionality.functional_extensionality _ _ (fun x => idSubst_exp (var_exp ) (fun n => eq_refl) (id x))). Qed.

Lemma varL_exp   (sigmaexp : fin  -> exp ) : funcomp (subst_exp sigmaexp) (var_exp ) = sigmaexp .
Proof. exact (FunctionalExtensionality.functional_extensionality _ _ (fun x => eq_refl)). Qed.

Lemma rinstInst_exp   (xiexp : fin  -> fin ) : ren_exp xiexp = subst_exp (funcomp (var_exp ) xiexp) .
Proof. exact (FunctionalExtensionality.functional_extensionality _ _ (fun x => rinst_inst_exp xiexp (_) (fun n => eq_refl) x)). Qed.

Lemma compComp_exp    (sigmaexp : fin  -> exp ) (tauexp : fin  -> exp ) (s : exp ) : subst_exp tauexp (subst_exp sigmaexp s) = subst_exp (funcomp (subst_exp tauexp) sigmaexp) s .
Proof. exact (compSubstSubst_exp sigmaexp tauexp (_) (fun n => eq_refl) s). Qed.

Lemma compComp'_exp    (sigmaexp : fin  -> exp ) (tauexp : fin  -> exp ) : funcomp (subst_exp tauexp) (subst_exp sigmaexp) = subst_exp (funcomp (subst_exp tauexp) sigmaexp) .
Proof. exact (FunctionalExtensionality.functional_extensionality _ _ (fun n => compComp_exp sigmaexp tauexp n)). Qed.

End Terms.

(* CUSTOM CHANGES *)
Definition beta {X} (s: exp) (t: exp) := @subst_exp X (t .: var_exp) s.
Hint Rewrite @instId_exp @rinstInst_exp @compComp_exp @compComp'_exp @varL_exp : asimpl.
Hint Unfold beta upRen_exp_exp up_exp_exp : asimpl.

Ltac asimpl := autounfold with asimpl; autorewrite with asimpl using (cbn [subst_exp ren_exp]; fsimpl).
Tactic Notation "asimpl" "in" hyp(J) :=
  autounfold with asimpl in J; autorewrite with asimpl in J using (cbn [subst_exp ren_exp] in J; fsimplin J).


From Equations Require Import Equations.
Require Import Coq.Program.Equality.
Require Import Coq.Lists.List.

Require Import MirrorSolve.FirstOrder.
Require Import MirrorSolve.HLists.

Import ListNotations.
Import HListNotations.
(*
From SMTCoq Require Import SMTCoq. *)

Set Universe Polymorphism.
Section BFOL.
  Inductive sorts: Set :=
  | BoolSort.

  Scheme Equality for sorts.
  Set Universe Polymorphism.

  Inductive funs: arity sorts -> sorts -> Type :=
  | BLit: forall (b: bool), funs [] BoolSort
  | BAnd: funs [BoolSort; BoolSort] BoolSort
  | BOr: funs [BoolSort; BoolSort] BoolSort
  | BNot: funs [BoolSort] BoolSort
  | BImpl: funs [BoolSort; BoolSort] BoolSort.

  Inductive rels: arity sorts -> Type :=.

  Definition sig: signature :=
    {| sig_sorts := sorts;
      sig_funs := funs;
      sig_rels := rels |}.

  Definition fm ctx := FirstOrder.fm sig ctx.
  Definition tm ctx := FirstOrder.tm sig ctx.

  Definition mod_sorts (s: sig_sorts sig) : Type :=
    match s with
    | BoolSort => bool
    end.

  Local Open Scope bool_scope.

  Obligation Tactic := idtac.
  Equations
    mod_fns params ret (f: sig_funs sig params ret) (args: HList.t mod_sorts params)
    : mod_sorts ret :=
    { mod_fns _ _ (BLit b) hnil := b;
      mod_fns _ _ BAnd (x ::: y ::: hnil) := x && y;
      mod_fns _ _ BOr (x ::: y ::: hnil) := x || y;
      mod_fns _ _ BImpl (x ::: y ::: hnil) := implb x y;
      mod_fns _ _ BNot (x ::: hnil) := negb x
    }.

  Definition mod_rels params
    (args: sig_rels sig params)
    (env: HList.t mod_sorts params) : Prop :=
    match args with
    end.

  Program Definition fm_model : model sig := {|
    FirstOrder.mod_sorts := mod_sorts;
    FirstOrder.mod_fns := mod_fns;
    FirstOrder.mod_rels := mod_rels;
  |}.

  Lemma b_interp_subst b:
    forall c v,
      b = interp_tm (c := c) (sig := sig) (m := fm_model) v (TFun sig (BLit b) hnil).
  Proof.
    intros.
    vm_compute; reflexivity.
  Qed.

End BFOL.