(***********************************************************)
(*      This file contains a direct implementation with no *)
(*      optimisation of Fourier-Mozkin algorithm. We use   *)
(*      it to show that a system is unsolvable             *)
(***********************************************************)

Require Import ZArith Znumtheory List.
Require Import FourierConcTerm.

(***********************************************************)
(* We first describe the algorithm then its partial        *)
(* correctness proof                                       *)
(***********************************************************)

(***********************************************************)
(* The implementation is naive. The set of inequations is  *)
(* as a matrices (i.e a list of list of integers), the     *)
(* constant part of the equation is separated in order to  *)
(* make variable elimination only for the variables part   *)
(* A sparse representation should be more sensible but     *)
(* anyway Fourier is not a good choice for large problems  *)
(*                                                         *)
(* A line of the inequation contains the list of the       *)
(* coefficients of the variable and a constant.            *)
(* For example                                             *)
(* 3x + z >= 4 is encoded as line (3::0::1::nil) -4 lLe    *)
(*  x + y >  2 is encoded as line (1::1::0::nil) -2 lLt    *)
(*  x = y      is encoded as line (1::-1::0::nil) 0 lEq    *)
(***********************************************************)
Inductive ltype : Type := lEq | lLt | lLe.
Inductive line : Type := Line (_: list Z) (_: Z) (_:ltype).

(* A system is a list of line *)
Definition dt := list line.

(* An example
      3x + y - z >= 0
      2x     + z >= 2
      -x + y + z >= 0
*)
Definition ex1 :=    Line (3::1::-1::nil)%Z 0 lLe::
                     Line (2::0::1::nil)%Z (-2) lLe ::
                     Line (-1::1::1::nil)%Z 0 lLe ::nil.

(* How line types combine *)

Definition lmerge t1 t2 :=
  match t1 with
    lEq => t2
  | lLt => t1
  | lLe => match t2 with lLt => t2 | _ => t1 end
  end.

(* Some check *)
Lemma lmerge_id: forall t, lmerge t t = t.
Proof. intro t; destruct t; auto. Qed.

Lemma lmerge_sym: forall t1 t2, lmerge t1 t2 = lmerge t2 t1.
Proof. intros t1 t2; destruct t1; destruct t2; auto. Qed.

(***********************************************************)
(*  Splitting the system in 3 depending of the top coef    *)
(*    the positive part, the negative one, the zero one    *)
(***********************************************************)

(* The split datastructure *)
Inductive op_eq : Type :=
  | Some_eq (_: positive) (_: list Z) (_: Z)
  | No_eq.

Inductive dt4 :Type := DT4 (_: op_eq) (_ _ _: dt).
(* Empty split *)
Definition nil_dt4 := DT4 No_eq nil nil nil.

(* Add an element in the zero part *)
Definition add4z l (v: dt4) : dt4 :=
  let (e,lp,ln,lz) := v in DT4 e lp ln (l::lz).
(* Add an element in the positive part *)
Definition add4p l (v: dt4) : dt4 :=
  let (e,lp,ln,lz) := v in DT4  e (l::lp) ln lz.
(* Add an element in the negative part *)
Definition add4n l (v: dt4) : dt4 :=
  let (e,lp,ln,lz) := v in DT4  e lp (l::ln) lz.
(* Add an element in the equation part *)
Definition add4e p l c (v: dt4) : dt4 :=
  let (e,lp,ln,lz) := v in
  match e with
    No_eq => DT4 (Some_eq p l c) lp ln lz
  | Some_eq p1 l1 c1 =>
     match (p ?= p1)%positive with
       Lt => DT4 (Some_eq p l c) (Line (Zpos p1::l1) c1 lEq::lp) ln lz
    |  _  => DT4 e (Line (Zpos p::l) c lEq::lp) ln lz
    end
  end.

Fixpoint oppsm (l: list Z): list Z :=
  match l with nil => nil | v :: l1 => -v :: oppsm l1 end.

(* Splitting in a tail recursive way *)
Fixpoint split_aux (v: dt) (r: dt4) {struct v}: dt4 :=
  match v with
    nil => r
  | Line nil _ _ as l::v1 => split_aux v1 r
  | Line (0%Z::l1) c t as l::v1 =>
      split_aux v1 (add4z (Line l1 c t) r)
  | Line (Zpos p::l1) c1 lEq :: v1 =>
      split_aux v1 (add4e p l1 c1 r)
  | Line (Zneg p::l1) c1 lEq :: v1 =>
      split_aux v1 (add4e p (oppsm l1) (-c1) r)
  | Line (Zpos _::_) _ _  as l ::v1 =>
      split_aux v1 (add4p l r)
  | Line (Zneg x::l1) c e as l ::v1 =>
      split_aux v1 (add4n (Line (Zpos x :: l1) c e) r)
  end.

Definition split v := split_aux v nil_dt4.

(*
Eval vm_compute in split ex1.
*)

(***********************************************************)
(*  Adding the product of the positive and negative parts  *)
(*  to the zero part removing the top variable             *)
(***********************************************************)

Fixpoint mapsm (v: Z) (l: list Z) {struct l}: list Z :=
  match l with nil => nil | v1 :: l1 => (v * v1) :: mapsm v l1 end.

Fixpoint merge (v1 v2: Z) (l1 l2: list Z) {struct l1}: list Z :=
  match l1 with
    nil => mapsm v2 l2
  | v3:: l3 => match l2 with
                 nil => mapsm v1 l1
               | v4:: l4 => (v1*v3 + v2*v4) :: merge v1 v2 l3 l4
               end
  end.

Fixpoint app_one (v c: Z) (op: ltype) (l: list Z) (l1: dt) (r: dt)
     {struct l1} :=
  match l1 with
    nil => r
  | (Line nil _  _  as a)::l2 => app_one v c op l l2 (a :: r)
  | (Line (v1::ll2) c1 op1)::l2 =>
        let v2 := Z.gcd v v1 in
        let k1 := v1/v2 in
        let k2 := v/v2 in
           app_one v c op l l2
              (Line (merge k1 k2 l ll2) (k1 * c + k2 * c1)
                        (lmerge op op1) :: r)
  end.

Fixpoint product (l1 l2: dt) (r: dt) {struct l1} : dt :=
  match l1 with
    nil => r
  | (Line (v::l) c lLt)::l3 => product l3 l2 (app_one v c lLt l l2 r)
  | (Line (v::l) c lLe)::l3 => product l3 l2 (app_one v c lLe l l2 r)
  | _ ::l3 => product l3 l2 r
  end.

(***********************************************************)
(*  Refuting by eliminating variables one by one           *)
(***********************************************************)

(* elim one variable *)
Definition elim_one v : dt :=
  match split v with
    DT4 No_eq x y z => product x y z
  | DT4 (Some_eq p l c) x y z =>
     app_one (Zpos p) (-c) lEq (oppsm l) x
       (app_one (Zpos p) c lEq l y z)
  end.

(* a system is unsolvable if there one constant negative element *)
Fixpoint unsolvable d :=
  match d with
    nil => false
  | Line nil (Zneg _) lLe::_ => true
  | Line nil (0%Z) lLt::_ => true
  | Line nil (Zneg _) lLt::_ => true
  | Line nil (Zpos _) lEq::_ => true
  | Line nil (Zneg _) lEq::_ => true
  | _::d1 => unsolvable d1
  end.

(* we use a clause to count how many variable to eliminate *)
Fixpoint refute_l (a: list Z) (v: dt) :=
  match a with
  | nil => unsolvable v
  | _::b  => refute_l b (elim_one v)
  end.

(* extract the first clause *)
Definition first_clause (v: dt) :=
  match v with nil => nil | Line a _ _::_ => a end.

Definition refute (v: dt) := refute_l (first_clause v) v.

(*
Eval vm_compute in refute   (Line (1::nil) 0 lLe::
                             Line (-1::nil) (-0) lLt ::nil).
*)

(*
Eval vm_compute in refute ex1.
*)

(*
(* x >=0 and -x -1 <= 0 *)
Eval vm_compute in refute (Line (1::nil) 0 lLe::
                           Line (-1::nil) (-1) lLe ::nil).
*)

(***********************************************************)
(*                                                         *)
(*                   Proving Part                          *)
(*                                                         *)
(***********************************************************)

Section Proof.

Variable FT : Fmodule.
Variable FA : Faxiom FT.

Let injT1 := (injT FT).
Coercion injT1 : Z >-> T.

Open Scope F_scope.

(* Change the top coefficient of the line *)
Definition swap_top l := match l with
  |  Line nil _ _ => l
  |  Line (p::l1) c eq  => Line ((-p)::l1) c eq
end.

(* Change the top coefficient of the line *)
Definition op_line l := match l with
  |  Line l1 c t  => Line (oppsm l1) (-c) t
end.

(************************************************************)
(*          Line interpretation                             *)
(************************************************************)

Fixpoint list_to_T (l1: list Z) (l2: list (T _)) {struct l1} : T _ :=
  match l1, l2 with
    a::l3, x::l4 => a * x  + (list_to_T l3 l4)
  | _, _ => 0
  end.

Lemma list_to_T_nil: forall l1, list_to_T l1 nil = 0.
Proof.
intros l1; destruct l1; simpl; auto.
Qed.

Definition line_to_T (l: line) (env: list (T _)) :=
  match l with
    Line ll c lEq => (0:T _) = (list_to_T ll env) + c
  | Line ll c lLe => 0 <= (list_to_T ll env) + c
  | Line ll c lLt => 0 < (list_to_T ll env) + c
  end.

(* Dealing with opposite *)

Lemma opp_opp: forall (a: Z), -(-a) = a.
Proof. intros a; case a; auto. Qed.

Lemma opp_oppsm: forall l, oppsm (oppsm l) = l.
Proof.
intro l; induction l as [|a l Hrec]; simpl; auto.
rewrite Hrec; rewrite opp_opp; auto.
Qed.

Lemma list_to_T_opp: forall l env,
  list_to_T (oppsm l) env = (-1) * (list_to_T l env).
Proof.
intros l; induction l as [|v l Hrec]; simpl.
unfold injT1; rewrite scalT_inj0; auto.
intros [|e env].
unfold injT1; rewrite scalT_inj0; auto.
rewrite Hrec; rewrite scalT_plus_r; auto.
rewrite <-scalT_mul; auto.
Qed.

Lemma line_to_T_opp: forall l c env,
  line_to_T (Line l c lEq) env ->
  line_to_T (Line (oppsm l) (- c) lEq) env.
Proof.
unfold line_to_T; intros l c env H1.
rewrite list_to_T_opp.
change (Z.opp c) with (-1 * c)%Z.
unfold injT1; rewrite injT_mul; auto.
rewrite <- scalT_plus_r; auto.
fold injT1; rewrite <- H1.
unfold injT1; rewrite scalT_inj0; auto.
Qed.

(* All the elements of the dt are verified *)
Definition Pdt d env := forall a, In a d -> line_to_T a env.

(* All the element of the dt are verified with the flip of
   the first element  *)
Definition Pdot d env := forall a, In a d -> line_to_T (swap_top a) env.

(* Length of the variable part of a line *)
Definition llength l :=
  match l with Line w _ _ => length w end.

(************************************************************)
(*          Split correctness                               *)
(************************************************************)

(* the split only shuffle things around but we restrict
   ourself to prove inclusion *)

(* Special inclusion to handle the fact that
   we store only positive equation
*)
Inductive InE: line -> dt -> Prop :=
  InE_base: forall i b, In i b -> InE i b
| InE_eq: forall l c b,
     In (Line l c lEq) b -> InE (Line (oppsm l) (-c) lEq) b.

(* Absolute value like lemma for InE *)
Lemma InE_opp: forall l c b,
   InE (Line l c lEq) b -> InE (Line (oppsm l) (-c) lEq) b.
Proof.
intros l c b HH; inversion_clear HH.
apply InE_eq; auto.
rewrite opp_opp; rewrite opp_oppsm; auto.
apply InE_base; auto.
Qed.

Lemma InE_line_to_T: forall i d env,
  InE i d -> Pdt d env -> line_to_T i env.
Proof.
intros i d env HH; inversion_clear HH; auto.
intros H1; apply line_to_T_opp; auto.
Qed.

Definition dincl (a b: dt) (f: line -> line) :=
  forall i, In i a -> InE (f i) b.
(* identity filter *)
Definition id_elt (l: line) := l.
(* removing filter *)
Definition rm_elt l :=
  match l with Line l1 c eq => Line (0::l1) c eq end.

(* Inclusion behave well with correctness *)
Lemma Pdt_incl_id: forall d1 d2 env,
  dincl d1 d2 id_elt -> Pdt d2 env -> Pdt d1 env.
Proof.
intros d1 d2 env Hinc Hd2 i Hi.
apply InE_line_to_T with (2 := Hd2); auto.
apply (Hinc i Hi).
Qed.

Lemma Pdt_incl_op: forall d1 d2 env,
  dincl d1 d2 swap_top -> Pdt d2 env -> Pdot d1 env.
Proof.
intros d1 d2 env Hinc Hd2 i Hi.
apply InE_line_to_T with (2 := Hd2); auto.
Qed.

Lemma line_to_T_tail: forall i env,
  line_to_T (rm_elt i) env -> line_to_T i (tail env).
Proof.
intros [l c t] [| e env]; simpl;
  try (rewrite scalT_0; auto; rewrite injT_0_l; auto);
  rewrite list_to_T_nil; auto.
Qed.

Lemma InE_tail_line_to_T: forall i d env,
  InE (rm_elt i) d -> Pdt d env ->  line_to_T i (tail env).
Proof.
intros i d env HI Hp; apply line_to_T_tail.
apply InE_line_to_T with (2 := Hp); auto.
Qed.

Lemma Pdt_incl_rm: forall d1 d2 env,
  dincl d1 d2 rm_elt -> Pdt d2 env -> Pdt d1 (tail env).
Proof.
intros d1 d2 env Hinc Hd2 i Hi.
apply InE_tail_line_to_T with (2 := Hd2); auto.
Qed.

Definition d4incl (a: dt4) (b: dt) :=
  match a with
    DT4 No_eq d1 d2 d3 =>
      (dincl d1 b id_elt)
   /\ (dincl d2 b swap_top)
   /\ (dincl d3 b rm_elt)
  | DT4 (Some_eq p l c) d1 d2 d3 =>
      InE (Line (Zpos p::l) c lEq) b
   /\ (dincl d1 b id_elt)
   /\ (dincl d2 b swap_top)
   /\ (dincl d3 b rm_elt)

  end.

(* Horrible copy and paste proof, as we have to split  *)
(* similar cases (lLt lLe) we get similar subproofs    *)
(* This could be abstract away                         *)
Lemma split_aux_cor: forall v v1 (r: dt4),
  dincl v v1 id_elt -> d4incl r v1 -> d4incl (split_aux v r) v1.
Proof.
intro v; induction v as [| a v Hrec]; intros v1 r; simpl; auto.
destruct a as [x c t]; destruct x as [| x xs].
intros H1 H2; apply Hrec; auto with datatypes.
intros u Hu; apply H1; auto with datatypes.
destruct x as [|x|x]; intros H1 H2.
 apply Hrec; auto with datatypes;
  try (intros u Hu; apply H1; auto with datatypes).
destruct r as [e w1 w2 w3]; destruct e; simpl.
case H2; clear H2; intros H2 (H3,(H4,H5));
  repeat split; auto.
intros i Hi; case Hi; auto; intros; subst.
simpl; apply (H1 (Line (0 :: xs) c t)); auto with datatypes.
case H2; clear H2; intros H2 (H3,H4);
  repeat split; auto.
intros i Hi; case Hi; auto; intros; subst.
simpl; apply (H1 (Line (0 :: xs) c t)); auto with datatypes.
destruct t; auto; apply Hrec;
  try (intros u Hu; apply H1; auto with datatypes).
