(***
  Boolean Unification Type Declarations.
  Authors:
    Joseph St. Pierre
    Spyridon Antonatos
***)

(*** Required Libraries ***)
Require Import Bool.
Require Import Omega.
Require Import EqNat.
Require Import List.
Require Import Setoid.
Import ListNotations.

(** * Introduction **)

(** In order for any proofs to be constructed in Coq, we need to formally define
    the logic and data across which said proofs will operate. Since the heart of
    our analysis is concerned with the unification of Boolean equations, it
    stands to reason that we should articulate precisely how algebra functions
    with respect to Boolean rings. To attain this, we shall formalize what an
    equation looks like, how it can be composed inductively, and also how
    substitutions behave when applied to equations. *)

(** * Terms **)

(** ** Definitions **)

(** We shall now begin describing the rules of Boolean arithmetic as well as the
    nature of Boolean equations. *)

(** Define a variable to be a natural number *)

Definition var := nat.

(** A _term_, as has already been previously described, is now inductively
    declared to hold either a constant value, a single variable, a sum of terms,
    or a product of terms. *)

Inductive term: Type :=
  | T0  : term
  | T1  : term
  | VAR  : var -> term
  | SUM : term -> term -> term
  | PRODUCT : term -> term -> term.

(** For convenience's sake, we define some shorthanded notation for readability.
    *)

Implicit Types x y z : term.
Implicit Types n m : var.

Notation "x + y" := (SUM x y) (at level 50, left associativity).
Notation "x * y" := (PRODUCT x y) (at level 40, left associativity).

(** ** Axioms *)

(** Now that we have informed Coq on the nature of what a term is, it is now
    time to propose a set of axioms that will articulate exactly how algebra
    behaves across Boolean rings. This is a requirement since the very act of
    unifying an equation is intimately related to solving it algebraically. Each
    of the axioms proposed below describe the rules of Boolean algebra precisely
    and in an unambiguous manner. None of these should come as a surprise to the
    reader; however, if one is not familiar with this form of logic, the rules
    regarding the summation and multiplication of identical terms might pose as
    a source of confusion.

    For reasons of keeping Coq's internal logic consistent, we roll our own
    custom equivalence relation as opposed to simply using "=". This will
    provide a surefire way to avoid any odd errors from later cropping up in our
    proofs. Of course, by doing this we introduce some implications that we will
    need to address later. *)

Parameter eqv : term -> term -> Prop.

(**  Here we introduce some special notation for term equivalence *)

Infix " == " := eqv (at level 70).

(** Below is the set of fundamental axioms concerning the equivalence "=="
    relation. They form the boolean ring (or system) on which Lowenheim's
    formula and proof are developed.

    Most of these axioms will appear familiar to anyone; however, certain ones
    such as the summation of two identical terms are true only across Boolean
    rings and as such might appear strange at first glance. *)

Axiom sum_comm : forall x y, x + y == y + x.

Axiom sum_assoc : forall x y z, (x + y) + z == x + (y + z).

Axiom sum_id : forall x, T0 + x == x.

(** Across boolean rings, the summation of two terms will always be 0 because
    there are only two elements in the ring: 0 and 1. For this reason, the
    mapping of [1 + 1] has nowhere else to go besides 0. *)

Axiom sum_x_x : forall x, x + x == T0.

Axiom mul_comm : forall x y, x * y == y * x.

Axiom mul_assoc : forall x y z, (x * y) * z == x * (y * z).

(** Across boolean rings, the multiplication of two identical terms will always
    be the same as just having one instance of said term. This is because
    $0 \ast 0 = 0$ and $1 \ast 1 = 1$ as one would expect normally. *)

Axiom mul_x_x : forall x, x * x == x.

Axiom mul_T0_x : forall x, T0 * x == T0.

Axiom mul_id : forall x, T1 * x == x.

Axiom distr : forall x y z, x * (y + z) == (x * y) + (x * z).

(** Any axioms beyond this point of the development are not considered part of
    the "fundamental axiom system", but they still need to exist for the
    development and proofs to hold. *)

(** Across all equations, adding an expression to both sides does not break the
    equivalence of the relation. *)

Axiom term_sum_symmetric :
  forall x y z, x == y <-> x + z == y + z.

Axiom refl_comm :
  forall t1 t2, t1 == t2 -> t2 == t1.

Axiom T1_not_equiv_T0 :
  ~(T1 == T0).

Hint Resolve sum_comm sum_assoc sum_x_x sum_id distr
             mul_comm mul_assoc mul_x_x mul_T0_x mul_id.

(** Now that the core axioms have been taken care of, we need to handle the
    implications posed by our custom equivalence relation. Below we inform Coq
    of the behavior of our equivalence relation with respect to reflexivity,
    symmetry, and transitivity in order to allow for rewrites during the
    construction of proofs operating across our new equivalence relation. *)

(* Mundane coq magic for custom equivalence relation *)

Axiom eqv_ref : Reflexive eqv.
Axiom eqv_sym : Symmetric eqv.
Axiom eqv_trans : Transitive eqv.

Add Parametric Relation : term eqv
  reflexivity proved by @eqv_ref
  symmetry proved by @eqv_sym
  transitivity proved by @eqv_trans
  as eq_set_rel.

Axiom SUM_compat :
  forall x x', x == x' ->
  forall y y', y == y' ->
    (x + y) == (x' + y').

Axiom PRODUCT_compat :
  forall x x', x == x' ->
  forall y y', y == y' ->
    (x * y) == (x' * y').

Add Parametric Morphism : SUM with
  signature eqv ==> eqv ==> eqv as SUM_mor.
Proof.
exact SUM_compat.
Qed.

Add Parametric Morphism : PRODUCT with
  signature eqv ==> eqv ==> eqv as PRODUCT_mor.
Proof.
exact PRODUCT_compat.
Qed.

Hint Resolve eqv_ref eqv_sym eqv_trans SUM_compat PRODUCT_compat.

(** ** Lemmas **)

(** Since Coq now understands the basics of Boolean algebra, it serves as a good
    exercise for us to generate some further rules using Coq's proving systems.
    By doing this, not only do we gain some additional tools that will become
    handy later down the road, but we also test whether our axioms are behaving
    as we would like them to. *)

(** This is a lemma for a sub-case of term multiplication. *)

Lemma mul_x_x_plus_T1 :
  forall x, x * (x + T1) == T0.
Proof.
  intros. rewrite distr. rewrite mul_x_x. rewrite mul_comm.
  rewrite mul_id. apply sum_x_x.
Qed.

(** This is a lemma to convert term equivalence to equivalence between their
    addition and ground term [T0], and vice-versa. *)

Lemma x_equal_y_x_plus_y :
  forall x y, x == y <-> x + y == T0.
Proof.
  intros. split.
  - intros. rewrite H. rewrite sum_x_x. reflexivity.
  - intros. rewrite term_sum_symmetric with (y := y) (z := y). rewrite sum_x_x.
    apply H.
Qed.

Hint Resolve mul_x_x_plus_T1 x_equal_y_x_plus_y.

(** These lemmas just serve to make certain rewrites regarding the core axioms
    less tedious to write. While one could certainly argue that they should be
    formulated as axioms and not lemmas due to their triviality, being pedantic
    is a good exercise. *)

(** This is a lemma for identity addition between term and ground term [T0]. *)

Lemma sum_id_sym :
  forall x, x + T0 == x.
Proof.
  intros. rewrite sum_comm. apply sum_id.
Qed.

(** Here is a lemma for identity multiplication between term and ground term
    [T1]. *)

Lemma mul_id_sym :
  forall x, x * T1 == x.
Proof.
  intros. rewrite mul_comm. apply mul_id.
Qed.

(** This is a lemma for multiplication between term and ground term [T0]. *)

Lemma mul_T0_x_sym :
  forall x, x * T0 == T0.
Proof.
  intros. rewrite mul_comm. apply mul_T0_x.
Qed.

Lemma sum_assoc_opp :
 forall x y z, x + (y + z) == (x + y) + z.
Proof.
  intros. rewrite sum_assoc. reflexivity.
Qed.

Lemma mul_assoc_opp :
 forall x y z, x * (y * z) == (x * y) * z.
Proof.
  intros. rewrite mul_assoc. reflexivity.
Qed.

Lemma distr_opp :
 forall x y z, x * y  +  x * z == x * ( y + z).
Proof.
  intros. rewrite distr. reflexivity.
Qed.

(** * Variable Sets **)

(** Now that the underlying behavior concerning Boolean algebra has been
    properly articulated to Coq, it is now time to begin formalizing the logic
    surrounding our meta reasoning of Boolean equations and systems. While there
    are certainly several approaches to begin this process, we thought it best
    to ease into things through formalizing the notion of a set of variables
    present in an equation. *)

(** ** Definitions **)

(** We now define a _variable set_ to be precisely a list of variables;
    additionally, we include several functions for including and excluding
    variables from these variable sets. Furthermore, since uniqueness is not a
    property guaranteed by Coq lists and it has the potential to be desirable,
    we define a function that consumes a variable set and removes duplicate
    entries from it. For convenience, we also provide several examples to
    demonstrate the functionalities of these new definitions. *)

(** Here is a definition of the new type to represent a list (set) of variables
    (natural numbers). *)

Definition var_set := list var.
Implicit Type vars: var_set.

(** Here is a simple function to check to see if a variable is in a variable
    set. *)

Fixpoint var_set_includes_var (v : var) (vars : var_set) : bool :=
  match vars with
  | nil => false
  | n :: n' => if (beq_nat v n) then true
                                else var_set_includes_var v n'
  end.

