(**
Perfect Crypto - Simple definitions for message encryption and signing using
symmetric and assymetric keys

Perry Alexander
The University of Kansas

Provides definitions for:

- [keyType] - [symmetric], [public] and [private] key constructors.
- [inverse] - defines the inverse of any key.
- [is_inverse] - proof that [inverse] is decidable and provides a decision procesure for [inverse].
- [is_not_decryptable] - predicate indicating that a message is or is not decryptable using a specified key.
- [decrypt] - attempts to decrypt a message with a given key.  Returns the decrypted message if decryption occurs.  Returns a proof that the message cannot be decrypted with the key if decryption does not occur.
- [is_signed] - proof that signature checking is decidable and provides a decision procedure for signature check.
- [check] - checks a signature on a message with a given key.  Returns a proof that the check succeeds or does not succeed.
- [check_dec] - proof that signature checking is decidable and provides a decision procedure for signature checking.  Alternative function for [check].
*)

Require Import Omega.
Require Import Ensembles.
Require Import CpdtTactics.
Require Import Eqdep_dec.
Require Import Peano_dec.
Require Import Coq.Program.Equality.
(*Require Import Messages.*)

(** Ltac helper functions for discharging cases generated from sumbool types
  using one or two boolean cases. *)

Ltac eq_not_eq P := destruct P;
  [ (left; subst; reflexivity) |
    (right; unfold not; intros; inversion H; contradiction) ].

Ltac eq_not_eq' P Q := destruct P; destruct Q;
  [ (subst; left; reflexivity) |
    (right; unfold not; intros; inversion H; contradiction) |
    (right; unfold not; intros; inversion H; contradiction) |
    (right; unfold not; intros; inversion H; contradiction) ].

(** Key values will be [nat] by default.  Could be anything satisfying
 properties following.  *)

Definition key_val : Type := nat.

(** Key types are [symmetric], [public] and [private]. *)
Inductive keyType: Type :=
| symmetric : key_val -> keyType
| private : key_val -> keyType
| public : key_val -> keyType.

(** A [symmetric] key is its own inverse.  A [public] key is the inverse of
  the [private] key with the same [key_val].  A [private] key is the inverse of
  the [public] key with the same [key_val]. *)

Fixpoint inverse(k:keyType):keyType :=
match k with
| symmetric k => symmetric k
| public k => private k
| private k => public k
end.

(** Proof that inverse is decidable for any two keys. The resulting proof
 gives us the function [is_inverse] that is a decision procedure for key
 inverse checking.  It will be used in [decrypt] and [check] later in the
 specification. *)

Theorem is_inverse (k k':keyType) : {k = (inverse k')}+{k <> (inverse k')}.
Proof.
  intros.
  destruct k; destruct k';
  match goal with
  | [ |- {symmetric ?P = (inverse (symmetric ?Q))}+{symmetric ?P <> (inverse (symmetric ?Q))} ] => (eq_not_eq (eq_nat_dec P Q))
  | [ |- {private ?P = (inverse (public ?Q))}+{private ?P <> (inverse (public ?Q))} ] => (eq_not_eq (eq_nat_dec P Q))
  | [ |- {public ?P = (inverse (private ?Q))}+{public ?P <> (inverse (private ?Q))} ] => (eq_not_eq (eq_nat_dec P Q))
  | [ |- _ ] => right; simpl; unfold not; intros; inversion H
  end.
Defined.

Eval compute in (is_inverse (public 1) (private 1)).

Eval compute in (is_inverse (public 1) (private 2)).

Eval compute in (is_inverse (public 2) (private 1)).

Eval compute in (is_inverse (private 1) (public 1)).

Eval compute in (is_inverse (symmetric 1) (symmetric 1)).

Eval compute in (is_inverse (symmetric 1) (symmetric 2)).

(** Various proofs for keys and properties of the inverse operation.  All keys
  must have an inverse.  All keys have a unique inverse.  Equal inverses come
  from equal keys *)

Theorem inverse_injective : forall k1 k2, inverse k1 = inverse k2 -> k1 = k2.
Proof.
  intros.
  destruct k1; destruct k2; simpl in H; try (inversion H); try (reflexivity).
Defined.

Hint Resolve inverse_injective.

Theorem inverse_inverse : forall k, inverse (inverse k) = k.
Proof.
  intros. destruct k; try reflexivity.
Defined.

Hint Resolve inverse_inverse.

Theorem inverse_surjective : forall k, exists k', (inverse k) = k'.
Proof.
  intros. exists (inverse k). auto.
Defined.

Hint Resolve inverse_surjective.

Theorem inverse_bijective : forall k k',
    inverse k = inverse k' -> k = k'
  /\ forall k, exists k'', inverse k = k''.
Proof.
  auto.
Defined.

Lemma infoPri : forall k' n', (k' <> (private n')) ->
                         exists n, (k' = (public n)) \/
                          ((k' = (symmetric n)) \/
                         exists n, (k' = (private n)) /\ (n <> n')).
Proof.
  intros. destruct k'. destruct k. exists 0. right. left. reflexivity.
  exists (S k). right. left. reflexivity. destruct (eq_nat_dec k n'). subst. unfold not in H. assert (private n' = private n'). reflexivity. apply H in H0. inversion H0. exists 0. right. right. exists k. split. reflexivity. assumption. exists k. left. reflexivity.
Defined.

Lemma inverse_info : forall k k',
    k = inverse k' ->
    exists n, k = symmetric n /\  k' = symmetric n \/
    exists n, (k = public n) /\ (k' = private n) \/
                          exists n, (k = private n) /\ (k' = public n).
Proof.
  intros. destruct k; destruct k'; try inversion H. inversion H. exists k0. left.  split; reflexivity. exists 0. right. exists 0. right. exists k0. split; reflexivity. exists 0. right. exists k0. left. split; reflexivity.
Defined.

Inductive type : Type :=
| Basic : type
| Key : type
| Encrypt : type -> type
| Hash : type
| Pair : type -> type -> type
| Either : type -> type -> type.

(** Basic messages are natural numbers.  Really should be held abstract, but we
  need an equality decision procedure to determine message equality.  Compound
  messages are keys, encrypted messages, hashes and pairs. Note that signed
  messages are pairs of a message and encrypted hash. *)

Inductive message : type -> Type :=
| basic : nat -> message Basic
| key : keyType -> message Key
| encrypt (t:type) : message t -> keyType -> message (Encrypt t)
| hash : forall t, message t -> message (Hash)
| pair : forall t1 t2, message t1 -> message t2 -> message (Pair t1 t2)
| leither : forall t1 t2, message t1 -> message (Either t1 t2)
| reither : forall t1 t2, message t2 -> message (Either t1 t2)
| bad : forall t1,  message t1.

Definition getP1Type (t:type):type :=
  match t with
  | Pair t1 t2 => t1
  | _ => t
  end.

Definition getP2Type (t:type):type :=
  match t with
  | Pair t1 t2 => t2
  | _ => t
  end.

Definition pairFst{t1 t2: type} (m:message (Pair t1 t2)) : message t1 :=
  match m in message t' return message (getP1Type t') with
  | pair _ _ m1 _ => m1
  | bad _ => bad _
  | _ => bad _
  end.

(*
Definition pair1 := pair _ _ (basic 1) (basic 2).
Eval compute in pairFst pair1.
Definition pair1' := pair _ _ (bad Basic) (basic 2).
Eval compute in pairFst pair1'.
Definition pair1'' := pair _ _ (basic 1) (bad Basic).
Eval compute in pairFst pair1''. *)

Definition pairSnd{t1 t2: type} (m:message (Pair t1 t2)) : message t2 :=
  match m in message t' return message (getP2Type t') with
  | pair _ _ _ m2 => m2
  | bad _ => bad _
  | _ => bad _
  end.

(*
Definition pair2 := pair _ _ (basic 1) (basic 2).
Eval compute in pairSnd pair2.
Definition pair2' := pair  _ _ (basic 1) (bad Basic).
Eval compute in pairSnd pair2'. *)

(** Predicate that determines if a message cannot be decrypted.  Could be
  that it is not encrypted to begin with or the wrong key is used. *)

Definition is_not_decryptable{t:type}(m:message t)(k:keyType):Prop :=
  match m with
  | encrypt _ m' k' => k <> inverse k'
  (*| bad _ => False     *)
  | _ => True
  end.

Definition is_decryptable{t:type}(m:message t)(k:keyType):Prop :=
  match m with
  | encrypt _ m' k' => k = inverse k'
  (*| bad _ => True*)
  | _ => False
  end.

(** Prove that is_not_decryptable and is_decryptable are inverses.  This is a
  bit sloppy.  Should really only have one or the other, but this theorem
  assures they play together correctly.  Note that it is not installed as
  a Hint.  *)

Theorem decryptable_inverse: forall t:type, forall m:(message t), forall k,
    (is_not_decryptable m k) <-> not (is_decryptable m k).
Proof.
  intros.
  split. destruct m; try (tauto).
  simpl. intros. assumption.
  intros. destruct m; try (reflexivity).
  simpl. tauto. Defined.
  (*simpl. unfold not in H. simpl in H. apply H. trivial.
Defined. *)

(** [decrypt] returns either a decrypted message or a proof of why the message
  cannot be decrypted.  Really should be able to shorten the proof. *)

(*
Inductive sumor (A : Type) (B : Prop) : Type :=
    inleft : A -> A + {B} | inright : B -> A + {B}
*)

Theorem is_not_decryptable_basic: forall n k, is_not_decryptable (basic n) k.
Proof.
  intros.
  reflexivity.
Defined.

Theorem is_not_decryptable_key: forall k k', is_not_decryptable (key k) k'.
Proof.
  intros.
  reflexivity.
Defined.

Theorem is_not_decryptable_hash: forall t n k, is_not_decryptable (hash t n) k.
Proof.
  intros.
  reflexivity.
Defined.

Theorem is_not_decryptable_pair: forall t1 t2 n m k, is_not_decryptable (pair t1 t2 n m) k.
Proof.
  intros.
  reflexivity.
Defined.

Theorem is_not_decryptable_bad: forall t k, is_not_decryptable (bad t) k.
Proof.
  intros.
  reflexivity.
Defined.

Definition decrypt_type(t:type):type :=
  match t with
  | Encrypt t' => t'
  | _ => t
  end.

Inductive decryptable {t:type} : (message (Encrypt t)) -> keyType -> Prop :=
| cDecryptable {m':message t} {j:keyType} : decryptable (encrypt _ m' j) (inverse j).

Fixpoint decrypt{t:type}(m:message (Encrypt t))(k:keyType) :
  (message t * is_decryptable m k)+
  {(is_not_decryptable m k)}.
  refine match m in message t' return (message (decrypt_type t') * is_decryptable m k) + {(is_not_decryptable m k)} with
         | basic _ => inright _ _
         | key _ => inright _ _
         | encrypt _ m' j => (if (is_inverse k j) then (inleft _ (m',_)) else (inright _ _ ))
         | hash _ _ => inright _ _
         | pair _ _ _ _ => inright _ _
         | leither _ _ _ => inright _ _
         | reither _ _ _ => inright _ _
         | bad _ => inright _ _
         end.
Proof.
  reflexivity.
  reflexivity.
  simpl. assumption.
  simpl. assumption.
  reflexivity.
  reflexivity.
  reflexivity.
  reflexivity.
  reflexivity.
Defined.
(*
Fixpoint decrypt{t:type}(m:message (Encrypt t))(k:keyType):(message t)+{(is_not_decryptable m k)}.
  refine match m in message t' return (message (decrypt_type t') + {(is_not_decryptable m k)}) with
         | basic _ => inright _ _
         | key _ => inright _ _
         | encrypt m' j => (if (is_inverse k j) then (inleft _) else (inright _ _ ))
         | hash _ _ => inright _ _
         | pair  _ _ => inright _ _
         | leither _ _ _ => inright _ _
         | reither _ _ _ => inright _ _
         | bad _ => inright _ _
         end.
Proof.
  reflexivity.
  reflexivity.
  simpl. assumption.
  simpl. assumption.
  reflexivity.
  reflexivity.
  reflexivity.
  reflexivity.
  reflexivity.
Defined.
 *)

Definition encrypted_with {t:type}(m:message (Encrypt t)) : keyType :=
  match m with
  | encrypt _ m' j => j
  | _ => (public 0)
  end.

Eval compute in encrypted_with (bad (Encrypt Basic)).
Eval compute in encrypted_with (encrypt _ _ (public 33)).

