(**
私家版：代数的構造とCoq
「Magma の六角形」を実装してみる。

@suharahiromichi

2015_01_02
2015_05_01
*)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(*
Generalizable All Variables.
個別に宣言する。
*)
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.

(**
# Setoid
 *)
Class setoid_equal (A : Type) := setoid_eq : A -> A -> Prop.
Infix "==" := setoid_eq.
Class Setoid (A : Type) (equal : setoid_equal A) : Prop :=
  {
    (* 同値関係（だけ） *)
    prf_Setoid_ref :                        (* 反射律 *)
      forall x : A, equal x x;
    prf_Setoid_sym :                        (* 対象律 *)
      forall x y : A, equal x y -> equal y x;
    prf_Setoid_trans :                      (* 推移律 *)
      forall x y z : A, equal x y -> equal y z -> equal x z
  }.

Generalizable Variables A equal.

Class magma_binop `{X : @Setoid A equal} := magma_op : A -> A -> A.
Infix "*" := magma_op.
Class Magma `{X : @Setoid A equal} (dot : magma_binop) : Prop :=
  {
    prf_binop : forall (x1 y1 x2 y2 : A),
                  x1 == y1 -> x2 == y2 -> x1 * x2 == y1 * y2
  }.

(* ******************** *)
(* ***** 性質 ********* *)
(* ******************** *)
Generalizable Variables dot ST.

Class Associative `{X : @Magma A equal ST dot} : Prop :=
  associative : forall (x y z : A), (x * y) * z == x * (y * z).

Class LIdentical `{X : @Magma A equal ST dot} (e : A) : Prop :=
  left_identical: forall x : A, e * x == x.

Class RIdentical `{X : @Magma A equal ST dot} (e : A) : Prop :=
  right_identical: forall x : A , x * e == x.

Class Identical `{X : @Magma A equal ST dot} (e : A) : Prop :=
  {
    identical_l : LIdentical e;
    identical_r : RIdentical e
  }.

(* divの引数を直感的な順番にした。 *)
Class LDivisible `{X : @Magma A equal ST dot} (div : A -> A -> A) : Prop :=
  left_divisible: forall (a b : A), (div b a) * a == b.

Class RDivisible `{X : @Magma A equal ST dot} (div : A -> A -> A) : Prop :=
  right_divisible: forall (a b : A), a * (div b a) == b.

Class Divisible `{X : @Magma A equal ST dot} (divL divR : A -> A -> A) : Prop :=
  {
    divisible_l : LDivisible divL;
    divisible_r : RDivisible divL
  }.

(* Invertible の定義を Monoid からMagmaに移動する。 *)
Class LInvertible `{X : @Magma A equal ST dot}  (e : A) (inv : A -> A) : Prop :=
  left_invertible: forall (x : A), (inv x) * x == e.

Class RInvertible `{X : @Magma A equal ST dot}  (e : A) (inv : A -> A) : Prop :=
  right_invertible: forall (x : A), (inv x) * x == e.

Class Invertible `{X : @Magma A equal ST dot}  (e : A) (inv : A -> A) : Prop :=
  {
    invertible_l :> LInvertible e inv;
    invertible_r :> RInvertible e inv
  }.

(* ******************** *)
(* bool 排他的論理和の群 *)
(* ******************** *)
Check setoid_equal bool.
Instance bool_equal : setoid_equal bool := eq.
Check false == true : Prop.

Check @Setoid bool bool_equal.
Program Instance bool_setoid : @Setoid bool bool_equal.
Next Obligation.
    by [].                                  (* bool_equal は reflextivity できる。 *)
Qed.
Next Obligation.
    by [].
Qed.
Next Obligation.
  by rewrite H H0.                          (* bool_equal は rewrite できる。 *)
Qed.

Check @magma_binop bool bool_equal bool_setoid.
Instance bool_dot : @magma_binop bool bool_equal bool_setoid := xorb.
Eval compute in false * false.              (* false *)
Eval compute in false * true.               (* true *)
Eval compute in true * false.               (* true *)
Eval compute in true * true.                (* false *)

Check @Magma bool bool_equal bool_setoid bool_dot.
Program Instance bool_magma : @Magma bool eq bool_setoid xorb.
Next Obligation.
  by rewrite H H0.
