I'm using Descriptions, like they are described here, as a way of encoding the shape of inductive data types. However, I'm stuck on how to represent inductive types that are:
Mutually inductive
Have different indices
For example, suppose we've got something like this, where we're ordering different types:
data Foo : Set where
N : ℕ -> Foo
P : (Foo × Foo) -> Foo
data <N : ℕ -> ℕ -> Set where
<0 : (n : ℕ) -> <N zero n
<suc : (m n : ℕ) -> <N m n -> <N (suc m) (suc n)
data <P : (Foo × Foo) -> (Foo × Foo) -> Set
data <F : Foo -> Foo -> Set
data <P where
<Pair : (x1 x2 y1 y2 : Foo) -> <F x1 y1 -> <F x2 y2 -> <P (x1 , x2) (y1 , y2)
data <F where
<FN : ∀ (a b : ℕ) -> <N a b -> <F (N a) (N b)
<FP : ∀ (p1 p2 : (Foo × Foo) ) -> <P p1 p2 -> <F (P p1) (P p2)
That is, we've got a type of binary trees with nats at the leaves. We have a partial order between trees, where we compare nats in the usual way, and we compare pairs of nodes by comparing their respective subtrees.
Notice how <F and <P are mutually dependent on each other. Of course, we could inline this to make <F and <P one type, I'm trying to avoid that, for cases where <P is more complicated.
What I'm wondering is: can the above partial order types be expressed using Descriptions?
I get stuck even trying to describe the above types as the fixed-point of an indexed functor. Usually we have an index type (I : Set) and the functor has type (X : I -> Set) -> I -> Set. But we can't have both "Foo" and "Foo × Foo" be our I value. Is there some trick that allows us to use
I = Foo ⊎ (Foo × Foo)?
Take the sum of all of the indices:
Ix = ((Foo × Foo) × (Foo × Foo)) ⊎ (Foo × Foo)
data <P : Ix -> Set
data <F : Ix -> Set
data <P where
<Pair : (x1 x2 y1 y2 : Foo) -> <F (inj₂(x1 , y1)) -> <F (inj₂(x2 , y2))
-> <P (inj₁((x1 , x2), (y1 , y2)))
data <F where
<FN : ∀ (a b : ℕ) -> <N a b -> <F (inj₂(N a , N b))
<FP : ∀ (p1 p2 : (Foo × Foo) ) -> <P (inj₁(p1 , p2)) -> <F (inj₂(P p1 , P p2))
We can tidy up the indices a bit more, and write things in a form which is more obviously describable by indexed functors:
data Ix : Set where
<P : Foo × Foo → Foo × Foo → Ix
<F : Foo → Foo → Ix
data T : Ix → Set where
<Pair : ∀ x1 x2 y1 y2 → T (<F x1 y1) → T (<F x2 y2)
→ T (<P (x1 , x2) (y1 , y2))
<FN : ∀ (a b : ℕ) → <N a b → T (<F (N a) (N b))
<FP : ∀ p1 p2 → T (<P p1 p2) → T (<F (P p1) (P p2))
I note though that <P and <F can be defined recursively, so induction is not essential here.
<F : Foo → Foo → Set
<F (N n) (N n') = <N n n'
<F (P (x , y)) (P (x' , y')) = <F x x' × <F y y'
<F (N _) (P _) = ⊥
<F (P _) (N _) = ⊥
I have the following addition in Isabelle:
function proj_add :: "(real × real) × bit ⇒ (real × real) × bit ⇒ (real × real) × bit" where
"proj_add ((x1,y1),l) ((x2,y2),j) = ((add (x1,y1) (x2,y2)), l+j)"
if "delta x1 y1 x2 y2 ≠ 0 ∧ (x1,y1) ∈ e_aff ∧ (x2,y2) ∈ e_aff"
| "proj_add ((x1,y1),l) ((x2,y2),j) = ((ext_add (x1,y1) (x2,y2)), l+j)"
if "delta' x1 y1 x2 y2 ≠ 0 ∧ (x1,y1) ∈ e_aff ∧ (x2,y2) ∈ e_aff"
| "proj_add ((x1,y1),l) ((x2,y2),j) = undefined"
if "delta x1 y1 x2 y2 = 0 ∧ delta' x1 y1 x2 y2 = 0 ∨ (x1,y1) ∉ e_aff ∨ (x2,y2) ∉ e_aff"
apply(fast,fastforce)
using coherence e_aff_def by auto
Now, I want to extract all defined values to simulate addition on classes instead of specific values:
function proj_add_class :: "((real × real) × bit) set ⇒ ((real × real) × bit) set ⇒ ((real × real) × bit) set" where
"proj_add_class c1 c2 =
(⋃ cr ∈ c1 × c2. proj_add cr.fst cr.snd)"
The above is just a template. Apparently, I cannot take the first element from cr and thus I'm getting an error. On the other hand, how can I remove undefined values?
See here for the complete theory.
Background
Having gained a certain level of understanding of the article upon which the formalisation is based, I decided to update the answer. The original answer is available through the revision history: I believe that everything that was stated in the original answer is sensible, but, possibly, less optimal from the perspective of the style of exposition than the revised answer.
Introduction
I use a slightly updated notation based on my own revision of a part of a draft of your formalisation associated with 4033cbf288. The following theories have been imported: Complex_Main "HOL-Algebra.Group" "HOL-Algebra.Bij" and "HOL-Library.Bit"
Definitions I
First, I restate some of the relevant definitions to ensure that the answer is self-contained:
locale curve_addition =
fixes c d :: real
begin
definition e :: "real ⇒ real ⇒ real"
where "e x y = x⇧2 + c*y⇧2 - 1 - d*x⇧2*y⇧2"
fun add :: "real × real ⇒ real × real ⇒ real × real" (infix ‹⊕⇩E› 65)
where
"(x1, y1) ⊕⇩E (x2, y2) =
(
(x1*x2 - c*y1*y2) div (1 - d*x1*y1*x2*y2),
(x1*y2 + y1*x2) div (1 + d*x1*y1*x2*y2)
)"
definition delta_plus :: "real ⇒ real ⇒ real ⇒ real ⇒ real" (‹δ⇩y›)
where "δ⇩y x1 y1 x2 y2 = 1 + d*x1*y1*x2*y2"
definition delta_minus :: "real ⇒ real ⇒ real ⇒ real ⇒ real" (‹δ⇩x›)
where "δ⇩x x1 y1 x2 y2 = 1 - d*x1*y1*x2*y2"
definition delta :: "real ⇒ real ⇒ real ⇒ real ⇒ real" (‹δ⇩E›)
where "δ⇩E x1 y1 x2 y2 = (δ⇩x x1 y1 x2 y2) * (δ⇩y x1 y1 x2 y2)"
end
locale ext_curve_addition = curve_addition +
fixes c' d' t
assumes c'_eq_1[simp]: "c' = 1"
assumes d'_neq_0[simp]: "d' ≠ 0"
assumes c_def: "c = c'⇧2"
assumes d_def: "d = d'⇧2"
assumes t_sq_def: "t⇧2 = d/c"
assumes t_sq_n1: "t⇧2 ≠ 1"
begin
fun add0 :: "real × real ⇒ real × real ⇒ real × real" (infix ‹⊕⇩0› 65)
where "(x1, y1) ⊕⇩0 (x2, y2) = (x1, y1/sqrt(c)) ⊕⇩E (x2, y2/sqrt(c))"
definition delta_plus_0 :: "real ⇒ real ⇒ real ⇒ real ⇒ real" (‹δ⇩0⇩y›)
where "δ⇩0⇩y x1 y1 x2 y2 = δ⇩y x1 (y1/sqrt(c)) x2 (y2/sqrt(c))"
definition delta_minus_0 :: "real ⇒ real ⇒ real ⇒ real ⇒ real" (‹δ⇩0⇩x›)
where "δ⇩0⇩x x1 y1 x2 y2 = δ⇩x x1 (y1/sqrt(c)) x2 (y2/sqrt(c))"
definition delta_0 :: "real ⇒ real ⇒ real ⇒ real ⇒ real" (‹δ⇩0›)
where "δ⇩0 x1 y1 x2 y2 = (δ⇩0⇩x x1 y1 x2 y2) * (δ⇩0⇩y x1 y1 x2 y2)"
definition delta_plus_1 :: "real ⇒ real ⇒ real ⇒ real ⇒ real" (‹δ⇩1⇩y›)
where "δ⇩1⇩y x1 y1 x2 y2 = x1*x2 + y1*y2"
definition delta_minus_1 :: "real ⇒ real ⇒ real ⇒ real ⇒ real" (‹δ⇩1⇩x›)
where "δ⇩1⇩x x1 y1 x2 y2 = x2*y1 - x1*y2"
definition delta_1 :: "real ⇒ real ⇒ real ⇒ real ⇒ real" (‹δ⇩1›)
where "δ⇩1 x1 y1 x2 y2 = (δ⇩1⇩x x1 y1 x2 y2) * (δ⇩1⇩y x1 y1 x2 y2)"
fun ρ :: "real × real ⇒ real × real"
where "ρ (x, y) = (-y, x)"
fun τ :: "real × real ⇒ real × real"
where "τ (x, y) = (1/(t*x), 1/(t*y))"
fun add1 :: "real × real ⇒ real × real ⇒ real × real" (infix ‹⊕⇩1› 65)
where
"(x1, y1) ⊕⇩1 (x2, y2) =
(
(x1*y1 - x2*y2) div (x2*y1 - x1*y2),
(x1*y1 + x2*y2) div (x1*x2 + y1*y2)
)"
definition e' :: "real ⇒ real ⇒ real"
where "e' x y = x⇧2 + y⇧2 - 1 - t⇧2*x⇧2*y⇧2"
end
locale projective_curve = ext_curve_addition
begin
definition "E⇩a⇩f⇩f = {(x, y). e' x y = 0}"
definition "E⇩O = {(x, y). x ≠ 0 ∧ y ≠ 0 ∧ (x, y) ∈ E⇩a⇩f⇩f}"
definition G where
"G ≡ {id, ρ, ρ ∘ ρ, ρ ∘ ρ ∘ ρ, τ, τ ∘ ρ, τ ∘ ρ ∘ ρ, τ ∘ ρ ∘ ρ ∘ ρ}"
definition symmetries where
"symmetries = {τ, τ ∘ ρ, τ ∘ ρ ∘ ρ, τ ∘ ρ ∘ ρ ∘ ρ}"
definition rotations where
"rotations = {id, ρ, ρ ∘ ρ, ρ ∘ ρ ∘ ρ}"
definition E⇩a⇩f⇩f⇩0 where
"E⇩a⇩f⇩f⇩0 =
{
((x1, y1), (x2, y2)).
(x1, y1) ∈ E⇩a⇩f⇩f ∧ (x2, y2) ∈ E⇩a⇩f⇩f ∧ δ⇩0 x1 y1 x2 y2 ≠ 0
}"
definition E⇩a⇩f⇩f⇩1 where
"E⇩a⇩f⇩f⇩1 =
{
((x1, y1), (x2, y2)).
(x1, y1) ∈ E⇩a⇩f⇩f ∧ (x2, y2) ∈ E⇩a⇩f⇩f ∧ δ⇩1 x1 y1 x2 y2 ≠ 0
}"
end
Definitions II
I use coherence without proof, but I have ported the proof in the repository to my notation before copying the statement of the theorem to this answer, i.e. the proof does exist but it is not part of the answer.
context projective_curve
begin
type_synonym repEPCT = ‹((real × real) × bit)›
type_synonym EPCT = ‹repEPCT set›
definition gluing :: "(repEPCT × repEPCT) set"
where
"gluing =
{
(((x0, y0), l), ((x1, y1), j)).
((x0, y0) ∈ E⇩a⇩f⇩f ∧ (x1, y1) ∈ E⇩a⇩f⇩f) ∧
(
((x0, y0) ∈ E⇩O ∧ (x1, y1) = τ (x0, y0) ∧ j = l + 1) ∨
(x0 = x1 ∧ y0 = y1 ∧ l = j)
)
}"
definition E where "E = (E⇩a⇩f⇩f × UNIV) // gluing"
lemma coherence:
assumes "δ⇩0 x1 y1 x2 y2 ≠ 0" "δ⇩1 x1 y1 x2 y2 ≠ 0"
assumes "e' x1 y1 = 0" "e' x2 y2 = 0"
shows "(x1, y1) ⊕⇩1 (x2, y2) = (x1, y1) ⊕⇩0 (x2, y2)"
sorry
end
proj_add
The definition of proj_add is almost identical to the one in the original question with the exception of the added option domintros (it is hardly possible to state anything meaningful about it without the domain theorems). I also show that it is equivalent to the plain definition that is currently used.
context projective_curve
begin
function (domintros) proj_add :: "repEPCT ⇒ repEPCT ⇒ repEPCT"
(infix ‹⊙› 65)
where
"((x1, y1), i) ⊙ ((x2, y2), j) = ((x1, y1) ⊕⇩0 (x2, y2), i + j)"
if "(x1, y1) ∈ E⇩a⇩f⇩f" and "(x2, y2) ∈ E⇩a⇩f⇩f" and "δ⇩0 x1 y1 x2 y2 ≠ 0"
| "((x1, y1), i) ⊙ ((x2, y2), j) = ((x1, y1) ⊕⇩1 (x2, y2), i + j)"
if "(x1, y1) ∈ E⇩a⇩f⇩f" and "(x2, y2) ∈ E⇩a⇩f⇩f" and "δ⇩1 x1 y1 x2 y2 ≠ 0"
| "((x1, y1), i) ⊙ ((x2, y2), j) = undefined"
if "(x1, y1) ∉ E⇩a⇩f⇩f ∨ (x2, y2) ∉ E⇩a⇩f⇩f ∨
(δ⇩0 x1 y1 x2 y2 = 0 ∧ δ⇩1 x1 y1 x2 y2 = 0)"
subgoal by (metis τ.cases surj_pair)
subgoal by auto
subgoal unfolding E⇩a⇩f⇩f_def using coherence by auto
by auto
termination proj_add using "termination" by blast
lemma proj_add_pred_undefined:
assumes "¬ ((x1, y1), (x2, y2)) ∈ E⇩a⇩f⇩f⇩0 ∪ E⇩a⇩f⇩f⇩1"
shows "((x1, y1), l) ⊙ ((x2, y2), j) = undefined"
using assms unfolding E⇩a⇩f⇩f⇩0_def E⇩a⇩f⇩f⇩1_def
by (auto simp: proj_add.domintros(3) proj_add.psimps(3))
lemma proj_add_def:
"(proj_add ((x1, y1), i) ((x2, y2), j)) =
(
if ((x1, y1) ∈ E⇩a⇩f⇩f ∧ (x2, y2) ∈ E⇩a⇩f⇩f ∧ δ⇩0 x1 y1 x2 y2 ≠ 0)
then ((x1, y1) ⊕⇩0 (x2, y2), i + j)
else
(
if ((x1, y1) ∈ E⇩a⇩f⇩f ∧ (x2, y2) ∈ E⇩a⇩f⇩f ∧ δ⇩1 x1 y1 x2 y2 ≠ 0)
then ((x1, y1) ⊕⇩1 (x2, y2), i + j)
else undefined
)
)"
(is "?lhs = ?rhs")
proof(cases ‹δ⇩0 x1 y1 x2 y2 ≠ 0 ∧ (x1, y1) ∈ E⇩a⇩f⇩f ∧ (x2, y2) ∈ E⇩a⇩f⇩f›)
case True
then have True_exp: "(x1, y1) ∈ E⇩a⇩f⇩f" "(x2, y2) ∈ E⇩a⇩f⇩f" "δ⇩0 x1 y1 x2 y2 ≠ 0"
by auto
then have rhs: "?rhs = ((x1, y1) ⊕⇩0 (x2, y2), i + j)" by simp
show ?thesis unfolding proj_add.simps(1)[OF True_exp, of i j] rhs ..
next
case n0: False show ?thesis
proof(cases ‹δ⇩1 x1 y1 x2 y2 ≠ 0 ∧ (x1, y1) ∈ E⇩a⇩f⇩f ∧ (x2, y2) ∈ E⇩a⇩f⇩f›)
case True show ?thesis
proof-
from True n0 have False_exp:
"(x1, y1) ∈ E⇩a⇩f⇩f" "(x2, y2) ∈ E⇩a⇩f⇩f" "δ⇩1 x1 y1 x2 y2 ≠ 0"
by auto
with n0 have rhs: "?rhs = ((x1, y1) ⊕⇩1 (x2, y2), i + j)" by auto
show ?thesis unfolding proj_add.simps(2)[OF False_exp, of i j] rhs ..
qed
next
case False then show ?thesis using n0 proj_add.simps(3) by auto
qed
qed
end
proj_add_class
I also provide what I would consider to be a natural solution (again, using the function infrastructure) for the statement of proj_add_class and show that it agrees with the definition that is used at the moment on the domain of interest.
context projective_curve
begin
function (domintros) proj_add_class :: "EPCT ⇒ EPCT ⇒ EPCT" (infix ‹⨀› 65)
where
"A ⨀ B =
the_elem
(
{
((x1, y1), i) ⊙ ((x2, y2), j) | x1 y1 i x2 y2 j.
((x1, y1), i) ∈ A ∧ ((x2, y2), j) ∈ B ∧
((x1, y1), (x2, y2)) ∈ E⇩a⇩f⇩f⇩0 ∪ E⇩a⇩f⇩f⇩1
} // gluing
)"
if "A ∈ E" and "B ∈ E"
| "A ⨀ B = undefined" if "A ∉ E ∨ B ∉ E"
by (meson surj_pair) auto
termination proj_add_class using "termination" by auto
definition proj_add_class' (infix ‹⨀''› 65) where
"proj_add_class' c1 c2 =
the_elem
(
(case_prod (⊙) `
({(x, y). x ∈ c1 ∧ y ∈ c2 ∧ (fst x, fst y) ∈ E⇩a⇩f⇩f⇩0 ∪ E⇩a⇩f⇩f⇩1})) // gluing
)"
lemma proj_add_class_eq:
assumes "A ∈ E" and "B ∈ E"
shows "A ⨀' B = A ⨀ B"
proof-
have
"(λ(x, y). x ⊙ y) `
{(x, y). x ∈ A ∧ y ∈ B ∧ (fst x, fst y) ∈ E⇩a⇩f⇩f⇩0 ∪ E⇩a⇩f⇩f⇩1} =
{
((x1, y1), i) ⊙ ((x2, y2), j) | x1 y1 i x2 y2 j.
((x1, y1), i) ∈ A ∧ ((x2, y2), j) ∈ B ∧ ((x1, y1), x2, y2) ∈ E⇩a⇩f⇩f⇩0 ∪ E⇩a⇩f⇩f⇩1
}"
apply (standard; standard)
subgoal unfolding image_def by clarsimp blast
subgoal unfolding image_def by clarsimp blast
done
then show ?thesis
unfolding proj_add_class'_def proj_add_class.simps(1)[OF assms]
by auto
qed
end
Conclusion
The appropriate choice of a definition is a subjective matter. Therefore, I can only express my personal opinion about what I believe to be the most suitable choice.
Suppose I have some natural numbers d ≥ 2 and n > 0; in this case, I can split off the d's from n and get n = m * dk, where m is not divisible by d.
I'd like to use this repeated removal of the d-divisible parts as a recursion scheme; so I thought I'd make a datatype for the Steps leading to m:
import Data.Nat.DivMod
data Steps: (d : Nat) -> {auto dValid: d `GTE` 2} -> (n : Nat) -> Type where
Base: (rem: Nat) -> (rem `GT` 0) -> (rem `LT` d) -> (quot : Nat) -> Steps d {dValid} (rem + quot * d)
Step: Steps d {dValid} n -> Steps d {dValid} (n * d)
and write a recursive function that computes the Steps for a given pair of d and n:
total lemma: x * y `GT` 0 -> x `GT` 0
lemma {x = Z} LTEZero impossible
lemma {x = Z} (LTESucc _) impossible
lemma {x = (S k)} prf = LTESucc LTEZero
steps : (d : Nat) -> {auto dValid: d `GTE` 2} -> (n : Nat) -> {auto nValid: n `GT` 0} -> Steps d {dValid} n
steps Z {dValid = LTEZero} _ impossible
steps Z {dValid = (LTESucc _)} _ impossible
steps (S d) {dValid} n {nValid} with (divMod n d)
steps (S d) (q * S d) {nValid} | MkDivMod q Z _ = Step (steps (S d) {dValid} q {nValid = lemma nValid})
steps (S d) (S rem + q * S d) | MkDivMod q (S rem) remSmall = Base (S rem) (LTESucc LTEZero) remSmall q
However, steps is not accepted as total since there's no apparent reason why the recursive call is well-founded (there's no structural relationship between q and n).
But I also have a function
total wf : (S x) `LT` (S x) * S (S y)
with a boring proof.
Can I use wf in the definition of steps to explain to Idris that steps is total?
Here is one way of using well-founded recursion to do what you're asking. I'm sure though, that there is a better way. In what follows I'm going to use the standard LT function, which allows us to achieve our goal, but there some obstacles we will need to work around.
Unfortunately, LT is a function, not a type constructor or a data constructor, which means we cannot define an implementation of the
WellFounded
typeclass for LT. The following code is a workaround for this situation:
total
accIndLt : {P : Nat -> Type} ->
(step : (x : Nat) -> ((y : Nat) -> LT y x -> P y) -> P x) ->
(z : Nat) -> Accessible LT z -> P z
accIndLt {P} step z (Access f) =
step z $ \y, lt => accIndLt {P} step y (f y lt)
total
wfIndLt : {P : Nat -> Type} ->
(step : (x : Nat) -> ((y : Nat) -> LT y x -> P y) -> P x) ->
(x : Nat) -> P x
wfIndLt step x = accIndLt step x (ltAccessible x)
We are going to need some helper lemmas dealing with the less than relation, the lemmas can be found in this gist (Order module). It's a subset of my personal library which I recently started. I'm sure the proofs of the helper lemmas can be minimized, but it wasn't my goal here.
After importing the Order module, we can solve the problem (I slightly modified the original code, it's not difficult to change it or write a wrapper to have the original type):
total
steps : (n : Nat) -> {auto nValid : 0 `LT` n} -> (d : Nat) -> Steps (S (S d)) n
steps n {nValid} d = wfIndLt {P = P} step n d nValid
where
P : (n : Nat) -> Type
P n = (d : Nat) -> (nV : 0 `LT` n) -> Steps (S (S d)) n
step : (n : Nat) -> (rec : (q : Nat) -> q `LT` n -> P q) -> P n
step n rec d nV with (divMod n (S d))
step (S r + q * S (S d)) rec d nV | (MkDivMod q (S r) prf) =
Base (S r) (LTESucc LTEZero) prf q
step (Z + q * S (S d)) rec d nV | (MkDivMod q Z _) =
let qGt0 = multLtNonZeroArgumentsLeft nV in
let lt = multLtSelfRight (S (S d)) qGt0 (LTESucc (LTESucc LTEZero)) in
Step (rec q lt d qGt0)
I modeled steps after the divMod function from the contrib/Data/Nat/DivMod/IteratedSubtraction.idr module.
Full code is available here.
Warning: the totality checker (as of Idris 0.99, release version) does not accept steps as total. It has been recently fixed and works for our problem (I tested it with Idris 0.99-git:17f0899c).
I've two Fibonacci implementations, seen below, that I want to prove are functionally equivalent.
I've already proved properties about natural numbers, but this exercise requires another approach that I cannot figure out.
The textbook I'm using have introduced the following syntax of Coq, so it should be possible to prove equality using this notation:
<definition> ::= <keyword> <identifier> : <statement> <proof>
<keyword> ::= Proposition | Lemma | Theorem | Corollary
<statement> ::= {<quantifier>,}* <expression>
<quantifier> ::= forall {<identifier>}+ : <type>
| forall {({<identifier>}+ : <type>)}+
<proof> ::= Proof. {<tactic>.}* <end-of-proof>
<end-of-proof> ::= Qed. | Admitted. | Abort.
Here are the two implementations:
Fixpoint fib_v1 (n : nat) : nat :=
match n with
| 0 => O
| S n' => match n' with
| O => 1
| S n'' => (fib_v1 n') + (fib_v1 n'')
end
end.
Fixpoint visit_fib_v2 (n a1 a2 : nat) : nat :=
match n with
| 0 => a1
| S n' => visit_fib_v2 n' a2 (a1 + a2)
end.
It is pretty obvious that these functions compute the same value for the base case n = 0, but the induction case is much harder?
I've tried proving the following Lemma, but I'm stuck in induction case:
Lemma about_visit_fib_v2 :
forall i j : nat,
visit_fib_v2 i (fib_v1 (S j)) ((fib_v1 j) + (fib_v1 (S j))) = (fib_v1 (add_v1 i (S j))).
Proof.
induction i as [| i' IHi'].
intro j.
rewrite -> (unfold_visit_fib_v2_0 (fib_v1 (S j)) ((fib_v1 j) + (fib_v1 (S j)))).
rewrite -> (add_v1_0_n (S j)).
reflexivity.
intro j.
rewrite -> (unfold_visit_fib_v2_S i' (fib_v1 (S j)) ((fib_v1 j) + (fib_v1 (S j)))).
Admitted.
Where:
Fixpoint add_v1 (i j : nat) : nat :=
match i with
| O => j
| S i' => S (add_v1 i' j)
end.
A note of warning: in what follows I'll to try to show the main idea of such a proof, so I'm not going to stick to some subset of Coq and I won't do arithmetic manually. Instead I'll use some proof automation, viz. the ring tactic. However, feel free to ask additional questions, so you could convert the proof to somewhat that would suit your purposes.
I think it's easier to start with some generalization:
Require Import Arith. (* for `ring` tactic *)
Lemma fib_v1_eq_fib2_generalized n : forall a0 a1,
visit_fib_v2 (S n) a0 a1 = a0 * fib_v1 n + a1 * fib_v1 (S n).
Proof.
induction n; intros a0 a1.
- simpl; ring.
- change (visit_fib_v2 (S (S n)) a0 a1) with
(visit_fib_v2 (S n) a1 (a0 + a1)).
rewrite IHn. simpl; ring.
Qed.
If using ring doesn't suit your needs, you can perform multiple rewrite steps using the lemmas of the Arith module.
Now, let's get to our goal:
Definition fib_v2 n := visit_fib_v2 n 0 1.
Lemma fib_v1_eq_fib2 n :
fib_v1 n = fib_v2 n.
Proof.
destruct n.
- reflexivity.
- unfold fib_v2. rewrite fib_v1_eq_fib2_generalized.
ring.
Qed.
#larsr's answer inspired this alternative answer.
First of all, let's define fib_v2:
Require Import Coq.Arith.Arith.
Definition fib_v2 n := visit_fib_v2 n 0 1.
Then, we are going to need a lemma, which is the same as fib_v2_lemma in #larsr's answer. I'm including it here for consistency and to show an alternative proof.
Lemma visit_fib_v2_main_property n: forall a0 a1,
visit_fib_v2 (S (S n)) a0 a1 =
visit_fib_v2 (S n) a0 a1 + visit_fib_v2 n a0 a1.
Proof.
induction n; intros a0 a1; auto with arith.
change (visit_fib_v2 (S (S (S n))) a0 a1) with
(visit_fib_v2 (S (S n)) a1 (a0 + a1)).
apply IHn.
Qed.
As suggested in the comments by larsr, the visit_fib_v2_main_property lemma can be also proved by the following impressive one-liner:
now induction n; firstorder.
Because of the nature of the numbers in the Fibonacci series it's very convenient to define an alternative induction principle:
Lemma pair_induction (P : nat -> Prop) :
P 0 ->
P 1 ->
(forall n, P n -> P (S n) -> P (S (S n))) ->
forall n, P n.
Proof.
intros H0 H1 Hstep n.
enough (P n /\ P (S n)) by tauto.
induction n; intuition.
Qed.
The pair_induction principle basically says that if we can prove some property P for 0 and 1 and if for every natural number k > 1, we can prove P k holds under the assumption that P (k - 1) and P (k - 2) hold, then we can prove forall n, P n.
Using our custom induction principle, we get the proof as follows:
Lemma fib_v1_eq_fib2 n :
fib_v1 n = fib_v2 n.
Proof.
induction n using pair_induction.
- reflexivity.
- reflexivity.
- unfold fib_v2.
rewrite visit_fib_v2_main_property.
simpl; auto.
Qed.
Anton's proof is very beautiful, and better than mine, but it might be useful, anyway.
Instead of coming up with the generalisation lemma, I strengthened the induction hypothesis.
Say the original goal is Q n. I then changed the goal with
cut (Q n /\ Q (S n))
from
Q n
to
Q n /\ Q (S n)
This new goal trivially implies the original goal, but with it the induction hypothesis becomes stronger, so it becomes possible to rewrite more.
IHn : Q n /\ Q (S n)
=========================
Q (S n) /\ Q (S (S n))
This idea is explained in Software Foundations in the chapter where one does proofs over even numbers.
Because the propostion often is very long, I made an Ltac tactic that names the long and messy term.
Ltac nameit Q :=
match goal with [ _:_ |- ?P ?n] => let X := fresh Q in remember P as X end.
Require Import Ring Arith.
(Btw, I renamed vistit_fib_v2 to fib_v2.)
I needed a lemma about one step of fib_v2.
Lemma fib_v2_lemma: forall n a b, fib_v2 (S (S n)) a b = fib_v2 (S n) a b + fib_v2 n a b.
intro n.
pattern n.
nameit Q.
cut (Q n /\ Q (S n)).
tauto. (* Q n /\ Q (S n) -> Q n *)
induction n.
split; subst; simpl; intros; ring. (* Q 0 /\ Q 1 *)
split; try tauto. (* Q (S n) *)
subst Q. (* Q (S (S n)) *)
destruct IHn as [H1 H2].
assert (L1: forall n a b, fib_v2 (S n) a b = fib_v2 n b (a+b)) by reflexivity.
congruence.
Qed.
The congruence tactic handles goals that follow from a bunch of A = B assumptions and rewriting.
Proving the theorem is very similar.
Theorem fib_v1_fib_v2 : forall n, fib_v1 n = fib_v2 n 0 1.
intro n.
pattern n.
nameit Q.
cut (Q n /\ Q (S n)).
tauto. (* Q n /\ Q (S n) -> Q n *)
induction n.
split; subst; simpl; intros; ring. (* Q 0 /\ Q 1 *)
split; try tauto. (* Q (S n) *)
subst Q. (* Q (S (S n)) *)
destruct IHn as [H1 H2].
assert (fib_v1 (S (S n)) = fib_v1 (S n) + fib_v1 n) by reflexivity.
assert (fib_v2 (S (S n)) 0 1 = fib_v2 (S n) 0 1 + fib_v2 n 0 1) by
(pose fib_v2_lemma; congruence).
congruence.
Qed.
All the boiler plate code could be put in a tactic, but I didn't want to go crazy with the Ltac, since that was not what the question was about.
This proof script only shows the proof structure. It could be useful to explain the idea of the proof.
Require Import Ring Arith Psatz. (* Psatz required by firstorder *)
Theorem fibfib: forall n, fib_v2 n 0 1 = fib_v1 n.
Proof with (intros; simpl in *; ring || firstorder).
assert (H: forall n a0 a1, fib_v2 (S n) a0 a1 = a0 * (fib_v1 n) + a1 * (fib_v1 (S n))).
{ induction n... rewrite IHn; destruct n... }
destruct n; try rewrite H...
Qed.
There is a very powerful library -- math-comp written in the Ssreflect formal proof language that is in its turn based on Coq. In this answer I present a version that uses its facilities. It's just a simplified piece of this development. All credit goes to the original author.
Let's do some imports and the definitions of our two functions, math-comp (ssreflect) style:
From mathcomp
Require Import ssreflect ssrnat ssrfun eqtype ssrbool.
Fixpoint fib_rec (n : nat) {struct n} : nat :=
if n is n1.+1 then
if n1 is n2.+1 then fib_rec n1 + fib_rec n2
else 1
else 0.
Fixpoint fib_iter (a b n : nat) {struct n} : nat :=
if n is n1.+1 then
if n1 is n2.+1
then fib_iter b (b + a) n1
else b
else a.
A helper lemma expressing the basic property of Fibonacci numbers:
Lemma fib_iter_property : forall n a b,
fib_iter a b n.+2 = fib_iter a b n.+1 + fib_iter a b n.
Proof.
case=>//; elim => [//|n IHn] a b; apply: IHn.
Qed.
Now, let's tackle equivalence of the two implementations.
The main idea here, that distinguish the following proof from the other proofs has been presented as of time of this writing, is that we perform
kind of complete induction, using elim: n {-2}n (leqnn n). This gives us the following (strong) induction hypothesis:
IHn : forall n0 : nat, n0 <= n -> fib_rec n0 = fib_iter 0 1 n0
Here is the main lemma and its proof:
Lemma fib_rec_eq_fib_iter : fib_rec =1 fib_iter 0 1.
Proof.
move=>n; elim: n {-2}n (leqnn n)=> [n|n IHn].
by rewrite leqn0; move/eqP=>->.
case=>//; case=>// n0; rewrite ltnS=> ltn0n.
rewrite fib_iter_property.
by rewrite <- (IHn _ ltn0n), <- (IHn _ (ltnW ltn0n)).
Qed.
Here is yet another answer, similar to the one using mathcomp, but this one uses "vanilla" Coq.
First of all, we need some imports, additional definitions, and a couple of helper lemmas:
Require Import Coq.Arith.Arith.
Definition fib_v2 n := visit_fib_v2 n 0 1.
Lemma visit_fib_v2_property n: forall a0 a1,
visit_fib_v2 (S (S n)) a0 a1 =
visit_fib_v2 (S n) a0 a1 + visit_fib_v2 n a0 a1.
Proof. now induction n; firstorder. Qed.
Lemma fib_v2_property n:
fib_v2 (S (S n)) = fib_v2 (S n) + fib_v2 n.
Proof. apply visit_fib_v2_property. Qed.
To prove the main lemma we are going to use the standard well-founded induction lt_wf_ind principle for natural numbers with the < relation (a.k.a. complete induction):
This time we need to prove only one subgoal, since the n = 0 case for complete induction is always vacuously true. Our induction hypothesis, unsurprisingly, looks like this:
IH : forall m : nat, m < n -> fib_v1 m = fib_v2 m
Here is the proof:
Lemma fib_v1_eq_fib2 n :
fib_v1 n = fib_v2 n.
Proof.
pattern n; apply lt_wf_ind; clear n; intros n IH.
do 2 (destruct n; trivial).
rewrite fib_v2_property.
rewrite <- !IH; auto.
Qed.