(**
A Constructive Theory of Regular Languages in Coq (pdf)

において

Theorem 4.2 For every NFA (DFA) we can construct a DFA (NFA) accepting the same language.

を証明する箇所を抜粋する。
*)

(** Authors: Christian Doczkal and Jan-Oliver Kaiser *)
(** より抜粋 *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype
ssrnat seq choice fintype path fingraph  finfun  finset.

Set Implicit Arguments.

Section FA.
Variable char : finType.
Definition word := seq char.                (* reqexp.word *)

(** * Finite Automata *)

(** ** Deterministic Finite Automata *)

Record dfa : Type :=
  {
    dfa_state :> finType;
    dfa_s : dfa_state;
    dfa_fin : pred dfa_state;
    (* dfa_trans : dfa_state -> char -> dfa_state *)
    dfa_trans (x : dfa_state) (a : char) : dfa_state
    (* dfa_trans : {ffun dfa_state -> char -> dfa_state} *)
  }.

(** For DFAs, we use the direct recursive defintion of acceptance
    as well as a definition in terms of runs. The latter is used
    in the translation of DFAs to regular expressions. *)

Fixpoint dfa_accept {A : dfa} (x : A) w :=
  if w is a :: w' then dfa_accept (dfa_trans A x a) w' else x \in dfa_fin A.

Arguments dfa_trans [d] x a.
Arguments dfa_accept [A] x w.

Section DFA_Acceptance.
Variable A : dfa.

Lemma dfa_accept_cons (x : A) a w :
  a :: w \in dfa_accept x = (w \in dfa_accept (dfa_trans x a)).
Proof.
    by rewrite -simpl_predE /=.
Qed.
(* 必要なものだけ抜粋した。 *)
End DFA_Acceptance.

Definition dfa_lang A := [pred w | dfa_accept (dfa_s A) w].

(** ** Nondeterministic Finite Automata. *)
Record nfa : Type :=
  {
    nfa_state :> finType;
    nfa_s : nfa_state;
    nfa_fin : pred nfa_state;
    (* nfa_trans : nfa_state -> char -> nfa_state -> bool *)
    nfa_trans (x : nfa_state) (a : char) (y : nfa_state) : bool
  }.

(** Non-deterministic acceptance. **)
Fixpoint nfa_accept (A : nfa) (x : A) w :=
  if w is a :: w' then [exists y, nfa_trans A x a y && nfa_accept A y w']
                  else x \in nfa_fin A.

Definition nfa_lang (A : nfa) := [pred w | nfa_accept A (nfa_s A) w].

(** ** Equivalence of DFAs and NFAs *)
(** We use the powerset construction to obtain
   a deterministic automaton from a non-deterministic one. **)
Section PowersetConstruction.

Variable A : nfa.

Definition nfa_to_dfa : dfa :=
  {|
    dfa_s := [set nfa_s A];
    dfa_fin X := [exists x: A, (x \in X) && nfa_fin A x];
    dfa_trans X a := \bigcup_(x | x \in X) [set y | nfa_trans A x a y]
  |}.
Section TEST.
  (**
X : dfa ではなく、 A : nfa, X : {set A}、すなわち dfa≡{set A} とみなす。
これが、パワーセット・コンストラクションということなのだろう。
ここで、finSet が出てくるのがポイントである。
   *)
  Variable X : {set A}.
  Variable a : char.

  Check [set nfa_s A] : {set A}.
  Check [exists x: A, (x \in X) && nfa_fin A x] : bool.
  Check \bigcup_(x | x \in X) [set y | nfa_trans A x a y] : {set A}.
End TEST.

Lemma nfa_to_dfa_aux2 (x : A) w (X : nfa_to_dfa) :
  x \in X -> nfa_accept A x w -> dfa_accept X w.
Proof.
  move => H0.
  elim: w X x H0 => [|a w IHw] X x H0 /=.
  - move => H1.
    apply/existsP.
    exists x.
      by rewrite H0.
  - move => /= /existsP [] y /andP [] H1 H2.
    apply: (IHw _ y) => //.
    apply/bigcupP.
    exists x => //=.
      by rewrite in_set.
Qed.

Check @bigcupP : forall (T I : finType) (x : T) (P : pred I) (F : I -> {set T}),
    reflect (exists2 i : I, P i & x \in F i) (x \in \bigcup_(i | P i) F i).

Lemma nfa_to_dfa_aux1 (X : nfa_to_dfa) w :
  dfa_accept X w -> exists2 x, (x \in X) & nfa_accept A x w.
Proof.
  elim: w X => [|a w IHw] X => //=.
  - move/existsP => [x] /andP [] H0 H1.
    exists x; assumption.
  - move/IHw => [] y /bigcupP [x] H0.
    rewrite inE => H1 H2.
    exists x.
    + assumption.
    + apply/existsP.
      exists y.
        by apply/andP.
Qed.

Lemma nfa_to_dfa_correct : nfa_lang A =i dfa_lang nfa_to_dfa.
Proof.
  move => w.
  apply/idP/idP => /=.
  (* w \in nfa_lang A -> w \in dfa_lang nfa_to_dfa *)
  - apply: nfa_to_dfa_aux2.
      by apply/set1P.
  (* w \in dfa_lang nfa_to_dfa -> w \in nfa_lang A *)
  - by move/nfa_to_dfa_aux1 => [x] /set1P ->.
Qed.

End PowersetConstruction.

(** Embedding deterministic automata in non-deterministic automata. **)
Section Embed.

Variable A : dfa.

Definition dfa_to_nfa : nfa :=
  {|
  nfa_s := dfa_s A;
  nfa_fin := dfa_fin A;
  nfa_trans x b y := y == dfa_trans x b
  |}.

Lemma dfa_to_nfa_correct : dfa_lang A =i nfa_lang dfa_to_nfa.
Proof.
  move => w. rewrite /dfa_lang /nfa_lang /=. move: (dfa_s A) => x.
  elim: w x => [|b w IHw] x //=.
  rewrite dfa_accept_cons IHw !inE /=. apply/idP/existsP.
    move => H0. exists (dfa_trans x b). by rewrite eq_refl.
  by move => [] y /andP [] /eqP ->.
Qed.

End Embed.

(** sample NFA *)

Definition nfa_char (a : char) : nfa :=
  {|
    nfa_state := bool_finType;
    nfa_s := false;
    nfa_fin := id;
    nfa_trans x b y := [&& (b == a),  ~~ x & y]
  |}.
Print nfa_char.

Lemma nfa_char_correct (a : char) : nfa_lang (nfa_char a) =1 pred1 [:: a].
Proof.
 move => [|b w] => //.
 apply/existsP/eqP => [[x] /andP [/and3P [/eqP -> _ Hx]] |[-> ->]].
 - case: w => //= c w /existsP [y] /=. by rewrite Hx andbF.
 - exists true. by rewrite /= eqxx.
Qed.

(** sample NFA を DFA に変換する。 *)

Definition dfa_char' (a : char) : dfa := nfa_to_dfa (nfa_char a).

(** 変換した DFA と等価なDFAと、その証明。 *)

Definition dfa_char (a : char) : dfa :=
  {|
    dfa_state := set_of_finType bool_finType; (* 省いてもよい。 *)
    dfa_s := [set false];
    dfa_fin X := [exists x, (x \in X) && x];
    dfa_trans X b :=
      \bigcup_(x | x \in X) [set y | nfa_trans (nfa_char a) x b y]
  |}.

Goal dfa_char' =1 dfa_char.
Proof.
  move=> a.
  rewrite /dfa_char' /nfa_to_dfa /dfa_char.
    by f_equal.
Qed.

(**
NOTE:
set_of_finType bool_finType とはなにか？

復習：
(1) bool_finType は finType のカノニカルなサブタイプである。
 *)
Check bool_finType : finType.

(**
(2) コアーション [Finite.sort] : Finite.type >-> Sortclass
によって、bool_finType は bool 型に埋め込むことができる。
 *)
(* Set Printing Coercions. *)
Check true : bool_finType.
Check true : Finite.sort bool_finType.

(**
同様に、
(1) set_of_finType bool_finType は finType のカノニカルなサブタイプである。
 *)
Check set_of_finType bool_finType : finType.
(**
(2) コアーションによって {set bool_finType} に埋め込むことができる。
 *)
Check [set true] : set_of_finType bool_finType. (* set_of_finType の定義から *)
Check [set true] : Finite.Pack (Finite.class (set_finType bool_finType)) {set bool_finType}.
Check [set true] : set_finType bool_finType.
Check [set true] : {set Finite.sort bool_finType}.
Check [set true] : {set bool_finType}.

Print Graph.
Set Printing Coercions.

(* 型引数は、finType型 *)
Check [set true] : set_of_eqType bool_finType.
Check [set true] : set_of_choiceType bool_finType.
Check [set true] : set_of_countType bool_finType.
Check [set true] : set_of_finType bool_finType.

(* 型引数に制限がある。 *)
Check [set true] : {set Equality.sort bool_eqType}.
Check [set true] : {set Equality.sort bool_choiceType}.
Check [set true] : {set Equality.sort bool_countType}.
Check [set true] : {set Equality.sort bool_finType}.
Check [set true] : {set bool_eqType}.

Fail Check [set true] : {set Choice.sort bool_eqType}.
Check [set true] : {set Choice.sort bool_choiceType}.
Check [set true] : {set Choice.sort bool_countType}.
Check [set true] : {set Choice.sort bool_finType}.
Check [set true] : {set bool_choiceType}.

Fail Check [set true] : {set Countable.sort bool_eqType}.
Fail Check [set true] : {set Countable.sort bool_choiceType}.
Fail Check [set true] : {set Countable.sort bool_countype}.
Check [set true] : {set Countable.sort bool_finType}.
Check [set true] : {set bool_countType}.

Fail Check [set true] : {set Finite.sort bool_eqType}.
Fail Check [set true] : {set Finite.sort bool_choiceType}.
Fail Check [set true] : {set Finite.sort bool_countType}.
Check [set true] : {set Finite.sort bool_finType}.
Check [set true] : {set bool_finType}.

(* END *)


Require Import POrder POrderSet TerminalDogma.premises
                                TerminalDogma.Extensionality.
Require Import Relations.
Require Import SetFacility.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** Canonical structure *)

(** Enter the 'context' by introducing the canonical structures. *)
Import SubsetOrder.CanonicalStruct.

(** The single item [𝒫(nat)] has coercions to many notions related. *)
Check 𝒫(nat).
Check 𝒫(nat) : poset.
Check 𝒫(nat) : clattice.
Check 𝒫(nat) : cpo.

Axiom A : chain (𝒫(nat)).
Check (⊔ᶜᵖᵒ A).

(** the type of monotonic functions between [𝒫(nat)] and [𝒫(nat)] *)
Check [ 𝒫(nat) ↦ᵐ 𝒫(nat) ].

(** The system 'knows' that if we apply monotonic functions to a chain, we get
    a chain. *)
Axiom (f : 𝒫(nat) -> 𝒫(nat)) (monof : [ 𝒫(nat) ↦ᵐ 𝒫(nat) ]).

Check f [<] A : 𝒫( _ ).
Fail Check f [<] A : chain _.

Check monof [<] A : 𝒫( _ ).
Check monof [<] A : chain _.

(** nonempty set *)
Check 𝒫(nat)₊.
Check union : 𝒫(nat) ->  𝒫(nat)-> 𝒫(nat).
(** Because of canonical structure, [union] 'remembers' its property about
    nonempty sets. *)
Check union : 𝒫(nat)₊ -> 𝒫(nat) -> 𝒫(nat)₊.

(** Function lifting *)
Section FunctionLifting.

Variable (T V W: Type) (f : T -> V) (g : T -> V -> W).

(** function lifting of single-variable functions *)
Check f : T -> V.
Check f[<] : 𝒫(T) -> 𝒫(V).

(** function lifting of multi-variable functions *)
Check g                             : T -> V -> W.
Check g[<]                          : 𝒫(T) -> 𝒫(V -> W).
Check (fun a => g[<]a[>])           : 𝒫(T) -> V -> 𝒫(W).
Check (fun a => g[<]a[>][<])        : 𝒫(T) -> 𝒫(V) -> 𝒫(𝒫(W)).
Check (fun a b => ⋃(g[<]a[>][<]b))  : 𝒫(T) -> 𝒫(V) -> 𝒫(W).

Definition g_lifted := (fun a b => ⋃(g[<]a[>][<]b)).

Lemma continuity_f_lifted A : f[<](⋃ A) = ⋃ (f[<][<]A).
Proof.
    equal_f_comp A.
    rewrite mapR_bigU_swapF. by [].

    Restart.
    seteq_killer.
Qed.

Lemma continuity_g_lifted A B : g_lifted (⋃ A) (⋃ B) = ⋃ (g_lifted [<] A [><] B).
Proof.
    rewrite /g_lifted.

    Restart.
    seteq_killer.
Qed.

End FunctionLifting.

(** seteq_killer demo *)

Lemma Example1 {X Y: Type} (f : X -> 𝒫(𝒫(Y))):

    ⋃ ◦ (⋃ ◦ f)[<] = ⋃ ◦ ⋃ ◦ f[<].

Proof.
    apply functional_extensionality => A.
    seteq_killer.

    Undo.
    apply seteqP => x; split.
    set_simpl.
    set_move_up.
    set_move_down.
    set_simpl.
    set_move_up.
    set_move_down.
Qed.

Lemma Example2 {X : Type} (A B: 𝒫(𝒫(X))) :

        ⋃ (A ∪ B) = (⋃ A) ∪ (⋃ B).

Proof.
    seteq_killer.
Qed.

(** WARNING: this is not correct. *)
Lemma Example3 {X : Type} (A B: 𝒫(𝒫(X))) :

        ⋂ (A ∩ B) = (⋂ A) ∩ (⋂ B).

Proof.
    seteq_killer.
Abort.

Lemma Example4 {X Y: Type} (F : 𝒫(X -> Y)) (A : 𝒫(𝒫(X))) :

    ⋃(F [>][<] (⋃ A)) = ⋃ (⋃ (F[>][<][<] A)).

Proof.
    seteq_killer.
Qed.

(** 2023/2/6
    git commit: 48aac14771ce40140937bc45fc2f1aeb8123284e *)


Require Import Arith Omega.

Section bounded_forall.

  Implicit Type (P : nat -> Prop).

  Fixpoint bounded_forall P n :=
    match n with
      | 0 => True
      | S n => P 0 /\ bounded_forall (fun i => P (S i)) n
    end.

  Fact bounded_forall_spec P n : bounded_forall P n -> forall i, i < n -> P i.
  Proof.
    revert P.
    induction n as [ | n IHn ]; simpl; intros P Hn i Hi; try omega.
    destruct i as [ | i ]; try tauto.
    apply IHn with (P := fun i => P (S i)); try tauto.
    omega.
  Qed.

End bounded_forall.

Lemma can_be_brute_forced : forall (n : nat), n < 10 -> n mod 10 = (n ^ 5) mod 10.
Proof.
  now apply bounded_forall_spec.
Qed.


Require Export TopologicalSpaces.
Require Import ClassicalChoice.
Require Import EnsemblesSpec.

Section OpenBasis.

Variable X : TopologicalSpace.
Variable B : Family (point_set X).

Record open_basis : Prop :=
  { open_basis_elements :
     forall V:Ensemble (point_set X), In B V -> open V;
    open_basis_cover :
     forall (x:point_set X) (U:Ensemble (point_set X)),
        open U -> In U x -> exists V:Ensemble (point_set X),
        In B V /\ Included V U /\ In V x
  }.

Hypothesis Hbasis: open_basis.

Lemma coverable_by_open_basis_impl_open:
  forall U:Ensemble (point_set X),
    (forall x:point_set X, In U x -> exists V:Ensemble (point_set X),
     In B V /\ Included V U /\ In V x) -> open U.
