Require Import Arith Bool List Omega.
Require Import Cpdt.CpdtTactics Cpdt.MoreSpecif.
Require Coq.extraction.Extraction.

Set Implicit Arguments.
Set Asymmetric Patterns.

(* Chapter 8. More Dependent Types *)

(* 8.1 Length-Indexed Lists *)

Section ilist.
  Variable A : Set.

  Inductive ilist : nat -> Set :=
  | Nil : ilist O
  | Cons : forall n, A -> ilist n -> ilist (S n).

  (* We may apply ilist to any natural number, even natural numbers that are
     only known at runtime.  It is this breaking of the _phase distinction_
     that characterizes ilist as _dependently typed_. *)

  (* Old version of Coq rejects this *)
  Fixpoint app n1 (ls1 : ilist n1) n2 (ls2 : ilist n2) : ilist (n1 + n2) :=
    match ls1 with
      | Nil => ls2
      | Cons _ x ls1' => Cons x (app ls1' ls2)
    end.

  (* return: expresses dependency of the match result type on the _value_
             being matched
     in:     expresses dependency of the match result type on the _type_
             being matched *)
  Fixpoint app' n1 (ls1 : ilist n1) n2 (ls2 : ilist n2) : ilist (n1 + n2) :=
    match ls1 in (ilist n1) return (ilist (n1 + n2)) with
      | Nil => ls2
      | Cons _ x ls1' => Cons x (app' ls1' ls2)
          (* ^ parameters! *)
    end.

  (* app can be typed in "stratified type systems"
     ... the length indices can be treated as compile-time-only type information
         whereas the "list" type information cannot *)

  (* example where length indices cannot be erased in the runtime *)
  Fixpoint inject (ls : list A) : ilist (length ls) :=
    match ls with
      | nil => Nil
      | h :: t => Cons h (inject t)
    end.

  Fixpoint unject n (ls : ilist n) : list A :=
    match ls with
      | Nil => nil
      | Cons _ h t => h :: unject t
    end.

  Theorem inject_inverse : forall ls, unject (inject ls) = ls.
  Proof.
    induction ls.
    - reflexivity.
    - simpl. rewrite IHls. reflexivity.
  Qed.

  (* unsuccessful attempt to write "hd" function ...
       Definition hd n (ls : ilist (S n)) : A :=
         match ls with
           | Nil => ???
           | Cons _ h _ => h
         end.

     or...

       Definition hd n (ls : ilist (S n)) : A :=
         match ls with  (* inexhaustive pattern match *)
           | Cons _ h _ => h
         end.
   *)

  (* Actually the recent Coq supports inexhaustive match iff the return type
     is correct. Let's try to use this...

      Definition hd n (ls : ilist (S n)) : A :=
        match ls in (ilist (S n)) with
          | Cons _ h _ => h
        end.

      ... which fails, because S (in [ilist (S n)]) is not variable!
          No non-variables are allowed in [in] clauses.
          (Continues to next chapters)
   *)

  (* Our final definition *)
  Definition hd' n (ls : ilist n) :=
    match ls in (ilist n) return (match n with O => unit | S _ => A end) with
      | Nil => tt
      | Cons _ h _ => h
    end.

  (* This passes because the index of [ls] is known to be nonzero *)
  Definition hd n (ls : ilist (S n)) : A := hd' ls.
End ilist.

(* 8.2 The One Rule of Dependent Pattern Matching in Coq *)

(** The rest of this chapter will demonstrate a few other elegant applications of dependent types in Coq.  Readers encountering such ideas for the first time often feel overwhelmed, concluding that there is some magic at work whereby Coq sometimes solves the halting problem for the programmer and sometimes does not, applying automated program understanding in a way far beyond what is found in conventional languages.  The point of this section is to cut off that sort of thinking right now!  Dependent type-checking in Coq follows just a few algorithmic rules.  Chapters 10 and 12 introduce many of those rules more formally, and the main additional rule is centered on%\index{dependent pattern matching}% _dependent pattern matching_ of the kind we met in the previous section.

A dependent pattern match is a [match] expression where the type of the overall [match] is a function of the value and/or the type of the%\index{discriminee}% _discriminee_, the value being matched on.  In other words, the [match] type _depends_ on the discriminee.

When exactly will Coq accept a dependent pattern match as well-typed?  Some other dependently typed languages employ fancy decision procedures to determine when programs satisfy their very expressive types.  The situation in Coq is just the opposite.  Only very straightforward symbolic rules are applied.  Such a design choice has its drawbacks, as it forces programmers to do more work to convince the type checker of program validity.  However, the great advantage of a simple type checking algorithm is that its action on _invalid_ programs is easier to understand!

We come now to the one rule of dependent pattern matching in Coq.  A general dependent pattern match assumes this form (with unnecessary parentheses included to make the syntax easier to parse):
[[
  match E as y in (T x1 ... xn) return U with
    | C z1 ... zm => B
    | ...
  end
]]

The discriminee is a term [E], a value in some inductive type family [T], which takes [n] arguments.  An %\index{as clause}%[as] clause binds the name [y] to refer to the discriminee [E].  An %\index{in clause}%[in] clause binds an explicit name [xi] for the [i]th argument passed to [T] in the type of [E].

We bind these new variables [y] and [xi] so that they may be referred to in [U], a type given in the %\index{return clause}%[return] clause.  The overall type of the [match] will be [U], with [E] substituted for [y], and with each [xi] substituted by the actual argument appearing in that position within [E]'s type.

In general, each case of a [match] may have a pattern built up in several layers from the constructors of various inductive type families.  To keep this exposition simple, we will focus on patterns that are just single applications of inductive type constructors to lists of variables.  Coq actually compiles the more general kind of pattern matching into this more restricted kind automatically, so understanding the typing of [match] requires understanding the typing of [match]es lowered to match one constructor at a time.

The last piece of the typing rule tells how to type-check a [match] case.  A generic constructor application [C z1 ... zm] has some type [T x1' ... xn'], an application of the type family used in [E]'s type, probably with occurrences of the [zi] variables.  From here, a simple recipe determines what type we will require for the case body [B].  The type of [B] should be [U] with the following two substitutions applied: we replace [y] (the [as] clause variable) with [C z1 ... zm], and we replace each [xi] (the [in] clause variables) with [xi'].  In other words, we specialize the result type based on what we learn based on which pattern has matched the discriminee.

This is an exhaustive description of the ways to specify how to take advantage of which pattern has matched!  No other mechanisms come into play.  For instance, there is no way to specify that the types of certain free variables should be refined based on which pattern has matched.  In the rest of the book, we will learn design patterns for achieving similar effects, where each technique leads to an encoding only in terms of [in], [as], and [return] clauses.

A few details have been omitted above.  In Chapter 3, we learned that inductive type families may have both%\index{parameters}% _parameters_ and regular arguments.  Within an [in] clause, a parameter position must have the wildcard [_] written, instead of a variable.  (In general, Coq uses wildcard [_]'s either to indicate pattern variables that will not be mentioned again or to indicate positions where we would like type inference to infer the appropriate terms.)  Furthermore, recent Coq versions are adding more and more heuristics to infer dependent [match] annotations in certain conditions.  The general annotation inference problem is undecidable, so there will always be serious limitations on how much work these heuristics can do.  When in doubt about why a particular dependent [match] is failing to type-check, add an explicit [return] annotation!  At that point, the mechanical rule sketched in this section will provide a complete account of "what the type checker is thinking."  Be sure to avoid the common pitfall of writing a [return] annotation that does not mention any variables bound by [in] or [as]; such a [match] will never refine typing requirements based on which pattern has matched.  (One simple exception to this rule is that, when the discriminee is a variable, that same variable may be treated as if it were repeated as an [as] clause.) *)

(** * A Tagless Interpreter *)

(** A favorite example for motivating the power of functional programming is implementation of a simple expression language interpreter.  In ML and Haskell, such interpreters are often implemented using an algebraic datatype of values, where at many points it is checked that a value was built with the right constructor of the value type.  With dependent types, we can implement a%\index{tagless interpreters}% _tagless_ interpreter that both removes this source of runtime inefficiency and gives us more confidence that our implementation is correct. *)

Inductive type : Set :=
| Nat : type
| Bool : type
| Prod : type -> type -> type.

Inductive exp : type -> Set :=
| NConst : nat -> exp Nat
| Plus : exp Nat -> exp Nat -> exp Nat
| Eq : exp Nat -> exp Nat -> exp Bool

| BConst : bool -> exp Bool
| And : exp Bool -> exp Bool -> exp Bool
| If : forall t, exp Bool -> exp t -> exp t -> exp t

| Pair : forall t1 t2, exp t1 -> exp t2 -> exp (Prod t1 t2)
| Fst : forall t1 t2, exp (Prod t1 t2) -> exp t1
| Snd : forall t1 t2, exp (Prod t1 t2) -> exp t2.

(** We have a standard algebraic datatype [type], defining a type language of naturals, Booleans, and product (pair) types.  Then we have the indexed inductive type [exp], where the argument to [exp] tells us the encoded type of an expression.  In effect, we are defining the typing rules for expressions simultaneously with the syntax.

   We can give types and expressions semantics in a new style, based critically on the chance for _type-level computation_. *)

Fixpoint typeDenote (t : type) : Set :=
  match t with
    | Nat => nat
    | Bool => bool
    | Prod t1 t2 => typeDenote t1 * typeDenote t2
  end%type.

(** The [typeDenote] function compiles types of our object language into "native" Coq types.  It is deceptively easy to implement.  The only new thing we see is the [%]%\coqdocvar{%#<tt>#type#</tt>#%}% annotation, which tells Coq to parse the [match] expression using the notations associated with types.  Without this annotation, the [*] would be interpreted as multiplication on naturals, rather than as the product type constructor.  The token %\coqdocvar{%#<tt>#type#</tt>#%}% is one example of an identifier bound to a%\index{notation scope delimiter}% _notation scope delimiter_.  In this book, we will not go into more detail on notation scopes, but the Coq manual can be consulted for more information.

   We can define a function [expDenote] that is typed in terms of [typeDenote]. *)

Fixpoint expDenote t (e : exp t) : typeDenote t :=
  match e with
    | NConst n => n
    | Plus e1 e2 => expDenote e1 + expDenote e2
    | Eq e1 e2 => if eq_nat_dec (expDenote e1) (expDenote e2) then true else false

    | BConst b => b
    | And e1 e2 => expDenote e1 && expDenote e2
    | If _ e' e1 e2 => if expDenote e' then expDenote e1 else expDenote e2

    | Pair _ _ e1 e2 => (expDenote e1, expDenote e2)
    | Fst _ _ e' => fst (expDenote e')
    | Snd _ _ e' => snd (expDenote e')
  end.

(* begin hide *)
(* begin thide *)
Definition sumboool := sumbool.
(* end thide *)
(* end hide *)

(** Despite the fancy type, the function definition is routine.  In fact, it is less complicated than what we would write in ML or Haskell 98, since we do not need to worry about pushing final values in and out of an algebraic datatype.  The only unusual thing is the use of an expression of the form [if E then true else false] in the [Eq] case.  Remember that [eq_nat_dec] has a rich dependent type, rather than a simple Boolean type.  Coq's native [if] is overloaded to work on a test of any two-constructor type, so we can use [if] to build a simple Boolean from the [sumbool] that [eq_nat_dec] returns.

   We can implement our old favorite, a constant folding function, and prove it correct.  It will be useful to write a function [pairOut] that checks if an [exp] of [Prod] type is a pair, returning its two components if so.  Unsurprisingly, a first attempt leads to a type error.
[[
Definition pairOut t1 t2 (e : exp (Prod t1 t2)) : option (exp t1 * exp t2) :=
  match e in (exp (Prod t1 t2)) return option (exp t1 * exp t2) with
    | Pair _ _ e1 e2 => Some (e1, e2)
    | _ => None
  end.
]]

<<
Error: The reference t2 was not found in the current environment
>>

We run again into the problem of not being able to specify non-variable arguments in [in] clauses.  The problem would just be hopeless without a use of an [in] clause, though, since the result type of the [match] depends on an argument to [exp].  Our solution will be to use a more general type, as we did for [hd].  First, we define a type-valued function to use in assigning a type to [pairOut]. *)

(* EX: Define a function [pairOut : forall t1 t2, exp (Prod t1 t2) -> option (exp t1 * exp t2)] *)

(* begin thide *)
Definition pairOutType (t : type) := option (match t with
                                               | Prod t1 t2 => exp t1 * exp t2
                                               | _ => unit
                                             end).

(** When passed a type that is a product, [pairOutType] returns our final desired type.  On any other input type, [pairOutType] returns the harmless [option unit], since we do not care about extracting components of non-pairs.  Now [pairOut] is easy to write. *)

Definition pairOut t (e : exp t) :=
  match e in (exp t) return (pairOutType t) with
    | Pair _ _ e1 e2 => Some (e1, e2)
    | _ => None
  end.
(* end thide *)

