Inductive Tree 0 : Set :=
| Pair : Tree -> Tree -> Tree
| Next : Tree -> Tree
| Terminal : Tree.

Theorem comp : Tree -> Tree -> Tree.
Proof.

f : A -> B     x : A
--------------------
      f x : B

Gamma |- t : A   =>   t |= Theta[A]

map succ x |=_{x |= B} A        map succ nats |= B
---------------------------------------------------
        map succ (map succ nats) |= A

-------------------------------     -----------------
omega |=_{(fold omega) |= D}  D     (fold omega) |= D
-----------------------------------------------------
            omega (fold omega) |= D


Require Export D.

Theorem fold_constants_aexp_sound :
  atrans_sound fold_constants_aexp.

Proof.
  unfold atrans_sound. intro a. unfold aequiv.  intros st.
  aexp_cases (induction a) Case; try reflexivity.
(* 여기서 simpl을 해줘야함. simpl을 하고 나서 destruct 해야, 전개된 fold_constatns_aexp a1 들까지 다 destruct 된다 !! *)

simpl.
destruct (fold_constants_aexp a1); destruct (fold_constants_aexp a2); rewrite IHa1; rewrite IHa2; reflexivity.

simpl.
destruct (fold_constants_aexp a1); destruct (fold_constants_aexp a2); rewrite IHa1; rewrite IHa2; reflexivity.

simpl.
destruct (fold_constants_aexp a1); destruct (fold_constants_aexp a2); rewrite IHa1; rewrite IHa2; reflexivity.
Qed.

Lemma optimize_0plus_aexp_sound:
  atrans_sound optimize_0plus_aexp.
Proof.
  unfold atrans_sound.
  intros a.
  induction a;
    try (simpl; apply refl_aequiv).
    destruct a1.
      destruct n.
        unfold aequiv. simpl. apply IHa2.
        unfold aequiv. unfold aequiv in IHa2.
        simpl. intros st. rewrite IHa2.
Qed.

Lemma aeval_lem : forall st a2 a,
  (aeval st match a2 with |ANum 0 => a | _ => APlus a (optimize_0plus_aexp a2) end = aeval st (APlus a (optimize_0plus_aexp a2))).
Proof. intros. destruct a2; try reflexivity. destruct n. simpl. omega. reflexivity. Qed.

Lemma opt_APlus_helper : forall a1 a2 st,
  aeval st a1 = aeval st (optimize_0plus_aexp a1) ->
  aeval st a2 = aeval st (optimize_0plus_aexp a2) ->
  aeval st a1 + aeval st a2= aeval st (APlus (optimize_0plus_aexp a1) (optimize_0plus_aexp a2)).
Proof. intros. aexp_cases (induction a1) Case;
  (* a1 = ANum, Aid *)
  try (simpl; rewrite H0; reflexivity);   simpl; rewrite<-H0;
  (* a1 = AMinus AMult *)
  try (inversion H; reflexivity).
Qed.
(* 이거 다시 한번 증명해봐... a1 = APlus 일 때 inversion 잘 쓰면 된다는거 이해하기!! *)

Lemma optimize_0plus_aexp_sound:
  atrans_sound optimize_0plus_aexp.
Proof.
  unfold atrans_sound; intros; unfold aequiv; intros.
  aexp_cases (induction a) Case; try reflexivity; try (simpl; rewrite IHa1; rewrite IHa2; reflexivity).
  simpl. aexp_cases (destruct (optimize_0plus_aexp a1) eqn:Ha) SCase.
(*  aexp_cases (induction a1) SCase. *)
  simpl. destruct a1.
  destruct n0. simpl. assumption. rewrite aeval_lem. simpl. rewrite IHa2. inversion Ha. reflexivity.
  simpl. rewrite aeval_lem. simpl. rewrite IHa2. inversion Ha.
  rewrite aeval_lem. simpl. rewrite IHa2. simpl in IHa1. rewrite IHa1. reflexivity.
  rewrite aeval_lem. simpl. rewrite IHa2. simpl in IHa1. rewrite IHa1. reflexivity.
  rewrite aeval_lem. simpl. rewrite IHa2. simpl in IHa1. rewrite IHa1. reflexivity.
  destruct a1.
  destruct n. simpl. assumption.
  rewrite aeval_lem. simpl. rewrite IHa2. inversion Ha.
  rewrite aeval_lem. simpl. rewrite IHa2. simpl in IHa1. rewrite IHa1. reflexivity.
  rewrite aeval_lem. simpl. rewrite IHa2. simpl in IHa1. rewrite IHa1. reflexivity.
  rewrite aeval_lem. simpl. rewrite IHa2. simpl in IHa1. rewrite IHa1. reflexivity.
  rewrite aeval_lem. simpl. rewrite IHa2. simpl in IHa1. rewrite IHa1. reflexivity.

  destruct a1.
  destruct n. simpl. assumption.
  rewrite aeval_lem. simpl. rewrite IHa2. inversion Ha.
  rewrite aeval_lem. simpl. rewrite IHa2. inversion Ha.
  rewrite aeval_lem. simpl. rewrite IHa2. inversion Ha.
  simpl in IHa1. rewrite IHa1. reflexivity.
   rewrite aeval_lem. simpl. rewrite IHa2. inversion Ha.
  rewrite aeval_lem. simpl. rewrite IHa2. inversion Ha.

  destruct a1.
  destruct n. simpl. assumption.
  rewrite aeval_lem. simpl. rewrite IHa2. inversion Ha.
  rewrite aeval_lem. simpl. rewrite IHa2. inversion Ha.
  rewrite aeval_lem. simpl. rewrite IHa2. inversion Ha.
  simpl in IHa1. rewrite IHa1. reflexivity.
   rewrite aeval_lem. simpl. rewrite IHa2. inversion Ha.
  simpl in IHa1.  rewrite IHa1. rewrite H0. rewrite H1. reflexivity.
  simpl. rewrite aeval_lem. simpl. rewrite IHa2. simpl in IHa1. rewrite IHa1. reflexivity.

  destruct a1.
  destruct n. simpl. assumption.
  rewrite aeval_lem. simpl. rewrite IHa2. inversion Ha.
  rewrite aeval_lem. simpl. rewrite IHa2. inversion Ha.
  rewrite aeval_lem. simpl. rewrite IHa2. inversion Ha.


Require Import VST.floyd.proofauto.
Require Import curve448.
Require Import list_int_functions.
Require Import stdpp.list.
Require Import ZArith.
Require Import compcert.lib.Coqlib.
Require Import list_lemmas.

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

Local Open Scope Z.

Definition prime: Z := 2^448 - 2^224 - 1.

Definition undef14 :=
       [Vundef; Vundef; Vundef; Vundef; Vundef; Vundef; Vundef;
        Vundef; Vundef; Vundef; Vundef; Vundef; Vundef; Vundef].

(* Functions to compute added lists. *)
Definition is_big (n : Z) (a : list Z) (b : Z) :=
   if (n =? 0)
      then Znth n a + b >=? Int.modulus
      else Int.eq (Int.repr (Znth n a)) Int.mone.

Fixpoint allprev_big_aux (n : nat) (a : list Z) (b : Z) : bool :=
   match n with
   | O   => true
   | S n' => is_big (Z.of_nat n') a b
            && allprev_big_aux n' a b
   end.

Definition allprev_big (i b : Z) (a : list Z) :=
   allprev_big_aux (Z.to_nat i) a b.

Definition allprev_big_compute (i b : Z) (a : list Z) :=
   if (i =? 0) then Vlong (Int64.repr b)
   else if (allprev_big i b a)
                        then Vlong Int64.one
                        else Vlong Int64.zero.

Fixpoint added_list_aux (n : nat) (b : Z) (a : list Z):=
   match n with
   | O    => [(Znth (Z.of_nat n) a) + b]
   | S n' => added_list_aux n' b a ++
             [(Znth (Z.of_nat (S n')) a)
             + (if (allprev_big (Z.of_nat (S n')) b a) then 1 else 0) mod Int.modulus]
   end.

Definition added_list (a : list Z) (b : Z):=
   added_list_aux 13 b a.
(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
(* %%%%%%%%%%%%% Lemmas about added_lists %%%%%%%%%%%%% *)
Lemma zlength_added_list:
forall a: list Z, forall b : Z,
Zlength (added_list a b) = 14.
Proof.
   intros.
   unfold added_list.
   unfold added_list_aux.
   list_solve.
Qed.

Lemma znth_added_list:
forall i:nat, forall b: Z, forall a : list Z,
0 < (Z.of_nat i) < Zlength (added_list a b) ->
Znth (Z.of_nat i) (added_list a b) =
         Znth (Z.of_nat i) a +
         (if allprev_big (Z.of_nat i) b a then 1 else 0) mod Int.modulus.
Proof. (* By manual induction for now. *)
   intros.
   destruct i.
   destruct H; discriminate H.
   replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) in * by lia.
   destruct i. unfold added_list; unfold added_list_aux; list_solve;
   replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) in * by lia.
   destruct i. unfold added_list; unfold added_list_aux; list_solve;
   replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) in * by lia.
   destruct i. unfold added_list; unfold added_list_aux; list_solve;
   replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) in * by lia.
   destruct i. unfold added_list; unfold added_list_aux; list_solve;
   replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) in * by lia.
   destruct i. unfold added_list; unfold added_list_aux; list_solve;
   replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) in * by lia.
   destruct i. unfold added_list; unfold added_list_aux; list_solve;
   replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) in * by lia.
   destruct i. unfold added_list; unfold added_list_aux; list_solve;
   replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) in * by lia.
   destruct i. unfold added_list; unfold added_list_aux; list_solve;
   replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) in * by lia.
   destruct i. unfold added_list; unfold added_list_aux; list_solve;
   replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) in * by lia.
   destruct i. unfold added_list; unfold added_list_aux; list_solve;
   replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) in * by lia.
   destruct i. unfold added_list; unfold added_list_aux; list_solve;
   replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) in * by lia.
   destruct i. unfold added_list; unfold added_list_aux; list_solve;
   replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) in * by lia.
   destruct i. unfold added_list; unfold added_list_aux; list_solve;
   replace (Z.of_nat (S i)) with ((Z.of_nat i)+1) in * by lia.
   rewrite zlength_added_list in H.
   assert (Z.of_nat (S (S (S (S (S (S (S (S (S (S (S (S (S i))))))))))))) + 1 >= 14) by lia.
   destruct H.
   lia.
Qed.

Lemma allprev_big_unfoldable :
   forall (i b : Z) (a : list Z),
   0 <= i ->
   0 <= b < 2^32-1 ->
   allprev_big (i + 1) b a =
   is_big i a b && allprev_big i b a.
Proof.
   intros.
   unfold allprev_big.
   replace (i + 1) with (Z.succ i) by easy.
   rewrite Z2Nat.inj_succ by apply H.
   assert (i = Z.of_nat (Z.to_nat i)) by
      ((rewrite Z2Nat.id; auto)).
   rewrite H1 at 2.
   induction (Z.to_nat i); auto.
