Theorem both_and : (forall A B : Prop, A -> B -> A /\ B).
Proof.
  intros A B.
  intros proof_A proof_B.
  refine (conj _ _).
    exact proof_A.
    exact proof_B.
Qed.

Theorem and_commutes : (forall A B : Prop, A /\ B -> B /\ A).
Proof.
  intros A B.
  intros proof_A_and_B.
  case proof_A_and_B.
    intros proof_A proof_B.
    refine (conj _ _).
      exact proof_B.
      exact proof_A.
Qed.

Theorem and_commutes_again : (forall A B : Prop, A /\ B -> B /\ A).
Proof.
  intros A B.
  intros proof_A_and_B.
  destruct proof_A_and_B as [ proof_A proof_B ].
  refine (conj _ _).
    exact proof_B.
    exact proof_A.
Qed.


(** CS6225 -- Pset4a (120 points) *)

(** * 6.822 Formal Reasoning About Programs, Spring 2018 - Pset 3 *)

Require Import Frap Pset4aSig.

(* Define the identity function [id], which just returns its
 * argument without modification.
 *)
Definition id {A : Type} (x : A) : A := x.

(* [compose] is another higher-order function: [compose g f]
 * applies [f] to its input and then applies [g]. Argument order
 * follows the general convention of functional composition in
 * mathematics denoted by the small circle.
 *)
Definition compose {A B C : Type} (g : B -> C) (f : A -> B)
           (x : A) : C := g(f x).

(* If we map the [id] function over any list, we get the
 * same list back.
 *)
Theorem map_id : forall {A : Type} (xs : list A),
    map id xs = xs.
Proof.
  simplify.
  induction xs.
  - simplify. equality.
  - unfold id. simplify. unfold id in IHxs. rewrite IHxs. equality.
Qed.

(* If we map the composition of two functions over the list,
 * it's the same as mapping the first function over the whole list
 * and then mapping the second function over that resulting list.
 *)
Theorem map_compose : forall {A B C : Type} (g : B -> C) (f : A -> B)
                        (xs : list A),
    map (compose g f) xs = map g (map f xs).
Proof.
  simplify.
  induction xs.
  - simplify. equality.
  - unfold compose. simplify. unfold compose in IHxs. rewrite IHxs. equality.
Qed.

(* Next we can show some classic properties that demonstrate a
 * certain sense in which [map] only modifies the elements of
 * a list, but preserves its structure: [map_length] shows it
 * preserves length, and [map_append] and [map_rev] show that
 * it commutes with [++] and [rev], respectively.
 * For each of [length], [++], and [rev], it doesn't matter
 * whether we apply [map] before the operation or after.
 *)
Theorem map_length : forall {A B : Type} (f : A -> B) (xs : list A),
    length (map f xs) = length xs.
Proof.
  induction xs.
  - simplify. equality.
  - unfold length. simplify. unfold length in IHxs. rewrite IHxs. equality.
Qed.

Theorem map_append : forall {A B : Type} (f : A -> B) (xs ys : list A),
    map f (xs ++ ys) = map f xs ++ map f ys.
Proof.
  induction xs.
    - simplify. equality.
    - unfold append. simplify. unfold append in IHxs. rewrite IHxs. equality.
Qed.

Theorem map_rev : forall {A B : Type} (f : A -> B) (xs : list A),
    map f (rev xs) = rev (map f xs).
Proof.
  induction xs.
      - simplify. equality.
      - simpl map. simpl rev. simplify. rewrite  (map_append (f) (rev xs) ([a])). rewrite IHxs. equality.
Qed.

(* [fold] is a higher-order function that is even more general
 * than [map]. In essence, [fold f z] takes as input a list
 * and produces a term where the [cons] constructor is
 * replaced by [f] and the [nil] constructor is replaced
 * by [z].
 *
 * [fold] is a "right" fold, which associates the binary operation
 * the opposite way as the [left_fold] function that we defined
 * in lecture.
 *)
Fixpoint fold {A B : Type} (b_cons : A -> B -> B) (b_nil : B)
         (xs : list A) : B :=
match xs with
| [] => b_nil
| h::t => b_cons h (fold b_cons  b_nil t)
end.

(* For instance, we should have
     fold plus 10 [1; 2; 3]
   = 1 + (2 + (3 + 10))
   = 16
 *)
Example fold_example : fold plus 10 [1; 2; 3] = 16.
Proof.
  simplify. equality.
Qed.

(* Prove that [map] can actually be defined as a particular
 * sort of [fold].
 *)

Definition map_is_fold : forall {A B : Type} (f : A -> B) (xs : list A),
    map f xs = fold (fun x ys => cons (f x) ys) nil xs.
Proof.
  intros.
  induction xs.
    - simplify. equality.
    - simpl. rewrite IHxs. simpl fold. equality.
Qed.

(* Since [fold f z] replaces [cons] with [f] and [nil] with
 * [z], [fold cons nil] should be the identity function.
 *)
Theorem fold_id : forall {A : Type} (xs : list A),
    fold cons nil xs = xs.
Proof.
  simplify.
  induction xs.
    - simplify. equality.
    - simpl fold. rewrite IHxs. equality.
Qed.

(* If we apply [fold] to the concatenation of two lists,
 * it is the same as folding the "right" list and using
 * that as the starting point for folding the "left" list.
 *)

(* We will use this lemma to prove the next theorem *)
Lemma app_nil : forall {A:Type} (lst : list A),
  lst ++ nil = lst.
Proof.
  intros A lst.
  induction lst as [ | h t IH].
  - trivial.
  - simpl. rewrite -> IH. trivial.
Qed.

Theorem fold_append : forall {A : Type} (f : A -> A -> A) (z : A)
                        (xs ys : list A),
    fold f z (xs ++ ys) =
    fold f (fold f z ys) xs.
Proof.
  simplify.
  induction xs.
  - simplify. equality.
  - simpl fold. rewrite IHxs. equality.
Qed.

(* Using [fold], define a function that computes the
 * sum of a list of natural numbers.
 *)
Definition sum (lst:list nat) :nat := fold (fun (x:nat) (y:nat)=> x+y) 0 lst.

(* Note that [simplify] fails to reduce [ sum [1; 2; 3] ].
 * This is due to a quirk of [simplify]'s behavior: because
 * unfolding [sum] does not present an immediate opportunity
 * for reduction (since [fold] will still need to be unfolded
 * to its fixpoint definition, no simplification is performed).
 * A simple remedy is to use the tactic [unfold sum] prior to
 * calling [simplify]. This should come in handy for future proofs
 * involving definitions that use [fold], too.
 *)
Example sum_example : sum [1; 2; 3] = 6.
Proof.
  simpl. equality.
Qed.

(* Using [fold], define a function that computes the
 * conjunction of a list of Booleans (where the 0-ary
 * conjunction is defined as [true]).
 *)
Definition all (lst:list bool) :bool := fold (fun (x:bool) (y:bool) => x && y) true lst.

Example all_example : all [true; false; true] = false.
Proof.
   simplify. equality.
Qed.

(* The following two theorems, [sum_append] and [all_append],
 * say that the sum of the concatenation of two lists
 * is the same as summing each of the lists first and then
 * adding the result.
 *)
Theorem sum_append : forall (xs ys : list nat),
    sum (xs ++ ys) = sum xs + sum ys.
Proof.
  simplify.
  induction xs.
    - simplify. equality.
    - simpl sum. unfold sum. simpl fold. unfold sum in IHxs. rewrite IHxs. linear_arithmetic.
Qed.

Theorem all_append : forall (xs ys : list bool),
    all (xs ++ ys) = andb (all xs) (all ys).
Proof.
  simplify.
  induction xs.
    - simplify. equality.
    - simpl all. unfold all. simpl fold. unfold all in IHxs. rewrite IHxs. ring.
Qed.

(* Just like we defined [map] for lists, we can similarly define
 * a higher-order function [tree_map] which applies a function on
 * elements to all of the elements in the tree, leaving the tree
 * structure in tact.
 *)
Fixpoint tree_map {A B : Type} (f : A -> B) (t : tree A)
  : tree B := match t with
| Leaf => Leaf
| Node a b c => Node (tree_map f a) (f b) (tree_map f c)
end.

Example tree_map_example :
  tree_map (fun x => x + 1) (Node (Node Leaf 1 Leaf) 2 (Node Leaf 3 (Node Leaf 4 Leaf)))
  = (Node (Node Leaf 2 Leaf) 3 (Node Leaf 4 (Node Leaf 5 Leaf))).
