Library SMTLIB.Theory: Structures & Theories
From Equations Require Import Equations.
From SMTLIB Require Import Signature Symbols Utils.
Open Scope smt_scope.
Interpretations and Heterogeneous Lists
Section Interpretation.
Variable (domain : sort → Type).
Fixpoint interpretation (σs : list sort) (σ : sort) : Type :=
match σs with
| [] ⇒ domain σ
| σ' :: σs' ⇒ domain σ' → interpretation σs' σ
end.
Inductive hlist : list sort → Type :=
| HNil : hlist []
| HCons : ∀ σ σs, domain σ → hlist σs → hlist (σ :: σs).
Case analysis on an hlist whose index is a known list shape.
dependent destruction reaches these too, but by a route that needs
eq_rect_eq; a dependent match on the index does not.
Lemma hlist_nil_eq : ∀ (vs : hlist []), vs = HNil.
Proof.
intros vs.
refine (match vs as vs0 in hlist l
return match l return hlist l → Prop with
| [] ⇒ fun vs1 ⇒ vs1 = HNil
| _ :: _ ⇒ fun _ ⇒ True
end vs0
with
| HNil ⇒ eq_refl
| HCons _ _ _ _ ⇒ I
end).
Qed.
Lemma hlist_cons_eq : ∀ σ σs (vs : hlist (σ :: σs)),
∃ v vs', vs = HCons σ σs v vs'.
Proof.
intros σ σs vs.
refine (match vs as vs0 in hlist l
return match l return hlist l → Prop with
| [] ⇒ fun _ ⇒ True
| σ0 :: σs0 ⇒
fun vs1 ⇒ ∃ v vs', vs1 = HCons σ0 σs0 v vs'
end vs0
with
| HNil ⇒ I
| HCons σ0 σs0 v vs' ⇒ _
end).
now ∃ v, vs'.
Qed.
Equations interp_apply {σs σ}
(F : interpretation σs σ)
(vs : hlist σs) : domain σ :=
interp_apply F HNil := F;
interp_apply F (HCons _ _ v vs') := interp_apply (F v) vs'.
Proof.
intros vs.
refine (match vs as vs0 in hlist l
return match l return hlist l → Prop with
| [] ⇒ fun vs1 ⇒ vs1 = HNil
| _ :: _ ⇒ fun _ ⇒ True
end vs0
with
| HNil ⇒ eq_refl
| HCons _ _ _ _ ⇒ I
end).
Qed.
Lemma hlist_cons_eq : ∀ σ σs (vs : hlist (σ :: σs)),
∃ v vs', vs = HCons σ σs v vs'.
Proof.
intros σ σs vs.
refine (match vs as vs0 in hlist l
return match l return hlist l → Prop with
| [] ⇒ fun _ ⇒ True
| σ0 :: σs0 ⇒
fun vs1 ⇒ ∃ v vs', vs1 = HCons σ0 σs0 v vs'
end vs0
with
| HNil ⇒ I
| HCons σ0 σs0 v vs' ⇒ _
end).
now ∃ v, vs'.
Qed.
Equations interp_apply {σs σ}
(F : interpretation σs σ)
(vs : hlist σs) : domain σ :=
interp_apply F HNil := F;
interp_apply F (HCons _ _ v vs') := interp_apply (F v) vs'.
The inverse of interp_apply: the interpretation of a rank read off a
function on its argument lists.
Fixpoint interp_curry {σs σ} : (hlist σs → domain σ) → interpretation σs σ :=
match σs return (hlist σs → domain σ) → interpretation σs σ with
| [] ⇒ fun F ⇒ F HNil
| σ' :: σs' ⇒ fun F v ⇒ interp_curry (fun vs ⇒ F (HCons σ' σs' v vs))
end.
Lemma interp_apply_curry : ∀ σs σ (F : hlist σs → domain σ) vs,
interp_apply (interp_curry F) vs = F vs.
Proof.
intros σs σ F vs. revert F.
induction vs as [| σ' σs' v vs IH]; intros F; simp interp_apply.
- reflexivity.
- apply (IH (fun vs ⇒ F (HCons σ' σs' v vs))).
Qed.
match σs return (hlist σs → domain σ) → interpretation σs σ with
| [] ⇒ fun F ⇒ F HNil
| σ' :: σs' ⇒ fun F v ⇒ interp_curry (fun vs ⇒ F (HCons σ' σs' v vs))
end.
Lemma interp_apply_curry : ∀ σs σ (F : hlist σs → domain σ) vs,
interp_apply (interp_curry F) vs = F vs.
Proof.
intros σs σ F vs. revert F.
induction vs as [| σ' σs' v vs IH]; intros F; simp interp_apply.
- reflexivity.
- apply (IH (fun vs ⇒ F (HCons σ' σs' v vs))).
Qed.
Fixpoint hlist_lookup {σs} (vs : hlist σs)
(i : nat) : option { σ : sort & domain σ } :=
match vs with
| HNil ⇒ None
| HCons σ0 σs0 v0 vs0 ⇒
match i with
| 0 ⇒ Some (existT σ0 v0)
| S i' ⇒ hlist_lookup vs0 i'
end
end.
Theorem hlist_lookup_Some : ∀ σs (vs : hlist σs) i σ,
σs !! i = Some σ ↔ ∃ v, hlist_lookup vs i = Some (existT σ v).
Proof. induction vs; sauto q:on. Qed.
Corollary hlist_lookup_Some_1 : ∀ σs (vs : hlist σs) i σ v,
hlist_lookup vs i = Some (existT σ v) → σs !! i = Some σ.
Proof. hauto lq:on use:hlist_lookup_Some. Qed.
Corollary hlist_lookup_is_Some : ∀ σs (vs : hlist σs) i,
is_Some (σs !! i) ↔ is_Some (hlist_lookup vs i).
Proof.
split; intros.
- destruct H as [σ Hσ].
rewrite hlist_lookup_Some with (vs := vs) in Hσ.
destruct Hσ as [v Hσ_v]. ∃ (existT σ v). assumption.
- destruct H as [[σ v] Hσ_v].
∃ σ. eapply hlist_lookup_Some_1. eauto.
Qed.
The values of an hlist, each tagged with its sort: the form a finite
map from variables stores them in.
Fixpoint hlist_to_list {σs} (vs : hlist σs) : list (sigT domain) :=
match vs with
| HNil ⇒ []
| HCons σ0 σs0 v0 vs0 ⇒ existT σ0 v0 :: hlist_to_list vs0
end.
Lemma list_lookup_hlist_to_list : ∀ σs (vs : hlist σs) i,
hlist_to_list vs !! i = hlist_lookup vs i.
Proof. induction vs as [| σ σs v vs IH]; intros [|i]; simpl; auto. Qed.
Lemma fmap_projT1_hlist_to_list : ∀ σs (vs : hlist σs),
projT1 <$> hlist_to_list vs = σs.
Proof. induction vs as [| σ σs v vs IH]; simpl; [done | by f_equal]. Qed.
Lemma length_hlist_to_list : ∀ σs (vs : hlist σs),
length (hlist_to_list vs) = length σs.
Proof. induction vs as [| σ σs v vs IH]; simpl; congruence. Qed.
match vs with
| HNil ⇒ []
| HCons σ0 σs0 v0 vs0 ⇒ existT σ0 v0 :: hlist_to_list vs0
end.
Lemma list_lookup_hlist_to_list : ∀ σs (vs : hlist σs) i,
hlist_to_list vs !! i = hlist_lookup vs i.
Proof. induction vs as [| σ σs v vs IH]; intros [|i]; simpl; auto. Qed.
Lemma fmap_projT1_hlist_to_list : ∀ σs (vs : hlist σs),
projT1 <$> hlist_to_list vs = σs.
Proof. induction vs as [| σ σs v vs IH]; simpl; [done | by f_equal]. Qed.
Lemma length_hlist_to_list : ∀ σs (vs : hlist σs),
length (hlist_to_list vs) = length σs.
Proof. induction vs as [| σ σs v vs IH]; simpl; congruence. Qed.
Type-valued "every element satisfies P".
Fixpoint hlist_ForallT {σs}
(P : ∀ σ, domain σ → Type) (vs : hlist σs) : Type :=
match vs with
| HNil ⇒ unit
| HCons σ σs' v vs' ⇒ (P σ v × hlist_ForallT P vs')%type
end.
(P : ∀ σ, domain σ → Type) (vs : hlist σs) : Type :=
match vs with
| HNil ⇒ unit
| HCons σ σs' v vs' ⇒ (P σ v × hlist_ForallT P vs')%type
end.
The hlist_ForallT payload is a nested tuple, which is what a Type-level
definition wants. A proof wants it indexed, to match the hlist_lookup
lemmas above.
Theorem hlist_ForallT_lookup :
∀ (P : ∀ σ, dom σ → Prop) σs (vs : hlist σs),
hlist_ForallT P vs →
∀ i p, hlist_lookup vs i = Some p → P (projT1 p) (projT2 p).
Proof.
intros P σs vs. induction vs as [|σ σs' v vs' IH]; simpl.
- intros _ i p Hlk. destruct i; simpl in Hlk; discriminate.
- intros [Hv Hall] i p Hlk. destruct i; simpl in Hlk.
+ injection Hlk as <-. exact Hv.
+ eapply IH; eassumption.
Qed.
End Interpretation.
Arguments HNil {_}.
Arguments HCons {_}.
Arguments hlist_to_list {_ _} _.
∀ (P : ∀ σ, dom σ → Prop) σs (vs : hlist σs),
hlist_ForallT P vs →
∀ i p, hlist_lookup vs i = Some p → P (projT1 p) (projT2 p).
Proof.
intros P σs vs. induction vs as [|σ σs' v vs' IH]; simpl.
- intros _ i p Hlk. destruct i; simpl in Hlk; discriminate.
- intros [Hv Hall] i p Hlk. destruct i; simpl in Hlk.
+ injection Hlk as <-. exact Hv.
+ eapply IH; eassumption.
Qed.
End Interpretation.
Arguments HNil {_}.
Arguments HCons {_}.
Arguments hlist_to_list {_ _} _.
Replacements for dependent destruction on an hlist at a known index
shape, so that the lemmas above carry the case analysis rather than
eq_rect_eq. hlist_cons keeps the tail under the name the head
variable had, as dependent destruction does.
Ltac hlist_nil vs :=
let H := fresh in
pose proof (hlist_nil_eq _ vs) as H; subst vs.
Ltac hlist_cons vs :=
let v := fresh "d" in
let tl := fresh in
destruct (hlist_cons_eq _ _ _ vs) as (v & tl & ->); rename tl into vs.
Fixpoint hlist_map
{domain1 domain2 : sort → Type}
(g : ∀ σ, domain1 σ → domain2 σ)
{σs : list sort}
(vs : hlist domain1 σs) : hlist domain2 σs :=
match vs with
| HNil ⇒ HNil
| HCons σ σs v vs' ⇒ HCons σ σs (g σ v) (hlist_map g vs')
end.
Theorem hlist_map_map :
∀ {d1 d2 d3} (f : ∀ σ, d1 σ → d2 σ) (g : ∀ σ, d2 σ → d3 σ)
σs (vs : hlist d1 σs),
hlist_map g (hlist_map f vs) = hlist_map (fun σ v ⇒ g σ (f σ v)) vs.
Proof. intros d1 d2 d3 f g σs vs. induction vs; simpl; congruence. Qed.
let H := fresh in
pose proof (hlist_nil_eq _ vs) as H; subst vs.
Ltac hlist_cons vs :=
let v := fresh "d" in
let tl := fresh in
destruct (hlist_cons_eq _ _ _ vs) as (v & tl & ->); rename tl into vs.
Fixpoint hlist_map
{domain1 domain2 : sort → Type}
(g : ∀ σ, domain1 σ → domain2 σ)
{σs : list sort}
(vs : hlist domain1 σs) : hlist domain2 σs :=
match vs with
| HNil ⇒ HNil
| HCons σ σs v vs' ⇒ HCons σ σs (g σ v) (hlist_map g vs')
end.
Theorem hlist_map_map :
∀ {d1 d2 d3} (f : ∀ σ, d1 σ → d2 σ) (g : ∀ σ, d2 σ → d3 σ)
σs (vs : hlist d1 σs),
hlist_map g (hlist_map f vs) = hlist_map (fun σ v ⇒ g σ (f σ v)) vs.
Proof. intros d1 d2 d3 f g σs vs. induction vs; simpl; congruence. Qed.
hlist_map commutes with lookup: the ith element of the mapped list is
the image of the ith element.
Theorem hlist_lookup_map :
∀ {d1 d2} (f : ∀ σ, d1 σ → d2 σ) σs (vs : hlist d1 σs) i σ v,
hlist_lookup d1 vs i = Some (existT σ v) →
hlist_lookup d2 (hlist_map f vs) i = Some (existT σ (f σ v)).
Proof.
intros d1 d2 f σs vs.
induction vs as [| σ0 σs0 v0 vs0 IH]; intros i σ v Hlk.
- destruct i; discriminate.
- destruct i as [| i]; cbn in ×.
+ injection Hlk as Hσ Hv. subst σ0.
apply (Eqdep_dec.inj_pair2_eq_dec _ (fun x y ⇒ decide (x = y)))
in Hv. by subst v0.
+ apply IH, Hlk.
Qed.
Theorem hlist_map_id :
∀ {d} (f : ∀ σ, d σ → d σ) σs (vs : hlist d σs),
(∀ σ v, f σ v = v) → hlist_map f vs = vs.
Proof. intros d f σs vs Hf. induction vs; simpl; congruence. Qed.
∀ {d1 d2} (f : ∀ σ, d1 σ → d2 σ) σs (vs : hlist d1 σs) i σ v,
hlist_lookup d1 vs i = Some (existT σ v) →
hlist_lookup d2 (hlist_map f vs) i = Some (existT σ (f σ v)).
Proof.
intros d1 d2 f σs vs.
induction vs as [| σ0 σs0 v0 vs0 IH]; intros i σ v Hlk.
- destruct i; discriminate.
- destruct i as [| i]; cbn in ×.
+ injection Hlk as Hσ Hv. subst σ0.
apply (Eqdep_dec.inj_pair2_eq_dec _ (fun x y ⇒ decide (x = y)))
in Hv. by subst v0.
+ apply IH, Hlk.
Qed.
Theorem hlist_map_id :
∀ {d} (f : ∀ σ, d σ → d σ) σs (vs : hlist d σs),
(∀ σ v, f σ v = v) → hlist_map f vs = vs.
Proof. intros d f σs vs Hf. induction vs; simpl; congruence. Qed.
Ground Terms
Section GroundTerm.
Variables (Σ : signature) (gen : ∀ σ, adt_free Σ σ → Type).
Unset Elimination Schemes.
Inductive ground_term : sort → Type :=
| GGen :
∀ σ (H : adt_free Σ σ),
gen σ H →
ground_term σ
| GConstr :
∀ c σs δ s,
s ∈ Σ.(sort_symbols) →
sort_top_symbol δ = Some s →
c ∈ Σ.(constructors_for_sort) s →
monomorphic_rank Σ c σs δ →
sort_wf Σ δ →
hlist ground_term σs →
ground_term δ.
Set Elimination Schemes.
End GroundTerm.
Arguments GGen {_} {_}.
Arguments GConstr {_} {_}.
Definition ground_term_constructor {Σ gen δ} (g : ground_term Σ gen δ)
: option func :=
match g with
| GGen _ _ _ ⇒ None
| GConstr c _ _ _ _ _ _ _ _ _ ⇒ Some c
end.
Elimination
Section GroundTermRect.
Context (Σ : signature) (gen : ∀ σ, adt_free Σ σ → Type).
Context (P : ∀ σ, ground_term Σ gen σ → Type).
Context (Hgen : ∀ σ H (x : gen σ H), P σ (GGen σ H x)).
Context (Hconstr :
∀ c σs δ s Hs Hδ Hc Hrank Hwf (vs : hlist (ground_term Σ gen) σs),
hlist_ForallT (ground_term Σ gen) P vs →
P δ (GConstr c σs δ s Hs Hδ Hc Hrank Hwf vs)).
The recursion over the argument list has to be an inner fix. Written as
a mutual Fixpoint the guard checker rejects it: hlist is not in the
same inductive block as ground_term, so it cannot see an element of the
list as a subterm of the term. Inlined, the subterm information
propagates, because ws is passed vs and vs is a subterm of g.
Fixpoint ground_term_rect σ (g : ground_term Σ gen σ) {struct g} : P σ g :=
match g with
| GGen σ H x ⇒ Hgen σ H x
| GConstr c σs δ s Hs Hδ Hc Hrank Hwf vs ⇒
Hconstr c σs δ s Hs Hδ Hc Hrank Hwf vs
((fix go σs' (ws : hlist (ground_term Σ gen) σs') {struct ws}
: hlist_ForallT (ground_term Σ gen) P ws :=
match ws with
| HNil ⇒ tt
| HCons σ' σs'' w ws' ⇒ (ground_term_rect σ' w, go σs'' ws')
end) σs vs)
end.
End GroundTermRect.
Lemma ground_term_ind :
∀ (Σ : signature) (gen : ∀ σ, adt_free Σ σ → Type)
(P : ∀ σ, ground_term Σ gen σ → Prop),
(∀ σ H (x : gen σ H), P σ (GGen σ H x)) →
(∀ c σs δ s Hs Hδ Hc Hrank Hwf (vs : hlist (ground_term Σ gen) σs),
(∀ i p, hlist_lookup (ground_term Σ gen) vs i = Some p →
P (projT1 p) (projT2 p)) →
P δ (GConstr c σs δ s Hs Hδ Hc Hrank Hwf vs)) →
∀ σ g, P σ g.
Proof.
intros Σ gen P Hgen Hconstr.
apply (ground_term_rect Σ gen P Hgen).
intros c σs δ s Hs Hδ Hc Hrank Hwf vs Hall.
apply Hconstr. now apply hlist_ForallT_lookup.
Qed.
match g with
| GGen σ H x ⇒ Hgen σ H x
| GConstr c σs δ s Hs Hδ Hc Hrank Hwf vs ⇒
Hconstr c σs δ s Hs Hδ Hc Hrank Hwf vs
((fix go σs' (ws : hlist (ground_term Σ gen) σs') {struct ws}
: hlist_ForallT (ground_term Σ gen) P ws :=
match ws with
| HNil ⇒ tt
| HCons σ' σs'' w ws' ⇒ (ground_term_rect σ' w, go σs'' ws')
end) σs vs)
end.
End GroundTermRect.
Lemma ground_term_ind :
∀ (Σ : signature) (gen : ∀ σ, adt_free Σ σ → Type)
(P : ∀ σ, ground_term Σ gen σ → Prop),
(∀ σ H (x : gen σ H), P σ (GGen σ H x)) →
(∀ c σs δ s Hs Hδ Hc Hrank Hwf (vs : hlist (ground_term Σ gen) σs),
(∀ i p, hlist_lookup (ground_term Σ gen) vs i = Some p →
P (projT1 p) (projT2 p)) →
P δ (GConstr c σs δ s Hs Hδ Hc Hrank Hwf vs)) →
∀ σ g, P σ g.
Proof.
intros Σ gen P Hgen Hconstr.
apply (ground_term_rect Σ gen P Hgen).
intros c σs δ s Hs Hδ Hc Hrank Hwf vs Hall.
apply Hconstr. now apply hlist_ForallT_lookup.
Qed.
Reading a Sort Off a Term
Definition embeddable_sort_of_ground_term
(Σ : signature) (gen : ∀ σ, adt_free Σ σ → Type)
(σ : sort) (g : ground_term Σ gen σ) : embeddable_sort Σ σ :=
match g in ground_term _ _ σ0 return embeddable_sort Σ σ0 with
| GGen σ0 H _ ⇒ embeddable_sort_adt_free Σ σ0 H
| GConstr c σs δ s Hs Hδ Hc Hrank Hwf _ ⇒
embeddable_sort_adt Σ δ (adt_intro Σ δ s c Hs Hδ Hc Hwf)
end.
Corollary Forall_embeddable_sort_of_hlist :
∀ Σ gen σs,
hlist (ground_term Σ gen) σs → Forall (embeddable_sort Σ) σs.
Proof.
intros Σ gen σs vs. induction vs as [| σ σs' v vs' IH]; constructor;
eauto using embeddable_sort_of_ground_term.
Qed.
(Σ : signature) (gen : ∀ σ, adt_free Σ σ → Type)
(σ : sort) (g : ground_term Σ gen σ) : embeddable_sort Σ σ :=
match g in ground_term _ _ σ0 return embeddable_sort Σ σ0 with
| GGen σ0 H _ ⇒ embeddable_sort_adt_free Σ σ0 H
| GConstr c σs δ s Hs Hδ Hc Hrank Hwf _ ⇒
embeddable_sort_adt Σ δ (adt_intro Σ δ s c Hs Hδ Hc Hwf)
end.
Corollary Forall_embeddable_sort_of_hlist :
∀ Σ gen σs,
hlist (ground_term Σ gen) σs → Forall (embeddable_sort Σ) σs.
Proof.
intros Σ gen σs vs. induction vs as [| σ σs' v vs' IH]; constructor;
eauto using embeddable_sort_of_ground_term.
Qed.
Section Structure.
Record structure :=
{
domain : sort → Type;
domain_σ_bool : domain σ_bool = bool;
domain_σ_map : ∀ σ1 σ2, domain (τ_map σ1 σ2) = (domain σ1 → domain σ2);
interp : func → ∀ (σs : list sort) (σ : sort), interpretation domain σs σ;
}.
Variable (Σ : signature).
Moving Between the Domain and the Term Algebra
Definition domain_gen (A : structure) : ∀ σ, adt_free Σ σ → Type :=
fun σ _ ⇒ A.(domain) σ.
Section EmbedProject.
Context (A : structure).
Context (Hdom : ∀ δ, adt Σ δ →
A.(domain) δ = ground_term Σ (domain_gen A) δ).
fun σ _ ⇒ A.(domain) σ.
Section EmbedProject.
Context (A : structure).
Context (Hdom : ∀ δ, adt Σ δ →
A.(domain) δ = ground_term Σ (domain_gen A) δ).
adt_axioms' constructor condition has to equate a domain-level
application with a term-level one, so it needs to send a constructor's
arguments across. A datatype-sorted argument transports by the domain
equation; a datatype-free one is a generator leaf. The choice between
the two builds a term, so it cannot be made classically — adt_dec is
what makes this a function.
An argument sort that is neither — a datatype buried under another sort
constructor — has no ground terms at all, so there is nothing to send
it to. The crossing therefore takes an embeddable_sort proof, and
the constructor condition below is stated only at the ranks that have
one.
Definition ground_term_embed (σ : sort) (Hi : embeddable_sort Σ σ)
(v : A.(domain) σ) : ground_term Σ (domain_gen A) σ :=
match decide (adt Σ σ) with
| left H ⇒ cast (Hdom σ H) v
| right H ⇒ GGen σ (adt_free_of_embeddable Σ σ Hi H) v
end.
(v : A.(domain) σ) : ground_term Σ (domain_gen A) σ :=
match decide (adt Σ σ) with
| left H ⇒ cast (Hdom σ H) v
| right H ⇒ GGen σ (adt_free_of_embeddable Σ σ Hi H) v
end.
The left inverse. A leaf gives its generator back; a constructor
application is a datatype element, so the domain equation transports it
back. This is what takes a destructured GConstr's argument list back
to domain elements.
Definition ground_term_project (σ : sort)
(g : ground_term Σ (domain_gen A) σ) : A.(domain) σ :=
match g in ground_term _ _ σ0 return A.(domain) σ0 with
| GGen σ H x ⇒ x
| GConstr c σs δ s Hs Hδ Hc Hrank Hwf vs ⇒
cast_sym (Hdom δ (adt_intro Σ δ s c Hs Hδ Hc Hwf))
(GConstr c σs δ s Hs Hδ Hc Hrank Hwf vs)
end.
Lemma ground_term_embed_adt : ∀ σ Hi (H : adt Σ σ) v,
ground_term_embed σ Hi v = cast (Hdom σ H) v.
Proof.
intros σ Hi H v. unfold ground_term_embed.
destruct (decide (adt Σ σ)) as [H'|H']; [| contradiction].
now rewrite (adt_irrelevant _ _ H' H).
Qed.
Lemma ground_term_embed_gen : ∀ σ Hi (H : adt_free Σ σ) v,
ground_term_embed σ Hi v = GGen σ H v.
Proof.
intros σ Hi H v. unfold ground_term_embed.
destruct (decide (adt Σ σ)) as [H'|H'];
[destruct (adt_free_not_adt Σ σ H H') |].
now rewrite (adt_free_irrelevant _ _ (adt_free_of_embeddable Σ σ Hi H') H).
Qed.
Lemma ground_term_project_adt : ∀ σ (H : adt Σ σ) g,
ground_term_project σ g = cast_sym (Hdom σ H) g.
Proof.
intros σ Hadt g. revert Hadt.
destruct g as [σ0 Hn x | c σs δ s Hs Hδ Hc Hrank Hwf vs]; intros Hadt.
- destruct (adt_free_not_adt Σ σ0 Hn Hadt).
- simpl. now rewrite (adt_irrelevant _ _ (adt_intro _ _ _ _ Hs Hδ Hc Hwf) Hadt).
Qed.
(g : ground_term Σ (domain_gen A) σ) : A.(domain) σ :=
match g in ground_term _ _ σ0 return A.(domain) σ0 with
| GGen σ H x ⇒ x
| GConstr c σs δ s Hs Hδ Hc Hrank Hwf vs ⇒
cast_sym (Hdom δ (adt_intro Σ δ s c Hs Hδ Hc Hwf))
(GConstr c σs δ s Hs Hδ Hc Hrank Hwf vs)
end.
Lemma ground_term_embed_adt : ∀ σ Hi (H : adt Σ σ) v,
ground_term_embed σ Hi v = cast (Hdom σ H) v.
Proof.
intros σ Hi H v. unfold ground_term_embed.
destruct (decide (adt Σ σ)) as [H'|H']; [| contradiction].
now rewrite (adt_irrelevant _ _ H' H).
Qed.
Lemma ground_term_embed_gen : ∀ σ Hi (H : adt_free Σ σ) v,
ground_term_embed σ Hi v = GGen σ H v.
Proof.
intros σ Hi H v. unfold ground_term_embed.
destruct (decide (adt Σ σ)) as [H'|H'];
[destruct (adt_free_not_adt Σ σ H H') |].
now rewrite (adt_free_irrelevant _ _ (adt_free_of_embeddable Σ σ Hi H') H).
Qed.
Lemma ground_term_project_adt : ∀ σ (H : adt Σ σ) g,
ground_term_project σ g = cast_sym (Hdom σ H) g.
Proof.
intros σ Hadt g. revert Hadt.
destruct g as [σ0 Hn x | c σs δ s Hs Hδ Hc Hrank Hwf vs]; intros Hadt.
- destruct (adt_free_not_adt Σ σ0 Hn Hadt).
- simpl. now rewrite (adt_irrelevant _ _ (adt_intro _ _ _ _ Hs Hδ Hc Hwf) Hadt).
Qed.
The two round trips. ground_term_project is a genuine inverse, not merely a
retraction, which is what lets a destructured GConstr be put back
together after its arguments have been read off.
Lemma ground_term_project_embed : ∀ σ Hi v,
ground_term_project σ (ground_term_embed σ Hi v) = v.
Proof.
intros σ Hi v. unfold ground_term_embed.
destruct (decide (adt Σ σ)) as [H|H].
- rewrite (ground_term_project_adt σ H). now rewrite cast_sym_cast.
- reflexivity.
Qed.
Lemma ground_term_embed_project : ∀ σ Hi g,
ground_term_embed σ Hi (ground_term_project σ g) = g.
Proof.
intros σ Hi g. destruct (decide (adt Σ σ)) as [Hd|Hd].
- rewrite (ground_term_project_adt σ Hd), (ground_term_embed_adt σ Hi Hd).
now rewrite cast_cast_sym.
- rewrite (ground_term_embed_gen σ Hi (adt_free_of_embeddable Σ σ Hi Hd)).
revert Hd.
destruct g as [σ0 Hn x | c σs δ s Hs Hδ Hc Hrank Hwf vs]; intros Hd.
+ simpl. now rewrite (adt_free_irrelevant _ _
(adt_free_of_embeddable Σ σ0 Hi Hd) Hn).
+ exfalso. apply Hd. exact (adt_intro _ _ _ _ Hs Hδ Hc Hwf).
Qed.
Lemma ground_term_embed_inj : ∀ σ Hi v1 v2,
ground_term_embed σ Hi v1 = ground_term_embed σ Hi v2 → v1 = v2.
Proof.
intros σ Hi v1 v2 Heq.
rewrite <- (ground_term_project_embed σ Hi v1),
<- (ground_term_project_embed σ Hi v2).
now f_equal.
Qed.
Crossing a Constructor's Argument List
Fixpoint hlist_map_embed {σs} (vs : hlist A.(domain) σs)
: Forall (embeddable_sort Σ) σs →
hlist (ground_term Σ (domain_gen A)) σs :=
match vs in hlist _ σs0
return Forall (embeddable_sort Σ) σs0 →
hlist (ground_term Σ (domain_gen A)) σs0 with
| HNil ⇒ fun _ ⇒ HNil
| HCons σ σs' v vs' ⇒
fun H ⇒
HCons σ σs' (ground_term_embed σ (Forall_cons_head H) v)
(hlist_map_embed vs' (Forall_cons_tail H))
end.
: Forall (embeddable_sort Σ) σs →
hlist (ground_term Σ (domain_gen A)) σs :=
match vs in hlist _ σs0
return Forall (embeddable_sort Σ) σs0 →
hlist (ground_term Σ (domain_gen A)) σs0 with
| HNil ⇒ fun _ ⇒ HNil
| HCons σ σs' v vs' ⇒
fun H ⇒
HCons σ σs' (ground_term_embed σ (Forall_cons_head H) v)
(hlist_map_embed vs' (Forall_cons_tail H))
end.
The round trip on a whole argument list: what a destructured GConstr
needs in order to be put back together after its arguments have been
read off the domain.
Lemma hlist_map_embed_project :
∀ σs (vs : hlist (ground_term Σ (domain_gen A)) σs) H,
hlist_map_embed (hlist_map ground_term_project vs) H = vs.
Proof.
intros σs vs. induction vs as [| σ σs' v vs' IH]; intros H.
- reflexivity.
- cbn [hlist_map hlist_map_embed].
f_equal; [apply ground_term_embed_project | apply IH].
Qed.
End EmbedProject.
∀ σs (vs : hlist (ground_term Σ (domain_gen A)) σs) H,
hlist_map_embed (hlist_map ground_term_project vs) H = vs.
Proof.
intros σs vs. induction vs as [| σ σs' v vs' IH]; intros H.
- reflexivity.
- cbn [hlist_map hlist_map_embed].
f_equal; [apply ground_term_embed_project | apply IH].
Qed.
End EmbedProject.
The Selector and Tester Conditions
Definition adt_selector_condition (E : sort → Prop) (A : structure) : Prop :=
∀ c σs δ i g σi vi,
c ∈ Σ.(constructors) →
monomorphic_rank Σ c σs δ →
Forall E σs →
Σ.(selectors_for_constructor) c !! i = Some g →
let G := A.(interp) g [δ] σi in
∀ vs,
hlist_lookup A.(domain) vs i = Some (existT σi vi) →
let C := A.(interp) c σs δ in
G (interp_apply A.(domain) C vs) = vi.
∀ c σs δ i g σi vi,
c ∈ Σ.(constructors) →
monomorphic_rank Σ c σs δ →
Forall E σs →
Σ.(selectors_for_constructor) c !! i = Some g →
let G := A.(interp) g [δ] σi in
∀ vs,
hlist_lookup A.(domain) vs i = Some (existT σi vi) →
let C := A.(interp) c σs δ in
G (interp_apply A.(domain) C vs) = vi.
A tester holds exactly on the range of its constructor, at each sort
the constructor builds. At any other sort the condition says nothing,
as Definition 9(5) says nothing, so a tester the signature overloads at
such a sort is left free there.
The condition is about constructors and says nothing about any other
symbol. It has to be restricted explicitly, because
tester_for_constructor is a total function on func that a signature
is free to define as the identity off constructors — as Σ_core and
Σ_reals_ints both do. Read at such a symbol the condition would ask
the symbol's own interpretation to recognise the symbol's own range,
which no interpretation of a surjection can do: at f_not it asks
negb to be true exactly on the range of negb.
Definition adt_tester_condition (A : structure) : Prop :=
∀ c σs δ,
c ∈ Σ.(constructors) →
monomorphic_rank Σ c σs δ →
let P := A.(interp) (Σ.(tester_for_constructor) c) [δ] σ_bool in
let C := A.(interp) c σs δ in
∀ v,
cast A.(domain_σ_bool) (P v) = true
↔ ∃ vs, interp_apply A.(domain) C vs = v.
∀ c σs δ,
c ∈ Σ.(constructors) →
monomorphic_rank Σ c σs δ →
let P := A.(interp) (Σ.(tester_for_constructor) c) [δ] σ_bool in
let C := A.(interp) c σs δ in
∀ v,
cast A.(domain_σ_bool) (P v) = true
↔ ∃ vs, interp_apply A.(domain) C vs = v.
The Constructor Condition
Definition adt_constructor_condition (A : structure)
(Hdom : ∀ δ, adt Σ δ → A.(domain) δ = ground_term Σ (domain_gen A) δ)
: Prop :=
∀ c σs δ s
(Hs : s ∈ Σ.(sort_symbols))
(Hδ : sort_top_symbol δ = Some s)
(Hc : c ∈ Σ.(constructors_for_sort) s)
(Hrank : monomorphic_rank Σ c σs δ)
(Hwf : sort_wf Σ δ)
(Hσs : Forall (embeddable_sort Σ) σs),
let C := A.(interp) c σs δ in
∀ vs, cast (Hdom δ (adt_intro Σ δ s c Hs Hδ Hc Hwf))
(interp_apply A.(domain) C vs) =
GConstr c σs δ s Hs Hδ Hc Hrank Hwf
(hlist_map_embed A Hdom vs Hσs).
Record adt_axioms (A : structure) : Prop :=
{
(Hdom : ∀ δ, adt Σ δ → A.(domain) δ = ground_term Σ (domain_gen A) δ)
: Prop :=
∀ c σs δ s
(Hs : s ∈ Σ.(sort_symbols))
(Hδ : sort_top_symbol δ = Some s)
(Hc : c ∈ Σ.(constructors_for_sort) s)
(Hrank : monomorphic_rank Σ c σs δ)
(Hwf : sort_wf Σ δ)
(Hσs : Forall (embeddable_sort Σ) σs),
let C := A.(interp) c σs δ in
∀ vs, cast (Hdom δ (adt_intro Σ δ s c Hs Hδ Hc Hwf))
(interp_apply A.(domain) C vs) =
GConstr c σs δ s Hs Hδ Hc Hrank Hwf
(hlist_map_embed A Hdom vs Hσs).
Record adt_axioms (A : structure) : Prop :=
{
Definition 8, first bullet, and the domain half of Definition 9's
ADT requirement: the domain of a datatype sort is the free term
algebra over the signature's constructors.
The constructor condition reads the domain through adt_domain;
the selector and tester conditions do not mention ground_term, and
are shared with the variants of the domain condition that other
theories introduce.
adt_interp_constructor : adt_constructor_condition A adt_domain;
adt_interp_selector : adt_selector_condition (embeddable_sort Σ) A;
adt_interp_tester : adt_tester_condition A;
}.
End Structure.
Arguments adt_axioms {_}.
Arguments adt_domain {_} {_}.
Arguments adt_interp_constructor {_} {_}.
Arguments adt_interp_selector {_} {_}.
Arguments adt_interp_tester {_} {_}.
adt_interp_selector : adt_selector_condition (embeddable_sort Σ) A;
adt_interp_tester : adt_tester_condition A;
}.
End Structure.
Arguments adt_axioms {_}.
Arguments adt_domain {_} {_}.
Arguments adt_interp_constructor {_} {_}.
Arguments adt_interp_selector {_} {_}.
Arguments adt_interp_tester {_} {_}.
Consequences of the Structure Axioms
Definition domain_witness (A : structure) (σ : sort) : A.(domain) σ :=
A.(interp) (IdSimple "") [] σ.
A.(interp) (IdSimple "") [] σ.
The tester condition with its lets reduced, in the form a caller
applies.
Corollary adt_interp_tester_at_rank :
∀ Σ (A : structure) (Ht : adt_tester_condition Σ A) c σs δ,
c ∈ Σ.(constructors) →
monomorphic_rank Σ c σs δ →
∀ v,
cast A.(domain_σ_bool)
(A.(interp) (Σ.(tester_for_constructor) c) [δ] σ_bool v) = true
↔ ∃ vs, interp_apply A.(domain) (A.(interp) c σs δ) vs = v.
Proof.
intros Σ A Ht c σs δ Hcon Hrank v. exact (Ht c σs δ Hcon Hrank v).
Qed.
Arguments adt_interp_tester_at_rank {_} {_}.
Theorem adt_interp_constructor_disjoint :
∀ Σ (A : structure) (Hadt : adt_axioms (Σ := Σ) A)
c1 c2 σs1 σs2 δ s
(Hs : s ∈ Σ.(sort_symbols)) (Hδ : sort_top_symbol δ = Some s)
(Hc1 : c1 ∈ Σ.(constructors_for_sort) s)
(Hc2 : c2 ∈ Σ.(constructors_for_sort) s)
(Hrank1 : monomorphic_rank Σ c1 σs1 δ)
(Hrank2 : monomorphic_rank Σ c2 σs2 δ)
(Hwf : sort_wf Σ δ)
(Hσs1 : Forall (embeddable_sort Σ) σs1)
(Hσs2 : Forall (embeddable_sort Σ) σs2)
vs1 vs2,
interp_apply A.(domain) (A.(interp) c1 σs1 δ) vs1
= interp_apply A.(domain) (A.(interp) c2 σs2 δ) vs2 →
c1 = c2.
Proof.
intros Σ A Hadt c1 c2 σs1 σs2 δ s Hs Hδ Hc1 Hc2 Hrank1 Hrank2 Hwf Hσs1 Hσs2
vs1 vs2 Heq.
pose proof (adt_interp_constructor Hadt c1 σs1 δ s Hs Hδ Hc1 Hrank1 Hwf Hσs1 vs1)
as H1.
pose proof (adt_interp_constructor Hadt c2 σs2 δ s Hs Hδ Hc2 Hrank2 Hwf Hσs2 vs2)
as H2.
simpl in H1, H2.
set (P1 := adt_domain Hadt δ (adt_intro Σ δ s c1 Hs Hδ Hc1 Hwf)) in ×.
set (P2 := adt_domain Hadt δ (adt_intro Σ δ s c2 Hs Hδ Hc2 Hwf)) in ×.
assert (Hcast : cast P1 (interp_apply A.(domain) (A.(interp) c1 σs1 δ) vs1)
= cast P1 (interp_apply A.(domain) (A.(interp) c2 σs2 δ) vs2)).
{ f_equal. exact Heq. }
rewrite H1 in Hcast.
assert (HP : P1 = P2) by (unfold P1, P2; f_equal; apply adt_irrelevant).
rewrite HP in Hcast.
rewrite H2 in Hcast.
pose proof (f_equal ground_term_constructor Hcast) as Hcc. simpl in Hcc.
now injection Hcc.
Qed.
Arguments adt_interp_constructor_disjoint {_} {_}.
∀ Σ (A : structure) (Ht : adt_tester_condition Σ A) c σs δ,
c ∈ Σ.(constructors) →
monomorphic_rank Σ c σs δ →
∀ v,
cast A.(domain_σ_bool)
(A.(interp) (Σ.(tester_for_constructor) c) [δ] σ_bool v) = true
↔ ∃ vs, interp_apply A.(domain) (A.(interp) c σs δ) vs = v.
Proof.
intros Σ A Ht c σs δ Hcon Hrank v. exact (Ht c σs δ Hcon Hrank v).
Qed.
Arguments adt_interp_tester_at_rank {_} {_}.
Theorem adt_interp_constructor_disjoint :
∀ Σ (A : structure) (Hadt : adt_axioms (Σ := Σ) A)
c1 c2 σs1 σs2 δ s
(Hs : s ∈ Σ.(sort_symbols)) (Hδ : sort_top_symbol δ = Some s)
(Hc1 : c1 ∈ Σ.(constructors_for_sort) s)
(Hc2 : c2 ∈ Σ.(constructors_for_sort) s)
(Hrank1 : monomorphic_rank Σ c1 σs1 δ)
(Hrank2 : monomorphic_rank Σ c2 σs2 δ)
(Hwf : sort_wf Σ δ)
(Hσs1 : Forall (embeddable_sort Σ) σs1)
(Hσs2 : Forall (embeddable_sort Σ) σs2)
vs1 vs2,
interp_apply A.(domain) (A.(interp) c1 σs1 δ) vs1
= interp_apply A.(domain) (A.(interp) c2 σs2 δ) vs2 →
c1 = c2.
Proof.
intros Σ A Hadt c1 c2 σs1 σs2 δ s Hs Hδ Hc1 Hc2 Hrank1 Hrank2 Hwf Hσs1 Hσs2
vs1 vs2 Heq.
pose proof (adt_interp_constructor Hadt c1 σs1 δ s Hs Hδ Hc1 Hrank1 Hwf Hσs1 vs1)
as H1.
pose proof (adt_interp_constructor Hadt c2 σs2 δ s Hs Hδ Hc2 Hrank2 Hwf Hσs2 vs2)
as H2.
simpl in H1, H2.
set (P1 := adt_domain Hadt δ (adt_intro Σ δ s c1 Hs Hδ Hc1 Hwf)) in ×.
set (P2 := adt_domain Hadt δ (adt_intro Σ δ s c2 Hs Hδ Hc2 Hwf)) in ×.
assert (Hcast : cast P1 (interp_apply A.(domain) (A.(interp) c1 σs1 δ) vs1)
= cast P1 (interp_apply A.(domain) (A.(interp) c2 σs2 δ) vs2)).
{ f_equal. exact Heq. }
rewrite H1 in Hcast.
assert (HP : P1 = P2) by (unfold P1, P2; f_equal; apply adt_irrelevant).
rewrite HP in Hcast.
rewrite H2 in Hcast.
pose proof (f_equal ground_term_constructor Hcast) as Hcc. simpl in Hcc.
now injection Hcc.
Qed.
Arguments adt_interp_constructor_disjoint {_} {_}.
What a Consumer of the Datatype Condition Needs
No junk: every value of a datatype sort is built by one of that
sort's constructors. A match with no variable pattern rests on
this: it is what says one of the arms fires.
adt_constructed_domain :
∀ δ (v : A.(domain) δ),
adt Σ δ →
∃ c σs s (vs : hlist A.(domain) σs),
s ∈ Σ.(sort_symbols)
∧ sort_top_symbol δ = Some s
∧ c ∈ Σ.(constructors_for_sort) s
∧ monomorphic_rank Σ c σs δ
∧ interp_apply A.(domain) (A.(interp) c σs δ) vs = v;
∀ δ (v : A.(domain) δ),
adt Σ δ →
∃ c σs s (vs : hlist A.(domain) σs),
s ∈ Σ.(sort_symbols)
∧ sort_top_symbol δ = Some s
∧ c ∈ Σ.(constructors_for_sort) s
∧ monomorphic_rank Σ c σs δ
∧ interp_apply A.(domain) (A.(interp) c σs δ) vs = v;
No confusion: two constructors of one sort that build a common value
are the same constructor. Restates
adt_interp_constructor_disjoint without naming adt_axioms.
adt_constructed_disjoint :
∀ c1 c2 σs1 σs2 δ s,
s ∈ Σ.(sort_symbols) →
sort_top_symbol δ = Some s →
c1 ∈ Σ.(constructors_for_sort) s →
c2 ∈ Σ.(constructors_for_sort) s →
monomorphic_rank Σ c1 σs1 δ →
monomorphic_rank Σ c2 σs2 δ →
sort_wf Σ δ →
∀ vs1 vs2,
interp_apply A.(domain) (A.(interp) c1 σs1 δ) vs1
= interp_apply A.(domain) (A.(interp) c2 σs2 δ) vs2 →
c1 = c2;
}.
Arguments adt_constructed_domain {_} {_}.
Arguments adt_constructed_disjoint {_} {_}.
∀ c1 c2 σs1 σs2 δ s,
s ∈ Σ.(sort_symbols) →
sort_top_symbol δ = Some s →
c1 ∈ Σ.(constructors_for_sort) s →
c2 ∈ Σ.(constructors_for_sort) s →
monomorphic_rank Σ c1 σs1 δ →
monomorphic_rank Σ c2 σs2 δ →
sort_wf Σ δ →
∀ vs1 vs2,
interp_apply A.(domain) (A.(interp) c1 σs1 δ) vs1
= interp_apply A.(domain) (A.(interp) c2 σs2 δ) vs2 →
c1 = c2;
}.
Arguments adt_constructed_domain {_} {_}.
Arguments adt_constructed_disjoint {_} {_}.
adt_constructed does not read a signature's variable sorts, so it carries
to any signature agreeing with it except on sorts.
Theorem adt_constructed_signatures_agree_except_sorts : ∀ Σ1 Σ2 A,
signatures_agree_except_sorts Σ1 Σ2 →
adt_constructed Σ1 A → adt_constructed Σ2 A.
Proof.
intros Σ1 Σ2 A Hsym Hadt. split.
- intros δ v Hδ.
apply (adt_signatures_agree_except_sorts _ _ _
(signatures_agree_except_sorts_sym _ _ Hsym)) in Hδ.
destruct (adt_constructed_domain Hadt δ v Hδ)
as (c & σs & s & vs & Hs & Hhead & Hc & Hrank & Hv).
∃ c, σs, s, vs.
rewrite <- (signatures_agree_except_sorts_sort_symbols _ _ Hsym),
<- (signatures_agree_except_sorts_constructors_for_sort _ _ Hsym).
split_and!; [exact Hs | exact Hhead | exact Hc | | exact Hv].
exact (monomorphic_rank_signatures_agree_except_sorts _ _ _ _ _ Hsym Hrank).
- intros c1 c2 σs1 σs2 δ s Hs Hhead Hc1 Hc2 Hrank1 Hrank2 Hwf.
pose proof (signatures_agree_except_sorts_sym _ _ Hsym) as Hsym'.
apply (adt_constructed_disjoint Hadt c1 c2 σs1 σs2 δ s).
+ rewrite (signatures_agree_except_sorts_sort_symbols _ _ Hsym). exact Hs.
+ exact Hhead.
+ rewrite
(signatures_agree_except_sorts_constructors_for_sort _ _ Hsym). exact Hc1.
+ rewrite
(signatures_agree_except_sorts_constructors_for_sort _ _ Hsym). exact Hc2.
+ exact (monomorphic_rank_signatures_agree_except_sorts _ _ _ _ _
Hsym' Hrank1).
+ exact (monomorphic_rank_signatures_agree_except_sorts _ _ _ _ _
Hsym' Hrank2).
+ exact (sort_wf_signatures_agree_except_sorts _ _ _ Hsym' Hwf).
Qed.
Theorem adt_constructed_of_adt_axioms :
∀ Σ (A : structure),
constructor_args_embeddable Σ →
adt_axioms (Σ := Σ) A → adt_constructed Σ A.
Proof.
intros Σ A Hiv Hadt. constructor.
- intros δ v Hδ.
destruct (cast (adt_domain Hadt δ Hδ) v)
as [σ0 Hn x | c σs δ' s Hs Hhead Hc Hrank Hwf vs] eqn:Hg;
[destruct (adt_free_not_adt Σ σ0 Hn Hδ) |].
pose proof (Forall_embeddable_sort_of_hlist Σ _ σs vs) as Hσs.
∃ c, σs, s, (hlist_map (ground_term_project Σ A (adt_domain Hadt)) vs).
split_and!; try assumption.
pose proof (adt_interp_constructor Hadt c σs δ' s Hs Hhead Hc Hrank Hwf Hσs
(hlist_map (ground_term_project Σ A (adt_domain Hadt)) vs)) as Hconstr.
simpl in Hconstr.
rewrite hlist_map_embed_project in Hconstr.
rewrite (adt_irrelevant _ _ (adt_intro Σ δ' s c Hs Hhead Hc Hwf) Hδ) in Hconstr.
rewrite <- Hg in Hconstr.
apply (f_equal (cast_sym (adt_domain Hadt δ' Hδ))) in Hconstr.
rewrite !cast_sym_cast in Hconstr.
exact Hconstr.
- intros c1 c2 σs1 σs2 δ s Hs Hδ Hc1 Hc2 Hrank1 Hrank2 Hwf vs1 vs2 Heq.
eapply (adt_interp_constructor_disjoint Hadt c1 c2 σs1 σs2 δ s
Hs Hδ Hc1 Hc2 Hrank1 Hrank2 Hwf
(Hiv c1 σs1 δ s Hs Hδ Hc1 Hrank1)
(Hiv c2 σs2 δ s Hs Hδ Hc2 Hrank2)).
exact Heq.
Qed.
signatures_agree_except_sorts Σ1 Σ2 →
adt_constructed Σ1 A → adt_constructed Σ2 A.
Proof.
intros Σ1 Σ2 A Hsym Hadt. split.
- intros δ v Hδ.
apply (adt_signatures_agree_except_sorts _ _ _
(signatures_agree_except_sorts_sym _ _ Hsym)) in Hδ.
destruct (adt_constructed_domain Hadt δ v Hδ)
as (c & σs & s & vs & Hs & Hhead & Hc & Hrank & Hv).
∃ c, σs, s, vs.
rewrite <- (signatures_agree_except_sorts_sort_symbols _ _ Hsym),
<- (signatures_agree_except_sorts_constructors_for_sort _ _ Hsym).
split_and!; [exact Hs | exact Hhead | exact Hc | | exact Hv].
exact (monomorphic_rank_signatures_agree_except_sorts _ _ _ _ _ Hsym Hrank).
- intros c1 c2 σs1 σs2 δ s Hs Hhead Hc1 Hc2 Hrank1 Hrank2 Hwf.
pose proof (signatures_agree_except_sorts_sym _ _ Hsym) as Hsym'.
apply (adt_constructed_disjoint Hadt c1 c2 σs1 σs2 δ s).
+ rewrite (signatures_agree_except_sorts_sort_symbols _ _ Hsym). exact Hs.
+ exact Hhead.
+ rewrite
(signatures_agree_except_sorts_constructors_for_sort _ _ Hsym). exact Hc1.
+ rewrite
(signatures_agree_except_sorts_constructors_for_sort _ _ Hsym). exact Hc2.
+ exact (monomorphic_rank_signatures_agree_except_sorts _ _ _ _ _
Hsym' Hrank1).
+ exact (monomorphic_rank_signatures_agree_except_sorts _ _ _ _ _
Hsym' Hrank2).
+ exact (sort_wf_signatures_agree_except_sorts _ _ _ Hsym' Hwf).
Qed.
Theorem adt_constructed_of_adt_axioms :
∀ Σ (A : structure),
constructor_args_embeddable Σ →
adt_axioms (Σ := Σ) A → adt_constructed Σ A.
Proof.
intros Σ A Hiv Hadt. constructor.
- intros δ v Hδ.
destruct (cast (adt_domain Hadt δ Hδ) v)
as [σ0 Hn x | c σs δ' s Hs Hhead Hc Hrank Hwf vs] eqn:Hg;
[destruct (adt_free_not_adt Σ σ0 Hn Hδ) |].
pose proof (Forall_embeddable_sort_of_hlist Σ _ σs vs) as Hσs.
∃ c, σs, s, (hlist_map (ground_term_project Σ A (adt_domain Hadt)) vs).
split_and!; try assumption.
pose proof (adt_interp_constructor Hadt c σs δ' s Hs Hhead Hc Hrank Hwf Hσs
(hlist_map (ground_term_project Σ A (adt_domain Hadt)) vs)) as Hconstr.
simpl in Hconstr.
rewrite hlist_map_embed_project in Hconstr.
rewrite (adt_irrelevant _ _ (adt_intro Σ δ' s c Hs Hhead Hc Hwf) Hδ) in Hconstr.
rewrite <- Hg in Hconstr.
apply (f_equal (cast_sym (adt_domain Hadt δ' Hδ))) in Hconstr.
rewrite !cast_sym_cast in Hconstr.
exact Hconstr.
- intros c1 c2 σs1 σs2 δ s Hs Hδ Hc1 Hc2 Hrank1 Hrank2 Hwf vs1 vs2 Heq.
eapply (adt_interp_constructor_disjoint Hadt c1 c2 σs1 σs2 δ s
Hs Hδ Hc1 Hc2 Hrank1 Hrank2 Hwf
(Hiv c1 σs1 δ s Hs Hδ Hc1 Hrank1)
(Hiv c2 σs2 δ s Hs Hδ Hc2 Hrank2)).
exact Heq.
Qed.
No-confusion in the form a client of a tester wants: outside the range of
its own constructor a tester is false. Stated against adt_constructed
rather than adt_axioms, so it serves every reading of the domain
condition.
Theorem adt_interp_tester_false_off_constructor :
∀ Σ (A : structure)
(Ht : adt_tester_condition Σ A) (Hcon : adt_constructed Σ A)
c1 c2 σs1 σs2 δ s
(Hs : s ∈ Σ.(sort_symbols)) (Hδ : sort_top_symbol δ = Some s)
(Hc1 : c1 ∈ Σ.(constructors_for_sort) s)
(Hc2 : c2 ∈ Σ.(constructors_for_sort) s)
(Hrank1 : monomorphic_rank Σ c1 σs1 δ)
(Hrank2 : monomorphic_rank Σ c2 σs2 δ)
(Hwf : sort_wf Σ δ)
vs2,
c1 ≠ c2 →
cast A.(domain_σ_bool)
(A.(interp) (Σ.(tester_for_constructor) c1) [δ] σ_bool
(interp_apply A.(domain) (A.(interp) c2 σs2 δ) vs2)) = false.
Proof.
intros Σ A Ht Hcon c1 c2 σs1 σs2 δ s Hs Hδ Hc1 Hc2 Hrank1 Hrank2 Hwf vs2 Hne.
assert (Hc1' : c1 ∈ Σ.(constructors))
by (eapply Σ.(constructors_for_sort_wf); eassumption).
pose proof (Ht c1 σs1 δ Hc1' Hrank1) as Htest.
simpl in Htest.
set (v := interp_apply A.(domain) (A.(interp) c2 σs2 δ) vs2) in ×.
destruct (cast A.(domain_σ_bool)
(A.(interp) (Σ.(tester_for_constructor) c1) [δ] σ_bool v))
eqn:Hb.
- exfalso.
apply Htest in Hb.
destruct Hb as [vs1 Hvs1].
eapply (adt_constructed_disjoint Hcon) in Hvs1; eauto.
- reflexivity.
Qed.
Arguments adt_interp_tester_false_off_constructor {_} {_}.
∀ Σ (A : structure)
(Ht : adt_tester_condition Σ A) (Hcon : adt_constructed Σ A)
c1 c2 σs1 σs2 δ s
(Hs : s ∈ Σ.(sort_symbols)) (Hδ : sort_top_symbol δ = Some s)
(Hc1 : c1 ∈ Σ.(constructors_for_sort) s)
(Hc2 : c2 ∈ Σ.(constructors_for_sort) s)
(Hrank1 : monomorphic_rank Σ c1 σs1 δ)
(Hrank2 : monomorphic_rank Σ c2 σs2 δ)
(Hwf : sort_wf Σ δ)
vs2,
c1 ≠ c2 →
cast A.(domain_σ_bool)
(A.(interp) (Σ.(tester_for_constructor) c1) [δ] σ_bool
(interp_apply A.(domain) (A.(interp) c2 σs2 δ) vs2)) = false.
Proof.
intros Σ A Ht Hcon c1 c2 σs1 σs2 δ s Hs Hδ Hc1 Hc2 Hrank1 Hrank2 Hwf vs2 Hne.
assert (Hc1' : c1 ∈ Σ.(constructors))
by (eapply Σ.(constructors_for_sort_wf); eassumption).
pose proof (Ht c1 σs1 δ Hc1' Hrank1) as Htest.
simpl in Htest.
set (v := interp_apply A.(domain) (A.(interp) c2 σs2 δ) vs2) in ×.
destruct (cast A.(domain_σ_bool)
(A.(interp) (Σ.(tester_for_constructor) c1) [δ] σ_bool v))
eqn:Hb.
- exfalso.
apply Htest in Hb.
destruct Hb as [vs1 Hvs1].
eapply (adt_constructed_disjoint Hcon) in Hvs1; eauto.
- reflexivity.
Qed.
Arguments adt_interp_tester_false_off_constructor {_} {_}.
Theories
Record pretheory :=
{
pΣ : signature;
pmodels : structure → Prop;
}.
Record pretheories_composable (pT1 : pretheory) (pT2 : pretheory) : Prop :=
{
ptc_signatures_composable : signatures_composable pT1.(pΣ) pT2.(pΣ);
}.
Arguments ptc_signatures_composable {_} {_}.
Definition pretheory_compose
(pT1 : pretheory) (pT2 : pretheory)
(C : pretheories_composable pT1 pT2) : pretheory :=
{|
pΣ := pT1.(pΣ) ⊕[ C.(ptc_signatures_composable) ] pT2.(pΣ);
pmodels A :=
pT1.(pmodels) A ∧ pT2.(pmodels) A;
|}.
#[global] Instance pretheory_compose_compose :
Compose pretheory pretheories_composable := pretheory_compose.
Definition pretheory_add_sorts (pT : pretheory) (sorts' : sorting) : pretheory :=
{|
pΣ := sorts' ⊍ pT.(pΣ);
pmodels A := pT.(pmodels) A;
|}.
Record theory :=
{
Σ : signature;
models : structure → Prop;
}.
Closing with the standard's reading of Definition 8: a datatype domain is
the well-sorted ground terms, in which a datatype sort occurs as a
constructor's argument sort and never below another sort constructor.
Definition theory_init (pT : pretheory) : theory :=
{|
Σ := pT.(pΣ);
models A := pT.(pmodels) A ∧ adt_axioms (Σ := pT.(pΣ)) A;
|}.
{|
Σ := pT.(pΣ);
models A := pT.(pmodels) A ∧ adt_axioms (Σ := pT.(pΣ)) A;
|}.
Model Construction
- construct a domain meeting every component's requirements;
- take each component's pretheory_interpretable at that domain and combine them with pretheory_compose_interpretable;
- discharge the datatype condition at the finished signature, which no component owes — see theory_init.
Definition structure_of (D : sort → Type)
(Hbool : D σ_bool = bool)
(Hmap : ∀ σ1 σ2, D (τ_map σ1 σ2) = (D σ1 → D σ2))
(ι : ∀ f (σs : list sort) (σ : sort), interpretation D σs σ)
: structure :=
{|
domain := D;
domain_σ_bool := Hbool;
domain_σ_map := Hmap;
interp := ι;
|}.
(Hbool : D σ_bool = bool)
(Hmap : ∀ σ1 σ2, D (τ_map σ1 σ2) = (D σ1 → D σ2))
(ι : ∀ f (σs : list sort) (σ : sort), interpretation D σs σ)
: structure :=
{|
domain := D;
domain_σ_bool := Hbool;
domain_σ_map := Hmap;
interp := ι;
|}.
ι1 and ι2 give the same value at every rank of every symbol in
fs.
Definition interp_agree_on (D : sort → Type) (fs : func → Prop)
(ι1 ι2 : ∀ f (σs : list sort) (σ : sort), interpretation D σs σ) : Prop :=
∀ f, fs f → ∀ σs σ, ι1 f σs σ = ι2 f σs σ.
(ι1 ι2 : ∀ f (σs : list sort) (σ : sort), interpretation D σs σ) : Prop :=
∀ f, fs f → ∀ σs σ, ι1 f σs σ = ι2 f σs σ.
Building an Interpretation
Ignore the arguments and return the domain's witness.
Fixpoint interp_const (witness : ∀ σ, D σ) (σs : list sort) (σ : sort)
: interpretation D σs σ :=
match σs with
| [] ⇒ witness σ
| _ :: σs' ⇒ fun _ ⇒ interp_const witness σs' σ
end.
: interpretation D σs σ :=
match σs with
| [] ⇒ witness σ
| _ :: σs' ⇒ fun _ ⇒ interp_const witness σs' σ
end.
Override base at one rank, in the shape of stdpp's fn_insert: key,
value, function.
Definition interp_insert_rank (σs : list sort) (σ : sort)
(v : interpretation D σs σ)
(base : ∀ σs σ, interpretation D σs σ)
: ∀ σs' σ', interpretation D σs' σ' :=
fun σs' σ' ⇒
match decide ((σs', σ') = (σs, σ)) with
| left H ⇒
@eq_rect_r (list sort × sort) (σs, σ)
(fun p : list sort × sort ⇒ interpretation D (fst p) (snd p))
v (σs', σ') H
| right _ ⇒ base σs' σ'
end.
Lemma interp_insert_rank_eq : ∀ σs σ v base,
interp_insert_rank σs σ v base σs σ = v.
Proof.
intros σs σ v base. unfold interp_insert_rank.
destruct (decide ((σs, σ) = (σs, σ))) as [Heq | Hne];
[| exfalso; by apply Hne].
by rewrite (Eqdep_dec.UIP_dec (fun x y ⇒ decide (x = y)) Heq eq_refl).
Qed.
Lemma interp_insert_rank_ne : ∀ σs σ v base σs' σ',
(σs', σ') ≠ (σs, σ) →
interp_insert_rank σs σ v base σs' σ' = base σs' σ'.
Proof.
intros σs σ v base σs' σ' Hne. unfold interp_insert_rank.
by destruct (decide ((σs', σ') = (σs, σ))).
Qed.
(v : interpretation D σs σ)
(base : ∀ σs σ, interpretation D σs σ)
: ∀ σs' σ', interpretation D σs' σ' :=
fun σs' σ' ⇒
match decide ((σs', σ') = (σs, σ)) with
| left H ⇒
@eq_rect_r (list sort × sort) (σs, σ)
(fun p : list sort × sort ⇒ interpretation D (fst p) (snd p))
v (σs', σ') H
| right _ ⇒ base σs' σ'
end.
Lemma interp_insert_rank_eq : ∀ σs σ v base,
interp_insert_rank σs σ v base σs σ = v.
Proof.
intros σs σ v base. unfold interp_insert_rank.
destruct (decide ((σs, σ) = (σs, σ))) as [Heq | Hne];
[| exfalso; by apply Hne].
by rewrite (Eqdep_dec.UIP_dec (fun x y ⇒ decide (x = y)) Heq eq_refl).
Qed.
Lemma interp_insert_rank_ne : ∀ σs σ v base σs' σ',
(σs', σ') ≠ (σs, σ) →
interp_insert_rank σs σ v base σs' σ' = base σs' σ'.
Proof.
intros σs σ v base σs' σ' Hne. unfold interp_insert_rank.
by destruct (decide ((σs', σ') = (σs, σ))).
Qed.
Override base at one function symbol, at every rank.
Definition interp_insert_func (f : func)
(v : ∀ σs σ, interpretation D σs σ)
(base : ∀ f σs σ, interpretation D σs σ)
: ∀ f' σs σ, interpretation D σs σ :=
fun f' σs σ ⇒ if decide (f' = f) then v σs σ else base f' σs σ.
Lemma interp_insert_func_eq : ∀ f v base σs σ,
interp_insert_func f v base f σs σ = v σs σ.
Proof.
intros f v base σs σ. unfold interp_insert_func.
by rewrite decide_True by reflexivity.
Qed.
Lemma interp_insert_func_ne : ∀ f v base f' σs σ,
f' ≠ f → interp_insert_func f v base f' σs σ = base f' σs σ.
Proof.
intros f v base f' σs σ Hne. unfold interp_insert_func.
by rewrite decide_False.
Qed.
End BuildInterp.
(v : ∀ σs σ, interpretation D σs σ)
(base : ∀ f σs σ, interpretation D σs σ)
: ∀ f' σs σ, interpretation D σs σ :=
fun f' σs σ ⇒ if decide (f' = f) then v σs σ else base f' σs σ.
Lemma interp_insert_func_eq : ∀ f v base σs σ,
interp_insert_func f v base f σs σ = v σs σ.
Proof.
intros f v base σs σ. unfold interp_insert_func.
by rewrite decide_True by reflexivity.
Qed.
Lemma interp_insert_func_ne : ∀ f v base f' σs σ,
f' ≠ f → interp_insert_func f v base f' σs σ = base f' σs σ.
Proof.
intros f v base f' σs σ Hne. unfold interp_insert_func.
by rewrite decide_False.
Qed.
End BuildInterp.
pT's model conditions depend on the domain and on the symbols pT
declares, and on nothing else — so interpreting another component's
symbols leaves them standing. A component proves this of its own
conditions; it is immediate when each condition names a single symbol.
Definition pretheory_local (pT : pretheory) : Prop :=
∀ D Hbool Hmap ι1 ι2,
interp_agree_on D pT.(pΣ).(funcs) ι1 ι2 →
pT.(pmodels) (structure_of D Hbool Hmap ι1) →
pT.(pmodels) (structure_of D Hbool Hmap ι2).
∀ D Hbool Hmap ι1 ι2,
interp_agree_on D pT.(pΣ).(funcs) ι1 ι2 →
pT.(pmodels) (structure_of D Hbool Hmap ι1) →
pT.(pmodels) (structure_of D Hbool Hmap ι2).
pT's symbols can be interpreted over the domain D. Whatever pT
requires of D is a premise of the component's own theorem rather than
part of this predicate, so that a composition can be stated over one
domain.
Definition pretheory_interpretable (pT : pretheory) (D : sort → Type)
(Hbool : D σ_bool = bool)
(Hmap : ∀ σ1 σ2, D (τ_map σ1 σ2) = (D σ1 → D σ2)) : Prop :=
∃ ι, pT.(pmodels) (structure_of D Hbool Hmap ι).
(Hbool : D σ_bool = bool)
(Hmap : ∀ σ1 σ2, D (τ_map σ1 σ2) = (D σ1 → D σ2)) : Prop :=
∃ ι, pT.(pmodels) (structure_of D Hbool Hmap ι).
The composite declares the union of the two symbol sets, so agreeing on
them is agreeing on each.
Theorem pretheory_compose_local :
∀ pT1 pT2 (C : pretheories_composable pT1 pT2),
pretheory_local pT1 →
pretheory_local pT2 →
pretheory_local (pT1 ⊕[ C ] pT2).
Proof.
intros pT1 pT2 C Hloc1 Hloc2 D Hbool Hmap ι1 ι2 Hagree [Hm1 Hm2].
split.
- eapply Hloc1; [| exact Hm1].
intros f Hf. apply Hagree. left. exact Hf.
- eapply Hloc2; [| exact Hm2].
intros f Hf. apply Hagree. right. exact Hf.
Qed.
∀ pT1 pT2 (C : pretheories_composable pT1 pT2),
pretheory_local pT1 →
pretheory_local pT2 →
pretheory_local (pT1 ⊕[ C ] pT2).
Proof.
intros pT1 pT2 C Hloc1 Hloc2 D Hbool Hmap ι1 ι2 Hagree [Hm1 Hm2].
split.
- eapply Hloc1; [| exact Hm1].
intros f Hf. apply Hagree. left. exact Hf.
- eapply Hloc2; [| exact Hm2].
intros f Hf. apply Hagree. right. exact Hf.
Qed.
Interpret each symbol by the component that declares it.
The two components must declare disjoint symbols.
signatures_composable makes the signatures agree where they overlap — on
arities, on constructors_for_sort, and on the ranks of shared
constructors — but it still admits a shared function symbol, which the two
model predicates may pin to different values. Where components do share a
symbol, this needs a different argument: that their conditions on it
agree.
Theorem pretheory_compose_interpretable :
∀ pT1 pT2 (C : pretheories_composable pT1 pT2) D Hbool Hmap,
pretheory_local pT1 →
pretheory_local pT2 →
(∀ f, pT1.(pΣ).(funcs) f → pT2.(pΣ).(funcs) f → False) →
pretheory_interpretable pT1 D Hbool Hmap →
pretheory_interpretable pT2 D Hbool Hmap →
pretheory_interpretable (pT1 ⊕[ C ] pT2) D Hbool Hmap.
Proof.
intros pT1 pT2 C D Hbool Hmap Hloc1 Hloc2 Hdisj [ι1 Hm1] [ι2 Hm2].
∃ (fun f σs σ ⇒
match decide (pT1.(pΣ).(funcs) f) with
| left _ ⇒ ι1 f σs σ
| right _ ⇒ ι2 f σs σ
end).
split.
- eapply Hloc1; [| exact Hm1].
intros f Hf σs σ. destruct (decide _); [reflexivity |].
contradiction.
- eapply Hloc2; [| exact Hm2].
intros f Hf σs σ. destruct (decide _) as [Hf1 |];
[| reflexivity].
exfalso. eapply Hdisj; eassumption.
Qed.
∀ pT1 pT2 (C : pretheories_composable pT1 pT2) D Hbool Hmap,
pretheory_local pT1 →
pretheory_local pT2 →
(∀ f, pT1.(pΣ).(funcs) f → pT2.(pΣ).(funcs) f → False) →
pretheory_interpretable pT1 D Hbool Hmap →
pretheory_interpretable pT2 D Hbool Hmap →
pretheory_interpretable (pT1 ⊕[ C ] pT2) D Hbool Hmap.
Proof.
intros pT1 pT2 C D Hbool Hmap Hloc1 Hloc2 Hdisj [ι1 Hm1] [ι2 Hm2].
∃ (fun f σs σ ⇒
match decide (pT1.(pΣ).(funcs) f) with
| left _ ⇒ ι1 f σs σ
| right _ ⇒ ι2 f σs σ
end).
split.
- eapply Hloc1; [| exact Hm1].
intros f Hf σs σ. destruct (decide _); [reflexivity |].
contradiction.
- eapply Hloc2; [| exact Hm2].
intros f Hf σs σ. destruct (decide _) as [Hf1 |];
[| reflexivity].
exfalso. eapply Hdisj; eassumption.
Qed.
pretheory_add_sorts changes neither the declared symbols nor the model
predicate, so both properties survive it.
Theorem pretheory_add_sorts_local :
∀ pT sorts',
pretheory_local pT →
pretheory_local (pretheory_add_sorts pT sorts').
Proof.
intros pT sorts' Hloc D Hbool Hmap ι1 ι2 Hagree Hm. eapply Hloc; eauto.
Qed.
Theorem pretheory_add_sorts_interpretable :
∀ pT sorts' D Hbool Hmap,
pretheory_interpretable pT D Hbool Hmap →
pretheory_interpretable (pretheory_add_sorts pT sorts') D Hbool Hmap.
Proof.
intros pT sorts' D Hbool Hmap [ι Hm]. ∃ ι. exact Hm.
Qed.
∀ pT sorts',
pretheory_local pT →
pretheory_local (pretheory_add_sorts pT sorts').
Proof.
intros pT sorts' Hloc D Hbool Hmap ι1 ι2 Hagree Hm. eapply Hloc; eauto.
Qed.
Theorem pretheory_add_sorts_interpretable :
∀ pT sorts' D Hbool Hmap,
pretheory_interpretable pT D Hbool Hmap →
pretheory_interpretable (pretheory_add_sorts pT sorts') D Hbool Hmap.
Proof.
intros pT sorts' D Hbool Hmap [ι Hm]. ∃ ι. exact Hm.
Qed.