destruct r as [e w1 w2 w3]; destruct e; simpl.
case H2; clear H2; intros H2 (H3,(H4,H5)).
case Pos.compare_spec; repeat split; simpl; auto with datatypes.
intros i Hi; case Hi; auto; intros; subst; simpl; auto with datatypes.
refine (H1 _ _); auto with datatypes.
intros i Hi; case Hi; auto; intros; subst; simpl; auto with datatypes.
intros i Hi; case Hi; auto; intros; subst; simpl; auto with datatypes.
case H2; clear H2; intros H2 (H3,H4); repeat split; auto.
refine (H1 _ _); auto with datatypes.
destruct r as [e w1 w2 w3]; destruct e; simpl.
case H2; clear H2; intros H2 (H3,(H4,H5)).
repeat split; auto.
intros i Hi; case Hi; auto; intros; subst; simpl; auto with datatypes.
case H2; clear H2; intros H2 (H3,H4);
  repeat split; auto.
intros i Hi; case Hi; auto; intros; subst; simpl; auto with datatypes.
destruct r as [e w1 w2 w3]; destruct e; simpl.
case H2; clear H2; intros H2 (H3,(H4,H5)).
repeat split; auto.
intros i Hi; case Hi; auto; intros; subst; simpl; auto with datatypes.
case H2; clear H2; intros H2 (H3,H4); repeat split; auto.
intros i Hi; case Hi; auto; intros; subst; simpl; auto with datatypes.
destruct t; auto; apply Hrec;
  try (intros u Hu; apply H1; auto with datatypes).
destruct r as [e w1 w2 w3]; destruct e; simpl.
case H2; clear H2; intros H2 (H3,(H4,H5)).
case Pos.compare_spec; repeat split; simpl; auto with datatypes.
intros i Hi; case Hi; auto; intros; subst; simpl; auto with datatypes.
change (Zpos p :: oppsm xs) with (oppsm (Zneg p:: xs)); unfold id_elt.
apply InE_opp; refine (H1 _ _); auto with datatypes.
change (Zpos x :: oppsm xs) with (oppsm (Zneg x:: xs)); unfold id_elt.
apply InE_opp; refine (H1 _ _); auto with datatypes.
intros i Hi; case Hi; auto; intros; subst; simpl; auto with datatypes.
intros i Hi; case Hi; auto; intros; subst; simpl; auto with datatypes.
change (Zpos x :: oppsm xs) with (oppsm (Zneg x:: xs)); unfold id_elt.
apply InE_opp; refine (H1 _ _); auto with datatypes.
case H2; clear H2; intros H2 (H3,H4); repeat split; auto.
change (Zpos x :: oppsm xs) with (oppsm (Zneg x:: xs)); unfold id_elt.
apply InE_opp; refine (H1 _ _); auto with datatypes.
destruct r as [e w1 w2 w3]; destruct e; simpl.
case H2; clear H2; intros H2 (H3,(H4,H5)).
repeat split; auto.
intros i Hi; case Hi; auto; intros; subst; simpl; auto with datatypes.
refine (H1 _ _); auto with datatypes.
case H2; clear H2; intros H2 (H3,H4); repeat split; auto.
intros i Hi; case Hi; auto; intros; subst; simpl; auto with datatypes.
refine (H1 _ _); auto with datatypes.
destruct r as [e w1 w2 w3]; destruct e; simpl.
case H2; clear H2; intros H2 (H3,(H4,H5)).
repeat split; auto.
intros i Hi; case Hi; auto; intros; subst; simpl; auto with datatypes.
refine (H1 _ _); auto with datatypes.
case H2; clear H2; intros H2 (H3,H4); repeat split; auto.
intros i Hi; case Hi; auto; intros; subst; simpl; auto with datatypes.
refine (H1 _ _); auto with datatypes.
Qed.

Lemma split_cor: forall v, d4incl (split v) v.
Proof.
intros v; unfold split; apply split_aux_cor.
intros i Hi; apply InE_base; auto.
repeat split; intros i Hi; inversion Hi.
Qed.

Definition d4pos (a: dt4) :=
  match a with DT4 _ dp dn _ =>
      (forall x l c t, In (Line (x::l) c t) dp -> (0 < x)%Z)
   /\ (forall x l c t, In (Line (x::l) c t) dn -> (0 < x)%Z)
  end.

(* Another copy and paste proof *)
Lemma split_aux_pos: forall v r,
  d4pos r -> d4pos (split_aux v r).
Proof.
intro v; induction v as [| a v Hrec];
  intros (w1,w2,w3,w4) (H1,H2); repeat split; auto.
destruct a as [[|[|x|x] l] c t]; simpl.
 apply Hrec; repeat split; auto with datatypes.
 apply Hrec; repeat split; auto with datatypes.
destruct t; simpl; apply Hrec.
destruct w1.
case Pos.compare_spec.
repeat split; simpl; auto with datatypes.
intros x1 l1 c1 t1 Hx1; case Hx1; auto; intros H3.
injection H3; intros; subst; red; simpl; auto.
apply H1 with (1 := H3).
repeat split; simpl; auto with datatypes.
intros x1 l1 c1 t1 Hx1; case Hx1; auto; intros H3.
injection H3; intros; subst; red; simpl; auto.
apply H1 with (1 := H3).
repeat split; simpl; auto with datatypes.
intros x1 l1 c1 t1 Hx1; case Hx1; auto; intros H3.
injection H3; intros; subst; red; simpl; auto.
apply H1 with (1 := H3).
repeat split; simpl; auto with datatypes.
repeat split; simpl; auto with datatypes.
intros x1 l1 c1 t1 Hx1; case Hx1; auto; intros H3.
injection H3; intros; subst; red; simpl; auto.
apply H1 with (1 := H3).
repeat split; simpl; auto with datatypes.
intros x1 l1 c1 t1 Hx1; case Hx1; auto; intros H3.
injection H3; intros; subst; red; simpl; auto.
apply H1 with (1 := H3).
destruct t; simpl; apply Hrec.
destruct w1.
case Pos.compare_spec.
repeat split; simpl; auto with datatypes.
intros x1 l1 c1 t1 Hx1; case Hx1; auto; intros H3.
injection H3; intros; subst; red; simpl; auto.
apply H1 with (1 := H3).
repeat split; simpl; auto with datatypes.
intros x1 l1 c1 t1 Hx1; case Hx1; auto; intros H3.
injection H3; intros; subst; red; simpl; auto.
apply H1 with (1 := H3).
repeat split; simpl; auto with datatypes.
intros x1 l1 c1 t1 Hx1; case Hx1; auto; intros H3.
injection H3; intros; subst; red; simpl; auto.
apply H1 with (1 := H3).
repeat split; simpl; auto with datatypes.
repeat split; simpl; auto with datatypes.
intros x1 l1 c1 t1 Hx1; case Hx1; auto; intros H3.
injection H3; intros; subst; red; simpl; auto.
apply H2 with (1 := H3).
repeat split; simpl; auto with datatypes.
intros x1 l1 c1 t1 Hx1; case Hx1; auto; intros H3.
injection H3; intros; subst; red; simpl; auto.
apply H2 with (1 := H3).
Qed.

Lemma split_pos: forall v, d4pos (split v).
Proof.
intros v; unfold split; apply split_aux_pos.
repeat split; intros i l c t Hi; inversion Hi.
Qed.

(************************************************************)
(*          Product correctness                             *)
(************************************************************)

Lemma mapsm_cor: forall v l env,
  list_to_T (mapsm v l) env = v * list_to_T l env.
Proof.
intros v l; induction l as [| v1 l2 Hrec]; intros env; simpl; auto.
unfold injT1; rewrite scalT_inj0; auto.
destruct env as [| y env].
unfold injT1; rewrite scalT_inj0; auto.
rewrite scalT_plus_r; auto; rewrite Hrec; rewrite scalT_mul; auto.
Qed.

Lemma merge_cor: forall v1 v2 l1 l2 env,
  list_to_T (merge v1 v2 l1 l2) env =
   v1 * list_to_T l1 env + v2 * list_to_T l2 env.
Proof.
intros v1 v2 l1; induction l1 as [| w1 l1 Hrec]; intros l2 env; simpl; auto.
rewrite mapsm_cor; unfold injT1; rewrite scalT_inj0; auto; rewrite injT_0_l; auto.
destruct l2 as [| w2 l2]; destruct env as [| x env]; simpl;
  unfold injT1; repeat rewrite scalT_inj0; repeat rewrite injT_0_r; auto.
rewrite mapsm_cor; rewrite scalT_plus_r; auto; rewrite scalT_mul; auto.
rewrite Hrec.
repeat rewrite scalT_plus_r; repeat rewrite scalT_plus_l; auto.
rewrite scalT_mul; repeat rewrite plusT_A; auto;
  apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C; repeat rewrite plusT_A; auto;
  apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C; repeat rewrite scalT_mul; auto.
Qed.

Lemma dt_dot_nil: forall l, Pdt l nil -> Pdot l nil.
Proof.
intros l H i Hi; simpl.
generalize (H _ Hi); destruct i as [[|x w] c]; auto.
Qed.

Lemma Zgcd_spos: forall x y, (0 < x -> 0 < y -> 0 < Z.gcd x y)%Z.
Proof.
intros x y; case x; case y; auto with zarith.
Qed.

Lemma Zgcd_div_spos_l: forall x y, (0 < x -> 0 < y -> 0 < x/Z.gcd x y)%Z.
Proof.
intros x y Hx Hy; destruct (Zgcd_is_gcd x y) as [[z Hz] _ _].
pattern x at 1; rewrite Hz; rewrite Z_div_mult.
generalize Hx (Zgcd_spos _ _ Hx Hy); pattern x at 1; rewrite Hz.
case z; case Z.gcd; intros; auto with zarith; discriminate.
apply Z.lt_gt; apply Zgcd_spos; auto with zarith.
Qed.

Lemma Zgcd_div_spos_r: forall x y, (0 < x -> 0 < y -> 0 < y/ Z.gcd x y)%Z.
Proof.
intros x y Hx Hy; destruct (Zgcd_is_gcd x y) as [_ [z Hz] _].
pattern y at 1; rewrite Hz; rewrite Z_div_mult.
generalize Hy (Zgcd_spos _ _ Hx Hy); pattern y at 1; rewrite Hz.
case z; case Z.gcd; intros; auto with zarith; discriminate.
apply Z.lt_gt; apply Zgcd_spos; auto with zarith.
Qed.

Lemma app_one_cor: forall v c t l l1 r env,
  (0 < v)%Z -> (forall x ll c t, In (Line (x::ll) c t) l1 -> (0 < x)%Z) ->
  Pdt r (tail env) -> line_to_T (Line (v::l) c t) env ->
  Pdot l1 env ->
   Pdt (app_one v c t l l1 r) (tail env).
Proof.
intros v c t l l1; induction l1 as [| (li,c1,t1) l1 Hrec]; intros r env;
  destruct env as [| e env]; simpl; auto; destruct li as [|x li]; simpl; auto.
intros Hv Hl1 H1 H2 H3; apply (fun x => Hrec x nil); simpl; auto.
intros x ll cc tt Hx; apply (fun x => Hl1 x ll cc tt); auto.
intros i; simpl; intros [Hi | Hi]; subst; auto.
apply (H3 (Line nil c1 t1)); auto with datatypes.
intros i Hi; apply H3; auto with datatypes.
intros Hv Hl1 H1 H2 H3.
assert (Hxp: (0 < x)%Z).
  apply (fun x => Hl1 x li c1 t1); auto.
assert (Hzx:= Zgcd_div_spos_r _ _ Hv Hxp).
assert (Hzv:= Zgcd_div_spos_l _ _ Hv Hxp).
apply (fun x => Hrec x nil); simpl; auto.
intros x1 ll cc tt Hx; apply (fun x => Hl1 x ll cc tt); auto.
intros i; simpl; intros [Hi | Hi]; subst; simpl; auto.
rewrite merge_cor; repeat rewrite list_to_T_nil.
unfold injT1; repeat rewrite scalT_inj0; repeat (rewrite injT_0_l in H2,H3 |- *);
  repeat rewrite injT_0_l; auto.
rewrite injT_plus; repeat rewrite injT_mul; auto.
cut (line_to_T (swap_top (Line (x :: li) c1 t1)) nil); auto with datatypes.
destruct t; destruct t1; simpl; auto; unfold injT1 in H2 |- *;
  rewrite injT_0_l in H2; auto; try rewrite <- H2; auto;
  repeat rewrite scalT_inj0; repeat rewrite injT_0_l; auto; intros H4.
rewrite <- H4; rewrite scalT_inj0; auto.
apply scalT_spos; auto.
apply scalT_pos; auto with zarith.
rewrite <- H4; rewrite scalT_inj0; auto.
rewrite injT_0_r; auto.
apply scalT_spos; auto.
apply plusTss_pos; auto; apply scalT_spos; auto.
apply plusTs1_pos; auto; try apply scalT_spos; auto;
  apply scalT_pos; auto with zarith.
rewrite <- H4; rewrite scalT_inj0; auto.
rewrite injT_0_r; auto.
apply scalT_pos; auto with zarith.
apply plusT1s_pos; auto; try apply scalT_spos; auto;
  apply scalT_pos; auto with zarith.
apply plusT_pos; auto; apply scalT_pos; auto with zarith.
intros i Hi; auto with datatypes.
intros Hv Hl1 H1 H2 H3.
apply (fun x => Hrec x (e::env)); simpl; auto.
intros x ll cc tt Hcc; apply (Hl1 x ll cc tt); auto.
intros i; simpl; intros [Hi | Hi]; subst; simpl; auto.
apply (H3 (Line nil c1 t1)); auto with datatypes.
intros i Hi; apply (H3 i); auto with datatypes.
intros Hv Hl1 H1 H2 H3.
assert (Hxp: (0 < x)%Z).
  apply (fun x => Hl1 x li c1 t1); auto.
assert (Hzx:= Zgcd_div_spos_r _ _ Hv Hxp).
assert (Hzv:= Zgcd_div_spos_l _ _ Hv Hxp).
apply (fun x => Hrec x (e::env)); simpl; auto.
intros xx ll cc tt Hcc; apply (Hl1 xx ll cc tt); auto.
intros i; simpl; intros [Hi|Hi]; subst; simpl; auto.
rewrite merge_cor.
match goal with |- context[?X + ?Y] =>
  replace (X + Y) with
    ((x / Z.gcd v x) * (v * e + list_to_T l env + c) +
     (v / Z.gcd v x) * (- x * e + list_to_T li env + c1))
end.
cut (line_to_T (swap_top (Line (x :: li) c1 t1)) (e::env)); auto with datatypes.
destruct t; destruct t1; simpl; auto; unfold injT1 in H2 |- *;
  auto; try rewrite <- H2; auto;
  repeat rewrite scalT_inj0; repeat rewrite injT_0_l; auto; intros H4.
rewrite <- H4; rewrite scalT_inj0; auto.
apply scalT_spos; auto.
apply scalT_pos; auto with zarith.
rewrite <- H4; rewrite scalT_inj0; auto.
rewrite injT_0_r; auto.
apply scalT_spos; auto.
apply plusTss_pos; auto; apply scalT_spos; auto.
apply plusTs1_pos; auto; try apply scalT_spos; auto;
  apply scalT_pos; auto with zarith.
rewrite <- H4; rewrite scalT_inj0; auto.
rewrite injT_0_r; auto.
apply scalT_pos; auto with zarith.
apply plusT1s_pos; auto; try apply scalT_spos; auto;
  apply scalT_pos; auto with zarith.
