Require Import Coq.Bool.Bool.
Require Import Coq.Reals.Reals.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Reals.ROrderedType.
Require Import Lists.List.
Import ListNotations.
Require Import Coq.Lists.ListSet.
Open Scope R_scope.
Require Import Ascii String.

From HYDLA Require Export PropFormula.

Variable x x' x'' prevx prevx': partial.
Variable t: R.
Definition INIT := [[$ x(t) = Some 10; $ x'(t) = Some 0]].
Definition FALL := [[[]$ x''(t) = Some(-10)]].
Definition BOUNCE := [[[]prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t))]].
(* add history about continuity for implementation *)
Definition Q : history :=
  "INIT" ~~> [[$ x(t) = Some 10; $ x'(t) = Some 0]; nil; nil; nil];
  "FALL" ~~> [[[]$ x''(t) = Some(-10); $ x''(t) = Some(-10)];
              [$ x''(t) = Some(-10)]; [$ x''(t) = Some(-10)]; [$ x''(t) = Some(-10)]];
  "BOUNCE" ~~> [[[]prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t)); prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t))];
                [prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t))];
                [prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t)); $ x'(t) = mul (Some(-1)) (prevx'(t))];
                [prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t))]];
  "continuity" ~~> [[$rightCont x t; $rightCont x' t; $rightCont x'' t]; [$cont x t; $cont x' t; $cont x'' t];
                    [$cont x t; $rightCont x' t]; [$cont x t; $cont x' t; $cont x'' t]].
Definition MS : set string := ["INIT"%string; "FALL"%string; "BOUNCE"%string].

Theorem semantics_i :
  let init := unfold_some (Q "INIT"%string) in
  let bounce := unfold_some (Q "BOUNCE"%string) in
  let fall := unfold_some (Q "FALL"%string) in
    Is_true (c_eq init (closure init)) /\
    Is_true (c_eq fall (closure fall)) /\
    Is_true (c_eq bounce (closure bounce)).
Proof.
  intros. split.
  - unfold Is_true, c_eq, c_subset, is_subset. simpl.
    destruct (Feq_dec ($ x t = Some 10) ($ x t = Some 10)).
    + destruct (Feq_dec ($ x' t = Some 0) ($ x t = Some 10)).
      { reflexivity. }
      destruct (Feq_dec ($ x' t = Some 0) ($ x' t = Some 0)).
      { reflexivity. }
      { congruence. }
    + congruence.
  - split.
    + unfold Is_true, c_eq, c_subset, is_subset. simpl.
      destruct (Feq_dec ($ x'' t = Some (-10)) ([] $ x'' t = Some (-10))).
      { congruence. }
      destruct (Feq_dec ($ x'' t = Some (-10)) ($ x'' t = Some (-10))).
      { simpl. destruct (Feq_dec ([] $ x'' t = Some (-10)) ([] $ x'' t = Some (-10))).
        { destruct (Feq_dec ($ x'' t = Some (-10)) ([] $ x'' t = Some (-10))).
          { congruence. }
          simpl. destruct (Feq_dec ($ x'' t = Some (-10)) ($ x'' t = Some (-10))).
          { unfold set_mem, is_subset. simpl. destruct (Feq_dec ($ x'' t = Some (-10)) ($ x'' t = Some (-10))).
            { destruct (Feq_dec ($ x'' t = Some (-10)) ($ x'' t = Some (-10))).
              { simpl. destruct (Feq_dec ($ x'' t = Some (-10)) ($ x'' t = Some (-10))).
                { reflexivity. }
                congruence.
              }
              congruence.
            }
            congruence.
          }
          congruence.
        }
        congruence.
      }
      congruence.
    + unfold Is_true, c_eq, c_subset, is_subset. simpl.
      destruct (Feq_dec (prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t)) ([] prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t))).
      { congruence. }
      destruct (Feq_dec (prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t)) (prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t))).
      { simpl. destruct (Feq_dec ([] prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t)) ([] prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t))).
        { destruct (Feq_dec (prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t)) ([] prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t))).
          { congruence. }
          destruct (Feq_dec (prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t)) (prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t))).
          { destruct (Feq_dec ($ x' t = mul (Some (-1)) (prevx' t)) (prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t))).
            { congruence. }
            destruct (Feq_dec ($ x' t = mul (Some (-1)) (prevx' t)) ($ x' t = mul (Some (-1)) (prevx' t))).
            { unfold is_subset. simpl. destruct (Feq_dec (prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t)) (prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t))).
              { unfold set_mem. simpl. destruct (Feq_dec (prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t)) (prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t))).
                { reflexivity. }
                congruence.
              }
              congruence.
            }
            congruence.
          }
          congruence.
        }
        congruence.
      }
      congruence. Qed.

Lemma cl_INIT: closure INIT = INIT.
Proof.
  unfold closure, INIT, closure2. simpl.
  unfold eq_f.
  destruct (Feq_dec ($ x t = Some 10) ($ x t = Some 10)).
  { destruct (Feq_dec ($ x' t = Some 0) ($ x' t = Some 0)).
    { reflexivity. }
    congruence.
  }
  congruence. Qed.
Lemma cl_FALL:
  closure FALL = [[[]$ x''(t) = Some(-10); $ x''(t) = Some(-10)]; [$ x''(t) = Some(-10)]].
Proof.
  unfold closure, FALL, closure2. simpl.
  destruct (Feq_dec ($ x'' t = Some (-10)) ([] $ x'' t = Some (-10))).
  { congruence. }
  unfold eq_f.
  destruct (Feq_dec ([] $ x'' t = Some (-10)) ([] $ x'' t = Some (-10))).
  { reflexivity. }
  congruence. Qed.
Lemma cl_BOUNCE:
  closure BOUNCE
    = [[[]prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t)); prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t))];
       [prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t))]].
Proof.
  unfold closure, BOUNCE, closure2. simpl.
  destruct (Feq_dec (prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t)) ([] prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t))).
  { congruence. }
  unfold eq_f. destruct (Feq_dec ([] prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t)) ([] prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t))).
  { reflexivity. }
  congruence. Qed.
Theorem semantics_ii :
  let init := unfold_some (Q "INIT"%string) in
  let bounce := unfold_some (Q "BOUNCE"%string) in
  let fall := unfold_some (Q "FALL"%string) in
    Is_true (c_subset (closure INIT) init) /\
    Is_true (c_subset (closure FALL) fall) /\
    Is_true (c_subset (closure BOUNCE) bounce).
Proof.
  intros.
  rewrite -> cl_INIT.
  rewrite -> cl_FALL.
  rewrite -> cl_BOUNCE.
 unfold Is_true, c_subset, is_subset. simpl. split.
  - destruct (Feq_dec ($ x t = Some 10) ($ x t = Some 10)).
    { destruct (Feq_dec ($ x' t = Some 0) ($ x t = Some 10)).
      { reflexivity. }
      destruct (Feq_dec ($ x' t = Some 0) ($ x' t = Some 0)).
      { reflexivity. }
      congruence.
    }
    congruence.
  - split.
    + destruct (Feq_dec ([] $ x'' t = Some (-10)) ([] $ x'' t = Some (-10))).
      { destruct (Feq_dec ($ x'' t = Some (-10)) ([] $ x'' t = Some (-10))).
        { congruence. }
        destruct (Feq_dec ($ x'' t = Some (-10)) ($ x'' t = Some (-10))).
        { reflexivity. }
        congruence.
      }
      congruence.
    + destruct (Feq_dec ([] prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t)) ([] prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t))).
      { destruct (Feq_dec (prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t)) ([] prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t))).
        { congruence. }
        destruct (Feq_dec (prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t)) (prevx t = Some 0 ~> $ x' t = mul (Some (-1)) (prevx' t))).
        { reflexivity. }
        congruence.
      }
      congruence. Qed.

Definition y := Some 0 |--> Some 10; (fun t => Some(10-5*t^2))|_(Some 0, Some(sqrt 2));
                Some(sqrt 2) |--> Some 0; (fun t => Some(20*sqrt(2)*t-5*t^2-30))|_(Some(sqrt 2), Some(3*sqrt(2))).
Definition y' := Some 0 |--> Some 0; (fun t => Some(-10*t))|_(Some 0, Some(sqrt 2));
                 Some(sqrt 2) |--> Some(10*sqrt(2)); (fun t => Some(20*sqrt(2)-10*t))|_(Some(sqrt 2), Some(3*sqrt(2))).
Definition y'' := Some 0 |--> Some(-10); (fun t => Some(-10))|_(Some 0, Some(sqrt 2));
                  (fun t => Some(-10))|_(Some(sqrt 2), Some(3*sqrt(2))).
Definition prevy := (fun t => Some(10-5*t^2))|_(Some 0, Some(sqrt 2));
                    Some(sqrt 2) |--> Some 0; (fun t => Some(20*sqrt(2)*t-5*t^2-30))|_(Some(sqrt 2), Some(3*sqrt(2))).
Definition prevy' := (fun t => Some(-10*t))|_(Some 0, Some(sqrt 2));
                     Some(sqrt 2) |--> Some(-10*sqrt(2)); (fun t => Some(20*sqrt(2)-10*t))|_(Some(sqrt 2), Some(3*sqrt(2))).
Definition prevy'' := (fun t => Some(-10))|_(Some 0, Some(3*sqrt(2))).

Theorem semantics_iii_s1_pp1 :
  let E := ["INIT"%string; "FALL"%string; "BOUNCE"%string] in
  let t := 0 in
  let x := y in let x' := y' in let x'' := y'' in
  let prevx := prevy in let prevx' := prevy' in let prevx'' := prevy'' in
  let QEt := [$ x(t) = Some 10; $ x'(t) = Some 0;
              []$ x''(t) = Some(-10); $ x''(t) = Some(-10);
              []prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t)); prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t));
              $rightCont x t; $rightCont x' t; $rightCont x'' t] in
  andl (map f2p QEt).
Proof.
  unfold map, f2p, andl, y, y', y'', prevy. simpl.
  repeat split.
  - destruct (Reqb 0 0) eqn:E.
    + trivial.
    + apply reqb00false in E.
      case E.
  - destruct (Reqb 0 0) eqn:E.
    + trivial.
    + apply reqb00false in E.
      case E.
  - destruct (Reqb 0 0) eqn:E.
    + trivial.
    + apply reqb00false in E.
      case E.
  - unfold update_pt, update_in.
    destruct (Rltb 0 0) eqn:E1.
    + simpl.
      destruct (Rltb 0 (sqrt 2)) eqn:E2.
      * destruct (Reqb 0 0) eqn:E3.
        -- rewrite Rmult_0_l.
           rewrite Rmult_0_r.
           rewrite Rminus_0_r.
           intros.
           inversion H.
           assert (H2: 10 = 0 -> False). { admit. }
           apply H2 in H1.
           case H1.
        -- apply reqb00false in E3.
           case E3.
      * assert (H: Rltb 0 (sqrt 2) = false -> False). { admit. }
        apply H in E2.
        case E2.
    + simpl.
      destruct (Reqb (sqrt 2) 0) eqn:E2.
      * assert (H: Reqb (sqrt 2) 0 = true -> False). { admit. }
        apply H in E2.
        case E2.
      * assert (H: Rltb (sqrt 2) 0 = false). { admit. }
        rewrite H. simpl.
        unfold empty.
        intros.
        inversion H0.
  - admit.
  - admit.
  - admit.
  Admitted.

Theorem semantics_iii_s1_ip2 :
  let E := ["INIT"%string; "FALL"%string; "BOUNCE"%string] in
  let x := y in let x' := y' in let x'' := y'' in
  let prevx := prevy in let prevx' := prevy' in let prevx'' := prevy'' in
  let QEt := [$ x''(t) = Some(-10);
              prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t));
              $cont x t; $cont x' t; $cont x'' t] in
  0 < t < sqrt(2) -> andl (map f2p QEt).
Proof.
  unfold map, f2p, andl, y'', prevy. simpl.
  intros.
  repeat split.
  - destruct (Reqb 0 t) eqn:E.
    + trivial.
    + unfold update_in, Rltb. simpl.
      destruct (Rlt_dec 0 t). simpl.
      * destruct (Rlt_dec t (sqrt 2)).
        -- trivial.
        -- inversion H.
           contradiction.
      * inversion H.
        contradiction.
  - unfold update_in, Rltb. simpl.
    destruct (Rlt_dec 0 t). simpl.
    + destruct (Rlt_dec t (sqrt 2)).
      * admit.
      * inversion H.
        contradiction.
    + inversion H.
      contradiction.
  - Admitted.

Theorem semantics_iii_s1_pp3 :
  let E := ["INIT"%string; "BOUNCE"%string] in
  let t := sqrt(2) in
  let x := y in let x' := y' in let x'' := y'' in
  let prevx := prevy in let prevx' := prevy' in let prevx'' := prevy'' in
  let QEt := [prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t)); $ x'(t) = mul (Some(-1)) (prevx'(t));
              $cont x t; $rightCont x' t] in
  andl (map f2p QEt).
Proof.
  unfold map, f2p, andl. simpl.
  repeat split.
  - intros.
    unfold y', prevy', update_pt.
    destruct (Reqb 0 (sqrt 2)) eqn:E1.
    + apply Reqb_eq in E1.
      rewrite <- sqrt_0 in E1.
      apply sqrt_inj in E1.
      * assert (H2: 0 = 2 -> False). { admit. }
        apply H2 in E1. case E1.
      * apply Rle_refl.
      * apply Rle_0_2.
    + unfold update_in, update_pt, Rltb.
      destruct (Rlt_dec (sqrt 2) (sqrt 2)).
      * apply Rlt_irrefl in r. case r.
      * rewrite andb_false_r. simpl.
        destruct (Reqb (sqrt 2) (sqrt 2)) eqn:E2.
        -- unfold mul. admit.
        -- apply test_Reqb2 in E2.
           apply Rdichotomy in E2.
           generalize E2. intros [E3|E4].
           { contradiction. }
           { contradiction. }
  - unfold y', mul, prevy'. simpl.
    destruct (Reqb 0 (sqrt 2)) eqn:E1.
    + apply Reqb_eq in E1.
      assert (H: 0 = sqrt 2 -> False). { admit. }
      apply H in E1. case E1.
    + unfold update_in, update_pt, Rltb.
      destruct (Rlt_dec (sqrt 2) (sqrt 2)).
      * apply Rlt_irrefl in r. case r.
      * rewrite andb_false_r. simpl.
        destruct (Reqb (sqrt 2) (sqrt 2)) eqn:E2.
        -- assert (H: -1 * (-10 * sqrt 2) = 10 * sqrt 2). { admit. }
           rewrite H. trivial.
        -- apply test_Reqb2 in E2.
           apply Rdichotomy in E2.
           generalize E2. intros [E3|E4].
           { contradiction. } { contradiction. }
  Admitted.

