(*|
##########################
Proving termination in Coq
##########################

:Link: https://stackoverflow.com/q/19507311
|*)

(*|
Question
********

How can I prove termination for ``size_prgm``? I tried, but can't come
up with a well founded relation to pass to ``Fix``.
|*)

Require Import List. (* .none *)
Inductive Stmt : Set :=
| assign : Stmt
| if' : list Stmt -> list Stmt -> Stmt.

Fail Fixpoint size_prgm (p : list Stmt) : nat :=
  match p with
  | nil    => 0
  | s :: t => size_prgm t +
                match s with
                | assign  => 1
                | if' b0 b1 => S (size_prgm b0 + size_prgm b1)
                end
  end. (* .fails *)

(*|
Answer (gallais)
****************

The termination oracle is quite better than what it used to be.
Defining a function ``sum_with`` using ``fold_left`` and feeding it
the recursive call to ``size_prgm`` works perfectly well.
|*)

Reset Initial. (* .none *)
Require Import List.

Inductive Stmt : Set :=
| assign : Stmt
| if' : list Stmt -> list Stmt -> Stmt.

Definition sum_with {A : Type} (f : A -> nat) (xs : list A) : nat :=
  fold_left (fun n a => n + f a) xs 0.

Fixpoint size_prgm (p : Stmt) : nat :=
  match p with
  | assign    => 1
  | if' b0 b1 => sum_with size_prgm b1 + sum_with size_prgm b0
  end.

(*|
Answer (Vinz)
*************

Short answer, since I don't have much time right now (I'll try to get
back to you later): this is a really usual (and silly) problem that
every Coq user has to experience one day.

If I recall correctly, there is two "general" solutions to this
problem and lots of very specific ones. For the two former:

1. build a inner fixpoint: I don't really remember how to do this
   properly.
2. use a mutual recursive type: The issue with your code is that you
   use ``list Stmt`` in your ``Stmt`` type, and Coq is not able to
   compute the induction principle you have in mind. But you could use
   a time like
|*)

Reset Initial. (* .none *)
Inductive Stmt : Set :=
| assign : Stmt
| if' : list_Stmt -> list_Stmt -> Stmt
with list_Stmt : Set :=
| Nil_Stmt : list_Stmt
| Cons_Stmt : Stmt -> list_Stmt -> list_Stmt.

(*|
Now write your function over this type and a bijection between this
type and your original ``Stmt`` type.
|*)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* $Id: Field.v 7693 2005-12-21 23:50:17Z herbelin $ *)

(**** Tests of Field with real numbers ****)

Require Import Reals LegacyRfield.

(* Example 1 *)
Goal
forall eps : R,
(eps * (1 / (2 + 2)) + eps * (1 / (2 + 2)))%R = (eps * (1 / 2))%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 2 *)
Goal
forall (f g : R -> R) (x0 x1 : R),
((f x1 - f x0) * (1 / (x1 - x0)) + (g x1 - g x0) * (1 / (x1 - x0)))%R =
((f x1 + g x1 - (f x0 + g x0)) * (1 / (x1 - x0)))%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 3 *)
Goal forall a b : R, (1 / (a * b) * (1 / 1 / b))%R = (1 / a)%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 4 *)
Goal
forall a b : R, a <> 0%R -> b <> 0%R -> (1 / (a * b) / 1 / b)%R = (1 / a)%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 5 *)
Goal forall a : R, 1%R = (1 * (1 / a) * a)%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 6 *)
Goal forall a b : R, b = (b * / a * a)%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 7 *)
Goal forall a b : R, b = (b * (1 / a) * a)%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 8 *)
Goal
forall x y : R,
(x * (1 / x + x / (x + y)))%R =
(- (1 / y) * y * (- (x * (x / (x + y))) - 1))%R.
Proof.
  intros.
   legacy field.
Abort.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(* Notation management revised in December 2002 *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*  NATURAL  .v                                                             *)
(*                                                                          *)
(* Defines (infix)  syntax for operations on nat                            *)
(* Defines tactics for addition and multiplication                          *)
(* Defines some additional properties for addition and multiplication       *)
(*                                                                          *)
(*                                                                          *)
(*                                                                          *)
(*  Samuel Boutin                                                           *)
(*  Coq V5.10                                                               *)
(*  June  1995                                                              *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                              NATURAL.v                                   *)
(****************************************************************************)

Require Export Arith.
Require Export Plus.
Require Export Mult.
Require Import AC.
Require Import HS.

Open Scope nat_scope.

Notation "p .1" := (fst p) (at level 20) : nat_scope.
Notation "p .2" := (snd p) (at level 20) : nat_scope.

(* Redefine explicitly 0 and 1 that are later redefine also in INT_scope *)

Notation "0" := 0 (at level 11) : nat_scope.
Notation "1" := 1 (at level 11) : nat_scope.

(* space around eq *)

Notation "t1  =  t2" := (t1 = t2) (at level 70).

Section NAT.

(*************************************************************
PROPERTIES OF nat
*************************************************************

eq_S         : (n,m:nat)                   n=m->(S n)=(S m)
pred_Sn      : (m:nat)                              m=(pred (S m))

plus_sym     : (n,m:nat)                       n + m = m + n
plus_assoc_l : (n,m,p:nat)               n + (m + p) = (n + m) + p
plus_permute : (n,m,p:nat)               n + (m + p) = m + (n + p)
plus_assoc_r : (n,m,p:nat)               (n + m) + p = n + (m + p)
plus_n_O     : (n:nat)                             n = n + O
plus_n_Sm    : (n,m:nat)                   (S n + m) = n + (S m)
simpl_plus_l : (n,m,p:nat)       n + m = n + p =>  m = p

mult_sym         : (n,m:nat)                   n * m = m * n
mult_assoc_l     : (n,m,p:nat)           n * (m * p) = (n * m) * p
mult_permute     : (n,m,p:nat)           n * (m * p) = m * (n * p)
mult_assoc_r     : (n,m,p:nat)           (n * m) * p = n * (m * p)
mult_n_O         : (n:nat)                         O = n * O
mult_n_Sm        : (n,m:nat)             (n * m) + n = n * (S m)

mult_plus_distr   : (n,m,p:nat)           (n + m) * p = (n * p) + (m * p)
mult_plus_distr_l : (n,m,p:nat)           p * (n + m) = (p * n) + (p * m).
mult_minus_distr : (n,m,p:nat)           (n - m) * p = (n * p) - (m * p)

minus_n_O        : (n:nat)                         n = n - O
minus_n_n        : (n:nat)                         O = n - n

minus_plus_simpl : (n,m,p:nat)                 n - m = (p + n) - (p + m)
plus_minus       : (n,m,p:nat)        n = m + p => p = n - m

*************************************************************)

(* Decision AC for addition and multiplication on N*)

Lemma plus_simpl_l : forall n m p : nat, m = p -> n + m = n + p.
intros.
elim H; auto.
Qed.

Lemma mult_simpl_l : forall n m p : nat, m = p -> n * m = n * p.
intros.
elim H; auto.
Qed.

Lemma mult_permute : forall n m p : nat, n * (m * p) = m * (n * p).
intros.
elim (mult_comm p n).
elim (mult_assoc_reverse m p n).
elim (mult_comm n).
auto.
Qed.

Lemma mult_plus_distr_l : forall n m p : nat, p * (n + m) = p * n + p * m.
intros.
rewrite (mult_comm p).
rewrite (mult_plus_distr_r n m p).
repeat elim (mult_comm p); auto.
Qed.

End NAT.

Ltac CNa := intros; ac_of eq plus plus_comm plus_permute; auto.

Ltac ANa := intros; repeat elim plus_assoc.

Ltac ACNa :=
  intros; repeat elim plus_assoc; ac_of eq plus plus_comm plus_permute; auto.

Ltac HSNa := intros; hs_of eq plus plus_comm plus_permute plus_simpl_l.

Ltac CNm := intros; ac_of eq mult mult_comm mult_permute; auto.

Ltac ANm := intros; repeat elim mult_assoc.

Ltac ACNm :=
  intros; repeat elim mult_assoc; ac_of eq mult mult_comm mult_permute; auto.

Ltac HSNm := intros; hs_of eq mult mult_comm mult_permute mult_simpl_l.


Inductive ProbLevel (X : Type) (level : nat) : Type :=
  | absolute_evid (x : X)
  | prob_evid (p : ProbLevel X (level + 1)).

(* Create a ProbLevel with absolute evidence *)
Check absolute_evid nat 2 1.

(* Create a ProbLevel using probabilistic evidence from 1 level higher *)
Check prob_evid nat 2 (absolute_evid nat 3 1).

Axiom prob_level_abs_imp :
  forall (n : nat) (A : Type) (B: (ProbLevel A n) -> Type)
  (f : forall (a : A), B (absolute_evid A n a)),
  forall (p : ProbLevel A n), (ProbLevel (B p) n).

Axiom prob_level_evid_imp :
  forall (m n : nat) (A : Type) (B: (ProbLevel A m) -> Type)
  (f : forall (p : ProbLevel A (m + 1)), ProbLevel (B (prob_evid A m p)) (n + 1)),
  forall (p : ProbLevel A m), (ProbLevel (B p) n).

Axiom prob_level_abs_comp :
  forall (n : nat) (A : Type) (B: (ProbLevel A n) -> Type)
  (f : forall (a : A), B (absolute_evid A n a)),
  forall (a : A), prob_level_abs_imp n A B f (absolute_evid A n a)
  = absolute_evid (B (absolute_evid A n a)) n (f a).

