(*****************)
(* Prism Theorem *)
(*****************)

(* Auxiliary notion : compat 
   Used to generate the right simultaneous induction on U, V and W *)

(* (compat U V W) iff U,V,W are compatible markings, and (sub V U) *)
Inductive compat : redexes -> redexes -> redexes -> Prop :=
  | Compat_Var : forall n : nat, compat (Var n) (Var n) (Var n)
  | Compat_Fun :
      forall U V W : redexes, compat U V W -> compat (Fun U) (Fun V) (Fun W)
  | Compat_Ap1 :
      forall U1 V1 W1 : redexes,
      compat U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      compat U2 V2 W2 ->
      forall b : bool, compat (Ap false U1 U2) (Ap false V1 V2) (Ap b W1 W2)
  | Compat_Ap2 :
      forall U1 V1 W1 : redexes,
      compat U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      compat U2 V2 W2 ->
      forall b b' : bool,
      compat (Ap true (Fun U1) U2) (Ap b (Fun V1) V2) (Ap b' (Fun W1) W2).(*****************)
(* Prism Theorem *)
(*****************)

(* Auxiliary notion : compat 
   Used to generate the right simultaneous induction on U, V and W *)

(* (compat U V W) iff U,V,W are compatible markings, and (sub V U) *)
Inductive compat : redexes -> redexes -> redexes -> Prop :=
  | Compat_Var : forall n : nat, compat (Var n) (Var n) (Var n)
  | Compat_Fun :
      forall U V W : redexes, compat U V W -> compat (Fun U) (Fun V) (Fun W)
  | Compat_Ap1 :
      forall U1 V1 W1 : redexes,
      compat U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      compat U2 V2 W2 ->
      forall b : bool, compat (Ap false U1 U2) (Ap false V1 V2) (Ap b W1 W2)
  | Compat_Ap2 :
      forall U1 V1 W1 : redexes,
      compat U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      compat U2 V2 W2 ->
      forall b b' : bool,
      compat (Ap true (Fun U1) U2) (Ap b (Fun V1) V2) (Ap b' (Fun W1) W2).(*****************)
(* Prism Theorem *)
(*****************)

(* Auxiliary notion : compat 
   Used to generate the right simultaneous induction on U, V and W *)

(* (compat U V W) iff U,V,W are compatible markings, and (sub V U) *)
Inductive compat : redexes -> redexes -> redexes -> Prop :=
  | Compat_Var : forall n : nat, compat (Var n) (Var n) (Var n)
  | Compat_Fun :
      forall U V W : redexes, compat U V W -> compat (Fun U) (Fun V) (Fun W)
  | Compat_Ap1 :
      forall U1 V1 W1 : redexes,
      compat U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      compat U2 V2 W2 ->
      forall b : bool, compat (Ap false U1 U2) (Ap false V1 V2) (Ap b W1 W2)
  | Compat_Ap2 :
      forall U1 V1 W1 : redexes,
      compat U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      compat U2 V2 W2 ->
      forall b b' : bool,
      compat (Ap true (Fun U1) U2) (Ap b (Fun V1) V2) (Ap b' (Fun W1) W2).(*****************)
(* Prism Theorem *)
(*****************)

(* Auxiliary notion : compat 
   Used to generate the right simultaneous induction on U, V and W *)

(* (compat U V W) iff U,V,W are compatible markings, and (sub V U) *)
Inductive compat : redexes -> redexes -> redexes -> Prop :=
  | Compat_Var : forall n : nat, compat (Var n) (Var n) (Var n)
  | Compat_Fun :
      forall U V W : redexes, compat U V W -> compat (Fun U) (Fun V) (Fun W)
  | Compat_Ap1 :
      forall U1 V1 W1 : redexes,
      compat U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      compat U2 V2 W2 ->
      forall b : bool, compat (Ap false U1 U2) (Ap false V1 V2) (Ap b W1 W2)
  | Compat_Ap2 :
      forall U1 V1 W1 : redexes,
      compat U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      compat U2 V2 W2 ->
      forall b b' : bool,
      compat (Ap true (Fun U1) U2) (Ap b (Fun V1) V2) (Ap b' (Fun W1) W2).(*****************)
(* Prism Theorem *)
(*****************)

(* Auxiliary notion : compat 
   Used to generate the right simultaneous induction on U, V and W *)

(* (compat U V W) iff U,V,W are compatible markings, and (sub V U) *)
Inductive compat : redexes -> redexes -> redexes -> Prop :=
  | Compat_Var : forall n : nat, compat (Var n) (Var n) (Var n)
  | Compat_Fun :
      forall U V W : redexes, compat U V W -> compat (Fun U) (Fun V) (Fun W)
  | Compat_Ap1 :
      forall U1 V1 W1 : redexes,
      compat U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      compat U2 V2 W2 ->
      forall b : bool, compat (Ap false U1 U2) (Ap false V1 V2) (Ap b W1 W2)
  | Compat_Ap2 :
      forall U1 V1 W1 : redexes,
      compat U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      compat U2 V2 W2 ->
      forall b b' : bool,
      compat (Ap true (Fun U1) U2) (Ap b (Fun V1) V2) (Ap b' (Fun W1) W2).

(* Specifications: *)
Lemma compat_intro : forall U W WU : redexes, residuals W U WU -> forall (V WV : redexes) (R2 : residuals W V WV) (S : sub V U), compat U V W.
Lemma prism0 : forall U V W : redexes, compat U V W -> forall (UV : redexes) (R1 : residuals U V UV) (WU WV : redexes) (R2 : residuals W U WU) (R3 : residuals W V WV), residuals WV UV WU.
Lemma prism1 : forall U V W : redexes, sub V U -> forall UV : redexes, residuals U V UV -> forall WV : redexes, residuals W V WV -> forall WU : redexes, residuals W U WU -> residuals WV UV WU.
Lemma prism2 : forall U V W : redexes, sub V U -> regular U -> forall UV : redexes, residuals U V UV -> forall WV : redexes, residuals W V WV -> forall WU : redexes, residuals WV UV WU -> residuals W U WU.
Theorem prism : forall U V W : redexes, sub V U -> forall UV : redexes, residuals U V UV -> forall WV : redexes, residuals W V WV -> forall WU : redexes, residuals W U WU <-> regular U /\ residuals WV UV WU.
Lemma cube : forall U V UV VU : redexes, residuals U V UV -> residuals V U VU -> forall W WU WV WUV : redexes, residuals W U WU -> residuals WU VU WUV -> residuals W V WV -> residuals WV UV WUV.
Lemma paving : forall U V W WU WV : redexes, residuals W U WU -> residuals W V WV -> exists UV : redexes, (exists VU : redexes, (exists WUV : redexes, residuals WU VU WUV /\ residuals WV UV WUV)).