(* Copyright (c) 2008-2012, 2015, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* begin hide *)
Require Import List.

Require Import Cpdt.CpdtTactics Cpdt.MoreSpecif.

Set Implicit Arguments.
Set Asymmetric Patterns.
(* end hide *)

(** %\chapter{Proof by Reflection}% *)

(** The last chapter highlighted a very heuristic approach to proving.  In this chapter, we will study an alternative technique,%\index{proof by reflection}% _proof by reflection_ %\cite{reflection}%.  We will write, in Gallina, decision procedures with proofs of correctness, and we will appeal to these procedures in writing very short proofs.  Such a proof is checked by running the decision procedure.  The term _reflection_ applies because we will need to translate Gallina propositions into values of inductive types representing syntax, so that Gallina programs may analyze them, and translating such a term back to the original form is called _reflecting_ it. *)

(** * Proving Evenness *)

(** Proving that particular natural number constants are even is certainly something we would rather have happen automatically.  The Ltac-programming techniques that we learned in the last chapter make it easy to implement such a procedure. *)

Inductive isEven : nat -> Prop :=
| Even_O : isEven O
| Even_SS : forall n, isEven n -> isEven (S (S n)).

(* begin thide *)
Ltac prove_even := repeat constructor.
(* end thide *)

Theorem even_256 : isEven 256.
  prove_even.
Qed.