Proof.
  simplify. equality.
Qed.

(* [tree_map_flatten] shows that [map]
 * and [tree_map] are related by the [flatten] function.
 *)
Theorem tree_map_flatten : forall {A B : Type} (f : A -> B) (t : tree A),
  flatten (tree_map f t) = map f (flatten t).
Proof.
  simplify.
  induction t.
      - simplify. equality.
      - simpl flatten. rewrite IHt1. rewrite IHt2. rewrite  (map_append f (flatten t1) (d::flatten t2)). simpl map. equality.
Qed.

(* Using [fold], define a function that composes a list of functions,
 * applying the *last* function in the list *first*.
 *)
Definition compose_list {A : Type} (lst: list (A -> A)) (y: A) : A := fold (fun (f:A->A) (y:A) => f y) y (lst).

Example compose_list_example :
  compose_list [fun x => x + 1; fun x => x * 2; fun x => x + 2] 1 = 7.
Proof.
  simplify. equality.
Qed.

(* Show that [sum xs] is the same as converting each number
 * in the list [xs] to a function that adds that number,
 * composing all of those functions together and finally
 * applying that large composed function to [0].
 *)
Theorem compose_list_map_add_sum : forall (xs : list nat),
    compose_list (map plus xs) 0 = sum xs.
Proof.
  simplify.
  induction xs.
    - simplify. equality.
    - unfold compose_list. simplify. unfold compose_list in IHxs. rewrite IHxs. simpl sum. equality.
Qed.

(* Ignore the below lines: *)

(*Lemma util: forall {A B:Type} (zs: list B) (xs: list A) (f: A->B),
  fold (fun (x : A) (ys : list B) => f x :: ys) zs xs = zs++fold (fun (x : A) (ys : list B) => f x :: ys) [] xs.
Proof.
  simplify.
  induct xs.
    - simplify. rewrite (app_nil zs). equality.
    - simplify. induction zs.
        ++ simplify. equality.
        ++ simplify.

*)
(* Lemma fold_id_util : forall {A : Type} (xs: list A) (a:A),
  fold cons [a] xs = a::xs.
Proof.
  simplify.
  induct xs.
    - simplify. equality.
    -
*)


(** * Andrew Chen
3/13/22 *)

From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Init.Nat.
From Coq Require Import Lia.
From Coq Require Import Lists.List. Import ListNotations.
Require Import Coq.Program.Program.
Require Import Relation_Definitions.
Require Export Coq.Classes.RelationClasses.
Require Export Coq.Classes.Morphisms.
Require Export Coq.Classes.Init.
Require Import Coq.Program.Basics.
Require Import Coq.Program.Tactics.
Require Import Coq.Sets.Ensembles.
Require Import Coq.ZArith.Int. (*would like to use integers, but did not
                                 realize it was necessary until it was too late *)

(*Basic group definitions and properties, showing group axioms from left axioms.*)

Class Group (G : Type) : Type :=
{
  op : G -> G -> G;
  inv : G -> G;
  e : G;

  associativity : forall a b c, op a (op b c) = op (op a b) c;
  leftidentity : forall a, op e a = a;
  leftinverse : forall a, op (inv a) a = e;
}.

Class Finite (G : Type) : Type :=
{
  elements : list G;
}.

Class FiniteGroup (G : Type) {g : Group G} {f : Finite G} : Type := { }.

(*Class FiniteGroup (G : Type) {g : Group G}: Type :=
{
  elements : list G;
  (*
  (*cardinality := length(elements);*)
  memberfinitegroup (m : G) : Prop := In m elements <-> member m*)
}. *)

Definition finiteorder {G : Type}{g : Group G}{f : Finite G}{f : FiniteGroup G} : nat :=
  length(elements).

(*Definition isfinitegroup (G : Type){g : Group G}{f : Finite G}{f : FiniteGroup G} : Prop :=
  forall (g : G), In g elements. *)

Notation "x '**' y" := (op x y) (at level 50, left associativity).

Definition idempotent {G : Type} {g : Group G} (a : G) : Prop :=
  op a a = a.

Definition identity {G : Type} {g : Group G} (a : G) : Prop :=
  a = e.

Lemma leftapplication {G : Type} {g : Group G} : forall (a b c: G),
  a = b -> c ** a = c ** b.
Proof.
  intros. rewrite H. reflexivity.
Qed.

Lemma rightapplication {G : Type} {g : Group G} : forall (a b c : G),
  a = b -> a ** c = b ** c.
Proof.
  intros. rewrite H. reflexivity.
Qed.

Theorem rightinverse {G : Type} {g : Group G} : forall (a : G),
  op a (inv a) = e. (*hard*)
Proof.
  intros. rewrite <- leftidentity with (a ** inv a).
  rewrite <- leftinverse with (a ** inv a).
  rewrite <- associativity.
  assert (A: a ** inv a ** (a ** inv a) = a ** (inv a ** a) ** inv a).
  { rewrite associativity. rewrite associativity. reflexivity. }
   rewrite A. rewrite leftinverse with a. rewrite <- associativity.
   rewrite leftidentity. reflexivity.
Qed.

Theorem rightidentity {G : Type} {g : Group G} : forall (a : G),
  a ** e = a.
Proof.
  intros. rewrite <- leftinverse with a.
  rewrite associativity. rewrite rightinverse with a.
  rewrite leftidentity. reflexivity.
Qed.

Lemma leftcancellation {G : Type} {g : Group G} : forall (a b c : G),
  c ** a = c ** b -> a = b.
Proof.
  intros. rewrite <- leftidentity. rewrite <- leftinverse with c.
  rewrite <- associativity. rewrite <- H. rewrite associativity.
  rewrite leftinverse. rewrite leftidentity. reflexivity.
Qed.

Lemma rightcancellation {G : Type} {g : Group G} : forall (a b c : G),
  a ** c = b ** c -> a = b.
Proof.
  intros. rewrite <- rightidentity. rewrite <- rightinverse with c.
  rewrite associativity. rewrite <- H. rewrite <- associativity.
  rewrite rightinverse. rewrite rightidentity. reflexivity.
Qed.

Theorem inverse_unique {G : Type} {g : Group G}: forall (a b: G),
  a ** b = e -> a = inv b /\  b = inv a.
Proof.
  intros. split.
  * rewrite <- leftidentity. rewrite <- H.
    rewrite <- associativity.
    rewrite rightinverse with b. rewrite rightidentity. reflexivity.
  * rewrite <- rightidentity. rewrite <- H.
    rewrite associativity.
    rewrite leftinverse with a. rewrite leftidentity. reflexivity.
Qed.

Lemma inverseinverse {G : Type} {g : Group G} : forall (a : G),
  inv (inv a) = a.
Proof.
  intros.
  remember (leftinverse a) as H.
  destruct HeqH. apply inverse_unique in H. destruct H.
  symmetry. assumption.
Qed.

Lemma inversefunction {G : Type} {g : Group G} : forall (a b : G),
  a = b -> inv a = inv b.
Proof.
  intros. rewrite H; reflexivity.
Qed.

Lemma inverseinjective {G : Type} {g : Group G} : forall (a b : G),
  inv a = inv b -> a = b.
Proof.
  intros. apply inversefunction in H. repeat rewrite inverseinverse in H. assumption.
Qed.

Theorem inversedistribution {G : Type} {g : Group G} : forall (a b : G),
 inv (a ** b) = inv b ** inv a.
Proof.
  intros. rewrite <- rightcancellation with (inv (a ** b)) (inv b ** inv a) a. reflexivity.
  rewrite <- associativity. rewrite leftinverse with a. rewrite rightidentity.
  rewrite <- rightcancellation with (inv (a ** b) ** a) (inv b) b. reflexivity.
  rewrite leftinverse with b. rewrite <- associativity. rewrite leftinverse with (a ** b).
  reflexivity.
Qed.

Lemma einverse_ise {G : Type} {g : Group G} : forall (a : G),
  inv e = e.
Proof.
  intros. rewrite <- leftidentity with (inv e). rewrite rightinverse with e. reflexivity.
Qed.

Theorem leftinverseisrightinverse {G : Type} {g : Group G}: forall (a b c: G),
  a ** b = e /\ c ** a = e -> b = c.
Proof.
  intros. destruct H. apply leftapplication with (c ** a) e (inv c) in H0.
  rewrite associativity in H0. rewrite leftinverse in H0. rewrite leftidentity in H0.
  rewrite rightidentity in H0. rewrite H0 in H. apply inverse_unique in H. destruct H.
  apply inverseinjective in H. symmetry; assumption.