apply plusT_pos; auto; apply scalT_pos; auto with zarith.
repeat rewrite scalT_plus_r; auto.
repeat rewrite plusT_A; auto; rewrite plusT_C; repeat rewrite plusT_A; auto.
apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C; repeat rewrite plusT_A; auto.
rewrite plusT_C; repeat rewrite plusT_A; auto.
apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C; repeat rewrite plusT_A; auto.
rewrite plusT_C; repeat rewrite plusT_A; auto.
unfold injT1; rewrite injT_plus; repeat rewrite injT_mul; auto.
apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C; repeat rewrite plusT_A; auto.
rewrite <- (injT_0_r); auto.
apply f_equal2 with (f := plusT FT); auto.
repeat rewrite <- scalT_mul; auto.
replace (x / Z.gcd v x * v)%Z with (v / Z.gcd v x * x)%Z.
replace (v / Z.gcd v x * - x)%Z with ((-1) * (v / Z.gcd v x * x))%Z; try ring.
rewrite (scalT_mul _ FA (-1)%Z); rewrite plusT_0; auto.
assert (Hdv: ((Z.gcd v x) | v)%Z).
assert (Hz:= (Zgcd_is_gcd v x)); inversion Hz; auto.
case Hdv; intros q Hq; pattern v at 1 4; rewrite Hq.
rewrite Z_div_mult.
assert (Hdx: ((Z.gcd v x) | x)%Z).
assert (Hz:= (Zgcd_is_gcd v x)); inversion Hz; auto.
case Hdx; intros q1 Hq1; pattern x at 1 2; rewrite Hq1.
rewrite Z_div_mult; try ring.
apply Z.lt_gt; apply Zgcd_spos; auto.
apply Z.lt_gt; apply Zgcd_spos; auto.
intros i Hi; apply (H3 i); auto with datatypes.
Qed.

(* Special case for elimination of the positive part with an equation *)
Lemma app_one_cor_eq: forall v c l l1 r env,
  (0 < v)%Z -> (forall x ll c t, In (Line (x::ll) c t) l1 -> (0 < x)%Z) ->
  Pdt r (tail env) -> line_to_T (Line (-v::l) c lEq) env ->
  Pdt l1 env ->
   Pdt (app_one v c lEq l l1 r) (tail env).
Proof.
intros v c l l1; induction l1 as [| (li,c1,t1) l1 Hrec]; intros r env;
  destruct env as [| e env]; simpl; auto; destruct li as [|x li]; simpl; auto.
intros Hv Hl1 H1 H2 H3; apply (fun x => Hrec x nil); simpl; auto.
intros x ll cc tt Hx; apply (fun x => Hl1 x ll cc tt); auto.
intros i; simpl; intros [Hi | Hi]; subst; auto.
apply (H3 (Line nil c1 t1)); auto with datatypes.
intros i Hi; apply H3; auto with datatypes.
intros Hv Hl1 H1 H2 H3.
unfold injT1 in H2; rewrite injT_0_l in H2; auto.
assert (Hxp: (0 < x)%Z).
  apply (fun x => Hl1 x li c1 t1); auto.
assert (Hzx:= Zgcd_div_spos_r _ _ Hv Hxp).
assert (Hzv:= Zgcd_div_spos_l _ _ Hv Hxp).
apply (fun x => Hrec x nil); simpl; auto.
intros x1 ll cc tt Hx; apply (fun x => Hl1 x ll cc tt); auto.
intros i; simpl; intros [Hi | Hi]; subst; simpl; auto.
rewrite merge_cor; repeat rewrite list_to_T_nil.
cut (line_to_T (Line (x :: li) c1 t1) nil); auto with datatypes; simpl.
unfold injT1; repeat rewrite scalT_inj0; repeat (rewrite injT_0_l in H2,H3 |- *);
  auto.
repeat rewrite injT_0_l; auto.
rewrite injT_plus; repeat rewrite injT_mul; auto.
destruct t1; simpl; intros H4;
  try (rewrite <- H2); try (rewrite <-H4);
  repeat rewrite scalT_inj0; auto;
  try (rewrite injT_0_r); try (rewrite injT_0_l); auto.
apply scalT_spos; auto.
apply scalT_pos; auto with zarith.
unfold injT1; rewrite <- H2; rewrite injT_0_r; auto.
intros i Hi; auto with datatypes.
intros Hv Hl1 H1 H2 H3.
apply (fun x => Hrec x (e::env)); simpl; auto.
intros x ll cc tt Hcc; apply (Hl1 x ll cc tt); auto.
intros i; simpl; intros [Hi | Hi]; subst; simpl; auto.
apply (H3 (Line nil c1 t1)); auto with datatypes.
intros i Hi; apply (H3 i); auto with datatypes.
intros Hv Hl1 H1 H2 H3.
apply (fun x => Hrec x (e::env)); simpl; auto.
intros xx ll cc tt Hcc; apply (Hl1 xx ll cc tt); auto.
intros i; simpl; intros [Hi|Hi]; subst; simpl; auto.
rewrite merge_cor.
assert (Hxp: (0 < x)%Z).
  apply (fun x => Hl1 x li c1 t1); auto.
assert (Hzx:= Zgcd_div_spos_r _ _ Hv Hxp).
assert (Hzv:= Zgcd_div_spos_l _ _ Hv Hxp).
match goal with |- context[?X + ?Y] =>
  replace (X + Y) with
    ((x / Z.gcd v x) * (-v * e + list_to_T l env + c) +
     (v / Z.gcd v x) * (x * e + list_to_T li env + c1))
end.
cut (line_to_T (Line (x :: li) c1 t1) (e::env)); auto with datatypes.
destruct t1; simpl; auto; unfold injT1 in H2 |- *;
  auto; try rewrite <- H2; auto;
  repeat rewrite scalT_inj0; repeat rewrite injT_0_l; auto; intros H4.
rewrite <- H4; rewrite scalT_inj0; auto.
apply scalT_spos; auto.
apply scalT_pos; auto with zarith.
repeat rewrite scalT_plus_r; auto.
repeat rewrite plusT_A; auto; rewrite plusT_C; repeat rewrite plusT_A; auto.
apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C; repeat rewrite plusT_A; auto.
rewrite plusT_C; repeat rewrite plusT_A; auto.
apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C; repeat rewrite plusT_A; auto.
rewrite plusT_C; repeat rewrite plusT_A; auto.
unfold injT1; rewrite injT_plus; repeat rewrite injT_mul; auto.
apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C; repeat rewrite plusT_A; auto.
rewrite <- (injT_0_r); auto.
apply f_equal2 with (f := plusT FT); auto.
repeat rewrite <- scalT_mul; auto.
rewrite plusT_C; auto.
replace (v / Z.gcd v x * x)%Z with (x / Z.gcd v x * v)%Z.
replace (x / Z.gcd v x * - v)%Z with ((-1) * (x / Z.gcd v x * v))%Z; try ring.
rewrite (scalT_mul _ FA (-1)%Z); rewrite plusT_0; auto.
assert (Hdv: ((Z.gcd v x) | x)%Z).
assert (Hz:= (Zgcd_is_gcd v x)); inversion Hz; auto.
case Hdv; intros q Hq; pattern x at 1 4; rewrite Hq.
rewrite Z_div_mult; auto.
assert (Hdx: ((Z.gcd v x) | v)%Z).
assert (Hz:= (Zgcd_is_gcd v x)); inversion Hz; auto.
case Hdx; intros q1 Hq1; pattern v at 1 2; rewrite Hq1.
rewrite Z_div_mult; try ring.
apply Z.lt_gt; apply Zgcd_spos; auto.
apply Z.lt_gt; apply Zgcd_spos; auto.
intros i Hi; apply (H3 i); auto with datatypes.
Qed.

Lemma product_cor: forall l1 l2 r env,
  (forall x ll c t, In (Line (x::ll) c t) l1 -> (0 < x)%Z) ->
  (forall x ll c t, In (Line (x::ll) c t) l2 -> (0 < x)%Z) ->
  Pdt r (tail env) -> Pdt l1 env ->
  Pdot l2 env -> Pdt (product l1 l2 r) (tail env).
Proof.
intros l1; elim l1; simpl; auto; clear l1.
intros ([|x w],c,t) l1 Hrec l2 r env Hp1 Hp2 H2 H3 H4; auto.
apply Hrec; auto with datatypes.
intros x ll c1 t1 Hx.
apply (Hp1 x ll c1 t1); auto.
intros i Hi; apply (H3 i); auto with datatypes.
destruct t.
apply Hrec; auto with datatypes.
intros x1 ll c1 t1 Hx.
apply (Hp1 x1 ll c1 t1); auto with datatypes.
intros i Hiu; apply H3; auto with datatypes.
apply Hrec; auto with datatypes.
intros x1 ll c1 t1 Hx.
apply (Hp1 x1 ll c1 t1); auto.
apply app_one_cor; auto with datatypes.
apply (Hp1 x w c lLt); auto.
intros i Hiu; apply H3; auto with datatypes.
apply Hrec; auto with datatypes.
intros x1 ll c1 t1 Hx.
apply (Hp1 x1 ll c1 t1); auto.
apply app_one_cor; auto with datatypes.
apply (Hp1 x w c lLe); auto.
intros i Hiu; apply H3; auto with datatypes.
Qed.

(************************************************************)
(*          Refute correctness                              *)
(************************************************************)

Lemma elim_one_cor: forall v env,
  Pdt v env -> Pdt (elim_one v) (tail env).
Proof.
intros v env Hv; unfold elim_one.
generalize (split_cor v) (split_pos v);
  case split; intros [p l c|] w1 w2 w3.
intros (Hd1, (Hd2, (Hd3, Hd4))) (Hp1, Hp2).
apply app_one_cor_eq; auto with zarith.
red; auto.
apply app_one_cor; auto with zarith.
red; auto.
apply Pdt_incl_rm with (1 := Hd4); auto.
apply InE_line_to_T with (2 := Hv); auto.
apply Pdt_incl_op with (1 := Hd3); auto.
apply (line_to_T_opp (Zpos p::l)).
apply InE_line_to_T with (2 := Hv); auto.
apply Pdt_incl_id with (1 := Hd2); auto.
intros (Hd1, (Hd2, Hd3)) (Hp1, Hp2).
apply product_cor; auto.
apply Pdt_incl_rm with (1 := Hd3); auto.
apply Pdt_incl_id with (1 := Hd1); auto.
apply Pdt_incl_op with (1 := Hd2); auto.
Qed.

Lemma unsolvable_cor: forall d env,
  unsolvable d = true -> ~ Pdt d env.
Proof.
intros d env; induction d as [| [[| x w] c t] d Hrec]; simpl.
intros HH; discriminate HH.
destruct c; simpl; auto.
destruct t; simpl.
intros H H1; case (Hrec H).
intros i Hi; auto with datatypes.
intros _ H; case (ltT_neg _ FA (0%Z)); auto with zarith.
generalize (H (Line nil (0%Z) lLt)); simpl; auto.
unfold injT1; rewrite injT_0_r; auto with datatypes.
intros H H1; case (Hrec H).
intros i Hi; auto with datatypes.
destruct t; simpl.
intros _ H; case (leT_neg _ FA (Zneg p)).
red; simpl; auto.
change (Zneg p) with ((-1) * (Zpos p))%Z.
rewrite injT_mul; auto.
generalize (H (Line nil (Zpos p) lEq)); simpl.
unfold injT1; rewrite injT_0_l; auto.
intros HH; rewrite <-HH; auto; rewrite scalT_inj0; auto.
apply leT_refl; auto.
intros H H1; case (Hrec H); intros i Hi; auto with datatypes.
intros H H1; case (Hrec H); intros i Hi; auto with datatypes.
destruct t; simpl.
intros _ H; case (leT_neg _ FA (Zneg p)).
red; simpl; auto.
generalize (H (Line nil (Zneg p) lEq)); simpl.
unfold injT1; rewrite injT_0_l; auto.
intros HH; rewrite <-HH; auto.
apply leT_refl; auto.
intros _ H; case (ltT_neg _ FA (Zneg p)); try discriminate.
generalize (H (Line nil (Zneg p) lLt)); simpl.
unfold injT1; rewrite injT_0_l; auto.
intros _ H; case (leT_neg _ FA (Zneg p)).
red; simpl; auto.
generalize (H (Line nil (Zneg p) lLe)); simpl.
unfold injT1; rewrite injT_0_l; auto.
intros H H1; case (Hrec H); intros i Hi; auto with datatypes.
Qed.

Lemma refute_l_cor: forall a v env,
  length a = length env ->
  refute_l a v = true -> ~ Pdt v env.
intros a; induction a as [|x a Hrec].
intros; apply unsolvable_cor; auto.
intros v [|e env]; try (intros HH; discriminate).
intros HH Hr Hd; apply (Hrec (elim_one v) env); auto.
injection HH; auto.
intros HH1; apply (elim_one_cor v (e::env)); auto.
Qed.

Lemma refute_cor: forall v env,
  length (first_clause v) = length env ->
  refute v = true -> ~ Pdt v env.
Proof.
intros v env Hl Hr; apply (refute_l_cor (first_clause v)); auto.
Qed.

End Proof.


(**
正規表現の言語を定義して、次の文献にある例を実行してみた。
文献[1]：Tukuba Coq Users' Grup 「Coqによる定理証明」
坂口さん著「反復定理で遊ぼう」

実装にあたっては、
文献[2]: https://www.ps.uni-saarland.de/~doczkal/regular/
を参考にしているが、そのパッケージは使用しない。
 *)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype finset.

(** 定義 1.1
語は文字のseqで表す。
 *)
Variable char : finType.                    (* アルファベットΣ *)
Variables a b c : char.                     (* 文字 *)
Variables w : seq char.                     (* 語 *)

(** 定義 1.2
正規表現
 *)
Inductive regexp :=
 | Void              : regexp
 | Eps               : regexp
 | Atom (a : char)   : regexp
 | Plus (e1 e2 : regexp) : regexp
 | Conc (e1 e2 : regexp) : regexp
 | Star (e : regexp) : regexp.

Check Void.
Check Eps.

(* 例 1.3
正規表現
*)
Check (Conc (Conc (Star (Atom a))
                  (Plus (Atom b) (Atom c)))
            (Star (Star (Atom a)))).

(** 定義 1.5
正規表現の言語
*)
(**
決定性言語を「与えられた語が、その言語に含まれるか」を示す述語として定義する。
*)
Definition dlang := pred (seq char).        (* 決定性言語の集合 *)
Variables L1 L2 : dlang.                    (* ひとつの言語 *)

(**
言語の演算
 *)
Definition void : dlang := pred0.           (* 語を含まない言語 *)
Definition eps : dlang := pred1 [::].       (* 空の語だけを含む言語 *)
Definition atom x : dlang := pred1 [:: x].  (* 一文字の語だけを含む言語 *)
Definition plus (L1 L2 : dlang) :=          (* 言語の和 *)
  [pred w | L1 w || L2 w].
