Section STRONG_COLLECTION.
(* << A Sketch of the Proof of Strong Collection >> -- Advice of "Hanul Jeon" > Aczel의 Strong Collection의 증명을 스케치해보면, > 우선 forall x:X, exists y, phi(x,y)가 성립한다고 합시다. > 여기서 AC를 적용해서 forall x:X, phi(x,f(x))인 f를 찾고, > base set을 X의 base와 똑같이 잡을 겁니다. > 그리고 원소는 f(x)에 대응하게끔 잡을 거고요. > 문제는 AC가 Coq에서 작동할 것 같지 않다는 거네요. *)
Hypothesis AC : forall A : Type, forall B : Type, forall P : A -> B -> Prop, (forall x, exists y, P x y) -> (exists f, forall x, P x (f x)).
Proof with eauto with *.
intros X NONEMPTY. set (base_set := children X).
assert (claim : exists f : base_set -> Tree, forall x : base_set, P (childnodes X x) (f x)).
{ eapply AC with (P := fun x : base_set => fun y : Tree => P (childnodes X x) y)... }
destruct claim as [f claim]. exists (mkNode base_set (fun x => f x)). split.
- intros x [c EQ]. exists (f c). split... eapply COMPAT1...
- intros x [c EQ]. exists (childnodes X c). split... eapply COMPAT2...
Qed.
End STRONG_COLLECTION.
Inductive rLt (lhs : Tree) (rhs : Tree) : Prop :=
| rLt_intro c
(H_rLe : lhs ≦ᵣ childnodes rhs c)
: lhs <ᵣ rhs
where "lhs <ᵣ rhs" := (rLt lhs rhs) : type_scope
with rLe (lhs : Tree) (rhs : Tree) : Prop :=
| rLe_intro
(H_rLt : forall c, childnodes lhs c <ᵣ rhs)
: lhs ≦ᵣ rhs
where "lhs ≦ᵣ rhs" := (rLe lhs rhs) : type_scope.
#[global] Hint Constructors rLt rLe : aczel_hints.
Fixpoint rLt_inv x y (H_rLt : y <ᵣ x) {struct H_rLt}
: exists c1 : children x, forall c2 : children y, childnodes y c2 <ᵣ childnodes x c1
with rLe_inv x y (H_rLe : x ≦ᵣ y) {struct H_rLe}
: forall c1 : children x, exists c2 : children y, childnodes x c1 ≦ᵣ childnodes y c2.
#[global]
Instance rLe_PreOrder : PreOrder rLe :=
{ PreOrder_Reflexive := rLe_refl
; PreOrder_Transitive := rLe_trans
}.
Definition rEq_asSetoid : isSetoid Tree :=
mkSetoidFromPreOrder rLe_PreOrder.
Definition rEq (lhs : Tree) (rhs : Tree) : Prop :=
rEq_asSetoid.(eqProp) lhs rhs.
Infix "=ᵣ" := rEq (at level 70, no associativity) : type_scope.
#[global] Hint Resolve rLe_eqTree_rLe eqTree_rLe_rLe : aczel_hints.
#[global]
Add Parametric Morphism
: rLe with signature (eqProp ==> eqProp ==> iff)
as rLe_compatWith_eqProp.
#[global]
Add Parametric Morphism
: rEq with signature (eqProp ==> eqProp ==> iff)
as rEq_compatWith_eqProp.
#[global]
Add Parametric Morphism
: rLt with signature (eqProp ==> eqProp ==> iff)
as rLt_compatWith_eqProp.
#[global] Hint Resolve rLt_implies_rLe member_implies_rLt : aczel_hints.
#[local] Hint Resolve rLe_rLt_rLt rLt_rLe_rLt : core.
#[global]
Add Parametric Morphism
: rLt with signature (eqProp ==> eqProp ==> iff) as rLt_compatWith_eq.
#[global]
Instance rLt_StrictOrder
: StrictOrder rLt.
Fixpoint fromAcc {A : Type@{Set_u}} {R : A -> A -> Prop} (x : A) (ACC : Acc R x) {struct ACC} : Tree :=
match ACC with
| Acc_intro _ ACC_INV => mkNode { y : A | R y x } (fun c => @fromAcc A R (proj1_sig c) (ACC_INV (proj1_sig c) (proj2_sig c)))
end.
#[global] Hint Rewrite fromAcc_unfold : simplication_hints.
Fixpoint fromAcc_pirrel (A : Type@{Set_u}) (R : A -> A -> Prop) (x : A) (ACC : Acc R x) (ACC' : Acc R x) {struct ACC}
: fromAcc x ACC == fromAcc x ACC'.
Definition fromWf {A : Type@{Set_u}} (R : A -> A -> Prop) (Wf : well_founded R) : Tree :=
mkNode A (fun x => @fromAcc A R x (Wf x)).
Definition succ (x : Tree) : Tree :=
union x (singlton x).
#[global] Hint Rewrite succ_spec : simplication_hints.
#[global]
Instance succ_eqPropCompatible1
: eqPropCompatible1 succ.
Definition isTransitiveSet (x : Tree) : Prop :=
forall y, y \in x -> forall z, z \in y -> z \in x.
#[global] Hint Unfold isTransitiveSet : aczel_hints.

Lemma isTransitiveSet_compatWith_eqTree
: isCompatibleWith_eqProp isTransitiveSet.