Qed.

Theorem inversecommutes {G : Type} {g : Group G}: forall (a b: G),
  a ** b = e <-> b ** a = e.
Proof.
  intros. split; intros.
  * rewrite <- rightinverse with b. rewrite <- leftapplication with a (inv b) b. reflexivity.
    rewrite <- leftinverse with b in H. apply rightcancellation in H. assumption.
  * rewrite <- rightinverse with a. rewrite <- leftapplication with b (inv a) a. reflexivity.
    rewrite <- leftinverse with a in H. apply rightcancellation in H. assumption.
Qed.

Lemma leftidentity_unique {G : Type}{g : Group G}: forall (a b : G),
  a ** b = b -> a = e.
Proof.
  intros. rewrite <- leftidentity with b in H.
  rewrite associativity in H. rewrite rightidentity with a in H.
  rewrite rightcancellation with a e b. reflexivity. assumption.
Qed.

Lemma rightidentity_unique {G : Type}{g : Group G}: forall (a b : G),
  a ** b = a -> b = e.
Proof.
  intros. rewrite <- rightidentity with a in H.
  rewrite <- associativity in H. rewrite leftidentity with b in H.
  rewrite leftcancellation with b e a. reflexivity. assumption.
Qed.

Theorem leftidentityisrightidentity {G : Type} {g : Group G}: forall (a b c: G),
  a ** b = a /\ c ** a = a -> b = c.
Proof.
  intros. destruct H. rewrite <- leftidentity in H0. apply rightcancellation in H0.
  rewrite <- rightidentity in H. apply leftcancellation in H. rewrite <- H in H0. symmetry.
  assumption.
Qed.

Theorem idempotent_is_identity {G : Type} {g : Group G} : forall (a : G),
idempotent a <-> identity a.
Proof.
  intros. split; intros.
  * inversion H. unfold identity. rewrite <- leftidentity in H0. apply rightcancellation in H0.
    rewrite H0. apply rightidentity.
  * inversion H. unfold idempotent. apply rightidentity.
Qed.

(*Cyclic and Abelian groups *)

Class AbelianGroup (G : Type) {g : Group G} : Type :=
{
  commutativity : forall a b, op a b = op b a
}.

Definition iscommutative {G : Type} {g : Group G} (a b : G) : Prop :=
  a ** b = b ** a.

Definition isabelian (G : Type) {g : Group G} : Prop :=
  forall (a b: G), iscommutative a b.

Fixpoint opexponent {G : Type} {g : Group G}(base : G)(n : nat): G :=
  match n with
  | O => e
  | S n => base ** opexponent base n
end.

Class CyclicGroup (G : Type) {g : Group G} : Type :=
{
  generator : exists a, forall b, exists (n : nat), opexponent a n = b
}.

Definition iscyclic (G : Type) {g : Group G} : Prop :=
  exists (a : G), forall (b : G), exists (n : nat), opexponent a n = b.

Definition isgenerator {G : Type} {g : Group G} (gen : G) : Prop :=
  forall b, exists (n : nat), opexponent gen n = b.

Lemma opexponentaddition {G : Type}{g : Group G}: forall (a : G) (n1 n2 : nat),
  (opexponent a n1) ** (opexponent a n2) = (opexponent a (n1 + n2)) /\
  (opexponent a n2) ** (opexponent a n1) = (opexponent a (n1 + n2)).
Proof.
  intros. split.
  * induction n1. simpl. apply leftidentity.
    simpl. rewrite <- associativity.
    rewrite leftapplication with (opexponent a n1 ** opexponent a n2) (opexponent a (n1 + n2)) a.
    reflexivity. assumption.
  * induction n2. simpl. rewrite leftidentity. rewrite plus_0_r. reflexivity.
    assert (A: n1 + S n2 = S n2 + n1).
    { lia. }
    rewrite A. simpl. rewrite <- associativity.
    rewrite leftapplication with (opexponent a n2 ** opexponent a n1) (opexponent a (n2 + n1)) a.
    reflexivity.
    assert (B : n2 + n1 = n1 + n2).
    { lia. }
    rewrite B; assumption.
Qed.

Theorem cyclicisabelian (G : Type){g : Group G}{c : CyclicGroup G} :
  isabelian G.
Proof.
  unfold isabelian. unfold iscommutative. intros. inversion c. destruct generator0.
  assert (A: exists n1, opexponent x n1 = a).
  { eapply H. }
  assert (B: exists n1, opexponent x n1 = b).
  { eapply H. }
  destruct A. destruct B.
  rewrite <- H0. rewrite <- H1.
  assert (X: opexponent x x0 ** opexponent x x1 = opexponent x (x0+x1)).
  {apply opexponentaddition. }
  assert (Y : opexponent x x1 ** opexponent x x0 = opexponent x (x0+x1)).
  {apply opexponentaddition. }
  rewrite X. rewrite Y. reflexivity.
Qed.

(*Defining Subgroups*)

Class Restrict (G : Type) : Type :=
{
  member : G -> Prop
}.

Class Subgroup (G : Type){g : Group G}{r : Restrict G} : Type :=
{
  closure : forall a b, member a -> member b -> member (op a b);
  inverse : forall a, member a -> member (inv a);
  identityinsubgroup : forall a, identity a -> member a
}.

Class FiniteSubgroup (G : Type){g : Group G}{r : Restrict G}{f : Finite G} : Type := {}.

Definition subgroupfiniteorder {G : Type}{g : Group G}{r : Restrict G}{f : Finite G}{fg : FiniteSubgroup G} : nat :=
  length(elements).

Definition issubgroup {G : Type}{g : Group G}(r : Restrict G) : Prop :=
  forall (a b : G), member a -> member b -> member e /\ member (a ** b) /\ member (inv a).

(*Informally, if G is a group and a is in G, then H = { a ^ n | n \in Z} is a subgroup of G
  containing a. This is the smallest subgroup containing a, as subgroups must be closed
  under operation. *)
Theorem smallestsubgroupcontaininga {G : Type}{g : Group G}{r : Restrict G} :
  forall (a : G), ((forall (n : nat), member (opexponent a n)) /\
                  (forall (b : G), member b -> (exists (n: nat), b = opexponent a n)))
                  -> issubgroup r.
Proof.
  intros. unfold issubgroup. intros. split.
  * assert (B: member (opexponent a 0)).
    { intros. apply H. }
    simpl in B. assumption.
  * split; destruct H.
    - apply H2 in H1. apply H2 in H0. destruct H1. destruct H0.
      rewrite H0. rewrite H1.
      assert(A : opexponent a x0 ** opexponent a x = opexponent a (x0 + x)).
      { apply opexponentaddition. }
      rewrite A. apply H.
    - apply H2 in H0. destruct H0. rewrite H0.
      (*At the point the informal proof relies on the usage of Z,
        namely the existence of -x,
        but here I only have the naturals in the form of nat. *)
Admitted.

Class NormalSubgroup (G : Type){g : Group G}{r : Restrict G}{h : Subgroup G} : Type :=
{
  normal : forall (g n : G), member n -> member (g ** n ** (inv g))
}.

Lemma onenonmemberleadstononmember{G : Type}{g : Group G}{r : Restrict G}{h : Subgroup G} : forall (a b : G),
 (~(member a) /\ member b ) \/ (member a /\ ~(member b)) -> ~(member (a ** b)).
 Proof.
  intros. remember closure as A. destruct H.
  * destruct H. unfold not. unfold not in H. intros. apply H.
    apply inverse in H0. apply A with (a ** b) (inv b) in H0.
    rewrite <- associativity in H0. rewrite rightinverse with b in H0. rewrite rightidentity in H0.
    assumption. assumption.
  * destruct H. unfold not. unfold not in H. intros. apply H0.
    apply inverse in H. apply A with (inv a) (a ** b) in H.
    rewrite associativity in H. rewrite leftinverse with a in H. rewrite leftidentity in H.
    assumption. assumption.
Qed.

Lemma subgroupinverse {G : Type}{g : Group G}{r : Restrict G}{h : Subgroup G} : forall (a : G),
  member(inv a) <-> member a.
Proof.
  intros. split; intros.
  * apply inverse in H. rewrite inverseinverse with a in H. assumption.
  * apply inverse in H; assumption.
Qed.

Lemma notsubgroupinverse {G : Type}{g : Group G}{r : Restrict G}{h : Subgroup G} : forall (a : G),
  ~member(inv a) <-> ~member a.
