(** * 6.822 Formal Reasoning About Programs, Spring 2020 - Pset 6 *)

(* In this pset, you will use abstract-interpretation results to enable
 * optimizations in programs:
 * (1) Develop and verify an analysis that just tracks known constant values
 *     for variables.
 * (2) Write and verify an optimization that replaces variables with their known
 *     constant values, which is trickier than it sounds, because variables may
 *     equal different constants at different points in the code!
 * (3) Use all of the above to prove that a particular run of the optimization
 *     generates an optimized program with the same behavior as the original
 *     program. *)

(* Authors: Adam Chlipala (adamc@csail.mit.edu), Peng Wang
* (wangpeng@csail.mit.edu), Andres Erbsen (andreser@mit.edu) *)

Require Import Frap AbstractInterpret Pset6Sig.
(* Note that module [AbstractInterpret] here duplicates the framework
 * definitions from AbstractInterpretation.v, the file with example code from
 * the last lecture. *)

(** * An abstract interpretation tracking equality to constants *)

(* copy-pasted from Sig file:
Inductive domain :=
| Exactly (n : nat)
| Anything.
*)

Definition represents (x:nat) (d:domain) : Prop :=
  match d with
  | Exactly n => x = n
  | Anything => True
  end.

Definition absint_binop (f : nat -> nat -> nat) (a b : domain) : domain :=
  match a, b with
  | Exactly n, Exactly m => Exactly (f n m)
  | _, _ => Anything
  end.

Definition join (a b : domain) : domain :=
  match a, b with
  | Exactly n, Exactly m => if n ==n m then Exactly n else Anything
  | _, _ => Anything
  end.

Definition constant_absint := {|
  Top := Anything;
  Constant := Exactly;
  Add := absint_binop Nat.add;
  Subtract := absint_binop Nat.sub;
  Multiply := absint_binop Nat.mul;
  Join := join;
  Represents := represents
|}.

(* copy-pasted from frap/AbstractInterpret.v:
Definition astate (a : absint) := fmap var a.
Definition compatible a (s : astate a) (v : valuation) : Prop :=
  forall x xa, s $? x = Some xa
               -> exists n, v $? x = Some n
                            /\ a.(Represents) n xa. *)

(* Depending on how you approach [constant_sound], this
 * lemma may or may not be useful. Regardless, it is used in our proof of
 * [optimize_program_ok] below. *)
(* from frap/AbstractInterpret.v:
Definition subsumed a (s1 s2 : astate a) :=
  forall x, match s1 $? x with
            | None => s2 $? x = None
            | Some xa1 =>
              forall xa2, s2 $? x = Some xa2
                          -> forall n, a.(Represents) n xa1
                                       -> a.(Represents) n xa2
            end.
*)
Lemma compatible_subsumed : forall a (s1 s2 : astate a) v,
  compatible s1 v -> subsumed s1 s2  -> compatible s2 v.
Proof.
  unfold compatible, subsumed; simplify.
  specialize H0 with (x:=x). cases (s1 $? x).
  apply H in Heq; first_order. equality.
Qed.
Hint Resolve compatible_subsumed : core.

Lemma constant_sound : absint_sound constant_absint.
Proof.
  split.

  (* You'll need to prove this one. *)

  all: simplify.

  (* As a convenience, here are some examples of how to
   * combine tactics using repeat-match-progress. These are not particularly
   * useful for this goal, just a reference for proof-scripting syntax. *)

  all:
    repeat match goal with
    | x : bool |- _
        => progress (cases x)
    | H : Some _ = Some _ |- _
        => progress (invert H)
    | |- Some _ = Some _ =>
        progress (apply f_equal)
    | H : ?x = ?x + 1 |- _
        => solve [linear_arithmetic]
    | H : forall b, b = true -> _ |- _
        => specialize (H true)
    | _ => progress (simplify)
    end.

Admitted.

(** * Optimizing programs based on that analysis *)

(* Our expression evaluator returns one of two outputs, for a particular input
 * expression: *)
(* copy-pasted from sig file:
Inductive constfold_result :=
| Known (n : nat)        (* The variable is exactly [n]. *)
| Simplified (e : arith) (* I don't know the exact value, but it's the same as this
                          * (potentially simplified) expression [e]. *).
*)

(* It's easy to convert a result back into a normal expression. *)
Definition to_arith (r : constfold_result) : arith :=
  match r with
  | Known n => Const n
  | Simplified e => e
  end.

(* The optimizer for expressions is straightforward though a bit fiddly. *)
Fixpoint constfold_arith (e : arith) (s : astate constant_absint) : constfold_result :=
  match e with
  | Const n => Known n
  | Var x =>
    match s $? x with
    | Some (Exactly n) => Known n
    | _ => Simplified e
    end
  | Plus e1 e2 =>
    match constfold_arith e1 s, constfold_arith e2 s with
    | Known n1, Known n2 => Known (n1 + n2)
    | e1', e2' => Simplified (Plus (to_arith e1') (to_arith e2'))
    end
  | Times e1 e2 =>
    match constfold_arith e1 s, constfold_arith e2 s with
    | Known n1, Known n2 => Known (n1 * n2)
    | e1', e2' => Simplified (Times (to_arith e1') (to_arith e2'))
    end
  | Minus e1 e2 =>
    match constfold_arith e1 s, constfold_arith e2 s with
    | Known n1, Known n2 => Known (n1 - n2)
    | e1', e2' => Simplified (Minus (to_arith e1') (to_arith e2'))
    end
  end.

(* Now we get to the optimizer for commands, which is about as much code, but
 * which is significantly more intricate.  As with [absint_step], we pass a
 * parameter [C], standing for *the context in which this command will be
 * run.*  We also pass [ss], a map from commands to what we know about
 * variables, right before running the corresponding command.  That information
 * is enough for us to replace variable occurrences with their known constant
 * values. *)
Fixpoint constfold_cmd (c : cmd) (ss : astates constant_absint) (C : cmd -> cmd) : cmd :=
  match c with
  | Skip => Skip
  | Assign x e =>
    (* Note how here we query the abstract state [ss] with the current command
     * [c] wrapped in [C].  In other words, we are querying the analysis
     * result, asking "when we reach this command, what is known to be true
     * about the variable values?". *)
    match ss $? C c with
    | None => Assign x e
    | Some s => Assign x (to_arith (constfold_arith e s))
                (* What do we do with what we learn?  If there are variable
                 * values associated with this location in the program, we use
                 * them to optimize the expression being assigned. *)
    end
  | Sequence c1 c2 => Sequence (constfold_cmd c1 ss (fun c' => C (Sequence c' c2)))
                               (constfold_cmd c2 ss C)
  | If e then_ else_ =>
    If e (constfold_cmd then_ ss C)
         (constfold_cmd else_ ss C)
  | While e body =>
    While e (constfold_cmd body ss (fun c' => C (Sequence c' c)))
  end.

Definition compatible_throughout_steps {A} ss v c:= forall c' s v',
  ss $? c' = Some s -> step^* (v, c) (v', c') -> @compatible A s v'.
(* This line makes [eauto] treat [compatible_throughout_steps] as inlined: *)
Hint Unfold compatible_throughout_steps : core.

(* Prove: any sequence of small steps can be replicated with the optimized command. *)
Lemma constfold_steps : forall v c v' c',
  step^* (v, c) (v', c') ->
  forall ss, compatible_throughout_steps ss v c ->
  step^* (v, constfold_cmd c ss (fun c1 => c1))
  (v', constfold_cmd c' ss (fun c1 => c1)).
Proof.
Admitted.

(* Prove: any full program execution can be replicated with the optimized program. *)
Lemma eval_constfold : forall v c v',
  eval v c v' ->
  forall ss, compatible_throughout_steps ss v c ->
  eval v (constfold_cmd c ss (fun c1 => c1)) v'.
Proof.
Admitted.

(* This lemma connects the previous to the [invariantFor] goal that FRAP abstract-interpretation machinery proves. *)
Lemma optimize_program_ok : forall v c v' ss,
  eval v c v'
  -> invariantFor (absint_trsys constant_absint c)
                  (fun p => exists s, ss $? snd p = Some s
                                      /\ subsumed (fst p) s)
  -> eval v (constfold_cmd c ss (fun c1 => c1)) v'.
Proof.
  simplify.
  apply eval_constfold; auto.
  eapply invariant_simulates with (sys1 := trsys_of v c) in H0;
    try (apply absint_simulates with (a := constant_absint); apply constant_sound).
  unfold compatible_throughout_steps.
  simplify.
  eapply use_invariant in H0; simplify; eauto.
  invert H0.
  invert H3.
  invert H4.
  invert H0.
  simplify.
  replace s with x in * by equality.
  eauto.
Qed.

(* Optional: Actually run your analysis to justify an automatic optimization.
 * You won't be graded on that part, but it's satisfying to run to wrap up the assignment! *)

Example loopsy :=
  "a" <- 7;;
  "b" <- 0;;
  while "n" loop
    "b" <- "b" + "a";;
    "n" <- "n" - 1
  done.

Example loopsy_optimized :=
  "a" <- 7;;
  "b" <- 0;;
  while "n" loop
    "b" <- "b" + 7;;
    "n" <- "n" - 1
  done.

(* Here are some hints we add, to get the iteration tactics to work properly. *)
Lemma merge_astates_fok_constant : forall x : option (astate constant_absint),
  match x with Some x' => Some x' | None => None end = x.
Proof.
  simplify; cases x; equality.
Qed.
Lemma merge_astates_fok2_constant : forall x (y : option (astate constant_absint)),
    match y with
    | Some y' => Some (merge_astate x y')
    | None => Some x
    end = None -> False.
Proof.
  simplify; cases y; equality.
Qed.
Hint Resolve merge_astates_fok_constant merge_astates_fok2_constant : core.

(* This part takes ~3GB of RAM and 10 minutes on the laptop we tested with. *)
(*
Lemma loopsy_optimized_properly : forall v v',
  eval v loopsy v'
  -> eval v loopsy_optimized v'.
Proof.
  simplify.
  assert (exists ss, invariantFor (absint_trsys constant_absint loopsy)
                                  (fun p => exists s, ss $? snd p = Some s
                                                      /\ subsumed (fst p) s)
                     /\ loopsy_optimized = constfold_cmd loopsy ss (fun c1 => c1)).

  eexists; propositional.

  apply interpret_sound.
  apply constant_sound.

  unfold loopsy.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret_done.

  simplify.
  equality.

  first_order.
  rewrite H1.
  apply optimize_program_ok.
  assumption.
  assumption.
Qed.
*)


(** * Tutoriel 4 - Extraction de programmes à partir de preuves *)

(** Dans ce tutoriel, nous allons extraire des programmes à partir de preuves
    simples sur les nombres naturels. *)

Require Extraction. (* Commentez cette ligne pour les anciennes
                       versions de Coq. *)

