(**************************************************************************
* TLC: A library for Coq                                                  *
* Sorted lists                                                            *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
Require Import LibTactics LibLogic LibRelation LibWf LibList
 LibOrder LibNat.

(* ********************************************************************** *)
(** * Permutations of lists *)

Section Permutation.
Variable A : Type.

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

(** We could define permutation in terms of multisets,
    but this would impose additional constraints on the
    type of elements. So instead, we use a definition
    in terms of permutation of two inner segment of lists,
    taking the reflexive-transitive closure. *)

Inductive permut_one : list A -> list A -> Prop :=
  | permut_one_intro : forall l1 l2 l3 l4,
      permut_one (l1++l2++l3++l4) (l1++l3++l2++l4).

Hint Constructors permut_one.

Definition permut := rtclosure permut_one.

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

(** Permutation is an equivalence *)

Lemma permut_refl : forall l,
  permut l l.
Proof using. intros. apply rtclosure_refl. Qed.

Lemma permut_sym : forall l1 l2,
  permut l1 l2 -> permut l2 l1.
Proof using.
  intros. induction H.
  apply permut_refl.
  applys rtclosure_last. apply IHrtclosure. inverts~ H.
Qed.

Lemma permut_trans : forall l2 l1 l3,
  permut l1 l2 -> permut l2 l3 -> permut l1 l3.
Proof using. intros. apply* rtclosure_trans. Qed.

(** Permutation is a congruence with respect to [++] and [::] *)

Lemma permut_flip : forall l1 l2,
  permut (l1++l2) (l2++l1).
Proof using.
  intros. lets: (permut_one_intro nil l1 l2 nil).
  rew_app in *. apply~ rtclosure_once.
Qed.

Lemma permut_app_l : forall l1 l1' l2,
  permut l1 l1' ->
  permut (l1 ++ l2) (l1' ++ l2).
Proof using.
  introv H. gen l2. induction H; intros.
  apply permut_refl.
  specializes IHrtclosure l2. inverts H.
   rew_app in *. eapply permut_trans.
   applys* rtclosure_step. apply permut_refl.
Qed.

Lemma permut_app_r : forall l1 l2 l2',
  permut l2 l2' ->
  permut (l1 ++ l2) (l1 ++ l2').
Proof using.
  introv H. gen l1. induction H; intros.
  apply permut_refl.
  specializes IHrtclosure l1. inverts H.
   rewrite <- app_assoc in *. eapply permut_trans.
   applys* rtclosure_step. apply permut_refl.
Qed.

Lemma permut_app_lr : forall l1 l1' l2 l2',
  permut l1 l1' -> permut l2 l2' ->
  permut (l1 ++ l2) (l1' ++ l2').
Proof using.
  intros. applys rtclosure_trans.
  sapply* permut_app_l.
  apply* permut_app_r.
Qed.

Lemma permut_cons : forall x l1 l1',
  permut l1 l1' ->
  permut (x::l1) (x::l1').
Proof using.
  intros. lets: (@permut_app_r (x::nil) _ _ H).
  rew_app in *. auto.
Qed.

(** Permutation are stable through list reversal *)

Lemma permut_rev : forall l,
  permut l (rev l).
Proof using.
  induction l. apply permut_refl. rew_rev.
  lets: (@permut_flip (a::nil) (rev l)). rew_app in *.
  apply~ (@permut_trans (a::rev l)). apply~ permut_cons.
Qed.

(** Properties of elements are preserved by permutation *)

Lemma Forall_permut_one : forall (P:A->Prop) l1 l2,
  Forall P l1 -> permut_one l1 l2 -> Forall P l2.
Proof using.
  introv F Per. inverts Per.
  lets F0 F345: (Forall_app_inv _ _ F).
  lets F3 F45: (Forall_app_inv _ _ F345).
  lets F4 F5: (Forall_app_inv _ _ F45).
  apply~ Forall_app. apply~ Forall_app. apply~ Forall_app.
Qed.

Lemma Forall_permut : forall (P:A->Prop) l1 l2,
  Forall P l1 -> permut l1 l2 -> Forall P l2.
Proof using.
  introv F1 Per. gen F1. induction Per.
  auto.
  autos* Forall_permut_one.
Qed.

End Permutation.

Hint Resolve permut_refl permut_flip
             permut_app_lr permut_cons.

(* ---------------------------------------------------------------------- *)
(** ** Permutation tactic *)

Section PermutationTactic.
Variable A : Type.
Implicit Types l : list A.

Lemma permut_get_1 : forall l1 l2,
  permut (l1 ++ l2) (l1 ++ l2).
Proof using. intros. apply permut_refl. Qed.
Lemma permut_get_2 : forall l1 l2 l3,
  permut (l1 ++ l2 ++ l3) (l2 ++ l1 ++ l3).
Proof using.
  intros. apply rtclosure_once.
  applys (@permut_one_intro _ nil l1 l2 l3).
Qed.
Lemma permut_get_3 : forall l1 l2 l3 l4,
  permut (l1 ++ l2 ++ l3 ++ l4) (l2 ++ l3 ++ l1 ++ l4).
Proof using.
  intros. do 2 rewrite <- (@app_assoc _ l2).
  apply permut_get_2.
Qed.
Lemma permut_get_4 : forall l1 l2 l3 l4 l5,
  permut (l1 ++ l2 ++ l3 ++ l4 ++ l5)
         (l2 ++ l3 ++ l4 ++ l1 ++ l5).
Proof using.
  intros. do 2 rewrite <- (@app_assoc _ l2).
  apply permut_get_3.
Qed.
Lemma permut_get_5 : forall l1 l2 l3 l4 l5 l6,
  permut (l1 ++ l2 ++ l3 ++ l4 ++ l5 ++ l6)
         (l2 ++ l3 ++ l4 ++ l5 ++ l1 ++ l6).
Proof using.
  intros. do 2 rewrite <- (@app_assoc _ l2).
  apply permut_get_4.
Qed.
Lemma permut_get_6 : forall l1 l2 l3 l4 l5 l6 l7,
  permut (l1 ++ l2 ++ l3 ++ l4 ++ l5 ++ l6 ++ l7)
         (l2 ++ l3 ++ l4 ++ l5 ++ l6 ++ l1 ++ l7).
Proof using.
  intros. do 2 rewrite <- (@app_assoc _ l2).
  apply permut_get_5.
Qed.

Lemma permut_tactic_setup : forall l1 l2,
  permut (nil ++ l1 ++ nil) (l2 ++ nil) -> permut l1 l2.
Proof using. intros. rew_list~ in H. Qed.

Lemma permut_tactic_keep : forall l1 l2 l3 l4,
  permut ((l1 ++ l2) ++ l3) l4 ->
  permut (l1 ++ (l2 ++ l3)) l4.
Proof using. intros. rew_list~ in H. Qed.

Lemma permut_tactic_simpl : forall l1 l2 l3 l4,
  permut (l1 ++ l3) l4 ->
  permut (l1 ++ (l2 ++ l3)) (l2 ++ l4).
Proof using.
  intros. eapply permut_trans.
  apply permut_get_2. apply~ permut_app_r.
Qed.

Lemma permut_tactic_trans : forall l1 l2 l3,
  permut l3 l2 -> permut l1 l3 -> permut l1 l2.
Proof using. introv P1 P2. apply~ (permut_trans P2 P1). Qed.

End PermutationTactic.

(** [permut_prepare] applies to a goal of the form [permut l l']
    and sets [l] and [l'] in the form [l1 ++ l2 ++ .. ++ nil],
    (some of the lists [li] are put in the form [x::nil]). *)
(* todo: improve so as to ensure no rewrite inside elements *)

Hint Rewrite app_assoc app_nil_l app_nil_r : permut_rew.

Ltac permut_lemma_get n :=
  match nat_from_number n with
  | 1 => constr:(permut_get_1)
  | 2 => constr:(permut_get_2)
  | 3 => constr:(permut_get_3)
  | 4 => constr:(permut_get_4)
  | 5 => constr:(permut_get_5)
  end.

Ltac permut_isolate_cons :=
  do 20 try (* todo : repeat *)
    match goal with |- context [?x::?l] =>
      match l with
      | nil => fail 1
      | _ => rewrite <- (@app_cons_one _ x l)
      end
    end.

Ltac permut_simpl_prepare :=
   autorewrite with permut_rew;
   permut_isolate_cons;
   autorewrite with permut_rew;
   apply permut_tactic_setup;
   repeat rewrite app_assoc.

(** [permut_simplify] simplifies a goal of the form
    [permut l l'] where [l] and [l'] are lists built with
    concatenation and consing, by cancelling syntactically
    equal elements *)

Ltac permut_index_of l lcontainer :=
  match constr:(lcontainer) with
  | l ++ _ => constr:(1)
  | _ ++ l ++ _ => constr:(2)
  | _ ++ _ ++ l ++ _ => constr:(3)
  | _ ++ _ ++ _ ++ l ++ _ => constr:(4)
  | _ ++ _ ++ _ ++ _ ++ l ++ _ => constr:(5)
  | _ ++ _ ++ _ ++ _ ++ _ ++ l ++ _ => constr:(6)
  | _ => constr:(0) (* not found *)
  end.

Ltac permut_simpl_once :=
  match goal with
  | |- permut (_ ++ nil) _ => fail 1
  | |- permut (_ ++ (?l ++ _)) ?l' =>
     match permut_index_of l l' with
     | 0 => apply permut_tactic_keep
     | ?n => let F := permut_lemma_get n in
            eapply permut_tactic_trans;
            [ apply F
            | apply permut_tactic_simpl ]
     end
  end.

Ltac permut_simpl :=
  permut_simpl_prepare;
  repeat permut_simpl_once;
  autorewrite with permut_rew;
  try apply permut_refl.

(* todo: permut rewrite *)

(* ********************************************************************** *)
(** * Sorted lists *)

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

Section Sorted.
Variable A : Type.
Implicit Types le : binary A.

Inductive sorted le : list A -> Prop :=
  | sorted_nil : sorted le nil
  | sorted_one : forall x, sorted le (x::nil)
  | sorted_two : forall x y l,
     sorted le (y::l) -> le x y ->
     sorted le (x::y::l).

Definition rsorted le := sorted (flip le).

Definition head_of_le le x l :=
  match l with
  | nil => True
  | h::_ => le x h
  end.

Definition head_le le l1 l2 :=
  match l1,l2 with
  | _,nil => True
  | nil,_ => True
  | h1::_,h2::_ => le h1 h2
  end.

End Sorted.

(* ---------------------------------------------------------------------- *)
(** ** Properties about sorted *)

Implicit Arguments sorted [A].
Hint Unfold rsorted.

Section SortedProperties.
Hint Constructors sorted.

Variables (A : Type).
Variable le : binary A.
Hint Resolve sorted_nil sorted_one.

Lemma sorted_inv : forall x l,
  sorted le (x::l) -> head_of_le le x l /\ sorted le l.
Proof using. introv H. inverts H; simpls~. Qed.

Lemma sorted_sub : forall x l,
  sorted le (x::l) -> sorted le l.
Proof using. introv H. inverts~ H. Qed.

Lemma sorted_cons : forall l,
  sorted le l -> forall x,
  head_of_le le x l -> sorted le (x::l).
Proof using. introv S Hd. inverts~ S. Qed.

Lemma head_le_from_sorted : forall x l1 l2,
  sorted le (x::l2) ->
  head_le le l1 (x::l2) ->
  head_le le (x::l1) l2.
Proof using.
  intros. destruct l2; simpl. auto. inverts~ H.
Qed.

Lemma sorted_cons_head_of : forall x l,
  sorted le (x::l) -> head_of_le le x l.
Proof using. introv H. inverts H; simpls~. Qed.

Lemma head_le_nil_l : forall l,
  head_le le nil l.
Proof using. intros. unfolds. destruct~ l. Qed.

Lemma head_le_nil_r : forall l,
  head_le le l nil.
Proof using. intros. unfolds. destruct~ l. Qed.

Lemma sorted_cons_head : forall l1 l2 x,
  head_le le (x::l1) l2 ->
  sorted le l2 ->
  sorted le (x::l2).
Proof using. introv H S2. destruct l2. auto. apply~ sorted_cons. Qed.

Lemma head_le_flip : forall l1 l2,
  head_le (flip le) l1 l2 = head_le le l2 l1.
Proof using. destruct l1; destruct l2; auto. Qed.

Lemma head_le_flip_1 : forall l1 l2,
  head_le (flip le) l1 l2 -> head_le le l2 l1.
Proof using. intros. rewrite~ <- head_le_flip. Qed.

Lemma head_le_flip_2 : forall l1 l2,
  head_le le l2 l1 -> head_le (flip le) l1 l2.
Proof using. intros. rewrite~ head_le_flip. Qed.

Lemma sorted_Forall_le : forall x l,
  total_preorder le ->
  head_of_le le x l -> sorted le l -> Forall (le x) l.
Proof using.
  induction l; simpl; introv Tot LeH Sl. auto. constructor~.
  lets: (sorted_sub Sl). constructor~. apply~ IHl.
  destruct~ l; simpls~. inverts Sl. sapply* total_preorder_trans.
Qed.

Lemma head_of_le_Forall_le : forall x l,
  Forall (le x) l -> head_of_le le x l.
Proof using. introv H. destruct l; simpls. auto. inverts~ H. Qed.

Lemma sorted_flip_flip : forall l,
  sorted le l ->
  sorted (flip (flip le)) l.
Proof using.
  introv H. rewrite flip_flip. induction H.
   constructor. constructor. apply~ sorted_cons.
Qed.

End SortedProperties.

(* ---------------------------------------------------------------------- *)
(** ** Properties about rsorted *)

Section RSortedProperties.
Variables (A : Type).
Variable le : binary A.
Hint Resolve sorted_nil sorted_one.
Hint Constructors sorted.

Lemma rsorted_inv : forall x l,
  rsorted le (x::l) -> head_of_le (flip le) x l /\ rsorted le l.
Proof using. introv H. inverts H; simpls~. Qed.

Lemma head_le_from_rsorted : forall x l1 l2,
  rsorted le (x::l2) ->
  head_le (flip le) l1 (x::l2) ->
  head_le (flip le) (x::l1) l2.
Proof using.
  intros. destruct l2; simpl. auto. inverts~ H.
Qed.

Lemma rsorted_cons_head : forall l1 l2 x,
  head_le (flip le) (x::l1) l2 ->
  rsorted le l2 ->
  rsorted le (x::l2).
Proof using. introv H S2. destruct~ l2. Qed.

Lemma sorted_app : forall l1 l2,
  head_le le l1 l2 -> rsorted le l1 -> sorted le l2 ->
  sorted le ((rev l1) ++ l2).
Proof using.
  introv. gen l2. induction l1; introv Hd S1 S2; rew_rev. auto.
  lets Hd1 S1': (rsorted_inv S1). clear S1.
  apply IHl1. destruct~ l1. auto.
  apply sorted_cons. auto. destruct~ l2.
Qed.

End RSortedProperties.

Lemma rsorted_app : forall (A : Type) (le : binary A) l1 l2,
  head_le le l2 l1 -> sorted le l1 -> rsorted le l2 ->
  rsorted le ((rev l1) ++ l2).
Proof using.
  unfold rsorted. intros. apply sorted_app.
    rewrite~ head_le_flip.
    unfolds. apply~ sorted_flip_flip.
    auto.
Qed.

(* ********************************************************************** *)
(** * Sorting of a list *)

Section Sorts.
Variables (A : Type).
Implicit Types le : binary A.
Hint Resolve sorted_nil sorted_one.

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

Definition sorts le l l' :=
  permut l l' /\ sorted le l'.

Definition rsorts le := sorts (flip le).

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

Lemma sorts_refl : forall le l,
  sorted le l -> sorts le l l.
Proof using. split. apply permut_refl. auto. Qed.

Lemma rsorts_refl : forall le l,
  rsorted le l -> rsorts le l l.
Proof using. intros. apply~ sorts_refl. Qed.

Lemma sorts_app_rev : forall le l1 l2,
 head_le le l1 l2 -> rsorted le l1 -> sorted le l2 ->
 sorts le (l1 ++ l2) (rev l1 ++ l2).
Proof using.
  introv H S1 S2. split.
  apply permut_app_l. apply permut_rev.
  apply~ sorted_app.
Qed.

Lemma rsorts_app_rev : forall le l1 l2,
 head_le le l2 l1 -> sorted le l1 -> rsorted le l2 ->
 rsorts le (l1 ++ l2) (rev l1 ++ l2).
Proof using.
  introv H S1 S2. split.
  apply permut_app_l. apply permut_rev.
  apply~ rsorted_app.
Qed.

Lemma sorts_permut : forall l1 l2 l' le,
  sorts le l1 l' -> permut l2 l1 ->
  sorts le l2 l'.
Proof using.
  introv [P1 S1] Per. split~.
  apply* (@permut_trans _ l1).
Qed.

Lemma rsorts_permut : forall l1 l2 l' le,
  rsorts le l1 l' -> permut l2 l1 ->
  rsorts le l2 l'.
Proof using. intros. apply~ (@sorts_permut l1). Qed.

Lemma sorts_cons : forall le l l' x,
  sorts le l l' -> head_of_le le x l' ->
  sorts le (x::l) (x::l').
Proof using.
  introv [P S] Hd. split.
  apply~ permut_cons. apply~ sorted_cons.
Qed.

Lemma sorts_2 : forall le l x1 x2,
  permut l (x1::x2::nil) ->
  le x1 x2 ->
  sorts le l (x1::x2::nil).
Proof using.
  intros. apply~ (@sorts_permut (x1::x2::nil)).
  apply sorts_refl. apply sorted_cons.
  apply sorted_one. simpls~.
Qed.

Lemma sorts_3 : forall le l x1 x2 x3,
  permut l (x1::x2::x3::nil) ->
  le x1 x2 -> le x2 x3 ->
  sorts le l (x1::x2::x3::nil).
Proof using.
  intros.
   apply~ (@sorts_permut (x1::x2::x3::nil)).
   apply sorts_refl. apply sorted_cons.
   apply sorted_cons. apply sorted_one.
   simpls~. simpls~.
Qed.

Lemma rsorts_2 : forall le l x1 x2,
  permut l (x1::x2::nil) ->
  le x2 x1 ->
  rsorts le l (x1::x2::nil).
Proof using.
  intros.
   apply~ (@rsorts_permut (x1::x2::nil)).
   apply rsorts_refl. applys sorted_cons.
   apply sorted_one. unfold flip. simpls~.
Qed.

Lemma rsorts_3 : forall le l x1 x2 x3,
  permut l (x1::x2::x3::nil) ->
  le x2 x1 -> le x3 x2 ->
  rsorts le l (x1::x2::x3::nil).
Proof using.
  intros.
   apply~ (@rsorts_permut (x1::x2::x3::nil)).
   apply rsorts_refl. applys sorted_cons.
   apply sorted_cons. apply sorted_one.
   simpls~. simpls~.
Qed.

Lemma sorts_length_lt_2 : forall le l,
  length l < 2 -> sorts le l l.
Proof using.
  intros. apply sorts_refl. destruct~ l.
  destruct~ l. rew_length in *. false. nat_math.
Qed.

End Sorts.


From Coq Require Export ssreflect.
From stdpp Require Export base list relations.

Tactic Notation "make_eq" constr(t) "as" ident(x) ident(E) :=
  set x := t ;
  assert (t = x) as E by reflexivity ;
  clearbody x.

Lemma take_cons {A : Type} (n : nat) (x : A) (xs : list A) :
  (0 < n)%nat → take n (x :: xs) = x :: take (n-1)%nat xs.
Proof.
  intros <- % Nat.succ_pred_pos. by rewrite /= - minus_n_O.
Qed.

Lemma drop_cons {A : Type} (n : nat) (x : A) (xs : list A) :
  (0 < n)%nat → drop n (x :: xs) = drop (n-1)%nat xs.
Proof.
  intros <- % Nat.succ_pred_pos. by rewrite /= - minus_n_O.
Qed.

Lemma nsteps_split `{R : relation A} m n x y :
  nsteps R (m+n) x y →
  ∃ (z : A), nsteps R m x z ∧ nsteps R n z y.
Proof.
  revert x ; induction m as [ | m' IH ] ; intros x H.
  - exists x. split ; [ constructor | assumption ].
  - inversion H as [ (*…*) | sum' x_ z y_ Hxz Hzy Esum' Ex Ey ] ; clear dependent sum' x_ y_.
    apply IH in Hzy as (ω & Hzω & Hωy).
    exists ω. split ; first econstructor ; eassumption.
Qed.


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

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

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

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

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

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Theorem drop_Nil: forall (x: natural), drop x Nil = Nil.
Proof.
  induction x ; simpl; reflexivity.
Qed.

Theorem drop_Cons: forall (x n: natural) (l: lst), drop (Succ x) (Cons n l) = drop x l.
  induction l; induction x; simpl; reflexivity.
Qed.

Theorem drop_Cons_assoc: forall (x1 x2 x3: natural) (l: lst),
    drop x1 (drop x2 (Cons x3 l)) = drop x2 (drop x1 (Cons x3 l)).
Proof.
  induction x1; induction x2; try (simpl; reflexivity).
  + induction l.
    * rewrite 2 drop_Cons. rewrite <- IHx1.
      rewrite IHx2. rewrite 2 drop_Cons.
      induction l.
      - rewrite IHx1. reflexivity.
lfind.  reflexivity.
Admitted.

Theorem drop_assoc : forall (x : natural) (y : natural) (z : lst), eq (drop x (drop y z)) (drop y (drop x z)).
Proof.
  induction z.
  + rewrite 2 drop_Cons_assoc. reflexivity.
  + rewrite 3 drop_Nil. reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : natural) (w : natural) (z : lst), eq (drop w (drop x (drop y z))) (drop y (drop x (drop w z))).
Proof.
  intros.
  rewrite (drop_assoc w x).
  rewrite (drop_assoc w y).
  rewrite (drop_assoc x y).
  reflexivity.
Qed.


Require Import ZArith.
Require Import smart_common.
Require Import smart_bdd.
Require Import FMapPositive.
Require Import FunctionalExtensionality.

Inductive canonical: var -> bdd -> Prop :=
  | Tcanonical : forall v, canonical v T
  | Fcanonical : forall v, canonical v F
  | Ncanonical :
      forall v v', (v' < v)%positive ->
      forall bt, canonical v' bt ->
      forall bf, canonical v' bf ->
      bt <> bf ->
      canonical v (N v' bt bf).

Hint Constructors canonical.

Lemma bdd_interp_canonical_independent:
  forall v b, canonical v b ->
  forall x env,
    bdd_interp b (PositiveMap.add v x env) = bdd_interp b env.
Proof.
  intros v b Hcan.
  remember v in |- *. assert (v <= v0)%positive by (subst; reflexivity). clear Heqv0.
  generalize dependent v0.
  induction Hcan; auto.
  simpl; intros.
  rewrite PositiveMap.gso by (zify; omega).
  destruct (PositiveMap.find v' env) as [[]|].
  - apply IHHcan1. zify; omega.
  - apply IHHcan2. zify; omega.
  - auto.
Qed.

Lemma bdd_canonical_aux1:
  forall bt bf v,
  forall b, canonical v b -> canonical v bt ->
    (forall env, bdd_interp b env = bdd_interp (N v bt bf) env) ->
    forall env, bdd_interp b env = bdd_interp bt env.
Proof.
  intros.
  specialize (H1 (PositiveMap.add v true env)). simpl in H1.
  rewrite PositiveMap.gss, !bdd_interp_canonical_independent in H1; auto.
Qed.

Local Hint Resolve bdd_canonical_aux1.

Lemma bdd_canonical_aux2:
  forall bt bf v,
  forall b, canonical v b -> canonical v bf ->
    (forall env, bdd_interp b env = bdd_interp (N v bt bf) env) ->
    forall env, bdd_interp b env = bdd_interp bf env.
Proof.
  intros.
  specialize (H1 (PositiveMap.add v false env)). simpl in H1.
  rewrite PositiveMap.gss, !bdd_interp_canonical_independent in H1; auto.
Qed.

Local Hint Resolve bdd_canonical_aux2.

Theorem bdd_canonical:
  forall a va, canonical va a ->
  forall b vb, canonical vb b ->
    (forall env, bdd_interp a env = bdd_interp b env) ->
    a = b.
Proof.
  induction 1; induction 1; subst; intro.
  - reflexivity.
  - specialize (H (PositiveMap.empty _)). discriminate.
  - rewrite <- IHcanonical2, <- IHcanonical1 in H2 by eauto. tauto.
  - specialize (H (PositiveMap.empty _)). discriminate.
  - reflexivity.
  - rewrite <- IHcanonical2, <- IHcanonical1 in H2 by eauto. tauto.
  - erewrite IHcanonical2 with (b:=T), IHcanonical1 with (b:=T) in H2 by (eauto; symmetry; eauto). tauto.
  - erewrite IHcanonical2 with (b:=F), IHcanonical1 with (b:=F) in H2 by (eauto; symmetry; eauto). tauto.
  - destruct (Pos.compare_spec v' v'0).
    + subst. f_equal.
      * eapply IHcanonical1; eauto.
        intro. specialize (H5 (PositiveMap.add v'0 true env)). simpl in H5.
        erewrite PositiveMap.gss, !bdd_interp_canonical_independent in H5 by eauto. auto.
      * eapply IHcanonical2; eauto.
        intro. specialize (H5 (PositiveMap.add v'0 false env)). simpl in H5.
        erewrite PositiveMap.gss, !bdd_interp_canonical_independent in H5 by eauto. auto.
    + erewrite <- IHcanonical3, <- IHcanonical4 in H4 by (eauto; symmetry; eauto). tauto.
    + erewrite IHcanonical2 with (b:=N v'0 bt0 bf0), IHcanonical1 with (b:=N v'0 bt0 bf0) in H2 by (eauto; symmetry; eauto). tauto.
  Grab Existential Variables.
  exact xH. exact xH. exact xH. exact xH.
Qed.

Lemma bdd_not_inj:
  forall b1 b2, bdd_not b1 = bdd_not b2 -> b1 = b2.
Proof.
  induction b1; induction b2; try reflexivity; try discriminate.
  unfold bdd_not, memo_rec.
  intro.
  rewrite Fix_eq with (x:=N v0 b2_1 b2_2) in H. rewrite Fix_eq in H.
  injection H. clear H. intros. subst.
  f_equal; auto.
  intros. replace g with f. easy. extensionality x'. extensionality p. auto.
  intros. replace g with f. easy. extensionality x'. extensionality p. auto.
Qed.

Theorem canonical_bdd_not:
  forall v b, canonical v b -> canonical v (bdd_not b).
Proof.
  induction 1; auto.
  unfold bdd_not, memo_rec.
  rewrite Fix_eq.
  constructor; auto.
  intro. apply bdd_not_inj in H3. tauto.
  intros. replace g with f. easy. extensionality x'. extensionality p. auto.
Qed.

Lemma canonical_le:
  forall v v' b, (v <= v')%positive ->
    canonical v b ->
    canonical v' b.
Proof.
  destruct 2; constructor; auto.
  zify; omega.
Qed.

Lemma canonical_N_check:
  forall v bt bf,
    canonical v bt ->
    canonical v bf ->
  forall v', (v < v')%positive ->
    canonical v' (N_check v bt bf).
Proof.
  unfold N_check. intros.
  pose proof (bdd_eqb_iff bt bf).
  destruct (bdd_eqb bt bf).
  eapply canonical_le; eauto. zify; omega.
  constructor; auto.
  unfold not. rewrite <- H2. discriminate.
Qed.

Theorem canonical_bdd_and:
  forall b1 b2 v,
    canonical v b1 ->
    canonical v b2 ->
    canonical v (bdd_and b1 b2).
Proof.
  intros. revert b2 H0.
  pose proof H. induction H; auto.
  intros.
  unfold bdd_and. unfold memo_rec.
  rewrite Fix_eq;
    try (intros; replace g with f; [easy|extensionality x'; extensionality p; auto]).
  induction H4; auto.
  unfold memo_rec.
  rewrite Fix_eq;
  try (intros; replace g with f; [easy|extensionality x'; extensionality p; auto]).
  destruct (Pos.compare_spec v' v'0); eapply canonical_N_check; subst; auto.
Qed.

Theorem canonical_bdd_or:
  forall b1 b2 v,
    canonical v b1 ->
    canonical v b2 ->
    canonical v (bdd_or b1 b2).
Proof.
  intros. revert b2 H0.
  pose proof H. induction H; auto.
  intros.
  unfold bdd_or. unfold memo_rec.
  rewrite Fix_eq;
    try (intros; replace g with f; [easy|extensionality x'; extensionality p; auto]).
  induction H4; auto.
  unfold memo_rec.
  rewrite Fix_eq;
    try (intros; replace g with f; [easy|extensionality x'; extensionality p; auto]).
  destruct (Pos.compare_spec v' v'0); eapply canonical_N_check; subst; auto.
Qed.

Theorem canonical_bdd_xor:
  forall b1 b2 v,
    canonical v b1 ->
    canonical v b2 ->
    canonical v (bdd_xor b1 b2).
Proof.
  intros. revert b2 H0.
  pose proof H. induction H; auto using canonical_bdd_not.
  intros.
  unfold bdd_xor, memo_rec.
  rewrite Fix_eq;
    try (intros; replace g with f; [easy|extensionality x'; extensionality p; auto]).
  induction H4; auto.
  unfold memo_rec.
  rewrite Fix_eq;
    try (intros; replace g with f; [easy|extensionality x'; extensionality p; auto]).
  auto using canonical_bdd_not.
  rewrite Fix_eq;
    try (intros; replace g with f; [easy|extensionality x'; extensionality p; auto]).
  destruct (Pos.compare_spec v' v'0); eapply canonical_N_check; subst; auto.
Qed.

(* BDD ITE  *)

Theorem canonical_bdd_ite:
  forall b1 b2 b3,
  forall v,
    canonical v b1 ->
    canonical v b2 ->
    canonical v b3 ->
    canonical v (bdd_ite b1 b2 b3).
Proof.
  intros. revert b2 H0 b3 H1.
  induction H; auto.
  unfold bdd_ite, memo_rec.
  rewrite Fix_eq;
    try (intros; replace g with f; [easy|extensionality x'; extensionality p; auto]).
  change (Fix (well_founded_ltof bdd bdd_size))
  with (memo_rec (well_founded_ltof bdd bdd_size)) in *.
  fold bdd_ite in *. unfold memo_rec.
  intros b2 ?.
  induction H3; auto;
  rewrite Fix_eq;
  try (intros; replace g with f; [easy|extensionality x'; extensionality p; auto]).
  - intros.
    induction H3;
    rewrite Fix_eq;
      try (intros; replace g with f; [easy|extensionality x'; extensionality p; auto]).
    apply canonical_N_check; auto.
    apply canonical_N_check; auto.
    destruct (Pos.compare_spec v' v'0); subst; apply canonical_N_check; auto.
  - intros.
    induction H3;
    rewrite Fix_eq;
      try (intros; replace g with f; [easy|extensionality x'; extensionality p; auto]).
    apply canonical_N_check; auto.
    apply canonical_N_check; auto.
    destruct (Pos.compare_spec v' v'0); subst; apply canonical_N_check; auto.
  - intros.
    match goal with |- context [match ?t with (_, _) => _ end] =>
                    remember t
    end.
    destruct p as [[rect recf] v1].
    assert (forall b, canonical v1 b -> canonical v1 (rect b)).
    { destruct (Pos.compare_spec v' v'0); inversion Heqp; subst; clear Heqp; auto. }
    assert (forall b, canonical v1 b -> canonical v1 (recf b)).
    { destruct (Pos.compare_spec v' v'0); inversion Heqp; subst; clear Heqp; auto. }
    assert (v1 < v)%positive.
    { destruct (Pos.compare_spec v' v'0); inversion Heqp; subst; clear Heqp; auto. }
    clear H H3.
    induction H5;
    rewrite Fix_eq;
      try (intros; replace g with f; [easy|extensionality x'; extensionality p; auto]).
    apply canonical_N_check; auto.
    apply canonical_N_check; auto.
    destruct (Pos.compare_spec v1 v'1); subst; apply canonical_N_check; auto.
Qed.


Require Import List Permutation.
Require Import RelationClasses Morphisms.
Require Import Omega Lra Rbase.
Require Import Relation_Definitions Sorted.

Require Import LibUtils.

Import ListNotations.

Section Map.

  Lemma removelast_map {A B : Type} (f:A->B) (l : list A) :
    removelast (map f l) = map f (removelast l).
  Proof.
    induction l; simpl; trivial.
    rewrite IHl.
    destruct l; simpl; trivial.
  Qed.

  Lemma tl_map {A B : Type} (f:A->B) (l : list A) :
    tl (map f l) = map f (tl l).
  Proof.
    destruct l; simpl; trivial.
  Qed.

End Map.

Section Fold.
  Context {A B C: Type}.

  Lemma fold_right_map
        (f:C -> A -> A) (g:B->C) (l:list B) (init:A) :
    fold_right f init (map g l) = fold_right (fun a b => f (g a) b) init l.
  Proof.
    revert init.
    induction l; simpl; trivial; intros.
    rewrite IHl; trivial.
  Qed.

End Fold.

Lemma fold_right_assoc_abs {A} (f:A->A->A) (init:A) (l : list (list A))
      (assoc:forall x y z : A, f x (f y z) = f (f x y) z)
      (abs:forall x, f init x = x) :
  fold_right f init (concat l) =
  fold_right f init (map (fold_right f init) l).
Proof.
  rewrite fold_right_map.
  induction l; simpl; trivial.
  rewrite fold_right_app.
  rewrite <- IHl.
  generalize (fold_right f init (concat l)); intros.
  induction a; simpl.
  - auto.
  - rewrite IHa.
    generalize (fold_right f init a1); intros.
    now rewrite assoc.
Qed.

Lemma fold_right_plus_concat (l : list (list R)) :
  fold_right Rplus R0 (concat l) =
  fold_right Rplus R0 (map (fold_right Rplus R0) l).
Proof.
  apply fold_right_assoc_abs; intros; lra.
Qed.

Lemma fold_right_plus_acc f acc l :
  fold_right (fun (a : nat) (b : R) => f a + b)%R acc l =
  (fold_right (fun (a : nat) (b : R) => f a + b)%R R0 l + acc)%R.
Proof.
  induction l; simpl.
  - lra.
  - rewrite IHl; lra.
Qed.

Section Seq.

  Lemma seq_shiftn {A:Type} (l:list A)  (n:nat) :
    seq n (length l) = map (fun x => x + n)%nat (seq 0 (length l)).
  Proof.
    induction n; simpl.
    - erewrite map_ext.
      + erewrite map_id; trivial.
      + intros; omega.
    - rewrite <- seq_shift.
      rewrite IHn.
      rewrite map_map.
      apply map_ext; intros.
      omega.
  Qed.

  Lemma list_as_nthseq_start {A:Type} (l:list A) (d:A) (c:nat) : l = map (fun n => nth (n-c) l d) (seq c%nat (length l)).
  Proof.
    induction l; simpl; trivial.
    rewrite <- seq_shift.
    rewrite map_map.
    simpl.
    replace (c-c)%nat with 0%nat by omega.
    rewrite IHl.
    f_equal.
    rewrite map_length.
    rewrite seq_length.
    apply map_ext_in; intros x inn.
    apply in_seq in inn.
    rewrite <- IHl.
    destruct c.
    - f_equal; omega.
    - assert (x-c > 0)%nat by omega.
      replace (x - S c)%nat with ((x - c) - 1)%nat by omega.
      destruct (x-c)%nat.
      + omega.
      + f_equal; omega.
  Qed.

  Lemma list_as_nthseq {A:Type} (l:list A) (d:A) : l = map (fun n => nth n l d) (seq 0%nat (length l)).
  Proof.
    rewrite (list_as_nthseq_start l d 0) at 1.
    apply map_ext; intros.
    f_equal; omega.
  Qed.

  Lemma seq_Sn s n : seq s (S n) = seq s n ++ [(s+n)]%nat.
  Proof.
    replace (S n) with (n + 1)%nat by omega.
    rewrite seq_plus.
    simpl; trivial.
  Qed.

Lemma tl_seq n : tl (seq 0 n) = seq 1 (n-1).
Proof.
  destruct n; simpl; trivial.
  rewrite Nat.sub_0_r.
  trivial.
Qed.

Lemma removelast_seq (n:nat) : removelast (seq 0 n) = seq 0 (n-1).
Proof.
  induction n; simpl; trivial.
  rewrite Nat.sub_0_r.
  rewrite <- seq_shift.
  rewrite removelast_map.
  rewrite IHn.
  repeat rewrite seq_shift.
  destruct n; simpl; trivial.
  rewrite Nat.sub_0_r.
  trivial.
Qed.

Lemma seq_shiftn_map start len : seq start len = map (plus start) (seq 0 len).
Proof.
  induction start; simpl.
  - rewrite map_id; trivial.
  - rewrite <- seq_shift.
    rewrite IHstart.
    rewrite map_map.
    trivial.
Qed.

End Seq.

Section fp.

  Lemma ForallOrdPairs_impl {A:Type} (R:A->A->Prop) (l:list A) (f:A->A) :
    ForallOrdPairs R l ->
    ForallOrdPairs (fun x y => R x y -> R (f x) (f y)) l ->
    ForallOrdPairs R (map f l).
  Proof.
    induction l; intros FP; inversion FP; clear FP; subst; intros FP; simpl.
    - constructor.
    - inversion FP; clear FP; subst.
      constructor.
      + rewrite Forall_forall in *.
        intros x inn.
        apply in_map_iff in inn.
        destruct inn as [xx [eqxx inxx]]; subst.
        auto.
      + intuition.
  Qed.

  Lemma ForallPairs_all {A:Type} (R:A->A->Prop) (l:list A) :
    (forall x1 x2, R x1 x2) -> ForallPairs R l.
  Proof.
    firstorder.
  Qed.

End fp.

Lemma nth_tl {A} idx (l:list A) d : nth idx (tl l) d = nth (S idx) l d.
Proof.
  destruct l; simpl; trivial.
  destruct idx; trivial.
Qed.

Lemma nth_removelast_in {A} idx (l:list A) d :
  idx < pred (length l) ->
  nth idx (removelast l) d = nth idx l d.
Proof.
  revert idx.
  induction l; simpl; trivial; intros idx inn.
  destruct l.
  - destruct idx; simpl in *; omega.
  - simpl in *.
    destruct idx; trivial.
    rewrite IHl by omega.
    trivial.
Qed.

Lemma nth_last {A} (l:list A) d: nth (pred (length l)) l d = last l d.
Proof.
  induction l; simpl; trivial.
  destruct l; simpl in *; trivial.
Qed.

Lemma nth_hd {A} (l:list A) d: nth 0 l d = hd d l.
Proof.
  destruct l; simpl in *; trivial.
Qed.

Lemma hd_app {A} (l1 l2:list A) d : l1 <> nil -> hd d (l1 ++ l2) = hd d l1.
Proof.
  induction l1; simpl; congruence.
Qed.

Lemma last_rev {A} (l:list A) d : last l d = hd d (rev l).
Proof.
  induction l; trivial.
  simpl rev.
  destruct l; trivial.
  rewrite hd_app; trivial.
  intros eqq.
  apply (f_equal (@length A)) in eqq.
  simpl in eqq.
  rewrite app_length in eqq.
  simpl in eqq.
  omega.
Qed.

Lemma last_app {A} (l1 l2:list A) d : l2 <> nil -> last (l1 ++ l2) d = last l2 d.
Proof.
  intros.
  repeat rewrite last_rev.
  rewrite rev_app_distr.
  rewrite hd_app; trivial.
  intro eqq; apply H.
  apply (f_equal (@rev A)) in eqq.
  rewrite rev_involutive in eqq.
  trivial.
Qed.

Lemma last_cons {A} (x:A) l y : last (x::l) y = last l x.
Proof.
  revert y.
  induction l; simpl; trivial; intros.
  destruct l; trivial.
  simpl in *.
  apply IHl.
Qed.

Lemma seq_last s n d :
  (n > 0)%nat ->
  last (seq s n) d = (s+n-1)%nat.
Proof.
  intros.
  destruct n.
  - simpl; omega.
  - rewrite seq_Sn.
    rewrite last_app by congruence.
    simpl.
    omega.
Qed.

Lemma last_map {A B} (f:A->B) (l:list A) d : last (map f l) (f d) = f (last l d).
Proof.
  induction l; simpl; trivial.
  destruct l; simpl; trivial.
Qed.

Lemma map_nth_in {A B} (f:A->B) l d1 n d2 :
  (n < length l)%nat ->
  nth n (map f l) d1 = f (nth n l d2).
Proof.
  revert n.
  induction l; simpl.
  - destruct n; omega.
  - destruct n; trivial.
    intros; eauto.
    rewrite IHl; trivial; omega.
Qed.

Lemma map_nth_in_exists {A B} (f:A->B) l d1 n :
  (n < length l)%nat ->
  exists d2,
  nth n (map f l) d1 = f (nth n l d2).
Proof.
  revert n.
  induction l; simpl.
  - destruct n; omega.
  - destruct n; trivial.
    + intros; eauto.
    + intros.
      destruct (IHl n).
      * omega.
      * rewrite H0.
        eauto.
Qed.

Lemma nth_in_default {A} (l:list A) d1 d2 n :
  (n < length l)%nat ->
  nth n l d1 = nth n l d2.
Proof.
  revert n.
  induction l; simpl.
  - destruct n; omega.
  - destruct n; trivial.
    + intros; eauto.
      rewrite (IHl n); trivial.
      omega.
Qed.

Lemma Forall_app_iff {A} {P:A->Prop} {l1 l2} :
  Forall P (l1 ++ l2) <->
  Forall P l1 /\ Forall P l2.
Proof.
  repeat rewrite Forall_forall.
  intuition.
  apply in_app_iff in H.
  intuition.
Qed.

Lemma StronglySorted_app_inv {A} {R:relation A} {l1 l2} :
  StronglySorted R (l1 ++ l2) ->
  StronglySorted R l1 /\ StronglySorted R l2.
Proof.
  Hint Constructors StronglySorted : list.
  revert l2.
  induction l1; intros l2 ss; simpl in *.
  - simpl in *; split; trivial with list.
  - inversion ss; subst; clear ss.
    destruct (IHl1 _ H1).
    split; trivial.
    constructor; trivial.
    apply Forall_app_iff in H2.
    tauto.
Qed.

Lemma StronglySorted_sub {A} (R1 R2:relation A) :
    subrelation R1 R2 ->
    forall l, StronglySorted R1 l -> StronglySorted R2 l.
Proof.
  Hint Constructors StronglySorted : list.
  intros sub.
  induction l; simpl; intros ssl; trivial with list.
  inversion ssl; clear ssl; subst.
  simpl in *.
  constructor.
  - apply IHl; intuition.
  - rewrite Forall_forall in *.
    eauto.
Qed.

Lemma StronglySorted_map_in {A B} (R1:relation A) (R2:relation B) (f:A->B) l :
  (forall x y, In x l /\ In y l -> R1 x y -> R2 (f x) (f y)) ->
  StronglySorted R1 l -> StronglySorted R2 (map f l).
Proof.
  Hint Constructors StronglySorted : list.
  intros prop.
  induction l; simpl; intros ssl; trivial with list.
  inversion ssl; clear ssl; subst.
  simpl in *.
  constructor.
  - apply IHl; intuition.
  - rewrite Forall_forall in *.
    intros x inn.
    apply in_map_iff in inn.
    destruct inn as [a' [eqq inn]].
    subst; auto.
Qed.

Lemma StronglySorted_map {A B} (R1:relation A) (R2:relation B) (f:A->B) :
  Proper (R1 ==> R2) f ->
  forall l,
    StronglySorted R1 l -> StronglySorted R2 (map f l).
Proof.
  intros.
  eapply StronglySorted_map_in; eauto.
Qed.

Lemma StronglySorted_compose {A B} R (f:A->B) (l:list A) :
  StronglySorted R (map f l) <->
  StronglySorted (fun x y => R (f x) (f y)) l.
Proof.
  induction l; simpl.
  - intuition.
  - split; inversion 1; subst; constructor; intuition.
    + now rewrite Forall_map in H3.
    + now rewrite Forall_map.
Qed.

Lemma StronglySorted_break {A} R (l:list A) x :
  StronglySorted R l ->
  In x l ->
  exists b c, l = b++x::c /\ Forall (fun y => R y x) b /\ Forall (R x) c.
Proof.
  induction l; simpl; intros ss inn; [tauto | ].
  invcs ss.
  destruct inn.
  - subst.
    exists nil, l.
    simpl.
    intuition.
  - destruct IHl as [b [c [p1 [p2 p3]]]]; trivial.
    subst.
    exists (a::b), c.
    simpl; intuition.
    constructor; trivial.
    rewrite Forall_forall in H2.
    specialize (H2 x).
    rewrite in_app_iff in H2; simpl in H2.
    eauto.
Qed.

Lemma StronglySorted_nth_lt {A} R (l:list A) idx1 idx2 d1 d2 :
  StronglySorted R l ->
  (idx2 < length l)%nat ->
  (idx1 < idx2)%nat ->
  R (nth idx1 l d1) (nth idx2 l d2).
Proof.
  intros.
  destruct (@nth_split _ idx1 l d1)
           as [l1 [l2 [leqq l1len]]]
  ; [ omega | ].
  rewrite leqq in H.
  apply StronglySorted_app_inv in H.
  destruct H as [ _ ssl2].
  inversion ssl2; clear ssl2; subst.
  rewrite leqq in *.
  rewrite app_length in H0.
  simpl in H0.
  revert H4.
  generalize (nth (length l1) l d1).
  clear l leqq.
  intros a Fa.
  rewrite Forall_forall in Fa.
  apply Fa.
  rewrite app_nth2 by omega.
  simpl.
  case_eq (idx2 - length l1); try omega.
  intros.
  apply nth_In.
  omega.
Qed.

Lemma StronglySorted_nth_le {A} R (l:list A) idx1 idx2 d1 d2 :
  reflexive _ R ->
  StronglySorted R l ->
  (idx2 < length l)%nat ->
  (idx1 <= idx2)%nat ->
  R (nth idx1 l d1) (nth idx2 l d2).
Proof.
  intros refl ?? leq.
  destruct leq.
  - erewrite nth_in_default; try apply refl.
    trivial.
  - apply StronglySorted_nth_lt; trivial.
    omega.
Qed.

Section bucket.

  Context {A:Type} {R:relation A} (R_dec : forall x y, {R x y} + {~ R x y}).

  Fixpoint find_bucket (needle:A) (haystack:list A)
    := match haystack with
       | x::((y::_) as more) => if R_dec x needle
                       then if R_dec needle y
                            then Some (x,y)
                            else find_bucket needle more
                       else None
       | _ => None
       end.

  Lemma find_bucket_break {needle l a1 a2}:
    find_bucket needle l = Some (a1, a2) ->
      exists l1 l2,
        l = l1 ++ [a1; a2] ++ l2.
  Proof.
    induction l; simpl; try discriminate.
    destruct l; try discriminate.
    destruct (R_dec a needle); try discriminate.
    destruct (R_dec needle a0).
    - inversion 1; subst.
      exists nil, l.
      reflexivity.
    - intros HH.
      destruct (IHl HH) as [l1 [l2 eqq]].
      rewrite eqq.
      exists (a::l1), l2.
      reflexivity.
  Qed.

  Lemma middle_find_bucket needle l1 l2 a1 a2:
    transitive _ R ->
    antisymmetric _ R ->
    StronglySorted R (l1++[a1]) ->
    R a1 needle ->
    R needle a2 ->
    ~ R needle a1 ->
    find_bucket needle (l1 ++ a1::a2::l2) = Some (a1, a2).
  Proof.
    intros trans antisymm.
    intros sorted r1 r2 nr1.
    revert sorted.
    induction l1; intros sorted.
    - simpl.
      destruct (R_dec a1 needle); [ | tauto].
      destruct (R_dec needle a2); [ | tauto].
      trivial.
    - simpl in *.
      inversion sorted; clear sorted; subst.
      specialize (IHl1 H1).
      rewrite IHl1; trivial.
      destruct (R_dec a needle).
      + destruct l1; simpl.
        * destruct (R_dec needle a1); tauto.
        * destruct (R_dec needle a0); trivial.
          elim nr1.
          apply (trans _ a0); trivial.
          inversion H1; clear H1; subst.
          rewrite Forall_forall in H4.
          apply H4.
          rewrite in_app_iff.
          simpl; tauto.
      + rewrite Forall_forall in H2.
        elim n.
        apply (trans _ a1); trivial.
        apply H2.
        rewrite in_app_iff.
        simpl; tauto.
  Qed.

  Lemma find_bucket_nth_finds needle l idx d1 d2:
    transitive _ R ->
    antisymmetric _ R ->
    StronglySorted R l ->
    S idx < length l ->
    R (nth idx l d1) needle ->
    R needle (nth (S idx) l d2) ->
    ~ R needle (nth idx l d1) ->
    find_bucket needle l = Some (nth idx l d1, nth (S idx) l d2).
  Proof.
    intros trans antisymm ss idx_bound.
    assert (idx_bound':idx < length l) by omega.
    destruct (nth_split l d1 idx_bound') as [l1 [l2 [eqq leneq]]].
    revert eqq.
    generalize (nth idx l d1); intros a1.
    intros eqq r1 r2 nr1.
    subst.
    rewrite app_nth2 in * by omega.
    replace ((S (length l1) - length l1)) with 1 in * by omega.
    rewrite app_length in idx_bound.
    simpl in *.
    destruct l2; simpl in *; [ omega | ].
    apply middle_find_bucket; trivial.
    replace (l1 ++ a1 :: a :: l2) with ((l1 ++ a1::nil) ++ (a :: l2)) in ss.
    - apply StronglySorted_app_inv in ss.
      tauto.
    - rewrite app_ass; simpl; trivial.
  Qed.

  Lemma find_bucket_needle_in needle l a1 a2:
    find_bucket needle l = Some (a1, a2) ->
    R a1 needle /\ R needle a2.
  Proof.
    induction l; simpl; try discriminate.
    destruct l; try discriminate.
    destruct (R_dec a needle); try discriminate.
    destruct (R_dec needle a0).
    - inversion 1; subst.
      tauto.
    - intuition.
  Qed.

  Lemma find_bucket_bucket_in needle l a1 a2 d1 d2:
    reflexive _ R ->
    StronglySorted R l ->
    find_bucket needle l = Some (a1, a2) ->
    R (hd d1 l) a1 /\ R a2 (last l d2).
  Proof.
    intros refl ssl eqq1.
    destruct (find_bucket_break eqq1)
      as [l1 [l2 eqq2]].
    replace (l1 ++ [a1; a2] ++ l2) with ((l1 ++ a1::nil) ++ (a2::l2)) in eqq2.
    - subst.
      apply StronglySorted_app_inv in ssl.
      destruct ssl as [ssl1 ssl2].
      split.
      + destruct l1; simpl.
        * apply refl.
        * inversion ssl1; subst.
          rewrite Forall_forall in H2.
          apply H2.
          rewrite in_app_iff; simpl; tauto.
      + inversion ssl2; clear ssl2; subst.
        rewrite last_app by congruence.
        rewrite Forall_forall in H2.
        simpl.
        destruct l2.
        * apply refl.
        * apply H2.
          clear.
          { revert a.
            induction l2.
            - simpl; tauto.
            - simpl in *.
              eauto.
          }
    - rewrite app_ass; simpl; reflexivity.
  Qed.

  Lemma find_bucket_bounded_le_exists a b l (needle:A) :
    (forall x y, R x y \/ R y x) ->
    R a needle ->
    R needle b ->
    exists lower upper,
    find_bucket needle (a::l++[b]) = Some (lower, upper).
  Proof.
    intros total r1 r2.
    simpl.
    destruct (R_dec a needle); [ | tauto].
    induction l; simpl.
    - destruct (R_dec needle b); [ | tauto].
      eauto.
    - destruct (IHl) as [lower [upper eqq]].
      destruct (R_dec needle a0).
      + eauto.
      + clear IHl r.
        { destruct (R_dec a0 needle).
          - destruct l; simpl in *.
            + destruct (R_dec needle b); simpl; eauto.
            + destruct (R_dec needle a1); eauto.
          - destruct (total needle a0); tauto.
        }
  Qed.

End bucket.

Lemma StronglySorted_seq s n : StronglySorted lt (seq s n).
Proof.
  revert s.
  induction n; intros s; simpl.
  - constructor.
  - constructor; trivial.
    rewrite Forall_forall; intros.
    apply in_seq in H.
    omega.
Qed.

Lemma length_S_tl {A : Type} (l : list A) :
  l <> nil ->
  length l = S (length (tl l)).
Proof.
  intros.
  destruct l; simpl; congruence.
Qed.

Lemma tl_length {A : Type} (l : list A) :
  length (tl l) = pred (length l).
Proof.
  intros.
  destruct l; simpl; congruence.
Qed.

Lemma removelast_length {A : Type} (l : list A) :
  length (removelast l) = pred (length l).
Proof.
  induction l; trivial.
  destruct l; trivial.
  simpl in *.
  rewrite IHl; trivial.
Qed.

Section combining.

Lemma combine_nth_in {A B : Type} (l : list A) (l' : list B) (n : nat) (x : A) (y : B) :
  n < min (length l) (length l') ->
  nth n (combine l l') (x, y) = (nth n l x, nth n l' y).
Proof.
  revert l' n.
  induction l; simpl; intros l' n nlt.
  - omega.
  - destruct l'; simpl in *.
    + omega.
    + destruct n; simpl; trivial.
      apply IHl.
      omega.
Qed.

Lemma combine_map {A B C D:Type} (f:A->C) (g:B->D) (l1:list A) (l2:list B) :
  combine (map f l1) (map g l2) = map (fun '(x,y) => (f x, g y)) (combine l1 l2).
Proof.
  revert l2.
  induction l1; intros l2; simpl; trivial.
  destruct l2; simpl; trivial.
  f_equal.
  auto.
Qed.

Lemma combine_self {A:Type} (l:list A) :
  combine l l = map (fun x => (x,x)) l.
Proof.
  induction l; simpl; trivial.
  f_equal; trivial.
Qed.

Lemma combine_nil_l {A B} (l:list B) : combine (@nil A) l = nil.
Proof.
  reflexivity.
Qed.

Lemma combine_nil_r {A B} (l:list A) : combine l (@nil B) = nil.
Proof.
  destruct l; trivial.
Qed.

Lemma combine_swap {A B} (l1:list A) (l2:list B) : combine l1 l2 = map (fun xy => (snd xy, fst xy)) (combine l2 l1).
Proof.
  revert l2; induction l1; simpl; intros
  ; destruct l2; simpl; trivial.
  rewrite IHl1; trivial.
Qed.

Lemma combine_domain_eq {A B} (x:list A) (y:list B) :
  length x = length y -> domain (combine x y) = x.
Proof.
  revert y.
  induction x; destruct y; simpl in *; intros
  ; try easy.
  inversion H.
  rewrite IHx; trivial.
Qed.

Lemma list_prod_map {A B C D:Type} (f:A->C) (g:B->D) (l1:list A) (l2:list B) :
  list_prod (map f l1) (map g l2) = map (fun '(x,y) => (f x, g y)) (list_prod l1 l2).
Proof.
  revert l2.
  induction l1; intros l2; simpl; trivial.
  rewrite map_app.
  repeat rewrite map_map.
  rewrite IHl1.
  trivial.
Qed.

Lemma list_prod_nil_l {A B} (l:list B) : list_prod (@nil A) l = nil.
Proof.
  reflexivity.
Qed.

Lemma list_prod_nil_r {A B} (l:list A) : list_prod l (@nil B) = nil.
Proof.
  induction l; trivial.
Qed.

Lemma list_prod_cons2_pred {A B} (l1:list A) a (l2:list B) :
  Permutation (list_prod l1 (a :: l2)) (map (fun x : A => (x, a)) l1 ++ list_prod l1 l2).
Proof.
  revert a l2.
  induction l1; simpl; intros.
  - reflexivity.
  - rewrite IHl1.
    apply Permutation_cons; trivial.
    repeat rewrite <- app_ass.
    apply Permutation_app; [ | reflexivity ].
    rewrite Permutation_app_swap.
    reflexivity.
Qed.

Lemma list_prod_swap {A B} (l1:list A) (l2:list B) : Permutation (list_prod l1 l2) (map (fun xy => (snd xy, fst xy)) (list_prod l2 l1)).
Proof.
  revert l1; induction l2; simpl; intros.
  - rewrite list_prod_nil_r; simpl.
    reflexivity.
  - rewrite map_app.
    rewrite <- IHl2.
    rewrite map_map; simpl.
    apply list_prod_cons2_pred.
Qed.

Instance list_prod_perm_proper1 {A B} : Proper ((@Permutation A) ==> eq ==> (@Permutation (A*B))) (@list_prod A B).
Proof.
  intros l1 l1' perm1 l2' l2 eqq; subst.
  revert l1 l1' perm1.
  apply Permutation_ind_bis; intros.
  - reflexivity.
  - simpl.
    rewrite H0; reflexivity.
  - simpl.
    rewrite H0.
    repeat rewrite <- app_ass.
    apply Permutation_app; [ | reflexivity ].
    rewrite Permutation_app_swap.
    reflexivity.
  - etransitivity; eauto.
Qed.

Global Instance list_prod_perm_proper {A B} : Proper ((@Permutation A) ==> (@Permutation B) ==> (@Permutation (A*B))) (@list_prod A B).
Proof.
  intros l1 l1' perm1 l2 l2' perm2.
  transitivity (list_prod l1' l2).
  - apply list_prod_perm_proper1; trivial.
  - rewrite (list_prod_swap l1' l2).
    rewrite (list_prod_swap l1' l2').
    apply Permutation_map.
    apply list_prod_perm_proper1; trivial.
Qed.

Lemma combine_incl_list_prod {A B} (l1:list A) (l2:list B) : incl (combine l1 l2) (list_prod l1 l2).
Proof.
  intros [x y] inn.
  apply in_prod_iff.
  split.
  - eapply in_combine_l; eauto.
  - eapply in_combine_r; eauto.
Qed.

End combining.

Definition adjacent_pairs {A:Type} (l:list A) := (combine l (tl l)).

Definition adjacent_pairs_alt {A:Type} (l:list A) := (combine (removelast l) (tl l)).

Lemma adjacent_pairs_alt_eq {A:Type} (l:list A) :
  adjacent_pairs l = adjacent_pairs_alt l.
Proof.
  unfold adjacent_pairs, adjacent_pairs_alt.
  induction l; simpl; trivial.
  destruct l; simpl in *; trivial.
  f_equal.
  trivial.
Qed.

Lemma adjacent_pairs_length {A:Type} (l:list A) : length (adjacent_pairs l) = pred (length l).
Proof.
  unfold adjacent_pairs.
  rewrite combine_length.
  rewrite tl_length.
  rewrite Nat.min_r; trivial.
  omega.
Qed.

Lemma adjacent_pairs_nth_in {A:Type} n (l:list A) d1 d2 :
  S n < length l ->
  nth n (adjacent_pairs l) (d1,d2) = (nth n l d1, nth (S n) l d2).
Proof.
  intros.
  unfold adjacent_pairs.
  rewrite combine_nth_in.
  - rewrite nth_tl; trivial.
  - rewrite tl_length.
    rewrite Nat.min_r; omega.
Qed.

Lemma adjacent_pairs_map {A B:Type} (f:A->B) (l:list A) :
  adjacent_pairs (map f l) = map (fun '(x,y) => (f x, f y)) (adjacent_pairs l).
Proof.
  unfold adjacent_pairs.
  rewrite tl_map, combine_map.
  trivial.
Qed.

Lemma adjacent_pairs_seq s n :
  adjacent_pairs (seq s n) = map (fun i => (i, S i)) (seq s (pred n)).
Proof.
  unfold adjacent_pairs.
  revert s.
  induction n; simpl; intros s; trivial.
  destruct n; simpl; trivial.
  f_equal.
  apply IHn.
Qed.


Require Import Basics.
Require Import Pos.Core.

Local Open Scope positive_scope.

(** ** Specification of [succ] in term of [add] *)

Lemma pos_add_1_r p : p + 1 = pos_succ p.
Proof.
  by destruct p.
Qed.

Lemma pos_add_1_l p : 1 + p = pos_succ p.
Proof.
  by destruct p.
Qed.

(** ** Specification of [add_carry] *)

Theorem pos_add_carry_spec p q : pos_add_carry p q = pos_succ (p + q).
Proof.
  revert q.
  induction p; destruct q; simpl; by apply ap.
Qed.

(** ** Commutativity *)

Theorem pos_add_comm p q : p + q = q + p.
Proof.
  revert q.
  induction p; destruct q; simpl; apply ap; trivial.
  rewrite 2 pos_add_carry_spec; by apply ap.
Qed.

(** ** Permutation of [add] and [succ] *)

Theorem pos_add_succ_r p q : p + pos_succ q = pos_succ (p + q).
Proof.
  revert q.
  induction p; destruct q; simpl; apply ap;
   auto using pos_add_1_r; rewrite pos_add_carry_spec; auto.
Qed.

Theorem pos_add_succ_l p q : pos_succ p + q = pos_succ (p + q).
Proof.
  rewrite pos_add_comm, (pos_add_comm p). apply pos_add_succ_r.
Qed.

Definition pos_add_succ p q : p + pos_succ q = pos_succ p + q.
Proof.
  by rewrite pos_add_succ_r, pos_add_succ_l.
Defined.

Definition pos_add_carry_spec_l q r
  : pos_add_carry q r = pos_succ q + r.
Proof.
  by rewrite pos_add_carry_spec, pos_add_succ_l.
Qed.

Definition pos_add_carry_spec_r q r
  : pos_add_carry q r = q + pos_succ r.
Proof.
  by rewrite pos_add_carry_spec, pos_add_succ_r.
Defined.

(** ** No neutral elements for addition *)
Lemma pos_add_no_neutral p q : q + p <> p.
Proof.
  revert q.
  induction p as [ |p IHp|p IHp]; intros [ |q|q].
  1,3: apply x0_neq_xH.
  1: apply x1_neq_xH.
  1,3: apply x1_neq_x0.
  2,4: apply x0_neq_x1.
  1,2: intro H; apply (IHp q).
  1: apply x0_inj, H.
  apply x1_inj, H.
Qed.

(** * Injectivity of pos_succ *)
Lemma pos_succ_inj n m : pos_succ n = pos_succ m -> n = m.
Proof.
  revert m.
  induction n as [ | n x | n x]; induction m as [ | m y | m y].
  + reflexivity.
  + intro p.
    destruct (x0_neq_x1 p).
  + intro p.
    simpl in p.
    apply x0_inj in p.
    destruct m.
    1,3: destruct (xH_neq_x0 p).
    destruct (xH_neq_x1 p).
  + intro p.
    destruct (x1_neq_x0 p).
  + simpl.
    intro p.
    by apply ap, x1_inj.
  + intro p.
    destruct (x1_neq_x0 p).
  + intro p.
    cbn in p.
    apply x0_inj in p.
    destruct n.
    1,3: destruct (x0_neq_xH p).
    destruct (x1_neq_xH p).
  + intro p.
    cbn in p.
    destruct (x0_neq_x1 p).
  + intro p.
    apply ap, x, x0_inj, p.
Defined.

(** ** Addition is associative *)

Theorem pos_add_assoc p q r : p + (q + r) = p + q + r.
Proof.
  revert q r.
  induction p.
  + intros [|q|q] [|r|r].
    all: try reflexivity.
    all: simpl.
    1,2: by destruct r.
    1,2: apply ap; symmetry.
    1: apply pos_add_carry_spec.
    1: apply pos_add_succ_l.
    apply ap.
    rewrite pos_add_succ_l.
    apply pos_add_carry_spec.
  + intros [|q|q] [|r|r].
    all: try reflexivity.
    all: cbn; apply ap.
    3,4,6: apply IHp.
    1: apply pos_add_1_r.
    1: symmetry; apply pos_add_carry_spec_r.
    1: apply pos_add_succ_r.
    rewrite 2 pos_add_carry_spec_l.
    rewrite <- pos_add_succ_r.
    apply IHp.
  + intros [|q|q] [|r|r].
    all: cbn; apply ap.
    1: apply pos_add_1_r.
    1: apply pos_add_carry_spec_l.
    1: apply pos_add_succ.
    1: apply pos_add_carry_spec.
    1: apply IHp.
    2: symmetry; apply pos_add_carry_spec_r.
    1,2: rewrite 2 pos_add_carry_spec, ?pos_add_succ_l.
    1,2: apply ap, IHp.
    rewrite ?pos_add_carry_spec_r.
    rewrite pos_add_succ.
    apply IHp.
Qed.

(** ** One is neutral for multiplication *)

Lemma pos_mul_1_l p : 1 * p = p.
Proof.
  reflexivity.
Qed.

Lemma pos_mul_1_r p : p * 1 = p.
Proof.
  induction p; cbn; trivial; by apply ap.
Qed.

(** pos_succ and doubling functions *)

Lemma pos_pred_double_succ n
  : pos_pred_double (pos_succ n) = n~1.
Proof.
  induction n as [|n|n nH].
  all: trivial.
  cbn; apply ap, nH.
Qed.

Lemma pos_succ_pred_double n
  : pos_succ (pos_pred_double n) = n~0.
Proof.
  induction n as [|n nH|n].
  all: trivial.
  cbn; apply ap, nH.
Qed.

(** ** Iteration and pos_succ *)
Lemma pos_iter_succ_l {A} (f : A -> A) p a
  : pos_iter f (pos_succ p) a = f (pos_iter f p a).
Proof.
  unfold pos_iter.
  by rewrite pos_peano_ind_beta_pos_succ.
Qed.

Lemma pos_iter_succ_r {A} (f : A -> A) p a
  : pos_iter f (pos_succ p) a = pos_iter f p (f a).
Proof.
  revert p f a.
  serapply pos_peano_ind.
  1: hnf; intros; trivial.
  hnf; intros p q f a.
  refine (_ @ _ @ _^).
  1,3: unfold pos_iter;
    by rewrite pos_peano_ind_beta_pos_succ.
  apply ap.
  apply q.
Qed.


Require Import extensionality.
Require Import irrelevance.
Require Import Nat.
Require Import Max2.

(********************************************************************************)
(************************* Parial Order on 'option a' ***************************)
(********************************************************************************)

Definition ole (a:Type) (x y:option a) : Prop :=
    forall (v:a), x = Some v -> y = Some v.

Arguments ole {a} _ _.

Lemma ole_refl : forall (a:Type) (x:option a), ole x x.
Proof. intros a x v H. assumption. Qed.

Lemma ole_anti : forall (a:Type) (x y:option a),
    ole x y -> ole y x -> x = y.
Proof.
    unfold ole. intros a x y Hxy Hyx. destruct x as [v|], y as [w|].
        - apply Hyx. reflexivity.
        - symmetry. apply Hxy. reflexivity.
        - apply Hyx. reflexivity.
        - reflexivity.
Qed.

Lemma ole_trans : forall (a:Type) (x y z:option a),
    ole x y -> ole y z -> ole x z.
Proof.
    unfold ole. intros a x y z Hxy Hyz v H.
    apply Hyz, Hxy. assumption.
Qed.

Definition ole' (a:Type) (x y:option a) : Prop :=
    match x with
    | None          => True
    | Some v        =>
        match y with
        | None      => False
        | Some w    => v = w
        end
    end.

Arguments ole' {a} _ _.

Lemma ole_equivalence : forall (a:Type) (x y:option a),
    ole x y <-> ole' x y.
Proof.
    intros a x y. unfold ole, ole'. destruct x as [v|], y as [w|]; split.
    - intros H. assert (Some w = Some v) as E.
        { apply H. reflexivity. }
        inversion E. reflexivity.
    - intros H1. subst. intros v H. assumption.
    - intros H. assert (None = Some v) as E.
        { apply H. reflexivity. }
        inversion E.
    - intros H1. exfalso. assumption.
    - intros H. apply I.
    - intros H1 v H2. inversion H2.
    - intros H. apply I.
    - intros H1 v H2. assumption.
Qed.

(********************************************************************************)
(******************************* Monotone Maps **********************************)
(********************************************************************************)

(* Bad definition from cpdt                                                     *)
Definition monotone (a:Type) (f:nat -> option a) : Prop :=
    forall (n:nat) (v:a), f n = Some v ->
    forall (m:nat), n <= m -> f m = Some v.

Arguments monotone {a} _.

(* Checking bad definition makes sense                                          *)
Lemma monotone_check : forall (a:Type) (f:nat -> option a),
    monotone f <-> forall (n m:nat), n <= m -> ole (f n) (f m).
Proof.
    intros a f. split; unfold monotone, ole; intros H.
    - intros n m H1 v H2. apply H with n; assumption.
    - intros n v H1 m H2. apply H with n; assumption.
Qed.

(********************************************************************************)
(******************************** Computations **********************************)
(********************************************************************************)

(* A computation is a monotone map                                              *)
Definition Computation (a:Type) : Type := { f:nat -> option a | monotone f }.

Definition eval (a:Type) (c:Computation a) (n:nat) : option a := proj1_sig c n.

Arguments eval {a}.

(* Expresses the fact that computation k yields value v for input n             *)
Definition runTo (a:Type) (k:Computation a) (n:nat) (v:a) : Prop :=
    eval k n = Some v.

Arguments runTo {a} _ _ _.

(* Expresses the fact that computation k eventually yields v                    *)
Definition run (a:Type) (k:Computation a) (v:a) : Prop :=
    exists (n:nat), runTo k n v.

Arguments run {a} _ _.

(* We are defining a value with coq tactics. This value is essentially a tuple  *)
(* where the second coordinate is a proof, so using tactics appears to be       *)
(* making sense. Note that this proof is not opaque ('Defined' rather than      *)
(* 'Qed'). Alternatively, we could have defined the proof separately as some    *)
(* sort of lemma and defined the value 'bot' in the usual direct way by         *)
(* referring to this lemma                                                      *)

Definition bot' (a:Type) : Computation a.
    unfold Computation. exists (fun (_:nat) => None).
    unfold monotone. intros n v H. inversion H.
Defined.

Arguments bot' {a}.

Definition botf (a:Type) (n:nat) : option a := None.

Arguments botf {a} _.

Lemma botp : forall (a:Type), monotone (@botf a).
Proof.
    unfold monotone, botf. intros a n v H. inversion H.
Qed.

Arguments botp {a}.

(* A lot better I think, details of proof decoupled from computation logic      *)
Definition bot (a:Type) : Computation a :=
    exist monotone botf botp.

Arguments bot {a}.

(********************************************************************************)
(************************ Equality between Computations *************************)
(********************************************************************************)

Definition ceq (a:Type) (k1 k2:Computation a) : Prop :=
    forall (n:nat), eval k1 n = eval k2 n.

Arguments ceq {a} _ _.

Notation "x == y" := (ceq x y) (at level 90).

Lemma ceq_refl : forall (a:Type) (x:Computation a), x == x.
Proof.
    intros a [f p] n. simpl. reflexivity.
Qed.

Lemma ceq_sym  : forall (a:Type) (x y:Computation a),
    x == y -> y == x.
Proof.
    intros a [f p] [g q] H n. simpl. symmetry. apply H.
Qed.

Lemma ceq_trans : forall (a:Type) (x y z:Computation a),
    x == y -> y == z -> x == z.
Proof.
    intros a [f p] [g q] [h r] Hxy Hyz n. simpl.
    apply eq_trans with (g n).
    - apply Hxy.
    - apply Hyz.
Qed.

(********************************************************************************)
(**************************** Computation as Monad ******************************)
(********************************************************************************)

(* 'return' is a keyword in coq, so using 'pure' instead                        *)
Definition pure' (a:Type) : a -> Computation a.
    intros v.
    unfold Computation. exists (fun (_:nat) => Some v).
    unfold monotone. intros n w H. inversion H. subst.
    intros m H'. reflexivity.
Defined.

Arguments pure' {a} _.

(* computation is made explicit                                                 *)
Definition puref (a:Type)(x:a)(n:nat) : option a := Some x.

Arguments puref {a} _ _.

(* statement of what it is we are proving is also clear                         *)
Lemma purep : forall (a:Type) (x:a), monotone (puref x).
Proof.
    unfold monotone, puref. intros a x n v H m H'.
    inversion H. subst. reflexivity.
Qed.

Arguments purep {a} _.

(* wrapping up in a single function, no complexity here                         *)
Definition pure (a:Type)(x:a) : Computation a :=
    exist monotone (puref x) (purep x).

Arguments pure {a} _.

(* Checking 'pure' has the intended semantics                                   *)
Lemma run_pure : forall (a:Type) (v:a), run (pure v) v.
Proof.
    intros a v. unfold run. exists 0. reflexivity.
Qed.

(* Totally useless definition. computation logic and proof are coupled          *)
Definition bind'(a b:Type)(k:Computation a)(g:a -> Computation b):Computation b.
    unfold Computation.
    remember (fun (n:nat) =>
        match eval k n with
        |   Some va => proj1_sig (g va) n
        |   None    => None
        end) as gf eqn:GF.
    exists gf.
    unfold monotone.
    intros n vb H m I.
    destruct k as [f Mf]. simpl in GF.
    unfold monotone in Mf.
    rewrite GF in H. rewrite GF.
    destruct (f n) as [va|] eqn:Fn.
        - destruct (f m) as [va'|] eqn:Fm.
            + assert (f m = Some va) as E.
                { apply Mf with n; assumption. }
              rewrite Fm in E. inversion E.
              destruct (g va) as [g' Mg']. simpl. simpl in H.
              unfold monotone in Mg'. apply Mg' with n; assumption.
            + assert (f m = Some va) as E.
                { apply Mf with n; assumption. }
              rewrite Fm in E. inversion E.
        - inversion H.
Defined.

Arguments bind' {a} {b} _ _.

(* computation logic of bind is plainly visible                                 *)
Definition bindf
    (a b:Type)
    (k:Computation a)
    (g:a -> Computation b)
    (n:nat)
    :option b :=
    match k with                    (* unpack computation k             *)
    | exist _ f _ =>
        match (f n) with            (* result of f after n cycles       *)
        | None   => None            (* first computation fails          *)
        | Some v =>                 (* first computation returns value  *)
            match (g v) with        (* unpack second computation        *)
            | exist _ h _ => h n    (* returns result after n cycles    *)
            end
        end
    end.

Arguments bindf {a} {b} _ _ _.

(* what we are proving is clear                                                 *)
Lemma bindp : forall (a b:Type) (k:Computation a) (g:a -> Computation b),
    monotone (bindf k g).
Proof.
    unfold monotone, bindf. intros a b [f p] g n v H m H'.
    destruct (f n) as [x|] eqn:E.
    - unfold monotone in p. rewrite (p n x).
        + destruct (g x) as [h q]. unfold monotone in q.
          apply q with n; assumption.
        + assumption.
        + assumption.
    - inversion H.
Qed.

Arguments bindp {a} {b} _ _.

(* packing adds no complexity                                                   *)
Definition bind (a b:Type) (k:Computation a) (g:a -> Computation b)
    : Computation b := exist monotone (bindf k g) (bindp k g).

Arguments bind {a} {b}.

Notation "k >>= g" := (bind k g) (at level 50, left associativity).

(* checking bind has the intended semantics                                      *)
Lemma run_bind : forall (a b:Type) (k:Computation a) (h:a -> Computation b),
    forall (x:a) (y:b), run k x -> run (h x) y -> run (k >>= h) y.
Proof.
    intros a b [f p] h x y [n Hx] [m Hy].
    destruct (h x) as [g q] eqn:H.
    unfold runTo in Hx. simpl in Hx.
    unfold runTo in Hy. simpl in Hy.
    unfold monotone in p. unfold monotone in q.
    unfold run. unfold runTo.
    exists (max n m). unfold bind. simpl.
    assert (f (max n m) = Some x) as E.
        { apply p with n. assumption. apply n_le_max. }
    rewrite E, H. simpl. apply q with m.
        - assumption.
        - apply m_le_max.
Qed.

(********************************************************************************)
(************************** Checking Monad Laws *********************************)
(********************************************************************************)

Lemma left_identity : forall (a b:Type) (x:a) (h:a -> Computation b),
    (pure x) >>= h == h x.
Proof. intros a b x h n. simpl. destruct (h x) as [f p]. reflexivity. Qed.

Lemma right_identity : forall (a:Type) (k:Computation a),
    k >>= pure == k.
Proof. intros a [f p] n. simpl. destruct (f n) as [v|]; reflexivity. Qed.

Lemma associativity : forall (a b c:Type),
    forall (k:Computation a) (f:a -> Computation b) (g:b -> Computation c),
    k >>= f >>= g == k >>= (fun (x:a) => (f x) >>= g).
Proof.
    intros a b c [k p] f g n. simpl. destruct (k n) as [v|].
    - destruct (f v) as [h q]. reflexivity.
    - reflexivity.
Qed.

(********************************************************************************)
(********************** Partial Order on Computations  **************************)
(********************************************************************************)

Definition cle (a:Type) (x y:Computation a) : Prop :=
    forall (n:nat), ole (eval x n) (eval y n).

Arguments cle {a} _ _.

Lemma cle_refl : forall (a:Type) (x:Computation a), cle x x.
Proof. intros a [f p] n. apply ole_refl. Qed.

(* Assuming extensionality and proof irrelevance                                *)
Lemma cle_anti : forall (a:Type) (x y:Computation a),
    cle x y -> cle y x -> x = y.
Proof.
    unfold cle. intros a [f p] [g q]. simpl. intros H1 H2.
    assert (f = g) as H.
        { apply extensionality. intros n. apply ole_anti.
          - apply H1.
          - apply H2.
        }
    clear H1 H2. revert p q. subst. intros p q.
    assert (p = q) as H. { apply irrelevance. } subst.
    reflexivity.
Qed.

Lemma cle_trans : forall (a:Type) (x y z:Computation a),
    cle x y -> cle y z -> cle x z.
Proof.
    unfold cle. intros a [f p] [g q] [h r]. simpl. intros H1 H2 n.
    apply ole_trans with (g n).
        - apply H1.
        - apply H2.
Qed.

Definition cle' (a:Type) (x y:Computation a) : Prop :=
    forall (n:nat) (v:a), runTo x n v -> runTo y n v.

Arguments cle' {a} _ _.

Lemma cle_equivalence: forall (a:Type) (x y:Computation a),
    cle x y <-> cle' x y.
Proof.
    unfold cle, cle', ole, runTo. intros a x y. split; intros H; assumption.
Qed.

(********************************************************************************)
(************** Partial Order on Arrows 'a -> Computation b'  *******************)
(********************************************************************************)

Definition cfle (a b:Type) (f g:a -> Computation b) : Prop :=
    forall (x:a), cle (f x) (g x).

Arguments cfle {a} {b} _ _.

Lemma cfle_refl : forall (a b:Type) (f:a -> Computation b), cfle f f.
Proof.
    unfold cfle. intros a b f x. apply cle_refl.
Qed.

Lemma cfle_anti : forall (a b:Type) (f g:a -> Computation b),
    cfle f g -> cfle g f -> f = g.
Proof.
    unfold cfle. intros a b f g H1 H2. apply extensionality.
    intros x. apply cle_anti.
        - apply H1.
        - apply H2.
Qed.

Lemma cfle_trans : forall (a b:Type) (f g h:a -> Computation b),
    cfle f g -> cfle g h -> cfle f h.
Proof.
    unfold cfle. intros a b f g h H1 H2 x.
    apply cle_trans with (g x).
        - apply H1.
        - apply H2.
Qed.

(* 'slice at n', just a preorder though                                         *)
Definition cfle_n (a b:Type) (n:nat) (f g:a -> Computation b) : Prop :=
    forall (x:a), ole (eval (f x) n) (eval (g x) n).

Arguments cfle_n {a} {b}.

Lemma cfle_n_refl : forall (a b:Type) (n:nat) (f:a -> Computation b),
    cfle_n n f f.
Proof. intros a b n f x. apply ole_refl. Qed.

Lemma cfle_n_trans : forall (a b:Type) (n:nat) (f g h:a -> Computation b),
    cfle_n n f g -> cfle_n n g h -> cfle_n n f h.
Proof.
    intros a b n f g h H1 H2 x. apply ole_trans with (eval (g x) n).
        - apply H1.
        - apply H2.
Qed.

(********************************************************************************)
(************************* Continuous Function on Arrows  ***********************)
(********************************************************************************)

Definition continuous (a b: Type)(F:(a -> Computation b)->(a -> Computation b)):=
    forall (f g:a -> Computation b)(n:nat),
        cfle_n n f g  -> cfle_n n (F f) (F g).

Arguments continuous {a} {b}.

(* This is a stronger property than just being monotone wr to cfle              *)

Lemma continuous_stronger : forall (a b:Type)
    (F:(a -> Computation b)->(a -> Computation b)), continuous F ->
        forall (f g:a -> Computation b), cfle f g -> cfle (F f) (F g).
Proof.
    intros a b F C f g H x n. revert x. apply C. intros x. apply H.
Qed.

Definition Operator (a b:Type) : Type :=
    {F: (a -> Computation b) -> (a -> Computation b) | continuous F}.

Definition ap (a b:Type) (F:Operator a b) (f:a -> Computation b)
    : a -> Computation b := proj1_sig F f.

Arguments ap {a} {b}.

Notation "F $ f" :=(ap F f) (at level 60, right associativity).

(********************************************************************************)
(************************ The Fixed Point of an Operator  ***********************)
(********************************************************************************)

Definition init (a b:Type) : a -> Computation b := (fun x => bot).

Arguments init {a} {b}.

Fixpoint iter (a b:Type) (F:Operator a b) (n:nat) : a -> Computation b :=
    match n with
    | 0     => init
    | S n   => F $ (iter a b F n)
    end.

Arguments iter {a} {b}.

Lemma iter_increasing_ : forall (a b:Type) (F:Operator a b) (n:nat),
    cfle (iter F n) (iter F (S n)).
Proof.
    intros a b [F p]. induction n as [|n IH].
    - unfold cfle, iter, cle, init, ole, bot, ap, botf.
      simpl. intros x n v H. inversion H.
    - intros x m. simpl. revert x. apply p. intros x. apply IH.
Qed.

Lemma iter_increasing : forall (a b:Type) (F:Operator a b) (n m:nat),
    n <= m -> cfle (iter F n) (iter F m).
Proof.
    intros a b F n m H. induction H as [|m H IH].
    - apply cfle_refl.
    - apply cfle_trans with (iter F m).
        + assumption.
        + apply iter_increasing_.
Qed.

Definition Fixf (a b:Type) (F:Operator a b) (x:a) (n:nat) : option b :=
    eval (iter F n x) n.

Arguments Fixf {a} {b}.

Lemma Fixp : forall (a b:Type) (F:Operator a b) (x:a), monotone (Fixf F x).
Proof.
    intros a b F x. apply monotone_check. intros n m H.
    unfold Fixf. apply ole_trans with (proj1_sig (iter F n x) m).
    - destruct (iter F n x) as [f p]. simpl. apply monotone_check; assumption.
    - apply iter_increasing. assumption.
Qed.

Arguments Fixp {a} {b}.

Definition Fix (a b:Type) (F:Operator a b) (x:a) : Computation b :=
    exist monotone (Fixf F x) (Fixp F x).

Arguments Fix {a} {b}.

(* key lemma                                                                    *)
Lemma FFix_iter : forall (a b:Type) (F:Operator a b) (x:a) (n:nat),
    eval ((F $ Fix F) x) n = eval (iter F (S n) x) n.
Proof.
    intros a b F x n.
    destruct F as [F' p] eqn:E. rewrite <- E.
    unfold continuous, cfle_n in p.
    remember (Fix F) as f eqn:E1.
    remember (iter F n) as g eqn:E2.
    assert (eval (F' f x) n = eval ((F $ f) x) n) as E3.
        { unfold eval, ap. rewrite E. reflexivity. }
    assert (eval (F' g x) n = eval (iter F (S n) x) n) as E4.
        { unfold eval. rewrite E2. unfold iter, ap. rewrite E. reflexivity. }
    assert (forall (x:a), eval (f x) n = eval (g x) n) as H.
        { intros y. rewrite E1, E2. unfold Fix,Fixf, iter, eval. reflexivity. }
    rewrite <- E3, <- E4.
    apply ole_anti; apply p; intros y; rewrite H; apply ole_refl.
Qed.

(* If computation F (Fix F) terminates @x, so will computation Fix F @x         *)
Lemma FFix_Fix : forall (a b:Type) (F:Operator a b) (x:a) (n:nat),
    ole (eval ((F $ Fix F) x) n) (eval (Fix F x) (S n)).
Proof.
    intros a b F x n. apply ole_trans with (eval (iter F (S n) x) n).
    - rewrite FFix_iter. apply ole_refl.
    - assert (eval (Fix F x) (S n) = eval (iter F (S n) x) (S n)) as E.
        { reflexivity. }
      rewrite E. destruct (iter F (S n) x) as [f p]. simpl.
      apply monotone_check.
        + assumption.
        + apply le_S, le_n.
Qed.

(* If computation Fix F terminates @x, so will computation F (Fix F) @x         *)
Lemma Fix_FFix : forall (a b:Type) (F:Operator a b) (x:a) (n:nat),
    ole (eval (Fix F x) n) (eval ((F $ Fix F) x) n).
Proof.
    intros a b F x n. rewrite FFix_iter. apply iter_increasing_.
Qed.

(* checking Fix has the intended semantics  *)
(* F (Fix F) terminates iff (Fix F) terminates, and both results equal          *)
Theorem run_Fix : forall (a b:Type) (F:Operator a b) (x:a) (v:b),
    run ((F $ Fix F) x) v <-> run (Fix F x) v.
Proof.
    intros a b F x v. split; unfold run, runTo; intros [n H].
    - exists (S n). apply FFix_Fix. assumption.
    - exists n. apply Fix_FFix. assumption.
Qed.


Theorem andb_eq_orb :
  forall(b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
intros b c.
destruct b.
- simpl. destruct c.
+ intros H. reflexivity.
+ intros H. rewrite H. reflexivity.
- simpl. destruct c.
+ intros H. rewrite H. reflexivity.
+ intros H. reflexivity.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.

Require Import Exponentiation.

(* Why3 goal *)
Notation power := Zpower.

Lemma power_is_exponentiation :
  forall x n, (0 <= n)%Z -> power x n = Exponentiation.power _ 1%Z Zmult x n.
Proof.
intros x [|n|n] H.
easy.
2: now elim H.
unfold Exponentiation.power, power, Zpower_pos.
now rewrite iter_nat_of_P.
Qed.

(* Why3 goal *)
Lemma Power_0 :
forall (x:Z), ((power x 0%Z) = 1%Z).
Proof.
intros x.
apply refl_equal.
Qed.

(* Why3 goal *)
Lemma Power_s :
forall (x:Z) (n:Z),
 (0%Z <= n)%Z -> ((power x (n + 1%Z)%Z) = (x * (power x n))%Z).
Proof.
intros x n h1.
rewrite Zpower_exp.
change (power x 1) with (x * 1)%Z.
ring.
now apply Zle_ge.
easy.
Qed.

(* Why3 goal *)
Lemma Power_s_alt :
forall (x:Z) (n:Z),
 (0%Z < n)%Z -> ((power x n) = (x * (power x (n - 1%Z)%Z))%Z).
intros x n h1.
rewrite <- Power_s.
f_equal; auto with zarith.
omega.
Qed.

(* Why3 goal *)
Lemma Power_1 :
forall (x:Z), ((power x 1%Z) = x).
Proof.
exact Zmult_1_r.
Qed.

(* Why3 goal *)
Lemma Power_sum :
forall (x:Z) (n:Z) (m:Z),
 (0%Z <= n)%Z ->
 ((0%Z <= m)%Z -> ((power x (n + m)%Z) = ((power x n) * (power x m))%Z)).
Proof.
intros x n m Hn Hm.
now apply Zpower_exp; apply Zle_ge.
Qed.

(* Why3 goal *)
Lemma Power_mult :
forall (x:Z) (n:Z) (m:Z),
 (0%Z <= n)%Z ->
 ((0%Z <= m)%Z -> ((power x (n * m)%Z) = (power (power x n) m))).
Proof.
intros x n m Hn Hm.
rewrite 3!power_is_exponentiation ; auto with zarith.
apply Power_mult ; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Power_comm1 :
forall (x:Z) (y:Z),
 ((x * y)%Z = (y * x)%Z) ->
 forall (n:Z), (0%Z <= n)%Z -> (((power x n) * y)%Z = (y * (power x n))%Z).
Proof.
intros x y h1 n h2.
auto with zarith.
Qed.

(* Why3 goal *)
Lemma Power_comm2 :
forall (x:Z) (y:Z),
 ((x * y)%Z = (y * x)%Z) ->
 forall (n:Z),
  (0%Z <= n)%Z -> ((power (x * y)%Z n) = ((power x n) * (power y n))%Z).
Proof.
intros x y h1 n h2.
rewrite 3!power_is_exponentiation ; auto with zarith.
apply Power_comm2 ; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Power_non_neg :
forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (0%Z <= y)%Z) -> (0%Z <= (power x y))%Z.
intros x y (h1,h2).
now apply Z.pow_nonneg.
Qed.

Open Scope Z_scope.

(* Why3 goal *)
Lemma Power_monotonic :
forall (x:Z) (n:Z) (m:Z),
 ((0%Z < x)%Z /\ ((0%Z <= n)%Z /\ (n <= m)%Z)) ->
 ((power x n) <= (power x m))%Z.
intros.
apply Z.pow_le_mono_r; auto with zarith.
Qed.


Require Export P03.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  exact FILL_IN_HERE. Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

Section HilbertSaxiom.

Variables A B C : Prop.

Lemma HilbertS : (A -> B -> C) -> (A -> B) -> A -> C.
Proof.
move=> hAiBiC hAiB hA.
move: hAiBiC.
apply.
  by [].
by apply: hAiB.
Qed.

Hypotheses (hAiBiC : A -> B -> C) (hAiB : A -> B) (hA : A).

Lemma HilbertS2 : C.
Proof.
apply: hAiBiC; first by apply: hA.
exact: hAiB.
Qed.

Check (hAiB hA).

Lemma HilbertS3 : C.
Proof. by apply: hAiBiC; last exact: hAiB. Qed.

Lemma HilbertS4 : C.
Proof. exact:  (hAiBiC _ (hAiB _)). Qed.

Lemma HilbertS5 : C.
Proof. exact: hAiBiC (hAiB _). Qed.

Lemma HilbertS6 : C.
Proof. exact HilbertS5. Qed.

End HilbertSaxiom.

Section Symmetric_Conjunction_Disjunction.

Print bool.

Lemma andb_sym : forall A B : bool, A && B -> B && A.
Proof.
case.
  by case.
by [].
Qed.

Lemma andb_sym2 : forall A B : bool, A && B -> B && A.
Proof. by case; case. Qed.

Lemma andb_sym3 : forall A B : bool, A && B -> B && A.
Proof. by do 2! case. Qed.

Variables (C D : Prop) (hC : C) (hD : D).
Check (and C D).
Print and.
Check conj.
Check (conj hC hD).

Lemma and_sym : forall A B : Prop, A /\ B -> B /\ A.
Proof. by move=> A1 B []. Qed.

Print or.

Check or_introl.

Lemma or_sym : forall A B : Prop, A \/ B -> B \/ A.
Proof. by move=> A B [hA | hB]; [apply: or_intror | apply: or_introl]. Qed.

Lemma or_sym2 : forall A B : bool, A \/ B -> B \/ A.
Proof. by move=> [] [] AorB; apply/orP; move/orP : AorB. Qed.

End Symmetric_Conjunction_Disjunction.

Section R_sym_trans.

Variables (D : Type) (R : D -> D -> Prop).

Hypothesis R_sym : forall x y, R x y -> R y x.

Hypothesis R_trans : forall x y z, R x y -> R y z -> R x z.

Lemma refl_if : forall x : D, (exists y, R x y) -> R x x.
Proof.
move=> x [y Rxy].
exact: R_trans (R_sym _ y _).
Qed.

End R_sym_trans.

Section Smullyan_drinker.

Variables (D : Type) (P : D -> Prop).
Hypotheses (d : D) (EM : forall A, A \/ ~A).

Lemma drinker : exists x, P x -> forall y, P y.
Proof.
(* case: (EM (exists y, ~P y)) => [[y notPy]| nonotPy] *)
have [[y notPy]| nonotPy] := EM (exists y, ~P y); first by exists y.
exists d => _ y; case: (EM (P y)) => // notPy.
by case: nonotPy; exists y.
Qed.

End Smullyan_drinker.

Section Equality.

Variable f : nat -> nat.
Hypothesis f00 : f 0 = 0.

Lemma fkk : forall k, k = 0 -> f k = k.
Proof. by move=> k k0; rewrite k0. Qed.

Lemma fkk2 : forall k, k = 0 -> f k = k.
Proof. by move=> k ->. Qed.

Variable f10 : f 1 = f 0.

Lemma ff10 : f (f 1) = 0.
Proof. by rewrite f10 f00. Qed.

Variables (D : eqType) (x y : D).

Lemma eq_prop_bool : x = y -> x == y.
Proof. by move/eqP. Qed.

Lemma eq_bool_prop : x == y -> x = y.
Proof. by move/eqP. Qed.

End Equality.

Section Using_Definition.

Variable U : Type.

Definition set := U -> Prop.

Definition subset (A B : set) := forall x, A x -> B x.

Definition transitive (T : Type) (R : T -> T -> Prop) :=
 forall x y z, R x y -> R y z -> R x z.

Lemma subset_trans : transitive set subset.
Proof.
rewrite /transitive /subset => x y z subxy subyz t xt.
by apply: subyz; apply: subxy.
Qed.

Lemma subset_trans2 : transitive set subset.
Proof.
move=> x y z subxy subyz t.
by move/subxy; move/subyz.
Qed.

End Using_Definition.

Section Basic_ssrnat.

Lemma three : S (S (S O)) = 3 /\ 3 = 0.+1.+1.+1.
Proof. by []. Qed.

Lemma concrete_plus : plus 16 64 = 80.
Proof. (*simpl.*) by []. Qed.

Lemma concrete_addn : 16 + 64 = 80.
Proof. (*simpl.*)  by []. Qed.

Lemma concrete_le : le 1 3.
Proof. by apply: (Le.le_trans _ 2); apply: Le.le_n_Sn. Qed.

Lemma concrete_big_le : le 16 64.
Proof. by auto 47 with arith. Qed.

Lemma concrete_big_leq : 0 <= 51.
Proof. by []. Qed.

Lemma semi_concrete_leq : forall n m, n <= m -> 51 + n <= 51 + m.
Proof. by []. Qed.

Lemma concrete_arith : (50 < 100) && (3 + 4 < 3 * 4 <= 17 - 2).
Proof. by []. Qed.

Lemma plus_com : forall m1 n1, n1 + m1 = m1 + n1.
Proof.
by elim=> [| n IHn m]; [elim | rewrite -[n.+1 + m]/(n + m).+1 -IHn; elim: m].
Qed.

End Basic_ssrnat.

Section Euclidean_division.

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

Definition edivn_rec d := fix loop (m q : nat) {struct m} :=
  if m - d is m'.+1 then loop m' q.+1 else (q, m).

Definition edivn m d := if d is d'.+1 then edivn_rec d' m 0 else (0, m).

CoInductive edivn_spec (m d : nat) : nat * nat -> Type :=
  EdivnSpec q r of m = q * d + r & (d > 0) ==> (r < d) : edivn_spec m d (q, r).

Lemma edivnP : forall m d, edivn_spec m d (edivn m d).
Proof.
move=> m [|d] //=; rewrite -{1}[m]/(0 * d.+1 + m).
elim: m {-2}m 0 (leqnn m) => [|n IHn] [|m] q //=; rewrite ltnS => le_mn.
rewrite subn_if_gt; case: ltnP => // le_dm.
rewrite -{1}(subnKC le_dm) -addSn addnA -mulSnr; apply: IHn.
apply: leq_trans le_mn; exact: leq_subr.
Qed.

Lemma edivn_eq : forall d q r, r < d -> edivn (q * d + r) d = (q, r).
Proof.
move=> d q r lt_rd; have d_gt0: 0 < d by exact: leq_trans lt_rd.
case: edivnP lt_rd => q' r'; rewrite d_gt0 /=.
wlog: q q' r r' / q <= q' by case (ltnP q q'); last symmetry; eauto.
rewrite leq_eqVlt; case: eqP => [-> _|_] /=; first by move/addnI->.
rewrite -(leq_pmul2r d_gt0); move/leq_add=> Hqr Eqr _; move/Hqr {Hqr}.
by rewrite addnS ltnNge mulSn -addnA Eqr addnCA addnA leq_addr.
Qed.

CoInductive edivn_spec_right : nat -> nat -> nat * nat -> Type :=
  EdivnSpec_right m d q r of m = q * d + r & (d > 0) ==> (r < d) :
  edivn_spec_right m d (q, r).

CoInductive edivn_spec_left (m d : nat)(qr : nat * nat) : Type :=
EdivnSpec_left of m = (fst qr) * d + (snd qr) & (d > 0) ==> (snd qr < d) :
   edivn_spec_left m d qr.

Lemma edivnP_left : forall m d, edivn_spec_left m d (edivn m d).
Proof.
move=> m [|d] //=; rewrite -{1}[m]/(0 * d.+1 + m).
elim: m {-2}m 0 (leqnn m) => [|n IHn] [|m] q //=; rewrite ltnS => le_mn.
rewrite subn_if_gt; case: ltnP => // le_dm.
rewrite -{1}(subnKC le_dm) -addSn addnA -mulSnr; apply: IHn.
apply: leq_trans le_mn; exact: leq_subr.
Qed.

Lemma edivnP_right : forall m d, edivn_spec_right m d (edivn m d).
Proof.
move=> m [|d] //=; rewrite -{1}[m]/(0 * d.+1 + m).
elim: m {-2}m 0 (leqnn m) => [|n IHn] [|m] q //=; rewrite ltnS => le_mn.
rewrite subn_if_gt; case: ltnP => // le_dm.
rewrite -{1}(subnKC le_dm) -addSn addnA -mulSnr; apply: IHn.
apply: leq_trans le_mn; exact: leq_subr.
Qed.

Lemma edivn_eq_right : forall d q r, r < d -> edivn (q * d + r) d = (q, r).
Proof.
move=> d q r lt_rd; have d_gt0: 0 < d by exact: leq_trans lt_rd.
set m := q * d + r; have: m = q * d + r by [].
set d' := d; have: d' = d by [].
case: (edivnP_right m d') => {m d'} m d' q' r' -> lt_r'd' d'd q'd'r'.
move: q'd'r' lt_r'd' lt_rd; rewrite d'd d_gt0 {d'd m} /=.
wlog: q q' r r' / q <= q' by case (ltnP q q'); last symmetry; eauto.
rewrite leq_eqVlt; case: eqP => [-> _|_] /=; first by move/addnI->.
rewrite -(leq_pmul2r d_gt0); move/leq_add=> Hqr Eqr _; move/Hqr {Hqr}.
by rewrite addnS ltnNge mulSn -addnA -Eqr addnCA addnA leq_addr.
Qed.

Lemma edivn_eq_left : forall d q r, r < d -> edivn (q * d + r) d = (q, r).
Proof.
move=> d q r lt_rd; have d_gt0: 0 < d by exact: leq_trans lt_rd.
case: (edivnP_left (q * d + r) d) lt_rd; rewrite d_gt0 /=.
set q':= (edivn (q * d + r) d).1; set r':= (edivn (q * d + r) d).2.
rewrite (surjective_pairing (edivn (q * d + r) d)) -/q' -/r'.
wlog: q r q' r' / q <= q' by case (ltnP q q'); last symmetry; eauto.
rewrite leq_eqVlt; case: eqP => [-> _|_] /=; first by move/addnI->.
rewrite -(leq_pmul2r d_gt0); move/leq_add=> Hqr Eqr _; move/Hqr {Hqr}.
by rewrite addnS ltnNge mulSn -addnA Eqr addnCA addnA leq_addr.
Qed.

End Euclidean_division.


(* -------------------------Description--------------------------------------

   In this file we capture the notion of ordType. This type has
   elements with decidable equality. This is almost same and inspired by
   ssreflect library.
   We also connect natural numbers and booleans to this type by creating
   canonical instances nat_eqType and bool_eqType.

   Structure type: Type:=  Pack {
                             E: Type;
                             eqb: E-> E -> bool;
                             eqP: forall x y, reflect (eq x y)(eqb x y) }.

  Notation "x == y":= (@Decidable.eqb _ x y)(at level 70, no associativity).

  Some important results are:

  Lemma eqP  (T:ordType)(x y:T): reflect (x=y)(eqb  x y).
  Lemma nat_eqP (x y:nat): reflect (x=y)(Nat.eqb x y).

  Canonical nat_eqType: eqType:=
                              {| Decidable.E:= nat; Decidable.eqb:= Nat.eqb;
                                  Decidable.eqP:= nat_eqP |}.

  Lemma bool_eqP (x y:bool): reflect (x=y)(Bool.eqb x y).

  Canonical bool_eqType: eqType:=
                             {| Decidable.E:= bool; Decidable.eqb:= Bool.eqb;
                                  Decidable.eqP:= bool_eqP |}.

   ------------------------------------------------------------------------- *)

From Coq Require Export ssreflect  ssrbool.
Require Export  GenReflect Lia.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module Decidable.
  Structure type: Type:= Pack {
                             E: Type;
                             eqb: E-> E -> bool;
                             eqP: forall x y, reflect (eq x y)(eqb x y) }.
  Module Exports.
    Coercion E : type >-> Sortclass.
    Notation eqType:= type.
    End Exports.
End Decidable.
Export Decidable.Exports.

Notation "x == y":= (@Decidable.eqb _ x y)(at level 70, no associativity): bool_scope.

Lemma eqP  (T:eqType)(x y:T): reflect (x=y)(x == y).
Proof. apply Decidable.eqP. Qed.

Hint Resolve eqP: core.

Lemma eq_to_eqb (T:eqType)(x y:T): (x=y)-> (x == y).
Proof.  intro; apply /eqP; auto. Qed.
Lemma eqb_to_eq (T:eqType) (x y:T): (x == y)-> (x=y).
Proof. intro;apply /eqP; auto. Qed.

Hint Immediate eq_to_eqb eqb_to_eq: core.

Lemma eq_refl (T: eqType)(x:T): x == x.
Proof. apply /eqP; auto. Qed.
Lemma eq_symm (T: eqType)(x y:T): (x == y)=(y == x).
Proof. { case (x== y) eqn:H1; case ( y== x) eqn:H2;  try(auto).
       { assert (H3: x=y). apply /eqP;auto.
         rewrite H3 in H2; rewrite eq_refl in H2; inversion H2. }
       { assert (H3: y= x). apply /eqP; auto.
         rewrite H3 in H1; rewrite eq_refl in H1; inversion H1.  } } Qed.

Hint Resolve eq_refl eq_symm: core.

(*--------- Natural numbers as an instance of eqType---------------------*)

Lemma nat_eqb_ref (x:nat): Nat.eqb x x = true.
Proof. induction x;simpl;auto. Qed.
Hint Resolve nat_eqb_ref:core.

Lemma nat_eqb_elim (x y:nat):  Nat.eqb x y -> x = y.
Proof. { revert y. induction x.
       { intro y. case y. tauto. simpl; intros n H; inversion H. }
       intro y. case y. simpl; intro H; inversion H. simpl. eauto. } Qed.
Hint Resolve nat_eqb_elim: core.

Lemma nat_eqb_intro (x y:nat): x=y -> Nat.eqb x y.
Proof. intro H. subst x. eauto. Qed.
Hint Resolve nat_eqb_intro: core.

Lemma nat_eqP (x y:nat): reflect (x=y)(Nat.eqb x y).
Proof. apply reflect_intro.  split; eauto. Qed.
Hint Resolve nat_eqP: core.

Canonical nat_eqType: eqType:= {| Decidable.E:= nat; Decidable.eqb:= Nat.eqb;
                                  Decidable.eqP:= nat_eqP |}.

(*--------- Bool as an instance of eqType --------------------------------*)
Lemma bool_eqb_ref (x:bool): Bool.eqb x x = true.
Proof. destruct x; simpl; auto. Qed.
Hint Resolve bool_eqb_ref: core.

Lemma bool_eqb_elim (x y:bool): (Bool.eqb x y) -> x = y.
Proof. destruct x; destruct y; simpl; try (auto || tauto). Qed.

Lemma bool_eqb_intro (x y:bool): x = y -> (Bool.eqb x y).
Proof. intros; subst y; destruct x; simpl; auto. Qed.

Hint Immediate bool_eqb_elim bool_eqb_intro: core.

Lemma bool_eqP (x y:bool): reflect (x=y)(Bool.eqb x y).
Proof. apply reflect_intro.
       split. apply bool_eqb_intro. apply bool_eqb_elim. Qed.
Hint Resolve bool_eqP: core.

Canonical bool_eqType: eqType:= {| Decidable.E:= bool; Decidable.eqb:= Bool.eqb;
                                  Decidable.eqP:= bool_eqP |}.

Ltac conflict_eq :=
    match goal with
    | H:  (?x == ?x)= false  |- _
      => switch_in H; cut(False);[tauto |auto]
    | H: ~(is_true (?x == ?x)) |- _
      => cut(False);[tauto |auto]
    | H: ~ (?x = ?x) |- _
      => cut(False);tauto
    | H: (?x == ?y) = true, H1: ?x <> ?y |- _
      => absurd (x = y);auto
    | H:  is_true (?x == ?y), H1: ?x <> ?y |- _
      => absurd (x = y);auto
    | H: (?x == ?y) = true, H1: ?y <> ?x |- _
      => absurd (y = x);[auto | (symmetry;auto)]
    | H: is_true (?x == ?y), H1: ?y <> ?x |- _
      => absurd (y = x);[auto | (symmetry;auto)]
    | H: (?x == ?y) = false, H1: ?x = ?y |- _
      => switch_in H; absurd (x=y); auto
    | H: (?x == ?y) = false, H1: ?y = ?x |- _
      => switch_in H; symmetry in H1; absurd (x=y); auto
    end.


Require Import Reals.
Require Import Interval.Tactic.

Goal forall x, (1 < x <= 5)%R -> (2 > Rabs x)%R -> (2 <= x + 1 <= 3)%R.
Proof.
intros x H1 H2.
interval with (i_prec 30).
Qed.


(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(** * Halting problem for one counter machines CM1_HALT  *)

(*
  Problem(s):
    One Counter Machine Halting (CM1_HALT)
*)

Require Import List Nat.

Definition State : Set := nat.
(* a configuration consists of a state and a counter value *)
Record Config : Set := mkConfig { state : State; value : nat }.

(* an instruction (n, q) maps
  a configuration (p, c) to (q, c * (n+2) / (n+1)) if c is divisible by (n+1)
  and otherwise to (p+1, c) *)
Definition Instruction : Set := State * nat.

(* an one counter machine is a list of instructions *)
Definition Cm1 : Set := list Instruction.

(* one counter machine step function *)
Definition step (M: Cm1) (x: Config) : Config :=
  match (value x), (nth_error M (state x)) with
  | 0, _ => x (* halting configuration *)
  | _, None => x (* halting configuration *)
  | _, Some (p, n) =>
      match modulo (value x) (n+1) with
      | 0 => {| state := p; value := ((value x) * (n+2)) / (n+1) |}
      | _ => {| state := 1 + state x; value := value x |}
      end
  end.

(* unfold step if the configuration is decomposed *)
Arguments step _ !x /.

(* halting configuration property *)
Definition halting (M : Cm1) (x: Config) : Prop := step M x = x.

(* One Counter Machine Halting Problem (with Denominators at most 4) *)
Definition CM1_HALT : { M : Cm1 | Forall (fun '(_, n) => n < 4) M } -> Prop :=
  fun '(exist _ M _) =>
    exists n, halting M (Nat.iter n (step M) {| state := 0; value := 1 |}).


(* File: Trees.v  (last edited on 25/10/2000) (c) Klaus Weich  *)

From Coq Require Import Le.
From IPC Require Export My_Arith.

(******   Tree stuff  ********************************************)

Section Trees.

Variable A : Set.

Inductive Tree : Set :=
    node : A -> Forest -> Tree
with Forest : Set :=
  | Nil_Forest : Forest
  | Cons_Forest : Tree -> Forest -> Forest.

Fixpoint height_tree (t : Tree) : nat :=
  match t with
  | node a succs => S (height_forest succs)
  end

 with height_forest (succs : Forest) : nat :=
  match succs with
  | Nil_Forest => 0
  | Cons_Forest t0 succs => max (height_tree t0) (height_forest succs)
  end.

(*
Inductive Tree : Set :=
| node : A -> (list Tree) -> Tree.

Fixpoint height_tree [t:Tree] : nat :=
  Cases t of
  | (node a succs) => (S (height_forest succs))
  end
with height_forest[succs:(list Tree)] : nat :=
  Cases succs of
  | nil => O
  | (cons t0 succs) => (max (height_tree t0) (height_forest succs))
  end.
Does not work!!
*)

Definition root (t : Tree) := match t with
                              | node a _ => a
                              end.
Definition successors (t : Tree) := match t with
                                    | node _ succs => succs
                                    end.

Inductive In_Forest (t0 : Tree) : Forest -> Prop :=
  | in_forest_head :
      forall succs : Forest, In_Forest t0 (Cons_Forest t0 succs)
  | in_forest_tail :
      forall (t1 : Tree) (succs : Forest),
      In_Forest t0 succs -> In_Forest t0 (Cons_Forest t1 succs).

Lemma height_in_le :
 forall (t : Tree) (succs : Forest),
 In_Forest t succs -> height_tree t <= height_forest succs.
intros t succs in_t.
elim in_t; clear in_t succs.

intros succs.
simpl in |- *.
apply le_n_max1.

intros t1 succs in_t le_t.
apply Nat.le_trans with (height_forest succs).
assumption.
simpl in |- *.
apply le_n_max2.
Qed.

Lemma My_Tree_ind :
 forall P : Tree -> Prop,
 (forall (a : A) (succs : Forest),
  (forall t : Tree, In_Forest t succs -> P t) -> P (node a succs)) ->
 forall t : Tree, P t.
intros P step.
cut (forall (n : nat) (t : Tree), height_tree t <= n -> P t).
intro claim.
intro t.
apply claim with (height_tree t).
trivial.
intros n; elim n; clear n.

intros t; elim t; clear t.
intros a succs u0.
elimtype False.
inversion_clear u0.

intros n ih t.
elim t; clear t.
intros a succs u0.
apply step; clear step.
intros t in_t.
apply ih; clear ih P.
apply le_S_n.
apply Nat.le_trans with (S (height_forest succs)).
apply le_n_S.
apply height_in_le; assumption.
assumption.
Qed.

Lemma My_Tree_rec :
 forall P : Tree -> Set,
 (forall (a : A) (succs : Forest),
  (forall t : Tree, In_Forest t succs -> P t) -> P (node a succs)) ->
 forall t : Tree, P t.
intros P step.
cut (forall (n : nat) (t : Tree), height_tree t <= n -> P t).
intro claim.
intro t.
apply claim with (height_tree t).
trivial.
intros n; elim n; clear n.

intros t; elim t; clear t.
intros a succs u0.
elimtype False.
inversion_clear u0.

intros n ih t.
elim t; clear t.
intros a succs u0.
apply step; clear step.
intros t in_t.
apply ih; clear ih P.
apply le_S_n.
apply Nat.le_trans with (S (height_forest succs)).
apply le_n_S.
apply height_in_le; assumption.
assumption.
Qed.

(* Successor relation  *)

Inductive Successor : Tree -> Tree -> Prop :=
  | successor_refl : forall t : Tree, Successor t t
  | successor_trans :
      forall t0 t1 : Tree,
      In_Forest t1 (successors t0) ->
      forall t2 : Tree, Successor t2 t1 -> Successor t2 t0.

Lemma succs_trans :
 forall t1 t2 : Tree,
 Successor t2 t1 -> forall t0 : Tree, Successor t1 t0 -> Successor t2 t0.
intros t1 t2 u0 t0 u1.
generalize u0; clear u0.
elim u1; clear u1 t0 t1.
trivial.

intros t0 t1 in_t1 t3 suc_t3_t1 ih suc_t2_t3.
apply (successor_trans t0 t1 in_t1 t2).
apply ih; assumption.
Qed.

Lemma succs_refl : forall t : Tree, Successor t t.
intros.
apply successor_refl.
Qed.

Lemma Succs_Tree_ind :
 forall P : Tree -> Prop,
 (forall a : A, P (node a Nil_Forest)) ->
 (forall t0 t1 : Tree, Successor t0 t1 -> P t0 -> P t1) ->
 forall t : Tree, P t.
intros P leaf step t.
apply My_Tree_ind.
intros a succs; case succs; clear succs.
intros.
apply leaf.
intros t0 succs ih.
apply step with t0.
apply successor_trans with t0.
simpl in |- *.
apply in_forest_head.
apply successor_refl.
apply ih.
apply in_forest_head.
Qed.

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

Inductive In_tree : A -> Tree -> Prop :=
  | in_leave : forall (a : A) (succs : Forest), In_tree a (node a succs)
  | in_succs :
      forall (succs : Forest) (t : Tree),
      In_Forest t succs ->
      forall a : A, In_tree a t -> forall a' : A, In_tree a (node a' succs).

Lemma in_successor_in :
 forall (a : A) (t : Tree),
 In_tree a t -> forall t' : Tree, Successor t t' -> In_tree a t'.
intros a t in_t t' suc.
generalize in_t; clear in_t.
elim suc; clear suc.
trivial.
clear t t'.
intros t0 t1 in_t1 t2 suc_t2 ih in_t2.
generalize in_t1; clear in_t1.
elim t0; clear t0.
intros a' succs in_t1.
apply in_succs with (t := t1).
assumption.
apply ih.
assumption.
Qed.

(********************************************************************)
(*  Monotone Trees                                                  *)

Variable I : Set.
Variable P : A -> I -> Prop.

Inductive Is_Monotone_Tree : Tree -> Prop :=
    is_monotone_tree_intro :
      forall (a : A) (succs : Forest),
      Is_Monotone_Forest a succs -> Is_Monotone_Tree (node a succs)
with Is_Monotone_Forest : A -> Forest -> Prop :=
  | is_monotone_forest_nil : forall a : A, Is_Monotone_Forest a Nil_Forest
  | is_monotone_forest_cons :
      forall (a : A) (t : Tree) (succs : Forest),
      (forall i : I, P a i -> P (root t) i) ->
      Is_Monotone_Tree t ->
      Is_Monotone_Forest a succs ->
      Is_Monotone_Forest a (Cons_Forest t succs).

Lemma is_monotone_tree_successor :
 forall t : Tree,
 Is_Monotone_Tree t ->
 forall t0 : Tree, Successor t0 t -> Is_Monotone_Tree t0.
intros t is_mon_t t0 suc_t0.
generalize is_mon_t; clear is_mon_t.
elim suc_t0; clear suc_t0 t0.
trivial.
intros t0 t1 in_t1 t2 suc_t2 ih is_mon_t0.
apply ih; clear ih suc_t2 t2.
generalize in_t1; clear in_t1.
inversion_clear is_mon_t0.
simpl in |- *.
generalize H; clear H.
elim succs; clear succs.
intros H in_t1.
inversion_clear in_t1.
intros t2 succs ih H in_t1.
inversion_clear in_t1.
inversion_clear H; assumption.
apply ih.
inversion_clear H; assumption.
assumption.
Qed.

Inductive Is_Monotone (t : Tree) : Prop :=
    is_monotone_intro :
      (forall t0 : Tree,
       Successor t0 t ->
       forall i : I,
       P (root t0) i -> forall t1 : Tree, Successor t1 t0 -> P (root t1) i) ->
      Is_Monotone t.

Lemma is_monotone_successor :
 forall T : Tree,
 Is_Monotone T -> forall t : Tree, Successor t T -> Is_Monotone t.
intros T mon_T t suc_t.
apply is_monotone_intro.
intros t0 suc_t0 i Pa t1 suc_1.
inversion_clear mon_T.
apply H with t0.
apply succs_trans with t; assumption.
assumption.
assumption.
Qed.

Lemma is_monotone_tree_is_monotone :
 forall t : Tree, Is_Monotone_Tree t -> Is_Monotone t.
intros t H.
apply is_monotone_intro.
intros t0 suc_t0.
generalize (is_monotone_tree_successor t H t0 suc_t0); clear H suc_t0 t.
intros H i P0 t1 suc_t1.
generalize P0; clear P0.
generalize H; clear H.
elim suc_t1; clear suc_t1 t0 t1.
trivial.
intros t0 t1 in_t1 t2 suc_t2 ih H P0.
apply ih; clear ih.
apply is_monotone_tree_successor with t0.
assumption.
apply successor_trans with t1.
assumption.
apply successor_refl.
generalize P0; clear P0.
generalize in_t1; clear in_t1.
inversion_clear H.
simpl in |- *.
intros in_t1 Pa.
generalize H0; clear H0.
generalize in_t1; clear in_t1.
elim succs; clear succs.
intros in_t1 H0.
inversion_clear in_t1.
intros t3 succs ih in_t1 H0.
inversion_clear in_t1.
inversion_clear H0.
apply H; assumption.
apply ih.
assumption.
inversion_clear H0; assumption.
Qed.

End Trees.