Require Import ssreflect ssrfun seq ssrbool ssrnat fintype eqtype choice.
Require Import Setoid Morphisms RelationClasses.

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

Section Regex.

Variable sym: eqType.

Inductive Regex :=
| RAny | RSym (sym:sym) | REmp | RVoid | RSeq (r s: Regex) | RAlt (r s: Regex)
| RStar (r: Regex).

(* Size, depth *)
Fixpoint rsize r :=
match r with
| RSeq r1 r2 => 1 + rsize r1 + rsize r2
| RAlt r1 r2 => 1 + rsize r1 + rsize r2
| RStar r => 1 + rsize r
| _ => 1
end.

Fixpoint rdepth r :=
match r with
| RSeq r1 r2 => 1 + max (rdepth r1) (rdepth r2)
| RAlt r1 r2 => 1 + max (rdepth r1) (rdepth r2)
| RStar r => 1 + rdepth r
| _ => 1
end.

(* Smart constructors *)
Fixpoint rSeq r1 r2 :=
match r1, r2 with
| _, RVoid => RVoid
| RVoid, _ => RVoid
| REmp, _ => r2
| _, REmp => r1
| RSeq r1a r1b, _ => RSeq r1a (rSeq r1b r2)
| _, _ => RSeq r1 r2
end.

(* This one does balancing too *)
Fixpoint rAlt r1 r2 :=
match r1, r2 with
| _, RVoid => r1
| RVoid, _ => r2
| RAlt r1a r1b, _ => RAlt r1a (rAlt r1b r2)
| _, _ => RAlt r1 r2
end.

Fixpoint rStar r :=
match r with
| RVoid => REmp
| REmp => REmp
| RStar r => RStar (rStar r)
| _ => r
end.

(*======================================================================================
  Semantic interpretation
  ======================================================================================*)
Inductive rinterp : Regex -> seq sym -> Prop :=
| rinterp_RAny b : rinterp RAny [::b]
| rinterp_REmp : rinterp REmp nil
| rinterp_RSym b : rinterp (RSym b) [::b]
| rinterp_RAlt1 r1 r2 l : rinterp r1 l -> rinterp (RAlt r1 r2) l
| rinterp_RAlt2 r1 r2 l : rinterp r2 l -> rinterp (RAlt r1 r2) l
| rinterp_RSeq r1 r2 l1 l2 : rinterp r1 l1 -> rinterp r2 l2 -> rinterp (RSeq r1 r2) (l1++l2)
| rinterp_RStarNil r : rinterp (RStar r) nil
| rinterp_RStarCons r c l1 l2 : rinterp r (c::l1) -> rinterp (RStar r) l2 -> rinterp (RStar r) (c::(l1++l2)).

Lemma rinterpRAny l :
  rinterp RAny l <-> exists b, l = [::b].
Proof. split => H. inversion H. subst. by exists b.
destruct H. subst. apply rinterp_RAny. Qed.

Lemma rinterpREmp l :
  rinterp REmp l <-> l = nil.
Proof. split => H. by inversion H. subst; constructor.
Qed.

Lemma rinterpRSym b l :
  rinterp (RSym b) l <-> l = [::b].
Proof. split => H. inversion H. by subst.
subst. apply rinterp_RSym. Qed.

Lemma rinterpRVoid l :
  rinterp RVoid l <-> False.
Proof. split => H. inversion H. done. Qed.

Lemma rinterpRAlt (r1 r2: Regex) (l: seq sym) :
  rinterp (RAlt r1 r2) l <-> rinterp r1 l \/ rinterp r2 l.
Proof. split => H. inversion H. by left. by right.
destruct H. by apply rinterp_RAlt1. by apply rinterp_RAlt2. Qed.

Lemma rinterpRSeq (r1 r2: Regex) (l: seq sym) :
  rinterp (RSeq r1 r2) l <-> exists l1 l2, l = l1++l2 /\ rinterp r1 l1 /\ rinterp r2 l2.
Proof. split => H. inversion H. subst. by exists l1, l2.
destruct H as [l1 [l2 [-> [H2 H3]]]].  by constructor. Qed.

Lemma rinterpRSeqSym (r: Regex) s (l: seq sym) :
  rinterp (RSeq (RSym s) r) l <-> exists l', l = s::l' /\ rinterp r l'.