Definition decrypt'{t:type}(m:message (Encrypt t))(k:keyType) : (k = inverse (encrypted_with m)) -> message t.
  refine
  ( fun pf =>
  match m with
         | basic _ => _
         | key _ => _
         | encrypt _ m' j => _
         | hash _ _ =>  _
         | pair  _ _ _ _ =>  _
         | leither _ _ _ => _
         | reither _ _ _ => _
         | bad _ =>  _
  end ).
  (exact (fun (x:Type) => (fun x => x))).
  (exact (fun (x:Type) => (fun x => x))).
  exact m'.
  (exact (fun (x:Type) => (fun x => x))).
  (exact (fun (x:Type) => (fun x => x))).
  (exact (fun (x:Type) => (fun x => x))).
  (exact (fun (x:Type) => (fun x => x))).
  destruct t0.
  (exact (fun (x:Type) => (fun x => x))).
  (exact (fun (x:Type) => (fun x => x))).
  exact (bad t0).
  (exact (fun (x:Type) => (fun x => x))).
  (exact (fun (x:Type) => (fun x => x))).
  (exact (fun (x:Type) => (fun x => x))). Defined.

  (*
Definition almostMessage := decrypt' (encrypt (basic 0) (public 1)) (private 1). *)

Example same_inverse : forall n, (private n) = inverse (public n).
Proof.
  intros. reflexivity. Qed.

(*
Eval compute in almostMessage (same_inverse 1).
 *)

Definition decryptM {t:type} (m:message (Encrypt t)) (k:keyType):message t :=
  match decrypt m k with
  | inleft (m',_) => m'
  | inright _ => bad t
  end.

(*
Definition decryptM {t:type} (m:message (Encrypt t)) (k:keyType):message t :=
  match decrypt m k with
  | inleft m' => m'
  | inright _ => bad t
  end.
 *)

(*
Definition enc1 := encrypt (basic 42) (public 1). Check enc1.
Definition enc2 := encrypt enc1 (public 2).
Eval compute in decryptM enc1 (private 1).
Eval compute in decryptM enc1 (private 0).
Eval compute in decryptM enc2 (private 2).
Eval compute in decryptM (decryptM enc2 (private 2)) (private 1). *)

(*Fixpoint decrypt'{t:type}(m:message (Encrypt t))(k:keyType):message t+{(is_not_decryptable m k)}.
refine
  match m with
  | basic _ => inright _ is_not_decryptable_basic
  | key _ => inright _ is_not_decryptable_key
  | encrypt t m' j => (if (is_inverse k j) then (inleft _ m') else (inright _ _ ))
  | hash _ _ => inright _ is_not_decryptable_hash
  | pair _ _ _ _ => inright _ is_not_decryptable_pair
  end.
Proof.
  simpl. assumption.
Abort. *)

(** This should solve the previous proof if there is a way to try it on every
  proof generated by refine

  repeat try (match goal with
  | [ |- is_not_decryptable (encrypt ?X ?Y) ?Z ] => simpl; assumption
  | [ |- _ ] => reflexivity
  end).
*)

(*
Eval compute in decrypt(encrypt (basic 1) (symmetric 1)) (symmetric 1).

Eval compute in decrypt(encrypt (basic 1) (symmetric 1)) (symmetric 2). *)

(** Generate a signature using encryption and hash *)

Definition sign{t:type}(m:message t)(k:keyType) :=
  (pair  _ _ m (encrypt _ (hash t m) k)).

(*
Eval compute in sign (basic 1) (public 1). *)

Ltac eq_key_helper :=
  match goal with
  | [ |- {symmetric ?P = symmetric ?Q} + {symmetric ?P <> symmetric ?Q} ] =>
    (eq_not_eq (eq_nat_dec P Q))
  | [ |- {public ?P = public ?Q} + {public ?P <> public ?Q} ] =>
    (eq_not_eq (eq_nat_dec P Q))
  | [ |- {private ?P = private ?Q} + {private ?P <> private ?Q} ] =>
    (eq_not_eq (eq_nat_dec P Q))
  | [ |- _ ] => right; unfold not; intros; inversion H
  end.

