Require Import String Omega Morph.

(* Name indices are [nat]s *)
Definition index := nat.

(* Shift up all indices greater than or equal to [i] *)
Fixpoint shift_idx (i : index) (j : index) : index :=
  match i with
  | 0 => S j
  | S i =>
    match j with
    | 0 => 0
    | S j => S (shift_idx i j)
    end
  end.

Lemma rw_shift_idx_ge i j :
  i <= j ->
  shift_idx i j = S j.
Proof.
  generalize dependent j.
  induction i; destruct j; intros; try easy.
  cbn; auto with arith.
Qed.

Lemma rw_shift_idx_lt i j :
  S j <= i ->
  shift_idx i j = j.
Proof.
  generalize dependent j.
  induction i; destruct j; intros; try easy.
  cbn; auto with arith.
Qed.

Lemma rw_shift_idx_same i :
  shift_idx i i = S i.
Proof.
  apply rw_shift_idx_ge; auto.
Qed.

(* Partial inverse of [shift_idx]. Returns [None] iff [i = j]. *)
Fixpoint inverse_shift_idx i j :=
  match i with
  | 0 =>
    match j with
    | 0 => None
    | S j => Some j
    end
  | S i =>
    match j with
    | 0 => Some 0
    | S j =>
      match inverse_shift_idx i j with
      | None => None
      | Some j' => Some (S j')
      end
    end
  end.

Lemma rw_inverse_shift_idx_eq i j :
  i = j ->
  inverse_shift_idx i j = None.
Proof.
  intros <-.
  induction i; try easy; cbn.
  rewrite IHi; easy.
Qed.

Lemma rw_inverse_shift_idx_lt i j :
  S j <= i ->
  inverse_shift_idx i j = Some j.
Proof.
  generalize dependent j.
  induction i; destruct j; intros Heq; try easy; cbn.
  rewrite IHi; auto with arith.
Qed.

Lemma rw_inverse_shift_idx_gt i j :
  S i <= j ->
  inverse_shift_idx i j = Some (pred j).
Proof.
  generalize dependent j.
  induction i; destruct j; intros Heq; try easy; cbn.
  rewrite IHi; f_equal; omega.
Qed.

Lemma rw_inverse_shift_idx_same i :
  inverse_shift_idx i i = None.
Proof.
  apply rw_inverse_shift_idx_eq; easy.
Qed.

(* Tactics for handling the above operations *)

Arguments shift_idx !i !j.
Arguments inverse_shift_idx !i !j.

(* Rewrite [shift_idx]s, [unshift_idx]s and [inverse_shift_idx]s where
   the order of the parameters can be determined by the omega tactic *)
Ltac simpl_idxs :=
  repeat progress
    (match goal with
     | |- context [shift_idx ?i ?j] =>
       first
         [ rewrite (rw_shift_idx_ge i j) by omega
         | rewrite (rw_shift_idx_lt i j) by omega ]
     | |- context [inverse_shift_idx ?i ?j] =>
       first
         [ rewrite (rw_inverse_shift_idx_eq i j) by omega
         | rewrite (rw_inverse_shift_idx_lt i j) by omega
         | rewrite (rw_inverse_shift_idx_gt i j) by omega ]
     end; cbn).

(* Case split on the order of the parameters, then simplify any
   [shift_idx]s and [inverse_shift_idx]s affected by the
   ordering. *)
Ltac case_order i j :=
  destruct (Compare_dec.lt_eq_lt_dec i j) as [[|]|];
  simpl_idxs.

(* Inverses *)

Lemma rw_inverse_shift_idx_shift_idx i j :
  inverse_shift_idx i (shift_idx i j) = Some j.
Proof.
  case_order i j; easy.
Qed.

Lemma rw_shift_idx_inverse_shift_idx {i j} :
  option_map (shift_idx i) (inverse_shift_idx i j)
  = if Nat.eq_dec i j then None else Some j.
Proof.
  case_order i j;
    destruct (Nat.eq_dec i j); f_equal; try omega.
Qed.

(* Comparison for free name indices *)

Inductive index_comparison (i : index) : index -> Set :=
| same_idx : index_comparison i i
| diff_idx j : index_comparison i (shift_idx i j).

Fixpoint compare_idx (i : index)
  : forall j, index_comparison i j :=
  match i with
  | 0 => fun j =>
    match j with
    | 0 => same_idx _
    | S j => diff_idx _ j
    end
  | S i => fun j =>
    match j with
    | 0 => diff_idx _ 0
    | S j =>
      match compare_idx i j with
      | same_idx _ => same_idx _
      | diff_idx _ j' => diff_idx _ (S j')
      end
    end
  end.

Lemma rw_compare_idx_same :
  forall i, compare_idx i i = same_idx i.
Proof. induction i; cbn; try rewrite IHi; easy. Qed.

Lemma rw_compare_idx_shift :
  forall i j, compare_idx i (shift_idx i j) = diff_idx i j.
Proof. induction i; destruct j; cbn; try rewrite IHi; easy. Qed.

Hint Rewrite @rw_shift_idx_same @rw_inverse_shift_idx_same
     @rw_inverse_shift_idx_shift_idx @rw_shift_idx_inverse_shift_idx
     @rw_compare_idx_same @rw_compare_idx_shift
  : rw_idxs.

Arguments shift_idx : simpl never.
Arguments inverse_shift_idx : simpl never.

(* Free names are a pair of a string and an index *)

Set Primitive Projections.
Record name := mkname { n_string : string; n_index : index }.
Add Printing Constructor name.
Unset Primitive Projections.

Definition name_of_string s := mkname s 0.
Coercion name_of_string : string >-> name.
Bind Scope string_scope with name.

Lemma name_dec (a : name) (b : name) :
  {a = b} + {a <> b}.
Proof.
  destruct (string_dec (n_string a) (n_string b)).
  - destruct (Nat.eq_dec (n_index a) (n_index b)).
    + left; destruct a, b; cbn in *; subst; easy.
    + right; intro; subst; contradiction.
  - right; intro; subst; contradiction.
Qed.

Definition indistinct_names a b :=
  n_string a = n_string b.

Definition distinct_names a b :=
  not (indistinct_names a b).

Lemma distinct_names_dec a b :
  { distinct_names a b } + { indistinct_names a b }.
Proof.
  destruct (string_dec (n_string a) (n_string b)).
  - right; easy.
  - left; easy.
Qed.

Lemma distinct_names_same a :
  ~ (distinct_names a a).
Proof.
  intro Hd.
  unfold distinct_names, indistinct_names in Hd.
  easy.
Qed.

Lemma distinct_names_symmetric {a b} :
  distinct_names a b ->
  distinct_names b a.
Proof.
  unfold distinct_names; intuition.
Qed.

(* Shift the index of a name up by one *)
Definition succ_name (a : name) :=
  mkname (n_string a) (S (n_index a)).

