Require Import Equations.Equations.
Require Import Coq.Sorting.Sorted.
Require Import Permutation.
Require Import Coq.ZArith.Znat Coq.Numbers.NatInt.NZOrder.
Require Import Coq.Arith.PeanoNat.
Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.

Require Import msort.
Require Import aux_lemmas.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

 (** *** Functional models *)

Definition merge_spec : ident * funspec :=
  DECLARE _merge
    WITH A : val, B : val, res : val, cA : list val, cB : list val, shA : share, shB : share, sizeA : nat, sizeB : nat
    PRE [ tptr tint, tptr tint, tptr tint, tint, tint ]
      PROP   (readable_share shA; readable_share shB;
              Sorted (I_cmp Cle) cA; Sorted (I_cmp Cle) cB;
              1 <= Z.of_nat sizeA <= Int.max_signed; 1 <= Z.of_nat sizeB <= Int.max_signed;
              2 <= Z.of_nat sizeA + Z.of_nat sizeB <= Int.max_signed;
              Forall (fun x => is_int I32 Signed x) cA; Forall (fun x => is_int I32 Signed x) cB)
      PARAMS (A; B; res; Vint (Int.repr (Z.of_nat sizeA)); Vint (Int.repr (Z.of_nat sizeB)))
      SEP    (data_at shA (tarray tint (Z.of_nat sizeA)) cA A; data_at shB (tarray tint (Z.of_nat sizeB)) cB B;
              data_at Ews (tarray tint (Z.of_nat sizeA + Z.of_nat sizeB)) (list_repeat (sizeA + sizeB) Vundef) res)
    POST [ tvoid ]
      EX cRes : list val,
        PROP   (Permutation (cA ++ cB) cRes; Sorted (I_cmp Cle) cRes)
        RETURN ()
        SEP    (data_at shA (tarray tint (Z.of_nat sizeA)) cA A; data_at shB (tarray tint (Z.of_nat sizeB)) cB B;
                data_at Ews (tarray tint (Z.of_nat sizeA + Z.of_nat sizeB)) cRes res).

Definition msort_spec : ident * funspec :=
  DECLARE _msort
    WITH array : val, contents : list val, sh : share, size : nat, gv: globals
    PRE [ tptr tint, tint ]
      PROP    (readable_share sh; Forall (fun x => is_int I32 Signed x) contents; (Z.of_nat size * 4 <= Int.max_signed); (size > 0)%nat)
      PARAMS  (array; Vint (Int.repr (Z.of_nat size)))
      GLOBALS (gv)
      SEP     (data_at sh (tarray tint (Z.of_nat size)) contents array; mem_mgr gv)
    POST [ tptr tint ]
      EX res : val, EX cRes : list val,
        PROP   (Permutation contents cRes; StronglySorted (I_cmp Cle) cRes; res <> nullval)
        RETURN (res)
        SEP    (data_at sh (tarray tint (Z.of_nat size)) contents array;
                malloc_token Ews (tarray tint (Z.of_nat (Datatypes.length contents))) res * data_at Ews (tarray tint (Z.of_nat size)) cRes res; mem_mgr gv).

Definition Gprog : funspecs := ltac:(with_library prog [msort_spec; merge_spec]).

 (** *** Proof of merge *)

