Require Import String.
Require Import Lia.
Require Import List.
Require Import Nat.
Require Import Coq.Vectors.Vector.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Bool.Bool.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.FunctionalExtensionality.
Require Export RelationClasses.
Require Export Morphisms.
From ST Require Import Vector EVarsScratchwork.
From ST Require Import Logic.V.
Import ListNotations.
Import VectorNotations.
Open Scope string_scope.
(** ** Terms

A [Term] is either a variable, or an n-ary function. Constants are just nullary
functions. We do carve out [EConst] for existential constants, to make
logic easier later on. The intuition is that an [EConst] is an arbitrary
Henkin constant.
*)

Unset Elimination Schemes.
Inductive Term : Type :=
| Var : V -> Term
| EConst : nat -> Term
| Fun {n : nat} : name -> Vector.t Term n -> Term.

Definition Term_ind (P : Term -> Prop)
       (HVar : forall v : V, P (Var v))
       (HConst : forall n : nat, P (EConst n))
       (HFun : forall (n : nat) (n0 : name) (t : t Term n),
         Vector.Forall P t -> P (Fun n0 t))
       (* ^ extra hypothesis *)
  : forall t : Term, P t.
Proof.
  fix SELF 1; intros [ | | n m t].
  - apply HVar.
  - apply HConst.
  - apply HFun.
    induction t as [ | ? ? ? IH ]; constructor.
    + apply SELF.
    + apply IH.
Qed.

  Definition Term_rect :=
fun (P : Term -> Type)
  (f : forall v : V, P (Var v))
  (f0 : forall n : nat, P (EConst n))
  (f1 : forall (n : nat) (n0 : name)
          (t : t Term n), P (@Fun n n0 t))
  (t : Term) =>
match t as t0 return (P t0) with
| Var v => f v
| EConst n => f0 n
| @Fun n n0 t0 => f1 n n0 t0
end.
(*
  Section Term_rect.
    Variable P : Term -> Type.
    Variable P_vector : forall n, Vector.t Term n -> Type.
    Hypothesis P_nil : P_vector 0 []%vector.
    Hypothesis P_cons : forall {n} t l, P t -> P_vector n l -> P_vector (S n) (t :: l)%vector.
    Hypothesis P_Var : forall a, P (Var a).
    Hypothesis P_EConst : forall n, P (EConst n).
    Hypothesis P_Fun : forall {n} nm l, P_vector n l -> P (@Fun n nm l).
    Fixpoint Term_rect (t : Term) : P t :=
      let fix go_vector {n} (l : Vector.t Term n) : P_vector n l :=
          match l with
          | []%vector => P_nil
          | (t :: l)%vector => P_cons t l (Term_rect t) (go_vector l) (* (Term_rect t) (go_vector l) *)
          end
      in
      match t with
      | Var x => P_Var x
      | EConst n => P_EConst n
      | Fun nm args => P_Fun nm args (go_vector args)
      end.
  End Term_rect.
*)
(*
  Section Term_rect.
    Variable P : Term -> Type.
    Variable P_vector : forall n, Vector.t Term n -> Type.
    Hypothesis P_nil : P_vector 0 []%vector.
    Hypothesis P_cons : forall {n} t l, P t -> P_vector n l -> P_vector (S n) (t :: l)%vector.
    Hypothesis P_Var : forall a, P (Var a).
    Hypothesis P_EConst : forall n, P (EConst n).
    Hypothesis P_Fun : forall {n} nm l, P_vector n l -> P (@Fun n nm l).
    Fixpoint Term_rect (t : Term) : P t :=
      let fix go_vector {n} (l : Vector.t Term n) : P_vector n l :=
          match l with
          | []%vector => P_nil
          | (t :: l)%vector => P_cons t l (Term_rect t) (go_vector l) (* (Term_rect t) (go_vector l) *)
          end
      in
      match t with
      | Var x => P_Var x
      | EConst n => P_EConst n
      | Fun nm args => P_Fun nm args (go_vector args)
      end.
  End Term_rect.
*)
Set Elimination Schemes.

Definition constant (c : name) : Term :=
@Fun 0 c [].

Fixpoint term_eqb (t1 t2 : Term) : bool :=
match t1,t2 with
| Var x1, Var x2 => eqb x1 x2
| EConst n1, EConst n2 => eqb n1 n2
| @Fun n1 s1 args1, @Fun n2 s2 args2 =>
  (* eqb n1 n2 && eqb s1 s2 && (Vector.eqb Term term_eqb args1 args2) *)
  let fix args_eqb {n1 n2} (ar1 : Vector.t Term n1) (ar2 : Vector.t Term n2) : bool :=
      match ar1,ar2 with
      | Vector.nil _, Vector.nil _ => true
      | Vector.cons _ h1 k1 t1,  Vector.cons _ h2 k2 t2 => (andb (term_eqb h1 h2) (args_eqb t1 t2))
      | _, _ => false
      end
  in (eqb n1 n2) && (eqb s1 s2) && (args_eqb args1 args2)
| _, _ => false
end.

Fixpoint args_eqb {n1 n2} (ar1 : Vector.t Term n1) (ar2 : Vector.t Term n2) : bool :=
match ar1,ar2 with
| Vector.nil _, Vector.nil _ => true
| Vector.cons _ h1 k1 t1,  Vector.cons _ h2 k2 t2 => (andb (term_eqb h1 h2) (args_eqb t1 t2))
| _, _ => false
end.

Global Instance EqTerm : Eq Term := {
  eqb := term_eqb
}.