Theorem semantics_iii_s1_ip4 :
  let E := ["INIT"%string; "FALL"%string; "BOUNCE"%string] in
  let x := y in let x' := y' in let x'' := y'' in
  let prevx := prevy in let prevx' := prevy' in let prevx'' := prevy'' in
  let QEt := [$ x''(t) = Some(-10);
              prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t));
              $cont x t; $cont x' t; $cont x'' t] in
  sqrt(2) < t < 3*sqrt(2) -> andl (map f2p QEt).
Proof.
  unfold map, f2p, andl. simpl.
  repeat split.
  - unfold y'', update_pt, update_in.
    destruct (Reqb 0 t) eqn:E1.
    + trivial.
    + unfold Rltb.
      destruct (Rlt_dec t (sqrt 2)).
      * inversion H.
        apply Rgt_asym in r.
        contradiction.
      * rewrite andb_false_r.
        -- destruct (Rlt_dec (sqrt 2) t).
           ++ destruct (Rlt_dec t (3*sqrt 2)).
              { reflexivity. }
              { inversion H. contradiction. }
           ++ inversion H. contradiction.
  - unfold prevy, update_in, update_pt. simpl.
    unfold Rltb.
    destruct (Rlt_dec t (sqrt 2)) eqn:E1.
    + inversion H.
      apply Rgt_asym in H0.
      contradiction.
    + rewrite andb_false_r.
      destruct (Reqb (sqrt 2) t) eqn:E2.
      * apply Reqb_eq in E2.
        inversion H.
        assert (H2: sqrt 2 = t -> sqrt 2 < t -> False). { admit. }
        apply H2 in E2.
        { case E2. } { apply H0. }
      * destruct (Rlt_dec (sqrt 2) t) eqn:E3.
        -- destruct (Rlt_dec t (3*sqrt 2)) eqn:E4.
           ++ simpl. intros.
              assert (H1: Some (20 * sqrt 2 * t - 5 * (t * (t * 1)) - 30) = Some 0 -> False). { admit. }
              apply H1 in H0. case H0.
           ++ unfold empty. simpl.
              intros.
              discriminate H0.
        -- unfold empty. simpl.
           intros. discriminate H0.
  Admitted.

Theorem semantics_iii_s2_1_pp1 :
  let E := ["INIT"%string; "FALL"%string; "BOUNCE"%string] in
  let t := 0 in
  let x := y in let x' := y' in let x'' := y'' in
  let prevx := prevy in let prevx' := prevy' in let prevx'' := prevy'' in
  let QEt := [$ x(t) = Some 10; $ x'(t) = Some 0;
              []$ x''(t) = Some(-10); $ x''(t) = Some(-10);
              []prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t)); prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t));
              $rightCont x t; $rightCont x' t; $rightCont x'' t] in
  ~ exists E', ssubset E' MS = true /\ ssubset E E' = true /\ E <> E' /\ andl (map f2p QEt).
Proof.
  unfold not.
  intros.
  destruct H.
  generalize H.
  unfold MS.
  intros [A [B [C D]]].
  assert (H1: x0 = ["INIT"%string; "FALL"%string; "BOUNCE"%string]). { admit. }
  rewrite <- H1 in C. clear H.
  assert (H: x0 = x0). { trivial. }
  apply C in H. case H.
  Admitted.

Theorem semantics_iii_s2_1_ip2 :
  let E := ["INIT"%string; "FALL"%string; "BOUNCE"%string] in
  let x := y in let x' := y' in let x'' := y'' in
  let prevx := prevy in let prevx' := prevy' in let prevx'' := prevy'' in
  let QEt := [$ x''(t) = Some(-10);
              prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t));
              $cont x t; $cont x' t; $cont x'' t] in
  0 < t < sqrt(2) -> ~ exists E', ssubset E' MS = true /\ ssubset E E' = true /\ E <> E' /\ andl (map f2p QEt).
Proof.
  unfold not.
  intros.
  destruct H0. destruct H0. destruct H1. destruct H2.
  assert (H4: x0 = ["INIT"%string; "FALL"%string; "BOUNCE"%string]). { admit. }
  rewrite <- H4 in H2.
  assert (H5: x0 = x0). { trivial. }
  apply H2 in H5. case H5.
  Admitted.

Theorem semantics_iii_s2_1_pp3 :
  let E := ["INIT"%string; "BOUNCE"%string] in
  let t := sqrt 2 in
  let x := y in let x' := y' in let x'' := y'' in
  let prevx := prevy in let prevx' := prevy' in let prevx'' := prevy'' in
  let QE't := [$ x''(t) = Some(-10);
              prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t)); $ x'(t) = mul (Some(-1)) (prevx'(t));
              $cont x t; $rightCont x' t] in
  ~ exists E', ssubset E' MS = true /\ ssubset E E' = true /\ E <> E' /\ andl (map f2p QE't).
Proof.
  unfold not.
  intros.
  destruct H. destruct H. destruct H0. destruct H1.
  assert (H3: x0 = ["INIT"%string; "FALL"%string; "BOUNCE"%string]). { admit. }
  unfold andl, map, f2p in H2.
  simpl in H2.
  repeat destruct H2.
  assert (H9: y'' (sqrt 2) = None). { admit. }
  rewrite H9 in H8.
  inversion H8.
  Admitted.

Theorem semantics_iii_s2_1_ip4 :
  let E := ["INIT"%string; "FALL"%string; "BOUNCE"%string] in
  let x := y in let x' := y' in let x'' := y'' in
  let prevx := prevy in let prevx' := prevy' in let prevx'' := prevy'' in
  let QEt := [$ x''(t) = Some(-10);
              prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t));
              $cont x t; $cont x' t; $cont x'' t] in
  sqrt(2) < t < 3*sqrt(2) -> ~ exists E', ssubset E' MS = true /\ ssubset E E' = true /\ E <> E' /\ andl (map f2p QEt).
Proof.
  unfold not.
  intros.
  destruct H0. destruct H0. destruct H1. destruct H2.
  unfold MS in H0.
  assert (H4: x0 = ["INIT"%string; "FALL"%string; "BOUNCE"%string]). { admit. }
  rewrite <- H4 in H2.
  assert (H5: x0 = x0). { trivial. }
  apply H2 in H5. case H5.
  Admitted.

(* z : rival trajectory *)
(* set z to x, for "andl (map f2p QEt)" *)
Theorem semantics_iii_s2_2_pp1:
  let E := ["INIT"%string; "FALL"%string; "BOUNCE"%string] in
  let t := 0 in
  let QEt := fun (x x' x'' prevx prevx' prevx'' : partial) =>
              [$ x(t) = Some 10; $ x'(t) = Some 0;
              []$ x''(t) = Some(-10); $ x''(t) = Some(-10);
              []prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t)); prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t));
              $rightCont x t; $rightCont x' t; $rightCont x'' t] in
  ~ exists (z z' z'' prevz prevz' prevz'' : partial), exists E',
  let x := z in let x' := z' in let x'' := z'' in
  let prevx := prevz in let prevx' := prevz' in let prevx'' := prevz'' in
    ssubset E' MS = true
    /\ (forall t', t' < t /\ z(t') = y(t') /\ z'(t') = y'(t') /\ z''(t') = y''(t'))
    /\ (~ sim y z t \/ ~ sim y' z' t \/ ~ sim y'' z'' t)
    /\ ssubset E E' = true
    /\ andl (map f2p (QEt x x' x'' prevx prevx' prevx'')).
Proof.
  unfold not.
  intros. destruct H. destruct H. destruct H. destruct H. destruct H. destruct H. destruct H.
  destruct H. destruct H0. destruct H1. destruct H2.
  case H1.
  - intros.
    assert (H5: ~ rightCont x0 0). { admit. }
    unfold not in H5.
    unfold andl, map, f2p in H3. simpl in H3.
    destruct H3. destruct H3. destruct H3.
    apply H5 in H8.
    case H8.
  - intros. case H4.
    Admitted.

Theorem semantics_iii_s2_2_ip2:
  let E := ["INIT"%string; "FALL"%string; "BOUNCE"%string] in
  let QEt := fun (x x' x'' prevx prevx' prevx'' : partial) =>
              [$ x''(t) = Some(-10); prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t));
               $cont x t; $cont x' t; $cont x'' t] in
  0 < t < sqrt(2) -> ~ exists (z z' z'' prevz prevz' prevz'' : partial), exists E',
  let x := z in let x' := z' in let x'' := z'' in
  let prevx := prevz in let prevx' := prevz' in let prevx'' := prevz'' in
    ssubset E' MS = true
    /\ (forall t', t' < t /\ z(t') = y(t') /\ z'(t') = y'(t') /\ z''(t') = y''(t'))
    /\ (~ sim y z t \/ ~ sim y' z' t \/ ~ sim y'' z'' t)
    /\ ssubset E E' = true
    /\ andl (map f2p (QEt x x' x'' prevx prevx' prevx'')).
Proof.
  unfold not.
  intros.
  destruct H. destruct H0. destruct H0. destruct H0. destruct H0. destruct H0. destruct H0. destruct H0.
  destruct H0. destruct H2. destruct H3. destruct H4.
  clear H0. clear H4.
  unfold andl, map, f2p in H5. simpl in H5.
  destruct H5. destruct H0. destruct H0.
  case H3.
  - intros.
    assert (H8: ~ leftCont x0 t \/ ~ leftCont x0 t). { admit. }
    case H8.
    + intros.
      unfold cont in H6.
      destruct H6.
      unfold not in H9.
      apply H9 in H6.
      case H6.
    + Admitted.

Theorem semantics_iii_s2_2_pp3_case1:
  let E := ["INIT"%string; "BOUNCE"%string] in
  let t := sqrt 2 in
  let QEt := fun (x x' x'' prevx prevx' prevx'' : partial) =>
              [prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t)); $ x'(t) = mul (Some(-1)) (prevx'(t));
               $cont x t; $rightCont x' t] in
  ~ exists (z z' z'' prevz prevz' prevz'' : partial), exists E',
  let x := z in let x' := z' in let x'' := z'' in
  let prevx := prevz in let prevx' := prevz' in let prevx'' := prevz'' in
  let QE't := QEt in E = E' /\
    ssubset E' MS = true
    /\ (forall t', t' < t /\ z(t') = y(t') /\ z'(t') = y'(t') /\ z''(t') = y''(t'))
    /\ (~ sim y z t \/ ~ sim y' z' t \/ ~ sim y'' z'' t)
    /\ ssubset E E' = true
    /\ andl (map f2p (QE't x x' x'' prevx prevx' prevx'')).
Proof.
  unfold not.
  intros.
  destruct H. destruct H. destruct H. destruct H. destruct H. destruct H. destruct H.
  destruct H. destruct H0. destruct H1. destruct H2. destruct H3.
  clear H0. clear H3.
  unfold andl in H4. simpl in H4.
  destruct H4. repeat destruct H0.
  destruct H2.
  - clear H. clear H1. clear H5. clear H6. clear H3.
    assert (G: cont y (sqrt 2)). { admit. } unfold cont in G. destruct G.
    unfold sim in H0.
    unfold cont in H4. destruct H4.
    destruct H0.
    split.
    + split.
      * intros. trivial.
      * intros. trivial.
    + split.
      * intros. trivial.
      * intros. trivial.
  - destruct H0.
    + clear H. clear H1. clear H6. clear H4.
      assert (H: ~ leftCont x1 (sqrt 2)). { admit. } (* by H5 *)
      assert (G: rightCont y' (sqrt 2) /\ ~ leftCont y' (sqrt 2)). { admit. }
      unfold sim in H0. destruct H0.
      destruct G.
      split.
      * split.
        -- intros.
           unfold not in H1.
           apply H1 in H2.
           case H2.
        -- intros.
           unfold not in H.
           apply H in H2.
           case H2.
      * split.
        -- intros. trivial.
        -- intros. trivial.
    + clear H. clear H1. clear H6. clear H4. clear H3.
      assert (H: ~ leftCont x2 (sqrt 2) /\ ~ rightCont x2 (sqrt 2)). { admit. } (* by H0 and def of derivative *)
      assert (G: ~ leftCont y'' (sqrt 2) /\ ~ rightCont y'' (sqrt 2)). { admit. }
      unfold not in H. destruct H.
      unfold not in G. destruct G.
      unfold sim in H0. destruct H0.
      split.
      * split.
        -- intros.
           apply H2 in H0.
           case H0.
        -- intros.
           apply H in H0.
           case H0.
      * split.
        -- intros.
           apply H3 in H0.
           case H0.
        -- intros.
           apply H1 in H0.
           case H0.
  Admitted.

Theorem semantics_iii_s2_2_pp3_case2:
  let E := ["INIT"%string; "BOUNCE"%string] in
  let t := sqrt 2 in
  let QEt := fun (x x' x'' prevx prevx' prevx'' : partial) =>
              [prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t)); $ x'(t) = mul (Some(-1)) (prevx'(t));
               $cont x t; $rightCont x' t] in
  ~ exists (z z' z'' prevz prevz' prevz'' : partial), exists E',
  let x := z in let x' := z' in let x'' := z'' in
  let prevx := prevz in let prevx' := prevz' in let prevx'' := prevz'' in
  let QE't := fun (x x' x'' prevx prevx' prevx'' : partial) =>
              [$ x''(t) = Some(-10);
               prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t)); $ x'(t) = mul (Some(-1)) (prevx'(t));
               $cont x t; $rightCont x' t] in
  E' = ["INIT"%string; "FALL"%string; "BOUNCE"%string] /\
    ssubset E' MS = true
    /\ (forall t', t' < t /\ z(t') = y(t') /\ z'(t') = y'(t') /\ z''(t') = y''(t'))
    /\ (~ sim y z t \/ ~ sim y' z' t \/ ~ sim y'' z'' t)
    /\ ssubset E E' = true
    /\ andl (map f2p (QE't x x' x'' prevx prevx' prevx'')).
Proof.
  unfold not.
  intros.
  destruct H. destruct H. destruct H. destruct H. destruct H. destruct H. destruct H.
  destruct H. destruct H0. destruct H1. destruct H2. destruct H3.
  clear H0. clear H2. clear H3. clear H. clear H1.
  unfold andl in H4. simpl in H4.
  destruct H4. repeat destruct H.
  clear H3. clear H1. clear H0.
  assert (H: x2 (sqrt 2) = None). { admit. } (* by H2 and def of derivative *)
  rewrite H in H4.
  discriminate.
  Admitted.

Theorem semantics_iii_s2_2_ip4:
  let E := ["INIT"%string; "FALL"%string; "BOUNCE"%string] in
  let QEt := fun (x x' x'' prevx prevx' prevx'' : partial) =>
              [$ x''(t) = Some(-10); prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t));
               $cont x t; $cont x' t; $cont x'' t] in
  sqrt(2) < t < 3*sqrt(2) -> ~ exists (z z' z'' prevz prevz' prevz'' : partial), exists E',
  let x := z in let x' := z' in let x'' := z'' in
  let prevx := prevz in let prevx' := prevz' in let prevx'' := prevz'' in
    ssubset E' MS = true
    /\ (forall t', t' < t /\ z(t') = y(t') /\ z'(t') = y'(t') /\ z''(t') = y''(t'))
    /\ (~ sim y z t \/ ~ sim y' z' t \/ ~ sim y'' z'' t)
    /\ ssubset E E' = true
    /\ andl (map f2p (QEt x x' x'' prevx prevx' prevx'')).