(* Shift up all names with the same string as [a] and an index
   greater than or equal to [a]'s *)
Definition shift_name (a : name) (b : name) :=
  mkname (n_string b)
   (if string_dec (n_string a) (n_string b) then
      shift_idx (n_index a) (n_index b)
    else
      n_index b).
Arguments shift_name !a !b.

Lemma rw_shift_name_distinct a b :
  distinct_names a b ->
  shift_name a b = b.
Proof.
  unfold shift_name.
  destruct (string_dec (n_string a) (n_string b)); easy.
Qed.

Lemma rw_shift_name_indistinct a b :
  indistinct_names a b ->
  shift_name a b
  = mkname (n_string b) (shift_idx (n_index a) (n_index b)).
Proof.
  unfold shift_name.
  destruct (string_dec (n_string a) (n_string b)); easy.
Qed.

Lemma rw_shift_name_same a :
  shift_name a a = succ_name a.
Proof.
  rewrite rw_shift_name_indistinct by easy.
  rewrite rw_shift_idx_same; easy.
Qed.

(* Partial inverse of [shift_name]. Returns [None] iff [b = a]. *)
Definition inverse_shift_name (a : name) (b : name) :=
  if string_dec (n_string a) (n_string b) then
    option_map (mkname (n_string b))
      (inverse_shift_idx (n_index a) (n_index b))
  else
    Some b.

Lemma rw_inverse_shift_name_distinct a b :
  distinct_names a b ->
  inverse_shift_name a b = Some b.
Proof.
  unfold inverse_shift_name.
  destruct (string_dec (n_string a) (n_string b)); easy.
Qed.

Lemma rw_inverse_shift_name_indistinct a b :
  indistinct_names a b ->
  inverse_shift_name a b
  = option_map (mkname (n_string b))
      (inverse_shift_idx (n_index a) (n_index b)).
Proof.
  unfold inverse_shift_name.
  destruct (string_dec (n_string a) (n_string b)); easy.
Qed.

Lemma rw_inverse_shift_name_same a :
  inverse_shift_name a a = None.
Proof.
  rewrite rw_inverse_shift_name_indistinct by easy.
  rewrite rw_inverse_shift_idx_same; easy.
Qed.

(* Rewrite [shift_idx]s, [unshift_idx]s and [inverse_shift_idx]s where
   the order of the parameters can be determined by the omega tactic *)
Ltac simpl_names :=
  repeat progress
    (match goal with
     | |- context [shift_name ?a ?b] =>
       first
         [ rewrite (rw_shift_name_distinct a b) by easy
         | rewrite (rw_shift_name_indistinct a b) by easy ]
     | |- context [inverse_shift_name ?a ?b] =>
       first
         [ rewrite (rw_inverse_shift_name_distinct a b) by easy
         | rewrite (rw_inverse_shift_name_indistinct a b) by easy ]
     end; cbn).

(* Case split on the strings of the parameters, then simplify any
   [shift_names]s and [inverse_shift_names]s affected by the
   ordering. *)
Ltac case_strings a b :=
  destruct (distinct_names_dec a b);
  simpl_names.

(* Inverses *)

Lemma rw_inverse_shift_name_shift_name a b :
  inverse_shift_name a (shift_name a b) = Some b.
Proof.
  case_strings a b; autorewrite with rw_idxs; easy.
Qed.

Lemma rw_shift_name_inverse_shift_name a b :
  option_map (shift_name a) (inverse_shift_name a b)
  = if distinct_names_dec a b then Some b
    else if Nat.eq_dec (n_index a) (n_index b) then None
    else Some b.
Proof.
  case_strings a b; try easy;
    case_order (n_index a) (n_index b);
    simpl_names; simpl_idxs;
      try replace (S (pred (n_index b))) with (n_index b) by omega;
      destruct (Nat.eq_dec (n_index a) (n_index b)); try omega; easy.
Qed.

Hint Rewrite @rw_shift_name_same @rw_inverse_shift_name_same
     @rw_inverse_shift_name_shift_name
  : rw_names.

(* Renaming operation on names *)

Definition rename_name a b c :=
  match inverse_shift_name b c with
  | Some c' => shift_name a c'
  | None => a
  end.

Arguments rename_name !a !b !c.

Lemma rw_rename_name_distinct a b c :
  distinct_names a c ->
  rename_name b a c = shift_name b c.
Proof.
  intros.
  unfold rename_name.
  rewrite (rw_inverse_shift_name_distinct a c) by easy.
  easy.
Qed.

Lemma rw_rename_name_both_distinct a b c :
  distinct_names a c ->
  distinct_names b c ->
  rename_name b a c = c.
Proof.
  intros.
  rewrite (rw_rename_name_distinct a b c) by easy.
  rewrite (rw_shift_name_distinct b c) by easy.
  easy.
Qed.

Lemma rw_rename_name_same a b : rename_name b a a = b.
Proof.
  unfold rename_name.
  autorewrite with rw_names; easy.
Qed.

Lemma rw_rename_name_shift_name a b c :
  rename_name b a (shift_name a c) = shift_name b c.
Proof.
  unfold rename_name.
  autorewrite with rw_names; easy.
Qed.

Lemma rw_rename_name_rename_name a b c d :
  rename_name b a (rename_name a c d)
  = rename_name b c d.
Proof.
  unfold rename_name.
  case_strings c d;
    case_order (n_index c) (n_index d);
    autorewrite with rw_names; easy.
Qed.

Hint Rewrite @rw_rename_name_same @rw_rename_name_shift_name
     @rw_rename_name_rename_name
  : rw_names.

(* Comparison for free names *)

Inductive name_comparison (a : name) : name -> Set :=
| same_name : name_comparison a a
| diff_name b : name_comparison a (shift_name a b).

Lemma compare_names a b : name_comparison a b.
Proof.
  destruct a as [an ai], b as [bn bi]; cbn.
  remember (string_dec an bn) as Hdec.
  destruct Hdec; subst.
  - destruct (compare_idx ai bi) as [|j].
    + apply same_name.
    + replace (mkname bn (shift_idx ai j))
        with (shift_name (mkname bn ai) (mkname bn j));
        try apply diff_name.
      unfold shift_name, n_string.
      rewrite <- HeqHdec; easy.
  - replace (mkname bn bi)
        with (shift_name (mkname an ai) (mkname bn bi));
      try apply diff_name.
    unfold shift_name, n_string.
    rewrite <- HeqHdec; easy.
Qed.

(* Bound variables are represented by a level *)

Definition Zero := Empty_set.

Inductive Succ {S : Set} : Set := l0 | lS (s : S).

Fixpoint level (V : nat) : Set :=
  match V with
  | 0 => Zero
  | S V => @Succ (level V)
  end.
Arguments level !V.

(* Variables are either free names or bound levels *)

Inductive var {V : nat} :=
| free (name : name)
| bound (l : level V).

(* The core operations acting on variables *)

Definition wkv {V} (v : @var V) : @var (S V) :=
  match v with
  | free n => free n
  | bound l => @bound (S V) (lS l)
  end.

Definition openv a {V} (v : @var (S V)) : @var V :=
  match v with
  | free n => free (shift_name a n)
  | bound l0 => free a
  | bound (lS l) => @bound V l
  end.

Definition closev a {V} (v : @var V) : @var (S V) :=
  match v with
  | free n =>
    match inverse_shift_name a n with
    | Some n' => free n'
    | None => @bound (S V) l0
    end
  | bound l => @bound (S V) (lS l)
  end.

Definition bindv {V} (v : @var (S V)) : option (@var V) :=
  match v with
  | free n => Some (free n)
  | bound l0 => None
  | bound (lS l) => Some (@bound V l)
  end.

(* We don't want to reduce the operations if it just exposes
   the inner match. ([wkv] has no inner matches) *)

Arguments openv : simpl nomatch.
Arguments closev : simpl nomatch.
Arguments bindv : simpl nomatch.

(* Add reductions for [closev]. The other operations reduce
   directly by cbn. *)

Lemma rw_closev_shift a b :
  forall {V}, @closev a V (free (shift_name a b)) = free b.
Proof.
  unfold closev; autorewrite with rw_names; easy.
Qed.

Lemma rw_closev_same a :
  forall {V}, @closev a V (free a) =
    @bound (S V) (@l0 (level V)).
Proof.
  unfold closev; autorewrite with rw_names; easy.
Qed.

Hint Rewrite @rw_closev_shift @rw_closev_same : rw_vars.

(* Open and close on the same variable are inverses. Weaken
   is a right inverse of bind. *)

Lemma rw_openv_closev a {V} (v : @var V) :
  openv a (closev a v) = v.
Proof.
  destruct v as [n|l]; cbn; try easy.
  destruct (compare_names a n); autorewrite with rw_vars; easy.
Qed.

Lemma rw_closev_openv a {V} (v : @var (S V)) :
  closev a (openv a v) = v.
Proof.
  destruct v as [n|[|l]]; cbn;
    autorewrite with rw_vars; easy.
Qed.

Lemma rw_bindv_wkv {V} (v : @var V) :
  bindv (wkv v) = Some v.
Proof. destruct v; easy. Qed.

Hint Rewrite @rw_closev_openv @rw_openv_closev @rw_bindv_wkv
  : rw_vars.

(* [openv] and [closev] on distinct names *)
Lemma closev_distinct {a b} (Hd : distinct_names a b) {V} :
  closev a (@free V b) = free b.
Proof.
  unfold closev.
  rewrite (rw_inverse_shift_name_distinct a b) by easy.
  easy.
Qed.

Lemma openv_distinct {a b} (Hd : distinct_names a b) {V} :
  openv a (@free (S V) b) = free b.
Proof.
  unfold openv.
  rewrite (rw_shift_name_distinct a b) by easy.
  easy.
Qed.

(* Combined operations *)

Definition shiftv a {V} v := @openv a V (wkv v).
Definition renv a b {V} v := @openv a V (closev b v).
Definition substv a {V} v := @bindv V (closev a v).

(* We want [shiftv] to reduce whenever [v] is a
   constructor, since [wkv] will always reduce in
   such cases. *)
Arguments shiftv a {V} !v.

(* Add reductions for [renv] and [substv] based on the
   similar reductions for [closev] *)

Lemma rw_renv_free a b c :
  forall {V}, @renv b a V (free c) =
    free (rename_name b a c).
Proof.
  intros; unfold renv.
  destruct (compare_names a c);
    autorewrite with rw_names rw_vars; easy.
Qed.

Lemma rw_substv_shift a c :
  forall {V}, @substv a V (free (shift_name a c)) =
              Some (free c).
Proof.
  intros; unfold substv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_substv_same a :
  forall {V}, @substv a V (free a) = None.
Proof.
  intros; unfold substv; autorewrite with rw_vars; easy.
Qed.

Hint Rewrite @rw_renv_free @rw_substv_shift @rw_substv_same
  : rw_vars.

(* Combined operation reductions based on identities *)

Lemma rw_closev_shiftv a {V} (v : @var V) :
  closev a (shiftv a v) = wkv v.
Proof.
  unfold shiftv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_closev_renv a b {V} (v : @var V) :
  closev a (renv a b v) = closev b v.
Proof.
  unfold renv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_renv_same a {V} (v : @var V) :
  renv a a v = v.
Proof.
  unfold renv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_renv_openv a b {V} (v : @var (S V)) :
  renv b a (openv a v) = openv b v.
Proof.
  unfold renv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_renv_shiftv a b {V} (v : @var V) :
  renv b a (shiftv a v) = shiftv b v.
Proof.
  unfold renv, shiftv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_renv_renv a b c {V} (v : @var V) :
  renv b a (renv a c v) = renv b c v.
Proof.
  unfold renv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_substv_renv a b {V} (v : @var V) :
  substv a (renv a b v) = substv b v.
Proof.
  unfold renv, substv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_substv_shiftv a {V} (v : @var V) :
  substv a (shiftv a v) = Some v.
Proof.
  unfold shiftv, substv; autorewrite with rw_vars; easy.
Qed.

Hint Rewrite @rw_closev_shiftv @rw_closev_renv @rw_renv_same
     @rw_renv_openv @rw_renv_shiftv @rw_renv_renv
     @rw_substv_renv @rw_substv_shiftv
  : rw_vars.

(* Fold combined operations *)

Lemma rw_shiftv_fold a {V} (v : @var V) :
  openv a (wkv v) = shiftv a v.
Proof. easy. Qed.
Lemma rw_renv_fold a b {V} (v : @var V) :
  openv b (closev a v) = renv b a v.
Proof. easy. Qed.
Lemma rw_substv_fold a {V} (v : @var V) :
  bindv (closev a v) = substv a v.
Proof. easy. Qed.

Hint Rewrite @rw_shiftv_fold @rw_renv_fold @rw_substv_fold
  : rw_vars.

(* Combined operations on distinct names *)

Lemma shiftv_distinct {a b} (Hd : distinct_names a b) {V} :
  shiftv a (@free V b) = free b.
Proof.
  cbn; rewrite (rw_shift_name_distinct a b) by easy; easy.
Qed.

Lemma renv_distinct {a b c} (Hd : distinct_names a c) {V} :
  renv b a (@free V c) = free (shift_name b c).
Proof.
  autorewrite with rw_vars.
  rewrite (rw_rename_name_distinct a b c) by easy; easy.
Qed.

Lemma renv_both_distinct {a b c}
      (Hd1 : distinct_names a c) (Hd2 : distinct_names b c) {V} :
  renv b a (@free V c) = free c.
Proof.
  autorewrite with rw_vars.
  rewrite (rw_rename_name_both_distinct a b c) by easy; easy.
Qed.

Lemma substv_distinct {a b} (Hd : distinct_names a b) {V} :
  substv a (@free V b) = Some (free b).
Proof.
  unfold substv; rewrite (closev_distinct Hd); easy.
Qed.

(* [wkv] commutes with [shiftv] and [renv]. We generally
   try to move [wkv] leftwards but carefully to avoid
   breaking confluence. *)

Lemma swap_shiftv_wkv a {V} (v : @var V) :
  shiftv a (wkv v) = wkv (shiftv a v).
Proof. destruct v; easy. Qed.

Lemma swap_renv_wkv a b {V} (v : @var V) :
  renv a b (wkv v) = wkv (renv a b v).
Proof.
  destruct v; cbn; autorewrite with rw_vars; easy.
Qed.

Lemma rw_bindv_shiftv_wkv a {V} (v : @var V) :
  bindv (shiftv a (wkv v)) = Some (shiftv a v).
Proof.
  rewrite swap_shiftv_wkv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_bindv_renv_wkv a b {V} (v : @var V) :
  bindv (renv a b (wkv v)) = Some (renv a b v).
Proof.
  rewrite swap_renv_wkv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_openv_shiftv_wkv a b {V} (v : @var V) :
  openv a (shiftv b (wkv v)) = shiftv a (shiftv b v).
Proof.
  rewrite swap_shiftv_wkv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_openv_renv_wkv a b c {V} (v : @var V) :
  openv a (renv b c (wkv v)) = shiftv a (renv b c v).
Proof.
  rewrite swap_renv_wkv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_closev_wkv_shiftv a {V} (v : @var V) :
  closev a (wkv (shiftv a v)) = wkv (wkv v).
Proof.
  rewrite <- swap_shiftv_wkv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_renv_wkv_shiftv a b {V} (v : @var V) :
  renv b a (wkv (shiftv a v)) = wkv (shiftv b v).
Proof.
  rewrite swap_renv_wkv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_substv_wkv_shiftv a {V} (v : @var V) :
  substv a (wkv (shiftv a v)) = Some (wkv v).
Proof.
  rewrite <- swap_shiftv_wkv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_closev_wkv_renv a b {V} (v : @var V) :
  closev a (wkv (renv a b v)) = closev b (wkv v).
Proof.
  rewrite <- swap_renv_wkv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_renv_wkv_renv a b c {V} (v : @var V) :
  renv b a (wkv (renv a c v)) = wkv (renv b c v).
Proof.
  rewrite swap_renv_wkv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_substv_wkv_renv a b {V} (v : @var V) :
  substv a (wkv (renv a b v)) = substv b (wkv v).
Proof.
  rewrite <- swap_renv_wkv; autorewrite with rw_vars; easy.
Qed.

Lemma rw_shiftv_shiftv_wkv a b {V} (v : @var V) :
  shiftv a (shiftv b (wkv v)) = shiftv a (wkv (shiftv b v)).
Proof.
  rewrite swap_shiftv_wkv; easy.
Qed.

Lemma rw_renv_shiftv_wkv a b c {V} (v : @var V) :
  renv b a (shiftv c (wkv v)) = renv b a (wkv (shiftv c v)).
Proof.
  rewrite swap_shiftv_wkv; easy.
Qed.

Lemma rw_renv_renv_wkv a b c d {V} (v : @var V) :
  renv b a (renv c d (wkv v)) = renv b a (wkv (renv c d v)).
Proof.
  rewrite swap_renv_wkv; easy.
Qed.

Hint Rewrite @rw_bindv_shiftv_wkv @rw_bindv_renv_wkv
     @rw_openv_shiftv_wkv @rw_openv_renv_wkv
     @rw_closev_wkv_shiftv @rw_renv_wkv_shiftv
     @rw_substv_wkv_shiftv @rw_closev_wkv_renv
     @rw_renv_wkv_renv @rw_substv_wkv_renv
     @rw_shiftv_shiftv_wkv @rw_renv_shiftv_wkv
     @rw_renv_renv_wkv
  : rw_vars.

(* Comparison of vars *)

Inductive var_comparison (a : name) {V} : @var V -> Set :=
| samev : var_comparison a (@free V a)
| diffv v : var_comparison a (shiftv a v).

Definition compare_vars a {V} (v : @var V)
  : var_comparison a v.
  destruct v as [b|l].
  destruct (compare_names a b).
  - constructor.
  - change (free (shift_name a b))
      with (shiftv a (@free V b)).
    constructor.
  - change (bound l) with (shiftv a (bound l)).
    constructor.
Qed.

(* Comparison with [bound l0] *)

Inductive l0_comparison {V} : @var (S V) -> Set :=
| samel0 : l0_comparison (@bound (S V) (@l0 (level V)))
| diffl0 v : l0_comparison (wkv v).

Definition compare_l0 {V} (v : @var (S V)) : l0_comparison v.
Proof.
  destruct v as [a|[|l]].
  - change (@free (S V) a)
      with (@wkv V (free a)); constructor.
  - constructor.
  - change (@bound (S V) (lS l))
      with (@wkv V (bound l)); constructor.
Qed.

(* A couple of useful commuting lemmas *)

Lemma swap_shiftv_shiftv_distinct {a b} (Hd : distinct_names a b)
      {V} (v : @var V) :
  shiftv a (shiftv b v) = shiftv b (shiftv a v).
Proof.
  destruct v as [c|l]; cbn; try easy.
  case_strings b c; try easy.
  rewrite (rw_shift_name_distinct a c).
  - rewrite (rw_shift_name_distinct a _);
      replace (n_string c) with (n_string b); easy.
  - unfold distinct_names, indistinct_names.
    replace (n_string c) with (n_string b); easy.
Qed.

Lemma swap_shift_close {a b} (Hd : distinct_names b a)
      {V} (v : @var V) :
  closev a (shiftv b v) = shiftv b (closev a v).
Proof.
  destruct (compare_vars a v).
  - rewrite shiftv_distinct by easy.
    autorewrite with rw_vars rw_names.
    easy.
  - rewrite swap_shiftv_shiftv_distinct by easy.
    autorewrite with rw_vars rw_names.
    rewrite swap_shiftv_wkv; easy.
Qed.

Definition swap_bound {V} (v : @var (S (S V))) : @var (S (S V)) :=
  match v with
  | free a => free a
  | bound l =>
    @bound (S (S V))
    (match l with
     | l0 => lS l0
     | lS l0 => l0
     | lS (lS v) => lS (lS v)
     end)
  end.

Lemma swap_close_close {x y}
      (Hd : distinct_names x y) {V} {v : @var V} :
  closev x (closev y v) = swap_bound (closev y (closev x v)).
Proof.
  destruct (compare_vars y v); autorewrite with rw_vars; cbn.
  - replace (free y) with (shiftv x (@free V y)).
    + autorewrite with rw_vars; easy.
    + rewrite (shiftv_distinct Hd); easy.
  - rewrite swap_shift_close
      by auto using distinct_names_symmetric.
    autorewrite with rw_vars.
    destruct v as [n|l]; cbn; try easy.
    destruct (compare_names x n);
      autorewrite with rw_vars; easy.
Qed.

(* Algebra of operations on [var 0] *)
Inductive renaming {trm : Set} :=
| r_id
| r_comp (r : renaming) (s : renaming)
| r_shift (b : name) (r : renaming)
| r_rename (b : name) (r : renaming) (a : name)
| r_subst (t : trm) (r : renaming) (a : name).

Declare Scope ren_scope.
Notation "r1 ; r2" := (r_comp r1 r2)
  (at level 57, right associativity) : ren_scope.
Notation "r ,, ^ a" := (r_shift a r)
  (at level 47, left associativity) : ren_scope.
Notation "r ,, a <- b" := (r_rename a r b)
  (at level 47, left associativity, a at next level) : ren_scope.
Notation "r ,, u // a" := (r_subst u r a)
  (at level 47, left associativity, u at next level) : ren_scope.
Notation "^ a" := (r_shift a r_id)
  (at level 47, left associativity) : ren_scope.
Notation "a <- b" := (r_rename a r_id b)
  (at level 47, left associativity) : ren_scope.
Notation "u // a" := (r_subst u r_id a)
  (at level 47, left associativity) : ren_scope.
Notation "r ,, a" := (r_rename a r a)
  (at level 47, left associativity) : ren_scope.

Delimit Scope ren_scope with ren.

Fixpoint total {trm : Set} (r : @renaming trm) : Prop :=
  match r with
  | r_id => True
  | r_comp r s => total r /\ total s
  | r_shift b r => total r
  | r_rename b r a => total r
  | r_subst u r a => False
  end.

Definition proj1 {A B : Prop} (H : A /\ B) := let (a, _) := H in a.
Definition proj2 {A B : Prop} (H : A /\ B) := let (_, b) := H in b.

Fixpoint applyt {trm : Set} (r : @renaming trm) :
  forall (rn : total r), morph (@var) 0 (@var) 0 :=
  match r with
  | r_id =>
    fun _ _ v => v
  | r_comp r s =>
    fun rn V v => applyt r (proj1 rn) V (applyt s (proj2 rn) V v)
  | r_shift b r =>
    fun rn V v => openv b (applyt r rn (S V) (wkv v))
  | r_rename b r a =>
    fun rn V v => openv b (applyt r rn (S V) (closev a v))
  | r_subst _ _ _ => False_rec _
  end.

Arguments applyt {trm} !r rn {V} t /.

Lemma rw_applyt_bound trm (r : @renaming trm) rn :
  forall {V} (v : level V),
    applyt r rn (bound v) = bound v.
Proof.
  induction r; try destruct rn; cbn; intros; auto;
    repeat match goal with [ H : _ |- _ ] => rewrite H; clear H end;
    cbn; easy.
Qed.

Hint Rewrite @rw_applyt_bound : rw_names.

Lemma rw_applyt_wkv :
  forall trm (r : @renaming trm) (rn : total r) {V} (v : @var V),
    applyt r rn (wkv v) = wkv (applyt r rn v).
Proof.
  induction r; cbn; intuition.
  - rewrite IHr2, IHr1; reflexivity.
  - repeat rewrite IHr.
    autorewrite with rw_vars.
    rewrite <- swap_shiftv_wkv; reflexivity.
  - destruct (compare_vars a v).
    + autorewrite with rw_vars rw_names; reflexivity.
    + autorewrite with rw_vars.
      repeat rewrite IHr.
      autorewrite with rw_vars.
      rewrite <- swap_shiftv_wkv; reflexivity.
Qed.

Hint Rewrite @rw_applyt_wkv : rw_names.

Lemma rw_applyt_wkv_free trm (r : @renaming trm) rn {a V} :
  applyt r rn (@free (S V) a) = wkv (applyt r rn (@free V a)).
Proof.
  change (@free (S V) a) with (wkv (@free V a)).
  apply rw_applyt_wkv.
Qed.

Hint Rewrite @rw_applyt_wkv_free : rw_names.


Require Coq.Init.Datatypes.
Import Coq.Init.Notations.
Notation "A -> B" := (forall (_ : A), B) : type_scope.

Section inductionExamples.

  Inductive ThreeElementSet:=
  |zero
  |one
  |two.

  Inductive PairOrTriple:=
  |pair (x y:ThreeElementSet)
  |triple (x y z:ThreeElementSet).

  Inductive Lst:=
  |nil
  |cons (x:ThreeElementSet) (l:Lst).

End inductionExamples.

Section functionExamples.

  Definition plusOneModThree (X:ThreeElementSet):
    ThreeElementSet.
  Proof.
    induction X.
    - apply one.
    - apply two.
    - apply zero.
  Defined.

  Definition constantAtZero (X:ThreeElementSet):
    ThreeElementSet.
  Proof.
    apply zero.
  Defined.

  Definition plusTwoModThree (X:ThreeElementSet):
    ThreeElementSet.
  Proof.
    induction X.
    - apply two.
    - apply zero.
    - apply one.
  Defined.

  Definition roundToPair (p:PairOrTriple):
    PairOrTriple.
  Proof.
    induction p.
    - apply (pair x y).
    - apply (pair x y).
  Defined.

  Fixpoint append (l m:Lst):
    Lst.
  Proof.
    destruct l.
    - apply m.
    - apply (cons x (append l m)).
  Defined.

End functionExamples.

Section inductionExercises.

  Inductive FourElementSet:=
  (* define four element set *).

  Inductive Nat:=
  (* define natural number induction *).

End inductionExercises.

Section functionExercises.

  Definition constantAtZero4 (x:FourElementSet):
    FourElementSet.
  Proof.
    (* define the function x|->0*)
  Defined.

  Definition doubleModThree (x:ThreeElementSet):
    ThreeElementSet.
  Proof.
    (* define the function x|->2x (mod 3)*)
  Defined.

  Definition fourModThree (x:FourElementSet):
    ThreeElementSet.
  Proof.
    (* define the function x|->x( mod 3)
       that lands in ThreeElementSet *)
  Defined.

  Fixpoint length (l:Lst):
    Nat.
  Proof.
    (* return the length of l *)
  Defined.

End functionExercises.


Add LoadPath "C:\Projects\Coq".

Require Export Induction.
Require Export Case.

Module NatList.

Inductive natprod :=
  | pair : nat -> nat -> natprod.

Definition fst a :=
  match a with
  | pair a _ => a
  end.

Definition snd v :=
  match v with
  | pair _ b => b
  end.

Eval compute in fst (pair 2 3).

Notation "( x , y )" := (pair x y).

Eval compute in fst(2, 3).

Definition fst' p :=
  match p with
  | (x, _) => x
  end.

Definition snd' p :=
  match p with
  | (_, y) => y
  end.

Definition swap_pair v :=
  match v with
  | (x, y) => (y, x)
  end.

Theorem surjective_pairing':
  forall n m, (n, m) = (fst (n, m), snd (n, m)).
Proof.
  reflexivity.
Qed.

Theorem surjective_pairing_stuck:
  forall p, p = (fst p, snd p).
Proof.
  destruct p.
  reflexivity.
Qed.

Theorem snd_fst_is_swap:
  forall p, (snd p, fst p) = swap_pair p.

  destruct p.
  reflexivity.
Qed.

Theorem fst_swap_is_snd:
  forall p, fst (swap_pair p) = snd p.
destruct p.
reflexivity.
Qed.

Inductive natlist :=
  | nil
  | cons: nat -> natlist -> natlist.

Definition mylist := cons 1 (cons 2 (cons 3 nil)).

Notation "x :: l" := (cons x l) (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Fixpoint repeat n count :=
  match count with
  | O => nil
  | S count' => n :: repeat n count'
  end.

Eval compute in repeat 9 10.

Fixpoint length l :=
  match l with
  | nil => O
  | _ :: rest => S (length rest)
  end.

Fixpoint app l1 l2 :=
  match l1 with
  | [] => l2
  | x::rest => x :: app rest l2
  end.

Eval compute in app [1;2;3] (repeat 9 10).

Notation "x ++ y" := (app x y) (right associativity, at level 60).

Example test_app1: [1;2;3] ++ [4;5] = [1;2;3;4;5].
Proof. reflexivity. Qed.
Example test_app2: nil ++ [4;5] = [4;5].
Proof. reflexivity. Qed.
Example test_app3: [1;2;3] ++ nil = [1;2;3].
Proof. reflexivity. Qed.

Definition hd default l :=
  match l with
  | [] => default
  | h :: _ => h
  end.

Definition tl l :=
  match l with
  | [] => []
  | _ :: t => t
  end.

Fixpoint nonzeros l :=
  match l with
  | [] => []
  | 0 :: rest => nonzeros rest
  | x :: rest => x :: nonzeros rest
  end.

Fixpoint oddmembers l :=
  match l with
  | [] => []
  | n :: rest =>
    if oddb n then
      n :: oddmembers rest
    else
      oddmembers rest
  end.

Definition countoddmembers l :=
  length (oddmembers l).

Example test_nonzeros: nonzeros [0;1;0;2;3;0;0] = [1;2;3].
reflexivity. Qed.

Example test_oddmembers: oddmembers [0;1;0;2;3;0;0] = [1;3].
reflexivity. Qed.

Example test_countoddmembers1: countoddmembers [1;0;3;1;4;5] = 4.
reflexivity. Qed.
Example test_countoddmembers2: countoddmembers [0;2;4] = 0.
reflexivity. Qed.
Example test_countoddmembers3: countoddmembers nil = 0.
reflexivity. Qed.

Fixpoint alternate l1 l2 :=
  match l1, l2 with
  | [], l
  | l, [] => l
  | x :: xs, y :: ys => x :: y :: alternate xs ys
  end.

Example test_alternate1: alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
reflexivity. Qed.
Example test_alternate2: alternate [1] [4;5;6] = [1;4;5;6].
reflexivity. Qed.
Example test_alternate3: alternate [1;2;3] [4] = [1;4;2;3].
reflexivity. Qed.
Example test_alternate4: alternate [] [20;30] = [20;30].
reflexivity. Qed.

Definition bag := natlist.

Fixpoint count v s :=
  match s with
  | [] => O
  | x :: xs =>
    if beq_nat v x then
      S (count v xs)
    else
      count v xs
  end.

Example test_count1: count 1 [1;2;3;1;4;1] = 3.
reflexivity. Qed.
Example test_count2: count 6 [1;2;3;1;4;1] = 0.
reflexivity. Qed.

Definition sum : bag -> bag -> bag := app.

Example test_sum1: count 1 (sum [1;2;3] [1;4;1]) = 3.
reflexivity. Qed.

Definition add v s : bag := v :: s.

Example test_add1: count 1 (add 1 [1;4;1]) = 3.
reflexivity. Qed.

Example test_add2: count 5 (add 1 [1;4;1]) = 0.
reflexivity. Qed.

Definition member v (s: bag) :=
  ble_nat 1 (count v s).

Example test_member1: member 1 [1;4;1] = true.
reflexivity. Qed.

Example test_member2: member 2 [1;4;1] = false.
reflexivity. Qed.

Fixpoint remove_one v s : bag :=
  match s with
  | [] => []
  | x :: xs =>
    if beq_nat x v
    then xs
    else x :: remove_one v xs
  end.

Example test_remove_one1: count 5 (remove_one 5 [2;1;5;4;1]) = 0.
reflexivity. Qed.
Example test_remove_one2: count 5 (remove_one 5 [2;1;4;1]) = 0.
reflexivity. Qed.
Example test_remove_one3: count 4 (remove_one 5 [2;1;4;5;1;4]) = 2.
reflexivity. Qed.
Example test_remove_one_4: count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1.
reflexivity. Qed.

Fixpoint remove_all v (s: bag) :=
  match s with
  | [] => []
  | x :: xs =>
    if beq_nat x v
    then remove_all v xs
    else x :: remove_all v xs
  end.

Example test_remove_all1: count 5 (remove_all 5 [2;1;5;4;1]) = 0.
reflexivity. Qed.
Example test_remove_all2: count 5 (remove_all 5 [2;1;4;1]) = 0.
reflexivity. Qed.
Example test_remove_all3: count 4 (remove_all 5 [2;1;4;5;1;4]) = 2.
reflexivity. Qed.
Example test_remove_all4: count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0.
reflexivity. Qed.

Fixpoint subset (s1: bag) (s2: bag) :=
  match s1 with
  | [] => true
  | x :: xs =>
    if member x s2
    then subset xs (remove_one x s2)
    else false
  end.

Example test_subset1: subset [1;2] [2;1;4;1] = true.
reflexivity. Qed.
Example test_subset2: subset [1;2;2] [2;1;4;1] = false.
reflexivity. Qed.

Theorem beq_nat_refl:
  forall n, beq_nat n n = true.
induction n. reflexivity. simpl. rewrite -> IHn. reflexivity. Qed.

Theorem add_count:
  forall n s, count n (add n s) = S (count n s).
Proof.
  intros.
  induction s as [|s'].
  simpl.
  rewrite -> beq_nat_refl.
  reflexivity.
  simpl.
  rewrite -> beq_nat_refl.
  reflexivity.
Qed.

Theorem nil_app:
  forall l, [] ++ l = l.
reflexivity. Qed.

Theorem tl_length_pred:
  forall l, pred (length l) = length (tl l).
Proof.
  destruct l as [|n l'].
  Case "l = []".
    reflexivity.
  Case "l = n :: l'".
    reflexivity.
Qed.

Theorem app_ass:
  forall l1 l2 l3, (l1 ++ l2) ++ l3 = l1 ++ l2 ++ l3.
Proof.
  intros.
  induction l1 as [|n l1'].
  Case "l1 = []".
    reflexivity.
  Case "l1 = n :: l1'".
    simpl. rewrite -> IHl1'.
    reflexivity.
Qed.

Theorem app_length:
  forall l1 l2, length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros.
  induction l1 as [|n l1'].
  Case "l1 = []".
    reflexivity.
  Case "l1 = n :: l1'".
    simpl. rewrite -> IHl1'.
    reflexivity.
Qed.

Fixpoint snoc l v :=
  match l with
  | [] => [v]
  | h :: t => h :: snoc t v
  end.

Fixpoint rev l :=
  match l with
  | [] => []
  | h :: t => snoc (rev t) h
  end.

Example test_rev1: rev [1;2;3] = [3;2;1].
reflexivity. Qed.
Example test_rve2: rev [] = [].
reflexivity. Qed.

Theorem rev_length_firsttry:
  forall l, length (rev l) = length l.
Proof.
  intro.
  induction l as [| n l'].
  Case "l = []".
    reflexivity.
  Case "l = n :: l'".
    simpl.
    rewrite <- IHl'.
Abort.

Theorem length_snoc:
  forall n l, length (snoc l n) = S (length l).
Proof.
  intros.
  induction l as [|n' l'].
  Case "l = []".
    reflexivity.
  Case "l = n' :: l'".
    simpl.
    rewrite -> IHl'.
    reflexivity.
Qed.

Theorem rev_length:
  forall l, length (rev l) = length l.
Proof.
  intro.
  induction l as [|n l'].
  Case "l = []".
    reflexivity.
  Case "l = n :: l'".
    simpl.
    rewrite -> length_snoc.
    rewrite -> IHl'.
    reflexivity.
Qed.

Theorem app_nil_end:
  forall l, l ++ [] = l.
Proof.
  intro.
  induction l as [|n l'].
  Case "l = []".
    reflexivity.
  Case "l = n :: l'".
    simpl.
    rewrite -> IHl'.
    reflexivity.
Qed.

Theorem app_ass4:
  forall l1 l2 l3 l4, l1 ++ l2 ++ l3 ++ l4 = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  intros.
  rewrite -> app_ass.
  rewrite -> app_ass.
  reflexivity.
Qed.

Theorem snoc_append:
  forall l n, snoc l n = l ++ [n].
Proof.
  intros.
  induction l as [|n' l'].
  Case "l = []".
    reflexivity.
  Case "l = n' :: l'".
    simpl.
    rewrite -> IHl'.
    reflexivity.
Qed.

Theorem distr_rev:
  forall l1 l2, rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros.
  induction l1 as [|n l1'].
  Case "l1 = []".
    simpl.
    rewrite -> app_nil_end.
    reflexivity.
  Case "l1 = n :: l1'".
    simpl.
    rewrite -> IHl1'.
    rewrite -> snoc_append.
    rewrite -> snoc_append.
    rewrite -> app_ass.
    reflexivity.
Qed.

Lemma nonzeros_app:
  forall l1 l2, nonzeros (l1 ++ l2) = nonzeros l1 ++ nonzeros l2.
Proof.
  intros.
  induction l1 as [|n l1'].
  Case "l1 = []".
    reflexivity.
  Case "l1 = n :: l1'".
    destruct n as [|n'].
    SCase "n = 0".
      simpl.
      rewrite -> IHl1'.
      reflexivity.
    SCase "n = S n'".
      simpl.
      rewrite -> IHl1'.
      reflexivity.
Qed.

Theorem snoc_pow:
  forall n m l, cons n (snoc l m) = n :: l ++ [m].
Proof.
  intros.
  rewrite -> snoc_append.
  reflexivity.
Qed.

Theorem count_member_nonzero:
  forall (s: bag), ble_nat 1 (count 1 (1 :: s)) = true.
Proof.
  intro.
  reflexivity.
Qed.

Theorem ble_n_Sn:
  forall n, ble_nat n (S n) = true.
Proof.
  intro n.
  induction n as [| n'].
  Case "n = 0".
    reflexivity.
  Case "n = S n'".
    simpl.
    rewrite -> IHn'.
    reflexivity.
Qed.

Theorem remove_decreases_count:
  forall (s: bag),
    ble_nat (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
  intro s.
  induction s as [|n s'].
  Case "s = []".
    reflexivity.
  Case "s = n :: s'".
    destruct n as [|n'].
    simpl.
    rewrite -> ble_n_Sn.
    reflexivity.
    simpl.
    rewrite -> IHs'.
    reflexivity.
Qed.

Theorem count_distr:
  forall n l1 l2, count n (sum l1 l2) = count n l1 + count n l2.
Proof.
  intros.
  induction l1 as [|n' l1'].
  Case "l1 = []".
    reflexivity.
  Case "l1 = n' :: l1'".
    replace (sum (n' :: l1') l2) with (n' :: sum l1' l2).
    simpl.
    rewrite -> IHl1'.
    destruct (beq_nat n n').
    reflexivity.
    reflexivity.
    reflexivity.
Qed.

Theorem rev_involutive:
  forall l, rev (rev l) = l.
Proof.
  intro l.
  induction l as [|n l'].
  Case "l = []".
    reflexivity.
  Case "l = n :: l'".
    simpl.
    rewrite -> snoc_append.
    rewrite -> distr_rev.
    rewrite -> IHl'.
    reflexivity.
Qed.

Theorem rev_injective:
  forall l1 l2, rev l1 = rev l2 -> l1 = l2.
Proof.
  intros l1 l2.
  intro H.
  induction l1 as [|n l1'].
  Case "l1 = []".
    replace l2 with (rev (rev l2)).
    rewrite <- H.
    reflexivity.
    rewrite -> rev_involutive.
    reflexivity.
  Case "l1 = n :: l1'".
    replace (n :: l1') with (rev (rev (n :: l1'))).
    rewrite <- rev_involutive.
    rewrite -> H.
    reflexivity.
    rewrite -> rev_involutive.
    reflexivity.
Qed.

Theorem rev_injective_easy:
  forall l1 l2, rev l1 = rev l2 -> l1 = l2.
Proof.
  intros.
  replace l1 with (rev (rev l1)).
  replace l2 with (rev (rev l2)).
  rewrite -> H.
  reflexivity.
  rewrite -> rev_involutive.
  reflexivity.
  rewrite -> rev_involutive.
  reflexivity.
Qed.

Theorem rev_injective_easier:
  forall l1 l2, rev l1 = rev l2 -> l1 = l2.
Proof.
  intros.
  replace l1 with (rev (rev l1)).
  rewrite -> H.
  rewrite -> rev_involutive.
  reflexivity.
  rewrite -> rev_involutive.
  reflexivity.
Qed.

Theorem rev_injective_easiest:
  forall l1 l2, rev l1 = rev l2 -> l1 = l2.
intros.
  rewrite <- rev_involutive.
  rewrite <- H.
  rewrite -> rev_involutive.
  reflexivity.
Qed.

(*
It would seem I skipped writing rev_involutive on first reading
and thus only came up with the idea of solving that first when
going through my first solution to rev_injective. As you can see
I took down a heavy path on my first go which took multiple attempts
to get to the simplest solution. Yet it might be possible that my
first solution (using involution anyway) could be easier than the
so call hard way.
*)

Inductive natoption :=
  | Some: nat -> natoption
  | None.

Fixpoint index_bad n l :=
  match l with
  | [] => 43
  | a :: l' =>
    if beq_nat n 0
    then a
    else index_bad (pred n) l'
  end.

Fixpoint index n l :=
  match n, l with
  | _, [] => None
  | 0, a :: l' => Some a
  | S n', _ :: l' => index n' l'
  end.

Example test_index1: index 0 [4;5;6;7] = Some 4.
reflexivity. Qed.
Example test_index2: index 3 [4;5;6;7] = Some 7.
reflexivity. Qed.
Example test_index3: index 10 [1;2;3] = None.
reflexivity. Qed.

Definition option_elim d o :=
  match o with
  | Some v => v
  | None => d
  end.

Definition hd_opt l :=
  match l with
  | [] => None
  | x :: _ => Some x
  end.

Example test_hd_opt1: hd_opt [] = None.
reflexivity. Qed.
Example test_hd_opt2: hd_opt [1] = Some 1.
reflexivity. Qed.
Example test_hd_opt3: hd_opt [5;6] = Some 5.
reflexivity. Qed.

Theorem option_elim_hd:
  forall l default, hd default l = option_elim default (hd_opt l).
Proof.
  intros.
  destruct l.
  reflexivity.
  reflexivity.
Qed.

Fixpoint beq_natlist l1 l2 :=
  match l1, l2 with
  | [], [] => true
  | [], _ | _, [] => false
  | a :: l1', b :: l2' =>
     andb (beq_nat a b) (beq_natlist l1' l2')
  end.

Example test_beq_natlist1: beq_natlist nil [] = true.
reflexivity. Qed.
Example test_beq_natlist2: beq_natlist [1;2;3] [1;2;3] = true.
reflexivity. Qed.
Example test_beq_natlist3: beq_natlist [1;2;3] [1;2;4] = false.
reflexivity. Qed.

Theorem beq_natlist_refl:
  forall l, true = beq_natlist l l.
Proof.
  intro l.
  induction l as [|n l'].
  Case "l = []".
    reflexivity.
  Case "l = n :: l'".
    simpl. rewrite -> IHl'.
    rewrite -> beq_nat_refl.
    reflexivity.
Qed.

Module Dictionary.

Inductive dict :=
  | empty
  | record: nat -> nat -> dict -> dict.

Definition insert k v d := record k v d.

Fixpoint find k d :=
  match d with
  | empty => None
  | record k' v d' =>
    if beq_nat k k'
    then Some v
    else find k d'
  end.

Theorem dictionary_invariant1':
  forall d k v, find k (insert k v d) = Some v.
Proof.
  intros.
  simpl.
  rewrite -> beq_nat_refl.
  reflexivity.
Qed.

Theorem dictionary_invarian2':
  forall d m n o,
    beq_nat m n = false -> find m d = find m (insert n o d).
Proof.
  intros.
  simpl.
  rewrite -> H.
  reflexivity.
Qed.

End Dictionary.

End NatList.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Binary relations                                                        *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibBool LibLogic LibProd LibSum.
Require Export LibOperation.

(* ********************************************************************** *)
(** * Generalities on binary relations *)

Definition binary (A : Type) := A -> A -> Prop.

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

Instance binary_inhab : forall A, Inhab (binary A).
Proof using. intros. apply (prove_Inhab (fun _ _ => True)). Qed.

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

Lemma binary_extensional : forall A (R1 R2:binary A),
  (forall x y, R1 x y <-> R2 x y) -> R1 = R2.
Proof using. intros_all. apply~ prop_ext_2. Qed.

Instance binary_extensional_inst : forall A, Extensional (binary A).
Proof using. intros. apply (Build_Extensional _ (@binary_extensional A)). Defined.

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

Section Properties.
Variables (A:Type).
Implicit Types x y z : A.
Implicit Types R : binary A.

(** Reflexivity, irreflexivity, transitivity, symmetry, totality, definedness, functionality *)

Definition refl R :=
  forall x, R x x.
Definition irrefl R :=
  forall x, ~ (R x x).
Definition trans R :=
  forall y x z, R x y -> R y z -> R x z.
Definition sym R :=
  forall x y, R x y -> R y x.
Definition asym R :=
  forall x y, R x y -> ~ R y x.
Definition total R :=
  forall x y, R x y \/ R y x.
Definition defined R :=
  forall x, exists y, R x y.
  (* I would have liked to call this [total R], but this already
     means something else... *)
Definition functional R :=
  forall x y z, R x y -> R x z -> y = z.

(** Antisymmetry with respect to an equivalence relation,
    antisymmetry with respect to Leibnitz equality,
     i.e. [forall x y, R x y -> R y x -> x = y] *)

Definition antisym_wrt (E:binary A) R :=
  forall x y, R x y -> R y x -> E x y.
Definition antisym :=
  antisym_wrt (@eq A).

(** Inclusion between relations *)

Definition incl R1 R2 :=
  forall x y, R1 x y -> R2 x y.

(** Equality between relations *)

(* TODO move further down in the file *)
(* TODO already called binary_extensional above? *)
Lemma rel_eq_intro : forall R1 R2,
  (forall x y, R1 x y <-> R2 x y) -> R1 = R2.
Proof using. intros. extens*. Qed.

Lemma rel_eq_elim : forall R1 R2,
  R1 = R2 -> (forall x y, R1 x y <-> R2 x y).
Proof using. intros. subst*. Qed.

End Properties.

(** Inclusion between a function and a relation. *)
(* TODO: maybe use longer name? *)

Definition incl_fr A B (f : A -> B) (R : A -> B -> Prop) :=
  forall x, R x (f x).
Definition incl_rf A B (R : A -> B -> Prop) (f : A -> B) :=
  forall x y, R x y -> y = f x.

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

Section Constructions.
Variable (A : Type).
Implicit Types R : binary A.
Implicit Types x y z : A.

(** The empty relation *)

Definition empty : binary A :=
  fun x y => False.

(** Swap (i.e. symmetric, converse, or transpose) of a relation *)

Definition flip R : binary A :=
  fun x y => R y x.

(** Complement of a relation *)

Definition compl R : binary A :=
  fun x y => ~ R y x.

(** Union of two relations *)

Definition union R1 R2 : binary A :=
  fun x y => R1 x y \/ R2 x y.

(** Strict order associated with an order, wrt Leibnitz' equality *)

Definition strict R : binary A :=
  fun x y => R x y /\ x <> y.

(** Large order associated with an order, wrt Leibnitz' equality *)

Definition large R : binary A :=
  fun x y => R x y \/ x = y.

End Constructions.

(** Inverse image *)

Definition inverse_image (A B:Type) (R:binary B) (f:A->B) : binary A :=
  fun x y => R (f x) (f y).

(** Composition of two relations, usually written [R1; R2]. *)

Definition sequence (A B C:Type) (R1:A->B->Prop) (R2:B->C->Prop) : A->C->Prop :=
  fun x z => exists y, R1 x y /\ R2 y z.

(** Pointwise product *)

Definition prod2 (A1 A2:Type)
 (R1:binary A1) (R2:binary A2) : binary (A1*A2) :=
  fun p1 p2 : A1*A2 => match p1,p2 with (x1,x2),(y1,y2) =>
    R1 x1 y1 /\ R2 x2 y2 end.

Definition prod3 (A1 A2 A3:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3)
 : binary (A1*A2*A3) :=
  prod2 (prod2 R1 R2) R3.

Definition prod4 (A1 A2 A3 A4:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4)
 : binary (A1*A2*A3*A4) :=
  prod2 (prod3 R1 R2 R3) R4.

Tactic Notation "unfold_prod" :=
  unfold prod4, prod3, prod2.

Tactic Notation "unfolds_prod" :=
  unfold prod4, prod3, prod2 in *.

(** Lexicographical order *)

Definition lexico2 {A1 A2} (R1:binary A1) (R2:binary A2)
  : binary (A1*A2) :=
  fun p1 p2 : A1*A2 => let (x1,x2) := p1 in let (y1,y2) := p2 in
  (R1 x1 y1) \/ (x1 = y1) /\ (R2 x2 y2).

Definition lexico3 {A1 A2 A3}
 (R1:binary A1) (R2:binary A2) (R3:binary A3) : binary (A1*A2*A3) :=
  lexico2 (lexico2 R1 R2) R3.

Definition lexico4 {A1 A2 A3 A4}
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4)
 : binary (A1*A2*A3*A4) :=
  lexico2 (lexico3 R1 R2 R3) R4.

Tactic Notation "unfold_lexico" :=
  unfold lexico4, lexico3, lexico2.

Tactic Notation "unfolds_lexico" :=
  unfold lexico4, lexico3, lexico2 in *.

(* ---------------------------------------------------------------------- *)
(** ** Properties of constructions *)

Section ConstructionsProp.
Variable (A : Type).
Implicit Types R : binary A.
Implicit Types x y z : A.

Lemma refl_elim : forall x y R,
  refl R -> x = y -> R x y.
Proof using. intros_all. subst~. Qed.

Lemma sym_elim : forall x y R,
  sym R -> R x y -> R y x.
Proof using. introv Sy R1. apply* Sy. Qed.

Lemma antisym_elim : forall x y R,
  antisym R -> R x y -> R y x -> x <> y -> False.
Proof using. intros_all*. Qed.

Lemma irrefl_neq : forall R,
  irrefl R ->
  forall x y, R x y -> x <> y.
Proof using. introv H P E. subst. apply* H. Qed.

Lemma irrefl_elim : forall R,
  irrefl R ->
  forall x, R x x -> False.
Proof using. introv H P. apply* H. Qed.

Lemma sym_to_eq : forall R,
  sym R ->
  forall x y, R x y = R y x.
Proof using. introv H. intros. apply prop_ext. split; apply H. Qed.

Lemma sym_flip : forall R,
  sym R -> flip R = R.
Proof using. intros. unfold flip. apply* prop_ext_2. Qed.

Lemma trans_strict : forall R,
  trans R -> antisym R -> trans (strict R).
Proof using.
  introv T S. unfold strict. introv [H1 H2] [H3 H4]. split.
    apply* T.
    intros K. subst. apply H2. apply~ S.
Qed.

Lemma flip_flip : forall R,
  flip (flip R) = R.
Proof using. intros. apply* prop_ext_2. Qed.

Lemma flip_refl : forall R,
  refl R -> refl (flip R).
Proof using. intros_all. unfolds flip. auto. Qed.

Lemma flip_trans : forall R,
  trans R -> trans (flip R).
Proof using. intros_all. unfolds flip. eauto. Qed.

Lemma flip_antisym : forall R,
  antisym R -> antisym (flip R).
Proof using. intros_all. unfolds flip. auto. Qed.

Lemma flip_asym : forall R,
  asym R -> asym (flip R).
Proof using. intros_all. unfolds flip. apply* H. Qed.

Lemma flip_total : forall R,
  total R -> total (flip R).
Proof using. intros_all. unfolds flip. auto. Qed.

Lemma flip_strict : forall R,
  flip (strict R) = strict (flip R).
Proof using. intros. unfold flip, strict. apply* prop_ext_2. Qed.

Lemma flip_large : forall R,
  flip (large R) = large (flip R).
Proof using. intros. unfold flip, large. apply* prop_ext_2. Qed.

Lemma large_refl : forall R,
  refl (large R).
Proof using. unfold large. intros_all~. Qed.

Lemma large_trans : forall R,
  trans R -> trans (large R).
Proof using. unfold large. introv Tr [H1|E1] [H2|E2]; subst*. Qed.

Lemma large_antisym : forall R,
  antisym R -> antisym (large R).
Proof using. introv T. introv H1 H2. (* todo: bug introv *)
  unfolds large. destruct H1; destruct H2; auto. Qed.

Lemma large_total : forall R,
  total R -> total (large R).
Proof using. unfold large. intros_all~. destruct* (H x y). Qed.

Lemma strict_large : forall R,
  irrefl R -> strict (large R) = R.
Proof using.
  intros. unfold large, strict. apply prop_ext_2.
  intros_all. split; intros K.
  autos*.
  split. left*. apply* irrefl_neq.
Qed.

Lemma large_strict : forall R,
  refl R -> large (strict R) = R.
Proof using.
  intros. unfold large, strict. apply prop_ext_2.
  intros_all. split; intros K.
  destruct K. autos*. subst*.
  destruct (classic (x1 = x2)). subst. right*. left*.
  (* todo: cases *)
Qed.

Lemma double_incl : forall R1 R2,
  incl R1 R2 -> incl R2 R1 -> R1 = R2.
Proof using. unfolds incl. intros. apply* prop_ext_2. Qed.

Lemma rel_incl_trans : forall R1 R2 R3,
  incl R1 R2 -> incl R2 R3 -> incl R1 R3.
Proof using.
  unfold incl. eauto.
Qed.

Lemma flip_injective : injective (@flip A).
Proof using.
  intros R1 R2 E. apply prop_ext_2. intros x y.
  unfolds flip. rewrite* (func_same_2 y x E).
Qed.

Lemma eq_by_flip_l : forall R1 R2,
  R1 = flip R2 -> flip R1 = R2.
Proof using. intros. apply flip_injective. rewrite~ flip_flip. Qed.

Lemma eq_by_flip_r : forall R1 R2,
  flip R1 = R2 -> R1 = flip R2.
Proof using. intros. apply flip_injective. rewrite~ flip_flip. Qed.

(* TODO: do we really need this extensional version? *)

Lemma flip_flip_applied : forall R x y,
  (flip (flip R)) x y = R x y.
Proof using. auto. Qed.

End ConstructionsProp.

Lemma trans_elim : forall A (y x z : A) R,
  trans R -> R x y -> R y z -> R x z.
Proof using. introv Tr R1 R2. apply* Tr. Qed.

Lemma trans_sym : forall A (y x z : A) R,
  trans R -> sym R -> R z y -> R y x -> R x z.
Proof using. introv Tr Sy R1 R2. apply* Tr. Qed.

Lemma trans_sym_1 : forall A (y x z : A) R,
  trans R -> sym R -> R y x -> R y z -> R x z.
Proof using. introv Tr Sy R1 R2. apply* Tr. Qed.

Lemma trans_sym_2 : forall A (y x z : A) R,
  trans R -> sym R -> R x y -> R z y -> R x z.
Proof using. introv Tr Sy R1 R2. apply* Tr. Qed.

Implicit Arguments trans_elim [A x z R].
Implicit Arguments trans_sym [A x z R].
Implicit Arguments trans_sym_1 [A x z R].
Implicit Arguments trans_sym_2 [A x z R].

(** Other forms of transitivity *)

Lemma large_strict_trans : forall A y x z (R:binary A),
  trans R -> large R x y -> R y z -> R x z.
Proof using. introv T [E|H] H'; subst*. Qed.

Lemma strict_large_trans : forall A y x z (R:binary A),
  trans R -> R x y -> large R y z -> R x z.
Proof using. introv T H [E|H']; subst*. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Properties about [functional] *)

(* A relation [R] is functional if and only if [flip R] composed
   with [R] is a subset of the diagonal relation [eq]. *)

Lemma functional_characterization : forall A (R : binary A),
  functional R <->
  incl (sequence (flip R) R) eq.
Proof using.
  unfold functional, incl, sequence, flip.
  split.
    introv ? [ ? [ ? ? ]]. eauto.
    eauto.
Qed.

(* The empty relation is functional. *)

Lemma functional_empty : forall A,
  functional (@empty A).
Proof using.
  unfold empty. repeat intro. tauto.
Qed.

(* TODO: a tactic "functional_exploit R" that looks for two distinct
   assumptions in the goal of the form [R ?x ?y] and produces [functional R]
   as subgoal. *)

(* ---------------------------------------------------------------------- *)
(** ** Properties about [union] *)

(* TODO: rename lemmas *)

Lemma prove_rel_union_left : forall A (R1 R2 : binary A) x y,
  R1 x y ->
  union R1 R2 x y.
Proof using.
  unfold union. eauto.
Qed.

Lemma prove_rel_union_right : forall A (R1 R2 : binary A) x y,
  R2 x y ->
  union R1 R2 x y.
Proof using.
  unfold union. eauto.
Qed.

Lemma union_covariant : forall A (R1 R2 S1 S2 : binary A),
  incl R1 S1 ->
  incl R2 S2 ->
  incl (union R1 R2) (union S1 S2).
Proof using.
  unfold incl, union. intuition eauto.
Qed.

Lemma union_refl_left : forall A (R S : binary A),
  refl R ->
  refl (union R S).
Proof using.
  unfold refl, union. eauto.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Properties of inclusion *)

(* TODO change hypothesis names in proofs *)
(* TODO decide whether to use a tactic exploit functional *)

(* TODO there is something by the same name in [LibBag]. *)
Lemma incl_refl : forall A (R:binary A), incl R R.
Proof using. unfolds incl. auto. Qed.

Hint Resolve incl_refl.

Lemma lexico2_incl : forall A1 A2
 (R1 R1':binary A1) (R2 R2':binary A2),
  incl R1 R1' -> incl R2 R2' -> incl (lexico2 R1 R2) (lexico2 R1' R2').
Proof using.
  introv I1 I2. intros [x1 x2] [y1 y2] [H1|[H1 H2]].
  left~. subst. right~.
Qed.

(* If [R] is defined, [S] is functional, and [R] is a subset of [S],
   then [R] equals [S]. In that case, [R] and [S] represent the graph
   of a total function. *)

Lemma defined_incl_functional:
  forall (A : Type) (R S : binary A),
  defined R ->
  functional S ->
  incl R S ->
  R = S.
Proof using.
  introv hdef hfun hincl. eapply binary_extensional. intros v w. split; intros H; eauto.
  forwards [ w' M1 ]: hdef v.
  forwards M2: hincl. eauto.
  forwards: hfun H M2. subst*.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Inclusion between a function and a relation. *)

(* If the relation [R] is functional and if [f] is included in [R],
   then [R] is included in [f], i.e., they coincide. *)

(* TODO: currently limited to the case where B = A, but it shouldn't be *)

Lemma incl_fr_functional:
  forall A (f : A -> A) (R : A -> A -> Prop),
  incl_fr f R ->
  functional R ->
  incl_rf R f.
Proof using.
  introv h1 h2. intros a b H. forwards M: h1 a. forwards*: h2 H M.
Qed.

(* Note: [incl_fr f R] implies [defined R]
         [incl_rf R f] implies [functional R] *)

(* ---------------------------------------------------------------------- *)
(** ** Properties of lexicographical composition *)

Section LexicoApp.
Variables (A1 A2 A3 A4:Type).
Variables (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4).

Lemma lexico2_app_1 : forall x1 x2 y1 y2,
  R1 x1 y1 ->
  lexico2 R1 R2 (x1,x2) (y1,y2).
Proof using. intros. left~. Qed.

Lemma lexico2_app_2 : forall x1 x2 y1 y2,
  x1 = y1 -> R2 x2 y2 ->
  lexico2 R1 R2 (x1,x2) (y1,y2).
Proof using. intros. right~. Qed.

Lemma lexico3_app_1 : forall x1 x2 x3 y1 y2 y3,
  R1 x1 y1 ->
  lexico3 R1 R2 R3 (x1,x2,x3) (y1,y2,y3).
Proof using. intros. left. left~. Qed.

Lemma lexico3_app_2 : forall x1 x2 x3 y1 y2 y3,
  x1 = y1 -> R2 x2 y2 ->
  lexico3 R1 R2 R3 (x1,x2,x3) (y1,y2,y3).
Proof using. intro. left. right~. Qed.

Lemma lexico3_app_3 : forall x1 x2 x3 y1 y2 y3,
  x1 = y1 -> x2 = y2 -> R3 x3 y3 ->
  lexico3 R1 R2 R3 (x1,x2,x3) (y1,y2,y3).
Proof using. intros. right~. Qed.

Lemma lexico4_app_1 : forall x1 x2 x3 x4 y1 y2 y3 y4,
  R1 x1 y1 ->
  lexico4 R1 R2 R3 R4 (x1,x2,x3,x4) (y1,y2,y3,y4).
Proof using. intros. left. left. left~. Qed.

Lemma lexico4_app_2 : forall x1 x2 x3 x4 y1 y2 y3 y4,
  x1 = y1 -> R2 x2 y2 ->
  lexico4 R1 R2 R3 R4 (x1,x2,x3,x4) (y1,y2,y3,y4).
Proof using. intros. left. left. right~. Qed.

Lemma lexico4_app_3 : forall x1 x2 x3 x4 y1 y2 y3 y4,
  x1 = y1 -> x2 = y2 -> R3 x3 y3 ->
  lexico4 R1 R2 R3 R4 (x1,x2,x3,x4) (y1,y2,y3,y4).
Proof using. intros. left. right~. Qed.

Lemma lexico4_app_4 : forall x1 x2 x3 x4 y1 y2 y3 y4,
  x1 = y1 -> x2 = y2 -> x3 = y3 -> R4 x4 y4 ->
  lexico4 R1 R2 R3 R4 (x1,x2,x3,x4) (y1,y2,y3,y4).
Proof using. intros. right~. Qed.

End LexicoApp.

(** Transitivity *)

Lemma lexico2_trans : forall A1 A2
 (R1:binary A1) (R2:binary A2),
  trans R1 -> trans R2 -> trans (lexico2 R1 R2).
Proof using.
  introv Tr1 Tr2. intros [x1 x2] [y1 y2] [z1 z2] Rxy Ryz.
  simpls. destruct Rxy as [L1|[Eq1 L1]];
   destruct Ryz as [M2|[Eq2 M2]]; subst*.
Qed.

Lemma lexico3_trans : forall A1 A2 A3
 (R1:binary A1) (R2:binary A2) (R3:binary A3),
  trans R1 -> trans R2 -> trans R3 -> trans (lexico3 R1 R2 R3).
Proof using.
  introv Tr1 Tr2 Tr3. applys~ lexico2_trans. applys~ lexico2_trans.
Qed.

Lemma lexico4_trans : forall A1 A2 A3 A4
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  trans R1 -> trans R2 -> trans R3 -> trans R4 -> trans (lexico4 R1 R2 R3 R4).
Proof using.
  introv Tr1 Tr2 Tr3. applys~ lexico3_trans. applys~ lexico2_trans.
Qed.

(* ********************************************************************** *)
(** * Equivalence relations *)

Record equiv A (R:binary A) :=
 { equiv_refl : refl R;
   equiv_sym : sym R;
   equiv_trans : trans R }.

(** Equality is an equivalence *)

Lemma eq_equiv : forall A, equiv (@eq A).
Proof using. intros. constructor; intros_all; subst~. Qed.

Hint Resolve eq_equiv.

(** Symmetric of an equivalence is an equivalence *)

Lemma flip_equiv : forall A (E:binary A),
  equiv E -> equiv (flip E).
Proof using.
  introv Equi. unfold flip. constructor; intros_all;
    dintuition eauto.
Qed.

(** Product of two equivalences is an equivalence *)

Lemma prod2_equiv : forall A1 A2 (E1:binary A1) (E2:binary A2),
  equiv E1 -> equiv E2 -> equiv (prod2 E1 E2).
Proof using.
  introv Equi1 Equi2. constructor.
  intros [x1 x2]. simpl. dintuition.
  intros [x1 x2] [y1 y2]. simpl. dintuition.
  intros [x1 x2] [y1 y2] [z1 z2]. simpl. dintuition eauto.
Qed.
(* NEWCOQ: clean above *)

(* todo: other arities of Prod *)

(**************************************************************************)
(* * Closures *)

(* TODO: eliminate the use of the section variable R *)

Section Closures.
Variables (A : Type) (R : binary A).

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

(** Reflexive-transitive closure ( R* ) *)

Inductive rtclosure : binary A :=
  | rtclosure_refl : forall x,
      rtclosure x x
  | rtclosure_step : forall y x z,
      R x y -> rtclosure y z -> rtclosure x z.

(** Transitive closure ( R+ ) *)

Inductive tclosure : binary A :=
  | tclosure_intro : forall x y z,
     R x y -> rtclosure y z -> tclosure x z.

(** Another definition of transitive closure ( R+ ) *)

Inductive tclosure' : binary A :=
  | tclosure'_step : forall x y,
     R x y -> tclosure' x y
  | tclosure'_trans : forall y x z,
     tclosure' x y -> tclosure' y z -> tclosure' x z.

(** Symmetric-transitive closure *)

Inductive stclosure (A:Type) (R:binary A) : binary A :=
  | stclosure_step : forall x y,
      R x y -> stclosure R x y
  | stclosure_sym : forall x y,
      stclosure R x y -> stclosure R y x
  | stclosure_trans : forall y x z,
      stclosure R x y -> stclosure R y z -> stclosure R x z.

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

Hint Constructors tclosure rtclosure equiv.

Lemma rtclosure_once : forall x y,
  R x y -> rtclosure x y.
Proof using. autos*. Qed.

Hint Resolve rtclosure_once.

Lemma rtclosure_trans : trans rtclosure.
Proof using. introv R1 R2. induction* R1. Qed.

Lemma rtclosure_last : forall y x z,
  rtclosure x y -> R y z -> rtclosure x z.
Proof using. introv R1 R2. induction* R1. Qed.

Hint Resolve rtclosure_trans.

Lemma tclosure_once : forall x y,
  R x y -> tclosure x y.
Proof using. eauto. Qed.

Lemma tclosure_rtclosure : forall x y,
  tclosure x y -> rtclosure x y.
Proof using. intros. destruct* H. Qed.

Hint Resolve tclosure_once tclosure_rtclosure.

Lemma tclosure_rtclosure_step : forall x y z,
  rtclosure x y -> R y z -> tclosure x z.
Proof using. intros. induction* H. Qed.

Lemma tclosure_step_rtclosure : forall x y z,
  R x y -> rtclosure y z -> tclosure x z.
Proof using. intros. gen x. induction* H0. Qed.

Lemma tclosure_step_tclosure : forall x y z,
  R x y -> tclosure y z -> tclosure x z.
Proof using. intros. inverts* H0. Qed.

Hint Resolve tclosure_rtclosure_step tclosure_step_rtclosure.

Lemma tclosure_rtclosure_tclosure : forall y x z,
  rtclosure x y -> tclosure y z -> tclosure x z.
Proof using. intros. gen z. induction* H. Qed.

Lemma tclosure_tclosure_rtclosure : forall y x z,
  tclosure x y -> rtclosure y z -> tclosure x z.
Proof using. intros. induction* H. Qed.

Lemma tclosure_trans : trans tclosure.
Proof using. intros_all. autos* tclosure_tclosure_rtclosure. Qed.

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

(** Star induction principle with transitivity hypothesis *)

Lemma rtclosure_ind_trans : forall (P : A -> A -> Prop),
  (forall x : A, P x x) ->
  (forall x y : A, R x y -> P x y) ->
  (forall y x z : A, rtclosure x y -> P x y -> rtclosure y z -> P y z -> P x z) ->
  forall x y : A, rtclosure x y -> P x y.
Proof using.
  introv Hrefl Hstep Htrans S. induction S.
  auto. apply~ (@Htrans y).
Qed.

(** Star induction principle with steps at the end *)

Lemma rtclosure_ind_right : forall (P : A -> A -> Prop),
  (forall x : A, P x x) ->
  (forall y x z : A, rtclosure x y -> P x y -> R y z -> P x z) ->
  forall x y : A, rtclosure x y -> P x y.
Proof using.
  introv Hrefl Hlast. apply rtclosure_ind_trans.
  auto.
  intros. apply~ (Hlast x).
  introv S1 P1 S2 _. gen x. induction S2; introv S1 P1.
     auto.
     apply IHS2. eauto. apply~ (Hlast x).
Qed.

End Closures.

(** Star induction principle with transitivity hypothesis *)

Lemma tclosure_ind_trans : forall A (R:binary A) (P : A -> A -> Prop),
  (forall x y : A, R x y -> P x y) ->
  (forall y x z : A, tclosure R x y -> P x y -> tclosure R y z -> P y z -> P x z) ->
  forall x y : A, tclosure R x y -> P x y.
Proof using.
  Hint Resolve tclosure_once.
  introv Hstep Htrans S. inverts S as HR S. gen x. induction S; introv HR.
    autos*.
    applys* Htrans. constructors*.
Qed.

Hint Resolve rtclosure_refl rtclosure_step rtclosure_once : rtclosure.
(* TODO: should rename and complete the [closure] database *)
(* TODO: should not need to re-export the following version *)

Lemma incl_tclosure_self : forall A (R:binary A),
   incl R (tclosure R).
Proof using. unfolds incl. intros. apply~ tclosure_once. Qed.
Hint Resolve incl_tclosure_self.

(* TODO: sort and complete the following *)

Hint Resolve stclosure_step stclosure_sym stclosure_trans.

Lemma stclosure_le : forall A (R1 R2 : binary A),
  incl R1 R2 -> incl (stclosure R1) (stclosure R2).
Proof using. unfolds incl. introv Le H. induction* H. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Additional definitions *)

(* TODO: move above once section has been eliminated *)
(* A theory of [rstclosure]. *)

Inductive rstclosure (A : Type) (R : binary A) : binary A :=
  | rstclosure_step : forall x y,
      R x y -> rstclosure R x y
  | rstclosure_refl : forall x,
      rstclosure R x x
  | rstclosure_sym : forall x y,
      rstclosure R x y -> rstclosure R y x
  | rstclosure_trans : forall y x z,
      rstclosure R x y -> rstclosure R y z -> rstclosure R x z.

(** Symmetric closure *)

Definition sclosure (A:Type) (R:binary A) : binary A :=
  fun x y => R x y \/ R y x.

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

Hint Constructors tclosure : tclosure.
Hint Constructors rstclosure : rstclosure.
Hint Constructors stclosure : stclosure.
Hint Unfold sclosure : sclosure.

(* ---------------------------------------------------------------------- *)
(** ** Additional properties *)

(* TODO: check name of lemmas below, and sort lemmas *)

Lemma rtclosure_refl_contrapositive : forall A (R : binary A) x y,
  ~ rtclosure R x y ->
  x <> y.
Proof using.
  intros. intro. subst. eauto using rtclosure_refl.
Qed.

Lemma rtclosure_rstclosure : forall A (R : binary A) x y,
  rtclosure R x y -> rstclosure R x y.
Proof using.
  induction 1; eauto with rstclosure.
Qed.

Lemma stclosure_rstclosure : forall A (R : binary A) x y,
  stclosure R x y -> rstclosure R x y.
Proof using.
  induction 1; eauto with rstclosure.
Qed.

Lemma stclosure_is_rstclosure : forall A (R : binary A),
  refl R ->
  stclosure R = rstclosure R.
Proof using.
  intros. eapply binary_extensional. intros x y.
  split; eauto using stclosure_rstclosure.
  gen x y. induction 1; eauto with stclosure.
Qed.

Lemma refl_rstclosure : forall A (R : binary A),
  refl (rstclosure R).
Proof using.
  unfold refl. eauto with rstclosure.
Qed.

Lemma rstclosure_covariant : forall A (R S : binary A),
  incl R S ->
  incl (rstclosure R) (rstclosure S).
Proof using.
  unfold incl. induction 2; eauto with rstclosure.
Qed.

Lemma rstclosure_inflationary: forall A (R : binary A),
  incl R (rstclosure R).
Proof using.
  unfold incl. eauto with rstclosure.
Qed.

Lemma prove_rstclosure_incl : forall A (R S : binary A),
  incl R (rstclosure S) ->
  incl (rstclosure R) (rstclosure S).
Proof using.
  unfold incl. induction 2; eauto with rstclosure.
Qed.

Lemma rstclosure_union : forall A (R S : binary A),
  incl (union (rstclosure R) (rstclosure S))
       (rstclosure (union R S)).
Proof using.
  unfold incl, union. intros ? ? ? x y H.
  destruct H; gen x y;
  induction 1; eauto with rstclosure.
Qed.

Lemma sym_sclosure : forall A (R : binary A),
  sym (sclosure R).
Proof using.
  unfold sym, sclosure. tauto.
Qed.

Lemma sclosure_is_a_closure_operator : forall A (R1 R2 : binary A),
  incl R1 (sclosure R2) ->
  incl (sclosure R1) (sclosure R2).
Proof using.
  unfold sclosure, incl. introv h. introv H.
  destruct H.
  { eauto. }
  { forwards M: h. eauto. destruct M; tauto. }
Qed.

Lemma sclosure_covariant : forall A (R1 R2 : binary A),
  incl R1 R2 ->
  incl (sclosure R1) (sclosure R2).
Proof using.
  unfold sclosure, incl. introv M H. destruct H; eauto.
Qed.

Lemma rtclosure_covariant : forall A (R1 R2 : binary A),
  incl R1 R2 ->
  incl (rtclosure R1) (rtclosure R2).
Proof using.
  unfold incl. induction 2; eauto with rtclosure.
Qed.

Lemma tclosure_covariant : forall A (R1 R2 : binary A),
  incl R1 R2 ->
  incl (tclosure R1) (tclosure R2).
Proof using.
  unfold incl. inversion 2; subst. econstructor.
  eauto.
  eapply rtclosure_covariant; eauto.
Qed.

Lemma tclosure_last : forall A (R : binary A) y x z,
  tclosure R x y -> R y z -> tclosure R x z.
Proof using.
  inversion 1; intros; subst.
  eauto using rtclosure_last with tclosure.
Qed.

(* If a relation is symmetric, then so is its transitive closure. *)

Lemma sym_rtclosure : forall A (R : binary A),
  sym R ->
  sym (rtclosure R).
Proof using.
  unfold sym. induction 2; eauto using rtclosure_last with rtclosure.
Qed.

Lemma sym_tclosure : forall A (R : binary A),
  sym R ->
  sym (tclosure R).
Proof using.
  unfold sym. inversion 2; subst.
  eapply tclosure_rtclosure_step.
  eapply sym_rtclosure; eauto.
  eauto.
Qed.

Lemma sclosure_incl_stclosure : forall A (R : binary A),
  incl (sclosure R) (stclosure R).
Proof using.
  unfold incl. inversion 1; eauto with stclosure.
Qed.

Lemma tclosure_incl_stclosure : forall A (R1 R2 : binary A),
  incl R1 (stclosure R2) ->
  incl (tclosure R1) (stclosure R2).
Proof using.
  introv H M. induction M using tclosure_ind_trans.
  applys* H.
  applys* stclosure_trans.
Qed.

Lemma stclosure_is_tclosure_sclosure : forall A (R : binary A),
  stclosure R = tclosure (sclosure R).
Proof using.
  extens. intros x y. split.
  { gen x y. induction 1.
    { eauto with tclosure sclosure rtclosure. }
    { eapply sym_tclosure. eapply sym_sclosure. eauto. }
    { eapply tclosure_trans; eauto. }
  }
  { intros.
    eapply tclosure_incl_stclosure; [ | eassumption ].
    eapply sclosure_incl_stclosure. }
Qed.