Qed.

Section Group_1.
  Generalizable Variables divl divr one MG QG.

  Check @Magma.
  Check `(@Magma A equal ST dot).
  Class qg_divop `{X : @Magma A equal ST dot} := qg_op : A -> A -> A.
  Infix "/" := qg_op.
  Class Quasigroup `{X : @Magma A equal ST dot} (divl divr : qg_divop) : Prop :=
    {
      divisible : Divisible divl divr
    }.

  Check @Quasigroup.
  Check `(@Quasigroup A equal ST dot MG divl divr).
  Class lp_unitop `{X : @Quasigroup A equal ST dot MG divl divr} := lp_op : A.
  Class Loop `{X : @Quasigroup A equal ST dot MG divl divr} (lp_unit : A) : Prop :=
    {
      lp_identical : Identical lp_unit      (* IdenticalはMagmaで定義している。 *)
    }.

  Check @Loop.
  Check `(@Loop A equal ST dot MG divl divr QG one).
  Class Group_1 `{X : @Loop A equal ST dot MG divl divr QG one} : Prop :=
    {
        prf_group_1 : Associative
    }.

  (* ******************** *)
  (* bool 排他的論理和の群 *)
  (* ******************** *)
  Check @qg_divop bool bool_equal bool_setoid bool_dot bool_magma.
  Instance bool_div : @qg_divop bool bool_equal bool_setoid bool_dot bool_magma := xorb.
  Eval compute in false / false.              (* false *)
  Eval compute in false / true.               (* true *)
  Eval compute in true / false.               (* true *)
  Eval compute in true / true.                (* false *)

  Check @Quasigroup bool bool_equal bool_setoid bool_dot bool_magma bool_div bool_div.
  Program Instance bool_qg : @Quasigroup bool bool_equal bool_setoid bool_dot bool_magma bool_div bool_div.
  Next Obligation.
  Proof.
    apply Build_Divisible.
    - rewrite /LDivisible.                  (* 左割算 *)
      rewrite /bool_div.
        by case; case.
    - rewrite /RDivisible.                  (* 右割算 *)
      rewrite /bool_div.
        by case; case.
  Qed.

  Check `(@lp_unitop bool eq ST xorb MG divl divr QG).
  Check @lp_unitop bool bool_equal bool_setoid bool_dot bool_magma bool_div bool_div bool_qg.
  Instance bool_unit : @lp_unitop bool bool_equal bool_setoid bool_dot bool_magma bool_div bool_div bool_qg := false.

  Program Instance bool_loop : @Loop bool bool_equal bool_setoid bool_dot bool_magma bool_div bool_div bool_qg bool_unit.
  Next Obligation.
    apply Build_Identical.
    - rewrite /LIdentical.                  (* 左単位元 *)
        by case.
    - rewrite /RIdentical.                  (* 右単位元 *)
        by case.
  Qed.

  Check @Group_1 bool bool_equal bool_setoid bool_dot bool_magma bool_div bool_div bool_qg bool_unit bool_loop.
  Program Instance bool_group_1 : @Group_1 bool bool_equal bool_setoid bool_dot bool_magma bool_div bool_div bool_qg bool_unit bool_loop.
  Next Obligation.                          (* 結合則 *)
  Proof.
    rewrite /Associative.
      by apply Bool.xorb_assoc_reverse.
  Qed.
End Group_1.

Section Group_2.
  Generalizable Variables one MG SG.        (* MGは、Group_1 とは別なものになる。 *)

  Check @Magma.
  Class Semigroup `{X : @Magma A equal ST dot} : Prop :=
    {
      prf_semigroup : forall (x y z : A), (x * y) * z == x * (y * z)
    }.

  Check @Semigroup.
  Class Monoid `{X : @Semigroup A equal ST dot MG} (mon_unit : A) : Prop :=
    {
      mon_identical : Identical mon_unit    (* IdenticalはMagmaで定義している。 *)
  }.

  Check @Monoid.
  Class gp_invop `{X : @Monoid A equal ST dot MG SG one} := gp_op : A -> A.
  (* Invertible の定義を Monoid からMagmaに移動する。 *)
  Class Group_2 `{X : @Monoid A equal ST dot MG SG one} (inv : gp_invop) : Prop :=
    {
      invertible : Invertible one inv
    }.

  (* ******************** *)
  (* bool 排他的論理和の群 *)
  (* ******************** *)
  Check @Semigroup bool bool_equal bool_setoid bool_dot bool_magma.
  Program Instance bool_sg : @Semigroup bool bool_equal bool_setoid bool_dot bool_magma.
  Next Obligation.                          (* 結合則 *)
  Proof.
    rewrite /magma_op /bool_dot.
    by rewrite Bool.xorb_assoc_reverse.
  Qed.

  Check Monoid bool_unit.
  Check @Monoid bool bool_equal bool_setoid bool_dot bool_magma bool_sg bool_unit.
  Program Instance bool_monoid : @Monoid bool bool_equal bool_setoid bool_dot bool_magma bool_sg bool_unit.
  Next Obligation.
    apply Build_Identical.
    - rewrite /LIdentical.                  (* 左単位元 *)
        by case.
    - rewrite /RIdentical.                  (* 右単位元 *)
        by case.
  Qed.
  Check bool_monoid : Monoid bool_unit.

  Check gp_invop.
  Check @gp_invop bool bool_equal bool_setoid bool_dot bool_magma bool_sg bool_unit bool_monoid.
  Instance bool_inv : @gp_invop bool bool_equal bool_setoid bool_dot bool_magma bool_sg bool_unit bool_monoid := id.

  Check @Group_2 bool bool_equal bool_setoid bool_dot bool_magma bool_sg bool_unit bool_monoid bool_inv.
  Program Instance bool_groop_2 : @Group_2 bool bool_equal bool_setoid bool_dot bool_magma bool_sg bool_unit bool_monoid bool_inv.
  Next Obligation.
    apply Build_Invertible.
    - rewrite /LInvertible.                 (* 左逆元 *)
      rewrite /bool_unit /bool_inv => x.
      by case x.
    - rewrite /RInvertible.                 (* 右逆元 *)
      rewrite /bool_unit /bool_inv => x.
      by case x.
  Qed.

  (* 補足説明 *)
  Check `(@Monoid bool bool_equal ST bool_dot MG SG bool_unit).
  (* 一部を、Generalizable Variable にしてもよいが、証明している対象が違ってきているかもしれない。 *)
  Program Instance bool_monoid' : `(@Monoid bool bool_equal ST bool_dot MG SG bool_unit).
  Next Obligation.
    apply Build_Identical.
    - rewrite /LIdentical.                  (* 左単位元 *)
        by case.
    - rewrite /RIdentical.                  (* 右単位元 *)
        by case.
  Qed.
  Check bool_monoid'. (* forall (ST : Setoid bool_equal) (MG : Magma bool_dot) (SG : Semigroup), Monoid bool_unit *)

  Program Instance bool_groop_2' : Group_2 bool_inv. (* @がいらない場合もある。 *)
  Next Obligation.
    apply Build_Invertible.
    - rewrite /LInvertible.                 (* 左逆元 *)
      rewrite /bool_unit /bool_inv => x.
        by case x.
    - rewrite /RInvertible.                 (* 右逆元 *)
      rewrite /bool_unit /bool_inv => x.
        by case x.
  Qed.