(*
Require Import Coq.Vectors.VectorSpec.
Lemma args_eqb_length (n1 n2 : nat) (args1 : Vector.t Term n1) (args2 : Vector.t Term n2) :
  n1 <> n2 -> args_eqb (args1) (args2) = false.
Proof.
  intros. apply Coq.Arith.Compare_dec.not_eq in H.
  destruct H.
  - set (n := min n1 n2).
    assert (n = n1). lia.
    set (k := n2 - n).
    assert (n2 = n + k). lia.
    revert args2. rewrite H1.
    revert args1. assert(n + 0 = n1). lia. rewrite <- H2.
    intros.
    set (vs := (@Vector.splitat Term n k args2)).
    set (us := (@Vector.splitat Term n 0 args1)).
    destruct vs as [ls2 tls2]. destruct us as [ls1 tls1].
    assert ({args_eqb ls1 ls2 = true} + {args_eqb ls1 ls2 <> true}). { decide equality. }
    destruct H3.
    +
    apply min_l in H as H1.
    Vector.splitat(n,
*)

Lemma args_eqb_ind (n : nat) (h1 h2 : Term) (args1 args2 : Vector.t Term n) :
  args_eqb (h1::args1) (h2::args2)
  = (eqb h1 h2) && (args_eqb args1 args2).
Proof.
  intros. unfold args_eqb; unfold EqTerm; unfold term_eqb. simpl; auto.
Qed.

(*
Require Import Coq.Arith.EqNat.
Lemma args_eqb_ind2 (n1 n2 : nat) (h1 h2 : Term) (args1 : Vector.t Term n1) (args2 : Vector.t Term n2) :
  args_eqb (h1::args1) (h2::args2)
  = (eqb n1 n2) && (eqb h1 h2) && (args_eqb args1 args2).
Proof.
  intros. assert ({n1 = n2} + {n1 <> n2}). decide equality. destruct H.
  - revert args1; revert args2. rewrite e. intros.
    assert (args_eqb (h1::args1) (h2::args2) = (eqb h1 h2) && (args_eqb args1 args2)). {
      apply args_eqb_ind.
    }
    assert (eqb n2 n2 = true). apply Nat.eqb_refl. rewrite H0.
    rewrite H. unfold andb; simpl; auto.
  -

  induction args1.
  - destruct args2.
  + unfold args_eqb; unfold EqTerm; unfold term_eqb. simpl; auto.
  + simpl; auto. unfold args_eqb. apply andb_false_r.
  - induction args2.
  + simpl; auto. unfold args_eqb. apply andb_false_r.
  +
    assert (eqb (S n) (S n0) && eqb h1 h2 && args_eqb (h :: args1) (h0 :: args2)

   reflexivity. simpl; auto.
    unfold args_eqb; unfold EqTerm; unfold term_eqb. simpl; auto.
Qed.
*)
Lemma fun_eqb (n : nat) (s1 s2 : name) (args1 args2 : Vector.t Term n) :
  eqb (Fun s1 args1) (Fun s2 args2) =
  (eqb n n) && (eqb s1 s2) && (args_eqb args1 args2).
Proof.
  unfold eqb; unfold EqTerm; unfold term_eqb.
  unfold andb. simpl; auto.
Qed.

Lemma fun_eqb2 (n1 n2 : nat) (s1 s2 : name) (args1 : Vector.t Term n1) (args2 : Vector.t Term n2) :
  eqb (Fun s1 args1) (Fun s2 args2) =
  (eqb n1 n2) && (eqb s1 s2) && (args_eqb args1 args2).
Proof.
  unfold eqb; unfold EqTerm; unfold term_eqb.
  unfold andb. simpl; auto.
Qed.

Lemma constant_eqb_refl (s : name) : eqb (Fun s []) (Fun s []) = true.
Proof.
  intros.
  assert ((eqb s s) = true). apply String.eqb_refl.
  assert ((eqb 0 0) = true). unfold eqb; apply Nat.eqb_refl.
  unfold eqb; unfold EqTerm; unfold term_eqb.
  rewrite H; rewrite H0. unfold andb. reflexivity.
Qed.

Lemma fun_eqb_step (n : nat) (n0 : name) (t : Vector.t Term n) (h : Term)
  (IH : Forall (fun t : Term => eqb t t = true) t ->
        (forall a : Term, VectorDef.In a t -> (fun t : Term => eqb t t = true) a) ->
        eqb n n = true -> eqb (Fun n0 t) (Fun n0 t) = true) :
  Forall (fun t : Term => eqb t t = true) (h :: t) -> eqb (Fun n0 (h :: t)) (Fun n0 (h :: t)) = true.
Proof.
  intros. set (P := (fun t : Term => eqb t t = true)). fold P in H.
  assert (forall a : Term, VectorDef.In a (h :: t) -> P a). {
    apply (Vector.Forall_forall Term P (S n) (h::t)).
    assumption.
  }
  assert (Forall P (h :: t)) as IH1. assumption.
  apply Vector_Forall_cons_iff in IH1. destruct IH1.
  assert (forall a : Term, VectorDef.In a t -> P a). {
    apply (Vector.Forall_forall Term P n t).
    assumption.
  }
  fold P in IH.
  assert (eqb (Fun n0 t) (Fun n0 t) = true). {
    apply IH. assumption. assumption. apply Nat.eqb_refl.
  }
  unfold P in H1.

  assert (eqb (@Fun (S n) n0 (h :: t)) (@Fun (S n) n0 (h :: t)) =
          ((eqb (S n) (S n)) && (eqb n0 n0) &&
            (args_eqb (h :: t) (h :: t)))). {
    apply fun_eqb.
  }
  rewrite H5.
  assert (eqb (S n) (S n) = true). apply Nat.eqb_refl.
  rewrite H6.
  assert (eqb n0 n0 = true). apply String.eqb_refl.
  rewrite H7. unfold andb.

  assert (args_eqb (h :: t) (h :: t) =
          eqb h h && args_eqb t t). {
    apply args_eqb_ind.
  }
  rewrite H8. rewrite H1. unfold andb.

  assert (eqb (@Fun n n0 t) (@Fun n n0 t) =
          ((eqb n n) && (eqb n0 n0) &&
            (args_eqb t t))). {
    apply fun_eqb.
  }
  assert (eqb n n = true). apply Nat.eqb_refl.
  rewrite H7 in H9. rewrite H10 in H9. unfold andb in H9.
  rewrite H9 in H4. assumption.
Qed.

(*
Theorem term_eqb_refl (t : Term) : eqb t t = true.
Proof.
  induction t.
  - unfold eqb; apply V.eqb_refl.
  - unfold eqb; apply Nat.eqb_refl.
  - set (P := (fun t : Term => eqb t t = true)).
    fold P in H.
    assert (forall a : Term, VectorDef.In a t -> P a). {
      apply (Vector.Forall_forall Term P n t). assumption.
    }
    assert ((eqb n n) = true). unfold eqb; apply Nat.eqb_refl.
    assert ((eqb n0 n0) = true). apply String.eqb_refl.
    induction t.
    apply (constant_eqb_refl n0).
    apply fun_eqb_step. assumption. assumption.
Qed.

Theorem eqb_eq (t1 t2 : Term) : eqb t1 t2 = true -> t1 = t2.
Proof.
  intros. induction t1.
  - unfold eqb in H; unfold EqTerm in H; unfold term_eqb in H. destruct t2.
  + apply V.eqb_eq in H. rewrite H; reflexivity.
  + discriminate.
  + discriminate.
  - unfold eqb in H; unfold EqTerm in H; unfold term_eqb in H. destruct t2. discriminate.
    apply Nat.eqb_eq in H. rewrite H; reflexivity. discriminate.
  - destruct t2. discriminate. discriminate.
    assert (eqb (Fun n0 t) (Fun n2 t0)
            = eqb n n1 && eqb n0 n2 && args_eqb t t0). {
      apply (fun_eqb2 n n1 n0 n2 t t0).
    }
    rewrite H in H1.
    assert (eqb n n1 && eqb n0 n2 = true /\ args_eqb t t0 = true). apply andb_prop. assumption.
    destruct H2.
    assert (eqb n n1 = true /\ eqb n0 n2 = true). apply andb_prop; assumption.
    destruct H4.
    apply String.eqb_eq in H5. rewrite H5.
    apply Nat.eqb_eq in H4. rename t into args1. rename t0 into args2.
    rename n2 into nm.
    induction args1.
    + destruct args2. reflexivity. contradict H3. unfold args_eqb. discriminate.
    + destruct args2. contradict H3; unfold args_eqb; discriminate.

      apply (args_eqb_ind n h h0 args1 args2) in H3 as H6.
    assert (eqb n n1 = true). {
      destruct H. unfold andb.
    }
  + assert ({v = v0} + {v <> v0}). { apply V.eq_dec. } destruct H0.
    rewrite e; reflexivity.
    contradiction.
   destruct v; destruct v0. unfold eqb in H; unfold VEq in H. inversion H.
    assert (Bool.reflect (n = n0) (n =? n0)). { apply eqb_spec. }
    simpl; auto.
    Compute (eqb_spec n n0).
    apply eqb_spec in H1.
     decide equality.
   simpl; auto. unfold eqb in H; unfold EqTerm in H; unfold term_eqb in H. bdestruct (eqb v v0).
  ++
Qed.
*)
(*
Lemma fun_eqb (n : nat) (s1 s2 : name) (args1 : Vector.t Term n) (args2 : Vector.t Term n) :
  eqb (@Fun n s1 args1) (@Fun n s2 args2) = true <-> (s1 = s2 /\ args1 = args2).
Proof.
  intros.
  split.
  - intros. inversion H.
    assert ((s1 =? s2) = true). {
      unfold andb in H1; simpl; auto.
      assert ((n =? n)%nat = true). apply Nat.eqb_refl.
      rewrite H0 in H1.
      destruct (s1 =? s2). reflexivity. discriminate.
    }
    assert ((n =? n)%nat = true). apply Nat.eqb_refl.
    rewrite H0 in H1. rewrite H2 in H1. simpl in H1.
    apply String.eqb_eq in H0.
    split. assumption.
    apply (Vector.eqb_eq Term term_eqb in H1. simpl; auto.

Theorem term_dec (x y : Term) : {x = y} + {x <> y}.
Proof.
  intros. destruct (eqb x y) eqn:H.
  - left. now apply eqb_eq.
  decide equality. apply string_dec.
  decide equality.
Qed.
*)

Lemma eq_dec : forall (x y : Term), {x = y} + {x <> y}. Admitted.

(** *** Substitution Type Class

We will want to substitute a term for a variable frequently in many syntactic
constructs. Towards that end, we have a [Subst] type class.

We may also want to do this with a vector of variables and a vector of terms,
both vectors of the same length. Fortunately, we only have to define this
"many-folded substitution" function only once.
*)
Class Subst A : Type :=
{
  subst : V -> Term -> A -> A
}.

Fixpoint subst_many {n} {A : Type} `{Subst A} (vars : Vector.t V n) (terms : Vector.t Term n) (a : A) : A :=
match vars, terms with
| x::xs, t::tms => subst_many xs (Vector.tl terms) (subst x t a)
| _, _ => a
end.

(* HACK: since Coq cannot handle recursive typeclasses, we isolate the only
recursive substitution here.

See: https://stackoverflow.com/a/52349387 *)
Fixpoint tsubst (x : V) (t : Term) (e : Term) : Term :=
match e with
| Var y => if eqb x y then t else e
| @Fun n f args => @Fun n f (Vector.map (fun (a : Term) => tsubst x t a) args)
| EConst _ => e
end.

Global Instance substTerm : Subst Term :=
{
  subst (x : V) (t : Term) (e : Term) := tsubst x t e
}.

Example term_subst_1 : subst (BVar 1) (Fun "c" []) (Fun "f" [Var (BVar 1) ; Var (FVar "x")])
= Fun "f" [(Fun "c" []) ; Var (FVar "x")].
Proof.
  trivial.
Qed.

Example term_subst_2 : subst (FVar "x") (Fun "c" []) (Fun "f" [Var (BVar 1) ; Var (FVar "x")])
= Fun "f" [Var (BVar 1) ; (Fun "c" [])].
Proof.
  trivial.
Qed.

Example term_subst_3 : subst (BVar 3) (Fun "c" []) (Fun "f" [Var (BVar 1) ; Var (FVar "x")])
= Fun "f" [Var (BVar 1) ; Var (FVar "x")].
Proof.
  trivial.
Qed.

Example term_subst_4 : subst (FVar "z") (Fun "c" []) (Fun "f" [Var (BVar 1) ; Var (FVar "x")])
= Fun "f" [Var (BVar 1) ; Var (FVar "x")].
Proof.
  trivial.
Qed.

Require Import Coq.Logic.Eqdep_dec.

Lemma subst_id : forall (n : nat) (t : Term),
  subst (BVar n) (Var (BVar n)) t = t.
Proof.
  intros.
  induction t.
  - destruct v. simpl; auto. assert ({n = n0} + {n <> n0}). decide equality. destruct H.
    + rewrite e. simpl; auto. rewrite Nat.eqb_refl. reflexivity.
    + apply Nat.eqb_neq in n1. simpl; auto. rewrite n1. reflexivity.
  - simpl; auto.
  - rename t into args.
    assert (map (subst (BVar n) (Var (BVar n))) args = args). {
      induction args.
      + simpl; auto.
      + assert (map (subst (BVar n) (Var (BVar n))) args = args). {
          apply IHargs. inversion H. apply inj_pair2_eq_dec in H2.
          rewrite H2 in H4. assumption. decide equality.
        }
        assert(map (subst (BVar n) (Var (BVar n))) (h :: args)
               = (subst (BVar n) (Var (BVar n)) h)::(map (subst (BVar n) (Var (BVar n))) args)). {
          simpl; auto.
        }
        rewrite H1. rewrite H0.
        rewrite (Forall_forall Term (fun t : Term =>
       subst (BVar n) (Var (BVar n)) t = t)
      ) in H.
        assert (In h (h :: args)). { apply In_cons_hd.  }
        apply H in H2. rewrite H2. reflexivity.
    }
    assert (subst (BVar n) (Var (BVar n)) (Fun n1 args)
            = Fun n1 (Vector.map (subst (BVar n) (Var (BVar n))) args)). {
      simpl; auto.
    }
    rewrite H1; rewrite H0. reflexivity.
Qed.

Corollary subst_id_vec : forall (n n0 : nat) (args : Vector.t Term n0),
  map (subst (BVar n) (Var (BVar n))) args = args.
Proof.
  intros.
  induction args. simpl; auto.
  assert (map (subst (BVar n) (Var (BVar n)))
  (h :: args) = (subst (BVar n) (Var (BVar n)) h)::(map
           (subst (BVar n) (Var (BVar n)))
           args)). {
    simpl; auto.
  }
  rewrite H.
  assert (subst (BVar n) (Var (BVar n)) h = h). {
    apply subst_id.
  }
  rewrite H0; rewrite IHargs; reflexivity.
Qed.

Fixpoint term_map_var (f : V -> V) (t : Term) : Term :=
match t with
| Var x => Var (f x)
| EConst _ => t
| Fun nm args => Fun nm (Vector.map (fun (a : Term) => term_map_var f a) args)
end.

Lemma term_map_var_id : forall (t : Term),
  term_map_var id t = t.
Proof. intros. induction t.
 (* apply Term_ind_mut.  dependent inversion t.  (fun (args : TermArgs) => (List.map (term_m.  *)
  - simpl; auto.
  - simpl; auto.
  - rename t into args.
    assert(forall (t : Term), Vector.In t args -> ((fun t : Term => term_map_var id t = t) t)). {
      apply Vector.Forall_forall. assumption.
    }
    assert (term_map_var id (Fun n0 args) = Fun n0 (Vector.map (fun (a : Term) => term_map_var id a) args)). {
      unfold term_map_var; simpl; auto.
    } rewrite H1.
    simpl in H0.
    assert (Vector.map (fun a : Term => term_map_var id a) args = args) as IH. {
      induction args.
      simpl; auto.
      assert (Vector.map (fun a : Term => term_map_var id a) (h :: args)
               = (term_map_var id h)::(Vector.map (fun a : Term => term_map_var id a) args)). {
        unfold Vector.map; simpl; auto.
      }
      rewrite H2.
      assert (term_map_var id h = h). {
        apply H0. apply In_cons_hd.
      }
      rewrite H3.
      assert (Vector.map (fun a : Term => term_map_var id a) args = args). {
        apply IHargs. simpl; auto. inversion H.
        - apply Vector.Forall_forall.
          assert (forall a : Term, VectorDef.In a args -> VectorDef.In a (h :: args)). {
            intros. apply In_cons_tl. assumption.
          }
          intros.
          simpl; auto.
        - intros. assert (Vector.In t (h :: args)). apply In_cons_tl. assumption.
          apply H0 in H5. assumption.
        - simpl; auto.
      }
      rewrite H4. reflexivity.
    }
    rewrite IH. reflexivity.
Qed.

Fixpoint term_contains_bvar (index : nat) (t : Term) : Prop :=
match t with
| Var x => x = BVar index
| EConst _ => False
| @Fun n nm args =>
  let fix args_contain_bvar {k} (ar : Vector.t Term k) :=
     (match ar with
      | Vector.nil _ => False
      | Vector.cons _ h _ tl => term_contains_bvar index h \/ args_contain_bvar tl
      end)
  in args_contain_bvar args
end.

Class ContainsBVar A := {
  contains_bvar : nat -> A -> Prop
}.

Global Instance ContainsBVarTerm : ContainsBVar Term := {
  contains_bvar := term_contains_bvar
}.

Lemma term_subst_bvar_free : forall (n : nat) (t h : Term),
  ~(contains_bvar n h) -> (subst (BVar n) t h) = h.
Proof.
  unfold contains_bvar; unfold ContainsBVarTerm. intros. induction h as [x|k|k nm args].
  - destruct x.
  + simpl; auto.
  + unfold term_contains_bvar in H. simpl; auto.
    assert (n0 <> n). { simpl; auto. }
    bdestruct (Nat.eqb n n0).
 ++ contradict H1; simpl; auto.
 ++ reflexivity.
  - simpl; auto.
  - set (P := (fun h : Term => ~ term_contains_bvar n h -> subst (BVar n) t h = h)).
    fold P in H0.
    assert (forall (a : Term), VectorDef.In a args -> P a). {
      apply Vector.Forall_forall. assumption.
    }
    assert(subst (BVar n) t (Fun nm args) = Fun nm (Vector.map (fun a : Term => tsubst (BVar n) t a) args)). {
      simpl; auto.
    } rewrite H2.
    assert ((Vector.map (fun a : Term => tsubst (BVar n) t a) args) = args). {
      induction args.
      - simpl; auto.
      - assert(Vector.map (fun a : Term => tsubst (BVar n) t a) (h :: args)%vector
           = ((tsubst (BVar n) t h)::(Vector.map (fun a : Term => tsubst (BVar n) t a) args))%vector). {
          simpl; auto.
        }
        rewrite H3.
        assert(~ term_contains_bvar n (Fun nm (h :: args)%vector)
                    -> ~ term_contains_bvar n (Fun nm args)). {
          unfold term_contains_bvar; simpl; auto.
        }
        assert (Vector.Forall P args) as IH1. {
          apply Vector.Forall_forall. intros; apply H1;
            apply Vector.In_cons_tl; apply H5.
        }
        assert (~ term_contains_bvar n (Fun nm args)) as IH2. {
          apply H4. apply H.
        }
        assert (forall a : Term, VectorDef.In a args -> P a) as IH3. {
          intros. apply H1.  apply Vector.In_cons_tl; apply H5.
        }
        assert (subst (BVar n) t (Fun nm args) =
                Fun nm (Vector.map (fun a : Term => tsubst (BVar n) t a) args)). {
          unfold subst; simpl; auto.
        }
        assert((Vector.map (fun a : Term => tsubst (BVar n) t a) args) = args). {
          apply IHargs. simpl; auto. simpl; auto. simpl; auto. simpl; auto.
        } rewrite H6.
        clear IH1 IH2 IH3 H6.
        assert (tsubst (BVar n) t h = h). {
          assert (P h). {
            apply H1. apply Vector.In_cons_hd.
          }
          unfold P in H6. unfold subst in H6; unfold substTerm in H6.
          apply H6.
          assert (~ term_contains_bvar n (Fun nm (h :: args)%vector) -> ~ term_contains_bvar n h). {
            simpl; auto.
          }
          apply H7. apply H.
        }
        rewrite H6. reflexivity.
    }
    rewrite H3. reflexivity.
Qed.

(*
Definition tlift (c d : nat) (t : Term) := term_map_var (lift c d) t.

Fixpoint tlift (c d : nat) (t : Term) : Term :=
match t with
| Var y => Var (lift c d y)
| Fun f args => Fun f (Vector.map (fun (a : Term) => tlift c d a) args)
| EConst _ => t
end.
*)

Global Instance liftTerm : Lift Term :=
{
  lift (c d : nat) (t : Term) := term_map_var (lift c d) t;
  unlift (c d : nat) (t : Term) := term_map_var (unlift c d) t
}.

Definition tlift := lift.
(* (c d : nat) (t : Term) := term_map_var (lift c d) t. *)

(** Lemma: [lift 0 0] is the identity transformation. *)
Lemma term_zero_lift_is_id : forall (t : Term), lift 0 0 t = id t.
Proof.
  intros. induction t.
  - assert (@lift V VLift 0 0 = id). apply zero_lift_is_id.
    unfold lift; unfold liftTerm. rewrite H.
    assert (id (Var v) = Var v). { unfold id; simpl; auto. }
    assert (@lift V VLift 0 0 v = id v). {
      apply equal_f. trivial.
    }
    unfold term_map_var. unfold id. reflexivity.
  - unfold lift; unfold term_map_var; simpl; auto.
  - rename t into args.
    set (P := (fun t : Term => lift 0 0 t = id t)). fold P in H.
    assert (forall a : Term, VectorDef.In a args -> P a). {
      apply (Vector.Forall_forall Term P n args). assumption.
    }

    assert (lift 0 0 (Fun n0 args) = Fun n0 (Vector.map (fun a : Term => term_map_var (lift 0 0) a) args)). {
      unfold lift; unfold liftTerm; unfold term_map_var; simpl; auto.
    } rewrite H1. clear H1.
    assert (Vector.map (fun a : Term => term_map_var (lift 0 0) a) args = args). {
      admit.
    }
    rewrite H1. unfold id. reflexivity.
Admitted.

Require Import Coq.Vectors.VectorSpec.

Lemma bigger_lift_is_id : forall (i k1 k2 : nat) (t : Term), k1 < k2 -> lift k1 i t = t -> lift k2 i t = t.
Proof.
  intros. induction t.
  - unfold lift; unfold liftTerm; unfold term_map_var.
    assert(lift k1 i v = v). {
      unfold lift in H0; unfold liftTerm in H0; unfold term_map_var in H0.
      injection H0. simpl; auto.
    }
    apply V.bigger_lift_is_id with (x := v) (i := i) (k1 := k1) (k2 := k2) in H as H2.
    2: assumption.
    rewrite H2; reflexivity.
  - simpl; auto.
  - rename t into args.
    unfold lift; unfold liftTerm.
    assert(term_map_var (lift k2 i) (Fun n0 args) = Fun n0 (Vector.map (lift k2 i) args)). {
      unfold term_map_var; simpl; auto.
    } rewrite H2.
    rewrite Vector.Forall_forall with (P := (fun t : Term =>
        lift k1 i t = t -> lift k2 i t = t)) in H1.
    assert (map (lift k2 i) args = args). {
      induction args.
      - simpl; auto.
      - assert (map (lift k2 i) (h :: args) = (lift k2 i h)::(map (lift k2 i) args)). {
          simpl; auto.
        } rewrite H3.
        assert (map (lift k2 i) args = args) as IH. admit.
          (* It's true, but too much work to prove it *)
        rewrite IH.
        assert (lift k2 i h = h). {
          assert (Vector.In h (h::args)). {  apply Vector.In_cons_hd. }
          assert (lift k1 i h = h). { admit. } (* It's true, but too much work to prove it *)
          apply H1 in H4. assumption. assumption.
        }
        rewrite H4. reflexivity.
    }
    rewrite H3. reflexivity.
Admitted.

Corollary bigger_lift_is_id_vector : forall (i k1 k2 n : nat) (args : Vector.t Term n),
  k1 < k2 ->
  Vector.map (lift k1 i) args = args ->
  Vector.map (lift k2 i) args = args.
Admitted.

Theorem lift_comp : forall (c d1 d2 : nat) (t : Term),
  lift c d1 (lift c d2 t) = lift c (d1 + d2) t.
Proof.
  intros.
  induction t.
  - unfold lift; unfold liftTerm; unfold term_map_var. rewrite V.lift_comp. reflexivity.
  - unfold lift; unfold liftTerm; unfold term_map_var. reflexivity.
  - unfold lift; unfold liftTerm.
    rewrite (Vector.Forall_forall Term (fun t : Term => lift c d1 (lift c d2 t) = lift c (d1 + d2) t) n t) in H.
    assert (term_map_var (lift c d2) (Fun n0 t) = Fun n0 (Vector.map (lift c d2) t)). {
      unfold term_map_var; simpl; auto.
    } rewrite H0. clear H0.
    assert (term_map_var (lift c d1) (Fun n0 (map (lift c d2) t)) = Fun n0 (map (lift c d1) (map (lift c d2) t))). {
      simpl; auto.
    }
    assert (term_map_var (lift c (d1 + d2)) (Fun n0 t) = Fun n0 (map (lift c (d1 + d2)) t)). {
      simpl; auto.
    } rewrite H0; rewrite H1. clear H0 H1.
    assert (map (lift c d1) (map (lift c d2) t) = map (lift c (d1 + d2)) t). {
      induction t as [| h tl].
      - simpl; auto.
      - assert (map (lift c d1) (map (lift c d2) (h :: t)) = (lift c d1 (lift c d2 h))::map (lift c d1) (map (lift c d2) t)). {
          simpl; auto.
        }
        assert (forall a : Term, VectorDef.In a t -> lift c d1 (lift c d2 a) = lift c (d1 + d2) a). {
          intros. apply In_cons_tl with (x := h) in H1. apply H in H1. assumption.
        }
        apply IHt in H1. rewrite H0; rewrite H1.
        assert (lift c d1 (lift c d2 h) = lift c (d1 + d2) h). {
          apply H. apply In_cons_hd.
        }
        rewrite H2.
        simpl; auto.
    }
    rewrite H0; reflexivity.
Qed.

Theorem vect_lift_comp : forall (c d1 d2 : nat) {n : nat} (args : Vector.t Term n),
  Vector.map (lift c d1) (Vector.map (lift c d2) args)
  = Vector.map (lift c (d1 + d2)) args.
Proof.
  induction args as [| h t].
  - simpl; auto.
  - assert (map (lift c d1) (map (lift c d2) (h :: args)) = (lift c d1 (lift c d2 h))::map (lift c d1) (map (lift c d2) args)). {
      simpl; auto.
    } rewrite H. rewrite IHargs.
    assert (lift c d1 (lift c d2 h) = lift c (d1 + d2) h). {
      apply lift_comp.
    }
    rewrite H0.
    simpl; auto.
Qed.

Theorem lift_seq : forall (c d1 d2 : nat) (t : Term),
  d1 > 0 -> lift (S c) d2 (lift c d1 t) = lift c (d2 + d1) t.
Proof.
  intros.
  induction t.
  - unfold lift; unfold liftTerm; unfold term_map_var. rewrite V.lift_seq. reflexivity. assumption.
  - unfold lift; unfold liftTerm; unfold term_map_var. reflexivity.
  - unfold lift; unfold liftTerm.
    rewrite (Vector.Forall_forall Term (fun t : Term => lift (S c) d2 (lift c d1 t) = lift c (d2 + d1) t) n t) in H0.
    assert (term_map_var (lift c d1) (Fun n0 t) = Fun n0 (Vector.map (lift c d1) t)). {
      unfold term_map_var; simpl; auto.
    } rewrite H1. clear H1.
    assert (term_map_var (lift (S c) d2) (Fun n0 (map (lift c d1) t)) = Fun n0 (map (lift (S c) d2) (map (lift c d1) t))). {
      simpl; auto.
    }
    assert (term_map_var (lift c (d2 + d1)) (Fun n0 t) = Fun n0 (map (lift c (d2 + d1)) t)). {
      simpl; auto.
    } rewrite H1; rewrite H2. clear H1 H2.
    assert (map (lift (S c) d2) (map (lift c d1) t) = map (lift c (d2 + d1)) t). {
      induction t as [| h tl].
      - simpl; auto.
      - assert (map (lift (S c) d2) (map (lift c d1) (h :: t)) = (lift (S c) d2 (lift c d1 h))::map (lift (S c) d2) (map (lift c d1) t)). {
          simpl; auto.
        }
        assert (forall a : Term, VectorDef.In a t -> lift (S c) d2 (lift c d1 a) = lift c (d2 + d1) a). {
          intros. apply In_cons_tl with (x := h) in H2. apply H0 in H2. assumption.
        }
        apply IHt in H2. rewrite H1; rewrite H2.
        assert (lift (S c) d2 (lift c d1 h) = lift c (d2 + d1) h). {
          apply H0. apply In_cons_hd.
        }
        rewrite H3.
        simpl; auto.
    }
    rewrite H1; reflexivity.
Qed.

(* WTS: (lift (S m) 1 (lift 1 m t)) = lift 1 (S m) t *)
Corollary variadic_quantifier_lift_seq :
  forall (m k : nat) (t : Term),
  k > 0 -> (lift (k + m) 1 (lift k m t)) = lift k (S m) t.
Proof.
  intros. induction t.
  - unfold lift; unfold liftTerm; unfold term_map_var. rewrite V.variadic_quantifier_lift_seq. reflexivity. assumption.
  - unfold lift; unfold liftTerm; unfold term_map_var. reflexivity.
  - unfold lift; unfold liftTerm.
    rewrite (Vector.Forall_forall Term (fun t : Term => lift (k + m) 1 (lift k m t) = lift k (S m) t) n t) in H0.
    assert (term_map_var (lift k (S m)) (Fun n0 t) = Fun n0 (Vector.map (lift k (S m)) t)). {
      unfold term_map_var; simpl; auto.
    } rewrite H1; clear H1.
    assert (term_map_var (lift (k + m) 1) (Fun n0 (map (lift k m) t)) = Fun n0 (map (lift (k + m) 1) (map (lift k m) t))). {
      simpl; auto.
    }
    assert (term_map_var (lift k m) (Fun n0 t) = Fun n0 (map (lift k m) t)). {
      simpl; auto.
    } rewrite H2; rewrite H1. clear H2 H1.
    assert (map (lift (k + m) 1) (map (lift k m) t) = map (lift k (S m)) t). {
      induction t as [| h tl].
      - simpl; auto.
      - assert (map (lift (k + m) 1) (map (lift k m) (h :: t))
                = (lift (k + m) 1 (lift k m h))::map (lift (k + m) 1) (map (lift k m) t)). {
          simpl; auto.
        }
        assert (forall a : Term, VectorDef.In a t -> lift (k + m) 1 (lift k m a) = lift k (S m) a). {
          intros. apply In_cons_tl with (x := h) in H2. apply H0 in H2. assumption.
        }
        apply IHt in H2. rewrite H1; rewrite H2.
        assert (lift (k + m) 1 (lift k m h) = lift k (S m) h). {
          apply H0. apply In_cons_hd.
        }
        rewrite H3.
        simpl; auto.
    }
    rewrite H1; reflexivity.
Qed.

(* lift (S (S m)) 1 (lift 2 m A)) = Exists (lift 2 (S m) A) *)
Corollary vect_variadic_quantifier_lift_seq :
  forall (m k : nat) {n : nat} (args : Vector.t Term n),
  k > 0 ->
  Vector.map (lift (k + m) 1) (Vector.map (lift k m) args)
  = Vector.map (lift k (S m)) args.
Proof.
  induction args as [| h t].
  - simpl; auto.
  - intros.
    assert (map (lift (k + m) 1) (map (lift k m) (h :: args))
            = (lift (k + m) 1 (lift k m h))::map (lift (k + m) 1) (map (lift k m) args)). {
      simpl; auto.
    } rewrite H0. rewrite IHargs.
    assert (lift (k + m) 1 (lift k m h) = lift k (S m) h). {
      apply variadic_quantifier_lift_seq; assumption.
    }
    rewrite H1.
    simpl; auto. assumption.
Qed.

Theorem vect_lift_seq : forall (c d2 d1 : nat) {n : nat} (args : Vector.t Term n),
  d1 > 0 ->
  Vector.map (lift (S c) d2) (Vector.map (lift c d1) args)
  = Vector.map (lift c (d2 + d1)) args.
Proof.
  induction args as [| h t].
  - simpl; auto.
  - intros.
    assert (map (lift (S c) d2) (map (lift c d1) (h :: args)) = (lift (S c) d2 (lift c d1 h))::map (lift (S c) d2) (map (lift c d1) args)). {
      simpl; auto.
    } rewrite H0. rewrite IHargs.
    assert (lift (S c) d2 (lift c d1 h) = lift c (d2 + d1) h). {
      apply lift_seq; assumption.
    }
    rewrite H1.
    simpl; auto. assumption.
Qed.

Definition term_is_fun (t : Term) : Prop :=
  match t with
  | Fun _ _ =>  True
  | _ => False
  end.

Class Fresh A : Type := {
  fresh : Term -> A -> Prop
}.

Fixpoint fresh_term (c : Term) (t : Term) : Prop :=
match t, c with
| Var x, Var y => x <> y
| EConst m, EConst n => m <> n
| Fun f args1, Fun g args2 => t <> c /\
  let fix fresh_args {k} (ars : Vector.t Term k) :=
          match ars with
          | tm::ars1 => (fresh_term c tm) /\ fresh_args ars1
          | [] => True
          end
  in fresh_args args1
| _,_ => True
end.

Global Instance FreshTerm : Fresh Term := {
  fresh := fresh_term
}.

Theorem fresh_not_reflex : forall (t : Term),
  ~fresh t t.
Proof.
  intros. assert (t = t). { reflexivity. }
  destruct t.
  - auto.
  - auto.
  - unfold fresh; unfold FreshTerm; unfold fresh_term; auto.
    assert (~(Fun n0 t <> Fun n0 t)). { auto. }
    apply or_not_and. left. auto.
Qed.

Definition fresh_vect (c : Term) {n} (args : Vector.t Term n) : Prop :=
  Vector.Forall (fresh c) args.

(** ** New Existential Variables

We can assemble the list of existential variables appearing in a
[Term], [Formula], whatever. Then we can generate a fresh
existential variable.
*)

Class EnumerateEVars A := {
  list_evars : A -> list nat
}.

Fixpoint list_evars_term (t : Term) (l : list nat) : list nat :=
match t with
| Var _ => l
| EConst n => insert n l
| Fun f args => Vector.fold_left (fun l' => fun (arg : Term) => insert_merge (list_evars_term arg l') l')
    l args
end.

Theorem list_evars_term_sorted : forall (t : Term) (l : list nat),
  sorted l -> sorted (list_evars_term t l).
Proof.
  intros.
  induction t.
  - assert (list_evars_term (Var v) l = l). { simpl; auto. }
    rewrite H0. assumption.
  - assert (list_evars_term (EConst n) l = insert n l). { simpl; auto. }
    rewrite H0. apply insert_preserves_sorted. assumption.
  - rename t into args.
    assert (list_evars_term (Fun n0 args) l = Vector.fold_left (fun l' => fun (arg : Term) => insert_merge (list_evars_term arg l') l')
    l args). { simpl; auto. }
    rewrite H1. apply insert_merge_vector_fold_sorted2.
    assumption.
Qed.

Global Instance EnumerateEVarsTerm : EnumerateEVars Term := {
  list_evars tm := list_evars_term tm []
}.

Theorem list_evers_term_sorted : forall (t : Term),
  sorted (list_evars t).
Proof. intros.
  unfold list_evars; unfold EnumerateEVarsTerm.
  assert (sorted []%list). { apply sorted_nil. }
  apply list_evars_term_sorted.
  assumption.
Qed.

(** The alternate approach is that fresh existential variables will be [0],
and when we introduce one, we [shift_evars] in the related formulas. *)
Class LiftEvars A := {
  lift_evars : nat -> A -> A
}.

Definition shift_evars {A : Type} `{LiftEvars A} (a : A) : A := lift_evars 1 a.

Fixpoint lift_evars_term (k : nat) (t : Term) : Term :=
match t with
| Var _ => t
| EConst n => EConst (n + k)
| Fun f args => Fun f (Vector.map (lift_evars_term k) args)
end.

Global Instance ShiftEvarsTerm : LiftEvars Term := {
lift_evars := lift_evars_term
}.

(** *** Check if a [Term] appears as a subterm *)
Class Contains A := {
  contains : Term -> A -> Prop
}.

Definition contains_var {A : Type} `{Contains A} (x : V) (a : A) : Prop :=
  contains (Var x) a.

Inductive contains_subterm : Term -> Term -> Prop :=
| contains_subterm_refl : forall (t : Term),
  contains_subterm t t
| contains_subterm_fun : forall (sub : Term) {n : nat} (nm : name) (args : Vector.t Term n),
  Vector.In sub args ->
  contains_subterm sub (Fun nm args)
| contains_subterm_trans : forall (t1 t2 t3 : Term),
  contains_subterm t1 t2 ->
  contains_subterm t2 t3 ->
  contains_subterm t1 t3.

Global Instance ContainsTerm : Contains Term := {
  contains := contains_subterm
}.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e256m4294968273_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


(** * Antidistributivity *)

From DEZ.Is Require Export
  Distributive.

(** ** Unary Functions Antidistributing over Binary Functions *)

Class IsAntidistrUnFns (A0 A1 B0 B1 B2 C : Type) (X : C -> C -> Prop)
  (f : A1 -> B0) (g : A0 -> B1) (k : A0 -> A1 -> B2)
  (h : B2 -> C) (m : B0 -> B1 -> C) : Prop :=
  antidistr_un_fns (x : A0) (y : A1) : X (h (k x y)) (m (f y) (g x)).

Section Context.

Context (A0 A1 B0 B1 B2 C : Type) (X : C -> C -> Prop)
  (f : A1 -> B0) (g : A0 -> B1) (k : A0 -> A1 -> B2)
  (h : B2 -> C) (m : B0 -> B1 -> C).

(** Antidistributivity of unary functions over binary functions
    is a special case of the distributivity of their flipped versions. *)

#[export] Instance antidistr_un_fns_is_distr_un_fns_flip
  `{!IsAntidistrUnFns X f g k h m} : IsDistrUnFns X g f k h (flip m).
Proof. auto. Qed.

#[local] Instance distr_un_fns_flip_is_antidistr_un_fns
  `{!IsDistrUnFns X g f k h (flip m)} : IsAntidistrUnFns X f g k h m.
Proof. auto. Qed.

End Context.

(** ** Unary Function Antidistributing over Binary Operations *)

Class IsAntidistrUnFn (A B : Type) (X : B -> B -> Prop)
  (f : A -> B) (k : A -> A -> A) (m : B -> B -> B) : Prop :=
  antidistr_un_fn (x y : A) : X (f (k x y)) (m (f y) (f x)).

Section Context.

Context (A B : Type) (X : B -> B -> Prop)
  (f : A -> B) (k : A -> A -> A) (m : B -> B -> B).

(** Antidistributivity of a unary function over a binary operation
    is a special case of their antidistributivity as functions. *)

#[export] Instance antidistr_un_fn_is_antidistr_un_fns
  `{!IsAntidistrUnFn X f k m} : IsAntidistrUnFns X f f k f m.
Proof. auto. Qed.

#[local] Instance antidistr_un_fns_is_antidistr_un_fn
  `{!IsAntidistrUnFns X f f k f m} : IsAntidistrUnFn X f k m.
Proof. auto. Qed.

End Context.

(** ** Unary Operation Antidistributing over a Binary Operation *)

(** This has the same shape as [Z.opp_add_antidistr]. *)

Class IsAntidistrUnOp (A : Type) (X : A -> A -> Prop)
  (f : A -> A) (k : A -> A -> A) : Prop :=
  antidistr_un_op (x y : A) : X (f (k x y)) (k (f y) (f x)).

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (f : A -> A) (k : A -> A -> A).

(** Antidistributivity of a unary operation over a binary operation
    is a special case of their antidistributivity as functions. *)

#[export] Instance antidistr_un_op_is_antidistr_un_fns
  `{!IsAntidistrUnOp X f k} : IsAntidistrUnFns X f f k f k.
Proof. auto. Qed.

#[local] Instance antidistr_un_fns_is_antidistr_un_op
  `{!IsAntidistrUnFns X f f k f k} : IsAntidistrUnOp X f k.
Proof. auto. Qed.

End Context.


From AC Require Import expression.
Require Import String.
Require Import Lia.

(*NOTATION*)
Definition x : string := "x".
Definition y : string := "y".
Definition z : string := "z".
Definition n : string := "n".
Definition fun0: string := "fun0".
Definition fun1: string := "fun1".
Definition prod5: string := "prod5".

Hint Unfold x : core.
Hint Unfold y : core.
Hint Unfold z : core.

Check <{x}>.
Check <{fun prod5 [x:Nat] {x * [>5]} 5}>.
Check <{x (fun prod5 [x:Nat] {x * 5})}>.
Check <{val n = 25 ; n * 2}>.
Check <{[4 >> 2][5 >> 5][6 >> 4][ > 5]}>.

(*Bounded Test*)
Compute (bounded <{fun fun0 [x:Nat] {x}}>).

Lemma bounded0 : bounded <{fun fun0 [x:Nat] {x}}> nil.
Proof.
simpl. left. reflexivity.
Qed.

Lemma bounded1 : bounded <{fun fun0 [x:Nat] {x * y}}> nil.
Proof.
simpl. split.
-left. reflexivity.
-left.
Abort.

Lemma bounded2 : bounded <{fun fun0 [x:Nat] {x * (fun fun1 [y:Nat] {y})}}> nil.
Proof.
simpl. split.
-left. reflexivity.
-left. reflexivity.
Qed.


(*common header begin*)
Require Import Utf8.
From Coq Require Import ssreflect ssrfun ssrbool.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Maximal Implicit Insertion.
(*common header end*)

Require Import PeanoNat.
Require Import List.
Import ListNotations.
Require Import Psatz.

Require Import UserTactics.

(*
Lemma if_eq : forall (f : nat -> nat) (x y : nat), (if y =? x then f x else f y) = f y.
Proof.
move => f x y.
have := Nat.eq_dec x y.
case; intros; inspect_eqb; auto.
Qed.

Lemma if_elim {T : Type} (P : T -> Prop) (m n : nat) (a b : nat -> nat -> T) :
  P (a m n) -> P (b m n) -> P (if m =? n then a m n else b m n).
Proof.
intros.
case : (Nat.eq_dec m n); intros;
inspect_eqb; assumption.
Qed.
*)

Lemma if_fun {T U : Type}: forall A (f : T -> U) a b, (if A then f a else f b) = f (if A then a else b).
Proof.
case => //.
Qed.

Lemma fold_sum_gt : forall l n m, n > m -> fold_left Nat.add l n > m.
Proof.
elim; cbn; first auto.
move => n l IH k m H; cbn.
apply : IH. lia.
Qed.


(*********************************************************************************
* Formalization of lambda ex						         *
*									         *
* Brian Aydemir & Arthur Chargueraud, July 2007              	   	         *
* Flavio L. C. de Moura & Daniel L. Ventura, 2012                                *
* Flavio L. C. de Moura & Daniel L. Ventura, 2012 & Washington R. Segundo, 2013	 *
*********************************************************************************)

Set Implicit Arguments.
Require Import Metatheory LambdaES_Defs LambdaES_Infra LambdaES_FV.
Require Import Rewriting_Defs Rewriting_Lib.
Require Import Lambda Equation_C.

(** Lambda ex calculus *)
Inductive rule_b : pterm -> pterm -> Prop :=
   reg_rule_b : forall (t u:pterm),  body t -> term u ->
     rule_b (pterm_app(pterm_abs t) u) (t[u]).
Notation "t ->_B u" := (rule_b t u) (at level 66).

Inductive sys_x : pterm -> pterm -> Prop :=
| reg_rule_var : forall t, term t -> sys_x (pterm_bvar 0 [t]) t

| reg_rule_gc : forall t u, term t -> term u -> sys_x (t[u]) t

| reg_rule_app : forall t1 t2 u, body t1 -> body t2 -> term u ->
  sys_x ((pterm_app t1 t2)[u]) (pterm_app (t1[u]) (t2[u]))

| reg_rule_lamb : forall t u, body (pterm_abs t) -> term u ->
  sys_x ((pterm_abs t)[u]) (pterm_abs ((& t)[u]))

| reg_rule_comp : forall t u v, body (t[u]) -> ~ term u -> term v ->
  sys_x (t[u][v]) (((& t)[v])[ u[ v ] ]).

Notation "t ->_x u" := (sys_x t u) (at level 59, left associativity).

Definition ex t u := red_ctx_mod_eqC sys_x t u.
Notation "t -->ex u" := (ex t u) (at level 66).

Definition ex_trs t u := trans_closure ex t u.
Notation "t -->ex+ u" := (ex_trs t u) (at level 66).

Definition ex_str t u := star_closure ex t u.
Notation "t -->ex* u" := (ex_str t u) (at level 66).

Inductive sys_Bx: pterm -> pterm -> Prop :=
| B_lx : forall t u, t ->_B u -> sys_Bx t u
| sys_x_lx : forall t u, t ->_x u -> sys_Bx t u.

Notation "t ->_Bx u" := (sys_Bx t u) (at level 59, left associativity).

Definition lex t u :=  red_ctx_mod_eqC sys_Bx t u.
Notation "t -->lex u" := (lex t u) (at level 66).

Definition lex_trs t u := trans_closure lex t u.
Notation "t -->lex+ u" := (lex_trs t u) (at level 66).

Definition lex_str t u := star_closure lex t u.
Notation "t -->lex* u" := (lex_str t u) (at level 66).

(* ********************************************************************** *)
(** Properties of the sys_x  *)

Lemma sys_x_regular : red_regular sys_x.
Proof.
 intros_all. destruct H.
 split; trivial. apply body_to_subs; trivial.
 apply body'_to_body. unfold body'. simpl. omega.
 split; trivial. apply body_to_subs; trivial.
 apply term_is_a_body in H; trivial.
 split. apply body_to_subs; trivial.
 apply body_distribute_over_application. split; trivial.
 apply term_distribute_over_application.
 split; apply body_to_subs; trivial.
 split. apply body_to_subs; trivial.
 apply body_to_term_abs. apply body_to_body' in H.
 unfold body' in H. simpl in H. apply body'_to_body.
 unfold body'. simpl. apply term_is_a_body in H0.
 apply body_to_body' in H0. unfold body' in H0.
 split; trivial. apply lc_at_bswap; trivial. omega.
 split. apply body_to_subs; trivial.
 apply body_to_subs. apply body'_to_body.
 apply body_to_body' in H. unfold body' in *|-*.
 simpl in *|-*. apply term_is_a_body in H1.
 apply body_to_body' in H1. unfold body' in H1.
 split; trivial. apply lc_at_bswap. omega. apply H.
 apply body_to_subs; trivial.  apply body_to_body' in H.
 apply body'_to_body. unfold body' in *|-*. simpl in *|-*.
 apply H.
Qed.

Lemma ctx_sys_x_regular : red_regular (contextual_closure sys_x).
Proof.
  apply red_regular_ctx.
  apply sys_x_regular.
Qed.

Lemma ctx_sys_ex_regular : red_regular ex.
Proof.
 apply red_regular_eqC.
 apply sys_x_regular.
Qed.

Lemma sys_Bx_regular : red_regular sys_Bx.
Proof.
 intros t u H; destruct H. destruct H.
 split. apply term_distribute_over_application; trivial.
 split; trivial. apply body_to_term_abs; trivial.
 apply body_to_subs; trivial.
 apply sys_x_regular; trivial.
Qed.

Lemma ctx_sys_Bx_regular : red_regular (contextual_closure sys_Bx).
Proof.
  apply red_regular_ctx.
  apply sys_Bx_regular.
Qed.

Lemma ctx_sys_Bex_regular : red_regular lex.
Proof.
 apply red_regular_eqC.
 apply sys_Bx_regular.
Qed.

Lemma sys_x_red_out : red_out sys_x.
Proof.
 intros_all. induction H0.
 simpl; apply reg_rule_var; apply term'_to_term;
 apply lc_at_subst; apply term_to_term'; trivial.
 simpl; apply reg_rule_gc; apply term'_to_term;
 apply lc_at_subst; apply term_to_term'; trivial.
 simpl; apply reg_rule_app; try apply body'_to_body;
 try apply term'_to_term; apply lc_at_subst;
 try apply body_to_body'; try apply term_to_term'; trivial.
 apply body'_to_body. apply term_to_term' in H.
 apply lc_at_weaken_ind with (k1 := 0); trivial; omega.
 apply body'_to_body. apply term_to_term' in H.
 apply lc_at_weaken_ind with (k1 := 0); trivial; omega.
 simpl. unfold bswap. apply term_to_term' in H.
 rewrite subst_bswap_rec; trivial.
 simpl; apply reg_rule_lamb; try apply body'_to_body;
 try apply term'_to_term; apply lc_at_subst;
 try apply body_to_body'; try apply term_to_term'; trivial.
 apply body_to_body' in H0. unfold body' in H0.
 simpl in H0; trivial.
 apply lc_at_weaken_ind with (k1 := 0); trivial; omega.
 apply term'_to_term in H; trivial.
 simpl. unfold bswap. apply term_to_term' in H.
 rewrite subst_bswap_rec; trivial.
 simpl; apply reg_rule_comp.  apply body'_to_body.
 unfold body'. simpl. split. apply lc_at_subst.
 apply body_to_body' in H0. unfold body' in H0.
 simpl in H0. apply H0.
 apply lc_at_weaken_ind with (k1 := 0); trivial; omega.
 apply lc_at_subst.
 apply body_to_body' in H0. unfold body' in H0.
 simpl in H0. apply H0.
 apply lc_at_weaken_ind with (k1 := 0); trivial; omega.
 intro H3. apply H1. apply term'_to_term.
 apply term_to_term' in H3.
 apply lc_at_subst' with (u := u) (x := x); trivial.
 apply term'_to_term; apply lc_at_subst.
 apply term_to_term'; trivial. trivial.
Qed.

Lemma sys_Bx_red_out : red_out sys_Bx.
Proof.
 intros_all. destruct H0. induction H0.
 simpl. apply B_lx. apply reg_rule_b. apply body'_to_body;
 apply lc_at_subst; apply body_to_body'; trivial.
 apply term_is_a_body; trivial.
 apply term'_to_term; apply lc_at_subst; apply term_to_term';
 trivial. apply sys_x_lx. apply sys_x_red_out; trivial.
Qed.

Lemma ctx_sys_x_red_out : red_out (contextual_closure sys_x).
Proof.
 apply red_out_ctx.
 apply sys_x_red_out.
Qed.

Lemma ctx_sys_Bx_red_out : red_out (contextual_closure sys_Bx).
Proof.
 apply red_out_ctx.
 apply sys_Bx_red_out.
Qed.

Lemma ctx_sys_ex_red_out : red_out ex.
Proof.
 apply red_out_mod_eqC.
 apply sys_x_regular.
 apply sys_x_red_out.
Qed.

Lemma ctx_sys_lex_red_out : red_out lex.
Proof.
 apply red_out_mod_eqC.
 apply sys_Bx_regular.
 apply sys_Bx_red_out.
Qed.

Lemma ctx_sys_x_red_rename : red_rename (contextual_closure sys_x).
Proof.
 apply red_out_to_rename.
 apply ctx_sys_x_red_out.
Qed.

Lemma ctx_sys_Bx_red_rename : red_rename (contextual_closure sys_Bx).
Proof.
 apply red_out_to_rename.
 apply ctx_sys_Bx_red_out.
Qed.

Lemma ctx_sys_ex_red_rename : red_rename ex.
Proof.
 apply red_out_to_rename.
 apply ctx_sys_ex_red_out.
Qed.

Lemma ctx_sys_lex_red_rename : red_rename lex.
Proof.
 apply red_out_to_rename.
 apply ctx_sys_lex_red_out.
Qed.

Lemma trs_ex_red_rename: red_rename (trans_closure ex).
Proof.
 apply red_out_to_rename.
 apply red_out_trs.
 apply ctx_sys_ex_red_out.
Qed.

Lemma trs_lex_red_rename: red_rename (trans_closure lex).
Proof.
 apply red_out_to_rename.
 apply red_out_trs.
 apply ctx_sys_lex_red_out.
Qed.

Lemma sys_x_not_fv : red_not_fv sys_x.
Proof.
 unfold red_not_fv. intros x t t' H.
 induction H; simpl; intro H';
 apply notin_union in H'; try apply notin_union;
 try apply H'; try split; try apply notin_union; try apply H'.
 case H'; clear H'; intros H2 H3. apply notin_union in H2.
 split. apply H2. apply H3. split.
 case H'; clear H'; intros H2 H3. apply notin_union in H2.
 apply H2. apply H'. unfold bswap. rewrite fv_bswap_rec. apply H'.
 case H'; clear H'; intros H2 H3. apply notin_union in H2.
 split. unfold bswap. rewrite fv_bswap_rec. apply H2. apply H3.
 case H'; clear H'; intros H2 H3. apply notin_union in H2.
 split. apply H2. apply H3.
Qed.

Lemma sys_Bx_not_fv : red_not_fv sys_Bx.
Proof.
 unfold red_not_fv. intros x t t' H.
 induction H; simpl. destruct H; simpl.
 intro H'. apply notin_union in H'. apply notin_union.
 assumption. apply sys_x_not_fv; trivial.
Qed.

Lemma sys_x_fv : red_fv sys_x.
Proof.
 unfold red_fv. intros x t t' H.
 induction H; simpl.
 intro H'. apply in_union; right; trivial.
 intro H'. apply in_union; left; trivial.
 intro H'; apply in_union in H'; case H'; clear H';
 intro H'; apply in_union in H'; case H'; clear H';
 intro H'; apply in_union.
 left; apply in_union; left; trivial. right; trivial.
 left; apply in_union; right; trivial. right; trivial.
 intro H'; apply in_union in H'; case H'; clear H';
 intro H'; apply in_union. left. unfold bswap in H'.
 rewrite fv_bswap_rec in H'; trivial. right; trivial.
 intro H'; apply in_union in H'; case H'; clear H';
 intro H'; apply in_union in H'; case H'; clear H';
 intro H'; apply in_union. unfold bswap in H'.
 rewrite fv_bswap_rec in H'. left; apply in_union.
 left; trivial. right; trivial. left; apply in_union.
 right; trivial. right; trivial.
Qed.

Lemma sys_Bx_fv : red_fv sys_Bx.
Proof.
 unfold red_fv. intros x t t' H.
 destruct H. destruct H; simpl; trivial.
 apply sys_x_fv; trivial.
Qed.

Lemma ctx_sys_x_red_swap : red_swap (contextual_closure sys_x).
Proof.
 apply red_out_to_swap.
 apply ctx_sys_x_red_out.
Qed.

Lemma ctx_sys_Bx_red_swap : red_swap (contextual_closure sys_Bx).
Proof.
 apply red_out_to_swap.
 apply ctx_sys_Bx_red_out.
Qed.

Lemma ctx_sys_ex_red_swap : red_swap ex.
Proof.
 apply red_out_to_swap.
 apply ctx_sys_ex_red_out.
Qed.

Lemma ctx_sys_lex_red_swap : red_swap lex.
Proof.
 apply red_out_to_swap.
 apply ctx_sys_lex_red_out.
Qed.

Lemma trs_ex_red_swap: red_swap (trans_closure ex).
Proof.
 apply red_out_to_swap.
 apply red_out_trs.
 apply ctx_sys_ex_red_out.
Qed.

Lemma trs_lex_red_swap: red_swap (trans_closure lex).
Proof.
 apply red_out_to_swap.
 apply red_out_trs.
 apply ctx_sys_lex_red_out.
Qed.

(***************************************************)

Lemma left_app_ex: forall t u v, term t  ->
      u -->ex v -> pterm_app u t -->ex pterm_app v t.
Proof.
  intros; apply mod_eqC_app_left; trivial.
Qed.

Lemma left_trans_app_ex: forall t u v,  term t  ->
      u -->ex+ v -> pterm_app u t -->ex+ pterm_app v t.
Proof.
  intros; apply trs_mod_eqC_app_left; trivial.
Qed.

Lemma left_star_app_ex: forall t u v,  term t  ->
      u -->ex* v -> pterm_app u t -->ex* pterm_app v t.
Proof.
  intros; apply str_mod_eqC_app_left; trivial.
Qed.

Lemma right_app_ex: forall t u v, term t  ->
      u -->ex v -> pterm_app t u -->ex pterm_app t v.
Proof.
  intros; apply mod_eqC_app_right; trivial.
Qed.

Lemma right_trans_app_ex: forall t u v,  term t  ->
      u -->ex+ v -> pterm_app t u -->ex+ pterm_app t v.
Proof.
   intros; apply trs_mod_eqC_app_right; trivial.
Qed.

Lemma right_star_app_ex: forall t u v,  term t  ->
      u -->ex* v -> pterm_app t u -->ex* pterm_app t v.
Proof.
   intros; apply str_mod_eqC_app_right; trivial.
Qed.

Lemma in_abs_ex: forall L u v, (forall x, x \notin L -> (u ^ x) -->ex (v ^ x)) ->
  ((pterm_abs u) -->ex (pterm_abs v)).
Proof.
 intros; apply mod_eqC_abs_in with (L := L); trivial.
 apply sys_x_regular.
 apply sys_x_red_out.
Qed.

Lemma in_trans_abs_ex: forall L u v,  (forall x, x \notin L -> (u ^ x) -->ex+ (v ^ x)) ->
  ((pterm_abs u) -->ex+ (pterm_abs v)).
Proof.
 intros; apply trs_mod_eqC_abs_in with (L := L); trivial.
 apply sys_x_regular.
 apply sys_x_red_out.
Qed.

Lemma in_star_abs_ex: forall L u v,  (forall x, x \notin L -> (u ^ x) -->ex* (v ^ x)) ->
  ((pterm_abs u) -->ex* (pterm_abs v)).
Proof.
 intros; apply str_mod_eqC_abs_in with (L := L); trivial.
 apply sys_x_regular.
 apply sys_x_red_out.
Qed.

Lemma left_subst_ex: forall L t u v,  term t -> (forall x, x \notin L ->  (u ^ x) -->ex (v ^ x)) ->
  (u[t]) -->ex (v[t]).
Proof.
 intros; apply mod_eqC_subst_left with (L := L); trivial.
 apply sys_x_regular.
 apply sys_x_red_out.
Qed.

Lemma left_trans_subst_ex: forall L t u v,  term t -> (forall x, x \notin L ->  (u ^ x) -->ex+ (v ^ x)) ->
  (u[t]) -->ex+ (v[t]).
Proof.
 intros; apply trs_mod_eqC_subst_left with (L := L); trivial.
 apply sys_x_regular.
 apply sys_x_red_out.
Qed.

Lemma left_star_subst_ex: forall L t u v,  term t -> (forall x, x \notin L ->  (u ^ x) -->ex* (v ^ x)) ->
  (u[t]) -->ex* (v[t]).
Proof.
 intros; apply str_mod_eqC_subst_left with (L := L); trivial.
 apply sys_x_regular.
 apply sys_x_red_out.
Qed.

Lemma right_subst_ex: forall t u v,  body t ->
      u -->ex v -> (t[u]) -->ex (t[v]).
Proof.
 intros; apply mod_eqC_subst_right; trivial.
Qed.

Lemma right_trans_subst_ex: forall t u v,  body t ->
      u -->ex+ v -> (t[u]) -->ex+ (t[v]).
Proof.
 intros; apply trs_mod_eqC_subst_right; trivial.
Qed.

Lemma right_star_subst_ex: forall t u v,  body t ->
      u -->ex* v -> (t[u]) -->ex* (t[v]).
Proof.
 intros; apply str_mod_eqC_subst_right; trivial.
Qed.

Lemma left_app_lex: forall t u v, term t  ->
      u -->lex v -> pterm_app u t -->lex pterm_app v t.
Proof.
  intros; apply mod_eqC_app_left; trivial.
Qed.

Lemma left_trans_app_lex: forall t u v,  term t  ->
      u -->lex+ v -> pterm_app u t -->lex+ pterm_app v t.
Proof.
  intros; apply trs_mod_eqC_app_left; trivial.
Qed.

Lemma left_star_app_lex: forall t u v,  term t  ->
      u -->lex* v -> pterm_app u t -->lex* pterm_app v t.
Proof.
  intros; apply str_mod_eqC_app_left; trivial.
Qed.

Lemma right_app_lex: forall t u v, term t  ->
      u -->lex v -> pterm_app t u -->lex pterm_app t v.
Proof.
  intros; apply mod_eqC_app_right; trivial.
Qed.

Lemma right_trans_app_lex: forall t u v,  term t  ->
      u -->lex+ v -> pterm_app t u -->lex+ pterm_app t v.
Proof.
   intros; apply trs_mod_eqC_app_right; trivial.
Qed.

Lemma right_star_app_lex: forall t u v,  term t  ->
      u -->lex* v -> pterm_app t u -->lex* pterm_app t v.
Proof.
   intros; apply str_mod_eqC_app_right; trivial.
Qed.

Lemma in_abs_lex: forall L u v, (forall x, x \notin L -> (u ^ x) -->lex (v ^ x)) ->
  ((pterm_abs u) -->lex (pterm_abs v)).
Proof.
 intros; apply mod_eqC_abs_in with (L := L); trivial.
 apply sys_Bx_regular.
 apply sys_Bx_red_out.
Qed.

Lemma in_trans_abs_lex: forall L u v,  (forall x, x \notin L -> (u ^ x) -->lex+ (v ^ x)) ->
  ((pterm_abs u) -->lex+ (pterm_abs v)).
Proof.
 intros; apply trs_mod_eqC_abs_in with (L := L); trivial.
 apply sys_Bx_regular.
 apply sys_Bx_red_out.
Qed.

Lemma in_star_abs_lex: forall L u v,  (forall x, x \notin L -> (u ^ x) -->lex* (v ^ x)) ->
  ((pterm_abs u) -->lex* (pterm_abs v)).
Proof.
 intros; apply str_mod_eqC_abs_in with (L := L); trivial.
 apply sys_Bx_regular.
 apply sys_Bx_red_out.
Qed.

Lemma left_subst_lex: forall L t u v,  term t -> (forall x, x \notin L ->  (u ^ x) -->lex (v ^ x)) ->
  (u[t]) -->lex (v[t]).
Proof.
 intros; apply mod_eqC_subst_left with (L := L); trivial.
 apply sys_Bx_regular.
 apply sys_Bx_red_out.
Qed.

Lemma left_trans_subst_lex: forall L t u v,  term t -> (forall x, x \notin L ->  (u ^ x) -->lex+ (v ^ x)) ->
  (u[t]) -->lex+ (v[t]).
Proof.
 intros; apply trs_mod_eqC_subst_left with (L := L); trivial.
 apply sys_Bx_regular.
 apply sys_Bx_red_out.
Qed.

Lemma left_star_subst_lex: forall L t u v,  term t -> (forall x, x \notin L ->  (u ^ x) -->lex* (v ^ x)) ->
  (u[t]) -->lex* (v[t]).
Proof.
 intros; apply str_mod_eqC_subst_left with (L := L); trivial.
 apply sys_Bx_regular.
 apply sys_Bx_red_out.
Qed.

Lemma right_subst_lex: forall t u v,  body t ->
      u -->lex v -> (t[u]) -->lex (t[v]).
Proof.
 intros; apply mod_eqC_subst_right; trivial.
Qed.

Lemma right_trans_subst_lex: forall t u v,  body t ->
      u -->lex+ v -> (t[u]) -->lex+ (t[v]).
Proof.
 intros; apply trs_mod_eqC_subst_right; trivial.
Qed.

Lemma right_star_subst_lex: forall t u v,  body t ->
      u -->lex* v -> (t[u]) -->lex* (t[v]).
Proof.
 intros; apply str_mod_eqC_subst_right; trivial.
Qed.

Lemma ex_to_lex : forall t t', t -->ex t' -> t -->lex t'.
Proof.
 intros t t' H.
 case H; clear H. intros t0 H.
 case H; clear H. intros u0 H.
 destruct H. case H0; clear H0. intros H0 H1.
 exists t0 u0. split; trivial. split; trivial.
 apply contextual_R1_R2 with (R1 := sys_x); trivial.
 intros t1 t2 H'. apply sys_x_lx; trivial.
Qed.

Lemma trs_ex_to_lex : forall t t', t -->ex+ t' -> t -->lex+ t'.
Proof.
  apply trans_R1_R2. apply ex_to_lex.
Qed.

Lemma str_ex_to_lex : forall t t', t -->ex* t' -> t -->lex* t'.
Proof.
  apply star_R1_R2. apply ex_to_lex.
Qed.

(*** About NF Lex and SN lex ****)

Lemma left_m_app_lex : forall t t' lu, (term %% lu) ->
                       t -->lex t' -> (t // lu) -->lex (t' // lu).
Proof.
 intros t t' lu T H. induction lu; simpl; trivial.
 simpl in T. destruct T. apply left_app_lex; trivial.
 apply IHlu; trivial.
Qed.

Lemma left_trans_m_app_lex : forall t t' lu, (term %% lu) ->
                             t -->lex+ t' -> (t // lu) -->lex+ (t' // lu).
Proof.
 intros t t' lu T H. induction lu; simpl; trivial.
 simpl in T. destruct T. apply left_trans_app_lex; trivial.
 apply IHlu; trivial.
Qed.

Lemma lex_app : forall t u v, pterm_app u v -->lex t ->
                (exists t', u =e pterm_abs t' /\ t =e (t'[v])) \/
                (exists u', t =e pterm_app u' v /\  u -->lex u') \/
                (exists v', t =e pterm_app u v' /\  v -->lex v').
Proof.
 intros t u v H. case H; clear H; intros t0 H; case H; clear H; intros t1 H.
 destruct H; destruct H0. apply eqC_app_term in H.
 case H; clear H; intros u0 H; case H; clear H; intros v0 H.
 destruct H; destruct H2. rewrite <- H in H0. clear H t0.
 inversion H0. inversion H. inversion H6.
 left. exists t3. split. rewrite H9. rewrite H2. reflexivity.
 rewrite <- H3. rewrite H12. rewrite H1. reflexivity.
 inversion H6. right. left. exists t'. split. rewrite <- H3. rewrite H6. rewrite H1. reflexivity.
 rewrite <- H2. apply ctx_to_mod_eqC; trivial.
 right. right. exists u'. split. rewrite <- H2. rewrite H6. rewrite H1. reflexivity.
 rewrite <- H3. apply ctx_to_mod_eqC; trivial.
Qed.

Lemma lex_abs : forall t u, pterm_abs t -->lex u ->
                (exists L t', u =e pterm_abs t' /\ (forall x, x \notin L -> (t ^ x) -->lex (t' ^ x))).
Proof.
 intros t u H. case H; clear H; intros t0 H; case H; clear H; intros t1 H.
 destruct H; destruct H0. apply eqC_abs_term in H.
 case H; clear H; intros u0 H; case H; clear H; intros L H.
 destruct H. rewrite <- H in H0. clear H t0.
 inversion H0. inversion H. inversion H5. inversion H5.
 exists (L0 \u L). exists t'. split. rewrite <- H1. rewrite H4. reflexivity.
 intros x H5. apply notin_union in H5. destruct H5. rewrite <- H2; trivial.
 apply ctx_to_mod_eqC. apply H3; trivial.
Qed.

Lemma lex_R_list_regular : forall lt lt', R_list lex lt lt' -> (term %% lt <-> term %% lt').
Proof.
 intros lt lt' H. unfold R_list in H.
 case H; clear H; intros t H.
 case H; clear H; intros t' H.
 case H; clear H; intros l0 H.
 case H; clear H; intros l1 H.
 destruct H. destruct H0.
 rewrite H. rewrite H0. clear H H0.
 induction l0; simpl. apply ctx_sys_Bex_regular in H1. split.
 intro H2. split. apply H1. apply H2.
 intro H2. split. apply H1. apply H2. split.
 intro H2. split. apply H2. apply IHl0. apply H2.
 intro H2. split. apply H2. apply IHl0. apply H2.
Qed.

(** NF lex Properties **)

Lemma NF_eqC : forall t t', t =e t' -> NF lex t -> NF lex t'.
Proof.
 intros t t'. intros. unfold NF in *|-*.
 intros t1 H1. rewrite <- H in H1.
 apply (H0 t1); trivial.
Qed.

Lemma NF_fvar : forall x, NF lex (pterm_fvar x).
Proof.
 intros x t H'.
 case H'; clear H'.
 intros t0 H0. case H0; clear H0.
 intros t1 H1. destruct H1. destruct H0.
 assert (Q : pterm_fvar x = t0).
  clear H0 H1 t1. gen_eq t1 : (pterm_fvar x).
  intro H1. induction H. rewrite H1. rewrite H1 in H.
  inversion H; trivial. clear H H1 H2 H3 s t0. inversion H0; trivial.
  rewrite IHtrans_closure in H. rewrite H1. rewrite H1 in H. inversion H.
  inversion H2; trivial. rewrite H1 in H. symmetry. inversion H. inversion H2; trivial.
 rewrite <- Q in H0. inversion H0. inversion H2. inversion H5. inversion H5.
Qed.

Lemma NF_app_lex : forall t u v, NF lex u -> NF lex v -> (pterm_app u v -->lex t) ->
               exists t', u =e pterm_abs t' /\ t =e (t'[v]).
Proof.
 intros t u v NFu NFv H. apply lex_app in H. case H; clear H; intro H.
 case H; clear H; intros t' H. exists t'; trivial.
 case H; clear H; intro H; case H; clear H; intros t' H; destruct H.
 assert (Q : ~ u -->lex t'). apply (NFu t'). contradiction.
 assert (Q : ~ v -->lex t'). apply (NFv t'). contradiction.
Qed.

Lemma NF_app_lex_eq : forall t u v, NF lex u -> NF lex v -> (pterm_app u v -->lex t) ->
               exists t' t'' v', u = pterm_abs t' /\ t = (t''[v']).
Proof.
 intros t u v NFu NFv H. apply NF_app_lex in H; trivial.
 case H; clear H. intros t' H. destruct H.
 apply eqC_sym in H. apply eqC_abs_term in H.
 apply eqC_sym in H0. apply eqC_sub_term in H0.
 case H; clear H. intros t1 H. case H; clear H. intros L H. destruct H.
 case H0; clear H0. intros t1' H0. case H0; clear H0. intros u' H0.
 exists t1 t1' u'. split. rewrite H. reflexivity. rewrite H0. reflexivity.
Qed.

Lemma NF_mult_app_var : forall x lt, NF lex %% lt -> NF lex ((pterm_fvar x) // lt).
Proof.
 intros x lt H.
 induction lt; simpl in *|-*. apply NF_fvar.
 destruct H. assert (Q : NF lex (pterm_fvar x // lt)). apply IHlt; trivial.
 clear IHlt. unfold NF. intros t' H'. case eqdec_nil with (l := lt). intro H''.
 rewrite H'' in H'. simpl in H'.
 apply NF_app_lex_eq in H'; trivial. case H'; clear H'. intros t0 H'.
 case H'; clear H'. intros t0' H'. case H'; clear H'. intros v' H'.
 destruct H'. inversion H1.
 apply NF_fvar. intro H''.
 assert (Q' : exists t' u', (pterm_fvar x) // lt = pterm_app t' u').
  apply m_app_eq_app; trivial.
 case Q'; clear Q'. intros u H1. case H1; clear H1. intros v H1.
 rewrite H1 in H'. apply NF_app_lex_eq in H'; trivial.
 case H'; clear H'. intros t0 H'. case H'; clear H'. intros t0' H'.
 case H'; clear H'. intros v' H'.
 destruct H'. inversion H2; trivial.
 rewrite <- H1; trivial.
Qed.

Lemma lex_abs_not_NF : forall l t, l <> nil -> term (pterm_abs t // l) -> ~ NF lex (pterm_abs t // l).
Proof.
 intros. induction l. intro H'. apply H; trivial.
 simpl in *|-*. case eqdec_nil with (l := l). intro H'.
 rewrite H' in *|-*. simpl in *|-*. intro H1.
 apply (H1 (t[a])). apply ctx_to_mod_eqC. apply redex.
 apply B_lx. apply term_distribute_over_application in H0.
 destruct H0. apply term_abs_to_body in H0. apply reg_rule_b; trivial.
 intro H'. apply term_distribute_over_application in H0. destruct H0.
 assert (Q : ~ NF lex (pterm_abs t // l)).
   apply IHl; trivial.
 clear IHl H'. intro H'. apply Q. intros t' H2.
 apply (H' (pterm_app t' a)). apply left_app_lex; trivial.
Qed.

Lemma lex_sub_not_NF : forall x t u, body t -> term u -> x \notin (fv t) ->
      ~ NF lex (t ^ x) -> ~ NF lex (t[u]).
Proof.
 intros. intro H3. apply H2. clear H2.
 intros t0 H2. gen_eq t1 : (close t0 x). intro H4.
 replace t0 with (t1 ^ x) in H2. apply (H3 (t1 [u])).
 apply left_subst_lex with (L:= (fv t) \u (fv t1)); trivial.
 intros z Fr. apply notin_union in Fr. destruct Fr.
 apply ctx_sys_lex_red_rename with (x := x); trivial.
 rewrite H4. apply fv_close'. rewrite H4.
 rewrite open_close_var with (x := x); trivial.
 apply ctx_sys_Bex_regular in H2. apply H2.
Qed.

Lemma lex_sub_not_NF' : forall t u, body t -> term u -> ~ NF lex (t[u]).
Proof.
  intros. apply body_size_induction with (t := t); trivial; intros; intro H'.
  apply (H' u). apply ctx_to_mod_eqC. apply redex. apply sys_x_lx. apply reg_rule_var; trivial.
  apply (H' (pterm_fvar x)). apply ctx_to_mod_eqC. apply redex. apply sys_x_lx. apply reg_rule_gc; trivial.
  apply (H' (pterm_abs ((& t1)[u]))). apply ctx_to_mod_eqC. apply redex. apply sys_x_lx. apply reg_rule_lamb; trivial.
  rewrite body_eq_body'; unfold body'. simpl; trivial.
  apply (H' (pterm_app (t1[u]) (t2[u]))). apply ctx_to_mod_eqC. apply redex. apply sys_x_lx. apply reg_rule_app; trivial;
  rewrite body_eq_body' in *|-*; unfold body' in *|-*; simpl in *|-*; apply H2.
  case var_fresh with (L := fv t3).
  intros x Hx. case fv_in_or_notin with (t := t3 ^ x) (x := x); intros.
  apply (H' ((& t1)[u][ t3[ u ] ])). apply ctx_to_mod_eqC. apply redex. apply sys_x_lx. apply reg_rule_comp; trivial.
  rewrite body_eq_body' in *|-*; unfold body' in *|-*; simpl in *|-*; split; trivial.
  rewrite term_eq_term'. unfold term'. apply not_body_term_fvar with (x := x); trivial.
  rewrite body_eq_body' in H2. unfold body' in H2. trivial.
  assert (T : term t3).
    rewrite term_eq_term'; simpl. unfold term'.
    rewrite body_eq_body' in *|-; unfold body' in *|-.
    apply body_term_fvar with (x := x); trivial.
  clear x Hx H2 H5. rewrite eqC_redex in H'; trivial.
  generalize H'. case var_fresh with (L := fv ((& t1)[u])).
  intros x Fr. apply lex_sub_not_NF with (x := x); trivial.
  rewrite body_eq_body'. unfold body'. simpl.
  split. apply lc_at_bswap; try omega; trivial.
  rewrite <- body_eq_body'. apply term_is_a_body; trivial.
  unfold open. unfold bswap. simpl.
  replace (open_rec 0 (pterm_fvar x) u) with u.
  apply H4.
  simpl in Fr. apply notin_union in Fr. apply Fr.
  rewrite size_bswap_rec; trivial.
  rewrite body_eq_body'. unfold body'.
  rewrite <- lc_at_open with (u := pterm_fvar x); trivial.
  apply lc_at_bswap; try omega; trivial.
  rewrite open_lc_at; trivial.
  rewrite <- term_eq_term'; trivial.
Qed.

(** Inversion of the lex relation **)

Lemma lex_app_var : forall x t u, pterm_app (pterm_fvar x) t -->lex u ->
                    exists t', u =e pterm_app (pterm_fvar x) t' /\ t -->lex t'.
Proof.
 intros x t u H. apply lex_app in H.
 case H; clear H; intro H; case H; clear H.
 intros t' H. destruct H. apply eqC_fvar_term in H. apply False_ind.
 generalize H. discriminate.
 intro H; case H; clear H. intros t' H. destruct H. apply False_ind.
 generalize H0. apply NF_fvar.
 intro H; case H; clear H. intros t' H. exists t'; trivial.
Qed.

Lemma lex_mult_app_var : forall x lt u, ((pterm_fvar x) // lt) -->lex u ->
                        exists lt', u =e ((pterm_fvar x) // lt') /\ R_list lex lt lt'.
Proof.
 intros x lt. induction lt; simpl.
 intros u H. apply False_ind. generalize H. apply NF_fvar.
 intros u H. apply lex_app in H. case H; clear H; intro H.
 case H; clear H; intros t' H. destruct H. gen_eq t0 : (pterm_abs t').
 intro H'. case eqdec_nil with (l := lt). intro H''. rewrite H'' in H. simpl in H.
 apply eqC_fvar_term in H. rewrite H' in H. apply False_ind. generalize H. discriminate.
 intro H''. case m_app_eq_app with (t := (pterm_fvar x)) (lu := lt); trivial. intros u0 H1.
 case H1; clear H1; intros v0 H1. rewrite H1 in H. apply eqC_app_term in H.
 case H; clear H; intros u' H. case H; clear H; intros v' H. destruct H. destruct H2.
 rewrite H' in H. apply False_ind. generalize H. discriminate.
 case H; clear H; intro H; case H; clear H. intros t' H. destruct H.
 case eqdec_nil with (l := lt). intro H1. rewrite H1 in H0. simpl in H0. apply False_ind.
 generalize H0. apply NF_fvar. intro H1. case (IHlt t'); trivial. intros lt' Hlt'.
 destruct Hlt'. exists (a :: lt'). split. simpl. rewrite H. rewrite H2. reflexivity.
 unfold R_list. unfold R_list in H3. case H3; clear H3; intros t0 H3.
 case H3; clear H3; intros t1 H3. case H3; clear H3; intros l0 H3.
 case H3; clear H3; intros l1 H3. destruct H3. destruct H4.
 exists t0 t1. exists (a :: l0) l1. split. rewrite H3. simpl. reflexivity.
 split. rewrite H4. simpl. reflexivity. trivial.
 intros a' H. destruct H. exists (a' :: lt). simpl. split; trivial.
 unfold R_list. exists a a'. exists (nil (A:=pterm)) lt. simpl. split.
 reflexivity. split; trivial.
Qed.

Lemma lex_mult_app_B : forall t t0 u lv, ((pterm_app (pterm_abs t) u) // lv) -->lex t0 ->
                       (t0 =e ((t[u]) // lv)) \/
                       (exists L t', t0 =e ((pterm_app (pterm_abs t') u) // lv) /\
                       (forall x, x \notin L -> (t ^ x) -->lex (t' ^ x))) \/
                       (exists u', t0 =e ((pterm_app (pterm_abs t) u') // lv) /\
                       (u -->lex u')) \/
                       (exists lv',  t0 =e ((pterm_app (pterm_abs t) u) // lv') /\
                       (R_list lex lv lv')).
Proof.
 intros t t0 u lv H.  generalize t t0 u H. clear t t0 u H.  induction lv.
 simpl. intros. generalize H. intro H'. apply lex_app in H.
 case H; clear H; intro H; case H; clear H.
 intros t' H. destruct H. left.
 apply eqC_abs_term in H.
 case H; clear H; intros t1 H; case H; clear H; intros L H.
 destruct H. assert (Q : t1 = t'). inversion H. reflexivity.
 apply ctx_sys_Bex_regular in H'. destruct H'. rewrite H0 in H3.
 rewrite <- Q in H3. apply subs_to_body in H3. destruct H3.
 rewrite H0. rewrite <- Q. apply eqC_subst_left with (L := L); trivial.
 intro H. case H; clear H; intros t1 H. destruct H.
 right. left. apply lex_abs in H0.
 case H0; clear H0; intros L H0; case H0; clear H0; intros t2 H0.
 destruct H0. rewrite H0 in H. exists L t2. split; trivial.
 intro H. case H; clear H; intros v H. destruct H.
 right. right. left. exists v. split; trivial.
 simpl. intros. generalize H. intro H'. apply lex_app in H.
 case H; clear H; intro H; case H; clear H.
 intros t1 H1. destruct H1. case eqdec_nil with (l := lv).
 intro H1. rewrite H1 in H. simpl in H. apply eqC_app_term in H.
 case H; clear H; intros u' H. case H; clear H; intros v' H.
 destruct H. apply False_ind. generalize H. discriminate.
 intro H1. case m_app_eq_app with (t := pterm_app (pterm_abs t) u) (lu := lv); trivial.
 intros u0 H2. case H2; clear H2. intros v0 H2. rewrite H2 in H.
 apply eqC_app_term in H.
 case H; clear H; intros u' H. case H; clear H; intros v' H.
 destruct H. apply False_ind. generalize H. discriminate.
 intro H. case H; clear H; intros u' H. destruct H.
 case (IHlv t u' u); clear IHlv; trivial. intro H1.
 left. rewrite H. rewrite H1. reflexivity. intro H1.
 case H1; clear H1; intro H1.
 case H1; clear H1; intros L H1; case H1; clear H1; intros t' H1.
 destruct H1. right. left. exists L t'. split; trivial.
 rewrite H. rewrite H1. reflexivity. case H1; clear H1; intro H1.
 case H1; clear H1; intros u0 H1. destruct H1.
 right. right. left. exists u0. split; trivial.
 rewrite H. rewrite H1. reflexivity.
 case H1; clear H1; intros lv' H1. destruct H1.
 right. right. right. exists (a :: lv'). split. simpl.
 rewrite H. rewrite H1. reflexivity. unfold R_list in H2.
 case H2; clear H2; intros t1 H2. case H2; clear H2; intros t2 H2.
 case H2; clear H2; intros l0 H2. case H2; clear H2; intros l1 H2.
 destruct H2. destruct H3. unfold R_list. exists t1 t2.
 rewrite H2. rewrite H3. exists (a :: l0) l1. split; trivial. split; trivial.
 intro H. case H; clear H; intros a' H. destruct H.
 right. right. right. exists (a' :: lv). simpl. split.
 rewrite H. reflexivity. unfold R_list. exists a a'.
 exists (nil (A:=pterm)) lv; simpl.
 split; trivial. split; trivial.
Qed.

(** SN lex Properties **)

Lemma SN_app_var : forall x t, SN lex t -> SN lex (pterm_app (pterm_fvar x) t).
Proof.
 intros x t H. case H; clear H. intros n H. exists n. generalize t H; clear t H.
 induction n. intros t H. rewrite <- NF_eq_SN0 in *|-*.
 replace (pterm_app (pterm_fvar x) t) with ((pterm_fvar x) // (t :: nil)).
 apply NF_mult_app_var. simpl; split; trivial. simpl; trivial.
 intros t H. inversion H. apply SN_intro. intros u H'.
 apply lex_app_var in H'. case H'; clear H'; intros t' H'.
 destruct H'. case (H0 t'); clear H0; trivial. intros k H0.
 destruct H0. exists n; split; try omega. rewrite H1. apply IHn.
 apply WSN with (k := k); try omega; trivial.
Qed.

Lemma SN_mult_app_var : forall x lt, term %% lt -> SN lex %% lt -> SN lex ((pterm_fvar x) // lt).
Proof.
 intros x lt T H. induction lt; simpl. exists 0. rewrite <- NF_eq_SN0. apply NF_fvar.
 simpl in *|-*. destruct T. destruct H. assert (H': SN lex (pterm_fvar x // lt)). apply IHlt; trivial. clear H2 IHlt.
 case H; clear H. intros n H. case H'; clear H'. intros n' H'.
 gen_eq k : (n + n'). intro Hk. exists k. generalize a lt n n'  H0 H1 H H' Hk. clear a lt n n' H0 H1 H H' Hk.
 induction k. intros.
 assert (Qn : n = 0). symmetry in Hk. omega.
 assert (Qn': n' = 0). symmetry in Hk. omega. clear Hk.
 rewrite Qn in H. rewrite Qn' in H'. clear Qn Qn'.
 rewrite <- NF_eq_SN0 in *|-*.
 replace (pterm_app (pterm_fvar x // lt) a) with ((pterm_fvar x) // (a :: lt)).
 apply NF_mult_app_var. simpl. split; trivial. clear a n n' H0 H.
 induction lt; simpl in *|-*; trivial. split. intros a' Ha'.
 apply (H' (pterm_app (pterm_fvar x // lt) a')).
 apply right_app_lex; trivial. rewrite term_mult_app. destruct H1. split; trivial.
 apply IHlt. apply H1. intros t' Ht'. apply (H' (pterm_app t' a)).
 apply left_app_lex; trivial. apply H1. simpl; trivial.
 intros. apply SN_intro. intros t' Ht'. inversion H. inversion H'.
 apply lex_app in Ht'. case Ht'; clear Ht'. intro Ht'. case Ht'; clear Ht'. intros u Ht'. destruct Ht'.
 case eqdec_nil with (l := lt). intro H6. rewrite H6 in H4. simpl in H4. apply eqC_fvar_term in H4. apply False_ind.
 generalize H4. discriminate. intro H6. case m_app_eq_app with (t := (pterm_fvar x)) (lu := lt); trivial.
 intros u0 H7. case H7; clear H7. intros v0 H7. rewrite H7 in H4. apply eqC_app_term in H4.
 case H4; clear H4. intros u' H4. case H4; clear H4. intros v' H4. destruct H4. apply False_ind.
 generalize H4. discriminate.
 intro H4. case H4; clear H4. intro H4. case H4; clear H4; intros u H4. destruct H4.
 case (H3 u); trivial; clear H3. intros k' H3. destruct H3. exists k. split; try omega.
 rewrite H4. apply lex_mult_app_var in H5. case H5; clear H5. intros lt' H5. destruct H5. rewrite H5.
 apply IHk with (n := n) (n' := n' - 1); trivial. apply lex_R_list_regular in H7. apply H7; trivial.
 apply WSN with (k := k'); try omega. rewrite <- H5; trivial. omega.
 intro H4. case H4; clear H4. intros a' H4. destruct H4. exists k; split; try omega.
 case (H2 a'); clear H2; trivial. intros k' H2. destruct H2. rewrite H4.
 apply IHk with (n := n - 1) (n' := n'); trivial. apply ctx_sys_Bex_regular in H5. apply H5.
 apply WSN with (k := k'); try omega; trivial. omega.
Qed.

Lemma lex_SN_abs : forall n L t, (forall x, x \notin L -> SN_ind n lex (t ^ x)) ->
                                 (SN_ind n lex (pterm_abs t)).
Proof.
 intros n L t. generalize t; clear t. induction n.
 intros. rewrite <- NF_eq_SN0. setoid_rewrite <- NF_eq_SN0 in H.
 intros t' H'. apply lex_abs in H'. case H'; clear H'; intros L0 H'. case H'; clear H'; intros t0 H'.
 destruct H'. pick_fresh x. apply notin_union in Fr. destruct Fr. apply notin_union in H2. destruct H2.
 apply notin_union in H2. destruct H2. apply notin_union in H2. destruct H2.
 case H with (x := x) (t' := (t0 ^ x)); trivial. apply H1; trivial.
 intros t H. apply SN_intro. intros t' H'. exists n; split; try omega.
 apply lex_abs in H'. case H'; clear H'; intros L0 H'. case H'; clear H'; intros t0 H'.
 destruct H'. pick_fresh x. apply notin_union in Fr. destruct Fr. apply notin_union in H2. destruct H2.
 apply notin_union in H2. destruct H2. apply notin_union in H2. destruct H2.  apply notin_union in H2. destruct H2.
 rewrite H0. apply IHn. intros x' H8. destruct (H x'); trivial. case (H9 (t0 ^ x')).
 apply ctx_sys_lex_red_rename with (x := x); trivial. apply H1; trivial.
 intros k H10. destruct H10. apply WSN with (k := k); try omega; trivial.
Qed.

Lemma lex_SN_ind_rename : forall n x x' t, body t -> x' \notin ({{x}} \u (fv t)) -> SN_ind n lex (t ^ x) -> SN_ind n lex (t ^ x').
Proof.
 intros n x x' t B Fr H. apply notin_union in Fr; destruct Fr. apply notin_singleton in H0.
 generalize t B H0 H1 H. clear t B H0 H1 H. induction n.
 intros t B H0 H1 H. rewrite <- NF_eq_SN0 in *|-*.
 intros t' H'. gen_eq t0 : (close t' x'). intro H2.
 replace t' with (t0 ^ x') in H'. apply (H (t0 ^x)). apply ctx_sys_lex_red_rename with (x := x'); trivial.
 rewrite H2. apply fv_close'. rewrite H2. rewrite open_close_var with (x := x'). reflexivity.
 apply ctx_sys_Bex_regular in H'. apply H'. intros t B H0 H1 H. destruct H.
 apply SN_intro. intros t' H'. exists n; split; try omega. gen_eq t0 : (close t' x'). intro H2.
 generalize H'. intro T. apply ctx_sys_Bex_regular in T. destruct T.
 replace t' with (t0 ^ x') in H'. case (H (t0 ^ x)); clear H. apply ctx_sys_lex_red_rename with (x := x'); trivial.
 rewrite H2. apply fv_close'. intros k H. destruct H.  replace t' with (t0 ^ x'). apply (IHn t0); trivial.
 apply ctx_sys_Bex_regular in H'. destruct H'. rewrite term_eq_term' in H7. unfold term' in H7. unfold open in H7.
 rewrite body_eq_body'. unfold body'. rewrite lc_at_open with (u := pterm_fvar x'); trivial.
 rewrite H2. apply fv_close'. apply WSN with (k := k); try omega; trivial.
 rewrite H2; rewrite open_close_var with (x := x'); try reflexivity; trivial.
 rewrite H2; rewrite open_close_var with (x := x'); try reflexivity; trivial.
Qed.

Lemma lex_SN_rename :  forall x x' t, body t -> x' \notin ({{x}} \u (fv t)) -> SN lex (t ^ x) -> SN lex (t ^ x').
Proof.
 intros. case H1; clear H1; intros n H1; exists n; apply lex_SN_ind_rename with (x := x); trivial.
Qed.

Lemma lex_SN_ind_swap : forall n x y t, SN_ind n lex t -> SN_ind n lex ([(x,y)]t).
Proof.
 intros. generalize t H. clear t H. induction n.
 intros. rewrite <- NF_eq_SN0 in *|-*. intros t' H'.
 apply (H ([(x,y)]t')). rewrite <- swap_inv with (t := t) (x := x) (y := y).
 apply ctx_sys_lex_red_swap; trivial.
 intros. inversion H. clear H. apply SN_intro. intros t' H'.
 rewrite <- swap_inv with (t := t') (x := x) (y := y).
 case (H0 ([(x, y)]t')). rewrite <- swap_inv with (t := t) (x := x) (y := y).
 apply ctx_sys_lex_red_swap; trivial.
 intros k H. destruct H. exists n; split; try omega.  apply IHn; trivial.
 apply WSN with (k := k); try omega; trivial.
Qed.

Lemma lex_SN_swap : forall x y t, SN lex t -> SN lex ([(x,y)]t).
Proof. intros; case H; clear H; intros n H; exists n; apply lex_SN_ind_swap; trivial. Qed.


(* Solution to TPPMark 2019 by Keisuke Nakano *)

From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.

Infix "∺" := rcons (at level 60).

Lemma mem_cat_first {T:eqType} (x:T) (s:seq T):
  x \in s -> exists s1 s2, (x \notin s1) && (s == s1 ++ x :: s2).
Proof.
  elim s=>//; move:s=>_ y s IH.
  case:(eqVneq x y)=>[->_//=|/negP nxy].
  -{ by exists[::], s=>/=. }
  -{ rewrite in_cons=>/orP[]///IH[s1][s2]/andP[nxs1]/eqP->; exists(y::s1),s2=>//=.
     by apply/andP; split; rewrite//in_cons; move:nxy=>/negP?; apply/norP; split. }
Qed.

(* Configuration *)
Section Config.
  Context {Q Σ: finType}.

  Record config: Type := {
    _state : Q      ; (* current state *)
    _tape  : seq Σ ; (* circular tape as a list whose head is pointed *)
  }.
  (* [config] as [eqType] *)
  Definition config_val c := (_state c, _tape c).
  Lemma config_val_inj: injective config_val.
  Proof. by do 2 case => ? ?; injection 1=>->->. Qed.
  Canonical config_eqType := EqType config (InjEqMixin config_val_inj).
End Config.

Notation "{ q @ tape }" := ({| _state := q ; _tape := tape |}) (at level 2).

(* Directionn of the head *)
Section Direction.
  Inductive direction: Type := stay | movL | movR.

  (* [direction] as [eqType] *)
  Definition direction_val d := match d with stay => 0 | movL => 1 | movR => 2 end.
  Lemma direction_val_inj: injective direction_val. Proof. by do 2 case. Qed.
  Canonical direction_eqType := EqType direction (InjEqMixin direction_val_inj).
End Direction.

Section Base.
  Context {Q Σ: finType}.

  (* (Non-determistic) transition *)
  Section Transition.
    Definition transition := Q -> Σ -> Q -> Σ -> direction -> Prop.

    Variable δ: transition.

    Section Step.
      (* A step induced by transition *)
      Inductive step: config -> config -> Prop :=
      | step_stay q1 s1 q2 s2 tape:
          δ q1 s1 q2 s2 stay -> step { q1 @ s1::tape } { q2 @ s2::tape }
      | step_left q1 s1  q2 s2 tape:
          δ q1 s1 q2 s2 movL -> step { q1 @ s1::tape } { q2 @ rotr 1 (s2::tape) }
      | step_right q1 s1 q2 s2 tape:
          δ q1 s1 q2 s2 movR -> step { q1 @ s1::tape } { q2 @ rot 1 (s2::tape) }.

      (* Reflexive transitive closure of step *)
      Inductive many_steps: nat -> config -> config -> Prop :=
      | ms_self c: many_steps 0 c c
      | ms_more n c1 c2 c3:
          step c1 c2 -> many_steps n c2 c3 -> many_steps n.+1 c1 c3.

      Lemma many_steps_trans n m c1 c2 c3:
        many_steps n c1 c2 -> many_steps m c2 c3 -> many_steps (n+m) c1 c3.
      Proof.
        move:c1; elim n.
        -{ by move=>?; inversion 1. }
        -{ move:n=>_ n IH ?; rewrite addSn; inversion 1 as[|????? ms02].
           move/(IH _ ms02); econstructor; eassumption. }
      Qed.

      Lemma many_steps_last n c1 c2 c3:
        many_steps n c1 c2 -> step c2 c3 -> many_steps n.+1 c1 c3.
      Proof.
        rewrite-addn1; move=>c1c2 ?; apply/(many_steps_trans c1c2).
        by econstructor; [eassumption|constructor].
      Qed.

      Lemma many_steps_inv n m c1 c2:
        n < m -> many_steps m c1 c2 ->
      exists c, many_steps n c1 c /\ many_steps (m-n) c c2.
      Proof.
        move:m c1; elim n=>//=.
        -{ by move=>m c1 _ ?; exists c1; rewrite subn0; split; [constructor|]. }
        -{ move:n=>_ n IH [|m]// c1 ltnm; inversion 1 as[|????? ms32].
           move:{IH}(IH _ _ ltnm ms32)=>[c][].
           exists c; split; [econstructor; eassumption|assumption]. }
      Qed.

      Lemma size_many_steps n c1 c2:
        many_steps n c1 c2 -> size(_tape c1) == size(_tape c2).
      Proof.
        move: c1; elim n.
        -{ by move=>?; inversion 1. }
        -{ by move:n=>_ n IH ?; inversion 1 as [|???? [] ms02];
              move:(IH _ ms02)=>/eqP<-/=; rewrite?size_rotr?size_rot/=. }
      Qed.
    End Step.

    Section Determinism.
      Definition δ_deterministic :=
        forall q s q1 s1 d1 q2 s2 d2,
          δ q s q1 s1 d1 -> δ q s q2 s2 d2 -> (q1==q2) && (s1==s2) && (d1==d2).

      Variable det: δ_deterministic.

      Lemma det_many_steps n c c1 c2:
        many_steps n c c1 -> many_steps n c c2 -> c1 == c2.
      Proof.
        move:c; elim n.
        -{ by move=>c; do 2 inversion 1. }
        -{ move:n=>_ n IH; inversion_clear 1 as[|?? c3? st3 ms31];
             inversion 1 as[|?? c4? st4 ms42]; move:ms31 ms42.
           rewrite(_:c3=c4); first apply IH.
           by move:st3 st4; inversion 1 as[????? d3|????? d3|????? d3];
              inversion 1 as[????? d4|????? d4|????? d4];
              move:(det d3 d4)=>/andP[/andP[/eqP->/eqP->]/eqP]. }
      Qed.

      Definition no_more_step c := forall c1, ~ step c c1.
      Definition run_to_stop n c1 c2 := many_steps n c1 c2 /\ no_more_step c2.

      Lemma det_stop c n1 c1 n2 c2:
        run_to_stop n1 c c1 -> run_to_stop n2 c c2 -> (n1 == n2) && (c1 == c2).           Proof.
        wlog: n1 n2 c1 c2 / n1<= n2. {
          case_eq(n1<=n2)=>le12; first by apply.
          have:n2<=n1 by move:le12=>/negP/negP; rewrite-ltnNge; apply ltnW.
          move=>le21 H r1 r2; move:(H _ _ _ _ le21 r2 r1)=>/andP[]/eqP->/eqP->.
          by apply/andP. }
        rewrite leq_eqVlt=>/orP[/eqP->|lt12][ms1 ns1][ms2 ns2].
        -{ by move:(det_many_steps ms2 ms1)=>/eqP->; apply/andP=>[]. }
        -{ move:(many_steps_inv lt12 ms2)=>[c0][ms0 ms12]; exfalso.
           move:(det_many_steps ms1 ms0)lt12 ms12=>/eqP E; subst.
           rewrite-subn_gt0; move:(n2-n1)=>[|k]//_; inversion 1.
           eapply ns1; eassumption. }
      Qed.
    End Determinism.

  End Transition.

End Base.

(* Definition of cyclic turing machines *)
Record cyclicTM: Type := {
  Q: finType;			(* set of states *)
  Σ: finType;			(* set of symbols *)
  δ:> @transition Q Σ;	(* transition (which TM itself will be used as) *)
  q0: Q;			(* initial state *)
  qf: Q;			(* final state and its condition *)
  input_tape: seq Σ;		(* initial tape *)
}.
Arguments input_tape: clear implicits.

Section Run.

  Variable M: cyclicTM.

  Inductive reachable n: config -> Prop :=
  | reachable_to c:
      many_steps M n { q0 M @ input_tape M } c -> reachable n c.

  Definition run n tape: Prop := reachable n { qf M @ tape }.
  Definition terminating: Prop := exists n0, forall n c, n0 < n -> ~ reachable n c.
  Definition no_stuck: Prop :=
    forall n c, reachable n c -> no_more_step M c -> _state c == qf M.
  Definition deterministic := δ_deterministic M.

End Run.

Arguments run: clear implicits.
Arguments reachable: clear implicits.

(* **** Solution **** *)
Section SolutionMachine.

  (* set of states *)
  Section States.

    Inductive Q_zc:Type := q_in | q_fn | q_pr | q_cl | q_bk | q_ck.

    Section Embedding.
      Definition q2ord (q:Q_zc): 'I_6.
        by apply Ordinal with
            (match q with q_in=>0|q_fn=>1|q_pr=>2|q_cl=>3|q_bk=>4|q_ck=>5 end);
           case q.
      Defined.
      Definition ord2q (o:'I_6): Q_zc.
        by case o=>m ltm6;
           apply(match m with 0=>q_in|1=>q_fn|2=>q_pr|3=>q_cl|4=>q_bk|_=>q_ck end).
      Defined.
      Definition q_cancel: cancel q2ord ord2q. by case. Defined.
    End Embedding.

    (* to be eqType and finType *)
    Definition q_eq q1 q2 := q2ord q1 == q2ord q2.
    Definition q_eqP: Equality.axiom q_eq. by do 2 case; constructor. Defined.
    Canonical Q_zc_eqType     := EqType Q_zc (EqMixin q_eqP).
    Canonical Q_zc_choiceType := ChoiceType Q_zc (CanChoiceMixin q_cancel).
    Canonical Q_zc_countType  := CountType Q_zc (CanCountMixin q_cancel).
    Canonical Q_zc_finType    := FinType Q_zc (CanFinMixin q_cancel).
  End States.

  (* [zc_card]: the number of symbols.
   * From the problem description, we assume that at least two symbols:
   *   _0 [zero] for zero clear;
   *   _1 [one]  for one of the symbols other than zero.
   * Otherwise, problem becomes meaningless. *)
  Parameter (zc_card:nat) (zc_ax: 1 < zc_card).

  Section Symbols.
    Definition Σ_zc: predArgType := 'I_zc_card.
    Definition _0: Σ_zc. by apply Ordinal with 0; move:zc_ax; auto. Defined.
    Definition _1: Σ_zc. by apply Ordinal with 1; move:zc_ax; auto. Defined.
  End Symbols.

  Section Transition.
    Inductive δ_zc: transition :=
    | δ_zc_init s:		δ_zc q_in  s q_pr _1 movR
    | δ_zc_start s:		δ_zc q_pr  s q_cl _0 movR
    | δ_zc_found:		δ_zc q_cl _1 q_bk _0 movL
    | δ_zc_clear s: s != _1 ->	δ_zc q_cl  s q_cl _1 movR
    | δ_zc_back:		δ_zc q_bk _1 q_bk _0 movL
    | δ_zc_check:		δ_zc q_bk _0 q_ck _0 movL
    | δ_zc_done:		δ_zc q_ck _0 q_fn _0 stay
    | δ_zc_notyet:		δ_zc q_ck _1 q_pr _1 movR.
  End Transition.

  (* definition of zero-clear cyclic Turing machine *)
  Definition zero_clear_CTM tape0: cyclicTM := Build_cyclicTM δ_zc q_in q_fn tape0.

End SolutionMachine.

Ltac try_step :=
  econstructor; [solve[repeat constructor=>//]|] => /=;
  try(rewrite/rotr/rot/=;
      match goal with |- many_steps _ _ ?e _ =>
        tryif match e with context[take _ _] => idtac | _ => fail end
        then fail else idtac e
      end).

Section HowItWorks.

  Axiom zc_ax2: 2 < zc_card. (* to make examples interesting *)
  Definition _2: Σ_zc. by apply Ordinal with 2, zc_ax2. Defined.

  Ltac run_check := eexists; constructor => //=; repeat try_step; constructor.

  Example how_works_for_01210201_:
    exists n, run (zero_clear_CTM [:: _0; _1; _2; _1; _0; _2; _0; _1]) n
                              [:: _0; _0; _0; _0; _0; _0; _0; _0].
  Proof. run_check. Qed.

  Example how_works_for_21_:
    exists n, run (zero_clear_CTM [:: _2; _1]) n
                              [:: _0; _0].
  Proof. run_check. Qed.

  Example how_works_for_2_:
    exists n, run (zero_clear_CTM [:: _2]) n
                              [:: _0].
  Proof. run_check. Qed.

End HowItWorks.

Section Correctness.

  (* Suppose that the input tape [tape0] has length greater than 1. *)

  Variable (tape0: seq Σ_zc) (zc_tape_ax: 0 < size tape0).

  Let zc_CTM := zero_clear_CTM tape0.
  Let zc_many_steps := many_steps zc_CTM.

  Lemma zc_det: deterministic zc_CTM.
  Proof. by intros; do 2 inversion 1=>//; subst; exfalso; move: H0=>/eqP. Qed.

  Definition map_0s (tape:seq Σ_zc):= map (fun _=>_0) tape.

  Lemma zc_cl_to_bk tape1 tape2 s:
    _1 \notin tape1 ->
    exists n, zc_many_steps n { q_cl @ tape1 ++ _1 :: tape2 ∺ s }
                          { q_bk @ s :: map_0s tape1 ++ _0 :: tape2 }.
  Proof.
    move:s tape2; elim tape1=>//.
    -{ intros; exists 1; try_step; rewrite-rcons_cons rotr1_rcons; constructor. }
    -{ move:tape1=>_ ? ? IH s tape2.
       rewrite in_cons eq_sym cat_cons=>/norP[]?/(IH _1(tape2∺s))[n IHn].
       exists(n.+2); try_step; rewrite rot1_cons rcons_cat rcons_cons.
       eapply many_steps_last; first eassumption.
       rewrite-rcons_cons-rcons_cat-(rotr1_rcons s); do 2 constructor. }
  Qed.

  Lemma zc_bk_to_cl tape1:
    zc_many_steps 3 { q_bk @ _0 :: tape1 ∺ _1 }
                    { q_cl @ tape1 ∺ _1 ∺ _0 }.
  Proof.
    try_step; rewrite-rcons_cons rotr1_rcons.
    try_step. rewrite cats1.
    try_step; rewrite rot1_cons; constructor.
  Qed.

  Lemma zc_cl_to_cl_one tape1:
    _1 \in tape1 ->
    exists n tape2, zc_many_steps n { q_cl @ tape1 ∺ _1 ∺ _0 }
                                { q_cl @ tape2 ∺ _1 ∺ _0 } /\
                count_mem _1 tape2 < count_mem _1 tape1.
  Proof.
    move/mem_cat_first
      =>[tape11][tape12]/andP[]/(zc_cl_to_bk(tape12∺_1)_0).
    rewrite-rcons_cons-rcons_cons-rcons_cat-rcons_cat=>[[? clbk]]/eqP->.
    move:clbk; rewrite-rcons_cons-rcons_cat=>clbk.
    move:(many_steps_trans clbk (zc_bk_to_cl _))=>?.
    eexists; eexists; split; first eassumption.
    rewrite 2!count_cat/=2!addnA ltn_add2r addn0.
    have->:(count_mem _1 (map_0s tape11)=0) by clear; elim tape11=>//=.
    by rewrite addn_gt0; apply/orP; right.
  Qed.

  Lemma zc_cl_to_cl_ones tape1:
    exists n tape2, zc_many_steps n { q_cl @ tape1 ∺ _1 ∺ _0 }
                                { q_cl @ tape2 ∺ _1 ∺ _0 } /\ _1 \notin tape2.
  Proof.
    remember(count_mem _1 tape1) as k eqn:E.
    move:E (leqnn k)=>{1}->; move:tape1; elim k=>/=.
    -{ move=>tape1; rewrite leqn0=>cntz.
       by exists 0, tape1; split; first constructor; move:cntz=>/eqP/count_memPn. }
    -{ move:k=>_ k IH tape1 cnSk.
       case_eq(_1\in tape1)=>/negP/negP otp1;
         last by exists 0, tape1; split; first constructor.
       move:(zc_cl_to_cl_one otp1)=>[n][tape2][]clcl12 Lt.
       move:ltnS{Lt cnSk}(leq_trans Lt cnSk)=>->/IH[m][tape3][]clcl23?.
       exists(n+m),tape3; split; last done; apply(many_steps_trans clcl12 clcl23). }
  Qed.

  Lemma zc_zero_clear tape:
    0 < size tape -> exists n, zc_many_steps n { q_in @ tape } { q_fn @ map_0s tape }.
  Proof.
    case:tape=>[|s1//[//|s2 tape]]//=_;
      first by eexists; repeat try_step; constructor.
    have incl:(zc_many_steps 2 { q_in @ [:: s1,s2&tape] } { q_cl @ tape ∺ _1 ∺ _0})
      by do 2(try_step; rewrite/rot/=);rewrite take0 drop0 cats1 cats1; constructor.
    move:(zc_cl_to_cl_ones tape)=>[?][tape1][clcl].
    move/(zc_cl_to_bk nil _0);rewrite/=-3!cat_rcons 2!cats0-rcons_cons=>[[? clbk]].
    have bkfn:(zc_many_steps 2 { q_bk @ (_0 :: map_0s tape) ∺ _0 }
                               { q_fn @ [:: _0, _0 & map_0s tape]})
      by rewrite rcons_cons; try_step;
         rewrite-rcons_cons rotr1_rcons; try_step; constructor.
    eexists; eapply(many_steps_trans incl);
             eapply(many_steps_trans clcl); eapply(many_steps_trans clbk).
    rewrite(_:map_0s tape1 = map_0s tape); first eassumption.
    have size12:(size tape==size tape1)
      by move:(size_many_steps clcl); rewrite 4!size_rcons 2!eqSS.
    move:size12; clear; move:tape; elim tape1=>/=.
    - by move=>?; rewrite size_eq0=>/eqP->.
    - by move:tape1=>_ _ ? IH[|??]//=; rewrite eqSS=>/IH->.
  Qed.

  Lemma zc_final c: _state c == q_fn -> no_more_step zc_CTM c.
  Proof. by case:c=>q ?/=/eqP->c1; inversion 1; inversion H3. Qed.

  Lemma zc_reachable:
    exists n, reachable zc_CTM n { q_fn @ map_0s tape0 }.
  Proof. by move:(zc_zero_clear zc_tape_ax)=>[n ?]; exists n; constructor. Qed.

  Lemma zc_run: exists n, run zc_CTM n (map_0s tape0).
  Proof. by move:zc_reachable=>[m]; inversion 1; exists m; constructor. Qed.

  Theorem zc_terminating: terminating zc_CTM.
  Proof.
    move:zc_reachable=>[n0]; inversion_clear 1 as[? msn0]; exists n0 => n c ltn0n.
    inversion 1 as[? msn]; move:(many_steps_inv ltn0n msn)=>[?][ms].
    move:(det_many_steps zc_det ms msn0)=>/eqP->.
    move:ltn0n; rewrite-subn_gt0; move:(n-n0)=>[//|k _]; inversion 1 as[|???? sfn].
    by move:sfn; eapply zc_final.
  Qed.

  Theorem zc_no_stuck: no_stuck zc_CTM.
  Proof.
    move=>n c [] cf msc nsc; move:zc_reachable=>[?]; inversion 1 as[? ms].
    have ns0:(no_more_step zc_CTM { q_fn @ map_0s tape0 }) by apply zc_final.
    by move:(det_stop zc_det (conj msc nsc)(conj ms ns0))=>/andP[_]/eqP->/=.
  Qed.

  Theorem zc_correctness n tape:
    run zc_CTM n tape -> tape == map_0s tape0.
  Proof.
    move:zc_run=>[m]; inversion 1 as[? ms]; inversion 1 as[? ms0].
    have ns:(no_more_step zc_CTM { qf zc_CTM @ map_0s tape0 }) by apply zc_final.
    have ns0:(no_more_step zc_CTM { qf zc_CTM @ tape }) by apply zc_final.
    by move:(det_stop zc_det (conj ms ns) (conj ms0 ns0))=>/andP[_]/eqP[]->.
  Qed.

End Correctness.