Axiom prob_level_evid_comp :
  forall (m n : nat) (A : Type) (B: (ProbLevel A m) -> Type)
  (f : forall (p2 : ProbLevel A (m + 1)), ProbLevel (B (prob_evid A m p2)) (n + 1)),
  forall (p : ProbLevel A (m + 1)),
  prob_level_evid_imp m n A B f (prob_evid A m p)
  = prob_evid (B (prob_evid A m p)) n (f p).

Definition prob_level_abs_imp_independent (A B : Type) (f : A -> B) (n : nat)
  := (prob_level_abs_imp n A (fun (_ : ProbLevel A n) => B) f).

Definition prob_level_evid_imp_independent (A B : Type) (m n : nat)
  (f : (ProbLevel A (m + 1)) -> (ProbLevel B (n + 1)))
  := prob_level_evid_imp m n A (fun (_ : ProbLevel A m) => B) f.

Definition prob_level_abs_comp_independent (A B : Type) (f : A -> B) (n : nat) (a : A)
  := prob_level_abs_comp n A (fun (_ : ProbLevel A n) => B) f.

Definition prob_level_evid_comp_independent (A B : Type) (m n : nat)
  (p : ProbLevel A (m + 1)) (f : (ProbLevel A (m + 1)) -> (ProbLevel B (n + 1)))
  := prob_level_evid_comp m n A (fun (_ : ProbLevel A m) => B) f.

(* TODO do we need both parts of the /\? *)
(*
Axiom prob_level_function_extensionality :
  forall (A : Type) (B : Type) (n : nat) (f1 : ProbLevel A n -> B)
    (f2 : ProbLevel A n -> B),
  ((forall (a : A), (f1 (absolute_evid A n a)) = (f2 (absolute_evid A n a)))
  /\
  (forall (p : ProbLevel A (n + 1)), (f1 (prob_evid A n p)) = (f2 (prob_evid A n p))))
  -> f1 = f2.
*)

Axiom prob_level_ind :
  forall (A : Type),
  ((forall (n : nat), (ProbLevel A n)) -> A).

Axiom prob_level_ind_comp :
  forall (A : Type) (f : forall (n : nat), ProbLevel A n),
  (forall (m : nat), absolute_evid A m (prob_level_ind A f) = f m).

Axiom continuum_hypothesis :
  forall (A : Type),
  (forall (a : A), prob_level_ind A (fun (n : nat) => absolute_evid A n a) = a).


(* Check that possible instantiation made during evar materialization
   are taken into account and do not raise Not_found *)

Set Implicit Arguments.

Record SpecializedCategory (obj : Type) (Morphism : obj -> obj -> Type) := {
  Object :> _ := obj;

  Identity' : forall o, Morphism o o;
  Compose' : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d'
}.

Section SpecializedCategoryInterface.
  Variable obj : Type.
  Variable mor : obj -> obj -> Type.
  Variable C : @SpecializedCategory obj mor.

  Definition Morphism (s d : C) := mor s d.
  Definition Identity (o : C) : Morphism o o := C.(Identity') o.
  Definition Compose (s d d' : C) (m : Morphism d d') (m0 : Morphism s d) :
Morphism s d' := C.(Compose') s d d' m m0.
End SpecializedCategoryInterface.

Section ProductCategory.
  Variable objC : Type.
  Variable morC : objC -> objC -> Type.
  Variable objD : Type.
  Variable morD : objD -> objD -> Type.
  Variable C : SpecializedCategory morC.
  Variable D : SpecializedCategory morD.

(* Should fail nicely *)
Definition ProductCategory : @SpecializedCategory (objC * objD)%type (fun s d
=> (morC (fst s) (fst d) * morD (snd s) (snd d))%type).
Fail refine {|
      Identity' := (fun o => (Identity (fst o), Identity (snd o)));
      Compose' := (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd
m2) (snd m1)))
    |}.


From Coq Require Import Classical ClassicalEpsilon.
From VLSM.Lib Require Import SsrExport Traces TraceProperties.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** * Properties of possibly-infinite traces requiring classical logic *)

Section sec_trace_classical_properties.

Context {A B : Type}.

#[local] Notation trace := (@trace A B).
#[local] Notation propT := (@propT A B).

(** ** Relating finiteness and infiniteness *)

Lemma not_infiniteT_finiteT : forall tr : trace,
 ~ infiniteT tr -> finiteT tr.
Proof.
move => tr Hnot.
case: (classic (finiteT tr)) => Hinf //.
case: Hnot.
exact: not_finiteT_infiniteT.
Qed.

Lemma finiteT_infiniteT : forall tr : trace,
 finiteT tr \/ infiniteT tr.
Proof.
move => tr.
case: (classic (finiteT tr)) => Hinf; first by left.
right; exact: not_finiteT_infiniteT.
Qed.

Definition finiteT_infiniteT_dec (tr : trace) : { finiteT tr }+{ infiniteT tr } :=
match excluded_middle_informative (finiteT tr) with
| left Hfin => left Hfin
| right Hfin => right (not_finiteT_infiniteT Hfin)
end.

(** ** Using midpoints to show the right associativity of the append property *)

CoFixpoint midp (p0 p1 : trace -> Prop) tr0 tr1 (h : followsT (appendT p0 p1) tr0 tr1) : trace :=
match followsT_dec h with
| inl (existT tr (exist a (conj _ (conj _ H)))) =>
  let: exist x _ := constructive_indefinite_description _ H in x
