(* begin hide *)
(**********************************************************************)
(* Equations                                                          *)
(* Copyright (c) 2009-2021 Matthieu Sozeau <matthieu.sozeau@inria.fr> *)
(**********************************************************************)
(* This file is distributed under the terms of the                    *)
(* GNU Lesser General Public License Version 2.1                      *)
(**********************************************************************)
(* end hide *)
(** * Normalization of Simply Typed Lambda-Calculus through Hereditary Substitutions.

  Uses extrinsic encoding of terms, with de Bruijn indices, lifting and
  substitution. Derive hereditary substitution function justified by a
  well-founded order on typable terms and conclude with a normalizer building
  beta-short eta-long normal forms, typable in a bidirectional type system. *)

Require Program.
From Equations Require Import Equations.
Require Import Lia.
Require Import List Utf8.

Import ListNotations.

Set Keyed Unification.

Derive Signature for le CompareSpec.

Inductive term :=
| Var (n : nat)
| Lambda (t : term)
| App (t u : term)
| Pair (t u : term)
| Fst (t : term) | Snd (t : term)
| Tt.

Derive NoConfusion Subterm EqDec for term.

Coercion Var : nat >-> term.

Declare Scope term_scope.
Delimit Scope term_scope with term.
Bind Scope term_scope with term.

Notation " @( f , x ) " := (App (f%term) (x%term)).
Notation " 'λ' t " := (Lambda (t%term)) (at level 0).
Notation " << t , u >> " := (Pair (t%term) (u%term)).

Parameter atomic_type : Set.
Parameter atomic_type_eqdec : EqDec atomic_type.
#[export] Existing Instance atomic_type_eqdec.

Inductive type :=
| atom (a : atomic_type)
| product (a b : type)
| unit
| arrow (a b : type).

Derive NoConfusion Subterm EqDec for type.

Coercion atom : atomic_type >-> type.
Notation " x × y " := (product x y) (at level 90).
Notation " x ---> y " := (arrow x y) (at level 30).

Require Import Arith.

Equations lift (k n : nat) (t : term) : term :=
lift k n (Var i) with Nat.compare i k := {
  | Lt := Var i ;
  | _ := Var (i + n) } ;
lift k n (Lambda t) := Lambda (lift (S k) n t) ;
lift k n (App t u) := @(lift k n t, lift k n u) ;
lift k n (Pair t u) := << lift k n t, lift k n u >> ;
lift k n (Fst t) := Fst (lift k n t) ;
lift k n (Snd t) := Snd (lift k n t) ;
lift k n Tt := Tt.

Tactic Notation "absurd"  tactic(tac) := exfalso; tac.

Ltac term_eq :=
  match goal with
    | |- Var _ = Var _ => f_equal ; lia
    | |- @eq nat _ _ => lia || absurd lia
    | |- lt _ _ => lia || absurd lia
    | |- le _ _ => lia || absurd lia
    | |- gt _ _ => lia || absurd lia
    | |- ge _ _ => lia || absurd lia
  end.

#[local] Hint Extern 4 => term_eq : term.

Ltac term := typeclasses eauto with term core arith.

Ltac do_rewrites :=
  repeat
    match goal with
        H : ?lhs = ?rhs |- context [?lhs] => rewrite H; clear H
    end.

Ltac crush := do_rewrites; auto; try term.

Lemma lift0 k t : lift k 0 t = t.
Proof.
  funelim (lift k 0 t); term || rewrite ?H; crush.
Qed.
#[local] Hint Rewrite lift0 : lift.
Require Import Lia.

Lemma lift_k_lift_k k n m t : lift k n (lift k m t) = lift k (n + m) t.
Proof.
  funelim (lift k m t); intros; simp lift; try rewrite H ; try rewrite H0; auto.

  destruct (Nat.compare_spec i k); try discriminate. subst.
  case_eq (Nat.compare (k + n) k); intro H; simp lift; try term.
  rewrite Nat.compare_lt_iff in H; term.
  rewrite Heq; simp lift; term.

  rewrite Heq. rewrite Nat.compare_gt_iff in Heq. simp lift.
  destruct (Nat.compare_spec (i + n) k); try discriminate; simp lift; term.
Qed.
#[local] Hint Rewrite lift_k_lift_k : lift.

Equations subst (k : nat) (t : term) (u : term) : term :=
subst k (Var i) u with Nat.compare i k := {
  | Eq := lift 0 k u ;
  | Lt := i ;
  | Gt := Var (pred i) } ;
subst k (Lambda t) u := Lambda (subst (S k) t u) ;
subst k (App a b) u := @(subst k a u, subst k b u) ;
subst k (Pair a b) u := << subst k a u, subst k b u >> ;
subst k (Fst t) u := Fst (subst k t u) ;
subst k (Snd t) u := Snd (subst k t u) ;
subst k Tt _ := Tt.

Lemma substnn n t : subst n n t = lift 0 n t.
Proof. funelim (subst n n t) ; try rewrite H ; try rewrite H0; simp lift; auto.
  rewrite Nat.compare_lt_iff in Heq; absurd lia.
  rewrite Nat.compare_gt_iff in Heq; absurd lia.
Qed.
#[local] Hint Rewrite substnn : subst.
Notation ctx := (list type).

Reserved Notation " Γ |-- t : A " (at level 70, t, A at next level).

Inductive types : ctx -> term -> type -> Prop :=
| axiom Γ i : i < length Γ -> (Γ |-- i : nth i Γ unit)

| abstraction Γ A B t :
  A :: Γ |-- t : B -> Γ |-- λ t : A ---> B

| application Γ A B t u :
  Γ |-- t : A ---> B -> Γ |-- u : A -> Γ |-- @(t, u) : B

| unit_intro Γ : Γ |-- Tt : unit

| pair_intro Γ A B t u :
  Γ |-- t : A -> Γ |-- u : B ->
    Γ |-- << t , u >> : (A × B)

| pair_elim_fst Γ A B t : Γ |-- t : (A × B) -> Γ |-- Fst t : A

| pair_elim_snd Γ A B t : Γ |-- t : (A × B) -> Γ |-- Snd t : B

where "Γ |-- i : A " := (types Γ i A).

Derive Signature for types.

Notation " [ t ] u " := (subst 0 u t) (at level 10).

Notation " x @ y " := (app x y) (at level 30, right associativity).

Lemma nth_length {A} x t (l l' : list A) : nth (length l) (l @ (t :: l')) x = t.
Proof. induction l; simpl; auto. Qed.

#[local] Hint Constructors types : term.

Lemma nat_compare_elim (P : nat -> nat -> comparison -> Prop)
  (PEq : forall i, P i i Eq)
  (PLt : forall i j, i < j -> P i j Lt)
  (PGt : forall i j, i > j -> P i j Gt) :
  forall i j, P i j (Nat.compare i j).
Proof. intros. case (Nat.compare_spec i j); intros; subst; auto. Qed.

