├── .gitignore ├── _CoqProject ├── LICENSE ├── SigmaEta.v ├── FunctionExtensionality.v ├── Eqdep_dec.v ├── README.md ├── Adjointification.v ├── ReduceIWtoW.v ├── IWType.v ├── CharacterizeIWEquality.v ├── FiberProperties.v └── FiberEquiv.v /.gitignore: -------------------------------------------------------------------------------- 1 | *.aux 2 | *.bak 3 | 4 | *.vo 5 | *.glob 6 | *.v.d 7 | 8 | *.swp 9 | \#*# 10 | 11 | Makefile 12 | 13 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R . IWTypes 2 | Adjointification.v 3 | FunctionExtensionality.v 4 | IWType.v 5 | SigmaEta.v 6 | ReduceIWtoW.v 7 | CharacterizeIWEquality.v 8 | FiberEquiv.v 9 | Eqdep_dec.v 10 | FiberProperties.v 11 | 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Jasper Hugunin 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /SigmaEta.v: -------------------------------------------------------------------------------- 1 | (* 2 | Coq does not have judgemental sigma eta conversion. 3 | Assuming function extensionality, we develop eta conversion 4 | inside a function, as part of a term whose type is judgementally 5 | the same before and after the eta expansion. 6 | 7 | This was surprisingly hard to prove. 8 | *) 9 | 10 | From IWTypes Require Import FunctionExtensionality. 11 | 12 | Section sigma_eta. 13 | Context {FunExt : FunExt}. 14 | 15 | Definition sigma_eta_eq {A} (P : A -> Type) (x : sigT P) 16 | : x = existT P (projT1 x) (projT2 x) 17 | := match x with existT _ p1 p2 => eq_refl end. 18 | 19 | Context {A B} (P : forall a : A, B a -> Type). 20 | 21 | Definition sigma_eta_family f (a : A) : sigT (P a) 22 | := existT _ (projT1 (f a)) (projT2 (f a)). 23 | Definition sigma_eta_family_eq f : f = sigma_eta_family f 24 | := funext (fun a => sigma_eta_eq (P a) (f a)). 25 | 26 | Context (C : forall (p1 : forall a, B a), (forall a, P a (p1 a)) -> Type). 27 | Definition Cf f := C (fun a => projT1 (f a)) (fun a => projT2 (f a)). 28 | Context (make_C : forall f, Cf f). 29 | 30 | Definition sigma_eta_family_funext f 31 | : make_C (sigma_eta_family f) = make_C f 32 | := let lemma 33 | : eq_rect (Cf (sigma_eta_family f)) (fun T => T) 34 | (make_C (sigma_eta_family f)) (Cf f) 35 | (f_equal Cf (eq_trans 36 | (eq_sym (sigma_eta_family_eq f)) 37 | (sigma_eta_family_eq f))) = 38 | make_C f 39 | := match eq_sym (sigma_eta_family_eq f) as p in (_ = f') 40 | return 41 | eq_rect (Cf (sigma_eta_family f)) (fun T => T) 42 | (make_C (sigma_eta_family f)) (Cf f') 43 | (f_equal Cf (eq_trans p (sigma_eta_family_eq f'))) = 44 | make_C f' 45 | with eq_refl => f_equal 46 | (fun p2 => 47 | eq_rect _ (fun T => T) _ _ (f_equal Cf (eq_trans eq_refl p2))) 48 | (funext_comp eq_refl) 49 | end in 50 | let cancel_paths {A} {a b : A} (p : a = b) 51 | : eq_trans (eq_sym p) p = eq_refl 52 | := match p in (_ = b) return eq_trans (eq_sym p) p = eq_refl 53 | with eq_refl => eq_refl end in 54 | match cancel_paths (sigma_eta_family_eq f) in (_ = p) 55 | return eq_rect _ (fun T => T) _ _ (f_equal Cf p) = _ 56 | with eq_refl => lemma end. 57 | End sigma_eta. -------------------------------------------------------------------------------- /FunctionExtensionality.v: -------------------------------------------------------------------------------- 1 | (* 2 | Proof that strong function extensionality follows 3 | from naive function extensionality. 4 | 5 | We create a typeclass carrying a proof of naive functionality, 6 | and provide a version of function extensionality that is an 7 | adjoint equivalence with the cannonical happly. 8 | 9 | To use, simply provide an instance of FunExt in the context. 10 | *) 11 | 12 | From IWTypes Require Adjointification. 13 | 14 | Class FunExt := funext_raw 15 | : forall {A B} (f g : forall a : A, B a), (forall a, f a = g a) -> f = g. 16 | 17 | Section funext. 18 | Context {FunExt : FunExt}. 19 | Context {A} {B : A -> Type}. 20 | Implicit Types f g : forall a, B a. 21 | 22 | Definition happly {f g} (feq : f = g) : forall a, f a = g a 23 | := match feq in (_ = g) return forall a, f a = g a 24 | with eq_refl => fun a => eq_refl end. 25 | 26 | Definition funext {f g} (hom : forall a, f a = g a) : f = g 27 | := eq_trans (eq_sym (funext_raw f f (happly eq_refl))) (funext_raw f g hom). 28 | 29 | Definition funext_comp {f g} (feq : f = g) 30 | : funext (happly feq) = feq 31 | := match feq return funext (happly feq) = feq 32 | with eq_refl => eq_trans_sym_inv_l (funext_raw f f (happly eq_refl)) end. 33 | End funext. 34 | 35 | Section funext_app. 36 | Context {FunExt : FunExt}. 37 | Context {A} {B : A -> Type}. 38 | Implicit Types f g : forall a, B a. 39 | 40 | Definition funext_contract {f g} (hom : forall a, f a = g a) 41 | : existT _ f (fun a => eq_refl) = existT _ g hom 42 | := f_equal 43 | (fun r => existT (fun g => forall a, f a = g a) 44 | (fun a => projT1 (r a)) (fun a => projT2 (r a))) 45 | (funext (fun a => 46 | match hom a as homa in (_ = ga) 47 | return existT _ (f a) eq_refl = existT _ ga homa 48 | with eq_refl => eq_refl end)). 49 | 50 | Definition funext_app {f g} 51 | : forall (hom : forall a, f a = g a), happly (funext hom) = hom 52 | := Adjointification.fg_id' happly funext funext_comp 53 | (fun hom => match funext_contract hom in (_ = existT _ g hom) 54 | return happly (funext hom) = hom 55 | with eq_refl => f_equal happly (funext_comp eq_refl) end). 56 | 57 | Definition happly_adjoint {f g} 58 | : forall feq : f = g, 59 | funext_app (happly feq) = f_equal happly (funext_comp feq) 60 | := Adjointification.f_adjoint _ _ _ _. 61 | 62 | Definition funext_adjoint {f g} 63 | : forall hom : forall a, f a = g a, 64 | funext_comp (funext hom) = f_equal funext (funext_app hom) 65 | := Adjointification.g_adjoint _ _ _ _. 66 | End funext_app. 67 | -------------------------------------------------------------------------------- /Eqdep_dec.v: -------------------------------------------------------------------------------- 1 | (* Based on Coq's Eqdep_dec module, but for Type. *) 2 | Section Eqdep_dec. 3 | Context {A : Type} (x : A) (A_dec : forall y : A, (x = y) + (x = y -> False)). 4 | 5 | Let comp (y y' : A) (eq1 : x = y) (eq2 : x = y') : y = y' 6 | := eq_ind x (fun a : A => a = y') eq2 y eq1. 7 | 8 | Definition trans_sym_eq (y : A) (u : x = y) : comp y y u u = eq_refl 9 | := match u with eq_refl => eq_refl end. 10 | 11 | Let nu y : x = y -> x = y 12 | := fun xeqy => 13 | match A_dec y with 14 | | inl xeqy' => xeqy' 15 | | inr xneqy => False_rect _ (xneqy xeqy) 16 | end. 17 | 18 | Let nu_constant y (u v : x = y) : nu y u = nu y v 19 | := match A_dec y as d 20 | return 21 | match d with inl xeqy => xeqy | inr xneqy => False_rect _ (xneqy u) end 22 | = 23 | match d with inl xeqy => xeqy | inr xneqy => False_rect _ (xneqy v) end 24 | with 25 | | inl xeqy => eq_refl 26 | | inr xneqy => False_rect _ (xneqy u) 27 | end. 28 | 29 | Let nu_inv y (v : x = y) : x = y 30 | := comp x y (nu x eq_refl) v. 31 | 32 | Let proj (P : A -> Type) (exP : sigT P) (def : P x) : P x := 33 | match exP with 34 | | existT _ x' prf => 35 | match A_dec x' with 36 | | inl eqprf => eq_rect x' P prf x (eq_sym eqprf) 37 | | _ => def 38 | end 39 | end. 40 | 41 | Definition nu_left_inv_on (y : A) (u : x = y) : nu_inv y (nu y u) = u 42 | := match u with eq_refl => trans_sym_eq x (nu x eq_refl) end. 43 | 44 | Definition eq_proofs_unicity_on (y : A) (p1 p2 : x = y) : p1 = p2 45 | := eq_ind (nu_inv y (nu y p1)) (fun p3 : x = y => p3 = p2) 46 | (eq_ind (nu_inv y (nu y p2)) (fun p3 : x = y => nu_inv y (nu y p1) = p3) 47 | (eq_ind (nu y p1) (fun e : x = y => nu_inv y (nu y p1) = nu_inv y e) 48 | eq_refl (nu y p2) (nu_constant y p1 p2)) p2 49 | (nu_left_inv_on y p2)) p1 (nu_left_inv_on y p1). 50 | 51 | Definition K_dec_on (P : x = x -> Type) (H : P eq_refl) (p : x = x) : P p 52 | := eq_rect eq_refl P H p (eq_proofs_unicity_on x eq_refl p). 53 | 54 | Definition inj_right_pair_on (P : A -> Type) (y y' : P x) 55 | (H : existT P x y = existT P x y') : y = y' 56 | := let H0 : proj P (existT P x y) y = proj P (existT P x y') y 57 | := f_equal (fun px => proj P px y) H in 58 | match A_dec x as d 59 | return 60 | match d with inl xeqx => eq_rect x P y x (eq_sym xeqx) | inr _ => y end = 61 | match d with inl xeqx => eq_rect x P y' x (eq_sym xeqx) | inr _ => y end 62 | -> y = y' 63 | with 64 | | inl xeqx => K_dec_on 65 | (fun xeqx => eq_rect x P y x xeqx = eq_rect x P y' x xeqx -> y = y') 66 | (fun H0 => H0) (eq_sym xeqx) 67 | | inr xneqx => False_ind _ (xneqx eq_refl) 68 | end H0. 69 | End Eqdep_dec. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # IWTypes 2 | A Coq development of the theory of Indexed W types with function extensionality. 3 | 4 | ## Setting 5 | We define Indexed W types as a generalization of W types, where we define an inductive family of types. 6 | They are very similar to dependent W types and indexed containers. 7 | The type former is `IW A B I C D : I -> Type`, with `A I : Type`, `B : A -> Type`, `C : A -> I`, and `D : forall x : A, B x -> I`. 8 | The interpretation is the same as `W A B`, but with `I` being the index type, and the constructor taking the form 9 | `sup : forall x : A, (forall c : B x, IW (D x c)) -> IW (C x)`. 10 | They then satisfy a dependent induction principle, which computes as expected. 11 | 12 | Here, we examine the behaviour of these types, characterize their equality, 13 | and find sufficient conditions for them to be n-types or have decidable equality. 14 | We also present a reduction to non-indexed W types. 15 | 16 | Apart from the reduction to W types, I am not aware of these results being published anywhere in the literature. 17 | 18 | ## Module index 19 | Indexed W types are defined in `IWType.v`. We also show that IW types are unique up to equivalence. 20 | 21 | `CharacterizeIWEquality.v` contains a proof that for `a b : IW A B I C D i` (abbreviated `IW i`), 22 | `a = b` is equivalent to 23 | ``` 24 | IW 25 | {x : A & (forall c : B x, IW (D x c) * (forall c : B x, IW (D x c))} 26 | (fun (x, _, _) => B x) 27 | {i : I & IW i * IW i} 28 | (fun (x, children1, children2) => (C x, sup x children1, sup x children2)) 29 | (fun (x, children1, children2) (c : B x) => (D x c, children1 c, children2 c)) 30 | (i, a, b) 31 | ``` 32 | 33 | In `FiberEquiv.v`, we show that for a b : IW i, 34 | `{(x, children1, children2) & (C x, sup x children1, sup x children2) = (i, a, b)}` is equivalent to 35 | `data_part a = data_part b :> {x & C x = i}`, 36 | that is, the fibers of C for equality as above are equivalent to equality in a fiber of `C`. 37 | 38 | In `FiberProperties.v`, we show that if the fibers of `C` are mere propositions, then `IW A B I C D i` is a mere proposition for all `i`, 39 | and that if the fibers of `C` have decidable equality, then `IW A B I C D i` has decidable equality for all i. 40 | 41 | Combined with the results in `CharacterizeIWEquality.v` and `FiberEquiv.v`, 42 | this implies that all positive h-levels are inherited from the fibers of C by induction. 43 | If you represent usual W types by setting `I=1`, then this matches the result by Danielsson: 44 | https://homotopytypetheory.org/2012/09/21/positive-h-levels-are-closed-under-w/ 45 | 46 | Finally, in a different vein, we show that IW types can be reduced to W types by typechecking `W A B` in `ReductIWtoW.v`. 47 | This is a known result, which I found in 48 | Indexed Containers by Thorsten Altenkirch and Peter Morris 49 | http://www.cs.nott.ac.uk/~psztxa/publ/ICont.pdf 50 | 51 | Modules `Adjointification.v`, `FunctionExtensionality.v`, `SigmaEta.v`, `Eqdep_dec.v` contain nothing new. 52 | They contain standard lemmas used in the main proofs. 53 | -------------------------------------------------------------------------------- /Adjointification.v: -------------------------------------------------------------------------------- 1 | (* Turn a pair of inverses into an adjoint equivalence *) 2 | (* Proof follows the HoTT book *) 3 | (* Mostly, just a lot of manipulation of equality proofs *) 4 | 5 | Module Import lemmas. 6 | 7 | (* Lemma 2.4.3 in HoTT book, specialized to g = id *) 8 | Definition commute_homotopy_id {A} {f : A -> A} 9 | (H : forall a, f a = a) {x y : A} (p : x = y) 10 | : eq_trans (H x) p = eq_trans (f_equal f p) (H y) 11 | := match p in (_ = y) 12 | return eq_trans (H x) p = eq_trans (f_equal f p) (H y) 13 | with eq_refl => eq_sym (eq_trans_refl_l (H x)) end. 14 | 15 | End lemmas. 16 | 17 | Section adjointify. 18 | Context {A B} (f : A -> B) (g : B -> A). 19 | 20 | Section g_adjoint. 21 | Context 22 | (gf_id : forall a, g (f a) = a) 23 | (fg_id : forall b, f (g b) = b). 24 | 25 | Definition f_adjoint_gives_g_adjoint_pointwise 26 | (b : B) (f_adjoint_at_gb : fg_id (f (g b)) = f_equal f (gf_id (g b))) 27 | : gf_id (g b) = f_equal g (fg_id b) 28 | := let precomposed_eq 29 | : eq_trans (f_equal (fun a => g (f a)) (f_equal g (fg_id b))) 30 | (gf_id (g b)) = 31 | eq_trans (f_equal g (f_equal (fun b => f (g b)) (fg_id b))) 32 | (f_equal g (fg_id b)) 33 | := eq_trans 34 | (eq_sym (commute_homotopy_id gf_id (f_equal g (fg_id b)))) 35 | (eq_rect (f_equal g (fg_id (f (g b)))) (fun p => eq_trans p _ = _) 36 | (eq_trans (eq_trans 37 | (eq_sym (eq_trans_map_distr g _ _)) 38 | (f_equal (fun p => f_equal g p) 39 | (commute_homotopy_id fg_id (fg_id b)))) 40 | (eq_trans_map_distr g _ _)) _ 41 | (eq_trans (eq_trans 42 | (f_equal (fun p => f_equal g p) f_adjoint_at_gb) 43 | (f_equal_compose f g _)) 44 | (eq_id_comm_r _ gf_id (g b)))) in 45 | match fg_id b as p 46 | return 47 | forall p1 p2, 48 | eq_trans (f_equal _ (f_equal g p)) p1 = 49 | eq_trans (f_equal g (f_equal _ p)) p2 -> 50 | p1 = p2 51 | with eq_refl => fun p1 p2 eq => 52 | eq_trans (eq_trans 53 | (eq_sym (eq_trans_refl_l _)) 54 | eq) 55 | (eq_trans_refl_l _) 56 | end (gf_id (g b)) (f_equal g (fg_id b)) precomposed_eq. 57 | 58 | Definition f_adjoint_gives_g_adjoint 59 | (f_adjoint : forall a, fg_id (f a) = f_equal f (gf_id a)) 60 | (b : B) : gf_id (g b) = f_equal g (fg_id b) 61 | := f_adjoint_gives_g_adjoint_pointwise b (f_adjoint (g b)). 62 | End g_adjoint. 63 | 64 | Section correction. 65 | Context 66 | (gf_id : forall a, g (f a) = a) 67 | (fg_id : forall b, f (g b) = b). 68 | 69 | Definition fg_id' b : f (g b) = b 70 | := eq_trans (eq_sym (fg_id (f (g b)))) 71 | (eq_trans (f_equal f (gf_id (g b))) (fg_id b)). 72 | 73 | Definition f_adjoint a : fg_id' (f a) = f_equal f (gf_id a) 74 | := let symmetric_eq 75 | : eq_trans (f_equal f (gf_id (g (f a)))) (fg_id (f a)) = 76 | eq_trans (fg_id (f (g (f a)))) (f_equal f (gf_id a)) 77 | := eq_trans (eq_trans 78 | (f_equal (fun H => eq_trans (f_equal f H) (fg_id (f a))) 79 | (eq_sym (eq_id_comm_r _ gf_id a))) 80 | (f_equal (fun p => eq_trans p _) 81 | (eq_trans 82 | (f_equal_compose (fun a => g (f a)) f _) 83 | (eq_sym (f_equal_compose f (fun b => f (g b)) _))))) 84 | (eq_sym (commute_homotopy_id fg_id (f_equal f (gf_id a)))) in 85 | match fg_id (f (g (f a))) as p 86 | return forall p', _ = eq_trans p p' -> eq_trans (eq_sym p) _ = p' 87 | with eq_refl => fun p' eq => 88 | eq_trans (eq_trans_refl_l _) (eq_trans eq (eq_trans_refl_l _)) 89 | end _ symmetric_eq. 90 | 91 | Definition g_adjoint 92 | : forall b, gf_id (g b) = f_equal g (fg_id' b) 93 | := f_adjoint_gives_g_adjoint gf_id fg_id' f_adjoint. 94 | 95 | End correction. 96 | 97 | End adjointify. 98 | -------------------------------------------------------------------------------- /ReduceIWtoW.v: -------------------------------------------------------------------------------- 1 | (* 2 | We present a reduction from Indexed W types to W types. 3 | The main idea is to take a W type that forgets all the index information, 4 | and then recursively define well_formed m i predicate which witnesses 5 | that m has index i. 6 | We then show that the sigma type combining the two satisfies the expected 7 | induction principle, and so is equivalent to any other implementation. 8 | 9 | I found this construction (typecheck unindexed trees) in 10 | Indexed Containers by Thorsten Altenkirch and Peter Morris 11 | http://www.cs.nott.ac.uk/~psztxa/publ/ICont.pdf, 12 | which references 13 | * M. Abbott, T. Altenkirch, and N. Ghani. Containers - constructing 14 | strictly positive types. Theoretical Computer Science, 15 | 342:327, September 2005. Applied Semantics: Selected Topics. 16 | * N. Gambino and M. Hyland. Wellfounded trees and dependent 17 | polynomial functors. In S. Berardi, M. Coppo, and 18 | F. Damiani, editors, types for Proofs and Programs (TYPES 2003), 19 | Lecture Notes in Computer Science, 2004 20 | as previous examples of the technique. 21 | *) 22 | 23 | From IWTypes Require Import IWType. 24 | From IWTypes Require Import FunctionExtensionality. 25 | From IWTypes Require SigmaEta. 26 | 27 | (* 28 | Define the W type inductively. 29 | As with IW types, we have uniqueness, so WLOG we use this one, 30 | which has nice judgemental equalities. 31 | *) 32 | Inductive W (Data : Type) (Children : Data -> Type) := 33 | sup : forall x : Data, (Children x -> W Data Children) -> W Data Children. 34 | Arguments sup {Data Children} x children. 35 | 36 | Section IW_to_W. 37 | Context {FunExt : FunExt}. 38 | 39 | (* We want to build a type that satisfies this spec. *) 40 | Context (S : spec). 41 | 42 | (* This is our approximation to S that forgets index information. *) 43 | Definition tree := W (Data S) (@Children S). 44 | 45 | (* We define, recursively, a well_formed predicate that represents a proof 46 | that m has index i. *) 47 | Fixpoint well_formed (i : Index S) (m : tree) : Type 48 | := match m with 49 | | sup x children => 50 | (index x = i) * 51 | (forall c, well_formed (child_index x c) (children c)) 52 | end. 53 | 54 | (* Define our implementation of S *) 55 | Definition carrier' i := sigT (well_formed i). 56 | Definition sup' (x : Data S) (children : forall c, carrier' (child_index x c)) 57 | : carrier' (index x) 58 | := existT (well_formed (index x)) 59 | (sup x (fun c => projT1 (children c))) 60 | (eq_refl, fun c => projT2 (children c)). 61 | 62 | (* Define the induction principle and show it computes. *) 63 | Section induct'. 64 | Context 65 | (P : forall i, carrier' i -> Type) 66 | (IS : forall x children, (forall c, P _ (children c)) -> 67 | P _ (sup' x children)). 68 | 69 | (* The induction is structural on the unindexed W type. *) 70 | Fixpoint induct'_pre i m 71 | : forall (m_ix_i : well_formed i m), P i (existT _ m m_ix_i) 72 | := match m with 73 | | sup x children => fun '(p, IH) => match p in (_ = i) 74 | return P i (existT _ (sup x children) (p, IH)) 75 | with eq_refl => IS x 76 | (fun c => existT _ (children c) (IH c)) 77 | (fun c => induct'_pre _ (children c) (IH c)) 78 | end 79 | end. 80 | 81 | (* 82 | Note that because of the match on m, we lose one level of judgemental equality. 83 | If we were working in a type theory with 84 | - W types with judgemental dependent eliminators AND 85 | - Sigma type with judgemental eta 86 | Then it appears that we can build Indexed W types 87 | with judgemental dependent eliminators 88 | *) 89 | Definition induct' : forall i m, P i m 90 | := fun i '(existT _ m m_ix_i) => induct'_pre i m m_ix_i. 91 | 92 | (* 93 | We need function extensionality to compensate for the lack of 94 | judgemental eta for sigma. 95 | *) 96 | Definition induct_computes' x children 97 | : induct' _ (sup' x children) = 98 | IS x children (fun c => induct' _ (children c)) 99 | := SigmaEta.sigma_eta_family_funext _ 100 | (fun p1 p2 => 101 | P _ (existT _ (sup x p1) (eq_refl, p2))) 102 | (fun children => IS x children (fun c => induct' _ (children c))) 103 | children. 104 | End induct'. 105 | 106 | (* 107 | Thus we have constructed an implementation of the Indexed W type S 108 | from the non-indexed W type tree. 109 | *) 110 | Definition I' : impl S 111 | := Build_impl S carrier' sup' induct' induct_computes'. 112 | 113 | End IW_to_W. -------------------------------------------------------------------------------- /IWType.v: -------------------------------------------------------------------------------- 1 | (* 2 | We define an Indexed W type by five pieces of data. 3 | First, we have two pieces that are the same as regular W types: 4 | Data : Type 5 | The type of data carried by each node, traditionally A 6 | Children : Data -> Type 7 | The children of a node with data x are named by (Children x). 8 | Traditionally B. 9 | Then we specify the indices: 10 | Index : Type 11 | The type of indices 12 | index : Data -> Index 13 | A node with data x has is labeled (index x) 14 | child_index : forall x : Data, Children x -> Index 15 | Child c : Children x is labeled (child_index x c) 16 | 17 | The Indexed W type is a type family carrier : Index -> Type, 18 | along with a constructor 19 | sup : forall x : Data, (forall c : Children x, carrier (child_index x c)) -> 20 | carrier (index x) 21 | We then require sup to satisfy an appropriate dependent induction principle. 22 | 23 | Note that regular W types are a subset of Indexed W types, obtained by 24 | setting Index = unit. 25 | *) 26 | 27 | From IWTypes Require Import FunctionExtensionality. 28 | 29 | Record spec := { 30 | Data : Type; 31 | Children : Data -> Type; 32 | Index : Type; 33 | index : Data -> Index; 34 | child_index : forall x, Children x -> Index; 35 | }. 36 | Arguments Data S : rename. 37 | Arguments Children {S} x : rename. 38 | Arguments Index S : rename. 39 | Arguments index {S} x : rename. 40 | Arguments child_index {S} x c : rename. 41 | 42 | Record impl {S : spec} := { 43 | carrier : Index S -> Type; 44 | sup : 45 | forall x : Data S, 46 | (forall (c : Children x), carrier (child_index x c)) -> 47 | carrier (index x); 48 | induct : 49 | forall (P : forall i, carrier i -> Type), 50 | (forall x children, (forall c, P _ (children c)) -> 51 | P _ (sup x children)) -> 52 | forall i m, P i m; 53 | induct_computes : 54 | forall P IS, 55 | forall x children, 56 | induct P IS _ (sup x children) = 57 | IS x children (fun c => induct P IS _ (children c)); 58 | }. 59 | Arguments impl S : clear implicits. 60 | 61 | Module unique. 62 | Section unique. 63 | (* We prove that the implementation of a spec is unique up to equivalence. *) 64 | 65 | Context {FunExt : FunExt}. 66 | Context {S} {I1 I2 : impl S}. 67 | 68 | Definition I1_to_I2 : forall i, carrier I1 i -> carrier I2 i 69 | := induct I1 70 | (fun i _ => carrier I2 i) 71 | (fun x children IH => sup I2 x IH). 72 | 73 | Definition I2_to_I1 : forall i, carrier I2 i -> carrier I1 i 74 | := induct I2 75 | (fun i _ => carrier I1 i) 76 | (fun x children IH => sup I1 x IH). 77 | 78 | Definition I1_to_I2_sup 79 | : forall x children, 80 | I1_to_I2 _ (sup I1 x children) = 81 | sup I2 x (fun c => I1_to_I2 _ (children c)) 82 | := induct_computes I1 _ _. 83 | 84 | Definition I2_to_I1_sup 85 | : forall x children, 86 | I2_to_I1 _ (sup I2 x children) = 87 | sup I1 x (fun c => I2_to_I1 _ (children c)) 88 | := induct_computes I2 _ _. 89 | 90 | Definition I1_to_I2_to_I1_id 91 | : forall i m, I2_to_I1 i (I1_to_I2 i m) = m 92 | := induct I1 93 | (fun i m => I2_to_I1 i (I1_to_I2 i m) = m) 94 | (fun x children IH => eq_trans (eq_trans 95 | (f_equal (I2_to_I1 _) (I1_to_I2_sup _ _)) 96 | (I2_to_I1_sup _ _)) 97 | (f_equal (sup I1 x) (funext IH))). 98 | 99 | (* The reverse holds by symmetry, so the two implementations are equivalent. *) 100 | 101 | End unique. 102 | End unique. 103 | 104 | Module concrete. 105 | Section concrete. 106 | (* We prove that every spec has an implementation. *) 107 | 108 | Context (S : spec). 109 | 110 | Inductive IW : Index S -> Type 111 | := IWsup : 112 | forall (x : Data S) (children : forall c, IW (child_index x c)), 113 | IW (index x). 114 | 115 | Definition IWinduct 116 | (P : forall i, IW i -> Type) 117 | (IS : 118 | forall x children, (forall c, P _ (children c)) -> 119 | P _ (IWsup x children)) 120 | : forall i m, P i m 121 | := fix induct i (m : IW i) : P i m := match m with 122 | | IWsup x children => IS x children (fun c => induct _ (children c)) 123 | end. 124 | Definition IWcomputes P IS x children 125 | : IWinduct P IS _ (IWsup x children) = 126 | IS x children (fun c => IWinduct P IS _ (children c)) 127 | := eq_refl. 128 | Definition IWsat : impl S 129 | := Build_impl S IW IWsup IWinduct IWcomputes. 130 | 131 | (* 132 | With the above module unique, 133 | this shows that every spec has a unique implementation. 134 | With univalence, you probably have that impl S is contractable. 135 | *) 136 | 137 | End concrete. 138 | Arguments IWsup {S} x children. 139 | End concrete. 140 | -------------------------------------------------------------------------------- /CharacterizeIWEquality.v: -------------------------------------------------------------------------------- 1 | (* 2 | We present a characterization of the equality in an Indexed W type 3 | as an Indexed W type of the same shape. 4 | (assuming function extensionality) 5 | 6 | That is, a path between (sup x children1) and (sup y children2) is 7 | a path p between x and y, 8 | and a path between each pair of children, lying over p. 9 | 10 | I am not aware of this result in any of the literature, 11 | but I believe it is an interesting result. 12 | In particular, I was surprised not to find it in the HoTT book. 13 | *) 14 | 15 | From IWTypes Require Import IWType. 16 | From IWTypes Require Import FunctionExtensionality. 17 | 18 | (* We aren't working with nat, and we want to use the * notation for pairs. *) 19 | Close Scope nat_scope. 20 | 21 | Section IWEquality. 22 | Context {FunExt : FunExt}. 23 | Context {S : spec}. 24 | 25 | (* Postulate an implementation I of S *) 26 | Context (I : impl S). 27 | 28 | (* Define the type of children of a node labeled by x *) 29 | Definition children_for (x : Data S) := forall c, carrier I (child_index x c). 30 | 31 | (* We claim that equality in T satisfies the following spec: *) 32 | Definition Seq : spec := {| 33 | Data := {x : Data S & children_for x * children_for x}; 34 | Children := fun '(existT _ x _) => Children x; 35 | Index := {i : Index S & carrier I i * carrier I i}; 36 | index := fun '(existT _ x (children1, children2)) => 37 | existT _ (index x) (sup I x children1, sup I x children2); 38 | child_index := fun '(existT _ x (children1, children2)) c => 39 | existT _ _ (children1 c, children2 c); 40 | |}. 41 | 42 | (* This is the type family we claim satisfies the above spec *) 43 | Definition eq_type : Index Seq -> Type 44 | := fun '(existT _ i (a, b)) => a = b. 45 | (* Introduction rule, easy by funext *) 46 | Definition eq_sup 47 | : forall dat : Data Seq, (forall c, eq_type (child_index dat c)) -> 48 | eq_type (index dat) 49 | := fun '(existT _ x (children1, children2)) children_eq => 50 | f_equal (sup I x) (funext children_eq). 51 | 52 | (* Now we prove that we have the induction rule, and that it computes. *) 53 | Section induct. 54 | Context 55 | (P : forall iab, eq_type iab -> Type) 56 | (IS : forall dat children_eq, (forall c, P _ (children_eq c)) -> 57 | P (index dat) (eq_sup dat children_eq)). 58 | 59 | (* First we show that P holds for reflexivity *) 60 | Definition eq_induct_refl : forall i a, P (existT _ i (a, a)) eq_refl 61 | := induct I (fun i a => P (existT _ i (a, a)) eq_refl) 62 | (fun x children refl_children_P => eq_rect 63 | (funext (happly eq_refl)) 64 | (fun p' => 65 | P (existT _ (index x) (sup I x children, sup I x children)) 66 | (f_equal (sup I x) p')) 67 | (IS (existT _ x (children, children)) (happly eq_refl) 68 | refl_children_P) 69 | eq_refl 70 | (funext_comp eq_refl)). 71 | 72 | (* Then we use path induction to generalize. *) 73 | Definition eq_induct 74 | : forall iab p, P iab p 75 | := fun '(existT _ i (a, b)) (p : a = b) => match p in (_ = b) 76 | return P (existT _ i (a, b)) p with eq_refl => eq_induct_refl i a end. 77 | 78 | (* Finally, we show that the induction above computes as expected. *) 79 | 80 | (* First eq_induct_refl: *) 81 | Definition eq_induct_refl_computes 82 | x children1 83 | : eq_induct_refl (index x) (sup I x children1) = 84 | eq_rect (funext (fun c => eq_refl)) _ 85 | (IS (existT _ x (children1, children1)) (happly eq_refl) 86 | (fun c => eq_induct_refl _ (children1 c))) 87 | eq_refl (funext_comp eq_refl) 88 | := induct_computes I _ _ _ _. 89 | 90 | (* Then in general *) 91 | Definition eq_induct_computes 92 | : forall dat children_eq, 93 | eq_induct (index dat) (eq_sup dat children_eq) = 94 | IS dat children_eq (fun c => eq_induct _ (children_eq c)) 95 | := fun '(existT _ x (children1, children2)) => 96 | fun children_eq : forall c, children1 c = children2 c => 97 | eq_trans (eq_trans 98 | (match funext children_eq 99 | as p' in (_ = children2) 100 | return 101 | match f_equal (sup I x) p' as p'' in (_ = b) 102 | return P (existT _ (index x) (sup I x children1, b)) p'' 103 | with eq_refl => eq_induct_refl (index x) (sup I x children1) end 104 | = 105 | eq_rect (funext (happly p')) 106 | (fun p'' => P (existT _ _ (_, _)) (f_equal (sup I x) p'')) 107 | (IS (existT _ x (children1, children2)) (happly p') 108 | (fun c => eq_induct (existT _ _ (_, _)) (happly p' c))) 109 | p' (funext_comp p') 110 | with eq_refl => eq_induct_refl_computes x children1 111 | end) 112 | (f_equal (eq_rect _ _ _ _) (funext_adjoint children_eq))) 113 | (match funext_app children_eq as children_p in (_ = children_eq') 114 | return 115 | eq_rect _ _ _ _ (f_equal funext children_p) = 116 | IS (existT _ x (children1, children2)) children_eq' 117 | (fun c => eq_induct (existT _ _ (_, _)) (children_eq' c)) 118 | with eq_refl => eq_refl end). 119 | End induct. 120 | 121 | (* Thus the equality is an inductive family: *) 122 | Definition Ieq : impl Seq 123 | := Build_impl Seq eq_type eq_sup eq_induct eq_induct_computes. 124 | 125 | End IWEquality. 126 | Arguments eq_sup {FunExt S I} dat children. 127 | -------------------------------------------------------------------------------- /FiberProperties.v: -------------------------------------------------------------------------------- 1 | (* 2 | For some properties, if they hold for all the fibers of the index map, 3 | then they hold for the Indexed W type. 4 | We assume function extensionality throughout. 5 | 6 | We work with the concrete inductive implementation IW, since 7 | it has nice judgemental equalities. Since all implementations are equivalent, 8 | the results hold for any implementation. 9 | 10 | We show below that being a subsingleton / mere proposition is such a property. 11 | 12 | We also show below that, assuming we can lift decisions over the children 13 | (if the children are finitely enumerable, this is possible) 14 | that decidability of equality is another such property. 15 | 16 | Since we showed that the fibers of the index map of the equality family are 17 | equivalent to equality in a fiber of the index map, we have by recursion 18 | that all positive h-levels are also inherited. 19 | 20 | In the case of non-indexed W types, the Index type is unit, so the unique 21 | fiber is equivalent to the Data set, and this result coincides with 22 | the result by Danielsson: 23 | https://homotopytypetheory.org/2012/09/21/positive-h-levels-are-closed-under-w/ 24 | *) 25 | 26 | From IWTypes Require Import IWType. 27 | From IWTypes Require Import FunctionExtensionality. 28 | From IWTypes Require Eqdep_dec. 29 | Import IWType.concrete. 30 | 31 | (* We aren't working with nat, and we want to use the + notation for types. *) 32 | Close Scope nat_scope. 33 | 34 | Definition fib {A B} (f : A -> B) (b : B) := {a : A & f a = b}. 35 | 36 | Definition isProp A := forall x y : A, x = y. 37 | 38 | Definition isProp_inherited {FunExt : FunExt} (S : spec) 39 | (fibers_prop : forall i, isProp (fib (@index S) i)) 40 | : forall i, isProp (IW S i) 41 | := fix isProp i a : forall b, a = b := match a with 42 | | IWsup x children1 => fun (b : IW S (index x)) => 43 | let children_contract children2 : children1 = children2 44 | := funext (fun c => isProp _ (children1 c) (children2 c)) in 45 | match b in (IW _ i) 46 | return 47 | forall iy : i = index x, 48 | IWsup x children1 = 49 | eq_rect i (IW S) b (index x) iy 50 | with IWsup y children2 => fun iy : index y = index x => 51 | match fibers_prop (index x) (existT _ x eq_refl) (existT _ y iy) 52 | in (_ = existT _ y iy) 53 | return 54 | forall children2, 55 | IWsup x children1 = 56 | eq_rect (index y) _ (IWsup y children2) (index x) iy 57 | with eq_refl => fun children2 => 58 | f_equal (IWsup x) (children_contract children2) 59 | end children2 60 | end eq_refl 61 | end. 62 | 63 | Definition decidable (A : Type) := A + (A -> False). 64 | Definition decidable_eq (A : Type) := forall x y : A, decidable (x = y). 65 | 66 | (* If Children x is finitely enumerable, we have liftP. *) 67 | Definition decidable_eq_inherited {FunExt : FunExt} (S : spec) 68 | (liftP : forall (x : Data S) (P : Children x -> Type), 69 | (forall c, decidable (P c)) -> decidable (forall c, P c)) 70 | (fibers_dec : forall i, decidable_eq (fib (@index S) i)) 71 | : forall i, decidable_eq (IW S i) 72 | := let children_for (x : Data S) := forall c, IW S (child_index x c) in 73 | let getfib {i} (a : IW S i) : fib (@index S) i 74 | := match a with IWsup x _ => existT _ x eq_refl end in 75 | let getfib_computes x y children p 76 | : getfib (eq_rect (index y) (IW S) (IWsup y children) (index x) p) = 77 | existT _ y p 78 | := match p 79 | return getfib (eq_rect _ _ (IWsup y children) _ p) = existT _ y p 80 | with eq_refl => eq_refl end in 81 | let getfib_plus {i} (a : IW S i) 82 | : {f : fib (@index S) i & children_for (projT1 f)} 83 | := match a with IWsup x children => 84 | existT _ (existT _ x eq_refl) children end in 85 | let children_eq (x : Data S) children1 children2 86 | : IWsup x children1 = IWsup x children2 -> children1 = children2 87 | := fun aeqb => Eqdep_dec.inj_right_pair_on 88 | _ (fibers_dec _ (existT _ x eq_refl)) 89 | (fun f => children_for (projT1 f)) 90 | _ _ (f_equal getfib_plus aeqb) in 91 | fix decide_eq i a : forall b, decidable (a = b) := match a with 92 | | IWsup x children1 => fun (b : IW S (index x)) => 93 | let decide_children children2 : decidable (children1 = children2) 94 | := match liftP x (fun c => children1 c = children2 c) 95 | (fun c => decide_eq _ (children1 c) (children2 c)) 96 | with 97 | | inl agree => inl (funext agree) 98 | | inr disagree => inr (fun agree => disagree (happly agree)) 99 | end in 100 | match b in (IW _ i) 101 | return 102 | forall iy : i = index x, 103 | decidable ( 104 | IWsup x children1 = 105 | eq_rect i (IW S) b (index x) iy 106 | ) 107 | with IWsup y children2 => fun iy : index y = index x => 108 | match fibers_dec (index x) (existT _ x eq_refl) (existT _ y iy) 109 | with 110 | | inl fiber_eq => match fiber_eq in (_ = existT _ y iy) 111 | return 112 | forall children2, 113 | decidable ( 114 | IWsup x children1 = 115 | eq_rect (index y) (IW S) (IWsup y children2) (index x) iy 116 | ) 117 | with eq_refl => fun children2 => 118 | match decide_children children2 with 119 | | inl children_eq => inl (f_equal (IWsup x) children_eq) 120 | | inr children_neq => inr (fun aeqb => children_neq 121 | (children_eq x children1 children2 aeqb)) 122 | end 123 | end children2 124 | | inr fiber_neq => inr 125 | (fun aeqb 126 | : IWsup x children1 = eq_rect _ _ (IWsup y children2) _ iy => 127 | fiber_neq (eq_trans 128 | (f_equal getfib aeqb) 129 | (getfib_computes x y children2 iy))) 130 | end 131 | end eq_refl 132 | end. 133 | 134 | 135 | -------------------------------------------------------------------------------- /FiberEquiv.v: -------------------------------------------------------------------------------- 1 | (* 2 | Furthermore, we prove that each fiber of the new index map is equivalent 3 | to the equality in a fiber of the original index map. 4 | 5 | Specifically, with a and b having index i, 6 | the fiber of a = b is equivalent to the path space ax = bx in the fiber of i. 7 | *) 8 | 9 | From IWTypes Require Import IWType. 10 | From IWTypes Require Import CharacterizeIWEquality. 11 | 12 | Definition fib {A B} (f : A -> B) (b : B) := {a : A & f a = b}. 13 | 14 | Module Import inner. 15 | Section inner. 16 | Context {S : spec} (I : impl S). 17 | 18 | (* 19 | Since we are working with an arbitrary implementation, we don't have 20 | judgemental matching. The below destruct_type gives some of that back. 21 | *) 22 | Definition deconstruct_type i (a : carrier I i) 23 | := {a' : {x : Data S & children_for I x * (index x = i)} & 24 | eq_rect _ _ (sup I _ (fst (projT2 a'))) i (snd (projT2 a')) = a}. 25 | Definition deconstruct 26 | : forall i a, deconstruct_type i a 27 | := induct I deconstruct_type 28 | (fun x children _ => existT _ (existT _ x (children, eq_refl)) eq_refl). 29 | Definition deconstruct_computes 30 | : forall x children, 31 | deconstruct _ (sup I x children) = 32 | existT _ (existT _ x (children, eq_refl)) eq_refl 33 | := induct_computes I _ _. 34 | Definition deconstruct_contract 35 | : forall i a (d : deconstruct_type i a), 36 | deconstruct i a = d 37 | := fun i a '(existT _ (existT _ x' (children', px)) p) => 38 | match p with eq_refl => match px with eq_refl => 39 | deconstruct_computes x' children' 40 | end end. 41 | (* 42 | To prove something for all destructions of (sup I x children), it is enough 43 | to prove it for (x, children) with reflexive paths. 44 | This is basically the judgemental computation rule. 45 | *) 46 | Definition deconstruct_type_rect x children 47 | (P : deconstruct_type (index x) (sup I x children) -> Type) 48 | (IS : P (existT _ (existT _ x (children, eq_refl)) eq_refl)) 49 | : forall d, P d 50 | := fun d => eq_rect _ P IS d (eq_trans 51 | (eq_sym (deconstruct_computes x children)) 52 | (deconstruct_contract _ _ d)). 53 | Definition deconstruct_type_rect_computes x children P IS 54 | : deconstruct_type_rect x children P IS 55 | (existT _ (existT _ x (children, eq_refl)) eq_refl) = 56 | IS 57 | := f_equal _ (eq_trans_sym_inv_l (deconstruct_computes x children)). 58 | 59 | (* Take a node with index i and make an element of the fiber of i. *) 60 | Definition data_from_deconstruct i a 61 | : deconstruct_type i a -> fib (@index S) i 62 | := fun '(existT _ (existT _ x (_, p)) _) => existT _ x p. 63 | 64 | (* Define the forward and reverse functions, and prove they are inverses. *) 65 | Definition fib_to_eq_rect 66 | (P : forall i a b, deconstruct_type i a -> deconstruct_type i b -> 67 | fib (@index (Seq I)) (existT _ i (a, b)) -> Type) 68 | (IS : forall x children1 children2, 69 | P (index x) (sup I x children1) (sup I x children2) 70 | (existT _ (existT _ x (children1, eq_refl)) eq_refl) 71 | (existT _ (existT _ x (children2, eq_refl)) eq_refl) 72 | (existT _ (existT _ x (children1, children2)) eq_refl)) 73 | : forall i a b da db fx, P i a b da db fx 74 | := fun i a b da db '(existT _ dat index_eq) => 75 | match dat 76 | return forall index_eq da db, P i a b da db (existT _ dat index_eq) 77 | with existT _ x (children1, children2) => fun index_eq => 78 | match index_eq in (_ = existT _ i (a, b)) 79 | return 80 | forall da db, 81 | P i a b da db (existT _ (existT _ x (children1, children2)) index_eq) 82 | with eq_refl => 83 | (deconstruct_type_rect x children1 _ 84 | (deconstruct_type_rect x children2 _ 85 | (IS x children1 children2))) 86 | end 87 | end index_eq da db. 88 | Definition fib_to_eq_rect_computes P IS x children1 children2 89 | (da := existT _ (existT _ x (children1, eq_refl)) eq_refl 90 | : deconstruct_type _ (sup I x children1)) 91 | (db := existT _ (existT _ x (children2, eq_refl)) eq_refl) 92 | (fx := existT _ (existT _ x (children1, children2)) eq_refl) 93 | : fib_to_eq_rect P IS _ (sup I x children1) (sup I x children2) da db fx = 94 | IS x children1 children2 95 | := eq_trans (x:=fib_to_eq_rect P IS _ _ _ da db fx) 96 | (f_equal (fun f => f db) 97 | (deconstruct_type_rect_computes x children1 _ _)) 98 | (deconstruct_type_rect_computes x children2 _ _). 99 | Definition fib_to_eq_parametrized 100 | : forall i (a b : carrier I i) da db, 101 | fib (@index (Seq I)) (existT _ i (a, b)) -> 102 | data_from_deconstruct i a da = data_from_deconstruct i b db 103 | :> fib (@index S) i 104 | := fib_to_eq_rect _ (fun x children1 children2 => eq_refl). 105 | 106 | Definition eq_to_fib_rect 107 | (P : forall i a b da db, 108 | data_from_deconstruct i a da = data_from_deconstruct i b db -> Type) 109 | (IS : forall x children1 children2, 110 | P (index x) (sup I x children1) (sup I x children2) 111 | (existT _ (existT _ x (children1, eq_refl)) eq_refl) 112 | (existT _ (existT _ x (children2, eq_refl)) eq_refl) 113 | eq_refl) 114 | : forall i a b da db data_eq, P i a b da db data_eq 115 | := fun i a b da db => 116 | match da, db with 117 | existT _ (existT _ x (children1, px)) pa, 118 | existT _ (existT _ y (children2, py)) pb => 119 | match pa, pb with eq_refl, eq_refl => 120 | fun data_eq : existT _ x px = existT _ y py => 121 | match data_eq in (_ = existT _ y py) 122 | return 123 | forall children2, 124 | let da := existT _ (existT _ x (children1, px)) eq_refl in 125 | let db := existT _ (existT _ y (children2, py)) eq_refl in 126 | P _ _ _ da db data_eq 127 | with eq_refl => fun children2 => 128 | match px in (_ = i) 129 | return 130 | let da := existT _ (existT _ x (children1, px)) eq_refl in 131 | let db := existT _ (existT _ x (children2, px)) eq_refl in 132 | P _ _ _ da db eq_refl 133 | with eq_refl => IS x children1 children2 134 | end end children2 end end. 135 | Definition eq_to_fib_parametrized 136 | : forall i a b da db, 137 | data_from_deconstruct i a da = data_from_deconstruct i b db -> 138 | fib (@index (Seq I)) (existT _ i (a, b)) 139 | := eq_to_fib_rect 140 | (fun i a b _ _ _ => fib (@index (Seq I)) (existT _ i (a, b))) 141 | (fun x children1 children2 => 142 | existT _ (existT _ x (children1, children2)) eq_refl). 143 | 144 | Definition eq_to_fib_to_eq_id_parametrized 145 | : forall i a b da db data_eq, 146 | fib_to_eq_parametrized i a b da db 147 | (eq_to_fib_parametrized i a b da db data_eq) = 148 | data_eq 149 | := eq_to_fib_rect _ 150 | (fun x children1 children2 => 151 | fib_to_eq_rect_computes _ _ x children1 children2). 152 | 153 | Definition fib_to_eq_to_fib_id_parametrized 154 | : forall i a b da db fx, 155 | eq_to_fib_parametrized i a b da db 156 | (fib_to_eq_parametrized i a b da db fx) = 157 | fx 158 | := fib_to_eq_rect _ 159 | (fun x children1 children2 => 160 | (f_equal (eq_to_fib_parametrized _ _ _ _ _) 161 | (fib_to_eq_rect_computes _ _ x children1 children2))). 162 | End inner. 163 | End inner. 164 | 165 | (* By specializing the above, we get the desired inverses. *) 166 | Section fibers. 167 | Context {S : spec} (I : impl S). 168 | 169 | Definition data_part : forall i, carrier I i -> fib (@index S) i 170 | := fun i a => data_from_deconstruct I i a (deconstruct I i a). 171 | 172 | Definition fib_to_eq i (a b : carrier I i) 173 | : fib (@index (Seq I)) (existT _ i (a, b)) -> 174 | data_part i a = data_part i b :> fib (@index S) i 175 | := fib_to_eq_parametrized I i a b _ _. 176 | 177 | Definition eq_to_fib i (a b : carrier I i) 178 | : data_part i a = data_part i b :> fib (@index S) i -> 179 | fib (@index (Seq I)) (existT _ i (a, b)) 180 | := eq_to_fib_parametrized I i a b _ _. 181 | 182 | Definition fib_to_eq_to_fib_id i a b 183 | : forall fx, eq_to_fib i a b (fib_to_eq i a b fx) = fx 184 | := fib_to_eq_to_fib_id_parametrized I i a b _ _. 185 | 186 | Definition eq_to_fib_to_eq_id i a b 187 | : forall data_eq, fib_to_eq i a b (eq_to_fib i a b data_eq) = data_eq 188 | := eq_to_fib_to_eq_id_parametrized I i a b _ _. 189 | End fibers. 190 | --------------------------------------------------------------------------------