End Group_2.

Section Group_3.
  Generalizable Variables inv divl divr one MG QG LP SG MON GP.

  Check @Group_1.
  Check `(@Group_1 A equal ST dot MG divl divr QG one LP).
  Class gp1_invop `{X : @Group_1 A equal ST dot MG divl divr QG one LP} := gp1_op : A -> A.

  Class inv_Group_1 `{@Group_1 A equal ST dot MG divl divr QG one LP} (inv : gp1_invop) : Prop :=
    {
      invertible' : Invertible one inv
    }.

  Check `(@Group_2 A equal ST dot MG SG one MON inv).
  Class gp2_divop `{@Group_2 A equal ST dot MG SG one MON inv} := gp2_op : A -> A -> A.
  Infix "/" := gp2_op.
  Class div_Group_2 `{@Group_2 A equal ST dot MG SG one MON inv} (divl divr : gp2_divop) : Prop :=
    {
      divisible' : Divisible divl divr
    }.

End Group_3.

(**
# 参考：
    http://www.labri.fr/perso/casteran/CoqArt/TypeClassesTut/typeclassestut.pdf
    http://mathink.net/program/coq_setoid.html
    http://mathink.net/program/coq_map.html
    http://mathink.net/program/coq_group.html
    http://en.wikipedia.org/wiki/Magma_(algebra)
*)

