(**********************************************************************)
(* 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                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                   SF_reduction.v                                   *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Omega.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Wave_as_SF.SF_Terms.
Require Import IntensionalLib.Wave_as_SF.SF_Tactics.

(*
Definition s_op := Op Sop.
Definition f_op := Op Fop.
*)
Definition node := Op Node.
Definition k_op := App node node.
Definition i_op := App (App node k_op) k_op.
Ltac unfold_op := unfold i_op, k_op, node.

(* compounds *)

Fixpoint right_component (M : SF) :=
match M with
| App _ M2 => M2
| _ => M
end.

Definition left_component (U : SF) :=
match U with
| App U1 _ => U1
| _ => i_op
end.

Lemma rank_component_app_l:
forall M N, rank (left_component (App M N)) < rank (App M N).
Proof. split_all; omega. Qed.

Lemma rank_component_app_r:
forall M N, rank (right_component (App M N)) < rank (App M N).
Proof. split_all; omega. Qed.

Inductive compound : SF -> Prop :=
| N1_compound : forall M, compound (App (Op Node) M)
| N2_compound : forall M N, compound (App (App (Op Node) M) N)
.

Hint Constructors compound.

Lemma rank_compound_l : forall M, compound M ->
rank (left_component M) < rank M.
Proof.
split_all. inversion H; subst;
eapply2 rank_component_app_l ||
split_all.
Qed.

Lemma rank_compound_r : forall M, compound M ->
rank (right_component M) < rank M.
Proof.
split_all. inversion H; subst;
eapply2 rank_component_app_r ||
inv1 compound.
Qed.

Definition preserves_compound (red:termred) :=
forall M, compound M -> forall N, red M N ->
compound N /\ red (left_component M) (left_component N) /\ red(right_component M) (right_component N).

Lemma preserves_compound_multi_step :
forall (red:termred), preserves_compound red -> preserves_compound (multi_step red).
Proof.
red. intros red p M c N R; induction R; split_all. repeat split.
eapply2 IHR. eapply2 p.
apply succ_red with (left_component N); auto.
 eapply2 p. eapply2 IHR. eapply2 p.
apply succ_red with (right_component N); auto.
 eapply2 p. eapply2 IHR. eapply2 p.
Qed.

Hint Resolve preserves_compound_multi_step.

(* SF-reduction  *)

Inductive sf_red1 : termred :=
  | ref_sf_red : forall i, sf_red1 (Ref i) (Ref i)
  | op_sf_red : forall o, sf_red1 (Op o) (Op o)
  | app_sf_red :
      forall M M' ,
      sf_red1 M M' ->
      forall N N' : SF, sf_red1 N N' -> sf_red1 (App M N) (App M' N')
  | s_red: forall (M M' N N' P P' : SF),
             sf_red1 M M' -> sf_red1 N N' -> sf_red1 P P' ->
             sf_red1
                   (App (App (App (Op Node) (App (Op Node) M)) N) P)
                  (App (App N' P') (App M' P'))
  | k_red : forall M  M' N o,  sf_red1 M M' ->
               sf_red1 (App (App (App (Op Node) (Op o)) M) N) M'
  | f_red: forall (P P' Q Q' M N N': SF),
             sf_red1 P P' -> sf_red1 Q Q' -> sf_red1 N N' ->
   sf_red1 (App (App (App (Op Node) (App (App (Op Node) P) Q)) M) N)
                     (App (App N' P') Q')
.

Hint Constructors sf_red1.

Definition sf_red := multi_step sf_red1.

Lemma reflective_sf_red1 : reflective sf_red1.
Proof. red; induction M; split_all. Qed.
Hint Resolve reflective_sf_red1.

Lemma reflective_sf_red : reflective sf_red.
Proof. unfold sf_red; eapply2 refl_multi_step. Qed.
Hint Resolve reflective_sf_red.

Lemma preserves_app_sf_red : preserves_app sf_red.
Proof. eapply2 preserves_app_multi_step. red; split_all. Qed.
Hint Resolve  preserves_app_sf_red.

Lemma  preserves_compound_sf_red1:
forall M, compound M -> forall N, sf_red1 M N ->
compound N /\
sf_red1 (left_component M) (left_component N) /\
sf_red1(right_component M) (right_component N).
Proof.
induction M; split_all; inv1 compound; subst; inv sf_red1.
case o; auto. case o; auto.
 Qed.

Hint Resolve preserves_compound_sf_red1 .

Lemma  preserves_compound_sf_red: preserves_compound sf_red.
Proof.
eapply2 preserves_compound_multi_step.
split_all; split; eapply2 preserves_compound_sf_red1.
Qed.
Hint Resolve preserves_compound_sf_red .

Ltac app_op := unfold_op;
match goal with
| |- sf_red _ _ => red; app_op
| |- multi_step sf_red1 (Op _) (Op _) => red; one_step; app_op
| |- multi_step sf_red1 (App _ _) (App _ _) => eapply2 preserves_app_sf_red ; app_op
| |- multi_step sf_red1 (left_component _) (left_component _) => eapply2 preserves_compound_sf_red; app_op
| |- multi_step sf_red1 (right_component _) (right_component _) => eapply2 preserves_compound_sf_red; app_op
| |- sf_red1 (App _ _) (App _ _) => eapply2 app_sf_red ; app_op
| |- sf_red1 (left_component _) (left_component _) => eapply2 preserves_compound_sf_red1; app_op
| |- sf_red1 (right_component _) (right_component _) => eapply2 preserves_compound_sf_red1; app_op
| H : sf_red1 _ _ |- compound _ => eapply2 preserves_compound_sf_red1
| |- sf_red1 (left_component _) _ => eapply2 preserves_compound_sf_red1
| |- sf_red1 (right_component _) _ => eapply2 preserves_compound_sf_red1
| _ => try red; split_all
end.

Ltac sf_red_compound :=
fold sf_red in *;
match goal with
| H : sf_red   (App (App (Op ?o) ?M1) ?M2) ?N |- _ =>
assert(sf_red  (right_component (App (App (Op o) M1) M2))
          (right_component N)) by
eapply2 preserves_compound_sf_red;
assert(sf_red  (left_component (App (App (Op o) M1) M2))
          (left_component N)) by
eapply2 preserves_compound_sf_red; simpl in *; clear H; sf_red_compound
| H : sf_red (App (Op ?o) ?M1) ?N  |- _ =>
assert(sf_red  (right_component (App (Op o) M1))
          (right_component N)) by
eapply2 preserves_compound_sf_red; clear H; sf_red_compound
| _ => simpl in *
end;
simpl in *.

(* Diamond Lemmas *)

Lemma diamond_sf_red1_sf_red1 : diamond sf_red1 sf_red1.
Proof.
red; intros M N OR; induction OR; split_all; eauto.

(* 4 subgoals *)
inversion H; clear H; subst; inv sf_red1; inv sf_red1; eauto.

(* 7 subgoals *)
elim(IHOR1 M'0); elim(IHOR2 N'0); split_all;
inversion H; inversion H0; eauto.
(* 6 *)
case o; case o0.
elim(IHOR1 (App (App (Op Node) (App (Op Node) M'0)) N'0));
elim(IHOR2 P'); split_all;
inversion H; inversion H0; eauto; split_all. inv sf_red1.
invsub. exist(App (App N'2 x) (App N'5 x)).
(* 5 *)
elim (IHOR1 (App (App (Op Node) (Op o)) P)); split_all.
inversion H. inv sf_red1. invsub. exist N'1.
case o1; case o0. auto.
(* 4 *)
elim (IHOR1 (App (App (Op Node) (App (App (Op Node) P') Q')) N'1));
elim (IHOR2 N'0);
split_all;  inversion H; inversion H0; eauto.
inv sf_red1.  invsub.
exist(App (App x N'7) N'6).
case o0; case o; split; auto.
(* 3 *)
inversion H; subst. clear H. inv sf_red1.
elim(IHOR1 N'3); elim(IHOR2 N'1); elim(IHOR3 N'0); split_all.
inversion H; inversion H0; inversion H1.
exist (App (App x0 x) (App x1 x)).
split; auto.
case o0; case o. auto.
elim(IHOR1 M'0); elim(IHOR2 N'0); elim(IHOR3 P'0); split_all.
inversion H0; inversion H1; inversion H2.
exist (App (App x0 x) (App x1 x)).
(* 2 *)
inversion H; subst. clear H. inv sf_red1.
elim(IHOR N'0); split_all. inversion H.
case o0; case o1.
exist x.
elim(IHOR P); split_all.
(* 1 *)
inversion H; subst; clear H; inv sf_red1.
elim(IHOR1 N'4); elim(IHOR2 N'3); elim(IHOR3 N'0); split_all.
inversion H; inversion H0; inversion H1.
exist(App (App x x1) x0). split; auto.
case o0; case o; auto.
elim(IHOR1 P'0); elim(IHOR2 Q'0); elim(IHOR3 N'0); split_all.
inversion H; inversion H0; inversion H1.
exist(App (App x x1) x0).
Qed.

Hint Resolve diamond_sf_red1_sf_red1.

Lemma diamond_sf_red1_sf_red : diamond sf_red1 sf_red.
Proof. eapply2 diamond_strip. Qed.

Lemma diamond_sf_red : diamond sf_red sf_red.
Proof.  eapply2 diamond_tiling. Qed.
Hint Resolve diamond_sf_red.

(* Confluence *)

Definition confluence (A : Set) (R : A -> A -> Prop) :=
  forall x y : A,
  R x y -> forall z : A, R x z -> exists u : A, R y u /\ R z u.

Theorem confluence_sf_red: confluence SF sf_red.
Proof. red; split_all; eapply2 diamond_sf_red. Qed.

(* SF-sequential-reduction *)

Inductive sf_seqred1 : SF -> SF -> Prop :=
  | appl_sf_seqred :  forall M M' N, sf_seqred1 M M' ->
                                      sf_seqred1 (App M N) (App M' N)
  | appr_sf_seqred :  forall M N N', sf_seqred1 N N' ->
                                      sf_seqred1 (App M N) (App M N')
  | s_sf_seqred: forall (M N P : SF),
             sf_seqred1
                   (App (App (App (Op Node) (App (Op Node) M)) N) P)
                  (App (App N P) (App M P))
  | k_sf_seqred : forall M N o,
               sf_seqred1 (App (App (App (Op Node) (Op o)) M) N) M
  | f_sf_seqred : forall (P Q M N: SF),
             sf_seqred1 (App (App (App (Op Node) (App (App (Op Node) P) Q)) M) N)
                     (App (App N P) Q)
.

Definition sf_seqred := multi_step sf_seqred1.

Hint Constructors sf_seqred1 .

Lemma reflective_sf_seqred: reflective sf_seqred.
Proof. red; red; reflect. Qed.
Hint Resolve reflective_sf_seqred.

Definition preserves_apl (red : termred) :=
forall M M' N, red M M' -> red (App M N) (App M' N).

Definition preserves_apr (red : termred) :=
forall M N N', red N N' -> red (App M N) (App M N').

Lemma preserves_apl_multi_step : forall (red: termred), preserves_apl red -> preserves_apl (multi_step red).
Proof. red. induction 2; split_all. apply succ_red with (App N0 N); auto. Qed.

Lemma preserves_apr_multi_step : forall (red: termred), preserves_apr red -> preserves_apr (multi_step red).
Proof. red. induction 2; split_all. apply succ_red with (App M N); auto. Qed.

Lemma preserves_apl_sf_seqred: preserves_apl sf_seqred.
Proof. eapply2 preserves_apl_multi_step. red; split_all.  Qed.
Hint Resolve preserves_apl_sf_seqred.

Lemma preserves_apr_sf_seqred: preserves_apr sf_seqred.
Proof. eapply2 preserves_apr_multi_step. red; split_all.  Qed.
Hint Resolve preserves_apr_sf_seqred.

Lemma preserves_app_sf_seqred: preserves_app sf_seqred.
Proof.
red; split_all.
apply transitive_red with (App M' N); split_all.
eapply2 preserves_apl_sf_seqred.
eapply2 preserves_apr_sf_seqred.
Qed.
Hint Resolve preserves_app_sf_seqred.

Lemma preserves_compound_sf_seqred1: forall M N : SF,
   sf_seqred1 M N ->
   compound M ->
   compound N /\
   sf_seqred (left_component M) (left_component N) /\
   sf_seqred (right_component M) (right_component N).
Proof.
intros M N R; induction R; intro c; inversion c; split_all; split; subst;
inv sf_seqred1; auto; split; auto;
red; one_step; unfold_op; eapply2 abs_sf_seqred.
Qed.

Definition preserves_components_l (red: termred) :=
forall M, compound M -> forall N, red M N -> compound N /\
multi_step red (left_component M) (left_component N).

Lemma preserves_components_l_multi_step :
forall red, preserves_components_l red ->
forall M, compound M -> forall N, multi_step red M N -> compound N /\
multi_step red (left_component M) (left_component N).
Proof.
intros red p M c N R; induction R; split_all. split.
eapply2 IHR. eapply2 p.
apply transitive_red with (left_component N); split_all.
eapply2 p. eapply2 IHR. eapply2 p.
Qed.

Definition preserves_components_r (red: termred) :=
forall M, compound M -> forall N, red M N -> compound N /\
multi_step red (right_component M) (right_component N).

Lemma preserves_components_r_multi_step :
forall red, preserves_components_r red ->
forall M, compound M -> forall N, multi_step red M N -> compound N /\
multi_step red (right_component M) (right_component N).
Proof.
intros red p M c N R; induction R; split_all. split.
eapply2 IHR. eapply2 p.
apply transitive_red with (right_component N); split_all.
eapply2 p. eapply2 IHR. eapply2 p.
Qed.

Lemma preserves_components_l_sf_seqred1 :  preserves_components_l sf_seqred1.
Proof.
red; split_all.  gen_inv H H0; inv1 compound; subst; split_all; split;
inv sf_seqred1; inversion H8; subst; one_step.
Qed.

Lemma preserves_components_r_sf_seqred1 :  preserves_components_r sf_seqred1.
Proof.
red; split_all.  gen_inv H H0; inv1 compound; subst; split_all; split;
inv sf_seqred1; one_step.
Qed.

Lemma sf_seqred1_to_sf_red1 : implies_red sf_seqred1 sf_red1.
Proof. red. intros M N B; induction B; split_all. Qed.

Lemma sf_seqred_to_sf_red: implies_red sf_seqred sf_red.
Proof.
eapply2 implies_red_multi_step.
red; split_all; one_step; eapply2 sf_seqred1_to_sf_red1.
Qed.

Lemma to_sf_seqred_multi_step: forall red, implies_red red sf_seqred -> implies_red (multi_step red) sf_seqred.
Proof.
red.  intros red B M N R; induction R; split_all.
red; split_all.
assert(sf_seqred M N) by eapply2 B.
apply transitive_red with N; auto.
eapply2 IHR.
Qed.

Lemma sf_red1_to_sf_seqred: implies_red sf_red1 sf_seqred .
Proof.
red.  intros M N OR; induction OR; split_all.
(* 3 *)
apply succ_red with (App (App N P) (App M P)). eapply2 s_sf_seqred.
eapply2 preserves_app_sf_seqred.
case o.
apply succ_red with M.
eapply2 k_sf_seqred. auto.
red; apply succ_red with  (App (App N P) Q) ; split_all.
eapply2 preserves_app_sf_seqred.
Qed.

Hint Resolve sf_red1_to_sf_seqred.

Lemma sf_red_to_sf_seqred: implies_red sf_red sf_seqred.
Proof. eapply2 to_sf_seqred_multi_step. Qed.

Lemma diamond_sf_seqred: diamond sf_seqred sf_seqred.
Proof.
red; split_all.
assert(sf_red M N) by eapply2 sf_seqred_to_sf_red.
assert(sf_red M P) by eapply2 sf_seqred_to_sf_red.
elim(diamond_sf_red M N H1 P); split_all.
inversion H3.
exist x; split; eapply2 sf_red_to_sf_seqred.
Qed.
Hint Resolve diamond_sf_seqred.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export per.
(** printing #  $\times$ #×# *)
(** printing <=>  $\Leftrightarrow$ #⇔# *)
(** printing ~<~  $\preceq$ #⪯# *)
(** printing ~=~  $\sim$ #~# *)
(** printing ===>  $\Downarrow$ #⇓# *)
(** printing [[  $[$ *)
(** printing ]]  $]$ *)
(** printing \\  $\backslash$ *)
(** printing mkc_axiom   $\mathtt{Ax}$ *)
(** printing mkc_base    $\mathtt{Base}$ *)
(** printing mkc_int     $\intg$ *)
(** printing mkc_integer $\mathtt{int}$ *)
(** printing mkc_uni $\mathbb{U}$ *)
(* begin hide *)

(** Empty candidate type system *)
Definition cts_bot {p} (T T' : @CTerm p) (eq : @CTerm p -> @CTerm p -> Type) : Set := False.

Definition univ_def {p}
           lib
           (ts : cts)
           (uni T T' : @CTerm p)
           (eq : per) : [U] :=
     (T ===>(lib) uni
     # T' ===>(lib) uni
     # forall A A',
         eq A A' <=> {eqa : per , close lib ts A A' eqa})
    {+} ts T T' eq.

Definition univ0 {p} (lib : @library p) (T T' : @CTerm p) (eq : per(p)) := False.
Definition univ1 {p} lib (T T' : @CTerm p) eq := close lib (univ_def lib (univ0 lib) (mkc_uni 0)) T T' eq.
Definition univ2 {p} lib (T T' : @CTerm p) eq := close lib (univ_def lib (univ1 lib) (mkc_uni 1)) T T' eq.
Definition univ3 {p} lib (T T' : @CTerm p) eq := close lib (univ_def lib (univ2 lib) (mkc_uni 2)) T T' eq.

Definition univ' {p} lib (T T' : @CTerm p) eq :=
  univ0 lib T T' eq [+] univ1 lib T T' eq [+] univ2 lib T T' eq [+] univ3 lib T T' eq.

(* end hide *)

(**

  We now define Nuprl's universes of types, the Nuprl type system
  and various useful abstractions such as the equality
  meta-theoretical relation which expresses when two terms are equal
  in a type.

 *)

(**

  [univi i] is a candidate type system that contains all the types at
  level i.  [univi 0] is the empty type system.  [univi 1] contains
  all the types that do not mention universes.  [univi 2] contains all
  the types of [univi 1] plus all the types that mention universes no
  higher than [mkc_uni 0]%\dots%.  Two types [A] and [A'] are equal in
  a universe at level [S i] if there exists an equality [eqa] such
  that [A] and [A'] are equal with PER [eqa] in the closed type system
  [close (univi i)].  For simplicity, the universe [univi (S i)] is
  denoted by [mkc_uni i].

 *)

Fixpoint univi {p} lib (i : nat) (T T' : @CTerm p) (eq : per(p)) : [U] :=
  match i with
  | 0 => False
  | S n =>
    (T ===>(lib) (mkc_uni n)
     # T' ===>(lib) (mkc_uni n)
     # forall A A',
         eq A A' <=> {eqa : per , close lib (univi lib n) A A' eqa})
    {+} univi lib n T T' eq
  end.

(**

  Even though we can define [univi] in [Type] as a fixpoint, this
  definition is not useful to define more than one universe.  As a
  matter of fact, we can prove prove that [mkc_uni 0] is a member of
  [mkc_uni 1], but we cannot prove that [mkc_uni i] is a member of
  [mkc_uni (S i)] when [i] is greater than [0].  Intuitively this is
  because we cannot fit all the universes of Nuprl into one universe
  of Coq, and [univi i] cannot be at different levels for different
  [i]s.

  More precisely, the problem in [univi (S i)]'s definition is that if
  [eqa] is a relation at the Coq level $l$ then [univi (S i)] is at
  least at level $l+1$, and in general to be able to prove the double
  implication, [eq] must also be at level $l+1$.  However, because
  [eqa] is at level $l$, in the recursive call, in the case where
  [close (univi i) A A' eqa] is [univi i A A' eqa], we end up having
  to prove that our relation at level $l$ is equivalent to a relation
  at level $l+1$, which in general is not possible.

  One alternative approach is to put [univi] in Prop instead of
  [Type].  Another approach is to define instead a finite number of
  universes and add more as needed.

*)

(* begin hide *)

(*
Set Printing Universes.
Print close.
Print univi.
Print Universes.
Check (fun T T' => univi 1 T T' (fun A A' => {eqa : per & close (univi 0) A A' eqa})).
*)

Lemma univi_mkc_uni {p} :
  forall lib (i : nat),
    univi lib
          (S i)
          (mkc_uni i)
          (mkc_uni i)
          (fun A A' => {eqa : per(p) , close lib (univi lib i) A A' eqa}).
Proof.
  intros.
  simpl.
  left.
  dands; try (spcast; apply computes_to_valc_refl; sp).
  sp.
Qed.

Lemma univi_exists {p} :
  forall lib i (T T' : @CTerm p) eq,
    univi lib i T T' eq
    -> {j : nat
        , j < i
         # T ===>(lib) (mkc_uni j)
         # T' ===>(lib) (mkc_uni j)
         # forall A A',
              eq A A' <=> {eqa : per , close lib (univi lib j) A A' eqa}}.
Proof.
  induction i; simpl; sp.
  exists i; sp; omega.
  discover; sp.
  exists j; sp; omega.
Qed.

Lemma univi_exists_iff {p} :
  forall lib i (T T' : @CTerm p) eq,
    univi lib i T T' eq
    <=> {j : nat
          , j < i
          # T ===>(lib) (mkc_uni j)
          # T' ===>(lib) (mkc_uni j)
          # forall A A',
               eq A A' <=> {eqa : per , close lib (univi lib j) A A' eqa}}.
Proof.
  sp; split; intro k.
  apply univi_exists; auto.
  revert T T' eq k.
  induction i; simpl; sp.
  destruct (eq_nat_dec j i); subst; sp.
  right.
  apply IHi with (T := T) (T' := T') (eq := eq); sp.
  exists j; sp; omega.
Qed.

Definition nuprli {p} lib (i : nat) := @close p lib (univi lib i).

Lemma fold_nuprli {p} :
  forall lib i, close lib (univi lib i) = @nuprli p lib i.
Proof.
  sp.
Qed.

(*
(*Polymorphic*) Definition univ (T T' : CTerm) (eq : per) :=
  {n : nat
    & computes_to_valc T (mkc_uni n)
    # computes_to_valc T' (mkc_uni n)
    # forall A A',
         eq A A' <=> {eqa : per & nuprli n A A' eqa}}.
*)

(* end hide *)

(**

  The [univ] operator is a candidate type system that contains all the
  universes.

 *)

Definition univ {p} lib (T T' : @CTerm p) (eq : per) :=
  {i : nat , univi lib i T T' eq}.

(**

  We say that a candidate type system defines only universes if all
  its types are of the forms [mkc_uni i].  For example, we can prove
  that [univ] defines only universes.

*)

Definition defines_only_universes {p} lib (ts : cts(p)) :=
  forall T eq, ts T T eq -> {i : nat , T ===>(lib) (mkc_uni i)}.

(* begin hide *)

Lemma univi_iff_univ {p} :
  forall lib (a b : @CTerm p) eq,
    univ lib a b eq <=> {i : nat , univi lib i a b eq}.
Proof.
  sp; split; sp.
Qed.

(* end hide *)

(**

  Finally, the Nuprl type system is defined by closing the [univ]
  candidate type system.

 *)

Definition nuprl {p} lib := @close p lib (univ lib).

(* begin hide *)

(* ============ Extension of the type system with a new universe of types ============ *)
Inductive closep {p} lib (ts : cts) (T T' : @CTerm p) (eq : per) : [U] :=
  | CLp_init    : ts T T' eq -> closep lib ts T T' eq
  | CLp_int     : per_int     lib (closep lib ts) T T' eq -> closep lib ts T T' eq
  | CLp_base    : per_base    lib (closep lib ts) T T' eq -> closep lib ts T T' eq
  | CLp_sqle    : per_approx  lib (closep lib ts) T T' eq -> closep lib ts T T' eq
  | CLp_sqeq    : per_cequiv  lib (closep lib ts) T T' eq -> closep lib ts T T' eq
  | CLp_eq      : per_eq      lib (closep lib ts) T T' eq -> closep lib ts T T' eq
  | CLp_isect   : per_isect   lib (closep lib ts) T T' eq -> closep lib ts T T' eq
  | CLp_func    : per_func    lib (closep lib ts) T T' eq -> closep lib ts T T' eq
  | CLp_disect  : per_disect  lib (closep lib ts) T T' eq -> closep lib ts T T' eq
  | CLp_pertype : per_pertype lib (closep lib ts) T T' eq -> closep lib ts T T' eq
  | CLp_w       : per_w       lib (closep lib ts) T T' eq -> closep lib ts T T' eq
  | CLp_m       : per_m       lib (closep lib ts) T T' eq -> closep lib ts T T' eq
  | CLp_pw      : per_pw      lib (closep lib ts) T T' eq -> closep lib ts T T' eq
  | CLp_pm      : per_pm      lib (closep lib ts) T T' eq -> closep lib ts T T' eq
  | CLp_union   : per_union   lib (closep lib ts) T T' eq -> closep lib ts T T' eq
  | CLp_image   : per_image   lib (closep lib ts) T T' eq -> closep lib ts T T' eq
  | CLp_compute : per_compute lib (closep lib ts) T T' eq -> closep lib ts T T' eq.
Hint Constructors closep.

Fixpoint univip {p} lib (i : nat) (T T' : @CTerm p) (eq : per(p)) : [U] :=
  match i with
  | 0 => False
  | S n =>
    (T ===>(lib) (mkc_uni n)
     # T' ===>(lib) (mkc_uni n)
     # forall A A',
         eq A A' <=> {eqa : per , closep lib (univip lib n) A A' eqa})
    {+} univip lib n T T' eq
  end.

Definition univp {p} lib (T T' : @CTerm p) (eq : per) :=
  {i : nat , univip lib i T T' eq}.

Definition nuprlp {p} lib := @closep p lib (univp lib).

Definition Nuprl {p} lib (T T' : @CTerm p) (eq : per) :=
  nuprl lib T T' eq [+] univp lib T T' eq.
(* ==================================================================================*)

Lemma typable_in_higher_univ {pp} :
  forall lib i (T T' : @CTerm pp) eq,
    nuprli lib i T T' eq
    -> forall k, nuprli lib (k + i) T T' eq.
Proof.
  unfold nuprli; introv cl; induction k; simpl; sp.

  remember (univi lib (k + i)) as u; revert Hequ.
  clear cl.
  close_cases (induction IHk using @close_ind') Case; sp; subst.

  - Case "CL_eq".
    apply CL_eq; unfold per_eq; sp.
    exists A B a1 a2 b1 b2 eqa; sp.

  - Case "CL_req".
    apply CL_req; unfold per_req; sp.
    exists A B a1 a2 b1 b2 eqa; sp.

  - Case "CL_teq".
    apply CL_teq; unfold per_teq; sp.
    exists a1 a2 b1 b2 eqa; sp.

  - Case "CL_isect".
    apply CL_isect; unfold per_isect; sp.
    exists eqa eqb; sp.
    exists A A' v v' B B'; sp.

  - Case "CL_func".
    apply CL_func; unfold per_func; sp.
    exists eqa eqb; sp.
    exists A A' v v' B B'; sp.

  - Case "CL_disect".
    apply CL_disect; unfold per_disect; sp.
    exists eqa eqb; sp.
    exists A A' v v' B B'; sp.

  - Case "CL_pertype".
    apply CL_pertype; unfold per_pertype; sp.
    exists R1 R2 eq1 eq2; sp.

  - Case "CL_ipertype".
    apply CL_ipertype; unfold per_ipertype; sp.
    exists R1 R2 eq1; sp.

  - Case "CL_spertype".
    apply CL_spertype; unfold per_spertype; sp.
    exists R1 R2 eq1; sp.

  - Case "CL_w".
    apply CL_w; unfold per_w; sp.
    exists eqa eqb; sp.
    exists A A' v v' B B'; sp.

  - Case "CL_m".
    apply CL_m; unfold per_m; sp.
    exists eqa eqb; sp.
    exists A A' v v' B B'; sp.

  - Case "CL_pw".
    apply CL_pw; unfold per_pw; sp.
    exists eqp eqa eqb p p' cp cp' ca ca'.
    exists cb cb' C C'; sp.
    unfold type_pfamily.
    exists Pr Pr' ap ap' A A' bp bp'.
    exists ba ba' B B'; sp.

  - Case "CL_pm".
    apply CL_pm; unfold per_pm; sp.
    exists eqp eqa eqb p p' cp cp' ca ca'.
    exists cb cb' C C'; sp.
    unfold type_pfamily.
    exists Pr Pr' ap ap' A A' bp bp'.
    exists ba ba' B B'; sp.

  - Case "CL_texc".
    apply CL_texc; unfold per_texc; sp.
    exists eqn eqe N N' E E'; sp.

  - Case "CL_union".
    apply CL_union; unfold per_union; sp.
    exists eqa eqb A A' B B'; sp.

    (*
  - Case "CL_eunion".
    apply CL_eunion; unfold per_eunion; sp.
    exists eqa1 eqa2 eqb1 eqb2 A A' B B'; sp.
     *)

  - Case "CL_image".
    apply CL_image; unfold per_image; sp.
    exists eqa A A' f f'; sp.

(*
  - Case "CL_eisect".
    apply CL_eisect; unfold per_eisect; sp.
    exists eqa eqa' eqb; sp.
    exists A A' v v' B B'.
    exists f g f' g'; sp.
*)

  - Case "CL_partial".
    apply CL_partial; unfold per_partial; sp.
    exists A1 A2 eqa; sp.

  - Case "CL_admiss".
    apply CL_admiss; unfold per_partial; sp.
    exists A1 A2 eqa; sp.

  - Case "CL_mono".
    apply CL_mono; unfold per_partial; sp.
    exists A1 A2 eqa; sp.

  - Case "CL_ffatom".
    apply CL_ffatom; unfold per_ffatom; sp.
    exists A1 A2 x1 x2 a1 a2 eqa u; sp.

  - Case "CL_effatom".
    apply CL_effatom; unfold per_effatom; sp.
    exists A1 A2 x1 x2 a1 a2 eqa; sp.

  - Case "CL_ffatoms".
    apply CL_ffatoms; unfold per_ffatoms; sp.
    exists A1 A2 x1 x2 eqa; sp.

  - Case "CL_set".
    apply CL_set; unfold per_set; sp.
    exists eqa eqb; sp.
    exists A A' v v' B B'; sp.

  - Case "CL_tunion".
    apply CL_tunion; unfold per_tunion; sp.
    exists eqa eqb; sp.
    exists A A' v v' B B'; sp.

  - Case "CL_product".
    apply CL_product; unfold per_product; sp.
    exists eqa eqb; sp.
    exists A A' v v' B B'; sp.
Qed.

Lemma typable_in_higher_univ_r {p} :
  forall lib i (T T' : @CTerm p) eq,
    nuprli lib i T T' eq
    -> forall k, nuprli lib (i + k) T T' eq.
Proof.
  unfold nuprli; introv n; sp.
  generalize (typable_in_higher_univ lib i T T' eq n k); sp.
  assert (k + i = i + k) as e by omega.
  rww e; sp.
Qed.

Lemma minus_plus_n :
  forall n k : nat,
    n <= k -> (k - n) + n = k.
Proof.
  induction n; simpl; sp.
  omega.
  destruct k; simpl; sp.
  omega.
  rw <- plus_n_Sm.
  rw IHn; sp; omega.
Qed.

Lemma typable_in_higher_univ_max {p} :
  forall lib i1 i2 (A1 B1 A2 B2 : @CTerm p) eq1 eq2,
    nuprli lib i1 A1 B1 eq1
    -> nuprli lib i2 A2 B2 eq2
    -> nuprli lib (Peano.max i1 i2) A1 B1 eq1
       # nuprli lib (Peano.max i1 i2) A2 B2 eq2.
Proof.
  introv n1 n2.
  generalize (typable_in_higher_univ
                lib i1 A1 B1 eq1 n1 ((Peano.max i1 i2) - i1));
    intro k1.
  generalize (typable_in_higher_univ
                lib i2 A2 B2 eq2 n2 ((Peano.max i1 i2) - i2));
    intro k2.
  assert (((Peano.max i1 i2) - i1) + i1 = Peano.max i1 i2) as max1.
  apply minus_plus_n; sp.
  apply max_prop1.
  assert (((Peano.max i1 i2) - i2) + i2 = Peano.max i1 i2) as max2.
  apply minus_plus_n; sp.
  apply max_prop2.
  rw max1 in k1.
  rw max2 in k2.
  sp.
Qed.

Lemma uni_in_higher_univ {p} :
  forall lib i (T T' : @CTerm p) eq,
    univi lib i T T' eq
    -> forall k, univi lib (k + i) T T' eq.
Proof.
  induction k; simpl; sp.
Qed.

Lemma uni_in_higher_univ_r {p} :
  forall lib i (T T' : @CTerm p) eq,
    univi lib i T T' eq
    -> forall k, univi lib (i + k) T T' eq.
Proof.
  introv u; sp.
  generalize (uni_in_higher_univ lib i T T' eq u k); sp.
  assert (k + i = i + k) as e by omega.
  rww e; sp.
Qed.

(*
Definition Nuprl T T' eq := {n : nat & Nuprli n T T' eq}.
*)

(*
Lemma univi_implies_univ :
  forall i a b eq,
    univi i a b eq
    -> univ a b eq.
Proof.
  induction i; simpl; sp.
  unfold univ.
  exists i; sp.
Qed.
*)

(*
(*Error: Universe inconsistency.*)

Lemma mkc_uni_in_nuprl :
  forall i : nat,
    nuprl (mkc_uni i)
          (mkc_uni i)
          (fun A A' => {eqa : per & close (univi i) A A' eqa}).
Proof.
  intro.
  apply CL_init.
  exists (S i); simpl.
  left; sp; apply computes_to_valc_refl; sp.
Qed.

Lemma nuprl_mkc_uni :
  forall i : nat,
    {eq : per & nuprl (mkc_uni i) (mkc_uni i) eq}.
Proof.
  intros.
  exists (fun A A' => {eqa : per & close (univi i) A A' eqa}).
  apply mkc_uni_in_nuprl.
Qed.
*)

(*
Lemma univ_exists :
  forall T T' eq,
    univ T T' eq -> {i : nat & univi i T T' eq}.
Proof.
  unfold univ; sp.
  exists (S n).
  apply univi_exists_iff.
  exists n; sp; omega.
Qed.
*)

(*
Lemma univ_type_system : type_system univ.
Proof.
  unfold type_system; sp.

  - unfold uniquely_valued, eq_term_equals; sp.
    allunfold univ; sp.
    computes_to_eqval.
    trewrite p0 t1 t2; trewrite p t1 t2; split; sp.

  - unfold type_extensionality; sp.
    allunfold univ; sp.
    exists n; sp.
    trewrite <- p A A'.
    symm; sp.

  - unfold type_symmetric; sp.
    allunfold univ; sp.
    exists n; sp.

  - unfold type_transitive; sp.
    allunfold univ; sp.
    computes_to_eqval.
    exists n0; sp.

  - unfold type_value_respecting; sp.
    allunfold univ; sp.
    exists n; sp.
    apply cequivc_uni with (t := T); auto.

  - unfold term_symmetric, term_equality_symmetric; sp.
    allunfold univ; sp.
    apply p in X0; sp.
    apply p.
    exists eqa; auto.
    generalize (nuprli_type_system n); sp.
    inversion X; sp.

  - unfold term_transitive, term_equality_transitive; sp.
    allunfold univ; sp.
    apply p in X0; apply p in X1; sp; apply p.
    generalize (nuprli_type_system n); sp.
    inversion X; sp.
    exists eqa.
    apply uniquely_valued_trans4 with (T2 := t2) (eq1 := eqa0); sp.

  - unfold term_value_respecting, term_equality_respecting; sp.
    allunfold univ; sp.
    apply p in X0; sp; apply p.
    exists eqa.
    generalize (nuprli_type_system n); sp.
    inversion X; sp.
Qed.
*)

Lemma nuprli_implies_nuprl {pp} :
  forall lib (a b : @CTerm pp) i eq,
    nuprli lib i a b eq
    -> nuprl lib a b eq.
Proof.
  unfold nuprli, nuprl; introv n.
  remember (univi lib i) as k.
  revert i Heqk.
  close_cases (induction n using @close_ind') Case; sp; subst.

  - Case "CL_init".
    apply CL_init.
    exists i; sp.

  - Case "CL_eq".
    apply CL_eq.
    unfold per_eq; sp.
    exists A B a1 a2 b1 b2 eqa; sp.
    apply IHn with (i0 := i); sp.

  - Case "CL_req".
    apply CL_req.
    unfold per_req; sp.
    exists A B a1 a2 b1 b2 eqa; sp.
    apply IHn with (i0 := i); sp.

  - Case "CL_teq".
    apply CL_teq.
    unfold per_teq; sp.
    exists a1 a2 b1 b2 eqa; sp.
    apply IHn1 with (i0 := i); sp.
    apply IHn2 with (i0 := i); sp.
    apply IHn3 with (i0 := i); sp.

  - Case "CL_isect".
    apply CL_isect.
    unfold per_isect, type_family; sp.
    exists eqa eqb; sp.
    exists A A' v v' B B'; sp.
    apply IHn with (i0 := i); sp.
    apply recb with (i0 := i); sp.

  - Case "CL_func".
    apply CL_func.
    unfold per_func, type_family; sp.
    exists eqa eqb; sp; try (exists A A' v v' B B'); sp.
    apply IHn with (i0 := i); sp.
    apply recb with (i0 := i); sp.

  - Case "CL_disect".
    apply CL_disect.
    unfold per_disect, type_family; sp.
    exists eqa eqb; sp; try (exists A A' v v' B B'); sp.
    apply IHn with (i0 := i); sp.
    apply recb with (i0 := i); sp.

  - Case "CL_pertype".
    apply CL_pertype.
    unfold per_pertype; sp.
    exists R1 R2 eq1 eq2; sp.
    apply rec1 with (i0 := i); sp.
    apply rec2 with (i0 := i); sp.

  - Case "CL_ipertype".
    apply CL_ipertype.
    unfold per_ipertype; sp.
    exists R1 R2 eq1; sp.
    apply rec1 with (i0 := i); sp.

  - Case "CL_spertype".
    apply CL_spertype.
    unfold per_spertype; sp.
    exists R1 R2 eq1; sp.
    apply rec1 with (i0 := i); sp.
    apply rec2 with (i0 := i); sp.
    apply rec3 with (i0 := i); sp.

  - Case "CL_w".
    apply CL_w.
    unfold per_w, type_family; sp.
    exists eqa eqb; sp; try (exists A A' v v' B B'); sp.
    apply IHn with (i0 := i); sp.
    apply recb with (i0 := i); sp.

  - Case "CL_m".
    apply CL_m.
    unfold per_m, type_family; sp.
    exists eqa eqb; sp; try (exists A A' v v' B B'); sp.
    apply IHn with (i0 := i); sp.
    apply recb with (i0 := i); sp.

  - Case "CL_pw".
    apply CL_pw.
    unfold per_pw, type_pfamily; sp.
    exists eqp eqa eqb.
    exists p p' cp cp' ca ca' cb cb'.
    exists C C'; sp.
    exists Pr Pr' ap ap' A A' bp bp'.
    exists ba ba' B B'; sp.
    apply IHn with (i0 := i); sp.
    apply reca with (i0 := i); sp.
    apply recb with (i0 := i); sp.

  - Case "CL_pm".
    apply CL_pm.
    unfold per_pm, type_pfamily; sp.
    exists eqp eqa eqb.
    exists p p' cp cp' ca ca' cb cb'.
    exists C C'; sp.
    exists Pr Pr' ap ap' A A' bp bp'.
    exists ba ba' B B'; sp.
    apply IHn with (i0 := i); sp.
    apply reca with (i0 := i); sp.
    apply recb with (i0 := i); sp.

  - Case "CL_texc".
    apply CL_texc.
    unfold per_texc; sp.
    exists eqn eqe N N' E E'; sp.
    { apply IHn1 with (i0 := i); sp. }
    { apply IHn2 with (i0 := i); sp. }

  - Case "CL_union".
    apply CL_union.
    unfold per_union; sp.
    exists eqa eqb A A' B B'; sp.
    + apply IHn1 with (i0 := i); sp.
    + apply IHn2 with (i0 := i); sp.

      (*
  - Case "CL_eunion".
    apply CL_eunion.
    unfold per_eunion; sp.
    exists eqa1 eqa2 eqb1 eqb2 A A' B B'; sp.
    + apply IHn1 with (i0 := i); sp.
    + apply IHn2 with (i0 := i); sp.
    + apply IHn3 with (i0 := i); sp.
    + apply IHn4 with (i0 := i); sp.*)

  - Case "CL_image".
    apply CL_image.
    unfold per_image; sp.
    exists eqa A A' f f'; sp.
    apply IHn with (i0 := i); sp.

(*
  - Case "CL_eisect".
    apply CL_eisect.
    unfold per_eisect, etype_family; sp.
    exists eqa eqa' eqb; sp.
    exists A A' v v' B B'.
    exists f g f' g'; sp.
    apply IHn1 with (i0 := i); sp.
    apply IHn2 with (i0 := i); sp.
    apply recb with (i0 := i); sp.
    apply recb' with (i0 := i); sp.
*)

  - Case "CL_partial".
    apply CL_partial.
    unfold per_partial; sp.
    exists A1 A2 eqa; sp.
    apply IHn with (i0 := i); sp.

  - Case "CL_admiss".
    apply CL_admiss.
    unfold per_admiss; sp.
    exists A1 A2 eqa; sp.
    apply IHn with (i0 := i); sp.

  - Case "CL_mono".
    apply CL_mono.
    unfold per_mono; sp.
    exists A1 A2 eqa; sp.
    apply IHn with (i0 := i); sp.

  - Case "CL_ffatom".
    apply CL_ffatom.
    unfold per_ffatom; sp.
    exists A1 A2 x1 x2 a1 a2 eqa u; sp.
    apply IHn with (i0 := i); sp.

  - Case "CL_effatom".
    apply CL_effatom.
    unfold per_effatom; sp.
    exists A1 A2 x1 x2 a1 a2 eqa; sp.
    apply IHn with (i0 := i); sp.

  - Case "CL_ffatoms".
    apply CL_ffatoms.
    unfold per_ffatoms; sp.
    exists A1 A2 x1 x2 eqa; sp.
    apply IHn with (i0 := i); sp.

  - Case "CL_set".
    apply CL_set.
    unfold per_set, type_family; sp.
    exists eqa eqb; sp; try (exists A A' v v' B B'); sp.
    apply IHn with (i0 := i); sp.
    apply recb with (i0 := i); sp.

  - Case "CL_tunion".
    apply CL_tunion.
    unfold per_tunion, type_family; sp.
    exists eqa eqb; sp; try (exists A A' v v' B B'); sp.
    apply IHn with (i0 := i); sp.
    apply recb with (i0 := i); sp.

  - Case "CL_product".
    apply CL_product.
    unfold per_product, type_family; sp.
    exists eqa eqb; sp; try (exists A A' v v' B B'); sp.
    apply IHn with (i0 := i); sp.
    apply recb with (i0 := i); sp.
Qed.

(* --- a few useful abstractions *)

(* end hide *)

(**

  The predicate [tequality T1 T2] is true if [T1] and [T2] are equal
  types of the Nuprl type system.

 *)

Definition tequality {p} lib (T1 T2 : @CTerm p) :=
  { eq : per , nuprl lib T1 T2 eq }.

(**

  The predicate [type T] is true if [T] is a type of the Nuprl type
  system.

 *)

Definition type {p} lib (T : @CTerm p) := tequality lib T T.

(**

  The predicate [equality t1 t2 T] is true if [t1] and [t2] are equal
  members of the type [T].

 *)

Definition equality {p} lib (t1 t2 T : @CTerm p) :=
  { eq : per , nuprl lib T T eq # eq t1 t2 }.

(**

  [member t T] is true if [t] is a member of the type [T].

 *)

Definition member {p} lib (t T : @CTerm p) := equality lib t t T.

(**

  The predicate [tequalityi i T1 T2] is true if [T1] and [T2] are
  equal types of the Nuprl type system at level i.

 *)

Definition tequalityi {p} lib i (T1 T2 : @CTerm p) := equality lib T1 T2 (mkc_uni i).

(**

  The predicate [typei i T] is true if [T] is a type of the Nuprl type
  system at level i.

 *)

Definition typei {p} lib i (T : @CTerm p) := tequalityi lib i T T.

(* begin hide *)

(** This is similar to eqorsq but using 'equality' instead of 'eq' *)
Definition equorsq {p} lib (t1 t2 T : @CTerm p) := equality lib t1 t2 T {+} ccequivc lib t1 t2.
Definition equorsq2 {p} lib (t1 t2 t3 t4 T : @CTerm p) := equorsq lib t1 t2 T # equorsq lib t3 t4 T.

Lemma fold_equorsq {p} :
  forall lib (t1 t2 T : @CTerm p),
    (equality lib t1 t2 T {+} ccequivc lib t1 t2) = equorsq lib t1 t2 T.
Proof. sp. Qed.

Lemma fold_equorsq2 {p} :
  forall lib (t1 t2 t3 t4 T : @CTerm p),
    (equorsq lib t1 t2 T # equorsq lib t3 t4 T) = equorsq2 lib t1 t2 t3 t4 T.
Proof. sp. Qed.

(*
Definition cequorsq t1 t2 T := equality t1 t2 T {+} ccequivc t1 t2.
Definition cequorsq2 t1 t2 t3 t4 T := cequorsq t1 t2 T # cequorsq t3 t4 T.
*)

(*
(* Whichever the second one is, it fails with a universe error *)

Lemma tequality_sym :
  forall t1 t2,
    tequality t1 t2 -> tequality t2 t1.
Proof.
  unfold tequality; sp.
  exists eq.
  apply nuprl_sym; sp.
Qed.

Lemma tequality_mkc_uni :
  forall i : nat, tequality (mkc_uni i) (mkc_uni i).
Proof.
  generalize nuprl_mkc_uni; sp.
Qed.
*)

(* end hide *)

(**

  Because it is sometime useful to remember the levels of types, we
  define the following abstractions.  When we do not want to remember
  levels we will use [tequality] and when we want to remember levels,
  we will use [tequalityi].  Therefore, we use [eqtypes nolvl] when we
  do not to remember levels and we use [eqtypes (atlvl i)] we we do
  want to remember levels.

*)

Inductive lvlop : Type :=
| nolvl : lvlop
| atlvl : nat -> lvlop.

Definition eqtypes {p} lib lvl (T1 T2 : @CTerm p) :=
  match lvl with
    | nolvl => tequality lib T1 T2
    | atlvl l => tequalityi lib l T1 T2
  end.

Definition ltype {p} lib l (T : @CTerm p) := eqtypes lib l T T.

(* begin hide *)

(* end hide *)


(** * Predicates over observations (sequences of actions) *)
(** Basic definitions of observations. *)
Require Import Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrnat Ssreflect.ssrbool Ssreflect.eqtype Ssreflect.fintype Ssreflect.finfun Ssreflect.seq Ssreflect.tuple.
Require Import x86proved.bitsrep x86proved.x86.ioaction x86proved.charge.csetoid.
Require Import Coq.Setoids.Setoid Coq.Classes.RelationClasses Coq.Classes.Morphisms Coq.Program.Basics.
Require Import Coq.Lists.Streams.
Require Import x86proved.common_definitions.
(** Importing this file really only makes sense if you also import
    ilogic, so we force that. *)
Require Export x86proved.charge.ilogic x86proved.charge.bilogic x86proved.ilogicss.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Definition OPred := ILFunFrm Actions Prop.

Identity Coercion OPred_def : OPred >-> ILFunFrm.

Local Existing Instance ILFun_Ops.
Local Existing Instance ILFun_ILogic.

(** Giving these cost 1 ensures that they are preferred over spec/Prop instances *)
Instance osepILogicOps : ILogicOps OPred | 1 := _.
Instance osepILogic : ILogic OPred | 1 := _.
Global Opaque osepILogicOps osepILogic.

Definition mkOPred (P : Actions -> Prop) : OPred
  := @mkILFunFrm Actions _ Prop _ P (fun t t' H => (eq_rect _ _ (reflexivity _) _ (f_equal P H))).

(** ** Singleton predicate *)
Definition eq_opred s := mkOPred (fun s' => s === s').

(** ** The empty sequence of actions *)
Definition empOP : OPred := eq_opred nil.

(** ** A single output action *)
Definition outOP (c:Chan) (d:Data) : OPred := eq_opred [::Out c d].
Definition inOP (c:Chan) (d:Data) : OPred := eq_opred [::In c d].

(** ** A sequence of actions that splits into the concatenation of one
       satisfying P and one satisfying Q *)
Definition catOP (P Q: OPred) : OPred
 := mkOPred (fun o => exists o1 o2, o = o1++o2 /\ P o1 /\ Q o2).

(** ** Repetition *)
Fixpoint repOP n P := if n is n'.+1 then catOP P (repOP n' P) else empOP.

(** ** Kleene star *)
Definition starOP P : OPred := Exists n, repOP n P.

(** ** Rolling a function on numbers into a single [OPred] *)
Fixpoint rollOP n (f : nat -> OPred) : OPred :=
  match n with
    | 0 => empOP
    | S n' => catOP (f (S n')) (rollOP n' f)
  end.

(** ** Rolling a function on numbers into a single [OPred], with a starting and ending place *)
Fixpoint partial_rollOP (f : nat -> OPred) (start : nat) (count : nat)  : OPred :=
  if count is count'.+1
  then catOP (f start) (partial_rollOP f (start.+1) count')
  else empOP.

(** ** Rolling a function any number of places from a given starting location *)
Definition roll_starOP (f : nat -> OPred) (start : nat) : OPred := Exists n, partial_rollOP f start n.

(** ** Equality with a prefix of a stream *)
Definition eq_opred_stream (x : Stream Action) : OPred
  := mkOPred (list_is_prefix_of_stream x).

(** Generate [eq_opred_stream] by mapping and folding *)
Definition map_opred_to_stream {T} (f1 : T -> Action) (f2 : T -> Actions) (s : Stream T) : OPred
  := eq_opred_stream (flatten_stream (map (fun v => (f1 v, f2 v)) s)).

Global Opaque catOP inOP outOP eq_opred empOP repOP starOP rollOP partial_rollOP roll_starOP eq_opred_stream map_opred_to_stream.


(** This file contains main results of the paper **)

Require Import LibLN.
Require Main_ott Main_Proofs.
Require Recur_ott Recur_Proofs.
Require Full_ott Full_Proofs.
Require Alg_Proofs.

(* ******* Definition ******* *)

(* Lemmas in Section 4 *)

Module Type Metatheory.

(* **** Syntax and Relations **** *)

  (* Term *)
  Parameter trm : Set.
  Parameter trm_star : trm.

  (* Context *)
  Parameter binding : Set.
  Parameter bind_sub : trm -> trm -> binding.
  Definition env := LibEnv.env binding.
  Notation "x ~< e ~: A" := (x ~ bind_sub e A) (at level 20).
    (* In paper: x <: e : A *)

  (* Substitution *)
  Parameter subst : var -> trm -> trm -> trm.
  Parameter substenv : var -> trm -> binding -> binding.
  Notation "t [ z := u ]" := (subst z u t) (at level 68).
  Notation "t [[ z := u ]]" := (map (substenv z u) t) (at level 68).

  (* Operational Semantics *)
  Parameter reduct : trm -> trm -> Prop.
  Parameter value : trm -> Prop.
  Notation "t1 --> t2" := (reduct t1 t2) (at level 67).

  (* Unified Subtyping *)
  Parameter sub : env -> trm -> trm -> trm -> Prop.
  Notation "G |= e1 << e2 ~: A" := (sub G e1 e2 A) (at level 67).
    (* In paper: G |- e1 <: e2 : A *)
  Notation "G |= e ~: A" := (sub G e e A) (at level 67).
    (* In paper: G |- e : A *)

  (* Context Well-formedness *)
  Parameter wf : env -> Prop.
  Notation "|= G" := (wf G) (at level 67).
    (* In paper: |- G *)

(* **** Lemmas **** *)

  (* Lemma 4.1: Reflexivity *)
  Parameter lem_reflexivity : forall G e1 e2 A,
    G |= e1 << e2 ~: A ->
    G |= e1 ~: A /\ G |= e2 ~: A.

  (* Lemma 4.2: Left Reflexivity *)
  Parameter lem_left_reflexivity : forall G e1 e2 A,
    G |= e1 << e2 ~: A ->
    G |= e1 ~: A.

  (* Lemma 4.3: Right Reflexivity *)
  Parameter lem_right_reflexivity : forall G e1 e2 A,
    G |= e1 << e2 ~: A ->
    G |= e2 ~: A.

  (* Lemma 4.4: Weakening *)
  Parameter lem_weakening : forall G3 G1 G2 e1 e2 A,
    G1 & G3 |= e1 << e2 ~: A ->
    |= G1 & G2 & G3 ->
    G1 & G2 & G3 |= e1 << e2 ~: A.

  (* Lemma 4.5: Consistency of Typing *)
  Parameter lem_consistency_of_typing : forall B G e1 e2 A,
    G |= e1 ~: A ->
    G |= e1 << e2 ~: B ->
    G |= e1 << e2 ~: A.

  (* Lemma 4.6: Type Narrowing *)
  Parameter lem_type_narrowing : forall e A B G2 G1 C x e1 e2,
    G1 & x ~< e ~: B & G2 |= e1 << e2 ~: C ->
    G1 |= e ~: A ->
    G1 |= A << B ~: trm_star  ->
    G1 & x ~< e ~: A & G2 |= e1 << e2 ~: C.

  (* Lemma 4.7: Bound Narrowing *)
  Parameter lem_bound_narrowing : forall e G2 G1 B C x e' e1 e2,
    G1 & x ~< e ~: B & G2 |= e1 << e2 ~: C ->
    G1 |= e' << e ~: B ->
    G1 & x ~< e' ~: B & G2 |= e1 << e2 ~: C.

  (* Lemma 4.8: Generalized Transitivity *)
  Parameter lem_generalized_transitivity : forall e2 G e1 e3 A B,
    G |= e1 << e2 ~: A ->
    G |= e2 << e3 ~: B ->
    G |= e1 << e3 ~: A.

  (* Lemma 4.9: Transitivity *)
  Parameter lem_transitivity : forall e2 G e1 e3 A,
    G |= e1 << e2 ~: A ->
    G |= e2 << e3 ~: A ->
    G |= e1 << e3 ~: A.

  (* Lemma 4.10: Substitution *)
  Parameter lem_substitution : forall B e (G2:env) e' (G1:env) x e1 e2 A,
    G1 |= e' << e ~: B ->
    G1 & x ~< e ~: B & G2 |= e1 << e2 ~: A ->
    G1 & (G2 [[x := e']]) |= (e1 [x := e']) << (e2 [x := e']) ~: (A [x := e']).

  (* Lemma 4.11: Correctness of Types *)
  Parameter lem_correctness_of_types : forall G e1 e2 A,
    G |= e1 << e2 ~: A ->
    G |= A ~: trm_star.

  (* Lemma 4.12: Determinacy of Reduction *)
  Parameter lem_determinacy_of_reduction : forall e e1 e2,
    e --> e1 -> e --> e2 -> e1 = e2.

  (* Lemma 4.13: Type Preservation *)
  Parameter lem_type_preservation : forall G e e' A,
    G |= e ~: A ->
    e --> e' ->
    G |= e' ~: A.

  (* Lemma 4.14: Subtype Preservation *)
  Parameter lem_subtype_preservation : forall G e1 e2 e1' e2' A,
    G |= e1 << e2 ~: A ->
    e1 --> e1' ->
    e2 --> e2' ->
    G |= e1' << e2' ~: A.

  (* Lemma 4.15: Generalized Subtype Preservation *)
  Parameter SubLemma : env -> trm -> trm -> trm -> Prop.
  (* SubLemma is defined as follows: *)
  (* Definition SubLemma G e1 e2 A := *)
  (*   match e1,e2 with *)
  (*   | trm_castup B e1',trm_castup _ e2' => forall A' B', *)
  (*       A --> A' -> B --> B' -> G |= e1' << e2' ~: A' *)
  (*   | _,_ => forall e1' e2', *)
  (*       e1 --> e1' -> e2 --> e2' -> G |= e1' << e2' ~: A *)
  (*   end. *)
  Parameter lem_generalized_subtype_preservation : forall G e1 e2 A,
    G |= e1 << e2 ~: A -> SubLemma G e1 e2 A.

  (* Lemma 4.16: Reduction Exists in the Middle *)
  Parameter lem_reduction_exists_in_the_middle : forall G B A A' C C' D,
    G |= B << A ~: D ->
    A --> A' ->
    G |= C << B ~: D ->
    C --> C' ->
    exists B', B --> B'.

  (* Lemma 4.17: Progress *)
  Parameter lem_progress : forall e A,
    empty |= e ~: A ->
    value e \/ exists e', e --> e'.

  (* Lemma 4.18: Generalized Progress *)
  Parameter lem_generalized_progress : forall G e A,
    G |= e ~: A ->
    value e \/ exists e', e --> e'.

End Metatheory.

(* Theorems in Section 5 *)

Module Type Algorithmic.

(* **** Syntax and Relations **** *)

  (* Term *)
  Parameter trm : Set.

  (* Context *)
  Parameter binding : Set.
  Definition env := LibEnv.env binding.

  (* Unified Subtyping *)
  Parameter sub : env -> trm -> trm -> trm -> Prop.
  Notation "G |= e1 << e2 ~: A" := (sub G e1 e2 A) (at level 67).
    (* In paper: G |- e1 <: e2 : A *)

  (* Erasure *)
  Parameter erasure : trm -> trm.
  Notation "[# e #]" := (erasure e) (at level 2).
    (* In paper: |e| *)
  Parameter rem_anno_env : binding -> binding.
  Notation "{# G #}" := (map rem_anno_env G) (at level 2).
    (* In paper: |G| *)

  (* Algorithmic Subtyping *)
  Parameter dsub : env -> trm -> trm -> Prop.

  (* Bidirectional Typing *)
  Parameter dir : Set. (* Directions *)
  Parameter inf : dir. (* Synthesis direction *)
  Parameter dtyping : dir -> env -> trm -> trm -> Prop.

(* **** Theorems **** *)

  (* Theorem 5.1: Soundness of Algorithm *)
  Parameter lem_soundness : forall G d e1 e2 A,
    dtyping d G e1 A ->
    dtyping d G e2 A ->
    dsub G e1 e2 ->
    {#G#} |= [#e1#] << [#e2#] ~: [#A#].

  (* Theorem 5.2: Completeness of Algorithm *)
  Parameter lem_completeness : forall G e1 e2 A,
     G |= e1 << e2 ~: A ->
     dsub G e1 e2 /\
     exists e1' e2',
       dtyping inf G e1' A /\
       dtyping inf G e2' A /\
       [#e1'#] = e1 /\
       [#e2'#] = e2.

End Algorithmic.

(* ******* Verification ******* *)

(* "Main" variant implements all lemmas in Section 4 *)

Module MainImpl : Metatheory.
  Module M := Main_ott.
  Module P := Main_Proofs.
  Definition trm := M.trm.
  Definition trm_star := M.trm_star.
  Definition binding := M.binding.
  Definition bind_sub := M.bind_sub.
  Definition env := M.env.
  Definition subst z u t := M.subst_trm u z t.
  Definition substenv := P.substenv.
  Definition reduct := M.reduct.
  Definition value := M.value.
  Definition sub := M.sub.
  Definition wf := M.wf.

  Definition lem_reflexivity := P.sub_refl.
  Definition lem_left_reflexivity := P.sub_refl_left.
  Definition lem_right_reflexivity := P.sub_refl_right.
  Definition lem_weakening := P.sub_weaken.
  Definition lem_consistency_of_typing := P.sub_typekeep.
  Definition lem_type_narrowing := P.sub_narrowing_typ.
  Definition lem_bound_narrowing := P.sub_narrowing.
  Definition lem_generalized_transitivity := P.sub_trans_aux.
  Definition lem_transitivity := P.sub_trans.
  Definition lem_substitution := P.sub_substitution.
  Definition lem_correctness_of_types := P.sub_wf_from_sub.
  Definition lem_determinacy_of_reduction := P.reduct_determ.
  Definition lem_type_preservation := P.subject_reduction_wh.
  Definition lem_subtype_preservation := P.sub_reduct_preserve.
  Definition SubLemma := P.SubLemma.
  Definition lem_generalized_subtype_preservation := P.sub_reduct_preserve1.
  Definition lem_reduction_exists_in_the_middle := P.sub_reduct_middle.
  Definition lem_progress := P.progress_empty_wh.
  Definition lem_generalized_progress := P.progress_wh.
End MainImpl.

(* "Recur" variant implements all lemmas in Section 4 *)

Module RecurImpl : Metatheory.
  Module M := Recur_ott.
  Module P := Recur_Proofs.
  Definition trm := M.trm.
  Definition trm_star := M.trm_star.
  Definition binding := M.binding.
  Definition bind_sub := M.bind_sub.
  Definition env := M.env.
  Definition subst z u t := M.subst_trm u z t.
  Definition substenv := P.substenv.
  Definition reduct := M.reduct.
  Definition value := M.value.
  Definition sub := M.sub.
  Definition wf := M.wf.

  Definition lem_reflexivity := P.sub_refl.
  Definition lem_left_reflexivity := P.sub_refl_left.
  Definition lem_right_reflexivity := P.sub_refl_right.
  Definition lem_weakening := P.sub_weaken.
  Definition lem_consistency_of_typing := P.sub_typekeep.
  Definition lem_type_narrowing := P.sub_narrowing_typ.
  Definition lem_bound_narrowing := P.sub_narrowing.
  Definition lem_generalized_transitivity := P.sub_trans_aux.
  Definition lem_transitivity := P.sub_trans.
  Definition lem_substitution := P.sub_substitution.
  Definition lem_correctness_of_types := P.sub_wf_from_sub.
  Definition lem_determinacy_of_reduction := P.reduct_determ.
  Definition lem_type_preservation := P.subject_reduction_wh.
  Definition lem_subtype_preservation := P.sub_reduct_preserve.
  Definition SubLemma := P.SubLemma.
  Definition lem_generalized_subtype_preservation := P.sub_reduct_preserve1.
  Definition lem_reduction_exists_in_the_middle := P.sub_reduct_middle.
  Definition lem_progress := P.progress_empty_wh.
  Definition lem_generalized_progress := P.progress_wh.
End RecurImpl.

(* "Full" variant implements all lemmas in Section 4 *)

Module FullImpl : Metatheory.
  Module M := Full_ott.
  Module P := Full_Proofs.
  Definition trm := M.trm.
  Definition trm_star := M.trm_star.
  Definition binding := M.binding.
  Definition bind_sub := M.bind_sub.
  Definition env := M.env.
  Definition subst z u t := M.subst_trm u z t.
  Definition substenv := P.substenv.
  Definition reduct := M.reduct.
  Definition value := M.value.
  Definition sub := M.sub.
  Definition wf := M.wf.

  Definition lem_reflexivity := P.sub_refl.
  Definition lem_left_reflexivity := P.sub_refl_left.
  Definition lem_right_reflexivity := P.sub_refl_right.
  Definition lem_weakening := P.sub_weaken.
  Definition lem_consistency_of_typing := P.sub_typekeep.
  Definition lem_type_narrowing := P.sub_narrowing_typ.
  Definition lem_bound_narrowing := P.sub_narrowing.
  Definition lem_generalized_transitivity := P.sub_trans_aux.
  Definition lem_transitivity := P.sub_trans.
  Definition lem_substitution := P.sub_substitution.
  Definition lem_correctness_of_types := P.sub_wf_from_sub.
  Definition lem_determinacy_of_reduction := P.reduct_determ.
  Definition lem_type_preservation := P.subject_reduction_wh.
  Definition lem_subtype_preservation := P.sub_reduct_preserve.
  Definition SubLemma := P.SubLemma.
  Definition lem_generalized_subtype_preservation := P.sub_reduct_preserve1.
  Definition lem_reduction_exists_in_the_middle := P.sub_reduct_middle.
  Definition lem_progress := P.progress_empty_wh.
  Definition lem_generalized_progress := P.progress_wh.
End FullImpl.

(* "Alg" proves all theorems in Section 5 *)

Module AlgImpl : Algorithmic.
  Module M := Main_ott.
  Module P := Alg_Proofs.
  Definition trm := M.trm.
  Definition binding := M.binding.
  Definition env := M.env.
  Definition sub := M.sub.
  Definition erasure := P.remove_anno.
  Definition rem_anno_env := P.rem_anno_env.
  Definition dsub := P.dsub.
  Definition dir := P.dir.
  Definition inf := P.inf.
  Definition dtyping := P.dtyping.

  Definition lem_soundness := P.bidir_to_sub.
  Definition lem_completeness := P.sub_to_bidir.
End AlgImpl.


(** * Well-founded relation on [reachable] *)
Require Import Fiat.Parsers.ContextFreeGrammar.Core Fiat.Parsers.Reachable.OnlyFirst.Reachable.
Require Import Fiat.Parsers.BaseTypes.

Section rel.
  Context {Char} {HSLM : StringLikeMin Char} {predata : @parser_computational_predataT Char} {G : grammar Char}.

  Section size.
    Context {ch : Char} {valid : nonterminals_listT}.
    Definition size_of_reachable_from_item'
               (size_of_reachable_from_productions : forall {pats}, reachable_from_productions G ch valid pats -> nat)
               {it} (p : reachable_from_item G ch valid it) : nat
      := match p with
           | ReachableTerminal _ _ => 0
           | ReachableNonTerminal _ _ p' => S (size_of_reachable_from_productions p')
         end.

    Fixpoint size_of_reachable_from_productions {pats} (p : reachable_from_productions G ch valid pats) : nat
      := match p with
           | ReachableHead _ _ p' => S (size_of_reachable_from_production p')
           | ReachableTail _ _ p' => S (size_of_reachable_from_productions p')
         end
    with size_of_reachable_from_production {pat} (p : reachable_from_production G ch valid pat) : nat
         := match p with
              | ReachableProductionHead _ _ p' => S (size_of_reachable_from_item' (@size_of_reachable_from_productions) p')
              | ReachableProductionTail _ _ _ p' => S (size_of_reachable_from_production p')
            end.

    Definition size_of_reachable_from_item
               {it} (p : reachable_from_item G ch valid it) : nat
      := @size_of_reachable_from_item' (@size_of_reachable_from_productions) it p.
  End size.
End rel.