MathClasses.interfaces.universal_algebra
Require
theory.setoids ne_list.
Require Import
List
abstract_algebra util jections.
Require Export
ua_basic.
Section for_signature.
Variable σ: Signature.
Notation OpType := (OpType (sorts σ)).
Inductive Term (V: Type): OpType → Type :=
| Var: V → ∀ a, Term V (ne_list.one a)
| App t y: Term V (ne_list.cons y t) → Term V (ne_list.one y) → Term V t
| Op o: Term V (σ o).
Arguments Var {V} _ _.
Fixpoint map_var `(f: V → W) `(t: Term V o): Term W o :=
match t in Term _ o return Term W o with
| Var v s ⇒ Var (f v) s
| App _ _ x y ⇒ App _ _ _ (map_var f x) (map_var f y)
| Op s ⇒ Op _ s
end.
Definition Term0 v sort := Term v (ne_list.one sort).
Section applications_ind.
Context V (P: ∀ {a}, Term0 V a → Type).
Arguments P {a} _.
Fixpoint applications {ot}: Term V ot → Type :=
match ot with
| ne_list.one x ⇒ @P x
| ne_list.cons x y ⇒ λ z, ∀ v, P v → applications (App V _ _ z v)
end.
Lemma applications_rect:
(∀ v a, P (Var v a)) →
(∀ o, applications (Op _ o)) →
(∀ a (t: Term0 V a), P t).
Proof.
intros X0 X1 ??.
cut (applications t).
intros. assumption.
induction t; simpl.
apply X0.
apply IHt1; exact IHt2.
apply X1.
Defined.
End applications_ind.
Definition T := Term nat.
Definition T0 := Term0 nat.
Definition Identity t := prod (T t) (T t).
Definition Identity0 sort := Identity (ne_list.one sort).
Definition mkIdentity0 {sort}: T (ne_list.one sort) → T (ne_list.one sort) → Identity0 sort := pair.
Record Entailment (P: Type): Type := { entailment_premises: list P; entailment_conclusion: P }.
Definition EqEntailment := Entailment (sigT Identity0).
Inductive Statement: Type :=
| Eq t (i: Identity t)
| Impl (a b: Statement)
| Conj (a b: Statement)
| Disj (a b: Statement)
| Ext (P: Prop).
Definition identity_as_eq (s: sigT Identity0): Statement := Eq _ (projT2 s).
Coercion identity_as_entailment sort (e: Identity0 sort): EqEntailment := Build_Entailment _ nil (existT _ _ e).
Coercion entailment_as_statement (e: EqEntailment): Statement :=
(fold_right Impl (identity_as_eq (entailment_conclusion _ e)) (map identity_as_eq (entailment_premises _ e))).
Definition entailment_as_conjunctive_statement (e: EqEntailment): Statement :=
Impl (fold_right Conj (Ext True) (map identity_as_eq (entailment_premises _ e)))
(identity_as_eq (entailment_conclusion _ e)).
Section Vars.
Context (A: sorts σ → Type) (V: Type) `{e: ∀ a, Equiv (A a)} `{∀ a, Equivalence (e a)}.
Definition Vars := ∀ a, V → A a.
Global Instance ua_vars_equiv: Equiv Vars :=
@pointwise_dependent_relation (sorts σ) (λ a, V → A a)
(λ _, pointwise_relation _ (=)).
Global Instance: Equivalence ((=): relation Vars) := {}.
End Vars.
Definition no_vars x: Vars x False := λ _, False_rect _.
Fixpoint close {V} {o} (v: Vars (λ x, Term False (ne_list.one x)) V) (t: Term V o): Term False o :=
match t in Term _ o return Term False o with
| Var x y ⇒ v y x
| App x y z r ⇒ App _ x y (close v z) (close v r)
| Op o ⇒ Op _ o
end.
Section eval.
Context `{Algebra σ A}.
Fixpoint eval {V} {n: OpType} (vars: Vars A V) (t: Term V n) {struct t}: op_type A n :=
match t with
| Var v a ⇒ vars a v
| Op o ⇒ algebra_op o
| App n a f p ⇒ eval vars f (eval vars p)
end.
Global Instance eval_proper {V} (n: OpType):
Proper ((=) ==> eq ==> (=)) (@eval V n).
Proof with auto.
intros x y E a _ [].
induction a.
apply E...
apply IHa1...
simpl.
apply algebra_propers.
Qed.
Global Instance eval_strong_proper {V} (n: OpType):
Proper ((pointwise_dependent_relation (sorts σ) _
(λ _, pointwise_relation V eq)) ==> eq ==> eq) (@eval V n).
Proof with auto.
intros x y E a _ [].
unfold pointwise_dependent_relation in E.
unfold pointwise_relation in E.
induction a; simpl.
apply E...
congruence.
reflexivity.
Qed.
Hint Extern 4 (Equiv (Term _ _)) ⇒ exact eq: typeclass_instances.
Hint Extern 4 (Equiv (Term0 _ _)) ⇒ exact eq: typeclass_instances.
Instance: ∀ V n v, Setoid_Morphism (@eval V (ne_list.one n) v).
Proof.
constructor; try apply _.
unfold Setoid. apply _.
destruct H0. apply _.
Qed.
Fixpoint app_tree {V} {o}: Term V o → op_type (Term0 V) o :=
match o with
| ne_list.one _ ⇒ id
| ne_list.cons _ _ ⇒ λ x y, app_tree (App _ _ _ x y)
end.
Lemma eval_map_var `(f: V → W) v s (t: Term V s):
eval v (map_var f t) ≡ eval (λ s, v s ∘ f) t.
Proof.
induction t; simpl.
reflexivity.
congruence.
reflexivity.
Qed.
Definition eval_stmt (vars: Vars A nat): Statement → Prop :=
fix F (s: Statement) :=
match s with
| Eq _ i ⇒ eval vars (fst i) = eval vars (snd i)
| Impl a b ⇒ F a → F b
| Ext P ⇒ P
| Conj a b ⇒ F a ∧ F b
| Disj a b ⇒ F a ∨ F b
end.
Global Instance eval_stmt_proper: Proper ((=) ==> eq ==> iff) eval_stmt.
Proof with auto.
intros v v' ve s s' se. subst.
induction s'; simpl; try solve [intuition].
split; intros E.
transitivity (eval v (fst i)).
apply eval_proper... symmetry...
transitivity (eval v (snd i))...
apply eval_proper...
transitivity (eval v' (fst i)).
apply eval_proper...
rewrite E.
apply eval_proper...
Qed.
Definition boring_eval_entailment (vars: Vars A nat) (ee: EqEntailment):
eval_stmt vars ee ↔ eval_stmt vars (entailment_as_conjunctive_statement ee).
Proof. destruct ee. simpl. induction entailment_premises0; simpl; intuition. Qed.
End eval.
End for_signature.
Remove Hints ua_vars_equiv : typeclass_instances.
Hint Extern 0 (Equiv (Vars _ _ _)) ⇒ eapply @ua_vars_equiv : typeclass_instances.
Record EquationalTheory :=
{ et_sig:> Signature
; et_laws:> EqEntailment et_sig → Prop }.
Class InVariety
(et: EquationalTheory)
(carriers: sorts et → Type)
{e: ∀ a, Equiv (carriers a)}
`{!AlgebraOps et carriers}: Prop :=
{ variety_algebra:> Algebra et carriers
; variety_laws: ∀ s, et_laws et s → ∀ vars, eval_stmt et vars s }.
Module op_type_notations.
Global Infix "-=>" := (ne_list.cons) (at level 95, right associativity).
End op_type_notations.
Module notations.
Global Infix "===" := (mkIdentity0 _) (at level 70, no associativity).
Global Infix "-=>" := (Impl _) (at level 95, right associativity).
End notations.
theory.setoids ne_list.
Require Import
List
abstract_algebra util jections.
Require Export
ua_basic.
Section for_signature.
Variable σ: Signature.
Notation OpType := (OpType (sorts σ)).
Inductive Term (V: Type): OpType → Type :=
| Var: V → ∀ a, Term V (ne_list.one a)
| App t y: Term V (ne_list.cons y t) → Term V (ne_list.one y) → Term V t
| Op o: Term V (σ o).
Arguments Var {V} _ _.
Fixpoint map_var `(f: V → W) `(t: Term V o): Term W o :=
match t in Term _ o return Term W o with
| Var v s ⇒ Var (f v) s
| App _ _ x y ⇒ App _ _ _ (map_var f x) (map_var f y)
| Op s ⇒ Op _ s
end.
Definition Term0 v sort := Term v (ne_list.one sort).
Section applications_ind.
Context V (P: ∀ {a}, Term0 V a → Type).
Arguments P {a} _.
Fixpoint applications {ot}: Term V ot → Type :=
match ot with
| ne_list.one x ⇒ @P x
| ne_list.cons x y ⇒ λ z, ∀ v, P v → applications (App V _ _ z v)
end.
Lemma applications_rect:
(∀ v a, P (Var v a)) →
(∀ o, applications (Op _ o)) →
(∀ a (t: Term0 V a), P t).
Proof.
intros X0 X1 ??.
cut (applications t).
intros. assumption.
induction t; simpl.
apply X0.
apply IHt1; exact IHt2.
apply X1.
Defined.
End applications_ind.
Definition T := Term nat.
Definition T0 := Term0 nat.
Definition Identity t := prod (T t) (T t).
Definition Identity0 sort := Identity (ne_list.one sort).
Definition mkIdentity0 {sort}: T (ne_list.one sort) → T (ne_list.one sort) → Identity0 sort := pair.
Record Entailment (P: Type): Type := { entailment_premises: list P; entailment_conclusion: P }.
Definition EqEntailment := Entailment (sigT Identity0).
Inductive Statement: Type :=
| Eq t (i: Identity t)
| Impl (a b: Statement)
| Conj (a b: Statement)
| Disj (a b: Statement)
| Ext (P: Prop).
Definition identity_as_eq (s: sigT Identity0): Statement := Eq _ (projT2 s).
Coercion identity_as_entailment sort (e: Identity0 sort): EqEntailment := Build_Entailment _ nil (existT _ _ e).
Coercion entailment_as_statement (e: EqEntailment): Statement :=
(fold_right Impl (identity_as_eq (entailment_conclusion _ e)) (map identity_as_eq (entailment_premises _ e))).
Definition entailment_as_conjunctive_statement (e: EqEntailment): Statement :=
Impl (fold_right Conj (Ext True) (map identity_as_eq (entailment_premises _ e)))
(identity_as_eq (entailment_conclusion _ e)).
Section Vars.
Context (A: sorts σ → Type) (V: Type) `{e: ∀ a, Equiv (A a)} `{∀ a, Equivalence (e a)}.
Definition Vars := ∀ a, V → A a.
Global Instance ua_vars_equiv: Equiv Vars :=
@pointwise_dependent_relation (sorts σ) (λ a, V → A a)
(λ _, pointwise_relation _ (=)).
Global Instance: Equivalence ((=): relation Vars) := {}.
End Vars.
Definition no_vars x: Vars x False := λ _, False_rect _.
Fixpoint close {V} {o} (v: Vars (λ x, Term False (ne_list.one x)) V) (t: Term V o): Term False o :=
match t in Term _ o return Term False o with
| Var x y ⇒ v y x
| App x y z r ⇒ App _ x y (close v z) (close v r)
| Op o ⇒ Op _ o
end.
Section eval.
Context `{Algebra σ A}.
Fixpoint eval {V} {n: OpType} (vars: Vars A V) (t: Term V n) {struct t}: op_type A n :=
match t with
| Var v a ⇒ vars a v
| Op o ⇒ algebra_op o
| App n a f p ⇒ eval vars f (eval vars p)
end.
Global Instance eval_proper {V} (n: OpType):
Proper ((=) ==> eq ==> (=)) (@eval V n).
Proof with auto.
intros x y E a _ [].
induction a.
apply E...
apply IHa1...
simpl.
apply algebra_propers.
Qed.
Global Instance eval_strong_proper {V} (n: OpType):
Proper ((pointwise_dependent_relation (sorts σ) _
(λ _, pointwise_relation V eq)) ==> eq ==> eq) (@eval V n).
Proof with auto.
intros x y E a _ [].
unfold pointwise_dependent_relation in E.
unfold pointwise_relation in E.
induction a; simpl.
apply E...
congruence.
reflexivity.
Qed.
Hint Extern 4 (Equiv (Term _ _)) ⇒ exact eq: typeclass_instances.
Hint Extern 4 (Equiv (Term0 _ _)) ⇒ exact eq: typeclass_instances.
Instance: ∀ V n v, Setoid_Morphism (@eval V (ne_list.one n) v).
Proof.
constructor; try apply _.
unfold Setoid. apply _.
destruct H0. apply _.
Qed.
Fixpoint app_tree {V} {o}: Term V o → op_type (Term0 V) o :=
match o with
| ne_list.one _ ⇒ id
| ne_list.cons _ _ ⇒ λ x y, app_tree (App _ _ _ x y)
end.
Lemma eval_map_var `(f: V → W) v s (t: Term V s):
eval v (map_var f t) ≡ eval (λ s, v s ∘ f) t.
Proof.
induction t; simpl.
reflexivity.
congruence.
reflexivity.
Qed.
Definition eval_stmt (vars: Vars A nat): Statement → Prop :=
fix F (s: Statement) :=
match s with
| Eq _ i ⇒ eval vars (fst i) = eval vars (snd i)
| Impl a b ⇒ F a → F b
| Ext P ⇒ P
| Conj a b ⇒ F a ∧ F b
| Disj a b ⇒ F a ∨ F b
end.
Global Instance eval_stmt_proper: Proper ((=) ==> eq ==> iff) eval_stmt.
Proof with auto.
intros v v' ve s s' se. subst.
induction s'; simpl; try solve [intuition].
split; intros E.
transitivity (eval v (fst i)).
apply eval_proper... symmetry...
transitivity (eval v (snd i))...
apply eval_proper...
transitivity (eval v' (fst i)).
apply eval_proper...
rewrite E.
apply eval_proper...
Qed.
Definition boring_eval_entailment (vars: Vars A nat) (ee: EqEntailment):
eval_stmt vars ee ↔ eval_stmt vars (entailment_as_conjunctive_statement ee).
Proof. destruct ee. simpl. induction entailment_premises0; simpl; intuition. Qed.
End eval.
End for_signature.
Remove Hints ua_vars_equiv : typeclass_instances.
Hint Extern 0 (Equiv (Vars _ _ _)) ⇒ eapply @ua_vars_equiv : typeclass_instances.
Record EquationalTheory :=
{ et_sig:> Signature
; et_laws:> EqEntailment et_sig → Prop }.
Class InVariety
(et: EquationalTheory)
(carriers: sorts et → Type)
{e: ∀ a, Equiv (carriers a)}
`{!AlgebraOps et carriers}: Prop :=
{ variety_algebra:> Algebra et carriers
; variety_laws: ∀ s, et_laws et s → ∀ vars, eval_stmt et vars s }.
Module op_type_notations.
Global Infix "-=>" := (ne_list.cons) (at level 95, right associativity).
End op_type_notations.
Module notations.
Global Infix "===" := (mkIdentity0 _) (at level 70, no associativity).
Global Infix "-=>" := (Impl _) (at level 95, right associativity).
End notations.