Require Import RamifyCoq.lib.List_ext.
Require Import RamifyCoq.sample_mark.env_unionfind_arr.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.path_lemmas.
Require Import RamifyCoq.graph.subgraph2.
Require Import RamifyCoq.graph.graph_relation.
Require Import RamifyCoq.graph.reachable_computable.
Require Import RamifyCoq.graph.UnionFind.
Require Import RamifyCoq.msl_application.UnionFindGraph.
Require Import RamifyCoq.msl_application.ArrayGraph.
Require Import RamifyCoq.floyd_ext.share.
Require Import RamifyCoq.sample_mark.spatial_array_graph.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.

Local Coercion UGraph_LGraph: Graph >-> LGraph.
Local Identity Coercion ULGraph_LGraph: LGraph >-> UnionFindGraph.LGraph.
Local Identity Coercion LGraph_LabeledGraph: UnionFindGraph.LGraph >-> LabeledGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.
Existing Instances maGraph finGraph liGraph.

Definition mallocN_spec :=
 DECLARE _mallocN
  WITH sh:wshare, n: Z
  PRE [ 67%positive OF tint]
     PROP (4 <= n <= Int.max_unsigned)
     LOCAL (temp 67%positive (Vint (Int.repr n)))
     SEP ()
  POST [ tptr tvoid ]
     EX v: pointer_val,
     PROP (malloc_compatible n (pointer_val_val v))
     LOCAL (temp ret_temp (pointer_val_val v))
     SEP (memory_block sh n (pointer_val_val v)).

Definition whole_graph sh g x := (@full_graph_at mpred SAGA_VST pointer_val (SAG_VST sh) g x).

Definition makeSet_spec :=
  DECLARE _makeSet
  WITH sh: wshare, V: Z
    PRE [_V OF tint]
      PROP (0 < V <= Int.max_signed / 8)
      LOCAL (temp _V (Vint (Int.repr V)))
      SEP ()
    POST [tptr vertex_type]
      EX g: Graph, EX rt: pointer_val,
      PROP (forall i: Z, 0 <= i < V -> vvalid g i)
      LOCAL (temp ret_temp (pointer_val_val rt))
      SEP (whole_graph sh g rt).

