(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*i $Id: Zorder.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)

Require Import BinPos.
Require Import BinInt.
Require Import Arith_base.
Require Import Decidable.
Require Import Zcompare.

Open Local Scope Z_scope.

Implicit Types x y z : Z.

(*********************************************************)
(** Properties of the order relations on binary integers *)

(** * Trichotomy *)

Theorem Ztrichotomy_inf : forall n m:Z, {n < m} + {n = m} + {n > m}.
Proof.
  unfold Zgt, Zlt in |- *; intros m n; assert (H := refl_equal (m ?= n)).
  set (x := m ?= n) in H at 2 |- *.
  destruct x;
    [ left; right; rewrite Zcompare_Eq_eq with (1 := H) | left; left | right ];
    reflexivity.
Qed.

Theorem Ztrichotomy : forall n m:Z, n < m \/ n = m \/ n > m.
Proof.
  intros m n; destruct (Ztrichotomy_inf m n) as [[Hlt| Heq]| Hgt];
    [ left | right; left | right; right ]; assumption.
Qed.

(**********************************************************************)
(** * Decidability of equality and order on Z *)

Theorem dec_eq : forall n m:Z, decidable (n = m).
Proof.
  intros x y; unfold decidable in |- *; elim (Zcompare_Eq_iff_eq x y);
    intros H1 H2; elim (Dcompare (x ?= y));
      [ tauto
	| intros H3; right; unfold not in |- *; intros H4; elim H3; rewrite (H2 H4);
	  intros H5; discriminate H5 ].
Qed.

Theorem dec_Zne : forall n m:Z, decidable (Zne n m).
Proof.
  intros x y; unfold decidable, Zne in |- *; elim (Zcompare_Eq_iff_eq x y).
  intros H1 H2; elim (Dcompare (x ?= y));
    [ right; rewrite H1; auto
      | left; unfold not in |- *; intro; absurd ((x ?= y) = Eq);
	[ elim H; intros HR; rewrite HR; discriminate | auto ] ].
Qed.

Theorem dec_Zle : forall n m:Z, decidable (n <= m).
Proof.
  intros x y; unfold decidable, Zle in |- *; elim (x ?= y);
    [ left; discriminate
      | left; discriminate
      | right; unfold not in |- *; intros H; apply H; trivial with arith ].
Qed.

Theorem dec_Zgt : forall n m:Z, decidable (n > m).
Proof.
  intros x y; unfold decidable, Zgt in |- *; elim (x ?= y);
    [ right; discriminate | right; discriminate | auto with arith ].
Qed.

Theorem dec_Zge : forall n m:Z, decidable (n >= m).
Proof.
  intros x y; unfold decidable, Zge in |- *; elim (x ?= y);
    [ left; discriminate
      | right; unfold not in |- *; intros H; apply H; trivial with arith
      | left; discriminate ].
Qed.

Theorem dec_Zlt : forall n m:Z, decidable (n < m).
Proof.
  intros x y; unfold decidable, Zlt in |- *; elim (x ?= y);
    [ right; discriminate | auto with arith | right; discriminate ].
Qed.

Theorem not_Zeq : forall n m:Z, n <> m -> n < m \/ m < n.
Proof.
  intros x y; elim (Dcompare (x ?= y));
    [ intros H1 H2; absurd (x = y);
      [ assumption | elim (Zcompare_Eq_iff_eq x y); auto with arith ]
      | unfold Zlt in |- *; intros H; elim H; intros H1;
	[ auto with arith
	  | right; elim (Zcompare_Gt_Lt_antisym x y); auto with arith ] ].
Qed.

(** * Relating strict and large orders *)

Lemma Zgt_lt : forall n m:Z, n > m -> m < n.
Proof.
  unfold Zgt, Zlt in |- *; intros m n H; elim (Zcompare_Gt_Lt_antisym m n);
    auto with arith.
Qed.

Lemma Zlt_gt : forall n m:Z, n < m -> m > n.
Proof.
  unfold Zgt, Zlt in |- *; intros m n H; elim (Zcompare_Gt_Lt_antisym n m);
    auto with arith.
Qed.

Lemma Zge_le : forall n m:Z, n >= m -> m <= n.
Proof.
  intros m n; change (~ m < n -> ~ n > m) in |- *; unfold not in |- *;
    intros H1 H2; apply H1; apply Zgt_lt; assumption.
Qed.

Lemma Zle_ge : forall n m:Z, n <= m -> m >= n.
Proof.
  intros m n; change (~ m > n -> ~ n < m) in |- *; unfold not in |- *;
    intros H1 H2; apply H1; apply Zlt_gt; assumption.
Qed.

Lemma Zle_not_gt : forall n m:Z, n <= m -> ~ n > m.
Proof.
  trivial.
Qed.

Lemma Zgt_not_le : forall n m:Z, n > m -> ~ n <= m.
Proof.
  intros n m H1 H2; apply H2; assumption.
Qed.

Lemma Zle_not_lt : forall n m:Z, n <= m -> ~ m < n.
Proof.
  intros n m H1 H2.
  assert (H3 := Zlt_gt _ _ H2).
  apply Zle_not_gt with n m; assumption.
Qed.

Lemma Zlt_not_le : forall n m:Z, n < m -> ~ m <= n.
Proof.
  intros n m H1 H2.
  apply Zle_not_lt with m n; assumption.
Qed.

Lemma Znot_ge_lt : forall n m:Z, ~ n >= m -> n < m.
Proof.
  unfold Zge, Zlt in |- *; intros x y H; apply dec_not_not;
    [ exact (dec_Zlt x y) | assumption ].
Qed.

Lemma Znot_lt_ge : forall n m:Z, ~ n < m -> n >= m.
Proof.
  unfold Zlt, Zge in |- *; auto with arith.
Qed.

Lemma Znot_gt_le : forall n m:Z, ~ n > m -> n <= m.
Proof.
  trivial.
Qed.

Lemma Znot_le_gt : forall n m:Z, ~ n <= m -> n > m.
Proof.
  unfold Zle, Zgt in |- *; intros x y H; apply dec_not_not;
    [ exact (dec_Zgt x y) | assumption ].
Qed.

Lemma Zge_iff_le : forall n m:Z, n >= m <-> m <= n.
Proof.
  intros x y; intros. split. intro. apply Zge_le. assumption.
  intro. apply Zle_ge. assumption.
Qed.

Lemma Zgt_iff_lt : forall n m:Z, n > m <-> m < n.
Proof.
  intros x y. split. intro. apply Zgt_lt. assumption.
  intro. apply Zlt_gt. assumption.
Qed.

(** * Equivalence and order properties *)

(** Reflexivity *)

Lemma Zle_refl : forall n:Z, n <= n.
Proof.
  intros n; unfold Zle in |- *; rewrite (Zcompare_refl n); discriminate.
Qed.

Lemma Zeq_le : forall n m:Z, n = m -> n <= m.
Proof.
  intros; rewrite H; apply Zle_refl.
Qed.

Hint Resolve Zle_refl: zarith.

(** Antisymmetry *)

Lemma Zle_antisym : forall n m:Z, n <= m -> m <= n -> n = m.
Proof.
  intros n m H1 H2; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]].
  absurd (m > n); [ apply Zle_not_gt | apply Zlt_gt ]; assumption.
  assumption.
  absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption.
Qed.

(** Asymmetry *)

Lemma Zgt_asym : forall n m:Z, n > m -> ~ m > n.
Proof.
  unfold Zgt in |- *; intros n m H; elim (Zcompare_Gt_Lt_antisym n m);
    intros H1 H2; rewrite H1; [ discriminate | assumption ].
Qed.

Lemma Zlt_asym : forall n m:Z, n < m -> ~ m < n.
Proof.
  intros n m H H1; assert (H2 : m > n). apply Zlt_gt; assumption.
  assert (H3 : n > m). apply Zlt_gt; assumption.
  apply Zgt_asym with m n; assumption.
Qed.

(** Irreflexivity *)

Lemma Zgt_irrefl : forall n:Z, ~ n > n.
Proof.
  intros n H; apply (Zgt_asym n n H H).
Qed.

Lemma Zlt_irrefl : forall n:Z, ~ n < n.
Proof.
  intros n H; apply (Zlt_asym n n H H).
Qed.

Lemma Zlt_not_eq : forall n m:Z, n < m -> n <> m.
Proof.
  unfold not in |- *; intros x y H H0.
  rewrite H0 in H.
  apply (Zlt_irrefl _ H).
Qed.

(** Large = strict or equal *)

Lemma Zlt_le_weak : forall n m:Z, n < m -> n <= m.
Proof.
  intros n m Hlt; apply Znot_gt_le; apply Zgt_asym; apply Zlt_gt; assumption.
Qed.

Lemma Zle_lt_or_eq : forall n m:Z, n <= m -> n < m \/ n = m.
Proof.
  intros n m H; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]];
    [ left; assumption
      | right; assumption
      | absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption ].
Qed.

Lemma Zle_lt_or_eq_iff : forall n m, n <= m <-> n < m \/ n = m.
Proof.
  unfold Zle, Zlt. intros.
  generalize (Zcompare_Eq_iff_eq n m).
  destruct (n ?= m); intuition; discriminate.
Qed.

(** Dichotomy *)

