I'm playing with a little formalisation in Idris and I'm having some strange behaviour: high compilation time and CPU usage for a function.
The code is an regex pattern matching algorithm. First the regex definition:
data RegExp : Type where
Zero : RegExp
Eps : RegExp
Chr : Char -> RegExp
Cat : RegExp -> RegExp -> RegExp
Alt : RegExp -> RegExp -> RegExp
Star : RegExp -> RegExp
Comp : RegExp -> RegExp
Regex membership and non-membership are defined as the following mutually recursive data types:
mutual
data NotInRegExp : List Char -> RegExp -> Type where
NotInZero : NotInRegExp xs Zero
NotInEps : Not (xs = []) -> NotInRegExp xs Eps
NotInChr : Not (xs = [ c ]) -> NotInRegExp xs (Chr c)
NotInCat : zs = xs ++ ys -> (Either (NotInRegExp xs l)
((InRegExp xs l)
,(NotInRegExp ys r)))
-> NotInRegExp zs (Cat l r)
NotInAlt : NotInRegExp xs l -> NotInRegExp xs r -> NotInRegExp xs (Alt l r)
NotInStar : NotInRegExp xs Eps ->
NotInRegExp xs (Cat e (Star e)) ->
NotInRegExp xs (Star e)
NotInComp : InRegExp xs e -> NotInRegExp xs (Comp e)
data InRegExp : List Char -> RegExp -> Type where
InEps : InRegExp [] Eps
InChr : InRegExp [ a ] (Chr a)
InCat : InRegExp xs l ->
InRegExp ys r ->
zs = xs ++ ys ->
InRegExp zs (Cat l r)
InAltL : InRegExp xs l ->
InRegExp xs (Alt l r)
InAltR : InRegExp xs r ->
InRegExp xs (Alt l r)
InStar : InRegExp xs (Alt Eps (Cat e (Star e))) ->
InRegExp xs (Star e)
InComp : NotInRegExp xs e -> InRegExp xs (Comp e)
After these rather long definitions, I define a smart constructor for alternatives:
infixl 4 .|.
(.|.) : RegExp -> RegExp -> RegExp
Zero .|. e = e
e .|. Zero = e
e .|. e' = Alt e e'
Now, I want to prove that this smart constructor is sound and complete with respect to regex membership semantics. The proofs are almost straightforward induction / case analysis. But, one of these proofs is demanding a lot of time and CPU to compile (around 90% of CPU in Mac OS X El Capitan).
The offending function is:
altOptNotInComplete : NotInRegExp xs (Alt l r) -> NotInRegExp xs (l .|. r)
altOptNotInComplete {l = Zero} (NotInAlt x y) = y
altOptNotInComplete {l = Eps}{r = Zero} (NotInAlt x y) = x
altOptNotInComplete {l = Eps}{r = Eps} pr = pr
altOptNotInComplete {l = Eps}{r = (Chr x)} pr = pr
altOptNotInComplete {l = Eps}{r = (Cat x y)} pr = pr
altOptNotInComplete {l = Eps}{r = (Alt x y)} pr = pr
altOptNotInComplete {l = Eps}{r = (Star x)} pr = pr
altOptNotInComplete {l = Eps}{r = (Comp x)} pr = pr
altOptNotInComplete {l = (Chr x)}{r = Zero} (NotInAlt y z) = y
altOptNotInComplete {l = (Chr x)}{r = Eps} pr = pr
altOptNotInComplete {l = (Chr x)}{r = (Chr y)} pr = pr
altOptNotInComplete {l = (Chr x)}{r = (Cat y z)} pr = pr
altOptNotInComplete {l = (Chr x)}{r = (Alt y z)} pr = pr
altOptNotInComplete {l = (Chr x)}{r = (Star y)} pr = pr
altOptNotInComplete {l = (Chr x)}{r = (Comp y)} pr = pr
altOptNotInComplete {l = (Cat x y)}{r = Zero} (NotInAlt z w) = z
altOptNotInComplete {l = (Cat x y)}{r = Eps} pr = pr
altOptNotInComplete {l = (Cat x y)}{r = (Chr z)} pr = pr
altOptNotInComplete {l = (Cat x y)}{r = (Cat z w)} pr = pr
altOptNotInComplete {l = (Cat x y)}{r = (Alt z w)} pr = pr
altOptNotInComplete {l = (Cat x y)}{r = (Star z)} pr = pr
altOptNotInComplete {l = (Cat x y)}{r = (Comp z)} pr = pr
altOptNotInComplete {l = (Alt x y)}{r = Zero} (NotInAlt z w) = z
altOptNotInComplete {l = (Alt x y)}{r = Eps} pr = pr
altOptNotInComplete {l = (Alt x y)}{r = (Chr z)} pr = pr
altOptNotInComplete {l = (Alt x y)}{r = (Cat z w)} pr = pr
altOptNotInComplete {l = (Alt x y)}{r = (Alt z w)} pr = pr
altOptNotInComplete {l = (Alt x y)}{r = (Star z)} pr = pr
altOptNotInComplete {l = (Alt x y)}{r = (Comp z)} pr = pr
altOptNotInComplete {l = (Star x)}{r = Zero} (NotInAlt y z) = y
altOptNotInComplete {l = (Star x)}{r = Eps} pr = pr
altOptNotInComplete {l = (Star x)}{r = (Chr y)} pr = pr
altOptNotInComplete {l = (Star x)}{r = (Cat y z)} pr = pr
altOptNotInComplete {l = (Star x)}{r = (Alt y z)} pr = pr
altOptNotInComplete {l = (Star x)}{r = (Star y)} pr = pr
altOptNotInComplete {l = (Star x)}{r = (Comp y)} pr = pr
altOptNotInComplete {l = (Comp x)}{r = Zero} (NotInAlt y z) = y
altOptNotInComplete {l = (Comp x)}{r = Eps} pr = pr
altOptNotInComplete {l = (Comp x)}{r = (Chr y)} pr = pr
altOptNotInComplete {l = (Comp x)}{r = (Cat y z)} pr = pr
altOptNotInComplete {l = (Comp x)}{r = (Alt y z)} pr = pr
altOptNotInComplete {l = (Comp x)}{r = (Star y)} pr = pr
altOptNotInComplete {l = (Comp x)}{r = (Comp y)} pr = pr
I can't understand why this function is demanding so much CPU. Is there a way to "optimize" this code in order that compilation behaves normally?
The previous code is available at the following gist. I'm using Idris 0.10 on Mac Os X El Capitan.
Any clue is highly welcome.
Related
I'm basically trying to prove
Theorem le_unique {x y : nat} (p q : x <= y) : p = q.
without assuming any axioms (e.g. proof irrelevance). In particular, I've tried to get through le_unique by induction and inversion, but it never seems to get far
Theorem le_unique (x y : nat) (p q : x <= y) : p = q.
Proof.
revert p q.
induction x as [ | x rec_x]. (* induction on y similarly fruitless; induction on p, q fails *)
- destruct p as [ | y p].
+ inversion q as [ | ]. (* destruct q fails and inversion q makes no progress *)
admit.
+ admit.
- admit.
Admitted.
In the standard library, this lemma can be found as Peano_dec.le_unique in the module Coq.Arith.Peano_dec.
As for a relatively simple direct proof, I like to go by induction on p itself.
After proving by hand a few induction principles that Coq doesn't automatically generate, and remembering that proofs of equality on nat are unique, the proof is a relatively straightforward induction on p followed by cases on q, giving four cases two of which are absurd.
Below is a complete Coq file proving le_unique.
Import EqNotations.
Require Eqdep_dec PeanoNat.
Lemma nat_uip {x y : nat} (p q : x = y) : p = q.
apply Eqdep_dec.UIP_dec.
exact PeanoNat.Nat.eq_dec.
Qed.
(* Generalize le_ind to prove things about the proof *)
Lemma le_ind_dependent :
forall (n : nat) (P : forall m : nat, n <= m -> Prop),
P n (le_n n) ->
(forall (m : nat) (p : n <= m), P m p -> P (S m) (le_S n m p)) ->
forall (m : nat) (p : n <= m), P m p.
exact (fun n P Hn HS => fix ind m p : P m p := match p with
| le_n _ => Hn | le_S _ m p => HS m p (ind m p) end).
Qed.
(*
Here we give an proof-by-cases principle for <= which keeps both the left
and right hand sides fixed.
*)
Lemma le_case_remember (x y : nat) (P : x <= y -> Prop)
(IHn : forall (e : y = x), P (rew <- e in le_n x))
(IHS : forall y' (q' : x <= y') (e : y = S y'), P (rew <- e in le_S x y' q'))
: forall (p : x <= y), P p.
exact (fun p => match p with le_n _ => IHn | le_S _ y' q' => IHS y' q' end eq_refl).
Qed.
Theorem le_unique {x y : nat} (p q : x <= y) : p = q.
revert q.
induction p as [|y p IHp] using le_ind_dependent;
intro q;
case q as [e|x' q' e] using le_case_remember.
- rewrite (nat_uip e eq_refl).
reflexivity.
- (* x = S x' but x <= x', so S x' <= x', which is a contradiction *)
exfalso.
rewrite e in q'.
exact (PeanoNat.Nat.nle_succ_diag_l _ q').
- (* S y' = x but x <= y', so S y' <= y', which is a contradiction *)
exfalso; clear IHp.
rewrite <- e in p.
exact (PeanoNat.Nat.nle_succ_diag_l _ p).
- injection e as e'.
(* We now get rid of e as equal to (f_equal S e'), and then destruct e'
now that it is an equation between variables. *)
assert (f_equal S e' = e).
+ apply nat_uip.
+ destruct H.
destruct e'.
change (le_S x y p = le_S x y q').
f_equal.
apply IHp.
Qed.
Inspired by Eqdep_dec (and with a lemma from it), I've been able to cook this proof up. The idea is that x <= y can be converted to exists k, y = k + x, and roundtripping through this conversion produces a x <= y that is indeed = to the original.
(* Existing lemmas (e.g. Nat.le_exists_sub) seem unusable (declared opaque) *)
Fixpoint le_to_add {x y : nat} (prf : x <= y) : exists k, y = k + x :=
match prf in _ <= y return exists k, y = k + x with
| le_n _ => ex_intro _ 0 eq_refl
| le_S _ y prf =>
match le_to_add prf with
| ex_intro _ k rec =>
ex_intro
_ (S k)
match rec in _ = z return S y = S z with eq_refl => eq_refl end
end
end.
Fixpoint add_to_le (x k : nat) : x <= k + x :=
match k with
| O => le_n x
| S k => le_S x (k + x) (add_to_le x k)
end.
Theorem rebuild_le
{x y : nat} (prf : x <= y)
: match le_to_add prf return x <= y with
| ex_intro _ k prf =>
match prf in _ = z return x <= z -> x <= y with
| eq_refl => fun p => p
end (add_to_le x k)
end = prf.
Proof.
revert y prf.
fix rec 2. (* induction is not enough *)
destruct prf as [ | y prf].
- reflexivity.
- specialize (rec y prf).
simpl in *.
destruct (le_to_add prf) as [k ->].
subst prf.
reflexivity.
Defined.
Then, any two x <= ys will produce the same k, by injectivity of +. The decidability of = on nat tells us that the produced equalities are also equal. Thus, the x <= ys map to the same exists k, y = k + x, and mapping that equality back tells us the x <= ys were also equal.
Theorem le_unique (x y : nat) (p q : x <= y) : p = q.
Proof.
rewrite <- (rebuild_le p), <- (rebuild_le q).
destruct (le_to_add p) as [k ->], (le_to_add q) as [l prf].
pose proof (f_equal (fun n => n - x) prf) as prf'.
simpl in prf'.
rewrite ?Nat.add_sub in prf'.
subst l.
apply K_dec with (p := prf).
+ decide equality.
+ reflexivity.
Defined.
I'm still hoping there's a better (i.e. shorter) proof available.
I have a following code. I didn't write the full code, but this should work.
Definition in_domain {X Y : Set} (f : X -> option Y) x := match (f x) with | Some y => True | None => False end.
Definition injective {X Y : Set} (f : X -> option Y) := forall x y z, f x = Some z -> f y = Some z -> x = y.
Definition surjective {X Y : Set} (f : X -> option Y) := forall y, exists x, f x = Some y.
Definition bijective {X Y : Set} (f : X -> option Y) := injective f /\ surjective f.
Definition compose {X Y Z : Set} (f : X -> option Y) (g : Y -> option Z) (H : forall x, in_domain f x -> in_domain g (f x)) := fun x => match (f x) with | Some y => g y | None => None end.
Now I am trying to write Definition inverse {X Y : Set} (f : X -> option Y) (H : bijective f) : Y -> option X. I couldn't make the function g that f x = Some y <-> g y = Some x.
If generating such function is possible, could you please demonstrate how to?
You need axioms to do this, because Coq does not allow you by default to extract the witness out of an existential proof. In this case, you only need functional extensionality and the principle of unique choice, a weaker variant of the axiom of choice. Here is one possibility for a simplified variant of your problem:
Require Import Coq.Logic.Description.
Require Import Coq.Logic.FunctionalExtensionality.
Definition injective {X Y : Set} (f : X -> Y) := forall x y, f x = f y -> x = y.
Definition surjective {X Y : Set} (f : X -> Y) := forall y, exists x, f x = y.
Definition bijective {X Y : Set} (f : X -> Y) := injective f /\ surjective f.
Lemma inverse {X Y : Set} (f : X -> Y) :
bijective f -> {g : Y -> X | (forall x, g (f x) = x) /\
(forall y, f (g y) = y) }.
Proof.
intros [inj sur].
apply constructive_definite_description.
assert (H : forall y, exists! x, f x = y).
{ intros y.
destruct (sur y) as [x xP].
exists x; split; trivial.
intros x' x'P.
now apply inj; rewrite xP, x'P. }
exists (fun y => proj1_sig (constructive_definite_description _ (H y))).
split.
- split.
+ intros x.
destruct (constructive_definite_description _ _).
simpl.
now apply inj.
+ intros y.
now destruct (constructive_definite_description _ _).
- intros g' [H1 H2].
apply functional_extensionality.
intros y.
destruct (constructive_definite_description _ _) as [x e].
simpl.
now rewrite <- e, H1.
Qed.
(** **** Exercise: 3 stars, advanced (filter_exercise)
This one is a bit challenging. Pay attention to the form of your
induction hypothesis. *)
Theorem filter_exercise : forall (X : Type) (test : X -> bool)
(x : X) (l lf : list X),
filter test l = x :: lf ->
test x = true.
Proof.
intros X test x l lf. induction l as [| h t].
- simpl. intros H. discriminate H.
- simpl. destruct (test h) eqn:E.
+
Here is what I got so far:
X : Type
test : X -> bool
x, h : X
t, lf : list X
IHt : filter test t = x :: lf -> test x = true
E : test h = true
============================
h :: filter test t = x :: lf -> test x = true
And here I am stuck. What is so special in induction hypothesis that I must pay attention to?
Given the goal with an arrow in it,
h :: filter test t = x :: lf -> test x = true
^^
the natural next step is to intros the premise. The new premise
h :: filter test t = x :: lf
implies that the components of :: are respectively equal i.e. h = x and filter test t = lf, which can be extracted using inversion. The rest is trivial.
As I said I have on hypothesis
e0 : (val =? n) = true
and I have to prove val = n
Inductive is_found : nat -> abr -> bool -> Prop :=
|is_not_found_nil : forall (n : nat), (is_found n nil false)
|is_found_node_eq : forall (n val : nat) (fg fd : abr), val = n -> (is_found n (Node val fg fd) (val =? n))
|is_found_node_lt : forall (n val : nat) (fg fd : abr) (res : bool), val > n -> (is_found n fg res) -> (is_found n (Node val fg fd) res)
|is_found_node_gt : forall (n val : nat) (fg fd : abr) (res : bool), val < n -> (is_found n fd res) -> (is_found n (Node val fg fd) res).
(* fonction *)
Fixpoint find (n : nat) (a : abr) : bool :=
match a with
|nil => false
|(Node val f1 f2) => if (val =? n) then true else match (lt_dec val n) with
|left _ => (find n f2)
|right _ => (find n f1)
end
end.
Functional Scheme find_ind := Induction for find Sort Prop.
Goal forall (n : nat) (a : abr), (is_found n a (find n a)).
induction a.
simpl.
apply is_not_found_nil.
functional induction (find n (Node n0 a1 a2)) using find_ind.
apply is_not_found_nil.
rewrite <- e0.
apply is_found_node_eq.
3 subgoals
n, n0 : nat
a1, a2 : abr
IHa1 : is_found n a1 (find n a1)
IHa2 : is_found n a2 (find n a2)
val : nat
f1, f2 : abr
e0 : (val =? n) = true
______________________________________(1/3)
val = n
______________________________________(2/3)
is_found n (Node val f1 f2) (find n f2)
______________________________________(3/3)
is_found n (Node val f1 f2) (find n f1)
You want to use the lemma beq_nat_true.
If I execute
Require Import Coq.Arith.Arith.
Search "=?".
I see
Nat.eqb_refl: forall x : nat, (x =? x) = true
beq_nat_refl: forall n : nat, true = (n =? n)
Nat.eqb_sym: forall x y : nat, (x =? y) = (y =? x)
Nat.eqb_spec: forall x y : nat, Bool.reflect (x = y) (x =? y)
beq_nat_eq: forall n m : nat, true = (n =? m) -> n = m
beq_nat_true: forall n m : nat, (n =? m) = true -> n = m
Nat.eqb_eq: forall n m : nat, (n =? m) = true <-> n = m
beq_nat_false: forall n m : nat, (n =? m) = false -> n <> m
Nat.eqb_neq: forall x y : nat, (x =? y) = false <-> x <> y
Nat.eqb_compat:
Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq))
Nat.eqb
Nat.eqb_compare:
forall x y : nat, (x =? y) = match x ?= y with
| Eq => true
| _ => false
end
Nat.bit0_eqb: forall a : nat, Nat.testbit a 0 = (a mod 2 =? 1)
Nat.pow2_bits_eqb: forall n m : nat, Nat.testbit (2 ^ n) m = (n =? m)
Nat.setbit_eqb:
forall a n m : nat,
Nat.testbit (Nat.setbit a n) m = ((n =? m) || Nat.testbit a m)%bool
Nat.clearbit_eqb:
forall a n m : nat,
Nat.testbit (Nat.clearbit a n) m = (Nat.testbit a m && negb (n =? m))%bool
Nat.testbit_eqb: forall a n : nat, Nat.testbit a n = ((a / 2 ^ n) mod 2 =? 1)
You could also do
Search ((_ =? _) = true).
which gives you the lemmas which contain a subterm matching the pattern ((_ =? _) = true), which is the subset
Nat.eqb_refl: forall x : nat, (x =? x) = true
beq_nat_true: forall n m : nat, (n =? m) = true -> n = m
Nat.eqb_eq: forall n m : nat, (n =? m) = true <-> n = m
Of these, it looks like
beq_nat_true: forall n m : nat, (n =? m) = true -> n = m
does what you want. You should be able to solve your goal with any of
now apply beq_nat_true.
auto using beq_nat_true.
apply beq_nat_true, e0.
apply beq_nat_true in e0; exact e0.
apply beq_nat_true in e0; subst; reflexivity.
now apply beq_nat_true in e0.
If you want to turn this into a tactic, you can write something like
Ltac beq_nat_to_eq :=
repeat match goal with
| [ H : (_ =? _) = true |- _ ] => apply beq_nat_true in H
| [ H : (_ =? _) = false |- _ ] => apply beq_nat_false in H
end.
I am learning Homotopic Type Theory (HoTT) and its relation to COQ.
Especially the path induction concept of the identity type is still mysterious to me.
Therefore I made some experiments with COQ.
Let's start with a simple Lemma for the standard equality type using path induction:
Lemma eq_sym: forall (x y:nat), x = y -> y = x.
intros.
apply (match H in (_ = y0) return y0 = x with eq_refl => eq_refl end).
Defined.
Now let's see if that is a special handling of the COQ "eq" type. Therefore let's define a new equality type (only for nat) with an analogous symmetry lemma:
Inductive est (x : nat) : nat -> Prop :=
est_refl: est x x.
Lemma est_sym: forall (x y:nat), est x y -> est y x.
intros.
apply (match H in (est _ y0) return est y0 x with est_refl => est_refl x end).
Defined.
Ok, this works in the same way like the standard "=" type.
Now let's generalise it:
Inductive tri (x : nat) : nat->nat->Prop :=
tri_refl: tri x x x.
Lemma tri_sym: forall (x y z:nat), tri x y z -> tri z x y.
intros.
apply (match H in (tri _ y0 z0) return tri z0 x y0 with tri_refl => tri_refl x end).
Defined.
My question is:
How does this relate to the theory of HoTT?
Is this a generalised path induction which is not part of HoTT?
Your "three-ended equality" is equivalent to a pair of equality proofs, in the sense that we can write Coq functions that convert back and forth between the two forms. (These are the eq_of_teq and teq_of_eq terms in the excerpt below.)
Section Teq.
Variable T : Type.
Inductive teq (x : T) : T -> T -> Prop :=
| teq_refl : teq x x x.
Definition teq_of_eq {x y z} (e1 : x = y) (e2 : x = z) : teq x y z :=
match e1 in _ = y' return x = z -> teq x y' z with
| eq_refl => fun e2 =>
match e2 in _ = z' return teq x x z' with
| eq_refl => teq_refl x
end
end e2.
Definition eq_of_teq1 {x y z} (te : teq x y z) : x = y :=
match te in teq _ y' z' return x = y' with
| teq_refl => eq_refl
end.
Definition eq_of_teq2 {x y z} (te : teq x y z) : x = z :=
match te in teq _ y' z' return x = z' with
| teq_refl => eq_refl
end.
Definition teq_eq_teq x y z (te : teq x y z) :
teq_of_eq (eq_of_teq1 te) (eq_of_teq2 te) = te :=
match te as te' in teq _ y' z' return teq_of_eq (eq_of_teq1 te') (eq_of_teq2 te') = te' with
| teq_refl => eq_refl
end.
Definition eq_teq_eq1 x y z (e1 : x = y) (e2 : x = z) :
eq_of_teq1 (teq_of_eq e1 e2) = e1 :=
match e1 as e1' in _ = y' return eq_of_teq1 (teq_of_eq e1' e2) = e1' with
| eq_refl =>
match e2 as e2' in _ = z' return eq_of_teq1 (teq_of_eq eq_refl e2') = eq_refl with
| eq_refl => eq_refl
end
end.
Definition eq_teq_eq2 x y z (e1 : x = y) (e2 : x = z) :
eq_of_teq2 (teq_of_eq e1 e2) = e2 :=
match e1 as e1' in _ = y' return eq_of_teq2 (teq_of_eq e1' e2) = e2 with
| eq_refl =>
match e2 as e2' in _ = z' return eq_of_teq2 (teq_of_eq eq_refl e2') = e2' with
| eq_refl => eq_refl
end
end.
End Teq.
The teq_eq_teq, eq_teq_eq1 and eq_teq_eq2 lemmas show that the converting back and forth does not change the terms we start with; hence, both representations are equivalent. In this sense, Coq does not have more expressive power than HoTT just because we can define a teq.
In basic Martin-Löf type theory (the formal system upon which HoTT is based), you don't gain much by carrying a pair of equalities between the same terms, since the only thing you can do with such equalities is to perform casts on the types of the terms you manipulate. Thus, it doesn't really matter usually whether you have only one or two equality proofs between terms.
The situation changes a little bit in HoTT because of the addition of the univalence axiom, which allows us to use equality proofs between types in a computationally interesting way. This is because a proof of A = B in HoTT can be any bijection between the types A = B. In that setting, a proof of teq A B C would be equivalent to two bijections: one between A and B, and the other one between A and C.