Qed.
(* %%%%%%%%%%%%% General Lemmas %%%%%%%%%%%%% *)
Lemma L3 (z : Z) :
0 <= z < Int64.modulus -> Int64.unsigned (Int64.repr z) = z.
Proof.
   intros.
   rewrite Int64.unsigned_repr_eq.
   rewrite Z.mod_small; auto.
Qed.

Lemma  L4' (z : Z):
Int.eq (Int.repr z) Int.mone = false -> z mod Int.modulus ≠ Int.modulus - 1.
Proof.
   intros.
   apply int_eq_false_e in H.
   unfold "≠".
   intros.
   replace (Int.modulus - 1) with (Int.modulus - 1 mod Int.modulus) in H0.
   assert (Int.repr z = Int.repr (Int.modulus - 1)).
   apply modulo_samerepr.
   apply H0.
   replace (Int.repr (Int.modulus - 1)) with (Int.repr (- 1)) in H1.
   contradiction.
   rewrite modulo_samerepr with (y:= Int.modulus - 1); reflexivity.
   apply Zmod_small with (a := Int.modulus - 1) (n:= Int.modulus).
   easy.
Qed.

Lemma L4 (z : Z) :
Int.eq (Int.repr z) Int.mone = false -> z mod Int.modulus < Int.modulus - 1.
Proof.
   intros.
   apply int_eq_false_e in H.
   unfold Int.mone in H.
   apply Znot_ge_lt.
   unfold not.
   intros.
   assert (Int.modulus ≠ 0) by easy.
   apply Z.mod_bound_or with (a := z) in H1.
   destruct H1.
   destruct H1.
   assert (z mod Int.modulus <= Int.modulus - 1).
   apply Zlt_succ_le.
   replace (Z.succ (Int.modulus - 1)) with (Int.modulus) by easy.
   assumption.
   assert ( z mod Int.modulus = Int.modulus - 1).
   apply Z.ge_le in H0.
   apply Z.le_antisymm; assumption.
   replace (Int.modulus - 1) with (- 1 mod Int.modulus) in H4 by easy.
   apply modulo_samerepr in H4.
   contradiction.
   destruct H1.
   assert (Int.modulus < 0).
   apply Z.lt_le_trans with (m:= z mod Int.modulus); assumption.
   discriminate H3.
   Qed.

Lemma int64_shru_small (z : Z) : 0 <= z < two_p 32 ->
   Int64.shru (Int64.repr z) (Int64.repr 32) = Int64.zero.
Proof.
   intros.
   rewrite Int64.shru_div_two_p.
   assert (Int64.unsigned (Int64.repr z) / two_p (Int64.unsigned (Int64.repr 32)) = 0).
   rewrite Zdiv_small; try easy.
   split.
   destruct H.
   rewrite L3; try easy.
   split; try easy.
   assert ((two_p 32) < Int64.modulus) by easy.
   apply Z.lt_trans with (two_p 32); assumption.
   replace (Int64.unsigned (Int64.repr 32)) with 32 by easy.
   destruct H.
   rewrite L3; try easy.
   split; try easy.
   assert ((two_p 32) < Int64.modulus) by easy.
   apply Z.lt_trans with (two_p 32); assumption.
   rewrite H0. easy.
Qed.

Lemma div_eucl_by_hand: forall a b q r: Z,
0 < b ->
0 <= r < b ->
a = q * b + r ->
Z.div_eucl a b = (q, r).
Proof.
    intros.
    rewrite Zaux.Zdiv_eucl_unique.
    rewrite H1 at 1.
    rewrite Z.div_add_l; try lia.
    rewrite Z.div_small; try lia.
    rewrite H1.
    rewrite Z.add_mod; try lia.
    rewrite Z.mod_mul; try lia.
    (* assert ((0 + r mod b) mod b = r). *)
    replace (0 + r mod b) with (r mod b) by lia.
    rewrite Z.mod_mod; try lia.
    rewrite Z.mod_small; try lia.
    replace (q + 0) with (q) by lia.
    reflexivity.
Qed.

Lemma  div_bound_double: forall n z : Z,
0 < n ->
n <= z < 2 * n ->
z / n = 1.
Proof.
    intros.
    unfold "/".
    assert (Z.div_eucl z (n) = (1, z-n)).
    assert (z = n + (z - n)) by lia.
    rewrite div_eucl_by_hand with (q:= 1) (r:= z - n); try lia.
    reflexivity.
    rewrite H1.
    reflexivity.
Qed.

Lemma int64_shru_big (z : Z) : two_p 32 <= z < two_p 33 ->
   Int64.shru (Int64.repr z) (Int64.repr 32) = Int64.one.
Proof.
    intros.
    rewrite Int64.shru_div_two_p.
    replace (Int64.unsigned (Int64.repr 32)) with 32 by easy.
    rewrite L3.
    assert (z / two_p 32 = 1).
    apply div_bound_double; try easy.
    rewrite H0; easy.
    destruct H.
    split.
    assert (0 <= two_p 32) by easy.
    lia.
    assert (two_p 33 < Int64.modulus) by easy.
    lia.
Qed.

Lemma repr_eq_32_64: forall n:Z,
   Int.repr (Int64.unsigned (Int64.repr (n))) = Int.repr (Int.unsigned (Int.repr (n))).
Proof.
   intros.
   rewrite Int64.unsigned_repr_eq.
   rewrite Int.unsigned_repr_eq.
   rewrite modulo_samerepr with (y:= n mod Int.modulus); try easy.
   replace (Int64.modulus) with (Int.modulus * Int.modulus) by easy.
   rewrite Zaux.Zmod_mod_mult; try easy.
   symmetry; apply Zmod_mod.
Qed.

Lemma L6: forall x : Z,
0 <= x < Int.modulus -> Int64.unsigned (Int64.repr x) = Int.unsigned (Int.repr x).
Proof.
   intros.
   assert (x = Int.unsigned(Int.repr x)).
   rewrite Int.unsigned_repr_eq.
   rewrite Z.mod_small; try lia.
   rewrite H0.
   rewrite Int64.int_unsigned_repr.
   rewrite H0 at 1.
   easy.
Qed.

Lemma L7:
forall x y,
0 <= x < Int.modulus -> 0 < y <= 32 ->
(Z.land x (Z.ones y)) mod Int.modulus = Z.land x (Z.ones y).
Proof.
   intros.
   rewrite Z.mod_small; try easy.
   split.
   apply Z.land_nonneg.
   lia.
   rewrite Z.land_ones; try lia.
   replace (Int.modulus) with (2^32) by easy.
   assert (A1 : x mod 2 ^ y < 2^y).
   apply Z.mod_pos_bound; lia.
   assert (A2 : 2 ^ y <= 2 ^ 32).
   destruct H0.
   apply Z.pow_le_mono_r; try lia.
   apply Z.lt_le_trans with (m:= 2^y); try lia.
Qed.

Lemma lt_max_unsigned_iff_le_mod: forall x : Z,
x <= Int.max_unsigned <-> x < Int.modulus.
Proof.
   replace Int.max_unsigned with (2^32-1) by easy.
   replace Int.modulus with (2^32) by easy.
   lia.
Qed.

(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
Definition curve448AddInt_spec : ident * funspec :=
DECLARE _curve448AddInt
WITH    r : val,
        shr : share,
        a : val,
        contents_a : list Z,
        b : Z,
        gv : globals
PRE [ tptr tuint, tptr tuint, tuint]
    PROP   (writable_share shr;
            Zlength contents_a = 14;
            0 <= (list_to_int contents_a) < prime; 0 <= b < 2^32 - 1;
            forall x : Z, In x contents_a → 0 <= x < 2 ^ 32 /\ x mod Int.modulus < 2^32)
    PARAMS (r ; a ; Vint (Int.repr b)) GLOBALS (gv)
    SEP    (data_at_ shr (tarray tuint 14) r;
            data_at Tsh (tarray tuint 14) (map Vint (map Int.repr contents_a)) a)
POST [ tvoid ]
    PROP   ()
    RETURN ()
    SEP    (data_at shr (tarray tuint 14) (* r contains the representation of A + B mod p *)
   (*cont*)(map Vint (map Int.repr (int_to_list (((list_to_int contents_a) + (b)) mod prime)))) r ;
            data_at Tsh (tarray tuint 14) (map Vint (map Int.repr contents_a)) a ).

Definition curve448AddInt_INV  (a : val)  (contents_a : list Z)
                            (b : Z)
                            (r : val) (shr : share) (gv : globals) :=
    (EX i : Z,
    (PROP   (Zlength contents_a = 14)
    (* ;t = (Int64.repr b) \/ t = Int64.one \/ t = Int64.zero) *)
    LOCAL   (temp _a a; temp _r r;
            temp _temp (allprev_big_compute i b contents_a);
            gvars gv)
    SEP     (
            data_at Tsh (tarray tuint 14) (map Vint (map Int.repr contents_a)) a;
            data_at shr (tarray tuint 14)
            (
               (sublist.sublist 0 i (map Vint (map Int.repr (added_list contents_a b))))
               ++ (sublist.sublist i 14 undef14)
            )
            r)
    ))%assert.

Definition Gprog : funspecs := ltac:(with_library prog [ curve448AddInt_spec ])(*add red here*).