Proof.
  intros. split; intros.
  * unfold not. intros. unfold not in H. apply H. apply inverse in H0. assumption.
  * unfold not. unfold not in H. intros. apply H. rewrite subgroupinverse in H0. assumption.
Qed.

Lemma subgroupleftmember {G : Type}{g : Group G}{r : Restrict G}{h : Subgroup G} : forall (a b : G),
  member a -> member b <-> member(a ** b).
Proof.
  intros; split; intros.
  * apply closure with a b in H. assumption. assumption.
  * apply inverse in H. apply closure with (inv a) (a ** b) in H. rewrite associativity in H.
    rewrite leftinverse in H. rewrite leftidentity in H. assumption. assumption.
Qed.

Lemma subgrouprightmember {G : Type}{g : Group G}{r : Restrict G}{h : Subgroup G} : forall (a b : G),
  member b -> member a <-> member(a ** b).
Proof.
  intros; split; intros.
  * apply closure with a b in H. assumption. assumption.
  * apply inverse in H. apply closure with (a ** b) (inv b) in H. rewrite <- associativity in H.
    rewrite rightinverse in H. rewrite rightidentity in H. assumption. assumption.
Qed.

(*the below proof is difficult, not sure how to complete it. *)
Theorem fundamentaltheoremofcyclicgroups {G : Type}{g : Group G}{c : CyclicGroup G}{r : Restrict G}{h : Subgroup G} :
  exists (a : G), member a /\ forall (h : G), member h -> exists (n : nat), h = opexponent a n.
Proof.
  remember generator as A. destruct A. eexists. split.
  * Abort.
  (*exists x.  intros. destruct. split. *)

(* Cosets *)

Class LeftCosetRestrict (G : Type) : Type :=
{
  lcosetmember : G -> Prop
}.

Class RightCosetRestrict (G : Type) : Type :=
{
  rcosetmember : G -> Prop
}.

(*Not all cosets are groups, so we do not give it the subgroup annotation*)
Class leftcoset {G: Type}{g : Group G}(r : Restrict G){c : LeftCosetRestrict G}(a : G):=
{
  inleftcoset : forall (h : G), member h ->  lcosetmember (a ** h)
}.

Class rightcoset {G: Type}{g : Group G}(r : Restrict G){c : RightCosetRestrict G}(a : G):=
{
  inrightcoset : forall (h : G), member h ->  rcosetmember (h ** a)
}.

Definition leftrightcosetequalfora {G : Type}{g : Group G}{r : Restrict G}(h : Subgroup G)(a : G)
      {l : LeftCosetRestrict G}{r : RightCosetRestrict G} : Prop :=
  forall (s : G), member s -> (lcosetmember (a ** s) <-> rcosetmember (s ** a)).

Definition leftrightcosetsequal {G : Type}{g : Group G}{r : Restrict G}(h : Subgroup G)
{l : LeftCosetRestrict G}{r : RightCosetRestrict G} : Prop :=
  forall (a : G), leftrightcosetequalfora h a.

Definition leftcosetrelation {G : Type}{g : Group G}{r : Restrict G}
(a : G)(b : G) : Prop :=
  member ((inv a) ** b).

Definition rightcosetrelation {G : Type}{g : Group G}{r : Restrict G}
(a : G)(b : G) : Prop :=
  member (a ** (inv b)).

Definition isequivalencerelation {G : Type}(f : G -> G -> Prop): Prop :=
  forall (a b c : G), f a a /\ ((f a b) <-> (f b a)) /\ ((f a b) -> (f b c) -> (f a c)).

Theorem cosetrelationisequivrelation {G : Type}{g : Group G}{r : Restrict G}{h : Subgroup G} :
 isequivalencerelation leftcosetrelation /\ isequivalencerelation rightcosetrelation.
Proof.
  unfold isequivalencerelation. split; split.
  * unfold leftcosetrelation. rewrite leftinverse. apply identityinsubgroup. reflexivity.
  * split.
    - split; unfold leftcosetrelation; intros; apply inverse in H;
      rewrite inversedistribution in H; rewrite inverseinverse in H;
      assumption.
    - unfold leftcosetrelation; repeat intros.
      apply closure with (inv a ** b) (inv b ** c) in H.
      repeat rewrite <- associativity in H.
      assert (A: b ** (inv b ** c) = (b ** inv b) ** c).
      { rewrite <- associativity. reflexivity. }
        rewrite A in H. rewrite rightinverse in H.
        rewrite leftidentity in H. assumption.
        assumption.
  * unfold rightcosetrelation. rewrite rightinverse. apply identityinsubgroup. reflexivity.
  *  split.
    - split; unfold rightcosetrelation; intros; apply inverse in H;
      rewrite inversedistribution in H; rewrite inverseinverse in H;
      assumption.
    - unfold rightcosetrelation; repeat intros.
      apply closure with (a ** inv b) (b ** inv c) in H.
      repeat rewrite <- associativity in H.
      assert (A: inv b ** (b ** inv c) = (inv b ** b) ** inv c).
      { rewrite <- associativity. reflexivity. }
        rewrite A in H. rewrite leftinverse in H.
        rewrite leftidentity in H. assumption.
        assumption.
Qed.

Class LeftCosetEquivalenceClass {G: Type}{g : Group G}{r : Restrict G}{c : LeftCosetRestrict G}(a : G):=
{
  inleftcosetequivalenceclass (b : G) : leftcosetrelation a b
}.

Class RightCosetEquivalenceClass {G: Type}{g : Group G}{r : Restrict G}{c : RightCosetRestrict G}(a : G):=
{
  inrightcosetequivalenceclass (b : G) : rightcosetrelation a b
}.

Class LeftCosets (G: Type){g : Group G}{r : Restrict G}{c : LeftCosetRestrict G}:=
{
  aleftcoset (a : G) : LeftCosetEquivalenceClass a
}.

Class FiniteLeftCosets (G: Type){g : Group G}{r : Restrict G}{c : LeftCosetRestrict G}{f : Finite G} : Type := {}.

Definition leftcosetsfinitecardinality {G : Type}{g : Group G}{r : Restrict G}{c : LeftCosetRestrict G}{f : Finite G}
{flc : FiniteLeftCosets G} : nat :=
  length(elements).

Class RightCosets (G: Type){g : Group G}{r : Restrict G}{c : RightCosetRestrict G}:=
{
  arightcoset (a : G) : RightCosetEquivalenceClass a
}.

Class FiniteRightCosets (G: Type){g : Group G}{r : Restrict G}{c : RightCosetRestrict G}{f : Finite G} : Type := {}.

Definition rightcosetsfinitecardinality {G : Type}{g : Group G}{r : Restrict G}{c : RightCosetRestrict G}{f : Finite G}
{frc : FiniteRightCosets G} : nat :=
  length(elements).

Definition isbijective {A : Type}{B : Type}(f : A -> B) :=
  (forall (b1 b2 : B)(a1 a2 : A), b1 = f a1 -> b2 = f a2 -> b1 = b2 -> a1 = a2)
  /\ (forall (b : B), exists (a : A), f a = b).

(* The (a : G) is the representative of the coset aH, while h is intended to be any element
    of the subgroup. The proof of Lagrange's theorem uses the bijectivity of this function to
    show that for any coset aH, aH has the same number of elements as H.*)
Definition lagrangemapping {G : Type}{g : Group G}{r : Restrict G}
{s : Subgroup G}{f: Finite G}{fg : FiniteGroup G}{sf : FiniteSubgroup G}(a : G) : G -> G := fun h => a ** h.

Theorem partoflagrange {G : Type}{g : Group G}{r : Restrict G}
{s : Subgroup G}{f: Finite G}{fg : FiniteGroup G}{sf : FiniteSubgroup G}
(a : G): isbijective (lagrangemapping a).
Proof.
  unfold isbijective. unfold lagrangemapping. split; intros.
  * rewrite H1 in H. rewrite H0 in H. apply leftcancellation in H.
    symmetry. assumption.
  * exists (inv a ** b). rewrite associativity. rewrite rightinverse.
    rewrite leftidentity. reflexivity.
Qed.

