(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2009-04-29 (bigN)
- Frederic Blanqui, 2009-03-19 (setoid)
- Adam Koprowski and Hans Zantema, 2007-03-22

* Termination criterion based on matrix interpretations.

References:
-  J. Endrullis, J. Waldmann and H. Zantema, "Matrix Interpretations for
   Proving Termination of Term Rewriting", Proceedings of the 3rd
   International Joint Conference (IJCAR 2006), 2006.
*)

Set Implicit Arguments.

Require Import LogicUtil Setoid Matrix2 VecUtil AMonAlg2 SN RelUtil
  AWFMInterpretation VecEq NatUtil VecOrd AMatrixBasedInt2_Nat
  VecArith2 OrdSemiRing2.

(***********************************************************************)
(** * Proving termination with matrix interpretation over domain
natural numbers. *)

Section S.

  Variable Sig : Signature.
  Variable dim : nat.
  Notation vec := (vector AN dim).

  Definition matrixInt := @matrixInt matrix.
  Definition mkMatrixInt := @mkMatrixInt matrix.

  Section MonotoneAlgebra.

    Variable m : MatrixMethodConf Sig dim.
    Notation mint := (matrixInt dim).
    Notation vec_invariant := (vec_invariant).
    Notation mi_eval_aux := (mi_eval_aux ).
    Notation trsInt := (trsInt m).

    Definition dom2vec (d: dom dim) := (dom2vec d).
    Parameter mi_eval_ok : forall f v,
      vec_invariant (mi_eval_aux (trsInt f) (Vmap dom2vec v)).
    Definition I := I m mi_eval_ok.
    Definition succeq (d : dom dim) := succeq d.
    Definition refl_succeq (d : dom dim) := refl_succeq d.
    Definition monotone_succeq :=
      @monotone_succeq Sig dim m mi_eval_ok.
    Definition trans_succeq (d : dom dim) := trans_succeq d.
    Definition succeq' := succeq' m.
    Definition succeq'_sub := @succeq'_sub Sig dim m mi_eval_ok.
    Definition succeq'_dec := succeq'_dec m.
    Infix ">=v" := vec_ge (at level 70).
    Definition succ_vec (v1 v2: vector nat dim) :=
      v1 >=v v2 /\ vec_at0 v1 > vec_at0 v2.
    Definition succ v1 v2 := succ_vec (dom2vec v1) (dom2vec v2).

    Lemma succ_wf : WF succ.

    Proof.
      apply WF_incl with (Rof gtN
        (fun v : dom dim => vec_at0 (dom2vec v))).
      unfold succ, succ_vec, Rof, gtN. intros x y. intuition.
      apply WF_inverse. apply gt_WF.
    Qed.

    Lemma trans_succ : transitive succ.

    Proof.
      unfold succ. apply Rof_trans with (f:=dom2vec).
      unfold succ_vec.
      intros v1 v2 v3 h12 h23. intuition.
      apply vec_ge_trans with v2; hyp.
    Qed.

    Lemma succ_succeq_compat : absorbs_left succ succeq.

    Proof.
      intros x z xz. destruct xz as [y [xy yz]]. split.
      apply trans_succeq with y. hyp. destruct yz. hyp.
      apply ge_gt_compatN with (Vnth (dom2vec y)
        (dim_pos dim)). unfold vec_at0.
      apply Vforall2n_nth. hyp.
      destruct yz. hyp.
    Qed.

    Lemma succ_dec : rel_dec succ.

    Proof.
      apply intersection_dec. apply succeq_dec. intros x y.
      apply NatUtil.gt_dec.
    Defined.

    Notation IR_succ := (IR I succ).

    Require Import ATrs.

    Definition rule_mi l r := rule_mi m (@mkRule Sig l r).
    Definition mint_gt n (l r : mint n) :=
      mint_ge l r /\ vec_at0 (const l) > vec_at0 (const r).
    Definition term_gt := term_gt m mint_gt.
    Infix "[+]" := vector_plus (at level 50).

    Lemma vec_plus_gt_compat_l : forall (vl vl' vr vr': vector nat dim),
      vec_at0 vl >= vec_at0 vl' -> vec_at0 vr > vec_at0 vr' ->
      vec_at0 (vl [+] vr) > vec_at0 (vl' [+] vr').

    Proof.
      unfold vec_at0, vector_plus. intros.
      do 2 rewrite Vnth_map2.
      unfold Aplus. apply plus_gt_compat_rN; hyp.
    Qed.

    Lemma mint_eval_mon_succ : forall (val : valuation I) k
      (mi mi' : mint k), mint_gt mi mi' ->
      succ_vec (mint_eval val mi) (mint_eval val mi').

    Proof.
      intros. destruct H. split.
      apply mint_eval_mon_succeq. hyp.
      unfold mint_eval, add_vectors. simpl.
      apply vec_plus_gt_compat_l.
      unfold vec_at0.
      apply Vforall2n_nth.
      exact (mint_eval_mon_succeq_args _ H). hyp.
    Qed.

    Notation vec := (vector AN).

    Add Parametric Relation n : (vec n) (@eq_vec n) reflexivity proved
      by (@eq_vec_refl AN eqAN sid_theoryAN n) symmetry proved by
      (@eq_vec_sym AN eqAN sid_theoryAN n) transitivity proved by
      (@eq_vec_trans AN eqAN sid_theoryAN n) as eq_vec_rel.

    Add Parametric Morphism n : (@vec_ge n) with signature (@eq_vec n)
      ==> (@eq_vec n) ==> iff as vec_ge_mor.

    Proof.
      unfold vec_ge. intros.
      apply (Vforall2n_mor sid_theoryAN). intuition.
      trans a1. apply eq_ge_compatN. sym. hyp.
      trans a2. hyp. apply eq_ge_compatN. hyp.
      trans a1'. apply eq_ge_compatN. hyp.
      trans a2'. hyp. apply eq_ge_compatN. sym. hyp.
      hyp. hyp.
    Qed.

    Implicit Arguments vec_ge_mor [n x y x0 y0].

    Lemma term_gt_incl_succ : term_gt << IR_succ.

    Proof.
      intros l r lr v. destruct (mint_eval_equiv l r v). simpl in * .
      unfold succ, I, succ_vec. symmetry in H. symmetry in H0.
      rewrite (vec_ge_mor H H0).
      rewrite (Vnth_mor _ H (dim_pos dim)).
      rewrite (Vnth_mor _ H0 (dim_pos dim)).
      change (succ_vec (mint_eval v
        (mi_of_term  m (ABterm.inject_term
          (Max.le_max_l (maxvar l) (maxvar r)))))
      (mint_eval v (mi_of_term m
        (ABterm.inject_term (Max.le_max_r (maxvar l) (maxvar r)))))).
      apply mint_eval_mon_succ. hyp.
    Qed.

    Lemma mint_gt_dec : forall n, rel_dec (@mint_gt n).

    Proof.
      intro. apply intersection_dec. apply mint_ge_dec.
      intros x y. apply NatUtil.gt_dec.
    Defined.

    Definition succ' := term_gt.
    Definition succ'_sub := term_gt_incl_succ.
    Definition succ'_dec := term_gt_dec m mint_gt mint_gt_dec.

    (** Define record type for MonotoneAlgType. *)

    Definition matAlg := mkbMonoAlgType Sig I succ succeq refl_succeq
      trans_succ trans_succeq monotone_succeq succ_wf
      succ_succeq_compat succ' succeq' succ'_sub succeq'_sub succ'_dec
      succeq'_dec.

    Section ExtendedMonotoneAlgebra.

      Section VecMonotonicity.

        Lemma vec_plus_gt_compat_r : forall (vl vl' vr vr': vector nat
          dim), vec_at0 vl > vec_at0 vl' -> vec_at0 vr >= vec_at0 vr'
          -> vec_at0 (vl [+] vr) > vec_at0 (vl' [+] vr').

        Proof.
          unfold vec_at0, vector_plus.
          intros. simpl. do 2 rewrite Vnth_map2.
          unfold Aplus, Peano.gt. apply plus_gt_compat_lN; hyp.
        Qed.

        Notation vec := (vector AN dim).

        Variable f : matrix dim dim -> vec -> vec.

        Variable f_mon : forall M v1 v2, get_elem M (dim_pos dim)
          (dim_pos dim) > 0 -> v1 >=v v2 -> vec_at0 v1 > vec_at0 v2 ->
          vec_at0 (f M v1) > vec_at0 (f M v2).

        Variables (a b : vec).

        Lemma vec_add_monotone_map2 : forall n1 (v1 : vector vec n1) n2
          (v2 : vector vec n2)  n (M : vector (matrix dim dim) n) i_j,
          Vforall (fun m => get_elem m (dim_pos dim) (dim_pos dim) > 0) M ->
          a >=v b -> vec_at0 a > vec_at0 b ->
          vec_at0 (add_vectors
            (Vmap2 f M (Vcast (Vapp v1 (Vcons a v2)) i_j))) >
          vec_at0 (add_vectors
            (Vmap2 f M (Vcast (Vapp v1 (Vcons b v2)) i_j))).

        Proof.
          induction v1; intros; simpl.
          destruct n; [absurd_arith | idtac].
          unfold add_vectors, vec_at0, vector_plus.
          simpl.
          do 2 rewrite Vnth_map2.
          unfold Aplus. apply plus_gt_compat_rN.
          apply eq_ge_compatN. refl.
          unfold vec_at0 in f_mon. apply f_mon; try hyp.
          apply (Vforall_in (x:=Vhead M) H). apply Vin_head.
          destruct n0; [absurd_arith | idtac]. unfold vec_at0.
          unfold add_vectors, vec_at0, vector_plus.
          simpl.
          do 2 rewrite Vnth_map2.
          unfold Aplus. apply plus_gt_compat_lN. 2:
          apply eq_ge_compatN; refl.
          match goal with |- ?Hl > ?Hr => fold (Hr > Hl) end.
          unfold vec_at0, add_vectors in IHv1.
          apply IHv1; try hyp.
          apply Vforall_incl with (S n0) M.
          intros. VSntac M. simpl. auto.
          hyp.
        Qed.

      End VecMonotonicity.

      Lemma dot_product_mon_r : forall i j (jp : (j < i)%nat)
        (v v' w w' : vector nat i),
        v >=v v' -> w >=v w' -> Vnth v jp > A0N ->
        Vnth w jp > Vnth w' jp ->
        dot_product v w > dot_product v' w'.

      Proof.
        intros i j. gen i. clear i.
        induction j; intros.
        destruct i. absurd_arith.
        VSntac v. VSntac w. VSntac v'. VSntac w'.
        unfold dot_product. simpl.
        fold (dot_product (Vtail v') (Vtail w')).
        fold (dot_product (Vtail v) (Vtail w)).
        unfold Aplus, Peano.gt. apply plus_gt_compat_rN.
        apply dot_product_mon; apply Vreln_tail_intro; hyp.
        do 4 rewrite Vhead_nth. apply mult_lt_compat_lr.
        apply (Vforall2n_nth (R:=geN)). hyp.
        rewrite (lt_unique (lt_O_Sn i) jp). hyp.
        rewrite (lt_unique (lt_O_Sn i) jp). hyp.
        destruct i. absurd_arith.
        VSntac v. VSntac w. VSntac v'. VSntac w'.
        unfold dot_product. simpl.
        fold (dot_product (Vtail v') (Vtail w')).
        fold (dot_product (Vtail v) (Vtail w)).
        unfold Aplus, Peano.gt. apply plus_gt_compat_lN.
        apply IHj with (lt_S_n jp).
        apply Vreln_tail_intro. hyp.
        apply Vreln_tail_intro. hyp.
        rewrite Vnth_tail. rewrite lt_nS_Sn. hyp.
        do 2 rewrite Vnth_tail. rewrite lt_nS_Sn. hyp.
        apply mult_le_compat.
        do 2 rewrite Vhead_nth. apply (Vforall2n_nth (R:=geN)). hyp.
        do 2 rewrite Vhead_nth. apply (Vforall2n_nth (R:=geN)). hyp.
      Qed.

      (** Additional property of interpretation required to ensure strict
         monotonicity of interpretations: upper left corner of every matrix
         needs to be positive. *)

      Definition monotone_interpretation n (fi : matrixInt dim n) :=
        Vforall (fun m => get_elem m (dim_pos dim) (dim_pos dim) > 0)
        (args fi).

      Definition bmonotone_interpretation n (fi : matrixInt dim n) :=
        bVforall (fun m => bgt_nat (get_elem m (dim_pos dim) (dim_pos
        dim)) 0) (args fi).

      Lemma bmonotone_interpretation_ok : forall n (fi : matrixInt dim
        n), bmonotone_interpretation fi = true <->
        monotone_interpretation fi.

      Proof.
        intros. apply bVforall_ok. intro. apply bgt_nat_ok.
      Qed.

      Lemma monotone_succ : (forall f : Sig, monotone_interpretation
        (trsInt f)) -> monotone I succ.

      Proof.
        intros H f i j i_j vi vj a b ab. split.
        apply monotone_succeq. destruct ab. hyp.
        simpl. apply vec_plus_gt_compat_r.
        do 2 rewrite Vmap_cast. do 2 rewrite Vmap_app. simpl.
        apply vec_add_monotone_map2; try solve [destruct ab; hyp].
        intros. unfold vec_at0.
        unfold mat_vec_prod.
        do 2 rewrite Vnth_col_mat.
        do 2 rewrite mat_mult_spec.
        apply dot_product_mon_r with 0%nat (dim_pos dim).
        unfold vec_ge, ge. apply Vforall2n_intro. intros. apply le_refl.
        unfold vec_ge, ge. apply Vforall2n_intro. intros.
        do 2 rewrite get_col_col_mat. destruct ab.
        apply Vforall2n_nth. hyp.
        hyp.
        do 2 rewrite get_col_col_mat. hyp.
        apply H. apply le_refl.
      Qed.

      Require Import List ListForall.

      Section fin_Sig.

        Variable Fs : list Sig.
        Variable Fs_ok : forall f : Sig, In f Fs.

        Lemma fin_monotone_succ : forallb (fun f =>
          bmonotone_interpretation (trsInt f)) Fs = true -> monotone I
          succ.

        Proof.
          intro H. apply monotone_succ. intro f.
          rewrite <- bmonotone_interpretation_ok.
          rewrite forallb_forall in H. apply H. apply Fs_ok.
        Qed.

      End fin_Sig.

    End ExtendedMonotoneAlgebra.

  End MonotoneAlgebra.

  Implicit Arguments fin_monotone_succ [Fs].

  Ltac prove_cc_succ Fs_ok :=
    apply IR_context_closed; apply (fin_monotone_succ Fs_ok);
      (check_eq || fail 10
         "could not prove the monotony of this matrix interpretation").
End S.


Require Import init.

Require Export topology_base.
Require Import topology_continuous.

Definition homeomorphism {U V} `{Topology U, Topology V} (f : U → V) :=
    continuous f ∧ ∃ H : Bijective f, continuous (bij_inv f).

(* begin hide *)
Section Homeomorphism.

Context {U V} `{Topology U, Topology V}.
Variable f : U → V.
(* end hide *)
Theorem homeomorphism_open :
   homeomorphism f ↔ (Bijective f ∧ (∀ A, open A ↔ open (image_under f A))).
Proof.
    split.
    -   intros [cont [bij inv_cont]].
        split; try exact bij.
        rewrite continuous_open in cont.
        rewrite continuous_open in inv_cont.
        intros A.
        split.
        +   intros A_open.
            specialize (inv_cont A A_open).
            rewrite inverse_image_bij_inv in inv_cont.
            exact inv_cont.
        +   intros A_open.
            specialize (cont _ A_open).
            rewrite inj_inverse_image in cont by apply bij.
            exact cont.
    -   intros [bij opens].
        split.
        +   intros x B B_neigh.
            exists (inverse_image f B).
            repeat split.
            *   apply opens.
                rewrite bij_inverse_image by exact bij.
                apply B_neigh.
            *   apply B_neigh.
            *   intros y' [a [Bfa eq]]; subst.
                exact Bfa.
        +   exists bij.
            rewrite continuous_open.
            intros A A_open.
            rewrite inverse_image_bij_inv.
            apply opens.
            exact A_open.
Qed.
(* begin hide *)
End Homeomorphism.
(* end hide *)


Require Export Stlc.Inst.
Require Export Coq.Relations.Relation_Operators.
Require Export Common.Relations.

(** ** Evaluation *)

Fixpoint Value (t: Tm) : Prop :=
  match t with
    | abs τ t      => True
    | unit         => True
    | true         => True
    | false        => True
    | pair t₁ t₂   => Value t₁ ∧ Value t₂
    | inl t        => Value t
    | inr t        => Value t
    | var _ | app _ _ | ite _ _ _
    | proj₁ _ | proj₂ _ | caseof _ _ _
    | seq _ _ | fixt _ _ _   => False
  end.

Fixpoint ECtx (C: PCtx) : Prop :=
  match C with
    | phole            => True
    | papp₁ C t        => ECtx C
    | papp₂ t C        => Value t ∧ ECtx C
    | pite₁ C t₂ t₃    => ECtx C
    | ppair₁ C t       => ECtx C
    | ppair₂ t C       => Value t ∧ ECtx C
    | pproj₁ C         => ECtx C
    | pproj₂ C         => ECtx C
    | pinl C           => ECtx C
    | pinr C           => ECtx C
    | pcaseof₁ C t₂ t₃ => ECtx C
    | pseq₁ C t        => ECtx C
    | pfixt τ₁ τ₂ C    => ECtx C
    | pabs _ _ | pite₂ _ _ _ | pite₃ _ _ _
    | pcaseof₂ _ _ _ | pcaseof₃ _ _ _
    | pseq₂ _ _ => False
  end.

Reserved Notation "t₁ -->₀ t₂" (at level 80).
Inductive eval₀ : Tm → Tm → Prop :=
  | eval_beta {τ₁ t₁ t₂} :
      Value t₂ →
      app (abs τ₁ t₁) t₂ -->₀ t₁[beta1 t₂]
  | eval_ite_true {t₁ t₂} :
      ite true t₁ t₂ -->₀ t₁
  | eval_ite_false {t₁ t₂} :
      ite false t₁ t₂ -->₀ t₂
  | eval_proj₁ {t₁ t₂} :
      Value t₁ → Value t₂ →
      proj₁ (pair t₁ t₂) -->₀ t₁
  | eval_proj₂ {t₁ t₂} :
      Value t₁ → Value t₂ →
      proj₂ (pair t₁ t₂) -->₀ t₂
  | eval_case_inl {t t₁ t₂} :
      Value t →
      caseof (inl t) t₁ t₂ -->₀ t₁[beta1 t]
  | eval_case_inr {t t₁ t₂} :
      Value t →
      caseof (inr t) t₁ t₂ -->₀ t₂[beta1 t]
  | eval_seq_next {t₁ t₂} :
      Value t₁ →
      seq t₁ t₂ -->₀ t₂
  | eval_fix {τ₁ τ₂ t} :
      fixt τ₁ τ₂ (abs (τ₁ ⇒ τ₂) t) -->₀
      t[beta1 (abs τ₁ (app (fixt τ₁ τ₂ (abs (τ₁ ⇒ τ₂) t[wkm↑])) (var 0)))]
where "t₁ -->₀ t₂" := (eval₀ t₁ t₂).

Reserved Notation "t₁ --> t₂" (at level 80).
Inductive eval : Tm → Tm → Prop :=
| eval_ctx₀ C {t t'} :
    t -->₀ t' → ECtx C → pctx_app t C --> pctx_app t' C
where "t₁ --> t₂" := (eval t₁ t₂).

Hint Constructors eval : eval.
Hint Constructors eval₀ : eval.
Hint Constructors clos_refl_trans_1n : eval.
Hint Constructors clos_trans_1n : eval.

Definition normal (t : Tm) := forall t', not (t --> t').

(* Alternative induction principle without program contexts. *)
Lemma eval_ind' (P: Tm → Tm → Prop) :
  (∀ (τ₁ : Ty) (t₁ t₂ : Tm), Value t₂ → P (app (abs τ₁ t₁) t₂) t₁[beta1 t₂]) →
  (∀ t₁ t₂ : Tm, P (ite true t₁ t₂) t₁) →
  (∀ t₁ t₂ : Tm, P (ite false t₁ t₂) t₂) →
  (∀ t₁ t₂ : Tm, Value t₁ → Value t₂ → P (proj₁ (pair t₁ t₂)) t₁) →
  (∀ t₁ t₂ : Tm, Value t₁ → Value t₂ → P (proj₂ (pair t₁ t₂)) t₂) →
  (∀ t t₁ t₂ : Tm, Value t → P (caseof (inl t) t₁ t₂) t₁[beta1 t]) →
  (∀ t t₁ t₂ : Tm, Value t → P (caseof (inr t) t₁ t₂) t₂[beta1 t]) →
  (∀ t₁ t₂ : Tm, Value t₁ → P (seq t₁ t₂) t₂) →
  (∀ (τ₁ τ₂ : Ty) (t : Tm),
     P (fixt τ₁ τ₂ (abs (τ₁ ⇒ τ₂) t))
       t[beta1 (abs τ₁ (app (fixt τ₁ τ₂ (abs (τ₁ ⇒ τ₂) t[wkm↑])) (var 0)))]) →
  (∀ t₁ t₁' t₂ : Tm, t₁ --> t₁' → P t₁ t₁' → P (app t₁ t₂) (app t₁' t₂)) →
  (∀ t₁ t₂ t₂' : Tm, Value t₁ → t₂ --> t₂' → P t₂ t₂' → P (app t₁ t₂) (app t₁ t₂')) →
  (∀ t₁ t₁' t₂ t₃ : Tm, t₁ --> t₁' → P t₁ t₁' → P (ite t₁ t₂ t₃) (ite t₁' t₂ t₃)) →
  (∀ t₁ t₁' t₂ : Tm, t₁ --> t₁' → P t₁ t₁' → P (pair t₁ t₂) (pair t₁' t₂)) →
  (∀ t₁ t₂ t₂' : Tm, Value t₁ → t₂ --> t₂' → P t₂ t₂' → P (pair t₁ t₂) (pair t₁ t₂')) →
  (∀ t t' : Tm, t --> t' → P t t' → P (proj₁ t) (proj₁ t')) →
  (∀ t t' : Tm, t --> t' → P t t' → P (proj₂ t) (proj₂ t')) →
  (∀ t t' : Tm, t --> t' → P t t' → P (inl t) (inl t')) →
  (∀ t t' : Tm, t --> t' → P t t' → P (inr t) (inr t')) →
  (∀ t₁ t₁' t₂ t₃ : Tm, t₁ --> t₁' → P t₁ t₁' → P (caseof t₁ t₂ t₃) (caseof t₁' t₂ t₃)) →
  (∀ t₁ t₁' t₂ : Tm, t₁ --> t₁' → P t₁ t₁' → P (seq t₁ t₂) (seq t₁' t₂)) →
  (∀ (τ₁ τ₂ : Ty) (t₁ t₁' : Tm), t₁ --> t₁' → P t₁ t₁' → P (fixt τ₁ τ₂ t₁) (fixt τ₁ τ₂ t₁')) →
  ∀ t t0 : Tm, t --> t0 → P t t0.