| inr (existT tr (existT tr' (existT a (exist b (conj _ (conj _ H)))))) =>
  Tcons a b (@midp _ _ _ _ H)
end.

Lemma midpointT_midp :
  forall (p0 p1 : trace -> Prop) tr0 tr1 (h : followsT (appendT p0 p1) tr0 tr1),
    midpointT h (midp h).
Proof.
cofix CIH.
dependent inversion h; subst.
- rewrite [midp _]trace_destr /=.
  case: (constructive_indefinite_description _ _) => /= x [a1 hm].
  by apply: midpointT_nil => //; case: x a1 hm.
- rewrite [midp _]trace_destr /=.
  exact: (@midpointT_delay _ _ p0 p1 (Tcons a b tr) (Tcons a b tr')
    (followsT_delay a b f) tr tr' f a b (midp f)).
Qed.

Lemma appendT_assoc_R : forall p1 p2 p3,
 forall tr : trace, (appendT p1 (appendT p2 p3)) tr -> (appendT (appendT p1 p2)  p3) tr.
Proof.
move => p1 p2 p3 tr0 [tr1 [h1 h2]].
exists (midp h2); split.
- exists tr1; split => //.
  exact: (midpointT_before (midpointT_midp h2)).
- exact: (midpointT_after (midpointT_midp h2)).
Qed.

Lemma AppendT_assoc_R : forall (p1 p2 p3 : propT), (p1 *** p2 *** p3) =>> (p1 *** p2) *** p3.
Proof.
move => [f1 hf1] [f2 hf2] [f3 hf3] tr0 /= h1.
exact: appendT_assoc_R.
Qed.

End sec_trace_classical_properties.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Functor.Diagonal.
Require Export Category.Structure.Cone.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

(* A natural transformation Δd ⟹ F (where Δd is the Constant functor on d) is
   the same as a cone over F (whose vertex is d). *)

Theorem Cone_Transform {J : Category} {C : Category} (F : J ⟶ C) (d : C) :
  Diagonal J d ⟹ F ↔ { c : Cone F | vertex_obj = d }.
Proof.
  split; intros.
  - unshelve eexists.
    + unshelve econstructor; intros.
      * exact d.
      * apply X.
      * simpl.
        rewrite (naturality[X]); cat.
    + reflexivity.
  - transform; simpl; intros;
    destruct X; subst.
    + apply x0.
    + cat; apply ump_cones.
    + cat; symmetry; apply ump_cones.
Qed.


Require Import Arith.
Require Import List.
Require Import Relations.
Require Import Wellfounded.
Require Import list_util.
Require Import ModEq.

Set Implicit Arguments.

Hint Resolve le_plus_r le_plus_l le_n_S le_S_n.

Section CharType.

Variable C: Set.
Variable C_eq_dec: forall x y:C, {x=y}+{x<>y}.

(* Deterministic Finite Automata *)
Record DFA: Set := mkDFA {
  DFAstates: list nat; DFAtrans: nat->C->nat;
  DFAinit: nat; DFAaccept: list nat;
  DFAtrans_const: forall c s, In s DFAstates -> In (DFAtrans s c) DFAstates;
  DFAinit_const: In DFAinit DFAstates;
  DFAacc_const: incl DFAaccept DFAstates}.
Definition DFAacc (d:DFA) (w:list C) : Prop := In (fold_left (DFAtrans d) w (DFAinit d)) (DFAaccept d).
Definition DFAacc_dec: forall d w, {DFAacc d w}+{~DFAacc d w}. intros. destruct (in_dec nat_eq_dec (fold_left (DFAtrans d) w (DFAinit d)) (DFAaccept d)); [left|right]; auto. Defined.
Definition DFA_neg: forall d, {e|forall w, DFAacc e w <-> ~DFAacc d w}. intros. destruct d. assert (H:incl (removeAll nat_eq_dec DFAaccept0 DFAstates0) DFAstates0). intros s Hs. apply removeAll_In in Hs. destruct Hs; auto. exists (mkDFA DFAtrans0 DFAinit0 DFAtrans_const0 DFAinit_const0 H). unfold DFAacc; simpl; intros; split; intros. apply removeAll_In in H0. destruct H0; auto. apply removeAll_In. split; auto. clear -DFAinit_const0 DFAtrans_const0. revert DFAinit_const0. generalize DFAinit0. induction w; simpl; auto. Defined.
Definition DFA_and: forall d1 d2, {e|forall w, DFAacc e w <-> DFAacc d1 w /\ DFAacc d2 w}. intros. destruct d1 as [st1 tr1 i1 a1 Ht1 Hi1 Ha1]. destruct d2 as [st2 tr2 i2 a2 Ht2 Hi2 Ha2]. destruct (ubound_sig st2) as [u H _]. destruct (nat_eq_dec u 0) as [Hu|Hu]. subst u. absurd (i2<0); auto. remember (flat_map (fun x=> (map (fun y=>x*u+y) st2)) st1) as st. remember (i1*u+i2) as i. remember (flat_map (fun x=>map (fun y=>x*u+y) a2) a1) as a. remember (fun s c=> let (s1,s2):=(divN Hu s,modN Hu s) in tr1 s1 c*u+tr2 s2 c) as tr.
  assert (Htr:forall c s, In s st-> In (tr s c) st). subst st tr. intros. apply in_flat_map. apply in_flat_map in H0. destruct H0 as [s1 [H1 H2]]. apply in_map_iff in H2. destruct H2 as [s2 [H2 H3]]. subst s. unfold divN. unfold modN. destruct (divmod u (s1*u+s2)) as [[q [r [H4 H5] H6]]|H4]; [|contradiction]. destruct (H6 s1 s2); auto. subst q r. exists (tr1 s1 c). split; auto. apply in_map_iff. exists (tr2 s2 c); auto. assert (Hi:In i st). subst i st. apply in_flat_map. exists i1. split; auto. apply in_map_iff. exists i2; auto.
  assert (Ha:incl a st). subst a st. intros s Hs. apply in_flat_map in Hs. apply in_flat_map. destruct Hs as [s1 [H0 H1]]. apply in_map_iff in H1. destruct H1 as [s2 [H1 H2]]. subst s. exists s1. split; auto. apply in_map_iff. exists s2; auto. exists (mkDFA tr i Htr Hi Ha). unfold DFAacc; simpl. assert (forall w s1 s2, In s1 st1->In s2 st2->fold_left tr w (s1*u+s2)=fold_left tr1 w s1*u+fold_left tr2 w s2). induction w; simpl; intros; auto. rewrite <- IHw; auto. f_equal. subst tr. unfold divN. unfold modN. destruct (divmod u (s1*u+s2)) as [[q [r [H2 H3] H4]]|H4]; [|contradiction]. destruct (H4 s1 s2); auto. subst q r; auto.
  intros; split; intros. subst a i. rewrite H0 in H1; auto. apply in_flat_map in H1. destruct H1 as [s1 [H1 H2]]. apply in_map_iff in H2. destruct H2 as [s2 [H2 H3]]. destruct (divmod u (s1*u+s2)) as [[q [r [H4 H5] H6]]|H4]; [|contradiction]. destruct (H6 s1 s2); auto. subst q r. destruct (H6 (fold_left tr1 w i1) (fold_left tr2 w i2)); auto. apply H. revert Hi2. generalize i2. clear -Ht2. induction w; simpl; auto. subst s1 s2; auto. destruct H1. subst tr i a. apply in_flat_map. exists (fold_left tr1 w i1). split; auto. apply in_map_iff. exists (fold_left tr2 w i2). split; auto. rewrite H0; auto. Defined.
Definition DFA_nil: {d|forall w, ~DFAacc d w}. assert (Htr:forall (c:C) (s:nat), In s (0::nil) -> In ((fun _ _=>0) c s) (0::nil)). auto. assert (Hi:In 0 (0::nil)). auto. assert (Ha:incl nil (0::nil)). auto. exists (mkDFA (fun _ _=>0) 0 Htr Hi Ha). unfold DFAacc. simpl. intros w D; auto. Defined.
Definition DFA_word: forall w, {d|forall cs, DFAacc d cs <-> cs=w}. induction w. assert (Htr:forall c s, In s (1::0::nil) -> In ((fun (c:C) s=> 0) c s) (1::0::nil)). intros. auto. assert (Hi: In 1 (1::0::nil)); auto. assert (Ha: incl (1::nil) (1::0::nil)). intros x Hx. destruct Hx. subst x; auto. destruct H. exists (mkDFA (fun _ _=>0) 1 Htr Hi Ha). unfold DFAacc. simpl. intros; split; intros. destruct H. destruct cs; auto. simpl in H. contradict H. induction cs; simpl. discriminate. auto. destruct H. subst cs. simpl; auto. destruct IHw as [d H]. destruct d as [st tr i ac Htr Hi Ha]. unfold DFAacc in H. simpl in H.
  destruct (ubound_sig st) as [u Hu _]. remember (fun s c=>if nat_eq_dec s u then if C_eq_dec c a then i else (S u) else if nat_eq_dec s (S u) then (S u) else tr s c) as tr'. assert (Htr':forall c s, In s (S u::u::st) -> In (tr' s c) (S u::u::st)). intros. subst tr'. destruct (nat_eq_dec s u). destruct (C_eq_dec c a); auto. destruct (nat_eq_dec s (S u)); auto. right; right. apply Htr. destruct H0. contradict n0; auto. destruct H0. contradict n; auto. auto. assert (Hi':In u (S u::u::st)); auto. assert (Ha':incl ac (S u::u::st)); auto. intros x Hx; auto. assert (Ht1:forall s c, In s st ->tr' s c = tr s c). intros. subst tr'. destruct (nat_eq_dec s u). subst s. absurd (u<u); auto. destruct (nat_eq_dec s (S u)). subst s. absurd (S u<u); auto. auto.
  exists (mkDFA tr' u Htr' Hi' Ha'). unfold DFAacc. simpl. intros; split; intros. destruct cs. simpl in H0. absurd (u<u); auto. simpl in H0. rewrite Heqtr' in H0. destruct (nat_eq_dec u u). destruct (C_eq_dec c a). subst a. f_equal. apply H. rewrite <- Heqtr' in H0. revert H0. revert Hi.  generalize i as s. induction cs; simpl; intros; auto. apply IHcs; auto. rewrite Ht1 in H0; auto. rewrite <- Heqtr' in H0. replace (fold_left tr' cs (S u)) with (S u) in H0. absurd (S u<u); auto. clear H0. induction cs; simpl; auto. rewrite IHcs at 1. f_equal. subst tr'. destruct (nat_eq_dec (S u) u). absurd (u<u); auto. rewrite <- e0 at 2; auto. destruct (nat_eq_dec (S u) (S u)); auto. contradict n1; auto. contradict n; auto.
  subst cs. simpl. replace (tr' u a) with i. replace (fold_left tr' w i) with (fold_left tr w i). apply H; auto. revert Hi. generalize i as s. clear H. induction w; simpl; intros; auto. rewrite Ht1; auto. subst tr'. destruct (nat_eq_dec u u). destruct (C_eq_dec a a); auto. contradict n; auto. contradict n; auto. Defined.

(* Non-deterministic Finite Automata *)
Record NFA: Type := mkNFA {
  NFAstates: list nat;
  NFAtrans: nat -> C -> list nat;
  NFAinit: list nat; (* take a list for future extension *)
  NFAaccept: list nat;
  NFAtrans_const: forall c s, In s NFAstates -> incl (NFAtrans s c) NFAstates;
  NFAinit_const: incl NFAinit NFAstates;
  NFAacc_const: incl NFAaccept NFAstates;
}.
Inductive NFAsteps (tr:nat->C->list nat) : list C -> list nat -> Prop:=
| NFAsteps_nil: forall s, NFAsteps tr nil (s::nil)
| NFAsteps_cons: forall s t l w c, NFAsteps tr w (t::l) -> In t (tr s c) -> NFAsteps tr (c::w) (s::t::l)
.
Inductive NFAacc (n:NFA) (w:list C) : Prop := NFAacc_intro: forall is es l, In es (NFAaccept n) ->In is (NFAinit n) -> NFAsteps (NFAtrans n) w l -> Head is l -> Tail es l -> NFAacc n w.
Hint Constructors NFAsteps NFAacc.

Theorem NFAsteps_const: forall l s w st tr, (forall c s, In s st-> incl (tr s c) st) -> NFAsteps tr w l -> Head s l -> In s st -> incl l st. Proof. induction l; intros. inversion H1. inversion H0. inversion H1. subst a w s0 l a0 l0. intros x Hx. destruct Hx. subst x; auto. destruct H3. inversion H1. subst w s0 l a0 a l1. intros x Hx. destruct Hx. subst x; auto. cut (incl (t::l0) st); intros; auto. apply IHl with (w:=w0) (tr:=tr) (s:=t); auto. apply H in H7; auto. Qed.
Definition NFAsteps_states': forall tr w s, {sl| forall l, In l sl <-> Head s l /\ NFAsteps tr w l}. induction w; intros. exists ((s::nil)::nil); intros; split; intros. destruct H. subst l; auto. destruct H. destruct H. inversion H0. subst l. inversion H. subst a s0 l. left; auto.
  exists (flat_map (fun t=>let (sl,_):= IHw t in map (cons s) sl) (tr s a)). intros; split; intros. apply in_flat_map in H. destruct H as [t [H1 H2]]. destruct (IHw t) as [sl H3]. apply in_map_iff in H2. destruct H2 as [m [H4 H5]]. subst l. split; auto. apply H3 in H5. destruct H5. inversion H. subst a0 m. auto. destruct H. apply in_flat_map. inversion H0. subst a w0 l. inversion H. subst a s0 l. exists t. split; auto. destruct (IHw t) as [sl H6]. apply in_map_iff. exists (t::l0); auto. split; auto. apply H6. auto. Defined.
Definition NFAsteps_states: forall tr w sl, {tl| forall t, In t tl <-> exists s l, In s sl /\ NFAsteps tr w l /\ Head s l /\ Tail t l}. intros. exists (map (fun l=>match tail l with inleft (existT _  a _) => a |inright _ => 0 end) (flat_map (fun s=>let (l,_):=NFAsteps_states' tr w s in l) sl)). intros; split; intros. apply in_map_iff in H. destruct H as [x [H H0]]. apply in_flat_map in H0. destruct H0 as [y [H0 H1]]. destruct (NFAsteps_states' tr w y) as [l H2]. apply H2 in H1. destruct H1. destruct (tail x) as [[a [m H4]]|H4]. subst x a. exists y. exists (m++t::nil); auto. subst x t. inversion H1.
  destruct H as [s [l [H1 [H2 [H3 H4]]]]]. apply in_map_iff. exists l. split. destruct (tail l) as [[a [m H5]]|H5]. subst l. apply Tail_app_rev in H4. inversion H4; auto. inversion H5. discriminate. subst l. inversion H3. apply in_flat_map. exists s. split; auto. destruct (NFAsteps_states' tr w s). apply i. auto. Defined.
Definition NFAacc_dec: forall n w, {NFAacc n w}+{~NFAacc n w}. intros. destruct (NFAsteps_states (NFAtrans n) w (NFAinit n)) as [tl H _]. destruct findP with (l:=tl) (P:=fun s=>In s (NFAaccept n)) as [[s H0]|H0]. intros. apply in_dec. apply nat_eq_dec. left. apply H in H0.  destruct H0 as [is [l [H1 [H2 [H3 H4]]]]]. apply NFAacc_intro with is s l; auto. right. intros D. inversion D. contradict H1. apply H0. apply H. exists is. exists l; auto. Defined.

Theorem NFAsteps_app: forall tr w1 l1, NFAsteps tr w1 l1 -> forall w2 l2 s, NFAsteps tr w2 (s::l2) -> Tail s l1 -> NFAsteps tr (w1++w2) (l1++l2). Proof. intros tr w1 l1 H. induction H; simpl; intros. inversion H0. subst a s0; auto. inversion H3. apply NFAsteps_cons; auto. apply IHNFAsteps with s0; auto. inversion H2; auto. Qed.
Theorem NFAsteps_app_s_rev: forall tr l1 l2 w s, NFAsteps tr w (l1++l2) -> Tail s l1 -> exists w1 w2, w=w1++w2 /\ NFAsteps tr w1 l1 /\ NFAsteps tr w2 (s::l2). Proof. induction l1 as [|t l1]; simpl; intros. inversion H0. inversion H. subst w s0. exists nil. exists nil. split; auto. split. destruct l1; auto. inversion H4. destruct l2; auto. destruct l1; inversion H4. subst w s0. rewrite H2 in H4. inversion H0. subst a t l1. simpl in H2. subst l2. exists nil. exists (c::w0); auto. subst a b l0. destruct l1. inversion H6. inversion H2. subst t0 l. apply IHl1 with (s:=s) in H4; auto. destruct H4 as [w1 [w2 [H9 [H7 H8]]]]. exists (c::w1). exists w2. split; simpl; f_equal; auto. Qed.
Theorem NFAsteps_app_w_rev: forall tr w1 w2 l, NFAsteps tr (w1++w2) l -> exists s l1 l2, l=l1++l2 /\ NFAsteps tr w1 l1 /\ NFAsteps tr w2 (s::l2) /\ Tail s l1. Proof. induction w1 as [|c w1]; simpl; intros. destruct l as [|t l]. inversion H. exists t. exists (t::nil). exists l; auto. inversion H. subst c0 w l. apply IHw1 in H2. destruct H2 as [u [l1 [l2 [Ha [Hb [Hc Hd]]]]]]. exists u. destruct l1. inversion Hb. inversion Ha. subst n l0. exists (s::t::l1). exists l2. split; auto. Qed.
Theorem NFAsteps_parteq: forall tr1 tr2 w l st, incl l st -> (forall s c, In s st -> tr1 s c = tr2 s c) -> NFAsteps tr1 w l -> NFAsteps tr2 w l. Proof. intros. induction H1; auto. apply NFAsteps_cons; auto. apply IHNFAsteps. intros x Hx; auto. rewrite <- H0; auto. Qed.
Theorem NFAsteps_length: forall tr w l, NFAsteps tr w l -> length l = S(length w). Proof. intros. induction H; simpl; auto. Qed.

(* Non-deterministic Finite Automata with Empty *)
Record EFA: Set := mkEFA {
  EFAstates: list nat; EFAtrans: nat->C->list nat; EFAempty: nat->list nat;
  EFAinit: list nat; (* take a list for future extension *)
  EFAaccept: list nat;
  EFAtrans_const: forall c s, In s EFAstates -> incl (EFAtrans s c) EFAstates;
  EFAempty_const: forall s, In s EFAstates -> incl (EFAempty s) EFAstates;
  EFAinit_const: incl EFAinit EFAstates;
  EFAacc_const: incl EFAaccept EFAstates;
}.
Inductive EFAsteps (tr:nat->C->list nat) (emp:nat->list nat) : list C -> list nat -> Prop:=
| EFAsteps_nil: forall s, EFAsteps tr emp nil (s::nil)
| EFAsteps_empty: forall s t l w, EFAsteps tr emp w (t::l) -> In t (emp s) -> EFAsteps tr emp w (s::t::l)
| EFAsteps_cons: forall s t l w c, EFAsteps tr emp w (t::l) -> In t (tr s c) -> EFAsteps tr emp (c::w) (s::t::l)
.
Inductive EFAacc (n:EFA) (w:list C) : Prop := EFAacc_intro: forall is es l, In es (EFAaccept n) -> In is (EFAinit n) -> EFAsteps (EFAtrans n) (EFAempty n) w l -> Head is l -> Tail es l -> EFAacc n w.
Hint Constructors EFAsteps EFAacc clos_refl_trans.

Theorem EFAsteps_const: forall l w s st tr emp, (forall c s, In s st->incl (tr s c) st) -> (forall s, In s st->incl (emp s) st) -> In s st -> EFAsteps tr emp w l -> Head s l -> incl l st. Proof. induction l; intros. inversion H3. intros x Hx. destruct Hx. subst x. inversion H3. subst a a0 l0. auto. inversion H2. subst w s0 l. destruct H4. subst w0 a l. cut (incl (t::l0) st); intros; auto. apply IHl with (w:=w) (tr:=tr) (emp:=emp) (s:=t); auto. inversion H3. subst a s0 l. apply H0 in H9; auto. inversion H3. subst w a s0 a0 l l1. cut (incl (t::l0) st); intros; auto. apply IHl with (w:=w0) (s:=t) (tr:=tr) (emp:=emp); auto. apply H in H9; auto. Qed.
Theorem EFAsteps_app: forall tr emp w1 l1, EFAsteps tr emp w1 l1 -> forall w2 l2 s, EFAsteps tr emp w2 (s::l2) -> Tail s l1 -> EFAsteps tr emp (w1++w2) (l1++l2). Proof. intros tr emp w1 l1 H. induction H; simpl; intros. inversion H0. subst a s0; auto. inversion H3. apply EFAsteps_empty; auto. replace (t::l++l2) with ((t::l)++l2); auto. apply IHEFAsteps with s0; auto. inversion H2; auto. apply EFAsteps_cons; auto. replace (t::l++l2) with ((t::l)++l2); auto. apply IHEFAsteps with s0; auto. inversion H2; auto. Qed.
Theorem EFAsteps_app_s_rev: forall tr emp l1 l2 w s, EFAsteps tr emp w (l1++l2) -> Tail s l1 -> exists w1 w2, w=w1++w2 /\ EFAsteps tr emp w1 l1 /\ EFAsteps tr emp w2 (s::l2). Proof. induction l1 as [|t l1]; simpl; intros. inversion H0. inversion H. subst w s0. exists nil. exists nil. split; auto. split. destruct l1; auto. inversion H4. destruct l2; auto. destruct l1; inversion H4. subst w0 s0. rewrite H2 in H4. inversion H0. subst a t l1. simpl in H2. subst l2. exists nil. exists w; auto. subst a b l0. destruct l1. inversion H6. inversion H2. subst n l. apply IHl1 with (s:=s) in H4; auto. destruct H4 as [w1 [w2 [H9 [H7 H8]]]]. exists w1. exists w2. split; auto.
  subst s0 w. inversion H0. subst a t l1. exists nil. exists (c::w0). simpl in H2. subst l2. auto. subst a b l0. destruct l1. inversion H6. inversion H2. subst n l. replace (t0::l1++l2) with ((t0::l1)++l2) in H4; auto. apply IHl1 with (s:=s) in H4; auto. destruct H4 as [w1 [w2 [H7 [H8 H9]]]]. subst w0. exists (c::w1). exists w2; auto. Qed.
Theorem EFAsteps_cons_rev: forall tr emp w c l, EFAsteps tr emp (c::w) l -> exists s t l1 l2, l=l1++t::l2 /\ Tail s l1 /\ EFAsteps tr emp nil l1 /\ EFAsteps tr emp w (t::l2) /\ In t (tr s c). Proof. intros tr emp w c l H. remember (c::w) as w' in H. revert Heqw'. revert c w. induction H; intros. inversion Heqw'. apply IHEFAsteps in Heqw'. destruct Heqw' as [s' [t' [l1' [l2' [H1 [H2 [H3 [H4 H5]]]]]]]].  exists s'. exists t'. exists (s::l1'). exists l2'. split. simpl; f_equal; auto. split ; auto. split; auto. destruct l1'; auto. inversion H1. subst n l; auto. inversion Heqw'. subst c0 w0. exists s. exists t. exists (s::nil). exists l; auto. Qed.
Theorem EFAsteps_app_w_rev: forall tr emp w1 w2 l, EFAsteps tr emp (w1++w2) l -> exists s l1 l2, l=l1++l2 /\ Tail s l1 /\ EFAsteps tr emp w1 l1 /\ EFAsteps tr emp w2 (s::l2). Proof. induction w1 as [|c w1]; simpl; intros. destruct l as [|s l]. inversion H. exists s. exists (s::nil). exists l; auto. destruct (EFAsteps_cons_rev H) as [s [t [l1 [l2 [H1 [H2 [H3 [H4 H5]]]]]]]]. subst l. destruct (IHw1 w2 (t::l2) H4) as [u [m1 [m2 [H6 [H7 [H8 H9]]]]]]. destruct m1. inversion H8. inversion H6. subst n l2. exists u. exists (l1++t::m1). exists m2. split; auto. rewrite <- app_assoc; auto. split; auto. split; auto. replace (c::w1) with (nil++c::w1); auto. apply EFAsteps_app with s; auto. Qed.
Definition EFA_empty_states': forall emp sl st, (forall s, In s st -> incl (emp s) st) -> incl sl st-> {tl|forall t, In t tl<->exists s, In s sl /\ clos_refl_trans nat (fun x y=>In y (emp x)) s t}. intros emp sl st He. apply (Fix (well_founded_ltof (list nat) (fun l=>length (removeAll nat_eq_dec l st)))) with (P:=fun sl=>incl sl st->{tl|forall t,In t tl<->exists s,In s sl/\clos_refl_trans nat (fun x y=>In y (emp x)) s t}). clear sl. intros sl IH H. destruct (incl_dec nat_eq_dec (flat_map emp sl) sl) as [[x H0 H1]|H0]. destruct (IH (flat_map emp sl++sl)) as [tl H2]. unfold ltof. rewrite removeAll_app. apply removeAll_length2 with x; auto. apply removeAll_In. split; auto. apply in_flat_map in H0. destruct H0 as [y [H2 H3]]. apply He in H3; auto.
  intros y Hy. apply in_app_or in Hy. destruct Hy; auto. apply in_flat_map in H2. destruct H2 as [z [H3 H4]]. apply He in H4; auto. exists tl. intros t; split; intros. apply H2 in H3. destruct H3 as [s [H4 H5]]. apply in_app_or in H4. destruct H4. apply in_flat_map in H3. destruct H3 as [u [H6 H7]]. exists u. split; auto. apply rt_trans with s; auto. exists s; auto. apply H2. destruct H3 as [s [H4 H5]]. exists s. split; auto. apply in_or_app; auto. exists sl. intros; split; intros. exists t; auto. destruct H1 as [s [H2 H3]]. clear -H0 H2 H3 He. induction H3; auto. apply H0. apply in_flat_map. exists x; auto. Defined.
Theorem EFAsteps_incl: forall tr1 emp1 tr2 emp2 w l st, incl l st -> (forall s t, In s st-> In t (emp1 s) -> In t st -> In t (emp2 s)) -> (forall s c t, In s st -> In t (tr1 s c) -> In t st -> In t (tr2 s c)) -> EFAsteps tr1 emp1 w l -> EFAsteps tr2 emp2 w l. Proof. intros. induction H2; auto. apply EFAsteps_empty; auto. apply IHEFAsteps. intros x Hx; auto. apply EFAsteps_cons; auto. apply IHEFAsteps. intros x Hx; auto. Qed.

Definition EFA_empty_states: forall tr emp sl st, (forall s, In s st->incl (emp s) st) -> incl sl st -> {tl|forall t, In t tl<->exists s, In s sl /\ exists l, EFAsteps tr emp nil l /\ Head s l /\ Tail t l}. intros. destruct (EFA_empty_states' emp H H0) as [tl H1]. exists tl. intros; split; intros. apply H1 in H2. destruct H2 as [s [H2 H3]]. exists s. split; auto. clear -H3. induction H3. exists (x::y::nil); auto. exists (x::nil); auto. destruct IHclos_refl_trans1 as [l [H1 [H5 H6]]]; auto. destruct IHclos_refl_trans2 as [m [H7 [H9 H10]]]. inversion H9. subst a m. exists (l++l0). split. cut (EFAsteps tr emp (nil++nil) (l++l0)); auto. apply EFAsteps_app with y; auto. split. inversion H5; simpl; auto. inversion H10. subst a z l0. rewrite app_nil_r; auto. subst a b l1. auto. apply H1. destruct H2 as [s [H3 [l [H4 [H5 H6]]]]]. exists s; split; auto. inversion H5. subst a l. clear -H4 H6. revert H6 H4. revert s. induction l0; intros. inversion H6. apply rt_refl. inversion H1. inversion H4. subst w s0 t0 l0. apply rt_trans with a. apply rt_step; auto. apply IHl0; auto. inversion H6; auto. Defined.
Definition EFAsteps_states: forall tr emp w sl st, (forall c s, In s st->incl (tr s c) st) -> (forall s, In s st->incl (emp s) st) ->incl sl st -> {tl|forall t, In t tl <-> exists s, In s sl /\ exists l, EFAsteps tr emp w l /\ Head s l /\ Tail t l}. induction w as [|c w]; intros. destruct (EFA_empty_states tr emp H0 H1) as [tl H2]. exists tl. auto.
  destruct (EFA_empty_states tr emp H0 H1) as [tl H2]. assert (H3: incl (flat_map (fun s=>tr s c) tl) st). intros x Hx. apply in_flat_map in Hx. destruct Hx as [y [H3 H4]]. apply H in H4; auto. destruct (H2 y). destruct (H5 H3) as [s [Ha [l [Hb [Hc Hd]]]]]. apply EFAsteps_const with (s:=s) (st:=st) in Hb; auto. destruct (IHw (flat_map (fun s=>tr s c) tl) st H H0 H3) as [ul H4]. clear IHw. exists ul. intros; split; intros. apply H4 in H5. destruct H5 as [s [Ha [l [Hb [Hc Hd]]]]]. clear H4. apply in_flat_map in Ha. destruct Ha as [x [H4 H5]]. apply H2 in H4. destruct H4 as [y [H4 [m [H8 [H6 H7]]]]]. clear H2. exists y. split; auto. exists (m++l). split. replace (c::w) with (nil++c::w); auto. apply EFAsteps_app with x; auto. inversion Hc. subst a l. apply EFAsteps_cons; auto. split. inversion H6; simpl; auto. auto.  apply H4. clear H4. destruct H5 as [s [H4 [l [H8 [H6 H7]]]]]. destruct (EFAsteps_cons_rev H8) as [u [v [l1 [l2 [Ha [Hb [Hc [Hd He]]]]]]]]. subst l. exists v. split. apply in_flat_map. exists u. split; auto. apply H2. clear H2. exists s. split; auto. exists l1; auto. split; auto. split; auto. destruct l1. inversion Hc. inversion H6; auto. exists (v::l2). split; auto. split; auto. apply Tail_app_rev in H7; auto. discriminate. Defined.
Definition EFAacc_dec: forall n w, {EFAacc n w}+{~EFAacc n w}. intros. destruct EFAsteps_states with (tr:=EFAtrans n) (emp:=EFAempty n) (sl:=EFAinit n) (w:=w) (st:=EFAstates n) as [tl H]. apply (EFAtrans_const n). apply (EFAempty_const n). apply (EFAinit_const n); auto. destruct findP with (P:=fun s=>In s tl) (l:=EFAaccept n). intros. apply in_dec. apply nat_eq_dec. destruct s as [s H1 H2]. left. apply H in H2. destruct H2 as [is [H4 [l [H5 [H6 H7]]]]]. apply EFAacc_intro with is s l; auto. right. intros D. inversion D. apply n0 in H0. contradict H0. apply H. exists is. split; auto. exists l; auto. Defined.

Definition EFA2NFA: forall e, {n| forall w, EFAacc e w <-> NFAacc n w}. intros. destruct (EFA_empty_states (EFAtrans e) (EFAempty e) (EFAempty_const e) (EFAinit_const e)) as [is H]. assert (Hi: incl is (EFAstates e)). intros x Hx. apply H in Hx. destruct Hx as [s [H1 [l [H2 [H3 H4]]]]]. apply (EFAinit_const e) in H1. apply EFAsteps_const with (s:=s) (st:=EFAstates e) in H2; auto. apply (EFAtrans_const e). apply (EFAempty_const e); auto. remember (fun s c=>match in_dec nat_eq_dec s (EFAstates e) with |left H => match EFA_empty_states (EFAtrans e) (EFAempty e) (EFAempty_const e) (EFAtrans_const e c s H) with exist _ sl _ => sl end |right _ => nil end) as tr. assert (Ht: forall c s, In s (EFAstates e) -> incl (tr s c) (EFAstates e)). intros. subst tr. destruct (in_dec nat_eq_dec s (EFAstates e)); [|contradiction]. destruct (EFA_empty_states (EFAtrans e) (EFAempty e) (EFAempty_const e) (EFAtrans_const e c s i)) as [tl H1]. intros x Hx. apply H1 in Hx.  destruct Hx as [t [H2 [l [H3 [H4 H5]]]]]. inversion H4. subst a l. assert (In t (EFAstates e)). apply (EFAtrans_const e c s); auto. apply EFAsteps_const with (s:=t)  (st:=EFAstates e) in H3; auto. apply EFAtrans_const. apply EFAempty_const.
  exists (mkNFA (NFAstates:=EFAstates e) tr Ht Hi (EFAacc_const e)). cut (forall w t, (exists s, In s (EFAinit e) /\ exists l, EFAsteps (EFAtrans e) (EFAempty e) w l /\ Head s l /\ Tail t l) <-> exists s, In s is /\ exists l, NFAsteps tr w l /\ Head s l /\ Tail t l). intros; split; intros. inversion H1. assert (exists s, In s (EFAinit e) /\ exists l, EFAsteps (EFAtrans e) (EFAempty e) w l /\ Head s l /\ Tail es l). exists is0. split; auto. exists l; auto. apply (H0 w es) in H7. destruct H7 as [s [Ha [m [Hb [Hc Hd]]]]]. apply NFAacc_intro with s es m; auto. inversion H1. assert (exists s, In s is/\ exists l, NFAsteps tr w l /\ Head s l /\Tail es l). exists is0; split; auto. exists l; auto. apply H0 in H7. destruct H7 as [s [Ha [m [Hb [Hc Hd]]]]]. apply EFAacc_intro with s es m; auto.
  intros w. apply (Fix (well_founded_ltof (list C) (length (A:=C)))) with (P:=fun w=>forall t, (exists s, In s (EFAinit e)/\(exists l, EFAsteps (EFAtrans e) (EFAempty e) w l/\Head s l/\Tail t l))<->(exists s, In s is/\exists l, NFAsteps tr w l/\Head s l/\Tail t l)). clear w. intros w IH t. destruct (tail w) as [[c [w' H1]]|H1]. subst w. split; intros. destruct H0 as [s [H1 [l [H2 [H3 H4]]]]]. apply EFAsteps_app_w_rev in H2. destruct H2 as [u [l1 [l2 [Ha [Hb [Hc Hd]]]]]]. subst l. apply EFAsteps_cons_rev in Hd. destruct Hd as [v [w [m1 [m2 [H5 [H6 [H7 [H8 H9]]]]]]]]. assert (exists s, In s (EFAinit e) /\ exists l, EFAsteps (EFAtrans e) (EFAempty e) w' l/\Head s l/\Tail v l). exists s. split; auto. destruct m1. inversion H7. inversion H5. subst n l2. exists (l1++m1); auto. split; auto. replace w' with (w'++nil). apply EFAsteps_app with u; auto. rewrite app_nil_r; auto. split. destruct l1. inversion Hc. inversion H3; simpl; auto. inversion H6. subst v m1 a. rewrite app_nil_r; auto. clear -H10. induction l1; simpl; auto. apply IH in H0. clear IH. destruct H0 as [x [Hd [l [He [Hf Hg]]]]]. exists x. split; auto. exists (l++t::nil). split. apply NFAsteps_app with v; auto. apply NFAsteps_cons; auto.
  simpl. subst tr. destruct (in_dec nat_eq_dec v (EFAstates e)). destruct (EFA_empty_states (EFAtrans e) (EFAempty e) (EFAempty_const e) (EFAtrans_const e c v i)). apply i0. exists w. split; auto. exists (w::m2). split; auto. split; auto. destruct l2. destruct m1. inversion H7. inversion H5. destruct m1; inversion H10. clear -H5 H4. assert (Tail t (n::l2)). induction l1; auto. apply IHl1. inversion H4; auto. destruct l1; inversion H2. destruct m1. inversion H5. subst u m2. auto. inversion H5. rewrite H2 in H. clear -H. induction m1; auto. apply IHm1. inversion H; auto. destruct m1; inversion H3. contradict n. apply Hi in Hd. inversion Hf. subst a l. apply NFAsteps_const with (s:=x) (st:=EFAstates e) in He; auto.  split. inversion Hf; simpl; auto. auto. unfold ltof. rewrite app_length. rewrite plus_comm; auto.
  destruct H0 as [u [H1 [l [H2 [H3 H4]]]]]. apply NFAsteps_app_w_rev in H2. destruct H2 as [v [m1 [m2 [Ha [Hb [Hc Hd]]]]]]. subst l. assert (exists s, In s is/\exists l, NFAsteps tr w' l/\Head s l/\Tail v l). exists u. split; auto. exists m1; split; auto. split; auto. destruct m1. inversion Hb. inversion H3; auto. apply IH in H0. clear IH. destruct H0 as [x [H5 [l [H6 [H7 H8]]]]]. exists x; split; auto. inversion Hc. subst c0 w s m2. clear Hc. simpl in H12. inversion H10. subst t0 l0. clear H10.  assert (s=t). clear -H4. induction m1; simpl; auto. inversion H4; auto. inversion H1. apply IHm1. inversion H4; auto. destruct m1; inversion H2. subst s. clear H4. subst tr. destruct (in_dec nat_eq_dec v (EFAstates e)). destruct (EFA_empty_states (EFAtrans e) (EFAempty e) (EFAempty_const e) (EFAtrans_const e c v i)). apply i0 in H12. destruct H12 as [s [H13 [m [H14 [H15 H16]]]]]. exists (l++m). split. apply EFAsteps_app with v; auto. inversion H15. subst a m. apply EFAsteps_cons; auto. split. inversion H7; simpl; auto. apply Tail_app; auto. inversion H12.  unfold ltof. rewrite app_length. rewrite plus_comm; auto.
  subst w. clear IH. split; intros. destruct H0 as [s [H1 [l [H2 [H3 H4]]]]]. exists t. split. apply H. exists s. split; auto. exists l; auto. exists (t::nil); auto. destruct H0 as [s [H1 [l [H2 [H3 H4]]]]]. inversion H2. subst l. inversion H3. subst a s0 l. inversion H4. subst a t. apply H in H1. destruct H1 as [t [Ha [l [Hb [Hc Hd]]]]]. exists t. split; auto. exists l; auto. inversion H6. Defined.

Definition NFA2EFA: forall n, {e|forall w, EFAacc e w <-> NFAacc n w}. intros. assert (H: forall s, In s (NFAstates n) -> incl ((fun _=>nil) s) (NFAstates n)). intros. intros x Hx; inversion Hx. exists (mkEFA (NFAtrans n) (fun _ => nil) (NFAtrans_const n) H (NFAinit_const n) (NFAacc_const n)). intros; split; intros. inversion H0. clear H0. simpl in H1. simpl in H2. apply NFAacc_intro with is es l; auto. clear -H3. simpl in H3. induction H3; auto. inversion H0. inversion H0. apply EFAacc_intro with is es l; auto. clear -H3. simpl. induction H3; auto. Defined.
Definition DFA2NFA: forall d, {n|forall w, DFAacc d w <-> NFAacc n w}. intros. assert (Ht: forall c s, In s (DFAstates d)->incl (DFAtrans d s c::nil) (DFAstates d)). intros. intros x Hx. destruct Hx. subst x. apply DFAtrans_const; auto. destruct H0. assert (Hi: incl (DFAinit d::nil) (DFAstates d)). intros x Hx. destruct Hx. subst x. apply DFAinit_const; auto. destruct H. exists (mkNFA (fun s c=>DFAtrans d s c::nil) Ht Hi (DFAacc_const d)). unfold DFAacc. cut (forall w s t, t=fold_left (DFAtrans d) w s <-> exists l, NFAsteps (fun s c =>DFAtrans d s c::nil) w l /\ Head s l /\Tail t l). intros. split; intros. destruct (H w (DFAinit d) (fold_left (DFAtrans d) w (DFAinit d))). destruct H1 as [l [H3 [H4 H5]]]; auto. apply NFAacc_intro with (DFAinit d) (fold_left (DFAtrans d) w (DFAinit d)) l; auto. simpl. auto. inversion H0. clear H0. simpl in H1. simpl in H2. destruct H2; [|destruct H0]. subst is. assert (es=fold_left (DFAtrans d) w (DFAinit d)). apply H. exists l; auto. rewrite <- H0; auto.
  induction w; intros; split; intros. simpl in H. subst t. exists (s::nil); auto. destruct H as [l [H1 [H2 H3]]]. inversion H1. subst l. inversion H2. subst a s0 l. inversion H3. subst t; auto. inversion H4. simpl in H. subst t. destruct (IHw (DFAtrans d s a) (fold_left (DFAtrans d) w (DFAtrans d s a))). clear IHw H0. destruct H as [l [H1 [H2 H3]]]; auto. exists (s::l). split; auto. inversion H2. subst a0 l. apply NFAsteps_cons; auto. simpl. destruct H as [l [H1 [H2 H3]]]. inversion H1. clear H1. simpl in H6. destruct H6; [|destruct H1]. subst a w0 l t0. simpl. apply IHw. clear IHw. inversion H2. subst s0 a l. exists (DFAtrans d s c::l0); auto. split; auto. split; auto. inversion H3; auto. Defined.
Definition DFA2EFA: forall d, {e|forall w, DFAacc d w <-> EFAacc e w}. intros. destruct (DFA2NFA d) as [n H]. destruct (NFA2EFA n) as [e H0]. exists e. intros; split; intros. apply H0. apply H; auto. apply H; apply H0; auto. Defined.

Definition NFA2DFA: forall n, {d|forall w, NFAacc n w <-> DFAacc d w}. intros. remember (fun s c=>ps2i nat_eq_dec (NFAstates n) (flat_map (fun s=>NFAtrans n s c) (i2ps nat_eq_dec (NFAstates n) s))) as t. assert (Hu: forall c s, In s (seq 0 (psSize nat_eq_dec (NFAstates n))) -> In (t s c) (seq 0 (psSize nat_eq_dec (NFAstates n)))). intros. subst t. apply in_seq. split. apply le_O_n. apply ps2i_spec1. intros x Hx. apply in_flat_map in Hx. destruct Hx as [y [H4 H5]]. apply NFAtrans_const in H5; auto. apply i2ps_spec1 in H4; auto. apply in_seq in H. destruct H; auto. assert (Hj: In (ps2i nat_eq_dec (NFAstates n) (NFAinit n)) (seq 0 (psSize nat_eq_dec (NFAstates n)))). apply in_seq. split. apply le_O_n. apply ps2i_spec1. intros x Hx. apply NFAinit_const; auto. destruct (contain_powerSet nat_eq_dec (NFAstates n) (NFAaccept n)) as [al H4]. assert (Hac: incl (map (ps2i nat_eq_dec (NFAstates n)) al) (seq 0 (psSize nat_eq_dec (NFAstates n)))). intros x Hx. apply in_seq. split. apply le_O_n. apply in_map_iff in Hx. destruct Hx as [y [H1 H2]]. subst x. apply ps2i_spec1; auto. assert (Exists (equiv y) al). apply Exists_exists. exists y; split; auto. apply equiv_refl. apply H4 in H. destruct H; auto. exists (mkDFA t (ps2i nat_eq_dec (NFAstates n)  (NFAinit n)) Hu Hj Hac).
  assert (H5: forall w, fold_left t w (ps2i nat_eq_dec (NFAstates n) (NFAinit n)) = let (tl,_) := NFAsteps_states (NFAtrans n) w (NFAinit n) in ps2i nat_eq_dec (NFAstates n) tl). apply (Fix (well_founded_ltof (list C) (length (A:=C)))). intros w IH. destruct (tail w) as [[c [w' H1]]|H1]. subst w. destruct (NFAsteps_states (NFAtrans n) (w'++c::nil) (NFAinit n)) as [tl H1]. rewrite fold_left_app. rewrite IH. clear IH. destruct (NFAsteps_states (NFAtrans n) w' (NFAinit n)) as [ul H0]. assert (Hv:incl ul (NFAstates n)).  intros z Hz. apply H0 in Hz. destruct Hz as [s [l [Hs [Ht [Hw Hv]]]]]. apply NFAsteps_const with (s:=s) (st:=NFAstates n) in Ht; auto. apply NFAtrans_const. apply NFAinit_const in Hs; auto. simpl. subst t. apply ps2i_spec3. intros x; split; intros. apply in_flat_map in H. destruct H as [y [H5 H6]]. apply i2ps_spec3 in H5. apply H1. apply H0 in H5. destruct H5 as [s [l [Ha [Hb [Hc Hd]]]]]. exists s. exists (l++x::nil); split; auto. split. apply NFAsteps_app with y; auto. split. inversion Hc; simpl; auto. auto. auto. apply H1 in H. destruct H as [s [l [H5 [H6 [H7 H8]]]]]. apply in_flat_map. apply NFAsteps_app_w_rev in H6. destruct H6 as [t [m1 [m2 [Ha [Hb [Hc Hd]]]]]]. subst l. inversion Hc. subst c0 w s0 m2. inversion H6. subst t0 l. apply Tail_app_rev in H8; auto. inversion H8. subst s0. exists t. split; auto. apply i2ps_spec3. apply Hv. subst a. apply H0. exists s. exists m1; split; auto. split; auto. split; auto.  destruct m1. inversion Hb.  inversion H7; auto. inversion H3. discriminate.
  unfold ltof. rewrite app_length. simpl. rewrite <- plus_n_Sm. rewrite <- plus_n_O; auto. subst w. simpl. f_equal. generalize (NFAinit n). induction l; simpl; auto. f_equal; auto.
  intros; split; intros. inversion H. unfold DFAacc; simpl. rewrite H5. destruct (NFAsteps_states (NFAtrans n) w (NFAinit n)) as[tl H7]. assert (H8:incl tl (NFAstates n)). intros x Hx. apply H7 in Hx. destruct Hx as [s [m [Ha [Hb [Hc Hd]]]]]. apply NFAsteps_const with (s:=s) (st:=NFAstates n) in Hb; auto. apply NFAtrans_const. apply NFAinit_const in Ha; auto. assert (Exists (equiv tl) al). apply H4. split; auto. exists  es; split; auto. apply H7. exists is. exists l; split; auto. apply Exists_exists in H9. destruct H9 as [x [Ha Hb]]. apply in_map_iff. exists x; split; auto. apply ps2i_spec3. apply equiv_sym; auto. unfold DFAacc in H. simpl in H. apply in_map_iff in H. destruct H as [x [H1 H2]]. rewrite H5 in H1. destruct (NFAsteps_states (NFAtrans n) w (NFAinit n)) as [ul H6]. assert (H7:incl ul (NFAstates n)). intros y Hy. apply H6 in Hy. destruct Hy as [s [m [Ha [Hb [Hc Hd]]]]]. apply NFAsteps_const with (s:=s) (st:=NFAstates n) in Hb; auto. apply NFAtrans_const. apply NFAinit_const in Ha; auto. apply ps2i_spec2 in H1; auto. assert (Exists (equiv ul) al). apply Exists_exists. exists x. split; auto. apply equiv_sym; auto. apply H4 in H. destruct H. destruct H0 as [y [H8 H9]]. apply H6 in H8. destruct H8 as [s [l [Ha [Hb [Hc Hd]]]]]. apply NFAacc_intro with s y l; auto. assert (Exists (equiv x) al). apply Exists_exists. exists x; split; auto. apply equiv_refl. apply H4 in H. destruct H; auto. Defined.
Definition EFA2DFA: forall e, {d|forall w, EFAacc e w <-> DFAacc d w}. intros. destruct (EFA2NFA e) as [n H]. destruct (NFA2DFA n) as [d H0]. exists d; intros; split; intros. apply H0. apply H; auto. apply H; apply H0; auto. Defined.

Definition EFA_map: forall e (f:nat->nat), (forall x y, In x (EFAstates e) -> In y (EFAstates e) -> f x=f y -> x=y) -> {e'|EFAstates e'=map f (EFAstates e) & forall w, EFAacc e w <-> EFAacc e' w}. intros e. destruct e as [st tr emp ini acc Htr Hemp Hini Hacc]. simpl. intros. destruct (inv_func nat_eq_dec f st 0 H) as [g Hg1 _]. remember (fun s c=>map f (tr (g s) c)) as tr'. assert (Htr': forall c s, In s (map f st) -> incl (tr' s c) (map f st)). intros. apply in_map_iff in H0. destruct H0 as [x [H1 H2]]. subst s. subst tr'. rewrite Hg1; auto. intros y Hy. apply in_map_iff in Hy. destruct Hy as [z [H3 H4]]. subst y. apply in_map_iff. exists z; split; auto. apply Htr in H4; auto. remember (fun s=>map f (emp (g s))) as emp'. assert (Hemp': forall s, In s (map f st)->incl (emp' s) (map f st)). intros. apply in_map_iff in H0. destruct H0 as [x [H1 H2]]. subst s. subst emp'. rewrite Hg1; auto. intros y Hy. apply in_map_iff in Hy. destruct Hy as [z [H3 H4]]. subst y. apply in_map_iff. exists z; split; auto. apply Hemp in H4; auto. assert (Hini': forall s, In s (map f ini)->In s (map f st)). intros. apply in_map_iff in H0. destruct H0 as [x [H1 H2]]. subst s. apply in_map_iff. exists x; split; auto. assert (Hacc': incl (map f acc) (map f st)). intros x Hx. apply in_map_iff in Hx. destruct Hx as [y [H1 H2]]. subst x. apply in_map_iff. exists y; split; auto.
  exists (mkEFA tr' emp' Htr' Hemp' Hini' Hacc'); auto. intros; split; intros; inversion H0. simpl in H1. simpl in H2. clear H0. apply EFAacc_intro with (f is) (f es) (map f l); simpl; auto. simpl in H3. apply in_map_iff. exists es; split; auto. simpl in H3. apply in_map_iff. exists is; auto. simpl in H3. assert (H6:incl l st). apply EFAsteps_const with (s:=is) (st:=st) in H3; auto. subst emp' tr'. clear -H3 H6 Hg1. revert H3. revert H6. revert w. induction l; intros. inversion H3. inversion H3; simpl; auto. subst a w0 l. apply EFAsteps_empty; auto. apply IHl; auto. intros x Hx. apply H6. right; auto. simpl. simpl in H4. apply in_map_iff. exists t. split; auto. rewrite Hg1; auto. subst a w l. apply EFAsteps_cons; auto. apply IHl; auto. intros x Hx. apply H6. right; auto. simpl. rewrite Hg1; auto. apply in_map_iff. exists t; split; auto. inversion H4; simpl; auto. clear -H5. induction H5; simpl; auto.
  simpl in H1. simpl in H2. clear H0. apply in_map_iff in H1. destruct H1 as [es' [H6 H1]]. subst es. apply in_map_iff in H2. destruct H2 as [is' [H6 H2]]. subst is. apply EFAacc_intro with is' es' (map g l); simpl; auto. assert (H6:incl l (map f st)). apply EFAsteps_const with (s:=f is') (st:=map f st) in H3; auto. apply in_map_iff. exists is'; split; auto. simpl in H3.  revert H3. revert H6. revert w. subst emp' tr'. clear -Hemp Htr Hg1. induction l; intros. inversion H3. inversion H3; simpl; auto. apply EFAsteps_empty; auto. subst w0 a l. apply IHl; auto. intros x Hx; auto. simpl. simpl in H4. subst a w0 l. apply in_map_iff in H4. destruct H4 as [u [H4 H5]]. subst t. rewrite Hg1; auto. apply Hemp in H5; auto. cut (In s (map f st)); intros. apply in_map_iff in H. destruct H as [x [H7 H8]]. subst s. rewrite Hg1; auto. apply H6; auto. apply EFAsteps_cons; auto. subst w a l. apply IHl; auto. intros x Hx; auto. simpl. subst w a l. simpl in H4. apply in_map_iff in H4. destruct H4 as [u [H4 H5]]. subst t. rewrite Hg1; auto. apply Htr in H5; auto. cut (In s (map f st)); intros; auto. apply in_map_iff in H. destruct H as [x [H8 H7]]. subst s. rewrite Hg1; auto. inversion H4; simpl. rewrite Hg1; auto. apply Hacc in H1. clear -H1 H5 Hg1. induction l. inversion H5. simpl. inversion H5; auto. simpl. rewrite Hg1; auto. Defined.

End CharType.
Hint Constructors NFAsteps NFAacc EFAsteps EFAacc.


(** Basic lemmas about [Z.div] for bootstrapping various tactics *)
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Hints.Core.
Local Open Scope Z_scope.

Module Z.
  Lemma div_0_r_eq a b : b = 0 -> a / b = 0.
  Proof. intro; subst; auto with zarith. Qed.
  Hint Resolve div_0_r_eq : zarith.
  Hint Rewrite div_0_r_eq using assumption : zsimplify.
End Z.


Require Import GeoCoq.Tarski_dev.Ch09_plane.
Require Import GeoCoq.Tactics.Coinc.tactics_axioms.

(* In this file we prove that Cop in Tarski neutral dimensionless is a Coinc_theory *)

Section Tarski_is_a_Coinc_theory_for_cop.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Definition not_col : arity Tpoint 3 := fun A B C : Tpoint => ~ Col A B C.

Lemma not_col_perm_1 : forall A X, app_1_n not_col A X -> app_n_1 not_col X A.
Proof.
unfold not_col.
simpl.
Col.
Qed.

Lemma not_col_perm_2 : forall A B (X : cartesianPower Tpoint 1),
  app_2_n not_col A B X -> app_2_n not_col B A X.
Proof.
unfold not_col.
unfold app_2_n.
simpl.
Col.
Qed.

Definition cop : arity Tpoint 4 := Coplanar.

Lemma cop_perm_1 : forall A (X : cartesianPower Tpoint 3), app_1_n cop A X -> app_n_1 cop X A.
Proof.
unfold cop.
simpl.
Cop.
Qed.

Lemma cop_perm_2 : forall A B (X : cartesianPower Tpoint 2), app_2_n cop A B X -> app_2_n cop B A X.
Proof.
unfold cop.
unfold app_2_n.
simpl.
Cop.
Qed.

Lemma cop_bd : forall A (X : cartesianPower Tpoint 2), app_2_n cop A A X.
Proof.
unfold cop.
unfold app_2_n.
simpl.
Cop.
Qed.

Lemma cop_3 : forall (COP : cartesianPower Tpoint 4) (NOT_COL : cartesianPower Tpoint 3),
  pred_conj cop COP NOT_COL -> app not_col NOT_COL -> app cop COP.
Proof.
unfold pred_conj.
unfold cop.
unfold not_col.
simpl in *.
intros COP NOT_COL HCop HNot_Col.
destruct HCop as [HCop1 [HCop2 [HCop3 HCop4]]].
apply coplanar_pseudo_trans with (fst NOT_COL) (fst (snd NOT_COL)) (snd (snd NOT_COL)); Cop.
Qed.

Global Instance Tarski_is_a_Arity_for_cop : Arity.
Proof. exact (Build_Arity Tpoint 1). Defined.

Global Instance Tarski_is_a_Coinc_predicates_for_cop :
  (Coinc_predicates Tarski_is_a_Arity_for_cop).
Proof.
exact (Build_Coinc_predicates Tarski_is_a_Arity_for_cop not_col cop).
Defined.

Global Instance Tarski_is_a_Coinc_theory_for_cop :   (Coinc_theory Tarski_is_a_Arity_for_cop Tarski_is_a_Coinc_predicates_for_cop).
Proof.
exact (Build_Coinc_theory Tarski_is_a_Arity_for_cop
                          Tarski_is_a_Coinc_predicates_for_cop
                          not_col_perm_1 not_col_perm_2 cop_perm_1 cop_perm_2
                          cop_bd cop_3).
Defined.

End Tarski_is_a_Coinc_theory_for_cop.


(*
 Copyright 2022 ZhengPu Shi
  This file is part of coq-matrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Homomorphism Theory.
  author    : ZhengPu Shi
  date      : 2021.12

  remark    :
  1. it is implemented with equivalence equality, not Leibniz equality.

  History   :
    2022.07.12  by Zhengpu SHI, remove equivalence relation, only use eq
*)

Require Export BasicConfig.

Section Homo.
  Variable A B : Type.
  Variable fa ga : A -> A -> A.
  Variable fb gb : B -> B -> B.
  Infix "+" := fa.
  Infix "*" := ga.
  Infix "⊕" := fb (at level 50).
  Infix "⊗" := gb (at level 40).

  (** If <A,+> and <B,⊕> is homomorphism, and + is commutative,
    then ⊕ is commutative too. *)
  Lemma homo_keep_comm : homomorphism fa fb ->
    commutative fa -> commutative fb.
  Proof.
    intros [phi [Hhomo Hsurj]] H. intros a b.
    destruct (Hsurj a) as [a' Ha'].
    destruct (Hsurj b) as [b' Hb'].
    rewrite <- Ha', <- Hb'.
    repeat rewrite <- Hhomo. f_equal; auto.
  Qed.

  (** If <A,+> and <B,⊕> is homomorphism, and + is associative,
    then ⊕ is associative too. *)
  Lemma homo_keep_assoc : homomorphism fa fb ->
    associative fa -> associative fb.
  Proof.
    intros [phi [Hhomo Hsurj]] H. intros a b c.
    destruct (Hsurj a) as [a' Ha'].
    destruct (Hsurj b) as [b' Hb'].
    destruct (Hsurj c) as [c' Hc'].
    rewrite <- Ha', <- Hb', <- Hc'.
    repeat rewrite <- Hhomo.
    rewrite H. auto.
  Qed.

  (** If <A,+,*>,<B,⊕,⊗> is homomorphism,
    and * is left distributive about + over A,
    then ⊗ is left distributive about ⊕ over B. *)
  Lemma homo_keep_distr_l : homomorphism2 fa ga fb gb ->
    distributive_left fa ga -> distributive_left fb gb.
  Proof.
    intros [phi [[Hhomo Hsurj] [Hhomo' Hsurj']]] H. intros a b c.
    destruct (Hsurj a) as [a' Ha'].
    destruct (Hsurj b) as [b' Hb'].
    destruct (Hsurj c) as [c' Hc'].
    rewrite <- Ha', <- Hb', <- Hc'.
    rewrite <- ?Hhomo', <- ?Hhomo, <- ?Hhomo'.
    f_equal; auto.
  Qed.

  (** If <A,+,*>,<B,⊕,⊗> is homomorphism,
    and * is right distributive about + over A,
    then ⊗ is right distributive about ⊕ over B. *)
  Lemma homo_keep_distr_r : homomorphism2 fa ga fb gb ->
    distributive_right fa ga -> distributive_right fb gb.
  Proof.
    intros [phi [[Hhomo Hsurj] [Hhomo' Hsurj']]] H. intros a b c.
    destruct (Hsurj a) as [a' Ha'].
    destruct (Hsurj b) as [b' Hb'].
    destruct (Hsurj c) as [c' Hc'].
    rewrite <- Ha', <- Hb', <- Hc'.
    rewrite <- ?Hhomo', <- ?Hhomo, <- ?Hhomo'.
    f_equal; auto.
  Qed.

End Homo.

Section Compose.

  (** Composition of homomorphism mapping is also homomorphism mapping *)
  Lemma homom_comp_imply_homo : forall A B C (fa : A -> A -> A)
    (fb : B -> B -> B) (fc : C -> C -> C),
    homomorphism fa fb -> homomorphism fb fc ->
    homomorphism fa fc.
  Proof.
    intros.
    destruct H as [phi [Hhomo Hsurj]], H0 as [psi [Hhomo' Hsurj']].
    exists (fun a => psi (phi a)). split.
    - intros a b. rewrite <- Hhomo'. f_equal. rewrite <- Hhomo. auto.
    - intros c.
      destruct (Hsurj' c) as [b Hb].
      destruct (Hsurj b) as [a Ha].
      exists a. subst. auto.
  Qed.

End Compose.