(* ********** *)

(* Paraphernalia: *)

Require Import Arith Bool.

Notation "A =n= B" :=
  (beq_nat A B) (at level 70, right associativity).

(* ********** *)

Theorem euclidean_division:
  forall d : nat,
    (0 < d) ->
    forall n : nat,
    exists q r: nat,
    (r < d
    /\
    n = (q * d) + r).
Proof.
  intros d H_d.
  intro n.
  induction n as [ | k [q [r [H_r H_k]]]].
  exists 0.
  exists 0.
  split.
      apply H_d.

    Search (0 * _ = 0).
    Check (Nat.mul_0_l d).
    rewrite -> (Nat.mul_0_l d).
    reflexivity.

    Check (lt_le_S).
    Check (le_lt_or_eq).
    apply (lt_le_S r d) in H_r.
    apply (le_lt_or_eq (S r) d) in H_r.

    destruct H_r as [IH_r | IH_r].
      Search (S _ < _ -> _ < _).
      exists q.
      exists (S r).
      split.
      apply IH_r.
      Check (H_k).
      rewrite -> H_k.

      Search (S (_ + _) = _ + S _).
      rewrite -> (plus_n_Sm (q * d) r).
      reflexivity.

    exists (S q).
    exists 0.
    split.
      apply H_d.
      rewrite -> H_k.
      rewrite <- IH_r.
      Search (S _ = _ + S _).
      rewrite -> (plus_n_Sm (q * (S r)) r).
      Search (S _ * _ = _ * _ + _).
      rewrite -> (Nat.mul_succ_l (q) (S r)).
      Search (_ + 0 = _).
      rewrite -> (Nat.add_0_r (q * S r + S r)).
      reflexivity.
   Qed.


Require Import Arith List.

(** * Strongly-specified "pred" *)

Lemma eq_geq_contra : 0 > 0 -> False.
  inversion 1.
Qed.

Check False_rec.

Print pred.

Extraction pred.

Definition pred_strong1 : forall (n : nat), n > 0 -> nat :=
  fun n : nat =>
    match n return (n > 0 -> nat) with
      | O => fun pf : 0 > 0 => False_rec _ (eq_geq_contra pf)
      | S n' => fun _ => n'
    end.

Extraction pred_strong1.

Print sig.

Definition pred_strong2 : {n : nat | n > 0} -> nat :=
  fun s : {n : nat | n > 0} =>
    match s with
      | exist O pf => False_rec _ (eq_geq_contra pf)
      | exist (S n') _ => n'
    end.

Extraction pred_strong2.

Definition pred_strong3 : forall n, n > 0 -> {m : nat | n = S m} :=
  fun n : nat =>
    match n return (n > 0 -> {m : nat | n = S m}) with
      | O => fun pf : 0 > 0 => False_rec _ (eq_geq_contra pf)
      | S n' => fun _ => exist (fun m => S n' = S m) n' (refl_equal _)
    end.

Extraction pred_strong3.

Definition pred_strong4 : forall n, n > 0 -> {m : nat | n = S m}.
  intros n pf.
  destruct n.
  assert False.
  inversion pf.
  tauto.
  exists n.
  reflexivity.
Defined.

Extraction pred_strong4.

Definition pred_strong5 : forall n, n > 0 -> {m : nat | n = S m}.
  refine (fun n : nat =>
    match n return (n > 0 -> {m : nat | n = S m}) with
      | O => fun pf : 0 > 0 => False_rec _ _
      | S n' => fun _ => exist (fun m => S n' = S m) n' _
    end).
  inversion pf.
  reflexivity.
Defined.

Extraction pred_strong5.

Hint Resolve eq_geq_contra.

Definition pred_strong6 : forall n, n > 0 -> {m : nat | n = S m}.
  refine (fun n : nat =>
    match n return (n > 0 -> {m : nat | n = S m}) with
      | O => fun pf : 0 > 0 => False_rec _ _
      | S n' => fun _ => exist (fun m => S n' = S m) n' _
    end); auto.
Defined.

Extraction pred_strong6.

(** * Eliminations and extraction *)

Check eq_S.

Check (pairT sig ex).

Definition Set_to_Set (x : nat) (s : {y : nat | y = x + x}) : {y : nat | S y = S (x + x)} :=
  match s with
    | exist y pf => exist (fun y => S y = S (x + x)) y (eq_S _ _ pf)
  end.

Extraction Set_to_Set.

Definition Set_to_Prop (x : nat) (s : {y : nat | y = x + x}) : exists y, S y = S (x + x) :=
  match s with
    | exist y pf => ex_intro (fun y => S y = S (x + x)) y (eq_S _ _ pf)
  end.

Extraction Set_to_Prop.

Definition Prop_to_Prop (x : nat) (s : exists y, y = x + x) : exists y, S y = S (x + x) :=
  match s with
    | ex_intro y pf => ex_intro (fun y => S y = S (x + x)) y (eq_S _ _ pf)
  end.

Extraction Prop_to_Prop.

(*Definition Prop_to_Set (x : nat) (s : exists y, y = x + x) : {y : nat | S y = S (x + x)} :=
  match s with
    | ex_intro y pf => exist (fun y => S y = S (x + x)) y (eq_S _ _ pf)
  end.*)

(** * Decidable equality *)

Print sumbool.

Hint Extern 1 (_ <> _) => discriminate.

Definition bool_eq_dec1 : forall (x y : bool), {x = y} + {x <> y}.
  destruct x; destruct y; auto.
Defined.

Definition bool_eq_dec2 : forall (x y : bool), {x = y} + {x <> y}.
  refine (fun x : bool =>
    match x return (forall y : bool, {x = y} + {x <> y}) with
      | false => fun y : bool =>
	match y return ({false = y} + {false <> y}) with
	  | false => left _ _
	  | true => right _ _
	end
      | true => fun y : bool =>
	match y return ({true = y} + {true <> y}) with
	  | false => right _ _
	  | true => left _ _
	end
    end); auto.
Defined.

Extraction bool_eq_dec1.
Extraction bool_eq_dec2.

Definition nat_eq_dec1 : forall (x y : nat), {x = y} + {x <> y}.
  induction x; destruct y; firstorder.
Defined.

Definition nat_eq_dec2 : forall (x y : nat), {x = y} + {x <> y}.
  refine (fix nat_eq_dec2 (x : nat) : forall (y : nat), {x = y} + {x <> y} :=
    match x return (forall y : nat, {x = y} + {x <> y}) with
      | O => fun y : nat =>
	match y return ({O = y} + {O <> y}) with
	  | O => left _ _
	  | S _ => right _ _
	end
      | S x' => fun y : nat =>
	match y return ({S x' = y} + {S x' <> y}) with
	  | O => right _ _
	  | S y' =>
	    match nat_eq_dec2 x' y' with
	      | left _ => left _ _
	      | right _ => right _ _
	    end
	end
    end); auto.
Defined.

Extraction nat_eq_dec1.
Extraction nat_eq_dec2.

Definition bool_eq_dec : forall (x y : bool), {x = y} + {x <> y}.
  decide equality.
Defined.

Definition nat_eq_dec : forall (x y : nat), {x = y} + {x <> y}.
  decide equality.
Defined.

Extraction bool_eq_dec.
Extraction nat_eq_dec.

(** * List membership *)

Hint Extern 1 False =>
  match goal with
    | [ H : In _ (_ :: _) |- _ ] => inversion H; clear H; subst
  end.

Section In_dec.
  Variable A : Set.
  Variable A_eq_dec : forall (x y : A), {x = y} + {x <> y}.

  Definition In_dec : forall (x : A) (ls : list A), {In x ls} + {~In x ls}.
    refine (fix In_dec (x : A) (ls : list A) {struct ls}
      : {In x ls} + {~In x ls} :=
      match ls return {In x ls} + {~In x ls} with
	| nil => right _ _
	| x' :: ls' =>
	  if A_eq_dec x x'
	    then left _ _
	    else if In_dec x ls'
	      then left _ _
	      else right _ _
      end); intros; subst; intuition.
  Qed.
End In_dec.

Extraction In_dec.

(** * Association lists *)

Print sumor.

Hint Extern 1 False =>
  match goal with
    | [ H : (_, _) = (_, _) |- _ ] => injection H; clear H; intros; subst
  end.

Section assoc.
  Variables A B : Set.
  Variable A_eq_dec : forall (x y : A), {x = y} + {x <> y}.

  Definition assoc : forall (x : A) (ls : list (A * B)),
    {y : B | In (x, y) ls} + {forall y, ~In (x, y) ls}.
    refine (fix assoc (x : A) (ls : list (A * B)) {struct ls}
      : {y : B | In (x, y) ls} + {forall y, ~In (x, y) ls} :=
      match ls return {y : B | In (x, y) ls} + {forall y, ~In (x, y) ls} with
	| nil => inright _ _
	| (x', y) :: ls' =>
	  if A_eq_dec x x'
	    then inleft _ (exist _ y _)
	    else match assoc x ls' with
		   | inleft (exist y' _) => inleft _ (exist _ y' _)
		   | inright _ => inright _ _
		 end
      end); intros; subst; intuition; eauto.
  Qed.
End assoc.

Extraction assoc.

(** * Set signatures *)

Print sigS.

Definition makeSum (n : nat) : {m1 : nat & {m2 : nat | m1 + m2 = n}}.
  refine (fun n : nat =>
    match n return {m1 : nat & {m2 : nat | m1 + m2 = n}} with
      | O => existS (fun m1 => {m2 : nat | m1 + m2 = O}) O (exist _ O _)
      | S n' => existS (fun m1 => {m2 : nat | m1 + m2 = S n'}) 1 (exist _ n' _)
    end); auto.
Defined.

Extraction makeSum.

(** * (Not so) Finite state machines *)

Section tryAll.
  Variables A B : Set.
  Variable P : forall (x : A), B -> Prop.
  Variable P_dec : forall x, {y : B | P x y} + {forall y, ~P x y}.

  Definition tryAll : forall (ls : list A),
    {y : B | exists x, In x ls /\ P x y}
    + {forall x, In x ls -> forall y, ~P x y}.
    refine (fix tryAll (ls : list A)
      : {y : B | exists x, In x ls /\ P x y}
      + {forall x, In x ls -> forall y, ~P x y} :=
      match ls return {y : B | exists x, In x ls /\ P x y}
	+ {forall x, In x ls -> forall y, ~P x y} with
	| nil => inright _ _
	| x :: ls' =>
	  match P_dec x with
	    | inleft (exist y _) => inleft _ (exist _ y _)
	    | inright _ => match tryAll ls' with
			     | inleft (exist y _) => inleft _ (exist _ y _)
			     | inright _ => inright _ _
			   end
	  end
      end); simpl; intuition; subst; eauto.
    firstorder.
  Defined.
End tryAll.