Proof.
  do 21 intro; induction 1 as [C ? ? r' ec].
  revert ec t t' r'.
  induction C; cbn in *; intuition.
  induction r'; cbn in *; intuition.
Qed.

(* The in-between induction principle *)
Lemma eval_ind'' (P: Tm → Tm → Prop) :
  (∀ t t' : Tm, t -->₀ t' → P t t') →
  (∀ t₁ t₁' t₂ : Tm, t₁ --> t₁' → P t₁ t₁' → P (app t₁ t₂) (app t₁' t₂)) →
  (∀ t₁ t₂ t₂' : Tm, Value t₁ → t₂ --> t₂' → P t₂ t₂' → P (app t₁ t₂) (app t₁ t₂')) →
  (∀ t₁ t₁' t₂ t₃ : Tm, t₁ --> t₁' → P t₁ t₁' → P (ite t₁ t₂ t₃) (ite t₁' t₂ t₃)) →
  (∀ t₁ t₁' t₂ : Tm, t₁ --> t₁' → P t₁ t₁' → P (pair t₁ t₂) (pair t₁' t₂)) →
  (∀ t₁ t₂ t₂' : Tm, Value t₁ → t₂ --> t₂' → P t₂ t₂' → P (pair t₁ t₂) (pair t₁ t₂')) →
  (∀ t t' : Tm, t --> t' → P t t' → P (proj₁ t) (proj₁ t')) →
  (∀ t t' : Tm, t --> t' → P t t' → P (proj₂ t) (proj₂ t')) →
  (∀ t t' : Tm, t --> t' → P t t' → P (inl t) (inl t')) →
  (∀ t t' : Tm, t --> t' → P t t' → P (inr t) (inr t')) →
  (∀ t₁ t₁' t₂ t₃ : Tm, t₁ --> t₁' → P t₁ t₁' → P (caseof t₁ t₂ t₃) (caseof t₁' t₂ t₃)) →
  (∀ t₁ t₁' t₂ : Tm, t₁ --> t₁' → P t₁ t₁' → P (seq t₁ t₂) (seq t₁' t₂)) →
  (∀ (τ₁ τ₂ : Ty) (t₁ t₁' : Tm), t₁ --> t₁' → P t₁ t₁' → P (fixt τ₁ τ₂ t₁) (fixt τ₁ τ₂ t₁')) →
  ∀ t t0 : Tm, t --> t0 → P t t0.