Lemma Zle_or_lt : forall n m:Z, n <= m \/ m < n.
Proof.
  intros n m; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]];
    [ left; apply Znot_gt_le; intro Hgt; assert (Hgt' := Zlt_gt _ _ Hlt);
      apply Zgt_asym with m n; assumption
      | left; rewrite Heq; apply Zle_refl
      | right; apply Zgt_lt; assumption ].
Qed.

(** Transitivity of strict orders *)

Lemma Zgt_trans : forall n m p:Z, n > m -> m > p -> n > p.
Proof.
  exact Zcompare_Gt_trans.
Qed.

Lemma Zlt_trans : forall n m p:Z, n < m -> m < p -> n < p.
Proof.
  exact Zcompare_Lt_trans.
Qed.

(** Mixed transitivity *)

Lemma Zle_gt_trans : forall n m p:Z, m <= n -> m > p -> n > p.
Proof.
  intros n m p H1 H2; destruct (Zle_lt_or_eq m n H1) as [Hlt| Heq];
    [ apply Zgt_trans with m; [ apply Zlt_gt; assumption | assumption ]
      | rewrite <- Heq; assumption ].
Qed.

Lemma Zgt_le_trans : forall n m p:Z, n > m -> p <= m -> n > p.
Proof.
  intros n m p H1 H2; destruct (Zle_lt_or_eq p m H2) as [Hlt| Heq];
    [ apply Zgt_trans with m; [ assumption | apply Zlt_gt; assumption ]
      | rewrite Heq; assumption ].
Qed.

Lemma Zlt_le_trans : forall n m p:Z, n < m -> m <= p -> n < p.
  intros n m p H1 H2; apply Zgt_lt; apply Zle_gt_trans with (m := m);
    [ assumption | apply Zlt_gt; assumption ].
Qed.

Lemma Zle_lt_trans : forall n m p:Z, n <= m -> m < p -> n < p.
Proof.
  intros n m p H1 H2; apply Zgt_lt; apply Zgt_le_trans with (m := m);
    [ apply Zlt_gt; assumption | assumption ].
Qed.

(** Transitivity of large orders *)

Lemma Zle_trans : forall n m p:Z, n <= m -> m <= p -> n <= p.
Proof.
  intros n m p H1 H2; apply Znot_gt_le.
  intro Hgt; apply Zle_not_gt with n m. assumption.
  exact (Zgt_le_trans n p m Hgt H2).
Qed.

Lemma Zge_trans : forall n m p:Z, n >= m -> m >= p -> n >= p.
Proof.
  intros n m p H1 H2.
  apply Zle_ge.
  apply Zle_trans with m; apply Zge_le; trivial.
Qed.

Hint Resolve Zle_trans: zarith.

(** * Compatibility of order and operations on Z *)

(** ** Successor *)

(** Compatibility of successor wrt to order *)

Lemma Zsucc_le_compat : forall n m:Z, m <= n -> Zsucc m <= Zsucc n.
Proof.
  unfold Zle, not in |- *; intros m n H1 H2; apply H1;
    rewrite <- (Zcompare_plus_compat n m 1); do 2 rewrite (Zplus_comm 1);
      exact H2.
Qed.

Lemma Zsucc_gt_compat : forall n m:Z, m > n -> Zsucc m > Zsucc n.
Proof.
  unfold Zgt in |- *; intros n m H; rewrite Zcompare_succ_compat;
    auto with arith.
Qed.

Lemma Zsucc_lt_compat : forall n m:Z, n < m -> Zsucc n < Zsucc m.
Proof.
  intros n m H; apply Zgt_lt; apply Zsucc_gt_compat; apply Zlt_gt; assumption.
Qed.

Hint Resolve Zsucc_le_compat: zarith.

(** Simplification of successor wrt to order *)

Lemma Zsucc_gt_reg : forall n m:Z, Zsucc m > Zsucc n -> m > n.
Proof.
  unfold Zsucc, Zgt in |- *; intros n p;
    do 2 rewrite (fun m:Z => Zplus_comm m 1);
      rewrite (Zcompare_plus_compat p n 1); trivial with arith.
Qed.

Lemma Zsucc_le_reg : forall n m:Z, Zsucc m <= Zsucc n -> m <= n.
Proof.
  unfold Zle, not in |- *; intros m n H1 H2; apply H1; unfold Zsucc in |- *;
    do 2 rewrite <- (Zplus_comm 1); rewrite (Zcompare_plus_compat n m 1);
      assumption.
Qed.

Lemma Zsucc_lt_reg : forall n m:Z, Zsucc n < Zsucc m -> n < m.
Proof.
  intros n m H; apply Zgt_lt; apply Zsucc_gt_reg; apply Zlt_gt; assumption.
Qed.

(** Special base instances of order *)

Lemma Zgt_succ : forall n:Z, Zsucc n > n.
Proof.
  exact Zcompare_succ_Gt.
Qed.

Lemma Znot_le_succ : forall n:Z, ~ Zsucc n <= n.
Proof.
  intros n; apply Zgt_not_le; apply Zgt_succ.
Qed.

Lemma Zlt_succ : forall n:Z, n < Zsucc n.
Proof.
  intro n; apply Zgt_lt; apply Zgt_succ.
Qed.

Lemma Zlt_pred : forall n:Z, Zpred n < n.
Proof.
  intros n; apply Zsucc_lt_reg; rewrite <- Zsucc_pred; apply Zlt_succ.
Qed.

(** Relating strict and large order using successor or predecessor *)

Lemma Zgt_le_succ : forall n m:Z, m > n -> Zsucc n <= m.
Proof.
  unfold Zgt, Zle in |- *; intros n p H; elim (Zcompare_Gt_not_Lt p n);
    intros H1 H2; unfold not in |- *; intros H3; unfold not in H1;
      apply H1;
	[ assumption
	  | elim (Zcompare_Gt_Lt_antisym (n + 1) p); intros H4 H5; apply H4; exact H3 ].
Qed.

Lemma Zle_gt_succ : forall n m:Z, n <= m -> Zsucc m > n.
Proof.
  intros n p H; apply Zgt_le_trans with p.
  apply Zgt_succ.
  assumption.
Qed.

Lemma Zle_lt_succ : forall n m:Z, n <= m -> n < Zsucc m.
Proof.
  intros n m H; apply Zgt_lt; apply Zle_gt_succ; assumption.
Qed.

Lemma Zlt_le_succ : forall n m:Z, n < m -> Zsucc n <= m.
Proof.
  intros n p H; apply Zgt_le_succ; apply Zlt_gt; assumption.
Qed.

Lemma Zgt_succ_le : forall n m:Z, Zsucc m > n -> n <= m.
Proof.
  intros n p H; apply Zsucc_le_reg; apply Zgt_le_succ; assumption.
Qed.

Lemma Zlt_succ_le : forall n m:Z, n < Zsucc m -> n <= m.
Proof.
  intros n m H; apply Zgt_succ_le; apply Zlt_gt; assumption.
Qed.

Lemma Zle_succ_gt : forall n m:Z, Zsucc n <= m -> m > n.
Proof.
  intros n m H; apply Zle_gt_trans with (m := Zsucc n);
    [ assumption | apply Zgt_succ ].
Qed.

Lemma Zlt_succ_r : forall n m, n < Zsucc m <-> n <= m.
Proof.
  split; [apply Zlt_succ_le | apply Zle_lt_succ].
Qed.

(** Weakening order *)

Lemma Zle_succ : forall n:Z, n <= Zsucc n.
Proof.
  intros n; apply Zgt_succ_le; apply Zgt_trans with (m := Zsucc n);
    apply Zgt_succ.
Qed.

Hint Resolve Zle_succ: zarith.

Lemma Zle_pred : forall n:Z, Zpred n <= n.
Proof.
  intros n; pattern n at 2 in |- *; rewrite Zsucc_pred; apply Zle_succ.
Qed.

Lemma Zlt_lt_succ : forall n m:Z, n < m -> n < Zsucc m.
  intros n m H; apply Zgt_lt; apply Zgt_trans with (m := m);
    [ apply Zgt_succ | apply Zlt_gt; assumption ].
Qed.

Lemma Zle_le_succ : forall n m:Z, n <= m -> n <= Zsucc m.
Proof.
  intros x y H.
  apply Zle_trans with y; trivial with zarith.
Qed.

Lemma Zle_succ_le : forall n m:Z, Zsucc n <= m -> n <= m.
Proof.
  intros n m H; apply Zle_trans with (m := Zsucc n);
    [ apply Zle_succ | assumption ].
Qed.

Hint Resolve Zle_le_succ: zarith.

(** Relating order wrt successor and order wrt predecessor *)

Lemma Zgt_succ_pred : forall n m:Z, m > Zsucc n -> Zpred m > n.
Proof.
  unfold Zgt, Zsucc, Zpred in |- *; intros n p H;
    rewrite <- (fun x y => Zcompare_plus_compat x y 1);
      rewrite (Zplus_comm p); rewrite Zplus_assoc;
	rewrite (fun x => Zplus_comm x n); simpl in |- *;
	  assumption.
Qed.

Lemma Zlt_succ_pred : forall n m:Z, Zsucc n < m -> n < Zpred m.
Proof.
  intros n p H; apply Zsucc_lt_reg; rewrite <- Zsucc_pred; assumption.
Qed.

(** Relating strict order and large order on positive *)

Lemma Zlt_0_le_0_pred : forall n:Z, 0 < n -> 0 <= Zpred n.
Proof.
  intros x H.
  rewrite (Zsucc_pred x) in H.
  apply Zgt_succ_le.
  apply Zlt_gt.
  assumption.
Qed.

Lemma Zgt_0_le_0_pred : forall n:Z, n > 0 -> 0 <= Zpred n.
Proof.
  intros; apply Zlt_0_le_0_pred; apply Zgt_lt. assumption.
Qed.

(** Special cases of ordered integers *)

Lemma Zlt_0_1 : 0 < 1.
Proof.
  change (0 < Zsucc 0) in |- *. apply Zlt_succ.
Qed.

Lemma Zle_0_1 : 0 <= 1.
Proof.
  change (0 <= Zsucc 0) in |- *. apply Zle_succ.
Qed.

Lemma Zle_neg_pos : forall p q:positive, Zneg p <= Zpos q.
Proof.
  intros p; red in |- *; simpl in |- *; red in |- *; intros H; discriminate.
Qed.

Lemma Zgt_pos_0 : forall p:positive, Zpos p > 0.
Proof.
  unfold Zgt in |- *; trivial.
Qed.

(* weaker but useful (in [Zpower] for instance) *)
Lemma Zle_0_pos : forall p:positive, 0 <= Zpos p.
Proof.
  intro; unfold Zle in |- *; discriminate.
Qed.

Lemma Zlt_neg_0 : forall p:positive, Zneg p < 0.
Proof.
  unfold Zlt in |- *; trivial.
Qed.

Lemma Zle_0_nat : forall n:nat, 0 <= Z_of_nat n.
Proof.
  simple induction n; simpl in |- *; intros;
    [ apply Zle_refl | unfold Zle in |- *; simpl in |- *; discriminate ].
Qed.

Hint Immediate Zeq_le: zarith.

(** Transitivity using successor *)

Lemma Zgt_trans_succ : forall n m p:Z, Zsucc n > m -> m > p -> n > p.
Proof.
  intros n m p H1 H2; apply Zle_gt_trans with (m := m);
    [ apply Zgt_succ_le; assumption | assumption ].
Qed.

(** Derived lemma *)

Lemma Zgt_succ_gt_or_eq : forall n m:Z, Zsucc n > m -> n > m \/ m = n.
Proof.
  intros n m H.
  assert (Hle : m <= n).
  apply Zgt_succ_le; assumption.
  destruct (Zle_lt_or_eq _ _ Hle) as [Hlt| Heq].
  left; apply Zlt_gt; assumption.
  right; assumption.
Qed.

(** ** Addition *)
(** Compatibility of addition wrt to order *)

Lemma Zplus_gt_compat_l : forall n m p:Z, n > m -> p + n > p + m.
Proof.
  unfold Zgt in |- *; intros n m p H; rewrite (Zcompare_plus_compat n m p);
    assumption.
Qed.

Lemma Zplus_gt_compat_r : forall n m p:Z, n > m -> n + p > m + p.
Proof.
  intros n m p H; rewrite (Zplus_comm n p); rewrite (Zplus_comm m p);
    apply Zplus_gt_compat_l; trivial.
Qed.

Lemma Zplus_le_compat_l : forall n m p:Z, n <= m -> p + n <= p + m.
Proof.
  intros n m p; unfold Zle, not in |- *; intros H1 H2; apply H1;
    rewrite <- (Zcompare_plus_compat n m p); assumption.
Qed.

Lemma Zplus_le_compat_r : forall n m p:Z, n <= m -> n + p <= m + p.
Proof.
  intros a b c; do 2 rewrite (fun n:Z => Zplus_comm n c);
    exact (Zplus_le_compat_l a b c).
Qed.

Lemma Zplus_lt_compat_l : forall n m p:Z, n < m -> p + n < p + m.
Proof.
  unfold Zlt in |- *; intros n m p; rewrite Zcompare_plus_compat;
    trivial with arith.
Qed.

Lemma Zplus_lt_compat_r : forall n m p:Z, n < m -> n + p < m + p.
Proof.
  intros n m p H; rewrite (Zplus_comm n p); rewrite (Zplus_comm m p);
    apply Zplus_lt_compat_l; trivial.
Qed.

Lemma Zplus_lt_le_compat : forall n m p q:Z, n < m -> p <= q -> n + p < m + q.
Proof.
  intros a b c d H0 H1.
  apply Zlt_le_trans with (b + c).
  apply Zplus_lt_compat_r; trivial.
  apply Zplus_le_compat_l; trivial.
Qed.

Lemma Zplus_le_lt_compat : forall n m p q:Z, n <= m -> p < q -> n + p < m + q.
Proof.
  intros a b c d H0 H1.
  apply Zle_lt_trans with (b + c).
  apply Zplus_le_compat_r; trivial.
  apply Zplus_lt_compat_l; trivial.
Qed.

Lemma Zplus_le_compat : forall n m p q:Z, n <= m -> p <= q -> n + p <= m + q.
Proof.
  intros n m p q; intros H1 H2; apply Zle_trans with (m := n + q);
    [ apply Zplus_le_compat_l; assumption
      | apply Zplus_le_compat_r; assumption ].
Qed.

Lemma Zplus_lt_compat : forall n m p q:Z, n < m -> p < q -> n + p < m + q.
  intros; apply Zplus_le_lt_compat. apply Zlt_le_weak; assumption. assumption.
Qed.

(** Compatibility of addition wrt to being positive *)

Lemma Zplus_le_0_compat : forall n m:Z, 0 <= n -> 0 <= m -> 0 <= n + m.
Proof.
  intros x y H1 H2; rewrite <- (Zplus_0_l 0); apply Zplus_le_compat; assumption.
Qed.

(** Simplification of addition wrt to order *)

Lemma Zplus_gt_reg_l : forall n m p:Z, p + n > p + m -> n > m.
Proof.
  unfold Zgt in |- *; intros n m p H; rewrite <- (Zcompare_plus_compat n m p);
    assumption.
Qed.

Lemma Zplus_gt_reg_r : forall n m p:Z, n + p > m + p -> n > m.
Proof.
  intros n m p H; apply Zplus_gt_reg_l with p.
  rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
Qed.

Lemma Zplus_le_reg_l : forall n m p:Z, p + n <= p + m -> n <= m.
Proof.
  intros n m p; unfold Zle, not in |- *; intros H1 H2; apply H1;
    rewrite (Zcompare_plus_compat n m p); assumption.
Qed.

Lemma Zplus_le_reg_r : forall n m p:Z, n + p <= m + p -> n <= m.
Proof.
  intros n m p H; apply Zplus_le_reg_l with p.
  rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
Qed.

Lemma Zplus_lt_reg_l : forall n m p:Z, p + n < p + m -> n < m.
Proof.
  unfold Zlt in |- *; intros n m p; rewrite Zcompare_plus_compat;
    trivial with arith.
Qed.

Lemma Zplus_lt_reg_r : forall n m p:Z, n + p < m + p -> n < m.
Proof.
  intros n m p H; apply Zplus_lt_reg_l with p.
  rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
Qed.

(** ** Multiplication *)
(** Compatibility of multiplication by a positive wrt to order *)

Lemma Zmult_le_compat_r : forall n m p:Z, n <= m -> 0 <= p -> n * p <= m * p.
Proof.
  intros a b c H H0; destruct c.
  do 2 rewrite Zmult_0_r; assumption.
  rewrite (Zmult_comm a); rewrite (Zmult_comm b).
  unfold Zle in |- *; rewrite Zcompare_mult_compat; assumption.
  unfold Zle in H0; contradiction H0; reflexivity.
Qed.

Lemma Zmult_le_compat_l : forall n m p:Z, n <= m -> 0 <= p -> p * n <= p * m.
Proof.
  intros a b c H1 H2; rewrite (Zmult_comm c a); rewrite (Zmult_comm c b).
  apply Zmult_le_compat_r; trivial.
Qed.

Lemma Zmult_lt_compat_r : forall n m p:Z, 0 < p -> n < m -> n * p < m * p.
Proof.
  intros x y z H H0; destruct z.
  contradiction (Zlt_irrefl 0).
  rewrite (Zmult_comm x); rewrite (Zmult_comm y).
  unfold Zlt in |- *; rewrite Zcompare_mult_compat; assumption.
  discriminate H.
Qed.

Lemma Zmult_gt_compat_r : forall n m p:Z, p > 0 -> n > m -> n * p > m * p.
Proof.
  intros x y z; intros; apply Zlt_gt; apply Zmult_lt_compat_r; apply Zgt_lt;
    assumption.
Qed.

Lemma Zmult_gt_0_lt_compat_r :
  forall n m p:Z, p > 0 -> n < m -> n * p < m * p.
Proof.
  intros x y z; intros; apply Zmult_lt_compat_r;
    [ apply Zgt_lt; assumption | assumption ].
Qed.

Lemma Zmult_gt_0_le_compat_r :
  forall n m p:Z, p > 0 -> n <= m -> n * p <= m * p.
Proof.
  intros x y z Hz Hxy.
  elim (Zle_lt_or_eq x y Hxy).
  intros; apply Zlt_le_weak.
  apply Zmult_gt_0_lt_compat_r; trivial.
  intros; apply Zeq_le.
  rewrite H; trivial.
Qed.

Lemma Zmult_lt_0_le_compat_r :
  forall n m p:Z, 0 < p -> n <= m -> n * p <= m * p.
Proof.
  intros x y z; intros; apply Zmult_gt_0_le_compat_r; try apply Zlt_gt;
    assumption.
Qed.

Lemma Zmult_gt_0_lt_compat_l :
  forall n m p:Z, p > 0 -> n < m -> p * n < p * m.
Proof.
  intros x y z; intros.
  rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
    apply Zmult_gt_0_lt_compat_r; assumption.
Qed.

Lemma Zmult_lt_compat_l : forall n m p:Z, 0 < p -> n < m -> p * n < p * m.
Proof.
  intros x y z; intros.
  rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
    apply Zmult_gt_0_lt_compat_r; try apply Zlt_gt; assumption.
Qed.

Lemma Zmult_gt_compat_l : forall n m p:Z, p > 0 -> n > m -> p * n > p * m.
Proof.
  intros x y z; intros; rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
    apply Zmult_gt_compat_r; assumption.
Qed.

Lemma Zmult_ge_compat_r : forall n m p:Z, n >= m -> p >= 0 -> n * p >= m * p.
Proof.
  intros a b c H1 H2; apply Zle_ge.
  apply Zmult_le_compat_r; apply Zge_le; trivial.
Qed.

Lemma Zmult_ge_compat_l : forall n m p:Z, n >= m -> p >= 0 -> p * n >= p * m.
Proof.
  intros a b c H1 H2; apply Zle_ge.
  apply Zmult_le_compat_l; apply Zge_le; trivial.
Qed.

Lemma Zmult_ge_compat :
  forall n m p q:Z, n >= p -> m >= q -> p >= 0 -> q >= 0 -> n * m >= p * q.
Proof.
  intros a b c d H0 H1 H2 H3.
  apply Zge_trans with (a * d).
  apply Zmult_ge_compat_l; trivial.
  apply Zge_trans with c; trivial.
  apply Zmult_ge_compat_r; trivial.
Qed.

Lemma Zmult_le_compat :
  forall n m p q:Z, n <= p -> m <= q -> 0 <= n -> 0 <= m -> n * m <= p * q.
Proof.
  intros a b c d H0 H1 H2 H3.
  apply Zle_trans with (c * b).
  apply Zmult_le_compat_r; assumption.
  apply Zmult_le_compat_l.
  assumption.
  apply Zle_trans with a; assumption.
Qed.

(** Simplification of multiplication by a positive wrt to being positive *)

Lemma Zmult_gt_0_lt_reg_r : forall n m p:Z, p > 0 -> n * p < m * p -> n < m.
Proof.
  intros x y z; intros; destruct z.
  contradiction (Zgt_irrefl 0).
  rewrite (Zmult_comm x) in H0; rewrite (Zmult_comm y) in H0.
  unfold Zlt in H0; rewrite Zcompare_mult_compat in H0; assumption.
  discriminate H.
Qed.

Lemma Zmult_lt_reg_r : forall n m p:Z, 0 < p -> n * p < m * p -> n < m.
Proof.
  intros a b c H0 H1.
  apply Zmult_gt_0_lt_reg_r with c; try apply Zlt_gt; assumption.
Qed.

Lemma Zmult_le_reg_r : forall n m p:Z, p > 0 -> n * p <= m * p -> n <= m.
Proof.
  intros x y z Hz Hxy.
  elim (Zle_lt_or_eq (x * z) (y * z) Hxy).
  intros; apply Zlt_le_weak.
  apply Zmult_gt_0_lt_reg_r with z; trivial.
  intros; apply Zeq_le.
  apply Zmult_reg_r with z.
  intro. rewrite H0 in Hz. contradiction (Zgt_irrefl 0).
  assumption.
Qed.

Lemma Zmult_lt_0_le_reg_r : forall n m p:Z, 0 < p -> n * p <= m * p -> n <= m.
Proof.
  intros x y z; intros; apply Zmult_le_reg_r with z.
  try apply Zlt_gt; assumption.
  assumption.
Qed.

Lemma Zmult_ge_reg_r : forall n m p:Z, p > 0 -> n * p >= m * p -> n >= m.
Proof.
  intros a b c H1 H2; apply Zle_ge; apply Zmult_le_reg_r with c; trivial.
  apply Zge_le; trivial.
Qed.

Lemma Zmult_gt_reg_r : forall n m p:Z, p > 0 -> n * p > m * p -> n > m.
Proof.
  intros a b c H1 H2; apply Zlt_gt; apply Zmult_gt_0_lt_reg_r with c; trivial.
  apply Zgt_lt; trivial.
Qed.

(** Compatibility of multiplication by a positive wrt to being positive *)

Lemma Zmult_le_0_compat : forall n m:Z, 0 <= n -> 0 <= m -> 0 <= n * m.
Proof.
  intros x y; case x.
  intros; rewrite Zmult_0_l; trivial.
  intros p H1; unfold Zle in |- *.
  pattern 0 at 2 in |- *; rewrite <- (Zmult_0_r (Zpos p)).
  rewrite Zcompare_mult_compat; trivial.
  intros p H1 H2; absurd (0 > Zneg p); trivial.
  unfold Zgt in |- *; simpl in |- *; auto with zarith.
Qed.

Lemma Zmult_gt_0_compat : forall n m:Z, n > 0 -> m > 0 -> n * m > 0.
Proof.
  intros x y; case x.
  intros H; discriminate H.
  intros p H1; unfold Zgt in |- *; pattern 0 at 2 in |- *;
    rewrite <- (Zmult_0_r (Zpos p)).
  rewrite Zcompare_mult_compat; trivial.
  intros p H; discriminate H.
Qed.

Lemma Zmult_lt_0_compat : forall n m:Z, 0 < n -> 0 < m -> 0 < n * m.
Proof.
  intros a b apos bpos.
  apply Zgt_lt.
  apply Zmult_gt_0_compat; try apply Zlt_gt; assumption.
Qed.

(** For compatibility *)
Notation Zmult_lt_O_compat := Zmult_lt_0_compat (only parsing).

Lemma Zmult_gt_0_le_0_compat : forall n m:Z, n > 0 -> 0 <= m -> 0 <= m * n.
Proof.
  intros x y H1 H2; apply Zmult_le_0_compat; trivial.
  apply Zlt_le_weak; apply Zgt_lt; trivial.
Qed.

(** Simplification of multiplication by a positive wrt to being positive *)

Lemma Zmult_le_0_reg_r : forall n m:Z, n > 0 -> 0 <= m * n -> 0 <= m.
Proof.
  intros x y; case x;
    [ simpl in |- *; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H
      | intros p H1; unfold Zle in |- *; rewrite Zmult_comm;
	pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p));
	  rewrite Zcompare_mult_compat; auto with arith
      | intros p; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H ].
