Require Import Coq.Unicode.Utf8_core.
Require Import Coq.Bool.Bool.

Require Import VarAssign.

Inductive boolExpr : Type :=
| Atom : nat -> bool -> boolExpr
| And  : boolExpr -> boolExpr -> boolExpr
| Or   : boolExpr -> boolExpr -> boolExpr.

Definition optional_and (a b:option bool) : option bool :=
match a with
| None => None
| Some ba => (match b with
             | None => None
             | Some bb => Some (ba && bb) end)
end.

Definition optional_or (a b:option bool) : option bool :=
match a with
| None => None
| Some ba => (match b with
             | None => None
             | Some bb => Some (ba || bb)
             end)
end.

Definition optional_not (a:option bool) : option bool :=
match a with
| None => None
| Some ba => Some (negb ba)
end.

Fixpoint eval_ (be:boolExpr) (va:varAssign) : option bool :=
match be with
| Atom n same => let value := lookup va n in
                 if same then value else (optional_not value)
| And e1 e2   => optional_and (eval_ e1 va) (eval_ e2 va)
| Or e1 e2    => optional_or (eval_ e1 va) (eval_ e2 va)
end.

Inductive eval : boolExpr -> bool -> varAssign -> Prop :=
| eval_atom_same : forall n va res, (assigns va n res) ->
                                    eval (Atom n true) res va
| eval_atom_neg  : forall n va res, (assigns va n res) ->
                                    eval (Atom n false) (negb res) va
| eval_and       : forall e1 res1 e2 res2 va, (eval e1 res1 va) -> (eval e2 res2 va) ->
                                              eval (And e1 e2) (andb res1 res2) va
| eval_or        : forall e1 res1 e2 res2 va, (eval e1 res1 va) -> (eval e2 res2 va) ->
                                              eval (Or e1 e2) (orb res1 res2) va.

Inductive boolExpr' : Type :=
| Atom' : nat -> boolExpr'
| Not'  : boolExpr' -> boolExpr'
| And'  : boolExpr' -> boolExpr' -> boolExpr'
| Or'  : boolExpr' -> boolExpr' -> boolExpr'.

Fixpoint eval_' (be:boolExpr') (va:varAssign) : option bool :=
match be with
| Atom' n     => lookup va n
| Not' e      => optional_not (eval_' e va)
| And' e1 e2  => optional_and (eval_' e1 va) (eval_' e2 va)
| Or' e1 e2  => optional_or (eval_' e1 va) (eval_' e2 va)
end.

Inductive eval' : boolExpr' -> bool -> varAssign -> Prop :=
| eval'_atom : forall n va res, (assigns va n res) -> eval' (Atom' n) res va
| eval'_not  : forall b' res va, eval' b' res va -> eval' (Not' b') (negb res) va
| eval'_and  : forall b1' res1 b2' res2 va, eval' b1' res1 va ->
                                           eval' b2' res2 va ->
                                           eval' (And' b1' b2') (andb res1 res2) va
| eval'_or   : forall b1' res1 b2' res2 va, eval' b1' res1 va ->
                                           eval' b2' res2 va ->
                                           eval' (Or' b1' b2') (orb res1 res2) va.

Fixpoint b_b'_equivalent (be:boolExpr) (be':boolExpr') : bool :=
match be with
| Atom n same => if same
                 then (match be' with
                       | Atom' n => true
                       | _ => false
                      end)
                 else (match be' with
                       | Not' (Atom' n) => true
                       | _ => false
                       end)
| And e1 e2   => (match be' with
                  | And' e1' e2' => (b_b'_equivalent e1 e1') && (b_b'_equivalent e2 e2')
                  | _ => false
                  end)
| Or e1 e2    => (match be' with
                  | Or' e1' e2' => (b_b'_equivalent e1 e1') && (b_b'_equivalent e2 e2')
                  | _ => false
                  end)
end.

Inductive eq_b_b' : boolExpr -> boolExpr' -> Prop :=
| eq_atom_atom' : forall n, eq_b_b' (Atom n true) (Atom' n)
| eq_natom_not' : forall n, eq_b_b' (Atom n false) (Not' (Atom' n))
| eq_and_and'   : forall b1 b1' b2 b2', eq_b_b' b1 b1' -> eq_b_b' b2 b2' ->
                                        eq_b_b' (And b1 b2) (And' b1' b2')
| eq_or_or'     : forall b1 b1' b2 b2', eq_b_b' b1 b1' -> eq_b_b' b2 b2' ->
                                        eq_b_b' (Or b1 b2) (Or' b1' b2').

Compute (b_b'_equivalent (And (Atom 1 true) (Atom 1 false)) (And' (Atom' 1) (Not' (Atom' 1)))).

Lemma same_assigns :
  forall res res' va n, assigns va n res -> assigns va n res' -> res = res'.
Proof.
  intros. induction va.
  - inversion H.
  - inversion H; inversion H0.
    + rewrite H5 in H10. assumption.
    + unfold not in H11. symmetry in H1. apply H11 in H1. inversion H1.
    + unfold not in H6. symmetry in H8. apply H6 in H8. inversion H8.
    + apply IHva. assumption. assumption.
Qed.

Lemma eqb_and :
  forall a b c d, eqb a c = true -> eqb b d = true -> eqb (a && b) (c && d) = true.
intros. destruct a; destruct b; destruct c; destruct d; simpl;
          try reflexivity; try inversion H; try inversion H0.
Qed.

Lemma eqb_or :
  forall a b c d, eqb a c = true -> eqb b d = true -> eqb (a || b) (c || d) = true.
intros. destruct a; destruct b; destruct c; destruct d; simpl;
          try reflexivity; try inversion H; try inversion H0.
Qed.

Theorem eq_b_b'_sameResult :
  forall b res b' res' va, eq_b_b' b b' -> eval b res va -> eval' b' res' va ->
                           (eqb res res') = true.
Proof.
  intro. intro. intro. intro. intro. intro. generalize res res'.
  induction H; intros.
  - inversion H. inversion H0. apply (same_assigns res0 res'0 va n) in H2.
    + rewrite H2. apply eqb_reflx.
    + assumption.
  - inversion H. inversion H0. inversion H6. apply (same_assigns res1 res2 va n) in H2.
    + rewrite H2. destruct res2; reflexivity.
    + assumption.
  - inversion H1. inversion H2.
     apply (IHeq_b_b'1 res1 res3) in H5. apply (IHeq_b_b'2 res2 res4) in H8.
     apply eqb_and. assumption. assumption. assumption. assumption.
  - inversion H1. inversion H2.
     apply (IHeq_b_b'1 res1 res3) in H5. apply (IHeq_b_b'2 res2 res4) in H8.
     apply eqb_or. assumption. assumption. assumption. assumption.
Qed.

(*-----------------------------------------*)

Definition eqOptBool (a b:option bool) : bool :=
match a with
| None    => (match b with
              | None => true
              | Some _ => false
              end)
| Some ba => (match b with
              | None => false
              | Some bb => (eqb ba bb)
              end)
end.

(*
Lemma eq_atom_atom' :
  forall n n0 b, b_b'_equivalent (Atom n b) (Atom' n0) = true -> ((n = n0) /\ (b = true)).
Admitted.
*)
Lemma eq_atom_false_not' :
  forall n b', b_b'_equivalent (Atom n false) (Not' b') = true ->
                    (b' = (Atom' n)).
Admitted.

Lemma neq_atom_not' :
  forall n n0, b_b'_equivalent (Atom n true) (Not' n0) = false.
Admitted.

Lemma neq_atom_and' :
  forall n b b'1 b'2, b_b'_equivalent (Atom n b) (And' b'1 b'2) = false.
Admitted.

Lemma neq_atom_or' :
  forall n b b'1 b'2, b_b'_equivalent (Atom n b) (Or' b'1 b'2) = false.
Admitted.

Lemma neq_and_atom' :
  forall n b1 b2, b_b'_equivalent (And b1 b2) (Atom' n) = false.
Admitted.

Lemma neq_and_not' :
  forall b1 b2 b', b_b'_equivalent (And b1 b2) (Not' b') = false.
Admitted.
(*
Lemma eq_and_and' :
  forall b1 b2 b'1 b'2, b_b'_equivalent b1 b'1 = true ->
                        b_b'_equivalent b2 b'2 = true ->
                        b_b'_equivalent (And b1 b2) (And' b'1 b'2) = true.
Admitted.
*)
Lemma neq_and_or' :
  forall b1 b2 b'1 b'2, b_b'_equivalent (And b1 b2) (Or' b'1 b'2) = false.
Admitted.

Lemma eqOptBool_lookup :
  forall n va, eqOptBool (lookup va n) (lookup va n) = true.
Proof.
  intros. destruct (lookup va n); simpl.
  - apply eqb_reflx.
  - reflexivity.
Qed.

(*
Theorem b_b'_equivalent_sameResult :
  forall b b' va, (b_b'_equivalent b b') = true ->
                  eqOptBool (eval_ b va) (eval_' b' va) = true.
Proof.
  induction b; induction b'; intros.
  * apply eq_atom_atom' in H. inversion H. rewrite H0. rewrite H1. simpl.
    apply (eqOptBool_lookup n0 va).
  * destruct b.
    + rewrite neq_atom_not' in H. inversion H.
    + apply eq_atom_false_not' in H. rewrite H. simpl. destruct (lookup va n); simpl.
      { destruct b; simpl; reflexivity. }
      { reflexivity. }
  * rewrite neq_atom_and' in H. inversion H.
  * rewrite neq_atom_or'  in H. inversion H.
  * rewrite neq_and_atom' in H. inversion H.
  * rewrite neq_and_not'  in H. inversion H.
  * Admitted.

*)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Euclidean Division *)

Require Import NZAxioms NZMulOrder.

(** The first signatures will be common to all divisions over NZ, N and Z *)

Module Type DivMod (Import T:Typ).
 Parameters Inline div modulo : t -> t -> t.
End DivMod.

Module Type DivModNotation (T:Typ)(Import NZ:DivMod T).
 Infix "/" := div.
 Infix "mod" := modulo (at level 40, no associativity).
End DivModNotation.

Module Type DivMod' (T:Typ) := DivMod T <+ DivModNotation T.

Module Type NZDivCommon (Import NZ : NZAxiomsSig')(Import DM : DivMod' NZ).
 Declare Instance div_wd : Proper (eq==>eq==>eq) div.
 Declare Instance mod_wd : Proper (eq==>eq==>eq) modulo.
 Axiom div_mod : forall a b, b ~= 0 -> a == b*(a/b) + (a mod b).
End NZDivCommon.

(** The different divisions will only differ in the conditions
    they impose on [modulo]. For NZ, we only describe behavior
    on positive numbers.

    NB: This axiom would also be true for N and Z, but redundant.
*)

Module Type NZDivSpecific (Import NZ : NZOrdAxiomsSig')(Import DM : DivMod' NZ).
 Axiom mod_bound : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b.
End NZDivSpecific.

Module Type NZDiv (NZ:NZOrdAxiomsSig)
 := DivMod NZ <+ NZDivCommon NZ <+ NZDivSpecific NZ.

Module Type NZDiv' (NZ:NZOrdAxiomsSig) := NZDiv NZ <+ DivModNotation NZ.