Lemma body_merge: semax_body Vprog Gprog f_merge merge_spec.
Proof.
start_function.
VST.floyd.forward.forward.
VST.floyd.forward.forward.
forward_for_simple_bound (Z.of_nat sizeA + Z.of_nat sizeB)
 (EX i : Z, EX x : nat, EX y : nat, EX cRes' : list val, (* i is the index in the loop and x/y are the positions in the respective array *)
   PROP (i <= (Z.of_nat sizeA + Z.of_nat sizeB); i = (Z.add (Z.of_nat x) (Z.of_nat y)); le x sizeA; le y sizeB;
        Zlength cRes' = i;
        Forall (fun a => Forall (I_cmp Cle a) (sublist x (length cA) cA)) cRes'; Forall (fun a => Forall (I_cmp Cle a) (sublist y (length cB) cB)) cRes';
        Sorted (I_cmp Cle) cRes';
        Forall (fun x => is_int I32 Signed x) cA; Forall (fun x => is_int I32 Signed x) cB;
        Permutation (sublist 0 x cA ++ sublist 0 y cB) cRes')
   LOCAL (temp _a (Vint (Int.repr (Z.of_nat sizeA)));
          temp _b (Vint (Int.repr (Z.of_nat sizeB)));
          temp _A A;
          temp _B B;
          temp _res res;
          temp _x (Vint (Int.repr (Z.of_nat x)));
          temp _y (Vint (Int.repr (Z.of_nat y))))
   SEP (data_at shA (tarray tint (Z.of_nat sizeA)) cA A; data_at shB (tarray tint (Z.of_nat sizeB)) cB B;
        data_at Ews (tarray tint (Z.of_nat sizeA + Z.of_nat sizeB)) (cRes' ++ (list_repeat (sizeA + sizeB - Z.to_nat i) Vundef)) res)).
   - (* initially the loop invariant is satisfied *)
     Exists 0%nat 0%nat (@nil val).
     entailer!.
     cbn.
     erewrite Coq.Arith.PeanoNat.Nat.sub_0_r.
     entailer!.
   - (* the loop body preserves the loop invariant *)
     Intros.
     forward_if
      (EX min : int, EX x' : nat, EX y' : nat, (* min is the minimum of the values at the current positions the in the two arrays. x' and y' are the new indices after the if  *)
        PROP (Sorted (I_cmp Cle) (cRes' ++ [Vint min]);
              Forall (fun x => is_int I32 Signed x) cA; Forall (fun x => is_int I32 Signed x) cB;
              Permutation (sublist 0 x' cA ++ sublist 0 y' cB) (cRes'++[Vint min]);
              (x' + y')%nat = ((x + y) + 1)%nat;
              (x <= x')%nat; (x' <= (NPeano.Nat.min (S x) (length cA)))%nat; (y <= y')%nat; (y' <= (NPeano.Nat.min (S y) (length cB)))%nat;
                 ((x < (length cA))%nat  /\ (y < (length cB))%nat  /\ min = I_min (Clt) (nth x cA Vundef) (nth y cB Vundef))
              \/ ((x >= (length cA))%nat /\ (y < (length cB))%nat  /\ min = force_int (nth y cB Vundef))
              \/ ((x < (length cA))%nat  /\ (y >= (length cB))%nat /\ min = force_int (nth x cA Vundef)))
        LOCAL (temp _a (Vint (Int.repr (Z.of_nat sizeA)));
                temp _b (Vint (Int.repr (Z.of_nat sizeB)));
                temp _A A;
                temp _B B;
                temp _res res;
                temp _x (Vint (Int.repr (Z.of_nat x')));
                temp _y (Vint (Int.repr (Z.of_nat y')));
                temp _i (Vint (Int.repr i)))
        SEP (data_at shA (tarray tint (Z.of_nat sizeA)) cA A; data_at shB (tarray tint (Z.of_nat sizeB)) cB B;
             data_at Ews (tarray tint ((Z.of_nat sizeA) + (Z.of_nat sizeB))) (cRes' ++ [Vint min] ++ list_repeat (sizeA + sizeB - (Z.to_nat i + 1)) Vundef) res)).
      + (* The end of A is not reached yet *)
        forward_if.
        * (* The end of B is not reached yet *)
          VST.floyd.forward.forward.
          { entailer!. eapply (Forall_is_int _ _ _ _ _ H4 H19 H16). }
          {
            VST.floyd.forward.forward.
            { entailer!. eapply (Forall_is_int _ _ _ _ _ H5 H23 H17). }
            {
              forward_if.
              { (* The current minimum is in A *)
                VST.floyd.forward.forward.
                VST.floyd.forward.forward.
                VST.floyd.forward.forward.
                Exists (force_int (nth x cA Vundef)) (S x) y.
                entailer!.
                {
                  repeat apply conj.
                  {
                    eapply append_sorted; [auto|].
                    erewrite int_id.
                    2: eapply (Forall_nth _ _); [eapply H4| eapply (Z_lt_length cA sizeA x H22 H16)].
                    eapply (Forall_sublist_cmp cRes' cA (I_cmp Cle) x Vundef).
                    { eapply (Z_lt_length cA sizeA x H22 H16). }
                    { auto. }
                  }
                  {
                    erewrite int_id.
                    2: eapply (Forall_nth _ _); [eapply H4| eapply (Z_lt_length cA sizeA x H22 H16)].
                    eapply sublist_permutation; [|easy].
                    eapply (Z_lt_length cA sizeA x H22 H16).
                  }
                  { epose (Z_lt_length cA sizeA x H22 H16). erewrite min_l; now easy. }
                  { epose (Z_lt_length cB sizeB y H25 H17). erewrite min_l; [lia|assumption]. }
                  {
                    left.
                    repeat apply conj.
                      { eapply (Z_lt_length cA sizeA x H22 H16). }
                      { eapply (Z_lt_length cB sizeB y H25 H17). }
                      {
                        do 2 erewrite <- Znth_nth_eq in H18.
                        unfold force_int.
                        destruct (nth x cA Vundef), (nth y cB Vundef); cbn in H18; try now auto.
                        { unfold I_min. cbn in *. destruct (Int.lt i i0); easy. }
                        { eapply (Z_lt_length cB sizeB y H25 H17). }
                        all: eapply (Z_lt_length cA sizeA x H22 H16).
                      }
                  }
                  { do 2 f_equal. lia. }
                }
                {
                  erewrite int_id.
                  2: eapply (Forall_nth _ _); [eapply H4| eapply (Z_lt_length cA sizeA x H22 H16)].
                  cbn.
                  erewrite <- Znth_nth_eq; [|eapply (Z_lt_length cA sizeA x H22 H16)].
                  erewrite list_invariant; [entailer!|lia|lia|].
                  erewrite <- Nat2Z.inj_add in H11.
                  erewrite Zlength_length_eq in H11.
                  lia.
                }
              }
              { (* The current minimum is in B *)
                VST.floyd.forward.forward.
                VST.floyd.forward.forward.
                VST.floyd.forward.forward.
                Exists (force_int (nth y cB Vundef)) (x) (S y).
                entailer!.
                {
                  erewrite int_id. 2: eapply (Forall_nth _ _); [eapply H5| eapply (Z_lt_length cB sizeB y H25 H17)].
                  repeat apply conj.
                  {
                    eapply append_sorted; [auto|].
                    eapply (Forall_sublist_cmp cRes' cB (I_cmp Cle) y Vundef).
                    { eapply (Z_lt_length cB sizeB y H25 H17). }
                    { auto. }
                  }
                  { eapply sublist_permutation2; [|easy]. eapply (Z_lt_length cB sizeB y H25 H17). }
                  { epose (Z_lt_length cA sizeA x H22 H16). erewrite min_l; [lia|assumption]. }
                  { epose (Z_lt_length cB sizeB y H25 H17). erewrite min_l ; now easy. }
                  {
                    left; repeat apply conj.
                      { eapply (Z_lt_length cA sizeA x H22 H16). }
                      { eapply (Z_lt_length cB sizeB y H25 H17). }
                      {
                        do 2 erewrite <- Znth_nth_eq in H18.
                        2: eapply (Z_lt_length cB sizeB y H25 H17).
                        2,3: eapply (Z_lt_length cA sizeA x H22 H16).
                        unfold force_int.
                        destruct (nth x cA Vundef), (nth y cB Vundef); cbn in H18; try now auto.
                        unfold I_min.
                        cbn in *.
                        destruct (Int.lt i i0); easy.
                      }
                  }
                  { do 2 f_equal. lia. }
                }
                {
                  erewrite int_id.
                  2: eapply (Forall_nth _ _); [eapply H5| eapply (Z_lt_length cB sizeB y H25 H17)].
                  cbn.
                  erewrite <- Znth_nth_eq; [|eapply (Z_lt_length cB sizeB y H25 H17)].
                  erewrite list_invariant2; [entailer!|lia|lia|].
                  erewrite <- Nat2Z.inj_add in H11.
                  erewrite Zlength_length_eq in H11.
                  lia.
                }
              }
            }
          }
        * (* The end of B has been reached *)
          VST.floyd.forward.forward.
          { entailer!. eapply (Forall_is_int _ _ _ _ _ H4 H19 H16). }
          {
            VST.floyd.forward.forward.
            VST.floyd.forward.forward.
            Exists (force_int (nth x cA Vundef)) (S x) y.
            entailer!.
            {
              erewrite int_id. 2: eapply (Forall_nth _ _); [eapply H4|eapply (Z_lt_length cA sizeA x H20 H16)].
              repeat apply conj.
              {
                eapply append_sorted; [auto|].
                eapply (Forall_sublist_cmp cRes' cA (I_cmp Cle) x Vundef).
                { eapply (Z_lt_length cA sizeA x H20 H16). }
                { auto. }
              }
              { eapply sublist_permutation; [|easy]. eapply (Z_lt_length cA sizeA x H20 H16). }
              { epose (Z_lt_length cA sizeA x H20 H16). erewrite min_l; now easy. }
              {
                epose (Z_ge_length cB sizeB y H23 H17).
                pose H23.
                erewrite Zlength_length_eq in e.
                eapply Nat2Z.inj in e.
                rewrite <- e in H10.
                erewrite min_r; [easy|lia].
              }
              {
                do 2 right. repeat apply conj.
                  { eapply (Z_lt_length cA sizeA x H20 H16). }
                  { eapply (Z_ge_length cB sizeB y H23 H17). }
                  { easy. }
              }
              { do 2 f_equal. lia. }
            }
            {
              erewrite int_id.
              2: eapply (Forall_nth _ _); [eapply H4|eapply (Z_lt_length cA sizeA x H20 H16)].
              cbn.
              erewrite <- Znth_nth_eq; [|eapply (Z_lt_length cA sizeA x H20 H16)].
              erewrite list_invariant; [entailer!|lia|lia|].
              erewrite <- Nat2Z.inj_add in H11.
              erewrite Zlength_length_eq in H11.
              lia.
            }
          }
      + (* The end of A has been reached *)
        forward_if.
        * (* The end of B is not reached yet *)
          VST.floyd.forward.forward.
          { entailer!. eapply (Forall_is_int _ _ _ _ _ H5 H22 H17). }
          {
            VST.floyd.forward.forward.
            VST.floyd.forward.forward.
            Exists (force_int (nth y cB Vundef)) (x) (S y).
            entailer!.
            {
              erewrite int_id.
              2: eapply (Forall_nth _ _); [eapply H5|eapply (Z_lt_length cB sizeB y H23 H17)].
              repeat apply conj.
              {
                eapply append_sorted; [auto|].
                eapply (Forall_sublist_cmp cRes' cB (I_cmp Cle) y Vundef).
                { eapply (Z_lt_length cB sizeB y H23 H17). }
                { auto. }
              }
              { eapply sublist_permutation2; [|easy]. eapply (Z_lt_length cB sizeB y H23 H17). }
              {
                epose (Z_ge_length cA sizeA x H20 H16).
                pose H20.
                erewrite Zlength_length_eq in e.
                eapply Nat2Z.inj in e.
                rewrite <- e in H9.
                erewrite min_r; [easy|lia].
              }
              { epose (Z_lt_length cB sizeB y H23 H17). erewrite min_l; now easy. }
              {
                right. left. repeat apply conj.
                { eapply (Z_ge_length cA sizeA x H20 H16). }
                { eapply (Z_lt_length cB sizeB y H23 H17). }
                { easy. }
              }
              { do 2 f_equal. lia. }
            }
            {
              erewrite int_id.
              2: eapply (Forall_nth _ _); [eapply H5|eapply (Z_lt_length cB sizeB y H23 H17)].
              cbn.
              erewrite <- Znth_nth_eq; [|eapply (Z_lt_length cB sizeB y H23 H17)].
              erewrite list_invariant2; [entailer!|lia|lia|].
              erewrite <- Nat2Z.inj_add in H11.
              erewrite Zlength_length_eq in H11.
              lia.
            }
          }
        * (* The end of B has been reached, too. This case will not be reached in the loop because then i >= sizeA + size B *)
          VST.floyd.forward.forward.
          lia.
      + Intros min x' y'.
        Exists x' y' (cRes' ++ [Vint min]).
        entailer!.
        { repeat apply conj.
          { erewrite Zlength_length_eq in H25. erewrite <- (Nat2Z.inj (length cA)); [lia|easy]. }
          { erewrite Zlength_length_eq in H28. erewrite <- (Nat2Z.inj (length cB)); [lia|easy]. }
          {
            erewrite Zlength_length_eq.
            erewrite <- Nat2Z.inj_add.
            erewrite app_length; cbn.
            erewrite Nat2Z.inj_add; cbn.
            f_equal.
            erewrite <- Zlength_length_eq.
            lia.
          }
          { now apply (Forall_min_invariant x x' y cA cB cRes' min H23 H19 H20 H4 H5 H). }
          {
            destruct (invariant_disj_equiv x y cA cB min) as [? _].
            apply (Forall_min_invariant y y' x cB cA cRes' min (H8 H23) H21 H22 H5 H4 H0 H13).
          }
        }
        {
          assert (((sizeA + sizeB)%nat - (Z.to_nat (Z.of_nat x + Z.of_nat y) + 1))%nat
                  = ((sizeA + sizeB)%nat - Z.to_nat (Z.of_nat x + Z.of_nat y + 1))%nat) by lia.
          rewrite H8.
          rewrite app_assoc.
          entailer!.
        }
 - Intros x y cRes'.
   Exists cRes'.
   entailer!.
    {
      assert (x = sizeA)%nat by lia; assert (y = sizeB)%nat by lia.
      rewrite H23 in H13; rewrite H24 in H13.
      unfold sublist in H13.
      erewrite Zlength_length_eq in H15; erewrite Zlength_length_eq in H18.
      eapply Nat2Z.inj in H15; eapply Nat2Z.inj in H18.
      rewrite <- H15 in H13; rewrite <- H18 in H13.
      do 2 erewrite firstn_length_eq in H13; [now cbn in H13|constructor|constructor|constructor].
    }
    {
      assert (sizeA + sizeB - Z.to_nat (Z.of_nat sizeA + Z.of_nat sizeB) = 0)%nat by lia.
      rewrite H23; cbn.
      erewrite app_nil_r.
      entailer!.
    }
Qed.

 (** *** Proof of msort *)

Lemma body_msort: semax_body Vprog Gprog f_msort msort_spec.
Proof.
start_function.
assert (sizeMax : (Z.of_nat size <= Int.max_signed)) by lia.
rename H1 into sizePos.
forward_if.
{
  (* The array has size 1 -> already sorted *)
  forward_call (tarray tint 1, gv).
  {
    repeat apply conj; destruct size; cbn; now try lia.
  }
  {
    Intros res.
    destruct (eq_dec res nullval).
    {
      rewrite e.
      forward_if (
        (PROP (res <> nullval)
        LOCAL (temp _res res)
        SEP ())).
      { forward_call 1; easy. }
      { contradiction. }
      { now Intros. }
    }
    {
      forward_if (
        (PROP (res <> nullval; length contents = size)
        LOCAL (temp _res res; gvars gv; temp _array array; temp _size (Vint (Int.repr (Z.of_nat size))))
        SEP (mem_mgr gv;
             malloc_token Ews (tarray tint (Z.of_nat size)) res * data_at_ Ews (tarray tint (Z.of_nat size)) res;
             data_at sh (tarray tint (Z.of_nat size)) contents array))).
        { forward_call 1; contradiction. }
        {
          VST.floyd.forward.forward.
          entailer!.
          { erewrite Zlength_length_eq in H6. now eapply Nat2Z.inj in H6. }
          {
            rewrite H1.
            entailer!.
          }
        }
        {
          Intros.
          VST.floyd.forward.forward.
          {
            entailer!.
            unfold Znth.
            destruct (zlt 0 0); [lia|].
            now dependent elimination H; cbn in *; [lia|].
          }
          {
            VST.floyd.forward.forward.
            VST.floyd.forward.forward.
            Exists res contents.
            entailer!.
            {
              destruct contents as [|]; cbn in *; [cbn in H1; lia|destruct contents; cbn in *; [|lia]].
              repeat constructor.
            }
            {
              destruct contents as [|]; cbn in *; [cbn in H1; lia|destruct contents; cbn in *; [|lia]].
              entailer!.
            }
          }
        }
    }
  }
}
{
  (* The array has size > 1 *)
  forward_call (tarray tint (Z.of_nat size), gv).
  {
    entailer!; cbn.
    erewrite Z.mul_comm.
    repeat f_equal.
    lia.
  }
  {
    repeat apply conj; destruct size; cbn; try lia; try reflexivity.
    unfold Int.max_signed, Int.half_modulus, Int.modulus in *; cbn in *.
    lia.
  }
  {
    Intros res.
    destruct (eq_dec res nullval).
    {
      rewrite e.
      forward_if (
        (PROP (res <> nullval)
        LOCAL (temp _res res)
        SEP ())
      ).
        { forward_call 1; easy. }
        { contradiction. }
        { now Intros. }
    }
    {
      forward_if (
        (PROP (res <> nullval; length contents = size)
         LOCAL (temp _res__1 res; gvars gv; temp _array array;
                temp _size (Vint (Int.repr (Z.of_nat size))))
         SEP (mem_mgr gv;
              malloc_token Ews (tarray tint (Z.of_nat size)) res *
              data_at_ Ews (tarray tint (Z.of_nat size)) res;
              data_at sh (tarray tint (Z.of_nat size)) contents array))).
        { forward_call 1; contradiction. }
        { VST.floyd.forward.forward. entailer!. erewrite Zlength_length_eq in H6. now eapply Nat2Z.inj in H6. }
        {
          Intros.
          forward_call (array, sublist 0 (size/2) contents, sh, (size / 2)%nat, gv).
          {
            unfold Int.mone in H2; destruct H2.
            assert (2 <> -1) by lia.
            apply H9.
            eapply (repr_inj_signed 2 (-1)); unfold repable_signed, Int.min_signed, Int.max_signed; easy.
          }
          {
            entailer!. cbn -[Nat.div Nat.modulo]. repeat f_equal.
            now eapply int_nat_div2_eq.
          }
          {
            entailer!.
            erewrite <- (firstn_length_eq contents (length contents)) at 4; [|lia].
            pose (le_plus_minus (length contents / 2) (length contents)).
            erewrite e at 4.
            {
              erewrite <- firstn_app.
              erewrite (split2_data_at_Tarray_app (Z.of_nat (length contents / 2))); [entailer!| |]; rewrite Zlength_length_eq; f_equal.
              1: rewrite firstn_length_le; try easy; eapply Nat_div_2_le.
              erewrite <- Nat2Z.inj_sub; [|eapply Nat_div_2_le].
              f_equal.
              erewrite firstn_length_le; [easy|].
              erewrite List.skipn_length; lia.
            }
            {
              eapply Nat_div_2_le.
            }
          }
          {
            repeat apply conj; [easy| | |].
            eapply (Forall_firstn_weaken (length contents)); [rewrite H2; eapply Nat_div_2_le|].
            rewrite firstn_length_eq; [easy|lia].
            eapply (Z.le_trans (Z.of_nat (size / 2) * 4) (Z.of_nat size * 4)); [|easy].
            eapply Z.mul_le_mono_nonneg; try lia.
            eapply Nat2Z.inj_le.
            eapply Nat_div_2_le.
            destruct size as [|[|]]; [lia|lia|].
            unfold gt, lt.
            assert (2 / 2 = 1)%nat; [now cbn|].
            rewrite <- H3 at 1.
            eapply Nat2Z.inj_le.
            repeat erewrite div_Zdiv; [|lia|lia].
            eapply Z.ge_le_iff; eapply Z_div_ge; lia.
          }
          {
            Intros vret0; destruct vret0 as [A cA].
            (* The first argument is the address of the second half of the input array *)
            forward_call ((field_address0 (tarray tint (Z.of_nat (Datatypes.length contents))) [ArraySubsc (Z.of_nat (Datatypes.length contents / 2))] array),
                          sublist (size/2) (length contents) contents, sh, (size / 2 + Nat.modulo size 2)%nat, gv).
            {
              repeat apply conj. 1,2,3: intros ?; unfold Int.mone;
              destruct H2 as [_ H20];
              assert (2 <> -1) by lia;
              apply H2;
              eapply (repr_inj_signed 2 (-1)); unfold repable_signed, Int.min_signed, Int.max_signed; easy.
              all: now eapply size_div2_mod2_int_range.
            }
            {
              entailer!. cbn -[Nat.div Nat.modulo]. repeat f_equal.
              {
                unfold Int.divs.
                repeat erewrite Int.signed_repr; unfold Int.max_signed, Int.half_modulus, Int.modulus in *; cbn in *; try lia.
                change ((fst (Nat.divmod (Datatypes.length contents) 1 0 1))) with ((length contents) / 2)%nat in *.
                rewrite Z.quot_div_nonneg; [|lia|lia]. Search Cop.sem_add_ptr_int field_address0.
                unfold field_address0 in *.
                unfold Cop.sem_add_ptr_int; cbn in *.
                destruct array; try easy; cbn in *.
                {
                  unfold field_compatible in *; cbn in *; easy.
                }
                {
                  unfold field_address0.
                  destruct (field_compatible0_dec _ _).
                  {
                    cbn; repeat f_equal.
                    unfold Ptrofs.mul.
                    f_equal.
                    autorewrite with norm.
                    erewrite Int.signed_repr.
                    unfold Ptrofs.unsigned.
                    repeat erewrite Ptrofs.unsigned_repr.
                    f_equal.
                    change ((fst (Nat.divmod (Datatypes.length contents) 1 0 1))) with ((length contents) / 2)%nat.
                    change 2 with (Z.of_nat 2).
                    now erewrite div_Zdiv; lia.
                    {
                      apply conj; eapply Z.ge_le_iff; [eapply Z_div_ge0; lia|].
                      unfold Ptrofs.max_unsigned, Ptrofs.modulus; cbn.
                      eapply (Zge_trans _  (Z.of_nat (Datatypes.length contents))); [lia|erewrite Z.ge_le_iff; eapply Z_div_2_le].
                    }
                    {
                      apply conj; unfold Ptrofs.max_unsigned, Ptrofs.modulus; cbn; lia.
                    }
                    {
                      apply conj; unfold Int.half_modulus, Int.modulus in *; cbn in *.
                      change 2 with (Z.of_nat 2); erewrite <- div_Zdiv; try lia.
                      eapply Z.ge_le_iff; eapply (Zge_trans _  (Z.of_nat (Datatypes.length contents))); [lia|eapply Z.ge_le_iff; eapply Z_div_2_le].
                    }
                  }
                  {
                    unfold field_compatible, isptr in H16.
                    easy.
                  }
                }
              }
              { now eapply int_nat_div2_mod2_eq. }
            }
            {
              entailer!.
              erewrite <- skipn_firstn.
              erewrite firstn_length_eq at 1; [|lia].
              erewrite <- Nat2Z.inj_sub; [|eapply Nat_div_2_le].
              erewrite <- Nat_div_2.
              entailer!.
              unfold sublist.
              erewrite (firstn_length_eq contents (Datatypes.length contents)); [|lia].
              entailer!.
            }
            {
              repeat apply conj; [easy| | |].
              {
                unfold sublist.
                erewrite firstn_length_eq; [|lia].
                change contents with (skipn 0 contents) in H.
                eapply Forall_skipn_weaken in H; [eapply H|lia].
              }
              {
                eapply (Z.le_trans _ (Z.of_nat size * 4)); [|easy].
                erewrite <- Nat_div_2.
                lia.
              }
              {
                unfold gt.
                erewrite <- Nat_div_2.
                eapply ArithProp.lt_minus_O_lt.
                eapply Nat_div_2_lt; lia.
              }
            }
            {
              Intros vret; destruct vret as [B cB].
              forward_call (A,B,res,cA,cB,Ews,Ews,(Nat.div size 2),(Nat.div size 2 + Nat.modulo size 2)%nat).
              {
                repeat apply conj. 1,2,5: intros ?; unfold Int.mone;
                destruct H2 as [_ ?];
                assert (2 <> -1) by lia;
                try apply H2;
                try eapply (repr_inj_signed 2 (-1)); unfold repable_signed, Int.min_signed, Int.max_signed; easy.
                all: now eapply size_div2_mod2_int_range.
              }
              {
                entailer!. cbn -[Nat.div Nat.modulo]. repeat f_equal.
                { now eapply int_nat_div2_eq. }
                { now eapply int_nat_div2_mod2_eq. }
              }
              {
                erewrite <- Nat_div_2.
                erewrite <- Nat2Z.inj_add.
                erewrite <- le_plus_minus; [|eapply Nat_div_2_le].
                unfold data_at_, field_at_. cbn.
                erewrite Nat2Z.id.
                entailer!.
              }
              {
                assert (1 <= Z.of_nat (size / 2 + size mod 2)).
                {
                  eapply Z2Nat.inj_le; [lia|lia|].
                  cbn -[Nat.div Nat.modulo].
                  erewrite Nat2Z.id.
                  erewrite <- Nat_div_2.
                  eapply ArithProp.lt_minus_O_lt.
                  eapply Nat_div_2_lt; lia.
                }
                assert (1 <= Z.of_nat (size / 2)).
                {
                  assert (1 = 2 / 2) by (cbn; lia).
                  rewrite H10.
                  erewrite div_Zdiv; [cbn -[Z.div]|lia].
                  eapply Z_div_le; lia.
                }
                repeat apply conj; try easy; auto; try lia; cbn [snd] in *.
                1,2: now eapply StronglySorted_Sorted.
                {
                  erewrite div_Zdiv; [cbn|lia].
                  eapply (Z.le_trans _ (Z.of_nat size)); [eapply Z_div_2_le|unfold Int.max_signed, Int.half_modulus, Int.modulus in *; cbn in *; lia].
                }
                {
                  eapply (Z.le_trans _ (Z.of_nat size * 4)); [|easy].
                  erewrite <- Nat_div_2.
                  lia.
                }
                {
                  erewrite <- Nat_div_2.
                  erewrite <- Nat2Z.inj_add.
                  erewrite <- le_plus_minus; [lia|eapply Nat_div_2_le].
                }
                all: eapply Permutation_Forall.
                1: exact H3.
                2: exact H6.
                { unfold sublist; cbn; now eapply Forall_firstn. }
                { unfold sublist; cbn; eapply Forall_skipn; erewrite firstn_length_eq; [easy|lia]. }
              }
              {
                Intros merged.
                forward_call (tarray tint (Z.of_nat (Datatypes.length (firstn (fst (Nat.divmod (Datatypes.length contents) 1 0 1)) contents))), A, gv).
                {
                  cbn [fst] in *.
                  destruct (eq_dec A nullval); [easy|].
                  erewrite firstn_length_le; [|eapply Nat_div_2_le].
                  entailer!.
                }
                {
                  forward_call (tarray tint (Z.of_nat (Datatypes.length contents / 2 + Datatypes.length contents mod 2)), B, gv).
                  {
                    cbn [fst] in *.
                    destruct (eq_dec B nullval); [easy|].
                    entailer!.
                    erewrite <- Nat_div_2.
                    erewrite firstn_length_eq; [|lia].
                    erewrite List.skipn_length.
                    change (fst (Nat.divmod (Datatypes.length contents) 1 0 1)) with (length contents / 2)%nat.
                    entailer!.
                  }
                  {
                    VST.floyd.forward.forward.
                    Exists res merged.
                    entailer!.
                    {
                      apply conj.
                      {
                        cbn [snd] in *; unfold sublist in *.
                        erewrite firstn_length_eq in H6.
                        cbn [skipn] in H3.
                        epose (Permutation_app H3 H6).
                        erewrite firstn_skipn in p.
                        eapply (Permutation_trans p H9).
                        lia.
                      }
                      {
                        now eapply (Sorted_StronglySorted I_cmp_le_trans).
                      }
                    }
                    {
                      erewrite <- Nat2Z.inj_add.
                      erewrite <- le_plus_minus; [|eapply Nat_div_2_le].
                      entailer!.
                      erewrite sepcon_comm.
                      erewrite Nat2Z.inj_sub; [|eapply Nat_div_2_le].
                      erewrite <- (split2_data_at_Tarray_app (Z.of_nat (length contents / 2)) (Z.of_nat (Datatypes.length contents)) sh tint _ _ array).
                      {
                        erewrite firstn_skipn.
                        entailer!.
                      }
                      {
                        erewrite Zlength_length_eq; f_equal.
                        erewrite firstn_length_le; [easy|eapply Nat_div_2_le].
                      }
                      {
                        erewrite Zlength_length_eq.
                        erewrite <- Nat2Z.inj_sub; [f_equal|eapply Nat_div_2_le].
                        now erewrite skipn_length.
                      }
                    }
                  }
                }
              }
            }
          }
        }
    }
  }
}
Qed.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*             Yannick Forster            [+]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*                             [+] Affiliation Saarland Univ. *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

From Undecidability.Shared.Libs.DLW
  Require Import utils_tac.

Require Import Undecidability.Synthetic.Undecidability.
Require Import Undecidability.Synthetic.ReducibilityFacts.

From Undecidability.PCP              Require Import PCP PCP_undec.
From Undecidability.StackMachines    Require Import BSM.
From Undecidability.MinskyMachines   Require Import MM.

From Undecidability.ILL
  Require Import EILL ILL iBPCP_MM MM_EILL EILL_ILL.

Require Import Undecidability.PCP.Reductions.HaltTM_1_to_PCPb.

Import ReductionChainNotations UndecidabilityNotations.

(* The reduction chain from the CPP 2019, Y. Forster & D. Larchey-Wendling *)

Theorem PCP_chain_ILL :
  ⎩ PCP ⪯ₘ PCPb ⪯ₘ iPCPb ⪯ₘ BSM_HALTING ⪯ₘ MM_HALTS_ON_ZERO ⪯ₘ EILL_PROVABILITY ⪯ₘ ILL_PROVABILITY ⎭.
Proof.
  msplit 5; ( apply PCP_chain_iPCPb || apply iBPCP_chain_MM || idtac).
  + apply MM_HALTS_ON_ZERO_EILL_PROVABILITY.
  + apply EILL_ILL_PROVABILITY.
Qed.

Check PCP_chain_ILL.

(* Undecidability results *)

Local Hint Resolve EILL_rILL_cf_PROVABILITY
                   EILL_rILL_PROVABILITY
                   EILL_ILL_cf_PROVABILITY
                 : core.

(* EILL provability using G_eill *)

Theorem EILL_undec : undecidable EILL_PROVABILITY.
Proof. undec from PCP_undec using chain PCP_chain_ILL. Qed.

(* whole ILL with cut *)

Theorem ILL_undec : undecidable ILL_PROVABILITY.
Proof. undec from PCP_undec using chain PCP_chain_ILL. Qed.

(* whole ILL without cut *)

Theorem ILL_cf_undec : undecidable ILL_cf_PROVABILITY.
Proof. undec from EILL_undec; auto. Qed.

(* (!,&,-o) fragment of ILL without cut *)

Theorem rILL_cf_undec : undecidable rILL_cf_PROVABILITY.
Proof. undec from EILL_undec; auto. Qed.

(* (!,&,-o) fragment of ILL with cut *)

Theorem rILL_undec : undecidable rILL_PROVABILITY.
Proof. undec from EILL_undec; auto. Qed.


From Undecidability.FOL Require Import Syntax.Facts Semantics.Tarski.FullFacts Syntax.BinSig Semantics.FiniteTarski.Full.
From Undecidability.TRAKHTENBROT Require bpcp. (* keep this Require to avoid universe problems *)
From Undecidability.TRAKHTENBROT Require Import fo_sat fo_sig fo_terms fo_logic fol_ops.
Require Import Undecidability.Synthetic.DecidabilityFacts.
Require Import Vector Lia.

Set Default Goal Selector "!".
Set Default Proof Using "Type".

(* Reduction from the TRAKHTENBROT development to the FSAT problems in FOL *)

(* syntax translation **)

Definition term' := @fo_term Empty_set (fun f => match f with end).
Definition form' := fol_form (Σrel 2).

Definition translate_term (t : term') : term :=
  match t with
  | in_var n => $n
  | _ => $0
  end.

Fixpoint translate (phi : form') : form :=
  match phi with
  | @fol_false _  => ⊥
  | fol_atom tt v => atom tt (map translate_term v)
  | fol_bin fol_conj phi psi => translate phi ∧ translate psi
  | fol_bin fol_disj phi psi => translate phi ∨ translate psi
  | fol_bin fol_imp phi psi => translate phi → translate psi
  | fol_quant fol_ex phi => ∃ translate phi
  | fol_quant fol_fa phi => ∀ translate phi
  end.

(* verification **)

Section Forward.

  Variable D : Type.
  Variable M : fo_model (Σrel 2) D.

  Instance M1 :
    interp D.
  Proof using M.
    split.
    - intros [].
    - intros [] v. exact (fom_rels M tt v).
  Defined.

  Lemma fwd_eval rho t :
    fo_term_sem M rho t = eval rho (translate_term t).
  Proof.
    destruct t as [n|[]]; cbn. reflexivity.
  Qed.

  Lemma fwd_sat rho phi :
    fol_sem M rho phi <-> rho ⊨ translate phi.
  Proof.
    induction phi in rho |- *; try destruct p; try destruct f; cbn; try now intuition; try firstorder.
    - unfold sat. rewrite map_map. erewrite map_ext.
      1:{ match goal with [ |- ?P <-> ?Q ] => enough (P = Q) as ->  end. 1: reflexivity. reflexivity. }
      eapply fwd_eval.
    - split; intros [d H]; exists d; apply IHphi.
      + eapply fol_sem_ext; try apply H. now intros [].
      + eapply sat_ext; try apply H. now intros [].
    - split; intros H d; apply IHphi.
      + eapply fol_sem_ext; try apply H. now intros [].
      + eapply sat_ext; try apply H. now intros [].
  Qed.

End Forward.

Section Backward.

  Variable D : Type.
  Variable M : interp D.

  Definition M2 :
    fo_model (Σrel 2) D.
  Proof using M.
    split.
    - intros [].
    - intros [] v. exact (i_atom (P:=tt) v).
  Defined.

  Lemma bwd_eval rho t :
    fo_term_sem M2 rho t = eval rho (translate_term t).
  Proof.
    destruct t as [n|[]]; cbn. reflexivity.
  Qed.

  Lemma bwd_sat rho phi :
    fol_sem M2 rho phi <-> rho ⊨ translate phi.
  Proof.
    induction phi in rho |- *; try destruct p; try destruct f; cbn; try now intuition; try firstorder.
    - unfold sat. rewrite map_map. erewrite map_ext.
      1:{ match goal with [ |- ?P <-> ?Q ] => enough (P = Q) as ->  end. 1: reflexivity. reflexivity. }
      eapply bwd_eval.
    - split; intros [d H]; exists d; apply IHphi.
      + eapply fol_sem_ext; try apply H. now intros [].
      + eapply sat_ext; try apply H. now intros [].
    - split; intros H d; apply IHphi.
      + eapply fol_sem_ext; try apply H. now intros [].
      + eapply sat_ext; try apply H. now intros [].
  Qed.

End Backward.

(* reduction theorems **)

Lemma reduction :
  @fo_form_fin_dec_SAT (Σrel 2) ⪯ Full.FSAT.
Proof.
  exists translate. intros phi. split.
  - intros (D & M & [L HL] & HD & rho & H). exists D, (@M1 D M), rho. repeat split.
    + exists L. apply HL.
    + intros [ ]. apply decidable_iff. constructor. apply HD.
    + now apply fwd_sat.
  - intros (D & M & rho & [L HL] & HD & H). specialize (HD tt). apply decidable_iff in HD. destruct HD as [HD]. exists D, (@M2 D M), (exist _ L HL). eexists.
    + intros []. apply HD.
    + exists rho. now apply bwd_sat.
Qed.

Lemma reduction_disc :
  @fo_form_fin_discr_dec_SAT (Σrel 2) ⪯ FSATd.
Proof.
  exists translate. intros phi. split.
  - intros (D & HE & M & [L HL] & HD & rho & H). exists D, (@M1 D M), rho. repeat split.
    + exists L. apply HL.
    + apply discrete_iff. constructor. apply HE.
    + intros [ ]. apply decidable_iff. constructor. apply HD.
    + now apply fwd_sat.
  - intros (D & M & rho & [L HL] & [HE] % discrete_iff & HD & H).
    specialize (HD tt).
    apply decidable_iff in HD. destruct HD as [HD].
    exists D, HE, (@M2 D M), (exist _ L HL). eexists.
    + intros []. apply HD.
    + exists rho. now apply bwd_sat.
Qed.


Require Export CFGinnermost ListExtra.

Section cfg.
  Context `{C : redCFG}.

  Notation "p '-a>b' q" := (a_edge p q) (at level 55).
  Notation "p '-a>' q" := (p -a>b q = true) (at level 55).
  Notation "p '-->b' q" := (edge p q) (at level 55).
  Notation "p '-->' q" := (p -->b q = true) (at level 55, right associativity).

  (** * Definitions **)

  Definition ancestor a p q :=
    loop_contains a p /\ loop_contains a q \/ a = root .

  Definition near_ancestor  a p q := (* we cannot allow root for the other ancestor *)
    ancestor a p q /\ forall a', loop_contains a' p /\ loop_contains a' q -> loop_contains a' a.

  Definition outermost_loop h p := loop_contains h p /\ forall h', loop_contains h' p -> loop_contains h h'.

  Definition ex_outermost_loop p
    := finType_sig_or_never (DecPred (fun h => outermost_loop h p)).

  Definition get_outermost_loop p : option Lab
    := match ex_outermost_loop p with
       | inleft (exist _ h H) => Some h
       | inright _ => None
       end.

  Definition strict_incl (A : Type) (l l' : list A)
    := l ⊆ l' /\ exists a, a ∈ l' /\ a ∉ l.

  Infix "⊂" := strict_incl (at level 55).

  (** * Facts about outermost_loops **)

  Lemma loop_contains_outermost h p
        (Hl : loop_contains h p)
    : exists h', outermost_loop h' p.
  Proof.
    remember (elem Lab).
    specialize (@elementIn Lab) as Hin.
    rewrite <-Heql in Hin.
    clear Heql.
    unfold outermost_loop.
    enough (forall l', l' ⊆ l
                  -> exists h' : Lab, loop_contains h' p /\ (forall h'0 : Lab, h'0 ∈ l'
                                                                   -> loop_contains h'0 p
                                                                   -> loop_contains h' h'0)).
    {
      specialize (H l).
      exploit H.
      destructH. eexists; eauto.
    }
    induction l';intros.
    - exists h. split;eauto. intros. cbn in H0. contradiction.
    - exploit IHl'.
      + eapply incl_cons;eauto.
      + destructH. decide (loop_contains a h').
        * exists a. split;[eapply loop_contains_trans;eauto|].
          intros. destruct H0.
          -- subst. eauto using loop_contains_self, loop_contains_loop_head.
          -- exploit IHl'1. eapply loop_contains_trans;eauto.
        * exists h'. split;[auto|]. intros.
          destruct H0;[subst|eapply IHl'1;eauto].
          eapply loop_contains_either in IHl'0;eauto.
          destruct IHl'0; [contradiction|auto].
  Qed.

  Lemma get_outermost_loop_spec p
    : match get_outermost_loop p with
      | Some h => outermost_loop h p
      | None => forall h, loop_contains h p -> False
      end.
  Proof.
    unfold get_outermost_loop.
    destruct (ex_outermost_loop p).
    - destruct s. cbn in *. auto.
    - cbn in *. intros. eapply loop_contains_outermost in H. destructH.
      eapply n;eauto.
  Qed.

  (*
  Lemma LPath_loop_contains  h h' p π
        (Hpath : LPath h p π)
        (Hin : h' ∈ tl π)
    : loop_contains h p.
  Proof.
    revert dependent p. revert dependent h'.
    induction π;intros;inversion Hpath;subst;cbn in *;[contradiction|].
    destruct π;inversion H3;subst;cbn in *;[destruct Hin;[subst|contradiction]|].
    - decide (innermost_loop_strict h' a);cbn in *;[|congruence]. unfold innermost_loop_strict in i. destructH;auto.
    - destruct Hin.
      + admit.
      + eapply IHπ;auto. inversion Hpath; subst; eauto.
        admit.
   *)

  (** * Existence of ancestors, near_ancestors **)

  Lemma ex_LPath p
    : exists h, (forall h', loop_contains h' p -> loop_contains h h') /\ exists π, LPath h p π.
  Proof.
    remember (get_outermost_loop p) as oh.
    specialize (get_outermost_loop_spec p) as Hspec.
    destruct (get_outermost_loop p).
    - unfold outermost_loop in Hspec. destructH.
      exists e. split;eauto. eapply loop_LPath;eauto.
    - exists p. split; [intros h' Hh'; eapply Hspec in Hh';contradiction|].
      eexists. econstructor.
  Qed.

  Definition ex_near_ancestor_opt p q
    := finType_sig_or_never (DecPred (fun a => near_ancestor a p q)).

  (*
  Lemma near_ancestor_same  h p q a
        (Hloop : innermost_loop h p)
        (Hanc1 : near_ancestor a h q)
    : near_ancestor a p q.*)

  (* show:
   * ancestors are exactly LPath p ∩ LPath q ∪ {root}
   * if x ∈ LPath p ∩ LPath q -> lpath to x is prefix of both lpaths
   * thus the nearest ancestor is the last such x
   *)

  Lemma ex_near_ancestor p q
    : exists a, near_ancestor a p q.
  Proof.

    (****)
    remember (elem Lab).
    specialize (@elementIn Lab) as Hin.
    rewrite <-Heql in Hin.
    clear Heql.
    unfold near_ancestor.
    enough (forall l', l' ⊆ l
                  -> exists a : Lab, ancestor a p q /\ (forall a' : Lab, a' ∈ l'
                                                             -> loop_contains a' p /\ loop_contains a' q
                                                             -> loop_contains a' a)).
    {
      specialize (H l).
      exploit H.
      destructH. eexists; eauto.
    }
    induction l';intros.
    - exists root. split;[right;auto|].
      intros;cbn in *;contradiction.
    - exploit IHl';[eapply incl_cons;eauto|].
      destructH.
      decide (loop_contains a p /\ loop_contains a q).
      + destructH. decide (loop_contains a0 a).
        * exists a. split;[left;auto|].
          intros. destruct H0;[subst;eauto using loop_contains_self, loop_contains_loop_head|].
          specialize (IHl'1 a'). exploit IHl'1.
          eapply loop_contains_trans;eauto.
        * destruct IHl'0.
          -- exists a0. split;[left;auto|].
             intros.
             destruct H1.
             ++ subst. eapply loop_contains_either in a2;[|destruct H0 as [H0 _];apply H0].
                destruct a2;[|eauto].
                contradict n. eauto.
             ++ eapply IHl'1;eauto.
          -- subst a0. exists a. split;[left;auto|].
             intros. destruct H0;[subst;eauto using loop_contains_self, loop_contains_loop_head|].
             specialize (IHl'1 a'). exploit IHl'1.
             eapply root_loop_root in IHl'1. subst.
             destructH. eapply loop_contains_either in H2. 2: apply a2.
             destruct H2;[|auto]. eapply root_loop_root in H1. subst.
             eauto using loop_contains_loop_head, loop_contains_self.
      + simpl_dec' n.
        destruct n.
        1,2 : exists a0; split;[auto|];
                  intros; destruct H1;[subst;destruct H2;contradiction|eapply IHl'1;eauto].
  Qed.

  (** * Dominance **)

  Lemma ancestor_dom1 a p q
    : ancestor a p q -> Dom edge__P root a p.
  Proof.
    intros.
    destruct H.
    - destruct H.
      eapply dom_loop;eauto.
    - subst. eapply dominant_root.
  Qed.

  Lemma ancestor_sym a p q
    : ancestor a p q -> ancestor a q p.
  Proof.
    unfold ancestor;firstorder 0.
  Qed.

  Lemma ancestor_dom2 a p q
    : ancestor a p q -> Dom edge__P root a q.
  Proof.
    eauto using ancestor_dom1, ancestor_sym.
  Qed.

  Lemma ancestor_deq_loop1 a p q
    : ancestor a p q -> deq_loop p a.
  Proof.
    intros. destruct H.
    - destructH. eapply loop_contains_deq_loop;eauto.
    - subst a. eapply deq_loop_root.
  Qed.

  Lemma ancestor_deq_loop2 a p q
    : ancestor a p q -> deq_loop q a.
  Proof.
    intros. eapply ancestor_sym in H. eapply ancestor_deq_loop1;eauto.
  Qed.

End cfg.


(* Here we prove properties about the logical relation such as
   monotonicity under tick_le and heapseq_le *)

From SimplyRatt Require Export LogicalRelation.

From SimplyRatt Require Import Tactics.

From Coq Require Import Program.Equality Omega.

Lemma vrel_gc A : forall Hs s t, vrel A Hs s t -> vrel A Hs (gc s) t.
Proof.
  remember (tsize A) as N. generalize dependent A.
  induction (lt_wf N) as [N _ IH]. intros.
  destruct A; try solve[autorewrite with vrel in *;eauto].
  - rewrite vrel_times in *. autodest.
    exists x, x0. split. reflexivity. split.
    + eapply (IH (tsize A1));[simpl; omega|eauto|eauto].
    + eapply (IH (tsize A2));[simpl; omega|eauto|eauto].
  - rewrite vrel_plus in *. autodest.
    + left. exists x. split. reflexivity. eapply (IH (tsize A1));[simpl; omega|eauto|eauto].
    + right. exists x. split. reflexivity. eapply (IH (tsize A2));[simpl; omega|eauto|eauto].
  - rewrite vrel_arrow in *. autodest. exists x. split. reflexivity. intros.
    rewrite gc_idem in *. apply H0;eauto.
  - destruct Hs.
    + rewrite vrel_delay_nil in *. assumption.
    + rewrite vrel_delay in *. autodest.
      exists x, x0. split. reflexivity. split. apply store_mapsto_gc; assumption.
      intros. rewrite store_tick_gc. auto.
  - rewrite vrel_mu in *. autodest. exists x. split. reflexivity.
    apply (IH (tsize (tsubst 0 A (Delay (Mu A))))). rewrite tsize_subst. auto. auto. auto.
Qed.

Lemma trel_mono A Hs Hs' s s' t : heapseq_le Hs Hs' -> tick_le s s' ->  trel A Hs s t -> trel A Hs' s' t.
Proof.
  unfold trel in *. intros.
  assert (heapseq_le Hs Hs'0) as A1 by eauto using heapseq_le_trans.
  assert (tick_le s s'0) as A2 by eauto using tick_le_trans.
  remember (H1  Hs'0 s'0 A1 A2) as A3. clear HeqA3 H1. autodest.
Qed.

Lemma vrel_mono A : forall Hs Hs' s s' t, heapseq_le Hs Hs' -> tick_le s s' ->  vrel A Hs s t -> vrel A Hs' s' t.
Proof.
  remember (tsize A) as N. generalize dependent A.
  induction (lt_wf N) as [N _ IH]. intros. destruct A; try solve[autorewrite with vrel in *;eauto].
  - rewrite vrel_times in *. autodest.
    exists x, x0. split. auto. split.
    + eapply (IH (tsize A1)); eauto. simpl. omega.
    + eapply (IH (tsize A2)); eauto. simpl. omega.
  - rewrite vrel_plus in *. autodest.
    + left. exists x. split. auto. eapply (IH (tsize A1)); eauto. simpl. omega.
    + right. exists x. split. auto. eapply (IH (tsize A2)); eauto. simpl. omega.
  - rewrite vrel_arrow in *. autodest.
    exists x. split. auto. intros.
    apply H2; eauto using heapseq_le_trans, store_le_trans, tick_le_gc.
  - destruct Hs.
    + inversion H. subst. rewrite vrel_delay_nil in *. auto.
    + inversion H. subst. rewrite vrel_delay in *. autodest.
      exists x, x0. split. auto. split. eauto using tick_le_mapsto.
      intros. apply H4 in H1. autodest.
      eapply trel_mono. eassumption. eapply tick_le_store_tick. eassumption.
      eassumption. auto.
  - rewrite vrel_box in *. autodest.
    split. assumption. intros. remember (heapseq_le_suffix _ _ _ H H3) as Su. clear HeqSu.
    autodest. eapply trel_mono. eassumption. econstructor. econstructor. apply heap_le_refl.
    apply H2. assumption.
  - rewrite vrel_mu in *. autodest. exists x. split. auto.
    eapply (IH (tsize (tsubst 0 A (Delay (Mu A))))); try rewrite tsize_subst; eauto.
Qed.

Lemma vrel_gc_rev A : forall Hs s t, vrel A Hs (gc s) t -> vrel A Hs s t.
Proof.
  intros. eauto using vrel_mono, tick_le_gc'.
Qed.

Lemma vrel_stable A : forall Hs Hs' s s' t, stable A -> suffix Hs' Hs -> vrel A Hs s t -> vrel A Hs' s' t.
Proof.
  remember (tsize A) as N. generalize dependent A.
  induction (lt_wf N) as [N _ IH]. intros A HN Hs Hs' s s' t ST SU VR.
  destruct A; inversion ST; try solve[autorewrite with vrel in *;eauto].
  - rewrite vrel_times in *. autodest. exists x, x0.
    split. auto. split.
    + eapply (IH (tsize A1)); simpl; eauto; try omega.
    + eapply (IH (tsize A2)); simpl; eauto; try omega.
  - rewrite vrel_plus in *. autodest.
    + left. exists x. split. auto. eapply (IH (tsize A1)); simpl; eauto; try omega.
    + right. exists x. split. auto. eapply (IH (tsize A2)); simpl; eauto; try omega.
  - rewrite vrel_box in *. autodest. split. auto. intros. apply H1. eauto using suffix_trans.
Qed.

Lemma vrel_trel A Hs s t : vrel A Hs s t -> trel A Hs s t.
Proof.
  intros. assert (isvalue t) by eauto using vrel_val. unfold trel.
  intros. exists t, s'. split. apply red_value. auto. eauto using vrel_mono.
Qed.

(* context relation *)

Lemma crel_init (G : ctx init) Hs s g : crel G Hs s g -> s = store_bot.
Proof.
  intros C. dependent induction C;eauto.
Qed.

Lemma crel_now (G : ctx now) Hs s g : crel G Hs s g -> s <> store_bot.
Proof.
  intros C. dependent induction C;eauto.
Qed.

Lemma crel_now' (G : ctx now) Hs s g : crel G Hs s g ->
                                   exists hn hl, s = store_lock hn hl.
Proof.
  intros C. apply crel_now in C. destruct s; eauto. contradiction.
Qed.

Lemma crel_later (G : ctx later) Hs s g : crel G Hs s g ->
                                   exists hn hl, s = store_lock (Some hn) hl.
Proof.
  intros C. dependent induction C;eauto.
Qed.

Lemma crel_gc ty (G : ctx ty) Hs s g : ty <> later -> crel G Hs s g -> crel G Hs (gc s) g.
Proof.
  intros T C; induction C.
  - simpl. auto.
  - simpl. eauto using vrel_gc.
  - auto.
  - eapply crel_lock; try eassumption. rewrite <- store_bot_gc. assumption.
  - contradiction.
Qed.

Lemma heaps_single_closed h : closed_heap h -> closed_heaps (heaps_single h).
Proof.
  intro C. intros h' H. inversion H. auto.
Qed.

Hint Resolve heaps_single_closed.

Lemma crel_mono ty (G : ctx ty) Hs Hs' s s' g :
  heapseq_le Hs Hs' -> closed_heapseq Hs' ->
  tick_le s s' -> closed_store s' ->  crel G Hs s g -> crel G Hs' s' g.
Proof.
  intros HS CL T CS C. generalize dependent Hs'. generalize dependent s'.
  induction C;intros.
  - inversion T. subst. inversion H. subst. eauto.
  - eauto using vrel_mono.
  - eauto.
  - pose (heapseq_le_suffix'' _ _ _ HS H H0 CL) as HL. autodest. eapply crel_lock;
    try eassumption. pose (tick_le_bot' _ _ T) as B. apply B. assumption.
    eauto.
  - inversion T. subst. inversion H. subst.
    dependent destruction CS.
    apply crel_tick.
    apply IHC;eauto using heaps_single_le.
Qed.

Lemma crel_skip_later g hn hl G Hs :
  crel G Hs (store_lock (Some hn) hl) g ->
  crel (skip_later G)
       (heaps_single hl :: Hs) (store_lock None hn) (sub_skip (skip_later_count G) g).
Proof.
  intros C. dependent induction C;simpl;eauto.
Qed.

Lemma crel_skip_now g G Hs s :
  crel G Hs s g -> exists Hs', suffix Hs Hs' /\ closed_heapseq Hs' /\
  crel (skip_now G) Hs' store_bot (sub_skip (skip_now_count G) g).
Proof.
  intros C. dependent induction C.
  - simpl. pose (IHC G0 eq_refl JMeq_refl) as IH. autodest.
  - simpl. pose (IHC G0 eq_refl JMeq_refl) as IH. autodest.
  - eauto.
Qed.

Lemma crel_ground ty (G : ctx ty) Hs s g : crel G Hs s g -> ground_sub 0 g G.
Proof.
  intros CR. induction CR; eauto.
Qed.

Lemma crel_sub_closed ty g (G : ctx ty) Hs s A t :
      G ⊢ t ∶ A -> closed_sub g -> crel G Hs s g -> closed_term (sub_app g t).
Proof.
  intros. eapply ground_sub_closed;eauto using crel_ground.
Qed.

Lemma ctx_lookup_vrel ty (G : ctx ty) i T Hs s g :
  ctx_lookup G i T -> crel G Hs s g -> exists t, sub_lookup g i = Some t /\ vrel T Hs s t.
Proof.
  intros L C. generalize dependent g. induction L;intros.
  - dependent destruction C. eexists. split. cbv. reflexivity. assumption.
  - dependent destruction C. apply IHL in C. autodest.
  - dependent destruction C. apply IHL in C. autodest.
Qed.

Lemma sub_skip_later_app Hs s g G t A : skip_later G ⊢ t ∶ A -> crel G Hs s g ->
                                      sub_app (sub_skip (skip_later_count G) g) t = sub_app g t.
Proof.
  intros. apply sub_skips_id. eapply typing_svars;try eassumption. apply skip_later_skipn.
Qed.

Lemma sub_skip_now_app Hs s g G t A : skip_now G ⊢ t ∶ A -> crel G Hs s g ->
                                      sub_app (sub_skip (skip_now_count G) g) t = sub_app g t.
Proof.
  intros. apply sub_skips_id. eapply typing_svars;try eassumption. apply skip_now_skipn.
Qed.

Lemma sub_skip_both_app Hs s g G t A :
  skip_now (skip_later G) ⊢ t ∶ A -> crel G Hs s g ->
  sub_app (sub_skip (skip_now_count (skip_later G)) (sub_skip (skip_later_count G) g)) t
           = sub_app g t.
Proof.
  intros. rewrite sub_skips_id. apply sub_skips_id. eapply typing_svars;try eassumption.
  apply ctx_skips_now.  apply skip_later_skipn.
  eapply typing_svars;try eassumption. apply skip_now_skipn.
Qed.

Lemma crel_now_lock (G : ctx now) Hs s g : crel G Hs (gc s) g ->
                                           exists h, gc s = store_lock None h.
Proof.
  intros C.
  apply crel_now in C. destruct s.
  - simpl in C. contradiction.
  - simpl in *. eauto.
Qed.

Inductive vtype : type -> Prop :=
| vtype_unit : vtype Unit
| vtype_nat : vtype Nat
| vtype_times A B :
    vtype A ->
    vtype B ->
    vtype (Times A B)
| vtype_plus A B :
    vtype A ->
    vtype B ->
    vtype (Plus A B).

Lemma vtype_typing A Hs s v : vtype A -> vrel A Hs s v -> ctx_empty ⊢ v ∶ A.
Proof.
  intros VT VR. generalize dependent v.
  induction VT; intros; autorewrite with vrel in VR;autodest.
Qed.

Ltac impossible := match goal with
                   | [H : _ |- _] => try solve[inversion H]; clear H;impossible
                   | _ => idtac
                   end.

Lemma typing_vtype A Hs s v : vtype A -> isvalue v -> ctx_empty ⊢ v ∶ A -> vrel A Hs s v.
Proof.
  intros VT V Ty. generalize dependent v.
  induction VT;intros;
    dependent destruction Ty;try solve[impossible];inversion V;subst; autorewrite with vrel in *;eauto.
    do 2 eexists. eauto.
Qed.

Lemma vtype_vrel A Hs s Hs' s' v : vtype A -> vrel A Hs s v -> vrel A Hs' s' v.
Proof.
  intros VT VR. generalize dependent v.
  induction VT; intros; autorewrite with vrel in *;autodest;
  eauto 10.
Qed.

Lemma vtype_tsubst i A B : vtype A -> tsubst i A B = A.
Proof.
  intros VT. induction VT;simpl;f_equal;eauto.
Qed.

Lemma vrel_delay_closed A Hs s v : vrel (Delay A) Hs s v -> closed_term v.
Proof.
  intros V. destruct Hs; autorewrite with vrel in V; autodest.
Qed.

Lemma vtype_vrel_closed A Hs s v : vtype A -> vrel A Hs s v -> closed_term v.
  intros VT. generalize dependent v. induction VT;intros v VR;autorewrite with vrel in VR;
                                       autodest.
Qed.

Lemma vtype_inhab A : vtype A -> exists v, vrel A nil store_bot v.
Proof.
  intros VT. induction VT.
  - exists unit. autorewrite with vrel in *. auto.
  - exists (natlit 0). autorewrite with vrel in *. eauto.
  - autodest. eexists. autorewrite with vrel in *. eauto.
  - autodest. eexists. autorewrite with vrel in *. eauto.
Qed.

Lemma trel_app T1 T2 Hs s t1 t2 :
  closed_term t1 -> closed_term t2 ->
  trel (Arrow T1 T2) Hs s t1 -> trel T1 Hs s t2 ->
  trel T2 Hs s (app t1 t2).
Proof.
  unfold trel in *. intros Ct1 Ct2 IHT1 IHT2 Hs' s' HS TL HCH HCs.
  pose (IHT1 _ _ HS TL HCH HCs) as IH1.
  destruct IH1 as (v & s''& [IH1s IH1v]).
  rewrite vrel_arrow in IH1v.
  destruct IH1v as (u & [V IH1]). subst.
  assert (tick_le s s'') as TL' by eauto using tick_le_trans, red_extensive.
  assert (closed_term (abs u) /\ closed_store s'') as HCC by
        (apply red_closed with (t := t1) (s := s');eauto).
  destruct HCC as [HC'' HCs'].
  pose (IHT2 _ _ HS TL' HCH HCs') as IH2.
  destruct IH2 as (v' & s'''& [IH2s IH2v]).
  apply vrel_gc in IH2v.
  assert (store_le (gc s'') (gc s''')) as SL by
          eauto using tick_le_gc,red_extensive.
  assert (closed_term v' /\ closed_store s''') as CT by
        (apply red_closed with (t := t2) (s := s'');eauto using crel_sub_closed).
    destruct CT as [CT CTS].
    assert (closed_store (gc s''')) as CGS by (eauto using closed_store_gc).
    pose (IH1 _ (gc s''') (heapseq_le_refl _) SL HCH CGS v' IH2v CT _ _ (heapseq_le_refl _)
              (tick_le_gc' s''') HCH CTS) as IH1v.
    destruct IH1v as (w & s1 & [R V]).
    exists w, s1. simpl. eauto.
Qed.

Lemma trel_adv l hl hn Hs A t:
  heap_mapsto l t hn ->
  trel A Hs (store_lock (Some hn) hl) t ->
  trel A Hs (store_lock (Some hn) hl) (adv (ref l)).
Proof.
  intros M Tt. unfold trel in *. intros.
  assert (exists (v : term) (s'' : store), {t, s'}⇓ {v, s''} /\ vrel A Hs' s'' v)
    as Tt' by eauto.
  autodest. apply tick_le_tick' in H0. autodest.
  do 2 eexists. split.
  eapply red_adv. constructor. auto. eauto.  eauto. eauto.
Qed.


(* Author: Jean-Marie Madiot *)

Require Import Omega.
Require Import Arith.

(* For n t == t 0 || t 1 || .. || t (n - 1) *)
Ltac For n t :=
  match n with
    0 => idtac
  | S ?n' => (For n' t || t n')
  end.

(* run n t == t n || t (1 + n) || t (2 + n) || ..  *)
Ltac For_inf n t :=
  t n ||
    let n' := (eval compute in (1 + n)) in
    For_inf n' t.

(* sugar to write "iter_cube t 5" instead of "iter_cube t 5%nat" *)
Ltac forcenat n :=
  match type of n with
    nat => n
  | N => eval compute in (N.to_nat n)
  | Z => eval compute in (Z.to_nat n)
  end.

(* exists (+z) / exists (-z) *)
Ltac explus n := let z := eval compute in (Z.of_nat n) in exists z.
Ltac exminus n := let z := eval compute in (Z.opp (Z.of_nat n)) in exists z.

(* factoring disjunctive patterns by hand *)
Ltac match_exists_on_type ty t :=
  lazymatch goal with
  | |- @ex ty ?P => t P
  | |- @sig ty ?P => t P
  | |- @sigT ty ?P => t P
  (* the following are commented out because they give out a collision warning *)
  (*
  | |- @ex2 ty (fun x => ?P) (fun x => ?Q) => let PQ := constr:(fun x : ty => P /\ Q) in t PQ
  | |- @sig2 ty (fun x => ?P) (fun x => ?Q) => let PQ := constr:(fun x : ty => P /\ Q) in t PQ
  | |- @sigT2 ty (fun x => ?P) (fun x => ?Q) => let PQ := constr:(fun x : ty => P /\ Q) in t PQ
  *)
  | |- @ex2 ty ?P ?Q => let PQ := constr:(fun x => P x /\ Q x) in t PQ
  | |- @sig2 ty ?P ?Q => let PQ := constr:(fun x => P x /\ Q x) in t PQ
  | |- @sigT2 ty ?P ?Q => let PQ := constr:(fun x => P x /\ Q x) in t PQ
  end.

(* we don't really need the proposition, though *)
Ltac if_exists_on_type ty t :=
  match_exists_on_type ty ltac:(fun _ => t).

(* [iter_cube_new] is a refactored version of [iter_cube], but it is 5 times slower *)
Ltac iter_cube_new t n :=
  let n := forcenat n in
  (* if existential is nat *)
  (if_exists_on_type
     nat
     ltac:(For n ltac:(fun i => exists i; iter_cube_new t n)))
  ||
  (* if existential is Z *)
  (if_exists_on_type
     Z
     ltac:(For n ltac:(fun i => (explus i; iter_cube_new t n) ||
                             (exminus i; iter_cube_new t n))))
  (* otherwise *)
  ||
  t.

(* try tactic [t] after instantiating existentials in the cube
   [0, n-1]^(number of "exists") for nat
   [-n+1, n-1]^(number of "exists") for Z
 *)
Ltac iter_cube t n :=
  let n := forcenat n in
  lazymatch goal with
  | |- @ex    nat _   => For n ltac:(fun i => exists i; iter_cube t n)
  | |- @sig   nat _   => For n ltac:(fun i => exists i; iter_cube t n)
  | |- @sigT  nat _   => For n ltac:(fun i => exists i; iter_cube t n)
  | |- @ex2   nat _ _ => For n ltac:(fun i => exists i; iter_cube t n)
  | |- @sig2  nat _ _ => For n ltac:(fun i => exists i; iter_cube t n)
  | |- @sigT2 nat _ _ => For n ltac:(fun i => exists i; iter_cube t n)
  | |- @ex    Z _   => For n ltac:(fun i => (explus i; iter_cube t n) || (exminus i; iter_cube t n))
  | |- @sig   Z _   => For n ltac:(fun i => (explus i; iter_cube t n) || (exminus i; iter_cube t n))
  | |- @sigT  Z _   => For n ltac:(fun i => (explus i; iter_cube t n) || (exminus i; iter_cube t n))
  | |- @ex2   Z _ _ => For n ltac:(fun i => (explus i; iter_cube t n) || (exminus i; iter_cube t n))
  | |- @sig2  Z _ _ => For n ltac:(fun i => (explus i; iter_cube t n) || (exminus i; iter_cube t n))
  | |- @sigT2 Z _ _ => For n ltac:(fun i => (explus i; iter_cube t n) || (exminus i; iter_cube t n))
  | |- _ => t
  end.

(* try tactic [t] after instantiating existentials in the cone
   (x_1 + ... + x_(number of "exists")) < n *)
Ltac iter_cone t n :=
  lazymatch goal with
  | |- @ex   nat _ => For n ltac:(fun i => exists i; let n' := eval compute in (n - i) in iter_cone t n')
  | |- @sig  nat _ => For n ltac:(fun i => exists i; let n' := eval compute in (n - i) in iter_cone t n')
  | |- @sigT nat _ => For n ltac:(fun i => exists i; let n' := eval compute in (n - i) in iter_cone t n')
  | |- @ex   Z _ => fail "Bounded sum exploration not yet implemented for Z"
  | |- @sig  Z _ => fail "Bounded sum exploration not yet implemented for Z"
  | |- @sigT Z _ => fail "Bounded sum exploration not yet implemented for Z"
  | |- _ => t
  end.

(* try tactic [t] after instantiating existentials in the plane
   (x_1 + ... + x_(number of "exists")) == n *)
Ltac iter_plane t n :=
  let Sn := (eval compute in (1 + n)) in
  lazymatch goal with
  | |- @ex   nat _ => For Sn ltac:(fun i => exists i; let n' := eval compute in (n - i) in iter_plane t n')
  | |- @sig  nat _ => For Sn ltac:(fun i => exists i; let n' := eval compute in (n - i) in iter_plane t n')
  | |- @sigT nat _ => For Sn ltac:(fun i => exists i; let n' := eval compute in (n - i) in iter_plane t n')
  | |- @ex   Z _ => fail "Constant-sum exploration not yet implemented for Z"
  | |- @sig  Z _ => fail "Constant-sum exploration not yet implemented for Z"
  | |- @sigT Z _ => fail "Constant-sum exploration not yet implemented for Z"
  | |- _ => match n with 0 => t | _ => fail end
  end.

(* [iter_planes t] tries [t] on planes of increasing distance to 0.
   (Will run forever if [t] never succeeds.)  *)

Tactic Notation "iter_planes" tactic(t) :=
  For_inf 0 ltac:(iter_plane t).

(* [iter_planes t n] tries [t] on planes of distance to 0 from 0 to n-1 *)

Tactic Notation "iter_planes" tactic(t) constr(n) :=
  For n ltac:(iter_plane t).

(* [iter_cubes t n] tries [t] on cubes of side from 0 from 0 to n-1
   (faster than [iter_cube t n] in cases where the solution is close
   to 0 and n is large) *)

Tactic Notation "iter_cubes" tactic(t) constr(n) :=
  For n ltac:(iter_cube t).

(* [iter_cubes t] tries [t] on cubes of increasing side.  Will run
   forever if [t] never succeeds. *)

Tactic Notation "iter_cubes" tactic(t) :=
  For_inf 1 ltac:(iter_cube t).

(* Which of the above tactics/notations is faster depends on where the
   solutions typically are. Closer to the diagonal would mean cubes
   are faster.  But if one wants no redundancy in the exploration and
   never run [t] twice on the same instantiation, one should use
   [iter_planes t]. *)

(** Use [eomega] for most uses. *)

Tactic Notation "eomega" :=
  iter_cubes omega.

Tactic Notation "eomega" constr(n) :=
  let n := forcenat n in
  let n' := (eval compute in (1 + n)) in
  iter_cube omega n'.

Tactic Notation "eomega" "sum" :=
  iter_planes omega.

Tactic Notation "eomega" "sum" constr(n) :=
  let n := forcenat n in
  let n' := (eval compute in (1 + n)) in
  iter_cone omega n'.

(** If your goal is [exists a, exists b, ...], try:
  - [eomega] to try all instances
  - [eomega 5] to try all instances with a, b, .. <= 5
  - [eomega sum] to try all instances without redundancy
  - [eomega sum 5] to try instances with a + b + ... <= 5
*)

Section Tests.

Goal exists a b, a = 5 /\ b = 5.
Proof.
  Fail Fail eomega.   (* success *)
  Fail      eomega 4. (* fail: 4 is not enough) *)
  Fail Fail eomega 5. (* success *)

  Fail Fail eomega sum.    (* success *)
  Fail      eomega sum 9.  (* fail: 9 is not enough *)
  Fail Fail eomega sum 10. (* success *)

  eomega.
Qed.

Goal 15 = 15.
Proof.
  eomega.
Qed.

Goal exists n, n = 0.
Proof.
  Fail Fail iter_plane omega 0.
  Fail      iter_plane omega 1.
  Fail      iter_plane omega 2.
  Fail Fail iter_planes omega.
  eomega.
Qed.

(* ex, sig, sigT *)
Goal exists n, n = 15.        Proof. eomega. Qed.
Goal { n | n = 15 }.     Proof. eomega. Qed.
Goal { n : nat & n = 15 }. Proof. eomega. Qed.

(* ex2, sig2, sigT2 *)
Goal exists2 x, x * x + 2 = 3 * x & x <> 1. Proof. eomega. Qed.
Goal { x | x * x + 2 = 3 * x & x <> 1 }. Proof. eomega. Qed.
Goal { x : nat & x * x + 2 = 3 * x & x <> 1 }. Proof. eomega. Qed.

Goal exists a b c, a = 5 /\ b = 6 /\ c = 4 /\ a + c + b = b + a + c.
Proof.
  eomega.
Qed.

Goal exists x y, 3 * x * y = 12.
Proof.
  eomega.
Qed.

Goal exists x2 x3 x4 : nat, 0 <= x2 /\ 1 <= x4 /\ x4 <= x3 /\ S (S x4) <= x3 /\ 2 <= x2.
Proof.
  eomega.
Qed.

Goal forall x2 x3 x4 : nat,
    (0 <= x2 /\ 1 <= x4 /\ x4 <= x3 /\ S (S x4) <= x3 /\ 2 <= x2) ->
    x2 <= 2 ->
    x3 <= 2 ->
    x4 <= 2 ->
    False.
Proof.
  intros.
  omega.
Qed.

Goal exists a b, forall x, 6 * x + x + x = a * x + b.
  Time iter_planes ltac:(intros; ring).
  (* 0.2 s *)
Qed.

(*
Goal exists a b c, forall x, (x + 2) * (x + 4) = a * x * x + b * x + c.
  Time iter_planes ltac:(intros; ring).
  (* 5 s (8 s with "iter_cubes" *)
Qed.

Goal exists a b c d, forall x y, (x + 2) * (y + 4) = a * x * y + b * x + c * y + d.
  Time iter_planes ltac:(intros; ring).
  (* 25 s *)
Qed.
*)

Open Scope Z_scope.

Goal exists x1 x2 : Z, x1 = - 5 /\ x2 = 5.
Proof.
  eomega.
Qed.

Goal exists x1 x2 : Z, x1 * x2 = 15 /\ x1 < 0 /\ x2 < 0.
Proof.
  eomega.
Qed.

Goal exists x1 x2 : Z, 0 <= x1 /\ 0 <= x1 + x2 /\ 1 <= x1 + x2 /\ x2 + 1 <= 0.
Proof.
  eomega.
Qed.

Goal exists x1 x2 x3 x4 : Z,
    x1 * x2 * x3 * x4 = 16 /\
    x1 * x2 < 0 /\
    x3 * x4 < 0.
Proof.
  eomega.
Qed.

Goal exists x1 x2 : Z,
    x1 * x2 = - 16 /\
    0 < x1 < 5 /\
    -5 < x2 < 0.
Proof.
  eomega 5.
Qed.

Goal exists x1 x2 : Z,
    x1 * x2 = - 16 /\
    0 < x1 < 5 /\
    -5 < x2 < 0.
Proof.
  Fail eomega sum 8. (* not implemented *)
  Fail eomega 3. (* not enough fuel *)
  eomega 4.
Qed.

Goal exists x, x * x * x = - 27.
Proof.
  eomega.
Qed.

(* We can iter on both Z and nat at the same time *)
Goal exists n : nat, exists z : Z, Z.pow z (Z.of_nat n) = - 27.
Proof.
  Fail eomega 4. (* omega can't handle those operators *)
  iter_cubes reflexivity.
Qed.

Definition fifth_root : { x | x * x * x * x * x = 69343957 }.
Proof.
  Time Fail Fail iter_cubes reflexivity. (* slightly faster than eomega *)
  eomega.
Defined.
Print fifth_root. (* 37, as 37^5 = 69343957, obviously *)

Goal { x | x * x * x * x = 81 }%nat.
Proof.
  Fail eomega 2.
  eomega 3.
Qed.

Goal { x | x * x * x = 81 }%nat.
Proof.
  Fail eomega 100.
Abort. (* no such number exists *)

End Tests.


(* This file imports the constructive indefinite description axiom. *)

Require Export Logic.IndefiniteDescription.

Require Import defs.
Require Import tactics.

Inductive inf_clos_cases (R : relation term) : term -> term -> Set :=
| inf_clos_cases_bot : forall t : term, R t bot -> inf_clos_cases R t bot
| inf_clos_cases_var : forall (t : term) (n : nat), R t (var n) -> inf_clos_cases R t (var n)
| inf_clos_cases_app : forall t x y x' y' : term,
    R t (app x y) -> inf_clos R x x' -> inf_clos R y y' -> inf_clos_cases R t (app x' y')
| inf_clos_cases_abs : forall t x x' : term, R t (abs x) -> inf_clos R x x' -> inf_clos_cases R t (abs x').

Lemma lem_inf_clos_cases {R : relation term} : forall t s, inf_clos R t s -> inf_clos_cases R t s.
Proof.
  enough (H: forall t s, inf_clos R t s -> { p : inf_clos_cases R t s | True }) by
      (intros t s H0; generalize (H t s H0); ycrush).
  enough (forall t s, inf_clos R t s -> exists p : inf_clos_cases R t s, True) by
      (intros; apply constructive_indefinite_description; ycrush).
  yelles 2.
Qed.

Inductive par_clos_cases (R : relation term) : term -> term -> Set :=
| par_clos_cases_base : forall x y, R x y -> par_clos_cases R x y
| par_clos_cases_bot : par_clos_cases R bot bot
| par_clos_cases_var : forall n, par_clos_cases R (var n) (var n)
| par_clos_cases_app : forall x y x' y', par_clos R x x' -> par_clos R y y' ->
                                         par_clos_cases R (app x y) (app x' y')
| par_clos_cases_abs : forall x y, par_clos R x y -> par_clos_cases R (abs x) (abs y).

Lemma lem_par_clos_cases {R : relation term} : forall t s, par_clos R t s -> par_clos_cases R t s.
Proof.
  enough (H: forall t s, par_clos R t s -> { p : par_clos_cases R t s | True }) by
      (intros t s H0; generalize (H t s H0); ycrush).
  enough (forall t s, par_clos R t s -> exists p : par_clos_cases R t s, True) by
      (intros; apply constructive_indefinite_description; ycrush).
  yelles 2.
Qed.


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

Require Export Eqdep.
(* The lemma uniq is taken from Bruno Barras , see coq-club msg # Fri, 17 May 2002 17:17:49 +0200
   It does not require any axiom because equality over nat is decidable *)
Require Export Eqdep_dec.
(* required for vcons *)
Require Export Peano_dec.
Require Export Omega.

Axiom proof_irr : forall (A : Prop) (p q : A), p = q.

Lemma two_step_ind :
 forall P : nat -> Prop,
 P 0 -> P 1 -> (forall n : nat, P n -> P (S (S n))) -> forall n : nat, P n.
intros P h0 h1 hr n; cut (P n /\ P (S n)).
intros H; elim H; trivial.
elim n.
split; trivial.
intros n0 H; try assumption.
elim H.
intros H0 H1; try assumption.
split; [ trivial | apply hr; trivial ].
Qed.

Section vect_def.
Variable A : Set.

Inductive vect : nat -> Set :=
  | vnil : vect 0
  | vcons : forall n : nat, A -> vect n -> vect (S n).

Lemma uniq : forall v : vect 0, v = vnil.
intros v.
change (v = eq_rec _ vect vnil _ (refl_equal 0)) in |- *.
generalize (refl_equal 0).
change
  ((fun (n : nat) (v : vect n) =>
    forall e : 0 = n, v = eq_rec _ vect vnil _ e) 0 v)
 in |- *.
case v; intros.
apply K_dec_set with (p := e).
exact eq_nat_dec.
reflexivity.
discriminate e.
Qed.
(* These two following theorems are derived from the hardware contrib of Coq *)

Definition eq_vect := eq_dep nat vect.

Lemma decompose_dep :
 forall n m : nat,
 m = S n ->
 forall v : vect (S n),
 {a : A &  {v' : vect n | eq_vect (S n) v (S n) (vcons n a v')}}.
intros n m H v.
generalize H; clear H.
dependent inversion_clear v
 with
  (fun (n' : nat) (vl : vect n') =>
   m = n' -> {a : A &  {v' : vect n | eq_vect n' vl (S n) (vcons n a v')}}).
unfold eq_vect in |- *.
intros H; exists a; exists v0.
apply eq_dep_intro.
Qed.

Lemma decompose :
 forall (n : nat) (v : vect (S n)),
 {a : A &  {v' : vect n | v = vcons n a v'}}.
intros n v.
cut {a : A &  {t : vect n | eq_vect (S n) v (S n) (vcons n a t)}}.
intros H; elim H; clear H.
intros a H; elim H; clear H.
intros v' H.
exists a; exists v'.
apply eq_dep_eq with (U := nat) (P := vect) (p := S n).
unfold eq_vect in H; trivial.
apply (decompose_dep n (S n)); trivial.
Qed.
(* end of hardware contrib *)

Lemma eq_vect_vcons :
 forall (c n : nat) (vc : vect c) (vn : vect n) (a a' : A),
 a = a' ->
 eq_vect c vc n vn -> eq_vect (S c) (vcons c a vc) (S n) (vcons n a' vn).
intros c n vc vn a a' H H'.
rewrite H.
cut (eq_vect (S c) (vcons c a' vc) (S c) (vcons c a' vc)).
intros Hcut.
unfold eq_vect in |- *.
apply
 (eq_dep_ind nat vect c vc
    (fun (n0 : nat) (v0 : vect n0) =>
     eq_dep nat vect (S c) (vcons c a' vc) (S n0) (vcons n0 a' v0)) Hcut n vn
    H').
unfold eq_vect in |- *; apply eq_dep_intro.
Qed.

Lemma vcons_lemma :
 forall (n : nat) (x y : A) (xs ys : vect n),
 x = y -> xs = ys -> vcons n x xs = vcons n y ys.
intros n x y xs ys Hxy Hxsys.
rewrite Hxy.
rewrite Hxsys.
trivial.
Qed.
(* recursion principles *)

Lemma induc1 :
 forall P : forall n : nat, vect n -> Prop,
 P 0 vnil ->
 (forall (n : nat) (v : vect n), P n v -> forall a : A, P (S n) (vcons n a v)) ->
 forall (n : nat) (v : vect n), P n v.
intros P Hnil Hvcons n.
elim n.
intros v.
replace v with vnil; [ idtac | rewrite uniq; auto ].
exact Hnil.
intros n0 HR v.
elim (decompose n0 v).
intros ve Hve; elim Hve; intros xe Heq.
rewrite Heq.
apply Hvcons.
apply HR.
Qed.

Lemma induc2 :
 forall P : forall n : nat, vect n -> vect n -> Prop,
 P 0 vnil vnil ->
 (forall (n : nat) (v v' : vect n),
  P n v v' -> forall a b : A, P (S n) (vcons n a v) (vcons n b v')) ->
 forall (n : nat) (v v' : vect n), P n v v'.
intros P Hnil Hvcons n.
elim n.
intros v v'.
replace v with vnil; [ idtac | rewrite uniq; auto ].
replace v' with vnil; [ idtac | rewrite uniq; auto ].
exact Hnil.
intros n0 HR v v'.
elim (decompose n0 v).
intros ve Hve; elim Hve; intros xe Heq.
rewrite Heq.
elim (decompose n0 v').
intros ve' Hve'; elim Hve'; intros xe' Heq'.
rewrite Heq'.
apply Hvcons.
apply HR.
Qed.

Lemma induc3 :
 forall P : forall n : nat, vect n -> vect n -> vect n -> Prop,
 P 0 vnil vnil vnil ->
 (forall (n : nat) (v v' v'' : vect n),
  P n v v' v'' ->
  forall a b c : A, P (S n) (vcons n a v) (vcons n b v') (vcons n c v'')) ->
 forall (n : nat) (v v' v'' : vect n), P n v v' v''.
intros P Hvnil Hvcons n.
elim n.
intros v v' v''.
replace v with vnil; [ idtac | rewrite uniq; auto ].
replace v' with vnil; [ idtac | rewrite uniq; auto ].
replace v'' with vnil; [ idtac | rewrite uniq; auto ].
exact Hvnil.
intros n0 HR v v' v''.
elim (decompose n0 v).
intros ve Hve; elim Hve; intros xe Heq.
rewrite Heq.
elim (decompose n0 v').
intros ve' Hve'; elim Hve'; intros xe' Heq'.
rewrite Heq'.
elim (decompose n0 v'').
intros ve'' Hve''; elim Hve''; intros xe'' Heq''.
rewrite Heq''.
apply Hvcons.
apply HR.
Qed.
(* some basic operations on vectors *)

Definition head (n : nat) (v : vect n) :=
  match v in (vect n) return (0 < n -> A) with
  | vnil => fun h : 0 < 0 => False_rec A (lt_irrefl 0 h)
  | vcons p a v' => fun h : 0 < S p => a
  end.

Lemma head_lemma_1 :
 forall v v' : vect 1, v = v' -> head 1 v (le_n 1) = head 1 v' (le_n 1).
intros v v' H; rewrite H; trivial.
Qed.

Definition tail (n : nat) (v : vect n) :=
  match v in (vect m) return (vect (pred m)) with
  | vnil => vnil
  | vcons p a v' => v'
  end.

Lemma le_S_lt_O : forall n m : nat, S m <= n -> 0 < n.
intros; apply lt_le_trans with (S m); auto with arith.
Qed.

Lemma lt_le_pred : forall n m : nat, n < m -> n <= pred m.
simple induction n; simple induction m; auto with arith.
Qed.

Lemma le_Sn_le_n_pred : forall n m : nat, S n <= m -> n <= pred m.
intros; apply lt_le_pred; trivial.
Qed.

Theorem zerop : forall n : nat, {n = 0} + {0 < n}.
destruct n; auto with arith.
Defined.

Fixpoint nth (i : nat) : forall n : nat, vect n -> 0 < i -> i <= n -> A :=
  fun (n : nat) (v : vect n) =>
  match i as j return (0 < j -> j <= n -> A) with
  | O => fun (h' : 0 < 0) h'' => False_rec A (lt_irrefl 0 h')
  | S p =>
      fun (h' : 0 < S p) (h'' : S p <= n) =>
      match zerop p with
      | left _ => head n v (le_S_lt_O _ _ h'')
      | right h => nth p (pred n) (tail n v) h (le_Sn_le_n_pred _ _ h'')
      end
  end.

Remark nth_lemma_aux : forall (i n : nat) (Hi2 : S i <= S n), i <= n.
intros; apply le_S_n; trivial.
Qed.

Lemma nth_lemma :
 forall (i n : nat) (a : A) (v : vect n) (Hi1 : 0 < S (S i))
   (Hi2 : S (S i) <= S n) (Hi1' : 0 < S i),
 nth (S (S i)) (S n) (vcons n a v) Hi1 Hi2 =
 nth (S i) n v Hi1' (le_Sn_le_n_pred (S i) (S n) Hi2).
intros i; elim i using two_step_ind.
intros n a v Hi1 Hi2 Hi1'; simpl in |- *; trivial.
intros i' a v Hi1 Hi2 Hi1'; simpl in |- *; trivial.
intros i' HR n' a v Hi1 Hi2 Hi1'; simpl in |- *; trivial.
Qed.

Lemma nth_lemma' :
 forall (c n : nat) (w : vect n) (a : A) (H1 : 0 < S c)
   (H2 : S c <= S n) (H1' : 0 < c),
 nth (S c) (S n) (vcons n a w) H1 H2 =
 nth c n w H1' (le_Sn_le_n_pred c (S n) H2).
intros c; elim c.
intros n w a H1 H2 H1'; inversion H1'.
intros c' HR.
simpl in |- *; trivial.
Qed.
(* last *)

Lemma last_o1 : forall n c' : nat, S c' <= n -> 0 < n - c'.
intros; omega.
Qed.

Lemma last_o2 : forall n c' : nat, n - c' <= n.
intros; omega.
Qed.

Lemma last_o3 : forall c' : nat, 0 <= c'.
intros; omega.
Qed.

Lemma last_o4 : forall c' n : nat, S c' <= n -> c' <= n.
intros; omega.
Qed.

Definition last :
  forall (n : nat) (v : vect n) (c : nat), 0 <= c -> c <= n -> vect c.
intros n v; fix 1.
intros c; case c.
intros; apply vnil.
intros c' Hc1' Hc2'.
apply vcons.
apply (nth (n - c') n v).
apply last_o1; assumption.
apply last_o2; assumption.
apply last.
apply last_o3; assumption.
apply last_o4; assumption.
Defined.

Lemma last_vcons :
 forall (n : nat) (w : vect n) (c : nat) (H1 : 0 < n - c)
   (H2 : n - c <= n) (H1c' : 0 <= S c) (H2c' : S c <= n)
   (H1c : 0 <= c) (H2c : c <= n),
 vcons c (nth (n - c) n w H1 H2) (last n w c H1c H2c) =
 last n w (S c) H1c' H2c'.
intros n w c H1 H2 H1c' H2c' H1c H2c.
unfold last at 2 in |- *.
apply vcons_lemma.
rewrite (proof_irr _ H1 (last_o1 n c H2c')).
rewrite (proof_irr _ H2 (last_o2 n c)).
trivial.
rewrite (proof_irr _ H1c (last_o3 c)).
rewrite (proof_irr _ H2c (last_o4 c n H2c')).
trivial.
Qed.

Lemma last_S :
 forall (c n : nat) (a : A) (v : vect n) (H1 : 0 <= c)
   (H2 : c <= n) (H2' : c <= S n),
 last n v c H1 H2 = last (S n) (vcons n a v) c H1 H2'.
intros c; elim c.
intros n a v H1 H2 H2'; try assumption.
rewrite (uniq (last n v 0 H1 H2)).
rewrite (uniq (last (S n) (vcons n a v) 0 H1 H2')); trivial.
intros c' HR.
intros n a v H1 H2 H2'.
unfold last in |- *.
apply vcons_lemma.
generalize (last_o1 (S n) c' H2') (last_o2 (S n) c').
rewrite <- minus_Sn_m.
intros Hcut1 Hcut2.
symmetry  in |- *.
rewrite (nth_lemma' (n - c') n v a Hcut1 Hcut2 (last_o1 n c' H2)).
rewrite (proof_irr _ (le_Sn_le_n_pred (n - c') (S n) Hcut2) (last_o2 n c')).
trivial.
replace
 (fix last (c0 : nat) : 0 <= c0 -> c0 <= n -> vect c0 :=
    match c0 as c1 return (0 <= c1 -> c1 <= n -> vect c1) with
    | O => fun (_ : 0 <= 0) (_ : 0 <= n) => vnil
    | S c'0 =>
        fun (_ : 0 <= S c'0) (Hc2' : S c'0 <= n) =>
        vcons c'0 (nth (n - c'0) n v (last_o1 n c'0 Hc2') (last_o2 n c'0))
          (last c'0 (last_o3 c'0) (last_o4 c'0 n Hc2'))
    end) with (last n v); [ idtac | trivial ].
replace
 (fix last (c0 : nat) : 0 <= c0 -> c0 <= S n -> vect c0 :=
    match c0 as c1 return (0 <= c1 -> c1 <= S n -> vect c1) with
    | O => fun (_ : 0 <= 0) (_ : 0 <= S n) => vnil
    | S c'0 =>
        fun (_ : 0 <= S c'0) (Hc2' : S c'0 <= S n) =>
        vcons c'0
          (nth (S n - c'0) (S n) (vcons n a v) (last_o1 (S n) c'0 Hc2')
             (last_o2 (S n) c'0))
          (last c'0 (last_o3 c'0) (last_o4 c'0 (S n) Hc2'))
    end) with (last (S n) (vcons n a v)); [ idtac | trivial ].
omega.
apply (HR n a v (last_o3 c') (last_o4 c' n H2) (last_o4 c' (S n) H2')).
Qed.

Lemma last_vcons' :
 forall (n : nat) (w : vect n) (c : nat) (a : A) (H1 : 0 < n - c)
   (H2 : n - c <= n) (H1c' : 0 <= S c) (H2c' : S c <= S n)
   (H1c : 0 <= c) (H2c : c <= n),
 vcons c (nth (n - c) n w H1 H2) (last n w c H1c H2c) =
 last (S n) (vcons n a w) (S c) H1c' H2c'.
intros n; elim n.
intros w c a H1 H2 H1c' H2c' H1c H2c; cut (c = 0).
intros Hrew; generalize w a H1 H2 H1c' H2c' H1c H2c;
 clear w a H1 H2 H1c' H2c' H1c H2c.
rewrite Hrew.
intros w a H1; simpl in H1; inversion H1.
omega.
intros n0 HR v c.
intros a H1 H2 H1c' H2c' H1c H2c.
cut (c <= n0).
intros Hcut; generalize a H1 H2 H1c' H2c' H1c H2c;
 clear a H1 H2 H1c' H2c' H1c H2c.
rewrite <- (minus_Sn_m _ _ Hcut).
2: omega.
intros a H1 H2 H1c' H2c' H1c H2c.
unfold last at 2 in |- *.
apply vcons_lemma.
generalize (last_o1 (S (S n0)) c H2c') (last_o2 (S (S n0)) c).
replace (S (S n0) - c) with (S (S (n0 - c))); [ idtac | omega ].
intros Hcut1 Hcut2.
symmetry  in |- *.
rewrite (nth_lemma' (S (n0 - c)) (S n0) v a Hcut1 Hcut2 H1).
rewrite (proof_irr _ H2 (le_Sn_le_n_pred (S (n0 - c)) (S (S n0)) Hcut2)).
trivial.
replace
 (fix last (c : nat) : 0 <= c -> c <= S (S n0) -> vect c :=
    match c as c1 return (0 <= c1 -> c1 <= S (S n0) -> vect c1) with
    | O => fun (_ : 0 <= 0) (_ : 0 <= S (S n0)) => vnil
    | S c' =>
        fun (_ : 0 <= S c') (Hc2' : S c' <= S (S n0)) =>
        vcons c'
          (nth (S (S n0) - c') (S (S n0)) (vcons (S n0) a v)
             (last_o1 (S (S n0)) c' Hc2') (last_o2 (S (S n0)) c'))
          (last c' (last_o3 c') (last_o4 c' (S (S n0)) Hc2'))
    end) with (last (S (S n0)) (vcons (S n0) a v));
 [ idtac | trivial ].
generalize (last_S c (S n0) a v H1c H2c (last_o4 c (S (S n0)) H2c')).
rewrite (proof_irr _ H1c (last_o3 c)).
trivial.
Qed.

Lemma last_n :
 forall (c n : nat) (v : vect n) (H : c = n) (H1 : 0 <= c) (H2 : c <= n),
 eq_vect c (last n v c H1 H2) n v.
intros c; elim c.
intros n v H; simpl in |- *.
intros H1 H2.
generalize H v; case n.
intros; rewrite uniq.
unfold eq_vect in |- *; apply eq_dep_intro.
intros n' Hd; discriminate Hd.
intros c' HR n; case n.
intros v Hd; discriminate Hd.
intros n' v' Heq H1 H2.
cut (0 < S n' - c'); [ intros Hcut1 | omega ].
cut (S n' - c' <= S n'); [ intros Hcut2 | omega ].
cut (0 <= S c'); [ intros Hcut3 | omega ].
cut (S c' <= S n'); [ intros Hcut4 | omega ].
cut (0 <= c'); [ intros Hcut5 | omega ].
cut (c' <= S n'); [ intros Hcut6 | omega ].
elim (decompose _ v').
intros x0 Hx; elim Hx; clear Hx; intros v0 Heq'.
rewrite Heq'.
rewrite <-
 (last_vcons (S n') (vcons n' x0 v0) c' Hcut1 Hcut2 H1 H2 Hcut5 Hcut6)
 .
apply
 (eq_vect_vcons c' n' (last (S n') (vcons n' x0 v0) c' Hcut5 Hcut6) v0
    (nth (S n' - c') (S n') (vcons n' x0 v0) Hcut1 Hcut2) x0).
cut (S n' - c' = 1); [ intros Hcut'' | omega ].
generalize Hcut1 Hcut2; rewrite Hcut''.
simpl in |- *; trivial.
rewrite <- (last_S c' n' x0 v0 Hcut5 (le_S_n _ _ Hcut4) Hcut6).
apply HR.
omega.
Qed.

Lemma last_n' :
 forall (n : nat) (v : vect n) (H1 : 0 <= n) (H2 : n <= n),
 last n v n H1 H2 = v.
intros; apply (eq_dep_eq nat vect n (last n v n H1 H2) v).
apply last_n.
trivial.
Qed.

End vect_def.

Fixpoint map (A B : Set) (f : A -> B) (n : nat) (v : vect A n) {struct v} :
 vect B n :=
  match v in (vect _ p) return (vect B p) with
  | vnil => vnil B
  | vcons p x v' => vcons B p (f x) (map A B f p v')
  end.

Lemma map_2 :
 forall (A B : Set) (n : nat) (t : vect A n) (f : A -> B)
   (g : B -> A) (H : forall x : A, g (f x) = x),
 map B A g n (map A B f n t) = map A A (fun x : A => g (f x)) n t.
intros A2 B n; elim n.
intros t f g H; rewrite (uniq A2).
rewrite (uniq B (map A2 B f 0 t)).
simpl in |- *; trivial.
intros n0 H t f g H0; try assumption.
elim (decompose A2 n0 t).
intros x Hx; elim Hx; intros v Hvx; rewrite Hvx; clear Hx Hvx.
simpl in |- *.
rewrite H.
trivial.
apply H0.
Qed.

Lemma map_2' :
 forall (A B : Set) (n : nat) (t : vect A n) (f : A -> B)
   (g : B -> A) (H : forall x : A, g (f x) = x),
 map B A g n (map A B f n t) = t.
intros A2 B n; elim n.
intros t f g H; rewrite (uniq A2).
rewrite (uniq B (map A2 B f 0 t)).
simpl in |- *; trivial.
intros n0 H t f g H0; try assumption.
elim (decompose A2 n0 t).
intros x Hx; elim Hx; intros v Hvx; rewrite Hvx; clear Hx Hvx.
simpl in |- *.
rewrite H.
rewrite H0; trivial.
apply H0.
Qed.

  (*
  Local Variables:
  mode: coq
  coq-prog-name: "/usr/local/coq-7.4/bin/coqtop -emacs -q"
  compile-command: "make vectors.vo"
  End:
  *)


(** * Certifying translation *)

(** Proving that concrete expressions translate correctly *)

From ConCert Require Import Ast EvalE Notations EnvSubst PCUICTranslate PCUICtoTemplate CustomTactics.
From Coq Require Import Basics String List.

Import ListNotations.
Import NamelessSubst.
Import BaseTypes.
Import StdLib.

Notation "'eval' ( Σ , n , e )"  := (expr_eval_i Σ n [] e) (at level 100).

Definition expr_to_tc Σ := compose trans (expr_to_term Σ).
Definition type_to_tc := compose trans type_to_term.
Definition global_to_tc := compose trans_minductive_entry trans_global_dec.

Definition x := "x".
Definition y := "y".
Definition z := "z".

(** ** Negation on booleans *)

(** First we define a conversion function taking a bool and producing the corresponding syntactic λsmart value *)
Definition of_bool : bool -> val :=
  fun b => if b then vConstr Bool "true" []
        else vConstr Bool "false" [].

Definition my_negb_syn :=
  [| \x : Bool =>
          case x : Bool return Bool of
          | True -> False
          | False -> True |].

(** We translate and unquote using the ConCert embedding feature *)
Make Definition my_negb := (expr_to_tc Σ (indexify nil my_negb_syn)).

(** We prove that the running the interpreter with [my_negb_syn] applied to an expression originating from Coq' boolean value computes the same result as the unquoted function [my_negb]. As a result, we do not depend on correctness of [unquote]  *)
Lemma my_negb_correct b :
  exists n v,
    eval(Σ, n,
         indexify nil ([| {my_negb_syn} {of_val_i (of_bool b)} |]) ) = Ok v
      /\ v = of_bool (negb b).
Proof.
  destruct b; exists 3;eexists;simpl;eauto.
Qed.

(** One can prove similar results any non-recursive definition. Proofs in this case would require just case analysis and computation. For recursive definitions proofs would require induction and some additional lemmas *)


Require Import
 Unicode.Utf8 Program
 CRArith CRabs
 Qminmax Qauto Qround Qmetric
 stdlib_omissions.P
 stdlib_omissions.Z
 stdlib_omissions.Q
 stdlib_omissions.N
 metric2.Classified
 util.Container Ranges
 decision.

Require QnonNeg QnnInf CRball.
Import QnonNeg.notations QnnInf.notations CRball.notations.

Implicit Arguments proj1_sig [[A] [P]].

Local Open Scope Q_scope.
Local Open Scope uc_scope.
Local Open Scope CR_scope.

Hint Immediate ball_refl Qle_refl.

(** Some missing theory about positive: *)

Lemma Pmax_le_l (x y: positive): (x <= Pmax x y)%positive.
Admitted.

Lemma Pmax_le_r (x y: positive): (x <= Pmax y x)%positive.
Admitted.

Hint Immediate Pmax_le_l Pmax_le_r.

(** A few summing/enumming utilities: *)

Program Fixpoint enum' (n: nat): list (sig (ge n)) :=
  match n with
  | O => nil
  | S n' => n' :: map (λ x: sig (ge n'), x) (enum' n')
  end.

Lemma enum_enum' (n: nat): enum n = map (@proj1_sig _ _) (enum' n).
Proof.
 induction n; simpl. reflexivity.
 rewrite IHn, map_map. reflexivity.
Qed.

Lemma length_enum' n: length (enum' n) = n.
Proof with auto with arith.
 induction n...
 simpl. rewrite map_length...
Qed.

Definition cmΣ {M: CMonoid} (n: nat) (f: nat -> M): M := cm_Sum (map f (enum n)).
Definition cmΣ' {M: CMonoid} (n: nat) (f: sig (ge n) → M): M := cm_Sum (map f (enum' n)).

Opaque CR.

Lemma cm_Sum_constant (c: CR) (l: list CR): (forall x, List.In x l → x == c) → cm_Sum l == ' length l * c.
Proof with auto.
 intros.
 induction l.
  simpl.
  admit.
 simpl.
 rewrite IHl...
 admit.
Qed.

Lemma cmΣ'_constant (c: CR) (n: nat): cmΣ' n (λ _, c) == ' n * c.
Proof with auto.
 unfold cmΣ'.
 rewrite (cm_Sum_constant c).
  rewrite map_length, length_enum'. reflexivity.
 intros.
 apply in_map_iff in H.
 destruct H.
 symmetry.
 destruct H.
 subst.
 reflexivity.
Qed.

(** A straightforward definition of a Riemann approximation with n samples: *)

Program Definition Riemann (r: Range Q) (f: sig (In r) → CR) (n: positive): CR :=
  let w := (snd r - fst r)%Q in
  let iw: Q := w / n in
    ' iw * cmΣ' (nat_of_P n) (λ i, f (fst r + (` i: nat) * iw)%Q).

Next Obligation. Proof with auto with *.
 apply alt_in_QRange.
 exists (i / n).
 split.
  split.
   apply Qmult_le_0_compat.
    admit.
   apply Qinv_le_0_compat...
  apply Qdiv_le_1.
  split...
  admit.
 unfold Qdiv.
 generalize (Qinv n).
 intro.
 ring.
Qed.

(** ... and some properties thereof: *)

Lemma Riemann_plus (r: Range Q) (f g: sig (In r) → CR) n:
  Riemann r (λ x, f x + g x) n == Riemann r f n + Riemann r g n.
Proof with auto.
 unfold Riemann.
 unfold cmΣ'.
Admitted.

Lemma Riemann_scale (r: Range Q) (f: sig (In r) → CR) (c: CR) n:
  Riemann r (CRmult c ∘ f)%prg n == c * Riemann r f n.
Proof with auto.
 unfold Riemann.
 unfold cmΣ'.
 unfold Basics.compose.
Admitted.

(** Finally, we say what it means for a value to be the integral of a function on some range: *)

Class Integral (r: Range Q) (f: sig (∈ r) → CR): Type := integral:
  sig (λ x: CR, ∀ e: Qpos, ∃ n: positive, ∀ m: positive,
   (n <= m)%positive → ball e (Riemann r f m) x).
    (* this used to be just [∃ n, ball e (Riemann r f n) x], but i couldn't prove unicity that way *)

Implicit Arguments Integral [[r]].
Implicit Arguments integral [[r] [Integral]].

Notation "∫" := integral.

Lemma integral_unique (r: Range Q) (f: sig (In r) → CR)
  {i0: Integral f} {i1: Integral f}: ` i0 == ` i1.
Proof with auto.
 destruct i0, i1.
 simpl @proj1_sig.
 apply ball_eq.
 intros.
 set (h := (e1 * (1#2))%Qpos).
 setoid_replace e1 with (h+h)%Qpos.
  2: subst h; unfold QposEq; simpl; ring.
 specialize (e h).
 specialize (e0 h).
 destruct e, e0.
 apply ball_triangle with (Riemann r f (Pmax x1 x2))...
 apply ball_sym...
Qed.

(** We know what the integral must be for constant functions: *)

Obligation Tactic := idtac.

Section constant_integral.

  Context (r: Range Q) (y: CR).

  Notation f := (λ _: sig (In r), y).

  Program Definition integrate_constant: Integral f := ' (snd r - fst r)%Q * y.

  Next Obligation. Proof with auto.
   intros.
   exists 1%positive.
   intros.
   apply ball_eq_iff.
   unfold Riemann.
   clear H.
   rewrite cmΣ'_constant.
   admit. (* arithmetic *)
  Qed.

  Program Lemma constant_integral `{!Integral (λ _: sig (In r), y)}:
    ∫ f == integrate_constant.
  Proof. intros. apply integral_unique. Qed.

End constant_integral.

(** ...and for sums: *)

Section additive.

  Context
    (r: Range Q)
    (f g: sig (In r) → CR)
    `{!Integral f}
    `{!Integral g}.

  Let summed := (λ x, f x + g x).

  Program Definition sum_integrals: Integral summed := ∫ f + ∫ g.
  Next Obligation.
   intro.
   unfold integral.
   destruct Integral0, Integral1.
   simpl @proj1_sig.
   set (h := (e * (1#2))%Qpos).
   specialize (e0 h).
   specialize (e1 h).
   destruct e0, e1.
   exists (Pmax x1 x2).
   intros.
   setoid_replace e with (h+h)%Qpos.
    2: subst h; unfold QposEq; simpl; ring.
   unfold summed. rewrite Riemann_plus.
   admit. (* not hard *)
  Qed.

  Program Lemma summed_integral `{!Integral summed}:
    ∫ summed == sum_integrals.
  Proof. intro. apply integral_unique. Qed.

End additive.

(** ...and for scaled functions: *)

Section scalar_mult.

  Context (r: Range Q) (f: sig (∈ r) → CR) `{!Integral f} (c: Qpos).

  Let scaled := (CRmult (' c) ∘ f)%prg.

  Program Definition scale_integral: Integral scaled := ' c * ∫ f.
  Next Obligation.
   intro.
   unfold integral.
   destruct Integral0.
   simpl @proj1_sig.
   specialize (e0 (e / c)%Qpos).
   destruct e0.
   exists x0.
   intros.
   specialize (H m H0).
   unfold scaled.
   rewrite Riemann_scale.
   admit. (* not hard *)
  Qed.

  Program Lemma scaled_integral `{!Integral scaled}:
    ∫ scaled == scale_integral.
  Proof. intro. apply integral_unique. Qed.

End scalar_mult. (* Todo: generalize to more than just Qpos *)

(** ...and if we know the integral for a function at two adjacent ranges, we know the
 integral on the merged range: *)

Section adjacent.

  Context
    (a b c: Q)
    (fab: sig (In (a, b)) → CR)
    (fbc: sig (In (b, c)) → CR)
    (fac: sig (In (a, c)) → CR)
    (fab_good: ∀ x x', (` x == ` x')%Q → fab x == fac x')
    (fbc_good: ∀ x x', (` x == ` x')%Q → fac x == fac x')
    `{!Integral fab}
    `{!Integral fbc}.

  Program Definition integrate_merged: Integral fac := ∫ fab + ∫ fbc.
  Next Obligation.
   intro.
   unfold integral.
   destruct Integral0, Integral1.
   simpl @proj1_sig.
   set (h := (e * (1#2))%Qpos).
   specialize (e0 h).
   specialize (e1 h).
   destruct e0, e1.
   exists (x1 * x2)%positive.
   intros.
  Admitted. (* hassle, but doable, i think *)

  Context `{!Integral fac}.

  Program Lemma adjacent: ∫ fac == ∫ fab + ∫ fbc.
  Proof.
   transitivity (` integrate_merged).
    apply integral_unique.
   reflexivity.
  Qed.

End adjacent.

(** More generally, we can implement integration of uniformly continuous functions: *)

Section implementable.

  Context (r: Range Q) (f: sig (∈ r) → CR)
    `{!UniformlyContinuous_mu f}
    `{!UniformlyContinuous f}.

  Definition integrate_ucFunc: Integral f.
  Admitted.

End implementable.

(* Note: This should be much easier than it was in the old setting, because now all
 we'll need to do (hopefully) in the implementation is show that it does indeed produce
 Riemann approximations, and we no longer have to show Bishop's properties. *)

(** It should be fairly easy to prove that the implementation above
 is continuous in the function parameter: *)

Section continuity_in_f. (* with fixed range *)

  Context (r: Range Q) .

  Program Let raw (u: UCFunction (sig (∈ r)) CR): CR := integrate_ucFunc r u.
    (* needed to remove the type dependency by dropping the Integral wrapping around the result CR *)

  Instance: UniformlyContinuous_mu raw.
   constructor.
   intro. admit.
  Defined.

  Instance: UniformlyContinuous raw.
  Proof with auto.
   constructor.
     apply _.
    apply _.
   intros.
   unfold raw.
   unfold uc_mu in H.
   simpl in H.
  Admitted.

End continuity_in_f.

(** Continuity in both range and function simultaneously is trickier. *)

Section extend.

  Context (T: Type) (P: T → Prop) `{∀ t, Decision (P t)} (f: sig P → CR).

  Definition extend (t: T): CR :=
    match decide (P t) with
    | left H => f (exist _ _ H)
    | right _ => 0
    end.

  Context `{te: canonical_names.Equiv T}.

  Global Instance: Proper canonical_names.equiv extend.
  Admitted.

End extend.

Section continuity_in_both.

  Context (bound: Range CR).

  Definition IntegrationInput := sigT (λ r: Range Q, UCFunction (sig (∈ r)) (sig (∈ bound))).
    (* Hm, I think this probably needs an a-priori bound on r as well.. *)

  Instance dec_in: ∀ (a: Range Q), (∀ t : Q, Decision ((∈ a) t)).
  Admitted.

  Program Definition metric: IntegrationInput → Range Q * @sig (Q → CR) (Proper canonical_names.equiv) :=
   λ ab, (projT1 ab, (@extend Q (∈ projT1 ab) _ (@proj1_sig _ _ ∘ ucFun_itself (projT2 ab))%prg)).
     (* should never actually run at runtime *)
(*
  Global Instance IntegrationInput_equiv: canonical_names.Equiv IntegrationInput := delegated_equiv _ metric.
  Global Instance IntegrationInput_ball: MetricSpaceBall IntegrationInput := delegated_ball _ metric.
  Global Instance IntegrationInput_mspc: MetricSpaceClass IntegrationInput.
  Proof. apply (delegated_mspc _ metric). Qed.

  Program Definition integrate_ucFunc_wrapped_for_continuity: IntegrationInput → CR :=
    λ p, integrate_ucFunc (fst (projT1 p), snd (projT1 p)) (λ x, projT2 p (` x)).

  Next Obligation.
   intros.
   destruct x.
   simpl.
   assumption.
  Qed.

  Global Instance integrate_ucFunc_wrapped_for_continuity_mu: UniformlyContinuous_mu integrate_ucFunc_wrapped_for_continuity.
  Admitted.

  Global Instance integrate_ucFunc_wrapped_for_continuity_uc: UniformlyContinuous integrate_ucFunc_wrapped_for_continuity.
  Proof.
   constructor.
     apply _.
    apply _.
   admit.
  Qed.
*)
End continuity_in_both.