Proof.
intros.
assert (U = FamilyUnion [ V:Ensemble (point_set X) |
                          In B V /\ Included V U ]).
apply Extensionality_Ensembles; split; red; intros.
destruct (H x H0) as [V].
destruct H1 as [? [? ?]].
exists V; auto.
constructor; auto.
destruct H0.
destruct H0.
destruct H0.
auto with sets.

rewrite H0.
apply open_family_union.
intros.
destruct H1.
destruct H1.
apply open_basis_elements; trivial.
Qed.

End OpenBasis.

Implicit Arguments open_basis [[X]].
Implicit Arguments coverable_by_open_basis_impl_open [[X]].
Implicit Arguments open_basis_elements [[X]].
Implicit Arguments open_basis_cover [[X]].

Section BuildFromOpenBasis.

Variable X : Type.
Variable B : Family X.

Definition open_basis_cond :=
  forall U V:Ensemble X, In B U -> In B V ->
    forall x:X, In (Intersection U V) x ->
      exists W:Ensemble X, In B W /\ In W x /\
                           Included W (Intersection U V).
Definition open_basis_cover_cond :=
  forall x:X, exists U:Ensemble X, In B U /\ In U x.

Hypothesis Hbasis : open_basis_cond.
Hypothesis Hbasis_cover: open_basis_cover_cond.

Inductive B_open : Ensemble X -> Prop :=
  | B_open_intro: forall F:Family X, Included F B ->
    B_open (FamilyUnion F).

Definition Build_TopologicalSpace_from_open_basis : TopologicalSpace.
refine (Build_TopologicalSpace X B_open _ _ _).
intros.
pose proof (choice (fun (x:{S:Ensemble X | In F S}) (F:Family X) =>
  Included F B /\ proj1_sig x = FamilyUnion F)).
refine (let H:=(H0 _) in _).
intros.
destruct x.
pose proof (H x i).
destruct H1.
exists F0.
split; simpl; trivial.
clear H0.
destruct H1.
assert (FamilyUnion F = FamilyUnion (IndexedUnion x)).
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
pose proof (H0 (exist _ _ H1)).
destruct H3.
simpl in H4.
rewrite H4 in H2.
destruct H2.
constructor 1 with S0.
exists (exist _ _ H1).
assumption.
assumption.

destruct H1.
destruct H1.
pose proof (H0 a).
destruct H3.
destruct a.
simpl in H4.
exists x2.
assumption.
rewrite H4.
exists x1.
assumption.
assumption.

rewrite H1.
constructor.
red; intros.
destruct H2.
pose proof (H0 a).
destruct H3.
auto with sets.

intros.
assert (Intersection U V = FamilyUnion
  [ S:Ensemble X | In B S /\ Included S (Intersection U V) ]).
apply Extensionality_Ensembles; split; red; intros.
destruct H.
destruct H0.
destruct H1.
destruct H1.
destruct H2.
pose proof (H _ H1).
pose proof (H0 _ H2).
pose proof (Hbasis _ _ H5 H6).
assert (In (Intersection S S0) x). constructor; trivial.
apply H7 in H8.
clear H7.
destruct H8.
destruct H7 as [? [? ?]].
exists x0; trivial.
constructor.
split; trivial.
red; intros.
constructor.
exists S; trivial.
pose proof (H9 x1 H10).
destruct H11; trivial.
exists S0; trivial.
pose proof (H9 x1 H10).
destruct H11; trivial.
destruct H1.
destruct H1.
destruct H1.
auto.

rewrite H1.
constructor.
red; intros.
destruct H2.
destruct H2.
auto.

assert (Full_set = FamilyUnion B).
apply Extensionality_Ensembles; split; red; intros.
pose proof (Hbasis_cover x).
destruct H0.
destruct H0.
exists x0; trivial.
constructor.

rewrite H; constructor.
auto with sets.
Defined.

Lemma Build_TopologicalSpace_from_open_basis_point_set:
  point_set Build_TopologicalSpace_from_open_basis = X.
Proof.
reflexivity.
Qed.

Lemma Build_TopologicalSpace_from_open_basis_basis:
  @open_basis Build_TopologicalSpace_from_open_basis B.
Proof.
constructor.
intros.
simpl.
assert (V = FamilyUnion (Singleton V)).
apply Extensionality_Ensembles; split; red; intros.
exists V; auto with sets.
destruct H0.
destruct H0; trivial.
rewrite H0; constructor.
red; intros.
destruct H1; trivial.
simpl.
intros.
destruct H.
destruct H0.
exists S; repeat split; auto with sets.
red; intros.
exists S; trivial.
Qed.

End BuildFromOpenBasis.

Implicit Arguments open_basis_cond [[X]].
Implicit Arguments open_basis_cover_cond [[X]].
Implicit Arguments Build_TopologicalSpace_from_open_basis [[X]].
Implicit Arguments Build_TopologicalSpace_from_open_basis_point_set [[X]].
Implicit Arguments Build_TopologicalSpace_from_open_basis_basis [[X]].


Require Import BenB.

Variable X: R -> Prop.
Variable Y: R -> Prop.
Variable Z: R -> Prop.

Theorem getallen_006 :
  (forall t:R, X t -> Y (t+2))
->
    (forall t:R, Y t -> Z (t+3))
  ->
    (forall t:R, X t -> Z (t+5)).
Proof.
imp_i a1.
imp_i a2.
all_i a.
imp_i a3.
imp_e (Y (a+2)).
replace (a+5) with (a+2+3).
all_e (forall t:R, Y t -> Z (t+3)) (a+2).
hyp a2.
lin_solve.
imp_e (X a).
all_e (forall t:R, X t -> Y (t + 2)) a.
hyp a1.
hyp a3.
Qed.


Require Import HoTT.

(** We introduce the notion of connected pointed types, which we will use as a tool later.  *)
Definition isconn (X : pType) := forall (x : X), merely (point X = x).
Record Conn_pType := {ptype_conn_ptype :> pType ; isconn_conn_ptype : isconn ptype_conn_ptype}.

Definition ptype_prod (X Y : pType) : pType
  := Build_pType (X * Y) (point _, point _).

Definition conn_ptype_prod (X Y : Conn_pType) : Conn_pType.
Proof.
  apply (Build_Conn_pType (ptype_prod X Y)).
  unfold isconn.
  intros [x y].
  generalize (isconn_conn_ptype X x). intro p.
  generalize (isconn_conn_ptype Y y). intro q.
  strip_truncations. apply tr. exact (path_prod (_,_) (_,_) p q).
Defined.


Require Import init.

Require Export module_category.
Require Import set.

(** These are unital associative algebras.  I'm just calling it "AlgebraObj"
because unital associative algebras are all I care about for the moment.  I can
change names later if I need to.
*)
Record AlgebraObj (F : CRingObj) := make_algebra {
    algebra_module : ModuleObj F;
    algebra_mult : Mult (module_V algebra_module);
    algebra_ldist : @Ldist (module_V algebra_module) (module_plus algebra_module) algebra_mult;
    algebra_rdist : @Rdist (module_V algebra_module) (module_plus algebra_module) algebra_mult;
    algebra_mult_assoc : @MultAssoc (module_V algebra_module) algebra_mult;
    algebra_one : One (module_V algebra_module);
    algebra_mult_lid : @MultLid (module_V algebra_module) algebra_mult algebra_one;
    algebra_mult_rid : @MultRid (module_V algebra_module) algebra_mult algebra_one;
    algebra_scalar_lmult : @ScalarLMult (cring_U F) (module_V algebra_module) algebra_mult (module_scalar algebra_module);
    algebra_scalar_rmult : @ScalarRMult (cring_U F) (module_V algebra_module) algebra_mult (module_scalar algebra_module);
}.
Arguments algebra_module {F}.
Arguments algebra_mult {F}.
Arguments algebra_ldist {F}.
Arguments algebra_rdist {F}.
Arguments algebra_mult_assoc {F}.
Arguments algebra_one {F}.
Arguments algebra_mult_lid {F}.
Arguments algebra_mult_rid {F}.
Arguments algebra_scalar_lmult {F}.
Arguments algebra_scalar_rmult {F}.
Definition algebra_V {F} (A : AlgebraObj F) := module_V (algebra_module A).
Definition algebra_plus {F} (A : AlgebraObj F) := module_plus (algebra_module A).
Definition algebra_zero {F} (A : AlgebraObj F) := module_zero (algebra_module A).
Definition algebra_neg {F} (A : AlgebraObj F) := module_neg (algebra_module A).
Definition algebra_plus_assoc {F} (A : AlgebraObj F) := module_plus_assoc (algebra_module A).
Definition algebra_plus_comm {F} (A : AlgebraObj F) := module_plus_comm (algebra_module A).
Definition algebra_plus_lid {F} (A : AlgebraObj F) := module_plus_lid (algebra_module A).
Definition algebra_plus_linv {F} (A : AlgebraObj F) := module_plus_linv (algebra_module A).
Definition algebra_scalar {F} (A : AlgebraObj F) := module_scalar (algebra_module A).
Definition algebra_scalar_id {F} (A : AlgebraObj F) := module_scalar_id (algebra_module A).
Definition algebra_scalar_ldist {F} (A : AlgebraObj F) := module_scalar_ldist (algebra_module A).
Definition algebra_scalar_rdist {F} (A : AlgebraObj F) := module_scalar_rdist (algebra_module A).
Definition algebra_scalar_comp {F} (A : AlgebraObj F) := module_scalar_comp (algebra_module A).

Global Existing Instances algebra_mult algebra_ldist algebra_rdist
    algebra_mult_assoc algebra_one algebra_mult_lid algebra_mult_rid
    algebra_scalar_lmult algebra_scalar_rmult algebra_plus algebra_zero
    algebra_neg algebra_plus_assoc algebra_plus_comm algebra_plus_lid
    algebra_plus_linv algebra_scalar algebra_scalar_id algebra_scalar_ldist
    algebra_scalar_rdist algebra_scalar_comp.

Record AlgebraObjHomomorphism {R : CRingObj} (A B : AlgebraObj R) := make_algebra_homomorphism {
    algebra_homo_f :> algebra_V A → algebra_V B;
    algebra_homo_plus : ∀ u v,
        algebra_homo_f (u + v) = algebra_homo_f u + algebra_homo_f v;
    algebra_homo_scalar : ∀ a v,
        algebra_homo_f (a · v) = a · algebra_homo_f v;
    algebra_homo_mult : ∀ u v,
        algebra_homo_f (u * v) = algebra_homo_f u * algebra_homo_f v;
    algebra_homo_one : algebra_homo_f 1 = 1
}.
Arguments algebra_homo_f {R A B}.

Definition algebra_to_module_homomorphism {R : CRingObj} {A B : AlgebraObj R}
    (f : AlgebraObjHomomorphism A B) :=
    make_module_homomorphism R (algebra_module A) (algebra_module B)
    f
    (algebra_homo_plus _ _ f)
    (algebra_homo_scalar _ _ f).

Theorem algebra_to_module_homo_eq {R : CRingObj} {A B : AlgebraObj R}
    (f : AlgebraObjHomomorphism A B) :
    ∀ x, f x =
    (algebra_to_module_homomorphism f) x.
Proof.
    reflexivity.
Qed.

Theorem algebra_homo_zero {R : CRingObj} {M N : AlgebraObj R} :
    ∀ f : AlgebraObjHomomorphism M N,
    f 0 = 0.
Proof.
    intros f.
    rewrite algebra_to_module_homo_eq.
    apply module_homo_zero.
Qed.

Theorem algebra_homo_neg {R : CRingObj} {M N : AlgebraObj R} :
    ∀ f : AlgebraObjHomomorphism M N,
    ∀ v, f (-v) = -f v.
Proof.
    intros f v.
    rewrite algebra_to_module_homo_eq.
    apply module_homo_neg.
Qed.

Theorem algebra_homomorphism_eq {R : CRingObj} {M N : AlgebraObj R} :
    ∀ f g : AlgebraObjHomomorphism M N,
    (∀ x, f x = g x) → f = g.
Proof.
    intros [f1 plus1 scalar1 mult1 one1] [f2 plus2 scalar2 mult2 one2] f_eq.
    cbn in *.
    assert (f1 = f2) as eq.
    {
        apply functional_ext.
        apply f_eq.
    }
    subst f2.
    rewrite (proof_irrelevance plus2 plus1).
    rewrite (proof_irrelevance scalar2 scalar1).
    rewrite (proof_irrelevance mult2 mult1).
    rewrite (proof_irrelevance one2 one1).
    reflexivity.
Qed.

Definition algebra_homo_id {R : CRingObj} (A : AlgebraObj R)
    : AlgebraObjHomomorphism A A := make_algebra_homomorphism R A A
        (λ x, x)
        (λ u v, Logic.eq_refl _)
        (λ a v, Logic.eq_refl _)
        (λ u v, Logic.eq_refl _)
        (Logic.eq_refl _).

Lemma algebra_homo_compose_plus : ∀ {R : CRingObj} {L M N : AlgebraObj R}
    {f : AlgebraObjHomomorphism M N} {g : AlgebraObjHomomorphism L M},
    ∀ a b, f (g (a + b)) = f (g a) + f (g b).
Proof.
    intros R L M N f g a b.
    rewrite algebra_homo_plus.
    apply algebra_homo_plus.
Qed.
Lemma algebra_homo_compose_scalar : ∀ {R : CRingObj} {L M N : AlgebraObj R}
    {f : AlgebraObjHomomorphism M N} {g : AlgebraObjHomomorphism L M},
    ∀ a v, f (g (a · v)) = a · f (g v).
Proof.
    intros R L M N f g a v.
    rewrite algebra_homo_scalar.
    apply algebra_homo_scalar.
Qed.
Lemma algebra_homo_compose_mult : ∀ {R : CRingObj} {L M N : AlgebraObj R}
    {f : AlgebraObjHomomorphism M N} {g : AlgebraObjHomomorphism L M},
    ∀ a b, f (g (a * b)) = f (g a) * f (g b).
Proof.
    intros R L M N f g a b.
    rewrite algebra_homo_mult.
    apply algebra_homo_mult.
Qed.
Lemma algebra_homo_compose_one : ∀ {R : CRingObj} {L M N : AlgebraObj R}
    {f : AlgebraObjHomomorphism M N} {g : AlgebraObjHomomorphism L M},
    f (g 1) = 1.
Proof.
    intros R L M N f g.
    rewrite algebra_homo_one.
    apply algebra_homo_one.
Qed.
Definition algebra_homo_compose {R : CRingObj} {L M N : AlgebraObj R}
    (f : AlgebraObjHomomorphism M N) (g : AlgebraObjHomomorphism L M)
    : AlgebraObjHomomorphism L N := make_algebra_homomorphism R L N
        (λ x, f (g x))
        algebra_homo_compose_plus algebra_homo_compose_scalar
        algebra_homo_compose_mult algebra_homo_compose_one.

(* begin show *)
Global Program Instance ALGEBRA (R : CRingObj) : Category := {
    cat_U := AlgebraObj R;
    cat_morphism M N := AlgebraObjHomomorphism M N;
    cat_compose {L M N} f g := algebra_homo_compose f g;
    cat_id M := algebra_homo_id M;
}.
(* end show *)
Next Obligation.
    apply algebra_homomorphism_eq.
    intros x.
    cbn.
    reflexivity.
Qed.
Next Obligation.
    apply algebra_homomorphism_eq.
    intros x.
    cbn.
    reflexivity.
Qed.
Next Obligation.
    apply algebra_homomorphism_eq.
    intros x.
    cbn.
    reflexivity.
Qed.

Theorem algebra_to_module_iso {R : CRingObj} {A B : AlgebraObj R} :
    ∀ f : cat_morphism (ALGEBRA R) A B, isomorphism f →
    isomorphism (C0 := MODULE R)(algebra_to_module_homomorphism f).