Module NZDivPropFunct
 (Import NZ : NZOrdAxiomsSig')
 (Import NZP : NZMulOrderPropSig NZ)
 (Import NZD : NZDiv' NZ)
.

(** Uniqueness theorems *)

Theorem div_mod_unique :
 forall b q1 q2 r1 r2, 0<=r1<b -> 0<=r2<b ->
  b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2.
Proof.
intros b.
assert (U : forall q1 q2 r1 r2,
            b*q1+r1 == b*q2+r2 -> 0<=r1<b -> 0<=r2 -> q1<q2 -> False).
 intros q1 q2 r1 r2 EQ LT Hr1 Hr2.
 contradict EQ.
 apply lt_neq.
 apply lt_le_trans with (b*q1+b).
 rewrite <- add_lt_mono_l. tauto.
 apply le_trans with (b*q2).
 rewrite mul_comm, <- mul_succ_l, mul_comm.
 apply mul_le_mono_nonneg_l; intuition; try order.
 rewrite le_succ_l; auto.
 rewrite <- (add_0_r (b*q2)) at 1.
 rewrite <- add_le_mono_l. tauto.

intros q1 q2 r1 r2 Hr1 Hr2 EQ; destruct (lt_trichotomy q1 q2) as [LT|[EQ'|GT]].
elim (U q1 q2 r1 r2); intuition.
split; auto. rewrite EQ' in EQ. rewrite add_cancel_l in EQ; auto.
elim (U q2 q1 r2 r1); intuition.
Qed.

Theorem div_unique:
 forall a b q r, 0<=a -> 0<=r<b ->
   a == b*q + r -> q == a/b.
Proof.
intros a b q r Ha (Hb,Hr) EQ.
destruct (div_mod_unique b q (a/b) r (a mod b)); auto.
apply mod_bound; order.
rewrite <- div_mod; order.
Qed.

Theorem mod_unique:
 forall a b q r, 0<=a -> 0<=r<b ->
  a == b*q + r -> r == a mod b.
Proof.
intros a b q r Ha (Hb,Hr) EQ.
destruct (div_mod_unique b q (a/b) r (a mod b)); auto.
apply mod_bound; order.
rewrite <- div_mod; order.
Qed.

(** A division by itself returns 1 *)

Lemma div_same : forall a, 0<a -> a/a == 1.
Proof.
intros. symmetry.
apply div_unique with 0; intuition; try order.
now nzsimpl.
Qed.

Lemma mod_same : forall a, 0<a -> a mod a == 0.
Proof.
intros. symmetry.
apply mod_unique with 1; intuition; try order.
now nzsimpl.
Qed.

(** A division of a small number by a bigger one yields zero. *)

Theorem div_small: forall a b, 0<=a<b -> a/b == 0.
Proof.
intros. symmetry.
apply div_unique with a; intuition; try order.
now nzsimpl.
Qed.

(** Same situation, in term of modulo: *)

Theorem mod_small: forall a b, 0<=a<b -> a mod b == a.
Proof.
intros. symmetry.
apply mod_unique with 0; intuition; try order.
now nzsimpl.
Qed.

(** * Basic values of divisions and modulo. *)

Lemma div_0_l: forall a, 0<a -> 0/a == 0.
Proof.
intros; apply div_small; split; order.
Qed.

Lemma mod_0_l: forall a, 0<a -> 0 mod a == 0.
Proof.
intros; apply mod_small; split; order.
Qed.

Lemma div_1_r: forall a, 0<=a -> a/1 == a.
Proof.
intros. symmetry.
apply div_unique with 0; try split; try order; try apply lt_0_1.
now nzsimpl.
Qed.

Lemma mod_1_r: forall a, 0<=a -> a mod 1 == 0.
Proof.
intros. symmetry.
apply mod_unique with a; try split; try order; try apply lt_0_1.
now nzsimpl.
Qed.

Lemma div_1_l: forall a, 1<a -> 1/a == 0.
Proof.
intros; apply div_small; split; auto. apply le_succ_diag_r.
Qed.

Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1.
Proof.
intros; apply mod_small; split; auto. apply le_succ_diag_r.
Qed.

Lemma div_mul : forall a b, 0<=a -> 0<b -> (a*b)/b == a.
Proof.
intros; symmetry.
apply div_unique with 0; try split; try order.
apply mul_nonneg_nonneg; order.
nzsimpl; apply mul_comm.
Qed.

Lemma mod_mul : forall a b, 0<=a -> 0<b -> (a*b) mod b == 0.
Proof.
intros; symmetry.
apply mod_unique with a; try split; try order.
apply mul_nonneg_nonneg; order.
nzsimpl; apply mul_comm.
Qed.

(** * Order results about mod and div *)

(** A modulo cannot grow beyond its starting point. *)

Theorem mod_le: forall a b, 0<=a -> 0<b -> a mod b <= a.
Proof.
intros. destruct (le_gt_cases b a).
apply le_trans with b; auto.
apply lt_le_incl. destruct (mod_bound a b); auto.
rewrite lt_eq_cases; right.
apply mod_small; auto.
Qed.

(* Division of positive numbers is positive. *)

Lemma div_pos: forall a b, 0<=a -> 0<b -> 0 <= a/b.
Proof.
intros.
rewrite (mul_le_mono_pos_l _ _ b); auto; nzsimpl.
rewrite (add_le_mono_r _ _ (a mod b)).
rewrite <- div_mod by order.
nzsimpl.
apply mod_le; auto.
Qed.

Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b.
Proof.
intros a b (Hb,Hab).
assert (LE : 0 <= a/b) by (apply div_pos; order).
assert (MOD : a mod b < b) by (destruct (mod_bound a b); order).
rewrite lt_eq_cases in LE; destruct LE as [LT|EQ]; auto.
exfalso; revert Hab.
rewrite (div_mod a b), <-EQ; nzsimpl; order.
Qed.

Lemma div_small_iff : forall a b, 0<=a -> 0<b -> (a/b==0 <-> a<b).
Proof.
intros a b Ha Hb; split; intros Hab.
destruct (lt_ge_cases a b); auto.
symmetry in Hab. contradict Hab. apply lt_neq, div_str_pos; auto.
apply div_small; auto.
Qed.

Lemma mod_small_iff : forall a b, 0<=a -> 0<b -> (a mod b == a <-> a<b).
Proof.
intros a b Ha Hb. split; intros H; auto using mod_small.
rewrite <- div_small_iff; auto.
rewrite <- (mul_cancel_l _ _ b) by order.
rewrite <- (add_cancel_r _ _ (a mod b)).
rewrite <- div_mod, H by order. now nzsimpl.
Qed.

Lemma div_str_pos_iff : forall a b, 0<=a -> 0<b -> (0<a/b <-> b<=a).
Proof.
intros a b Ha Hb; split; intros Hab.
destruct (lt_ge_cases a b) as [LT|LE]; auto.
rewrite <- div_small_iff in LT; order.
apply div_str_pos; auto.
Qed.

(** As soon as the divisor is strictly greater than 1,
    the division is strictly decreasing. *)

Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a.
Proof.
intros.
assert (0 < b) by (apply lt_trans with 1; auto using lt_0_1).
destruct (lt_ge_cases a b).
rewrite div_small; try split; order.
rewrite (div_mod a b) at 2 by order.
apply lt_le_trans with (b*(a/b)).
rewrite <- (mul_1_l (a/b)) at 1.
rewrite <- mul_lt_mono_pos_r; auto.
apply div_str_pos; auto.
rewrite <- (add_0_r (b*(a/b))) at 1.
rewrite <- add_le_mono_l. destruct (mod_bound a b); order.
Qed.

(** [le] is compatible with a positive division. *)

Lemma div_le_mono : forall a b c, 0<c -> 0<=a<=b -> a/c <= b/c.
Proof.
intros a b c Hc (Ha,Hab).
rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ];
 [|rewrite EQ; order].
rewrite <- lt_succ_r.
rewrite (mul_lt_mono_pos_l c) by order.
nzsimpl.
rewrite (add_lt_mono_r _ _ (a mod c)).
rewrite <- div_mod by order.
apply lt_le_trans with b; auto.
rewrite (div_mod b c) at 1 by order.
rewrite <- add_assoc, <- add_le_mono_l.
apply le_trans with (c+0).
nzsimpl; destruct (mod_bound b c); order.
rewrite <- add_le_mono_l. destruct (mod_bound a c); order.
Qed.

(** The following two properties could be used as specification of div *)

Lemma mul_div_le : forall a b, 0<=a -> 0<b -> b*(a/b) <= a.
Proof.
intros.
rewrite (add_le_mono_r _ _ (a mod b)), <- div_mod by order.
rewrite <- (add_0_r a) at 1.
rewrite <- add_le_mono_l. destruct (mod_bound a b); order.
Qed.

Lemma mul_succ_div_gt : forall a b, 0<=a -> 0<b -> a < b*(S (a/b)).
Proof.
intros.
rewrite (div_mod a b) at 1 by order.
rewrite (mul_succ_r).
rewrite <- add_lt_mono_l.
destruct (mod_bound a b); auto.
Qed.

(** The previous inequality is exact iff the modulo is zero. *)

Lemma div_exact : forall a b, 0<=a -> 0<b -> (a == b*(a/b) <-> a mod b == 0).
Proof.
intros. rewrite (div_mod a b) at 1 by order.
rewrite <- (add_0_r (b*(a/b))) at 2.
apply add_cancel_l.
Qed.

(** Some additionnal inequalities about div. *)

Theorem div_lt_upper_bound:
  forall a b q, 0<=a -> 0<b -> a < b*q -> a/b < q.
Proof.
intros.
rewrite (mul_lt_mono_pos_l b) by order.
apply le_lt_trans with a; auto.
apply mul_div_le; auto.
Qed.

Theorem div_le_upper_bound:
  forall a b q, 0<=a -> 0<b -> a <= b*q -> a/b <= q.
Proof.
intros.
rewrite (mul_le_mono_pos_l _ _ b) by order.
apply le_trans with a; auto.
apply mul_div_le; auto.
Qed.

Theorem div_le_lower_bound:
  forall a b q, 0<=a -> 0<b -> b*q <= a -> q <= a/b.
Proof.
intros a b q Ha Hb H.
destruct (lt_ge_cases 0 q).
rewrite <- (div_mul q b); try order.
apply div_le_mono; auto.
rewrite mul_comm; split; auto.
apply lt_le_incl, mul_pos_pos; auto.
apply le_trans with 0; auto; apply div_pos; auto.
Qed.

(** A division respects opposite monotonicity for the divisor *)

Lemma div_le_compat_l: forall p q r, 0<=p -> 0<q<=r ->
    p/r <= p/q.
Proof.
 intros p q r Hp (Hq,Hqr).
 apply div_le_lower_bound; auto.
 rewrite (div_mod p r) at 2 by order.
 apply le_trans with (r*(p/r)).
 apply mul_le_mono_nonneg_r; try order.
 apply div_pos; order.
 rewrite <- (add_0_r (r*(p/r))) at 1.
 rewrite <- add_le_mono_l. destruct (mod_bound p r); order.
Qed.

(** * Relations between usual operations and mod and div *)

Lemma mod_add : forall a b c, 0<=a -> 0<=a+b*c -> 0<c ->
 (a + b * c) mod c == a mod c.
Proof.
 intros.
 symmetry.
 apply mod_unique with (a/c+b); auto.
 apply mod_bound; auto.
 rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
 now rewrite mul_comm.
Qed.

Lemma div_add : forall a b c, 0<=a -> 0<=a+b*c -> 0<c ->
 (a + b * c) / c == a / c + b.
Proof.
 intros.
 apply (mul_cancel_l _ _ c); try order.
 apply (add_cancel_r _ _ ((a+b*c) mod c)).
 rewrite <- div_mod, mod_add by order.
 rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
 now rewrite mul_comm.
Qed.

Lemma div_add_l: forall a b c, 0<=c -> 0<=a*b+c -> 0<b ->
 (a * b + c) / b == a + c / b.
Proof.
 intros a b c. rewrite (add_comm _ c), (add_comm a).
 intros. apply div_add; auto.
Qed.

(** Cancellations. *)

Lemma div_mul_cancel_r : forall a b c, 0<=a -> 0<b -> 0<c ->
 (a*c)/(b*c) == a/b.
Proof.
 intros.
 symmetry.
 apply div_unique with ((a mod b)*c).
 apply mul_nonneg_nonneg; order.
 split.
 apply mul_nonneg_nonneg; destruct (mod_bound a b); order.
 rewrite <- mul_lt_mono_pos_r; auto. destruct (mod_bound a b); auto.
 rewrite (div_mod a b) at 1 by order.
 rewrite mul_add_distr_r.
 rewrite add_cancel_r.
 rewrite <- 2 mul_assoc. now rewrite (mul_comm c).
Qed.

Lemma div_mul_cancel_l : forall a b c, 0<=a -> 0<b -> 0<c ->
 (c*a)/(c*b) == a/b.
Proof.
 intros. rewrite !(mul_comm c); apply div_mul_cancel_r; auto.
Qed.

Lemma mul_mod_distr_l: forall a b c, 0<=a -> 0<b -> 0<c ->
  (c*a) mod (c*b) == c * (a mod b).
Proof.
 intros.
 rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))).
 rewrite <- div_mod.
 rewrite div_mul_cancel_l; auto.
 rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
 apply div_mod; order.
 rewrite <- neq_mul_0; intuition; order.
Qed.

