Require Import Coq.Relations.Relations.

Require Export CatSem.CAT.retype_functor_po.
Require Export CatSem.CAT.rmonad_gen_type_po.

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

Notation "^ f" := (lift (M:= opt_monad _) f) (at level 5).

Ltac fin := simpl in *; intros;
   autorewrite with fin; auto with fin.

Hint Unfold lift : fin.
Hint Extern 1 (_ = _) => f_equal : fin.

Notation "V *" := (opt (T:=unit) _ V) (at level 5).

Definition TT := ITYPE unit.

Lemma l_eq (V W : TT) (f g : forall t, V t -> W t) r:
   (forall t v, f t v = g t v) ->
       (forall t (v : opt r V t),
       lift (M:=opt_monad r) f t v = ^g t v).
Proof.
  intros.
  destruct v;
  unfold lift;
  simpl;
  auto.
  rewrite H.
  auto.
Qed.

(*
Inductive ULC_ (V : Type) : Type :=
  | Var : V -> ULC_ V
  | Abs : ULC_ (option V) -> ULC_ V
  | App : ULC_ V -> ULC_ V -> ULC_ V.

Definition ULC_d (V : TT) : Type :=
      ULC_ (V tt).
Definition ULC (V : TT) : TT :=
       fun _ => ULC_d V.
*)

Inductive ULC (V : TT) : TT :=
  | Var : forall t, V t -> ULC V t
  | Abs : forall r s : unit, ULC (opt r V) s -> ULC V tt
  | App : forall r s, ULC V tt -> ULC V r -> ULC V s.

Lemma App_eq V r s (M M' : ULC V tt) (N N' : ULC V r) :
  M = M' -> N = N' -> App _ M N = App s M' N'.
Proof.
  intros.
  rewrite H.
  rewrite H0.
  auto.
Qed.

Fixpoint rename V W (f : V ---> W) t (y : ULC V t) :
          ULC W t :=
  match y with
  | Var _ v => Var (f _ v)
  | Abs _ _  v => Abs (rename ^f v)
  | App _ _  s t => App _ (rename f s) (rename f t)
  end.

Definition inj u V := rename (V:=V) (W:= opt u V)
                (@some unit u V).

Definition _shift (u : unit) (V W : TT) (f : V ---> ULC W) :
         V*  ---> ULC (W*) :=
   fun t v =>
   match v in (opt _ _ y) return (ULC (W *) y) with
   | some t0 p => inj u (f t0 p)
   | none => Var (none u W)
   end.

Fixpoint _subst V W (f : V ---> ULC W) t (y : ULC V t) :
         ULC W t :=
  match y with
  | Var _ v => f _ v
  | Abs _ _ v => Abs (_subst (_shift f) v)
  | App _ _ s t => App _ (_subst f s) (_subst f t)
  end.

Definition substar (u : unit) (V : TT) (M : ULC V u) :
           ULC (opt u V) ---> ULC V :=
 _subst (fun t (y : opt u V t) => match y with
         | none => M
         | some _ v => Var v
         end).

Notation "M [*:= N ]" := (substar N M) (at level 50).

(** Notations for functions *)
Notation "y //- f" := (rename f y)
  (at level 42, left associativity).
Notation "y >- f" := (_shift f y) (at level 40).
Notation "y >>= f" := (_subst f y)
  (at level 42, left associativity).

Lemma rename_eq : forall (V : TT) (t : unit) (v : ULC V t)
         (W : TT) (f g : V ---> W),
     (forall t y, f t y = g t y) -> v //- f = v //- g.