Lemma body_curve448AddInt : semax_body Vprog Gprog f_curve448AddInt curve448AddInt_spec.
Proof.
   start_function.
   forward.
   forward_for_simple_bound 14
   (curve448AddInt_INV a contents_a b r shr gv).
   entailer!.
   easy.
   repeat forward.
   entailer!.
   assert (a_i_bound : 0 <= Znth i contents_a < 2^32).
      apply H2; apply Znth_In; lia.
   unfold allprev_big_compute.
   rewrite allprev_big_unfoldable by lia.
   destruct (allprev_big i b contents_a) eqn : E_prev;
   destruct (i+1 =? 0) eqn : E_succ;
   destruct (i =? 0) eqn : E_i;
   simpl; try lia; try rewrite andb_true_r; try rewrite andb_false_r;
   try rewrite Z.eqb_eq in *; try rewrite Z.eqb_neq in *;
   try rewrite E_i in *.
   unfold is_big; simpl.

   unfold Int64.add.
   assert (b_bound : 0 <= b < Int.modulus);
   replace Int.modulus with (2^32) by easy; try lia.
   repeat rewrite L6; try easy; try apply Int.unsigned_range.
   repeat rewrite Int.unsigned_repr; try easy;
   try (replace Int.max_unsigned with (2^32-1) by easy); try lia.
   destruct (Znth 0 contents_a + b >=? 2^32) eqn : a_geq_b; simpl.
   rewrite Z.geb_le in a_geq_b.
   rewrite int64_shru_big; auto.
   split; rewrite two_p_equiv; try lia.
   rewrite int64_shru_small; auto.
   split; try rewrite two_p_equiv; try lia.

   unfold is_big.
   assert (i_not0: i=?0 = false) by lia; rewrite i_not0.
   unfold Int64.add.
   destruct (Int.eq (Int.repr (Znth i contents_a)) Int.mone) eqn: aimone.
   apply Int.same_if_eq in aimone.
   unfold Int.mone in aimone.
   rewrite aimone.
   replace (Int.unsigned (Int.repr (-1))) with (2^32 -1) by easy.
   repeat rewrite Int64.unsigned_repr; try easy.

   apply L4 in aimone.
   rewrite int64_shru_small; auto.
   split; try lia.
      apply Z.add_nonneg_nonneg;
      apply Int64.unsigned_range.
      rewrite two_p_equiv.
      unfold Int64.one.
      repeat rewrite Int64.unsigned_repr; try easy.
      rewrite Int.unsigned_repr_eq.
      replace (Int.modulus) with (2^32) in aimone at 2 by easy.
      lia.
      split; try apply Int.unsigned_range.
      rewrite Int.unsigned_repr_eq.
      assert (Int.modulus - 1 < Int64.max_unsigned) by easy;
      lia.

   discriminate E_prev.

   rewrite Int64.add_zero_l.
      rewrite int64_shru_small; auto.
      rewrite two_p_equiv.
      rewrite Int.unsigned_repr; auto.
      replace (Int.max_unsigned) with (2^32-1); try easy; try lia.

   (* Prove that if loop inv holds after i then it holds after doing the
      i+1 iteration. *)
   assert (a_i_bound : 0 <= Znth i contents_a < 2^32).
      apply H2; apply Znth_In; lia.
   assert (b_bound : 0 <= b < Int.modulus).
      replace Int.modulus with (2^32) by easy; try lia.
   assert (b_64bound : 0 <= b <= Int64.max_unsigned).
      split; try easy;
      assert (2^32-1 < Int64.max_unsigned) by easy; lia.
   assert (data_at_r : (upd_Znth i
   (sublist.sublist 0 i (map Vint (map Int.repr (added_list contents_a b))) ++
    sublist.sublist i 14 undef14)
   (force_val
      (sem_cast_l2i I32 Unsigned
         (force_val
            (sem_and tulong tuint
               (force_val
                  (both_long (λ n1 n2 : int64, Some (Vlong (Int64.add n1 n2)))
                     sem_cast_pointer (sem_cast_i2l Unsigned)
                     (allprev_big_compute i b contents_a)
                     (Vint (Int.repr (Znth i contents_a))))) (Vint (Int.repr (-1))))))))
   =
   (sublist.sublist 0 (i + 1) (map Vint (map Int.repr (added_list contents_a b))) ++
       sublist.sublist (i + 1) 14 undef14)).

   rewrite <- !(sublist_rejoin 0 i (i+1)); try easy.
   rewrite <- app_assoc.
   rewrite upd_list_app_upper.
   assert (len_sublist : Zlength (sublist.sublist 0 i (map Vint (map Int.repr (added_list contents_a b)))) = i).
   rewrite calc_Zlength_sublist with (len := 14); try easy; try lia.
   rewrite len_sublist; autorewrite with sublist.
   rewrite sublist_update_0th_gen; try easy; try lia.
   rewrite sublist_len_1.
   repeat f_equal.
   autorewrite with sublist.
   unfold allprev_big_compute.

   destruct (i=?0) eqn: i_0.
   rewrite Z.eqb_eq in i_0; rewrite i_0 in *.
   unfold added_list.
   unfold added_list_aux.
   autorewrite with sublist.
   simpl.
   f_equal.
   unfold Int64.and.
   replace (Int64.unsigned (Int64.repr (Int.unsigned (Int.repr (-1)))))
      with (Z.ones 32) by easy.
   rewrite Z.land_ones by easy.
   rewrite L6.
   rewrite Int.unsigned_repr.
   unfold Int64.add.
   rewrite Int64.int_unsigned_repr.
   rewrite Int.unsigned_repr.
   rewrite Int64.unsigned_repr.
   rewrite Int64.unsigned_repr.
   apply modulo_samerepr.
   replace (Z.of_nat 0) with 0 by easy.
   replace (2^32) with Int.modulus by easy.
   rewrite Z.mod_mod by easy.
   rewrite Z.add_comm; lia.
   lia.
   rewrite Int64.unsigned_repr by lia.
   split.
   apply Z.add_nonneg_nonneg; try easy.
   assert (Int.modulus + 2^32 < Int64.max_unsigned) by easy; lia.
   replace Int.max_unsigned with (2^32-1) by easy. lia.
   split.
   apply Z.mod_bound_pos; try easy.
   apply Int64.unsigned_range.
   apply lt_max_unsigned_iff_le_mod.
   apply Z.mod_bound_pos; try easy; try apply Int64.unsigned_range.
   split.
   apply Z.mod_bound_pos; try easy.
   apply Int64.unsigned_range.
   apply Z.mod_bound_pos; try easy; try apply Int64.unsigned_range.

   rewrite Z.eqb_neq in i_0.

   replace (i) with (Z.of_nat (Z.to_nat i)) at 3 by lia.
   rewrite znth_added_list.
   replace (Z.of_nat (Z.to_nat i)) with i by lia.
   destruct (allprev_big i b contents_a) eqn: E_prev; simpl.
   unfold Int64.and.
   replace (Int64.unsigned (Int64.repr (Int.unsigned (Int.repr (-1)))))
      with (Z.ones 32) by easy.
   rewrite Z.land_ones by easy.
   rewrite L6.
   rewrite Int.unsigned_repr_eq.
   unfold Int64.add.
   rewrite Int64.int_unsigned_repr.
   rewrite Int.unsigned_repr.
   rewrite Int64.unsigned_repr.
   unfold Int64.one.
   rewrite Int64.unsigned_repr by easy.
   f_equal.
   apply modulo_samerepr.
   rewrite Z.mod_mod by easy.
   replace (2^32) with (Int.modulus) by easy.
   rewrite Z.mod_mod by easy.
   rewrite Z.add_comm.
   easy.
      replace (Int64.unsigned Int64.one) with (1) by easy.
      replace (Int64.max_unsigned) with (2^64-1) by easy; lia.
      rewrite lt_max_unsigned_iff_le_mod. easy.
      apply Z.mod_bound_pos; try easy; try apply Int64.unsigned_range.

   unfold Int64.and.
   replace (Int64.unsigned (Int64.repr (Int.unsigned (Int.repr (-1)))))
      with (Z.ones 32) by easy.
   rewrite Z.land_ones by easy.
   rewrite L6.
   rewrite Int.unsigned_repr_eq.
   rewrite Int64.add_zero_l.
   rewrite Int64.int_unsigned_repr.
   rewrite Int.unsigned_repr.
   f_equal.
   autorewrite with norm.
   rewrite Z.mod_mod by easy.
   rewrite modulo_samerepr with (y:=Znth i contents_a); auto.
   rewrite Z.mod_mod by easy.
   lia.
      rewrite lt_max_unsigned_iff_le_mod; easy.
      apply Z.mod_bound_pos; try easy; try apply Int64.unsigned_range.
      replace (Z.of_nat (Z.to_nat i)) with i; try lia.
      rewrite zlength_added_list; lia.
      autorewrite with sublist.
      rewrite zlength_added_list; lia.
      rewrite Zlength_sublist; try lia.
      autorewrite with sublist.
      rewrite zlength_added_list; lia.
      autorewrite with sublist.
      rewrite zlength_added_list; lia.

   rewrite data_at_r.
   cancel.

(* After verifying curve448Red, add it to Gprog and then perform
   forward_call with it. *)

(* void curve448AddInt(uint32_t *r, const uint32_t *a, uint32_t b)
{
uint_t i;
uint64_t temp;

//Compute R = A + B
temp = b;
for(i = 0; i < 14; i++)
{
   temp += a[i];
   r[i] = temp & 0xFFFFFFFF;
   temp >>= 32;
}

//Perform modular reduction
curve448Red(r, r, (uint32_t) temp);
} *)

(* Loop Analysis {
temp starts being b. Then it will either be 1 or 0.
If temp = b and we are inside the loop then i = 0.
   temp = b -> i = 0.
If temp = 1 then
   - temp + a[i] >= 2^32
   which can only happen if:
   - b + a[0] >= 2^32
   - temp = 1 and a[i] = -1
}*)


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


From Undecidability Require Import TM.Util.Prelim TM.Util.Relations TM.Util.TM_facts.

(* * Tapes-Lift *)

(* Select the [m] elements of [V], of that their index is in [I] *)
Definition select (m n: nat) (X: Type) (I : Vector.t (Fin.t n) m) (V : Vector.t X n) : Vector.t X m :=
  Vector.map (Vector.nth V) I.

Corollary select_nth m n X (I : Vector.t (Fin.t n) m) (V : Vector.t X n) (k : Fin.t m) :
  (select I V) [@ k] = V [@ (I [@ k])].
Proof. now apply Vector.nth_map. Qed.