Proof.
  do 13 intro; induction 1.
  induction C; cbn in *; intuition.
Qed.

Definition evaln := stepRel eval.

Hint Constructors stepRel : eval.

Notation "t₁ -->* t₂" := (clos_refl_trans_1n Tm eval t₁ t₂) (at level 80).
Notation "t₁ -->+ t₂" := (clos_trans_1n Tm eval t₁ t₂) (at level 80).

Definition Terminating (t: Tm) : Prop :=
  ∃ v, Value v ∧ t -->* v.

Notation "t ⇓" := (Terminating t) (at level 8, format "t ⇓").
Notation "t ⇑" := (not (Terminating t)) (at level 8, format "t ⇑").

(* Terminates in maximum n steps *)
Definition TerminatingN (t: Tm) (n : nat) : Prop :=
  ∃ v m, Value v ∧ m ≤ n ∧ evaln t v m.
Notation "t ⇓_ n" := (TerminatingN t n) (at level 8, format "t ⇓_ n").


Require Import Setoid.
Require Export Category NaturalTransformation CategoryIsomorphisms.
Require Import Common FunctorIsomorphisms.

Set Implicit Arguments.

Generalizable All Variables.

Local Ltac intro_object_of :=
  repeat match goal with
           | [ |- appcontext[ObjectOf ?G ?x] ] => unique_pose_with_body (ObjectOf G x)
         end.