Definition find_spec :=
  DECLARE _find
  WITH sh: wshare, g: Graph, subsets: pointer_val, i: Z
    PRE [_subsets OF (tptr vertex_type), _i OF tint]
      PROP (vvalid g i)
      LOCAL (temp _subsets (pointer_val_val subsets); temp _i (Vint (Int.repr i)))
      SEP (whole_graph sh g subsets)
    POST [tint]
      EX g': Graph, EX rt: Z,
      PROP (uf_equiv g g' /\ uf_root g' i rt)
      LOCAL (temp ret_temp (Vint (Int.repr rt)))
      SEP (whole_graph sh g' subsets).

Definition union_spec :=
 DECLARE _Union
  WITH sh: wshare, g: Graph, subsets: pointer_val, x: Z, y: Z
  PRE [ _subsets OF (tptr vertex_type), _x OF tint, _y OF tint]
          PROP  (vvalid g x /\ vvalid g y)
          LOCAL (temp _subsets (pointer_val_val subsets); temp _x (Vint (Int.repr x)); temp _y (Vint (Int.repr y)))
          SEP   (whole_graph sh g subsets)
  POST [ Tvoid ]
        EX g': Graph,
        PROP (uf_union g x y g')
        LOCAL ()
        SEP (whole_graph sh g' subsets).

Definition Gprog : funspecs := ltac:(with_library prog [mallocN_spec; makeSet_spec; find_spec; union_spec]).

Fixpoint prog_list_helper (i: nat) (n: nat) : list (val * val) :=
  match n with
  | O => nil
  | S n' => if (le_dec i n') then (Vundef, Vundef) :: prog_list_helper i n'
            else (Vint (Int.repr (Z.of_nat (n'))), Vint (Int.repr 0)) :: prog_list_helper i n'
  end.

Definition progressive_list (i: nat) (n: nat) := rev (prog_list_helper i n).

Lemma progressive_list_repeat: forall n, list_repeat n (Vundef, Vundef) = progressive_list O n.
Proof.
  induction n; unfold progressive_list; simpl; auto. unfold progressive_list in IHn. rewrite <- IHn.
  change ((Vundef, Vundef) :: list_repeat n (Vundef, Vundef)) with (((Vundef, Vundef) :: nil) ++ list_repeat n (Vundef, Vundef)).
  change ((Vundef, Vundef) :: nil) with (list_repeat 1 (Vundef, Vundef)). rewrite !list_repeat_app. rewrite Nat.add_comm. auto.
Qed.

Lemma progressive_list_length: forall i n, length (progressive_list i n) = n.
Proof. intros. unfold progressive_list. rewrite rev_length. induction n; simpl; auto. destruct (le_dec i n); simpl; rewrite IHn; auto. Qed.

Definition progressive_array sh i V rt := data_at sh (tarray vertex_type V) (progressive_list (Z.to_nat i) (Z.to_nat V)) (pointer_val_val rt).

Lemma upd_Znth_twice: forall {A: Type} i (l: list A) v1 v2, 0 <= i < Zlength l -> upd_Znth i (upd_Znth i l v1) v2 = upd_Znth i l v2.
Proof.
  intros. unfold upd_Znth. f_equal; [|f_equal].
  - rewrite sublist0_app1.
    + rewrite sublist_same; auto. rewrite Zlength_sublist; omega.
    + rewrite Zlength_sublist; omega.
  - assert (Zlength (sublist 0 i l) = i) by (rewrite Zlength_sublist; omega). rewrite sublist_app2; rewrite H0. 2: omega.
    assert (i + 1 - i = 1) by omega. rewrite H1. clear H1. rewrite Zlength_app. rewrite H0. rewrite Zlength_cons. unfold Z.succ.
    rewrite Zlength_sublist; [|omega..]. assert (i + (Zlength l - (i + 1) + 1) - i = Zlength l - i) by omega. rewrite H1; clear H1.
    rewrite sublist_1_cons. rewrite sublist_same; [auto | omega |]. rewrite Zlength_sublist; omega.
Qed.

Lemma prog_list_helper_gt: forall i j n, (i >= n)%nat -> (j >= n)%nat -> prog_list_helper i n = prog_list_helper j n.
Proof. intros. revert i j H H0. induction n; intros; simpl; auto. destruct (le_dec i n), (le_dec j n); [exfalso; omega ..|]. f_equal. apply IHn; omega. Qed.

Lemma upd_Znth_progressive_list: forall i V,
    0 <= i < Z.of_nat V -> upd_Znth i (progressive_list (Z.to_nat i) V) (Vint (Int.repr i), Vint (Int.repr 0)) = progressive_list (Z.to_nat (i + 1)) V.
Proof.
  intros. induction V. 1: exfalso; simpl in H; intuition. rewrite Nat2Z.inj_succ in H. unfold Z.succ in H. unfold progressive_list. simpl. destruct (le_dec (Z.to_nat i) V).
  - destruct (le_dec (Z.to_nat (i + 1)) V).
    + simpl. assert (0 <= i < Z.of_nat V) by (apply inj_le in l0; rewrite Z2Nat.id in l0; omega). unfold progressive_list in IHV. rewrite <- IHV; auto.
      rewrite upd_Znth_app1; auto. change (rev (prog_list_helper (Z.to_nat i) V)) with (progressive_list (Z.to_nat i) V).
      rewrite Zlength_correct, progressive_list_length. auto.
    + assert (Z.to_nat (i + 1) > V)%nat by omega. apply inj_gt in H0. rewrite Z2Nat.id in H0. 2: omega. assert (i = Z.of_nat V) by omega. subst i.
      clear IHV l n H0 H. rewrite Nat2Z.id. simpl. rewrite upd_Znth_char.
      * f_equal. change 1 with (Z.of_nat 1). rewrite <- Nat2Z.inj_add, Nat2Z.id. f_equal. apply prog_list_helper_gt; omega.
      * change (rev (prog_list_helper V V)) with (progressive_list V V). rewrite Zlength_correct, progressive_list_length. auto.
  - exfalso. assert (Z.to_nat i > V)%nat by omega. apply inj_gt in H0. rewrite Z2Nat.id in H0; omega.
Qed.

Lemma progressive_nat_inc_list: forall n i, (i >= n)%nat -> map (fun x : Z => (Vint (Int.repr x), Vint (Int.repr 0))) (nat_inc_list n) = progressive_list i n.
Proof.
  induction n; intros; unfold progressive_list in *; simpl; auto. destruct (le_dec i n). 1: exfalso; omega. rewrite map_app. simpl. rewrite <- IHn; intuition.
Qed.

Lemma body_makeSet: semax_body Vprog Gprog f_makeSet makeSet_spec.
Proof.
  start_function. forward_call (sh, Z.mul V 8).
  - assert (Int.min_signed <= 8 <= Int.max_signed) by rep_omega.
    assert (Int.min_signed <= V <= Int.max_signed). {
      split; rewrite Z.le_lteq; left.
      - rep_omega.
      - apply Z.le_lt_trans with (Int.max_signed / 8); [intuition | apply Z.div_lt; omega].
    } rewrite !Int.signed_repr; auto. split. 1: omega.
    assert (Z.mul 8 (Int.max_signed /8) <= Int.max_signed) by (apply Z_mult_div_ge; intuition). rep_omega.
  - split. 1: omega. assert (Z.mul 8 (Int.max_signed /8) <= Int.max_signed) by (apply Z_mult_div_ge; intuition). rep_omega.
  - Intros rt.
    assert (memory_block sh (V * 8) (pointer_val_val rt) = data_at_ sh (tarray vertex_type V) (pointer_val_val rt)). {
      assert (memory_block sh (V * 8) (pointer_val_val rt) = memory_block sh (sizeof (tarray vertex_type V)) (pointer_val_val rt)). {
        simpl sizeof. rewrite Zmax0r. 2: intuition. assert (V * 8 = 8 * V)%Z by omega. rewrite H1. auto.
      } rewrite <- memory_block_data_at_; auto. apply malloc_compatible_field_compatible; auto.
      unfold malloc_compatible in *. destruct (pointer_val_val rt); auto. destruct H0. split; auto. simpl sizeof. rewrite Zmax0r; intuition.
    } rewrite H1. clear H1.
    assert (data_at_ sh (tarray vertex_type V) (pointer_val_val rt) = data_at sh (tarray vertex_type V) (progressive_list O (Z.to_nat V)) (pointer_val_val rt)). {
      unfold data_at_, field_at_, data_at. assert (default_val (nested_field_type (tarray vertex_type V) []) = list_repeat (Z.to_nat V) (Vundef, Vundef)) by reflexivity.
      rewrite H1. rewrite progressive_list_repeat. auto.
    } rewrite H1. clear H1.
    forward_for_simple_bound V
      (EX i: Z,
       PROP ()
       LOCAL (temp _subsets (pointer_val_val rt); temp _V (Vint (Int.repr V)))
       SEP (progressive_array sh i V rt)); unfold progressive_array.
    + destruct H. apply Z.le_trans with (Int.max_signed / 8); auto. rewrite Z.lt_eq_cases. left. apply Z_div_lt; intuition.
    + entailer.
    + Opaque Znth. forward. remember (Znth i (progressive_list (Z.to_nat i) (Z.to_nat V))) as lll. destruct lll. forward.
      assert (0 <= i < Zlength (progressive_list (Z.to_nat i) (Z.to_nat V))) by (split; [|rewrite Zlength_correct, progressive_list_length, Z2Nat.id]; omega).
      rewrite upd_Znth_same, upd_Znth_twice; [|auto ..]. unfold progressive_array, data_at.
      rewrite upd_Znth_progressive_list. 2: rewrite Z2Nat.id; omega. entailer. Transparent Znth.
    + forward. Exists (makeSet_discrete_Graph (Z.to_nat V)) rt. entailer!.
      * intros. simpl. rewrite makeSet_vvalid. rewrite Z2Nat.id; omega.
      * unfold whole_graph, full_graph_at. simpl. Exists (Z.to_nat V). apply andp_right; intros; [apply andp_right; apply prop_right|].
        -- intros. rewrite makeSet_vvalid. intuition.
        -- rewrite Z2Nat.id; omega.
        -- simpl. unfold vcell_array_at, SAG_VST. rewrite map_length, nat_inc_list_length. rewrite Z2Nat.id. 2: intuition.
           assert (map (fun x : Z => vgamma (makeSet_discrete_LabeledGraph (Z.to_nat V)) x) (nat_inc_list (Z.to_nat V)) =
                   map (fun x => (0%nat, x)) (nat_inc_list (Z.to_nat V))). {
             apply list_map_exten. intros. unfold vgamma, UnionFindGraph.vgamma. simpl. rewrite makeSet_dst. simpl. auto.
           } rewrite H6. clear H6. rewrite list_map_compose. unfold vgamma2cdata. simpl. rewrite <- progressive_nat_inc_list; intuition.
Qed.

Lemma whole_graph_fold: forall n sh g p,
    (forall v : Z, 0 <= v < Z.of_nat n <-> vvalid (lg_gg g) v) -> Z.of_nat n <= Int.max_signed / 8 ->
    data_at sh (tarray vertex_type (Z.of_nat n)) (map (fun x : Z => vgamma2cdata (vgamma (lg_gg g) x)) (nat_inc_list n)) (pointer_val_val p) = whole_graph sh g p.
Proof.
  intros. apply pred_ext; unfold whole_graph, full_graph_at, vcell_array_at, SAG_VST; [apply (exp_right n)|Intros n']; rewrite map_length, nat_inc_list_length, list_map_compose.
  - apply andp_right; auto. apply andp_right; apply prop_right; auto.
  - destruct (lt_eq_lt_dec n n') as [[? | ?] | ?]; [exfalso | subst n' | exfalso]; auto.
    + assert (vvalid (lg_gg g) (Z.of_nat n)) by (rewrite <- H1; intuition). rewrite <- H in H3. intuition.
    + assert (vvalid (lg_gg g) (Z.of_nat n')) by (rewrite <- H; intuition). rewrite <- H1 in H3. intuition.
Qed.

Lemma whole_graph_unfold: forall sh g p,
    whole_graph sh g p =
    EX n: nat, !! (forall v : Z, 0 <= v < Z.of_nat n <-> vvalid (lg_gg g) v) && !!(Z.of_nat n <= Int.max_signed / 8) &&
                  (data_at sh (tarray vertex_type (Z.of_nat n)) (map (fun x : Z => vgamma2cdata (vgamma (lg_gg g) x)) (nat_inc_list n)) (pointer_val_val p)).
Proof.
  intros. unfold whole_graph, full_graph_at, vcell_array_at, SAG_VST.
  apply pred_ext; Intros n; apply (exp_right n); apply andp_right; [apply andp_right; apply prop_right| |apply andp_right; apply prop_right|];
    auto; rewrite map_length, nat_inc_list_length, list_map_compose; auto.
Qed.

Lemma Znth_nat_inc_list: forall {A: Type} {d: Inhabitant A} n (f: Z -> A) i, 0 <= i < Z.of_nat n -> Znth i (map f (nat_inc_list n)) = f i.
Proof.
  intros. rewrite Znth_map. 2: rewrite Zlength_correct, nat_inc_list_length; auto. f_equal. induction n.
  - exfalso. simpl in H. intuition.
  - simpl. assert (0 <= i < Z.of_nat n \/ i = Z.of_nat n). {
      rewrite Nat2Z.inj_succ in H. destruct H. rewrite Z.lt_succ_r, Z.lt_eq_cases in H0. destruct H0; [left | right]; auto.
    } assert (Zlength (nat_inc_list n) = Z.of_nat n) by (rewrite Zlength_correct, nat_inc_list_length; auto). destruct H0.
    + rewrite app_Znth1. 2: rewrite H1; destruct H0; auto. apply IHn; auto.
    + rewrite app_Znth2. 2: rewrite H1; intuition. rewrite H0, H1. replace (Z.of_nat n - Z.of_nat n) with 0 by omega. rewrite Znth_0_cons. auto.
Qed.

Lemma graph_same_size: forall (g g': Graph) n n', (forall x : Z, vvalid g x <-> vvalid g' x) -> (forall v : Z, 0 <= v < Z.of_nat n' <-> vvalid (lg_gg g') v) ->
                                                  (forall v : Z, 0 <= v < Z.of_nat n <-> vvalid (lg_gg g) v) -> n = n'.
Proof.
  intros. assert (forall v, 0 <= v < Z.of_nat n' <-> 0 <= v < Z.of_nat n). intros. rewrite H0. rewrite H1. symmetry. apply H. clear -H2.
  destruct (lt_eq_lt_dec n n'); [destruct s|]; auto; exfalso.
  - specialize (H2 (Z.of_nat n)). omega.
  - specialize (H2 (Z.of_nat n')). omega.
Qed.

Lemma list_eq_Znth {A} {d: Inhabitant A}: forall (l1 l2: list A) n, length l1 = n -> length l2 = n -> (forall j, 0 <= j < Z.of_nat n -> Znth j l1 = Znth j l2) -> l1 = l2.
Proof.
  intros l1 l2 n. revert l1 l2. induction n; intros.
  - simpl in *. destruct l1, l2; simpl in *; [auto | exfalso; intuition..].
  - destruct l1, l2; simpl in H, H0; [exfalso; intuition..| ]. assert (a = a0) by (specialize (H1 0); rewrite !Znth_0_cons in H1; apply H1; rewrite Nat2Z.inj_succ; omega).
    subst a0. cut (l1 = l2); intros. 1: subst l2; auto. inversion H. inversion H0. apply (IHn _ _); auto. intros. specialize (H1 (j + 1)).
    assert (0 < j + 1) by omega. assert (j + 1 - 1 = j) by omega. rewrite !Znth_pos_cons in H1; auto. rewrite !H6 in H1. apply H1. rewrite Nat2Z.inj_succ. omega.
Qed.

Lemma upd_Znth_Graph_redirect_parent: forall (i root : Z) (g: Graph) n (Hw: weak_valid g root) (Hv: vvalid g i) (Hi: ~ reachable g root i),
    0 <= i < Z.of_nat n -> 0 <= root < Z.of_nat n -> upd_Znth i (map (fun m : Z => vgamma2cdata (vgamma (lg_gg g) m)) (nat_inc_list n))
                                                              (Vint (Int.repr root), Vint (Int.repr (Z.of_nat (vlabel (lg_gg g) i)))) =
                                                     map (fun m : Z => vgamma2cdata (vgamma (lg_gg (Graph_gen_redirect_parent g i root Hw Hv Hi)) m))(nat_inc_list n).
Proof.
  intros.
  assert (Zlength (map (fun m : Z => vgamma2cdata (vgamma (lg_gg g) m)) (nat_inc_list n)) = Z.of_nat n) by (rewrite Zlength_map, Zlength_correct, nat_inc_list_length; auto).
  apply (list_eq_Znth _ _ n).
  - rewrite <- (Nat2Z.id n) at 2. rewrite <- Zlength_length. 2: omega. rewrite upd_Znth_Zlength; auto. rewrite <- H1 in H. auto.
  - rewrite list_length_map, nat_inc_list_length; auto.
  - intros. rewrite Znth_nat_inc_list; auto. rewrite (upd_Znth_lookup' (Z.of_nat n)); auto. rewrite Znth_nat_inc_list; auto.
    unfold vgamma2cdata, vgamma, UnionFindGraph.vgamma. simpl. unfold graph_gen.updateEdgeFunc. unfold EquivDec.equiv_dec, Z_EqDec, zeq. destruct (Z.eq_dec j i).
    + subst j. destruct (Z.eq_dec i i). 2: exfalso; apply n0; auto. f_equal. destruct (Z_lt_dec root 0); [exfalso; omega | auto].
    + f_equal. destruct (Z.eq_dec i j). 1: exfalso; intuition. auto.
Qed.

Lemma body_find: semax_body Vprog Gprog f_find find_spec.
Proof.
  start_function. rewrite whole_graph_unfold. Intros n. forward.
  assert (H_BOUND: 0 <= i < Zlength (nat_inc_list n)) by (rewrite Zlength_correct, nat_inc_list_length, H0; assumption). forward.
  - apply prop_right. rewrite H0. auto.
  - rewrite <- (map_id (nat_inc_list n)) at 1. rewrite Znth_nat_inc_list. 2: rewrite H0; auto. simpl id.
    forward_if
      (EX g': Graph, EX rt: Z,
       PROP (uf_equiv g g' /\ uf_root g' i rt)
       LOCAL (temp _p (Vint (Int.repr rt)); temp _subsets (pointer_val_val subsets); temp _i (Vint (Int.repr i)))
       SEP (whole_graph sh g' subsets)).
    + rewrite whole_graph_fold; [|intuition..]. destruct (vgamma (lg_gg g) i) eqn: ?. forward_call (sh, g, subsets, z).
      * unfold vgamma, UnionFindGraph.vgamma in Heqp. inversion Heqp. clear Heqp. destruct (Z_lt_dec (dst (lg_gg g) i) 0). 1: exfalso; apply H2; auto.
        destruct ((proj2 (@only_one_edge _ _ _ _ _ _ (liGraph g) _ i H)) (eq_refl i)) as [_ ?]. destruct (valid_graph g _ H3) as [_ [? | ?]]; auto.
        hnf in H6. exfalso. apply n1. auto.
      * Intros vret. destruct vret as [g' root]. simpl fst in *. simpl snd in *. rewrite whole_graph_unfold. Intros n'. forward. Opaque Znth. forward. Transparent Znth.
        -- apply prop_right. rewrite H5. destruct H3. rewrite <- H3. auto.
        -- assert (n' = n). {
             destruct H3, (lt_eq_lt_dec n n'); [destruct s|]; auto; exfalso.
             - specialize (H3 (Z.of_nat n)). specialize (H0 (Z.of_nat n)). specialize (H5 (Z.of_nat n)). rewrite <- H0 in H3. rewrite <- H3 in H5. omega.
             - specialize (H3 (Z.of_nat n')). specialize (H0 (Z.of_nat n')). specialize (H5 (Z.of_nat n')). rewrite <- H0 in H3. rewrite <- H3 in H5. omega.
           } subst n'. assert (z <> i) by (unfold vgamma, UnionFindGraph.vgamma in Heqp; inversion Heqp; intro; apply H2; rewrite H9 in H7; rewrite H9; subst i; auto).
           assert (weak_valid g' root) by (right; destruct H4; apply reachable_foot_valid in H4; auto).
           assert (vvalid g' i) by (destruct H3 as [? _]; rewrite <- H3; apply H).
           assert (~ reachable g' root i) by (apply (uf_equiv_not_reachable g g' i n0 z root); auto).
           apply (exp_right (Graph_gen_redirect_parent g' i root H8 H9 H10)). apply (exp_right root). rewrite Znth_nat_inc_list. 2: rewrite H0; auto.
           Opaque vgamma2cdata. Opaque vgamma. entailer !; [split|]. Transparent vgamma. Transparent vgamma2cdata.
           ++ apply (graph_gen_redirect_parent_equiv g g' i n0 z); auto.
           ++ apply (uf_root_gen_dst_same g' (liGraph g') i i root); auto.
              ** rewrite <- (uf_equiv_root_the_same g g' i root); auto.
                 apply (uf_root_edge _ (liGraph g) _ z); [| apply (vgamma_not_dst g i n0 z) | rewrite (uf_equiv_root_the_same g g')]; auto.
              ** apply reachable_refl; auto.
           ++ rewrite whole_graph_unfold. apply (exp_right n). entailer. unfold vgamma2cdata at 2. unfold vgamma at 2. unfold UnionFindGraph.vgamma.
              cut ((upd_Znth i (map (fun x : Z => vgamma2cdata (vgamma (lg_gg g') x)) (nat_inc_list n))
                             (Vint (Int.repr root), Vint (Int.repr (Z.of_nat (vlabel (lg_gg g') i))))) =
                   (map (fun x : Z => vgamma2cdata (vgamma (lg_gg (Graph_gen_redirect_parent g' i root H8 H9 H10)) x)) (nat_inc_list n))); intros.
              ** rewrite <- H15. apply derives_refl.
              ** rewrite <- H0 in H. destruct H4. apply reachable_foot_valid in H4. rewrite <- H5 in H4. clear -H H4. rewrite <- upd_Znth_Graph_redirect_parent; auto.
    + unfold vgamma2cdata at 1. unfold vgamma at 1. unfold UnionFindGraph.vgamma. forward. rewrite whole_graph_fold; [|intuition..]. apply (exp_right g).
      simpl projT2. simpl id. apply (exp_right i). entailer !.
      split; [|split]. 1: apply (uf_equiv_refl _  (liGraph g)). 2: rewrite <- H2; reflexivity. destruct (Z_lt_dec (dst (lg_gg g) i) 0).
      * split. 1: apply reachable_refl; auto. intros. destruct H4 as [[? ?] ?]. destruct H4 as [[? ?] [? ?]]. simpl in H4. subst z. destruct l0.
        -- simpl in H5. auto.
        -- simpl in H6. destruct H6. assert (strong_evalid g z) by (destruct l0; [|destruct H6]; auto). destruct H8 as [? [? ?]]. symmetry in H4.
           destruct (@only_one_edge _ _ _ _ _ _ (liGraph g) _ z H) as [? _]. specialize (H11 (conj H4 H8)). simpl in H11. subst z. rewrite <- H0 in H10.
           destruct H10. assert (dst g i < 0) by apply l. exfalso; omega.
      * destruct (vvalid_src_evalid _ (liGraph g) i H) as [_ ?]. destruct (valid_graph g _ H4) as [_ [? | ?]]. 1: simpl in H5; exfalso; auto. simpl id in *.
        rewrite <- H0 in H5. rewrite <- H0 in H. apply repr_inj_unsigned in H2.
        -- exfalso. rewrite H0 in H. assert (reachable g i i) by (apply reachable_refl; auto). pose proof (dst_not_reachable _ (liGraph g) _ _ _ H H2 H6). auto.
        -- split. 1: omega. rewrite Z.lt_eq_cases. left. apply Z.lt_trans with (Int.max_signed / 8). 2: reflexivity. destruct H5. apply Z.lt_le_trans with (Z.of_nat n); auto.
        -- split. 1: omega. rewrite Z.lt_eq_cases. left. apply Z.lt_trans with (Int.max_signed / 8). 2: compute; auto. destruct H. apply Z.lt_le_trans with (Z.of_nat n); auto.
    + Intros g' rt. forward. apply (exp_right g'). apply (exp_right rt). entailer !.
Qed.

Lemma bounded_vertex: forall v n, 0 <= v < n -> n <= Int.max_signed / 8 -> Int.min_signed <= v <= Int.max_signed.
Proof.
  intros. destruct H. split.
  - apply Z.le_trans with 0; auto. rewrite Z.lt_eq_cases. left. apply Int.min_signed_neg.
  - apply Z.le_trans with n. 1: rewrite Z.lt_eq_cases; left; auto. apply Z.le_trans with (Int.max_signed / 8); auto. rewrite Z.lt_eq_cases; left. apply Z_div_lt; intuition.
Qed.

Lemma body_union: semax_body Vprog Gprog f_Union union_spec.
Proof.
  start_function. destruct H.
  forward_call (sh, g, subsets, x). Intros vret. destruct vret as [g1 x_root]. simpl fst in *. simpl snd in *.
  assert (vvalid g1 y) by (destruct H1 as [? _]; rewrite <- H1; apply H0).
  forward_call (sh, g1, subsets, y). Intros vret. destruct vret as [g2 y_root]. simpl fst in *. simpl snd in *.
  forward_if
    (PROP (x_root <> y_root)
     LOCAL (temp _yroot (Vint (Int.repr y_root)); temp _xroot (Vint (Int.repr x_root));
     temp _subsets (pointer_val_val subsets); temp _x (Vint (Int.repr x));
     temp _y (Vint (Int.repr y)))  SEP (whole_graph sh g2 subsets)).
  - forward. apply (exp_right g2). entailer. rewrite whole_graph_unfold. Intros n. apply prop_right. apply (the_same_root_union g g1 g2 x y y_root); auto.
    assert (x_root = y_root). {
      assert (Int.signed (Int.repr x_root) = Int.signed (Int.repr y_root)) by (rewrite H6; auto). rewrite !Int.signed_repr in H10; auto.
      - apply (bounded_vertex _ (Z.of_nat n)); auto. destruct H5. apply reachable_foot_valid in H5. rewrite <- H8 in H5; auto.
      - apply (bounded_vertex _ (Z.of_nat n)); auto. destruct H4. destruct H2. apply reachable_foot_valid in H2. rewrite H4 in H2. rewrite <- H8 in H2; auto.
    } subst y_root. apply H2.
  - forward. entailer!.
  - rewrite whole_graph_unfold. Intros n.
    assert (0 <= x_root < Z.of_nat n) by (destruct H4; destruct H2; apply reachable_foot_valid in H2; rewrite H4 in H2; rewrite <- H7 in H2; auto).
    assert (H_XROOT_BOUND: 0 <= x_root < Zlength (nat_inc_list n)) by (rewrite Zlength_correct, nat_inc_list_length; apply H9). forward.
    rewrite <- (map_id (nat_inc_list n)) at 1. rewrite Znth_nat_inc_list; auto. simpl id. unfold vgamma2cdata at 1. unfold vgamma at 1.
    unfold UnionFindGraph.vgamma. assert (0 <= y_root < Z.of_nat n) by (destruct H5; apply reachable_foot_valid in H5; rewrite <- H7 in H5; auto).
    assert (H_YROOT_BOUND: 0 <= y_root < Zlength (nat_inc_list n)) by (rewrite Zlength_correct, nat_inc_list_length; apply H10). forward.
    rewrite <- (map_id (nat_inc_list n)) at 1. rewrite Znth_nat_inc_list; auto. unfold vgamma2cdata at 1. unfold vgamma at 1. unfold UnionFindGraph.vgamma. simpl id.
    forward_if
      (EX g': Graph,
       PROP (uf_union g x y g')
       LOCAL (temp _yRank (Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) y_root)))); temp _xRank (Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) x_root))));
              temp _yroot (Vint (Int.repr y_root)); temp _xroot (Vint (Int.repr x_root)); temp _subsets (pointer_val_val subsets); temp _x (Vint (Int.repr x));
              temp _y (Vint (Int.repr y)))
       SEP (whole_graph sh g' subsets)).
    + Opaque Znth. forward. rewrite Znth_nat_inc_list; auto.
      assert (weak_valid g2 y_root) by (right; rewrite <- H7; auto). assert (vvalid g2 x_root) by (rewrite <- H7; auto).
      assert (~ reachable g2 y_root x_root) by (intro; destruct H5; specialize (H15 _ H14); auto).
      apply (exp_right (Graph_gen_redirect_parent g2 x_root y_root H12 H13 H14)). unfold vgamma2cdata at 2. unfold vgamma at 2. unfold UnionFindGraph.vgamma.
      Opaque vgamma2cdata. Opaque vgamma. entailer !. Transparent vgamma. Transparent vgamma2cdata.
      * apply (diff_root_union_1 g g1 g2 x y x_root y_root); auto.
      * rewrite whole_graph_unfold. apply (exp_right n). rewrite <- upd_Znth_Graph_redirect_parent; auto. entailer!.
    + assert (weak_valid g2 x_root) by (right; rewrite <- H7; auto). assert (vvalid g2 y_root) by (rewrite <- H7; auto).
      assert (~ reachable g2 x_root y_root) by (intro; rewrite (uf_equiv_root_the_same g1 g2) in H2; auto; destruct H2; specialize (H15 _ H14); auto).
      forward_if
        (EX g': Graph,
         PROP (uf_union g x y g')
         LOCAL (temp _yRank (Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) y_root)))); temp _xRank (Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) x_root))));
                temp _yroot (Vint (Int.repr y_root)); temp _xroot (Vint (Int.repr x_root)); temp _subsets (pointer_val_val subsets); temp _x (Vint (Int.repr x));
                temp _y (Vint (Int.repr y)))
         SEP (whole_graph sh g' subsets)).
      * forward. rewrite Znth_nat_inc_list; auto. apply (exp_right (Graph_gen_redirect_parent g2 y_root x_root H12 H13 H14)). unfold vgamma2cdata at 2. unfold vgamma at 2.
        unfold UnionFindGraph.vgamma. Opaque vgamma2cdata. Opaque vgamma. entailer!. Transparent vgamma. Transparent vgamma2cdata.
        -- apply (diff_root_union_2 g g1 g2 x y x_root y_root); auto.
        -- rewrite whole_graph_unfold. apply (exp_right n). rewrite <- upd_Znth_Graph_redirect_parent; auto. entailer!.
      * forward. rewrite Znth_nat_inc_list; auto. remember (Graph_gen_redirect_parent g2 y_root x_root H12 H13 H14) as g3.
        assert (uf_union g x y g3) by (rewrite Heqg3; simpl; apply (diff_root_union_2 g g1 g2 x y x_root y_root); auto).
        unfold vgamma2cdata at 2. unfold vgamma at 2. unfold UnionFindGraph.vgamma. forward. apply (exp_right (Graph_vgen g3 x_root ((vlabel (lg_gg g2) x_root) + 1)%nat)).
        Opaque vgamma2cdata. Opaque vgamma. entailer !. Transparent vgamma. Transparent vgamma2cdata.
        rewrite upd_Znth_diff; auto; [|rewrite Zlength_map, Zlength_correct, nat_inc_list_length; auto..]. rewrite Znth_nat_inc_list; auto.
        rewrite whole_graph_unfold. apply (exp_right n). entailer !.
        cut (upd_Znth x_root (upd_Znth y_root (map (fun x0 : Z => vgamma2cdata (vgamma (lg_gg g2) x0)) (nat_inc_list n))
                                        (Vint (Int.repr x_root), Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) y_root)))))
                       (let (x0, _) := vgamma2cdata (vgamma (lg_gg g2) x_root) in x0, Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) x_root) + 1))) =
             map (fun x0 : Z => vgamma2cdata (vgamma (lg_gg (Graph_vgen (Graph_gen_redirect_parent g2 y_root x_root H12 H13 H14) x_root
                                                                        (vlabel (lg_gg g2) x_root + 1)%nat)) x0)) (nat_inc_list n)); intros.
        -- rewrite <- H23. apply derives_refl.
        -- clear -H6 H9 H10. assert (Zlength (map (fun m : Z => vgamma2cdata (vgamma (lg_gg g2) m)) (nat_inc_list n)) = Z.of_nat n) by
               (rewrite Zlength_map, Zlength_correct, nat_inc_list_length; auto).
           assert (Zlength (upd_Znth y_root (map (fun x0 : Z => vgamma2cdata (vgamma (lg_gg g2) x0)) (nat_inc_list n))
                                     (Vint (Int.repr x_root), Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) y_root))))) = Z.of_nat n) by
               (rewrite upd_Znth_Zlength; auto; rewrite <- H in H10; auto). apply (list_eq_Znth _ _ n).
           ++ rewrite <- (Nat2Z.id n) at 2. rewrite <- Zlength_length. 2: omega. rewrite <- H in H10, H9. rewrite upd_Znth_Zlength; auto; rewrite upd_Znth_Zlength; auto.
           ++ rewrite list_length_map, nat_inc_list_length; auto.
           ++ intros. rewrite Znth_nat_inc_list; auto. rewrite (upd_Znth_lookup' (Z.of_nat n)); auto. rewrite (upd_Znth_lookup' (Z.of_nat n)); auto.
              rewrite Znth_nat_inc_list; auto. unfold vgamma2cdata, vgamma, UnionFindGraph.vgamma. simpl.
              unfold graph_gen.updateEdgeFunc, graph_gen.update_vlabel, EquivDec.equiv_dec, Z_EqDec, zeq. destruct (Z.eq_dec j x_root).
              ** subst j. destruct (Z.eq_dec y_root x_root). 1: exfalso; auto. destruct (Z.eq_dec x_root x_root). 2: exfalso; apply n1; auto. do 3 f_equal.
                 transitivity (Z.succ (Z.of_nat (vlabel (lg_gg g2) x_root))). 2: rewrite <- Nat2Z.inj_succ; f_equal; unfold Z_EqDec; omega. rewrite Z.add_1_r. auto.
              ** destruct (Z.eq_dec j y_root).
                 --- subst j. destruct (Z.eq_dec y_root y_root). 2: exfalso; apply n1; auto. destruct (Z.eq_dec x_root y_root). 1: exfalso; auto. destruct (Z_lt_dec x_root 0).
                     1: destruct H9; exfalso; omega. auto.
                 --- destruct (Z.eq_dec y_root j). 1: exfalso; apply n1; auto. destruct (Z.eq_dec x_root j). 1: exfalso; auto. auto.
    + Intros g'. forward. apply (exp_right g'). entailer!.
Qed.


(** * 6.887 Formal Reasoning About Programs, Spring 2017 - Pset 4 *)

Require Import Frap.

Set Implicit Arguments.

(* Authors: Adam Chlipala (adamc@csail.mit.edu), Peng Wang (wangpeng@csail.mit.edu) *)

(* A copy of the parallel transition-system combinator from TransitionSystem.v *)

Record threaded_state shared private := {
  Shared : shared;
  Private : private
}.

Inductive parallel1 shared private1 private2
  (init1 : threaded_state shared private1 -> Prop)
  (init2 : threaded_state shared private2 -> Prop)
  : threaded_state shared (private1 * private2) -> Prop :=
| Pinit : forall sh pr1 pr2,
  init1 {| Shared := sh; Private := pr1 |}
  -> init2 {| Shared := sh; Private := pr2 |}
  -> parallel1 init1 init2 {| Shared := sh; Private := (pr1, pr2) |}.

Inductive parallel2 shared private1 private2
          (step1 : threaded_state shared private1 -> threaded_state shared private1 -> Prop)
          (step2 : threaded_state shared private2 -> threaded_state shared private2 -> Prop)
          : threaded_state shared (private1 * private2)
            -> threaded_state shared (private1 * private2) -> Prop :=
| Pstep1 : forall sh pr1 pr2 sh' pr1',
  (* First thread gets to run. *)
  step1 {| Shared := sh; Private := pr1 |} {| Shared := sh'; Private := pr1' |}
  -> parallel2 step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
               {| Shared := sh'; Private := (pr1', pr2) |}
| Pstep2 : forall sh pr1 pr2 sh' pr2',
  (* Second thread gets to run. *)
  step2 {| Shared := sh; Private := pr2 |} {| Shared := sh'; Private := pr2' |}
  -> parallel2 step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
               {| Shared := sh'; Private := (pr1, pr2') |}.

Definition parallel shared private1 private2
           (sys1 : trsys (threaded_state shared private1))
           (sys2 : trsys (threaded_state shared private2)) := {|
  Initial := parallel1 sys1.(Initial) sys2.(Initial);
  Step := parallel2 sys1.(Step) sys2.(Step)
|}.

(* Now, we come to the main problem to be solved: prove the correctness of a
 * famous locking algorithm, applied to the particular example of incrementing a
 * counter from the lecture code.  Instead of assuming that a correct
 * implementation of locking is provided to us, we provide our own, on top of
 * basic atomic read/write operations on shared variables!
 * Specifically, we use Peterson's Algorithm, which you can read about here:
 *   https://en.wikipedia.org/wiki/Peterson%27s_algorithm *)

(** Instantiated to our setting, it's equivalent to this code.

  bool flag[2] = {false, false};
  bool turn = false;
  int global = 0;

  oneThread(me, other) {
    int local;

    flag[me] = true;
    turn = other;
    while (flag[other] && turn == other);
    local = global;
    global = local + 1;
    flag[me] = false;
  }

  The idea is that we run "oneThread(0, 1)" in parallel with "oneThread(1, 0)".
  After both threads finish, "global" had better be holding the value 2.
*)

(* We formalize local states with this type, standing for the different points
 * before, between, and after the lines of code, in order.  Note that, as with
 * the example from lecture, only the [Write] state needs to store the value of
 * variable "local". *)
Inductive increment_program :=
| SetFlag : increment_program
| SetTurn : increment_program
| ReadFlag : increment_program
| ReadTurn : increment_program
| Read : increment_program
| Write : nat -> increment_program
| UnsetFlag : increment_program
| Done : increment_program.

(* Record of global variables *)
Record inc_state := {
  Flag1 : bool;
  Flag2 : bool;
  (* The two cells of the "flag" array, represented as separate variables *)
  Turn : bool;
  (* Global variable "turn", representing with "false" for 0 and "true" for 1 *)
  Global : nat
  (* Global variable "global", represented more directly *)
}.

Definition increment_state := threaded_state inc_state increment_program.

(* The next two relations translate the single-thread code in a tedious way. *)

Inductive increment_init : increment_state -> Prop :=
| IncInit :
  increment_init {| Shared := {| Flag1 := false; Flag2 := false; Turn := false; Global := O |};
                    Private := SetFlag |}.

Inductive increment_step : bool (* This Boolean is set iff parameter "me" would
                                 * be 1. *)
                           -> increment_state -> increment_state -> Prop :=
| IncSetFlag1 : forall fl1 fl2 tu g,
  increment_step false
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := SetFlag |}
                 {| Shared := {| Flag1 := true; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := SetTurn |}
| IncSetFlag2 : forall fl1 fl2 tu g,
  increment_step true
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := SetFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := true; Turn := tu; Global := g |};
                    Private := SetTurn |}
| IncSetTurn : forall am2 fl1 fl2 tu g,
  increment_step am2
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := SetTurn |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := negb am2; Global := g |};
                    Private := ReadFlag |}
| IncReadFlag1True : forall fl1 fl2 tu g,
  fl2 = true
  -> increment_step false
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadTurn |}
| IncReadFlag1False : forall fl1 fl2 tu g,
  fl2 = false
  -> increment_step false
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Read |}
| IncReadFlag2True : forall fl1 fl2 tu g,
  fl1 = true
  -> increment_step true
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadTurn |}
| IncReadFlag2False : forall fl1 fl2 tu g,
  fl1 = false
  -> increment_step true
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := ReadFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Read |}
| IncReadTurnTrue : forall am2 fl1 fl2 g,
  increment_step am2
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := negb am2; Global := g |};
                    Private := ReadTurn |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := negb am2; Global := g |};
                    Private := ReadFlag |}
| IncReadTurnFalse : forall am2 fl1 fl2 g,
  increment_step am2
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := am2; Global := g |};
                    Private := ReadTurn |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := am2; Global := g |};
                    Private := Read |}
| IncRead : forall am2 fl1 fl2 tu g,
  increment_step am2
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Read |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Write g |}
| IncWrite : forall am2 fl1 fl2 tu g v,
  increment_step am2
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Write v |}
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := S v |};
                    Private := UnsetFlag |}
| IncUnsetFlag1 : forall fl1 fl2 tu g,
  increment_step false
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := UnsetFlag |}
                 {| Shared := {| Flag1 := false; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := Done |}
| IncUnsetFlag2 : forall fl1 fl2 tu g,
  increment_step true
                 {| Shared := {| Flag1 := fl1; Flag2 := fl2; Turn := tu; Global := g |};
                    Private := UnsetFlag |}
                 {| Shared := {| Flag1 := fl1; Flag2 := false; Turn := tu; Global := g |};
                    Private := Done |}.

Definition increment_sys am2 := {|
  Initial := increment_init;
  Step := increment_step am2
|}.

Definition increment2_sys := parallel (increment_sys false) (increment_sys true).

(* The natural correctness condition, looking nearly the same as for the example
 * from lecture *)
Definition increment2_correct (s : threaded_state inc_state (increment_program * increment_program)) :=
  s.(Private) = (Done, Done)
  -> s.(Shared).(Global) = 2.

Module Type S.
  Axiom increment2_ok :
    invariantFor increment2_sys increment2_correct.
End S.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C X X0 G Gprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ X0 A /\ (wd_ X0 C /\ (wd_ X B /\ (wd_ X C /\ (col_ X G A /\ (col_ X0 G B /\ (col_ X Gprime A /\ (col_ X0 Gprime B /\ (col_ C X0 A /\ (col_ C X B /\ col_ A X B))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Copyright © 2008-2008
 * Cezary Kaliszyk
 * Russell O'Connor
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Import Coq.QArith.QArith.
Require Import Coq.QArith.Qreals.
Require Import Coq.QArith.QArith_base.
Require Import CoRN.tactics.CornTac.
Require Import Coq.Reals.RIneq.
Require Import Coq.Reals.Rcomplete.
Require Import Coq.Reals.Rlimit.
Require Import Coq.Reals.Rbasic_fun.
Require Import CoRN.coq_reals.Rreals.
Require Import CoRN.reals.iso_CReals.
Require Import CoRN.reals.CauchySeq.
Require Import Coq.Reals.Rtrigo_def.
Require Import CoRN.transc.PowerSeries.
Require Import Coq.Logic.ConstructiveEpsilon.
Require Import Coq.Reals.Rlogic.
Require Export Coq.Reals.Reals.
Require Import CoRN.transc.Pi.
Require Import CoRN.transc.MoreArcTan.
Require Import CoRN.logic.PropDecid.
Require Import CoRN.transc.Exponential.
From Coq Require Import Lia Lra.

(* Backwards compatibility for Hint Rewrite locality attributes *)
Set Warnings "-unsupported-attributes".

(* This changed in RLogic and should probably be moved there: *)
Lemma forall_dec : forall P:nat->Prop, (forall n, {P n} + {~ P n}) -> {forall n, P n} + {~forall n, P n}.
intros.
case (sig_forall_dec _ H) as [[n H1] | H1];intuition.
Qed.

(** * Coq Real Numbers and IR isomorphisms

 Warning: The Coq real numbers depend on classical logic.  Importing this
 module will give you classical logic, the axioms of Coq's real number
 structure, plus all the logical consquences of these axioms.  To avoid
 these consequences, use CoRN's real number structure [IR] instead.

 All real number structures are isomorphic.  This module uses this
 isomorphis to create a rewrite database [RtoIR] for converting many
 problems over [R] into problems over [IR] where constructive methods
 may be employed.
*)

(** ** The isomorphism *)

Lemma RIR_iso : Isomorphism RReals IR.
Proof.
 exact (Canonic_Isomorphism_between_CReals RReals IR).
Qed.

Definition RasIR : R -> IR := iso_map_lft _ _ RIR_iso.
Definition IRasR : IR -> R := iso_map_rht _ _ RIR_iso.

Lemma RasIRasR_id : forall (x:R), (IRasR (RasIR x)=x).
Proof.
 apply (inversity_rht _ _ RIR_iso).
Qed.

Lemma IRasRasIR_id : forall (x:IR), (RasIR (IRasR x)[=]x).
Proof.
 apply (inversity_lft _ _ RIR_iso).
Qed.

(** equality *)

Lemma R_eq_as_IR : forall x y, (x = y -> RasIR x [=] RasIR y).
Proof.
 apply: map_wd_unfolded.
Qed.

(** apartness *)

Lemma R_eq_as_IR_back : forall x y, (RasIR x [=] RasIR y -> x = y).
Proof.
 intros x y H.
 replace x with (IRasR (RasIR x)) by apply RasIRasR_id.
 replace y with (IRasR (RasIR y)) by apply RasIRasR_id.
 apply: map_wd_unfolded; assumption.
Qed.

Lemma R_ap_as_IR : forall x y, (RasIR x [#] RasIR y -> x <> y).
Proof.
 intros x y H.
 replace x with (IRasR (RasIR x)) by apply RasIRasR_id.
 replace y with (IRasR (RasIR y)) by apply RasIRasR_id.
 change (IRasR (RasIR x) [#] IRasR (RasIR y)).
 apply: map_pres_apartness; assumption.
Qed.

Lemma R_ap_as_IR_back : forall x y, (x <> y -> RasIR x [#] RasIR y).
Proof.
 intros x y H.
 apply map_pres_apartness.
 assumption.
Qed.

Lemma IR_ap_as_R : forall x y, (x <> y -> RasIR x [#] RasIR y).
Proof.
 intro.
 apply: map_pres_apartness.
Qed.

(** less-than *)

Open Scope R_scope.

Lemma R_lt_as_IR : forall x y, (RasIR x [<] RasIR y -> x < y).
Proof.
 intros x y H.
 replace x with (IRasR (RasIR x)) by apply RasIRasR_id.
 replace y with (IRasR (RasIR y)) by apply RasIRasR_id.
 change (IRasR (RasIR x) [<] IRasR (RasIR y)).
 apply: map_pres_less; assumption.
Qed.

Lemma R_lt_as_IR_back : forall x y, (x [<] y -> IRasR x < IRasR y).
Proof.
 intros x y H.
 change (IRasR x [<] IRasR y).
 apply: map_pres_less.
 assumption.
Qed.

Lemma IR_lt_as_R : forall x y, (x < y -> RasIR x [<] RasIR y).
Proof.
 intro.
 apply: map_pres_less.
Qed.

Lemma IR_lt_as_R_back : forall x y, (IRasR x < IRasR y -> x [<] y).
Proof.
 intros.
 stepl (RasIR (IRasR x)); [| now apply IRasRasIR_id].
 stepr (RasIR (IRasR y)); [| now apply IRasRasIR_id].
 apply map_pres_less.
 assumption.
Qed.

(** le *)

Lemma R_le_as_IR : forall x y, (RasIR x [<=] RasIR y -> x <= y).
Proof.
 intros x y H.
 cut (~ (y < x)).
  apply Rnot_lt_le.
 intro xy.
 revert H. rewrite -> leEq_def. intro H. apply H.
 apply IR_lt_as_R.
 assumption.
Qed.

Lemma IR_le_as_R : forall x y, (x <= y -> RasIR x [<=] RasIR y).
Proof.
 intros x y H.
 rewrite -> leEq_def.
 intro xy.
 assert (~ (y < x)).
  apply RIneq.Rle_not_lt; assumption.
 apply H0.
 apply R_lt_as_IR.
 assumption.
Qed.

Lemma IR_le_as_R_back : forall x y, (IRasR x <= IRasR y -> x [<=] y).
Proof.
 intros.
 rewrite -> leEq_def.
 intro xy.
 cut (~ (IRasR y < IRasR x)); intro.
  apply H0.
  apply R_lt_as_IR.
  stepl y; [| now rewrite -> IRasRasIR_id; reflexivity].
  stepr x; [| now rewrite -> IRasRasIR_id; reflexivity].
  assumption .
 apply (RIneq.Rle_not_lt (IRasR y) (IRasR x)).
  assumption.
 assumption.
Qed.

(** zero *)

Lemma R_Zero_as_IR : (RasIR R0 [=] [0]).
Proof.
 apply map_pres_zero_unfolded.
Qed.

Lemma IR_Zero_as_R : (IRasR [0] = 0).
Proof.
 apply: map_pres_zero_unfolded.
Qed.

#[global]
Hint Rewrite R_Zero_as_IR : RtoIR.

(** one *)

Lemma R_One_as_IR : (RasIR R1 [=] [1]).
Proof.
 apply map_pres_one_unfolded.
Qed.

#[global]
Hint Rewrite R_One_as_IR : RtoIR.

Lemma IR_One_as_R : (IRasR [1] = R1).
Proof.
 apply: map_pres_one_unfolded.
Qed.

(** addition *)

Lemma R_plus_as_IR : forall x y, (RasIR (x+y) [=] RasIR x [+] RasIR y).
Proof.
 apply: map_pres_plus.
Qed.

#[global]
Hint Rewrite R_plus_as_IR : RtoIR.

Lemma IR_plus_as_R : forall x y, (IRasR (x[+]y) [=] IRasR x + IRasR y).
Proof.
 apply: map_pres_plus_unfolded.
Qed.

(** negation *)

Lemma R_opp_as_IR : forall x, (RasIR (- x) [=] ([--] (RasIR x))).
Proof.
 apply: map_pres_minus.
Qed.

#[global]
Hint Rewrite R_opp_as_IR : RtoIR.

Lemma IR_opp_as_R : forall x, (IRasR ([--] x) [=] (- (IRasR x))).
Proof.
 apply: map_pres_minus_unfolded.
Qed.

(** subtraction *)

Lemma R_minus_as_IR : forall x y, (RasIR (x-y) [=] RasIR x [-] RasIR y).
Proof.
 intros x y.
 unfold cg_minus.
 rewrite <- R_opp_as_IR.
 rewrite <- R_plus_as_IR.
 reflexivity.
Qed.

#[global]
Hint Rewrite R_minus_as_IR : RtoIR.

Lemma IR_minus_as_R : forall x y, (IRasR (x[-]y) [=] IRasR x - IRasR y).
Proof.
  intros x y.
  unfold Rminus.
  rewrite <- IR_opp_as_R.
  rewrite <- IR_plus_as_R.
  reflexivity.
Qed.

(** multiplication *)

Lemma R_mult_as_IR : forall x y, (RasIR (x*y) [=] RasIR x [*] RasIR y).
Proof.
 apply: map_pres_mult.
Qed.

#[global]
Hint Rewrite R_mult_as_IR : RtoIR.

Lemma IR_mult_as_R : forall x y, (IRasR (x[*]y) = IRasR x * IRasR y).
Proof.
 apply: map_pres_mult_unfolded.
Qed.

(** reciprocal *)

Lemma R_recip_as_IR : forall y Hy, (RasIR (1 / y) [=] ([1] [/] RasIR y [//] Hy)).
Proof.
 intros y Hy.
 simpl in Hy.
 assert (y [#] 0).
  apply: R_ap_as_IR.
  stepr ([0]:IR). assumption.
   symmetry.
  apply R_Zero_as_IR.
 change (1/y) with ([1] [/] y [//] X).
 eapply eq_transitive.
  unfold RasIR.
  apply (map_pres_inv_unfolded RReals IR).
 apply div_wd; reflexivity.
Qed.

#[global]
Hint Rewrite R_recip_as_IR : RtoIR.

(** division *)

Lemma R_div_as_IR : forall x y Hy, (RasIR (x/y) [=] (RasIR x [/] RasIR y [//] Hy)).
Proof.
 intros x y Hy.
 unfold Rdiv.
 rewrite -> R_mult_as_IR.
 rstepr ((RasIR x) [*] ([1] [/]RasIR y[//]Hy)).
 replace (/ y) with (1 / y).
  rewrite <- R_recip_as_IR; reflexivity.
 unfold Rdiv.
 ring.
Qed.

(** absolute value *)

Lemma R_abs_as_IR : forall x, RasIR (Rabs x) [=] AbsIR (RasIR x).
Proof.
 intro x.
 unfold Rabs.
 destruct (Rcase_abs x) as [Hx | Hx].
  cut (RasIR x[<=][0]).
   intro Hxn.
   rewrite -> (AbsIR_eq_inv_x (RasIR x) Hxn).
   autorewrite with RtoIR; reflexivity.
  stepr (RasIR 0); [| now apply R_Zero_as_IR].
  apply less_leEq.
  apply IR_lt_as_R.
  assumption.
 cut ([0] [<=] RasIR x).
  intro Hxn.
  rewrite -> (AbsIR_eq_x _ Hxn).
  reflexivity.
 stepl (RasIR 0); [| now apply R_Zero_as_IR].
 apply IR_le_as_R.
 lra.
Qed.
#[global]
Hint Rewrite R_abs_as_IR : RtoIR.

(** parital sum *)

Lemma R_sum_as_IR : forall a m,
    RasIR (sum_f_R0 a m) [=] (seq_part_sum (fun i : nat => RasIR (a i)) (S m)).
Proof.
 intros a m.
 induction m.
  simpl.
  rational.
 simpl.
 autorewrite with RtoIR.
 rewrite -> IHm.
 simpl.
 reflexivity.
Qed.

(** infinite sum *)

Lemma R_infsum_as_IR_convergent : forall (y: R) a,
  infinit_sum a y -> convergent (fun i : nat => RasIR (a i)).
Proof.
 unfold infinit_sum.
 unfold convergent.
 intros y a conv.
 assert (cauchy := CV_Cauchy _ (exist _ y conv)).
 clear conv.
 unfold Cauchy_crit in cauchy.
 unfold Cauchy_prop.
 intros e e0.
 pose (new_e0 := R_lt_as_IR_back _ _ e0).
 rewrite -> IR_Zero_as_R in new_e0.
 assert (sig (fun N => forall n m : nat, (n >= N)%nat ->
   (m >= N)%nat -> R_dist (sum_f_R0 a n) (sum_f_R0 a m) < IRasR e )).
  apply constructive_indefinite_description_nat.
   intros N.
   apply forall_dec.
    intros n0.
   apply forall_dec.
   intros n1.
   apply imp_dec.
    unfold ge.
    destruct (le_gt_dec N n0).
     left; auto with *.
    right; auto with *.
   apply imp_dec.
    destruct (le_gt_dec N n1).
     left; auto with *.
    right; auto with *.
   apply Rlt_dec.
  apply cauchy; auto with *.
 destruct H as [N HN].
 exists (S N).
 intros m Hm.
 assert (N <= pred m)%nat by  auto with *.
 assert (HH := HN (pred m) N H (le_refl N)).
 clear - HH Hm.
 destruct m.
  exfalso.
  auto with *.
 rewrite <- R_sum_as_IR.
 rewrite <- R_sum_as_IR.
 rewrite <- R_minus_as_IR.
 apply AbsIR_imp_AbsSmall.
 stepl (RasIR (Rabs(sum_f_R0 a m - sum_f_R0 a N))); [| now apply R_abs_as_IR].
 apply less_leEq.
 unfold R_dist in HH.
 stepr (RasIR (IRasR e)); [| now apply IRasRasIR_id].
 apply IR_lt_as_R.
 assumption.
Qed.

Lemma R_infsum_as_IR : forall (y: R) a,
  Rfunctions.infinit_sum a y -> forall prf,
  RasIR y [=] series_sum (fun i : nat => RasIR (a i)) prf.
Proof.
 intros y a Hay prf.
 unfold series_sum.
 unfold infinit_sum in *.
 apply Limits_unique.
 unfold Cauchy_Lim_prop2.
 simpl.
 clear prf.
 intros e He.
 assert (sig (fun N => forall n : nat, (n >= N)%nat -> R_dist (sum_f_R0 a n) y < IRasR e )).
  apply constructive_indefinite_description_nat.
   intros N.
   apply forall_dec.
   intros n0.
   apply imp_dec.
    unfold ge.
    destruct (le_gt_dec N n0).
     left; auto with *.
    right; auto with *.
   apply Rlt_dec.
  apply (Hay).
  unfold Rgt.
  apply R_lt_as_IR.
  stepl ([0]:IR); [| now symmetry;apply R_Zero_as_IR].
  stepr (e); [| now symmetry; apply IRasRasIR_id].
  assumption.
 destruct H as [N HN].
 exists (S N).
 intros m Hm.
 assert (N <= pred m)%nat.
  auto with *.
 assert (HH := HN (pred m) H).
 clear - HH Hm.
 destruct m.
  exfalso.
  auto with *.
 rewrite <- R_sum_as_IR.
 rewrite <- R_minus_as_IR.
 apply AbsIR_imp_AbsSmall.
 unfold R_dist in HH.
 simpl in HH.
 apply less_leEq.
 stepl (RasIR (Rabs(sum_f_R0 a m - y))); [| apply R_abs_as_IR].
 stepr (RasIR (IRasR e)); [| apply IRasRasIR_id].
 apply IR_lt_as_R.
 assumption.
Qed.

Lemma R_infsum_f_as_IR : forall (x y: R) f,
  Rfunctions.infinit_sum (f x) y -> forall prf,
  RasIR y [=] series_sum (fun i : nat => RasIR (f x i)) prf.
Proof.
 intros x y f cprf rprf.
 apply R_infsum_as_IR.
 assumption.
Qed.

(** factorial *)

Lemma R_nring_as_IR : forall i, RasIR (nring i) [=] nring i.
Proof.
 induction i.
  simpl.
  apply R_Zero_as_IR.
 simpl.
 autorewrite with RtoIR.
 rewrite -> IHi.
 reflexivity.
Qed.
#[global]
Hint Rewrite R_nring_as_IR : RtoIR.

Add Morphism RasIR with signature (@cs_eq _) ==> (@cs_eq _) as R_as_IR_wd.
Proof.
 intros.
 rewrite H.
 reflexivity.
Qed.

(** integers *)

Lemma R_pring_as_IR : forall x, RasIR (pring _ x) [=] pring _ x.
Proof.
 intro x.
 (*rewrite pring_convert.*)
 stepr (nring (R := IR) (nat_of_P x)).
  stepl (RasIR (nring (R := RReals) (nat_of_P x))).
   apply R_nring_as_IR.
  apply R_as_IR_wd.
  symmetry.
  apply (pring_convert RReals x).
 symmetry.
 apply (pring_convert IR x).
Qed.

Lemma R_zring_as_IR : forall x, RasIR (zring x) [=] zring x.
Proof.
 induction x; simpl.
   apply R_Zero_as_IR.
  apply R_pring_as_IR.
 rewrite -> R_opp_as_IR.
 rewrite -> R_pring_as_IR.
 reflexivity.
Qed.

Lemma INR_as_nring : forall x, INR x = nring (R:=RRing) x.
Proof.
 induction x.
  reflexivity.
 simpl nring.
 rewrite <- IHx.
 apply S_INR.
Qed.

Lemma IZR_as_zring : forall x, IZR x = zring (R:=RRing) x.
Proof.
 induction x.
   reflexivity.
  rewrite <- positive_nat_Z, <- INR_IZR_INZ.
  rewrite INR_as_nring.
  (* rewrite pring_convert *)
  symmetry.
  rewrite positive_nat_Z.
  apply (pring_convert RRing p).
 change (IZR (Zneg p)) with (Ropp (IZR (Zpos p))).
 rewrite <- positive_nat_Z, <- INR_IZR_INZ.
 rewrite INR_as_nring.
 apply Ropp_eq_compat.
 symmetry.
 apply (pring_convert RRing p).
Qed.

Lemma R_IZR_as_IR : forall x, RasIR (IZR x) [=] zring x.
Proof.
 induction x.
   apply R_Zero_as_IR.
  rewrite <- positive_nat_Z, <- INR_IZR_INZ.
  rewrite R_INR_as_IR.
  rewrite -> R_nring_as_IR.
  auto with *.
 change (IZR (Zneg p)) with (Ropp (IZR (Zpos p))).
 rewrite <- positive_nat_Z, <- INR_IZR_INZ.
 rewrite -> R_opp_as_IR.
 rewrite R_INR_as_IR.
 rewrite -> R_nring_as_IR.
 simpl zring.
 auto with *.
Qed.

#[global]
Hint Rewrite R_IZR_as_IR : RtoIR.

(** exponents *)

Lemma R_pow_as_IR : forall x i,
  RasIR (Rpow_def.pow x i)[=] nexp _ i (RasIR x).
Proof.
 intros x i.
 induction i.
  simpl.
  apply R_One_as_IR.
 simpl.
 autorewrite with RtoIR.
 rewrite -> IHi.
 auto with *.
Qed.
#[global]
Hint Rewrite R_pow_as_IR : RtoIR.

Lemma R_exp_as_IR : forall x, RasIR (exp x) [=] Exp (RasIR x).
Proof.
 unfold exp.
 unfold projT1.
 intro x; case (exist_exp x).
 unfold exp_in.
 intros y rsums.
 rewrite -> ( R_infsum_f_as_IR x y ((fun x i => / INR (fact i) * Rpow_def.pow x i)) rsums
   (R_infsum_as_IR_convergent _ _ rsums) ).
 simpl.
 apply series_sum_wd.
 intro i.
 autorewrite with RtoIR.
 replace (/ nring (fact i)) with (1 / nring (fact i)).
  2: field; apply (nring_fac_ap_zero RReals i).
 cut (Dom (f_rcpcl' IR) (RasIR (nring (R:=RRing) (fact i)))).
  intro Hy.
  rewrite -> (R_recip_as_IR (nring (fact i)) Hy).
  clear.
  rewrite -> (cg_inv_zero IR (RasIR x)).
  apply mult_wdl.
  apply div_wd.
   reflexivity.
  apply (R_nring_as_IR (fact i)).
 simpl.
 stepl (nring (R:=IR) (fact i)).
  apply (nring_fac_ap_zero IR i).
 symmetry.
 apply (R_nring_as_IR).
Qed.

#[global]
Hint Rewrite R_exp_as_IR : RtoIR.

(** trigonometry *)

Lemma R_cos_as_IR : forall x, RasIR (cos x) [=] Cos (RasIR x).
Proof.
 unfold cos.
 intro x.
 case (exist_cos (Rsqr x)).
 unfold cos_in.
 intros y rsums.
 rewrite -> (R_infsum_f_as_IR x y (fun x i => cos_n i * Rsqr x ^ i) rsums
   (R_infsum_as_IR_convergent _ _ rsums) ).
 simpl.
 unfold series_sum.
 apply Lim_seq_eq_Lim_subseq with (fun n => 2*n)%nat.
   intros; lia.
  intros n; exists (S n); lia.
 induction n.
  reflexivity.
 simpl in *.
 rewrite -> IHn.
 rewrite (plus_comm n (S (n + 0))).
 simpl.
 rstepr ( seq_part_sum (fun n0 : nat =>
   (cos_seq n0[/]nring (R:=IR) (fact n0)[//]nring_fac_ap_zero IR n0)[*]
     nexp IR n0 (RasIR x[-][0])) (n + 0 + n)[+] (
       (cos_seq (n + 0 + n)[/]nring (R:=IR) (fact (n + 0 + n))[//]
         nring_fac_ap_zero IR (n + 0 + n))[*]nexp IR (n + 0 + n) (RasIR x[-][0])[+]
           (cos_seq (S (n + 0 + n))[/]
             nring (R:=IR) (fact (n + 0 + n) + (n + 0 + n) * fact (n + 0 + n))[//]
               nring_fac_ap_zero IR (S (n + 0 + n)))[*]
                 (nexp IR (n + 0 + n) (RasIR x[-][0])[*](RasIR x[-][0]))) ).
 apply bin_op_wd_unfolded.
  rewrite plus_comm.
  reflexivity.
 replace (n + 0 + n)%nat with (n + n)%nat by auto with *.
 unfold Rsqr.
 unfold cos_n.
 simpl.
 unfold cos_seq.
 simpl.
 destruct (even_or_odd_plus (n + n)).
 destruct (even_or_odd_plus (S(n + n))).
 simpl.
 destruct s; [ | exfalso; auto with *].
 destruct s0; simpl.
  exfalso; auto with *.
 autorewrite with RtoIR.
 stepr ( (nexp IR x0 [--][1][/]nring (R:=IR) (fact (n + n))[//]
   nring_fac_ap_zero IR (n + n))[*]nexp IR (n + n) (RasIR x[-][0]) ).
  apply bin_op_wd_unfolded.
   replace (n + 0)%nat with n by auto with *.
   assert (Dom (f_rcpcl' IR) (RasIR (nring (R:=RRing) (fact (n + n))))).
    simpl.
    stepr (RasIR 0); [| now apply R_Zero_as_IR].
    apply R_ap_as_IR_back.
    apply (nring_fac_ap_zero RReals (n + n)).
   rewrite -> (R_div_as_IR ((-1)^n) (nring (R := RRing) (fact (n + n))) X).
   apply div_wd.
    autorewrite with RtoIR.
    replace n with x0 by lia.
    reflexivity.
   autorewrite with RtoIR.
   reflexivity.
  clear.
  induction n; simpl.
   reflexivity.
  rewrite -> IHn.
  replace (n + S n)%nat with (S (n + n))%nat by auto with *.
  simpl.
  rstepr ( nexp IR (n + n) (RasIR x[-][0])[*]((RasIR x[-][0])[*](RasIR x[-][0])) ).
  apply bin_op_wd_unfolded.
   reflexivity.
  rational.
 setoid_replace (([0][/]nring (R:=IR) (fact (n + n) + (n + n) * fact (n + n))[//]
   nring_fac_ap_zero IR (S (n + n)))[*] (nexp IR (n + n) (RasIR x[-][0])[*](RasIR x[-][0])))
     with ([0]:IR).
  rational.
 rational.
Qed.

#[global]
Hint Rewrite R_cos_as_IR : RtoIR.

Lemma R_sin_as_IR : forall x, RasIR (sin x) [=] Sin (RasIR x).
Proof.
 unfold sin.
 intro x.
 case (exist_sin (Rsqr x)).
 unfold sin_in.
 intros y rsums.
 rewrite -> R_mult_as_IR.
 rewrite -> (R_infsum_f_as_IR x y (fun x i => sin_n i * Rsqr x ^ i) rsums
   (R_infsum_as_IR_convergent _ _ rsums) ).
 assert (convergent (fun n : nat => RasIR x[*](fun i : nat => RasIR (sin_n i * Rsqr x ^ i)) n)).
  apply conv_series_mult_scal.
  apply (R_infsum_as_IR_convergent _ _ rsums).
 rewrite <- (series_sum_mult_scal (fun i : nat => RasIR (sin_n i * Rsqr x ^ i))
   (R_infsum_as_IR_convergent _ _ rsums) (RasIR x) X).
 simpl.
 unfold series_sum.
 apply Lim_seq_eq_Lim_subseq with (fun n => 2*n)%nat.
   intros; lia.
  intros n; exists (S n); lia.
 induction n.
  reflexivity.
 simpl in *.
 rewrite -> IHn.
 rewrite (plus_comm n (S (n + 0))).
 simpl.
 replace (n + 0 + n)%nat with (n + n)%nat by auto with *.
 unfold sin_n.
 simpl.
 replace (n + 0)%nat with (n)%nat by auto with *.
 unfold sin_seq at 3.
 unfold sin_seq at 3.
 simpl.
 destruct (even_or_odd_plus (n + n)).
 destruct (even_or_odd_plus (S(n + n))).
 destruct s; [ | exfalso; auto with *].
 destruct s0; simpl.
  exfalso; auto with *.
 rstepr ( seq_part_sum (fun n0 : nat =>
   (sin_seq n0[/]nring (R:=IR) (fact n0)[//]nring_fac_ap_zero IR n0)[*]
     nexp IR n0 (RasIR x[-][0])) (n + n)[+](
       ([0][/]nring (R:=IR) (fact (n + n))[//]nring_fac_ap_zero IR (n + n))[*]
         nexp IR (n + n) (RasIR x[-][0])[+]
           (nexp IR x1 [--][1][/]nring (R:=IR) (fact (n + n) + (n + n) * fact (n + n))[//]
             nring_fac_ap_zero IR (S (n + n)))[*]
               (nexp IR (n + n) (RasIR x[-][0])[*](RasIR x[-][0]))) ).
 apply bin_op_wd_unfolded.
  reflexivity.
 setoid_replace (RasIR x [-] [0]) with (RasIR x);[|rational].
 replace x1 with n by lia.
 clear.
 setoid_replace (([0][/]nring (R:=IR) (fact (n + n))[//]nring_fac_ap_zero IR (n + n))[*]
   nexp IR (n + n) (RasIR x)) with ([0]:IR);[|rational].
 rstepr ( RasIR x [*] ( (nexp IR n [--][1][/]nring (R:=IR) (fact (n + n) + (n + n) * fact (n + n))[//]
   nring_fac_ap_zero IR (S (n + n)))[*](nexp IR (n + n) (RasIR x))) ).
 apply bin_op_wd_unfolded.
  reflexivity.
 autorewrite with RtoIR.
 unfold Rsqr.
 apply bin_op_wd_unfolded.
  cut (Dom (f_rcpcl' IR) (RasIR (nring (R:=RRing) (fact (n + n + 1))))).
   intro X.
   rewrite -> (R_div_as_IR ((-1)^n) (nring (R:=RRing) (fact (n + n + 1))) X).
   apply div_wd.
    autorewrite with RtoIR; reflexivity.
   autorewrite with RtoIR.
   apply nring_wd.
   replace (n + n + 1)%nat with (S (n + n)) by lia.
   simpl.
   reflexivity.
  simpl.
  stepr (RasIR 0); [| now apply R_Zero_as_IR].
  apply R_ap_as_IR_back.
  apply (nring_fac_ap_zero RReals (n + n + 1)).
 induction n; simpl.
  reflexivity.
 replace (n + S n)%nat with (S(n + n)) by lia.
 simpl.
 rewrite -> IHn.
 autorewrite with RtoIR.
 rational.
Qed.

#[global]
Hint Rewrite R_sin_as_IR : RtoIR.

Lemma R_tan_as_IR : forall x dom, RasIR (tan x) [=] Tan (RasIR x) dom.
Proof.
 intros x dom.
 unfold tan.
 cut (Dom (f_rcpcl' IR) (RasIR (cos x))).
  intro Hdiv.
  rewrite -> (R_div_as_IR (sin x) (cos x) Hdiv).
  cut (Dom (f_rcpcl' IR) (Cos (RasIR x))).
   intro ndom.
   stepl (Sin(RasIR x) [/] Cos(RasIR x) [//] ndom).
    unfold Tan.
    unfold Tang.
    apply: div_wd.
     apply: pfwdef.
     reflexivity.
    apply: pfwdef.
    reflexivity.
   apply div_wd.
    symmetry; apply R_sin_as_IR.
   symmetry; apply R_cos_as_IR.
  unfold pfdom,f_rcpcl' in *.
  stepl (RasIR (cos x)); [| now apply R_cos_as_IR].
  assumption.
 unfold pfdom,f_rcpcl', Tang,Fdiv in *.
 destruct dom.
 destruct e.
 stepl (Cos (RasIR x)); [| now symmetry; apply R_cos_as_IR].
 apply: c.
Qed.

(** logarithm *)

Lemma R_ln_as_IR : forall x prf, RasIR (ln x) [=] Log (RasIR x) prf.
Proof.
 intros x prf.
 apply Exp_cancel.
 rewrite -> Exp_Log.
 rewrite <- R_exp_as_IR.
 apply R_as_IR_wd.
 apply exp_ln.
 apply R_lt_as_IR.
 stepl ([0]:IR); [| now symmetry; apply R_Zero_as_IR].
 assumption.
Qed.

(** pi *)

Lemma R_pi_as_IR : RasIR (PI) [=] Pi.
Proof.
 assert (Sin (RasIR PI) [=] [0]).
  rewrite <- R_sin_as_IR.
  rewrite sin_PI.
  apply R_Zero_as_IR.
 assert (Not (forall z : Z, RasIR PI[#]zring (R:=IR) z[*]Pi)).
  unfold Not.
  intro X.
  apply ((eq_imp_not_ap _ _ _ H) (Sin_ap_Zero (RasIR (PI)) X)).
 clear H.
 apply (not_ap_imp_eq).
 intro PiNot.
 elim H0.
 intro z.
 elim z.
   simpl.
   rstepr ([0]:IR).
   stepr (RasIR 0); [| now apply R_Zero_as_IR].
   apply R_ap_as_IR_back.
   apply PI_neq0.
  intro p.
  rewrite <- convert_is_POS.
  stepr (nring (R := IR) (nat_of_P p) [*] Pi); [| now apply mult_wdl; symmetry; apply (zring_plus_nat IR)].
  case (nat_of_P p).
   simpl.
   rstepr ([0]:IR).
   stepr (RasIR 0); [| now apply R_Zero_as_IR].
   apply R_ap_as_IR_back.
   apply PI_neq0.
  intro n.
  case n.
   simpl.
   rstepr (Pi).
   assumption.
  intro n0.
  apply less_imp_ap.
  apply leEq_less_trans with Four.
   rstepr (([1] [+] [1]) [*] ([1] [+] [1]):IR).
   rewrite <- R_One_as_IR.
   rewrite <- R_plus_as_IR.
   rewrite <- R_mult_as_IR.
   apply IR_le_as_R.
   apply PI_4.
  apply less_leEq_trans with (Two [*] Pi).
   rstepl (Two [*] Two:IR).
   apply mult_resp_less_lft.
    apply Pi_gt_2.
   rstepr (([0] [+] [1]) [+] [1] : IR).
   apply plus_one_ext_less.
   apply zero_lt_posplus1.
   apply eq_imp_leEq.
   reflexivity.
  apply mult_resp_leEq_rht.
   simpl.
   apply (plus_resp_leEq).
   apply (plus_resp_leEq).
   stepl (nring (R := IR) 0); [| now auto with *].
   apply nring_leEq; auto with *.
  apply less_leEq.
  apply pos_Pi.
 intro p.
 apply Greater_imp_ap.
 simpl.
 apply leEq_less_trans with ([0]:IR).
  rewrite -> pring_convert.
  apply less_leEq.
  apply inv_cancel_less.
  rstepl ([0][*][0]:IR).
  rstepr ((nring (R:=IR) (nat_of_P p))[*]Pi).
  apply mult_resp_less_both.
     apply eq_imp_leEq.
     reflexivity.
    rstepl (nring (R := IR) 0) .
    apply nring_less.
    auto with *.
   apply eq_imp_leEq.
   reflexivity.
  auto with *.
 stepl (RasIR 0); [| now apply R_Zero_as_IR].
 apply IR_lt_as_R.
 apply PI_RGT_0.
Qed.

Lemma R_pi_alt_as_IR : RasIR (Alt_PI) [=] pi.
Proof.
 unfold Alt_PI.
 unfold pi.
 destruct (exist_PI) as [x prf].
 unfold pi_series.
 unfold tg_alt in prf.
 unfold PI_tg in prf.
 rewrite -> R_mult_as_IR.
 apply mult_wd.
  change 4 with ((1 + 1) * (1 + 1)).
  rewrite -> R_mult_as_IR.
  rewrite -> R_plus_as_IR.
  rewrite -> R_One_as_IR.
  rational.
 rewrite -> (R_infsum_as_IR x ( (fun i : nat => (-1) ^ i * / INR (2 * i + 1))
   ) prf (R_infsum_as_IR_convergent _ _ prf) ).
 apply series_sum_wd.
 intro n.
 autorewrite with RtoIR.
 apply mult_wd.
  simpl; reflexivity.
 stepr (RasIR (1 / nring (R:=RRing) (2 * n + 1))).
  apply R_as_IR_wd.
  unfold Rdiv.
  simpl; auto with *.
 cut (n + (n + 0) + 1 = S (n + n))%nat.
  intro DF.
  cut (Dom (f_rcpcl' IR) (RasIR (nring (R:=RReals) (2 * n + 1)))).
   intro H.
   rewrite -> (R_recip_as_IR (nring (R:=RReals) (2 * n + 1)) H).
   apply div_wd.
    reflexivity.
   rewrite -> R_nring_as_IR.
   apply nring_wd.
   rewrite <- DF.
   simpl.
   auto.
  simpl.
  stepr (RasIR 0); [| now apply R_Zero_as_IR].
  apply R_ap_as_IR_back.
  apply Rgt_not_eq.
  rewrite DF.
  unfold Rgt.
  change ([0] [<] nring (R:=RRing) (S (n + n))).
  apply pos_nring_S.
 auto with *.
Qed.

#[global]
Hint Rewrite R_pi_as_IR : RtoIR.

(** rationals *)

Lemma R_Q2R_as_IR : forall q, RasIR (Q2R q) [=] inj_Q IR q.
Proof.
 intro q.
 destruct q.
 unfold Q2R.
 cut (Dom (f_rcpcl' IR) (RasIR (nring (R:=RRing) (nat_of_P Qden)))).
  intro Hy.
  stepr (RasIR (zring (R:=RRing) Qnum)[/]RasIR (nring (R:=RRing) (nat_of_P Qden))[//]Hy).
   stepl (RasIR (zring (R:=RRing) Qnum / nring (R:=RRing) (nat_of_P Qden))).
    apply (R_div_as_IR (zring Qnum) (nring (nat_of_P Qden))).
   apply R_as_IR_wd.
   unfold Rdiv.
   replace (nring (R:=RRing) (nat_of_P Qden)) with (INR (nat_of_P Qden)).
    replace (zring (R:=RRing) Qnum) with (IZR Qnum).
     now rewrite <- positive_nat_Z, INR_IZR_INZ.
    apply IZR_as_zring.
   apply INR_as_nring.
  apply div_wd.
   apply R_zring_as_IR.
  apply R_nring_as_IR.
 simpl.
 stepr (RasIR 0); [| now apply R_Zero_as_IR].
 apply IR_ap_as_R.
 apply Rgt_not_eq.
 unfold Rgt.
 replace 0 with (nring (R:=RRing) 0).
  change ((nring (R:=RRing) 0 [<] nring (R:=RRing) (nat_of_P Qden))).
  apply nring_less.
  auto with *.
 auto with *.
Qed.

#[global]
Hint Rewrite R_Q2R_as_IR : RtoIR.

Close Scope R_scope.


(*
 * Strong Normalization for Nested Relational Calculus.
 * Copyright Ezra Cooper, 2008-2020.
 *)

Load "eztactics.v".

Require Import Arith.
Require Import List.

Add LoadPath "Listkit" as Listkit.

Require Import Listkit.AllType.
Require Import Listkit.AllType.
Require Import Listkit.Foreach.
Require Import Listkit.Map.
Require Import Listkit.NthError.
Require Import Listkit.Sets.
Require Import Listkit.listkit.

Require Import OutsideRange.
Require Import Shift.
Require Import Term.
Require Import Typing.

Hint Rewrite map_length: map.

(*Section Subst.*)

(** Until I did all this, I didn't realize that substitution was a big
ask; a complex function with an algorithm in its own right. *)

Ltac map_lia :=
   autorewrite with map; lia.

(** * Simultaneous substitution of a list of terms beginning at De Bruijn index k *)
Fixpoint subst_env k vs tm {struct tm} :=
  match tm with
  | TmConst => tm
  | TmVar x =>
    if le_gt_dec k x then
      match nth_error vs (x - k) with
      | None => tm
      | Some v => v
      end
    else tm
  | TmPair l m => TmPair (subst_env k vs l) (subst_env k vs m)
  | TmProj b m => TmProj b (subst_env k vs m)
  | TmApp l m => TmApp (subst_env k vs l) (subst_env k vs m)
  | TmAbs n => TmAbs (subst_env (S k) (map (shift 0 1) vs) n)
  | TmNull => TmNull
  | TmSingle m => TmSingle (subst_env k vs m)
  | TmUnion m n => TmUnion (subst_env k vs m) (subst_env k vs n)
  | TmBind m K => TmBind (subst_env k vs m) (subst_env (S k) (map (shift 0 1) vs) K)
  | TmIf b m n => TmIf (subst_env k vs b) (subst_env k vs m) (subst_env k vs n)
  | TmTable ty => tm
  end.

Ltac break_ne :=
  match goal with
  | |- context C [nth_error (map ?f ?A) ?B]
  => rewrite nth_error_map
  | H: nth_error ?A ?B = ?C |- context C [nth_error ?A ?B]
  => rewrite H
  | |- context C [match nth_error ?A ?B with _ => _ end]
        => let a := fresh "a" in
           let b := fresh "b" in
           let c := fresh "c" in
           let d := fresh "d" in
              nth_error_dichotomize a b c d (* bounds is_error v v_def *)
        end.

(* This "magic" tactic is quite likely to solve goals involing subst_env. *)
Ltac magic :=
  (repeat double_case; simpl);
  (repeat (rewrite nth_error_map); simpl);
  (repeat breakauto; simpl);
  (repeat (rewrite nth_error_map); simpl);
  (repeat break_ne; simpl);
  try solve [auto | lia].

Lemma subst_env_nonfree_noop:
  forall N T env Vs n,
    Typing env N T ->
    n >= length env ->
      subst_env n Vs N = N.
Proof.
 induction N; simpl; intros T env Vs n tp n_big;
   auto; inversion tp; try (f_equal; eauto).
 (* Case TmVar *)
  break; [ | sauto].
  subst.
  case_eq (nth_error Vs (x - n)); [ | sauto].
  absurd (x < length env).
    efinish.
   efinish_new NthError.
 (* Case TmAbs *)
 eapply IHN; efinish.
 (* Case TmBind *)
 eapply IHN2 with (T:=TyList t).
  apply H3.
 simpl; lia.
Qed.

Lemma subst_env_closed_noop:
  forall N T Vs n,
    Typing nil N T ->
      subst_env n Vs N = N.
Proof.
 intros.
 eapply subst_env_nonfree_noop; eauto.
 simpl; lia.
Qed.

    (* env_typing Vs env' -> *)
    (* x < length Vs & x < length env' & Typing (TmVar x) T *)
Lemma subst_env_preserves_typing_var:
  forall x Vs env env' T k,
    env_typing Vs env' ->
    Typing (env ++ env') (TmVar x) T ->
    k = length env ->
      Typing env (subst_env k Vs (TmVar x)) T.
Proof.
 simpl; intros x Vs env env' T k Vs_tp tp k_eq; inversion tp; subst.
 destruct Vs_tp as [Vs_env'_equilong Vs_tp].
 destruct (le_gt_dec (length env) x).
 - (* Case x is beyond [length env] *)
   case_eq (nth_error Vs (x - length env));
     [intros v H_v | intros H_v]; auto.
   (* Obtained value v for x - length env in Vs. *)
    apply Weakening_closed.
    eapply foreach2_ty_member; eauto.
    auto with NthError.
   (* Bogus case of no value for x - length env. *)
   refute.
   apply nth_error_ok_rev in H0.
   apply <- nth_error_overflow in H_v.
   rewrite app_length in H0.
   lia.
 - (* Case of x in env. *)
  apply TVar.
  rewrite nth_error_ext_length in H0; auto.
Qed.

(**
       Vs :: env'
env, env' |- M       : T
env       |- M{Vs/k} : T    (where k = length env)
*)
Lemma subst_env_preserves_typing:
  forall M Vs env env' T k,
    env_typing Vs env' ->
    Typing (env ++ env') M T ->
    k = length env ->
      Typing env (subst_env k Vs M) T.
Proof.
 induction M; simpl; intros Vs env env' T k Vs_tp tp k_eq;
    inversion tp; subst; eauto.
 - (* Case TmVar *)
   eapply subst_env_preserves_typing_var; eauto.
 - (* Case TmAbs *)
   apply TAbs.
   replace (S (length env)) with (length (s::env)) by trivial.
   apply IHM with env'; trivial.
   erewrite env_typing_shift_noop; eauto.
 - (* Case TmBind *)
   eapply TBind; eauto using IHM1, IHM2.
   erewrite env_typing_shift_noop; eauto.
Qed.

(* Note: Used only in one place, in sn.v! *)
#[export] Hint Resolve subst_env_preserves_typing : Subst.

Lemma subst_nil :
  forall N k, subst_env k nil N = N.
Proof.
 induction N; intros k; simpl; try (solve [f_equal; eauto]).
 (* Case TmVar *)
 rewrite nth_error_nil.
 destruct (le_gt_dec k x); auto.
Qed.

Lemma subst_env_one:
  forall n n' M env,
    n = n' ->
    subst_env n (M::env) (TmVar n') = M.
Proof.
  intros.
  simpl.
  destruct (le_gt_dec n n'); try lia.
  replace (n' - n) with 0 by lia.
  auto.
Qed.

Lemma subst_env_noop:
  forall n x M,
    n <> x ->
    subst_env n (M::nil) (TmVar x) = TmVar x.
Proof.
 intros; simpl.
 break.
 - break_ne.
   { auto. }
   simpl in *.
   lia.
 - auto.
Qed.

(** If a variable is bigger than [q + length env] then it is untouched
 by substituting ([q], [env]). *)
(* TODO: This might be a lemma that would be immediate from a lemma about
   subst_env and freevars. *)
Lemma subst_env_big_var :
  forall q x env,
    q + length env <= x ->
      subst_env q env (TmVar x) = TmVar x.
Proof.
 intros.
 simpl.
 break; auto.
 nth_error_dichotomize bounds is_error v v_def; auto.
 finish.
Qed.

Lemma shift_subst_commute_hi_var:
  forall (x : nat) (env : list Term) (k q n : nat),
    q + length env <= k ->
    shift k n (subst_env q env (TmVar x)) =
    subst_env q (map (shift k n) env) (shift k n (TmVar x)).
Proof.
  intros.
  unfold shift at 3.
  unfold shift_var.
  destruct (le_gt_dec k x) ; [ | ].
   rewrite subst_env_big_var by lia.
   rewrite subst_env_big_var.
    simpl; unfold shift_var.
    break; finish.
   solve[map_lia].
  repeat (magic; unfold shift_var; simpl).
Qed.

Lemma shift_subst_commute_helper:
  forall M env k q n,
    subst_env q (map (shift (S k) n) (map (shift 0 1) env)) M =
    subst_env q (map (shift 0 1)     (map (shift k n) env)) M.
Proof.
  intros.
  f_equal.
  repeat (rewrite map_map).
  apply map_ext; intros x.
  apply shift_shift_commute.
  lia.
Qed.

Lemma shift_subst_commute_hi:
  forall M env k q n,
    q + length env <= k ->
    shift k n (subst_env q env M) =
      subst_env q (map (shift k n) env) (shift k n M).
Proof.
 induction M; intros env k q n k_overbounds_subst; simpl; try (f_equal; eauto).

 (* Case TmVar *)
- apply shift_subst_commute_hi_var; auto.

 (* Case TmAbs *)
 - rewrite IHM by map_lia.
   apply shift_subst_commute_helper.

 (* Case TmBind *)
 - rewrite IHM2 by map_lia.
   apply shift_subst_commute_helper.
Qed.

Lemma shift_subst_commute_lo:
  forall M env k q n,
    k <= q ->
    shift k n (subst_env q env M) =
      subst_env (q + n) (map (shift k n) env) (shift k n M).
Proof.
 induction M; simpl; intros env k q n k_low; try (f_equal; eauto).
 (* TmVar *)
        unfold shift_var.
        (* Take cases on where x is in relation to k, q: *)
        case_eq (le_gt_dec q x); intros;
          case_eq (le_gt_dec k x); intros; try (solve[exfalso;lia]);
          destruct (le_gt_dec (q + n) (x + n)); try (solve[exfalso;lia]).
        (* Case k <= q <= x. *)
          replace (x + n - (q + n)) with (x - q) by lia.
          (* Take cases on whether x - q is defined in env: *)
          nth_error_dichotomize index_hi result_none V V_def;
            rewrite nth_error_map ; (rewrite result_none || rewrite V_def);
          simpl; unfold shift_var.
          (* Case length env <= x - q. *)
           rewrite H0; sauto.
          (* Case x - q < length env. *)
          sauto.
        (* Case k <= x < q. *)
         simpl; unfold shift_var.
         solve [breakauto].
        (* Case x < k <= q. *)
        breakauto.
        simpl; unfold shift_var.
        rewrite H0; sauto.

 (* Case TmAbs *)
     rewrite IHM by lia.
     apply shift_subst_commute_helper.

 (* Case TmBind *)
 rewrite IHM2 by lia.
 apply shift_subst_commute_helper.
Qed.

(** If two successive substitutions are "independent" and adjacent then we can combine
   them into one (on a var). *)
Lemma subst_env_concat_TmVar:
  forall (x : nat) (Vs Ws : list Term) (env : list Ty) (k : nat),
    env_typing (Vs ++ Ws) env ->
    length (Vs ++ Ws) = length env ->
       subst_env k Vs (subst_env (k + length Vs) Ws (TmVar x)) =
       subst_env k (Vs ++ Ws) (TmVar x).
Proof.
 intros ? ? ? ? ? env_closed VsWs_env_equilong.
 unfold subst_env at 3.
 unfold subst_env at 2.
 unfold env_typing in *.

 case_eq (le_gt_dec k x); [intros k_le_x ?|intros x_gt_x H].
 (* Case k <= x *)
  replace (x - (k + length Vs)) with (x - k - length Vs) by lia.

  destruct (equilong_nth_error Term Ty (Vs ++ Ws) env (x - k))
        as [[x_small [VW' [T' HH]]] | [x_large HH]]; trivial;
    destruct HH as [lookup_VWs lookup_env].
  (* Case x < k + length (Vs ++ Ws) *)
   destruct (le_gt_dec (k + length Vs) x).
   (* Case k + length Vs <= x *)
    rewrite <- rewrite_nth_error_app; [|lia].
    rewrite lookup_VWs; simpl.
    (* subst_env k Vs VW' = VW': *)
    apply subst_env_closed_noop with T'.
    (* Typing nil VW' T': *)
    eapply foreach2_ty_member; eauto.
    apply env_closed.
   (* Case k + length Vs > x *)
   simpl; rewrite H.
   (rewrite nth_error_ext_length in lookup_VWs by lia);
   (rewrite nth_error_ext_length by lia; reflexivity).

  (* Case x >= k + length (Vs ++ Ws) *)
  rewrite app_length in x_large.
  rewrite <- rewrite_nth_error_app; [|lia].
  rewrite lookup_VWs; simpl.
  double_case.
  apply subst_env_big_var; lia.

 (* Case k > x *)
 break; [exfalso; lia| ].
 simpl.
 rewrite H; easy.
Qed.

(** If two successive substitutions are "independent" and adjacent then we can combine
   them into one. *)
Lemma subst_env_concat:
  forall N Vs Ws env k,
    env_typing (Vs ++ Ws) env->
    let k' := k + length Vs in
    let VWs := Vs ++ Ws in
      subst_env k Vs (subst_env k' Ws N) = subst_env k (VWs) N.
Proof.
 let triage := solve[simpl; f_equal; eauto] in
 induction N; intros Vs Ws env k env_closed;
     inversion env_closed as [VsWs_env_equilong env_closed'];
     trivial; try triage.

 (* Case TmVar *)
  eapply subst_env_concat_TmVar; eauto.

 (* Case TmAbs *)
  simpl; f_equal.
  rewrite map_app.
  replace (length Vs) with (length (map (shift 0 1) Vs)); [|apply map_length].
  replace (S (k + length (map (shift 0 1) Vs))) with
     (S k + length (map (shift 0 1) Vs)); [|easy].
  apply IHN with env; auto.
  rewrite <- map_app.
  erewrite env_typing_shift_noop; eauto.

 (* Case TmBind *)
 simpl; f_equal; eauto.
 rewrite map_app.
 replace (length Vs) with (length (map (shift 0 1) Vs)); [|apply map_length].
 replace (S(k + length (map (shift 0 1) Vs))) with
    (S k + length (map (shift 0 1) Vs)); [|easy].
 apply IHN2 with env; auto.
 rewrite <- map_app.
 erewrite env_typing_shift_noop; eauto.
Qed.

(** Shifting creates a term with a "dummy" (unused) variable;
    substituting at that variable has no effect, so we can drop it off
    the environment for substitution. *)
Lemma subst_dummyvar :
  forall N h t k,
    subst_env k (h::t) (shift k 1 N) = subst_env (S k) t (shift k 1 N).
Proof.
 induction N; intros h t1 k; try (solve[simpl; f_equal; eauto]).
 (* TmVar *)
 unfold shift, shift_var.
 destruct (le_gt_dec k x).
  unfold subst_env.
  replace (x + 1 - k) with (S (x - k)) by lia.
  replace (nth_error (h::t1) (S (x - k))) with (nth_error t1 (x - k)) by auto.
  replace (x + 1 - (S k)) with (x - k) by lia.
  repeat breakauto.
 unfold subst_env.
 repeat breakauto.
Qed.

Lemma subst_var_outside_range:
  forall q env x,
    outside_range q (length env + q) x = true ->
      subst_env q env (TmVar x) = TmVar x.
Proof.
 unfold outside_range.
 intros.
 simpl.
 magic.
 break_in H; lia. (* Maybe break should explore hypotheses anyway? *)
Qed.

Lemma subst_var_inside_range:
  forall q env x,
    outside_range q (length env + q) x = false ->
      exists X, value X = nth_error env (x - q) /\
                (subst_env q env (TmVar x)) = X.
Proof.
 unfold outside_range.
 intros.
 simpl.
 break_in H. (* If break_in were done in magic, whole proof would be automated. *)
 - magic.
   * break_in H; easy.
   * eauto.
 - easy.
Qed.

Definition set_remove := Listkit.Sets.set_remove.

(** [unshift q k] commutes with subst, if we offset the environment by
    [k] and [shift q k] all its terms.

    TODO: Consider making this use outside_range.
*)
Lemma subst_unshift :
  forall M env q k n,
    q <= n ->
    all_Type _ eq_nat_dec (fun x => Outside_Range q (k + q) x) (freevars M) ->
      subst_env n env (unshift q k M) =
      unshift q k (subst_env (n + k) (map (shift q k) env) M).
Proof.
 induction M; simpl; intros env q k n q_le_n fvs_dichot;
   try (apply all_Type_union_rev in fvs_dichot; destruct fvs_dichot);
   try (f_equal; eauto).
 (* Case TmVar *)
     assert (H : {x < q} + {x >= k + q}).
      unfold all_Type in fvs_dichot.
      apply fvs_dichot.
      simpl.
      auto.
     unfold unshift, shift, unshift_var, shift_var.
     simpl.
     rewrite nth_error_map.
     replace (x - (n + k)) with (x - k - n) by lia.

     destruct H.
     (* x < q *)
      break; break; break; try break; finish.
     (* x >= k + q *)
     destruct (le_gt_dec (k + q) x); [ | finish].
     destruct (le_gt_dec n (x - k)).
      destruct (le_gt_dec (n + k) x); [ | finish].
      nth_error_dichotomize bounds is_error v v_def.
       break; finish.
      rewrite unshift_shift; auto.
     destruct (le_gt_dec (n + k) x); [ finish | ].
     break; finish.

 (* Case TmAbs *)
  simpl in *.
  rewrite map_map.
  replace (map (fun x => shift 0 1 (shift q k x)) env)
     with (map (fun x => shift (S q) k (shift 0 1 x)) env)
       by (apply map_ext ; intro M'; apply shift_shift_commute; solve [auto|lia]).
  rewrite IHM.
    rewrite -> map_map; solve [trivial].
   solve [lia].

  (* Obligation: that if {x - 1 | x \in (S \\ {0})} is all outside [q, k + q),
     then {x | x \in S} is all outside [Sq, k + Sq). *)
  clear IHM.
  unfold all_Type in *.
  intros x H.
  destruct x.
   unfold Outside_Range.
   left; lia.
  specialize (fvs_dichot x).
  lapply fvs_dichot.
  unfold Outside_Range; firstorder lia.
  replace x with (pred (S x)) by lia.
  apply set_map_intro.
  solve [auto with Listkit].

 (* Case TmBind *)
 rewrite IHM2; (try lia || auto).
  f_equal.
  apply shift_subst_commute_helper.
 apply all_Type_map_fwd in a0.
 unfold all_Type.
 unfold all_Type in a0.
 intros.
 unfold Term.set_remove in a0.
 destruct (eq_nat_dec x 0).
  subst x.
  unfold Outside_Range.
  left; lia.
 specialize (a0 x).
 lapply a0.
  unfold Outside_Range.
  intros H0.
  destruct H0.
   left; lia.
  right; lia.
 apply set_remove_intro.
 intuition.

 (* Case TmIf *)
 apply all_Type_union_rev in a0 as [a0 a1].
 rewrite (IHM2 _ _ _ _); auto.
 apply all_Type_union_rev in a0 as [a0 a1].
 rewrite (IHM3 _ _ _ _); auto.
Qed.

Import Setoid.

Lemma union_distrib: forall A B C, eq_sets _ (A ∪ (B ∪ C)) ((A ∪ B) ∪ (A ∪ C)).
Proof.
 intros.
 split; solve_set_union_inclusion.
Qed.

(* Notation "{ q / env } M" := (subst_env q env M) (at level 100). *)
Notation "A ⊆ B" := (incl_sets nat A B) (at level 100).
Notation "A % x" := (Term.set_remove nat eq_nat_dec x A) (at level 100).

Lemma subst_freevars_binder:
 forall M env q,
 set_map Nat.eq_dec Init.Nat.pred
   ((set_unions nat Nat.eq_dec (map freevars (map (shift 0 1) env))
     ∪ set_filter nat
         (fun x : nat =>
          outside_range (S q) (length (map (shift 0 1) env) + S q) x)
         (freevars M)) % 0)
 ⊆ (set_unions nat Nat.eq_dec (map freevars env)
    ∪ set_filter nat (fun x : nat => outside_range q (length env + q) x)
        (set_map Nat.eq_dec Init.Nat.pred (freevars M % 0))).
Proof.
 intros M env q.

 (* consider that this works as well as the explicit rewrites below :-/ *)
 (* Hint Rewrite map_length map_map set_filter_map union_remove unions_remove map_union set_unions_map : idunno. *)
 (* autorewrite with idunno. *)

 rewrite map_length.
 rewrite map_map.
 rewrite set_filter_map.
 rewrite union_remove.
 rewrite unions_remove.
 rewrite map_map.
 rewrite map_union.
 rewrite set_unions_map.
 rewrite map_map.

 (* Corresponding sides of the union are \subseteq *)

 apply incl_sets_union.
 (* Left side *)
  rewrite <- filter_remove.
  set (f := fun x : nat => outside_range (S q) (length env + S q) x).
  set (g := fun x : nat => outside_range q (length env + q) (pred x)).
  rewrite filter_extensionality with (g:=g); [solve [auto with Listkit]|].
  intros.
  assert (x <> 0).
   apply set_remove_elim in H.
   intuition.
  unfold f, g.
  unfold outside_range.
  break; break; try (break; try break); auto; finish.
 (* Right side *)
 apply unions2_mor.
 apply compwise_eq_sets_map.
 intros x.
 setoid_replace (set_remove nat eq_nat_dec 0 (freevars (shift 0 1 x)))
        with (freevars (shift 0 1 x)).
 rewrite pred_freevars_shift; solve [auto with Listkit].
 solve[apply remove_0_shift_0_1].
Qed.

(** After making a substitution, the freevars of the result is:
     - the freevars of the original term,
     - less the range of variables we replaced
     - union the freevars of all the substituted terms.
 *)
Lemma subst_freevars:
  forall M env q,
    incl_sets _
      (freevars (subst_env q env M))
      (set_union eq_nat_dec
        (set_unions nat eq_nat_dec (map freevars env))
        (set_filter nat (fun x => outside_range q (length env + q) x) (freevars M))).
Proof.
 induction M; intros env q.
 (* Case TmConst *)
            simpl; solve [auto with Listkit].

 (* Case TmVar *)
           case_eq (outside_range q (length env + q) x); intro H.
           (* Case x is outside [q, k + q). *)
            rewrite subst_var_outside_range by trivial.
           simpl.
           rewrite H.
           apply incl_sets_union2.

           (* Case x is inside [q, k + q). *)
           destruct (subst_var_inside_range q env x H) as [M [H0 H1]].
           rewrite H1.
           apply incl_union_left.
           apply nth_error_set_unions with (n := x - q).
           rewrite nth_error_map.
           rewrite <- H0.
           sauto...

 (* Case TmPair *)
          simpl.
          rewrite IHM1 by auto.
          rewrite IHM2 by auto.
          rewrite set_filter_union.
          solve_set_union_inclusion. (* TODO: Make this opaque-ify anything that doesn't contain
                                           set_union *)

 (* Case TmProj *)
         simpl.
         apply IHM; auto.

 (* Case TmAbs *)
        simpl.
        rewrite IHM by auto.
        clear IHM.
        apply subst_freevars_binder; auto.

 (* Case TmApp *)
       simpl.
       rewrite IHM1 by auto.
       rewrite IHM2 by auto.
       setoid_rewrite set_filter_union.
       solve_set_union_inclusion.

 (* Case TmNull*)
      simpl.
      solve [auto with Listkit].

 (* Case TmSingle*)
     simpl.
     rewrite IHM.
     solve [auto with Listkit].

 (* Case TmUnion*)
    simpl.
    rewrite IHM1 by auto.
    rewrite IHM2 by auto.
    rewrite set_filter_union.
    solve_set_union_inclusion.

 (* Case TmBind *)
   simpl.
   rewrite IHM1 by auto.
   rewrite set_union_assoc.
   rewrite set_filter_union.

   rewrite <- set_union_assoc.
   remember (set_unions nat eq_nat_dec (map freevars env)).
   remember (set_filter nat (fun x : nat => outside_range q (length env + q) x)
            (freevars M1)).
   remember (set_filter nat (fun x : nat => outside_range q (length env + q) x)
              (set_map eq_nat_dec pred (freevars M2 % 0))).
   setoid_replace (s ∪ (l ∪ l0)) with ((s ∪ l) ∪ (s ∪ l0)) by (apply union_distrib).

   apply incl_sets_union; [| solve [auto with Listkit]].
   subst s l l0.

   rewrite IHM2.
   simpl.
   apply subst_freevars_binder.

 (* Case TmIf *)
  simpl.
  rewrite IHM1, IHM2, IHM3 by auto.
  rewrite set_filter_union.
  rewrite set_filter_union.
  solve_set_union_inclusion.

 (* Case TmTable *)
 simpl.
 solve [auto with Listkit].
Qed.

Lemma subst_unused_noop_binder:
 forall M : Term,
 (forall (env : list Term) (n : nat),
  all nat (fun x : nat => ~ in_env_domain n env x) (freevars M) ->
  subst_env n env M = M) ->
 forall (env : list Term) (n : nat),
 all nat (fun x : nat => ~ in_env_domain n env x)
  (set_map Nat.eq_dec Init.Nat.pred (freevars M % 0)) ->
 subst_env (S n) (map (shift 0 1) env) M = M.
Proof.
  intros M IHM env n H.
  rewrite IHM; [auto|].
  unfold all in *.
  intros.
  specialize (H (pred x)).
  unfold in_env_domain in *.
  destruct (eq_nat_dec x 0).
  { lia. }
  lapply H.
  { rewrite map_length.
    intros.
    lia. }
  apply set_map_intro.
  apply set_remove_intro.
  auto.
Qed.

Lemma subst_unused_noop:
  forall M env n,
    all nat (fun x => not (in_env_domain n env x)) (freevars M)
    -> subst_env n env M = M.
Proof.
 induction M; simpl; intros; try (
   try (rewrite all_union in H; destruct H);
   f_equal; auto
 ).
 (* Case TmVar *)
   assert (~in_env_domain n env x).
    unfold all in H.
    apply H.
    unfold set_In, In.
    auto.
   unfold in_env_domain in H0.
   break; auto.
   nth_error_dichotomize bounds is_error v v_def; finish.
 (* Case TmAbs *)
  apply subst_unused_noop_binder; auto.
 (* Case TmBind *)
 apply subst_unused_noop_binder; auto.

 (* Case TmIf *)
 apply all_union in H0; destruct H0.
 auto.
 apply all_union in H0; destruct H0.
 auto.
Qed.

Lemma subst_factor_binder:
  forall N m n env env',
  (forall (m n : nat) (env : set Term) (env' : list Term),
      all Term
        (fun z : Term =>
         all nat (fun x : nat => ~ in_env_domain m env' x) (freevars z)) env ->
      m + length env' <= n \/ n + length env <= m ->
      subst_env m (map (subst_env n env) env') (subst_env n env N) =
      subst_env n env (subst_env m env' N)) ->
  all Term
       (fun z : Term =>
        all nat (fun x : nat => ~ in_env_domain m env' x) (freevars z)) env ->
  m + length env' <= n \/ n + length env <= m ->
  subst_env (S m) (map (shift 0 1) (map (subst_env n env) env'))
    (subst_env (S n) (map (shift 0 1) env) N) =
  subst_env (S n) (map (shift 0 1) env)
    (subst_env (S m) (map (shift 0 1) env') N).
Proof.
 intros N m n env env' IHN H0 H1.
 replace (S m) with (m + 1) by lia.
 replace (S n) with (n + 1) by lia.
 rewrite map_map.
 rewrite map_ext with (g:=(fun x => subst_env (n + 1) (map (shift 0 1) env) (shift 0 1 x))).
  replace (map (fun x : Term => subst_env (n + 1) (map (shift 0 1) env) (shift 0 1 x)) env')
     with (map (subst_env (n + 1) (map (shift 0 1) env)) (map (shift 0 1) env')).
   apply IHN.

    (* Preservation of the free-variable relationship. *)
    unfold (*all_terms,*) all in H0 |- *.
    intros Z Z_source x x_free_in_Z.
    destruct (map_image _ _ (shift 0 1) Z env Z_source) as [X' [X_X'_eq X'_in_env]].
    pose (n0 := H0 X' X'_in_env (pred x)).
    subst Z.
    unfold in_env_domain in *.
    rewrite map_length.
    lapply n0.
     lia.
    apply freevars_shift in x_free_in_Z.
    apply set_map_image in x_free_in_Z.
    destruct x_free_in_Z as [x' [x'_def x'_in_X'_fvs]].
    subst x.
    replace (pred (shift_var 0 1 x')) with (x'); auto.
    unfold shift_var. break; lia.
   solve[map_lia].
  rewrite map_map; solve [trivial]...
 intro.
 rewrite shift_subst_commute_lo; [auto|].
 solve [lia]...
Qed.

Lemma subst_factor_var:
 forall x m n env env',
 (* If *)
 (* 1. All freevars of all items in env are not in the domain of env', *)
 all _ (fun z =>
            all _ (fun x => not (in_env_domain m env' x)) (freevars z)) env ->
 (* 2. and the domain (m,env') does not contain n, and (n,env) does not contain m,
    i.e. they are nonoverlapping: *)
 (m + length env' <= n \/ n + length env <= m) ->
 (* Then *)
 (* We can "commute" the two substitutions, with a modification to one: *)
   subst_env m (map (subst_env n env) env') (subst_env n env (TmVar x)) =
   subst_env n env (subst_env m env' (TmVar x)).
Proof.
  simpl.
  intros x m n env env' H0 H1.
(* Either we are in the range of [n x env] or we are in the range of
  [m x env'] or neither--since they don't overlap. *)
  set (P := m <= x < m + length env').
  set (Q := n <= x < n + length env).

  assert (H : not P /\ Q \/ P /\ not Q \/ not P /\ not Q).
  subst P Q.

  intuition.
    destruct (le_gt_dec x n);
      destruct (le_gt_dec x m);
      lia.
  destruct (le_gt_dec x n);
    destruct (le_gt_dec x m);
    lia.

  destruct H as [H | [H | H]].
  (* x is in the (n, env) range and not in (m, env') *)
  - destruct H; subst P Q.
    assert (H3: x - n < length env) by lia.
    destruct (nth_error_exists _ env (x - n) H3)
      as [v v_def].
    pose (v_fvs_notin_m_env' := nth_error_all _ _ _ _ _ v_def H0).
    clearbody v_fvs_notin_m_env'.

    assert (v_subst_env'_noop: forall f, subst_env m (map f env') v = v).
    { intro f.
      apply subst_unused_noop.
      rewrite in_env_domain_map.
      auto.
    }

    repeat magic.

  (* x is in the (m, env') range and not in (n, env) *)
  - destruct H; subst P Q.
    repeat magic.

  (* x is in the (m, env') range and not in (n, env) *)
  - destruct H; subst P Q.
    repeat magic.
Qed.

Lemma subst_factor :
  forall N m n env env',
    (* If *)
    (* 1. All freevars of all items in env are not in the domain of env', *)
    all _ (fun z =>
                all _ (fun x => not (in_env_domain m env' x)) (freevars z)) env ->
    (* 2. and the domain (m,env') does not contain n, and (n,env) does not contain m,
       i.e. they are nonoverlapping: *)
    (m + length env' <= n \/ n + length env <= m) ->
    (* Then *)
    (* We can "commute" the two substitutions, with a modification to one: *)
      subst_env m (map (subst_env n env) env') (subst_env n env N) =
      subst_env n env (subst_env m env' N).
(* TODO: reverse the orientation of that equation. *)
Proof.
 induction N; intros m n env env' H0 H1; simpl; try (solve[f_equal; auto using subst_factor_binder]).
 (* Case TmVar *)
 - apply subst_factor_var; auto.
 Qed.

(* Some notations might be nice, but I'm not sure I've got the right ones yet.

(*
Notation "N { M / x }" := (subst_env x (M :: nil) N) (at level 900). *)
Notation "{ x / env } N" := (subst_env x env N) (at level 100).
Notation "{ x :/ M } N" := (subst_env x (M :: nil) N) (at level 100).

Notation "^^ M" := (shift 0 1 M) (at level 98).
Notation ",, M" := (unshift 0 1 M) (at level 98).
*)

Lemma closing_subst_closes:
  forall vs ts m t,
    env_typing vs ts ->
    Typing ts m t ->
    Typing nil (subst_env 0 vs m) t.
Proof.
 intros.
 apply subst_env_preserves_typing with (env' := ts); simpl; auto.
Qed.

(*End Subst.*)