Definition conc (L1 L2: dlang) : dlang :=   (* 言語の積、語の畳込 *)
  fun v => [exists i : 'I_(size v).+1, L1 (take i v) && L2 (drop i v)].
Definition residual (x : char) (L : dlang) := [pred w | L (x :: w)].
Definition star (L : dlang) : dlang :=      (* クリーネ閉包 *)
  fix star v := if v is x :: v' then conc (residual x L) star v' else true.

(* 以下は、正規表現の言語の定義には不要だが *)
Definition compl L : dlang := predC L.      (* 言語の補集合 *)
Definition prod (L1 L2 : dlang) :=          (* 言語の積、語の積 *)
  [pred w in L1 | L2 w].

(**
正規表現の言語
与えられた正規表現に対して、それに対応する語を含む言語
（その語に対してtrueを返す論理式）を返す。
 *)
Fixpoint re_lang (e : regexp) : dlang :=
  match e with
  | Void => void
  | Eps => eps
  | Atom x => atom x
  | Star e1 => star (re_lang e1)
  | Plus e1 e2 => plus (re_lang e1) (re_lang e2)
  | Conc e1 e2 => conc (re_lang e1) (re_lang e2)
  end.

Lemma re_void__lang_none (w : seq char) :
  ~~ (re_lang Void w).
Proof.
  rewrite /re_lang /void.
  by [].
Qed.

Lemma re_eps__lang_null : re_lang Eps [::].
Proof.
  rewrite /re_lang /eps.
  by [].
Qed.

Lemma re_atom__lang_atom (a : char) :
  re_lang (Atom a) [:: a].
Proof.
  rewrite /re_lang /atom /=.
  by [].
Qed.

Lemma re_plus__lang_or (e1 e2 : regexp) (w : seq char) :
    re_lang e1 w || re_lang e2 w ->
    re_lang (Plus e1 e2) w.
Proof.
  rewrite /re_lang /=.
  case/orP => H.
    by apply/orP; left.
    by apply/orP; right.
Qed.

Lemma take_drop (L1 L2 : dlang) (w : seq char) (i : 'I_(size w).+1) :
    L1 (take i w) -> L2 (drop i w) -> (conc L1 L2) w.
Proof.
  move=> H1 H2.
  rewrite /conc.
  apply/existsP.
  exists i.
  by apply/andP; split.
Qed.

Lemma re_cons__lang_take_drop (e1 e2 : regexp) (w : seq char) (i : 'I_(size w).+1) :
    re_lang e1 (take i w) ->
    re_lang e2 (drop i w) ->
    re_lang (Conc e1 e2) w.
Proof.
  move=> L1 L2.
  rewrite /re_lang /conc.
  apply/existsP.
  exists i.
  apply/andP; split.
  by apply L1.
  by apply L2.
Qed.

(**
文献[2]で証明されている補題たち。一部を修正した。
*)
Lemma plusP {L1 L2 : dlang} {w : seq char} :
  reflect (L1 w \/ L2 w) (plus L1 L2 w).
Proof.
    by apply/orP.
Qed.

Lemma concP {L1 L2 : dlang} {w : seq char} :
  reflect (exists w1 w2, w = w1 ++ w2 /\ L1 w1  /\ L2 w2) (conc L1 L2 w).
Proof.
  apply: (iffP existsP) => [[n] /andP [H1 H2] | [w1] [w2] [e [H1 H2]]].
  - exists (take n w). exists (drop n w).
             by rewrite cat_take_drop.
  - have lt_w1: size w1 < (size w).+1 by rewrite e size_cat ltnS leq_addr.
    exists (Ordinal lt_w1); subst.
    rewrite take_size_cat // drop_size_cat //. exact/andP.
Qed.

Lemma conc_cat {L1 L2 : dlang} {w1 w2 : seq char} :
  L1 w1 -> L2 w2 -> conc L1 L2 (w1 ++ w2).
Proof.
  move => H1 H2.
  apply/concP.
  by exists w1, w2.
Qed.

Lemma conc_eq (L1 L2 L3 L4: dlang) :
  L1 =i L2 ->
  L3 =i L4 ->
  conc L1 L3 =i conc L2 L4.
Proof.
  move=> H1 H2.
  move=> w.
  apply: eq_existsb => n.
  (* by rewrite (_ : L1 =1 L2) // (_ : L3 =1 L4). *)
  rewrite (H1 : L1 =1 L2).                  (* rewrite (_ : L1 =1 L2) *)
  rewrite (H2 : L3 =1 L4).                  (* rewrite (_ : L3 =1 L4) *)
    by [].
Qed.

Lemma starP {L : dlang} {v : seq char} :
  reflect (exists2 vv, all [predD L & eps] vv & v = flatten vv) (star L v).
Proof.
  elim: {v}_.+1 {-2}v (ltnSn (size v)) => // n IHn [|x v] /= le_v_n.
  - by left; exists [::].
  - apply: (iffP concP) => [[u] [v'] [def_v [Lxu starLv']] | [[|[|y u] vv] //=]].
    case/IHn: starLv' => [|vv Lvv def_v'].
    + by rewrite -ltnS (leq_trans _ le_v_n) // def_v size_cat !ltnS leq_addl.
    + by exists ((x :: u) :: vv); [exact/andP | rewrite def_v def_v'].
    + case/andP=> Lyu Lvv [def_x def_v]; exists u. exists (flatten vv).
      subst. split => //; split => //. apply/IHn; last by exists vv.
      by rewrite -ltnS (leq_trans _ le_v_n) // size_cat !ltnS leq_addl.
Qed.

Lemma star_eq (L1 L2 : dlang) :
  L1 =i L2 -> star L1 =i star L2.
Proof.
  move => H1 w.
  apply/starP/starP; move => [] vv H3 H4; exists vv => //;
  erewrite eq_all; try eexact H3; move => x /=; by rewrite ?H1 // -?H1.
Qed.

Lemma star_cat (w1 w2 : seq char) (L : dlang) :
  L w1 -> star L w2 -> star L (w1 ++ w2).
Proof.
  case: w1 => [|a w1] // H1 /starP [vv Ha Hf].
  apply/starP.
  exists ((a::w1) :: vv).
  - rewrite /=.
    apply/andP; split.
    + by apply H1.
    + by apply Ha.
  - by rewrite Hf //= H1.
Qed.

(**
rep とその補題
 *)
Fixpoint rep (s : seq char) n : seq char :=
  if n is n'.+1 then
    s ++ rep s n'
  else
    [::].

Lemma rep_nil n : rep [::] n = [::].
Proof.
  by elim: n => //=.
Qed.

Lemma star_rep (L1 : dlang) (w : seq char) (n : nat) :
       L1 w -> (star L1) (rep w n).
Proof.
  move=> H1.
  elim: n.
  - move=> /=.                              (* n = 0 *)
    by [].
  - move=> n IHn /=.                        (* n = n + 1 *)
    apply star_cat.
    + by [].
    + by apply IHn.
Qed.

Lemma re_star__lang_star (e : regexp)  (w : seq char) (n : nat) :
    re_lang e w ->
    re_lang (Star e) (rep w n).
Proof.
  elim: n.
  - by [].
  - move=> n /= IHn => H.
    apply star_cat.
    + by [].
    + by apply IHn.
Qed.

(** 例 1.6
正規表現の言語
*)

(** 正規表現 a* b a* の言語は、{a^n b a^m : n,m ∈ Nat} である。 *)
Goal forall (n m : nat),
       re_lang
         (Conc (Conc (Star (Atom a)) (Atom b)) (Star (Atom a)))
         ((rep [:: a] n ++ [:: b]) ++ rep [:: a] m).
Proof.
  move=> n m.
  rewrite /conc.
  apply conc_cat.
  apply conc_cat.
  - apply star_rep.
    + by rewrite /atom /=.
    + by rewrite /atom /=.
  - apply star_rep.
    + by rewrite /atom /=.
Qed.

(** すごく遠回りして解いた例 *)
Lemma size_rep_one a n :
  size (rep [:: a] n) = n.
Proof.
  elim: n => /=.
  - by [].
  - move=> n IHn.
    by rewrite IHn.
Qed.

Lemma size_cons (a :char)  l n :
  size l = n -> size (a :: l) = n.+1.
Proof.
  move=> H /=.
  by rewrite H.
Qed.

Lemma size_rep a :
  forall n m, size (rep [:: a] n ++ b :: rep [:: a] m) = n + m + 1.
Proof.
  move=> n m.
  rewrite size_cat.
  Check (size_cons b (rep [::a] m)).
  rewrite (size_cons b (rep [::a] m) m).
  rewrite size_rep_one.
  by nat_norm.
  rewrite size_rep_one.
  by [].
Qed.

Lemma take_take_1 (a : char) (n : nat) (ln lm : seq char) :
  size ln = n ->
  take (n + 1) ((ln ++ [:: a]) ++ lm) = ln ++ [:: a].
Proof.
  move=> Hn.
  have Hsize :  n + 1 <= size (ln ++ [:: a]).
  - by rewrite size_cat Hn //=.
  have Hsize2 : n + 1 = size (ln ++ [:: a]).
  - by rewrite size_cat Hn //=.
  Check @takel_cat (n + 1) char (ln ++ [:: a]) Hsize lm.
  rewrite (@takel_cat (n + 1) char (ln ++ [:: a]) Hsize lm).
  rewrite Hsize2.
  Check @take_size char (ln ++ [:: a]).
  rewrite (@take_size char (ln ++ [:: a])).
  by [].
Qed.

Lemma take_take' (a : char) (n : nat) (ln lm : seq char) :
  size ln = n ->
  take n (take (n + 1) ((ln ++ [:: a]) ++ lm)) = ln.
Proof.
  move=> Hn.
  rewrite (take_take_1 a n ln lm).
  have Hsize : n <= size ln.
  - by rewrite Hn.
  Check @takel_cat n char ln Hsize [:: a].
  rewrite (@takel_cat n char ln Hsize [:: a]).
  rewrite -Hn.
  Check @take_size char ln.
  rewrite (@take_size char ln).
  by [].
  by apply Hn.
Qed.

Lemma subnnn n : n - n = 0.
Proof.
  elim: n.
  - by [].
  - move=> n IHn.
    by rewrite subSS.
Qed.

Lemma drop_take' (a : char) (n : nat) (ln lm : seq char) :
  size ln = n ->
  drop n (take (n + 1) ((ln ++ [:: a]) ++ lm)) = [:: a].
Proof.
  move=> Hn.
  rewrite (take_take_1 a n ln lm).
  Check @drop_cat n char ln [:: a].
  rewrite (@drop_cat n char ln [:: a]).
  rewrite Hn.
  case: (n < n).
  - rewrite -Hn.
    rewrite (drop_size ln).
    by [].
  - have Hzero : n - n = 0 by rewrite subnnn.
    rewrite Hzero //=.
    by [].
Qed.

Lemma take_take n m (a b : char) :
  take n (take (n + 1) (rep [:: a] n ++ b :: rep [:: a] m)) = rep [:: a] n.
Proof.
  Check take_take' b n (rep [:: a] n) (rep [:: a] m).
  have H : take n (take (n + 1) ((rep [:: a] n ++ [:: b]) ++ rep [:: a] m)) = rep [:: a] n.
  - rewrite (take_take' b n (rep [:: a] n) (rep [:: a] m)).
    + by [].
    + apply size_rep_one.
  - Check catA.
    rewrite -catA /= in H.
      by apply H.
Qed.

Lemma drop_take n m (a b : char) :
  (drop n (take (n + 1) (rep [:: a] n ++ b :: rep [:: a] m))) = [:: b].
Proof.
  have H : drop n (take (n + 1) ((rep [:: a] n ++ [:: b]) ++ rep [:: a] m)) = [:: b].
  - Check drop_take' b n (rep [:: a] n) (rep [:: a] m).
    apply (drop_take' b n (rep [:: a] n) (rep [:: a] m)).
    by apply size_rep_one.
  - rewrite -catA /= in H.
    by apply H.
Qed.

Lemma take_rep n :
  forall (a : char) (l : seq char), take n (rep [:: a] n ++ l) = rep [:: a] n.
Proof.
  move=> a l.
  have Hsize : n <= size (rep [:: a] n) by rewrite size_rep_one.
  Check @takel_cat n char (rep [:: a] n) Hsize l.
  rewrite (@takel_cat n char (rep [:: a] n) Hsize l).

  have Hsize2 : size (rep [:: a] n) = n by rewrite size_rep_one.
  rewrite -{1}Hsize2.
  Check @take_size char (rep [:: a] n).
  rewrite (@take_size char (rep [:: a] n)).
  by [].
Qed.

Lemma drop_rep n :
  forall (a b : char) (l : seq char),
    drop (n + 1) (rep [:: a] n ++ b :: l) = l.
Proof.
  move=> a b l.
  have Hsize2 : n + 1 = size (rep [:: a] n ++ [:: b]).
  - by rewrite size_cat //= size_rep_one.
  have H : drop (n + 1) ((rep [:: a] n ++ [:: b]) ++ l) = l.
  - Check @drop_cat (n + 1) char ((rep [:: a] n) ++ [:: b]) l.
    rewrite (@drop_cat (n + 1) char ((rep [:: a] n) ++ [:: b]) l).
    rewrite -Hsize2.
    case (n + 1 < n + 1).
    + Check (drop_size (rep [:: a] n ++ [:: b])).
      rewrite {1}Hsize2.
      rewrite (drop_size (rep [:: a] n ++ [:: b])).
      by [].
    + have Hzero : (n + 1 - (n + 1)) = 0.
      * nat_norm => //=.
                      by rewrite subnnn.
      rewrite Hzero.
      by apply drop0.
  - Search ((_ ++ _) ++ _).
    Check @catA char.
      by rewrite -catA //= in H.
Qed.

Goal forall (n m : nat),
       re_lang
         (Conc (Conc (Star (Atom a)) (Atom b)) (Star (Atom a)))
         (rep [:: a] n ++ [:: b] ++ rep [:: a] m).
Proof.
  move=> n m.
  rewrite /re_lang /conc /=.
  apply/existsP => /=.
  rewrite (size_rep a n m).
  rewrite -addn1.
  have lt_n__n_m_1 : n + 1 < n + m + 1 + 1.
  - apply/ltP.
    rewrite 2!addn1.
    apply Lt.lt_n_S.
    rewrite -addnA.
    rewrite [m + 1]addnC.
    rewrite addnA.
    apply/ltP.
    apply (@ltn_addr n (n + 1) m).
    rewrite addn1.
    apply ltnSn.

  exists (Ordinal lt_n__n_m_1).

  apply/andP.
  split.
  - apply/existsP => /=.
    Check size_takel.
    rewrite size_takel.
    rewrite -addn1.
    have lt_n__n_1 : n < n + 1 + 1.
      apply (@ltn_addr n (n + 1) 1).
      rewrite addn1.
      apply ltnSn.

    exists (Ordinal lt_n__n_1).
    apply/andP.
    split.
    + simpl.
      rewrite take_take.
      apply star_rep.
      by rewrite /atom /=.
    + simpl.
      * rewrite drop_take.
          by rewrite /atom /=.
      * rewrite size_cat size_rep_one.
          rewrite (size_cons b (rep [:: a] m) m).
          - rewrite -[m.+1]addn1 [m + 1]addnC addnA.
              by apply leq_addr.
          - by rewrite size_rep_one.
    + simpl.
      rewrite drop_rep.
      apply star_rep.
      by rewrite /atom /=.
Qed.
(** すごく遠回りして解いた例、終わり。 *)

(** 正規表現 (aaa)* の言語は、{a^3n : n ∈ Nat} である。 *)
Goal forall (n : nat), re_lang
                         (Star (Conc (Conc (Atom a) (Atom a)) (Atom a)))
                         (rep [:: a; a; a] n).
Proof.
  move=> n.
  rewrite /re_lang /conc /=.
  apply star_rep.

  Compute (take 1 (take 2 [:: a; a; a])).
  Compute (drop 1 (take 2 [:: a; a; a])).
  Compute (drop 2 [:: a; a; a]).

  apply/existsP.                            (* exists 2 をする。 *)
  have lt_2_size : 2 < (size [:: a; a; a]).+1 by [].
  exists (Ordinal lt_2_size).

  apply/andP; split.
  - apply/existsP.                          (* exists 1 をする。 *)
    have lt_1_size : 1 <  (size (take 2 [:: a; a; a])).+1 by [].
    exists (Ordinal lt_1_size).
    apply/andP.
    split.
    + simpl.
        by rewrite /atom /=.                  (* atom a [:: a] *)
    + simpl.
        by rewrite /atom /=.                  (* atom a [:: a] *)
  - simpl.
        by rewrite /atom /=.                  (* atom a [:: a] *)
Qed.

(** 正規表現 0* の言語は、{ε} である。  *)
Goal re_lang (Star Eps) [::].
Proof.
  rewrite /re_lang /eps.
  by [].
Qed.

(** 定理 1.10 （クリーネの定理）
言語Lが正規言語なら、かつそのときに限り、言語がLであるような正規表現が存在する。

文献[2]より：
We now call a general language regular if it is equivalent to the language of some
regular expression.
Theorem 3.1 The matching problem for regular expressions is decidable.
Proof This is an immediate consequence of defining the semantics of regular
expressions in terms of decidable languages.

文献[2]ではこの証明は書かれていないで、次が定義されている。
 *)
Definition regular (L : dlang) :=
  exists e : regexp, forall w, L w <-> re_lang e w.

(** 例 *)
Goal regular (re_lang Void).
Proof.
  by exists Void.
Qed.

(** 補足：言語が等しいということ。 *)
Goal L1 = L2 -> L1 =i L2.
Proof.
  move=> H.
  (* Goal : L1 =i L2 *)
  move=> w.
  (* Goal : L1 w = L2 w *)
  apply/(f_equal (fun L => w \in L)).
  (* Goal : L1 = L2 *)
  by [].
Qed.

(* w \in L は、「rewrite /in_mem /mem /=」 で、L w になる。
   実際は、直接 apply できる。
*)
Goal forall (L : dlang), (L w <-> w \in L).
Proof.
  rewrite /in_mem /mem /=.                  (* 不要 *)
  by [].
Qed.

(* END *)


(*********************************************************************

 Zig-zags in categories

 A zig-zag in a category is a finite chain of morphisms like this

 x1 --> x2 <-- x3 --> x4 <-- x5

 In this file, we define the notion of zig-zags and a number of
 operations on them.

 Contents:
 1. Definition of zig-zags
 2. Constructors for zig-zags
 3. Action of functors on zig-zags
 4. Appending zig-zags
 5. Reversing zig-zags
 6. Zig-zags in groupoids give morphisms
 7. Examples of zig-zag notation

 *********************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Groupoids.

Local Open Scope cat.

(**
 1. Definition of zig-zags
 *)
Definition zig_zag_of_length
           {C : category}
           (n : ℕ)
  : ∏ (x y : C), UU.
Proof.
  induction n as [ | n IHn ].
  - exact (λ x y, z_iso x y).
  - exact (λ x y, ∑ (z : C), ((x --> z) ⨿ (z --> x)) × IHn z y).
Defined.

Definition zig_zag
           {C : category}
           (x y : C)
  : UU
  := ∑ (n : ℕ), zig_zag_of_length n x y.

Definition length_of_zig_zag
           {C : category}
           {x y : C}
           (gs : zig_zag x y)
  : ℕ
  := pr1 gs.

(**
 2. Constructors for zig-zags
 *)
Definition empty_zig_zag
           {C : category}
           (x : C)
  : zig_zag x x
  := 0 ,, identity_z_iso x.

Notation "x ■" := (empty_zig_zag x) (at level 40) : cat.

Definition left_cons_zig_zag
           {C : category}
           {x z y : C}
           (f : x --> z)
           (gs : zig_zag z y)
  : zig_zag x y
  := 1 + length_of_zig_zag gs ,, (z ,, (inl f ,, pr2 gs)).

Notation "x -[ f ]-> gs" := (@left_cons_zig_zag _ x _ _ f gs)
                              (at level 41, right associativity) : cat.

Definition right_cons_zig_zag
           {C : category}
           {x z y : C}
           (f : z --> x)
           (gs : zig_zag z y)
  : zig_zag x y
  := 1 + length_of_zig_zag gs ,, (z ,, (inr f ,, pr2 gs)).

Notation "x <-[ f ]- gs" := (@right_cons_zig_zag _ x _ _ f gs)
                              (at level 41, right associativity) : cat.

(**
 3. Action of functors on zig-zags
 *)
Definition functor_on_zig_zag_of_length
           {C₁ C₂ : category}
           (F : C₁ ⟶ C₂)
           {x y : C₁}
           {n : ℕ}
           (gs : zig_zag_of_length n x y)
  : zig_zag_of_length n (F x) (F y).
Proof.
  revert x y gs.
  induction n as [ | n IHn ].
  - intros x y gs.
    exact (functor_on_z_iso F gs).
  - intros x y gs.
    induction gs as [ z gs ].
    induction gs as [ g gs ].
    induction g as [ g | g ].
    + exact (F z ,, inl (#F g) ,, IHn _ _ gs).
    + exact (F z ,, inr (#F g) ,, IHn _ _ gs).
Defined.

Definition functor_on_zig_zag
           {C₁ C₂ : category}
           (F : C₁ ⟶ C₂)
           {x y : C₁}
           (gs : zig_zag x y)
  : zig_zag (F x) (F y)
  := length_of_zig_zag gs ,, functor_on_zig_zag_of_length F (pr2 gs).

(**
 4. Appending zig-zags
 *)
Definition precomp_z_iso_zig_zag_of_length
           {C : category}
           {n : ℕ}
           {x y z : C}
           (fs : zig_zag_of_length n y z)
           (i : z_iso x y)
  : zig_zag_of_length n x z.
Proof.
  revert x y z fs i.
  induction n as [ | n IHn ].
  - intros x y z fs i.
    exact (z_iso_comp i fs).
  - intros x y z fs i.
    induction fs as [ w fs ].
    induction fs as [ f fs ].
    induction f as [ f | f ].
    + exact (w ,, inl (i · f) ,, fs).
    + exact (w ,, inr (f · inv_from_z_iso i) ,, fs).
Defined.

Definition append_zig_zag_of_length
           {C : category}
           {n m : ℕ}
           {x y z : C}
           (fs : zig_zag_of_length n x y)
           (gs : zig_zag_of_length m y z)
  : zig_zag_of_length (n + m) x z.
Proof.
  revert x y z fs gs.
  induction n as [ | n IHn ].
  - intros x y z fs gs.
    exact (precomp_z_iso_zig_zag_of_length gs fs).
  - intros x y z fs gs.
    induction fs as [ w fs ].
    induction fs as [ f fs ].
    induction f as [ f | f ].
    + exact (w ,, inl f ,, IHn w y z fs gs).
    + exact (w ,, inr f ,, IHn w y z fs gs).
Defined.

Definition append_zig_zag
           {C : category}
           {x y z : C}
           (fs : zig_zag x y)
           (gs : zig_zag y z)
  : zig_zag x z
  := length_of_zig_zag fs + length_of_zig_zag gs
     ,,
     append_zig_zag_of_length (pr2 fs) (pr2 gs).

(**
 5. Reversing zig-zags
 *)
Definition post_cons_left_zig_zag_of_length
           {C : category}
           {n : ℕ}
           {x y z : C}
           (gs : zig_zag_of_length n x y)
           (f : y --> z)
  : zig_zag_of_length (S n) x z.
Proof.
  revert x y z gs f.
  induction n as [ | n IHn ].
  - intros x y z gs f.
    exact (z ,, inl (pr1 gs · f) ,, identity_z_iso z).
  - intros x y z gs f.
    induction gs as [ w gs ].
    induction gs as [ g gs ].
    induction g as [ g | g ].
    + exact (w ,, inl g ,, IHn _ _ _ gs f).
    + exact (w ,, inr g ,, IHn _ _ _ gs f).
Defined.

Definition post_cons_right_zig_zag_of_length
           {C : category}
           {n : ℕ}
           {x y z : C}
           (gs : zig_zag_of_length n x y)
           (f : z --> y)
  : zig_zag_of_length (S n) x z.
Proof.
  revert x y z gs f.
  induction n as [ | n IHn ].
  - intros x y z gs f.
    exact (z ,, inr (f · inv_from_z_iso gs) ,, identity_z_iso z).
  - intros x y z gs f.
    induction gs as [ w gs ].
    induction gs as [ g gs ].
    induction g as [ g | g ].
    + exact (w ,, inl g ,, IHn _ _ _ gs f).
    + exact (w ,, inr g ,, IHn _ _ _ gs f).
Defined.

Definition reverse_zig_zag_of_length
           {C : category}
           {n : ℕ}
           {x y : C}
           (gs : zig_zag_of_length n x y)
  : zig_zag_of_length n y x.
Proof.
  revert x y gs.
  induction n as [ | n IHn ].
  - intros x y gs.
    exact (z_iso_inv gs).
  - intros x y gs.
    induction gs as [ z gs ].
    induction gs as [ g gs ].
    induction g as [ g | g ].
    + exact (post_cons_right_zig_zag_of_length (IHn _ _ gs) g).
    + exact (post_cons_left_zig_zag_of_length (IHn _ _ gs) g).
Defined.

Definition reverse_zig_zag
           {C : category}
           {x y : C}
           (gs : zig_zag x y)
  : zig_zag y x
  := length_of_zig_zag gs ,, reverse_zig_zag_of_length (pr2 gs).

(**
 6. Zig-zags in groupoids give morphisms
 *)
Definition zig_zag_of_length_in_grpd_to_mor
           {G : groupoid}
           {n : ℕ}
           {x y : G}
           (gs : zig_zag_of_length n x y)
  : x --> y.
Proof.
  revert x y gs.
  induction n as [ | n IHn ].
  - intros x y gs.
    exact (pr1 gs).
  - intros x y gs.
    induction gs as [ z gs ].
    induction gs as [ g gs ].
    induction g as [ g | g ].
    + exact (g · IHn _ _ gs).
    + exact (inv_from_z_iso (g ,, pr2 G _ _ _) · IHn _ _ gs).
Defined.

Definition zig_zag_in_grpd_to_mor
           {G : groupoid}
           {x y : G}
           (gs : zig_zag x y)
  : x --> y
  := zig_zag_of_length_in_grpd_to_mor (pr2 gs).

(**
 7. Examples of zig-zag notation
 *)
Local Example zig_zag_notation_1
              {C : category}
              {w x y z : C}
              (f : w --> x)
              (g : y --> x)
              (h : y --> z)
  : zig_zag w z
  := w -[ f ]-> x <-[ g ]- y -[ h ]-> z ■.

Local Example zig_zag_notation_2
              {C : category}
              {w x y z : C}
              (f : w --> x)
              (g : x --> y)
              (h : z --> y)
  : zig_zag w z
  := w -[ f ]-> x -[ g ]-> y <-[ h ]- z ■.


Require Import Coq.Arith.PeanoNat.
Require Import Coq.ZArith.ZArith.
Require Import riscv.util.Tactics.

Local Open Scope nat_scope.

Lemma rewrite_div_mod: forall (a b: nat),
    b <> 0 ->
    exists q r, a mod b = r /\ a / b = q /\ a = b * q + r /\ r < b.
Proof.
  intros.
  exists (a / b). exists (a mod b).
  rewrite <- (Nat.div_mod a b) by assumption.
  pose proof (Nat.mod_upper_bound a b).
  auto.
Qed.

Ltac nat_div_mod_to_quot_rem_step :=
  so fun hyporgoal => match hyporgoal with
  | context [?a mod ?b] =>
      let Ne := fresh "Ne" in
      let P := fresh "P" in
      assert (b <> 0) as Ne by omega;
      pose proof (rewrite_div_mod a b Ne) as P;
      clear Ne;
      let q := fresh "q" in
      let r := fresh "r" in
      let Er := fresh "Er" in
      let Eq := fresh "Eq" in
      let E := fresh "E" in
      let B := fresh "B" in
      destruct P as [ q [ r [ Er [ Eq [ E B ] ] ] ] ];
      rewrite? Er in *;
      rewrite? Eq in *;
      clear Er Eq
  end.

Ltac nat_div_mod_to_quot_rem := repeat nat_div_mod_to_quot_rem_step.


(********************************)
(********************************)
(****                        ****)
(****   Product categories   ****)
(****                        ****)
(********************************)
(********************************)

Require Import Main.CategoryTheory.Category.
Require Import Main.CategoryTheory.Functor.
Require Import Main.Tactics.

#[local] Set Universe Polymorphism.

#[local] Open Scope type. (* Parse `*` as `prod` rather than `mul`. *)

#[local] Theorem productCategoryCAssoc
  {C D}
  (w x y z : object C * object D)
  (f : arrow (fst w) (fst x) * arrow (snd w) (snd x))
  (g : arrow (fst x) (fst y) * arrow (snd x) (snd y))
  (h : arrow (fst y) (fst z) * arrow (snd y) (snd z))
: (
    compose
      (fst h)
      (fst (compose (fst g) (fst f), compose (snd g) (snd f))),
    compose
      (snd h)
      (snd (compose (fst g) (fst f), compose (snd g) (snd f)))
  ) = (
    compose
      (fst (compose (fst h) (fst g), compose (snd h) (snd g)))
      (fst f),
    compose
      (snd (compose (fst h) (fst g), compose (snd h) (snd g)))
      (snd f)
  ).
Proof.
  search.
Qed.

#[local] Theorem productCategoryCIdentLeft
  {C D}
  (x y : object C * object D)
  (f : arrow (fst x) (fst y) * arrow (snd x) (snd y))
: (
    compose (fst (@id C (fst y), @id D (snd y))) (fst f),
    compose (snd (@id C (fst y), @id D (snd y))) (snd f)
  ) = f.
Proof.
  search.
Qed.

#[local] Theorem productCategoryCIdentRight
  {C D : category}
  (x y : object C * object D)
  (f : arrow (fst x) (fst y) * arrow (snd x) (snd y))
: (
    compose (fst f) (fst (@id C (fst x), @id D (snd x))),
    compose (snd f) (snd (@id C (fst x), @id D (snd x)))
  ) = f.
Proof.
  search.
Qed.

Definition productCategory C D : category := newCategory
  (object C * object D)
  (fun x y => arrow (fst x) (fst y) * arrow (snd x) (snd y))
  (fun _ _ _ f g => (compose (fst f) (fst g), compose (snd f) (snd g)))
  (fun _ => (id, id))
  productCategoryCAssoc
  productCategoryCIdentLeft
  productCategoryCIdentRight.

#[local] Theorem productCategoryProj1FIdent
  {C D}
  (x : object (productCategory C D))
: fst (@id (productCategory C D) x) = id.
Proof.
  search.
Qed.

#[local] Theorem productCategoryProj1FComp
  {C D}
  (x y z : object (productCategory C D))
  (f : arrow x y)
  (g : arrow y z)
: compose (fst g) (fst f) = fst (compose g f).
Proof.
  search.
Qed.

Definition productCategoryProj1 C D :
  functor (productCategory C D) C := newFunctor
    (productCategory C D)
    C
    fst
    (fun _ _ => fst) productCategoryProj1FIdent productCategoryProj1FComp.

#[local] Theorem productCategoryProj2FIdent
  {C D}
  (x : object (productCategory C D))
: snd (@id (productCategory C D) x) = id.
Proof.
  search.
Qed.

#[local] Theorem productCategoryProj2FComp
  {C D}
  (x y z : object (productCategory C D))
  (f : arrow x y)
  (g : arrow y z)
: compose (snd g) (snd f) = snd (compose g f).
Proof.
  search.
Qed.

Definition productCategoryProj2 C D :
  functor (productCategory C D) D := newFunctor
    (productCategory C D)
    D
    snd
    (fun _ _ => snd) productCategoryProj2FIdent productCategoryProj2FComp.


(**************************************************************)
(*   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 Omega.

(* Require Import tacs. *)

Require Import list_nat list_in list_forall list_prefix.

Set Implicit Arguments.

Section decide.

  Variables X : Type.

  Implicit Type (ll : list X).

  Definition list_choose (P Q : X -> Prop) ll : (forall a, In a ll -> P a \/ Q a)
                                             -> (exists a, In a ll /\ P a)
                                             \/ (forall a, In a ll -> Q a).
  Proof.
    induction ll as [ | x ll IH ]; intros HP.
    right; intros ? [].
    destruct IH as [ (z & H1 & H2) | IH ].
    intros z Hz; apply HP; right; auto.
    left; exists z; split; auto; right; auto.
    destruct (HP x) as [ H3 | H3 ].
    left; auto.
    left; exists x; split; auto; left; auto.
    right; intros q [ | Hq]; auto; intros; subst; auto.
  Qed.

  (* for an heterogeneous list [P x1 + Q x1;...;Pxn + Q xn], either find i s.t. P xi or
     a proof that for any j, Q xj *)

  Definition list_dep_choice_rect ll (P Q : forall x, In_t x ll -> Type) :
       (forall x Hx, P x Hx + Q x Hx)
    -> { x : _ & { Hx : In_t x ll & P x Hx } }
     + (forall x Hx, Q x Hx).
  Proof.
    revert P Q.
    induction ll as [ | x ll IH ]; intros P Q HP.
    right; intros ? [].
    specialize (IH (fun x Hx => P _ (inr Hx)) (fun x Hx => Q _ (inr Hx))).
    destruct IH as [ (z & H1 & H2) | IH ].
    intros z Hz; apply HP; right; auto.
    left; exists z, (inr H1); auto.
    destruct (HP _ (inl eq_refl)) as [ H3 | H3 ].
    left; exists x, (inl eq_refl); auto.
    right; intros q [ | Hq]; auto; intros; subst; auto.
  Qed.

  Definition list_dep_choice_ind ll (P Q : forall x : X, In_t x ll -> Prop) :
    (forall x Hx, P x Hx \/ Q x Hx) -> (exists x Hx, P x Hx) \/ forall x Hx, Q x Hx.
  Proof.
    revert P Q.
    induction ll as [ | x ll IH ]; intros P Q HPQ.
    right; intros ? [].
    destruct (IH (fun x Hx => P _ (inr Hx)) (fun x Hx => Q _ (inr _ Hx))) as [ (z & H1 & H2) | IH' ].
    intros z Hz; apply HPQ; right; auto.
    left; exists z, (inr H1); auto.
    destruct (HPQ x (inl eq_refl)) as [ H3 | H3 ].
    left; exists x, (inl eq_refl); auto.
    right; intros q [ Hq | Hq]; subst; auto.
  Qed.

  Definition list_choose_rect (P Q : X -> Type) ll :
       (forall x, In_t x ll -> P x + Q x)
    -> { z : _ & (In_t z ll * P z)%type }
     + (forall z, In_t z ll -> Q z).
  Proof.
    intros H.
    destruct (list_dep_choice_rect ll (fun x _ => P x) (fun x _ => Q x) H) as [ (x & H1 & H2) | H1 ].
    left; exists x; auto.
    right; auto.
  Qed.

  Definition list_choose_ind (P Q : X -> Prop) ll :
       (forall x, In x ll -> P x \/ Q x)
    -> (exists z, In z ll /\ P z) \/ forall z, In z ll -> Q z.
  Proof.
    intros H.
    rewrite <- In_In_t in H.
    destruct (list_dep_choice_ind ll (fun x _ => P x) (fun x _ => Q x) H) as [ (x & H1 & H2) | H1 ].
    left; exists x; split; auto; apply In_t_In; auto.
    right; apply In_In_t; auto.
  Qed.

  Definition list_choose_rec (P Q : X -> Prop) ll :
    (forall x, In x ll -> {P x} + {Q x}) -> { z | In z ll /\ P z } + { forall z, In z ll -> Q z }.
  Proof.
    intros H.
    destruct (list_choose_rect P Q ll) as [ (z & H1 & H2) | H1 ].
    intros x Hx; destruct (H x); try tauto; apply In_t_In; auto.
    left; exists z; split; auto; apply In_t_In; auto.
    right; apply In_In_t; auto.
  Qed.

  Variable P : X -> Prop.

  Definition list_dec_rec ll :
    (forall x, In x ll -> {P x} + {~ P x}) -> { z | In z ll /\ P z } + { forall z, In z ll -> ~ P z }.
  Proof.
    apply list_choose_rec.
  Qed.

  Corollary list_reif_dec ll :
    (forall x, In x ll -> {P x} + {~ P x}) -> (exists x, P x /\ In x ll) -> { x | P x /\ In x ll }.
  Proof.
    intros Pdec H.
    destruct list_dec_rec with (ll := ll) as [ (x & ? & ?) | H0 ]; auto.
    exists x; auto.
    contradict H.
    intros (x & ? & ?); apply (H0 x); auto.
  Qed.

  Definition list_dec_ind ll :
    (forall x, In x ll -> P x \/ ~ P x) -> (exists z, In z ll /\ P z ) \/ forall z, In z ll -> ~ P z.
  Proof.
    apply list_choose_ind.
  Qed.

End decide.

Section list_eq_dec.

  Variable (X : Type).

  Fact list_eq_dect ll mm :  (forall x y : X, In_t x ll -> In_t y mm -> { x = y } + { x <> y })
                         -> { ll = mm } + { ll <> mm }.
  Proof.
    revert mm; induction ll as [ | x ll ]; intros [ | y mm ] H.
    left; auto.
    right; discriminate.
    right; discriminate.
    destruct (H x y) as [ H1 | H1 ]; try (left; auto; fail).
    subst y.
    destruct (IHll mm) as [ H2 | H2 ].
    intros; apply H; right; auto.
    subst mm; left; auto.
    right; contradict H2; injection H2; auto.
    right; contradict H1; injection H1; auto.
  Qed.

  Fact list_eq_dec ll mm :  (forall x y : X, In x ll -> In y mm -> { x = y } + { x <> y })
                         -> { ll = mm } + { ll <> mm }.
  Proof.
    intros H; apply list_eq_dect.
    intros; apply H; apply In_t_In; auto.
  Qed.

End list_eq_dec.

Section finite_decision.

  Variables (X : Type) (P : X -> Prop).

  (* Given x in ll s.t. P x, finds the first among them, i.e. y in ll s.t. P y
     and ~ P z for any z before y *)

  Fact In_first ll : (forall x, In x ll -> P x \/ ~ P x)
                   -> forall x, In x ll -> P x -> exists l y r, ll = l++y::r
                                                    /\ P y
                                                    /\ forall z, In z l -> ~ P z.
  Proof.
    induction ll as [ | y ll IH ]; simpl; intros Hll x H1 H2; destruct H1.
    subst; exists nil, x, ll; repeat split; auto.
    destruct (Hll y) as [ Hy | Hy ]; auto.
    exists nil, y, ll; repeat split; auto.
    destruct IH with (3 := H2) as (l & z & r & H3 & H4 & H5); auto.
    subst; exists (y::l), z, r; repeat split; auto.
    intros k [ ? | ? ].
    subst k; auto.
    apply H5; auto.
  Qed.

  Variable Q : list X -> list X -> Prop.

  (* if Q is decidable over the splits l++r of ll and Q nil ll holds then
     there is prefix l s.t Q l' r' holds whenever l' <= l
     and Q l' r' does not hold for the successor prefix of l'
     (if it exists).

  *)

  Definition largest_list_prefix ll : (forall l r, ll = l++r -> { Q l r } + { ~ Q l r })
                                   -> Q nil ll
                                   -> { l : _ & { r | ll = l++r
                                                   /\ Q l r
                                                   /\ (forall l' r', ll = l'++r' -> length l' = S (length l) -> ~ Q l' r')
                                                   /\ (forall l' r', ll = l'++r' -> length l' <= length l    ->   Q l' r') } }.
  Proof.
    intros HQ H0.
    set (K n := forall l r, ll = l++r -> length l = n -> Q l r).
    destruct (@largest_nat_prefix (length ll) K) as (i & H1 & H2 & H3 & H3').
    intros i Hi; unfold K.
    destruct (list_prefix _ Hi) as (l & r & H1 & H2).
    destruct (HQ _ _ H1) as [ H5 | H5 ].
    left.
    intros l' r' H3 H4; subst.
    destruct list_prefix_eq with (1 := H3); try omega; subst; auto.
    right; contradict H5; apply H5; auto.
    red.
    intros l r H1 H2 .
    destruct (list_prefix_eq l r nil ll); auto.
    subst l r; auto.
    destruct (list_prefix _ H1) as (l & r & H4 & H5).
    exists l, r.
    repeat split; auto.

    intros l' r' H6 H7.
    intros H8.
    assert (K (S i)) as C.
      red.
      intros l'' r'' H9 H10.
      rewrite <- H5, <- H7 in H10.
      rewrite H6 in H9.
      destruct list_prefix_eq with (1 := H9); auto.
      subst l'' r''; auto.
    apply H3 in C.
    apply f_equal with (f := @length X) in H6.
    rewrite app_length in H6.
    omega.

    intros l' r' H6 H7.
    rewrite H5 in H7.
    apply H3' in H7.
    apply H7; auto.
  Defined.

  Variables (R : list X -> X -> list X -> Prop).

  Definition list_find_split ll : (forall l x r, ll = l++x::r -> { R l x r } + { ~ R l x r })
                               -> { l : _ & { x : _ & { r | ll = l++x::r /\ R l x r } } }
                                + { forall l x r, ll = l++x::r -> ~ R l x r }.
  Proof.
    revert R.
    induction ll as [ | x ll IH ]; intros R HR.
    right; intros [ | ] ? ?; discriminate 1.
    destruct (HR nil x ll) as [ H0 | H0 ]; auto.
    left; exists nil, x, ll; auto.
    destruct (IH (fun l y r => R (x::l) y r)) as [ (l & y & r & H1 & H2) | H1 ].
    intros; apply HR; simpl; f_equal; auto.
    left; exists (x::l), y, r; split; simpl; auto; f_equal; auto.
    right.
    intros l y r H2.
    destruct l as [ | k l ];
    injection H2; intros; subst; auto.
  Defined.

End finite_decision.

Fact Forall_dec X (P : X -> Prop) ll :
       (forall x, In x ll -> { P x } + { ~ P x })
   -> { Forall P ll } + { ~ Forall P ll }.
Proof.
  intros H.
  destruct (list_choose_rec (fun x => ~ P x) P ll) as [ (x & H1 & H2) | H1 ].
  intros x Hx; specialize (H _ Hx); tauto.
  right; contradict H2; rewrite Forall_forall in H2; apply H2; auto.
  rewrite <- Forall_forall in H1; tauto.
Qed.

Fact finite_fall_disj U (P : U -> Prop) (Q : Prop) l : (forall u, In u l -> P u) \/ Q <-> forall u, In u l -> P u \/ Q.
Proof.
  split.
  intros [ H | H ] u Hu.
  left; auto.
  right; auto.
  intros H.
  destruct (list_choose (fun _ => Q) P l) as [ (u & H1 & H2) | H1 ].
  intros a; specialize (H a); tauto.
  right; auto.
  left; auto.
Qed.

Section combi_principle.

  Let seq (l : list Type) := forall X, In_t X l -> X.

  Let empseq : seq nil.
  Proof. intros ? []. Defined.

  Let consseq X (l : list Type) (a : X) : seq l -> seq (X::l).
  Proof.
    intros H Y [ HY | HY ].
    subst; apply a.
    apply (H _ HY).
  Defined.

(*
  Let hd X l : seq (X::l) -> X.
  Proof. intros H; apply (H _ (inl eq_refl)). Defined.

  Definition tl X l : seq (X::l) -> seq l.
  Proof. intros H Y HY; apply (H _ (inr HY)). Defined.
*)

  (* the combinatorial principle of page 241
     in a purely intuitionistic way

     Beware than universal quantification should be finite here otherwise
     we cannot replace (forall u, P u \/ Q) with (forall u, Pu) \/ Q

  *)

  Fact combi_principle (l : list Type) (A : forall X, In_t X l -> list X)
                                       (P : seq l -> Prop)
                                       (B : forall X, In_t X l -> X -> Prop) :
        (forall a : seq l, (forall X HX, In (a X HX) (A X HX)) -> P a \/ exists X HX, B X HX (a X HX))
     -> (exists a, P a /\ forall X HX, In (a X HX) (A X HX)) \/ exists X HX, forall x, In x (A X HX) -> B X HX x.
  Proof.
    revert A P B; induction l as [ | X l IH ]; intros A P B H.

    destruct (H empseq) as [ H1 | (? & [] & _) ].
    intros ? [].
    left; exists empseq; split; auto.
    intros ? [].

    set (P' s := forall a, In a (A _ (inl eq_refl)) -> P (consseq a s)\/ B _ (inl eq_refl) a).
    set (A' X HX := A X (inr HX)).
    set (B' X HX := B X (inr HX)).

    destruct (IH A' P' B') as [ (a & Ha & Ha') | (Y & HY1 & HY2) ].

    intros s Hs.
    unfold P'.
    apply finite_fall_disj.
    intros a Ha.
    destruct (H (consseq a s)) as [ H1 | (Y & HY & H1) ].
    intros Y [ HY | HY ]; subst; auto; apply Hs.
    left; left; auto.
    destruct HY as [ HY | HY ].
    subst Y.
    left; right; apply H1.
    right.
    exists Y, HY; apply H1.

    red in Ha.
    apply list_choose in Ha.
    destruct Ha as [ (Y & H1 & H2) | H1 ].
    left; exists (consseq Y a); split; auto.
    intros ? [ ? | ? ]; subst; auto; apply Ha'.
    right; exists X, (inl eq_refl); auto.

    unfold A', B' in HY2.
    right; exists Y, (inr HY1); auto.
  Qed.

End combi_principle.

Section list_fan_combi_principle.

  Variable X : Type.

  Fact list_fan_combi_principle ll P :
               (forall p, Forall2 (@In X) p (map (@fst _ _) ll)
                       -> P p \/ Exists2 (fun x B => B x) p (map (@snd _ _) ll))
            -> (exists p, Forall2 (@In _) p (map (@fst _ _) ll) /\ P p)
            \/ (exists A B, In (A,B) ll/\ forall x, In x A -> B x).
  Proof.
    revert P.
    induction ll as [ | (A,B) ll IH ]; intros P Hll.

    destruct (Hll nil) as [ H0 | H0 ]; simpl; auto.
    left; exists nil; simpl; auto.
    apply Exists2_nil_inv in H0; destruct H0.

    set (P' l := forall a, In a A -> P (a::l) \/ B a).
    destruct (IH P') as [ (p & H1 & H2) | (A1 & B1 & H1 & H2) ].

    intros l Hl.
    unfold P'.
    apply finite_fall_disj.
    intros a Ha.
    destruct (Hll (a::l)) as [ H1 | H1 ].
    simpl; constructor; auto.
    tauto.
    simpl in H1.
    apply Exists2_cons_inv in H1; tauto.

    apply list_choose in H2.
    destruct H2 as [ (a & H2 & H3) | H2 ].
    left; exists (a::p); simpl; split; auto.
    right; exists A, B; simpl; split; auto.

    right; exists A1, B1; simpl; split; auto.
  Qed.

End list_fan_combi_principle.

Section hig_combi_principle.

  Variable X : Type.
  Variable ll : list (list X).
  Variable P : list X -> Prop.
  Variable B : X -> Prop.

  Fact hig_combi_principle :
               (forall p, Forall2 (@In X) p ll -> P p \/ exists x, In x p /\ B x)
            -> (exists p, Forall2 (@In _) p ll /\ P p)
            \/ (exists A, In A ll/\ forall x, In x A -> B x).
  Proof.
    intros H.
    set (ll' := map (fun x => (x,B)) ll).
    destruct (list_fan_combi_principle ll' P) as [ (p & H1 & H2) | (A & B' & H1 & H2) ].

    intros p Hp.
    unfold ll' in Hp.
    rewrite map_map, map_id in Hp.
    destruct (H p) as [ H1 | (x & H1 & H2) ]; auto.
    right.
    unfold ll'; rewrite map_map; simpl.

    clear H ll'.
    induction Hp.
    destruct H1.
    destruct H1 as [ H1 | H1 ].
    subst; simpl.
    constructor 1; auto.
    rewrite map_length.
    revert Hp; apply Forall2_length.
    constructor 2; auto.

    left; exists p; split; auto.
    unfold ll' in H1; rewrite map_map, map_id in H1; auto.

    unfold ll' in H1.
    rewrite in_map_iff in H1.
    destruct H1 as (A' & H1 & H3).
    injection H1; intros; subst A' B'.
    right; exists A; auto.
  Qed.

End hig_combi_principle.

Section list_decide_special.

  Section one.

    Variable (X Y : Type) (Q R S : X -> Y -> Prop).

    Hypothesis HQ : forall x y, Q x y -> R x y \/ S x y.

    Fact one_list_decide ll : (forall x, In x ll -> exists y, Q x y)
                           -> (forall x, In x ll -> exists y, R x y)
                           \/ (exists x y, In x ll /\ S x y).
    Proof.
      intros H.
      destruct (list_choose_ind (fun x => exists y, S x y) (fun x => exists y, R x y) ll) as [ (x & H1 & y & H2) | H1 ].
      intros x Hx; destruct (H _ Hx) as (y & Hy).
      apply HQ in Hy.
      destruct Hy; [ right | left ]; exists y; auto.
      right; exists x, y; split; auto; apply In_t_In; auto.
      left; auto.
    Qed.

  End one.

  Section two_prop.

    Variable (X Y : Type) (P S : X -> Y -> Prop) (Q : X -> Prop) (R : Y -> Prop).

    Hypothesis HQ : forall x y, P x y -> Q x \/ R y \/ S x y.

    Variables (ll : list X) (mm : list Y).

    Let A : forall T, In_t T (X::Y::nil) -> list T.
    Proof.
      intros T [ ? | [ ? | [] ] ]; subst T.
      exact ll.
      exact mm.
    Defined.

    Let PA : (forall T, In_t T (X::Y::nil) -> T) -> Prop.
    Proof.
      intros H.
      apply S; apply H.
      left; auto.
      right; left; auto.
    Defined.

    Let PB : forall T, In_t T (X::Y::nil) -> T -> Prop.
    Proof.
      intros T [ ? | [ ? | [] ] ]; subst T.
      apply Q.
      apply R.
    Defined.

    Fact two_list_decide_prop       : (forall x y, In x ll -> In y mm -> P x y)
                                   -> (forall x, In x ll -> Q x)
                                   \/ (forall y, In y mm -> R y)
                                   \/ (exists x y, In x ll /\ In y mm /\ S x y).
    Proof.
      intros HP.
      destruct (@combi_principle (X::Y::nil) A PA PB) as [ (a & H1 & H2) | (X0 & HX0 & H1) ] .

      intros f Hf.
      generalize (Hf _ (inl eq_refl)) (Hf _ (inr (inl eq_refl))).
      simpl; unfold eq_rect_r; simpl.
      clear Hf; intros HX HY.
      destruct (HQ (HP _ _ HX HY)) as [ H | [ H | H ] ].
      right; exists X, (inl eq_refl); cbv; auto.
      right; exists Y, (inr (inl eq_refl)); cbv; auto.
      left; cbv; auto.

      cbv in H1.
      right; right.
      exists (a X (inl eq_refl)), (a Y (inr (inl eq_refl))); repeat split; auto; apply H2.

      destruct HX0 as [ ? | [ ? | [] ] ]; subst.

      left; apply H1.
      right; left; apply H1.
    Qed.

  End two_prop.

  Section two.

    Variable (X Y Z : Type) (P S : X -> Y -> Z -> Prop) (Q : X -> Z -> Prop) (R : Y -> Z -> Prop).

    Hypothesis HP : forall x y z, P x y z -> Q x z \/ R y z \/ S x y z.

    Fact two_list_decide ll mm : (forall x y, In x ll -> In y mm -> exists z, P x y z)
                              -> (forall x, In x ll -> exists z, Q x z)
                              \/ (forall y, In y mm -> exists z, R y z)
                              \/ (exists x y z, In x ll /\ In y mm /\ S x y z).
    Proof.
      intros H.
      destruct (two_list_decide_prop (fun x y => exists z, P x y z)
                                     (fun x y => exists z, S x y z)
                                     (fun x   => exists z, Q x z)
                                     (fun   y => exists z, R y z)
            ) with (2 := H) as [ HQ | [ HR | HS ] ]; try tauto.

      intros x y (z & Hz); apply HP in Hz; destruct Hz as [ | [|] ].
      left; exists z; auto.
      right; left; exists z; auto.
      right; right; exists z; auto.

      destruct HS as (x & y & ? & ? & z & ?).
      right; right; exists x, y, z; auto.
    Qed.

  End two.

End list_decide_special.


Require Import Basics.
Require Import Types.
Require Import HProp.
Require Import HSet.
Require Import TruncType.
Require Import UnivalenceImpliesFunext.
Require Import Colimits.Pushout Truncations HIT.SetCone.

Local Open Scope path_scope.

Section AssumingUA.
Context `{ua:Univalence}.

(** We will now prove that for sets, epis and surjections are equivalent.*)
Definition isepi {X Y} `(f:X->Y) := forall Z: hSet,
  forall g h: Y -> Z, g o f = h o f -> g = h.

Definition isepi' {X Y} `(f : X -> Y) :=
  forall (Z : hSet) (g : Y -> Z), Contr { h : Y -> Z | g o f = h o f }.

Lemma equiv_isepi_isepi' {X Y} f : @isepi X Y f <~> @isepi' X Y f.
Proof.
  unfold isepi, isepi'.
  apply (@equiv_functor_forall' _ _ _ _ _ (equiv_idmap _)); intro Z.
  apply (@equiv_functor_forall' _ _ _ _ _ (equiv_idmap _)); intro g.
  unfold equiv_idmap; simpl.
  refine (transitivity (@equiv_sigT_ind _ (fun h : Y -> Z => g o f = h o f) (fun h => g = h.1)) _).
  (** TODO(JasonGross): Can we do this entirely by chaining equivalences? *)
  apply equiv_iff_hprop.
  { intro hepi.
    refine {| center := (g; idpath) |}.
    intro xy; specialize (hepi xy).
    apply path_sigma_uncurried.
    exists hepi.
    apply path_ishprop. }
  { intros hepi xy.
    exact (ap pr1 ((contr (g; 1))^ @ contr xy)). }
Defined.

Section cones.
  Lemma isepi'_contr_cone `{Funext} {A B : hSet} (f : A -> B) : isepi' f -> Contr (setcone f).
  Proof.
    intros hepi.
    exists (setcone_point _).
    pose (alpha1 := @pglue A B Unit f (const tt)).
    pose (tot:= { h : B -> setcone f & tr o push o inl o f = h o f }).
    transparent assert (l : tot).
    { simple refine (tr o _ o inl; _).
      { refine push. }
      { refine idpath. } }
    pose (r := (@const B (setcone f) (setcone_point _); (ap (fun f => @tr 0 _ o f) (path_forall _ _ alpha1))) : tot).
    subst tot.
    assert (X : l = r).
      { let lem := constr:(fun X push' => hepi (BuildhSet (setcone f)) (tr o push' o @inl _ X)) in
        pose (lem _ push).
        refine (path_contr l r). }
    subst l r.

    pose (I0 b := ap10 (X ..1) b).
    refine (Trunc_ind _ _).
    pose (fun a : B + Unit => (match a as a return setcone_point _ = tr (push a) with
                                 | inl a' => (I0 a')^
                                 | inr tt => idpath
                               end)) as I0f.
    refine (Pushout_ind _ (fun a' => I0f (inl a')) (fun u => (I0f (inr u))) _).

    simpl. subst alpha1. intros.
    unfold setcone_point.
    subst I0. simpl.
    pose (X..2) as p. simpl in p.
    rewrite (transport_precompose f _ _ X..1) in p.
    assert (H':=concat (ap (fun x => ap10 x a) p) (ap10_ap_postcompose tr (path_arrow (pushl o f) (pushr o const tt) pglue) _)).
    rewrite ap10_path_arrow in H'.
    clear p.
    (** Apparently [pose; clearbody] is only ~.8 seconds, while [pose proof] is ~4 seconds? *)
    pose (concat (ap10_ap_precompose f (X ..1) a)^ H') as p.
    clearbody p.
    simpl in p.
    rewrite p.
    rewrite transport_paths_Fr.
    apply concat_Vp.
  Qed.
End cones.

Lemma issurj_isepi {X Y} (f:X->Y): IsSurjection f -> isepi f.
Proof.
intros sur ? ? ? ep. apply path_forall. intro y.
specialize (sur y). pose (center (merely (hfiber f y))).
apply (Trunc_rec (n:=-1) (A:=(sigT (fun x : X => f x = y))));
  try assumption.
intros [x p]. set (p0:=apD10 ep x).
transitivity (g (f x)).
- by apply ap.
- transitivity (h (f x));auto with path_hints. by apply ap.
Qed.

(** Old-style proof using polymorphic Omega. Needs resizing for the isepi proof to live in the
 same universe as X and Y (the Z quantifier is instantiated with an hSet at a level higher)
<<
Lemma isepi_issurj {X Y} (f:X->Y): isepi f -> issurj f.
Proof.
  intros epif y.
  set (g :=fun _:Y => Unit_hp).
  set (h:=(fun y:Y => (hp (hexists (fun _ : Unit => {x:X & y = (f x)})) _ ))).
  assert (X1: g o f = h o f ).
  - apply path_forall. intro x. apply path_equiv_biimp_rec;[|done].
    intros _ . apply min1. exists tt. by (exists x).
  - specialize (epif _ g h).
    specialize (epif X1). clear X1.
    set (p:=apD10 epif y).
    apply (@minus1Trunc_map (sigT (fun _ : Unit => sigT (fun x : X => y = f x)))).
    + intros [ _ [x eq]].
      exists x.
        by symmetry.
    + apply (transport hproptype p tt).
Defined.
>> *)

Section isepi_issurj.
  Context {X Y : hSet} (f : X -> Y) (Hisepi : isepi f).
  Definition epif := equiv_isepi_isepi' _ Hisepi.
  Definition fam (c : setcone f) : hProp.
  Proof.
    pose (fib y := hexists (fun x : X => f x = y)).
    apply (fun f => @Trunc_rec _ _ hProp _ f c).
    refine (Pushout_rec hProp fib (fun _ => Unit_hp) (fun x => _)).
    (** Prove that the truncated sigma is equivalent to Unit *)
    pose (contr_inhabited_hprop (fib (f x)) (tr (x; idpath))) as i.
    apply path_hprop. simpl. simpl in i.
    apply (equiv_contr_unit).
  Defined.

  Lemma isepi_issurj : IsSurjection f.
  Proof.
    intros y.
    pose (i := isepi'_contr_cone _ epif).

    assert (X0 : forall x : setcone f, fam x = fam (setcone_point f)).
    { intros. apply contr_dom_equiv. apply i. }
    specialize (X0 (tr (push (inl y)))). simpl in X0.
    exact (transport Contr (ap trunctype_type X0)^ _).
  Defined.
End isepi_issurj.

Lemma isepi_isequiv X Y (f : X -> Y) `{IsEquiv _ _ f}
: isepi f.
Proof.
  intros ? g h H'.
  apply ap10 in H'.
  apply path_forall.
  intro x.
  transitivity (g (f (f^-1 x))).
  - by rewrite eisretr.
  - transitivity (h (f (f^-1 x))).
    * apply H'.
    * by rewrite eisretr.
Qed.
End AssumingUA.


Require Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Basics.

Require Import Coq.Bool.Bool.

Require Import Coq.Relations.Relation_Definitions.

Require Import Graph.
Require Import ReducedHomo.

Open Scope program_scope.

(* Remove the empty leaves around an operator *)
Definition kSimpl {A: Type} (c : Graph A -> Graph A -> Graph A) (x y:Graph A) :=
  if isEmpty x
  then if isEmpty y
    then Empty
    else y
  else if isEmpty y
    then x
    else c x y.

Definition dropEmpty {A:Type} (g:Graph A) := foldg Empty Vertex (kSimpl Overlay) (kSimpl Connect) g.

Definition induce {A:Type} (pred : A -> bool) (g:Graph A) :=
  foldg Empty (fun x => if pred x then Vertex x else Empty) (kSimpl Overlay) (kSimpl Connect) g.

(* A smart homomorphism is a graph morphism where you have removed empty leaves *)
Definition Smart_hom {A B} (f : Graph A -> Graph B) : Prop :=
  f = dropEmpty ∘ (bind (compose f Vertex)).

Lemma smart_hom_empty {A B}  {f : Graph A -> Graph B}: Smart_hom f -> f Empty = Empty.
Proof.
  intros H.
  rewrite H.
  reflexivity.
Qed.

Lemma smart_hom_overlay {A B} {f : Graph A -> Graph B} (a b: Graph A):
  Smart_hom f -> f (Overlay a b) = kSimpl Overlay (f a) (f b).
Proof.
  intros H.
  rewrite H.
  reflexivity.
Qed.

Lemma smart_hom_connect {A B} {f : Graph A -> Graph B} (a b: Graph A) :
  Smart_hom f -> f (Connect a b) = kSimpl Connect (f a) (f b).
Proof.
  intros H.
  rewrite H.
  reflexivity.
Qed.

(* A smart homomorphism is a foldg-function *)
Theorem smart_hom_single {A B} {f : Graph A -> Graph B} :
  Smart_hom f -> f = foldg Empty (fun v => f (Vertex v)) (kSimpl Overlay) (kSimpl Connect).
Proof.
  intros S.
  apply FunctionalExtensionality.functional_extensionality.
  intros g.
  induction g.
  - rewrite (smart_hom_empty S). auto.
  - reflexivity.
  - rewrite foldg_overlay.
    rewrite (eq_sym IHg1).
    rewrite (eq_sym IHg2).
    rewrite (smart_hom_overlay g1 g2 S).
    reflexivity.
  - rewrite foldg_connect.
    rewrite (eq_sym IHg1).
    rewrite (eq_sym IHg2).
    rewrite (smart_hom_connect g1 g2 S).
    reflexivity.
Qed.

Lemma f_inside_if {A B} (f : A -> B) (x:bool) (a1 a2:A) : f (if x then a1 else a2) = if x then f a1 else f a2.
Proof.
  induction x.
  - auto.
  - auto.
Qed.

Theorem induce_smart_hom (A:Type) (pred : A -> bool) : Smart_hom (induce pred).
Proof.
  unfold Smart_hom.
  apply FunctionalExtensionality.functional_extensionality.
  intro x.
  induction x.
  - auto.
  - unfold compose; unfold bind; unfold induce; unfold foldg.
    rewrite (f_inside_if dropEmpty (pred a)).
    unfold dropEmpty; unfold foldg.
    reflexivity.
  - unfold induce; unfold compose; unfold dropEmpty.
    rewrite foldg_overlay.
    fold (induce pred x1); rewrite IHx1.
    fold (induce pred x2); rewrite IHx2.
    auto.
  - unfold induce; unfold compose; unfold dropEmpty.
    rewrite foldg_connect.
    fold (induce pred x1); rewrite IHx1.
    fold (induce pred x2); rewrite IHx2.
    auto.
Qed.

Lemma r_ov_empty {A} {R: relation (Graph A)} {a b: Graph A} `{EqG A R} :
   R a Empty -> R b Empty -> R (Overlay a b) Empty.
Proof.
  intros ra rb.
  rewrite rb.
  rewrite (id_Plus a).
  exact ra.
Qed.

Lemma r_co_empty {A} {R: relation (Graph A)} {a b: Graph A} `{EqG A R} :
  R a Empty -> R b Empty -> R (Connect a b) Empty.
Proof.
  intros ra rb.
  rewrite rb.
  rewrite EqG_TimesRightId.
  exact ra.
Qed.

Lemma is_empty_R A (R: relation (Graph A)) (g:Graph A): EqG A R -> isEmpty g = true -> R g Empty.
Proof.
  intros E i.
  induction g.
  - reflexivity.
  - discriminate.
  - unfold isEmpty in i.
    rewrite foldg_overlay in i.
    rewrite andb_true_iff in i.
    fold (isEmpty g1) in i; fold (isEmpty g2) in i.
    destruct i.
    apply IHg1 in H; apply IHg2 in H0.
    rewrite H0.
    rewrite (id_Plus g1).
    exact H.
  - unfold isEmpty in i.
    rewrite foldg_connect in i.
    rewrite andb_true_iff in i.
    fold (isEmpty g1) in i; fold (isEmpty g2) in i.
    destruct i.
    apply IHg1 in H; apply IHg2 in H0.
    rewrite H0.
    rewrite EqG_TimesRightId.
    exact H.
Qed.

(* A smart homomorphism is a reduced homomorphism *)
Theorem smart_hom_is_reduced_hom A B (R: relation (Graph B)) (f : Graph A -> Graph B) :
  EqG B R -> Smart_hom f -> Reduced_hom R f.
Proof.
  intros H S.
  split.
  - exact H.
  - rewrite (smart_hom_empty S).
    reflexivity.
  - intros a b.
    rewrite (smart_hom_overlay a b S).
    unfold kSimpl.
    destruct (bool_dec (isEmpty (f a)) true); destruct (bool_dec (isEmpty (f b)) true).
   -- rewrite e; rewrite e0.
      symmetry.
      apply r_ov_empty.
      apply (is_empty_R B R (f a) H). exact e.
      apply (is_empty_R B R (f b) H). exact e0.
   -- rewrite e; rewrite (not_true_is_false (isEmpty (f b)) n).
      rewrite (is_empty_R B R (f a) H e).
      rewrite EqG_PlusCommut.
      rewrite (id_Plus (f b)).
      reflexivity.
   -- rewrite (not_true_is_false (isEmpty (f a)) n); rewrite e.
      rewrite (is_empty_R B R (f b) H e).
      rewrite (id_Plus (f a)).
      reflexivity.
   -- rewrite (not_true_is_false (isEmpty (f a)) n).
      rewrite (not_true_is_false (isEmpty (f b)) n0).
      reflexivity.
  - intros a b.
    rewrite (smart_hom_connect a b S).
    unfold kSimpl.
    destruct (bool_dec (isEmpty (f a)) true); destruct (bool_dec (isEmpty (f b)) true).
   -- rewrite e; rewrite e0.
      symmetry.
      apply r_co_empty.
      apply (is_empty_R B R (f a) H); exact e.
      apply (is_empty_R B R (f b) H); exact e0.
   -- rewrite e; rewrite (not_true_is_false (isEmpty (f b)) n).
      rewrite (is_empty_R B R (f a) H e).
      rewrite (timesLeftId (f b)). reflexivity.
   -- rewrite (not_true_is_false (isEmpty (f a)) n); rewrite e.
      rewrite (is_empty_R B R (f b) H e).
      rewrite EqG_TimesRightId.
      reflexivity.
   -- rewrite (not_true_is_false (isEmpty (f a)) n).
      rewrite (not_true_is_false (isEmpty (f b)) n0).
      reflexivity.
Qed.

Lemma smart_hom_e A B (f : Graph A -> Graph B) (x : Graph A) :
  Smart_hom f -> isEmpty x = true -> f x = Empty.
Proof.
  intros S i.
  rewrite (smart_hom_single S).
  induction x.
  - auto.
  - compute in i.
    discriminate i.
  - rewrite foldg_overlay.
    unfold isEmpty in i.
    rewrite foldg_overlay in i.
    fold (isEmpty x1) in i.
    fold (isEmpty x2) in i.
    rewrite andb_true_iff in i.
    destruct i as (i1,i2).
    apply IHx1 in i1; rewrite i1.
    apply IHx2 in i2; rewrite i2.
    auto.
  - rewrite foldg_connect.
    unfold isEmpty in i.
    rewrite foldg_connect in i.
    fold (isEmpty x1) in i.
    fold (isEmpty x2) in i.
    rewrite andb_true_iff in i.
    destruct i as (i1,i2).
    apply IHx1 in i1; rewrite i1.
    apply IHx2 in i2; rewrite i2.
    auto.
Qed.

Lemma smart_hom_isE A B (f : Graph A -> Graph B) (x : Graph A) :
  Smart_hom f -> isEmpty x = true -> isEmpty (f x) = true.
Proof.
  intros S i.
  rewrite (smart_hom_e A B f x S i).
  auto.
Qed.

Lemma isEmpty_kSimpl A c (x y : Graph A) :
   c = Overlay \/ c = Connect -> isEmpty (kSimpl c x y) = true -> isEmpty x = true /\ isEmpty y = true.
Proof.
  intros H i.
  unfold kSimpl in i.
  destruct (bool_dec (isEmpty x) true); destruct (bool_dec (isEmpty y) true).
  - rewrite e. rewrite e0. auto.
  - rewrite e.
    split. auto.
    rewrite e in i.
    rewrite (not_true_is_false (isEmpty y) n) in i.
    exact i.
  - rewrite e.
    split. auto.
    rewrite e in i.
    rewrite (not_true_is_false (isEmpty x) n) in i.
    exact i. auto.
  - rewrite (not_true_is_false (isEmpty x) n) in i.
    rewrite (not_true_is_false (isEmpty y) n0) in i.
    destruct H.
 -- rewrite H in i.
    unfold isEmpty in i.
    rewrite foldg_overlay in i.
    fold (isEmpty x) in i. fold (isEmpty y) in i.
    rewrite andb_true_iff in i.
    exact i.
 -- rewrite H in i.
    unfold isEmpty in i.
    rewrite foldg_connect in i.
    fold (isEmpty x) in i. fold (isEmpty y) in i.
    rewrite andb_true_iff in i.
    exact i.
Qed.

Lemma ovov A : Overlay (A:=A) = Overlay. Proof. auto. Qed.
Lemma coco A : Connect (A:=A) = Connect. Proof. auto. Qed.

Lemma isEmpty_drope_e A (x : Graph A) :
 isEmpty (dropEmpty x) = true -> dropEmpty x = Empty.
Proof.
  intros H.
  induction x.
  - auto.
  - compute in H. discriminate H.
  - unfold dropEmpty.
    rewrite foldg_overlay.
    fold (dropEmpty x1).
    fold (dropEmpty x2).
    unfold dropEmpty in H.
    rewrite foldg_overlay in H.
    fold (dropEmpty x1) in H.
    fold (dropEmpty x2) in H.
    destruct (isEmpty_kSimpl A Overlay (dropEmpty x1) (dropEmpty x2) (or_introl (ovov A)) H) as (H1,H2).
    apply IHx1 in H1. rewrite H1.
    apply IHx2 in H2. rewrite H2.
    auto.
  - unfold dropEmpty.
    rewrite foldg_connect.
    fold (dropEmpty x1).
    fold (dropEmpty x2).
    unfold dropEmpty in H.
    rewrite foldg_connect in H.
    fold (dropEmpty x1) in H.
    fold (dropEmpty x2) in H.
    destruct (isEmpty_kSimpl A Connect (dropEmpty x1) (dropEmpty x2) (or_intror (coco A)) H) as (H1,H2).
    apply IHx1 in H1. rewrite H1.
    apply IHx2 in H2. rewrite H2.
    auto.
Qed.

(* You can compose two smart homomorphisms *)
Theorem smart_hom_compo A B C (s1 : Graph A -> Graph B) (s2 : Graph B -> Graph C):
 (Smart_hom s1) /\ (Smart_hom s2) ->
  s2 ∘ s1 = foldg Empty (s2 ∘ s1 ∘ Vertex) (kSimpl Overlay) (kSimpl Connect).
Proof.
  intros H.
  destruct H as (H1,H2).
  rewrite (smart_hom_single H1).
  rewrite (smart_hom_single H1) in H1.
  remember (foldg Empty (fun v : A => s1 (Vertex v)) (kSimpl Overlay) (kSimpl Connect)) as f1.
  rewrite (smart_hom_single H2).
  rewrite (smart_hom_single H2) in H2.
  remember (foldg Empty (fun v : B => s2 (Vertex v)) (kSimpl Overlay) (kSimpl Connect)) as f2.
  apply FunctionalExtensionality.functional_extensionality.
  intros g.
  unfold compose.
  induction g.
  - rewrite Heqf1. rewrite Heqf2. auto.
  - rewrite Heqf1. rewrite Heqf2. auto.
  - rewrite Heqf1.
    repeat rewrite foldg_overlay.
    rewrite (eq_sym Heqf1).
    rewrite (eq_sym IHg1). rewrite (eq_sym IHg2).
    unfold kSimpl.
    destruct (bool_dec (isEmpty (f1 g1)) true) ; destruct (bool_dec (isEmpty (f1 g2)) true).
 -- rewrite e. rewrite (smart_hom_e B C f2 (f1 g1) H2 e). simpl.
    rewrite e0.
    rewrite (smart_hom_isE B C f2 (f1 g2) H2 e0).
    rewrite (smart_hom_empty H2). reflexivity.
 -- rewrite e. rewrite (not_true_is_false (isEmpty (f1 g2)) n).
    rewrite (smart_hom_e B C f2 (f1 g1) H2 e). simpl.
    destruct (bool_dec (isEmpty (f2 (f1 g2))) true).
  + rewrite e0.
    rewrite H2.
    unfold compose.
    apply (isEmpty_drope_e C).
    fold (f2 ∘ Vertex).
    fold (compose dropEmpty (bind (f2 ∘ Vertex)) (f1 g2)).
    rewrite (eq_sym H2). exact e0.
  + rewrite (not_true_is_false (isEmpty (f2 (f1 g2))) n0). reflexivity.
 -- rewrite e. rewrite (not_true_is_false (isEmpty (f1 g1)) n).
    rewrite (smart_hom_e B C f2 (f1 g2) H2 e). simpl.
    destruct (bool_dec (isEmpty (f2 (f1 g1))) true).
  + rewrite e0.
    rewrite H2.
    unfold compose.
    apply (isEmpty_drope_e C).
    fold (f2 ∘ Vertex).
    fold (compose dropEmpty (bind (f2 ∘ Vertex)) (f1 g1)).
    rewrite (eq_sym H2). exact e0.
  + rewrite (not_true_is_false (isEmpty (f2 (f1 g1))) n0). reflexivity.
 -- rewrite (not_true_is_false (isEmpty (f1 g1)) n).
    rewrite (not_true_is_false (isEmpty (f1 g2)) n0).
    rewrite (smart_hom_overlay (f1 g1) (f1 g2) H2). auto.
  - rewrite Heqf1.
    repeat rewrite foldg_connect.
    rewrite (eq_sym Heqf1).
    rewrite (eq_sym IHg1). rewrite (eq_sym IHg2).
    unfold kSimpl.
    destruct (bool_dec (isEmpty (f1 g1)) true) ; destruct (bool_dec (isEmpty (f1 g2)) true).
 -- rewrite e. rewrite (smart_hom_e B C f2 (f1 g1) H2 e). simpl.
    rewrite e0.
    rewrite (smart_hom_isE B C f2 (f1 g2) H2 e0).
    rewrite (smart_hom_empty H2). reflexivity.
 -- rewrite e. rewrite (not_true_is_false (isEmpty (f1 g2)) n).
    rewrite (smart_hom_e B C f2 (f1 g1) H2 e). simpl.
    destruct (bool_dec (isEmpty (f2 (f1 g2))) true).
  + rewrite e0.
    rewrite H2.
    unfold compose.
    apply (isEmpty_drope_e C).
    fold (f2 ∘ Vertex).
    fold (compose dropEmpty (bind (f2 ∘ Vertex)) (f1 g2)).
    rewrite (eq_sym H2). exact e0.
  + rewrite (not_true_is_false (isEmpty (f2 (f1 g2))) n0). reflexivity.
 -- rewrite e. rewrite (not_true_is_false (isEmpty (f1 g1)) n).
    rewrite (smart_hom_e B C f2 (f1 g2) H2 e). simpl.
    destruct (bool_dec (isEmpty (f2 (f1 g1))) true).
  + rewrite e0.
    rewrite H2.
    unfold compose.
    apply (isEmpty_drope_e C).
    fold (f2 ∘ Vertex).
    fold (compose dropEmpty (bind (f2 ∘ Vertex)) (f1 g1)).
    rewrite (eq_sym H2). exact e0.
  + rewrite (not_true_is_false (isEmpty (f2 (f1 g1))) n0). reflexivity.
 -- rewrite (not_true_is_false (isEmpty (f1 g1)) n).
    rewrite (not_true_is_false (isEmpty (f1 g2)) n0).
    rewrite (smart_hom_connect (f1 g1) (f1 g2) H2). auto.
Qed.

Lemma dropEmpty_idempotence A (x:Graph A) : dropEmpty (dropEmpty x) = dropEmpty x.
Proof.
  induction x.
  - auto.
  - auto.
  - unfold dropEmpty.
    rewrite foldg_overlay.
    fold (dropEmpty x1).
    fold (dropEmpty x2).
    unfold kSimpl at 3 4.
    destruct (bool_dec (isEmpty (dropEmpty x1)) true) ; destruct (bool_dec (isEmpty (dropEmpty x2)) true).
 -- rewrite e. rewrite e0. auto.
 -- rewrite e. rewrite (not_true_is_false (isEmpty (dropEmpty x2)) n). auto.
 -- rewrite e. rewrite (not_true_is_false (isEmpty (dropEmpty x1)) n). auto.
 -- rewrite (not_true_is_false (isEmpty (dropEmpty x1)) n).
    rewrite (not_true_is_false (isEmpty (dropEmpty x2)) n0).
    rewrite foldg_overlay.
    fold (dropEmpty (dropEmpty x1)).
    fold (dropEmpty (dropEmpty x2)).
    rewrite IHx1.
    rewrite IHx2.
    unfold kSimpl.
    rewrite (not_true_is_false (isEmpty (dropEmpty x1)) n).
    rewrite (not_true_is_false (isEmpty (dropEmpty x2)) n0).
    reflexivity.
  - unfold dropEmpty.
    rewrite foldg_connect.
    fold (dropEmpty x1).
    fold (dropEmpty x2).
    unfold kSimpl at 3 4.
    destruct (bool_dec (isEmpty (dropEmpty x1)) true) ; destruct (bool_dec (isEmpty (dropEmpty x2)) true).
 -- rewrite e; rewrite e0; auto.
 -- rewrite e; rewrite (not_true_is_false (isEmpty (dropEmpty x2)) n); auto.
 -- rewrite e; rewrite (not_true_is_false (isEmpty (dropEmpty x1)) n); auto.
 -- rewrite (not_true_is_false (isEmpty (dropEmpty x1)) n).
    rewrite (not_true_is_false (isEmpty (dropEmpty x2)) n0).
    rewrite foldg_connect.
    fold (dropEmpty (dropEmpty x1)).
    fold (dropEmpty (dropEmpty x2)).
    rewrite IHx1.
    rewrite IHx2.
    unfold kSimpl.
    rewrite (not_true_is_false (isEmpty (dropEmpty x1)) n).
    rewrite (not_true_is_false (isEmpty (dropEmpty x2)) n0).
    reflexivity.
Qed.

(* And the composition of two smart homomorphisms is a smart homomorphism *)
Theorem smart_hom_compo_is_smart A B C (s1 : Graph A -> Graph B) (s2 : Graph B -> Graph C):
 (Smart_hom s1) /\ (Smart_hom s2) -> Smart_hom (s2 ∘ s1).
Proof.
  intros H.
  rewrite (smart_hom_compo A B C s1 s2 H).
  destruct H as (H1,H2).
  unfold Smart_hom.
  apply FunctionalExtensionality.functional_extensionality.
  intro g.
  unfold compose.
  induction g.
  - auto.
  - unfold bind. unfold foldg.
    rewrite H2.
    unfold compose.
    rewrite (dropEmpty_idempotence C (bind (fun x : B => s2 (Vertex x)) (s1 (Vertex a)))).
    reflexivity.
  - rewrite foldg_overlay.
    rewrite IHg1.
    rewrite IHg2.
    auto.
  - rewrite foldg_connect.
    rewrite IHg1.
    rewrite IHg2.
    auto.
Qed.