Coinduction and dependent types

Question

I'm trying to write a Coq function which takes a Stream and a predicate and returns, as a list, the longest prefix of the stream for which the property holds. This is what I have:

Require Import List Streams.
Require Import Lt.

Import ListNotations.
Local Open Scope list_scope.

Section TakeWhile.

Context {A : Type} {P : Stream A -> Prop}.
Hypothesis decide_P : forall s : Stream A, {P s} + {~ P s}.

Program Fixpoint take_while (s : Stream A)
    (H : Exists (fun s => ~ P s) s) : list A :=
  if decide_P s
  then hd s :: take_while (tl s) _
  else [].

Next Obligation.
  destruct H; tauto.
Defined.

End TakeWhile.

But when I attempt to perform calculations with this function, I get a very large term with all the definitions expanded. I'm not sure why, but I'm guessing that Coq is reluctant to unfold the coinductive Stream argument. Here's an example:

Require Import Program.Equality.
Require Import Compare_dec.

Lemma not_lt_le :
  forall n m : nat, ~ n < m -> m <= n.
Proof.
  pose le_or_lt.
  firstorder.
Qed.

Definition increasing (s : Stream nat) : Prop :=
  forall n : nat, Exists (fun s => ~ hd s < n) s.

CoFixpoint nats (n : nat) := Cons n (nats (S n)).

Theorem increasing_nats :
  forall n : nat, increasing (nats n).
Proof.
  intros n m.
  induction m.
  - left.
    pose lt_n_0.
    firstorder.
  - dependent induction IHm.
    * apply not_lt_le, le_lt_or_eq in H.
      destruct H.
      + left.
        pose le_not_lt.
        firstorder.
      + right.
        left.
        simpl in *.
        rewrite H.
        pose lt_irrefl.
        firstorder.
    * right.
      simpl.
      apply IHIHm.
      reflexivity.
Qed.

Given this, the command Eval compute in take_while (fun s => lt_dec (hd s) 5) (nats 0) (increasing_nats 0 5) leads to a very large term, as I mentioned above.

Can anyone give me some guidance on this?

Answer 1

The problem is that take_while is defined recursively on H. Since proofs are often defined opaquely in Coq (as it is the case with your increasing_nats theorem), take_while won't be able to reduce the increasing_nats 0 5 term and will get stuck, producing the huge term you saw. Even if you ended the proof of increasing_nats with Defined instead of Qed, forcing its definition to be transparent, that proof uses other lemmas that were also defined opaquely, making evaluation get stuck too.

One solution is to prove increasing_nats without using any additional lemmas and end the proof with Defined. This approach doesn't scale to more interesting cases, as you may be required to reprove lots of theorems using Defined.

Another solution is to pass take_while an explicit bound parameter:

Section TakeWhile.

Variable A : Type.
Variable P : A -> Prop.
Variable decide_P : forall a, {P a} + {~ P a}.

Fixpoint take_while_bound n (s : Stream A) : list A :=
  match n with
    | 0 => []
    | S n =>
      if decide_P (hd s) then
        hd s :: take_while_bound n (tl s)
      else
        []
  end.

End TakeWhile.

If you want to use this function to show that the extracted prefix is maximal, then you would have to show that some element for which P does not hold occurs in s before the nth position. Despite this drawback, this function could be more convenient to use, because you don't have to pass a proof object to it.

Finally, you could also prove a lemma about take_while showing how it reduces, and apply that lemma every time you want to simplify an expression involving that function. Thus, simplification becomes clumsier, as you need to do it explicitly, but at least you'll be able to prove things about take_while.

Answer 2

As an addendum to Amori's answer, here are the theorems you need to compute your function.

Definition le_IsSucc (n1 n2 : nat) (H1 : S n1 <= n2) : IsSucc n2 :=
  match H1 with
  | le_n     => I
  | le_S _ _ => I
  end.

Definition le_Sn_0 (n1 : nat) (H1 : S n1 <= 0) : False :=
  le_IsSucc _ _ H1.

Fixpoint le_0_n (n1 : nat) : 0 <= n1 :=
  match n1 with
  | 0   => le_n _
  | S _ => le_S _ _ (le_0_n _)
  end.

Fixpoint le_n_S (n1 n2 : nat) (H1 : n1 <= n2) : S n1 <= S n2 :=
  match H1 with
  | le_n      => le_n _
  | le_S _ H2 => le_S _ _ (le_n_S _ _ H2)
  end.

Fixpoint le_or_lt (n1 n2 : nat) : n1 <= n2 \/ S n2 <= n1 :=
  match n1 with
  | 0   => or_introl (le_0_n _)
  | S _ =>
    match n2 with
    | 0   => or_intror (le_n_S _ _ (le_0_n _))
    | S _ =>
      match le_or_lt _ _ with
      | or_introl H1 => or_introl (le_n_S _ _ H1)
      | or_intror H1 => or_intror (le_n_S _ _ H1)
      end
    end
  end.

Definition not_lt_le (n1 n2 : nat) (H1 : S n1 <= n2 -> False) : n2 <= n1 :=
  match le_or_lt n2 n1 with
  | or_introl H2 => H2
  | or_intror H2 =>
    match H1 H2 with
    end
  end.

Definition le_pred' (n1 n2 : nat) : pred n1 <= pred n2 -> pred n1 <= pred (S n2) :=
  match n2 with
  | 0   => fun H1 => H1
  | S _ => le_S _ _
  end.

Fixpoint le_pred (n1 n2 : nat) (H1 : n1 <= n2) : pred n1 <= pred n2 :=
  match H1 with
  | le_n      => le_n _
  | le_S _ H2 => le_pred' _ _ (le_pred _ _ H2)
  end.

Definition le_S_n (n1 n2 : nat) (H1 : S n1 <= S n2) : n1 <= n2 :=
  le_pred _ _ H1.

Fixpoint le_Sn_n (n1 : nat) : S n1 <= n1 -> False :=
  match n1 with
  | 0   => fun H1 => le_Sn_0 _ H1
  | S _ => fun H1 => le_Sn_n _ (le_S_n _ _ H1)
  end.

Definition le_Sn_le (n1 n2 : nat) (H1 : S n1 <= n2) : n1 <= n2 :=
  le_S_n _ _ (le_S _ _ H1).

Fixpoint le_not_lt (n1 n2 : nat) (H1 : n1 <= n2) : S n2 <= n1 -> False :=
  match H1 with
  | le_n      => le_Sn_n _
  | le_S _ H2 => fun H3 => le_not_lt _ _ H2 (le_S_n _ _ (le_S _ _ H3))
  end.

Definition le_lt_or_eq (n1 n2 : nat) (H1 : n1 <= n2) : S n1 <= n2 \/ n1 = n2 :=
  match H1 with
  | le_n      => or_intror eq_refl
  | le_S _ H2 => or_introl (le_n_S _ _ H2)
  end.

Theorem increasing_nats : forall n : nat, increasing (nats n).
Proof.
unfold increasing.
unfold not.
unfold lt.
intros n m.
induction m.
  apply Here.
  apply (le_Sn_0 (hd (nats n))).

  dependent induction IHm.
    apply not_lt_le in H.
    apply le_lt_or_eq in H.
    destruct H.
      apply Here.
      apply (le_not_lt _ _ H).

      apply Further.
      apply Here.
      rewrite H.
      apply le_Sn_n.
    apply (Further (nats n) (IHIHm _ eq_refl)).
Defined.