(* Relational tapes-lift *)
Section LiftTapes_Rel.

  Variable (sig : finType) (F : Type).
  Variable m n : nat.

  Variable I : Vector.t (Fin.t n) m.

  Definition not_index (i : Fin.t n) : Prop :=
    ~ Vector.In i I.

  Variable (R : pRel sig F m).

  Definition LiftTapes_select_Rel : pRel sig F n :=
    fun t '(y, t') => R (select I t) (y, select I t').

  Definition LiftTapes_eq_Rel : pRel sig F n :=
    ignoreParam (fun t t' => forall i : Fin.t n, not_index i -> t'[@i] = t[@i]).

  Definition LiftTapes_Rel := LiftTapes_select_Rel ∩ LiftTapes_eq_Rel.

  Variable T : tRel sig m.

  Definition LiftTapes_T : tRel sig n :=
    fun t k => T (select I t) k.

End LiftTapes_Rel.

Arguments not_index : simpl never.
Arguments LiftTapes_select_Rel {sig F m n} I R x y /.
Arguments LiftTapes_eq_Rel {sig F m n} I x y /.
Arguments LiftTapes_Rel {sig F m n } I R x y /.
Arguments LiftTapes_T {sig m n} I T x y /.

Lemma vector_hd_nth (X : Type) (n : nat) (xs : Vector.t X (S n)) : Vector.hd xs = xs[@Fin0].
Proof. now destruct_vector. Qed.

Lemma vector_tl_nth (X : Type) (n : nat) (i : Fin.t (S n)) (xs : Vector.t X (S (S n))) : (Vector.tl xs)[@i] = xs[@Fin.FS i].
Proof. now destruct_vector. Qed.

Section Fill.

  Fixpoint lookup_index_vector {m n : nat} (I : Vector.t (Fin.t n) m) : Fin.t n -> option (Fin.t m) :=
    match I with
    | Vector.nil _ => fun (i : Fin.t n) => None
    | Vector.cons _ i' m' I' =>
      fun (i : Fin.t n) =>
        if Fin.eqb i i' then Some Fin0
        else match lookup_index_vector I' i with
             | Some j => Some (Fin.FS j)
             | None => None
             end
    end.

  Lemma Some_inj (X : Type) (x y : X) :
    Some x = Some y -> x = y.
  Proof. congruence. Qed.

  Lemma lookup_index_vector_Some (m n : nat) (I : Vector.t (Fin.t n) m) (i : Fin.t n) (j : Fin.t m) :
    dupfree I ->
    I[@j] = i ->
    lookup_index_vector I i = Some j.
  Proof.
    induction 1 as [ | m i' I' H1 H2 IH]; intros Heq; cbn in *.
    - contradict (fin_destruct_O j).
    - destruct (Fin.eqb i i') eqn:Eqb; cbn in *.
      + f_equal. apply Fin.eqb_eq in Eqb as ->.
        pose proof (fin_destruct_S j) as [(j'&->) | ->]; cbn in *.
        * exfalso. contradict H1. eapply vect_nth_In; eauto.
        * reflexivity.
      + destruct (lookup_index_vector I' i) as [j' | ] eqn:El.
        * pose proof (fin_destruct_S j) as [(j''&->) | ->]; cbn in *.
          -- specialize IH with (1 := Heq). apply Some_inj in IH as ->. reflexivity.
          -- subst. enough (Fin.eqb i i = true) by congruence. now apply Fin.eqb_eq.
        * exfalso. pose proof (fin_destruct_S j) as [(j''&->) | ->]; cbn in *.
          -- specialize IH with (1 := Heq). congruence.
          -- subst. enough (Fin.eqb i i = true) by congruence. now apply Fin.eqb_eq.
  Qed.

  Lemma lookup_index_vector_Some' (m n : nat) (I : Vector.t (Fin.t n) m) (i : Fin.t n) (j : Fin.t m) :
    lookup_index_vector I i = Some j ->
    I[@j] = i.
  Proof.
    revert i j. induction I as [ | i' n' I' IH ]; intros i j Hj.
    - destruct_fin j.
    - pose proof (fin_destruct_S j) as [(j'&->) | ->]; cbn in *.
      + destruct (Fin.eqb i i'); inv Hj.
        destruct (lookup_index_vector I' i) as [ j'' | ] eqn:Ej''.
        * apply Some_inj in H0. apply Fin.FS_inj in H0 as ->. now apply IH.
        * congruence.
      + destruct (Fin.eqb i i') eqn:Ei'.
        * now apply Fin.eqb_eq in Ei'.
        * destruct (lookup_index_vector I' i) as [ j'' | ] eqn:Ej''.
          -- congruence.
          -- congruence.
  Qed.

  Lemma lookup_index_vector_None (m n : nat) (I : Vector.t (Fin.t n) m) (i : Fin.t n) :
    (~ Vector.In i I) ->
    lookup_index_vector I i = None.
  Proof.
    intros HNotIn.
    destruct (lookup_index_vector I i) eqn:E; auto.
    exfalso. apply lookup_index_vector_Some' in E.
    contradict HNotIn. eapply vect_nth_In; eauto.
  Qed.

  Variable X : Type.

  (* Replace the elements of [init] of which the index is in [I] with the element in [V] of that index. *)
  Definition fill {m n : nat} (I : Vector.t (Fin.t n) m) (init : Vector.t X n) (V : Vector.t X m) : Vector.t X n :=
    tabulate (fun i => match lookup_index_vector I i with
                    | Some j => V[@j]
                    | None => init[@i]
                    end).

  Section Test.
    Variable (a b x y z : X).

    (* The following goals should hold by computation *)
    Goal fill [|Fin0; Fin1|] [|x;y;z|] [|a;b|] = [|a;b;z|].
    Proof. cbn. reflexivity. Qed.

    Goal fill [|Fin2; Fin1|] [|x;y;z|] [|a;b|] = [|x;b;a|].
    Proof. cbn. reflexivity. Qed.

    Goal fill [|Fin1; Fin0|] [|x;y;z|] [|a;b|] = [|b;a;z|]. (* [a] and [b] are swapped, [z] is unchanged. *)
    Proof. cbn. reflexivity. Qed.

    (* This didn't hold (by computation) for the old version with replacement *)
    Goal forall (ss : Vector.t X 3), fill [|Fin0; Fin1|] ss [|a;b|] = [|a;b; ss[@Fin2]|].
    Proof. intros. cbn. reflexivity. Qed.

  End Test.

  Variable m n : nat.
  Implicit Types (i : Fin.t n) (j : Fin.t m).
  Implicit Types (I : Vector.t (Fin.t n) m) (init : Vector.t X n) (V : Vector.t X m).

  Lemma fill_correct_nth I init V i j :
    dupfree I ->
    I[@j] = i ->
    (fill I init V)[@i] = V[@j].
  Proof.
    intros HDup Heq.
    unfold fill. simpl_vector.
    erewrite lookup_index_vector_Some; eauto.
  Qed.

  Lemma fill_not_index I init V (i : Fin.t n) :
    not_index I i ->
    (fill I init V)[@i] = init[@i].
  Proof.
    intros HNotIn. unfold not_index in HNotIn.
    unfold fill. simpl_vector.
    erewrite lookup_index_vector_None; eauto.
  Qed.

  Definition fill_default I (def : X) V :=
    fill I (Vector.const def n) V.

  Corollary fill_default_not_index I V def i :
    not_index I i ->
    (fill_default I def V)[@i] = def.
  Proof. intros. unfold fill_default. rewrite fill_not_index; auto. apply Vector.const_nth. Qed.

End Fill.

Section loop_map.
  Variable A B : Type.
  Variable (f : A -> A) (h : A -> bool) (g : A -> B).
  Hypothesis step_map_comp : forall a, g (f a) = g a.

  Lemma loop_map k a1 a2 :
    loop f h a1 k = Some a2 ->
    g a2 = g a1.
  Proof.
    revert a1 a2. induction k as [ | k' IH]; intros; cbn in *.
    - destruct (h a1); now inv H.
    - destruct (h a1).
      + now inv H.
      + apply IH in H. now rewrite step_map_comp in H.
  Qed.

End loop_map.

Section LiftNM.

  Variable sig : finType.

  Variable m n : nat.

  Variable F : finType.

  Variable pM : pTM sig F m.

  Variable I : Vector.t ((Fin.t n)) m.
  Variable I_dupfree : dupfree I.

  Definition LiftTapes_trans :=
    fun '(q, sym ) =>
      let (q', act) := trans (m := projT1 pM) (q, select I sym) in
      (q', fill_default I (None, Nmove) act).

  Definition LiftTapes_TM : TM sig n :=
    {|
      trans := LiftTapes_trans;
      start := start (projT1 pM);
      halt := halt (m := projT1 pM);
    |}.

  Definition LiftTapes : pTM sig F n := (LiftTapes_TM; projT2 pM).

  Definition selectConf : mconfig sig (state LiftTapes_TM) n -> mconfig sig (state (projT1 pM)) m :=
    fun c => mk_mconfig (cstate c) (select I (ctapes c)).

  Lemma current_chars_select (t : tapes sig n) :
    current_chars (select I t) = select I (current_chars t).
  Proof. unfold current_chars, select. apply Vector.eq_nth_iff; intros i ? <-. now simpl_tape. Qed.

  Lemma doAct_select (t : tapes sig n) act :
    doAct_multi (select I t) act = select I (doAct_multi t (fill_default I (None, Nmove) act)).
  Proof.
    unfold doAct_multi, select. apply Vector.eq_nth_iff; intros i ? <-. simpl_tape.
    unfold fill_default. f_equal. symmetry. now apply fill_correct_nth.
  Qed.

  Lemma LiftTapes_comp_step (c1 : mconfig sig (state (projT1 pM)) n) :
    step (M := projT1 pM) (selectConf c1) = selectConf (step (M := LiftTapes_TM) c1).
  Proof.
    unfold selectConf. unfold step; cbn.
    destruct c1 as [q t] eqn:E1.
    unfold step in *. cbn -[current_chars doAct_multi] in *.
    rewrite current_chars_select.
    destruct (trans (q, select I (current_chars t))) as (q', act) eqn:E; cbn.
    f_equal. apply doAct_select.
  Qed.

  Lemma LiftTapes_lift (c1 c2 : mconfig sig (state LiftTapes_TM) n) (k : nat) :
    loopM (M := LiftTapes_TM) c1 k = Some c2 ->
    loopM (M := projT1 pM) (selectConf c1) k = Some (selectConf c2).
  Proof.
    intros HLoop.
    eapply loop_lift with (f := step (M := LiftTapes_TM)) (h := haltConf (M := LiftTapes_TM)).
    - cbn. auto.
    - intros ? _. now apply LiftTapes_comp_step.
    - apply HLoop.
  Qed.

  Lemma LiftTapes_comp_eq (c1 c2 : mconfig sig (state LiftTapes_TM) n) (i : Fin.t n) :
    not_index I i ->
    step (M := LiftTapes_TM) c1 = c2 ->
    (ctapes c2)[@i] = (ctapes c1)[@i].
  Proof.
    intros HI H. unfold LiftTapes_TM in *.
    destruct c1 as [state1 tapes1] eqn:E1, c2 as [state2 tapes2] eqn:E2.
    unfold step, select in *. cbn in *.
    destruct (trans (state1, select I (current_chars tapes1))) as (q, act) eqn:E3.
    inv H. erewrite Vector.nth_map2; eauto. now rewrite fill_default_not_index.
  Qed.

  Lemma LiftTapes_eq (c1 c2 : mconfig sig (state LiftTapes_TM) n) (k : nat) (i : Fin.t n) :
    not_index I i ->
    loopM (M := LiftTapes_TM) c1 k = Some c2 ->
    (ctapes c2)[@i] = (ctapes c1)[@i].
  Proof.
    intros Hi HLoop. unfold loopM in HLoop.
    eapply loop_map with (g := fun c => (ctapes c)[@i]); eauto.
    intros. now apply LiftTapes_comp_eq.
  Qed.

  Lemma LiftTapes_Realise (R : Rel (tapes sig m) (F * tapes sig m)) :
    pM ⊨ R ->
    LiftTapes ⊨ LiftTapes_Rel I R.
  Proof.
    intros H. split.
    - apply (H (select I t) k (selectConf outc)).
      now apply (@LiftTapes_lift (initc LiftTapes_TM t) outc k).
    - hnf. intros i HI. now apply (@LiftTapes_eq (initc LiftTapes_TM t) outc k i HI).
  Qed.

  Lemma LiftTapes_unlift (k : nat)
        (c1 : mconfig sig (state (LiftTapes_TM)) n)
        (c2 : mconfig sig (state (LiftTapes_TM)) m) :
    loopM (M := projT1 pM) (selectConf c1) k = Some c2 ->
    exists c2' : mconfig sig (state (LiftTapes_TM)) n,
      loopM (M := LiftTapes_TM) c1 k = Some c2' /\
      c2 = selectConf c2'.
  Proof.
    intros HLoop. unfold loopM in *. cbn in *.
    apply loop_unlift with (lift:=selectConf) (f:=step (M:=LiftTapes_TM)) (h:=haltConf (M:=LiftTapes_TM)) in HLoop as (c'&HLoop&->).
    - exists c'. split; auto.
    - auto.
    - intros ? _. apply LiftTapes_comp_step.
  Qed.

  Lemma LiftTapes_Terminates T :
    projT1 pM ↓ T ->
    projT1 LiftTapes ↓ LiftTapes_T I T.
  Proof.
    intros H initTapes k Term. hnf in *.
    specialize (H (select I initTapes) k Term) as (outc&H).
    pose proof (@LiftTapes_unlift k (initc LiftTapes_TM initTapes) outc H) as (X&X'&->). eauto.
  Qed.

  Lemma LiftTapes_RealiseIn R k :
    pM ⊨c(k) R ->
    LiftTapes ⊨c(k) LiftTapes_Rel I R.
  Proof.
    intros (H1&H2) % Realise_total. apply Realise_total. split.
    - now apply LiftTapes_Realise.
    - eapply TerminatesIn_monotone.
      + apply LiftTapes_Terminates; eauto.
      + firstorder.
  Qed.

End LiftNM.

Arguments LiftTapes : simpl never.
Notation "pM @ ts" := (LiftTapes pM ts) (at level 41, only parsing).

(* * Tactic Support *)

(* TODO: Some of this is probably deprecated, e.g. the [app_tapes] stuff *)

Lemma smpl_dupfree_helper1 (n : nat) :
  dupfree [|Fin.F1 (n := n)|].
Proof. vector_dupfree. Qed.

Lemma smpl_dupfree_helper2 (n : nat) :
  dupfree [|Fin.FS (Fin.F1 (n := n))|].
Proof. vector_dupfree. Qed.

Ltac smpl_dupfree :=
  once lazymatch goal with
  | [ |- dupfree [|Fin.F1 |] ] => apply smpl_dupfree_helper1
  | [ |- dupfree [|Fin.FS |] ] => apply smpl_dupfree_helper2
  | [ |- dupfree _ ] => now vector_dupfree (* fallback tactic *)
  end.

Ltac smpl_TM_LiftN :=
  once lazymatch goal with
  | [ |- LiftTapes _ _ ⊨ _] =>
    apply LiftTapes_Realise; [ smpl_dupfree | ]
  | [ |- LiftTapes _ _ ⊨c(_) _] => apply LiftTapes_RealiseIn; [ smpl_dupfree | ]
  | [ |- projT1 (LiftTapes _ _) ↓ _] => apply LiftTapes_Terminates; [ smpl_dupfree | ]
  end.
Smpl Add smpl_TM_LiftN : TM_Correct.

Ltac is_num_const n :=
  once lazymatch n with
  | O => idtac
  | S ?n => is_num_const n
  | _ => fail "Not a number"
  end.

(*
Section Test_Is_Num_Const.
  Variable n : nat.
  Eval cbn in ltac:(is_num_const 42).
  Fail Eval cbn in ltac:(is_num_const n).
  Fail Eval cbn in ltac:(is_num_const (S n)).
End Test_Is_Num_Const.
*)

(* This tactical executes [t 0], ..., [t (n-1)]. *)
Ltac do_n_times n t :=
  match n with
  | O => idtac
  | (S ?n') =>
    t 0;
    do_n_times n' ltac:(fun i => let next := constr:(S i) in t next)
  end.
(*
Eval cbn in ltac:(do_n_times 42 ltac:(fun a => idtac a)).
*)

(* This similiar tactical executes [t Fin0], ..., [t Fin_(n-1)]. *)
Ltac do_n_times_fin_rect n m t :=
  once lazymatch n with
  | O => idtac
  | S ?n' =>
    let m' := eval hnf in (pred m) in
    let one := eval cbv in (@Fin.F1 _ : Fin.t m) in
    t one;
    do_n_times_fin_rect n' m' ltac:(fun i => let next := eval hnf in (Fin.FS i) in t next)
  end.

Ltac do_n_times_fin n t := do_n_times_fin_rect n n t.

(*
Eval cbn in ltac:(do_n_times_fin 3 ltac:(fun a => idtac a)).
Eval cbn in ltac:(do_n_times_fin 3 ltac:(fun a => let x := eval simpl in (a : Fin.t 3) in idtac x)).
*)

(* Check whether a vector (syntactically) contains an element *)
Ltac vector_contains a vect :=
  once lazymatch vect with
  | @Vector.nil ?A => fail "Vector doesn't contain" a
  | @Vector.cons ?A a ?n ?vect' => idtac
  | @Vector.cons ?A ?b ?n ?vect' => vector_contains a vect'
  | _ => fail "No vector" vect
  end.

(* Fail Check ltac:(vector_contains 42 (@Vector.nil nat); idtac "yes!"). *)
(* Check ltac:(vector_contains 42 [|4;8;15;16;23;42|]; idtac "yes!"). *)

(*
 * The tactic [simpl_not_in_vector] tries to specialise hypothesises of the form
 * [H : forall i : Fin.t n, not_index [F1; ...; Fk] i -> _]
 * with [i := Fin0], ..., [i := Fin(n-1)] to new assumptions [H_0].
 *)

Lemma splitAllFin k' n (P : Fin.t (k'+n) -> Prop):
  (forall i, P i) -> (forall (i : Fin.t k'), P (Fin.L n i)) /\ (forall (i : Fin.t n), P (Fin.R k' i)).
Proof.
  easy.
Qed.

Fixpoint not_indexb {n} (v : list (Fin.t n)) (i : Fin.t n) {struct v}: bool :=
match v with
  []%list => true
| (i'::v)%list => if Fin.eqb i' i then false else not_indexb v i
end.

Require Import Equations.Prop.DepElim.
Lemma not_index_reflect n m (v : Vector.t _ m) (i : Fin.t n):
  not_index v i <-> not_indexb (Vector.to_list v) i = true.
Proof.
  unfold Vector.to_list. depind v;cbn. easy.
  specialize (Fin.eqb_eq _ h i) as H'.
  destruct Fin.eqb. { destruct H' as [->]. 2:easy. split. 2:easy. destruct 1. constructor. }
  rewrite <- IHv. cbv;intuition. apply H1. now constructor. apply H1.
  inversion H2;subst. now specialize (H0 eq_refl). apply Eqdep_dec.inj_pair2_eq_dec in H6;subst. easy.
  decide equality.
Qed.

Arguments not_indexb : simpl nomatch.

Lemma not_index_reflect_helper n m (v : Vector.t _ m) (P : Fin.t n -> Prop):
(forall i : Fin.t n, not_index v i  -> P i)
-> (forall i : Fin.t n, if not_indexb (Vector.to_list v) i then P i else True).
Proof.
  intros H i. specialize (H i). setoid_rewrite not_index_reflect in H. destruct not_indexb;now eauto.
Qed.

Lemma not_index_reflect_helper2 n' (l : list _) (P : Fin.t n' -> Prop):
(forall i : Fin.t n', if not_indexb l i then P i else True)
-> (forall i : Fin.t n', not_index (Vector.of_list l) i  -> P i).
Proof.
  intros H i. specialize (H i). setoid_rewrite not_index_reflect.
  rewrite VectorSpec.to_list_of_list_opp. destruct not_indexb;now eauto.
Qed.

Local Definition _Flag_DisableWarning := Lock unit.

Local Definition _flag_DisableWarning : _Flag_DisableWarning := tt.

Ltac simpl_not_in_vector_one :=
  let moveCnstLeft :=
    let rec loop k n :=
      lazymatch n with
        S ?n => loop uconstr:(S k) n
      | _ => uconstr:(k + n)
      end
    in loop 0
    in
  once lazymatch goal with
  | [ H : forall i : Fin.t ?n, not_index ?vect i -> _ |- _ ] =>
    specialize (not_index_reflect_helper H);clear H;intros H;
    let n' := moveCnstLeft n in
    change n with n' in H at 1;
    let tmp := fresh "tmp" in
    apply splitAllFin in H as [tmp H];
    cbn [not_indexb Vector.to_list Fin.R Vector.caseS Fin.eqb Vector.nth] in H;
    let helper i :=
      let H' := fresh H "_0" in
      assert (H':= tmp i);
      cbn in H';
      once lazymatch type of H' with
        | if (if Nat.eqb ?k ?k then false else true) then _ else True =>
        fail 1000 "arguments for not_indexb should have been set to [simpl nomatch]";clear H'
        | if not_indexb (?i::_)%list ?i then _ else True => clear H'
        | ?i = ?j => idtac
        | True => clear H'
        | ?G => idtac "simpl_not_in_vector_one is not intended for this kind of non-ground tape index" G
      end
    in
    once lazymatch type of tmp with
      forall i : Fin.t ?n, _ =>
        do_n_times_fin n helper;clear tmp
    end;
    match type of H with
    | forall i : Fin.t 0, _ => clear H
    | forall u, if _ then _ else _ =>
          specialize (not_index_reflect_helper2 H);clear H;intros H;cbn [Vector.of_list] in H
    | forall i : Fin.t _, _[@ _] = _[@ _] => idtac
    | ?t => match goal with
            | H : _Flag_DisableWarning |- _ => idtac
            | |- _ =>  idtac "unexpected case in simpl_not_in_vector_one" t
            end
    end
  end.

Ltac simpl_not_in_vector := repeat simpl_not_in_vector_one.

(* (* Test *) *)
(* Goal True. *)
(*   assert (forall i : Fin.t 10, not_index [|Fin8; Fin1; Fin2; Fin3|] i -> i = i) as HInj by firstorder. *)
(*   simpl_not_in_vector_one. *)
(*   Fail Check HInj. *)
(*   Show Proof. *)
(*   Check (HInj_0 : Fin0 = Fin0). *)
(*   Check (HInj_1 : Fin4 = Fin4). *)
(*   Check (HInj_2 : Fin5 = Fin5). *)
(*   Check (HInj_3 : Fin6 = Fin6). *)
(*   Check (HInj_4 : Fin7 = Fin7). *)
(*   Check (HInj_5 : Fin9 = Fin9). *)
(* Abort. *)

Ltac simpl_not_in := repeat simpl_not_in_vector.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool eqtype ssrnat.

Lemma test (x : bool) : True.
have H1 x := x.
have (x) := x => H2.
have H3 T (x : T) := x.
have ? : bool := H1 _ x.
have ? : bool := H2 _ x.
have ? : bool := H3 _ x.
have ? (z : bool) : forall y : bool, z = z := fun y => refl_equal _.
have ? w : w = w := @refl_equal nat w.
have ? y : true by [].
have ? (z : bool) : z = z.
  exact: (@refl_equal _ z).
have ? (z w : bool) : z = z by exact: (@refl_equal _ z).
have H w (a := 3) (_ := 4) : w && true = w.
  by rewrite andbT.
exact I.
Qed.

Lemma test1 : True.
suff (x : bool): x = x /\ True.
  by move/(_ true); case=> _.
split; first by exact: (@refl_equal _ x).
suff H y : y && true = y /\ True.
  by case: (H true).
suff H1 /= : true && true /\ True.
  by rewrite andbT; split; [exact: (@refl_equal _ y) | exact: I].
match goal with |- is_true true /\ True => idtac end.
by split.
Qed.

Lemma foo n : n >= 0.
have f i (j := i + n) : j < n.
  match goal with j := i + n |- _ => idtac end.
Undo 2.
suff f i (j := i + n) : j < n.
  done.
match goal with j := i + n |- _ => idtac end.
Undo 3.
done.
Qed.


From stdpp Require Import BVbase tactics.
From stdpp Require Import options.

Local Set Universe Polymorphism.
Local Set Polymorphic Inductive Cumulativity.

(** Without this flag, Coq minimizes some universes to [Set] when they
    should not be, e.g. in [texist_exist].
    See the [texist_exist_universes] test. *)
Local Unset Universe Minimization ToSet.

(** Telescopes *)
Inductive tele : Type :=
  | TeleO : tele
  | TeleS {X} (binder : X → tele) : tele.

Global Arguments TeleS {_} _.

(** The telescope version of Coq's function type *)
Fixpoint tele_fun (TT : tele) (T : Type) : Type :=
  match TT with
  | TeleO => T
  | TeleS b => ∀ x, tele_fun (b x) T
  end.

Notation "TT -t> A" :=
  (tele_fun TT A) (at level 99, A at level 200, right associativity).

(** An eliminator for elements of [tele_fun].
    We use a [fix] because, for some reason, that makes stuff print nicer
    in the proofs in iris:bi/lib/telescopes.v *)
Definition tele_fold {X Y} {TT : tele} (step : ∀ {A : Type}, (A → Y) → Y) (base : X → Y)
  : (TT -t> X) → Y :=
  (fix rec {TT} : (TT -t> X) → Y :=
     match TT as TT return (TT -t> X) → Y with
     | TeleO => λ x : X, base x
     | TeleS b => λ f, step (λ x, rec (f x))
     end) TT.
Global Arguments tele_fold {_ _ !_} _ _ _ /.

(** A duplication of the type [sigT] to avoid any connection to other universes
 *)
Record tele_arg_cons {X : Type} (f : X → Type) : Type := TeleArgCons
  { tele_arg_head : X;
    tele_arg_tail : f tele_arg_head }.
Global Arguments TeleArgCons {_ _} _ _.

(** A sigma-like type for an "element" of a telescope, i.e. the data it
  takes to get a [T] from a [TT -t> T]. *)
Fixpoint tele_arg@{u} (t : tele@{u}) : Type@{u} :=
  match t with
  | TeleO => unit
  | TeleS f => tele_arg_cons (λ x, tele_arg (f x))
  end.
Global Arguments tele_arg _ : simpl never.

(* Coq has no idea that [unit] and [tele_arg_cons] have anything to do with
   telescopes. This only becomes a problem when concrete telescope arguments
   (of concrete telescopes) need to be typechecked. To work around this, we
   annotate the notations below with extra information to guide unification.
 *)

(* The cast in the notation below is necessary to make Coq understand that
   [TargO] can be unified with [tele_arg TeleO]. *)
Notation TargO := (tt : tele_arg TeleO) (only parsing).
(* The casts and annotations are necessary for Coq to typecheck nested [TargS]
   as well as the final [TargO] in a chain of [TargS]. *)
Notation TargS a b :=
  ((@TeleArgCons _ (λ x, tele_arg (_ x)) a b) : (tele_arg (TeleS _))) (only parsing).
Coercion tele_arg : tele >-> Sortclass.

Lemma tele_arg_ind (P : ∀ TT, tele_arg TT → Prop) :
  P TeleO TargO →
  (∀ T (b : T → tele) x xs, P (b x) xs → P (TeleS b) (TargS x xs)) →
  ∀ TT (xs : tele_arg TT), P TT xs.
Proof.
  intros H0 HS TT. induction TT as [|T b IH]; simpl.
  - by intros [].
  - intros [x xs]. by apply HS.
Qed.

Fixpoint tele_app {TT : tele} {U} : (TT -t> U) -> TT → U :=
  match TT as TT return (TT -t> U) -> TT → U with
  | TeleO => λ F _, F
  | TeleS r => λ (F : TeleS r -t> U) '(TeleArgCons x b),
      tele_app (F x) b
  end.
(* The bidirectionality hint [&] simplifies defining tele_app-based notation
such as the atomic updates and atomic triples in Iris. *)
Global Arguments tele_app {!_ _} & _ !_ /.

(* This is a local coercion because otherwise, the "λ.." notation stops working. *)
Local Coercion tele_app : tele_fun >-> Funclass.

(** Inversion lemma for [tele_arg] *)
Lemma tele_arg_inv {TT : tele} (a : tele_arg TT) :
  match TT as TT return tele_arg TT → Prop with
  | TeleO => λ a, a = TargO
  | TeleS f => λ a, ∃ x a', a = TargS x a'
  end a.
Proof. destruct TT; destruct a; eauto. Qed.
Lemma tele_arg_O_inv (a : TeleO) : a = TargO.
Proof. exact (tele_arg_inv a). Qed.
Lemma tele_arg_S_inv {X} {f : X → tele} (a : TeleS f) :
  ∃ x a', a = TargS x a'.
Proof. exact (tele_arg_inv a). Qed.

(** Map below a tele_fun *)
Fixpoint tele_map {T U} {TT : tele} : (T → U) → (TT -t> T) → TT -t> U :=
  match TT as TT return (T → U) → (TT -t> T) → TT -t> U with
  | TeleO => λ F : T → U, F
  | @TeleS X b => λ (F : T → U) (f : TeleS b -t> T) (x : X),
                  tele_map F (f x)
  end.
Global Arguments tele_map {_ _ !_} _ _ /.

Lemma tele_map_app {T U} {TT : tele} (F : T → U) (t : TT -t> T) (x : TT) :
  (tele_map F t) x = F (t x).
Proof.
  induction TT as [|X f IH]; simpl in *.
  - rewrite (tele_arg_O_inv x). done.
  - destruct (tele_arg_S_inv x) as [x' [a' ->]]. simpl.
    rewrite <-IH. done.
Qed.

Global Instance tele_fmap {TT : tele} : FMap (tele_fun TT) := λ T U, tele_map.

Lemma tele_fmap_app {T U} {TT : tele} (F : T → U) (t : TT -t> T) (x : TT) :
  (F <$> t) x = F (t x).
Proof. apply tele_map_app. Qed.

(** Operate below [tele_fun]s with argument telescope [TT]. *)
Fixpoint tele_bind {U} {TT : tele} : (TT → U) → TT -t> U :=
  match TT as TT return (TT → U) → TT -t> U with
  | TeleO => λ F, F tt
  | @TeleS X b => λ (F : TeleS b → U) (x : X), (* b x -t> U *)
      tele_bind (λ a, F (TargS x a))
  end.
Global Arguments tele_bind {_ !_} _ /.

(* Show that tele_app ∘ tele_bind is the identity. *)
Lemma tele_app_bind {U} {TT : tele} (f : TT → U) x :
  (tele_bind f) x = f x.
Proof.
  induction TT as [|X b IH]; simpl in *.
  - rewrite (tele_arg_O_inv x). done.
  - destruct (tele_arg_S_inv x) as [x' [a' ->]]. simpl.
    rewrite IH. done.
Qed.

(** We can define the identity function and composition of the [-t>] function
space. *)
Definition tele_fun_id {TT : tele} : TT -t> TT := tele_bind id.

Lemma tele_fun_id_eq {TT : tele} (x : TT) :
  tele_fun_id x = x.
Proof. unfold tele_fun_id. rewrite tele_app_bind. done. Qed.

Definition tele_fun_compose {TT1 TT2 TT3 : tele} :
  (TT2 -t> TT3) → (TT1 -t> TT2) → (TT1 -t> TT3) :=
  λ t1 t2, tele_bind (compose (tele_app t1) (tele_app t2)).

Lemma tele_fun_compose_eq {TT1 TT2 TT3 : tele} (f : TT2 -t> TT3) (g : TT1 -t> TT2) x :
  tele_fun_compose f g $ x = (f ∘ g) x.
Proof. unfold tele_fun_compose. rewrite tele_app_bind. done. Qed.

(** Notation *)
Notation "'[tele' x .. z ]" :=
  (TeleS (fun x => .. (TeleS (fun z => TeleO)) ..))
  (x binder, z binder, format "[tele  '[hv' x  ..  z ']' ]").
Notation "'[tele' ]" := (TeleO)
  (format "[tele ]").

Notation "'[tele_arg' x ; .. ; z ]" :=
  (TargS x ( .. (TargS z TargO) ..))
  (format "[tele_arg  '[hv' x ;  .. ;  z ']' ]").
Notation "'[tele_arg' ]" := (TargO)
  (format "[tele_arg ]").

(** Notation-compatible telescope mapping *)
(* This adds (tele_app ∘ tele_bind), which is an identity function, around every
   binder so that, after simplifying, this matches the way we typically write
   notations involving telescopes. *)
Notation "'λ..' x .. y , e" :=
  (tele_app (tele_bind (λ x, .. (tele_app (tele_bind (λ y, e))) .. )))
  (at level 200, x binder, y binder, right associativity,
   format "'[  ' 'λ..'  x  ..  y ']' ,  e") : stdpp_scope.

(** Telescopic quantifiers *)
Definition tforall {TT : tele} (Ψ : TT → Prop) : Prop :=
  tele_fold (λ (T : Type) (b : T → Prop), ∀ x : T, b x) (λ x, x) (tele_bind Ψ).
Global Arguments tforall {!_} _ /.
Definition texist {TT : tele} (Ψ : TT → Prop) : Prop :=
  tele_fold ex (λ x, x) (tele_bind Ψ).
Global Arguments texist {!_} _ /.

Notation "'∀..' x .. y , P" := (tforall (λ x, .. (tforall (λ y, P)) .. ))
  (at level 200, x binder, y binder, right associativity,
  format "∀..  x  ..  y ,  P") : stdpp_scope.
Notation "'∃..' x .. y , P" := (texist (λ x, .. (texist (λ y, P)) .. ))
  (at level 200, x binder, y binder, right associativity,
  format "∃..  x  ..  y ,  P") : stdpp_scope.

Lemma tforall_forall {TT : tele} (Ψ : TT → Prop) :
  tforall Ψ ↔ (∀ x, Ψ x).
Proof.
  symmetry. unfold tforall. induction TT as [|X ft IH].
  - simpl. split.
    + done.
    + intros ? p. rewrite (tele_arg_O_inv p). done.
  - simpl. split; intros Hx a.
    + rewrite <-IH. done.
    + destruct (tele_arg_S_inv a) as [x [pf ->]].
      revert pf. setoid_rewrite IH. done.
Qed.

Lemma texist_exist {TT : tele} (Ψ : TT → Prop) :
  texist Ψ ↔ ex Ψ.
Proof.
  symmetry. induction TT as [|X ft IH].
  - simpl. split.
    + intros [p Hp]. rewrite (tele_arg_O_inv p) in Hp. done.
    + intros. by exists TargO.
  - simpl. split; intros [p Hp]; revert Hp.
    + destruct (tele_arg_S_inv p) as [x [pf ->]]. intros ?.
      exists x. rewrite <-(IH x (λ a, Ψ (TargS x a))). eauto.
    + rewrite <-(IH p (λ a, Ψ (TargS p a))).
      intros [??]. eauto.
Qed.

(* Teach typeclass resolution how to make progress on these binders *)
Typeclasses Opaque tforall texist.
Global Hint Extern 1 (tforall _) =>
  progress cbn [tforall tele_fold tele_bind tele_app] : typeclass_instances.
Global Hint Extern 1 (texist _) =>
  progress cbn [texist tele_fold tele_bind tele_app] : typeclass_instances.


Require Import
        CertifiedExtraction.Core
        CertifiedExtraction.PropertiesOfTelescopes.

Fixpoint NoDuplicates_helper {A} var (vars: list A) :=
  match vars with
  | nil => True
  | cons var' vars => var <> var' /\ NoDuplicates_helper var vars
  end.

Fixpoint NoDuplicates {A} (vars: list A) :=
  match vars with
  | nil => True
  | cons var vars => NoDuplicates_helper var vars /\ NoDuplicates vars
  end.

Fixpoint PreconditionSet_helper {av} (tenv: Telescope av) (ext: StringMap.t (Value av)) (vars: list string) :=
  match vars with
  | nil => True
  | cons var vars => (not (StringMap.In var ext)) /\ NotInTelescope var tenv /\ PreconditionSet_helper tenv ext vars
  end.

Definition PreconditionSet {av} (tenv: Telescope av) (ext: StringMap.t (Value av)) (vars: list string) :=
  NoDuplicates vars /\ PreconditionSet_helper tenv ext vars.

Notation "[[[ x ; .. ; y ]]]" := (cons x .. (cons y nil) ..).

Ltac destruct_ands H :=
  match type of H with
  | _ /\ _ => let h1 := fresh in
            let h2 := fresh in
            destruct H as (h1 & h2);
              destruct_ands h1;
              destruct_ands h2
  | True => clear H
  | _ => idtac
  end.

Ltac _PreconditionSet_t_in H :=
  cbv beta iota zeta delta [PreconditionSet PreconditionSet_helper NoDuplicates NoDuplicates_helper] in H;
  destruct_ands H.

Ltac _PreconditionSet_t :=
  cbv beta iota zeta delta [PreconditionSet PreconditionSet_helper NoDuplicates NoDuplicates_helper];
  repeat match goal with
         | |- _ /\ _ => split
         end.

Ltac PreconditionSet_t :=
     repeat
     match goal with
     | [ H: PreconditionSet _ _ _ |- _ ] => _PreconditionSet_t_in H
     | [ H: PreconditionSet_helper _ _ _ |- _ ] => _PreconditionSet_t_in H
     | [ H: NoDuplicates _ |- _ ] => _PreconditionSet_t_in H
     | [ H: NoDuplicates_helper _ _ |- _ ] => _PreconditionSet_t_in H
     | [  |- PreconditionSet _ _ _ ] => _PreconditionSet_t
     | [  |- PreconditionSet_helper _ _ _ ] => _PreconditionSet_t
     | [  |- NoDuplicates _ ] => _PreconditionSet_t
     | [  |- NoDuplicates_helper _ _ ] => _PreconditionSet_t
     end.


(** Direct definition of zero objects *)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.opp_precat.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.terminal.

Section def_zero.

  Variable C : category.

  Definition isZero (b : C) : UU :=
    (∏ a : C, iscontr (b --> a)) × (∏ a : C, iscontr (a --> b)).

  Lemma isaprop_isZero (b : C) : isaprop (isZero b).
  Proof.
    apply isapropdirprod.
    - apply impred. intros t. apply isapropiscontr.
    - apply impred. intros t. apply isapropiscontr.
  Qed.

  Definition Zero : UU := total2 (λ a, isZero a).

  Definition ZeroObject (Z : Zero) : C := pr1 Z.
  Coercion ZeroObject : Zero >-> ob.

  Definition make_Zero (b : C) (H : isZero b) : Zero.
  Proof.
    exists b; exact H.
  Defined.

  Definition make_isZero (b : C) (H : ∏ (a : C), iscontr (b --> a))
             (H' : ∏ (a : C), iscontr (a --> b)) : isZero b.
  Proof.
    unfold isZero.  exact ((H,,H')).
  Defined.

  Definition ZeroArrowFrom (Z : Zero) (b : C) : Z --> b := pr1 (pr1 (pr2 Z) b).

  Definition ZeroArrowTo (Z : Zero) (b : C) : b --> Z := pr1 (pr2 (pr2 Z) b).

  Lemma ArrowsToZero (Z : Zero) (b : C) (f g : b --> Z) : f = g.
  Proof.
    apply proofirrelevancecontr.
    apply (pr2 (pr2 Z) _).
  Qed.

  Lemma ArrowsFromZero (Z : Zero) (b : C) (f g : Z --> b) : f = g.
  Proof.
    apply proofirrelevancecontr.
    apply (pr1 (pr2 Z) _).
  Qed.

  (** For any pair of objects, there exists a unique arrow which factors
    through the zero object *)
  Definition ZeroArrow (Z : Zero) (a b : C) : C⟦a, b⟧ := (ZeroArrowTo Z a) · (ZeroArrowFrom Z b).

  Lemma ZeroArrowEq (Z : Zero) (a b : C) (f1 : C⟦a, Z⟧) (g1 : C⟦Z, b⟧) :
    f1 · g1 = ZeroArrow Z a b.
  Proof.
    rewrite (ArrowsToZero Z a f1 (ZeroArrowTo Z a)).
    rewrite (ArrowsFromZero Z b g1 (ZeroArrowFrom Z b)).
    apply idpath.
  Qed.

  Lemma ZeroArrow_comp_left (Z : Zero) (a b c : C) (f : C⟦b, c⟧) :
    ZeroArrow Z a b · f = ZeroArrow Z a c.
  Proof.
    unfold ZeroArrow at 1. rewrite <- assoc.
    apply ZeroArrowEq.
  Qed.

  Lemma ZeroArrow_comp_right (Z : Zero) (a b c : C) (f : C⟦a, b⟧) :
    f · ZeroArrow Z b c = ZeroArrow Z a c.
  Proof.
    unfold ZeroArrow at 1. rewrite assoc.
    apply ZeroArrowEq.
  Qed.

  Lemma ZeroEndo_is_identity (Z : Zero) (f : Z --> Z) : identity Z = f.
  Proof.
    apply ArrowsToZero.
  Qed.

  Lemma isziso_from_Zero_to_Zero (Z Z' : Zero) :
    is_z_isomorphism (ZeroArrowTo Z Z').
  Proof.
    exists (ZeroArrowTo Z' Z).
    split; apply pathsinv0; apply ZeroEndo_is_identity.
  Qed.

  Definition z_iso_Zeros (Z Z' : Zero) : z_iso Z Z' :=
    tpair _ (ZeroArrowTo Z' Z) (isziso_from_Zero_to_Zero Z' Z).

  Lemma ZerosArrowEq (Z Z' : Zero) (a b : C) : ZeroArrow Z a b = ZeroArrow Z' a b.
  Proof.
    set (i := z_iso_Zeros Z Z').
    unfold ZeroArrow.
    assert (e : ZeroArrowTo Z a · identity _ = ZeroArrowTo Z a) by apply id_right.
    rewrite <- e. clear e.
    rewrite <- (z_iso_inv_after_z_iso i). rewrite assoc.
    assert (e1 : ZeroArrowTo Z a · i = ZeroArrowTo Z' a) by apply ArrowsToZero.
    rewrite e1. clear e1.
    assert (e2 : inv_from_z_iso i · ZeroArrowFrom Z b = ZeroArrowFrom Z' b)
      by apply ArrowsFromZero.
    rewrite <- assoc. rewrite e2. clear e2.
    apply idpath.
  Qed.

  Definition hasZero := ishinh Zero.

End def_zero.

Arguments isZero {_} _.
Arguments ZeroObject [C] _.
Arguments ZeroArrowTo [C]{Z} b.
Arguments ZeroArrowFrom [C]{Z} b.
Arguments ZeroArrow [C] _ _ _.
Arguments make_isZero {_} _ _ _ .
Arguments make_Zero {_} _ _ .

Section Zero_Unique.

  Variable C : category.
  Hypothesis H : is_univalent C.

  Lemma isaprop_Zero : isaprop (Zero C).
  Proof.
    apply invproofirrelevance.
    intros Z Z'.
    apply (total2_paths_f (isotoid _ H (z_iso_Zeros _ Z Z'))).
    apply proofirrelevance.
    unfold isZero.
    apply isapropdirprod; apply impred; intros t; apply isapropiscontr.
  Defined.

End Zero_Unique.

Section facts.

  Variable C : category.

  Lemma ZeroIffInitialAndTerminal (b : C) :
    isZero b <-> (isInitial C b) × (isTerminal C b).
  Proof.
    unfold isZero, isInitial, isTerminal.
    split; intros H; apply H.
  Qed.

  Definition ZIsoToisZero {A : C} (Z : Zero C) (i : z_iso A Z) :
    isZero A.
  Proof.
    use make_isZero.
    - intros a.
      use tpair.
      + exact (i · (ZeroArrowFrom a)).
      + cbn. intros t.
        apply (pre_comp_with_z_iso_is_inj (pr2 (z_iso_inv_from_z_iso i))).
        rewrite assoc. cbn. rewrite (z_iso_after_z_iso_inv i). rewrite id_left.
        apply ArrowsFromZero.
    - intros a.
      use tpair.
      + exact ((ZeroArrowTo a) · (z_iso_inv_from_z_iso i)).
      + cbn. intros t.
        apply (post_comp_with_z_iso_is_inj (pr2 i)).
        rewrite <- assoc. cbn.
        etrans.
        2: { apply maponpaths, pathsinv0, (z_iso_after_z_iso_inv i). }
        rewrite id_right.
        apply ArrowsToZero.
  Qed.

  (** ** Transport of ZeroArrow *)
  Lemma transport_target_ZeroArrow {a b c : C} (Z : Zero C) (e : b = c) :
    transportf _ e (ZeroArrow Z a b) = ZeroArrow Z a c.
  Proof.
    induction e. apply idpath.
  Qed.

  Lemma transport_source_ZeroArrow {a b c : C} (Z : Zero C) (e : b = a) :
    transportf (λ (a' : ob C), precategory_morphisms a' c) e (ZeroArrow Z b c) = ZeroArrow Z a c.
  Proof.
    induction e. apply idpath.
  Qed.

Definition zero_lifts (M:category) {X:Type} (j : X -> ob M) := ∃ z, isZero (j z).

End facts.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This tests the dynamic semantics of statements and expressions, pg. 58, 59.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.

Require Export FormalSyntax.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export Tacticals.

Require Export TestUtilities.

(* Test the S judgement. *)

(* ?TODO Let's make these tests more meaninful. *)

(* Let's make some e->e' transitions that actually evaluate something to test this stuff. *)

Definition s  := (if_s (i_e (i_i 0))
                       (e_s (i_e (i_i 0)))
                       (e_s (i_e (i_i 1)))).
Definition s' := (e_s (i_e (i_i 0))).

Definition e  := (dot (cpair (i_e (i_i 0)) (i_e (i_i 1))) zero_pe).
Definition e' := (i_e (i_i 0)).

Definition hxv := [(x,v)].

Example S_Let_3_1_test :
  S [] (letx x v s) [(x,v)] s.
Proof.
  apply S_let_3_1;
  eauto 20 with Chapter3.
Qed.

Example S_seq_3_2_test :
  S [] (seq (e_s v) s) [] s.
Proof.
  apply S_seq_3_2.
  eauto 20 with Chapter3.
Qed.

Example S_return_3_3_test :
 S [] (seq (retn v) s) [] (retn v).
Proof.
  apply S_return_3_3.
  eauto 20 with Chapter3.
Qed.

Example S_if0_3_4_test :
 S [] (if_s (i_e (i_i 0)) s1 s2)
   [] s1.
Proof.
  apply S_if0_3_4.
Qed.

Example S_if_ne_0_3_5_test :
  S [] (if_s vi1 s1 s2) [] s2.
Proof.
  apply S_if_ne_0_3_5.
  eauto 20 with Chapter3.
Qed.

Example S_while_3_6_test :
 S [] (while e s)
   [] (if_s e (seq s (while e s)) (e_s (i_e (i_i 0)))).
Proof.
  apply S_while_3_6.
Qed.

(* Bug 8, just naming in two constructors. *)

(* TODO Questionable test? *)
Example S_open_3_7_test :
  S [] (open (pack tau' v (etype aliases alpha k tau)) alpha x s)
    [] (letx x' v (subst_St s tau alpha)).
Proof.
  apply S_open_3_7.
  eauto 20 with Chapter3.
Qed.

(* TODO Questionable test? *)
Definition etau := (etype aliases alpha A tau).
Definition H38 := [(x,(pack etau v etau))].
Example pack_value:
  getH H38 x = Some v' ->
  Value v'.
Proof.
  intros H.
  compute in H.
  compute.
  eauto 20 with Chapter3.
Qed.

(* Okay so H evaluates right and is a value. *)
(* Bug 20, State unbound. *)
(* Bug 21, Pack not in Values! *)
(* Is this a bug with get or is this just not syntax directed without
  some Tacticals. At least need Tactical for adding nil. *)
(* Bug 22, why is this not syntax directed ? Automation bug really. *)
Example S_openstar_3_8_test :
  S H38 (openstar (p_e x []) alpha x' s)
    H38 (letx x'  (amp (p_e x ([] ++ [u_pe])))
                          (subst_St s tau alpha)).
Proof.
  apply S_openstar_3_8 with
  (tau':= etau) (v:= v) (q:= aliases) (k:=A)
  (v':= (pack etau v etau));
  eauto 20 with Chapter3.
Qed.

Example S_exp_3_9_1_test :
  S [] (e_s e) [] (e_s e').
Proof.
  apply S_exp_3_9_1.
  eauto 20 with Chapter3.
Qed.

Example S_ret_3_9_2_test :
  S [] (retn e) [] (retn e').
Proof.
  apply S_ret_3_9_2.
  eauto 20 with Chapter3.
Qed.

Example S_if_3_9_3_test :
  S [] (if_s e s1 s2) [] (if_s e' s1 s2).
Proof.
  apply S_if_3_9_3.
  eauto 20 with Chapter3.
Qed.

Example S_letx_3_9_4_test :
  S [] (letx x e s) [] (letx x e' s).
Proof.
  apply S_letx_3_9_4.
  eauto 20 with Chapter3.
Qed.

(* ? TODO e not a value.*)
Example S_open_3_9_5_test :
  S [] (open e alpha x s) [] (open e' alpha x s).
Proof.
  apply S_open_3_9_5.
  eauto 20 with Chapter3.
Qed.

(* Bug 9 - extra tvar. *)
(* Bug 10. If returning the wrong clause. *)
Example S_seq_3_10_test :
  S [] (seq s s2) [] (seq s' s2).
Proof.
  apply S_seq_3_10.
  eauto 20 with Chapter3.
Qed.

Example S_openstar_3_11_test :
 S [] (openstar (dot (p_e x []) zero_pe)    alpha x s)
   [] (openstar      (p_e x [i_pe zero_pe]) alpha x s).
Proof.
  apply S_openstar_3_11.
  eauto 20 with Chapter3.
  apply L_xpi_3_1.
Qed.

(* Test R. *)

Definition h703 := [(x,v)].
Example R_get_3_1_test:
  R h703  (e_s (p_e x nil))
    h703  (e_s v).
Proof.
  (* I don't care because eauto can find this v'. *)
  apply R_get_3_1 with (v':=v);
  eauto 20 with Chapter3.
Qed.

Example R_assign_3_2_test:
  R [(x,(i_e (i_i 2)))] (e_s (assign (p_e x []) (i_e (i_i 3))))
    [(x,(i_e (i_i 3)))] (e_s (i_e (i_i 3))).
Proof.
 (* eauto 20 with Chapter3. works. *)
  eapply R_assign_3_2.
  reflexivity.
  eauto 20 with Chapter3.
  reflexivity.
  eauto 20 with Chapter3.
  eauto 20 with Chapter3.
  eauto 20 with Chapter3.
Qed.

Example R_initial_assign_3_2_test:
  R [] (e_s (assign (p_e x []) (i_e (i_i 3))))
    [(x,(i_e (i_i 3)))] (e_s (i_e (i_i 3))).
Proof.
 apply R_initial_assign_3_2;
 eauto 20 with Chapter3.
Qed.

Example R_star_3_3_test:
  R hxv (e_s (star (amp (p_e x nil))))
    hxv (e_s (p_e x nil)).
Proof.
  apply R_star_amp_3_3.
Qed.

Example R_dot_3_4_0_test:
  R [] (e_s (dot (cpair v0 v1) zero_pe))
    [] (e_s v0).
Proof.
  apply R_dot_3_4_0.
Qed.

Example R_dot_3_4_1_test:
  R [] (e_s (dot (cpair v0 v1) one_pe))
    [] (e_s v1).
Proof.
  apply R_dot_3_4_1.
Qed.

Example R_appl_3_5_test:
  R [] (e_s (appl (f_e (dfun tau x tau' s)) v))
    [] (e_s (call (letx x v s))).
Proof.
  apply R_appl_3_5.
  eauto 20 with Chapter3.
Qed.

Example R_call_3_6_test:
  R [] (e_s (call (retn v)))
    [] (e_s v).
Proof.
  apply R_call_3_6.
  eauto 20 with Chapter3.
Qed.

Example R_inst_3_7_test:
  R [] (e_s (inst (f_e (ufun alpha k f)) tau))
    [] (e_s (f_e (subst_F f tau alpha))).
Proof.
  apply R_inst_3_7.
Qed.

(* Bug 12, R instead of S in the precondition. *)

Example R_call_3_8_test:
  R [] (e_s (call s)) [] (e_s (call s')).
Proof.
  apply R_call_3_8.
  eauto 20 with Chapter3.
Qed.

(* Originally I had an invalid left expression here. *)

Example R_amp_3_9_1_test:
  R hxv (e_s (amp (dot (p_e x nil) zero_pe)))
    hxv (e_s (amp (p_e x [i_pe zero_pe]))).
Proof.
  apply R_amp_3_9_1.
  apply L_xpi_3_1.
Qed.

Example R_assign_3_9_2_test:
  R [] (e_s (assign (star (amp (p_e x nil))) v0))
    [] (e_s (assign (p_e x nil) v0)).
Proof.
  apply R_assign_3_9_2.
  eauto 20 with Chapter3.
Qed.

(* These would be nice for test but I can't make a statement into an expression. Even an If. *)

(* TODO It would be better if I went from h to h' here. *)
Example R_star_3_10_1_test:
  R [] (e_s (star (star (amp (p_e x [])))))
    [] (e_s (star (p_e x []))).
Proof.
  apply R_star_3_10_1.
  eauto 20 with Chapter3.
Qed.

Example R_dot_3_10_2_test:
  R [] (e_s (dot (star (amp (p_e x [])))  zero_pe))
    [] (e_s (dot (p_e x [])               zero_pe)).
Proof.
  apply R_dot_3_10_2.
  eauto 20 with Chapter3.
Qed.

(* TODO I should really make these change h to h' under e's evaluation. *)

Example Bug14_e_e':
 ~ R [] (e_s (i_e (i_i 0)))
     [] (e_s (i_e (i_i 1))).
Proof.
  compute.
  intros H.
  inversion H.
Qed.

(* Bug 17, L's instead of R's on precondition to 3.10 rules. *)
Example R_assign_3_10_3_test:
  R h (e_s (assign (p_e x pdot) e))
    h (e_s (assign (p_e x pdot) e')).
Proof.
  apply R_assign_3_10_3.
  eauto 20 with Chapter3.
Qed.

Example R_inst_3_10_4_test:
  R h  (e_s (inst e tau))
    h (e_s (inst e' tau)).
Proof.
  apply R_inst_3_10_4.
  eauto 20 with Chapter3.
Qed.

Example R_pack_3_10_5_test:
  R h  (e_s (pack tau' e  (etype witnesschanges alpha k tau)))
    h  (e_s (pack tau' e' (etype witnesschanges alpha k tau))).
Proof.
  apply R_pack_3_10_5.
  eauto 20 with Chapter3.
Qed.

(* Bug 18, Tau unquantified in three rules. *)
Example R_cpair_3_10_6_test:
  R h (e_s (cpair e e2))
    h (e_s (cpair e' e2)).
Proof.
  apply R_cpair_3_10_6.
  eauto 20 with Chapter3.
Qed.

Example R_cpair_3_10_7_test:
  R h (e_s (cpair v e))
    h (e_s (cpair v e')).
Proof.
  apply R_cpair_3_10_7;
  eauto 20 with Chapter3.
Qed.

Example R_cpair_3_10_8_test:
  R h (e_s (cpair e e2))
    h (e_s (cpair e' e2)).
Proof.
  apply R_cpair_3_10_8.
  eauto 20 with Chapter3.
Qed.

Example R_appl_3_10_9_test:
  R h (e_s (appl e e2))
    h (e_s (appl e' e2)).
Proof.
  apply R_appl_3_10_9.
  eauto 20 with Chapter3.
Qed.

Example R_appl_3_10_10_test:
  R h (e_s (appl v e))
    h (e_s (appl v e')).
Proof.
  apply R_appl_3_10_10;
  eauto 20 with Chapter3.
Qed.

(* Test L *)

Example L_xpi_3_1_test:
  L h (e_s (dot (p_e x nil) zero_pe))
    h (e_s (p_e x [(i_pe zero_pe)])).
Proof.
 apply L_xpi_3_1.
Qed.

Example L_staramp_3_2_test:
  L h (e_s (star (amp (p_e x nil)))) h (e_s (p_e x nil)).
Proof.
 apply L_staramp_3_2.
Qed.

(* Bug 11, h should have been h'. *)
(* Bug 14, extra e in quantification. *)
Example L_star_3_3_test:
  L h (e_s (star e)) h (e_s (star e')) .
Proof.
 eapply L_star_3_3.
 eauto 20 with Chapter3.
Qed.

(* Bug 19, extra quantified variable. *)
Example L_ei_3_4_test:
  L [] (e_s (dot (dot (p_e x []) zero_pe) zero_pe))
    [] (e_s (dot (p_e x ([] ++ [i_pe zero_pe])) zero_pe)).
Proof.
 apply L_ei_3_4.
 eauto 20 with Chapter3.
Qed.


From iris.proofmode Require Import tactics.
From iris_string_ident Require Import ltac2_string_ident.

Lemma sep_demo {PROP: sbi} (P1: PROP)  (P2 P3: Prop) (Himpl: P2 -> P3) :
  P1 ∗ ⌜P2⌝ -∗ P1 ∗ ⌜P3⌝.
Proof.
  iIntros "[HP %HP2]".
  iFrame.
  iPureIntro.
  exact (Himpl HP2).
Qed.