Proof.
  intros V t v.
  induction v;
  intros;
  simpl.
  rewrite H;
  auto.

  apply f_equal.
  apply IHv.
  simpl in *.
  intros.
  destruct t.
  destruct r.
  assert (H':= l_eq (r:=tt) H (t:=tt) y).
  simpl in *.
  rewrite <- H'.
  auto.

  rewrite (IHv1 _ _ _ H).
  rewrite (IHv2 _ _ _ H).
  auto.
Qed.

Hint Resolve rename_eq l_eq : fin.
Hint Rewrite rename_eq l_eq : fin.

Lemma rename_comp V t (y : ULC V t) W
         (f : V ---> W) Z (g : W ---> Z):
 y //- (fun s y => g s (f s y)) =  y //- f //- g.
Proof.
  intros V t y.
  induction y;
  simpl;
  intros;
  fin.

  apply f_equal.
  rewrite <- IHy.
  apply rename_eq.
  intros r' y0.
  destruct y0;
  fin.
Qed.

Lemma rename_id_eq V t (y : ULC V t) (f : V ---> V)
        (H : forall t v, f t v = v) :
    y //- f = y.
Proof.
  intros V t y.
  induction y;
  simpl;
  intros;
  fin.
  apply f_equal.
  apply IHy.
  intros r' v;
  destruct v;
  fin. unfold lift.
  fin.
Qed.

Lemma rename_id V t (y : ULC V t) : y //- id _ = y .
Proof.
  intros V t y.
  apply rename_id_eq.
  fin.
Qed.

Lemma _shift_eq u V W (f g : V ---> ULC W)
     (H : forall t v, f t v = g t v) t (y : opt u V t) :
          y >- f = y >- g.
Proof.
  intros u V W f g H t v.
  destruct v;
  fin.
Qed.

Hint Resolve  rename_id _shift_eq : fin.
Hint Rewrite  rename_id _shift_eq : fin.

Lemma shift_var u (V : TT) t (y : opt u V t) :
       y >- @Var _ = Var y.
Proof.
  intros u V t y;
  induction y;
  fin.
Qed.

Hint Resolve shift_var : fin.
Hint Rewrite shift_var : fin.

Lemma var_lift_shift (u : unit) V W
    (f : V ---> W) t (y : opt u V t) :
     Var (^f _ y) = y >- (f ;; @Var _ ).
Proof.
  intros u V W f t y;
  induction y; fin.
Qed.

Hint Resolve var_lift_shift : fin.

Lemma shift_lift u V W Z (f : V ---> W)
         (g : W ---> ULC Z) t (y : opt u V t) :
      (^f _ y) >- g = y >- (f ;; g).
Proof.
  intros u V W Z f g t y.
  induction y; fin.
Qed.

Hint Resolve shift_lift : fin.
Hint Rewrite shift_lift : fin.

Lemma subst_eq V t (y : ULC V t)
      W (f g : V ---> ULC W)
       (H : forall t y, f t y = g t y):
      y >>= f = y >>= g.
Proof.
  intros V t y.
  induction y;
  fin.
Qed.

Hint Resolve subst_eq : fin.
Hint Rewrite subst_eq : fin.

Obligation Tactic := unfold Proper; red; fin.

Program Instance subst_oid V W :
 Proper (equiv ==> equiv (Setoid:=mor_oid (ULC V) (ULC W)))
                (@_subst V W).

Lemma subst_var (V : TT) :
    forall t (v : ULC V t), v >>= (@Var V) = v .
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite <- IHy at 2.
  apply subst_eq.
  fin.
Qed.

Lemma subst_eq_rename V t (v : ULC V t) W
            (f : V ---> W)  :
     v //- f  = v >>= (f ;; Var (V:=W)).
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite IHy.
  apply subst_eq.
  intros tr z;
  destruct z;
  fin.
Qed.

Lemma rename_shift a V W Z (f : V ---> ULC W)
           (g : W ---> Z) t
       (y : opt a V t) :
    (y >- f) //- ^g = y >- (f ;; rename g).
Proof.
  intros a V W Z f g t y.
  induction y;
  fin.
  unfold inj.
  rewrite <- rename_comp.
  rewrite <- rename_comp.
  fin.
Qed.

Hint Rewrite rename_shift : fin.
Hint Resolve rename_shift : fin.

Hint Unfold inj : fin.

Lemma rename_subst V t (v : ULC V t) W Z (f : V ---> ULC W)
      (g : W ---> Z) :
      (v >>= f) //- g  = v >>= (f ;; rename g).
Proof.
  intros V t y.
  induction y;
  fin.
  rewrite IHy.
  apply f_equal.
  apply subst_eq.
  intros tr z;
  destruct z;
  simpl; auto.
  unfold inj.
  rewrite <- rename_comp.
  rewrite <- rename_comp.
  apply rename_eq.
  fin.
Qed.

Lemma subst_rename V t (v : ULC V t) W Z (f : V ---> W)
      (g : W ---> ULC Z) :
      v //- f >>= g = v >>= (f ;; g).
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite IHy.
  apply subst_eq.
  intros tr z;
  destruct z;
  fin.
Qed.

Lemma rename_substar V u t (v : ULC (opt u V) t) W
       (f : V ---> W) N:
     v [*:= N] //- f = (v //- ^f) [*:= N //- f ].
Proof.
  intros.
  unfold substar.
  rewrite rename_subst.
  rewrite subst_rename.
  apply subst_eq.
  intros t0 z ;
  destruct z ;
  fin.
Qed.

Hint Rewrite subst_rename rename_subst : fin.

Hint Rewrite rename_shift : fin.
Hint Resolve rename_shift : fin.

Lemma subst_shift_shift (u:unit) V (t : unit)
      (v : opt u V t)
         W Z (f: V ---> ULC W) (g: W ---> ULC Z):
    (v >- f) >>= (_shift g)  =
             v >- (f ;; _subst g).
Proof.
  intros u V t v.
  induction v;
  simpl; intros;
  try apply subst_term_inj; auto.
  unfold inj.
  rewrite subst_rename.
  fin.
Qed.

Hint Resolve subst_shift_shift : fin.
Hint Rewrite subst_shift_shift : fin.

Lemma subst_subst V t (v : ULC V t) W Z
             (f : V ---> ULC W)
             (g : W ---> ULC Z) :
     v >>= f >>= g = v >>= (f;; _subst g).
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite IHy.
  apply subst_eq.
  intros tr z;
  destruct z;
  fin.
  unfold inj.
  fin.
Qed.

Lemma lift_rename V t (s : ULC V t) W (f : V ---> W) :
          s >>= (fun t z => Var (f t z)) = s //- f.
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite <- IHy.
  apply subst_eq.
  intros tr z;
  destruct z;
  fin.
Qed.

Lemma rename_rename V W Z (f : V ---> W)
        (g : W ---> Z) t (v : ULC V t) :
  v //- f //- g = v //- (f ;; g).
Proof.
  intros.
  repeat rewrite <- lift_rename.
  rewrite subst_subst.
  fin.
Qed.

Lemma subst_var_eta (V:TT) t (v:ULC V t):
        v >>= (fun t z => @Var V t z) = v.
Proof.
  induction v; intros; simpl; auto.
  rewrite <- IHv at 2.
  apply f_equal. apply subst_eq.
  intros; apply shift_var.
  rewrite IHv1. rewrite IHv2; auto.
Qed.

Lemma subst_substar (V W : TT)
       t (M: ULC (opt t V) t) (N:ULC V t)
      (f:forall t, V t -> ULC W t):
   M [*:=N]  >>= f = (M >>= _shift f) [*:= (N >>= f)].
Proof.
  intros V W t M N f.
  unfold substar. simpl.
  repeat rewrite subst_subst.
  apply subst_eq.
  intros t0 y.
  simpl.
  destruct y. unfold _shift.
  unfold inj.
  simpl.
  rewrite subst_rename. simpl.
  rewrite (subst_var_eta (f t0 v)). auto.
  simpl.
  apply subst_eq; auto.
Qed.

Hint Resolve subst_var subst_subst lift_rename : fin.
Hint Rewrite subst_subst lift_rename: fin.

Ltac sim := unfold substar; simpl ;
            unfold inj; simpl.

Section Relations_on_ULC.

Reserved Notation "x :> y" (at level 70).

Variable rel : forall (V:TT) t, relation (ULC V t).

Inductive ULCpropag (V: TT)
       : forall t, relation (ULC V t) :=
| relorig : forall t (v v': ULC V t), rel v v' ->  v :> v'
| relApp1: forall s t (M M' : ULC V tt) (N : ULC V s),
       M :> M' -> App t M N :> App _ M' N
| relApp2: forall t s M (N N' : ULC V t),
      N :> N' -> App s M N :> App _ M N'
| relAbs: forall s t (M M':ULC (opt s V) t),
      M :> M' -> Abs M :> Abs M'

where "y :> z" := (@ULCpropag _ _ y z).

Notation "y :>> z" :=
  (clos_refl_trans_1n _ (@ULCpropag _ _ ) y z) (at level 50).

Variable V : TT.
Variable s t : unit.

(** these are some trivial lemmata  which will be used later *)

Lemma cp_App1 (M M': ULC V tt) (N : ULC V t) :
    M :>> M' -> App s M N :>> App _ M' N.
Proof.
  intros. generalize N.
  induction H. constructor.
  intros. constructor 2 with (App _ y N0); auto.
  constructor 2. auto.
Qed.

Lemma cp_App2 (M : ULC V tt) (N N' : ULC V t):
    N :>> N' -> App s M N :>> App _ M N'.
Proof.
  intros. generalize M.
  induction H. constructor.
  intros. constructor 2 with (App _ M0 y); auto.
  constructor 3. auto.
Qed.

Lemma cp_Abs (M M': ULC (opt s V) t ):
      M :>> M' -> Abs M :>> Abs M'.
Proof.
  intros. induction H. constructor.
  constructor 2 with (Abs y); auto.
  constructor 4. auto.
Qed.

End Relations_on_ULC.

(** Beta reduction *)

Reserved Notation "a >> b" (at level 70).

Inductive beta (V : TT): forall t, relation (ULC V t) :=
| app_abs : forall s t (M: ULC (opt s V) t) N,
               beta (App _ (Abs M) N) (M [*:= N]).

Definition beta_star := ULCpropag beta.

Definition beta_rel :=
   fun (V : TT) t => clos_refl_trans_1n _ (@beta_star V t).

Notation "a >> b" := (beta_rel a b).

(** lemmata *)

Lemma beta_eq : forall V t (M N : ULC V t),
   M = N -> M >> N.
Proof.
  intros.
  destruct H.
  reflexivity.
Qed.

Lemma beta_trans : forall V t (M N K : ULC V t),
 M >> K -> N >> M -> N >> K.
Proof.
  intros.
  transitivity M;
  auto.
Qed.

Lemma beta_beta : forall V t s M (N : ULC V t),
   App s (Abs M) N >> M [*:= N].
Proof.
  intros.
  apply clos_refl_trans_1n_contains.
  apply relorig.
  constructor.
Qed.

Lemma app_abs_red V t (M : ULC _ t) (N M' : ULC V t) :
   M [*:= N ] >> M' -> App _ (Abs M) N >> M'.
Proof.
  intros.
  apply (beta_trans H).
  apply beta_beta.
Qed.

Definition eta_red V s t (M : ULC V tt) :=
 Abs (App s (inj t M) (Var (V:=V *) (none t (V) ))) >> M.

Lemma App1_app_abs V s t (M : ULC (opt t V) tt)
       (N : ULC V t) (L : ULC _ s) K:
  beta_rel (App s (M [*:= N]) L) K ->
  beta_rel (App _ (App _ (Abs M) N) L) K.
Proof.
  intros.
  transitivity (App s (M[*:=N]) L).
  apply cp_App1.
  apply clos_refl_trans_1n_contains.
  apply relorig.
  constructor.
  auto.
Qed.

Lemma App2_app_abs V s t (M : ULC (opt t V) s)
      M' (N : ULC V _) K:
  beta_rel (App s M' (M [*:= N])) K ->
  beta_rel (App _ M' (App s (Abs M) N)) K.
Proof.
  intros.
  transitivity (App s M' (M[*:=N])).
  apply cp_App2.
  apply beta_beta.
  auto.
Qed.

Lemma App1_App1_app_abs V r s t
     (M : ULC (opt t V) tt)
     (N : ULC _ t)
     (K : ULC V r)
     (L : ULC V s) (R : ULC V t):
  beta_rel (App _ (App _ (M[*:=N]) K) L) R ->
  beta_rel (App _ (App _ (App _ (Abs M) N) K) L) R.
Proof.
  simpl; intros.
  transitivity (App t (App _ (M [*:=N]) K) L).
  apply cp_App1.
  apply cp_App1.
  apply beta_beta.
  auto.
Qed.

Lemma App1_App1_App1_app_abs V r s t u v
       (M : ULC (opt u V) tt)
       (N : ULC V u)
       (K : ULC V s)
       (L : ULC V r)
       (J : ULC V v) (R : ULC V t):
  beta_rel (App _ (App _ (App _ (M[*:=N]) K) L) J) R ->
  beta_rel (App _ (App _ (App _ (App _ (Abs M) N) K) L) J) R.
Proof.
  simpl; intros.
  apply (beta_trans H).
  do 3 apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App1_App1_Abs_app_abs V r t v w y z z'
        (M : ULC (opt z (opt y (opt w (opt z' V)))) tt)
        (N : ULC _ z)
        (K : ULC _ v)
        (L : ULC _ r) (R : ULC V tt):
beta_rel (Abs (Abs
      (App t (App tt (Abs (M[*:=N])) K) L))) R ->
beta_rel (Abs (Abs (App t (App _ (Abs (App tt (Abs M) N)) K) L))) R.
Proof.
  intros.
  apply (beta_trans H).
  repeat apply cp_Abs.
  repeat apply cp_App1.
  apply cp_Abs.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App1_App1_app_abs V r s t u v w
         (M : ULC (opt r (opt s (opt t V))) tt)
         (N : ULC _ r)
         (K : ULC _ v)
         (L : ULC _ w) (R : ULC V tt):
beta_rel (Abs (Abs (App u (App _ (M[*:=N]) K) L))) R ->
beta_rel (Abs (Abs (App u (App _ (App _ (Abs M) N) K) L))) R.
Proof.
  intros.
  apply (beta_trans H).
  repeat apply cp_Abs.
  repeat apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App1_app_abs V r s t u v
       (M : ULC (opt r (opt s (opt t V))) tt)
       N (K : ULC _ v) (R : ULC V tt) :
beta_rel (Abs (Abs (App u (M[*:=N]) K))) R ->
beta_rel (Abs (Abs (App u (App _ (Abs M) N) K))) R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_Abs.
  apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_Abs_app_abs V r s t
       (M : ULC (opt r (opt s (opt t V))) tt)
       N (R : ULC V tt) :
beta_rel (Abs (Abs (M[*:=N]))) R ->
beta_rel (Abs (Abs (App tt (Abs M) N))) R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_Abs.
  apply beta_beta.
Qed.

Lemma App2_App1_app_abs V t s r
    (M : ULC (opt t V) tt) N K
    (L : ULC V r)  (R:ULC V t) :
  App _ K (App s (M [*:=N]) L) >> R ->
  App _ K (App s (App _ (Abs M) N) L) >> R.
Proof.
  intros.
  apply (beta_trans H).
  apply cp_App2.
  apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App1_Abs_App2_App1_app_abs V r s t u v w y z
     (M : ULC (opt r (opt s (opt t (opt u V)))) tt)
     N (K : ULC _ tt) (L : ULC _ v) (J : ULC _ w)
       (R:ULC V tt):
   Abs (Abs (App u (Abs (App y K
             (App z (M[*:=N]) J))) L)) >> R ->
   Abs (Abs (App u (Abs (App y K
     (App z (App _ (Abs M) N) J))) L)) >> R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_Abs.
  apply cp_App1.
  apply cp_Abs.
  apply cp_App2.
  apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App1_Abs_App2_app_abs V r s t u v w y
   (M : ULC (opt r (opt s (opt t (opt u V)))) tt)
   N (K : ULC _ tt) (L : ULC _ w)
       (R:ULC V tt):
   Abs (Abs (App v (Abs (App y K
             (M[*:=N]) )) L)) >> R ->
   Abs (Abs (App v (Abs (App y K
      (App tt (Abs M) N) )) L)) >> R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_Abs.
  apply cp_App1.
  apply cp_Abs.
  apply cp_App2.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App2_app_abs V r s t u
      (M : ULC (opt r (opt s (opt t V))) tt)
      N K (R:ULC V tt) :
  Abs (Abs (App u K (M[*:=N]))) >> R ->
  Abs (Abs (App u K (App tt (Abs M) N))) >> R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_Abs.
  apply cp_App2.
  apply beta_beta.
Qed.

Lemma App2_Abs_Abs_App2_App1_app_abs V r s t u v   z
     (M : ULC (opt r (opt s (opt t V))) tt)
     N K L (J : ULC _ z) (R:ULC V tt) :
   App _ K (Abs (Abs (App u L (App v (M[*:=N]) J)))) >> R ->
   App _ K (Abs (Abs (App u L (App v (App _ (Abs M) N) J)))) >> R.
Proof.
  intros.
  apply (beta_trans H).
  apply cp_App2.
  do 2 apply cp_Abs.
  apply cp_App2.
  apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App1_App1_App1_app_abs V r s t u v w y
   (M : ULC (opt r (opt s (opt t V))) tt)
   N (K : ULC _ y) (L : ULC _ w) (J : ULC _ v) (R:ULC V tt) :
  Abs (Abs (App u (App _ (App _ (M [*:=N]) K) L) J)) >> R ->
  Abs (Abs (App u (App _ (App _ (App _ (Abs M) N) K) L) J)) >> R .
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_Abs.
  do 3 apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App2_App1_App1_app_abs V r s t  v w y z
    (M : ULC (opt r (opt s (opt t V))) tt)
    (N : ULC _ _) (K : ULC _ tt)
    (L : ULC _ v) (J : ULC _ w) (R:ULC V tt):
   Abs (Abs (App z K (App y (App _ (M[*:=N]) L) J))) >> R ->
   Abs (Abs (App z K (App y (App _ (App _ (Abs M) N) L) J))) >> R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_Abs.
  apply cp_App2.
  do 2 apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App2_App1_app_abs V r s t u v  y
    (M : ULC (opt r (opt s (opt t V))) tt)
    N (K : ULC _ tt) (L : ULC _ y) (R:ULC V tt):
  Abs (Abs (App u K (App v (M[*:=N]) L))) >> R ->
  Abs (Abs (App u K (App v (App _ (Abs M) N) L))) >> R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_Abs.
  apply cp_App2.
  apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_App2_app_abs V r s t
     (M : ULC (opt r (opt s V)) tt)
     N K (R : ULC V tt) :
   Abs (App t K (M[*:=N])) >> R ->
   Abs (App t K (App tt (Abs M) N)) >> R.
Proof.
  intros.
  apply (beta_trans H).
  apply cp_Abs.
  apply cp_App2.
  apply beta_beta.
Qed.

Lemma App1_Abs_app_abs V r s t
   (M : ULC (opt r (opt s V)) tt)
   N (K : ULC _ t) (R:ULC V t) :
  App _ (Abs (M[*:=N])) K >> R ->
  App _ (Abs (App tt (Abs M) N)) K >> R.
Proof.
  intros.
  apply (beta_trans H).
  apply cp_App1.
  apply cp_Abs.
  apply beta_beta.
Qed.

Lemma App1_Abs_App2_App1_app_abs V r s t u v w
   (M : ULC (opt r (opt s V)) tt)
   N (K : ULC _ tt) (L : ULC _ t)
   (J : ULC _ u) (R:ULC V tt) :
  App _ (Abs (App v K (App w (M[*:=N]) L))) J >> R ->
  App _ (Abs (App v K (App w (App _ (Abs M) N) L))) J >> R.
Proof.
  intros.
  apply (beta_trans H).
  apply cp_App1.
  apply cp_Abs.
  apply cp_App2.
  apply cp_App1.
  apply beta_beta.
Qed.

Lemma App1_Abs_Abs_App2_App1_app_abs V r s t u v w y
   (M : ULC (opt r (opt s (opt t V))) tt)
    N (K : ULC _ tt) (L:ULC _ u) (J : ULC _ v) (R:ULC V t) :
  App _ (Abs (Abs (App w K (App y (M[*:=N]) L)))) J >> R ->
  App _ (Abs (Abs (App w K (App y (App _ (Abs M) N) L)))) J >> R.
Proof.
  intros.
  apply (beta_trans H).
  apply cp_App1.
  do 2 apply cp_Abs.
  apply cp_App2.
  apply cp_App1.
  apply beta_beta.
Qed.

Lemma App1_App1_Abs_app_abs V r s t u
   (M : ULC (opt r (opt s V)) tt)
    N (K : ULC _ t) (L : ULC _ u) (R:ULC V tt) :
  App _ (App _ (Abs (M[*:=N])) K) L >> R ->
  App _ (App _ (Abs (App tt (Abs M)N)) K) L >> R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_App1.
  apply cp_Abs.
  apply beta_beta.
Qed.

Lemma App1_App1_Abs_Abs_app_abs V r s t u v
    (M : ULC (opt r (opt s (opt t V))) tt)
     N (K : ULC _ u) (L : ULC _ v) (R:ULC V t) :
  App _ (App _ (Abs (Abs (M[*:=N]))) K) L >> R ->
  App _ (App _ (Abs (Abs (App tt (Abs M)N))) K) L >> R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_App1.
  do 2 apply cp_Abs.
  apply beta_beta.
Qed.

Obligation Tactic := idtac.

Program Instance ULCBETA_struct (V : TT) :
   ipo_obj_struct (ULC V) := {
 IRel t := @beta_rel V t
}.
Next Obligation.
Proof.
  constructor.
  constructor.
  assert (H':= @clos_rt_is_preorder _ (@beta_star V t)).
  unfold beta_rel in *.
  unfold Transitive.
  intros.
  destruct H' as [H1 H2].
  unfold transitive in H2.
  simpl in *.
  apply trans_rt1n.
  apply H2 with y;
    apply rt1n_trans;
    auto.
Qed.

Definition ULCBETA (V: TT) : IPO unit :=
    Build_ipo_obj (ULCBETA_struct V ).

Program Instance Var_s (V : TT) :
    ipo_mor_struct (a:=SM_ipo _ V) (b:=ULCBETA V) (Var (V:=V)).
Next Obligation.
Proof.
  intros V t.
  unfold Proper;
  red.
  simpl.
  intros y z H.
  induction H.
  reflexivity.
Qed.

Definition VAR V := Build_ipo_mor (Var_s V).

Lemma rename_beta (V W : TT)(f : V ---> W) t (v w : ULC V t):
     v >> w -> v //- f >> w //- f.
Proof.
  intros V W f t v w H.
  generalize dependent W.
  induction H.
  reflexivity.
  intros W f.
  transitivity (y //- f);
  auto.
  clear dependent z.
  generalize dependent W.
  induction H.
  induction H.

  simpl.
  intros W f.
  destruct s.
  destruct t.
  apply app_abs_red.
  simpl.
  unfold substar.
  rewrite  rename_subst.
  simpl.
  rewrite subst_rename.
  simpl.
  apply beta_eq.
  apply (subst_eq M).
  intros s y;
  destruct y as [s y| ];
  simpl;
  auto.

  intros W f.
  simpl.
  apply cp_App1.
  apply IHULCpropag.
  intros W f.
  simpl.
  apply cp_App2.
  apply IHULCpropag.
  simpl.
  intros W f.
  apply cp_Abs.
  apply IHULCpropag.
Qed.

Program Instance subst_s (V W : TT)
     (f : SM_ipo _ V ---> ULCBETA W) :
   ipo_mor_struct
     (a:=ULCBETA V) (b:=ULCBETA W) (_subst f).
Next Obligation.
Proof.
  intros V W f t.
  unfold Proper;
  red.
  intros y z H.
  generalize dependent W.
  induction H;
  simpl;
  intros.
  constructor.
  transitivity (_subst f y);
  try apply IHclos_refl_trans_1n.
  clear dependent z.

    generalize dependent W.
  induction H;
  simpl;
  intros.

  Focus 2.
  apply cp_App1.
  apply IHULCpropag.
  Focus 2.
  apply cp_App2.
  apply IHULCpropag.
  Focus 2.
  apply cp_Abs.
  simpl in *.
  destruct s.
  destruct t.
  apply (IHULCpropag _ (SM_ind
            (V:=opt _ V) (W:=ULCBETA (opt tt W))
      (fun t y => _shift f y))).

  generalize dependent W.
    induction H;
    simpl;
    intros.
    apply clos_refl_trans_1n_contains.
    apply relorig.
    assert (H:=app_abs (_subst (_shift f) M) (_subst f N)).
    destruct s;
    destruct t.
    rewrite subst_substar.
    auto.
Qed.

Lemma subst_beta (V W : TT) (f : V ---> ULC W) t
    (v w : ULC V t) :
   v >> w -> v >>= f >> w >>= f.
Proof.
  intros.
  assert (H':= subst_s _ _ (SM_ind (W:= ULCBETA W) f)).
  apply H'.
  simpl.
  auto.
Qed.

Definition SUBST V W f := Build_ipo_mor (subst_s V W f).

Obligation Tactic := fin.

Program Instance ULCBETAM_s : RMonad_struct (SM_ipo unit) ULCBETA := {
   rweta := VAR;
   rkleisli a b f := SUBST f
}.
Next Obligation.
Proof.
  unfold Proper;
  red;
  fin.
Qed.

Definition ULCBETAM : RMonad (SM_ipo unit) := Build_RMonad ULCBETAM_s.

Lemma rename_lift V t (v : ULC V t) W (f : V ---> W) :
       v //- f = rlift ULCBETAM f _ v.
Proof.
  unfold lift;
  fin.
Qed.
(*
Hint Rewrite lift_rename : fin.
*)

Lemma shift_shift r s V W (f : SM_ipo _ V ---> ULCBETAM W)
                (y : (opt r V) s) :
   sshift_ (P:=ULCBETAM) (W:=W) f y = y >- f .
Proof.
  intros r  s V W f y.
  destruct y as [t y | ];
  simpl;
  unfold inj;
  fin.
Qed.

Hint Resolve shift_shift : fin.
Hint Rewrite shift_shift : fin.

(* the Turing fixpoint operator Theta.
   it has (Theta g) --> g (Theta g)
*)
Definition ULC_theta_h (V : TT) : ULC V tt :=
 Abs(
  Abs(
   App tt
    (Var (none tt _ ))
    (App tt
      (App _
        (Var (some tt (none tt V)))
        (Var (some tt (none tt V))))
      (Var (none tt _)))
)).

Definition ULC_theta (V : TT) : ULC V tt :=
App _ (ULC_theta_h V) (ULC_theta_h V).

(* Y = \f. (\x. f (x x)) (\x. f (x x))  *)

Definition ULC_fix (V : TT) : ULC V tt :=
 Abs (
   App tt
    (Abs
      (App tt
        (Var (some tt (none tt V)))
        (App tt
          (Var (none tt (opt tt V)))
          (Var (none tt (opt tt V))))
     ))
    (Abs
      (App  tt
        (Var (some tt (none tt V)))
        (App tt
          (Var (none tt (opt tt V)))
          (Var (none tt (opt tt V))))
     ))

).

(* not: [m+1] =
     \f.\n. ([m] f) (f n)

instead : [m+1] = \fn. f ([m] f n)
*)

(* note : [m] has 2*m redexes in it *)

Fixpoint ULC_Nat (n : nat) (V : TT) := match n with
| 0 => Abs (Abs (Var (none tt (opt tt V))))
| S n' =>
    Abs(
     Abs (
      App tt
       (Var (some tt (none tt _ )))
       (App tt
         (App _
           (ULC_Nat n' _ )
           (Var (some tt (none tt _ ))))
         (Var (none tt _ )))))
end.

(* naturals are constant under renaming *)

Lemma ulc_nats_rename n :
  forall (V W : TT) (f : V ---> W),
     ULC_Nat n W = ULC_Nat n V //- f.
Proof.
  induction n.
  simpl.
  intros.
  unfold lift.
  simpl.
  auto.

  simpl.
  intros.
  apply f_equal.
  apply f_equal.
  apply f_equal.
  rewrite <- IHn.
  auto.
Qed.

(* nats are constant under substitution *)

Lemma ulc_nats_subst n :
 forall (V W : TT)
       (f : V ---> ULC W),
     ULC_Nat n W = ULC_Nat n V >>= f.
Proof.
  induction n.
  reflexivity.
  simpl.
  intros.
  rewrite <- (IHn (V * *)).
  reflexivity.
Qed.

(* - pow 0 T = \x.x
   - pow Sn T = \x. T ((pow n T) x)

   - pow 1 T = \x. T ((pow 0 T) x) =
             = \x. T (\y.y x) -> \x. T x

   - pow 2 T = \x. T ((pow 1 T) x) =
             -> \x. T ((\x.Tx) x) ->
                \x. T (T x)
*)

Fixpoint pow n V (T : ULC V tt) : ULC V tt :=
  match n return ULC V tt with
  | 0 => Abs (Var (none tt V ))
  | S n' => Abs
       (App tt
        (inj _ T)
        (App tt
          (inj tt (pow n' T))
          (Var (none tt _))))
  end.

(* lets build  fun f x => App f (f^n x) *)
(* - ULC_nat_skel 0 f y = y
   - ULC_nat_skel Sn f y = App f (...)
*)

Fixpoint ULC_nat_skel n V
   (f : ULC (opt tt V) tt)
   (y : ULC (opt tt (opt tt V)) tt) :
      ULC (opt tt (opt tt V)) tt :=
match n with
| 0 => y
| S n' => App _ (inj tt f) (ULC_nat_skel n' f y)
end.

(*  take the to-be-bound-next free variables as f and y *)

Definition ULC_nat_sk n V :=
 ULC_nat_skel n (Var (none tt V)) (Var (none tt (V*))).

(*  have free variables f, y

   - ULC_Nat_noredex 0 = y
   - ULC_Nat_noredex Sn = f (...)
*)
(*
Fixpoint ULC_Nat_noredex n V t :=
  match n with
  | 0 => Var (V:=opt t (opt t V)) (none t (opt t V))
  | S n' => App _ (Var (some t (none t V)))
                   (ULC_Nat_noredex n' V t)
  end.
*0
(* ULC_nat_sk = ULC_Nat_noredex *)
(* both have two free variables f, y
*)
*)
(*
Lemma ULC_nat_sk_ULC_Nat_noredex n V :
   ULC_nat_sk n V = ULC_Nat_noredex n V tt.
Proof.
  induction n.
  reflexivity.
  simpl; intros.
  rewrite <- IHn.
  reflexivity.
Qed.
*)
(* we bind the free variables f, y
   in order to define the natural numbers
*)
(*
Definition ULC_Nat_nox n V t : ULC V t :=
  Abs (
   Abs (ULC_Nat_noredex n V t)).
*)
Definition ULC_N n V : ULC V tt :=
  Abs (Abs (ULC_nat_sk n V)).

Lemma ULC_nat_skel_rename_lift n V W
     (f : V* ---> W*) a b :
  ULC_nat_skel n a b //- (^f) =
         ULC_nat_skel n (a//-f) (b//-^f).
Proof.
induction n.
  reflexivity.
  intros;
  simpl in *.
  apply App_eq;
  auto.
  unfold inj.
  repeat rewrite rename_rename.
  fin.
Qed.

Lemma ULC_nat_skel_rename_some n V
       a b :
   ULC_nat_skel n a b //- (some tt (A:=V * *)) =
     ULC_nat_skel n (inj _ a) (b //- some tt (A:= V * * )).
Proof.
  simpl.
  intros.
  induction n.
  reflexivity.
  simpl.
  apply App_eq.
  auto.
  simpl.
  auto.
Qed.

Lemma ULC_N_skel_subst_shift n V W
   (f : V* ---> ULC W*) a b :
  ULC_nat_skel n a b >>= (_shift f) =
  ULC_nat_skel n (a>>= f) (b>>=(_shift f)).
Proof.
  induction n.
  reflexivity.
  intros;
  simpl in *.
  apply App_eq;
  auto.
  unfold inj;
  simpl.
  rewrite rename_subst.
  rewrite subst_rename.
  fin.
Qed.

(* is less useful than it might seem *)

Lemma ULC_N_skel_substar n V (M : ULC (V* * ) tt)
                (a : ULC (V* * ) tt)
                (b:ULC (opt tt (opt tt V) * ) tt) :
  inj tt (ULC_nat_skel n (a) b [*:= M]) =
  ( ULC_nat_skel n a ((inj tt (b[*:= M])))).
Proof.
  induction n.
  reflexivity.
  simpl;
  intros.
  rewrite <- IHn.
  unfold inj;
  simpl.
  apply App_eq;
  auto.
  rewrite subst_rename.
  rewrite rename_subst.
  simpl.
  rewrite rename_lift.
  simpl.
  auto.
Qed.

(* renaming with 2 times lifted map doesn't change
   ULC_nat_sk (which has only 2 free vars)
*)

Lemma ULC_N_sk_rename n V W (f : V ---> W)  :
  ULC_nat_sk n V //- ^(^f) = ULC_nat_sk n _ .
Proof.
  induction n.
  reflexivity.
  intros;
  simpl in *.
  apply App_eq.
  auto.
  rewrite IHn.
  auto.
Qed.

(* similar for substitution with 2times shifted map
*)

Lemma ULC_N_sk_subst n V W (f : V ---> ULC W) :
  ULC_nat_sk n V >>= _shift (_shift f) =
    ULC_nat_sk n W .
Proof.
  induction n.
  reflexivity.
  simpl.
  intros.
  rewrite IHn.
  unfold inj.
  simpl.
  reflexivity.
Qed.

(* the naturals defined with skel are constant under
   substitution
*)

Lemma ULC_N_subst n V W (f : V ---> ULC W) :
  ULC_N n V >>= f = ULC_N n W.
Proof.
  simpl.
  intros.
  rewrite ULC_N_sk_subst.
  auto.
Qed.

(* the following lemma are the same as for skel.
   no surprise, the defs are equal
*)
(*
Lemma ULC_Nat_noredex_rename n V W (f : V ---> W) t :
  ULC_Nat_noredex n V t //- ^(^f) = ULC_Nat_noredex n _ t.
Proof.
  induction n.
  reflexivity.
  intros;
  simpl in *.
  apply App_eq.
  auto.
  rewrite IHn.
  auto.
Qed.

Lemma ULC_Nat_noredex_subst n V W (f : V ---> ULC W) t :
  ULC_Nat_noredex n V t >>= _shift (_shift f) =
    ULC_Nat_noredex n W t.
Proof.
  induction n.
  reflexivity.
  simpl.
  intros.
  apply App_eq;
  auto.
Qed.

Lemma ULC_Nat_nox_subst n V W (f : V ---> ULC W) t:
  ULC_Nat_nox n V t >>= f = ULC_Nat_nox n W t.
Proof.
  induction n.
  reflexivity.
  simpl in *.
  intros.
  (**)
  unfold _shift in IHn.
  unfold inj in IHn.
  simpl in IHn.
  (**)
  unfold ULC_Nat_nox in *.
  simpl.
  repeat apply f_equal.
  apply ULC_Nat_noredex_subst.
Qed.
*)

(* Nat n reduces to Nat_nox n *)
(* Nat n has 2n redexes *)
(*
Lemma ULC_nat_red_ULC_Nat_alt n V :
  ULC_Nat n V >> ULC_Nat_nox n V tt.
Proof.
  induction n.
  reflexivity.
  intros.
  simpl.
  unfold ULC_Nat_nox in *.
  assert (H:= IHn (opt tt (opt tt V))).
transitivity (
Abs
  (Abs
     (App (Var (V:=(V * ) * ) (t:=tt)
             (some tt (A:=V * ) (t:=tt) (none tt V)))
        (App
           (App

(Abs (Abs (ULC_Nat_noredex n (V * ) * tt)))

              (Var (V:=(V * ) * ) (t:=tt)
                 (some tt (A:=V * ) (t:=tt) (none tt V))))
           (Var (V:=(V * ) * ) (t:=tt) (none tt V * )))))
).
  apply cp_Abs.
  apply cp_Abs.
  apply cp_App2.
  apply cp_App1.
  apply cp_App1.
  apply H.
  clear H IHn.
  sim.
  apply cp_Abs.
  apply cp_Abs.
  apply cp_App2.
  apply App1_app_abs.
  sim.
  apply app_abs_red.
  sim.
  rewrite subst_subst.
  simpl.

  apply beta_eq.
  generalize dependent V.

  induction n.
  reflexivity.
  simpl.
  intro V.
  rewrite IHn.
  auto.
Qed.
 *)

Lemma pow_rename (n: nat) (V W : TT)(f : V ---> W) T :
   pow n T //- f = pow n (T //- f).
Proof.
  induction n.
  reflexivity.
  intros;
  simpl.
  apply f_equal.
  apply App_eq.
  unfold inj; simpl.
  repeat rewrite rename_rename;
  fin.
  apply App_eq.
  unfold inj; simpl.
  rewrite <- IHn.
  repeat rewrite rename_rename;
  fin.
  fin.
Qed.

Lemma pow_subst (n: nat) (V W : TT)(f : V ---> ULC W) T :
   pow n T >>= f = pow n (T >>= f).
Proof.
  induction n.
  reflexivity.
  simpl.
  intros.
  apply f_equal.
  apply App_eq.
  unfold inj.
  rewrite rename_subst.
  rewrite subst_rename.
  fin.
  apply App_eq.
  unfold inj.
  rewrite <- IHn.
  rewrite rename_subst.
  rewrite subst_rename.
  fin.
  auto.
Qed.

Lemma n_red_pow n V T :
  App _ (ULC_Nat n V) T >> pow n T.
Proof.
  intro n;
  induction n.
  simpl.
  intros V T.
  apply app_abs_red.
  unfold substar;
  simpl.
  reflexivity.
  simpl in IHn.
  unfold pow in IHn.
  intros V T.
  simpl.
  apply app_abs_red.
  unfold substar;
  simpl.
  unfold pow.
  simpl.
  rewrite <- ulc_nats_subst.
  apply cp_Abs.
  apply cp_App2.
  apply cp_App1.
  unfold inj;
  simpl.
  assert (H':= rename_beta (some tt (A:=V))
                (IHn V T)).
  apply (beta_trans H').
  apply beta_eq.
  simpl.
  rewrite <- ulc_nats_rename.
  auto.
Qed.

Definition ULC_Nat_alt n V : ULC V tt :=
  Abs (pow n (Var (none tt V))).

(** plus = \n.\m.\f.\x. n(f) (m(f)x) *)
(*
Definition ULC_plus (V : TT) :=
  Abs (V:=V)
   (
   Abs (V:=opt tt V)
     (
    Abs (V:= opt tt (opt tt V))
         (
          Abs (V:= opt tt (opt tt (opt tt V)))
           (
             App (V:=opt tt (opt tt (opt tt (opt tt V))))
               (App (V:=opt tt (opt tt (opt tt (opt tt V))))
                    (Var (V:=opt tt (opt tt (opt tt (opt tt V))))
                         (some tt (some tt (some tt (none tt V)))))
                    (Var (V:=opt tt (opt tt (opt tt (opt tt V))))
                         (some tt (A:=(opt tt (opt tt (opt tt V))))
                              (none tt (opt tt (opt tt V)) ))) )
               (App (V:=opt tt (opt tt (opt tt (opt tt V))))
                    (App (V:=opt tt (opt tt (opt tt (opt tt V))))
                         (Var (V:=opt tt (opt tt (opt tt (opt tt V))))
                              (some tt (some tt (none tt (opt tt V) ))))
                         (Var (V:=opt tt (opt tt (opt tt (opt tt V))))
                              (some tt (A:= opt tt (opt tt (opt tt V)))
                                  (none tt (opt tt (opt tt V))))))
                    (Var (V:=opt tt (opt tt (opt tt (opt tt V))))
                         (none tt (opt tt (opt tt (opt tt V) )) )))
              )

             )
       )
 ).
*)
(** SUCC := \nfx.f (n f x) *)
Definition ULCsucc V : ULC V tt :=
  Abs (
   Abs (
    Abs (
      App tt
       (Var (some tt (none tt _ )))
       (App tt
         (App _
           (Var (some tt (some tt (none tt _ ))))
           (Var (some tt (none tt _ )))
         )
         (Var (none tt _ ))
       )))).

(* alternative definition for succ :
    succ := \m.\f.\n. (m f)(f n)
*)
(*
Definition ULCsucc_alt V : ULC V tt :=
  Abs (
   Abs (
    Abs(
     App
      (App
        (Var (some tt (some tt (none tt V))))
        (Var (some tt (none tt (opt tt V)))))
      (App
        (Var (some tt (none tt _ )))
        (Var (none tt _ )))

))).
*)

(** if then else = \a.\b.\c. a(b)(c) *)

Definition ULC_cond (V : TT) :=
     Abs (V:=V)
        ( Abs (V:=opt tt V)
            ( Abs (V:=opt tt (opt tt V))
               (
                   App (V:= opt tt (opt tt (opt tt V))) tt
                      (App (V:= opt tt (opt tt (opt tt V))) _
                         (Var (V:= opt tt (opt tt (opt tt V)))
                            (some tt (some tt (none tt V))))
                         (Var (some tt (none tt (opt tt V))))
                      )
                      (Var (none tt (opt tt (opt tt V)))
                      )
               )
            )
        ).

Definition ULC_omega (V : TT) :=
    Abs (V:= V)
      ( App tt (Var (none tt V)) (Var (none tt V))).

(* TRUE = \xy.x *)
Definition ULC_True V : ULC V tt :=
  Abs (Abs (Var (some tt (none tt V)))).

(* FALSE = \xy.y *)
Definition ULC_False V : ULC V tt :=
  Abs (Abs (Var (none tt (opt tt V)))).

(* zero? = \n.((n)(true)false)true     *)

Definition ULC_zero (V : TT) :=
  Abs (
   App tt
     (App tt
       (Var (none tt V ))
       (Abs (r:=tt) (ULC_False _)))
     (ULC_True _ )).

(* T f := \gh. h (g f) *)
Definition ULC_T V f : ULC V tt :=
  Abs (
   Abs (
    App tt
     (Var (none tt _))
     (App tt
       (Var (some tt (none tt V)))
       (inj _ (inj (t:=tt) _ f))))
).

Lemma T_rename (V W : TT) (g : V ---> W) f :
  ULC_T  f //- g = ULC_T (f//-g).
Proof.
  simpl.
  unfold ULC_T.
  intros.
  repeat apply f_equal.
  unfold inj;
  simpl.
  repeat rewrite rename_rename.
  apply rename_eq.
  simpl.
  auto.
Qed.

(*PRED := \nfx.n (\gh.h (g f)) (\u.x) (\u.u)*)

Definition ULC_pred_alt (V : TT) : ULC V tt :=
  Abs (
   Abs (
    Abs (
     App tt
       (App tt
         (App tt
           (Var (some tt (some tt (none tt V))))
           (ULC_T (Var (some tt (none tt _ ))))
)
         (Abs (Var (some tt (none tt _ )))))
       (Abs (Var (none tt _ )))
))).

Definition ULC_pred (V : TT) : ULC V tt :=
  Abs (
   Abs (
    Abs (
     App tt
       (App _
         (App _
           (Var (some tt (some tt (none tt V))))
           (Abs (
             Abs (
              App tt
               (Var (none tt _ ))
               (App tt
                 (Var (some tt (none tt _ )))
                 (Var (some tt (some tt (some tt (none tt _ )))))
             )))))
         (Abs (Var (some tt (none tt _ )))))
       (Abs (Var (none tt _ )))
))).

Lemma ULC_pred_alt_correct V :
  ULC_pred_alt V = ULC_pred V.
Proof.
  reflexivity.
Qed.


Require Import Setoid.
(**DomCN is the old CN, the universe of common nouns**)
Definition DomCN:=Set.

(**Equiv is an equivalence relation on elements of DomCN**)
Record Equiv (A:DomCN) : Type := mkEquiv { eq1:> A->A->Prop; _eq2: reflexive A(eq1)/\ symmetric A eq1/\ transitive A eq1}.
Check Equiv.
(**CN is a setoid, here expressed a record, second projection is the equiv relation on the type**)
Record CN := mkCN{ B:> DomCN; B2:Equiv B}.

(**small capitals for the types in DomCN**)
Parameter human  man : DomCN.
Parameter john: human.
Axiom mh: man->human. Coercion mh: man>->human.

(**IC for Human**)
Parameter IC_Human : Equiv(human).
(**This is the CN type in Capitals as a setoid**)
Definition HUMAN:= mkCN human IC_Human.

(**Given the IC for man as being inherited from human**)
Definition AIC_Man := fun x: man=>fun y:man=> IC_Human(x)(y).
(** We prove the equivalence of AIC_Man**)
Theorem EQ: reflexive  man  AIC_Man/\  symmetric man AIC_Man/\  transitive man AIC_Man. cbv. destruct  IC_Human. destruct _eq3. destruct H0. split. intro. unfold reflexive in H.  apply H. split. intro. unfold symmetric in H0. intuition. intro. unfold transitive in H1. intro. intro. intros. apply H1 with y. assumption. assumption. Qed.
Check eq1.
Check _eq2.
Check Equiv.

(**A first definition of three, prety standard but takes into account the IC, B and B2 are the two respective projections**)
Definition three:=fun A:CN=> fun P:A.(B)->Prop=>exists x:A.(B),P(x)/\exists y:A.(B), P(y)/\ exists z:A.(B), P(z)/\not((A.(B2))(x)(y))/\not((A.(B2))(y)(z)) /\not((A.(B2))(x)(z)).

(** Similarly for some**)
Definition some:=fun A:CN=> fun P:A.(B)->Prop=> exists x:A.(B), P(x).

(**Predicates are functions from the first projection of the CN to Prop**)
Parameter walk: HUMAN.(B)->Prop.
Check walk john.
Check (three HUMAN) walk.

(** Defining the IC for man and then MAN**)
Definition IC_Man:=  mkEquiv man AIC_Man EQ.
Definition MAN:= mkCN man IC_Man.

(**A proof that if three men walk, three humans walk**)
Theorem MANWALK: (three MAN) walk-> (three HUMAN) walk. cbv. intros. destruct H.
                                                        destruct H. destruct H0. destruct H0. destruct H1. destruct H1. destruct H2. destruct H3. exists x. split. intuition. exists x0. split. intuition. exists x1. split. intuition. intuition. Qed.

(** Defining the dot for PhyInfo and type book**)
Parameter Phy Info: DomCN.
Record PhyInfo : DomCN := mkPhyInfo { phy :> Phy; info :> Info }.
Parameter book: DomCN.
Axiom bf: book-> PhyInfo. Coercion bf: book >-> PhyInfo.

(** IC for Phy, Info and PhyInfo**)
Parameter IC_Phy: Equiv(Phy).
Parameter IC_Info: Equiv(Info).
Definition PHY:= mkCN Phy IC_Phy.
Definition INFO:= mkCN Info IC_Info.
Parameter IC_PhyInfo: Equiv PhyInfo.
Definition PHYINFO:= mkCN PhyInfo  IC_PhyInfo.

(** Defining the IC criteria for book**)
Definition AIC_Book1 := fun x: book=>fun y:book=> IC_Phy(x)(y).
Definition AIC_Book2 := fun x: book=>fun y:book=> IC_Info(x)(y).
Theorem EQ1: reflexive  book  AIC_Book1/\  symmetric book AIC_Book1/\  transitive book AIC_Book1. cbv. destruct  IC_Phy. destruct _eq3. destruct H0. split. intro. unfold reflexive in H.  apply H. split. intro. unfold symmetric in H0. intuition. intro. unfold transitive in H1. intro. intro. intros. apply H1 with y. assumption. assumption. Qed.

Theorem EQ2: reflexive  book  AIC_Book2/\  symmetric book AIC_Book2/\  transitive book AIC_Book2. cbv. destruct  IC_Info. destruct _eq3. destruct H0. split. intro. unfold reflexive in H.  apply H. split. intro. unfold symmetric in H0. intuition. intro. unfold transitive in H1. intro. intro. intros. apply H1 with y. assumption. assumption. Qed.

Definition IC_Book1:=  mkEquiv book  AIC_Book1 EQ1.
Definition IC_Book2:=  mkEquiv book  AIC_Book2 EQ2.
Definition Book1:= mkCN book IC_Book1.
Definition Book2:= mkCN book IC_Book2.
Parameter picked_up: human->Phy->Prop.
Parameter mastered: human->Info->Prop.
Parameter the: forall A:DomCN, A.

(**mastered three books, mastered three INFO**)
Theorem MASTEREDINFO:(three Book2) (mastered john)-> (three INFO)(mastered john). cbv. intros. destruct H. destruct H. destruct H0. destruct H0. destruct H1. destruct H1. destruct H2. destruct H3. exists x. split.    intuition. exists x0. split. intuition. exists x1. split. intuition. split. intuition. split. intuition. intuition. Qed.

Theorem pickedupPHY:(three Book1) (picked_up john)-> (three PHY)(picked_up john). cbv. intros. destruct H. destruct H. destruct H0. destruct H0. destruct H1. destruct H1. destruct H2. destruct H3. exists x. split.    intuition. exists x0. split. intuition. exists x1. split. intuition. split. intuition. split. intuition. intuition. Qed.

Definition AND:= fun A:DomCN=>  fun P: A->Prop=>fun Q:A->Prop=> fun x:A=> P(x) /\ Q(x).

Theorem pickedupMasteredPHY:(three Book2) (AND(book)(picked_up john)(mastered john))-> (three INFO)(mastered  john). cbv. intros. destruct H. destruct H. destruct H. destruct H0. destruct H0. destruct H0. destruct H2. destruct H2. destruct H2. destruct H4. exists x. split. intuition. intuition.  exists x0. intuition. intuition. exists x1. split. intuition. intuition. Qed.

Section BOOK.
Variable BOOK1BOOK2: forall x:book, forall y:book, IC_Book1  x y-> IC_Book2 x y.
Theorem pick1edupMasteredPHY:(three Book2) (AND(book)(picked_up john)(mastered john))-> (three PHY)(picked_up  john).
cbv. intros. destruct H. destruct H. destruct H. destruct H0. destruct H0. destruct H0. destruct H2. destruct H2.
destruct H2. destruct H4. exists x. split. intuition. intuition.  exists x0. intuition. intuition. exists x1. split.
intuition. split. destruct IC_Book2 in BOOK1BOOK2. destruct IC_Book1 in BOOK1BOOK2. destruct _eq3. destruct a.
destruct _eq4. destruct a. destruct IC_Info in H4. destruct IC_Phy. destruct IC_Info in H7. destruct IC_Info in H8. d
estruct _eq5. destruct _eq4. destruct _eq6. destruct H9. destruct _eq3. destruct H13. destruct H11. unfold transitive in H18.
unfold symmetric in H11. unfold reflexive in H10. unfold transitive in H17. unfold symmetric in H13. unfold reflexive in H12.
unfold transitive in H14. unfold symmetric in H9. unfold reflexive in H6. destruct H16. unfold transitive in H19.
unfold symmetric in H16. unfold reflexive in H15. firstorder.  Abort all.

Definition Three_dot2:=fun c: Book1.(B)->PHYINFO.(B)=>fun P:PHYINFO.(B)->Prop=>exists x y z: Book1.(B), not((PHY.(B2))(c(x))(c(y)))/\not((PHY.(B2))(c(y))(c(z))) /\not((PHY.(B2))(c(x))(c(z)))/\not((INFO.(B2))(c(x))(c(y)))/\not((INFO.(B2))(c(y))(c(z))) /\not((INFO.(B2))(c(x))(c(z)))/\P (c(x))/\ P(c(y))/\P(c(z)). (**arbitrary A, WHEN SUBTYPING WORKS C SHOULD BE REDUNDANT, CHECK IT**)

Definition and:= fun A:DomCN=>  fun P: A->Prop=>fun Q: A->Prop=>fun x: A=>  P(x)/\Q(x).
Axiom c1: Book1.(B)->PHYINFO.(B). Axiom c2: Book2.(B)->PHYINFO.(B).
                  (**John picked up and mastered three books->John mastered three informational objects**)
Theorem pickedmastered3m: (Three_dot2 c1)(and PHYINFO(picked_up john )(mastered john))-> exists x y z: Book1.(B),mastered (john)(c1 x)/\mastered (john)(c1 y)/\mastered (john)(c1 z)/\ not((INFO.(B2))(c1(x))(c1(y)))/\not((INFO.(B2))(c1(y))(c1(z)))/\not((INFO.(B2))(c1(x))(c1(z))). cbv. firstorder. Qed.

                   (**John picked up and mastered three books->John picked_up three physical objects**)
Theorem pickedmastered3p: (Three_dot2 c1)(and PHYINFO(picked_up john )(mastered john))-> exists x y z: Book1.(B),picked_up (john)(c1 x)/\picked_up (john)(c1 y)/\picked_up (john)(c1 z)/\ not((PHY.(B2))(c1(x))(c1(y)))/\not((PHY.(B2))(c1(y))(c1(z)))/\not((PHY.(B2))(c1(x))(c1(z))). cbv. firstorder. Qed.

 (**John picked up and mastered three books-> John picked up three physical objects and mastered three informational objects**)
Theorem pickedmastered3pm: (Three_dot2 c1)(and PHYINFO(picked_up john )(mastered john))-> exists x y z: Book1.(B),picked_up (john)(c1 x)/\picked_up (john)(c1 y)/\picked_up (john)(c1 z)/\ not((PHY.(B2))(c1(x))(c1(y)))/\not((PHY.(B2))(c1(y))(c1(z)))/\not((PHY.(B2))(c1(x))(c1(z)))/\mastered (john)(c1 x)/\mastered (john)(c1 y)/\mastered (john)(c1 z)/\ not((INFO.(B2))(c1(x))(c1(y)))/\not((INFO.(B2))(c1(y))(c1(z)))/\not((INFO.(B2))(c1(x))(c1(z))).
cbv. firstorder. Qed.

                      (**Collecting the previous examples plus new ones**)
Theorem MANWALKSOME: (some MAN) walk-> (some  HUMAN) walk. cbv. intros.                                                       firstorder. Qed.
Theorem BOOKPICKED:( (some Book1) ( picked_up john))-> (some PHY)( picked_up john).
   cbv.  intro. firstorder. Qed. (**John picked up a book->John picked up a physical object**)
  Theorem BOOKMASTERED:( (some Book1) ( mastered john))-> (some INFO)( mastered john).
    cbv.  intro. firstorder. Qed. (**John mastered  a book->John mastered an informational object**)
Parameter John: man.
Theorem MANEQUALHUMAN: (MAN.(B2) John John)-> (HUMAN.(B2) John John).
  cbv. intro. assumption. Qed.

Parameter Heavy: PHY.(B)->Prop.
Record heavybook :DomCN := mkheavybook { l3 :>book; L : Heavy l3 }.

Definition AIC_HBook1 := fun x: heavybook=>fun y:heavybook=> IC_Book1(x)(y).
Theorem EQ4: reflexive  heavybook  AIC_HBook1/\  symmetric heavybook AIC_HBook1/\  transitive heavybook AIC_HBook1. cbv. destruct  IC_Phy. destruct _eq3. destruct H0. split. intro. unfold reflexive in H.  apply H. split. intro. unfold symmetric in H0. intuition. intro. unfold transitive in H1. intro. intro. intros. apply H1 with y. assumption. assumption. Qed.

Definition IC_HBook1:=  mkEquiv heavybook  AIC_HBook1 EQ4.
Definition HBook1:= mkCN heavybook IC_HBook1.

Definition AIC_HBook2 := fun x: heavybook=>fun y:heavybook=> IC_Book2(x)(y).
Theorem EQ5: reflexive  heavybook  AIC_HBook2/\  symmetric heavybook AIC_HBook2/\  transitive heavybook AIC_HBook2. cbv. destruct  IC_Info. destruct _eq3. destruct H0. split. intro. unfold reflexive in H.  apply H. split. intro. unfold symmetric in H0. intuition. intro. unfold transitive in H1. intro. intro. intros. apply H1 with y. assumption. assumption. Qed.

Definition IC_HBook2:=  mkEquiv heavybook  AIC_HBook2 EQ5.
Definition HBook2:= mkCN heavybook IC_HBook2.

Theorem HEAVYBOOK:( (some HBook2) ( mastered john))-> (some INFO)( mastered john). firstorder. Qed.
Theorem HEAVYBOOK1:( (some HBook1) (picked_up john))-> (some PHY)( picked_up john). firstorder. Qed.
Theorem HEAVYBOOK2:( (three HBook1) (picked_up john))-> (three PHY)( picked_up john). cbv.  firstorder. Qed.
Theorem HEAVYBOOK3:( (three HBook2) ( mastered john))-> (three INFO)( mastered john). cbv. intros. firstorder. Qed.

Parameter informative: Info->Prop.
Axiom c3: HBook1.(B)->PHYINFO.(B). Axiom c4: HBook2.(B)->PHYINFO.(B).
Record heavyinfobook :DomCN := mkheavyinfobook { l4 :>heavybook; _ : informative l4 }.

Definition AIC_HIBook1 := fun x: heavyinfobook=>fun y:heavyinfobook=> IC_HBook1(x)(y).
Theorem EQ6: reflexive  heavyinfobook  AIC_HIBook1/\  symmetric heavyinfobook AIC_HIBook1/\  transitive heavyinfobook AIC_HIBook1. cbv. destruct  IC_Phy. destruct _eq3. destruct H0. split. intro. unfold reflexive in H.  apply H. split. intro. unfold symmetric in H0. intuition. intro. unfold transitive in H1. intro. intro. intros. apply H1 with y. assumption. assumption. Qed.
Definition IC_HIBook1:=  mkEquiv heavyinfobook  AIC_HIBook1 EQ6.
Definition HIBook1:= mkCN heavyinfobook IC_HIBook1.

Definition AIC_HIBook2 := fun x: heavyinfobook=>fun y:heavyinfobook=> IC_HBook2(x)(y).
Theorem EQ7: reflexive  heavyinfobook  AIC_HIBook2/\  symmetric heavyinfobook AIC_HIBook2/\  transitive heavyinfobook AIC_HIBook2. cbv. destruct  IC_Info. destruct _eq3. destruct H0. split. intro. unfold reflexive in H.  apply H. split. intro. unfold symmetric in H0. intuition. intro. unfold transitive in H1. intro. intro. intros. apply H1 with y. assumption. assumption. Qed.
Definition IC_HIBook2:=  mkEquiv heavyinfobook  AIC_HIBook2 EQ7.
Definition HIBook2:= mkCN heavyinfobook IC_HIBook2.

Theorem HEAVYIBOOK2:( (three HIBook1) (picked_up john))-> (three PHY)( picked_up john). cbv. firstorder. Qed.
Theorem HEAVYIBOOK3:( (three HIBook2) ( mastered john))-> (three INFO)( mastered john). cbv. intros. firstorder.                                                 Qed.
Theorem HEAVYIBOOK4:( (three HIBook1) (picked_up john))-> (three HBook1)( picked_up john). cbv.  firstorder. Qed.
Theorem HEAVYIBOOK5:( (three HIBook2) ( mastered john))-> (three HBook2)( mastered john). cbv. intros. firstorder.                                                 Qed.
Theorem HEAVYIBOOK6:( (three HBook1) (picked_up john))-> (three Book1)( picked_up john). cbv.  firstorder. Qed.
Theorem HEAVYIBOOK7:( (three HBook2) ( mastered john))-> (three Book2)( mastered john). cbv. intros. firstorder.                                                 Qed.
Axiom HB: HBook1.(B)->Book1.(B).
Theorem HEAVYIBOOK8: (three HBook1)((picked_up john ))->    three Book1 (Heavy).
decompose record HBook1.  cbv. decompose record heavybook. intros.  firstorder. decompose record H0. decompose record x.
decompose record x. exists l5. split. assumption.  decompose record x0. exists l6. split. assumption. decompose record x1.
exists l7. split. assumption. firstorder.  Abort all. End BOOK.

Definition Three_d:=fun A:CN=> fun c: A.(B)->PHYINFO.(B)=>fun P:PHYINFO.(B)->Prop=>exists x y z: A.(B), not((PHY.(B2))(c(x))(c(y)))/\not((PHY.(B2))(c(y))(c(z))) /\not((PHY.(B2))(c(x))(c(z)))/\not((INFO.(B2))(c(x))(c(y)))/\not((INFO.(B2))(c(y))(c(z))) /\not((INFO.(B2))(c(x))(c(z)))/\P (c(x))/\ P(c(y))/\P(c(z)).

Theorem masteredheavy: (Three_d HBook1 bf)(mastered john)-> exists x y z: heavybook, not((PHY.(B2))((x))((y)))/\not((PHY.(B2))((y))((z))) /\not((PHY.(B2))((x))((z))). cbv. firstorder. Qed.
Theorem masteredheavy1: (Three_d HBook1 bf)(mastered john)-> (three Book1) Heavy. cbv.  firstorder. exists x. split.
apply (x.(L)).  exists x0. split.  apply (x0.(L)).    exists x1. split. apply (x1.(L)). firstorder.  Qed.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.
Require Import RobustTraceProperty.

Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Section RobustHyperPreservation.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  (*CA: we don't need a particular structure of traces to define preservation
        e.g. traces = values or our defn of traces both make sense
   *)
  Variable trace__S trace__T : Type.

  Local Definition prop__S := prop trace__S.
  Local Definition prop__T := prop trace__T.
  Local Definition hprop__S := hprop trace__S.
  Local Definition hprop__T := hprop trace__T.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition beh__S := beh Source_Semantics.
  Local Definition beh__T := beh Target_Semantics.
  Local Definition par__S := par Source.
  Local Definition par__T := par Target.
  Local Definition ctx__S := ctx Source.
  Local Definition ctx__T := ctx Target.
  Local Definition rhsat__S := rhsat Source_Semantics.
  Local Definition rhsat__T := rhsat Target_Semantics.

  Local Definition cmp := compile_par Source Target compilation_chain.

  Local Notation "P ↓" := (cmp P) (at level 50).
 (* CA: don't understand why this does not work

   Local Notation " C [ P ] " := (plug _  P C) (at level 50).
  *)
  Local Definition plug__S:= plug Source.
  Local Definition plug__T := plug Target.

  (* these are still maps between properties *)
  Variable σ__π : prop__T -> prop__S.
  Variable τ__π : prop__S -> prop__T.

  Local Definition σ : hprop__T -> hprop__S := lift σ__π.
  Local Definition τ : hprop__S -> hprop__T := lift τ__π.

  Definition σRhP (P : par__S) (H__T : hprop__T) :=
    rhsat__S P (σ H__T) -> rhsat__T (P ↓) H__T.

  Definition σRHP := forall P H__T, σRhP P H__T.

  Lemma contra_σRhP (P : par__S) (H__T : hprop__T) :
    (σRhP P H__T) <->  ((exists C__T, ~ H__T (beh__T (plug__T (P↓) C__T))) ->
                   (exists C__S, ~ (σ H__T) (beh__S ( plug__S  P C__S)))).
  Proof.
    rewrite /σRhP. by rewrite [_ -> _] contra !neg_rhsat.
  Qed.

  Lemma contra_σRTP :
    σRHP <-> (forall P H__T,  ((exists C__T, ~ H__T (beh__T (plug__T (P↓) C__T))) ->
                      (exists C__S, ~ (σ H__T) (beh__S ( plug__S  P C__S))))).
  Proof.
    rewrite /σRHP.
    split => H P H__T; by move/contra_σRhP: (H P H__T).
  Qed.

  Definition τRhP (P : par__S) (H__S : hprop__S) :=
    rhsat__S P H__S -> rhsat__T (P ↓) (τ H__S).

  Definition τRHP := forall P H__S, τRhP P H__S.

  Lemma contra_τRhP (P : par__S) (H__S : hprop__S) :
    (τRhP P H__S) <-> ((exists C__T, ~ (τ H__S) (beh__T (plug__T (P↓) C__T))) ->
                 (exists C__S, ~  H__S (beh__S (plug__S P C__S)))).
  Proof.
    rewrite /τRhP. by rewrite [_ -> _] contra !neg_rhsat.
  Qed.

  Lemma contra_τRHP :
    τRHP <-> (forall P H__S, ((exists C__T, ~ (τ H__S) (beh__T (plug__T (P↓) C__T))) ->
                 (exists C__S, ~  H__S (beh__S (plug__S P C__S))))).
  Proof.
    rewrite /τRHP.
    split => H P H__S; by move/contra_τRhP: (H P H__S).
  Qed.

End RobustHyperPreservation.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj22synthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus lv0 lv1) (Succ lv2)) (plus lv1 (Succ (plus lv2 lv0)))).
Admitted.
QuickChick conj22synthconj4.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e152m17_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e129m25_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e384m2e128m2e96p2e32m1_12limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e158m15_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e174m17_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e190m11_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e129m25_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


From Flocq Require Import Core Sterbenz.
Require Import Gappa_common.
Require Import Gappa_round_aux.

Theorem fix_subset :
  forall x : R, forall xn zn : Z,
  FIX x xn ->
  Zle_bool zn xn = true ->
  FIX x zn.
Proof.
intros x xn zn Hx Hb.
apply fix_le with (1 := Hx).
now apply Zle_bool_imp_le.
Qed.

Theorem flt_subset :
  forall x : R, forall xn zn : positive,
  FLT x xn ->
  Zle_bool (Zpos xn) (Zpos zn) = true ->
  FLT x zn.
Proof.
intros x xn zn Hx Hb.
apply flt_le with (1 := Hx).
now apply Zle_bool_imp_le.
Qed.

Definition fix_of_singleton_bnd_helper (xi : FF) (n : Z) :=
 Zeq_bool (Fnum (lower xi)) (Fnum (upper xi)) &&
 Zeq_bool (Fexp (lower xi)) (Fexp (upper xi)) &&
 Zle_bool n (Fexp (lower xi)).

Theorem fix_of_singleton_bnd :
 forall x : R, forall xi : FF, forall n : Z,
 ABS x xi ->
 fix_of_singleton_bnd_helper xi n = true ->
 FIX x n.
Proof.
intros x xi n (_, (Hx1, Hx2)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zeq_bool_correct_t _ _ H1). clear H1. intro H1.
generalize (Zeq_bool_correct_t _ _ H2). clear H2. intro H2.
generalize (Zle_bool_imp_le _ _ H3). clear H3. intro H3.
assert (float2R (lower xi) = Rabs x).
apply Rle_antisym.
exact Hx1.
replace (lower xi) with (upper xi).
exact Hx2.
apply sym_equal.
induction (lower xi). induction (upper xi).
exact (f_equal2 _ H1 H2).
unfold Rabs in H.
induction (Rcase_abs x).
exists (Fopp2 (lower xi)).
split.
rewrite Fopp2_correct.
rewrite <- (Ropp_involutive x).
apply Ropp_eq_compat.
exact H.
exact H3.
exists (lower xi).
exact (conj H H3).
Qed.

Definition flt_of_singleton_bnd_helper (xi : FF) (n : positive) :=
 Zeq_bool (Fnum (lower xi)) (Fnum (upper xi)) &&
 Zeq_bool (Fexp (lower xi)) (Fexp (upper xi)) &&
 Zlt_bool (Z.abs (Fnum (lower xi))) (two_power_pos n).

Theorem flt_of_singleton_bnd :
 forall x : R, forall xi : FF, forall n : positive,
 ABS x xi ->
 flt_of_singleton_bnd_helper xi n = true ->
 FLT x n.
Proof.
intros x xi n (_, (Hx1, Hx2)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zeq_bool_correct_t _ _ H1). clear H1. intro H1.
generalize (Zeq_bool_correct_t _ _ H2). clear H2. intro H2.
generalize (Zlt_cases (Z.abs (Fnum (lower xi))) (two_power_pos n)). rewrite H3. rewrite two_power_pos_correct. clear H3. intro H3.
assert (float2R (lower xi) = Rabs x).
apply Rle_antisym.
exact Hx1.
replace (lower xi) with (upper xi).
exact Hx2.
apply sym_equal.
induction (lower xi). induction (upper xi).
exact (f_equal2 _ H1 H2).
unfold Rabs in H.
induction (Rcase_abs x).
exists (Fopp2 (lower xi)).
split.
rewrite Fopp2_correct.
rewrite <- (Ropp_involutive x).
apply Ropp_eq_compat.
exact H.
simpl.
rewrite Zabs_Zopp.
exact H3.
exists (lower xi).
exact (conj H H3).
Qed.

Theorem neg_fix :
  forall x : R, forall xn zn : Z,
  FIX x xn ->
  Zle_bool zn xn = true ->
  FIX (-x)%R zn.
Proof.
intros x xn zn [fx [Hx1 Hx2]] Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
exists (Fopp2 fx).
split.
rewrite <- Hx1.
apply Fopp2_correct.
now apply Z.le_trans with xn.
Qed.

Theorem abs_fix :
  forall x : R, forall xn zn : Z,
  FIX x xn ->
  Zle_bool zn xn = true ->
  FIX (Rabs x) zn.
Proof.
intros x xn zn [[mx ex] [Hx1 Hx2]] Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
exists (Float2 (Z.abs mx) ex).
split.
rewrite <- Hx1.
apply F2R_Zabs.
now apply Z.le_trans with xn.
Qed.

Definition add_fix_helper (xn yn zn : Z) :=
 Zle_bool zn xn &&
 Zle_bool zn yn.

Theorem add_fix :
 forall x y : R, forall xn yn zn : Z,
 FIX x xn -> FIX y yn ->
 add_fix_helper xn yn zn = true ->
 FIX (x + y)%R zn.
Proof.
intros x y xn yn zn (fx,(Hx1,Hx2)) (fy,(Hy1,Hy2)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1.
generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2.
exists (Fplus2 fx fy).
split.
rewrite <- Hx1.
rewrite <- Hy1.
apply Fplus2_correct.
unfold Fplus2, Fshift2.
case (Fexp fx - Fexp fy)%Z ; intros.
exact (Z.le_trans _ _ _ H1 Hx2).
exact (Z.le_trans _ _ _ H2 Hy2).
exact (Z.le_trans _ _ _ H1 Hx2).
Qed.

Theorem sub_fix :
 forall x y : R, forall xn yn zn : Z,
 FIX x xn -> FIX y yn ->
 add_fix_helper xn yn zn = true ->
 FIX (x - y)%R zn.
Proof.
intros x y xn yn zn Hx (fy,(Hy1,Hy2)) Hb.
unfold Rminus.
apply (add_fix _ (-y) _ yn zn Hx).
exists (Fopp2 fy).
split.
rewrite <- Hy1.
apply Fopp2_correct.
exact Hy2.
exact Hb.
Qed.

Theorem mul_fix :
 forall x y : R, forall xn yn zn : Z,
 FIX x xn -> FIX y yn ->
 Zle_bool zn (xn + yn) = true ->
 FIX (x * y)%R zn.
Proof.
intros x y xn yn zn (fx,(Hx1,Hx2)) (fy,(Hy1,Hy2)) Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
exists (Fmult2 fx fy).
split.
rewrite <- Hx1. rewrite <- Hy1.
apply Fmult2_correct.
apply Z.le_trans with (1 := H1).
exact (Zplus_le_compat _ _ _ _ Hx2 Hy2).
Qed.

Lemma flt_abs_aux :
  forall x : R, forall xn : positive,
  FLT (Rabs x) xn <-> FLT x xn.
Proof.
intros x xn.
unfold Rabs.
case Rcase_abs ; intros Hx.
2: easy.
split ; intros [[mx ex] [Hx1 Hx2]] ;
  exists (Float2 (Z.opp mx) ex) ; split ; simpl.
rewrite <- (Ropp_involutive x), <- Hx1.
apply F2R_Zopp.
now rewrite Zabs_Zopp.
rewrite <- Hx1.
apply F2R_Zopp.
now rewrite Zabs_Zopp.
Qed.

Lemma flt_1_aux :
  forall x y : R, forall yn : positive,
  FLT x 1 -> FLT y yn ->
  FLT (x * y)%R yn.
Proof.
intros x y yn [[mx ex] [<- Hx]] Hy.
destruct mx as [|mx|mx].
rewrite float2_zero, Rmult_0_l.
exists (Float2 Z0 0).
split.
apply float2_zero.
now apply (Zpower_gt_0 radix2 (Zpos yn)).
destruct mx ; try now destruct mx.
destruct Hy as [[my ey] [<- Hy]].
exists (Float2 my (ex + ey)).
split.
2: exact Hy.
unfold float2R ; simpl.
rewrite <- Operations.F2R_mult.
unfold Operations.Fmult.
now rewrite Zmult_1_l.
destruct mx ; try now destruct mx.
destruct Hy as [[my ey] [<- Hy]].
exists (Float2 (-my) (ex + ey)).
split.
2: simpl ; now rewrite Zabs_Zopp.
unfold float2R ; simpl.
rewrite <- Operations.F2R_mult.
unfold Operations.Fmult.
now replace (-1 * my)%Z with (Z.opp my) by ring.
Qed.

Theorem mul_flt :
  forall x y : R, forall xn yn zn : positive,
  FLT x xn -> FLT y yn ->
  Zle_bool (Zpos (if xn =? 1 then yn else if yn =? 1 then xn else xn + yn)%positive) (Zpos zn) = true ->
  FLT (x * y)%R zn.
Proof.
intros x y xn yn zn Hx Hy Hb.
apply Zle_bool_imp_le in Hb.
revert Hb.
apply flt_le.
case Pos.eqb_spec.
intros ->.
now apply flt_1_aux.
intros _.
case Pos.eqb_spec.
intros ->.
rewrite Rmult_comm.
now apply flt_1_aux.
intros _.
destruct Hx as [fx [Hx1 Hx2]].
destruct Hy as [fy [Hy1 Hy2]].
exists (Fmult2 fx fy).
split.
rewrite <- Hx1. rewrite <- Hy1.
apply Fmult2_correct.
change (Z.pow_pos 2 (xn + yn)) with (Zpower radix2 (Zpos xn + Zpos yn)).
rewrite Zpower_plus by easy.
simpl Z.abs.
rewrite Zabs_Zmult.
apply Zmult_lt_compat ; split ;
  try assumption ; apply Zabs_pos.
Qed.

Theorem fix_of_flt_bnd :
 forall x : R, forall xi : FF, forall n : Z, forall p : positive,
 FLT x p -> ABS x xi ->
 Zle_bool (n + Zpos p) (Zpos (digits (pos_of_Z (Fnum (lower xi)))) + Fexp (lower xi))
 && Fpos (lower xi) = true ->
 FIX x n.
Proof.
intros x ((ml,el),xu) n p ((mx,ex),(Hx1,Hx2)) (_,(Hxi,_)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zle_bool_imp_le _ _ H1). simpl Fnum. simpl Fexp. clear H1. intro H1.
generalize (Fpos_correct _ H2). simpl. clear H2. intro H2.
exists (Float2 mx ex).
split.
exact Hx1.
apply Zplus_le_reg_l with (Zpos p).
rewrite Zplus_comm.
apply Z.le_trans with (1 := H1). clear H1.
rewrite digits2_digits.
assert (H0: (0 < ml)%Z).
apply gt_0_F2R with (1 := H2).
rewrite Zpos_pos_of_Z with (1 := H0).
assert (H0': ml <> Z0).
intros H.
now rewrite H in H0.
rewrite Zdigits_mag with (1 := H0').
rewrite <- mag_F2R with (1 := H0').
apply Z.le_trans with (mag radix2 (Rabs (Float2 mx ex))).
apply mag_le.
now apply F2R_gt_0.
now rewrite Hx1.
rewrite mag_abs.
unfold float2R.
assert (Hx0: mx <> Z0).
intros H.
apply Rle_not_lt with (1 := Hxi).
rewrite <- Hx1, H.
unfold float2R.
rewrite F2R_0, Rabs_R0.
now apply F2R_gt_0.
rewrite mag_F2R with (1 := Hx0).
apply Zplus_le_compat_r.
destruct (mag radix2 (IZR mx)) as (e, He).
simpl.
apply bpow_lt_bpow with radix2.
apply Rle_lt_trans with (Rabs (IZR mx)).
apply He.
now apply (IZR_neq _ 0).
rewrite <- abs_IZR.
rewrite <- IZR_Zpower. 2: easy.
now apply IZR_lt.
Qed.

Theorem flt_of_fix_bnd :
  forall x xi n p,
  FIX x n -> ABS x xi ->
  Zle_bool (Zpos (digits (pos_of_Z (Fnum (upper xi)))) + Fexp (upper xi)) (n + Zpos p) = true ->
  FLT x p.
Proof.
intros x (xl,(mu,eu)) n p ((m,e),(Hx1,Hx2)) Hxi H.
generalize (Zle_bool_imp_le _ _ H). clear H. intro H.
exists (Float2 m e).
split.
exact Hx1.
unfold float2R in Hx1. simpl in Hx1.
simpl Fnum in H. simpl Fexp in H.
apply (lt_F2R radix2 e).
rewrite F2R_Zabs.
apply Rle_lt_trans with (F2R (Float radix2 mu eu)).
simpl. rewrite Hx1.
apply Hxi.
apply Rlt_le_trans with (bpow radix2 (n + Zpos p)).
destruct (Zle_or_lt mu 0) as [Hu|Hu].
apply Rle_lt_trans with R0.
now apply F2R_le_0.
apply bpow_gt_0.
apply Rlt_le_trans with (bpow radix2 (Digits.Zdigits radix2 mu + eu)).
rewrite Zdigits_mag. 2: intros Hu' ; now rewrite Hu' in Hu.
rewrite <- mag_F2R. 2: intros Hu' ; now rewrite Hu' in Hu.
destruct (mag radix2 (F2R (Float radix2 mu eu))) as (e', He).
apply (Rle_lt_trans _ _ _ (RRle_abs _)).
apply He.
apply Rgt_not_eq.
now apply F2R_gt_0.
rewrite <- (Zpos_pos_of_Z _ Hu).
rewrite <- digits2_digits.
now apply bpow_le.
unfold F2R. simpl.
change (Zpower_pos 2 p) with (Zpower radix2 (Zpos p)).
rewrite IZR_Zpower. 2: easy.
rewrite <- bpow_plus.
apply bpow_le.
rewrite Zplus_comm.
now apply Zplus_le_compat_l.
Qed.

Definition sub_flt_helper (xn yn zn : positive) (xyi : FF) :=
  Zle_bool (Zpos xn) (Zpos zn) &&
  Zle_bool (Zpos yn) (Zpos zn) &&
  Fle2 (Float2 (-1) (-1)) (lower xyi) &&
  Fle2 (upper xyi) (Float2 1 0).

Theorem sub_flt :
  forall x y xn yn xyi zn,
  FLT x xn -> FLT y yn -> REL x y xyi ->
  sub_flt_helper xn yn zn xyi = true ->
  FLT (x - y) zn.
Proof.
intros x y xn yn xyi zn Hx Hy (eps,((Hxy1,Hxy2),Hxy3)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4).
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H3). clear H3. intro H3.
generalize (Fle2_correct _ _ H4). clear H4. intro H4.
destruct (total_order_T y 0) as [[Zy|Zy]|Zy].
(* *)
apply <- FLT_iff_generic.
unfold Rminus.
rewrite <- (Ropp_involutive x), Rplus_comm.
apply sterbenz.
now apply FLX_exp_valid.
apply FLX_exp_monotone.
apply generic_format_opp.
apply -> FLT_iff_generic.
now apply flt_subset with yn.
apply generic_format_opp.
apply -> FLT_iff_generic.
now apply flt_subset with xn.
rewrite Hxy3, <- Ropp_mult_distr_l_reverse.
unfold Rdiv.
rewrite (Rmult_comm 2), 2!Rmult_assoc.
pattern (-y)%R at 2 3 ; rewrite <- Rmult_1_r.
assert (Zy': (0 <= -y)%R).
apply Rlt_le.
now apply Ropp_0_gt_lt_contravar.
split ; apply Rmult_le_compat_l ; try easy.
apply Rmult_le_reg_r with 2%R.
now apply IZR_lt.
rewrite Rmult_assoc, Rinv_l, Rmult_1_l, Rmult_1_r.
apply (Rplus_le_compat_l _ _ 1%R).
apply Rle_trans with (1 := Hxy2).
now rewrite <- (Rmult_1_r 1).
apply Rgt_not_eq.
now apply IZR_lt.
replace 1%R with ((1 + -1 / 2)*2)%R at 1 by field.
apply Rmult_le_compat_r.
now apply IZR_le.
apply Rplus_le_compat_l.
now apply Rle_trans with (2 := Hxy1).
(* *)
rewrite Zy, Rminus_0_r.
now apply flt_subset with xn.
(* *)
apply <- FLT_iff_generic.
apply sterbenz.
now apply FLX_exp_valid.
apply FLX_exp_monotone.
apply -> FLT_iff_generic.
now apply flt_subset with xn.
apply -> FLT_iff_generic.
now apply flt_subset with yn.
rewrite Hxy3.
unfold Rdiv.
rewrite (Rmult_comm 2).
assert (Zy': (0 <= y)%R).
now apply Rlt_le.
split ; apply Rmult_le_compat_l ; try easy.
replace (/2)%R with (1 + -1/2)%R by field.
apply Rplus_le_compat_l.
now apply Rle_trans with (2 := Hxy1).
apply (Rplus_le_compat_l _ _ 1%R).
apply Rle_trans with (1 := Hxy2).
now rewrite <- (Rmult_1_r 1).
Qed.

Theorem sub_flt_rev :
  forall x y xn yn xyi zn,
  FLT x xn -> FLT y yn -> REL x y xyi ->
  sub_flt_helper xn yn zn xyi = true ->
  FLT (y - x) zn.
Proof.
intros x y xn yn xyi zn Hx Hy Hxy Hb.
apply <- FLT_iff_generic.
rewrite <- Ropp_minus_distr.
apply generic_format_opp.
apply -> FLT_iff_generic.
eapply sub_flt ; eassumption.
Qed.