Proof.
  intros.
  unfold not.
  intros.
  destruct H0. destruct H0. destruct H0. destruct H0. destruct H0. destruct H0. destruct H0.
  destruct H0. destruct H1. destruct H2. destruct H3.
  clear H0. clear H3.
  simpl in H4.
  unfold andl in H4. simpl in H4.
  destruct H4. destruct H0. destruct H0.
  case H2.
  - intros.
    assert (H8: ~ leftCont x0 t \/ ~ leftCont x0 t). { admit. }
    case H8.
    + intros.
      unfold cont in H5.
      destruct H5.
      unfold not in H7.
      apply H7 in H5.
      case H5.
    + Admitted.

Theorem semantics_iii_s3_pp1:
  let E := ["INIT"%string; "FALL"%string; "BOUNCE"%string] in
  let t := 0 in
  let x := y in let x' := y' in let x'' := y'' in
  let prevx := prevy in let prevx' := prevy' in let prevx'' := prevy'' in
  let QEt := [$ x(t) = Some 10; $ x'(t) = Some 0;
              []$ x''(t) = Some(-10); $ x''(t) = Some(-10);
              []prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t)); prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t));
              $rightCont x t; $rightCont x' t; $rightCont x'' t] in
  prevx(t) = Some 0 -> set_mem Feq_dec ($ x'(t) = mul (Some(-1)) (prevx'(t))) QEt = true.
Proof.
  simpl.
  intros.
  unfold prevy, update_in, update_pt, Rltb in H.
  destruct (Rlt_dec 0 0) in H.
  - apply Rlt_irrefl in r. case r.
  - simpl in H.
    destruct (Reqb (sqrt 2) 0) eqn:E1.
    + assert (H2: Reqb (sqrt 2) 0 = true -> False). { admit. }
      apply H2 in E1. case E1.
    + destruct (Rlt_dec (sqrt 2) 0).
      * assert (H2: sqrt 2 < 0 -> False). { admit. }
        apply H2 in r. case r.
      * simpl in H.
        inversion H.
  Admitted.

Theorem semantics_iii_s3_ip2:
  let E := ["INIT"%string; "FALL"%string; "BOUNCE"%string] in
  let x := y in let x' := y' in let x'' := y'' in
  let prevx := prevy in let prevx' := prevy' in let prevx'' := prevy'' in
  let QEt := [$ x''(t) = Some(-10);
              prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t));
              $cont x t; $cont x' t; $cont x'' t] in
  0 < t < sqrt(2) -> prevx(t) = Some 0 -> set_mem Feq_dec ($ x'(t) = mul (Some(-1)) (prevx'(t))) QEt = true.
Proof.
  intros.
  assert (H1: prevx0 t = Some 0 -> False). { admit. }
  apply H1 in H0. case H0.
  Admitted.

Theorem semantics_iii_s3_pp3:
  let E := ["INIT"%string; "BOUNCE"%string] in
  let t := sqrt 2 in
  let x := y in let x' := y' in let x'' := y'' in
  let prevx := prevy in let prevx' := prevy' in let prevx'' := prevy'' in
  let QEt := [prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t)); $ x'(t) = mul (Some(-1)) (prevx'(t));
              $cont x t; $rightCont x' t] in
  prevx(t) = Some 0 -> set_mem Feq_dec ($ x'(t) = mul (Some(-1)) (prevx'(t))) QEt = true.
Proof.
  intros.
  unfold QEt. simpl.
  destruct (Feq_dec ($ x'0 t0 = mul (Some (-1)) (prevx'0 t0)) (prevx0 t0 = Some 0 ~> $ x'0 t0 = mul (Some (-1)) (prevx'0 t0))).
  - trivial.
  - destruct (Feq_dec ($ x'0 t0 = mul (Some (-1)) (prevx'0 t0)) ($ x'0 t0 = mul (Some (-1)) (prevx'0 t0))).
    + trivial.
    + contradiction.
  Qed.

Theorem semantics_iii_s3_ip4:
  let E := ["INIT"%string; "FALL"%string; "BOUNCE"%string] in
  let x := y in let x' := y' in let x'' := y'' in
  let prevx := prevy in let prevx' := prevy' in let prevx'' := prevy'' in
  let QEt := [$ x''(t) = Some(-10);
              prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t));
              $cont x t; $cont x' t; $cont x'' t] in
  sqrt(2) < t < 3*sqrt(2) -> prevx(t) = Some 0 -> set_mem Feq_dec ($ x'(t) = mul (Some(-1)) (prevx'(t))) QEt = true.
Proof.
  intros.
  assert (H1: prevx0 t = Some 0 -> False). { admit. }
  apply H1 in H0. case H0.
  Admitted.

Theorem semantics_iii_s4_pp1:
  let E := ["INIT"%string; "FALL"%string; "BOUNCE"%string] in
  let t := 0 in
  let x := y in let x' := y' in let x'' := y'' in
  let prevx := prevy in let prevx' := prevy' in let prevx'' := prevy'' in
  let QEt := [$ x(t) = Some 10; $ x'(t) = Some 0;
              []$ x''(t) = Some(-10); $ x''(t) = Some(-10);
              []prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t)); prevx(t) = Some 0 ~> $ x'(t) = mul (Some(-1)) (prevx'(t));
              $rightCont x t; $rightCont x' t; $rightCont x'' t] in
  leftCont x t -> set_mem Feq_dec ($leftCont x t) QEt = true
  /\ leftCont x' t -> set_mem Feq_dec ($leftCont x' t) QEt = true
  /\ leftCont x'' t -> set_mem Feq_dec ($leftCont x'' t) QEt = true
  /\ rightCont x t -> set_mem Feq_dec ($rightCont x t) QEt = true
  /\ rightCont x' t -> set_mem Feq_dec ($rightCont x' t) QEt = true
  /\ rightCont x'' t -> set_mem Feq_dec ($rightCont x'' t) QEt = true.
Proof.
  Admitted.


Require Import UFO.Lang.BindingsFacts.
Require Import UFO.Rel.Definitions.
Require Import UFO.Rel.Monotone.
Require Import UFO.Rel.Compat_map.
Require Import UFO.Util.Subset.
Require Import UFO.Util.Postfix.
Set Implicit Arguments.

Section section_compat_md_lv.

Context (EV LV V : Set).
Context (Ξ : XEnv EV LV).
Context (Γ : V → ty ∅ EV LV ∅).
Context (σ : ms ∅ EV (inc LV) ∅) (ℓ : lbl LV ∅).
Context (m₁ m₂ : md EV (inc LV) V ∅).

Hint Resolve subset_trans.

Lemma compat_md_lv n :
n ⊨ ⟦ (LV_shift_XEnv Ξ) (LV_shift_ty ∘ Γ) ⊢ m₁ ≼ˡᵒᵍₘ m₂ : σ ^ (LV_shift_lbl ℓ) ⟧ →
n ⊨ ⟦ Ξ Γ ⊢ (md_lv m₁) ≼ˡᵒᵍₘ (md_lv m₂) : (ms_lv σ) ^ ℓ ⟧.
Proof.
intro Hm.
iintro ξ₁ ; iintro ξ₂ ;
iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ;
iintro γ₁ ; iintro γ₂ ;
iintro Hξ ; iintro Hδ ; iintro Hρ ; iintro Hγ.
simpl 𝓜_Fun.
repeat ieexists ; repeat isplit ; [ crush | ].
iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂'.
iintro X₁ ; iintro X₂ ; iintro φ ; iintro HX₁X₂.
ispecialize Hm ξ₁' ; ispecialize Hm ξ₂'.
ispecialize Hm δ₁ ; ispecialize Hm δ₂ ; ispecialize Hm δ.
ispecialize Hm (env_ext ρ₁ (lbl_id (lid_f X₁))) ;
ispecialize Hm (env_ext ρ₂ (lbl_id (lid_f X₂))) ;
ispecialize Hm (env_ext ρ φ).
iespecialize Hm.
ispecialize Hm.
{ iintro_prop ; ielim_prop Hξ ; unfold 𝜩 ; rewrite LV_map_XEnv_dom.
  eapply 𝜩_monotone ; eauto.
}
ispecialize Hm.
{ eapply δ_is_closed_monotone ; eauto. }
ispecialize Hm.
{ iintro_prop ; intros α X ; destruct α as [ | α ] ; simpl.
  + ielim_prop HX₁X₂ ; destruct HX₁X₂.
    split ; let H := fresh in (intro H ; inversion H) ; subst ; auto.
  + apply postfix_is_subset in Hξ₁' ; apply postfix_is_subset in Hξ₂'.
    ielim_prop Hρ ; specialize (Hρ α X) ; crush.
}
ispecialize Hm.
{ iintro x ; ispecialize Hγ x.
  apply 𝓥_monotone with (ξ₁ := ξ₁) (ξ₂ := ξ₂) ; [auto|auto| ].
  erewrite <- I_iff_elim_M ; [ exact Hγ | apply LV_map_𝓥 ].
  - crush.
  - crush.
  - repeat iintro ; apply auto_contr_id.
}

clear - Hm.
repeat erewrite <- LV_V_bind_md, <- EV_LV_bind_md, LV_bind_bind_md ; try apply Hm.
{ intro α ; destruct α ; simpl ; [ crush | ].
  erewrite LV_bind_map_lbl, LV_map_lbl_id, LV_bind_lbl_id ; reflexivity.
}
{ intro ; erewrite LV_bind_map_eff, LV_map_eff_id, LV_bind_eff_id ; reflexivity. }
{ intro ; erewrite LV_bind_map_val, LV_map_val_id, LV_bind_val_id ; reflexivity. }
{ intro α ; destruct α ; simpl ; [ crush | ].
  erewrite LV_bind_map_lbl, LV_map_lbl_id, LV_bind_lbl_id ; reflexivity.
}
{ intro ; erewrite LV_bind_map_eff, LV_map_eff_id, LV_bind_eff_id ; reflexivity. }
{ intro ; erewrite LV_bind_map_val, LV_map_val_id, LV_bind_val_id ; reflexivity. }
Qed.

End section_compat_md_lv.


From BSC Require Export Lang.
Export Lang.

Definition heap_typing (Σ : store_ty) (σ : store) : Prop :=
  length Σ = length σ /\
  (forall l, l < length σ ->
             has_type Σ empty (store_lookup σ l) (store_ty_lookup Σ l)).

