(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(* This contribution was updated for Coq V5.10 by the COQ workgroup.        *)
(* January 1995                                                             *)
(****************************************************************************)
(*                                                                          *)
(*      Coq V5.8                                                            *)
(*                                                                          *)
(*                                                                          *)
(*      Alternating Bit Protocol                                            *)
(*                                                                          *)
(*      Jan Friso Groote                                                    *)
(*      Utrecht University                                                  *)
(*                                                                          *)
(*      November 1992                                                       *)
(*                                                                          *)
(* From bezem@phil.ruu.nl Fri Apr  2 13:14:31 1993                          *)
(*                                                                          *)
(****************************************************************************)
(*                               abp_lem25.v                                *)
(****************************************************************************)

Require Import abp_base.
Require Import abp_defs.
Require Import abp_lem1.
Require Import abp_lem2.

Theorem Lem10 :
 forall d : D,
 seq (ia frame c6 (tuple e1)) (X1 d) =
 enc H
   (mer (seq (ia frame s6 (tuple e1)) (L i))
      (mer (R i) (mer (K i) (seq (Tn_d d e0) (seq (Sn e1) (S i)))))).

intros.
elim EXPH4.
elim Lmers6.
elim LmerK.
elim LmerTnd.
pattern (R i) at 1 3 4 5 in |- *.
elim ProcR.
elim LmerRn.
elim CommTn_dK.
elim (SC3 (seq (Rn e1) (seq (Rn e0) (R i))) (K i)).
elim CommKRn.
elim
 (SC3 (seq (Rn e1) (seq (Rn e0) (R i))) (seq (Tn_d d e0) (seq (Sn e1) (S i)))).
elim CommTn_dRn.
elim CommKs6.
elim CommRns6.
pattern e1 at 1 2 in |- *.
elimtype (toggle e0 = e1).
elim CommTn_ds6_b.

repeat elim A6.
repeat elim A6'.
unfold X1 in |- *.
elim
 (SC6 (mer (seq (Sn_d d e0) (seq (Sn e1) (S i))) (mer (R i) (K i))) (L i)).
elim SC7.
elim SC7.
elim (SC6 (mer (K i) (L i)) (R i)).
elim SC7.
apply refl_equal.
elim Toggle1.
apply refl_equal.
Qed.

Theorem Lem11 :
 forall d : D,
 seq (ia frame c6 sce) (X1 d) =
 enc H
   (mer (seq (ia frame s6 sce) (L i))
      (mer (R i) (mer (K i) (seq (Tn_d d e0) (seq (Sn e1) (S i)))))).

intros.
elim EXPH4.
elim Lmers6.
elim LmerK.
elim LmerTnd.
pattern (R i) at 1 3 4 5 in |- *.
elim ProcR.
elim LmerRn.
elim CommTn_dK.
elim (SC3 (seq (Rn e1) (seq (Rn e0) (R i))) (K i)).
elim CommKRn.
elim
 (SC3 (seq (Rn e1) (seq (Rn e0) (R i))) (seq (Tn_d d e0) (seq (Sn e1) (S i)))).
elim CommTn_dRn.
elim CommKs6.
elim CommRns6.
elim CommTn_ds6_sce.
repeat elim A6.
repeat elim A6'.
unfold X1 in |- *.
elim
 (SC6 (mer (seq (Sn_d d e0) (seq (Sn e1) (S i))) (mer (R i) (K i))) (L i)).
elim SC7.
elim SC7.
elimtype (mer (K i) (mer (L i) (R i)) = mer (R i) (mer (K i) (L i))).
apply refl_equal.
elim (SC6 (mer (K i) (L i)) (R i)).
elim SC7.
apply refl_equal.
Qed.

Theorem Lem12 :
 forall d : D,
 seq (ia Frame c2 (Tuple e0 d))
   (alt
      (seq (ia one int i)
         (seq (ia Frame c3 (Tuple e0 d)) (seq (ia D s4 d) (X2 d))))
      (seq (ia one int i)
         (seq (ia Frame c3 lce)
            (seq (ia frame c5 (tuple e1))
               (seq
                  (alt (seq (ia one int i) (ia frame c6 (tuple e1)))
                     (seq (ia one int i) (ia frame c6 sce)))
                  (X1 d)))))) = X1 d.
intros.
pattern (X1 d) at 2 in |- *.
elim Lem3.
elim Lem4.
elim Lem5.
elim Lem6.
elim Lem7.
elim Lem8.
elim Lem9.
elim Lem10.
elim Lem11.
elim A4.
elim A5.
elim A5.
apply refl_equal.
Qed.

Theorem Lem13 :
 forall d : D,
 seq (ia Frame c2 (Tuple e1 d))
   (enc H
      (mer (seq (Tn_d d e1) (S i))
         (mer
            (seq
               (alt (seq (ia one int i) (ia Frame s3 (Tuple e1 d)))
                  (seq (ia one int i) (ia Frame s3 lce)))
               (K i)) (mer (L i) (seq (Rn e0) (R i)))))) =
 Y1 d.

intro.
unfold Y1 at 1 in |- *.
elim (EXPH4 (seq (Sn_d d e1) (S i))).
elim LmerSnd.
elim LmerK.
elim LmerL.
pattern (R i) at 2 3 5 8 in |- *.
elim ProcR.
elim LmerRn.
elim CommLRn.
elim CommKL.
elim CommKRn.
elim ProcSn_d.
elim A5.
elim Comms2K.
elim Comms2Rn.
elim Comms2L.
repeat elim A6.
repeat elim A6'.
elim SC7.
apply refl_equal.
Qed.

Theorem Lem14 :
 forall d : D,
 alt
   (seq (ia one int i)
      (enc H
         (mer (seq (ia Frame s3 (Tuple e1 d)) (K i))
            (mer (seq (Tn_d d e1) (S i)) (mer (L i) (seq (Rn e0) (R i)))))))
   (seq (ia one int i)
      (enc H
         (mer (seq (ia Frame s3 lce) (K i))
            (mer (seq (Tn_d d e1) (S i)) (mer (L i) (seq (Rn e0) (R i))))))) =
 enc H
   (mer (seq (Tn_d d e1) (S i))
      (mer
         (seq
            (alt (seq (ia one int i) (ia Frame s3 (Tuple e1 d)))
               (seq (ia one int i) (ia Frame s3 lce)))
            (K i)) (mer (L i) (seq (Rn e0) (R i))))).
intros.
elim (EXPH4 (seq (Tn_d d e1) (S i))).
elim LmerTnd.
elim LmerL.
elim A4.
elim A5.
elim A5.
elim Lmeri.
elim LmerRn.
elim CommLRn.
elim CommiL.
elim CommiRn.
elim CommTn_dL.
elim CommTn_di.
elim CommTn_dRn.
repeat elim A6.
repeat elim A6'.
apply refl_equal.
Qed.

Theorem Lem15 :
 forall d : D,
 seq (ia Frame c3 lce)
   (enc H
      (mer (K i)
         (mer (seq (ia frame s5 (tuple e0)) (seq (Rn e0) (R i)))
            (mer (seq (Tn_d d e1) (S i)) (L i))))) =
 enc H
   (mer (seq (ia Frame s3 lce) (K i))
      (mer (seq (Tn_d d e1) (S i)) (mer (L i) (seq (Rn e0) (R i))))).
intros.
elim (EXPH4 (seq (ia Frame s3 lce) (K i))).
elim Lmers3.
elim LmerTnd.
elim LmerL.
elim LmerRn.
elim CommLRn.
elim CommTn_dL.
elim CommTn_dRn.
elim Comms3Tn_d.
elim Comms3L.
elim Comms3Rn_lce.
repeat elim A6'.
repeat elim A6.
elim SC7.
elim A5.
apply refl_equal.
Qed.

Theorem Lem16 :
 forall d : D,
 seq (ia Frame c3 (Tuple e1 d))
   (enc H
      (mer (K i)
         (mer (seq (ia D s4 d) (seq (ia frame s5 (tuple e1)) (R i)))
            (mer (seq (Tn_d d e1) (S i)) (L i))))) =
 enc H
   (mer (seq (ia Frame s3 (Tuple e1 d)) (K i))
      (mer (seq (Tn_d d e1) (S i)) (mer (L i) (seq (Rn e0) (R i))))).
intros.
elim (EXPH4 (seq (ia Frame s3 (Tuple e1 d)) (K i))).
elim Lmers3.
elim LmerTnd.
elim LmerL.
elim LmerRn.
elim CommLRn.
elim CommTn_dL.
elim CommTn_dRn.
elim Comms3Tn_d.
elim Comms3L.
pattern e1 at 4 in |- *.
elimtype (toggle e0 = e1).
elim Comms3Rn_b.
repeat elim A6'.
elim Toggle1.
apply refl_equal.
elim Toggle1.
apply refl_equal.
Qed.

Theorem Lem17 :
 forall d : D,
 seq (ia D s4 d) (Y2 d) =
 enc H
   (mer (K i)
      (mer (seq (ia D s4 d) (seq (ia frame s5 (tuple e1)) (R i)))
         (mer (seq (Tn_d d e1) (S i)) (L i)))).
intros.
elim EXPH4.
elim LmerK.
elim Lmers4.
elim LmerTnd.
elim LmerL.
elim CommTn_dL.
elim CommTn_ds4.
elim CommLs4.
elim CommKs4.
elim (SC3 (seq (Tn_d d e1) (S i)) (K i)).
elim CommTn_dK.
elim CommKL.
repeat elim A6.
repeat elim A6'.
unfold Y2 in |- *.
elim (SC6 (seq (ia frame s5 (tuple e1)) (R i)) (L i)).
elim (SC6 (mer (seq (ia frame s5 (tuple e1)) (R i)) (L i)) (K i)).
elim
 (SC6 (mer (mer (seq (ia frame s5 (tuple e1)) (R i)) (L i)) (K i))
    (seq (Tn_d d e1) (S i))).
elim SC7.
elim SC7.
elim (SC6 (mer (K i) (seq (Tn_d d e1) (S i))) (L i)).
elim SC7.
apply refl_equal.
Qed.

Theorem Lem18 :
 forall d : D,
 seq (ia frame c5 (tuple e0))
   (enc H
      (mer (seq (Rn e0) (R i))
         (mer
            (alt (seq (ia one int i) (seq (ia frame s6 (tuple e0)) (L i)))
               (seq (ia one int i) (seq (ia frame s6 sce) (L i))))
            (mer (K i) (seq (Tn_d d e1) (S i)))))) =
 enc H
   (mer (K i)
      (mer (seq (ia frame s5 (tuple e0)) (seq (Rn e0) (R i)))
         (mer (seq (Tn_d d e1) (S i)) (L i)))).
intros.
elim (EXPH4 (K i)).
elim LmerK.
elim LmerL.
elim Lmers5.
elim LmerTnd.
elim CommTn_dL.
elim CommTn_ds5.
elim CommLs5.
elim CommKs5.
elim CommKL.
elim CommTn_dK.
repeat elim A6.
repeat elim A6'.
apply refl_equal.
Qed.

Theorem Lem19 :
 forall d : D,
 alt
   (seq (ia one int i)
      (enc H
         (mer (seq (ia frame s6 (tuple e0)) (L i))
            (mer (seq (Rn e0) (R i)) (mer (K i) (seq (Tn_d d e1) (S i)))))))
   (seq (ia one int i)
      (enc H
         (mer (seq (ia frame s6 sce) (L i))
            (mer (seq (Rn e0) (R i)) (mer (K i) (seq (Tn_d d e1) (S i))))))) =
 enc H
   (mer (seq (Rn e0) (R i))
      (mer
         (alt (seq (ia one int i) (seq (ia frame s6 (tuple e0)) (L i)))
            (seq (ia one int i) (seq (ia frame s6 sce) (L i))))
         (mer (K i) (seq (Tn_d d e1) (S i))))).

intros.
elim (EXPH4 (seq (Rn e0) (R i))).
elim Lmeri.
elim LmerK.
elim LmerTnd.
elim LmerRn.
elim (SC3 (seq (Rn e0) (R i)) (seq (Tn_d d e1) (S i))).
elim CommTn_dRn.
elim (SC3 (seq (Rn e0) (R i)) (K i)).
elim CommKRn.
elim
 (SC3 (seq (Rn e0) (R i))
    (alt (seq (ia one int i) (seq (ia frame s6 (tuple e0)) (L i)))
       (seq (ia one int i) (seq (ia frame s6 sce) (L i))))).

elim CommiRn.
elim
 (SC3
    (alt (seq (ia one int i) (seq (ia frame s6 (tuple e0)) (L i)))
       (seq (ia one int i) (seq (ia frame s6 sce) (L i))))
    (seq (Tn_d d e1) (S i))).

elim CommTn_di.
elim CommTn_dK.
elim CommiK.
repeat elim A6.
repeat elim A6'.
apply refl_equal.
Qed.


Require Import Coq.Lists.List.
Require Import ExtLib.Tactics.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Data.ListNth.
Require Import MirrorCore.TypesI.

Set Implicit Arguments.
Set Strict Implicit.
Set Printing Universes.

Polymorphic Lemma f_eq@{A B}
: forall {T : Type@{A}} {U : Type@{B}} (f : T -> U) (a b : T), a = b -> f a = f b.
Proof. intros. destruct H. reflexivity. Defined.

Section Env.
  Variable typ : Set.
  Context {RType_typ : RType typ}.

  (** Environments **)
  Definition tenv : Set := list typ.
  Definition env : Type@{Urefl} := list (sigT (@typD _ _)).

  Definition typeof_env (e : env) : tenv :=
    map (@projT1 _ _) e.

  Fixpoint valof_env (e : env) : hlist typD (typeof_env e) :=
    match e as e return hlist typD (typeof_env e) with
    | nil => Hnil
    | t :: ts => Hcons (projT2 t) (valof_env ts)
    end.

  Definition lookupAs (e : env) (n : nat) (ty : typ) : option (typD ty) :=
    match nth_error e n with
      | None => None
      | Some (existT _ t v) =>
        match type_cast ty t with
          | Some pf => Some (Relim (fun x => x) pf v)
          | None => None
        end
    end.

  Theorem lookupAs_weaken : forall (a b : env) n t x,
    lookupAs a n t = Some x ->
    lookupAs (a ++ b) n t = Some x.
  Proof.
    clear. unfold lookupAs. intros.
    consider (nth_error a n); intros.
    { erewrite nth_error_weaken by eassumption. auto. }
    { exfalso.
      refine match H0 in _ = x return match x return Prop with
                                      | None => True
                                      | Some _ => False
                                      end
             with
             | eq_refl => I
             end. }
  Qed.

  Fixpoint join_env@{} (gs : list typ) (hgs : hlist@{Set Urefl} (@typD _ _) gs) : env :=
    match hgs with
    | Hnil => nil
    | Hcons c d => existT _ _ c :: join_env d
    end.

  Fixpoint split_env@{} (gs : env) : sigT (hlist@{Set Urefl} (@typD _ _)) :=
    match gs with
    | nil => existT _ nil Hnil
    | g :: gs =>
      let res := split_env gs in
      existT _ (projT1 g :: projT1 res) (Hcons (projT2 g) (projT2 res))
    end.

  Theorem split_env_app : forall (gs gs' : env),
    split_env (gs ++ gs') =
    let (a,b) := split_env gs in
    let (c,d) := split_env gs' in
    existT _ ((a ++ c) : list (typ : Set)) (hlist_app b d).
  Proof.
    induction gs; simpl; intros.
    { destruct (split_env gs'); reflexivity. }
    { destruct a. rewrite IHgs.
      destruct (split_env gs).
      destruct (split_env gs'). reflexivity. }
  Qed.

  Theorem split_env_projT1@{} : forall (x : env),
    projT1 (split_env x) = map (@projT1 _ _) x.
  Proof.
    induction x; simpl; intros; auto.
    f_equal. auto.
  Qed.

  Theorem split_env_typeof_env@{} : forall (x : env),
    projT1 (split_env x) = typeof_env x.
  Proof.
    exact split_env_projT1.
  Qed.

  Lemma join_env_app
  : forall a b (ax : hlist _ a) (bx : hlist _ b),
      join_env ax ++ join_env bx = join_env (hlist_app ax bx).
  Proof.
    refine (fix rec (a b : list typ) (ax : hlist@{Set Urefl} _ _) {struct ax} :=
              match ax with
              | Hnil => _
              | Hcons _ _ => _
              end).
    reflexivity.
    simpl. intro. rewrite rec. reflexivity.
  Qed.

  Theorem split_env_nth_error : forall (ve : env) v tv,
    nth_error ve v = Some tv <->
    match nth_error (projT1 (split_env ve)) v as t
          return match t return Type@{Urefl} with
                   | Some v => typD v
                   | None => unit
                 end -> Prop
    with
      | None => fun _ => False
      | Some v => fun res => tv = existT _ v res
    end (hlist_nth (projT2 (split_env ve)) v).
  Proof.
    clear.
    induction ve; simpl; intros.
    { destruct v; simpl in *; intuition; inversion H. }
    { destruct v; simpl in *.
      { intuition.
        { inversion H; subst. destruct tv; reflexivity. }
        { subst. destruct a. reflexivity. } }
      { eapply IHve. } }
  Qed.

  Lemma split_env_nth_error_None
  : forall (ve : env) (v : nat),
      nth_error ve v = None <->
      nth_error (projT1 (split_env ve)) v = None.
  Proof.
    clear.
    induction ve; simpl; intros.
    { destruct v; simpl; intuition. }
    { destruct v; simpl.
      { unfold value. intuition congruence. }
      { rewrite IHve; auto. reflexivity. } }
  Qed.

  Lemma split_env_length : forall (a : env),
    length a = length (projT1 (split_env a)).
  Proof.
    induction a; simpl; auto.
  Qed.

  Theorem split_env_join_env : forall (a : tenv) b,
    split_env (@join_env a b) = existT _ a b.
  Proof.
    induction b; simpl; auto.
    rewrite IHb. eauto.
  Qed.

  Theorem join_env_split_env : forall x,
    join_env (projT2 (split_env x)) = x.
  Proof.
    induction x; simpl; auto.
    rewrite IHx. destruct a; reflexivity.
  Qed.

  Lemma split_env_projT2_join_env@{} : forall (x : tenv) (h : hlist@{Set Urefl} _ x) (vs : env),
    split_env vs = @existT _ _ x h ->
    vs = join_env h.
  Proof.
    induction h using (@hlist_ind@{Set Urefl Set}); destruct vs; simpl; intros; inversion H; auto.
    subst.
    rewrite join_env_split_env. destruct s; auto.
  Qed.

  Lemma typeof_env_join_env@{} : forall a (b : hlist _ a),
    typeof_env (join_env b) = a.
  Proof.
    induction a; simpl; intros.
    { rewrite (HList.hlist_eta b). reflexivity. }
    { rewrite (HList.hlist_eta b). simpl. rewrite IHa.
      reflexivity. }
  Qed.

  Lemma map_projT1_split_env@{}
  : forall vs x h,
      split_env vs = existT (hlist _) x h ->
      map (@projT1 _ _) vs = x.
  Proof.
    intros. change x with (projT1 (existT _ x h)).
    rewrite <- H.
    rewrite split_env_projT1. reflexivity.
  Qed.

  Lemma nth_error_join_env@{}
  : forall (ls : tenv) (hls : hlist@{Set Urefl} _ ls) v t,
      nth_error ls v = Some t ->
      exists val,
        nth_error (join_env hls) v = Some (@existT _ _ t val).
  Proof.
    clear.
    induction hls using (@hlist_ind@{Set Urefl Set}); simpl; intros.
    { destruct v; inversion H. }
    { destruct v; simpl in *; eauto.
      inversion H; clear H; subst. eauto. }
  Qed.

  Theorem split_env_eta@{} : forall (vs : env),
      split_env vs = existT _ (typeof_env vs) (valof_env vs).
  Proof.
    induction vs; simpl; auto.
    rewrite IHvs. simpl. reflexivity.
  Qed.

End Env.

Arguments env {typ _} : rename.
Arguments join_env {typ _ _} _ : rename.
Arguments split_env {typ _} _ : rename.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool seq.
Require while.

(** * %\goto%#Goto#: A Low-level Language

   This section corresponds to Section 2 in %\cite{saabasuustalu2007}%#[Saabas&Uustalu2007]#. *)

Declare Scope goto_scope.

Module Goto (while_semop_m : while.WHILE_SEMOP).

Import while_semop_m.

(** ** Syntax and (Small-step) Semantics of %\goto\ %#Goto# *)

Definition label := nat.

Lemma label_dec : forall (l l' : label), { l = l' } + { l <> l' }.
Proof. decide equality. Qed.

Definition lstate := option (label * state).

(** printing ||- %\ensuremath{\vdash}%*)

(** For the operational semantics of one-step, non-branching instructions of
   %\goto%#Goto#, we use the one-step commands
   (type %\coqdocvar{cmd0}%#cmd0# and operational semantics noted $\cdot-\cdot\to\cdot$#-- ---->#)
   %(see Section \ref{sec:while})%. *)

(** printing ----> %\ensuremath{\rightarrow}%*)

(** printing ---> %\ensuremath{\rightarrow}%*)

Local Open Scope while_cmd_scope.

Reserved Notation " c ||- s ---> t " (at level 82, no associativity).
Inductive exec0_label : lstate -> cmd0 -> lstate -> Prop :=
| exec0_label_cmd0 : forall s c s', Some s -- c ----> Some s' ->
  forall l, exec0_label (Some (l, s)) c (Some (S l, s'))
| exec0_label_err : forall s c, Some s -- c ----> None ->
  forall l, exec0_label (Some (l, s)) c None
where " c ||- s ---> t " := (exec0_label s c t) : goto_scope.

Local Open Scope goto_scope.

(** Branches may be conditional or not. For conditional branches, we use a language of boolean expressions
   (type %\coqdocvar{expr\_b}%#expr_b#)
   %(see Section \ref{sec:while})%: *)

Inductive branch : Type := jmp : label -> branch | cjmp : expr_b -> label -> branch.

(** printing |>> %\ensuremath{\gg}%*)

Reserved Notation "c ||- s |>> t" (at level 82, no associativity).

(** Note that branches never cause errors: *)

Inductive exec_branch : label * state -> branch -> label * state -> Prop :=
| exec_jmp : forall l s l', jmp l' ||- (l, s) |>> (l', s)
| exec_cjmp_true : forall l s t l', eval_b t s -> cjmp t l' ||- (l, s) |>> (l', s)
| exec_cjmp_false : forall l s t l', ~ eval_b t s -> cjmp t l' ||- (l, s) |>> (S l, s)
where "c ||- s |>> t" := (exec_branch s c t) : goto_scope.

(** Unstructured programs are lists of labeled (branching or not) instructions. They are
   wellformed when no instruction has two labels: *)

Inductive insn : Type := C : cmd0 -> insn | B : branch -> insn.

Definition code := seq (label * insn).

Reserved Notation "c ||- s ->> t" (at level 82, no associativity).

Definition wellformed_goto (c : code) : Prop :=
  forall l i i', List.In (l, i) c -> List.In (l, i') c -> i = i'.

Lemma wellformed_goto_app c : wellformed_goto c ->
  forall c1 c2, c = c1 ++ c2 -> wellformed_goto c1 /\ wellformed_goto c2.
Proof.
move=> wf_c c1 c2 Hc; subst; split => x l l' l_c1 l'_c1';
  apply (wf_c x l l'); apply List.in_or_app; by auto.
Qed.

Lemma dom_In_wf c : wellformed_goto c -> forall p i, List.In (p, i) c ->
  forall c1 c2, c = c1 ++ c2 -> List.In p (unzip1 c1) -> List.In (p, i) c1.
Proof.
move=> Hwf p i HIn p1 p2 Hp.
case/List.in_map_iff; case=> p_ i' /= [] ? ?; subst p_.
have : List.In (p, i') c by rewrite Hp; apply List.in_or_app; left.
by move/(Hwf _ _ _ HIn) => ->.
Qed.

Lemma dom_In_wf2 c : wellformed_goto c -> forall p i, List.In (p, i) c ->
  forall c1 c2, c = c1 ++ c2 -> List.In p (unzip1 c2) -> List.In (p, i) c2.
Proof.
move=> Hwf p l HIn p1 p2 Hp.
case/List.in_map_iff; case=> p_ i' /= [] ? ?; subst p_.
have : List.In (p, i') c by rewrite Hp; apply List.in_or_app; right.
by move/(Hwf _ _ _ HIn) => ->.
Qed.

(** printing ->> %\ensuremath{\twoheadrightarrow}%*)

(** We can now define the semantics of %\goto%#Goto#. The type below
   corresponds to Figure 1 (%\figureone%#Small-step semantics rules of Goto#) in
   %\cite{saabasuustalu2007}%#[Saabas&Uustalu2007]#: *)

Inductive exec_goto : code -> lstate -> lstate -> Prop :=
| exec_goto_cmd0 : forall l i s s' c, List.In (l, C i) c  ->
  i ||- Some (l, s) ---> Some s' -> c ||- Some (l, s) ->> Some s'
| exec_goto_cmd0_err : forall l i s c, List.In (l, C i) c  ->
  i ||- Some (l, s) ---> None -> c ||- Some (l, s) ->> None
| exec_goto_branch : forall l j s s' c, List.In (l, B j) c ->
  j ||- (l, s) |>> s'  -> c ||- Some (l, s) ->> Some s'
where "c ||- s ->> t" := (exec_goto c s t) : goto_scope.

Lemma cmd0_labels c l s l' s' : c ||- Some (l, s) ---> Some (l', s') ->
  l <> l'.
Proof. move=> H; inversion H; by subst. Qed.

(** ** Properties *)

(** %See the end of Section \ref{sec:closure} for a comment about Lemma 2 (\lemmatwo).%

%\noindent% Lemma 3 (%\lemmathree%#Extension of the domain#) in %\cite{saabasuustalu2007}%#[Saabas&Uustalu2007]#: *)

Lemma exec_goto_extension_right' : forall c s s' i, c ||- s ->> s' ->
  c ++ i :: nil ||- s ->> s'.
Proof.
move=> c [ [l s] |] [ [l' s'] |] i H; inversion H; subst => //.
- eapply exec_goto_cmd0; eauto; apply List.in_or_app; by left.
- eapply exec_goto_branch; eauto; apply List.in_or_app; by left.
- eapply exec_goto_cmd0_err; eauto; apply List.in_or_app; by left.
Qed.

Lemma exec_goto_extension_right : forall c' s s' c, c ||- s ->> s'  ->  c ++ c' ||- s ->> s'.
Proof.
elim.
- by move=> *; rewrite cats0.
- move=> i lst IH s s' c H.
  rewrite (_ : c ++ i :: lst = (c ++ i :: nil) ++ lst); last by rewrite -catA.
  by apply IH, exec_goto_extension_right'.
Qed.

Lemma exec_goto_contraction_right_ c st st' : c ||- st ->> st'  ->
 forall c1 c2 l s l' s', c = c1 ++ c2 -> st = Some (l,s) -> st' = Some (l',s') ->
  List.In l (unzip1 c1) -> ~ List.In l (unzip1 c2) ->
   c1 ||- st ->> st'.
Proof.
move=> [] //;
  move=> {c st st'} p i s [l' s'] c HIn H c1 c2 l0 s0 l1 s1 Hc;
    case=> X Y; subst; case=> X Y; subst => l0_c1 l0_c2.
- eapply exec_goto_cmd0; eauto.
  case: (List.in_app_or _ _ _ HIn) => // abs.
  exfalso; apply/l0_c2/List.in_map_iff.
  eexists; split; last by apply abs. done.
- eapply exec_goto_branch; eauto.
  case: (List.in_app_or _ _ _ HIn) => // abs.
  exfalso; apply/l0_c2/List.in_map_iff.
  eexists; split; last by apply abs. done.
Qed.

Lemma exec_goto_contraction_right c1 c2 : wellformed_goto (c1 ++ c2) ->
  forall l s l' s', c1 ++ c2 ||-  Some (l, s) ->> Some (l', s')  ->
    List.In l (unzip1 c1) -> c1 ||-  Some (l, s) ->> Some (l', s').
Proof.
move=> Hwf l s l' s'; move: Hwf.
move Heqc : (c1 ++ c2) => c. move Heqs : (Some (l, s)) => st. move Heqs' : (Some (l', s')) => st'.
move=> Hwf H; move: H c1 c2 l s l' s' Heqc Heqs Heqs' Hwf.
case=> //; move=> {st st' c} p i s [p' s'] c HIn H c1 c2 l st l' st' Hc;
  case=> X Y; subst; case=> X Y; subst => wf_c p_c1.
- eapply exec_goto_cmd0; eauto; by eapply dom_In_wf; eauto.
- eapply exec_goto_branch; eauto; by eapply dom_In_wf; eauto.
Qed.

Lemma exec_goto_extension_left : forall c s s' i, c ||- s ->> s' -> i :: c ||- s ->> s'.
Proof.
move=> c [[l s]|] [[l' s']|] i H; inversion H; subst => //.
- eapply exec_goto_cmd0; eauto; rewrite /=; by right.
- eapply exec_goto_branch; eauto; rewrite /=; by right.
- eapply exec_goto_cmd0_err; eauto; rewrite /=; by right.
Qed.

Lemma exec_goto_contraction_left_ c st st' : c ||- st ->> st' ->
 forall c1 c2 l s l' s', c = c1 ++ c2 -> st = Some (l, s) -> st' = Some (l', s') ->
  List.In l (unzip1 c2) -> ~ List.In l (unzip1 c1) -> c2 ||- st ->> st'.
Proof.
move=> Hexec; destruct Hexec => c1 c2 l0 s0 l' st' Hc H3 H4 HIn HnotIn.
- case: H3 => X Y; subst.
  case: H4 => X; subst.
  apply exec_goto_cmd0 with i => //.
  case/(List.in_app_or _ _ _) : H => // abs.
  exfalso; apply/HnotIn/List.in_map_iff.
  eexists; split; last by apply abs. done.
- done.
- case: H3 => X Y; subst.
  case: H4 => X; subst.
  apply exec_goto_branch with j => //.
  case/(List.in_app_or _ _ _) : H => // abs.
  exfalso; apply/HnotIn/List.in_map_iff.
  eexists; split; last by apply abs. done.
Qed.

Lemma exec_goto_contraction_left c1 c2 : wellformed_goto (c1 ++ c2) ->
 forall l s l' s', c1 ++ c2 ||- Some (l, s) ->> Some (l', s')  ->
  List.In l (unzip1 c2) -> c2 ||- Some (l, s) ->> Some (l', s').
Proof.
move=> Hwf l s l' s'; move : Hwf.
move Heqc : (c1 ++ c2) => c. move Heqs : (Some (l, s)) => st.
move Heqs' : (Some (l', s')) => st'.
move=> Hwf H; move: H c1 c2 l s l' s' Heqc Heqs Heqs' Hwf.
case=> //; move=> {st st' c} p i s [p' s'] c HIn H c1 c2 l st l' st' Hc;
    case=> X Y; subst; case=> X Y; subst => wf_c p_c2.
- eapply exec_goto_cmd0; eauto; by eapply dom_In_wf2; eauto.
- eapply exec_goto_branch; eauto; by eapply dom_In_wf2; eauto.
Qed.

(** ** Reflexive, Transitive Closure Predicates *)

(** %\label{sec:closure}%

   %\noindent% Reflexive, transitive closure, to be used in Theorem 6
   (%\theoremsix%#Preservation of evaluations as stuck reduction sequences#) of
   %\cite{saabasuustalu2007}%#[Saabas&Uustalu2007]#: *)

(** printing --->* %\ensuremath{\twoheadrightarrow^*}% *)

Reserved Notation  " c ||- s '--->*' t " (at level 82, no associativity).

Inductive redseqs : code -> lstate -> lstate -> Prop :=
| redseqs_refl : forall s c, c ||- s --->* s
| redseqs_trans : forall s s' s'' c, c ||- s --->* s' -> c ||- s' ->> s'' -> c ||- s --->* s''
where " c ||- s '--->*' t " :=  (redseqs c s t) : goto_scope.

Lemma redseqs_inv_nil s s' : nil ||- s --->* s' -> s = s'.
Proof.
move H' : nil => c H; move: H H'.
elim=> // ls ls' ls'' c0 H IH H0 H1; subst.
by inversion_clear H0.
Qed.

Lemma redseqs_transitivity' c s' s'' : c ||- s' --->* s'' ->
  forall s, c ||- s --->* s' -> c ||- s --->* s''.
Proof.
elim=> // st st' st'' c0 H IH H' st0 H''.
apply redseqs_trans with st'; [by apply IH | exact H'].
Qed.

Lemma redseqs_transitivity c s s' : c ||- s --->* s' ->
  forall s'', c ||- s' --->* s''  ->  c ||- s --->* s''.
Proof. move=> H s'' H'; by apply redseqs_transitivity' with s'. Qed.

Lemma redseqs_extension_left'' c s' s'' : c ||- s' --->* s'' ->
  forall l i l' st', s' = Some (l', st')  ->  (l, i) :: c ||- s' --->* s''.
Proof.
elim=> //; move=> {c s' s''}.
- move=> *; by apply redseqs_refl.
- move=> s s' s'' c Hc IH Hc' l i l' st' Hs.
  apply redseqs_trans with s'.
  + by eapply IH; eauto.
  + inversion Hc'; subst.
    * eapply exec_goto_cmd0; eauto; rewrite /=; by right.
    * eapply exec_goto_cmd0_err; eauto; rewrite /=; by right.
    * eapply exec_goto_branch; eauto; rewrite /=; by right.
Qed.

Lemma redseqs_extension_left' c l' s' s'' : c ||- Some (l', s') --->* s'' ->
 forall l i, (l, i) :: c ||- Some (l', s') --->* s''.
Proof. move=> H l i; by apply (redseqs_extension_left'' _ _ _ H l i l' s'). Qed.

Lemma redseqs_extension_left c l s s' c' :
  c ||- Some (l, s) --->* s' -> c' ++ c ||- Some (l, s) --->* s'.
Proof.
induction c' => // *.
destruct a; by apply redseqs_extension_left'; auto.
Qed.

Lemma redseqs_extension_right''' c st' st'' : redseqs c st' st'' ->
 forall l i l' s' , st' = Some (l', s') -> redseqs (c ++ (l, i) :: nil) st' st''.
Proof.
elim=> //; move=> {c st' st''}.
- move=> *; by apply redseqs_refl.
- move=> s s' s'' c Hc IH Hc' l i l' s'0 Hs.
  apply redseqs_trans with s'.
  + by eapply IH; eauto.
  + inversion Hc'; subst.
    * eapply exec_goto_cmd0; eauto; apply List.in_or_app; by left.
    * eapply exec_goto_cmd0_err; eauto; apply List.in_or_app; by left.
    * eapply exec_goto_branch; eauto; apply List.in_or_app; by left.
Qed.

Lemma redseqs_extension_right'' c l' s' s'' : redseqs c (Some (l', s')) s'' ->
  forall l i, redseqs (c ++ (l, i) :: nil) (Some (l', s')) s''.
Proof. move=> H l i; by apply (redseqs_extension_right''' _ _ _ H l i l' s'). Qed.

Lemma redseqs_extension_right' : forall c l s s' c',
  redseqs c (Some (l, s)) s' -> redseqs (c ++ rev c') (Some (l, s)) s'.
Proof.
induction c'; intros.
- by rewrite cats0.
- rewrite -cat1s rev_cat catA; destruct a; by apply redseqs_extension_right''; auto.
Qed.

Lemma redseqs_extension_right c l s s' c' :
  c ||- Some (l, s) --->* s' -> c ++ c' ||- Some (l, s) --->* s'.
Proof.
move=> H.
rewrite -(revK c'); by apply redseqs_extension_right'.
Qed.

(** Reflexive, transitive closure with explicit index k,
   to be used in Theorem 7 (%\theoremseven%#Reflection of stuck reduction sequences as evaluations#): *)

Inductive redseq (c : code) : nat -> lstate -> lstate -> Prop :=
| zero_red : forall s, redseq c O s s
| more_red : forall n s s' s'', c ||- s ->> s' -> redseq c n s' s'' -> redseq c (S n) s s''.

Lemma more_red' c n s s' : redseq c n s s' -> forall s'', c ||- s' ->> s'' -> redseq c (S n) s s''.
Proof.
induction 1.
- move=> s'' H. apply more_red with s'' => //; destruct s''; by apply zero_red.
- move=> s''' H'. apply more_red with s' => //; by apply IHredseq.
Qed.

Lemma red_seqs_red_seq p s s' : redseqs p s s' -> exists n, redseq p n s s'.
Proof.
induction 1.
- exists O; destruct s; by apply zero_red.
- case: IHredseqs => n IH; exists (S n); by apply more_red' with s'.
Qed.

Lemma redseq_nil k ST ST' : redseq nil k ST ST' -> ST = ST'.
Proof. elim=> // n s s' s'' Hexec Hredseq; by inversion Hexec. Qed.

Lemma redseq_inv_refl' c k st st' : redseq c k st st' ->
  forall l s, st = Some (l, s) -> ~ List.In l (unzip1 c) -> st = st'.
Proof.
move=> [] // n s s' s'' Hexec Hredseq l s0 H1 H2; subst.
inversion Hexec => //; subst.
exfalso; apply/H2/List.in_map_iff; by eexists (l, C i).
exfalso; apply/H2/List.in_map_iff; by eexists (l, C i).
exfalso; apply/H2/List.in_map_iff; by eexists (l, B j).
Qed.

Lemma redseq_sC_refl : forall k c st st', redseq c k st st' ->
  forall l s l' s' p i, st = Some (l, s) -> st' = Some (l', s') ->
    c = (p, C i) :: nil -> p <> l -> st = st'.
Proof.
move=> [|n] c st st' H l s l' s' p i Hst Hst' Hc Hpl; subst.
- by inversion H; subst.
- inversion H; subst.
  inversion H1; subst.
  * case: H5 => //. case=> X Y; by subst.
  * case: H5 => //. case=> X Y; by subst.
  * by case: H5.
Qed.

Lemma redseq_sC_inv : forall k c st st', redseq c k st st' ->
  forall l s l' s' i, st = Some (l, s) -> st' = Some (l', s') ->
    l <> l' -> c = (l, C i) :: nil -> i ||- st ---> st'.
Proof.
induction 1.
- destruct s as [[l1 s1]|] => //.
  move=> l s0 l' s' i [Hs1 Hs2] [Hs'1 Hs'2] Hll' Hc; by subst.
- move=> l s0 l' s'0 i Hs Hs'' Hll' Hc; subst.
  inversion H; subst.
  + case: H4 => //. case => X; subst.
    inversion H0; subst => //.
    inversion H1; subst.
     * case: H4 => //. case => X Y; subst.
       by apply cmd0_labels in H6.
     * case: H4 => //. case => X Y; subst.
       inversion H2; subst.
       inversion H3; by subst.
     * by case: H4.
  + case: H4 => //. case => X; subst.
    inversion H0; subst.
    inversion H1; by subst.
  + by case: H4.
Qed.

Lemma redseq_self_jump : forall k l s l' s', l <> l' ->
  ~ redseq ((l, B (jmp l)) :: nil) k (Some (l, s)) (Some (l', s')).
Proof.
elim.
- move=> l s l' s' l_l' H; inversion H; by subst.
- move=> k IH l s l' s' l_l' H; inversion H; subst.
  inversion H1; subst.
  + by case: H5.
  + by case: H5.
  + case: H5 => //. case=> X; subst.
    inversion H7; subst.
    by move: (IH _ s _ s' l_l').
Qed.

Lemma redseq_self_cjmp : forall k t l s l' s', l <> l' -> eval_b t s ->
  ~ redseq ((l, B (cjmp t l)) :: nil) k (Some (l, s)) (Some (l', s')).
Proof.
elim.
- move=> t l s l' s' l_l' Hb H; inversion H; by subst.
- move=> k IH t l s l' s' l_l' Hb H; inversion H; subst.
  inversion H1; subst.
  + rewrite /= in H5; by case: H5.
  + rewrite /= in H5; by case: H5.
  + rewrite /= in H5; case: H5; last by done.
    case=> ?; subst j.
    inversion H7; subst => //.
    by move: (IH _ _ _ _ s' l_l' H8).
Qed.

(** The following two lemmas express, in the particular case of branches, a property similar to Lemma 2 (%\lemmatwo%#Stuck states#) in %\cite{saabasuustalu2007}%#[Saabas&Uustalu2007]#. They are used in the proof of Theorem 7 (%\theoremseven%#Reflection of stuck reduction sequences as evaluations#) in lieu of Lemma 2. *)

Lemma redseq_out_of_domain_jump : forall k p m l s l' s', p <> l ->
  redseq ((p, B (jmp m)) :: nil) k (Some (l, s)) (Some (l', s')) -> l = l' /\ s = s'.
Proof.
elim.
- do 7 intro; inversion 1; by subst.
- move=> k IH p m l s l' s' Hpl; inversion 1; subst.
  inversion H1; subst.
  + by case: H5.
  + by case: H5.
  + case: H5 => //. case=> X Y; by subst.
Qed.

Lemma redseq_out_of_domain_cjmp : forall k p t m l s l' s', p <> l ->
  redseq ((p, B (cjmp t m)) :: nil) k (Some (l, s)) (Some (l', s')) -> l = l' /\ s = s'.
Proof.
elim.
- do 8 intro; inversion 1; by subst.
- move=> k IH p t m l s l' s' Hpl; inversion 1; subst.
  inversion H1; subst.
  + by case: H5.
  + by case: H5.
  + case: H5 => //. case=> X Y; by subst.
Qed.

End Goto.

Module Goto_Deter (while_semop_deter_m : while.WHILE_SEMOP_DETER).

Module Import goto_m := Goto while_semop_deter_m.

Import while_semop_deter_m.

Local Open Scope while_cmd_scope.
Local Open Scope goto_scope.

(** ** Properties *)

(** Lemma 1 (%\lemmaone%#Determinacy#) in %\cite{saabasuustalu2007}%#[Saabas&Uustalu2007]#: *)

Lemma exec0_label_deter : forall s c s', c ||- s ---> s' ->
  forall s'', c ||- s ---> s'' -> s' = s''.
Proof.
move=> [[l s]|] c [[l' s']|] H; inversion H; subst.
- move=> [[l'' s'']|] H'; inversion H'; subst.
  + case: (exec0_deter _ _ _ H3 _ H4) => ?; by subst.
  + by move: (exec0_deter _ _ _ H3 _ H4).
- move=> [[l'' s'']|] H'; inversion H'; subst; last by reflexivity.
  by move: (exec0_deter _ _ _ H3 _ H4).
Qed.

Lemma branch_deter s c s' : c ||- s |>> s' ->
  forall s'', c ||- s |>> s'' -> s' = s''.
Proof. inversion_clear 1; move=> s''; by inversion_clear 1. Qed.

Lemma exec_goto_deter : forall c, wellformed_goto c ->
 forall s s', c ||- s ->> s' -> forall s'', c ||- s ->> s'' -> s' = s''.
Proof.
move=> c Hwf [[l s]|] [[l' s']|]  H' [[l'' s'']|] H'' //; inversion H'; inversion H''; subst.
- case: (Hwf _ _ _ H3 H9) => ?; subst.
  by rewrite (exec0_label_deter _ _ _ H4 _ H10).
- by move: (Hwf _ _ _ H3 H9).
- by move: (Hwf _ _ _ H3 H9).
- case: (Hwf _ _ _ H3 H9) => ?; subst.
  by rewrite (branch_deter _ _ _ H4 _ H10).
- case: (Hwf _ _ _ H3 H8) => X; subst.
  by move: (exec0_label_deter _ _ _ H4 _ H9).
- by move: (Hwf _ _ _ H3 H8).
- case: (Hwf _ _ _ H2 H8) => X; subst.
  by move: (exec0_label_deter _ _ _ H3 _ H9).
- by move: (Hwf _ _ _ H2 H8).
Qed.

End Goto_Deter.


Require Import Coq.Classes.DecidableClass.
Require Import Coq.Lists.List.
Require Import Coq.Bool.Bool.
Require Import SquiggleEq.export.
Require Import SquiggleEq.UsefulTypes.
Require Import SquiggleEq.list.
Require Import SquiggleEq.LibTactics.
Require Import SquiggleEq.tactics.
Require Import SquiggleEq.AssociationList.
Require Import ExtLib.Structures.Monads.
Require Import ReflParam.common.
Require Import ReflParam.Trecord.

(* The type of this definition is what we eanted [Type] Set Set to be.
Now, [Type] Set Set is Set -> Set -> Type *)
Definition setTrans : GoodRel [Total; OneToOne] Set Set.
(* apply Build_GoodRel with  (R:=fun H H0 : Set => BestRel H H0). *)
Abort.

Lemma TSet: TotalHeteroRelHalf (fun H H0 : Set => BestRel H H0).
Proof using.
  intros s1. exists s1.
(*
s1 : Set
______________________________________(1/1)
BestRel s1 s1
*)
(* use the identity relation *)
Abort.

Lemma OneSet: oneToOneHalf
  (fun S₁ S₂ : Set => BestRel S₁ S₂).
(*the relation says that says that S₁ and S₂ are isomporphic types (upto eq).
Then one to one requires univalence.
And irrel implies UIP. The two are contradictory. *)
Proof using.
  intros  A B₁ B₂ H1b H2b.
  destruct H1b.
  destruct H2b.
  unfold allProps in *. simpl in *.
  rename R0 into R2.
(*

   A
  . .
.    .
 .    .
.    .
 .    .
B₁ =? B₂

Consider A₁ = B₁= A₂ = A
Now we have A ~ B₂ (A isomorphic to B2).
They may not be equal (the questionmark link) unless we admit univalence.
But univalence goes against the idea of having parametricity relations be proof
irrelevant.

If we reject that idea and do not require relations to be proof irrelevant,
we would be forced to get rid of irrel hyps in PiTypeR.v
and PIW.v
Is that riddance possible?
Even if it is, it assuming univalence makes this work less useful in comparison to HoTT.
Still, the free theorems may go beyond HoTT

oneToOne was a critical requirement for TotalHeter for Pi Types. So we need this proof.

Have [Set] be [Prop]? Then we wont need the irrel argument.
*)

(* Alternatively, translate Type as before. Only Set will be translated specially.
this means that the main advantate of our approach would be in polymorphic propositions
in about T:Set. For most applications, where ts are ASTs, this suffices
*)
Abort.

Require Import Coq.Numbers.BinNums.

Lemma NotOneOneSet: (oneToOneHalf
  (fun S₁ S₂ : Set => BestRel S₁ S₂)) -> False.
Proof using.
 intros Hc.
 unfold oneToOneHalf in Hc.
 specialize (Hc nat nat N).
 simpl in Hc.
(*BestRel nat nat -> BestRel nat N -> nat = N *)
Abort.

Lemma irrelSet: relIrrUptoEq
  (fun S₁ S₂ : Set => BestRel S₁ S₂).
Proof using.
  intros ? ? ? ?.
  (* these may be two different isomorphisms and may not be equal *)
Abort.

(* In the translation of Pi, can the x_R be of type Cast (A_R _ _)? If so,
irrel may not be needed, and thus we can ditch proof irrelevance for
the univalence axiom. The advantage over HoTT will then be that we get stronger
free theorems in some cases.
Casting will also make it compulsary to not match on x_r, and thus use
the alternate version of translation of inductives and fixpoints.
We can have both versions – the proof irrelevance version and the univalence version
*)

Notation Type_R := (fun T1 T2 => T1 -> T2 -> Type) (only parsing).

(** The case of Prop:Type *)
Definition Prop_R :  Type_R Prop Prop.
  simpl.
  intros P1 P2. exact (BestRel P1 P2).
Defined.

(** The case of Set:Type *)
Definition Set_R :  Type_R Set Set.
  simpl.
  intros P1 P2. exact (BestRel P1 P2).
Defined.

(*
Definition Prop_R2 :  BestRel Prop Prop.
  simpl.
  exists (fun P1 P2:Prop => BestRelP P1 P2); simpl.
  simpl
Defined.
*)

(** * Subtyping

We know that Set :> Type. Does the parametricity translation need to preserve this?
Let A:Set
Let's check whetner [[Set]] A A:> [[Type]] A A.
Unlike the AnyRel translation, BestR needs to be added here. This can be problematic.
*)

Require Import Coq.Unicode.Utf8.

Section SubtypTest.
  Variable A:Set.
  Variable A_R : (λ(x x': Set), BestRel x x') A A.
  Check (BestR A_R: ((λ(x x': Type@{i}), x → x' → Type@{i}) A A)).
(** We may be able to ask Coq to mark all uses of subtyping by a Cast.
     Then we can translate (cast (cast t Set) Type) as projTyRel t.
  According to Figure 1 of Lasson12, there is only one other subtyping rule :
   covariance of the codomain of dependent function types.
  For such rules, we need to put the projTyrel under a lambda.
  In general, given an encoding of the subtyping rule, an explicit
  casting function can be computed by recursing on it.
*)
End SubtypTest.


(****************************************************************)
(*  On monadic parametricity of second-order functionals        *)
(*  by Bauer A., Hofmann M., Karbyshev A.                       *)
(*                                                              *)
(*  Aleksandr Karbyshev                                         *)
(*  May 2012                                                    *)
(*  Build with Coq 8.4 + Ssreflect 1.4                          *)
(****************************************************************)

Set Automatic Coercions Import.
Require Export PredomAll.
Require Import stuff.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module Monad.
Section axioms.
Variable T : cpoType -> cpoType.
Variable val : forall X, X =-> T X.
Variable bind : forall X Y, T X =-> (X -=> T Y) -=> T Y.
Definition axiom0 := forall A B f a, @bind A B (@val A a) f =-= f a.
Definition axiom1 := forall A t, @bind A A t (@val A) =-= t.
Definition axiom2 := forall A B C t f g, @bind B C (@bind A B t f) g =-= bind _ _ t (Fcont_app (CCOMP _ _ _ (@bind _ _, f)) g).
End axioms.

Definition axiom T val bind := @axiom0 T val bind /\ @axiom1 T val bind /\ @axiom2 T bind.

Record strictMonad := mkStrictMonad {
  T :> cpoType -> cppoType;
  tval : forall X, X =-> T X;
  tbind : forall X Y, (T X : cpoType) =-> (X -=> T Y) -=> T Y;
  taxiom0 : @axiom0 T tval tbind;
  taxiom1 : @axiom1 T tval tbind;
  taxiom2 : @axiom2 T tbind;
  taxiom3 : forall A B f, @tbind A B PBot f =-= PBot
}.
End Monad.

Notation monadType := Monad.strictMonad.
Notation tval := Monad.tval.
Notation tbind := Monad.tbind.
Notation taxiom0 := Monad.taxiom0.
Notation taxiom1 := Monad.taxiom1.
Notation taxiom2 := Monad.taxiom2.
Notation taxiom3 := Monad.taxiom3.

Definition State (S : cpoType) : monadType.
exists
  (*(fun X => S -=> (X * S) _BOT)*)
  (fun X => exp_cppoType S (liftCppoType (X * S)))
  ((*locked*) (fun X => ((*CURRY*) exp_fun (eta << Id))))
  ((*locked*) (fun X Y =>
     (exp_fun (CCOMP _ _ _ << <| KLEISLI << UNCURRY1 _ _ _ << SND _ _, FST _ _ |>)))).
- rewrite /Monad.axiom0 /=. move => A B f a. apply: fmon_eq_intro => s /=.
  by rewrite kleisliVal.
- rewrite /Monad.axiom1 /=. move => A t. apply: fmon_eq_intro => s /=.
  rewrite UC_id /=.
  have H : eta << Id =-= eta
    by move => X; apply: fmon_eq_intro => x.
  by rewrite H; rewrite kleisli_unit.
- rewrite /Monad.axiom2 /=. move => A B C t f g. apply: fmon_eq_intro => s /=.
  split.
  + apply: DLless_cond => x Hx.
    elim: (kleisliValVal Hx) => vx Hvx. elim: (kleisliValVal (proj1 Hvx)) => vy Hvy.
    rewrite (proj1 Hvy). by rewrite !kleisliVal.
  + apply: DLless_cond => x Hx.
    elim: (kleisliValVal Hx) => vx Hvx.
    rewrite (proj1 Hvx). by rewrite !kleisliVal.
- move => A B f /=. apply: fmon_eq_intro => s /=. by apply: kleisli_bot.
(*- intuition; simpl. apply: fmon_eq_intro => h; simpl.
  split.
  + apply: DLless_cond => x Hx. elim (kleisliValVal Hx) => vx Hvx. simpl in Hvx.
    elim: Hvx => _ Hvx. by elim (PBot_incon_eq (Oeq_sym Hvx)).
  + apply: DLless_cond => x Hx. by elim (PBot_incon_eq (Oeq_sym Hx)).*)
Defined.

Definition valState S := @tval (State S).
Definition bindState S := @tbind (State S).

Lemma valState_simpl S X x s : @tval (State S) X x s =-= Val (x, s).
Proof.
by [].
Qed.

Lemma bindState_simpl S X Y t (f : X =-> (State S Y : cpoType)) s :
  @tbind (State S) X Y t f s =-= kleisli (uncurry f) (t s).
Proof.
by [].
Qed.

Lemma bindState_bot S X Y (t : State S X) :
  bindState S X Y t (@Pointed.least (CPPO.pointedType (exp_cppoType X (State S Y)))) =-= PBot.
Proof.
rewrite /bindState /=. (*unlock; simpl.*)
apply: fmon_eq_intro => h /=. rewrite /bindState /=. unlock; simpl. split.
- apply: DLless_cond => x Hx. elim: (kleisliValVal Hx) => vx Hvx. rewrite /= in Hvx.
  elim: Hvx => _ Hvx. by elim: (PBot_incon_eq (Oeq_sym Hvx)).
- apply: DLless_cond => x Hx. by elim: (PBot_incon_eq (Oeq_sym Hx)).
Qed.

Definition Cont (R : cppoType) : monadType.
exists
  (fun (X : cpoType) => exp_cppoType (X -=> R) R)
  (fun X => (*locked*) (exp_fun (EV _ _ << SWAP)))
  (fun X Y =>
    (*locked*) (exp_fun (exp_fun (EV _ _ << <| FST _ _ << FST _ _, FCONT_app _ _ _ << <| SND _ _, SND _ _ << FST _ _ |> |>)))).
- rewrite /Monad.axiom0 /=. move => A B f a. unlock; simpl. by apply: fmon_eq_intro => h.
- rewrite /Monad.axiom1 /=. move => A t. unlock; simpl. apply: fmon_eq_intro => h /=.
  apply: fmon_eq_compat; by apply: fmon_eq_intro.
- rewrite /Monad.axiom2 /=. move => A B C t f g. unlock; simpl.
  apply: fmon_eq_intro => h /=.
  apply: fmon_eq_compat; by apply: fmon_eq_intro.
- move => A B f /=. unlock; simpl. by apply: fmon_eq_intro => h.
Defined.

Definition valCont R := @tval (Cont R).
Definition bindCont R := @tbind (Cont R).

Lemma valCont_simpl R X x h : @tval (Cont R) X x h =-= h x.
Proof.
by [].
Qed.

Lemma bindCont_simpl R X Y t f h :
  @tbind (Cont R) X Y t f h =-= t (Fcont_app f h).
Proof.
rewrite /=.
apply: (fcont_eq_compat (Oeq_refl _)).
by apply: fcont_eq_intro => x.
Qed.

Definition Lift : monadType.
exists (fun X => liftCppoType X)
       (fun X => @eta X)
       (fun X Y => exp_fun (uncurry (@KLEISLI X Y) << SWAP)).
- rewrite /Monad.axiom0 /= => X Y f x.
  by rewrite kleisliVal.
- rewrite /Monad.axiom1 /= => X t.
  by rewrite kleisli_unit.
- rewrite /Monad.axiom2 /= => X Y Z t f g.
  split.
  + apply: kleisli_leq => y Hy /=.
    elim: (kleisliValVal Hy) => x [Ex Ey].
    exists x. by rewrite Ey kleisliVal.
  + apply: DLless_cond => z Hz.
    elim: (kleisliValVal Hz) => /= x [Ht H].
    by rewrite Ht !kleisliVal /=.
- move => X Y f /=. by rewrite kleisli_bot.
Defined.


Require Import FJ_util.
Require Import List.
Require Import Arith.Peano_dec.
Require Import JMeq.

Section FJ_Definition.

  Definition C : Set := nat.
  Definition F : Set := nat.
  Definition M : Set := nat.

  Inductive CL := cl : C -> CL | Object : CL.

  Variable TV : C -> option M -> nat -> Set.

  Inductive Ty : Set :=
  | t_var : forall c m n, TV c m n -> Ty
  | NTy : N -> Ty
  with N : Set := N_def : CL -> list Ty -> N.
  Implicit Arguments t_var [c m n].

  Definition TContext := list (N * C * option M).

  Inductive x_this : Set :=
  | x : x_this
  | this : x_this.

  Variable V : x_this -> Ty -> Set.
  Axiom variables_exist : forall t (P : (V x t) -> Prop),
                            (forall v : V x t, P v) -> exists v', P v'.
  Axiom this_exists : forall t (P : (V this t) -> Prop),
                            (forall v : V this t, P v) -> exists v', P v'.

  Inductive FD := fd : Ty -> F -> FD.

  Inductive E : Set :=
  | e_var : forall xt t, V xt t -> E
  | fd_access : E -> F -> E
  | m_call : E -> M -> list Ty -> list E -> E
  | new : N -> list E -> E.
  Implicit Arguments e_var [xt t].

  Inductive MB : x_this -> Set :=
  | mb_empty : E -> MB x
  | mb_var : forall t, (V x t -> MB x) -> MB x
  | mb_this : forall t, (V this t -> MB x) -> MB this.

  Inductive K := k : C -> list FD -> K.

  Inductive Mty : Set :=
  | mty : list N -> list Ty -> Ty -> Mty
  | mty_tp : forall c m n, (TV c (Some m) n -> Mty) -> Mty.

  Inductive MD : Set :=
  | md : list N -> Ty -> M -> MB this -> MD
  | md_tp : forall c m n , (TV c (Some m) n -> MD) -> MD.

  Inductive L : Set :=
  | cld : C -> list N -> N -> list FD -> K -> list MD -> L
  | cld_tp : forall c n, (TV c None n -> L) -> L.

  Inductive TSub c m n : (TV c m n -> Ty) -> Ty -> Ty -> Prop :=
  | S_tvar_eq : forall t, TSub c m n (@t_var c m n) t t
  | S_tvar_neq : forall (tv: TV c m n) t,
                   TSub c m n (fun _ => t_var tv) t (t_var tv)
  | S_NTy : forall c' tys t tys',
              Forall2 (fun ty0 ty0' => TSub c m n ty0 t ty0') tys tys' ->
              TSub c m n
                   (fun tv => (NTy (N_def c' (map (fun ty => ty tv) tys))))
                   t (NTy (N_def c' tys')).

  Section TSub_recursion.
    Variables (P : forall c m n t0 t t0', TSub c m n t0 t t0' -> Prop)
              (Q : forall c m n ts t ts', Forall2 (fun t0 t0' => TSub c m n t0 t t0') ts ts' -> Prop).

    Hypothesis
      (H1 : forall c m n t, P _ _ _ _ _ _ (S_tvar_eq c m n t))
      (H2 : forall c m n tv t, P _ _ _ _ _ _ (S_tvar_neq c m n tv t))
      (H3 : forall c m n c' tys t tys' sub_ts,
              Q _ _ _ _ _ _ sub_ts ->
              P _ _ _ _ _ _ (S_NTy c m n c' tys t tys' sub_ts))
      (H4 : forall c m n t,
              Q c m n nil t nil (Forall2_nil (fun t0 t0' => TSub c m n t0 t t0')))
      (H5 : forall c m n t0 ts t t0' ts' sub_t0 sub_ts,
              P c m n t0 t t0' sub_t0 -> Q c m n ts t ts' sub_ts ->
              Q c m n _ _ _ (Forall2_cons _ _ sub_t0 sub_ts)).

    Fixpoint TSub_rec c m n t0 t t0' (tsub_t0 : TSub c m n t0 t t0') : P c m n _ _ _ tsub_t0 :=
      match tsub_t0 return P c m n _ _ _ tsub_t0 with
        | S_tvar_eq t => H1 c m n t
        | S_tvar_neq tv t => H2 c m n tv t
        | S_NTy c' tys t tys' sub_ts =>
          H3 c m n c' tys t tys' sub_ts
             ((fix ts_rect ts ts' (sub_ts : Forall2 (fun t0 t0' => TSub c m n t0 t t0') ts ts') : Q _ _ _ _ _ _ sub_ts :=
                 match sub_ts return Q _ _ _ _ _ _ sub_ts with
                   | Forall2_nil => H4 c m n t
                   | Forall2_cons t0 t0' ts ts' sub_t0 sub_ts =>
                     H5 c m n t0 ts t t0' ts' sub_t0 sub_ts (TSub_rec _ _ _ _ _ _ sub_t0) (ts_rect _ _ sub_ts)
                 end) _ _ sub_ts)
      end.
  End TSub_recursion.

  Variable CT : C -> option L.
  Variable CT_self : forall c c1 cl' l k fds, CT c = Some (cld c1 cl' l k fds) -> c = c1.

  Inductive subtype : Ty -> Ty -> Prop :=
  | sub_refl : forall c, subtype c c
  | sub_trans : forall c d e, subtype c d -> subtype d e ->
                              subtype c e
  | sub_class : forall c d fds k' mds, CT c = Some (cld c (ty_def d) fds k' mds) ->
                                      subtype (ty_def (cl c)) (ty_def d).

  Inductive fields : Ty -> list FD -> Prop :=
  | fields_Obj : fields (ty_def Object) nil
  | fields_cl :
      forall c d c_fds d_fds k' mds,
        CT c = Some (cld c (ty_def d) c_fds k' mds) ->
        fields (ty_def d) d_fds ->
        fields (ty_def (cl c)) (d_fds ++ c_fds).

  Scheme fields_rec := Induction for fields Sort Prop.

  Inductive Extract_tys : forall xt, MB xt -> list Ty -> Prop :=
  | mb_empty_nil : forall e, Extract_tys _ (mb_empty e) nil
  | mb_var_cons : forall ty ctxt tys,
                    (forall v : V x ty, Extract_tys _ (ctxt v) tys) ->
                    Extract_tys _ (mb_var ty ctxt) (ty::tys)
  | mb_this_cons : forall ty ctxt tys,
                     (forall v : V this ty, Extract_tys x (ctxt v) tys) ->
                     Extract_tys this (mb_this ty ctxt) (ty::tys).

  Scheme Extract_tys_rec := Induction for Extract_tys Sort Prop.

  Inductive mtype : M -> Ty -> Mty -> Prop :=
  | mtype_fnd : forall m c d fds k' mds ty mb tys,
                  CT c = Some (cld c d fds k' mds) ->
                  In (md ty m mb) mds ->
                  Extract_tys _ mb tys ->
                  mtype m (ty_def (cl c)) (mty tys ty)
  | mtype_not_fnd : forall m c d fds k' mds mty',
                      CT c = Some (cld c d fds k' mds) ->
                      (forall b mb, ~ In (md b m mb) mds) ->
                      mtype m d mty' ->
                      mtype m (ty_def (cl c)) mty'.

  Inductive mbody : M -> Ty -> MB this -> Prop :=
  | mbody_fnd :
      forall m c d fds k' mds ty mb,
        CT c = Some (cld c d fds k' mds) ->
        In (md ty m mb) mds ->
        mbody m (ty_def (cl c)) mb
  | mbody_not_fnd :
      forall m c d fds k' mds mb',
        CT c = Some (cld c d fds k' mds) ->
        (forall b mb, ~ In (md b m mb) mds) ->
        mbody m d mb' ->
        mbody m (ty_def (cl c)) mb'.

  Inductive E_WF : E -> Ty -> Prop :=
  | T_Var : forall xt t (v:V xt t), E_WF (e_var v) t
  | T_Fields : forall e f ty fds ty' i,
                 E_WF e ty ->
                 fields ty fds ->
                 nth_error fds i = Some (fd ty' f) ->
                 E_WF (fd_access e f) ty'
  | T_Invk : forall e_0 ty_0 U m Us Ss es,
             E_WF e_0 ty_0 ->
             mtype m ty_0 (mty Us U) ->
             List_P2' E_WF es Ss -> List_P2' subtype Ss Us ->
             E_WF (m_call e_0 m es) U
  | T_New : forall cl Ss fds es,
              fields (ty_def cl) fds ->
              List_P2' E_WF es Ss ->
              List_P2' (fun S fd' => match fd' with fd T _ => subtype S T end) Ss fds ->
            E_WF (new (ty_def cl) es) (ty_def cl).

  Inductive E_WF_in_MB (c:Ty) : forall xt, MB xt -> Ty -> Prop :=
  | wf_e_mb_empty : forall e ty, E_WF e ty ->
                                     E_WF_in_MB c _ (mb_empty e) ty
  | wf_e_mb_var : forall t (f : V x t -> MB x) ty,
                    (forall v, E_WF_in_MB c _ (f v) ty) ->
                    E_WF_in_MB c x (mb_var _ f) ty
  | wf_e_mb_this : forall (f : V this c -> MB x) ty,
                     (forall v, E_WF_in_MB c _ (f v) ty) ->
                     E_WF_in_MB c this (mb_this _ f) ty.

  Scheme E_WF_in_MB_rec := Induction for E_WF_in_MB Sort Prop.

  Definition override (m : M) (ty : Ty) (Ts : list Ty) (T : Ty) : Prop :=
    forall ds d, mtype m ty (mty ds d) -> T = d /\ Ts = ds.

  Inductive Meth_WF : C -> MD -> Prop :=
  | T_MD : forall (mb:MB this) (e_0 c_0 :Ty) (c:C)
                  (d:CL) (fds:list FD) (k':K) (mds:list MD) (m:M) tys,
      Extract_tys _ mb tys ->
      E_WF_in_MB (ty_def (cl c)) this mb e_0 ->
      subtype e_0 c_0 ->
      CT c = Some (cld c (ty_def d) fds k' mds) ->
      override m (ty_def d) tys c_0 ->
      Meth_WF c (md c_0 m mb).

  Inductive L_WF : L -> Prop :=
  T_cld :
    forall c d d_fds c_fds k' mds,
      k' = k c (d_fds ++ c_fds) ->
      fields (ty_def d) d_fds ->
      (forall md, In md mds -> Meth_WF c md) ->
      distinct (map (fun md' => match md' with md _ m _ => m end) mds) ->
      distinct (map (fun fd' => match fd' with fd _ f => f end) (d_fds++c_fds)) ->
      L_WF (cld c (ty_def d) c_fds k' mds).

  Inductive Sub : (forall xt t, V xt t -> E) -> E -> E -> Prop :=
  | S_var_eq : forall e, Sub e_var e e
  | S_var_neq : forall xt t (v:V xt t) e, Sub (fun _ _ _ => e_var v) e (e_var v)
  | S_fd_access : forall e0 e e0' f,
                    Sub e0 e e0' ->
                    Sub (fun xt t v => fd_access (e0 xt t v) f) e
                        (fd_access e0' f)
  | S_m_call : forall e0 es e e0' es' m,
                 Sub e0 e e0' ->
                 Forall2 (fun e0 e0' => Sub e0 e e0') es es' ->
                 Sub (fun xt t v =>
                        m_call (e0 xt t v) m (map (fun e0 => e0 xt t v) es))
                     e (m_call e0' m es')
  | S_new : forall ty es e es',
              Forall2 (fun e0 e0' => Sub e0 e e0') es es' ->
              Sub (fun xt t v => new ty (map (fun e0 => e0 xt t v) es)) e
                  (new ty es').

 Section Sub_recursion.
    Variables (P : forall e0 e e0', Sub e0 e e0' -> Prop)
              (Q : forall es e es', Forall2 (fun e0 e0' => Sub e0 e e0') es es' -> Prop).

    Hypothesis
      (H1 : forall e, P _ _ _ (S_var_eq e))
      (H2 : forall xt t v e, P _ _ _ (S_var_neq xt t v e))
      (H3 : forall e0 e e0' f sub_e0, P _ _ _ sub_e0 -> P _ _ _ (S_fd_access e0 e e0' f sub_e0))
      (H4 : forall e0 es e e0' es' m sub_e0 sub_es, P _ _ _ sub_e0 -> Q _ _ _ sub_es -> P _ _ _ (S_m_call e0 es e e0' es' m sub_e0 sub_es))
      (H5 : forall ty es e es' sub_es, Q _ _ _ sub_es -> P _ _ _ (S_new ty es e es' sub_es))
      (H6 : forall e, Q nil e nil (Forall2_nil (fun e0 e0' => Sub e0 e e0')))
      (H7 : forall e0 es e e0' es' sub_e0 sub_es, P e0 e e0' sub_e0 -> Q es e es' sub_es -> Q _ _ _ (Forall2_cons _ _ sub_e0 sub_es)).

    Fixpoint Sub_rec e0 e e0' (sub_e0 : Sub e0 e e0') : P _ _ _ sub_e0 :=
      match sub_e0 return P _ _ _ sub_e0 with
        | S_var_eq e => H1 e
        | S_var_neq xt t v e => H2 xt t v e
        | S_fd_access e0 e e0' f sub_e0 =>
          H3 e0 e e0' f sub_e0 (Sub_rec _ _ _ sub_e0)
        | S_m_call e0 es e e0' es' m Vs sub_e0 sub_es =>
          H4 e0 es e e0' es' m Vs sub_e0 sub_es (Sub_rec _ _ _ sub_e0)
             ((fix es_rect es es' (sub_es : Forall2 (fun e0 e0' => Sub e0 e e0') es es') : Q _ _ _ sub_es :=
                 match sub_es return Q _ _ _ sub_es with
                   | Forall2_nil => H6 e
                   | Forall2_cons e0 e0' es es' sub_e0 sub_es =>
                     H7 e0 es e e0' es' sub_e0 sub_es (Sub_rec _ _ _ sub_e0) (es_rect _ _ sub_es)
                 end) _ _ sub_es)
        | S_new ty es e es' sub_es =>
          H5 ty es e es' sub_es
             ((fix es_rect es es' (sub_es : Forall2 (fun e0 e0' => Sub e0 e e0') es es') : Q _ _ _ sub_es :=
                 match sub_es return Q _ _ _ sub_es with
                   | Forall2_nil => H6 e
                   | Forall2_cons e0 e0' es es' sub_e0 sub_es =>
                     H7 e0 es e e0' es' sub_e0 sub_es (Sub_rec _ _ _ sub_e0) (es_rect _ _ sub_es)
                 end) _ _ sub_es)
      end.
  End Sub_recursion.

  Inductive Subst : forall xt, MB xt -> list E -> E -> Prop :=
  | Sub_empty : forall e, Subst _ (mb_empty e) nil e
  | Sub_var : forall t f es e e0 e',
                (forall v : V x t, Subst _ (f v) es (e x t v)) ->
                Sub e e0 e' ->
                Subst _ (mb_var _ f) (e0::es) e'
  | Sub_this : forall t f es e e0 e',
                 (forall v : V this t, Subst _ (f v) es (e this t v)) ->
                 Sub e e0 e' ->
                 Subst this (mb_this _ f) (e0::es) e'.

 Inductive Reduce : E -> E -> Prop :=
  | R_Field : forall c ty fds es f e n,
                fields (ty_def c) fds ->
                nth_error fds n = Some (fd ty f) -> nth_error es n = Some e ->
                Reduce (fd_access (new (ty_def c) es) f) e
  | R_Invk : forall m (c:CL) (mb:MB this) es ds e,
               mbody m (ty_def c) mb ->
               Subst this mb ds e ->
               Reduce (m_call (new (ty_def c) es) m ds) e.

  Notation "e ~> d" := (Reduce e d) (at level 70).

  Scheme Reduce_rec := Induction for Reduce Sort Prop.

  Inductive C_Reduce : E -> E -> Prop :=
  | RC_Field :
      forall e e' f, C_Reduce e e' -> C_Reduce (fd_access e f) (fd_access e' f)
  | RC_Invk_Recv :
      forall e e' m es,
        C_Reduce e e' -> C_Reduce (m_call e m es) (m_call e' m es)
  | RC_Invk_Arg :
      forall e m es es',
        C_Reduce_List es es' -> C_Reduce (m_call e m es) (m_call e m es')
  | RC_New_Arg :
      forall ty es es',
        C_Reduce_List es es' -> C_Reduce (new ty es) (new ty es')
  with C_Reduce_List : list E -> list E -> Prop :=
       | Reduce_T : forall e e' es,
                      C_Reduce e e' -> C_Reduce_List (e :: es) (e' :: es)
       | Reduce_P : forall e es es',
                      C_Reduce_List es es' -> C_Reduce_List (e :: es) (e :: es').

  Section Soundness.
    Variable (WF_CT : forall c l, CT c = Some l -> L_WF l).

    Definition Fields_eq_P c fds (fields_fds : fields c fds) :=
      forall fds', fields c fds' -> fds = fds'.

    Lemma Fields_eq_H1 : Fields_eq_P _ _ fields_Obj.
      unfold Fields_eq_P; intros.
      inversion H; subst.
      reflexivity.
    Qed.

    Lemma Fields_eq_H2 : forall c d c_fds d_fds k' mds CT_c par_fds,
                           Fields_eq_P _ _ par_fds ->
                           Fields_eq_P _ _ (fields_cl c d c_fds d_fds k' mds CT_c par_fds).
      unfold Fields_eq_P; intros.
      inversion H0; subst.
      rewrite H2 in CT_c; inversion CT_c; subst. clear CT_c H2.
      rewrite (H _ H3). reflexivity.
    Qed.

    Definition Fields_eq := fun c fds fields_fds fds' => fields_rec _ Fields_eq_H1 Fields_eq_H2 c fds fields_fds fds'.

    Definition parent_fields_names_eq_P cl' d_fds (cl_fields : fields cl' d_fds) :=
      forall d d_fds' d_fds'', cl' = ty_def d -> d_fds'' = d_fds ->
        fields (ty_def d) d_fds' ->
        map (fun fd' : FD => match fd' with fd _ f => f end) d_fds =
        map (fun fd' : FD => match fd' with fd _ f => f end) d_fds'.

    Lemma parent_fields_names_eq_H1 : parent_fields_names_eq_P _ _ fields_Obj.
      unfold parent_fields_names_eq_P; intros.
      inversion H; subst. inversion H1; subst.
      reflexivity.
    Qed.

    Lemma parent_fields_names_eq_H2 :
      forall c d c_fds d_fds k' mds CT_c par_fds,
        parent_fields_names_eq_P _ _ par_fds ->
        parent_fields_names_eq_P _ _ (fields_cl c d c_fds d_fds k' mds CT_c par_fds).
      unfold parent_fields_names_eq_P; intros.
      inversion H0; subst. clear H0.
      inversion H2; subst. rewrite H1 in CT_c; inversion CT_c; subst.
      generalize (Fields_eq _ _ par_fds _ H3); intro; subst.
      reflexivity.
    Qed.

    Definition parent_fields_names_eq := fun cl' d_fds cl_fields d => fields_rec _ parent_fields_names_eq_H1 parent_fields_names_eq_H2 cl' d_fds cl_fields d.

    Definition fds_distinct_P cl' fds (fields_fds : fields cl' fds) :=
      forall c d f m n fds',
      map (fun fd' => match fd' with fd _ f => f end) fds' =
      map (fun fd' => match fd' with fd _ f => f end) fds ->
      nth_error fds' m = Some (fd c f) -> nth_error fds n = Some (fd d f) -> m = n.

    Lemma fds_distinct_H1 : fds_distinct_P _ _ fields_Obj.
      unfold fds_distinct_P; intros.
      destruct n; simpl in H1; discriminate.
    Qed.

    Lemma fds_distinct_H2 : forall c d c_fds d_fds k' mds CT_c par_fds,
                              fds_distinct_P _ _ par_fds ->
                              fds_distinct_P _ _ (fields_cl c d c_fds d_fds k' mds CT_c par_fds).
      unfold fds_distinct_P; intros.
      generalize (WF_CT _ _ CT_c); intros WF_c; inversion WF_c; subst.
      assert (distinct (map (fun fd' => match fd' with fd _ f => f end) (d_fds ++ c_fds))).
      generalize c_fds d_fds0 (parent_fields_names_eq _ _ par_fds _ _ _ (refl_equal _) (refl_equal _) H9) H12; clear.
      induction d_fds; simpl; intros c_fds d_fds0 H H0; destruct d_fds0; simpl in H, H0;
      try discriminate; auto.
      destruct a; destruct f.
      injection H; intros d_fds_eq f_eq; rewrite f_eq; destruct H0 as [NotIn_f dist_rest]; split.
      unfold not; intros In_f; apply NotIn_f; generalize d_fds0 c_fds d_fds_eq In_f; clear;
        induction d_fds; simpl; intros; destruct d_fds0; simpl in *|-*; try discriminate; auto.
      destruct a; destruct f0; simpl in d_fds_eq; injection d_fds_eq; clear d_fds_eq; intros d_fds_eq a_eq; subst.
      destruct In_f; try tauto; right; eapply IHd_fds; eauto.
      eauto.
      assert (nth_error (map (fun fd' => match fd' with fd _ f => f end) (d_fds ++ c_fds)) n = Some f).
      generalize d_fds n H2; clear;
        induction c_fds; simpl;
          try (induction d_fds; intros; destruct n; simpl in *|-* );
            first [discriminate | destruct a; injection H1; intros; subst; reflexivity | eauto];
              destruct a; simpl in *|-*; intros; try discriminate; try injection H2; intros;
                first [ try inversion H; reflexivity | eauto].
      rename H2 into H'.
      generalize n H'; clear; induction c_fds; simpl; intro n; destruct n; simpl; intros;
        try (simpl in H'; discriminate); eauto.
      destruct a; simpl in *|-*.
      injection H'; intros; subst; reflexivity.
      assert (nth_error (map (fun fd' : FD => match fd' with
                                                | fd _ f => f
                                              end) fds') m = Some f) by
      (generalize m H1; clear; induction fds'; simpl; intro m; destruct m; simpl; intros;
        try discriminate; eauto; destruct a; injection H1; intros; subst; reflexivity).
      rewrite H0 in H5.
      rewrite map_app in H5; rewrite <- map_app in H5.
      generalize m n H3 H4 H5; clear;
        induction (map (fun fd' : FD => match fd' with
                                          | fd _ f => f
                                        end) (d_fds ++ c_fds)); simpl; intros;
        destruct m; destruct n; simpl in *|-*; intros; try discriminate; auto;
          destruct H3.
      inversion H5; subst.
      elimtype False; apply H; eapply nth_error_in; eauto.
      inversion H4; subst.
      elimtype False; apply H; eapply nth_error_in; eauto.
      eauto.
    Qed.

    Definition fds_distinct := fun cl' fds fields_fds c => fields_rec _ fds_distinct_H1 fds_distinct_H2 cl' fds fields_fds c.

    Definition m_eq_dec := eq_nat_dec.

    Lemma In_m_mds_dec : forall m mds, (exists ty, exists mb, In (md ty m mb) mds) \/ (forall ty mb, ~ In (md ty m mb) mds).
      induction mds; intros; simpl.
      tauto.
      destruct a as [ty' m' mb']; destruct (m_eq_dec m m').
      subst; left; exists ty'; exists mb'; left; try reflexivity.
      destruct IHmds as [[ty'' [mb'' In_m]] | NIn_m].
      left; exists ty''; exists mb''; tauto.
      right; unfold not; intros ty mb H; destruct H.
      congruence.
      eapply NIn_m; eauto.
    Qed.

    Lemma meth_overriding S T (sub_S_T : subtype S T) : forall m Us U,
                              mtype m T (mty Us U) -> mtype m S (mty Us U).
      intros.
      induction sub_S_T; auto.
      destruct (In_m_mds_dec m mds) as [[ty [mb In_m]] | Not_In_m].
      generalize (WF_CT _ _ H0); intro WF_c. inversion WF_c. subst.
      clear CT_self.
      generalize (H8 _ In_m); intro WF_m. inversion WF_m; subst.
      rewrite H12 in H0. inversion H0. subst.
      unfold override in H13. destruct (H13 Us U H); subst.
      eapply mtype_fnd; eassumption.
      eapply mtype_not_fnd; eassumption.
    Qed.

    Lemma subclass_fields : forall S T (sub_S_T : subtype S T),
                              forall fds',
                                fields T fds' ->
                                exists fds, fields S fds /\
                                            (forall fd' n, nth_error fds' n = Some fd' -> nth_error fds n = Some fd').
      intros S T sub_S_T.
      induction sub_S_T; intros.
      Case "sub_refl".
      exists fds'. split. assumption.
      intros. assumption.
      Case "sub_trans".
      destruct (IHsub_S_T2 _ H) as [fds'' [fields_d nth_fds']].
      destruct (IHsub_S_T1 _ fields_d) as [fds''' [fields_c nth_fds'']].
      exists fds'''. split. assumption.
      intros.
      apply (nth_fds'' _ _ (nth_fds' _ _ H0)).
      Case "sub_class".
      generalize (WF_CT _ _ H); intros.
      inversion H1; subst.
      generalize (Fields_eq _ _ H0 _ H8); intro; subst.
      eexists. split. econstructor; eassumption.
      clear.
      induction d_fds; intros; destruct n; simpl in *|-*; try discriminate; auto.
    Qed.

    Definition Term_subst_pres_types_sub_P e0 d e (sub_e0 : Sub e0 d e) :=
      forall xt t (v:V xt t) D S, E_WF (e0 _ _ v) D ->
                                  E_WF d S ->
                                  subtype S t ->
                                  exists C, E_WF e C /\ subtype C D.

    Definition Term_subst_pres_types_sub_Q es d es' (sub_es : List_P2' (fun e0 e0' => Sub e0 d e0') es es') :=
      forall xt t (v:V xt t) Ds S,
        List_P2' E_WF (map (fun e0 => e0 _ _ v) es) Ds ->
        E_WF d S ->
        subtype S t ->
        exists Cs, List_P2' E_WF es' Cs /\ List_P2' subtype Cs Ds.

    Lemma Term_subst_pres_types_sub_H1 : forall e, Term_subst_pres_types_sub_P _ _ _ (S_var_eq e).
      unfold Term_subst_pres_types_sub_P; intros.
      inversion H; repeat subst.
      exists S. split; assumption.
    Qed.

    Lemma Term_subst_pres_types_sub_H2 : forall xt t v e, Term_subst_pres_types_sub_P _ _ _ (S_var_neq xt t v e).
      unfold Term_subst_pres_types_sub_P; intros.
      exists D. split. assumption. constructor.
    Qed.

    Lemma Term_subst_pres_types_sub_H3 : forall e0 e e0' f sub_e0, Term_subst_pres_types_sub_P _ _ _ sub_e0 -> Term_subst_pres_types_sub_P _ _ _ (S_fd_access e0 e e0' f sub_e0).
      unfold Term_subst_pres_types_sub_P; intros.
      inversion H0; subst.
      destruct (H _ _ _ _ _ H5 H1 H2) as [E [wf_e0' sub_E]].
      destruct (subclass_fields _ _ sub_E _ H6) as [fds' [fields_E nth_fds]].
      generalize (nth_fds _ _ H8); intros.
      exists D. split. econstructor; eassumption. constructor.
    Qed.

    Lemma Term_subst_pres_types_sub_H4 : forall e0 es e e0' es' m sub_e0 sub_es, Term_subst_pres_types_sub_P _ _ _ sub_e0 -> Term_subst_pres_types_sub_Q _ _ _ sub_es -> Term_subst_pres_types_sub_P _ _ _ (S_m_call e0 es e e0' es' m sub_e0 sub_es).
      unfold Term_subst_pres_types_sub_P; unfold Term_subst_pres_types_sub_Q; intros.
      inversion H1; subst.
      rename Us into Es. rename Ss into Ds. rename ty_0 into D0.
      destruct (H _ _ _ _ _ H7 H2 H3) as [C0 [wf_e0' sub_C0_D0]].
      destruct (H0 _ _ _ _ _ H10 H2 H3) as [Cs [wf_es' sub_Cs_Ds]].
      generalize (meth_overriding _ _  sub_C0_D0 _ _ _ H8); intro.
      eexists.
      split. econstructor; try eassumption.
      generalize sub_Cs_Ds H11; clear; intros.
      Prop_Ind H11; intros; inversion sub_Cs_Ds; subst; constructor.
      constructor 2 with (d:=a); assumption.
      eapply IHList_P2'; eauto.
      constructor.
    Qed.

    Lemma Term_subst_pres_types_sub_H5 : forall ty es e es' sub_es, Term_subst_pres_types_sub_Q _ _ _ sub_es -> Term_subst_pres_types_sub_P _ _ _ (S_new ty es e es' sub_es).
      unfold Term_subst_pres_types_sub_P; unfold Term_subst_pres_types_sub_Q; intros.
      inversion H0; subst.
      destruct (H _ _ _ _ _ H6 H1 H2) as [Es [wf_es' sub_Es_Ss]].
      eexists. split.
      econstructor; try eassumption.
      generalize H8 sub_Es_Ss; clear; intros.
      Prop_Ind H8; intros; inversion sub_Es_Ss; subst; constructor.
      destruct b.
      constructor 2 with (d:=a); assumption.
      eapply IHList_P2'; eauto.
      constructor.
    Qed.

    Lemma Term_subst_pres_types_sub_H6 : forall e, Term_subst_pres_types_sub_Q _ _ _ (nil_P2' (fun e0 e0' => Sub e0 e e0')).
      unfold Term_subst_pres_types_sub_Q; intros.
      inversion H; subst.
      exists nil. split; constructor.
    Qed.

    Lemma Term_subst_pres_types_sub_H7 : forall e0 es e e0' es' sub_e0 sub_es, Term_subst_pres_types_sub_P e0 e e0' sub_e0 -> Term_subst_pres_types_sub_Q es e es' sub_es -> Term_subst_pres_types_sub_Q _ _ _ (cons_P2' _ _ _ _ _ sub_e0 sub_es).
      unfold Term_subst_pres_types_sub_P; unfold Term_subst_pres_types_sub_Q; intros.
      inversion H1; subst.
      destruct (H _ _ _ _ _ H6 H2 H3). destruct H4.
      destruct (H0 _ _ _ _ _ H8 H2 H3). destruct H7.
      eexists. split. econstructor; eassumption.
      constructor; assumption.
    Qed.

    Definition Term_subst_pres_types_sub := Sub_rec _ _ Term_subst_pres_types_sub_H1 Term_subst_pres_types_sub_H2 Term_subst_pres_types_sub_H3 Term_subst_pres_types_sub_H4 Term_subst_pres_types_sub_H5 Term_subst_pres_types_sub_H6 Term_subst_pres_types_sub_H7.

    Lemma Term_subst_pres_types : forall mb D0 D,
                                   E_WF_in_MB D0 this mb D ->
                                   forall ds Ss Us e,
                                     List_P2' E_WF ds Ss ->
                                     List_P2' subtype Ss Us ->
                                     Extract_tys this mb Us ->
                                     Subst this mb ds e ->
                                     exists E, E_WF e E /\ subtype E D.
      intros mb D0 D H.
      induction H.
      Case "wf_e_mb_empty".
      intros.
      inversion H3; subst.
      exists ty. split. assumption. constructor.
      Case "wf_e_mb_var".
      intros.
      inversion H4; subst.
      inversion H3; subst.
      assert (JMeq f1 f) by
          (change match existT (fun t => V x t -> MB x) t f1 with
                       | existT t f1 => JMeq f1 f
                   end; rewrite H6; constructor); subst; clear H6.
      assert (JMeq ctxt0 f) by
          (change match existT (fun t => V x t -> MB x) t ctxt0 with
                       | existT t ctxt0 => JMeq ctxt0 f
                   end; rewrite H9; constructor); subst; clear H9.
      inversion H1; subst.
      inversion H2; subst.
      rename e1 into d.
      destruct (variables_exist _ _ H7) as [v sub_v].
      generalize (H10 v); intro ex_tys.
      destruct (H0 _ _ _ _ _ H12 H15 ex_tys sub_v).
      generalize Term_subst_pres_types_sub; intro.
      destruct H5.
      destruct (H6 _ _ _ H8 _ _ _ _ _ H5 H9 H13).
      destruct H14.
      exists x1. split. assumption.
      constructor 2 with (d:=x0); assumption.
      Case "wf_e_mb_this".
      intros.
      inversion H4; subst.
      inversion H3; subst.
      assert (JMeq f1 f) by
          (change match existT (fun t => V _ t -> MB x) D0 f1 with
                       | existT D0 f1 => JMeq f1 f
                   end; rewrite H6; constructor); subst; clear H6.
      assert (JMeq ctxt0 f) by
          (change match existT (fun t => V _ t -> MB x) D0 ctxt0 with
                       | existT D0 ctxt0 => JMeq ctxt0 f
                   end; rewrite H9; constructor); subst; clear H9.
      inversion H1; subst.
      inversion H2; subst.
      destruct (this_exists _ _ H7) as [v sub_v].
      generalize (H10 v); intro ex_tys.
      destruct (H0 _ _ _ _ _ H12 H15 ex_tys sub_v).
      generalize Term_subst_pres_types_sub; intro.
      destruct H5.
      destruct (H6 _ _ _ H8 _ _ _ _ _ H5 H9 H13).
      destruct H14.
      exists x1. split. assumption.
      constructor 2 with (d:=x0); assumption.
    Qed.

    Lemma Lem_1_4 :
      forall m c0 mb,
        mbody m c0 mb ->
        forall Ds d, mtype m c0 (mty Ds d) ->
                     exists D0, exists c, subtype c0 D0 /\
                                          subtype c d /\
                                          Extract_tys _ mb Ds /\
                                          E_WF_in_MB D0 _ mb c.
      intros m c0 mb mb_c0.
      induction mb_c0.
      Case "mb_class".
      intros.
      inversion H1; subst.
      SCase "m in mds".
      rewrite H in H6. inversion H6; subst. clear H6.
      generalize (WF_CT _ _ H); intros. inversion H2; subst.
      generalize (H12 _ H0) (H12 _ H7). intros.
      inversion H3; subst. inversion H4; subst.
      rewrite H23 in H18. inversion H18; subst. clear H18.
      rewrite H in H23. inversion H23; subst. clear H23.
      assert (mb0 = mb).
      generalize H0 H7 H13; clear; intros.
      induction mds. inversion H0.
      inversion H0; inversion H7.
      rewrite H in H1. inversion H1; subst. split; reflexivity.
      subst. inversion H13.
      contradict H.
      apply (in_map (fun md' => match md' with md _ m _ => m end) _ _ H1).
      subst. inversion H13.
      contradict H1.
      apply (in_map (fun md' => match md' with md _ m _ => m end) _ _ H).
      inversion H13.
      apply (IHmds H H1 H3).
      subst.
      repeat eexists; eauto.
      constructor.
      SCase "m not in mds".
      rewrite H in H3. inversion H3; subst. clear H3.
      destruct (H4 ty mb H0).
      Case "mb_super".
      intros.
      inversion H1; subst.
      SCase "m in mds".
      rewrite H in H6. inversion H6; subst.
      destruct (H0 _ _ H7).
      SCase "m not in mds".
      rewrite H in H3. inversion H3; subst. clear H3.
      destruct (IHmb_c0 _ _ H6)
               as [D0' [c' [sub_d1_D0' [sub_c_d [ext_Ds wf_mb']]]]].
      repeat eexists; eauto.
      destruct d1.
      constructor 2 with (d:=ty_def c0).
      eapply sub_class; eauto. assumption.
    Qed.

    Definition pres_P e e' (red_c : Reduce e e') :=
      forall c, E_WF e c -> exists d, E_WF e' d /\ subtype d c.

    Lemma pres_H1 : forall c ty fds es f e0 n fields_fds fds_n es_n,
                      pres_P _ _ (R_Field c ty fds es f e0 n fields_fds fds_n es_n).
      unfold pres_P; intros.
      inversion H; subst.
      inversion H2; subst.
      generalize (Fields_eq _ _ H3 _ H4).
      generalize (Fields_eq _ _ H4 _ fields_fds).
      intros; subst.
      rename Ss into Cs.
      apply P2'_if_P2 in H6; unfold List_P2 in H6; destruct H6 as [fnd_es not_fnd_es].
      destruct (fnd_es _ _ es_n) as [C [Cs_n wf_e0]].
      exists C. split. eassumption.
      rewrite <- (fds_distinct _ _ H3 _ _ _ _ _ _ (refl_equal _) fds_n H5) in H5.
      apply P2'_if_P2 in H8; unfold List_P2 in H8; destruct H8 as [fnd_Cs not_fnd_Cs].
      destruct (fnd_Cs _ _ Cs_n) as [fd' [fds_n' sub_C]].
      rewrite fds_n' in H5. inversion H5. subst.
      assumption.
    Qed.

    Lemma pres_H2 : forall m c mb es ds e mbody_m sub_mb,
                      pres_P _ _ (R_Invk m c mb es ds e mbody_m sub_mb).
      unfold pres_P; intros.
      inversion H; subst. inversion H3; subst.
      rename c0 into c1. rename c into c0. rename c1 into c.
      rename e into e'. rename Us into Ds. rename Ss into Cs.
      destruct (Lem_1_4 _ _ _ mbody_m _ _ H4)
        as [D0 [b [sub_c0_D0 [sub_b_c [ext_Ds wf_mb]]]]].
      destruct (Term_subst_pres_types _ _ _ wf_mb _ _ _ _ H6 H7 ext_Ds sub_mb)
               as [d [wf_e' sub_d_b]].
      exists d. split.
      assumption.
      constructor 2 with (d:=b); assumption.
    Qed.

End FJ_Definition.


Require Import Coq.ZArith.ZArith.
Require Import Coq.ZArith.Znumtheory.
Require Import ExtLib.Data.List.
Require Import ExtLib.Data.Bool.
Require Import String.
Require Maps.
Require Coq.funind.Recdef.
Import Nnat.

Require Import CpdtTactics.
Require Import ExtLib.Structures.Monads ExtLib.Data.Monads.StateMonad.

(* Add LoadPath "../common" as Common. *)
(* Add LoadPath "../L1_MalechaQuoted" as L1. *)
(* Add LoadPath "../L2_typeStripped" as L2. *)
(* Add LoadPath "../LambdaBoxMut_flattenedApp" as LambdaBoxMut. *)
(* Add LoadPath "../LambdaBoxLocal" as LambdaBoxLocal. *)
(* Add LoadPath "../L5_LambdaANF" as LambdaANF. *)

(*
This file has been moved to certicoq/oldL5. was it needed? If so, please
revert the commit 7625.

Require Export LambdaANF.cpseval
*)
Require Import cps.
Require Import cps_util.
Require Import shrink_cps.
Require Import cps_show.

Require Import L5_to_LambdaANF closure_conversion uncurry.

Definition compile_L1_to_LambdaBoxLocal := LambdaBoxMut_to_LambdaBoxLocal.program_exp.

Check L5a.compile_L1_to_L5a.

Definition emap {A B} (f:A->B) (en: exceptionMonad.exception A) :
  exceptionMonad.exception B :=
  match en with
  | exceptionMonad.Exc s => exceptionMonad.Exc s
  | exceptionMonad.Ret e => exceptionMonad.Ret (f e)
  end.

Definition show_exn (x : exceptionMonad.exception exp) : string :=
  match x with
  | exceptionMonad.Exc s => s
  | exceptionMonad.Ret e => show_exp e
  end.

Definition compile_L1_to_LambdaANF (e:Ast.program) :=
    match L5a.compile_L1_to_L5a e with
    | exceptionMonad.Exc s => exceptionMonad.Exc s
    | exceptionMonad.Ret e => exceptionMonad.Ret (convert_top (L5a.Halt_c e))
    end.

Quote Recursively Definition p0L1 := 0%nat.
Eval compute in compile_L1_to_LambdaANF p0L1.

Definition uncurry_LambdaANF := emap (fun x => match uncurry x with
                                        | None => x
                                        | Some y => y
                                        end).
Definition shrink_once_LambdaANF := emap shrink_top.
Definition closure_convert_LambdaANF := emap closure_conversion.
Definition compile_uncurry (e:Ast.program) :=
  uncurry_LambdaANF (compile_L1_to_LambdaANF e).

Eval compute in compile_uncurry p0L1.

Quote Recursively Definition P1L1 := (fun x:nat => x).
Definition P1LambdaANF := Eval compute in compile_L1_to_LambdaANF P1L1.
Definition P1LambdaANFs := Eval compute in shrink_once_LambdaANF P1LambdaANF.
Eval compute in show_exn P1LambdaANF.
Eval compute in show_exn P1LambdaANFs.
Definition P1LambdaANFu := Eval compute in uncurry_LambdaANF P1LambdaANF.
Eval compute in show_exn P1LambdaANFu.
Definition P1LambdaANFsu := Eval compute in uncurry_LambdaANF P1LambdaANFs.
Eval compute in show_exn P1LambdaANFsu.

Quote Recursively Definition P2L1 := (fun (x y:nat) => x).
Definition P2LambdaANF := Eval compute in compile_L1_to_LambdaANF P2L1.
Eval compute in show_exn P2LambdaANF.
Definition P2LambdaANFs := Eval compute in shrink_once_LambdaANF P2LambdaANF.
Eval compute in show_exn P2LambdaANFs.
Definition P2LambdaANFsu := Eval compute in uncurry_LambdaANF P2LambdaANFs.
Eval compute in show_exn P2LambdaANFsu.
Definition P2LambdaANFu := Eval compute in uncurry_LambdaANF P2LambdaANF.
Print P2LambdaANFu.

Definition P3 := (fun f:nat => 0%nat).
Quote Recursively Definition P3L1 := P3.
Definition P3LambdaANF := Eval compute in compile_L1_to_LambdaANF P3L1.
Eval compute in show_exn P3LambdaANF.
Definition P3LambdaANFs := Eval compute in shrink_once_LambdaANF P3LambdaANF.
Eval compute in show_exn P3LambdaANFs.

Definition P4 := (0,1)%nat.
Quote Recursively Definition P4L1 := P4.
Definition P4LambdaBoxLocal := Eval compute in compile_L1_to_LambdaBoxLocal P4L1.
Print P4LambdaBoxLocal.
Definition P4LambdaANF := Eval compute in compile_L1_to_LambdaANF P4L1.
Eval compute in show_exn P4LambdaANF.
(* This doesn't shrink correctly. *)
Definition P4LambdaANFs := Eval compute in shrink_once_LambdaANF P3LambdaANF.
Eval compute in show_exn P4LambdaANFs.

Definition P5 :=
  (fun x => match x with | 0 => 0 | S n => n end)%nat.
Quote Recursively Definition P5L1 := P5.
Definition P5LambdaANF := Eval compute in compile_L1_to_LambdaANF P5L1.
Eval compute in show_exn P5LambdaANF.
(* This doesn't shrink correctly. *)
Definition P5LambdaANFs := Eval compute in shrink_once_LambdaANF P5LambdaANF.
Eval compute in show_exn P5LambdaANFs.
(*
Definition p0L5 := Eval compute in compile p0L1.
Print p0L5.
Check compile.
Check (compile : Ast.program -> exceptionMonad.exception cps).
Definition p0LambdaANF := compile_to_LambdaANF p0L5.
Definition p0LambdaANFs := Eval compute in shrink_once_LambdaANF p0LambdaANF.
Definition p0LambdaANFscc := Eval compute in closure_convert_LambdaANF p0LambdaANF.
Print p0LambdaANFs.
*)
(* Print p0LambdaANFscc. *)

Definition sabry (x:nat): (nat -> nat) :=
  fun (y:nat) => x.

Quote Recursively Definition pSabryL1 := sabry.
Definition pSabryLambdaANF := Eval compute in compile_L1_to_LambdaANF pSabryL1.
Print pSabryLambdaANF.
Definition pSabryLambdaANFu := Eval compute in compile_uncurry pSabryL1.
Print pSabryLambdaANFu.
Definition pSabryLambdaANFs := Eval compute in shrink_once_LambdaANF pSabryLambdaANFu.
Print pSabryLambdaANFs.
Definition feil:nat := sabry (0%nat) (1%nat).

Quote Recursively Definition pFeilL1 := feil.
Definition pFeilL5 := Eval compute in compile pFeilL1.
Definition pFeilLambdaANF := Eval compute in compile_to_LambdaANF pFeilL5.
Definition pFeilLambdaANFs := Eval compute in shrink_once_LambdaANF pFeilLambdaANF.
Definition pFeilLambdaANFss := Eval compute in shrink_once_LambdaANF pFeilLambdaANFs.
Definition pFeilLambdaANFsss := Eval compute in shrink_once_LambdaANF pFeilLambdaANFss.
Print pFeilLambdaANFs.
Print pFeilL5.
Print pFeilLambdaANFsss.

Fixpoint idn (n:nat) : nat := n.
Quote Recursively Definition pIdnL1 := idn.
Definition pIdnL5 := Eval compute in compile pIdnL1.
Definition pIdnLambdaANF := Eval compute in compile_to_LambdaANF pIdnL5.

Definition pIdnLambdaANFs := Eval compute in shrink_once_LambdaANF pIdnLambdaANF.
(* Definition pIdnLambdaANFcc := Eval compute in
      closure_convert_LambdaANF pIdnLambdaANFs.
Print pIdnLambdaANFcc. *)
Print pIdnLambdaANF.
Print pIdnLambdaANFs.

(* Can all administrative redexes be reduces in one round of shrink? *)
Definition predn (n : nat) : nat :=
  match n with 0%nat => 0 | S n => n end.
Quote Recursively Definition pPredL1 := predn.
Print pPredL1.
Definition pPredL5 := Eval compute in compile pPredL1.
Definition pPredLambdaANF := Eval compute in compile_to_LambdaANF pPredL5.
Print pPredLambdaANF.
Definition pPredLambdaANFs := Eval compute in shrink_once_LambdaANF (pPredLambdaANF).
Definition pPredLambdaANFcc := Eval compute in
      (closure_convert_LambdaANF pPredLambdaANFs).
Print pPredLambdaANFs.
Print pPredLambdaANFcc.

Transparent N.add.
Quote Recursively Definition p_add01 := (Nat.add 0%nat 1).
Print p_add01.
Definition pAdd01L5 := Eval compute in compile p_add01.
Definition pAdd01LambdaANF := Eval compute in compile_to_LambdaANF pAdd01L5.
Definition pAdd01LambdaANFs := Eval compute in shrink_once_LambdaANF (pAdd01LambdaANF).
Print pAdd01LambdaANFs.

Inductive Alph : Set :=
| A : Alph
| B : Alph
| C : nat -> Alph
| D : nat -> Alph ->  nat -> Alph.

Fixpoint foo (a:Alph) (b:Alph) : nat :=
  match a with
    | A => 0
    | D x z y => foo z a
    | _ => 2
  end.

Fixpoint foo2 (a:Alph*Alph) : nat :=
  match a with
     | (A, x) => 0
     | (y, D _ _ _) => 1
     | (B, x) => 2
     |  _ => 3
  end.

Quote Recursively Definition pFooL1 := foo.
Print pFooL1.
Definition pFooL5 := Eval compute in compile pFooL1.
Definition pFooLambdaANF := Eval compute in compile_to_LambdaANF pFooL5.
Definition pFooLambdaANFs := Eval compute in shrink_once_LambdaANF (pFooLambdaANF).
Print pFooLambdaANFs.

(* Reflect back at Nat ?

Write to certicoq:

(0) test in tests.v ...

(1) AXIOMS REJECTED by malecha_L1 even if in Prop <---| High priority due to prop axioms

TEST SHRINK REDUCER
 extract shrink to ocaml and test efficiency

 translate to C and test efficiency
*)
Quote Recursively Definition pShrink := convert_top.
Set Printing Depth 100.
Print pShrink.
Definition pShrinkL5 := Eval compute in compile pShrink.
Print pShrinkL5.
Definition pShrinkLambdaANF := Eval compute in compile_to_LambdaANF pShrinkL5.
Definition pShrinkLambdaANFs := Eval compute in shrink_once_LambdaANF pShrinkLambdaANF.
Print pShrinkLambdaANFs.


(* This is the top-level file in this development.  It uses the other files and shows that one can construct certain localizations that are not provably accessible. *)

Require Import HoTT.
(* This redundant line is so that we pick up the intended [factor1] and [factor2]. If Sets/Ordinals.v is changed, we can remove the next line. *)
Require Import HoTT.Factorization.

Require Import CORS.
Require Import Conn.
Require Import Smallness.
Require Import misc.

(* See Smallness.v for a discussion of universe variables. *)

(* If i <= j and [O] is a reflective subuniverse of [Type@{j}] such that when [X] is in [Type@{i}], [O X] is i-small, then [O] restricts to a reflective subuniverse of [Type@{i}]. This is Proposition 3.2 from the paper. *)
(* This only requires [Funext] because [O] is not assumed to unconditionally land in [HProp]s, so we can't resize the predicate defining the subuniverse unless we have [Funext].  One could also relax the requirement that the predicate lands in the universe [i]. *)
Definition restrict_O@{i j | i <= j} `{PropResizing} `{Funext}
           (O : ReflectiveSubuniverse@{j})
           (sX : forall X : Type@{i}, IsSmall@{i j} (O X))
  : ReflectiveSubuniverse@{i}.
Proof.
  snrapply Build_ReflectiveSubuniverse.
  - snrapply Build_Subuniverse.
    + exact (fun X => (resize_hprop (In O X))).           (* The predicate on Type@{i}. *)
    + exact _.                                            (* It's an hprop, by [ishprop_resize_hprop]. *)
    + intros T U I f feq. cbn; cbn in I.                  (* It's replete. *)
      apply equiv_resize_hprop.
      srapply (inO_equiv_inO T f).
      apply (equiv_resize_hprop _)^-1%equiv.
      exact I.
  - intro X.
    snrapply Build_PreReflects.
    + exact (smalltype (sX X)).                           (* The reflected type. *)
    + cbn.                                                (* It's in the new O. *)
      apply equiv_resize_hprop.
      srapply (inO_equiv_inO (O X) (equiv_smalltype (sX X))^-1%equiv).
    + exact ((equiv_smalltype (sX X))^-1%equiv o (to O X)).  (* The map from X to the reflected type. *)
  - intro X.                                              (* The universal property. *)
    snrapply Build_Reflects.
    intros Q Q_inO.
    cbn; cbn in Q_inO.
    nrapply ooextendable_compose.
    + rapply ooextendable_equiv.
    + rapply extendable_to_O'.
      exact ((equiv_resize_hprop _)^-1%equiv Q_inO).
Defined.

(* This just combines [restrict_O] and [issmall_n_image]. *)
Definition restrict_O'@{i j k u | i <= j, i < k, j <= k, k < u} `{PropResizing} `{Univalence}
           (n : trunc_index) (O : ReflectiveSubuniverse@{j})
           (C : forall X : Type@{i}, IsConnMap@{k} n (to O X))
           (L : forall X : Type@{i}, IsLocallySmall@{i j k} (trunc_index_to_nat n) (O X))
  : ReflectiveSubuniverse@{i}.
Proof.
  snrapply (restrict_O O).
  intro X.
  rapply issmall_n_image@{i j k u}.
  apply L.
Defined.

(* Given a family of maps, form the family with the map [S^{n+2} -> Unit] added. *)
Local Definition extended_generators@{j} (n : trunc_index)
      {I : Type@{j}} {A B : I -> Type@{j}} (f : forall i, A i -> B i)
  : LocalGenerators@{j}.
Proof.
  snrapply Build_LocalGenerators.
  - exact (sum@{j j} I Unit).
  - intros [i | u].
    + exact (A i).
    + exact (Sphere@{j} n.+2).
  - intros [i | u].
    + exact (B i).
    + exact Unit.
  - intros [i | u].
    + exact (f i).
    + exact (fun _ => tt).
Defined.

(* Being local with respect to the extended generating set is equivalent to being n-truncated and local with respect to the original family of maps. This could be generalized as in RSS Thm 3.29. *)
Definition islocal_extended_generators@{k} (n : trunc_index)
      {I : Type@{k}} {A B : I -> Type@{k}} (f : forall i, A i -> B i)
      (X : Type@{k})
  : IsLocal (extended_generators n f) X <-> IsLocal (Build_LocalGenerators _ _ _ f) X * IsTrunc n.+1 X.
Proof.
  destruct (istrunc_iff_sphere_oo_null@{k k k k} n X)
    as [ooext_istrunc istrunc_ooext].
  split.
  - intro isLX.
    split.
    + intro a; cbn.
      exact (isLX (inl a)).
    + apply istrunc_ooext.
      rapply (@ooextendable_islocal _ _ _ (inr tt)).
  - intros [isLX isTrX].
    intros [a | b].
    + apply isLX.
    + cbn.
      apply ooext_istrunc; assumption.
Defined.

(* Given any family of n-connected maps in any universe [Type@{j}], one can localize in [Type@{i}] with respect to the extended family. This is Theorem 3.3 from the paper. Note that since localizations exist in all universes, we can remove the constraint that [i <= j]. *)
Definition nonaccessible_localization@{i j k u | i < k, j <= k, k < u} `{PropResizing} `{Univalence}
           (n : trunc_index) {I : Type@{j}}
           {A B : I -> Type@{j}} (f : forall i, A i -> B i) (C : forall i, IsConnMap n (f i))
  : ReflectiveSubuniverse@{i}.
Proof.
  (* We first form the localization in a universe [k], with [i < k] and [j <= k].  Having [O] in the context helps at the end of the proof. *)
  pose (O := Loc@{k k} (extended_generators n f)).
  snrapply (restrict_O'@{i k k u} n O).
  - intro X.
    apply eta_connected_generators_connected_tr@{k k u}.
    intros [i | u].
    + cbn. apply lift_isconnmap_trunc@{j k}. apply C.
    + cbn.
      apply conn_map_to_unit_isconnected@{k k}.
      apply isconnected_pred.
      nrapply isconnected_sn.
  - intro X.  (* All local types are (n+2)-locally small, since S^{n+2} -> Unit is a generator. *)
    apply islocally_small_trunc@{i k k u}.
    exact (snd (fst (islocal_extended_generators n f (O X)) _)).
Defined.

(* Here we just nail down the fact that the local objects are the n-truncated objects that are local with respect to the original family.  The only difference from [islocal_extended_generators] is that we have to handle the propositional resizing, and we state truncation in the universe [i] containing [X]. *)
Definition in_nonaccessible_localization@{i j k u | i < k, j <= k, k < u} `{PropResizing} `{Univalence}
           (n : trunc_index) {I : Type@{j}}
           {A B : I -> Type@{j}} (f : forall i, A i -> B i) (C : forall i, IsConnMap n (f i))
           (X : Type@{i})
  : In (nonaccessible_localization@{i j k u} n f C) X <-> IsLocal (Build_LocalGenerators@{k} _ _ _ f) X * IsTrunc n.+1 X.
Proof.
  (* Get rid of propositional resizing on the LHS: *)
  apply (iff_compose@{u k} (iff_inverse@{u k} (iff_equiv (equiv_resize_hprop _)))).
  apply (iff_compose@{u k} (islocal_extended_generators n f X)).
  (* Change from [IsTrunc@{i}] to [IsTrunc@{k}]. *)
  nrapply iff_functor_prod.
  - split; exact idmap.
  - split; exact (@istrunc_equiv_istrunc _ _ equiv_idmap _).
Defined.

(* A special case of [nonaccessible_localization], which reproduces the Casacuberta-Scevenels-Smith result.  Associated to any family of surjective group homomorphisms, there is a localization onto the 1-types which are local with respect to the family. *)
Definition rsu_from_group_surjections@{i j k u | i < k, j <= k, k < u} `{PropResizing} `{Univalence}
           (I : Type@{j}) (A B : I -> Group@{j}) (f : forall i, GroupHomomorphism (A i) (B i))
           (S : forall i, IsSurjection (f i))
  : ReflectiveSubuniverse@{i}.
Proof.
  snrapply (nonaccessible_localization@{i j k u} 0).
  4: exact (fun i => fmap pClassifyingSpace (f i)).
  intro i;
  apply isconn_map_functor_pclassifyingspace@{j u};
  apply S.
Defined.

(* If i <= j and [OFS] is a factorization system on [Type@{j}] such that when [f] is in [Type@{i}], the image is i-small, then [OFS] restricts to a factorization system on [Type@{i}]. *)
Definition restrict_OFS@{i j | i <= j} `{PropResizing} (OFS : FactorizationSystem@{j j j})
           (is : forall (X Y : Type@{i}) (f : X -> Y), IsSmall@{i j} (factor OFS f))
  : FactorizationSystem@{i i i}.
Proof.
  snrapply Build_FactorizationSystem.
  - intros X Y g; exact (resize_hprop@{j i} (class1 OFS g)).
  - intros; apply ishprop_resize_hprop.
  - intros; simpl.
    apply equiv_resize_hprop.
    rapply class1_isequiv.
  - intros; simpl in *.
    apply equiv_resize_hprop.
    apply class1_compose; rapply (equiv_resize_hprop _)^-1%equiv; assumption.
  - intros X Y g; exact (resize_hprop@{j i} (class2 OFS g)).
  - intros; apply ishprop_resize_hprop.
  - intros; simpl.
    apply equiv_resize_hprop.
    rapply class2_isequiv.
  - intros; simpl in *.
    apply equiv_resize_hprop.
    apply class2_compose; rapply (equiv_resize_hprop _)^-1%equiv; assumption.
  - intros X Y g.
    snrapply  Build_Factorization.
    + exact (smalltype (is X Y g)).
    + exact ((equiv_smalltype (is X Y g))^-1%equiv o (factor1 (factor OFS g))).
    + exact ((factor2 (factor OFS g)) o (equiv_smalltype (is X Y g))).
    + intro x.
      refine ((ap _ _) @ _).
      * apply eisretr.
      * apply fact_factors.
    + apply equiv_resize_hprop.
      apply (class1_compose _ (factor1 _)).
      * apply inclass1.
      * rapply class1_isequiv.
    + apply equiv_resize_hprop.
      apply (class2_compose _ _ (factor2 _)).
      * apply class2_isequiv.
        (* Have to spell this out, or else Coq forces i = j for some reason: *)
        exact (equiv_isequiv (equiv_smalltype (is X Y g))).
      * apply inclass2.
  - intros X Y f fact fact'.
    let T := type of fact in transparent assert (liftfact : (T -> Factorization@{j} (@class1 OFS) (@class2 OFS) f)).
    { intro facti; destruct facti.
      snrapply Build_Factorization; try assumption.
      all: apply (equiv_resize_hprop _)^-1%equiv; assumption. }
    destruct (path_factor OFS f (liftfact fact) (liftfact fact')).
    snrapply Build_PathFactorization; assumption.
Defined.

(* RSS Theorem 2.41, which I don't think has been formalized. *)
Definition OFS_from_family@{j} (f : LocalGenerators@{j})
  : FactorizationSystem@{j j j}.
Admitted.

(* Theorem 3.6 from the paper. The definition of OFS in the library is different from in the paper, so the proof needs to be slightly different.  In the paper, [L] is defined to be the class of maps in [Type@{i}] which are left orthogonal to [R], while here we define [L] to be the restriction of [L'] to [Type@{i}].  It follows that both definitions agree. *)
(* Unfortunately, the HoTT library is currently missing too many things for this to be fully formalized.  The notion of maps being orthogonal (the unique lifting property) has not been defined.  We also need that being right orthogonal to [S^{n+1} -> 1] implies being n-truncated (similar to istrunc_allnullhomot), and that being left orthogonal to the maps that are right orthogonal to a class of (n-1)-connected maps means you are (n-1)-connected. *)
Definition nonaccessible_OFS@{i j u} `{PropResizing} `{Univalence}
           (n : trunc_index) (I : Type@{j})
           (A B : I -> Type@{j}) (f : forall i, A i -> B i) (C : forall i, IsConnMap n (f i))
  : FactorizationSystem@{i i i}.
Proof.
  pose (OFS := OFS_from_family (extended_generators n f)).
  apply (restrict_OFS OFS).
  intros X Y g.
  snrapply (issmall_n_image n (factor1 (factor OFS g))).
  - admit.   (* Left factor is n-connected. *)
  - apply (islocally_small_truncmap n (factor2 (factor OFS g))).
    + admit.  (* Right factor is (n+1)-truncated. *)
    + apply islocally_small_in.
Admitted.
(* Need to add universe constraints when this is finished. *)