Theorem eq_key_type_dec (k k':keyType) : {k=k'}+{k<>k'}.
Proof.
  intros.
  destruct k; destruct k'; eq_key_helper.
Defined.

Theorem eq_key_dec : forall (k k':message Key), {k=k'}+{k<>k'}.
Proof.
  intros.
  dep_destruct k; dep_destruct k'.
  destruct k0; destruct k1; try (right; unfold not; intros; inversion H; contradiction).
  destruct (eq_nat_dec k0 k1).
  left. subst. reflexivity.
  right. unfold not. intros. inversion H. contradiction.
  destruct (eq_nat_dec k0 k1).
  left. subst. reflexivity.
  right. unfold not. intros. inversion H. contradiction.
    destruct (eq_nat_dec k0 k1).
  left. subst. reflexivity.
  right. unfold not. intros. inversion H. contradiction.
  right. unfold not. intros. inversion H.
  right. unfold not. intros. inversion H.
  left. reflexivity.
Defined.

Print eq_key_dec.

Check eq_key_dec.

Hint Resolve eq_key_dec.

Theorem eq_type_dec : forall (x y:type), {x = y} + {x <> y}.
Proof.
  induction x, y;
  match goal with
  | [ |- {?T = ?T} + {?T <> ?T} ] => left; reflexivity
  | [ |- {?C ?T = ?C ?U} + {?C ?T <> ?C ?U} ] => specialize IHx with y; destruct IHx; [ left; subst; reflexivity | right; unfold not; intros; inversion H; contradiction ]
  | [ |- {?C ?T ?U = ?C ?T' ?U'} + {?C ?T ?U <> ?C ?T' ?U'} ] => specialize IHx1 with y1; specialize IHx2 with y2; destruct IHx1; destruct IHx2;
  [ left; subst; reflexivity
   | subst; right; unfold not; intros; inversion H; contradiction
   | subst; right; unfold not; intros; inversion H; contradiction
   | subst; right; unfold not; intros; inversion H; contradiction ]
  | [ |- _ ] => right; unfold not; intros; inversion H
  end. (*destruct IHx. subst. admit.*)
Defined.

Theorem message_eq_lemma: forall t, forall m:(message t), forall m':(message t), forall k k',
    {m=m'}+{m<>m'} ->
    {k=k'}+{k<>k'} ->
    {(encrypt _ m k)=(encrypt _ m' k')}+{(encrypt _ m k) <> (encrypt _ m' k')}.
Proof.
  intros.
  destruct H; destruct H0.
  left; subst; reflexivity.
  right; subst; unfold not; intros; inversion H; contradiction.
  right. subst. unfold not. intros. inversion H. apply inj_pair2_eq_dec in H1. contradiction.
  apply eq_type_dec.
  right. unfold not. intros. inversion H. apply inj_pair2_eq_dec in H1. contradiction.
  apply eq_type_dec.
Defined.

Hint Resolve message_eq_lemma.

Ltac whack_right :=
  match goal with
  | [ |- {basic ?P = basic ?Q}+{basic ?P <> basic ?Q} ] =>
    (eq_not_eq (eq_nat_dec P Q))
  | [ |- {key ?P = key ?Q}+{key ?P <> key ?Q} ] =>
    (eq_not_eq (eq_key_dec P Q))
  | [ |- {encrypt ?P ?P' = encrypt ?Q ?Q'}+{encrypt ?P ?P' <> encrypt ?Q ?Q'} ] =>
    auto
  | [ H : {?P = ?Q}+{?P <> ?Q} |- {hash ?P = hash ?Q}+{hash ?P <> hash ?Q} ] =>
    (eq_not_eq H)
  | [ H1 : {?P = ?P'}+{?P <> ?P'},
      H2 : {?Q = ?Q'}+{?Q <> ?Q'}
      |- {pair ?P ?Q = pair ?P' ?Q'}+{pair ?P ?Q <> pair ?P' ?Q'} ] =>
    (eq_not_eq' H1 H2)
  | [ |- _ ] => right; unfold not; intros; inversion H
  end.

(*Theorem message_eq_dec: forall t, forall m:(message t), forall m':(message t), {m=m'}+{m<>m'}.
Proof.
  dependent induction m; dependent induction m'.
  (eq_not_eq (eq_nat_dec n n0)).
  right; unfold not; intros; inversion H.
  (eq_not_eq (eq_key_type_dec k k0)).
  right; unfold not; intros; inversion H.

  specialize IHm with m'.
  destruct IHm; destruct (eq_key_type_dec k k0);
  [ left; subst; reflexivity
  | right; unfold not; intros; inversion H; contradiction
  | right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1;
    [contradiction | apply eq_type_dec]
  | right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1;
    [contradiction | apply eq_type_dec]].

  right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1.

  specialize IHm with m'.
  destruct IHm;
  [ left; subst; reflexivity
  | right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1;
    [contradiction | apply eq_type_dec]].

  right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1.

  specialize IHm2 with m'2.
  specialize IHm1 with m'1.
  destruct IHm1; destruct IHm2;
  [ left; subst; reflexivity
  | right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1; apply inj_pair2_eq_dec in H2; [ contradiction | apply eq_type_dec | apply eq_type_dec | apply eq_type_dec ]
  | right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1; apply inj_pair2_eq_dec in H2; [ contradiction | apply eq_type_dec | apply eq_type_dec | apply eq_type_dec ]
  | right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1; apply inj_pair2_eq_dec in H2; [ contradiction | apply eq_type_dec | apply eq_type_dec | apply eq_type_dec ]].

  right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1.
  right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1
  right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1.
  right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1.
  right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1.
  right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1.
  left; reflexivity.
Defined.
 *)

(*Hint Resolve message_eq_dec. *)

Print encrypt.

(*Definition is_signed{t:type}(m:message (Pair t (Encrypt (Hash t))))(k:keyType):Prop :=
  match m with
  | pair t t' n n' => n' = sign n k
  | _ => False
  end.

  match m with
  | (pair r (Encrypt (Hash r')) m' m'') => match (decrypt m'' k) with
                      | inleft (hash r m''') => m'=m'''
                      | inleft _ => False
                      | inright _ => False
                      end
  | _ => False
  end.

  | (pair t t' m m') => match m' with
                       | encrypt t m'' k' =>  match m'' with
                                            | (hash t m''') => m=m''' /\ (k = inverse k')
                                      end
                  end
  end.

Example sign_1_ex: is_signed (pair (basic 1) (encrypt (hash (basic 1)) (private sf1))) (public 1).
Proof.
  simpl. tauto.
Defined.

Example sign_2_ex: not (is_signed (pair (basic 1) (encrypt (hash (basic 1)) (private 1))) (public 2)).
Proof.
  unfold not. intros.
  simpl in H. inversion H. inversion H1.
Defined.

Theorem check_dec: forall m:message, forall k, {(is_signed m k)}+{not (is_signed m k)}.
Proof.
  intros.
  destruct m; try tauto.
  destruct m2; try tauto.
    destruct m2; try tauto.
      destruct (is_inverse k k0).
        destruct (message_eq_dec m1 m2); try tauto.
        left. subst. simpl. tauto.
          right. unfold not. intros. simpl in H. tauto.
          right. unfold not. intros. simpl in H. tauto.
Defined.

Eval compute in check_dec (sign (basic 1) (private 1)) (public 1).

Eval compute in check_dec (sign (basic 1) (private 1)) (public 2).

Notation " 'good' " := (left _ _).

Notation " 'bad' " := (right _ _).

Eval compute in check_dec (sign (basic 1) (private 1)) (public 1).

Eval compute in check_dec (sign (basic 1) (private 1)) (public 2). *)

Theorem m2 : forall P Q R: Prop, P -> Q -> R -> Q.
Proof.
  intros. match goal with | [ B : _ |- _ ] => exact B end.
Defined.

(** [notHyp] determines if [P] is in the assumption set of a proof state.
  The first match case simply checks to see if [P] matches any assumption and
  fails if it does.  The second match case grabs everything else.  If [P]
  is a conjunction, it checks to see if either of its conjuncts is an
  assumption calling [notHyp] recursively.

*)

Ltac notHyp P :=
  match goal with
  | [ _ : P |- _ ] => fail 1
  | _ =>
    match P with
    | ?P1 /\ ?P2 => first [ notHyp P1 | notHyp P2 | fail 2 ]
    | _ => idtac
    end
  end.

Ltac extend pf :=
  let t := type of pf in
  notHyp t; generalize pf; intro.


(*
Inductive and (P Q:Prop) : Prop :=
| conj: P -> Q -> and P Q
.

Arguments conj {P} {Q} _ _.

Notation "P /\ Q" := (conj P Q).
*)

Theorem and_comm : forall (P Q:Prop),
    P /\ Q -> Q /\ P.
Proof.
    intros P Q [H1 H2]. split.
    - exact H2.
    - exact H1.
Qed.

Theorem and_assoc : forall (P Q R:Prop),
    P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
    intros P Q R [H1 [H2 H3]]. split.
    - split.
        + exact H1.
        + exact H2.
    - exact H3.
Qed.


Require Export GeoCoq.Tarski_dev.Annexes.circles.
Require Export GeoCoq.Axioms.continuity_axioms.

Section Tangency.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

(** Euclid Book III, Prop 11 and Prop 12
 We do not need to distinguish between internal or external tangency. *)

(** If two circles are tangent, the common point is on the line joining the centers. *)

Lemma TangentCC_Col : forall A B C D X,
 TangentCC A B C D ->
 OnCircle X A B ->
 OnCircle X C D ->
 Col X A C.
Proof.
intros.

unfold TangentCC in *.

induction(eq_dec_points A C).
subst C.
Col.

assert(HS:=ex_sym1 A C X H2).
ex_and HS Y.
ex_and H4 M.

assert(Cong X A Y A).
apply(is_image_col_cong A C X Y A H2 H6); Col.
assert(Cong X C Y C).
apply(is_image_col_cong A C X Y C H2 H6); Col.

destruct H.
unfold unique in H.

assert(x =X).
apply H.
split; auto.
subst x.
assert(OnCircle Y A B).
unfold OnCircle in *.
apply cong_transitivity with A X; Cong.
assert(OnCircle Y C D).
unfold OnCircle in *.
apply cong_transitivity with C X; Cong.
assert(X = Y).
apply H.
split; auto.
subst Y.

unfold Reflect in H6.
induction H6.
spliter.
unfold ReflectL in *.
spliter.
ex_and H11 Z.

assert(Z = X).
apply l7_3; auto.
subst Z.
Col.
spliter.
contradiction.
Qed.

Lemma tangent_neq : forall A B O P,
 O<>P -> Tangent A B O P -> A<>B.
Proof.
intros.
intro.
subst B.
unfold Tangent in *.
unfold unique in *.
ex_and H0 T.
assert(HH:=symmetric_point_construction T O).
ex_and HH T'.
assert(OnCircle T' O P).
apply (symmetric_oncircle T T' O P); auto.
assert(T = T').
apply H1.
split; Col.
subst T'.
apply H.
apply l7_3 in H3.
subst T.
unfold OnCircle in H2.
treat_equalities; tauto.
Qed.

(** A line going through the center is not tangent to the circle. *)

Lemma diam_not_tangent : forall O P A B,
  P <> O -> Col O A B -> ~ Tangent A B O P.
Proof.
intros O P A B HOP HCol HTan.
destruct HTan as [Q [[HQCol HQOn] HQUnique]].
destruct(eq_dec_points A B).
  subst B.
  destruct (segment_construction Q O O P) as [Q' [HQ'1 HQ'2]].
  assert (HQQ' : Q <> Q') by (intro; treat_equalities; auto).
  apply HQQ', HQUnique; split; Col.
destruct (diff_col_ex3 A B O) as [C [HOC [HAC [HBC HColC]]]]; Col.
destruct (diam_points O P C) as [Q1 [Q2 [HBet [HQ1Q2C [HQ1On HQ2On]]]]].
assert (HQ1Q2 : Q1 <> Q2).
  intro; treat_equalities; auto.
assert(Q = Q1) by (apply HQUnique; split; ColR).
assert(Q = Q2) by (apply HQUnique; split; ColR).
treat_equalities; auto.
Qed.

(** Every point on the tangent different from the point of tangency is strictly outside the circle. *)

Lemma tangent_out : forall A B O P T X,
  X <> T -> Col A B X -> TangentAt A B O P T -> OutCircleS X O P.
Proof.
intros.
unfold TangentAt in *.
spliter.

induction(eq_dec_points O P).
subst P.
unfold OutCircleS.
unfold Lt.

split.
apply le_trivial.
intro.
unfold OnCircle in *.
assert(T = O).
apply cong_identity with O; Cong.
assert(X = O).
apply cong_identity with O; Cong.
subst O.
contradiction.

assert(InCircle X O P -> X = T).
intro.

assert(HH:= chord_completion O P T X H3 H5).
ex_and HH T'.
assert(A <> B).
apply (tangent_neq A B O P); auto.
unfold Tangent in *.
unfold unique in *.
ex_and H1 TT.
assert(TT= T).
apply H9.
split; auto.
subst TT.
assert(T = T').
apply H9.
split; auto.
apply bet_col in H7.

assert(Col A X T); ColR.
subst T'.
apply between_identity in H7.
subst X.
tauto.

assert(~InCircle X O P).
intro.
apply H5 in H6.
contradiction.
apply ninc__outcs.
assumption.
Qed.

(** If line AB is tangent to a circle of center O at a point T, then OT is perpendicular to AB.
This is Euclid Book III, Prop 18 *)

Lemma tangentat_perp :
forall A B O P T, O <> P -> TangentAt A B O P T -> Perp A B O T.
Proof.
intros.
assert(TA:=H0).
unfold TangentAt in H0.
spliter.
assert(A <> B).
apply (tangent_neq A B O P); auto.
assert(~Col A B O).
intro.
assert(~Tangent A B O P).
apply(diam_not_tangent); Col.
contradiction.

assert(HH:= l8_18_existence A B O H4).
ex_and HH R.

induction(eq_dec_points T R).
subst R.
auto.

assert(HH:= (symmetric_point_construction T R)).
ex_and HH T'.

induction(eq_dec_points A R).
subst A.
assert(Perp T R R O).
apply perp_comm.
apply (perp_col R B O R T); Col.
assert(Perp_at R T R R O).
apply perp_in_comm.
apply perp_perp_in.
Perp.
assert(Per O R T).
apply l8_2.
apply perp_in_per; auto.
unfold Per in *.
ex_and H11 T''.
assert(T' = T'').
apply (symmetric_point_uniqueness T R T' T''); auto.
subst T''.

assert(T <> T').
intro.
subst T'.
apply H7.
apply sym_equal.
apply l7_3; auto.

assert(OnCircle T' O P).
unfold OnCircle in *.
apply cong_transitivity with O T; Cong.

assert(OutCircleS T' O P).
apply (tangent_out R B O P T T'); ColR.
unfold OutCircleS in *.
unfold Lt in *.
spliter.
unfold OnCircle in H14.
apply False_ind.
apply H16.
Cong.

assert(Perp T R R O).
apply perp_comm.
apply (perp_col R A O R T); Col.
apply perp_left_comm.
eapply (perp_col A B O R R); auto.
unfold Midpoint in *.
spliter.
apply bet_col in H8.
ColR.
assert(Perp_at R T R R O).
apply perp_in_comm.
apply perp_perp_in.
Perp.

assert(Per O R T).
apply l8_2.
apply perp_in_per; auto.
unfold Per in *.
ex_and H12 T''.
assert(T' = T'').
apply (symmetric_point_uniqueness T R T' T''); auto.
subst T''.

assert(T <> T').
intro.
subst T'.
apply H7.
apply sym_equal.
apply l7_3; auto.

assert(OnCircle T' O P).
unfold OnCircle in *.
apply cong_transitivity with O T; Cong.

assert(OutCircleS T' O P).
unfold Midpoint in *.
spliter.
apply bet_col in H12.
apply (tangent_out A B O P T T'); auto.
ColR.
unfold OutCircleS in *.
unfold Lt in *.
spliter.
unfold OnCircle in H14.
apply False_ind.
apply H17.
Cong.
Qed.

(** AB is tangent to the circle (O,P) iff they intersect at a point X
such that AB is perpendicular to OX. *)

Lemma tangency_chara : forall A B O P, P <> O ->
 (exists X, OnCircle X O P /\ Perp_at X A B O X) <-> Tangent A B O P.
Proof.
intros.

split.
intro.
ex_and H0 T.
unfold Tangent.
unfold unique.
exists T.
split.
split; auto.
apply perp_in_col in H1.
tauto.
intros.
spliter.
assert(Col A B T).
apply perp_in_col in H1.
tauto.

induction(eq_dec_points T x').
auto.
apply False_ind.

assert(Perp T x' O T).
apply (perp_col2 A B); auto.
apply perp_in_perp in H1.
auto.

assert(Perp_at T T x' O T).
apply perp_perp_in; auto.

assert(Per x' T O).
apply perp_in_comm in H7.
apply perp_in_per; auto.

assert(~Col x' T O).
apply perp_not_col in H6.
ColR.

assert(Lt T x' x' O /\ Lt T O x' O).
assert_diffs.
apply(l11_46 x' T O); auto.
unfold OnCircle in *.
unfold Lt in H10.
spliter.
apply H12.
apply cong_transitivity with O P; Cong.

intros.
assert(HT:=H0).
unfold Tangent in H0.
unfold unique in H0.
ex_and H0 T.

assert(TangentAt A B O P T).
unfold TangentAt.
repeat split; auto.
exists T.
split; auto.
assert(HH:=tangentat_perp A B O P T).
assert(Perp A B O T).
apply HH; auto.

apply(l8_14_2_1b_bis A B O T T H4); Col.
Qed.

Lemma tangency_chara2 : forall A B O P Q,
 OnCircle Q O P -> Col Q A B ->
 ((forall X, Col A B X -> X = Q \/ OutCircleS X O P) <-> Tangent A B O P).
Proof.
intros.
split.
intros.
unfold Tangent.
unfold unique.
exists Q.
repeat split; Col.
intros.
spliter.
assert(HH:=(H1 x' H2)).
induction HH.
auto.
unfold OnCircle in *.
unfold OutCircleS in *.
unfold Lt in *.
spliter.
apply False_ind.
apply H5; Cong.

intros.
assert(TangentAt A B O P Q).
unfold TangentAt.
repeat split; Col.

induction(eq_dec_points X Q).
left; auto;

unfold Tangent in H1.
right.

apply(tangent_out A B O P Q X); auto.
Qed.

Lemma tangency_chara3 : forall A B O P Q, A <> B ->
 OnCircle Q O P -> Col Q A B ->
 ((forall X, Col A B X -> OutCircle X O P) <-> Tangent A B O P).
Proof.

intros.
split.
intros.

assert(HT:= (tangency_chara2 A B O P Q H0 H1)); auto.
apply HT.
intros.
induction(eq_dec_points X Q).
left; auto.
right.
assert(OutCircle X O P).
apply H2; Col.

unfold OutCircleS.
unfold OutCircle in H5.
unfold Lt.
split; auto.
intro.

assert(HH:=midpoint_existence X Q).
ex_and HH M.
assert(InCircleS M O P).
apply(bet_inc2__incs O P Q X M); Circle.
intro.
subst M.

apply l7_2 in H7.
apply is_midpoint_id in H7.
subst X; tauto.
intro.
subst M.
apply is_midpoint_id in H7.
contradiction.
unfold Midpoint in H7.
spliter.
Between.

assert(Col A B M).
unfold Midpoint in *.
spliter.
ColR.
assert(HH:=(H2 M H9)).
unfold InCircleS in *.
unfold OutCircle in *.

apply le__nlt in HH.
contradiction.

intros.
assert(TangentAt A B O P Q).
unfold TangentAt.
repeat split; Col.

induction(eq_dec_points X Q).
subst X.
unfold TangentAt in *.
spliter.
apply onc__outc; auto.

assert(OutCircleS X O P).
apply(tangent_out A B O P Q X); auto.
unfold OutCircleS in *.
unfold OutCircle.
unfold Lt in H6.
tauto.
Qed.

(** Euclid Book III Prop 5
 If two circles cut one another, then they do not have the same center. *)

Lemma intercc__neq :  forall A B C D,
 InterCC A B C D -> A<>C.
Proof.
intros.
unfold InterCC in *.
ex_and H P.
ex_and H0 Q.
unfold InterCCAt in *.
spliter.
unfold OnCircle in *.
intro.
subst C.
apply H.
unfold EqC.
unfold OnCircle in *.
assert(Cong A B A D) by (apply cong_transitivity with A P; Cong).
intro.
split.
intro.
apply cong_transitivity with A B; Cong.
intro.
apply cong_transitivity with A D; Cong.
Qed.

(** Euclid Book III Prop 6
If two circles touch one another, then they do not have the same center.
*)

Lemma tangentcc__neq: forall A B C D,
 A<>B ->
 TangentCC A B C D ->
 A<>C.
Proof.
intros.
unfold TangentCC in *.
unfold unique in *.
ex_and H0 T.
intro.
subst C.
unfold OnCircle in *.
assert(Cong A B A D) by (apply cong_transitivity with A T; Cong).
assert(T = B).
apply(H1 B); Cong.
subst T.
assert(HH:=symmetric_point_construction B A).
ex_and HH B'.
unfold Midpoint in *.
spliter.
assert(B = B').
  apply(H1 B'); split; Cong.
  apply cong_transitivity with A B; Cong.
subst B'.
treat_equalities; tauto.
Qed.

Lemma interccat__neq : forall A B C D P Q, InterCCAt A B C D P Q -> A <> C.
Proof.
intros.
apply intercc__neq  with B D.
unfold InterCC.
exists P; exists Q;auto.
Qed.

(** Prop 17 construction of the tangent to a circle at a given point *)

Lemma tangent_construction : forall O P X, segment_circle -> OutCircle X O P
                                                  -> exists Y, Tangent X Y O P.
Proof.
intros.
induction(eq_dec_points O P).
subst P.
exists O.
unfold Tangent.
unfold unique.
unfold OnCircle in *.
exists O.
repeat split; Col; Cong.
intros.
spliter.
treat_equalities; auto.

assert(O <> X).
{
  intro.
  rewrite H2 in *;clear H2.
  treat_equalities.
  intuition.
}

assert(HH:=circle_cases O P X).
induction HH.

assert(HH:= perp_exists X O X H2).
ex_and HH Y.
unfold OnCircle in *.
exists Y.
apply tangency_chara; auto.
exists X.
apply perp_perp_in in H4.
split; Circle.

induction H3.
unfold OutCircle in *.
unfold InCircleS in *.
apply lt__nle in H3; contradiction.

assert(exists Q : Tpoint, OnCircle Q O P /\ Out O X Q).
{
  apply(onc_exists); auto.
}

ex_and H4 U.

assert(Bet O U X).
{
  unfold Out in H5.
  spliter.
  induction H7.
  unfold OutCircleS in *.
  unfold OnCircle in *.
  assert(Le O X O U).
  {
    unfold Le.
    exists X.
    split; Cong.
  }
  assert(Lt O U O X).
  {
    apply(cong2_lt__lt O P O X); Cong.
  }
  apply le__nlt in H8.
  contradiction.
  assumption.
}

assert(exists X : Tpoint, Perp U X O U).
{
  apply(perp_exists U O U).
  intro.
  unfold OnCircle in H4.
  treat_equalities; tauto.
}
ex_and H7 R.
assert(HP:=symmetric_point_construction X O).
ex_and HP W.
unfold Midpoint in *.
spliter.
assert(exists X0 : Tpoint, (Bet U R X0 \/ Bet U X0 R) /\ Cong U X0 W X).
{
  apply(segment_construction_2 R U W X).
  apply perp_distinct in H8.
  spliter.
  auto.
}

ex_and H10 T.

assert(InCircleS U O X).
{
  unfold InCircleS.
  unfold OutCircleS in H3.
  unfold OnCircle in H4.
  apply(cong2_lt__lt O P O X); Cong.
}

assert(OutCircleS T O X).
{
  apply(diam_cong_incs__outcs O X X W U T); auto.
  unfold Diam.
  unfold OnCircle.
  repeat split; Cong.
  Cong.
}
unfold segment_circle in H.
assert(exists Z : Tpoint, Bet U Z T /\ OnCircle Z O X).
{
  apply(H O X U T).
  apply incs__inc; auto.
  apply outcs__outc; auto.
}

ex_and H14 Y.
assert(exists Q : Tpoint, OnCircle Q O P /\ Out O Y Q).
{
  apply(onc_exists O P Y); auto.
  intro.
  unfold OnCircle in H15.
  treat_equalities; tauto.
}
ex_and H16 V.

exists V.

assert(Bet O V Y).
{
  unfold Out in H17.
  spliter.
  induction H19.
  unfold OutCircleS in H3.
  assert(Lt O V O Y).
  {
    apply (cong2_lt__lt O P O X); Cong.
  }
  unfold OnCircle in *.
  assert(Le O Y O V).
  {
    unfold Le.
    exists Y.
    split; Cong.
  }
  apply le__nlt in H21.
  contradiction.
  assumption.
}

assert(Cong O X O Y) by Cong.
assert(Cong O U O V) by (apply cong_transitivity with O P; Cong).

assert(CongA X O V Y O U).
{
  unfold OnCircle in *.
  apply(l11_10 U O Y Y O U X V Y U).
  apply conga_left_comm.
  apply conga_refl; intro;treat_equalities; tauto.
  repeat split; try(intro;treat_equalities; tauto).
  right; auto.
  repeat split; try(intro;treat_equalities; tauto).
  left; auto.
  apply out_trivial; intro;treat_equalities; tauto.
  apply out_trivial; intro;treat_equalities; tauto.
}

assert(Cong V X U Y).
{

  apply(cong2_conga_cong V O X U O Y); Cong.
  CongA.
}

assert(CongA O U Y O V X).
{
  unfold OnCircle in *.
  apply(cong3_conga O U Y O V X).
  intro;treat_equalities; tauto.
  intro;treat_equalities.
  unfold OutCircleS in *.
  unfold Lt in *.
  spliter.
  Cong.
  repeat split; Cong.
}

assert(Per O V X).
{
  apply(l11_17 O U Y O V X).
  apply(perp_col _ _ _ _ Y) in H8.

  apply perp_perp_in in H8.
  apply perp_in_comm in H8.
  apply perp_in_per.
  apply perp_in_sym.
  apply perp_in_comm.
  assumption.
  intro.
  treat_equalities.
  unfold CongA in H23.
  tauto.
  induction H10;
  ColR.
  assumption.
}

apply tangency_chara; auto.
exists V.
split; auto.
apply per_perp_in in H24; Cong.
apply perp_in_left_comm.
apply perp_in_sym.
assumption.
unfold OnCircle in *.
intro.
treat_equalities; tauto.
intro.
treat_equalities.
unfold CongA in H23.
tauto.
Qed.

Lemma interccat__ncol : forall A B C D P Q,
 InterCCAt A B C D P Q -> ~ Col A C P.
Proof.
intros.
intro.
assert (HH := H).
unfold InterCCAt in HH.
spliter.
apply H2.
apply (l4_18 A C).
apply interccat__neq in H.
auto.
assumption.
apply cong_transitivity with A B; Cong.
apply cong_transitivity with C D; Cong.
Qed.

(** Euclid Book III Prop 10
 A circle does not cut a circle at more than two points.
 *)
Lemma cop_onc2__oreq : forall A B C D P Q,
 InterCCAt A B C D P Q -> Coplanar A C P Q ->
 forall Z, OnCircle Z A B -> OnCircle Z C D -> Coplanar A C P Z -> Z=P \/ Z=Q.
Proof.
intros.
assert(HIC := H).
unfold InterCCAt in H.
spliter.
induction (eq_dec_points Z Q).
  right; auto.
left.
assert(HH:=midpoint_existence Q P).
ex_and HH M.
assert(Per A M Q).
apply(mid_onc2__per A B Q P M); auto.
assert(Per C M Q).
apply(mid_onc2__per C D Q P M); auto.

assert(HH:=midpoint_existence Z Q).
ex_and HH N.

assert(Per A N Q).
apply(mid_onc2__per A Z Q Z).
apply cong_transitivity with A B; Cong.
Circle.
Midpoint.

assert(Per C N Q).
apply(mid_onc2__per C Z Q Z).
apply cong_transitivity with C D; Cong.
Circle.
Midpoint.

assert(Col A C M).
apply cop_per2__col with Q; auto.
induction(col_dec P Q A).
exists M.
left.
split; ColR.
apply coplanar_perm_12, col_cop__cop with P; Col; Cop.
assert_diffs;auto.

assert(A <> C).
apply(interccat__neq A B C D P Q); auto.

assert(Col A C N).
apply cop_per2__col with Q; auto.
apply coplanar_perm_12, col_cop__cop with Z; Col.
apply coplanar_trans_1 with P; Cop.
apply interccat__ncol in HIC.
Col.
assert_diffs;auto.

assert(Perp A C Q P).
induction(eq_dec_points A M).
subst M.
apply per_perp_in in H12; auto.
apply perp_in_comm in H12.

apply perp_in_perp in H12.
apply perp_sym.
apply (perp_col Q A A C P); Perp.
ColR.
assert_diffs;auto.

apply per_perp_in in H11; auto.
apply perp_in_comm in H11.
apply perp_in_perp in H11.
apply perp_comm in H11.
apply (perp_col A M M Q C) in H11; Col.
apply perp_sym in H11.
apply perp_comm in H11.
apply (perp_col Q M C A P) in H11; Col.
Perp.
assert_diffs;auto.

assert(Col Q N Z).
ColR.

assert(Perp A C Q Z).
induction(eq_dec_points A N).
subst N.
apply per_perp_in in H15; auto.
apply perp_in_comm in H15.
apply perp_in_perp in H15.
apply perp_sym.
apply (perp_col Q A A C Z); Perp.
assert_diffs;auto.

apply per_perp_in in H14; auto.
apply perp_in_comm in H14.
apply perp_in_perp in H14.
apply perp_comm in H14.
apply (perp_col A N N Q C) in H14; Col.
apply perp_sym in H14.
apply perp_comm in H14.
apply (perp_col Q N C A Z) in H14; Col.
Perp.
assert_diffs;auto.

apply perp_sym in H21.
apply perp_sym in H19.
assert (HH : Par Q P Q Z).
apply (l12_9 _ _ _ _ A C); auto.
Cop.
apply coplanar_trans_1 with P; Cop.
apply interccat__ncol in HIC.
Col.
induction HH.
unfold Par_strict in H22.
spliter.
apply False_ind.
apply H23.
exists Q.
split; ColR.
spliter.
assert(Z = P \/ Z = Q).
apply(line_circle_two_points A B P Q Z H4); auto.
induction H26; tauto.
Qed.

End Tangency.

Section Tangency_2D.

Context `{T2D:Tarski_2D}.

Lemma onc2__oreq : forall A B C D P Q,
 InterCCAt A B C D P Q ->
 forall Z, OnCircle Z A B -> OnCircle Z C D  -> Z=P \/ Z=Q.
Proof.
intros.
assert(HCop := all_coplanar A C P Q).
assert(HCop1 := all_coplanar A C P Z).
apply(cop_onc2__oreq A B C D); assumption.
Qed.

End Tangency_2D.


(** 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 (lf3 : natural) (lf2 : natural) (lf1 : natural) : natural :=
  plus Zero lf1.


Inductive seq : nat -> Set :=
| niln : seq 0
| consn : forall n : nat , nat -> seq n -> seq (S n).

Fixpoint length (n:nat) (s:seq n) {struct s} : nat :=
  match s with
  | niln => 0
  | consn i _ s' => S (length i s')
  end.


Require Import XR_Rmin.
Require Import XR_Rlt.
Require Import XR_Rle_dec.
Require Import XR_Rlt_le_trans.
Require Import XR_Rnot_le_lt.

Local Open Scope R_scope.

Lemma Rmin_Rgt_l : forall r1 r2 r, r < Rmin r1 r2  -> r < r1 /\ r < r2.
Proof.
  intros x y z.
  intro h.
  unfold Rmin in h.
  destruct (Rle_dec x y) as [ hminl | hminr ].
  {
    split.
    { exact h. }
    {
      apply Rlt_le_trans with x.
      { exact h. }
      { exact hminl. }
    }
  }
  {
    split.
    {
      apply Rlt_trans with y.
      { exact h. }
      {
        apply Rnot_le_lt.
        exact hminr.
      }
    }
    {
      exact h.
    }
  }
Qed.


Require Import Wf.
Require Import Wf_nat.

Require Import Relation_Definitions.

Section WfInclusion.
  Variable A : Type.
  Variables R1 R2 : A -> A -> Prop.

  Lemma Acc_incl : inclusion A R1 R2 -> forall z:A, Acc R2 z -> Acc R1 z.
  Proof.
    induction 2.
    apply Acc_intro; auto with sets.
  Defined.
  Hint Resolve Acc_incl.

  Theorem wf_incl : inclusion A R1 R2 -> well_founded R2 -> well_founded R1.
  Proof.
    unfold well_founded in |- *; auto with sets.
  Defined.
End WfInclusion.

Section Inverse_Image.
  Variables A B : Type.
  Variable R : B -> B -> Prop.
  Variable f : A -> B.

  Let Rof (x y:A) : Prop := R (f x) (f y).

  Remark Acc_lemma : forall y:B, Acc R y -> forall x:A, y = f x -> Acc Rof x.
  Proof.
    induction 1 as [y _ IHAcc]; intros x H.
    apply Acc_intro; intros y0 H1.
    apply (IHAcc (f y0)); try trivial.
    rewrite H; trivial.
  Defined.

  Lemma Acc_inverse_image : forall x:A, Acc R (f x) -> Acc Rof x.
  Proof.
    intros; apply (Acc_lemma (f x)); trivial.
  Defined.

  Theorem wf_inverse_image : well_founded R -> well_founded Rof.
  Proof.
    red in |- *; intros; apply Acc_inverse_image; auto.
  Defined.
End Inverse_Image.

(** This section's aim is to prove that the lexicographic product of [<] *)
Section Wf_lt_lexic.
  Definition lex2 (p p' : nat*nat) : Prop :=
    (fst p) < (fst p') \/
    (fst p) = (fst p') /\ (snd p) < (snd p').

  Variable A B : Type.
  Variable measA: A -> nat.
  Variable measB: B -> nat.

  Definition orderAB : (A*B) -> (A*B) -> Prop :=
    fun ab1 ab2 =>
      let (a1,b1) := ab1 in
        let (a2, b2) := ab2 in
          lex2 (measA a1, measB b1) (measA a2, measB b2).

  Theorem wf_lt_lexico : well_founded orderAB.
  Proof.
    intros [a b].
    set (acc_a := (Wf_nat.well_founded_ltof A measA) a).
    generalize b; clear b; induction acc_a as [a acc_a IHa].
    pose (gen := refl_equal (measA a)).
    intro b. generalize gen.
    cut (forall a0, measA a = measA a0 -> Acc orderAB (a0,b)).
    intros; auto.
    pattern b; refine (well_founded_ind
      (Wf_nat.well_founded_ltof B measB) _ _ b).
    clear b; intros b IHb.
    constructor.
    intros [a1 b1] H2; destruct H2 as [H2 | H2]; simpl in H2.
    apply (IHa a1). unfold Wf_nat.ltof.
    rewrite H; assumption.
    destruct H2 as [H2 H3].
    apply (IHb b1). unfold Wf_nat.ltof.
    assumption.
    rewrite H2; assumption.
  Defined.
End Wf_lt_lexic.


(** 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 (lf1 : natural) (lf3 : natural) (z : natural) (lf2 : natural)
  : natural := mult lf1 (Succ Zero).


(** 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 (lf1 : natural) (lf2 : natural) (y : natural) (x : natural)
  : natural := mult lf1 (Succ Zero).


(** 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 (lf1 : natural) (y : natural) (z : natural) (x : natural)
  : natural := mult (Succ Zero) lf1.


(** 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 (z : natural) (y : natural) (lf2 : natural) : natural :=
  plus lf2 (mult (Succ y) z).


(** 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 (lf2 : natural) (x : natural) (y : natural) (lf1 : natural)
  : natural := mult x (Succ y).


(* Exercise 34 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_034 : ~(forall x, P x \/ (Q x -> S x)) -> ~(forall x, S x).
Proof.
imp_i a1.
neg_i (forall x:D, P x \/ (Q x -> S x)) a2.
hyp a1.
all_i a.
dis_i2.
imp_i a3.
all_e (forall x:D, S x) a.
hyp a2.
Qed.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Category.

(**
A sub category of C is a category whose objects are a subset (here we ues
subset types, i.e., sig) of objects of C and whose arrows are a subset of
arrows of C.

Here, we define a subcategory using two functions Obj_Cri : Obj C -> Prop
which defines the objects of subcategory and
Hom_Cri : ∀ (a b : Obj) -> Hom a b -> Prop
which defines the arrows of subcategory.
In other words, Obj_Cri and Hom_Cri are respectively cirteria for objects and
arrows being in the sub category. We furthermore, require that the Hom_Cri
provides that identity arrows of all objects in the subcategory are part of
the arrows of the subcategory. Additionally, For ant two composable arrow that
are in the subcategory, their composition must also be in the subcategory.
*)
Section SubCategory.
  Context (C : Category)
          (Obj_Cri : Obj → Type)
          (Hom_Cri : ∀ a b, (a –≻ b)%morphism → Prop).

  Arguments Hom_Cri {_ _} _.

  Context (Hom_Cri_id : ∀ a, Obj_Cri a → Hom_Cri (id a))
          (Hom_Cri_compose :
             ∀ a b c (f : (a –≻ b)%morphism)
               (g : (b –≻ c)%morphism),
               Hom_Cri f → Hom_Cri g → Hom_Cri (g ∘ f)).

  Arguments Hom_Cri_id {_} _.
  Arguments Hom_Cri_compose {_ _ _ _ _} _ _.

  Local Obligation Tactic := idtac.

  Program Definition SubCategory : Category :=
  {|
    Obj := sigT Obj_Cri;

    Hom :=
      fun a b =>
        sig (@Hom_Cri (projT1 a) (projT1 b));

    compose :=
      fun _ _ _ f g =>
        exist _ _
              (Hom_Cri_compose (proj2_sig f) (proj2_sig g));

    id :=
      fun a =>
        exist _ _ (Hom_Cri_id (projT2 a))
  |}.

  Next Obligation.
    intros.
    apply sig_proof_irrelevance; simpl; abstract auto.
  Qed.

  Next Obligation.
    symmetry.
    apply SubCategory_obligation_1.
  Qed.

  Local Hint Extern 3 => simpl.

  Local Obligation Tactic := basic_simpl; auto.

  Solve Obligations.

End SubCategory.

(**
A wide subcategory of C is a subcategory of C that has all the objects of C but
not necessarily all its arrows.
*)
Notation Wide_SubCategory C Hom_Cri := (SubCategory C (fun _ => True) Hom_Cri).

(**
A Full subcategory of C is a subcategory of C that for any pair of objects of
the category that it has, it has all the arrows between them. In practice, we
construct a full subcategory by only expecting an object criterion and setting
the arrow criterrion to accept all arrows.
*)
Notation Full_SubCategory C Obj_Cri :=
  (SubCategory C Obj_Cri (fun _ _ _ => True) (fun _ _ => I) (fun _ _ _ _ _ _ _ => I)).


Require Import List.
Import ListNotations.

(* 再帰関数の定義 *)
Fixpoint reverse {A : Type} (xs : list A) :=
  match xs with
  | nil => nil
  | x :: xs' =>
    reverse xs' ++ [x]
  end.

Compute reverse [1; 2; 3]. (* = [3; 2; 1] : list nat *)

(* 補題 *)
Lemma reverse_append : forall (A : Type) (xs ys : list A),
  reverse (xs ++ ys) = reverse ys ++ reverse xs.
Proof.
  intros A xs ys.
  induction xs.
- simpl.
  rewrite app_nil_r.
  reflexivity.
- simpl.
  rewrite IHxs.
  rewrite app_assoc.
  reflexivity.
Qed.

Theorem reverse_reverse : forall (A : Type) (xs : list A),
  reverse (reverse xs) = xs.
Proof.
  intros A xs.
  induction xs.
- simpl.
  reflexivity.
- simpl.
  rewrite reverse_append.
  simpl.
  rewrite IHxs.
  reflexivity.
Qed.


Require Export MoreCoq.

Check (3=3).

Check (forall (n : nat), n = 2).

Theorem silly :
  0 * 3 = 0.
  reflexivity.
Qed.

Print silly.

Check eq_refl.

Check Prop.
Check silly.

Theorem silly_1 :
  forall (n:nat),
    n = n.
  reflexivity.
Qed.

Check silly_1.
Check (0*3 =0).
Check (0).
Check (forall (n m:nat),n = m).
Check (eq_refl).
Print silly.

Lemma silly_implication :
  (1+1)=2 -> 0*3 = 0.
  intros H.
  reflexivity.
Qed.

Print silly_implication.

Print silly_1.
Check mult.
Check (nat -> nat -> nat).
Check (forall p q, p -> q).

Inductive and (P Q : Prop) : Prop :=
  conj : P -> Q -> (and P Q).

Notation "P /\ Q" := (and P Q) : type_scope.
Check and.
Check (conj).
Check (forall (p : Prop), p -> p -> and p p).
Check (0 = 0).
Check (nat).

Theorem aaaaaa:
  Prop -> Prop -> Prop.
  apply and.
Qed.
Theorem and_example :
  (0 = 0) /\ (4 = mult 2 2).
  apply conj.
  reflexivity.
  reflexivity.
Qed.
Print and_example.

Print conj.
Print and.
Theorem proj1 :
  forall (P Q : Prop),
    P /\ Q -> P.
  intros P Q H.
  destruct H.
  apply H.
Qed.

Print proj1.

Check proj1.

Theorem and_commut :
  forall (P Q : Prop),
    P /\ Q -> Q /\ P.
  intros P Q.
  intros H.
  destruct H.
  apply conj.
  apply H0.
  apply H.
Qed.

Theorem and_assoc :
  forall (P Q R : Prop),
    P /\ ( Q /\ R ) -> (P /\ Q) /\ R.

  intros P Q R h.
  destruct h.
  destruct H0.
  apply conj.
  apply conj.
  apply H.
  apply H0.
  apply H1.
Qed.

Definition iff ( P Q :Prop) := (P -> Q) /\ (Q /\ P).
Notation "P <-> Q" := (iff P Q)
                        (at level 95, no associativity)
                      : type_scope.
Theorem iff_implies :
  forall (P Q :Prop),
    (P <-> Q) -> P -> Q.
  intros P Q.
  intros H.
  intros H1.
  destruct H.
  apply H in H1.
  apply H1.
Qed.

Theorem iff_sym :
  forall (P Q : Prop),
    (P <-> Q) -> (Q <-> P).
  intros P Q h.
  destruct h.
  destruct H0.
  apply conj.
  intros q.
  apply H1.
  apply conj.
  apply H1.
  apply H0.
Qed.

Inductive or (P Q : Prop) : Prop :=
| or_introl : P -> or P Q
| or_intror : Q -> or P Q.

Notation "P \/ Q" := (or P Q) : type_scope.

Check (or_introl).

Theorem or_commut :
  forall (P Q : Prop),
    P \/ Q -> Q \/ P.
  intros P Q h.
  destruct h.
  apply or_intror.
  apply H.
  apply or_introl.
  apply H.
Qed.

Theorem or_distributes_over_and_1 :
  forall (P Q R : Prop),
    P \/ (Q /\ R) -> (P \/ Q) /\ (P \/ R).
  intros P Q R h.
  apply conj.
  destruct h.
  left.
  apply H.
  destruct H.
  right.
  apply H.
  destruct h.
  left.
  apply H.
  destruct H.
  right.
  apply H0.
Qed.

Theorem andb_prop :
  forall (b c : bool),
    andb b c = true ->
    b = true /\ c = true.
  intros b c h.
  unfold andb in h.
  destruct b.
  rewrite -> h.
  apply conj.
  reflexivity.
  reflexivity.
  apply conj.
  apply h.
  inversion h.
Qed.

Check true.
Check and.

Inductive False : Prop :=.

Theorem False_implies_nonsense :
  False -> 2 + 2 = 5.
  intros  h.
  inversion h.
Qed.

Theorem False_iiiiiiiiiii :
  False -> 1 + 1 = 3.
  intros h.

  destruct h.
Qed.

Theorem nonsense_implies_False :
  2 + 2 = 5 -> False.
  intros h.
  inversion h.
Qed.

Inductive Truth : Prop :=
| fact : Truth.

Definition not (P : Prop) := P -> False.
Notation "~ x" := (not x) : type_scope.

Check not.

Theorem contradiction_implies_anything :
  forall (P Q :Prop),
    (P /\ (~P)) -> Q.
  intros P Q.
  intros H.
  unfold not in H.
  destruct H.
  apply H0 in H.
  inversion H.
Qed.

Theorem double_neg :
  forall (P : Prop),
    P -> ~~P.
  intros P p.
  unfold not.
  unfold not.
  intros h.
  apply h in p.
  inversion p.
Qed.

Definition peirce :=
  forall (P Q : Prop),
    ((P -> Q) -> P) -> P.

Definition classic :=
  forall (P : Prop),
    ~~P -> P.

Theorem O :
  peirce <-> classic.
  apply conj.
  intro h.
  unfold peirce in h.
  unfold classic.
  unfold not.
  intro P.
  intro h1.
Abort.

Theorem contrapositive:
  forall (P Q : Prop),
    (P -> Q) -> (~Q -> ~P).
  intros P Q.
  intros h.
  unfold not.
  intros h1.
  intros p.
  apply h in p.
  apply h1 in p.
  destruct p.
Qed.

Theorem not_False:
  False -> False.
  intros h.
  inversion h.
Qed.

Print not_False.
Theorem excluded_middle_irrefutable:
  forall (P : Prop),
   ~~(P \/ (~P)).
  intros p.
  unfold not.
  intros h.
  apply h.
  right.
  intros p1.
  apply h.
  left.
  apply p1.
Qed.

Print excluded_middle_irrefutable.

Theorem peirce_classic :
  peirce -> classic.
  unfold peirce.
  unfold classic.
  intros h.
  unfold not.
  intros P.
  assert (((P -> False) -> P) -> P) as H.
  apply h.
  intros h1.
  apply H.
  intro h2.
  apply h1 in h2.
  inversion h2.
Qed.

Definition excluded_middle :=
  forall (P : Prop),
    P \/ ~P.

Theorem classic_excluded_middle :
  classic -> excluded_middle.
  unfold classic.
  unfold excluded_middle.
  intros H.
  intros P.
  assert (~~(P\/~P)) as h.
  apply excluded_middle_irrefutable.
  apply H in h.
  apply h.
Qed.

Definition de_morgan_not_and_not :=
  forall (P Q :Prop),
    ~(~P /\ ~Q) -> P\/Q.
(*
Theorem excluded_middle_de_morgan_not_and_not :
  classic -> de_morgan_not_and_not.
  unfold de_morgan_not_and_not.
  unfold classic.
  unfold not.
  intros h.
  intros p q.
  intros h1.
  apply h.
  intros h2.
  apply h1.
  apply conj.
  intros p1.
  apply h2.
  left.
  apply p1.
  intros q1.
  apply h2.
  right.
  apply q1.
Qed.
*)
Theorem excluded_middle_classic :
  excluded_middle -> classic.
  unfold excluded_middle.
  unfold classic.
  unfold not.
  intros h1.
  intros p.
  intros h.
  assert (p \/ (p -> False)) as H.
  apply h1.
  destruct H.
  apply H.
  apply h in H.
  inversion H.
Qed.

Theorem excluded_middle_de_morgan_not_and_not :
  excluded_middle -> de_morgan_not_and_not.
  unfold excluded_middle.
  unfold de_morgan_not_and_not.
  unfold not.
  intros h.
  intros p q.
  intro h1.
  assert (p \/ ( p -> False)) as H.
  apply h.
  destruct H.
  left.
  apply H.
  assert (q \/ (q -> False)) as H2.
  apply h.
  destruct H2.
  right.
  apply H0.
  assert ((p -> False) /\ (q -> False)) as H3.
  apply conj.
  apply H.
  apply H0.
  apply h1 in H3.
  inversion H3.
Qed.

Definition implies_to_or :=
  forall p q:Prop,
    (p -> q) -> (~p\/q).

Theorem de_morgan_not_and_not_implies_to_or:
  de_morgan_not_and_not -> implies_to_or.
  unfold de_morgan_not_and_not.
  unfold implies_to_or.
  unfold not.
  intros H.
  intros p q.
  intros h1.
  apply H.
  intros h2.
  destruct h2.
  apply H0.
  intros p'.
  apply H1.
  apply h1.
  apply p'.
Qed.

Theorem implies_to_or_peirce :
  implies_to_or -> peirce.
  unfold implies_to_or.
  unfold peirce.
  unfold not.
  intros H.
  intros p q.
  intros h.
  assert ((p -> p) -> (p -> False) \/ p) as h1.
  apply H.
  assert ( p->p) as h2.
  intros p'.
  apply p'.
  apply h1 in h2.
  destruct h2.
  apply h.
  intros p'.
  apply H0 in p'.
  inversion p'.
  apply H0.
Qed.

(* Please all use excluded_middle *)

Notation "x <> y" := (~ (x = y)) : type_scope.

Theorem not_false_then_true :
  forall (b : bool),
    b <> false -> b = true.

  intros b.
  intros h.
  destruct b.
  reflexivity.
  unfold not in h.
  assert (false = false) as h'.
  reflexivity.
  apply h in h'.
  inversion h'.
Qed.


(** A library of positive multivariate polynomials *)

Require Import Arith List.
Require Import BellantoniCook.Lib.

(** * Representation of polynomials:

  - [pow] is the type of a variable identifier and its exponent.

  - [mon] is the type of a monomial, consisting of a coefficient and a list of variable identifiers with their exponents.

  - [pol] is the type of a polynomial, consisting of the number of variables and a list of monomials.
*)

Definition pow : Type := (nat*nat)%type.
Definition mon : Type := (nat * list pow)%type.
Definition pol : Type := (nat * list mon)%type.

(** * Evaluation of polynomials

  - [peval p [v0, v1,...]] is the evaluation of the polynomial [p] with variables [0], [1]... respectively
    instantiated with the values [v0], [v1]...
    If a variable is not assigned a value, then it is assumed to be [0].
    Values that do not correspond to a variable are ignored.
*)

Definition peval_pow (xn:pow)(l:list nat) : nat :=
  power (nth (fst xn) l 0) (snd xn).

Definition peval_mon (m:mon)(l:list nat) : nat :=
  (fst m) * multl (map (fun x => peval_pow x l) (snd m)).

Definition peval (p:pol)(l:list nat) :=
  plusl (map (fun m => peval_mon m l) (snd p)).

Lemma peval_parity : forall ar p l,
  peval (ar, snd p) l = peval p l.
Proof. intros ar [ar0 ml] l; simpl; trivial. Qed.

Lemma peval_pow_monotonic : forall xn l1 l2,
  (forall i, nth i l1 0 <= nth i l2 0) ->
  peval_pow xn l1 <= peval_pow xn l2.
Proof.
 intros [x n] l1 l2 H; simpl.
 apply power_le_l; trivial.
Qed.

Lemma peval_mon_monotonic : forall m l1 l2,
  (forall i, nth i l1 0 <= nth i l2 0) ->
  peval_mon m l1 <= peval_mon m l2.
Proof.
 unfold peval_mon; intros [a xl] l1 l2 H.
 induction xl; simpl; trivial.
 rewrite !mult_assoc, !(mult_comm a), <- !mult_assoc.
 apply mult_le_compat; trivial.
 apply peval_pow_monotonic; trivial.
Qed.

Lemma peval_monotonic : forall p l1 l2,
  (forall i, nth i l1 0 <= nth i l2 0) ->
  peval p l1 <= peval p l2.
Proof.
 unfold peval; intros [ar ml] l1 l2 H.
 induction ml; simpl; trivial.
 apply plus_le_compat; trivial.
 apply peval_mon_monotonic; trivial.
Qed.

Lemma peval_nth i pl p l :
  peval (nth i pl p) l =
  nth i (map (fun p => peval p l) pl) (peval p l).
Proof.
 intros; revert i.
 induction pl; intros [ | i]; simpl; intros; trivial.
Qed.

Notation parity := (@fst nat (list mon)).

(** * Well-formedness of polynomials *)

Definition pWF_pow (ar:nat)(xn:pow) : Prop :=
  fst xn < ar.

Definition pWF_mon (ar:nat)(m:mon) : Prop :=
  andl (pWF_pow ar) (snd m).

Definition pWF' (ar:nat)(ml:list mon) : Prop :=
  andl (pWF_mon ar) ml.

Definition pWF (p:pol) : Prop :=
  pWF' (fst p) (snd p).

Lemma pWF_mon_le : forall ar1 ar2 m,
  ar1 <= ar2 ->
  pWF_mon ar1 m -> pWF_mon ar2 m.
Proof.
 unfold pWF_mon, pWF_pow; intros ar1 ar2 [a xl].
 induction xl as [ | xn xl' IH]; simpl; intros; trivial.
 destruct xn as [x n]; simpl in *.
 split;[ omega | tauto].
Qed.

Lemma pWF'_le ar1 ar2 ml :
  ar1 <= ar2 -> pWF' ar1 ml -> pWF' ar2 ml.
Proof.
 induction ml; simpl; intros; trivial.
 split;[ | tauto].
 apply pWF_mon_le with ar1; trivial; tauto.
Qed.

Lemma pWF_mon_app : forall ar a1 xl1 a2 xl2,
  pWF_mon ar (a1, xl1) -> pWF_mon ar (a2, xl2) ->
  pWF_mon ar (a1*a2, xl1++xl2).
Proof.
 unfold pWF_mon, pWF_pow.
 induction xl1 as [ | [x n] xl1' IH]; simpl; intros; trivial.
 split;[ tauto | ].
 apply IH with a1; tauto.
Qed.

Lemma pWF'_app ar ml1 ml2 :
  pWF' ar ml1 -> pWF' ar ml2 -> pWF' ar (ml1++ml2).
Proof.
 induction ml1 as [ | m1 ml1' IH]; simpl; intros; trivial.
 split;[ tauto | ].
 apply IH; tauto.
Qed.

Lemma pWF_nth i pl p0 :
  andl pWF pl -> pWF p0 -> pWF (nth i pl p0).
Proof.
 intros; revert i.
 induction pl; simpl in *; intros; case i; intros; trivial.
 tauto.
 apply IHpl; tauto.
Qed.

Lemma parity_mon_correct : forall ar m l l1 l2,
  pWF_mon ar m -> length l = ar -> peval_mon m (l++l1) = peval_mon m (l++l2).
Proof.
 unfold peval_mon, peval_pow, pWF_mon, pWF_pow.
 intros ar [a xl] l l1 l2 H1 H2; simpl in *; f_equal; f_equal.
 induction xl as [ | [x n] xl' IH]; simpl in *; trivial.
 f_equal;[ | tauto].
 f_equal; rewrite !app_nth1; trivial; omega.
Qed.

Lemma parity_correct : forall p l l1 l2,
  pWF p -> length l = parity p -> peval p (l++l1) = peval p (l++l2).
Proof.
 unfold peval, peval_mon, peval_pow, pWF, pWF_mon, pWF_pow.
 intros [ar ml] l l1 l2 H1 H2; simpl in *; f_equal.
 induction ml as [ | m ml' IH]; simpl in *; trivial.
 f_equal;[ | tauto].
 apply parity_mon_correct with ar; tauto.
Qed.

(** * Basic polynomials *)

(** ** Constant polynomial

  - [pcst ar a] is the constant polynomial with [ar] variables and equal to the constant [a].
*)

Definition pcst (ar a:nat) : pol :=
  (ar, [(a,nil)]).

Lemma parity_pcst ar a :
  parity (pcst ar a) = ar.
Proof. trivial. Qed.

Lemma pWF_pcst ar a : pWF (pcst ar a).
Proof. compute; intros; tauto. Qed.

Lemma pcst_correct : forall ar k l, peval (pcst ar k) l = k.
Proof. unfold peval, peval_mon, peval_pow; simpl; intros; omega. Qed.

(** ** Single variable polynomial

  - [pproj ar i] is the polynomial with [ar] variables and equal to the [i]th variable.
*)

Definition pproj (ar i:nat) : pol :=
  (ar,[(1,[(i,1)])]).

Lemma parity_pproj n i :
  parity (pproj n i) = n.
Proof. trivial. Qed.

Lemma pWF_pproj ar i : i < ar -> pWF (pproj ar i).
Proof. compute; intros; tauto. Qed.

Lemma pproj_correct : forall ar i l,
 peval (pproj ar i) l = nth i l 0.
Proof. unfold peval, peval_mon, peval_pow; simpl; intros; omega. Qed.

(** ** Scalar multiplication of a polynomial

  - [pscalar n p] is the polynomial [p] where all coefficients have been multiplied by [n].
*)

Definition pscalar_mon (n:nat)(m:mon) : mon :=
  (n * fst m, snd m).

Definition pscalar (n:nat)(p:pol) : pol :=
  (fst p, map (pscalar_mon n) (snd p)).

Lemma parity_pscalar n p :
  parity (pscalar n p) = parity p.
Proof. trivial. Qed.

Lemma pWF_pscalar : forall n p,
  pWF p -> pWF (pscalar n p).
Proof.
 unfold pWF, pWF_mon, pWF_pow; intros n [ar ml] H.
 induction ml; simpl in *; trivial; tauto.
Qed.

Lemma pscalar_mon_correct : forall n m l,
  peval_mon (pscalar_mon n m) l = n * peval_mon m l.
Proof. unfold peval_mon; intros n [a xl] l; simpl; ring. Qed.

Lemma map_pscalar_mon n ml l :
  plusl (map (fun m => peval_mon (pscalar_mon n m) l) ml) =
  n * plusl (map (fun m => peval_mon m l) ml).
Proof.
 induction ml; simpl; trivial.
 rewrite pscalar_mon_correct, IHml; ring.
Qed.

Lemma pscalar_correct : forall n p l,
  peval (pscalar n p) l = n * peval p l.
Proof.
 unfold peval, pscalar; intros n [ar pl] l.
 induction pl; simpl in *; trivial.
 rewrite map_map in *.
 rewrite pscalar_mon_correct; simpl in IHpl.
 rewrite IHpl; ring.
Qed.

(** ** Sum of polynomials

  - [pplus p1 p2] is the sum of the polynomials [p1] and [p2].

  - [pplusl pl] is the sum of the polynomials in the list [pl].
*)

Definition pplus (p1 p2:pol) : pol :=
  (max (fst p1) (fst p2), snd p1 ++ snd p2).

Lemma parity_pplus : forall p1 p2,
  parity (pplus p1 p2) = max (parity p1) (parity p2).
Proof.
 intros [ar1 ml1] [ar2 ml2]; trivial.
Qed.

Lemma pWF_pplus : forall p1 p2,
  pWF p1 -> pWF p2 -> pWF (pplus p1 p2).
Proof.
 unfold pWF, pWF_mon, pWF_pow.
 intros [ar1 ml1] [ar2 ml2] H1 H2; simpl in *.
 induction ml1 as [ | m1 ml1' IH]; simpl in *.
 apply pWF'_le with ar2; auto with arith.
 split;[ | tauto ].
 apply pWF_mon_le with ar1; auto with arith; tauto.
Qed.

Lemma pplus_correct : forall p1 p2 l,
 peval (pplus p1 p2) l = peval p1 l + peval p2 l.
Proof.
 unfold peval, peval_mon, peval_pow.
 intros [ar1 ml1] [ar2 ml2] l.
 induction ml1 as [ | m1 ml1' IH]; simpl in *; trivial.
 unfold peval, pplus in IH; rewrite IH; ring.
Qed.

Definition pplusl (pl:list pol) : pol :=
  fold_right pplus (pcst 0 0) pl.

Lemma parity_pplusl : forall pl,
  parity (pplusl pl) = maxl (map parity pl).
Proof.
 induction pl; trivial; simpl pplusl.
 rewrite parity_pplus, IHpl; trivial.
Qed.

Definition pWF_pplusl : forall pl,
  andl pWF pl -> pWF (pplusl pl).
Proof.
 unfold pWF, pWF_mon, pWF_pow.
 induction pl; intros;[ simpl; tauto |].
 apply pWF_pplus; simpl in *; tauto.
Qed.

Lemma pplusl_correct : forall pl l,
  peval (pplusl pl) l = plusl (map (fun p => peval p l) pl).
Proof.
 induction pl; simpl; intros; trivial.
 rewrite pplus_correct, IHpl; trivial.
Qed.

Lemma peval_nth_pplus : forall pl l i n,
  peval (nth i pl (pcst n 0)) l <=
  peval (pplusl pl) l.
Proof.
 induction pl; simpl; intros; case i; trivial; rewrite pplus_correct; [ omega | ].
 intros; eapply le_trans;[ apply IHpl | ].
 omega.
Qed.

(** ** Multiplication of polynomials

  - [pmult p1 p2] is the multiplication of the polynomials [p1] and [p2].

  - [pmultl pl] is the multiplication of the polynomials in the list [pl].
*)

Definition pmult_mon (m12:mon*mon) : mon :=
  (fst (fst m12) * fst (snd m12), snd (fst m12) ++  snd (snd m12)).

Definition pmult (p1 p2:pol) : pol :=
  (max (fst p1) (fst p2), map pmult_mon (list_prod (snd p1) (snd p2))).

Lemma parity_pmult : forall p1 p2,
  parity (pmult p1 p2) = max (parity p1) (parity p2).
Proof. intros [ar1 ml1] [ar2 ml2]; trivial. Qed.

Lemma pWF_pmult_mon : forall ar1 m1 ar2 m2,
  pWF_mon ar1 m1 -> pWF_mon ar2 m2 ->
  pWF_mon (max ar1 ar2) (pmult_mon (m1, m2)).
Proof.
 intros ar1 [a1 xl1] ar2 [a2 xl2]; simpl pmult_mon; intros.
 apply pWF_mon_app.
 apply pWF_mon_le with ar1; auto with arith.
 apply pWF_mon_le with ar2; auto with arith.
Qed.

Lemma pWF_pmult : forall p1 p2,
  pWF p1 -> pWF p2 -> pWF (pmult p1 p2).
Proof.
 unfold pWF, pWF_mon, pWF_pow.
 intros [ar1 ml1] [ar2 ml2] H1 H2; simpl in *.
 induction ml1 as [ | m1 ml1' IH1]; simpl in *; intros; trivial.
 rewrite map_app, map_map.
 apply pWF'_app;[ | tauto ].
 clear IH1.
 induction ml2 as [ | m2 ml2' IH2]; simpl in *; intros; trivial.
 split;[ | tauto ].
 apply pWF_pmult_mon; tauto.
Qed.

Lemma pmult_mon_correct : forall m12 l,
  peval_mon (pmult_mon m12) l =
  peval_mon (fst m12) l * peval_mon (snd m12) l.
Proof.
 unfold peval_mon, peval_pow.
 intros [[a1 xl1] [a2 xl2]] l; simpl.
 induction xl1 as [ | x1 xl1' IH]; simpl;[ ring | ring [IH] ].
Qed.

Lemma map_pmult_mon : forall m1 ml2 l,
 map (fun m2 => peval_mon (pmult_mon (m1, m2)) l) ml2 =
 map (fun m2 => peval_mon m1 l * peval_mon m2 l) ml2.
Proof.
 unfold peval_mon, peval_pow.
 intros [a1 xl1] ml2 l; simpl.
 induction ml2 as [ | [a2 xl2] ml2' IH]; simpl; trivial.
 rewrite IH, map_app, multl_app; f_equal; ring.
Qed.

Lemma pmult_correct : forall p1 p2 l,
 peval (pmult p1 p2) l = peval p1 l * peval p2 l.
Proof.
 unfold peval; intros [ar1 ml1] [ar2 ml2] l; simpl.
 induction ml1 as [ | m1 ml1' IH]; simpl; trivial.
 rewrite !map_app, !map_map, map_pmult_mon, plusl_app.
 rewrite map_map in IH; rewrite IH.
 rewrite mult_plus_distr_r.
 f_equal.
 rewrite multl_plus_distr_l, map_map; trivial.
Qed.

Definition pmultl (pl:list pol) : pol :=
  fold_right pmult (pcst 0 1) pl.

Lemma parity_pmultl pl :
  parity (pmultl pl) = maxl (map parity pl).
Proof.
 induction pl; simpl pmultl; trivial.
 rewrite parity_pmult, IHpl; trivial.
Qed.

Definition pWF_pmultl pl :
  andl pWF pl -> pWF (pmultl pl).
Proof.
 induction pl; simpl pmultl; intros.
 apply pWF_pcst.
 apply pWF_pmult; simpl in *; tauto.
Qed.

Lemma pmultl_correct pl l :
  peval (pmultl pl) l = multl (map (fun p => peval p l) pl).
Proof.
 induction pl; simpl; intros; trivial.
 rewrite pmult_correct, IHpl; trivial.
Qed.

(** ** Power of a polynomial

  - [ppower p n] is the polynomial [p] to the power [n].
*)

Fixpoint ppower (p:pol)(n:nat) : pol :=
  match n with
  | 0 => pcst (fst p) 1
  | S n' => pmult p (ppower p n')
  end.

Lemma parity_ppower p n :
  parity (ppower p n) = parity p.
Proof.
 induction n; simpl ppower; trivial.
 rewrite parity_pmult, IHn; auto with arith.
Qed.

Lemma pWF_ppower p n :
  pWF p -> pWF (ppower p n).
Proof.
 induction n; simpl ppower; intros.
 apply pWF_pcst.
 apply pWF_pmult; tauto.
Qed.

Lemma ppower_correct p n l :
  peval (ppower p n) l = power (peval p l) n.
Proof.
 induction n; simpl; intros; trivial.
 rewrite pmult_correct, IHn;trivial.
Qed.

(** ** Composition of polynomials

  - [pcomp p pl] is the polynomial [p] where each variable [i] is replaced by the [i]th polynomial in
    the list [pl].
*)

Definition pcomp_pow' (xn:pow)(pl:list pol) : pol :=
  ppower (nth (fst xn) pl (pcst 0 0)) (snd xn).

Definition pcomp_pow (xn:pow)(pl:list pol) : pol :=
  (maxl (map parity pl), snd (pcomp_pow' xn pl)).

Definition pcomp_mon' (m:mon)(pl:list pol) : pol :=
  pscalar (fst m) (pmultl (map (fun xn => pcomp_pow xn pl) (snd m))).

Definition pcomp_mon (m:mon)(pl:list pol) : pol :=
  (maxl (map parity pl), snd (pcomp_mon' m pl)).

Definition pcomp' (p:pol)(pl:list pol) : pol :=
  pplusl (map (fun m => pcomp_mon m pl) (snd p)).

Definition pcomp (p:pol)(pl:list pol) : pol :=
  (maxl (map parity pl), snd (pcomp' p pl)).

Lemma parity_pcomp_pow : forall xn pl,
  parity (pcomp_pow xn pl) = maxl (map parity pl).
Proof.
 unfold pcomp_pow; intros [x n] pl; simpl.
 case_eq (ppower (nth x pl (pcst 0 0)) n); trivial.
Qed.

Lemma map_parity_pcomp_pow xl pl :
  map (fun xn => parity (pcomp_pow xn pl)) xl = map (fun _ => maxl (map parity pl)) xl.
Proof. destruct xl; simpl; trivial. Qed.

Lemma parity_pcomp_mon' : forall m pl,
  parity (pcomp_mon' m pl) <= maxl (map parity pl).
Proof.
 intros [a xl] pl; simpl.
 rewrite parity_pmultl.
 induction xl; simpl.
 omega.
 apply Nat.max_lub; trivial.
Qed.

Lemma parity_pcomp_mon : forall m pl,
  parity (pcomp_mon m pl) = maxl (map parity pl).
Proof.
 unfold pcomp_mon; intros [a xl] pl; simpl; trivial.
Qed.

Lemma parity_pcomp p pl :
  parity (pcomp p pl) = maxl (map parity pl).
Proof.
 unfold pcomp; intros.
 case (pcomp' p pl); trivial.
Qed.

Lemma pWF_pcomp_pow' : forall xn pl,
  andl pWF pl -> pWF (pcomp_pow' xn pl).
Proof.
 intros [x n] pl H; simpl.
 apply pWF_ppower.
 apply pWF_nth; trivial.
 apply pWF_pcst.
Qed.

Lemma pWF_pcomp_pow : forall xn pl,
  andl pWF pl -> pWF (pcomp_pow xn pl).
Proof.
 intros [x n] pl H.
 apply pWF'_le with (ar1 := fst (pcomp_pow' (x, n) pl)).
 rewrite parity_pcomp_pow.
 unfold pcomp_pow'.
 rewrite parity_ppower.
 destruct (le_lt_dec (length pl) x).
 rewrite nth_overflow; auto with arith.
 apply in_le_maxl.
 apply in_map.
 apply nth_In; trivial.
 apply pWF_pcomp_pow'; trivial.
Qed.

Lemma pWF_pcomp_mon' : forall m pl,
  andl pWF pl -> pWF (pcomp_mon' m pl).
Proof.
 unfold pWF, pWF', pWF_mon, pWF_pow.
 intros [a xl] pl H.
 induction xl as [ | [x n]  xl' IH].
 simpl; tauto.
 apply pWF_pscalar.
 apply pWF_pmultl.
 clear IH.
 induction xl'; simpl in *.
 split; trivial.
 apply pWF_pcomp_pow; trivial.
 split;[ tauto | split ].
 apply pWF_pcomp_pow; trivial.
 apply IHxl'.
Qed.

Lemma pWF_pcomp_mon : forall m pl,
  andl pWF pl -> pWF (pcomp_mon m pl).
Proof.
 intros [a xl] pl H.
 apply pWF'_le with (ar1 := fst (pcomp_mon' (a, xl) pl)).
 apply parity_pcomp_mon'.
 apply pWF_pcomp_mon'; trivial.
Qed.

Lemma pWF_pcomp' : forall p pl,
  andl pWF pl -> pWF (pcomp' p pl).
Proof.
 intros [ar ml] pl H; simpl.
 apply pWF_pplusl.
 induction ml; simpl in *; trivial.
 split; trivial.
 apply pWF_pcomp_mon; trivial.
Qed.

Lemma pWF_pcomp : forall p pl,
  andl pWF pl -> pWF (pcomp p pl).
Proof.
 intros [ar ml] pl H.
 apply pWF'_le with (ar1 := fst (pcomp' (ar, ml) pl)).
 rewrite parity_pcomp; unfold pcomp'.
 rewrite parity_pplusl, map_map.
 induction ml; simpl.
 omega.
 apply Nat.max_lub; trivial.
 apply pWF_pcomp'; trivial.
Qed.

Lemma pcomp_pow'_correct : forall xn pl l,
  peval (pcomp_pow' xn pl) l =
  power (peval (nth (fst xn) pl (pcst 0 0)) l) (snd xn).
Proof. intros [x n] pl l; simpl; apply ppower_correct. Qed.

Lemma pcomp_pow_correct xn pl l :
  peval (pcomp_pow xn pl) l =
  power (peval (nth (fst xn) pl (pcst 0 0)) l) (snd xn).
Proof.
 intros; unfold pcomp_pow; apply pcomp_pow'_correct.
Qed.

Lemma pcomp_mon'_correct : forall m pl l,
  peval (pcomp_mon' m pl) l = peval_mon m (map (fun p => peval p l) pl).
Proof.
 intros [a xl] pl l; induction xl.
 unfold peval, peval_mon.
 simpl; ring.
 unfold pcomp_mon' in *; simpl in *.
 rewrite pscalar_correct, pmult_correct, pmultl_correct in *.
 rewrite mult_assoc, (mult_comm a), <- mult_assoc, IHxl, pcomp_pow_correct, peval_nth.
 destruct a0 as [x n].
 unfold peval_mon, peval_pow.
 rewrite pcst_correct; simpl; ring.
Qed.

Lemma pcomp_mon_correct : forall m pl l,
  peval (pcomp_mon m pl) l = peval_mon m (map (fun p => peval p l) pl).
Proof.
 intros [a xl] pl l; unfold pcomp_mon.
 rewrite peval_parity.
 apply pcomp_mon'_correct.
Qed.

Lemma pcomp'_correct : forall p pl l,
  peval (pcomp' p pl) l = peval p (map (fun p' => peval p' l) pl).
Proof.
 unfold pcomp'; intros [ar ml] pl l.
 induction ml; simpl in *; trivial.
 rewrite pplus_correct, pcomp_mon_correct, IHml; trivial.
Qed.

Lemma pcomp_correct p pl l :
  peval (pcomp p pl) l = peval p (map (fun p => peval p l) pl).
Proof.
 intros; unfold pcomp; rewrite peval_parity.
 apply pcomp'_correct.
Qed.

(** ** Shifting of a polynomial

  - [pshift p] is the polynomial [p] with one more variable and where each variable [i] is replaced by [i+1].
*)

Definition pshift_pow (xn:pow) : pow :=
  (S (fst xn), snd xn).

Definition pshift_mon (m:mon) : mon :=
  (fst m, map pshift_pow (snd m)).

Definition pshift (p:pol) : pol :=
  (S (fst p), map pshift_mon (snd p)).

Lemma parity_pshift : forall p,
  parity (pshift p) = S (parity p).
Proof. intros [ar ml]; trivial. Qed.

Lemma pWF_pshift_mon : forall ar m,
  pWF_mon ar m -> pWF_mon (S ar) (pshift_mon m).
Proof.
 unfold pWF_mon, pWF_pow.
 intros ar [a xl] H; simpl.
 induction xl as [ | [x n]  xl' IH]; simpl in *; trivial.
 split; [ omega | tauto ].
Qed.

Lemma pWF_pshift : forall p, pWF p -> pWF (pshift p).
Proof.
 unfold pWF; intros [ar ml] H; simpl.
 induction ml; simpl in *; trivial.
 split;[ | tauto].
 apply pWF_pshift_mon; tauto.
Qed.

Lemma pshift_pow_correct : forall xn l,
  peval_pow (pshift_pow xn) l = peval_pow xn (tl l).
Proof.
 unfold peval_pow; intros [x n] l; simpl; f_equal.
 rewrite nth_S_tl; trivial.
Qed.

Lemma pshift_mon_correct : forall m l,
  peval_mon (pshift_mon m) l = peval_mon m (tl l).
Proof.
 unfold peval_mon; intros [a xl] l.
 induction xl; simpl in * ;trivial.
 rewrite mult_assoc, (mult_comm a), <- mult_assoc, pshift_pow_correct, IHxl; ring.
Qed.

Lemma pshift_correct : forall p l,
  peval (pshift p) l = peval p (tl l).
Proof.
 unfold peval; intros [ar ml] l.
 induction ml; simpl in *; trivial.
 rewrite pshift_mon_correct, IHml; trivial.
Qed.

(** ** Polynomial defined as a sum of a range of variables

  - [psum start len] is the polynomial with [start+len] variables and
    consisting in the sum of the variables [start] to [start+len-1].
*)

Definition psum (start len : nat) : pol :=
  pplus (pcst (start+len) 0) (pplusl (map (pproj (start+len)) (seq start len))).

Lemma psum_correct start len l :
  peval (psum start len) l =
  plusl (map (fun i => nth i l 0) (seq start len)).
Proof.
 intros; unfold psum.
 rewrite pplus_correct, pcst_correct, pplusl_correct; simpl; f_equal.
 induction (seq start len); simpl; intros; trivial.
 rewrite pproj_correct; congruence.
Qed.

Lemma pWF_psum start len : pWF (psum start len).
Proof.
 intros;unfold psum.
 apply pWF_pplus.
 apply pWF_pcst.
 apply pWF_pplusl.
 rewrite <- forall_andl; intros.
 rewrite in_map_iff in H.
 destruct H as (y & H1 & H2); subst.
 apply pWF_pproj.
 rewrite in_seq_iff in H2.
 tauto.
Qed.

Lemma parity_psum start len :
  parity (psum start len) = start + len.
Proof.
 intros; unfold psum.
 rewrite parity_pplus, parity_pcst, parity_pplusl, max_l; trivial.
 apply maxl_map.
 intros p H.
 rewrite in_map_iff in H.
 destruct H as (x & H & _).
 subst; trivial.
Qed.

(** * Tactic for well-formedness

  - The tactic [pWF] attempts to prove automatically goals of the form [pWF p] where
    [p] is a polynomial.
*)

Ltac pWF :=
  match goal with
  | |- pWF (pcst _ _) => apply pWF_pcst
  | |- pWF (pproj _ _) => apply pWF_pproj; try omega
  | |- pWF (pscalar _ _) => apply pWF_pscalar; pWF
  | |- pWF (pplus _ _) => apply pWF_pplus; pWF
  | |- pWF (pplusl _) => apply pWF_pplusl; rewrite <- forall_andl; intros; pWF
  | |- pWF (pmult _ _) => apply pWF_pmult; pWF
  | |- pWF (pmultl _) => apply pWF_pmultl; rewrite <- forall_andl; intros; pWF
  | |- pWF (ppower _ _) => apply pWF_ppower; pWF
  | |- pWF (pcomp _ _) => apply pWF_pcomp; rewrite <- forall_andl; intros; pWF
  | |- pWF (pshift _) => apply pWF_pshift; pWF
  | |- pWF (psum _ _) => apply pWF_psum
  | |- _ => idtac
  end.

(** * Degree of a polynomial

  - [deg p] is the degree of the polynomial [p].
*)

Definition deg_mon (m:mon) : nat :=
  plusl (map (@snd _ _) (snd m)).

Definition deg (p:pol) : nat :=
  maxl (map deg_mon (snd p)).


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor.
Require Import Functor.Functor_Ops.

Local Open Scope functor_scope.

Section Functor_Properties.
  Context {C C' : Category} (F : C –≻ C').

  Local Open Scope object_scope.
  Local Open Scope isomorphism_scope.
  Local Open Scope morphism_scope.

  (** A functor is said to be injective if its object map is. *)
  Definition Injective_Func := ∀ (c c' : Obj), F _o c = F _o c' → c = c'.

  (** A functor is said to be essentially injective if its object map maps
equal objects to isomorphic objects in the codomain category. *)
  Definition Essentially_Injective_Func :=
    ∀ (c c' : Obj), F _o c = F _o c' → c ≃ c'.

  (** A functor is said to be surjective if its object map is. *)
  Definition Surjective_Func := ∀ (c : Obj), {c' : Obj | F _o c' = c}.

  (** A functor is said to be essentially surjective if for each object in the
codomain category there is an aobject in the domain category that is mapped
to an aobject isomorphic to it. *)
  Definition Essentially_Surjective_Func :=
    ∀ (c : Obj), {c' : Obj & F _o c' ≃ c}.

  (** A functor is said to be faithful if its arrow map is injective. *)
  Definition Faithful_Func := ∀ (c c' : Obj) (h h' : (c –≻ c')%morphism),
      F _a h = F _a h' → h = h'.

  (** A functor is said to be full if its arrow map is surjective. *)
  Definition Full_Func :=
    ∀ (c1 c2 : Obj) (h' : ((F _o c1) –≻ (F _o c2))%morphism),
      {h : (c1 –≻ c2)%morphism | F _a h = h'}
  .

  Local Ltac Inv_FTH :=
    match goal with
      [fl : Full_Func |- _] =>
      progress (
          repeat
            match goal with
              [|- context [(F _a (proj1_sig (fl _ _ ?x)))]] =>
              rewrite (proj2_sig (fl _ _ x))
            end
        )
    end
  .

  Local Hint Extern 1 => Inv_FTH.

  Local Hint Extern 1 => rewrite F_compose.

  Local Hint Extern 1 =>
  match goal with
    [fth : Faithful_Func |- _ = _ ] => apply fth
  end
  .

  Local Obligation Tactic := basic_simpl; auto 6.

  (** Any fully-faithful functor is essentially surjective. *)
  Program Definition Fully_Faithful_Essentially_Injective
          (fth : Faithful_Func) (fl : Full_Func) : Essentially_Injective_Func
    :=
      fun c c' eq =>
        {|
          iso_morphism :=
            proj1_sig (
                fl
                  _
                  _
                  match eq in _ = y return
                        (_ –≻ y)%morphism
                  with
                    eq_refl => id (F _o c)
                  end
              );
          inverse_morphism :=
            proj1_sig (
                fl
                  _
                  _
                  match eq in _ = y return
                        (y –≻ _)%morphism
                  with
                    eq_refl => id (F _o c)
                  end
              )
        |}
  .

  (** Any fully-faithful functor is conservative.
      A conservative functor is one for which we have to objects of the domain
      category are isomorphic if their images are ismorphic. *)
  Program Definition Fully_Faithful_Conservative
          (fth : Faithful_Func) (fl : Full_Func)
    : ∀ (c c' : Obj), F _o c ≃ F _o c' → c ≃ c' :=
    fun c c' I =>
      {|
        iso_morphism := proj1_sig (fl _ _ I);
        inverse_morphism := proj1_sig (fl _ _ (I⁻¹))
      |}
  .

End Functor_Properties.

(** Functors Preserve Isomorphisms. *)
Section Functors_Preserve_Isos.
  Context {C C' : Category} (F : C –≻ C')
          {a b : C} (I : (a ≃≃ b ::> C)%isomorphism).

  Program Definition Functors_Preserve_Isos : (F _o a ≃ F _o b)%isomorphism :=
    {|
      iso_morphism := (F _a I)%morphism;
      inverse_morphism := (F _a (I⁻¹))%morphism
    |}.

End Functors_Preserve_Isos.

Section Embedding.
  Context (C C' : Category).

  (**
    An embedding is a functor that is fully-faithful. Such a functor is
    necessarily essentially injective and conservative, i.e.,
    if F _O c ≃ F _O c' then c ≃ c'.
   *)

  Record Embedding : Type :=
    {
      Emb_Func : C –≻ C';

      Emb_Faithful : Faithful_Func Emb_Func;

      Emb_Full : Full_Func Emb_Func
    }.

  Coercion Emb_Func : Embedding >-> Functor.

  Definition Emb_Essent_Inj (E : Embedding) :=
    Fully_Faithful_Essentially_Injective
      (Emb_Func E) (Emb_Faithful E) (Emb_Full E).

  Definition Emb_Conservative (E : Embedding) :=
    Fully_Faithful_Conservative
      (Emb_Func E) (Emb_Faithful E) (Emb_Full E).

End Embedding.

Arguments Emb_Func {_ _} _.
Arguments Emb_Faithful {_ _} _ {_ _} _ _ _.
Arguments Emb_Full {_ _} _ {_ _} _.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** ** Braun trees *)

(** Three Algorithms on Braun Trees - C.
Okasaki(1997):

For any given node of a Braun tree, the
left subtree is either exactly the same
size as the right subtree, or one element
larger.

Braun trees always have minimum height,
and the shape of each Braun tree is
completely determined by its size.

In return for this rigor, algorithms that
manipulate Braun trees are often
exceptionally simple and elegant, and need
not maintain any explicit balance
information.
 *)

Section BinaryTree.

Variable T : Type.

Inductive btree : Type :=
| BTempty
| BTnode
    (l : btree)
    (a : T)
    (r : btree).

Implicit Type bt : btree.

(** A generic binary tree size algorithm *)
Fixpoint bt_size bt : nat :=
  if bt is (BTnode l _ r) then
    (bt_size l +
     bt_size r).+1
  else
    0.

End BinaryTree.

Arguments BTempty {T}.
Arguments BTnode {T} l a r.
Arguments bt_size {T}.

Section BraunTree.

Variable T : Type.
Implicit Type brt : btree T.
Fixpoint is_brtree brt : bool :=
  if brt is (BTnode l _ r) then
    [&& is_brtree l,
        is_brtree r &
        (bt_size l == (bt_size r)) ||
        (bt_size l == (bt_size r).+1)]
  else
    true.

Arguments is_brtree : simpl never.

(** As for the size, with Braun trees
    we can do better! *)

Fixpoint brt_diff brt s : nat :=
  match brt with
  | BTempty => 0
  | BTnode l _ r =>
    if s == 0 then 1
    else if odd s then brt_diff l (s %/ 2)
    else brt_diff r (s.-1 %/ 2)
  end.

Fixpoint brt_size brt : nat :=
  if brt is (BTnode l _ r) then
    let: sr := brt_size r in
    (2 * sr + brt_diff l sr).+1
  else 0.

(** Rewrite multi-rule *)
(** Exercise *)
Lemma is_brtree_node l x r :
  is_brtree (BTnode l x r) ->
  (is_brtree l * is_brtree r) *
  (bt_size r <= bt_size l) *
  ((bt_size l == bt_size r) ||
   (bt_size l == (bt_size r).+1)).
Proof.
Admitted.

(** Exercise *)
Lemma bt_size1 (bt : btree T) :
  bt_size bt = 1 ->
  exists x,
    bt = BTnode BTempty x BTempty.
Proof.
Admitted.

(** Exercise *)
Lemma brt_diff_correct brt s :
  is_brtree brt ->
  (bt_size brt == s) ||
  (bt_size brt == s.+1) ->
  brt_diff brt s = bt_size brt - s.
Proof.
Admitted.

(** The spec of [brt_size] is [bt_size] *)
Lemma brt_size_correct brt :
  is_brtree brt ->
  brt_size brt = bt_size brt.
Proof.
elim: brt => // l _ x r IHr.
move=> /is_brtree_node node /=.
rewrite IHr ?node //.
rewrite brt_diff_correct ?node //.
rewrite mulSn mul1n -addnA.
(* subnKC : forall m n : nat, m <= n -> m + (n - m) = n *)
by rewrite subnKC ?node // addnC.
Qed.

End BraunTree.

Arguments is_brtree {T} brt.
Arguments is_brtree_node {T l x r}.

Section BraunTreeInsert.

Variable T : Type.
Variable leT : rel T.
Implicit Types (a e : T) (bt : btree T).

Fixpoint br_insert e bt : btree T :=
  if bt is (BTnode l a r) then
    if leT e a then
      BTnode
        (br_insert a r) e l
    else
      BTnode
        (br_insert e r) a l
  else
    BTnode
      BTempty
      e
      BTempty.

Lemma br_insert_size e bt :
  bt_size (br_insert e bt) =
  (bt_size bt).+1.
Proof.
Admitted.

Lemma dup {A} : A -> A * A.
Proof. by []. Qed.

Lemma br_insert_is_brtree e bt :
  is_brtree bt ->
  is_brtree (br_insert e bt).
Proof.
elim: bt e => // l IHl a r IHr e.
move=> /is_brtree_node Br.
move=> /=.
case: ifP=> [le | gt] /=.
- rewrite br_insert_size.
  rewrite IHr ?Br //.
  case: Br => _; case/orP=> /eqP->.
  - by rewrite eq_refl orbT.
  by rewrite eq_refl.
(** Exercise: remove proof duplication *)
rewrite br_insert_size.
rewrite IHr ?Br //.
case: Br => _; case/orP=> /eqP->.
- by rewrite eq_refl orbT.
by rewrite eq_refl.
Qed.

End BraunTreeInsert.

Section BraunTreeRemove.

Variable T : Type.
(** [def] is a default element we have
    to have since the type system
    does not prevent us from considering
    the case of empty tree *)
Variable (def : T).
Implicit Types (bt : btree T).

Fixpoint br_remove_min bt : T * btree T :=
  match bt with
  | BTempty => (def, BTempty)
  | BTnode BTempty a r => (a, BTempty)
  | BTnode l a r =>
      let: (min, l) := br_remove_min l in
      (min, BTnode r a l)
  end.

Lemma br_remove_min_is_brtree bt :
  is_brtree bt ->
  is_brtree (br_remove_min bt).2.
Proof.
Admitted.

End BraunTreeRemove.

(** Packing it all together *)
Module Sub.
Section BraunTreeSubType.

Variable T : Type.

Inductive brtree :=
  BrTree (bt : btree T) of is_brtree bt.

Coercion tree_of_brtree (brt : brtree) :=
  let: BrTree bt _ := brt in bt.

Canonical brtree_subType :=
  [subType for tree_of_brtree].

End BraunTreeSubType.
End Sub.

(** Another take on Braun trees *)

(** Extrinsic vs intrinsic verification *)

From Coq Require Import Extraction Program.

Module BraunTreeIntrinsic.
Section BraunTreeIntrinsic.

Variable T : Type.

Inductive brtree : nat -> Type :=
| BrTempty : brtree 0
| BrTnode
    m (l : brtree m)
    (a : T)
    n (r : brtree n)
    of (m = n \/ m = n.+1)
  : brtree (m+n).+1.

Definition brt_size' {n} (brt : brtree n) :=
  n.

(** What's the problem with this definition? *)

End BraunTreeIntrinsic.

Arguments BrTempty {T}.

(** Let's talk about running verified
    algorithms. *)

Extraction brt_size'.

(**
val brt_size' : nat -> 'a1 brtree -> nat

let brt_size' n _ =
  n

But we do not want to keep the size
of the tree at run-time.
*)

Section BraunTree.
Variable T : Type.

Fixpoint brt_slow_size1
           {n} (brt : brtree T n)
  : nat :=
  if brt is (BrTnode _ l _ _ r _) then
    (brt_slow_size1 l +
     brt_slow_size1 r).+1
  else
    0.

Fixpoint brt_slow_size2
           {n} (brt : brtree T n)
  : {s | s = n}.
case: brt.
- by exists 0.
move=> m' l x n' r pf.
exists (sval (brt_slow_size2 _ l) +
        sval (brt_slow_size2 _ r)).+1.
case: (brt_slow_size2 _ _).
case: (brt_slow_size2 _ _).
move=>/=.
by move=> ? -> ? ->.
Defined.

Print brt_slow_size2.

Fail Program Fixpoint brt_slow_size3
           {n} (brt : brtree T n)
  : {s | s = n} :=
  if brt is (BrTnode _ l _ _ r _) then
      ((brt_slow_size3 l) +
       (brt_slow_size3 r)).+1
  else
    0.

Variable leT : rel T.

Fail Fixpoint br_insert {n} (e : T)
         (brt : brtree T n)
  : brtree T n.+1 :=
  if brt is (BrTnode _ l a _ r _) then
    if leT e a then
      BrTnode
        (br_insert a r) e l
    else
      BrTnode
        (br_insert e r) a l
  else
    BrTnode
      BrTempty
      e
      BrTempty
      (or_introl erefl).

(** But we can know express more
    in types, compare this to
    bt_remove_min *)
Fixpoint brt_remove_min {n}
         (bt : brtree T n.+1) :
  T * brtree T n.
Admitted.

End BraunTree.