Print even_256.
(** %\vspace{-.15in}% [[
even_256 =
Even_SS
  (Even_SS
     (Even_SS
        (Even_SS
    ]]

    %\noindent%...and so on.  This procedure always works (at least on machines with infinite resources), but it has a serious drawback, which we see when we print the proof it generates that 256 is even.  The final proof term has length super-linear in the input value.  Coq's implicit arguments mechanism is hiding the values given for parameter [n] of [Even_SS], which is why the proof term only appears linear here.  Also, proof terms are represented internally as syntax trees, with opportunity for sharing of node representations, but in this chapter we will measure proof term size as simple textual length or as the number of nodes in the term's syntax tree, two measures that are approximately equivalent.  Sometimes apparently large proof terms have enough internal sharing that they take up less memory than we expect, but one avoids having to reason about such sharing by ensuring that the size of a sharing-free version of a term is low enough.

    Superlinear evenness proof terms seem like a shame, since we could write a trivial and trustworthy program to verify evenness of constants.  The proof checker could simply call our program where needed.

    It is also unfortunate not to have static typing guarantees that our tactic always behaves appropriately.  Other invocations of similar tactics might fail with dynamic type errors, and we would not know about the bugs behind these errors until we happened to attempt to prove complex enough goals.

    The techniques of proof by reflection address both complaints.  We will be able to write proofs like in the example above with constant size overhead beyond the size of the input, and we will do it with verified decision procedures written in Gallina.

    For this example, we begin by using a type from the [MoreSpecif] module (included in the book source) to write a certified evenness checker. *)

(* begin hide *)
(* begin thide *)
Definition paartial := partial.
(* end thide *)
(* end hide *)

Print partial.
(** %\vspace{-.15in}% [[
Inductive partial (P : Prop) : Set :=  Proved : P -> [P] | Uncertain : [P]
    ]]

    A [partial P] value is an optional proof of [P]. The notation [[P]] stands for [partial P]. *)

Local Open Scope partial_scope.

(** We bring into scope some notations for the [partial] type.  These overlap with some of the notations we have seen previously for specification types, so they were placed in a separate scope that needs separate opening. *)

(* begin thide *)
Definition check_even : forall n : nat, [isEven n].
  Hint Constructors isEven.

  refine (fix F (n : nat) : [isEven n] :=
    match n with
      | 0 => Yes
      | 1 => No
      | S (S n') => Reduce (F n')
    end); auto.
Defined.

(** The function [check_even] may be viewed as a _verified decision procedure_, because its type guarantees that it never returns %\coqdocnotation{%#<tt>#Yes#</tt>#%}% for inputs that are not even.

   Now we can use dependent pattern-matching to write a function that performs a surprising feat.  When given a [partial P], this function [partialOut] returns a proof of [P] if the [partial] value contains a proof, and it returns a (useless) proof of [True] otherwise.  From the standpoint of ML and Haskell programming, it seems impossible to write such a type, but it is trivial with a [return] annotation. *)

Definition partialOut (P : Prop) (x : [P]) :=
  match x return (match x with
                    | Proved _ => P
                    | Uncertain => True
                  end) with
    | Proved pf => pf
    | Uncertain => I
  end.

(** It may seem strange to define a function like this.  However, it turns out to be very useful in writing a reflective version of our earlier [prove_even] tactic: *)

Ltac prove_even_reflective :=
  match goal with
    | [ |- isEven ?N] => exact (partialOut (check_even N))
  end.
(* end thide *)

(** We identify which natural number we are considering, and we "prove" its evenness by pulling the proof out of the appropriate [check_even] call.  Recall that the %\index{tactics!exact}%[exact] tactic proves a proposition [P] when given a proof term of precisely type [P]. *)

Theorem even_256' : isEven 256.
  prove_even_reflective.
Qed.

Print even_256'.
(** %\vspace{-.15in}% [[
even_256' = partialOut (check_even 256)
     : isEven 256
    ]]

    We can see a constant wrapper around the object of the proof.  For any even number, this form of proof will suffice.  The size of the proof term is now linear in the number being checked, containing two repetitions of the unary form of that number, one of which is hidden above within the implicit argument to [partialOut].

    What happens if we try the tactic with an odd number? *)

Theorem even_255 : isEven 255.
  (** %\vspace{-.275in}%[[
  prove_even_reflective.
]]

<<
User error: No matching clauses for match goal
>>

  Thankfully, the tactic fails.  To see more precisely what goes wrong, we can run manually the body of the [match].

  %\vspace{-.15in}%[[
  exact (partialOut (check_even 255)).
]]

<<
  Error: The term "partialOut (check_even 255)" has type
 "match check_even 255 with
  | Yes => isEven 255
  | No => True
  end" while it is expected to have type "isEven 255"
>>

  As usual, the type checker performs no reductions to simplify error messages.  If we reduced the first term ourselves, we would see that [check_even 255] reduces to a %\coqdocnotation{%#<tt>#No#</tt>#%}%, so that the first term is equivalent to [True], which certainly does not unify with [isEven 255]. *)

Abort.

(** Our tactic [prove_even_reflective] is reflective because it performs a proof search process (a trivial one, in this case) wholly within Gallina, where the only use of Ltac is to translate a goal into an appropriate use of [check_even]. *)

(** * Reifying the Syntax of a Trivial Tautology Language *)

(** We might also like to have reflective proofs of trivial tautologies like this one: *)

Theorem true_galore : (True /\ True) -> (True \/ (True /\ (True -> True))).
  tauto.
Qed.

(* begin hide *)
(* begin thide *)
Definition tg := (and_ind, or_introl).
(* end thide *)
(* end hide *)

Print true_galore.
(** %\vspace{-.15in}% [[
true_galore =
fun H : True /\ True =>
and_ind (fun _ _ : True => or_introl (True /\ (True -> True)) I) H
     : True /\ True -> True \/ True /\ (True -> True)
    ]]

    As we might expect, the proof that [tauto] builds contains explicit applications of natural deduction rules.  For large formulas, this can add a linear amount of proof size overhead, beyond the size of the input.

   To write a reflective procedure for this class of goals, we will need to get into the actual "reflection" part of "proof by reflection."  It is impossible to case-analyze a [Prop] in any way in Gallina.  We must%\index{reification}% _reify_ [Prop] into some type that we _can_ analyze.  This inductive type is a good candidate: *)

(* begin thide *)
Inductive taut : Set :=
| TautTrue : taut
| TautAnd : taut -> taut -> taut
| TautOr : taut -> taut -> taut
| TautImp : taut -> taut -> taut.

(** We write a recursive function to _reflect_ this syntax back to [Prop].  Such functions are also called%\index{interpretation function}% _interpretation functions_, and we have used them in previous examples to give semantics to small programming languages. *)

Fixpoint tautDenote (t : taut) : Prop :=
  match t with
    | TautTrue => True
    | TautAnd t1 t2 => tautDenote t1 /\ tautDenote t2
    | TautOr t1 t2 => tautDenote t1 \/ tautDenote t2
    | TautImp t1 t2 => tautDenote t1 -> tautDenote t2
  end.

(** It is easy to prove that every formula in the range of [tautDenote] is true. *)

Theorem tautTrue : forall t, tautDenote t.
  induction t; crush.
Qed.

(** To use [tautTrue] to prove particular formulas, we need to implement the syntax reification process.  A recursive Ltac function does the job. *)

Ltac tautReify P :=
  match P with
    | True => TautTrue
    | ?P1 /\ ?P2 =>
      let t1 := tautReify P1 in
      let t2 := tautReify P2 in
        constr:(TautAnd t1 t2)
    | ?P1 \/ ?P2 =>
      let t1 := tautReify P1 in
      let t2 := tautReify P2 in
        constr:(TautOr t1 t2)
    | ?P1 -> ?P2 =>
      let t1 := tautReify P1 in
      let t2 := tautReify P2 in
        constr:(TautImp t1 t2)
  end.

(** With [tautReify] available, it is easy to finish our reflective tactic.  We look at the goal formula, reify it, and apply [tautTrue] to the reified formula. *)

Ltac obvious :=
  match goal with
    | [ |- ?P ] =>
      let t := tautReify P in
        exact (tautTrue t)
  end.

(** We can verify that [obvious] solves our original example, with a proof term that does not mention details of the proof. *)
(* end thide *)

Theorem true_galore' : (True /\ True) -> (True \/ (True /\ (True -> True))).
  obvious.
Qed.

Print true_galore'.
(** %\vspace{-.15in}% [[
true_galore' =
tautTrue
  (TautImp (TautAnd TautTrue TautTrue)
     (TautOr TautTrue (TautAnd TautTrue (TautImp TautTrue TautTrue))))
     : True /\ True -> True \/ True /\ (True -> True)
    ]]

    It is worth considering how the reflective tactic improves on a pure-Ltac implementation.  The formula reification process is just as ad-hoc as before, so we gain little there.  In general, proofs will be more complicated than formula translation, and the "generic proof rule" that we apply here _is_ on much better formal footing than a recursive Ltac function.  The dependent type of the proof guarantees that it "works" on any input formula.  This benefit is in addition to the proof-size improvement that we have already seen.

    It may also be worth pointing out that our previous example of evenness testing used a function [partialOut] for sound handling of input goals that the verified decision procedure fails to prove.  Here, we prove that our procedure [tautTrue] (recall that an inductive proof may be viewed as a recursive procedure) is able to prove any goal representable in [taut], so no extra step is necessary. *)

(** * A Monoid Expression Simplifier *)

(** Proof by reflection does not require encoding of all of the syntax in a goal.  We can insert "variables" in our syntax types to allow injection of arbitrary pieces, even if we cannot apply specialized reasoning to them.  In this section, we explore that possibility by writing a tactic for normalizing monoid equations. *)

Section monoid.
  Variable A : Set.
  Variable e : A.
  Variable f : A -> A -> A.

  Infix "+" := f.

  Hypothesis assoc : forall a b c, (a + b) + c = a + (b + c).
  Hypothesis identl : forall a, e + a = a.
  Hypothesis identr : forall a, a + e = a.

  (** We add variables and hypotheses characterizing an arbitrary instance of the algebraic structure of monoids.  We have an associative binary operator and an identity element for it.

     It is easy to define an expression tree type for monoid expressions.  A [Var] constructor is a "catch-all" case for subexpressions that we cannot model.  These subexpressions could be actual Gallina variables, or they could just use functions that our tactic is unable to understand. *)

(* begin thide *)
  Inductive mexp : Set :=
  | Ident : mexp
  | Var : A -> mexp
  | Op : mexp -> mexp -> mexp.

  (** Next, we write an interpretation function. *)

  Fixpoint mdenote (me : mexp) : A :=
    match me with
      | Ident => e
      | Var v => v
      | Op me1 me2 => mdenote me1 + mdenote me2
    end.

  (** We will normalize expressions by flattening them into lists, via associativity, so it is helpful to have a denotation function for lists of monoid values. *)

  Fixpoint mldenote (ls : list A) : A :=
    match ls with
      | nil => e
      | x :: ls' => x + mldenote ls'
    end.

  (** The flattening function itself is easy to implement. *)

  Fixpoint flatten (me : mexp) : list A :=
    match me with
      | Ident => nil
      | Var x => x :: nil
      | Op me1 me2 => flatten me1 ++ flatten me2
    end.

  (** This function has a straightforward correctness proof in terms of our [denote] functions. *)

  Lemma flatten_correct' : forall ml2 ml1,
    mldenote ml1 + mldenote ml2 = mldenote (ml1 ++ ml2).
    induction ml1; crush.
  Qed.

  Theorem flatten_correct : forall me, mdenote me = mldenote (flatten me).
    Hint Resolve flatten_correct'.

    induction me; crush.
  Qed.

  (** Now it is easy to prove a theorem that will be the main tool behind our simplification tactic. *)

  Theorem monoid_reflect : forall me1 me2,
    mldenote (flatten me1) = mldenote (flatten me2)
    -> mdenote me1 = mdenote me2.
    intros; repeat rewrite flatten_correct; assumption.
  Qed.

  (** We implement reification into the [mexp] type. *)

  Ltac reify me :=
    match me with
      | e => Ident
      | ?me1 + ?me2 =>
        let r1 := reify me1 in
        let r2 := reify me2 in
          constr:(Op r1 r2)
      | _ => constr:(Var me)
    end.

  (** The final [monoid] tactic works on goals that equate two monoid terms.  We reify each and change the goal to refer to the reified versions, finishing off by applying [monoid_reflect] and simplifying uses of [mldenote].  Recall that the %\index{tactics!change}%[change] tactic replaces a conclusion formula with another that is definitionally equal to it. *)

  Ltac monoid :=
    match goal with
      | [ |- ?me1 = ?me2 ] =>
        let r1 := reify me1 in
        let r2 := reify me2 in
          change (mdenote r1 = mdenote r2);
            apply monoid_reflect; simpl
    end.

  (** We can make short work of theorems like this one: *)

(* end thide *)

  Theorem t1 : forall a b c d, a + b + c + d = a + (b + c) + d.
    intros; monoid.
    (** [[
  ============================
   a + (b + (c + (d + e))) = a + (b + (c + (d + e)))

        ]]

        Our tactic has canonicalized both sides of the equality, such that we can finish the proof by reflexivity. *)

    reflexivity.
  Qed.

  (** It is interesting to look at the form of the proof. *)

  Print t1.
  (** %\vspace{-.15in}% [[
t1 =
fun a b c d : A =>
monoid_reflect (Op (Op (Op (Var a) (Var b)) (Var c)) (Var d))
  (Op (Op (Var a) (Op (Var b) (Var c))) (Var d))
  (eq_refl (a + (b + (c + (d + e)))))
     : forall a b c d : A, a + b + c + d = a + (b + c) + d
      ]]

      The proof term contains only restatements of the equality operands in reified form, followed by a use of reflexivity on the shared canonical form. *)

End monoid.

(** Extensions of this basic approach are used in the implementations of the %\index{tactics!ring}%[ring] and %\index{tactics!field}%[field] tactics that come packaged with Coq. *)

(** * A Smarter Tautology Solver *)

(** Now we are ready to revisit our earlier tautology solver example.  We want to broaden the scope of the tactic to include formulas whose truth is not syntactically apparent.  We will want to allow injection of arbitrary formulas, like we allowed arbitrary monoid expressions in the last example.  Since we are working in a richer theory, it is important to be able to use equalities between different injected formulas.  For instance, we cannot prove [P -> P] by translating the formula into a value like [Imp (Var P) (Var P)], because a Gallina function has no way of comparing the two [P]s for equality.

   To arrive at a nice implementation satisfying these criteria, we introduce the %\index{tactics!quote}%[quote] tactic and its associated library. *)

Require Import Quote.

(* begin thide *)
Inductive formula : Set :=
| Atomic : index -> formula
| Truth : formula
| Falsehood : formula
| And : formula -> formula -> formula
| Or : formula -> formula -> formula
| Imp : formula -> formula -> formula.
(* end thide *)

(** The type %\index{Gallina terms!index}%[index] comes from the [Quote] library and represents a countable variable type.  The rest of [formula]'s definition should be old hat by now.

   The [quote] tactic will implement injection from [Prop] into [formula] for us, but it is not quite as smart as we might like.  In particular, it wants to treat function types specially, so it gets confused if function types are part of the structure we want to encode syntactically.  To trick [quote] into not noticing our uses of function types to express logical implication, we will need to declare a wrapper definition for implication, as we did in the last chapter. *)

Definition imp (P1 P2 : Prop) := P1 -> P2.
Infix "-->" := imp (no associativity, at level 95).

(** Now we can define our denotation function. *)

Definition asgn := varmap Prop.

(* begin thide *)
Fixpoint formulaDenote (atomics : asgn) (f : formula) : Prop :=
  match f with
    | Atomic v => varmap_find False v atomics
    | Truth => True
    | Falsehood => False
    | And f1 f2 => formulaDenote atomics f1 /\ formulaDenote atomics f2
    | Or f1 f2 => formulaDenote atomics f1 \/ formulaDenote atomics f2
    | Imp f1 f2 => formulaDenote atomics f1 --> formulaDenote atomics f2
  end.
(* end thide *)

(** The %\index{Gallina terms!varmap}%[varmap] type family implements maps from [index] values.  In this case, we define an assignment as a map from variables to [Prop]s.  Our interpretation function [formulaDenote] works with an assignment, and we use the [varmap_find] function to consult the assignment in the [Atomic] case.  The first argument to [varmap_find] is a default value, in case the variable is not found. *)

Section my_tauto.
  Variable atomics : asgn.

  Definition holds (v : index) := varmap_find False v atomics.

  (** We define some shorthand for a particular variable being true, and now we are ready to define some helpful functions based on the [ListSet] module of the standard library, which (unsurprisingly) presents a view of lists as sets. *)

  Require Import ListSet.

  Definition index_eq : forall x y : index, {x = y} + {x <> y}.
    decide equality.
  Defined.

  Definition add (s : set index) (v : index) := set_add index_eq v s.

  Definition In_dec : forall v (s : set index), {In v s} + {~ In v s}.
    Local Open Scope specif_scope.

    intro; refine (fix F (s : set index) : {In v s} + {~ In v s} :=
      match s with
        | nil => No
        | v' :: s' => index_eq v' v || F s'
      end); crush.
  Defined.

  (** We define what it means for all members of an index set to represent true propositions, and we prove some lemmas about this notion. *)

  Fixpoint allTrue (s : set index) : Prop :=
    match s with
      | nil => True
      | v :: s' => holds v /\ allTrue s'
    end.

  Theorem allTrue_add : forall v s,
    allTrue s
    -> holds v
    -> allTrue (add s v).
    induction s; crush;
      match goal with
        | [ |- context[if ?E then _ else _] ] => destruct E
      end; crush.
  Qed.

  Theorem allTrue_In : forall v s,
    allTrue s
    -> set_In v s
    -> varmap_find False v atomics.
    induction s; crush.
  Qed.

  Hint Resolve allTrue_add allTrue_In.

  Local Open Scope partial_scope.

  (** Now we can write a function [forward] that implements deconstruction of hypotheses, expanding a compound formula into a set of sets of atomic formulas covering all possible cases introduced with use of [Or].  To handle consideration of multiple cases, the function takes in a continuation argument, which will be called once for each case.

     The [forward] function has a dependent type, in the style of Chapter 6, guaranteeing correctness.  The arguments to [forward] are a goal formula [f], a set [known] of atomic formulas that we may assume are true, a hypothesis formula [hyp], and a success continuation [cont] that we call when we have extended [known] to hold new truths implied by [hyp]. *)

  Definition forward : forall (f : formula) (known : set index) (hyp : formula)
    (cont : forall known', [allTrue known' -> formulaDenote atomics f]),
    [allTrue known -> formulaDenote atomics hyp -> formulaDenote atomics f].
    refine (fix F (f : formula) (known : set index) (hyp : formula)
      (cont : forall known', [allTrue known' -> formulaDenote atomics f])
      : [allTrue known -> formulaDenote atomics hyp -> formulaDenote atomics f] :=
      match hyp with
        | Atomic v => Reduce (cont (add known v))
        | Truth => Reduce (cont known)
        | Falsehood => Yes
        | And h1 h2 =>
          Reduce (F (Imp h2 f) known h1 (fun known' =>
            Reduce (F f known' h2 cont)))
        | Or h1 h2 => F f known h1 cont && F f known h2 cont
        | Imp _ _ => Reduce (cont known)
      end); crush.
  Defined.

  (** A [backward] function implements analysis of the final goal.  It calls [forward] to handle implications. *)

(* begin thide *)
  Definition backward : forall (known : set index) (f : formula),
    [allTrue known -> formulaDenote atomics f].
    refine (fix F (known : set index) (f : formula)
      : [allTrue known -> formulaDenote atomics f] :=
      match f with
        | Atomic v => Reduce (In_dec v known)
        | Truth => Yes
        | Falsehood => No
        | And f1 f2 => F known f1 && F known f2
        | Or f1 f2 => F known f1 || F known f2
        | Imp f1 f2 => forward f2 known f1 (fun known' => F known' f2)
      end); crush; eauto.
  Defined.
(* end thide *)

  (** A simple wrapper around [backward] gives us the usual type of a partial decision procedure. *)

  Definition my_tauto : forall f : formula, [formulaDenote atomics f].
(* begin thide *)
    intro; refine (Reduce (backward nil f)); crush.
  Defined.
(* end thide *)
End my_tauto.

(** Our final tactic implementation is now fairly straightforward.  First, we [intro] all quantifiers that do not bind [Prop]s.  Then we call the [quote] tactic, which implements the reification for us.  Finally, we are able to construct an exact proof via [partialOut] and the [my_tauto] Gallina function. *)

Ltac my_tauto :=
  repeat match goal with
           | [ |- forall x : ?P, _ ] =>
             match type of P with
               | Prop => fail 1
               | _ => intro
             end
         end;
  quote formulaDenote;
  match goal with
    | [ |- formulaDenote ?m ?f ] => exact (partialOut (my_tauto m f))
  end.
(* end thide *)

(** A few examples demonstrate how the tactic works. *)

Theorem mt1 : True.
  my_tauto.
Qed.

Print mt1.
(** %\vspace{-.15in}% [[
mt1 = partialOut (my_tauto (Empty_vm Prop) Truth)
     : True
    ]]

    We see [my_tauto] applied with an empty [varmap], since every subformula is handled by [formulaDenote]. *)

Theorem mt2 : forall x y : nat, x = y --> x = y.
  my_tauto.
Qed.

(* begin hide *)
(* begin thide *)
Definition nvm := (Node_vm, Empty_vm, End_idx, Left_idx, Right_idx).
(* end thide *)
(* end hide *)

Print mt2.
(** %\vspace{-.15in}% [[
mt2 =
fun x y : nat =>
partialOut
  (my_tauto (Node_vm (x = y) (Empty_vm Prop) (Empty_vm Prop))
     (Imp (Atomic End_idx) (Atomic End_idx)))
     : forall x y : nat, x = y --> x = y
    ]]

    Crucially, both instances of [x = y] are represented with the same index, [End_idx].  The value of this index only needs to appear once in the [varmap], whose form reveals that [varmap]s are represented as binary trees, where [index] values denote paths from tree roots to leaves. *)

Theorem mt3 : forall x y z,
  (x < y /\ y > z) \/ (y > z /\ x < S y)
  --> y > z /\ (x < y \/ x < S y).
  my_tauto.
Qed.

Print mt3.
(** %\vspace{-.15in}% [[
fun x y z : nat =>
partialOut
  (my_tauto
     (Node_vm (x < S y) (Node_vm (x < y) (Empty_vm Prop) (Empty_vm Prop))
        (Node_vm (y > z) (Empty_vm Prop) (Empty_vm Prop)))
     (Imp
        (Or (And (Atomic (Left_idx End_idx)) (Atomic (Right_idx End_idx)))
           (And (Atomic (Right_idx End_idx)) (Atomic End_idx)))
        (And (Atomic (Right_idx End_idx))
           (Or (Atomic (Left_idx End_idx)) (Atomic End_idx)))))
     : forall x y z : nat,
       x < y /\ y > z \/ y > z /\ x < S y --> y > z /\ (x < y \/ x < S y)
    ]]

    Our goal contained three distinct atomic formulas, and we see that a three-element [varmap] is generated.

    It can be interesting to observe differences between the level of repetition in proof terms generated by [my_tauto] and [tauto] for especially trivial theorems. *)

Theorem mt4 : True /\ True /\ True /\ True /\ True /\ True /\ False --> False.
  my_tauto.
Qed.

Print mt4.
(** %\vspace{-.15in}% [[
mt4 =
partialOut
  (my_tauto (Empty_vm Prop)
     (Imp
        (And Truth
           (And Truth
              (And Truth (And Truth (And Truth (And Truth Falsehood))))))
        Falsehood))
     : True /\ True /\ True /\ True /\ True /\ True /\ False --> False
    ]]
    *)

Theorem mt4' : True /\ True /\ True /\ True /\ True /\ True /\ False -> False.
  tauto.
Qed.

(* begin hide *)
(* begin thide *)
Definition fi := False_ind.
(* end thide *)
(* end hide *)

Print mt4'.
(** %\vspace{-.15in}% [[
mt4' =
fun H : True /\ True /\ True /\ True /\ True /\ True /\ False =>
and_ind
  (fun (_ : True) (H1 : True /\ True /\ True /\ True /\ True /\ False) =>
   and_ind
     (fun (_ : True) (H3 : True /\ True /\ True /\ True /\ False) =>
      and_ind
        (fun (_ : True) (H5 : True /\ True /\ True /\ False) =>
         and_ind
           (fun (_ : True) (H7 : True /\ True /\ False) =>
            and_ind
              (fun (_ : True) (H9 : True /\ False) =>
               and_ind (fun (_ : True) (H11 : False) => False_ind False H11)
                 H9) H7) H5) H3) H1) H
     : True /\ True /\ True /\ True /\ True /\ True /\ False -> False
    ]]

The traditional [tauto] tactic introduces a quadratic blow-up in the size of the proof term, whereas proofs produced by [my_tauto] always have linear size. *)

(** ** Manual Reification of Terms with Variables *)

(* begin thide *)
(** The action of the [quote] tactic above may seem like magic.  Somehow it performs equality comparison between subterms of arbitrary types, so that these subterms may be represented with the same reified variable.  While [quote] is implemented in OCaml, we can code the reification process completely in Ltac, as well.  To make our job simpler, we will represent variables as [nat]s, indexing into a simple list of variable values that may be referenced.

   Step one of the process is to crawl over a term, building a duplicate-free list of all values that appear in positions we will encode as variables.  A useful helper function adds an element to a list, preventing duplicates.  Note how we use Ltac pattern matching to implement an equality test on Gallina terms; this is simple syntactic equality, not even the richer definitional equality.  We also represent lists as nested tuples, to allow different list elements to have different Gallina types. *)

Ltac inList x xs :=
  match xs with
    | tt => false
    | (x, _) => true
    | (_, ?xs') => inList x xs'
  end.

Ltac addToList x xs :=
  let b := inList x xs in
    match b with
      | true => xs
      | false => constr:(x, xs)
    end.

(** Now we can write our recursive function to calculate the list of variable values we will want to use to represent a term. *)

Ltac allVars xs e :=
  match e with
    | True => xs
    | False => xs
    | ?e1 /\ ?e2 =>
      let xs := allVars xs e1 in
        allVars xs e2
    | ?e1 \/ ?e2 =>
      let xs := allVars xs e1 in
        allVars xs e2
    | ?e1 -> ?e2 =>
      let xs := allVars xs e1 in
        allVars xs e2
    | _ => addToList e xs
  end.

(** We will also need a way to map a value to its position in a list. *)

Ltac lookup x xs :=
  match xs with
    | (x, _) => O
    | (_, ?xs') =>
      let n := lookup x xs' in
        constr:(S n)
  end.

(** The next building block is a procedure for reifying a term, given a list of all allowed variable values.  We are free to make this procedure partial, where tactic failure may be triggered upon attempting to reify a term containing subterms not included in the list of variables.  The type of the output term is a copy of [formula] where [index] is replaced by [nat], in the type of the constructor for atomic formulas. *)

Inductive formula' : Set :=
| Atomic' : nat -> formula'
| Truth' : formula'
| Falsehood' : formula'
| And' : formula' -> formula' -> formula'
| Or' : formula' -> formula' -> formula'
| Imp' : formula' -> formula' -> formula'.

(** Note that, when we write our own Ltac procedure, we can work directly with the normal [->] operator, rather than needing to introduce a wrapper for it. *)

Ltac reifyTerm xs e :=
  match e with
    | True => constr:Truth'
    | False => constr:Falsehood'
    | ?e1 /\ ?e2 =>
      let p1 := reifyTerm xs e1 in
      let p2 := reifyTerm xs e2 in
        constr:(And' p1 p2)
    | ?e1 \/ ?e2 =>
      let p1 := reifyTerm xs e1 in
      let p2 := reifyTerm xs e2 in
        constr:(Or' p1 p2)
    | ?e1 -> ?e2 =>
      let p1 := reifyTerm xs e1 in
      let p2 := reifyTerm xs e2 in
        constr:(Imp' p1 p2)
    | _ =>
      let n := lookup e xs in
        constr:(Atomic' n)
  end.

(** Finally, we bring all the pieces together. *)

Ltac reify :=
  match goal with
    | [ |- ?G ] => let xs := allVars tt G in
      let p := reifyTerm xs G in
        pose p
  end.

(** A quick test verifies that we are doing reification correctly. *)

Theorem mt3' : forall x y z,
  (x < y /\ y > z) \/ (y > z /\ x < S y)
  -> y > z /\ (x < y \/ x < S y).
  do 3 intro; reify.

(** Our simple tactic adds the translated term as a new variable:
[[
f := Imp'
         (Or' (And' (Atomic' 2) (Atomic' 1)) (And' (Atomic' 1) (Atomic' 0)))
         (And' (Atomic' 1) (Or' (Atomic' 2) (Atomic' 0))) : formula'
]]
*)
Abort.

(** More work would be needed to complete the reflective tactic, as we must connect our new syntax type with the real meanings of formulas, but the details are the same as in our prior implementation with [quote]. *)
(* end thide *)

(** * Building a Reification Tactic that Recurses Under Binders *)

(** All of our examples so far have stayed away from reifying the syntax of terms that use such features as quantifiers and [fun] function abstractions.  Such cases are complicated by the fact that different subterms may be allowed to reference different sets of free variables.  Some cleverness is needed to clear this hurdle, but a few simple patterns will suffice.  Consider this example of a simple dependently typed term language, where a function abstraction body is represented conveniently with a Coq function. *)

Inductive type : Type :=
| Nat : type
| NatFunc : type -> type.

Inductive term : type -> Type :=
| Const : nat -> term Nat
| Plus : term Nat -> term Nat -> term Nat
| Abs : forall t, (nat -> term t) -> term (NatFunc t).

Fixpoint typeDenote (t : type) : Type :=
  match t with
    | Nat => nat
    | NatFunc t => nat -> typeDenote t
  end.

Fixpoint termDenote t (e : term t) : typeDenote t :=
  match e with
    | Const n => n
    | Plus e1 e2 => termDenote e1 + termDenote e2
    | Abs _ e1 => fun x => termDenote (e1 x)
  end.

(** Here is a %\%naive%{}% first attempt at a reification tactic. *)

(* begin hide *)
Definition red_herring := O.
(* end hide *)
Ltac refl' e :=
  match e with
    | ?E1 + ?E2 =>
      let r1 := refl' E1 in
      let r2 := refl' E2 in
        constr:(Plus r1 r2)

    | fun x : nat => ?E1 =>
      let r1 := refl' E1 in
        constr:(Abs (fun x => r1 x))

    | _ => constr:(Const e)
  end.

(** Recall that a regular Ltac pattern variable [?X] only matches terms that _do not mention new variables introduced within the pattern_.  In our %\%naive%{}% implementation, the case for matching function abstractions matches the function body in a way that prevents it from mentioning the function argument!  Our code above plays fast and loose with the function body in a way that leads to independent problems, but we could change the code so that it indeed handles function abstractions that ignore their arguments.

   To handle functions in general, we will use the pattern variable form [@?X], which allows [X] to mention newly introduced variables that are declared explicitly.  A use of [@?X] must be followed by a list of the local variables that may be mentioned.  The variable [X] then comes to stand for a Gallina function over the values of those variables.  For instance: *)

Reset refl'.
(* begin hide *)
Reset red_herring.
Definition red_herring := O.
(* end hide *)
Ltac refl' e :=
  match e with
    | ?E1 + ?E2 =>
      let r1 := refl' E1 in
      let r2 := refl' E2 in
        constr:(Plus r1 r2)

    | fun x : nat => @?E1 x =>
      let r1 := refl' E1 in
        constr:(Abs r1)

    | _ => constr:(Const e)
  end.

(** Now, in the abstraction case, we bind [E1] as a function from an [x] value to the value of the abstraction body.  Unfortunately, our recursive call there is not destined for success.  It will match the same abstraction pattern and trigger another recursive call, and so on through infinite recursion.  One last refactoring yields a working procedure.  The key idea is to consider every input to [refl'] as _a function over the values of variables introduced during recursion_. *)

Reset refl'.
(* begin hide *)
Reset red_herring.
(* end hide *)
Ltac refl' e :=
  match eval simpl in e with
    | fun x : ?T => @?E1 x + @?E2 x =>
      let r1 := refl' E1 in
      let r2 := refl' E2 in
        constr:(fun x => Plus (r1 x) (r2 x))

    | fun (x : ?T) (y : nat) => @?E1 x y =>
      let r1 := refl' (fun p : T * nat => E1 (fst p) (snd p)) in
        constr:(fun u => Abs (fun v => r1 (u, v)))

    | _ => constr:(fun x => Const (e x))
  end.

(** Note how now even the addition case works in terms of functions, with [@?X] patterns.  The abstraction case introduces a new variable by extending the type used to represent the free variables.  In particular, the argument to [refl'] used type [T] to represent all free variables.  We extend the type to [T * nat] for the type representing free variable values within the abstraction body.  A bit of bookkeeping with pairs and their projections produces an appropriate version of the abstraction body to pass in a recursive call.  To ensure that all this repackaging of terms does not interfere with pattern matching, we add an extra [simpl] reduction on the function argument, in the first line of the body of [refl'].

   Now one more tactic provides an example of how to apply reification.  Let us consider goals that are equalities between terms that can be reified.  We want to change such goals into equalities between appropriate calls to [termDenote]. *)

Ltac refl :=
  match goal with
    | [ |- ?E1 = ?E2 ] =>
      let E1' := refl' (fun _ : unit => E1) in
      let E2' := refl' (fun _ : unit => E2) in
        change (termDenote (E1' tt) = termDenote (E2' tt));
          cbv beta iota delta [fst snd]
  end.

Goal (fun (x y : nat) => x + y + 13) = (fun (_ z : nat) => z).
  refl.
(** %\vspace{-.15in}%[[
  ============================
   termDenote
     (Abs
        (fun y : nat =>
         Abs (fun y0 : nat => Plus (Plus (Const y) (Const y0)) (Const 13)))) =
   termDenote (Abs (fun _ : nat => Abs (fun y0 : nat => Const y0)))
]]
*)

Abort.

(** Our encoding here uses Coq functions to represent binding within the terms we reify, which makes it difficult to implement certain functions over reified terms.  An alternative would be to represent variables with numbers.  This can be done by writing a slightly smarter reification function that identifies variable references by detecting when term arguments are just compositions of [fst] and [snd]; from the order of the compositions we may read off the variable number.  We leave the details as an exercise (though not a trivial one!) for the reader. *)


Definition name : Type := nat.

Inductive aexp : Type :=
  | ANum (n : nat)
  | AVar (x : name)
  | APlus (a a' : aexp).

Coercion ANum : nat >-> aexp.
Coercion AVar : name >-> aexp.
Notation "a1 +' a2" := (APlus a1 a2) (at level 50).

Definition W : name := 1.
Definition X : name := 2.
Definition Y : name := 3.
Definition Z : name := 4.

Definition state : Type := name -> nat.
Definition update (x : name)(n : nat)(s : state)
 : state := fun x' => if Nat.eqb x x' then n else s x'.
Definition empty : state := fun _ => 0.

Inductive fstep : aexp * state -> nat -> Prop :=
  | num (n : nat)(s : state) : fstep (ANum n , s) n
  | var (x : name)(s : state) : fstep (AVar x , s) (s x)
  | fplusr (n i : nat)(a2 : aexp)(s : state) :
           fstep (a2 , s) i ->
           fstep (n +' a2 , s) (n + i).
Inductive step : aexp * state -> aexp * state -> Prop :=
  | plusl (a1 a2 a1t : aexp)(s : state) :
          step (a1 , s) (a1t , s) ->
          step (a1 +' a2 , s) (a1t +' a2 , s)
  | fplusl (a1 a2 : aexp)(s : state)(i : nat) :
           fstep (a1 , s) i ->
           step (a1 +' a2 , s) (i +' a2 , s)
  | plusr (a2 a2t : aexp)(s : state)(n : nat) :
          step (a2 , s) (a2t , s) ->
          step (n +' a2 , s) (n +' a2t , s).

Notation "w f=> i" := (fstep w i) (at level 50).
Notation "w s=> w'" := (step w w') (at level 50).

Require Import Coq.Arith.Plus.

Lemma lem1 : (ANum 3 , empty) f=> 100 -> False.
intros.
inversion H. Qed.

Lemma lem2 : forall n s1 s2 i, (ANum n , s1) f=> i -> (ANum n , s2) f=> i.
intros.
inversion H.
apply num. Qed.

Fixpoint aeval (a : aexp)(s : state) : nat :=
  match a with
  | ANum n => n
  | AVar x => s x
  | APlus a1 a2 => aeval a1 s + aeval a2 s
  end.

Inductive bstep : aexp * state -> nat -> Prop :=
  | bnum (n : nat)(s : state) : bstep (ANum n , s) n
  | bvar (x : name)(s : state) : bstep (AVar x , s) (s x)
  | bsum (a1 a2 : aexp)(s : state)(n1 n2 : nat) :
      bstep (a1 , s) n1 -> bstep (a2 , s) n2 -> bstep (a1 +' a2 , s) (n1 + n2).

Notation "w ˇ i" := (bstep w i) (at level 50).

Lemma todenot : forall a s n, (a , s) ˇ n -> aeval a s = n.
intros.  induction a. simpl. inversion H. reflexivity.
simpl. inversion H. reflexivity. inversion H. rewrite -> (IHa1 a1 H4).

Lemma fromdenot : forall a s n, aeval a s = n -> (a , s) ˇ n.
Admitted.


Require Import Nat Util Get.

Notation "'list_max' L" := (fold_left max L 0) (at level 50).

Lemma list_max_swap L x
: max (list_max L) x = fold_left max L x.
Proof.
  general induction L; simpl; eauto.
  setoid_rewrite <- IHL; eauto.
  setoid_rewrite Max.max_comm at 4.
  rewrite Max.max_assoc; eauto.
Qed.

Lemma list_max_get L n x
: get L n x
  -> x <= list_max L.
Proof.
  intros. general induction L; eauto; invt get; simpl.
  - rewrite <- list_max_swap. eapply Max.le_max_r.
  - rewrite <- list_max_swap. rewrite <- Max.le_max_l; eauto.
Qed.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From VFA Require Import Perm.
Hint Constructors Permutation : core.
From Coq Require Export Lists.List.

Fixpoint select (x: nat) (l: list nat) : (nat * list nat) :=
  match l with
  | []      => (x, [])
  | h :: t  =>
    if x <=? h
    then let (j, l') := select x t in (j, h :: l')
    else let (j, l') := select h t in (j, x :: l')
  end.

Fail Fixpoint selsort (l : list nat) : list nat :=
  match l with
  | []      => []
  | x :: r  => let (y, r') := select x r in y :: selsort r'
  end.

Fixpoint selsort (l : list nat) (n : nat) : list nat :=
  match l, n with
  | _     , O     => [] (* ran out of fuel *)
  | []    , _     => []
  | x :: r, S n'  => let (y, r') := select x r in y :: selsort r' n'
end.

Definition selection_sort (l : list nat) : list nat := selsort l (length l).

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

Inductive sorted: list nat -> Prop :=
 | sorted_nil: sorted []
 | sorted_1: forall i, sorted [i]
 | sorted_cons: forall i j l, i <= j -> sorted (j :: l) -> sorted (i :: j :: l).
Hint Constructors sorted : core.

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

Example pairs_example : forall (a c x : nat) (b d l : list nat),
    (a, b) = (let (c, d) := select x l in (c, d)) ->
    (a, b) = select x l.
Proof.
  intros. destruct (select x l) eqn:E. auto.
Qed.

Ltac gen x := generalize dependent x.

Lemma select_perm: forall x l y r,
    (y, r) = select x l -> Permutation (x :: l) (y :: r).
Proof.
  intros x l. gen x.
  induction l; simpl; intros x y r H.
  - injection H as Hl Hr; subst.
    constructor.
    constructor.
  - bdestruct (a >=? x).
    + destruct (select x l) eqn:E.
      injection H as Hl Hr; subst.
      change (x :: a :: l) with ([x] ++ [a] ++ l).
      change (n :: a :: l0) with ([n] ++ [a] ++ l0).
      apply perm_trans with ([a] ++ [x] ++ l).
      * apply Permutation_app_swap_app.
      * apply perm_trans with ([a] ++ [n] ++ l0).
        ** simpl.
           apply perm_skip.
           apply IHl.
           symmetry.
           assumption.
        ** apply Permutation_app_swap_app.
    + destruct (select a l) eqn:E.
      injection H as Hl Hr; subst.
      change (n :: x :: l0) with ([n] ++ [x] ++ l0).
      apply perm_trans with ([x] ++ [n] ++ l0).
      * simpl.
        apply perm_skip.
        apply IHl.
        symmetry.
        assumption.
      * apply Permutation_app_swap_app.
Qed.

Lemma selsort_perm: forall n l,
    length l = n -> Permutation l (selsort l n).
Proof.
  intros n.
  induction n; intros l Hlen; simpl in Hlen.
  - simpl. destruct l.
      constructor.
      simpl in Hlen. discriminate.
  - unfold selsort.
    fold selsort.
    destruct l.
    + constructor.
    + destruct (select n0 l) eqn:E.
      symmetry in E.
      apply select_perm in E.
      apply perm_trans with (n1 :: l0).
      * assumption.
      * apply perm_skip.
        apply IHn.
        simpl in Hlen.
        Search Permutation.
        apply Permutation_length in E.
        simpl in E.
        lia.
Qed.

Lemma selection_sort_perm: forall l,
    Permutation l (selection_sort l).
Proof.
  intro l.
  unfold selection_sort.
  apply selsort_perm.
  reflexivity.
Qed.

Lemma select_rest_length : forall x l y r,
    select x l = (y, r) -> length l = length r.
Proof.
  intros.
  symmetry in H.
  apply select_perm in H.
  apply Permutation_length in H.
  simpl in H.
  lia.
Qed.

Lemma select_fst_leq: forall al bl x y,
    select x al = (y, bl) ->  y <= x.
Proof.
  intro al.
  induction al; simpl; intros bl x y Hsel.
  - injection Hsel as Exy.
    lia.
  - bdestruct (a >=? x).
    + destruct (select x al) eqn:E.
      injection Hsel as Hs1 Hs2.
      subst.
      apply IHal with l.
      assumption.
    + destruct (select a al) eqn:E.
      injection Hsel as Hs1 Hs2.
      subst.
      assert (G: y <= a). {
        apply IHal with l.
        assumption.
      }
      lia.
Qed.

Definition le_all x xs := Forall (fun y => x <= y) xs.

Infix "<=*" := le_all (at level 70, no associativity).

Lemma select_smallest: forall al bl x y,
    select x al = (y, bl) ->
    y <=* bl.
Proof.
  intro al.
  induction al; simpl; intros bl x y H.
  - injection H as Hl Hr.
    subst.
    unfold le_all.
    Search Forall.
    apply Forall_nil.
  - bdestruct (a >=? x).
    + destruct (select x al) eqn:E.
      injection H as Hl Hr.
      subst.
      assert (G1: y <=* l). {
        apply IHal with x.
        assumption.
      }
      assert (G2: y <= a). {
        apply select_fst_leq in E.
        lia.
      }
      apply Forall_cons.
      apply G2.
      apply G1.
    + destruct (select a al) eqn:E.
      injection H as Hl Hr.
      subst.
      assert (G1: y <=* l). {
        apply IHal with a.
        assumption.
      }
      assert (G2: y <= x). {
        apply select_fst_leq in E.
        lia.
      }
      apply Forall_cons.
      apply G2.
      apply G1.
Qed.

Lemma select_in : forall al bl x y,
    select x al = (y, bl) ->
    In y (x :: al).
Proof.
  intro al.
  induction al; simpl; intros bl x y H.
  - injection H as Hl Hr. left. assumption.
  - bdestruct (a >=? x).
    + destruct (select x al) eqn:E.
      injection H as Hl Hr.
      subst.
      apply IHal in E.
      destruct E.
      * left. assumption.
      * right. right. assumption.
    + destruct (select a al) eqn:E.
      injection H as Hl Hr.
      subst.
      apply IHal in E.
      destruct E.
      * right. left. assumption.
      * right. right. assumption.
Qed.

Lemma tst: forall l x y, x <=* l -> In y l -> x <= y.
Proof.
  intros l x y H1 H2.
  induction H1.
  - exfalso. apply H2.
  - destruct H2.
    + lia.
    + apply IHForall. apply H0.
Qed.

Lemma cons_of_small_maintains_sort: forall bl y n,
    n = length bl ->
    y <=* bl ->
    sorted (selsort bl n) ->
    sorted (y :: selsort bl n).
Proof.
  intros bl y n. gen bl. gen y.
  induction n; simpl; intros y bl Hn Hle Hsort.
  - destruct bl.
    + constructor.
    + simpl in Hn. discriminate Hn.
  - destruct bl as [| bh bt ].
    + simpl in Hn. discriminate Hn.
    + destruct (select bh bt) eqn:E.
      constructor.
      * apply select_in in E.
        apply tst with  (bh :: bt).
          assumption.
          assumption.
      * apply Hsort.
Qed.

Lemma selsort_sorted : forall n al,
    length al = n -> sorted (selsort al n).
Proof.
  intro n.
  induction n; simpl in *; intros al Hlen.
  - destruct al.
    + constructor.
    + discriminate Hlen.
  - destruct al.
    + discriminate Hlen.
    + destruct (select n0 al) eqn:E.
      Print sorted.
      apply cons_of_small_maintains_sort.
      * simpl in Hlen. apply select_rest_length in E. lia.
      * apply select_smallest in E. assumption.
      * apply IHn. apply select_rest_length in E. simpl in Hlen. lia.
Qed.

Lemma selection_sort_sorted : forall al,
    sorted (selection_sort al).
Proof.
  unfold selection_sort.
  intros al.
  apply selsort_sorted.
  reflexivity.
Qed.

Theorem selection_sort_is_correct :
  is_a_sorting_algorithm selection_sort.
Proof.
  intro a.
  split.
  - apply selection_sort_perm.
  - apply selection_sort_sorted.
Qed.

From VFA Require Import Multiset.
From Coq Require Import FunctionalExtensionality.

Module MultiserProof.

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

Lemma contents_cons: forall x l r,
  contents l = contents r -> contents (x :: l) = contents (x :: r).
Proof.
  intros x l.
  induction l; intros r H.
  - simpl in H.
    simpl.
    rewrite <- H.
    reflexivity.
  - simpl in *.
    rewrite H.
    reflexivity.
Qed.

Lemma select_rest_multiset : forall x l y r,
    select x l = (y, r) -> contents (x :: l) = contents (y :: r).
Proof.
  intros x l. gen x.
  induction l; intros x y r H.
  - extensionality o.
    simpl in H.
    injection H as Hl Hr. subst.
    reflexivity.
  - extensionality o.
    simpl in H.
    bdestruct (a >=? x).
    + destruct (select x l) eqn:E.
      injection H as Hl Hr. subst.
      simpl.
      rewrite (union_swap (singleton x) (singleton a)).
      rewrite (union_swap (singleton y) (singleton a)).
      simpl in IHl.
      rewrite (IHl _ y l0).
        reflexivity.
        assumption.
    + destruct (select a l) eqn:E.
      injection H as Hl Hr. subst.
      simpl. simpl in IHl.
      rewrite (union_swap (singleton y) (singleton x)).
      rewrite <- (IHl a y l0).
        reflexivity.
        assumption.
Qed.

Lemma same_contents_same_len: forall l1 l2,
  contents l1 = contents l2 -> length l1 = length l2.
Proof.
  intro l1.
  induction l1; intros l2 H.
  - simpl in H.
    destruct l2.
    + reflexivity.
    + exfalso.
      apply equal_f with v in H.
      simpl in H.
      unfold union, singleton, empty in H.
      rewrite Nat.eqb_refl in H.
      discriminate H.
  - assert (G: S (contents l1 a) = contents l2 a). {
      apply equal_f with a in H.
      simpl in H.
      unfold union, singleton, empty in H.
      rewrite Nat.eqb_refl in H.
      simpl in H.
      assumption.
    }
    destruct (contents_cons_inv _ _ _ G) as [l1' [l2' [Hl Hcont]]].
    rewrite Hl.
    rewrite app_length. simpl.
    rewrite Nat.add_comm. simpl.
    rewrite <- app_length.
    rewrite <- (IHl1 (l2' ++ l1')).
    + reflexivity.
    + extensionality o.
      rewrite Hl in H.
      rewrite contents_distr in *.
      simpl in H.
      apply equal_f with o in H.
      unfold union, singleton, empty in *.
      bdestruct (o =? a).
      * lia.
      * lia.
Qed.

Lemma selsort_multiset: forall n l,
    length l = n -> contents l = contents (selsort l n).
Proof.
  intros n.
  induction n; intros l Hlen; simpl in Hlen.
  - extensionality o.
    simpl. destruct l.
      constructor.
      simpl in Hlen. discriminate.
  - unfold selsort.
    fold selsort.
    destruct l.
    + constructor.
    + destruct (select v l) eqn:E.
      apply select_rest_multiset in E.
      extensionality o.
      assert (E' := E).
      eapply equal_f in E.
      rewrite E.
      simpl.
      rewrite <- IHn.
      * reflexivity.
      * simpl in Hlen.
        assert (G: length l0 = length l). {
          apply same_contents_same_len in E'.
          simpl in E'.
          injection E' as E'.
          rewrite E'.
          reflexivity.
        }
        rewrite <- G in Hlen.
        injection Hlen as Hlen.
        apply Hlen.
Qed.

Lemma selection_sort_multiset : forall al,
    contents al = contents (selection_sort al).
Proof.
  intro al.
  apply selsort_multiset.
  reflexivity.
Qed.

Theorem selection_sort_is_correct' :
  is_a_sorting_algorithm' selection_sort.
Proof.
  intro a.
  split.
  - apply selection_sort_multiset.
  - apply selection_sort_sorted.
Qed.

End MultiserProof.

Require Import Recdef.

Function selsort' l {measure length l} :=
  match l with
  | []      => []
  | x :: r  => let (y, r') := select x r
               in y :: selsort' r'
end.

Proof.
  intros.
  assert (Hperm: Permutation (x :: r) (y :: r')).
  { apply select_perm. auto. }
  apply Permutation_length in Hperm.
  inv Hperm. simpl. lia.
Defined.

Print selsort'.
Print selsort'_terminate.
Check selsort'_equation.

Lemma selsort'_perm : forall n l,
    length l = n -> Permutation l (selsort' l).
Proof.
(* TODO *)
Admitted.


Require Import List.
Import ListNotations.
Require Import PeanoNat.
(* Import Nat. *)
Require Import Ring.
(* Require Import Arith. *)
(* Import ArithRing. *)
(* Require Import NArithRing. *)
(* Require Import NArith. *)
Require Import FunctionalExtensionality.
Require Import BinInt.
Require Import ZArith.
Require Import ZArithRing.
Import Z.
Open Scope Z_scope.

Set Implicit Arguments.

Definition Vector (A : Type) := list A.

(* Vector functions *)

Fixpoint alignWith (A : Type) (f : A -> A -> A) (v1 v2 : Vector A) :=
  match v1, v2 with
  | [], _ => v2
  | _, [] => v1
  | a1 :: v12, a2 :: v22 => f a1 a2 :: alignWith f v12 v22
  end.

(* Laws about Vector functions *)

Lemma map_alignWith :
  forall A (f : A -> A -> A) (g : A -> A),
      (forall (x y : A), g (f x y) = f (g x) (g y)) ->
      forall (v1 v2 : Vector A), map g (alignWith f v1 v2) = alignWith f (map g v1) (map g v2).
Proof.
  induction v1; destruct v2; simpl alignWith; simpl map; try reflexivity; rewrite H; rewrite IHv1; reflexivity.
Qed.

(* Addition *)

Definition zero : Vector Z := [].

Definition plus (v1 v2 : Vector Z) : Vector Z :=
  alignWith add v1 v2.

Hint Unfold plus.
Ltac simpl_plus := unfold plus; simpl alignWith.

(* Auxiliary lemmas *)

Lemma map_plus :
  forall (n : Z) (v1 v2 : Vector Z),
    map (mul n) (plus v1 v2) = plus (map (mul n) v1) (map (mul n) v2).
Proof.
  intros n v1 v2; unfold plus.
  rewrite map_alignWith; try reflexivity.
  apply mul_add_distr_l.
Qed.

Lemma plus_cons :
  forall (n1 n2 : Z) (v1 v2 : Vector Z),
    n1 + n2 :: plus v1 v2 = plus (n1 :: v1) (n2 :: v2).
Proof.
  reflexivity.
Qed.

(* Properties of plus *)

Lemma plus_comm :
  forall (v1 v2 : Vector Z),
    plus v1 v2 = plus v2 v1.
Proof.
  induction v1; destruct v2;
    simpl_plus; try reflexivity; rewrite add_comm;
      rewrite <- IHv1; reflexivity.
Qed.

Lemma plus_0_l :
  forall (v : Vector Z),
    plus zero v = v.
Proof.
  unfold zero, plus.
  simpl alignWith.
  reflexivity.
Qed.

Lemma plus_0_r :
  forall (v : Vector Z),
    plus v zero = v.
Proof.
  intro v.
  rewrite plus_comm.
  apply plus_0_l.
Qed.

Lemma plus_assoc :
  forall (v1 v2 v3 : Vector Z),
    plus v1 (plus v2 v3) = plus (plus v1 v2) v3.
Proof.
  induction v1; destruct v2, v3; try reflexivity;
    simpl_plus; simpl alignWith; rewrite IHv1, add_assoc; reflexivity.
Qed.

(* Derived lemmas about plus *)

Lemma plus_swap_1 :
  forall (v1 v2 v3 : Vector Z),
    plus v1 (plus v2 v3) = plus v2 (plus v1 v3).
Proof.
  intros v1 v2 v3.
  rewrite plus_assoc, plus_comm with (v1 := v1), <- plus_assoc.
  reflexivity.
Qed.

Lemma plus_swap_2 :
  forall (v1 v2 v3 v4 : Vector Z),
    plus (plus v1 v2) (plus v3 v4) = plus (plus v1 v3) (plus v2 v4).
Proof.
  intros v1 v2 v3 v4.
  rewrite plus_assoc, <- plus_assoc with (v1 := v1), plus_comm with (v1 := v2), plus_assoc, plus_assoc.
  reflexivity.
Qed.

Definition one : Vector Z := [1].

Fixpoint mult (v1 v2 : Vector Z) : Vector Z :=
  match v1, v2 with
  | [], _ => []
  | _, [] => []
  | n :: v12, _ => plus (map (mul n) v2) (0 :: mult v12 v2)
  end.

(* Auxiliary lemmas about mult *)

Lemma map_mult :
  forall (n : Z) (v1 v2 : Vector Z),
    map (mul n) (mult v1 v2) = mult (map (mul n) v1) v2.
Proof.
  intros v.
  induction v1; intros v2; simpl mult; try reflexivity.
  destruct v2; try reflexivity.
  rewrite map_plus, map_map, <- IHv1.
  simpl map.
  rewrite mul_0_r.
  do 2 f_equal.
  - ring.
  - f_equal.
    extensionality x.
    ring.
Qed.

Lemma map_add_0 :
  forall (v : Vector Z), map (fun n => n + 0) v = v.
Proof.
  induction v; simpl; try reflexivity.
  rewrite add_0_r, IHv.
  reflexivity.
Qed.

(* Properties of mult *)

Lemma mult_comm :
  forall (v1 v2 : Vector Z),
    mult v1 v2 = mult v2 v1.
Proof.
  induction v1; induction v2; simpl; try reflexivity.
  rewrite <- IHv2, IHv1.
  do 2 rewrite <- plus_cons.
  f_equal.
  - ring.
  - simpl.
    destruct v1, v2; only 1-3: simpl; try reflexivity.
    + rewrite plus_0_r, plus_0_l.
      simpl_plus.
      rewrite plus_0_r, add_0_r.
      reflexivity.
    + rewrite plus_0_l, plus_0_r.
      simpl_plus.
      rewrite plus_0_r, add_0_r.
      reflexivity.
    + rewrite plus_swap_1. rewrite <- IHv1.
      reflexivity.
Qed.

Lemma mult_0_l :
  forall (v : Vector Z),
    mult zero v = zero.
Proof.
  reflexivity.
Qed.

Lemma mult_0_r :
  forall (v : Vector Z),
    mult v zero =  zero.
Proof.
  intros v1.
  rewrite mult_comm, mult_0_l.
  reflexivity.
Qed.

Lemma alignWith_nil_r :
  forall A (f : A -> A -> A) v, alignWith f v [] = v.
Proof.
  intros A f v.
  induction v; reflexivity.
Qed.

Lemma mult_1_l :
  forall (v : Vector Z),
    mult one v = v.
Proof.
  intros v.
  unfold one.
  destruct v; simpl; try reflexivity.
  simpl_plus.
  rewrite alignWith_nil_r.
  rewrite map_ext with (g := id); try (intros; unfold id; ring).
  rewrite map_id.
  destruct z; try reflexivity.
Qed.

Lemma mult_1_r :
  forall (v : Vector Z),
    mult v one = v.
Proof.
  intros v.
  rewrite mult_comm.
  apply mult_1_l.
Qed.

(* Auxiliary lemma for proving associativity and distributivity *)

Lemma mult_plus_distr_r :
  forall (v1 v2 v3 : Vector Z),
    mult v1 (plus v2 v3) = plus (mult v1 v2) (mult v1 v3).
Proof.
  induction v1; intros v2 v3; simpl mult; try reflexivity.
  destruct v2.
  - rewrite plus_0_l.
    destruct v3; try reflexivity.
  - destruct v3.
    + rewrite plus_0_r.
      reflexivity.
    + unfold plus.
      simpl.
      ring_simplify (a * (z + z0) + 0) (a * z + 0 + (a * z0 + 0)).
      rewrite map_plus.
      do 2 rewrite plus_cons.
      rewrite IHv1.
      rewrite plus_swap_2.
      reflexivity.
Qed.

Lemma mult_plus_distr_l :
  forall (v1 v2 v3 : Vector Z),
    mult (plus v1 v2) v3 = plus (mult v1 v3) (mult v2 v3).
Proof.
  intros v1 v2 v3.
  rewrite mult_comm, mult_plus_distr_r, mult_comm, (mult_comm v3).
  reflexivity.
Qed.

Lemma mult_assoc :
  forall (v1 v2 v3 : Vector Z),
    mult v1 (mult v2 v3) = mult (mult v1 v2) v3.
Proof.
  induction v1; intros v2 v3; simpl mult; try reflexivity.
  rewrite IHv1.
  destruct v2.
  - rewrite mult_0_l.
    reflexivity.
  - destruct v3; simpl; try reflexivity.
    rewrite <- plus_cons, <- plus_cons.
    f_equal.
    + ring.
    + rewrite mult_plus_distr_l, <- IHv1, plus_assoc.
      unfold plus.
      rewrite map_alignWith.
      * rewrite map_map, map_mult.
        do 3 f_equal.
        extensionality x.
        ring.
      * apply mul_add_distr_l.
Qed.


(* -*- mode: coq; mode: visual-line -*- *)

Require Import HoTT.Basics.
Require Import Types.Prod Types.Sigma Types.Forall Types.Arrow Types.Paths.

Local Open Scope path_scope.

(** * Equivalences *)

Section AssumeFunext.
  Context `{Funext}.

  (** We begin by showing that, assuming function extensionality, [IsEquiv f] is an hprop. *)
  Global Instance hprop_isequiv {A B} `(f : A -> B)
  : IsHProp (IsEquiv f).
  Proof.
    apply hprop_inhabited_contr; intros feq.
    (* We will show that if [IsEquiv] is inhabited, then it is contractible, because it is equivalent to a sigma of a pointed path-space over a pointed path-space, both of which are contractible. *)
    refine (contr_equiv' { g : B -> A & g = f^-1 } _).
    equiv_via ({ g:B->A & { r:g=f^-1 & { s:g=f^-1 & r=s }}}); apply equiv_inverse.
    1:exact (equiv_functor_sigma' 1 (fun _ => equiv_sigma_contr _ )).
    (* First we apply [issig], peel off the first component, and convert to pointwise paths. *)
    refine (_ oE (issig_isequiv f)^-1).
    refine (equiv_functor_sigma' (equiv_idmap (B -> A)) _); intros g; simpl.
    equiv_via ({ r : g == f^-1 & { s : g == f^-1 & r == s }}).
    (* Now the idea is that if [f] is an equivalence, then [g f == 1] and [f g == 1] are both equivalent to [g == f^-1]. *)
    { refine (equiv_functor_sigma'
                (equiv_functor_forall idmap (fun b p => (ap f)^-1 (p @ (eisretr f b)^)))
                (fun r => equiv_functor_sigma'
                            (equiv_functor_forall f (fun a p => p @ (eissect f a)))^-1 _));
      intros s; simpl.
      (* What remains is to show that under these equivalences, the remaining datum [eisadj] reduces simply to [r == s].  Pleasingly, Coq can compute for us exactly what this means. *)
      apply equiv_inverse;
        refine (equiv_functor_forall' (Build_Equiv _ _ f _) _);
        intros a; simpl; unfold functor_forall.
      rewrite transport_paths_FlFr.
      (* At this point it's just naturality wrangling, potentially automatable.  It's a little unusual because what we have to prove is not just the existence of some path, but that one path-type is equivalent to another one, but we can mostly still use [rewrite]. *)
      Open Scope long_path_scope.
      rewrite ap_pp, !concat_p_pp, eisadj, <- !ap_V, <- !ap_compose.
      rewrite (concat_pA1_p (eissect f) (eissect f a)^).
      rewrite (concat_A1p s (eissect f a)^).
      rewrite (concat_pp_A1 (fun x => (eissect f x)^) (eissect f a)).
      (* Here instead of [whiskerR] we have to be a bit fancier. *)
      refine (_ oE (equiv_ap (equiv_concat_r (eissect f a)^ _) _ _)^-1).
      rewrite concat_pV_p.
      refine (_ oE equiv_ap (ap f) _ _).
      (* Now we can get rid of the [<~>] and reduce the question to constructing some path. *)
      apply equiv_concat_l.
      rewrite !ap_pp, !ap_V, <- !eisadj, <- ap_compose.
      rewrite_moveL_Vp_p.
      symmetry; exact (concat_A1p (eisretr f) (r (f a))).
      Close Scope long_path_scope. }
    (* The leftover goal is just nested applications of funext. *)
    { refine (equiv_functor_sigma' (equiv_path_arrow g f^-1)
                                   (fun r => equiv_functor_sigma' (equiv_path_arrow g f^-1) _));
      intros s; simpl.
      refine (_ oE equiv_path_forall r s).
      exact (equiv_ap (path_forall g f^-1) r s). }
  Qed.

  (** Thus, paths of equivalences are equivalent to paths of functions. *)
  Lemma equiv_path_equiv {A B : Type} (e1 e2 : A <~> B)
  : (e1 = e2 :> (A -> B)) <~> (e1 = e2 :> (A <~> B)).
  Proof.
    equiv_via ((issig_equiv A B) ^-1 e1 = (issig_equiv A B) ^-1 e2).
    2: symmetry; apply equiv_ap; refine _.
    exact (equiv_path_sigma_hprop ((issig_equiv A B)^-1 e1) ((issig_equiv A B)^-1 e2)).
  Defined.

  Definition path_equiv {A B : Type} {e1 e2 : A <~> B}
  : (e1 = e2 :> (A -> B)) -> (e1 = e2 :> (A <~> B))
    := equiv_path_equiv e1 e2.

  Global Instance isequiv_path_equiv {A B : Type} {e1 e2 : A <~> B}
  : IsEquiv (@path_equiv _ _ e1 e2)
    (* Coq can find this instance by itself, but it's slow. *)
    := equiv_isequiv (equiv_path_equiv e1 e2).

  (** This implies that types of equivalences inherit truncation.  Note that we only state the theorem for [n.+1]-truncatedness, since it is not true for contractibility: if [B] is contractible but [A] is not, then [A <~> B] is not contractible because it is not inhabited.

   Don't confuse this lemma with [trunc_equiv], which says that if [A] is truncated and [A] is equivalent to [B], then [B] is truncated.  It would be nice to find a better pair of names for them. *)
  Global Instance istrunc_equiv {n : trunc_index} {A B : Type} `{IsTrunc n.+1 B}
  : IsTrunc n.+1 (A <~> B).
  Proof.
    simpl. intros e1 e2.
    apply (trunc_equiv _ (equiv_path_equiv e1 e2)).
  Defined.

  (** In the contractible case, we have to assume that *both* types are contractible to get a contractible type of equivalences. *)
  Global Instance contr_equiv_contr_contr {A B : Type} `{Contr A} `{Contr B}
  : Contr (A <~> B).
  Proof.
    exists equiv_contr_contr.
    intros e. apply path_equiv, path_forall. intros ?; apply contr.
  Defined.

  (** The type of *automorphisms* of an hprop is always contractible *)
  Global Instance contr_aut_hprop A `{IsHProp A}
  : Contr (A <~> A).
  Proof.
    exists 1%equiv.
    intros e; apply path_equiv, path_forall. intros ?; apply path_ishprop.
  Defined.

  (** Equivalences are functorial under equivalences. *)
  Definition functor_equiv {A B C D} (h : A <~> C) (k : B <~> D)
  : (A <~> B) -> (C <~> D)
  := fun f => ((k oE f) oE h^-1).

  Global Instance isequiv_functor_equiv {A B C D} (h : A <~> C) (k : B <~> D)
  : IsEquiv (functor_equiv h k).
  Proof.
    refine (isequiv_adjointify _
              (functor_equiv (equiv_inverse h) (equiv_inverse k)) _ _).
    - intros f; apply path_equiv, path_arrow; intros x; simpl.
      exact (eisretr k _ @ ap f (eisretr h x)).
    - intros g; apply path_equiv, path_arrow; intros x; simpl.
      exact (eissect k _ @ ap g (eissect h x)).
  Defined.

  Definition equiv_functor_equiv {A B C D} (h : A <~> C) (k : B <~> D)
  : (A <~> B) <~> (C <~> D)
  := Build_Equiv _ _ (functor_equiv h k) _.

  (** Reversing equivalences is an equivalence *)
  Global Instance isequiv_equiv_inverse {A B}
  : IsEquiv (@equiv_inverse A B).
  Proof.
    refine (isequiv_adjointify _ equiv_inverse _ _);
      intros e; apply path_equiv; reflexivity.
  Defined.

  Definition equiv_equiv_inverse A B
  : (A <~> B) <~> (B <~> A)
    := Build_Equiv _ _ (@equiv_inverse A B) _.

End AssumeFunext.


Require Import Braun.common.util Braun.common.le_util.
Require Import Braun.common.log Braun.common.big_oh Braun.common.pow.
Require Import Braun.monad.monad Braun.arith.plus Braun.fib.fib.
Require Import Program Div2 Omega Even.

Fixpoint fib_rec_time (n:nat) :=
  match n with
    | O => 1
    | S n' =>
      match n' with
        | O => 1
        | S n'' => (fib_rec_time n'') + (fib_rec_time n') + 1
      end
  end.

Definition fib_rec_result (n:nat) (res:nat) (c:nat) :=
    Fib n res /\
    c = fib_rec_time n.

Load "fib_rec_gen.v".

Next Obligation.
Proof.
  split;eauto.
Qed.

Next Obligation.
Proof.
  split;eauto.
Qed.

Next Obligation.
Proof.
  clear am H3 am0 H2.
  rename H1 into FR_A.
  rename H0 into FR_B.

  destruct FR_A as [FIBA FIBTIMEA].
  destruct FR_B as [FIBB FIBTIMEB].
  unfold fib_rec_result in *.
  split.
  eauto.
  rename n'' into n.
  destruct n as [|n]; subst; simpl; omega.
Qed.

Program Lemma fib_big_oh_fib:
  big_oh fib fib_rec_time.
Proof.
  exists 0 1.
  apply (well_founded_induction lt_wf (fun n => 0 <= n -> fib n <= 1 * (fib_rec_time n))).
  intros n IH _.
  destruct n as [|n]. simpl. omega.
  destruct n as [|n]. simpl. auto.
  replace (fib_rec_time (S (S n))) with
    ((fib_rec_time n) + (fib_rec_time (S n)) + 1); auto.

  assert (fib n <= 1 * (fib_rec_time n)) as IHn.
  eapply IH. auto. omega.
  assert (fib (S n) <= 1 * (fib_rec_time (S n))) as IHSn.
  eapply IH. auto. omega.

  rewrite mult_1_l in *.

  clear IH.
  replace (fib (S (S n))) with (fib n + fib (S n)); auto.
  omega.
Qed.

Fixpoint fib_rec_time2 (n:nat) :=
  match n with
    | O => 0
    | S n' =>
      match n' with
        | O => 1
        | S n'' => (fib_rec_time2 n'') + (fib_rec_time2 n') + 1
      end
  end.

Lemma fib_rec_time12 : big_oh fib_rec_time fib_rec_time2.
Proof.
  exists 1 11.
  intros n LT.
  destruct n. intuition.
  clear LT.
  apply (well_founded_induction
           lt_wf
           (fun n => fib_rec_time (S n) <= 11 * (fib_rec_time2 (S n)))).
  clear n; intros n IND.
  destruct n.
  simpl.
  omega.
  destruct n.
  simpl.
  omega.
  replace (fib_rec_time (S (S (S n))))
  with (fib_rec_time (S n) + fib_rec_time (S (S n)) + 1);
    [|unfold fib_rec_time;omega].
  replace (fib_rec_time2 (S (S (S n))))
  with (fib_rec_time2 (S n) + fib_rec_time2 (S (S n)) + 1);
    [|unfold fib_rec_time2;omega].
  repeat (rewrite mult_plus_distr_l).
  apply plus_le_compat.
  apply plus_le_compat;apply IND;auto.
  omega.
Qed.

Lemma fib_rec_time2_fib_relationship :
  forall n, fib_rec_time2 n + 1 = (fib (S (S n))).
Proof.
  intros.
  apply (well_founded_induction
           lt_wf
           (fun n => fib_rec_time2 n + 1 = (fib (S (S n))))).
  clear n; intros n IND.
  destruct n.
  simpl; reflexivity.
  destruct n.
  simpl; reflexivity.
  replace (fib_rec_time2 (S (S n))) with (fib_rec_time2 (S n) + fib_rec_time2 n + 1);
    [|unfold fib_rec_time2;omega].
  rewrite fib_SS.
  replace (fib_rec_time2 (S n) + fib_rec_time2 n + 1 + 1)
  with ((fib_rec_time2 (S n) + 1) + (fib_rec_time2 n + 1));[|omega].
  rewrite IND; auto.
Qed.

Lemma fib_rec_time23 : big_oh fib_rec_time2 fib.
Proof.
  exists 0 3.
  intros n _.
  assert ((fib_rec_time2 n + 1) <= S (3 * fib n));[|omega].
  rewrite fib_rec_time2_fib_relationship.
  replace (S (3 * fib n)) with (3 * fib n + 1);[|omega].
  rewrite fib_SS.
  replace (3 * fib n + 1) with (2 * fib n + 1 + fib n);[|omega].
  apply plus_le_compat; auto.
  destruct n.
  simpl.
  omega.
  rewrite fib_SS.
  replace (2 * fib (S n) + 1) with (fib (S n) + (fib (S n) + 1));[|omega].
  apply plus_le_compat;auto.
  apply le_plus_trans.
  apply fib_monotone; auto.
Qed.

Theorem fib_big_theta_fib:
  big_theta fib fib_rec_time.
Proof.
  split.
  apply fib_big_oh_fib.
  apply big_oh_rev.
  apply (big_oh_trans fib_rec_time fib_rec_time2).
  apply fib_rec_time12.
  apply fib_rec_time23.
Qed.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq choice fintype.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Inductive BinaryTree (T : Type) : Type :=
    | Nill : BinaryTree T
    | Node : BinaryTree T -> BinaryTree T -> T -> BinaryTree T -> BinaryTree T
    .

Check (Nill nat).
Check (Node (Nill nat) (Nill nat) 5 (Nill nat)).
Check (Node (Nill nat) (Nill nat) 5
      (Node (Nill nat) (Nill nat) 7 (Nill nat))).

(* ========================= *)
(* Functions of BinaryTree T *)
(* ========================= *)

Definition Lst {T} (tree : BinaryTree T) : BinaryTree T :=
  match tree with
  | Nill => Nill T
  | Node _ Left _ _ => Left
  end.

Definition Rst {T} (tree : BinaryTree T) : BinaryTree T :=
  match tree with
  | Nill => Nill T
  | Node _ _ _ Right => Right
  end.

Notation null := (Nill nat).
Notation "l -| v |- r" := (Node (Nill nat) l v r) (at level 43, left associativity).
Notation "@ v " := (null -| v |- null) (at level 43, left associativity).

Eval compute in (Lst null).
Eval compute in (Rst null).

Eval compute in (Lst (@5)).
Eval compute in (Rst (@5)).

Eval compute in (Lst ((@3) -| 5 |- (@7))).
Eval compute in (Rst ((@3) -| 5 |- (@7))).

Fixpoint nodes {T} (tree : BinaryTree T) : seq T :=
  match tree with
  | Nill => [::]
  | Node _ Left value Right => value :: (nodes Left ++ nodes Right)
  end.

(* ====================== *)
(* Height of BinaryTree T *)
(* ====================== *)

Fixpoint height {T} (tree : BinaryTree T) : nat :=
    match tree with
    | Nill              => 0
    | Node _ Left _ Right => 1 + maxn (height Left) (height Right)
    end.

Lemma height_nill : forall {T}, height (Nill T) = 0.
Proof.
  done.
Qed.

Lemma height_empty_tree : forall {T} (tree : BinaryTree T),
  height tree = 0 <-> tree = Nill T.
Proof.
  by move => T; case.
Qed.

Lemma height_subtrees : forall {T} (tree : BinaryTree T),
  tree <> Nill T <-> height tree = 1 + maxn (height (Lst tree)) (height (Rst tree)).
Proof.
  by move => T; case.
Qed.

(* Count of BinaryTree T *)

Fixpoint count {T} (tree : BinaryTree T) : nat :=
    match tree with
    | Nill              => 0
    | Node _ Left _ Right => 1 + (count Left) + (count Right)
    end.

Eval compute in (height null).
Eval compute in (count null).

Eval compute in (height (@5)).
Eval compute in (count (@5)).

Eval compute in (height ((@3) -| 5 |- (@7))).
Eval compute in (count ((@3) -| 5 |- (@7))).

Eval compute in (height ((@3) -| 5 |- ((@6) -| 7 |- (@8)))).
Eval compute in (count ((@3) -| 5 |- ((@6) -| 7 |- (@8)))).

Lemma count_nill : forall {T}, count (Nill T) = 0.
Proof.
  done.
Qed.

Lemma count_empty_tree : forall {T} (tree : BinaryTree T),
  count tree = 0 <-> tree = Nill T.
Proof.
  by move => T; case.
Qed.

Lemma count_subtrees : forall {T} (tree : BinaryTree T),
  tree <> Nill T <-> count tree = 1 + count (Lst tree) + count (Rst tree).
Proof.
  by move => T; case.
Qed.

(* =================================================== *)
(* Connection between height and count of BinaryTree T *)
(* =================================================== *)

Theorem leq_height_count : forall {T} (tree : BinaryTree T),
  height tree <= count tree.
Proof.
  move => T; elim => [| _ _ Ltree iHl value Rtree iHr] /= //.

    rewrite (leq_add2l 1 _ (_ + _)).

  - suff: forall a b c d, (maxn a b <= maxn c d)
          -> (maxn a b <= c + d).
    move => L1; apply: L1.

  - suff: forall a b c d, a <= c -> b <= d -> a + b <= c + d
          -> maxn a b <= maxn c d.
    move => L2; apply: L2.
    apply: iHl. apply: iHr.

    by apply: leq_add.

    (* first subgoal *)
    move => a b c d acH bdH H.
    case: (leqP b a) => abH.
    - rewrite maxnC maxnE subnKC => //.
      case: (leqP d c) => cdH.
      - rewrite maxnC maxnE subnKC => //.
      - rewrite maxnE subnKC.
        - apply: ltnW. apply: leq_ltn_trans.
          apply: acH. apply: cdH.
        - by apply: ltnW.
    - rewrite maxnE subnKC.
      case: (leqP d c) => cdH.
      - rewrite maxnC maxnE subnKC => //.
        apply: leq_trans. apply: bdH.
        apply: cdH.
      - rewrite maxnE subnKC => //.
        - apply: ltnW => //.
        - apply: ltnW => //.

    (* Auxiliary lemma *)
    have: forall x y, maxn x y <= x + y.
    elim => [x | x iHx y] .
    - rewrite max0n => //.
    - case: y => [| y]; first
      rewrite maxn0 addn0 => //.
      - rewrite maxnSS -add1n -(add1n x)
        (leq_add2l 1 _ (_ + _)) addnS.
        by apply: leqW.

    move => leq_maxn_sum.

    (* second subgoal *)
    move => a b c d H.
    apply: leq_trans. apply: H.
    apply: leq_maxn_sum.
Qed.

Ltac solve :=
  do ![try case: andP => //; case];
  try split => //; try done.

(* ============================================================ *)
(* ### ----- Canonical comparison and eqType for BynaryTree T.  *)
(* ============================================================ *)

Section EqTree.

Variables T : eqType.
Implicit Type t : BinaryTree T.

Fixpoint eqtree t1 t2 {struct t1} :=
  match t1, t2 with
  | Nill, Nill => true
  | Node P1 L1 v1 R1, Node P2 L2 v2 R2 =>
    (v1 == v2) && eqtree P1 P2 && eqtree L1 L2 && eqtree R1 R2
  | _, _ => false
  end.

Lemma eqtreeP : Equality.axiom eqtree.
Proof.
  move; elim => [| tp1 iHtp tl1 iHtl v1 tr1 iHtr] [| tp2 tl2 v2 tr2];
        do [by constructor | simpl].
  - case: andP.
    - case; case: andP => //; case.
      case: andP => //; case => eqv eqtp _ eqtl _ eqtr.
      constructor.
      case: iHtp eqtp => Htp _ //.
      case: iHtl eqtl => Htl _ //.
      case: iHtr eqtr => Htr _ //.
      case: eqP eqv => /= // Hv _.
      by rewrite Htp Htl Hv Htr.
  - move => H. constructor => H'. inversion H'.
     apply: H. solve.
    - case: iHtr H4 => //.
    - case: iHtl H2 => //.
    - case: eqP H3 => //.
    - case: iHtp H1 => //.
Qed.

Canonical tree_eqMixin := EqMixin eqtreeP.
Canonical tree_eqType := Eval hnf in EqType (BinaryTree T) tree_eqMixin.

Lemma eqtreeE : eqtree = eq_op.
Proof.
  elim: eqtree => //; do [by constructor].
Qed.

End EqTree.

Implicit Arguments eqtreeP [T x y].

Eval compute in (null == null).
Eval compute in (null == (@4) -| 5 |- (@6)).
Eval compute in ((@4) -| 5 |- (@6) == (@4) -| 5 |- (@6)).
Eval compute in ((@3) -| 5 |- (@6) == (@4) -| 5 |- (@6)).

(* ================== *)
(* Binary search tree *)
(* ================== *)

Fixpoint Is_cond (s : seq nat) (P : nat -> bool) : bool :=
  match s with
  | [::]    => true
  | y :: ys => P y && Is_cond ys P
  end.

Fixpoint Left_cond (tree : BinaryTree nat) : bool :=
  match tree with
  | Nill => true
  | Node _ Left value Right => Is_cond (nodes (Lst tree)) (fun y => y < value)
    && Left_cond Left && Left_cond Right
  end.

Fixpoint Right_cond (tree : BinaryTree nat) : bool :=
  match tree with
  | Nill => true
  | Node _ Left value Right => Is_cond (nodes (Rst tree)) (fun y => value < y)
    && Right_cond Left && Right_cond Right
  end.

Eval compute in (Left_cond (((@1) -| 2 |- (@3)) -| 4 |- (@ 6))).
Eval compute in (Left_cond (((@3) -| 2 |- (@1)) -| 4 |- (@ 6))).
Eval compute in (Right_cond (((@1) -| 2 |- (@3)) -| 4 |- (@ 6))).
Eval compute in (Right_cond (((@3) -| 2 |- (@1)) -| 4 |- (@ 6))).

Inductive BST : BinaryTree nat -> Prop :=
  | bst_nill : BST null
  | bst_node : forall tree, Left_cond tree -> Right_cond tree ->
    BST (Lst tree) -> BST (Rst tree) -> BST tree.

Lemma BST_Nill : BST null.
Proof.
  apply: bst_nill.
Qed.

Lemma BST_Combine : forall tp tl v tr,
  Left_cond (Node tp tl v tr) -> Right_cond (Node tp tl v tr) ->
  BST tl -> BST tr -> BST (Node tp tl v tr).
Proof.
  move => tp tl value tr Lc Rc lH rH.
  by apply: bst_node.
Qed.

Lemma BST_One : forall y, BST (@ y).
Proof.
  move => y;
  apply: bst_node => //;
  do [apply: BST_Nill].
Qed.

Lemma BST_Example_1 : BST ((@3) -| 5 |- (@ 7)).
Proof.
  apply: bst_node => //;
  do [apply: BST_One].
Qed.

Lemma BST_Two_l : forall a b, b < a ->
  BST ((@ b) -| a |- null).
Proof.
  move => a b cond.
  apply: bst_node => // /=.
  - solve.
  - apply: BST_One.
  - apply: BST_Nill.
Qed.

Lemma BST_Two_r : forall a b, a < b ->
  BST (null -| a |- (@ b)).
Proof.
  move => a b cond.
  apply: bst_node => // /=.
  - solve.
  - apply: BST_Nill.
  - apply: BST_One.
Qed.

Lemma BST_Tree : forall a b c, b < a < c ->
  BST ((@ b) -| a |- (@ c)).
Proof.
  move => a b c cond.
  apply: bst_node => /=.
  - solve.
    by case: andP cond => //; case.
  - solve.
    by case: andP cond => //; case.
  - apply: BST_One.
  - apply: BST_One.
Qed.

Lemma BST_Example_2 : BST ((null -| 3 |- (@ 4)) -| 5 |- (@ 7)).
Proof.
  by apply: bst_node => //;
  do [apply: BST_Two_r| apply: BST_One].
Qed.

(* ============= *)
(* Insert in BST *)
(* ============= *)

Fixpoint BST_insert (value : nat) (tree : BinaryTree nat) : BinaryTree nat :=
    match tree with
    | Nill                => null -| value |- null
    | Node _ Left y Right =>
        if value < y
        then (BST_insert value Left) -| y |- Right
        else if y < value
        then Left -| y |- (BST_insert value Right)
        else tree
    end.

Notation "v >> t" := (BST_insert v t) (at level 43, left associativity).

Eval compute in (2 >> null).
Eval compute in (2 >> (@ 3)).
Eval compute in (2 >> (@ 1)).
Eval compute in (1 >> ((@ 2) -| 4 |- (@ 6))).
Eval compute in (3 >> ((@ 2) -| 4 |- (@ 6))).
Eval compute in (5 >> ((@ 2) -| 4 |- (@ 6))).
Eval compute in (7 >> ((@ 2) -| 4 |- (@ 6))).

Axiom Insert_cond : forall value tree,
  nodes (value >> tree) = value :: (nodes tree).

Lemma Safety_Left_cond : forall tree y, Left_cond tree -> Left_cond (y >> tree).
Proof.
  elim => /= [y _ | tp _ tl iHtl z tr iHtr w H] //.
  - case: andP H => //; case; solve => condL lH _ rH _.
    case: (ltngtP w z) => cond /=; solve.
    - rewrite Insert_cond => /=; solve.
    - apply: iHtl lH.
    - apply: iHtr rH.
Qed.

Lemma Safety_Right_cond : forall tree y, Right_cond tree -> Right_cond (y >> tree).
Proof.
  elim => /= [y _ | tp _ tl iHtl z tr iHtr w H] //.
  - case: andP H => //; case; solve => condR lH _ rH _.
    case: (ltngtP w z) => cond /=; solve.
    - apply: iHtl lH.
    - apply: iHtr rH.
    - rewrite Insert_cond => /=.
      by solve; apply: ltnW.
Qed.

Theorem Safety_BST_insert : forall tree y, BST tree -> BST (y >> tree).
Proof.
  elim => /= [y _ | tp _ tl iHtl z tr iHtr w H] //.
  - apply: BST_One.
    inversion H.
    inversion H0; case: andP H6 => //; case.
    case: andP => //; case => condL lH _ rH _;
    inversion H1; case: andP H6 => //; case.
    case: andP => //; case => condR lH' _ rH' _.
    case: (ltngtP w z) => cond //.
    - apply: BST_Combine => /= //.
      - solve.
        - rewrite Insert_cond => /=; solve.
        - apply: Safety_Left_cond lH.
      - solve.
        apply: Safety_Right_cond lH'.
      - apply: iHtl H2.
    - apply: BST_Combine => /= //.
      - solve; apply: Safety_Left_cond rH.
      - solve.
        - apply: Safety_Right_cond rH'.
        - rewrite Insert_cond => /=.
          by solve; apply: ltnW.
      - apply: iHtr H3.
Qed.

(* ======================== *)
(* BST with bool definition *)
(* ======================== *)

Fixpoint BSTeq (tree : BinaryTree nat) : bool :=
  match tree with
  | Nill => true
  | Node _ Left value Right =>
    Left_cond tree && Right_cond tree &&
    BSTeq Left && BSTeq Right
  end.

Lemma BSTeq_Nill : BSTeq null.
Proof.
  done.
Qed.

Lemma BSTeq_Combine : forall tp tl v tr,
  Left_cond (Node tp tl v tr) -> Right_cond (Node tp tl v tr) ->
  BSTeq tl -> BSTeq tr -> BSTeq (Node tp tl v tr).
Proof.
  move => /= tp tl value tr Lc Rc lH rH.
  case: andP => //; case.
  case: andP => //; case.
  by case: andP => //; case.
Qed.

Lemma BSTeq_One : forall y, BSTeq (null -| y |- null).
Proof.
  done.
Qed.

Lemma BSTeq_Example_1 : BSTeq ((@ 3) -| 5 |- (@ 7)).
Proof.
  done.
Qed.

Lemma BSTeq_Two_l : forall a b, b < a ->
  BSTeq ((@ b) -| a |- null).
Proof.
  move => /= a b cond.
  solve.
Qed.

Lemma BSTeq_Two_r : forall a b, a < b ->
  BSTeq (null -| a |- (@ b)).
Proof.
  move => /= a b cond; solve.
Qed.

Lemma BSTeq_Tree : forall a b c, b < a < c ->
  BSTeq ((@ b) -| a |- (@ c)).
Proof.
  move => /= a b c cond; solve.
  - by case: andP cond => //; case.
  - by case: andP cond => //; case.
Qed.

Lemma BSTeq_Example_2 : BSTeq ((null -| 3 |- (@ 4)) -| 5 |- (@ 7)).
Proof.
  done.
Qed.

Theorem Safety_BSTeq_insert : forall tree y, BSTeq tree -> BSTeq (y >> tree).
Proof.
  elim => /= [y _ | tp _ tl iHtl z tr iHtr w] //.
  case: andP => //; case.
  case: andP => //; case.
  case: andP => //; case => condL condR _ lH _ rH _.
  case: andP condR => //; case.
  case: andP => //; case => condtR LH _ RH _.
  case: andP condL => //; case.
  case: andP => //; case => condtL LH' _ RH' _.
  case: (ltngtP w z) => cond /= //.
  - rewrite Insert_cond /=; solve.
    - apply: iHtl lH.
    - apply: Safety_Right_cond LH.
    - apply: Safety_Left_cond LH'.
  - rewrite Insert_cond /=; solve.
    - apply: iHtr rH.
    - apply: Safety_Right_cond RH.
    - apply: Safety_Left_cond RH'.
  solve.
Qed.

(* =========================== *)
(* Reflect betwen BST and BST' *)
(* =========================== *)

Theorem bstP (tree : BinaryTree nat) : reflect (BST tree) (BSTeq tree).
Proof.
  elim: tree => [| tp _ tl iHtl z tr iHtr] /=.
  - constructor; apply: BST_Nill.
  - case: andP.
    - case; case: andP => //; case.
      case; case: andP => //. case => condL condR _ lH _ rH.
      constructor.
      apply: BST_Combine => //.
      - by case: iHtl lH.
      - by case: iHtr rH.
    - move => H1. constructor. move => H2.
      apply: H1. inversion H2.
      case: andP => //; case.
      - solve. move: H3.
        rewrite Rst_elem. case: iHtr => //.
      - case: andP => //; case.
        - split => //. move: H1.
          rewrite Lst_elem; case: iHtl => //.
        - split => //.
Qed.

Lemma BST_Example_3 : BST (((@2) -| 3 |- (@ 4)) -| 5 |- ((@6) -| 7 |- (@ 9))).
Proof.
  by apply: bstP.
Qed.

(* =========================== *)
(* ### ----- Tree with parents *)
(* =========================== *)

Definition Pst {T} (tree : BinaryTree T) : BinaryTree T :=
  match tree with
  | Nill => Nill T
  | Node Parent _ _ _ => Parent
  end.

Fixpoint Parent_cond {T: eqType} (tree : BinaryTree T) : bool :=
  match tree with
  | Nill => true
  | Node P L _ R =>
    (if P == Nill T then true
     else (Lst P == tree) || (Rst P == tree)) &&
    (if L == Nill T then true
     else Pst L == tree) &&
    (if R == Nill T then true
     else Pst R == tree) &&
    Parent_cond P && Parent_cond L && Parent_cond R
  end.

(* =========================== *)
(* ### ------ BST with parents *)
(* =========================== *)

Inductive BSTwP : BinaryTree nat -> Prop :=
  | wP_constr : forall tree, BST tree -> Parent_cond tree -> BSTwP tree.

Definition BSTwPeq (tree : BinaryTree nat) : bool :=
  BSTeq tree && Parent_cond tree.

Lemma bstwpP (tree : BinaryTree nat) : reflect (BSTwP tree) (BSTwPeq tree).
Proof.
  unfold BSTwPeq.
  case: andP => cond; constructor.
  - constructor; case: cond => //;
    case: bstP => //.
  - move => H; apply: cond.
    case: H => t bst_cond parent_cond. split => //.
    by case: bstP.
Qed.

Fixpoint BSTwP_insert (value : nat) (tree : BinaryTree nat) : BinaryTree nat :=
    match tree with
    | Nill                => Node (null -| 5 |- null) null value null
    | Node _ Left y Right =>
        if value < y
        then (BSTwP_insert value Left) -| y |- Right
        else if y < value
        then Left -| y |- (BSTwP_insert value Right)
        else tree
    end.

Notation "v >>wP t" := (BSTwP_insert v t) (at level 43, left associativity).

Eval compute in (2 >>wP null).
Eval compute in (2 >>wP (@ 3)).
Eval compute in (2 >>wP (@ 1)).
Eval compute in (1 >>wP ((@ 2) -| 4 |- (@ 6))).
Eval compute in (3 >>wP ((@ 2) -| 4 |- (@ 6))).
Eval compute in (5 >>wP ((@ 2) -| 4 |- (@ 6))).
Eval compute in (7 >>wP ((@ 2) -| 4 |- (@ 6))).

Axiom Insert_cond_wP : forall value tree,
  nodes (value >>wP tree) = value :: (nodes tree).

Lemma bst_insertP (tree : BinaryTree nat) (y : nat) :
  reflect (BSTeq (y >> tree)) (BSTeq (y >>wP tree)).
Proof.
  elim: tree y => [| tp iHtp tl iHtl v tr iHtr y] /=;
        do [by constructor|].
  case: (ltngtP y v) => cond /= //.
  - case: andP => //.
    case: andP => //.
    case: andP => //.
    case: andP => //.
    case: andP => //.
    case: andP => //.
    case: andP => //.
    case: andP => //.
    by constructor.
    constructor => /=.
    case: n. solve.
    case: p4 => _.
    case: iHtl => //.
Admitted.

(* =========================== *)
(* ### ------------ Splay tree *)
(* =========================== *)


(* Re-doing Examples/Specware-Overview/MergeSort.sw in SpecwareCoq *)

Load DivideAndConquer.

Require Import List.
Import ListNotations.
Require Import Coq.Arith.Arith_base.
Require Import Coq.Arith.Div2.
Require Import Coq.Wellfounded.Wellfounded.
Require Import Coq.Relations.Relation_Operators.

(***
 *** Definitions of "sorted" and "permutation-of"
 ***)

(* A list is sorted iff it is empty, a singleton, or its first element is no
greater than its second and its tail is sorted. *)
Fixpoint sorted (l: list nat) : Prop :=
  match l with
    | [] => True
    | x::l' =>
      (match l' with
         | [] => True
         | y::_ => x <= y /\ sorted l'
       end)
  end.

(* Two lists are permutations of each other iff they have the same number of
occurrences of all elements. *)
Definition permOf (l1 l2: list nat) : Prop :=
  forall x, count_occ eq_nat_dec l1 x = count_occ eq_nat_dec l2 x.

Lemma permOf_refl l : permOf l l.
  intro x; reflexivity.
Qed.

Lemma permOf_sym l1 l2 : permOf l1 l2 -> permOf l2 l1.
  intros pof x; symmetry; apply (pof x).
Qed.

Lemma permOf_trans l1 l2 l3 :
  permOf l1 l2 -> permOf l2 l3 -> permOf l1 l3.
  intros pof12 pof23 x.
  rewrite (pof12 x). apply pof23.
Qed.

Lemma permOf_cons x l1 l2 :
  permOf l1 l2 -> permOf (x::l1) (x::l2).
  intros pof y. destruct (eq_nat_dec x y).
  rewrite (count_occ_cons_eq _ _ e); rewrite (count_occ_cons_eq _ _ e).
  f_equal; apply pof.
  rewrite (count_occ_cons_neq _ _ n); rewrite (count_occ_cons_neq _ _ n).
  apply pof.
Qed.

Lemma permOf_swap x y l : permOf (x::y::l) (y::x::l).
  intro z; unfold count_occ; fold (count_occ eq_nat_dec l).
  destruct (eq_nat_dec x z); destruct (eq_nat_dec y z); reflexivity.
Qed.

Lemma permOf_nil_cons x l : ~(permOf [] (x::l)).
  intro pof.
  assert (0 = count_occ eq_nat_dec (x::l) x); [ apply pof | ].
  rewrite (count_occ_cons_eq eq_nat_dec l eq_refl) in H.
  discriminate.
Qed.

Lemma permOf_app_cons l1 x l2 :
  permOf (l1 ++ x::l2) (x::l1 ++ l2).
  induction l1.
  intro y; reflexivity.
  intro y.
  unfold app; fold (app l1).
  unfold count_occ; fold (count_occ eq_nat_dec (l1++x::l2));
  fold (count_occ eq_nat_dec (l1++l2)).
  rewrite (IHl1 y).
  case_eq (eq_nat_dec a y); intros; case_eq (eq_nat_dec x y); intros.
  unfold count_occ; rewrite H0; reflexivity.
  unfold count_occ; rewrite H0; reflexivity.
  unfold count_occ; rewrite H0; reflexivity.
  unfold count_occ; rewrite H0; reflexivity.
Qed.

Lemma permOf_cons_in x l1 l2 :
  permOf (x::l1) l2 -> In x l2.
  intro pof.
  apply (proj2 (count_occ_In eq_nat_dec _ _)).
  rewrite <- pof.
  unfold count_occ; destruct (eq_nat_dec x x).
  apply lt_0_Sn.
  elimtype False; apply (n eq_refl).
Qed.

Lemma in_split_set x l :
  In x l -> { l1 : list nat & { l2 : list nat & l = l1 ++ x :: l2 } }.
  induction l; intros.
  elimtype False; apply H.
  destruct (eq_nat_dec a x).
  rewrite e. exists []; exists l; reflexivity.
  assert (In x l).
  destruct H; [ contradiction | assumption ].
  destruct (IHl H0) as [ l1 X ]; destruct X as [ l2 e ].
  exists (a::l1); exists l2. rewrite e. reflexivity.
Qed.

Lemma permOf_cons_inv x l1 l2 :
  permOf (x::l1) (x::l2) -> permOf l1 l2.
  intros pof y.
  assert (count_occ eq_nat_dec (x::l1) y =
          count_occ eq_nat_dec (x::l2) y); [ apply pof | ].
  unfold count_occ in H; fold (count_occ eq_nat_dec) in H.
  destruct (eq_nat_dec x y).
  injection H; intros; assumption.
  assumption.
Qed.

Lemma permOf_app l1 l1' l2 l2' :
  permOf l1 l1' -> permOf l2 l2' -> permOf (l1++l2) (l1'++l2').
  revert l1' l2 l2'; induction l1; intros.
  destruct l1'.
  assumption.
  elimtype False; apply (permOf_nil_cons n l1'); assumption.
  assert (In a l1').
  apply (permOf_cons_in _ l1); assumption.
  destruct (in_split_set a l1' H1) as [ l1'' X ]; destruct X as [ l2'' e ].
  rewrite e. rewrite <- app_assoc.
  rewrite <- app_comm_cons. rewrite <- app_comm_cons.
  apply (permOf_trans _ (a :: l1'' ++ l2'' ++ l2')).
  apply permOf_cons.
  rewrite app_assoc.
  apply IHl1.
  rewrite e in H.
  apply (permOf_cons_inv a).
  apply (permOf_trans _ _ _ H).
  apply permOf_app_cons.
  assumption.
  apply permOf_sym.
  apply permOf_app_cons.
Qed.

(***
 *** The high-level spec for sorting
 ***)

Spec Sorting.

Spec Variable sort : (list nat -> list nat).
Spec Axiom sort_correct :
  (forall l, sorted (sort l) /\ permOf l (sort l)).

Spec End Sorting.

(***
 *** The MergeSort0 spec, which instantiates all the elements of the
 *** DivideAndConquer_base spec for merge-sort.
 ***)

Spec MergeSort0.

(* Domain and range types *)
Spec Definition D : Type := (list nat).
Spec Definition R : Type := (list nat).

(* Input / output predicate *)
Spec Definition IO : (D -> R -> Prop) :=
  (fun lin lout => sorted lout /\ permOf lin lout).

(* The well-founded partial order on the inputs *)
Spec Definition smaller : (D -> D -> Prop) :=
  (fun l1 l2 => length l1 < length l2).

(* Proof that smaller is well-founded. Note that we make this a Definition
instead of a Theorem because DivideAndConquer_base requires well-foundedness to
be a subtype predicate and not an axiom. *)
Definition smaller_wf : (well_founded smaller) :=
  (well_founded_ltof _ _).

(***
 *** The base case, which is directly sorting a singleton list
 ***)

(* Test if a list is empty or a singleton; leb is the decision procedure for
deciding less-than-or-equal. *)
Spec Definition primitive : (D -> bool) :=
  (fun l => leb (length l) 1).

(* Sorting for an empty or singleton list is just the identity *)
Spec Definition direct_solve : (D -> R) := (fun l => l).

(***
 *** The decompose operation; requires list prefix and suffix
 ***)

(* Take the prefix of l of length <= n *)
Fixpoint list_prefix n l : list nat :=
  match n with
    | 0 => []
    | S n' =>
      match l with
        | [] => []
        | x::l' => x :: list_prefix n' l'
      end
  end.

(* Lemma: the length of list_prefix n l is no greater than n *)
Lemma list_prefix_len n l : length (list_prefix n l) <= n.
  revert l; induction n; intros.
  reflexivity.
  destruct l.
  apply le_0_n.
  apply le_n_S. apply IHn.
Qed.

(* Take the suffix of l, removing the first n elements, if they exist *)
Fixpoint list_suffix n l : list nat :=
  match n with
    | 0 => l
    | S n' =>
      match l with
        | [] => []
        | x::l' => list_suffix n' l'
      end
  end.

(* Lemma: the length of list_suffix n l is length l - n *)
Lemma list_suffix_len n l : length (list_suffix n l) = length l - n.
  revert l; induction n; intro l; destruct l; try reflexivity.
  unfold list_suffix; fold list_suffix.
  unfold length; fold (length l); fold (length (list_suffix n l)).
  apply IHn.
Qed.

(* Appending the prefix and the suffix yields the original list *)
Lemma list_prefix_suffix_eq n l : list_prefix n l ++ list_suffix n l = l.
  revert l; induction n; intro l; [ | destruct l ].
  reflexivity.
  reflexivity.
  unfold list_prefix; fold list_prefix.
  unfold list_suffix; fold list_suffix.
  unfold app; fold (app (list_prefix n l)).
  f_equal.
  apply IHn.
Qed.

(* The decompose operator splits a list into prefix and suffix *)
Spec Definition decompose : (D -> D * D) :=
  (fun l => (list_prefix (div2 (length l)) l,
             list_suffix (div2 (length l)) l)).

(* Proof that decompose yields smaller lists. As with smaller_wf, we make this a
Definition and not a Theorem because DivideAndConquer_base needs it as a proof
of a subtype predicate. *)
Definition decompose_smallerH l :
  primitive l = false ->
  smaller (fst (decompose l)) l /\ smaller (snd (decompose l)) l.
  intro H; unfold decompose, smaller, def, fst, snd.
  assert (1 < length l).
  apply leb_complete_conv. assumption.
  split.
  apply (le_lt_trans _ (div2 (length l))).
  apply list_prefix_len. apply lt_div2.
  transitivity 1; [ constructor | assumption ].
  rewrite list_suffix_len.
  apply lt_minus.
  apply lt_le_weak. apply lt_div2.
  transitivity 1; [ constructor | assumption ].
  destruct l.
  inversion H0.
  destruct l.
  inversion H0; inversion H2.
  apply lt_0_Sn.
Qed.

Definition decompose_smaller :
  (forall l,
     primitive l = false ->
     smaller (fst (decompose l)) l /\ smaller (snd (decompose l)) l) :=
  decompose_smallerH.

(***
 *** The compose operation, which requires list merge
 ***)

(* The length order on pairs of lists, which requires one of the two lists in
the pair to be smaller and the other to be the same list; this is called the
symmetric product of the length ordering. *)
Definition list_pair_smaller : list nat * list nat -> list nat * list nat -> Prop :=
  symprod _ _ smaller smaller.

(* Merge two lists *)
Function merge_lists (l_pair: list nat * list nat) {wf list_pair_smaller l_pair} : list nat :=
  let (l1,l2) := l_pair in
  match l1 with
    | [] => l2
    | x1::l1' =>
      match l2 with
        | [] => l1
        | x2::l2' =>
          if lt_dec x1 x2 then
            x1::merge_lists (l1',l2)
          else
            x2::merge_lists (l1,l2')
      end
  end.
intros. apply left_sym. apply le_n.
intros. apply right_sym. apply le_n.
apply wf_symprod; apply smaller_wf.
Defined.

(* Helper lemma: merge_lists applied to two cons lists yields a result whose
head is one of the two heads of the two lists. *)
Lemma merge_lists_cons_cons x1 l1 x2 l2 :
  {merge_lists (x1::l1, x2::l2) = x1::merge_lists (l1,x2::l2)} +
  {merge_lists (x1::l1, x2::l2) = x2::merge_lists (x1::l1,l2)}.
  assert (forall l_pair,
            l_pair = (x1::l1, x2::l2) ->
            {merge_lists l_pair = x1::merge_lists (l1,x2::l2)} +
            {merge_lists l_pair = x2::merge_lists (x1::l1,l2)}).
  intro l_pair; functional induction (merge_lists l_pair); intros; try discriminate.
  injection H; intros.
  rewrite H0; rewrite H1; rewrite H2; rewrite H3; left; reflexivity.
  injection H; intros.
  rewrite H0; rewrite H1; rewrite H2; rewrite H3; right; reflexivity.
  apply H; reflexivity.
Qed.

(* Helper lemma: merging two sorted lists is sorted *)
Lemma merge_lists_sorted l_pair :
  sorted (fst l_pair) -> sorted (snd l_pair) -> sorted (merge_lists l_pair).
  functional induction (merge_lists l_pair); unfold fst, snd; intros; try assumption.
  unfold sorted; fold sorted.
  destruct l1' as [ | x1' l1' ].
  split.
  apply lt_le_weak; assumption.
  apply IHl; [ constructor | assumption ].
  destruct (merge_lists_cons_cons x1' l1' x2 l2') as [ e_ml | e_ml ];
    rewrite e_ml; rewrite <- e_ml.
  split.
  destruct H; assumption.
  apply IHl; [ destruct H | ]; assumption.
  split.
  apply lt_le_weak; assumption.
  apply IHl; [ destruct H | ]; assumption.
  unfold sorted; fold sorted.
  destruct l2' as [ | x2' l2' ].
  split.
  destruct (le_or_lt x2 x1); [ assumption | contradiction ].
  assumption.
  destruct (merge_lists_cons_cons x1 l1' x2' l2') as [ e_ml | e_ml ];
    rewrite e_ml; rewrite <- e_ml.
  split.
  destruct (le_or_lt x2 x1); [ assumption | contradiction ].
  apply IHl; [ assumption | destruct H0; assumption ].
  split.
  destruct H0; assumption.
  apply IHl; [ assumption | destruct H0; assumption ].
Qed.

(* Helper lemma: merging lists yields a permutation of the original lists *)
Lemma merge_lists_permOf l_pair :
  permOf (fst l_pair ++ snd l_pair) (merge_lists l_pair).
  functional induction (merge_lists l_pair); unfold fst, snd.
  intro x; reflexivity.
  intro x; rewrite app_nil_r; reflexivity.
  apply permOf_cons; fold (app l1'); apply IHl.
  apply (permOf_trans _ (x2 :: (x1 :: l1') ++ l2')).
  apply permOf_app_cons.
  apply permOf_cons. apply IHl.
Qed.

Spec Definition compose : (R -> R -> R) := (fun l1 l2 => merge_lists (l1,l2)).

(***
 *** Correctness theorems for the base and step cases
 ***)

(* Theorem: direct_solve is correct for primitive problems *)
Spec Theorem direct_solve_correct :
  (forall l, primitive l = true -> IO l (direct_solve l)).
  unfold primitive, D, IO, direct_solve, def; intros.
  destruct l.
  (* Prove correctness for the empty list *)
  split.
  unfold sorted; trivial.
  unfold permOf; intros; reflexivity.

  destruct l.
  (* Prove correctness for singleton lists *)
  split.
  unfold sorted; trivial.
  unfold permOf; intros; reflexivity.

  (* Lists with more than 1 element contradict primitive l = true *)
  discriminate H.
Qed.

(* Theorem: if we solve the two decomposed problems then composing them is a
solution *)
Spec Theorem solve_soundness :
  (forall l lout1 lout2,
     IO (fst (decompose l)) lout1 ->
     IO (snd (decompose l)) lout2 ->
     IO l (compose lout1 lout2)).
  unfold D, R, decompose, compose, IO, def, fst, snd.
  intros l lout1 lout2 conj1 conj2; destruct conj1; destruct conj2.
  split.
  apply merge_lists_sorted; assumption.
  rewrite <- (list_prefix_suffix_eq (div2 (length l)) l).
  apply (permOf_trans _ (lout1 ++ lout2)).
  apply permOf_app; assumption.
  fold (fst (lout1,lout2)); fold (snd (lout1,lout2)).
  apply merge_lists_permOf.
Qed.

Spec End MergeSort0.

(***
 *** Now we make an interpretation from DivideAndConquer_base to MergeSort0
 ***)

Spec Interpretation DC_MergeSort0 : DivideAndConquer_base -> MergeSort0.
prove_simple_interp {{ }}.
apply (MergeSort0.smaller_wf (D__proof__param:=pf) (smaller__proof__param:=eq_refl)).
intros d H.
Check MergeSort0.decompose_smaller.
apply (MergeSort0.decompose_smaller
         (smaller__proof__param:=pf2) (primitive__proof__param:=pf3)
         (decompose__proof__param:=eq_refl)
         d H).
apply (MergeSort0.direct_solve_correct
         (D__param:=t) (D__proof__param:=pf) (R__param:=t0) (R__proof__param:=pf0)
         (IO__param:=t1) (IO__proof__param:=pf1)
         (primitive__param:=t3) (primitive__proof__param:=pf3)
         (direct_solve__proof__param:=pf4)
         d H).
apply (MergeSort0.solve_soundness
         (IO__proof__param:=pf1) (smaller__proof__param:=pf2)
         (decompose__proof__param:=pf5) (compose__proof__param:=pf6)
         _ _ _ H H0).
apply (MergeSort0.solve_soundness
         (IO__proof__param:=pf1) (smaller__proof__param:=pf2)
         (decompose__proof__param:=pf5) (compose__proof__param:=pf6)
         _ _ _ H H0).
Defined.