Proof.
    intros f [g [fg gf]].
    exists (algebra_to_module_homomorphism g).
    split.
    -   apply module_homomorphism_eq.
        intros x; cbn.
        inversion fg as [eq].
        apply (func_eq _ _ eq).
    -   apply module_homomorphism_eq.
        intros x; cbn.
        inversion gf as [eq].
        apply (func_eq _ _ eq).
Qed.


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

Require Import List Arith Nat Lia Relations Bool.

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

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.FOL.TRAKHTENBROT
  Require Import notations decidable gfp fol_ops fo_sig fo_terms fo_logic fo_definable fo_sat.

Import fol_notations.

Set Implicit Arguments.

Local Notation " e '#>' x " := (vec_pos e x).
Local Notation " e [ v / x ] " := (vec_change e x v).

(* ∈ and ⊆ are already used for object level syntax at too low level 59 *)

Local Infix "∊" := In (at level 70, no associativity).
Local Infix "⊑" := incl (at level 70, no associativity).

Local Notation "M , r ⊨ A" := (fol_sem M r A) (at level 70, format "M , r  ⊨  A").

Local Notation "f ∘ g" := (fun x => f (g x)) (at level 55, left associativity).

Section discrete_quotient.

  (* We show the FO bisimilarity/indistinguishability ≡ is both
      decidable and first order definable, ie there is a FO formula
      A(.,.) such that

            x ≡ y <-> A(x,y) holds for any x,y in the model M

      We use it to quotient the model M and get a discrete model
      (based on the finite type pos n) where identity coincides
      with FO bisimilarity.

      The idea of the construction is the following. We
      start from a finitary signature Σ to simplify the
      explanation but the devel below works in a sub-signature
      of Σ where the list ls bounds usable terms symbols and
      the list lr usable bound relations symbols.

      So given a finitary Σ and a finite and Boolean model M
      for Σ, we define the operator

                 F : (M² -> Prop) -> (M² -> Prop)

      transforming a binary relation R : M² -> Prop into F(R).

         x F(R) y iff      t(x)  R  t(y) for any t(.) = s<v(./p)>
                       and f(x) <-> f(y) for any f(.) = r<v(./p)>

      Then F(.) is monotonic, ω-continuous, and satisfies
      I ⊆ F(I), (F(R))⁻ ⊆ F(R⁻) and F(R) o F(R) ⊆ F (R o R)
      hence Kleene's greatest fixpoint gfp(F) exists, is
      obtained after ω-steps and is an equivalence relation.

      Moreover, F preserves decidability and FO-definability.
      Now we show that gfp(F) ~ F^n(TT) for a finite n
      which implies that gfp(F) is decidable and FO-definable.
      Here TT := fun _ _ => True is the full binary relation
      over M.

      The sequence n => F^n(TT) is a sequence of decidable
      (hence also weakly decidable) relations. If
      F^a(TT) ⊆ F^b(TT) for a < b then we have F^a(TT) ~ F^i(TT)
      for any i => a and thus for any i >= a F^i(TT) ~ gfp F.

      The sequence n => F^n(TT) belongs to the weak power list
      of binary relations over M (upto equivalence) which contains
      all weakly decidable binary relations over M. By the PHP,
      for n greater that the length of this list (which is
      2^(m*m) where m is the cardinal of M), we must have
      F^a(TT) ~ F^b(TT) for a <> b, hence we deduce
      F^n(TT) ~ gfp F.

      Hence, gfp F is decidable and FO-definable as well.

  *)

  Variables (Σ : fo_signature) (ls : list (syms Σ)) (lr : list (rels Σ)).

  (* fo_bisimilar means no FO formula can distinguish x from y. Beware that
      two free variables might be needed, see the remarks and counter-example
      below *)

  Definition fo_bisimilar X (M : fo_model Σ X) x y :=
         forall φ, fol_syms φ ⊑ ls -> fol_rels φ ⊑ lr
                -> forall ρ, M,x·ρ ⊨ φ <-> M,y·ρ ⊨ φ.

  (* Let us assume a finite and Boolean model m *)

  Variables (X : Type)
            (fin : finite_t X)
            (M : fo_model Σ X)
            (dec : fo_model_dec M).

  Infix "≐" := (fo_bisimilar M) (at level 70).

  Fact fo_bisimilar_refl x : x ≐ x.
  Proof. intro; tauto. Qed.

  Fact fo_bisimilar_sym x y : x ≐ y -> y ≐ x.
  Proof. unfold fo_bisimilar; intros H ? ? ? ?; rewrite H; auto; tauto. Qed.

  Fact fo_bisimilar_trans x y z : x ≐ y -> y ≐ z -> x ≐ z.
  Proof. unfold fo_bisimilar; intros H ? ? ? ? ?; rewrite H; auto. Qed.

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

  (* Construction of the greatest fixpoint of the following operator fom_op.
      Any prefixpoint R ⊆ fom_op R is a simulation for the model *)

  Local Definition fom_op1 R x y :=
          forall s, s ∊ ls
       -> forall (v : vec _ (ar_syms Σ s)) i,
                 R (fom_syms M s (v[x/i])) (fom_syms M s (v[y/i])).

  Local Definition fom_op2 x y :=
          forall s, s ∊ lr
       -> forall (v : vec _ (ar_rels Σ s)) i,
                 fom_rels M s (v[x/i]) <-> fom_rels M s (v[y/i]).

  Local Definition fom_op R x y := fom_op1 R x y /\ fom_op2 x y.

  (* First we show properties of fom_op

      a) Monotonicity
      b) preserves Reflexivity, Symmetry and Transitivity
      c) ω-continuous
      d) preserves decidability
      e) preserves FO definability

  *)

  Hint Resolve finite_t_pos finite_t_vec : core.

  (* Monotonicity *)

  Local Fact fom_op_mono R T : (forall x y, R x y -> T x y) -> (forall x y, fom_op R x y -> fom_op T x y).
  Proof. unfold fom_op, fom_op1, fom_op2; intros ? ? ? []; split; intros; auto. Qed.

  (* Reflexivity, symmetry & transitivity *)

  Local Fact fom_op_id x y : x = y -> fom_op (@eq _) x y.
  Proof. unfold fom_op, fom_op1, fom_op2; intros []; split; auto; tauto. Qed.

  Local Fact fom_op_sym R x y : fom_op R y x -> fom_op (fun x y => R y x) x y.
  Proof. unfold fom_op, fom_op1, fom_op2; intros []; split; intros; auto; symmetry; auto. Qed.

  Local Fact fom_op_trans R x z : (exists y, fom_op R x y /\ fom_op R y z)
                        -> fom_op (fun x z => exists y, R x y /\ R y z) x z.
  Proof.
    unfold fom_op, fom_op1, fom_op2.
    intros (y & H1 & H2); split; intros s Hs v p.
    + exists (fom_syms M s (v[y/p])); split; [ apply H1 | apply H2 ]; auto.
    + transitivity (fom_rels M s (v[y/p])); [ apply H1 | apply H2 ]; auto.
  Qed.

  (* ω-continuity *)

  Local Fact fom_op_continuous : gfp_continuous fom_op.
  Proof.
    intros f Hf x y H; split; intros s Hs v p.
    + intros n.
      generalize (H n); intros (H1 & H2).
      apply H1; auto.
    + apply (H 0); auto.
  Qed.

  Section fom_op_dec.

    (* fom_op is closed under strong decidability,
       a bit more complicated but we have all
       the tools to do it the easy way *)

    Let fom_op1_dec R :
          (forall x y, { R x y } + { ~ R x y })
       -> (forall x y, { fom_op1 R x y } + { ~ fom_op1 R x y }).
    Proof.
      unfold fom_op1.
      intros HR x y.
      apply forall_list_sem_dec; intros.
      do 2 (apply (fol_quant_sem_dec fol_fa); auto; intros).
    Qed.

    Let fom_op2_dec x y : { fom_op2 x y } + { ~ fom_op2 x y }.
    Proof.
      unfold fom_op2.
      apply forall_list_sem_dec; intros.
      do 2 (apply (fol_quant_sem_dec fol_fa); auto; intros).
      apply (fol_bin_sem_dec fol_conj);
        apply (fol_bin_sem_dec fol_imp); auto.
    Qed.

    Local Fact fom_op_dec R :
            (forall x y, { R x y } + { ~ R x y })
         -> (forall x y, { fom_op R x y } + { ~ fom_op R x y }).
    Proof using fin dec. intros; apply (fol_bin_sem_dec fol_conj); auto. Qed.

  End fom_op_dec.

  Section fo_definability.

    (* fom_op is closed under FO definability,
       more complicated but we have all the
       needed closure properties *)

    Tactic Notation "solve" "with" "proj" constr(t) :=
      apply fot_def_equiv with (f := fun φ => φ t); fol def; intros; rew vec.

    Let fol_def_fom_op1 R :
           fol_definable ls lr M (fun ψ => R (ψ 0) (ψ 1))
        -> fol_definable ls lr M (fun ψ => fom_op1 R (ψ 0) (ψ 1)).
    Proof.
      intros H.
      apply fol_def_list_fa; intros s Hs.
      apply fol_def_vec_fa.
      apply fol_def_finite_fa; auto; intro p.
      apply fol_def_subst2; auto.
      * apply fot_def_comp; auto; intro q.
        destruct (pos_eq_dec p q); subst.
        - solve with proj (ar_syms Σ s).
        - solve with proj (pos2nat q).
      * apply fot_def_comp; auto; intro q.
        destruct (pos_eq_dec p q); subst.
        - solve with proj (ar_syms Σ s+1).
        - solve with proj (pos2nat q).
    Qed.

    Let fol_def_fom_op2 :
           fol_definable ls lr M (fun ψ => fom_op2 (ψ 0) (ψ 1)).
    Proof.
      apply fol_def_list_fa; intros r Hr.
      apply fol_def_vec_fa.
      apply fol_def_finite_fa; auto; intro p.
      apply fol_def_iff.
      * apply fol_def_atom; auto; intro q.
        destruct (pos_eq_dec p q); subst.
        - solve with proj (ar_rels Σ r).
        - solve with proj (pos2nat q).
      * apply fol_def_atom; auto; intro q.
        destruct (pos_eq_dec p q); subst.
        - solve with proj (ar_rels Σ r+1).
        - solve with proj (pos2nat q).
    Qed.

    Local Fact fol_def_fom_op R :
            fol_definable ls lr M (fun ψ => R (ψ 0) (ψ 1))
         -> fol_definable ls lr M (fun ψ => fom_op R (ψ 0) (ψ 1)).
    Proof. intro; apply fol_def_conj; auto. Qed.

    Hint Resolve fol_def_fom_op : core.

    Local Fact fol_def_iter_fom_op R n :
            fol_definable ls lr M (fun ψ => R (ψ 0) (ψ 1))
         -> fol_definable ls lr M (fun ψ => iter fom_op R n (ψ 0) (ψ 1)).
    Proof. revert R; induction n; simpl; auto. Qed.

  End fo_definability.

  (* Now we build the greatest fixpoint fom_eq and show its properties

      a) it is an equivalence relation
      b) it is a congruence wrt to the model functions and relations
      c) it is decidable and FO definable

      the reason is that it is obtained after finitely many iterations of fom_op

    *)

  (* We build the greatest bisimulation which is an equivalence
      and a (pre-)fixpoint for the above operator *)

  Definition fom_eq := gfp fom_op.

  Infix "≡" := fom_eq (at level 70, no associativity).

  Hint Resolve fom_op_mono fom_op_id fom_op_sym fom_op_trans
               fom_op_continuous fom_op_dec : core.

  Local Fact fom_eq_equiv : equiv _ fom_eq.
  Proof. apply gfp_equiv; eauto. Qed.

  Local Fact fom_eq_refl x : x ≡ x.                         Proof. apply (proj1 fom_eq_equiv). Qed.
  Local Fact fom_eq_sym x y : x ≡ y -> y ≡ x.               Proof. apply fom_eq_equiv. Qed.
  Local Fact fom_eq_trans x y z : x ≡ y -> y ≡ z -> x ≡ z.  Proof. apply fom_eq_equiv. Qed.

  Local Fact fom_eq_fix x y : fom_op fom_eq x y <-> x ≡ y.
  Proof. apply gfp_fix; eauto. Qed.

  Local Fact fom_eq_incl R :
           (forall x y, R x y -> fom_op R x y)
        -> (forall x y, R x y -> x ≡ y).
  Proof. apply gfp_greatest; eauto. Qed.

  (* It is a congruence wrt to the model *)

  Local Fact fom_eq_syms x y s v p :
          s ∊ ls -> x ≡ y -> fom_syms M s (v[x/p]) ≡ fom_syms M s (v[y/p]).
  Proof. intros; apply fom_eq_fix; auto. Qed.

  Local Fact fom_eq_rels x y s v p :
          s ∊ lr -> x ≡ y -> fom_rels M s (v[x/p]) <-> fom_rels M s (v[y/p]).
  Proof. intros; apply fom_eq_fix; auto. Qed.

  Hint Resolve fom_eq_refl fom_eq_sym fom_eq_trans fom_eq_syms fom_eq_rels : core.

  Local Theorem fom_eq_syms_full s v w :
          s ∊ ls -> (forall p, v#>p ≡ w#>p) -> fom_syms M s v ≡ fom_syms M s w.
  Proof. intro; apply map_vec_pos_equiv; eauto. Qed.

  Local Theorem fom_eq_rels_full s v w :
          s ∊ lr -> (forall p, v#>p ≡ w#>p) -> fom_rels M s v <-> fom_rels M s w.
  Proof. intro; apply map_vec_pos_equiv; eauto; tauto. Qed.

  (* And because the signature is finite (ie the symbols and relations)
                  the model M is finite and composed of decidable relations

      We do have a decidable equivalence here *)

  Local Fact fom_eq_dec x y : { x ≡ y } + { ~ x ≡ y }.
  Proof using fin dec. apply gfp_decidable; eauto. Qed.

  Section fol_characterization.

    (* We show that the greatest bisimulation is equivalent to FOL undistinguishability.
        This result is purely for the sake of completeness of the description of fom_eq,
        it is not used in the reduction below

        It states that x and y are bisimilar iff there is no interpretation of a
        FO formula that can distinguish x from y *)

    Hint Resolve fom_eq_syms_full fom_eq_rels_full : core.

    Let f : fo_simulation ls lr M M.
    Proof. exists fom_eq; abstract eauto. Defined.

    Let fom_eq_fol_charac1 φ :
            fol_syms φ ⊑ ls
         -> fol_rels φ ⊑ lr
         -> forall ρ δ, (forall n, n ∊ fol_vars φ -> ρ n ≡ δ n) -> M,ρ ⊨ φ <-> M,δ ⊨ φ.
    Proof. intros; apply fo_model_simulation with (R := f); auto. Qed.

    (* By fom_eq_form_sem above, we know there is a FO formula
        A(.,.) in two free variables such that x ≡ y <-> A(x,y).

        One obvious follow up question is can we show

           x ≡ y <-> A(x) <-> A(y) for any A(.) with one free variable

        Another obvious follow up question is, for a given x in the
        model, can one characterize the class of { y | x ≡ y } with
        a formula Ax(.) with one free variable.

        Both questions have a negative answer proved in the counter
        example to be found below. There is a model of Σ = {ø,{=²}}
        with two distinct values where =² is interpreted by identity
        and such that A(x) <-> A(y) for any formula with at most one
        free variable. See theorem FO_does_not_characterize_classes.

      *)

    Let fom_eq_fo_bisimilar x y : x ≡ y -> x ≐ y.
    Proof.
      intros ? ? ? ? ?; apply fom_eq_fol_charac1; auto.
      intros [] _; auto.
    Qed.

    Let fo_bisimilar_fom_eq x y : x ≐ y -> x ≡ y.
    Proof.
      revert x y; apply gfp_greatest; eauto.
      intros x y H; split.
      * intros s Hs v p A H1 H2 phi.
        destruct (fot_vec_env Σ p) as (w & Hw1 & Hw2).
        set (B := fol_subst (fun n =>
               match n with
                 | 0   => in_fot s w
                 | S n => £ (S n + ar_syms Σ s)
               end) A).
        assert (HB : forall z, fol_sem M (z·(env_vlift phi v)) B
                           <-> fol_sem M (fom_syms M s (v[z/p]))·phi A).
        { intros z; unfold B; rewrite fol_sem_subst; apply fol_sem_ext.
          intros [ | n] _; rew fot; simpl; f_equal.
          * apply vec_pos_ext; intros q; rewrite vec_pos_map; apply Hw1.
          * rewrite env_vlift_fix1; auto. }
        rewrite <- !HB; apply H.
        - red; apply Forall_forall, fol_syms_subst.
          intros [ | n ]; rew fot.
          + intros _; apply Forall_forall.
            intros s' [ <- | Hs' ]; auto; apply H1; revert Hs'.
            rewrite in_flat_map; intros (z & H3 & H4).
            apply vec_list_inv in H3; destruct H3 as (q & ->).
            rewrite Hw2 in H4; destruct H4.
          + constructor.
          + apply Forall_forall, H1.
        - unfold B; rewrite fol_rels_subst; auto.
      * intros r Hr v p; red in H.
        destruct (fot_vec_env Σ p) as (w & Hw1 & Hw2).
        set (B := fol_atom r w).
        assert (HB : forall z, fol_sem M (z·(env_vlift (fun _ => x) v)) B
                           <-> fom_rels M r (v[z/p])).
        { intros z; unfold B; simpl; apply fol_equiv_ext; f_equal.
          apply vec_pos_ext; intros q; rewrite vec_pos_map; apply Hw1. }
        rewrite <- !HB; apply H.
        - unfold B; simpl; intros z; rewrite in_flat_map.
          intros (t & H3 & H4).
          apply vec_list_inv in H3.
          destruct H3 as (q & ->).
          rewrite Hw2 in H4; destruct H4.
        - unfold B; simpl; intros ? [ <- | [] ]; auto.
    Qed.

    Hint Resolve fom_eq_fo_bisimilar fo_bisimilar_fom_eq : core.

    Theorem fom_eq_fol_characterization x y : x ≡ y <-> x ≐ y.
    Proof. split; auto. Qed.

  End fol_characterization.

  (** R is an equivalence relation and a congruence for the interpretations
      of all the symbols in ls and lr *)

  Definition fo_congruence_upto R :=
      ( (equivalence _ R)
    * (forall s v w, s ∊ ls -> (forall p, R (v#>p) (w#>p)) -> R (fom_syms M s v) (fom_syms M s w))
    * (forall r v w, r ∊ lr -> (forall p, R (v#>p) (w#>p)) -> fom_rels M r v <-> fom_rels M r w) )%type.

  Theorem fo_bisimilar_dec_congr :
            fo_congruence_upto (fun x y => x ≐ y)
         * (forall x y, decidable (x ≐ y)).
  Proof using fin dec.
    lsplit 3.
    + split; red; [ intros ? | intros ? ? ? | intros ? ?];
        rewrite <- !fom_eq_fol_characterization; eauto.
    + intros ? ? ? ? ?; apply fom_eq_fol_characterization, fom_eq_syms_full; auto.
      intro; apply fom_eq_fol_characterization; auto.
    + intros ? ? ? ? ?; apply fom_eq_rels_full; auto.
      intro; apply fom_eq_fol_characterization; auto.
    + intros x y.
      destruct (fom_eq_dec x y); [ left | right ];
        rewrite <- fom_eq_fol_characterization; auto.
  Qed.

  Section build_the_discrete_model.

    (* And now we can build a discrete model with this decidable
      equivalence. There is a fo_projection from M to Md where
      Md is a Boolean model based on the ground type pos n.

     *)

    Let l := proj1_sig fin.
    Let Hl : forall x, x ∊ l := proj2_sig fin.

    Hint Resolve fom_eq_dec : core.

    Let Q : fin_quotient fom_eq.
    Proof. apply decidable_EQUIV_fin_quotient with (l := l); eauto. Qed.

    Let n := fq_size Q.
    Let cls := fq_class Q.
    Let repr := fq_repr Q.
    Let E1 p : cls (repr p) = p.              Proof. apply fq_surj. Qed.
    Let E2 x y : x ≡ y <-> cls x = cls y.     Proof. apply fq_equiv. Qed.

    Let Md : fo_model Σ (pos n).
    Proof.
      exists.
      + intros s v; apply cls, (fom_syms M s), (vec_map repr v).
      + intros s v; apply (fom_rels M s), (vec_map repr v).
    Defined.

    Let H1 s v : s ∊ ls -> cls (fom_syms M s v) = fom_syms Md s (vec_map cls v).
    Proof.
      intros Hs; simpl.
      apply E2.
      apply fom_eq_syms_full; auto.
      intros p; rewrite vec_map_map, vec_pos_map.
      apply E2; rewrite E1; auto.
    Qed.

    Let H2 r v : r ∊ lr -> fom_rels M r v <-> fom_rels Md r (vec_map cls v).
    Proof.
      intros Hs; simpl.
      apply fom_eq_rels_full; auto.
      intros p; rewrite vec_map_map, vec_pos_map.
      apply E2; rewrite E1; auto.
    Qed.

    Let f : fo_projection ls lr M Md.
    Proof. exists cls repr; abstract auto. Defined.

    Let H3 φ ρ :   fol_syms φ ⊑ ls
                -> fol_rels φ ⊑ lr
                -> M,ρ ⊨ φ <-> Md,cls∘ρ ⊨ φ.
    Proof. intros; apply fo_model_projection with (p := f); auto. Qed.

    Let H4 p q : fo_bisimilar Md p q <-> p = q.
    Proof.
      split.
      + intros H.
        rewrite <- (E1 q), <- (E1 p).
        apply E2, fom_eq_fol_characterization.
        intros A Hs Hr phi.
        specialize (H A Hs Hr (fun p => cls (phi p))).
        revert H; apply fol_equiv_impl.
        all: rewrite H3; auto; apply fol_sem_ext; intros []; now simpl.
      + intros []; red; tauto.
    Qed.

    (* Every finite & decidable model can be projected to pos n
        with decidable relations and such that identity is exactly
        FO undistinguishability *)

    Theorem fo_fin_model_discretize :
        { n : nat &
        { Md : fo_model Σ (pos n) &
        { _ : fo_model_dec Md &
        { _ : fo_projection ls lr M Md &
          (forall p q, fo_bisimilar Md p q <-> p = q) } } } }.
    Proof using E1.
      exists n, Md.
      exists; eauto.
      red; simpl; auto.
    Qed.

  End build_the_discrete_model.

  (** Additional results on FO definability *)

  Section FO_definability.

    (* Because the fixpoint is reached after finitely many iterations, it is FO definable *)

    Local Fact fom_eq_finite : { n | forall x y, x ≡ y <-> iter fom_op (fun _ _ => True) n x y }.
    Proof using fin dec. apply gfp_finite_t; eauto. Qed.

    Theorem fo_bisimilar_fol_def : fol_definable ls lr M (fun φ => φ 0 ≐ φ 1).
    Proof using fin dec.
      destruct fom_eq_finite as (n & Hn).
      apply fol_def_equiv with (R := fun φ => iter fom_op (fun _ _ : X => True) n (φ 0) (φ 1)).
      + intro; rewrite <- fom_eq_fol_characterization, <- Hn; tauto.
      + apply fol_def_iter_fom_op; fol def.
    Qed.

  End FO_definability.

  (** We have a much stronger statement than the decidability of ≐.
      In fact ≐ is first order definable and this follows from the
      fact that X/M is finite *)

  Section fo_bisimilar_formula.

    (* We build a single FO formula with two variables
        such that:
          a) ξ(.,.) only has two free variables, 0 and 1
          b) ξ is built using only symbols in ls and lr
          c) ξ characterize bisimilarity upto ls/lr

                  x ≐ y <-> x ≡ y <-> ξ(x,y)
     *)

    Let A := proj1_sig fo_bisimilar_fol_def.

    (* Let use remove unused variables by mapping them to £0 *)

    Definition fo_bisimilar_formula := fol_subst (fun n => match n with 0 => £1 | _ => £0 end) A.

    Notation ξ := fo_bisimilar_formula.

    Fact fo_bisimilar_formula_vars : fol_vars ξ ⊑ 0::1::nil.
    Proof.
      unfold fo_bisimilar_formula; rewrite fol_vars_subst.
      intros n; rewrite in_flat_map; intros (? & _ & H).
      revert x H; intros [ | [] ]; simpl; tauto.
    Qed.

    Fact fo_bisimilar_formula_syms : fol_syms ξ ⊑ ls.
    Proof.
      unfold fo_bisimilar_formula; red.
      apply Forall_forall, fol_syms_subst.
      + intros [ | []]; rew fot; auto.
      + apply Forall_forall, (proj2_sig fo_bisimilar_fol_def).
    Qed.

    Fact fo_bisimilar_formula_rels : fol_rels ξ ⊑ lr.
    Proof.
      unfold fo_bisimilar_formula; rewrite fol_rels_subst.
      apply (proj2_sig fo_bisimilar_fol_def).
    Qed.

    Fact fo_bisimilar_formula_sem φ x y : M,y·x·φ ⊨ ξ <-> x ≐ y.
    Proof.
      unfold fo_bisimilar_formula; rewrite fol_sem_subst.
      apply (proj2_sig fo_bisimilar_fol_def).
    Qed.

  End fo_bisimilar_formula.

End discrete_quotient.

Import ListNotations.

Section counter_model_to_class_FO_definability.

  (* Even though ≐ is FO definable, its equivalence classes are not *)

  (* We show that there is a model over Σ = Σrel 2 = {ø,{=²}}
      where bisimulation ≐ is identity but x ≐ _ is not definable
      by a FO formula with a single free variable

      There are two non-equivalent values that cannot be
      distinguished when using a single variable

      Even though ≐ is FO definable by a formula with two
      free variables, equivalences classes of ≐ are not
      FO definable *)

  Let Σ := Σrel 2.

  Let M : fo_model Σ bool.
  Proof.
    exists; simpl.
    + intros [].
    + exact (fun _ => rel2_on_vec eq).
  Defined.

  Let M_dec : fo_model_dec M.
  Proof. intros [] ?; apply bool_dec. Qed.

  Notation α := true.
  Notation β := false.

  (* A projection of M onto itself which swaps α/β *)

  Let f : @fo_projection Σ [] [tt] _ M _ M.
  Proof.
    exists negb negb; simpl.
    + abstract now intros [].
    + abstract intros [].
    + abstract (intros [] v _;
      vec split v with x; vec split v with y; vec nil v; simpl;
      revert x y; now intros [] []).
  Defined.

  Let homeomorphism φ ρ : M,ρ ⊨ φ <-> M,negb∘ρ ⊨ φ.
  Proof.
    apply fo_model_projection with (p := f); auto.
    all: intros []; simpl; auto.
  Qed.

  Infix "≐" := (fo_bisimilar (Σ := Σ) nil [tt] M) (at level 70, no associativity).

  Hint Resolve finite_t_bool : core.

  Let bisim_is_identity x y : x ≐ y <-> x = y.
  Proof.
    split.
    + intros H.
      now apply (H (@fol_atom Σ tt (£0##£1##ø)))
        with (ρ := fun n => match n with 0 => y | _ => x end).
    + intros ->; apply fo_bisimilar_refl.
  Qed.

 (* α/true and β/false are not bisimilar *)

  Let true_is_not_false : ~ α ≐ β.
  Proof. now rewrite bisim_is_identity. Qed.

  (* No formula using only variable 0 can distinguish α from β *)

  Let no_distinct φ ρ x y : fol_vars φ ⊑ [0] -> M,x·ρ ⊨ φ <-> M,y·ρ ⊨ φ.
  Proof.
    revert x y; intros [] [] H; try tauto; [ | symmetry ];
      rewrite homeomorphism with (ρ := β·ρ) at 1;
      apply fol_sem_ext; intros n Hn; now apply H in Hn as [ [] | [] ].
  Qed.

  (** There is a (discrete, finite, decidable) model M over Σ2 with
      two values α and β such that:
       1) FO bisimilarity (up to all symbols) is equivalent to identity
       2) no FO formula with one free variable can distinguish the elements
          of M, in particular distinguish α from β;
       3) there is a FO ξ(.,.) with 2 free variables that distinguishes
          α from β, i.e. ξ(α,α) and not ξ(β,α) (hence particular, α <> β).
   *)

  Theorem FO_does_not_characterize_classes :
     exists (M : fo_model Σ bool) (_ : fo_model_dec M) (a b : bool),
              (forall x y, fo_bisimilar (Σ := Σ) nil [tt] M x y <-> x = y)
           /\ (forall x y φ ρ, fol_vars φ ⊑ [0] -> M,x·ρ ⊨ φ <-> M,y·ρ ⊨ φ)
           /\ exists ξ, fol_vars ξ ⊑ [0;1] /\ forall ρ, M,a·a·ρ ⊨ ξ /\ ~ M,b·a·ρ ⊨ ξ.
  Proof.
    exists M, M_dec, true, false; msplit 2; auto.
    exists (fo_bisimilar_formula (Σ := Σ) nil [tt] finite_t_bool M_dec); split.
    + apply fo_bisimilar_formula_vars.
    + intro; rewrite !fo_bisimilar_formula_sem; split; auto; intro; tauto.
  Qed.

End counter_model_to_class_FO_definability.


Require Import init.

Require Export mult_field.

#[universes(template)]
Class ScalarMult U V := {
    scalar_mult : U → V → V
}.
Infix "·" := scalar_mult : algebra_scope.
Arguments scalar_mult : simpl never.

Class ScalarComp U V `{Mult U, ScalarMult U V} := {
    scalar_comp : ∀ a b v, a · (b · v) = (a * b) · v
}.

Class ScalarId U V `{One U, ScalarMult U V} := {
    scalar_id : ∀ v, 1 · v = v
}.

Class ScalarLdist U V `{Plus V, ScalarMult U V} := {
    scalar_ldist : ∀ a u v, a · (u + v) = a · u + a · v
}.
Class ScalarRdist U V `{Plus U, Plus V, ScalarMult U V} := {
    scalar_rdist : ∀ a b v, (a + b) · v = a · v + b · v
}.

Class ScalarLMult U V `{Mult V, ScalarMult U V} := {
    scalar_lmult : ∀ a u v, (a · u) * v = a · (u * v)
}.
Class ScalarRMult U V `{Mult V, ScalarMult U V} := {
    scalar_rmult : ∀ a u v, u * (a · v) = a · (u * v)
}.

Class Module U V `{
    MR : CRing U,
    MG : AbelianGroup V,
    SM : ScalarMult U V,
    SMC : @ScalarComp U V UM SM,
    SME : @ScalarId U V UE SM,
    SML : @ScalarLdist U V UP0 SM,
    SMR : @ScalarRdist U V UP UP0 SM
}.

Class VectorSpace U V `{
    VF : Field U,
    VG : AbelianGroup V,
    SM : ScalarMult U V,
    SMC : @ScalarComp U V UM SM,
    SME : @ScalarId U V UE SM,
    SML : @ScalarLdist U V UP0 SM,
    SMR : @ScalarRdist U V UP UP0 SM
}.

Class Algebra U V `{
    AR : CRing U,
    AR : Ring V,
    SM : ScalarMult U V,
    SMC : @ScalarComp U V UM SM,
    SME : @ScalarId U V UE SM,
    SML : @ScalarLdist U V UP0 SM,
    SMR : @ScalarRdist U V UP UP0 SM,
    SMLM : @ScalarLMult U V UM0 SM,
    SMRM : @ScalarRMult U V UM0 SM
}.

Class AlgebraField U V `{
    AF : Field U,
    AR : Ring V,
    SM : ScalarMult U V,
    SMC : @ScalarComp U V UM SM,
    SME : @ScalarId U V UE SM,
    SML : @ScalarLdist U V UP0 SM,
    SMR : @ScalarRdist U V UP UP0 SM,
    SMLM : @ScalarLMult U V UM0 SM,
    SMRM : @ScalarRMult U V UM0 SM
}.

(* begin hide *)
Section LinearBase.

Context {U V} `{AlgebraField U V}.

(* end hide *)
Theorem lscalar : ∀ {u v} a, u = v → a · u = a · v.
Proof.
    intros u v a eq.
    rewrite eq.
    reflexivity.
Qed.
Theorem rscalar : ∀ {a b} v, a = b → a · v = b · v.
Proof.
    intros u v a eq.
    rewrite eq.
    reflexivity.
Qed.
Theorem lrscalar : ∀ {a b u v}, a = b → u = v → a · u = b · v.
Proof.
    intros a b u v eq1 eq2.
    apply lscalar with b in eq2.
    apply rscalar with u in eq1.
    rewrite eq1, <- eq2.
    reflexivity.
Qed.

Theorem scalar_lanni : ∀ v, 0 · v = 0.
Proof.
    intros v.
    assert (0 · v = 0 · v) as eq by reflexivity.
    rewrite <- (plus_lid 0) in eq at 1.
    rewrite scalar_rdist in eq.
    apply plus_0_a_ab_b in eq.
    symmetry; exact eq.
Qed.

Theorem scalar_ranni : ∀ a, a · 0 = 0.
Proof.
    intros a.
    assert (a · 0 = a · 0) as eq by reflexivity.
    rewrite <- (plus_lid 0) in eq at 1.
    rewrite scalar_ldist in eq.
    apply plus_0_a_ab_b in eq.
    symmetry; exact eq.
Qed.

Theorem scalar_lneg : ∀ a b, -a · b = -(a · b).
Proof.
    intros a b.
    apply plus_lcancel with (a · b).
    rewrite <- scalar_rdist.
    do 2 rewrite plus_rinv.
    apply scalar_lanni.
Qed.

Theorem scalar_rneg : ∀ a b, a · -b = -(a · b).
Proof.
    intros a b.
    apply plus_lcancel with (a · b).
    rewrite <- scalar_ldist.
    do 2 rewrite plus_rinv.
    apply scalar_ranni.
Qed.

Theorem scalar_neg_one : ∀ a, (-(1)) · a = -a.
Proof.
    intros a.
    rewrite scalar_lneg.
    rewrite scalar_id.
    reflexivity.
Qed.

Theorem scalar_lcancel : ∀ {a b} c, 0 ≠ c → c · a = c · b → a = b.
Proof.
    intros a b c c_nz eq.
    apply lscalar with (/c) in eq.
    do 2 rewrite scalar_comp in eq.
    rewrite mult_linv in eq by exact c_nz.
    do 2 rewrite scalar_id in eq.
    exact eq.
Qed.

Theorem scalar_rcancel : ∀ {a b} c, 0 ≠ c → a · c = b · c → a = b.
Proof.
    intros a b c c_nz eq.
    rewrite <- plus_0_anb_a_b in eq.
    rewrite <- scalar_lneg in eq.
    rewrite <- scalar_rdist in eq.
    classic_contradiction contr.
    rewrite <- (scalar_ranni (a - b)) in eq.
    apply scalar_lcancel in eq; [>contradiction|].
    intros contr2.
    rewrite plus_0_anb_a_b in contr2.
    contradiction.
Qed.

(* begin hide *)
End LinearBase.
(* end hide *)


(**
10進各桁の和が3の倍数なら、3の倍数であることの証明
========================

@suharahiromichi

2020/04/10
 *)

From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(* Set Print All. *)

Section multiple_of_3.

(**
# 問題
*)

(**
任意の自然数が3の倍数であることと、
その数を10進数で表したときの各桁の和が3の倍数であることは同値である。

たとえば、2019 は 3の倍数で、2+0+1+9=12 も3の倍数ですが、
2020 は3の倍数でなく、2+0+2+0+4 も3の倍数ではありません。
*)

(**
10進数の数値の各桁を ... x3 x2 x1 x0 で表すとします。
*)
Variable x : nat -> nat.

(**
``0*x0 + 10*x1 + 100*x2 + 1000*x3 + ...`` が3で割り切れることと、
``x0 + x1 + x2 + x3 + ...`` が3で割り切れることが、同値であることを証明します。

MathComp では、x が3で割り切れることを ``3 %| x`` で表します。
割る数の3が前なのに注意してください。これはbool値の述語です。

同値であるとは、bool値が等しいこと（どちらもtrueか、どちらもfalse）で表します。

数列の和 ``Σ(i=0..n)(x i)`` は、big operator を使って``\sum_(0 <= i < n.+1)(x i)``
となります。
``\sum_`` は、演算子と単位元を組み合わせた ``\bigop[addn/0]`` の略記です。

以上から、
*)

Check forall (n : nat), (3 %| \sum_(0 <= i < n.+1)(10^i * (x i))) =
                        (3 %| \sum_(0 <= i < n.+1)(x i)).

(**
を証明すればよいことになります。
以下において、0 は 3の倍数であるとします。

また、``i = 0 to n`` を ``0 <= i < n.+1`` とするのは、
big operator の補題 big_nat1 を使えるようにするためです。
*)

(**
# 証明
*)

(**
## 補題 1.

``0*x0 + 9*x1 + 99*x2 + 999*x3`` は3の倍数である。

3の倍数問題の根幹となる補題です。
0, 9, 99, 999 に、任意の自然数 xi を掛けたものの和が、3の倍数になることを証明します。
*)

Lemma gt_exp m n : 0 < m -> 0 < m^n.
Proof.
  move=> H.
  elim: n => // n IHn.
    by rewrite expnS -{1}(muln0 m)ltn_pmul2l.
Qed.

Lemma dvdn3_99 n : 3 %| (10^n - 1).
Proof.
  elim: n => //.
  move=> n IHn.
  rewrite expnS.
  have {1}-> : 10 = 9 + 1 by [].
  rewrite mulnDl mul1n -addnBA.
  - by rewrite dvdn_addr // dvdn_mulr.
  - by apply: gt_exp.
Qed.

Lemma dvdn3_99x n : 3 %| (10^n - 1) * (x n).
Proof.
  rewrite dvdn_mulr //.
    by apply: dvdn3_99.
Qed.

(**
0*x0, 9*x1, 99*x2 が3の倍数であることが判ったので、
これをつかって、補題を証明します。
 *)

Lemma dvdn3_s99x (n : nat) : 3 %| \sum_(0 <= i < n.+1)((10^i - 1) * (x i)).
Proof.
  elim: n => [| n IHn].
  - rewrite big_nat1.
    apply: dvdn_mulr.
      by apply: dvdn3_99.
  - rewrite big_nat_recr // dvdn_addl // dvdn_mulr //.
      by apply: dvdn3_99.
Qed.

(**
## 補題 ``Σ(f + g) = Σf + Σg``

数列の和について、自明な補題について証明しておきます。
これは、bigop.v のなかで、
可換なop一般に対して証明されているので、それを使います。
 *)

Check big_split
  : forall (R : Type) (idx : R) (op : Monoid.com_law idx)
           (I : Type) (r : seq I) (P : pred I) (F1 F2 : I -> R),
    \big[op/idx]_(i <- r | P i) op (F1 i) (F2 i) =
    op (\big[op/idx]_(i <- r | P i) F1 i) (\big[op/idx]_(i <- r | P i) F2 i).

Lemma s__s_s (n : nat) (F G : nat -> nat) :
  \sum_(0 <= i < n)(F i + G i) =
  \sum_(0 <= i < n)(F i) + \sum_(0 <= i < n)(G i).
Proof.
    by rewrite big_split /=.
Qed.

(**
## 補題 2.

``x + 10*x1 + 100*x2 + 1000*x3 = (0*x0 + 9*x1 + 99*x2 + 999*x3) + (x0 + x1 + x2 + x3)``

数列の和の問題として、``x + 10*x1 + 100*x2 + 1000*x3`` が、
``0*x0 + 9*x1 + 99*x2 + 999*x3`` と``x0 + x1 + x2 + x3`` の和であることを証明します。

これは一見自明ですが、``Σ(f + g) = Σf + Σg`` を使うために式を変形していきます。
*)

Lemma l_100__99_1 (n : nat) : 10 ^ n = 10 ^ n - 1 + 1.
Proof.
  rewrite addn1 subn1 prednK //.
    by apply: gt_exp.
Qed.

Lemma l_100x__99x_x (i : nat) : 10^i * (x i) = (10^i - 1) * (x i) + (x i).
Proof.
  rewrite -{3}[(x i)]mul1n.
  rewrite -mulnDl.
    by rewrite -l_100__99_1.
Qed.

Lemma s100x__s99x_x (n : nat) :
  \sum_(0 <= i < n.+1)(10^i * (x i)) =
  \sum_(0 <= i < n.+1)((10^i - 1) * (x i) + (x i)).
Proof.
  elim: n => [| n IHn].
  - by rewrite 2!big_nat1 l_100x__99x_x.
  - rewrite big_nat_recr //=.
    rewrite [\sum_(0 <= i < n.+2) ((10 ^ i - 1) * x i + x i)]big_nat_recr //=.
    have <- : 10 ^ n.+1 * x n.+1 = (10 ^ n.+1 - 1) * x n.+1 + x n.+1
      by rewrite -{3}[x n.+1]mul1n -[(10 ^ n.+1 - 1) * x n.+1 + 1 * x n.+1]mulnDl
         -l_100__99_1.
      by rewrite -IHn.
Qed.

Lemma s100x__s99x_sx (n : nat) :
  \sum_(0 <= i < n.+1)(10^i * (x i)) =
  \sum_(0 <= i < n.+1)((10^i - 1) * (x i)) + \sum_(0 <= i < n.+1)(x i).
Proof.
    by rewrite -s__s_s s100x__s99x_x.
Qed.

(**
## 定理

``x + 10*x1 + 100*x2 + 1000*x3`` が3で割りきれることと、
``x0 + x1 + x2 + x3`` が3で割りきれることは、同値である。

二つの補題をつかって、定理を証明します。
 *)

Theorem mo3 (n : nat) : (3 %| \sum_(0 <= i < n.+1)(10^i * (x i))) =
                      (3 %| \sum_(0 <= i < n.+1)(x i)).
Proof.
  rewrite s100x__s99x_sx.
  rewrite dvdn_addr //.
    by apply: dvdn3_s99x.
Qed.

(* *************************** *)
(* 予備の補題                  *)
(* *************************** *)

Lemma test100 (x2 : nat) : (3 %| x2) = (3 %| 100 * x2).
Proof.
  have -> : 100 = 99 + 1 by [].
  rewrite mulnDl mul1n.
  rewrite dvdn_addr => //=.
    by rewrite dvdn_mulr.
Qed.

Lemma test10 x1 : (3 %| x1) = (3 %| 10 * x1).
Proof.
  have -> : 10 = 9 + 1 by [].
  rewrite mulnDl mul1n.
  rewrite dvdn_addr => //=.
    by rewrite dvdn_mulr.
Qed.

Lemma dvdn3_s99 (n : nat) : 3 %| \sum_(0 <= i < n.+1)(10^i - 1).
Proof.
  elim: n => [| n IHn].
  - by rewrite big_nat1.
  - rewrite big_nat_recr //.
    rewrite dvdn_addl //.
      by apply: dvdn3_99.
Qed.

End multiple_of_3.

(* END *)


Fixpoint truth_value (x : syntax) : bool
  := match x with
     | One  => true
     | Zero => false
     | Tensor l r => truth_value l && truth_value r
     | With l r   => truth_value l && truth_value r
     | Implication l r => if truth_value l then truth_value r else true
     | Bang r => truth_value r
     end.

Definition truth_value_of_context (ctx : seq syntax) : bool
  := foldr andb true (map truth_value ctx).

Theorem model : forall {Ctx P},
  (Ctx ||- P) -> truth_value_of_context Ctx = true -> truth_value P = true.


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

(** Here are collected some results about the type sumbool (see INIT/Specif.v)
   [sumbool A B], which is written [{A}+{B}], is the informative
   disjunction "A or B", where A and B are logical propositions.
   Its extraction is isomorphic to the type of booleans. *)

(** A boolean is either [true] or [false], and this is decidable *)

Definition sumbool_of_bool : forall b:bool, {b = true} + {b = false}.
  destruct b; auto.
Defined.

Hint Resolve sumbool_of_bool: bool.

Definition bool_eq_rec :
  forall (b:bool) (P:bool -> Set),
    (b = true -> P true) -> (b = false -> P false) -> P b.
  destruct b; auto.
Defined.

Definition bool_eq_ind :
  forall (b:bool) (P:bool -> Prop),
    (b = true -> P true) -> (b = false -> P false) -> P b.
  destruct b; auto.
Defined.

(** Logic connectives on type [sumbool] *)

Section connectives.

  Variables A B C D : Prop.

  Hypothesis H1 : {A} + {B}.
  Hypothesis H2 : {C} + {D}.

  Definition sumbool_and : {A /\ C} + {B \/ D}.
    case H1; case H2; auto.
  Defined.

  Definition sumbool_or : {A \/ C} + {B /\ D}.
    case H1; case H2; auto.
  Defined.

  Definition sumbool_not : {B} + {A}.
    case H1; auto.
  Defined.

End connectives.

Hint Resolve sumbool_and sumbool_or: core.
Hint Immediate sumbool_not : core.

(** Any decidability function in type [sumbool] can be turned into a function
    returning a boolean with the corresponding specification: *)

Definition bool_of_sumbool :
  forall A B:Prop, {A} + {B} -> {b : bool | if b then A else B}.
  intros A B H.
  elim H; intro; [exists true | exists false]; assumption.
Defined.
Implicit Arguments bool_of_sumbool.


Require Import List.

Require Import untyped.

(*
Compute expDenote (Const 42).
Compute expDenote (Binop Plus (Const 2) (Const 3)).
Compute expDenote (Binop Times (Binop Plus (Const 2) (Const 3)) (Const 7)).
*)

Lemma expDenote_test1 : expDenote (Const 42) = 42.
Proof. reflexivity. Qed.

Lemma expDenote_test2 : expDenote (Binop Plus (Const 2) (Const 3)) = 5.
Proof. reflexivity. Qed.

Lemma expDenote_test3 :
    expDenote (Binop Times (Binop Plus (Const 2) (Const 3)) (Const 7)) = 35.
Proof. reflexivity. Qed.

Lemma compile_test1 : compile (Const 42) = iConst 42 :: nil.
Proof. reflexivity. Qed.

Lemma compile_test2 : compile (Binop Plus (Const 2) (Const 3))
    = iConst 3 :: iConst 2 :: iBinop Plus :: nil
    .
Proof. reflexivity. Qed.

Lemma compile_test3 :
    compile (Binop Times (Binop Plus (Const 2) (Const 3)) (Const 7))
  = iConst 7 :: iConst 3 :: iConst 2 :: iBinop Plus :: iBinop Times :: nil
    .
Proof. reflexivity. Qed.

Lemma eval_test1 : eval (Const 42) = Some 42.
Proof. reflexivity. Qed.

Lemma eval_test2 : eval (Binop Plus (Const 2) (Const 3)) = Some 5.
Proof. reflexivity. Qed.

Lemma eval_test3 :
    eval (Binop Times (Binop Plus (Const 2) (Const 3)) (Const 7)) = Some 35.
Proof. reflexivity. Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path div.
Require Import fintype tuple finfun bigop prime finset.

(******************************************************************************)
(* This files contains the definition of:                                     *)
(*     n ^_ m == the falling (or lower) factorial of n with m terms, i.e.,    *)
(*               the product n * (n - 1) * ... * (n - m + 1)                  *)
(*               Note that n ^_ m = 0 if m > n.                               *)
(*   'C(n, m) == the binomial coeficient n choose m                           *)
(*            := n ^_ m %/ fact m                                             *)
(*                                                                            *)
(* In additions to the properties of these functions, triangular_sum, Wilson  *)
(* and Pascal are examples of how to manipulate expressions with bigops.      *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** More properties of the factorial **)

Lemma fact_smonotone m n : 0 < m -> m < n -> m`! < n`!.
Proof.
case: m => // m _; elim: n m => // n IHn [|m] lt_m_n.
  by rewrite -[_.+1]muln1 leq_mul ?fact_gt0.
by rewrite ltn_mul ?IHn.
Qed.

Lemma fact_prod n : n`! = \prod_(1 <= i < n.+1) i.
Proof.
elim: n => [|n IHn] //; first by rewrite big_nil.
by apply sym_equal; rewrite factS IHn // !big_add1 big_nat_recr /= mulnC.
Qed.

Lemma logn_fact p n : prime p -> logn p n`! = \sum_(1 <= k < n.+1) n %/ p ^ k.
Proof.
move=> p_prime; transitivity (\sum_(1 <= i < n.+1) logn p i).
  rewrite big_add1; elim: n => /= [|n IHn]; first by rewrite logn1 big_geq.
  by rewrite big_nat_recr -IHn /= factS mulnC lognM ?fact_gt0.
transitivity (\sum_(1 <= i < n.+1) \sum_(1 <= k < n.+1) (p ^ k %| i)).
  apply: eq_big_nat => i /andP[i_gt0 le_i_n]; rewrite logn_count_dvd //.
  rewrite -!big_mkcond (big_nat_widen _ _ n.+1) 1?ltnW //; apply: eq_bigl => k.
  by apply: andb_idr => /dvdn_leq/(leq_trans (ltn_expl _ (prime_gt1 _)))->.
by rewrite exchange_big_nat; apply: eq_bigr => i _; rewrite divn_count_dvd.
Qed.

Theorem Wilson p : p > 1 -> prime p = (p %| ((p.-1)`!).+1).
Proof.
have dFact n: 0 < n -> (n.-1)`! = \prod_(0 <= i < n | i != 0) i.
  move=> n_gt0; rewrite -big_filter fact_prod; symmetry; apply: congr_big => //.
  rewrite /index_iota subn1 -[n]prednK //=; apply/all_filterP.
  by rewrite all_predC has_pred1 mem_iota.
move=> lt1p; have p_gt0 := ltnW lt1p.
apply/idP/idP=> [pr_p | dv_pF]; last first.
  apply/primeP; split=> // d dv_dp; have: d <= p by exact: dvdn_leq.
  rewrite orbC leq_eqVlt => /orP[-> // | ltdp].
  have:= dvdn_trans dv_dp dv_pF; rewrite dFact // big_mkord.
  rewrite (bigD1 (Ordinal ltdp)) /=; last by rewrite -lt0n (dvdn_gt0 p_gt0).
  by rewrite orbC -addn1 dvdn_addr ?dvdn_mulr // dvdn1 => ->.
pose Fp1 := Ordinal lt1p; pose Fp0 := Ordinal p_gt0.
have ltp1p: p.-1 < p by [rewrite prednK]; pose Fpn1 := Ordinal ltp1p.
case eqF1n1: (Fp1 == Fpn1); first by rewrite -{1}[p]prednK -1?((1 =P p.-1) _).
have toFpP m: m %% p < p by rewrite ltn_mod.
pose toFp := Ordinal (toFpP _); pose mFp (i j : 'I_p) := toFp (i * j).
have Fp_mod (i : 'I_p) : i %% p = i by exact: modn_small.
have mFpA: associative mFp.
  by move=> i j k; apply: val_inj; rewrite /= modnMml modnMmr mulnA.
have mFpC: commutative mFp by move=> i j; apply: val_inj; rewrite /= mulnC.
have mFp1: left_id Fp1 mFp by move=> i; apply: val_inj; rewrite /= mul1n.
have mFp1r: right_id Fp1 mFp by move=> i; apply: val_inj; rewrite /= muln1.
pose mFpLaw := Monoid.Law mFpA mFp1 mFp1r.
pose mFpM := Monoid.operator (@Monoid.ComLaw _ _ mFpLaw mFpC).
pose vFp (i : 'I_p) := toFp (egcdn i p).1.
have vFpV i: i != Fp0 -> mFp (vFp i) i = Fp1.
  rewrite -val_eqE /= -lt0n => i_gt0; apply: val_inj => /=.
  rewrite modnMml; case: egcdnP => //= _ km -> _; rewrite {km}modnMDl.
  suffices: coprime i p by move/eqnP->; rewrite modn_small.
  rewrite coprime_sym prime_coprime //; apply/negP=> /(dvdn_leq i_gt0).
  by rewrite leqNgt ltn_ord.
have vFp0 i: i != Fp0 -> vFp i != Fp0.
  move/vFpV=> inv_i; apply/eqP=> vFp0.
  by have:= congr1 val inv_i; rewrite vFp0 /= mod0n.
have vFpK: {in predC1 Fp0, involutive vFp}.
  move=> i n0i; rewrite /= -[vFp _]mFp1r -(vFpV _ n0i) mFpA.
  by rewrite vFpV (vFp0, mFp1).
have le_pmFp (i : 'I_p) m: i <= p + m.
  by apply: leq_trans (ltnW _) (leq_addr _ _).
have eqFp (i j : 'I_p): (i == j) = (p %| p + i - j).
  by rewrite -eqn_mod_dvd ?(modnDl, Fp_mod).
have vFpId i: (vFp i == i :> nat) = xpred2 Fp1 Fpn1 i.
  symmetry; have [->{i} | /eqP ni0] := i =P Fp0.
    by rewrite /= -!val_eqE /= -{2}[p]prednK //= modn_small //= -(subnKC lt1p).
  rewrite 2!eqFp -Euclid_dvdM //= -[_ - p.-1]subSS prednK //.
  have lt0i: 0 < i by rewrite lt0n.
  rewrite -addnS addKn -addnBA // mulnDl -{2}(addn1 i) -subn_sqr.
  rewrite addnBA ?leq_sqr // mulnS -addnA -mulnn -mulnDl.
  rewrite -(subnK (le_pmFp (vFp i) i)) mulnDl addnCA.
  rewrite -[1 ^ 2]/(Fp1 : nat) -addnBA // dvdn_addl.
    by rewrite Euclid_dvdM // -eqFp eq_sym orbC /dvdn Fp_mod eqn0Ngt lt0i.
  by rewrite -eqn_mod_dvd // Fp_mod modnDl -(vFpV _ ni0) eqxx.
suffices [mod_fact]: toFp (p.-1)`! = Fpn1.
  by rewrite /dvdn -addn1 -modnDml mod_fact addn1 prednK // modnn.
rewrite dFact //; rewrite ((big_morph toFp) Fp1 mFpM) //; first last.
- by apply: val_inj; rewrite /= modn_small.
- by move=> i j; apply: val_inj; rewrite /= modnMm.
rewrite big_mkord (eq_bigr id) => [|i _]; last by apply: val_inj => /=.
pose ltv i := vFp i < i; rewrite (bigID ltv) -/mFpM [mFpM _ _]mFpC.
rewrite (bigD1 Fp1) -/mFpM; last by rewrite [ltv _]ltn_neqAle vFpId.
rewrite [mFpM _ _]mFp1 (bigD1 Fpn1) -?mFpA -/mFpM; last first.
  rewrite -lt0n -ltnS prednK // lt1p.
  by rewrite [ltv _]ltn_neqAle vFpId eqxx orbT eq_sym eqF1n1.
rewrite (reindex_onto vFp vFp) -/mFpM => [|i]; last by do 3!case/andP; auto.
rewrite (eq_bigl (xpredD1 ltv Fp0)) => [|i]; last first.
  rewrite andbC -!andbA -2!negb_or -vFpId orbC -leq_eqVlt.
  rewrite andbA -ltnNge; symmetry; case: (altP eqP) => [->|ni0].
    by case: eqP => // E; rewrite ?E !andbF.
  by rewrite vFpK //eqxx vFp0.
rewrite -{2}[mFp]/mFpM -[mFpM _ _]big_split -/mFpM.
by rewrite big1 ?mFp1r //= => i /andP[]; auto.
Qed.

(** The falling factorial *)

Fixpoint ffact_rec n m := if m is m'.+1 then n * ffact_rec n.-1 m' else 1.

Definition falling_factorial := nosimpl ffact_rec.

Notation "n ^_ m" := (falling_factorial n m)
  (at level 30, right associativity) : nat_scope.

Lemma ffactE : falling_factorial = ffact_rec. Proof. by []. Qed.

Lemma ffactn0 n : n ^_ 0 = 1. Proof. by []. Qed.

Lemma ffact0n m : 0 ^_ m = (m == 0). Proof. by case: m. Qed.

Lemma ffactnS n m : n ^_ m.+1 = n * n.-1 ^_ m. Proof. by []. Qed.

Lemma ffactSS n m : n.+1 ^_ m.+1 = n.+1 * n ^_ m. Proof. by []. Qed.

Lemma ffactn1 n : n ^_ 1 = n. Proof. exact: muln1. Qed.

Lemma ffactnSr n m : n ^_ m.+1 = n ^_ m * (n - m).
Proof.
elim: n m => [|n IHn] [|m] //=; first by rewrite ffactn1 mul1n.
by rewrite !ffactSS IHn mulnA.
Qed.

Lemma ffact_gt0 n m : (0 < n ^_ m) = (m <= n).
Proof. by elim: n m => [|n IHn] [|m] //=; rewrite ffactSS muln_gt0 IHn. Qed.

Lemma ffact_small n m : n < m -> n ^_ m = 0.
Proof. by rewrite ltnNge -ffact_gt0; case: posnP. Qed.

Lemma ffactnn n : n ^_ n = n`!.
Proof. by elim: n => [|n IHn] //; rewrite ffactnS IHn. Qed.

Lemma ffact_fact n m : m <= n -> n ^_ m * (n - m)`! = n`!.
Proof.
by elim: n m => [|n IHn] [|m] //= le_m_n; rewrite ?mul1n // -mulnA IHn.
Qed.

Lemma ffact_factd n m : m <= n -> n ^_ m = n`! %/ (n - m)`!.
Proof. by move/ffact_fact <-; rewrite mulnK ?fact_gt0. Qed.

(** Binomial coefficients *)

Fixpoint binomial_rec n m :=
  match n, m with
  | n'.+1, m'.+1 => binomial_rec n' m + binomial_rec n' m'
  | _, 0 => 1
  | 0, _.+1 => 0
  end.

Definition binomial := nosimpl binomial_rec.

Notation "''C' ( n , m )" := (binomial n m)
  (at level 8, format "''C' ( n ,  m )") : nat_scope.

Lemma binE : binomial = binomial_rec. Proof. by []. Qed.

Lemma bin0 n : 'C(n, 0) = 1. Proof. by case: n. Qed.

Lemma bin0n m : 'C(0, m) = (m == 0). Proof. by case: m. Qed.

Lemma binS n m : 'C(n.+1, m.+1) = 'C(n, m.+1) + 'C(n, m). Proof. by []. Qed.

Lemma bin1 n : 'C(n, 1) = n.
Proof. by elim: n => //= n IHn; rewrite binS bin0 IHn addn1. Qed.

Lemma bin_gt0 m n : (0 < 'C(m, n)) = (n <= m).
Proof.
elim: m n => [|m IHm] [|n] //.
by rewrite binS addn_gt0 !IHm orbC ltn_neqAle andKb.
Qed.

Lemma leq_bin2l m1 m2 n : m1 <= m2 -> 'C(m1, n) <= 'C(m2, n).
Proof.
elim: m1 m2 n => [m2 | m1 IHm [|m2] //] [|n] le_m12; rewrite ?bin0 //.
by rewrite !binS leq_add // IHm.
Qed.

Lemma bin_small n m : n < m -> 'C(n, m) = 0.
Proof. by rewrite ltnNge -bin_gt0; case: posnP. Qed.

Lemma binn n : 'C(n, n) = 1.
Proof. by elim: n => [|n IHn] //; rewrite binS bin_small. Qed.

Lemma mul_Sm_binm m n : m.+1 * 'C(m, n) = n.+1 * 'C(m.+1, n.+1).
Proof.
elim: m n => [|m IHm] [|n] //; first by rewrite bin0 bin1 muln1 mul1n.
by rewrite mulSn {2}binS mulnDr addnCA !IHm -mulnDr.
Qed.

Lemma bin_fact m n : n <= m -> 'C(m, n) * (n`! * (m - n)`!) = m`!.
Proof.
move/subnKC; move: (m - n) => m0 <-{m}.
elim: n => [|n IHn]; first by rewrite bin0 !mul1n.
by rewrite -mulnA mulnCA mulnA -mul_Sm_binm -mulnA IHn.
Qed.

(* In fact the only exception is n = 0 and m = 1 *)
Lemma bin_factd n m : 0 < n -> 'C(n, m)  = n`! %/ (m`! * (n - m)`!).
Proof.
move=> n_gt0; have [/bin_fact <-|lt_n_m] := leqP m n.
  by rewrite mulnK // muln_gt0 !fact_gt0.
by rewrite bin_small // divnMA !divn_small ?fact_gt0 // fact_smonotone.
Qed.

Lemma bin_ffact n m : 'C(n, m) * m`! = n ^_ m.
Proof.
apply/eqP; have [lt_n_m | le_m_n] := ltnP n m.
  by rewrite bin_small ?ffact_small.
by rewrite -(eqn_pmul2r (fact_gt0 (n - m))) ffact_fact // -mulnA bin_fact.
Qed.

Lemma bin_ffactd n m : 'C(n, m) = n ^_ m %/ m`!.
Proof. by rewrite -bin_ffact mulnK ?fact_gt0. Qed.

Lemma bin_sub n m : m <= n -> 'C(n, n - m) = 'C(n, m).
Proof.
move=> le_m_n; apply/eqP; move/eqP: (bin_fact (leq_subr m n)).
by rewrite subKn // -(bin_fact le_m_n) !mulnA mulnAC !eqn_pmul2r // fact_gt0.
Qed.

Lemma binSn n : 'C(n.+1, n) = n.+1.
Proof. by rewrite -bin_sub ?leqnSn // subSnn bin1. Qed.

Lemma bin2 n : 'C(n, 2) = (n * n.-1)./2.
Proof.
by case: n => //= n; rewrite -{3}[n]bin1 mul_Sm_binm mul2n half_double.
Qed.

Lemma bin2odd n : odd n -> 'C(n, 2) = n * n.-1./2.
Proof. by case: n => // n oddn; rewrite bin2 -!divn2 muln_divA ?dvdn2. Qed.

Lemma prime_dvd_bin k p : prime p -> 0 < k < p -> p %| 'C(p, k).
Proof.
move=> p_pr /andP[k_gt0 lt_k_p]; have def_p := ltn_predK lt_k_p.
have: p %| p * 'C(p.-1, k.-1) by rewrite dvdn_mulr.
by rewrite -def_p mul_Sm_binm def_p prednK // Euclid_dvdM // gtnNdvd.
Qed.

Lemma triangular_sum n : \sum_(0 <= i < n) i = 'C(n, 2).
Proof.
by elim: n => [|n IHn]; [rewrite big_geq | rewrite big_nat_recr IHn binS bin1].
Qed.

Lemma textbook_triangular_sum n : \sum_(0 <= i < n) i = 'C(n, 2).
Proof.
rewrite bin2; apply: canRL half_double _.
rewrite -addnn {1}big_nat_rev -big_split big_mkord /= ?add0n.
rewrite (eq_bigr (fun _ => n.-1)); first by rewrite sum_nat_const card_ord.
by case: n => [|n] [i le_i_n] //=; rewrite subSS subnK.
Qed.

Theorem Pascal a b n :
  (a + b) ^ n = \sum_(i < n.+1) 'C(n, i) * (a ^ (n - i) * b ^ i).
Proof.
elim: n => [|n IHn]; rewrite big_ord_recl muln1 ?big_ord0 //.
rewrite expnS {}IHn /= mulnDl !big_distrr /= big_ord_recl muln1 subn0.
rewrite !big_ord_recr /= !binn !subnn bin0 !subn0 !mul1n -!expnS -addnA.
congr (_ + _); rewrite addnA -big_split /=; congr (_ + _).
apply: eq_bigr => i _; rewrite mulnCA (mulnA a) -expnS subnSK //.
by rewrite (mulnC b) -2!mulnA -expnSr -mulnDl.
Qed.
Definition expnDn := Pascal.

Lemma Vandermonde k l i :
  \sum_(j < i.+1) 'C(k, j) * 'C(l, i - j) = 'C(k + l , i).
Proof.
pose f k i := \sum_(j < i.+1) 'C(k, j) * 'C(l, i - j).
suffices{k i} fxx k i: f k.+1 i.+1 = f k i.+1 + f k i.
  elim: k i => [i | k IHk [|i]]; last by rewrite -/(f _ _) fxx /f !IHk -binS.
    by rewrite big_ord_recl big1_eq addn0 mul1n subn0.
  by rewrite big_ord_recl big_ord0 addn0 !bin0 muln1.
rewrite {}/f big_ord_recl (big_ord_recl (i.+1)) !bin0 !mul1n.
rewrite -addnA -big_split /=; congr (_ + _).
by apply: eq_bigr => j _ ; rewrite -mulnDl.
Qed.

Lemma subn_exp m n k :
  m ^ k - n ^ k = (m - n) * (\sum_(i < k) m ^ (k.-1 -i) * n ^ i).
Proof.
case: k => [|k]; first by rewrite big_ord0.
rewrite mulnBl !big_distrr big_ord_recl big_ord_recr /= subn0 muln1.
rewrite subnn mul1n -!expnS subnDA; congr (_ - _).
set F := fun _ => n * _; rewrite (eq_bigr F) ?addnK {}/F // => i _.
by rewrite (mulnCA n) -expnS mulnA -expnS subnSK.
Qed.

Lemma predn_exp m k : (m ^ k).-1 = m.-1 * (\sum_(i < k) m ^ i).
Proof.
rewrite -!subn1 -{1}(exp1n k) subn_exp; congr (_ * _).
symmetry; rewrite (reindex_inj rev_ord_inj); apply: eq_bigr => i _ /=.
by rewrite -subn1 -subnDA exp1n muln1.
Qed.

Lemma dvdn_pred_predX n e : (n.-1 %| (n ^ e).-1)%N.
Proof. by rewrite predn_exp dvdn_mulr. Qed.

Lemma modn_summ I r (P : pred I) F d :
  \sum_(i <- r | P i) F i %% d = \sum_(i <- r | P i) F i %[mod d].
Proof.
by apply/eqP; elim/big_rec2: _ => // i m n _; rewrite modnDml eqn_modDl.
Qed.

(* Combinatorial characterizations. *)

Section Combinations.

Implicit Types T D : finType.

Lemma card_uniq_tuples T n (A : pred T) :
  #|[set t : n.-tuple T | all A t & uniq t]| = #|A| ^_ n.
Proof.
elim: n A => [|n IHn] A.
  by rewrite (@eq_card1 _ [tuple]) // => t; rewrite [t]tuple0 inE.
rewrite -sum1dep_card (partition_big (@thead _ _) A) /= => [|t]; last first.
  by case/tupleP: t => x t; do 2!case/andP.
transitivity (#|A| * #|A|.-1 ^_ n)%N; last by case: #|A|.
rewrite -sum_nat_const; apply: eq_bigr => x Ax.
rewrite (cardD1 x) [x \in A]Ax /= -(IHn [predD1 A & x]) -sum1dep_card.
rewrite (reindex (fun t : n.-tuple T => [tuple of x :: t])) /=; last first.
  pose ttail (t : n.+1.-tuple T) := [tuple of behead t].
  exists ttail => [t _ | t /andP[_ /eqP <-]]; first exact: val_inj.
  by rewrite -tuple_eta.
apply: eq_bigl=> t; rewrite Ax theadE eqxx andbT /= andbA; congr (_ && _).
by rewrite all_predI all_predC has_pred1 andbC.
Qed.

Lemma card_inj_ffuns_on D T (R : pred T) :
  #|[set f : {ffun D -> T} in ffun_on R | injectiveb f]| = #|R| ^_ #|D|.
Proof.
rewrite -card_uniq_tuples.
have bijFF: {on (_ : pred _), bijective (@Finfun D T)}.
  by exists val => // x _; exact: val_inj.
rewrite -(on_card_preimset (bijFF _)); apply: eq_card => t.
rewrite !inE -(codom_ffun (Finfun t)); congr (_ && _); apply: negb_inj.
by rewrite -has_predC has_map enumT has_filter -size_eq0 -cardE.
Qed.

Lemma card_inj_ffuns D T :
  #|[set f : {ffun D -> T} | injectiveb f]| = #|T| ^_ #|D|.
Proof.
rewrite -card_inj_ffuns_on; apply: eq_card => f.
by rewrite 2!inE; case: ffun_onP => // [].
Qed.

Lemma card_draws T k : #|[set A : {set T} | #|A| == k]| = 'C(#|T|, k).
Proof.
have [ltTk | lekT] := ltnP #|T| k.
  rewrite bin_small // eq_card0 // => A.
  by rewrite inE eqn_leq andbC leqNgt (leq_ltn_trans (max_card _)).
apply/eqP; rewrite -(eqn_pmul2r (fact_gt0 k)) bin_ffact // eq_sym.
rewrite -sum_nat_dep_const -{1 3}(card_ord k) -card_inj_ffuns -sum1dep_card.
pose imIk (f : {ffun 'I_k -> T}) := f @: 'I_k.
rewrite (partition_big imIk (fun A => #|A| == k)) /= => [|f]; last first.
  by move/injectiveP=> inj_f; rewrite card_imset ?card_ord.
apply/eqP; apply: eq_bigr => A /eqP cardAk.
have [f0 inj_f0 im_f0]: exists2 f, injective f & f @: 'I_k = A.
  rewrite -cardAk; exists enum_val; first exact: enum_val_inj.
  apply/setP=> a; apply/imsetP/idP=> [[i _ ->] | Aa]; first exact: enum_valP.
  by exists (enum_rank_in Aa a); rewrite ?enum_rankK_in.
rewrite (reindex (fun p : {ffun _} => [ffun i => f0 (p i)])) /=; last first.
  pose ff0' f i := odflt i [pick j | f i == f0 j].
  exists (fun f => [ffun i => ff0' f i]) => [p _ | f].
    apply/ffunP=> i; rewrite ffunE /ff0'; case: pickP => [j | /(_ (p i))].
      by rewrite ffunE (inj_eq inj_f0) => /eqP.
    by rewrite ffunE eqxx.
  rewrite -im_f0 => /andP[/injectiveP injf /eqP im_f].
  apply/ffunP=> i; rewrite !ffunE /ff0'; case: pickP => [y /eqP //|].
  have /imsetP[j _ eq_f0j_fi]: f i \in f0 @: 'I_k by rewrite -im_f mem_imset.
  by move/(_ j)=> /eqP[].
rewrite -ffactnn -card_inj_ffuns -sum1dep_card; apply: eq_bigl => p.
apply/andP/injectiveP=> [[/injectiveP inj_f0p _] i j eq_pij | inj_p].
  by apply: inj_f0p; rewrite !ffunE eq_pij.
set f := finfun _.
have injf: injective f by move=> i j; rewrite !ffunE => /inj_f0; exact: inj_p.
split; first exact/injectiveP.
rewrite eqEcard card_imset // cardAk card_ord leqnn andbT -im_f0.
by apply/subsetP=> x /imsetP[i _ ->]; rewrite ffunE mem_imset.
Qed.

Lemma card_ltn_sorted_tuples m n :
  #|[set t : m.-tuple 'I_n | sorted ltn (map val t)]| = 'C(n, m).
Proof.
have [-> | n_gt0] := posnP n; last pose i0 := Ordinal n_gt0.
  case: m => [|m]; last by apply: eq_card0; case/tupleP=> [[]].
  by apply: (@eq_card1 _ [tuple]) => t; rewrite [t]tuple0 inE.
rewrite -{12}[n]card_ord -card_draws.
pose f_t (t : m.-tuple 'I_n) := [set i in t].
pose f_A (A : {set 'I_n}) := [tuple of mkseq (nth i0 (enum A)) m].
have val_fA (A : {set 'I_n}) : #|A| = m -> val (f_A A) = enum A.
  by move=> Am; rewrite -[enum _](mkseq_nth i0) -cardE Am.
have inc_A (A : {set 'I_n}) : sorted ltn (map val (enum A)).
  rewrite -[enum _](eq_filter (mem_enum _)).
  rewrite -(eq_filter (mem_map val_inj _)) -filter_map.
  by rewrite (sorted_filter ltn_trans) // unlock val_ord_enum iota_ltn_sorted.
rewrite -!sum1dep_card (reindex_onto f_t f_A) /= => [|A]; last first.
  by move/eqP=> cardAm; apply/setP=> x; rewrite inE -(mem_enum (mem A)) -val_fA.
apply: eq_bigl => t; apply/idP/idP=> [inc_t|]; last first.
  by case/andP; move/eqP=> t_m; move/eqP=> <-; rewrite val_fA.
have ft_m: #|f_t t| = m.
  rewrite cardsE (card_uniqP _) ?size_tuple // -(map_inj_uniq val_inj).
  exact: (sorted_uniq ltn_trans ltnn).
rewrite ft_m eqxx -val_eqE val_fA // -(inj_eq (inj_map val_inj)) /=.
apply/eqP; apply: (eq_sorted_irr ltn_trans ltnn) => // y.
by apply/mapP/mapP=> [] [x t_x ->]; exists x; rewrite // mem_enum inE in t_x *.
Qed.

Lemma card_sorted_tuples m n :
  #|[set t : m.-tuple 'I_n.+1 | sorted leq (map val t)]| = 'C(m + n, m).
Proof.
set In1 := 'I_n.+1; pose x0 : In1 := ord0.
have add_mnP (i : 'I_m) (x : In1) : i + x < m + n.
  by rewrite -ltnS -addSn -!addnS leq_add.
pose add_mn t i := Ordinal (add_mnP i (tnth t i)).
pose add_mn_nat (t : m.-tuple In1) i := i + nth x0 t i.
have add_mnC t: val \o add_mn t =1 add_mn_nat t \o val.
  by move=> i; rewrite /= (tnth_nth x0).
pose f_add t := [tuple of map (add_mn t) (ord_tuple m)].
rewrite -card_ltn_sorted_tuples -!sum1dep_card (reindex f_add) /=.
  apply: eq_bigl => t; rewrite -map_comp (eq_map (add_mnC t)) map_comp.
  rewrite enumT unlock val_ord_enum -{1}(drop0 t).
  have [m0 | m_gt0] := posnP m.
    by rewrite {2}m0 /= drop_oversize // size_tuple m0.
  have def_m := subnK m_gt0; rewrite -{2}def_m addn1 /= {1}/add_mn_nat.
  move: 0 (m - 1) def_m => i k; rewrite -{1}(size_tuple t) => def_m.
  rewrite (drop_nth x0) /=; last by rewrite -def_m leq_addl.
  elim: k i (nth x0 t i) def_m => [|k IHk] i x /=.
    by rewrite add0n => ->; rewrite drop_size.
  rewrite addSnnS => def_m; rewrite -addSn leq_add2l -IHk //.
  by rewrite (drop_nth x0) // -def_m leq_addl.
pose sub_mn (t : m.-tuple 'I_(m + n)) i : In1 := inord (tnth t i - i).
exists (fun t => [tuple of map (sub_mn t) (ord_tuple m)]) => [t _ | t].
  apply: eq_from_tnth => i; apply: val_inj.
  by rewrite /sub_mn !(tnth_ord_tuple, tnth_map) addKn inord_val.
rewrite inE /= => inc_t; apply: eq_from_tnth => i; apply: val_inj.
rewrite tnth_map tnth_ord_tuple /= tnth_map tnth_ord_tuple.
suffices [le_i_ti le_ti_ni]: i <= tnth t i /\ tnth t i <= i + n.
  by rewrite /sub_mn inordK ?subnKC // ltnS leq_subLR.
pose y0 := tnth t i; rewrite (tnth_nth y0) -(nth_map _ (val i)) ?size_tuple //.
case def_e: (map _ _) => [|x e] /=; first by rewrite nth_nil ?leq_addr.
rewrite def_e in inc_t; split.
  case: {-2}i; rewrite /= -{1}(size_tuple t) -(size_map val) def_e.
  elim=> //= j IHj lt_j_t; apply: leq_trans (pathP (val i) inc_t _ lt_j_t).
  by rewrite ltnS IHj 1?ltnW.
move: (_ - _) (subnK (valP i)) => k /=.
elim: k {-2}(val i) => /= [|k IHk] j def_m; rewrite -ltnS -addSn.
  by rewrite [j.+1]def_m -def_e (nth_map y0) ?ltn_ord // size_tuple -def_m.
rewrite (leq_trans _ (IHk _ _)) -1?addSnnS //; apply: (pathP _ inc_t).
rewrite -ltnS (leq_trans (leq_addl k _)) // -addSnnS def_m.
by rewrite -(size_tuple t) -(size_map val) def_e.
Qed.

Lemma card_partial_ord_partitions m n :
  #|[set t : m.-tuple 'I_n.+1 | \sum_(i <- t) i <= n]| = 'C(m + n, m).
Proof.
symmetry; set In1 := 'I_n.+1; pose x0 : In1 := ord0.
pose add_mn (i j : In1) : In1 := inord (i + j).
pose f_add (t : m.-tuple In1) := [tuple of scanl add_mn x0 t].
rewrite -card_sorted_tuples -!sum1dep_card (reindex f_add) /=.
  apply: eq_bigl => t; rewrite -[\sum_(i <- t) i]add0n.
  transitivity (path leq x0 (map val (f_add t))) => /=; first by case: map.
  rewrite -{1 2}[0]/(val x0); elim: {t}(val t) (x0) => /= [|x t IHt] s.
    by rewrite big_nil addn0 -ltnS ltn_ord.
  rewrite big_cons addnA IHt /= val_insubd ltnS.
  have [_ | ltn_n_sx] := leqP (s + x) n; first by rewrite leq_addr.
  rewrite -(leq_add2r x) leqNgt (leq_trans (valP x)) //=.
  by rewrite leqNgt (leq_trans ltn_n_sx) ?leq_addr.
pose sub_mn (i j : In1) := Ordinal (leq_ltn_trans (leq_subr i j) (valP j)).
exists (fun t : m.-tuple In1 => [tuple of pairmap sub_mn x0 t]) => /= t inc_t.
  apply: val_inj => /=; have{inc_t}: path leq x0 (map val (f_add t)).
    by move: inc_t; rewrite inE /=; case: map.
  rewrite [map _ _]/=; elim: {t}(val t) (x0) => //= x t IHt s.
  case/andP=> le_s_sx /IHt->; congr (_ :: _); apply: val_inj => /=.
  move: le_s_sx; rewrite val_insubd.
  case le_sx_n: (_ < n.+1); first by rewrite addKn.
  by case: (val s) le_sx_n; rewrite ?ltn_ord.
apply: val_inj => /=; have{inc_t}: path leq x0 (map val t).
  by move: inc_t; rewrite inE /=; case: map.
elim: {t}(val t) (x0) => //= x t IHt s /andP[le_s_sx inc_t].
suffices ->: add_mn s (sub_mn s x) = x by rewrite IHt.
by apply: val_inj; rewrite /add_mn /= subnKC ?inord_val.
Qed.

Lemma card_ord_partitions m n :
  #|[set t : m.+1.-tuple 'I_n.+1 | \sum_(i <- t) i == n]| = 'C(m + n, m).
Proof.
symmetry; set In1 := 'I_n.+1; pose x0 : In1 := ord0.
pose f_add (t : m.-tuple In1) := [tuple of sub_ord (\sum_(x <- t) x) :: t].
rewrite -card_partial_ord_partitions -!sum1dep_card (reindex f_add) /=.
  by apply: eq_bigl => t; rewrite big_cons /= addnC (sameP maxn_idPr eqP) maxnE.
exists (fun t : m.+1.-tuple In1 => [tuple of behead t]) => [t _|].
  exact: val_inj.
case/tupleP=> x t; rewrite inE /= big_cons => /eqP def_n.
by apply: val_inj; congr (_ :: _); apply: val_inj; rewrite /= -{1}def_n addnK.
Qed.

End Combinations.


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

- Solange Coupet-Grimal and William Delobel, 2006-01-09
- Adam Koprowski, 2007-06-01 added Decidability section

Definition and properties of lexicographic order on lists of elements
of a setoid. In particular, proofs that lex 'transmits' strict partial
order property, and is a lifting.
*)

From CoLoR Require Import RelExtras ListUtil AccUtil LogicUtil.
From Coq Require Peano_dec.

Module LexOrder (ES : Eqset).

  Section Lex.

    Variable r : relation ES.A.

    Inductive lex : relation (list ES.A) :=
      | lex1 : forall h h' (l l' : list ES.A),
	r h h' -> length l = length l' -> lex (h::l) (h'::l')
      | lex2 : forall (h : ES.A) (l l' : list ES.A),
	lex l l' -> lex (h::l) (h::l').

    Lemma lex_length : forall ss ts : list ES.A,
      lex ss ts -> length ss = length ts.

    Proof.
      induction ss as [ | s ss IHss]; intros ts Hlex.
      inversion Hlex; trivial.
      destruct ts as [ | t ts]; inversion Hlex; subst.
      simpl; auto with arith.
      simpl; gen (IHss ts H0); auto with arith.
    Qed.

    Lemma SPO_to_lex_SPO : forall (ss : list ES.A),
      (forall s, In s ss ->
        (forall t u, r s t -> r t u -> r s u) /\ (r s s -> False)) ->
      (forall ts us : list ES.A, lex ss ts -> lex ts us -> lex ss us)
      /\ (lex ss ss -> False).

    Proof.
      induction ss as [ | s ss IHss]; intro Hss; split.
      intros ts us Hss_ts Hts_us; inversion Hss_ts; subst; trivial.
      intro H; inversion H.
      intros ts us Hss_ts Hts_us.
      assert (Hs : In s (s::ss)).
      left; trivial.
      elim (Hss s Hs); intros Hss' Hss''.
      destruct ts as [ | t ts]; inversion Hss_ts; subst.
      destruct us as [ | u us]; inversion Hts_us; subst.
      constructor 1.
      apply Hss' with t; try left; trivial.
      rewrite H4; trivial.
      constructor 1; trivial.
      rewrite H4; apply lex_length; trivial.
      destruct us as [ | u us]; inversion Hts_us; subst.
      constructor 1; trivial.
      rewrite <- H5; apply lex_length; trivial.
      constructor 2.
      elim IHss.
      intros H2 H3; apply (H2 ts); trivial.
      intros s s_in_ss; split.
      elim (Hss s); try right; trivial.
      elim (Hss s); try right; trivial.
      intro H; inversion H; subst.
      elim (Hss s); try left; trivial; intros H1 H2.
      apply H2; hyp.
      elim IHss.
      intros H2 H3; apply H3; trivial.
      intros s' s'_in_ss; apply (Hss s'); try right; trivial.
    Qed.

    Lemma irrefl_to_lex_irrefl : forall (ss : list ES.A),
      (forall s, In s ss -> r s s -> False) -> lex ss ss -> False.

    Proof.
      intro ss; induction ss as [ | h ss IHss]; intros Hss Hlex;
        inversion Hlex; subst.
      apply Hss with h; try left; trivial.
      apply IHss; trivial.
      intros s s_in_ss; apply Hss; try right; trivial.
    Qed.

    Lemma lex_lifting_aux : forall n (l : list ES.A),
      length l = n -> Accs r l -> Restricted_acc (Accs r) lex l.

    Proof.
      intro n; induction n as [ | n IHn]; intros l Hl HAccs.
      destruct l; [constructor | inversion Hl].
      intros l' Hl' Hlex; inversion Hlex.
      destruct l as [ | h l]; [inversion Hl | idtac].
      assert (acc_h : Acc r h).
      apply HAccs; left; trivial.
      assert (Accs_l : forall (a : ES.A), In a l -> Acc r a).
      intros s s_in_l; apply HAccs; right; trivial.
      assert (Hl2 : length l = n).
      inversion Hl; trivial.
      gen (IHn l Hl2 Accs_l).
      clear Hl HAccs.
      generalize dependent l.
      induction acc_h as [h acc_h IHh].
      intros l Accs_l Hl Hacc.
      induction Hacc as [l Hacc IHl].
      constructor.
      intros l' Hl' Hlex.
      destruct l' as [ | h' l'].
      inversion Hlex.
      assert (Accs_l' : forall (a : ES.A), In a l' -> Acc r a).
      intros t Ht; apply Hl'; right; trivial.
      clear Hl'.
      inversion Hlex; subst.
      apply IHh; trivial.
      apply IHn; trivial.
      apply IHl; trivial.
      cut (length (h :: l') = length ( h :: l)).
      simpl; auto with arith.
      gen Hlex; apply lex_length.
    Qed.

    Section Lex_and_one_less.

      Lemma one_less2lex : forall l l', one_less r l l' -> lex l l'.

      Proof.
        intros l l' H1; inversion H1; subst.
        generalize dependent l; induction p as [ | p]; intros l Hl H1.
        destruct l as [|h l]; inversion H1.
        subst; simpl; constructor; trivial.
        destruct l as [|h l]; inversion H1.
        subst; simpl; constructor 2; trivial.
        apply IHp; trivial.
        apply (@one_less_cons _ r l (l [p := a']) p a a'); trivial.
      Qed.

    End Lex_and_one_less.

  End Lex.

  Lemma lex_lifting : forall (r : relation ES.A) (l : list ES.A),
    Accs r l -> Restricted_acc (Accs r) (lex r) l.

  Proof.
    intros r l; apply (lex_lifting_aux r (length l) l); trivial.
  Qed.

  Section Decidability.

    Import Peano_dec.

    Variable eqA_dec : forall a b : ES.A, {a = b} + {~a = b}.

    Lemma lex_dec : forall R l l',
      (forall a b, In a l -> In b l' -> {R a b} + {~R a b}) ->
      {lex R l l'} + {~lex R l l'}.

    Proof.
      induction l; intros.
      right. intro nil_l. inversion nil_l.
      revert X; destruct l'; intro.
      right. intro al_nil. inversion al_nil.
      destruct (X a a0); auto with datatypes.
      destruct (eq_nat_dec (length l) (length l')).
      left. constructor; trivial.
      right. intro al_nil. inversion al_nil; intuition.
      apply n. apply lex_length with R. hyp.
      destruct (eqA_dec a a0).
      rewrite e. destruct (IHl l'). intuition.
      left. constructor 2. hyp.
      right. intro ll'. inversion ll'; intuition.
      apply n. congruence.
      right. intro ll'. inversion ll'; intuition.
    Defined.

  End Decidability.

  Section Homomorphism.

    Variable R : relation ES.A.
    Variable f : ES.A -> ES.A.

    Lemma lex_homomorphic : forall l l',
      (forall x x', In x l -> In x' l' -> R x x' -> R (f x) (f x')) ->
      lex R l l' -> lex R (map f l) (map f l').

    Proof.
      induction l; intros.
      inversion H0.
      destruct l'. inversion H0.
      simpl. inversion H0.
      constructor 1. apply H; auto with datatypes.
      do 2 rewrite map_length. hyp.
      constructor 2. apply IHl.
      intros. apply H; intuition. hyp.
    Qed.

  End Homomorphism.

End LexOrder.


Require Import Coq.Init.Prelude.

Fixpoint fnd (n : nat) : Prop :=
  match n with
  | O => True
  | S n => True /\ fnd n
  end.

Fixpoint big_and (xs : list Prop) : Prop :=
  match xs with
  | nil => True
  | cons x xs => and x (big_and xs)
  end.
Fixpoint typeof_big_conj (xs : list Prop) (P : Prop) : Prop :=
  match xs with
  | nil => P
  | cons x xs => x -> typeof_big_conj xs P
  end.
Lemma apply_rconj_and xs (P Q : Prop) : P -> typeof_big_conj xs Q -> typeof_big_conj xs (P /\ Q).
Proof. revert Q; revert P; induction xs; intros; cbn in *; eauto. Qed.
Lemma big_conj xs : typeof_big_conj xs (big_and xs).
Proof. induction xs. exact I. cbn. intros. apply apply_rconj_and; eauto. Qed.

Require Import Coq.Lists.List.

Goal fnd 1000.
  Time
  let n := match goal with |- fnd ?n => n end in
  let ls := eval cbv in (repeat True n) in
  let pf := constr:(big_conj ls) in
  let T := type of pf in
  let T := eval cbv [typeof_big_conj big_and] in T in
  pose proof (pf : T) as H; apply H; exact I.
Time Qed.
(*
Finished transaction in 0.207 secs (0.207u,0.s) (successful)
Finished transaction in 0.047 secs (0.047u,0.s) (successful)
*)


Require Import HoTT.
From GR.bicategories Require Import
     bicategory.bicategory_laws
     lax_functor.lax_functor
     lax_transformation.lax_transformation
     lax_transformation.examples.identity
     lax_transformation.examples.composition
     modification.modification.

Section RightIdentity.
  Context `{Univalence}
          {C D : BiCategory}
          {F₁ F₂ : LaxFunctor C D}.
  Variable (η : LaxTransformation F₁ F₂).

  Local Notation right_identity_mod_d
    := (fun (A : C) => right_unit (η A) : compose (identity_transformation F₁) η A ==> η A).

  Definition right_identity_is_mod : is_modification right_identity_mod_d.
  Proof.
    intros A B f ; cbn in *.
    unfold bc_whisker_l, bc_whisker_r.
    rewrite !vcomp_assoc.
    rewrite <- (vcomp_left_identity (id₂ (η B))).
    rewrite interchange.
    rewrite !vcomp_assoc.
    rewrite triangle_r.
    rewrite !vcomp_assoc.
    rewrite (ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
    rewrite assoc_left.
    rewrite vcomp_left_identity.
    rewrite <- !vcomp_assoc.
    rewrite <- interchange.
    rewrite left_unit_left.
    rewrite vcomp_left_identity.
    rewrite hcomp_id₂.
    rewrite vcomp_left_identity.
    pose @right_unit_assoc as p.
    unfold bc_whisker_l in p.
    rewrite <- p ; clear p.
    rewrite right_unit_natural.
    rewrite vcomp_assoc.
    rewrite right_unit_assoc.
    unfold bc_whisker_r.
    rewrite !vcomp_assoc.
    rewrite assoc_left.
    rewrite vcomp_right_identity.
    reflexivity.
  Qed.

  Definition right_identity_modification
    : Modification (compose (identity_transformation F₁) η) η
    := Build_Modification right_identity_mod_d right_identity_is_mod.

  Definition right_identity_modification_iso
    : iso_modification right_identity_modification.
  Proof.
    intros X ; cbn.
    apply _.
  Qed.

  Definition right_identity_mod
    : IsoModification (composition.compose (identity_transformation F₁) η) η.
  Proof.
    make_iso_modification.
    - exact right_identity_modification.
    - exact right_identity_modification_iso.
  Defined.
End RightIdentity.


Require Import List.
Import ListNotations.

Inductive reg_exp {T: Type} : Type :=
    | EmptySet
    | EmptyStr
    | Char (t: T)
    | App (r1 r2: reg_exp)
    | Union (r1 r2: reg_exp)
    | Star (r: reg_exp).

Inductive exp_match {T}: list T -> reg_exp -> Prop :=
    | MEmpty: exp_match [] EmptySet
    | MChar x: exp_match [x] (Char x)
    | MApp s1 re1 s2 re2
        (H1: exp_match s1 re1) (H2: exp_match s2 re2):
        exp_match (s1 ++ s2) (App re1 re2)
    | MUnionL s1 re1 re2 (H1: exp_match s1 re1):
        exp_match s1 (Union re1 re2)
    | MUnionR re1 s2 re2 (H1: exp_match s2 re2):
        exp_match s2 (Union re1 re2)
    | MStar0 re: exp_match [] (Star re)
    | MStarApp s1 s2 re
        (H1: exp_match s1 re) (H2: exp_match s2 (Star re)):
        exp_match (s1 ++ s2) (Star re).

Notation "s =~ re" := (exp_match s re) (at level 80).

Example regex2: [1; 2] =~ App (Char 1) (Char 2).
Proof.
    apply (MApp [1] _ [2]).
    - apply MChar.
    - apply MChar.
Qed.

Fixpoint reg_exp_of_list {T} (l: list T) :=
    match l with
    | [] => EmptyStr
    | x::xs => App (Char x) (reg_exp_of_list xs)
    end.

Lemma empty_is_empty: forall T (s: list T),
    ~ (s =~ EmptySet).
Proof.
    intros T s H.
    inversion H.
Abort.
(* Qed. *)

Lemma MUnion': forall T (s: list T) (re1 re2: @reg_exp T),
    s =~ re1 \/ s =~ re2 ->
    s =~ Union re1 re2.
Proof.
    intros.
    destruct H as [P | Q].
    - apply (MUnionL s re1 re2) in P.
      apply P.
    - apply (MUnionR re1 s re2) in Q.
      apply Q.
Qed.

Fixpoint re_chars {T} (re: reg_exp) : list T :=
    match re with
    | EmptySet => []
    | EmptyStr => []
    | Char x => [x]
    | App re1 re2 => re_chars re1 ++ re_chars re2
    | Union re1 re2 => re_chars re1 ++ re_chars re2
    | Star re => re_chars re
    end.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Theorem drop_Nil: forall (x: natural), drop x Nil = Nil.
Proof.
  induction x ; simpl; reflexivity.
Qed.

Theorem drop_Cons: forall (x n: natural) (l: lst), drop (Succ x) (Cons n l) = drop x l.
  induction l; induction x; simpl; reflexivity.
Qed.

Theorem drop_Cons_assoc: forall (x1 x2 x3: natural) (l: lst),
    drop x1 (drop x2 (Cons x3 l)) = drop x2 (drop x1 (Cons x3 l)).
Proof.
  induction x1; induction x2; try (simpl; reflexivity).
  + induction l.
    * rewrite 2 drop_Cons. rewrite <- IHx1.
      rewrite IHx2. rewrite 2 drop_Cons.
      induction l.
      - rewrite IHx1. reflexivity.
      - rewrite 3 drop_Nil. reflexivity.
    * simpl. rewrite 2 drop_Nil. reflexivity.
  + intros. simpl. destruct (drop x1 l); reflexivity.
  + intros. simpl. destruct (drop x2 l); reflexivity.
Qed.

Theorem drop_assoc : forall (x : natural) (y : natural) (z : lst), eq (drop x (drop y z)) (drop y (drop x z)).
Proof.
  induction z.
lfind.  reflexivity.
Admitted.

Theorem theorem0 : forall (x : natural) (y : natural) (w : natural) (z : lst), eq (drop w (drop x (drop y z))) (drop y (drop x (drop w z))).
Proof.
  intros.
  rewrite (drop_assoc w x).
  rewrite (drop_assoc w y).
  rewrite (drop_assoc x y).
  reflexivity.
Qed.