Qed.

Lemma Zmult_gt_0_lt_0_reg_r : forall n m:Z, n > 0 -> 0 < m * n -> 0 < m.
Proof.
  intros x y; case x;
    [ simpl in |- *; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H
      | intros p H1; unfold Zlt in |- *; rewrite Zmult_comm;
	pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p));
	  rewrite Zcompare_mult_compat; auto with arith
      | intros p; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H ].
Qed.

Lemma Zmult_lt_0_reg_r : forall n m:Z, 0 < n -> 0 < m * n -> 0 < m.
Proof.
  intros x y; intros; eapply Zmult_gt_0_lt_0_reg_r with x; try apply Zlt_gt;
    assumption.
Qed.

Lemma Zmult_gt_0_reg_l : forall n m:Z, n > 0 -> n * m > 0 -> m > 0.
Proof.
  intros x y; case x.
  intros H; discriminate H.
  intros p H1; unfold Zgt in |- *.
  pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p)).
  rewrite Zcompare_mult_compat; trivial.
  intros p H; discriminate H.
Qed.

(** ** Square *)
(** Simplification of square wrt order *)

Lemma Zgt_square_simpl :
  forall n m:Z, n >= 0 -> n * n > m * m -> n > m.
Proof.
  intros n m H0 H1.
  case (dec_Zlt m n).
  intro; apply Zlt_gt; trivial.
  intros H2; cut (m >= n).
  intros H.
  elim Zgt_not_le with (1 := H1).
  apply Zge_le.
  apply Zmult_ge_compat; auto.
  apply Znot_lt_ge; trivial.
Qed.

Lemma Zlt_square_simpl :
  forall n m:Z, 0 <= n -> m * m < n * n -> m < n.
Proof.
  intros x y H0 H1.
  apply Zgt_lt.
  apply Zgt_square_simpl; try apply Zle_ge; try apply Zlt_gt; assumption.
Qed.

(** * Equivalence between inequalities *)

Lemma Zle_plus_swap : forall n m p:Z, n + p <= m <-> n <= m - p.
Proof.
  intros x y z; intros. split. intro. rewrite <- (Zplus_0_r x). rewrite <- (Zplus_opp_r z).
  rewrite Zplus_assoc. exact (Zplus_le_compat_r _ _ _ H).
  intro. rewrite <- (Zplus_0_r y). rewrite <- (Zplus_opp_l z). rewrite Zplus_assoc.
  apply Zplus_le_compat_r. assumption.
Qed.

Lemma Zlt_plus_swap : forall n m p:Z, n + p < m <-> n < m - p.
Proof.
  intros x y z; intros. split. intro. unfold Zminus in |- *. rewrite Zplus_comm. rewrite <- (Zplus_0_l x).
  rewrite <- (Zplus_opp_l z). rewrite Zplus_assoc_reverse. apply Zplus_lt_compat_l. rewrite Zplus_comm.
  assumption.
  intro. rewrite Zplus_comm. rewrite <- (Zplus_0_l y). rewrite <- (Zplus_opp_r z).
  rewrite Zplus_assoc_reverse. apply Zplus_lt_compat_l. rewrite Zplus_comm. assumption.
Qed.

Lemma Zeq_plus_swap : forall n m p:Z, n + p = m <-> n = m - p.
Proof.
  intros x y z; intros. split. intro. apply Zplus_minus_eq. symmetry  in |- *. rewrite Zplus_comm.
  assumption.
  intro. rewrite H. unfold Zminus in |- *. rewrite Zplus_assoc_reverse.
  rewrite Zplus_opp_l. apply Zplus_0_r.
Qed.

Lemma Zlt_minus_simpl_swap : forall n m:Z, 0 < m -> n - m < n.
Proof.
  intros n m H; apply Zplus_lt_reg_l with (p := m); rewrite Zplus_minus;
    pattern n at 1 in |- *; rewrite <- (Zplus_0_r n);
      rewrite (Zplus_comm m n); apply Zplus_lt_compat_l;
	assumption.
Qed.

Lemma Zlt_0_minus_lt : forall n m:Z, 0 < n - m -> m < n.
Proof.
  intros n m H; apply Zplus_lt_reg_l with (p := - m); rewrite Zplus_opp_l;
    rewrite Zplus_comm; exact H.
Qed.

Lemma Zle_0_minus_le : forall n m:Z, 0 <= n - m -> m <= n.
Proof.
  intros n m H; apply Zplus_le_reg_l with (p := - m); rewrite Zplus_opp_l;
    rewrite Zplus_comm; exact H.
Qed.

Lemma Zle_minus_le_0 : forall n m:Z, m <= n -> 0 <= n - m.
Proof.
  intros n m H; unfold Zminus; apply Zplus_le_reg_r with (p := m);
    rewrite <- Zplus_assoc; rewrite Zplus_opp_l; rewrite Zplus_0_r; exact H.
Qed.

Lemma Zmult_lt_compat:
  forall n m p q : Z, 0 <= n < p -> 0 <= m < q -> n * m < p * q.
Proof.
  intros n m p q (H1, H2) (H3,H4).
  assert (0<p) by (apply Zle_lt_trans with n; auto).
  assert (0<q) by (apply Zle_lt_trans with m; auto).
  case Zle_lt_or_eq with (1 := H1); intros H5; auto with zarith.
  case Zle_lt_or_eq with (1 := H3); intros H6; auto with zarith.
  apply Zlt_trans with (n * q).
  apply Zmult_lt_compat_l; auto.
  apply Zmult_lt_compat_r; auto with zarith.
  rewrite <- H6; rewrite Zmult_0_r; apply Zmult_lt_0_compat; auto with zarith.
  rewrite <- H5; simpl; apply Zmult_lt_0_compat; auto with zarith.
Qed.

Lemma Zmult_lt_compat2:
  forall n m p q : Z, 0 < n <= p -> 0 < m < q -> n * m < p * q.
Proof.
  intros n m p q (H1, H2) (H3, H4).
  apply Zle_lt_trans with (p * m).
  apply Zmult_le_compat_r; auto.
  apply Zlt_le_weak; auto.
  apply Zmult_lt_compat_l; auto.
  apply Zlt_le_trans with n; auto.
Qed.

(** For compatibility *)
Notation Zlt_O_minus_lt := Zlt_0_minus_lt (only parsing).


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From adtind Require Import goal40.

Set Printing Depth 1000.
Definition lfind_eval  y:=
lst_subset y y.

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons (Succ (Succ (Succ Zero))) Nil))).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons (Succ Zero) Nil))).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Nil).


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                                                                          *)
(* Jean-Francois.Monin@lannion.cnet.fr                                      *)
(* December 1994, Coq V5.10                                                 *)
(*                                                                          *)
(****************************************************************************)
(*                                tree_plus.v                               *)
(****************************************************************************)

(* ================================================== *)

(* Require func_pred. *)

Require Export tree.

Definition leaveplus : tree -> nat := ext_morph plus.

Definition Pleaveplus : tree -> nat -> Prop := Pext_morph plus.

Definition Plp := Pl plus.
Definition Pnp := Pn plus.

Definition Plp_lp : forall t : tree, Pleaveplus t (leaveplus t) :=
  Pem_em plus.

Definition lp_eq_Plp :
  forall (t : tree) (n : nat), n = leaveplus t -> Pleaveplus t n :=
  em_eq_Pem plus.

Definition Plp_lp_eq :
  forall (t : tree) (n : nat), Pleaveplus t n -> n = leaveplus t :=
  Pem_em_eq plus.

Hint Resolve Plp Pnp lp_eq_Plp Plp_lp_eq.

(* ================================================== *)


(** * 6.887 Formal Reasoning About Programs, Spring 2016 - Pset 1 *)

Require Import Frap Pset1Sig.

Lemma applyIndHyp : forall (x : nat) (m1: map_) (m2 : map_), (allPositive m1 -> x > 0 -> interp_map m1 x > 0) -> ( allPositive m2 -> x > 0 -> interp_map m2 x > 0) -> ( allPositive (Add m1 m2) -> x > 0 -> interp_map (Add m1 m2) x > 0).
  Proof.
    intros.
    simplify.
    destruct H1.
    specialize (H H1 H2).
    specialize (H0 H3 H2).
    linear_arithmetic.
  Qed.
Theorem allPositive_ok : forall (m : map_) (x : nat),
  allPositive m
  -> x > 0
  -> interp_map m x > 0.
Proof.

  (*works below*)
  induct m. intro.
  intro.
  intro.
  unfold interp_map.
  unfold allPositive in H. trivial.

  intro.
  intro.
  intro.
  unfold allPositive in H.
  unfold interp_map. trivial.

  intro.
  Check applyIndHyp.
  apply (applyIndHyp x m1 m2 (IHm1 x) (IHm2 x)).

  intros.
  simplify.
  specialize (IHm2 x).
  specialize (IHm1 (interp_map m2 x)).
  destruct H.
  exact (IHm1 H (IHm2 H1 H0)).
Qed.
(*from perry*)
(*
Lemma fl_lsls_plus_ls: forall (lsls : list(list nat)) (ls1 ls2 : nat), fold_left plus lsls (ls1 ++ ls2) = fold_left plus lsls ls1 ++ ls2.
Proof.

Admitted.*)

Lemma fl_list_plus_nat: forall (ls : list nat) (a0 a : nat), fold_left plus ls (a0 + a) = fold_left plus ls a0 + a.
Proof.
  induct ls.
  simplify.
  ring.
  simplify.
  repeat rewrite IHls.
  SearchAbout fold_left.
  ring.
Qed.

Lemma fl_list_max_nat: forall (ls : list nat) (a0 a : nat), fold_left max ls (max a0 a) = max (fold_left max ls a0) a.
Proof.
  induct ls.
  simplify.
  ring.

  simplify.
  repeat rewrite IHls.
  SearchAbout max.

  rewrite <- Max.max_assoc .
  symmetry.
  rewrite <- Max.max_assoc.
  f_equal.
  apply Max.max_comm.
Qed.

Lemma fl_swap_plus : forall (ls1 ls2 : list nat) (a:nat), fold_left plus (ls1 ++ ls2) a = fold_left plus (ls2 ++ ls1) a.
Proof.
  induct ls1.
  simplify.
  rewrite app_nil_r.
  equality.

  simplify.
  SearchAbout fold_left app.
  rewrite IHls1.
  repeat rewrite fold_left_app.
  simplify.
  f_equal.
  apply fl_list_plus_nat.
Qed.

Lemma fl_swap_max :  forall (ls1 ls2 : list nat) (a:nat), fold_left max (ls1 ++ ls2) a = fold_left max (ls2 ++ ls1) a.
Proof.
  induct ls1.
  simplify.
  rewrite app_nil_r.
  equality.

  simplify.
  rewrite IHls1.
  repeat rewrite fold_left_app.
  repeat simplify.
  f_equal.
  apply fl_list_max_nat.
Qed.

Theorem reduce_swap : forall e ls1 ls2, interp_reduce e (ls1 ++ ls2) = interp_reduce e (ls2 ++ ls1).
Proof.
  (*try cases, destruct, cases on +, max*)
  induct e.
  simplify.
  apply fl_swap_plus.
  repeat simplify.
  apply fl_swap_max.