Lemma mul_mod_distr_r: forall a b c, 0<=a -> 0<b -> 0<c ->
  (a*c) mod (b*c) == (a mod b) * c.
Proof.
 intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l.
Qed.

(** Operations modulo. *)

Theorem mod_mod: forall a n, 0<=a -> 0<n ->
 (a mod n) mod n == a mod n.
Proof.
 intros. destruct (mod_bound a n); auto. now rewrite mod_small_iff.
Qed.

Lemma mul_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n ->
 ((a mod n)*b) mod n == (a*b) mod n.
Proof.
 intros a b n Ha Hb Hn. symmetry.
 generalize (mul_nonneg_nonneg _ _ Ha Hb).
 rewrite (div_mod a n) at 1 2 by order.
 rewrite add_comm, (mul_comm n), (mul_comm _ b).
 rewrite mul_add_distr_l, mul_assoc.
 intros. rewrite mod_add; auto.
 now rewrite mul_comm.
 apply mul_nonneg_nonneg; destruct (mod_bound a n); auto.
Qed.

Lemma mul_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n ->
 (a*(b mod n)) mod n == (a*b) mod n.
Proof.
 intros. rewrite !(mul_comm a). apply mul_mod_idemp_l; auto.
Qed.

Theorem mul_mod: forall a b n, 0<=a -> 0<=b -> 0<n ->
 (a * b) mod n == ((a mod n) * (b mod n)) mod n.
Proof.
 intros. rewrite mul_mod_idemp_l, mul_mod_idemp_r; trivial. reflexivity.
 now destruct (mod_bound b n).
Qed.

Lemma add_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n ->
 ((a mod n)+b) mod n == (a+b) mod n.
Proof.
 intros a b n Ha Hb Hn. symmetry.
 generalize (add_nonneg_nonneg _ _ Ha Hb).
 rewrite (div_mod a n) at 1 2 by order.
 rewrite <- add_assoc, add_comm, mul_comm.
 intros. rewrite mod_add; trivial. reflexivity.
 apply add_nonneg_nonneg; auto. destruct (mod_bound a n); auto.
Qed.

Lemma add_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n ->
 (a+(b mod n)) mod n == (a+b) mod n.
Proof.
 intros. rewrite !(add_comm a). apply add_mod_idemp_l; auto.
Qed.

Theorem add_mod: forall a b n, 0<=a -> 0<=b -> 0<n ->
 (a+b) mod n == (a mod n + b mod n) mod n.
Proof.
 intros. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. reflexivity.
 now destruct (mod_bound b n).
Qed.

Lemma div_div : forall a b c, 0<=a -> 0<b -> 0<c ->
 (a/b)/c == a/(b*c).
Proof.
 intros a b c Ha Hb Hc.
 apply div_unique with (b*((a/b) mod c) + a mod b); trivial.
 (* begin 0<= ... <b*c *)
 destruct (mod_bound (a/b) c), (mod_bound a b); auto using div_pos.
 split.
 apply add_nonneg_nonneg; auto.
 apply mul_nonneg_nonneg; order.
 apply lt_le_trans with (b*((a/b) mod c) + b).
 rewrite <- add_lt_mono_l; auto.
 rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l; auto.
 (* end 0<= ... < b*c *)
 rewrite (div_mod a b) at 1 by order.
 rewrite add_assoc, add_cancel_r.
 rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
 apply div_mod; order.
Qed.

(** A last inequality: *)

Theorem div_mul_le:
 forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a/b) <= (c*a)/b.
Proof.
 intros.
 apply div_le_lower_bound; auto.
 apply mul_nonneg_nonneg; auto.
 rewrite mul_assoc, (mul_comm b c), <- mul_assoc.
 apply mul_le_mono_nonneg_l; auto.
 apply mul_div_le; auto.
Qed.

(** mod is related to divisibility *)

Lemma mod_divides : forall a b, 0<=a -> 0<b ->
 (a mod b == 0 <-> exists c, a == b*c).
Proof.
 split.
 intros. exists (a/b). rewrite div_exact; auto.
 intros (c,Hc). rewrite Hc, mul_comm. apply mod_mul; auto.
 rewrite (mul_le_mono_pos_l _ _ b); auto. nzsimpl. order.
Qed.

End NZDivPropFunct.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Proof of the axioms of choice                                           *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibEpsilon LibRelation.
Generalizable Variables A B.

(** This files includes several versions of the axiom of choice.
    This "axiom" is actually proved in terms of indefinite description.
    Remark: the choice results contained in this file are not very
    useful in practice since it is usually more convenient to use
    the epsilon operator directly. *)

(* ********************************************************************** *)
(* ################################################################# *)
(** * Functional choice *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Functional choice *)

(** This result can be used to build a function from a relation that maps
    every input to at least one output. *)

Lemma functional_choice : forall A B (R:A->B->Prop),
  (forall x, exists y, R x y) ->
  (exists f, forall x, R x (f x)).
Proof using.
  intros. exists (fun x => sig_val (indefinite_description (H x))).
  intro x. apply (sig_proof (indefinite_description (H x))).
Qed.
(* --LATER: the premise is called [defined] in LibRelation *)
(* --LATER: functionality -> definedness? *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Dependent functional choice *)

(** It is a generalization of functional choice to dependent functions. *)

Scheme and_indd := Induction for and Sort Prop.
Scheme eq_indd := Induction for eq Sort Prop.

Lemma dependent_functional_choice :
  forall A (B:A->Type) (R:forall x, B x -> Prop),
  (forall x, exists y, R x y) ->
  (exists f, forall x, R x (f x)).
Proof using.
  introv H.
  pose (B' := { x:A & B x }).
  pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)).
  destruct (functional_choice R') as (f,Hf).
    intros x. destruct (H x) as (y,Hy).
     exists (existT (fun x => B x) x y). split~.
  sets proj1_transparent: (fun P Q (p:P/\Q) => let (a,b) := p in a).
  exists (fun x => eq_rect _ _ (projT2 (f x)) _ (proj1_transparent _ _ (Hf x))).
  intros x. destruct (Hf x) as (Heq,HR) using and_indd.
  destruct (f x). simpls. destruct Heq using eq_indd. apply HR.
Qed.

Arguments dependent_functional_choice [A] [B].

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Guarded functional choice *)

(** Similar to functional choice, except that it targets partial functions *)

Lemma guarded_functional_choice : forall A `{Inhab B} (P : A->Prop) (R : A->B->Prop),
  (forall x, P x -> exists y, R x y) ->
  (exists f, forall x, P x -> R x (f x)).
Proof using.
  intros. apply (functional_choice (fun x y => P x -> R x y)).
  intros. apply~ indep_general_premises.
Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Omniscient functional choice *)

(** Similar to functional choice except that the proof of functionality
    of the relation is given after the fact, for each argument. *)

Lemma omniscient_functional_choice : forall A `{Inhab B} (R : A->B->Prop),
  exists f, forall x, (exists y, R x y) -> R x (f x).
Proof using. intros. apply~ guarded_functional_choice. Qed.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Functional unique choice *)

(** This section provides a similar set of results excepts that it is
    specialized for the case where each argument has a unique image. *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Functional unique choice *)

Lemma functional_unique_choice : forall A B (R:A->B->Prop),
  (forall x , exists! y, R x y) ->
  (exists! f, forall x, R x (f x)).
Proof using.
  intros. destruct (functional_choice R) as [f Hf].
  intros. apply (ex_of_ex_unique (H x)).
  exists f. split. auto.
   intros g Hg. apply fun_ext_1. intros y.
   apply~ (at_most_one_of_ex_unique (H y)).
Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Dependent functional unique choice *)

Theorem dependent_functional_unique_choice :
  forall (A:Type) (B:A->Type) (R:forall (x:A), B x -> Prop),
  (forall (x:A), exists! y : B x, R x y) ->
  (exists! f : (forall (x:A), B x), forall (x:A), R x (f x)).
Proof using.
  intros. destruct (dependent_functional_choice R) as [f Hf].
  intros. apply (ex_of_ex_unique (H x)).
  exists f. split. auto.
   intros g Hg. extens. intros y.
   apply~ (at_most_one_of_ex_unique (H y)).
 Qed.

Arguments dependent_functional_unique_choice [A] [B].

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Guarded functional unique choice *)

Lemma guarded_functional_unique_choice :
  forall A `{Inhab B} (P : A->Prop) (R : A->B->Prop),
  (forall x, P x -> exists! y, R x y) ->
  (exists f, forall x, P x -> R x (f x)).
Proof using.
  introv I M. apply (functional_choice (fun x y => P x -> R x y)).
  intros. apply indep_general_premises.
  introv H. destruct* (M _ H) as (y&Hy&_).
Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Omniscient functional unique choice *)

Lemma omniscient_functional_unique_choice :
  forall A `{Inhab B} (R : A->B->Prop),
  exists f, forall x, (exists! y, R x y) -> R x (f x).
Proof using.
  intros. destruct (omniscient_functional_choice R) as [f F].
  exists f. introv (y&Hy&Uy). autos*.
Qed.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Relational choice *)

(** Relational choice can be used to extract from a relation a subrelation
    that describes a function, by mapping every argument to a unique image. *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Relational choice *)