Lemma nth_extend_left {A} (a : A) n (l l' : list A) : nth n l a = nth (length l' + n) (l' @ l) a.
Proof. induction l'; auto. Qed.

Lemma nth_app_l {A} (a : A) {n} (l l' : list A) : n < length l -> nth n (l @ l') a = nth n l a.
Proof.
  revert l l' n; induction l; intros; auto. depelim H. destruct n; trivial.
  simpl. eapply IHl. simpl in H. lia.
Qed.

Lemma nth_app_r {A} (a : A) {n} (l l' : list A) : length l <= n ->
  nth n (l @ l') a = nth (n - length l) l' a.
Proof.
  revert l l' n; induction l; intros; auto. simpl in H. depelim H; auto.
  destruct n; simpl in H. depelim H. simpl; apply IHl; lia.
Qed.

Lemma nth_extend_middle {A} (a : A) n (l l' l'' : list A) :
  match Nat.compare n (length l') with
    | Lt => nth n (l' @ l) a = nth n (l' @ l'' @ l) a
    | _ => nth n (l' @ l) a = nth (n + length l'') (l' @ l'' @ l) a
  end.
Proof.
  assert (foo:=Nat.compare_spec n (length l')).
  depelim foo; fold (length l') in H;
  try rewrite H0; try rewrite H. rewrite <- nth_extend_left.
  replace (length l'') with (length l'' + 0) by auto with arith. rewrite <- nth_extend_left.
  replace (length l') with (length l' + 0) by auto with arith.
  now rewrite <- nth_extend_left.

  clear H0. now rewrite !nth_app_l by trivial.
  clear H0. rewrite !nth_app_r by lia. f_equal. lia.
Qed.

#[local] Hint Rewrite <- app_assoc in_app_iff in_inv : list.

Lemma type_lift Γ t T Γ' : Γ' @ Γ |-- t : T ->
  forall Γ'', Γ' @ Γ'' @ Γ |-- lift (length Γ') (length Γ'') t : T.
Proof.
  intros H.
  depind H; intros; simp lift; eauto with term.

  generalize (nth_extend_middle unit i Γ0 Γ' Γ'').
  destruct Nat.compare; intros H'; rewrite H'; simp lift;
    apply axiom; autorewrite with list in H |- *; lia.

  apply abstraction. rewrite app_comm_cons. now apply IHtypes.
Qed.

Lemma type_lift1 Γ t T A : Γ |-- t : T -> A :: Γ |-- lift 0 1 t : T.
Proof. intros. apply (type_lift Γ t T [] H [A]). Qed.

Lemma type_liftn Γ Γ' t T : Γ |-- t : T -> Γ' @ Γ |-- lift 0 (length Γ') t : T.
Proof. intros. apply (type_lift Γ t T [] H Γ'). Qed.
#[local] Hint Resolve type_lift1 type_lift type_liftn : term.

Ltac crush ::= do_rewrites; simpl; do_rewrites; auto; try term.

Lemma app_cons_snoc_app {A} l (a : A) l' : l ++ (a :: l') = (l ++ a :: nil) ++ l'.
Proof. induction l; crush. Qed.

#[local] Hint Extern 5 => progress (simpl ; autorewrite with list) : term.
Ltac term ::= simp lift subst; try typeclasses eauto with core term.

Lemma substitutive Γ t T Γ' u U :
  (Γ' @ (U :: Γ)) |-- t : T -> Γ |-- u : U ->
  Γ' @ Γ |-- subst (length Γ') t u : T.
Proof with term.
  intros H. depind H; term. intros.

  (* Var *)
  assert (spec:=Nat.compare_spec i (length Γ')).
  depelim spec; try fold (length Γ') in H1; subst;
  try rewrite H1; try rewrite H2 ; simp subst.

  (* Eq *)
  generalize (type_lift Γ0 u U [] H0 Γ'); simpl; intros.
  rewrite app_cons_snoc_app, app_nth1, app_nth2; try (simpl; lia).
  now rewrite <- minus_n_n. term.

  (* Lt *)
  rewrite app_nth1 by lia. rewrite <- (app_nth1 _ Γ0); term.

  (* Gt *)
  rewrite app_nth2; term.
  change (U :: Γ0) with ((cons U nil) @ Γ0). rewrite app_nth2; term.
  simpl. rewrite (nth_extend_left unit _ Γ0 Γ').
  replace (length Γ' + (i - length Γ' - 1)) with (pred i); term.
  apply axiom. autorewrite with list in H |- *. simpl in H. lia.

  (* Abstraction *)
  intros. apply abstraction. now eapply (IHtypes _ _ _ (A :: Γ')).
Qed.

Lemma subst1 Γ t T u U : U :: Γ |-- t : T -> Γ |-- u : U -> Γ |-- subst 0 t u : T.
Proof. intros; now apply (substitutive Γ t T [] u U). Qed.

Reserved Notation " t --> u " (at level 55, right associativity).

Inductive reduce : term -> term -> Prop :=
| red_beta t u : @((Lambda t) , u) --> subst 0 t u
| red_fst t u : Fst << t , u >> --> t
| red_snd t u : Snd << t , u >> --> u

where " t --> u " := (reduce t u).
Derive Signature for reduce.

Require Import Relations.

Definition reduces := clos_refl_trans term reduce.
Notation " t -->* u " := (reduces t u) (at level 55).

Require Import Setoid.

#[local]
Instance: Transitive reduces.
Proof. red; intros. econstructor 3; eauto. Qed.

#[local]
Instance: Reflexive reduces.
Proof. red; intros. econstructor 2; eauto. Qed.

Inductive value : term -> Prop :=
| val_var (i : nat) : value i
| val_unit : value Tt
| val_pair a b : value a -> value b -> value << a, b >>
| val_lambda t : value λ t.
Derive Signature for value.

#[local] Hint Constructors value : term.

Inductive reduce_congr : relation term :=
| reduce1 t u : reduce t u -> reduce_congr t u
| reduce_app_l t t' u : reduce_congr t t' ->
  reduce_congr (@(t, u)) (@(t', u))
| reduce_app_r t u u' : reduce_congr u u' ->
  reduce_congr (@(t, u)) (@(t, u'))
| reduce_pair_l t t' u : reduce_congr t t' ->
  reduce_congr (<< t, u >>) (<< t', u >>)
| reduce_pair_r t u u' : reduce_congr u u' ->
  reduce_congr (<< t, u >>) (<< t, u' >>)
| reduce_fst t t' : reduce_congr t t' -> reduce_congr (Fst t) (Fst t')
| reduce_snd t t' : reduce_congr t t' -> reduce_congr (Snd t) (Snd t').
Derive Signature for reduce_congr.

Ltac find_empty :=
  match goal with
      [ H : _ |- _ ] => solve [ depelim H ]
  end.

Lemma preserves_red1 Γ t τ : Γ |-- t : τ → forall u, t --> u → Γ |-- u : τ.
Proof.
  intros H; induction H; intros t' redtt'; term; try find_empty; depelim redtt'.
  apply subst1 with A. now depelim H. apply H0.
  now depelim H.
  now depelim H.
Qed.

Lemma preserves_redpar Γ t τ : Γ |-- t : τ → forall u, reduce_congr t u → Γ |-- u : τ.
Proof.
  intros H. induction H; intros t' rtt'; depelim rtt'; term; try find_empty.

  depelim H1. depelim H. eapply subst1; eauto.

  depelim H0; depelim H; term.
  depelim H0; depelim H; term.
Qed.

Lemma subject_reduction Γ t τ : Γ |-- t : τ → forall u, t -->* u → Γ |-- u : τ.
Proof. induction 2; eauto using preserves_red1. Qed.
#[local] Hint Constructors reduce reduce_congr : term.
Lemma progress_ t τ : nil |-- t : τ → (exists t', reduce_congr t t') \/ value t.
Proof.
  intros H; depind H; auto with term.

  destruct IHtypes1 as [[t' tt']|vt].
  left; eauto with term.
  destruct IHtypes2 as [[u' uu']|vu].
  left; eauto with term.
  depelim H; [depelim H|depelim vt..].
  left. exists ([u]t0). eauto with term.

  destruct IHtypes1 as [[t' tt']|vt]; eauto with term.
  destruct IHtypes2 as [[u' uu']|vu]; eauto with term.

  destruct IHtypes as [[t' tt']|vt]; eauto with term.
  depelim vt; depelim H;
  eauto with term. depelim H.

  destruct IHtypes as [[t' tt']|vt]; eauto with term.
  depelim vt; depelim H;
  eauto with term. depelim H.
Qed.

Reserved Notation " Γ |-- t => A " (at level 70, t, A at next level).
Reserved Notation " Γ |-- t <= A " (at level 70, t, A at next level).

Inductive atomic : type -> Prop :=
| atomic_atom a : atomic (atom a).

Derive Signature for atomic.
#[local] Hint Constructors atomic : term.

(* FIXME bug *)
Equations? atomic_dec (t : type) : { atomic t } + { ~ atomic t } :=
atomic_dec (atom a) := left (atomic_atom a) ;
atomic_dec t := right _.
Proof. all:(intro H; depelim H). Qed.

Inductive check : ctx -> term -> type -> Prop :=
| abstraction_check Γ A B t :
  A :: Γ |-- t <= B ->
  Γ |-- λ t <= A ---> B

| pair_intro_check Γ A B t u :
  Γ |-- t <= A -> Γ |-- u <= B ->
    Γ |-- << t , u >> <= (A × B)

| unit_intro_check Γ : Γ |-- Tt <= unit

| check_synth Γ t T : atomic T -> Γ |-- t => T -> Γ |-- t <= T

with synthetize : ctx -> term -> type -> Prop :=

| axiom_synth Γ i : i < length Γ ->
  Γ |-- i => nth i Γ unit

| application_synth {Γ A B t u} :
  Γ |-- t => A ---> B -> Γ |-- u <= A -> Γ |-- @(t, u) => B

| pair_elim_fst_synth {Γ A B t} : Γ |-- t => (A × B) -> Γ |-- Fst t => A

| pair_elim_snd_synth {Γ A B t} : Γ |-- t => (A × B) -> Γ |-- Snd t => B

where "Γ |-- i => A " := (synthetize Γ i A)
and  "Γ |-- i <= A " := (check Γ i A).
Derive Signature for check synthetize.

#[local] Hint Constructors synthetize check : term.

Scheme check_mut_ind := Elimination for check Sort Prop
  with synthetize_mut_ind := Elimination for synthetize Sort Prop.

Combined Scheme check_synthetize from check_mut_ind, synthetize_mut_ind.

Lemma synth_arrow {Γ t T} : forall A : Prop, Γ |-- λ (t) => T -> A.
Proof. intros A H. depelim H. Qed.

Lemma synth_pair {Γ t u T} : forall A : Prop, Γ |-- << t, u >> => T -> A.
Proof. intros A H. depelim H. Qed.

Lemma synth_unit {Γ T} : forall A : Prop, Γ |-- Tt => T -> A.
Proof. intros A H. depelim H. Qed.

#[local] Hint Extern 3 =>
  match goal with
    | H : ?Γ |-- ?t => ?T |- _ => apply (synth_arrow _ H) || apply (synth_pair _ H) || apply (synth_unit _ H)
  end : term.

Lemma check_types : (forall Γ t T, Γ |-- t <= T -> Γ |-- t : T)
with synthetizes_types : (forall Γ t T, Γ |-- t => T -> Γ |-- t : T).
Proof. intros. destruct H; try econstructor; term.
  intros. destruct H; try solve [ econstructor; term ].
Qed.

#[local] Hint Resolve check_types synthetizes_types : term.

Inductive normal : term -> Prop :=
| normal_unit : normal Tt
| normal_pair a b : normal a -> normal b -> normal << a, b >>
| normal_abs t : normal t -> normal λ t
| normal_neutral r : neutral r -> normal r

with neutral : term -> Prop :=
| neutral_var i : neutral (Var i)
| neutral_fst t : neutral t -> neutral (Fst t)
| neutral_snd t : neutral t -> neutral (Snd t)
| neutral_app t n : neutral t -> normal n -> neutral (@(t, n)).

Derive Signature for normal neutral.
#[local] Hint Constructors normal neutral : term.

Lemma check_lift_gen Δ t T (H : Δ |-- t <= T) : forall Γ Γ', Δ = Γ' @ Γ ->
  forall Γ'', Γ' @ Γ'' @ Γ |-- lift (length Γ') (length Γ'') t <= T
with synthetize_lift_gen Δ t T (H : Δ |-- t => T) : forall Γ Γ', Δ = Γ' @ Γ ->
  forall Γ'', Γ' @ Γ'' @ Γ |-- lift (length Γ') (length Γ'') t => T.
Proof.
  destruct H; intros; simp lift.

  econstructor.
  change (S (length Γ')) with (length (A :: Γ')). change (A :: Γ' @ Γ'' @ Γ0) with ((A :: Γ') @ Γ'' @ Γ0).
  eapply check_lift_gen; try eassumption. subst. rewrite app_comm_cons; subst; try eassumption; trivial.

  econstructor; eapply check_lift_gen; eassumption.
  econstructor.

  econstructor. eassumption.
  eapply synthetize_lift_gen; eassumption.

  destruct H; intros; simp lift; try solve [econstructor; term].
  clear check_lift_gen synthetize_lift_gen. subst.
  generalize (nth_extend_middle unit i Γ0 Γ' Γ'').
  destruct Nat.compare; intros H'; rewrite H'; simp lift; apply axiom_synth; autorewrite with list in H |- *; lia.
Qed.

Definition check_lift Γ t T Γ' (H : Γ' @ Γ |-- t <= T) :
  forall Γ'', Γ' @ Γ'' @ Γ |-- lift (length Γ') (length Γ'') t <= T :=
  check_lift_gen (Γ' @ Γ) _ _ H _ _ eq_refl.
Definition synthetize_lift Γ t T Γ' (H : Γ' @ Γ |-- t => T) :
  forall Γ'', Γ' @ Γ'' @ Γ |-- lift (length Γ') (length Γ'') t => T :=
  synthetize_lift_gen (Γ' @ Γ) _ _ H _ _ eq_refl.

Lemma check_lift1 {Γ t T A} : Γ |-- t <= T -> A :: Γ |-- lift 0 1 t <= T.
Proof. intros. apply (check_lift Γ t T [] H [A]). Qed.

Lemma synth_lift1 {Γ t T A} : Γ |-- t => T -> A :: Γ |-- lift 0 1 t => T.
Proof. intros. apply (synthetize_lift Γ t T [] H [A]). Qed.
#[local] Hint Resolve check_lift1 synth_lift1 : term.

Lemma check_lift_ctx {Γ t T Γ'} : Γ |-- t <= T -> Γ' @ Γ |-- lift 0 (length Γ') t <= T.
Proof. intros. apply (check_lift Γ t T [] H Γ'). Qed.

Lemma synth_lift_ctx {Γ t T Γ'} : Γ |-- t => T -> Γ' @ Γ |-- lift 0 (length Γ') t => T.
Proof. intros. apply (synthetize_lift Γ t T [] H Γ'). Qed.
#[local] Hint Resolve check_lift_ctx synth_lift_ctx : term.

Equations η (a : type) (t : term) : term :=
η (atom _) t := t ;
η (product a b) t := << η a (Fst t), η b (Snd t) >> ;
η (arrow a b) t := (Lambda (η b @(lift 0 1 t, η a 0)))%term ;
η unit t := Tt.

Lemma checks_arrow Γ t A B : Γ |-- t <= A ---> B → ∃ t', t = λ t' ∧ A :: Γ |-- t' <= B.
Proof. intros H; inversion H; subst.
  exists t0; term.
  inversion H0.
Qed.

Lemma normal_lift {t k n} : normal t → normal (lift k n t)
  with neutral_lift {t k n} : neutral t -> neutral (lift k n t).
Proof. destruct 1; simp lift; constructor; term.
  destruct 1; simp lift; try (constructor; term).
  destruct Nat.compare; term.
Qed.
#[local] Hint Resolve normal_lift neutral_lift : term.

Lemma check_normal {Γ t T} : Γ |-- t <= T -> normal t
 with synth_neutral {Γ t T} : Γ |-- t => T -> neutral t.
Proof. destruct 1; constructor; term. destruct 1; constructor; term. Qed.
#[local] Hint Resolve check_normal synth_neutral : term.

Lemma eta_expand Γ t A : neutral t → Γ |-- t => A -> Γ |-- η A t <= A.
Proof. revert Γ t; induction A; intros; simp η; constructor; term.

  assert(0 < length (A1 :: Γ)) by (simpl; lia).
  specialize (IHA1 (A1 :: Γ) 0 (neutral_var _) (axiom_synth (A1 :: Γ) 0 H1)).
  apply (IHA2 (A1 :: Γ) @(lift 0 1 t, η A1 0)); term.
Qed.

Lemma η_normal : forall Γ A t, neutral t -> Γ |-- t => A -> normal (η A t).
Proof. intros. now apply eta_expand in H0; term. Qed.

(** Going to use the subterm order *)

Require Import Arith Wf_nat.
#[export] Instance wf_nat : Classes.WellFounded lt := lt_wf.

#[local] Hint Constructors Subterm.lexprod : subterm_relation.

Derive Signature for Acc.
Notation lexicographic R S := (Subterm.lexprod _ _ R S).

Definition her_order : relation (type * term * term) :=
  lexicographic (lexicographic type_subterm term_subterm) term_subterm.

#[local] Hint Unfold her_order : subterm_relation.

Import Program.Tactics.
Obligation Tactic := program_simpl.

Arguments exist [A] [P].

Definition hereditary_type (t : type * term * term) :=
  (term * option { u : type | u = (fst (fst t)) \/ type_subterm u (fst (fst t)) })%type.

Inductive IsLambda {t} : hereditary_type t -> Set :=
| isLambda abs a b prf : IsLambda (Lambda abs, Some (exist (arrow a b) prf)).

Equations is_lambda {t} (h : hereditary_type t) : IsLambda h + term :=
is_lambda (pair (Lambda abs) (Some (exist (arrow a b) prf))) := inl (isLambda abs a b prf) ;
is_lambda (pair t' _) := inr t'.
Arguments is_lambda : simpl never.
Lemma is_lambda_inr {t} (h : hereditary_type t) : forall t', is_lambda h = inr t' -> fst h = t'.
Proof.
  let elim := constr:(fun_elim (f:=@is_lambda)) in apply elim; simpl; intros; try congruence.
Qed.

Inductive IsPair {t} : hereditary_type t -> Set :=
| isPair u v a b prf : IsPair (Pair u v, Some (exist (product a b) prf)).

Equations is_pair {t} (h : hereditary_type t) : IsPair h + term :=
is_pair (pair (Pair u v) (Some (exist (product a b) prf))) := inl (isPair u v a b prf) ;
is_pair (pair t' _) := inr t'.
Arguments is_pair : simpl never.

Lemma is_pair_inr {t} (h : hereditary_type t) : forall t', is_pair h = inr t' -> fst h = t'.
Proof.
  let elim := constr:(fun_elim (f:=@is_pair)) in apply elim; simpl; intros; try congruence.
Qed.

Lemma nth_extend_right {A} (a : A) n (l l' : list A) : n < length l ->
  nth n l a = nth n (l @ l') a.
Proof. revert n l'. induction l; simpl; intros; auto. depelim H. destruct n; auto.
  apply IHl. auto with arith.
Qed.

Definition her_type (t : type * term * term) :=
  let u' := fst (fst t) in
   { u : type | u = u' \/ type_subterm u u' }.

#[local] Remove Hints t_step : subterm_relation.
#[local] Remove Hints Subterm.clos_trans_stepr : subterm_relation.

Ltac apply_step :=
  match goal with
    |- clos_trans ?A ?R ?x ?y => not_evar y; eapply t_step
  end.
#[local] Hint Extern 30 (clos_trans _ _ _ _) => apply_step : subterm_relation.

Lemma clos_trans_inv {A} R (x y z : A) :
  clos_trans A R y z → clos_trans A R x y → clos_trans A R x z.
Proof. eauto using t_trans. Qed.

Ltac apply_transitivity :=
  match goal with
    |- clos_trans ?A ?R ?x ?y =>
    not_evar x; not_evar y; eapply clos_trans_inv
  end.
#[local] Hint Extern 31 (clos_trans _ _ _ _) => apply_transitivity : subterm_relation.

Equations? hereditary_subst (t : type * term * term) (k : nat) :
  term * option (her_type t)
  by wf t her_order :=

hereditary_subst (pair (pair A a) t) k with t := {
  | Var i with Nat.compare i k := {
    | Eq := (lift 0 k a, Some (exist A _)) ;
    | Lt := (Var i, None) ;
    | Gt := (Var (pred i), None) } ;

  | Lambda t' := (Lambda (fst (hereditary_subst (A, a, t') (S k))), None) ;

  | App f arg with hereditary_subst (A, a, f) k := {
    | p with is_lambda p := {
        | inl (isLambda f' A' B' prf) :=
          let (f'', y) := hereditary_subst (A', fst (hereditary_subst (A, a, arg) k), f') 0 in
            (f'', Some (exist B' _)) ;
        | inr f' := (@(f', fst (hereditary_subst (A, a, arg) k)), None) } } ;

  | Pair i j :=
    (<< fst (hereditary_subst (A, a, i) k), fst (hereditary_subst (A, a, j) k) >>, None) ;

  | Fst t' with hereditary_subst (A, a, t') k := {
    | p with is_pair p := {
      | inl (isPair u v a' b' prf) := (u, Some (exist a' _)) ;
      | inr p' := (Fst p', None) } } ;

  | Snd t' with hereditary_subst (A, a, t') k := {
    | p with is_pair p := {
      | inl (isPair u v a' b' prf) := (v, Some (exist b' _)) ;
      | inr p' := (Snd p', None) } } ;

  | Tt := (Tt, None) }.
Proof.
  all:(try match goal with |- her_order _ _ =>
                       unfold her_type in *; simpl in *; try (clear; constructor 2; do 2 constructor)
       end).
  1:(destruct prf; subst; eauto 10 with subterm_relation).
  all:(clear -prf; simpl in *; destruct prf; subst; eauto 5 with subterm_relation).
Defined.

#[local] Hint Unfold her_type : subterm_relation.
#[local] Hint Unfold Program.Basics.const : subterm_relation.

Ltac autoh :=
  unfold type_subterm in * ; try typeclasses eauto with hereditary_subst subterm_relation.
Ltac simph :=
  try (rewrite_strat (innermost (hints hereditary_subst)));
  autoh.

#[local] Hint Transparent type_subterm : subterm_relation.

Ltac invert_term :=
  match goal with
    | [ H : check _ (Lambda _) _ |- _ ] => depelim H
    | [ H : check _ (Pair _ _) _ |- _ ] => depelim H
    | [ H : check _ Tt _ |- _ ] => depelim H
    | [ H : types _ ?t _ |- _ ] =>
      match t with
        | Var _ => depelim H
        | Lambda _ => depelim H
        | App _ _ => depelim H
        | Pair _ _ => depelim H
        | Fst _ => depelim H
        | Snd _ => depelim H
        | Tt => depelim H
      end
  end.

Set Regular Subst Tactic.

Lemma hereditary_subst_type Γ Γ' t T u U : Γ |-- u : U -> Γ' @ (U :: Γ) |-- t : T ->
  let (t', o) := hereditary_subst (U, u, t) (length Γ') in
    (Γ' @ Γ |-- t' : T /\ (forall ty prf, o = Some (exist ty prf) -> ty = T)).
Proof.
  intros.
  funelim (hereditary_subst (U, u, t) (length Γ'));
    DepElim.simpl_dep_elim; subst;
    try (split; [ (intros; try discriminate) | solve [ intros; discriminate ] ]);
    DepElim.simplify_dep_elim.

  invert_term. simpl in *. apply abstraction.
  specialize (H Γ (A0 :: Γ')). simpl in H. eqns_specialize_eqs H.
  simpl in H.
  on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
  specialize (H _ H0 H1).
  apply H; auto.

  on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
  on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
  depelim H2. constructor. now apply H. now apply H0.
  depelim H0. term.

  (* Var *) simpl.
  apply Nat.compare_eq in Heq; subst.
  depelim H0.
  rewrite !nth_length. split. term. intros.
  noconf H1. auto.

  (* Lt *)
  apply Nat.compare_lt_iff in Heq. depelim H0.
  replace (nth i (Γ' @ (_ :: Γ)) unit) with (nth i (Γ' @ Γ) unit).
  constructor. rewrite app_length. auto with arith.
  now do 2 rewrite <- nth_extend_right by auto.

  (* Gt *)
  pose (substitutive _ _ _ _ _ _ H0 H).
  simp subst in t. rewrite Heq in t. simp subst in t.

  (* App *)
  simpl in *.
  - on_call (hereditary_subst (A, a, arg)) ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in * ).
    dependent elimination H2 as [application _ U T f arg tyfn tyu].
    specialize (H _ _ H1 tyu).
    specialize (Hind _ _ H1 tyfn). rewrite Heq in Hind.
    destruct Hind as [Ht' Ht''].
    dependent elimination Ht' as [abstraction _ U T abs tyabs].
    eqns_specialize_eqs Ht''. noconf Ht''.
    destruct H as [Ht tty].
    specialize (H0 _ [] _ _ _ _ Ht tyabs eq_refl).
    destruct H0 as [H0 H5].
    split; auto.
    intros ty prf0 Heq'.
    noconf Heq'. auto.

  (* App no redex *)
  - apply is_lambda_inr in Heq. revert Heq.
    intros <-. depelim H1.
    specialize (H _ _ H0 H1_0).
    specialize (Hind _ _ H0 H1_).
    on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in * ).
    on_call (hereditary_subst (A, a, arg)) ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in * ).
    destruct H, Hind. econstructor; eauto.

  (* Fst redex *)
  - simpl in *.
    depelim H0. specialize (Hind _ _ H H0).
    rewrite Heq in Hind.
    destruct Hind. depelim H1. intuition auto.
    eqns_specialize_eqs H2. noconf H2.
    now noconf H1.

  (* Fst no redex *)
  - apply is_pair_inr in Heq. revert Heq.
    on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in * ).
    depelim H0. intros <-.
    specialize (Hind _ _ H H0); eauto.
    destruct Hind. now apply pair_elim_fst with B.

  (* Snd redex *)
  - simpl. depelim H0. specialize (Hind _ _ H H0).
    rewrite Heq in Hind.
    destruct Hind. depelim H1. intuition auto.
    eqns_specialize_eqs H2. noconf H2.
    now noconf H1.

  (* Snd no redex *)
  - apply is_pair_inr in Heq. revert Heq.
    on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in * ).
    intros Ht2; subst t. simpl in *. depelim H0.
    specialize (Hind _ _ H H0); eauto. now apply pair_elim_snd with A0.
Qed.
Print Assumptions hereditary_subst_type.
Import Program.Basics.
#[export] Instance: subrelation eq (flip impl).
Proof. reduce. subst; auto. Qed.

Lemma nth_pred Γ' Γ U n : n > length Γ' -> nth (pred n) (Γ' @ Γ) unit = nth n (Γ' @ (U :: Γ)) unit.
Proof.
  revert_until Γ'. induction Γ'; intros.

  destruct n; auto. depelim H.
  destruct n; auto. simpl pred. simpl.
  rewrite <- IHΓ'. destruct n; auto. simpl in H. depelim H. depelim H.
  simpl in *; lia.
Qed.

Lemma hereditary_subst_subst U u t Γ' :
  (forall Γ T, Γ |-- u <= U ->
    match hereditary_subst (U, u, t) (length Γ') with
      | (t', Some (exist ty _)) =>
         ((Γ' @ (U :: Γ) |-- t <= T -> Γ' @ Γ |-- t' <= T /\ ty = T) /\
          (Γ' @ (U :: Γ) |-- t => T -> Γ' @ Γ |-- t' <= T /\ ty = T))
      | (t', None) =>
        (Γ' @ (U :: Γ) |-- t <= T -> Γ' @ Γ |-- t' <= T) /\
        (Γ' @ (U :: Γ) |-- t => T -> Γ' @ Γ |-- t' => T)
    end).
Proof.
  funelim (hereditary_subst (U, u, t) (length Γ')); simpl in *.
  let Hind := fresh "Hind" in rename H into Hind; intros ?? Hu.
  simpl. simpl in *.

  (** Lambda *)
  - on_call hereditary_subst
            ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    split; intros Hsyn; [| elim (synth_arrow False Hsyn)].

    invert_term. constructor.
    specialize (Hind _ _ _ (A0 :: Γ') eq_refl). simpl in *.
    specialize (Hind _ B Hu).
    destruct o as [[ty prf]|], Hind as [Hind0 Hind1].
    apply Hind0; eauto. eauto.
    elim (synth_arrow False H0).

  (** Pairs *)
  - do 2 on_call hereditary_subst
          ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    split; intros Hsyn; [|elim (synth_pair False Hsyn)].
    invert_term.
    specialize (H0 _ B H1). specialize (H _ A0 H1).
    destruct o as [[ty prf]|], o0 as [[ty' prf']|], H, H0;
      destruct_conjs; constructor; eauto.
    now apply H. now apply H0. now apply H. now apply H0.

    elim (synth_pair False H3).

  (* Unit *)
  - split; intros Hsyn; [|elim (synth_unit False Hsyn)].
    depelim Hsyn. term.
    elim (synth_unit False H1).

  (* Var: eq *)
  - apply Nat.compare_eq in Heq; subst i.
    split; intros Hsyn; depelim Hsyn; rewrite ?nth_length.
    depelim H1; rewrite !nth_length.
    now split; term. split; term.

  (* Lt *)
  - apply Nat.compare_lt_iff in Heq.
    split; intros Hsyn; depelim Hsyn;
    [depelim H1;constructor;auto|];
    (rewrite nth_app_l by lia; rewrite <- nth_app_l with (l':=Γ) by lia;
     constructor; rewrite app_length; auto with arith).

  (* Gt *)
  - apply Nat.compare_gt_iff in Heq.
    split; intros Hsyn; depelim Hsyn.
    depelim H1. constructor. auto.
    replace (nth i (Γ' @ (A :: Γ)) unit) with (nth (pred i) (Γ' @ Γ) unit).
    constructor. rewrite app_length in *. simpl in H1. lia.
    now apply nth_pred.

    replace (nth _ (Γ' @ (_ :: _)) unit) with (nth (pred i) (Γ' @ Γ) unit).
    constructor. rewrite app_length in *. simpl in H0. lia.
    now apply nth_pred.

  (* App *)
  - cbn. on_call (hereditary_subst (A,a,arg))
            ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    specialize (H0 _ _ _ [] eq_refl).
    rewrite Heq in Hind.
    revert H0.
    on_call hereditary_subst
            ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    intros.

    (* Redex *)
    assert((Γ' @ (A :: Γ) |-- @(f, arg) => T → Γ' @ Γ |-- t0 <= T ∧ B' = T)).
    intros Ht; depelim Ht.
    destruct (Hind Γ (A0 ---> T) H1).
    specialize (H _ A' H1).
    destruct (H4 Ht). noconf H6.
    depelim H5. split; auto.

    destruct o; try destruct h; destruct H.
    destruct (H H2). subst x.
    specialize (H0 _ B' H7).
    destruct o0 as [[ty typrf]|]; destruct H0 as [Hcheck Hinf].
    now apply Hcheck. now apply Hcheck.

    specialize (H0 _ B' (H H2)).
    destruct o0 as [[ty typrf]|]; destruct H0 as [Hcheck Hinf].
    now apply Hcheck. now apply Hcheck.

    split; auto.
    depelim H6.

    split; eauto.
    intros Ht3u; apply H2.
    now depelim Ht3u.

  (* No redex *)
  - intros Γ T Hu.
    assert(Γ' @ (A :: Γ) |-- @( f, arg) => T
      → Γ' @ Γ |-- @( f', fst (hereditary_subst (A, a, arg) (length Γ'))) => T).
    intros Ht; depelim Ht.
    on_call hereditary_subst
            ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    revert Heq.
    on_call hereditary_subst
            ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    intros.
    pose (Hind _ (A0 ---> T) Hu).
    destruct o0 as [[ty prf']|].
    + destruct y as [Hind' Hind''].
      specialize (Hind'' Ht). destruct Hind''; subst ty.
      specialize (H _ A0 Hu).
      destruct o as [[ty' prf'']|].
      ++ destruct H as [Hind0 Hind0'].
        specialize (Hind0 H0). destruct Hind0. subst ty'.
        eapply application_synth; eauto. simpl in *.
        depelim H1. simp is_lambda in Heq. noconf Heq.
        depelim H1.

      ++ depelim H1. simp is_lambda in Heq. noconf Heq. depelim H1.
    + clear y. specialize (H _ A0 Hu).
      destruct (Hind _ (A0 ---> T) Hu).
      apply is_lambda_inr in Heq. cbn in Heq; subst t0. simpl.
      destruct o as [[ty prf]|]; destruct H as [Hindt0 Hindt0'].
      eapply application_synth; eauto.
      now apply Hindt0.
      eapply application_synth; eauto.

    + split; auto. intros H2.
      depelim H2.
      constructor; auto.

  (* Pair *)
  - simpl in Heq. autorewrite with is_pair in Heq. simpl in prf.
    intros Γ T Hu.
    assert( (Γ' @ (A :: Γ) |-- Fst t' => T → Γ' @ Γ |-- u <= T ∧ a' = T)).
    intros Ht; depelim Ht. specialize (Hind _ (T × B) Hu). revert Hind.
    on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    noconf Heq.
    intros [Hind Hind'].
    specialize (Hind' Ht). destruct Hind' as [H0 H1]. noconf H1.
    depelim H0. split; auto.
    depelim H0.
    split; auto.
    intros H1. depelim H1. intuition.

  - intros Γ T Hu.
    assert (Γ' @ (A :: Γ) |-- Fst t' => T → Γ' @ Γ |-- Fst p' => T).
    intros Ht; depelim Ht.
    specialize (Hind _ (T × B) Hu). revert Hind.
    on_call hereditary_subst ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    destruct o as [[ty prf]|]. intros [Hind Hind'].
    destruct (Hind' Ht). subst ty.
    depelim H. simp is_pair in Heq. discriminate.
    depelim H.

    apply is_pair_inr in Heq. simpl in Heq ; subst p'.
    intros [Hind Hind']. eapply pair_elim_fst_synth. now apply Hind'.
    split; auto. intros H2. depelim H2. intuition auto with term.

  (* Snd *)
  - intros Γ T Hu.
    assert((Γ' @ (A :: Γ) |-- Snd t' => T → Γ' @ Γ |-- v <= T ∧ b' = T)).

    intros Ht; depelim Ht. specialize (Hind _ (A0 × T) Hu). revert Hind.
    on_call hereditary_subst
            ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    noconf Heq.
    intros [Hind Hind'].
    specialize (Hind' Ht). destruct Hind' as [H0 H1]. noconf H1.
    depelim H0. split; auto. depelim H0.
    split; auto.
    intros H1. depelim H1. intuition auto with term.

  - intros Γ T Hu.
    assert (Γ' @ (A :: Γ) |-- Snd t' => T → Γ' @ Γ |-- Snd p' => T).
    intros Ht; depelim Ht.
    specialize (Hind _ (A0 × T) Hu). revert Hind.
    on_call hereditary_subst
            ltac:(fun c => remember c as hsubst; destruct hsubst; simpl in *).
    destruct o as [[ty prf]|]. intros [Hind Hind'].
    destruct (Hind' Ht). subst ty.
    depelim H. simp is_pair in Heq. discriminate.
    depelim H.

    intros [Hind Hind'].
    apply is_pair_inr in Heq. subst p'. simpl in *.
    specialize (Hind' Ht). econstructor; eauto.

    split; auto. intros H1. depelim H1. term.
Qed.

Print Assumptions hereditary_subst_subst.

Lemma check_liftn {Γ Γ' t T} : Γ |-- t <= T -> Γ' @ Γ |-- lift 0 (length Γ') t <= T.
Proof. intros. apply (check_lift Γ t T [] H Γ'). Qed.

Lemma synth_liftn {Γ Γ' t T} : Γ |-- t => T -> Γ' @ Γ |-- lift 0 (length Γ') t => T.
Proof. intros. apply (synthetize_lift Γ t T [] H Γ'). Qed.
#[local] Hint Resolve check_liftn synth_liftn : term.

(* Write normalization function *)
Lemma types_normalizes Γ t T : Γ |-- t : T → ∃ u, Γ |-- u <= T.
Proof. induction 1. (* eta-exp *)

  exists (η (nth i Γ unit) i).
  apply (eta_expand Γ i (nth i Γ unit) (neutral_var _)); term.

  destruct IHtypes as [t' tt'].
  exists λ t'; term.

  destruct IHtypes1 as [t' tt'].
  destruct IHtypes2 as [u' uu'].

  (* Hereditary substitution *)
  apply checks_arrow in tt'. destruct tt' as [t'' [t't'' t'B]]. subst.

  generalize (hereditary_subst_subst _ _ t'' [] Γ B uu').
  destruct_call hereditary_subst. destruct o. destruct h.
  simpl in *. intros. destruct H1. exists t0; intuition.
  simpl in *. intros. destruct H1. exists t0; intuition.

  (* Unit *)
  exists Tt; term.

  (* Pair *)
  destruct IHtypes1 as [t' tt'].
  destruct IHtypes2 as [u' uu'].
  exists << t' , u' >>. term.

  (* Fst *)
  destruct IHtypes as [t' tt'].
  depelim tt'. exists t0; term.

  depelim H0.

  (* Snd *)
  destruct IHtypes as [t' tt'].
  depelim tt'. exists u; term.

  depelim H0.
Qed.

Print Assumptions types_normalizes.


Require Export Db.Spec.
Require Export Db.Tactics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Export Coq.Program.Equality.
Require Export Coq.Program.Tactics.

Create HintDb ws.
Hint Constructors wsIx : ws.

Local Tactic Notation "crush'" tactic(T) :=
  cbn; intros;
  repeat
    (cbn;
     repeat crushDbSyntaxMatchH;
     crushRewriter;
     T);
  auto.

Lemma ap_wks {X Y} {vrX: Vr X} {wkX: Wk X} {vrY: Vr Y} {wkY: Wk Y}
  {apXY: Ap X Y} {apWkXY: LemApWk X Y} {apYY: Ap Y Y}
  {apCompXY: LemApComp X Y Y} {apWkYY: LemApWk Y Y} :
  ∀ (δ: Dom) (x: X), @wks X _ _ δ x = x[@wkms Y _ _ δ].
Proof.
  induction δ; crush' rewrite ?ap_wk, ?ap_comp.
  f_equal; extensionality i;
    cbn; now rewrite ap_wk.
Qed.

Definition ap_id'      := @ap_id.
Definition ap_comp'    := @ap_comp.
Definition ap_vr'      := @ap_vr.
Definition ap_lift'    := @ap_lift.
Definition ap_wk'      := @ap_wk.
Definition ap_wks'     := @ap_wks.
Definition comp_up'    := @comp_up.
Definition lift_vr'    := @lift_vr.
Definition ap_liftSub' := @ap_liftSub.

Arguments ap_id _ _ {_ _} x.
Arguments ap_comp' _ _ _ {_ _ _ _ _ _} x ξ ζ.
Arguments ap_vr' _ _ {_ _ _ _ _} ξ i.
Arguments ap_lift' _ _ _ {_ _ _ _ _ _ _} ζ x.
Arguments ap_wk' _ _ {_ _ _ _ _ _} x.
Arguments ap_wks' _ _ {_ _ _ _ _ _ _ _ _} δ x.
Arguments comp_up' _ _ {_ _ _ _ _ _} ξ ζ.
Arguments lift_vr' _ _ {_ _ _} i.
Arguments ap_liftSub' _ _ {_ _ _ _} t ξ.

(** *** Domains *)

Lemma dunion_assoc (δ₁ δ₂ δ₃: Dom) :
  δ₁ ∪ (δ₂ ∪ δ₃) = (δ₁ ∪ δ₂) ∪ δ₃.
Proof. induction δ₃; cbn; congruence. Qed.

Section Lemmas.

  Local Ltac crush :=
    crush' rewrite ?ap_vr, ?comp_up.

  (* Injectivity is closed under up. *)
  Lemma InjSubIxUp (ξ: Sub Ix) :
    Inj ξ → Inj (ξ ↑).
  Proof.
    intros ? [|?] [|?] ?; cbn in *;
      auto; discriminate.
  Qed.

  (* The following lemmas have more generic versions, but we stick to the
     specialized Ix versions to make proof search easier. *)
  Section Indices.

    Context {X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.

    (* Up commutes with lift. *)
    Lemma up_liftSub (ξ: Sub Ix) : ⌈ξ⌉↑ = ⌈ξ↑⌉.
    Proof.
      extensionality i; destruct i;
        cbn; now rewrite ?wk_vr.
    Qed.

    Lemma ups_liftSub (δ: Dom) :
      ∀ (ξ: Sub Ix), ⌈ξ⌉ ↑⋆ δ = ⌈ξ ↑⋆ δ⌉.
    Proof.
      induction δ; cbn; intros.
      - reflexivity.
      - now rewrite ?IHδ, ?up_liftSub.
    Qed.
    (* (* Lifting the identity yields the identity. *) *)
    (* Lemma liftSub_id : ⌈idm Ix⌉ = idm X. *)
    (* Proof. reflexivity. Qed. *)

    (* The weakening substitution is just the lifted
         weakening renaming. *)
    Lemma liftSub_wkm : ⌈@wkm Ix _ _⌉ = @wkm X _ _.
    Proof. extensionality i; crush. Qed.

    Lemma liftSub_wkms (δ: Dom) : ⌈@wkms Ix _ _ δ⌉ = @wkms X _ _ δ.
    Proof.
      extensionality i; induction δ; cbn in *.
      - reflexivity.
      - rewrite <- IHδ; cbn.
        rewrite wk_vr; reflexivity.
    Qed.

    Context {apX : Ap X X}.
    Context {apVrX: LemApVr X X}.

    Lemma liftSub_comp (ξ ζ: Sub Ix) :
      @liftSub Ix _ X _  _ (ξ >=> ζ) = ⌈ξ⌉ >=> ⌈ζ⌉.
    Proof. extensionality i; crush. Qed.

    (* Up commutes with the composition with a lifting
       on the left-hand side .*)
    Lemma up_comp_lift (ξ: Sub Ix) (ζ: Sub X):
      (⌈ξ⌉ >=> ζ)↑ = ⌈ξ↑⌉ >=> ζ↑.
    Proof. extensionality i; destruct i; crush. Qed.

  End Indices.

  Section Weakening.

    Context {X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.

    Lemma up_idm : up (idm X) = idm X.
    Proof.
      extensionality i; destruct i; cbn;
        now rewrite ?wk_vr.
    Qed.

    Lemma ups_idm (δ: Dom) : ups (idm X) δ = idm X.
    Proof.
      induction δ; cbn;
        now rewrite ?IHδ, ?up_idm.
    Qed.

    Lemma ups_dunion (ξ: Sub X) δ₁ δ₂ :
       ξ ↑⋆ (δ₁ ∪ δ₂) = (ξ ↑⋆ δ₁) ↑⋆ δ₂.
    Proof. induction δ₂; crush. Qed.

    Lemma ups_up (ξ : Sub X) δ : (ξ ↑⋆ δ) ↑ = ξ ↑⋆ (S δ).
    Proof. reflexivity. Qed.

    Lemma wkm_snoc0 : wkm · vr 0 = idm X.
    Proof. extensionality i; destruct i; crush. Qed.

    Lemma wkms_zero : wkms 0 = idm X.
    Proof. reflexivity. Qed.

    Lemma apply_ups_wks (ξ: Sub X) (δ: Dom) (i: Ix) :
      (ξ ↑⋆ δ) (wks δ i) = wks δ (ξ i).
    Proof. induction δ; crush. Qed.

    Lemma wks_comm δ (ξ: Sub X) :
      ∀ i, wks δ (ξ i) = (ξ ↑⋆ δ) (wks δ i).
    Proof. induction δ; crush. Qed.

    (* Point-wise the weakening substitution is the
       variable injection of the weakening action on
       indices. *)
    Lemma apply_wkms (δ: Dom) (i: Ix) :
      @wkms X _ _ δ i = vr (wks δ i).
    Proof. induction δ; crush. Qed.

    Context {apX : Ap X X}.
    Context {apWkX: LemApWk X X}.

    Lemma apply_up_def_O (ζ: Sub X) :
      (ζ ↑) 0 = vr 0.
    Proof. crush. Qed.

    Lemma apply_up_def_S (ζ: Sub X) :
      ∀ (i: Ix), (ζ ↑) (S i) = (ζ i)[wkm].
    Proof. crush. Qed.

    Lemma up_def (ζ: Sub X) :
      ζ ↑ = (ζ >=> wkm) · vr 0.
    Proof. extensionality i; destruct i; crush. Qed.

    Lemma wkms_succ (δ: Dom) : wkms (S δ) = wkms δ >=> @wkm X _ _.
    Proof. extensionality i; crush. Qed.

  End Weakening.

  Section Application.

    Context {X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.
    Context {apX : Ap X X}.

    Section Het.
      Context {S: Type}.
      Context {vrS : Vr S}.
      Context {wkS : Wk S}.
      Context {apXS: Ap X S}.

      Lemma comp_id_right (ζ: Sub X) :
        ζ >=> idm S = ζ.
      Proof. extensionality i; crush. Qed.

    End Het.

    Context {apVrX: LemApVr X X}.

    Lemma comp_id_left (ζ: Sub X) :
      @idm X _ >=> ζ = ζ.
    Proof. extensionality i; crush. Qed.

    Lemma comp_snoc (ζ₁ ζ₂: Sub X) t :
      (ζ₁ · t) >=> ζ₂ = (ζ₁ >=> ζ₂) · t[ζ₂].
    Proof. extensionality i; destruct i; reflexivity. Qed.

    Context {apWkX: LemApWk X X}.
    Context {apCompX: LemApComp X X X}.

    Lemma apply_wk_ap (x: X) (ζ: Sub X) :
      (wk x)[ζ] = x[wkm >=> ζ].
    Proof. now rewrite ap_wk. Qed.

    Lemma apply_wks_ap δ (x: X) (ζ: Sub X) :
      (wks δ x)[ζ] = x[wkms δ >=> ζ].
    Proof. now rewrite ap_wks, ap_comp. Qed.

    (* Always try to associate to the left in rewriting. *)
    Lemma comp_assoc (ζ₁ ζ₂ ζ₃: Sub X) :
      ζ₁ >=> (ζ₂ >=> ζ₃) = (ζ₁ >=> ζ₂) >=> ζ₃.
    Proof. extensionality i; crush. Qed.

    Lemma wkms_comm δ (ξ: Sub X) :
      ξ      >=> wkms δ =
      wkms δ >=> (ξ ↑⋆ δ).
    Proof.
      pose proof apply_wkms.
      pose proof apply_ups_wks.
      pose proof ap_wks.
      extensionality i; crush.
    Qed.

    Lemma wkm_comm (ξ: Sub X) :
      ξ   >=> wkm =
      wkm >=> ξ↑.
    Proof. apply (wkms_comm 1). Qed.

    Context {Y: Type}.
    Context {vrY: Vr Y}.
    Context {wkY: Wk Y}.
    Context {apXY: Ap X Y}.
    Context {compUpX : LemCompUp X Y}.

    Lemma comp_ups (ξ: Sub X) (ζ: Sub Y) (δ: Dom) :
      (ξ >=> ζ) ↑⋆ δ  = (ξ ↑⋆ δ) >=> (ζ ↑⋆ δ).
    Proof. induction δ; crush. Qed.

  End Application.

  Section BetaInteraction.

    Context {X : Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.
    Context {apX : Ap X X}.
    Context {apWkX: LemApWk X X}.
    Context {apVrX: LemApVr X X}.
    Context {apCompX: LemApComp X X X}.

    Lemma beta_comm δ (ζ₁ ζ₂: Sub X) :
      beta δ ζ₁  >=> ζ₂  =
      (ζ₂ ↑⋆ δ)  >=> beta δ (ζ₁ >=> ζ₂).
    Proof.
      extensionality i. crush. revert ζ₁ ζ₂ i.
      induction δ; crush.
      destruct i; crush.
      rewrite ap_wk, ap_comp; crush.
      f_equal; extensionality j; crush.
    Qed.

    Lemma apply_beta_wks (δ: Dom) :
      ∀ (ξ: Sub X) i, beta δ ξ (wks δ i) = vr i.
    Proof. induction δ; crush. Qed.

    Lemma wkms_beta_cancel δ (ξ: Sub X) :
      wkms δ >=> beta δ ξ = idm X.
    Proof.
      pose proof apply_wkms.
      pose proof apply_beta_wks.
      extensionality i; crush.
    Qed.

    Lemma beta1_comm (x : X) (ζ: Sub X) :
      beta1 x >=> ζ  =
      (ζ ↑)   >=> beta1 x[ζ].
    Proof. apply (beta_comm 1). Qed.

    Lemma wkm_beta1_cancel (x: X) :
      wkm >=> beta1 x = idm X.
    Proof. apply (wkms_beta_cancel 1). Qed.

  End BetaInteraction.

  Section Misc.

    Context {X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.
    Context {apX: Ap X X}.
    Context {apVrX: LemApVr X X}.

    Lemma wkm_snoc_cancel (ζ: Sub X) t : wkm >=> (ζ · t) = ζ.
    Proof. extensionality i; destruct i; crush. Qed.

    Lemma snoc_eta_red (ζ: Sub X) : (wkm >=> ζ) · ζ 0 = ζ.
    Proof. extensionality i; destruct i; crush. Qed.

  End Misc.

  (* This subsection contains pointful variables of the pointfree lemmas of the
     previous subsection. These are intended to be user-facing. The Db.Inst
     module populates the infrastructure database with these lemmas and some
     others such that it results in a terminating rewrite system (hopefully). *)
  Section Pointful.

    Context {T X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.
    Context {apTX: Ap T X}.
    Context {apXX: Ap X X}.
    Context {apCompTX: LemApComp T X X}.
    Context {apVrX: LemApVr X X}.
    Context {apWkX: LemApWk X X}.
    Context {apCompX: LemApComp X X X}.
    Context {compUpX: LemCompUp X X}.

    Local Ltac crushPointful :=
      (* (* Convert renamings into substitutions *) *)
      (* rewrite <- ?ap_liftSub; *)
      (* Go point-free *)
      rewrite ?ap_comp; f_equal;
      (* Flow ups outside *)
      rewrite <- ?comp_up, <- ?comp_ups;
      (* (* Convert lifted weakening renaming into weakening substitution *) *)
      (* rewrite <- ?liftSub_wkm; *)
      (* Apply the point-free lemmas *)
      rewrite ?wkm_comm,
              ?wkm_beta1_cancel,
              ?beta1_comm;
      (* Get rid of identities *)
      rewrite ?up_idm, ?ups_idm, ?ap_id;
      reflexivity.

    Lemma apply_wkm_comm (t: T) (ξ: Sub X) :
      t[ξ][wkm] = t[wkm][ξ↑].
    Proof. crushPointful. Qed.

    Lemma apply_wkm_beta1_cancel (t: T) (x: X) :
      t[wkm][beta1 x] = t.
    Proof. crushPointful. Qed.

    Lemma apply_beta1_comm (t: T) (x: X) (ζ: Sub X) :
      t[beta1 x][ζ] = t[ζ↑][beta1 x[ζ]].
    Proof. crushPointful. Qed.

    (* 1 up variant *)
    Lemma apply_wkm_up_comm (t: T) (ξ: Sub X) :
      t[ξ↑][wkm↑] = t[wkm↑][ξ↑↑].
    Proof. crushPointful. Qed.

    Lemma apply_wkm_beta1_up_cancel (t: T) (x: X) :
      t[wkm↑][(beta1 x)↑] = t.
    Proof. crushPointful. Qed.

    Lemma apply_beta1_up_comm (t: T) (x: X) (ζ: Sub X) :
      t[(beta1 x)↑][ζ↑] = t[ζ↑↑][(beta1 x[ζ])↑].
    Proof. crushPointful. Qed.

    (* 2 ups variant *)
    Lemma apply_wkm_up2_comm (t: T) (ξ: Sub X) :
      t[ξ↑↑][wkm↑↑] = t[wkm↑↑][ξ↑↑↑].
    Proof. crushPointful. Qed.

    Lemma apply_wkm_beta1_up2_cancel (t: T) (x: X) :
      t[wkm↑↑][(beta1 x)↑↑] = t.
    Proof. crushPointful. Qed.

    Lemma apply_beta1_up2_comm (t: T) (x: X) (ζ: Sub X) :
      t[(beta1 x)↑↑][ζ↑↑] = t[ζ↑↑↑][(beta1 x[ζ])↑↑].
    Proof. crushPointful. Qed.

    (* δ ups variant *)
    Lemma apply_wkm_ups_comm (δ: Dom) (t: T) (ξ: Sub X) :
      t[ξ ↑⋆ δ][wkm ↑⋆ δ] = t[wkm ↑⋆ δ][ξ↑ ↑⋆ δ].
    Proof. crushPointful. Qed.

    Lemma apply_wkm_beta1_ups_cancel (δ: Dom) (t: T) (x: X) :
      t[wkm ↑⋆ δ][beta1 x ↑⋆ δ] = t.
    Proof. crushPointful. Qed.

    Lemma apply_beta1_ups_comm (δ: Dom) (t: T) (x: X) (ζ: Sub X) :
      t[beta1 x ↑⋆ δ][ζ ↑⋆ δ] = t[ζ↑ ↑⋆ δ][beta1 x[ζ] ↑⋆ δ].
    Proof. crushPointful. Qed.

  End Pointful.

End Lemmas.

Ltac crushDbLemmasMatchH :=
  match goal with
    | H: context[@ap ?X ?X ?vrX _ ?ξ (@vr ?X ?vrX ?i)] |- _ =>
      replace (@ap X X vrX _ ξ (@vr X vrX i)) with (ξ i) in H by
          refine (eq_sym (ap_vr ξ i))

    | |- context[@up ?X ?vrX ?wkX ?ζ O        ] =>
      change (@up X vrX wkX ζ O) with (@vr X vrX O)
    | |- context[@up _ _ ?wkX (idm _)         ] => rewrite (@up_idm _ _ wkX)
    | |- context[@ups _ _ ?wkX (idm _) ?δ     ] => rewrite (@ups_idm _ _ wkX δ)
    | |- context[@ap ?X ?X ?vrX _ ?ξ (@vr ?X ?vrX ?i)] =>
      replace (@ap X X vrX _ ξ (@vr X vrX i)) with (ξ i) by
          refine (eq_sym (ap_vr ξ i))
  end.

Ltac crushDbLemmasRewriteH :=
  rewrite
    ?dunion_assoc, ?ups_dunion, ?comp_up, ?comp_ups,
    (* ?up_liftSub, ?ups_liftSub, *)
    (* ?ap_liftSub, ?liftSub_wkm, ?liftSub_wkms, ?ap_lift, *)
    <- ?ap_comp,
    ?apply_wkm_comm,     ?apply_wkm_beta1_cancel,     ?apply_beta1_comm,
    ?apply_wkm_up_comm,  ?apply_wkm_beta1_up_cancel,  ?apply_beta1_up_comm,
    ?apply_wkm_up2_comm, ?apply_wkm_beta1_up2_cancel, ?apply_beta1_up2_comm,
    ?apply_wkm_ups_comm, ?apply_wkm_beta1_ups_cancel, ?apply_beta1_ups_comm.

    (* Print liftSub_wkm. *)

    (* Unset Printing Notations. *)
    (* Set Printing Implicit. *)
    (* Print ups_idm. *)

    (* | [|- context[(@liftSub Ix _ ?X _ _ ?ξ)↑]] => replace (@liftSub Ix _ X _ _ ξ)↑ *)
    (*                                                 with (@liftSub Ix _ X _ _ ξ↑) by *)
    (*                                                   exact (eq_sym (up_liftSub ξ)) *)
    (* | [|- context[@liftSub Ix _ ?X _ _ ?ξ ↑⋆ ?δ]] => replace (@liftSub Ix _ X _ _ ξ ↑⋆ δ) *)
    (*                                                 with (@liftSub Ix _ X _ _ (ξ ↑⋆ δ)) by *)
    (*                                                   exact (eq_sym (ups_liftSub δ ξ)) *)

  (* liftSub_id : ⌈idm Ix⌉ = idm X. *)
  (* liftSub_wkm  ⌈@wkm Ix _ _⌉ = @wkm X _ _. *)
  (* liftSub_wkms  ⌈@wkms Ix _ _ δ⌉ = @wkms X _ _ δ. *)


(**************************************************************************
* TLC: A library for Coq                                                  *
* Examples for LibFix                                                     *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
Require Import LibTactics LibLogic LibReflect LibFunc LibEpsilon LibList
  LibInt LibNat LibProd LibSum LibRelation LibWf LibFix LibStream.
Require Import Div2.
Open Scope nat_scope.
Open Scope comp_scope.
Open Scope func_scope.

(** Setting up of automation *)

Hint Resolve lt_wf : wf.

Ltac auto_tilde ::= auto with wf.
Ltac auto_star ::= try solve [ auto | false | math | intuition eauto ].

Hint Resolve list_equiv_equiv.

(* ********************************************************************** *)
(** * DFS *)

Module DFS.

Parameter marks : Type.
Parameter marks_inhab : Inhab marks.
Existing Instance marks_inhab.
Implicit Type i : nat.

Parameter is_marked : marks -> nat -> bool.
Parameter add_mark : marks -> nat -> marks.
Parameter nb_unmarked : marks -> nat.
Parameter add_mark_nb_unmarked : forall m i,
  is_marked m i = false ->
  nb_unmarked (add_mark m i) < nb_unmarked m.

Parameter neighbours : nat -> list nat.

Definition Dfs dfs m i :=
  'let m := add_mark m i in
  'let v := neighbours i in
  'let aux := (fun j m => if is_marked m j then m else dfs m j) in
  fold_left aux m v.

Definition dfs := FixFun2 Dfs.

Lemma fix_dfs : forall m i,
  is_marked m i = false ->
  dfs m i = Dfs dfs m i.
  (* Could be added to the statement:
     /\ (forall m i, is_marked m i = false ->
         nb_unmarked (Dfs dfs m i) < nb_unmarked m). *)
Proof using.
  applys~ FixFun2_fix_partial_inv
    (measure2 (fun m i => nb_unmarked m))
    (fun m i m' => nb_unmarked m' < nb_unmarked m).
  intros m i f1 f2 Hi IH. unfolds Dfs.
  unfold measure2 in IH. sets_eq N: (nb_unmarked m).
  let_name_all. let_name_all.
  let_name_all as aux1. let_name_all as aux2.
  asserts L: (nb_unmarked m0 < N).
    subst N m0. applys* add_mark_nb_unmarked.
  clears m i. gen m0. induction v as [|i v]. simple*.
  intros m Lt. simpl.
  asserts [E F]: (aux1 i m = aux2 i m /\ nb_unmarked (aux1 i m) < N).
    rewrite EQaux1, EQaux2. case_if as C.
      auto.
      forwards* [E L]: IH C. split. auto. math.
  rewrite <- E. applys* IHv.
Qed.

(*
Extraction Language Ocaml.
Extraction Inline Dfs
  FixFun2Mod FixFun2 curry2 uncurry2 FixFunMod.
Set Extraction Optimize.
Extraction dfs.
*)

End DFS.

(* ********************************************************************** *)
(** * COFE for streams *)

(** Definition of stream ordered family of requiv *)

Definition stream_mod_family A (E:binary A) : family nat (stream A) :=
  nat_family (bisimilar_mod_upto E).

(** Special case of comparing stream values wrt equality *)

Definition stream_family A := stream_mod_family (@eq A).

(** Similarity for this OFE is equal to stream bisimilarity *)

Lemma stream_mod_similarity : forall A (E:binary A),
  bisimilar_mod E = similar (stream_mod_family E).
Proof using.
  intros. apply prop_ext_2. intros s1 s2.
  unfold similar. simpl. split.
  intros. apply~ bisimilar_mod_to_upto.
  intros. apply~ bisimilar_mod_take.
Qed.

Hint Resolve stream_mod_similarity.

Lemma stream_similarity : forall A,
  @bisimilar A = similar (stream_family A).
Proof using. intros. apply stream_mod_similarity. Qed.

Hint Resolve stream_similarity.

(** Completeness of the OFE *)

Hint Unfold list_equiv.
Hint Constructors Forall2.

Lemma stream_mod_cofe : forall A {IA:Inhab A} (E:binary A),
  equiv E -> COFE (stream_mod_family E).
Proof using.
  introv IA Equiv. apply nat_cofe. typeclass.
  intros. apply~ bisimilar_mod_upto_equiv.
  introv H. exists (diagonal (fun i => u (S i)) 0).
  induction i; unfolds.
    simple~.
    apply~ bisimilar_mod_upto_succ. apply~ (trans_sym_1 (u i)).
    rewrite stream_diagonal_nth. math_rewrite~ (i + 0 = i).
Qed.

Lemma stream_cofe : forall A {IA:Inhab A}, COFE (stream_family A).
Proof using. intros. apply~ stream_mod_cofe. Qed.

Hint Resolve @stream_cofe.

(* ********************************************************************** *)
(** * Constant stream -- basic corecursive value *)

Definition Const1 const1 := (1%nat) ::: const1.

Definition const1 := FixValMod (@bisimilar nat) Const1.

Lemma const1_fix : const1 === Const1 const1.
Proof using.
  applys~ (FixValMod_fix (stream_family nat)). typeclass.
  intros i s1 s2 H. simpls. destruct~ i.
  unfolds. simpl. constructor~. apply* H.
Qed.

(* ********************************************************************** *)
(** * Constant stream -- basic corecursion *)

Definition Const const (n:nat) := n ::: const n.

Definition const := FixFunMod (@bisimilar nat) Const.

Lemma const_fix : forall n, const n === Const const n.
Proof using.
  intros.
  applys (FixFunMod_corec (stream_family nat) (@pred_true nat)); autos*.
  apply stream_cofe.
  clear n. intros i n s1 s2 _ H. simpls. destruct~ i.
  unfolds. simpl. constructor~. apply* H.
Qed.

(* ********************************************************************** *)
(** * Polymorphic Constant stream -- basic corecursion with polymorphism *)

Definition PConst A pconst (n:A) := n ::: pconst n.

Definition pconst `{IA:Inhab A} := FixFunMod (@bisimilar A) (@PConst A).

Lemma pconst_fix : forall A {IA:Inhab A} (n:A),
  pconst n === PConst pconst n.
Proof using.
  intros.
  applys* (FixFunMod_corec (stream_family A) (@pred_true A)).
  clears n. intros i n s1 s2 _ H. simpls. destruct~ i.
  unfolds. simpl. constructor~. apply* H.
Qed.

Lemma pconst_spec : forall A {IA:Inhab A} (x:A),
  LibStream.const x === pconst x.
Proof using.
  intros.
  apply bisimilar_mod_take. induction i. simple~.
  apply* sym_elim. apply* trans_sym_2.
   apply bisimilar_mod_to_upto. apply pconst_fix.
   simpl. constructor~.
Qed.

(* ********************************************************************** *)
(** * Mutually-defined stream -- basic corecursion *)
(* u = 1::2::3::1::2::3::1::2::3::1::2::3::1::2::3::...*)

Definition MU (mu mv : stream nat) := (1%nat) ::: mv.
Definition MV (mu mv : stream nat) := (2%nat) ::: ((3%nat) ::: mu).

Definition muv := FixValModMut2 (@bisimilar nat) (@bisimilar nat) MU MV.
Definition mu := fst muv.
Definition mv := snd muv.

Lemma uv_fix : mu === MU mu mv /\ mv === MV mu mv.
Proof using.
  applys (FixValModMut2_fix
    (prod_family (stream_family nat) (stream_family nat))).
  apply tuple2_from_proj.
  unfold bisimilar. rewrite stream_mod_similarity. apply prod_similar.
  apply prod_cofe; typeclass.
  intros i u1 v1 u2 v2 H. simpls. destruct~ i. split.
    unfolds. simpl. constructor~. apply* H.
    unfolds. simpl. constructor~. destruct i. simple~. simpl.
     constructor~. apply* H.
Qed.

(* ********************************************************************** *)
(** * Stream of natural numbers *)

Definition Nats nats (n:nat) := n ::: nats (S n).

Definition nats := FixFunMod (@bisimilar nat) Nats.

Lemma nats_fix : forall (n:nat),
  nats n === Nats nats n.
Proof using.
  intros.
  applys (FixFunMod_corec (stream_family nat) (@pred_true nat)); autos*.
  apply stream_cofe.
  clears n. intros i n s1 s2 _ H. simpls. destruct~ i.
  unfolds. simpl. constructor~. apply* H.
Qed.

(* ********************************************************************** *)
(** * Filter on streams *)

Definition dist_to_next A (P:A->Prop) (s:stream A) :=
  epsilon (first_st_at P s).

Lemma eventually_to_dist : forall A (P:A->Prop) s,
  eventually P s -> exists n, first_st_at P s n.
Proof using.
  introv H. induction H. exists 0. simple~.
  destruct (classic (P x)).
    exists 0. simple~.
    destruct IHeventually as [n Pn]. exists (S n). simple~.
Qed.

Lemma eventually_dist_cons : forall A (P:A->Prop) s x,
  eventually P s -> ~ P x ->
  dist_to_next P s < dist_to_next P (x:::s).
Proof using.
  introv H Nx. unfold dist_to_next.
  spec_epsilon as n Pn. apply~ eventually_to_dist.
  spec_epsilon as n' Pn'. apply~ eventually_to_dist.
   apply~ eventually_tail.
  clearbody n n'. destruct n'; simpl in Pn'; tryfalse.
  rewrite* (@first_st_at_unique n n' A P s).
Qed.

Section MyFilters.
Context (A:Type) {IA:Inhab A}.
Variable (P:A->Prop).

Definition Filter filter s :=
  let '(x:::s') := s in
  let s'' := filter s' in
  If P x then x:::s'' else s''.

Definition filter := FixFunMod (@bisimilar A) Filter.

Lemma filter_fix : forall s,
  infinitely_often P s ->
  filter s === Filter filter s.
Proof using.
  applys~ (FixFunMod_mixed_partial
    (stream_family A)
    (measure (dist_to_next P))
    (infinitely_often P)
    (@bisimilar A)).
  intros i s f1 f2 Ps H. simpls.
  destruct s. simpl. unfolds. destruct i. simple~.
   inverts Ps as Ps' Ev. case_if as C.
     simpl. constructor~. apply~ H. left*.
     inverts Ev as Ev.
       false.
       apply~ H. right. split~. apply~ eventually_dist_cons.
Qed.

End MyFilters.

(* ********************************************************************** *)
(** * The log function -- basic recursion *)

(** Definition of the functional *)

Definition Log log n :=
 If n <= 1 then 0 else 1 + log (div2 n).

(** Construction of the fixed point *)

Definition log := FixFun Log.

Lemma fix_log : forall n,
  log n = Log log n.
Proof using.
  applys~ (FixFun_fix (@lt nat _)).
  introv H. unfolds. case_if~.
  fequals. apply H. apply* div2_lt.
Qed.

(** Example of unfolding of the body *)

Lemma log_double : forall n, n > 0 ->
  log(2*n) = 1 + log n.
Proof using.
  introv Pos. rewrite fix_log. unfold Log.
  case_if*. fequals. rewrite~ div2_double.
Qed.

(** Example of reasoning by induction *)

Lemma log_grows : forall n m,
  m <= n -> log m <= log n.
Proof using.
  induction n using peano_induction. introv Le.
  do 2 rewrite fix_log. unfolds Log.
  (do 2 case_if); autos*.
  rew_nat. apply H. apply* div2_lt. apply~ div2_grows.
Qed.

(*
Extraction Language Ocaml.
Extraction Inline Log.
Set Extraction Optimize.
Extraction log.
*)

(* ********************************************************************** *)
(** * Loop on odd numbers -- partial function *)

(** The function [F] defined in this module returns [1]
    on any even number and "loops" on any odd number.
    It does not actually loop, since when a recursive
    call is not made on a smaller argument, the recursion
    is stopped and a dummy value is returned. *)

Require Import Even.

Definition Only_even only_even n :=
  If n = 0 then 1 else
  If n = 1 then 1 + only_even 1 else
  only_even (n - 2).

Definition only_even := FixFun Only_even.

Lemma only_even_fix : forall n, even n ->
  only_even n = Only_even only_even n.
Proof using.
  applys~ (FixFun_fix_partial (@lt nat _)).
  intros f1 f2 n Pn IH. unfolds. case_if~. case_if as C.
  subst. inverts Pn as Pn'. inverts Pn'.
  apply* IH. inverts Pn as Pn'; tryfalse. inverts Pn'. simpl. rew_nat~.
Qed.

(* ********************************************************************** *)
(** * GCD function (binary currified function, by measure) *)

Definition Gcd gcd x y :=
  If x = 0 then y else
  If y = 0 then x else
  If x <= y then gcd x (y-x) else gcd (x-y) y.

(** The measure is the sum of the arguments *)

Definition gcd := FixFun2 Gcd.

Lemma fix_gcd : forall x y,
  gcd x y = Gcd gcd x y.
Proof using.
  applys~ (FixFun2_fix (measure2 plus)).
  unfold measure2. introv IH. unfolds.
  case_if~. case_if~. case_if. apply* IH. apply* IH.
Qed.

(* ********************************************************************** *)
(** * Zero function (nested recursion) *)

(** [zero n] is a function that always returns [0]. *)

Definition Zero zero n :=
  If n = 0 then 0 else zero (zero (n-1)).

Definition zero := FixFun Zero.

Implicit Arguments FixFun_fix_partial_inv [A B F f].

Lemma zero_fix : forall x, zero x = Zero zero x
              /\ forall x, zero x = 0.
Proof using.
  forwards~ [H1 H2]: (FixFun_fix_partial_inv lt pred_true (fun (x y : nat) => y = 0) _ (F:=Zero)).
  introv _ H. unfold Zero. case_if~.
  forwards* [H1 H2]: (H (x-1)). rewrite <- H1. rewrite H2. apply* H.
Qed.

(* ********************************************************************** *)
(** * Ackerman's function (nested non-primitive recursion, two arguments) *)

Ltac emaths := eauto with maths.

Definition Ack ack m n :=
  If m = 0 then n+1 else
  If n = 0 then ack (m-1) 1 else
  ack (m-1) (ack m (n-1)).

Definition ack := FixFun2 Ack.

Lemma fix_ack : forall m n,
  ack m n = Ack ack m n.
Proof using.
  applys~ (FixFun2_fix (lexico2 (@lt nat _) (@lt nat _))).
  introv IH. unfolds. case_if~. case_if~.
  apply IH. emaths.
  rewrite IH. fequals~. emaths. emaths.
Qed.

(* ********************************************************************** *)
(** * McCarthy's 91 function (nested recursion) *)

(** [McCarthy n] returns [n-10] if [n > 100] and returns
    [91] otherwise. It is defined using nested recursion. *)

Definition McCarthy mcCarthy n :=
  If n > 100
    then n - 10
    else mcCarthy (mcCarthy (n + 11)).

Definition mcCarthy := FixFun McCarthy.

Definition McCarthy_post n r :=
  If n > 100 then r = n - 10 else r = 91.

Lemma McCarthy_fix_post :
     (forall n, mcCarthy n = McCarthy mcCarthy n)
  /\ (forall n, McCarthy_post n (mcCarthy n)).
Proof using.
  sets meas: (fun n => If n > 100 then 0 else 101 - n).
  applys~ (FixFun_fix_inv (measure meas)). introv IH.
  unfold McCarthy. unfold McCarthy_post. case_if~.
  forwards [K1 K2]: IH (x+11). unfold measure, meas. case_if; case_if*.
  rewrite <- K1 in *. sets y: (f1(x+11)). unfolds in K2.
  forwards [L1 L2]: IH y. unfold measure, meas. case_if; case_if*. case_if*.
  rewrite <- L1 in *. sets z: (f1 y). unfolds in L2. split~.
  case_if*. case_if*.
Qed.

(** Corrolaries *)

Lemma McCarthy_fix : forall n,
  mcCarthy n = McCarthy mcCarthy n.
Proof using. apply (proj1 (McCarthy_fix_post)). Qed.

Lemma McCarthy_spec_gt100 : forall n,
  n > 100 -> mcCarthy n = n - 10.
Proof using.
  introv Lt. lets H: (proj2 McCarthy_fix_post n). unfolds in H. case_if*.
Qed.

Lemma McCarthy_spec_le100 : forall n,
  n <= 100 -> mcCarthy n = 91.
Proof using.
  introv Le. lets H: (proj2 McCarthy_fix_post n). unfolds in H. case_if*.
Qed.

(* ********************************************************************** *)
(** * Integer division (binary function) *)

Require Import Arith. (* todo : needed?*)

(** [div n m] returns a pair [(q,r)] such that
    [n = q*m + r] with [r < m]. Its definition involves
    non-structural recursion. *)

Definition Div div n m :=
  If n < m then (0,n)
  else let (q,r) := div (n-m) m : nat*nat in
       (q+1,r).

Definition div := FixFun2 Div.

Lemma fix_div : forall n m, m <> 0 ->
  div n m = Div div n m.
Proof using.
  applys~ (FixFun2_fix_partial (measure (@fst nat nat))).
  introv Posm IH. unfold Div. case_if~.
  rewrite~ IH. unfolds. simpl. math.
Qed.

(* ********************************************************************** *)
(** * A function on trees -- higher-order recursion *)

Definition Mem A (x:A) l := Exists (=x) l. (* todo: move *)

(** The congruence rule for [map] on lists *)

Lemma map_congr : forall A B (f1 f2 : A->B) l,
  (forall x, Mem x l -> f1 x = f2 x) ->
  LibList.map f1 l = LibList.map f2 l.
Proof using. Hint Constructors Exists. Hint Unfold Mem.
  introv H. induction l. auto. rew_map. fequals~.
Qed.

(** Definition of trees *)

Inductive tree : Type :=
  | leaf : nat -> tree
  | node : list tree -> tree.

Instance tree_inhab : Inhab tree.
Proof using. intros. apply (prove_Inhab (leaf 0)). Qed.

(** An induction principle for trees *)

Section Tree_induct.
Variables
(P : tree -> Prop)
(Q : list tree -> Prop)
(P1 : forall n, P (leaf n))
(P2 : forall l, Q l -> P (node l))
(Q1 : Q nil)
(Q2 : forall t l, P t -> Q l -> Q (t::l)).

Fixpoint tree_induct_gen (T : tree) : P T :=
  match T as x return P x with
  | leaf n => P1 n
  | node l => P2
      ((fix tree_list_induct (l : list tree) : Q l :=
      match l as x return Q x with
      | nil   => Q1
      | t::l' => Q2 (tree_induct_gen t) (tree_list_induct l')
      end) l)
  end.

End Tree_induct.

Lemma tree_induct : forall (P : tree -> Prop),
  (forall n : nat, P (leaf n)) ->
  (forall l : list tree,
    (forall t, Mem t l -> P t) -> P (node l)) ->
  forall T : tree, P T.
Proof using.
  introv Hl Hn. eapply tree_induct_gen with (Q := fun l =>
    forall t, Mem t l -> P t); intros.
  auto. auto. inversions H. inversions~ H1.
Qed.

(** Definition of immediate subtrees *)

Inductive subtree : binary tree :=
  | subtree_intro : forall t l,
     Mem t l -> subtree t (node l).

Hint Constructors subtree.

Lemma subtree_wf : wf subtree.
Proof using.
  intros t. induction t using tree_induct;
  constructor; introv K; inversions~ K.
Qed.

(** Definition of the [treeincr] function *)

Definition Treeincr treeincr t :=
  match t with
  | leaf n => leaf (S n)
  | node l => node (LibList.map treeincr l)
  end.

Definition treeincr := FixFun Treeincr.

Lemma treeincr_fix : forall t,
  treeincr t = Treeincr treeincr t.
Proof using.
  applys (FixFun_fix subtree).
  reflexivity. apply subtree_wf.
  introv H. unfold Treeincr. destruct x.
    auto.
    fequals. apply~ map_congr.
Qed.

(* ********************************************************************** *)
(** * An example with cofinite trees *)

Require Import LibNat.

(** Definition of [itree], trees with possibly-infinite branches *)

CoInductive itree : Type :=
  | itree_leaf : nat -> itree
  | itree_node : itree -> itree -> itree.

(** The type [itree] is inhabited *)

Instance itree_inhab : Inhab itree.
Proof using. intros. apply (prove_Inhab (itree_leaf 0)). Qed.

(** Similarity up to level [i] between two trees *)

Fixpoint itree_similar_upto (i:nat) (m1 m2: itree) :=
  match i with
  | O => True
  | S i' => match m1,m2 with
     | itree_leaf n1, itree_leaf n2 => n1 = n2
     | itree_node t11 t12, itree_node t21 t22 =>
           itree_similar_upto i' t11 t21
        /\ itree_similar_upto i' t12 t22
     | _, _ => False
     end
  end.

(** Similarity upto is an equivalence *)

Lemma itree_similar_upto_equiv :
  forall i, equiv (itree_similar_upto i).
Proof using.
  constructor; unfolds.
  induction i; intros; simple~. destruct~ x.
  induction i; intros; simple~. destruct x; destruct y; simpls*.
  induction i; intros; simple~. destruct x; destruct y; destruct z; simpls*.
Qed.

Hint Resolve itree_similar_upto_equiv.
Hint Extern 1 (itree_similar_upto ?i _ _) =>
  apply (@equiv_refl _ _ (itree_similar_upto_equiv i)).

(** Construction of the COFE for the family [itree] *)

Definition itree_family := Build_family lt itree_similar_upto.

Definition itree_left t :=
  match t with
  | itree_leaf n => arbitrary
  | itree_node t1 t2 => t1
  end.

Definition itree_right t :=
  match t with
  | itree_leaf n => arbitrary
  | itree_node t1 t2 => t2
  end.

Definition shifts A (u:nat->A) :=
  fun n => u (S n).

CoFixpoint itree_diagonal (u:nat->itree) : itree :=
  match u 0 with
  | itree_leaf n => itree_leaf n
  | itree_node t1 t2 =>
      itree_node (itree_diagonal (itree_left \o shifts u))
                 (itree_diagonal (itree_right \o shifts u))
  end.

Lemma itree_family_COFE : COFE itree_family.
Proof using.
  apply~ nat_cofe'. typeclass.
  introv H. exists (itree_diagonal (shifts u)).
  cuts M: (forall k i u, i <= k ->
    (forall i j : nat, i < j -> itree_similar_upto (S i) (u i) (u j)) ->
      itree_similar_upto (S i) (u k) (itree_diagonal u)).
    intros i. destruct i. simple~.
    sets u': (shifts u). change (u (S i)) with (u' i).
    apply M. math.
      intros i' j' Ri'j'. unfold u', shifts. apply H. math.
  clears u. induction k using peano_induction; introv Lik Coh.
  tests: (k = 0). math_rewrite (i = 0). simpl. destruct~ (u 0).
  unfolds. fold itree_similar_upto.
  forwards S0: (>> Coh 0 k __). math. simpl in S0.
  unfold itree_diagonal; fold itree_diagonal.
  sets_eq <- u0: (u 0). sets_eq <- uk: (u k).
  destruct u0 as [|t01 t02]; destruct uk as [|tk1 tk2]; auto_false.
  split. (* todo: find a way to factorize both sides *)
  (* left subtree *)
  destruct i. simple~.
  sets u': (itree_left \o shifts u).
  asserts_rewrite (tk1 = u' (k-1)).
    unfold u'. unfold compose, shifts, itree_left.
    math_rewrite (S (k - 1) = k). rewrite~ EQuk.
  apply H; try math. intros i' j' Li'j'.
  unfold u'. unfold compose, shifts, itree_left.
  sets_eq i'': (S i'). sets_eq j'': (S j').
  forwards Ssi: (Coh i'' j''). math.
  simpl in Ssi. destruct (u i''); destruct (u j''); auto_false*.
  (* right subtree *)
  destruct i. simple~.
  sets u': (itree_right \o shifts u).
  asserts_rewrite (tk2 = u' (k-1)).
    unfold u'. unfold compose, shifts. unfold itree_right.
    math_rewrite (S (k - 1) = k). rewrite~ EQuk.
  apply H; try math. intros i' j' Li'j'.
  unfold u'. unfold compose, shifts, itree_left.
  sets_eq i'': (S i'). sets_eq j'': (S j').
  forwards Ssi: (Coh i'' j''). math.
  simpl in Ssi. destruct (u i''); destruct (u j''); auto_false*.
Qed.

(** Two equivalent definitions of similarity between two trees,
    one using an coinductive predicate and another constructed
    as the intersection of the "similarity-upto" relations. *)

CoInductive itree_similar : binary itree :=
  | itree_similar_leaf : forall n,
      itree_similar (itree_leaf n) (itree_leaf n)
  | itree_similar_node : forall t11 t12 t21 t22 : itree,
      itree_similar t11 t21 ->
      itree_similar t12 t22 ->
      itree_similar (itree_node t11 t12) (itree_node t21 t22).

Hint Constructors itree_similar.

Lemma itree_similar_eq : itree_similar = similar itree_family.
Proof using.
  apply prop_ext_2. intros t1 t2. iff H.
  intros i. hnf. gen t1 t2. induction i; simpl; introv H.
   auto. inversions~ H.
  hnf in H. gen t1 t2. cofix IH.
   intros t1 t2. destruct t1; destruct t2;
    introv H; lets H1: (H 1); simpl in H1; inversions H1; constructor.
      apply IH. intros i. lets_simpl HSi: (H (S i)). autos*.
      apply IH. intros i. lets_simpl HSi: (H (S i)). autos*.
Qed.

(** A first corecursive operation: the "product" of two trees.
   Note that it always add a head element. *)

Definition Product product m1 m2 :=
  match m1,m2 with
  | itree_node t11 t12, itree_node t21 t22 =>
     itree_node (product t11 t22) (product t12 t21)
  | _, _ => itree_node m1 m2
  end.

Definition product := FixFun2Mod itree_similar Product.

(** We prove that [product] satisfies the fixed point equation *)

Lemma product_fixpoint : forall m1 m2,
  itree_similar (product m1 m2) (Product product m1 m2).
Proof using.
  apply (FixFun2Mod_corec itree_family).
  reflexivity. apply itree_similar_eq. apply itree_family_COFE.
  simpl. introv H. destruct i. simple~. unfold Product.
  destruct x1; destruct x2; simpl; auto with maths.
Qed.

(** And we show that it is productive wrt its arguments *)

Lemma product_incr_similarity : forall i m1 m1' m2 m2',
   itree_similar_upto i m1 m1' ->
   itree_similar_upto i m2 m2' ->
   itree_similar_upto (S i) (product m1 m2) (product m1' m2').
Proof using.
  induction i using peano_induction.
  change (itree_similar_upto) with (family_sim itree_family).
  introv K1 K2. (* todo: setoid rewrite *)
  eapply cofe_similar_modulo. apply itree_family_COFE.
    rewrite <- itree_similar_eq. apply product_fixpoint.
    rewrite <- itree_similar_eq. apply product_fixpoint.
  simpl in K1, K2 |- *.
  destruct m1; destruct m2; simpl; auto.
  destruct m1'; destruct m2'; simple~. destruct~ i. inversions K1.
  destruct m1'; destruct m2'; simple~. destruct~ i. inversions K1.
  destruct m1'; destruct m2'; simple~. destruct~ i. inversions K2.
  destruct m1'; destruct m2'; simple~; destruct~ i.
    inversions K1. inversions K1. inversions K2.
    simpl in K1, K2. destruct K1. destruct K2. auto with maths.
Qed.

(** A second corecursive function, which is not guarded:
    it is productive only because the function [product]
    is productive. *)

Definition Makeitree makeitree m :=
  match m with
  | itree_node t1 t2 => product (makeitree t1) (makeitree t2)
  | itree_leaf n => itree_leaf (S n)
  end.

Definition makeitree := FixFunMod itree_similar Makeitree.

(** Still, we can establish the fixed point equation for our function *)

Lemma makeitree_fixpoint : forall m,
  itree_similar (makeitree m) (Makeitree makeitree m).
Proof using.
  apply (FixFunMod_corec_total itree_family).
  reflexivity. apply itree_similar_eq. apply itree_family_COFE.
  introv H. unfold Makeitree. simpl. destruct x.
  auto.
  destruct i. auto. apply product_incr_similarity.
    apply H; simpl; auto with maths.
    apply H; simpl; auto with maths.
Qed.

(* ********************************************************************** *)
(** * Verification of a recursive parser in CPS form *)

Ltac auto_tilde ::= auto with wf.

(* ---------------------------------------------------------------------- *)
(** ** The assertion construction *)

(** The expression [ ##P## v ] is equivalent to [v],
    with the assertion that [P] holds. If [P] does not hold,
    then the expression is undefined. *)

Definition asserts (P:Prop) (A:Type) `{Inhab A} (v:A) :=
  If P then v else arbitrary.

Notation "'##' P '##' v" := (asserts P v) (at level 69).

Tactic Notation "case_asserts" :=
  unfold asserts; case_if.
Tactic Notation "case_asserts" "~" :=
  case_asserts; auto_tilde.

(* ---------------------------------------------------------------------- *)
(** ** Definition of the data types *)

Inductive regexp : Type :=
  | regexp_null : regexp
  | regexp_empty : regexp
  | regexp_char : nat -> regexp
  | regexp_alt : regexp -> regexp -> regexp
  | regexp_seq : regexp -> regexp -> regexp
  | regexp_star : regexp -> regexp.

Definition text := list nat.

Definition arg_type := (regexp * text * (text -> bool))%type.

(* ---------------------------------------------------------------------- *)
(** ** Definition of the regexp parser as an optimal fixed point *)

Definition Parse (parse : arg_type -> bool) (p : arg_type) : bool :=
  let '(r,s,k) := p in
  match r with
  | regexp_null => false
  | regexp_empty => k s
  | regexp_char c =>
     match s with
     | nil => false
     | c'::s' => If c = c' then k s' else false
     end
  | regexp_alt r1 r2 => parse (r1,s,k) || parse (r2,s,k)
  | regexp_seq r1 r2 => parse (r1,s,(fun s' => parse (r2,s',k)))
  | regexp_star r1 => k s || parse (r1,s,(fun s' => parse (r,s',k)))
  end.

Definition parse := FixFun Parse.

(** At this point, the function [parse] exists and can thus
    be mentioned in other definitions. *)

(* ---------------------------------------------------------------------- *)
(** ** Domain of the parser *)

(** [productive r] is the same as [not (nullable r)];
    it asserts that [r] consumes at least one character *)

Fixpoint productive (r:regexp) : Prop :=
  match r with
  | regexp_null => True
  | regexp_empty => False
  | regexp_char c => True
  | regexp_alt r1 r2 => productive r1 /\ productive r2
  | regexp_seq r1 r2 => productive r1 \/ productive r2
  | regexp_star r1 => False
  end.

(** [normal r] ensures that expressions under a star are productive *)

Fixpoint normal (r:regexp) : Prop :=
  match r with
  | regexp_null => True
  | regexp_empty => True
  | regexp_char c => True
  | regexp_alt r1 r2 => normal r1 /\ normal r2
  | regexp_seq r1 r2 => normal r1 /\ normal r2
  | regexp_star r1 => productive r1 /\ normal r1
  end.

Hint Unfold productive normal.

(** Definition of the domain *)

Definition parse_dom (p:arg_type) :=
  let '(r,s,k) := p in normal r.

(* ---------------------------------------------------------------------- *)
(** ** Termination relation for the parser *)

(** Sub-expression order for [regexp] *)

Inductive regexp_sub : binary regexp :=
  | regexp_sub_seq_1 : forall r1 r2,
      regexp_sub r1 (regexp_seq r1 r2)
  | regexp_sub_seq_2 : forall r1 r2,
      regexp_sub r2 (regexp_seq r1 r2)
  | regexp_sub_alt_1 : forall r1 r2,
      regexp_sub r1 (regexp_alt r1 r2)
  | regexp_sub_alt_2 : forall r1 r2,
      regexp_sub r2 (regexp_alt r1 r2)
  | regexp_sub_star : forall r1,
      regexp_sub r1 (regexp_star r1).

Hint Constructors regexp_sub.

Lemma regexp_sub_wf : wf regexp_sub.
Proof using. intros r. induction r; constructor; intros r' le; inverts~ le. Qed.

Hint Resolve regexp_sub_wf : wf.

(** [text_sub] is the transitive closure of the sub-list order *)

Definition text_sub : binary text := tclosure (@list_sub _).

Lemma text_sub_wf : wf text_sub.
Proof using. lets: tclosure_wf. unfold text_sub. prove_wf. Qed.

Hint Resolve text_sub_wf : wf.

Lemma text_sub_once : forall s c,
  text_sub s (c::s).
Proof using. intros. apply~ tclosure_once. Qed.

Lemma text_sub_trans : trans text_sub.
Proof using. apply tclosure_trans. Qed.

Hint Resolve text_sub_trans text_sub_once.

Lemma text_sub_app : forall s s1 s2,
  s = s1 ++ s2 -> large text_sub s2 s.
Proof using.
  intros. subst. induction s1; rew_list. auto.
  inverts IHs1.
    left. applys~ (@trans_elim text) (s1++s2).
    rewrite <- H. left. apply text_sub_once.
Qed.

(** [parse_sub] is the termination relation used for [parse];
    It is the lexicographical order [(s,r)] *)

Definition parse_sub : binary (regexp * text) :=
  lexico2 regexp_sub text_sub.

Lemma parse_sub_wf : wf parse_sub.
Proof using. prove_wf. Qed.

Hint Unfold parse_sub.
Hint Resolve parse_sub_wf : wf.

(** [parse_arg_sub] is similar to [parse_sub] except that
    it takes triples of the form [(r,s,k)] as arguments *)

Definition parse_arg_sub : binary arg_type :=
  fun p1 p2 => let '(r1,s1,k1) := p1 in let '(r2,s2,k2) := p2 in
               parse_sub (r1,s1) (r2,s2).

Lemma parse_arg_sub_wf : wf parse_arg_sub.
Proof using.
  intros [[r s] k].
  sets_eq p: (r,s). gen k r s. induction_wf IH: parse_sub_wf p.
  intros. subst p. constructor. intros [[r2 s2] k2] S. applys~ IH S.
Qed.

Hint Unfold parse_arg_sub.
Hint Resolve parse_arg_sub_wf : wf.

(* ---------------------------------------------------------------------- *)
(** ** Auxiliary recursive function *)

(** [parse'] is a function equivalen to [parse] except that it includes
    some assertions in order to make termination more obvious.
    Those assertions appear in-between [##] symbols. *)

Definition Parse' (parse : arg_type -> bool) (p : arg_type) : bool :=
  let '(r,s,k) := p in
  match r with
  | regexp_null => false
  | regexp_empty => k s
  | regexp_char c =>
     match s with
     | nil => false
     | c'::s' => If c = c' then k s' else false
     end
  | regexp_alt r1 r2 => parse (r1,s,k) || parse (r2,s,k)
  | regexp_seq r1 r2 => parse (r1,s,(fun s' => parse (r2,s',k)))
  | regexp_star r1 => k s || parse (r1,s,(fun s' => ##text_sub s' s## parse (r,s',k)))
  end.

Definition parse' := FixFun Parse'.

(** Remark: I will show further on how to factorize the definitions
    of [Parse] and [Parse'] so as to avoid the duplication of code. *)

(* ---------------------------------------------------------------------- *)
(** ** Proof of termination of the auxiliary function *)

(** Thanks to the assertions it contains, [parse'] is a total function
    that satisfies a contraction condition, and thus satisfies the
    fixed point equation for [Parse']. *)

Lemma parse'_fix : forall p,
  parse' p = Parse' parse' p.
Proof using.
  applys~ (FixFun_fix parse_arg_sub).
  intros f1 f2 [[r s] k] H. unfolds. destruct r; auto.
  fequal; auto 7.
  rewrite H; [|auto 7]. fequals_rec.
   apply func_ext_1. intros s'. apply~ H.
  fequal. rewrite H; [|auto 7]. fequals_rec.
   apply func_ext_1. intros s'. case_asserts; auto 7.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Properties of the auxiliary function *)

(** [select_sub r] is equivalent to the strict sub-text relation
    when [r] is [productive], and it is otherwise equivalent to
    the large sub-text relation. *)

Definition select_sub (r:regexp) : binary text :=
  If productive r then text_sub else large text_sub.

(** The key result consists in showing that, when [r] is is normal form,
    the computation of [parse' (r,s,k)] is not affected by the evaluations
    of the assertions. *)

Lemma parse'_cont : forall r s k1 k2, normal r ->
  (forall s', select_sub r s' s -> k1 s' = k2 s') ->
  parse' (r,s,k1) = parse' (r,s,k2).
Proof using.
  intros r s. sets_eq p: (r,s). gen r s. induction_wf IH: parse_sub_wf p.
  introv P N E. subst p. do 2 rewrite parse'_fix. unfolds. destruct r; simpl in N.
  auto.
  apply E. hnf. rewrite~ If_r.
  destruct s as [|c' s']. auto. case_if~. apply E. unfolds. rewrite~ If_l.
  inverts N. asserts M: (forall r s', (r = r1 \/ r = r2) -> select_sub r s' s ->
                select_sub (regexp_alt r1 r2) s' s).
    introv C S. hnf in S |- *. simpl. case_if.
      destruct H1. case_if. auto. inverts C; tryfalse.
      case_if~.
   fequals.
     applys~ IH. auto 7. eauto 8.
     applys~ IH. auto 7. eauto 8.
  inverts N. applys~ IH. intros s' S'. applys~ IH.
    intros s'' S''. apply E. hnf in S',S''|-*. simpl.
    tests: (productive r1); tests: (productive r2).
      rewrite~ If_l. applys* (@trans_elim text) s'.
      rewrite~ If_l. applys* (@large_strict_trans text) s'.
      rewrite~ If_l. applys* (@strict_large_trans text) s'.
      rewrite If_r; [|rew_logic';auto]. applys~ (@large_trans text) s'.
  fequals.
    apply E. unfold select_sub. simpl. rewrite~ If_r.
  inverts N. applys~ IH. auto 7. intros s' S'. case_asserts~.
   applys~ IH. hnf in S'. rewrite~ If_l in S'.
   intros s'' S''. apply E. hnf in S'' |- *. simpls. case_if; tryfalse.
   inverts S''. left. applys* trans_elim. auto.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Proof of the fixed point equation for [parse] *)

(** The first step consists in proving that [parse']
    is a fixed point for [Parse] on the domain. This is done
    by showing that the assertions in the continuations are
    irrelevant, using the lemma [parse'_cont]. Yet, the statement
    [ Lemma parse'_fix_Parse_simple : forall p, parse_dom p ->
      parse' p = Parse parse' p. ]
    is not strong enough. Indeed, we need to generalize this
    into a form where we replace [parse'] with an arbitrary
    other total function that behave like [parse'] on the domain. *)

Lemma parse'_fix_Parse :
  fixed_point (pfunc_equal parse_dom) Parse parse'.
Proof using.
  intros f Hf [[r s] k] N. asserts E: (pfunc_equal parse_dom f parse').
    unfolds. apply~ equiv_sym. clear Hf.
  rewrite~ E. rewrite parse'_fix.
  unfold Parse, Parse'. destruct r; auto; simpl in N.
  inverts N. fequals; rewrite~ E.
  inverts N. rewrite~ E. apply~ parse'_cont. intros s' S'. rewrite~ E.
  inverts N. fequals. rewrite~ E. apply~ parse'_cont. intros s' S'.
   hnf in S'. rewrite~ If_l in S'. case_asserts; auto_false. rewrite~ E. simple~.
Qed.

(** The second step consists in proving that the functional [Parse]
    satisfies a contraction condition. This is almost the standard
    contraction condition, except that [f1] is specialized as [parse'].
    In this proof, we exploit the fact that [parse'] depends only
    a subdomain of its continuation. Remark: the statement is equivalent
    to [rec_contractive' eq parse_dom Parse parse_arg_sub parse']. *)

Lemma Parse_contractive_for_parse' : forall f' p, parse_dom p ->
  (forall q, parse_dom q -> parse_arg_sub q p -> parse' q = f' q) ->
  Parse parse' p = Parse f' p.
Proof using.
  introv N IH. unfold Parse. destruct p as [[r s] k].
  hnf in N. destruct r; simpl in N; auto.
  inverts N. fequals; apply~ IH.
  inverts N. erewrite parse'_cont; auto. apply~ IH.
   simpl. intros s' S'. apply~ IH.
  inverts N. fequals. erewrite parse'_cont; auto. apply IH; auto 7.
   simpl. intros s' S'. hnf in S'. rewrite~ If_l in S'. apply~ IH; hnfs~.
Qed.

(** Third and last step: we can put all the pieces together.
    Since [parse'] is a generally-consistent fixed point for [Parse]
    on the domain [parse_dom], [parse'] is extended by [parse],
    which is the optimal fixed point of [Parse]. Hence, [parse]
    and [parse'] agree on the domain [parse_dom]. It follows that
    [parse] satsifies the fixed point equation for [Parse] on the domain. *)

Lemma parse_fix : forall p, parse_dom p ->
  parse p = Parse parse p.
Proof using.
  applys~ (FixFun_fix_partial' (P:=parse_dom) (R:=parse_arg_sub) (F:=Parse) (f':=parse')).
  applys Parse_contractive_for_parse'. apply parse'_fix_Parse.
Qed.

Corollary parse_fix' : forall r s k, normal r ->
  parse (r,s,k) = Parse parse (r,s,k).
Proof using. intros. applys~ parse_fix. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Bonus: factorization of the definitions of [Parse] and [Parse'] *)

(** The idea is to define a single functional that takes as argument a
    function, which is intented to be instantiated either as [asserts]
    or as [ignore]. *)

Definition ignore (P:Prop) (A:Type) `{Inhab A} (v:A) := v.

Section Common.

Context (check : Prop -> forall A `{Inhab A}, A -> A).

Notation "'#' P '#' v" := (@check P _ _ v) (at level 69).

(** Here is the common definition to build [Parse] and [Parse']. *)

Definition Parse_common (parse : arg_type -> bool) (p : arg_type) : bool :=
  let '(r,s,k) := p in
  match r with
  | regexp_null => false
  | regexp_empty => k s
  | regexp_char c =>
     match s with
     | nil => false
     | c'::s' => If c = c' then k s' else false
     end
  | regexp_alt r1 r2 => parse (r1,s,k) || parse (r2,s,k)
  | regexp_seq r1 r2 => parse (r1,s,(fun s' => parse (r2,s',k)))
  | regexp_star r1 => k s || parse (r1,s,(fun s' => #text_sub s' s# parse (r,s',k)))
  end.

End Common.

(** Here are the alternative definitions for [Parse] and [Parse']. *)

Definition Parse_alternative := Parse_common ignore.
Definition Parse'_alternative := Parse_common asserts.

(** Finally, we can check that the alternative definitions are convertible
    with the one we had written by hand previously. *)

Lemma Parse_alternative_correct : Parse = Parse_alternative.
Proof using. reflexivity. Qed.

Lemma Parse'_alternative_correct : Parse' = Parse'_alternative.
Proof using. reflexivity. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Reasoning about [parse] *)

(** The inductively-defined proposition [sem r s] asserts that the
    string [s] matches the regular expression [r]. *)

Inductive sem : regexp -> text -> Prop :=
  | sem_empty :
      sem regexp_empty nil
  | sem_char : forall c,
      sem (regexp_char c) (c::nil)
  | sem_alt_1 : forall r1 r2 s,
      sem r1 s -> sem (regexp_alt r1 r2) s
  | sem_alt_2 : forall r1 r2 s,
      sem r2 s -> sem (regexp_alt r1 r2) s
  | sem_seq : forall r1 r2 s1 s2,
      sem r1 s1 -> sem r2 s2 -> sem (regexp_seq r1 r2) (s1 ++ s2)
  | sem_star_void : forall r1,
      sem (regexp_star r1) nil
  | sem_star_step : forall r1 s1 s2,
      sem r1 s1 ->
      sem (regexp_star r1) s2 ->
      sem (regexp_star r1) (s1 ++ s2).

Hint Constructors sem.

(** Observe that if a string [s] matches a productive regular
    expression [r], then [s] is not the empty string. *)

Lemma sem_productive : forall r s,
  sem r s -> productive r -> s <> nil.
Proof using.
  introv S. induction S; introv P; simpl in P; auto_false*.
  intros E. destruct (app_eq_nil_inv E). subst. destruct* P.
Qed.

(** The continuation [is_nil] holds only of the empty string *)

Definition is_nil (s:text) :=
  match s with nil => true | _ => false end.

(** The first result asserts that if [s] matches [r] semantically,
    then the [parse] function applied to [r] and [s] returns true. *)

Lemma sem_to_parse_ind : forall r s s' k,
  sem r s -> normal r -> k s' = true -> parse (r, s ++ s', k) = true.
Proof using.
  introv S N K. gen s' k N. induction S; intros;
   (rewrite parse_fix; [ | apply N ]); unfold Parse at 1; simpl in N;
   (try match type of N with _ /\ _ => destruct N end).
  rew_list~.
  rew_list. rewrite~ If_l.
  rewrite~ IHS.
  rewrite IHS at 1; auto. rew_bool~.
  rew_list. auto.
  rew_list. rewrite~ K.
  rew_list. rewrite~ IHS1. rew_bool~.
Qed.

Corollary sem_to_parse : forall r s,
  sem r s -> normal r -> parse (r,s,is_nil) = true.
Proof using. intros. forwards~ M: (@sem_to_parse_ind r s nil is_nil). rew_list~ in M. Qed.

(** The second result asserts the reciprocal: if the parse function
    applied to [r] and [s] returns true, then [s] matches [r] semantically. *)

Lemma parse_to_sem_ind : forall r s k,
  normal r -> parse (r,s,k) = true ->
  exists s1 s2, s = s1 ++ s2 /\ sem r s1 /\ k s2 = true.
Proof using.
  introv N P. sets_eq p: (r,s). gen r s k.
  induction_wf IH: parse_sub_wf p. intros. subst p.
  rewrite~ parse_fix in P. unfold Parse in P. destruct r;
   simpl in N; (try match type of N with _ /\ _ => destruct N end).
  false.
  exists (nil:text) s. splits~.
  destruct s; tryfalse. case_if; tryfalse.
   exists (n0::nil) s. splits~.
  case_eq (parse (r1,s,k)); intros P1.
    forwards~ (s1&s2&E&S&P'): IH P1. auto 7. exists~ s1 s2.
    rewrite P1 in P. rew_bool in P.
    forwards~ (s1&s2&E&S&P'): IH P. auto 7. exists~ s1 s2.
  forwards~ (s1&s2&E&S&P'): IH P. auto.
    forwards~ (s3&s4&E'&S'&K): IH P'. auto.
    forwards M: text_sub_app E. subst s s2. exists (s1 ++ s3) s4. rew_list~.
  case_eq (k s); intros K.
    exists (nil:text) s. splits~.
    rewrite K in P. rew_bool in P.
    forwards~ (s1&s2&E&S&P'): IH P. auto.
    forwards~ (s3&s4&E'&S'&K'): IH P'; try solve [hnfs~].
      forwards M: text_sub_app E. inverts M. auto. false.
       applys~ sem_productive S. apply* app_eq_self_inv_r.
    subst s s2. exists (s1++s3) s4. rew_list~.
Qed.

Corollary parse_to_sem : forall r s,
  normal r -> parse (r,s,is_nil) = true -> sem r s.
Proof using.
  intros. forwards~ (s1&s2&E&S&K): (@parse_to_sem_ind r s is_nil).
  subst. destruct s2; tryfalse. rew_list~ in *.
Qed.

(** We can reformulate those two results in the form of an
    equivalence between [sem] and [parse] *)

Theorem parse_iff_sem : forall r s, normal r ->
  (parse (r,s,is_nil) = true <-> sem r s).
Proof using. split. apply~ parse_to_sem. intros. apply~ sem_to_parse. Qed.

(** A similar, more general, result *)

Theorem parse_iff_sem_ind : forall r s k, normal r ->
  (parse (r,s,k) = true <-> (exists s1 s2, s = s1 ++ s2 /\ sem r s1 /\ k s2 = true)).
Proof using.
  split. intros. apply~ parse_to_sem_ind.
  intros (s1&s2&?&?&?). subst. apply~ sem_to_parse_ind.
Qed.