Reserved Notation "Σ '⊆' Σ'" (at level 40).
Inductive extends : store_ty -> store_ty -> Prop :=
| extends_nil : forall Σ', nil ⊆ Σ'
| extends_cons : forall Σ Σ' T, Σ ⊆ Σ' -> (T::Σ) ⊆ (T::Σ')
where "Σ '⊆' Σ'" := (extends Σ Σ').

Lemma extends_lookup : forall l Σ Σ',
    l < length Σ ->
    Σ ⊆ Σ' ->
    store_ty_lookup Σ l = store_ty_lookup Σ' l.
Proof.
  intros l Σ.
  generalize dependent l.
  induction Σ.
  - intros.
    inversion H.
  - intros.
    destruct Σ'.
    + inversion H0.
    + inversion H0; subst.
      destruct l.
      * unfold store_ty_lookup; auto.
      * simpl in H.
        rewrite <- Nat.succ_lt_mono in H.
        eapply IHΣ in H; eauto.
Qed.

Lemma length_extends : forall l Σ Σ',
    l < length Σ ->
    Σ ⊆ Σ' ->
    l < length Σ'.
Proof.
  intros.
  generalize dependent l.
  induction H0; intros.
  - inversion H.
  - simpl.
    destruct Σ'.
    + inversion H0; subst; auto.
    + simpl.
      destruct l.
      * apply Nat.lt_0_succ.
      * simpl in H.
        rewrite <- Nat.succ_lt_mono in H.
        apply IHextends in H.
        rewrite <- Nat.succ_lt_mono.
        auto.
Qed.

Lemma extends_app : forall Σ Σ',
    Σ ⊆ (Σ ++ Σ').
Proof.
  induction Σ.
  - intros.
    simpl.
    constructor.
  - intros.
    simpl.
    apply extends_cons.
    apply IHΣ.
Qed.

Lemma extends_refl : forall Σ, Σ ⊆ Σ.
Proof.
  induction Σ; constructor; auto.
Qed.

Lemma store_lookup_shift : forall Σ l n m,
    l < length Σ ->
    tshift n m (store_ty_lookup Σ l) = store_ty_lookup (map (tshift n m) Σ) l.
Proof.
  induction Σ.
  - intros.
    inversion H.
  - intros.
    simpl.
    destruct l.
    + unfold store_ty_lookup.
      auto.
    + unfold store_ty_lookup.
      simpl.
      simpl in H.
      rewrite <- Nat.succ_lt_mono in H.
      eapply IHΣ in H.
      unfold store_ty_lookup in H.
      apply H.
Qed.

Lemma store_lookup_subst : forall Σ l n T,
    l < length Σ ->
    tsubst n T (store_ty_lookup Σ l) = store_ty_lookup (map (tsubst n T) Σ) l.
Proof.
  induction Σ.
  - intros.
    inversion H.
  - intros.
    simpl.
    destruct l.
    + unfold store_ty_lookup; auto.
    + unfold store_ty_lookup; simpl.
      simpl in H.
      rewrite <- Nat.succ_lt_mono in H.
      eapply IHΣ in H.
      unfold store_ty_lookup in H.
      apply H.
Qed.

Lemma store_extends_tshift : forall Σ Σ' n m,
    Σ ⊆ Σ' -> (map (tshift n m) Σ) ⊆ (map (tshift n m) Σ').
Proof.
  intros.
  induction H.
  - simpl.
    constructor.
  - simpl.
    constructor.
    apply IHextends.
Qed.

Lemma store_weakening : forall Σ Σ' Γ e T,
    Σ ⊆ Σ' ->
    has_type Σ Γ e T ->
    has_type Σ' Γ e T.
Proof.
  intros.
  generalize dependent Σ'.
  induction H0; intros; eauto using store_extends_tshift.
  rewrite extends_lookup with (Σ' := Σ'); eauto.
  apply T_Loc.
  eapply length_extends; eauto.
Qed.

Lemma extends_shift : forall Σ Σ',
    Σ ⊆ Σ' -> (map (tshift 1 0) Σ) ⊆ (map (tshift 1 0) Σ').
Proof.
  induction Σ.
  - intros.
    simpl.
    constructor.
  - intros.
    simpl.
    inversion H.
    subst.
    simpl.
    constructor.
    apply IHΣ.
    apply H3.
Qed.


Require Export Separate.

Module Binarize.

  Import Base Definitions Symbols Derivation Inlining.

  Section Binarize.

    Context {Tt Vt: Type}.

    Context {Tt_eqdec: eq_dec Tt}.
    Context {Vt_eqdec: eq_dec Vt}.

    Context {TtToNat: Tt -> nat}.
    Context {VtToNat: Vt -> nat}.
    Context {NatToTt: nat -> Tt }.
    Context {NatToVt: nat -> Vt}.

    Hypothesis Id1: forall x, TtToNat (NatToTt x) = x.
    Hypothesis Id2: forall x, NatToTt (TtToNat x) = x.
    Hypothesis Id3: forall x, VtToNat (NatToVt x) = x.
    Hypothesis Id4: forall x, NatToVt (VtToNat x) = x.

    Fixpoint step G G' :=
      match G' with
          [] => []
        | R A [] :: Gr => R A [] :: step G Gr
        | R A [s0] :: Gr => R A [s0] :: step G Gr
        | R A [s0 ; s1] :: Gr => R A [s0 ; s1] :: step G Gr
        | R A (s0 :: ur) :: Gr =>
          let (B, H) := @pickFresh _ _ TtToNat VtToNat NatToVt Id3 G
          in R A [s0 ; Vs B] :: @R Tt Vt B ur :: Gr
      end.

    Definition step' G := step G G.

    Fixpoint count_bin (G: @grammar Tt Vt) :=
      match G with
          [] => 0
        | R A u :: Gr => if decision ((|u|) <= 2) then count_bin Gr else |u| + count_bin Gr
      end.

    Definition bin G := it step' (count_bin G) G.

    Definition binary G := forall A u, @R Tt Vt A u el G -> (|u|) <= 2.

    (** * Binarization yields binary gramar *)

    Lemma count_decr G G' :
      step G' G <> G -> count_bin G > count_bin (step G' G).
    Proof.
      intros H.
      induction G as [| [A u] G IHG] ; simpl in * ; [tauto | ].
      destruct u as [| s0 [| s1 [| s2 u]]] ; try now (simpl ; apply IHG ; intros H0 ; apply H ; f_equal).
      simpl.  decide (S (S (| u |)) <= 2) as [D | D] ; omega.
    Qed.

    Lemma fp_bin G :
      FP step' (bin G).
    Proof.
      apply it_fp. intros n.
      remember (it step' n G) as G'.
      decide (step' G' = G') as [D | D].
      - left. auto.
      - right. simpl. rewrite <- HeqG'.
        apply count_decr in D. unfold step'. omega.
    Qed.

    Lemma fp_binary G :
      FP step' G -> binary G.
    Proof.
      intros Ss A u Ru.
      unfold FP, step' in Ss.
      remember G as G'.
      do 2 rewrite HeqG' in Ss at 2.
      rewrite HeqG' in Ru. clear HeqG'.
      induction G as [| [B v] Gr IHGr] ; simpl in * ; [tauto |].
      destruct Ru as [Ru | Ru].
      - inv Ru. destruct u as [| s0 [| s1 [| s2 u]]] ; simpl ; auto. inv Ss.
      - destruct v as [| s0 [| s1 [| s2 v]]] ; try now (simpl in Ss ; inversion Ss ; apply IHGr ; auto).
    Qed.

    Lemma bin_binary G :
      binary (bin G).
    Proof.
      apply fp_binary, fp_bin.
    Qed.

    (** * Binarization preserves languages *)

    Lemma step_or G G' :
      step G' G = G \/ exists A Gr B u s, G === R A (s :: u) :: Gr /\ step G' G === R A [s ; Vs B] :: R B u :: Gr /\ ~ Vs B el symbs G'.
    Proof.
      induction G as [| [A u] G IHG].
      - simpl. now left.
      - destruct u as [| s0 [| s1 [| s2 u]]] ; unfold step.
        + destruct IHG as [H | [A' [Gr [B' [u' [s [H0 [H1 H2]]]]]]]] ; try now (left ; f_equal).
          right. exists A', (R A [] :: Gr), B', u', s. repeat split ; try rewrite H0 ; auto using Base.equi_swap ; rewrite H1 ; auto 7 using Base.equi_swap.
        + simpl ; destruct IHG as [H | [A' [Gr [B' [u' [s [H0 [H1 H2]]]]]]]] ; try now (left ; f_equal).
          right. exists A', (R A [s0] :: Gr), B', u', s. repeat split ; try rewrite H0 ; auto using Base.equi_swap ; rewrite H1 ; auto 7 using Base.equi_swap.
        + simpl ; destruct IHG as [H | [A' [Gr [B' [u' [s [H0 [H1 H2]]]]]]]] ; try now (left ; f_equal).
          right. exists A', (R A [s0 ; s1] :: Gr), B', u', s. repeat split ; try rewrite H0 ; auto using Base.equi_swap ; rewrite H1 ; auto 7 using Base.equi_swap.
        + destruct (@pickFresh _ _ _ _ _ _ G') as [B N].
          right. exists A, G, B, (s1 :: s2 :: u), s0. repeat split ; auto.
          intros H. specialize (N (Vs B) H). unfold sless' in N. omega.
    Qed.

    Lemma step_der_equiv G A u :
      terminal u -> (Vs A) el dom G -> (der G A u <-> der (step G G) A u).
    Proof.
      intros T Do.
      destruct (step_or G G) as [Ss | Ss].
      - rewrite <- Ss at 1. split ; auto.
      - destruct Ss as [A' [Gr [B [v [s [H0 [H1 H2]]]]]]].
        assert (RL : substG (R A' [s; Vs B] :: Gr) (Vs B) v = R A' (s :: v) :: Gr). {
          simpl. decide (s = Vs B).
          + exfalso. rewrite e in H0.
            apply H2. apply symbs_inv. exists A', (Vs B :: v). rewrite H0. split ; auto.
          + decide (@Vs Tt Vt B = Vs B) ; try tauto. rewrite app_nil_r. f_equal.
            apply substG_skip. intros H. apply H2.
            apply symbs_subset with (G0 := Gr) ; auto. rewrite H0. auto. }
                                                                                rewrite der_equiv_G with (G1 := step G G) (G2 := R B v :: R A' [s; Vs B] :: Gr) by (rewrite Base.equi_swap ; auto).
        rewrite der_equiv_G with (G2 := R A' (s :: v) :: Gr) ; auto.
        rewrite <- RL. symmetry. eapply der_substG_G_equiv; eauto.
        + intros H. apply symbs_dom in Do. inv H. eauto.
        + simpl. intros [H | H].
          { inv H. apply H2. apply symbs_inv. exists B, (s :: v). rewrite H0. split ; auto. }
          { apply symbs_dom in H. apply H2.
            apply symbs_subset with (G0 := Gr) ; auto. rewrite H0. auto. }
        + intros H. apply H2. apply symbs_inv. exists A', (s :: v). rewrite H0. split ; auto.
        + intros H. destruct (T (Vs B) H) as [t T']. inv T'.
    Qed.

    Lemma step_dom G G' :
      dom G <<= dom (step G' G).
    Proof.
      revert G'.
      induction G as [| [A u] G IHG] ; intros G' ; try destruct u as [| s0 [| s1 [| s2 u]]] ; simpl ; auto.
    Qed.

    Lemma bin_der_equiv G A u :
      terminal u -> (Vs A) el dom G -> (der G A u <-> der (bin G) A u).
    Proof.
      unfold bin. remember (count_bin G) as n. clear Heqn.
      intros T. revert G.
      induction n as [| n IHn] ; intros G Do ; simpl.
      - split ; auto.
      - rewrite (IHn G Do).
        apply step_der_equiv ; auto.
        apply it_ind ; auto.
        intros r H0. now apply step_dom.
    Qed.

    Lemma bin_language G A u :
      Vs A el dom G -> (language G A u <-> language (bin G) A u).
    Proof.
      intros D.
      split ; intros [L0 L1] ; split ; auto ; [rewrite <- bin_der_equiv | rewrite bin_der_equiv] ; auto.
    Qed.

  End Binarize.

End Binarize.


(**
  [TypeTheory.Initiality.Syntax]

  Part of the [Initiality] package for the [UniMath.TypeTheory] library

  Goal: as elementary as possible a proof of initiality, for a specific fairly straightforward type theory, but written with an eye to extensibility.

  This file constructs raw syntax, along the main constructions on it (variable-renaming, substitution).

  It aims to give as streamlined as possible a path to the definition of judgements/derivations, so basic lemmas about substitution etc are deferred to [Initiality.SyntaxLemmas].
*)

Require Import UniMath.MoreFoundations.All.
Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.

Section deBruijn.
  (** We first set up the machinery for handling variables, represented by de Bruijn indices. *)

  Definition dB_empty : UU := empty.

  Inductive dB_plusone (X : UU) : UU := dB_top_internal | dB_next_internal (x:X).

  Global Arguments dB_top_internal {_}.
  Global Arguments dB_next_internal {_} _.

  (** [dB_vars n]: the set of variables in scope over a context of length [n].

  As far as possible, this should be interfaced with just through [dB_top], [dB_next], and [dB_rect] below. *)
  Fixpoint dB_vars (n : nat) : UU
    := match n with
       | O => dB_empty
       | S n => dB_plusone (dB_vars n)
       end.

  Global Arguments dB_vars !_ .

  Coercion dB_vars : nat >-> UU.

  Definition dB_top {n} : dB_vars (S n)
    := dB_top_internal.

  Definition dB_next {n} : dB_vars n -> dB_vars (S n)
    := dB_next_internal.

(** We should always interface with [dB_vars] just through [dB_top], [dB_next], and the following two recursors. *)
  Definition dB_0_rect
      (P : dB_vars 0 -> Type)
    : forall i, P i.
  Proof.
    intros [].
  Defined.

  Definition dB_Sn_rect {n}
      (P : dB_vars (S n) -> Type)
      (p_top : P dB_top)
      (p_next : forall i, P (dB_next i))
    : forall i, P i.
  Proof.
    exact (dB_plusone_rect _ P p_top p_next).
  Defined.

  Arguments dB_Sn_rect : simpl nomatch.

  (** We check that [dB_Sn_rect] computes appropriately, concluding with [Abort] since we don’t need to save the results. *)
  Definition dB_Sn_rect_comp1 {n}
      (P : dB_vars (S n) -> Type)
      (p_top : P dB_top)
      (p_next : forall i, P (dB_next i))
    : dB_Sn_rect P p_top p_next dB_top = p_top.
  Proof.
    intros. apply idpath.
  Abort. (* Proof a test only, not for saving. *)

  Definition dB_Sn_rect_comp2 {n}
      (P : dB_vars (S n) -> Type)
      (p_top : P dB_top)
      (p_next : forall i, P (dB_next i))
    : forall i, dB_Sn_rect P p_top p_next (dB_next i) = p_next i.
  Proof.
    intros. apply idpath.
  Abort. (* Proof a test only, not for saving. *)

  (** Further auxiliary constructions *)
  Definition fmap_dB_S {m n} (f : dB_vars m -> dB_vars n)
    : dB_vars (S m) -> dB_vars (S n).
  Proof.
    apply dB_Sn_rect.
    - apply dB_top.
    - intros i. apply dB_next, f, i.
  Defined.

End deBruijn.

Section Expressions.

  Inductive ty_expr : nat -> UU
  :=
    | U_expr {n} : ty_expr n
    | El_expr {n} : tm_expr n -> ty_expr n
    | Pi_expr {n} : ty_expr n -> ty_expr (S n) -> ty_expr n
  with tm_expr : nat -> UU
  :=
    | var_expr {n} : dB_vars n -> tm_expr n
    | lam_expr {n} : ty_expr n -> ty_expr (S n) -> tm_expr (S n)
                      -> tm_expr n
    | app_expr {n} : ty_expr n -> ty_expr (S n)
                      -> tm_expr n -> tm_expr n
                      -> tm_expr n.
End Expressions.

Section Renaming.
(** Renaming variables in raw expressions.  This can be seen as a special case of substitution, or as the functoriality of expressions in the variables of the context.  Functoriality lemmas are given in [Initiality.SyntaxLemmas]. *)

  Fixpoint
    rename_ty {m n : nat} (f : m -> n) (e : ty_expr m) : ty_expr n
  with
    rename_tm {m n : nat} (f : m -> n) (e : tm_expr m) : tm_expr n.
  Proof.
    - (* rename_ty *)
      destruct e as [ m | m a | m A B ].
      + (* case [U_expr] *)
        exact U_expr.
      + (* case [El_expr] *)
        exact (El_expr (rename_tm _ _ f a)).
      + (* case [Pi_expr] *)
        refine (Pi_expr (rename_ty _ _ f A) _).
        refine (rename_ty _ _ (fmap_dB_S f) B).
    - (* rename_tm *)
      destruct e as [ m i | m A B b | m A B g a ].
      + (* case [var_expr] *)
        apply var_expr, f, i.
      + (* case [lam_expr] *)
        refine (lam_expr _ _ _).
        * exact (rename_ty _ _ f A).
        * exact (rename_ty _ _ (fmap_dB_S f) B).
        * exact (rename_tm _ _ (fmap_dB_S f) b).
      + (* case [app_expr] *)
        refine (app_expr _ _ _ _).
        * exact (rename_ty _ _ f A).
        * exact (rename_ty _ _ (fmap_dB_S f) B).
        * exact (rename_tm _ _ f g).
        * exact (rename_tm _ _ f a).
  Defined.

End Renaming.

Section Raw_Context_Maps.
(** AKA “substitutions”. *)

  Definition raw_context_map n m := dB_vars m -> tm_expr n.

  Identity Coercion id_raw_context_map : raw_context_map >-> Funclass.

  Definition idmap_raw_context n : raw_context_map n n.
  Proof.
    exact var_expr.
  Defined.

  Definition extend_raw_context_map
      {m n} (f : raw_context_map n m) (a : tm_expr n)
    : raw_context_map n (S m)
  := dB_Sn_rect _ a f.

  Definition weaken_raw_context_map {n m}
      : raw_context_map n m -> raw_context_map (S n) (S m).
  Proof.
    intros f. refine (extend_raw_context_map _ _).
    - intros i. exact (rename_tm dB_next (f i)).
    - apply var_expr, dB_top.
  Defined.

End Raw_Context_Maps.

Section Substitution.

  Fixpoint
    subst_ty {m n} (f : raw_context_map n m) (e : ty_expr m) {struct e} : ty_expr n
  with
    subst_tm {m n} (f : raw_context_map n m) (e : tm_expr m) {struct e} : tm_expr n.
  Proof.
    - (* subst_ty *)
      destruct e as [ m | m a | m A B ].
      + (* case [U_expr] *)
        exact U_expr.
      + (* case [El_expr] *)
        exact (El_expr (subst_tm _ _ f a)).
      + (* case [Pi_expr] *)
        refine (Pi_expr (subst_ty _ _ f A) _).
        refine (subst_ty _ _ (weaken_raw_context_map f) B).
    - (* subst_tm *)
      destruct e as [ m i | m A B b | m A B g a ].
      + (* case [var_expr] *)
        apply f, i.
      + (* case [lam_expr] *)
        refine (lam_expr _ _ _).
        * exact (subst_ty _ _ f A).
        * exact (subst_ty _ _ (weaken_raw_context_map f) B).
        * exact (subst_tm _ _ (weaken_raw_context_map f) b).
      + (* case [app_expr] *)
        refine (app_expr _ _ _ _).
        * exact (subst_ty _ _ f A).
        * exact (subst_ty _ _ (weaken_raw_context_map f) B).
        * exact (subst_tm _ _ f g).
        * exact (subst_tm _ _ f a).
  Defined.

  (** Some auxiliary functions for common special cases *)

  Definition dB_next_context_map (n:nat)
    : raw_context_map (S n) n
  := fun i => var_expr (dB_next i).

  (** Substituting just the “top” variable, as in the typing rule for [app],
   or the conclusion of beta-reduction; also used when viewing a term as a
   section of the projection, as in CwA semantics. *)
  Definition tm_as_raw_context_map {n} (a : tm_expr n)
    : raw_context_map n (S n)
  := extend_raw_context_map (idmap_raw_context _) a.

  Definition subst_top_ty {n} (a : tm_expr n) (e : ty_expr (S n)) : ty_expr n
    := subst_ty (tm_as_raw_context_map a) e.

  Definition subst_top_tm {n} (a : tm_expr n) (e : tm_expr (S n)) : tm_expr n
    := subst_tm (tm_as_raw_context_map a) e.

End Substitution.


(************************************************************************************)
(************************************************************************************)
(*This files gives the basic semantic for abstract theory*)
(************************************************************************************)
(************************************************************************************)

Require Import GenLemmas.

(************************************************************************************)
(*Abstract signature of semantic*)
(************************************************************************************)
Module Type AbsSemSig.

(*The sort of the theory*)
Parameter sort : term.
Axiom sort_not_kind : sort <> kind.
Axiom typ_sort : forall e, typ e sort kind.
Axiom sort_clsd :
  (forall n k, eq_term (lift_rec n k sort) sort) /\
  (forall t k, eq_term (subst_rec t k sort) sort).

Definition wf_clsd_env e := forall i j, val_ok e i j ->
  exists j', val_ok e i j' /\ (forall n, closed_pure_term (j' n)).

Axiom PredVary : forall e x y i j,
  wf_clsd_env e ->
  typ e x sort ->
  typ e y sort ->
  val_ok e i j ->
  (exists j', val_ok e i j' /\ (forall n, closed_pure_term (j' n)) /\
    (exists P, P <> kind /\ [int P i, tm P j'] \real int (Prod sort prop) i /\
      exists u, [int u i, tm u j'] \real (app (int P i) (int x i)) /\
        ((exists v, [int v i, tm v j'] \real (app (int P i) (int y i))) ->
          int x i == int y i))).

End AbsSemSig.

(************************************************************************************)
(*This Module describes logic connectors and quantifiers with properties*)
(************************************************************************************)
Module SemLogic (M : AbsSemSig).

Export M.

Definition EQ_term x y :=
  Prod (Prod sort prop) (Prod (App (Ref 0) (lift 1 x)) (App (Ref 1) (lift 2 y))).

Lemma EQ_term_elim : forall e x y t,
  wf_clsd_env e ->
  typ e x sort ->
  typ e y sort ->
  typ e t (EQ_term x y) ->
  eq_typ e x y.
do 2 red; intros e x y t Hclsd Hx Hy Ht i j' Hok'.
generalize PredVary; intro HP. specialize HP with (1:=Hclsd) (2:=Hx) (3:=Hy) (4:=Hok').
destruct HP as (j, (Hok, (_, HP))).
destruct HP as (P, HP).
destruct HP as (HSP, HP).
destruct HP as (HP, Hxy).
destruct Hxy as (u, (Hv, Hxy)).
apply red_typ with (1:=Hok) in Ht; [|discriminate].
destruct Ht as (_, Ht).

apply Hxy; clear Hxy Hclsd e Hx Hy j' Hok' Hok.
unfold EQ_term in Ht. simpl int in Ht.
apply rprod_elim with (x:=int P i) (u:=tm P j) in Ht; [
  |do 2 red; intros; apply prod_ext; [|do 2 red; intros; rewrite H2]; rewrite H0; reflexivity|trivial].
apply rprod_elim with (x:=int u i) (u:=tm u j) in Ht.
 exists (App (App t P) u). revert Ht; apply real_morph; simpl; [reflexivity| |reflexivity].
  rewrite split_lift. do 2 rewrite int_cons_lift_eq; reflexivity.

 do 2 red; intros. rewrite H0. reflexivity.

 revert Hv; apply real_morph; [|rewrite int_cons_lift_eq|]; reflexivity.
Qed.

(*False_symb for BF*)
Definition False_symb := Prod prop (Ref 0).

Lemma False_symb_typ : forall e, typ e False_symb prop.
intros; apply typ_prod; [right; trivial|left; apply typ_prop|].
 setoid_replace prop with (lift 1 prop) using relation eq_term at 2;
   [apply typ_var; trivial|simpl; split; red; reflexivity].
Qed.

Lemma False_symb_elim : forall e t P,
  typ e t False_symb ->
  typ e P prop ->
  typ e (App t P) P.
red; intros e t P Ht HP i j Hok.
generalize HP; intros HSP.
apply red_typ with (1:=Hok) in HSP; [destruct HSP as (HSP, _)|discriminate].
revert i j Hok; fold (typ e (App t P) P).
setoid_replace P with (subst P (Ref 0)) using relation eq_term at 2;
  [|unfold subst; rewrite red_sigma_var_eq; [rewrite lift0; reflexivity|trivial]].
apply typ_app with (V:=prop); [| |discriminate|discriminate]; trivial.
Qed.

(*True_symb for TF*)
Definition True_symb := Prod prop (Prod (Ref 0) (Ref 1)).

Lemma True_symb_typ : forall e, typ e True_symb prop.
intro e.
apply typ_prod; [right; trivial|left; apply typ_prop|].
apply typ_prod; [right; trivial|right|].
 setoid_replace prop with (lift 1 prop) using relation eq_term at 2;
   [apply typ_var; trivial|simpl; split; red; reflexivity].

 setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
   [apply typ_var; trivial|simpl; split; red; reflexivity].
Qed.

Lemma True_symb_intro : forall e, exists t, typ e t True_symb.
exists (Abs prop (Abs (Ref 0) (Ref 0))).
apply typ_abs; [left; apply typ_prop| |discriminate].
apply typ_abs; [right| |discriminate].
 setoid_replace prop with (lift 1 prop) using relation eq_term at 2;
   [apply typ_var; trivial|simpl; split; red; reflexivity].

 rewrite <- (eq_term_lift_ref_fv 1 0 0); [apply typ_var; trivial|omega].
Qed.

(*Impl for implf*)
Definition Impl A B := Prod A (lift 1 B).

Lemma Impl_typ : forall e A B,
  typ e A prop ->
  typ e B prop ->
  typ e (Impl A B) prop.
intros. apply typ_prod; [right|right|]; trivial.
setoid_replace prop with (lift 1 prop) using relation eq_term;
  [apply weakening; trivial|simpl; split; red; reflexivity].
Qed.

Lemma Impl_intro : forall e b A B,
  typ e A prop ->
  B <> kind ->
  typ (A::e) b (lift 1 B) ->
  typ e (Abs A b) (Impl A B).
intros. apply typ_abs; [right| |destruct B; [discriminate|]]; trivial.
Qed.

Lemma Impl_elim : forall e t u A B,
  A <> kind ->
  B <> kind ->
  typ e t (Impl A B) ->
  typ e u A ->
  typ e (App t u) B.
intros.
setoid_replace B with (subst u (lift 1 B)) using relation eq_term;
  [|unfold subst; rewrite subst_lift_lt; [rewrite lift0; reflexivity|omega]].
apply typ_app with (V:=A); [| | |destruct B; [discriminate|]]; trivial.
Qed.

(*Neg for neg*)
Definition Neg t := Impl t False_symb.

Lemma Neg_typ : forall e t,
  typ e t prop ->
  typ e (Neg t) prop.
intros; unfold Neg; apply Impl_typ; [trivial|apply False_symb_typ].
Qed.

Lemma Neg_intro : forall na A e,
  typ e na (Impl A False_symb) ->
  typ e na (Neg A).
intros; unfold Neg; trivial.
Qed.

Lemma Neg_elim : forall na A e,
  typ e na (Neg A) ->
  typ e na (Impl A False_symb).
intros; unfold Neg; trivial.
Qed.

(*Conj for conj*)
Definition Conj A B :=
  Prod prop (Prod (Prod (lift 1 A) (Prod (lift 2 B) (Ref 2))) (Ref 1)).

Lemma Conj_typ : forall e A B,
  typ e A prop ->
  typ e B prop ->
  typ e (Conj A B) prop.
intros.
apply typ_prod; [right|left; apply typ_prop|]; trivial.
apply typ_prod; [right|right|]; trivial.
 apply typ_prod; [right|right|]; trivial.
  setoid_replace prop with (lift 1 prop) using relation eq_term at 2;
    [apply weakening; trivial|simpl; split; red; reflexivity].

  apply typ_prod; [right; trivial|right|].
   setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
     [do 2 rewrite split_lift with (n:=1);
       do 2 apply weakening; trivial
       |simpl; split; red; reflexivity].

   setoid_replace prop with (lift 3 prop) using relation eq_term at 2;
     [apply typ_var; trivial|simpl; split; red; reflexivity].

 setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
   [apply typ_var; trivial|simpl; split; red; reflexivity].
Qed.

Lemma Conj_intro : forall e A B u v,
  typ e A prop ->
  typ e B prop ->
  typ e u A /\ typ e v B ->
  exists t, typ e t (Conj A B).
intros e A B u v HTA HTB H. destruct H as (HA, HB).
exists (Abs prop (Abs (Prod (lift 1 A) (Prod (lift 2 B) (Ref 2)))
  (App (App (Ref 0) (lift 2 u)) (lift 2 v)))).
red; intros i j Hok.
generalize HTA; intros HSA.
generalize HTB; intros HSB.
apply red_typ with (1:=Hok) in HSA; [destruct HSA as (HSA, _)|discriminate].
apply red_typ with (1:=Hok) in HSB; [destruct HSB as (HSB, _)|discriminate].
revert i j Hok;
fold (typ e (Abs prop (Abs (Prod (lift 1 A) (Prod (lift 2 B) (Ref 2)))
  (App (App (Ref 0) (lift 2 u)) (lift 2 v)))) (Conj A B)).
apply typ_abs; [left; apply typ_prop| |discriminate].
apply typ_abs; [right| |discriminate].
 apply typ_prod; [right; trivial|right|].
  setoid_replace prop with (lift 1 prop) using relation eq_term at 2;
    [apply weakening; trivial|simpl; split; red; reflexivity].

  apply typ_prod; [right; trivial|right|].
   setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
     [do 2 rewrite split_lift with (n:=1);
       do 2 apply weakening; trivial|simpl; split; red; reflexivity].

   setoid_replace prop with (lift 3 prop) using relation eq_term at 2;
     [apply typ_var; trivial|simpl; split; red; reflexivity].

 setoid_replace (Ref 1) with (subst (lift 2 v) (Ref 2)) using relation eq_term;
  [|unfold subst; rewrite red_sigma_var_gt; [reflexivity|omega]].
 apply typ_app with (V:=(lift 2 B));
   [| |destruct B; [discriminate|]|discriminate]; trivial.
  rewrite split_lift with (n:=1) at 2.
  rewrite split_lift with (n:=1) (T:=v).
  do 2 apply weakening; trivial.

  setoid_replace (Prod (lift 2 B) (Ref 2)) with
    (subst (lift 2 u) (lift 1 (Prod (lift 2 B) (Ref 2)))) using relation eq_term at 2; [
      |unfold subst; unfold lift at 3; rewrite <- simpl_subst_lift_rec; reflexivity].
  apply typ_app with (V:=lift 2 A);
    [| |destruct A; [discriminate|]|discriminate]; trivial.
   rewrite split_lift with (T:=u). rewrite split_lift with (T:=A) (n:=1).
   do 2 apply weakening; trivial.

   unfold lift at 4. rewrite red_lift_prod.
   rewrite <- split_lift with (n:=2) (T:=B).
   rewrite eq_term_lift_ref_fv; [simpl|omega].
   assert (eq_term ((Prod (lift 2 A) (Prod (lift 3 B) (Ref 3))))
     (lift 1 (Prod (lift 1 A) (Prod (lift 2 B) (Ref 2))))).
    unfold lift at 3. rewrite red_lift_prod.
    rewrite <- split_lift with (T:=A) (n:=1).
    rewrite red_lift_prod.
    rewrite eq_term_lift_ref_fv; [|omega].
    unfold lift at 4. rewrite lift_rec_acc; [reflexivity|omega].

   rewrite H. apply typ_var; trivial.
Qed.

Lemma Conj_elim1 : forall e A B t,
  typ e A prop ->
  typ e B prop ->
  typ e t (Conj A B) ->
  exists u, typ e u A.
intros e A B t HA HB Ht;
  exists (App (App t A) (Abs A (Abs (lift 1 B) (Ref 1)))).
red; intros i j Hok.
generalize HA; intros HSA.
generalize HB; intros HSB.
apply red_typ with (1:=Hok) in HSA; [destruct HSA as (HSA, _)|discriminate].
apply red_typ with (1:=Hok) in HSB; [destruct HSB as (HSB, _)|discriminate].
revert i j Hok;
fold (typ e ((App (App t A) (Abs A (Abs (lift 1 B) (Ref 1))))) A).

rewrite (simpl_subst_lift_rec (Abs A (Abs (lift 1 B) (Ref 1))) A 0) at 3.
fold (lift 1 A). fold (subst (Abs A (Abs (lift 1 B) (Ref 1))) (lift 1 A)).
apply typ_app with (V:=Prod A (Prod (lift 1 B) (lift 2 A)));
  [| |discriminate|destruct A; [discriminate|trivial]].
 apply typ_abs; [right; trivial| |discriminate].
  apply typ_abs; [right|apply typ_var|destruct A; [discriminate|]]; trivial.
   setoid_replace prop with (lift 1 prop) using relation eq_term;
     [apply weakening; trivial|simpl; split; red; reflexivity].

 unfold Conj in Ht.
 assert (eq_term ((Prod (Prod A (Prod (lift 1 B) (lift 2 A))) (lift 1 A)))
   (subst A (Prod (Prod (lift 1 A) (Prod (lift 2 B) (Ref 2))) (Ref 1)))).
  unfold subst. do 3 rewrite red_sigma_prod.
  do 2 (rewrite red_sigma_var_eq; trivial).
  do 2 (rewrite subst_lift_lt; [|omega]).
  rewrite lift0; reflexivity.

 rewrite H; clear H.
 apply typ_app with (V:=prop); [trivial|trivial|discriminate|discriminate].
Qed.

Lemma Conj_elim2 : forall e A B t,
  typ e A prop ->
  typ e B prop ->
  typ e t (Conj A B) ->
  exists u, typ e u B.
intros e A B t HA HB Ht;
  exists (App (App t B) (Abs A (Abs (lift 1 B) (Ref 0)))).
red; intros i j Hok.
generalize HA; intros HSA.
generalize HB; intros HSB.
apply red_typ with (1:=Hok) in HSA; [destruct HSA as (HSA, _)|discriminate].
apply red_typ with (1:=Hok) in HSB; [destruct HSB as (HSB, _)|discriminate].
revert i j Hok;
fold (typ e ((App (App t B) (Abs A (Abs (lift 1 B) (Ref 0))))) B).

rewrite (simpl_subst_lift_rec (Abs A (Abs (lift 1 B) (Ref 0))) B 0) at 3.
fold (lift 1 B). fold (subst (Abs A (Abs (lift 1 B) (Ref 0))) (lift 1 B)).
apply typ_app with (V:=Prod A (Prod (lift 1 B) (lift 1 (lift 1 B))));
  [| |discriminate|destruct B; [discriminate|trivial]].
 apply typ_abs; [right; trivial| |discriminate].
  apply typ_abs; [right|apply typ_var|destruct B; [discriminate|]]; trivial.
   setoid_replace prop with (lift 1 prop) using relation eq_term;
     [apply weakening; trivial|simpl; split; red; reflexivity].

 unfold Conj in Ht.
 assert (eq_term ((Prod (Prod A (Prod (lift 1 B) (lift 2 B))) (lift 1 B)))
   (subst B (Prod (Prod (lift 1 A) (Prod (lift 2 B) (Ref 2))) (Ref 1)))).
  unfold subst. do 3 rewrite red_sigma_prod.
  do 2 (rewrite red_sigma_var_eq; trivial).
  do 2 (rewrite subst_lift_lt; [|omega]).
  rewrite lift0; reflexivity.

 rewrite <- split_lift. rewrite H; clear H.
 apply typ_app with (V:=prop); [trivial|trivial|discriminate|discriminate].
Qed.

(*Disj for disj*)
Definition Disj A B := Prod prop (Prod (Prod (lift 1 A) (Ref 1))
  (Prod (Prod (lift 2 B) (Ref 2)) (Ref 2))).

Lemma Disj_typ : forall e A B,
  typ e A prop ->
  typ e B prop ->
  typ e (Disj A B) prop.
intros. apply typ_prod; [right; trivial|left; apply typ_prop|].
apply typ_prod; [right; trivial|right|].
 apply typ_prod; [right; trivial|right|].
  setoid_replace prop with (lift 1 prop) using relation eq_term at 2;
    [apply weakening; trivial|simpl; split; red; reflexivity].

  setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
    [apply typ_var; trivial|simpl; split; red; reflexivity].

 apply typ_prod; [right; trivial|right|].
  apply typ_prod; [right; trivial|right|].
   setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
     [do 2 rewrite split_lift with (n:=1); do 2 apply weakening; trivial
       |simpl; split; red; reflexivity].

   setoid_replace prop with (lift 3 prop) using relation eq_term at 2;
     [apply typ_var; trivial|simpl; split; red; reflexivity].

  setoid_replace prop with (lift 3 prop) using relation eq_term at 2;
    [apply typ_var; trivial|simpl; split; red; reflexivity].
Qed.

Lemma Disj_intro1 : forall e t A B,
  typ e A prop ->
  typ e B prop ->
  typ e t A  ->
  exists u, typ e u (Disj A B).
intros e t A B HA HB Ht.
exists (Abs prop (Abs (Prod (lift 1 A) (Ref 1))
  (Abs (Prod (lift 2 B) (Ref 2)) (App (Ref 1) (lift 3 t))))).
red; intros i j Hok.
generalize HA; intros HSA.
apply red_typ with (1:=Hok) in HSA; [destruct HSA as (HSA, _)|discriminate].
revert i j Hok;
fold (typ e (Abs prop (Abs (Prod (lift 1 A) (Ref 1))
  (Abs (Prod (lift 2 B) (Ref 2))
  (App (Ref 1) (lift 3 t))))) (Disj A B)).
apply typ_abs; [left; apply typ_prop| |discriminate].
 apply typ_abs; [right| |discriminate].
  apply typ_prod; [right; trivial|right|].
   setoid_replace prop with (lift 1 prop) using relation eq_term at 2;
     [apply weakening; trivial|simpl; split; red; reflexivity].

   setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
     [apply typ_var; trivial|simpl; split; red; reflexivity].

  apply typ_abs; [right| |discriminate].
   apply typ_prod; [right; trivial|right|].
    setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
      [do 2 rewrite split_lift with (n:=1); do 2 apply weakening
        |simpl; split; red; reflexivity]; trivial.

    setoid_replace prop with (lift 3 prop) using relation eq_term at 2;
      [apply typ_var; trivial|simpl; split; red; reflexivity].

   setoid_replace (Ref 2) with (subst (lift 3 t) (Ref 3)) using relation eq_term at 2; [
     |unfold subst; rewrite red_sigma_var_gt; [reflexivity|omega]].
   apply typ_app with (V:=(lift 3 A));
     [| |destruct A; [discriminate|trivial]|discriminate].
    do 2 rewrite split_lift with (T:=t).
    rewrite split_lift with (T:=A) (n:=2).
    rewrite split_lift with (T:=A) (n:=1).
    do 3 apply weakening; trivial.

    rewrite <- (eq_term_lift_ref_fv 1 1 2) by omega.
    rewrite split_lift with (n:=2).
    unfold lift at 3. rewrite <- red_lift_prod.
    fold (lift 1 (Prod (lift 2 A) (Ref 2))).
    rewrite <- (eq_term_lift_ref_fv 1 1 1) at 2 by omega.
    rewrite split_lift with (n:=1) (T:=A).
    unfold lift at 4. rewrite <- red_lift_prod.
    fold (lift 1 (Prod (lift 1 A) (Ref 1))).
    rewrite <- split_lift. apply typ_var; trivial.
Qed.

Lemma Disj_intro2 : forall e t A B,
  typ e A prop ->
  typ e B prop ->
  typ e t B  ->
  exists u, typ e u (Disj A B).
intros e t A B HA HB Ht.
exists (Abs prop (Abs (Prod (lift 1 A) (Ref 1))
  (Abs (Prod (lift 2 B) (Ref 2)) (App (Ref 0) (lift 3 t))))).
red; intros i j Hok.
generalize HB; intros HSB.
apply red_typ with (1:=Hok) in HSB; [destruct HSB as (HSB, _)|discriminate].
revert i j Hok;
fold (typ e (Abs prop (Abs (Prod (lift 1 A) (Ref 1))
  (Abs (Prod (lift 2 B) (Ref 2)) (App (Ref 0) (lift 3 t))))) (Disj A B)).
apply typ_abs; [left; apply typ_prop| |discriminate].
 apply typ_abs; [right| |discriminate].
  apply typ_prod; [right; trivial|right|].
   setoid_replace prop with (lift 1 prop) using relation eq_term at 2;
     [apply weakening; trivial|simpl; split; red; reflexivity].

   setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
     [apply typ_var; trivial|simpl; split; red; reflexivity].

  apply typ_abs; [right| |discriminate].
   apply typ_prod; [right; trivial|right|].
    setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
      [do 2 rewrite split_lift with (n:=1); do 2 apply weakening
        |simpl; split; red; reflexivity]; trivial.

    setoid_replace prop with (lift 3 prop) using relation eq_term at 2;
      [apply typ_var; trivial|simpl; split; red; reflexivity].

   setoid_replace (Ref 2) with (subst (lift 3 t) (Ref 3)) using relation eq_term at 2; [
     |unfold subst; rewrite red_sigma_var_gt; [reflexivity|omega]].
   apply typ_app with (V:=(lift 3 B));
     [| |destruct B; [discriminate|trivial]|discriminate].
    do 2 rewrite split_lift with (T:=t).
    rewrite split_lift with (T:=B) (n:=2).
    rewrite split_lift with (T:=B) (n:=1) at 2.
    do 3 apply weakening; trivial.

    rewrite <- (eq_term_lift_ref_fv 1 1 2) by omega.
    rewrite split_lift with (n:=2).
    unfold lift at 3. rewrite <- red_lift_prod.
    fold (lift 1 (Prod (lift 2 B) (Ref 2))).
    apply typ_var; trivial.
Qed.

Lemma Disj_elim : forall e t t1 t2 A B C,
  typ e A prop ->
  typ e B prop ->
  typ e C prop ->
  typ e t (Disj A B) ->
  typ (A::e) t1 (lift 1 C) ->
  typ (B::e) t2 (lift 1 C) ->
  exists u, typ e u C.
intros e t t1 t2 A B C HA HB HC Ht Ht1 Ht2.
exists (App (App (App t C) (Abs A t1)) (Abs B t2)).
red; intros i j Hok.
generalize HC; intros HSC.
apply red_typ with (1:=Hok) in HSC; [destruct HSC as (HSC, _)|discriminate].
revert i j Hok;
fold (typ e (App (App (App t C) (Abs A t1)) (Abs B t2)) C).
apply Impl_intro in Ht1; [|exact HA|exact HSC].
apply Impl_intro in Ht2; [|exact HB|exact HSC].
setoid_replace C with (subst (Abs B t2) (lift 1 C)) using relation eq_term at 2; [
  |unfold subst; rewrite subst_lift_lt; [rewrite lift0; reflexivity|omega]].
apply typ_app with (V:=(Impl B C));
  [| |discriminate|destruct C; [discriminate|]]; trivial.
setoid_replace (Prod (Impl B C) (lift 1 C)) with
  (subst (Abs A t1) (lift 1 (Prod (Impl B C) (lift 1 C)))) using relation eq_term; [
    |unfold subst; rewrite subst_lift_lt; [rewrite lift0; reflexivity|omega]].
apply typ_app with (V:=(Impl A C)); [trivial| |discriminate|discriminate].
unfold Impl; unfold Disj in Ht.
unfold lift at 2 3 4. do 2 rewrite red_lift_prod.
rewrite lift_rec_acc; [simpl plus|omega].
fold (lift 1 B) (lift 2 C).
assert (eq_term
  (Prod (Prod A (lift 1 C)) (Prod (Prod (lift 1 B) (lift 2 C)) (lift 2 C)))
  (subst C (Prod (Prod (lift 1 A) (Ref 1))
    (Prod (Prod (lift 2 B) (Ref 2)) (Ref 2))))).
 unfold subst. do 4 rewrite red_sigma_prod.
 do 2 (rewrite subst_lift_lt by omega). rewrite lift0.
 do 2 (rewrite red_sigma_var_eq; trivial); reflexivity.

rewrite H; clear H.
apply typ_app with (V:=prop); [| |discriminate|discriminate]; trivial.
Qed.

(*Fall for fall*)
Definition Fall A := Prod sort A.

Lemma Fall_typ : forall e A,
  typ (sort::e) A prop ->
  typ e (Fall A) prop.
intros; apply typ_prod; [right|unfold typs; left; apply typ_sort|];trivial.
Qed.

Lemma Fall_intro : forall e t B,
  typ (sort::e) B prop ->
  typ (sort::e) t B ->
  typ e (Abs sort t) (Fall B).
intros e t B HB Ht i j Hok'.
assert (exists x, [x, Sat.SatSet.daimon] \real int sort i).
 apply typs_non_empty with (e:=e) (j:=j); [left; apply typ_sort|]; trivial.
destruct H as (x, H).
assert (val_ok (sort :: e) (V.cons x i) (I.cons Sat.SatSet.daimon j)).
 apply vcons_add_var; [| |apply sort_not_kind]; trivial.

generalize HB; intros HSB.
apply red_typ with (1:=H0) in HSB; [destruct HSB as (HSB, _)|discriminate].
clear H H0; revert i j Hok'; fold (typ e (Abs sort t) (Fall B)).
apply typ_abs; [left; apply typ_sort| |]; trivial.
Qed.

Lemma Fall_elim : forall e t u B,
  typ (sort::e) B prop ->
  typ e t (Fall B) ->
  typ e u sort ->
  typ e (App t u) (subst u B).
red; intros e t u B HB Ht Hu i j Hok.

assert (exists x, [x, Sat.SatSet.daimon] \real int sort i).
 apply typs_non_empty with (e:=e) (j:=j); [left; apply typ_sort|]; trivial.
destruct H as (x, H).
assert (val_ok (sort :: e) (V.cons x i) (I.cons Sat.SatSet.daimon j)).
 apply vcons_add_var; [| |apply sort_not_kind]; trivial.

generalize HB; intros HSB.
apply red_typ with (1:=H0) in HSB; [destruct HSB as (HSB, _)|discriminate].
clear H H0; revert i j Hok; fold (typ e (App t u) (subst u B)).
apply typ_app with (V:=sort); [| |apply sort_not_kind|]; trivial.
Qed.

(*Exst for exst*)
Definition Exst A := Prod prop (
  Prod (Prod (lift 1 sort) (Prod (subst (Ref 0) (lift_rec 2 1 A)) (Ref 2))) (Ref 1)).

Lemma Exst_typ : forall e A,
  typ (sort::e) A prop ->
  typ e (Exst A) prop.
intros e A HA; unfold Exst.
apply typ_prod; [right; trivial|left; apply typ_prop|].
apply typ_prod; [right|right
  |setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
    [apply typ_var|simpl; split; red; reflexivity]]; trivial.
apply typ_prod; [right; trivial
  |left; setoid_replace kind with (lift 1 kind) using relation eq_term;
    [apply weakening; apply typ_sort|simpl; split; red; reflexivity]|].
apply typ_prod; [right|right
  |setoid_replace prop with (lift 3 prop) using relation eq_term at 2;
    [apply typ_var|simpl; split; red; reflexivity]]; trivial.
rewrite subst0_lift.
setoid_replace prop with (lift_rec 1 1 prop) using relation eq_term at 2;
  [apply weakening_bind; trivial|simpl; split; red; reflexivity].
Qed.

Lemma Exst_intro : forall e A p a,
  typ (sort::e) A prop ->
  typ e a sort ->
  typ e p (subst a A) ->
  exists t, typ e t (Exst A).
intros e A p a HA Ha Hp.
exists (Abs prop (Abs (Prod (lift 1 sort) (Prod (subst (Ref 0) (lift_rec 2 1 A)) (Ref 2)))
  (App (App (Ref 0) (lift 2 a)) (lift 2 p)))).
red; intros i j Hok.
assert (exists x, [x, Sat.SatSet.daimon] \real int sort i).
 apply typs_non_empty with (e:=e) (j:=j); [left; apply typ_sort|]; trivial.
destruct H as (x, H).
assert (val_ok (sort :: e) (V.cons x i) (I.cons Sat.SatSet.daimon j)).
 apply vcons_add_var; [| |apply sort_not_kind]; trivial.

generalize HA; intros HSA.
apply red_typ with (1:=H0) in HSA; [destruct HSA as (HSA, _)|discriminate].
clear H H0; revert i j Hok;
fold (typ e (Abs prop (Abs (Prod (lift 1 sort) (Prod (subst (Ref 0) (lift_rec 2 1 A)) (Ref 2)))
  (App (App (Ref 0) (lift 2 a)) (lift 2 p)))) (Exst A)).
apply typ_abs; [left; apply typ_prop| |discriminate].
apply typ_abs; [right| |discriminate].
 apply typ_prod; [right; trivial
   |left; setoid_replace kind with (lift 1 kind) using relation eq_term;
     [apply weakening; apply typ_sort|simpl; split; red; reflexivity]|].
  apply typ_prod; [right; trivial|right; rewrite subst0_lift|].
   setoid_replace prop with (lift_rec 1 1 prop) using relation eq_term at 2;
     [apply weakening_bind; trivial|simpl; split; red; reflexivity].

   setoid_replace prop with (lift 3 prop) using relation eq_term at 2;
     [apply typ_var; trivial|simpl; split; red; reflexivity].

 setoid_replace (Ref 1) with (subst (lift 2 p) (Ref 2)) using relation eq_term; [
   |unfold subst; rewrite red_sigma_var_gt; [reflexivity|omega]].
 apply typ_app with (V:=(lift 2 (subst a A)));
   [| |destruct A; [discriminate|trivial]|discriminate].
  do 2 rewrite split_lift with (n:=1). do 2 apply weakening; trivial.

  assert (eq_term (Prod (lift 2 (subst a A)) (Ref 2))
    (subst (lift 2 a) (Prod (subst (Ref 0) (lift_rec 3 1 A)) (Ref 3)))).
   unfold subst at 2. rewrite red_sigma_prod. rewrite red_sigma_var_gt; [|omega].
   apply Prod_morph; [rewrite subst0_lift|reflexivity].
    apply eq_term_intro; intros.
     unfold lift, subst. rewrite int_lift_rec_eq.
     do 2 rewrite int_subst_rec_eq. do 2 rewrite int_lift_rec_eq. do 4 rewrite V.lams0.
     rewrite <- V.cons_lams; [rewrite V.lams0|do 2 red; intros; rewrite H]; reflexivity.

     unfold lift, subst. rewrite tm_lift_rec_eq.
     do 2 rewrite tm_subst_rec_eq. do 2 rewrite tm_lift_rec_eq. do 4 rewrite I.lams0.
     rewrite <- I.cons_lams; [rewrite I.lams0|do 2 red; intros; rewrite H]; reflexivity.

     destruct A; simpl; trivial.

   rewrite H; clear H.
   apply typ_app with (V:=(lift 2 sort)); [| | |discriminate].
    do 2 rewrite split_lift with (n:=1). do 2 apply weakening; trivial.

    assert (eq_term (Prod (subst (Ref 0) (lift_rec 3 1 A)) (Ref 3))
      (lift_rec 1 1 (Prod (subst (Ref 0) (lift_rec 2 1 A)) (Ref 2)))).
     rewrite red_lift_prod. rewrite eq_term_lift_ref_fv by omega.
     apply Prod_morph; [|simpl plus; reflexivity].
      do 2 rewrite subst0_lift. rewrite lift_rec_acc; [simpl; reflexivity|omega].

    rewrite H; clear H. rewrite split_lift with (n:=1).
    unfold lift at 2. rewrite <- red_lift_prod. apply typ_var; trivial.

    case_eq sort; intros; [discriminate|apply sort_not_kind in H; contradiction].
Qed.

Lemma Exst_elim : forall e t1 t2 A C,
  typ (sort::e) A prop ->
  typ e C prop ->
  typ e t1 (Exst A) ->
  typ (A::sort::e) t2 (lift 2 C) ->
  exists t, typ e t C.
intros e t1 t2 A C HA HC Ht1 Ht2.
exists (App (App t1 C) (Abs sort (Abs A t2))).
red; intros i j Hok.
generalize HC; intros HSC.
apply red_typ with (1:=Hok) in HSC; [destruct HSC as (HSC, _)|discriminate].
revert i j Hok; fold (typ e (App (App t1 C) (Abs sort (Abs A t2))) C).
apply typ_abs in Ht2; [|right|destruct C; [discriminate|]]; trivial.
apply typ_abs in Ht2; [|left; apply typ_sort|discriminate].

assert (eq_term C (subst (Abs sort (Abs A t2)) (lift 1 C))).
 unfold subst; rewrite subst_lift_lt; [rewrite lift0; reflexivity|omega].

rewrite H at 2; clear H.
apply typ_app with (V:=(Prod sort (Prod A (lift 2 C))));
  [|unfold Exst in Ht1|discriminate|destruct C; [discriminate|]]; trivial.
assert (eq_term (Prod (Prod sort (Prod A (lift 2 C))) (lift 1 C))
  (subst C (Prod (Prod (lift 1 sort) (Prod (subst (Ref 0) (lift_rec 2 1 A)) ((Ref 2)))) (Ref 1)))).
 unfold subst. do 3 rewrite red_sigma_prod.
 rewrite (subst0_lift A 1). do 2 (rewrite red_sigma_var_eq; [|trivial]).
 rewrite subst_lift_lt; [rewrite lift0|omega].
 apply Prod_morph; [|reflexivity].
  apply Prod_morph; [reflexivity|].
   apply Prod_morph; [|reflexivity].
    apply eq_term_intro; [| |destruct A; simpl; trivial]; intros.
     rewrite int_subst_rec_eq. rewrite int_lift_rec_eq.
     apply int_morph; [reflexivity|do 2 red; intros].
      destruct a; unfold V.lams, V.shift; simpl; intros;
        [|replace (a-0) with a by omega]; reflexivity.

     rewrite tm_subst_rec_eq. rewrite tm_lift_rec_eq.
     apply tm_morph; [reflexivity|do 2 red; intros].
      destruct a; unfold I.lams, I.shift; simpl; intros;
        [|replace (a-0) with a by omega]; reflexivity.

rewrite H; clear H.
apply typ_app with (V:=prop); [| |discriminate|discriminate]; trivial.
Qed.

(*Equation is encoded impredicatively*)
Lemma EQ_term_typ : forall x y e,
  typ e x sort ->
  typ e y sort ->
  typ e (EQ_term x y) prop.
intros; apply typ_prod; [right; trivial|left|].
 apply typ_prod; [left; trivial|left; apply typ_sort|apply typ_prop].

 apply typ_prod; [right; trivial|right|].
  setoid_replace prop with (subst (lift 1 x) prop) using relation eq_term at 2;
    [|simpl; split; red; reflexivity].
  apply typ_app with (V:=(lift 1 sort));
    [apply weakening; trivial| | |discriminate].
   setoid_replace (Prod (lift 1 sort) prop) with (lift 1 (Prod sort prop)) using relation eq_term;
     [apply typ_var; trivial
       |unfold lift; rewrite red_lift_prod; apply Prod_morph; [|simpl; split; red]; reflexivity].

   case_eq sort; intros H1; [discriminate|apply sort_not_kind in H1; contradiction].

  setoid_replace prop with (subst (lift 2 y) prop) using relation eq_term at 2;
    [|simpl; split; red; reflexivity].
  apply typ_app with (V:=(lift 2 sort));
    [do 2 rewrite split_lift with (n:=1); do 2 apply weakening; trivial| | |discriminate].
   setoid_replace (Prod (lift 2 sort) prop) with (lift 2 (Prod sort prop)) using relation eq_term;
     [apply typ_var; trivial|].
    unfold lift; rewrite red_lift_prod; apply Prod_morph; [|simpl; split; red]; reflexivity.

   case_eq sort; intros H1; [discriminate|apply sort_not_kind in H1; contradiction].
Qed.

End SemLogic.

(************************************************************************************************)
(*This module represents axioms and prove them*)
(************************************************************************************************)
Module Type SemanticAx (M : AbsSemSig).

Include SemLogic M.

(*Specific theory axioms. Required : they can be proved in the SN model*)
Parameter ax : Prop.
Parameter ax_provable : ax.

End SemanticAx.

(************************************************************************************************)
(*Full interpretation of the theory*)
(************************************************************************************************)
Module Type TheorySem.

Declare Module sig : AbsSemSig.
Export sig.

Declare Module ax : SemanticAx sig.
Export ax.

End TheorySem.


Require Import Coq.Classes.Morphisms.
Require Import Coq.omega.Omega.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Tactics.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.CtxLogic.

Set Implicit Arguments.
Set Strict Implicit.

Section instantiate.
  Variable typ : Set.
  Variable expr : Set.
  Context {RType_typ : RType typ}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {Expr_expr : @Expr typ _ expr}.
  Context {ExprOk_expr : ExprOk Expr_expr}.

  Definition instantiate (f : uvar -> option expr) (n : nat) (e : expr) : expr :=
    expr_subst f (fun _ => None) n e.

  Definition sem_preserves_if_ho tus tvs
             (P : exprT tus tvs Prop -> Prop)
             (f : uvar -> option expr) : Prop :=
    forall u e t get,
      f u = Some e ->
      nth_error_get_hlist_nth _ tus u = Some (@existT _ _ t get) ->
      exists eD,
        exprD tus tvs t e = Some eD /\
        P (fun us vs => get us = eD us vs).

  Definition sem_preserves_if tus tvs
             (P : exprT tus tvs Prop)
             (f : uvar -> option expr) : Prop :=
    @sem_preserves_if_ho tus tvs
                         (fun P' => forall us vs, P us vs -> P' us vs) f.

  Definition instantiate_spec_ho
             (instantiate : (uvar -> option expr) -> nat -> expr -> expr)
    : Prop :=
    forall tus tvs f e tvs' t eD P (EApp : CtxLogic.ExprTApplicative P),
      sem_preserves_if_ho P f ->
      exprD tus (tvs' ++ tvs) t e = Some eD ->
      exists eD',
        exprD tus (tvs' ++ tvs) t (instantiate f (length tvs') e) = Some eD' /\
        P (fun us vs => forall vs',
               eD us (hlist_app vs' vs) = eD' us (hlist_app vs' vs)).

  Definition instantiate_spec
             (instantiate : (uvar -> option expr) -> nat -> expr -> expr)
  : Prop :=
    forall tus tvs f e tvs' t eD P,
      @sem_preserves_if tus tvs P f ->
      exprD tus (tvs' ++ tvs) t e = Some eD ->
      exists eD',
        exprD tus (tvs' ++ tvs) t (instantiate f (length tvs') e) = Some eD' /\
        forall us vs vs',
          P us vs ->
          eD us (hlist_app vs' vs) = eD' us (hlist_app vs' vs).

  Theorem instantiate_sound_ho
  : instantiate_spec_ho instantiate.
  Proof.
    red. unfold instantiate.
    intros. remember (expr_subst f (fun _ : var => None) (length tvs') e).
    symmetry in Heqy.
    generalize expr_subst_sound_ho; intro expr_subst_sound_ho.
    red in expr_subst_sound_ho.
    eapply expr_subst_sound_ho
      with (tus:=tus) (tvs:=tvs) (tus':=tus) (tvs':=tvs) (_tvs:=tvs') (t:=t)
           (P:=fun Q => P (fun a b => Q a b a b)) (eD := eD) in Heqy;
      eauto.
    { clear - EApp.
      constructor.
      { intros. eapply exprTPure. eauto. }
      { intros. revert H0. eapply exprTAp. eauto. } }
    { clear Heqy H0. intros.
      specialize (H u).
      destruct (f u).
      { specialize (H _ _ _ eq_refl H1).
        forward_reason.
        eexists; split; eauto. }
      { eexists; split; eauto.
        eapply exprTPure; eauto. } }
    { intros; eexists; split; eauto.
      eapply exprTPure; eauto. }
  Qed.

  Theorem instantiate_sound
  : instantiate_spec instantiate.
  Proof.
    red. intros.
    eapply instantiate_sound_ho in H0; eauto.
    { forward_reason.
      eexists; split; eauto. }
    { eapply ExprTApplicative_foralls_impl. }
  Qed.

  Definition mentionsU_instantiate_spec
             (instantiate : (uvar -> option expr) -> nat -> expr -> expr)
             (mentionsU : uvar -> expr -> bool)
  : Prop :=
    forall f n e u,
      mentionsU u (instantiate f n e) = true <-> (** do i need iff? **)
      (   (f u = None /\ mentionsU u e = true)
       \/ exists u' e',
            f u' = Some e' /\
            mentionsU u' e = true /\
            mentionsU u e' = true).

  Theorem mentionsU_instantiate
  : mentionsU_instantiate_spec instantiate (@mentionsU _ _ _ _).
  Proof using ExprOk_expr.
    red. intros.
    unfold instantiate.
    rewrite mentionsU_subst; eauto.
    split; destruct 1.
    { left. tauto. }
    { destruct H.
      { right. forward_reason. do 2 eexists; split; eauto. }
      { forward_reason. congruence. } }
    { left. tauto. }
    { forward_reason. right. left.
      do 2 eexists; split; eauto. }
  Qed.

  Corollary mentionsU_instantiate_false
  : forall uv f n e,
      mentionsU uv (instantiate f n e) = false <->
      (f uv = None -> mentionsU uv e = false) /\
      (forall u e',
         f u = Some e' ->
         mentionsU u e = true ->
         mentionsU uv e' = false).
  Proof.
    split; intros.
    { destruct (mentionsU_instantiate f n e uv).
      split. consider (mentionsU uv e); auto.
      { intros. exfalso.
        rewrite H2 in H. congruence.
        left; auto. }
      { intros.
        consider (mentionsU uv e'); auto; intro.
        rewrite H1 in H. congruence.
        clear H0.
        right. exists u. exists e'.
        split; auto. } }
    { consider (mentionsU uv (instantiate f n e)); auto.
      intros.
      eapply mentionsU_instantiate in H0.
      forward_reason.
      destruct H0.
      { destruct H0. apply H in H0. congruence. }
      { forward_reason.
        eapply H1 in H0; eauto. } }
  Qed.

  Theorem mentionsV_instantiate
  : forall v f n e,
      mentionsV v (instantiate f n e) = true <->
      (   mentionsV v e = true
       \/ (v >= n /\
           exists u e', mentionsU u e = true /\
                        f u = Some e' /\
                        mentionsV (v-n) e' = true)).
  Proof.
    red. intros.
    unfold instantiate.
    rewrite mentionsV_subst; eauto.
    split; destruct 1.
    { left. tauto. }
    { destruct H. destruct H0.
      { left; tauto. }
      destruct H0.
      { right. split; auto. }
      { forward_reason. congruence. } }
    { consider (v ?[ lt ] n); intros.
      { left. tauto. }
      { right. split. omega. left. tauto. } }
    { forward_reason. right. split; auto.
      right. left. eauto. }
  Qed.

  Theorem mentionsV_instantiate_0
  : forall v f e,
      mentionsV v (instantiate f 0 e) = true <->
      (   mentionsV v e = true
       \/ exists u e', mentionsU u e = true /\
                       f u = Some e' /\
                       mentionsV v e' = true).
  Proof.
    intros. rewrite mentionsV_instantiate.
    split; destruct 1; eauto.
    { right. rewrite <- Minus.minus_n_O in *. tauto. }
    { rewrite <- Minus.minus_n_O in *. right; split; try tauto. omega. }
  Qed.

  Theorem instantiate_noop
  : forall f n e,
      (forall u, mentionsU u e = true -> f u = None) ->
      instantiate f n e = e.
  Proof.
    intros. unfold instantiate.
    eapply expr_subst_noop; eauto.
  Qed.

  Theorem Proper_instantiate
  : Proper ((eq ==> eq) ==> eq ==> eq ==> eq)%signature instantiate.
  Proof.
    intros.
    red. red. red. red. unfold instantiate. intros; subst.
    eapply Proper_subst; eauto.
    red. auto.
  Qed.

End instantiate.

Arguments mentionsU_instantiate {typ expr RType RTypeOk Expr ExprOk} n e u : rename.
Arguments mentionsU_instantiate_false {typ expr RType RTypeOk Expr ExprOk} _ _ _ : rename.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* Instantiation of the Ring tactic for the binary integers of ZArith *)

Require Export LegacyArithRing.
Require Export ZArith_base.
Require Import Eqdep_dec.
Require Import LegacyRing.

Definition Zeq (x y:Z) :=
  match (x ?= y)%Z with
  | Datatypes.Eq => true
  | _ => false
  end.

Lemma Zeq_prop : forall x y:Z, Is_true (Zeq x y) -> x = y.
  intros x y H; unfold Zeq in H.
  apply Z.compare_eq.
  destruct (x ?= y)%Z; [ reflexivity | contradiction | contradiction ].
Qed.

Definition ZTheory : Ring_Theory Z.add Z.mul 1%Z 0%Z Z.opp Zeq.
  split; intros; eauto with zarith.
  apply Zeq_prop; assumption.
Qed.

(* NatConstants and NatTheory are defined in Ring_theory.v *)
Add Legacy Ring Z Z.add Z.mul 1%Z 0%Z Z.opp Zeq ZTheory
 [ Zpos Zneg 0%Z xO xI 1%positive ].


(** Simple elimination + computation + uniqueness + coherence for W A B
        ->
    Dependent elimination + computation for W A B
**)

Require Import HoTT.
Require Import w.

Local Open Scope path_scope.
Local Open Scope fibration_scope.

Section AssumeFunext.
Context `{Funext}.

Section DepRules.

Variable A : Type.
Variable B : A -> Type.

(* Assume a fixed type W with an appropriate constructor. *)
Variable W : Type.
Variable sup : forall (x : A), (B x -> W) -> W.

(* Assume simple elim and comp rules for W. *)
Variable P : hasWSimpElimCompRules A B W sup.

(* Assume simple uniq and coh rules for W. *)
Variable Q : hasWSimpUniqCohRules A B W sup.

(* Assume the premises of the dependent elim and comp rules. *)
Variable E : W -> Type.
Variable e : forall x f, (forall b, E (f b)) -> E (sup x f).

(***********************************************************************)
(***********************************************************************)

(* To obtain dep elim, we use simple elim with the type below. *)
Definition C : Type := { x : W & E x }.

(* For this we supply the term below. *)
Definition c : forall x, (B x -> C) -> C
  := fun x g =>
  (sup x (fun b => (g b).1); e x (fun b => (g b).1) (fun b => (g b).2)).

(* This gives us the following functions: *)
Definition u_1 : W -> W := fun w => ((P C c).1 w).1.
Definition u_2 : forall w, E(u_1 w) := fun w => ((P C c).1 w).2.

(* By the computation rules for simple elim: *)
Definition p : forall x f, u_1 (sup x f) = sup x (fun b => u_1 (f b))
  := fun x f => ((P C c).2 x f) ..1.

Definition gamma : forall x f,
  p x f # u_2 (sup x f) = e x (fun b => u_1 (f b)) (fun b => u_2 (f b))
  := fun x f => ((P C c).2 x f) ..2.

(***********************************************************************)
(***********************************************************************)

(* We now want to show that the function u_1 defined above is (pointwise)
   propositionally equal to the identity function on W. *)

(* By the uniqueness rule for simple elim: *)
Definition alpha : forall w, u_1 w = w
  := (Q W sup u_1 p idmap (fun x f => 1)).1.

(* By the coherence rule for simple elim: *)
Definition theta : forall x f,
  alpha (sup x f) = p x f @ ap (sup x) (path_forall _ _ (fun b => alpha (f b))) @ 1^
  := (Q W sup u_1 p idmap (fun x f => 1)).2.

(***********************************************************************)
(***********************************************************************)

(* Dependent elim. *)
Definition drec : forall (w : W), E w := fun w => alpha w # u_2 w.

(* Dependent comp. *)
Definition beta : forall x f, drec (sup x f)  = e x f (fun b => drec (f b)).
Proof.
intros. unfold drec.
rewrite (theta x f).
repeat rewrite transport_pp.
simpl.
rewrite (gamma x f).

set (q := path_forall _ _ (fun b => alpha (f b))).
set (X := fun f => forall b : B x, E (f b)).

transitivity (e x f (transport X q (fun b => u_2 (f b)))).
induction q; reflexivity.

apply ap.
transitivity (fun b => transport E (apD10 q b) (u_2 (f b))).
induction q; reflexivity.

apply H; intro.
unfold q. rewrite apD10_path_forall. reflexivity.
Defined.

(* Putting this all together: *)
Definition depRules : { drec : forall (x : W), E x &
  forall x f, drec (sup x f)  = e x f (fun b => drec (f b)) }
  := (drec; beta).

End DepRules.

(***********************************************************************)
(***********************************************************************)

Theorem wSimpRules_imp_wDepRules (A : Type) (B : A -> Type) (W : Type) (sup : forall (x : A), (B x -> W) -> W) :
  hasWSimpElimCompRules A B W sup *
  hasWSimpUniqCohRules A B W sup ->
  hasWDepElimCompRules A B W sup.
Proof.
intro I.
destruct I as [P Q].
unfold hasWDepElimCompRules.
apply depRules.
assumption.
assumption.
Defined.

Theorem wDep_imp_wSimp (A : Type) (B : A -> Type) : WSimp A B -> WDep A B.
Proof.
intro I.
destruct I as [W [sup P]].
unfold WDep.
refine (W; (sup; _)).
apply wSimpRules_imp_wDepRules.
assumption.
Defined.

End AssumeFunext.


From Cofq.SystemK Require Import
     SystemKDefinitions.

From Cofq.Utils Require Import
     Utils.

From Coq Require Import
     Lia
     Program.Wf.

From ExtLib Require Import
     Structures.Monads
     Structures.Functor
     Eqv.

Import MonadNotation.
Local Open Scope monad_scope.
Local Open Scope string_scope.

Fixpoint kvalue_size {I} `{FInt I} (value : KValue) : nat :=
  match value with
  | KAnnotated type raw_value => 1 + kraw_value_size raw_value
  end
with kraw_value_size {I} `{FInt I} (raw_value : KRawValue) : nat :=
  match raw_value with
  | KNum num => 0
  | KVar index => 0
  | KFix type_param_count value_params fbody => 1 + kterm_size fbody
  | KTuple tuple_bodies => 1 + (list_sum (map kvalue_size tuple_bodies))
  end
with kterm_size {I} `{FInt I} (term : KTerm) : nat :=
  match term with
  | KLet declaration lbody => 1 + kdeclaration_size declaration + kterm_size lbody
  | KApp f type_params value_params => 1 + kvalue_size f + (list_sum (map kvalue_size value_params))
  | KIf0 value then_term else_term => 1 + kvalue_size value + kterm_size then_term + kterm_size else_term
  | KHalt type value => 1 + kvalue_size value
  end
with kdeclaration_size {I} `{FInt I} (declaration : KDeclaration) : nat :=
  match declaration with
  | KVal value => 1 + kvalue_size value
  | KProjN i value => 1 + kvalue_size value
  | KOp op value_a value_b => 1 + kvalue_size value_a + kvalue_size value_b
  end
.

Fixpoint ktype_size (τ : KType) : nat :=
  match τ with
  | KProd ts => 1 + (list_sum (map ktype_size ts))
  | KTForall type_param_count term_params => 1 + (list_sum (map ktype_size term_params))
  | KTVar x => 0
  | KIntType => 0
  end.

(*
Obligation Tactic := try Tactics.program_simpl; try solve [cbn; try lia | repeat split; try solve [intros; discriminate | intros; intros CONTRA; inversion CONTRA; discriminate]].
Program Fixpoint ftype_eq (τ1 : FType) (τ2 : FType) {measure (type_size τ1 + type_size τ2)} : bool
  := match τ1, τ2 with
     | Arrow a1 b1, Arrow a2 b2 => ftype_eq a1 a2 && ftype_eq b1 b2
     | Prod es1, Prod es2 =>
       zip_pred (fun τ1 τ2 => ftype_eq τ1 τ2) es1 es2
     | TForall t1, TForall t2 => ftype_eq t1 t2
     | TVar x, TVar y => N.eqb x y
     | IntType, IntType => true
     | _, _ => false
     end.
Next Obligation.
Admitted.

Program Fixpoint term_eq (e1 e2 : Term) {measure (term_size e1 + term_size e2)} : bool
  := match e1, e2 with
     | Var x, Var y => N.eqb x y
     | Ann e1 t1, Ann e2 t2 => term_eq e1 e2 && ftype_eq t1 t2
     | Fix fτ1 aτ1 body1, Fix fτ2 aτ2 body2 =>
       ftype_eq fτ1 fτ2 && ftype_eq aτ1 aτ2 && term_eq body1 body2
     | App f1 a1, App f2 a2 =>
       term_eq f1 f2 && term_eq a1 a2
     | TAbs x, TAbs y => term_eq x y
     | TApp e1 τ1, TApp e2 τ2 => term_eq e1 e2 && ftype_eq τ1 τ2
     | Tuple xs, Tuple ys =>
       zip_pred (fun e1 e2 => term_eq e1 e2) xs ys
     | ProjN i1 e1, ProjN i2 e2 =>
       N.eqb i1 i2 && term_eq e1 e2
     | Num x, Num y => eq x y
     | If0 c1 a1 b1, If0 c2 a2 b2 =>
       term_eq c1 c2 && term_eq a1 a2 && term_eq b1 b2
     | Op op1 a1 b1, Op op2 a2 b2 =>
       op_eq op1 op2 && term_eq a1 a2 && term_eq b1 b2
     | _, _ => false
     end.
Next Obligation.
  cbn.
Admitted.

Fixpoint is_value {I} `{FInt I} (e : Term) : bool :=
  match e with
  | Var x => true
  | Ann x x0 => false
  | Fix x x0 x1 => true
  | App x x0 => false
  | TAbs x => true
  | TApp x x0 => false
  | Tuple xs =>
    forallb is_value xs
  | ProjN x x0 => false
  | Num x => true
  | If0 x x0 x1 => false
  | Op x x0 x1 => false
  end.
*)


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From QuickChick Require Import QuickChick.
From adtind Require Import goal50.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma lfind_hyp_test : (@eq natural (count (insort (Nil) (Zero)) (Zero)) (Succ (Zero))).
Admitted.
QuickChick lfind_hyp_test.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_rfn_sel_con_reduce :
  forall T1 x1 L1 Ts1 T', T1 = (t_rfn_sel x1 L1 Ts1 T') ->
                     forall T2 T2' Ts2, T2 = t_con T2' Ts2 ->
                                   subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


Theorem nlem: forall p: Prop,
  ~~(p \/ ~p).
Proof.
  intros p.
  intros H.
  apply H.
  right.
  intros S.
  apply H.
  left. apply S.
Qed.