Require Import Arith.
Require Import Omega.
Require Import List.
Require Import LambdaSyntax.

(** Representation using DeBruijn indices. *)

Set Implicit Arguments.

Inductive db_term (A : Type) : Type :=
| db_const : A -> db_term A
| db_var : var -> db_term A
| db_app : db_term A -> db_term A -> db_term A
| db_abs : db_term A -> db_term A.

Arguments db_var [A] _.

Notation "\\ M" := (db_abs M) (at level 60, right associativity).
Notation "M $$ N" := (db_app M N) (at level 50, left associativity).
Notation "[ v ]" := (db_var v) (at level 40, no associativity).
Notation "[ v # T ]" := (db_var (A := T) v) (at level 40, no associativity).

Definition binders := list var.

(** * Conversion to DeBruijn form *)

Fixpoint find_var_in_binders (bs : binders) (v : var) (i : nat) : option nat :=
  match bs with
    | nil => None
    | v' :: bs' => if beq_nat v v' then Some i
                   else find_var_in_binders bs' v (S i)
  end.

Definition map_var (v : var) (lv : nat) (bs : binders) : var :=
  match find_var_in_binders bs v 0 with
    | None => v + lv
    | Some i => i
  end.

Fixpoint term_to_db_aux {A : Type} (t : term A) (bs : binders) (lv : nat) : db_term A :=
  match t with
    | Const a => db_const a
    | Var v => db_var (map_var v lv bs)
    | App m n => db_app (term_to_db_aux m bs lv) (term_to_db_aux n bs lv)
    | Abs x body => db_abs (term_to_db_aux body (x::bs) (S lv))
  end.

Definition term_to_db {A : Type} (t : term A) : db_term A :=
  term_to_db_aux t nil 0.

(** ** Conversion examples *)