Proof. rewrite rinterpRSeq. simpl.
split. move => [l1 [l2 [H1 [H2 H3]]]]. inversion H2. subst. by exists l2.
move => [l' [H1 H2]]. subst. exists [::s]. exists l'. split => //. split => //. constructor.
Qed.

Lemma rinterpRStar (r: Regex) (l: seq sym) :
  rinterp (RStar r) l <->
  if l is c::l' then
  (exists l1 l2, l' = l1++l2 /\ rinterp r (c::l1) /\ rinterp (RStar r) l2) else True.
Proof. split => H.
+ destruct l => //. inversion H; subst. by exists l1, l2.
+ destruct l => //. constructor.
  destruct H as [l1 [l2 [H1 [H2 H3]]]]. subst. by constructor.
Qed.

Hint Rewrite rinterpRAny rinterpREmp rinterpRSym rinterpRVoid rinterpRAlt
  rinterpRSeqSym rinterpRSeq rinterpRStar : rinterp.

(*======================================================================================
  Semantic equivalence
  ======================================================================================*)
Definition regexEq (r1 r2: Regex) := forall l, rinterp r1 l <-> rinterp r2 l.

Notation "x '===' y" := (regexEq x y) (at level 70, no associativity).

Global Instance regexEqEqu : Equivalence regexEq.
Proof. constructor; red => //.
+ move => r1 r2 H l. firstorder.
+ move => r1 r2 r3 H1 H2 l. firstorder.
Qed.

Global Instance regexEq_RSeq_m: Proper (regexEq ==> regexEq ==> regexEq) RSeq.
Proof. move => r1 r2 EQ1 q1 q2 EQ2 .
rewrite /regexEq in EQ1, EQ2.
move => l.
split => /= H /=.
+ inversion H. subst. constructor; firstorder.
+ inversion H. subst. constructor; firstorder.
Qed.

Global Instance regexEq_RAlt_m:  Proper (regexEq ==> regexEq ==> regexEq) RAlt.
Proof. move => p1 p2 EQ1 q1 q2 EQ2 .
move => l.
split => /= H /=. inversion H; subst.
apply rinterp_RAlt1. firstorder.
apply rinterp_RAlt2. firstorder.
inversion H; subst.
apply rinterp_RAlt1. firstorder.
apply rinterp_RAlt2. firstorder.
Qed.

Global Instance regexEq_rinterp_m: Proper (regexEq ==> eq ==> iff) rinterp.
Proof. move => r1 r2 EQ l1 l2 ->.
rewrite /regexEq in EQ. firstorder.
Qed.

Lemma regexEq_RSeqREmp r : RSeq r REmp === r.
Proof. rewrite /regexEq => l. rewrite rinterpRSeq. simpl (rinterp REmp). simpl.
split => //.  move => [l1 [l2 [H1 [H2 H3]]]]. subst. inversion H3; subst. by rewrite cats0.
move => H. exists l, nil. rewrite cats0. firstorder. constructor. Qed.

Lemma regexEq_REmpRSeq r : RSeq REmp r === r.
Proof. rewrite /regexEq => l. rewrite rinterpRSeq. simpl (rinterp REmp). simpl.
split => //.  move => [l1 [l2 [H1 [H2 H3]]]]. subst. inversion H2; subst. done.
move => H. exists nil, l. firstorder. constructor. Qed.

Lemma regexEq_RSeqRVoid r : RSeq r RVoid === RVoid.
Proof. rewrite /regexEq => l. rewrite rinterpRSeq. split => //.
move => [l1 [l2 [H1 [H2 H3]]]]. inversion H3. move => H. inversion H.
Qed.

Lemma regexEq_RVoidRSeq r : RSeq RVoid r === RVoid.
Proof. rewrite /regexEq => l. rewrite rinterpRSeq. split => //.
move => [l1 [l2 [H1 [H2 H3]]]]. inversion H2. move => H. inversion H.
Qed.

Lemma regexEq_RAltRVoid r : RAlt r RVoid === r.
Proof. rewrite /regexEq => l. rewrite rinterpRAlt. firstorder. inversion H. Qed.

Lemma regexEq_RVoidRAlt r : RAlt RVoid r === r.
Proof. rewrite /regexEq => l. rewrite rinterpRAlt. firstorder. inversion H. Qed.

Lemma regexEq_RSeqAssoc r1 r2 r3 : RSeq r1 (RSeq r2 r3) === RSeq (RSeq r1 r2) r3.
Proof. rewrite /regexEq => l. rewrite !rinterpRSeq. split.
+ move => [l1 [l2 [H1 [H2 H3]]]]. rewrite -> rinterpRSeq in H3.
destruct H3 as [l3 [l4 [H4 [H5 H6]]]]. subst. exists (l1++l3), l4. rewrite catA.
firstorder. by constructor.
+ move => [l1 [l2 [H1 [H2 H3]]]]. rewrite -> rinterpRSeq in H2.
destruct H2 as [l3 [l4 [H4 [H5 H6]]]]. subst. exists l3, (l4++l2). rewrite catA.
firstorder. by constructor.
Qed.

Lemma regexEq_RAltAssoc r1 r2 r3 : RAlt r1 (RAlt r2 r3) === RAlt (RAlt r1 r2) r3.
Proof. rewrite /regexEq => l. rewrite !rinterpRAlt. firstorder. Qed.

Lemma regexEq_RAltComm r1 r2 : RAlt r1 r2 === RAlt r2 r1.
Proof. rewrite /regexEq => l. rewrite !rinterpRAlt. firstorder. Qed.

Lemma regexEq_RStarVoid : RStar RVoid === REmp.
Proof. move => l. autorewrite with rinterp. destruct l => //.
split => // H. destruct H as [l1 [l2 [H1 [H2 H3]]]]. by rewrite -> rinterpRVoid in H2.
Qed.

Lemma regexEq_RStarEmp : RStar REmp === REmp.
Proof. move => l. autorewrite with rinterp. destruct l => //.
split => // H. destruct H as [l1 [l2 [H1 [H2 H3]]]]. subst.
by rewrite -> rinterpREmp in H2.
Qed.

(*
Lemma regexEq_RStarRStar r : RStar (RStar r) === RStar r.
Proof. induction r => l; autorewrite with rinterp.
+ destruct l => //.
split => H. destruct H as [l1 [l2 [H1 [H2 H3]]]]. subst.
rewrite -> rinterpRStar in H2.
destruct H2 as [l3 [l4 [H4 [H5 H6]]]]. subst.
rewrite -catA. exists l3, (l4 ++ l2).
*)

Lemma rSeqDef r1 : forall r2, rSeq r1 r2 === RSeq r1 r2.
Proof. induction r1 => r2.
(* RAny *)
+ destruct r2 => //.
  - by rewrite regexEq_RSeqREmp.
  - by rewrite regexEq_RSeqRVoid.
(* RSym *)
+ destruct r2 => //.
  - by rewrite regexEq_RSeqREmp.
  - by rewrite regexEq_RSeqRVoid.
(* REmp *)
+ rewrite regexEq_REmpRSeq. by destruct r2 => //.
(* RVoid *)
+ rewrite regexEq_RVoidRSeq. by destruct r2 => //.
(* RSeq *)
+ destruct r2 => //.
  - by rewrite /= -regexEq_RSeqAssoc IHr1_2.
  - by rewrite /= -regexEq_RSeqAssoc IHr1_2.
  - by rewrite -regexEq_RSeqAssoc regexEq_RSeqREmp.
  - by rewrite regexEq_RSeqRVoid.
  - by rewrite /= IHr1_2 regexEq_RSeqAssoc.
  - by rewrite /= IHr1_2 regexEq_RSeqAssoc.
  - by rewrite /= IHr1_2 regexEq_RSeqAssoc.
(* RAlt *)
+ destruct r2 => //.
  - by rewrite regexEq_RSeqREmp.
  - by rewrite regexEq_RSeqRVoid.
(* RStar *)
+ destruct r2 => //.
  - by rewrite regexEq_RSeqREmp.
  - by rewrite regexEq_RSeqRVoid.
Qed.

Lemma rAltDef r1 r2 : rAlt r1 r2 === RAlt r1 r2.
Proof. induction r1 => //=.
+ destruct r2 => //. by rewrite regexEq_RAltRVoid.
+ destruct r2 => //. by rewrite regexEq_RAltRVoid.
+ destruct r2 => //. by rewrite regexEq_RAltRVoid.
+ rewrite regexEq_RVoidRAlt. by destruct r2.
+ destruct r2 => //. by rewrite regexEq_RAltRVoid.
+ destruct r2 => //.
  - by rewrite IHr1_2 regexEq_RAltAssoc.
  - by rewrite IHr1_2 regexEq_RAltAssoc.
  - by rewrite IHr1_2 regexEq_RAltAssoc.
  - by rewrite regexEq_RAltRVoid.
  - by rewrite IHr1_2 regexEq_RAltAssoc.
  - by rewrite IHr1_2 regexEq_RAltAssoc.
  - by rewrite IHr1_2 regexEq_RAltAssoc.
+ destruct r2 => //.
  - by rewrite regexEq_RAltRVoid.
Qed.

(*======================================================================================
  Derivatives
  ======================================================================================*)

(* Nullable transformation *)
Fixpoint rnull (r: Regex) : Regex :=
match r with
| REmp     => REmp
| RAlt c1 c2 => rAlt (rnull c1) (rnull c2)
| RSeq c1 c2 => rSeq (rnull c1) (rnull c2)
| RStar c => REmp
| _ => RVoid
end.

Fixpoint rnullable (r: Regex) : bool :=
match r with
| REmp | RStar _ => true
| RAlt r1 r2 => rnullable r1 || rnullable r2
| RSeq r1 r2 => rnullable r1 && rnullable r2
| _ => false
end.

(* Derivative of a regexp wrt a symbol *)
Fixpoint rderivSym (s:sym) (r: Regex) : Regex :=
match r with
| RAny     => REmp
| RSym b   => if b==s then REmp else RVoid
| RAlt c d => rAlt (rderivSym s c) (rderivSym s d)
| RSeq c1 c2 => rAlt (rSeq (rderivSym s c1) c2) (rSeq (rnull c1) (rderivSym s c2))
| RStar r => rSeq (rderivSym s r) (RStar r)
| _ => RVoid
end.

(* Partial Antimirov-style derivative wrt a symbol *)
Definition nilRegexes: seq Regex := nil.
Definition singletonRegex r: seq Regex := [::r].
Definition unionRegexes s1 s2: seq Regex := s1 ++ s2.

Fixpoint arderivSym (s:sym) (r: Regex) : seq Regex :=
match r with
| RAny     => singletonRegex REmp
| RSym b   => if b==s then singletonRegex REmp else nilRegexes
| RAlt c d => unionRegexes (arderivSym s c) (arderivSym s d)
| RSeq r1 r2 => unionRegexes (map (fun r1' => RSeq r1' r2) (arderivSym s r1))
                             (if rnullable r1 then arderivSym s r2 else nilRegexes)
| RStar r => map (fun r' => RSeq r' (RStar r)) (arderivSym s r)
| _ => nilRegexes
end.

(* Generalization to strings *)
Fixpoint rderivSyms (ss: seq sym) r :=
if ss is s::ss' then rderivSyms ss' (rderivSym s r) else r.

Inductive matches : Regex -> seq sym -> Prop :=
| matchesEmp r : rinterp r nil -> matches r nil
| matchesCons r a s : matches (rderivSym a r) s -> matches r (a::s).

(* Semantic interpretation of nullable *)
Lemma rinterpNull r : forall l, rinterp (rnull r) l <-> (l = nil /\ rinterp r nil).
Proof. induction r => l/=; autorewrite with rinterp.
+ split => //. move => [H1 H2]. by destruct H2.
+ split => //. by move => [H1 H2].
+ intuition.
+ intuition.
+ rewrite rSeqDef. autorewrite with rinterp.
split.
move => H. destruct H as [l1 [l2 [H1 [H2 H3]]]]. subst.
destruct (proj1 (IHr1 _) H2) as [H4 H5]. subst.
destruct (proj1 (IHr2 _) H3) as [H6 H7]. subst.
split => //. exists nil, nil. intuition.
move => [H [l1 [l2 [H3 [H4 H5]]]]].
subst. exists l1, l2. split => //.
split. destruct l1 => //.  destruct l2 => //.
specialize (IHr1 nil). destruct IHr1 as [I1 I2]. apply I2. intuition.
specialize (IHr2 nil). destruct IHr2 as [I1 I2]. destruct l1 => //. destruct l2 => //.
apply I2. intuition.
+ rewrite rAltDef. autorewrite with rinterp.
split. move => H. destruct H.
+ destruct (proj1 (IHr1 _) H) as [H1 H2]. intuition.
+ destruct (proj1 (IHr2 _) H) as [H1 H2]. intuition.
move => [H1 H2].
subst. destruct H2.
+ specialize (IHr1 nil). left. by apply (proj2 IHr1).
+ specialize (IHr2 nil). right. by apply (proj2 IHr2).
+ intuition.
Qed.

(* Semantic interpretation of rderivSym *)
Lemma rinterpDerivSym c r : forall s, rinterp (rderivSym c r) s <-> rinterp r (c::s).
Proof. induction r => s; autorewrite with rinterp.
(* RAny *)
split => //=. move => ->. by exists c. move => [b H]. congruence.
(* RSym *)
split => //=.
case E: (sym0 == c). rewrite rinterpREmp. move => ->. by rewrite (eqP E).
by rewrite rinterpRVoid.
case E: (sym0 == c). rewrite rinterpREmp. rewrite (eqP E). by move => /=[H].
move => [H]/=. by rewrite H eq_refl in E.
(* REmp *)
split => //=.
(* RVoid *)
done.
(* RSeq *)
+ rewrite /= rAltDef 2!rSeqDef rinterpRAlt !rinterpRSeq. split => //= H.
(* => *)
destruct H.
-
destruct H as [l1 [l2 [H1 [H2 H3]]]].
exists (c::l1), l2. split. by subst. split => //.
by apply (IHr1 _).
-
destruct H as [l1 [l2 [H1 [H2 H3]]]]. subst.
apply rinterpNull in H2. destruct H2 as [H4 H5]. subst.
simpl. exists nil, (c::l2). split => //. split => //.
by apply (IHr2 l2).
(* <= *)
destruct H as [l1 [l2 [H1 [H2 H3]]]].
case E: l1 => [| c' l3].
-
subst. simpl in H1. subst.
right.
specialize (IHr2 s).
destruct IHr2 as [I1 I2]. specialize (I2 H3). exists nil, s. split => //. split => //.
by apply rinterpNull.
-
subst. injection H1 => [H4 H5]. subst. clear H1.
specialize (IHr1 l3). destruct IHr1 as [I1 I2].
specialize (I2 H2). left.
exists l3,l2. split => //.
(* RAlt *)
rewrite /= rAltDef !rinterpRAlt.
split => //= H.
(* => *)
destruct H.
left. by apply IHr1.
right. by apply IHr2.
(* <= *)
destruct H.
left. by apply IHr1.
right. by apply IHr2.
(* RStar *)
rewrite /= rSeqDef rinterpRSeq.
firstorder.
Qed.

Lemma rinterpDerivSyms s: forall r l, rinterp (rderivSyms s r) l <-> rinterp r (s++l).
Proof. induction s => //= r l. by rewrite IHs rinterpDerivSym. Qed.

Global Instance regexEq_rderivSym_m c :
  Proper (regexEq ==> regexEq) (rderivSym c).
Proof. move => r1 r2 EQ l. by rewrite 2!rinterpDerivSym EQ. Qed.

Fixpoint starfree (r: Regex) :=
match r with
| RAlt r s => starfree r && starfree s
| RSeq r s => starfree r && starfree s
| RStar _ => false
| _ => true
end.

(* r is expected to be star-free *)
Fixpoint DrvAny (r: Regex) :=
match r with
| REmp     => RVoid
| RSym b   => REmp
| RAny     => REmp
| RVoid    => RVoid
| RAlt c1 c2 => rAlt (DrvAny c1) (DrvAny c2)
| RSeq c1 c2 => rAlt (rSeq (DrvAny c1) c2) (rSeq (rnull c1) (DrvAny c2))
| RStar c => RVoid
end.

(* Derivative of a regexp g wrt another regexp r *)
Fixpoint deriv (r: Regex) g :=
match r with
| REmp     => g
| RSym b   => rderivSym b g
| RAny     => DrvAny g
| RVoid    => RVoid
| RAlt c1 c2 => rAlt (deriv c1 g) (deriv c2 g)
| RSeq c1 c2 => deriv c2 (deriv c1 g)
| RStar c => RVoid
end.

Lemma starfreerSeq r1 r2 : starfree r1 -> starfree r2 -> starfree (rSeq r1 r2).
Proof. move => SF1 SF2. induction r1 => //=. destruct r2 => //;destruct r2 => //.
destruct r2 => //; destruct r2 => //. destruct r2 => //. destruct r2 => //=.
simpl in SF1. destruct (andP SF1) as [SF1a SF1b]. destruct r2 => //=.
rewrite IHr1_2 => //. by rewrite SF1a. rewrite SF1a. rewrite IHr1_2 => //.
rewrite SF1a. rewrite IHr1_2 => //. rewrite SF1a. rewrite IHr1_2 => //.
simpl in SF1. destruct (andP SF1) as [SF1a SF1b]. destruct r2 => //=.
rewrite SF1a. by rewrite SF1b.
rewrite SF1a. by rewrite SF1b.
simpl in SF2. destruct (andP SF2) as [SF2a SF2b].
by rewrite SF1a SF1b SF2a SF2b.
simpl in SF2. destruct (andP SF2) as [SF2a SF2b].
by rewrite SF1a SF1b SF2a SF2b.
Qed.

Lemma starfreerAlt r1 r2 : starfree r1 -> starfree r2 -> starfree (rAlt r1 r2).
Proof. move => SF1 SF2. induction r1 => //=.
destruct r2 => //; destruct r2 => //.
destruct r2 => //; destruct r2 => //.
destruct r2 => //; destruct r2 => //.
destruct r2 => //; destruct r2 => //.
simpl in SF1. destruct (andP SF1) as [SF1a SF1b]. destruct r2 => //=.
by rewrite SF1a SF1b.
by rewrite SF1a SF1b.
by rewrite SF1a SF1b.
simpl in SF2. destruct (andP SF2) as [SF2a SF2b].
by rewrite SF1a SF1b SF2a SF2b.
simpl in SF2. destruct (andP SF2) as [SF2a SF2b].
by rewrite SF1a SF1b SF2a SF2b.
destruct r2 => //=.
simpl in SF1. destruct (andP SF1) as [SF1a SF1b].
rewrite SF1a. rewrite IHr1_2 => //.
simpl in SF1. destruct (andP SF1) as [SF1a SF1b].
rewrite SF1a. rewrite IHr1_2 => //.
simpl in SF1. destruct (andP SF1) as [SF1a SF1b].
rewrite SF1a. rewrite IHr1_2 => //.
simpl in SF1. destruct (andP SF1) as [SF1a SF1b].
simpl in SF2. destruct (andP SF2) as [SF2a SF2b].
rewrite SF1a. rewrite IHr1_2 => //.
simpl in SF1. destruct (andP SF1) as [SF1a SF1b].
rewrite SF1a. rewrite IHr1_2 => //.
Qed.

Lemma starfreeNull r : starfree r -> starfree (rnull r).
Proof. induction r => //=. move/andP => [R1 R2].
rewrite starfreerSeq => //. rewrite IHr1 => //.
rewrite IHr2 => //.
move/andP => [R1 R2].
rewrite starfreerAlt => //. rewrite IHr1 => //. rewrite IHr2 => //.
Qed.

Lemma starfreeDrvAny r : starfree r -> starfree (DrvAny r).
Proof. induction r => //=. move/andP => [R1 R2].
apply starfreerAlt => //. apply starfreerSeq => //. apply IHr1 => //.
apply starfreerSeq => //. apply starfreeNull => //.
apply IHr2 => //.
move/andP => [R1 R2].
apply starfreerAlt. apply IHr1 => //. apply IHr2 => //.
Qed.

Lemma starfreeDerivSym r : forall c, starfree r -> starfree (rderivSym c r).
Proof. induction r => //= c R.
by destruct (sym0 == c).
destruct (andP R) as [R1 R2].
apply starfreerAlt => //. apply starfreerSeq => //. apply IHr1 => //.
apply starfreerSeq => //. apply starfreeNull => //. apply IHr2 => //.
destruct (andP R) as [R1 R2].
apply starfreerAlt => //. apply IHr1 => //. apply IHr2 => //.
Qed.

Lemma starfreeDeriv r1 : forall r2, starfree r1 -> starfree r2 -> starfree (deriv r1 r2).
Proof. induction r1 => //=.
destruct r2 => //=.
move => _. move/andP => [R1 R2].
rewrite starfreerAlt => //. rewrite starfreerSeq => //. apply starfreeDrvAny => //.
rewrite starfreerSeq => //. apply starfreeNull => //. apply starfreeDrvAny => //.
move => _. move/andP => [R1 R2].
rewrite starfreerAlt => //. apply starfreeDrvAny => //. apply starfreeDrvAny => //.
move => r _ R. apply starfreeDerivSym => //.
move => r2. move/andP => [R1 R2] R3. apply IHr1_2 => //.
apply IHr1_1 => //.
move => r2. move/andP => [R1 R2] R3. apply starfreerAlt.
apply IHr1_1 => //.
apply IHr1_2 => //.
Qed.

(* Semantic definition of non-overlapping *)
Definition nonOverlapping r1 r2 := forall l1 l2, rinterp r1 l1 -> rinterp r2 (l1++l2) -> False.

(* This syntactic criterion implies a sensible semantic one *)
Definition NonOverlapping r1 r2 := match deriv r1 r2 with RVoid => true | _ => false end.

Fixpoint req (r1 r2: Regex) :bool :=
  match r1, r2 with
  | RAny, RAny => true
  | RSym s1, RSym s2 => s1==s2
  | RVoid, RVoid => true
  | REmp, REmp => true
  | RSeq r1a r1b, RSeq r2a r2b => req r1a r2a && req r1b r2b
  | RAlt r1a r1b, RAlt r2a r2b => req r1a r2a && req r1b r2b
  | RStar r1, RStar r2 => req r1 r2
  | _, _ => false
  end.

Definition States := seq Regex.
Fixpoint tryLookupState (ss: States) (r: Regex) :=
  if ss is r'::ss' then
    if req r r' then Some (size ss') else tryLookupState ss' r
  else None.

Definition lookupState (ss: States) (r: Regex) : States * nat :=
  if tryLookupState ss r is Some i then (ss, i)
  else (r::ss, size ss).

End Regex.

Fixpoint explore n (r: Regex bool_eqType) (ss: States _) (t: seq (nat*nat*nat)) :=
  if tryLookupState ss r is Some i then (ss,t,i)
  else
    let ss' := r::ss in
    let i := size ss in

    if n isn't n.+1 then (ss', t, i)
    else
    (* Derivatives wrt 0 and 1 symbols *)
      let r0 := rderivSym false r in
      let r1 := rderivSym true r in
      let: (ss0, t0, i0) := explore n r0 ss' t in
      let: (ss1, t1, i1) := explore n r1 ss0 t0 in
      (ss1, (i,i0,i1)::t1, i).

Definition iterations := 100.
Definition MAKEDFA r := explore iterations r nil nil.

Example r := RSeq (RStar (RSeq (RSym false) (RSym true))) (RSym true).

Compute MAKEDFA r.

(* Semantic interpretation of DrvAny *)
Lemma rinterpDrvAny r : starfree r -> forall l,
  rinterp (DrvAny r) l <-> exists b:bool, rinterp r (b::l).
Proof. move => SF.
induction r => l/=.
+ rewrite rinterpREmp. split => H. subst. exists true. rewrite rinterpRAny. by exists true.
  destruct H as [b H]. rewrite -> rinterpRAny in H. destruct H as [b2 H]. congruence.
+ rewrite rinterpREmp. split => H. subst. exists sym. by rewrite rinterpRSym.
  destruct H as [b H]. rewrite -> rinterpRSym in H. congruence.
+ split => //. rewrite rinterpRVoid. by move => [b H].
  move => [b H]. by rewrite -> rinterpREmp in H.
+ split => //. rewrite rinterpRVoid. by move => [_ H].
  move => [b H]. by rewrite -> rinterpRVoid in H.
+ rewrite rAltDef !rSeqDef rinterpRAlt 2!rinterpRSeq.
  simpl in SF. destruct (andP SF) as [SF1 SF2].
  split => // H. destruct H.
  - destruct H as [l1 [l2 [H1 [H2 H3]]]]. subst.
    destruct (proj1 (IHr1 SF1 _) H2) as [b H4]. exists b. rewrite rinterpRSeq.
    exists (b::l1), l2. intuition.
    destruct H as [l1 [l2 [H1 [H2 H3]]]]. subst. rewrite -> rinterpNull in H2.
    destruct H2 as [H4 H5]. subst. simpl.
    destruct (proj1 (IHr2 SF2 _) H3) as [b H4]. exists b. rewrite rinterpRSeq.
    exists nil, (b::l2). intuition.
  - destruct H as [b H]. rewrite ->rinterpRSeq in H.
    destruct H as [l1 [l2 [H1 [H2 H3]]]].
    destruct l1.
    - right. exists nil, l. split => //. rewrite rinterpNull. split => //.
      rewrite (IHr2 SF2). simpl in H1. subst. by exists b.
    - left. inversion H1. subst. exists l1, l2. split => //.
      rewrite (IHr1 SF1). split => //. by exists s.
+ simpl in SF. destruct (andP SF) as [SF1 SF2].
rewrite rAltDef rinterpRAlt. rewrite (IHr1 SF1) (IHr2 SF2).
split => //. move => H. destruct H; destruct H as [b H]; exists b. by apply rinterp_RAlt1.
by apply rinterp_RAlt2. move => [b H]. rewrite -> rinterpRAlt in H. firstorder.
by simpl in SF.
Qed.

(* Semantic interpretation of deriv *)
Lemma rinterpDeriv (r2:Regex bool_eqType) : forall r1 s2, starfree r1 -> starfree r2 -> (rinterp (deriv r2 r1) s2 <-> exists s1, rinterp r2 s1 /\ rinterp r1 (s1 ++ s2)).
Proof. induction r2 => r1 l1 SF1 SF2 //=.
+ rewrite rinterpDrvAny. split => H. destruct H as [b H]. exists [::b].
  rewrite rinterpRAny. split => //.  by exists b.
  destruct H as [l2 H]. rewrite -> rinterpRAny in H. destruct H as [[b H1] H2].
  subst. by exists b. done.
+ rewrite -> rinterpDerivSym. split => H. eexists [::sym].
  rewrite rinterpRSym. by intuition.
+ destruct H as [s1 [H1 H2]]. rewrite -> rinterpRSym in H1. by subst.
+ split => H. exists nil. rewrite rinterpREmp. done.
+ destruct H as [s1 [H1 H2]]. rewrite -> rinterpREmp in H1. by subst.
+ split => // H. by rewrite -> rinterpRVoid in H.
  destruct H as [s1 [H1 H2]]. by rewrite -> rinterpRVoid in H1.
+ simpl in SF2. destruct (andP SF2) as [SF2a SF2b]. rewrite IHr2_2 => //. split.
  move => [l1' [H1 H2]]. specialize (IHr2_1 r1 (l1'++l1) SF1 SF2a).
  rewrite -> IHr2_1 in H2.
  destruct H2 as [l3 [H3 H4]]. exists (l3++l1'). rewrite -catA.  split => //.
  rewrite rinterpRSeq. exists l3, l1'. intuition.
  move => [l1' [H1 H2]]. rewrite -> rinterpRSeq in H1.
  destruct H1 as [l3 [l4 [H3 [H4 H5]]]]. subst.
  exists l4. split => //.
  apply IHr2_1 => //.
  exists l3. rewrite catA. intuition. apply starfreeDeriv => //.
+ simpl in SF2. destruct (andP SF2) as [SF2a SF2b].
  rewrite rAltDef rinterpRAlt. rewrite (IHr2_2 _ _ SF1 SF2b). rewrite (IHr2_1 _ _ SF1 SF2a).
  split => H. destruct H. destruct H as [s1 [H1 H2]]. exists s1. rewrite rinterpRAlt.
  intuition.
  destruct H as [s1 [H1 H2]]. exists s1. rewrite rinterpRAlt. intuition.
  destruct H as [l1' [H1 H2]].
  rewrite -> rinterpRAlt in H1. destruct H1. left. by exists l1'. right. by exists l1'.
Qed.

(*
Corollary regexEq_deriv_m :
  Proper (@regexEq _ ==> @regexEq _ ==> @regexEq _) (@deriv bool_eqType).
Proof. rewrite /regexEq. move => r1 r2 /=EQ q1 q2 /=EQ' l.
split. rewrite -> rinterpDeriv. move => [l' [H1 H2]]. rewrite rinterpDeriv.
exists l'.  rewrite -EQ' -EQ. intuition.
move => [l' [H1 H2]]. exists l'.
rewrite EQ' EQ. intuition.
Qed.

Lemma rinterpSeqSymDeriv (c:bool) r : forall l,
  rinterp (RSeq (RSym c) (rderivSym c r)) l <-> exists l', l = c::l' /\ rinterp r l.
Proof.
move => l. rewrite rinterpRSeq.  simpl (rinterp _ _).
split.
+ move => [l1 [l2 [H1 [H2 H3]]]]. subst. rewrite -> rinterpDerivSym in H3. by exists l2.
+ move => [l' [H1 H2]]. subst. exists [::c], l'. by rewrite rinterpDerivSym.
Qed.
*)

Lemma NonOverlappingSound (r1 r2: Regex bool_eqType) : starfree r1 -> starfree r2 -> NonOverlapping r1 r2 -> nonOverlapping r1 r2.
Proof. rewrite /NonOverlapping/nonOverlapping. move => SF1 SF2 H l1 l2 R1 R2.
case E1: (deriv r1 r2); rewrite E1 in H => //.
have RDR := @rinterpDeriv r1 r2 l2 SF2 SF1. rewrite E1/= in RDR.
destruct RDR as [_ R].
rewrite -> rinterpRVoid in R. destruct R.
by exists l1.
Qed.

Definition onestep (r: Regex _) :=
  rAlt (rnull r) (
  rAlt (rSeq (RSym false) (rderivSym false r))
       (rSeq (RSym true) (rderivSym true r))).

Notation "x '===' y" := (regexEq x y) (at level 70, no associativity).

(*
Lemma rinterpOnestep r : onestep r === r.
Proof. rewrite /onestep. rewrite !rAltDef !rSeqDef. elim.
simpl. split => H. destruct H. apply rinterpNull in H. intuition.
destruct H. destruct H as [l1 [l2 [H1 [H2 H3]]]]. by subst.
destruct H as [l1 [l2 [H1 [H2 H3]]]]. by subst.
left.
apply rinterpNull.  intuition.

move => a l.
rewrite !rinterpRAlt !rinterpNull !rinterpSeqSymDeriv.
move => [H1 H2]. split.
move => H'. destruct H'. by destruct H.
destruct H; firstorder.
move => H3.
right. destruct a. - right. by exists l. - left. by exists l.
Qed.

*)


(** * Article 2: A Little Sentential Calculus *)

Module Article_2_A_Little_Sentential_Calculus.

(** printing -> %->% #-># *)
(** If you take an undergraduate course in
formal mathematical logic, you might start
with analogies to the real world.
It's an effective teaching strategy.
Formal logic has a lot of rules and
a few symbols to learn, and the student
might feel anxious about them.
But if the student can make a connection
between the familiar and the unfamiliar,
then ... well ... there should be less anxiety.

Analogies have their limits, of course,
and some analogies are so self-evidently contrived.
I have to admit that I am about to pose
a contrived example.

Let us suppose that there is an entrepreneur
named Patricia, who makes the most wonderful
marmalade out of quinces.
Patricia always buys her quinces from one
grocer, her childhood friend Robert.
Robert currently runs one store in the fabled
city of Sarnia, Ontario, and Patricia has to
go to Robert's store to buy her quinces.
(This would be in the days before DoorDash,
and I should remind you that other
food-delivery services are available.)
The question is, if Patricia is about to make
her new batch of quince marmalade,
has she been in Sarnia?

Let's work this out first:
Patricia is ready to make quince marmalade.
If Patricia is ready to make quince marmalade,
then it follows that she must have bought quinces.
If she bought quinces, and she always buys them from
Robert, then she must have been in Robert's store.
If she was in Robert's store, then she must have
been in Sarnia.

Now, we can write this formally in what is known
as the Sentential Calculus.  (Keep in mind, this
is only a little Sentential Calculus.)
We do this by assigning letters to sentences
that can be either true or false.

Like Article 1, this article is written as
a script in the vernacular of #Coq¹,#
and the text
that you are reading is actually written
as comments delimited by #(**#
and #*)# in the script.
(The coqdoc tool normally does not include
the #(**# and #*)#
delimiters, and I have used a trick so
that you can see them here.)

There will also be comments that are
delimited by #(*# and #*);#
these comments are what Coq script writers
would normally include in a script.
(The coqdoc tool will include the
#(*# and #*)# delimiters.)

In this case, we have four statements:

*)

(* P stands for "Patricia is prepared to make quince marmalade." *)

Axiom P : Prop.

(* Q stands for "Patricia has bought quinces." *)

Axiom Q : Prop.

(* R stands for "Patricia was in Robert's store." *)

Axiom R : Prop.

(* S stands for "Patricia was in Sarnia." *)

Axiom S : Prop.

(**

Note that these sentences are not necessarily True.
They could be True, but they could be False as well.

Each sentence is represented by a single letter,
and each letter is declared to be a [Prop]
(this word is short for #proposition#).
In Coq, a proposition is considered to either
be provable or not provable.

It is now obvious how contrived this example is;
I needed something for which the letters P, Q, R, and S
could stand, and I settled on Patricia, quinces, Robert,
and Sarnia. I'll come back to that later.

The Axiom command means that Coq should assume
something without proof.
In this case, Coq should assume that
P, Q, R, and S are propositions.

To repeat the point about the sentences,
Coq is not instructed to assume that P
is True; it is only to assume that P is
a proposition (which we are associating
with the sentence
"Patricia is prepared to make quince marmalade").
Similarly, Coq is instructed to assume
that Q, R, and S are propositions,
but not to assume that they are True.

We now tell Coq to assume that P is true:

**)

(* Pr1 means it is true that "Patricia is
prepared to make quince marmalade." *)

Axiom Pr1 : P.

(**

This axiom is called a "premise",
and I have chosen to begin the name of a
premise with the prefix "Pr".
This premise states that Coq should
assume, because of Pr1, that P is True
(or more correctly, P is provably True).
Based on his #tutorial,²#
Michael Nahas would refer to Pr1 as
a proof of P.

Basically, a formal proof of a
proposition in Coq is constructed
by listing proofs of other propositions
(these proofs of other propositions
are the premises) and then using tactics
to demonstrate how the premises lead
to the proposition we want to prove.
In our case, the goal is to get a
proof of S.
We cannot get this proof with only
the one premise, which is a proof of P.
We need more premises.

We got the first premise from the
statement "Patricia is ready to make
quince marmalade."  As you recall,
we had four statements; we therefore
need four premises, one for each statement.

So now, let us make a premise for the
second statement:

**)

(* Pr2 means that "if Patricia is prepared to make
quince marmalade, then she must have bought quinces." *)

Axiom Pr2 : P -> Q.

(**

The arrow pointing to the right is read "implies".
Here, we are stating that "P implies Q" or
"if P is true then Q is true", or "P is true only
if Q is true".

But what it really means: if you have a proof of P,
you can apply Pr2 to that proof
and you get another proof, this time a proof of Q.
We have a proof of #P —#
that is, #Pr1 —#
so we should be able to get a proof of Q.

We have converted two of the four sentences
into premises.  Now we convert the other two:

**)

(* Pr3 means that "if Patricia has bought quinces,
then she must have been in Robert's store." *)

Axiom Pr3 : Q -> R.

(* Pr4 means that "if Patricia was in Robert's store,
then she was in Sarnia." *)

Axiom Pr4 : R -> S.

(**

Having listed our propositions and premises,
we now write our theorem.
Remember that we want to prove that Patricia
was in Sarnia, which is designated by S.
So we proceed this way:

**)

Theorem T1 : S.

Proof.

    assert (MPP5 := Pr2 (Pr1) : Q).

    assert (MPP6 := Pr3 (MPP5) : R).

    assert (MPP7 := Pr4 (MPP6) : S).

    exact MPP7.

Qed.

(**

Here, unfortunately, is the complicated bit.

We have started with four premises,
numbered one through four.
The first assertion is therefore
numbered five.

Each new statement is derived from
two other statements by a method called
"Modus Ponendo Ponens" (which is a Latin phrase
that means "the method that affirms by affirming").

The assertion MPP5 affirms Q from
[ P -> Q ] (Pr2) by affirming P (Pr1).
The order is important:
The premise with the arrow is named first,
and the premise proving the left-hand
side of the arrow is named next,
and the proposition for which we want
the proof is named last.

The assertion MPP6 affirms R from
[ Q -> R ] (Pr3) by affirming Q (MPP5).
The assertion MPP6 is like MPP5,
except that the proof of the left-hand side
is not a premise.  The proof of the left-hand
side is an earlier assertion (MPP5 in particular).
This is how proofs work in Coq: you assert
proofs of some propositions from the premises,
then you assert proofs of other propositions
from proofs that you already asserted.

The assertion MPP7 affirms S from
[ R -> S ] (Pr4) by affirming R (MPP6).
Derivation MPP7 affirms S,
which was what we want,
so we use exact to tell Coq to check
that it is indeed what we want.
We then end the proof with "Qed",
which is short for another Latin phrase,
"quod erat demonstrandum".
(Mathematical logic employs a lot of Latin.
"Quod erat demonstrandum" means
"which was to be demonstrated".)
We could read the "exact MPP7. Qed."
as "MPP7 is exactly what was to be demonstrated."

Now, the above proof is reminiscent of the way that
proofs are presented in symbolic logic courses,
where you have to write down a numbered list of formulas,
and each formula must be justified as a premise,
an assumption, or as the result of applying a
rule of inference.  This proof is based
on an exercise in G. M. Hardegree's
"Symbolic Logic" #textbook.³#
It's great if you're writing proofs down by hand,
because it's easier to write single letters
than whole words.
But in the computer age, where typing words is easy,
we can be more expressive in formal proofs, like so:

**)

Axiom Patricia_is_prepared_to_make_marmalade : Prop.

Axiom Patricia_has_bought_quinces : Prop.

Axiom Patricia_was_in_Robert's_store : Prop.

Axiom Patricia_was_in_Sarnia : Prop.

Axiom Patricia_is_indeed_prepared_to_make_marmalade
    : Patricia_is_prepared_to_make_marmalade.

Axiom Patricia_needs_quinces_to_make_marmalade
    : Patricia_is_prepared_to_make_marmalade
        -> Patricia_has_bought_quinces.

Axiom Patricia_always_buys_quinces_from_Robert
    : Patricia_has_bought_quinces
        -> Patricia_was_in_Robert's_store.

Axiom Robert's_store_is_in_Sarnia
    : Patricia_was_in_Robert's_store
        -> Patricia_was_in_Sarnia.

Theorem Patricia_was_indeed_in_Sarnia : Patricia_was_in_Sarnia.

Proof.

assert (She_has_indeed_bought_quinces
    := Patricia_needs_quinces_to_make_marmalade
        ( Patricia_is_indeed_prepared_to_make_marmalade )
    : Patricia_has_bought_quinces).

assert (She_was_indeed_in_Robert's_store
    := Patricia_always_buys_quinces_from_Robert
        ( She_has_indeed_bought_quinces )
    : Patricia_was_in_Robert's_store).

assert (She_was_indeed_in_Sarnia
    := Robert's_store_is_in_Sarnia
        ( She_was_indeed_in_Robert's_store )
    : Patricia_was_in_Sarnia).

exact She_was_indeed_in_Sarnia.

Qed.

(**

Theorem T1 and theorem [Patricia_was_indeed_in_Sarnia]
are the same theorem, but in different forms.
The first theorem uses abbreviations and is very terse,
and it has comments explaining everything.
The second theorem uses whole words,
and doesn't need comments, but it is very verbose,
and I've had to use some conventions.
(For example, X_was_indeed_Y means that X_was_Y is true.)

So is theorem [Patricia_was_indeed_in_Sarnia]
easier to read and follow than theorem T1?
I would say yes, but [Patricia_was_indeed_in_Sarnia]
is easier to read than T1 much like the
three of clubs ranks higher than the two of clubs.
It's only marginally better.

I would say that there is more than one art of
computer programming #(cf. Knuth⁴)#
and one of those arts must be that happy medium
between terse and verbose.

So that's the second article. My plan for the
third article is to strike towards the happy medium.

** References:

#¹# Institut national de recherche en
sciences et technologies du numérique (Inria).
"The Coq Proof Assistant."
https://coq.inria.fr/

#²# Nahas, Michael.  "Mike Nahas's Coq Tutorial."
https://mdnahas.github.io/doc/nahas_tutorial.v

#³# Hardegree, G. M. (1999)
    "Symbolic Logic: A First Course."
    McGraw-Hill College.
    Section 5.22, exercise 1.
    <https://courses.umass.edu/phil110-gmh/MAIN/IHome-5.htm>

#⁴# Knuth, D. E. (1997, 1998, 2011)
    "The Art of Computer Programming."
    Addison-Wesley. Four volumes.

**)

End Article_2_A_Little_Sentential_Calculus.


(** 4 optional exercises attempted and 4 completed *)

(** Exercise 1(and_assoc) *)
Theorem and_assoc : forall P Q R : Prop,
  P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R H.
  inversion H as [HP [HQ HR]].
  split. split. apply HP. apply HQ. apply HR.
Qed.

(** Exercise 2 (or_distributes_over_and_2) *)
Theorem or_distributes_over_and_2 : forall P Q R : Prop,
  (P \/ Q) /\ (P \/ R) -> P \/ (Q /\ R).
Proof.
  intros P Q R. intros H. inversion H as [[HP | HQ] [HP' | HR]].
  apply or_introl. apply HP.
  apply or_introl. apply HP.
  apply or_introl. apply HP'.
  apply or_intror. split. apply HQ. apply HR.
Qed.

(** Exercise 3 (contrapositive) *)
Theorem contrapositive : forall P Q : Prop,
  (P -> Q) -> (~Q -> ~P).
Proof.
  intros P Q H. unfold not. intros HQF.
  intros HP. apply H in HP. apply HQF in HP.
  apply HP.
Qed.

(** Exercise 4 ((false_beq_nat) *)
Theorem beq_nat_false : forall n m,
  beq_nat n m = false -> n <> m.
Proof.
  intros n. unfold not. induction n as [| n'].
  Case "n = 0".
    intros m H. destruct m as [| m'].
    SCase "m = 0". simpl in H. inversion H.
    SCase "m = S m'". intros. inversion H0.
  Case "n = S n'".
    intros m H. destruct m as [| m'].
    SCase "m = 0". intros. inversion H0.
    SCase "m = S m'". intros. simpl in H. apply IHn' in H. apply H. inversion H0. reflexivity.
Qed.

(** Exercise 5 (optional (proj2))*)
Theorem proj2 : forall P Q : Prop,
  P /\ Q -> Q.
Proof.
  intros. inversion H. apply H1.
Qed.

(** Exercise 6 (optional (iff_properties)) *)
Theorem iff_refl : forall P : Prop,
  P <-> P.
Proof.
  intros. unfold iff. split.
    intros. apply H.
    intros. apply H.
Qed.

Theorem iff_trans : forall P Q R : Prop,
  (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  intros P Q R HPQ HQR.
  inversion HPQ.
  inversion HQR.
  unfold iff. split.
  intros. apply H in H3. apply H1 in H3. apply H3.
  intros. apply H2 in H3. apply H0 in H3. apply H3.
Qed.

(** Exercise 7 (optional (or_distributes_over_and)) *)
Theorem or_distributes_over_and : forall P Q R : Prop,
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R. split.
  apply or_distributes_over_and_1.
  apply or_distributes_over_and_2.
Qed.

(** Exercise 8 (optional (andb_false)) *)
Theorem andb_false : forall b c,
  andb b c = false -> b = false \/ c = false.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    destruct c.
    SCase "c = true". inversion H.
    SCase "c = false". right. apply H.
  Case "b = false".
    destruct c.
    SCase "c = true". left. apply H.
    SCase "c = false". left. apply H.
Qed.

(** Exercise 9 (not_both_true_and_false) *)
Theorem not_both_true_and_false : forall P : Prop,
  ~ (P /\ ~P).
Proof.
  intros P. unfold not.
  apply contradiction_implies_anything.
Qed.

(** Exercise 10 (excluded_middle_irrefutable) *)
Theorem excluded_middle_irrefutable:  forall (P:Prop), ~ ~ (P \/ ~ P).
Proof.
  intros. unfold not. intros. apply H.
  right. intros. apply H.
  left. apply H0.
Qed.


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Problem(s):
    Recognizing axiomatizations of Hilbert-style calculi (HSC_AX)
    (Linial-Post theorem, strengthened by Bokov [1,2])

  HSC_AX:
    Given a list s₁,...,sₙ of formulae such that
    [a → b → a] ⊢ sᵢ is derivable for i = 1...n,
    is [s₁,...,sₙ] ⊢ a → b → a derivable?

  References:
    [1] Grigoriy V. Bokov: Undecidable problems for propositional calculi with implication.
      Logic Journal of the IGPL, 24(5):792–806, 2016. doi:10.1093/jigpal/jzw013
    [2] Andrej Dudenhefner, Jakob Rehof: Lower End of the Linial-Post Spectrum.
      TYPES 2017: 2:1-2:15. doi: 10.4230/LIPIcs.TYPES.2017.2
*)

Require Import PeanoNat.
Require Import List.
Import ListNotations.

From Undecidability.HSC Require Import HSC_prelim.

(* the formula a → b → a *)
Definition a_b_a : formula := arr (var 0) (arr (var 1) (var 0)).

(* list of formulae derivable from a → b → a *)
Definition HSC_AX_PROBLEM := { Gamma: list formula | forall s, In s Gamma -> hsc [a_b_a] s}.

(* is the formula a → b → a derivable? *)
Definition HSC_AX (l: HSC_AX_PROBLEM) := hsc (proj1_sig l) a_b_a.


Require Import Reals.
Local Open Scope R_scope.
From ValidSDP Require Import validsdp.

Let p (x0 x1 x2 x3 x4 x5 : R) :=
  (0 - x1) * x2 - x0 * x3 + x1 * x4 + x2 * x5 - x4 * x5
  + x0 * (0 - x0 + x1 + x2 - x3 + x4 + x5).

Let b1 (x0 x1 x2 x3 x4 x5 : R) :=
  (x0 - 4/1) * (40401/10000 - x0).

Let b2 (x0 x1 x2 x3 x4 x5 : R) :=
  (x1 - 4/1) * (40401/10000 - x1).

Let b3 (x0 x1 x2 x3 x4 x5 : R) :=
  (x2 - 784/100) * (8/1 - x2).

Let b4 (x0 x1 x2 x3 x4 x5 : R) :=
  (x3 - 4/1) * (40401/10000 - x3).

Let b5 (x0 x1 x2 x3 x4 x5 : R) :=
  (x4 - 4/1) * (40401/10000 - x4).

Let b6 (x0 x1 x2 x3 x4 x5 : R) :=
  (x5 - 784/100) * (8/1 - x5).

Theorem p_nonneg (x0 x1 x2 x3 x4 x5 : R) :
  b1 x0 x1 x2 x3 x4 x5 >= 0 ->
  b2 x0 x1 x2 x3 x4 x5 >= 0 ->
  b3 x0 x1 x2 x3 x4 x5 >= 0 ->
  b4 x0 x1 x2 x3 x4 x5 >= 0 ->
  b5 x0 x1 x2 x3 x4 x5 >= 0 ->
  b6 x0 x1 x2 x3 x4 x5 >= 0 ->
  p x0 x1 x2 x3 x4 x5 >= 0.
Proof.
unfold b1, b2, b3, b4, b5, b6, p.
validsdp.
Qed.


(* This file was tested with coq 8.10.0 and coquelicot 3.0.4 *)

Require Import Reals Coquelicot.Coquelicot Psatz.

Lemma lim_atan_p_infty :
  filterlim atan (Rbar_locally p_infty) (at_left (PI/2)).
Proof.
assert (0 < PI) by (assert (t := PI2_RGT_0); psatzl R).
intros S [ep Pep].
set (e' := Rmin (PI/2) ep).
assert (0 < e') by now apply Rmin_glb_lt; destruct ep; auto; psatzl R.
assert (e' <= PI/2) by apply Rmin_l.
exists (tan (PI/2 - e')); intros x Px.
assert (atan x < PI/2) by (destruct (atan_bound x); psatzl R).
apply Pep;[|psatzl R].
change (Rabs (atan x - PI/2) < ep).
rewrite Rabs_left, Ropp_minus_distr;[| psatzl R].
apply Rlt_le_trans with (PI / 2 - atan (tan (PI / 2 - e'))).
  now apply Rplus_lt_compat_l, Ropp_lt_contravar, atan_increasing.
replace (atan (tan (PI / 2 - e'))) with (PI / 2 - e').
  now ring_simplify; apply Rmin_r.
apply tan_is_inj;[psatzl R | apply atan_bound | now rewrite atan_right_inv].
Qed.

Lemma lim_atan_m_infty :
  filterlim atan (Rbar_locally m_infty) (at_right (-PI/2)).
Proof.
apply filterlim_ext with (fun x => - (atan (- x))).
  now intros; rewrite atan_opp, Ropp_involutive.
apply (filterlim_comp _ _ _ (fun x => atan (- x)) Ropp _ (at_left (PI/2))).
  apply (filterlim_comp _ _ _ Ropp atan _ (Rbar_locally p_infty)).
    now apply filterlim_Rbar_opp.
  now apply lim_atan_p_infty.
replace (- PI / 2) with (- (PI / 2)) by field.
apply filterlim_Ropp_left.
Qed.

Lemma atan_left_inv x : -PI / 2 < x < PI / 2 -> atan (tan x) = x.
Proof.
intros [intx1 intx2].
destruct (atan_bound (tan x)).
destruct (Rtotal_order (atan (tan x)) x) as [abs | [ it | abs]]; auto;
  apply tan_increasing in abs; try lra; rewrite atan_right_inv in abs;
  lra.
Qed.

Lemma atan_lim_pinfty : Lim atan p_infty = PI/2.
Proof.
assert (t := PI2_RGT_0).
apply is_lim_unique; intros P [eps Peps].
assert (ep2 : 0 < Rmin eps (PI/4)).
  apply Rmin_glb_lt;[apply cond_pos | lra].
set (eps' := mkposreal _ ep2).
assert (eps' < PI / 2).
  unfold eps'; simpl.
  apply Rle_lt_trans with (PI/4).
    now apply Rmin_r.
  lra.
assert (eps' <= eps).
  now unfold eps'; simpl; apply Rmin_l.
assert (0 < eps') by apply cond_pos.
exists (tan (PI / 2 - eps')); intros x cx.
apply Peps. change (Rabs (atan x -PI/2) < eps).
  rewrite Rabs_left; cycle 1.
  destruct (atan_bound x); lra.
enough (PI / 2 - eps' < atan x) by lra.
rewrite <- (atan_left_inv (PI/2 - eps')); cycle 1.
  now split; psatzl R.
now apply atan_increasing.
Qed.

Lemma atan_lim_minfty : Lim atan m_infty = -PI/2.
Proof.
assert (t := PI2_RGT_0).
apply is_lim_unique; intros P [eps Peps].
assert (ep2 : 0 < Rmin eps (PI/4)).
  apply Rmin_glb_lt;[apply cond_pos | lra].
set (eps' := mkposreal _ ep2).
assert (eps' < PI / 2).
  unfold eps'; simpl.
  apply Rle_lt_trans with (PI/4).
    now apply Rmin_r.
  lra.
assert (eps' <= eps).
  now unfold eps'; simpl; apply Rmin_l.
assert (0 < eps') by apply cond_pos.
exists (tan (-PI / 2 + eps')); intros x cx.
apply Peps; change (Rabs (atan x - -PI/2) < eps).
  rewrite Rabs_right; cycle 1.
  destruct (atan_bound x); lra.
enough (atan x < -PI / 2 + eps') by lra.
rewrite <- (atan_left_inv (-PI/2 + eps')); cycle 1.
  now split; psatzl R.
now apply atan_increasing.
Qed.

Lemma integral_atan_comp_scal m : 0 < m ->
   is_RInt_gen (fun x => /m * /((x / m) ^ 2 + 1))
       (Rbar_locally m_infty) (Rbar_locally p_infty) PI.
Proof.
(* assert (tmp := PI2_RGT_0). *)
intros m0.
assert (is_derive_atan_scal : forall x,
           is_derive (fun x => atan (x / m)) x (/ m * /((x/m)^2 + 1))).
  intros x; auto_derive; auto; field.
  split; apply Rgt_not_eq; auto; apply Rplus_le_lt_0_compat.
    now apply pow2_ge_0.
  now apply pow2_gt_0, Rgt_not_eq.
intros P [eps Peps].
(* assert (ep2 : 0 < Rmin eps (PI/2)).
  apply Rmin_glb_lt;[apply cond_pos | psatzl R].
assert (eps' := mkposreal _ ep2).
*)
assert (atle : at_left (PI/2) (ball (PI/2) (pos_div_2 eps))).
  now exists (pos_div_2 eps); intros; tauto.
assert (atri : at_right (-PI/2) (ball (-PI/2) (pos_div_2 eps))).
  now exists (pos_div_2 eps); intros; tauto.
assert (H0 := lim_atan_p_infty _ atle).
assert (H0' := lim_atan_m_infty _ atri).
assert (abs' : 0 < / m) by now apply Rinv_0_lt_compat.
assert (H1 : filterlim (fun x => x / m) (Rbar_locally p_infty)
                (Rbar_locally p_infty)).
  replace (Rbar_locally p_infty) with (Rbar_locally (Rbar_mult p_infty (/ m))) at 2.
    now apply filterlim_Rbar_mult_r.
  apply f_equal; simpl; case (Rle_dec 0 (/ m)).
    intros r; case (Rle_lt_or_eq_dec 0 (/ m) r); auto.
    now intros abs; rewrite <- abs in abs'; case (Rlt_irrefl 0).
  now intros abs; case abs; apply Rlt_le.
assert (H2 : filterlim (fun x => x / m) (Rbar_locally m_infty)
                (Rbar_locally m_infty)).
  replace (Rbar_locally m_infty) with (Rbar_locally (Rbar_mult m_infty (/ m))) at 2.
    now apply filterlim_Rbar_mult_r.
  apply f_equal; simpl; case (Rle_dec 0 (/ m)).
    intros r; case (Rle_lt_or_eq_dec 0 (/ m) r); auto.
    now intros abs; rewrite <- abs in abs'; case (Rlt_irrefl 0).
  now intros abs; case abs; apply Rlt_le.
assert (t := filterlim_comp R R R (fun x => x / m) atan (Rbar_locally p_infty)
              (Rbar_locally p_infty) (at_left (PI/2)) H1 lim_atan_p_infty).
assert (t' := filterlim_comp R R R (fun x => x / m) atan (Rbar_locally m_infty)
              (Rbar_locally m_infty) (at_right (-PI/2)) H2 lim_atan_m_infty ).
specialize (t _ atle).
specialize (t' _ atri).
unfold filtermapi, filtermap in t, t' |- *.
apply (Filter_prod _ _ _ _ _ t' t).
intros x y; exists (atan (y/m) - atan (x/m)); split.
  apply (is_RInt_derive (fun x => atan (x / m))).
    intros z _; exact (is_derive_atan_scal z).
  intros z _; apply (ex_derive_continuous (fun x1 => /m * / ((x1 / m) ^ 2 + 1))).
  auto_derive; change ((z / m) ^ 2 + 1 <> 0).
  now apply Rgt_not_eq, Rplus_le_lt_0_compat;
           [apply pow2_ge_0 | apply Rlt_0_1].
apply Peps.
change (Rabs ((atan (y / m) - atan (x / m)) - PI) < eps).
replace ((atan (y / m) - atan (x / m)) - PI) with
    ((atan (y / m) - PI / 2) - (atan (x / m) + PI / 2)) by field.
apply Rle_lt_trans with (1 := Rabs_triang _ _).
replace (pos eps) with (pos_div_2 eps + pos_div_2 eps) by (simpl; field).
apply Rplus_lt_compat.
  exact H3.
rewrite <- Rabs_Ropp, !Ropp_plus_distr, Ropp_involutive, <- Ropp_div.
exact H.
Qed.

Lemma atan_derivative_improper_integral :
  is_RInt_gen (fun x => /(x ^ 2 + 1))
     (Rbar_locally m_infty) (Rbar_locally p_infty) PI.
Proof.
apply is_RInt_gen_ext with (fun x =>  /1 * /((x/1)^2 + 1)).
  exists (Rgt 0) (Rlt 0); try (exists 0; intros; psatzl R).
  intros x y _ _ z _; rewrite Rdiv_1, Rinv_1, Rmult_1_l; reflexivity.
apply integral_atan_comp_scal; psatzl R.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) : natural := plus (Succ y) Zero.


Require Export Recdef.

From FormalSystems Require Export Base.

Inductive AExp : Type :=
    | AConst : nat -> AExp
    | Var : Loc -> AExp
    | ABinOp : (nat -> nat -> nat) -> AExp -> AExp -> AExp.

Inductive BExp : Type :=
    | BConst : bool -> BExp
    | BRelOp : (nat -> nat -> bool) -> AExp -> AExp -> BExp
    | Not : BExp -> BExp
    | BBinOp : (bool -> bool -> bool) -> BExp -> BExp -> BExp.

Inductive Com : Type :=
    | Skip : Com
    | Asgn : Loc -> AExp -> Com
    | Seq : Com -> Com -> Com
    | If : BExp -> Com -> Com -> Com
    | While : BExp -> Com -> Com.

Definition State : Type := Loc -> nat.

Definition initialState : State := fun _ => 0.

Definition changeState (s : State) (x : Loc) (n : nat) : State :=
  fun y : Loc => if x =? y then n else s y.

Fixpoint loca (a : AExp) : list Loc :=
match a with
    | AConst _ => []
    | Var x => [x]
    | ABinOp f a1 a2 => loca a1 ++ loca a2
end.

Definition acompatible (a : AExp) (s1 s2 : State) : Prop :=
  forall x : Loc, In x (loca a) -> s1 x = s2 x.

Fixpoint locb (b : BExp) : list Loc :=
match b with
    | BConst _ => []
    | BRelOp _ a1 a2 => loca a1 ++ loca a2
    | Not b' => locb b'
    | BBinOp _ b1 b2 => locb b1 ++ locb b2
end.

Definition bcompatible (b : BExp) (s1 s2 : State) : Prop :=
  forall x : Loc, In x (locb b) -> s1 x = s2 x.

(* The list of all variables which are assigned to by the instruction c. *)
Fixpoint locw (c : Com) : list Loc :=
match c with
    | Skip => []
    | Asgn v _ => [v]
    | Seq c1 c2 => locw c1 ++ locw c2
    | If _ c1 c2 => locw c1 ++ locw c2
    | While _ c => locw c
end.

Definition wcompatible (c : Com) (s1 s2 : State) : Prop :=
  forall x : Loc, In x (locw c) -> s1 x = s2 x.

(* The list of all variables mentioned in c. *)
Fixpoint loc (c : Com) : list Loc :=
match c with
    | Skip => []
    | Asgn v a => v :: loca a
    | Seq c1 c2 => loc c1 ++ loc c2
    | If b c1 c2 => locb b ++ loc c1 ++ loc c2
    | While b c => locb b ++ loc c
end.

Definition ccompatible (c : Com) (s1 s2 : State) : Prop :=
  forall x : Loc, In x (loc c) -> s1 x = s2 x.


Require Import Classical.
Require Export Ensembles.
Require Import EnsemblesImplicit.
Require Export Relation_Definitions.
Require Import Relation_Definitions_Implicit.
Require Import EnsemblesSpec.

Unset Standard Proposition Elimination Names.

Section MinimalElements.

Variable T:Type.
Variable R:relation T.

(* R is well-founded if and only if every nonempty subset of
   T has a minimal element *)

Definition minimal_element_property : Prop :=
  forall S:Ensemble T, Inhabited S -> exists x:T, In S x /\
    forall y:T, In S y -> ~ R y x.

Lemma WF_implies_MEP: well_founded R -> minimal_element_property.
Proof.
unfold well_founded.
unfold minimal_element_property.
intros WF S Hinh.
destruct Hinh.
revert x H.
apply (@well_founded_ind T R WF
 (fun x:T =>
  In S x -> exists y:T, In S y /\ (forall z:T, In S z -> ~ R z y))).
intros.
case (classic (forall y:T, In S y -> ~ R y x)).
exists x.
split.
assumption.
assumption.

intro.
apply not_all_ex_not in H1.
destruct H1.
apply imply_to_and in H1.
destruct H1.
apply H with x0.
apply NNPP.
assumption.
assumption.
Qed.

Lemma MEP_implies_WF: minimal_element_property -> well_founded R.
Proof.
unfold well_founded.
unfold minimal_element_property.
intro MEP.
apply NNPP.
intuition.
apply not_all_ex_not in H.
destruct H.
assert (Inhabited [x:T | ~ Acc R x]).
exists x.
constructor; assumption.
apply MEP in H0.
destruct H0.
destruct H0.
destruct H0.
contradict H0.
constructor.
intros.
apply NNPP.
intuition.
apply H1 with y.
constructor; assumption.
assumption.
Qed.

End MinimalElements.

Section DecreasingSequences.

(* R is well-founded if and only if there is no infinite strictly
   decreasing sequence of elements of T *)

Variable T:Type.
Variable R:relation T.

Definition decreasing_sequence_property :=
  forall a:nat->T, exists n:nat, ~ R (a (S n)) (a n).

Lemma WF_implies_DSP: well_founded R -> decreasing_sequence_property.
Proof.
unfold decreasing_sequence_property.
intros WF a.
remember (a 0) as a0.
revert a0 a Heqa0.
apply (well_founded_ind WF (fun x:T =>
  forall a:nat->T, x = a 0 -> exists n:nat, ~ R (a (S n)) (a n))).
intros.
case (classic (R (a 1) (a 0))).
intro.
pose (b := fun n:nat => a (S n)).
assert (exists n:nat, ~ R (b (S n)) (b n)).
apply H with (a 1).
rewrite H0.
assumption.
trivial.
destruct H2.
exists (S x0).
unfold b in H2.
assumption.

exists 0.
assumption.
Qed.

Require Import ClassicalChoice.

Lemma DSP_implies_WF: decreasing_sequence_property -> well_founded R.
Proof.
unfold decreasing_sequence_property.
intro DSP.
apply MEP_implies_WF.
unfold minimal_element_property.
intro S0.
intros.
apply NNPP.
intuition.
assert (forall x:T, In S0 x -> exists y:T, In S0 y /\ R y x).
intros.
apply NNPP.
intuition.
assert (forall y:T, ~(In S0 y /\ R y x)).
apply not_ex_all_not.
assumption.
apply H0.
exists x.
split.
assumption.
intros.
apply H3 with y.
tauto.

pose (S_type := {x:T | In S0 x}).
assert (exists f:S_type -> S_type, forall x:S_type,
  R (proj1_sig (f x)) (proj1_sig x)).
apply choice with (R:=fun x y:S_type => R (proj1_sig y) (proj1_sig x)).
intro.
destruct x.
simpl.
pose proof (H1 x i).
destruct H2.
destruct H2.
exists (exist (fun x:T => In S0 x) x0 H2).
simpl.
assumption.

destruct H2 as [f Hf].

destruct H.
pose (b := nat_rect (fun n:nat => S_type)
  (exist (fun x:T => In S0 x) x H)
  (fun (n:nat) (x:S_type) => f x)).
simpl in b.
pose (a := fun n:nat => (proj1_sig (b n))).
assert (forall n:nat, R (a (S n)) (a n)).
unfold a.
intro.
simpl.
apply Hf.

contradict DSP.
apply ex_not_not_all.
exists a.
apply all_not_not_ex.
auto.
Qed.

End DecreasingSequences.


Require Export Relations.

Require Export List.

(* Dictionaries : a dictionary is roughly a partial maping from
   keys to values  *)

Module Type DEC_ORDER.
 Parameter A : Set.
 Parameter le : A -> A -> Prop.
 Parameter lt : A -> A -> Prop.
 Axiom ordered : order A le.
 Axiom lt_le_weak : forall a b:A, lt a b -> le a b.
 Axiom lt_diff : forall a b:A, lt a b -> a <> b.
 Axiom le_lt_or_eq : forall a b:A, le a b -> lt a b \/ a = b.
 Parameter lt_eq_lt_dec : forall a b:A, {lt a b} + {a = b} + {lt b a}.
End DEC_ORDER.

(* some derived theorems on dec_orders *)

Module Type MORE_DEC_ORDERS.
 Parameter A : Set.
 Parameter le : A -> A -> Prop.
 Parameter lt : A -> A -> Prop.
 Axiom le_trans : transitive A le.
 Axiom le_refl : reflexive A le.
 Axiom le_antisym : antisymmetric A le.
 Axiom lt_irreflexive : forall a:A, ~ lt a a.
 Axiom lt_trans : transitive A lt.
 Axiom lt_not_le : forall a b:A, lt a b -> ~ le b a.
 Axiom le_not_lt : forall a b:A, le a b -> ~ lt b a.
 Axiom lt_intro : forall a b:A, le a b -> a <> b -> lt a b.
 Parameter le_lt_dec : forall a b:A, {le a b} + {lt b a}.
 Parameter le_lt_eq_dec : forall a b:A, le a b -> {lt a b} + {a = b}.
End MORE_DEC_ORDERS.

(* A functor for getting some useful derived properties on decidable
   orders *)

Module More_Dec_Orders (D: DEC_ORDER) : MORE_DEC_ORDERS with Definition
  A := D.A with Definition le := D.le with Definition lt := D.lt.

 Definition A := D.A.
 Definition le := D.le.
 Definition lt := D.lt.

 Theorem le_trans : transitive A le.
 Proof.
   case D.ordered; auto.
 Qed.

 Theorem le_refl : reflexive A le.
  Proof.
   case D.ordered; auto.
 Qed.

 Theorem le_antisym : antisymmetric A le.
 Proof.
   case D.ordered; auto.
 Qed.

 Theorem lt_intro : forall a b:A, le a b -> a <> b -> lt a b.
 Proof.
   intros a b H diff; case (D.le_lt_or_eq a b H); tauto.
 Qed.

 Theorem lt_irreflexive : forall a:A, ~ lt a a.
 Proof.
  intros a H.
  case (D.lt_diff _ _ H); trivial.
 Qed.

 Theorem lt_not_le : forall a b:A, lt a b -> ~ le b a.
 Proof.
  intros a b H H0.
  absurd (a = b).
  apply D.lt_diff; trivial.
  apply le_antisym; auto; apply D.lt_le_weak; assumption.
 Qed.

 Theorem le_not_lt : forall a b:A, le a b -> ~ lt b a.
 Proof.
  intros a b H H0; apply (lt_not_le b a); auto.
 Qed.

 Theorem lt_trans : transitive A lt.
 Proof.
  unfold A, transitive in |- *.
  intros x y z H H0.
  apply (lt_intro x z).
  apply le_trans with y; apply D.lt_le_weak; assumption.
  intro e; rewrite e in H.
  absurd (y = z).
  intro e'; rewrite e' in H.
  apply (lt_irreflexive _ H).
  apply le_antisym; apply D.lt_le_weak; trivial.
 Qed.

 Definition le_lt_dec : forall a b:A, {le a b} + {lt b a}.
  intros a b; case (D.lt_eq_lt_dec a b).
  intro d; case d; auto.
  left; apply D.lt_le_weak; trivial.
  simple induction 1; left; apply le_refl.
  right; trivial.
 Defined.

 Definition le_lt_eq_dec : forall a b:A, le a b -> {lt a b} + {a = b}.
  intros a b H.
  case (D.lt_eq_lt_dec a b).
  trivial.
  intro H0; case (le_not_lt a b H H0).
 Defined.

End More_Dec_Orders.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Coq_Cats.Type_Cat.Type_Cat.

Section Arrow.
  Local Open Scope morphism_scope.

  (** The type accomodating all arrows of a category C. *)
  Record Arrow (C : Category) :=
    {
      Orig : Obj;
      Targ : Obj;
      Arr : Orig –≻ Targ
    }.

  Arguments Orig {_} _ : clear implicits.
  Arguments Targ {_} _ : clear implicits.
  Arguments Arr {_} _ : clear implicits.

  Coercion Arr : Arrow >-> Hom.

  (** An arrow (in the appropriate category, e.g., comma) from arrow f : a -> b to arrow g : c -> d is a pair of arrows h1 : a -> c and h2 : b -> d that makes the following diagram commute:
#

          f
   a ———————————> b
   |              |
h1 |              | h2
   |              |
   ↓              ↓
   c ———————————> d
          g

#
 *)
  Record Arrow_Hom {C : Category} (a b : Arrow C) :=
    {
      Arr_H : (Orig a) –≻ (Orig b);
      Arr_H' : (Targ a) –≻ (Targ b);
      Arr_Hom_com : Arr_H' ∘ (Arr a) = (Arr b) ∘ Arr_H
    }.
  Arguments Arr_H {_ _ _} _ : clear implicits.
  Arguments Arr_H' {_ _ _} _ : clear implicits.
  Arguments Arr_Hom_com {_ _ _} _ : clear implicits.

  Context (C : Category).

  Section Arrow_Hom_eq_simplify.
    Context {a b : Arrow C} (f g : Arrow_Hom a b).

    (** Two arrow homomorphisms are equal if the arrows between theor domains and codomain are respectively equal. In other words, we don't cate about the proof of the diagram commuting. *)
    Lemma Arrow_Hom_eq_simplify : Arr_H f = Arr_H g → Arr_H' f = Arr_H' g → f = g.
    Proof.
      destruct f; destruct g.
      basic_simpl.
      ElimEq.
      doHomPIR.
      reflexivity.
    Qed.

  End Arrow_Hom_eq_simplify.

  Section Compose_id.
    Context {x y z} (h : Arrow_Hom x y) (h' : Arrow_Hom y z).

    (** Composition of arrow homomorphisms. We basicall need to show that in the following diagram, the bigger diagram commutes if the smaller ones do.
#

           f
    a ———————————> b
    |              |
 h1 |              | h2
    |              |
    ↓              ↓
    c ———————————> d
    |      g       |
h1' |              | h2'
    |              |
    ↓              ↓
    c ———————————> d
           h

#
*)
    Program Definition Arrow_Hom_compose : Arrow_Hom x z :=
      {|
        Arr_H := (Arr_H h') ∘ (Arr_H h);
        Arr_H' := (Arr_H' h') ∘ (Arr_H' h)
      |}.

    Next Obligation. (* Arr_Hom_com *)
    Proof.
      destruct h as [hh hh' hc]; destruct h' as [h'h h'h' h'c]; cbn.
      rewrite assoc.
      rewrite hc.
      repeat rewrite assoc_sym.
      rewrite h'c.
      auto.
    Qed.

    (** The identity arrow morphism. We simply need to show that the following diagram commutes:
#

          f
   a ———————————> b
   |              |
id |              | id
   |              |
   ↓              ↓
   a ———————————> b
          f

#
which is trivial.
 *)
    Program Definition Arrow_id : Arrow_Hom x x :=
      {|
        Arr_H := id;
        Arr_H' := id
      |}.

  End Compose_id.

End Arrow.

Hint Extern 1 (?A = ?B :> Arrow_Hom _ _) => apply Arrow_Hom_eq_simplify; simpl.

Arguments Orig {_} _ : clear implicits.
Arguments Targ {_} _ : clear implicits.
Arguments Arr {_} _ : clear implicits.

Arguments Arr_H {_ _ _} _ : clear implicits.
Arguments Arr_H' {_ _ _} _ : clear implicits.
Arguments Arr_Hom_com {_ _ _} _ : clear implicits.

(** an arrow in a category is also an arrow in the opposite category. The domain and codomain are simply swapped. *)
Program Definition Arrow_to_Arrow_OP (C : Category) (ar : Arrow C) : Arrow (C ^op) :=
  {|
    Arr := ar
  |}.

Local Hint Extern 1 => unfold Sect.

(** The type of arrows of a category and the type of arrows of its opposite are isomorphic. *)
Program Definition Arrow_OP_Iso (C : Category) : (Arrow C) <~> (Arrow (C ^op)) :=
  {|
    equiv_fun := Arrow_to_Arrow_OP C;
    equiv_isequiv :=
      {|
        equiv_inv := Arrow_to_Arrow_OP (C ^op)
      |}
  |}.


From mathcomp Require Import ssreflect.
From Category.Base Require Import Logic Category Functor NatTran.

Set Universe Polymorphism.

Open Scope type_scope.

Program Definition ProductCat (C D : Category) : Category :=
  {|
    Obj := (Obj C) * (Obj D);
    Hom := fun X Y => Hom (fst X) (fst Y) * Hom (snd X) (snd Y);
    Hom_Id := fun X => pair (\Id (fst X)) (\Id (snd X));
    Hom_comp :=
      fun (X Y Z : (Obj C) * (Obj D)) =>
        fun
          (f1 : Hom (fst Y) (fst Z) * Hom (snd Y) (snd Z))
          (f2 : Hom (fst X) (fst Y) * Hom (snd X) (snd Y))
        => pair (fst f1 \o fst f2) (snd f1 \o snd f2)

  |}.
Next Obligation.
Proof.
  rewrite /=.
  by repeat rewrite Hom_assoc.
Qed.
Next Obligation.
  rewrite /=.
  by repeat rewrite Hom_IdL.
Qed.
Next Obligation.
  rewrite /=.
  by repeat rewrite Hom_IdR.
Qed.

Program Definition DiagonalFunctor (C : Category) : Functor C (ProductCat C C) :=
  {|
    FApp := fun (X : Obj C) => pair X X;
    FAppH := fun (X Y : Obj C) (f : Hom X Y) => pair f f
  |}.


Require Import Relations.

Lemma wf_inclusion :
 forall (A:Set) (R S:A -> A -> Prop),
   inclusion A R S -> well_founded S -> well_founded R.
Proof.
 intros A R S Hincl Hwf x.
  induction  x as [x IHx] using (well_founded_ind Hwf).
  constructor;  auto.
Qed.


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

 Preservation of certain colimits by pullbacks

 The pullback functor always has a left biadjoint, which is given by
 composition. For that reason, pullbacks always preserve limits such as
 terminal objects, products, inserters, and equifiers. However, in general,
 the pullback functor does not have a right adjoint (this is even not the
 case in the bicategory of categories), and this pseudofunctor does not
 even preserve all colimits. If we have some additional assumptions, then
 we can show that certain colimits are preserved.
 If the bicategory has a strict biinitial (i.e., all maps into that object
 are equivalents), then the pullback pseudofunctor preserves biinitial
 objects.

 Contents
 1. Pullbacks preserve strict biinitial objects

 **************************************************************************)
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.Core.NaturalTransformations.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.PullbackFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction.
Require Import UniMath.Bicategories.PseudoFunctors.Preservation.Preservation.
Require Import UniMath.Bicategories.Modifications.Modification.
Require Import UniMath.Bicategories.Colimits.Initial.
Require Import UniMath.Bicategories.Colimits.Extensive.
Require Import UniMath.Bicategories.Colimits.Examples.SliceBicategoryColimits.
Require Import UniMath.Bicategories.Limits.Pullbacks.
Require Import UniMath.Bicategories.Limits.PullbackFunctions.

Local Open Scope cat.

(**
 1. Pullbacks preserve strict biinitial objects
 *)
Definition pullback_preserves_biinitial
           (B : bicat_with_pb)
           (HI : strict_biinitial_obj B)
           {b₁ b₂ : B}
           (f : b₁ --> b₂)
  : preserves_biinitial
      (pb_psfunctor B f).
Proof.
  pose (H := map_to_strict_biinitial_is_biinitial
               (pr2 HI)
               (pb_pr2 f (is_biinitial_1cell_property (pr12 HI) b₂))).
  use (preserves_chosen_biinitial_to_preserve_biinitial
         (_ ,, _)
         (pb_psfunctor B f)).
  - apply biinitial_in_slice.
    exact (pr1 HI ,, pr12 HI).
  - use (equiv_from_biinitial
           (is_biinitial_slice
              (pb_obj f (is_biinitial_1cell_property (pr12 HI) b₂)
               ,,
               H)
              b₁)).
    + use make_1cell_slice.
      * apply id₁.
      * cbn.
        use is_biinitial_invertible_2cell_property.
        exact H.
    + use left_adjoint_equivalence_in_slice_bicat.
      cbn.
      apply internal_adjoint_equivalence_identity.
Defined.


(* Types and Functions *)

Inductive day : Type :=
| sun : day
| mon : day
| tue : day
| wed : day
| thu : day
| fri : day
| sat : day.

Let next_day d :=
  match d with
  | sun => mon
  | mon => tue
  | tue => wed
  | wed => thu
  | thu => fri
  | fri => sat
  | sat => sun
  end.

Definition prev_day d :=
  match d with
  | sun => sat
  | mon => sun
  | tue => mon
  | wed => tue
  | thu => wed
  | fri => thu
  | sat => fri
  end.

(* Theorems and proofs *)

Theorem wed_after_tue : next_day tue = wed.
Proof.
  auto.
Qed.

Print wed_after_tue.

(* eq_refl -- from Coq stdlib. Says "Equality is reflexive" *)

Theorem wed_after_tue' : next_day tue = wed.
Proof.
  (* new tactics -- simpl, trivial *)

  simpl. trivial.
Qed.

Print wed_after_tue'.
(* same proof as using [auto] *)

(* The day of the week never repeats. *)
Theorem day_never_repeats : forall d : day, next_day d <> d.

Proof. auto. (* stuck? *)

  (* new tactics -- intros, destruct, discriminate *)

  intros d. destruct d.
  simpl. discriminate.
  simpl. discriminate.
  simpl. discriminate.
  simpl. discriminate.
  simpl. discriminate.
  simpl. discriminate.
  simpl. discriminate.

Qed.

(* Same as previous; avoid tedium *)
Theorem day_never_repeats' : forall d : day, next_day d <> d.
Proof.
  intros d. destruct d.
  all: discriminate.
  (* discriminate does simplification as well! *)
Qed.

(* Introduce a "tactical" ; which combines tactics *)
Theorem day_never_repeats'' : forall d : day, next_day d <> d.
Proof.
  intros d. destruct d; discriminate.
Qed.

Theorem mon_preceds_tues : forall d : day,
  next_day d = tue -> d = mon.

(* What's the intuitive proof?
   - Consider every day one by one
   - precondition (LHS of implication) is false in 6 cases. Hence, holds.
   - The other d is mon.
*)
Proof.
  (* naming introductions explicitly *)
  intros d next_day_is_tue.
  destruct d; discriminate || trivial.

  (* || is a tactical. In t1 || t2, if t1 fails, then try t2. *)
Qed.

(**********************************************************************)

(* Lists *)

(* Import full list library; by default some parts are included *)
Require Import List.
Import ListNotations.

Module MyList. (* We can have modules within files *)

Inductive list (A : Type) : Type :=
| nil : list A
| cons : A -> list A -> list A.

End MyList.

(* What is the Coq stdlib definition of "list" *)
Check list.
(* [list] is a type constructor *)

Definition is_empty (A : Type) (lst : list A) :=
  match lst with
  | nil => true
  | cons _ _ => false
  end.
(* Need explicit types for [is_empty]. Coq's type system _vastly_ more
   expressive than OCaml's. Type inference is not possible always. *)

Definition is_empty_sugar (A : Type) (lst : list A) :=
  match lst with
  | [] => true
  | _::_ => false
  end.
(* [], :: are syntactic sugar for list constructors nil and cons *)

Compute is_empty nat [1].

Compute is_empty nat [].

(* Implicit arguments -- infer type from context; mostly works) *)
Definition is_empty' {A : Type} (lst : list A) :=
  match lst with
  | [] => true
  | _::_ => false
  end.

Compute is_empty' [1].

Check is_empty'.

Compute @is_empty' nat [1]. (* provide implcit argument explicitly! *)

Module MyLength.

(* Fixpoint in Coq = let rec in OCaml *)
Fixpoint length {A : Type} (lst : list A) :=
  match lst with
  | nil => 0
  | _::t => 1 + length t
  end.

Compute length [1;2].

End MyLength.

(**********************************************************************)

(* Options *)

Module MyOption.

Inductive option (A:Type) : Type :=
  | Some : A -> option A
  | None : option A.

End MyOption.

Definition hd_opt {A : Type} (lst : list A) : option A :=
  match lst  with
  | nil => None
  | x :: _ => Some x
  end.

Compute hd_opt [1].

Compute hd_opt [].

Compute @hd_opt nat [].

(* When [hd_opt] is applied to a list of length 0, it returns [None]. *)
Theorem length0_implies_hdopt_is_none :
  forall A : Type, forall lst : list A,
    length lst = 0 -> hd_opt lst = None.
Proof.
  intros A lst length_lst_is_0.
  destruct lst.
    simpl. trivial. (* trivial does simplification *)
    simpl in length_lst_is_0. discriminate.
Qed.

Theorem length0_implies_hdopt_is_none' :
forall A : Type, forall lst : list A,
  length lst = 0 -> hd_opt lst = None.
Proof.
  intros A lst length_lst_is_0.
  destruct lst.
    - trivial.
    - discriminate. (* skipped explicit simplification *)
Qed.

(** The characters [+] and [*] can also be used as bullets, as can [--], [---],
etc.

(**********************************************************************)

** Summary

- Coq is a proof assistant
  + Includes a OCaml like FP langauge (Gallina)
  + Type system more advanced than OCaml
  + Tactic language (Ltac) for proving things about programs
  + Simple proofs about lists and options
*)


(** We use Coq's definitions for falsity, truth,
    conjunctions, and disjunctions. *)

Module Show_Definitions.
  Inductive False := .
  Inductive True := I.
  (** We cheat with negation.  Will be explained later. *)
  Notation "~ P" := (P -> False).
  Inductive and (P Q: Prop) : Prop :=
  | conj: P -> Q -> and P Q.
  Inductive or (P Q: Prop) : Prop :=
  | or_introl: P -> or P Q
  | or_intror: Q -> or P Q.
End Show_Definitions.

Print False.
Print True.
Print and.
Print or.

Definition elim_False
  : forall Z: Type, False -> Z
  := fun Z a => match a with end.

Locate "/\".
Check and.
Print and.
Print or.
About or.  (* Overloaded implicit arguments *)

Definition match_and
  : forall X Y Z: Prop, X /\ Y -> (X -> Y -> Z) -> Z
  := fun X Y Z a e => match a with conj x y => e x y end.

Definition match_or
  : forall X Y Z: Prop, X \/ Y -> (X -> Z) -> (Y -> Z) -> Z
  := fun X Y Z a e1 e2 => match a with or_introl x => e1 x | or_intror y => e2 y end.

Section Demo.
  Variables X Y Z: Prop.

  (** We type check normal proofs.  Note how
      implicit arguments are supplied if necessary.
      Also note how parentheses are ommitted in the types derived. **)

  Check fun x:X => x.
  Check fun (x: X) (y: Y) => x.
  Check fun (x: X) (y: Y) => y.
  Check fun (f: X -> Y -> Z) y x => f x y.
  Check fun h: X /\ Y => match h with conj x y => x end.
  Check fun h: X /\ Y => match h with conj x y => y end.
  Check fun h: X /\ Y => match h with conj x y => conj y x end.
  Check fun h: (X /\ Y) /\ Z => match h with
                             conj (conj x y) z => conj x (conj y z)
                           end.

  (** Note implicit argument overloading of or_introl and or_intror *)

  Check fun h: X \/ Y => match h with
                       or_introl x => or_intror Y x
                     | or_intror y => or_introl X y
                     end.
  Check fun h: (X \/ Y) \/ Z => match h with
                             or_introl (or_introl x) => or_introl (Y \/ Z) x
                           | or_introl (or_intror y) => or_intror (or_introl y)
                           | or_intror z => or_intror (or_intror z)
                           end.
  Check conj
        (fun h: X /\ Y => match h with conj x y => conj y x end)
        (fun h: Y /\ X => match h with conj y x => conj x y end).

  Check fun h: False => match h return X with end.  (* exfalso quodlibet *)

  Check fun x (f: ~X) => f x.
  Check fun x (f: ~X) => elim_False Y (f x).
  Check fun x (f: ~X) => match f x return Y with end.
  Check fun (f: X -> ~X) g => let x := g (fun x => f x x) in f x x.

  (** Proof construction with tactics **)

  Goal ~ ~X -> (X -> ~X) -> False.
  Proof.
    refine (fun f g => _).
    refine (f _).
    refine (fun x => _).
    exact (g x x).
    Show Proof.
  Qed.

  Goal ~ ~X -> (X -> ~X) -> False.
  Proof.
    intros f g.
    apply f.
    intros x.
    exact (g x x).
    Show Proof.
  Qed.

  Goal ~(X <-> ~X).
  Proof.
    refine (fun a => match a with conj f g => _ end).
    refine (let x:X := _ in f x x).
    refine (g (fun x => _)).
    exact (f x x).
    Show Proof.
  Qed.

  Fact Russell :
    ~(X <-> ~X).
  Proof.
    intros [f g].
    assert (x: X).
    - apply g. intros x. exact (f x x).
    - exact (f x x).
    Show Proof.
  Qed.

  Goal X /\ (Y \/ Z) <-> (X /\ Y) \/ (X /\ Z).
  Proof.
    refine (conj _ _).
    - refine (fun a => match a with
                    | conj x b => match b with
                                 | or_introl y => _
                                 | or_intror z => _
                                 end
                    end).
      + exact (or_introl (conj x y)).
      + exact (or_intror (conj x z)).
    - refine (fun a => match a with
                    | or_introl b => match b with conj x y => _ end
                    | or_intror b => match b with conj x z => _ end
                    end).
      + exact (conj x (or_introl y)).
      + exact (conj x (or_intror z)).
    Show Proof.
  Qed.

  Goal X /\ (Y \/ Z) <-> (X /\ Y) \/ (X /\ Z).
  Proof.
    split.
    - intros [x [y|z]].
      + left. split.
        * exact x.
        * exact y.
      + right. split.
        * exact x.
        * exact z.
    - intros [[x y]|[x z]].
      + split.
        * exact x.
        * left. exact y.
      + split.
        * exact x.
        * right. exact z.
    Show Proof.
  Qed.

  Goal X /\ (Y \/ Z) <-> (X /\ Y) \/ (X /\ Z).
  Proof.
    split.
    - intros [x [y|z]].
      + auto.
      + auto.
    - intros [[x y]|[x z]].
      + auto.
      + auto.
    Show Proof.
  Qed.

  Goal X /\ (Y \/ Z) <-> (X /\ Y) \/ (X /\ Z).
  Proof.
    tauto.
    Show Proof.  (* Uses match functions *)
  Qed.

  Goal ~ ~(X -> Y) <-> (~ ~X -> ~ ~Y).
  Proof.
    apply conj.
    - intros f g h.
      apply f. intros f'.
      apply g. intros x.
      exact (h (f' x)).
    - intros f g.
      apply g. intros x.
      exfalso.
      apply f.
      + intros h. exact (h x).
      + intros y. exact (g (fun _ => y)).
   Show Proof.
  Qed.

  Goal X <-> Y -> Y <-> Z -> X <-> Z.
  Proof.
    refine (fun a => match a with conj f g => _ end).
    refine (fun a' => match a' with conj f' g' => _ end).
    refine (conj (fun x => _) (fun z => _)).
    - exact (f' (f x)).
    - exact (g (g' z)).
    Show Proof.
  Qed.

  Goal X <-> Y -> Y <-> Z -> X <-> Z.
  Proof.
    intros [f g] [f' g'].
    split.
    - intros x. exact (f' (f x)).
    - intros z. exact (g (g' z)).
  Show Proof.
  Qed.

End Demo.

(** Assumed variables are now taken as leading arguments *)

Check Russell.

Goal forall X (p q: X -> Prop),
    (forall x, p x <-> q x) -> (forall x, q x) -> forall x, p x.
Proof.
  intros X p q f g x.
  destruct (f x) as [_ h].
  exact (h (g x)).
  Show Proof.
Qed.

Goal forall X (p q: X -> Prop),
    (forall x, p x <-> q x) -> (forall x, q x) -> forall x, p x.
Proof.
  intros X p q f g x.
  refine (match f x with conj _ h => _ end).
  exact (h (g x)).
  Show Proof.
Qed.

(** Impredicative characterizations *)

Goal False <-> forall Z: Prop, Z.
Proof.
  split.
  - intros [].
  - intros f. exact (f False).
  Show Proof.
Qed.

Goal forall X Y: Prop,
    X /\ Y <-> forall Z: Prop, (X -> Y -> Z) -> Z.
Proof.
  intros X Y.
  split.
  - intros [x y] Z f. exact (f x y).
  - intros f.  exact (f (X /\ Y) (@conj X Y)).
Qed.

Goal forall X Y: Prop,
    X \/ Y <-> forall Z: Prop, (X -> Z) -> (Y -> Z) -> Z.
Proof.
  intros X Y.
  split.
  - intros [x|y] Z f g.
    + exact (f x).
    + exact (g y).
  - intros f.
    exact (f (X \/ Y) (@or_introl X Y) (@or_intror X Y)).
  Show Proof.
Qed.