(** Here is a function to remove all instances of var [v] from a list of vars.
    *)

Fixpoint var_set_remove_var (v : var) (vars : var_set) : var_set :=
  match vars with
  | nil => nil
  | n :: n' => if (beq_nat v n) then (var_set_remove_var v n')
                                else n :: (var_set_remove_var v n')
  end.

(** Next is a function to return a unique [var_set] without duplicates. Found
    vars should be empty for correctness guarantee. *)

Fixpoint var_set_create_unique (vars : var_set): var_set :=
  match vars with
  | nil => nil
  | n :: n' =>
    if (var_set_includes_var n n') then var_set_create_unique n'
                                   else n :: var_set_create_unique n'
  end.

(** This is a function to check if a given var_set is unique. *)

Fixpoint var_set_is_unique (vars : var_set): bool :=
  match vars with
  | nil => true
  | n :: n' =>
    if (var_set_includes_var n n') then false
                                   else var_set_is_unique n'
  end.

(** This is a function to get the variables of a term as a var_set. *)

Fixpoint term_vars (t : term) : var_set :=
  match t with
  | T0 => nil
  | T1 => nil
  | VAR x => x :: nil
  | PRODUCT x y => (term_vars x) ++ (term_vars y)
  | SUM x y => (term_vars x) ++ (term_vars y)
  end.

(** This is a function to generate a list of unique variables that make up a
    given term. *)

Definition term_unique_vars (t : term) : var_set :=
  var_set_create_unique (term_vars t).

(** ** Helper Lemmas for variable sets and lists *)

(** Now that we have established the functionality for variable sets, let us
    prove some properties about them. *)

Lemma vs_includes_true : forall (x : var) (lvar : list var),
  var_set_includes_var x lvar = true -> In x lvar.
Proof.
  intros.
  induction lvar.
  - simpl; intros. discriminate.
  - simpl in H. remember (beq_nat x a) as H2. destruct H2.
    + simpl. left. symmetry in HeqH2. pose proof beq_nat_true as H7.
      specialize (H7 x a HeqH2). symmetry in H7. apply H7.
    + specialize (IHlvar H). simpl. right. apply IHlvar.
Qed.

Lemma vs_includes_false : forall (x : var) (lvar : list var),
  var_set_includes_var x lvar = false -> ~ In x lvar.
Proof.
  intros.
  induction lvar.
  - simpl; intros. unfold not. intros. destruct H0.
  - simpl in H. remember (beq_nat x a) as H2. destruct H2. inversion H.
    specialize (IHlvar H). firstorder. intuition. apply IHlvar. simpl in H0.
    destruct H0.
    + inversion HeqH2. symmetry in H2. pose proof beq_nat_false as H7.
      specialize (H7 x a H2). rewrite H0 in H7. destruct H7. intuition.
    + apply H0.
Qed.

Lemma in_dup_and_non_dup : forall (x: var) (lvar : list var),
  In x lvar <-> In x (var_set_create_unique lvar).
Proof.
  intros. split.
  - induction lvar.
    + intros. simpl in H. destruct H.
    + intros. simpl. remember (var_set_includes_var a lvar) as C. destruct C.
      * symmetry in HeqC. pose proof vs_includes_true as H7.
        specialize (H7 a lvar HeqC). simpl in H. destruct H.
        -- rewrite H in H7. specialize (IHlvar H7). apply IHlvar.
        -- specialize (IHlvar H). apply IHlvar.
      * symmetry in HeqC. pose proof vs_includes_false as H7.
        specialize (H7 a lvar HeqC). simpl in H. destruct H.
        -- simpl. left. apply H.
        -- specialize (IHlvar H). simpl. right. apply IHlvar.
  - induction lvar.
    + intros. simpl in H. destruct H.
    + intros. simpl in H. remember (var_set_includes_var a lvar) as C.
      destruct C.
      * symmetry in HeqC. pose proof vs_includes_true as H7.
        specialize (H7 a lvar HeqC). specialize (IHlvar H). simpl.
        right. apply IHlvar.
      * symmetry in HeqC. pose proof vs_includes_false as H7.
        specialize (H7 a lvar HeqC). simpl in H. destruct H.
        -- simpl.  left. apply H.
        -- specialize (IHlvar H).  simpl. right. apply IHlvar.
Qed.

(** ** Examples **)

(** Below are some examples of the behaviors of variable sets. *)

Example var_set_create_unique_ex1 :
  var_set_create_unique [0;5;2;1;1;2;2;9;5;3] = [0;1;2;9;5;3].
Proof.
  simpl. reflexivity.
Qed.

Example var_set_is_unique_ex1 :
  var_set_is_unique [0;2;2;2] = false.
Proof.
  simpl. reflexivity.
Qed.

(** Here are examples to demonstrate the correctness of the function [term_vars]
    on specific cases. *)

Example term_vars_ex1 :
  term_vars (VAR 0 + VAR 0 + VAR 1) = [0;0;1].
Proof.
  simpl. reflexivity.
Qed.

Example term_vars_ex2 :
  In 0 (term_vars (VAR 0 + VAR 0 + VAR 1)).
Proof.
  simpl. left. reflexivity.
Qed.

(** * Ground Terms **)

(** Seeing as we just outlined the definition of a variable set, it seems fair
    to now formalize the definition of a ground term, or in other words, a term
    that has no variables and whose variable set is the empty set. *)

(** ** Definitions **)

(** A _ground term_ is a recursively defined proposition that is only true if
    and only if no variable appears in it; otherwise it will be a false
    proposition and no longer a ground term. *)

(** In this subsection we declare definitions related to ground terms, inluding
    functions and lemmas. *)

(** This is a function to check if a given term is a ground term (i.e. has no
    vars). *)

Fixpoint ground_term (t : term) : Prop :=
  match t with
    | VAR x => False
    | SUM x y => ground_term x /\ ground_term y
    | PRODUCT x y => ground_term x /\ ground_term y
    | _ => True
  end.

(** ** Lemmas **)

(** Our first real lemma (shown below), articulates an important property of
    ground terms: all ground terms are equvialent to either 0 or 1. This curious
    property is a direct result of the fact that these terms possess no
    variables and additioanlly because of the axioms of Boolean algebra. *)

(** This is a lemma (trivial, intuitively true) that proves that if the function
    [ground_term] returns true then it is either [T0] or [T1]. *)

Lemma ground_term_equiv_T0_T1 : forall x,
  ground_term x -> x == T0 \/ x == T1.
Proof.
  intros. induction x.
  - left. reflexivity.
  - right. reflexivity.
  - contradiction.
  - inversion H. destruct IHx1; destruct IHx2; auto. rewrite H2. left.
    rewrite sum_id. apply H3. rewrite H2. rewrite H3. rewrite sum_id. right.
    reflexivity. rewrite H2. rewrite H3. right. rewrite sum_comm.
    rewrite sum_id. reflexivity. rewrite H2. rewrite H3. rewrite sum_x_x. left.
    reflexivity.
  - inversion H. destruct IHx1; destruct IHx2; auto. rewrite H2. left.
    rewrite mul_T0_x. reflexivity. rewrite H2. left. rewrite mul_T0_x.
    reflexivity. rewrite H3. left. rewrite mul_comm. rewrite mul_T0_x.
    reflexivity. rewrite H2. rewrite H3. right. rewrite mul_id. reflexivity.
Qed.

(** This lemma, while intuitively obvious by definition, nonetheless provides a
    formal bridge between the world of ground terms and the world of variable
    sets. *)

Lemma ground_term_has_empty_var_set : forall x,
  ground_term x -> term_vars x = [].
Proof.
  intros. induction x.
  - simpl. reflexivity.
  - simpl. reflexivity.
  - contradiction.
  - firstorder. unfold term_vars. unfold term_vars in H2. rewrite H2.
    unfold term_vars in H1. rewrite H1. simpl. reflexivity.
  - firstorder. unfold term_vars. unfold term_vars in H2. rewrite H2.
    unfold term_vars in H1. rewrite H1. simpl. reflexivity.
Qed.

(** ** Examples **)

(** Here are some examples to show that our ground term definition is working
    appropriately. *)

Example ex_gt1 :
  ground_term (T0 + T1).
Proof.
  simpl. split.
  - reflexivity.
  - reflexivity.
Qed.

Example ex_gt2 :
  ground_term (VAR 0 * T1) -> False.
Proof.
  simpl. intros. destruct H. apply H.
Qed.

(** * Substitutions **)

(** It is at this point in our Coq development that we begin to officially
    define the principal action around which the entirety of our efforts are
    centered: the act of substituting variables with other terms. While
    substitutions alone are not of great interest, their emergent properties as
    in the case of whether or not a given substitution unifies an equation are
    of substantial importance to our later research. *)

(** ** Definitions **)

(** In this subsection we make the fundamental definitions of substitutions,
    basic functions for them, accompanying lemmas and some propsitions. *)

(** Here we define a _substitution_ to be a list of ordered pairs where each
    pair represents a variable being mapped to a term. For sake of clarity these
    ordered pairs shall be referred to as _replacements_ from now on and as a
    result, substitutions should really be considered to be lists of
    replacements. *)

Definition replacement := prod var term.

(** We define a new type [susbt] to represent a substitution as a list of
    replacements. *)

Definition subst := list replacement.

Implicit Type s : subst.

(** Our first function, [find_replacement], is an auxilliary to [apply_subst].
    This function will search through a substitution for a specific variable,
    and if found, returns the variable's associated term. *)

Fixpoint find_replacement (x : var) (s : subst) : term :=
  match s with
  | nil => VAR x
  | r :: r' =>
      if beq_nat (fst r) x then snd r
                           else find_replacement x r'
  end.

(** The [apply_subst] function will take a term and a substitution and will
    produce a new term reflecting the changes made to the original one. *)

Fixpoint apply_subst (t : term) (s : subst) : term :=
  match t with
  | T0 => T0
  | T1 => T1
  | VAR x => find_replacement x s
  | PRODUCT x y => PRODUCT (apply_subst x s) (apply_subst y s)
  | SUM x y => SUM (apply_subst x s) (apply_subst y s)
  end.

(** For reasons of completeness, it is useful to be able to generate _identity
    substitutions_; namely, substitutions that map the variables of a term to
    themselves. *)

(** This is a function when given a list of variables builds a list of
    identity substitutions - one for each variable. *)

Fixpoint build_id_subst (lvar : var_set) : subst :=
  match lvar with
  | nil => nil
  | v :: v' => (v , (VAR v)) :: build_id_subst v'
  end.

(** Since we now have the ability to generate identity substitutions, we should
    now formalize a general proposition for testing whether or not a given
    substitution is an identity substitution of a given term. *)

Definition subst_equiv (s1 s2: subst) : Prop :=
  forall t, apply_subst t s1 == apply_subst t s2.

Definition subst_is_id_subst (t : term) (s : subst) : Prop :=
  apply_subst t s == t.

(** Given we now have definitions for substitutions, we should now introduce the
    idea of a substitution composing another one. *)

Fixpoint subst_compose (s s' : subst) : subst :=
  match s' with
  | [] => s
  | (x, t) :: s'' => (x, apply_subst t s) :: (subst_compose s s'')
  end.

(** Here we define the domain of a substituion, namely the list of variables for
    which the substitution has a mapping (replacement). Essentially this acts as
    a list of all the first parts of the replacement. *)

Definition subst_domain (sig : subst) : list var :=
  map (fun r => (fst r)) sig.

(** We define the concept of a sub list. If an element is a member of a list,
    it is then a member of the other list as well. *)

Definition sub_dmn_list (l1 : list var) (l2 : list var) : Prop :=
 forall (x : var), In x l1 -> In x l2.

(** ** Helper Lemmas for the [apply_subst] function **)

(** Having now outlined the functionality of a subsitution, let us now begin to
    analyze some implications of its form and composition by proving some
    lemmas. *)

(** Given that we have a definition for identity substitutions, we should prove
    that identity substitutions do not modify a term. *)

Lemma id_subst: forall (t : term) (l : var_set),
  apply_subst t (build_id_subst l) == t.
Proof.
  intros. induction t.
  - simpl. reflexivity.
  - simpl. reflexivity.
  - simpl. induction l.
    + simpl. reflexivity.
    + simpl. destruct (beq_nat a v) eqn: e.
      * apply beq_nat_true in e. rewrite e. reflexivity.
      * apply IHl.
  - simpl. rewrite IHt1. rewrite IHt2. reflexivity.
  - simpl. rewrite IHt1. rewrite IHt2. reflexivity.
Qed.

(** These are helper lemmes for the [apply_subst] properties. *)

Lemma sum_comm_compat t1 t2: forall (sigma: subst),
  apply_subst (t1 + t2) sigma == apply_subst (t2 + t1) sigma.
Proof.
  intros. simpl. auto.
Qed.
Hint Resolve sum_comm_compat.

Lemma sum_assoc_compat t1 t2 t3: forall (sigma: subst),
  apply_subst ((t1 + t2) + t3) sigma == apply_subst (t1 + (t2 + t3)) sigma.
Proof.
  intros. simpl. auto.
Qed.
Hint Resolve sum_assoc_compat.

Lemma sum_id_compat t: forall (sigma: subst),
  apply_subst (T0 + t) sigma == apply_subst t sigma.
Proof.
  intros. simpl. auto.
Qed.
Hint Resolve sum_id_compat.

Lemma sum_x_x_compat t: forall (sigma: subst),
  apply_subst (t + t) sigma == apply_subst T0 sigma.
Proof.
  intros. simpl. auto.
Qed.
Hint Resolve sum_x_x_compat.

Lemma mul_comm_compat t1 t2: forall (sigma: subst),
  apply_subst (t1 * t2) sigma == apply_subst (t2 * t1) sigma.
Proof.
  intros. simpl. auto.
Qed.
Hint Resolve mul_comm_compat.

Lemma mul_assoc_compat t1 t2 t3: forall (sigma: subst),
  apply_subst ((t1 * t2) * t3) sigma == apply_subst (t1 * (t2 * t3)) sigma.
Proof.
  intros. simpl. auto.
Qed.
Hint Resolve mul_assoc_compat.

Lemma mul_x_x_compat t: forall (sigma: subst),
  apply_subst (t * t) sigma == apply_subst t sigma.
Proof.
  intros. simpl. auto.
Qed.
Hint Resolve mul_x_x_compat.

Lemma mul_T0_x_compat t: forall (sigma: subst),
  apply_subst (T0 * t) sigma == apply_subst T0 sigma.
Proof.
  intros. simpl. auto.
Qed.
Hint Resolve mul_T0_x_compat.

Lemma mul_id_compat t: forall (sigma: subst),
  apply_subst (T1 * t) sigma == apply_subst t sigma.
Proof.
  intros. simpl. auto.
Qed.
Hint Resolve mul_id_compat.

Lemma distr_compat t1 t2 t3: forall (sigma: subst),
  apply_subst (t1 * (t2 + t3)) sigma ==
  apply_subst ((t1 * t2) + (t1 * t3)) sigma.
Proof.
  intros. simpl. auto.
Qed.
Hint Resolve distr_compat.

Lemma refl_comm_compat t1 t2: forall (sigma: subst),
  apply_subst t1 sigma == apply_subst t2 sigma ->
  apply_subst t2 sigma == apply_subst t1 sigma.
Proof.
  intros. simpl. auto.
Qed.
Hint Resolve refl_comm_compat.

Lemma trans_compat t1 t2 t3 : forall (sigma: subst),
  apply_subst t1 sigma == apply_subst t2 sigma ->
  apply_subst t2 sigma == apply_subst t3 sigma ->
  apply_subst t1 sigma == apply_subst t3 sigma.
Proof.
  intros. eauto.
Qed.
Hint Resolve trans_compat.

Lemma trans_compat2 c1 c2 c3 :
  c1 == c2 ->
  c2 == c3 ->
  c1 == c3.
Proof.
  intros. eauto.
Qed.

(** This is an axiom that states that if two terms are equivalent then applying
    any substitution on them will also produce equivalent terms. The reason we
    axiomatized this and we did not prove it as a lemma is because the set of
    our fundamental axioms is not an inductive relation, so it would be
    impossible to prove the lemma below with our fundamental axioms in the
    currrent format. *)

Axiom apply_subst_compat : forall (t t' : term),
  t == t' ->
  forall (sigma: subst), apply_subst t sigma == apply_subst t' sigma.

Add Parametric Morphism : apply_subst with
      signature eqv ==> eq ==> eqv as apply_subst_mor.
Proof.
  exact apply_subst_compat.
Qed.

(** This is a simple lemma that states that an empty substitution cannot modify
    a term. *)

Lemma subst_empty_no_change :
  forall (t : term), (apply_subst t []) == t.
Proof.
  intros. induction t.
  - simpl. reflexivity.
  - simpl. reflexivity.
  - simpl. reflexivity.
  - simpl. rewrite IHt1. rewrite IHt2. reflexivity.
  - simpl. rewrite IHt1. rewrite IHt2. reflexivity.
Qed.

(** An intuitive thing to prove for ground terms is that they cannot be modified
    by applying substitutions to them. This will later prove to be very relevant
    when we begin to talk about unification. *)

(** This is a helpful lemma for showing substitutions do not affect ground
    terms. *)

Lemma ground_term_cannot_subst : forall x,
  ground_term x ->
  forall s, apply_subst x s == x.
Proof.
  intros. induction s.
  - apply ground_term_equiv_T0_T1 in H. destruct H.
    + rewrite H. simpl. reflexivity.
    + rewrite H. simpl. reflexivity.
  - apply ground_term_equiv_T0_T1 in H. destruct H. rewrite H.
    + simpl. reflexivity.
    + rewrite H. simpl. reflexivity.
Qed.

(** A fundamental property of substitutions is their distributivity across the
    summation and multiplication of terms. Again the importance of these proofs
    will not become apparent until we talk about unification. *)

(** This is a useful lemma for showing the distributivity of substitutions
    across term summation. *)

Lemma subst_sum_distribution : forall s x y,
  apply_subst x s + apply_subst y s == apply_subst (x + y) s.
Proof.
  intro. induction s.
  - simpl. intros. reflexivity.
  - intros. simpl. reflexivity.
Qed.

(** This is a lemma to prove the distributivity of the [apply_subst] function
    across term multiplication. *)

Lemma subst_mul_distribution : forall s x y,
  apply_subst x s * apply_subst y s == apply_subst (x * y) s.
Proof.
  intro. induction s.
  - intros. reflexivity.
  - intros. simpl. reflexivity.
Qed.

(** Here is a lemma to prove the opposite of summation distributivity of the
    [apply_subst] function across term summation. *)

Lemma subst_sum_distr_opp : forall s x y,
  apply_subst (x + y) s == apply_subst x s + apply_subst y s.
Proof.
  intros.
  apply refl_comm.
  apply subst_sum_distribution.
Qed.

(** This is a lemma to prove the opposite of multiplication distributivity of
    the [apply_subst] function across term summation. *)

Lemma subst_mul_distr_opp : forall s x y,
  apply_subst (x * y) s == apply_subst x s * apply_subst y s.
Proof.
  intros.
  apply refl_comm.
  apply subst_mul_distribution.
Qed.

(** This is an intutitive lemmas to apply a single replacement substitution on a
    VAR term. *)

Lemma var_subst: forall (v : var) (ts : term),
  apply_subst (VAR v) [(v , ts)] == ts.
Proof.
  intros. simpl. destruct (beq_nat v v) eqn: e.
  - apply beq_nat_true in e. reflexivity.
  - apply beq_nat_false in e. firstorder.
Qed.

(** ** Examples **)

(** Here are some examples showcasing the nature of applying substitutions to
    terms. *)

Example subst_ex1 :
  apply_subst (T0 + T1) [] == T0 + T1.
Proof.
  intros. reflexivity.
Qed.

Example subst_ex2 :
  apply_subst (VAR 0 * VAR 1) [(0, T0)] == T0.
Proof.
  intros. simpl. apply mul_T0_x.
Qed.

(** ** Auxillary Definitions for Substitutions and Terms *)

(** In this section we define more helper functions and lemmas related to
    substitutions and ground terms. Specifically we are defining a ground term,
    a ground substitution, a "01" term, a "01" substitution, and a substitution
    composition. A [ground_term] is a term with no variables in it.
    The terms that are used more in the future proofs are the "01"
    term and "01" substitution. A "01" term is a term that is either exaclty
    equal to [T0] or [T1]. A "01" substitution is a substitution in which each
    variable (or the first part of each replacement) is mapped to a "01" term. A
    "01" term is not necessarily a ground term (but it might be) and a "01"
    substitution is not necessarily a ground substitution (but it might be). In
    the proof file, we are mostly using the "01" term and substitution
    terminology.
*)

(** We define a proposition for a [ground_subst]. A substitution is ground when
    in all of its replacements, the second part is a [ground_term]. *)

Fixpoint ground_subst (sig : subst) : Prop :=
  match sig with
  | [] => True
  | r :: r' => ground_term (snd r) /\ ground_subst r'
  end.

(** This is a function to determine whether a term is a ground term, by
    returning a boolean. *)

Fixpoint is_ground_term (t : term) : bool :=
  match t with
  | T0 => true
  | T1 => true
  | VAR x => false
  | SUM a b => (is_ground_term a) && (is_ground_term b)
  | PRODUCT a b => (is_ground_term a) && (is_ground_term b)
  end.

(** This is a function to determine whether a subsitution is a ground
    substitution, by returning a boolean. *)

Fixpoint is_ground_subst (sig : subst) : bool :=
  existsb is_ground_term (map snd sig).

(** This is a function to determine whether a term is a [T0] or [T1] term by
    returning a boolean. *)

Definition is_01_term (t : term) : bool :=
  match t with
  | T0 => true
  | T1 => true
  | _ => false
  end.

(** This is a function to determine whether a substitution is a "01"
    substitution by returning a boolean, meaning that each second part of every
    replacement is either a [T0] or a [T1] term. *)

Fixpoint is_01_subst (sig : subst) : bool :=
  existsb is_01_term (map snd sig).

(** This is a function to determine whether a term is a [T0] or [T1] term by
    returning a proposition. *)

Fixpoint _01_term (t : term) : Prop :=
  match t with
  | T0 => True
  | T1 => True
  | _ => False
  end.

(** This is a function to determine whether a substitution is a "01"
    substitution by returning a proposition, meaning that each second part of
    every replacement is either a [T0] or a [T1] term. *)

Fixpoint _01_subst (sig : subst) : Prop :=
  match sig with
  | [] => True
  | r :: r' => _01_term (snd r) /\ _01_subst r'
  end.

(** * Unification **)

(** Now that we have established the concept of term substitutions in Coq, it is
    time for us to formally define the concept of Boolean unification.
    _Unification_, in its most literal sense, refers to the act of applying a
    substitution to terms in order to make them equivalent to each other. In
    other words, to say that two terms are _unifiable_ is to really say that
    there exists a substitution such that the two terms are equal. Interestingly
    enough, we can abstract this concept further to simply saying that a single
    term is unifiable if there exists a substitution such that the term will be
    equivalent to [0]. By doing this abstraction, we can prove that equation
    solving and unification are essentially the same fundamental problem. *)

(** Below is the initial definition for unification, namely that two terms can
    be unified to be equivalent to one another. By starting here we will show
    each step towards abstracting unification to refer to a single term. *)

(**  Proposition that a given substitution unifies (namely, makes equivalent),
    two given terms *)

Definition unifies (a b : term) (s : subst) : Prop :=
  apply_subst a s == apply_subst b s.

(** Here is a simple example demonstrating the concept of testing whether two
    terms are unified by a substitution. *)

Example ex_unif1 :
  unifies (VAR 0) (VAR 1) [(0, T1); (1, T1)].
Proof.
  unfold unifies. simpl. reflexivity.
Qed.

(** Now we are going to show that moving both terms to one side of the
    equivalence relation through addition does not change the concept of
    unification. *)

(** This is a proposition that a given substitution makes equivalent the sum of
    two terms when the substitution is applied to each of them, and ground term
    [T0]. *)

Definition unifies_T0 (a b : term) (s : subst) : Prop :=
  apply_subst a s + apply_subst b s == T0.

(** This is a lemma that proves that finding a unifier for [x = y] is the same
    as finding a unifier for [x + y = 0]. *)

Lemma unifies_T0_equiv : forall x y s,
  unifies x y s <-> unifies_T0 x y s.
Proof.
  intros. split.
  - intros. unfold unifies_T0. unfold unifies in H. rewrite H.
    rewrite sum_x_x. reflexivity.
  - intros. unfold unifies_T0 in H. unfold unifies.
    rewrite term_sum_symmetric with (x := apply_subst x s + apply_subst y s)
    (z := apply_subst y s) in H. rewrite sum_id in H.
    rewrite sum_comm in H.
    rewrite sum_comm with (y := apply_subst y s) in H.
    rewrite <- sum_assoc in H.
    rewrite sum_x_x in H.
    rewrite sum_id in H.
    apply H.
Qed.

(** Now we can define what it means for a substitution to be a unifier for a
    given term. *)

(** Here is a proposition that a given substitution unifies a given term, namely
    it makes it equivalent with [T0]. *)

Definition unifier (t : term) (s : subst) : Prop :=
  apply_subst t s == T0.

Example unifier_ex1 :
  unifier (VAR 0) [(0, T0)].
Proof.
  unfold unifier. simpl. reflexivity.
Qed.

(** To ensure our efforts were not in vain, let us now prove that this last
    abstraction of the unification problem is still equivalent to the original.
    *)

(** This is a lemma that proves that the unifier proposition can distributes
    over addition of terms. *)

Lemma unifier_distribution : forall x y s,
  unifies_T0 x y s <-> unifier (x + y) s.
Proof.
  intros. split.
  - intros. unfold unifies_T0 in H. unfold unifier.
    rewrite <- H. symmetry. apply subst_sum_distribution.
  - intros. unfold unifies_T0. unfold unifier in H.
    rewrite <- H. apply subst_sum_distribution.
Qed.

(** Lastly let us define a term to be unifiable if there exists a substitution
    that unifies it. *)

(** This is a proposition that states when a term is unifiable. *)

Definition unifiable (t : term) : Prop :=
  exists s, unifier t s.

Example unifiable_ex1 :
  exists x, unifiable (x + T1).
Proof.
  exists T1. unfold unifiable. unfold unifier.
  exists []. simpl. rewrite sum_x_x. reflexivity.
Qed.

(** * Most General Unifier **)

(** In this subsection we define propositions, lemmas and examples related to
    the most general unifier. *)

(** While the property of a term being unifiable is certainly important, it
    should come as no surprise that not all unifiers are created equal; in fact,
    certain unifiers possess the desirable property of being _more general_ than
    others. For this reason, let us now formally define the concept of a _most
    general unifier_ (mgu): a unifier such that with respect to a given term,
    all other unifiers are instances of it, or in other words, less general than
    it. *)

(** The first step towards establishing the concept of a mgu requires us to
    formalize the notion of a unifier being more general than another. To
    accomplish this goal, let us formulate the definition of a substitution
    composing another one; or in other words, to say that a substitution is more
    general than another one. *)

(** This is a proposition of sequential substition application. *)

Definition substitution_factor_through (s s' delta : subst) : Prop :=
  forall (x : var), apply_subst (apply_subst (VAR x) s) delta ==
                    apply_subst (VAR x) s' .

(** This is the definition of a more general substition. *)

Definition more_general_substitution (s s': subst) : Prop :=
  exists delta, substitution_factor_through s s' delta .

(** Now that we have articulated the concept of composing substitutions, let us
    now formulate the definition for a most general unifier. *)

(** This is the definition of a Most General Unifier (mgu): A Most General
    Unifier (MGU) takes in a term and a substitution and tells whether or not
    said substitution is an mgu for the given term. *)

Definition most_general_unifier (t : term) (s : subst) : Prop :=
  unifier t s /\
  forall (s' : subst),
  unifier t s' ->
  more_general_substitution s s'.

(** While this definition of a most general unifier is certainly valid, we can
    also characterize a unifier by other similar properties. For this reason,
    let us now define an alternative definition called a _reproductive unifier_,
    and then prove it to be equivalent to our definition of a most general
    unifier. This will make our proofs easier to formulate down the road as the
    task of proving a unifier to be reproductive is substantially easier than
    proving it to be most general directly. *)

Definition reproductive_unifier (t : term) (sig : subst) : Prop :=
  unifier t sig /\
  forall (tau : subst) (x : var),
  unifier t tau ->
  apply_subst (apply_subst (VAR x) sig ) tau == apply_subst (VAR x) tau.

(** This is a lemma to show that a reproductive unifier is a most general
    unifier. Since the ultimate goal is to prove that a specific algorithm
    produces an mgu then if we could prove it is a reproductive unifier then we
    could use this lemma to arrive at the desired conclusion. *)

Lemma reproductive_is_mgu : forall (t : term) (u : subst),
  reproductive_unifier t u ->
  most_general_unifier t u.
Proof.
  intros. unfold most_general_unifier. unfold reproductive_unifier in H.
  unfold more_general_substitution . destruct H. split.
  - apply H.
  - intros. specialize (H0 s'). exists s'. unfold substitution_factor_through.
    intros. specialize (H0 x).
    specialize (H0 H1). apply H0.
Qed.

(** This is a lemma to show that if two terms are equivalent then for any
    subsitution that is an mgu of one of the terms, then it is an mgu of the
    other term as well. *)

Lemma most_general_unifier_compat : forall  (t t' : term),
  t == t' ->
  forall (sigma: subst),
  most_general_unifier t sigma <-> most_general_unifier t' sigma.
Proof.
  intros. split.
  - intros. unfold most_general_unifier. unfold unifier in H0.
    unfold unifier in *. split.
    + unfold most_general_unifier in H0. destruct H0. unfold unifier in H0.
      rewrite H in H0. apply H0.
    + intros. unfold most_general_unifier in H0. destruct H0.
      specialize (H2 s'). unfold unifier in H0. symmetry in H. rewrite H in H1.
      unfold unifier in H2. specialize (H2 H1). apply H2.
  - unfold most_general_unifier.  intros. destruct H0 . split.
    + symmetry in H. unfold unifier in H0.  rewrite H in H0. unfold unifier.
      apply H0.
    + intros. specialize (H1 s'). unfold unifier in H2. rewrite H in H2.
      unfold unifier in H1. specialize (H1 H2). apply H1.
Qed.

(** * Auxilliary Computational Operations and Simplifications *)

(** These functions below will come in handy later during the Lowenheim formula
    proof. They mainly lay the groundwork for providing the computational nuts
    and bolts for Lowenheim's algorithm for finding most general unifiers and
    initial ground unifiers. *)

(*  alternate defintion of functions related to term operations and evaluations
    that take into consideration more sub-cases *)

(** This is a function to check if two terms are exaclty identical. *)

Fixpoint identical (a b: term) : bool :=
  match a , b with
  | T0, T0 => true
  | T0, _ => false
  | T1 , T1 => true
  | T1 , _ => false
  | VAR x , VAR y => if beq_nat x y then true else false
  | VAR x, _ => false
  | PRODUCT x y, PRODUCT x1 y1 => identical x x1 && identical y y1
  | PRODUCT x y, _ => false
  | SUM x y, SUM x1 y1 => identical x x1 && identical y y1
  | SUM x y, _ => false
  end.

(** This is basic addition for terms. *)

Definition plus_one_step (a b : term) : term :=
  match a, b with
  | T0, T0 => T0
  | T0, T1 => T1
  | T1, T0 => T1
  | T1 , T1 => T0
  | _ , _ => SUM a b
  end.

(** This is basic multiplication for terms. *)

Definition mult_one_step (a b : term) : term :=
  match a, b with
  | T0, T0 => T0
  | T0, T1 => T0
  | T1, T0 => T0
  | T1 , T1 => T1
  | _ , _ => PRODUCT a b
  end.

(** This is a function to simplify a term in very apparent and basic ways. They
    are only simplified if they are ground terms. *)

Fixpoint simplify (t : term) : term :=
  match t with
  | T0 => T0
  | T1 => T1
  | VAR x => VAR x
  | PRODUCT x y => mult_one_step (simplify x) (simplify y)
  | SUM x y => plus_one_step (simplify x) (simplify y)
  end.

(** Some lemmas follow to prove intuitive facts for the basic multiplication and
    addition of terms, leading up to proving the [simplify_eqv] lemma. *)

Lemma pos_left_sum_compat : forall (t t1 t2 : term),
  t == t1 -> plus_one_step t1 t2 == plus_one_step t t2.
Proof.
  intros. induction t1.
  - induction t.
    + reflexivity.
    + apply T1_not_equiv_T0 in H. inversion H.
    + induction t2.
      * simpl. rewrite H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite H. rewrite sum_id. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite H. rewrite sum_id. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite H. rewrite sum_id. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
  - induction t.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. reflexivity.
      * simpl. reflexivity.
      * simpl. reflexivity.
      * simpl. reflexivity.
      * simpl. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite sum_comm. rewrite sum_id. reflexivity.
      * simpl. rewrite H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite sum_comm. rewrite sum_id. reflexivity.
      * simpl. rewrite H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite sum_comm. rewrite sum_id. reflexivity.
      * simpl. rewrite H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
  - induction t.
    + induction t2.
      * simpl. rewrite H. rewrite sum_x_x. rewrite H. reflexivity.
      * simpl. rewrite <- H. rewrite sum_id. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite <- H. rewrite sum_comm. rewrite sum_id. reflexivity.
      * simpl. rewrite H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
  - induction t.
    + induction t2.
      * simpl. rewrite <- H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite <- H. rewrite sum_id. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite <- H. rewrite sum_comm. rewrite sum_id. reflexivity.
      * simpl. rewrite H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
 - induction t.
    + induction t2.
      * simpl. rewrite <- H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite <- H. rewrite sum_id. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite <- H. rewrite sum_comm. rewrite sum_id. reflexivity.
      * simpl. rewrite H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
Qed.

Lemma pos_right_sum_compat : forall  (t t1 t2 : term),
     t == t2 -> plus_one_step t1 t2 == plus_one_step t1 t.
Proof.
intros. induction t1.
  - induction t.
    + induction t2.
      * simpl. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. rewrite sum_x_x. apply H.
      * simpl. rewrite <- H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite <- H. rewrite sum_x_x. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. reflexivity.
      * simpl. rewrite H. rewrite sum_id. reflexivity.
      * simpl. rewrite H. rewrite sum_id. reflexivity.
      * simpl. rewrite <- H. rewrite sum_id. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite H. rewrite sum_id. reflexivity.
      * simpl. rewrite H. rewrite sum_id. reflexivity.
      * simpl. rewrite H. rewrite sum_id. reflexivity.
      * simpl. rewrite <- H. rewrite sum_id. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite H. rewrite sum_id. reflexivity.
      * simpl. rewrite H. rewrite sum_id. reflexivity.
      * simpl. rewrite H. rewrite sum_id. reflexivity.
      * simpl. rewrite <- H. rewrite sum_id. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite H. rewrite sum_id. reflexivity.
      * simpl. rewrite H. rewrite sum_id. reflexivity.
      * simpl. rewrite H. rewrite sum_id. reflexivity.
      * simpl. rewrite <- H. rewrite sum_id. reflexivity.
  - induction t.
    + induction t2.
      * simpl. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. rewrite sum_comm. rewrite sum_id. reflexivity.
      * simpl. rewrite <- H. rewrite sum_comm. rewrite sum_id. reflexivity.
      * simpl. rewrite <- H. rewrite sum_comm. rewrite sum_id. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. reflexivity.
      * simpl. rewrite H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite <- H. rewrite sum_x_x. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite sum_comm. rewrite sum_id. reflexivity.
      * simpl. rewrite H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite sum_comm. rewrite sum_id. reflexivity.
      * simpl. rewrite H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite sum_comm. rewrite sum_id. reflexivity.
      * simpl. rewrite H. rewrite sum_x_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
  - induction t.
    + induction t2.
      * simpl. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
  - induction t.
    + induction t2.
      * simpl. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
  - induction t.
    + induction t2.
      * simpl. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
Qed.

Lemma pos_left_mul_compat : forall  (t t1 t2 : term),
  t == t1 -> mult_one_step t1 t2 == mult_one_step t t2.
Proof.
  intros. induction t1.
  - induction t.
    + reflexivity.
    + apply T1_not_equiv_T0 in H. inversion H.
    + induction t2.
      * simpl. rewrite H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite H. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite H. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite H. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
  - induction t.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. reflexivity.
      * simpl. reflexivity.
      * simpl. reflexivity.
      * simpl. reflexivity.
      * simpl. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite mul_comm. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite mul_comm. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite mul_comm. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
  - induction t.
    + induction t2.
      * simpl. rewrite H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite <- H. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite <- H. rewrite mul_comm. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
  - induction t.
    + induction t2.
      * simpl. rewrite <- H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite <- H. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite <- H. rewrite mul_comm. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
  - induction t.
    + induction t2.
      * simpl. rewrite <- H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite <- H. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite <- H. rewrite mul_comm. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
Qed.

Lemma pos_right_mul_compat : forall  (t t1 t2 : term),
  t == t2 -> mult_one_step t1 t2 == mult_one_step t1 t.
Proof.
intros. induction t1.
  - induction t.
    + induction t2.
      * simpl. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite <- H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite <- H. rewrite mul_x_x. reflexivity.
    + induction t2.
      * simpl. reflexivity.
      * simpl. reflexivity.
      * simpl. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite mul_T0_x. reflexivity.
    + induction t2.
      * simpl. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite mul_T0_x. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite mul_T0_x. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite mul_T0_x. rewrite mul_T0_x. reflexivity.
    + induction t2.
      * simpl. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite mul_T0_x. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite mul_T0_x. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite mul_T0_x. rewrite mul_T0_x. reflexivity.
    + induction t2.
      * simpl. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite mul_T0_x. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite mul_T0_x. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite mul_T0_x. rewrite mul_T0_x. reflexivity.
  - induction t.
    + induction t2.
      * simpl. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. rewrite mul_comm. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite <- H. rewrite mul_comm. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite <- H. rewrite mul_comm. rewrite mul_T0_x. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. reflexivity.
      * simpl. rewrite H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite <- H. rewrite mul_x_x. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite mul_comm. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite mul_comm. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. rewrite mul_comm. rewrite mul_T0_x. reflexivity.
      * simpl. rewrite H. rewrite mul_x_x. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
  - induction t.
    + induction t2.
      * simpl. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
  - induction t.
    + induction t2.
      * simpl. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
  - induction t.
    + induction t2.
      * simpl. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
    + induction t2.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite H. reflexivity.
      * simpl. rewrite <- H. reflexivity.
Qed.

(** Being able to simplify a term can be a useful tool. Being able to use the
    simplified version of the term as the equivalent version of the original
    term can also be useful since many of our functions simplify the term first.
    *)

Lemma simplify_eqv : forall (t : term),
  simplify t == t.
Proof.
  intros. induction t.
  - simpl. reflexivity.
  - simpl. reflexivity.
  - simpl. reflexivity.
  - simpl. pose proof pos_left_sum_compat.
    specialize (H t1 (simplify t1) (simplify t2)).
    symmetry in IHt1. specialize (H IHt1). rewrite H.
    pose proof pos_right_sum_compat. specialize (H0 (simplify t2) t1 t2).
    specialize (H0 IHt2). symmetry in H0. rewrite H0.
    induction t1.
    + induction t2.
      * simpl. rewrite sum_x_x. reflexivity.
      * simpl. rewrite sum_id. reflexivity.
      * simpl. reflexivity.
      * simpl. reflexivity.
      * simpl. reflexivity.
    + induction t2.
      * simpl. rewrite sum_id_sym. reflexivity.
      * simpl. rewrite sum_x_x. reflexivity.
      * simpl. reflexivity.
      * simpl. reflexivity.
      * simpl. reflexivity.
    + simpl. reflexivity.
    + simpl. reflexivity.
    + simpl. reflexivity.
  - simpl. pose proof pos_left_mul_compat.
    specialize (H t1 (simplify t1) (simplify t2)).
    symmetry in IHt1. specialize (H IHt1). rewrite H.
    pose proof pos_right_mul_compat. specialize (H0 (simplify t2) t1 t2).
    specialize (H0 IHt2). symmetry in H0. rewrite H0.
    induction t1.
    + induction t2.
      * simpl. rewrite mul_x_x. reflexivity.
      * simpl. rewrite mul_T0_x.  reflexivity.
      * simpl. reflexivity.
      * simpl. reflexivity.
      * simpl. reflexivity.
    + induction t2.
      * simpl. rewrite mul_T0_x_sym. reflexivity.
      * simpl. rewrite mul_x_x. reflexivity.
      * simpl. reflexivity.
      * simpl. reflexivity.
      * simpl. reflexivity.
    + simpl. reflexivity.
    + simpl. reflexivity.
    + simpl. reflexivity.
Qed.


Require Import Arith Omega.

Lemma test : forall p:nat, p<>0 -> p-1+1=p.
Proof.
 intros; omega.
Qed.

(** Test of new syntax for rewrite : ! ? and so on... *)

Lemma but : forall a b c, a<>0 -> b<>0 -> c<>0 ->
 (a-1+1)+(b-1+1)+(c-1+1)=a+b+c.
Proof.
intros.
rewrite test.
Undo.
rewrite test,test.
Undo.
rewrite 2 test. (* or rewrite 2test or rewrite 2!test *)
Undo.
rewrite 2!test,2?test.
Undo.
(*rewrite 4!test.  --> error *)
rewrite 3!test.
Undo.
rewrite <- 3?test.
Undo.
(*rewrite <-?test. --> loops*)
rewrite !test by auto.
reflexivity.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_angledistinct.
Require Export GeoCoq.Elements.OriginalProofs.lemma_layoff.
Require Export GeoCoq.Elements.OriginalProofs.lemma_equalanglesNC.
Require Export GeoCoq.Elements.OriginalProofs.lemma_equalangleshelper.
Require Export GeoCoq.Elements.OriginalProofs.proposition_04.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_equalanglestransitive :
   forall A B C D E F P Q R,
   CongA A B C D E F -> CongA D E F P Q R ->
   CongA A B C P Q R.
Proof.
intros.
assert (neq A B) by (forward_using lemma_angledistinct).
assert (neq D E) by (forward_using lemma_angledistinct).
assert (neq B A) by (conclude lemma_inequalitysymmetric).
assert (neq E D) by (conclude lemma_inequalitysymmetric).
assert (neq E F) by (forward_using lemma_angledistinct).
assert (neq B C) by (forward_using lemma_angledistinct).
assert (neq P Q) by (forward_using lemma_angledistinct).
assert (neq Q P) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists U, (Out E D U /\ Cong E U B A)) by (conclude lemma_layoff);destruct Tf as [U];spliter.
let Tf:=fresh in
assert (Tf:exists V, (Out E F V /\ Cong E V B C)) by (conclude lemma_layoff);destruct Tf as [V];spliter.
assert (neq E U) by (conclude lemma_raystrict).
assert (neq E V) by (conclude lemma_raystrict).
assert (CongA P Q R D E F) by (conclude lemma_equalanglessymmetric).
assert (neq Q R) by (forward_using lemma_angledistinct).
let Tf:=fresh in
assert (Tf:exists u, (Out Q P u /\ Cong Q u E U)) by (conclude lemma_layoff);destruct Tf as [u];spliter.
let Tf:=fresh in
assert (Tf:exists v, (Out Q R v /\ Cong Q v E V)) by (conclude lemma_layoff);destruct Tf as [v];spliter.
assert (nCol A B C) by (conclude_def CongA ).
assert (CongA A B C U E V) by (conclude lemma_equalangleshelper).
assert (Cong B A E U) by (conclude lemma_congruencesymmetric).
assert (Cong B C E V) by (conclude lemma_congruencesymmetric).
assert ((Cong A C U V /\ CongA B A C E U V /\ CongA B C A E V U)) by (conclude proposition_04).
assert (Cong E U Q u) by (conclude lemma_congruencesymmetric).
assert (Cong E V Q v) by (conclude lemma_congruencesymmetric).
assert (CongA D E F u Q v) by (conclude lemma_equalangleshelper).
assert (CongA u Q v D E F) by (conclude lemma_equalanglessymmetric).
assert (CongA u Q v U E V) by (conclude lemma_equalangleshelper).
assert (CongA U E V u Q v) by (conclude lemma_equalanglessymmetric).
assert ((Cong U V u v /\ CongA E U V Q u v /\ CongA E V U Q v u)) by (conclude proposition_04).
assert (Cong A C u v) by (conclude lemma_congruencetransitive).
assert (Cong B A Q u) by (conclude lemma_congruencetransitive).
assert (Cong B C Q v) by (conclude lemma_congruencetransitive).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (Out B A A) by (conclude lemma_ray4).
assert (Out B C C) by (conclude lemma_ray4).
assert (CongA A B C P Q R) by (conclude_def CongA ).
close.
Qed.

End Euclid.


(* Exercise coq_list_08 *)

(* Those are the definitions from the previous exercise: *)

Inductive natlist : Set :=
  | nil : natlist
  | cons : nat -> natlist -> natlist.

Fixpoint append (l m : natlist) {struct l} : natlist :=
  match l with
  | nil => m
  | cons x xs => cons x (append xs m)
  end.

Fixpoint reverse (l : natlist) : natlist :=
  match l with
  | nil => nil
  | cons ele rem => append (reverse rem) (cons ele nil)
  end.

(* Now, let us prove that reversing a list twice gives back
   the original list. *)

(* For that we may need the result proven in the previous
   exercise *)
Axiom reverse_append : forall l m,
  reverse (append l m) = append (reverse m) (reverse l).

Lemma reverse_double : forall l, reverse (reverse l) = l.

Proof.
  intros.
  induction l.
  simpl; reflexivity.
  simpl.
  rewrite reverse_append.
  rewrite IHl.
  simpl.
  reflexivity.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (y : natural) (x : natural) (lf1 : natural) : natural :=
  plus (plus x y) lf1.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*             Ralph Matthes [+]                              *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*                             [+] Affiliation IRIT -- CNRS   *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Omega.

Require Import wf_utils llist fifo.

Set Implicit Arguments.

(* We provide an implementation of FIFO as a triple of lazy lists
   satisfying the axioms in fifo.v *)

Module FIFO_3llists <: FIFO.

Section fifo_three_lazy_lists.

  (** From "Simple and Efficient Purely Functional Queues and Deques" by Chris Okasaki
          Journal of Functional Programming 5(4):583-592

      this implements and proves the spec from page 587 with lazy lists
      with invariant (l,r,l') : lazy_length l' + lazy_length r = lazy_length l

      let rec lazy_rotate l r a := match r with
        | lcons y r' -> match l with
          | lnil       -> lcons y a
          | lcons x l' -> lcons x (lazy_rotate l' r' (lcons y a))

      let empty = (lnil,lnil,lnil)

      let make l r l' = match l' with
        | lnil       -> let l' = lazy_rotate l r lnil in (l',lnil,l')
        | lcons _ l' -> (l, r, l')

      let enq (l,r,l') x = make l (lcons x r) l'

      let deq (lcons x l,r,l') = (x,make l r l')

      let void (l,r,n) = l = lnil

    *)

  Variable X : Type.

  Implicit Types (l r : lazy_list X).

  Let Q_spec (c : lazy_list X * lazy_list X * lazy_list X) :=
    match c with (l,r,l') => lazy_length l' + lazy_length r = lazy_length l end.

  Definition fifo := sig Q_spec.

  Implicit Types (q : fifo) (x : X).

  Definition f2l : fifo -> list X.
  Proof.
    intros (((l,r),l') & H).
    exact (lazy2list l ++ rev (lazy2list r)).
  Defined.

  Definition empty : { q | f2l q = nil }.
  Proof.
    assert (H : Q_spec (lazy_nil,lazy_nil,lazy_nil)).
    { red; rewrite lazy_length_nil; auto. }
    exists (exist _ _ H).
    unfold f2l; simpl; auto.
  Defined.

  Definition make l r l' : lazy_length l' + lazy_length r = 1 + lazy_length l -> { m | lazy2list l ++ rev (lazy2list r) = f2l m }.
  Proof.
    induction l' as [ | x l'' _ ] using lazy_list_rect; intros E.
    + rewrite lazy_length_nil in E; simpl in E.
      destruct (lazy_rotate l r lazy_nil E) as (l'' & H'').
      assert (H : Q_spec (l'',lazy_nil,l'')).
      { red; rewrite lazy_length_nil; omega. }
      exists (exist _ _ H).
      unfold Q_spec; simpl.
      rewrite H''; simpl.
      rewrite lazy2list_nil.
      repeat rewrite <- app_nil_end; trivial.
    + assert (H : Q_spec (l,r,l'')).
      { red; rewrite lazy_length_cons in E; omega. }
      exists (exist _ _ H).
      unfold Q_spec; simpl; auto.
  Defined.

  Definition enq : forall q x, { q' | f2l q' = f2l q ++ x :: nil }.
  Proof.
    intros (((l,r),l') & H) x.
    refine (let (m,Hm) := make l (lazy_cons x r) l' _ in _).
    + red in H; rewrite lazy_length_cons; omega.
    + exists m.
      simpl; rewrite <- Hm.
      rewrite lazy2list_cons, app_ass; simpl; auto.
  Defined.

  Definition deq : forall q, f2l q <> nil -> { c : X * fifo | let (x,q') := c in f2l q = x::f2l q' }.
  Proof.
    intros (((l,r),l') & H); revert H; simpl.
    induction l as [ | x l _ ] using lazy_list_rect.
    + induction r as [ | y r _ ] using lazy_list_rect; intros H1 H2; exfalso.
      * destruct H2; rewrite lazy2list_nil; auto.
      * rewrite lazy_length_cons, lazy_length_nil in H1; omega.
    + intros H1 H2.
      refine (let (m,Hm) := @make l r l' _ in _).
      * rewrite lazy_length_cons in H1; omega.
      * exists (x,m).
        rewrite lazy2list_cons; simpl; f_equal; auto.
  Defined.

  Definition void : forall q, { b : bool | b = true <-> f2l q = nil }.
  Proof.
    intros (((l,r),l') & H).
    induction l as [ | x l _ ] using lazy_list_rect; red in H.
    + exists true; simpl.
      split; auto; intros _.
      induction r as [ | y r _ ] using lazy_list_rect.
      * rewrite lazy2list_nil; auto.
      * rewrite lazy_length_cons, lazy_length_nil in H; simpl in H; omega.
    + exists false; simpl.
      split; try discriminate.
      rewrite lazy2list_cons; discriminate.
  Defined.

End fifo_three_lazy_lists.

End FIFO_3llists.


Require Import ZArith.

Definition pos_even_bool (p:positive) : bool :=
  match p with
  | xO _ => true
  | _ => false
  end.

(* Tests :

Compute pos_even_bool 326%positive.

Compute pos_even_bool 3261%positive.

*)


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Ext_Cons.Prod_Cat.Prod_Cat.
Require Import Functor.Main.
Require Import Basic_Cons.Product.

Local Open Scope morphism_scope.

(**
Given two objects a and b the exponential (bᵃ, denoted 'Exponential a b' below)
is intuitively the internal representation of homomorphisms from a to b – it is
sometimes referred to as the internal hom. The notion of exponential is a
generalization of the notion function space from set theory.

Definition: bᵃ is an object equipped with an evaluation function eval: bᵃ×a -> b
such that for any other object z with arrow f : z×a -> b, we have a unique arrow
f^ that makes the following diagram commute:

#
<pre>
               eval
        bᵃ×a ——————————> b
         ↑             ↗
  bᵃ     |            /
  ↑      | <f^,idₐ>  /
  |      |          /
  |∃!f̂ ^  |         /
  |      |        / f
  z      |       /
         |      /
         |     /
         |    /
         |   /
         |  /
         z×a
</pre>
#
where <f, g> is the arrow map of the product functor.
*)
Record Exponential {C : Category} {HP : Has_Products C} (c d : Obj) : Type :=
{
  exponential : C;

  eval : ((×ᶠⁿᶜ C) _o (exponential, c))%object –≻ d;

  Exp_morph_ex : ∀ (z : C), (((×ᶠⁿᶜ C) _o (z, c))%object –≻ d) → (z –≻ exponential);

  Exp_morph_com : ∀ (z : C) (f : ((×ᶠⁿᶜ C) _o (z, c))%object –≻ d),
      f = (eval ∘ ((×ᶠⁿᶜ C) @_a (_, _) (_, _) (Exp_morph_ex z f, id c)))%morphism;

  Exp_morph_unique : ∀ (z : C) (f : ((×ᶠⁿᶜ C) _o (z, c))%object –≻ d)
                       (u u' : z –≻ exponential),
      f = (eval ∘ ((×ᶠⁿᶜ C) @_a (_, _) (_, _) (u, id c)))%morphism →
      f = (eval ∘ ((×ᶠⁿᶜ C) @_a (_, _) (_, _) (u', id c)))%morphism →
      u = u'
}.

Coercion exponential : Exponential >-> Obj.

Arguments Exponential _ {_} _ _, {_ _} _ _.

Arguments exponential {_ _ _ _} _, {_ _} _ _ {_}.
Arguments eval {_ _ _ _} _, {_ _} _ _ {_}.
Arguments Exp_morph_ex {_ _ _ _} _ _ _, {_ _} _ _ {_} _ _.
Arguments Exp_morph_com {_ _ _ _} _ _ _, {_ _} _ _ {_} _ _.
Arguments Exp_morph_unique {_ _ _ _} _ _ _ _ _ _ _, {_ _} _ _ {_} _ _ _ _ _ _.

Notation "a ⇑ b" := (Exponential a b) : object_scope.

(** Exponentials are unique up to isomorphism. *)
Theorem Exponential_iso {C : Category} {HP : Has_Products C} (c d : C)
        (E E' : (c ⇑ d)%object) : (E ≃ E')%isomorphism.
Proof.
  eapply
    (
      Build_Isomorphism
        _
        _
        _
        (Exp_morph_ex E' _ (eval E))
        (Exp_morph_ex E _ (eval E'))
    );
  eapply Exp_morph_unique; eauto;
  simpl_ids;
  match goal with
      [|- (_ ∘ ?M)%morphism = _] =>
      match M with
        (?U _a (?A ∘ ?B, ?C))%morphism =>
        cutrewrite (M = (U @_a (_, _) (_, _) (A, C))
                          ∘ (U @_a (_, _) (_, _) (B, C)))%morphism;
          [|simpl_ids; rewrite <- F_compose; simpl; simpl_ids; trivial]
      end
  end;
  rewrite <- assoc;
  repeat rewrite <- Exp_morph_com; auto.
Qed.

Definition Has_Exponentials (C : Category) {HP : Has_Products C} :=
  ∀ a b, (a ⇑ b)%object.

Existing Class Has_Exponentials.

Section Curry_UnCurry.
  Context (C : Category) {HP : Has_Products C} {HE : Has_Exponentials C}.

  (** Given a arrow f: a×b -> c in a category with exponentials, the curry of f
      is f̂f^ in the definition of Exponential above. *)
  Definition curry :
    forall {a b c : C},
      (((×ᶠⁿᶜ C) _o (a, b))%object –≻ c) → (a –≻ (HE b c)) :=
    fun {a b c : C} (f : ((×ᶠⁿᶜ C) _o (a, b))%object –≻ c) =>
      Exp_morph_ex (HE b c) _ f.

  (** Given an arrow f: a -> cᵇ, uncurry of f is the arrow
      (eval_cᵇ ∘ <id_b, f>): a×b -> c.
      See definition of Exponential above for details. *)
  Definition uncurry : forall {a b c : C},
      (a –≻ (HE b c)) → (((×ᶠⁿᶜ C) _o (a, b))%object –≻ c) :=
    fun {a b c : C} (f : a –≻ (HE b c)) =>
      ((eval (HE b c)) ∘ ((×ᶠⁿᶜ C) @_a (_, _) (_, _) (f, id C b)))%morphism.

  Section inversion.
    Context {a b c : C}.

    (** See definition of curry and uncurry above for details.
        Frollows immediately from the definition of Exponential above. *)
    Theorem curry_uncurry (f : a –≻ (HE b c)) : curry (uncurry f) = f.
    Proof.
      unfold curry, uncurry.
      eapply Exp_morph_unique; trivial.
      rewrite <- Exp_morph_com; trivial.
    Qed.

    (** See definition of curry and uncurry above for details.
        Follows immediately from the definition of Exponential above. *)
    Theorem uncurry_curry (f : ((×ᶠⁿᶜ C) _o (a, b))%object –≻ c) :
      uncurry (curry f) = f.
    Proof.
      unfold curry, uncurry.
      rewrite <- Exp_morph_com; trivial.
    Qed.

  End inversion.

  Section injectivity.
    Context {a b c : C}.

    (** See definition of curry above for details. Follows immediately from
        uncurry_curry above. *)
    Theorem curry_injective (f g : ((×ᶠⁿᶜ C) _o (a, b))%object –≻ c) :
      curry f = curry g → f = g.
    Proof.
      intros H.
      rewrite <- (uncurry_curry f); rewrite <- (uncurry_curry g).
      rewrite H; trivial.
    Qed.

    (** See definition of uncurry above for details.
        Follows immediately from curry_uncurry above. *)
    Theorem uncurry_injective (f g : a –≻ (HE b c)) :
      uncurry f = uncurry g → f = g.
    Proof.
      intros H.
      rewrite <- (curry_uncurry f); rewrite <- (curry_uncurry g).
      rewrite H; trivial.
    Qed.

  End injectivity.

  Section curry_compose.
    Context {a b c : C}.

    (** composing with curry is equivalent to compose and then curry: *)
    Lemma curry_compose (f : ((×ᶠⁿᶜ C) _o (a, b))%object –≻ c)
          {z : C} (g : z –≻ a)
      : (curry f) ∘ g = curry (f ∘ (Prod_morph_ex _ _ (g ∘ Pi_1) Pi_2)).
    Proof.
      unfold curry.
      eapply Exp_morph_unique; eauto.
      rewrite <- Exp_morph_com.
      match goal with
          [|- ((_ ∘ (_ _a) ?M) ∘ _)%morphism = _] =>
          match M with
              ((?N ∘ ?x)%morphism, id ?y) =>
              replace M with
              (compose (_ × _) (_, _) (_, _) (_, _) (x, id y) (N,id y)) by
                  (cbn; auto)
          end
      end.
      rewrite F_compose.
      cbn; simpl_ids.
      rewrite assoc_sym.
      match goal with
          [|- (?A ∘ ?B = ?C ∘ ?B)%morphism] => cutrewrite (A = C); trivial
      end.
      transitivity (uncurry (curry f));
        [unfold curry, uncurry; cbn; auto|apply uncurry_curry].
    Qed.

  End curry_compose.

End Curry_UnCurry.


Require Import Ensembles Finite_sets Finite_sets_facts.
Require Import List ListSet.
Require Import util.

Open Scope list_scope.

Section set_rep.

Variable X : Type.
 Hypothesis Xeq_dec : forall (x y:X), {x = y} + {x <> y}.

Definition InSet : forall U : Type, Ensemble U -> U -> Prop := Ensembles.In.

Lemma set_imp_ensemble : forall (s: set X),
NoDup s ->
exists E:Ensemble X, (forall x, set_In x s <-> InSet X E x) /\
  exists n, (length s = n) /\ (cardinal X E n).
Proof.
  intros s nodup. generalize dependent nodup.
  induction s; intros nodup.
  Case "[]".
    exists (Empty_set X).
    split.
    SCase "set_In <-> InSet".
      intros x.
      split. intros setin. inversion setin.
      intros  inset. inversion inset.
   SCase "length = size".
     exists 0.
     split. simpl. reflexivity.
     constructor.
 Case "a :: s".
   destruct IHs as [E [Hin Hcard]].
   inversion nodup; subst. exact H2.
   exists (Add X E a).
   split.
    SCase "set_In <-> InSet".
      intros x.
      split.
      SSCase "->".
        destruct (Xeq_dec a x) as [eqax | neqax].
        intros setIn. subst x.
        apply Add_intro2.
        intros setIn.
        destruct (Hin x) as [setInx InSetx].
        inversion setIn. assert False as F. apply neqax. exact H. inversion F.
        apply setInx in H. eapply Add_intro1 in H. exact H.
      SSCase "<-".
        intros inSet.
        destruct (Xeq_dec a x) as [eqax | neqax].
        subst. simpl. left. reflexivity.
        inversion inSet; subst.
        apply Hin in H.
        simpl. right. exact H.
        inversion H.
        assert False as F. apply neqax. exact H0. inversion F.
   SCase "length = size".
     destruct (set_In_dec Xeq_dec a s) as [ins | nins].
     inversion nodup; subst.
     assert False as F. apply H1. exact ins. inversion F.
     destruct Hcard as [n [len card]].
     exists (S n).
     split. simpl. auto.
     apply card_add. exact card.
     intros contra.
     destruct (Hin a) as [setIna InSeta].
     apply InSeta in contra.
     apply nins. exact contra.
Qed.

Lemma set_add_Sn : forall (s: set X) (x: X) (n:nat),
~ set_In x s ->
length s = n ->
length (set_add Xeq_dec x s) = S n.
Proof.
  intros s.
  induction s.
  Case "[]".
    intros x n notIn len.
    simpl. simpl in len.
    auto.
  Case "a :: s".
    intros x n notIn len.
    simpl. destruct (Xeq_dec x a).
    subst x.
    assert False as F. apply notIn. simpl. left. reflexivity. inversion F.
    simpl. rewrite <- len. simpl. destruct n. inversion len.
    assert (~ set_In x s) as xnotIns.
      intros contra. apply notIn. simpl. right. exact contra.
    assert (length s = n) as slen. auto.
    rewrite (IHs x n xnotIns slen).
    subst.
    reflexivity.
Qed.

Lemma set_add_nodup : forall x s,
NoDup (x :: s) ->
NoDup (set_add Xeq_dec x s).
Proof.
  intros x s. generalize dependent x.
  induction s.
  Case "[]".
    intros x xnotIn.
    simpl. exact xnotIn.
  Case "a :: s".
    intros x nodup.
    simpl.
    destruct (Xeq_dec x a) as [eqxa | neqxa].
    subst. inversion nodup. assert False as F. apply H1. simpl. left. reflexivity. inversion F.
    inversion nodup; subst. inversion H2; subst.
    assert (~ In x s) as notxIns.
      intros contra. apply H1. simpl. right. exact contra.
    assert (NoDup (x :: s)) as xsnodup.
      constructor. exact notxIns. exact H4.
    constructor.
    intros contra.
    apply set_add_elim2 in contra.
    apply H3. exact contra.
    intros contra2. subst. inversion nodup. apply H5. simpl. left. reflexivity.
    apply IHs. exact xsnodup.
Qed.

Lemma ensemble_imp_set : forall (E: Ensemble X),
Finite X E ->
exists s: set X, (forall x, set_In x s <-> InSet X E x) /\
  NoDup s /\
  exists n, (length s = n) /\ (cardinal X E n).
Proof.
  intros E fin.
  induction fin.
  Case "Empty_set".
    exists nil.
    split.
    intros x.
    split. intros setIn. inversion setIn.
    intros inSetx. inversion inSetx.
    split. constructor.
    exists 0. split. simpl. reflexivity.
    apply card_empty.
  Case "Add x".
    destruct IHfin as [s [Hin [Hnodup Hcard]]].
    exists (set_add Xeq_dec x s).
    split.
     SCase "set_In <-> InSet".
       intros a.
       split.
       SSCase "->".
         intros setInx.
         apply set_add_elim in setInx.
         destruct setInx as [eqax | aIns].
         subst a. apply Add_intro2.
         apply Add_intro1. apply Hin. exact aIns.
       SSCase "<-".
         intros InSeta.
         inversion InSeta; subst.
         apply set_add_intro.
         right.
         destruct (Hin a) as [HsetIn HInSet].
         apply HInSet.
         exact H0.
         inversion H0. subst.
         apply set_add_intro. left. reflexivity.
       split.
     SCase "NoDup s".
       assert (~ set_In x s) as xnotIns.
         destruct (set_In_dec Xeq_dec x s).
         apply Hin in s0. assert False as F. apply H. exact s0. inversion F.
         exact n.
         assert (NoDup (x :: s)) as xsnodup.
           constructor. exact xnotIns. exact Hnodup.
           apply set_add_nodup. exact xsnodup.
     SCase "length /\ card".
       destruct Hcard as [n [slen Acard]].
       destruct (set_In_dec Xeq_dec x s).
       SSCase "x in s".
         destruct (Hin x) as [HsetIn HInSet].
         assert False as F. apply H. apply HsetIn.
         exact s0. inversion F.
       SSCase "x not in s".
         exists (S n).
         split.
         apply set_add_Sn. exact n0. exact slen.
         apply card_add. exact Acard. exact H.
Qed.

End set_rep.