(*The above theorem is intended to show that "Every coset of a subgroup of H
  of a group G has the same number of elements as H", a statement which once established,
  Lagrange's theorem follows almost immediately from,
  as shown in Theorem 10.10 in Fraleigh,
  "A First Course in Abstract Algebra". However, my implementation has a couple of issues,
  namely that my Lagrange mapping goes from G -> G and does not reflect the fact that
  the mapping should go H -> G in the informal proof. Additionally, I have been unsuccessful
  in thinking of a way to count the number of items in a left coset equivalence class,
  and I also haven't shown a way to count the number of left coset equivalence classes.
  From the above theorem, when stated correctly, Lagrange's theorem is a direct result
  of the fact that the order of the group must be equal to the number of cosets times the number of
  items in each coset - the above theorem proving that the number of items in each coset
  must be the same as the number of items in the subgroup H from which the cosets are generated from,
  gives the result of Lagrange's theorem: the order of H divides the order of G.
  *)

Theorem Lagrange {G : Type}{g : Group G}{r : Restrict G}
{s : Subgroup G}{f: Finite G}{fg : FiniteGroup G}{sf : FiniteSubgroup G}
: exists (n : nat), n * subgroupfiniteorder = finiteorder.
Proof.
Abort.

(*Factor/Quotient Groups: Expansion *)
(*Class QuotientGroup (G : Type){g : Group G}{r : Restrict G}{h : Subgroup G}{n : NormalSubgroup G} : Type :=
{

}
*)


Require Import NArith Ring Monoid_instances Euclidean_Chains Pow
        Strategies Dichotomy BinaryStrat.
Import Addition_Chains.
Open Scope N_scope.

(* begin snippet FibDef *)
Fixpoint fib (n:nat) : N :=
  match n with
    0%nat | 1%nat => 1
  | (S ((S p) as q)) => fib p + fib q
  end.

Compute fib 20.
(* end snippet FibDef *)

Lemma fib_ind (P:nat->Prop) :
  P 0%nat -> P 1%nat -> (forall n, P n -> P (S n) -> P(S (S n))) ->
  forall n, P n.
Proof.
intros H0 H1 HS n; assert (P n /\ P (S n)).
{ induction n.
  - split;auto.
  - destruct IHn; split; auto.
}
 tauto.
Qed.

Lemma fib_SSn : forall (n:nat) , fib (S (S n)) = (fib n + fib (S n)).
Proof.
  intro n; pattern n; apply fib_ind; try reflexivity.
Qed.