Qed.

Theorem interp_swap : forall e ls1 ls2, interp_mr e (ls1 ++ ls2) = interp_mr e (ls2 ++ ls1).
Proof.
  induct e.
  simplify.
  unfold interp_mr.
  simplify.
  SearchAbout map.
  rewrite -> map_app.
  symmetry.
  rewrite -> map_app.
  simplify.
  rewrite reduce_swap.
  equality.
Qed.

Lemma red_add_dist : forall(ls1 ls2 : list nat), fold_left plus (ls1 ++ ls2) 0 = fold_left plus ls1 0 + fold_left plus ls2 0.
Proof.
  induct ls1.
  induct ls2.
  simplify.
  equality.

  simplify.
  equality.

  simplify.
  SearchRewrite (_ + 0).
  rewrite <- (plus_0_r (a)).
  rewrite <- plus_comm.
  SearchRewrite (_ + _).
  rewrite fl_list_plus_nat.
  symmetry.
  rewrite fl_list_plus_nat.
  symmetry.
  specialize (IHls1 ls2).

  rewrite IHls1.
  linear_arithmetic.
Qed.

Lemma red_max_dist : forall (ls1 ls2 : list nat), fold_left max (ls1 ++ ls2) 0 = max (fold_left max ls1 0) (fold_left max ls2 0).
Proof.
  induct ls1.
  induct ls2.
  simplify.
  equality.

  simplify.
  equality.

  simplify.
  SearchAbout max.

  rewrite fl_list_max_nat.
  symmetry.
  rewrite fl_list_max_nat.
  symmetry.

  specialize (IHls1 ls2).
  rewrite IHls1.
  SearchAbout max.

  rewrite <- Max.max_assoc.
  symmetry.
  rewrite <- Max.max_assoc.
  symmetry.
  f_equal.
  rewrite <- Max.max_comm .
  equality.
Qed.
Theorem mapReduce_partition_two : forall m r ls1 ls2, interp_mr (m, r) (ls1 ++ ls2) = interp_reduce r [interp_mr (m, r) ls1; interp_mr (m, r) ls2].
Proof.
  induct r.
  simplify.
  unfold interp_mr.
  simplify.

  SearchAbout map.
  rewrite map_app.
  rewrite red_add_dist.
  linear_arithmetic.

  unfold interp_mr.
  simplify.

  rewrite map_app.
  rewrite Max.max_0_l.
  rewrite red_max_dist.
  equality.
Qed.

Arguments app {_} _ _ .
Lemma app_conc : forall a (ls : list a) (b : a), b::ls = [b]++ls.
Proof.
  simplify.
  equality.
Qed.

Lemma lsls_partition : forall (lsls : list(list nat)) (a : list nat), fold_left app lsls a = fold_left app lsls [] ++ a.
Proof.

(*
  induct lsls.
  simplify.
  equality.

  simplify.
  SearchAbout app.
  cases a.
  simplify.
  rewrite IHlsls.
  SearchRewrite (_ ++ []).
  rewrite app_nil_r.
  equality.

  *)
Admitted.

Theorem mapReduce_partition : forall m r lsls, interp_mr (m, r) (fold_left app lsls []) = interp_reduce r (List.map (interp_mr (m, r)) lsls).
Proof.
  induct lsls.
  simplify.
  unfold interp_mr.
  simplify.
  equality.

  simplify.

  rewrite lsls_partition.
  rewrite mapReduce_partition_two.
  rewrite IHlsls.
  rewrite app_conc.
  rewrite reduce_swap.

  cases r.
  simplify.
  rewrite <- (plus_0_r (interp_mr (m, Sum) a)).
  rewrite <- plus_comm.
  SearchRewrite (_ + _).
  rewrite fl_list_plus_nat.

  symmetry.
  rewrite <- (plus_0_r (interp_mr (m, Sum) a)).
  rewrite <- (plus_comm (0) ( interp_mr (m, Sum) a)).
  SearchRewrite (_ + 0).
  rewrite fl_list_plus_nat.
  simplify.
  linear_arithmetic.

  simplify.
  (*rewrite fl_list_max_nat.*)
  symmetry.
  rewrite fl_list_max_nat.
  simplify.
  rewrite Max.max_0_l.
  rewrite Max.max_comm.
  equality.

Qed.

(* For full credit, the code you turn in can't use [Admitted] or [admit] anymore! *)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** This file centralizes the lemmas about [Z], classifying them
    according to the way they can be used in automatic search  *)

(** Lemmas which clearly leads to simplification during proof search are *)
(** declared as Hints. A definite status (Hint or not) for the other lemmas *)
(** remains to be given *)

(** Structure of the file *)
(** - simplification lemmas (only those are declared as Hints) *)
(** - reversible lemmas relating operators *)
(** - useful Bottom-up lemmas              *)
(** - irreversible lemmas with meta-variables *)
(** - unclear or too specific lemmas       *)
(** - lemmas to be used as rewrite rules   *)

(** Lemmas involving positive and compare are not taken into account *)

Require Import BinInt.
Require Import Zorder.
Require Import Zmin.
Require Import Zabs.
Require Import Zcompare.
Require Import Znat.
Require Import auxiliary.
Require Import Zmisc.
Require Import Wf_Z.

(************************************************************************)
(** *                 Simplification lemmas                             *)

(** No subgoal or smaller subgoals                                     *)

Hint Resolve
  (** ** Reversible simplification lemmas (no loss of information)      *)
  (** Should clearly be declared as hints                               *)

  (** Lemmas ending by eq *)
  Zsucc_eq_compat (* n = m -> Z.succ n = Z.succ m *)

  (** Lemmas ending by Z.gt *)
  Zsucc_gt_compat (* m > n -> Z.succ m > Z.succ n *)
  Zgt_succ (* Z.succ n > n *)
  Zorder.Zgt_pos_0 (* Z.pos p > 0 *)
  Zplus_gt_compat_l (* n > m -> p+n > p+m *)
  Zplus_gt_compat_r (* n > m -> n+p > m+p *)

  (** Lemmas ending by Z.lt *)
  Pos2Z.is_pos (* 0 < Z.pos p *)
  Z.lt_succ_diag_r (* n < Z.succ n *)
  Zsucc_lt_compat (* n < m -> Z.succ n < Z.succ m *)
  Z.lt_pred_l (* Z.pred n < n *)
  Zplus_lt_compat_l (* n < m -> p+n < p+m *)
  Zplus_lt_compat_r (* n < m -> n+p < m+p *)

  (** Lemmas ending by Z.le *)
  Nat2Z.is_nonneg (* 0 <= Z.of_nat n *)
  Pos2Z.is_nonneg (* 0 <= Z.pos p *)
  Z.le_refl (* n <= n *)
  Z.le_succ_diag_r (* n <= Z.succ n *)
  Zsucc_le_compat (* m <= n -> Z.succ m <= Z.succ n *)
  Z.le_pred_l (* Z.pred n <= n *)
  Z.le_min_l (* Z.min n m <= n *)
  Z.le_min_r (* Z.min n m <= m *)
  Zplus_le_compat_l (* n <= m -> p+n <= p+m *)
  Zplus_le_compat_r (* a <= b -> a+c <= b+c *)
  Z.abs_nonneg (* 0 <= |x| *)

  (** ** Irreversible simplification lemmas *)
  (** Probably to be declared as hints, when no other simplification is possible *)

  (** Lemmas ending by eq *)
  Z_eq_mult (* y = 0 -> y*x = 0 *)
  Zplus_eq_compat (* n = m -> p = q -> n+p = m+q *)

  (** Lemmas ending by Z.ge *)
  Zorder.Zmult_ge_compat_r (* a >= b -> c >= 0 -> a*c >= b*c *)
  Zorder.Zmult_ge_compat_l (* a >= b -> c >= 0 -> c*a >= c*b *)
  Zorder.Zmult_ge_compat (* :
      a >= c -> b >= d -> c >= 0 -> d >= 0 -> a*b >= c*d *)

  (** Lemmas ending by Z.lt *)
  Zorder.Zmult_gt_0_compat (* a > 0 -> b > 0 -> a*b > 0 *)
  Z.lt_lt_succ_r (* n < m -> n < Z.succ m *)

  (** Lemmas ending by Z.le *)
  Z.mul_nonneg_nonneg (* 0 <= x -> 0 <= y -> 0 <= x*y *)
  Zorder.Zmult_le_compat_r (* a <= b -> 0 <= c -> a*c <= b*c *)
  Zorder.Zmult_le_compat_l (* a <= b -> 0 <= c -> c*a <= c*b *)
  Z.add_nonneg_nonneg (* 0 <= x -> 0 <= y -> 0 <= x+y *)
  Z.le_le_succ_r (* x <= y -> x <= Z.succ y *)
  Z.add_le_mono (* n <= m -> p <= q -> n+p <= m+q *)

  : zarith.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat div fintype.
Require Import finset groups cyclic.

Import GroupScope.

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

Definition involg (gT : finGroupType) (a : gT) := involutive (mulg a).

Lemma involgKP : forall (gT : finGroupType) (a : gT),
  reflect (involg a) (a * a == 1).
Proof.
move=> gT a; apply:(iffP eqP)=> Ha; first by move=> x; rewrite mulgA Ha mul1g.
by rewrite -{2}(mulg1 a).
Qed.

Lemma invol_conjg_expn : forall (gT:finGroupType) (a t:gT),
  (involg t) -> forall n, a ^+ n ^t = (a ^ t) ^+n.
Proof.
move=> gT a t Hi; move/involgKP: Hi=> Heq.
elim =>[|n IHn]; first by rewrite !expg0 conj1g.
by rewrite !expgS conjMg IHn.
Qed.

Lemma involgen_order : forall (gT: finGroupType) (t: gT),
  (involg t) -> t !=1 -> #[t] = 2.
move=> gT t Hi; have:= (trivg_card1 <[t]>); rewrite cycle_eq1=>-> /=.
move/involgKP: Hi; have:= (expgS t 1); rewrite expg1=> <-.
move/order_inf;move: (order_gt0 t); rewrite /order /=.
case : #|<[t]>| => [|n0] ; first by rewrite ltn0.
by case :n0=> [|n1] // _; rewrite !ltnS leq_eqVlt ltn0 orbF; move/eqP->.
Qed.

Lemma involgen_group2 : forall (gT:finGroupType) (t:gT),
  (involg t) -> t != 1 -> <[t]> = [set 1;t].
Proof.
move=> gT t Hi Hn1; apply/eqP.
rewrite eqEsubset subUset !sub1set group1 cycle_id !andbT.
have G1t: (group_set [set 1; t]).
apply/group_setP; split; first by apply/setUP; left; apply/set1P.
move=> x y; move/setUP; case; move/set1P->; move/setUP; case; move/set1P->;
  rewrite ?mul1g ?mulg1 inE !in_set1 ?eq_refl ?orbT //.
  by move/involgKP: Hi->.
by rewrite -[[set 1; t]]/(gval (group G1t)) gen_subG /= sub1set inE !in_set1 eq_refl ?orbT.
Qed.

Module Type  Dihedral.
Parameter gT : finGroupType.
Parameter D : {group gT}.
Parameter c : gT.
Axiom dhntriv : (cycle c) != 1.
Axiom dhsub : c \in D.
Axiom dhindex : #|D : (cycle c)| = 2.
Axiom dhinvol : forall t, (t \in (D:\: (cycle c))) -> involg t.
End Dihedral.

Section Involutions.
Variable gT : finGroupType.
Variable D : {group gT}.
Variable c : gT.
Hypothesis dhsub : c \in D.
Hypothesis dhindex : #|D : (cycle c)| = 2.

Notation Local C := (cycle c).