Section NaturalIsomorphism.
  Section NaturalIsomorphism.
    Context `(C : @Category objC).
    Context `(D : @Category objD).
    Variables F G : Functor C D.

    Record NaturalIsomorphism :=
      {
        NaturalIsomorphism_Transformation :> NaturalTransformation F G;
        NaturalIsomorphism_Isomorphism : forall x : objC, IsomorphismOf (NaturalIsomorphism_Transformation x)
      }.
  End NaturalIsomorphism.

  Section Inverse.
    Context `(C : @Category objC).
    Context `(D : @Category objD).
    Variables F G : Functor C D.

    Definition InverseNaturalIsomorphism_NT (T : NaturalIsomorphism F G) : NaturalTransformation G F.
      exists (fun x => Inverse (NaturalIsomorphism_Isomorphism T x)).
      abstract (
          intros;
          repeat match goal with
                   | [ |- appcontext[?E] ] => match type of E with | IsomorphismOf _ => destruct E; simpl end
                   | [ H : _ |- _ ] => rewrite H
                 end;
          destruct T as [ [ ] ];
          simpl in *;
            pre_compose_to_identity; post_compose_to_identity;
          auto with functor
        ).
    Defined.

    Definition InverseNaturalIsomorphism (T : NaturalIsomorphism F G) : NaturalIsomorphism G F
      := {|
          NaturalIsomorphism_Transformation := InverseNaturalIsomorphism_NT T;
          NaturalIsomorphism_Isomorphism := (fun x => InverseOf _ (NaturalIsomorphism_Isomorphism T x))
        |}.
  End Inverse.

  Section Composition.
    Context `(C : @Category objC).
    Context `(D : @Category objD).
    Context `(E : @Category objE).
    Variables F F' F'' : Functor C D.
    Variables G G' : Functor D E.

    Local Ltac t :=
      simpl;
      compose4associativity;
      repeat match goal with
               | _ => reflexivity
               | [ H : _ |- _ ] => rewrite H
               | _ => progress (repeat rewrite LeftIdentity; repeat rewrite RightIdentity)
               | _ => progress repeat rewrite <- FCompositionOf
               | _ => progress repeat rewrite FIdentityOf
               | [ |- appcontext[?E] ] =>
                 match type of E with
                   | IsomorphismOf _ => destruct E; simpl
                 end
             end.

    Definition NIComposeT (T' : NaturalIsomorphism F' F'') (T : NaturalIsomorphism F F') : NaturalIsomorphism F F''
      := {|
          NaturalIsomorphism_Transformation := NTComposeT T' T;
          NaturalIsomorphism_Isomorphism := (fun x => ComposeIsomorphismOf (NaturalIsomorphism_Isomorphism T' x) (NaturalIsomorphism_Isomorphism T x))
        |}.

    Definition NIComposeF (U : NaturalIsomorphism G G') (T : NaturalIsomorphism F F') : NaturalIsomorphism (ComposeFunctors G F) (ComposeFunctors G' F').
      exists (NTComposeF U T).
      intro x.
      exists (Compose (Inverse (NaturalIsomorphism_Isomorphism U (F x)))
                      (MorphismOf G' (Inverse (NaturalIsomorphism_Isomorphism T x))));
        abstract t.
    Defined.
  End Composition.
End NaturalIsomorphism.

Section NaturalIsomorphismOfCategories.
  Context `(C : @Category objC).
  Context `(D : @Category objD).

  Local Reserved Notation "'F'".
  Local Reserved Notation "'G'".

  Record NaturalIsomorphismOfCategories := {
                                            NaturalIsomorphismOfCategories_F : Functor C D where "'F'" := NaturalIsomorphismOfCategories_F;
                                            NaturalIsomorphismOfCategories_G : Functor D C where "'G'" := NaturalIsomorphismOfCategories_G;
                                            NaturalIsomorphismOfCategories_Isomorphism_C :> NaturalIsomorphism (IdentityFunctor C) (ComposeFunctors G F);
                                            NaturalIsomorphismOfCategories_Isomorphism_D : NaturalIsomorphism (IdentityFunctor D) (ComposeFunctors F G)
                                          }.

  (*Record IsomorphismOfCategories := {
                                     IsomorphismOfCategories_F : Functor C D where "'F'" := IsomorphismOfCategories_F;
                                     IsomorphismOfCategories_G : Functor D C where "'G'" := IsomorphismOfCategories_G;
                                     IsomorphismOfCategories_Isomorphism_C : ComposeFunctors G F = IdentityFunctor C;
                                     IsomorphismOfCategories_Isomorphism_D : ComposeFunctors F G = IdentityFunctor D
                                   }.*)
End NaturalIsomorphismOfCategories.

Section NaturalEquivalence.
  Context `(C : @Category objC).
  Context `(D : @Category objD).
  Variable F G : Functor C D.

  Definition NaturalEquivalenceOf (T : NaturalTransformation F G) :=
    forall x : C.(Object), IsomorphismOf (T.(ComponentsOf) x).

  Definition FunctorsNaturallyEquivalent : Prop :=
    exists T : NaturalTransformation F G, exists NE : NaturalEquivalenceOf T, True.
End NaturalEquivalence.

(* grumble, grumble, grumble, [Functors] take [Categories] and so we don't get type inference.
   Perhaps I should fix this?  But I don't like having to prefix so many things with [] and
   having duplicated code just so I get type inference.
 *)
Arguments NaturalEquivalenceOf [objC C objD D F G] T.
Arguments FunctorsNaturallyEquivalent [objC C objD D] F G.

Section Coercions.
  Context `(C : @Category objC).
  Context `(D : @Category objD).
  Variables F G : Functor C D.
  Context `(C' : @Category objC').
  Context `(D' : @Category objD').
  Variables F' G' : Functor C' D'.

  Definition NaturalEquivalence_of_NaturalIsomorphism (T : NaturalIsomorphism F G) : NaturalEquivalenceOf T
    := fun x => NaturalIsomorphism_Isomorphism T x.

  Definition NaturalIsomorphism_of_NaturalEquivalence (T : NaturalTransformation F' G') (NE : NaturalEquivalenceOf T) : NaturalIsomorphism F' G'.
    exists T.
    exact (fun x => NE x : IsomorphismOf _).
  Defined.
End Coercions.

Coercion NaturalEquivalence_of_NaturalIsomorphism : NaturalIsomorphism >-> NaturalEquivalenceOf.
Coercion NaturalIsomorphism_of_NaturalEquivalence : NaturalEquivalenceOf >-> NaturalIsomorphism.
(* gives "Ambiguous paths"... Is this bad? *)

Section NaturalEquivalenceOfCategories.
  Context `(C : @Category objC).
  Context `(D : @Category objD).

  Definition NaturalEquivalenceOfCategories (F : Functor C D) (G : Functor D C) : Prop :=
    (FunctorsNaturallyEquivalent (IdentityFunctor C) (ComposeFunctors G F)) /\
    (FunctorsNaturallyEquivalent (IdentityFunctor D) (ComposeFunctors F G)).

  Definition CategoriesNaturallyEquivalent : Prop :=
    exists F : Functor C D, exists G : Functor D C, NaturalEquivalenceOfCategories F G.
End NaturalEquivalenceOfCategories.

Arguments NaturalEquivalenceOfCategories [objC C objD D] F G.

Section NaturalTransformationInverse.
  Context `(C : @Category objC).
  Context `(D : @Category objD).
  Variable F G : Functor C D.
  Variable T : NaturalTransformation F G.

  Hint Unfold InverseOf.
  Hint Resolve f_equal f_equal2 @Commutes.
  Hint Rewrite @LeftIdentity @RightIdentity.

  Definition NaturalEquivalenceInverse : NaturalEquivalenceOf T -> NaturalTransformation G F.
    refine (fun X => {| ComponentsOf := (fun c => proj1_sig (X c)) |});
    abstract (
        intros; destruct (X s); destruct (X d);
        simpl; unfold InverseOf in *; destruct_hypotheses;
        pre_compose_to_identity; post_compose_to_identity;
        auto
      ).
  (*morphisms 2*)
  Defined.

  Lemma NaturalEquivalenceInverse_NaturalEquivalence (TE : NaturalEquivalenceOf T) : NaturalEquivalenceOf (NaturalEquivalenceInverse TE).
    intro; apply InverseOf.
  Qed.
End NaturalTransformationInverse.

Section IdentityNaturalEquivalence.
  Context `(C : @Category objC).
  Context `(D : @Category objD).
  Variable F : Functor C D.

  Theorem IdentityNaturalEquivalence : NaturalEquivalenceOf (IdentityNaturalTransformation F).
    hnf; intros; hnf; simpl; unfold InverseOf in *; eexists; t_with ltac:(eauto with morphism).
  Qed.
End IdentityNaturalEquivalence.

Arguments IdentityNaturalEquivalence [objC C objD D] F x.

Hint Resolve @IdentityNaturalEquivalence @NaturalEquivalenceInverse_NaturalEquivalence : category.
Hint Resolve @IdentityNaturalEquivalence @NaturalEquivalenceInverse_NaturalEquivalence : natural_transformation.

Section FunctorNaturalEquivalenceRelation.
  Context `(C : @Category objC).
  Context `(D : @Category objD).

  Lemma functors_naturally_equivalent_refl (F : Functor C D) : FunctorsNaturallyEquivalent F F.
    exists (IdentityNaturalTransformation F); eauto with category.
  Qed.

  Lemma functors_naturally_equivalent_sym (F G : Functor C D) :
    FunctorsNaturallyEquivalent F G -> FunctorsNaturallyEquivalent G F.
    destruct 1 as [ ? [ H ] ]; exists (NaturalEquivalenceInverse H); eauto with category.
  Qed.

  Lemma functors_naturally_equivalent_trans (F G H : Functor C D) :
    FunctorsNaturallyEquivalent F G -> FunctorsNaturallyEquivalent G H -> FunctorsNaturallyEquivalent F H.
    destruct 1 as [ T [ ] ]; destruct 1 as [ U [ ] ];
    exists (NTComposeT U T); eexists; hnf; simpl; eauto with category.
  Qed.
End FunctorNaturalEquivalenceRelation.

Hint Resolve functors_naturally_equivalent_refl functors_naturally_equivalent_sym : category functor.
Hint Immediate functors_naturally_equivalent_refl functors_naturally_equivalent_sym functors_naturally_equivalent_trans : category functor.

(*Add Parametric Relation (C D : Category) : _ (@FunctorsNaturallyEquivalent C D)
    reflexivity proved by (@functors_naturally_equivalent_refl _ _)
    symmetry proved by (@functors_naturally_equivalent_sym _ _)
    transitivity proved by (@functors_naturally_equivalent_trans _ _)
      as functors_naturally_equivalent.

Add Parametric Morphism (C D E : Category) :
  (ComposeFunctors (C := C) (D := D) (E := E))
    with signature (@FunctorsNaturallyEquivalent _ _) ==> (@FunctorsNaturallyEquivalent _ _) ==> (@FunctorsNaturallyEquivalent _ _) as functor_n_eq_mor.
  intros;
  destruct_hypotheses;
  eexists (NTComposeF _ _);
  try (constructor; trivial);
  hnf in *; intros; simpl;
  eauto with category.
Qed.
*)
Section FunctorNaturalEquivalenceLemmas.
  Context `(B : @Category objB).
  Context `(C : @Category objC).
  Context `(D : @Category objD).
  Context `(E : @Category objE).

  Lemma LeftIdentityFunctorNE (F : Functor D C) : FunctorsNaturallyEquivalent (ComposeFunctors (IdentityFunctor _) F) F.
    match goal with
      | [ |- FunctorsNaturallyEquivalent ?a ?b ] => assert (H : a = b); eauto with functor; try (rewrite H; eauto with functor)
    end.
  Qed.

  Lemma RightIdentityFunctorNE (F : Functor C D) : FunctorsNaturallyEquivalent (ComposeFunctors F (IdentityFunctor _)) F.
    match goal with
      | [ |- FunctorsNaturallyEquivalent ?a ?b ] => assert (H : a = b); eauto with functor; try (rewrite H; eauto with functor)
    end.
  Qed.

  (* XXX TODO: Automate this better. *)
  Lemma PreComposeFunctorsNE (G : Functor D E) (F1 F2 : Functor C D) :
    FunctorsNaturallyEquivalent F1 F2 -> FunctorsNaturallyEquivalent (ComposeFunctors G F1) (ComposeFunctors G F2).
    intro;
    destruct_head FunctorsNaturallyEquivalent;
    destruct_hypotheses;
    eexists (NTComposeF (IdentityNaturalTransformation _) _);
    constructor; trivial; repeat (hnf; intros);
    simpl; eauto with category.
  Qed.

  Lemma PostComposeFunctorsNE (G1 G2 : Functor D E) (F : Functor C D) :
    FunctorsNaturallyEquivalent G1 G2 -> FunctorsNaturallyEquivalent (ComposeFunctors G1 F) (ComposeFunctors G2 F).
    intro;
    destruct_head FunctorsNaturallyEquivalent;
    destruct_hypotheses;
    eexists (NTComposeF _ (IdentityNaturalTransformation _));
    constructor; trivial; repeat (hnf; intros);
    simpl; eauto with category.
  Qed.

  Lemma ComposeFunctorsAssociativityNE (F : Functor B C) (G : Functor C D) (H : Functor D E) :
    FunctorsNaturallyEquivalent (ComposeFunctors (ComposeFunctors H G) F) (ComposeFunctors H (ComposeFunctors G F)).
    match goal with
      | [ |- FunctorsNaturallyEquivalent ?a ?b ] => cut (a = b); try let H' := fresh in solve [ intro H'; rewrite H'; trivial || eauto with functor ]
    end; eauto with functor.
  Qed.
End FunctorNaturalEquivalenceLemmas.

Hint Resolve @PreComposeFunctorsNE @PostComposeFunctorsNE @ComposeFunctorsAssociativityNE : category.
Hint Rewrite @LeftIdentityFunctorNE @RightIdentityFunctorNE : category.
Hint Resolve @PreComposeFunctorsNE @PostComposeFunctorsNE @ComposeFunctorsAssociativityNE : natural_transformation.
Hint Rewrite @LeftIdentityFunctorNE @RightIdentityFunctorNE : natural_transformation.
(*
Section CategoryNaturalEquivalenceRelation.

  Local Ltac t :=
    simpl; intros; apply Functor_Eq;
    repeat match goal with
             | _ => intro
             | _ => reflexivity
             | _ => progress simpl in *
             | [ |- context[match ?f ?x with _ => _ end] ] =>
               generalize (f x); intro; subst_eq_refl
           end.

  Lemma categories_naturally_equivalent_refl `(C : @Category objC) : CategoriesNaturallyEquivalent C C.
    repeat (exists (IdentityFunctor C)); split;
    match goal with
      | [ |- FunctorsNaturallyEquivalent ?a ?b ] => cut (a = b); try let H' := fresh in solve [ intro H'; rewrite <- H'; auto with category; reflexivity || trivial ]
    end;
    t.
  Qed.

  Lemma categories_naturally_equivalent_sym `(C : @Category objC) `(D : @Category objD) :
    CategoriesNaturallyEquivalent C D -> CategoriesNaturallyEquivalent D C.
    destruct 1 as [ F [ G [ ? ] ] ]; repeat (esplit; try eassumption).
  Qed.

  Ltac solve_4_associativity :=
    match goal with
      | [ |- ?Rel _ (ComposeFunctors (ComposeFunctors ?a ?b) (ComposeFunctors ?c ?d)) ] =>
        eapply (functors_naturally_equivalent_trans (G := ComposeFunctors a (ComposeFunctors (ComposeFunctors b c) d)));
          try solve [ repeat (rewrite ComposeFunctorsAssociativity); reflexivity || trivial ]
    end.

  Hint Extern 1 (FunctorsNaturallyEquivalent _ (ComposeFunctors ?a (ComposeFunctors (IdentityFunctor _) ?c))) => transitivity (ComposeFunctors a c) : category.

  Lemma categories_naturally_equivalent_trans `(C : @Category objC) `(D : @Category objD) `(E : @Category objE) :
    CategoriesNaturallyEquivalent C D -> CategoriesNaturallyEquivalent D E -> CategoriesNaturallyEquivalent C E.
    destruct 1 as [ F [ F' [ T T' ] ] ]; destruct 1 as [ G [ G' [ U U' ] ] ].
    exists (ComposeFunctors G F); exists (ComposeFunctors F' G').
    split; solve_4_associativity;
    rewrite_rev_hyp;
    autorewrite with functor. assumption.
  Qed.
End CategoryNaturalEquivalenceRelation.

Add Parametric Relation : _ CategoriesNaturallyEquivalent
    reflexivity proved by categories_naturally_equivalent_refl
    symmetry proved by categories_naturally_equivalent_sym
    transitivity proved by categories_naturally_equivalent_trans
      as categories_naturally_equivalent.
*)


Require Import Coq.Init.Peano.
Require Import Notations.
Require Import Coq.Lists.List.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.omega.Omega.
Require Import Coq.Arith.Le.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Numbers.NatInt.NZMul.
Require Import Coq.Structures.OrdersFacts.
Require Import Coq.ZArith.Znat.
Require Import Coq.QArith.QArith_base.
Require Import Coq.QArith.QOrderedType.
Require Import QArith_base Equalities Orders OrdersTac.
Require Import Coq.Sorting.Permutation.
Require Import Wf.
Require Import Lexicographic_Product.
Require Import Qreduction.
Require Import Coq.Bool.Bool.
Require Import Inverse_Image.
Require Import Coq.Bool.Sumbool.
Require Import Coq.Sorting.Mergesort.
Require Import Coq.Sorting.Sorted.
Import ListNotations.
Require Import Coq.Program.Basics.
Require Import Program.
Require Import FunInd Recdef.

Notation "'existsT' x .. y , p" :=
  (sigT (fun x => .. (sigT (fun y => p)) ..))
    (at level 200, x binder, right associativity,
     format "'[' 'existsT' '/ ' x .. y , '/ ' p ']'") : type_scope.

Module NatOrder <: TotalLeBool.
  Open Scope nat.
  Definition t := nat.
  Fixpoint leb x y :=
    match x, y with
    | 0, _ => true
    | _, 0 => false
    | S x', S y' => leb x' y'
    end.
  Infix "<=??" := leb (at level 35).
  Theorem leb_total : forall a1 a2, a1 <=?? a2 = true \/ a2 <=?? a1 = true.
  Proof. induction a1.
         destruct a2; left; auto.
         destruct a2. right; auto.
         pose proof (IHa1 a2). firstorder.
  Qed.

End NatOrder.

Module Import NatSort := Sort NatOrder.

Module RatOrder <: TotalLeBool.
  Definition t := Q.

  Definition leb r1 r2 :=
    match Q_dec r1 r2 with
    | inleft l => match l with
                  | left _ =>   true
                  | right _ => false
                  end
    | inright r => true
    end.

  Theorem leb_total : forall r1 r2, is_true (leb r1 r2) \/ is_true (leb r2 r1).
  Proof.
    intros r1 r2. unfold is_true, leb.
    destruct (Q_dec r1 r2). destruct s. auto.
    right.  destruct (Q_dec r2 r1). destruct s. auto.
    pose proof (Qlt_trans r1 r2 r1 q0 q).
    pose proof (Qlt_irrefl r1). unfold not in H0.
    pose proof (H0 H). inversion H1. auto. auto.
  Qed.

End RatOrder.

Module Import QSort := Sort RatOrder.

Definition Rat_eq r1 r2 := Qeq_bool r1 r2.

Lemma filter_len : forall (l : list Q) (f : Q -> bool),
    (length (filter f l) <= length l)%nat.
Proof.
  induction l. intros. auto.
  intros. simpl.
  remember (f a) as v.
  destruct v. simpl. pose proof (IHl f).
  omega.
  pose proof (IHl f). omega.
Qed.

Fixpoint takewhile (f : Q -> bool) (l : list Q) : list Q :=
  match l with
  | [] => []
  | h :: t => if f h then h :: takewhile f t else []
  end.

Fixpoint dropwhile (f : Q -> bool) (l : list Q) : list Q :=
  match l with
  | [] => []
  | h :: t => if f h then dropwhile f t else h :: t
  end.

Lemma inverse_of_each : forall (l : list Q) (f : Q -> bool),
    takewhile f l ++ dropwhile f l = l.
Proof.
  induction l. intros. auto.
  intros. remember (f a) as v.
  destruct v. simpl. rewrite <- Heqv.
  pose proof (IHl f). simpl. apply f_equal.
  auto.
  simpl. rewrite <- Heqv. auto.
Qed.

Lemma takelength : forall (l :  list Q) (f : Q -> bool),
    (length (takewhile f l) <= length l)%nat.
Proof.
  induction l. auto.
  intros. remember (f a) as v.
  destruct v. simpl. rewrite <- Heqv.
  simpl. pose proof (IHl f). omega.
  simpl. rewrite <- Heqv. simpl. omega.
Qed.

Lemma droplength : forall (l : list Q) (f : Q -> bool),
    (length (dropwhile f l) <= length l)%nat.
Proof.
  induction l. auto.
  intros.  remember (f a) as v.
  destruct v. simpl. rewrite <- Heqv.
  simpl. pose proof (IHl f). omega.
  simpl. rewrite <- Heqv. simpl. omega.
Qed.

Lemma groupby : forall (l : list Q),  {x : list (list Q) | concat x = l}.
Proof.
  induction l using (well_founded_induction
                     (wf_inverse_image _ nat _ (@length _)
                        PeanoNat.Nat.lt_wf_0)).
  destruct l. exists []. auto.
  remember (takewhile (Rat_eq q) l) as fhalf.
  remember (dropwhile (Rat_eq q) l) as shalf.
  assert (length shalf <= length l)%nat.
  pose proof (droplength l (Rat_eq q)).
  rewrite Heqshalf. auto.
  assert (length shalf < length (q :: l))%nat.
  simpl. omega.
  pose proof (H shalf H1). destruct H2.
  exists ((q :: fhalf) :: x). simpl.
  apply f_equal. rewrite e.
  pose proof (inverse_of_each l (Rat_eq q)).
  rewrite Heqfhalf. rewrite Heqshalf. auto.
Defined.

(* Change it to Qed if you want nice output of Eval statement *)
Eval compute in  (proj2_sig (groupby (sort [(3 # 1)%Q; (2 # 3)%Q; (2 # 1)%Q; (2 # 3)%Q; (2 # 1)]))).

Lemma concat_groupby_inverse :
    forall (l : list Q), concat (proj1_sig (groupby l)) = l.
Proof.
  intros l.
  remember (groupby l) as v.
  destruct v. simpl. auto.
Qed.

Lemma concat_rat_dep :
  forall  (l : list Q) , length l = length (concat (proj1_sig (groupby (sort l) ))).
Proof.
  intros l.
  rewrite (concat_groupby_inverse (sort l)).
  pose proof (Permuted_sort l).
  pose proof (Permutation_length).
  pose proof (H0 _ l (sort l) H). auto.
Qed.

(* Non dependent type *)
Fixpoint countem y (xs: list Q) : nat :=
   match xs with
   | [] => 0
   | x :: more => if Qeq_bool x y then S (countem y more) else 0
   end.

Fixpoint take (y : nat) (xs: list Q) :=
   match y, xs with
   | O, _ => []
   | S y', [] => []
   | S y', x :: more => x :: take y' more
   end.

Fixpoint skip y (xs: list Q) :=
   match y, xs with
   | O, _ => xs
   | S y', [] => []
   | S y', x :: more => skip y' more
   end.

Lemma skip_bounded:
   forall y xs, (length (skip y xs) <= length xs)%nat.
Proof.
   intros y xs. revert y.
   induction xs; intros; simpl.
   - destruct y; simpl; omega.
   - destruct y; simpl; try omega.
     rewrite IHxs. omega.
Qed.

Lemma take_skip:
   forall k (xs : list Q) , (take k xs ++ skip k xs = xs)%nat.
Proof.
   intros k xs. revert k.
   induction xs; intros; simpl.
   - destruct k; simpl; auto.
   - destruct k; simpl; auto.
     rewrite IHxs. auto.
Qed.

Function groupbysimple (xs: list Q) { measure length xs } :=
   match xs with
   | [] => []
   | x :: more =>
        let k := countem x more in
        (x :: take k more) :: groupbysimple (skip k more)
   end.
Proof.
   intros.
   simpl.
   assert (length (skip (countem x more) more) <= length more)%nat by
        apply skip_bounded.
   omega.
Defined.

Eval compute in (groupbysimple (sort [(3 # 1)%Q; (2 # 3)%Q; (2 # 1)%Q; (2 # 3)%Q; (2 # 1)])).

Lemma groupby_identity:
   forall xs, concat (groupbysimple xs) = xs.
Proof.
   intros.
   functional induction (groupbysimple xs).
   - simpl. auto.
   - simpl. rewrite IHl. rewrite take_skip. auto.
Qed.

Lemma concat_rat: forall  (l : list Q) , length l = length (concat (groupbysimple (sort l))).
Proof.
  intros l.
  pose proof (groupby_identity (sort l)).
  rewrite H.
  pose proof (Permuted_sort l).
  pose proof (Permutation_length).
  pose proof (H1 _ l (sort l) H0).
  auto.
Qed.

Fixpoint take {A : Type} (n : nat) (l : list A) : list A :=
  match n with
  | O => []
  | S n' => match l with
           | [] => []
           | h :: tl => h :: take n' tl
           end
  end.

Fixpoint drop {A : Type} (n : nat) (l : list A) : list A :=
  match n with
  | O => l
  | S n' => match l with
           | [] => []
           | h :: tl => drop n' tl
           end
  end.

Lemma take_drop_identity :
  forall (A : Type) (n : nat) (l : list A),
    take n l ++ drop n l = l.
Proof.
  intros A n.
  induction n; cbn; intros; try auto.
  destruct l; cbn; try auto.
  f_equal. apply IHn.
Qed.


Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.implementations.peano_naturals
  HoTT.Classes.orders.sum
  HoTT.Classes.tactics.ring_tac
  HoTT.Classes.tactics.ring_quote.

Import Quoting.Instances.
Generalizable Variables R.

Lemma test1 `{IsSemiRing R}
  : forall x y : R, x + (y * x) = x * (y + 1).
