Require Import Arith Arith.Even Arith.Div2 Omega.
Require Import Coq.Logic.JMeq Coq.Program.Wf.
Require Import Program.Syntax List.
Require Import Braun.common.util.
Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Wellfounded.Lexicographic_Product.

Set Implicit Arguments.

(* fl_log(n) = floor(log_2(n+1)) *)
Program Fixpoint fl_log n {wf lt n} : nat :=
  match n with
    | 0 => 0
    | S n' => S (fl_log (div2 n'))
  end.

(* cl_log(n) = ceiling(log_2(n+1)) *)
(* which is the same as Racket's 'integer-length' *)
Program Fixpoint cl_log n {wf lt n} : nat :=
  match n with
    | 0 => 0
    | S n' => S (cl_log (div2 n))
  end.

Example fl_log_ex :
  map fl_log
      [0;1;2;3;4;5;6;7;8;9;10;11;12;13;14;15]
  = [0;1;1;2;2;2;2;3;3;3;3; 3; 3; 3; 3; 4].
Proof.
  compute; reflexivity.
Qed.

Example cl_log_ex :
  map cl_log
      [0;1;2;3;4;5;6;7;8;9;10;11;12;13;14;15]
  = [0;1;2;2;3;3;3;3;4;4;4; 4; 4; 4; 4; 4].
Proof.
  compute; reflexivity.
Qed.

Lemma fl_log_div2' :
  forall n,
    fl_log (S n) = S (fl_log (div2 n)).
Proof.
  intros.
  apply (Fix_eq _ lt lt_wf (fun _ => nat)).
  intuition.
  destruct x; [ reflexivity | repeat f_equal].
Qed.
Hint Rewrite fl_log_div2'.

Lemma fl_log_div2'' :  forall n, div2 (n + 1) < S n.
Proof.
  intros n.
  replace (n+1) with (S n);[|omega].
  auto.
Qed.
Hint Resolve fl_log_div2''.

Lemma cl_log_zero :
  cl_log 0 = 0.
Proof.
  apply (Fix_eq _ lt lt_wf (fun _ => nat)).
  intuition.
  destruct x; [ reflexivity | repeat f_equal].
Qed.
Hint Rewrite cl_log_zero.

Lemma cl_log_div2' :
  forall n,
    cl_log (S n) = S (cl_log (div2 (S n))).
Proof.
  intros.
  apply (Fix_eq _ lt lt_wf (fun _ => nat)).
  intuition.
  destruct x; [ reflexivity | repeat f_equal].
Qed.
Hint Rewrite cl_log_div2'.

Lemma fl_log_zero :
  fl_log 0 = 0.
Proof.
  apply (Fix_eq _ lt lt_wf (fun _ => nat)).
  intuition.
  destruct x; [ reflexivity | repeat f_equal].
Qed.
Hint Rewrite fl_log_zero.

Lemma fl_log_div2 :
  forall n,
    fl_log (div2 n) + 1 = fl_log (S n).
Proof.
  intros n.
  rewrite fl_log_div2'.
  intuition.
Qed.
Hint Rewrite fl_log_div2.

Lemma fl_log_odd :
  forall n : nat,
    fl_log (n + n + 1) = (fl_log n) + 1.
Proof.
  intro n.
  rewrite plus_comm; simpl.
  rewrite fl_log_div2'.
  rewrite double_div2.
  rewrite plus_comm; simpl; reflexivity.
Qed.
Hint Rewrite fl_log_odd.

Lemma fl_log_even :
  forall n : nat,
    fl_log ((n + 1) + (n + 1)) = (fl_log n) + 1.
Proof.
  intro n.
  replace (n + 1 + (n + 1)) with (S (S (n + n))) ; [|omega].
  rewrite fl_log_div2'.
  rewrite div2_with_odd_argument.
  rewrite plus_comm; simpl; reflexivity.
Qed.
Hint Rewrite fl_log_even.

Lemma cl_log_odd :
  forall n,
    cl_log(n+n+1) = cl_log n + 1.
Proof.
  intros.
  rewrite plus_comm; simpl.
  rewrite cl_log_div2'.
  rewrite div2_with_odd_argument.
  rewrite plus_comm; simpl; reflexivity.
Qed.
Hint Rewrite cl_log_odd.

Lemma cl_log_even :
  forall n,
    cl_log (n+1) + 1 = cl_log (n + 1 + n + 1).
Proof.
  intros.
  replace (n + 1 + n + 1) with (S (S (n+n))); [|omega].
  rewrite cl_log_div2'.
  replace (S (S (n+n))) with ((n+1)+(n+1)); [|omega].
  rewrite double_div2.
  rewrite plus_comm; simpl; reflexivity.
Qed.
Hint Rewrite cl_log_even.

Lemma braun_invariant_implies_fl_log_property :
  forall s_size t_size,
    t_size <= s_size <= t_size + 1 ->
    fl_log t_size + 1 = fl_log (s_size + t_size + 1).
Proof.
  intros.
  assert (s_size = t_size \/ s_size = t_size + 1) as TwoCases;
    [ omega | ].

  inversion TwoCases; subst; clear.

  rewrite fl_log_odd.
  reflexivity.

  replace (t_size + 1 + t_size + 1) with ((t_size+1) + (t_size+1)); [| omega].
  rewrite fl_log_even.
  reflexivity.
Qed.
Hint Rewrite braun_invariant_implies_fl_log_property.

Lemma braun_invariant_implies_cl_log_property:
  forall s1_size t1_size,
    t1_size <= s1_size <= t1_size + 1 ->
    cl_log s1_size + 1 = cl_log (s1_size + t1_size + 1).
Proof.
  intros.
  assert (s1_size = t1_size \/ s1_size = t1_size+1) as TWOCASES; [omega|].
  inversion TWOCASES; clear TWOCASES; subst s1_size.

  replace (cl_log (t1_size + t1_size+1)) with (cl_log (S (t1_size + t1_size))).

  replace (cl_log (S (t1_size + t1_size)))
  with (S (cl_log (div2 (S (t1_size + t1_size))))) ; [|rewrite cl_log_div2';reflexivity].

  replace (div2 (S (t1_size+t1_size))) with t1_size;
    [| rewrite (div2_with_odd_input t1_size); reflexivity].

  omega.

  replace (t1_size + t1_size+1) with (S (t1_size+t1_size)).
  reflexivity.

  omega.

  replace (t1_size + 1 + t1_size + 1) with (S (S (t1_size+t1_size))); [|omega].
  rewrite cl_log_div2'.

  replace (S (S (t1_size+t1_size))) with ((S t1_size)+(S t1_size)); [|omega].
  rewrite double_div2.
  rewrite plus_comm.
  simpl.
  rewrite plus_comm.
  reflexivity.
Qed.
Hint Rewrite braun_invariant_implies_cl_log_property.

Lemma fl_log_cl_log_relationship :
  forall n,
    S (fl_log n) = cl_log (S n).
Proof.
  apply (well_founded_ind
           lt_wf
           (fun n => S (fl_log n) = cl_log (S n))).
  intros.
  destruct x.
  compute; reflexivity.
  rewrite fl_log_div2'.
  rewrite cl_log_div2'.
  rewrite (H (div2 x)); auto.
Qed.
Hint Rewrite fl_log_cl_log_relationship.

Lemma div2_le:
  forall n,
    div2 n <= n.
Proof.
  induction n as [|n].
  simpl. auto.

  apply Nat.div2_decr.
  auto.
Qed.

Lemma ind_0_div2 :
  forall P:nat -> Prop,
    P 0 -> (forall n, P (div2 n) -> P (S n)) -> forall n, P n.
Proof.
  intros P P0 I.
  apply (well_founded_ind lt_wf P).
  intros n IH.
  destruct n as [|n].
  auto.
  apply I.
  apply IH.
  unfold lt.
  apply le_n_S.
  apply div2_le.
Qed.

Lemma fl_log_decr:
  forall x,
    fl_log x <= x.
Proof.
  apply ind_0_div2.

  rewrite fl_log_zero.
  auto.

  intros n.
  rewrite <- fl_log_div2.
  intros LE.
  rewrite plus_comm. simpl.
  apply le_n_S.
  eapply le_trans.
  apply LE.
  apply div2_le.
Qed.

Lemma fl_log_monotone:
  forall x y,
    x <= y ->
    fl_log x <= fl_log y.
Proof.
  apply (ind_0_div2 (fun x => forall y : nat, x <= y -> fl_log x <= fl_log y)).

  intros y LE.
  rewrite fl_log_zero.
  apply le_0_n.

  intros n IH y LE.
  rewrite <- fl_log_div2.
  destruct y as [|y].
  omega.
  assert (n <= y) as LE'; try omega.
  clear LE.
  rewrite <- fl_log_div2.
  rewrite plus_comm. simpl.
  rewrite plus_comm. simpl.
  apply le_n_S.
  apply IH.
  apply div2_monotone.
  auto.
Qed.

Lemma cl_log_monotone:
  forall x y,
    x <= y ->
    cl_log x <= cl_log y.
Proof.
  intros [|n] y LE.

  rewrite cl_log_zero.
  apply le_0_n.

  rewrite <- fl_log_cl_log_relationship.
  destruct y as [|y].
  omega.
  rewrite <- fl_log_cl_log_relationship.
  assert (n <= y) as LE'; try omega.
  apply le_n_S.
  apply fl_log_monotone.
  auto.
Qed.

Lemma S_cl_log_doubles :
  forall n, S (cl_log (S n)) = cl_log (S n + S n).
Proof.
  intros.
  rewrite <- (double_div2 (S n)) at 1.
  replace (S n + S n) with (S (n+S n)) at 1;[|omega].
  rewrite <- cl_log_div2'.
  replace (S (n+S n)) with (S n + S n);omega.
Qed.

Lemma cl_log_product : forall n m, cl_log (n*m) <= 2*cl_log n + 2*cl_log m.
Proof.
  intros.
  apply (lt_wf_double_ind (fun n m => cl_log (n*m) <= 2*cl_log n + 2*cl_log m)).
  clear.
  intros.
  destruct n.
  rewrite mult_0_l.
  rewrite cl_log_zero.
  omega.
  destruct m.
  rewrite mult_0_r.
  rewrite cl_log_zero.
  omega.
  destruct (even_odd_dec n).
  destruct (even_odd_dec m).
  destruct n. rewrite mult_1_l. omega.
  destruct m. rewrite mult_1_r. omega.
  apply (le_trans (cl_log (S (S n) * S (S m)))
                  (cl_log (div2 (S (S n)) * div2 (S (S m))) + 4)).
  replace (div2 (S (S n))) with (div2 (S n));[|apply even_div2; auto].
  replace (div2 (S (S m))) with (div2 (S m));[|apply even_div2; auto].
  rewrite <- even_div_product; auto.
  replace ((S n) * div2 (S m)) with (div2 (S m) * (S n));[|rewrite mult_comm;auto].
  rewrite <- even_div_product; auto.
  destruct n.
  inversion e.
  inversion H2.
  destruct m.
  inversion e0.
  inversion H2.
  replace (S (S n)) with (n+2) at 2;[|omega].
  replace (S (S m)) with (m+2) at 2;[|omega].
  rewrite mult_plus_distr_r;
    repeat (rewrite mult_plus_distr_l);
    rewrite plus_assoc.
  replace (m * n + m * 2 + 2 * n + 2 * 2)
  with (S (S (S (S (m * n + m * 2 + 2 * n)))));[|omega].
  unfold div2 at 2; fold div2.
  replace (cl_log (div2 (S (S (div2 (m * n + m * 2 + 2 * n))))) + 4)
  with (S (S (S (S (cl_log (div2 (S (S (div2 (m * n + m * 2 + 2 * n))))))))));[|omega].
  rewrite <- cl_log_div2'.
  replace (S (S (div2 (m * n + m * 2 + 2 * n))))
  with (div2 (S (S (S (S (m * n + m * 2 + 2 * n))))));[|unfold div2;auto].
  rewrite <- cl_log_div2'.
  rewrite S_cl_log_doubles.
  replace (S (S (S (S (m * n + m * 2 + 2 * n)))) +
           S (S (S (S (m * n + m * 2 + 2 * n)))))
  with (S ((S (S (S (m * n + m * 2 + 2 * n)))) +
           S (S (S (S (m * n + m * 2 + 2 * n))))));[|omega].
  rewrite S_cl_log_doubles.
  apply cl_log_monotone.
  replace (S (S (S n))) with (n+3);[|omega].
  replace (S (S (S m))) with (m+3);[|omega].
  rewrite mult_plus_distr_r;
    repeat (rewrite mult_plus_distr_l);
    rewrite plus_assoc.
  rewrite mult_comm at 1.
  remember (m*n) as l.
  omega.
  repeat rewrite cl_log_div2'.
  replace ( 2 * S (cl_log (div2 (S (S n)))) + 2 * S (cl_log (div2 (S (S m)))))
  with ( 2 * (cl_log (div2 (S (S n)))) + 2 * (cl_log (div2 (S (S m)))) + 4);[|omega].
  apply plus_le_compat; auto.
  replace (S n) with (n + 1); try omega.
  replace (S m) with (m + 1); try omega.
  assert (((n+1)*(m+1)) = (n*m + m + n + 1)); try omega.
  rewrite mult_plus_distr_r.
  rewrite mult_plus_distr_l.
  rewrite mult_plus_distr_l.
  omega.
  rewrite H1.
  replace (n*m+m+n+1) with (S(n*m+m+n));[|omega].
  rewrite cl_log_div2'.
  replace (S(n*m+m+n)) with (n*m+m+n+1);[|omega].
  rewrite <- H1.
  rewrite mult_comm.
  rewrite even_div_product;[|apply odd_even_plus; auto; repeat constructor].
  apply (le_trans (S (cl_log (div2 (m + 1) * (n + 1))))
                  (2*cl_log(div2(m+1)) + 2*cl_log(n+1) + 1)).
  replace (S (cl_log (div2 (m + 1) * (n + 1))))
  with (cl_log (div2 (m + 1) * (n + 1)) +1);[|omega].
  apply plus_le_compat;auto.
  rewrite mult_comm.
  replace ( 2 * cl_log (div2 (m + 1)) + 2 * cl_log (n + 1))
  with  (2 * cl_log (n + 1) + 2 * cl_log (div2 (m + 1)));[|apply plus_comm].
  replace (n+1) with (S n); [auto|omega].
  replace (m+1) with (S m);[auto|omega].
  replace (cl_log (S m)) with (S (cl_log (div2 (S m))));[|
                                                        apply eq_sym;
                                                          apply cl_log_div2']; omega.
   replace (S n) with (n + 1); try omega.
  replace (S m) with (m + 1); try omega.
  assert (((n+1)*(m+1)) = (n*m + m + n + 1)); try omega.
  rewrite mult_plus_distr_r.
  rewrite mult_plus_distr_l.
  omega.
  rewrite H1.
  replace (n*m+m+n+1) with (S(n*m+m+n));[|omega].
  rewrite cl_log_div2'.
  replace (S(n*m+m+n)) with (n*m+m+n+1);[|omega].
  rewrite <- H1.
  rewrite even_div_product;[|apply odd_even_plus; auto; repeat constructor].
  apply (le_trans (S (cl_log (div2 (n + 1) * (m + 1))))
                  (2*cl_log(div2(n+1)) + 2*cl_log(m+1) + 1)).
  replace  (S (cl_log ((div2 (n+1)) * (m+1)))) with  (cl_log ((div2 (n+1)) * (m+1)) + 1).
  apply plus_le_compat; auto.
  omega.
  replace (n+1) with (S n);[|omega].
  rewrite cl_log_div2'.
  omega.
Qed.

Lemma cl_log_square_four :
  forall n, cl_log (n * n) <= 4 * cl_log n.
Proof.
  intros.
  eapply le_trans.
  apply cl_log_product.
  omega.
Qed.

Definition monotone (f : nat -> nat) := forall n m, n<=m -> f n <= f m.

Theorem log_prod_time :
  forall (n k:nat) (f g : nat -> nat),
    monotone g ->
    f 0 = k /\ (forall n, f (S n) = f (div2 (S n)) + g (S n)) ->
    f n <= (cl_log n)*(g n) + k.
Proof.
  intros n k f g Mono_g H.
  destruct H.
  apply (well_founded_ind
           lt_wf
           (fun n =>  f n <= cl_log n * g n + k)).
  clear n.
  intros n IH.
  destruct n.
  rewrite H.
  rewrite cl_log_zero. omega.
  rewrite H0.
  rewrite cl_log_div2'.
  replace (S (cl_log (div2 (S n)))) with ((cl_log (div2 (S n)))+1);[|omega].
  rewrite mult_plus_distr_r.
  rewrite mult_1_l.
  rewrite <- plus_assoc.
  replace (g (S n) + k) with (k + g (S n));[|omega].
  rewrite plus_assoc.
  apply plus_le_compat; auto.
  eapply le_trans.
  apply IH.
  apply lt_div2. omega.
  apply plus_le_compat; auto.
  apply mult_le_compat.
  auto.
  apply Mono_g.
  assert (div2 (S n) < S n).
  auto. omega.
Qed.

Theorem log_prod_time2 :
  forall (n m k:nat) (f g : nat -> nat -> nat),
    (forall m, monotone (fun n => g n m)) ->
    (forall m, f 0 m = k) /\ (forall n m, f (S n) m = f (div2 (S n)) m + g (S n) m) ->
    f n m <= (cl_log n)*(g n m) + k.
Proof.
  intros n m k f g Mono_g H.
  destruct H.
  apply (well_founded_ind
           lt_wf
           (fun n => forall m, f n m <= (cl_log n)*(g n m) + k)).
  clear n m.
  intros n IH.
  intros m.
  destruct n.
  rewrite H.
  rewrite cl_log_zero. omega.
  rewrite H0.
  rewrite cl_log_div2'.
  replace (S (cl_log (div2 (S n)))) with ((cl_log (div2 (S n)))+1);[|omega].
  rewrite mult_plus_distr_r.
  rewrite mult_1_l.
  rewrite <- plus_assoc.
  replace (g (S n) m + k) with (k + g (S n) m);[|omega].
  rewrite plus_assoc.
  apply plus_le_compat; auto.
  eapply le_trans.
  apply IH.
  apply lt_div2. omega.
  apply plus_le_compat; auto.
  apply mult_le_compat.
  auto.
  apply Mono_g.
  assert (div2 (S n) < S n).
  auto. omega.
Qed.


(** * Multiset:  Insertion Sort With Multisets *)

(** We have seen how to specify algorithms on "collections", such as
    sorting algorithms, using permutations.  Instead of using
    permutations, another way to specify these algorithms is to use
    multisets.  A _set_ of values is like a list with no repeats where
    the order does not matter.  A _multiset_ is like a list, possibly
    with repeats, where the order does not matter.  One simple
    representation of a multiset is a function from values to [nat]. *)

Require Import Coq.Strings.String.
From VFA Require Import Perm.
From VFA Require Import Sort.
Require Export FunctionalExtensionality.

(** In this chapter we will be using natural numbers for two different
    purposes: the values in the lists that we sort, and the
    multiplicity (number of times occurring) of those values.  To keep
    things straight, we'll use the [value] type for values, and [nat]
    for multiplicities. *)

Definition value := nat.

Definition multiset := value -> nat.

(** Just like sets, multisets have operators for [union], for the
    [empty] multiset, and the multiset with just a single element. *)

Definition empty : multiset :=
   fun x => 0.

Definition union (a b : multiset) : multiset :=
   fun x => a x + b x.

Definition singleton (v: value) : multiset :=
   fun x => if x =? v then 1 else 0.

(** **** Exercise: 1 star (union_assoc)  *)
(** Since multisets are represented as functions, to prove that one
    multiset equals another we must use the axiom of functional
    extensionality. *)

Lemma union_assoc: forall a b c : multiset, (* assoc stands for "associative" *)
   union a (union b c) = union (union a b) c.
Proof.
  intros. unfold union.
  extensionality x. apply plus_assoc. Qed.

(** [] *)

(** **** Exercise: 1 star (union_comm)  *)
Lemma union_comm: forall a b : multiset,  (* comm stands for "commutative" *)
   union a b = union b a.
Proof.
  intros. unfold union.
  extensionality x. apply plus_comm. Qed.

(** [] *)

(** Remark on efficiency:  These multisets aren't very efficient.  If
  you wrote programs with them, the programs would run slowly. However,
  we're using them for _specifications_, not for _programs_.  Our
  multisets built with [union] and [singleton] will never really
  _execute_ on any large-scale inputs; they're only used in the proof
  of correctness of algorithms such as [sort].  Therefore, their
  inefficiency is not a problem. *)

(** Contents of a list, as a multiset: *)

Fixpoint contents (al: list value) : multiset :=
  match al with
  | a :: bl => union (singleton a) (contents bl)
  | nil => empty
  end.

(** Recall the insertion-sort program from [Sort.v].  Note that it
    handles lists with repeated elements just fine. *)

Example sort_pi: sort [3;1;4;1;5;9;2;6;5;3;5] = [1;1;2;3;3;4;5;5;5;6;9].
Proof. simpl. reflexivity. Qed.

Example sort_pi_same_contents:
    contents ([3;1;4;1;5;9;2;6;5;3;5]) = contents [1;1;2;3;3;4;5;5;5;6;9].
Proof.
extensionality x. simpl.
destruct x; try reflexivity.
destruct x; try reflexivity.
destruct x; try reflexivity.
destruct x; try reflexivity.
destruct x; try reflexivity.
destruct x; try reflexivity.
destruct x; try reflexivity.
  (* Why does this work? Try it step by step, without [do 10] *)
Qed.

(* ################################################################# *)
(** * Correctness *)

(** A sorting algorithm must rearrange the elements into a list that
    is totally ordered.  But let's say that a different way: the
    algorithm must produce a list _with the same multiset of values_,
    and this list must be totally ordered. *)

Definition is_a_sorting_algorithm' (f: list nat -> list nat) :=
  forall al, contents al = contents (f al) /\ sorted (f al).

(** **** Exercise: 3 stars (insert_contents)  *)
(** First, prove the auxiliary lemma [insert_contents], which will be
    useful for proving [sort_contents] below.  Your proof will be by
    induction.  You do not need to use [extensionality]. *)

Lemma insert_contents: forall x l, contents (x::l) = contents (insert x l).
Proof. induction l.
  - reflexivity.
  - simpl in *.
    bdestruct (x <=? a).
    + reflexivity.
    + rewrite union_assoc. rewrite (union_comm (singleton x)).
      rewrite <- union_assoc. rewrite IHl.
      reflexivity.
Qed.

(** [] *)

(** **** Exercise: 3 stars (sort_contents)  *)
(** Now prove that sort preserves contents. *)

Theorem sort_contents: forall l, contents l = contents (sort l).
Proof. induction l.
  - reflexivity.
  - simpl. rewrite <- insert_contents.
    rewrite IHl. reflexivity.
Qed.

(** [] *)

(** Now we wrap it all up.  *)

Theorem insertion_sort_correct:
  is_a_sorting_algorithm' sort.
Proof.
split. apply sort_contents. apply sort_sorted.
Qed.

(** **** Exercise: 1 star (permutations_vs_multiset)  *)
(** Compare your proofs of [insert_perm, sort_perm] with your proofs
    of [insert_contents, sort_contents].  Which proofs are simpler?

      - [ ] easier with permutations,
      - [ ] easier with multisets
      - [ ] about the same.

   Regardless of "difficulty", which do you prefer / find easier to
   think about?
      - [ ] permutations or
      - [ ] multisets

   Put an X in one box in each list. *)
(* Do not modify the following line: *)
Definition manual_grade_for_permutations_vs_multiset : option (prod nat string) := None.
(** [] *)

(* ################################################################# *)
(** * Permutations and Multisets *)

(** The two specifications of insertion sort are equivalent.  One
    reason is that permutations and multisets are closely related.
    We're going to prove:

       [Permutation al bl <-> contents al = contents bl.] *)

(** **** Exercise: 3 stars (perm_contents)  *)
(** The forward direction is easy, by induction on the evidence for
    [Permutation]: *)

Lemma perm_contents:
  forall al bl : list nat,
   Permutation al bl -> contents al = contents bl.
Proof. intros. induction H.
  - reflexivity.
  - simpl. rewrite IHPermutation.
    reflexivity.
  - simpl. rewrite union_assoc. rewrite (union_comm (singleton y)).
    rewrite <- union_assoc. reflexivity.
  - rewrite IHPermutation1, IHPermutation2. reflexivity.
Qed.
(** [] *)

(** The other direction,
    [contents al = contents bl -> Permutation al bl],
    is surprisingly difficult.  (Or maybe there's an easy way
    that I didn't find.) *)

Fixpoint list_delete (al: list value) (v: value) :=
  match al with
  | x::bl => if x =? v then bl else x :: list_delete bl v
  | nil => nil
  end.

Definition multiset_delete (m: multiset) (v: value) :=
   fun x => if x =? v then pred(m x) else m x.

(** **** Exercise: 3 stars (delete_contents)  *)
Lemma delete_contents:
  forall v al,
   contents (list_delete al v) = multiset_delete (contents al) v.
Proof.
  intros.
  extensionality x.
  induction al.
  simpl. unfold empty, multiset_delete.
  bdestruct (x =? v); auto.
  simpl.
  bdestruct (a =? v).
  unfold multiset_delete, singleton, union. rewrite <- H.
  bdestruct (x =? a); reflexivity.
  simpl. unfold singleton, union.
  rewrite IHal. unfold multiset_delete.
  bdestruct (x =? a).
  replace (x =? v) with false.
  reflexivity.
  symmetry. rewrite Nat.eqb_neq. omega.
  reflexivity.
Qed.

(** [] *)

(** **** Exercise: 2 stars (contents_perm_aux)  *)
Lemma contents_perm_aux:
 forall v b, empty = union (singleton v) b -> False.
Proof. intros.
  assert (empty v = union (singleton v) b v) by
    (rewrite H; reflexivity).
  unfold empty, union, singleton in H0.
  rewrite Nat.eqb_refl in H0. inversion H0.
Qed.

(** [] *)

(** **** Exercise: 2 stars (contents_in)  *)
Lemma contents_in:
  forall (a: value) (bl: list value) , contents bl a > 0 -> In a bl.
Proof. intros. induction bl.
  - unfold contents, empty in H.
    inversion H.
  - unfold In. unfold contents, union, singleton in H.
    bdestruct (a =? a0). left. auto.
    right. apply IHbl. apply H.
Qed.

(** [] *)

(** **** Exercise: 2 stars (in_perm_delete)  *)
Lemma in_perm_delete:
  forall a bl,
  In a bl -> Permutation (a :: list_delete bl a) bl.
Proof. intros. induction bl.
  - inversion H.
  - simpl. bdestruct (a0 =? a).
    * subst. apply Permutation_refl.
    * apply perm_trans with (a0 :: a :: list_delete bl a).
      apply perm_swap. apply perm_skip. apply IHbl.
      destruct H. omega. assumption.
Qed.

(** [] *)

(** **** Exercise: 4 stars (contents_perm)  *)
Lemma contents_perm:
 forall al bl, contents al = contents bl -> Permutation al bl.
Proof.
  induction al; destruct bl; intro.
  auto.
  simpl in H.
  contradiction (contents_perm_aux _ _ H).
  simpl in H. symmetry in H.
  contradiction (contents_perm_aux _ _ H).
  specialize (IHal (list_delete (v :: bl) a)).
  (** From this point on, you don't need induction.
    Use the lemmas [perm_trans], [delete_contents],
     [in_perm_delete], [contents_in].   At _certain points_
     you'll need to unfold the definitions of
     [multiset_delete], [union], [singleton]. *)

  apply perm_trans with (a :: list_delete (v :: bl) a).
  - apply perm_skip. apply IHal.
    rewrite delete_contents.
    rewrite <- H. rewrite <- delete_contents. apply perm_contents.
    simpl. rewrite Nat.eqb_refl. apply Permutation_refl.

  - apply in_perm_delete. apply contents_in.
    rewrite <- H. unfold contents, union, singleton.
    rewrite Nat.eqb_refl. omega.
Qed.

(** [] *)

(* ################################################################# *)
(** * The Main Theorem: Equivalence of Multisets and Permutations *)
Theorem same_contents_iff_perm:
  forall al bl, contents al = contents bl <-> Permutation al bl.
Proof.
  intros. split. apply contents_perm. apply perm_contents.
Qed.

(** Therefore, it doesn't matter whether you prove your sorting
    algorithm using the Permutations method or the multiset method. *)

Corollary sort_specifications_equivalent:
    forall sort, is_a_sorting_algorithm sort <->  is_a_sorting_algorithm' sort.
Proof.
  unfold is_a_sorting_algorithm, is_a_sorting_algorithm'.
  split; intros;
  destruct (H al); split; auto;
  apply same_contents_iff_perm; auto.
Qed.


(** * IndProp: Inductively Defined Propositions *)

Set Warnings "-notation-overridden,-parsing".
From LF Require Export Logic.
Require Coq.omega.Omega.

Inductive even : nat -> Prop :=
| ev_0 : even 0
| ev_SS (n : nat) (H: even n) : even (S (S n))
.

Check ev_SS.
Theorem ev_4 : even 4.
Proof.
  apply (ev_SS 2).
  apply (ev_SS 0).
  apply ev_0.
Qed.

Theorem ev_4' : even 4.
Proof.
  apply (ev_SS 2 (ev_SS 0 ev_0)).
Qed.

Theorem ev_plus_4:
  forall n:nat, even n -> even (4 + n).
Proof.
  intros n H.
  exact (ev_SS (2 + n) (ev_SS n H)).
Qed.

Theorem ev_inversion :
  forall (n : nat), even n ->
    (n = 0) \/ (exists n', n = S (S n') /\ even n').
Proof.
  intros n Hn.
  destruct Hn as [|n' H'].
  - left. reflexivity.
  - right. exists n'. split. reflexivity. exact H'.
Qed.

Theorem ev_minus2 : forall n,
  even n -> even (pred (pred n)).
Proof.
  intros n Hn.
  destruct Hn as [|n' H'].
  - simpl. exact ev_0.
  - simpl. exact H'.
Qed.

Theorem evSS_ev : forall n,
  even (S (S n)) -> even n.
Proof.
  intros n Hn.
  apply ev_inversion in Hn.
  destruct Hn as [H' | H'].
  - discriminate H'.
  - destruct H' as [n' [Hl Hr]].
    injection Hl as Hl'.
    rewrite <- Hl' in Hr.
    exact Hr.
Qed.

Theorem evSS_ev' : forall n,
  even (S (S n)) -> even n.
Proof.
  intros n E.
  inversion E as [|n' E'].
  exact E'.
Qed.

Theorem one_not_even : ~ even 1.
Proof.
  unfold "~".
  intros H.
  inversion H.
Qed.


Require Import Nat.

Inductive lst : Type :=  Nil : lst | Cons : nat -> lst -> lst .

Inductive tree : Type := Node : nat -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : nat -> nat -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint mem (mem_arg0 : nat) (mem_arg1 : lst) : Prop
           := match mem_arg0, mem_arg1 with
              | x, Nil => False
              | x, Cons y z => or (eq x y) (mem x z)
              end.

Theorem mem_append : forall (x : nat) (y : lst) (z : lst), mem x y -> mem x (append y z).
Proof.
   intros.
   induction y.
   - contradiction.
   - simpl. destruct H.
   + auto.
   + apply IHy in H. auto.
Qed.


Theorem Ex011 (A B : Prop) : (A /\ ~A) -> B.
Proof.
  intro.
  destruct H.
  exfalso.
  apply H0.
  exact H.
Qed.

Theorem Ex011_2 (A B : Prop) : (A /\ ~A) -> B.
Proof.
  intro.
  destruct H.
  contradiction.
Qed.


Theorem induc4 : forall P: nat-> Prop,
                 P 0 -> P 1 -> P 2 -> P 3 ->
                 (forall p, P p -> P (S (S (S (S p))))) ->
                 forall n, P n.
Proof.
 intros P H0 H1 H2 H3 H.
 cut (forall n, (P n /\ P (S n) /\ P (S (S n)) /\ P (S (S (S n))))).
 intros H4 n; case (H4 n); auto.
 induction n.
 repeat split; auto.
 intuition.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

Fixpoint fac (fac_arg0 : natural) : natural
           := match fac_arg0 with
              | Zero => Succ Zero
              | Succ n => mult (fac n) n
              end.

Fixpoint qfac (qfac_arg0 : natural) (qfac_arg1 : natural) : natural
           := match qfac_arg0, qfac_arg1 with
              | Zero, n => n
              | Succ n, m => qfac n (mult m n)
              end.

Lemma plus_succ : forall (x y : natural), plus x (Succ y) = Succ (plus x y).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_assoc : forall (x y z : natural), plus (plus x y) z = plus x (plus y z).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_zero : forall (x : natural), plus x Zero = x.
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_commut : forall (x y : natural), plus x y = plus y x.
Proof.
intros.
induction x.
- rewrite plus_zero. reflexivity.
- simpl. lfind.  rewrite IHx.  reflexivity.
Admitted.

Lemma mult_zero : forall (x : natural), mult x Zero = Zero.
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. reflexivity.
Qed.

Lemma mult_succ : forall (x y : natural), plus (mult x y) x = mult x (Succ y).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite plus_succ. rewrite plus_assoc. rewrite (plus_commut y x). rewrite <- plus_assoc. rewrite IHx. rewrite plus_succ. reflexivity.
Qed.

Lemma mult_commut : forall (x y : natural), mult x y = mult y x.
Proof.
intros.
induction x.
- rewrite mult_zero. reflexivity.
- simpl. rewrite IHx. rewrite mult_succ. reflexivity.
Qed.

Lemma distrib : forall (x y z : natural), mult (plus x y) z = plus (mult x z) (mult y z).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. rewrite plus_assoc. rewrite (plus_commut (mult y z) z). rewrite <- plus_assoc. reflexivity.
Qed.

Lemma mult_assoc : forall (x y z : natural), mult (mult x y) z = mult x (mult y z).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite distrib. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : natural), eq (mult (fac x) y) (qfac x y).
Proof.
induction x.
- reflexivity.
- intros. simpl. rewrite <- IHx. rewrite mult_assoc. rewrite (mult_commut x y). reflexivity.
Qed.


Require Import ZArith.
Require Import Reals.
From Flocq Require Import Raux Defs Float_prop Operations.
Require Import Gappa_definitions.

Lemma float2_zero :
  forall e : Z, Float2 0 e = 0%R :>R.
Proof.
intro e.
apply F2R_0.
Qed.

Definition Fopp2 (x : float2) :=
  Float2 (- Fnum x) (Fexp x).

Lemma Fopp2_correct :
  forall x : float2,
  Fopp2 x = (- x)%R :>R.
Proof.
intros x.
unfold float2R, Fopp2. simpl.
apply F2R_Zopp.
Qed.

Definition Fmult2 (x y : float2) :=
  Float2 (Fnum x * Fnum y) (Fexp x + Fexp y).

Definition Fmult2_correct :
  forall x y : float2,
  Fmult2 x y = (x * y)%R :>R.
Proof.
intros (mx, ex) (my, ey).
exact (F2R_mult (Float radix2 mx ex) (Float radix2 my ey)).
Qed.

Definition shl (m : Z) (d : positive) :=
 match m with
 | Z0 => Z0
 | Zpos p => Zpos (shift_pos d p)
 | Zneg p => Zneg (shift_pos d p)
 end.

Lemma float2_shl_correct :
  forall m e : Z, forall d : positive,
  Float2 (shl m d) (e - Zpos d) = Float2 m e :>R.
Proof.
intros m e d.
replace (shl m d) with (m * Zpower_pos 2 d)%Z.
unfold float2R.
rewrite (F2R_change_exp _ (e - Zpos d) _ e).
simpl.
now replace (e - (e - Zpos d))%Z with (Zpos d) by ring.
generalize (Zgt_pos_0 d).
omega.
rewrite Zmult_comm.
destruct m as [|m|m] ; simpl.
apply Zmult_0_r.
now rewrite shift_pos_correct.
change (Zneg (shift_pos d m)) with (- Zpos (shift_pos d m))%Z.
rewrite shift_pos_correct.
now rewrite Zopp_mult_distr_r.
Qed.

Definition Fshift2 (x y : float2) :=
 match (Fexp x - Fexp y)%Z with
 | Zpos p => (shl (Fnum x) p, Fnum y, Fexp y)
 | Zneg p => (Fnum x, shl (Fnum y) p, Fexp x)
 | Z0 => (Fnum x, Fnum y, Fexp x)
 end.

Lemma Fshift2_correct :
  forall x y : float2,
  match Fshift2 x y with
  | (mx, my, e) => Float2 mx e = x :>R /\ Float2 my e = y :>R
  end.
Proof.
intros (mx, ex) (my, ey).
unfold Fshift2. simpl.
assert (ex = ex - ey + ey)%Z by ring.
pattern ex at - 1 ; rewrite H.
destruct (ex - ey)%Z as [|d|d] ; repeat split.
rewrite <- (float2_shl_correct mx _ d).
now ring_simplify (Zpos d + ey - Zpos d)%Z.
rewrite Zplus_comm.
apply float2_shl_correct.
Qed.

Definition Fplus2 (x y : float2) :=
 match Fshift2 x y with
 | (mx, my, e) => Float2 (mx + my) e
 end.

Lemma Fplus2_correct :
  forall x y : float2,
  Fplus2 x y = (x + y)%R :>R.
Proof.
intros x y.
unfold Fplus2.
generalize (Fshift2_correct x y).
destruct (Fshift2 x y) as ((mx, my), e).
intros (Hx, Hy).
rewrite <- Hx, <- Hy.
unfold float2R, F2R. simpl.
rewrite plus_IZR.
apply Rmult_plus_distr_r.
Qed.

Definition Fminus2 (x y : float2) :=
 match Fshift2 x y with
 | (mx, my, e) => Float2 (mx - my) e
 end.

Lemma Fminus2_correct :
  forall x y : float2,
  Fminus2 x y = (x - y)%R :>R.
Proof.
intros x y.
unfold Fminus2.
generalize (Fshift2_correct x y).
destruct (Fshift2 x y) as ((mx, my), e).
intros (Hx, Hy).
rewrite <- Hx, <- Hy.
unfold float2R, F2R. simpl.
rewrite minus_IZR.
apply Rmult_minus_distr_r.
Qed.

Definition Fcomp2 (x y : float2) :=
 match Fshift2 x y with
 | (mx, my, _) => (mx ?= my)%Z
 end.

Lemma Fcomp2_correct :
  forall x y : float2,
  Fcomp2 x y = Rcompare x y.
Proof.
intros x y.
unfold Fcomp2.
generalize (Fshift2_correct x y).
destruct (Fshift2 x y) as ((mx, my), e).
intros (Hx, Hy).
rewrite <- Hx, <- Hy.
unfold float2R, F2R. simpl.
rewrite Rcompare_mult_r.
now rewrite Rcompare_IZR.
apply bpow_gt_0.
Qed.

Definition Feq2 (x y : float2) :=
 match Fcomp2 x y with
 | Eq => true
 | _ => false
 end.

Lemma Feq2_correct :
  forall x y : float2,
  Feq2 x y = true -> x = y :>R.
Proof.
intros x y Hb.
apply Rcompare_Eq_inv.
rewrite <- Fcomp2_correct.
revert Hb.
unfold Feq2.
now case Fcomp2.
Qed.

Definition Flt2 (x y : float2) :=
 match Fcomp2 x y with
 | Lt => true
 | _ => false
 end.

Lemma Flt2_correct :
  forall x y : float2,
  Flt2 x y = true -> (x < y)%R.
Proof.
intros x y Hb.
apply Rcompare_Lt_inv.
rewrite <- Fcomp2_correct.
revert Hb.
unfold Flt2.
now case Fcomp2.
Qed.

Definition Fle2 (x y : float2) :=
 match Fcomp2 x y with
 | Gt => false
 | _ => true
 end.

Lemma Fle2_correct :
  forall x y : float2,
  Fle2 x y = true -> (x <= y)%R.
Proof.
intros x y Hb.
apply Rcompare_not_Gt_inv.
rewrite <- Fcomp2_correct.
intros H.
unfold Fle2 in Hb.
now rewrite H in Hb.
Qed.

Inductive Fle2_prop (x y : float2) : bool -> Prop :=
  | Fle2_true : (x <= y)%R -> Fle2_prop x y true
  | Fle2_false : (y < x)%R -> Fle2_prop x y false.

Lemma Fle2_spec :
  forall x y, Fle2_prop x y (Fle2 x y).
Proof.
intros x y.
case_eq (Fle2 x y) ; intros H.
apply Fle2_true.
apply Fle2_correct.
exact H.
generalize H. clear H.
unfold Fle2.
case_eq (Fcomp2 x y) ; try (intros ; discriminate).
intros H _.
apply Fle2_false.
apply Rcompare_Gt_inv.
now rewrite <- Fcomp2_correct.
Qed.

Definition Fis0 (x : float2) :=
 match (Fnum x) with
   Z0 => true
 | _ => false
 end.

Lemma Fis0_correct :
 forall x : float2,
 Fis0 x = true -> x = 0%R :>R.
intros x.
unfold Fis0.
induction x.
induction Fnum ; intro H0 ; try discriminate.
apply float2_zero.
Qed.

Definition Fpos (x : float2) :=
 match (Fnum x) with
   Zpos _ => true
 | _ => false
 end.

Lemma Fpos_correct :
  forall x : float2,
  Fpos x = true -> (0 < x)%R.
Proof.
intros (m, e) H.
unfold float2R.
apply F2R_gt_0. simpl.
revert H.
unfold Fpos. simpl.
now case m.
Qed.

Definition Fneg (x : float2) :=
 match (Fnum x) with
   Zneg _ => true
 | _ => false
 end.

Lemma Fneg_correct :
  forall x : float2,
  Fneg x = true -> (x < 0)%R.
Proof.
intros (m, e) H.
unfold float2R.
apply F2R_lt_0. simpl.
revert H.
unfold Fpos. simpl.
now case m.
Qed.

Definition Fpos0 (x : float2) :=
 match (Fnum x) with
   Zneg _ => false
 | _ => true
 end.

Lemma Fpos0_correct :
  forall x : float2,
  Fpos0 x = true -> (0 <= x)%R.
Proof.
intros (m, e) H.
unfold float2R.
apply F2R_ge_0. simpl.
revert H.
unfold Fpos. simpl.
now case m.
Qed.

Definition Fneg0 (x : float2) :=
 match (Fnum x) with
   Zpos _ => false
 | _ => true
 end.

Lemma Fneg0_correct :
  forall x : float2,
  Fneg0 x = true -> (x <= 0)%R.
Proof.
intros (m, e) H.
unfold float2R.
apply F2R_le_0. simpl.
revert H.
unfold Fpos. simpl.
now case m.
Qed.

Definition Flt2_m1 f :=
  Flt2 (Float2 (-1) 0) f.

Lemma Flt2_m1_correct :
  forall f,
  Flt2_m1 f = true ->
  (-1 < f)%R.
Proof.
intros f Hb.
generalize (Flt2_correct _ _ Hb).
unfold float2R, F2R. simpl.
now rewrite Rmult_1_r.
Qed.

Definition Fle2_m1 f :=
  Fle2 (Float2 (-1) 0) f.

Lemma Fle2_m1_correct :
  forall f,
  Fle2_m1 f = true ->
  (-1 <= f)%R.
Proof.
intros f Hb.
generalize (Fle2_correct _ _ Hb).
unfold float2R, F2R. simpl.
now rewrite Rmult_1_r.
Qed.


Require Export TopologicalSpaces.
Require Export DirectedSets.
Require Export InteriorsClosures.
Require Export Continuity.

Section Net.

Variable I:DirectedSet.
Variable X:TopologicalSpace.

Definition Net := DS_set I -> point_set X.

Definition net_limit (x:Net) (x0:point_set X) : Prop :=
  forall U:Ensemble (point_set X), open U -> In U x0 ->
  for large i:DS_set I, In U (x i).

Definition net_cluster_point (x:Net) (x0:point_set X) : Prop :=
  forall U:Ensemble (point_set X), open U -> In U x0 ->
  exists arbitrarily large i:DS_set I, In U (x i).

Lemma net_limit_is_cluster_point: forall (x:Net) (x0:point_set X),
  net_limit x x0 -> net_cluster_point x x0.
Proof.
intros.
red; intros.
red; intros.
pose proof (H U H0 H1).
destruct H2.
destruct (DS_join_cond i x1).
destruct H3.
exists x2; split; trivial.
apply H2; trivial.
Qed.

Lemma net_limit_in_closure: forall (S:Ensemble (point_set X))
  (x:Net) (x0:point_set X),
  (exists arbitrarily large i:DS_set I, In S (x i)) ->
  net_limit x x0 -> In (closure S) x0.
Proof.
intros.
apply NNPP.
red; intro.
pose proof (H0 (Complement (closure S))).
match type of H2 with | ?A -> ?B -> ?C => assert (C) end.
apply H2.
apply closure_closed.
assumption.
destruct H3.
pose proof (H x1).
destruct H4.
contradiction (H3 x2).
tauto.
apply closure_inflationary; tauto.
Qed.

Lemma net_cluster_point_in_closure: forall (S:Ensemble (point_set X))
  (x:Net) (x0:point_set X),
  (for large i:DS_set I, In S (x i)) ->
  net_cluster_point x x0 -> In (closure S) x0.
Proof.
intros.
apply NNPP.
red; intro.
pose proof (H0 (Complement (closure S))).
match type of H2 with | ?A -> ?B -> ?C => assert (C) end.
apply H2.
apply closure_closed.
assumption.
destruct H.
destruct (H3 x1).
destruct H4.
contradiction H5.
apply closure_inflationary.
apply H; trivial.
Qed.

End Net.

Implicit Arguments net_limit [[I] [X]].
Implicit Arguments net_cluster_point [[I] [X]].
Implicit Arguments net_limit_is_cluster_point [[I] [X]].
Implicit Arguments net_limit_in_closure [[I] [X]].
Implicit Arguments net_cluster_point_in_closure [[I] [X]].

Section neighborhood_net.

Variable X:TopologicalSpace.
Variable x:point_set X.

Inductive neighborhood_net_DS_set : Type :=
  | intro_neighborhood_net_DS :
    forall (U:Ensemble (point_set X)) (y:point_set X),
    open U -> In U x -> In U y -> neighborhood_net_DS_set.

Definition neighborhood_net_DS_ord
  (Uy Vz:neighborhood_net_DS_set) : Prop :=
  match Uy, Vz with
  | intro_neighborhood_net_DS U _ _ _ _,
    intro_neighborhood_net_DS V _ _ _ _ =>
    Included V U
  end.

Definition neighborhood_net_DS : DirectedSet.
refine (Build_DirectedSet neighborhood_net_DS_set
  neighborhood_net_DS_ord _ _).
constructor.
red; intros.
destruct x0.
simpl; auto with sets.
red; intros.
destruct x0; destruct y; destruct z.
simpl in H; simpl in H0; simpl.
auto with sets.

intros.
destruct i; destruct j.
assert (open (Intersection U U0)).
apply open_intersection2; trivial.
assert (In (Intersection U U0) x); auto with sets.

exists (intro_neighborhood_net_DS (Intersection U U0) x
  H H0 H0).
simpl; auto with sets.
Defined.

Definition neighborhood_net : Net neighborhood_net_DS X :=
  fun (x:neighborhood_net_DS_set) => match x with
  | intro_neighborhood_net_DS _ y _ _ _ => y
  end.

Lemma neighborhood_net_limit: net_limit neighborhood_net x.
Proof.
red; intros.
exists (intro_neighborhood_net_DS U x H H0 H0).
intros.
destruct j.
simpl in H1.
simpl.
auto with sets.
Qed.

End neighborhood_net.

Lemma net_limits_determine_topology:
  forall {X:TopologicalSpace} (S:Ensemble (point_set X))
  (x0:point_set X), In (closure S) x0 ->
  exists I:DirectedSet, exists x:Net I X,
  (forall i:DS_set I, In S (x i)) /\ net_limit x x0.
Proof.
intros.
assert (forall U:Ensemble (point_set X), open U -> In U x0 ->
  Inhabited (Intersection S U)).
intros.
apply NNPP; red; intro.
assert (Included (closure S) (Complement U)).
apply closure_minimal.
red; rewrite Complement_Complement; assumption.
red; intros.
red; red; red; intros.
contradiction H2.
exists x; auto with sets.
contradict H1.
apply H3.
assumption.
pose (Ssel := fun n:neighborhood_net_DS_set X x0 =>
  match n with
  | intro_neighborhood_net_DS V y _ _ _ => (In S y)
  end).
pose (our_DS_set := {n:neighborhood_net_DS_set X x0 | Ssel n}).
pose (our_DS_ord := fun (n1 n2:our_DS_set) =>
  neighborhood_net_DS_ord X x0 (proj1_sig n1) (proj1_sig n2)).
assert (preorder our_DS_ord).
constructor; red.
intros; red.
apply preord_refl.
apply (@DS_ord_cond (neighborhood_net_DS X x0)).
intros x y z.
unfold our_DS_ord; apply preord_trans.
apply (@DS_ord_cond (neighborhood_net_DS X x0)).
assert (forall i j:our_DS_set, exists k:our_DS_set,
  our_DS_ord i k /\ our_DS_ord j k).
destruct i.
destruct x.
destruct j.
destruct x.
assert (open (Intersection U U0)).
apply open_intersection2; trivial.
assert (In (Intersection U U0) x0).
auto with sets.
assert (Inhabited (Intersection S (Intersection U U0))).
apply H0; trivial.
destruct H4.
destruct H4.
pose (k0 := intro_neighborhood_net_DS X x0
  (Intersection U U0) x H2 H3 H5).
assert (Ssel k0).
red; unfold k0; simpl.
assumption.
exists (exist _ k0 H6).
split; red; simpl; auto with sets.

pose (our_DS := Build_DirectedSet our_DS_set our_DS_ord H1 H2).
exists our_DS.
exists (fun i:our_DS_set => neighborhood_net X x0 (proj1_sig i)).
split.
intros.
destruct i.
destruct x.
simpl.
simpl in s.
assumption.

red; intros.
assert (Inhabited (Intersection S U)).
apply H0; trivial.
destruct H5.
destruct H5.
pose (i0 := intro_neighborhood_net_DS X x0
  U x H3 H4 H6).
assert (Ssel i0).
simpl; assumption.
exists (exist _ i0 H7).
intros.
destruct j.
destruct x1.
simpl in H8.
red in H8; simpl in H8.
simpl.
auto with sets.
Qed.

Section Nets_and_continuity.

Variable X Y:TopologicalSpace.
Variable f:point_set X -> point_set Y.

Lemma continuous_func_preserves_net_limits:
  forall {I:DirectedSet} (x:Net I X) (x0:point_set X),
    net_limit x x0 -> continuous_at f x0 ->
    net_limit (fun i:DS_set I => f (x i)) (f x0).
Proof.
intros.
red; intros V ? ?.
assert (neighborhood V (f x0)).
apply open_neighborhood_is_neighborhood; split; trivial.
pose proof (H0 V H3).
destruct H4 as [U [? ?]].
destruct H4.
pose proof (H U H4 H6).
apply eventually_impl_base with (fun i:DS_set I => In U (x i));
  trivial.
intros.
assert (In (inverse_image f V) (x i)); auto with sets.
destruct H9; trivial.
Qed.

Lemma func_preserving_net_limits_is_continuous:
  forall x0:point_set X,
  (forall (I:DirectedSet) (x:Net I X),
    net_limit x x0 -> net_limit (fun i:DS_set I => f (x i)) (f x0))
  -> continuous_at f x0.
Proof.
intros.
pose proof (H (neighborhood_net_DS X x0)
  (neighborhood_net X x0)
  (neighborhood_net_limit X x0)).
apply continuous_at_open_neighborhoods; intros.
destruct H1.
pose proof (H0 V H1 H2).
destruct H3.
destruct x as [U].
exists U; repeat split; trivial.
pose proof (H3 (intro_neighborhood_net_DS X x0 U x o i H4)).
apply H5.
simpl; auto with sets.
Qed.

End Nets_and_continuity.

Section Subnet.

Variable X:TopologicalSpace.
Variable I:DirectedSet.
Variable x:Net I X.

Inductive Subnet {J:DirectedSet} : Net J X -> Prop :=
  | intro_subnet: forall h:DS_set J -> DS_set I,
    (forall j1 j2:DS_set J, DS_ord j1 j2 ->
       DS_ord (h j1) (h j2)) ->
    (exists arbitrarily large i:DS_set I,
       exists j:DS_set J, h j = i) ->
    Subnet (fun j:DS_set J => x (h j)).

Lemma subnet_limit: forall (x0:point_set X) {J:DirectedSet}
  (y:Net J X), net_limit x x0 -> Subnet y ->
  net_limit y x0.
Proof.
intros.
destruct H0.
red; intros.
pose proof (H U H2 H3).
destruct H4.
destruct (H1 x1).
destruct H5.
destruct H6.
exists x3.
intros.
apply H4.
apply preord_trans with x2.
apply DS_ord_cond.
assumption.
rewrite <- H6.
apply H0.
assumption.
Qed.

Lemma subnet_cluster_point: forall (x0:point_set X) {J:DirectedSet}
  (y:Net J X), net_cluster_point y x0 ->
  Subnet y -> net_cluster_point x x0.
Proof.
intros.
destruct H0 as [h h_increasing h_dominant].
red; intros.
red; intros.
pose proof (h_dominant i).
destruct H2.
destruct H2.
destruct H3.
pose proof (H U H0 H1 x2).
destruct H4.
destruct H4.
exists (h x3).
split; trivial.
apply preord_trans with x1.
apply DS_ord_cond.
assumption.
rewrite <- H3.
apply h_increasing; assumption.
Qed.

Section cluster_point_subnet.

Variable x0:point_set X.
Hypothesis x0_cluster_point: net_cluster_point x x0.
Hypothesis I_nonempty: inhabited (DS_set I).

Record cluster_point_subnet_DS_set : Type := {
  cps_i:DS_set I;
  cps_U:Ensemble (point_set X);
  cps_U_open_neigh: open_neighborhood cps_U x0;
  cps_xi_in_U: In cps_U (x cps_i)
}.

Definition cluster_point_subnet_DS_ord
  (iU1 iU2 : cluster_point_subnet_DS_set) : Prop :=
  DS_ord (cps_i iU1) (cps_i iU2) /\
  Included (cps_U iU2) (cps_U iU1).

Definition cluster_point_subnet_DS : DirectedSet.
refine (Build_DirectedSet
  cluster_point_subnet_DS_set
  cluster_point_subnet_DS_ord
  _ _).
constructor.
red; intros; split; auto with sets.
apply preord_refl.
apply DS_ord_cond.
red; intros.
destruct H; destruct H0.
red; split; auto with sets.
apply preord_trans with (cps_i y); trivial.
apply DS_ord_cond.

intros.
destruct i as [i0 U0 ? ?]; destruct j as [i1 U1 ? ?].
destruct (DS_join_cond i0 i1).
destruct H.
pose proof (x0_cluster_point
  (Intersection U0 U1)).
match type of H1 with | _ -> _ -> ?C =>
  assert C end.
apply H1.
apply open_intersection2;
  (apply cps_U_open_neigh0 ||
   apply cps_U_open_neigh1).
constructor;
  (apply cps_U_open_neigh0 ||
   apply cps_U_open_neigh1).
destruct (H2 x1).
destruct H3.
pose (ki := x2).
pose (kU := Intersection U0 U1).
assert (open_neighborhood kU x0).
split.
apply open_intersection2.
apply cps_U_open_neigh0.
apply cps_U_open_neigh1.
constructor; (apply cps_U_open_neigh0 ||
              apply cps_U_open_neigh1).
assert (In kU (x ki)).
exact H4.

exists (Build_cluster_point_subnet_DS_set
  ki kU H5 H6).
split; red; simpl; split.
apply preord_trans with x1; trivial.
apply DS_ord_cond.
red; intros.
destruct H7; trivial.
apply preord_trans with x1; trivial.
apply DS_ord_cond.
red; intros.
destruct H7; trivial.
Defined.

Definition cluster_point_subnet : Net
  cluster_point_subnet_DS X :=
  fun (iU:DS_set cluster_point_subnet_DS) =>
  x (cps_i iU).

Lemma cluster_point_subnet_is_subnet:
  Subnet cluster_point_subnet.
Proof.
constructor.
intros.
destruct j1; destruct j2.
simpl in H; simpl.
red in H; tauto.

red; intros.
exists i; split.
apply preord_refl; apply DS_ord_cond.
assert (open_neighborhood Full_set x0).
split.
apply open_full.
constructor.
assert (In Full_set (x i)).
constructor.
exists (Build_cluster_point_subnet_DS_set
  i Full_set H H0).
trivial.
Qed.

Lemma cluster_point_subnet_converges:
  net_limit cluster_point_subnet x0.
Proof.
red; intros.
destruct I_nonempty as [i0].
destruct (x0_cluster_point U H H0 i0).
destruct H1.
assert (open_neighborhood U x0).
split; trivial.
exists (Build_cluster_point_subnet_DS_set
  x1 U H3 H2).
intros.
destruct j.
red in H4; simpl in H4.
red in H4; simpl in H4.
unfold cluster_point_subnet; simpl.
destruct H4; auto with sets.
Qed.

Lemma net_cluster_point_impl_subnet_converges:
  exists J:DirectedSet, exists y:Net J X,
  Subnet y /\ net_limit y x0.
Proof.
exists cluster_point_subnet_DS.
exists cluster_point_subnet.
split.
exact cluster_point_subnet_is_subnet.
exact cluster_point_subnet_converges.
Qed.

End cluster_point_subnet.

End Subnet.


Require Export SfLib.

Module AExp.

Inductive aexp : Type :=
| ANum : nat -> aexp
| APlus : aexp -> aexp -> aexp
| AMinus : aexp -> aexp -> aexp
| AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
| BTrue : bexp
| BFalse : bexp
| BEq : aexp -> aexp -> bexp
| BLe : aexp -> aexp -> bexp
| BNot : bexp -> bexp
| BAnd : bexp -> bexp -> bexp.

Fixpoint aeval (e:aexp) : nat :=
  match e with
  | ANum n => n
  | APlus a1 a2 => (aeval a1) + (aeval a2)
  | AMinus a1 a2 => (aeval a1) - (aeval a2)
  | AMult a1 a2 => (aeval a1) * (aeval a2)
  end.

Example test_aeval1:
  aeval (APlus (ANum 2) (ANum 2)) = 4.
Proof. reflexivity. Qed.

Fixpoint beval (e:bexp) : bool :=
  match e with
  | BTrue => true
  | BFalse => false
  | BEq a1 a2 => beq_nat (aeval a1) (aeval a2)
  | BLe a1 a2 => ble_nat (aeval a1) (aeval a2)
  | BNot b1 => negb (beval b1)
  | BAnd b1 b2 => andb (beval b1) (beval b2)
  end.

Fixpoint optimize_0plus (e:aexp) : aexp :=
  match e with
  | ANum n => ANum n
  | APlus (ANum 0) e2 => optimize_0plus e2
  | APlus e1 e2 =>
    APlus (optimize_0plus e1) (optimize_0plus e2)
  | AMinus e1 e2 =>
    AMinus (optimize_0plus e1) (optimize_0plus e2)
  | AMult e1 e2 =>
    AMult (optimize_0plus e1) (optimize_0plus e2)
  end.

Example test_optimize_0plus:
  optimize_0plus (APlus (ANum 2)
                 (APlus (ANum 0)
                 (APlus (ANum 0) (ANum 1))))
  = APlus (ANum 2) (ANum 1).
Proof. reflexivity. Qed.

Theorem optimize_0plus_sound : forall e,
    aeval (optimize_0plus e) = aeval e.
Proof.
  intros e. induction e.
  Case "ANum". reflexivity.
  Case "APlus". destruct e1.
    SCase "e1 = ANum n". destruct n.
      SSCase "n = 0". simpl. apply IHe2.
      SSCase "n <> 0". simpl. rewrite IHe2. reflexivity.
    SCase "e1 = APlus e1_1 e1_2".
      simpl. simpl in IHe1. rewrite IHe1.
      rewrite IHe2. reflexivity.
    SCase "e1 = AMinus e1_1 e1_2".
      simpl. simpl in IHe1. rewrite IHe1.
      rewrite IHe2. reflexivity.
    SCase "e1 = AMult e1_1 e1_2".
      simpl. simpl in IHe1. rewrite IHe1.
      rewrite IHe2. reflexivity.
  Case "AMinus".
    simpl. rewrite IHe1. rewrite IHe2. reflexivity.
  Case "AMult".
    simpl. rewrite IHe1. rewrite IHe2. reflexivity.
Qed.

Lemma foo : forall n, ble_nat 0 n = true.
Proof.
  intros.
  destruct n.
    Case "n=0". simpl. reflexivity.
    Case "n=Sn". simpl. reflexivity.
Qed.

Lemma foo' : forall n, ble_nat 0 n = true.
Proof.
  intros.
  destruct n;
    simpl;
    reflexivity.
Qed.

Theorem optimize_0plus_sound' : forall e,
    aeval (optimize_0plus e) = aeval e.
Proof.
  intros e.
  induction e;
    try (simpl; rewrite IHe1; rewrite IHe2; reflexivity).
  Case "ANum". reflexivity.
  Case "APlus".
    destruct e1;
      try (simpl; simpl in IHe1; rewrite IHe1; rewrite IHe2; reflexivity).
    SCase "e1 = ANum n".
      destruct n;
        simpl; rewrite IHe2; reflexivity.
Qed.

Theorem optimize_0plus_sound'' : forall e,
    aeval (optimize_0plus e) = aeval e.
Proof.
  intros e.
  induction e;
    try (simpl; rewrite IHe1; rewrite IHe2; reflexivity);
    try reflexivity.
  Case "APlus".
    destruct e1; try (simpl; simpl in IHe1; rewrite IHe1;
                     rewrite IHe2; reflexivity).
    SCase "e1 = ANum n".
      destruct n; simpl; rewrite IHe2; reflexivity.
Qed.

Tactic Notation "simpl_and_try" tactic(c) :=
  simpl;
  try c.

Tactic Notation "aexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ANum" | Case_aux c "APlus" |
    Case_aux c "AMinus" | Case_aux c "AMult" ].

Theorem optimize_0plus_sound''' : forall e,
    aeval (optimize_0plus e) = aeval e.
Proof.
  intros e.
  aexp_cases (induction e) Case;
    try (simpl; rewrite IHe1; rewrite IHe2; reflexivity);
    try reflexivity.
  Case "APlus".
    aexp_cases (destruct e1) SCase;
      try (simpl; simpl in IHe1; rewrite IHe1; rewrite IHe2; reflexivity).
    SCase "ANum". destruct n;
      simpl; rewrite IHe2; reflexivity.
Qed.

Tactic Notation "bexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "BTrue" | Case_aux c "BFalse" |
    Case_aux c "BEq"   | Case_aux c "BLe" |
    Case_aux c "BNot"  | Case_aux c "BAnd" ].

Fixpoint optimize_0plus_b (e:bexp) : bexp :=
  match e with
  | BEq a1 a2 => BEq (optimize_0plus a1) (optimize_0plus a2)
  | BLe a1 a2 => BLe (optimize_0plus a1) (optimize_0plus a2)
  | _ => e
  end.

Example optimize_0plus_b_test1:
  optimize_0plus_b (BEq (APlus (ANum 0) (ANum 2))
                   (ANum 2))
  = (BEq (ANum 2) (ANum 2)).
Proof. reflexivity. Qed.

Theorem optimize_0plus_b_sound : forall e,
    beval (optimize_0plus_b e) = beval e.
Proof.
  intros e.
  bexp_cases (induction e) Case;
    try (simpl; rewrite optimize_0plus_sound;
         rewrite optimize_0plus_sound; reflexivity);
    try reflexivity.
Qed.

Module aevalR_first_try.

Inductive aevalR : aexp -> nat -> Prop :=
| E_ANum : forall (n:nat),
    aevalR (ANum n) n
| E_APlus : forall (e1 e2 : aexp) (n1 n2 : nat),
    aevalR e1 n1 ->
    aevalR e2 n2 ->
    aevalR (APlus e1 e2) (n1 + n2)
| E_AMinus : forall (e1 e2 : aexp) (n1 n2 : nat),
    aevalR e1 n1 ->
    aevalR e2 n2 ->
    aevalR (AMinus e1 e2) (n1 - n2)
| E_AMult : forall (e1 e2 : aexp) (n1 n2 : nat),
    aevalR e1 n1 ->
    aevalR e2 n2 ->
    aevalR (AMult e1 e2) (n1 * n2).

Notation "e '||' n" := (aevalR e n) : type_scope.

End aevalR_first_try.

Reserved Notation "e '||' n" (at level 50, left associativity).

Inductive aevalR : aexp -> nat -> Prop :=
| E_ANum : forall (n:nat),
    (ANum n) || n
| E_APlus : forall (e1 e2 : aexp) (n1 n2 : nat),
    (e1 || n1) -> (e2 || n2) -> (APlus e1 e2) || (n1 + n2)
| E_AMinus : forall (e1 e2 : aexp) (n1 n2 : nat),
    (e1 || n1) -> (e2 || n2) -> (AMinus e1 e2) || (n1 - n2)
| E_AMult : forall (e1 e2 : aexp) (n1 n2 : nat),
    (e1 || n1) -> (e2 || n2) -> (AMult e1 e2) || (n1 * n2)
where "e '||' n" := (aevalR e n) : type_scope.

Tactic Notation "aevalR_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_ANum"   | Case_aux c "E_APlus" |
    Case_aux c "E_AMinus" | Case_aux c "E_AMult" ].

Theorem aeval_iff_aevalR : forall a n,
    (a || n) <-> aeval a = n.
Proof.
  split.
  Case "->".
    intros H.
    aevalR_cases (induction H) SCase; simpl.
    SCase "E_ANum".
      reflexivity.
    SCase "E_APlus".
      rewrite IHaevalR1. rewrite IHaevalR2. reflexivity.
    SCase "E_AMinus".
      rewrite IHaevalR1. rewrite IHaevalR2. reflexivity.
    SCase "E_AMult".
      rewrite IHaevalR1. rewrite IHaevalR2. reflexivity.
  Case "<-".
    generalize dependent n.
    aexp_cases (induction a) SCase;
      simpl; intros; subst.
    SCase "ANum".
      apply E_ANum.
    SCase "APlus".
      apply E_APlus.
      apply IHa1. reflexivity.
      apply IHa2. reflexivity.
    SCase "AMinus".
      apply E_AMinus.
      apply IHa1. reflexivity.
      apply IHa2. reflexivity.
    SCase "AMult".
      apply E_AMult.
      apply IHa1. reflexivity.
      apply IHa2. reflexivity.
Qed.

Theorem aeval_iff_aevalR' : forall a n,
    (a || n) <-> aeval a = n.
Proof.
  split.
  Case "->".
    intros H; induction H; subst; reflexivity.
  Case "<-".
    generalize dependent n.
    induction a; simpl; intros; subst; constructor;
      try apply IHa1; try apply IHa2; reflexivity.
Qed.

Reserved Notation "e '||' n" (at level 50, left associativity).

Inductive bevalR : bexp -> bool -> Prop :=
| E_BTrue :
    BTrue || true
| E_BFalse :
    BFalse || false
| E_BEq : forall (e1 e2 : aexp) (n1 n2 : nat),
    aevalR e1 n1 ->
    aevalR e2 n2 ->
    (BEq e1 e2) || (beq_nat n1 n2)
| E_BLe : forall (e1 e2 : aexp) (n1 n2 : nat),
    aevalR e1 n1 ->
    aevalR e2 n2 ->
    (BLe e1 e2) || (ble_nat n1 n2)
| E_BNot : forall (e : bexp) (b : bool),
    e || b ->
    (BNot e) || (negb b)
| E_BAnd : forall (e1 e2 : bexp) (b1 b2 : bool),
    e1 || b1 ->
    e2 || b2 ->
    (BAnd e1 e2) || (andb b1 b2)
where "e '||' n" := (bevalR e n) : type_scope.

Tactic Notation "bevalR_cases" tactic(first) ident(c) :=
  first;
  [Case_aux c "E_BTrue" | Case_aux c "E_BFalse" |
   Case_aux c "E_BEq"   | Case_aux c "E_BLe" |
   Case_aux c "E_BNot"  | Case_aux c "E_BAnd" ].

Theorem beval_iff_bevalR : forall e b,
    (e || b) <-> beval e = b.
Proof.
  split.
  Case "->".
    intros H; induction H; simpl;
      try (apply aeval_iff_aevalR in H;
           apply aeval_iff_aevalR in H0);
      subst; reflexivity.
  Case "<-".
    generalize dependent b.
    induction e; simpl; intros; subst; constructor;
    try apply aeval_iff_aevalR;
    try apply IHe;
    try apply IHe1;
    try apply IHe2;
    reflexivity.
Qed.

End AExp.

Module Id.

Inductive id : Type :=
| Id : nat -> id.

Definition beq_id X1 X2 :=
  match (X1, X2) with
    (Id n1, Id n2) => beq_nat n1 n2
  end.

Theorem beq_id_refl : forall X,
    true = beq_id X X.
Proof.
  intros. destruct X.
  apply beq_nat_refl.
Qed.

Theorem beq_id_eq : forall i1 i2,
    true = beq_id i1 i2 -> i1 = i2.
Proof.
  intros. destruct i1 as [n]. destruct i2 as [m].
  unfold beq_id in H. apply beq_nat_eq in H.
  subst. reflexivity.
Qed.

Theorem beq_id_false_not_eq : forall i1 i2,
    beq_id i1 i2 = false -> i1 <> i2.
Proof.
  intros. destruct i1 as [n]. destruct i2 as [m].
  unfold beq_id in H. apply beq_nat_false in H.
  (*ここからSfLiを見てしまいました*)
  intros C. apply H. inversion C. reflexivity.
Qed.

Theorem not_eq_beq_id_false : forall i1 i2,
    i1 <> i2 -> beq_id i1 i2 = false.
Proof.
  intros. destruct i1 as [n]. destruct i2 as [m].
  (*ここからSfLibの中を見てしまいました*)
  assert (n <> m).
  Case "Proof of assertion".
    intros G. apply H. subst. reflexivity.
    apply not_eq_beq_false. apply H0.
Qed.

Theorem beq_id_sym : forall i1 i2,
    beq_id i1 i2 = beq_id i2 i1.
Proof.
  intros. destruct i1 as [n]. destruct i2 as [m].
  unfold beq_id. apply beq_nat_sym.
Qed.

End Id.

Definition state := id -> nat.

Definition empty_state : state :=
  fun _ => 0.

Definition update (st:state) (X:id) (n:nat) : state :=
  fun X' => if beq_id X X' then n else st X'.

Theorem update_eq : forall n X st,
    (update st X n) X = n.
Proof.
  intros. unfold update.
  rewrite <- beq_id_refl. reflexivity.
Qed.

Theorem update_neq : forall V2 V1 n st,
    beq_id V2 V1 = false ->
    (update st V2 n) V1 = (st V1).
Proof.
  intros. unfold update. rewrite H. reflexivity.
Qed.

Theorem update_example : forall (n:nat),
    (update empty_state (Id 2) n) (Id 3) = 0.
Proof.
  intros. unfold update. simpl. unfold empty_state. reflexivity.
Qed.

Theorem update_shadow : forall x1 x2 k1 k2 (f : state),
    (update (update f k2 x1) k2 x2) k1 = (update f k2 x2) k1.
Proof.
  intros. unfold update.
  destruct (beq_id k2 k1) as []eqn:?.
  (* 上の代わりに下記のtacticでもおｋ
  case_eq (beq_id k2 k1).
   *)
  Case "beq_id k2 k1 = true". reflexivity.
  Case "beq_id k2 k1 = false". reflexivity.
Qed.

Theorem update_same : forall x1 k1 k2 (f:state),
    f k1 = x1 ->
    (update f k1 x1) k2 = f k2.
Proof.
  intros. unfold update.
  destruct (beq_id k1 k2) as []eqn:?.
  Case "beq_id k1 k2 = true".
    apply eq_sym in Heqb.
    apply beq_id_eq in Heqb.
    rewrite <- H. rewrite Heqb. reflexivity.
  Case "beq_id k1 k2 = false".
    reflexivity.
Qed.

Theorem update_permute : forall x1 x2 k1 k2 k3 f,
    beq_id k2 k1 = false ->
    (update (update f k2 x1) k1 x2) k3 = (update (update f k1 x2) k2 x1) k3.
Proof.
  intros. unfold update.
  case_eq (beq_id k1 k3); intros.
  Case "beq_id k1 k3 = true".
    apply eq_sym in H0. apply beq_id_eq in H0.
    subst. rewrite H. reflexivity.
  Case "beq_id k1 k3 = false".
    reflexivity.
Qed.

Inductive aexp : Type :=
| ANum : nat -> aexp
| AId : id -> aexp
| APlus : aexp -> aexp -> aexp
| AMinus : aexp -> aexp -> aexp
| AMult : aexp -> aexp -> aexp.

Tactic Notation "aexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ANum" | Case_aux c "AId" | Case_aux c "APlus"
  | Case_aux c "AMinus" | Case_aux c "AMult" ].

Definition X : id := Id 0.
Definition Y : id := Id 1.
Definition Z : id := Id 2.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Tactic Notation "bexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "BTrue" | Case_aux c "BFalse" | Case_aux c "BEq"
  | Case_aux c "BLe" | Case_aux c "BNot" | Case_aux c "BAnd" ].

Fixpoint aeval (st : state) (e : aexp) : nat :=
  match e with
  | ANum n => n
  | AId X => st X
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2 => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (e : bexp) : bool :=
  match e with
  | BTrue => true
  | BFalse => false
  | BEq a1 a2 => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2 => ble_nat (aeval st a1) (aeval st a2)
  | BNot b1 => negb (beval st b1)
  | BAnd b1 b2 => andb (beval st b1) (beval st b2)
  end.

Example aexp1 :
  aeval (update empty_state X 5)
        (APlus (ANum 3) (AMult (AId X) (ANum 2)))
  = 13.
Proof. reflexivity.
Qed.

Example bexp1 :
  beval (update empty_state X 5)
        (BAnd BTrue (BNot (BLe (AId X) (ANum 4))))
  = true.
Proof. reflexivity.
Qed.

Inductive com : Type :=
| CSkip : com
| CAss : id -> aexp -> com
| CSeq : com -> com -> com
| CIf : bexp -> com -> com -> com
| CWhile : bexp -> com -> com.

Tactic Notation "com_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "SKIP" | Case_aux c "::=" | Case_aux c ";"
  | Case_aux c "IFB" | Case_aux c "WHILE" ].

Notation "'SKIP'" :=
  CSkip.
Notation "X '::=' a" :=
  (CAss X a) (at level 60).
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).

Definition fact_in_coq : com :=
  Z ::= AId X;
  Y ::= ANum 1;
  WHILE BNot (BEq (AId Z) (ANum 0)) DO
        Y ::= AMult (AId Y) (AId Z);
        Z ::= AMinus (AId Z) (ANum 1)
  END.

Definition plus2 : com :=
  X ::= (APlus (AId X) (ANum 2)).

Definition XtimesYinZ : com :=
  Z ::= (AMult (AId X) (AId Y)).

Definition subtract_slowly_body : com :=
  Z ::= AMinus (AId Z) (ANum 1);
  X ::= AMinus (AId X) (ANum 1).

Definition subtract_slowly : com :=
  WHILE BNot (BEq (AId X) (ANum 0)) DO
    subtract_slowly_body
  END.

Definition subtract_3_from_5_slowly : com :=
  X ::= ANum 3;
  Z ::= ANum 5;
  subtract_slowly.

Definition loop : com :=
  WHILE BTrue DO
        SKIP
  END.

Definition fact_body : com :=
  Y ::= AMult (AId Y) (AId Z) ;
  Z ::= AMinus (AId Z) (ANum 1).

Definition fact_loop : com :=
  WHILE BNot (BEq (AId Z) (ANum 0)) DO
    fact_body
  END.

Definition fact_com : com :=
  Z ::= AId X ;
  Y ::= ANum 1 ;
  fact_loop.

Fixpoint ceval_step1 (st : state) (c : com) : state :=
  match c with
  | SKIP =>
    st
  | l ::= a1 =>
          update st l (aeval st a1)
  | c1 ; c2 =>
    let st' := ceval_step1 st c1 in
    ceval_step1 st' c2
  | IFB b THEN c1 ELSE c2 FI =>
    if (beval st b)
         then ceval_step1 st c1
         else ceval_step1 st c2
  | WHILE b1 DO c1 END =>
    st
end.

Fixpoint ceval_step2 (st : state) (c : com) (i : nat) : state :=
  match i with
  | O  => empty_state
  | S i' =>
    match c with
    | SKIP =>
      st
    | l ::= a1 =>
            update st l (aeval st a1)
    | c1 ; c2 =>
      let st' := ceval_step2 st c1 i' in
      ceval_step1 st' c2
    | IFB b THEN c1 ELSE c2 FI =>
      if (beval st b)
      then ceval_step2 st c1 i'
      else ceval_step2 st c2 i'
    | WHILE b1 DO c1 END =>
      if (beval st b1)
      then let st' := ceval_step2 st c1 i' in
           ceval_step2 st' c i'
      else st
    end
end.

Fixpoint ceval_step3 (st : state) (c : com) (i : nat) : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
    | SKIP =>
      Some st
    | l ::= a1 =>
            Some (update st l (aeval st a1))
    | c1 ; c2 =>
      match (ceval_step3 st c1 i') with
      | Some st' => ceval_step3 st' c2 i'
      | None => None
      end
    | IFB b THEN c1 ELSE c2 FI =>
      if (beval st b)
      then ceval_step3 st c1 i'
      else ceval_step3 st c2 i'
    | WHILE b1 DO c1 END =>
      if (beval st b1)
      then match (ceval_step3 st c1 i') with
           | Some st' => ceval_step3 st' c i'
           | None => None
           end
      else Some st
    end
end.

Notation "'LETOPT' x <== e1 'IN' e2" :=
  (match e1 with
   | Some x => e2
   | None => None
   end)
    (right associativity, at level 60).

Fixpoint ceval_step (st : state) (c : com) (i : nat) : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
    | SKIP =>
      Some st
    | l ::= a1 =>
            Some (update st l (aeval st a1))
    | c1 ; c2 =>
      LETOPT st' <== ceval_step st c1 i' IN
             ceval_step st' c2 i'
    | IFB b THEN c1 ELSE c2 FI =>
      if (beval st b)
      then ceval_step st c1 i'
      else ceval_step st c2 i'
    | WHILE b1 DO c1 END =>
      if (beval st b1)
      then LETOPT st' <== ceval_step st c1 i' IN
                  ceval_step st' c i'
      else Some st
    end
end.

Definition test_ceval (st:state) (c:com) :=
  match ceval_step st c 500 with
  | None => None
  | Some st => Some (st X, st Y, st Z)
  end.

Definition pup_to_n : com :=
  Y ::= ANum 0;
  WHILE (BLe (ANum 1) (AId X)) DO
        Y ::= APlus (AId Y) (AId X);
        X ::= AMinus (AId X) (ANum 1)
  END.

Example pup_to_n_1 :
  test_ceval (update empty_state X 5) pup_to_n
  = Some (0, 15, 0).
Proof. reflexivity. Qed.

Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st || st
  | E_Ass : forall st a1 n l,
      aeval st a1 = n ->
      (l ::= a1) / st || (update st l n)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st || st' ->
      c2 / st' || st'' ->
      (c1; c2) / st || st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval st b1 = true ->
      c1 / st || st' ->
      (IFB b1 THEN c1 ELSE c2 FI) / st || st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval st b1 = false ->
      c2 / st || st' ->
      (IFB b1 THEN c1 ELSE c2 FI) / st || st'
  | E_WhileEnd : forall b1 st c1,
      beval st b1 = false ->
      (WHILE b1 DO c1 END) / st || st
  | E_WhileLoop : forall st st' st'' b1 c1,
      beval st b1 = true ->
      c1 / st || st' ->
      (WHILE b1 DO c1 END) / st' || st'' ->
      (WHILE b1 DO c1 END) / st || st''
where "c1 '/' st '||' st'" := (ceval c1 st st').

Tactic Notation "ceval_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_Skip" | Case_aux c "E_Ass" | Case_aux c "E_Seq"
  | Case_aux c "E_IfTrue" | Case_aux c "E_IfFalse" | Case_aux c "E_WhileEnd" | Case_aux c "E_WhileLoop" ].

Example ceval_example1:
  (X ::= ANum 2;
  IFB BLe (AId X) (ANum 1) THEN
    Y ::= ANum 3
  ELSE
    Z ::= ANum 4
  FI)
    / empty_state
    || (update (update empty_state X 2) Z 4).
Proof.
  apply E_Seq with (update empty_state X 2).
  Case "assignment command".
    apply E_Ass. reflexivity.
  Case "if command".
    apply E_IfFalse.
    reflexivity.
    apply E_Ass. reflexivity.
Qed.

Example ceval_example2:
  (X ::= ANum 0; Y ::= ANum 1; Z ::= ANum 2) / empty_state ||
  (update (update (update empty_state X 0) Y 1) Z 2).
Proof.
  apply E_Seq with (update empty_state X 0).
  apply E_Ass. reflexivity.
  apply E_Seq with (update (update empty_state X 0) Y 1).
  apply E_Ass. reflexivity.
  apply E_Ass. reflexivity.
Qed.

Theorem ceval_step__ceval : forall c st st',
    (exists i, ceval_step st c i = Some st') ->
    c / st || st'.
Proof.
  intros c st st' H.
  inversion H as [i E].
  clear H.
  generalize dependent st'.
  generalize dependent st.
  generalize dependent c.
  induction i as [| i'].
  Case "i = 0 -- contradictory".
    intros c st st' H. inversion H.
  Case "i = S i'".
    intros c st st' H.
    com_cases (destruct c) SCase;
      simpl in H; inversion H; subst; clear H.
    SCase "SKIP". apply E_Skip.
    SCase "::=". apply E_Ass. reflexivity.
    SCase ";".
      remember (ceval_step st c1 i') as r1. destruct r1.
      SSCase "Evaluation of r1 terminates normally".
        apply E_Seq with s.
          apply IHi'. rewrite Heqr1. reflexivity.
          apply IHi'. simpl in H1. assumption.
      SSCase "Otherwise -- contradiction".
        inversion H1.
    SCase "IFB".
      remember (beval st b) as r. destruct r.
      SSCase "r = true".
        apply E_IfTrue. rewrite Heqr. reflexivity.
        apply IHi'. assumption.
      SSCase "r = false".
        apply E_IfFalse. rewrite Heqr. reflexivity.
        apply IHi'. assumption.
    SCase "WHILE". remember (beval st b) as r. destruct r.
      SSCase "r = true".
        remember (ceval_step st c i') as r1. destruct r1.
        SSSCase "r1 = Some s".
          apply E_WhileLoop with s. rewrite Heqr. reflexivity.
          apply IHi'. rewrite Heqr1. reflexivity.
          apply IHi'. simpl in H1. assumption.
        SSSCase "r1 = None".
          inversion H1.
      SSCase "r = false".
        inversion H1.
        apply E_WhileEnd.
        rewrite Heqr. subst. reflexivity.
Qed.

Theorem ceval_step_more : forall i1 i2 st st' c,
    i1 <= i2 ->
    ceval_step st c i1 = Some st' ->
    ceval_step st c i2 = Some st'.
Proof.
  induction i1 as [| i1']; intros i2 st st' c Hle Hceval.
  Case "i1 = 0".
    inversion Hceval.
  Case "i1 = S i1'".
    destruct i2 as [| i2']. inversion Hle.
    assert (Hle': i1' <= i2') by omega.
    com_cases (destruct c) SCase.
    SCase "SKIP".
      simpl in Hceval. inversion Hceval.
      reflexivity.
    SCase "::=".
      simpl in Hceval. inversion Hceval.
      reflexivity.
    SCase ";".
      simpl in Hceval. simpl.
      remember (ceval_step st c1 i1') as st1'o.
      destruct st1'o.
      SSCase "st1'o = Some".
        symmetry in Heqst1'o.
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite Heqst1'o.
        apply (IHi1' i2') in Hceval; try assumption.
      SSCase "st1'o = None".
        inversion Hceval.
    SCase "IFB".
      simpl in Hceval. simpl.
      remember (beval st b) as bval.
      destruct bval; apply (IHi1' i2') in Hceval; assumption.
    SCase "WHILE".
      simpl in Hceval. simpl.
      destruct (beval st b); try assumption.
      remember (ceval_step st c i1') as st1'o.
      destruct st1'o.
      SSCase "st1'o = Some".
        symmetry in Heqst1'o.
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite -> Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      SSCase "st1'o = None".
        simpl in Hceval. inversion Hceval.
Qed.

Theorem ceval__ceval_step : forall c st st',
    c / st || st' ->
    exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st' Hce.
  ceval_cases (induction Hce) Case.
  Case "E_Skip". exists 1. reflexivity.
  Case "E_Ass". exists 1. simpl. rewrite H. reflexivity.
  Case "E_Seq". destruct IHHce1. destruct IHHce2.
    exists (1 + x + x0). simpl.
    remember (ceval_step st c1 (x + x0)) as r.
    destruct r.
    SCase "r = Some".
      apply ceval_step_more with (i2 := (x + x0)) in H.
      rewrite H in Heqr. inversion Heqr.
      apply ceval_step_more with (i1 := x0). omega.
      assumption. omega.
    SCase "r = None".
      apply ceval_step_more with (i2 := (x + x0)) in H.
      rewrite H in Heqr. inversion Heqr. omega.
  Case "E_IfTrue". destruct IHHce.
    exists (1 + x). simpl. rewrite H. apply H0.
  Case "E_IfFalse". destruct IHHce.
    exists (1 + x). simpl. rewrite H. apply H0.
  Case "E_WhileEnd". exists 1. simpl. rewrite H. reflexivity.
  Case "E_WhileLoop". destruct IHHce1. destruct IHHce2.
    exists (1 + x + x0). simpl. rewrite H.
    remember (ceval_step st c1 (x + x0)) as r.
    destruct r.
    SCase "r = Some".
      apply ceval_step_more with (i2 := x + x0) in H0.
      rewrite H0 in Heqr. inversion Heqr.
      apply ceval_step_more with (i2 := x + x0) in H1.
      assumption. omega. omega.
    SCase "r = None".
      apply ceval_step_more with (i2 := x + x0) in H0.
      rewrite H0 in Heqr. inversion Heqr. omega.
Qed.

Theorem ceval_and_ceval_step_coincide : forall c st st',
    c / st || st'
    <-> exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st'.
  split. apply ceval__ceval_step. apply ceval_step__ceval.
Qed.

Theorem ceval_deterministic : forall c st st1 st2,
    c / st || st1 ->
    c / st || st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2.
  ceval_cases (induction E1) Case;
    intros st2 E2; inversion E2; subst.
  Case "E_Skip". reflexivity.
  Case "E_Ass". reflexivity.
  Case "E_Seq".
    assert (st' = st'0) as EQ1.
    SCase "Proof of assertion". apply IHE1_1; assumption.
    subst st'0.
    apply IHE1_2. assumption.
  Case "E_IfTrue".
    SCase "b1 evaluates to true".
      apply IHE1. assumption.
    SCase "b1 evaluates to false (contradiction)".
      rewrite H in H5. inversion H5.
  Case "E_IfFalse".
    SCase "b1 evaluates to true (contradiction)".
      rewrite H in H5. inversion H5.
    SCase "b1 evaluates to false".
      apply IHE1. assumption.
  Case "E_WhileEnd".
    SCase "b1 evaluates to true".
      reflexivity.
    SCase "b1 evaluates to false (contradiction)".
      rewrite H in H2. inversion H2.
  Case "E_WhileLoop".
    SCase "b1 evaluates to true (contradiction)".
      rewrite H in H4. inversion H4.
    SCase "b1 evaluates to false".
      assert (st' = st'0) as EQ1.
      SSCase "Proof of assertion". apply IHE1_1; assumption.
      subst st'0.
      apply IHE1_2. assumption.
Qed.

Theorem ceval_deterministic' : forall c st st1 st2,
    c / st || st1 ->
    c / st || st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 He1 He2.
  apply ceval__ceval_step in He1.
  apply ceval__ceval_step in He2.
  inversion He1 as [i1 E1].
  inversion He2 as [i2 E2].
  apply ceval_step_more with (i2 := i1 + i2) in E1.
  apply ceval_step_more with (i2 := i1 + i2) in E2.
  rewrite E1 in E2. inversion E2. reflexivity.
  omega. omega.
Qed.

Theorem plus2_spec : forall st n st',
    st X = n ->
    plus2 / st || st' ->
    st' X = n + 2.
Proof.
  intros st n st' HX Heval.
  inversion Heval. subst.
  apply update_eq.
Qed.

Theorem XtimesYinZ_spec : forall st st' n m,
    st X = n ->
    st Y = m ->
    XtimesYinZ / st || st' ->
    st' Z = n * m.
Proof.
  intros st st' n m HX HY Heval.
  inversion Heval. subst.
  apply update_eq.
Qed.

Theorem loop_never_stops : forall st st',
    ~(loop / st || st').
Proof.
  intros st st' contra. unfold loop in contra.
  remember (WHILE BTrue DO SKIP END) as loopdef.
  induction contra; inversion Heqloopdef.
    Case "E_WhileEnd".
      rewrite H1 in H. simpl in H. inversion H.
    Case "E_WhileLoop". contradiction.
Qed.

Fixpoint no_whiles (c : com) : bool :=
  match c with
  | SKIP => true
  | _ ::= _ => true
  | c1 ; c2 => andb (no_whiles c1) (no_whiles c2)
  | IFB _ THEN ct ELSE cf FI => andb (no_whiles ct) (no_whiles cf)
  | WHILE _ DO _ END => false
  end.

(*
Inductive no_whilesR: com -> Prop :=
| NW_Skip : no_whilesR SKIP
| NW_Ass : forall l a,
    no_whilesR (l ::= a)
| NW_Seq : forall c1 c2,
    no_whilesR c1 ->
    no_whilesR c2 ->
    no_whilesR (c1 ; c2)
| NW_If : forall c1 c2 b,
    no_whilesR c1 ->
    no_whilesR c2 ->
    no_whilesR (IFB b THEN c1 ELSE c2 FI)
.

Theorem no_whiles_eqv : forall c,
    no_whiles c = true <-> no_whilesR c.
Proof.
  intros. split.
  Case "->". intro.
    com_cases (induction c) SCase; try (constructor).
    SCase ";".
      simpl in H. apply IHc1. rewrite <- H.
*)


(* Exercise coq_nat_09 *)

(* Now, let us prove that multiplication is commutative *)

(* For this we may need to use some properties of addition and multiplication
   that we proved before. *)
Require Import Arith.
Check mult_0_r.
Check plus_comm.
Check plus_assoc.

(* ... and a following auxiliary lemma *)

Lemma mult_succ : forall m n, n + n * m = n * S m.
Proof.
intros.
induction n.
simpl; reflexivity.
simpl.
rewrite <- IHn.
rewrite Nat.add_comm.
rewrite Nat.add_assoc.
rewrite Nat.add_comm with (n := m+n*m).
rewrite Nat.add_assoc.
rewrite Nat.add_comm with (n := n).
reflexivity.
Qed.

Lemma mult_comm : forall m n, m * n = n * m.

Proof.
intros.
induction m.
rewrite Nat.mul_0_r.
simpl.
reflexivity.
simpl.
rewrite IHm.
rewrite mult_succ.
reflexivity.
Qed.


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

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

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

Theorem test: forall code: bin, bin_to_nat(incr(code)) = 1 + bin_to_nat(code).
Proof.
intros n.
induction n as [|n'1 IHn1|n'2 IHn2].
- simpl. reflexivity.
- destruct n'1; repeat auto.
- destruct n'2.
  * reflexivity.
  * destruct n'2; repeat (simpl; auto).
  * simpl.
    simpl in IHn2.
    rewrite -> IHn2.
    destruct n'2; repeat (simpl; auto).
Qed.


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := nil : Lst | cons : Nat -> Lst -> Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : Lst) : Lst
           := match rev_arg0 with
              | nil => nil
              | cons x y => append (rev y) (cons x nil)
              end.

Lemma append_nil : forall (x : Lst), append x nil = x.
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : Lst), append (append x y) z = append x (append y z).
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.

Lemma rev_append : forall (x y : Lst), rev (append x y) = append (rev y) (rev x).
Proof.
  intros.
  induction x.
  - simpl. rewrite append_nil. reflexivity.
  - simpl. rewrite IHx. rewrite append_assoc. reflexivity.
Qed.

Lemma rev_rev : forall (x : Lst), rev (rev x) = x.
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite rev_append. simpl. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : Lst) (y : Lst), eq (rev (append (rev x) (rev y))) (append y x).
Proof.
  induction x.
  - intros. simpl. rewrite rev_rev. rewrite append_nil. reflexivity.
  - intros. simpl. rewrite rev_append. simpl. rewrite (eq_refl : cons n nil = rev (cons n nil)). rewrite IHx. rewrite rev_rev. simpl. reflexivity.
Qed.


Require Import Nat.
Require Import Arith.

(*
  The "Tm" type and the previously defined typing relation.
*)

Inductive Tm : Set :=
  | num (n : nat)
  | plus (t t' : Tm)
  | isZero (t : Tm)
  | true
  | false
  | ifThenElse (t t' t'' : Tm)
.

Notation "t + t'" := (plus t t') : term_scope.
Notation
  "'If' t 'then' t' 'else' t''" :=
  (ifThenElse t t' t'')
  (at level 100)
  : term_scope
.

(* Delimit Scope term_scope with term. *)
(* Bind Scope term_scope with Tm. *)
Open Scope term_scope.

(* Compute (plus (num 1) (num 2)). *)
Compute (num 1 + num (2 + 3)).
Compute (2 + 4)%nat.

(* The set of Ty and the inductive typing relation. *)

Inductive Ty : Set := Nat | Bool.

Inductive TypeJudgement : Tm -> Ty -> Prop :=
  | TJ_num {n : nat} : (num n) :: Nat
  | TJ_plus {t t' : Tm} (j : t :: Nat) (j' : t' :: Nat) : (t + t') :: Nat
  | TJ_isZero {t : Tm} (j : t :: Nat) : (isZero t) :: Bool
  | TJ_true : true :: Bool
  | TJ_false : false :: Bool

  | TJ_ifThenElse
    {t t' t'' : Tm} {A : Ty}
    (j : t :: Bool) (j' : t' :: A) (j'' : t'' :: A)
    : (If t then t' else t'') :: A

where "tm :: ty" := (TypeJudgement tm ty) : term_scope.

(*
  2.3. OperĂĄciĂłs szemantika
*)

(* val : 2.9. - 2.11. *)

Reserved Notation "t 'val'" (at level 1).

Inductive ValueJudgement : Tm -> Prop :=
  | VJ_num {n : nat} : (num n) val
  | VJ_true : true val
  | VJ_false : false val
where
  "t 'val'" :=
  (ValueJudgement t)
  : term_scope.

(*
  Transition judgements.
*)

Reserved Notation "t |-> t'" (at level 100).

(* One Step Transition : 2.14. - 2.22. *)

Inductive OneStepTransitionJudgement : Tm -> Tm -> Prop :=
  | OSTJ_sum {n1 n2 n : nat} :
    ((n1 + n2)%nat = n) ->
    num n1 + num n2 |-> num n

  | OSTJ_isZero_true :
    (isZero (num 0)) |-> true

  | OSTJ_isZero_false {n : nat} :
    (n > 0) ->
    isZero (num n) |-> false

  | OSTJ_ifThenElse_true {t t' : Tm} :
    If true then t else t' |-> t

  | OSTJ_ifThenElse_false {t t' : Tm} :
    If false then t else t' |-> t'

  | OSTJ_plus_left {t1 t1' t2 : Tm} :
    (t1 |-> t1') ->
    t1 + t2 |-> t1' + t2

  | OSTJ_plus_right {t1 t2 t2' : Tm} :
    t1 val -> (t2 |-> t2') ->
    t1 + t2 |-> t1 + t2'

  | OSTJ_isZero {t t' : Tm} :
    (t |-> t') ->
    isZero t |-> isZero t'

  | OSTJ_ifThenElse {t t' t1 t2 : Tm} :
    (t |-> t') ->
    If t then t1 else t2 |-> If t' then t1 else t2
where
  "t |-> t'" :=
  (OneStepTransitionJudgement t t')
  : term_scope.

(* Any Step Transition : 2.12. - 2.13. *)

Reserved Notation "t |->* t'" (at level 100).

Inductive AnyStepTransitionJudgement : Tm -> Tm -> Prop :=
  | ASTJ_refl {t : Tm} :
    t |->* t
  | ASTJ_trans {t t'' : Tm} (t' : Tm) :
    (t |-> t') -> (t' |->* t'') ->
    t |->* t''
where "t |->* t'" := (AnyStepTransitionJudgement t t') : term_scope.

Lemma p :
  (num 1 + num 2) + (num 3 + num 4) |-> num 3 + (num 3 + num 4)
.
Proof.
  apply OSTJ_plus_left.
  apply OSTJ_sum.
  simpl. reflexivity.
Qed.

Lemma q :
  num 3 + (num 3 + num 4) |-> num 3 + num 7
.
Proof.
  apply OSTJ_plus_right.
  - apply VJ_num.
  - apply OSTJ_sum.
    simpl. reflexivity.
Qed.

Lemma r :
  num 3 + num 7 |-> num 10
.
Proof.
  apply OSTJ_sum.
  simpl. reflexivity.
Qed.

Lemma TransitionTest1 :
  (num 1 + num 2) + (num 3 + num 4) |->* num 10
.
Proof.
  refine (ASTJ_trans _ p _).
  - refine (ASTJ_trans _ q _).
    + refine (ASTJ_trans _ r _).
      * exact ASTJ_refl.
Qed.

Lemma TransitionTest2 :
  If isZero (num 1 + num 2) then num 1 else (num 3 + num 1) |->* num 4
.
Proof.
  eapply ASTJ_trans.
  {
    eapply OSTJ_ifThenElse.
    eapply OSTJ_isZero.
    eapply OSTJ_sum; reflexivity.
  }

  eapply ASTJ_trans.
  {
    eapply OSTJ_ifThenElse.
    eapply OSTJ_isZero_false.
    eapply gt_Sn_O.
  }

  eapply ASTJ_trans.
  {
    eapply OSTJ_ifThenElse_false.
  }

  eapply ASTJ_trans.
  {
    eapply OSTJ_sum; reflexivity.
  }

  eapply ASTJ_refl.
Qed.

(* Proof.
  refine (ASTJ_trans _ _ _).
  - refine (OSTJ_ifThenElse _).
    + refine (OSTJ_isZero _).
      * refine (OSTJ_sum _).
        -- simpl. reflexivity.
  - refine (ASTJ_trans _ _ _).
    + refine (OSTJ_ifThenElse _).
      * refine (OSTJ_isZero_false _).
        -- auto.
    + refine (ASTJ_trans _ _ _).
      * refine (OSTJ_ifThenElse_false).
      * refine (ASTJ_trans _ _ _).
        -- refine (OSTJ_sum _).
           simpl. reflexivity.
        -- exact ASTJ_refl.
Qed. *)

Ltac transition_solver :=
  repeat (
    (eapply ASTJ_refl)
    ||
    (eapply ASTJ_trans; repeat (
      (eapply OSTJ_sum; reflexivity) ||
      (eapply OSTJ_plus_right; (only 1: eapply VJ_num)) ||
      (eapply OSTJ_plus_left) ||
      (eapply OSTJ_isZero_true) ||
      (eapply OSTJ_isZero_false; eapply gt_Sn_O) ||
      (eapply OSTJ_isZero) ||
      (eapply OSTJ_ifThenElse_true) ||
      (eapply OSTJ_ifThenElse_false) ||
      (eapply OSTJ_ifThenElse)
    ))
  )
.

(*
  2.19. Lemma.
  No transition from val.
*)

Lemma no_val_transition :
  forall t t' : Tm, ~ ((t val) /\ (t |-> t'))
.
Proof.
  unfold not. intros. inversion H.
  induction H1; inversion H0.
Qed.

(*
  2.20. Lemma.
  Determinism.
*)

Lemma determinism {t t'} :
  (t |-> t') -> (forall t'' : Tm, (t |-> t'') -> (t' = t''))
.
Proof.
  intros H.
  induction H.

  (* sum *)
  - intros. inversion H0.
    + rewrite <- H. rewrite <- H4. reflexivity.
    + inversion H4.
    + inversion H5.

  (* isZero_true *)
  - intros. inversion H.
    + reflexivity.
    + inversion H1.
    + inversion H1.

  (* isZero_false *)
  - intros. inversion H0.
    + rewrite <- H2 in H. inversion H.
    + reflexivity.
    + inversion H2.

  (* ifThenElse_true *)
  - intros. inversion H.
    + reflexivity.
    + inversion H4.

  (* ifThenElse_false *)
  - intros. inversion H.
    + reflexivity.
    + inversion H4.

  (* plus_left *)
  - intros. inversion H0.
    + rewrite <- H1 in *. inversion H.
    + pose (ir := IHOneStepTransitionJudgement t1'0 H4).
      rewrite ir. reflexivity.
    + pose (nvt := no_val_transition t1 t1').
      unfold not in nvt.
      pose (f := nvt (conj H3 H)). inversion f.

  (* plus_right *)
  - intros. inversion H1.
    + rewrite <- H4 in *. inversion H0.
    + pose (nvt := no_val_transition t1 t1').
      unfold not in nvt.
      pose (f := nvt (conj H H5)). inversion f.
    + pose (ir := IHOneStepTransitionJudgement t2'0 H6).
      rewrite ir. reflexivity.

  (* isZero *)
  - intros. inversion H0.
    + rewrite <- H2 in *. inversion H.
    + rewrite <- H1 in *. inversion H.
    + pose (ir := IHOneStepTransitionJudgement t'0 H2).
      rewrite ir. reflexivity.

  (* ifThenElse *)
  - intros. inversion H0.
    + rewrite <- H2 in *. inversion H.
    + rewrite <- H2 in *. inversion H.
    + pose (ir := IHOneStepTransitionJudgement t'0 H5).
      rewrite ir. reflexivity.
Qed.

(*
  2.29. Lemma
*)
Lemma progress_helper_Nat {t : Tm} :
  (t :: Nat) -> (t val) -> (exists n : nat, t = num n)
.
Proof.
  intros. inversion H0.
  + refine (ex_intro _ _ _). reflexivity.
  + rewrite <- H1 in *. inversion H.
  + rewrite <- H1 in *. inversion H.
Qed.

Lemma progress_helper_Bool {t : Tm} :
  (t :: Bool) -> (t val) -> (t = true \/ t = false).
Proof.
  intros.
  inversion H0.
  + subst. inversion H.
  + left. trivial.
  + right. trivial.
Qed.

Theorem progress {t : Tm} {A : Ty} :
  (t :: A) -> t val \/ (exists t' : Tm, t |-> t').
Proof.
  intros. induction H.
  + left. apply VJ_num.
  + right. destruct IHTypeJudgement1; destruct IHTypeJudgement2.
    - pose (lhs := progress_helper_Nat H H1).
      pose (rhs := progress_helper_Nat H0 H2).
      inversion lhs. inversion rhs. subst.
      eapply (ex_intro ). eapply OSTJ_sum. trivial.
    - pose (lhs := progress_helper_Nat H H1).
      inversion lhs. subst.
      inversion H2.
      (* all used variables must be in the context before applying ex_intro *)
      eapply ex_intro. eapply OSTJ_plus_right.
      * exact H1.
      * exact H3.
     - pose (rhs := progress_helper_Nat H0 H2).
       inversion rhs. subst.
       inversion H1.
       eapply ex_intro.
       eapply OSTJ_plus_left. exact H3.
     - inversion H1. inversion H2.
       eapply ex_intro. eapply OSTJ_plus_left. exact H3.

  (* isZero *)
  + right. destruct IHTypeJudgement.
    - pose (lem := progress_helper_Nat H H0).
      inversion lem. subst.
      destruct x; eapply ex_intro.
      * eapply OSTJ_isZero_true.
      * eapply OSTJ_isZero_false. apply gt_Sn_O.
    - inversion H0. eapply ex_intro. eapply OSTJ_isZero. exact H1.

  (* true *)
  + left. apply VJ_true.

  (* false *)
  + left. apply VJ_false.

  (* IfThenElse *)
  + destruct IHTypeJudgement1.
    - right. pose (lem := progress_helper_Bool H H2).
      destruct lem; subst.
      * eapply ex_intro. eapply OSTJ_ifThenElse_true.
      * eapply ex_intro. eapply OSTJ_ifThenElse_false.
    - right. inversion H2. eapply ex_intro. eapply OSTJ_ifThenElse. exact H3.
Qed.

Theorem type_preservation {t t' : Tm} :
  (t |-> t') -> (forall A : Ty, (t :: A) -> (t' :: A)).
Proof.
  intros H. induction H; intros.
  (* num *)
  + inversion H0. subst. apply TJ_num.
  (* true *)
  + inversion H. subst. apply TJ_true.
  (* false *)
  + inversion H0. apply TJ_false.
  (* IfThenElse *)
  + inversion H. subst. exact j'.
  + inversion H. subst. exact j''.
  (* Plus *)
  + inversion H0. subst. eapply TJ_plus.
    - apply IHOneStepTransitionJudgement. exact j.
    - exact j'.
  + inversion H1. subst. apply TJ_plus.
    - exact j.
    - apply IHOneStepTransitionJudgement. exact j'.
  (* isZero *)
  + inversion H0. subst. apply TJ_isZero.
    apply IHOneStepTransitionJudgement. exact j.
  (* IfThenElse condition rewrite *)
  + inversion H0. subst. apply TJ_ifThenElse.
    - apply IHOneStepTransitionJudgement. exact j.
    - exact j'.
    - exact j''.
Qed.


From mathcomp Require Import ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import Coq.Logic.Classical.
Require Import Coq.Logic.Decidable. (* Introducing decidable *)

Section Logic_Theories.
  Lemma or_dist_and: forall (A B C:Prop), A \/ (B /\ C) <-> (A \/ B) /\ (A \/ C).
  Proof.
    rewrite /iff.
    split.
    case.
    move => HA.
    split.
    left.
    apply HA.
    left.
    apply HA.
    case.
    move => HB HC.
    split; right.
    apply HB.
    apply HC.
    case.
    move => HAB HAC.
    inversion HAB.
    left.
    apply H.
    inversion HAC.
    left.
    apply H0.
    right.
    split.
    apply H.
    apply H0.
  Qed.

  Lemma and_dist_or: forall (A B C:Prop), A /\ (B \/ C) <-> (A /\ B) \/ (A /\ C).
  Proof.
    rewrite /iff.
    split.
    case => HA.
    case => HB.
    left.
    split; done.
    right.
    split; done.
    case.
    case => HA HB.
    split.
    done.
    left.
    done.
    case => HA HC.
    split.
    done.
    right.
    done.
  Qed.

  Lemma or_imply_to_imply_and:
    forall (A B C:Prop), (A \/ B -> C) -> ((A -> C) /\ (B -> C)).
  Proof.
    move => A B C H.
    split; move => H0; apply H.
    left.
    apply H0.
    right.
    apply H0.
  Qed.

  Lemma or_not_l_iff_3: forall (A B C:Prop), (A -> False) \/ (B -> False) \/ C <-> (A /\ B -> C).
  Proof.
    move => A B C.
    rewrite /iff.
    split => H.
    case.
    move => HA.
    apply or_not_l_iff_2.
    apply classic.
    move: HA.
    apply or_not_l_iff_2.
    apply classic.
    apply H.
    apply or_not_l_iff_2.
    apply classic.
    move => HA.
    apply or_not_l_iff_2.
    apply classic.
    move => HB.
    apply H.
    split.
    apply HA.
    apply HB.
  Qed.

  Lemma imply_and_to_or_imply: forall (A B C:Prop), (A -> B /\ C) -> (A -> B) /\ (A -> C).
  Proof.
    move => A B C H.
    split; apply H.
  Qed.

End Logic_Theories.


From Coq Require Import
  PeanoNat Lia Eqdep_dec Arith.

Section Fin.

  Inductive Fin : nat -> Type :=
  | Fz {n : nat} : Fin (S n)
  | Fs {n : nat} : Fin n -> Fin (S n).

  Fact uip_nat {n : nat} (e : n = n) : e = eq_refl.
  Proof. apply UIP_dec, eq_nat_dec. Qed.

  Lemma fin_ind :
    forall (n : nat) (P : Fin (S n) -> Type),
    P Fz -> (forall (f : Fin n), P (Fs f)) ->
    forall fw : Fin (S n), P fw.
  Proof.
    intros ? ? Hfz Hfs.
    refine (
      fix Fn fw :=
      match fw as fw' in Fin (S np)
        return
          forall (pf : np = n),
            fw = (eq_rect np (fun wp => Fin (S wp)) fw' n pf) ->
            P (eq_rect np (fun wp => Fin (S wp)) fw' n pf)
      with
      | Fz => fun Heq Hf => _
      | Fs _ => fun Heq Hf => _
      end eq_refl eq_refl).
    + subst.
      exact Hfz.
    + subst.
      apply Hfs.
  Qed.

  (*
    Show Proof.
    Print EqdepFacts.internal_eq_rew_r_dep.
  *)

  Fixpoint nat_to_fin (n : nat) : Fin (S n) :=
    match n with
    | 0 => Fz
    | S n' => Fs (nat_to_fin n')
  end.

  Fixpoint fin_to_nat {n : nat} (f : Fin n) : nat :=
    match f with
    | Fz => 0
    | Fs t => S (fin_to_nat t)
    end.

  Lemma nat_to_fin_and_fin_to_nat_inv :
    forall (n : nat), fin_to_nat (nat_to_fin n) = n.
  Proof.
    refine (
      fix Fn n :=
        match n with
        | 0 => eq_refl
        | S n' => _
        end).
      simpl; rewrite Fn.
      exact eq_refl.
  Defined.

  Lemma fin_inv_0 (f : Fin 0) : False.
  Proof.
    refine (match f with end).
  Defined.

  Lemma fin_inv_S {n : nat} (f : Fin (S n)) :
    (f = Fz) + {t | f = Fs t}.
  Proof.
    refine (match f with
      | Fz => _
      | Fs s => _
      end);
      [left | right; exists s];
      exact eq_refl.
  Defined.

  Lemma cast_fin : forall {n : nat} (f : Fin (S n)),
    Fin (S (fin_to_nat f)).
  Proof.
    refine (fix Fn n :=
      match n as n' return n = n' -> _ with
      | 0 => fun Hn f => _
      | S n' => fun Hn f => _
      end eq_refl);
    subst.
    +
      pose proof (fin_inv_S f) as [Ha | (t & Hb)].
      subst; simpl.
      exact Fz.
      pose proof (fin_inv_0 t) as Hf;
      refine (match Hf with end).
    +
      pose proof (fin_inv_S f) as [Ha | (t & Hb)].
      subst; simpl.
      exact Fz.
      pose proof (Fn _ t) as Ft.
      subst; simpl.
      exact (Fs Ft).
  Defined.

  Lemma fin_to_nat_and_nat_to_fin_inv :
    forall (n : nat) (f : Fin (S n)),
      nat_to_fin (fin_to_nat f) = @cast_fin _ f.
  Proof.
    refine (fix Fn n :=
      match n as n' return n = n' -> _ with
      | 0 => fun Hn f => _
      | S n' => fun Hn f => _
      end eq_refl);
    subst.
    +
      pose proof (fin_inv_S f) as [Ha | (t & Hb)].
      subst; simpl.
      exact eq_refl.
      pose proof (fin_inv_0 t) as Hf;
      refine (match Hf with end).
    +
      pose proof (fin_inv_S f) as [Ha | (t & Hb)].
      subst; simpl.
      exact eq_refl.
      pose proof (Fn _ t) as Ft.
      subst; simpl.
      rewrite Ft.
      reflexivity.
  Defined.

  Lemma FS_inj :
    forall {n} (x y : Fin n), Fs x = Fs y ->  x = y.
  Proof.
    intros ? ? ? Heq.
    refine
      match
        Heq in _ = a
        return
        match
          a as a' in Fin n
          return
            match n with
            | 0 => Prop
            | S n' => Fin n' -> Prop
            end
        with
        | Fz => fun _ => True
        | Fs y => fun x' => x' = y
        end x
    with
    | eq_refl => eq_refl
    end.
  Defined.

  Lemma fin_to_nat_lt :
    forall {n : nat} (f : Fin n),
    fin_to_nat f < n.
  Proof.
    induction n.
    + intros f.
      pose proof (fin_inv_0 f) as Hf;
      refine (match Hf with end).
    + intros f.
      pose proof (fin_inv_S f) as [H | (t & H)].
      subst; simpl.
      apply Nat.lt_0_succ.
      subst; simpl.
      apply Lt.lt_n_S,
      IHn.
  Defined.

  (** of_nat p n returns the p{^ th} element of
      fin n if p < n, othewise a proof that n <= p else *)
  Definition of_nat : forall (p n : nat),
    (Fin n) + {m | p = n + m}.
  Proof.
    intros p n.
    revert n p.
    refine (fix Fn n :=
      match n as n' return n' = n ->
        forall pt, (Fin n') + {m | pt = n' + m}  with
      | 0 => fun He p => inr (exist _ p eq_refl)
      | S n' => fun He p =>
        match p as p' return p = p' -> _ with
        | 0 => fun Hp => inl Fz
        | S p' => fun Hp => match Fn n' p' with
          | inl t => inl (Fs t)
          | inr (exist _ m e) => inr (exist _ m _)
          end
        end eq_refl
      end eq_refl).
      rewrite e.
      reflexivity.
  Defined.

  Definition of_nat_lt : forall {p n : nat}, p < n -> Fin n.
  Proof.
    intros ? ?.
    revert n p.
    refine
      (fix Fn n :=
        match n as n'
          return n = n' ->
            forall p, p < n' -> Fin n'
        with
        | 0 => fun Hn p Hp => False_rect _ (PeanoNat.Nat.nlt_0_r p Hp)
        | S n' => fun Hn p =>
            match p as p'
              return p = p' -> p' < S n' -> Fin (S n')
            with
            | 0 => fun Hp Hsp => @Fz _
            | S p' => fun Hp Hsp =>
              @Fs _ (Fn n' p' (proj2 (Nat.succ_lt_mono _ _ ) Hsp))
            end eq_refl
        end eq_refl).
  Defined.

  Fact le_inv n m (H : n <= m) :
      (exists e : m = n, eq_rect _ _ H _ e = le_n n)
    \/ (exists m' (e : m = S m') (H' : n <= m'),
      eq_rect _ _ H _ e = le_S _ _ H').
  Proof.
    revert m H.
    intros ? [ | m H ].
    + left. now exists eq_refl.
    + right. now exists m, eq_refl, H.
  Qed.

  Lemma le_unique : forall (m n : nat)
    (p q : m <= n), p = q.
  Proof.
    intros ?.
    refine(fix Fn n p {struct p} :=
      match p as p' in (_ <= np)
        return n = np -> forall (q : m <= np),
          p' = q
      with
      | le_n _ => fun Heq q =>
        match q as q' in (_ <= nq)
          return forall (pf : nq = m),
            le_n m = (eq_rect _ _ q' _ pf)
        with
        | le_n _ => fun pf => _
        | le_S _ nt Hnt => fun pf => _
        end  eq_refl
      | le_S _ nt Hnt => fun Heq q =>
        match q as q' in (_ <= S np)
          return
            forall (pf : np = nt),
              le_S _ nt Hnt =
              eq_rect np (fun w => m <= S w) q' nt pf
        with
        | le_n _ => _
        | le_S _ nw Hnw => fun pf => _
        end eq_refl
      end eq_refl).
    + rewrite (uip_nat pf).
      exact eq_refl.
    + abstract nia.
    + clear Fn.
      destruct m.
      ++ exact idProp.
      ++ abstract nia.
    + subst; simpl.
      f_equal.
      apply Fn.
  Qed.

  Lemma le_pair_induction:
    forall (n : nat)
    (P : forall m : nat, n <= m -> n <= m -> Prop),
    P n (le_n n) (le_n n) ->
    (forall (m : nat) (Ha Hb : n <= m), P m Ha Hb ->
      P (S m) (le_S n m Ha) (le_S n m Hb)) ->
    forall (mt : nat) (Hna Hnb : n <= mt), P mt Hna Hnb.
  Proof.
    intros ? ? Pa Pb.
    refine(
      fix Fn mt Hna {struct Hna} :=
      match Hna as Hna' in (_ <= mtp)
        return
          mt = mtp ->
          forall Hnb, P mtp Hna' Hnb
      with
      | le_n _ => fun _ Hnb =>
        match Hnb as Hnb' in (_ <= nt)
          return
            forall (pf : nt = n),
            P n (le_n n) (eq_rect nt _ Hnb' n pf)
        with
        | le_n _ =>  fun pf => _
        | le_S _ nt Hnt => fun pf => _
        end eq_refl
      | le_S _ nt Hnt => fun Heq Hnb =>
        match Hnb as Hnb' in (_ <= S np)
          return
            forall (pf : np = nt),
            P (S nt) (le_S n nt Hnt)
              (eq_rect np (fun w => n <= S w) Hnb' nt pf)
        with
        | le_n _ => _
        | le_S _ nw Hnw => fun pf => _
        end eq_refl
      end eq_refl).
    + rewrite (uip_nat pf).
      exact Pa.
    + abstract nia.
    + clear Fn.
      destruct n.
      ++ exact idProp.
      ++ abstract nia.
    + subst.
      apply Pb, Fn.
  Qed.

  Lemma le_unique_using_ind :
    forall {m n : nat}
    (p q : m <= n), p = q.
  Proof.
    intros ? ? ? ?.
    apply (le_pair_induction m
      (fun
        (n : nat)
        (a : m <= n)
        (b : m <= n) => a = b)).
    + exact eq_refl.
    + intros ? ? ? He;
      subst; reflexivity.
  Qed.