Lemma D_order : (#|C| * 2 = #|D|)%nat.
Proof.
move: dhsub; rewrite -cycle_subG; move/LaGrange.
by rewrite dhindex.
Qed.

Variable t :gT.
Variable Ht : t \in D:\:C.
Hypothesis Hit : involg t.

Lemma DmC_coset : D :\: C = C :* t.
Proof.
apply/eqP; rewrite eq_sym eqEcard card_rcoset.
have:= (cardsID C D); rewrite setIC; move: dhsub.
rewrite -cycle_subG; move/setIidPl ->; move/eqP.
rewrite -D_order mulnSr muln1 eqn_addl; move/eqP ->; rewrite leqnn andbT.
apply/subsetP=> x Hx; rewrite inE andbC; apply/andP; split;
move/rcosetP:Hx=> [a Heq] ->; move: Ht; rewrite inE; move/andP=> [HnC].
  move: dhsub; rewrite -cycle_subG; move/subsetP; move/(_ _ Heq).
  by move/groupMl ->.
by move=> [_]; rewrite (groupMl _ Heq).
Qed.

Lemma DmC_involP :
 reflect (forall u, (u \in D:\:C) -> involg u)
 (c ^ t == c ^-1).
Proof.
rewrite DmC_coset; apply:(iffP eqP).
  move=> Heq x; move/rcosetP=> [a Ha]->.
  move/cycleP: Ha => [n ->]; apply/involgKP; move/involgKP: Hit.
  rewrite  -{2}(invgK t) -eq_mulgV1 =>Hti.
  rewrite {1}(eqP Hti) -mulgA -/(conjg (c ^+ n) t).
  by rewrite (invol_conjg_expn _ Hit) Heq expVgn mulgV.
move=> Hix; apply/eqP; rewrite eq_sym eq_mulVg1 invgK conjgE; move: Hit.
move/involgKP; rewrite -{2}(invgK t) -eq_mulgV1 mulgA; move/eqP<-.
apply/involgKP; apply: (Hix (c * t)); apply/rcosetP; exists c => //.
by apply:cycle_id.
Qed.

End Involutions.

Module DihedralTheory (Dh:Dihedral).

Notation Local gT := Dh.gT.
Notation Local D := Dh.D.
Notation Local c := Dh.c.
Notation Local dhntriv := Dh.dhntriv.
Notation Local dhsub := Dh.dhsub.
Notation Local dhindex := Dh.dhindex.
Notation Local dhinvol := Dh.dhinvol.

Notation Local C := (cycle c).

Lemma DmCJ : forall a y, a \in C -> y \in D:\:C -> a ^ y = a ^-1.
Proof.
move=> a y Ha Hy; move/cycleP:Ha=> [n] ->; move/involgKP:(dhinvol Hy) => Heq.
apply/eqP; rewrite eq_sym eq_mulVg1 invgK conjgE mulgA.
move: Heq; rewrite -{2}(invgK y) -eq_mulgV1; move/eqP<-.
apply/involgKP; apply:dhinvol; rewrite (DmC_coset dhsub dhindex Hy).
apply/rcosetP; exists (c^+n) => //; apply:mem_cycle.
Qed.

Lemma Dgen : forall t, t\in D:\:C -> <<[set c * t; t]>> = D.
Proof.
move=> t Ht; apply/eqP; rewrite eqEcard.
have c2sub : <<[set c * t; t]>> \subset D.
  rewrite gen_subG subUset !sub1set (groupMl _ dhsub).
  by move:Ht; rewrite inE; move/andP=>[_] ->.
rewrite c2sub /=.
have: C \proper <<[set c* t; t]>>.
  rewrite properE gen_subG sub1set; apply/andP; split.
    apply/generatedP=> G; rewrite subUset !sub1set; move/andP=> [Gct Gt].
    rewrite -(mulg1 c); move/involgKP: (dhinvol Ht); move/eqP <-; rewrite mulgA.
    by rewrite (groupMl _ Gct).
  apply/subsetPn; exists t; first by apply:mem_gen; rewrite !inE eq_refl orbT.
  by move: Ht; rewrite inE; move/andP=> [H].
rewrite properEcard; move/andP=> [HCsub HCcard].
rewrite -(D_order dhsub dhindex); move: (cardSg HCsub).
move/dvdnP=> [k Hk]; rewrite Hk mulnC leq_mul2r.
move/eqP: Hk; rewrite -(LaGrange HCsub) mulnC /= eqn_mul2r.
move:(cardG_gt0 [group of C]); rewrite eqn0Ngt /= => -> /=.
move/eqP<-.
case e: #|<<[set c * t; t]>> : C|=>[|n0];
  first by move/eqP: e; rewrite eqn0Ngt indexg_gt0.
rewrite ltnS; move:e; case n0=>[|n1]; last by rewrite ltn0Sn.
by move/(index1g HCsub)=>Hcsub; move:HCcard; injection Hcsub=>->; rewrite ltnn.
Qed.

End DihedralTheory.

Section InvoGen.

Variable gT :finGroupType.
Variables s t : gT.
Hypothesis His : involg s.
Hypothesis Hit: involg t.
Hypothesis Hdistinct: s != t.
Hypothesis Htn1 : t != 1.
Hypothesis Hsn1 : s != 1.

Notation Local D := <<[set s; t]>>.
Notation Local C := (cycle (s * t)).

Lemma Cntriv : C != 1.
Proof.
apply/eqP; apply/trivgP; rewrite gen_subG sub1set inE; move: (His 1); move/eqP.
by rewrite mulg1 -{2}(invgK s) -eq_mulgV1; move/eqP->; rewrite -eq_mulVg1.
Qed.

Lemma DC_invol : (s * t) ^ t = (s * t) ^-1.
Proof.
apply/eqP; move/involgKP: Hit; rewrite conjgE -mulgA invMg; move/eqP->.
by move/involgKP: His; rewrite mulg1 -{2}(invgK s) -eq_mulgV1; move/eqP<-.
Qed.

Lemma DC_norm : t \in 'N_D(C).
Proof.
rewrite inE; apply/andP; split.
  by apply/generatedP=> G; rewrite subUset !sub1set; move/andP=> [_].
rewrite -sub1set; apply/normsP => x; move/set1P->.
rewrite -genJ conjg_set1 DC_invol; exact: cycleV.
Qed.

Lemma DCt : C * (cycle t) = D.
Proof.
suff : (s \in C * (cycle t)) && (t \in C * (cycle t)).
  move=> Hst; apply/eqP; rewrite eqEsubset.
  apply/andP; split; last first.
  have GCt : (group_set (C * <[t]>)).
    apply/comm_group_setP; apply:commute_sym; apply:normC; move: DC_norm.
    by move/setIP=>[_]; rewrite -sub1set -gen_subG.
  by rewrite -[C * <[t]>]/(gval (group GCt)) gen_subG subUset !sub1set /=.
by apply: mul_subG; rewrite gen_subG ?subUset sub1set ?groupM ?mem_gen //
  in_setU !in_set1 eq_refl ?orbT.
rewrite -{1}(mulg1 s) -(mulgV t) -{5}(mul1g t).
move/involgKP: Hit; rewrite -{2}(invgK t) -eq_mulgV1 mulgA; move/eqP<-.
by rewrite !mem_mulg ?group1 ?mem_gen ?inE ?eq_refl.
Qed.

Lemma Cnotst : ~~ ((s \in C) || (t \in C)).
Proof.
apply/negP =>H; have {H}Hboth: (s \in C) && (t\in C).
  by case/orP: H=> H; move: (cycle_id (s * t));
    rewrite ?(groupMl _ H) ?(groupMr _ H) => Hcyc; rewrite H Hcyc.
case e: (2 %| #[s * t]); move/andP:Hboth=> [Hsin]; move/cycleP=>[n0 H];
move: (cycleX (s * t) n0); rewrite -H; last first.
  by move/cardSg; rewrite [#|_|]involgen_order // e.
move/cycleP:Hsin =>[n1 H1]; move: (cycleX (s * t) n1); rewrite -H1=> sCsub tCsub.
set SG := [set H : {group gT} | (H \subset C) && (#|H| == 2)].
rewrite /= in SG; have :[group of <[s]>] \in SG.
by rewrite inE /= sCsub; move: (involgen_order His Hsn1); rewrite /order => ->.
have :[group of <[t]>] \in SG.
by rewrite inE /= tCsub; move: (involgen_order Hit Htn1); rewrite /order => ->.
rewrite /SG (cycle_sub_group e) !in_set1.
move/eqP<-; move/eqP; rewrite /= /group =>Hst.
have {Hst}: <[s]> = <[t]> by rewrite -![<[_]>]/(gval _) /cycle_group Hst /=.
rewrite (involgen_group2 Hit Htn1) (involgen_group2 His Hsn1); move/eqP.
rewrite eqEsubset !subUset !sub1set !inE eq_refl (negbTE Hsn1) (negbTE Htn1) /=.
by rewrite (negbTE Hdistinct).
Qed.

Lemma Ctcap : C :&: <[t]> = 1.
Proof.
move: Cnotst; rewrite negb_or; move/andP=>[_] HtnC.
rewrite (involgen_group2 Hit Htn1) setIUr.
move: (group1 [group of C]); rewrite -sub1set /=.
move/setIidPr->; move: (subsetIr C [set t]).
rewrite subset1; case/orP; last by move/eqP=>->; rewrite setU0.
by move/eqP; move/setIidPr; rewrite sub1set=>H; move: HtnC; rewrite H.
Qed.

Lemma DCindex : #|D : C| = 2.
Proof.
move: (divgI [group of D] [group of C]).
rewrite /= -DCt -group_modl ?subset_refl // -(setIC C <[t]>) Ctcap mulg1.

rewrite (TI_cardMg Ctcap) mulKn ?order_gt0 // =><- /=.
by rewrite [#|<[_]>|](involgen_order Hit Htn1).
Qed.

End InvoGen.

Module Involuted : Dihedral.
Variable gT :finGroupType.
Variables s t : gT.
Hypothesis His : involg s.
Hypothesis Hit: involg t.
Hypothesis Hdistinct: s != t.
Hypothesis Htn1 : t != 1.
Hypothesis Hsn1 : s != 1.

Definition D := [group of <<[set s; t]>>].
Definition c := (s * t).
Definition dhntriv : (cycle c) != 1 := (Cntriv His Hdistinct).
Lemma dhsub : c \in D.
Proof.
apply/generatedP=> G; rewrite subUset !sub1set; move/andP=>[Gs Gt].
by apply:groupM.
Qed.
Definition dhindex : #|D : (cycle c)| = 2 :=
  DCindex His Hit Hdistinct Htn1 Hsn1.
Lemma dhinvol : forall t, (t \in (D:\: (cycle c))) -> involg t.
Proof.
apply/(DmC_involP dhsub dhindex _ Hit ); last first.
  apply/eqP; apply:DC_invol; [exact:His|exact:Hit].
have:= (Cnotst His Hit Hdistinct Htn1 Hsn1); rewrite negb_or inE.
move/andP=> [_] -> /=; rewrite -(DCt His Hit) -{1}(mul1g t).
by apply:mem_mulg; rewrite ?group1 ?cycle_id.
Qed.
End Involuted.


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

(*i $Id: R_sqrt.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import Rbase.
Require Import Rfunctions.
Require Import Rsqrt_def.
Open Local Scope R_scope.

(** * Continuous extension of Rsqrt on R *)
Definition sqrt (x:R) : R :=
  match Rcase_abs x with
    | left _ => 0
    | right a => Rsqrt (mknonnegreal x (Rge_le _ _ a))
  end.

Lemma sqrt_pos : forall x : R, 0 <= sqrt x.
Proof.
  intros x.
  unfold sqrt.
  destruct (Rcase_abs x) as [H|H].
  apply Rle_refl.
  apply Rsqrt_positivity.
Qed.

Lemma sqrt_positivity : forall x:R, 0 <= x -> 0 <= sqrt x.
Proof.
  intros x _.
  apply sqrt_pos.
Qed.

Lemma sqrt_sqrt : forall x:R, 0 <= x -> sqrt x * sqrt x = x.
Proof.
  intros.
  unfold sqrt in |- *.
  case (Rcase_abs x); intro.
  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ r H)).
  rewrite Rsqrt_Rsqrt; reflexivity.
Qed.

Lemma sqrt_0 : sqrt 0 = 0.
Proof.
  apply Rsqr_eq_0; unfold Rsqr in |- *; apply sqrt_sqrt; right; reflexivity.
Qed.

Lemma sqrt_1 : sqrt 1 = 1.
Proof.
  apply (Rsqr_inj (sqrt 1) 1);
    [ apply sqrt_positivity; left
      | left
      | unfold Rsqr in |- *; rewrite sqrt_sqrt; [ ring | left ] ];
    apply Rlt_0_1.
Qed.

Lemma sqrt_eq_0 : forall x:R, 0 <= x -> sqrt x = 0 -> x = 0.
Proof.
  intros; cut (Rsqr (sqrt x) = 0).
  intro; unfold Rsqr in H1; rewrite sqrt_sqrt in H1; assumption.
  rewrite H0; apply Rsqr_0.
Qed.

Lemma sqrt_lem_0 : forall x y:R, 0 <= x -> 0 <= y -> sqrt x = y -> y * y = x.
Proof.
  intros; rewrite <- H1; apply (sqrt_sqrt x H).
Qed.

Lemma sqrt_lem_1 : forall x y:R, 0 <= x -> 0 <= y -> y * y = x -> sqrt x = y.
Proof.
  intros; apply Rsqr_inj;
    [ apply (sqrt_positivity x H)
      | assumption
      | unfold Rsqr in |- *; rewrite H1; apply (sqrt_sqrt x H) ].
Qed.

Lemma sqrt_def : forall x:R, 0 <= x -> sqrt x * sqrt x = x.
Proof.
  intros; apply (sqrt_sqrt x H).
Qed.

Lemma sqrt_square : forall x:R, 0 <= x -> sqrt (x * x) = x.
Proof.
  intros;
    apply
      (Rsqr_inj (sqrt (Rsqr x)) x (sqrt_positivity (Rsqr x) (Rle_0_sqr x)) H);
      unfold Rsqr in |- *; apply (sqrt_sqrt (Rsqr x) (Rle_0_sqr x)).
Qed.

Lemma sqrt_Rsqr : forall x:R, 0 <= x -> sqrt (Rsqr x) = x.
Proof.
  intros; unfold Rsqr in |- *; apply sqrt_square; assumption.
Qed.

Lemma sqrt_Rsqr_abs : forall x:R, sqrt (Rsqr x) = Rabs x.
Proof.
  intro x; rewrite Rsqr_abs; apply sqrt_Rsqr; apply Rabs_pos.
Qed.

Lemma Rsqr_sqrt : forall x:R, 0 <= x -> Rsqr (sqrt x) = x.
Proof.
  intros x H1; unfold Rsqr in |- *; apply (sqrt_sqrt x H1).
Qed.

Lemma sqrt_mult_alt :
  forall x y : R, 0 <= x -> sqrt (x * y) = sqrt x * sqrt y.
Proof.
  intros x y Hx.
  unfold sqrt at 3.
  destruct (Rcase_abs y) as [Hy|Hy].
  rewrite Rmult_0_r.
  destruct Hx as [Hx'|Hx'].
  unfold sqrt.
  destruct (Rcase_abs (x * y)) as [Hxy|Hxy].
  apply eq_refl.
  elim Rge_not_lt with (1 := Hxy).
  rewrite <- (Rmult_0_r x).
  now apply Rmult_lt_compat_l.
  rewrite <- Hx', Rmult_0_l.
  exact sqrt_0.
  apply Rsqr_inj.
  apply sqrt_pos.
  apply Rmult_le_pos.
  apply sqrt_pos.
  apply Rsqrt_positivity.
  rewrite Rsqr_mult, 2!Rsqr_sqrt.
  unfold Rsqr.
  now rewrite Rsqrt_Rsqrt.
  exact Hx.
  apply Rmult_le_pos.
  exact Hx.
  now apply Rge_le.
Qed.

Lemma sqrt_mult :
  forall x y:R, 0 <= x -> 0 <= y -> sqrt (x * y) = sqrt x * sqrt y.
Proof.
  intros x y Hx _.
  now apply sqrt_mult_alt.
Qed.

Lemma sqrt_lt_R0 : forall x:R, 0 < x -> 0 < sqrt x.
Proof.
  intros x H1; apply Rsqr_incrst_0;
    [ rewrite Rsqr_0; rewrite Rsqr_sqrt; [ assumption | left; assumption ]
      | right; reflexivity
      | apply (sqrt_positivity x (Rlt_le 0 x H1)) ].
Qed.

Lemma sqrt_div_alt :
  forall x y : R, 0 < y -> sqrt (x / y) = sqrt x / sqrt y.
Proof.
  intros x y Hy.
  unfold sqrt at 2.
  destruct (Rcase_abs x) as [Hx|Hx].
  unfold Rdiv.
  rewrite Rmult_0_l.
  unfold sqrt.
  destruct (Rcase_abs (x * / y)) as [Hxy|Hxy].
  apply eq_refl.
  elim Rge_not_lt with (1 := Hxy).
  apply Rmult_lt_reg_r with y.
  exact Hy.
  rewrite Rmult_assoc, Rinv_l, Rmult_1_r, Rmult_0_l.
  exact Hx.
  now apply Rgt_not_eq.
  set (Hx' := Rge_le x 0 Hx).
  clearbody Hx'. clear Hx.
  apply Rsqr_inj.
  apply sqrt_pos.
  apply Fourier_util.Rle_mult_inv_pos.
  apply Rsqrt_positivity.
  now apply sqrt_lt_R0.
  rewrite Rsqr_div, 2!Rsqr_sqrt.
  unfold Rsqr.
  now rewrite Rsqrt_Rsqrt.
  now apply Rlt_le.
  now apply Fourier_util.Rle_mult_inv_pos.
  apply Rgt_not_eq.
  now apply sqrt_lt_R0.
Qed.

Lemma sqrt_div :
  forall x y:R, 0 <= x -> 0 < y -> sqrt (x / y) = sqrt x / sqrt y.
Proof.
  intros x y _ H.
  now apply sqrt_div_alt.
Qed.

Lemma sqrt_lt_0_alt :
  forall x y : R, sqrt x < sqrt y -> x < y.
Proof.
  intros x y.
  unfold sqrt at 2.
  destruct (Rcase_abs y) as [Hy|Hy].
  intros Hx.
  elim Rlt_not_le with (1 := Hx).
  apply sqrt_pos.
  set (Hy' := Rge_le y 0 Hy).
  clearbody Hy'. clear Hy.
  unfold sqrt.
  destruct (Rcase_abs x) as [Hx|Hx].
  intros _.
  now apply Rlt_le_trans with R0.
  intros Hxy.
  apply Rsqr_incrst_1 in Hxy ; try apply Rsqrt_positivity.
  unfold Rsqr in Hxy.
  now rewrite 2!Rsqrt_Rsqrt in Hxy.
Qed.

Lemma sqrt_lt_0 : forall x y:R, 0 <= x -> 0 <= y -> sqrt x < sqrt y -> x < y.
Proof.
  intros x y _ _.
  apply sqrt_lt_0_alt.
Qed.

Lemma sqrt_lt_1_alt :
  forall x y : R, 0 <= x < y -> sqrt x < sqrt y.
Proof.
  intros x y (Hx, Hxy).
  apply Rsqr_incrst_0 ; try apply sqrt_pos.
  rewrite 2!Rsqr_sqrt.
  exact Hxy.
  apply Rlt_le.
  now apply Rle_lt_trans with x.
  exact Hx.
Qed.

Lemma sqrt_lt_1 : forall x y:R, 0 <= x -> 0 <= y -> x < y -> sqrt x < sqrt y.
Proof.
  intros x y Hx _ Hxy.
  apply sqrt_lt_1_alt.
  now split.
Qed.

Lemma sqrt_le_0 :
  forall x y:R, 0 <= x -> 0 <= y -> sqrt x <= sqrt y -> x <= y.
Proof.
  intros x y H1 H2 H3;
    generalize
      (Rsqr_incr_1 (sqrt x) (sqrt y) H3 (sqrt_positivity x H1)
        (sqrt_positivity y H2)); intro H4; rewrite (Rsqr_sqrt x H1) in H4;
      rewrite (Rsqr_sqrt y H2) in H4; assumption.
Qed.

Lemma sqrt_le_1_alt :
  forall x y : R, x <= y -> sqrt x <= sqrt y.
Proof.
  intros x y [Hxy|Hxy].
  destruct (Rle_or_lt 0 x) as [Hx|Hx].
  apply Rlt_le.
  apply sqrt_lt_1_alt.
  now split.
  unfold sqrt at 1.
  destruct (Rcase_abs x) as [Hx'|Hx'].
  apply sqrt_pos.
  now elim Rge_not_lt with (1 := Hx').
  rewrite Hxy.
  apply Rle_refl.
Qed.

Lemma sqrt_le_1 :
  forall x y:R, 0 <= x -> 0 <= y -> x <= y -> sqrt x <= sqrt y.
Proof.
  intros x y _ _ Hxy.
  now apply sqrt_le_1_alt.
Qed.

Lemma sqrt_inj : forall x y:R, 0 <= x -> 0 <= y -> sqrt x = sqrt y -> x = y.
Proof.
  intros; cut (Rsqr (sqrt x) = Rsqr (sqrt y)).
  intro; rewrite (Rsqr_sqrt x H) in H2; rewrite (Rsqr_sqrt y H0) in H2;
    assumption.
  rewrite H1; reflexivity.
Qed.

Lemma sqrt_less_alt :
  forall x : R, 1 < x -> sqrt x < x.
Proof.
  intros x Hx.
  assert (Hx1 := Rle_lt_trans _ _ _ Rle_0_1 Hx).
  assert (Hx2 := Rlt_le _ _ Hx1).
  apply Rsqr_incrst_0 ; trivial.
  rewrite Rsqr_sqrt ; trivial.
  rewrite <- (Rmult_1_l x) at 1.
  now apply Rmult_lt_compat_r.
  apply sqrt_pos.
Qed.

Lemma sqrt_less : forall x:R, 0 <= x -> 1 < x -> sqrt x < x.
Proof.
  intros x _.
  apply sqrt_less_alt.
Qed.

Lemma sqrt_more : forall x:R, 0 < x -> x < 1 -> x < sqrt x.
Proof.
  intros x H1 H2;
    generalize (sqrt_lt_1 x 1 (Rlt_le 0 x H1) (Rlt_le 0 1 Rlt_0_1) H2);
      intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x));
        intro H4; elim H4; intros H5 H6; rewrite <- H5; pattern x at 1 in |- *;
          rewrite <- (sqrt_def x (Rlt_le 0 x H1));
            apply (Rmult_lt_compat_l (sqrt x) (sqrt x) 1 (sqrt_lt_R0 x H1) H3).
Qed.

Lemma sqrt_cauchy :
  forall a b c d:R,
    a * c + b * d <= sqrt (Rsqr a + Rsqr b) * sqrt (Rsqr c + Rsqr d).
Proof.
  intros a b c d; apply Rsqr_incr_0_var;
    [ rewrite Rsqr_mult; repeat rewrite Rsqr_sqrt; unfold Rsqr in |- *;
      [ replace ((a * c + b * d) * (a * c + b * d)) with
        (a * a * c * c + b * b * d * d + 2 * a * b * c * d);
        [ replace ((a * a + b * b) * (c * c + d * d)) with
          (a * a * c * c + b * b * d * d + (a * a * d * d + b * b * c * c));
          [ apply Rplus_le_compat_l;
            replace (a * a * d * d + b * b * c * c) with
            (2 * a * b * c * d +
              (a * a * d * d + b * b * c * c - 2 * a * b * c * d));
            [ pattern (2 * a * b * c * d) at 1 in |- *; rewrite <- Rplus_0_r;
              apply Rplus_le_compat_l;
                replace (a * a * d * d + b * b * c * c - 2 * a * b * c * d)
              with (Rsqr (a * d - b * c));
                [ apply Rle_0_sqr | unfold Rsqr in |- *; ring ]
              | ring ]
            | ring ]
          | ring ]
        | apply
          (Rplus_le_le_0_compat (Rsqr c) (Rsqr d) (Rle_0_sqr c) (Rle_0_sqr d))
        | apply
          (Rplus_le_le_0_compat (Rsqr a) (Rsqr b) (Rle_0_sqr a) (Rle_0_sqr b)) ]
      | apply Rmult_le_pos; apply sqrt_positivity; apply Rplus_le_le_0_compat;
        apply Rle_0_sqr ].
Qed.

(************************************************************)
(** * Resolution of [a*X^2+b*X+c=0]                         *)
(************************************************************)

Definition Delta (a:nonzeroreal) (b c:R) : R := Rsqr b - 4 * a * c.

Definition Delta_is_pos (a:nonzeroreal) (b c:R) : Prop := 0 <= Delta a b c.

Definition sol_x1 (a:nonzeroreal) (b c:R) : R :=
  (- b + sqrt (Delta a b c)) / (2 * a).

Definition sol_x2 (a:nonzeroreal) (b c:R) : R :=
  (- b - sqrt (Delta a b c)) / (2 * a).

Lemma Rsqr_sol_eq_0_1 :
  forall (a:nonzeroreal) (b c x:R),
    Delta_is_pos a b c ->
    x = sol_x1 a b c \/ x = sol_x2 a b c -> a * Rsqr x + b * x + c = 0.
Proof.
  intros; elim H0; intro.
  unfold sol_x1 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv in |- *;
    repeat rewrite Rsqr_mult; rewrite Rsqr_plus; rewrite <- Rsqr_neg;
      rewrite Rsqr_sqrt.
  rewrite Rsqr_inv.
  unfold Rsqr in |- *; repeat rewrite Rinv_mult_distr.
  repeat rewrite Rmult_assoc; rewrite (Rmult_comm a).
  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; rewrite Rmult_plus_distr_r.
  repeat rewrite Rmult_assoc.
  pattern 2 at 2 in |- *; rewrite (Rmult_comm 2).
  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r.
  rewrite
    (Rmult_plus_distr_r (- b) (sqrt (b * b - 2 * (2 * (a * c)))) (/ 2 * / a))
    .
  rewrite Rmult_plus_distr_l; repeat rewrite Rplus_assoc.
  replace
  (- b * (sqrt (b * b - 2 * (2 * (a * c))) * (/ 2 * / a)) +
    (b * (- b * (/ 2 * / a)) +
      (b * (sqrt (b * b - 2 * (2 * (a * c))) * (/ 2 * / a)) + c))) with
  (b * (- b * (/ 2 * / a)) + c).
  unfold Rminus in |- *; repeat rewrite <- Rplus_assoc.
  replace (b * b + b * b) with (2 * (b * b)).
  rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r.
  rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc;
    rewrite (Rmult_comm 2).
  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; rewrite (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc;
    rewrite (Rmult_comm 2).
  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm a); rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; rewrite <- Rmult_opp_opp.
  ring.
  apply (cond_nonzero a).
  discrR.
  discrR.
  discrR.
  ring.
  ring.
  discrR.
  apply (cond_nonzero a).
  discrR.
  apply (cond_nonzero a).
  apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
  apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
  apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
  assumption.
  unfold sol_x2 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv in |- *;
    repeat rewrite Rsqr_mult; rewrite Rsqr_minus; rewrite <- Rsqr_neg;
      rewrite Rsqr_sqrt.
  rewrite Rsqr_inv.
  unfold Rsqr in |- *; repeat rewrite Rinv_mult_distr;
    repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm a); repeat rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; unfold Rminus in |- *; rewrite Rmult_plus_distr_r.
  rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc;
    pattern 2 at 2 in |- *; rewrite (Rmult_comm 2).
  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r;
    rewrite
      (Rmult_plus_distr_r (- b) (- sqrt (b * b + - (2 * (2 * (a * c)))))
        (/ 2 * / a)).
  rewrite Rmult_plus_distr_l; repeat rewrite Rplus_assoc.
  rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_involutive.
  replace
  (b * (sqrt (b * b + - (2 * (2 * (a * c)))) * (/ 2 * / a)) +
    (b * (- b * (/ 2 * / a)) +
      (b * (- sqrt (b * b + - (2 * (2 * (a * c)))) * (/ 2 * / a)) + c))) with
  (b * (- b * (/ 2 * / a)) + c).
  repeat rewrite <- Rplus_assoc; replace (b * b + b * b) with (2 * (b * b)).
  rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc;
    rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc;
      rewrite <- Rinv_l_sym.
  rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; rewrite (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; repeat rewrite Rmult_assoc; rewrite (Rmult_comm a);
    rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; rewrite <- Rmult_opp_opp; ring.
  apply (cond_nonzero a).
  discrR.
  discrR.
  discrR.
  ring.
  ring.
  discrR.
  apply (cond_nonzero a).
  discrR.
  discrR.
  apply (cond_nonzero a).
  apply prod_neq_R0; discrR || apply (cond_nonzero a).
  apply prod_neq_R0; discrR || apply (cond_nonzero a).
  apply prod_neq_R0; discrR || apply (cond_nonzero a).
  assumption.
Qed.

Lemma Rsqr_sol_eq_0_0 :
  forall (a:nonzeroreal) (b c x:R),
    Delta_is_pos a b c ->
    a * Rsqr x + b * x + c = 0 -> x = sol_x1 a b c \/ x = sol_x2 a b c.
Proof.
  intros; rewrite (canonical_Rsqr a b c x) in H0; rewrite Rplus_comm in H0;
    generalize
      (Rplus_opp_r_uniq ((4 * a * c - Rsqr b) / (4 * a))
        (a * Rsqr (x + b / (2 * a))) H0); cut (Rsqr b - 4 * a * c = Delta a b c).
  intro;
    replace (- ((4 * a * c - Rsqr b) / (4 * a))) with
    ((Rsqr b - 4 * a * c) / (4 * a)).
  rewrite H1; intro;
    generalize
      (Rmult_eq_compat_l (/ a) (a * Rsqr (x + b / (2 * a)))
        (Delta a b c / (4 * a)) H2);
      replace (/ a * (a * Rsqr (x + b / (2 * a)))) with (Rsqr (x + b / (2 * a))).
  replace (/ a * (Delta a b c / (4 * a))) with
  (Rsqr (sqrt (Delta a b c) / (2 * a))).
  intro;
    generalize (Rsqr_eq (x + b / (2 * a)) (sqrt (Delta a b c) / (2 * a)) H3);
      intro; elim H4; intro.
  left; unfold sol_x1 in |- *;
    generalize
      (Rplus_eq_compat_l (- (b / (2 * a))) (x + b / (2 * a))
        (sqrt (Delta a b c) / (2 * a)) H5);
      replace (- (b / (2 * a)) + (x + b / (2 * a))) with x.
  intro; rewrite H6; unfold Rdiv in |- *; ring.
  ring.
  right; unfold sol_x2 in |- *;
    generalize
      (Rplus_eq_compat_l (- (b / (2 * a))) (x + b / (2 * a))
        (- (sqrt (Delta a b c) / (2 * a))) H5);
      replace (- (b / (2 * a)) + (x + b / (2 * a))) with x.
  intro; rewrite H6; unfold Rdiv in |- *; ring.
  ring.
  rewrite Rsqr_div.
  rewrite Rsqr_sqrt.
  unfold Rdiv in |- *.
  repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm (/ a)).
  rewrite Rmult_assoc.
  rewrite <- Rinv_mult_distr.
  replace (2 * (2 * a) * a) with (Rsqr (2 * a)).
  reflexivity.
  ring_Rsqr.
  rewrite <- Rmult_assoc; apply prod_neq_R0;
    [ discrR | apply (cond_nonzero a) ].
  apply (cond_nonzero a).
  assumption.
  apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
  symmetry  in |- *; apply Rmult_1_l.
  apply (cond_nonzero a).
  unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse.
  rewrite Ropp_minus_distr.
  reflexivity.
  reflexivity.
Qed.


Require Import Iron.Data.List.Base.
Require Import Iron.Tactics.

(********************************************************************)
(** Lemmas: firstn *)

(* If we take zero elements from a list,
   then the resulting list is empty *)
Lemma firstn_zero
 :  forall A (xx: list A)
 ,  firstn O xx = nil.
Proof.
 intros. auto.
Qed.
Hint Resolve firstn_zero.

(* Up-lemma for get_take.
   If a list has an element at a particular index
   if we take the elements from the list at least up to that index
   then the resulting list still has the original element at the
   same point. *)
Lemma get_firstn_succ
 :  forall A n (xx: list A)
 ,  get n (firstn (S n) xx) = get n xx.
Proof.
 intros. gen n.
 induction xx.
  simpl. auto.
  destruct n.
   auto.
   rewrite <- get_rewind. rewrite <- IHxx. auto.
Qed.
Hint Resolve get_firstn_succ.

(* If a list has an element at a particular index
   if we take the elements from the list at least up to that index
   then the resulting list still has the original element at the
   same point. *)
Lemma get_firstn
 :  forall A m n (xx: list A) (x: A)
 ,  m > n
 -> get n xx            = Some x
 -> get n (firstn m xx) = Some x.
Proof.
 intros. gen n xx.
 induction m; intros.
  inverts H.
  induction n.
   destruct xx.
    false.
    simpl in H0. inverts H0. auto.
   destruct xx.
    false.
    simpl in H0. simpl. apply IHm. omega. trivial.
Qed.
Hint Resolve get_firstn.

(* If we take some elements from the front of a list,
   and there is still an element at a particular index
   then the number of elements we took was more than that index. *)
Lemma get_firstn_more
 :  forall A m n (xx: list A) (x: A)
 ,  get n (firstn m xx) = Some x -> m > n.
Proof.
 intros. gen n xx.
 induction m; intros.
  false.
  destruct xx.
   false.
   simpl in H. destruct n.
    auto.
    apply IHm in H. omega.
Qed.
Hint Resolve get_firstn_more.


Require Import Coq.Strings.String Coq.omega.Omega Coq.Lists.List Coq.Logic.FunctionalExtensionality Coq.Sets.Ensembles
        Fiat.Computation Fiat.ADT Fiat.ADTRefinement Fiat.ADTNotation Fiat.ADTRefinement.BuildADTRefinements
        Examples.CacheADT.KVEnsembles.

Open Scope string_scope.

Section CacheSpec.

  Variable Key : Type.
  Variable Value : Type.

  Definition CacheSig : ADTSig :=
    ADTsignature {
        Constructor "EmptyCache"  : unit -> rep,
        Method "AddKey" : rep x (Key * Value) -> rep x bool,
        Method "UpdateKey" : rep x (Key * (Value -> Value)) -> rep x bool,
        Method "LookupKey"   : rep x Key -> rep x (option Value)
  }.

  Definition CacheSpec : ADT CacheSig :=
    ADTRep (Ensemble (Key * Value)) {
        Def Constructor "EmptyCache" (_ : unit) : rep :=
          ret (fun _ => False),
        meth "AddKey" (r : rep, kv : Key * Value) : bool :=
            { r' | (SubEnsembleInsert kv r (fst r')) /\
                   ((usedKey r (fst kv) /\ snd r' = false) \/
                    (~ usedKey r (fst kv) /\ snd r' = true))},
        meth "UpdateKey" (r : rep, kv : Key * (Value -> Value)) : bool :=
              { r' |
                (Same_set _ (fst r') (EnsembleUpdateKey (fst kv) r (snd kv)))
                 /\ ((usedKey r (fst kv) /\ snd r' = true) \/
                     (~ usedKey r (fst kv) -> snd r' = false))},
        meth "LookupKey" (r : rep, k : Key) : option Value :=
                v <- {v | ValidLookup r k v};
        ret (r, v)
      }.

End CacheSpec.


From Classes Require Import EqualDec.

Axiom int : Type.
Axiom toNat : int -> nat.
Axiom toNat_inj : forall x y, toNat x = toNat y -> x = y.

Instance int_eqdec : EqualDec int.
Proof.
  apply (inj_eq_dec toNat); auto using toNat_inj.
Defined.


Inductive boolP : Prop :=
| trueP : boolP
| falseP : boolP.

Fail Check boolP_rect.

Inductive True : Prop := I : True.

Inductive False : Prop :=.

Inductive Empty_set : Set :=.

Fail Inductive Large_set : Set :=
  large_constr : forall A : Set, A -> Large_set.

Inductive smallunitProp : Prop :=
| onlyProps : True -> smallunitProp.

Check smallunitProp_rect.

Inductive nonsmallunitProp : Prop :=
| notonlyProps : nat -> nonsmallunitProp.

Fail Check nonsmallunitProp_rect.
Set Printing Universes.
Inductive inferProp :=
| hasonlyProps : True -> nonsmallunitProp -> inferProp.

Check (inferProp : Prop).

Inductive inferSet :=
| hasaset : nat -> True -> nonsmallunitProp -> inferSet.

Fail Check (inferSet : Prop).

Check (inferSet : Set).

Inductive inferLargeSet :=
| hasalargeset : Set -> True -> nonsmallunitProp -> inferLargeSet.

Fail Check (inferLargeSet : Set).

Inductive largeProp : Prop := somelargeprop : Set -> largeProp.

Inductive comparison : Set :=
  | Eq : comparison
  | Lt : comparison
  | Gt : comparison.

Inductive CompareSpecT (Peq Plt Pgt : Prop) : comparison -> Type :=
 | CompEqT : Peq -> CompareSpecT Peq Plt Pgt Eq
 | CompLtT : Plt -> CompareSpecT Peq Plt Pgt Lt
 | CompGtT : Pgt -> CompareSpecT Peq Plt Pgt Gt.

Inductive color := Red | Black.

Inductive option (A : Type) : Type :=
| None : option A
| Some : A -> option A.


(** Coq coding by choukh, Oct 2021 **)

Require Import BBST.Axiom.Meta.
Require Import BBST.Axiom.Separation.
Require Import BBST.Definition.Include.

Require BBST.Axiom.Extensionality.
Require BBST.Axiom.Union.
Require BBST.Axiom.Pairing.
Require BBST.Definition.Emptyset.
Require BBST.Definition.Singleton.

Axiom 大幂集 : 集合 → 集合.
Axiom 幂集公理 : ∀ A X, X ⊆ A → X ∈ 大幂集 A.

Definition 幂集 := λ A, {B ∊ 大幂集 A | B ⊆ A}.
Notation "'𝒫' A" := (幂集 A) (at level 9, right associativity, format "'𝒫'  A") : 集合域.

Lemma 幂集介入 : ∀ A B, B ⊆ A → B ∈ 𝒫 A.
Proof. intros. apply 分离介入; auto. now apply 幂集公理. Qed.

Lemma 幂集除去 : ∀ A B, B ∈ 𝒫 A → B ⊆ A.
Proof. intros. apply 分离之条件 in H; auto. Qed.

Global Opaque 幂集.

Lemma 任意集合都属于自身的幂集 : ∀ A, A ∈ 𝒫 A.
Proof. intros. now apply 幂集介入. Qed.
Global Hint Immediate 任意集合都属于自身的幂集 : core.

Lemma 幂集保持包含关系 : ∀ A B, A ⊆ B → 𝒫 A ⊆ 𝒫 B.
Proof.
  intros * H x Hx. apply 幂集介入.
  eapply 包含的传递性. 2: apply H. now apply 幂集除去 in Hx.
Qed.

Fact 幂集是单射: ∀ A B, 𝒫 A = 𝒫 B → A = B.
Proof.
  intros. apply 包含的反对称性.
  - apply 幂集除去. rewrite <- H; auto.
  - apply 幂集除去. rewrite H; auto.
Qed.

Import BBST.Definition.Emptyset.
Global Hint Immediate 空集是任意集合的子集 : core.

Lemma 空集属于任意幂集 : ∀ A, ∅ ∈ 𝒫 A.
Proof. intros. apply 幂集介入; auto. Qed.

Lemma 只有空集是空集的幂集 : ∀ x, x ∈ 𝒫 ∅ ↔ x = ∅.
Proof.
  split; intros.
  - apply 含于空集即为空集. now apply 幂集除去.
  - subst. apply 空集属于任意幂集.
Qed.

Import BBST.Axiom.Union.

Lemma 并集之幂 : ∀ A, A ⊆ 𝒫 ⋃ A.
Proof.
  intros A x H. apply 幂集介入. now apply 并得父集.
Qed.

Import BBST.Axiom.Extensionality.

Lemma 幂集之并 : ∀ A, ⋃ (𝒫 A) = A.
Proof.
  intros. 外延.
  - apply 并集除去 in H as [y [Hy Hx]].
    apply 幂集除去 in Hy; auto.
  - eapply 并集介入; auto.
Qed.

Import BBST.Axiom.Pairing.
Import BBST.Definition.Singleton.

Lemma 空集之幂 : 𝒫 ∅ = {∅,}.
Proof.
  外延.
  - apply 幂集除去 in H.
    apply 含于空集即为空集 in H. subst. auto.
  - apply 单集除去 in H. subst. auto.
Qed.

Lemma 单集之幂 : ∀ a, 𝒫 {a,} = {∅, {a,}}.
Proof.
  intros. 外延.
  - apply 幂集除去 in H.
    apply 单集的子集是空集或该单集 in H as []; subst; auto.
  - apply 配对除去 in H as []; subst; auto.
    apply 空集属于任意幂集.
Qed.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 14: Hoare Logic: Verifying Imperative Programs
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap.

(** * Syntax and semantics of a simple imperative language *)

(* Here's some appropriate syntax for expressions (side-effect-free) of a simple
 * imperative language with a mutable memory. *)
Inductive exp :=
| Const (n : nat)
| Var (x : string)
| Read (e1 : exp)
| Plus (e1 e2 : exp)
| Minus (e1 e2 : exp)
| Mult (e1 e2 : exp).

(* Those were the expressions of numeric type.  Here are the Boolean
 * expressions. *)
Inductive bexp :=
| Equal (e1 e2 : exp)
| Less (e1 e2 : exp).

Definition heap := fmap nat nat.
Definition valuation := fmap var nat.
Definition assertion := heap -> valuation -> Prop.

(* Here's the syntax of side-effecting commands, where we attach an assertion to
 * every "while" loop, for reasons that should become clear later.  The
 * assertion is ignored in the operational semantics! *)
Inductive cmd :=
| Skip
| Assign (x : var) (e : exp)
| Write (e1 e2 : exp)
| Seq (c1 c2 : cmd)
| If_ (be : bexp) (then_ else_ : cmd)
| While_ (inv : assertion) (be : bexp) (body : cmd)

(* And one more, which we'll use to characterize program correctness more
 * simply: *)
| Assert (a : assertion).

(* Shorthand notation for looking up in a finite map, returning zero if the key
 * is not found *)
Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).

(* Start of expression semantics: meaning of expressions *)
Fixpoint eval (e : exp) (h : heap) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x => v $! x
  | Read e1 => h $! eval e1 h v
  | Plus e1 e2 => eval e1 h v + eval e2 h v
  | Minus e1 e2 => eval e1 h v - eval e2 h v
  | Mult e1 e2 => eval e1 h v * eval e2 h v
  end.

(* Meaning of Boolean expressions *)
Definition beval (b : bexp) (h : heap) (v : valuation) : bool :=
  match b with
  | Equal e1 e2 => if eval e1 h v ==n eval e2 h v then true else false
  | Less e1 e2 => if eval e2 h v <=? eval e1 h v then false else true
  end.

(* A big-step operational semantics for commands *)
Inductive exec : heap -> valuation -> cmd -> heap -> valuation -> Prop :=
| ExSkip : forall h v,
  exec h v Skip h v
| ExAssign : forall h v x e,
  exec h v (Assign x e) h (v $+ (x, eval e h v))
| ExWrite : forall h v e1 e2,
  exec h v (Write e1 e2) (h $+ (eval e1 h v, eval e2 h v)) v
| ExSeq : forall h1 v1 c1 h2 v2 c2 h3 v3,
  exec h1 v1 c1 h2 v2
  -> exec h2 v2 c2 h3 v3
  -> exec h1 v1 (Seq c1 c2) h3 v3
| ExIfTrue : forall h1 v1 b c1 c2 h2 v2,
  beval b h1 v1 = true
  -> exec h1 v1 c1 h2 v2
  -> exec h1 v1 (If_ b c1 c2) h2 v2
| ExIfFalse : forall h1 v1 b c1 c2 h2 v2,
  beval b h1 v1 = false
  -> exec h1 v1 c2 h2 v2
  -> exec h1 v1 (If_ b c1 c2) h2 v2
| ExWhileFalse : forall I h v b c,
  beval b h v = false
  -> exec h v (While_ I b c) h v
| ExWhileTrue : forall I h1 v1 b c h2 v2 h3 v3,
  beval b h1 v1 = true
  -> exec h1 v1 c h2 v2
  -> exec h2 v2 (While_ I b c) h3 v3
  -> exec h1 v1 (While_ I b c) h3 v3

(* Assertions execute only when they are true.  They provide a way to embed
 * proof obligations within programs. *)
| ExAssert : forall h v (a : assertion),
  a h v
  -> exec h v (Assert a) h v.

(** * Hoare logic *)

(* Here's an inductive predicate capturing a class of *proved* specifications
 * for commands.  The intuition is that, when [hoare_triple P c Q], we know
 * that, when we start [c] in a state satisfying [P], if [c] finishes, its final
 * state satisfies [Q]. *)

Inductive hoare_triple : assertion -> cmd -> assertion -> Prop :=
| HtSkip : forall P, hoare_triple P Skip P
| HtAssign : forall (P : assertion) x e,
  hoare_triple P (Assign x e) (fun h v => exists v', P h v' /\ v = v' $+ (x, eval e h v'))
| HtWrite : forall (P : assertion) (e1 e2 : exp),
  hoare_triple P (Write e1 e2) (fun h v => exists h', P h' v /\ h = h' $+ (eval e1 h' v, eval e2 h' v))
| HtSeq : forall (P Q R : assertion) c1 c2,
  hoare_triple P c1 Q
  -> hoare_triple Q c2 R
  -> hoare_triple P (Seq c1 c2) R
| HtIf : forall (P Q1 Q2 : assertion) b c1 c2,
  hoare_triple (fun h v => P h v /\ beval b h v = true) c1 Q1
  -> hoare_triple (fun h v => P h v /\ beval b h v = false) c2 Q2
  -> hoare_triple P (If_ b c1 c2) (fun h v => Q1 h v \/ Q2 h v)
| HtWhile : forall (I P : assertion) b c,
  (forall h v, P h v -> I h v)
  -> hoare_triple (fun h v => I h v /\ beval b h v = true) c I
  -> hoare_triple P (While_ I b c) (fun h v => I h v /\ beval b h v = false)
| HtAssert : forall P I : assertion,
  (forall h v, P h v -> I h v)
  -> hoare_triple P (Assert I) P
| HtConsequence : forall (P Q P' Q' : assertion) c,
  hoare_triple P c Q
  -> (forall h v, P' h v -> P h v)
  -> (forall h v, Q h v -> Q' h v)
  -> hoare_triple P' c Q'.

(* Let's prove that the intuitive description given above really applies to this
 * predicate.  First, a helper lemma which we will need in the main proof below.
 * It says that if the loop body preserves the invariant, and executing the loop
 * terminates, then after executing the loop, the invariant still holds, and the
 * loop condition is false. *)
Lemma hoare_triple_big_step_while: forall (I : assertion) b c,
  (forall h v h' v', exec h v c h' v'
                     -> I h v
                     -> beval b h v = true
                     -> I h' v')
  -> forall h v h' v', exec h v (While_ I b c) h' v'
                       -> I h v
                       -> I h' v' /\ beval b h' v' = false.
Proof.
  induct 2; eauto.
Qed.

(* That main theorem statement literally translates our intuitive description of
 * [hoare_triple] from above. *)
Theorem hoare_triple_big_step : forall pre c post,
    hoare_triple pre c post
    -> forall h v h' v', exec h v c h' v'
                         -> pre h v
                         -> post h' v'.
Proof.
  induct 1; eauto; invert 1; eauto.

  simplify.
  eapply hoare_triple_big_step_while; eauto.
Qed.

(* BEGIN syntax macros that won't be explained *)
Coercion Const : nat >-> exp.
Coercion Var : string >-> exp.
(*Declare Scope cmd_scope.*)
Notation "*[ e ]" := (Read e) : cmd_scope.
Infix "+" := Plus : cmd_scope.
Infix "-" := Minus : cmd_scope.
Infix "*" := Mult : cmd_scope.
Infix "=" := Equal : cmd_scope.
Infix "<" := Less : cmd_scope.
Definition set (dst src : exp) : cmd :=
  match dst with
  | Read dst' => Write dst' src
  | Var dst' => Assign dst' src
  | _ => Assign "Bad LHS" 0
  end.
Infix "<-" := set (no associativity, at level 70) : cmd_scope.
Infix ";;" := Seq (right associativity, at level 75) : cmd_scope.
Notation "'when' b 'then' then_ 'else' else_ 'done'" := (If_ b then_ else_) (at level 75, b at level 0).
Notation "{{ I }} 'while' b 'loop' body 'done'" := (While_ I b body) (at level 75).
Notation "'assert' {{ I }}" := (Assert I) (at level 75).
Delimit Scope cmd_scope with cmd.
(* END macros *)

(* We should draw some attention to the next notation, which defines special
 * lambdas for writing assertions. *)
Notation "h & v ~> e" := (fun h v => e%nat%type) (at level 85, v at level 0).

(* And here's the classic notation for Hoare triples. *)
Notation "{{ P }} c {{ Q }}" := (hoare_triple P c%cmd Q) (at level 90, c at next level).

(* Special case of consequence: keeping the precondition; only changing the
 * postcondition. *)
Lemma HtStrengthenPost : forall (P Q Q' : assertion) c,
  hoare_triple P c Q
  -> (forall h v, Q h v -> Q' h v)
  -> hoare_triple P c Q'.
Proof.
  simplify; eapply HtConsequence; eauto.
Qed.

(* Finally, three tactic definitions that we won't explain.  The overall tactic
 * [ht] tries to prove Hoare triples, essentially by rote application of the
 * rules.  Some other obligations are generated, generally of implications
 * between assertions, and [ht] also makes a best effort to solve those. *)

Ltac ht1 :=
  match goal with
  | [  |- {{ _ }} _ {{ ?P }} ] =>
    tryif is_evar P then
      apply HtSkip || apply HtAssign || apply HtWrite || eapply HtSeq
      || eapply HtIf || eapply HtWhile || eapply HtAssert
    else
      eapply HtStrengthenPost
  end.

Ltac t := cbv beta; propositional; subst;
          repeat match goal with
                 | [ H : ex _ |- _ ] => invert H; propositional; subst
                 end;
          simplify;
          repeat match goal with
                 | [ _ : context[?a <=? ?b] |- _ ] => destruct (a <=? b); try discriminate
                 | [ H : ?E = ?E |- _ ] => clear H
                 end; simplify; propositional; auto; try equality; try linear_arithmetic.

Ltac ht := simplify; repeat ht1; t.

(** * Some examples of verified programs *)

(** ** Swapping the values in two variables *)

(* First, let's prove it with more manual applications of the Hoare-logic
 * rules. *)
Theorem swap_ok : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    "tmp" <- "x";;
    "x" <- "y";;
    "y" <- "tmp"
  {{_&v ~> v $! "x" = b /\ v $! "y" = a}}.
Proof.
  simplify.
  eapply HtSeq.
  apply HtAssign.
  eapply HtSeq.
  apply HtAssign.
  eapply HtStrengthenPost.
  apply HtAssign.
  simplify.
  t.
Qed.

(* We can also automate the proof easily. *)
Theorem swap_ok_snazzy : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    "tmp" <- "x";;
    "x" <- "y";;
    "y" <- "tmp"
  {{_&v ~> v $! "x" = b /\ v $! "y" = a}}.
Proof.
  ht.
Qed.

(** ** Computing the maximum of two variables *)

Theorem max_ok : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    when "x" < "y" then
      "m" <- "y"
    else
      "m" <- "x"
    done
  {{_&v ~> v $! "m" = max a b}}.
Proof.
  simplify.
  eapply HtStrengthenPost.
  apply HtIf.
  apply HtAssign.
  apply HtAssign.
  simplify.
  t.
Qed.

Theorem max_ok_snazzy : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    when "x" < "y" then
      "m" <- "y"
    else
      "m" <- "x"
    done
  {{_&v ~> v $! "m" = max a b}}.
Proof.
  ht.
Qed.

(** ** Iterative factorial *)

(* These two rewrite rules capture the definition of functional [fact], in
 * exactly the form useful in our Hoare-logic proof. *)
Lemma fact_base : forall n,
  n = 0
  -> fact n = 1.
Proof.
  simplify; subst; auto.
Qed.

Local Hint Rewrite <- minus_n_O.

Lemma fact_rec : forall n,
  n > 0
  -> fact n = n * fact (n - 1).
Proof.
  simplify; cases n; simplify; linear_arithmetic.
Qed.

Local Hint Rewrite fact_base fact_rec using linear_arithmetic.

(* Note the careful choice of loop invariant below.  It may look familiar from
 * earlier chapters' proofs! *)
Theorem fact_ok : forall n,
  {{_&v ~> v $! "n" = n}}
    "acc" <- 1;;
    {{_&v ~> v $! "acc" * fact (v $! "n") = fact n}}
    while 0 < "n" loop
      "acc" <- "acc" * "n";;
      "n" <- "n" - 1
    done
  {{_&v ~> v $! "acc" = fact n}}.
Proof.
  simplify.
  eapply HtSeq.
  apply HtAssign.
  eapply HtStrengthenPost.
  eapply HtWhile.
  simplify.
  t.
  eapply HtSeq.
  apply HtAssign.
  eapply HtStrengthenPost.
  apply HtAssign.
  simplify.
  t.
  simplify.
  t.
Qed.

Theorem fact_ok_snazzy : forall n,
  {{_&v ~> v $! "n" = n}}
    "acc" <- 1;;
    {{_&v ~> v $! "acc" * fact (v $! "n") = fact n}}
    while 0 < "n" loop
      "acc" <- "acc" * "n";;
      "n" <- "n" - 1
    done
  {{_&v ~> v $! "acc" = fact n}}.
Proof.
  ht.
Qed.

(** ** Selection sort *)

(* This is our one example of a program reading/writing memory, which holds the
 * representation of an array that we want to sort in-place. *)

(* One simple lemma turns out to be helpful to guide [eauto] properly. *)
Lemma leq_f : forall A (m : fmap A nat) x y,
  x = y
  -> m $! x <= m $! y.
Proof.
  ht.
Qed.

Local Hint Resolve leq_f : core.
Local Hint Extern 1 (@eq nat _ _) => linear_arithmetic : core.
Local Hint Extern 1 (_ < _) => linear_arithmetic : core.
Local Hint Extern 1 (_ <= _) => linear_arithmetic : core.
(* We also register [linear_arithmetic] as a step to try during proof search. *)

(* These invariants are fairly hairy, but probably the best way to understand
 * them is just to spend a while reading them.  They generally talk about
 * sortedness of subsets of the array.  See the final postcondition for how we
 * interpret a part of memory as an array.  Also note that we only prove here
 * that the final array is sorted, *not* that it's a permutation of the original
 * array!  (Exercise for the reader?  I'm not sure how much work it would
 * take.) *)
Theorem selectionSort_ok :
  {{_&_ ~> True}}
    "i" <- 0;;
    {{h&v ~> (forall i j, i < j < v $! "i" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j))
        /\ (forall i j, i < v $! "i" -> v $! "i" <= j < v $! "n" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j)) }}
    while "i" < "n" loop
      "j" <- "i"+1;;
      "best" <- "i";;
      {{h&v ~> v $! "i" < v $! "j" <= v $! "n"
         /\ v $! "i" <= v $! "best" < v $! "n"
         /\ (forall k, v $! "i" <= k < v $! "j" -> h $! (v $! "a" + v $! "best") <= h $! (v $! "a" + k))
         /\ (forall i j, i < j < v $! "i" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j))
         /\ (forall i j, i < v $! "i" -> v $! "i" <= j < v $! "n" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j)) }}
      while "j" < "n" loop
        when *["a" + "j"] < *["a" + "best"] then
          "best" <- "j"
        else
          Skip
        done;;
        "j" <- "j" + 1
      done;;
      "tmp" <- *["a" + "best"];;
      *["a" + "best"] <- *["a" + "i"];;
      *["a" + "i"] <- "tmp";;
      "i" <- "i" + 1
    done
  {{h&v ~> forall i j, i < j < v $! "n" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j)}}.
Proof.
  ht; repeat match goal with
             | [ |- context[_ $+ (?a + ?x, _) $! (?a + ?y)] ] =>
               cases (x ==n y); ht
             end.

  cases (k ==n x0 $! "j"); ht.
  specialize (H k); ht.

  cases (k ==n x $! "j"); ht.
Qed.

(** * An alternative correctness theorem for Hoare logic, with small-step semantics *)

(* In case you were worried that this chapter is too far removed from the
 * pattern of program reasoning we've seen recur again and again, help is here!
 * We can also characterize Hoare triples in terms of invariants of transition
 * systems.  To start with, here's a small-step semantics for our running
 * language. *)
Inductive step : heap * valuation * cmd -> heap * valuation * cmd -> Prop :=
| StAssign : forall h v x e,
  step (h, v, Assign x e) (h, v $+ (x, eval e h v), Skip)
| StWrite : forall h v e1 e2,
  step (h, v, Write e1 e2) (h $+ (eval e1 h v, eval e2 h v), v, Skip)
| StStepSkip : forall h v c,
  step (h, v, Seq Skip c) (h, v, c)
| StStepRec : forall h1 v1 c1 h2 v2 c1' c2,
  step (h1, v1, c1) (h2, v2, c1')
  -> step (h1, v1, Seq c1 c2) (h2, v2, Seq c1' c2)
| StIfTrue : forall h v b c1 c2,
  beval b h v = true
  -> step (h, v, If_ b c1 c2) (h, v, c1)
| StIfFalse : forall h v b c1 c2,
  beval b h v = false
  -> step (h, v, If_ b c1 c2) (h, v, c2)
| StWhileFalse : forall I h v b c,
  beval b h v = false
  -> step (h, v, While_ I b c) (h, v, Skip)
| StWhileTrue : forall I h v b c,
  beval b h v = true
  -> step (h, v, While_ I b c) (h, v, Seq c (While_ I b c))
| StAssert : forall h v (a : assertion),
  a h v
  -> step (h, v, Assert a) (h, v, Skip).

Local Hint Constructors step : core.

Definition trsys_of (st : heap * valuation * cmd) := {|
  Initial := {st};
  Step := step
|}.

(* We'll characterize *unstuckness* in roughly the same way as we did for
 * lambda-calculus type soundness: the program is done (reached [Skip]) or can
 * take a step. *)
Definition unstuck (st : heap * valuation * cmd) :=
  snd st = Skip
  \/ exists st', step st st'.

(* A convenient property of Hoare triples: they rule out stuckness, regardless
 * of the specs we choose, so long as the precondition accurately describes the
 * real execution state!  Note that the only real possibility for stuckness in
 * the semantics is via [Assert], which is why we included it.  We reduce
 * arbitrary correctness checks, on intermediate program states, to stuckness or
 * lack thereof in program execution. *)
Lemma hoare_triple_unstuck : forall P c Q,
  {{P}} c {{Q}}
  -> forall h v, P h v
                 -> unstuck (h, v, c).
Proof.
  induct 1; unfold unstuck; simplify; propositional; eauto.

  apply IHhoare_triple1 in H1.
  unfold unstuck in H1; simplify; first_order; subst; eauto.
  cases x.
  cases p.
  eauto.

  cases (beval b h v); eauto.

  cases (beval b h v); eauto.

  apply H0 in H2.
  apply IHhoare_triple in H2.
  unfold unstuck in H2; simplify; first_order.
Qed.

(* Another basic property: [Skip] has no effect on program state, and the set of
 * derivable specs for [Skip] reflects that fact. *)
Lemma hoare_triple_Skip : forall P Q,
  {{P}} Skip {{Q}}
  -> forall h v, P h v -> Q h v.
Proof.
  induct 1; auto.
Qed.

(* Finally, our main inductive proof: small steps preserve the existence of
 * Hoare triples.  We even give the concrete specification for the new command
 * [c'] that was stepped to.  It keeps the old postcondition, and we give it a
 * very specific precondition saying "the state is exactly this." *)
Lemma hoare_triple_step : forall P c Q,
  {{P}} c {{Q}}
  -> forall h v h' v' c',
      step (h, v, c) (h', v', c')
      -> P h v
      -> {{h''&v'' ~> h'' = h' /\ v'' = v'}} c' {{Q}}.
Proof.
  induct 1.

  invert 1.

  invert 1; ht; eauto.

  invert 1; ht; eauto.

  invert 1; simplify.

  eapply HtConsequence; eauto.
  propositional; subst.
  eapply hoare_triple_Skip; eauto.

  econstructor; eauto.

  invert 1; simplify.
  eapply HtConsequence; eauto; equality.
  eapply HtConsequence; eauto; equality.

  invert 1; simplify.
  eapply HtConsequence with (P := h'' & v'' ~> h'' = h' /\ v'' = v').
  apply HtSkip.
  auto.
  simplify; propositional; subst; eauto.

  econstructor.
  eapply HtConsequence; eauto.
  simplify; propositional; subst; eauto.
  econstructor; eauto.

  invert 1; simplify.
  eapply HtConsequence; eauto.
  econstructor.
  simplify; propositional; subst; eauto.

  simplify.
  eapply HtConsequence.
  eapply IHhoare_triple; eauto.
  simplify; propositional; subst; eauto.
  auto.
Qed.

(* Oh, what a coincidence! ;-)  As with type-safety proofs, we find that the
 * reasonably intuitive properties we just proved are precisely the hard parts
 * of a standard proof by invariant strengthening and invariant induction. *)
Theorem hoare_triple_invariant : forall P c Q h v,
  {{P}} c {{Q}}
  -> P h v
  -> invariantFor (trsys_of (h, v, c)) unstuck.
Proof.
  simplify.
  apply invariant_weaken with (invariant1 := fun st => {{h&v ~> h = fst (fst st)
                                                           /\ v = snd (fst st)}}
                                                         snd st
                                                       {{_&_ ~> True}}).

  apply invariant_induction; simplify.

  propositional; subst; simplify.
  eapply HtConsequence; eauto.
  equality.

  cases s.
  cases s'.
  cases p.
  cases p0.
  simplify.
  eapply hoare_triple_step; eauto.
  simplify; auto.

  simplify.
  cases s.
  cases p.
  simplify.
  eapply hoare_triple_unstuck; eauto.
  simplify; auto.
Qed.

(* A very simple example, just to show all this in action *)
Definition forever := (
  "i" <- 1;;
  "n" <- 1;;
  {{h&v ~> v $! "i" > 0}}
  while 0 < "i" loop
    "i" <- "i" * 2;;
    "n" <- "n" + "i";;
    assert {{h&v ~> v $! "n" >= 1}}
  done;;

  assert {{_&_ ~> False}}
  (* Note that this last assertion implies that the program never terminates! *)
)%cmd.

Theorem forever_ok : {{_&_ ~> True}} forever {{_&_ ~> False}}.
Proof.
  ht.
Qed.

Theorem forever_invariant : invariantFor (trsys_of ($0, $0, forever)) unstuck.
Proof.
  eapply hoare_triple_invariant.
  apply forever_ok.
  simplify; trivial.
Qed.