Lemma rel_choice : forall A B (R:A->B->Prop),
  (forall x, exists y, R x y) ->
  (exists R', rel_incl R' R
           /\ forall x, exists! y, R' x y).
Proof using.
  introv H. destruct~ (functional_choice R) as [f Hf].
  exists (fun x y => f x = y). split.
    introv E. simpls. subst~.
    intros x. exists~ (f x).
Qed.

(* --TODO: Dependent relational choice, is it meaningful?, useful? *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Guarded relational choice *)

Lemma guarded_rel_choice : forall A B (P : A->Prop) (R : A->B->Prop),
  (forall x, P x -> exists y, R x y) ->
  (exists R', rel_incl R' R
           /\ forall x, P x -> exists! y, R' x y).
Proof using.
  intros. destruct (rel_choice (fun (x:sig P) (y:B) => R (sig_val x) y))
   as (R',(HR'R,M)).
    intros (x,HPx). destruct (H _ HPx) as (y,HRxy). exists~ y.
  set (R'' := fun (x:A) (y:B) => exists (H : P x), R' (exist P x H) y).
  exists R''. split.
    intros x y (HPx,HR'xy). apply (HR'R _ _ HR'xy).
    intros x HPx. destruct (M (exist P x HPx)) as (y,(HR'xy,Uniq)).
     exists y. split.
       exists~ HPx.
       intros y' (H'Px,HR'xy'). apply Uniq.
        rewrite~ (proof_irrelevance HPx H'Px).
Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Omniscient relation choice *)

Lemma omniscient_rel_choice : forall A B (R : A->B->Prop),
  exists R', rel_incl R' R
          /\ forall x, (exists y, R x y) -> (exists! y, R' x y).
Proof using. intros. apply~ guarded_rel_choice. Qed.


Lemma NotnotP_andP : (forall (P : Prop), ~(~P /\ ~~P)).
Proof.
  intros.
  easy.
Qed.

Theorem modDeMorgan_imply_TE : (forall (P Q : Prop), ~(~P /\ ~Q) -> P \/ Q)
                               -> (forall (P : Prop), P \/ ~ P).
Proof.
  intros.
  apply H.
  apply NotnotP_andP.
Qed.

Theorem TE_imply_modDN : (forall (P : Prop), P \/ ~P)
                         -> forall (P : Prop), (~P -> P) -> P.
Proof.
  intros.
  destruct (H P).
  + easy.
  + apply H0.
    apply H1.
Qed.

<<<<<<< HEAD
(* En coq, not P = p -> false *)
=======
Theorem modDN_imply_Pierce : (forall (P : Prop), (~P -> P) -> P)
                             -> (forall (P Q : Prop), ((P -> Q) -> P) -> P).
Proof.
  intros.

Qed.
>>>>>>> 00e85d079641e974cef87d45fe3b169c1e270f46


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


(**
Here we interpret HIT signatures in the category of setoids.
 *)
Require Import prelude.all.
Require Import syntax.hit_signature.
Require Import setoids.base.
Require Import setoids.setoid_category.

Require Import algebras.univalent_algebra.
Require Import algebras.set_algebra.

Open Scope cat.

(**
Action of polynomials on equivalence relations.
 *)
Definition poly_eq_rel
           (P : poly_code)
           (X : setoid)
  : eqrel (⦃ P ⦄ (carrier X)).
Proof.
  induction P as [T | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact (path_rel T).
  - exact (carrier_eq X).
  - exact (sum_rel IHP₁ IHP₂).
  - exact (prod_rel IHP₁ IHP₂).
Defined.

(**
Action of polynomials on setoids
 *)
Definition setoid_poly_obj
           (P : poly_code)
           (X : setoid)
  : setoid.
Proof.
  use make_setoid.
  - exact (⦃ P ⦄ (carrier X)).
  - exact (poly_eq_rel P X).
Defined.

(**
This gives rises to a functor
 *)
Definition setoid_poly_mor
           (P : poly_code)
           {X Y : setoid_cat}
           (f : X --> Y)
  : setoid_poly_obj P X → setoid_poly_obj P Y
  := #⦃ P ⦄ (map_carrier f).

Definition setoid_poly_mor_is_morphism
           (P : poly_code)
           {X Y : setoid_cat}
           (f : X --> Y)
           {x y : setoid_poly_obj P X}
           (p : x ≡ y)
  : setoid_poly_mor P f x ≡ setoid_poly_mor P f y.
Proof.
  induction P as [T | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact p.
  - exact (map_eq f p).
  - induction x as [x | x], y as [y | y].
    + exact (IHP₁ _ _ p).
    + exact (fromempty p).
    + exact (fromempty p).
    + exact (IHP₂ _ _ p).
  - exact (IHP₁ _ _ (pr1 p) ,, IHP₂ _ _ (pr2 p)).
Qed.

Definition setoid_poly_data
           (P : poly_code)
  : functor_data setoid_cat setoid_cat.
Proof.
  use make_functor_data.
  - exact (setoid_poly_obj P).
  - intros X Y f.
    use make_setoid_morphism.
    + exact (setoid_poly_mor P f).
    + exact (@setoid_poly_mor_is_morphism P _ _ f).
Defined.

Definition setoid_poly_is_functor
           (P : poly_code)
  : is_functor (setoid_poly_data P).
Proof.
  split.
  - intros X.
    use setoid_morphism_eq.
    intros x ; cbn.
    induction P as [T | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
    + reflexivity.
    + reflexivity.
    + induction x as [x | x].
      * exact (maponpaths inl (IHP₁ x)).
      * exact (maponpaths inr (IHP₂ x)).
    + apply pathsdirprod.
      * exact (IHP₁ (pr1 x)).
      * exact (IHP₂ (pr2 x)).
  - intros X Y Z f g.
    use setoid_morphism_eq.
    intros x ; cbn.
    induction P as [T | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
    + reflexivity.
    + reflexivity.
    + induction x as [x | x].
      * exact (maponpaths inl (IHP₁ x)).
      * exact (maponpaths inr (IHP₂ x)).
    + apply pathsdirprod.
      * exact (IHP₁ (pr1 x)).
      * exact (IHP₂ (pr2 x)).
Qed.

Definition setoid_poly
           (P : poly_code)
  : setoid_cat ⟶ setoid_cat.
Proof.
  use make_functor.
  - exact (setoid_poly_data P).
  - exact (setoid_poly_is_functor P).
Defined.

Notation "⟨ P ⟩" := (setoid_poly P) (at level 10). (* \< \>} *)
Notation "⟨ P ⟩ X" := (setoid_poly P X : setoid) (at level 10).
Notation "# ⟨ P ⟩" := (#(setoid_poly P)) (at level 10).

(**
Univalent category of setoid prealgebras
 *)
Definition setoid_prealgebras
           (P : poly_code)
  : univalent_category.
Proof.
  use make_univalent_category.
  - exact (FunctorAlg (⟨ P ⟩)).
  - apply is_univalent_FunctorAlg.
    apply setoid_cat_is_univalent.
Defined.

(**
The carrier of a setoid prealgebra is a set prealgebra
 *)
Definition setoid_prealgebra_to_set_prealgebra
           (P : poly_code)
  : setoid_prealgebras P → set_prealgebras P.
Proof.
  intros X.
  use tpair.
  - exact (pr11 X).
  - exact (pr12 X).
Defined.

(**
Forgetful functor of setoid prealgebras
 *)
Definition prealgebra_setoid
           (P : poly_code)
  : setoid_prealgebras P ⟶ setoid_cat
  := forget_algebras _.

(**
Interpretation of endpoins
 *)
Definition setoid_endpoint
           {A P Q : poly_code}
           (e : endpoint A P Q)
           (X : setoid_prealgebras A)
  : setoid_cat ⟦ ⟨ P ⟩ (pr1 X) , ⟨ Q ⟩ (pr1 X) ⟧.
Proof.
  use make_setoid_morphism.
  - exact (set_endpoint e (setoid_prealgebra_to_set_prealgebra A X)).
  - intros x y p.
    induction e.
    + exact p.
    + exact (IHe2 _ _ (IHe1 _ _ p)).
    + exact p.
    + exact p.
    + exact (pr1 p).
    + exact (pr2 p).
    + split.
      * exact (IHe1 _ _ p).
      * exact (IHe2 _ _ p).
    + reflexivity.
    + exact (maponpaths f p).
    + exact (map_eq _ p).
Defined.

(**
Definition of algebras of HIT signatures in setoids
 *)
Definition is_setoid_algebra
           (Σ : hit_signature)
  : hsubtype (setoid_prealgebras (point_arg Σ)).
Proof.
  intro X.
  refine (∀ (j : path_index Σ)
            (x : ⟨ path_arg Σ j ⟩ (prealgebra_setoid _ X)),
             _).
  simple refine (make_hProp _ _).
  + exact (
        (pr1 (setoid_endpoint (path_lhs Σ j) X) x)
          ≡
          pr1 (setoid_endpoint (path_rhs Σ j) X) x).
  + apply isaprop_setoid_eq.
Defined.

(**
Univalent category of setoid algebras
 *)
Definition setoid_algebra
           (Σ : hit_signature)
  : univalent_category.
Proof.
  use make_univalent_category.
  - exact (full_sub_precategory (is_setoid_algebra Σ)).
  - apply is_univalent_full_subcat.
    apply univalent_category_is_univalent.
Defined.

(**
Projections of algebras
 *)
Section AlgebraProjections.
  Context {Σ : hit_signature}.
  Variable (X : setoid_algebra Σ).

  Definition alg_to_prealg
    : setoid_prealgebras (point_arg Σ)
    := pr1 X.

  Definition alg_carrier
    : setoid
    := pr1 alg_to_prealg.

  Definition alg_operation
    : setoid_cat ⟦ ⟨ point_arg Σ ⟩ alg_carrier , alg_carrier ⟧
    := pr2 alg_to_prealg.

  Definition alg_paths
             (j : path_index Σ)
             (x : ⟨ path_arg Σ j ⟩ alg_carrier)
    : pr1 (setoid_endpoint (path_lhs Σ j) alg_to_prealg) x
      ≡
      pr1 (setoid_endpoint (path_rhs Σ j) alg_to_prealg) x
    := pr2 X j x.
End AlgebraProjections.

(**
Projections of algebra maps
 *)
Section AlgebraMapProjections.
  Context {Σ : hit_signature}
          {X Y : setoid_algebra Σ}.
  Variable (f : X --> Y).

  Definition alg_map_carrier
    : setoid_morphism (alg_carrier X) (alg_carrier Y)
    := pr11 f.

  Definition alg_map_is_alg_mor
    : is_algebra_mor (⟨ point_arg Σ ⟩) (alg_to_prealg X) (alg_to_prealg Y) alg_map_carrier
    := pr21 f.
End AlgebraMapProjections.

(**
Builder
 *)
Definition make_prealgebra
           {P : poly_code}
           (X : setoid)
           (c : setoid_cat ⟦ ⟨ P ⟩ X , X ⟧)
  : setoid_prealgebras P.
Proof.
  use tpair.
  - exact X.
  - exact c.
Defined.

Definition make_algebra
           {Σ : hit_signature}
           (X : setoid)
           (c : setoid_cat ⟦ ⟨ point_arg Σ ⟩ X , X ⟧)
           (p : ∏ (j : path_index Σ) (x : ⟨ path_arg Σ j ⟩ X),
                pr1 (setoid_endpoint (path_lhs Σ j) (make_prealgebra X c)) x
                ≡
                pr1 (setoid_endpoint (path_rhs Σ j) (make_prealgebra X c)) x)
  : setoid_algebra Σ.
Proof.
  use tpair.
  - exact (make_prealgebra X c).
  - exact p.
Defined.

Definition make_algebra_map
           {Σ : hit_signature}
           {X Y : setoid_algebra Σ}
           (f : setoid_cat ⟦ alg_carrier X , alg_carrier Y ⟧)
           (p : ∏ (x : ⦃ point_arg Σ ⦄ (pr1 (alg_carrier X))),
                pr1 f (pr1 (alg_operation X) x)
                =
                pr1 (alg_operation Y) (#⦃ point_arg Σ ⦄ (pr1 f) x))
  : X --> Y.
Proof.
  use tpair.
  - use tpair.
    + exact f.
    + use setoid_morphism_eq.
      exact p.
  - exact tt.
Defined.

(**
Equality principle for maps beween algebras
 *)
Definition algebra_map_eq
           {Σ : hit_signature}
           {X Y : setoid_algebra Σ}
           {f g : X --> Y}
           (e : ∏ (x : alg_carrier X), alg_map_carrier f x = alg_map_carrier g x)
  : f = g.
Proof.
  use subtypePath.
  {
    intro ; exact isapropunit.
  }
  use subtypePath.
  {
    intro ; simpl.
    apply setoid_cat.
  }
  exact (setoid_morphism_eq _ _ e).
Qed.


(** * StlcProp: Properties of STLC *)

Require Import SfLib.
Require Import Maps.
Require Import Types.
Require Import Stlc.
Require Import Smallstep.
Module STLCProp.
Import STLC.

(** In this chapter, we develop the fundamental theory of the Simply
    Typed Lambda Calculus -- in particular, the type safety
    theorem. *)

(* ###################################################################### *)
(** * Canonical Forms *)

(** As we saw for the simple calculus in the [Types] chapter, the
    first step in establishing basic properties of reduction and types
    is to identify the possible _canonical forms_ (i.e., well-typed
    closed values) belonging to each type.  For [Bool], these are the boolean
    values [ttrue] and [tfalse].  For arrow types, the canonical forms
    are lambda-abstractions.  *)

Lemma canonical_forms_bool : forall t,
  empty |- t \in TBool ->
  value t ->
  (t = ttrue) \/ (t = tfalse).
Proof.
  intros t HT HVal.
  inversion HVal; intros; subst; try inversion HT; auto.
Qed.

Lemma canonical_forms_fun : forall t T1 T2,
  empty |- t \in (TArrow T1 T2) ->
  value t ->
  exists x u, t = tabs x T1 u.
Proof.
  intros t T1 T2 HT HVal.
  inversion HVal; intros; subst; try inversion HT; subst; auto.
  exists x0. exists t0.  auto.
Qed.

(* ###################################################################### *)
(** * Progress *)

(** As before, the _progress_ theorem tells us that closed, well-typed
    terms are not stuck: either a well-typed term is a value, or it
    can take a reduction step.  The proof is a relatively
    straightforward extension of the progress proof we saw in the
    [Types] chapter.  We'll give the proof in English first, then the
    formal version. *)

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.

(** _Proof_: By induction on the derivation of [|- t \in T].

    - The last rule of the derivation cannot be [T_Var], since a
      variable is never well typed in an empty context.

    - The [T_True], [T_False], and [T_Abs] cases are trivial, since in
      each of these cases we can see by inspecting the rule that [t]
      is a value.

    - If the last rule of the derivation is [T_App], then [t] has the
      form [t1 t2] for som e[t1] and [t2], where we know that [t1] and
      [t2] are also well typed in the empty context; in particular,
      there exists a type [T2] such that [|- t1 \in T2 -> T] and [|-
      t2 \in T2].  By the induction hypothesis, either [t1] is a value
      or it can take a reduction step.

        - If [t1] is a value, then consider [t2], which by the other
          induction hypothesis must also either be a value or take a step.

            - Suppose [t2] is a value.  Since [t1] is a value with an
              arrow type, it must be a lambda abstraction; hence [t1
              t2] can take a step by [ST_AppAbs].

            - Otherwise, [t2] can take a step, and hence so can [t1
              t2] by [ST_App2].

        - If [t1] can take a step, then so can [t1 t2] by [ST_App1].

    - If the last rule of the derivation is [T_If], then [t = if t1
      then t2 else t3], where [t1] has type [Bool].  By the IH, [t1]
      either is a value or takes a step.

        - If [t1] is a value, then since it has type [Bool] it must be
          either [true] or [false].  If it is [true], then [t] steps
          to [t2]; otherwise it steps to [t3].

        - Otherwise, [t1] takes a step, and therefore so does [t] (by
          [ST_If]). *)

Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  induction Ht; subst Gamma...
  - (* T_Var *)
    (* contradictory: variables cannot be typed in an
       empty context *)
    inversion H.

  - (* T_App *)
    (* [t] = [t1 t2].  Proceed by cases on whether [t1] is a
       value or steps... *)
    right. destruct IHHt1...
    + (* t1 is a value *)
      destruct IHHt2...
      * (* t2 is also a value *)
        assert (exists x0 t0, t1 = tabs x0 T11 t0).
        eapply canonical_forms_fun; eauto.
        destruct H1 as [x0 [t0 Heq]]. subst.
        exists ([x0:=t2]t0)...

      * (* t2 steps *)
        inversion H0 as [t2' Hstp]. exists (tapp t1 t2')...

    + (* t1 steps *)
      inversion H as [t1' Hstp]. exists (tapp t1' t2)...

  - (* T_If *)
    right. destruct IHHt1...

    + (* t1 is a value *)
      destruct (canonical_forms_bool t1); subst; eauto.

    + (* t1 also steps *)
      inversion H as [t1' Hstp]. exists (tif t1' t2 t3)...
Qed.

(** **** Exercise: 3 stars, optional (progress_from_term_ind)  *)
(** Show that progress can also be proved by induction on terms
    instead of induction on typing derivations. *)

Theorem progress' : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.
Proof.
  intros t.
  induction t; intros T Ht; auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** * Preservation *)

(** The other half of the type soundness property is the preservation
    of types during reduction.  For this, we need to develop some
    technical machinery for reasoning about variables and
    substitution.  Working from top to bottom (from the high-level
    property we are actually interested in to the lowest-level
    technical lemmas that are needed by various cases of the more
    interesting proofs), the story goes like this:

      - The _preservation theorem_ is proved by induction on a typing
        derivation, pretty much as we did in the [Types] chapter.  The
        one case that is significantly different is the one for the
        [ST_AppAbs] rule, whose definition uses the substitution
        operation.  To see that this step preserves typing, we need to
        know that the substitution itself does.  So we prove a...

      - _substitution lemma_, stating that substituting a (closed)
        term [s] for a variable [x] in a term [t] preserves the type
        of [t].  The proof goes by induction on the form of [t] and
        requires looking at all the different cases in the definition
        of substitition.  This time, the tricky cases are the ones for
        variables and for function abstractions.  In both cases, we
        discover that we need to take a term [s] that has been shown
        to be well-typed in some context [Gamma] and consider the same
        term [s] in a slightly different context [Gamma'].  For this
        we prove a...

      - _context invariance_ lemma, showing that typing is preserved
        under "inessential changes" to the context [Gamma] -- in
        particular, changes that do not affect any of the free
        variables of the term.  And finally, for this, we need a
        careful definition of...

      - the _free variables_ of a term -- i.e., those variables
        mentioned in a term and not in the scope of an enclosing
        function abstraction binding a variable of the same name.

   To make Coq happy, we need to formalize the story in the opposite
   order... *)

(* ###################################################################### *)
(** ** Free Occurrences *)

(** A variable [x] _appears free in_ a term _t_ if [t] contains some
    occurrence of [x] that is not under an abstraction labeled [x].
    For example:
      - [y] appears free, but [x] does not, in [\x:T->U. x y]
      - both [x] and [y] appear free in [(\x:T->U. x y) x]
      - no variables appear free in [\x:T->U. \y:T. x y]

    Formally: *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
      y <> x  ->
      appears_free_in x t12 ->
      appears_free_in x (tabs y T11 t12)
  | afi_if1 : forall x t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (tif t1 t2 t3).

Hint Constructors appears_free_in.

(** A term in which no variables appear free is said to be _closed_. *)

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

(** **** Exercise: 1 star (afi)  *)
(** If the definition of [appears_free_in] is not crystal clear to
    you, it is a good idea to take a piece of paper and write out the
    rules in informal inference-rule notation.  (Although it is a
    rather low-level, technical definition, understanding it is
    crucial to understanding substitution and its properties, which
    are really the crux of the lambda-calculus.) *)
(** [] *)

(* ###################################################################### *)
(** ** Substitution *)

(** To prove that substitution preserves typing, we first need a
    technical lemma connecting free variables and typing contexts: If
    a variable [x] appears free in a term [t], and if we know [t] is
    well typed in context [Gamma], then it must be the case that
    [Gamma] assigns a type to [x]. *)

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', Gamma x = Some T'.

(** _Proof_: We show, by induction on the proof that [x] appears
      free in [t], that, for all contexts [Gamma], if [t] is well
      typed under [Gamma], then [Gamma] assigns some type to [x].

      - If the last rule used was [afi_var], then [t = x], and from
        the assumption that [t] is well typed under [Gamma] we have
        immediately that [Gamma] assigns a type to [x].

      - If the last rule used was [afi_app1], then [t = t1 t2] and [x]
        appears free in [t1].  Since [t] is well typed under [Gamma],
        we can see from the typing rules that [t1] must also be, and
        the IH then tells us that [Gamma] assigns [x] a type.

      - Almost all the other cases are similar: [x] appears free in a
        subterm of [t], and since [t] is well typed under [Gamma], we
        know the subterm of [t] in which [x] appears is well typed
        under [Gamma] as well, and the IH gives us exactly the
        conclusion we want.

      - The only remaining case is [afi_abs].  In this case [t =
        \y:T11.t12], and [x] appears free in [t12]; we also know that
        [x] is different from [y].  The difference from the previous
        cases is that whereas [t] is well typed under [Gamma], its
        body [t12] is well typed under [(Gamma, y:T11)], so the IH
        allows us to conclude that [x] is assigned some type by the
        extended context [(Gamma, y:T11)].  To conclude that [Gamma]
        assigns a type to [x], we appeal to lemma [update_neq], noting
        that [x] and [y] are different variables. *)

Proof.
  intros x t T Gamma H H0. generalize dependent Gamma.
  generalize dependent T.
  induction H;
         intros; try solve [inversion H0; eauto].
  - (* afi_abs *)
    inversion H1; subst.
    apply IHappears_free_in in H7.
    rewrite update_neq in H7; assumption.
Qed.

(** Next, we'll need the fact that any term [t] which is well typed in
    the empty context is closed (it has no free variables). *)

(** **** Exercise: 2 stars, optional (typable_empty__closed)  *)
Corollary typable_empty__closed : forall t T,
    empty |- t \in T  ->
    closed t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Sometimes, when we have a proof [Gamma |- t : T], we will need to
    replace [Gamma] by a different context [Gamma'].  When is it safe
    to do this?  Intuitively, it must at least be the case that
    [Gamma'] assigns the same types as [Gamma] to all the variables
    that appear free in [t]. In fact, this is the only condition that
    is needed. *)

Lemma context_invariance : forall Gamma Gamma' t T,
     Gamma |- t \in T  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     Gamma' |- t \in T.

(** _Proof_: By induction on the derivation of
    [Gamma |- t \in T].

      - If the last rule in the derivation was [T_Var], then [t = x]
        and [Gamma x = T].  By assumption, [Gamma' x = T] as well, and
        hence [Gamma' |- t \in T] by [T_Var].

      - If the last rule was [T_Abs], then [t = \y:T11. t12], with [T
        = T11 -> T12] and [Gamma, y:T11 |- t12 \in T12].  The
        induction hypothesis is that, for any context [Gamma''], if
        [Gamma, y:T11] and [Gamma''] assign the same types to all the
        free variables in [t12], then [t12] has type [T12] under
        [Gamma''].  Let [Gamma'] be a context which agrees with
        [Gamma] on the free variables in [t]; we must show [Gamma' |-
        \y:T11. t12 \in T11 -> T12].

        By [T_Abs], it suffices to show that [Gamma', y:T11 |- t12 \in
        T12].  By the IH (setting [Gamma'' = Gamma', y:T11]), it
        suffices to show that [Gamma, y:T11] and [Gamma', y:T11] agree
        on all the variables that appear free in [t12].

        Any variable occurring free in [t12] must be either [y] or
        some other variable.  [Gamma, y:T11] and [Gamma', y:T11]
        clearly agree on [y].  Otherwise, note that any variable other
        than [y] that occurs free in [t12] also occurs free in [t =
        \y:T11. t12], and by assumption [Gamma] and [Gamma'] agree on
        all such variables; hence so do [Gamma, y:T11] and [Gamma',
        y:T11].

      - If the last rule was [T_App], then [t = t1 t2], with [Gamma |-
        t1 \in T2 -> T] and [Gamma |- t2 \in T2].  One induction
        hypothesis states that for all contexts [Gamma'], if [Gamma']
        agrees with [Gamma] on the free variables in [t1], then [t1]
        has type [T2 -> T] under [Gamma']; there is a similar IH for
        [t2].  We must show that [t1 t2] also has type [T] under
        [Gamma'], given the assumption that [Gamma'] agrees with
        [Gamma] on all the free variables in [t1 t2].  By [T_App], it
        suffices to show that [t1] and [t2] each have the same type
        under [Gamma'] as under [Gamma].  But all free variables in
        [t1] are also free in [t1 t2], and similarly for [t2]; hence
        the desired result follows from the induction hypotheses. *)

Proof with eauto.
  intros.
  generalize dependent Gamma'.
  induction H; intros; auto.
  - (* T_Var *)
    apply T_Var. rewrite <- H0...
  - (* T_Abs *)
    apply T_Abs.
    apply IHhas_type. intros x1 Hafi.
    (* the only tricky step... the [Gamma'] we use to
       instantiate is [update Gamma x T11] *)
    unfold update. unfold t_update. destruct (beq_id x0 x1) eqn: Hx0x1...
    rewrite beq_id_false_iff in Hx0x1. auto.
  - (* T_App *)
    apply T_App with T11...
Qed.

(** Now we come to the conceptual heart of the proof that reduction
    preserves types -- namely, the observation that _substitution_
    preserves types.

    Formally, the so-called _Substitution Lemma_ says this: Suppose we
    have a term [t] with a free variable [x], and suppose we've been
    able to assign a type [T] to [t] under the assumption that [x] has
    some type [U].  Also, suppose that we have some other term [v] and
    that we've shown that [v] has type [U].  Then, since [v] satisfies
    the assumption we made about [x] when typing [t], we should be
    able to substitute [v] for each of the occurrences of [x] in [t]
    and obtain a new term that still has type [T]. *)

(** _Lemma_: If [Gamma,x:U |- t \in T] and [|- v \in U], then [Gamma |-
    [x:=v]t \in T]. *)

Lemma substitution_preserves_typing : forall Gamma x U t v T,
     update Gamma x U |- t \in T ->
     empty |- v \in U   ->
     Gamma |- [x:=v]t \in T.

(** One technical subtlety in the statement of the lemma is that
    we assign [v] the type [U] in the _empty_ context -- in other
    words, we assume [v] is closed.  This assumption considerably
    simplifies the [T_Abs] case of the proof (compared to assuming
    [Gamma |- v \in U], which would be the other reasonable assumption
    at this point) because the context invariance lemma then tells us
    that [v] has type [U] in any context at all -- we don't have to
    worry about free variables in [v] clashing with the variable being
    introduced into the context by [T_Abs].

    The substitution lemma can be viewed as a kind of "commutation"
    property.  Intuitively, it says that substitution and typing can
    be done in either order: we can either assign types to the terms
    [t] and [v] separately (under suitable contexts) and then combine
    them using substitution, or we can substitute first and then
    assign a type to [ [x:=v] t ] -- the result is the same either
    way.

    _Proof_: We show, by induction on [t], that for all [T] and
    [Gamma], if [Gamma,x:U |- t \in T] and [|- v \in U], then [Gamma
    |- [x:=v]t \in T].

      - If [t] is a variable there are two cases to consider,
        depending on whether [t] is [x] or some other variable.

          - If [t = x], then from the fact that [Gamma, x:U |- x \in
            T] we conclude that [U = T].  We must show that [[x:=v]x =
            v] has type [T] under [Gamma], given the assumption that
            [v] has type [U = T] under the empty context.  This
            follows from context invariance: if a closed term has type
            [T] in the empty context, it has that type in any context.

          - If [t] is some variable [y] that is not equal to [x], then
            we need only note that [y] has the same type under [Gamma,
            x:U] as under [Gamma].

      - If [t] is an abstraction [\y:T11. t12], then the IH tells us,
        for all [Gamma'] and [T'], that if [Gamma',x:U |- t12 \in T']
        and [|- v \in U], then [Gamma' |- [x:=v]t12 \in T'].

        The substitution in the conclusion behaves differently
        depending on whether [x] and [y] are the same variable.

        First, suppose [x = y].  Then, by the definition of
        substitution, [[x:=v]t = t], so we just need to show [Gamma |-
        t \in T].  But we know [Gamma,x:U |- t : T], and, since [y]
        does not appear free in [\y:T11. t12], the context invariance
        lemma yields [Gamma |- t \in T].

        Second, suppose [x <> y].  We know [Gamma,x:U,y:T11 |- t12 \in
        T12] by inversion of the typing relation, from which
        [Gamma,y:T11,x:U |- t12 \in T12] follows by the context
        invariance lemma, so the IH applies, giving us [Gamma,y:T11 |-
        [x:=v]t12 \in T12].  By [T_Abs], [Gamma |- \y:T11. [x:=v]t12
        \in T11->T12], and by the definition of substitution (noting
        that [x <> y]), [Gamma |- \y:T11. [x:=v]t12 \in T11->T12] as
        required.

      - If [t] is an application [t1 t2], the result follows
        straightforwardly from the definition of substitution and the
        induction hypotheses.

      - The remaining cases are similar to the application case.

    One more technical note: This proof is a rare case where an
    induction on terms, rather than typing derivations, yields a
    simpler argument.  The reason for this is that the assumption
    [update Gamma x U |- t \in T] is not completely generic, in the
    sense that one of the "slots" in the typing relation -- namely the
    context -- is not just a variable, and this means that Coq's
    native induction tactic does not give us the induction hypothesis
    that we want.  It is possible to work around this, but the needed
    generalization is a little tricky.  The term [t], on the other
    hand, _is_ completely generic. *)

Proof with eauto.
  intros Gamma x U t v T Ht Ht'.
  generalize dependent Gamma. generalize dependent T.
  induction t; intros T Gamma H;
    (* in each case, we'll want to get at the derivation of H *)
    inversion H; subst; simpl...
  - (* tvar *)
    rename i into y. destruct (beq_idP x y) as [Hxy|Hxy].
    + (* x=y *)
      subst.
      rewrite update_eq in H2.
      inversion H2; subst. clear H2.
                  eapply context_invariance... intros x Hcontra.
      destruct (free_in_context _ _ T empty Hcontra) as [T' HT']...
      inversion HT'.
    + (* x<>y *)
      apply T_Var. rewrite update_neq in H2...
  - (* tabs *)
    rename i into y. apply T_Abs.
    destruct (beq_idP x y) as [Hxy | Hxy].
    + (* x=y *)
      subst.
      eapply context_invariance...
      intros x Hafi. unfold update, t_update.
      destruct (beq_id y x) eqn: Hyx...
    + (* x<>y *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (beq_idP y z) as [Hyz | Hyz]; subst; trivial.
      rewrite <- beq_id_false_iff in Hxy.
      rewrite Hxy...
Qed.

(* ###################################################################### *)
(** ** Main Theorem *)

(** We now have the tools we need to prove preservation: if a closed
    term [t] has type [T] and takes a step to [t'], then [t']
    is also a closed term with type [T].  In other words, the small-step
    reduction relation preserves types. *)

Theorem preservation : forall t t' T,
     empty |- t \in T  ->
     t ==> t'  ->
     empty |- t' \in T.

(** _Proof_: By induction on the derivation of [|- t \in T].

    - We can immediately rule out [T_Var], [T_Abs], [T_True], and
      [T_False] as the final rules in the derivation, since in each of
      these cases [t] cannot take a step.

    - If the last rule in the derivation was [T_App], then [t = t1
      t2].  There are three cases to consider, one for each rule that
      could have been used to show that [t1 t2] takes a step to [t'].

        - If [t1 t2] takes a step by [ST_App1], with [t1] stepping to
          [t1'], then by the IH [t1'] has the same type as [t1], and
          hence [t1' t2] has the same type as [t1 t2].

        - The [ST_App2] case is similar.

        - If [t1 t2] takes a step by [ST_AppAbs], then [t1 =
          \x:T11.t12] and [t1 t2] steps to [[x:=t2]t12]; the
          desired result now follows from the fact that substitution
          preserves types.

    - If the last rule in the derivation was [T_If], then [t = if t1
      then t2 else t3], and there are again three cases depending on
      how [t] steps.

        - If [t] steps to [t2] or [t3], the result is immediate, since
          [t2] and [t3] have the same type as [t].

        - Otherwise, [t] steps by [ST_If], and the desired conclusion
          follows directly from the induction hypothesis. *)

Proof with eauto.
  remember (@empty ty) as Gamma.
  intros t t' T HT. generalize dependent t'.
  induction HT;
       intros t' HE; subst Gamma; subst;
       try solve [inversion HE; subst; auto].
  - (* T_App *)
    inversion HE; subst...
    (* Most of the cases are immediate by induction,
       and [eauto] takes care of them *)
    + (* ST_AppAbs *)
      apply substitution_preserves_typing with T11...
      inversion HT1...
Qed.

(** **** Exercise: 2 stars, recommended (subject_expansion_stlc)  *)
(** An exercise in the [Types] chapter asked about the subject
    expansion property for the simple language of arithmetic and
    boolean expressions.  Does this property hold for STLC?  That is,
    is it always the case that, if [t ==> t'] and [has_type t' T],
    then [empty |- t \in T]?  If so, prove it.  If not, give a
    counter-example not involving conditionals.

(* FILL IN HERE *)
[]
*)

(* ###################################################################### *)
(** * Type Soundness *)

(** **** Exercise: 2 stars, optional (type_soundness)  *)
(** Put progress and preservation together and show that a well-typed
    term can _never_ reach a stuck state.  *)

Definition stuck (t:tm) : Prop :=
  (normal_form step) t /\ ~ value t.

Corollary soundness : forall t t' T,
  empty |- t \in T ->
  t ==>* t' ->
  ~(stuck t').
Proof.
  intros t t' T Hhas_type Hmulti. unfold stuck.
  intros [Hnf Hnot_val]. unfold normal_form in Hnf.
  induction Hmulti.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** * Uniqueness of Types *)

(** **** Exercise: 3 stars (types_unique)  *)
(** Another nice property of the STLC is that types are unique: a
    given term (in a given context) has at most one type. *)
(** Formalize this statement and prove it. *)

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

(* ###################################################################### *)
(** * Additional Exercises *)

(** **** Exercise: 1 star (progress_preservation_statement)  *)
(** Without peeking at their statements above, write down the progress
    and preservation theorems for the simply typed lambda-calculus. *)
(** [] *)

(** **** Exercise: 2 stars (stlc_variation1)  *)
(** Suppose we add a new term [zap] with the following reduction rule

                         ---------                  (ST_Zap)
                         t ==> zap

and the following typing rule:

                      ----------------               (T_Zap)
                      Gamma |- zap : T

    Which of the following properties of the STLC remain true in
    the presence of these rules?  For each property, write either
    "remains true" or "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars (stlc_variation2)  *)
(** Suppose instead that we add a new term [foo] with the following
    reduction rules:

                       -----------------                (ST_Foo1)
                       (\x:A. x) ==> foo

                         ------------                   (ST_Foo2)
                         foo ==> true

    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars (stlc_variation3)  *)
(** Suppose instead that we remove the rule [ST_App1] from the [step]
    relation. Which of the following properties of the STLC remain
    true in the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars, optional (stlc_variation4)  *)
(** Suppose instead that we add the following new rule to the
    reduction relation:

            ----------------------------------        (ST_FunnyIfTrue)
            (if true then t1 else t2) ==> true

    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars, optional (stlc_variation5)  *)
(** Suppose instead that we add the following new rule to the typing
    relation:

                 Gamma |- t1 \in Bool->Bool->Bool
                     Gamma |- t2 \in Bool
                 ------------------------------          (T_FunnyApp)
                    Gamma |- t1 t2 \in Bool

    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars, optional (stlc_variation6)  *)
(** Suppose instead that we add the following new rule to the typing
    relation:

                     Gamma |- t1 \in Bool
                     Gamma |- t2 \in Bool
                    ---------------------               (T_FunnyApp')
                    Gamma |- t1 t2 \in Bool

    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars, optional (stlc_variation7)  *)
(** Suppose we add the following new rule to the typing relation
    of the STLC:

                         ------------------- (T_FunnyAbs)
                         |- \x:Bool.t \in Bool

    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

[]
*)

End STLCProp.

(* ###################################################################### *)
(* ###################################################################### *)
(** ** Exercise: STLC with Arithmetic *)

(** To see how the STLC might function as the core of a real
    programming language, let's extend it with a concrete base
    type of numbers and some constants and primitive
    operators. *)

Module STLCArith.

(** To types, we add a base type of natural numbers (and remove
    booleans, for brevity). *)

Inductive ty : Type :=
  | TArrow : ty -> ty -> ty
  | TNat   : ty.

(** To terms, we add natural number constants, along with
    successor, predecessor, multiplication, and zero-testing. *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | tnat  : nat -> tm
  | tsucc : tm -> tm
  | tpred : tm -> tm
  | tmult : tm -> tm -> tm
  | tif0  : tm -> tm -> tm -> tm.

(** **** Exercise: 4 stars (stlc_arith)  *)
(** Finish formalizing the definition and properties of the STLC extended
    with arithmetic.  Specifically:

    - Copy the whole development of STLC that we went through above (from
      the definition of values through the Type Soundness theorem), and
      paste it into the file at this point.

    - Extend the definitions of the [subst] operation and the [step]
      relation to include appropriate clauses for the arithmetic operators.

    - Extend the proofs of all the properties (up to [soundness]) of
      the original STLC to deal with the new syntactic forms.  Make
      sure Coq accepts the whole file. *)

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

End STLCArith.

(** $Date: 2016-05-26 16:17:19 -0400 (Thu, 26 May 2016) $ *)


(** * Maps: Total and Partial Maps *)

(** _Maps_ (or _dictionaries_) are ubiquitous data structures both
    generally and in the theory of programming languages in
    particular; we're going to need them in many places in the coming
    chapters.  They also make a nice case study using ideas we've seen
    in previous chapters, including building data structures out of
    higher-order functions (from [Basics] and [Poly]) and the use of
    reflection to streamline proofs (from [IndProp]).

    We'll define two flavors of maps: _total_ maps, which include a
    "default" element to be returned when a key being looked up
    doesn't exist, and _partial_ maps, which return an [option] to
    indicate success or failure.  The latter is defined in terms of
    the former, using [None] as the default element. *)

(* ################################################################# *)
(** * The Coq Standard Library *)

(** One small digression before we begin...

    Unlike the chapters we have seen so far, this one does not
    [Require Import] the chapter before it (and, transitively, all the
    earlier chapters).  Instead, in this chapter and from now, on
    we're going to import the definitions and theorems we need
    directly from Coq's standard library stuff.  You should not notice
    much difference, though, because we've been careful to name our
    own definitions and theorems the same as their counterparts in the
    standard library, wherever they overlap. *)

From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.

(** Documentation for the standard library can be found at
    http://coq.inria.fr/library/.

    The [Search] command is a good way to look for theorems involving
    objects of specific types.  Take a minute now to experiment with it. *)

(* ################################################################# *)
(** * Identifiers *)

(** First, we need a type for the keys that we use to index into our
    maps.  In [Lists.v] we introduced a fresh type [id] for a similar
    purpose; here and for the rest of _Software Foundations_ we will
    use the [string] type from Coq's standard library. *)

(** To compare strings, we define the function [eqb_string], which
    internally uses the function [string_dec] from Coq's string
    library. *)

Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

(** (The function [string_dec] comes from Coq's string library.
    If you check the result type of [string_dec], you'll see that it
    does not actually return a [bool], but rather a type that looks
    like [{x = y} + {x <> y}], called a [sumbool], which can be
    thought of as an "evidence-carrying boolean."  Formally, an
    element of [sumbool] is either a proof that two things are equal
    or a proof that they are unequal, together with a tag indicating
    which.  But for present purposes you can think of it as just a
    fancy [bool].) *)

(** Now we need a few basic properties of string equality... *)
Theorem eqb_string_refl : forall s : string, true = eqb_string s s.
Proof. intros s. unfold eqb_string. destruct (string_dec s s) as [|Hs].
  - reflexivity.
  - destruct Hs. reflexivity.
Qed.

(** The following useful property follows from an analogous
    lemma about strings: *)

Theorem eqb_string_true_iff : forall x y : string,
    eqb_string x y = true <-> x = y.
Proof.
   intros x y.
   unfold eqb_string.
   destruct (string_dec x y) as [|Hs].
   - subst. split. reflexivity. reflexivity.
   - split.
     + intros contra. discriminate contra.
     + intros H. rewrite H in Hs. destruct Hs. reflexivity.
Qed.

(** Similarly: *)

Theorem eqb_string_false_iff : forall x y : string,
    eqb_string x y = false <-> x <> y.
Proof.
  intros x y. rewrite <- eqb_string_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

(** This handy variant follows just by rewriting: *)

Theorem false_eqb_string : forall x y : string,
   x <> y -> eqb_string x y = false.
Proof.
  intros x y. rewrite eqb_string_false_iff.
  intros H. apply H. Qed.

(* ################################################################# *)
(** * Total Maps *)

(** Our main job in this chapter will be to build a definition of
    partial maps that is similar in behavior to the one we saw in the
    [Lists] chapter, plus accompanying lemmas about its behavior.

    This time around, though, we're going to use _functions_, rather
    than lists of key-value pairs, to build maps.  The advantage of
    this representation is that it offers a more _extensional_ view of
    maps, where two maps that respond to queries in the same way will
    be represented as literally the same thing (the very same function),
    rather than just "equivalent" data structures.  This, in turn,
    simplifies proofs that use maps. *)

(** We build partial maps in two steps.  First, we define a type of
    _total maps_ that return a default value when we look up a key
    that is not present in the map. *)

Definition total_map (A : Type) := string -> A.

(** Intuitively, a total map over an element type [A] is just a
    function that can be used to look up [string]s, yielding [A]s. *)

(** The function [t_empty] yields an empty total map, given a default
    element; this map always returns the default element when applied
    to any string. *)

Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).

(** More interesting is the [update] function, which (as before) takes
    a map [m], a key [x], and a value [v] and returns a new map that
    takes [x] to [v] and takes every other key to whatever [m] does. *)

Definition t_update {A : Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if eqb_string x x' then v else m x'.

(** This definition is a nice example of higher-order programming:
    [t_update] takes a _function_ [m] and yields a new function
    [fun x' => ...] that behaves like the desired map. *)

(** For example, we can build a map taking [string]s to [bool]s, where
    ["foo"] and ["bar"] are mapped to [true] and every other key is
    mapped to [false], like this: *)

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true)
           "bar" true.

(** Next, let's introduce some new notations to facilitate working
    with maps. *)

(** First, we will use the following notation to create an empty
    total map with a default value. *)
Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).

Example example_empty := (_ !-> false).

(** We then introduce a convenient notation for extending an existing
    map with some bindings. *)
Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

(** The [examplemap] above can now be defined as follows: *)

Definition examplemap' :=
  ( "bar" !-> true;
    "foo" !-> true;
    _     !-> false
  ).

(** This completes the definition of total maps.  Note that we
    don't need to define a [find] operation because it is just
    function application! *)

Example update_example1 : examplemap' "baz" = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap' "foo" = true.
Proof. reflexivity. Qed.

Example update_example3 : examplemap' "quux" = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap' "bar" = true.
Proof. reflexivity. Qed.

(** To use maps in later chapters, we'll need several fundamental
    facts about how they behave. *)

(** Even if you don't work the following exercises, make sure
    you thoroughly understand the statements of the lemmas! *)

(** (Some of the proofs require the functional extensionality axiom,
    which is discussed in the [Logic] chapter.) *)

(** **** Exercise: 1 star, standard, optional (t_apply_empty)

    First, the empty map returns its default element for all keys: *)

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
    (_ !-> v) x = v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

    Next, if we update a map [m] at a key [x] with a new value [v]
    and then look up [x] in the map resulting from the [update], we
    get back [v]: *)

Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
    (x !-> v ; m) x = v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

    On the other hand, if we update a map [m] at a key [x1] and then
    look up a _different_ key [x2] in the resulting map, we get the
    same result that [m] would have given: *)

Theorem t_update_neq : forall (A : Type) (m : total_map A) x1 x2 v,
    x1 <> x2 ->
    (x1 !-> v ; m) x2 = m x2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

    If we update a map [m] at a key [x] with a value [v1] and then
    update again with the same key [x] and another value [v2], the
    resulting map behaves the same (gives the same result when applied
    to any key) as the simpler map obtained by performing just
    the second [update] on [m]: *)

Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
    (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** For the final two lemmas about total maps, it's convenient to use
    the reflection idioms introduced in chapter [IndProp].  We begin
    by proving a fundamental _reflection lemma_ relating the equality
    proposition on [id]s with the boolean function [eqb_id]. *)

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

    Use the proof of [eqbP] in chapter [IndProp] as a template to
    prove the following: *)

Lemma eqb_stringP : forall x y : string,
    reflect (x = y) (eqb_string x y).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Now, given [string]s [x1] and [x2], we can use the tactic
    [destruct (eqb_stringP x1 x2)] to simultaneously perform case
    analysis on the result of [eqb_string x1 x2] and generate
    hypotheses about the equality (in the sense of [=]) of [x1]
    and [x2]. *)

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

    With the example in chapter [IndProp] as a template, use
    [eqb_stringP] to prove the following theorem, which states that
    if we update a map to assign key [x] the same value as it already
    has in [m], then the result is equal to [m]: *)

Theorem t_update_same : forall (A : Type) (m : total_map A) x,
    (x !-> m x ; m) = m.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard, recommended (t_update_permute)

    Use [eqb_stringP] to prove one final property of the [update]
    function: If we update a map [m] at two distinct keys, it doesn't
    matter in which order we do the updates. *)

Theorem t_update_permute : forall (A : Type) (m : total_map A)
                                  v1 v2 x1 x2,
    x2 <> x1 ->
    (x1 !-> v1 ; x2 !-> v2 ; m)
    =
    (x2 !-> v2 ; x1 !-> v1 ; m).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Partial maps *)

(** Finally, we define _partial maps_ on top of total maps.  A partial
    map with elements of type [A] is simply a total map with elements
    of type [option A] and default element [None]. *)

Definition partial_map (A : Type) := total_map (option A).

Definition empty {A : Type} : partial_map A :=
  t_empty None.

Definition update {A : Type} (m : partial_map A)
           (x : string) (v : A) :=
  (x !-> Some v ; m).

(** We introduce a similar notation for partial maps: *)
Notation "x '|->' v ';' m" := (update m x v)
  (at level 100, v at next level, right associativity).

(** We can also hide the last case when it is empty. *)
Notation "x '|->' v" := (update empty x v)
  (at level 100).

Example examplepmap :=
  ("Church" |-> true ; "Turing" |-> false).

(** We now straightforwardly lift all of the basic lemmas about total
    maps to partial maps.  *)

Lemma apply_empty : forall (A : Type) (x : string),
    @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall (A : Type) (m : partial_map A) x v,
    (x |-> v ; m) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (A : Type) (m : partial_map A) x1 x2 v,
    x2 <> x1 ->
    (x2 |-> v ; m) x1 = m x1.
Proof.
  intros A m x1 x2 v H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall (A : Type) (m : partial_map A) x v1 v2,
    (x |-> v2 ; x |-> v1 ; m) = (x |-> v2 ; m).
Proof.
  intros A m x v1 v2. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall (A : Type) (m : partial_map A) x v,
    m x = Some v ->
    (x |-> v ; m) = m.
Proof.
  intros A m x v H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (A : Type) (m : partial_map A)
                                x1 x2 v1 v2,
    x2 <> x1 ->
    (x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
Proof.
  intros A m x1 x2 v1 v2. unfold update.
  apply t_update_permute.
Qed.

(* Wed Jan 9 12:02:45 EST 2019 *)


Require Import ZArith Arith Bool Omega.

Open Scope Z_scope.

(* The key to this corollary is that if s=Zsqrt_plain x, then
  s*s < (s+1) * (s+1), as stated by the companion theorem
  Zsqrt_interval, and the squaring operation is monotonic only
  for positive values. *)

Theorem div_Zsqrt :
 forall m n p:Z, 0 < m < n ->
  n=m*p-> 0 < m <= Z.sqrt n \/ 0 < p <= Z.sqrt n.
Proof.
 intros m n p Hint Heq.
 elim (Z_lt_le_dec (Z.sqrt n) m);
 elim (Z_lt_le_dec (Z.sqrt n) p).
 -  intros Hltm Hltp.
    assert (Hlem : (Z.sqrt n)+1 <= m) by  omega.
    assert (Hlep : (Z.sqrt n)+1 <= p) by  omega.
    elim (Z.lt_irrefl n).
    apply Z.lt_le_trans with (((Z.sqrt n)+1)*((Z.sqrt n)+1)).
    assert (Hposn : 0 <= n) by  omega.
    generalize (Z.sqrt_spec n Hposn);cbv zeta;intro H23.
    intuition.
    pattern n at 3; rewrite Heq.
    apply Zmult_le_compat; try omega.
    generalize (Z.sqrt_nonneg n).
    omega.
    generalize (Z.sqrt_nonneg n).
    omega.
 - intros Hple _; right; split; auto.
   apply Zmult_lt_0_reg_r with m; try tauto.
   rewrite Zmult_comm; omega.
 -  intros _ Hmle; left; split; tauto.
 -  intros _ Hmle; left; split; tauto.
Qed.

Definition divides_bool (p t:Z) : bool :=
 match t mod p with
   0 => true
 | _ => false
 end.

Fixpoint test_odds (n:nat) (p t:Z) {struct n} : bool :=
 match n with
 | 0%nat => negb (divides_bool 2 t)
 | S n' =>
   if test_odds n' (p - 2) t then negb (divides_bool p t) else false
 end.

Definition prime_test (n:nat) : bool :=
 match n with
 | 0%nat => false
 | 1%nat => false
 | S (S n) =>
  let x := (Z_of_nat (S (S n))) in
  let s := (Z.sqrt x) in
  let (half_s, even_bit) :=
    match s with
    | Zpos(xI h) => (Zpos h, 0)
    | Zpos(xO h) => (Zpos h, 1)
    | Zpos xH => (0, 0)
    | _ => (0, 1)
    end  in
  test_odds (Z.abs_nat half_s) (s + even_bit) x
 end.

Time Eval lazy beta iota delta zeta in (prime_test 2333).

(* Time Eval compute in (prime_test 2333).

  This command takes a much longer time.  The reason is that Z.sqrt_plain
  calls a strongly specified function, which builds a proof term that is
  large, but is discarded later.  Lazy computation avoid the useless
  work. *)

(* we use the same axiom as in the book, it is corrected in another exercise.
 *)

Axiom verif_divide :
  (forall m p:nat, 0 < m -> 0 < p ->
   (exists q:nat, m = q*p) ->(Z_of_nat m mod Z_of_nat p = 0)%Z )%nat.

(* This axiom is actually a lemma used in the same other exercise. *)

Axiom Z_to_nat_and_back :
 forall x:Z, (0 <= x)%Z -> (Z_of_nat (Z.abs_nat x))=x.

Theorem test_odds_correct2 :
  forall n x:nat,
    (1 < x)%nat ->
  forall p:Z,
    test_odds n p (Z_of_nat x) = true ->
    ~(exists y:nat, x = y*2)%nat.
Proof.
 intros n; elim n.
 - unfold test_odds, divides_bool; intros x H1ltx _ Heq Hex.
   assert (Heq' : Z_of_nat x mod Z_of_nat 2 = 0).
  +  apply verif_divide; auto with zarith.
  +  simpl (Z_of_nat 2) in Heq'; rewrite Heq' in Heq; simpl in Heq; discriminate.

 - clear n; intros n IHn x H1ltx p; simpl.
   case_eq (test_odds n (p - 2) (Z_of_nat x)).
   +  intros Htest' _ ; apply (IHn x H1ltx (p -2)); auto.
   +  intros; discriminate.
Qed.

Theorem Z_of_nat_le :
  forall x y, Z_of_nat x <= Z_of_nat y -> (x <= y)%nat.
Proof.
 intros; omega.
Qed.

Theorem test_odds_correct :
  forall (n x:nat)(p:Z),
   p = 2*(Z_of_nat n)+1 ->
   (1 < x)%nat -> test_odds n p (Z_of_nat x) = true ->
   forall q:nat, (1 < q <= 2*n+1)%nat -> ~(exists y:nat, x = q*y)%nat.
Proof.
 induction n.
 -  intros x p Hp1 H1ltx Hn q Hint.
    elimtype False;  omega.
  - intros x p Hp H1ltx; simpl (test_odds (S n) p (Z_of_nat x));
    intros Htest q (H1ltq, Hqle).
    case_eq (test_odds n (p -2) (Z_of_nat x)).
    + intros Htest'true.
      rewrite Htest'true in Htest.
      unfold divides_bool in Htest.
      elim (le_lt_or_eq q (2*S n + 1)%nat Hqle).
      *  intros Hqlt.
         assert (Hqle': (q <= (2* S n))%nat) by  omega.
         elim (le_lt_or_eq q (2 * S n)%nat Hqle').
         replace (2*S n)%nat with (2*n +2)%nat.
         intros Hqlt'.
         assert (Hqle'' : (q <= 2*n +1)%nat) by omega.
         apply (IHn x (p - 2)); auto with zarith arith;
         try (rewrite Hp; rewrite inj_S; unfold Z.succ); ring.
         ring.
         intros Hq (y, Hdiv); elim (test_odds_correct2 n x H1ltx (p - 2)); auto.
         exists (S n * y)%nat; rewrite Hdiv; rewrite Hq; ring.

      * intros Hq Hex; assert (Hp' : p = Z_of_nat q).
        rewrite Hp; rewrite Hq; rewrite inj_plus; rewrite inj_mult; auto.
        rewrite Hp' in Htest; rewrite (verif_divide x q) in Htest.
        simpl in Htest; discriminate.
        omega.
        omega.
        elim Hex; intros y Hdiv; exists y; rewrite Hdiv; ring.
    + intros Htest'; rewrite Htest' in Htest; simpl in Htest; discriminate.
Qed.

Axiom divisor_smaller :
  (forall m p:nat, 0 < m -> forall q:nat, m = q*p -> q <= m)%nat.

Theorem lt_Zpos : forall p:positive, 0 < Zpos p.
Proof.
 intros p; elim p.
 -  intros; rewrite Zpos_xI; omega.
 -  intros; rewrite Zpos_xO; omega.
 -  auto with zarith.
Qed.

Theorem Zneg_lt : forall p:positive, Zneg p < 0.
Proof.
 intros p; elim p.
 -  intros; rewrite Zneg_xI; omega.
 -  intros; rewrite Zneg_xO; omega.
 -  auto with zarith.
Qed.

Theorem prime_test_correct :
 forall n:nat, prime_test n = true ->
 ~(exists k:nat, k <> 1 /\ k <> n /\ (exists q:nat, n = q*k))%nat.
Proof.
 intros n; case_eq n.
 -  simpl;  intros Heq Hd; discriminate.
 -  intros n0; case_eq n0.
   +  simpl; intros Heq1 Heq2 Hd; discriminate.
   + unfold prime_test; intros n1 Heqn0 Heqn.
     assert (H1ltn : (1 < n)%nat).
     *  rewrite Heqn; auto with arith.
     * rewrite <- Heqn.
       lazy beta zeta delta [prime_test].
       case_eq (Z.sqrt (Z_of_nat n)).
       intros Hsqrt_eq.
       elim (Zlt_asym 1 (Z_of_nat n)).
       omega.
       lapply (Z.sqrt_spec (Z_of_nat n)).
       rewrite Hsqrt_eq; simpl.
       omega.
       omega.
       intros p Hsqrt_eq Htest_eq (k, (Hn1, (Hnn, (q,Heq)))).
       assert (H0ltn:(0 < n)%nat) by  omega.
       assert (Hkltn:(k < n)%nat).
       assert (Heq' : n=(k*q)%nat).
       rewrite Heq; ring.
       generalize (divisor_smaller n q H0ltn k Heq').
       omega.
       assert (Hex: exists k':nat, (1 < (Z_of_nat k') <= (Z.sqrt (Z_of_nat n))) /\
               (exists q':nat, n=(k'*q')%nat)).
       elim (div_Zsqrt (Z_of_nat k) (Z_of_nat n) (Z_of_nat q)).
       intros Hint1; exists k;split.
       omega.
       exists q; rewrite Heq; ring.
       intros Hint2; exists q; split.
       split.
       elim (Zle_or_lt (Z_of_nat q) 1); auto.
       intros hqle1;  assert (Hq1: q = 1%nat).
       omega.
       rewrite Hq1 in Heq; simpl in Heq; elim Hnn; rewrite Heq; ring.
       tauto.
       exists k; auto.
       split.
       case_eq k.
       intros Hk0; rewrite Hk0 in Heq; rewrite Heq in H1ltn;
       rewrite mult_0_r in H1ltn; omega.
       intros; unfold Z.lt; simpl; auto.
       omega.
       rewrite Zmult_comm; rewrite <- inj_mult; rewrite Heq;auto.
       elim Hex; intros k' ((H1ltk', Hk'ltsqrt), Hex'); clear Hex.
       case_eq p.
       intros p' Hp; rewrite Hp in Htest_eq.
       elim (test_odds_correct (Z.abs_nat (Zpos p'))
           n (Zpos p)) with k'.
       rewrite Z_to_nat_and_back.
       rewrite Hp.
       auto with zarith.
       auto with zarith.
       auto.
       repeat rewrite Zminus_0_r in Htest_eq.
       rewrite Hp; auto.
       split.
       omega.
       apply Z_of_nat_le.
       rewrite inj_plus.
       rewrite inj_mult.
       rewrite Z_to_nat_and_back.
       simpl (Z_of_nat 2).
       simpl (Z_of_nat 1).
       rewrite <- Zpos_xI.
       rewrite <- Hp.
       rewrite <- Hsqrt_eq; auto.
       auto with zarith.
       auto.
       intros p' Hp; rewrite Hp in Htest_eq.
       elim (test_odds_correct (Z.abs_nat (Zpos p')) n (Zpos p + 1))
       with k'.
       rewrite Z_to_nat_and_back.
       rewrite Hp; rewrite Zpos_xO; ring.
       generalize (lt_Zpos p'); intros; omega.
       auto.
       rewrite <- Hp in Htest_eq; auto.
       split; try omega.
       apply Z_of_nat_le.
       rewrite inj_plus.
       rewrite inj_mult.
       rewrite Z_to_nat_and_back.
       simpl (Z_of_nat 2); simpl (Z_of_nat 1).
       rewrite <- Zpos_xO.
       rewrite <- Hp; omega.
       auto with zarith.
       auto.
       intros Hp; rewrite Hp in Hsqrt_eq.
       rewrite Hsqrt_eq in Hk'ltsqrt.
       omega.
       intros p Hsqrt_eq.
       elim (Zle_not_lt 0 (Z.sqrt (Z_of_nat n))).
       apply Z.sqrt_nonneg.
       rewrite Hsqrt_eq.
       apply Zneg_lt.
Qed.


(* Ord: type class for ordered types. *)

Require Import EquivDec Compare_dec Relation_Definitions Le.
Require Import Coq.Classes.RelationClasses.
Require Import Equal Relations.

Open Scope list_scope.

Check transitive.

Class Ord (T: Type) {eq_: Eq T} := {
  lessthan: relation T;
  lt_trans: transitive lessthan;
  lt_asym: asymmetric lessthan;
  lt_dec: forall a b: T, {lessthan a b} + {a = b} + {lessthan b a}
}.

Instance ord_nat : Ord nat := {
  lessthan := lt;
  lt_dec := lt_eq_lt_dec
}.
Proof.
  unfold transitive.
  apply Lt.lt_trans.
  unfold asymmetric.
  apply NPeano.Nat.lt_asymm.
Defined.

Section ListLt.
  Context {T: Type}.
  Context {eq_elem: Eq T}.
  Context {ord_elem: Ord T}.

  Inductive list_lt: list T -> list T -> Prop :=
    | lt_nil  : forall x l, list_lt nil (x::l)
    | lt_cons : forall x xs y ys,
        lessthan x y -> list_lt (x::xs) (y::ys).

  Lemma list_lt_trans: transitive list_lt.
  Proof.
    unfold transitive. intros xs ys zs H1 H2.
    generalize dependent ys.
    generalize dependent zs.
    induction xs.
      intros.
      destruct zs. inversion H1. inversion H2. constructor.
      intros.
      inversion H1.
      destruct zs. subst. inversion H2.
      subst. inversion H2. subst.
      constructor. apply (lt_trans a y t H4 H0).
  Qed.

  Lemma list_lt_asym: asymmetric list_lt.
  Proof.
    unfold asymmetric. unfold not. intros.
    inversion H. subst. inversion H0. subst.
    inversion H0. subst. apply (lt_asym x y H1 H3).
  Qed.

  (* Theorem list_lt_asym_dec: forall l l', {list_lt l l'} + {~list_lt l l'}. *)
  (* Proof. *)
  (*   intros l. induction l. *)
  (*   destruct l'. right. intuition. inversion H. *)
  (*   left. constructor. *)
  (*   intros l'. *)
  (*   destruct l'. right. intuition. inversion H. *)
  (*   destruct (lt_dec a t). *)
  (*   destruct s. *)
  (*   destruct (IHl l'). *)
  (*   left. constructor. apply l0. apply l1. *)
  (*   right. intuition. inversion H. subst. contradiction. *)
  (*   right. intuition. inversion H. subst.  *)
  (*   apply (lt_asym t t). apply H3. apply H3. *)
  (*   right. intuition. inversion H. subst. apply (lt_asym a t). *)
  (*   apply H3. apply l0. *)
  (* Defined. *)

  Theorem list_lt_dec: forall l l', {list_lt l l'} + {l = l'} + {list_lt l' l}.
  Proof.
    intros l.
    induction l.
      intros l'.
      destruct l'. auto. left. left. constructor.
      intros l'.
      destruct l'.
        right. constructor.
        destruct (lt_dec a t).
        inversion s.
        left. left. constructor. apply H.
        destruct (IHl l').
        inversion s0. left. left.

        destruct (list_lt_asym_dec l l').
    auto. induction l. destruct l'. left. auto.
    elimtype False. apply b. constructor.
    destruct l'. right. constructor.

  Instance list_ord
    {eqlist: Eq (list T)}: Ord (list T) := {
    lessthan := list_lt;
    lt_trans := list_lt_trans;
    lt_asym := list_lt_asym
  }.
  (* decision procedure *)

Theorem list_leq_partialorder:
  forall T {eq_elem: Eq T} {ord_elem: Ord T}, partial_order list_leq.
Proof.
  intros.
  unfold partial_order.
  split. unfold preorder.
  split. unfold reflexive. intros l.
  induction l. constructor. constructor. apply eq_implies_leq. reflexivity.
  apply IHl.
  unfold transitive.
    intros xs ys zs H.

(* Instance list_leq_partial_order  *)
(*    {T: Type} {eq_elem: Eq T} {ord_elem: Ord T}:  *)
(*    PartialOrder eq (@list_leq T eq_elem ord_elem). *)
(* Proof. *)
(*   split. *)
(*   (* Prove reflexivity *) *)
(*     unfold Reflexive. *)
(*     intros l. *)
(*     induction l. constructor. *)
(*     constructor. apply eq_implies_leq. reflexivity. apply IHl. *)
(*   (* Prove symmetry *) *)
(*     unfold Symmetric. *)
(*     intros xs ys H. *)
(*     induction xs. *)

Instance ord_list
  {T: Type}
  {eq_elem: Eq T}
  {ord_elem: Ord T}
  {eq_list: Eq (list T)}:
  Ord (list T) := {
  leq := list_leq
}.