(** With [pairOut] available, we can write [cfold] in a straightforward way.  There are really no surprises beyond that Coq verifies that this code has such an expressive type, given the small annotation burden.  In some places, we see that Coq's [match] annotation inference is too smart for its own good, and we have to turn that inference off with explicit [return] clauses. *)

Fixpoint cfold t (e : exp t) : exp t :=
  match e with
    | NConst n => NConst n
    | Plus e1 e2 =>
      let e1' := cfold e1 in
      let e2' := cfold e2 in
      match e1', e2' return exp Nat with
        | NConst n1, NConst n2 => NConst (n1 + n2)
        | _, _ => Plus e1' e2'
      end
    | Eq e1 e2 =>
      let e1' := cfold e1 in
      let e2' := cfold e2 in
      match e1', e2' return exp Bool with
        | NConst n1, NConst n2 => BConst (if eq_nat_dec n1 n2 then true else false)
        | _, _ => Eq e1' e2'
      end

    | BConst b => BConst b
    | And e1 e2 =>
      let e1' := cfold e1 in
      let e2' := cfold e2 in
      match e1', e2' return exp Bool with
        | BConst b1, BConst b2 => BConst (b1 && b2)
        | _, _ => And e1' e2'
      end
    | If _ e e1 e2 =>
      let e' := cfold e in
      match e' with
        | BConst true => cfold e1
        | BConst false => cfold e2
        | _ => If e' (cfold e1) (cfold e2)
      end

    | Pair _ _ e1 e2 => Pair (cfold e1) (cfold e2)
    | Fst _ _ e =>
      let e' := cfold e in
      match pairOut e' with
        | Some p => fst p
        | None => Fst e'
      end
    | Snd _ _ e =>
      let e' := cfold e in
      match pairOut e' with
        | Some p => snd p
        | None => Snd e'
      end
  end.

(** The correctness theorem for [cfold] turns out to be easy to prove, once we get over one serious hurdle. *)

Theorem cfold_correct : forall t (e : exp t), expDenote e = expDenote (cfold e).
(* begin thide *)
  induction e; crush.

(** The first remaining subgoal is:

   [[
  expDenote (cfold e1) + expDenote (cfold e2) =
   expDenote
     match cfold e1 with
     | NConst n1 =>
         match cfold e2 with
         | NConst n2 => NConst (n1 + n2)
         | Plus _ _ => Plus (cfold e1) (cfold e2)
         | Eq _ _ => Plus (cfold e1) (cfold e2)
         | BConst _ => Plus (cfold e1) (cfold e2)
         | And _ _ => Plus (cfold e1) (cfold e2)
         | If _ _ _ _ => Plus (cfold e1) (cfold e2)
         | Pair _ _ _ _ => Plus (cfold e1) (cfold e2)
         | Fst _ _ _ => Plus (cfold e1) (cfold e2)
         | Snd _ _ _ => Plus (cfold e1) (cfold e2)
         end
     | Plus _ _ => Plus (cfold e1) (cfold e2)
     | Eq _ _ => Plus (cfold e1) (cfold e2)
     | BConst _ => Plus (cfold e1) (cfold e2)
     | And _ _ => Plus (cfold e1) (cfold e2)
     | If _ _ _ _ => Plus (cfold e1) (cfold e2)
     | Pair _ _ _ _ => Plus (cfold e1) (cfold e2)
     | Fst _ _ _ => Plus (cfold e1) (cfold e2)
     | Snd _ _ _ => Plus (cfold e1) (cfold e2)
     end

     ]]

     We would like to do a case analysis on [cfold e1], and we attempt to do so in the way that has worked so far.
     [[
  destruct (cfold e1).
]]

<<
User error: e1 is used in hypothesis e
>>

    Coq gives us another cryptic error message.  Like so many others, this one basically means that Coq is not able to build some proof about dependent types.  It is hard to generate helpful and specific error messages for problems like this, since that would require some kind of understanding of the dependency structure of a piece of code.  We will encounter many examples of case-specific tricks for recovering from errors like this one.

    For our current proof, we can use a tactic [dep_destruct]%\index{tactics!dep\_destruct}% defined in the book's [CpdtTactics] module.  General elimination/inversion of dependently typed hypotheses is undecidable, as witnessed by a simple reduction from the known-undecidable problem of higher-order unification, which has come up a few times already.  The tactic [dep_destruct] makes a best effort to handle some common cases, relying upon the more primitive %\index{tactics!dependent destruction}%[dependent destruction] tactic that comes with Coq.  In a future chapter, we will learn about the explicit manipulation of equality proofs that is behind [dependent destruction]'s implementation, but for now, we treat it as a useful black box.  (In Chapter 12, we will also see how [dependent destruction] forces us to make a larger philosophical commitment about our logic than we might like, and we will see some workarounds.) *)

  dep_destruct (cfold e1).

  (** This successfully breaks the subgoal into 5 new subgoals, one for each constructor of [exp] that could produce an [exp Nat].  Note that [dep_destruct] is successful in ruling out the other cases automatically, in effect automating some of the work that we have done manually in implementing functions like [hd] and [pairOut].

     This is the only new trick we need to learn to complete the proof.  We can back up and give a short, automated proof (which again is safe to skip and uses Ltac features not introduced yet). *)

  Restart.

  induction e; crush;
    repeat (match goal with
              | [ |- context[match cfold ?E with NConst _ => _ | _ => _ end] ] =>
                dep_destruct (cfold E)
              | [ |- context[match pairOut (cfold ?E) with Some _ => _
                               | None => _ end] ] =>
                dep_destruct (cfold E)
              | [ |- (if ?E then _ else _) = _ ] => destruct E
            end; crush).
Qed.
(* end thide *)

(** With this example, we get a first taste of how to build automated proofs that adapt automatically to changes in function definitions. *)

(** * Dependently Typed Red-Black Trees *)

(** Red-black trees are a favorite purely functional data structure with an interesting invariant.  We can use dependent types to guarantee that operations on red-black trees preserve the invariant.  For simplicity, we specialize our red-black trees to represent sets of [nat]s. *)

Inductive color : Set := Red | Black.

Inductive rbtree : color -> nat -> Set :=
| Leaf : rbtree Black 0
| RedNode : forall n, rbtree Black n -> nat -> rbtree Black n -> rbtree Red n
| BlackNode : forall c1 c2 n, rbtree c1 n -> nat -> rbtree c2 n -> rbtree Black (S n).

(** A value of type [rbtree c d] is a red-black tree whose root has color [c] and that has black depth [d].  The latter property means that there are exactly [d] black-colored nodes on any path from the root to a leaf. *)

(** At first, it can be unclear that this choice of type indices tracks any useful property.  To convince ourselves, we will prove that every red-black tree is balanced.  We will phrase our theorem in terms of a depth calculating function that ignores the extra information in the types.  It will be useful to parameterize this function over a combining operation, so that we can re-use the same code to calculate the minimum or maximum height among all paths from root to leaf. *)

(* EX: Prove that every [rbtree] is balanced. *)

(* begin thide *)
Require Import Max Min.

Section depth.
  Variable f : nat -> nat -> nat.

  Fixpoint depth c n (t : rbtree c n) : nat :=
    match t with
      | Leaf => 0
      | RedNode _ t1 _ t2 => S (f (depth t1) (depth t2))
      | BlackNode _ _ _ t1 _ t2 => S (f (depth t1) (depth t2))
    end.
End depth.

(** Our proof of balanced-ness decomposes naturally into a lower bound and an upper bound.  We prove the lower bound first.  Unsurprisingly, a tree's black depth provides such a bound on the minimum path length.  We use the richly typed procedure [min_dec] to do case analysis on whether [min X Y] equals [X] or [Y]. *)

Check min_dec.
(** %\vspace{-.15in}% [[
min_dec
     : forall n m : nat, {min n m = n} + {min n m = m}
   ]]
   *)

Theorem depth_min : forall c n (t : rbtree c n), depth min t >= n.
  induction t; crush;
    match goal with
      | [ |- context[min ?X ?Y] ] => destruct (min_dec X Y)
    end; crush.
Qed.

(** There is an analogous upper-bound theorem based on black depth.  Unfortunately, a symmetric proof script does not suffice to establish it. *)

Theorem depth_max : forall c n (t : rbtree c n), depth max t <= 2 * n + 1.
  induction t; crush;
    match goal with
      | [ |- context[max ?X ?Y] ] => destruct (max_dec X Y)
    end; crush.

(** Two subgoals remain.  One of them is: [[
  n : nat
  t1 : rbtree Black n
  n0 : nat
  t2 : rbtree Black n
  IHt1 : depth max t1 <= n + (n + 0) + 1
  IHt2 : depth max t2 <= n + (n + 0) + 1
  e : max (depth max t1) (depth max t2) = depth max t1
  ============================
   S (depth max t1) <= n + (n + 0) + 1

   ]]

   We see that [IHt1] is _almost_ the fact we need, but it is not quite strong enough.  We will need to strengthen our induction hypothesis to get the proof to go through. *)

Abort.

(** In particular, we prove a lemma that provides a stronger upper bound for trees with black root nodes.  We got stuck above in a case about a red root node.  Since red nodes have only black children, our IH strengthening will enable us to finish the proof. *)

Lemma depth_max' : forall c n (t : rbtree c n), match c with
                                                  | Red => depth max t <= 2 * n + 1
                                                  | Black => depth max t <= 2 * n
                                                end.
  induction t; crush;
    match goal with
      | [ |- context[max ?X ?Y] ] => destruct (max_dec X Y)
    end; crush;
    repeat (match goal with
              | [ H : context[match ?C with Red => _ | Black => _ end] |- _ ] =>
                destruct C
            end; crush).
Qed.

(** The original theorem follows easily from the lemma.  We use the tactic %\index{tactics!generalize}%[generalize pf], which, when [pf] proves the proposition [P], changes the goal from [Q] to [P -> Q].  This transformation is useful because it makes the truth of [P] manifest syntactically, so that automation machinery can rely on [P], even if that machinery is not smart enough to establish [P] on its own. *)

Theorem depth_max : forall c n (t : rbtree c n), depth max t <= 2 * n + 1.
  intros; generalize (depth_max' t); destruct c; crush.
Qed.

(** The final balance theorem establishes that the minimum and maximum path lengths of any tree are within a factor of two of each other. *)

Theorem balanced : forall c n (t : rbtree c n), 2 * depth min t + 1 >= depth max t.
  intros; generalize (depth_min t); generalize (depth_max t); crush.
Qed.
(* end thide *)

(** Now we are ready to implement an example operation on our trees, insertion.  Insertion can be thought of as breaking the tree invariants locally but then rebalancing.  In particular, in intermediate states we find red nodes that may have red children.  The type [rtree] captures the idea of such a node, continuing to track black depth as a type index. *)

Inductive rtree : nat -> Set :=
| RedNode' : forall c1 c2 n, rbtree c1 n -> nat -> rbtree c2 n -> rtree n.

(** Before starting to define [insert], we define predicates capturing when a data value is in the set represented by a normal or possibly invalid tree. *)

Section present.
  Variable x : nat.

  Fixpoint present c n (t : rbtree c n) : Prop :=
    match t with
      | Leaf => False
      | RedNode _ a y b => present a \/ x = y \/ present b
      | BlackNode _ _ _ a y b => present a \/ x = y \/ present b
    end.

  Definition rpresent n (t : rtree n) : Prop :=
    match t with
      | RedNode' _ _ _ a y b => present a \/ x = y \/ present b
    end.
End present.

(** Insertion relies on two balancing operations.  It will be useful to give types to these operations using a relative of the subset types from last chapter.  While subset types let us pair a value with a proof about that value, here we want to pair a value with another non-proof dependently typed value.  The %\index{Gallina terms!sigT}%[sigT] type fills this role. *)

Locate "{ _ : _ & _ }".
(** %\vspace{-.15in}%[[
Notation            Scope
"{ x : A  & P }" := sigT (fun x : A => P)
]]
*)

Print sigT.
(** %\vspace{-.15in}%[[
Inductive sigT (A : Type) (P : A -> Type) : Type :=
    existT : forall x : A, P x -> sigT P
]]
*)

(** It will be helpful to define a concise notation for the constructor of [sigT]. *)

Notation "{< x >}" := (existT _ _ x).

(** Each balance function is used to construct a new tree whose keys include the keys of two input trees, as well as a new key.  One of the two input trees may violate the red-black alternation invariant (that is, it has an [rtree] type), while the other tree is known to be valid.  Crucially, the two input trees have the same black depth.

   A balance operation may return a tree whose root is of either color.  Thus, we use a [sigT] type to package the result tree with the color of its root.  Here is the definition of the first balance operation, which applies when the possibly invalid [rtree] belongs to the left of the valid [rbtree].

   A quick word of encouragement: After writing this code, even I do not understand the precise details of how balancing works!  I consulted Chris Okasaki's paper "Red-Black Trees in a Functional Setting" %\cite{Okasaki} %and transcribed the code to use dependent types.  Luckily, the details are not so important here; types alone will tell us that insertion preserves balanced-ness, and we will prove that insertion produces trees containing the right keys.*)

Definition balance1 n (a : rtree n) (data : nat) c2 :=
  match a in rtree n return rbtree c2 n
    -> { c : color & rbtree c (S n) } with
    | RedNode' _ c0 _ t1 y t2 =>
      match t1 in rbtree c n return rbtree c0 n -> rbtree c2 n
        -> { c : color & rbtree c (S n) } with
        | RedNode _ a x b => fun c d =>
          {<RedNode (BlackNode a x b) y (BlackNode c data d)>}
        | t1' => fun t2 =>
          match t2 in rbtree c n return rbtree Black n -> rbtree c2 n
            -> { c : color & rbtree c (S n) } with
            | RedNode _ b x c => fun a d =>
              {<RedNode (BlackNode a y b) x (BlackNode c data d)>}
            | b => fun a t => {<BlackNode (RedNode a y b) data t>}
          end t1'
      end t2
  end.

(** We apply a trick that I call the%\index{convoy pattern}% _convoy pattern_.  Recall that [match] annotations only make it possible to describe a dependence of a [match] _result type_ on the discriminee.  There is no automatic refinement of the types of free variables.  However, it is possible to effect such a refinement by finding a way to encode free variable type dependencies in the [match] result type, so that a [return] clause can express the connection.

   In particular, we can extend the [match] to return _functions over the free variables whose types we want to refine_.  In the case of [balance1], we only find ourselves wanting to refine the type of one tree variable at a time.  We match on one subtree of a node, and we want the type of the other subtree to be refined based on what we learn.  We indicate this with a [return] clause starting like [rbtree _ n -> ...], where [n] is bound in an [in] pattern.  Such a [match] expression is applied immediately to the "old version" of the variable to be refined, and the type checker is happy.

   Here is the symmetric function [balance2], for cases where the possibly invalid tree appears on the right rather than on the left. *)

Definition balance2 n (a : rtree n) (data : nat) c2 :=
  match a in rtree n return rbtree c2 n -> { c : color & rbtree c (S n) } with
    | RedNode' _ c0 _ t1 z t2 =>
      match t1 in rbtree c n return rbtree c0 n -> rbtree c2 n
        -> { c : color & rbtree c (S n) } with
        | RedNode _ b y c => fun d a =>
          {<RedNode (BlackNode a data b) y (BlackNode c z d)>}
        | t1' => fun t2 =>
          match t2 in rbtree c n return rbtree Black n -> rbtree c2 n
            -> { c : color & rbtree c (S n) } with
            | RedNode _ c z' d => fun b a =>
              {<RedNode (BlackNode a data b) z (BlackNode c z' d)>}
            | b => fun a t => {<BlackNode t data (RedNode a z b)>}
          end t1'
      end t2
  end.

(** Now we are almost ready to get down to the business of writing an [insert] function.  First, we enter a section that declares a variable [x], for the key we want to insert. *)

Section insert.
  Variable x : nat.

  (** Most of the work of insertion is done by a helper function [ins], whose return types are expressed using a type-level function [insResult]. *)

  Definition insResult c n :=
    match c with
      | Red => rtree n
      | Black => { c' : color & rbtree c' n }
    end.

  (** That is, inserting into a tree with root color [c] and black depth [n], the variety of tree we get out depends on [c].  If we started with a red root, then we get back a possibly invalid tree of depth [n].  If we started with a black root, we get back a valid tree of depth [n] with a root node of an arbitrary color.

     Here is the definition of [ins].  Again, we do not want to dwell on the functional details. *)

  Fixpoint ins c n (t : rbtree c n) : insResult c n :=
    match t with
      | Leaf => {< RedNode Leaf x Leaf >}
      | RedNode _ a y b =>
        if le_lt_dec x y
          then RedNode' (projT2 (ins a)) y b
          else RedNode' a y (projT2 (ins b))
      | BlackNode c1 c2 _ a y b =>
        if le_lt_dec x y
          then
            match c1 return insResult c1 _ -> _ with
              | Red => fun ins_a => balance1 ins_a y b
              | _ => fun ins_a => {< BlackNode (projT2 ins_a) y b >}
            end (ins a)
          else
            match c2 return insResult c2 _ -> _ with
              | Red => fun ins_b => balance2 ins_b y a
              | _ => fun ins_b => {< BlackNode a y (projT2 ins_b) >}
            end (ins b)
    end.

  (** The one new trick is a variation of the convoy pattern.  In each of the last two pattern matches, we want to take advantage of the typing connection between the trees [a] and [b].  We might %\%naive%{}%ly apply the convoy pattern directly on [a] in the first [match] and on [b] in the second.  This satisfies the type checker per se, but it does not satisfy the termination checker.  Inside each [match], we would be calling [ins] recursively on a locally bound variable.  The termination checker is not smart enough to trace the dataflow into that variable, so the checker does not know that this recursive argument is smaller than the original argument.  We make this fact clearer by applying the convoy pattern on _the result of a recursive call_, rather than just on that call's argument.

     Finally, we are in the home stretch of our effort to define [insert].  We just need a few more definitions of non-recursive functions.  First, we need to give the final characterization of [insert]'s return type.  Inserting into a red-rooted tree gives a black-rooted tree where black depth has increased, and inserting into a black-rooted tree gives a tree where black depth has stayed the same and where the root is an arbitrary color. *)

  Definition insertResult c n :=
    match c with
      | Red => rbtree Black (S n)
      | Black => { c' : color & rbtree c' n }
    end.

  (** A simple clean-up procedure translates [insResult]s into [insertResult]s. *)

  Definition makeRbtree c n : insResult c n -> insertResult c n :=
    match c with
      | Red => fun r =>
        match r with
          | RedNode' _ _ _ a x b => BlackNode a x b
        end
      | Black => fun r => r
    end.

  (** We modify Coq's default choice of implicit arguments for [makeRbtree], so that we do not need to specify the [c] and [n] arguments explicitly in later calls. *)

  Implicit Arguments makeRbtree [c n].

  (** Finally, we define [insert] as a simple composition of [ins] and [makeRbtree]. *)

  Definition insert c n (t : rbtree c n) : insertResult c n :=
    makeRbtree (ins t).

  (** As we noted earlier, the type of [insert] guarantees that it outputs balanced trees whose depths have not increased too much.  We also want to know that [insert] operates correctly on trees interpreted as finite sets, so we finish this section with a proof of that fact. *)

  Section present.
    Variable z : nat.

    (** The variable [z] stands for an arbitrary key.  We will reason about [z]'s presence in particular trees.  As usual, outside the section the theorems we prove will quantify over all possible keys, giving us the facts we wanted.

       We start by proving the correctness of the balance operations.  It is useful to define a custom tactic [present_balance] that encapsulates the reasoning common to the two proofs.  We use the keyword %\index{Vernacular commands!Ltac}%[Ltac] to assign a name to a proof script.  This particular script just iterates between [crush] and identification of a tree that is being pattern-matched on and should be destructed. *)

    Ltac present_balance :=
      crush;
      repeat (match goal with
                | [ _ : context[match ?T with Leaf => _ | _ => _ end] |- _ ] =>
                  dep_destruct T
                | [ |- context[match ?T with Leaf => _ | _ => _ end] ] => dep_destruct T
              end; crush).

    (** The balance correctness theorems are simple first-order logic equivalences, where we use the function [projT2] to project the payload of a [sigT] value. *)

    Lemma present_balance1 : forall n (a : rtree n) (y : nat) c2 (b : rbtree c2 n),
      present z (projT2 (balance1 a y b))
      <-> rpresent z a \/ z = y \/ present z b.
      destruct a; present_balance.
    Qed.

    Lemma present_balance2 : forall n (a : rtree n) (y : nat) c2 (b : rbtree c2 n),
      present z (projT2 (balance2 a y b))
      <-> rpresent z a \/ z = y \/ present z b.
      destruct a; present_balance.
    Qed.

    (** To state the theorem for [ins], it is useful to define a new type-level function, since [ins] returns different result types based on the type indices passed to it.  Recall that [x] is the section variable standing for the key we are inserting. *)

    Definition present_insResult c n :=
      match c return (rbtree c n -> insResult c n -> Prop) with
        | Red => fun t r => rpresent z r <-> z = x \/ present z t
        | Black => fun t r => present z (projT2 r) <-> z = x \/ present z t
      end.

    (** Now the statement and proof of the [ins] correctness theorem are straightforward, if verbose.  We proceed by induction on the structure of a tree, followed by finding case analysis opportunities on expressions we see being analyzed in [if] or [match] expressions.  After that, we pattern-match to find opportunities to use the theorems we proved about balancing.  Finally, we identify two variables that are asserted by some hypothesis to be equal, and we use that hypothesis to replace one variable with the other everywhere. *)

    Theorem present_ins : forall c n (t : rbtree c n),
      present_insResult t (ins t).
      induction t; crush;
        repeat (match goal with
                  | [ _ : context[if ?E then _ else _] |- _ ] => destruct E
                  | [ |- context[if ?E then _ else _] ] => destruct E
                  | [ _ : context[match ?C with Red => _ | Black => _ end]
                      |- _ ] => destruct C
                end; crush);
        try match goal with
              | [ _ : context[balance1 ?A ?B ?C] |- _ ] =>
                generalize (present_balance1 A B C)
            end;
        try match goal with
              | [ _ : context[balance2 ?A ?B ?C] |- _ ] =>
                generalize (present_balance2 A B C)
            end;
        try match goal with
              | [ |- context[balance1 ?A ?B ?C] ] =>
                generalize (present_balance1 A B C)
            end;
        try match goal with
              | [ |- context[balance2 ?A ?B ?C] ] =>
                generalize (present_balance2 A B C)
            end;
        crush;
          match goal with
            | [ z : nat, x : nat |- _ ] =>
              match goal with
                | [ H : z = x |- _ ] => rewrite H in *; clear H
              end
          end;
          tauto.
    Qed.

    (** The hard work is done.  The most readable way to state correctness of [insert] involves splitting the property into two color-specific theorems.  We write a tactic to encapsulate the reasoning steps that work to establish both facts. *)

    Ltac present_insert :=
      unfold insert; intros n t; inversion t;
        generalize (present_ins t); simpl;
          dep_destruct (ins t); tauto.

    Theorem present_insert_Red : forall n (t : rbtree Red n),
      present z (insert t)
      <-> (z = x \/ present z t).
      present_insert.
    Qed.

    Theorem present_insert_Black : forall n (t : rbtree Black n),
      present z (projT2 (insert t))
      <-> (z = x \/ present z t).
      present_insert.
    Qed.
  End present.
End insert.

(** We can generate executable OCaml code with the command %\index{Vernacular commands!Recursive Extraction}%[Recursive Extraction insert], which also automatically outputs the OCaml versions of all of [insert]'s dependencies.  In our previous extractions, we wound up with clean OCaml code.  Here, we find uses of %\index{Obj.magic}%<<Obj.magic>>, OCaml's unsafe cast operator for tweaking the apparent type of an expression in an arbitrary way.  Casts appear for this example because the return type of [insert] depends on the _value_ of the function's argument, a pattern that OCaml cannot handle.  Since Coq's type system is much more expressive than OCaml's, such casts are unavoidable in general.  Since the OCaml type-checker is no longer checking full safety of programs, we must rely on Coq's extractor to use casts only in provably safe ways. *)

(* begin hide *)
Recursive Extraction insert.
(* end hide *)

(** * A Certified Regular Expression Matcher *)

(** Another interesting example is regular expressions with dependent types that express which predicates over strings particular regexps implement.  We can then assign a dependent type to a regular expression matching function, guaranteeing that it always decides the string property that we expect it to decide.

   Before defining the syntax of expressions, it is helpful to define an inductive type capturing the meaning of the Kleene star.  That is, a string [s] matches regular expression [star e] if and only if [s] can be decomposed into a sequence of substrings that all match [e].  We use Coq's string support, which comes through a combination of the [String] library and some parsing notations built into Coq.  Operators like [++] and functions like [length] that we know from lists are defined again for strings.  Notation scopes help us control which versions we want to use in particular contexts.%\index{Vernacular commands!Open Scope}% *)

Require Import Ascii String.
Open Scope string_scope.

Section star.
  Variable P : string -> Prop.

  Inductive star : string -> Prop :=
  | Empty : star ""
  | Iter : forall s1 s2,
    P s1
    -> star s2
    -> star (s1 ++ s2).
End star.

(** Now we can make our first attempt at defining a [regexp] type that is indexed by predicates on strings, such that the index of a [regexp] tells us which language (string predicate) it recognizes.  Here is a reasonable-looking definition that is restricted to constant characters and concatenation.  We use the constructor [String], which is the analogue of list cons for the type [string], where [""] is like list nil.
[[
Inductive regexp : (string -> Prop) -> Set :=
| Char : forall ch : ascii,
  regexp (fun s => s = String ch "")
| Concat : forall (P1 P2 : string -> Prop) (r1 : regexp P1) (r2 : regexp P2),
  regexp (fun s => exists s1, exists s2, s = s1 ++ s2 /\ P1 s1 /\ P2 s2).
]]

<<
User error: Large non-propositional inductive types must be in Type
>>

What is a %\index{large inductive types}%large inductive type?  In Coq, it is an inductive type that has a constructor that quantifies over some type of type [Type].  We have not worked with [Type] very much to this point.  Every term of CIC has a type, including [Set] and [Prop], which are assigned type [Type].  The type [string -> Prop] from the failed definition also has type [Type].

It turns out that allowing large inductive types in [Set] leads to contradictions when combined with certain kinds of classical logic reasoning.  Thus, by default, such types are ruled out.  There is a simple fix for our [regexp] definition, which is to place our new type in [Type].  While fixing the problem, we also expand the list of constructors to cover the remaining regular expression operators. *)

Inductive regexp : (string -> Prop) -> Type :=
| Char : forall ch : ascii,
  regexp (fun s => s = String ch "")
| Concat : forall P1 P2 (r1 : regexp P1) (r2 : regexp P2),
  regexp (fun s => exists s1, exists s2, s = s1 ++ s2 /\ P1 s1 /\ P2 s2)
| Or : forall P1 P2 (r1 : regexp P1) (r2 : regexp P2),
  regexp (fun s => P1 s \/ P2 s)
| Star : forall P (r : regexp P),
  regexp (star P).

(** Many theorems about strings are useful for implementing a certified regexp matcher, and few of them are in the [String] library.  The book source includes statements, proofs, and hint commands for a handful of such omitted theorems.  Since they are orthogonal to our use of dependent types, we hide them in the rendered versions of this book. *)

(* begin hide *)
Open Scope specif_scope.

Lemma length_emp : length "" <= 0.
  crush.
Qed.

Lemma append_emp : forall s, s = "" ++ s.
  crush.
Qed.

Ltac substring :=
  crush;
  repeat match goal with
           | [ |- context[match ?N with O => _ | S _ => _ end] ] => destruct N; crush
         end.

Lemma substring_le : forall s n m,
  length (substring n m s) <= m.
  induction s; substring.
Qed.

Lemma substring_all : forall s,
  substring 0 (length s) s = s.
  induction s; substring.
Qed.

Lemma substring_none : forall s n,
  substring n 0 s = "".
  induction s; substring.
Qed.

Hint Rewrite substring_all substring_none.

Lemma substring_split : forall s m,
  substring 0 m s ++ substring m (length s - m) s = s.
  induction s; substring.
Qed.

Lemma length_app1 : forall s1 s2,
  length s1 <= length (s1 ++ s2).
  induction s1; crush.
Qed.

Hint Resolve length_emp append_emp substring_le substring_split length_app1.

Lemma substring_app_fst : forall s2 s1 n,
  length s1 = n
  -> substring 0 n (s1 ++ s2) = s1.
  induction s1; crush.
Qed.

Lemma substring_app_snd : forall s2 s1 n,
  length s1 = n
  -> substring n (length (s1 ++ s2) - n) (s1 ++ s2) = s2.
  Hint Rewrite <- minus_n_O.

  induction s1; crush.
Qed.

Hint Rewrite substring_app_fst substring_app_snd using solve [trivial].
(* end hide *)

(** A few auxiliary functions help us in our final matcher definition.  The function [split] will be used to implement the regexp concatenation case. *)

Section split.
  Variables P1 P2 : string -> Prop.
  Variable P1_dec : forall s, {P1 s} + {~ P1 s}.
  Variable P2_dec : forall s, {P2 s} + {~ P2 s}.
  (** We require a choice of two arbitrary string predicates and functions for deciding them. *)

  Variable s : string.
  (** Our computation will take place relative to a single fixed string, so it is easiest to make it a [Variable], rather than an explicit argument to our functions. *)

  (** The function [split'] is the workhorse behind [split].  It searches through the possible ways of splitting [s] into two pieces, checking the two predicates against each such pair.  The execution of [split'] progresses right-to-left, from splitting all of [s] into the first piece to splitting all of [s] into the second piece.  It takes an extra argument, [n], which specifies how far along we are in this search process. *)

  Definition split' : forall n : nat, n <= length s
    -> {exists s1, exists s2, length s1 <= n /\ s1 ++ s2 = s /\ P1 s1 /\ P2 s2}
    + {forall s1 s2, length s1 <= n -> s1 ++ s2 = s -> ~ P1 s1 \/ ~ P2 s2}.
    refine (fix F (n : nat) : n <= length s
      -> {exists s1, exists s2, length s1 <= n /\ s1 ++ s2 = s /\ P1 s1 /\ P2 s2}
      + {forall s1 s2, length s1 <= n -> s1 ++ s2 = s -> ~ P1 s1 \/ ~ P2 s2} :=
      match n with
        | O => fun _ => Reduce (P1_dec "" && P2_dec s)
        | S n' => fun _ => (P1_dec (substring 0 (S n') s)
            && P2_dec (substring (S n') (length s - S n') s))
          || F n' _
      end); clear F; crush; eauto 7;
    match goal with
      | [ _ : length ?S <= 0 |- _ ] => destruct S
      | [ _ : length ?S' <= S ?N |- _ ] => destruct (eq_nat_dec (length S') (S N))
    end; crush.
  Defined.

  (** There is one subtle point in the [split'] code that is worth mentioning.  The main body of the function is a [match] on [n].  In the case where [n] is known to be [S n'], we write [S n'] in several places where we might be tempted to write [n].  However, without further work to craft proper [match] annotations, the type-checker does not use the equality between [n] and [S n'].  Thus, it is common to see patterns repeated in [match] case bodies in dependently typed Coq code.  We can at least use a [let] expression to avoid copying the pattern more than once, replacing the first case body with:
     [[
        | S n' => fun _ => let n := S n' in
          (P1_dec (substring 0 n s)
            && P2_dec (substring n (length s - n) s))
          || F n' _
     ]]

     The [split] function itself is trivial to implement in terms of [split'].  We just ask [split'] to begin its search with [n = length s]. *)

  Definition split : {exists s1, exists s2, s = s1 ++ s2 /\ P1 s1 /\ P2 s2}
    + {forall s1 s2, s = s1 ++ s2 -> ~ P1 s1 \/ ~ P2 s2}.
    refine (Reduce (split' (n := length s) _)); crush; eauto.
  Defined.
End split.

Implicit Arguments split [P1 P2].

(* begin hide *)
Lemma app_empty_end : forall s, s ++ "" = s.
  induction s; crush.
Qed.

Hint Rewrite app_empty_end.

Lemma substring_self : forall s n,
  n <= 0
  -> substring n (length s - n) s = s.
  induction s; substring.
Qed.

Lemma substring_empty : forall s n m,
  m <= 0
  -> substring n m s = "".
  induction s; substring.
Qed.

Hint Rewrite substring_self substring_empty using omega.

Lemma substring_split' : forall s n m,
  substring n m s ++ substring (n + m) (length s - (n + m)) s
  = substring n (length s - n) s.
  Hint Rewrite substring_split.

  induction s; substring.
Qed.

Lemma substring_stack : forall s n2 m1 m2,
  m1 <= m2
  -> substring 0 m1 (substring n2 m2 s)
  = substring n2 m1 s.
  induction s; substring.
Qed.

Ltac substring' :=
  crush;
  repeat match goal with
           | [ |- context[match ?N with O => _ | S _ => _ end] ] => case_eq N; crush
         end.

Lemma substring_stack' : forall s n1 n2 m1 m2,
  n1 + m1 <= m2
  -> substring n1 m1 (substring n2 m2 s)
  = substring (n1 + n2) m1 s.
  induction s; substring';
    match goal with
      | [ |- substring ?N1 _ _ = substring ?N2 _ _ ] =>
        replace N1 with N2; crush
    end.
Qed.

Lemma substring_suffix : forall s n,
  n <= length s
  -> length (substring n (length s - n) s) = length s - n.
  induction s; substring.
Qed.

Lemma substring_suffix_emp' : forall s n m,
  substring n (S m) s = ""
  -> n >= length s.
  induction s; crush;
    match goal with
      | [ |- ?N >= _ ] => destruct N; crush
    end;
    match goal with
      [ |- S ?N >= S ?E ] => assert (N >= E); [ eauto | omega ]
    end.
Qed.

Lemma substring_suffix_emp : forall s n m,
  substring n m s = ""
  -> m > 0
  -> n >= length s.
  destruct m as [ | m]; [crush | intros; apply substring_suffix_emp' with m; assumption].
Qed.

Hint Rewrite substring_stack substring_stack' substring_suffix
  using omega.

Lemma minus_minus : forall n m1 m2,
  m1 + m2 <= n
  -> n - m1 - m2 = n - (m1 + m2).
  intros; omega.
Qed.

Lemma plus_n_Sm' : forall n m : nat, S (n + m) = m + S n.
  intros; omega.
Qed.

Hint Rewrite minus_minus using omega.
(* end hide *)

(** One more helper function will come in handy: [dec_star], for implementing another linear search through ways of splitting a string, this time for implementing the Kleene star. *)

Section dec_star.
  Variable P : string -> Prop.
  Variable P_dec : forall s, {P s} + {~ P s}.

  (** Some new lemmas and hints about the [star] type family are useful.  We omit them here; they are included in the book source at this point. *)

  (* begin hide *)
  Hint Constructors star.

  Lemma star_empty : forall s,
    length s = 0
    -> star P s.
    destruct s; crush.
  Qed.

  Lemma star_singleton : forall s, P s -> star P s.
    intros; rewrite <- (app_empty_end s); auto.
  Qed.

  Lemma star_app : forall s n m,
    P (substring n m s)
    -> star P (substring (n + m) (length s - (n + m)) s)
    -> star P (substring n (length s - n) s).
    induction n; substring;
      match goal with
        | [ H : P (substring ?N ?M ?S) |- _ ] =>
          solve [ rewrite <- (substring_split S M); auto
            | rewrite <- (substring_split' S N M); auto ]
      end.
  Qed.

  Hint Resolve star_empty star_singleton star_app.

  Variable s : string.

  Lemma star_inv : forall s,
    star P s
    -> s = ""
    \/ exists i, i < length s
      /\ P (substring 0 (S i) s)
      /\ star P (substring (S i) (length s - S i) s).
    Hint Extern 1 (exists i : nat, _) =>
      match goal with
        | [ H : P (String _ ?S) |- _ ] => exists (length S); crush
      end.

    induction 1; [
      crush
      | match goal with
          | [ _ : P ?S |- _ ] => destruct S; crush
        end
    ].
  Qed.

  Lemma star_substring_inv : forall n,
    n <= length s
    -> star P (substring n (length s - n) s)
    -> substring n (length s - n) s = ""
    \/ exists l, l < length s - n
      /\ P (substring n (S l) s)
      /\ star P (substring (n + S l) (length s - (n + S l)) s).
    Hint Rewrite plus_n_Sm'.

    intros;
      match goal with
        | [ H : star _ _ |- _ ] => generalize (star_inv H); do 3 crush; eauto
      end.
  Qed.
  (* end hide *)

  (** The function [dec_star''] implements a single iteration of the star.  That is, it tries to find a string prefix matching [P], and it calls a parameter function on the remainder of the string. *)

  Section dec_star''.
    Variable n : nat.
    (** Variable [n] is the length of the prefix of [s] that we have already processed. *)

    Variable P' : string -> Prop.
    Variable P'_dec : forall n' : nat, n' > n
      -> {P' (substring n' (length s - n') s)}
      + {~ P' (substring n' (length s - n') s)}.

    (** When we use [dec_star''], we will instantiate [P'_dec] with a function for continuing the search for more instances of [P] in [s]. *)

    (** Now we come to [dec_star''] itself.  It takes as an input a natural [l] that records how much of the string has been searched so far, as we did for [split'].  The return type expresses that [dec_star''] is looking for an index into [s] that splits [s] into a nonempty prefix and a suffix, such that the prefix satisfies [P] and the suffix satisfies [P']. *)

    Definition dec_star'' : forall l : nat,
      {exists l', S l' <= l
        /\ P (substring n (S l') s) /\ P' (substring (n + S l') (length s - (n + S l')) s)}
      + {forall l', S l' <= l
        -> ~ P (substring n (S l') s)
        \/ ~ P' (substring (n + S l') (length s - (n + S l')) s)}.
      refine (fix F (l : nat) : {exists l', S l' <= l
          /\ P (substring n (S l') s) /\ P' (substring (n + S l') (length s - (n + S l')) s)}
        + {forall l', S l' <= l
          -> ~ P (substring n (S l') s)
          \/ ~ P' (substring (n + S l') (length s - (n + S l')) s)} :=
        match l with
          | O => _
          | S l' =>
            (P_dec (substring n (S l') s) && P'_dec (n' := n + S l') _)
            || F l'
        end); clear F; crush; eauto 7;
        match goal with
          | [ H : ?X <= S ?Y |- _ ] => destruct (eq_nat_dec X (S Y)); crush
        end.
    Defined.
  End dec_star''.

  (* begin hide *)
  Lemma star_length_contra : forall n,
    length s > n
    -> n >= length s
    -> False.
    crush.
  Qed.

  Lemma star_length_flip : forall n n',
    length s - n <= S n'
    -> length s > n
    -> length s - n > 0.
    crush.
  Qed.

  Hint Resolve star_length_contra star_length_flip substring_suffix_emp.
  (* end hide *)

  (** The work of [dec_star''] is nested inside another linear search by [dec_star'], which provides the final functionality we need, but for arbitrary suffixes of [s], rather than just for [s] overall. *)

  Definition dec_star' : forall n n' : nat, length s - n' <= n
    -> {star P (substring n' (length s - n') s)}
    + {~ star P (substring n' (length s - n') s)}.
    refine (fix F (n n' : nat) : length s - n' <= n
      -> {star P (substring n' (length s - n') s)}
      + {~ star P (substring n' (length s - n') s)} :=
      match n with
        | O => fun _ => Yes
        | S n'' => fun _ =>
          le_gt_dec (length s) n'
          || dec_star'' (n := n') (star P)
            (fun n0 _ => Reduce (F n'' n0 _)) (length s - n')
      end); clear F; crush; eauto;
    match goal with
      | [ H : star _ _ |- _ ] => apply star_substring_inv in H; crush; eauto
    end;
    match goal with
      | [ H1 : _ < _ - _, H2 : forall l' : nat, _ <= _ - _ -> _ |- _ ] =>
        generalize (H2 _ (lt_le_S _ _ H1)); tauto
    end.
  Defined.

  (** Finally, we have [dec_star], defined by straightforward reduction from [dec_star']. *)

  Definition dec_star : {star P s} + {~ star P s}.
    refine (Reduce (dec_star' (n := length s) 0 _)); crush.
  Defined.
End dec_star.

(* begin hide *)
Lemma app_cong : forall x1 y1 x2 y2,
  x1 = x2
  -> y1 = y2
  -> x1 ++ y1 = x2 ++ y2.
  congruence.
Qed.

Hint Resolve app_cong.
(* end hide *)

(** With these helper functions completed, the implementation of our [matches] function is refreshingly straightforward.  We only need one small piece of specific tactic work beyond what [crush] does for us. *)

Definition matches : forall P (r : regexp P) s, {P s} + {~ P s}.
  refine (fix F P (r : regexp P) s : {P s} + {~ P s} :=
    match r with
      | Char ch => string_dec s (String ch "")
      | Concat _ _ r1 r2 => Reduce (split (F _ r1) (F _ r2) s)
      | Or _ _ r1 r2 => F _ r1 s || F _ r2 s
      | Star _ r => dec_star _ _ _
    end); crush;
  match goal with
    | [ H : _ |- _ ] => generalize (H _ _ (eq_refl _))
  end; tauto.
Defined.

(** It is interesting to pause briefly to consider alternate implementations of [matches].  Dependent types give us much latitude in how specific correctness properties may be encoded with types.  For instance, we could have made [regexp] a non-indexed inductive type, along the lines of what is possible in traditional ML and Haskell.  We could then have implemented a recursive function to map [regexp]s to their intended meanings, much as we have done with types and programs in other examples.  That style is compatible with the [refine]-based approach that we have used here, and it might be an interesting exercise to redo the code from this subsection in that alternate style or some further encoding of the reader's choice.  The main advantage of indexed inductive types is that they generally lead to the smallest amount of code. *)

(* begin hide *)
Example hi := Concat (Char "h"%char) (Char "i"%char).
Eval hnf in matches hi "hi".
Eval hnf in matches hi "bye".

Example a_b := Or (Char "a"%char) (Char "b"%char).
Eval hnf in matches a_b "".
Eval hnf in matches a_b "a".
Eval hnf in matches a_b "aa".
Eval hnf in matches a_b "b".
(* end hide *)

(** Many regular expression matching problems are easy to test.  The reader may run each of the following queries to verify that it gives the correct answer.  We use evaluation strategy %\index{tactics!hnf}%[hnf] to reduce each term to%\index{head-normal form}% _head-normal form_, where the datatype constructor used to build its value is known.  (Further reduction would involve wasteful simplification of proof terms justifying the answers of our procedures.) *)

Example a_star := Star (Char "a"%char).
Eval hnf in matches a_star "".
Eval hnf in matches a_star "a".
Eval hnf in matches a_star "b".
Eval hnf in matches a_star "aa".

(** Evaluation inside Coq does not scale very well, so it is easy to build other tests that run for hours or more.  Such cases are better suited to execution with the extracted OCaml code. *)


Require Import ZArith ROmega.

(* Submitted by Xavier Urbain 18 Jan 2002 *)

Lemma lem1 :
 forall x y : Z, (-5 < x < 5)%Z -> (-5 < y)%Z -> (-5 < x + y + 5)%Z.
Proof.
intros x y.
romega.
Qed.

(* Proposed by Pierre Crégut *)

Lemma lem2 : forall x : Z, (x < 4)%Z -> (x > 2)%Z -> x = 3%Z.
intro.
 romega.
Qed.

(* Proposed by Jean-Christophe Filliâtre *)

Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z.
Proof.
intros.
romega.
Qed.

(* Proposed by Jean-Christophe Filliâtre: confusion between an Omega *)
(* internal variable and a section variable (June 2001) *)

Section A.
Variable x y : Z.
Hypothesis H : (x > y)%Z.
Lemma lem4 : (x > y)%Z.
 romega.
Qed.
End A.

(* Proposed by Yves Bertot: because a section var, L was wrongly renamed L0 *)
(* May 2002 *)

Section B.
Variable R1 R2 S1 S2 H S : Z.
Hypothesis I : (R1 < 0)%Z -> R2 = (R1 + (2 * S1 - 1))%Z.
Hypothesis J : (R1 < 0)%Z -> S2 = (S1 - 1)%Z.
Hypothesis K : (R1 >= 0)%Z -> R2 = R1.
Hypothesis L : (R1 >= 0)%Z -> S2 = S1.
Hypothesis M : (H <= 2 * S)%Z.
Hypothesis N : (S < H)%Z.
Lemma lem5 : (H > 0)%Z.
 romega.
Qed.
End B.

(* From Nicolas Oury (bug #180): handling -> on Set (fixed Oct 2002) *)
Lemma lem6 :
 forall (A : Set) (i : Z), (i <= 0)%Z -> ((i <= 0)%Z -> A) -> (i <= 0)%Z.
intros.
 romega.
Qed.

(* Adapted from an example in Nijmegen/FTA/ftc/RefSeparating (Oct 2002) *)
Require Import Omega.
Section C.
Parameter g : forall m : nat, m <> 0 -> Prop.
Parameter f : forall (m : nat) (H : m <> 0), g m H.
Variable n : nat.
Variable ap_n : n <> 0.
Let delta := f n ap_n.
Lemma lem7 : n = n.
 romega with nat.
Qed.
End C.

(* Problem of dependencies *)
Require Import Omega.
Lemma lem8 : forall H : 0 = 0 -> 0 = 0, H = H -> 0 = 0.
intros.
romega with nat.
Qed.

(* Bug that what caused by the use of intro_using in Omega *)
Require Import Omega.
Lemma lem9 :
 forall p q : nat, ~ (p <= q /\ p < q \/ q <= p /\ p < q) -> p < p \/ p <= p.
intros.
romega with nat.
Qed.

(* Check that the interpretation of mult on nat enforces its positivity *)
(* Submitted by Hubert Thierry (bug #743) *)
(* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z" *)
Lemma lem10 : forall n m : nat, le n (plus n (mult n m)).
Proof.
intros; romega with nat.
Qed.


Require Import Arith.
From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

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

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

Fixpoint eqb (n m: natural) : bool :=
  match n, m with
    | Zero, Zero => true
    | Zero, Succ _ => false
    | Succ _, Zero => false
    | Succ n', Succ m' => eqb n' m'
  end.

  Fixpoint mem  (mem_arg1 : lst) (mem_arg0 : natural)
  := match mem_arg0, mem_arg1 with
    | x, Nil => false
    | x, Cons y z => orb (eqb x y) (mem z x)
    end.

Fixpoint less (less_arg0 : natural) (less_arg1 : natural) : bool
           := match less_arg0, less_arg1 with
              | x, Zero => false
              | Zero, Succ x => true
              | Succ x, Succ y => less x y
              end.

Fixpoint insort  (insort_arg1 : lst) (insort_arg0 : natural) : lst
           := match insort_arg1, insort_arg0 with
              |  Nil, i => Cons i Nil
              | Cons x y, i => if less i x then Cons i (Cons x y) else Cons x (insort y i)
              end.

Fixpoint sort (sort_arg0 : lst) : lst
           := match sort_arg0 with
              | Nil => Nil
              | Cons x y => insort (sort y) x
              end.

Theorem eqb_refl: forall n, eqb n n = true.
Proof.
  induction n; simpl.
  { assumption. }
  { reflexivity. }
Qed.

Theorem theorem0 : forall (x : natural) (y : natural) (z : lst), eq x y -> eq (mem (insort z y) x) true.
Proof.
  intros.
  induction z.
  { subst. simpl. destruct (less y n).
    { simpl. rewrite eqb_refl. simpl. reflexivity. }
    { simpl. rewrite IHz. apply Bool.orb_true_r. }
  }
  { simpl. subst. rewrite eqb_refl. simpl. reflexivity. }
Qed.


Require Export ZArith.
Require Export ZArithRing.
Require Export Zcompare.
Require Export Zwf.
Open Scope Z_scope.

Definition factZ_it_F (fact : Z ->  Z) (x : Z) :=
   match Z_lt_le_dec x 0 with
     left h => 0
    | right h =>
        match Z_eq_dec 0 x with   left h' => 1
                                 | right h'' => x * fact (x - 1) end
   end.

Fixpoint iter (A : Set) (f : A ->  A) (k : nat) (a : A) {struct k} : A :=
 match k with   0%nat => a
               | S p => f (iter A f p a) end.
Implicit Arguments iter.

Definition factZ_terminates:
 forall (x : Z),
  ({v : Z |
   exists p : nat ,
   forall k, forall g, (p < k)%nat ->  iter factZ_it_F k g x = v }).
intros x; elim x  using (well_founded_induction (Zwf_well_founded 0)).
clear x; intros x Hrec.
unfold factZ_it_F.
case_eq (Z_lt_le_dec x 0).
intros h heq1; exists 0; exists 1%nat.
intros k; case k.
intros; omega.
intros; simpl; rewrite heq1; auto.
intros h heq2.
case_eq (Z_eq_dec 0 x).
intros h' heq3; exists 1; exists 1%nat.
intros k; case k.
intros; omega.
intros; simpl. rewrite heq2.  simpl in heq3. rewrite heq3; auto.
intros h'' heq4.
assert (HZwf: Zwf 0 (x - 1) x).
clear heq2 heq4.
unfold Zwf; omega.
destruct (Hrec (x - 1) HZwf) as [v Hex].
exists (x * v).
destruct Hex as [p Heq].
exists (S p); intros k; case k.
intros; omega.
simpl; intros k' hltk g; rewrite heq2; simpl in heq4;rewrite heq4.
fold factZ_it_F.
rewrite Heq.
trivial.
omega.
Qed.

Definition factZ_it : Z ->  Z :=
   fun x =>
      match factZ_terminates x with exist v _ => v end.

Theorem factZ_fix_eqn:
 forall x,
  factZ_it x =
  match Z_lt_le_dec x 0 with
    left h => 0
   | right h =>
       match Z_eq_dec 0 x with   left h' => 1
                                | right h'' => x * factZ_it (x - 1) end
  end.
intros x; unfold factZ_it.
elim (factZ_terminates x).
elim (factZ_terminates (x - 1)).
intros v' Hex' v Hex.
elim Hex; intros p Heq; elim Hex'; intros p' Heq'.
rewrite <- (Heq (S ((p + p') + 1)) factZ_it).

simpl iter.
unfold factZ_it_F.
2:omega.
case (Z_lt_le_dec x 0); auto.
case (Z_eq_dec 0 x); auto.
rewrite <- (Heq' ((p + p') + 1)%nat factZ_it).
 reflexivity.
omega.
Qed.


Require Import Nat Arith.

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

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

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

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

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Fixpoint mem (mem_arg0 : Nat) (mem_arg1 : Lst) : Prop
           := match mem_arg0, mem_arg1 with
              | x, nil => False
              | x, cons y z => x = y \/ mem x z
              end.

Theorem mem_append : forall (x : Nat) (y : Lst) (z : Lst), mem x y -> mem x (append y z).
Proof.
  intros.
  induction y.
  - contradiction.
  - simpl. destruct H.
    + auto.
    + apply IHy in H. auto.
Qed.


(**************************************************************************)
(**************************************************************************)
(****                                                                  ****)
(****   A demonstration that instead of having inductive families      ****)
(****   (i.e., inductive types with indices) built into the type       ****)
(****   theory, we can emulate them with families of inductive types   ****)
(****   (i.e., inductive types with parameters) if propositional       ****)
(****   equality is taken to be primitive                              ****)
(****                                                                  ****)
(**************************************************************************)
(**************************************************************************)

Require Import Coq.Init.Nat.
Require Import Main.Tactics.

(*
  We define two inductive definitions and prove they are isomorphic. The first
  definition is an inductive family, and the second is a family of inductive
  types.

  Note that `exp1` lives in `Type` because its `const1` constructor quantifies
  over `Set`. `exp2`, however, can live in `Set` since parameter arguments are
  not considered for universe constraints on inductive data types. In that
  sense, we have gained something from using a parameter instead of an index.
*)

Inductive exp1 : Set -> Type :=
| const1 : forall (a : Set), a -> exp1 a
| add1 : exp1 nat -> exp1 nat -> exp1 nat
| lessThan1 : exp1 nat -> exp1 nat -> exp1 bool.

#[export] Hint Constructors exp1 : main.

Inductive exp2 (a : Set) : Set :=
| const2 : a -> exp2 a
| add2 : nat = a -> exp2 nat -> exp2 nat -> exp2 a
| lessThan2 : bool = a -> exp2 nat -> exp2 nat -> exp2 a.

#[export] Hint Constructors exp2 : main.

Fixpoint exp1ToExp2 (a : Set) (e1 : exp1 a) : exp2 a :=
  match e1 with
  | const1 b x => const2 b x
  | add1 e2 e3 => add2 nat eq_refl (exp1ToExp2 nat e2) (exp1ToExp2 nat e3)
  | lessThan1 e2 e3 =>
    lessThan2 bool eq_refl (exp1ToExp2 nat e2) (exp1ToExp2 nat e3)
  end.

Fixpoint exp2ToExp1 (a : Set) (e1 : exp2 a) : exp1 a :=
  match e1 with
  | const2 _ x => const1 a x
  | add2 _ H e2 e3 =>
    match H in (_ = b) return exp1 b with
    | eq_refl => add1 (exp2ToExp1 nat e2) (exp2ToExp1 nat e3)
    end
  | lessThan2 _ H e2 e3 =>
    match H in (_ = b) return exp1 b with
    | eq_refl => lessThan1 (exp2ToExp1 nat e2) (exp2ToExp1 nat e3)
    end
  end.

Theorem exp1ToExp2ToExp1 :
  forall (a : Set) (e : exp1 a), exp2ToExp1 a (exp1ToExp2 a e) = e.
Proof.
  clean.
  induction e; search.
Qed.

#[export] Hint Resolve exp1ToExp2ToExp1 : main.

Theorem exp2ToExp1ToExp2 :
  forall (a : Set) (e : exp2 a), exp1ToExp2 a (exp2ToExp1 a e) = e.
Proof.
  clean.
  induction e; search.
Qed.

#[export] Hint Resolve exp2ToExp1ToExp2 : main.

(*
  Just for fun, we implement evaluators for both of the inductive definitions
  and prove they are preserved by the isomorphisms.
*)

Fixpoint eval1 (a : Set) (e1 : exp1 a) : a :=
  match e1 in exp1 b return b with
  | const1 _ x => x
  | add1 e2 e3 => eval1 nat e2 + eval1 nat e3
  | lessThan1 e2 e3 => ltb (eval1 nat e2) (eval1 nat e3)
  end.

Fixpoint eval2 (a : Set) (e1 : exp2 a) : a :=
  match e1 with
  | const2 _ x => x
  | add2 _ H e2 e3 =>
    match H in (_ = b) return b with
    | eq_refl => eval2 nat e2 + eval2 nat e3
    end
  | lessThan2 _ H e2 e3 =>
    match H in (_ = b) return b with
    | eq_refl => ltb (eval2 nat e2) (eval2 nat e3)
    end
  end.

Theorem exp1ToExp2PreservesEval :
  forall (a : Set) (e : exp1 a), eval1 a e = eval2 a (exp1ToExp2 a e).
Proof.
  clean.
  induction e; search.
  clean.
  rewrite IHe1.
  rewrite IHe2.
  search.
Qed.

#[export] Hint Resolve exp1ToExp2PreservesEval : main.

Theorem exp2ToExp1PreservesEval :
  forall (a : Set) (e : exp2 a), eval2 a e = eval1 a (exp2ToExp1 a e).
Proof.
  clean.
  induction e; search.
  clean.
  rewrite IHe1.
  rewrite IHe2.
  search.
Qed.

#[export] Hint Resolve exp2ToExp1PreservesEval : main.


(* Practica 1 *)

Section P1.
Variables A B C:Prop.

(* Ej 1.1 *)
Theorem e11: A->A.
Proof.
...
Qed.

(* Ej 1.2 *)
Theorem e12: A->B->A.
Proof.
...
Qed.

(* Ej 1.3 *)
Theorem e13: (A->(B->C))->(A->B)->(A->C).
Proof.
...
Qed.

(*Ej 2.1 *)
Theorem e21: (A->B)->(B->C)->A->C.
Proof.
...
Qed.

(*Ej 2.2 *)
Theorem e22: (A->B->C)->B->A->C.
Proof.
...
Qed.

(*Ej 3.1 *)
Theorem e31_1: A->A->A.
Proof.
...
Qed.

Theorem e31_2: A->A->A.
Proof.
...
Qed.

(* Ej 3.2 *)
Theorem e32_1: (A->B->C)->A->(A->C)->B->C.
Proof.
...
Qed.

Theorem e32_2: (A->B->C)->A->(A->C)->B->C.
Proof.
...
Qed.

(* Ej 4.1 *)
Theorem e41: A -> ~~A.
Proof.
...
Qed.

(* Ej 4.2 *)
Theorem e42: A -> B -> (A /\ B).
Proof.
...
Qed.

(* Ej 4.3 *)
Theorem e43: (A->B->C) -> (A/\B->C).
Proof.
...
Qed.

(* Ej 4.4 *)
Theorem e44: A->(A\/B).
Proof.
...
Qed.

(* Ej 4.5 *)
Theorem e45: B->(A\/B).
Proof.
...
Qed.

(* Ej 4.6 *)
Theorem e46: (A \/ B) -> (B \/ A).
Proof.
...
Qed.

(* Ej 4.7 *)
Theorem e47: (A->C)->(B->C)->A\/B->C.
Proof.
...
Qed.

(* Ej 4.8 *)
Theorem e48: False->A.
Proof.
...
Qed.

(* Ej 5.1 *)
Theorem e51: (A->B)-> ~B-> ~A.
Proof.
...
Qed.

(* Ej 5.2 *)
Theorem e52: ~(A/\~A).
Proof.
...
Qed.

(* Ej 5.3 *)
Theorem e53: (A->B)-> ~(A/\~B).
Proof.
...
Qed.

(* Ej 5.4 *)
Theorem e54: (A/\B)->~(A->~B).
Proof.
...
Qed.

(* Ej 5.5 *)
Theorem e55: (~A /\ ~~A) -> False.
Proof.
...
Qed.

(* Ej 6.1 *)
Theorem e61: (A\/B) -> ~(~A/\~B).
Proof.
...
Qed.

(* Ej 6.2 *)
Theorem e62: A\/B <-> B\/A.
Proof.
...
Qed.

(* Ej 6.3 *)
Theorem e63: A\/B -> ((A->B)->B).
Proof.
...
Qed.

End P1.

Section Logica_Clasica.
Variables A B C: Prop.

(* Ej 7.1 *)
Theorem e71: A \/ ~A -> ~~A->A.
Proof.
...
Qed.

(* Ej 7.2 *)
Theorem e72: A\/~A -> ((A->B) \/ (B->A)).
Proof.
...
Qed.

(* Ej 7.3 *)
Theorem e73: (A \/ ~A) -> ~(A /\ B) -> ~A \/ ~B.
Proof.
...
Qed.

Require Import Classical.
Check classic.

(* Ej 8.1 *)
Theorem e81: forall A:Prop, ~~A->A.
Proof.
...
Qed.

(* Ej 8.2 *)
Theorem e82: forall A B:Prop, (A->B)\/(B ->A).
Proof.
...
Qed.

(* Ej 8.3 *)
Theorem e83: forall A B:Prop, ~(A/\B)-> ~A \/ ~B.
Proof.
...
Qed.

End Logica_Clasica.

Section Traducciones.

(* Ej 9 *)
(* Definiciones *)
Variable NM RED CONS UTIL : Prop.

Hypothesis H1 : ...
Hypothesis H2 : ...

Theorem ej9 : ...
Proof.
...
Qed.

(* Ej 10 y 11 *)
(* Formalizaciones a cargo del estudiante *)

(* Ej 12 *)
(* Definiciones *)
Variable PF:Prop. (* el paciente tiene fiebre *)
Variable PA:Prop. (* el paciente tiene piel amarillenta *)
Variable PH:Prop. (* el paciente tiene hepatitis *)
Variable PR:Prop. (* el paciente tiene rubeola *)

Hypothesis Regla1: ...
Hypothesis Regla2: ...
Hypothesis Regla3: ...

Theorem ej12: (~PA /\ PF) -> ...

End Traducciones.


Set Warnings "-notation-overridden,-parsing".
From LF Require Export IndProp.

Print even.
(* ==>
  Inductive even : nat -> Prop :=
    | ev_0 : even 0
    | ev_SS : forall n, even n -> even (S (S n)).
*)

Theorem ev_4'' : even 4.
Proof.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_0.
  Show Proof.
Qed.

Definition ev_4''' : even 4 :=
  ev_SS 2 (ev_SS 0 ev_0).

Check (ev_SS 2 (ev_SS 0 ev_0)).

Theorem ev_plus4 : forall n, even n -> even (4 + n).
Proof.
  intros n H. simpl.
  apply ev_SS.
  apply ev_SS.
  apply H.
Qed.

Definition ev_plus4' : forall n, even n ->
                        even (4 + n) :=
  fun (n : nat) => fun (H : even n) =>
    ev_SS (S (S n)) (ev_SS n H).

Definition ev_plus4'' (n : nat) (H : even n)
                    : even (4 + n) :=
  ev_SS (S (S n)) (ev_SS n H).

Check ev_plus4''.
(* ===>
     : forall n : nat, even n -> even (4 + n) *)

(*
     ∀(x:nat), nat
  =  ∀(_:nat), nat
  =  nat → nat
*)

Definition ev_plus2 : Prop :=
  forall n, forall (E : even n), even (n + 2).

Definition ev_plus2' : Prop :=
  forall n, forall (_ : even n), even (n + 2).

Definition ev_plus2'' : Prop :=
  forall n, even n -> even (n + 2).

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

Print add1.

Module Props.

Module And.
Inductive and (P Q : Prop) : Prop :=
| conj : P -> Q -> and P Q.
End And.

Print prod.

Definition and_comm'_aux P Q (H : P /\ Q) :
                          Q /\ P :=
  match H with
  | conj HP HQ => conj HQ HP
  end.

Lemma and_comm : forall P Q : Prop,
        P /\ Q <-> Q /\ P.
Proof.
  intros P Q. split.
  - intros [HP HQ]. split.
    + apply HQ.
    + apply HP.
  - intros [HP HQ]. split.
    + apply HQ.
    + apply HP.
Qed.

Print and_comm'_aux.

Definition and_comm' P Q : P /\ Q <-> Q /\ P :=
  conj (and_comm'_aux P Q) (and_comm'_aux Q P).

Print and_comm'.

Definition conj_fact : forall P Q R,
  P /\ Q -> Q /\ R -> P /\ R.
intros P Q R [H0 H1] [_ H2].
split. apply H0. apply H2.
Defined.

Module Or.
Inductive or (P Q : Prop) : Prop :=
| or_introl : P -> or P Q
| or_intror : Q -> or P Q.
End Or.

Definition or_comm : forall P Q,
  P \/ Q -> Q \/ P.
intros P Q [H0 | H1].
right. apply H0.
left. apply H1.
Defined.

Module Ex.
Inductive ex {A : Type} (P : A -> Prop) : Prop :=
| ex_intro : forall x : A, P x -> ex P.
End Ex.

Check ex (fun n => even n).

Definition some_nat_is_even : exists n,
  even n :=
  ex_intro even 4 (ev_SS 2 (ev_SS 0 ev_0)).

Check ex_intro even 4.
Check ev_SS 2 (ev_SS 0 ev_0).

Definition ex_ev_Sn : ex (fun n => even (S n)).
  exists 1. apply (ev_SS 0 ev_0). Defined.

Inductive True : Prop :=
  | I : True.

Inductive False : Prop := .

End Props.

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

Definition four' : 2 + 2 == 1 + 3 :=
  eq_refl 4.

Definition singleton : forall (X:Type) (x:X),
  []++[x] == x::[] :=
  fun (X:Type) (x:X) => eq_refl [x].

Check singleton nat 2.

Lemma equality__leibniz_equality : forall (X : Type) (x y: X),
  x == y -> forall P:X -> Prop, P x -> P y.
Proof.
  intros. inversion H. rewrite <- H2.
  apply H0.
Qed.

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

End MyEquality.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Psatz.
Require Import PL.CoqInductiveType.
Require Import PL.SetsDomain.
Require Import PL.SemanticsIntro.
Local Open Scope string.
Local Open Scope sets_scope.

(** 之前我们已经学习了如何在Coq中用集合来定义正则表达式的语义。在这一讲中，我们
    将在Coq中证明集合的相关性质，并进一步证明正则表达式的相关性质。*)

(** * 集合与命题 *)

(** 由于集合以及集合间的运算是基于Coq中的命题进行定义的，集合相关性质的证明也可
    以规约为与命题有关的逻辑证明。例如，我们想要证明，交集运算具有交换律：*)

Lemma Sets_intersect_comm: forall (X Y: string -> Prop),
  X ∩ Y == Y ∩ X.
Proof.
  intros.
  (** 下面一条命令_[sets_unfold]_是SetsDomain库提供的自动证明指令，它可以将有关
      集合的性质转化为有关命题的性质。*)
  sets_unfold.
  (** 原本要证明的关于交集的性质现在就转化为了：
        _[forall a : string, X a /\ Y a <-> Y a /\ X a]_
      其中_[forall]_就是逻辑中『任意』的意思；_[/\]_之前我们已经了解，它表示『并
      且』的意思；_[<->]_表示『当且仅当』的意思；_[X a]_可以念做性质_[X]_对于
      _[a]_成立，也可以理解为_[a]_是集合_[X]_的元素。

      我们稍后再来完成相关性质的证明。在Coq中，要放弃当前的证明，可以用下面的
      _[Abort]_指令。*)
Abort.

(** 下面是一条关于并集运算的性质。*)

Lemma Sets_included_union1: forall (X Y: string -> Prop),
  X ⊆ X ∪ Y.
Proof.
  intros.
  sets_unfold.
  (** 经过转化，要证明的结论是：_[forall a : string, X a -> X a \/ Y a]_。这里，
      _[\/]_表示『或者』；_[->]_表示推出，也可以念做『如果...那么...』。*)
Abort.

(** 下面是一条关于一列集合的并集运算的性质。*)

Lemma Sets_included_omega_union0: forall (X: nat -> string -> Prop),
  X 0 ⊆ ⋃ X.
Proof.
  intros.
  sets_unfold.
  (** 经过转化，要证明的结论是：
         _[forall a : string, X 0 a -> exists n : nat, X n a]_
      它表示：对于任意一个字符串_[a]_，如果他是_[X 0]_的元素，那么就存在一个自然
      数_[n]_使得_[a]_是_[X n]_的元素。*)
Abort.

(** * 逻辑命题的证明 *)

(** ** 逻辑命题『真』的证明 *)

(** 我们不需要任何前提就可以推出_[True]_。在Coq标准库中，_[I]_是_[True]_的一个证
    明，我们可以用_[exact I]_来证明_[True]_。*)

Example proving_True_1: 1 < 2 -> True.
Proof.
  intros.
  exact I.
Qed.

Example proving_True_2: 1 > 2 -> True.
Proof.
  intros.
  exact I.
Qed.

(** ** 关于『并且』的证明 *)

(** 要证明『某命题并且某命题』成立，可以在Coq中使用_[split]_证明指令进行证明。该
    指令会将当前的证明目标拆成两个子目标。*)

Lemma True2: True /\ True.
Proof.
  split.
  + exact I.
  + exact I.
Qed.

(** 下面证明一个关于_[/\]_的一般性结论：*)

Lemma and_intro : forall A B : Prop, A -> B -> A /\ B.
Proof.
  intros A B HA HB.
  split.
  (** 下面的_[apply]_指令表示在证明中使用一条前提，或者使用一条已经经过证明的定
      理或引理。*)
  + apply HA.
  + apply HB.
Qed.

Example and_exercise :
  forall n m : nat, n + 2*m = 10 -> 2*n + m = 5 -> n = 0 /\ True.
Proof.
  intros.
  split.
  - lia.
  - exact I.
Qed.

(** 如果当前一条前提假设具有『某命题并且某命题』的形式，我们可以在Coq中使用
    _[destruct]_指令将其拆分成为两个前提。 *)

Lemma proj1 : forall P Q : Prop,
  P /\ Q -> P.
Proof.
  intros.
  destruct H as [HP HQ].
  apply HP.
Qed.

(** _[destruct]_指令也可以不指名拆分后的前提的名字，Coq会自动命名。*)

Lemma proj2 : forall P Q : Prop,
  P /\ Q -> Q.
Proof.
  intros.
  destruct H.
  (* 这里只用到第二个分支，因此可以用_[_]_把第一个扔掉： _[destruct H as [_ ?]]_ *)
  (* _[?]_ 表示让Coq来命名 *)
  apply H0.
Qed.

(** 当前提与结论中，都有_[/\]_的时候，我们就既需要使用_[split]_指令，又需要使用
    _[destruct]_指令。*)

Theorem and_commut : forall P Q : Prop,
  P /\ Q -> Q /\ P.
Proof.
  intros.
  destruct H as [HP HQ].
  split.
  - apply HQ.
  - apply HP.
Qed.

Theorem and_assoc : forall P Q R : Prop,
  P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros.
  destruct H as [HP HQR].
  destruct HQR as [HQ HR].
  split.
  - split.
    apply HP. apply HQ.
  - apply HR.
Qed.

(** ** 关于『或』的证明 *)

(** 『或』是另一个重要的逻辑连接词。如果『或』出现在前提中，我们可以用Coq中的
    _[destruct]_指令进行分类讨论。*)

Lemma or_example :
  forall n m : nat, n = 0 \/ m = 0 -> n * m = 0.
Proof.
  intros.
  destruct H as [H | H].
  + rewrite H.
    lia.
  + rewrite H.
    lia.
Qed.

(** 在上面的例子中，我们对于形如_[A \/ B]_的前提进行分类讨论。要证明_[A \/ B]_能
    推出原结论，就需要证明_[A]_与_[B]_中的任意一个都可以推出原结论。下面是一个一
    般性的结论. *)

Lemma or_example2 :
  forall P Q R: Prop, (P -> R) -> (Q -> R) -> (P \/ Q -> R).
Proof.
  intros.
  destruct H1 as [HP | HQ].
  + apply H.
    (* 注意，_[apply]_指令不一定要前提与结论完全吻合才能使用。此处，只要_[H]_中
       推导的结果与待证明的结论一致，就可以使用_[apply H]_。*)
    apply HP.
  + apply H0 in HQ.
    (* _[apply]_指令还可以在前提中做推导，不过这时需要使用_[apply ... in]_这一语
       法。*)
    apply HQ.
Qed.

(** 相反的，如果要证明一条形如_[A \/ B]_的结论整理，我们就只需要证明_[A]_与_[B]_
    两者之一成立就可以了。在Coq中的指令是：_[left]_与_[right]_。例如，下面是选择
    左侧命题的例子。*)

Lemma or_introl : forall A B : Prop, A -> A \/ B.
Proof.
  intros.
  left.
  apply H.
Qed.

(** 下面是选择右侧命题的例子。*)

Lemma or_intror : forall A B : Prop, B -> A \/ B.
Proof.
  intros.
  right.
  apply H.
Qed.

(** 下面性质请各位自行证明。*)

Theorem or_commut : forall P Q : Prop,
  P \/ Q  -> Q \/ P.
Proof.
  intros.
  destruct H as [HP | HQ].
  - right. apply HP.
  - left. apply HQ.
Qed.

(** ** 关于『如果...那么...』的证明 *)

(** 事实上，在之前的例子中，我们已经多次证明有关_[->]_的结论了。下面我们在看几个
    例子，并额外介绍几条Coq证明指令。

    下面的证明中，_[pose proof]_表示推导出一个新的结论，并将其用作之后证明中的前
    提。*)

Theorem modus_ponens: forall P Q: Prop,
  P /\ (P -> Q) -> Q.
Proof.
  intros.
  destruct H.
  (** 将_[H0: P -> Q]_作用在_[H: P]_上，我们就可以得出一个新结论：_[Q]_。*)
  pose proof H0 H.
  apply H1.
Qed.

(** 下面我们换一种方法证明。_[revert]_证明指令可以看做_[intros]_的反操作。 *)

Theorem modus_ponens_alter1: forall P Q: Prop,
  P /\ (P -> Q) -> Q.
Proof.
  intros.
  destruct H.
  (** 下面_[revert]_指令将前提中的_[P]_又放回了『结论中的前提』中去。*)
  revert H.
  apply H0.
Qed.

(** 下面我们再换一种方式证明，_[specialize]_指令与_[apply ... in]_指令的效果稍有
    不同。*)

Theorem modus_ponens_alter2: forall P Q: Prop,
  P /\ (P -> Q) -> Q.
Proof.
  intros.
  destruct H.
  specialize (H0 H).
  apply H0.
Qed.

(** 另外，我们可以直接使用_[exact]_指令，这个指令的效果像是_[pose proof]_或者
    _[specialize]_与_[apply]_的组合。*)

Theorem modus_ponens_alter3: forall P Q: Prop,
  P /\ (P -> Q) -> Q.
Proof.
  intros.
  destruct H.
  exact (H0 H).
Qed.

(** ** 关于『否定』与『假』的证明 *)

(** 在Coq中[~]表示否定，_[False]_表示假。如果前提为假，那么，矛盾推出一切。在Coq
    中，这可以用_[contradiction]_指令或_[destruct]_指令完成证明。*)

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

Theorem ex_falso_quodlibet_alter : forall (P: Prop),
  False -> P.
Proof.
  intros.
  destruct H.
Qed.

(** _[contradiction]_也可以用于_[P]_与_[~ P]_同时出现在前提中的情况： *)

Theorem contradiction_implies_anything : forall P Q : Prop,
  (P /\ ~ P) -> Q.
Proof.
  intros.
  destruct H.
  contradiction.
Qed.

(** 除了_[P]_与_[~ P]_不能同时为真之外，他们也不能同时为假，或者说，他们中至少有
    一个要为真。这是Coq标准库中的_[classic]_。 *)

Check classic.

(** 它说的是：_[forall P : Prop, P \/ ~ P]_。下面我们利用它做一些证明。 *)

Theorem double_neg_elim : forall P : Prop,
  ~ ~ P -> P.
Proof.
  intros.
  pose proof classic P. (* 把P塞给_[classic]_里面的前提_[forall P]_ *)
  destruct H0.
  + apply H0.
  + contradiction.
Qed.

Theorem not_False :
  ~ False.
Proof.
  pose proof classic False.
  destruct H.
  - contradiction.
  - apply H.
Qed.

Theorem double_neg_intro : forall P : Prop,
  P -> ~ ~ P.
Proof.
  intros.
  pose proof classic (~ P).
  destruct H0.
  - contradiction.
  - apply H0.
Qed.

(** ** 关于『当且仅当』的证明 *)

(** 在Coq中，_[<->]_符号对应的定义是_[iff]_，其将_[P <-> Q]_定义为
          _[(P -> Q) /\ (Q -> P)]_
    因此，要证明关于『当且仅当』的性质，首先可以使用其定义进行证明。*)

Theorem iff_refl: forall P: Prop, P <-> P.
Proof.
  intros.
  unfold iff.
  split.
  + intros.
    apply H.
  + intros.
    apply H.
Qed.

Theorem iff_imply: forall P Q: Prop, (P <-> Q) -> (P -> Q).
Proof.
  intros P Q H.
  unfold iff in H.
  destruct H.
  exact H.
Qed.

(** 当某前提假设具有形式_[P <-> Q]_，那我们也可以使用_[apply]_指令进行证明。*)

Theorem iff_imply_alter: forall P Q: Prop, (P <-> Q) -> (P -> Q).
Proof.
  intros.
  apply H.
  apply H0.
Qed.

(** 另外，_[rewrite]_指令也可以使用形如_[P <-> Q]_的等价性前提。*)

Theorem iff_imply_alter2: forall P Q: Prop, (P <-> Q) -> (P -> Q).
Proof.
  intros.
  rewrite <- H.
  apply H0.
Qed.

Theorem iff_imply_alter3: forall P Q: Prop, (P <-> Q) -> (P -> Q).
Proof.
  intros P Q.
  tauto. (* tautology, 重言式 *)
Qed.

(** ** 关于『存在』的证明 *)

(** 当待证明结论形为：存在一个_[x]_使得...，那么可以用_[exists]_指明究竟哪个
    _[x]_使得该性质成立。*)

Lemma four_is_even : exists n, 4 = n + n.
Proof.
  exists 2.
  lia.
Qed.

Lemma six_is_not_prime: exists n, 2 <= n < 6 /\ exists q, n * q = 6.
Proof.
  exists 2.
  split.
  + lia.
  + exists 3.
    lia.
Qed.

(** 当某前提形为：存在一个_[x]_使得...，那么可以使用Coq中的_[destruct]_指令进行
    证明。这一证明指令相当于数学证明中的：任意给定一个这样的_[x]_。 *)

Theorem exists_example : forall n,
  (exists m, n = 4 + m) ->
  (exists o, n = 2 + o).
Proof.
  intros.
  destruct H as [m H].
  exists (2 + m).
  lia.
Qed.

Theorem dist_exists_and : forall (X:Type) (P Q : X -> Prop),
  (exists x, P x /\ Q x) -> (exists x, P x) /\ (exists x, Q x).
Proof.
  intros.
  destruct H as [x [HP HQ]].
  split.
  - exists x.
    apply HP.
  - exists x.
    apply HQ.
Qed.

Theorem exists_exists : forall (X Y:Type) (P : X -> Y -> Prop),
  (exists x y, P x y) <-> (exists y x, P x y).
Proof.
  intros.
  unfold iff.
  split.
  - intros H. destruct H as [x' [y' H']].
    exists y'. exists x'. apply H'.
  - intros H. destruct H as [x' [y' H']].
    exists y'. exists x'. apply H'.
Qed.

(** * 集合性质的证明 *)

Lemma Sets_intersect_comm: forall (X Y: string -> Prop),
  X ∩ Y == Y ∩ X.
Proof.
  intros.
  sets_unfold.
  (* 此处可直接用_[tauto]_ *)
  intros.
  unfold iff.
  split.
  - apply and_commut.
  - apply and_commut.
Qed.

Lemma Sets_included_union1: forall (X Y: string -> Prop),
  X ⊆ X ∪ Y.
Proof.
  intros.
  sets_unfold.
  intros.
  left.
  apply H.
Qed.

Lemma Sets_included_omega_union0: forall (X: nat -> string -> Prop),
  X 0 ⊆ ⋃ X.
Proof.
  intros.
  sets_unfold.
  intros.
  exists 0.
  apply H.
Qed.

(* reg_denote (app r EmptyStr) == reg_denote r *)
Lemma string_set_app_empty_string_r: forall X: string -> Prop,
  X ∘ [""] == X.
Proof.
  intros.
  unfold string_set_app; sets_unfold.
  intros.
  split; intros.
  - destruct H as [s1 [s2 [? [? ?]]]].
    rewrite H1.
    rewrite <- H0.
    rewrite string_app_empty_r.
    exact H.
  - exists a, "".
    split.
    -- apply H.
    -- split.
       --- reflexivity.
       --- rewrite string_app_empty_r.
           reflexivity.
Qed.

Lemma string_set_app_assoc: forall X Y Z: string -> Prop,
  X ∘ (Y ∘ Z) == (X ∘ Y) ∘ Z.
Proof.
  intros.
  unfold string_set_app; sets_unfold.
  intros.
  split.
  - intros H.
    destruct H as [s1 H].
    destruct H as [s2 H].
    destruct H as [H1 H2].
    destruct H2 as [H2 H3].
    destruct H2 as [s3 [s4 H2]].
    destruct H2 as [H21 [H22 H23]].
    exists (string_app s1 s3). exists s4.
    split.
    -- exists s1. exists s3.
       split.
       --- apply H1.
       --- split.
           * apply H21.
           * reflexivity.
    -- split.
       --- apply H22.
       --- rewrite <- string_app_assoc.
           rewrite <- H23.
           rewrite <- H3.
           reflexivity.
  - intros H.
    destruct H as [s1 [s2 H]].
    destruct H as [H1 H2].
    destruct H2 as [H2 H3].
    destruct H1 as [s3 [s4 H1]].
    destruct H1 as [H11 H12].
    destruct H12 as [H12 H13].
    exists s3. exists (string_app s4 s2).
    split.
    -- apply H11.
    -- split.
       --- exists s4. exists s2.
           split.
           * apply H12.
           * split.
             ** apply H2.
             ** reflexivity.
       --- rewrite string_app_assoc.
           rewrite <- H13.
           rewrite <- H3.
           reflexivity.
Qed.


From coqlearn Require Export wjm02.

Inductive natprod:Type:=
    |pair (n1 n2:nat).
Check (pair 3 5).

Definition fst (p:natprod) :nat:=
    match p with
        |pair x y=>x
    end.

Definition snd (p:natprod):nat:=
    match p with
        |pair x y=>y
    end.

Compute (snd (pair 2 4)).

Notation "( x , y )":=(pair x y).
Check (1,2).

Compute (snd (12,23)).

Definition swap_pair (p:natprod):natprod:=
    match p with
        |(x,y)=>(y,x)
    end.

Compute (swap_pair (1,2)).

Theorem surjective_pairing:forall p:natprod,p=(fst p,snd p).
Proof.
intros p.
destruct p as [n m] eqn:E.
simpl. reflexivity.
Qed.

Theorem snd_fst_is_swap:forall p:natprod,(snd p,fst p)=swap_pair p.
Proof.
intros p.
simpl.
destruct p as [n m].
simpl. reflexivity.
Qed.

Theorem fst_swap_is_snd:forall p:natprod,fst (swap_pair p)=snd p.
Proof.
intros p.
destruct p as [n m].
simpl. reflexivity.
Qed.

Inductive natlist:Type:=
    |nil
    |cons (n:nat) (l:natlist).

Definition mylist := cons 1 (cons 2 (cons 3 nil)).
Check (mylist).

Notation "x :: l":=(cons x l) (at level 60,right associativity).
Notation "[]":=nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Check ([1;2;3;4;5]).
(*just for test

Notation "[ x | .. | y ]" := (cons y .. (cons x nil) ..).

Check ([1|2|3|4|5]).

Definition fst_element_list (L:natlist):natlist:=
    match L with
        |nil=>nil
        |cons x L'=>cons x nil
    end.

Compute (fst_element_list [1|2|3|4|5]).
*)

Fixpoint repeat (n count : nat) : natlist :=
  match count with
  | O => []
  | S count' => n::(repeat n count')
  end.

Fixpoint length (l:natlist):nat:=
    match l with
        |nil=>0
        |h::t=>S (length t)
    end.

Compute (repeat 6 6).
Compute (length [1;2;3]).

Fixpoint app (L1 L2:natlist):natlist:=
    match L1 with
        |nil=>L2
        |h::t=>h::(app t L2)
    end.

Compute (app [1;2;3] [6;5;4]).

Compute (app [] []).

Notation "x ++ y":=(app x y) (right associativity,at level 60).

Definition hd (default:nat) (l:natlist):nat:=
    match l with
        |nil=>default
        |h::t=>h
    end.

Definition tl(l:natlist):natlist:=
    match l with
        |nil=>nil
        |h::t=>t
    end.

Fixpoint nonzeros(l:natlist):natlist:=
    match l with
        |nil=>nil
        |0::t=>nonzeros t
        |not0::t=>not0::(nonzeros t)
    end.

Compute (nonzeros [0;1;0;2;0;3;0;0]).
Compute (nonzeros [1;2;3]).
Compute (nonzeros [0;0;0]).

Fixpoint odd_fst_element(l:natlist):bool:=
    match l with
    |nil=>true
    |O::t=>false
    |(S O)::t=>true
    |(S (S m))::t=>oddn m
    end.

Compute (odd_fst_element [2;1;2;3]).

Fixpoint oddmembers(l:natlist):natlist:=
    match l,(odd_fst_element l) with
        |[],_=>[]
        |h::nil,false=>[]
        |h::t,false=>oddmembers t
        |h::t,true=>h::(oddmembers t)
    end.

Compute (oddmembers [12;43;5;32;0;12;11;666]).

Fixpoint countoddmembers (l:natlist):nat:=
    match l,(odd_fst_element l) with
        |[],_=>0
        |h::nil,false=>0
        |h::t,false=>countoddmembers t
        |h::t,true=>S (countoddmembers t)
    end.

Compute (countoddmembers [0;2;4]).

Theorem app_assoc:forall (l1 l2 l3:natlist),(l1++l2)++l3=l1++(l2++l3).
Proof.
intros l1 l2 l3.
induction l1 as [|n l' IHl'].
    -reflexivity.
    -simpl. rewrite->IHl'. simpl. reflexivity.
Qed.

Inductive natoption : Type :=
  | Some (n : nat)
  | None.

Inductive id:Type:=
    |Id (n:nat).

Definition eqb_id (x1 x2 : id) :=
  match x1, x2 with
  | Id n1, Id n2 => n1 =? n2
  end.

Module PartialMap.

Inductive partial_map:Type:=
    |empty
    |record (i:id) (v:nat) (m:partial_map).

Definition update (d:partial_map) (x:id) (value:nat):partial_map:=
    record x value d.

Fixpoint find (x:id) (d:partial_map):natoption:=
    match d with
        |empty=>None
        |record y v d'=>if eqb_id x y
                        then Some v
                        else find x d'
    end.

End PartialMap.


(*|
################################################
Pattern matching using information from theorems
################################################

:Link: https://stackoverflow.com/q/44413328
|*)

(*|
Question
********

I have the following question, look in the code.
|*)

(* Suppose we have type A *)
Variable A : Type.

(* Also we have a function that returns the type (option A) *)
Variable f_opt : A -> option A.

(* Then, I can prove that this function always returns something: *)
Theorem always_some : forall x, exists y, f_opt x = Some y.
Admitted.

(* Or, equivalently: *)
Theorem always_not_none : forall x, f_opt x <> None.
Admitted.

(*|
Now I would like to get a version of ``f_opt`` that always returns a
value of type ``A``. Something like this:
|*)

Fail Definition f x : A :=
  match f_opt x with
  | Some y => y
  end. (* .fails .unfold *)

(*|
I understand that I need to do some kind of work with types, but I do
not understand what exactly i should do.
|*)

(*|
Answer (Arthur Azevedo De Amorim)
*********************************

In Coq's underlying theory, every pattern matching must be exhaustive
-- that is, it must explicitly consider all the constructors of the
inductive type in question. This is why you are getting the error
message you saw.

How do we get around this restriction? There are a few solutions.
First, let's see how to convince Coq that the ``None`` branch can
never occur. For this, we will use your ``always_not_none`` theorem:
|*)

Definition f x : A :=
  match f_opt x as res return res <> None -> A with
  | Some y => fun _ => y
  | None => fun H => match H eq_refl with end
  end (always_not_none x).

(*|
This code might look strange at first sight, but it almost performs
the pattern match you want. To explain to Coq that the ``None`` case
never arises, it combines ``always_not_none`` with the fact that
``f_opt x = None`` on that branch to derive a contradiction. This is
the ``H eq_refl`` term on that branch. Then, the ``match`` on that
contradiction suffices to convince Coq that the branch is spurious. A
bit more formally, because ``False``, the contradictory proposition,
is defined without any constructors, when we match on a term of type
``False``, there are no branches to deal with, and the entire
expression can return any type that we want -- in this case, ``A``.

What is strange about this code is the type annotations on the match,
and that it returns a function instead of something of type ``A``
directly. This is done because of how dependent pattern match works in
Coq: whenever we want to make use of information that we obtain from
being in a particular branch of a match (here, that ``f_opt x`` is
equal to ``None`` in that branch), we must explicitly make the match
return a function -- what Adam Chlipala calls the `convoy pattern
<http://adam.chlipala.net/cpdt/html/MoreDep.html>`__. This is done so
that Coq knows where you plan to use that extra information and check
that it is done correctly. Here, we use that ``f_opt x`` is ``None``
to feed the hypothesis needed by ``always_not_none x`` to derive a
contradiction.

Although this will solve your problem, I would generally advise you
against doing it this way. For instance, if you know that your ``A``
type is inhabited by some element ``a : A``, then you can simply make
``f`` return ``a`` on that branch. This has the benefit of avoiding
mentioning proofs inside your functions, which often gets in the way
when simplifying and rewriting terms.
|*)

(*|
Answer (Daniel Schepler)
************************

Using Coq's ``Program`` module, you can write an exhaustive pattern
match, but annotate that some branches should be impossible to reach
and then later provide the proof that this is the case:
|*)

Reset f. (* .none *)
Require Import Program.

Program Definition f x : A :=
  match f_opt x with
  | Some a => a
  | None => !
  end.
Next Obligation.
  destruct (always_some x). congruence.
Qed.

(*|
(The ``Program`` module does a lot of the work behind the scenes that
in a complete explicit definition you would have to write using the
"convoy pattern". Do be aware, however, that sometimes ``Program``
tends to generate lots of dependencies on ``JMeq`` and the axiom
``JMeq_eq`` when dependent types are involved, even when it might not
be necessary.)

----

**A:** To check if ``f`` depends on any additional axioms one can use
``Print Assumptions f.`` command.
|*)

(*|
Answer (Vinz)
*************

You will need to put your existential proof ``always_not_none`` in
``Set`` or ``Type`` to do so:
|*)

Reset always_some. (* .none *)
Theorem always_some : forall x, {y : A & f_opt x = Some y}.
Admitted.

(*|
Then you can do the following (or use ``refine`` or ``Program``):
|*)

Definition f (x : A) : A :=
  let s := always_some x in let (x0, _) := s in x0.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (y : natural) (x : natural) : natural :=
  plus (Succ lf2) (mult y x).