(******************************************************************************)
(** * Operations on sets (unary relations) *)
(******************************************************************************)

Require Import HahnBase.
Require Import Program.Basics List Arith micromega.Lia Relations Setoid Morphisms.

Set Implicit Arguments.

Local Open Scope program_scope.

(** Definitions of set operations *)
(******************************************************************************)

Section SetDefs.

  Variables A B : Type.
  Implicit Type f : A -> B.
  Implicit Type s : A -> Prop.
  Implicit Type ss : A -> B -> Prop.
  Implicit Type d : B -> Prop.

  Definition set_empty       := fun x : A => False.
  Definition set_full        := fun x : A => True.
  Definition set_compl s     := fun x => ~ (s x).
  Definition set_union s s'  := fun x => s x \/ s' x.
  Definition set_inter s s'  := fun x => s x /\ s' x.
  Definition set_minus s s'  := fun x => s x /\ ~ (s' x).
  Definition set_subset s s' := forall x, s x -> s' x.
  Definition set_equiv s s'  := set_subset s s' /\ set_subset s' s.
  Definition set_finite s    := exists findom, forall x (IN: s x), In x findom.
  Definition set_coinfinite s:= ~ set_finite (set_compl s).
  Definition set_collect f s := fun x => exists y, s y /\ f y = x.
  Definition set_map f d     := fun x => d (f x).
  Definition set_bunion s ss := fun x => exists y, s y /\ ss y x.
  Definition set_disjoint s s':= forall x (IN: s x) (IN': s' x), False.

End SetDefs.

Arguments set_empty {A}.
Arguments set_full {A}.
Arguments set_subset {A}.
Arguments set_equiv {A}.

Notation "P ∪₁ Q" := (set_union P Q) (at level 50, left associativity).
Notation "P ∩₁ Q" := (set_inter P Q) (at level 40, left associativity).
Notation "P \₁ Q" := (set_minus P Q) (at level 46).
Notation "∅"     := (@set_empty _).
Notation "a ⊆₁ b" := (set_subset a b) (at level 60).
Notation "a ≡₁ b" := (set_equiv a b)  (at level 60).
Notation "f ↑₁ P" := (set_collect f P) (at level 30).
Notation "f ↓₁ Q" := (set_map f Q) (at level 30).

Notation "⋃₁ x ∈ s , a" := (set_bunion s (fun x => a))
  (at level 200, x ident, right associativity,
   format "'[' ⋃₁ '/ ' x  ∈  s ,  '/ ' a ']'").
Notation "'⋃₁' x , a" := (set_bunion (fun _ => True) (fun x => a))
  (at level 200, x ident, right associativity,
   format "'[' ⋃₁ '/ ' x ,  '/ ' a ']'").
Notation "'⋃₁' x < n , a" := (set_bunion (fun t => t < n) (fun x => a))
  (at level 200, x ident, right associativity,
   format "'[' ⋃₁ '/ ' x  <  n ,  '/ ' a ']'").
Notation "'⋃₁' x <= n , a" := (set_bunion (fun t => t <= n) (fun x => a))
  (at level 200, x ident, right associativity,
   format "'[' ⋃₁ '/ ' x  <=  n ,  '/ ' a ']'").

(*
Notation "P ∪ Q" := (set_union P Q) (at level 50, left associativity) : function_scope.
Notation "P ∩ Q" := (set_inter P Q) (at level 40, left associativity) : function_scope.
Notation "P \ Q" := (set_minus P Q) (at level 46) : function_scope.
Notation "∅"     := (@set_empty _) : function_scope.
Notation "a ⊆ b" := (set_subset a b) (at level 60) : function_scope.
Notation "a ≡ b" := (set_equiv a b)  (at level 60) : function_scope. *)

Global Hint Unfold set_empty set_full set_compl set_union set_inter : unfolderDb.
Global Hint Unfold set_minus set_subset set_equiv set_coinfinite set_finite : unfolderDb.
Global Hint Unfold set_collect set_map set_bunion set_disjoint : unfolderDb.

(** Basic properties of set operations *)
(******************************************************************************)