Proof.
intros.
ring_with_nat.
Qed.

Require Import
  HoTT.Classes.interfaces.naturals.

Lemma test2 `{IsSemiRing R}
  : forall x y : R, x + (y * x) = x * (y + 1).
Proof.
intros.
apply (by_quoting (naturals_to_semiring nat R)).
compute. reflexivity.
Qed.

Lemma test3 `{IsSemiRing R}
  (pa pb pc : R) :
  pa * (pb * pc)
= pa * pb * pc.
Proof.
intros.
apply (by_quoting (naturals_to_semiring nat R)). compute.
reflexivity.
Qed.

Lemma test4 `{IsSemiRing R}
  (a b : R)
  : a * b = b * a.
Proof.
apply (ring_quote.Quoting.eval_eqquote R).
apply (prove_prequoted (naturals_to_semiring nat R)).
reflexivity.
Qed.

Lemma test5 : forall x y : nat, x + (y * x) = x * (y + 1).
Proof.
intros;ring_with_nat.
Qed.


(***************************************************************************)
(* Formalization of the Chou, Gao and Zhang's decision procedure.          *)
(* Julien Narboux (Julien@narboux.fr)                                      *)
(* LIX/INRIA FUTURS 2004-2006                                              *)
(* University of Strasbourg 2008                                           *)
(***************************************************************************)

Require Export basic_geometric_facts.

Theorem common_point_not_par_aux :
 forall A B C D Y : Point,
 Col Y A B ->
 Col Y C D ->
 A <> B ->
 C <> D ->
 ~ Col D A B ->
 ~ Col Y A C ->
 ~ parallel A B C D.
Proof with Geometry.
intros.
assert (D <> Y).
unfold not;intro;subst D...
unfold not;intro.
assert (C ** Y / D ** Y = S C A B / S D A B)...
assert (S C A B = S D A B).
unfold parallel in H6.
unfold S4 in H6.
assert (S C A B = - S A C B)...
rewrite H8.
RewriteVar (S A C B) H6.
ring_simplify.
Geometry.
rewrite H8 in H7.
assert (C ** Y = D ** Y).
RewriteVar (C ** Y) H7.
field...
Geometry.
assert (C = D).
assert (C ** D + D ** Y = C ** Y)...
rewrite <- H10 in H9.
assert (C ** D = 0)...
RewriteVar (C ** D) H9...
Geometry.
Qed.

Lemma col_par_1 : forall A B C,
 Col A B C -> parallel A B B C.
Proof.
intros.
unfold parallel, S4, Col in *.
rewrite H.
basic_simpl.
ring.
Qed.

Lemma col_par_2 : forall A B C,
 Col A B C -> parallel A B C B.
Proof.
intros.
unfold parallel, S4, Col in *.
basic_simpl.
uniformize_signed_areas.
rewrite H.
ring.
Qed.

Lemma col_par_3 : forall A B C,
 Col A B C -> parallel B A C B.
Proof.
intros.
unfold parallel, S4, Col in *.
basic_simpl.
uniformize_signed_areas.
rewrite H.
ring.
Qed.

Lemma col_par_4 : forall A B C,
 Col A B C -> parallel B A B C.
Proof.
intros.
unfold parallel, S4, Col in *.
basic_simpl.
uniformize_signed_areas.
rewrite H.
ring.
Qed.

Hint Resolve col_par_1 col_par_2 col_par_3 col_par_4 : Geom.

Lemma par_col_col_1 : forall A B C D,
 parallel A B C D ->
 Col A B C ->
 Col A B D.
Proof.
intros.
unfold parallel,S4,Col in *.
uniformize_signed_areas.
RewriteVar (S A B D) H.
replace (- (1) * S A C B) with (- S A C B) by ring.
auto.
Qed.

Lemma par_col_col_2 : forall A B C D,
 parallel A B C D ->
 Col A B D ->
 Col A B C.
Proof.
intros.
assert (parallel A B D C).
Geometry.
eapply par_col_col_1;eauto.
Qed.

Lemma par_col_col_3 : forall A B C D,
 parallel A B C D ->
 Col A C D ->
 Col B C D.
Proof with Geometry.
intros.
cut (Col C D B).
Geometry.
assert (parallel C D A B).
Geometry.
eapply par_col_col_1;eauto...
Qed.

Lemma par_col_col_4 : forall A B C D,
 parallel A B C D ->
 Col B C D ->
 Col A C D.
Proof.
intros.
cut (Col C D A).
Geometry.
assert (parallel C D B A).
Geometry.
eapply par_col_col_1;eauto.
Geometry.
Qed.

Theorem common_point_not_par :
 forall A B C D Y : Point,
 Col Y A B ->
 Col Y C D ->
 A <> B ->
 C <> D ->
 ~ Col Y A C ->
 ~ parallel A B C D.
Proof with Geometry.
intros.
cases_col D A B.
unfold parallel, S4 in |- *.
cut (Y = D).
intro.
assert (S A B D = S D A B)...
rewrite H6.
rewrite H4.
unfold not in |- *.
intro.
NormalizeRing H7.
clear H H0.
rewrite H5 in H3.
clear H5.
clear H6.
assert (Col A B D)...
assert (Col A B C)...
assert (Col A D C); eauto with Geom.
assert (Col A B Y)...
assert (Col A B D)...
assert (Col A Y D); eauto with Geom.
assert (A <> Y); eauto with Geom.
cases_equality Y D.
auto.
assert (Col Y D A)...
assert (Col Y D C)...
assert (Col Y A C); eauto with Geom.
intuition.
eapply common_point_not_par_aux; apply H || auto.
Qed.

Definition parallelogram (A B C D : Point) : Prop :=
  parallel A B C D /\ parallel B C A D /\ ~ Col A B C.

Theorem l1_24 :
 forall A B C D O : Point,
 parallelogram A B C D ->
 Col A C O ->
 Col B D O ->
 A ** O = O ** C.
Proof with Geometry.
intros.
unfold parallelogram in H.
DecompAndAll.
unfold parallel,S4 in *.
assert (S A B D = S A B C).
RewriteVar (S A B D) H2...
replace (-(1) * S A C B) with (- S A C B) by ring...
assert (S B C D = S B C A).
RewriteVar (S B C D) H4...
replace (-(1) * S B A C) with (- S B A C) by ring...
assert (S C B D = - S B C A).
rewrite <- H3...
assert (~ Col C B D).
unfold not in |- *; intro.
rewrite H7 in H6...
assert (A ** O / C ** O = S A B D / S C B D).
apply co_side...
unfold not in |- *; intro.
subst O...
rewrite H in H8...
rewrite H6 in H8...
assert (S A B C = S B C A)...
rewrite H9 in H8...
assert (C ** O = - O ** C)...
rewrite H10 in H8...
RewriteVar (A ** O) H8...
field...
rewrite <- H10.
assert (O <> C).
unfold not; intro;subst O...
Geometry.
Qed.

Theorem diago_par_intersect :
 forall A B C D : Point,
 parallelogram A B C D ->
 ~ parallel A C B D.
Proof with Geometry.
unfold parallelogram,parallel, S4 in |- *.
intros.
DecompAndAll.
assert (S A C D = S A C B + S A B D + S B C D)...
RewriteVar (S A C B) H0.
RewriteVar (S B C D) H2.
NormalizeRing H.
rewrite H.
replace (S B A C) with (- S A B C)...
ring_simplify (S A B C + - - S A B C)...
Qed.

Theorem para_not_col_1 :
 forall A B C D : Point,
 parallelogram A B C D ->
 ~ Col A B D.
Proof.
unfold parallelogram, parallel, S4 in |- *.
intros.
decompose [and] H.
unfold not in |- *; intro.
rewrite H1 in H0.
NormalizeRing H0.
assert (Col A C B); Geometry.
Qed.

Hint Resolve para_not_col_1: Geom.

Theorem para_not_col_2 :
 forall A B C D : Point, parallelogram A B C D -> ~ Col B C D.
Proof.
unfold parallelogram, parallel, S4 in |- *.
intros.
decompose [and] H.
unfold not in |- *; intro.
rewrite H1 in H2.
NormalizeRing H2.
assert (Col B A C); Geometry.
Qed.

Hint Resolve para_not_col_2: Geom.

Theorem para_not_col_3 :
 forall A B C D : Point, parallelogram A B C D -> ~ Col A C D.
Proof.
unfold parallelogram, parallel,S4 in |- *.
intros.
decompose [and] H.
unfold not in |- *; intro.
assert (S A C D = S A C B + S A B D + S B C D); Geometry.
rewrite H1 in H4.
rewrite H0 in H4.
NormalizeRing H4.
assert (Col B C D); Geometry.
assert (parallelogram A B C D).
unfold parallelogram in |- *; auto.
assert (~ Col B C D); eauto with Geom.
Qed.

Hint Resolve para_not_col_3: Geom.

Theorem para_1 : forall A B C D : Point,
  parallelogram A B C D -> parallelogram A D C B.
Proof.
unfold parallelogram in |- *.
intros.
decompose [and] H.
repeat split; Geometry.
assert (parallelogram A B C D); unfold parallelogram in |- *; auto.
assert (~ Col A C D); eauto with Geom.
Qed.

Hint Resolve para_1: Geom.

Theorem para_2 : forall A B C D : Point,
  parallelogram A B C D -> parallelogram B A D C.
Proof.
intros.
assert (~Col A B D).
eauto with Geom.
unfold parallelogram in *.
intros.
decompose [and] H.
repeat split; Geometry.
Qed.

Hint Resolve para_2: Geom.

Theorem para_3 : forall A B C D : Point,
  parallelogram A B C D -> parallelogram D C B A.
Proof.
intros.
assert (~Col D C B).
eauto with Geom.
unfold parallelogram in *.
intros.
decompose [and] H.
repeat split; Geometry.
Qed.

Hint Resolve para_3: Geom.

Theorem para_4 : forall A B C D : Point,
  parallelogram A B C D -> parallelogram C B A D.
Proof.
intros.
assert (~Col D C B).
eauto with Geom.
unfold parallelogram in *.
intros.
decompose [and] H.
repeat split; Geometry.
Qed.

Hint Resolve para_4: Geom.

Theorem not_para_eq_1 : forall A B C, ~ parallelogram A A B C.
Proof.
intuition idtac.
assert (~ Col A A C).
eauto with Geom.
intuition.
Qed.

Theorem not_para_eq_2 : forall A B C, ~ parallelogram A B C C.
Proof.
intuition idtac.
assert (~ Col B C C).
eauto with Geom.
intuition.
Qed.

Theorem not_para_eq_3 : forall A B C, ~ parallelogram A B C A.
Proof.
intuition idtac.
assert (~ Col A B A).
eauto with Geom.
intuition.
Qed.

Theorem not_para_eq_4 : forall A B C, ~ parallelogram A B B C.
Proof.
intuition idtac.
assert (~ Col A B B).
eauto with Geom.
intuition.
Qed.

Theorem not_para_eq_5 : forall A B C, ~ parallelogram A B A C.
Proof.
intuition idtac.
assert (~ Col A A C).
eauto with Geom.
intuition.
Qed.

Theorem not_para_eq_6 : forall A B C, ~ parallelogram A B C B.
Proof.
intuition idtac.
assert (~ Col B C B).
eauto with Geom.
intuition.
Qed.

Hint Resolve not_para_eq_1 not_para_eq_2 not_para_eq_3
not_para_eq_4 not_para_eq_5 not_para_eq_6 : Geom.

Theorem para_not_eq_1 : forall A B C D,
  parallelogram A B C D -> A<>B.
Proof.
intros.
unfold not;intro.
subst A.
cut (~parallelogram B B C D).
auto.
Geometry.
Qed.

Theorem para_not_eq_2 : forall A B C D,
  parallelogram A B C D -> A<>C.
Proof.
intros.
unfold not;intro.
subst A.
cut (~parallelogram C B C D).
auto.
Geometry.
Qed.

Theorem para_not_eq_3 : forall A B C D,
  parallelogram A B C D -> A<>D.
Proof.
intros.
unfold not;intro.
subst A.
cut (~parallelogram D B C D).
auto.
Geometry.
Qed.

Theorem para_not_eq_4 : forall A B C D,
  parallelogram A B C D -> B<>C.
Proof.
intros.
unfold not;intro.
subst B.
cut (~parallelogram A C C D).
auto.
Geometry.
Qed.

Theorem para_not_eq_5 : forall A B C D,
  parallelogram A B C D -> B<>D.
Proof.
intros.
unfold not;intro.
subst B.
cut (~parallelogram A D C D).
auto.
Geometry.
Qed.

Theorem para_not_eq_6 : forall A B C D,
  parallelogram A B C D -> C<>D.
Proof.
intros.
unfold not;intro.
subst C.
cut (~parallelogram A B D D).
auto.
Geometry.
Qed.

Hint Resolve para_not_eq_1 para_not_eq_2 para_not_eq_3
 para_not_eq_4 para_not_eq_5 para_not_eq_6 : Geom.

Theorem mid_point_equation :
 forall A C O P Q : Point,
 Col O A C -> A <> C -> A ** O = O ** C ->
 S A P Q + S C P Q = 2 * S O P Q.
Proof.
intros.
assert (T := l2_9 P Q A C O H0 H).
rewrite H1 in T.
rewrite T.
assert (O ** C / A ** C = 1 / 2).
assert (A ** O + O ** C = A ** C); Geometry.
rewrite H1 in H2.
rewrite <- H2.
field.
assert (O ** C + O ** C = 2 * O ** C).
ring.
assert (O <> C).
unfold not in |- *; intro.
assert (O ** C = 0); Geometry.
rewrite H5 in H1.
assert (A = O); Geometry.
assert (A = C).
congruence.
auto.
rewrite H3; Geometry.
rewrite H2; field; Geometry.
Qed.

Theorem col_par_par :  forall A B C D D',
 ~C=D ->
 parallel A B C D ->
 Col C D D' ->
 parallel A B C D'.
Proof with Geometry.
intros.
cases_col A C D.
assert (Col C D B).
eapply par_col_col_1 with (C:=A)...
assert (Col C A B).
eapply col_trans_1 with (B:=D)...
assert (Col D A B).
eapply col_trans_1 with (B:=C)...
unfold parallel, S4 in *.
replace (S A C B) with (- S C A B).
rewrite H4.
ring_simplify.
assert (Col C A D').
eapply col_trans_1 with (B:=D)...
cases_equality A C.
subst A.
assert (Col C B D').
eapply col_trans_1 with (B:=D)...
auto.
assert (Col  A B D').
eapply col_trans_1 with (B:=C)...
auto.
Geometry.
assert (~Col B C D).
unfold not;intro.
assert (Col C D A).
eapply par_col_col_1 with (C:=B)...
assert (Col A C D)...

assert (parallel A B C D)...
unfold parallel, S4 in H4.
unfold parallel,S4.

assert (C**D' / C**D = S A C D' / S A C D).
apply A6...
assert (C**D' / C**D = S B C D' / S B C D).
apply A6...
set (C ** D' / C ** D) in *.

RewriteVar (S A C B) H4.

replace (S A B D) with (S A B C + S A C D + S C B D).
2:symmetry;Geometry.
replace (S A B D') with (S A B C + S A C D' + S C B D').
2:symmetry;Geometry.
ring_simplify.
RewriteVar (S A C D') H5.
2:Geometry.
replace (S C B D') with (- S B C D').
2:Geometry.
RewriteVar (S B C D') H6.
2:Geometry.
replace (S B C D) with (-S C B D).
2:Geometry.
ring_simplify.
replace ( S A C D * f - S A C D + S C B D * f - S C B D) with
((S A C D + S C B D) * (f-1)) by ring.
replace (S A C D + S C B D) with 0.
ring.

symmetry.
assert (parallel  C D B A)...
unfold parallel,S4 in *.
RewriteVar (S C B D) H9.
uniformize_signed_areas.
ring.
Qed.


Require Import List.
Require Import Fin.

Require Import fl.cfg.Binarize.
Require Import fl.cfg.Chomsky.
Require Import fl.cfg.Definitions.
Require Import fl.cfg.Separate.

Module ChomskyInduction.

  Import ListNotations Base Definitions Derivation Chomsky.

  Section Definitions.

    Definition syntactic_analysis_is_possible :=
      forall {T V: Type} (G: @grammar T V) (A: var) (l: phrase),
        der G A l ->
        (R A l el G) \/ (exists rhs, R A rhs el G /\ derf G rhs l).

  End Definitions.

  Section Induction.

    Context {T V: Type}.

    Variable G: @grammar T V.
    Variable P: @var V -> @phrase T V -> Prop.

    Hypothesis H_chomsky: chomsky G.
    Hypothesis H_syntactic_analysis: syntactic_analysis_is_possible.

    Section Lemmas.

      Lemma derivability_from_empty:
        forall w, derf G [] w -> w = [].
      Proof.
        intros.
        assert (E: exists (r: @phrase T V), r = []).
        { exists []. reflexivity. }
        destruct E as [r E]; rewrite <- E in H.
        induction H; inversion E; auto.
      Qed.

      Lemma derivability_from_terminal:
        forall x y, derf G [Ts x] y -> [Ts x] = y.
      Proof.
        intros.
        assert (E: exists r, r = [@Ts _ V x]).
        { exists [Ts x]. reflexivity. }
        destruct E as [r E]; rewrite <- E in H.
        induction H; inversion E; subst; auto.
        - apply IHderf1 in E; subst.
          apply derivability_from_empty in H0; subst.
          auto.
      Qed.

      Lemma derf_is_length_monotone:
        forall p1 p2,
          derf G p1 p2 ->
          length p1 <= length p2.
      Proof.
        intros p1 p2 DERF.
        induction DERF.
        - auto.
        - apply Nat.le_trans with (m := |u|); [ | auto].
          apply not_gt; intros CONTR.
          apply lt_n_Sm_le, le_n_0_eq, eq_sym, length_zero_iff_nil in CONTR.
          subst; clear IHDERF DERF.
          destruct H_chomsky as [EF _].
          apply EF in H; auto.
        - simpl in *.
          rewrite app_length, <- Nat.add_1_r, Nat.add_comm.
          apply Nat.add_le_mono; auto.
      Qed.

      Lemma empty_is_not_derivable:
        forall r, ~ der G r [].
      Proof.
        intros r CONTR.
        apply derf_der_equiv in CONTR.
        apply derf_is_length_monotone in CONTR.
        inversion CONTR.
      Qed.

      Lemma derivability_of_terminal:
        forall r t,
          der G r [Ts t] ->
          R r [Ts t] el G.
      Proof.
        intros r t DER.
        destruct (H_syntactic_analysis DER) as [EL|EL].
        exact EL.
        destruct EL as [rhs [EL DER2]].
        assert (LEN:= derf_is_length_monotone DER2).

        assert (EW: rhs = [] \/ (exists t, rhs = [Ts t]) \/ (exists v, rhs = [Vs v])).
        { destruct rhs; [left; reflexivity | right ].
          destruct rhs; [ destruct s | inversion LEN; inversion H0].
          left; exists t0; reflexivity.
          right; exists v; reflexivity. }

        destruct EW as [EQ1 | [EQ2 | EQ3]].
        { exfalso.
          subst rhs.
          destruct H_chomsky as [EF _].
          specialize (EF r [] EL).
          auto. }
        { destruct EQ2; subst rhs.
          apply derivability_from_terminal in DER2; inversion DER2; subst.
          exact EL. }
        { exfalso.
          destruct EQ3; subst rhs.
          exfalso.
          destruct H_chomsky as [_ [_ [_ UF]]].
          eapply UF.
          exists x; eauto. }
      Qed.

      Lemma derivability_step:
        forall w1 w2 r r1 r2,
          R r [Vs r1; Vs r2] el G ->
          der G r1 w1 ->
          der G r2 w2 ->
          @der T V G r (w1 ++ w2).
      Proof.
        intros w1 w2 r r1 r2 RULE DERw1 DERw2.
        apply rDer in RULE.
        rewrite app_nil_end, app_assoc_reverse.
        apply replN with (B := r2); [|exact DERw2].
        rewrite app_nil_r, <- app_nil_l.
        eapply replN with (B := r1); [|exact DERw1].
        auto.
      Qed.

      Lemma derivability_backward_step:
        forall w r,
          length w >= 2 ->
          terminal w ->
          der G r w ->
          exists r1 r2 w1 w2,
            R r [Vs r1; Vs r2] el G /\
            der G r1 w1 /\
            der G r2 w2 /\
            length w1 > 0 /\
            length w2 > 0 /\
            w1 ++ w2 = w.
      Proof.
        intros w r LEN TER DER.
        apply H_syntactic_analysis in DER.
        destruct DER as [RULE | [rhs [RULE DER]]].
        { exfalso.
          destruct H_chomsky as [_ [UF [_ _]]].
          destruct w; [inversion LEN | destruct s].
          { assert (L1: Ts t el Ts t :: w). auto.
            specialize (UF _ _ RULE t L1); clear L1.
            inversion UF; subst w.
            inversion LEN; inversion H0. }
          { assert (EL: Vs v el Vs v :: w). auto.
            specialize (TER (Vs v) EL).
            destruct TER as [t EQ].
            inversion EQ. } }
        { assert (EQ: exists r1 r2, rhs = [Vs r1; Vs r2]).
          { destruct H_chomsky as [EF [SEP [BIN UF]]].
            destruct rhs as [ | [|r1]].
            { specialize (@EF _ _ RULE).
              exfalso; auto. }
            { assert (EL: Ts t el Ts t :: rhs); auto.
              specialize (@SEP _ _ RULE t EL).
              inversion SEP; subst.
              apply derivability_from_terminal in DER; subst.
              simpl in LEN; inversion LEN; inversion H0. }
            { destruct rhs as [ | ].
              { exfalso; eapply UF; exists r1; eauto. }
              { destruct rhs as [|].
                { destruct s as [t | r2].
                  { assert (EL: Ts t el [Vs r1; Ts t]); auto.
                    specialize (@SEP _ _ RULE t EL).
                    inversion SEP; inversion H. }
                  { exists r1, r2; reflexivity. } }
                { specialize (@BIN _ _ RULE).
                  simpl in BIN; inversion BIN; inversion H0; inversion H2. } } } }
          destruct EQ as [r1 [r2 EQ]]; subst rhs.
          eapply derf_split with (u1 := [Vs r1]) (u2 := [Vs r2]) in DER; [ | auto].
          destruct DER as [w1 [w2 [EQ [DER1 DER2]]]].
          apply derf_der_equiv in DER1; apply derf_der_equiv in DER2.
          exists r1, r2, w1, w2.
          repeat split; auto.
          + destruct w1.
            apply empty_is_not_derivable in DER1; inversion DER1.
            apply gt_Sn_O.
          + destruct w2.
            apply empty_is_not_derivable in DER2; inversion DER2.
            apply gt_Sn_O. }
      Qed.

    End Lemmas.

    Section MainLemma.

      Hypothesis inductive_step_1:
        forall (r : _) (t : ter),
          R r [Ts t] el G ->
          P r [Ts t].

      Hypothesis inductive_step_2:
        forall (r r1 r2: _) (w1 w2 : phrase),
          R r [Vs r1; Vs r2] el G ->
          P r1 w1 ->
          P r2 w2 ->
          terminal w1 ->
          terminal w2 ->
          der G r1 w1 ->
          der G r2 w2 ->
          P r (w1 ++ w2).

      Lemma chomsky_derivability_induction:
        forall (r : _) (w : _),
          @der T V G r w ->
          terminal w ->
          P r w.
      Proof.
        intros r w DER.
        assert (LEN: exists n, length w <= n).
        { exists (length w); apply le_n. }
        destruct LEN as [n LEN].
        generalize dependent LEN.
        generalize dependent w.
        generalize dependent r.
        induction n as [|n].
        { intros.
          exfalso.
          apply le_n_0_eq, eq_sym, length_zero_iff_nil in LEN.
          subst w.
          eapply empty_is_not_derivable; eauto. }
        { intros r w DER LEN TER.
          apply le_lt_or_eq in LEN; destruct LEN as [LEN|LEN].
          { apply IHn; auto.
            apply lt_n_Sm_le; exact LEN. }
          { assert (LEN': | w | = 1 \/ | w | > 1).
            { destruct n; [left | right]. exact LEN. rewrite LEN; apply gt_n_S, gt_Sn_O. }
            destruct LEN' as [LEN'|LEN']; [clear LEN | ].
            { assert (EW: (exists t, w = [Ts t]) \/ (exists v, w = [Vs v])).
              { destruct w; [inversion LEN' | ].
                destruct w; [destruct s | ].
                left; exists t; reflexivity. right; exists v; reflexivity.
                inversion LEN'. }
              destruct EW as [[t EQ] | [v EQ]]; subst w.
              { apply inductive_step_1, derivability_of_terminal; auto. }
              { exfalso.
                unfold terminal in TER.
                assert (L: (@Vs T V v) el [Vs v]). auto.
                specialize (TER (Vs v) L).
                inversion TER as [t EQ]; inversion EQ. } }
            { apply gt_le_S in LEN'.
              assert (L:= @derivability_backward_step w r LEN' TER DER).
              destruct L as[r1 [r2 [w1 [w2 [IN [DER1 [DER2 [LEN1 [LEN2 EQ]]]]]]]]].
              rewrite <- EQ.
              assert (length w1 + length w2 = length w).
              { rewrite <- EQ, app_length; reflexivity. }
              rewrite LEN in H.
              rewrite <- EQ in TER.
              destruct (terminal_split TER) as [T1 T2].
              eapply inductive_step_2; eauto.
              { apply IHn; auto.
                apply Nat.add_sub_eq_r in H. rewrite <- H.
                apply Nat.le_sub_le_add_r.
                apply Nat.le_trans with (m := n + 1).
                { rewrite Nat.add_1_r; auto. }
                { apply plus_le_compat_l; auto. } }
              {  apply IHn; auto.
                 apply Nat.add_sub_eq_l in H; rewrite <- H.
                 apply Nat.le_sub_le_add_r.
                 apply Nat.le_trans with (m := n + 1).
                 { rewrite Nat.add_1_r; auto. }
                 { apply plus_le_compat_l; auto. } } } } }
      Qed.

    End MainLemma.

  End Induction.

End ChomskyInduction.


(** * SfLib: Software Foundations Library *)

(* $Date: 2013-01-16 22:29:57 -0500 (Wed, 16 Jan 2013) $ *)

(** Here we collect together several useful definitions and theorems
    from Basics.v, List.v, Poly.v, Ind.v, and Logic.v that are not
    already in the Coq standard library.  From now on we can [Import]
    or [Export] this file, instead of cluttering our environment with
    all the examples and false starts in those files. *)

(** * From the Coq Standard Library *)

Require Omega.   (* needed for using the [omega] tactic *)
Require Export Bool.
Require Export List.
Require Export Arith.
Require Export Arith.EqNat.  (* Contains [beq_nat], among other things *)

(** * From Basics.v *)

Definition admit {T: Type} : T.  Admitted.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => ble_nat n' m'
      end
  end.

Theorem andb_true_elim1 : forall b c,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    reflexivity.
  Case "b = false".
    rewrite <- H. reflexivity.  Qed.

Theorem andb_true_elim2 : forall b c,
  andb b c = true -> c = true.
Proof.
(* An exercise in Basics.v *)
Admitted.

Theorem beq_nat_sym : forall (n m : nat),
  beq_nat n m = beq_nat m n.
(* An exercise in Lists.v *)
Admitted.

(* From Poly.v *)

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

(** * From Props.v *)

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).

(** * From Logic.v *)

Theorem andb_true : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  intros b c H.
  destruct b.
    destruct c.
      apply conj. reflexivity. reflexivity.
      inversion H.
    inversion H.  Qed.

Theorem not_eq_beq_false : forall n n' : nat,
     n <> n' ->
     beq_nat n n' = false.
Proof.
(* An exercise in Logic.v *)
Admitted.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.  Qed.

Theorem ev_not_ev_S : forall n,
  ev n -> ~ ev (S n).
Proof.
(* An exercise in Logic.v *)
Admitted.

Theorem ble_nat_true : forall n m,
  ble_nat n m = true -> n <= m.
(* An exercise in Logic.v *)
Admitted.

Theorem ble_nat_false : forall n m,
  ble_nat n m = false -> ~(n <= m).
(* An exercise in Logic.v *)
Admitted.

Inductive appears_in (n : nat) : list nat -> Prop :=
| ai_here : forall l, appears_in n (n::l)
| ai_later : forall m l, appears_in n l -> appears_in n (m::l).

Inductive next_nat (n:nat) : nat -> Prop :=
  | nn : next_nat n (S n).

Inductive total_relation : nat -> nat -> Prop :=
  tot : forall n m : nat, total_relation n m.

Inductive empty_relation : nat -> nat -> Prop := .

(** * From Later Files *)

Definition relation (X:Type) := X -> X -> Prop.

Definition deterministic {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Inductive multi (X:Type) (R: relation X)
                            : X -> X -> Prop :=
  | multi_refl  : forall (x : X),
                 multi X R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi X R y z ->
                    multi X R x z.
Implicit Arguments multi [[X]].

Tactic Notation "multi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "multi_refl" | Case_aux c "multi_step" ].

Theorem multi_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> multi R x y.
Proof.
  intros X R x y r.
  apply multi_step with y. apply r. apply multi_refl.   Qed.

Theorem multi_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      multi R x y  ->
      multi R y z ->
      multi R x z.
Proof.
  (* FILL IN HERE *) Admitted.

(* Identifiers and polymorphic partial maps. *)
Inductive id : Type :=
  Id : nat -> id.

Definition beq_id id1 id2 :=
  match (id1, id2) with
    (Id n1, Id n2) => beq_nat n1 n2
  end.

Theorem beq_id_refl : forall i,
  true = beq_id i i.
Proof.
  intros. destruct i.
  apply beq_nat_refl.  Qed.

Theorem beq_id_eq : forall i1 i2,
  true = beq_id i1 i2 -> i1 = i2.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  apply beq_nat_eq in H. subst.
  reflexivity.  Qed.

Theorem beq_id_false_not_eq : forall i1 i2,
  beq_id i1 i2 = false -> i1 <> i2.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  apply beq_nat_false in H.
  intros C. apply H. inversion C. reflexivity.  Qed.

Theorem not_eq_beq_id_false : forall i1 i2,
  i1 <> i2 -> beq_id i1 i2 = false.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  assert (n <> n0).
    intros C. subst. apply H. reflexivity.
  apply not_eq_beq_false. assumption.  Qed.

Theorem beq_id_sym: forall i1 i2,
  beq_id i1 i2 = beq_id i2 i1.
Proof.
  intros i1 i2. destruct i1. destruct i2. apply beq_nat_sym. Qed.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if beq_id x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite <- beq_id_refl. auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  beq_id x2 x1 = false ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite H. auto.
Qed.

Lemma extend_shadow : forall A (ctxt: partial_map A) t1 t2 x1 x2,
  extend (extend ctxt x2 t1) x2 t2 x1 = extend ctxt x2 t2 x1.
Proof with auto.
  intros. unfold extend. destruct (beq_id x2 x1)...
Qed.

(** * Some useful tactics *)

Tactic Notation "solve_by_inversion_step" tactic(t) :=
  match goal with
  | H : _ |- _ => solve [ inversion H; subst; t ]
  end
  || fail "because the goal is not solvable by inversion.".

Tactic Notation "solve" "by" "inversion" "1" :=
  solve_by_inversion_step idtac.
Tactic Notation "solve" "by" "inversion" "2" :=
  solve_by_inversion_step (solve by inversion 1).
Tactic Notation "solve" "by" "inversion" "3" :=
  solve_by_inversion_step (solve by inversion 2).
Tactic Notation "solve" "by" "inversion" :=
  solve by inversion 1.