(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(***************************************************)
(** * The intuitionistic Hilbert epsilon operator  *)
(***************************************************)
(** The following axioms mimick (a specialized version of) the intuitionistic Hilbert epsilon operator described in the author's LICS'03 submitted paper. *)
(** We first introduce a type of codes, that could be defined as a primitive type of natural numbers by following the paper.  But since the actual structure of its inhabitants will never be used in the forthcoming proofs, we prefer to keep it abstract. *)
(** The following axiom states that if a predicate P : Typ1->Prop holds for some type X : Typ1, then there exists a code c : Code such that P holds for (eps P c).  Technically, this axiom shows that we can always replace an existential statement over a large type (i.e. Typ1) by an existential statement over a small type (i.e. Code), which is crucial for interpreting the collection scheme. *)
Axiom
choice : forall P : Typ1 -> Prop, exT P -> ex Code (fun c => P (eps P c)).
(*********************************************)
(** * An implementation of a super-powerset  *)
(*********************************************)
(** On a fixed small type Z, we can build several pointed graphs of the form (Z, A, a), whose two extra parameters A and a range over (Rel Z) and Z respectively.  But since the cartesian product (Rel Z) * Z is itself a small type, it is not difficult to build a variant of the powerset (foo, FOO, foo_rt) that contains all the pointed graphs of the form (Z, A, a), that is, a pointed graph (called the "super-powerset" of Z) such that  (Z, A, a) \in (foo, FOO, foo_rt)  for any edge relation A : (Rel A) and for any root a : Z.  In what follows, we propose to achieve this construction, but in a more general setting.  For that, instead of considering a small type Z : Typ1, we will rather consider a family of small types Z : X->Y->Typ1 indexed by the inhabitants of two given small types X, Y : Typ1, and from these parameters, we propose to build a pointed graph ((foo X Y Z), (FOO X Y Z), (foo_rt X Y Z)) such that  ((Z x y), A, a) \in ((foo X Y Z), (FOO X Y Z), (foo_rt X Y Z))  for any x : X, y : Y, A : (Rel (Z x y)) and a : (Z x y). Intuitively, this pointed graph represents the union of the super-powersets associated to the carriers (Z x y) when x and y range over the small types X and Y respectively. *)
(** ** Building the carrier of the super-powerset **)
(** The carrier (foo X Y Z) of the super-powerset associated to a given family of small types Z : X->Y->Typ1 indexed by two small types X and Y would be naturally defined in Coq as follows:  Inductive foo [X,Y:Typ1; Z:X->Y->Typ1] : Typ1 := | foo_in : (x:X; y:Y)(Rel (Z x y))->(Z x y)->(foo X Y Z) | foo_rt : (foo X Y Z).  Intuitively, this type is the disjoint union of the cartesian products (Rel (Z x y)) * (Z x y) where x and y range over X and Y respectively, plus an extra element (foo_rt X Y Z) that will be used as the new root.  In our framework, this inductive definition is easily mimicked as follows: *)
Definition foo (X Y : Typ1) (Z : X -> Y -> Typ1) : Typ1 :=
(forall (x : X) (y : Y), Rel (Z x y) -> Z x y -> Prop) -> Prop.
Definition foo_in (X Y : Typ1) (Z : X -> Y -> Typ1)
(x : X) (y : Y) (R : Rel (Z x y)) (z : Z x y) : foo X Y Z :=
fun f => f x y R z.
Definition foo_rt (X Y : Typ1) (Z : X -> Y -> Typ1) :
foo X Y Z := fun _ => bot.
(** It is then easy to check the expected property of non-confusion holds for the constructors foo_in and foo_rt: *)
Proof fun X Y Z x y R z e => e (fun u => u (fun _ _ _ _ => top)) top_intro.
Proof
fun X Y Z x y R z e =>
e (fun u => u (fun _ _ _ _ => top) -> bot) (fun p => p) top_intro.
(** On the other hand, proving the injectivity of the constructor  (foo_in X Y Z) : (x:X; y:Y)(Rel (Z x y))->(Z x y)->(foo X Y Z)  (of arity 4) is a little bit more tricky, since the types of its last two arguments actually depend on the values of its first two arguments.  (This is the same problem as for the dependent pair.)  For this reason, we express the injectivity of the constructor (foo_in X Y Z) by using a dependent equality which is close to John Major's equality: *)
(* Equality of the images... *)
(* ... implies dependent equality: *)
Proof fun X Y Z x1 x2 y1 y2 R1 R2 z1 z2 H P p => H (fun f => f P) p.
(** This kind of equality is actually sufficent for proving the expected delocation property (cf Lemma FOO_deloc below). *)
(** ** Building the edge relation of the super-powerset **)
(** The edge relation (FOO X Y Z) : (Rel (foo X Y Z)) of the super-powerset of the family of small types Z : X->Y->Typ1 is defined by the following clauses:  1.  (Delocation of pointed graph structures:)  For any x:X and y:Y, for any relation R:(Rel (Z x y)) and for any pair of vertices z,z':(Z x y),  (R z' z) implies (FOO X Y Z (foo_in X Y Z x y R z') (foo_in X Y Z x y R z))  2.  (Connecting vertices to the new root:)  For any x:X and y:Y, for any relation R:(Rel (Z x y)) and for any vertex z:(Z x y), then (FOO X Y Z (foo_in X Y Z x y R z) (foo_rt X Y Z)).  Formally, we define this relation as follows: *)
Definition FOO (X Y : Typ1) (Z : X -> Y -> Typ1) (u' u : foo X Y Z) : Prop :=
forall E : Prop,
(forall (x : X) (y : Y) (R : Rel (Z x y)) (z' z : Z x y),
eq (foo X Y Z) u' (foo_in X Y Z x y R z') ->
eq (foo X Y Z) u (foo_in X Y Z x y R z) -> R z' z -> E) ->
(forall (x : X) (y : Y) (R : Rel (Z x y)) (z' : Z x y),
eq (foo X Y Z) u' (foo_in X Y Z x y R z') ->
eq (foo X Y Z) u (foo_rt X Y Z) -> E) -> E.
(** Both clauses are given by the following constructors: *)
Proof
fun X Y Z x y R z' z H E H1 H2 =>
H1 x y R z' z (eq_refl (foo X Y Z) (foo_in X Y Z x y R z'))
(eq_refl (foo X Y Z) (foo_in X Y Z x y R z)) H.
Proof
fun X Y Z x y R z' E H1 H2 =>
H2 x y R z' (eq_refl (foo X Y Z) (foo_in X Y Z x y R z'))
(eq_refl (foo X Y Z) (foo_rt X Y Z)).
(** We now prove that for any x:X, y:Y and R:(Rel (Z x y)), the function  (foo_in X Y Z x y R)  :  (Z x y)->(foo X Y Z)  induces a delocation from the graph ((Z x y), R) to the graph ((foo X Y Z), (FOO x y z)).  *)

Lemma FOO_deloc :
forall (X Y : Typ1) (Z : X -> Y -> Typ1) (x : X) (y : Y) (R : Rel (Z x y)),
deloc (Z x y) R (foo X Y Z) (FOO X Y Z) (foo_in X Y Z x y R).