Example term_to_db_ex1 :
  term_to_db (\X # nat --> Var X) = (\\ (db_var 0)).
Proof. reflexivity. Qed.

Example term_to_db_ex2 :
  term_to_db (\X # nat --> (Var X) $ (Var Y)) =
  \\ ((db_var 0) $$ (db_var 2)).
Proof. reflexivity. Qed.

Example term_to_db_ex3 :
  term_to_db (\Y # nat --> Var Y) = (\\ (db_var 0)).
Proof. reflexivity. Qed.

Example term_to_db_ex4 :
  term_to_db (\Y # nat --> (Var Y) $ (Var Z)) =
  (\\ ((db_var 0) $$ (db_var (S Z)))).
Proof. reflexivity. Qed.

Example term_to_db_ex5 :
  term_to_db ((Var 4) $ ((Var 3) $ (Var 2))) =
  ((db_var 4) $$ ((db_var 3) $$ [2 # nat])).
Proof. reflexivity. Qed.

Example term_to_db_ex6 :
  term_to_db (\ 7 --> (Var 3) $ (Var 7)) =
  (\\ [4 # nat] $$ [0]).
Proof. reflexivity. Qed.

Example term_to_db_ex7 :
  term_to_db (\ 7 --> (\ 8 --> (Var 4))) =
  (\\ (\\ [6 # nat])).
Proof. reflexivity. Qed.

(** * Conversion from DeBruijn form *)

Definition db_var_to_var (n i v : var) : var :=
  if leb (S n) i then (v + i - n) else (n - i).

Fixpoint db_to_term_aux {A : Type} (dt : db_term A) (i v : var) : term A :=
  match dt with
    | db_const a => Const a
    | db_var n => Var (db_var_to_var n i v)
    | db_app m n => App (db_to_term_aux m i v) (db_to_term_aux n i v)
    | db_abs body => Abs (v + (S i)) (db_to_term_aux body (S i) v)
  end.

Fixpoint max_free_var {A : Type} (dt : db_term A) (lv : nat) : nat :=
  match dt with
    | db_const _ => 0
    | db_var v => (v - lv)
    | db_app m n => max (max_free_var m lv) (max_free_var n lv)
    | db_abs body => max_free_var body (S lv)
  end.

Definition db_to_term {A : Type} (dt : db_term A) : term A :=
  db_to_term_aux dt 0 (max_free_var dt 0).

(** ** Examples *)

Example dbv_to_term_1 : db_to_term (\\ [0 # nat]) = (Abs 1 (Var 1)).
Proof. reflexivity. Qed.

Example dbv_to_term_2 :
  db_to_term (\\ ([0 # nat] $$ [2])) =
  (\2 --> (Var 2) $ (Var 1)).
Proof. reflexivity. Qed.

(** * Auxiliary lemmas and theorems *)

Lemma dbvar_to_var_zero : forall (n v : var),
                            db_var_to_var n 0 v = n.
Proof.
  intros n v.
  unfold db_var_to_var.
  replace (leb (S n) 0) with (false). apply eq_sym. apply minus_n_O.
  apply eq_sym. apply leb_correct_conv. apply lt_0_Sn.
Qed.

Lemma mapvar_nil : forall v lv, map_var v lv nil = v + lv.
Proof.
  intros v lv. unfold map_var. simpl. reflexivity.
Qed.

Lemma maxvar_app : forall (A : Type) v n (dt1 dt2 : db_term A),
                     v >= max_free_var (dt1 $$ dt2) n ->
                     v >= max_free_var dt1 n /\ v >= max_free_var dt2 n.
Proof.
  intros A v n dt1 dt2 Hgeq. simpl in Hgeq.
  apply NPeano.Nat.max_lub_iff in Hgeq. assumption.
Qed.

(** Generate a list [[v + n; v + n - 1; ...; v]]. *)

Fixpoint range_n_v (n : nat) (v : var) : list var :=
  match n with
    | 0 => nil
    | S n' => (v + n) :: (range_n_v n' v)
  end.

Lemma n_gt_0_Sn : forall n,
                    n > 0 -> (exists n', n = S n').
Proof.
  intros n H. destruct n eqn:E. inversion H.
  exists n0. reflexivity.
Qed.

Lemma n_gt_Sv_Sn : forall n v,
                     n > S v -> (exists n', n = S n').
Proof.
  intros n v H. destruct n eqn:E. inversion H. exists n0. reflexivity.
Qed.

Lemma v_lt_n_0 : forall n v, v < n -> 0 < n - v.
Proof.
  intros; omega.
Qed.

Lemma range_struct : forall n n' v,
                       n = S n' ->
                       range_n_v n v = (v + n) :: range_n_v n' v.
Proof.
  intros. rewrite H. reflexivity.
Qed.

Lemma find_in_range_v : forall v0 n v,
                        v < n ->
                        find_var_in_binders (range_n_v (n - v) v0) (v0 + n - v) v = Some v.
Proof.
  intros. destruct v.

  (* Case v = 0 *)
  apply n_gt_0_Sn in H. inversion H. rewrite <- minus_n_O.
  apply range_struct with (v := v0) in H0. rewrite H0.
  simpl. replace (beq_nat (v0 + n - 0) (v0 + n)) with (true). reflexivity.
  rewrite <- minus_n_O. apply beq_nat_refl.

  (* Case v = S v *)
  assert (H': S v < n). assumption.
  apply v_lt_n_0 in H. apply n_gt_0_Sn in H. inversion H.
  apply range_struct with (v := v0) (n := n - S v) in H0. rewrite H0.
  simpl. replace (beq_nat (v0 + n - S v) (v0 + (n - S v))) with (true). reflexivity.
  replace (v0 + (n - S v)) with (v0 + n - S v). apply beq_nat_refl.
  omega.
Qed.

Lemma minus_pred : forall n m, n > m -> m > 0 -> n - pred m = S (n - m).
Proof.
  intros n m Hnm Hm0. destruct m. inversion Hm0.
  simpl. rewrite NPeano.Nat.sub_succ_r. omega.
Qed.

Lemma minus_minus_Sn : forall n v i,
                         n > v - i -> v - i > 0 -> (n - (v - S i)) = S (n - (v - i)).
Proof.
  intros. simpl. rewrite NPeano.Nat.sub_succ_r. apply minus_pred; assumption.
Qed.

Lemma find_in_range_aux :
  forall v0 n v i,
    v < n -> i <= v ->
    find_var_in_binders (range_n_v (n - (v-i)) v0) (v0 + n - v) (v-i) = Some v.
Proof.
  intros. induction i.
  (* Case i = 0 *)
  rewrite <- minus_n_O. apply find_in_range_v. assumption.

  (* Case i = S i *)
  assert (Hnvi: n > v - i); try omega.
  assert (Hvi0: v - i > 0); try omega.
  apply minus_minus_Sn in Hnvi.
  apply range_struct with (v := v0) (n := n - (v - S i)) in Hnvi. rewrite Hnvi.
  simpl.
  replace (beq_nat (v0 + n - v) (v0 + (n - (v - S i)))) with (false).
  replace (S (v - S i)) with (v - i); try omega.
  apply IHi; omega. apply eq_sym. apply beq_nat_false_iff. omega.
  assumption.
Qed.

Lemma find_in_range : forall v0 n v,
                        v < n ->
                        find_var_in_binders (range_n_v n v0) (v0 + n - v) 0 = Some v.
Proof.
  intros. replace (range_n_v n v0) with (range_n_v (n - 0) v0).
  replace 0 with (v-v). apply find_in_range_aux with (i := v). assumption.
  apply le_refl. apply minus_diag. rewrite <- minus_n_O. reflexivity.
Qed.

Lemma mapvar_in_range : forall v0 n v,
                          (S v) <= n ->
                          map_var (v0 + n - v) n (range_n_v n v0) = v.
Proof.
  intros. unfold map_var. rewrite find_in_range. reflexivity.
  omega.
Qed.

Lemma find_out_of_range : forall v0 n v i,
                            v <= v0 ->
                            find_var_in_binders (range_n_v n v0) v i = None.
Proof.
  intros. generalize dependent i. induction n. reflexivity.
  intros. simpl. replace (beq_nat v (v0 + S n)) with (false).
  apply IHn. apply eq_sym. apply beq_nat_false_iff. omega.
Qed.

Lemma mapvar_out_of_range : forall v n v0,
                              v >= n ->
                              (v - n) <= v0 ->
                              map_var (v - n) n (range_n_v n v0) = v.
Proof.
  intros. unfold map_var. rewrite find_out_of_range.
  rewrite plus_comm. apply le_plus_minus_r. omega. assumption.
Qed.

(** * Converting from DeBruijn to standard and back is the identity  *)
Theorem from_to_dbv_aux :
  forall (A : Type) (dt : db_term A) v n,
    v >= (max_free_var dt n) ->
    term_to_db_aux (db_to_term_aux dt n v) (range_n_v n v) n = dt.
Proof.
  intros A dt.
  induction dt.

  (* Case dt = db_const *) reflexivity.

  (* Case dt = db_var *)
  intros. simpl in H.
  simpl. unfold db_var_to_var. destruct (leb (S v) n) eqn:E.
  apply leb_complete in E. rewrite mapvar_in_range. reflexivity. assumption.
  apply leb_complete_conv in E.
  rewrite mapvar_out_of_range. reflexivity. omega. assumption.

  (* Case dt = dt_app *)
  intros. simpl. apply maxvar_app in H.
  rewrite IHdt1; try rewrite IHdt2; try reflexivity; tauto.

  (* Case dt = db_abs *)
  intros. simpl. f_equal. apply IHdt. simpl in H. assumption.
Qed.

Theorem from_to_dbv : forall (A : Type) (dt : db_term A),
                        term_to_db (db_to_term dt) = dt.
Proof.
  intros. unfold term_to_db. unfold db_to_term. apply from_to_dbv_aux. auto.
Qed.

(** * Substitution *)

(** Shifting function, needed to preserve the identity of free variables
    after substitution. *)

Fixpoint shift_aux {A : Type} (dt : db_term A) d c : db_term A :=
  match dt with
    | db_const _ => dt
    | db_var k => db_var (if leb (S k) c then k else k + d)
    | db_abs body => db_abs (shift_aux body d (S c))
    | db_app m n => db_app (shift_aux m d c) (shift_aux n d c)
  end.

Definition shift {A : Type} (dt : db_term A) d : db_term A :=
  shift_aux dt d 0.

Example shift_ex1 :
  shift (\\ (\\ [1 # nat] $$ ([0] $$ [2]))) 2 = (\\ (\\ [1 # nat] $$ ([0] $$ [4]))).
Proof. reflexivity. Qed.

Example shift_ex2 :
  shift (\\ ([0 # nat] $$ [2]) $$ (\\ ([0] $$ [1]) $$ [2])) 2 =
  (\\ ([0 # nat] $$ [4]) $$ (\\ ([0] $$ [1]) $$ [4])).
Proof. reflexivity. Qed.

(** Substitute [dt] for variable [v] in term [orig]. *)

Fixpoint subst {A : Type} (orig : db_term A) v (dt : db_term A) : db_term A :=
  match orig with
    | db_const _ => orig
    | db_var x => if eq_nat_dec v x then dt else orig
    | db_abs body => db_abs (subst body (S v) (shift dt 1))
    | db_app m n => db_app (subst m v dt) (subst n v dt)
  end.

(** Module to localize substitution notation for DeBruijn terms. *)

Module SubstNotation.
  Notation "M [ v :-> N ]" := (subst M v N) (at level 50, left associativity).
End SubstNotation.

Import SubstNotation.

(** ** Free and bound variables *)

Fixpoint var_free_in_term {A : Type} (dt : db_term A) v : bool :=
  match dt with
    | db_const _ => false
    | db_var v' => beq_nat v v'
    | db_abs body => var_free_in_term body (S v)
    | db_app m n => orb (var_free_in_term m v) (var_free_in_term n v)
  end.

Inductive freeIn {A : Type} : db_term A -> var -> Prop :=
| freeIn_var : forall (v : var), freeIn (db_var v) v
| freeIn_app_l : forall (m n : db_term A) (v : var), freeIn m v -> freeIn (db_app m n) v
| freeIn_app_r : forall (m n : db_term A) (v : var), freeIn n v -> freeIn (db_app m n) v
| freeIn_abs : forall (body : db_term A) (v : var), freeIn body (S v) -> freeIn (db_abs body) v.

Example freeIn_ex1 : freeIn (\\ [1 # nat]) 0.
Proof.
  apply freeIn_abs. apply freeIn_var.
Qed.

Lemma not_free_in_var : forall (A : Type) v v',
                          ~(freeIn (db_var (A := A) v) v') -> v <> v'.
Proof.
  intros A v v' Hnfree.
  intro Hcontra. apply Hnfree. rewrite Hcontra. apply freeIn_var.
Qed.

Lemma not_free_in_app : forall (A : Type) (dt1 dt2 : db_term A) v,
                          ~(freeIn (dt1 $$ dt2) v) -> ~(freeIn dt1 v) /\ ~(freeIn dt2 v).
Proof.
  intros A dt1 dt2 v Hnfree.
  split; intro Hcontra; apply Hnfree;
    [ apply freeIn_app_l | apply freeIn_app_r ]; assumption.
Qed.

Lemma not_free_abs_succ_body : forall (A : Type) (dt : db_term A) v,
                                 ~(freeIn (\\ dt) v) ->
                                 ~(freeIn dt (S v)).
Proof.
  intros A dt v Hnfree. intro Hcontra; apply Hnfree.
  apply freeIn_abs. assumption.
Qed.

Lemma free_abs_succ_body : forall (A : Type) (t : db_term A) v,
                             freeIn (\\ t) v -> freeIn t (S v).
Proof.
  intros A t v Hfabs. inversion Hfabs. assumption.
Qed.

Lemma free_vars_abs :
  forall (A : Type) (t : db_term A) c1 c2 v1,
    freeIn (\\ t) v1 -> v1 >= c1 /\ v1 >= c2 -> S v1 >= S c1 /\ S v1 >= S c2.
Proof.
  intros A t c1 c2 v1 Hfabs Hgeq.
  split; apply le_n_S; apply Hgeq.
Qed.

Lemma free_app_contra : forall (A : Type) (t1 t2 : db_term A) v,
                          freeIn (t1 $$ t2) v -> freeIn t1 v \/ freeIn t2 v.
Proof.
  intros A t1 t2 v Hfree.
  inversion Hfree; [ left | right ]; assumption.
Qed.

(** ** The substitution lemma for DeBruijn terms *)

Lemma subst_same_var : forall (A : Type) (dt : db_term A) v,
                         (db_var v)[v :-> dt] = dt.
Proof.
  intros A dt v.
  simpl. destruct (eq_nat_dec v v). reflexivity. congruence.
Qed.

Lemma subst_diff_var : forall (A : Type) (dt : db_term A) v v',
                    v <> v' -> (db_var v)[v' :-> dt] = (db_var v).
Proof.
  intros A dt v v' Hneq.
  simpl. destruct (eq_nat_dec v' v). contra_equality. reflexivity.
Qed.

Lemma subst_non_free : forall (A : Type) (dt1 dt2 : db_term A) v,
                         ~(freeIn dt1 v) -> dt1 [v :-> dt2] = dt1.
Proof.
  intros A dt1. induction dt1; try reflexivity.

  (* Case dt1 = db_var *)
  intros dt2 v0 Hnfree.
  apply not_free_in_var in Hnfree. rewrite subst_diff_var. reflexivity. assumption.

  (* Case dt1 = db_app *)
  intros dt2 v Hnfree. apply not_free_in_app in Hnfree.
  simpl; f_equal; [ apply IHdt1_1 | apply IHdt1_2 ]; tauto.

  (* Case dt1 = dt_abs *)
  intros dt2 v Hnfree. simpl. f_equal. apply IHdt1.
  apply not_free_abs_succ_body. assumption.
Qed.

Lemma shift_aux_geq : forall (A : Type) v d c,
                       v >= c -> shift_aux (db_var (A := A) v) d c = db_var (v + d).
Proof.
  intros A v d c Hgt. destruct c. simpl. reflexivity. simpl.
  replace (leb v c) with (false). reflexivity.
  apply eq_sym. apply leb_correct_conv. omega.
Qed.

Lemma shift_aux_lt : forall (A : Type) v d c,
                       v < c -> shift_aux (db_var (A := A) v) d c = db_var v.
Proof.
  intros A v d c Hlt. destruct c. inversion Hlt.
  simpl. replace (leb v c) with (true). reflexivity.
  apply eq_sym. apply leb_correct. apply gt_S_le. assumption.
Qed.

Lemma free_shift_aux : forall (A : Type) (t : db_term A) v c,
                         v >= c -> freeIn t v -> freeIn (shift_aux t 1 c) (S v).
Proof.
  intros A t v c v_geq_c Hfree. generalize dependent c.
  induction Hfree.

  (* Case freeIn_var *)
  intros. rewrite shift_aux_geq; try assumption.
  rewrite NPeano.Nat.add_1_r. apply freeIn_var.

  (* Case freeIn_app_l *)
  intros. simpl. apply freeIn_app_l. apply IHHfree; assumption.

  (* Case freeIn_app_r *)
  intros. simpl. apply freeIn_app_r. apply IHHfree; assumption.

  (* Case freeIn_abs *)
  intros. simpl. apply freeIn_abs. apply IHHfree. apply le_n_S; assumption.
Qed.

Lemma free_shift : forall (A : Type) (t : db_term A) v,
                     freeIn t v -> freeIn (shift t 1) (S v).
Proof.
  intros. unfold shift. apply free_shift_aux; try assumption. apply le_0_n.
Qed.

Lemma lt_Sn_m_n_m : forall n m, S n < m -> n < m.
Proof.
  intros. assert (Hn : n < S n). apply lt_n_Sn.
  apply lt_trans with (m := S n) (p := m) in Hn; assumption.
Qed.

Lemma free_shift_aux_free : forall (A : Type) (t : db_term A) v c,
                              v >= c -> freeIn (shift_aux t 1 c) (S v) -> freeIn t v.
Proof.
  intros A t. induction t.

  (* Case t = db_const *)
  intros v c v_geq_c Hfree. simpl in Hfree. inversion Hfree.

  (* Case t = db_var *)
  intros v0 c v0_geq_c Hfree. destruct (eq_nat_dec v v0) as [ v_eq_v0 | v_neq_v0 ].
    (* Case v = v0 *) rewrite v_eq_v0. apply freeIn_var.
    (* Case v <> v0 *)
    destruct (le_lt_dec c v) as [ v_geq_c | v_lt_c ].
      (* Case v >= c *)
      rewrite shift_aux_geq in Hfree; try assumption.
      rewrite NPeano.Nat.add_1_r in Hfree. inversion Hfree. apply freeIn_var.
      (* Case v < c *)
      rewrite shift_aux_lt in Hfree; try assumption. inversion Hfree.
      rewrite H1 in v_lt_c. apply lt_Sn_m_n_m in v_lt_c.
      assert (Hcontra := le_lt_trans _ _ _ v0_geq_c v_lt_c).
      apply lt_irrefl in Hcontra. exfalso; assumption.

  (* Case t = db_app *)
  intros v c v_geq_c Hfree. simpl in Hfree. apply free_app_contra in Hfree.
  elim Hfree.
  intro H; apply freeIn_app_l; apply IHt1 with (c := c); assumption.
  intro H; apply freeIn_app_r; apply IHt2 with (c := c); assumption.

  (* Case t = db_abs *)
  intros v c v_geq_c Hfree. apply freeIn_abs. simpl in Hfree.
  apply IHt with (c := S c). apply le_n_S; assumption. apply free_abs_succ_body.
  assumption.
Qed.

Lemma free_shift_free : forall (A : Type) (t : db_term A) v,
                          freeIn (shift t 1) (S v) -> freeIn t v.
Proof.
  intros. unfold shift. apply free_shift_aux_free with (c := 0).
  apply le_0_n. assumption.
Qed.

Lemma shift_shift :
  forall (A : Type) (t : db_term A) c1 c2,
    c1 >= c2 ->
    shift_aux (shift_aux t 1 c1) 1 c2 = shift_aux (shift_aux t 1 c2) 1 (S c1).
Proof.
  intros A t. induction t. reflexivity.

  (* Case t = db_var *)
  intros c1 c2 c1_geq_c2. destruct (le_lt_dec c1 v).
    (* Case v >= c1 *)
    repeat rewrite shift_aux_geq; try omega. reflexivity.
    (* Case v < c1 *)
    destruct (le_lt_dec c2 v).
      (* Case v >= c2 *)
      rewrite shift_aux_lt; try assumption. rewrite shift_aux_geq; try assumption.
      rewrite shift_aux_lt. reflexivity. omega.
      (* Case v < c2 *)
      repeat rewrite shift_aux_lt; try omega. reflexivity.

  (* Case t = db_app *)
  intros c1 c2 c1_geq_c2.
  simpl; f_equal; [ apply IHt1 | apply IHt2 ]; assumption.

  (* Case t = db_abs *)
  intros c1 c2 c1_geq_c2.
  simpl. f_equal. apply IHt. apply le_n_S. assumption.
Qed.

Lemma shift_aux_subst_xchg :
  forall (A : Type) (dt1 dt2 : db_term A) v c,
    v >= c ->
    (shift_aux dt1 1 c)[S v :-> shift_aux dt2 1 c] = shift_aux (dt1 [v :-> dt2]) 1 c.
Proof.
  intros A dt1.
  induction dt1; try reflexivity.

  (* Case dt1 = db_var *)
  intros dt2 v0 c v0_geq_c.
  destruct (eq_nat_dec v v0) as [ v0_eq_v | v0_diff_v ].
    (* Case v0 = v *)
    rewrite v0_eq_v. rewrite shift_aux_geq; try assumption.
    rewrite NPeano.Nat.add_1_r. repeat rewrite subst_same_var. reflexivity.

    (* Case v0 <> v *)
    rewrite subst_diff_var; try assumption.
    destruct (le_lt_dec c v).
      (* Case v >= c *)
      rewrite shift_aux_geq; try apply le_0_n; try assumption. rewrite NPeano.Nat.add_1_r.
      rewrite subst_diff_var; auto with arith.
      (* Case v < c *)
      rewrite shift_aux_lt; try assumption. rewrite subst_diff_var. reflexivity.
      omega.

  (* Case dt1 = db_app *)
  intros dt2 v c v_geq_c.
  simpl; f_equal; [ apply IHdt1_1 | apply IHdt1_2 ]; try assumption.

  (* Case dt1 = db_abs *)
  intros dt2 v c v_geq_c.
  simpl. f_equal. rewrite <- IHdt1. f_equal. unfold shift.
  apply shift_shift. apply le_0_n. apply le_n_S; assumption.
Qed.

Lemma shift_subst_xchg : forall (A : Type) (dt1 dt2 : db_term A) v,
                           (shift dt1 1)[S v :-> shift dt2 1] = shift (dt1 [v :-> dt2]) 1.
Proof.
  intros A dt1 dt2 v. unfold shift. apply shift_aux_subst_xchg. apply le_0_n.
Qed.

Lemma subst_lemma : forall (A : Type) (M N L : db_term A) x y,
                      x <> y -> ~(freeIn L x) ->
                      M[x :-> N][y :-> L] = M[y :-> L][x :-> N[y :-> L]].
Proof.
  intros A M. induction M.

  (* Case M = db_const *) reflexivity.

  (* Case M = db_var *)
  intros N L x y Hneq Hnfree.
  destruct (eq_nat_dec v x) as [ v_eq_x | v_neq_x ].
    (* Case v = x *)
    rewrite v_eq_x. rewrite subst_same_var.
    rewrite subst_diff_var. rewrite subst_same_var. reflexivity. assumption.

    (* Case v <> x *)
    rewrite subst_diff_var; try assumption.
    destruct (eq_nat_dec v y) as [ v_eq_y | v_neq_y ].
      (* Case v = y *)
      rewrite v_eq_y. repeat rewrite subst_same_var.
      rewrite subst_non_free. reflexivity. assumption.

      (* Case v <> y *)
      repeat rewrite subst_diff_var; try assumption. reflexivity.

  (* Case M = db_app *)
  intros N L x y Hneq Hnfree. simpl. f_equal; [ apply IHM1 | apply IHM2 ]; assumption.

  (* Case M = db_abs *)
  intros N L x y Hneq Hnfree.
  simpl. f_equal. rewrite IHM. f_equal. apply shift_subst_xchg.
  apply not_eq_S; assumption.
  intro Hcontra. apply Hnfree.
  apply free_shift_free. assumption.
Qed.


(* ************************************************************** *)
Section pred1.

Variable Terms : Set.
Variable M : Terms.

(* predicates *)
Variable A : Prop.
Variable P : Terms -> Prop.
Variable Q : Terms -> Prop.
Variable R : Terms -> Terms -> Prop.

(* example *)
Theorem example0 : (forall x:Terms, (P x)) -> (P M).
Proof.
intro u.
apply u.
Qed.

Print example0.
(* \u: Pi x:Terms. Px. (u M) *)

(* example *)
Theorem example1 : forall x:Terms, (P x) -> (forall y:Terms, (P y) -> A) -> A.
Proof.
intro x.
intro h.
intro i.
apply i with x.
assumption.
Qed.

Print example1.
(* \x:Terms. \h:(P x). \i:(Pi y:Terms. Py -> A). (i x h) *)

(* example, see slide 35 of week 6 *)
Theorem example2 :
  (forall x : Terms , P x -> Q x)
  ->
  (forall x : Terms , P x)
  ->
  forall y : Terms , Q y.

Proof.
intro h.
intro i.
intro y.
apply h.
apply i.
Qed.
Print example2.
(* \h: (Pi x:Terms. Px -> Qx). \i: (Pi x:Terms Px). \y: Terms. h y (i y) *)

(* exercise 1: prove the lemma and inspect the proof term *)
Lemma one : (forall x : Terms, P x) -> P M.
Proof.
intro u.
apply u.
Qed.
Print one.

(* exercise 2: prove the lemma and inspect the proof term *)
Lemma two : (A -> forall x : Terms, P x) -> (forall y : Terms, A -> P y).
Proof.
intro H.
intro y.
intro x.
apply H.
exact x.
Qed.
Print two.

(* exercise 3: prove the lemma and inspect the proof term *)
Lemma three : A -> forall x : Terms, A.
Proof.
intro x.
intro y.
exact x.
Qed.
Print three.

(* example, see slides 13-14-15 of week 7 *)
Definition AS :=
  forall x y : Terms, (R x y) -> ~(R y x).
Definition IR :=
  forall x:Terms, ~(R x x).

Theorem AS_implies_IR : AS -> IR.
Proof.
unfold AS.
unfold IR.
unfold not.
intro h.
intro x.
intro i.
apply h with x x.
  (* alternative: apply (h x x ) *)
exact i.
exact i.
Qed.
Print AS_implies_IR.

(* given *)
Definition reflif := forall x : Terms, (exists y : Terms, R x y) -> R x x.

(* exercise 4:
   define sym as the proposition stating that
   R is symmetric, that is,
   if x and y are related via R, then y and x are related via R *)
Definition sym := forall x y : Terms, R x y -> R y x.

(* exercise 5:
   define trans as the proposition stating that
   R is transitive, that is,
   if x and y are related via R, and y and z are related via R,
   then x and z are related via R  *)
Definition trans := forall x y z : Terms, (R x y /\ R y z) -> R x z.

(* exercise 6: prove the following Lemma *)
Lemma str : sym -> trans -> reflif.
Proof.
unfold sym, trans, reflif.
intro sym.
intro trans.
intro.
intro.
elim H.
intro.
intro.
apply trans with x0.
split.
exact H0.
apply sym.
apply H0.
Qed.

End pred1.

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

Section logical_framework.

(* we encode propositional logic
   source: webpage Herman Geuvers
   handbook article Henk Barendregt *)

(* prop representing the propositions is declared as a Set *)
Parameter prop : Set.

(* implication on prop is a binary operator *)
Parameter imp : prop -> prop -> prop.

(* we can use infix notation => for imp *)
Infix "=>" := imp (right associativity, at level 85).

(* T expresses if a proposion in prop is valid
   if (T p) is inhabited then p is valid
   if (T p) is not inhabited then p is not valid *)
Parameter T : prop -> Prop.

(* the variable imp_introduction models the introduction rule for imp *)
Parameter imp_introduction : forall p q : prop, (T p -> T q) -> T (p => q).

(* the variable imp_elimination models the elimination rule for imp *)
Parameter imp_elimination : forall p q : prop, T (p => q) -> T p -> T q.

(* exercise 7 : prove the following lemma *)
Lemma I : forall p : prop, T (p => p).
Proof.
intro p. apply imp_introduction. intro Tp. apply Tp.
Qed.

(* exercise 8 : prove the following lemma *)
Lemma transitivity :
 forall p q r : prop, T (p => q) -> T (q => r) -> T (p => r).
Proof.
intros p q r.
intros p_implies_q q_implies_r.
apply imp_introduction. intro Tp.
apply imp_elimination with q. assumption.
apply imp_elimination with p. assumption.
assumption.
Qed.

Parameter conjunction : prop -> prop -> prop.
Infix "X" := conjunction (no associativity, at level 90).

(* exercise 9 : define variables that model the introduction
   rule for conjuction on prop, and both elimination rules *)

Parameter conjunction_introduction :
  forall p q : prop, T p -> T q -> T (p X q).

Parameter conjunction_elimination_l :
  forall p q : prop, T (p X q) -> T p.

Parameter conjunction_elimination_r :
  forall p q : prop, T (p X q) -> T q.

(* exercise 10: prove the following lemma *)
Lemma weak : forall a b c : prop, T (a => c) -> T ((a X b) => c).
Proof.
intros a b c a_implies_c.
apply imp_introduction. intro a_conj_b.
apply imp_elimination with a. assumption.
apply conjunction_elimination_l with b.
assumption.
Qed.

(* the remainder is not obligatory *)

(* bot represents falsum in prop *)
Parameter bot : prop.

(* not represents negation in prop *)
Definition not (p : prop) := p => bot.

(* not obligatory *)
(* exercise 11 : prove the following lemma *)
Lemma contrapositive : forall p q : prop, T (p => q) -> T (not q => not p).
Proof.
intros p q p_implies_q.
apply imp_introduction. unfold not. intro not_q.
apply imp_introduction. intro Tp.
apply imp_elimination with q. apply not_q.
apply imp_elimination with p. assumption.
assumption.
Qed.

End logical_framework.

(*
vim: filetype=coq
*)


(* Add some trivial facts about nats to the auto hint database,
   so we don't have to use omega as much. *)
Require Import FiatFormal.Tactics.

Lemma nat_eq_cases
 :  forall (n m : nat)
 ,  n = m \/ ~(n = m).
Proof. intros. omega. Qed.
Hint Resolve nat_eq_cases.

Lemma nat_zero_le_all
 : forall n, 0 <= n.
Proof.
 intros. omega.
Qed.
Hint Resolve nat_zero_le_all.

Lemma nat_zero_lt_succ
 : forall n, 0 < S n.
Proof.
 intros. omega.
Qed.
Hint Resolve nat_zero_lt_succ.

(* Don't add transitivity lemmas to the hints database as it
   can severely degrade performance. *)
Lemma nat_trans_le
 : forall a b c
 , a <= b -> b <= c -> a <= c.
Proof.
 intros. omega.
Qed.

(* Normalise naturals to use successor representation instead
   of addition. *)
Lemma nat_plus_zero
 : forall n, n + 0 = n.
Proof. auto. Qed.
Hint Rewrite nat_plus_zero : global.

Lemma nat_zero_plus
 :  forall n, 0 + n = n.
Proof. auto. Qed.
Hint Rewrite nat_zero_plus : global.

Lemma nat_minus_zero
 : forall n, n - 0 = n.
Proof. intros. omega. Qed.
Hint Rewrite nat_minus_zero : global.

Lemma nat_plus_one
 : forall n, n + 1 = S n.
Proof. intros. omega. Qed.

(* Tactics **********************************************************)
(* Normalise naturals. *)
Tactic Notation "norm_nat"
 := first
    [ rewrite nat_plus_zero
    | rewrite nat_minus_zero
    | rewrite nat_plus_one ].

(* Convert boolean (in)equalities *)
Ltac eqs_beq_nat
 := repeat match goal with
    | [ H : true = beq_nat ?n ?m |- _]
    => symmetry in H; apply beq_nat_true in H

    | [H : false = beq_nat ?n ?m |- _]
    => symmetry in H; apply beq_nat_false in H
    end.

(* Break on boolean equality *)
Ltac break_beq_nat
 := match goal with
     |  [ |- context [beq_nat ?n ?m] ]
     => let X := fresh in remember (beq_nat n m) as X; destruct X
    end; eqs_beq_nat.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List Arith Nat Lia Relations.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list finite php.

From Undecidability.TRAKHTENBROT
  Require Import notations.

Set Default Proof Using "Type".

Set Implicit Arguments.

(* * Kleene's greatest fixpoint of lia-continous operators *)

Section gfp.

  (* We develop the theory of Kleene's greatest fixpoint for binary relations
      and establish the fact that the gfp is an equivalence (under suitable hyps),
      reached after lia many steps (under lia continuity) and
      reached after finitely many steps (under finiteness of the domain and
      preservation of decidability *)

  Variable (M : Type).

  Implicit Type (R T : M -> M -> Prop).

  Notation "R ⊆ T" := (forall x y, R x y -> T x y).

  Notation "R 'o' T" := (fun x z => exists y, R x y /\ T y z) (at level 58).

  Let incl_trans R S T : R ⊆ S -> S ⊆ T -> R ⊆ T.
  Proof. firstorder. Qed.

  Let comp_mono R R' T T' : R ⊆ R' -> T ⊆ T' -> R o T ⊆ R' o T'.
  Proof. firstorder. Qed.

  Variable (F : (M -> M -> Prop) -> M -> M -> Prop).

  Hypothesis (HF0 : forall R T, R ⊆ T -> F R ⊆ F T).  (* Monotonicity *)

  Let sym R := fun x y => R y x.

  Let i := iter F (fun _ _ => True).

  Let iS n : i (S n) = F (i n).
  Proof. apply iter_S. Qed.

  Let i0 : i 0 = fun _ _ => True.
  Proof. auto. Qed.

  Let i_S n : i (S n) ⊆ i n.
  Proof.
    unfold i.
    induction n as [ | n IHn ].
    + simpl; auto.
    + intros ? ?.
      rewrite iter_S with (n := n), iter_S.
      apply HF0, IHn.
  Qed.

  Let i_decr n m : n <= m -> i m ⊆ i n.
  Proof. induction 1; auto. Qed.

  Definition gfp x y := forall n, i n x y.

  Notation I := (@eq M).

  Hypothesis HF1 : I ⊆ F I.    (* Reflexivity *)

  Let i_refl n : I ⊆ i n.
  Proof.
    induction n as [ | n IHn ].
    + rewrite i0; auto.
    + rewrite iS.
      apply incl_trans with (1 := HF1), HF0, IHn.
  Qed.

  Let gfp_refl : I ⊆ gfp.
  Proof. intros ? ? [] ?; apply i_refl; auto. Qed.

  Hypothesis HF2 : forall R, sym (F R) ⊆ F (sym R).   (* Symmetry *)

  Let i_sym n : sym (i n) ⊆ i n.
  Proof.
    induction n as [ | n IHn ].
    + intros ? ?; rewrite i0; simpl; auto.
    + rewrite iS; apply incl_trans with (2 := HF0 _ IHn), HF2.
  Qed.

  Let gfp_sym : sym gfp ⊆ gfp.
  Proof. intros ? ? H ?; apply i_sym, H. Qed.

  Hypothesis HF3 : forall R, F R o F R ⊆ F (R o R).   (* Transitivity *)

  Let i_trans n : i n o i n ⊆ i n.
  Proof.
    induction n as [ | n IHn ].
    + rewrite i0; auto.
    + rewrite iS; apply incl_trans with (1 := @HF3 _), HF0, IHn.
  Qed.

  Let gfp_trans : gfp o gfp ⊆ gfp.
  Proof.
    intros ? ? H ?; apply i_trans.
    revert H; apply comp_mono; auto.
  Qed.

  Fact gfp_equiv : equiv _ gfp.
  Proof using i_trans i_sym i_refl gfp_trans gfp_sym gfp_refl HF3 HF2 HF1.
    msplit 2.
    + intro; apply gfp_refl; auto.
    + intros ? y ? ? ?; apply gfp_trans; exists y; auto.
    + intros ? ?; apply gfp_sym.
  Qed.

  Fact gfp_greatest R : R ⊆ F R -> R ⊆ gfp.
  Proof using HF0.
    intros HR x y H n; revert x y H.
    induction n as [ | n IHn ].
    + now auto.
    + apply incl_trans with (1 := HR).
      rewrite iS; apply HF0; auto.
  Qed.

  Let gfp_fix1 : F gfp ⊆ gfp.
  Proof.
    intros ? ? H ?.
    apply i_S; rewrite iS.
    revert H; apply HF0; auto.
  Qed.

  (* This is ω-continuity *)

  Definition gfp_continuous := forall (s : nat -> M -> M -> Prop),
                        (forall n m, n <= m -> s m ⊆ s n)
                     -> (fun x y => forall n, F (s n) x y) ⊆ F (fun x y => forall n, s n x y).

  Variable HF4 : gfp_continuous.

  Let gfp_fix0 : gfp ⊆ F gfp.
  Proof.
    intros ? ? H.
    apply HF4; auto.
    intro; rewrite <- iS; apply H.
  Qed.

  Fact gfp_fix x y : F gfp x y <-> gfp x y.
  Proof using i_decr i_S gfp_fix1 gfp_fix0 HF4 HF0. split; auto. Qed.

  (* This is for decidability *)

  Let dec R := forall x y, { R x y } + { ~ R x y }.

  Variable HF5 : forall R, dec R -> dec (F R).       (* Preservation of decidability *)

  Let i_dec n : dec (i n).
  Proof.
    induction n as [ | n IHn ].
    + rewrite i0; left; auto.
    + rewrite iS; apply HF5; auto.
  Qed.

  (* For the decidability of gfp, we need the finiteness
      so that gfp = i n for a sufficiently large n *)

  (* A good pair for i (ie n < m and i n ⊆ i m) means gfp is reached  at n *)

  Let i_dup n m : n < m -> i n ⊆ i m -> forall k, n <= k -> forall x y, gfp x y <-> i k x y.
  Proof.
    intros H1 H2.
    generalize (i_decr H1) (i_S n); rewrite iS; intros H3 H4.
    generalize (incl_trans _ _ _ H2 H3); intros H5.
    assert (forall p, i n ⊆ i (p+n)) as H6.
    { induction p as [ | p IHp ]; auto.
      simpl plus; rewrite iS.
      apply incl_trans with (1 := H5), HF0; auto. }
    intros k Hk x y; split; auto.
    intros H a.
    destruct (le_lt_dec a k).
    + revert H; apply i_decr; auto.
    + replace a with (a-n+n) by lia.
      apply H6.
      revert H; apply i_decr; auto.
  Qed.

  (* If there is a good pair below b, then gfp = i b *)

  Let gfp_reached b : (exists n m, n < m <= b /\ i n ⊆ i m) -> (forall x y, gfp x y <-> i b x y).
  Proof.
    intros (n & m & H1 & H2).
    apply i_dup with (2 := H2); auto; try lia.
  Qed.

  Variable HF6 : finite_t M.     (* Finiteness of the domain *)

  (* When M is finite, there is a list [T1;...;Tk] of relations of
      type M -> M -> Prop which contains every weakly decidable relations
      upto equivalence.

      Hence, by the a generalized version of the PHP (proved w/o
      assuming discreteness), for n greater than the length of
      the list for M, one can find a duplicate
      in the list [i 0; ...;i n] ie a < b <= n such
      that i a ~ Tu ~ Tv ~ i b

      Then one can deduce i n ~ gfp *)

  Theorem gfp_finite_t : { n | forall x y, gfp x y <-> i n x y }.
  Proof using i_dup i_decr i_dec i_S gfp_reached HF6 HF5 HF0.
    destruct finite_t_weak_dec_rels with (1 := HF6)
      as (mR & HmR).
    exists (S (length mR)).
    set (l := map i (list_an 0 (S (length mR)))).
    apply (@gfp_reached (S (length mR))).
    destruct php_upto
      with (R := fun R T => forall x y, R x y <-> T x y)
           (l := l) (m := mR)
      as (a & R & b & T & c & H1 & H2).
    + intros R S H ? ?; rewrite H; tauto.
    + intros R S T H1 H2 ? ?; rewrite H1, H2; tauto.
    + intros R HR.
      unfold l in HR; apply in_map_iff in HR.
      destruct HR as (n & <- & _).
      destruct (HmR (i n)) as (T & H1 & H2).
      * intros x y; destruct (i_dec n x y); tauto.
      * exists T; auto.
    + unfold l; rewrite map_length, list_an_length; auto.
    + unfold l in H1; apply map_duplicate_inv in H1.
      destruct H1 as (a' & n & b' & m & c' & H1 & H3 & H4 & H5 & H6 & H7).
      exists n, m; rewrite <- H3, <- H5; split; try (intros ? ?; apply H2).
      apply list_an_duplicate_inv in H7; lia.
  Qed.

  (* As a consequence of been reached after a finite number of steps,
      gfp is one of the i n (for some computable n) and thus decidable *)

  Theorem gfp_decidable : dec gfp.
  Proof using i_dup i_decr i_dec i_S gfp_reached gfp_fix1 HF6 HF5 HF0.
    destruct gfp_finite_t as (n & Hn).
    intros x y; destruct (i_dec n x y); [ left | right ];
      rewrite Hn; tauto.
  Qed.

End gfp.