Section FSM.
  Variable char : Set.
  Variable state : Set.
  Variable startState : state.
  Variable acceptingStates : list state.
  Variable transitions : state -> char -> list state.

  Variable state_eq_dec : forall (s1 s2 : state), {s1 = s2} + {s1 <> s2}.

  Definition word := list char.

  Inductive reach : state -> word -> state -> Prop :=
    | Done : forall (s : state),
      reach s nil s
    | Step : forall (s : state) (ch : char) (w : word) (s' s'' : state),
      In s' (transitions s ch)
      -> reach s' w s''
      -> reach s (ch :: w) s''.

  Hint Constructors reach.

  Hint Extern 1 False =>
    match goal with
      | [ H : reach _ nil _ |- _ ] => inversion H; clear H; subst
      | [ H : reach _ (_ :: _) _ |- _ ] => inversion H; clear H; subst
    end.

  Hint Extern 1 (reach _ _ _) =>
    match goal with
      | [ H : ex _ |- _ ] => destruct H; intuition
    end.

  Definition accepted : forall (w : word) (s : state),
    {s' : state | reach s w s' /\ In s' acceptingStates}
    + {forall s', ~(reach s w s' /\ In s' acceptingStates)}.
    refine (fix accepted (w : word) (s : state) {struct w}
      : {s' : state | reach s w s' /\ In s' acceptingStates}
      + {forall s', ~(reach s w s' /\ In s' acceptingStates)} :=
      match w return {s' : state | reach s w s' /\ In s' acceptingStates}
	+ {forall s', ~(reach s w s' /\ In s' acceptingStates)} with
	| nil =>
	  match In_dec _ _ s acceptingStates with
	    | left _ => inleft _ (exist _ s _)
	    | right _ => inright _ _
	  end
	| ch :: w' =>
	  match tryAll _ _ (fun s s' => reach s w' s' /\ In s' acceptingStates) (accepted w') (transitions s ch) with
	    | inleft (exist s' _) => inleft _ (exist _ s' _)
	    | inright _ => inright _ _
	  end
      end); intuition eauto; firstorder.
  Defined.
End FSM.

Recursive Extraction accepted.


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

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
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 append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Theorem append_Nil: forall (l: lst), append l Nil = l.
Proof.
  induction l.
  { simpl. f_equal. assumption. }
  { simpl. reflexivity. }
Qed.

Theorem append_assoc:
  forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
  induction l1; induction l2; induction l3; try (simpl; reflexivity).
  - simpl. rewrite <- IHl1. f_equal.
  - simpl. rewrite 2 append_Nil. reflexivity.
  - simpl. rewrite append_Nil.  reflexivity.
  - simpl. rewrite 2 append_Nil. reflexivity.
Qed.

Theorem append_rev_Cons:
  forall (l1 l2: lst) (x: natural),
    rev (append l1 (Cons x l2)) = append (rev l2) (Cons x (rev l1)).
Proof.
  induction l1; induction l2; try (simpl; reflexivity).
  { intro. simpl. rewrite IHl1. simpl. rewrite <- append_assoc.
    f_equal. }
  { intro. simpl. rewrite IHl1. simpl. reflexivity. }
Qed.

Theorem rev_append: forall (l1 l2: lst), rev (append l1 l2) = append (rev l2) (rev l1).
Proof.
  induction l1.
  { induction l2.
    { simpl. lfind. Admitted.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Unicode.Utf8.
From LF Require Export Indprop.

Module MyEquality.
Inductive eq {X:Type} : X → X → Prop :=
  | eq_refl : ∀ x, eq x x.
Notation "x == y" := (eq x y)
                       (at level 70, no associativity)
                     : type_scope.

Lemma equality__leibniz_equality : ∀ (X : Type) (x y: X),
  x == y → ∀ P:X→Prop, P x → P y.
Proof.
    intros.
    inversion H.
    rewrite <-H2.
    assumption.
    Qed.

Lemma leibniz_equality__equality : ∀ (X : Type) (x y: X),
  (∀ P:X→Prop, P x → P y) → x == y.
Proof.
    intros.
    apply H.
    apply eq_refl.
    Qed.

    End MyEquality.


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

(** Some facts and definitions about propositional and predicate extensionality

We investigate the relations between the following extensionality principles

- Proposition extensionality
- Predicate extensionality
- Propositional functional extensionality
- Provable-proposition extensionality
- Refutable-proposition extensionality
- Extensional proposition representatives
- Extensional predicate representatives
- Extensional propositional function representatives

Table of contents

1. Definitions

2.1 Predicate extensionality <-> Proposition extensionality + Propositional functional extensionality

2.2 Propositional extensionality -> Provable propositional extensionality

2.3 Propositional extensionality -> Refutable propositional extensionality

*)

Set Implicit Arguments.

(**********************************************************************)
(** * Definitions *)

(** Propositional extensionality *)

Local Notation PropositionalExtensionality :=
  (forall A B : Prop, (A <-> B) -> A = B).

(** Provable-proposition extensionality *)

Local Notation ProvablePropositionExtensionality :=
  (forall A:Prop, A -> A = True).

(** Refutable-proposition extensionality *)

Local Notation RefutablePropositionExtensionality :=
  (forall A:Prop, ~A -> A = False).

(** Predicate extensionality *)

Local Notation PredicateExtensionality :=
  (forall (A:Type) (P Q : A -> Prop), (forall x, P x <-> Q x) -> P = Q).

(** Propositional functional extensionality *)

Local Notation PropositionalFunctionalExtensionality :=
  (forall (A:Type) (P Q : A -> Prop), (forall x, P x = Q x) -> P = Q).

(**********************************************************************)
(** * Propositional and predicate extensionality                      *)

(**********************************************************************)
(** ** Predicate extensionality <-> Propositional extensionality + Propositional functional extensionality *)

Lemma PredExt_imp_PropExt : PredicateExtensionality -> PropositionalExtensionality.
Proof.
  intros Ext A B Equiv.
  change A with ((fun _ => A) I).
  now rewrite Ext with (P := fun _ : True =>A) (Q := fun _ => B).
Qed.

Lemma PredExt_imp_PropFunExt : PredicateExtensionality -> PropositionalFunctionalExtensionality.
Proof.
  intros Ext A P Q Eq. apply Ext. intros x. now rewrite (Eq x).
Qed.

Lemma PropExt_and_PropFunExt_imp_PredExt :
  PropositionalExtensionality -> PropositionalFunctionalExtensionality -> PredicateExtensionality.
Proof.
  intros Ext FunExt A P Q Equiv.
  apply FunExt. intros x. now apply Ext.
Qed.

Theorem PropExt_and_PropFunExt_iff_PredExt :
  PropositionalExtensionality /\ PropositionalFunctionalExtensionality <-> PredicateExtensionality.
Proof.
  firstorder using PredExt_imp_PropExt, PredExt_imp_PropFunExt, PropExt_and_PropFunExt_imp_PredExt.
Qed.

(**********************************************************************)
(** ** Propositional extensionality and provable proposition extensionality *)

Lemma PropExt_imp_ProvPropExt : PropositionalExtensionality -> ProvablePropositionExtensionality.
Proof.
  intros Ext A Ha; apply Ext; split; trivial.
Qed.

(**********************************************************************)
(** ** Propositional extensionality and refutable proposition extensionality *)

Lemma PropExt_imp_RefutPropExt : PropositionalExtensionality -> RefutablePropositionExtensionality.
Proof.
  intros Ext A Ha; apply Ext; split; easy.
Qed.


Set Implicit Arguments.
Unset Strict Implicit.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

Import GRing.Theory Num.Def Num.Theory.

Require Import OUVerT.dist.

Local Open Scope ring_scope.

Section importance.
  Variable T: finType.
  Variable rty: realFieldType.
  Variables f g: dist T rty.
  Variable fg_support: support f =i support g.
  Variable X: T -> rty.

  Lemma importance:
    expectedValue f X = expectedValue g (fun x => f(x)/g(x) * X x).
  Proof.
    rewrite /expectedValue; apply: eq_big => // i _.
    rewrite mulrA [_ / _]mulrC mulrA.
    case H: (i \in support f).
    { move: fg_support => /(_ i); rewrite H => H2.
      rewrite divff; first by rewrite mul1r.
      by apply/eqP => H3; rewrite in_set H3 ltrr in H2. }
    have: (i \in support g) = false by rewrite -fg_support H.
    move => H2; rewrite in_set in H; rewrite in_set in H2.
    have H3: f i = 0.
    { by move: (dist_positive f i); rewrite ler_eqVlt H orbC /=; move/eqP. }
    have H4: g i = 0.
    { by move: (dist_positive g i); rewrite ler_eqVlt H2 orbC /=; move/eqP. }
    by rewrite H3 H4 !mulr0.
  Qed.
End importance.


(**
 * Formalization of Gödel's System T.
 *
 * We represent the language with well-typed terms, following an approach
 * similar to "Strongly Typed Term Representations in Coq" by Nick Benton,
 * Chung-Kil Hur, Andrew J. Kennedy and Conor Mcbride (2012). A good high-level
 * explanation of the approach is in this presentation:
 * https://www.cis.upenn.edu/~sweirich/wmm/wmm09/Benton-Slides.pdf.
 *
 * From there we define a unary logical relation we call hereditary termination,
 * well-founded due to recursion on (object) types. We prove all terms are
 * hereditarily terminating, which implies termination of every term.
 *
 * As a nice side-effect, we also use the termination proof as the crucial lemma
 * in a well-foundedness proof for an evaluator that steps system T expressions
 * to completion, with the expected correctness proof.
 *)

Require List.
Export List.ListNotations.
Open Scope list.

Require Export Equality.

Require Import Relations.
Require Import FunctionalExtensionality.
Require Import Eqdep_dec.
Require Import Recdef.

Global Set Implicit Arguments.

Set Default Goal Selector "!".

(** * Language definitions *)

Inductive type :=
  | natTy
  | arrow : type -> type -> type.

Definition type_dec : forall (t1 t2: type), {t1=t2} + {t1<>t2}.
Proof.
  decide equality.
Defined.

Definition context := list type.

Inductive variable : context -> type -> Type :=
| var_here : forall Gamma t, variable (t :: Gamma) t
| var_outer : forall Gamma t t', variable Gamma t -> variable (t' :: Gamma) t.

Arguments var_here {Gamma} {t}.

Inductive expr (Gamma: context) : type -> Type :=
| var : forall t (v: variable Gamma t), expr Gamma t
| zero : expr Gamma natTy
| succ : expr Gamma natTy -> expr Gamma natTy
| abs : forall t1 t2,
    forall (e: expr (t1 :: Gamma) t2),
      expr Gamma (arrow t1 t2)
| app : forall t1 t2,
    forall (e1: expr Gamma (arrow t1 t2))
      (e2: expr Gamma t1),
      expr Gamma t2
| iter : forall t,
    forall (ez: expr Gamma t)
      (e: expr (t :: Gamma) t)
      (n: expr Gamma natTy),
      expr Gamma t.

Arguments zero {Gamma}.

Implicit Types (Gamma: context) (t: type).

(** * Substitution *)

(** Defining substitution is tricky. We build it up gradually , starting with a
more basic notion of renaming. *)

Definition renaming Gamma Gamma' :=
  forall t (v: variable Gamma t), variable Gamma' t.

Program Definition renaming_shift
        Gamma Gamma' t
        (gamma: renaming Gamma Gamma') :
  renaming (t :: Gamma) (t :: Gamma') :=
  fun t' v =>
    match v with
      | var_here => var_here
      | var_outer _ v' => var_outer _ (gamma _ v')
    end.

Definition apply_renaming Gamma Gamma' (gamma: renaming Gamma Gamma')
           t (e: expr Gamma t) : expr Gamma' t.
  intros.
  generalize dependent Gamma'.
  generalize dependent Gamma.
  induction 1; intros; subst.
  - exact (var (gamma _ v)).
  - exact zero.
  - apply succ.
    now apply IHe.
  - eapply abs.
    eapply IHe; trivial.
    now apply renaming_shift.
  - now eapply app; [ apply IHe1 | apply IHe2 ].
  - eapply iter.
    + now apply IHe1.
    + apply IHe2; trivial.
      now apply renaming_shift.
    + now apply IHe3.
Defined.

Definition var_shift Gamma t' : renaming Gamma (t'::Gamma) :=
  fun _ v => var_outer t' v.

Definition expr_shift Gamma t t' (e: expr Gamma t) : expr (t' :: Gamma) t :=
  apply_renaming (var_shift t') e.

(** General substitution between two contexts. *)
Definition substitution Gamma Gamma' :=
  forall t (v: variable Gamma t), expr Gamma' t.

Program Definition substitution_shift
        Gamma Gamma' t
        (gamma: substitution Gamma Gamma') :
  substitution (t :: Gamma) (t :: Gamma') := fun t' v =>
  match v with
    | var_here => var var_here
    | var_outer _ v' => expr_shift t (gamma _ v')
  end.

Program Definition substitution_shift_expr
        Gamma Gamma' t
        (e': expr Gamma' t)
        (gamma: substitution Gamma Gamma') :
  substitution (t :: Gamma) Gamma' :=
  fun t' (v: variable (t :: Gamma) t') =>
    match v with
      | var_here => e'
      | var_outer _ v' => gamma _ v'
    end.

Definition apply_substitution Gamma Gamma' (gamma: substitution Gamma Gamma')
           t (e: expr Gamma t) : expr Gamma' t.
  intros.
  generalize dependent Gamma'.
  generalize dependent Gamma.
  induction 1; intros; subst.
  - exact (gamma _ v).
  - exact zero.
  - apply succ.
    now apply IHe.
  - eapply abs.
    eapply IHe; trivial.
    now apply substitution_shift.
  - now eapply app; [ apply IHe1 | apply IHe2 ].
  - eapply iter.
    + now apply IHe1.
    + apply IHe2; trivial.
      now apply substitution_shift.
    + now apply IHe3.
Defined.

(** * Four types of composition, between renamings and substitutions. *)

Definition compose_ren_ren Gamma Gamma' Gamma''
           (r: renaming Gamma Gamma')
           (r': renaming Gamma' Gamma'') : renaming Gamma Gamma'' :=
  fun t v => r' _ (r t v).

Definition compose_ren_sub Gamma Gamma' Gamma''
           (r: renaming Gamma Gamma')
           (s: substitution Gamma' Gamma'') : substitution Gamma Gamma'' :=
  fun t v => s _ (r t v).

Definition compose_sub_ren Gamma Gamma' Gamma''
           (s: substitution Gamma Gamma')
           (r: renaming Gamma' Gamma'') : substitution Gamma Gamma'' :=
  fun t v => apply_renaming r (s t v).

Definition compose_sub_sub Gamma Gamma' Gamma''
           (s: substitution Gamma Gamma')
           (s': substitution Gamma' Gamma'') : substitution Gamma Gamma'' :=
  fun t v => apply_substitution s' (s t v).

Ltac subst_ext :=
  intros;
  let ext := (let t := fresh "t" in
             let v := fresh "v" in
             extensionality t; extensionality v;
             dependent destruction v;
             eauto) in
  match goal with
  | [ |- _ = _ :> (renaming _ _) ] => ext
  | [ |- _ = _ :> (substitution _ _) ] => ext
  end.

Ltac inj_pair2 :=
  match goal with
  | [ H: @existT type ?P ?p _ = existT ?P ?p _ |- _ ] =>
    apply (inj_pair2_eq_dec type type_dec) in H; subst
  end.

Ltac deex H :=
  lazymatch type of H with
  | exists (varname:_), _ =>
    let name := fresh varname in
    destruct H as [name ?]
  end.

Ltac simplify_hook := fail.

Ltac simplify :=
  repeat match goal with
         | [ |- forall _, _ ] => intros
         | _ => progress subst
         | [ H: exists _, _ |- _ ] => deex H
         | [ H: _ /\ _ |- _ ] => destruct H
         | [ H: ?a = ?a |- _ ] => clear H
         | _ => inj_pair2
         | _ => progress simpl
         | _ => progress autounfold in *
         | [ H: context[_ = _] |- _ ] => rewrite H by auto
         | _ => progress autorewrite with subst
         | _ => simplify_hook
         end.

Ltac crush :=
  simplify; eauto;
  try solve [ subst_ext ].

Definition noop_substitution : forall {Gamma}, substitution Gamma Gamma.
  intros Gamma t v.
  apply var; auto.
Defined.

Lemma noop_substitution_shift : forall Gamma t,
    substitution_shift (t := t) (noop_substitution (Gamma := Gamma)) =
    noop_substitution.
Proof.
  crush.
Qed.

Hint Rewrite noop_substitution_shift : subst.

Lemma substitute_noop_substitution :
  forall Gamma t (e: expr Gamma t),
    apply_substitution noop_substitution e = e.
Proof.
  induction e; crush.
Qed.

Hint Rewrite substitute_noop_substitution : subst.

Section RenameSubstitutionCompositions.

  Lemma shift_ren_ren :
    forall Gamma Gamma' Gamma'' t
      (r: renaming Gamma Gamma')
      (r': renaming Gamma' Gamma''),
      renaming_shift (t:=t) (compose_ren_ren r r') =
      compose_ren_ren (renaming_shift r) (renaming_shift r').
  Proof.
    crush.
  Qed.

  Hint Rewrite @shift_ren_ren : subst.

  Lemma apply_ren_ren :
    forall Gamma t (e: expr Gamma t) Gamma' Gamma''
      (r: renaming Gamma Gamma')
      (r': renaming Gamma' Gamma'') ,
      apply_renaming (compose_ren_ren r r') e = apply_renaming r' (apply_renaming r e).
  Proof.
    induction e; crush.
  Qed.

  Lemma shift_ren_sub :
    forall Gamma Gamma' Gamma'' t
      (r: renaming Gamma Gamma')
      (s: substitution Gamma' Gamma''),
      substitution_shift (t:=t) (compose_ren_sub r s) =
      compose_ren_sub (renaming_shift r) (substitution_shift s).
  Proof.
    crush.
  Qed.

  Hint Rewrite shift_ren_sub : subst.

  Lemma apply_ren_sub :
    forall Gamma t (e: expr Gamma t) Gamma' Gamma''
      (r: renaming Gamma Gamma')
      (s: substitution Gamma' Gamma'') ,
      apply_substitution (compose_ren_sub r s) e = apply_substitution s (apply_renaming r e).
  Proof.
    induction e; crush.
  Qed.

  Hint Rewrite <- apply_ren_ren : subst.

  Lemma shift_sub_ren :
    forall Gamma Gamma' Gamma'' t
      (s: substitution Gamma Gamma')
      (r: renaming Gamma' Gamma''),
      substitution_shift (t:=t) (compose_sub_ren s r) =
      compose_sub_ren (substitution_shift s) (renaming_shift r).
  Proof.
    subst_ext.
    unfold compose_sub_ren; simplify.
    unfold expr_shift; crush.
  Qed.

  Hint Rewrite shift_sub_ren : subst.

  Lemma apply_sub_ren :
    forall Gamma t (e: expr Gamma t) Gamma' Gamma''
      (s: substitution Gamma Gamma')
      (r: renaming Gamma' Gamma''),
      apply_substitution (compose_sub_ren s r) e = apply_renaming r (apply_substitution s e).
  Proof.
    induction e; crush.
  Qed.

  Hint Rewrite <- apply_sub_ren : subst.
  Hint Rewrite <- apply_ren_sub : subst.

  Lemma shift_sub_sub :
    forall Gamma Gamma' Gamma'' t
      (s: substitution Gamma Gamma')
      (s': substitution Gamma' Gamma''),
      substitution_shift (t:=t) (compose_sub_sub s s') =
      compose_sub_sub (substitution_shift s) (substitution_shift s').
  Proof.
    subst_ext.
    unfold compose_sub_sub; simpl.
    unfold expr_shift; crush.
  Qed.

  Hint Rewrite shift_sub_sub : subst.

  Lemma apply_sub_sub :
    forall Gamma t (e: expr Gamma t) Gamma' Gamma''
      (s: substitution Gamma Gamma')
      (s': substitution Gamma' Gamma''),
      apply_substitution (compose_sub_sub s s') e =
      apply_substitution s' (apply_substitution s e).
  Proof.
    induction e; crush.
  Qed.

End RenameSubstitutionCompositions.

(** * Finally we build subst from a simple substitution.

Note that subst creates closed terms.
 *)

Definition subst t' (e': expr [] t') t (e: expr [t'] t) : expr [] t :=
  apply_substitution (substitution_shift_expr e' noop_substitution) e.

(** * The dynamics of the language. *)

Inductive val Gamma : forall t, expr Gamma t -> Prop :=
| val_z : val zero
| val_s : forall (e : expr Gamma natTy), val e -> val (succ e)
| val_abs : forall t1 t2 (e: expr (t1 :: Gamma) t2), val (abs e).

Inductive step : forall t, expr [] t -> expr [] t -> Prop :=
| step_s : forall (e e': expr [] natTy),
             step e e' ->
             step (succ e) (succ e')
| step_ap1 : forall t1 t2 (e1 e1': expr [] (arrow t1 t2)) e2,
               step e1 e1' ->
               step (app e1 e2) (app e1' e2)
| step_ap2 : forall t1 t2 (e1: expr [] (arrow t1 t2)) e2 e2',
               val e1 ->
               step e2 e2' ->
               step (app e1 e2) (app e1 e2')
| step_apE : forall t1 t2 (e2: expr [] t1) (e: expr [t1] t2),
               val e2 ->
               step (app (abs e) e2) (subst e2 e)
| step_iter1 : forall t (ez: expr [] t) e n n',
                 step n n' ->
                 step (iter ez e n) (iter ez e n')
| step_iter2 : forall t (ez: expr [] t) e,
                 step (iter ez e zero) ez
| step_iter3 : forall t (ez: expr [] t) e n,
                 val n ->
                 step (iter ez e (succ n)) (subst (iter ez e n) e).

Arguments step {t} e e'.

Global Hint Constructors step val : core.

(** * We prove progress only as an exercise. *)
Theorem progress : forall t (e: expr [] t),
    val e \/
    exists e', step e e'.
Proof.
  dependent induction e; eauto.
  - inversion v.
  - edestruct IHe; crush.
  - edestruct IHe1; crush.
    edestruct IHe2; crush.
    inversion H; crush.
  - edestruct IHe3; crush.
    inversion H; crush.
Qed.

Ltac inv_step :=
  match goal with
  | [ H: step _ _ |- _ ] =>
    inversion H; repeat inj_pair2; clear H
  end.

(** * General relation properties. *)

Global Hint Constructors clos_refl_trans_1n : core.
Arguments clos_refl_trans_1n {A} R _ _ : assert.

(** A deterministic relation can also be viewed as a (non-computational) partial
function *)
Definition deterministic A (R: A -> A -> Prop) :=
  forall a a' a'', R a a' ->
              R a a'' ->
              a' = a''.

(** Final values for a relation are those that have no image, interpreting the
relation as a function *)
Definition final A (R: A -> A -> Prop) a := forall a', ~R a a'.

Theorem deterministic_clos_refl_R : forall A (R: A -> A -> Prop),
    deterministic R ->
    forall a a' a'',
      clos_refl_trans_1n R a a'' ->
      final R a'' ->
      R a a' ->
      clos_refl_trans_1n R a' a''.
Proof.
  unfold final; intros.
  induction H0.
  - exfalso; intuition eauto.
  - erewrite H; eauto.
Qed.

(* Repeating a deterministic relation till it yields a final value, viewed as itself a relation, is deterministic. *)
Theorem deterministic_clos_refl_unique : forall A (R: A -> A -> Prop),
    deterministic R ->
    forall a a' a'',
      clos_refl_trans_1n R a a' ->
      clos_refl_trans_1n R a a'' ->
      final R a' ->
      final R a'' ->
      a' = a''.
Proof.
  unfold final; intros.
  generalize dependent a''.
  induction H0; intros.
  - inversion H1; subst; eauto.
    exfalso; intuition eauto.
  - eauto using deterministic_clos_refl_R.
Qed.

(** * Specializing the above tools for step *)

Infix "|->" := (step) (at level 20).
Infix "|->*" := (clos_refl_trans_1n step) (at level 20).

Lemma val_no_step : forall t (e e': expr [] t),
    val e ->
    ~e |-> e'.
Proof.
  induction 1; simplify;
    try match goal with
        | [ H: _ |-> _ |- _ ] =>
          inversion H; crush
        end.
Qed.

Lemma val_final : forall t (e: expr [] t),
    val e ->
    final step e.
Proof.
  unfold final; eauto using val_no_step.
Qed.

Theorem step_deterministic : forall t, deterministic (step (t:=t)).
Proof.
  unfold deterministic; intros.
  induction H; simplify;
    inversion H0; simplify;
      try pose proof (IHstep _ ltac:(eauto));
      repeat (intuition eauto || simplify);
      try solve [ exfalso; match goal with
                           | [ H: val ?e, H': step ?e ?e' |- _ ] =>
                             apply (val_no_step H H')
                           | [ H: step ?e _ |- _ ] =>
                             let Hval := fresh in
                             assert (val e) as Hval by eauto;
                             apply (val_no_step Hval H)
                           end ].
Qed.

Lemma step_clos_refl_R : forall t (e e' e'': expr [] t),
    val e'' ->
    e |->* e'' ->
    e |-> e' ->
    e' |->* e''.
Proof.
  eauto using step_deterministic, val_final, deterministic_clos_refl_R.
Qed.

Global Hint Resolve step_clos_refl_R : core.

Lemma step_val_unique : forall t (e e' e'': expr [] t),
    e |->* e' ->
    e |->* e'' ->
    val e' ->
    val e'' ->
    e' = e''.
Proof.
  eauto using deterministic_clos_refl_unique, step_deterministic, val_final.
Qed.

(* non-strictly positive definition *)
(*
Inductive HT : forall t (e: expr [] t), Prop :=
| HT_natTy : forall e, terminating e -> HT e
| HT_arrow : forall t1 t2 (e: expr [] (arrow t1 t2)), (forall (e1: expr [] t1), HT e1 ->
                                                                      HT (app e e1)) ->
                                                 HT e.
*)

(** * Logical relation for termination. *)

Definition terminating t (e: expr [] t) : Prop := exists e', e |->* e' /\ val e'.

Global Hint Unfold terminating : core.

Fixpoint hereditary_termination t : expr [] t -> Prop :=
  match t with
  | natTy => fun e => terminating e
  | arrow t1 t2 => fun e =>
                    (* not only does e terminate, but we also extract the body
                    of the abstraction it terminates to *)
                    exists e0, e |->* abs e0 /\
                    (forall e1: expr [] t1, hereditary_termination e1 ->
                                       hereditary_termination (subst e1 e0))
  end.

Ltac simplify_hook ::=
     match goal with
     | [ H: @hereditary_termination natTy _ |- _ ] =>
       simpl in H
     | [ H: @hereditary_termination (arrow _ _) _ |- _ ] =>
       simpl in H
     end.

(** Lift hereditary termination to contexts. *)
Definition HT_context Gamma (gamma: substitution Gamma []) :=
  forall t (v: variable Gamma t), hereditary_termination (gamma _ v).

Lemma step_respects_succ : forall e e',
    e |->* e' ->
    succ e |->* succ e'.
Proof.
  induction 1; crush.
Qed.

Global Hint Resolve step_respects_succ : core.

(** val turns out to be decidable *)
Definition val_dec : forall t (e: expr [] t), {val e} + {~val e}.
Proof.
  induction e; intuition;
    try solve [ right; inversion 1; intuition ].
Defined.

Lemma hereditary_termination_succ' : forall (e: expr [] natTy),
    hereditary_termination (succ e) ->
    hereditary_termination e.
Proof.
  simplify.

  remember (succ e).
  generalize dependent e.
  induction H; crush.
  - inversion H0; eauto.

  - inv_step.
    edestruct IHclos_refl_trans_1n; crush.
Qed.

Lemma HT_respects_step : forall t (e e': expr [] t),
    hereditary_termination e ->
    e |-> e' ->
    hereditary_termination e'.
Proof.
  induction t; simplify; eauto.
Qed.

Global Hint Resolve HT_respects_step : core.

Lemma HT_prepend_step : forall t (e e': expr [] t),
    hereditary_termination e' ->
    e |-> e' ->
    hereditary_termination e.
Proof.
  induction t; crush.
Qed.

Definition rename_substitution Gamma Gamma' (r: renaming Gamma Gamma') :
  substitution Gamma Gamma' :=
  fun t e => var (r _ e).

Lemma rename_substitution_shift_commute : forall Gamma Gamma' t (r: renaming Gamma Gamma'),
    rename_substitution (renaming_shift (t:=t) r) =
    substitution_shift (rename_substitution r).
Proof.
  crush.
Qed.

Hint Rewrite rename_substitution_shift_commute using (solve [ eauto ]) : subst.

Theorem apply_renaming_as_substitution : forall Gamma Gamma' (r: renaming Gamma Gamma'),
    apply_renaming r = apply_substitution (rename_substitution r).
Proof.
  intros.
  extensionality t; extensionality e.
  generalize dependent Gamma'.
  induction e; crush.
Qed.

Arguments renaming_shift {Gamma Gamma'} t gamma [t0] v : rename.
Arguments substitution_shift {Gamma Gamma'} t gamma [t0] v : rename.

Lemma compose_rename_unshift : forall Gamma t t' (e': expr Gamma t'),
    compose_sub_sub (rename_substitution
                             (renaming_shift t (var_shift t')))
                          (substitution_shift
                             t (substitution_shift_expr e' noop_substitution)) =
    noop_substitution.
Proof.
  crush.
Qed.

Hint Rewrite compose_rename_unshift : subst.

Hint Rewrite <- apply_sub_sub : subst.
Hint Rewrite apply_renaming_as_substitution : subst.

Lemma shift_unshift_noop : forall Gamma t (e: expr Gamma t)
                             t' (e': expr Gamma t'),
    apply_substitution (substitution_shift_expr e' noop_substitution)
                       (expr_shift t' e) = e.
Proof.
  induction e; crush.
Qed.

Hint Rewrite shift_unshift_noop : subst.

Lemma subst_shift :
  forall Gamma (gamma: substitution Gamma []) t1 t2 (e: expr (t1 :: Gamma) t2) e2,
    apply_substitution (substitution_shift_expr e2 gamma) e =
    subst e2 (apply_substitution (substitution_shift t1 gamma) e).
Proof.
  unfold subst; simplify.
  f_equal.
  unfold compose_sub_sub.
  subst_ext; crush.
Qed.

Hint Rewrite <- subst_shift : subst.

Theorem hereditary_termination_terminating :
  forall t (e: expr [] t),
    hereditary_termination e -> terminating e.
Proof.
  destruct t; crush.
Qed.

Lemma HT_abs :
  forall t1 t2 (e1: expr [] (arrow t1 t2)) e2,
    hereditary_termination e1 ->
    hereditary_termination e2 ->
    hereditary_termination (app e1 e2).
Proof.
  intros.
  destruct H; crush.
  generalize H0; intros Ht2.
  apply hereditary_termination_terminating in H0.
  destruct H0; crush.
  remember (abs x) as f.
  match goal with
  | [ H: _ |->* f |- _ ] =>
    induction H; crush
  end.
  - induction H0; eauto using HT_prepend_step.
  - induction H0; eauto using HT_prepend_step.
Qed.

Lemma hereditary_termination_succ : forall e,
    hereditary_termination e ->
    hereditary_termination (succ e).
Proof.
  crush.
Qed.

Global Hint Resolve HT_abs : core.

Lemma succ_step : forall e e',
    succ e |->* e' ->
    exists e'', e' = succ e''.
Proof.
  intros.
  remember (succ e).
  generalize dependent e.
  induction H; crush.
  inv_step; eauto.
Qed.

Global Hint Resolve HT_prepend_step : core.

Lemma HT_context_shift : forall Gamma (gamma: substitution Gamma []) t (e: expr [] t),
    HT_context gamma ->
    hereditary_termination e ->
    HT_context (substitution_shift_expr e gamma).
Proof.
  unfold HT_context; intros.
  dependent destruction v; crush.
Qed.

Global Hint Resolve HT_context_shift : core.

(** * The main theorem, with the fully generalized induction hypothesis *)

Theorem HT_context_subst : forall Gamma t (e: expr Gamma t) (gamma: substitution Gamma []),
    HT_context gamma -> hereditary_termination (apply_substitution gamma e).
Proof.
  intros.
  generalize dependent gamma.
  induction e; crush.
  - edestruct IHe; crush.
  - eexists; intuition crush.
  - specialize (IHe3 gamma H).
    simplify.
    induction H0; crush.
    dependent induction H1; crush.
    eapply HT_prepend_step; [ | apply step_iter3 ]; crush.
Qed.

(** Specialize [HT_context_subst] to noop_substitution *)
Theorem exprs_ht :
  forall t (e: expr [] t),
    hereditary_termination e.
Proof.
  intros.
  replace e with (apply_substitution noop_substitution e) by crush.
  apply HT_context_subst.
  unfold HT_context; inversion v.
Qed.

(** Derive termination from [hereditary_termination]. *)
Theorem exprs_terminating :
  forall t (e: expr [] t),
    terminating e.
Proof.
  auto using hereditary_termination_terminating, exprs_ht.
Qed.

(** * We now go on to build a well-founded evaluator for System T. *)

(** First we need a computational version of step. The type builds in the
correctness proof, since this is the easiest time to do so. *)
Fixpoint maybe_step t (e: expr [] t) : {e' | step e e'} + {val e}.
  Ltac solve_val := try solve [ right; eauto ].
  destruct e; solve_val.
  - inversion v.
  - destruct (maybe_step _ e) as [[e' ?] | ]; solve_val.
    left.
    (* step_s *)
    exists (succ e'); eauto.
  - left.
    destruct (maybe_step _ e1) as [[e1' ?] |].
    (* step_ap1 *)
    + exists (app e1' e2); eauto.
    + destruct (maybe_step _ e2) as [[e2' ?] |].
      (* step_ap2 *)
      { exists (app e1 e2'); eauto. }
      dependent destruction e1;
        try solve [ exfalso; inversion v ].
      exists (subst e2 e1); eauto.
  - left.
    destruct (maybe_step _ e3) as [[e3' ?] |].
    (* step_iter1 *)
    { exists (iter e1 e2 e3'); eauto. }
    dependent destruction e3;
      try solve [ exfalso; inversion v ].
    + (* step_iter2 *)
      exists e1; eauto.
    + (* step_iter3 *)
      exists (subst (iter e1 e2 e3) e2).
      inversion v; eauto.
Defined.

(** The well-founded relation for evaluation is step, but reversed, since when e
|-> e', e' is smaller than e in terms of remaining evaluation steps. *)
Definition converse_step t e e' := step (t:=t) e' e.

Theorem converse_step_wf : forall t, well_founded (converse_step (t:=t)).
Proof.
  unfold well_founded, converse_step; intros t e.
  pose proof (exprs_terminating e); simplify.
  induction H.
  - constructor; intros.
    exfalso; eapply val_no_step; eauto.
  - constructor; intros.
    pose proof (step_deterministic H H2); subst; eauto.
Defined.

(** We now define the evaluator with just Fix and the above well-founded
relation *)
Definition eval t : expr [] t -> expr [] t.
Proof.
  refine (Fix (converse_step_wf (t:=t)) (fun _ => expr [] t)
              (fun e => match maybe_step e with
                     | inleft e' => _
                     | inright _ => _
                     end)); intro eval_e.
  - (* recursive subcall via relation proof *)
    exact (eval_e (proj1_sig e') (proj2_sig e')).
  - (* reached a value, terminate *)
    exact e.
Defined.

(** The correctness of eval is given by the fact that it returns a value and
satisfies e |->* eval e; such a function is actually unique due to
[step_val_unique] *)

Theorem eval_val : forall t (e: expr [] t), val (eval e).
Proof.
  unfold eval, Fix; intros.
  induction (converse_step_wf e) using Acc_inv_dep; simpl.
  destruct (maybe_step x); eauto.
Qed.

Theorem eval_step : forall t (e: expr [] t),
    e |->* eval e.
Proof.
  unfold eval, Fix; intros.
  induction (converse_step_wf e) using Acc_inv_dep; simpl.
  destruct (maybe_step x) as [[] |]; eauto.
Qed.

(** Here we give an alternate definition using Function *)
Function eval' t (e: expr [] t) {wf (converse_step (t:=t)) e} :=
  match maybe_step e with
  | inleft e' => eval' (proj1_sig e')
  | inright _ => e
  end.
Proof.
  - unfold converse_step.
    destruct e'; auto.
  - apply converse_step_wf.
Defined.

Theorem eval'_val : forall t (e: expr [] t), val (eval' e).
Proof.
  intros.
  functional induction (eval' e); eauto.
Qed.

Theorem eval'_step : forall t (e: expr [] t),
    e |->* eval' e.
Proof.
  intros.
  functional induction (eval' e); eauto.
  destruct e'; eauto.
Qed.

(** The correctness proofs guarantee eval and eval' agree. *)
Theorem eval_eq_eval' : forall t (e: expr [] t),
    eval e = eval' e.
Proof.
  intros.
  eapply (step_val_unique (e := e));
    eauto using eval_step, eval'_step,
    eval_val, eval'_val.
Qed.

(* Local Variables: *)
(* company-coq-local-symbols: (("Gamma" . ?Γ) ("gamma" . ?γ)) *)
(* End: *)


Inductive bool : Type :=
  | true
  | false.

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

(* These two examples show that && binds tighter than ||.
As you can see, it is written nowhere in code,
from which we can deduce that precedence of && and ||
is hard-coded into Coq*)

Example test_orb_andb1: true || false && false = true.
Proof. simpl. reflexivity. Qed.

Example test_orb_andb2: false && true || true = true.
Proof. simpl. reflexivity. Qed.


(** * SfLib: Software Foundations Library *)
(* Version of 10/14/2009 *)

(* ###################################################################### *)
(** Here we collect together several useful definitions and theorems from
   Basics, List, Poly, Props, and Logic that are not already in the Coq
   standard library. From now on we can [Import] or [Export] this file, instead of
   using all the examples and false starts in those files. *)

(** * From the Coq standard library *)

Require Omega.   (* needed for using the [omega] tactic *)
Require Export Bool.
Require Export List.
Require Export Arith.
Require Export Arith.EqNat.  (* Contains [beq_nat], among other things *)

(** * From Basics.v *)

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Ltac Case name := Case_aux Case name.
Ltac SCase name := Case_aux SCase name.
Ltac SSCase name := Case_aux SSCase name.
Ltac SSSCase name := Case_aux SSSCase name.
Ltac SSSSCase name := Case_aux SSSSCase name.
Ltac SSSSSCase name :=  Case_aux SSSSSCase name.
Ltac SSSSSSCase name := Case_aux SSSSSSCase name.
Ltac SSSSSSSCase name := Case_aux SSSSSSSCase name.

Fixpoint ble_nat (n m : nat) {struct n} : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => ble_nat n' m'
      end
  end.

Theorem andb_true_elim1 : forall b c,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    reflexivity.
  Case "b = false".
    rewrite <- H. reflexivity.  Qed.

Theorem andb_true_elim2 : forall b c,
  andb b c = true -> c = true.
Proof.
    intros. destruct b. simpl in H. apply H.
    simpl in H. inversion H.
Qed.

(** * From Props.v *)

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).

(** * From Logic.v *)

Theorem andb_true : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  intros b c H.
  destruct b.
    destruct c.
      apply conj. reflexivity. reflexivity.
      inversion H.
    inversion H.  Qed.

Theorem not_eq_beq_false : forall n n' : nat,
     n <> n'
  -> beq_nat n n' = false.
Proof.
    induction n.
        intros. destruct n'. elim H. reflexivity.
        simpl. reflexivity.

        intros. destruct n'.
            simpl. reflexivity.

            simpl. apply IHn.

            intro H'. rewrite H' in H. elim H. reflexivity.
Qed.

(*Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.  Qed.

Theorem ev_not_ev_S : forall n,
  ev n -> ~ ev (S n).
Proof.
  induction n.
  intros. simpl. unfold ev.
xdmitted.*)
(* An exercise in Logic.v *)

(*Theorem ble_nat_true : forall n m,
  ble_nat n m = true -> n <= m.

  induction n.
      intros. omega.

      intros. destruct m. simpl in H. inversion H.

      simpl in H.
 An exercise in Logic.v
xdmitted.

Theorem ble_nat_false : forall n m,
  ble_nat n m = false -> ~(n <= m).
 An exercise in Logic.v
xdmitted.
*)
(** This is not identical to the [partial_function] in Logic.v,
   because it permits the domain type [X] and the range type [Y]
   to be different.  The curly braces around
     [{X Y: Type}] are a concise way of saying
       [Implicit Arguments] for [X] and [Y]. *)

Definition partial_function {X Y: Type} (R: X -> Y -> Prop) :=
  forall (x: X) (y1 y2 : Y), R x y1 -> R x y2 -> y1 = y2.

(* Basic list functions *)

Fixpoint sameLength (X : Type) (Y : Type) (a : list X) (b : list Y) : Prop :=
    match a with
     | nil => b=nil
     | (_::r1) => match b with
                   | nil => False
                   | (_::r2) => sameLength X Y r1 r2
                  end
   end.

Implicit Arguments sameLength [X Y].

Fixpoint elementPair (X : Type) (Y : Type) (a : X) (b : Y) (l1 : list X) (l2 : list Y) : Prop :=
    match l1 with
     | nil => False
     | (x::r1) => match l2 with
                   | nil => False
                   | (y::r2) => (x=a /\ y=b) \/ elementPair X Y a b r1 r2
                  end
    end.

Implicit Arguments elementPair [X Y].

Fixpoint elementTriple (X : Type) (Y : Type) (Z : Type) (a : X) (b : Y) (c : Z) (l1 : list X) (l2 : list Y) (l3 : list Z) : Prop :=
    match l1 with
     | nil => False
     | (x::r1) => match l2 with
                   | nil => False
                   | (y::r2) => match l3 with
                                 | nil => False
                                 | (z::r3) => (x=a /\ y=b /\ z=c) \/ elementTriple X Y Z a b c r1 r2 r3
                                end
                  end
    end.

Implicit Arguments elementTriple [X Y Z].


(* TEMPORARY FOR BACKWARD COMPATIBILITY

(************************************************************)
(************************************************************)
(************************************************************)
(* LibNat *)

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

(* ---------------------------------------------------------------------- *)
(** ** Addition and substraction *)

Hint Rewrite plus_zero_r plus_zero_l minus_zero : rew_nat.

(* ---------------------------------------------------------------------- *)
(** ** Comparison -- DEPRECATED? *)

Section CompProp.
Implicit Types a b c n m : nat.

Lemma le_SS : forall n m, (S n <= S m) = (n <= m).
Proof using. nat_math. Qed.
Lemma ge_SS : forall n m, (S n >= S m) = (n >= m).
Proof using. nat_math. Qed.
Lemma lt_SS : forall n m, (S n < S m) = (n < m).
Proof using. nat_math. Qed.
Lemma gt_SS : forall n m, (S n > S m) = (n > m).
Proof using. nat_math. Qed.

Lemma plus_le_l : forall a b c,
  (a + b <= a + c) = (b <= c).
Proof using. nat_math. Qed.
Lemma plus_ge_l : forall a b c,
  (a + b >= a + c) = (b >= c).
Proof using. nat_math. Qed.
Lemma plus_lt_l : forall a b c,
  (a + b < a + c) = (b < c).
Proof using. nat_math. Qed.
Lemma plus_gt_l : forall a b c,
  (a + b > a + c) = (b > c).
Proof using. nat_math. Qed.

Lemma plus_le_r : forall a b c,
  (b + a <= c + a) = (b <= c).
Proof using. nat_math. Qed.
Lemma plus_ge_r : forall a b c,
  (b + a >= c + a) = (b >= c).
Proof using. nat_math. Qed.
Lemma plus_lt_r : forall a b c,
  (b + a < c + a) = (b < c).
Proof using. nat_math. Qed.
Lemma plus_gt_r : forall a b c,
  (b + a > c + a) = (b > c).
Proof using. nat_math. Qed.

End CompProp.

(* ---------------------------------------------------------------------- *)
(** ** Simplification tactic *)

(** [rew_nat] performs some basic simplification on
    expressions involving natural numbers *)

Hint Rewrite le_SS ge_SS lt_SS gt_SS : rew_nat.
Hint Rewrite plus_le_l plus_ge_l plus_lt_l plus_gt_l : rew_nat.
Hint Rewrite plus_le_r plus_ge_r plus_lt_r plus_gt_r : rew_nat.

Tactic Notation "rew_nat" :=
  autorewrite with rew_nat.
Tactic Notation "rew_nat" "~" :=
  rew_nat; auto_tilde.
Tactic Notation "rew_nat" "*" :=
  rew_nat; auto_star.
Tactic Notation "rew_nat" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_nat).
  (* autorewrite with rew_nat in *. *)
Tactic Notation "rew_nat" "~" "in" "*" :=
  rew_nat in *; auto_tilde.
Tactic Notation "rew_nat" "*" "in" "*" :=
  rew_nat in *; auto_star.
Tactic Notation "rew_nat" "in" hyp(H) :=
  autorewrite with rew_nat in H.
Tactic Notation "rew_nat" "~" "in" hyp(H) :=
  rew_nat in H; auto_tilde.
Tactic Notation "rew_nat" "*" "in" hyp(H) :=
  rew_nat in H; auto_star.

(* ********************************************************************** *)
(** * -- TODO: Other operations and lemmas (not stable) *)

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

Definition div (n q : nat) :=
  match q with
  | 0 => 0
  | S predq =>
  let aux := fix aux (m r : nat) {struct m} :=
    match m,r with
    | 0, _ => 0
    | S m',0 => (1 + aux m' predq)%nat
    | S m', S r' => aux m' r'
    end in
  aux n predq
  end.

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

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

Fixpoint factorial (n:nat) : nat :=
  match n with
  | 0 => 1
  | S n' => n * (factorial n')
  end.

(************************************************************)
(************************************************************)
(************************************************************)
(* LibInt *)

(** --TODO: remove lemma below with comparisons in %nat *)

Lemma le_nat_of_le_int' : forall (n m:nat),
  (n:int) <= (m:int) ->
  (n <= m)%nat.
Proof using. math. Qed.

Lemma le_int_of_le_nat' : forall (n m:nat),
  (n <= m)%nat ->
  (n:int) <= (m:int).
Proof using. math. Qed.

Lemma lt_nat_of_lt_int' : forall (n m:nat),
  (n:int) < (m:int) ->
  (n < m)%nat.
Proof using. math. Qed.

Lemma lt_int_of_lt_nat' : forall (n m:nat),
  (n < m)%nat ->
  (n:int) < (m:int).
Proof using. math. Qed.

Lemma ge_nat_of_ge_int' : forall (n m:nat),
  (n:int) >= (m:int) ->
  (n >= m)%nat.
Proof using. math. Qed.

Lemma ge_int_of_ge_nat' : forall (n m:nat),
  (n >= m)%nat ->
  (n:int) >= (m:int).
Proof using. math. Qed.

Lemma gt_nat_of_gt_int' : forall (n m:nat),
  (n:int) > (m:int) ->
  (n > m)%nat.
Proof using. math. Qed.

Lemma gt_int_of_gt_nat' : forall (n m:nat),
  (n > m)%nat ->
  (n:int) > (m:int).
Proof using. math. Qed.

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

Lemma abs_eq_nat_inv : forall (x:int) (y:nat),
  abs x = y :> nat ->
  x >= 0 ->
  x = y :> int.

Lemma abs_neq_nat_inv : forall (x:int) (y:nat),
  abs x <> y :> nat ->
  x >= 0 ->
  x <> y :> int.

(* ---------------------------------------------------------------------- *)
(** ** Calling [maths] after eliminating boolean reflection *)

(** [maths] is a more powerful version of [math],
    able to deconstruct conjunctions, disjunctions,
    and negations, but as a consequence it might be slower. *)

Hint Rewrite istrue_and istrue_or istrue_neg : rew_reflect_and_or_neg.

Ltac maths_core tt :=
  autorewrite with rew_reflect_and_or_neg in *; intuition math.

Tactic Notation "maths" :=
  maths_core tt.

(* ---------------------------------------------------------------------- *)
(** ** Extend [zify] to handle [Z.to_nat]. *)

Lemma Z_of_nat_zify : forall x, Z.of_nat (Z.to_nat x) = Z.max 0 x.
Proof using.
  intros x. destruct x.
  - rewrite Z2Nat.id; reflexivity.
  - rewrite Z2Nat.inj_pos. math_lia.
  - rewrite Z2Nat.inj_neg. math_lia.
Qed.

Ltac zify_nat_op_extended :=
  match goal with
  | H : context [ Z.of_nat (Z.to_nat ?a) ] |- _ => rewrite (Z_of_nat_zify a) in H
  | |- context [ Z.of_nat (Z.to_nat ?a) ] => rewrite (Z_of_nat_zify a)
  | _ => zify_nat_op
  end.

Ltac zify_nat ::= repeat zify_nat_rel; repeat zify_nat_op_extended; unfold Z_of_nat' in *.

(************************************************************)
(* * Pow function *)

From TLC Require Import Zpow_facts.

Lemma power_pos:
  forall k n,
  0 < n ->
  0 <= k ->
  1 <= n^k.
Proof using.
  intros. math_rewrite (1 = n^0). reflexivity.
  apply Zpower_le_monotone; math.
Qed.

Lemma pow2_pos : forall n, n >= 0 -> 2^n >= 1.
Proof using.
  intros. forwards: power_pos n 2; math.
Qed.

Lemma pow2_succ : forall n, n >= 0 -> 2^(n+1) = 2*2^n.
Proof using.
  intros. math_rewrite (n+1 = Zsucc n).
  rewrite Zpower_Zsucc; math.
Qed.

(* A tactic that helps dealing with goals containing "b^m" for multiple m *)
From TLC Require Import List.

Ltac subst_eq_boxer_list l rewrite_tac :=
  match l with
  | nil => idtac
  | (@boxer _ ?p) :: ?Hs =>
    match p with
      (?tm, ?Htm) =>
      rewrite_tac Htm; clear Htm; clear tm;
      subst_eq_boxer_list Hs rewrite_tac
    end
  end.

(* Develop occurences of (b ^ m) in H into (b ^ (m - min_e) * b ^ min_e).
   (and try to simplify/compute b^(m - min_e)).
 *)
Ltac rew_pow_develop b m min_e H :=
  let m_eq_plusminus := fresh in
  assert (m = min_e + (m - min_e)) as m_eq_plusminus
      by (rewrite Zplus_minus; reflexivity);
  rewrite m_eq_plusminus in H; clear m_eq_plusminus;
  rewrite (Z.pow_add_r b min_e (m - min_e)) in H; [
    rewrite Z.mul_comm in H;
    let tm' := fresh "tm'" in
    let H' := fresh "H'" in
    remember (b ^ (m - min_e)) as tm' eqn:H' in H;
    let e := fresh "e" in
    evar (e: int);
    let Heqe := fresh in
    assert (e = m - min_e) as Heqe
        by (ring_simplify; subst e; reflexivity);
    rewrite <-Heqe in H'; clear Heqe; unfold e in H'; ring_simplify in H';
    rewrite H' in H; clear H'; clear tm'; clear e;
    try rewrite Z.mul_1_l in H
  | ring_simplify; auto with zarith ..].

Ltac rew_pow_aux_goal b min_e normalized_acc :=
  match goal with
  | |- context [ b ^ ?m ] =>
    let tm := fresh "tm" in
    let Heqtm := fresh "Heqtm" in
    remember (b ^ m) as tm eqn:Heqtm in |- *;
    rew_pow_develop b m min_e Heqtm; [
      rew_pow_aux_goal b min_e ((boxer (tm, Heqtm)) :: normalized_acc)
    | ..]
  | _ => subst_eq_boxer_list normalized_acc ltac:(fun E => rewrite E)
  end.

Ltac rew_pow_aux_in b min_e H normalized_acc :=
  match type of H with
  | context [ b ^ ?m ] =>
    let tm := fresh "tm" in
    let Heqtm := fresh "Heqtm" in
    remember (b ^ m) as tm eqn:Heqtm in H;
    rew_pow_develop b m min_e Heqtm; [
      rew_pow_aux_in b min_e H ((boxer (tm, Heqtm)) :: normalized_acc)
    | ..]
  | _ => subst_eq_boxer_list normalized_acc ltac:(fun E => rewrite E in H)
  end.

Tactic Notation "rew_pow" constr(b) constr(min_e) :=
  rew_pow_aux_goal b min_e (@nil Boxer).
Tactic Notation "rew_pow" "~" constr(b) constr(min_e) :=
  rew_pow_aux_goal b min_e (@nil Boxer); auto_tilde.
Tactic Notation "rew_pow" "*" constr(b) constr(min_e) :=
  rew_pow_aux_goal b min_e (@nil Boxer); auto_star.
Tactic Notation "rew_pow" constr(b) constr(min_e) "in" hyp(H) :=
  rew_pow_aux_in b min_e H (@nil Boxer).
Tactic Notation "rew_pow" "~" constr(b) constr(min_e) "in" hyp(H) :=
  rew_pow_aux_in b min_e H (@nil Boxer); auto_tilde.
Tactic Notation "rew_pow" "*" constr(b) constr(min_e) "in" hyp(H) :=
  rew_pow_aux_in b min_e H (@nil Boxer); auto_star.

(* Test  -- TODO: move *)
(* Axiom P : int -> Prop.  *)
(* Goal forall n, P (1 + 2 ^ (n + 3) + 2 ^ n + 2 ^ (n+1)). *)
(* Proof. *)
(*   intros. *)
(*   skip_asserts: (3 = 2 ^ (n+3)). rew_pow 2 n in H. *)
(*   rew_pow 2 n. *)
(* Admitted. *)

(************************************************************)
(* * Min function *)

From TLC Require Import LibEpsilon.

Instance int_le_total_order : Le_total_order (A:=int).
Proof using.
  constructor. constructor. constructor; unfolds.
  math. math. unfolds. math. unfolds.
  intros. tests: (x <= y). left~. right. math.
Qed.

(* --TODO: make polymorphic with classes *)

Section Min.
Implicit Types x y : int.

Definition min x y :=
  If x <= y then x else y.

Lemma min_self : forall x,
  min x x = x.
Proof using. intros. unfolds min. case_if~. Qed.

Lemma min_left : forall x y,
  x <= y ->
  min x y = x.
Proof using. intros. unfolds min. case_if~. false*. Qed.

Lemma min_right : forall x y,
  y <= x ->
  min x y = y.
Proof using. intros. unfolds min. case_if~. apply~ le_antisym. Qed.

Lemma min_trans_inv : forall a b x y : int,
  min a b <= x ->
  y < a ->
  y < b ->
  y < x.
Proof using. intros. unfolds min. case_if; math. Qed.

End Min.

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

Lemma plus_le_l : forall a b c,
  (a + b <= a + c) = (b <= c).
Proof using. math. Qed.
Lemma plus_ge_l : forall a b c,
  (a + b >= a + c) = (b >= c).
Proof using. math. Qed.
Lemma plus_lt_l : forall a b c,
  (a + b < a + c) = (b < c).
Proof using. math. Qed.
Lemma plus_gt_l : forall a b c,
  (a + b > a + c) = (b > c).
Proof using. math. Qed.

Lemma plus_le_r : forall a b c,
  (b + a <= c + a) = (b <= c).
Proof using. math. Qed.
Lemma plus_ge_r : forall a b c,
  (b + a >= c + a) = (b >= c).
Proof using. math. Qed.
Lemma plus_lt_r : forall a b c,
  (b + a < c + a) = (b < c).
Proof using. math. Qed.
Lemma plus_gt_r : forall a b c,
  (b + a > c + a) = (b > c).
Proof using. math. Qed.

Hint Rewrite plus_le_l plus_ge_l plus_lt_l plus_gt_l : rew_int.
Hint Rewrite plus_le_r plus_ge_r plus_lt_r plus_gt_r : rew_int.

(* ********************************************************************** *)
(** * Advanced induction *)

(* --TODO: move to LibNat *)
(* --TODO: document and explain when this is needed *)

Definition eq_gt_implies (P : (nat->Prop) -> Prop) :=
  forall n,
  (forall m, n > m -> P (eq m)) ->
  P (gt n).

Definition eq_lt_implies (P : (nat->Prop) -> Prop) :=
  forall n,
  (forall m, n < m -> P (eq m)) ->
  P (gt n).

Hint Unfold eq_lt_implies eq_gt_implies. (* --TODO: rename *)

Lemma eq_lt_induction : forall (P : (nat->Prop) -> Prop),
  (forall n, (forall m, n > m -> P (eq m)) -> P (lt n)) ->
  (forall n, P (lt n) -> P (eq n)) ->
  (forall n, P (eq n)).
Proof using. intros. induction n using peano_induction. auto. Qed.

Lemma eq_gt_induction : forall (P : (nat->Prop) -> Prop),
  (forall n, (forall m, n > m -> P (eq m)) -> P (gt n)) ->
  (forall n, P (gt n) -> P (eq n)) ->
  (forall n, P (eq n)).
Proof using. intros. induction n using peano_induction. auto. Qed.

Lemma eq_gt_induction_2 : forall (P1 P2 : (nat->Prop) -> Prop),
  eq_gt_implies P1 ->
  eq_gt_implies P2 ->
  (forall n, P1 (gt n) -> P2 (gt n) -> P1 (eq n) /\ P2 (eq n)) ->
     (forall n, P1 (eq n))
  /\ (forall n, P2 (eq n)).
Proof using.
  introv H1 H2 R.
  cuts M: (forall n, P1 (eq n) /\ P2 (eq n)).
    split; intros n; specializes M n; autos*.
  induction n using peano_induction. apply R;
    match goal with K: eq_gt_implies ?Pi |- ?Pi _ =>
      apply K; intros; forwards*: H; try math end.
Qed.

(* --TODO add missing arities *)

Lemma eq_gt_induction_5 : forall (P1 P2 P3 P4 P5 : (nat->Prop) -> Prop),
  eq_gt_implies P1 ->
  eq_gt_implies P2 ->
  eq_gt_implies P3 ->
  eq_gt_implies P4 ->
  eq_gt_implies P5 ->
  (forall n, P1 (gt n) -> P2 (gt n) -> P3 (gt n) -> P4 (gt n) -> P5 (gt n) ->
    P1 (eq n) /\ P2 (eq n) /\ P3 (eq n) /\ P4 (eq n) /\ P5 (eq n)) ->
     (forall n, P1 (eq n))
  /\ (forall n, P2 (eq n))
  /\ (forall n, P3 (eq n))
  /\ (forall n, P4 (eq n))
  /\ (forall n, P5 (eq n)).
Proof using.
  introv H1 H2 H3 H4 H5 R.
  cuts M: (forall n, P1 (eq n) /\ P2 (eq n) /\ P3 (eq n) /\ P4 (eq n) /\ P5 (eq n)).
    splits; intros n; specializes M n; autos*.
  induction n using peano_induction. apply R;
    match goal with K: eq_gt_implies ?Pi |- ?Pi _ =>
      apply K; intros; forwards*: H; try math end.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Modulo function *)

Lemma mod_eq_prove : forall k a b n,
  a = b + k * n -> a mod n = b mod n.
Proof using. intros. subst. rewrite~ Z_mod_plus_full. Qed.

Lemma mod_prove : forall k a b n,
  a = b + k * n -> 0 <= b -> b < n -> a mod n = b.
Proof using.
  intros. rewrite <- (@Zmod_small b n).
  apply* mod_eq_prove. math.
Qed.

Lemma mod2_zero :
  0 mod 2 = 0.
Proof using. reflexivity. Qed.

Lemma mod2_odd : forall k,
  (2 * k) mod 2 = 0.
Proof using. intros. apply (mod_prove k); math. Qed.

Lemma mod2_even : forall k,
  (2 * k + 1) mod 2 = 1.
Proof using. intros. apply (mod_prove k); math. Qed.

Lemma div2_odd : forall k,
  (2 * k) / 2 = k.
Proof using.
  intros. math_rewrite (2*k=k*2).
  apply Z_div_mult_full. math.
Qed.

Lemma div2_even : forall k,
  k >= 0 -> (2 * k + 1) / 2 = k.
Proof using. intros. symmetry. eapply Zdiv_unique with (r:=1); math. Qed.

Lemma mod2_bound : forall n,
  0 <= n mod 2 < 2.
Proof using. (* using stdlib *)
  intros. forwards: (Z_mod_remainder n 2). math.
  destruct H as [[? ?]|[? ?]]; math.
Qed.

Lemma div2_bounds : forall m n,
  m = n / 2 -> 2 * m <= n /\ n <= 2 * m + 1.
Proof using. (* using stdlib *)
  intros. lets K: (Z_div_mod_eq n 2) __. math. (* --TODO: forwards shouldn't do simpl *)
  rewrite <- H in K.
  lets [E1 E2]: (mod2_bound n). math.
Qed.

Implicit Arguments div2_bounds [m n].

Hint Rewrite mod2_zero mod2_odd mod2_even div2_odd div2_even : rew_parity.

Ltac rew_parity :=
  autorewrite with rew_parity.

(* ---------------------------------------------------------------------- *)
(** ** Comparison lifted *)

Lemma nat_int_lt : forall (n m:nat),
  n < m ->
  (n:int) < (m:int).
Proof using. math. Qed.

Lemma nat_int_le : forall (x y:nat),
  x <= y ->
  ((x:int) <= (y:int)).
Proof using. math. Qed.

Lemma nat_int_ge : forall (x y:nat),
  x >= y ->
  (x:int) >= (y:int).
Proof using. math. Qed.

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(* * LibOrder *)

(* ********************************************************************** *)
(* * Order modulo *)

(* --TODO: deprecate this *)

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(* * LibWf *)

Lemma measure_2_induction : forall A B (mu : A -> B -> nat) (P : A -> B -> Prop),
  (forall x1 x2, (forall y1 y2, mu y1 y2 < mu x1 x2 -> P y1 y2) -> P x1 x2) ->
  (forall x1 x2, P x1 x2).
Proof using.
  introv H. intros x1 x2. gen_eq p: (x1,x2). gen x1 x2.
  induction_wf IH: (wf_measure (fun p => mu (fst p) (snd p))) p.
  introv E. destruct p. inverts E. apply H.
  introv L. apply* IH. simpl. auto.
Qed.

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(* * LibWf *)

(** [unfold_wf] and [unfolds_wf] are shorthands for unfolding
    combinators used in definitions related to well-foundedness. *)

Ltac unfold_wf_base :=
  unfold_unproj; unfold_uncurryp;
  unfold lexico4, lexico3, lexico2.

Ltac unfolds_wf_base :=
  unfolds_unproj; unfolds_uncurryp; unfolds_lexico.

Tactic Notation "unfold_wf" :=
  unfold_wf_base.
Tactic Notation "unfold_wf" "~" :=
  unfold_wf; auto_tilde.
Tactic Notation "unfold_wf" "*" :=
  unfold_wf; auto_star.

Tactic Notation "unfolds_wf" :=
  unfolds_wf_base.
Tactic Notation "unfolds_wf" "~" :=
  unfolds_wf; auto_tilde.
Tactic Notation "unfolds_wf" "*" :=
  unfolds_wf; auto_star.

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(* * LibFix *)

(* ********************************************************************** *)
(** * Extraction product *)

(* ---------------------------------------------------------------------- *)
(** ** Extraction for Caml *)

Extraction Language Ocaml.

Extract Constant FixFunMod =>
  "(fun bigf -> let rec f x = bigf f x in f)".

Extract Constant FixValMod =>
  "(fun bigf -> let rec x = lazy (Lazy.force (bigf x)) in x)".

Extract Constant FixValModMut2 =>
 "(fun f1 f2 ->
  let rec x1 = lazy (Lazy.force (f1 x1 x2))
      and x2 = lazy (Lazy.force (f2 x1 x2)) in
  Pair (x1,x2))".

(* optional
Extraction Inline FixFunMod.
Extraction Inline FixValMod.
Extraction Inline FixValModMut2.
*)

(* ---------------------------------------------------------------------- *)
(** ** Extraction for Haskell *)

Extraction Language Haskell.

Extract Constant Fix =>
  "(fun bigf => let x = bigf x in x)".

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(* * LibMultiset *)

Hint Resolve foreach_empty foreach_single foreach_union.

Hint Rewrite foreach_union_eq : rew_foreach.

Tactic Notation "rew_foreach" :=
  autorewrite with rew_foreach.
Tactic Notation "rew_foreach" "~" constr(H) :=
  rew_foreach H; auto_tilde.
Tactic Notation "rew_foreach" "*" constr(H) :=
  rew_foreach H; auto_star.
Tactic Notation "rew_foreach" hyp(H) :=
  autorewrite with rew_foreach in H.

(* -- TODO: share [rew_foreach] tactics in LibContainer *)

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(* * LibSet *)

(* ********************************************************************** *)
(** * Tactics *)

(* DEPRECATED, use "set_prove" when possible *)

(* ---------------------------------------------------------------------- *)
(** ** Tactics to prove equalities on unions *)

(* Documentation appears further on *)

Lemma for_set_union_assoc : forall A,
  assoc (union (T:=set A)).
Proof using. intros. apply union_assoc. Qed.

Lemma for_set_union_comm : forall A,
  comm (union (T:=set A)).
Proof using. intros. apply union_comm. Qed.

Lemma for_set_union_empty_l : forall A (E:set A),
  \{} \u E = E.
Proof using. intros. apply union_empty_l. Qed.

Lemma for_set_union_empty_r : forall A (E:set A),
  E \u \{} = E.
Proof using. intros. apply union_empty_r. Qed.

Hint Rewrite <- for_set_union_assoc : rew_permut_simpl.
Hint Rewrite for_set_union_empty_l for_set_union_empty_r : rew_permut_simpl.
Ltac rew_per :=
  autorewrite with rew_permut_simpl; try typeclass.
Ltac rews_permut_simpl :=
  autorewrite with rew_permut_simpl in *; try typeclass.

Section PermutationTactic.
Context (A:Type).
Implicit Types l : set A.

Lemma permut_get_1 : forall l1 l2,
  (l1 \u l2) = (l1 \u l2).
Proof using. intros. auto. Qed.

Lemma permut_get_2 : forall l1 l2 l3,
  (l1 \u l2 \u l3) = (l2 \u l1 \u l3).
Proof using. intros. apply union_comm_assoc. Qed.

Lemma permut_get_3 : forall l1 l2 l3 l4,
  (l1 \u l2 \u l3 \u l4) = (l2 \u l3 \u l1 \u l4).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_2.
Qed.

Lemma permut_get_4 : forall l1 l2 l3 l4 l5,
    (l1 \u l2 \u l3 \u l4 \u l5)
  = (l2 \u l3 \u l4 \u l1 \u l5).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_3.
Qed.

Lemma permut_get_5 : forall l1 l2 l3 l4 l5 l6,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6)
  = (l2 \u l3 \u l4 \u l5 \u l1 \u l6).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_4.
Qed.

Lemma permut_get_6 : forall l1 l2 l3 l4 l5 l6 l7,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l1 \u l7).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_5.
Qed.

Lemma permut_get_7 : forall l1 l2 l3 l4 l5 l6 l7 l8,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l1 \u l8).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_6.
Qed.

Lemma permut_get_8 : forall l1 l2 l3 l4 l5 l6 l7 l8 l9,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8 \u l9)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8 \u l1 \u l9).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_7.
Qed.

Lemma permut_cancel_1 : forall l1 l2,
  (l1 \u l1 \u l2) = l1 \u l2.
Proof using. intros. rewrite union_assoc. rewrite union_self. auto. Qed.

Lemma permut_cancel_2 : forall l1 l2 l3,
  (l1 \u l2 \u l1 \u l3) = (l1 \u l2 \u l3).
Proof using.
  intros. rewrite <- (@permut_get_2 l1). apply permut_cancel_1.
Qed.

Lemma permut_cancel_3 : forall l1 l2 l3 l4,
  (l1 \u l2 \u l3 \u l1 \u l4) = (l1 \u l2 \u l3 \u l4).
Proof using.
  intros. rewrite <- (@permut_get_3 l1). apply permut_cancel_1.
Qed.

Lemma permut_cancel_4 : forall l1 l2 l3 l4 l5,
    (l1 \u l2 \u l3 \u l4 \u l1 \u l5)
  = (l1 \u l2 \u l3 \u l4 \u l5).
Proof using.
  intros. rewrite <- (@permut_get_4 l1). apply permut_cancel_1.
Qed.

Lemma permut_cancel_5 : forall l1 l2 l3 l4 l5 l6,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l1 \u l6)
  = (l1 \u l2 \u l3 \u l4 \u l5 \u l6).
Proof using.
  intros. rewrite <- (@permut_get_5 l1). apply permut_cancel_1.
Qed.

Lemma permut_tactic_setup : forall l1 l2,
   (\{} \u l1 \u \{}) = (l2 \u \{}) -> l1 = l2.
Proof using. intros. rews_permut_simpl. Qed.

Lemma permut_tactic_keep : forall l1 l2 l3 l4,
  ((l1 \u l2) \u l3) = l4 ->
  (l1 \u (l2 \u l3)) = l4.
Proof using. intros. rews_permut_simpl. Qed.

Lemma permut_tactic_simpl : forall l1 l2 l3 l4,
  (l1 \u l3) = l4 ->
  (l1 \u (l2 \u l3)) = (l2 \u l4).
Proof using. intros. subst. apply permut_get_2. Qed.

Lemma permut_tactic_trans : forall l1 l2 l3,
  l3 = l2 -> l1 = l3 -> l1 = l2.
Proof using. intros. subst~. Qed.

End PermutationTactic.

(** [permut_lemma_get n] returns the lemma [permut_get_n]
    for the given value of [n] *)

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

(** [permut_prepare] applies to a goal of the form [permut l l']
    and sets [l] and [l'] in the form [l1 \u l2 \u .. \u \{}],
    (some of the lists [li] are put in the form [x::\{}]). *)

Ltac permut_simpl_prepare :=
   rew_permut_simpl;
   apply permut_tactic_setup;
   repeat rewrite <- union_assoc.

(* --TODO : doc *)

Ltac cancel_all_dup l :=
  repeat first
    [ rewrite (permut_cancel_1 l)
    | rewrite (permut_cancel_2 l)
    | rewrite (permut_cancel_3 l)
    | rewrite (permut_cancel_4 l)
    | rewrite (permut_cancel_5 l) ].

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

(** [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_simpl_once :=
  match goal with
  | |- (_ \u \{}) = _ => fail 1
  | |- (_ \u (?l \u ?lr)) = ?l' =>
     cancel_all_dup 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;
            [ eapply F; try typeclass
            | apply permut_tactic_simpl ]
     end
  end.

Ltac permut_simpl :=
  permut_simpl_prepare;
  repeat permut_simpl_once;
  rew_permut_simpl;
  try apply refl_equal.

(* --TODO: move demos somewhere else *)

Section DemoSetUnion.
Variables (A:Type).

Lemma demo_set_union_permut_simpl_1 :
  forall l1 l2 l3 : set A,
  (l1 \u l2 \u l3 \u l1) = (l3 \u l2 \u l1).
Proof using.
  intros.
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  rew_permut_simpl.
Qed.

Lemma demo_set_union_permut_simpl_2 :
  forall
  (x:A) l1 l2 l3,
  (l1 \u \{x} \u l3 \u l2) = (l1 \u l2 \u (\{x} \u l3)).
Proof using.
  intros.
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  rew_permut_simpl.
Qed.

Lemma demo_set_union_permut_simpl_3 : forall (x y:A) l1 l1' l2 l3,
  l1 = l1' ->
    (l1 \u (\{x} \u l2) \u \{x} \u (\{y} \u l3))
  = (\{y} \u (l1' \u l2) \u (\{x} \u l3)).
Proof using.
  intros.
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  try permut_simpl_once.
  rew_permut_simpl.
Qed.

End DemoSetUnion.

(* ---------------------------------------------------------------------- *)
(** ** Tactics to prove membership *)

(* DEPRECATED: use "set_prove" when possible *)

Section InUnionGet.
Variables (A:Type).
Implicit Types l : set A.

Lemma in_union_get_1 : forall x l1 l2,
  x \in l1 -> x \in (l1 \u l2).
Proof using. intros. apply in_union_l. auto. Qed.

Lemma in_union_get_2 : forall x l1 l2 l3,
  x \in l2 -> x \in (l1 \u l2 \u l3).
Proof using. intros. apply in_union_r. apply~ in_union_get_1. Qed.

Lemma in_union_get_3 : forall x l1 l2 l3 l4,
  x \in l3 -> x \in (l1 \u l2 \u l3 \u l4).
Proof using. intros. apply in_union_r. apply~ in_union_get_2. Qed.

Lemma in_union_get_4 : forall x l1 l2 l3 l4 l5,
  x \in l4 -> x \in (l1 \u l2 \u l3 \u l4 \u l5).
Proof using. intros. apply in_union_r. apply~ in_union_get_3. Qed.

Lemma in_union_get_5 : forall x l1 l2 l3 l4 l5 l6,
  x \in l5 -> x \in (l1 \u l2 \u l3 \u l4 \u l5 \u l6).
Proof using. intros. apply in_union_r. apply~ in_union_get_4. Qed.

End InUnionGet.

Arguments in_union_get_1 [A] [x] [l1] [l2].
Arguments in_union_get_2 [A] [x] [l1] [l2] [l3].
Arguments in_union_get_3 [A] [x] [l1] [l2] [l3] [l4].
Arguments in_union_get_4 [A] [x] [l1] [l2] [l3] [l4] [l5].
Arguments in_union_get_5 [A] [x] [l1] [l2] [l3] [l4] [l5] [l6].

Ltac in_union_get :=
  match goal with H: ?x \in ?A |- ?x \in ?B =>
  match B with context [A] =>
  let go tt := first
        [ apply (in_union_get_1 H)
        | apply (in_union_get_2 H)
        | apply (in_union_get_3 H)
        | apply (in_union_get_4 H)
        | apply (in_union_get_5 H) ] in
  first [ go tt
        | rewrite <- (for_set_union_empty_r B);
          repeat rewrite <- for_set_union_assoc;
          go tt ]
  end end.

Hint Extern 3 (_ \in _ \u _) => in_union_get.

Section InUnionExtract.
Variables (A:Type).
Implicit Types l : set A.

Lemma in_union_extract_1 : forall x l1,
  x \in (\{x} \u l1).
Proof using. intros. apply in_union_get_1. apply in_single_self. Qed.

Lemma in_union_extract_2 : forall x l1 l2,
  x \in (l1 \u \{x} \u l2).
Proof using. intros. apply in_union_get_2. apply in_single_self. Qed.

Lemma in_union_extract_3 : forall x l1 l2 l3,
  x \in (l1 \u l2 \u \{x} \u l3).
Proof using. intros. apply in_union_get_3. apply in_single_self. Qed.

Lemma in_union_extract_4 : forall x l1 l2 l3 l4,
  x \in (l1 \u l2 \u l3 \u \{x} \u l4).
Proof using. intros. apply in_union_get_4. apply in_single_self. Qed.

Lemma in_union_extract_5 : forall x l1 l2 l3 l4 l5,
  x \in (l1 \u l2 \u l3 \u l4 \u \{x} \u l5).
Proof using. intros. apply in_union_get_5. apply in_single_self. Qed.

End InUnionExtract.

Ltac in_union_extract :=
  match goal with |- ?x \in ?A =>
  match A with context [\{x}] =>
  let go tt := first
        [ apply (in_union_extract_1)
        | apply (in_union_extract_2)
        | apply (in_union_extract_3)
        | apply (in_union_extract_4)
        | apply (in_union_extract_5) ] in
  first [ go tt
        | rewrite <- (for_set_union_empty_r A);
          repeat rewrite <- for_set_union_assoc;
          go tt ]
  end end.

Hint Extern 3 (_ \in _) => in_union_extract.

(* ---------------------------------------------------------------------- *)
(** ** Tactics to invert a membership hypothesis *)

(* --TODO: document and clean up *)

Section InversionsTactic.
Context (A:Type).
Implicit Types l : set A.
Implicit Types x : A.
Lemma empty_eq_single_inv_1 : forall x l1 l2,
  l1 = l2 -> x \notin l1 -> x \in l2 -> False.
Proof using. intros. subst*. Qed.
Lemma empty_eq_single_inv_2 : forall x l1 l2,
  l1 = l2 -> x \notin l2 -> x \in l1 -> False.
Proof using. intros. subst*. Qed.
Lemma notin_empty : forall x,
  x \notin (\{}:set A).
Proof using. intros. unfold notin. rewrite in_empty_eq. auto. Qed.
End InversionsTactic.
Hint Resolve notin_empty.

Ltac in_union_meta :=
  match goal with
  | |- _ \in \{_} => apply in_single_self
  | |- _ \in \{_} \u _ => apply in_union_l; apply in_single_self
  | |- _ \in _ \u _ => apply in_union_r; in_union_meta
  end.

Ltac fset_inv_core_for H :=
  let go L :=
     false L; [ apply H
              | try apply notin_empty
              | instantiate; try in_union_meta ] in
  match type of H with
  | \{} = _ => go empty_eq_single_inv_1
  | _ = \{} => go empty_eq_single_inv_2
  | _ = _ => go empty_eq_single_inv_1
  end.

Tactic Notation "fset_inv" constr(H) :=
  fset_inv_core_for H.

Ltac fset_inv_core :=
  match goal with
  | |- \{} <> _ => let H := fresh in intro H; fset_inv H
  | |- _ <> \{} => let H := fresh in intro H; fset_inv H
  | H: \{} = _ |- _ => fset_inv H
  | H: _ = \{} |- _ => fset_inv H
  end.

Tactic Notation "fset_inv" :=
  fset_inv_core.

Section InUnionInv.
Variables (A:Type).
Implicit Types l : set A.

Lemma set_in_empty_inv : forall x,
  x \in (\{}:set A) -> False.
Proof using. introv. apply notin_empty. Qed.
Lemma set_in_single_inv : forall x y : A,
  x \in (\{y}:set A) -> x = y.
Proof using. intros. rewrite @in_single_eq in H. auto. typeclass. Qed.
Lemma set_in_union_inv : forall x l1 l2,
  x \in (l1 \u l2) -> x \in l1 \/ x \in l2.
Proof using. introv H. rewrite @in_union_eq in H. auto. typeclass. Qed.

End InUnionInv.

Arguments set_in_single_inv [A] [x] [y].
Arguments set_in_union_inv [A] [x] [l1] [l2].

Ltac set_in_inv_base H M :=
  match type of H with
  | _ \in \{} => false; apply (@set_in_empty_inv _ _ H)
  | _ \in \{_} =>
    generalize (set_in_single_inv H); try clear H; intro_subst
  | _ \in _ \u _ =>
    let H' := fresh "TEMP" in
    destruct (set_in_union_inv H) as [H'|H'];
    try clear H; set_in_inv_base H' M
  | _ => rename H into M
  end.

Tactic Notation "set_in" constr(H) "as" ident(M) :=
  set_in_inv_base H M.
Tactic Notation "set_in" constr(H) :=
  let M := fresh "H" in set_in H as M.

(* ---------------------------------------------------------------------- *)
(** ** Tactic to prove two sets equal by double-inclusion *)

(* DEPRECATED: use "set_prove" instead when possible *)

Tactic Notation "eq_set" :=
  let H := fresh "TEMP" in
  apply set_ext; iff H; set_in H; in_union_get.
Tactic Notation "eq_set" "*" :=
  eq_set; auto_star.

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

(* FUTURE

  (** Sets of sets *)

  (* --TODO: typeclass for bigunion and bigintersection *)

  Definition bigunion_impl A (E : set (set A)) : set A :=
    \set{ x | exists_ F \in E, x \in (F:set A) }.

  Definition biguinter_impl A (E : set (set A)) : set A :=
    \set{ x | forall_ F \in E, x \in (F:set A) }.

*)

(************************************************************)
(************************************************************)
(************************************************************)
(* LibMap *)

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

(* migration:

  map_split ==> split_restrict_remove
  map_split ==> split_restrict_remove_single
  map_index_def ==> index_def
  map_indom_update_already => LibMap.indom_update_already
  map_indom_update_inv => LibMap.indom_update_inv
  map_restrict_single ==> restrict_single
  map_update_restrict ==> update_remove_one_eq
  dom_restrict_in ==> index_remove_one_in
  restrict_read ==> remove_one_read_neq
  restrict_update ==> remove_one_update_neq

  map_indom_update => indom_update
  map_indom_update_self => indom_update_self
  binds_inv => rewrite binds_def
  binds_get => binds_read

  map_update_read_eq => update_read_eq
  map_update_read_neq => update_read_neq
  map_update_read_if => update_read_if

  dom_update_in => dom_update_index
  dom_update_in_variant => dom_update_index'
  dom_update_notin => dom_update
  map_update_as_union => update_def_union
  map_indom_update_already_inv => indom_update_already_inv

  reduce_ => fold_

*)

(* --LATER: is this deprecated?
  Lemma binds_update_rem : forall A i j `{Inhab B} v w (M:map A B),
    j \notindom' M -> binds (M[j:=w]) i v -> binds M i v.
  Hint Resolve binds_update_rem.
*)

Lemma binds_update_indom_eq :
  forall A B (M : map A B) a1 a2 b1 b2,
  binds (M[a1:=b1]) a2 b2 =
  (    (a2 <> a1 /\ binds M a2 b2)
    \/ (a2 = a1 /\ b2 = b1)).
Proof using.
  split. introv [ [ ? ? ] | [ ? ? ] ].
  { eauto using binds_update_neq. }
  { subst. eapply binds_update_eq. }
  { eauto using binds_update_analysis. }
Qed.

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

(* --LATER: cleanup the three lemmas below *)

(* FALSE
Lemma binds_update_neq_inv' : forall A B i j v w (M:map A B),
  binds (M[j:=w]) i v -> j \notindom M -> binds M i v.

Lemma binds_update_neq_eq : forall A `{Inhab B} i j v w (M:map A B),
  j \notindom M ->
  (binds M i v = binds (M[j:=w]) i v).
Proof using.
  split; intros.
  { eapply binds_update_neq; [ | eauto ].
    assert (i \indom M). { eapply index_of_binds; eauto. }
    intro. subst. unfold notin in *. tauto. }
  { eauto using binds_update_neq_inv'. }
Qed.

*)

Lemma binds_update_neq' : forall A i j `{Inhab B} v w (M:map A B), (* --TODO: needed? *)
  i <> j ->
  binds M i v ->
  binds (M[j:=w]) i v.
Proof using. intros. applys* binds_update_neq. Qed.

(* --TODO: deprecated? *)
Lemma dom_update_at_index' :
  forall A `{Inhab B} (M M' : map A B) (D : set A) x v,
  M' = M[x:=v] ->
  D = dom M ->
  x \in D ->
  D = dom M'.
Proof using. intros. subst. rewrite~ dom_update_at_index. Qed.

(* Hint Resolve index_of_indom. *)

(*-- TODO: this statement is temporary; we probably shouldn't use [Proper]. *)
Lemma fold_pointwise :
  forall B (m : monoid_op B) (leB : B -> B -> Prop),
  Monoid m ->
  refl leB ->
  Proper (leB ++> leB ++> leB) (monoid_oper m) ->
  forall A (E : set A),
  finite E ->
  forall (f f' : A -> B),
  (forall x, x \in E -> leB (f x) (f' x)) ->
  leB (fold m f E) (fold m f' E).
Proof using.
  intros. do 2 rewrite fold_eq_fold_to_list.
  applys~ LibList.fold_pointwise.
  intros x. forwards~ (_&EQ): finite_list_repr E. rewrite (EQ x). auto.
Qed.

Lemma foreach_remove_of_foreach_pred_incl : forall P Q E F,
  foreach P E ->
  pred_incl P (fun (x:A) => x \notin F -> Q x) ->
  foreach Q (E \- F).
Proof using. introv M H Px. rewrite in_remove_eq in Px. applys* H. Qed.

(* ---------------------------------------------------------------------- *)
(** [to_set] *)

Lemma list_repr_to_set:
  forall A (xs : list A),
  noduplicates xs ->
  list_repr (to_set xs) xs.
Proof using.
  unfold list_repr, to_set. induction 1; split.
  { econstructor. }
  { tauto. }
  { econstructor; eauto. }
  { tauto. }
Qed.

Lemma list_repr_to_set_inverse:
  forall A (E : set A) (xs : list A),
  list_repr E xs ->
  E = to_set xs.
Proof using.
  unfold list_repr, to_set. introv (_ & ?).
  generalize dependent E. generalize dependent xs.
  induction xs; introv H; rewrite set_ext_eq; intros x;
  rewrite in_set_st_eq; rewrite H; tauto.
Qed.

Lemma to_set_nil:
  forall A,
  to_set (@nil A) = \{}.
Proof using.
  intros.
  erewrite <- list_repr_to_set_inverse by eapply list_repr_nil.
  eauto.
Qed.

(* -- TODO, fix using Prefix library

Lemma prefix_to_set:
  forall A (xs ys : list A),
  prefix xs ys ->
  to_set xs \c to_set ys.
Proof using.
  unfold to_set. introv (zs&?). subst.
  rewrite set_incl_in_eq. intros. rewrite in_set_st_eq in *.
  rewrite Mem_app_or_eq. tauto.
Qed.

*)

(************************************************************)
(************************************************************)
(************************************************************)
(* LibListZ *)

(* ********************************************************************** *)
(** * DEPRECATED -- List predicates using indices in Z *)

Section ZindicesOld.
Variables A : Type.
Implicit Types x : A.
Implicit Types l : list A.
Implicit Types i : int.
Ltac auto_tilde ::= eauto with maths.

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

(** Predicates *)

Definition ZInbound i l :=
  0 <= i /\ i < length l.

Definition ZNth i l x :=
  Nth (abs i) l x /\ 0 <= i.

Definition ZUpdate i x l l' :=
  Update (abs i) x l l' /\ 0 <= i.

(* ---------------------------------------------------------------------- *)
(** * DEPRECATED -- Znth *)

Lemma ZNth_here : forall i x l,
  i = 0 -> ZNth i (x::l) x.
Proof using. intros. subst. split~. constructor. Qed.

Lemma ZNth_zero : forall x l,
  ZNth 0 (x::l) x.
Proof using. intros. apply~ ZNth_here. Qed.

Lemma ZNth_next : forall i j x y l,
  ZNth j l x -> i = j+1 -> ZNth i (y::l) x.
Proof using.
  introv [H P] M. subst. split~.
  applys_eq* Nth_next 3. rew_abs_pos~.
Qed.

Lemma ZNth_app_l : forall i x l1 l2,
  ZNth i l1 x -> ZNth i (l1 ++ l2) x.
Proof using. introv [H P]. split~. apply~ Nth_app_l. Qed.

Lemma ZNth_app_r : forall i j x l1 l2,
  ZNth j l2 x -> i = j + length l1 -> ZNth i (l1 ++ l2) x.
Proof using.
  introv [H P]. unfold length. split~. subst.
  apply* Nth_app_r. rew_abs_pos~.
Qed.

Lemma ZNth_nil_inv : forall i x,
  ZNth i nil x -> False.
Proof using. introv [H P]. apply* Nth_nil_inv. Qed.

Lemma ZNth_cons_inv : forall i x l,
  ZNth i l x ->
     (exists q, l = x::q /\ i = 0)
  \/ (exists y q j, l = y::q /\ ZNth j q x /\ i = j+1).
Proof using.
  introv [H P]. forwards~: (@abs_pos i).
  destruct (Nth_cons_inv H); unpack.
  left. exists___. split~.
  right. exists___. splits~.
   split. rewrite* abs_pos_nat. math.
   math.
Qed.

Lemma ZNth_inbound : forall i l,
   ZInbound i l -> exists x, ZNth i l x.
Proof using.
  introv [P U]. unfolds length. gen_eq n: (abs i).
  gen i l. induction n; intros;
    forwards~: (@abs_pos i); destruct l; rew_length in U; try math.
  math_rewrite (i = 0). exists __. split~. constructor.
  forwards~ [x [M P']]: (>> IHn (i-1) l).
    forwards~: (@abs_to_succ_abs_minus_one i).
    exists x. split~. rewrite~ (@abs_to_succ_abs_minus_one i). constructor~.
Qed.

(* ---------------------------------------------------------------------- *)
(** * DEPRECATED -- ZInbound *)

Lemma ZInbound_zero : forall x l,
  ZInbound 0 (x::l).
Proof using. split; unfold length; rew_list~. Qed.

Lemma ZInbound_zero_not_nil : forall x l,
  l <> nil -> ZInbound 0 l.
Proof using.
  intros. split~. unfold length.
  destruct l; tryfalse. rew_list~.
Qed.

Lemma ZInbound_cons : forall i j x l,
  ZInbound j l -> j = i-1 -> ZInbound i (x::l).
Proof using. introv [P U] H. split; rew_list~. Qed.

Lemma ZInbound_nil_inv : forall i,
  ZInbound i nil -> False.
Proof using. introv [P U]. rew_list in U. math. Qed.

Lemma ZInbound_cons_inv : forall i x l,
  ZInbound i (x::l) -> i = 0 \/ (i <> 0 /\ ZInbound (i-1) l).
Proof using.
  introv [P U]. rew_length in U. tests: (i = 0).
    left~.
    right~. split. math. split~.
Qed.

Lemma ZInbound_cons_pos_inv : forall i x l,
  ZInbound i (x::l) -> i <> 0 -> ZInbound (i-1) l.
Proof using.
  introv H P. destruct* (ZInbound_cons_inv H).
Qed.

Lemma ZInbound_one_pos_inv : forall i x,
  ZInbound i (x::nil) -> i <> 0 -> False.
Proof using.
  intros. eapply ZInbound_nil_inv. apply* ZInbound_cons_pos_inv.
Qed.

Lemma ZInbound_app_l_inv : forall i l1 l2,
  ZInbound i (l1++l2) -> i < length l1 -> ZInbound i l1.
Proof using. introv [P U] H. split~. Qed.

Lemma ZInbound_app_r_inv : forall i j l1 l2,
  ZInbound j (l1++l2) -> j = length l1 + i -> i >= 0 -> ZInbound i l2.
Proof using. introv [P U] R H. rew_length in U. split~. Qed.

(* ---------------------------------------------------------------------- *)
(** * DEPRECATED -- ZUpdate *)

Lemma ZUpdate_here : forall x y l,
  ZUpdate 0 x (y::l) (x::l).
Proof using. split~. apply Update_here. Qed.

Lemma ZUpdate_cons : forall i j x y l l',
  ZUpdate j x l l' -> i = j+1 -> ZUpdate i x (y::l) (y::l').
Proof using.
  introv [U P] H. split~. applys_eq~ Update_cons 4.
  subst. rew_abs_pos~.
Qed.

Lemma ZUpdate_app_l : forall i x l1 l1' l2,
  ZUpdate i x l1 l1' -> ZUpdate i x (l1++l2) (l1'++l2).
Proof using. introv [U P]. split~. apply~ Update_app_l. Qed.

Lemma ZUpdate_app_r : forall i j x l1 l2 l2',
  ZUpdate j x l2 l2' -> i = j + length l1 -> ZUpdate i x (l1++l2) (l1++l2').
Proof using.
  introv [U P] H. unfolds length. split~. apply~ Update_app_r.
  subst. rew_abs_pos~.
Qed.

Lemma ZUpdate_not_nil : forall i x l1 l2,
  ZUpdate i x l1 l2 -> l2 <> nil.
Proof using. introv [U P]. apply~ Update_not_nil. Qed.

Lemma ZUpdate_length : forall i x l l',
  ZUpdate i x l l' -> length l = length l'.
Proof using.
  introv [U P]. unfolds length.
  forwards~: Update_length.
Qed.

End ZindicesOld.

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

(* UNDER CONSTRUCTION *)

(* --TODO: complete definitions and proofs, which are used by CFML/Dijstra *)

From TLC Require Import LibWf.

(* --TODO: implement a non-decidable version of count *)

Axiom count : (* UNDER CONSTRUCTION *)
  forall A (P:A->Prop) (l:list A), int.

(* currently not used
  Axiom count_make : forall A (f:A->Prop) n v,
    count f (make n v) = (If f v then n else 0).
*)

Axiom count_update : (* UNDER CONSTRUCTION *)
  forall `{Inhab A} (P:A->Prop) (l:list A) (i:int) v,
  index l i ->
  count P (l[i:=v]) = count P l
    - (If P (l[i]) then 1 else 0)
    + (If P v then 1 else 0).

Axiom count_bounds : (* UNDER CONSTRUCTION *)
  forall `{Inhab A} (l:list A) (P:A->Prop),
  0 <= count P l <= length l.

(** The following lemma is used to argue that the update to a sequence,
    when writing a value that satisfies [P] in place of one that did not
    satisfy [P], decreases the total number of values that satisfying
    [P] in the sequence. *)

Lemma count_upto : forall `{Inhab A} (P:A->Prop) (l:list A) (n i:int) (v:A),
  ~ P (l[i]) -> P v -> index l i -> (length l <= n)%Z ->
  upto n (count P (l[i:=v])) (count P l).
Proof using.
  introv Ni Pv Hi Le. forwards K: (count_bounds (l[i:=v]) P). split.
  rewrite length_update in K. math.
  lets M: (@count_update A _). rewrite~ M. clear M.
  do 2 (case_if; tryfalse). math.
Qed.

(* -------------------------------------------------------------------------- *)
(* --TODO: define a version of take that directly takes an int *)

Module TakeInt. (* --TODO: move to LibListZ *)
Import LibInt.
Section Facts.
Variables (A:Type).
Implicit Types x : A.
Implicit Types l : list A.

Lemma take_cons_pred_int : forall x l (n:int),
  n > 0 ->
  take (abs n) (x::l) = x :: (take (abs (n-1)) l).
Proof using. (* using stdlib *)
  introv Pos. rewrite take_cons_pred.
  rewrite abs_minus; try math. auto.
  forwards: lt_abs_abs 0 n; math.
Qed.

Lemma take_cons_int : forall x l (n:int),
  n >= 0 ->
  take (abs (n+1)) (x::l) = x :: (take (abs n) l).
Proof using.
  introv Pos. rewrite~ abs_plus.
  rewrite~ plus_comm. math.
Qed.

End Facts.
End TakeInt.
Export TakeInt.

(************************************************************)
(************************************************************)
(************************************************************)

*)


(* http://gallium.inria.fr/~scherer/gagallium/coq-eval/index.html *)

Definition nat_eq (x y: nat) : {x=y} + {x<>y}.
Proof.
decide equality.
Qed.
Compute (nat_eq 2 2).

Definition nat_eq2 (x y: nat) : {x=y} + {x<>y}.
Proof.
decide equality.
Defined.
Compute (nat_eq2 2 2).

(*vm_compute
native_compute *)

Require Import Coq.Program.Tactics.
Require Import Coq.ZArith.ZArith.
(*Require Export Coq.ZArith.Zcompare.
Require Export Coq.ZArith.Znat.*)

Require Import Coq.QArith.QArith.
Definition a := Z.of_nat 2 # Pos.of_nat 3.
Check Z.le.

Open Scope Z_scope. (* good *)
Definition t := { n : Z | n > 1 }.

Program Definition two : t := 2.
Next Obligation.
omega.
Show Proof.
Qed.

Program Definition succ (n: t) : t := n + 1.
Next Obligation. destruct n; simpl; omega. Qed.

(*!*)
Goal (1 # 1 <> 2 # 2).
congruence.
Show Proof.
Qed.