(** ** Exercice 1 - Relation d'Ackermann *)

(** Nous définissons une relation [ack : nat -> nat -> nat -> Prop] qui est
    la spécification de la fonction d'Ackermann : [ack m n r] signifie que
    le résultat de la fonction sur [m] et [n] doit être [r]. *)

Inductive ack : nat -> nat -> nat -> Prop :=
  | ack_0_n : forall n, ack O n (S n)
  | ack_m_0 : forall m r, ack m (S O) r -> ack (S m) O r
  | ack_m_n : forall m n r r',
      ack (S m) n r -> ack m r r' -> ack (S m) (S n) r'.

(** Prouvons que la relation est totale.
    Faites attention à bien commencer votre preuve, ce n'est pas simple ! *)

Lemma ack_total : forall m n, exists r, ack m n r.
Proof.
  (** Dans cette preuve, vous pouvez trouver utile de choisir des noms lors de
      la destruction d'une existentielle, en utilisant [destruct ... as (x,H)].

      Vous pouvez aussi utiliser [assumption] au lieu d'utiliser explicitement
      [exact H] lorsque la conclusion du but est l'une de ses hypothèses. *)
  induction m.
  + intro n. exists (S n). apply (ack_0_n n).
  + induction n.
    ++ (* pose proof (IHm 1) as toto. *)
assert (exists r1, ack m 1 r1) by (apply (IHm 1)). destruct H as [r1]. exists r1. apply ack_m_0. exact H.
    ++ destruct IHn as [rn]. pose proof (IHm rn). destruct H0 as [rn']. exists rn'. apply (ack_m_n m n rn rn' H H0).
Qed.
(** Demandez à Coq d'extraire un programme de la preuve [ack_total].
    Le résultat est décevant : c'est parce que le contenu calculatoire des
    objets de [Prop] est effacé. *)

Extraction ack_total.

(** L'expression [exists x:A, P x] est une notation pour [ex A P].
    Le type [ex] est défini de manière inductive : ses habitants
    (c'est-à-dire les preuves des énoncés existentiels) ne peuvent
    être dérivés qu'à l'aide de [ex_intro], c'est-à-dire en
    fournissant un témoin [x] et une preuve de [P x]. *)

Print ex.

(** Coq vient avec une variante de [ex] appelée [sig] qui définit
    la quantification existentielle sur [Type] plutôt que sur [Prop].
    L'expression [{x : A | P x}] est une notation pour [sig A P]. *)

Check { r : nat | ack 2 3 r }.
Print sig.

(** Prouvons la totalité en utilisant [sig]. *)

Lemma ack_total_sig : forall m n, { r | ack m n r }.
Proof.
  (** Les éléments suivants ne seront pas autorisés :

      intros. destruct (ack_total m n).

      En effet, nous ne pouvons pas utiliser [ack_total], qui n'a pas de
      sens du point de vue du calcul, pour définir [ack_total_sig].

      Cependant, copier le script de preuve de [ack_total] devrait fonctionner.
      En particulier, [destruct] fonctionne de manière similaire sur [ex] et
      sur [sig].

      À la fin, utilisez [Defined] plutôt que [Qed] pour éviter les
      avertissements : ceci informe Coq que nous nous intéressons au contenu
      de la preuve, et pas seulement au fait que l'énoncé est prouvable. *)
  induction m.
  + intro n. exists (S n). apply (ack_0_n n).
  + induction n.
    ++ pose proof (IHm 1). destruct H as [r1]. exists r1. apply ack_m_0. exact a.
    ++ destruct IHn as [rn]. pose proof (IHm rn). destruct H as [rn']. exists rn'. apply (ack_m_n m n rn rn' a a0).
Qed.

(** Nous pouvons maintenant extraire quelque chose d'intéressant de la preuve
    de la totalité. *)

Extraction ack_total_sig.

(** ** Exercice 2 - Fonction d'Ackermann *)

(** Nous allons extraire la fonction d'Ackermann à partir d'une preuve de la
    totalité de la relation d'Ackermann. Il est également possible (et souvent
    pratique) de définir la fonction explicitement dans Coq.

    La fonction sera essentiellement définie par induction sur les nombres
    naturels. Concrètement, nous formerons une définition [Fixpoint] : elle
    permet de définir une fonction récursive tant qu'un argument décroît
    strictement dans ces appels, de sorte que la terminaison est assurée.
    Ici, "décroissant" signifie que le nouvel argument doit être un
    sous-terme strict de l'argument (fini) initial.

    Par exemple, dans la (re)définition suivante de la fonction d'addition,
    l'argument décroissant est le premier : le seul appel récursif est un
    un sous-terme strict [m'] de [m]. *)

Fixpoint addition (m:nat) (n:nat) : nat :=
   match m with
    | O => n
    | S m' => S (addition m' n)
  end.

(** Définissons d'abord [fack'] de telle sorte que, si [fack_m] est la fonction
    d'Ackermann avec un premier argument fixé à [m], alors [fack' fack_m n] est
    le résultat de la fonction d'Ackermann pour [S m] et [n]. *)

Fixpoint fack' (fack_m : nat -> nat) (n:nat) : nat := match n with
  | O => fack_m 1
  | S n' => fack_m (fack' fack_m n')
end.

(** Définissez maintenant [fack] comme étant la fonction d'Ackermann. *)

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

(** Prouvez que [fack] implémente la spécification d'Ackermann. *)

Lemma fack_correct : forall m n, ack m n (fack m n).
Proof.
Admitted.

(** On obtient ainsi une nouvelle preuve de la totalité. *)

Lemma ack_total_fun : forall m n, { r | ack m n r }.
Proof.
  intros m n. exists (fack m n). apply fack_correct.
Defined.

Recursive Extraction ack_total_fun.

(** Calculons quelques valeurs de la fonction. *)

Lemma ack_3_3 : { x : nat | ack 3 3 x }.
Proof.
  apply ack_total_fun.
Defined.

(** L'extraction nous donne un programme que nous pourrions exécuter
    en OCaml. *)

Recursive Extraction ack_3_3.

(** Mais puisque nous avons une fonction Coq, nous pouvons aussi
    l'évaluer directement. *)

Eval compute in fack 3 3.

(** Nous pouvons également dérouler ce résultat à partir du type [sig] de
    l'une de nos preuves d'existence. *)

Eval compute in ack_total_fun 3 3.
Eval compute in let (x,_) := ack_total_fun 3 3 in x.
Eval compute in let (x,_) := ack_total_sig 3 3 in x.

(** ** Exercice 3 - Induction sur une relation *)

(** Jusqu'à présent, nous n'avons pas utilisé le fait que [ack] est donné comme
    une définition [Inductive]. Nous l'utiliserons ensuite pour prouver
    l'unicité : parce que [ack] est inductive, vous avez un schéma
    d'induction pour elle, que vous pouvez utiliser à travers la tactique
    d'induction : si [H : ack m n r], essayez d'utiliser [induction H]. *)

Check ack_ind.

Lemma ack_unicity : forall m n r1,
  ack m n r1 -> forall r2, ack m n r2 -> r1 = r2.
Proof.
  (** N'utilisez PAS les inductions sur [m] et [n] : faites une induction sur
      [ack m n r] directement.
      Attention : le [forall r2] n'arrive pas tout de suite dans la formule
      pour une bonne raison. *)
Admitted.

(** Merci à David Baelde. *)


Require Import Lambda.Util.Basic.

(** * De Bruijn Syntax of Terms *)

Inductive expr : Set :=
| Var (n : nat)
| Lam (e : expr)
| App (e1 e2 : expr).
(**[]*)

Declare Scope expr_scope.
Delimit Scope expr_scope with expr.

Notation "'λ' e" := (Lam e) (at level 10) : expr_scope.
Notation "e1 ⋅ e2" := (App e1 e2) (at level 8, left associativity) : expr_scope.
Notation "! n" := (Var n) (at level 0) : expr_scope.

Open Scope expr_scope.

(** Shifts free variables in [e] above a cutoff [c] up by [i]. *)
Fixpoint lift (c i : nat) (e : expr) : expr :=
  match e with
  | !n => ! match lt_dec n c with
           | left _ => n
           | right _ => n + i
           end
  | λ e => λ (lift (S c) i e)
  | e1 ⋅ e2 => (lift c i e1) ⋅ (lift c i e2)
  end.
(**[]*)

(** Substitution [e{esub/i}]. *)
Fixpoint subst (i : nat) (esub e : expr) : expr :=
  match e with
  | !n => match lt_eq_lt_dec i n with
         | inleft (left _) => ! (pred n)
         | inleft (right _) => lift 0 i esub
         | inright _ => !n
         end
  | λ e => λ (subst (S i) esub e)
  | e1 ⋅ e2 => (subst i esub e1) ⋅ (subst i esub e2)
  end.
(**[]*)

Section FrenchLemmas.
  (** The confluence proof reqiured
      evidence of some properties of
      shifting of de Bruijn indices.
      What these properties were was
      elusive to me, so I have looked
      to the work of a wise French person,
      who formalized the Calculus of Constructions in Coq.
      [http://www.lix.polytechnique.fr/~barras/CoqInCoq/Termes.html] *)

  Lemma lift0 : forall e k, lift k 0 e = e.
  Proof.
    induction e; intros; simpl;
      clean_compare; f_equal; auto 1.
  Qed.

  Lemma simpl_lift : forall e n p k i,
      i <= k + n -> k <= i ->
      lift i p (lift k n e) = lift k (p + n) e.
  Proof.
    induction e; intros; simpl;
      clean_compare; f_equal; auto 2; try lia.
    apply IHe; lia.
  Qed.

  Local Hint Extern 0 => rewrite simpl_lift by lia; reflexivity : core.

  Lemma permute_lift : forall e n k p i,
      i <= k -> lift i p (lift k n e) = lift (p + k) n (lift i p e).
  Proof.
    induction e; intros; simpl;
      clean_compare; f_equal; auto 2; try lia.
    rewrite IHe by lia. f_equal; lia.
  Qed.

  Local Hint Extern 0 => rewrite permute_lift by lia; reflexivity : core.

  Lemma simpl_subst : forall M N n p k,
      p <= n + k -> k <= p ->
      subst p N (lift k (S n) M) = lift k n M.
  Proof.
    induction M; intros; simpl;
      clean_compare; f_equal; auto 2; try lia.
    apply IHM; lia.
  Qed.

  Local Hint Extern 0 => rewrite simpl_subst by lia; reflexivity : core.

  Lemma commute_lift_subst : forall M N n p k,
      k <= p ->
      lift k n (subst p N M) = subst (n + p) N (lift k n M).
  Proof.
    induction M; intros; simpl;
      clean_compare;
      try (f_equal; auto 2; lia).
    f_equal; rewrite IHM by lia.
    f_equal; lia.
  Qed.

  Local Hint Extern 0 => rewrite commute_lift_subst by lia; reflexivity : core.

  Lemma distr_lift_subst : forall M N n p k,
      lift (p + k) n (subst p N M) = subst p (lift k n N) (lift (S (p + k)) n M).
  Proof.
    induction M; intros; simpl;
      clean_compare;
      try (f_equal; auto 2; lia).
    f_equal; rewrite <- IHM; f_equal; lia.
  Qed.

  Lemma distr_lift_subst0 : forall M N n k,
      lift k n (subst 0 N M) = subst 0 (lift k n N) (lift (S k) n M).
  Proof.
    intros. replace k with (0 + k) at 1 by lia.
    replace k with (0 + k) at 3 by lia.
    apply distr_lift_subst.
  Qed.

  Lemma distr_sub : forall M N P n p,
      subst (p + n) P (subst p N M) =
      subst p (subst n P N) (subst (S (p + n)) P M).
  Proof.
    induction M; intros; simpl;
      clean_compare; try (f_equal; auto 2; lia).
    f_equal; rewrite <- IHM; f_equal; lia.
  Qed.

  Lemma distr_sub0 : forall M N P n,
      subst n P (subst 0 N M) =
      subst 0 (subst n P N) (subst (S n) P M).
  Proof.
    intros. replace n with (0 + n) at 1 by lia.
    replace n with (0 + n) at 3 by lia.
    apply distr_sub.
  Qed.
End FrenchLemmas.

(** * Reduction Strategies *)

(** Non-determistic reduction. *)
Reserved Notation "e1 '-->' e2" (at level 40).

Inductive step : expr -> expr -> Prop :=
| step_beta e1 e2 :
    (λ e1) ⋅ e2 -->  subst 0 e2 e1
| step_lambda e e' :
    e -->  e' ->
    λ e -->  λ e'
| step_app_l e1 e1' e2 :
    e1 -->  e1' ->
    e1 ⋅ e2 -->  e1' ⋅ e2
| step_app_r e1 e2 e2' :
    e2 -->  e2' ->
    e1 ⋅ e2 -->  e1 ⋅ e2'
where "e1 '-->' e2" := (step e1 e2).
(**[]*)

Inductive is_lambda : expr -> Prop :=
| IsLambda e : is_lambda (λ e).
(**[]*)

Ltac not_is_lambda_lambda :=
  match goal with
  | H: ~ is_lambda (λ _)
    |- _ => exfalso; apply H; constructor
  end.
(**[]*)

(** No beta-reduxes. *)
Inductive normal_form : expr -> Prop :=
| nf_var n :
    normal_form !n
| nf_app e1 e2 :
    ~ is_lambda e1 ->
    normal_form e1 ->
    normal_form e2 ->
    normal_form (e1 ⋅ e2)
| nf_lam e :
    normal_form e ->
    normal_form (λ e).
(**[]*)

Section NormalForm.
  Local Hint Extern 0 => not_is_lambda_lambda : core.
  Hint Constructors is_lambda : core.

  Ltac contra_step :=
    match goal with
    | H: ?e -->  _, IH : (forall _, ~ ?e -->  _)
      |- _ => apply IH in H; contradiction
    end.

  Hint Extern 0 => contra_step : core.

  Theorem normal_form_step : forall e e',
    normal_form e -> ~ e -->  e'.
  Proof.
    intros e e' HN; generalize dependent e';
      induction HN; intros ? H'; inv H'; auto 2.
  Qed.
End NormalForm.

Notation "e1 '-->*' e2" := (refl_trans_closure step e1 e2) (at level 40).

Lemma why : forall (X : Type) (P : X -> Prop),
    (forall x, ~ P x) -> ~ exists x, P x.
Proof.
  intros X P HP [x H].
  apply HP in H. contradiction.
Qed.

Lemma why' : forall (X : Type) (P : X -> Prop),
    (~ exists x, P x) -> forall x, ~ P x.
Proof.
  intros X P H x HP. eauto.
Qed.

Section Confluence.
  Local Hint Constructors step : core.
  Local Hint Constructors refl_trans_closure : core.
  Local Hint Resolve inject_trans_closure : core.

  Lemma reduce_lambda : forall e e',
      e -->* e' -> λ e -->* λ e'.
  Proof. intros e e' H; induction H; eauto 3. Qed.

  Lemma reduce_app_l : forall e1 e1' e2,
      e1 -->* e1' -> e1 ⋅ e2 -->* e1' ⋅ e2.
  Proof. intros e1 e1' e2 H; induction H; eauto 3. Qed.

  Lemma reduce_app_r : forall e1 e2 e2',
      e2 -->* e2' -> e1 ⋅ e2 -->* e1 ⋅ e2'.
  Proof. intros e1 e2 e2' H; induction H; eauto 3. Qed.

  Local Hint Resolve reduce_lambda : core.
  Local Hint Resolve reduce_app_l : core.
  Local Hint Resolve reduce_app_r : core.

  Lemma reduce_app : forall e1 e1' e2 e2',
      e1 -->* e1' -> e2 -->* e2' -> e1 ⋅ e2 -->* e1' ⋅ e2'.
  Proof.
    intros ? ? ? ? H1 H2; inv H1; inv H2; eauto 3.
    transitivity (e1' ⋅ e2); eauto 3.
  Qed.

  Local Hint Resolve reduce_app : core.

  Lemma sub_right_step : forall er er' el c,
      er -->  er' -> subst c el er -->  subst c el er'.
  Proof.
    intros ? ? el c Her;
      generalize dependent c;
      generalize dependent el;
      induction Her; intros; simpl; auto 2.
    rewrite distr_sub0; auto 1.
  Qed.

  Lemma lift_step : forall e e' c i,
      e -->  e' -> lift c i e -->  lift c i e'.
  Proof.
    intros ? ? c i He;
      generalize dependent i;
      generalize dependent c;
      induction He; intros; simpl; clean_compare.
    rewrite distr_lift_subst0; auto 1.
  Qed.

  Local Hint Resolve lift_step : core.

  Lemma sub_left_step : forall er el el' c,
      el -->  el' -> subst c el er -->* subst c el' er.
  Proof. induction er; intros; simpl; clean_compare. Qed.

  Local Hint Resolve sub_right_step : core.
  Local Hint Resolve sub_left_step : core.

  Theorem confluence : forall e e1 e2,
      e -->  e1 -> e -->  e2 -> exists e', e1 -->* e' /\ e2 -->* e'.
  Proof.
    intros ? ? e2 H1;
      generalize dependent e2;
      induction H1; intros ? H2; inv H2; eauto 7.
    - inv H3; eauto 6.
    - pose proof IHstep _ H0 as [? [? ?]]; eauto 5.
    - inversion H1; subst.
      pose proof IHstep _ H1 as [? [? ?]];
        clear IHstep; eauto 6.
    - pose proof IHstep _ H4 as [? [? ?]]; eauto 5.
    - pose proof IHstep _ H4 as [? [? ?]]; eauto 5.
  Qed.
End Confluence.

(** Deterministic reduction. *)

Inductive shallow_value : expr -> Prop :=
| shl_var n : shallow_value !n
| shl_lam e : shallow_value (λ e).
(**[]*)

Inductive deep_value : expr -> Prop :=
| dp_var n :
    deep_value !n
| dp_lam e :
    deep_value e ->
    deep_value (λ e)
| dp_app e1 e2 :
    ~ is_lambda e1 ->
    deep_value e1 ->
    deep_value e2 ->
    deep_value (e1 ⋅ e2).
(**[]*)

(** Call-by-value. *)

Reserved Notation "e1 '⟶' e2" (at level 40).

Inductive cbv_reduce : expr -> expr -> Prop :=
| cbv_beta e1 e2 :
    shallow_value e2 ->
    (λ e1) ⋅ e2 ⟶  subst 0 e2 e1
| cbv_app_r e1 e2 e2' :
    shallow_value e1 ->
    e2 ⟶  e2' ->
    e1 ⋅ e2 ⟶  e1 ⋅ e2'
| cbv_app_l e1 e1' e2 :
    e1 ⟶  e1' ->
    e1 ⋅ e2 ⟶   e1' ⋅ e2
where "e1 '⟶' e2" := (cbv_reduce e1 e2).

(** Call-by-name. *)

Reserved Notation "e1 '==>' e2" (at level 40).

Inductive cbn_reduce : expr -> expr -> Prop :=
| cbn_beta e1 e2 :
    (λ e1) ⋅ e2 ==>  subst 0 e2 e1
| cbn_app_l e1 e1' e2 :
    e1 ==>  e1' ->
    e1 ⋅ e2 ==>  e1' ⋅ e2
where "e1 '==>' e2" := (cbn_reduce e1 e2).

(** Normal-order. *)

Reserved Notation "e1 '>->' e2" (at level 40).

Inductive normal_reduce : expr -> expr -> Prop :=
| normal_beta e1 e2 :
    (λ e1) ⋅ e2 >-> subst 0 e2 e1
| normal_lambda e e' :
    e >-> e' ->
    λ e >-> λ e'
| normal_app_r e1 e2 e2' :
    ~ is_lambda e1 ->
    normal_form e1 ->
    e2 >-> e2' ->
    e1 ⋅ e2 >-> e1 ⋅ e2'
| normal_app_l e1 e1' e2 :
    ~ is_lambda e1 ->
    e1 >-> e1' ->
    e1 ⋅ e2 >-> e1' ⋅ e2
where "e1 '>->' e2" := (normal_reduce e1 e2).

(** Applicative-order. *)

Reserved Notation "e1 '⇢' e2" (at level 40).

Inductive appl_reduce : expr -> expr -> Prop :=
| appl_beta e1 e2 :
    deep_value e1 ->
    deep_value e2 ->
    (λ e1) ⋅ e2 ⇢ subst 0 e2 e1
| appl_lambda e e' :
    e ⇢ e' ->
    λ e ⇢ λ e'
| appl_app_r e1 e2 e2' :
    deep_value e1 ->
    e2 ⇢ e2' ->
    e1 ⋅ e2 ⇢ e1 ⋅ e2'
| appl_app_l e1 e1' e2 :
    e1 ⇢ e1' ->
    e1 ⋅ e2 ⇢ e1' ⋅ e2
where "e1 '⇢' e2" := (appl_reduce e1 e2).
(**[]*)

Ltac cbv_step_lambda :=
  match goal with
  | H: λ _ ⟶  _ |- _ => inv H
  end.
(**[]*)

Ltac cbn_step_lambda :=
  match goal with
  | H: λ _ ==>   _ |- _ => inv H
  end.
(**[]*)

Ltac normal_step_app_var :=
  match goal with
  | H: !_ >-> _ |- _ => inv H
  end.
(**[]*)

Section Shallow.
  Local Hint Constructors shallow_value : core.

  Lemma cbv_reduce_value : forall e e',
      e ⟶   e' -> ~ shallow_value e.
  Proof. intros ? ? H Hv; inv H; inv Hv. Qed.

  Lemma cbn_reduce_value : forall e e',
      e ==>  e' -> ~ shallow_value e.
  Proof. intros ? ? H Hv; inv H; inv Hv. Qed.
End Shallow.

Section Deep.
  Local Hint Constructors deep_value : core.
  Local Hint Extern 0 => not_is_lambda_lambda : core.

  Lemma appl_reduce_value : forall e e',
      e ⇢ e' -> ~ deep_value e.
  Proof.
    intros ? ? H Hv; induction H; inv Hv; auto 2.
  Qed.

  Lemma normal_reduce_value : forall e e',
      e >-> e' -> ~ deep_value e.
  Proof.
    intros ? ? H Hv; induction H; inv Hv; auto 2.
  Qed.
End Deep.

Section NormalFormReduce.
  Local Hint Constructors normal_form : core.
  Local Hint Extern 0 => not_is_lambda_lambda : core.

  Lemma normal_form_reduce : forall e e',
      e >-> e' -> ~ normal_form e.
  Proof.
    intros ? ? He Hnf; induction He; inv Hnf; auto 2.
  Qed.
End NormalFormReduce.

Ltac contra_cbv_value :=
  match goal with
  | H: ?e ⟶  _, Hv: shallow_value ?e
    |- _ => apply cbv_reduce_value in H; contradiction
  end.
(**[]*)

Ltac contra_appl_value :=
  match goal with
  | H: ?e ⇢ _, Hv: deep_value ?e
    |- _ => apply appl_reduce_value in H; contradiction
  end.
(**[]*)

Ltac contra_cbn_value :=
  match goal with
  | H: ?e ==>  _, Hv: shallow_value ?e
    |- _ => apply cbn_reduce_value in H; contradiction
  end.
(**[]*)

Ltac contra_normal_value :=
  match goal with
  | H: ?e >-> _, Hv: normal_form ?e
    |- _ => apply normal_form_reduce in H; contradiction
  end.
(**[]*)

Section Determinism.
  Section CBV.
    Local Hint Extern 0 => contra_cbv_value : core.
    Local Hint Extern 0 => cbv_step_lambda : core.

    Theorem cbv_deterministic : deterministic cbv_reduce.
    Proof. ind_det; f_equal; eauto 2. Qed.
  End CBV.

  Section CBN.
    Local Hint Extern 0 => cbn_step_lambda : core.

    Theorem cbn_deterministic : deterministic cbn_reduce.
    Proof. ind_det; f_equal; eauto 2. Qed.
  End CBN.

  Local Hint Extern 0 => not_is_lambda_lambda : core.

  Section NORMAL.
    Local Hint Extern 0 => normal_step_app_var : core.
    Local Hint Extern 0 => contra_normal_value : core.

    Theorem normal_deterministic : deterministic normal_reduce.
    Proof. ind_det; f_equal; eauto 2. Qed.
  End NORMAL.

  Section APPL.
    Local Hint Extern 0 => contra_appl_value : core.

    Local Hint Extern 1 =>
    match goal with
    | H: λ ?e ⇢ _, Hv: deep_value ?e
      |- _ => inv H
    end : core.

    Theorem appl_deterministic : deterministic appl_reduce.
    Proof. ind_det; f_equal; eauto 2. Qed.
  End APPL.
End Determinism.

Section ValueEXM.
  Local Hint Constructors is_lambda : core.

  Lemma is_lambda_exm : forall e,
    is_lambda e \/ ~ is_lambda e.
  Proof. intros []; auto 2; right; intros H; inv H. Qed.

  Remove Hints is_lambda : core.
  Local Hint Constructors shallow_value : core.

  Lemma shallow_value_exm : forall e,
      shallow_value e \/ ~ shallow_value e.
  Proof. intros []; auto 2; right; intros H; inv H. Qed.

  Remove Hints shallow_value : core.
  Local Hint Constructors deep_value : core.
  (*Local Hint Resolve is_lambda_exm : core.*)

  Lemma deep_value_exm : forall e,
      deep_value e \/ ~ deep_value e.
  Proof.
    induction e as
        [ n
        | e [IHe | IHe]
        | e1 [IHe1 | IHe1] e2 [IHe2 | IHe2]]; auto 3;
    try match goal with
        | H: ~ deep_value ?e |- context [?e]
          => right; intros H'; inv H'; contradiction
        end.
    - destruct (is_lambda_exm e1) as [He1 | He1]; auto 3.
      right; intros H'; inv H'; contradiction.
  Qed.
End ValueEXM.

Section NFEXM.
  Local Hint Constructors normal_form : core.

  Lemma normal_form_exm : forall e, normal_form e \/ ~ normal_form e.
  Proof.
    intro e;
      induction e as [ n
                     | e [IHe | IHe]
                     | e1 [IHe1 | IHe1] e2 [IHe2 | IHe2]]; eauto;
        try (right; intros Hwrong; inv Hwrong; contradiction).
    destruct (is_lambda_exm e1) as [He1 | ?]; try inv He1; eauto.
    right; intros Hwrong; inv Hwrong. not_is_lambda_lambda.
  Qed.
End NFEXM.

Section InjectStep.
  Local Hint Constructors step : core.

  Theorem cbv_step : forall e e', e ⟶  e' -> e -->  e'.
  Proof. intros ? ? H; induction H; auto 2. Qed.

  Theorem cbn_step : forall e e', e ==>  e' -> e -->  e'.
  Proof. intros ? ? H; induction H; auto 2. Qed.

  Theorem normal_step : forall e e', e >-> e' -> e -->  e'.
  Proof. intros ? ? H; induction H; auto 2. Qed.

  Theorem appl_step : forall e e', e ⇢ e' -> e -->  e'.
  Proof. intros ? ? H; induction H; auto 2. Qed.
End InjectStep.

Section EXM.
  Local Hint Constructors step : core.

  Lemma step_exm : forall e,
      (exists e', e -->  e') \/ (forall e', ~ e -->  e').
  Proof.
    intro e;
      induction e as
        [ n
        | e [[e' IHe] | IHe]
        | e1 [[e1' IHe1] | IHe1] e2 [[e2' IHe2] | IHe2]];
      eauto.
    - right; intros ? H; inv H.
    - right; intros e' H; inv H.
      intuition; eauto.
    - destruct e1 as [? | e1 | ? ?]; eauto;
      right; intros e' H; inv H;
        intuition; eauto.
  Qed.
End EXM.

Notation "e1 >->* e2" := (refl_trans_closure normal_reduce e1 e2) (at level 40).

Theorem contrapositive : forall P Q : Prop,
    (P -> Q) -> (~ Q -> ~ P).
Proof. intuition. Qed.

Section Normalizing.
  Local Hint Resolve inject_trans_closure : core.
  Local Hint Constructors normal_reduce : core.
  Local Hint Constructors refl_trans_closure : core.
  Local Hint Constructors normal_form : core.

  Lemma normal_reduce_lambda : forall e e',
      e >->* e' -> λ e >->* λ e'.
  Proof.
    intros e e' H; induction H; eauto 3.
  Qed.

  Local Hint Resolve normal_form_exm : core.
  Local Hint Unfold Decidable.decidable : core.

  Lemma nor_normal_form_normal_reduce : forall e,
      ~ normal_form e -> exists e', e >-> e'.
  Proof.
    intro e;
      induction e as [ n
                     | e IHe
                     | e1 IHe1 e2 IHe2 ];
      intros Hnf; try (exfalso; eauto; contradiction).
    - pose proof IHe (contrapositive _ _ (nf_lam e) Hnf) as [? ?]; eauto.
    - pose proof is_lambda_exm e1 as [He1 | He1].
      + inv He1. eauto.
      + destruct (normal_form_exm e1) as [Hnf1 | Hnf1].
        * pose proof IHe2 (contrapositive _ _ (nf_app _ e2 He1 Hnf1) Hnf) as [? ?]; eauto.
        * pose proof IHe1 Hnf1 as [? ?]; eauto.
  Qed.

  Local Hint Resolve normal_step : core.

  Lemma step_normal_reduce : forall e e',
      e -->  e' -> exists e'', e >-> e''.
  Proof.
    intros e e' H; induction H;
      repeat match goal with
             | IH: exists _, _ >-> _ |- _ => destruct IH as [? ?]
             end; eauto;
    try match goal with
        | |- exists _, ?e1 ⋅ _ >-> _
          => destruct (is_lambda_exm e1) as [? | ?];
              try match goal with
                  | H: is_lambda _ |- _ => inv H
                  end; eauto
        end.
    destruct (normal_form_exm e1); eauto.
    apply nor_normal_form_normal_reduce in H2 as [? ?]; eauto.
  Qed.

  Local Hint Constructors is_lambda : core.

  Lemma multi_step_lambda : forall e e',
      λ e -->* e' -> is_lambda e'.
  Proof.
    intros e e' H.
    remember (λ e) as le eqn:Heqle;
      generalize dependent e.
    induction H; intros; subst; eauto.
    inv H. eauto.
  Qed.

  Lemma multi_step_lambda_step_inner : forall e e',
      λ e -->* λ e' -> e -->* e'.
  Proof.
    intros e e' H.
    remember (λ e) as le eqn:Heqle;
      remember (λ e') as le' eqn:Heqle';
      generalize dependent e';
      generalize dependent e;
      induction H; intros; subst.
    - inv Heqle'. eauto.
    - inv H. eauto.
  Qed.

  Definition sn (R : expr -> expr -> Prop) : expr -> Prop :=
    Acc (fun e' e => R e e').

  Local Hint Constructors Acc : core.
  Local Hint Unfold sn : core.

  Theorem normal_order_sn : forall e,
      sn step e -> sn normal_reduce e.
  Proof.
    intros e Hsn; induction Hsn;
      autounfold with core in *; eauto.
  Qed.

  Goal forall e, sn step e -> sn cbv_reduce e.
  Proof.
    intros e Hsn; induction Hsn;
      unfold sn in *; eauto.
    constructor.
    intros e' He'.
    assert (step x e') by eauto using cbv_step.
    auto.
  Qed.
End Normalizing.

Section Examples.
  Example omega_term : expr := λ !0 ⋅ !0.

  Local Hint Unfold omega_term : core.
  Local Hint Extern 0 => not_is_lambda_lambda : core.
  Local Hint Constructors is_lambda : core.

  Example omega_does_not_halt : ~ halts_R step (omega_term ⋅ omega_term).
  Proof.
    unfold halts_R; intros [e [Hms Hns]].
    remember (omega_term ⋅ omega_term) as oo eqn:Hoo.
    induction Hms; subst.
    - apply Hns with (omega_term ⋅ omega_term).
      constructor.
    - assert (a2 = omega_term ⋅ omega_term).
      { clear a3 Hms IHHms Hns.
        inv H; simpl; auto.
        + inv H3. inv H0. inv H3. inv H3.
        + inv H3. inv H0. inv H3. inv H3. }
      subst. intuition.
  Qed.
End Examples.


Require Import Nat Arith.

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

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

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

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

Fixpoint plus (plus_arg0 : Nat) (plus_arg1 : Nat) : Nat
           := match plus_arg0, plus_arg1 with
              | zero, n => n
              | succ n, m => succ (plus n m)
              end.

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 len (len_arg0 : Lst) : Nat
           := match len_arg0 with
              | nil => zero
              | cons x y => succ (len y)
              end.

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

Theorem len_append: forall (l1 l2: Lst), len (append l1 l2) = plus (len l1) (len l2).
Proof.
  induction l1; induction l2; simpl.
  { f_equal. rewrite IHl1. simpl. reflexivity. }
  { f_equal. rewrite IHl1. simpl. reflexivity. }
  { reflexivity. }
  { reflexivity. }
Qed.

Theorem plus_comm: forall (n m: Nat), plus n m = plus m n.
Proof.
  induction n; induction m.
  { simpl. rewrite IHn. rewrite <- IHm. simpl. rewrite IHn. reflexivity. }
  { simpl. rewrite IHn. simpl. reflexivity. }
  { simpl. rewrite <- IHm. simpl. reflexivity. }
  { reflexivity. }
Qed.

Theorem len_rev: forall (l: Lst), len (rev l) = len l.
Proof.
  induction l; simpl.
  { rewrite len_append. rewrite plus_comm. simpl. f_equal. assumption. }
  { reflexivity. }
Qed.

Theorem theorem0 : forall (x : Lst) (y : Lst), eq (len (rev (append x y))) (plus (len x) (len y)).
Proof.
  intros.
  rewrite len_rev.
  apply len_append.
Qed.


Require Export Lists.List.
Require Export GenReflect SetSpecs.
Require Export DecSort MinMax.
Require Export DecType SetReflect.
Require Export DecList.

Set Implicit Arguments.

Section MoreDecList.

Context { A: eqType}.
(*------------------ Uniform list -----------------------------------------------------*)

Inductive uniform : list A -> Prop:=
| Nil_uni: uniform nil
|Sing_uni(a:A): uniform (a::nil)
|Ind_uni(a b:A)(l:list A): a=b -> uniform (b::l)-> uniform (a::b::l).

Lemma uniform_elim (a:A)(l: list A): uniform (a::l)-> (forall x, In x l -> x=a).
Proof. { revert l. induction l.
       { simpl. intros H0 fA f. destruct f. }
       { simpl. intros H fA. inversion H. intro H5.  destruct H5 as [H5| H6].
        subst fA. symmetry. exact. apply IHl in H6. exact. subst a. exact. } } Qed.

Lemma uniform_elim1 (a:A)(l: list A): uniform (a::l)-> (forall x, In x (a::l)-> x=a).
Proof. { induction l.
        { simpl. intros. destruct H0. auto. inversion H0. }
        { intros. inversion H. subst a0.  simpl in H0. destruct H0.
        auto. apply IHl. exact. simpl. exact. } } Qed.

Lemma uniform_elim2 (a:A) (l: list A): uniform (a::l)-> uniform l.
Proof. intro H. inversion H. constructor. exact. Qed.

Lemma uniform_elim4 (a1 a2:A) (l: list A) : uniform l -> In a1 l -> In a2 l -> a1=a2.
Proof. { induction l.
         { simpl. intros H1 H2. destruct H2. }
         { intros H1 H2 H3.
           assert (H0:(forall x, In x (a::l)-> x=a)).
           apply uniform_elim1. exact. specialize (H0 a1) as Ha1.
           apply Ha1 in H2. specialize (H0 a2) as Ha2.
           apply Ha2 in H3. subst a1. subst a2. auto. }} Qed.

Lemma uniform_elim3 (a:A) (l:list A): uniform l -> uniform (delete a l).
Proof. { revert a.
         induction l.
         { simpl. auto. }
         { intros.
           case l eqn:H0.
           { simpl. destruct (a0==a) eqn: Ha. constructor. constructor. }
           { simpl. destruct (a0==a) eqn: Ha. eapply uniform_elim2.
             exact H.
           { apply uniform_elim2 in H as H1.  specialize (IHl a0) as Hl.
             apply Hl in H1.
             destruct (a0 == e) eqn:Hae.
             {  move /eqP in Ha.  move /eqP in Hae.  assert (H2: a<> e).
                intro. subst a0. auto.
                apply uniform_elim4 with (a1:=a) (a2:=e) in H. subst a.
                destruct H2. all:auto. }
             {  apply uniform_elim4 with (a1:=a) (a2:=e) in H.
                subst a. constructor. auto. simpl in H1.
                rewrite Hae in H1. all:auto.  }}}}} Qed.

Lemma uniform_intro (a:A)(l: list A): (forall x, In x l -> x=a) -> uniform (a::l).
Proof. { intros. induction l.
         { simpl. intros. constructor. }
         { simpl. intros.  assert (H1: (forall x : A, In x l -> x = a)).
           auto. specialize (H a0) as Ha0. assert (H2: In a0 (a0 :: l)).
           auto. apply Ha0 in H2. subst a0. apply IHl in H1.
           constructor. auto. exact. }} Qed.

(* ----------------- delete_all operation ---------------------------------------------  *)

Fixpoint del_all (a:A)(l: list A): list A:=
    match l with
    |nil => nil
    | a1::l1 => match  (a == a1) with
               |true => del_all a l1
               |false => a1 :: del_all a l1
               end
    end.

(* This function deletes all occurences of a in the list l *)

  Lemma del_all_elim1 (a b:A)(l: list A): In a (del_all b l)-> In a l.
  Proof. { induction l.
          { simpl. auto. }
          { simpl. destruct (a==a0) eqn:H0. intros. left. move /eqP in H0.
            auto. destruct (b==a0) eqn:H1. intros. right. apply IHl in H.
            exact. simpl. intros H2. destruct H2. left. exact.
            right. apply IHl in H. exact. } } Qed.

  Lemma del_all_elim2 (a b:A)(l: list A): In a (del_all b l)-> (a<>b).
  Proof. { induction l.
          { simpl. auto. }
          { simpl. destruct (b==a0) eqn:H0. exact. simpl. intros H1.
            destruct H1.  move /eqP in H0. subst a0. auto.
            apply IHl in H. exact. } } Qed.

  Lemma del_all_intro (a b: A)(l:list A): In a l -> a<>b -> In a (del_all b l).
  Proof. { induction l.
          { simpl. auto. }
          { simpl. intros H1 H2. destruct H1. destruct (b==a0) eqn: H3.
            move /eqP in H3. subst a0. subst b. apply IHl in H2. exact. tauto.
            simpl. left. auto. destruct (b==a0) eqn: H4. apply IHl in H2.
            exact. exact. simpl. right. apply IHl in H2. exact. exact. }} Qed.

  Lemma del_all_iff (a b:A)(l: list A): (In a (del_all b l) <-> (In a l /\ a<>b)).
  Proof. { induction l.
          { simpl. split. auto.  intros H. destruct H. auto. }
          { simpl. destruct (b==a0) eqn: H0. split. intros. split. right.
           apply IHl in H. destruct H. exact. apply IHl in H. destruct H.
           auto. intros H. destruct H. destruct H. move /eqP in H0. subst
           a0. subst b. tauto. apply IHl. split. exact. exact. simpl. split.
           intros H. destruct  H. split. left. auto. move /eqP in H0.
           subst a0. auto. split. apply IHl in H. destruct H. right. exact.
           apply IHl in H. destruct H. exact. simpl. intros. destruct H.
           destruct H. left. exact.  assert (H2: (In a l) /\ (a<>b)). split.
           exact. exact.  apply IHl in H2. right. exact. } } Qed.

  Hint Resolve del_all_elim1 del_all_elim2 del_all_intro: core.

  Lemma del_all_nodup (a:A)(l: list A): NoDup l -> NoDup (del_all a l).
  Proof. { induction l.
          { simpl. auto. }
          { simpl. intros H. destruct (a==a0) eqn: H1. move /eqP in H1.
            subst a0. eauto. assert (H0:NoDup l). eauto. apply IHl in H0.
            assert (H2: ~(In a0 l)). eauto.
            assert (H3: ~(In a0 (del_all a l))). eauto. eauto. } } Qed.

  Hint Resolve del_all_nodup: core.

 (* ------- count of an element a in the list l ----------------------------------------*)

 Fixpoint count (a:A) (l:list A) : nat:= match l with
                          | nil => 0
                          |a1::l1 => match a == a1 with
                                    |true => S (count a l1)
                                    |false => count a l1
                                    end
                                        end.
  Lemma countP1 (a:A) (l:list A): In a l -> (count a l >= 1).
  Proof. { induction l.
          { intros H. inversion H. }
          { intros H. simpl in H. destruct H. subst a0. simpl.
           destruct (a==a) eqn:H0. omega. move /eqP in H0. absurd (a=a).
           exact. exact. apply IHl in H. simpl. destruct (a==a0) eqn:H0.
           omega. exact. } } Qed.
  Lemma countP1b (a:A) (l:list A): (count a l >= 1) -> In a l.
  Proof. { induction l.
          { intros H. inversion H. }
          { intros H. simpl in H.
           simpl.
           destruct (a==a) eqn:H0.
           destruct (a == a0) eqn: Ha.
           left. move /eqP in Ha. auto. right.
           apply IHl in H. exact.
           destruct (a == a0) eqn: Ha.
           left. move /eqP in Ha. auto. right.
           apply IHl in H. exact. } } Qed.

  Lemma countP2 (a:A)(l: list A): ~ In a l -> (count a l = 0).
  Proof. { intros. induction l.
          { simpl. auto. }
          { simpl. destruct (a==a0) eqn: H0. move /eqP in H0. subst a0.
           simpl in H. destruct H. left. exact. move /eqP in H0.
           assert (H1: ~(In a l)). eauto. apply IHl in H1. exact. } } Qed.

  Lemma countP3 (a:A)(l: list A): (count a l = 0) -> ~ In a l.
  Proof. { induction l.
          { simpl. auto. }
          { simpl. destruct (a==a0) eqn:H0. intros. omega. intros.
            apply IHl in H. move /eqP in H0. intro.  destruct H1. auto.
            eauto. } } Qed.

  Lemma countP4 (a:A)(l: list A): count a (a::l) = S (count a l).
  Proof. simpl. destruct (a==a) eqn:H. exact. move /eqP in H. auto. Qed.

  Lemma countP5 (a b:A)(l: list A): (count a l) <= count a (b::l).
  Proof. { induction l.
         { simpl. omega. }
         { simpl. destruct (a==a0) eqn:H0. destruct (a==b) eqn:H1. omega.
           omega. destruct (a==b) eqn: H1. omega. omega. } } Qed.

  Lemma countP6 (a: A)(l: list A): count a l <= |l|.
  Proof. { induction l. simpl. omega. simpl. destruct (a==a0) eqn:H0.
  omega. omega. } Qed.

  Lemma countP7 (a:A) (l:list A): In a l -> count a l = S(count a (delete a l)).
  Proof. { induction l.
          { simpl. auto. }
          { simpl. intro H. destruct H as [H1 | H2]. destruct (a==a0) eqn: H0.
            exact. move /eqP in H0. auto. destruct (a==a0) eqn: H0. exact.
            apply IHl in H2. move /eqP in H0. simpl. destruct (a==a0) eqn: H1.
            move /eqP in H1. auto. exact. } } Qed.

  Lemma countP8 (a:A) (l:list A): forall x, x<>a-> count x (a::l) = count x l.
  Proof. { induction l.
          { simpl. intros. destruct (x==a) eqn: H0. move /eqP in H0. auto.
           exact. }
          { intros. simpl. destruct (x==a) eqn:H0. move /eqP in H0. auto.
            destruct (x==a0) eqn: H1. exact. exact. }} Qed.

  Lemma countP9 (a:A) (l:list A): forall x, x<>a -> count x l = count x (delete a l).
  Proof. { induction l.
          { simpl. intros;auto. }
          { intros. simpl. destruct (x==a0) eqn: H0. destruct (a==a0) eqn:H1.
            move /eqP in H0. move /eqP in H1. subst a0. auto. simpl.
            destruct (x==a0) eqn: H2. auto. auto. destruct (a==a0) eqn:H2.
            exact. simpl. destruct (x==a0) eqn: H3. inversion H0. auto. }}  Qed.

  Lemma countP10 (a:A)(l s:list A): count a l <= count a s -> count a (a::l) <= count a (a::s).
  Proof. { induction l.
          { simpl. intros. destruct (a==a) eqn: H1. omega. omega. }
          { simpl. intros. destruct (a==a0) eqn:H1. destruct (a==a) eqn:H2.
            omega. omega. destruct (a==a) eqn: H2. omega. omega. } } Qed.

  Lemma countP11 (a:A)(l s: list A): count a l = count a s -> count a (a::l) = count a (a::s).
  Proof. { induction l.
          { simpl. intros. destruct (a==a) eqn: H1. auto. exact. }
           { simpl. destruct (a==a0) eqn:H1. intros. destruct (a==a) eqn:H2.
            omega. omega. destruct (a==a) eqn: H2. intros. omega. omega. }} Qed.

  Lemma countP12 (a:A)(l s: list A): count a l < count a s -> count a (a::l) < count a (a::s).
  Proof. {  induction l.
          { simpl. intros. destruct (a==a) eqn: H1. omega. exact. }
          { simpl. destruct (a==a0) eqn: H2. destruct (a==a) eqn: H1. intros.
            omega. intros. omega. destruct (a==a) eqn: H1. intros. omega.
            intros. omega. }} Qed.

  Lemma count_nodup (l:list A): (forall x, In x l -> count x l <=1)-> NoDup l.
  Proof. { intros H.
         induction l.
         { auto. }
         { cut (NoDup l). cut (~In a l). auto. intros H1.
          specialize (H a) as H2.
          assert (H3:  count a (a :: l) <= 1). apply H2. auto.
          simpl in H3. replace (a==a) with true in H3.
          inversion H3. absurd (In a l). apply countP3. auto.
          exact. inversion H4. auto.
          apply IHl. intros x H1.
          cut ( count x l <= count x (a::l)).
          intros H2.
          assert (H3: count x (a :: l) <= 1).
          { apply H. auto. }
          omega. apply countP5. }} Qed.

  Lemma nodup_count (l:list A) (x:A): NoDup l -> In x l -> count x l <=1.
  Proof. { intros H1 H2.
           induction l. simpl. auto.
           { simpl in H2. destruct H2.
             { subst x.
             simpl. replace (a==a) with true.
             cut (count a l =0). omega.
             cut (~In a l). eapply countP2. auto. auto. }
             { assert (Ha: x<>a).
               { intro H2. subst x. absurd (In a l);auto. }
              replace (count x (a::l)) with (count x l).
              apply IHl. eauto. exact. symmetry.
               apply countP8. exact. }}} Qed.

  Hint Immediate countP1 countP2 countP3: core.
  Hint Resolve countP4 countP5 countP6 countP7 countP8 countP9: core.
  Hint Immediate count_nodup nodup_count: core.

End MoreDecList.

 Hint Resolve del_all_elim1 del_all_elim2 del_all_intro: core.
 Hint Resolve del_all_nodup: core.

 Hint Immediate countP1 countP2 countP3: core.
 Hint Resolve countP4 countP5 countP6 countP7 countP8 countP9:  core.
 Hint Resolve countP10 countP11 countP12: core.
 Hint Immediate count_nodup nodup_count: core.

Section Permutation.

  Context { A: eqType }.

   Lemma EM:forall x y : A, x=y \/ x<>y.
   Proof. eauto. Qed.

   Definition empty: list A:= nil.

   Lemma count_in_putin1 (a: A)(l: list A)(lr: A-> A-> bool):
     count a (putin lr a l)= S (count a l).
   Proof. { induction l. simpl. destruct (a==a) eqn:H. auto. conflict_eq.
           { simpl. case (lr a a0) eqn: H0.
             { destruct (a==a0) eqn:H1. move /eqP in H1.
               subst a0. assert (H: count a (a::a::l)=S(count a (a::l))). eauto.
               rewrite H. eauto.
               assert (H: count a (a :: a0 :: l) = S (count a (a0::l))).
               eauto.  move /eqP in H1. rewrite H. eauto. }
             { simpl. destruct (a==a0) eqn:H1. omega. auto. } } } Qed.

   Lemma count_in_putin2 (a b: A)(l: list A)(lr: A-> A-> bool):
     a<>b -> count a l = count a (putin lr b l).
   Proof. { induction l.
            { simpl; destruct (a==b) eqn:H. intros;conflict_eq. auto. }
            { intros.  simpl. case (lr b a0) eqn: H0.
              { destruct (a==a0) eqn:H1.
                move /eqP in H1. subst a0.
                replace (count a (b :: a :: l)) with (count a (a :: l)).
                eauto. symmetry; auto. move /eqP in H1.
                replace (count a (b :: a0 :: l)) with (count a (a0 :: l)).
                all: symmetry;eauto. }
              { destruct (a==a0) eqn: H1.
                move /eqP in H1. subst a0.
                replace (count a (a :: putin lr b l)) with (S(count a (putin lr b l))).
                 eauto. symmetry. auto.
                replace (count a (a0 :: putin lr b l)) with (count a (putin lr b l)).
                auto. move /eqP in H1. symmetry;auto. }  } } Qed.

  Lemma count_in_sorted (a: A)(l: list A)(lr: A-> A-> bool): count a l = count a (sort lr l).
  Proof. { induction l. simpl; auto.
           simpl. destruct  (a == a0) eqn:H0.
           move /eqP in H0. subst a.
           rewrite IHl. symmetry; apply count_in_putin1.
           move /eqP in H0. rewrite IHl.  apply count_in_putin2. auto. }  Qed.

  Hint Resolve count_in_putin1 count_in_putin2 count_in_sorted: core.

  (* ---------------  sublist of a list (subsequence)------------------------------------ *)

  Fixpoint sublist (l s: list A): bool := match (l, s) with
                                              |(nil , _) => true
                                              |(a::l1, nil) => false
                                              |(a::l1, b::s1) => match (a == b) with
                                                          |true => sublist l1 s1
                                                          |false => sublist l s1
                                                          end
                                       end.

  Lemma sublist_intro (l: list A): sublist nil l.
  Proof.   destruct l;simpl;auto. Qed.
  Lemma sublist_reflex (l: list A): sublist l l.
  Proof. induction l;simpl.
         auto. destruct (a==a) eqn:H; [auto | conflict_eq].  Qed.

  Lemma sublist_elim1 (l: list A): sublist l nil -> l=nil.
  Proof. destruct l; [auto | simpl; intro H; inversion H]. Qed.

  Lemma sublist_elim2 (a:A)(l s: list A): sublist (a::l) s -> In a s.
  Proof. induction s.  simpl; auto. simpl. destruct (a==a0) eqn:H. move /eqP in H.
         subst a0; auto. intro;right;auto. Qed.

  Lemma sublist_elim3 (a: A)(l s: list A): sublist (a::l) s -> sublist l s.
  Proof. { revert l; revert a. induction s.
         { auto. }
         { intros a0 l.
           simpl. destruct (a0 == a) eqn:H.
           { destruct l. auto.  destruct (e == a) eqn:H1.
             apply IHs. auto.  }
           { destruct l. auto.  destruct (e == a) eqn:H1.
             { intro H2. assert (H2a: sublist (e::l) s). eapply IHs;exact H2.
               eapply IHs; exact H2a. }
             { apply IHs. }
         } } } Qed.

  Lemma sublist_elim3a (a e: A)(l s: list A): sublist (a::l)(e::s)-> sublist l s.
  Proof. simpl. destruct (a==e) eqn:H. auto.   eauto using sublist_elim3. Qed.

   Lemma sublist_intro1 (a:A)(l s: list A): sublist l s -> sublist l (a::s).
   Proof.  { revert s;revert a. induction l.
           { auto. }
           { intros a0 s.
             simpl. destruct (a == a0) eqn:H. apply sublist_elim3. auto. } } Qed.

   Lemma sublist_Subset (l s: list A): sublist l s -> Subset l s.
   Proof. { revert s. induction l.  eauto.
           intros s H. eauto. unfold "[<=]". intros x H1.
           destruct H1. subst x. eauto using  sublist_elim2. apply sublist_elim3 in H.
           apply IHl in H. eauto. } Qed.

   Lemma sublist_elim4 (l s: list A): sublist l s -> (forall a, count a l <= count a s).
   Proof. { revert l. induction s as [| e s'].
          { intro l. intro H. assert (H1: l=nil); auto using sublist_elim1.
            subst l; auto.  }
          { intros l H x. destruct l as [|a l'].
            simpl. omega. destruct (x==a) eqn:Hxa.
            { move /eqP in Hxa. subst x.
              simpl in H. destruct (a == e) eqn: Hae. move /eqP in Hae.
              subst e.
              cut (count a l' <= count a s'); auto.
              assert (H1: count a (a :: l') <= count a  s'). eauto.
              cut (count a s' <= count a (e::s')). omega. auto. }
            { assert (H1: count x (a::l')<= count x s').
              { simpl. rewrite Hxa. eauto using sublist_elim3a. }
              cut (count x s' <= count x (e::s')). omega. auto. } } } Qed.

   (*

  Hint Extern 0 (is_true ( sublist ?x ?z) ) =>
  match goal with
  | H: is_true (sublist x  ?y) |- _ => apply (@sublist_trans  x y z)
  | H: is_true (sublist ?y  z) |- _ => apply (@sublist_trans  x y z)
  end.
*)

  Hint Resolve sublist_intro sublist_intro1 sublist_reflex sublist_Subset sublist_elim1: core.
  Hint Resolve sublist_elim2 sublist_elim3 sublist_elim4: core.

  (* -------------- list inclusion (subset in multiset) ----------------------------------*)

  Fixpoint included (l s: list A): bool := match l with
                                        |nil => true
                                        | a::l1 => match (memb a s) with
                                                  |true => included l1 (delete a s)
                                                  |false => false
                                                  end
                                        end.
  Lemma included_intro1 (l: list A): included nil l.
  Proof.  auto. Qed.

   Lemma included_refl (l: list A): included l l.
  Proof. { induction l. auto. simpl. destruct (a==a) eqn:H0. auto. move /eqP in H0. auto. } Qed.

  Lemma included_intro2 (a:A)(l s: list A): In a s -> included l (delete a s)-> included (a::l) s.
  Proof. { induction s.
          { simpl. auto. }
          { simpl. intros H1 H2. destruct H1. destruct (a==a0) eqn: H3. auto.
            move /eqP in H3. auto. destruct (a==a0) eqn: H3. simpl. exact.
            simpl.  assert (H4: memb a s). eauto. case (memb a s) eqn:H5.
            exact. auto. } } Qed.

  Lemma included_intro (l s: list A): (forall a, count a l <= count a s)-> included l s.
  Proof. { revert s. induction l. intros;apply included_intro1;auto.
           { intros s H. simpl.  case (memb a s) eqn:Has;move /membP in Has.
             apply IHl. intro x. destruct (EM x a).
             2:{  replace (count x l) with (count x (a::l)).
             replace (count x (delete a s)) with (count x s).
             all: eauto. } subst x.
             replace (count a l) with ((count a (a::l)) -1).
             replace (count a (delete a s)) with ((count a s)-1).
             specialize (H a).  omega.
             replace (count a s) with (S (count a (delete a s))). omega.
             symmetry; eauto.
             replace (count a (a :: l)) with (S (count a l)). omega.
             symmetry; eauto.
             specialize (H a). rewrite countP4 in H.
             replace (count a s) with 0 in H. inversion H. symmetry; eauto. } } Qed.

    Lemma included_intro3 (l s: list A): sublist l s -> included l s.
  Proof.  intro H. assert (H2: (forall a, count a l <= count a s)). eapply sublist_elim4. exact. eapply included_intro in H2. exact. Qed.

  Lemma included_elim1 (l: list A): included l nil -> l=nil.
  Proof. induction l. auto. intros. inversion H. Qed.

  Lemma included_elim2 (a:A)(l s: list A): included (a::l) s -> In a s.

  Proof. { induction l.
          {simpl. destruct (memb a s) eqn:H. auto. intro. inversion H0. }
          { simpl. destruct (memb a s) eqn:H. auto. intro. inversion H0. }}Qed.

  Lemma included_elim3 (a:A)(l s: list A): included (a::l) s -> included l (delete a s).
  Proof. { induction s.
          { simpl. auto. }
          { simpl. destruct (a==a0) eqn:H0. simpl. auto. simpl. intros H.
            destruct (memb a s) eqn:H1. auto. auto. } } Qed.

  Lemma included_elim (l s: list A): included l s-> (forall a, count a l <= count a s).
  Proof. { revert s. induction l. simpl. intros;omega.
           intros s H x. apply included_elim2 in H as H1. apply included_elim3 in H as H2.
           assert (H3: count a l <= count a (delete a s)).  eapply IHl with (s:= (delete a s)).
           auto.  destruct (EM x a).
           subst x. replace (count a (a::l)) with (S(count a l)).
           replace (count a s) with (S( count a (delete a s))).
           omega. symmetry; eauto.  eauto.
           replace (count x (a::l)) with (count x l).
           replace (count x s) with  (count x (delete a s)).
           eauto. all: symmetry;eauto. } Qed.

  Lemma included_elim4 (a:A)(l s: list A): included (a::l) s -> included l s.
  Proof. { intro H. assert (H1: (forall a0, count a0 (a::l) <= count a0 s)).
           eapply included_elim. exact. eapply included_intro.
           assert (H2:forall a0 : A, (count a0 l)<=(count a0 (a :: l))). eauto.
           intros. specialize (H1 a0). specialize (H2 a0). omega. } Qed.

Lemma included_elim4b (a:A) (l s: list A) : included l s -> included (a::l) (a::s).
Proof. { intro H. apply included_intro. intro x. simpl.
         destruct (x==a) eqn: H1. cut ((count x l)<= (count x s)).
        omega. all:apply included_elim;exact. } Qed.

Lemma included_elim4a (a:A) (l: list A) : included (delete a l) l.
Proof. { induction l. simpl. auto. simpl. destruct (a == a0) eqn: H0.
assert (H1: (forall a1, count a1 l <= count a1 (a0::l))). intros.
 eapply countP5. apply included_intro in H1. exact.
  assert (H3:(included (delete a l) l)-> (included (a0 :: delete a l) (a0 :: l))).
  eapply included_elim4b. eapply H3 in IHl. exact. } Qed.

   Lemma included_elim5 (l s: list A): included l s -> Subset l s.
  Proof. { unfold "[<=]".
          induction l.
          { simpl. intros. destruct H0. }
          { intros.  destruct H0. eapply included_elim2 in H as H2.
           subst a0. exact. apply IHl. eapply included_elim4 in H as H3.
           exact. exact. } } Qed.

    Lemma included_elim6 (l s: list A)(a b: A)(lr: A->A-> bool)(Hanti: antisymmetric lr): Sorted lr (a::l) -> Sorted lr (b::s) ->
     included (a::l) (b::s)-> a<>b -> included (a::l) s.
    Proof. { intros H1 H2 H3 H4.
           assert (H5: forall x, count x (a::l) <= count x (b::s)).
           { eapply included_elim;auto. }
           eapply included_intro.
           intros x. simpl.
           destruct (x == a) eqn: Hxa.
           { (*-----x=a----*)
            specialize (H5 a) as H6. simpl in H6. replace (a==b) with false in H6.
            replace (a==a) with true in H6. move /eqP in Hxa. subst x. exact.
            auto. auto. }
            { (*-----x<>a-----*)
              destruct (x==b) eqn:Hxb.
              {  (*----x=b---*)
               move /eqP in Hxb. subst x. replace (count b l) with 0. omega.
               symmetry. cut (~In b l). eauto. intro H6.
               assert (H7: lr a b). eauto.
               assert (H8: lr b a).
               { (*---lr b a ---*)
                cut (In a (b::s)). eauto. eapply included_elim2. exact H3.
                }
               absurd (a=b). auto. apply Hanti. split_;auto. }
              { (*--- x<>b----*)
                 specialize (H5 x) as Hx.
                 simpl in Hx. rewrite Hxa in Hx. rewrite Hxb in Hx. exact. } } } Qed.

  Lemma included_trans (l1 l2 l3: list A):
  included l1 l2-> included l2 l3 -> included l1 l3.
  Proof. { intros H1 H2.
          assert (H1a:forall a0 : A, (count a0 l1)<=(count a0 l2)).
          eapply included_elim. exact.
          assert (H2a:forall a0 : A, (count a0 l2)<=(count a0 l3)).
          eapply included_elim. exact.
          eapply included_intro. intros a.
          specialize (H1a a). specialize (H2a a). omega. } Qed.

   Hint Extern 0 (is_true ( included ?x ?z) ) =>
  match goal with
  | H: is_true (included x  ?y) |- _ => apply (@included_trans  x y z)
  | H: is_true (included ?y  z) |- _ => apply (@included_trans  x y z)
  end : core.

  Hint Resolve included_intro1 included_intro2 included_intro3: core.
  Hint Resolve included_refl included_intro: core.
  Hint Resolve included_elim1 included_elim2 included_elim3: core.
  Hint Resolve included_elim4 (* included_elim4a *) included_elim5 included_elim: core.

  (* ----- Some Misc Lemmas on nodup, sorted, sublist, subset and included ---------------- *)

  Lemma nodup_subset_included (l s: list A): NoDup l -> l [<=] s -> included l s.
  Proof. { intros H1 H2. eapply included_intro. intro a. assert (H: In a l -> In a s). eauto. assert (H3: forall x, In x l -> count x l <=1). eauto.
  specialize (H3 a) as H4. assert (H5:In a s -> count a s >=1). eauto.
  assert (H6:(In a l)\/( ~In a l)). eauto. destruct H6. apply H in H0 as H7.
  apply H5 in H7. apply H4 in H0. omega. assert (H6: count a l =0).
  eauto. replace (count a l) with 0. omega. } Qed.

  Lemma sublist_is_sorted (lr: A-> A-> bool)(l s: list A):  Sorted lr s -> sublist l s -> Sorted lr l.
  Proof. { revert l.
           induction s as [|b s1].
           { intros l H1 H2. assert (H3:l=nil).
             eauto.  subst l. auto. }
           { intros l H1 H2.
             destruct l as [|a l1].
             {  eapply Sorted_elim3. apply Sorted_single. Unshelve. exact. }
             { simpl in H2.
               destruct (a == b) eqn: Hab.
               { (*----a=b----*)
                 move /eqP in Hab. constructor.
                 { apply IHs1. eauto. exact. }
                 { intros x H3.
                   assert (H4: lr b x).
                   { cut (In x s1). apply Sorted_elim4. exact.
                   assert (H5: l1 [<=] s1). auto. auto. }
                 subst a;auto. } }
               { (*---a<>b---*)
                 apply IHs1.  eauto. exact.  } } } } Qed.

  Lemma sorted_included_sublist (l s: list A)(lr: A->A-> bool)(Hanti: antisymmetric lr):
    Sorted lr l-> Sorted lr s-> included l s-> sublist l s.
  Proof. { revert l.
           induction s as [|b s1].
           { intros l H1 H2 H3. destruct l;simpl in H3. simpl;auto.
            inversion H3. }
           { intros l H1 H2 H3.
             destruct l as [|a l1] eqn: H4.
             { simpl;auto. }
             { (*----sublist (a :: l1) (b :: s1)-----*)
               simpl. destruct (a==b) eqn: Hab.
               { (*----- a = b --------*)
               apply IHs1. eauto. eauto. move /eqP in Hab. subst b.
               cut (forall x, count x l1 <= count x s1). eauto.
               intros x.
               assert (H5: forall y, count y (a :: l1) <= count y (a :: s1)).
               eapply included_elim. exact. specialize (H5 x) as H6. simpl in H6.
               destruct (x == a);omega. }
               { (*------ a <> b--------*)
                assert (H5: included (a::l1) s1). eapply included_elim6.
                exact Hanti. auto. exact H2. exact H3. move /eqP in Hab.  exact.
                eapply IHs1. exact. eauto. exact. } } } } Qed.

  Lemma first_in_ordered_sublists (a e:A)(l s: list A)(lr: A->A-> bool)(Hrefl: reflexive lr):
    Sorted lr (a::l)-> Sorted lr (e::s)-> sublist (a::l)(e::s)-> lr e a.
  Proof. { intros H1 H2 H3. simpl in H3. destruct (a == e) eqn: H4.
         move /eqP in H4. subst a. auto.
         assert (H5: (forall x, In x l -> lr a x)). eapply Sorted_elim4. exact.
         assert (H6: (forall x, In x s -> lr e x)). eapply Sorted_elim4. exact.
         eauto. } Qed.

 Lemma nodup_included_nodup (l s: list A) :
 NoDup s -> included l s -> NoDup l.
 Proof. { intros. assert (H1:(forall a, count a l <= count a s)).
        apply included_elim. exact. apply count_nodup. intros.
        specialize (H1 x) as H3. assert (H4: count x s <=1).
        apply nodup_count. exact. eauto. omega. } Qed.

 Lemma subset_nodup_subset (a:A) (l s: list A) :
 l[<=]a::s-> NoDup l -> ~In a l -> l[<=]s.
 Proof. { intros. unfold Subset in H. unfold Subset. intros.
       specialize (H a0) as H3. apply H3 in H2 as H4. simpl in H4.
       destruct H4. subst a. absurd (In a0 l). exact. exact. exact. } Qed.

  Hint Resolve nodup_subset_included: core.
  Hint Immediate sorted_included_sublist first_in_ordered_sublists
  nodup_included_nodup :core.

  (* --------------------  permuted lists (permutation) -------------------------------------*)

  Definition perm (l s: list A): bool:= included l s && included s l.

  Lemma perm_intro  (l s: list A): (forall a, count a l = count a s)-> perm l s.
  Proof.  { intro H; split_; apply included_intro; intro a; specialize (H a); omega. } Qed.

  Lemma perm_intro0a (l: list A)(lr: A-> A-> bool): perm l (sort lr l).
  Proof. apply perm_intro. eauto. Qed.

  Lemma perm_intro0b (l: list A)(lr: A-> A-> bool): perm (sort lr l) l.
  Proof. apply perm_intro; eauto. Qed.

  Lemma perm_nil: perm nil nil.
  Proof. split_; eauto.  Qed.

  Lemma perm_refl (l: list A): perm l l.
  Proof. split_; eauto.  Qed.

  Lemma perm_intro3 (l s: list A): sublist l s -> sublist s l -> perm l s.
  Proof. intros; split_; eauto.  Qed.

  Lemma perm_elim   (l s: list A): perm l s -> (forall a, count a l = count a s).
  Proof.  { intros H a. move /andP in H. destruct H as [H1 H2].
          cut (count a l <= count a s). cut (count a s <= count a l). omega.
          all: eauto. } Qed.

  Lemma perm_elim1 (l: list A): perm l nil -> l = nil.
  Proof. intro H; move /andP in H; destruct H as [H1 H2]; eauto. Qed.
  Lemma perm_elim2 (l s: list A): perm l s -> l [=] s.
  Proof. move /andP;intro H; destruct H; split; eauto. Qed.
  Lemma perm_sym (l s: list A): perm l s -> perm s l.
  Proof. move /andP;intro H; apply /andP; tauto. Qed.

  Lemma perm_trans (x y z: list A): perm x y -> perm y z -> perm x z.
  Proof. intros H H1; move /andP in H; move /andP in H1; apply /andP.
         split;destruct H; destruct H1. all: auto. Qed.

  Hint Extern 0 (is_true ( perm ?x ?z) ) =>
  match goal with
  | H: is_true (perm x  ?y) |- _ => apply (@perm_trans x y z)
  | H: is_true (perm ?y  z) |- _ => apply (@perm_trans x y z)
  end : core.

  Hint Resolve  perm_intro0a  perm_intro0b perm_refl perm_nil perm_elim1 : core.
  Hint Immediate perm_elim perm_intro perm_sym: core.

  Lemma perm_sort1 (l s: list A)(lr: A-> A-> bool): perm l s -> perm  l (sort lr s).
  Proof.  eauto. Qed.

   Lemma perm_sort2 (l s: list A)(lr: A-> A-> bool): perm l s -> perm  (sort lr l) s.
   Proof. eauto.  Qed.

   Lemma perm_sort3 (l s: list A)(lr: A-> A-> bool): perm l s -> perm (sort lr l)(sort lr s).
   Proof. eauto using perm_sort1. Qed.

   Lemma countP1a (l:list A) (x:A): count x l >=1 -> In x l.
   Proof. { induction l. simpl. intros H. omega. simpl.  intros H.
          destruct (x == a) eqn: H1. left. move /eqP in H1. symmetry;exact.
          right. eapply IHl in H. exact. } Qed.

   Lemma perm_nodup (l s: list A): perm l s -> NoDup l -> NoDup s.
   Proof. { intros. apply count_nodup. intros.
          assert (H2: forall x, In x l -> count x l <= 1).
          eauto. assert (H3: forall a, count a l = count a s).
          eauto. specialize (H2 x) as H4. specialize (H3 x) as H5.
          assert (H6: count x s >=1). eauto.
          assert (H7: count x l>=1). omega.
          assert (H8:In x l). apply countP1a. exact. apply H4 in H8. omega. } Qed.

   Lemma perm_subset (l1 l2 s1 s2: list A): perm l1 l2 -> perm s1 s2 -> l1 [<=] s1 -> l2 [<=] s2.
   Proof. intros. unfold perm in H. unfold perm in H0. move /andP in H.
   move /andP in H0. destruct H. destruct H0. eapply included_elim5 in H2.
   eapply included_elim5 in H0. eauto. Qed.

   Lemma perm_elim3 (l s: list A)(a: A): perm l s -> perm (a::l) (a::s).
   Proof.  unfold perm. intros. move /andP in H. destruct H. apply /andP.
   split. eapply included_elim4b. exact. eapply included_elim4b. exact. Qed.

   Hint Resolve perm_sort1 perm_sort2 perm_sort3 perm_nodup perm_subset: core.

 End Permutation.

  Hint Resolve count_in_putin1 count_in_putin2 count_in_sorted: core.

  Hint Resolve sublist_intro sublist_intro1 sublist_reflex sublist_Subset sublist_elim1: core.
  Hint Resolve sublist_elim2 sublist_elim3 sublist_elim3a sublist_elim4: core.
(*
  Hint Extern 0 (is_true ( sublist ?x ?z) ) =>
  match goal with
  | H: is_true (sublist x  ?y) |- _ => apply (@sublist_trans _ x y z)
  | H: is_true (sublist ?y  z) |- _ => apply (@sublist_trans _ x y z)
  end.

*)
  Hint Resolve included_intro1 included_intro2 included_intro3: core.
  Hint Resolve included_refl included_intro: core.
  Hint Resolve included_elim1 included_elim2  included_elim3: core.
  Hint Resolve included_elim4 (*included_elim4a*) included_elim5 included_elim: core.

  Hint Extern 0 (is_true ( included ?x ?z) ) =>
  match goal with
  | H: is_true (included x  ?y) |- _ => apply (@included_trans _ x y z)
  | H: is_true (included ?y  z) |- _ => apply (@included_trans _ x y z)
  end : core.

  Hint Resolve nodup_subset_included: core.
  Hint Immediate sorted_included_sublist first_in_ordered_sublists
  nodup_included_nodup :core.
  Hint Resolve  perm_intro0a  perm_intro0b perm_refl perm_nil perm_elim1 : core.
  Hint Immediate perm_elim perm_intro perm_sym: core.
  Hint Resolve perm_elim1 perm_elim2 perm_elim3: core.

  Hint Extern 0 (is_true ( perm ?x ?z) ) =>
  match goal with
  | H: is_true (perm x  ?y) |- _ => apply (@perm_trans _ x y z)
  | H: is_true (perm ?y  z) |- _ => apply (@perm_trans _ x y z)
  end : core.

  Hint Resolve perm_sort1 perm_sort2 perm_sort3 perm_nodup perm_subset: core.


Record ARS : Type :=
  mkARS
    { elt : Type ;
      red : elt -> elt -> Prop
    }.

Inductive TransitiveClosure (A: ARS): elt A -> elt A -> Prop :=
  | tc_head : forall {x y}, red A x y -> TransitiveClosure A x y
  | tc_cons : forall {x y z}, TransitiveClosure A x y -> red A x y -> TransitiveClosure A x z.

Definition ReflexiveTransitiveClosure (A: ARS)(x y : elt A) : Prop :=
  x = y \/ TransitiveClosure A x y.

Definition SymmetricClosure (A: ARS)(x y: elt A) : Prop :=
  red A x y \/ red A y x.

Inductive TransitiveSymmetricClosure (A: ARS): elt A -> elt A -> Prop :=
| tsc_head: forall {x y}, SymmetricClosure A x y -> TransitiveSymmetricClosure A x y
| tsc_cons: forall {x y z}, TransitiveSymmetricClosure A x y -> SymmetricClosure A y z -> TransitiveSymmetricClosure A x z.

Definition ReflexiveTransitiveSymmetricClosure (A: ARS)(x y: elt A) : Prop :=
  x = y \/ TransitiveSymmetricClosure A x y.


(** * ProofObjects: Working with Explicit Evidence in Coq *)

Require Export MoreLogic.

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

(**  We have seen that Coq has mechanisms both for _programming_,
    using inductive data types (like [nat] or [list]) and functions
    over these types, and for _proving_ properties of these programs,
    using inductive propositions (like [ev] or [eq]), implication, and
    universal quantification.  So far, we have treated these mechanisms
    as if they were quite separate, and for many purposes this is
    a good way to think. But we have also seen hints that Coq's programming and
    proving facilities are closely related. For example, the
    keyword [Inductive] is used to declare both data types and
    propositions, and [->] is used both to describe the type of
    functions on data and logical implication. This is not just a
    syntactic accident!  In fact, programs and proofs in Coq are almost
    the same thing.  In this chapter we will study how this works.

    We have already seen the fundamental idea: provability in Coq is
    represented by concrete _evidence_.  When we construct the proof
    of a basic proposition, we are actually building a tree of evidence,
    which can be thought of as a data structure. If the proposition
    is an implication like [A -> B], then its proof will be an
    evidence _transformer_: a recipe for converting evidence for
    A into evidence for B.  So at a fundamental level, proofs are simply
    programs that manipulate evidence.
*)
(**
    Q. If evidence is data, what are propositions themselves?

    A. They are types!

    Look again at the formal definition of the [beautiful] property.  *)

Print beautiful.
(* ==>
  Inductive beautiful : nat -> Prop :=
      b_0 : beautiful 0
    | b_3 : beautiful 3
    | b_5 : beautiful 5
    | b_sum : forall n m : nat, beautiful n -> beautiful m -> beautiful (n + m)
*)

(** *** *)

(** The trick is to introduce an alternative pronunciation of "[:]".
    Instead of "has type," we can also say "is a proof of."  For
    example, the second line in the definition of [beautiful] declares
    that [b_0 : beautiful 0].  Instead of "[b_0] has type
    [beautiful 0]," we can say that "[b_0] is a proof of [beautiful 0]."
    Similarly for [b_3] and [b_5]. *)

(** *** *)

(** This pun between types and propositions (between [:] as "has type"
    and [:] as "is a proof of" or "is evidence for") is called the
    _Curry-Howard correspondence_.  It proposes a deep connection
    between the world of logic and the world of computation.
<<
                 propositions  ~  types
                 proofs        ~  data values
>>
    Many useful insights follow from this connection.  To begin with, it
    gives us a natural interpretation of the type of [b_sum] constructor: *)

Check b_sum.
(* ===> b_sum : forall n m,
                  beautiful n ->
                  beautiful m ->
                  beautiful (n+m) *)
(** This can be read "[b_sum] is a constructor that takes four
    arguments -- two numbers, [n] and [m], and two pieces of evidence,
    for the propositions [beautiful n] and [beautiful m], respectively --
    and yields evidence for the proposition [beautiful (n+m)]." *)

(** Now let's look again at a previous proof involving [beautiful]. *)

Theorem eight_is_beautiful: beautiful 8.
Proof.
    apply b_sum with (n := 3) (m := 5).
    apply b_3.
    apply b_5. Qed.

(** Just as with ordinary data values and functions, we can use the [Print]
command to see the _proof object_ that results from this proof script. *)

Print eight_is_beautiful.
(* ===> eight_is_beautiful = b_sum 3 5 b_3 b_5
     : beautiful 8  *)

(** In view of this, we might wonder whether we can write such
    an expression ourselves. Indeed, we can: *)

Check (b_sum 3 5 b_3 b_5).
(* ===> beautiful (3 + 5) *)

(** The expression [b_sum 3 5 b_3 b_5] can be thought of as
    instantiating the parameterized constructor [b_sum] with the
    specific arguments [3] [5] and the corresponding proof objects for
    its premises [beautiful 3] and [beautiful 5] (Coq is smart enough
    to figure out that 3+5=8).  Alternatively, we can think of [b_sum]
    as a primitive "evidence constructor" that, when applied to two
    particular numbers, wants to be further applied to evidence that
    those two numbers are beautiful; its type,
    forall n m, beautiful n -> beautiful m -> beautiful (n+m),
    expresses this functionality, in the same way that the polymorphic
    type [forall X, list X] in the previous chapter expressed the fact
    that the constructor [nil] can be thought of as a function from
    types to empty lists with elements of that type. *)

(** This gives us an alternative way to write the proof that [8] is
    beautiful: *)

Theorem eight_is_beautiful': beautiful 8.
Proof.
   apply (b_sum 3 5 b_3 b_5).
Qed.

(** Notice that we're using [apply] here in a new way: instead of just
    supplying the _name_ of a hypothesis or previously proved theorem
    whose type matches the current goal, we are supplying an
    _expression_ that directly builds evidence with the required
    type. *)

(* ##################################################### *)
(** ** Proof Scripts and Proof Objects *)

(** These proof objects lie at the core of how Coq operates.

    When Coq is following a proof script, what is happening internally
    is that it is gradually constructing a proof object -- a term
    whose type is the proposition being proved.  The tactics between
    the [Proof] command and the [Qed] instruct Coq how to build up a
    term of the required type.  To see this process in action, let's
    use the [Show Proof] command to display the current state of the
    proof tree at various points in the following tactic proof. *)

Theorem eight_is_beautiful'': beautiful 8.
Proof.
   Show Proof.
   apply b_sum with (n:=3) (m:=5).
   Show Proof.
   apply b_3.
   Show Proof.
   apply b_5.
   Show Proof.
Qed.

(** At any given moment, Coq has constructed a term with some
    "holes" (indicated by [?1], [?2], and so on), and it knows what
    type of evidence is needed at each hole.  *)

(**
    Each of the holes corresponds to a subgoal, and the proof is
    finished when there are no more subgoals.  At this point, the
    [Theorem] command gives a name to the evidence we've built and
    stores it in the global context. *)

(** Tactic proofs are useful and convenient, but they are not
    essential: in principle, we can always construct the required
    evidence by hand, as shown above. Then we can use [Definition]
    (rather than [Theorem]) to give a global name directly to a
    piece of evidence. *)

Definition eight_is_beautiful''' : beautiful 8 :=
  b_sum 3 5 b_3 b_5.

(** All these different ways of building the proof lead to exactly the
    same evidence being saved in the global environment. *)

Print eight_is_beautiful.
(* ===> eight_is_beautiful    = b_sum 3 5 b_3 b_5 : beautiful 8 *)
Print eight_is_beautiful'.
(* ===> eight_is_beautiful'   = b_sum 3 5 b_3 b_5 : beautiful 8 *)
Print eight_is_beautiful''.
(* ===> eight_is_beautiful''  = b_sum 3 5 b_3 b_5 : beautiful 8 *)
Print eight_is_beautiful'''.
(* ===> eight_is_beautiful''' = b_sum 3 5 b_3 b_5 : beautiful 8 *)

(** **** Exercise: 1 star (six_is_beautiful) *)
(** Give a tactic proof and a proof object showing that [6] is [beautiful]. *)

Theorem six_is_beautiful :
  beautiful 6.
Proof.
  (* FILL IN HERE *) Admitted.

Definition six_is_beautiful' : beautiful 6 :=
  (* FILL IN HERE *) admit.
(** [] *)

(** **** Exercise: 1 star (nine_is_beautiful) *)
(** Give a tactic proof and a proof object showing that [9] is [beautiful]. *)

Theorem nine_is_beautiful :
  beautiful 9.
Proof.
  (* FILL IN HERE *) Admitted.

Definition nine_is_beautiful' : beautiful 9 :=
  (* FILL IN HERE *) admit.
(** [] *)

(* ##################################################### *)
(** ** Quantification, Implications and Functions *)

(** In Coq's computational universe (where we've mostly been living
    until this chapter), there are two sorts of values with arrows in
    their types: _constructors_ introduced by [Inductive]-ly defined
    data types, and _functions_.

    Similarly, in Coq's logical universe, there are two ways of giving
    evidence for an implication: constructors introduced by
    [Inductive]-ly defined propositions, and... functions!

    For example, consider this statement: *)

Theorem b_plus3: forall n, beautiful n -> beautiful (3+n).
Proof.
   intros n H.
   apply b_sum.
   apply b_3.
   apply H.
Qed.

(** What is the proof object corresponding to [b_plus3]?

    We're looking for an expression whose _type_ is [forall n,
    beautiful n -> beautiful (3+n)] -- that is, a _function_ that
    takes two arguments (one number and a piece of evidence) and
    returns a piece of evidence!  Here it is: *)

Definition b_plus3' : forall n, beautiful n -> beautiful (3+n) :=
  fun (n : nat) => fun (H : beautiful n) =>
    b_sum 3 n b_3 H.

Check b_plus3'.
(* ===> b_plus3' : forall n : nat, beautiful n -> beautiful (3+n) *)

(** Recall that [fun n => blah] means "the function that, given [n],
    yields [blah]."  Another equivalent way to write this definition is: *)

Definition b_plus3'' (n : nat) (H : beautiful n) : beautiful (3+n) :=
  b_sum 3 n b_3 H.

Check b_plus3''.
(* ===> b_plus3'' : forall n, beautiful n -> beautiful (3+n) *)

(** When we view the proposition being proved by [b_plus3] as a function type,
    one aspect of it may seem a little unusual. The second argument's
    type, [beautiful n], mentions the _value_ of the first argument, [n].
    While such _dependent types_ are not commonly found in programming
    languages, even functional ones like ML or Haskell, they can
    be useful there too.

    Notice that both implication ([->]) and quantification ([forall])
    correspond to functions on evidence.  In fact, they are really the
    same thing: [->] is just a shorthand for a degenerate use of
    [forall] where there is no dependency, i.e., no need to give a name
    to the type on the LHS of the arrow. *)

(** For example, consider this proposition: *)

Definition beautiful_plus3 : Prop :=
  forall n, forall (E : beautiful n), beautiful (n+3).

(** A proof term inhabiting this proposition would be a function
    with two arguments: a number [n] and some evidence [E] that [n] is
    beautiful.  But the name [E] for this evidence is not used in the
    rest of the statement of [funny_prop1], so it's a bit silly to
    bother making up a name for it.  We could write it like this
    instead, using the dummy identifier [_] in place of a real
    name: *)

Definition beautiful_plus3' : Prop :=
  forall n, forall (_ : beautiful n), beautiful (n+3).

(** Or, equivalently, we can write it in more familiar notation: *)

Definition beatiful_plus3'' : Prop :=
  forall n, beautiful n -> beautiful (n+3).

(** In general, "[P -> Q]" is just syntactic sugar for
    "[forall (_:P), Q]". *)

(** **** Exercise: 2 stars b_times2 *)

(** Give a proof object corresponding to the theorem [b_times2] from Prop.v *)

Definition b_times2': forall n, beautiful n -> beautiful (2*n) :=
  (* FILL IN HERE *) admit.
(** [] *)

(** **** Exercise: 2 stars, optional (gorgeous_plus13_po) *)
(** Give a proof object corresponding to the theorem [gorgeous_plus13] from Prop.v *)

Definition gorgeous_plus13_po: forall n, gorgeous n -> gorgeous (13+n):=
   (* FILL IN HERE *) admit.
(** [] *)

(** It is particularly revealing to look at proof objects involving the
logical connectives that we defined with inductive propositions in Logic.v. *)

Theorem and_example :
  (beautiful 0) /\ (beautiful 3).
Proof.
  apply conj.
   (* Case "left". *)  apply b_0.
   (* Case "right". *)  apply b_3.  Qed.

(** Let's take a look at the proof object for the above theorem. *)

Print and_example.
(* ===>  conj (beautiful 0) (beautiful 3) b_0 b_3
            : beautiful 0 /\ beautiful 3 *)

(** Note that the proof is of the form
    conj (beautiful 0) (beautiful 3)
         (...pf of beautiful 3...) (...pf of beautiful 3...)
    as you'd expect, given the type of [conj]. *)

(** **** Exercise: 1 star, optional (case_proof_objects) *)
(** The [Case] tactics were commented out in the proof of
    [and_example] to avoid cluttering the proof object.  What would
    you guess the proof object will look like if we uncomment them?
    Try it and see. *)
(** [] *)

Theorem and_commut : forall P Q : Prop,
  P /\ Q -> Q /\ P.
Proof.
  intros P Q H.
  inversion H as [HP HQ].
  split.
    (* Case "left". *) apply HQ.
    (* Case "right". *) apply HP.  Qed.

(** Once again, we have commented out the [Case] tactics to make the
    proof object for this theorem easier to understand. It is still
    a little complicated, but after performing some simple reduction
    steps, we can see that all that is really happening is taking apart
    a record containing evidence for [P] and [Q] and rebuilding it in the
    opposite order: *)

Print and_commut.
(* ===>
    and_commut =
      fun (P Q : Prop) (H : P /\ Q) =>
        (fun H0 : Q /\ P => H0)
            match H with
            | conj HP HQ => (fun (HP0 : P) (HQ0 : Q) => conj Q P HQ0 HP0) HP HQ
            end
      : forall P Q : Prop, P /\ Q -> Q /\ P *)

(** After simplifying some direct application of [fun] expressions to arguments,
we get: *)

(* ===>
   and_commut =
     fun (P Q : Prop) (H : P /\ Q) =>
     match H with
     | conj HP HQ => conj Q P HQ HP
     end
     : forall P Q : Prop, P /\ Q -> Q /\ P *)

(** **** Exercise: 2 stars, optional (conj_fact) *)
(** Construct a proof object demonstrating the following proposition. *)

Definition conj_fact : forall P Q R, P /\ Q -> Q /\ R -> P /\ R :=
  (* FILL IN HERE *) admit.
(** [] *)

(** **** Exercise: 2 stars, advanced, optional (beautiful_iff_gorgeous) *)

(** We have seen that the families of propositions [beautiful] and
    [gorgeous] actually characterize the same set of numbers.
    Prove that [beautiful n <-> gorgeous n] for all [n].  Just for
    fun, write your proof as an explicit proof object, rather than
    using tactics. (_Hint_: if you make use of previously defined
    theorems, you should only need a single line!) *)

Definition beautiful_iff_gorgeous :
  forall n, beautiful n <-> gorgeous n :=
  (* FILL IN HERE *) admit.
(** [] *)

(** **** Exercise: 2 stars, optional (or_commut'') *)
(** Try to write down an explicit proof object for [or_commut] (without
    using [Print] to peek at the ones we already defined!). *)

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

(** Recall that we model an existential for a property as a pair consisting of
a witness value and a proof that the witness obeys that property.
We can choose to construct the proof explicitly.

For example, consider this existentially quantified proposition: *)
Check ex.

Definition some_nat_is_even : Prop :=
  ex _ ev.

(** To prove this proposition, we need to choose a particular number
    as witness -- say, 4 -- and give some evidence that that number is
    even. *)

Definition snie : some_nat_is_even :=
  ex_intro _ ev 4 (ev_SS 2 (ev_SS 0 ev_0)).

(** **** Exercise: 2 stars, optional (ex_beautiful_Sn) *)
(** Complete the definition of the following proof object: *)

Definition p : ex _ (fun n => beautiful (S n)) :=
(* FILL IN HERE *) admit.
(** [] *)

(* ##################################################### *)
(** ** Giving Explicit Arguments to Lemmas and Hypotheses *)

(** Even when we are using tactic-based proof, it can be very useful to
understand the underlying functional nature of implications and quantification.

For example, it is often convenient to [apply] or [rewrite]
using a lemma or hypothesis with one or more quantifiers or
assumptions already instantiated in order to direct what
happens.  For example: *)

Check plus_comm.
(* ==>
    plus_comm
     : forall n m : nat, n + m = m + n *)

Lemma plus_comm_r : forall a b c, c + (b + a) = c + (a + b).
Proof.
   intros a b c.
   (* rewrite plus_comm. *)
      (* rewrites in the first possible spot; not what we want *)
   rewrite (plus_comm b a).  (* directs rewriting to the right spot *)
   reflexivity.  Qed.

(** In this case, giving just one argument would be sufficient. *)

Lemma plus_comm_r' : forall a b c, c + (b + a) = c + (a + b).
Proof.
   intros a b c.
   rewrite (plus_comm b).
   reflexivity.  Qed.

(** Arguments must be given in order, but wildcards (_)
may be used to skip arguments that Coq can infer.  *)

Lemma plus_comm_r'' : forall a b c, c + (b + a) = c + (a + b).
Proof.
  intros a b c.
  rewrite (plus_comm _ a).
  reflexivity. Qed.

(** The author of a lemma can choose to declare easily inferable arguments
to be implicit, just as with functions and constructors.

  The [with] clauses we've already seen is really just a way of
  specifying selected arguments by name rather than position:  *)

Lemma plus_comm_r''' : forall a b c, c + (b + a) = c + (a + b).
Proof.
  intros a b c.
  rewrite plus_comm with (n := b).
  reflexivity. Qed.

(** **** Exercise: 2 stars (trans_eq_example_redux) *)
(** Redo the proof of the following theorem (from MoreCoq.v) using
an [apply] of [trans_eq] but _not_ using a [with] clause. *)

Example trans_eq_example' : forall (a b c d e f : nat),
     [a;b] = [c;d] ->
     [c;d] = [e;f] ->
     [a;b] = [e;f].
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ##################################################### *)
(** ** Programming with Tactics (Optional) *)

(** If we can build proofs with explicit terms rather than
tactics, you may be wondering if we can build programs using
tactics rather than explicit terms.  Sure! *)

Definition add1 : nat -> nat.
intro n.
Show Proof.
apply S.
Show Proof.
apply n. Defined.

Print add1.
(* ==>
    add1 = fun n : nat => S n
         : nat -> nat
*)

Eval compute in add1 2.
(* ==> 3 : nat *)

(** Notice that we terminate the [Definition] with a [.] rather than with
[:=] followed by a term.  This tells Coq to enter proof scripting mode
to build an object of type [nat -> nat].  Also, we terminate the proof
with [Defined] rather than [Qed]; this makes the definition _transparent_
so that it can be used in computation like a normally-defined function.

This feature is mainly useful for writing functions with dependent types,
which we won't explore much further in this book.
But it does illustrate the uniformity and orthogonality of the basic ideas in Coq. *)

(* $Date: 2014-06-05 07:22:21 -0400 (Thu, 05 Jun 2014) $ *)