(** Yves' encoding *)

(* begin snippet mul2Def *)
Definition mul2 (p q : N * N) :=
  match p, q with
    (a, b),(c,d) => (a*c + a*d + b*c, a*c + b*d)
  end.
(* end snippet mul2Def *)

Lemma neutral_l p : mul2 (0,1) p = p.
  unfold mul2. destruct p; f_equal; ring.
Qed.

Lemma neutral_r p : mul2 p (0,1)  = p.
  unfold mul2.  destruct p; f_equal; ring.
Qed.

(* begin snippet mul2Monoid  *)
#[ global ] Instance Mul2 : Monoid  mul2 (0,1).
(* end snippet mul2Monoid  *)

Proof.
  split.
  destruct x,y,z; unfold mul2;  cbn; f_equal; ring.
  intro x; now rewrite neutral_l.
  intro  x; now rewrite neutral_r.
Qed.

(* begin snippet nextFib:: no-out *)
Lemma next_fib (n:nat) : mul2 (1,0) (fib (S n), fib n) =
                         (fib (S (S n)), fib (S n)).
(* end snippet nextFib *)
Proof.
  unfold mul2; f_equal; ring_simplify.
  -  rewrite fib_SSn. ring.
  - reflexivity.
Qed.

(* begin snippet fibMul2Def *)
Definition fib_mul2 n := let (a,b) := power (M:=Mul2) (1,0) n
                         in (a+b).

Compute fib_mul2 20.
(* end snippet fibMul2Def *)

(* begin snippet fibMul2OK0:: no-out *)
Lemma fib_mul2_OK_0 (n:nat) :
  power (M:=Mul2) (1,0) (S (S n)) =
  (fib (S n), fib n).
Proof.
  induction n.
  (* ... *)
  (* end snippet fibMul2OK0 *)
  - reflexivity.
  - now rewrite power_eq2, IHn, next_fib.
Qed.

(* begin snippet fibMul2OK:: no-out *)
Lemma fib_mul2_OK n : fib n = fib_mul2 n.
(* end snippet fibMul2OK *)
Proof.
 unfold fib_mul2; pattern n;apply fib_ind; try reflexivity.
 - intros; rewrite fib_mul2_OK_0; now rewrite fib_SSn, N.add_comm.
Qed.

(* begin snippet TimeFibMul2 *)
Time Compute fib_mul2 87.
(* end snippet TimeFibMul2 *)

(* begin snippet fibPos *)
Definition fib_pos n :=
  let (a,b) := Pos_bpow (M:= Mul2) (1,0) n in
  (a+b).

Compute fib_pos xH.
Compute fib_pos 10%positive.

Time Compute fib_pos 153%positive.
(* end snippet fibPos *)

Locate chain_apply.
About chain_apply.

(* begin snippet fibEuclDemo *)
Definition fib_eucl gamma `{Hgamma: Strategy gamma} n :=
  let c := make_chain gamma  n
  in let r := chain_apply c (M:=Mul2) (1,0) in
       fst r + snd r.

Time Compute fib_eucl dicho  153.
Time Compute fib_eucl two  153.
Time Compute fib_eucl half 153.
(* end snippet fibEuclDemo *)

(*  68330027629092351019822533679447
     : N
Finished transaction in 0.002 secs (0.002u,0.s) (successful)
*)

Require Import AM.
Definition fib_with_chain c :=
  match chain_apply c  Mul2 (1,0) with
    Some ((a,b), nil) => Some (a+b) | _ => None end.

Definition c153 := chain_gen dicho (gen_F 153%positive).

Compute c153.

(*
  = (PUSH :: SQR :: SQR :: SQR :: MUL :: PUSH ::
     SQR :: SQR :: SQR :: SQR :: MUL :: nil)%list
     : code

*)
(* number of multiplications and squares *)

Compute mults_squares c153.

Compute fib_with_chain c153 .

(*
 = Some 68330027629092351019822533679447
     : option N
*)

Compute mults_squares (chain_gen dicho (gen_F 30000%positive)).

(*   = (6%nat, 13%nat)
     : nat * nat  *)


Require Import Bool Arith List Cpdt.CpdtTactics.
Set Implicit Arguments.
Set Asymmetric Patterns.
Require Extraction.

(** Arithmetic Expression Over Natural Numbers **)

(* Source Language *)

Inductive binop : Set := Plus | Times.

Inductive exp : Set :=
| Const : nat -> exp
| Binop : binop -> exp -> exp -> exp.

Definition binopDenote (b : binop) : nat -> nat -> nat :=
  match b with
  | Plus => plus
  | Times => mult
  end.

Fixpoint expDenote (e : exp) : nat :=
  match e with
  | Const n => n
  | Binop b e1 e2 =>
    (binopDenote b) (expDenote e1) (expDenote e2)
  end.

(* Target Language *)

Inductive instr : Set :=
| iConst : nat -> instr
| iBinop : binop -> instr
.

Definition prog := list instr.

Definition stack := list nat.

Definition instrDenote (i : instr) (s : stack): option stack :=
  match i with
  | iConst n => Some (n :: s)
  | iBinop b =>
    match s with
    | arg1 :: arg2 :: s' =>
      Some ((binopDenote b) arg1 arg2 :: s')
    | _ => None
    end
  end.

Fixpoint progDenote (p : prog) (s : stack) : option stack :=
  match p with
  | nil => Some s
  | i :: p' =>
    match instrDenote i s with
    | None => None
    | Some s' => progDenote p' s'
    end
  end.

(* Translation *)

Fixpoint compile (e : exp) : prog :=
  match e with
  | Const n => iConst n :: nil
  | Binop b e1 e2 =>
    compile e2 ++ compile e1 ++ iBinop b :: nil
  end.

Eval simpl in compile (Binop Plus (Const 2) (Const 3)).

(* Translation Correctness *)

Lemma compile_correct' : forall e p s, progDenote (compile e ++ p) s = progDenote p (expDenote e :: s).
Proof.
  induction e; crush.
Qed.

Theorem compile_correct : forall e, progDenote (compile e) nil = Some (expDenote e :: nil).
Proof.
  intros.
  rewrite (app_nil_end (compile e)).
  rewrite compile_correct'.
  reflexivity.
Qed.

(** Typed Expressions **)

(* Source Language *)

Inductive type : Set := Nat | Bool.

Inductive tbinop : type -> type -> type -> Set :=
| TPlus : tbinop Nat Nat Nat
| TTimes : tbinop Nat Nat Nat
| TEq : forall t, tbinop t t Bool
| TLt : tbinop Nat Nat Bool.

Inductive texp : type -> Set :=
| TNConst : nat -> texp Nat
| TBConst : bool -> texp Bool
| TBinop : forall t1 t2 t, tbinop t1 t2 t -> texp t1 -> texp t2 -> texp t.

Definition typeDenote (t : type) : Set :=
  match t with
  | Nat => nat
  | Bool => bool
  end.

Definition tbinopDenote arg1 arg2 res (b : tbinop arg1 arg2 res)
  : typeDenote arg1 -> typeDenote arg2 -> typeDenote res :=
  match b with
    | TPlus => plus
    | TTimes => mult
    | TEq Nat => beq_nat
    | TEq Bool => eqb
    | TLt => leb
  end.

Fixpoint texpDenote t (e : texp t) : typeDenote t :=
  match e with
  | TNConst n => n
  | TBConst b => b
  | TBinop _ _ _ b e1 e2 =>
    (tbinopDenote b) (texpDenote e1) (texpDenote e2)
  end.

Eval simpl in texpDenote (TBinop TTimes (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)).

(* Target Language *)

Definition tstack := list type.

Inductive tinstr : tstack -> tstack -> Set :=
| TiNConst : forall s, nat -> tinstr s (Nat :: s)
| TiBConst : forall s, bool -> tinstr s (Bool :: s)
| TiBinop : forall arg1 arg2 res s,
    tbinop arg1 arg2 res -> tinstr (arg1 :: arg2 :: s) (res :: s).

Inductive tprog : tstack -> tstack -> Set :=
| TNil : forall s, tprog s s
| TCons : forall s1 s2 s3,
    tinstr s1 s2
  -> tprog s2 s3
  -> tprog s1 s3.

Fixpoint vstack (ts : tstack) : Set :=
  match ts with
  | nil => unit
  | t :: ts' => typeDenote t * (vstack ts')
  end%type. (* %type as an instruction to Coq's extensible parser *)

Definition tinstrDenote ts ts' (i : tinstr ts ts') : vstack ts -> vstack ts' :=
  match i with
  | TiNConst _ n => fun s => (n, s)
  | TiBConst _ b => fun s => (b, s)
  | TiBinop _ _ _ _ b => fun s =>
    let '(arg1, (arg2, s')) := s in (* destruct multi-level tuple *)
      ((tbinopDenote b) arg1 arg2, s')
  end.

Fixpoint tprogDenote ts ts' (p : tprog ts ts') : vstack ts -> vstack ts' :=
  match p with
  | TNil _ => fun s => s
  | TCons _ _ _ i p' => fun s => tprogDenote p' (tinstrDenote i s)
  end.

(* Translation *)

Fixpoint tconcat ts ts' ts'' (p : tprog ts ts') : tprog ts' ts'' -> tprog ts ts'' :=
  match p with
  | TNil _ => fun p' => p'
  | TCons _ _ _ i p1 => fun p' => TCons i (tconcat p1 p')
  end.

Fixpoint tcompile t (e : texp t) (ts : tstack) : tprog ts (t :: ts) :=
  match e with
    | TNConst n => TCons (TiNConst _ n) (TNil _)
    | TBConst b => TCons (TiBConst _ b) (TNil _)
    | TBinop _ _ _ b e1 e2 => tconcat (tcompile e2 _)
      (tconcat (tcompile e1 _) (TCons (TiBinop _ b) (TNil _)))
  end.

(* This could work *)
(*
Definition tcompile :=
  fix tcompile (t : type) (e : texp t) (ts : tstack) {struct e} : tprog ts (t :: ts) :=
    match e in (texp t) return (tprog ts (t :: ts)) with
    | TNConst n => TCons (TiNConst ts n) (TNil (Nat :: ts))
    | TBConst b => TCons (TiBConst ts b) (TNil (Bool :: ts))
    | TBinop t1 t2 t0 b e1 e2 =>
      tconcat (tcompile t2 e2 ts)
              (tconcat (tcompile t1 e1 (t2 :: ts)) (TCons (TiBinop ts b) (TNil (t0 :: ts))))
    end.
*)

(* TODO: this doesn't work -- dependent pattern matching *)
(*
Fixpoint tcompile (t : type) (e : texp t) (ts : tstack) {struct e} : tprog ts (t :: ts) :=
  match e in (texp t) return (tprog ts (t :: ts)) with
  | TNConst n => TCons (TiNConst ts n) (TNil (Nat :: ts))
  | TBConst b => TCons (TiBConst _ b) (TNil _)
  | TBinop arg1 arg2 res b e1 e2 =>
    tconcat (tcompile arg2 e2 ts)
            (tconcat (tcompile arg1 e1 (arg2 :: ts))
                     (TCons (TiBinop ts b) (TNil (res :: ts))))
  end.
 *)

Eval simpl in tcompile (TBinop TTimes (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)).
Eval simpl in tprogDenote (tcompile (TBinop TTimes (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)) nil) tt.

(* Translation correctness *)

Lemma tconcat_correct : forall ts ts' ts'' (p : tprog ts ts') (p' : tprog ts' ts'') (s : vstack ts),
    tprogDenote (tconcat p p') s = tprogDenote p' (tprogDenote p s).
Proof.
  induction p; crush.
Qed.

Hint Rewrite tconcat_correct.

(* Strengthed induction hypothesis *)
Lemma tcompile_correct' : forall t (e : texp t) ts (s : vstack ts),
    tprogDenote (tcompile e ts) s = (texpDenote e, s).
Proof.
  induction e; crush.
Qed.

Hint Rewrite tcompile_correct'.

Theorem tcompile_correct : forall t (e : texp t),
    tprogDenote (tcompile e nil) tt = (texpDenote e, tt).
Proof.
  crush.
Qed.

Extraction tcompile.


(*
 * Divisibility rules.
 * E.g., an integer is divisible by 9 iff the sum of its digits are.
 *)

From Coq Require Import
  ZArith.
From FunProofs.Lib Require Import
  Series
  Util
  ZipMap.

Open Scope Z.
Import ZSum ZAltSum.

Definition Z_of_digits (ds : list Z) : Z :=
  sum (zipMap Z.mul ds (rev (tens (length ds)))).

Lemma Z_of_digits_mod ds m (n := Z_of_digits ds) :
  m <> 0 ->
  n mod m = sum (zipMap
    (fun x y => (x * y) mod m)
    (map (fun x => x mod m) ds)
    (map (fun y => y mod m) (rev (tens (length ds))))) mod m.
Proof.
  intros; subst n.
  rewrite <- zipMap_split.
  unfold Z_of_digits, zipMap.
  rewrite sum_mod, map_map by easy.
  erewrite map_ext with (g := fun xy => _); auto.
  intros; rewrite Z.mul_mod by easy; eauto.
Qed.

Section Div9.
  Lemma sum_digs_9_congr ds (n := Z_of_digits ds) : n mod 9 = (sum ds) mod 9.
  Proof.
    subst n; rewrite Z_of_digits_mod by easy.
    unfold tens; rewrite map_rev, (geom_mod _ 1), geom_one, map_repeat, rev_repeat
      by easy.
    rewrite zipMap_repeat_r, map_map by (now rewrite map_length).
    erewrite map_ext with (g := fun x => _).
    2: now intros; rewrite Z.mul_1_r, Z.mod_mod.
    symmetry; now apply sum_mod.
  Qed.

  Corollary divisibility_9 ds (n := Z_of_digits ds) : (9 | n) <-> (9 | sum ds).
  Proof. subst n; now rewrite <- !Z.mod_divide, sum_digs_9_congr. Qed.
End Div9.

Section Div3.
  Corollary sum_digs_3_congr ds (n := Z_of_digits ds) : n mod 3 = (sum ds) mod 3.
  Proof.
    apply mod_mul_congr with (m := 3); try easy.
    apply sum_digs_9_congr.
  Qed.

  Corollary divisibility_3 ds (n := Z_of_digits ds) : (3 | n) <-> (3 | sum ds).
  Proof. subst n; now rewrite <- !Z.mod_divide, sum_digs_3_congr. Qed.
End Div3.

Section Div11.
  Lemma altsum_digs_11_congr ds (n := Z_of_digits ds) :
    n mod 11 = (altsum (rev ds)) mod 11.
  Proof.
    subst n; rewrite Z_of_digits_mod by easy.
    rewrite <- sum_rev, zipMap_rev, <- !map_rev, rev_involutive.
    2: unfold tens; now rewrite !map_length, rev_length, geom_length.
    unfold tens; rewrite map_rev, (geom_mod _ (-1)), geom_none by easy.
    rewrite <- map_rev, <- zipMap_split.
    erewrite map_ext with (g := fun xy => _).
    2: intros; rewrite <- Z.mul_mod by easy; eauto.
    unfold altsum; rewrite (sum_mod (altmap _ _)) by easy.
    unfold ZSumOps.Tmodulo, ZAltSumOps.Topp, ZSumOps.T in *.
    do 2 f_equal.
    apply list_eq_pointwise; intros.
    assert (n < length ds \/ n >= length ds)%nat as [|] by lia.
    - match goal with
      | |- nth_error (map _ ?x) n = nth_error (map _ ?y) n =>
        assert (exists a b, nth_error x n = Some a /\ nth_error y n = Some b)
          as (? & ? & Hnth & Hnth')
      end.
      { match goal with
        | |- exists _ _, ?x = _ /\ ?y = _ => assert (x <> None /\ y <> None)
        end.
        { split; apply nth_error_Some;
            rewrite ?combine_length, altmap_length, rev_length, ?repeat_length; lia.
        }
        now destruct (nth_error _ _), (nth_error _); eauto.
      }
      erewrite !map_nth_error; eauto.
      rewrite Hnth'; f_equal.
      apply combine_nth_error in Hnth as (Hnth1 & Hnth2).
      2: rewrite altmap_length, rev_length, repeat_length; auto.
      assert (Hrep: nth_error (repeat 1 (length ds)) n = Some 1)
        by (rewrite repeat_nth; auto).
      apply altmap_nth_error with (f := Z.opp) in Hrep.
      apply altmap_nth_error with (f := Z.opp) in Hnth1.
      assert (Nat.Even n -> Nat.Odd n -> False).
      { rewrite <- Nat.even_spec, <- Nat.odd_spec.
        unfold Nat.odd; now destruct (Nat.even _).
      }
      rewrite Hnth', Hnth2 in *.
      destruct Hnth1 as [(? & ?) | (? & ?)], Hrep as [(? & ?) | (? & ?)]; intuition;
        simplify.
      + replace (snd _) with 1 by auto; lia.
      + replace (snd _) with (-1) by auto; lia.
    - match goal with
      | |- ?x = ?y => enough (x = None /\ y = None) as (? & ?) by congruence
      end.
      split; apply nth_error_None;
        rewrite map_length, ?combine_length, altmap_length, rev_length, ?repeat_length;
        lia.
  Qed.

  Corollary divisibility_11 ds (n := Z_of_digits ds) :
    (11 | n) <-> (11 | altsum (rev ds)).
  Proof. subst n; now rewrite <- !Z.mod_divide, altsum_digs_11_congr. Qed.
End Div11.

Section Div2.
  Lemma last_dig_even_congr ds (n := Z_of_digits ds) : n mod 2 = (last ds 0) mod 2.
  Proof.
    subst n; rewrite Z_of_digits_mod by easy.
    assert (ds = [] \/ 0 < length ds)%nat as [|]
      by (destruct ds; cbn; intuition lia); [subst; auto |].
    unfold tens; rewrite map_rev, (geom_mod _ 0), geom_zero, map_cons, map_repeat
      by easy.
    rewrite (@app_removelast_last _ ds 0) at 1 by (now destruct ds).
    rewrite map_app; cbn [rev]; rewrite rev_repeat, zipMap_app; auto.
    2: now rewrite map_length, repeat_length, removelast_length.
    rewrite zipMap_repeat_r by (now rewrite map_length, removelast_length).
    erewrite map_map, map_ext with (g := fun x => _).
    2: now intros; rewrite Z.mul_0_r; cbn.
    rewrite map_const, removelast_length, sum_app0, sum_repeat; cbn.
    now rewrite Z.mul_1_r, !Z.mod_mod.
  Qed.

  Lemma divisibility_2 ds (n := Z_of_digits ds) : (2 | n) <-> (2 | last ds 0).
  Proof. intros; subst n; now rewrite <- !Z.mod_divide, last_dig_even_congr. Qed.
End Div2.


(** * Rel: Properties of Relations *)

Require Export SfLib.

(** This short, optional chapter develops some basic definitions and a
    few theorems about binary relations in Coq.  The key definitions
    are repeated where they are actually used (in the [Smallstep]
    chapter), so readers who are already comfortable with these ideas
    can safely skim or skip this chapter.  However, relations are also
    a good source of exercises for developing facility with Coq's
    basic reasoning facilities, so it may be useful to look at it just
    after the [Logic] chapter. *)

(** A (binary) _relation_ on a set [X] is a family of propositions
    parameterized by two elements of [X] -- i.e., a proposition about
    pairs of elements of [X].  *)

Definition relation (X: Type) := X->X->Prop.

(** Somewhat confusingly, the Coq standard library hijacks the generic
    term "relation" for this specific instance. To maintain
    consistency with the library, we will do the same.  So, henceforth
    the Coq identifier [relation] will always refer to a binary
    relation between some set and itself, while the English word
    "relation" can refer either to the specific Coq concept or the
    more general concept of a relation between any number of possibly
    different sets.  The context of the discussion should always make
    clear which is meant. *)

(** An example relation on [nat] is [le], the less-than-or-equal-to
    relation which we usually write like this [n1 <= n2]. *)

Print le.
(* ====> Inductive le (n : nat) : nat -> Prop :=
             le_n : n <= n
           | le_S : forall m : nat, n <= m -> n <= S m *)
Check le : nat -> nat -> Prop.
Check le : relation nat.

(* ######################################################### *)
(** * Basic Properties of Relations *)

(** As anyone knows who has taken an undergraduate discrete math
    course, there is a lot to be said about relations in general --
    ways of classifying relations (are they reflexive, transitive,
    etc.), theorems that can be proved generically about classes of
    relations, constructions that build one relation from another,
    etc.  For example... *)

(** A relation [R] on a set [X] is a _partial function_ if, for every
    [x], there is at most one [y] such that [R x y] -- i.e., if [R x
    y1] and [R x y2] together imply [y1 = y2]. *)

Definition partial_function {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

(** For example, the [next_nat] relation defined earlier is a partial
    function. *)

Print next_nat.
(* ====> Inductive next_nat (n : nat) : nat -> Prop :=
           nn : next_nat n (S n) *)
Check next_nat : relation nat.

Theorem next_nat_partial_function :
   partial_function next_nat.
Proof.
  unfold partial_function.
  intros x y1 y2 H1 H2.
  inversion H1. inversion H2.
  reflexivity.  Qed.

(** However, the [<=] relation on numbers is not a partial function.
    In short: Assume, for a contradiction, that [<=] is a partial
    function.  But then, since [0 <= 0] and [0 <= 1], it follows that
    [0 = 1].  This is nonsense, so our assumption was
    contradictory. *)

Theorem le_not_a_partial_function :
  ~ (partial_function le).
Proof.
  unfold not. unfold partial_function. intros Hc.
  assert (0 = 1) as Nonsense.
  { (* Proof of assertion *)
    apply Hc with (x := 0).
    - apply le_n.
    - apply le_S. apply le_n. }
  inversion Nonsense.   Qed.

(** **** Exercise: 2 stars, optional  *)
(** Show that the [total_relation] defined in earlier is not a partial
    function. *)

Theorem total_relation_not_a_partial_function :
  ~ (partial_function total_relation).
Proof.
  unfold not. unfold partial_function. intros Hc.
  assert (0 = 1) as Nonsense.
  { (* Proof of assertion *)
    apply Hc with (x := 0).
    - apply tot.
    - apply tot. }
  inversion Nonsense.
Qed.

(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 2 stars, optional  *)
(** Show that the [empty_relation] defined earlier is a partial
    function. *)

Theorem  empty_relation_is_a_partial_function :
  partial_function empty_relation.
Proof.
  unfold partial_function.
  intros.
  inversion H0.
Qed.
(** [] *)

(** A _reflexive_ relation on a set [X] is one for which every element
    of [X] is related to itself. *)

Definition reflexive {X: Type} (R: relation X) :=
  forall a : X, R a a.

Theorem le_reflexive :
  reflexive le.
Proof.
  unfold reflexive. intros n. apply le_n.  Qed.

(** A relation [R] is _transitive_ if [R a c] holds whenever [R a b]
    and [R b c] do. *)

Definition transitive {X: Type} (R: relation X) :=
  forall a b c : X, (R a b) -> (R b c) -> (R a c).

Theorem le_trans :
  transitive le.
Proof.
  intros n m o Hnm Hmo.
  induction Hmo.
  - (* le_n *) apply Hnm.
  - (* le_S *) apply le_S. apply IHHmo.  Qed.

Theorem lt_trans:
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  apply le_S in Hnm.
  apply le_trans with (a := (S n)) (b := (S m)) (c := o).
  apply Hnm.
  apply Hmo. Qed.

(** **** Exercise: 2 stars, optional  *)
(** We can also prove [lt_trans] more laboriously by induction,
    without using le_trans.  Do this.*)

Theorem lt_trans' :
  transitive lt.
Proof.
  (* Prove this by induction on evidence that [m] is less than [o]. *)
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction Hmo as [| m' Hm'o].
    (* FILL IN HERE *)
  - apply le_S. apply Hnm.
  - apply le_trans with (a := (S n)) (b := (S m)) (c := (S m')).
    + apply le_S.  apply Hnm.
    + apply le_S. apply Hm'o.
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional  *)
(** Prove the same thing again by induction on [o]. *)

Theorem lt_trans'' :
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction o as [| o'].
  (* FILL IN HERE *) Admitted.
(** [] *)

(** The transitivity of [le], in turn, can be used to prove some facts
    that will be useful later (e.g., for the proof of antisymmetry
    below)... *)

Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
Proof.
  intros n m H. apply le_trans with (S n).
    apply le_S. apply le_n.
    apply H.  Qed.

(** **** Exercise: 1 star, optional  *)
Theorem le_S_n : forall n m,
  (S n <= S m) -> (n <= m).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (le_Sn_n_inf)  *)
(** Provide an informal proof of the following theorem:

    Theorem: For every [n], [~(S n <= n)]

    A formal proof of this is an optional exercise below, but try
    the informal proof without doing the formal proof first.

    Proof:
    (* FILL IN HERE *)
    []
 *)

(** **** Exercise: 1 star, optional  *)
Theorem le_Sn_n : forall n,
  ~ (S n <= n).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Reflexivity and transitivity are the main concepts we'll need for
    later chapters, but, for a bit of additional practice working with
    relations in Coq, here are a few more common ones.

   A relation [R] is _symmetric_ if [R a b] implies [R b a]. *)

Definition symmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a).

(** **** Exercise: 2 stars, optional 8 *)
Theorem le_not_symmetric :
  ~ (symmetric le).
Proof.
  unfold not. unfold symmetric. intros.
  assert (1 <= 0) as Nonsense.
  { apply H. apply le_S. apply le_n. }
  inversion Nonsense.
Qed.
(** [] *)

(** A relation [R] is _antisymmetric_ if [R a b] and [R b a] together
    imply [a = b] -- that is, if the only "cycles" in [R] are trivial
    ones. *)

Definition antisymmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a) -> a = b.

(** **** Exercise: 2 stars, optional 9 *)
Theorem le_antisymmetric :
  antisymmetric le.
Proof.
  unfold antisymmetric.
  intros a.
  induction a.
  - intros. destruct b.
    + reflexivity.
    + inversion H0.
  - intros.
    inversion H.
    + reflexivity.
    + inversion H0.
      * rewrite <- H2 in H3. rewrite H3. reflexivity.
      * apply eq_S. apply IHa.
        {
           apply le_Sn_le. apply H1.
        }
        {
           rewrite <- H2 in H0. apply le_Sn_le. rewrite H2. apply H4.
        }
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional  *)
Theorem le_step : forall n m p,
  n < m ->
  m <= S p ->
  n <= p.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** A relation is an _equivalence_ if it's reflexive, symmetric, and
    transitive.  *)

Definition equivalence {X:Type} (R: relation X) :=
  (reflexive R) /\ (symmetric R) /\ (transitive R).

(** A relation is a _partial order_ when it's reflexive,
    _anti_-symmetric, and transitive.  In the Coq standard library
    it's called just "order" for short. *)

Definition order {X:Type} (R: relation X) :=
  (reflexive R) /\ (antisymmetric R) /\ (transitive R).

(** A preorder is almost like a partial order, but doesn't have to be
    antisymmetric. *)

Definition preorder {X:Type} (R: relation X) :=
  (reflexive R) /\ (transitive R).

Theorem le_order :
  order le.
Proof.
  unfold order. split.
    - (* refl *) apply le_reflexive.
    - split.
      + (* antisym *) apply le_antisymmetric.
      + (* transitive. *) apply le_trans.  Qed.

(* ########################################################### *)
(** * Reflexive, Transitive Closure *)

(** The _reflexive, transitive closure_ of a relation [R] is the
    smallest relation that contains [R] and that is both reflexive and
    transitive.  Formally, it is defined like this in the Relations
    module of the Coq standard library: *)

Inductive clos_refl_trans {A: Type} (R: relation A) : relation A :=
    | rt_step : forall x y, R x y -> clos_refl_trans R x y
    | rt_refl : forall x, clos_refl_trans R x x
    | rt_trans : forall x y z,
          clos_refl_trans R x y ->
          clos_refl_trans R y z ->
          clos_refl_trans R x z.

(** For example, the reflexive and transitive closure of the
    [next_nat] relation coincides with the [le] relation. *)

Theorem next_nat_closure_is_le : forall n m,
  (n <= m) <-> ((clos_refl_trans next_nat) n m).
Proof.
  intros n m. split.
    - (* -> *)
      intro H. induction H.
      + (* le_n *) apply rt_refl.
      + (* le_S *)
        apply rt_trans with m. apply IHle. apply rt_step. apply nn.
    - (* <- *)
      intro H. induction H.
      + (* rt_step *) inversion H. apply le_S. apply le_n.
      + (* rt_refl *) apply le_n.
      + (* rt_trans *)
        apply le_trans with y.
        apply IHclos_refl_trans1.
        apply IHclos_refl_trans2. Qed.

(** The above definition of reflexive, transitive closure is
    natural -- it says, explicitly, that the reflexive and transitive
    closure of [R] is the least relation that includes [R] and that is
    closed under rules of reflexivity and transitivity.  But it turns
    out that this definition is not very convenient for doing
    proofs -- the "nondeterminism" of the [rt_trans] rule can sometimes
    lead to tricky inductions.

    Here is a more useful definition... *)

Inductive refl_step_closure {X:Type} (R: relation X) : relation X :=
  | rsc_refl  : forall (x : X), refl_step_closure R x x
  | rsc_step : forall (x y z : X),
                    R x y ->
                    refl_step_closure R y z ->
                    refl_step_closure R x z.

(** (Note that, aside from the naming of the constructors, this
    definition is the same as the [multi] step relation used in many
    other chapters.) *)

(** Our new definition of reflexive, transitive closure "bundles"
    the [rt_step] and [rt_trans] rules into the single rule step.
    The left-hand premise of this step is a single use of [R],
    leading to a much simpler induction principle.

    Before we go on, we should check that the two definitions do
    indeed define the same relation...

    First, we prove two lemmas showing that [refl_step_closure] mimics
    the behavior of the two "missing" [clos_refl_trans]
    constructors.  *)

Theorem rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> refl_step_closure R x y.
Proof.
  intros X R x y H.
  apply rsc_step with y. apply H. apply rsc_refl.   Qed.

(** **** Exercise: 2 stars, optional (rsc_trans)  *)
Theorem rsc_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      refl_step_closure R x y  ->
      refl_step_closure R y z ->
      refl_step_closure R x z.
Proof.
  intros.
  induction H.
  - apply H0.
  - apply rsc_step with y.
    * apply H.
    *  apply IHrefl_step_closure. apply H0.
Qed.
(** [] *)

(** Then we use these facts to prove that the two definitions of
    reflexive, transitive closure do indeed define the same
    relation. *)

(** **** Exercise: 3 stars, optional (rtc_rsc_coincide)  *)
Theorem rtc_rsc_coincide :
         forall (X:Type) (R: relation X) (x y : X),
  clos_refl_trans R x y <-> refl_step_closure R x y.
Proof.
  split.
  - intros. induction H.
    + apply rsc_step with y.
      * apply H.
      * apply rsc_refl.
    + apply rsc_refl.
    + apply rsc_trans with y.
      * apply IHclos_refl_trans1.
      * apply IHclos_refl_trans2.
  - intros.  induction H.
    + apply rt_refl.
    + apply rt_trans with y.
      * apply rt_step. apply H.
      * apply IHrefl_step_closure.
Qed.
(** [] *)

(** $Date: 2015-08-10 18:00:14 +0200 (Mon, 10 Aug 2015) $ *)