(* END *)


Require Export Families.
Require Import EnsemblesSpec.

Local Unset Standard Proposition Elimination Names.

Record Filter (X:Type) : Type := {
  filter_family: Family X;
  filter_intersection: forall S1 S2:Ensemble X,
    In filter_family S1 -> In filter_family S2 ->
    In filter_family (Intersection S1 S2);
  filter_upward_closed: forall S1 S2:Ensemble X,
    In filter_family S1 -> Included S1 S2 ->
    In filter_family S2;
  filter_full: In filter_family Full_set;
  filter_empty: ~ In filter_family Empty_set
}.

Arguments filter_family [X].

Record filter_basis {X:Type} (F:Filter X) (B:Family X) : Prop := {
  filter_basis_elements: Included B (filter_family F);
  filter_basis_cond: forall S:Ensemble X,
    In (filter_family F) S -> exists S':Ensemble X,
    In B S' /\ Included S' S
}.

Require Import IndexedFamilies.
Require Import FiniteTypes.

Lemma filter_finite_indexed_intersection: forall {X:Type} (F:Filter X)
  {A:Type} (S:IndexedFamily A X),
  FiniteT A -> (forall a:A, In (filter_family F) (S a)) ->
  In (filter_family F) (IndexedIntersection S).
Proof.
intros.
induction H.
rewrite empty_indexed_intersection.
apply filter_full.
replace (IndexedIntersection S) with
  (Intersection (IndexedIntersection (fun a:T => S (Some a)))
                (S None)).
apply filter_intersection.
apply IHFiniteT; auto.
apply H0.
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
destruct H1.
constructor.
destruct a; (apply H1 || apply H2).
destruct H1.
constructor; trivial.
constructor; auto.

destruct H1 as [g].
replace (IndexedIntersection S) with
  (IndexedIntersection (fun x:X0 => S (f x))).
apply IHFiniteT; auto.
apply Extensionality_Ensembles; split; red; intros.
destruct H3.
constructor.
intros.
pose proof (H3 (g a)).
congruence.
destruct H3.
constructor.
intro.
apply H3.
Qed.

Section filter_from_basis.

Variable X:Type.
Variable B:Family X.
Hypothesis B_nonempty: Inhabited B.
Hypothesis B_empty: ~ In B Empty_set.
Hypothesis B_basis_cond: forall S1 S2:Ensemble X,
  In B S1 -> In B S2 -> exists T:Ensemble X,
  In B T /\ Included T (Intersection S1 S2).

Definition Build_Filter_from_basis : Filter X.
refine (Build_Filter X [ S:Ensemble X | exists T:Ensemble X,
                       In B T /\ Included T S ] _ _ _ _).