Section SetProperties.
  Local Ltac u :=
    repeat autounfold with unfolderDb in *;
    ins; try solve [tauto | firstorder | split; ins; tauto].

  Variables A B C : Type.
  Implicit Type a : A.
  Implicit Type f : A -> B.
  Implicit Type s : A -> Prop.
  Implicit Type d : B -> Prop.
  Implicit Type ss : A -> B -> Prop.

  (** Properties of set complement. *)

  Lemma set_compl_empty : set_compl ∅ ≡₁ @set_full A.
  Proof. u. Qed.

  Lemma set_compl_full : set_compl (@set_full A) ≡₁ ∅.
  Proof. u. Qed.

  Lemma set_compl_compl s : set_compl (set_compl s) ≡₁ s.
  Proof. u. Qed.

  Lemma set_compl_union s s' :
    set_compl (s ∪₁ s') ≡₁ set_compl s ∩₁ set_compl s'.
  Proof. u. Qed.

  Lemma set_compl_inter s s' :
    set_compl (s ∩₁ s') ≡₁ set_compl s ∪₁ set_compl s'.
  Proof. u. Qed.

  Lemma set_compl_minus s s' :
    set_compl (s \₁ s') ≡₁ s' ∪₁ set_compl s.
  Proof. u. Qed.

  (** Properties of set union. *)

  Lemma set_unionA s s' s'' : (s ∪₁ s') ∪₁ s'' ≡₁ s ∪₁ (s' ∪₁ s'').
  Proof. u. Qed.

  Lemma set_unionC s s' : s ∪₁ s' ≡₁ s' ∪₁ s.
  Proof. u. Qed.

  Lemma set_unionK s : s ∪₁ s ≡₁ s.
  Proof. u. Qed.

  Lemma set_union_empty_l s : ∅ ∪₁ s ≡₁ s.
  Proof. u. Qed.

  Lemma set_union_empty_r s : s ∪₁ ∅ ≡₁ s.
  Proof. u. Qed.

  Lemma set_union_full_l s : set_full ∪₁ s ≡₁ set_full.
  Proof. u. Qed.

  Lemma set_union_full_r s : s ∪₁ set_full ≡₁ set_full.
  Proof. u. Qed.

  Lemma set_union_inter_l s s' s'' : (s ∩₁ s') ∪₁ s'' ≡₁ (s ∪₁ s'') ∩₁ (s' ∪₁ s'').
  Proof. u. Qed.

  Lemma set_union_inter_r s s' s'' : s ∪₁ (s' ∩₁ s'') ≡₁ (s ∪₁ s') ∩₁ (s ∪₁ s'').
  Proof. u. Qed.

  Lemma set_union_eq_empty s s' : s ∪₁ s' ≡₁ ∅ <-> s ≡₁ ∅ /\ s' ≡₁ ∅.
  Proof. u. Qed.

  (** Properties of set intersection. *)

  Lemma set_interA s s' s'' : (s ∩₁ s') ∩₁ s'' ≡₁ s ∩₁ (s' ∩₁ s'').
  Proof. u. Qed.

  Lemma set_interC s s' : s ∩₁ s' ≡₁ s' ∩₁ s.
  Proof. u. Qed.

  Lemma set_interK s : s ∩₁ s ≡₁ s.
  Proof. u. Qed.

  Lemma set_inter_empty_l s : ∅ ∩₁ s ≡₁ ∅.
  Proof. u. Qed.

  Lemma set_inter_empty_r s : s ∩₁ ∅ ≡₁ ∅.
  Proof. u. Qed.

  Lemma set_inter_full_l s : set_full ∩₁ s ≡₁ s.
  Proof. u. Qed.

  Lemma set_inter_full_r s : s ∩₁ set_full ≡₁ s.
  Proof. u. Qed.

  Lemma set_inter_union_l s s' s'' : (s ∪₁ s') ∩₁ s'' ≡₁ (s ∩₁ s'') ∪₁ (s' ∩₁ s'').
  Proof. u. Qed.

  Lemma set_inter_union_r s s' s'' : s ∩₁ (s' ∪₁ s'') ≡₁ (s ∩₁ s') ∪₁ (s ∩₁ s'').
  Proof. u. Qed.

  Lemma set_inter_minus_l s s' s'' : (s \₁ s') ∩₁ s'' ≡₁ (s ∩₁ s'') \₁ s'.
  Proof. u. Qed.

  Lemma set_inter_minus_r s s' s'' : s ∩₁ (s' \₁ s'') ≡₁ (s ∩₁ s') \₁ s''.
  Proof. u. Qed.

  (** Properties of set minus. *)

  Lemma set_minusE s s' : s \₁ s' ≡₁ s ∩₁ set_compl s'.
  Proof. u. Qed.

  Lemma set_minusK s : s \₁ s ≡₁ ∅.
  Proof. u. Qed.

  Lemma set_minus_inter_l s s' s'' :
    (s ∩₁ s') \₁ s'' ≡₁ (s \₁ s'') ∩₁ (s' \₁ s'').
  Proof. u. Qed.

  Lemma set_minus_inter_r s s' s'' :
    s \₁ (s' ∩₁ s'') ≡₁ (s \₁ s') ∪₁ (s \₁ s'').
  Proof. u; split; ins; tauto. Qed.

  Lemma set_minus_union_l s s' s'' :
    (s ∪₁ s') \₁ s'' ≡₁ (s \₁ s'') ∪₁ (s' \₁ s'').
  Proof. u. Qed.

  Lemma set_minus_union_r s s' s'' :
    s \₁ (s' ∪₁ s'') ≡₁ (s \₁ s') ∩₁ (s \₁ s'').
  Proof. u. Qed.

  Lemma set_minus_minus_l s s' s'' :
    s \₁ s' \₁ s'' ≡₁ s \₁ (s' ∪₁ s'').
  Proof. u. Qed.

  Lemma set_minus_minus_r s s' s'' :
    s \₁ (s' \₁ s'') ≡₁ (s \₁ s') ∪₁ (s ∩₁ s'').
  Proof. u. Qed.

  (** Properties of set inclusion. *)

  Lemma set_subsetE s s' : s ⊆₁ s' <-> s \₁ s' ≡₁ ∅.
  Proof. u; intuition; apply NNPP; firstorder. Qed.

  Lemma set_subset_eq (P : A -> Prop) a (H : P a): eq a ⊆₁ P.
  Proof. by intros x H'; subst. Qed.

  Lemma set_subset_refl : reflexive _ (@set_subset A).
  Proof. u. Qed.

  Lemma set_subset_trans : transitive _ (@set_subset A).
  Proof. u. Qed.

  Lemma set_subset_empty_l s : ∅ ⊆₁ s.
  Proof. u. Qed.

  Lemma set_subset_empty_r s : s ⊆₁ ∅ <-> s ≡₁ ∅.
  Proof. u. Qed.

  Lemma set_subset_full_l s : set_full ⊆₁ s <-> s ≡₁ set_full.
  Proof. u. Qed.

  Lemma set_subset_full_r s : s ⊆₁ set_full.
  Proof. u. Qed.

  Lemma set_subset_union_l s s' s'' : s ∪₁ s' ⊆₁ s'' <-> s ⊆₁ s'' /\ s' ⊆₁ s''.
  Proof. u. Qed.

  Lemma set_subset_union_r1 s s' : s ⊆₁ s ∪₁ s'.
  Proof. u. Qed.

  Lemma set_subset_union_r2 s s' : s' ⊆₁ s ∪₁ s'.
  Proof. u. Qed.

  Lemma set_subset_union_r s s' s'' : s ⊆₁ s' \/ s ⊆₁ s'' -> s ⊆₁ s' ∪₁ s''.
  Proof. u. Qed.

  Lemma set_subset_inter_r s s' s'' : s ⊆₁ s' ∩₁ s'' <-> s ⊆₁ s' /\ s ⊆₁ s''.
  Proof. u. Qed.

  Lemma set_subset_compl s s' (S1: s' ⊆₁ s) : set_compl s ⊆₁ set_compl s'.
  Proof. u. Qed.

  Lemma set_subset_inter s s' (S1: s ⊆₁ s') t t' (S2: t ⊆₁ t') : s ∩₁ t ⊆₁ s' ∩₁ t'.
  Proof. u. Qed.

  Lemma set_subset_union s s' (S1: s ⊆₁ s') t t' (S2: t ⊆₁ t') : s ∪₁ t ⊆₁ s' ∪₁ t'.
  Proof. u. Qed.

  Lemma set_subset_minus s s' (S1: s ⊆₁ s') t t' (S2: t' ⊆₁ t) : s \₁ t ⊆₁ s' \₁ t'.
  Proof. u. Qed.

  Lemma set_subset_bunion_l s ss sb (H: forall x (COND: s x), ss x ⊆₁ sb) : (⋃₁x ∈ s, ss x) ⊆₁ sb.
  Proof. u. Qed.

  Lemma set_subset_bunion_r s ss sb a (H: s a) (H': sb ⊆₁ ss a) : sb ⊆₁ ⋃₁x ∈ s, ss x.
  Proof. u. Qed.

  Lemma set_subset_bunion s s' (S: s ⊆₁ s') ss ss' (SS: forall x (COND: s x), ss x ⊆₁ ss' x) :
    (⋃₁x ∈ s, ss x) ⊆₁ ⋃₁x ∈ s, ss' x.
  Proof. u. Qed.

  Lemma set_subset_bunion_guard s s' (S: s ⊆₁ s') ss ss' (EQ: ss = ss') :
    (⋃₁x ∈ s, ss x) ⊆₁ (⋃₁x ∈ s', ss' x).
  Proof. subst; u. Qed.

  Lemma set_subset_collect f s s' (S: s ⊆₁ s') : f ↑₁ s ⊆₁ f ↑₁ s'.
  Proof. u. Qed.

  (** Properties of set equivalence. *)

  Lemma set_equivE s s' : s ≡₁ s' <-> s ⊆₁ s' /\ s' ⊆₁ s.
  Proof. u; firstorder. Qed.

  Lemma set_equiv_refl : reflexive _ (@set_equiv A).
  Proof. u. Qed.

  Lemma set_equiv_symm : symmetric _ (@set_equiv A).
  Proof. u. Qed.

  Lemma set_equiv_trans : transitive _ (@set_equiv A).
  Proof. u. Qed.

  Lemma set_equiv_compl s s' (S1: s ≡₁ s') : set_compl s ≡₁ set_compl s'.
  Proof. u. Qed.

  Lemma set_equiv_inter s s' (S1: s ≡₁ s') t t' (S2: t ≡₁ t') : s ∩₁ t ≡₁ s' ∩₁ t'.
  Proof. u. Qed.

  Lemma set_equiv_union s s' (S1: s ≡₁ s') t t' (S2: t ≡₁ t') : s ∪₁ t ≡₁ s' ∪₁ t'.
  Proof. u. Qed.

  Lemma set_equiv_minus s s' (S1: s ≡₁ s') t t' (S2: t ≡₁ t') : s \₁ t ≡₁ s' \₁ t'.
  Proof. u. Qed.

  Lemma set_equiv_bunion s s' (S: s ≡₁ s') ss ss' (SS: forall x (COND: s x), ss x ≡₁ ss' x) :
    set_bunion s ss ≡₁ set_bunion s' ss'.
  Proof. u. Qed.

  Lemma set_equiv_bunion_guard s s' (S: s ≡₁ s') ss ss' (EQ: ss = ss') : set_bunion s ss ≡₁ set_bunion s' ss'.
  Proof. subst; u. Qed.

  Lemma set_equiv_collect f s s' (S: s ≡₁ s') : f ↑₁ s ⊆₁ f ↑₁ s'.
  Proof. u. Qed.

  Lemma set_equiv_subset s s' (S1: s ≡₁ s') t t' (S2: t ≡₁ t') : s ⊆₁ t <-> s' ⊆₁ t'.
  Proof. u. Qed.

  Lemma set_equiv_exp s s' (EQ: s ≡₁ s') : forall x, s x <-> s' x.
  Proof. split; apply EQ. Qed.

  (** Absorption properties. *)

  Lemma set_union_absorb_l s s' (SUB: s ⊆₁ s') : s ∪₁ s' ≡₁ s'.
  Proof. u. Qed.

  Lemma set_union_absorb_r s s' (SUB: s ⊆₁ s') : s' ∪₁ s ≡₁ s'.
  Proof. u. Qed.

  Lemma set_inter_absorb_l s s' (SUB: s ⊆₁ s') : s' ∩₁ s ≡₁ s.
  Proof. u. Qed.

  Lemma set_inter_absorb_r s s' (SUB: s ⊆₁ s') : s ∩₁ s' ≡₁ s.
  Proof. u. Qed.

  Lemma set_minus_absorb_l s s' (SUB: s ⊆₁ s') : s \₁ s' ≡₁ ∅.
  Proof. u. Qed.

  (** Singleton sets *)

  Lemma set_subset_single_l a s : eq a ⊆₁ s <-> s a.
  Proof. u; intuition; desf. Qed.

  Lemma set_subset_single_r a s :
    s ⊆₁ eq a <-> s ≡₁ eq a \/ s ≡₁ ∅.
  Proof.
    u; intuition; firstorder.
    destruct (classic (exists b, s b)) as [M|M]; desf.
       left; split; ins; desf; eauto.
       specialize (H _ M); desf.
    right; split; ins; eauto.
  Qed.

  Lemma set_subset_single_single a b :
    eq a ⊆₁ eq b <-> a = b.
  Proof. u; intuition; desf; eauto using eq_sym. Qed.

  Lemma set_equiv_single_single a b :
    eq a ≡₁ eq b <-> a = b.
  Proof. u; intuition; desf; apply H; ins. Qed.

  Lemma set_nonemptyE s : ~ s ≡₁ ∅ <-> exists x, s x.
  Proof.
    u; intuition; firstorder.
    apply NNPP; intro; apply H0; ins; eauto.
  Qed.

  (** Big union *)

  Lemma set_bunion_empty ss : set_bunion ∅ ss ≡₁ ∅.
  Proof. u. Qed.

  Lemma set_bunion_eq a ss : set_bunion (eq a) ss ≡₁ ss a.
  Proof. u; splits; ins; desf; eauto. Qed.

  Lemma set_bunion_union_l s s' ss :
    set_bunion (s ∪₁ s') ss ≡₁ set_bunion s ss ∪₁ set_bunion s' ss.
  Proof. u. Qed.

  Lemma set_bunion_union_r s ss ss' :
    set_bunion s (fun x => ss x ∪₁ ss' x) ≡₁ set_bunion s ss ∪₁ set_bunion s ss'.
  Proof. u. Qed.

  Lemma set_bunion_bunion_l s ss (ss' : B -> C -> Prop) :
    (⋃₁x ∈ (⋃₁y ∈ s, ss y), ss' x) ≡₁ ⋃₁y ∈ s, ⋃₁x ∈ ss y, ss' x.
  Proof. u. Qed.

  Lemma set_bunion_inter_compat_l s sb ss :
    set_bunion s (fun x => sb ∩₁ ss x) ≡₁ sb ∩₁ set_bunion s ss.
  Proof. u; split; ins; desf; eauto 8. Qed.

  Lemma set_bunion_inter_compat_r s sb ss :
    set_bunion s (fun x => ss x ∩₁ sb) ≡₁ set_bunion s ss ∩₁ sb.
  Proof. u; split; ins; desf; eauto 8. Qed.

  Lemma set_bunion_minus_compat_r s sb ss :
    set_bunion s (fun x => ss x \₁ sb) ≡₁ set_bunion s ss \₁ sb.
  Proof. u; split; ins; desf; eauto 8. Qed.

  (** Collect *)

  Lemma set_collect_compose (f : A -> B) (g : B -> C) s :
    (g ∘ f) ↑₁ s ≡₁ g ↑₁ (f ↑₁ s) .
  Proof.
    unfold compose.
    repeat autounfold with unfolderDb.
    ins; splits; ins; splits; desf; eauto.
  Qed.

  Lemma set_collectE f s : f ↑₁ s ≡₁ set_bunion s (fun x => eq (f x)).
  Proof. u. Qed.

  Lemma set_collect_empty f : f ↑₁ ∅ ≡₁ ∅.
  Proof. u. Qed.

   Lemma set_collect_eq f a : f ↑₁ (eq a) ≡₁ eq (f a).
  Proof. u; splits; ins; desf; eauto. Qed.

  Lemma set_collect_union f s s' :
    f ↑₁ (s ∪₁ s') ≡₁ f ↑₁ s ∪₁ f ↑₁ s'.
  Proof. u. Qed.

  Lemma set_collect_inter f s s' :
    f ↑₁ (s ∩₁ s') ⊆₁ f ↑₁ s ∩₁ f ↑₁ s'.
  Proof. u. Qed.

  Lemma set_collect_bunion f (s : C -> Prop) (ss : C -> A -> Prop) :
    f ↑₁ (⋃₁x ∈ s, ss x) ≡₁ ⋃₁x ∈ s, f ↑₁ (ss x).
  Proof. u. Qed.

  (** Map *)

  Lemma set_map_compose (f : A -> B) (g : B -> C) (d : C -> Prop) :
    (g ∘ f) ↓₁ d ≡₁ f ↓₁ (g ↓₁ d) .
  Proof.
    autounfold with unfolderDb.
    ins; splits; ins; splits; desf; eauto.
  Qed.

  Lemma set_mapE f d : f ↓₁ d ≡₁ set_bunion d (fun x y => x = f y).
  Proof. split; u. desc. by subst y. Qed.

  Lemma set_map_empty f : f ↓₁ ∅ ≡₁ ∅.
  Proof. u. Qed.

  Lemma set_map_full f : f ↓₁ set_full ≡₁ set_full.
  Proof. u. Qed.

  Lemma set_map_union f d d' :
    f ↓₁ (d ∪₁ d') ≡₁ f ↓₁ d ∪₁ f ↓₁ d'.
  Proof. u. Qed.

  Lemma set_map_inter f d d' :
    f ↓₁ (d ∩₁ d') ≡₁ f ↓₁ d ∩₁ f ↓₁ d'.
  Proof. u. Qed.

  Lemma set_map_bunion f (d : C -> Prop) (dd : C -> B -> Prop) :
    f ↓₁ (⋃₁x ∈ d, dd x) ≡₁ ⋃₁x ∈ d, f ↓₁ (dd x).
  Proof. u. Qed.

  (** Collect and Map *)

  Lemma set_collect_map f d :
    f ↑₁ (f ↓₁ d) ⊆₁ d.
  Proof. u. desc. by subst x. Qed.

  Lemma set_map_collect f s :
    s ⊆₁ f ↓₁ (f ↑₁ s).
  Proof. u. Qed.

  (** Finite sets *)

  Lemma set_finite_empty : set_finite (A:=A) ∅.
  Proof. exists nil; ins. Qed.

  Lemma set_finite_eq a : set_finite (eq a).
  Proof. exists (a :: nil); ins; desf; eauto. Qed.

  Lemma set_finite_le n : set_finite (fun t => t <= n).
  Proof. exists (List.seq 0 (S n)); intros; apply in_seq; ins; auto with arith. Qed.

  Lemma set_finite_lt n : set_finite (fun t => t < n).
  Proof. exists (List.seq 0 n); intros; apply in_seq; ins; auto with arith. Qed.

  Lemma set_finite_union s s' : set_finite (s ∪₁ s') <-> set_finite s /\ set_finite s'.
  Proof.
    u; split; splits; ins; desf; eauto.
    eexists (_ ++ _); ins; desf; eauto using in_or_app.
  Qed.

  Lemma set_finite_unionI s (F: set_finite s) s' (F': set_finite s') : set_finite (s ∪₁ s').
  Proof.
    u; desf; eauto; eexists (_ ++ _); ins; desf; eauto using in_or_app.
  Qed.

  Lemma set_finite_bunion s (F: set_finite s) ss :
    set_finite (set_bunion s ss) <-> forall a (COND: s a), set_finite (ss a).
  Proof.
    u; split; ins; desf; eauto.
    revert s F H; induction findom; ins.
      by exists nil; ins; desf; eauto.
    specialize (IHfindom (fun x => s x /\ x <> a)); ins.
    specialize_full IHfindom; ins; desf; eauto.
      by apply F in IN; desf; eauto.
    tertium_non_datur (s a) as [X|X].
      eapply H in X; desf.
      eexists (findom0 ++ findom1); ins; desf.
      tertium_non_datur (y = a); desf; eauto 8 using in_or_app.
    eexists findom0; ins; desf; apply IHfindom; eexists; splits; eauto; congruence.
  Qed.

  (** Set disjointness *)

  Lemma set_disjointE s s' : set_disjoint s s' <-> s ∩₁ s' ≡₁ ∅.
  Proof. u. Qed.

  Lemma set_disjointC s s' : set_disjoint s s' <-> set_disjoint s' s.
  Proof. u. Qed.

  Lemma set_disjoint_empty_l s : set_disjoint ∅ s.
  Proof. u. Qed.

  Lemma set_disjoint_empty_r s : set_disjoint s ∅.
  Proof. u. Qed.

  Lemma set_disjoint_eq_l a s : set_disjoint (eq a) s <-> ~ s a.
  Proof. u; split; ins; desf; eauto. Qed.

  Lemma set_disjoint_eq_r a s : set_disjoint s (eq a) <-> ~ s a.
  Proof. u; split; ins; desf; eauto. Qed.

  Lemma set_disjoint_eq_eq a b : set_disjoint (eq a) (eq b) <-> a <> b.
  Proof. u; split; ins; desf; eauto. Qed.

  Lemma set_disjoint_union_l s s' s'' :
    set_disjoint (s ∪₁ s') s'' <-> set_disjoint s s'' /\ set_disjoint s' s''.
  Proof. u. Qed.

  Lemma set_disjoint_union_r s s' s'' :
    set_disjoint s (s' ∪₁ s'') <-> set_disjoint s s' /\ set_disjoint s s''.
  Proof. u. Qed.

  Lemma set_disjoint_bunion_l s ss sr :
    set_disjoint (set_bunion s ss) sr <-> forall x (IN: s x), set_disjoint (ss x) sr.
  Proof. u. Qed.

  Lemma set_disjoint_bunion_r s ss sr :
    set_disjoint sr (set_bunion s ss) <-> forall x (IN: s x), set_disjoint sr (ss x).
  Proof. u. Qed.

  Lemma set_disjoint_subset_l s s' (SUB: s ⊆₁ s') s'' :
    set_disjoint s' s'' -> set_disjoint s s''.
  Proof. u. Qed.

  Lemma set_disjoint_subset_r s s' (SUB: s ⊆₁ s') s'' :
    set_disjoint s'' s' -> set_disjoint s'' s.
  Proof. u. Qed.

  Lemma set_disjoint_subset s s' (SUB: s ⊆₁ s') sr sr' (SUB': sr ⊆₁ sr') :
    set_disjoint s' sr' -> set_disjoint s sr.
  Proof. u. Qed.

  (** Miscellaneous *)

  Lemma set_le n : (fun i => i <= n) ≡₁ (fun i => i < n) ∪₁ (eq n).
  Proof.
    u; intuition; lia.
  Qed.

  Lemma set_lt n : (fun i => i < n) ≡₁ (fun i => i <= n) \₁ (eq n).
  Proof.
    u; intuition; lia.
  Qed.

End SetProperties.

(** Lemmas about finite subsets of [nat] *)

Lemma set_finite_nat_bounded s (F : set_finite s) :
  (exists bound, forall m (M: s m), m < bound).
Proof.
  red in F; desc.
  exists (S (fold_right Nat.max 0 findom)); ins.
  apply Nat.lt_succ_r.
  apply F, in_split in M; desf.
  clear; induction l1; ins; eauto 2 with arith.
Qed.

Lemma set_finite_coinfinite_nat (s: nat -> Prop) :
  set_finite s -> set_coinfinite s.
Proof.
  assert (LT: forall l x, In x l -> x <= fold_right Init.Nat.add 0 l).
    induction l; ins; desf; try apply IHl in H; lia.
  repeat autounfold with unfolderDb; red; ins; desf.
  tertium_non_datur (s (S (fold_right plus 0 findom + fold_right plus 0 findom0))) as [X|X];
   [apply H in X | apply H0 in X]; apply LT in X; lia.
Qed.

Lemma set_coinfinite_fresh (s: nat -> Prop) (COINF: set_coinfinite s) :
  exists b, ~ s b /\ set_coinfinite (s ∪₁ eq b).
Proof.
  repeat autounfold with unfolderDb in *.
  tertium_non_datur (forall b, s b).
    by destruct COINF; exists nil; ins; desf.
  exists n; splits; red; ins; desf.
  apply COINF; exists (n :: findom); ins; desf; eauto.
  specialize (H0 x); tauto.
Qed.

Lemma set_bunion_lt_S A n (P : nat -> A -> Prop) :
  (⋃₁i < S n, P i) ≡₁ (⋃₁i < n, P i) ∪₁ P n.
Proof.
  unfold set_bunion, set_equiv, set_subset, set_union;
    split; ins; desf; eauto.
  rewrite Nat.lt_succ_r, Nat.le_lteq in *; desf; eauto.
Qed.

(** Add rewriting support. *)

Add Parametric Relation A : (A -> Prop) (set_subset (A:=A))
  reflexivity proved by (set_subset_refl (A:=A))
  transitivity proved by (set_subset_trans (A:=A))
  as set_subset_rel.

Add Parametric Relation A : (A -> Prop) (set_equiv (A:=A))
  reflexivity proved by (set_equiv_refl (A:=A))
  symmetry proved by (set_equiv_symm (A:=A))
  transitivity proved by (set_equiv_trans (A:=A))
  as set_equiv_rel.

Instance set_compl_Proper A : Proper (_ --> _) _ := set_subset_compl (A:=A).
Instance set_union_Proper A : Proper (_ ==> _ ==> _) _ := set_subset_union (A:=A).
Instance set_inter_Proper A : Proper (_ ==> _ ==> _) _ := set_subset_inter (A:=A).
Instance set_minus_Proper A : Proper (_ ++> _ --> _) _ := set_subset_minus (A:=A).
Instance set_bunion_Proper A B : Proper (_ ==> _ ==> _) _ := set_subset_bunion_guard (A:=A) (B:=B).

Instance set_compl_Propere A : Proper (_ ==> _) _ := set_equiv_compl (A:=A).
Instance set_union_Propere A : Proper (_ ==> _ ==> _) _ := set_equiv_union (A:=A).
Instance set_inter_Propere A : Proper (_ ==> _ ==> _) _ := set_equiv_inter (A:=A).
Instance set_minus_Propere A : Proper (_ ==> _ ==> _) _ := set_equiv_minus (A:=A).
Instance set_bunion_Propere A B : Proper (_ ==> _ ==> _) _ := set_equiv_bunion_guard (A:=A) (B:=B).
Instance set_subset_Proper A : Proper (_ ==> _ ==> _) _ := set_equiv_subset (A:=A).

Add Parametric Morphism A : (@set_finite A) with signature
  set_subset --> Basics.impl as set_finite_mori.
Proof. red; autounfold with unfolderDb; ins; desf; eauto. Qed.

Add Parametric Morphism A : (@set_finite A) with signature
  set_equiv ==> iff as set_finite_more.
Proof. red; autounfold with unfolderDb; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A : (@set_coinfinite A) with signature
  set_subset --> Basics.impl as set_coinfinite_mori.
Proof. unfold set_coinfinite; ins; rewrite H; ins. Qed.

Add Parametric Morphism A : (@set_coinfinite A) with signature
  set_equiv ==> iff as set_coinfinite_more.
Proof. unfold set_coinfinite; ins; rewrite H; ins. Qed.

Add Parametric Morphism A B : (@set_collect A B) with signature
  eq ==> set_subset ==> set_subset as set_collect_mori.
Proof. autounfold with unfolderDb; ins; desf; eauto. Qed.

Add Parametric Morphism A B : (@set_collect A B) with signature
  eq ==> set_equiv ==> set_equiv as set_collect_more.
Proof. repeat autounfold with unfolderDb; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A B : (@set_map A B) with signature
  eq ==> set_subset ==> set_subset as set_map_mori.
Proof. repeat autounfold with unfolderDb; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A B : (@set_map A B) with signature
  eq ==> set_equiv ==> set_equiv as set_map_more.
Proof. repeat autounfold with unfolderDb; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A : (@set_disjoint A) with signature
  set_subset --> set_subset --> Basics.impl as set_disjoint_mori.
Proof. red; autounfold with unfolderDb; ins; desf; eauto. Qed.

Add Parametric Morphism A : (@set_disjoint A) with signature
  set_equiv ==> set_equiv ==> iff as set_disjoint_more.
Proof. red; autounfold with unfolderDb; splits; ins; desf; eauto. Qed.

(** Add support for automation. *)

Lemma set_subset_refl2 A (x: A -> Prop) :  x ⊆₁ x.
Proof. reflexivity. Qed.

Lemma set_equiv_refl2 A (x: A -> Prop) :  x ≡₁ x.
Proof. reflexivity. Qed.

Global Hint Immediate set_subset_refl2 : core hahn.
Global Hint Resolve set_equiv_refl2 : core hahn.

Hint Rewrite set_compl_empty set_compl_full set_compl_compl : hahn.
Hint Rewrite set_compl_union set_compl_inter set_compl_minus : hahn.
Hint Rewrite set_union_empty_l set_union_empty_r set_union_full_l set_union_full_r : hahn.
Hint Rewrite set_inter_empty_l set_inter_empty_r set_inter_full_l set_inter_full_r : hahn.
Hint Rewrite set_bunion_empty set_bunion_eq set_bunion_bunion_l : hahn.
Hint Rewrite set_collect_empty set_collect_eq set_collect_bunion : hahn.
Hint Rewrite set_finite_union : hahn.
Hint Rewrite set_disjoint_eq_eq set_disjoint_eq_l set_disjoint_eq_r : hahn.

Hint Rewrite set_inter_union_l set_inter_union_r set_union_eq_empty : hahn_full.
Hint Rewrite set_minus_union_l set_minus_union_r set_union_eq_empty : hahn_full.
Hint Rewrite set_subset_union_l set_subset_inter_r : hahn_full.
Hint Rewrite set_minusK set_interK set_unionK : hahn_full.
Hint Rewrite set_bunion_inter_compat_l set_bunion_inter_compat_r : hahn_full.
Hint Rewrite set_bunion_minus_compat_r : hahn_full.
Hint Rewrite set_bunion_union_l set_bunion_union_r : hahn_full.
Hint Rewrite set_collect_union : hahn_full.
Hint Rewrite set_disjoint_union_l set_disjoint_union_r : hahn_full.
Hint Rewrite set_disjoint_bunion_l set_disjoint_bunion_r : hahn_full.

Global Hint Immediate set_subset_empty_l set_subset_full_r : hahn.
Global Hint Immediate set_finite_empty set_finite_eq set_finite_le set_finite_lt : hahn.
Global Hint Immediate set_disjoint_empty_l set_disjoint_empty_r : hahn.

Global Hint Resolve set_subset_union_r : hahn.
Global Hint Resolve set_finite_unionI set_finite_bunion : hahn.


Require Import Bool.
Require Import Arith.
Require Import Peano.

Inductive tp : Set :=
| Nat
| Bool
| Prod : tp -> tp -> tp.

Inductive exp : tp -> Set :=
| num : nat -> exp Nat
| add : exp Nat -> exp Nat -> exp Nat
| bval : bool -> exp Bool
| and : exp Bool -> exp Bool -> exp Bool
| isz : exp Nat -> exp Bool
| pair : forall t1 t2, exp t1 -> exp t2 -> exp (Prod t1 t2).

Notation " '#' n " := (num n) (at level 45) : exp_scope.
Notation " a1 + a2 " := (add a1 a2) (at level 50, left associativity) : exp_scope.
Notation " b1 & b2 " := (and b1 b2) (at level 40, left associativity) : exp_scope.
Notation " 0 ? a " := (isz a) (at level 37, no associativity) : exp_scope.
Notation "[ x ; .. ; y ]" := (add x .. (add y (num 0)) ..) : exp_scope.

Open Scope exp_scope.

Fixpoint interpret_tp (t:tp) : Set :=
match t with
| Nat => nat
| Bool => bool
| Prod t1 t2 => prod (interpret_tp t1) (interpret_tp t2)
end.

Fixpoint eval {t:tp} (e:exp t) : interpret_tp t :=
match e in exp t return interpret_tp t with
| #n => n
| a1 + a2 => (eval a1 + eval a2)%nat
| bval b => b
| b1 & b2 => (eval b1 && eval b2)%bool
| 0? a => beq_nat (eval a) 0
| pair _ _ e1 e2 => (eval e1, eval e2)
end.

Reserved Notation " t ==> t' " (at level 80).

(* semantyka naturalna wyrazen *)
Inductive evalR : forall {t}, exp t -> interpret_tp t -> Prop :=
| re_num : forall n, #n ==> n
| re_add : forall a1 a2 n1 n2,
           a1 ==> n1 -> a2 ==> n2 ->
           a1 + a2 ==> (n1 + n2)%nat
| re_bval : forall b,
            bval b ==> b
| re_and : forall b1 b2 t1 t2,
           b1 ==> t1 -> b2 ==> t2 ->
           b1 & b2 ==> t1 && t2
| re_isz : forall a n,
           a ==> n -> (0? a) ==> beq_nat n 0
| re_pair : forall t1 t2 (a1: exp t1) (a2: exp t2) n1 n2,
            a1 ==> n1 -> a2 ==> n2 ->
            (pair _ _ a1 a2) ==> (n1, n2)
where " t ==> t' " := (evalR t t').

(* proste makro do wykanczania dowodow indukcyjnych *)
Ltac finish :=
simpl in *; try subst; try constructor; try congruence; auto.

(* ta taktyka sama wyszukuje kandydatow do indukcji *)
Ltac induct_eval tac :=
match goal with
| [ H : eval ?X = _ |- _ ] => induction X; tac
| [ H : evalR _ _ |- _ ] => induction H; tac
| _ => fail
end.

Lemma equiv :
forall t (e:exp t) v, eval e = v <-> evalR e v.
Proof.
(* intros t e v; split; intro H.
induction e; finish.
induction H; finish.*)
split; intros; induct_eval finish.
Qed.

Require Import Coq.Program.Equality.

Lemma evalR_add :
forall (e1 e2: exp Nat) (n1 n2:nat),
  evalR e1 n1 -> evalR e2 n2 -> evalR (e1 + e2) ((n1 + n2)%nat).
(* induction e1. *)
dependent induction e1; intros; constructor; trivial.
Qed.

Hint Resolve evalR_add.

Lemma evalR_nat :
forall n, evalR (#n) n.
constructor.
Qed.

Hint Immediate evalR_nat.

Print HintDb core.

Lemma guess :
exists e1 e2: exp Nat, evalR (e1 + e2) ((2 + 3)%nat).
Proof.
debug eauto.
Qed.

Print guess.

(**)

Check ((2+3)%nat).

Close Scope exp_scope.

Check (2+3).

(* przypisujemy klucz do naszego zakresu *)
Delimit Scope exp_scope with exp.

(* tak uzywamy klucza, zeby skorzystac z notacji, gdy zakres nie jest otwarty *)

Check ([#3; #4])%exp.

(* Bazy twierdzen *)

(* Hint Constructors *)

Inductive even : nat -> Prop :=
| even0 : even 0
| evenSS : forall n, even n -> even (S (S n)).

(* dzieki temu auto bedzie widzialo konstruktory even *)
Hint Constructors even.

Print HintDb core.

Lemma even6 :
even 6.
Proof. auto. Qed.

(* Hint Immediate *)

Hypothesis n_1_m_1 : forall n m, n + 1 = m + 1 -> n = m.

(* podpowiedz dla auto, o niskim koszcie *)
Hint Immediate n_1_m_1 : mydb.

Print HintDb mydb.

Lemma n_1_m_1_ex :
forall n m, S (n + 1) = S (m + 1) -> n = m.
Proof.
intros n m H; injection H; intros.
info_auto with mydb.
(* samo auto nie dziala *)
Qed.

(* Hint Resolve *)

(* podpowiedz dla auto *)
Hint Resolve n_1_m_1_ex : mydb.

Print HintDb mydb.

Lemma n_1_m_1_ex2 :
forall n m, S (n + 1) = S (m + 1) -> n = m.
Proof.
intros.
info_auto with mydb.
Qed.

Check le_S_n.
Hint Resolve le_S_n : mydb.

Lemma le_S_3 :
forall n m, S (S (S n)) <= S (S (S m)) -> n <= m.
Proof.
(*intros; do 3 apply le_S_n; assumption.*)
debug auto with mydb.
Qed.

Print le_S_3.

Hint Resolve le_trans : mydb.

Print HintDb mydb.

Lemma le_trans2 :
forall n m p, n<=m -> m<=p -> n<=p.
Proof.
intros.
debug eauto with mydb.
(* tak tez mozna: apply le_trans with m. *)
(* albo tak :
eapply le_trans.
instantiate (1:=m).
trivial. trivial.
*)
Qed.

Remove Hints le_S_n: mydb.

Print HintDb mydb.

Hint Extern 4 =>
match goal with
| [ |- _ <= _ ] => simple apply le_S_n
| _ => fail
end : mydb.

Print HintDb mydb.

Lemma le_trans3 :
forall n m p, n<=m -> m<=p -> n<=p.
Proof.
intros.
debug eauto with mydb.
(* tak tez mozna: apply le_trans with m. *)
(* albo tak :
eapply le_trans.
instantiate (1:=m).
trivial. trivial.
*)
Qed.

(* Hint Rewrite *)

Variable A : Set.
Variable f : A -> A.
Hypothesis rew_f : forall x, f x = f (f x).

(* podpowiedz dla autorewrite; uwaga na nieskonczone ciagi przepisywan *)

Hint Rewrite <- rew_f : mydb.

Print Rewrite HintDb mydb.

Lemma rew_2f :
forall x, f (f x) = f x.
Proof.
intros.
autorewrite with mydb.
reflexivity.
Qed.

(* Hint Rewrite rew_f : mydb.  spowoduje zapetlenie *)

(* Hint Extern *)

Print HintDb core.

(* podpowiedz dla auto *)
Hint Extern 1 (_ <> _) => discriminate.

Print HintDb core.

Lemma true_false :
true <> false.
Proof.
info_auto.
Qed.

Hint Extern 1 =>
match goal with
| [ H : S ?m = S ?n |- _ ] => injection H; intro; clear H; try subst
end.

Print HintDb core.

Lemma injection_ex :
forall n m, S (S (S n)) = S (S (S m)) -> n = m.
Proof.
info_auto.
Qed.

(* Hint Unfold *)

Definition idnat (n:nat) : Prop := n = n.

(* podpowiedz dla auto, rozwija definicje w glowie celu *)
Hint Unfold idnat : mydb.

Print HintDb mydb.

Lemma idnat_5 :
idnat 5.
Proof.
auto.
info_auto with mydb.
Qed.

(* predefiniowane bazy *)

Lemma le_r :
forall n m p, n <= m -> n + p <= m + p.
Proof.
info_auto with arith.
Qed.

Print HintDb arith.

(* pattern, omega *)

Require Import Omega.

Lemma mult_distr_1 :
forall n m, n * m + m = (n + 1) * m.
Proof.
intros n m.
(* wybierz podterm (n+1): *)
pattern (n + 1).
(* przepisz tylko w wybranym miejscu: *)
rewrite plus_comm.
simpl.
auto with arith.
Qed.

Print mult_distr_1.

Lemma five_n :
forall n, n + n + n + n + n = 5 * n.
Proof.
intro.
(* wybierz 1. wystapienie n: *)
pattern n at 1.
(* przepisz tylko w wybranym miejscu: *)
rewrite <- mult_1_l.
repeat rewrite mult_distr_1.
auto.
Qed.

Print five_n.

Lemma five_n_omega :
forall n, n + n + n + n + n = 5 * n.
Proof.
intro.
omega.
Qed.

Print five_n_omega.

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

Lemma solve_omega :
big_useless_hyp 60 -> 1 <> 0.
Proof.
simpl.
Time omega.
(* Time auto. *)
Qed.

(* programowanie w Ltac *)

Ltac elimcase n :=
generalize (refl_equal n); pattern n at -1; case n; intros.

(* to samo robi istniejaca taktyka: *)
Print Ltac case_eq.
Print Ltac elimcase.
Print Ltac auto.

Lemma cases:
forall (P Q : nat -> Prop) n,
(n = 0 -> P n) -> (n > 0 -> Q n) -> P n \/ Q n.
Proof.
intros.
elimcase n.
left; subst; intuition.
right; subst; intuition.
Qed.

(* taktyka rekurencyjna :
   usun wszystkie przeslanki postaci _ = _ *)
Ltac clear_eq_hyp :=
match goal with
| [ H : _ = _ |- _ ] => clear H ; clear_eq_hyp
| _ => idtac
end.

(* inaczej: *)
Ltac clear_eq_hyp' :=
repeat match goal with
       | [ H : _ = _ |- _ ] => clear H
       | _ => idtac
       end.

Lemma clear_eq_hyp :
forall n, 1 = 1 -> 2 = 2 -> 3 = 3 -> 4 = 4 -> 5 = 5 -> 6 = 6 -> 0 <= n.
Proof.
intros.
clear_eq_hyp'.
auto with arith.
Qed.

(* zamien n + m na SSSS...S n *)

Ltac replace_plus :=
repeat match goal with
| [ |- context C [?X + S ?Y] ] => idtac C; rewrite <- plus_n_Sm
| [ |- context [?X + 0] ] => rewrite plus_0_r
| _ => fail
end.

(* stosuj konstruktory le do skutku *)
Ltac apply_le_c := constructor 1 || (constructor 2; apply_le_c).

Lemma le_n_n5 :
forall n, n <= S (n + 4).
Proof.
intro.
replace_plus.
apply_le_c.
(* info_auto with arith. *)
Qed.

(* sprawdz, czy nie ma juz takiej przeslanki: *)
Ltac not_in_hyps A :=
match goal with
| [ H : A |- _ ] => fail 1
| _ => idtac
end.

(* intros bez powtorzen,
z wylaczeniem sprawdzania powtorzen przy wprowadzaniu formul *)
Ltac new_intros :=
match goal with
| [ |- ?A -> ?B ] => not_in_hyps A; let h:=fresh "H" in intro h; new_intros
| [ |- ?A -> ?B ] => let h:=fresh "H" in intro h; clear h; new_intros
| [ |- forall _ : Prop, _ ] => let x:=fresh "A" in intro x; new_intros
| _ => idtac
end.

Lemma intros_wo_rep :
forall A B:Prop, (forall x:nat,x=0) -> (forall y:nat, y=0) ->
(A -> B) -> (B -> A) -> (A -> B) -> A -> B -> B -> A -> (A -> B) -> B.
Proof.
new_intros.
assumption.
Qed.

(* inversion *)

(* rozwiaz cel przez n-krotna inwersje: *)
Ltac by_inversion n :=
match n with
| O => idtac "nie udalo sie"
| S ?m => match goal with
         | [ H : _ |- _ ] => solve [inversion H; try subst; idtac H; by_inversion m]
         | _ => idtac n
         end
end.

Tactic Notation "contradiction" "by" "inversion" := by_inversion 1.
Tactic Notation "contradiction" "by" "inversion" constr(n) := by_inversion n.

Lemma not_even_1 :
~ even 5.
Proof.
intro.
contradiction by inversion.
contradiction by inversion 3.
Qed.

(* taktyki jako funkcje w Ltac *)

Require Import List.
Import ListNotations.

(* oblicz dlugosc listy *)
Ltac len l :=
match l with
|  _ :: ?ls => let ln := len ls in constr:(S ln)
| [] => O
end.

(* tak nie mozna oczywiscie:
Eval compute in len [2;3].*)

(* ale tak mozna sprawdzic wynik zastosowania taktyki, ktora zwraca wartosc: *)
Goal True.
  let n := len [2;3;4;9] in
    idtac n.
  let l := auto in idtac l.
  let l := constr:(ltac:(constructor):bool) in idtac l.
auto.
Qed.

Definition tail {A} (l:list A) : list A :=
match l with
| [] => ltac:(auto)
| h::t => t
end.

Print tail.

(* len + debugging info *)

Ltac len2 l :=
idtac l;
match l with
|  _ :: ?ls => let ln := len2 ls in constr:(S ln)
| [] => O
end.

Goal True.
  let n := len2 [2;3;4;9] in
    idtac n.
auto.
Qed.

Ltac len3 l k :=
idtac l;
match l with
|  _ :: ?ls => len3 ls ltac:(fun m => k (S m))
| [] => k 0
end.

Goal True.
  len3 [2;3;4;9] ltac:(fun n => pose n).
auto.
Qed.

(* generowanie zmiennych egzystencjalnych *)

(* odraczanie instancjacji kwantyfikatora przez uzycie zmiennej egzystencjalnej *)

Lemma two_gt_one :
(forall x, S x > x) -> 2 > 1.
Proof.
intros.
(* utworzenie nowej zmiennej egzystencjalnej i jej nazwy *)
evar (y : nat).
specialize (H ?y).
(* info_auto. <- tu blad: zostala zmienna niezunifikowana *)
apply H.
Qed.

Print two_gt_one.

(* przyklad z Compcerta *)

Lemma modusponens: forall (P Q: Prop), P -> (P -> Q) -> Q.
Proof. auto. Qed.

Ltac exploit x :=
   refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _) _)
|| refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _) _)
|| refine (modusponens _ _ (x _ _ _ _) _)
|| refine (modusponens _ _ (x _ _ _) _)
|| refine (modusponens _ _ (x _ _) _)
|| refine (modusponens _ _ (x _) _).

Lemma mp_test :
forall A B C D E:Prop, (A -> B -> C -> D) -> E.
intros.
exploit H.


Require Import List.

(* inductive predicate expressing the fact that two lists are obtained from
each other, by the Permute of two consecutive elements  *)
Inductive Transpose {A:Type} : list A -> list A -> Prop :=
  | transp_pair : forall(x y:A), Transpose (x::y::nil) (y::x::nil)
  | transp_gen  : forall (l m l1 l2 : list A),
    Transpose l m -> Transpose (l1++l++l2) (l1++m++l2).

(* one common issue with this sort of definition is that constructors of the
inductive predicates are akin to 'axioms', and it is very easy to define the
wrong thing, or things that are inconsistent, or incomplete etc *)

(* Here is another way to go about it *)
Definition Transpose' {A:Type} (l: list A) (m:list A) : Prop :=
  exists (l1 l2:list A) (x y:A),
  l = l1++(x::y::nil)++l2 /\ m = l1++(y::x::nil)++l2.

(* ideally, you want to check the equivalence between the two notions *)
Lemma Transpose_check: forall (A:Type)(l m:list A),
  Transpose l m <-> Transpose' l m.
Proof.
  intros A l m. split. intro H. generalize H. elim H. intros.
  unfold Transpose'. exists nil, nil, x, y. auto.
  clear H l m. intros l m l1 l2 H0 H1 H2. clear H2.
  cut (Transpose' l m). clear H0 H1. intro H.
  unfold Transpose' in H. elim H. intro l3. clear H. intro H.
  elim H. intro l4. clear H. intro H.
  elim H. intro x. clear H. intro H.
  elim H. intro y. clear H. intro H.
  elim H. clear H. intros H0 H1.
  unfold Transpose'.
  exists (l1++l3), (l4++l2), x, y. rewrite H0, H1. clear H0 H1.
  split. rewrite <- app_assoc with (l:=l1). rewrite <- app_assoc with (l:=l3).
  rewrite <- app_assoc with (n:=l2). reflexivity.
  rewrite <- app_assoc with (l:=l1). rewrite <- app_assoc with (l:=l3).
  rewrite <- app_assoc with (n:=l2). reflexivity.
  apply H1. exact H0.
  intro H. unfold Transpose' in H. elim H. clear H. intros l1 H.
  elim H. clear H. intros l2 H. elim H. clear H. intros x H.
  elim H. clear H. intros y H. elim H. clear H. intros Hl Hm.
  rewrite Hl, Hm. apply transp_gen. apply transp_pair.
Qed.

(* This inductive predicate expresses the fact that two
lists are Permutes of one another *)
Inductive Permute {A:Type} : list A -> list A -> Prop :=
  | perm_self : forall l:list A, Permute l l
  | perm_next : forall l l' m: list A,
    Permute l l' -> Transpose l' m -> Permute l m.

Lemma Permute_refl : forall (A:Type) (l:list A), Permute l l.
Proof.
  intros A l. apply perm_self.
Qed.

Lemma Transpose_sym: forall (A:Type) (l m: list A),
  Transpose l m -> Transpose m l.
Proof.
  intros A l m H. generalize H. elim H. clear l m H.
  intros x y H. clear H. apply transp_pair. clear l m H.
  intros l m l1 l2 H H' H0. clear H0. apply transp_gen.
  apply H'. exact H.
Qed.

Lemma Transpose_first: forall (A:Type) (l l' m:list A),
  Transpose l l' -> Permute l' m -> Permute l m.
Proof.
  intros A l l' m H0 H1. generalize H0. clear H0. generalize H1 l.
  elim H1. clear H1 l l' m. intros m. intro H. clear H. intro l.
  intro H. apply perm_next with (l':=l). apply perm_self. exact H.
  clear H1 l l' m. intros l l' m H0 H1 H3 H4 k H5.
  eapply perm_next. apply H1. exact H0. exact H5. exact H3.
  (* dont understand why normal 'apply ... with' was failing *)
Qed.

Lemma Permute_sym: forall (A:Type) (l m: list A),
  Permute l m -> Permute m l.
Proof.
  intros A l m H. generalize H. elim H. auto. clear H m l.
  intros l l' m H0 H1 H2 H3. apply Transpose_first with (l':=l').
  apply Transpose_sym. exact H2. apply H1. exact H0.
Qed.

Lemma Permute_trans: forall (A:Type) (l m k: list A),
  Permute l m -> Permute m k -> Permute l k.
Proof.
  intros A l m k H. generalize H k. clear k. elim H. auto.
  clear H l m. intros l l' m H0 H1 H2 H3 k H4.
  apply H1. exact H0. apply Transpose_first with (l':=m).
  exact H2. exact H4.
Qed.

Lemma Transpose_imp_eq_length: forall (A:Type)(l m:list A),
  Transpose l m -> length l = length m.
Proof.
  intros A l m H. generalize H. elim H.
  clear H l m. intros. simpl. reflexivity.
  clear H l m. intros l m l1 l2 H0 H1 H2. clear H2.
  rewrite app_length, app_length, app_length, app_length.
  rewrite H1. reflexivity. exact H0.
Qed.

Lemma Permute_imp_eq_length: forall (A:Type)(l m:list A),
  Permute l m -> length l = length m.
Proof.
  intros A l m H. generalize H. elim H.
  clear H l m. intros. reflexivity.
  clear H l m. intros l l' m H0 H1 H2 H3. clear H3.
  apply eq_trans with (y:=length l').
  apply H1. exact H0. apply Transpose_imp_eq_length. exact H2.
Qed.

Definition SubSet {A:Type}(l m:list A) : Prop :=
  forall (x:A), In x l -> In x m.

Definition EqSet {A:Type}(l m: list A) : Prop :=
  SubSet l m /\ SubSet m l.

Lemma SubSet_refl: forall (A:Type)(l:list A), SubSet l l.
Proof.
  intros A l. unfold SubSet. intros x. tauto.
Qed.

Lemma SubSet_trans: forall (A: Type)(l m k: list A),
  SubSet l m -> SubSet m k -> SubSet l k.
Proof.
  intros A l m k H0 H1. unfold SubSet. intros x H2.
  apply H1. apply H0. exact H2.
Qed.

Lemma Transpose_imp_SubSet: forall (A:Type)(l m:list A),
  Transpose l m -> SubSet l m.
Proof.
  intros A l m H. generalize H. elim H.
  clear H l m. intros x y H0. clear H0. unfold SubSet.
  intros z H0. simpl. simpl in H0. elim H0.
  clear H0. intro H0. right. left. exact H0.
  clear H0. intro H0. elim H0. clear H0. intro H0. left. exact H0.
  apply False_ind.
  clear H l m. intros l m l1 l2 H0 H1 H2. clear H2. unfold SubSet.
  intros x H2. simpl. rewrite in_app_iff, in_app_iff.
  rewrite in_app_iff, in_app_iff in H2. elim H2.
  clear H2. intro H2. left. exact H2.
  clear H2. intro H2. elim H2. clear H2. intro H2. right. left.
  apply H1. exact H0. exact H2.
  clear H2. intro H2. right. right. exact H2.
Qed.

Lemma Transpose_imp_EqSet: forall (A:Type)(l m:list A),
  Transpose l m -> EqSet l m.
Proof.
  intros A l m H. unfold EqSet. split.
  apply Transpose_imp_SubSet. exact H.
  apply Transpose_imp_SubSet. apply Transpose_sym. exact H.
Qed.

Lemma Permute_imp_SubSet: forall (A:Type)(l m: list A),
  Permute l m -> SubSet l m.
Proof.
  intros A l m H. generalize H. elim H.
  clear H l m. intros. apply SubSet_refl.
  clear H l m. intros l l' m H0 H1 H2 H3. clear H3.
  apply SubSet_trans with (m:= l'). apply H1. exact H0.
  apply Transpose_imp_SubSet. exact H2.
Qed.

Lemma Permute_imp_EqSet: forall (A:Type)(l m: list A),
  Permute l m -> EqSet l m.
Proof.
  intros A l m H. unfold EqSet. split.
  apply Permute_imp_SubSet. exact H.
  apply Permute_imp_SubSet. apply Permute_sym. exact H.
Qed.

Lemma Transpose_cons: forall (A:Type)(l m:list A)(a: A),
  Transpose l m -> Transpose (a::l) (a::m).
Proof.
 intros A l m a H.
 cut (a::l = (a::nil) ++ l ++ nil).
 cut (a::m = (a::nil) ++ m ++ nil).
 intros Hm Hl. rewrite Hm, Hl. apply transp_gen. exact H.
 rewrite <- app_comm_cons. rewrite app_nil_l. rewrite app_nil_r. reflexivity.
 rewrite <- app_comm_cons. rewrite app_nil_l. rewrite app_nil_r. reflexivity.
Qed.

Lemma Permute_cons: forall (A:Type)(l m: list A)(a: A),
  Permute l m -> Permute (a::l) (a::m).
Proof.
  intros A l m a H. generalize H. generalize a. clear a. elim H.
  clear H l m. intros. apply perm_self.
  clear H l m. intros l l' m H0 H1 H2 a H3.
  apply Permute_trans with (m:=(a::l')). apply H1. exact H0.
  apply (perm_next (a::l') (a::l') (a::m)). apply perm_self.
  apply Transpose_cons. exact H2.
Qed.


(**
Trois objectifs dans ce TD :
- Raisonner avec apply ... pour utiliser
  hypothèses implicatives et/ou quantifiées universellement)
- Utiliser des hypothèses de récurrence implicatives et/ou
   quantifiées universellement
- Utiliser une hypothèse indiquant une égalité entre deux
  constructeurs différents, ce qui est "manifestement impossible"
*)

(* ---------------------------------------------------------------------- *)
(** * Partie 1 : raisonnement, tactiques refine et apply *)

(** ** Rappels sur les tactiques *)
(**

- intro x
  a le même effet que
  refine (fun x => _)

- apply f
  a le même effet que
  refine f, ou
  refine (f _), ou
  refine (f _ _), etc.
  suivant le type de [f].

  Exemple

  f : T1 -> T2
  ============
  T2

  On peut ici utiliser refine (f _), il restera à trouver
  quelque chose de type T1.

  - destruct E as [ (* Cons1 *) x | (* Cons2 *) | (* Cons3 *) y z]
    a le même effet que
    refine (match E with
             | Cons1 x => _
             | Cons2 => _
             | Cons3 y z => _
             end).

    où E a un type inductif de constructeurs Cons1 Cons2 et Cons3
    ayant respectivement 1, 0 et 2 arguments.
 *)

(** ** Rappels sur les structures en arbre *)
(**
    1) on a vu des structures de données destinées à la
    programmation (listes, etc.), et des structures de données
    destinées au raisonnement, appelées arbres de preuve,
    qui se manipulent de la même manière.

    2) On a vu également que les types de structures de données pour
    la programmation ont eux même un type, l'univers Set.
 *)

(** ** L'univers Prop *)
(**
    Les arbres de preuve sont dans un univers parallèle à Set,
    appelé Prop.

    Remarque : en particulier, les égalités sont dans Prop.
*)

(*

Corerction get td3

Fixpoint get (i:int) (s:state) :nat :=
  match s with
  | nil => 0
  | cons (j,v) s' => match i with
                     | 0 => v
                     | S i' => get i' s'
                     end
  end.

  or

  match S, i with
  | nil, _ => 0
  | cons (j,v) s', 0 => v
  | cons (j,v) s', S i' => get i' s'
  end.

  get 0 Nil = 0
  get 0 x::q = x
  get (S i) Nil = 0
  get (S i) x::q = get i q
*)
Check (2 = 2).

Section sec_ABC.
  (** Considérons des propositions arbitraires A B C... *)
  Variable A B C : Prop.
  (** ... et des prédicats arbitraires P Q R sur nat *)
  Variable P Q R : nat -> Prop.

 (** Preuve à faire uniquement avec refine/intro/apply *)
 (** Faire également Show Proof après les invications de
     tactiques pour voir la preuve en train de se former. *)
  Lemma impl_trans:
    (A -> B) -> (B -> C) -> (A -> C).
  Proof.
    intros H1 H2 H3.
    apply H2.
    apply H1.
    apply H3.
  Qed.

  (** Preuve à faire uniquement avec intro/apply *)
  Lemma combi_S:   (A -> B -> C) -> (A -> B) -> A -> C.
  Proof.
    (* À compléter *)
  intros H1 H2 H3.
  apply H1.
  apply H3.
  apply H2.
  apply H3.
  Qed.

  (* Preuve à faire uniquement avec intro/apply *)
  Lemma forall_impl_trans:
    (forall n:nat, P n -> Q n) ->
    (forall n:nat, Q n -> R n) ->
    (forall n:nat, P n -> R n).
  Proof.
    intros H1 H2 n H3.
    apply H2.
    apply H1.
    apply H3.
  Qed.
End sec_ABC.

(* -------------------------------------------------------------------------- *)
(** * Partie 2 : équivalence entre égalité des entiers et eqnatb rendant true *)

(** eqnatb renvoie true ssi ses arguments représentent le même entier naturel *)

Fixpoint eqnatb n1 n2 :=
   match n1,n2 with
  | O,O => true
  | S n1', S n2' => eqnatb n1' n2'
  | _,_ => false
  end.

(** ** 2.1 Le sens le plus facile (récurrence simple) *)

Lemma eqnatb_eq_1 : forall n, eqnatb n n = true.
Proof.
  induction n as [|n' IHn'].
  - reflexivity.
  - cbn[eqnatb]. apply IHn'.
Qed.

Lemma eqnatb_eq : forall n1 n2, n1 = n2 -> eqnatb n1 n2 = true.
Proof.
  intros n1 n2 H.
  induction H.
  - rewrite eqnatb_eq_1. reflexivity.
Qed.

(* Facultatif : preuve directe sans utiliser eqnatb_eq_1 *)
Lemma eqnatb_eq_direct : forall n1 n2, n1 = n2 -> eqnatb n1 n2 = true.
Proof.
  (* À compléter: utiliser clear avant induction. *)
  (* La tactique clear [hy] retire l'hypothèse [hy] du but. *)
  intros n1 n2 H.
  rewrite H.
  clear H.
  induction n2 as [|n2' IHn2'].
  - reflexivity.
  - cbn[eqnatb]. apply IHn2'.
Qed.

(** ** 2.2 Le sens le plus difficile (récurrence quantifiée + preuve par cas) *)

(*** 2.2.1 Lemme préparatoire *)

(** Nouvelle tactique :
la tactique [change _expr_] permet de remplacer la conclusion
par une autre propriété convertible c'est-à-dire equivalente par calcul.

exemple:

===========
2 + 1 = 6
-> change (3 = 3 * 2)

Cela permet de "décalculer" un résultat de fonction.
 *)

Lemma absurd: 5 = 4 -> 15 = 12.
Proof.
  intros e.
  (** faire apparaitre 5 et 4 dans un même contexte
      en utilisant la tactique [change] *)
  (* À compléter *)
  (* change (... 5 ... = ... 4 ...). *)

  (* discriminate e.*)

  change(3 * 5 = 3 * 4).
  rewrite e.
  reflexivity.
Qed.
(* facultatif *)
Lemma true_false_eg : true = false -> forall n1 n2 : nat, n1 = n2.
Proof.
  intro etf. intros n1 n2.
  (** Definir une fonction f tq [f true = n1] et [f false = n2]   *)
  (* À compléter *)
  (* pose (f (b:bool) := ... *)
  pose(f (b:bool) := if b then n1 else n2).
  change(f true = f false).
  rewrite etf.
  reflexivity.

    (*discriminate.*)
Qed.

(*** 2.2.2 Réciproque de 2.1 *)
(** Dans l'exercice ci-dessous, il faut bien identifier la propriété de n1
    sur laquelle porte la récurrence *)
Lemma eq_eqnatb : forall n1 n2, eqnatb n1 n2 = true -> n1 = n2.
Proof.
  intros n1 n2 H.
  cbn[eqnatb] in H.
  induction n1 as [|n1' IHn1'], n2 as [|n2' IHn2'].
  - reflexivity.
  - discriminate.
  - discriminate.
  -
Admitted.

(** ** 2.3 Équivalence, tactique split *)

(** On peut utiliser split pour prouver une équivalence
    par décomposition en deux implications *)

Print iff.

Lemma eq_iff_eqnatb : forall n1 n2, eqnatb n1 n2 = true <-> n1 = n2.
Proof.
  split.
  - intro H.
    induction n1, n2.
    + reflexivity.
    + discriminate.
    + discriminate.
    +

Admitted.


Require Import PeanoNat.

(* Strong induction on Natural numbers with properties sending to Props. *)

Theorem strong_induction:
forall P : nat -> Prop,
(forall n : nat, (forall k : nat, (k < n -> P k)) -> P n) ->
forall n : nat, P n.
Proof.
intros P H. assert (Lem : forall n, (forall m, m <= n -> P m)).
{ induction n. intros.
  - assert (E: m = 0). inversion H0.  reflexivity. rewrite E. apply H.
    intros. exfalso. inversion H1.
  - intros. apply H. intros. apply IHn. inversion H0.
    * rewrite H2 in H1. apply Nat.lt_succ_r. apply H1.
    * assert (E: k <= m). apply Nat.lt_le_incl. apply H1.
      apply Nat.le_trans with (m:=m). apply E. apply H3. }
intro n. apply H. intros. apply Lem with (n:=n) (m:=k).
apply Nat.lt_le_incl. apply H0.
Qed.


Require Import Nat.
Theorem plus_1_neq_0: forall n: nat,
  (n + 1) =? 0 = false.
Proof.
  intros n. destruct n as [| n'] eqn:E.
  - reflexivity.
  - reflexivity.
Qed.

Check negb.

Theorem negb_involutive: forall b: bool,
  negb (negb b) = b.
Proof.
  intros b.
  destruct b.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_commutative'' :
  forall b c, andb b c = andb c b.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_true_elim2: forall b c: bool,
  andb b c = true -> c = true.
Proof.
  intros b c H.
  destruct c.
    - reflexivity.
    - rewrite <- H.
  destruct b.
    * reflexivity.
    * reflexivity.
Qed.

Theorem zero_nbeq_plus_1: forall n: nat,
  0 =? (n + 1) = false.
Proof.
  intros [|n'].
  reflexivity.
  reflexivity.
Qed.

Theorem identity_fn_applied_twice:
  forall (f: bool->bool),
  (forall (x: bool), f x = x) -> forall (b: bool), f (f b) = b.
Proof.
  intros f H [].
  rewrite -> H.
  rewrite -> H.
  reflexivity.
  rewrite -> H.
  rewrite -> H.
  reflexivity.
Qed.

Theorem neg_fn_applied_twice:
  forall (f: bool->bool),
  (forall (x: bool), f x = negb x) -> forall (b: bool), f (f b) = b.
Proof.
  intros f H [].
  rewrite -> H.
  rewrite -> H.
  reflexivity.
  rewrite -> H.
  rewrite -> H.
  reflexivity.
Qed.

Lemma andb_true: forall (b: bool), andb b true = b.
Proof.
  intros [].
  reflexivity.
  reflexivity.
Qed.

Lemma andb_false: forall (b: bool), andb b false = false.
Proof.
  intros [].
  reflexivity.
  reflexivity.
Qed.

Lemma orb_true: forall (b:bool), orb b true = true.
Proof.
  intros [].
  reflexivity.
  reflexivity.
Qed.

Lemma orb_false: forall (b: bool), orb b false = b.
Proof.
  intros [].
  reflexivity.
  reflexivity.
Qed.

Theorem andb_eq_orb:
  forall (b c: bool), (andb b c = orb b c) -> b = c.
Proof.
  intros b c.
  destruct c.
  rewrite -> andb_true.
  rewrite -> orb_true.
  intros H.
  rewrite -> H.
  reflexivity.
  rewrite -> andb_false.
  rewrite -> orb_false.
  intros H1.
  rewrite -> H1.
  reflexivity.
Qed.

Inductive bin: Type :=
  | Z
  | A (n: bin)
  | B (n: bin).

Fixpoint incr (m:bin):bin :=
  match m with
  | Z => B Z
  | A n => B n
  | B n => A (incr n)
  end.

Fixpoint bin_to_nat (m: bin): nat :=
  match m with
  | Z => 0
  | A n => 2 * bin_to_nat n
  | B n => 1 + 2 * bin_to_nat n
  end.

Compute bin_to_nat (incr (A (A (A (A (B Z)))))).

Example test_bin_incr1 : (incr (B Z)) = A (B Z).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr2 : (incr (A (B Z))) = B (B Z).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr3 : (incr (B (B Z))) = A (A (B Z)).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr4 : bin_to_nat (A (B Z)) = 2.
Proof. simpl. reflexivity. Qed.

Example test_bin_incr5 :
        bin_to_nat (incr (B Z)) = 1 + bin_to_nat (B Z).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr6 :
        bin_to_nat (incr (incr (B Z))) = 2 + bin_to_nat (B Z).
Proof. simpl. reflexivity. Qed.


Require Import Utf8.
Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Init.Specif.

(*Require Import Category.*)

(* In order to avoid intersecting classes but still have notations,
  I am splitting the group class *)

(*Class GroupOps (A : Type) := {
  unit : A;
  mult : A -> A -> A;
  inv : A -> A;
}.*)

Generalizable Variables a b c.

Class Group (A : Type) (gunit : A) (ginv : A -> A) (gmult : A -> A -> A) := {
    multAssoc: forall a b c : A, gmult a (gmult b c) = gmult (gmult a b) c;
    unitLeft: forall a : A, gmult gunit a = a;
    unitRight: forall a : A, gmult a gunit = a;
    invLeft: forall a : A, gmult (ginv a) a = gunit;
    invRight: forall a : A, gmult a (ginv a) = gunit;
}.

Definition unitOp {A gunit ginv gmult} {G : Group A gunit ginv gmult} := gunit.
Definition multOp {A gunit ginv gmult} {G : Group A gunit ginv gmult} := gmult.
Definition invOp {A gunit ginv gmult} {G : Group A gunit ginv gmult} := ginv.

Infix "*" := multOp : group_scope.
Notation "! a" := (invOp a) (right associativity, at level 30) : group_scope.
Notation "1" := (unitOp) (at level 10): group_scope.

Local Open Scope group_scope.

Definition isInverse {A} `{Group A} (a b : A) := (a * b = 1 /\ b * a = 1).

Definition isUnit `{Group} u := forall a, (u * a = a /\ a * u = a).

Corollary inverseUnique `{Group}: `(unique (isInverse a) (! a)).
Proof.
  unfold unique. intros a. unfold isInverse. split.
  - split.
    + apply invRight.
    + apply invLeft.
  - intros b I. destruct I as [I1 I2]. replace (! a) with (! a * 1).
    + rewrite <- I1. rewrite multAssoc. rewrite invLeft. apply unitLeft.
    + apply unitRight.
Qed.

Corollary unitUnique `{Group} : unique isUnit 1.
Proof.
  unfold isUnit; split.
  - intro a. split; [apply unitLeft | apply unitRight].
  - intros b U. edestruct U as [U1 U2]. rewrite <- U1. apply unitRight.
Qed.

Corollary inverseMult `{Group} : `(!(a * b) = !b * !a).
Proof.
  intros a b. apply inverseUnique. unfold isInverse. split.
  - replace (a * b * ((! b) * (! a))) with (a * (b * !b) * (!a)).
    + rewrite invRight. rewrite (unitRight a). apply invRight.
    + rewrite multAssoc. rewrite multAssoc. reflexivity.
  - replace (!b * !a * (a * b)) with (!b * (!a * a) * b).
    + rewrite invLeft. rewrite (unitRight (! b)). apply invLeft.
    + repeat (rewrite multAssoc). reflexivity.
Qed.

Corollary inverseInvolutive `{Group} : `(!!a = a).
Proof.
  intros a. apply inverseUnique. split.
  - apply invLeft.
  - apply invRight.
Qed.

Corollary unitInverse {A} `{Group A} : 1 = ! 1.
Proof.
  apply unitUnique. intro a. rewrite <- (inverseInvolutive a). split.
  - rewrite <- inverseMult. rewrite unitRight. reflexivity.
  - rewrite <- inverseMult. rewrite unitLeft. reflexivity.
Qed.

Class GroupMorphism {A B} `{Group A} `{Group B} (f : A -> B) := {
  groupMorphism_unit : f 1 = 1;
  groupMorphism_mult : `(f (a * b) = f a * f b);
  (* this one does follow from the others, but it's more convenient to have it here *)
  groupMorphism_inv : `(f (! a) = ! (f a));
}.

Definition groupIsomorphism {A B} `{Group A} `{Group B} (f : A -> B) :=
  (exists g : B -> A, GroupMorphism g /\ compose f g = id /\ compose g f = id).

Definition groupIsomorphic (A B : Type) `{G1 : Group A} `{G2 : Group B} :=
  exists f : A -> B, groupIsomorphism f.

(** GSets *)

Class GSet A X `{Group A} (gSet_action : A -> X -> X) := {
  gSet_composition : forall a b x, gSet_action a (gSet_action b x) = gSet_action (a * b) x;
  gSet_unit : forall x, gSet_action 1 x = x;
}.

Print GSet.

Arguments GSet (A X) {gunit ginv gmult} (H) (gSet_action).

Print GSet.

Definition gSetOp {A X} `{GSet A X} := gSet_action.

Notation "g '•' x" := (gSetOp g x) (at level 61, left associativity) : group_scope.

Class Equivariant {X Y} (F : X -> Y)
    {A action1 action2} `{G : Group A} (G1 : GSet A X G action1)
  (G2 : GSet A Y G action2) := {
  equivariance : forall (a : A) x, F (a • x) = a • (F x);
}.

Print Equivariant.

(* G-Sets and equivariant functions form a category *)

Instance EquivariantCompose {A X Y Z opX opY opZ} `{HG : Group A}
  {G1 : GSet A X HG opX} {G2 : GSet A Y HG opY} {G3 : GSet A Z HG opZ}
    (f : Y -> Z) (g : X -> Y)
  (E1 : Equivariant f G2 G3) (E2 : Equivariant g G1 G2) : (Equivariant (compose f g) G1 G3).
Proof.
  constructor. intros a x. unfold compose. rewrite (equivariance a x).
  rewrite (equivariance a (g x)). reflexivity.
Defined.

Instance equivariantId `{G : GSet} : Equivariant (fun x => x) G G.
  constructor. intros a x. reflexivity.
Defined.

Instance simpleGSet' A `{HG : Group A} : GSet A A HG (fun a b => a * b).
Proof.
  constructor.
  - apply multAssoc.
  - apply unitLeft.
Defined.

Instance simpleGSet A `{HG : Group A} : GSet A A HG (fun a b => a * b * !a).
Proof.
  constructor.
  - intros a b c. rewrite inverseMult. repeat (rewrite multAssoc). reflexivity.
  - intros a. rewrite <- unitInverse. rewrite (unitRight (1 * a)). apply unitLeft.
Defined.

Instance trivialGroup : Group Coq.Init.Datatypes.unit tt (fun u => tt) (fun u u' => tt).
Proof with auto.
  constructor ; (try intros [])...
Defined.

Print GroupMorphism.

Lemma exercise13 A `{HG : Group A} (f : A -> A) (P : GroupMorphism f)
  (E : Equivariant f (simpleGSet A) (simpleGSet' A)): groupIsomorphic A Coq.Init.Datatypes.unit.
Proof.
  exists (fun _ => tt). exists (fun _ => 1). split; try split.
  - reflexivity.
  - intros. rewrite unitRight. reflexivity.
  - intros. apply unitInverse.
  - extensionality a. destruct a. reflexivity.
  - extensionality a. unfold compose.
    replace 1 with (f a * ! (f a)). 2: { apply invRight. }
    pose proof (@equivariance A A f A _ _ _ _ _ HG (simpleGSet A) (simpleGSet' A) E).
    unfold gSetOp in H.
    rewrite <- groupMorphism_inv.
    assert( forall a : A, f (a) = a * (f a)).
    { intros b. rewrite <- H. rewrite <- multAssoc. rewrite invRight. rewrite unitRight. reflexivity. }
    rewrite H0. rewrite <- multAssoc. rewrite <- groupMorphism_mult. rewrite invRight.
    replace (f gunit) with (f 1) by reflexivity. rewrite groupMorphism_unit.
    rewrite unitRight. reflexivity.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Local Open Scope Z_scope.

Module Z.
  Lemma lnot_equiv n : Z.lnot n = Z.pred (-n).
  Proof. reflexivity. Qed.

  Lemma lnot_sub1 n : Z.lnot (n-1) = -n.
  Proof. rewrite lnot_equiv; lia. Qed.

  Lemma lnot_opp x : Z.lnot (- x) = x-1.
  Proof.
    rewrite <-Z.lnot_involutive, lnot_sub1; reflexivity.
  Qed.
End Z.


(*********************************************************)
(*  Formal  Proof of the Tic-Tac-Toe's Perfect Strategy  *)
(*  Author: Shuangquan Feng                              *)
(*  Date:   Apr 29. 2018                                 *)
(*********************************************************)

(* Tic-Tac-Toe' first player has a perfect strategy to never lose the game *)

Require Import board.

(* Definition of 'safe' board state:
   Either
   1. Player1 wins or ties
   2. There exists a move for player1 where either
      a. player1 wins or ties the game
      b. for any moves player2 can make,
         the resulting state is incomplete(i.e. not lose)
                and still safe for player1.
*)

Inductive safe (b:board) : Prop :=
  | win : (get_state b)=win -> safe b (* p1 wins *)
  | tie : (get_state b)=tie -> safe b (* p1 ties *)
  | safe_step:
    (exists (x:step),
      (* p1 makes one move and wins *)
      ((valid_move b x) /\ ((get_state (move b x))=win))
      \/
      (* p1 makes one move, forall possible moves for p2, p1 is safe *)
      (forall (y:step),
       (valid_round b x y)
            ->(((get_state (move b x))=incomplete)/\safe (move (move b x) y))))
      ->
      safe b.

(* The main theorem we want to prove.
   The initial empty board is safe, i.e. player1 can always win or tie *)
Theorem tic_tac_toe_first_always_safe:
    safe empty_board.

(* define some handy tactics to simplify the proof. *)

(* player1 puts X at cell c can directly win or tie the game *)
Ltac final c := exists (st c X); left; split; simpl; split; constructor.

(* player1 puts X at cell c,
   and enumerate all valid moves of player2 *)
Ltac put c' :=
    exists (st c' X); right; intros y H; split;
    try(reflexivity);unfold valid_round in H;
    induction y as [c s];subst; (* c:a cell, s:X *)
    (* separate out the props in 'valid_round' *)
    destruct H as [H1 [H2 [H3 [H4 H5]]]];
    clear H1;
    apply sym_eq_iff in H2; subst;
    (* enumerate all the moves player2 can choose *)
    induction c; simpl in H3; simpl;
    (* get rid of the contradictions *)
    try (exfalso; unfold not in H3; apply H3; constructor);
    try (inversion H4);
    try (inversion H5);
    apply safe_step; clear H3 H4 H5.

Proof.
  apply safe_step.

  (* player1 always first put X at top left corner *)
  put c00.
  - put c11; try(final c22).
    + put c20; try(final c02).
      * final c10.
  - put c11; try(final c22).
    + put c12; try(final c10).
      * put c21. put c20. put c01.
  - put c11; try(final c22).
    + put c20; try(final c02).
      * put c12. put c21. put c11.
  - put c02; try(final c01).
    + put c21.
      * put c12. put c22. put c20.
      * put c10. put c22. put c20.
      * put c12. put c22. put c10.
      * put c10. put c20. put c21.
  - put c11; try(final c22).
    + put c02; try(final c20).
      * final c01.
  - put c01; try(final c02).
    + put c11; try(final c21).
      * final c22.
  - put c11; try(final c22).
    + put c20; try(final c10).
      * final c02.
  - put c02; try(final c01).
    + put c20; try(final c11).
      * final c10.
Qed.


Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c. induction b.
  - (* base *)simpl. intros c_true. exact c_true.
  - (* ih *) induction c.
    + (* base *) simpl. intros f_t. reflexivity.
    + (* ih *) simpl. intros f_t. exact f_t.
Qed.

Fixpoint beq_nat (n m : nat) : bool :=
  match n with
  | 0 => match m with
         | 0 => true
         | S m' => false
         end
  | S n' => match m with
            | 0 => false
            | S m' => beq_nat n' m'
            end
  end.

Theorem zero_nbeq_plus_1 : forall n : nat,
  beq_nat 0 (n + 1) = false.
Proof.
  intros n.
  induction n.
  - (* base *) simpl. reflexivity.
  - (* ih *) simpl. reflexivity.
Qed.

Compute pred 1.
Compute pred 0.

(*
Fixpoint fact (n : nat) : nat :=
  match n with
  | 0 => 1
  | m => fact (pred n)
  end.

vs
*)
Fixpoint fact (n : nat) : nat :=
  match n with
  | 0 => 1
  | S m => fact m
  end.


(**
A Gentle Introduction to Type Classes and Relations in Coq
の
Chapter 2 An Introductory Example: Computing xn
の抜萃。
@suharahiromichi
*)

(**
配布ファイル typeclassesTut を make したのち、
そのディレクトリの本ファイルを置いて実行する。
なお、typeclassesTut を make には、
cp V8.3/Matrics.v Mat.v して、Section名をMatに修正する。
Makefileの _CoqProject のエントリを消す。
*)

(*
A variation of Monoid.v, using Program Fixpoint instead of Function *)

(**
これは、typeclassesTut/Monoid_prog.v をもとにしている。
Program Fixpoint を使い、Contextコマンドを使っている。*)

Set Implicit Arguments.

Require Import ZArith.
Require Import Div2.
Require Import Program.
(* typeclassesTut/V8.3/Matrics.v をrenameする。Section名も。 *)
Require Import Mat.

(** Monoid モノイド
- carrier (台) A
- binary, associative operation 'dot' on A
- neutral element 1 ∈ A for 'dot'
 *)
Class Monoid {A : Type} (dot : A -> A -> A) (one : A) : Type :=
  {
    dot_assoc : forall x y z: A, dot x (dot y z) = dot (dot x y) z;
    one_left  : forall x, dot one x = x;
    one_right : forall x, dot x one = x
  }.
Print Monoid.                        (* 値コンストラクタの指定を省くと、Build_Monoid になる。 *)
About one_left.                      (* Arguments A, dot, one, Monoid are implicit *)
(* Class ではなく、Record の場合は、dot one は implicit ではない。 *)
About one_right.

Require Import ZArith.
Open Scope Z_scope.

(**
ZMultは、モノイド (Z,*,1) である。
- 台は、Z (Implicit)
- 二項演算は、Zmult
- 単位元は、1
*)
(* Compute binary_power 2 100. で使われる。 *)
Instance ZMult : Monoid Zmult 1.
Proof.
  split; intros; ring.
Qed.
(* Note that we used Qed because we consider a class of sort Prop. In some cases where
instances must store some informative constants, ending an instance construction with
Defined may be necessary.  *)
Check ZMult : Monoid Z.mul 1.

(* おまけ。 *)
Instance Mult : Monoid mult 1%nat.
Proof.
  split; intros.
  now rewrite mult_assoc.
  now rewrite mult_1_l.
  now rewrite mult_1_r.
Qed.
Check Mult : Monoid mult 1%nat.
(* これがあると、Check power.  が nat -> nat -> nat になる。
でも、Z -> nat -> Z としても使える。 *)

Fixpoint power {A : Type} {dot : A -> A -> A} {one : A} {M : Monoid dot one}
         (a : A)(n : nat) :=
  match n with
    | 0%nat => one
    | S p => dot a (power a p)
  end.
Check power.                                (* 無意味 *)
About power.
Check power : Z -> nat -> Z.
Compute power 2%Z 10 : Z.
Check power : nat -> nat -> nat.
Compute power 2%nat 10 : nat.
Reset power.

Generalizable Variables A dot one.
(**
Coq Reference Manual から
2.7.20 Implicit generalization

Implicit generalization is an automatic elaboration of a statement with free variables
into a closed statement where these variables are quantified explicitly. Implicit
generalization is done inside binders starting with a ` and terms delimited by `{} and
`(), always introducing maximally inserted implicit arguments for the generalized
variables. Inside implicit generalization delimiters, free variables in the current
context are automatically quantified using a product or a lambda abstraction to generate a
closed term. In the following statement for example, the variables n and m are
autamatically generalized and become explicit arguments of the lemma as we are using `():
*)
(* `{} は、引数を{}で囲むのときと同様に implicit argument になる。 *)

Fixpoint power `{Monoid A dot one} (a : A) (n : nat) := (* 「`」 でコンテキスト *)
  match n with
    | 0%nat => one
    | S p => dot a (power a p)
  end.
Check power.                                (* 無意味 *)
Check power : nat -> nat -> nat.
Check power : Z -> nat -> Z.
About power.

Section binary_power.
  Context `{M : Monoid A dot one}.          (* コンテキスト *)
(**
Coq Reference Manual から
19.4  Sections and contexts

To ease the parametrization of developments by type classes, we provide a new way to
introduce variables into section contexts, compatible with the implicit argument
mechanism. The new command works similarly to the Variables vernacular (see 1.3.1), except
it accepts any binding context as argument.
*)
  Program Fixpoint binary_power_mult (acc : A) (x : A) (n : nat) {measure n} : A :=
    (* Implicit generalization によって、
       (A:Type) (dot:A->A->A) (one:A) (M: @Monoid A dot one)
       が省かれている。 *)
    (* acc * (x ** n) *)
    let M' := M in
    match n with
      | 0%nat => acc
      | _ => if  Even.even_odd_dec n
             then
               binary_power_mult  acc (dot x x) (div2 n)
             else
               binary_power_mult  (dot acc  x) (dot  x  x) (div2 n)
    end.
  Obligations.
  Next Obligation.                          (* Obligation 1 *)
    set (M' := M); apply lt_div2.
    apply neq_0_lt in H.
    apply H.
    Defined.
  Next Obligation.                          (* Obligation 2 と 3 *)
    set (M' := M); apply lt_div2; auto with arith.
    Defined.
  Check binary_power_mult.                  (* A -> A -> nat -> A *)
(*
  証明を1行にまとめると、以下になる。Next Obligation も要らないので、注意。
  Solve Obligations using program_simpl; set (M' := M); apply lt_div2; auto with arith.
 *)

  Import WfExtensionality.
  Lemma binary_power_mult_equation (acc x:A)(n:nat) :
    binary_power_mult acc x n =
    match n with
      | 0%nat => acc
      | _ => if Even.even_odd_dec n
             then
               binary_power_mult acc (dot x x) (div2 n)
             else
               binary_power_mult (dot acc  x) (dot  x  x) (div2 n)
    end.
  Proof.
    unfold binary_power_mult at 1.
    on_call binary_power_mult_func
            ltac:(fun c =>
                    unfold_sub @binary_power_mult_func c;
                    fold binary_power_mult_func).
    simpl. destruct n; reflexivity.
  Qed.
Check binary_power_mult : A -> A -> nat -> A.
End binary_power.
Check binary_power_mult.                    (* 無意味 *)
About binary_power_mult.
Check binary_power_mult : Z -> Z -> nat -> Z.
Check binary_power_mult : nat -> nat -> nat -> nat.

Definition binary_power `{Monoid A dot one} x n :=
  binary_power_mult one x n.

(************************************)
(* First example : モノイド (Z,*,1) *)
(************************************)
(* ZMult をここで使う。 *)
Compute binary_power 2 100.
(* = 1267650600228229401496703205376 : Z *)

Goal forall n : Z, 1 * (n * 1) = n.
Proof.
  intro n.
  rewrite one_left.
  rewrite one_right.
  trivial.
Save XX.                                    (* Lemma XXX : ... Qed. とおなじ。 *)

(***********************************)
(* Second example : 2 x 2 Matrices *)
(***********************************)
(* M2 と M2_mult と Id2 と M2_eq_intros は、Mat.v で定義 *)
Section M2_def.
  Variables (A : Type)
            (zero one : A)
            (plus : A -> A -> A)            (* (plus mult minus : A->A->A) *)
            (mult : A -> A -> A)
            (minus : A -> A -> A)
            (sym : A -> A).
  Notation "0" := zero.
  Notation "1" := one.
  Notation "x + y" := (plus x y).
  Notation "x * y" := (mult x y).
  Variable rth : ring_theory zero one plus mult minus sym (@eq A).
  (* セクションの外で、M2_Monoid を使うためには、rth に値を与えないといけない。 *)

  Print ring_theory.
  (* ring タクティクで、ここで見えるring_theory のセレクタが使えるようになる。 *)
  Add Ring Aring : rth.                     (* for ring. *)

(**
M2_Monoidは、以下のモノイドである。
- 台は M2 Z、Z の 2×2の行列
- 二項演算は、
c00 := plus (mult (c00 m) (c00 m')) (mult (c01 m) (c10 m'));
c01 := plus (mult (c00 m) (c01 m')) (mult (c01 m) (c11 m'));
c10 := plus (mult (c10 m) (c00 m')) (mult (c11 m) (c10 m'));
c11 := plus (mult (c10 m) (c01 m')) (mult (c11 m) (c11 m'))
- 単位元は、
c00 := one; c01 := zero; c10 := zero; c11 := one
*)

  Check @M2_mult A : (A -> A -> A) -> (A -> A -> A) -> M2 A -> M2 A -> M2 A.
  (* (plus : A -> A -> A) (mult : A -> A -> A) *)
  Check M2_mult plus mult : M2 A -> M2 A -> M2 A. (* dot *)

  Check @Id2 A : A -> A -> M2 A. (* (zero : A) (one : A) *)
  Check Id2 0 1 : M2 A.                            (* one *)

  Global Instance M2_Monoid : Monoid (M2_mult plus mult) (Id2 0 1).
  Proof.
    split.
    destruct x; destruct y; destruct z; simpl.
    unfold M2_mult; apply M2_eq_intros; simpl; ring. (* rth *)
    destruct x; simpl;
    unfold M2_mult; apply M2_eq_intros; simpl; ring. (* rth *)
    destruct x; simpl;
    unfold M2_mult; apply M2_eq_intros; simpl; ring. (* rth *)
  Qed.
  (* セクションの外で、M2_Monoid を使うためには、rth に値を与えないといけない。 *)
  About M2_Monoid.                                  (* Monoid ...  *)
End M2_def.

Check M2_mult Z.add Z.mul : M2 Z -> M2 Z -> M2 Z. (* dot *)
Check Id2 0 1 : M2 Z.                             (* one *)
(* セクションの外で、M2_Monoid を使うためには、rth に値を与えないといけない。 *)
About M2_Monoid.                                  (* ring_theory ... -> Monoid ...  *)

(* Zth を rth に与える。Zth は M2_defセクションの rth : ring ... に与えられる。 *)
Check Zth : ring_theory 0 1 Z.add Z.mul Z.sub Z.opp eq.
Print Zth.
Check M2_Monoid Zth : Monoid _ _.
Check M2_Monoid Zth : Monoid (M2_mult Z.add Z.mul) (Id2 0 1).
Check @M2_Monoid Z 0%Z 1%Z Zplus Zmult Zminus Z.opp Zth :
  Monoid (M2_mult Z.add Z.mul) (Id2 0 1).
(* これは、M2Z と等しい *)

Instance M2Z' : Monoid (M2_mult Z.add Z.mul) (Id2 0 1) := M2_Monoid Zth.
(* テキストの方法に記載されたのは、 *)
Instance M2Z : Monoid _ _ := M2_Monoid Zth.

(* Zthを使わずに、自力で証明する場合 *)
(*
Instance M2Z'' : Monoid (M2_mult Z.add Z.mul) (Id2 0 1) : Prop.
Proof.
  split.
  - intros x y z.                           (* M2_mult の結合則 *)
    apply M2_eq_intros; simpl; ring.

  - intros x.                               (* M2_mult の左単位元 *)
    Check M2_eq_intros.
    apply M2_eq_intros; unfold M2_mult; simpl.
    case (c00 x); [ring | reflexivity | reflexivity].
    case (c01 x); [ring | reflexivity | reflexivity].
    case (c10 x); [ring | reflexivity | reflexivity].
    case (c11 x); [ring | reflexivity | reflexivity].

  - intros x.                               (* M2_mult の右単位元 *)
    apply M2_eq_intros; unfold M2_mult; simpl; ring.
Qed.
*)
Check M2Z : Monoid (M2_mult Z.add Z.mul) (Id2 0 1).
Check ZMult : Monoid Z.mul 1.                (* 比較 *)

Compute power (Build_M2 1 1 1 0) 40.         (* M2Z をつかう。 *)
(*
行列の掛け算を40回繰り返す。
[1 1]  [1 1]  [1 1] ..... [1 1]
[1 0]  [1 0]  [1 0]       [1 0]
c00 := 165580141;
c01 := 102334155;
c10 := 102334155;
c11 := 63245986
*)

Definition fibonacci (n:nat) :=
  c00 (power (Build_M2  1 1 1 0) n).
Compute fibonacci 20.
Compute (c00 (power (Build_M2  1 1 1 0) 20)).

(** 一般的事項を証明する。 *)
(* Generic study of power functions *)
(** 最終的に、power と binary_power が等価なことを証明する。 *)
Section About_power.

  Require Import Arith.
  Context `(M : Monoid A dot one ).

  Ltac monoid_rw :=
    rewrite (@one_left A dot one M) ||
            rewrite (@one_right A dot one M)||
            rewrite (@dot_assoc A dot one M).

  Ltac monoid_simpl := repeat monoid_rw.

  Local Infix "*" := dot.
  Local Infix "**" := power (at level 30, no associativity).
  (* "+" はnat のplusである。power : A -> nat -> A だから。 *)

  Lemma power_x_plus :
    forall x n p, x ** (n + p) =  x ** n *  x ** p.
  Proof.
    induction n as [| p IHp]; simpl.
    intros; monoid_simpl; trivial.
    intro q; rewrite (IHp q); monoid_simpl; trivial.
  Qed.

  Ltac power_simpl := repeat (monoid_rw || rewrite <- power_x_plus).

  Lemma power_commute :
    forall x n p, x ** n * x ** p = x ** p * x ** n.
  Proof.
    intros x n p; power_simpl; rewrite (plus_comm n p); trivial.
  (* plus_comm は、nat のそれ。 *)
  Qed.

  Lemma power_commute_with_x :
    forall x n, x * x ** n = x ** n * x.
  Proof.
    induction n; simpl; power_simpl; trivial.
    repeat rewrite <- (@dot_assoc A dot one M); rewrite IHn; trivial.
  Qed.

  Lemma power_of_power :
    forall x n p,  (x ** n) ** p = x ** (p * n).
  Proof.
    induction p; simpl; [| rewrite power_x_plus; rewrite IHp]; trivial.
  Qed.

  Lemma power_S :
    forall x n, x *  x ** n = x ** S n.
  Proof.
    intros; simpl; auto.
  Qed.

  Lemma sqr : forall x, x ** 2 =  x * x.
  Proof.
    simpl; intros; monoid_simpl; trivial.
  Qed.

  Ltac factorize := repeat (
                        rewrite <- power_commute_with_x ||
                                rewrite <- power_x_plus ||
                                rewrite <- sqr ||
                                rewrite power_S ||
                                rewrite power_of_power).

  Lemma power_of_square :
    forall x n, (x * x) ** n = x ** n * x ** n.
  Proof.
    induction n; simpl; monoid_simpl; trivial.
    repeat rewrite dot_assoc; rewrite IHn; repeat rewrite dot_assoc.
    factorize; simpl; trivial.
  Qed.

  Lemma binary_power_mult_ok :
    forall n a x,  binary_power_mult a x n = a * x ** n.
  Proof.
    intro n; pattern n;apply lt_wf_ind.
    clear n; intros n Hn; destruct n.
    intros; simpl; monoid_simpl; trivial.
    intros; rewrite binary_power_mult_equation.
    destruct (Even.even_odd_dec (S n)).
    rewrite Hn.
    rewrite power_of_square; factorize.
    pattern (S n) at 3; replace (S n) with (div2 (S n) + div2 (S n))%nat; auto.
    generalize (even_double _ e); simpl; auto.
    apply lt_div2; auto with arith.
    rewrite Hn.
    rewrite power_of_square; factorize.
    pattern (S n) at 3; replace (S n) with (S (div2 (S n) + div2 (S n)))%nat; auto.
    rewrite <- dot_assoc; factorize;auto.
    generalize (odd_double _ o); intro H; auto.
    apply lt_div2; auto with arith.
  Qed.

  Lemma binary_power_ok :
    forall (x:A) (n:nat), binary_power x n = x ** n.
  Proof.
    intros n x; unfold binary_power; rewrite binary_power_mult_ok;
    monoid_simpl; auto.
  Qed.
  About binary_power_ok.
End About_power.
About binary_power_ok.

Implicit Arguments binary_power_ok [A dot one M].
About binary_power_ok.

Check binary_power_ok 2 20.

Let Mfib := Build_M2 1 1 1 0.

Check binary_power_ok Mfib 56 : binary_power Mfib 56 = power Mfib 56.
Check binary_power_ok (Build_M2 1 1 1 0) 40 :
  binary_power {| c00 := 1; c01 := 1; c10 := 1; c11 := 0 |} 40 =
  power {| c00 := 1; c01 := 1; c10 := 1; c11 := 0 |} 40.

Eval vm_compute in power 2 5.               (* 35 *)

(** 可換モノイド、アーベルモノイド *)
(** モノイド M に可換則を追加して得られる。 *)
Class Abelian_Monoid `(M : Monoid ):=
  {
    dot_comm : forall x y, dot x y = dot y x
  }.
Print Abelian_Monoid.

(**
ZMult_Abelian は、
ZMultモノイド（整数積のモノイド）に可換則を追加したもの。
 *)
Instance ZMult_Abelian : Abelian_Monoid ZMult.
Proof.
  split.
  exact Zmult_comm.
Qed.

(**
おまけとして (x * y)^n = x^n * y^n を証明する。
*)
Section Power_of_dot.
  Context `{M : Monoid A} {AM : Abelian_Monoid M}.

  Theorem power_of_mult :
    forall n x y, power (dot x y)  n =  dot (power x n) (power y n).
  Proof.
    induction n; simpl.
    rewrite one_left; auto.
    intros; rewrite IHn; repeat rewrite dot_assoc.
    rewrite <- (dot_assoc x y (power x n)); rewrite (dot_comm y (power x n)).
    repeat rewrite dot_assoc; trivial.
  Qed.
End Power_of_dot.

Check power_of_mult 3 4 5.
(* : power (4 * 5) 3 = power 4 3 * power 5 3 *)

Check power (Build_M2  1 1 1 0) 3.
Compute power (Build_M2 1 1 1 0) 3.
Check power_of_mult 3 (Build_M2  1 1 1 0) (Build_M2  1 1 1 0).
(* dot が ?204 のままなのは、なぜだろう。 *)

(* END *)

(* 補足 *)
(* power が polymorphic type な関数のとき、Check の結果は一定ではない。 *)
Check power.                                (* この結果に惑わされてはいけない。 *)
About power.                                (* こちらのほうを見る習慣をつけよう。 *)

(* ZMult モノイド *)
About ZMult.
Check power : Z -> nat -> Z.
Compute power 2%Z 10 : Z.
Check @power Z Zmult 1%Z ZMult : Z -> nat -> Z.
Compute @power Z Zmult 1%Z ZMult 2%Z 10 : Z.

(* Mult モノイド *)
About Mult.
Check power : nat -> nat -> nat.
Compute power 2%nat 10 : nat.
Check @power nat mult 1%nat Mult : nat -> nat -> nat.
Compute @power nat mult 1%nat Mult 2%nat 10 : nat.

(* M2Z モノイド *)
About M2Z.
Check power : M2 Z -> nat -> M2 Z.
Compute power (Build_M2 1 1 1 0) 40 : M2 Z.
Check @power (M2 Z) (@M2_mult Z Zplus Zmult) (@Id2 Z 0 1) M2Z :
  M2 Z -> nat -> M2 Z.
Compute @power (M2 Z) (@M2_mult Z Zplus Zmult) (@Id2 Z 0%Z 1%Z) M2Z
        (@Build_M2 Z 1%Z 1%Z 1%Z 0%Z) 40%nat : M2 Z.
Compute @power (M2 Z) (M2_mult Zplus Zmult) (Id2 0 1) M2Z
        (Build_M2 1 1 1 0) 40 : M2 Z.

(* END *)


(* week-13_fac.v *)
(* YSC3236 2017-2018, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of Fri 10 Nov 2017 *)

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

(* Paraphernalia: *)

Ltac unfold_tactic name := intros; unfold name; (* fold name; *) reflexivity.

Require Import Arith Bool.

Notation "A =n= B" :=
  (beq_nat A B) (at level 70, right associativity).

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

Definition specification_of_factorial (fac : nat -> nat) :=
  fac 0 = 1
  /\
  forall n' : nat,
    fac (S n') = (S n') * (fac n').

Theorem there_is_only_one_factorial :
  forall fac1 fac2 : nat -> nat,
    specification_of_factorial fac1 ->
    specification_of_factorial fac2 ->
    forall n : nat,
      fac1 n = fac2 n.
Proof.
  intros fac1 fac2.
  unfold specification_of_factorial.
  intros [S_fac1_0 S_fac1_S] [S_fac2_0 S_fac2_S] n.
  induction n as [ | n' IHn'].

  rewrite -> S_fac1_0.
  rewrite -> S_fac2_0.
  reflexivity.

  rewrite -> S_fac1_S.
  rewrite -> S_fac2_S.
  rewrite -> IHn'.
  reflexivity.
Qed.

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

Definition test_fac (candidate: nat -> nat) : bool :=
  (candidate 0 =n= 1)
  &&
  (candidate 1 =n= 1)
  &&
  (candidate 2 =n= 2)
  &&
  (candidate 3 =n= 6) &&
  (candidate 4 =n= 24)
  &&
  (candidate 5 =n= 120)
  .

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

(* The factorial function in direct style: *)

Fixpoint fac_ds (n : nat) : nat :=
  match n with
    | O => 1
    | S n' => (S n') * (fac_ds n')
  end.

Compute (test_fac fac_ds).

(* Associated unfold lemmas: *)

Lemma unfold_fac_ds_0 :
  fac_ds 0 = 1.
Proof.
  unfold_tactic fac_ds.
Qed.

Lemma unfold_fac_ds_S :
  forall n' : nat,
    fac_ds (S n') = S n' * fac_ds n'.
Proof.
  unfold_tactic fac_ds.
Qed.

(* Main definition: *)

Definition fac_v1 (n : nat) : nat :=
  fac_ds n.

Compute (test_fac fac_v1).

(* Associated unfold lemma: *)

Lemma unfold_fac_v1 :
  forall n : nat,
    fac_v1 n = fac_ds n.
Proof.
  unfold_tactic fac_v1.
Qed.

(* The main definition satisfies the specification: *)

Theorem fac_v1_satisfies_the_specification_of_factorial :
  specification_of_factorial fac_v1.
Proof.
  unfold specification_of_factorial.
  split.

  rewrite -> unfold_fac_v1.
  rewrite -> unfold_fac_ds_0.
  reflexivity.

  intro n'.
  rewrite -> (unfold_fac_v1 (S n')).
  rewrite -> (unfold_fac_v1  n').
  rewrite -> unfold_fac_ds_S.
  reflexivity.
Qed.
(* ********** *)

(* The factorial function in continuation-passing style: *)

Fixpoint fac_cps (ans : Type) (n : nat) (k : nat -> ans) : ans :=
  match n with
    | O => k 1
    | S n' => fac_cps ans n' (fun v => k (S n' * v))
  end.

(* Associated unfold lemmas: *)

Lemma unfold_fac_cps_0 :
  forall (ans : Type) (k : nat -> ans),
    fac_cps ans 0 k = k 1.
Proof.
  unfold_tactic fac_cps.
Qed.

Lemma unfold_fac_cps_S :
  forall (ans : Type) (n' : nat) (k : nat -> ans),
    fac_cps ans (S n') k = fac_cps ans n' (fun v => k (S n' * v)).
Proof.
  unfold_tactic fac_cps.
Qed.

(* Lemma about resetting the continuation: *)

Lemma about_fac_cps :
  forall (n : nat) (ans : Type) (k : nat -> ans),
    fac_cps ans n k = k (fac_cps nat n (fun v => v)).
Proof.
  intro n.
  induction n as [ | n' IHn'].
  intros ans k.
  rewrite ->2 unfold_fac_cps_0.
  reflexivity.

  intros ans k.
  rewrite ->2 unfold_fac_cps_S.
  rewrite -> IHn'.
  rewrite -> (IHn' nat (fun v : nat => S n' * v)).
  reflexivity.
Qed.

(* Main definition: *)

Definition fac_v2 (n : nat) : nat :=
  fac_cps nat n (fun v => v).

Compute (test_fac fac_v2).

(* Associated unfold lemma: *)

Lemma unfold_fac_v2 :
  forall n : nat,
    fac_v2 n = fac_cps nat n (fun v => v).
Proof.
  unfold_tactic fac_v2.
Qed.

(* The main definition satisfies the specification: *)

Theorem fac_v2_fits_the_specification_of_factorial :
  specification_of_factorial fac_v2.
Proof.
  unfold specification_of_factorial.
  split.
  rewrite -> unfold_fac_v2.
  rewrite -> unfold_fac_cps_0.
  reflexivity.

  intro n'.
  rewrite ->2 unfold_fac_v2.
  rewrite -> unfold_fac_cps_S.
  rewrite -> about_fac_cps.
reflexivity.
Qed.
(* ********** *)

(* end of week-13_fac.v *)


(* ***************************************************************** *)
(*                                                                   *)
(* Released: 2021/03/29.                                             *)
(* Due: 2021/04/02, 23:59:59, CST.                                   *)
(*                                                                   *)
(* 0. Read instructions carefully before start writing your answer.  *)
(*                                                                   *)
(* 1. You should not add any hypotheses in this assignment.          *)
(*    Necessary ones have been provided for you.                     *)
(*                                                                   *)
(* 2. In order to check whether you have finished all tasks or not,  *)
(*    just see whether all "Admitted" has been replaced.             *)
(*                                                                   *)
(* 3. You should submit this file (Assignment4.v) on CANVAS.         *)
(*                                                                   *)
(* 4. Only valid Coq files are accepted. In other words, please      *)
(*    make sure that your file does not generate a Coq error. A      *)
(*    way to check that is: click "compile buffer" for this file     *)
(*    and see whether an "Assignment4.vo" file is generated.         *)
(*                                                                   *)
(* 5. Do not copy and paste others' answer.                          *)
(*                                                                   *)
(* 6. Using any theorems and/or tactics provided by Coq's standard   *)
(*    library is allowed in this assignment, if not specified.       *)
(*                                                                   *)
(* 7. When you finish, answer the following question:                *)
(*                                                                   *)
(*      Who did you discuss with when finishing this                 *)
(*      assignment? Your answer to this question will                *)
(*      NOT affect your grade.                                       *)
(*      (* FILL IN YOUR ANSWER HERE AS COMMENT *)                    *)
(*                                                                   *)
(* ***************************************************************** *)

Require Import Coq.Lists.List. Import ListNotations.
Require Import PL.Imp PL.RTClosure.
Import Abstract_Pretty_Printing.

(* ################################################################# *)
(** * Task 1: Understanding Inductive Definition *)

Module Task1.

(** Consider potential integer expression transformations defined by the
    following relation [optimize]. *)

Inductive optimize: aexp -> aexp -> Prop :=
| optimize_plus_0_l: forall a, optimize (APlus 0 a) a
| optimize_plus_0_r: forall a, optimize (APlus a 0) a
| optimize_minus_0_r: forall a, optimize (AMinus a 0) a
| optimize_mult_1_l: forall a, optimize (AMult 1 a) a
| optimize_mult_1_r: forall a, optimize (AMult a 1) a
| optimize_mult_0_l: forall a, optimize (AMult 0 a) 0
| optimize_mult_0_r: forall a, optimize (AMult a 0) 0
| optimize_congr_APlus: forall a1 a2 a3 a4,
    optimize a1 a2 ->
    optimize a3 a4 ->
    optimize (a1 + a3) (a2 + a4)
| optimize_congr_AMinus: forall a1 a2 a3 a4,
    optimize a1 a2 ->
    optimize a3 a4 ->
    optimize (a1 - a3) (a2 - a4)
| optimize_congr_AMult: forall a1 a2 a3 a4,
    optimize a1 a2 ->
    optimize a3 a4 ->
    optimize (a1 * a3) (a2 * a4)
| optimize_refl: forall a,
    optimize a a
| optimize_trans: forall a1 a2 a3,
    optimize a1 a2 ->
    optimize a2 a3 ->
    optimize a1 a3
.

(** We call this relation [optimize] since it represents some kind of constant
    related optimization. You first task is to prove some of its instances. *)

(** **** Exercise: 1 star, standard: (optimize_sample1) *)

Example optimize_sample1: forall X Y: var,
  optimize (X + 0 * Y) X.
Proof.
  intros.
  eapply optimize_trans.
  2: apply optimize_plus_0_r.
  apply optimize_congr_APlus.
  + apply optimize_refl.
  + apply optimize_mult_0_l.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard: (optimize_sample2) *)

Example optimize_sample2: forall X Y: var,
  optimize ((0 * X) * 1) 0.
Proof.
  intros.
  eapply optimize_trans.
  2: apply optimize_mult_0_l.
  apply optimize_congr_AMult.
  + apply optimize_mult_0_l.
  + apply optimize_refl.
Qed.
(** [] *)

(** The next task for you is to prove [optimize] sound. Hint: you may need to
    use some properties about expression equivalence. You can use Coq's [Search]
    command to find those we have proved. For example, you can try

    [[
         Search APlus aexp_equiv.
    ]]
*)

(** **** Exercise: 3 stars, standard: (optimize_sound) *)

Theorem optimize_sound: forall a1 a2,
  optimize a1 a2 ->
  aexp_equiv a1 a2.
Proof.
  intros.
  induction H.
  + apply zero_plus_equiv.
  + apply plus_zero_equiv.
  + apply minus_zero_equiv.
  + apply one_mult_equiv.
  + apply mult_one_equiv.
  + apply zero_mult_equiv.
  + apply mult_zero_equiv.
  + apply APlus_congr.
    apply IHoptimize1.
    apply IHoptimize2.
  + apply AMinus_congr.
    apply IHoptimize1.
    apply IHoptimize2.
  + apply AMult_congr.
    apply IHoptimize1.
    apply IHoptimize2.
  + reflexivity.
  + rewrite IHoptimize1.
    rewrite IHoptimize2.
    reflexivity.
Qed.
(** [] *)

End Task1.

(* ################################################################# *)
(** * Task 2: Understanding Steps *)

Module Task2.

(** Prove the following step relations. *)

(** **** Exercise: 1 star, standard: (step_sample1) *)

Example step_sample1: forall (X: var) (st: state),
  st X = 5 ->
  astep st ((1 + X) * 2) ((1 + 5) * 2).
Proof.
  intros.
  apply AS_Mult1.
  apply AS_Plus2.
  { apply AH_num. }
  rewrite <- H.
  apply AS_Id.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard: (step_sample2) *)

Example step_sample2: forall (X: var) (st: state),
  cstep (If (0 <= (1 + 5) * 2) Then X ::= X - 1 Else Skip EndIf, st)%imp
        (If (0 <= 6 * 2) Then X ::= X - 1 Else Skip EndIf, st)%imp.
Proof.
  intros.
  apply CS_IfStep.
  apply BS_Le2.
  { apply AH_num. }
  apply AS_Mult1.
  apply AS_Plus.
Qed.
(** [] *)

End Task2.

(* ################################################################# *)
(** * Task 3: Alternative Small Step Semantics *)

Module Task3.
Local Open Scope imp.

(** Alice wrote three alternative definitions of [cstep]. Her purpose is to
    avoid administrative steps, i.e. the step from [Skip;; c] to [c]. These
    three definitions are [A1.cstep], [A2.cstep] and [A3.cstep] as follows.
    Her definitions only differ from the original [cstep] definition at the
    places of [CS_Seq]. *)

Module A1.

Inductive cstep : (com * state) -> (com * state) -> Prop :=
  | CS_AssStep : forall st X a a',
      astep st a a' ->
      cstep (CAss X a, st) (CAss X a', st)
  | CS_Ass : forall st1 st2 X n,
      st2 X = n ->
      (forall Y, X <> Y -> st1 Y = st2 Y) ->
      cstep (CAss X (ANum n), st1) (Skip, st2)
  | CS_SeqStep : forall st c1 c1' st' c2,
      cstep (c1, st) (c1', st') ->
      cstep (c1 ;; c2 , st) (c1' ;; c2, st')
  | CS_Seq : forall st c2 st' c2',
      cstep (c2, st) (Skip ;; c2', st') ->
      cstep (c2, st) (c2', st')   (* <- This is different. *)
  | CS_IfStep : forall st b b' c1 c2,
      bstep st b b' ->
      cstep
        (If b  Then c1 Else c2 EndIf, st)
        (If b'  Then c1 Else c2 EndIf, st)
  | CS_IfTrue : forall st c1 c2,
      cstep (If BTrue Then c1 Else c2 EndIf, st) (c1, st)
  | CS_IfFalse : forall st c1 c2,
      cstep (If BFalse Then c1 Else c2 EndIf, st) (c2, st)
  | CS_While : forall st b c,
      cstep
        (While b Do c EndWhile, st)
        (If b Then (c;; While b Do c EndWhile) Else Skip EndIf, st).

End A1.

Module A2.

Inductive cstep : (com * state) -> (com * state) -> Prop :=
  | CS_AssStep : forall st X a a',
      astep st a a' ->
      cstep (CAss X a, st) (CAss X a', st)
  | CS_Ass : forall st1 st2 X n,
      st2 X = n ->
      (forall Y, X <> Y -> st1 Y = st2 Y) ->
      cstep (CAss X (ANum n), st1) (Skip, st2)
  | CS_SeqStep : forall st c1 c1' st' c2,
      cstep (c1, st) (c1', st') ->
      cstep (c1 ;; c2 , st) (c1' ;; c2, st')
  | CS_Seq : forall st c2 st' c2',
      cstep (c2, st) (c2', st') ->
      cstep (Skip ;; c2, st) (c2', st')   (* <- This is different. *)
  | CS_IfStep : forall st b b' c1 c2,
      bstep st b b' ->
      cstep
        (If b  Then c1 Else c2 EndIf, st)
        (If b'  Then c1 Else c2 EndIf, st)
  | CS_IfTrue : forall st c1 c2,
      cstep (If BTrue Then c1 Else c2 EndIf, st) (c1, st)
  | CS_IfFalse : forall st c1 c2,
      cstep (If BFalse Then c1 Else c2 EndIf, st) (c2, st)
  | CS_While : forall st b c,
      cstep
        (While b Do c EndWhile, st)
        (If b Then (c;; While b Do c EndWhile) Else Skip EndIf, st).

End A2.

Module A3.

Inductive cstep : (com * state) -> (com * state) -> Prop :=
  | CS_AssStep : forall st X a a',
      astep st a a' ->
      cstep (CAss X a, st) (CAss X a', st)
  | CS_Ass : forall st1 st2 X n,
      st2 X = n ->
      (forall Y, X <> Y -> st1 Y = st2 Y) ->
      cstep (CAss X (ANum n), st1) (Skip, st2)
  | CS_SeqStep : forall st c1 c1' st' c2,
      cstep (c1, st) (c1', st') ->
      cstep (c1 ;; c2 , st) (c1' ;; c2, st')
  | CS_Seq : forall st c1 c2 st' c2',
      remove_skip c1 = CSkip ->
      cstep (c2, st) (c2', st') ->
      cstep (c1 ;; c2, st) (c2', st')   (* <- This is different. *)
  | CS_IfStep : forall st b b' c1 c2,
      bstep st b b' ->
      cstep
        (If b  Then c1 Else c2 EndIf, st)
        (If b'  Then c1 Else c2 EndIf, st)
  | CS_IfTrue : forall st c1 c2,
      cstep (If BTrue Then c1 Else c2 EndIf, st) (c1, st)
  | CS_IfFalse : forall st c1 c2,
      cstep (If BFalse Then c1 Else c2 EndIf, st) (c2, st)
  | CS_While : forall st b c,
      cstep
        (While b Do c EndWhile, st)
        (If b Then (c;; While b Do c EndWhile) Else Skip EndIf, st).

End A3.

(** But she is not sure, on what extent these [cstep] are well-defined
    semantics. Your task is to give her an answer using the following
    examples. *)

(** **** Exercise: 2 stars, standard *)

(** Which alternative semantics define a program execution process as follows?

    - 1. [A1.cstep]

    - 2. [A2.cstep]

    - 3. [A3.cstep]

    The execution process:

    [[
        Skip;; Y ::= X, st -->
        Y ::= 1, st
    ]]

    where [st X = 1].

    Remark: Your answer should be an ascending list of integers (which can be
    an empty list, a list with singleton element, or a list with more than one
    element, e.g. [], [1;3], [2], [1;2;3]). *)

Definition my_choice1: list Z := [2; 3].
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 2 stars, standard *)

(** Which alternative semantics define a program execution process as follows?

    - 1. [A1.cstep]

    - 2. [A2.cstep]

    - 3. [A3.cstep]

    The execution process:

    [[
        (Y ::= 1;; Skip);; X ::= 0, st -->
        (Skip;; Skip);; X ::= 0, st' -->
        Skip, st'' -->
    ]]

    where [st X = st' X = 1], [st' Y = st'' Y = 1] and all other variables on
    [st], [st'], [st''] have value [0].

    Remark: Your answer should be an ascending list of integers. *)

Definition my_choice2: list Z := [3].
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 2 stars, standard *)

(** Which alternative semantics define a program execution process as follows?

    - 1. [A1.cstep]

    - 2. [A2.cstep]

    - 3. [A3.cstep]

    The execution process:

    [[
        (Y ::= 1;; Skip);; X ::= 0, st -->
        X ::= 0, st' -->
        Skip, st'' -->
    ]]

    where [st X = st' X = 1], [st' Y = st'' Y = 1] and all other variables on
    [st], [st'], [st''] have value [0].

    Remark: Your answer should be an ascending list of integers. *)

Definition my_choice3: list Z := [1].
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

End Task3.

(* ################################################################# *)
(** * Task 4: Understanding Simulation *)

Module Task4.
Import Task3.
Local Open Scope imp.

(** In this task, you need to prove a simulation between our original small step
    semantics [cstep] and Alice's third alternative [A3.cstep] (which is defined
    by [A3.CS_AssStep], [A3.CS_Ass], etc.). *)

Inductive match_com: com -> com -> Prop :=
| MatRefl: forall c, match_com c c
| MatSkipSeq: forall c1_1 c1_2 c2_2,
    remove_skip c1_1 = CSkip ->
    match_com c1_2 c2_2 ->
    match_com (c1_1 ;; c1_2) c2_2
| MatSeq: forall c1_1 c1_2 c2_1,
    match_com c1_1 c2_1 ->
    match_com (c1_1 ;; c1_2) (c2_1 ;; c1_2).

Definition A3cstep_or_not (X Y: com * state): Prop :=
  X = Y \/ A3.cstep X Y.

(** We provide the definition of [match_com] for you. The idea is, if
    [match_com c1 c2], then [c1] has more [Skip] on the left than [c2]. Thus,
    [c1]'s execution via [A3.cstep] can eliminate those left-side skip in one
    step in the future, and simulate [c2]'s execution via [cstep], i.e.

    [[
        forall c1 c2 c2' st st',
          match_com c1 c2 ->
          cstep (c2, st) (c2', st') ->
          exists c1',
            match_com c1' c2' /\
            A3cstep_or_not (c1, st) (c1', st').
    ]]

    The following auxiliary lemma may be help! Prove it first. *)

(** **** Exercise: 2 stars, standard *)

Lemma match_com_skip_spec: forall c,
  match_com c Skip ->
  remove_skip c = Skip.
Proof.
  assert (forall c1 c2, match_com c1 c2 -> c2 = Skip -> remove_skip c1 = Skip).
  2: { intros; eapply H; eauto. }
  intros.
  induction H; simpl.
  + rewrite H0.
    reflexivity.
  + rewrite H.
    apply IHmatch_com.
    rewrite H0.
    reflexivity.
  + discriminate H0.
Qed.

(** **** Exercise: 4 stars, standard, optional *)

(** In order to prove the simulation property, you must be careful when choosing
    your proof strategy. There are mainly three candidates:

      - by induction over the proof of [match_com c1 c2],

      - by induction over the proof of [cstep (c2, st) (c2', st')],

      - by induction over the structure of [c1] (or [c2], [c2']).

    Make sure to find a good one before start typing your Coq proofs.

    Remark: this is an optional task, you do not lose points if you cannot solve
    it but you will get additional points if you complete it. *)

Theorem cstep_simulate_cstep: forall c1 c2 c2' st st',
  match_com c1 c2 ->
  cstep (c2, st) (c2', st') ->
  exists c1',
    match_com c1' c2' /\ A3cstep_or_not (c1, st) (c1', st').
Proof.
(* FILL IN HERE *) Admitted.

End Task4.

(* 2021-03-29 18:48 *)


Require Import ZArith.
Require Import Arith.

Open Scope Z_scope.

Fixpoint sum_f (f:nat -> Z) (n:nat)  : Z :=
  match n with
  | O => f O
  | S p => sum_f f p + f n
  end.

Theorem sum_n : forall n:nat, 2 * sum_f Z_of_nat n =
                              Z_of_nat n * (Z_of_nat n + 1).
Proof.
 induction n as [| p IHp].
 -  reflexivity.
 -  lazy beta iota zeta delta [sum_f]; fold sum_f.
     rewrite Zmult_plus_distr_r; rewrite IHp.
     rewrite inj_S ; unfold Z.succ ; ring.
Qed.