intros.
destruct H.
destruct H0.
destruct H as [T1 []].
destruct H0 as [T2 []].
destruct (B_basis_cond T1 T2 H H0) as [T' []].
constructor.
exists T'; split; trivial.
red; intros.
apply H4 in H5.
destruct H5.
constructor; auto.

intros.
destruct H.
destruct H as [T []].
constructor.
exists T; split; auto with sets.

constructor.
destruct B_nonempty as [T].
exists T; split; trivial.
red; intros; constructor.
red; intro.
destruct H.
destruct H as [T []].
assert (T = Empty_set).
apply Extensionality_Ensembles; split; auto with sets.
destruct H1.
contradiction B_empty.
Defined.

Lemma filter_from_basis_basis: filter_basis Build_Filter_from_basis B.
Proof.
constructor.
simpl.
red; intros S ?.
constructor.
exists S; split; auto with sets.
intros.
simpl in H.
destruct H.
exact H.
Qed.

End filter_from_basis.

Arguments Build_Filter_from_basis [X].

Require Import FiniteTypes.
Require Import IndexedFamilies.

Record filter_subbasis {X:Type} (F:Filter X) (B:Family X) : Prop := {
  filter_subbasis_elements: Included B (filter_family F);
  filter_subbasis_cond: forall S:Ensemble X,
    In (filter_family F) S -> exists J:Type, FiniteT J /\
          exists T:J->Ensemble X,
          (forall j:J, In B (T j)) /\
          Included (IndexedIntersection T) S
}.

Section filter_from_subbasis.

Variable X:Type.
Variable B:Family X.
Hypothesis B_subbasis_cond: forall (J:Type) (V:J->Ensemble X),
  FiniteT J -> (forall j:J, In B (V j)) ->
  Inhabited (IndexedIntersection V).

Require Import FiniteIntersections.

Definition Build_Filter_from_subbasis: Filter X.
refine (Build_Filter_from_basis (finite_intersections B) _ _ _).
exists Full_set.
constructor.
red; intro.
pose proof (finite_intersection_is_finite_indexed_intersection _ _ H).
destruct H0 as [J [? [V []]]].
assert (Inhabited (IndexedIntersection V)).
apply B_subbasis_cond; trivial.
rewrite <- H2 in H3.
destruct H3.
destruct H3.

intros.
exists (Intersection S1 S2); split; auto with sets.
constructor 3; trivial.
Defined.

Lemma filter_from_subbasis_subbasis:
  filter_subbasis Build_Filter_from_subbasis B.
Proof.
assert (filter_basis Build_Filter_from_subbasis (finite_intersections B)).
apply filter_from_basis_basis.
destruct H.
constructor.
assert (Included B (finite_intersections B)); auto with sets.
red; intros.
constructor; trivial.

intros.
destruct (filter_basis_cond0 S H) as [S' []].
pose proof (finite_intersection_is_finite_indexed_intersection
  _ _ H0).
destruct H2 as [J [? [V []]]].
exists J; split; trivial.
exists V; split; trivial.
rewrite <- H4; trivial.
Qed.

End filter_from_subbasis.

Arguments Build_Filter_from_subbasis [X].

Definition ultrafilter {X:Type} (F:Filter X) : Prop :=
  forall S:Ensemble X, In (filter_family F) S \/
                       In (filter_family F) (Ensembles.Complement S).

Require Import ZornsLemma.

Lemma ultrafilter_extension: forall {X:Type} (F:Filter X),
  exists U:Filter X, Included (filter_family F) (filter_family U) /\
                     ultrafilter U.
Proof.
intros.
pose (PO := { F':Filter X | Included (filter_family F) (filter_family F') }).
pose (PO_ord := fun (F1' F2':PO) =>
  Included (filter_family (proj1_sig F1')) (filter_family (proj1_sig F2'))).
assert (exists U:PO, premaximal PO_ord U).
apply ZornsLemmaForPreorders.
constructor.
red; intro.
destruct x.
red; simpl.
auto with sets.
red; intros.
destruct x; destruct y; destruct z.
red in H; simpl in H.
red in H0; simpl in H0.
red; simpl.
auto with sets.

intros.
Require Import DecidableDec.
destruct (classic_dec (Inhabited S)) as [Hnonempty|Hempty].
unshelve refine (let H0:=_ in let H1:=_ in let H2:=_ in let H3:=_ in
  let ub:=Build_Filter X (IndexedUnion (fun F':{F':PO | In S F'} =>
    filter_family (proj1_sig (proj1_sig F')))) H0 H1 H2 H3 in _);
  [ | clearbody H0 | clearbody H0 H1 | clearbody H0 H1 H2 | clearbody H0 H1 H2 H3 ].
intros.
destruct H0 as [F1'].
destruct H1 as [F2'].
destruct F1' as [[F1']].
destruct F2' as [[F2']].
simpl in H0.
simpl in H1.
destruct (H (exist _ F1' i) (exist _ F2' i1)); trivial.
red in H2; simpl in H2.
apply H2 in H0.
exists (exist _ (exist _ F2' i1)  i2).
simpl.
apply filter_intersection; trivial.
red in H2; simpl in H2.
apply H2 in H1.
exists (exist _ (exist _ F1' i) i0).
simpl.
apply filter_intersection; trivial.

intros.
destruct H1 as [[[F1']]].
simpl in H1.
exists (exist _ (exist _ F1' i) i0).
simpl.
apply filter_upward_closed with x; trivial.
destruct Hnonempty.
exists (exist _ x H2).
simpl.
apply filter_full.

red; intro.
inversion_clear H3 as [F'].
contradict H4.
apply filter_empty.

assert (Included (filter_family F) (filter_family ub)).
simpl.
red; intros.
destruct Hnonempty.
exists (exist _ x0 H5).
simpl.
destruct x0 as [F'].
simpl.
auto.

exists (exist _ ub H4).
intros.
red; simpl.
red; intros.
exists (exist _ y H5).
simpl.
trivial.

assert (Included (filter_family F) (filter_family F)).
auto with sets.
exists (exist _ F H0).
intros.
contradiction Hempty.
exists y; trivial.

destruct H as [[U]].
exists U; split; trivial.
red; intros.
classical_right.
assert (forall S':Ensemble X, In (filter_family U) S' ->
  Inhabited (Intersection S' (Ensembles.Complement S))).
intros.
apply NNPP; red; intro.
contradiction H0.
apply filter_upward_closed with S'; trivial.
red; intros.
apply NNPP; red; intro.
contradiction H2.
exists x.
auto with sets.

unshelve refine (let H2:=_ in let H3:=_ in let H4:=_ in
  let Uext := Build_Filter_from_basis
       (Im (filter_family U) (fun S':Ensemble X =>
          Intersection S' (Ensembles.Complement S))) H2 H3 H4 in _).
exists (Ensembles.Complement S).
exists Full_set.
apply filter_full.
apply Extensionality_Ensembles; split; auto with sets.
red; intros.
constructor; trivial; constructor.
red; intro.
inversion_clear H3 as [S'].
destruct (H1 S' H4) as [x].
rewrite <- H5 in H3.
destruct H3.

intros.
destruct H4.
destruct H5.
exists (Intersection y y0).
split; auto with sets.
exists (Intersection x x0).
apply filter_intersection; trivial.
apply Extensionality_Ensembles; split; red; intros.
destruct H8.
rewrite H6 in H8; destruct H8.
rewrite H7 in H9; destruct H9.
constructor; trivial; constructor; trivial.
destruct H8.
destruct H8.
constructor.
rewrite H6; constructor; trivial.
rewrite H7; constructor; trivial.

assert (Included (filter_family U) (filter_family Uext)).
red; intros.
apply filter_upward_closed with (Intersection x (Ensembles.Complement S)).
assert (filter_basis Uext
  (Im (filter_family U) (fun S':Ensemble X =>
                        Intersection S' (Ensembles.Complement S)))).
apply filter_from_basis_basis.
destruct H6.
apply filter_basis_elements0.
exists x; trivial.
auto with sets.
assert (Included (filter_family F) (filter_family Uext)).
auto with sets.

assert (PO_ord (exist _ U i) (exist _ Uext H6)).
red.
exact H5.
apply H in H7.
apply H7.
change (In (filter_family Uext) (Ensembles.Complement S)).
assert (filter_basis Uext (Im (filter_family U)
  (fun S':Ensemble X => Intersection S' (Ensembles.Complement S)))).
apply filter_from_basis_basis.
destruct H8.
apply filter_basis_elements0.
exists Full_set.
apply filter_full.
apply Extensionality_Ensembles; split; auto with sets.
red; intros.
constructor; trivial; constructor.
Qed.

Require Import InverseImage.

Definition filter_direct_image {X Y:Type} (f:X->Y) (F:Filter X) : Filter Y.
refine (Build_Filter Y
  [ S:Ensemble Y | In (filter_family F) (inverse_image f S) ]
  _ _ _ _).
intros.
destruct H.
destruct H0.
constructor.
rewrite inverse_image_intersection.
apply filter_intersection; trivial.

intros.
destruct H.
constructor.
apply filter_upward_closed with (inverse_image f S1); auto with sets.

constructor.
rewrite inverse_image_full.
apply filter_full.

red; intro.
destruct H.
rewrite inverse_image_empty in H.
revert H; apply filter_empty.
Defined.

Section filter_sum.

Variable X:Type.
Variable F G:Filter X.
Hypothesis F_G_compat: forall S T:Ensemble X,
  In (filter_family F) S -> In (filter_family G) T ->
  Inhabited (Intersection S T).

Definition filter_sum : Filter X.
refine (Build_Filter_from_basis
  (Im [ p:(Ensemble X)*(Ensemble X) |
        let (S,T):=p in In (filter_family F) S /\
                       In (filter_family G) T ]
    (fun p:(Ensemble X)*(Ensemble X) => let (S,T):=p in
       Intersection S T))
  _ _ _).
exists Full_set.
exists ( (Full_set, Full_set) ).
constructor.
split; apply filter_full.
apply Extensionality_Ensembles; split; red; intros.
constructor; constructor.
constructor.

red; intro.
inversion_clear H.
destruct x as [S T].
destruct H0.
destruct H.
assert (Inhabited (Intersection S T)).
apply F_G_compat; trivial.
rewrite <- H1 in H2.
destruct H2.
destruct H2.
intros.
destruct H.
destruct x as [S1 T1].
destruct H0.
destruct H0.
destruct x as [S2 T2].
exists (Intersection y y0).
split; auto with sets.
destruct H0.
destruct H.
destruct H.
exists ( (Intersection S1 S2, Intersection T1 T2) ).
constructor; split; apply filter_intersection; trivial.
rewrite H1; rewrite H2.
apply Extensionality_Ensembles; split; red; intros.
destruct H5.
destruct H5.
destruct H6.
constructor; constructor; trivial.
destruct H5.
destruct H5; destruct H6.
constructor; constructor; trivial.
Defined.

End filter_sum.

Arguments filter_sum [X].


Module Lecture1.
  Require Import Arith.
  Require Import List.

  Definition AnIntegerExists : nat.
  (* First prove by construction. Start with
     Definition AnIntegerExists : nat := _.
     and fill in the underscore. *)

  Lemma AnIntegerExistsB : nat.
  (* Then prove using tactics. Start with
     "Proof." and check out Coq's reports.
     Tactics: `apply`, `intros`, `split`, `destruct`. *)

  Definition Proj1 {A B:Prop} : A /\ B -> A.

  Lemma Proj1B {A B:Prop} : A /\ B -> A.

  (* Use `Locate`, `Check`, and `Print` to figure out
     how <-> works. Start with `Locate "_ <-> _".` *)
  Lemma ObjectivismB {A:Prop} : A <-> A.

  Definition Objectivism {A:Prop} : A <-> A.

  Lemma DistributeAnd {A B C:Prop} :
    A /\ (B \/ C) -> (A /\ B) \/ (A /\ C).

End Lecture1.


Require Import Arith.

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

Fixpoint len (l : lst) : nat :=
    match l with
    | Nil => 0
    | Cons x y => 1 + len y
    end.

Fixpoint append (l1 : lst) (l2 : lst) : lst :=
  match l1 with
  | Nil => l2
  | Cons x y => Cons x (append y l2)
  end.

Fixpoint rev (l1 : lst) : lst :=
    match l1 with
    | Nil => Nil
    | Cons x y => append (rev y) (Cons x Nil)
    end.

Theorem consLT : forall l1 n, (len l1) <= (len (Cons n l1)).
Proof.
  intros. simpl. apply le_n_Sn.
Qed.

Theorem appendLT : forall l1 l2, (len l1) <= (len (append l1 l2)).
Proof.
    intros. induction l1.
    - simpl. apply le_0_n.
    - simpl. apply le_n_S. assumption.
Qed.

Theorem appendLT2 : forall l1 l2, (len l2) <= (len (append l1 l2)).
Proof.
    intros. induction l1.
    - simpl. apply le_refl.
    - simpl. apply Nat.le_le_succ_r. assumption.
Qed.

Lemma append_assoc: forall l1 l2 l3, append l1 (append l2 l3) = (append (append l1 l2) l3).
Admitted.

Lemma len_app_cons: forall l1 l2 n, len (append l1 (Cons n l2)) = S (len (append l1 l2)).
Admitted.

Theorem appendLT3 : forall l1 l2, (len l1) <= (len (append (rev l1) l2)).
Proof.
    induction l1.
    - intros. simpl. apply le_0_n.
    - intros. simpl. rewrite <- append_assoc. simpl. rewrite len_app_cons.
      apply le_n_S. apply IHl1.
Qed.


Require Import List Omega.

Require Import copy.
Require Import dither.
Require Import halting_defs.
Require Import shift.
Require Import shift_maxsource.

(**************** WITNESS Machine ***************)

Definition witness :=
  (app Copy
  (app (shift HM     7)
       (shift Dither (max_source HM 0 + 8)))).

(*** Auxiliary properties for the 2nd path of Undecidability ***)

Lemma max_source_shift: forall M m n k,
      m <= n ->
      max_source (shift M m) (max_source M k + n) =
      max_source M k + n.
induction M; intros.

simpl. reflexivity.

destruct a. destruct p. destruct p.
simpl. elim (le_gt_dec s0 k); intros.
rewrite (gt_false s0 k).
rewrite Nat.add_comm at 1.
rewrite gt_false. apply IHM. assumption.

apply plus_le_compat.
assert (k <= max_source M k). apply max_source_ge. omega.
assumption. assumption.

rewrite (gt_true s0 k).
rewrite Nat.add_comm at 1.
rewrite gt_false. apply IHM. assumption.
apply plus_le_compat. apply max_source_ge. assumption. assumption.
Qed.

Lemma maxsource_swap: forall M n a b,
      max_source (cons a (cons b M)) n =
      max_source (cons b (cons a M)) n.
intros.
destruct a. destruct p. destruct p.
destruct b. destruct p. destruct p. simpl.

elim (le_gt_dec s0 n); intros.

rewrite gt_false.
elim (le_gt_dec s3 n); intros.

rewrite gt_false. reflexivity. assumption.

rewrite gt_true. rewrite gt_false. reflexivity. omega.
assumption. assumption.

rewrite gt_true.
elim (le_gt_dec s3 n); intros.

rewrite gt_false. rewrite gt_false. reflexivity. assumption. omega.

elim (le_gt_dec s3 s0); intros.

rewrite gt_false. rewrite gt_true.
assert (s3 < s0 \/ s3 = s0). apply le_lt_or_eq. assumption.
elim H; clear H a; intro.

rewrite gt_true. reflexivity. assumption.
rewrite H. rewrite gt_false. reflexivity.
omega. assumption. assumption.

rewrite gt_true. rewrite gt_true. rewrite gt_false. reflexivity.
omega. assumption. assumption. assumption.
Qed.

Lemma max_source_1step: forall p a x q b M n,
      max_source ((p, a, x, q) :: b :: M) n =
      if gtstate p n then max_source (b :: M) p
                     else max_source (b :: M) n.
auto.
Qed.

Lemma maxsource_app_comm_item: forall M n a,
      max_source (app M (cons a nil)) n = max_source (cons a M) n.
induction M; intros.

simpl. reflexivity.

rewrite maxsource_swap.
destruct a. destruct p. destruct p.

rewrite max_source_1step. simpl (max_source (((s0, s1, s, h) :: M) ++ a0 :: nil) n).
elim (le_gt_dec s0 n); intros.

rewrite gt_false. apply IHM. assumption.

rewrite gt_true. apply IHM. assumption.
Qed.

Lemma maxsource_app_comm: forall M N n,
      max_source (app M N) n = max_source (app N M) n.
induction M; intros.

simpl. rewrite <- app_nil_end. reflexivity.

assert (N ++ a :: M = app (app N (cons a nil)) M).
rewrite <- ass_app. rewrite <- app_comm_cons. auto.
rewrite H; clear H. rewrite <- IHM.

rewrite <- app_comm_cons. rewrite ass_app.
rewrite <- maxsource_app_comm_item. reflexivity.
Qed.

Lemma max_source_HM_witness:
      max_source witness 0 = max_source HM 0 + 9.
simpl.
rewrite maxsource_app_comm.
simpl. rewrite (gt_true (max_source HM 0 + 8 + 0) 6).
rewrite (gt_true (max_source HM 0 + 8 + 1) (max_source HM 0 + 8 + 0)).
rewrite (gt_false (max_source HM 0 + 8 + 1) (max_source HM 0 + 8 + 1)).

rewrite <- Nat.add_assoc. change (8+1) with 9.

apply max_source_shift. omega.

omega. omega. omega.
Qed.