From Coq Require Import Arith Lia ZArith List.
From Coq Require Import Sorting.Permutation.
From StructTact Require Import StructTactics ListTactics.
Import ListNotations.

Set Implicit Arguments.

Notation member := (in_dec eq_nat_dec).

Lemma seq_range :
  forall n a x,
    In x (seq a n) ->
    a <= x < a + n.
Proof.
  induction n; intros; simpl in *.
  - intuition auto.
  - break_or_hyp; try find_apply_hyp_hyp; intuition lia.
Qed.

Lemma plus_gt_0 :
  forall a b,
    a + b > 0 ->
    a > 0 \/ b > 0.
Proof.
  intros.
  destruct (eq_nat_dec a 0); intuition lia.
Qed.

Section list_util.
  Variables A B C : Type.
  Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  Lemma list_neq_cons :
    forall (l : list A) x,
      x :: l <> l.
  Proof using.
    intros l x H.
    symmetry in H.
    induction l;
      now inversion H.
  Qed.

  Lemma remove_preserve :
    forall (x y : A) xs,
      x <> y ->
      In y xs ->
      In y (remove A_eq_dec x xs).
  Proof using.
    induction xs; intros.
    - intuition auto.
    - simpl in *.
      concludes.
      break_or_hyp; break_if; subst; try congruence; intuition (auto with datatypes).
  Qed.

  Lemma in_remove :
    forall (x y : A) xs,
      In y (remove A_eq_dec x xs) ->
      In y xs.
  Proof using.
    induction xs; intros.
    - auto.
    - simpl in *. break_if; simpl in *; intuition auto.
  Qed.

  Lemma remove_partition :
    forall xs (p : A) ys,
      remove A_eq_dec p (xs ++ p :: ys) = remove A_eq_dec p (xs ++ ys).
  Proof using.
    induction xs; intros; simpl; break_if; congruence.
  Qed.

  Lemma remove_not_in :
    forall (x : A) xs,
      ~ In x xs ->
      remove A_eq_dec x xs = xs.
  Proof using.
    intros. induction xs; simpl in *; try break_if; intuition congruence.
  Qed.

  Lemma remove_app_comm :
    forall a xs ys,
      remove A_eq_dec a (xs ++ ys) = remove A_eq_dec a xs ++ remove A_eq_dec a ys.
  Proof.
    intros.
    generalize dependent ys.
    induction xs; intros.
    - tauto.
    - destruct (A_eq_dec a0 a);
      simpl;
      break_if;
      try rewrite <- app_comm_cons;
      rewrite IHxs;
      congruence.
  Qed.

  Lemma filter_app : forall (f : A -> bool) xs ys,
      filter f (xs ++ ys) = filter f xs ++ filter f ys.
  Proof using.
    induction xs; intros.
    - auto.
    - simpl. rewrite IHxs. break_if; auto.
  Qed.

  Lemma filter_fun_ext_eq : forall f g xs,
      (forall a : A, In a xs -> f a = g a) ->
      filter f xs = filter g xs.
  Proof using.
    induction xs; intros.
    - auto.
    - simpl. rewrite H by intuition (auto with datatypes).
      rewrite IHxs by intuition (auto with datatypes). auto.
  Qed.

  Lemma not_in_filter_false :
    forall (f : A -> bool) l x,
      In x l ->
      ~ In x (filter f l) ->
      f x = false.
  Proof.
    intros.
    destruct (f x) eqn:?H; [|tauto].
    unfold not in *; find_false.
    now eapply filter_In.
  Qed.

  Lemma filter_length_bound :
    forall f (l : list A),
      length (filter f l) <= length l.
  Proof.
    induction l.
    - easy.
    - simpl.
      break_if; simpl; lia.
  Qed.

  Lemma NoDup_map_injective : forall (f : A -> B) xs,
      (forall x y, In x xs -> In y xs ->
              f x = f y -> x = y) ->
      NoDup xs -> NoDup (map f xs).
  Proof using.
    induction xs; intros.
    - constructor.
    - simpl. invc_NoDup. constructor.
      + intro. do_in_map.
        assert (x = a) by intuition (auto with datatypes).
        congruence.
      + intuition (auto with datatypes).
  Qed.

  Lemma NoDup_disjoint_append :
    forall (l : list A) l',
      NoDup l ->
      NoDup l' ->
      (forall a, In a l -> ~ In a l') ->
      NoDup (l ++ l').
  Proof using.
    induction l; intros.
    - auto.
    - simpl. invc_NoDup. constructor.
      + intro. do_in_app. intuition eauto with datatypes.
      + intuition eauto with datatypes.
  Qed.

  Lemma NoDup_map_partition :
    forall (f : A -> B) xs l y zs xs' y' zs',
      NoDup (map f l) ->
      l = xs ++ y :: zs ->
      l = xs' ++ y' :: zs' ->
      f y = f y' ->
      xs = xs'.
  Proof using.
    induction xs; simpl; intros; destruct xs'.
    - auto.
    - subst. simpl in *. find_inversion.
      invc H. exfalso. rewrite map_app in *. simpl in *.
      repeat find_rewrite. intuition (auto with datatypes).
    - subst. simpl in *. find_inversion.
      invc H. exfalso. rewrite map_app in *. simpl in *.
      repeat find_rewrite. intuition (auto with datatypes).
    - subst. simpl in *. find_injection. intros. subst.
      f_equal. eapply IHxs; eauto. solve_by_inversion.
  Qed.

  Lemma filter_NoDup :
    forall p (l : list A),
      NoDup l ->
      NoDup (filter p l).
  Proof using.
    induction l; intros.
    - auto.
    - invc_NoDup. simpl. break_if; auto.
      constructor; auto.
      intro. apply filter_In in H. intuition auto.
  Qed.

  Lemma NoDup_map_filter :
    forall (f : A -> B) g l,
      NoDup (map f l) ->
      NoDup (map f (filter g l)).
  Proof using.
    intros. induction l; simpl in *.
    - constructor.
    - invc_NoDup. concludes.
      break_if; simpl in *; auto.
      constructor; auto.
      intro. do_in_map.
      find_apply_lem_hyp filter_In. intuition auto.
      match goal with | H : _ -> False |- False => apply H end.
      apply in_map_iff. eauto.
  Qed.

  Lemma filter_true_id : forall (f : A -> bool) xs,
      (forall x, In x xs -> f x = true) ->
      filter f xs = xs.
  Proof using.
    induction xs; intros.
    - auto.
    - simpl. now rewrite H, IHxs by intuition (auto with datatypes).
  Qed.

  Lemma map_of_map : forall (f : A -> B) (g : B -> C) xs,
      map g (map f xs) = map (fun x => g (f x)) xs.
  Proof using.
    induction xs; simpl; auto using f_equal2.
  Qed.

  Lemma filter_except_one : forall (f g : A -> bool) x xs,
      (forall y, In y xs ->
            x <> y ->
            f y = g y) ->
      g x = false ->
      filter f (remove A_eq_dec x xs) = filter g xs.
  Proof using.
    induction xs; intros.
    - auto.
    - simpl.
      break_if.
      + subst. repeat find_rewrite. eauto with datatypes.
      + simpl. rewrite H by auto with datatypes.
        break_if; eauto using f_equal2 with datatypes.
  Qed.

  Lemma flat_map_nil : forall (f : A -> list B) l,
      flat_map f l = [] ->
      l = [] \/ (forall x, In x l -> f x = []).
  Proof using.
    induction l; intros.
    - intuition auto.
    - right. simpl in *.
      apply app_eq_nil in H.
      intros; break_and; break_or_hyp; concludes; break_or_hyp; auto.
      contradiction.
  Qed.

  Theorem NoDup_Permutation_NoDup :
    forall (l l' : list A),
      NoDup l ->
      Permutation l l' ->
      NoDup l'.
  Proof using.
    intros l l' Hnd Hp.
    induction Hp; auto; invc_NoDup; constructor;
      eauto using Permutation_in, Permutation_sym;
      simpl in *; intuition (auto with struct_util).
  Qed.

  Theorem NoDup_append :
    forall l (a : A),
      NoDup (l ++ [a]) <-> NoDup (a :: l).
  Proof using.
    intuition eauto using NoDup_Permutation_NoDup, Permutation_sym, Permutation_cons_append.
  Qed.

  Lemma NoDup_map_elim :
    forall (f : A -> B) xs x y,
      f x = f y ->
      NoDup (map f xs) ->
      In x xs ->
      In y xs ->
      x = y.
  Proof using.
    induction xs; intros; simpl in *.
    - intuition auto.
    - invc_NoDup. intuition auto; subst; auto; exfalso.
      + repeat find_rewrite. auto using in_map.
      + repeat find_reverse_rewrite. auto using in_map.
  Qed.

  Lemma remove_length_not_in : forall (x : A) xs,
      ~ In x xs ->
      length (remove A_eq_dec x xs) = length xs.
  Proof using.
    induction xs; intros.
    - auto.
    - simpl in *. intuition auto.
      break_if; subst; simpl; intuition auto.
  Qed.

  Lemma remove_length_in : forall (x : A) xs,
      In x xs ->
      NoDup xs ->
      S (length (remove A_eq_dec x xs)) = length xs.
  Proof using.
    induction xs; intros; simpl in *; intuition; invc_NoDup;
      break_if; subst; intuition (simpl; try congruence).
    now rewrite remove_length_not_in.
  Qed.

  Lemma subset_size_eq :
    forall xs,
      NoDup xs ->
      forall ys,
        NoDup ys ->
        (forall x : A, In x xs -> In x ys) ->
        length xs = length ys ->
        (forall x, In x ys -> In x xs).
  Proof using.
    induction xs; intros.
    - destruct ys; simpl in *; congruence.
    - invc_NoDup. concludes.
      assert (In a ys) by eauto with datatypes.
      find_apply_lem_hyp in_split.
      break_exists_name l1.
      break_exists_name l2.
      subst.
      specialize (IHxs (l1 ++ l2)).
      conclude_using ltac:(eauto using NoDup_remove_1).
      forward IHxs.
      intros x' Hx'.
      assert (In x' (l1 ++ a :: l2)) by eauto with datatypes.
      do_in_app. simpl in *. intuition auto with datatypes. subst. congruence.
      concludes.
      forward IHxs.
      rewrite app_length in *. simpl in *. lia.
      concludes.
      do_in_app. simpl in *. intuition auto with datatypes.
  Qed.

  Lemma remove_NoDup :
    forall (x : A) xs,
      NoDup xs ->
      NoDup (remove A_eq_dec x xs).
  Proof using.
    induction xs; intros.
    - auto with struct_util.
    - invc_NoDup. simpl. break_if; eauto 6 using in_remove with struct_util.
  Qed.

  Lemma remove_length_ge : forall (x : A) xs,
      NoDup xs ->
      length (remove A_eq_dec x xs) >= length xs - 1.
  Proof using.
    induction xs; intros.
    - auto.
    - invc_NoDup. simpl. break_if.
      + rewrite Nat.sub_0_r.
        subst.
        rewrite remove_length_not_in; auto.
      + simpl. concludes. lia.
  Qed.

  Lemma remove_length_le :
    forall (x : A) xs eq_dec,
      length xs >= length (remove eq_dec x xs).
  Proof using.
    induction xs; intros.
    - auto.
    - simpl in *.
      specialize (IHxs eq_dec).
      break_if; subst; simpl; lia.
  Qed.

  Lemma remove_length_lt :
    forall (x : A) xs eq_dec,
      In x xs ->
      length xs > length (remove eq_dec x xs).
  Proof using.
    induction xs; intros; simpl in *; [contradiction|]; break_or_hyp.
    - subst.
      break_if; try congruence.
      pose proof remove_length_le x xs eq_dec.
      lia.
    - specialize (IHxs ltac:(eauto) ltac:(eauto)).
      break_if; subst; simpl; lia.
  Qed.

  Lemma subset_length :
    forall xs ys,
      NoDup xs ->
      (forall x : A, In x xs -> In x ys) ->
      length ys >= length xs.
  Proof using A_eq_dec.
    induction xs; intros.
    - simpl. lia.
    - specialize (IHxs (remove A_eq_dec a ys)).
      invc_NoDup.
      concludes.
      forward IHxs.
      intros.
      apply remove_preserve;
       [congruence|intuition (auto with datatypes)].
      concludes.
      pose proof remove_length_lt a ys A_eq_dec.
      assert (In a ys) by auto with datatypes.
      concludes.
      simpl. lia.
  Qed.

  Lemma app_cons_singleton_inv :
    forall xs (y : A) zs w,
      xs ++ y :: zs = [w] ->
      xs = [] /\ y = w /\ zs = [].
  Proof using.
    intros.
    destruct xs.
    - solve_by_inversion.
    - destruct xs; solve_by_inversion.
  Qed.

  Lemma app_cons_in :
    forall (l : list A) xs a ys,
      l = xs ++ a :: ys ->
      In a l.
  Proof using.
    intros. subst. auto with datatypes.
  Qed.
  Hint Resolve app_cons_in : struct_util.

  Lemma app_cons_in_rest:
    forall (l : list A) xs a b ys,
      l = xs ++ a :: ys ->
      In b (xs ++ ys) ->
      In b l.
  Proof using.
    intros. subst.
    do_in_app; intuition auto with datatypes.
  Qed.
  Hint Resolve app_cons_in_rest : struct_util.

  Lemma in_rest_app_cons:
    forall (l xs ys : list A) a b,
      l = xs ++ a :: ys ->
      In b l ->
      a <> b ->
      In b (xs ++ ys).
  Proof using.
    intros.
    subst_max.
    do_in_app.
    break_or_hyp.
    - auto with datatypes.
    - find_apply_lem_hyp in_inv.
      break_or_hyp; auto using in_or_app || congruence.
  Qed.
  Hint Resolve in_rest_app_cons : struct_util.

  Lemma remove_filter_commute :
    forall (l : list A) A_eq_dec f x,
      remove A_eq_dec x (filter f l) = filter f (remove A_eq_dec x l).
  Proof using.
    induction l; intros; simpl in *; auto.
    repeat (break_if; subst; simpl in *; try congruence).
  Qed.

  Lemma In_filter_In :
    forall (f : A -> bool) x l l',
      filter f l = l' ->
      In x l' -> In x l.
  Proof using.
    intros. subst.
    eapply filter_In; eauto.
  Qed.

  Lemma filter_partition :
    forall (l1 : list A) f l2 x l1' l2',
      NoDup (l1 ++ x :: l2) ->
      filter f (l1 ++ x :: l2) = (l1' ++ x :: l2') ->
      filter f l1 = l1' /\ filter f l2 = l2'.
  Proof using.
    induction l1; intros; simpl in *; break_if; simpl in *; invc_NoDup.
    - destruct l1'; simpl in *.
      + solve_by_inversion.
      + find_inversion. exfalso. eauto using In_filter_In with datatypes.
    - exfalso. eauto using In_filter_In with datatypes.
    - destruct l1'; simpl in *; break_and; find_inversion.
      + exfalso. eauto with datatypes.
      + find_apply_hyp_hyp. intuition auto using f_equal2.
    - eauto.
  Qed.

  Lemma map_inverses :
    forall (la : list A) (lb : list B)  (f : A -> B) g,
      (forall a, g (f a) = a) ->
      (forall b, f (g b) = b) ->
      lb = map f la ->
      la = map g lb.
  Proof using.
    destruct la; intros; simpl in *.
    - subst. reflexivity.
    - destruct lb; try congruence.
      simpl in *. find_inversion.
      find_higher_order_rewrite.
      f_equal.
      rewrite map_map.
      erewrite map_ext; [symmetry; apply map_id|].
      simpl in *. auto.
  Qed.

  Lemma In_notIn_implies_neq :
    forall x y l,
      In(A:=A) x l ->
      ~ In(A:=A) y l ->
      x <> y.
  Proof using.
    intuition congruence.
  Qed.

  Lemma In_cons_neq :
    forall a x xs,
      In(A:=A) a (x :: xs) ->
      a <> x ->
      In a xs.
  Proof using.
    simpl.
    intuition congruence.
  Qed.

  Lemma NoDup_app3_not_in_1 :
    forall (xs ys zs : list A) b,
      NoDup (xs ++ ys ++ b :: zs) ->
      In b xs ->
      False.
  Proof using.
    intros.
    rewrite <- app_ass in *.
    find_apply_lem_hyp NoDup_remove.
    rewrite app_ass in *.
    intuition (auto with datatypes).
  Qed.

  Lemma NoDup_app3_not_in_2 :
    forall (xs ys zs : list A) b,
      NoDup (xs ++ ys ++ b :: zs) ->
      In b ys ->
      False.
  Proof using.
    intros.
    rewrite <- app_ass in *.
    find_apply_lem_hyp NoDup_remove_2.
    rewrite app_ass in *.
    auto 10 with datatypes.
  Qed.

  Lemma NoDup_app3_not_in_3 :
    forall (xs ys zs : list A) b,
      NoDup (xs ++ ys ++ b :: zs) ->
      In b zs ->
      False.
  Proof using.
    intros.
    rewrite <- app_ass in *.
    find_apply_lem_hyp NoDup_remove_2.
    rewrite app_ass in *.
    auto 10 with datatypes.
  Qed.

  Lemma In_cons_2_3 :
    forall xs ys zs x y a,
      In (A:=A) a (xs ++ ys ++ zs) ->
      In a (xs ++ x :: ys ++ y :: zs).
  Proof using.
    intros.
    repeat (do_in_app; intuition auto 10 with datatypes).
  Qed.

  Lemma In_cons_2_3_neq :
    forall a x y xs ys zs,
      In (A:=A) a (xs ++ x :: ys ++ y :: zs) ->
      a <> x ->
      a <> y ->
      In a (xs ++ ys ++ zs).
  Proof using.
    intros.
    repeat (do_in_app; simpl in *; intuition (auto with datatypes; try congruence)).
  Qed.

  Lemma in_middle_reduce :
    forall a xs y zs,
      In (A:=A) a (xs ++ y :: zs) ->
      a <> y ->
      In a (xs ++ zs).
  Proof using.
    intros.
    do_in_app; simpl in *; intuition auto with datatypes. congruence.
  Qed.

  Lemma in_middle_insert :
    forall a xs y zs,
      In (A:=A) a (xs ++ zs) ->
      In a (xs ++ y :: zs).
  Proof using.
    intros.
    do_in_app; simpl in *; intuition auto with datatypes.
  Qed.

  Lemma NoDup_rev :
    forall l,
      NoDup (A:=A) l ->
      NoDup (rev l).
  Proof using.
    induction l; intros; simpl.
    - auto.
    - apply NoDup_append.
      invc_NoDup.
      constructor; auto.
      intuition.
      find_apply_lem_hyp in_rev.
      auto.
  Qed.

  Lemma NoDup_map_map :
    forall (f : A -> B) (g : A -> C) xs,
      (forall x y, In x xs -> In y xs -> f x = f y -> g x = g y) ->
      NoDup (map g xs) ->
      NoDup (map f xs).
  Proof using.
    induction xs; intros; simpl in *.
    - constructor.
    - invc_NoDup.
      constructor; auto.
      intro.
      do_in_map.
      find_apply_hyp_hyp.
      find_reverse_rewrite.
      auto using in_map.
  Qed.

  Lemma pigeon :
    forall (l : list A) sub1 sub2,
      (forall a, In a sub1 -> In a l) ->
      (forall a, In a sub2 -> In a l) ->
      NoDup l ->
      NoDup sub1 ->
      NoDup sub2 ->
      length sub1 + length sub2 > length l ->
      exists a, In a sub1 /\ In a sub2.
  Proof using A_eq_dec.
    induction l.
    intros.
    + simpl in *. find_apply_lem_hyp plus_gt_0. intuition.
      * destruct sub1; simpl in *; [lia|].
        specialize (H a). intuition.
      * destruct sub2; simpl in *; [lia|].
        specialize (H0 a). intuition.
    + intros. simpl in *.
      destruct (in_dec A_eq_dec a sub1);
        destruct (in_dec A_eq_dec a sub2); eauto;
          specialize (IHl (remove A_eq_dec a sub1) (remove A_eq_dec a sub2));
          cut (exists a0, In a0 (remove A_eq_dec a sub1) /\ In a0 (remove A_eq_dec a sub2));
          try solve [intros; break_exists;
                     intuition eauto using in_remove];
          apply IHl; try solve [
                           intros; find_copy_apply_lem_hyp in_remove;
                           find_apply_hyp_hyp; intuition; subst; exfalso; eapply remove_In; eauto];
          eauto using remove_NoDup; try solve_by_inversion;
            repeat match goal with
                   | H : ~ In a ?sub |- _ =>
                     assert (length (remove A_eq_dec a sub) = length sub)
                       by eauto using remove_length_not_in; clear H
                   | H : In a ?sub |- _ =>
                     assert (length (remove A_eq_dec a sub) >= length sub - 1)
                       by eauto using remove_length_ge; clear H
                   end; lia.
  Qed.

  Lemma snoc_assoc :
    forall (l : list A) x y,
      l ++ [x; y] = (l ++ [x]) ++ [y].
  Proof using.
    induction l; intros; simpl; intuition.
    auto using f_equal.
  Qed.

  Lemma cons_cons_app :
    forall (x y : A),
      [x; y] = [x] ++ [y].
  Proof using.
    auto.
  Qed.

  Lemma map_eq_inv :
    forall (f : A -> B) l xs ys,
      map f l = xs ++ ys ->
      exists l1 l2,
        l = l1 ++ l2 /\
        map f l1 = xs /\
        map f l2 = ys.
  Proof using.
    induction l; simpl; intros xs ys H.
    - symmetry in H. apply app_eq_nil in H. break_and. subst.
      exists [], []. auto.
    - destruct xs; simpl in *.
      + exists [], (a :: l). intuition.
      + invc H. find_apply_hyp_hyp.
        break_exists_name l1.
        break_exists_name l2.
        break_and.
        exists (a :: l1), l2. subst.
        intuition.
  Qed.

  Lemma map_partition :
    forall p l (x : B) p' (f : A -> B),
      map f l = (p ++ x :: p') ->
      exists ap a ap',
        l = ap ++ a :: ap' /\
        map f ap = p /\
        f a = x /\
        map f ap' = p'.
  Proof using.
    intros p l x p' f H_m.
    pose proof map_eq_inv f _ _ _ H_m.
    break_exists_name l1.
    break_exists_name l2.
    break_and.
    find_rewrite.
    destruct l2; simpl in *.
    - match goal with H : [] = _ :: _ |- _ => contradict H end.
      auto with datatypes.
    - repeat find_rewrite.
      find_inversion.
      exists l1, a, l2. auto.
  Qed.

  Lemma map_eq_inv_eq :
    forall (f : A -> B),
      (forall a a', f a = f a' -> a = a') ->
      forall l l', map f l = map f l' -> l = l'.
  Proof using.
    induction l; simpl; intros l' Heq; destruct l'; simpl in *; try congruence.
    find_inversion. auto using f_equal2.
  Qed.

  Lemma map_fst_snd_id :
    forall l, map (fun t : A * B => (fst t, snd t)) l = l.
  Proof using.
    intros.
    rewrite <- map_id.
    apply map_ext.
    destruct a; auto.
  Qed.

  Lemma in_firstn : forall n (x : A) xs,
      In x (firstn n xs) -> In x xs.
  Proof using.
    induction n; simpl; intuition; break_match; simpl in *; intuition.
  Qed.

  Lemma firstn_NoDup : forall n (xs : list A),
    NoDup xs ->
    NoDup (firstn n xs).
  Proof using.
    induction n; intros; simpl; destruct xs; auto with struct_util.
    invc_NoDup.
    eauto 6 using in_firstn with struct_util.
  Qed.

  Lemma NoDup_mid_not_in :
    forall (a : A) (l l' : list A),
    NoDup (l ++ a :: l') ->
    ~ In a (l ++ l').
  Proof using.
    induction l; intros; simpl in *.
    - invc_NoDup; auto.
    - invc_NoDup.
      intro.
      break_or_hyp.
      * match goal with H: ~ In _ _ |- _ => contradict H end.
        apply in_or_app.
        right; left. auto.
      * match goal with H: In _ _ |- _ => contradict H end.
        eauto.
    Qed.

  Lemma Permutation_split :
    forall (ns ns' : list A) (n : A),
      Permutation (n :: ns) ns' ->
      exists ns0, exists ns1, ns' = ns0 ++ n :: ns1.
  Proof using.
    intros l l' a H_pm.
    assert (In a (a :: l)); auto with datatypes.
    assert (In a l'); eauto using Permutation_in.
    find_apply_lem_hyp In_split; auto.
  Qed.

  Lemma NoDup_app_left :
    forall (l l' : list A),
      NoDup (l ++ l') -> NoDup l.
  Proof using.
    induction l; intros; simpl in *.
    - apply NoDup_nil.
    - invc_NoDup.
      find_apply_hyp_hyp.
      apply NoDup_cons; auto.
      intro.
      match goal with H: ~ In _ _ |- _ => contradict H end.
      apply in_or_app.
      left; auto.
  Qed.

  Lemma NoDup_app_right :
    forall (l l' : list A),
      NoDup (l ++ l') -> NoDup l'.
  Proof using.
    induction l; intros; simpl in *; auto.
    invc_NoDup.
    find_apply_hyp_hyp; auto.
  Qed.

  Lemma NoDup_in_not_in_right :
    forall (l l' : list A) (a : A),
      NoDup (l ++ l') -> In a l -> ~ In a l'.
  Proof using.
    induction l; intros; simpl in *; auto.
    invc_NoDup.
    break_or_hyp; eauto with datatypes.
  Qed.

  Lemma NoDup_in_not_in_left :
    forall (l l' : list A) (a : A),
    NoDup (l ++ l') -> In a l' -> ~ In a l.
  Proof using.
    intros.
    induction l; simpl in *; auto.
    invc_NoDup.
    concludes.
    intro.
    break_or_hyp; auto with datatypes.
  Qed.

  Lemma count_occ_app :
    forall l l' (a : A),
      count_occ A_eq_dec (l ++ l') a = count_occ A_eq_dec l a + count_occ A_eq_dec l' a.
  Proof using.
    intros.
    induction l; simpl in *; auto.
    break_if; auto.
    find_rewrite.
    auto.
  Qed.

  Lemma Permutation_map_fst :
    forall l l' : list (A * B),
      Permutation l l' ->
      Permutation (map fst l) (map fst l').
  Proof using.
    induction l; intros; simpl in *.
    - find_apply_lem_hyp Permutation_nil.
      find_rewrite.
      auto.
    - assert (In a l').
        apply Permutation_in with (l := a :: l); auto with datatypes.
      find_apply_lem_hyp in_split.
      break_exists.
      find_rewrite.
      find_apply_lem_hyp Permutation_cons_app_inv.
      find_apply_hyp_hyp.
      find_rewrite.
      rewrite map_app.
      simpl.
      apply Permutation_cons_app.
      rewrite <- map_app.
      auto.
     Qed.

  Lemma snd_eq_not_in_map :
    forall (l : list (A * B)) n m,
      (forall nm, In nm l -> snd nm = m) ->
      ~ In (n, m) l ->
      ~ In n (map fst l).
  Proof using.
    intros.
    induction l; simpl in *; auto.
    intro.
    break_or_hyp.
    - match goal with H: ~ _ |- _ => contradict H end.
      left.
      destruct a.
      match goal with H: forall _ : A * B, _ |- _ => specialize (H (a, b)) end.
      simpl in *.
      intuition eauto; repeat find_rewrite; auto.
    - match goal with H: In _ _ |- _ => contradict H end.
      apply IHl; eauto.
  Qed.

  Lemma NoDup_map_snd_fst :
    forall nms : list (A * B),
      NoDup nms ->
      (forall nm nm', In nm nms -> In nm' nms -> snd nm = snd nm') ->
      NoDup (map fst nms).
  Proof using.
    intros.
    induction nms; simpl in *.
    - apply NoDup_nil.
    - invc_NoDup.
      apply NoDup_cons.
      * assert (forall nm, In nm nms -> snd nm = snd a).
          intuition eauto.
        destruct a.
        apply snd_eq_not_in_map with (m := b); auto.
      * apply IHnms; auto.
  Qed.

  Lemma in_fold_left_by_cons_in :
    forall (l : list B) (g : B -> A) x acc,
      In x (fold_left (fun a b => g b :: a) l acc) ->
      In x acc \/ exists y, In y l /\ x = g y.
  Proof using A_eq_dec.
    intros until l.
    induction l.
    - auto.
    - simpl; intros.
      destruct (A_eq_dec x (g a)); subst.
      + right; exists a; tauto.
      + find_apply_lem_hyp IHl.
        break_or_hyp; [left|right].
        * find_apply_lem_hyp In_cons_neq; tauto.
        * break_exists_exists; tauto.
  Qed.

  Lemma fold_left_for_each_not_in :
    forall (f : A -> B -> A) (g : A -> B -> C),
      (forall a b b',
          b <> b' ->
          g (f a b') b = g a b) ->
      forall l a b,
        ~ In b l ->
        g (fold_left f l a) b = g a b.
  Proof using A B C.
    induction l as [| b' l']; simpl in *; auto.
    - intros. intuition.
      rewrite IHl'; auto.
  Qed.

  Lemma fold_left_for_each_in :
    forall (f : A -> B -> A) (g : A -> B -> C) (B_eq_dec : forall x y : B, {x = y} + {x <> y}),
      (forall a b b',
          b <> b' ->
          g (f a b') b = g a b) ->
      forall l a b,
        In b l ->
        exists a',
          g (fold_left f l a) b = g (f a' b) b.
  Proof using A B C.
    induction l as [|b' l']; simpl in *; intuition; subst.
    destruct (in_dec B_eq_dec b l'); intuition.
    find_eapply_lem_hyp fold_left_for_each_not_in; eauto.
  Qed.

  Lemma hd_error_tl_exists :
    forall (l : list A) x,
      hd_error l = Some x ->
      exists tl,
        l = x :: tl.
  Proof.
    intros.
    destruct l; simpl in *.
    - congruence.
    - eexists; solve_by_inversion.
  Qed.

  Lemma hd_error_None :
    forall (l : list A),
      hd_error l = None ->
      l = [].
  Proof.
    now destruct l.
  Qed.

End list_util.

(* We have to repeat these Hint Resolve commands because hints don't survive
   past the ends of sections *)
#[global] Hint Resolve app_cons_in : struct_util.
#[global] Hint Resolve app_cons_in_rest : struct_util.
#[global] Hint Resolve in_rest_app_cons : struct_util.


Require Import MyTactics.
Require Import LCSyntax.
Require Import LCValues.
Require Import LCReduction.
Require Import Arith.

(*|

-----
Types
-----

Here is the syntax of simple types:

|*)

Inductive ty :=
| TyVar (x : var)
| TyFun (A B : ty)
| TyOption (T: ty).

Fixpoint size (T: ty) { struct T } :=
  match T with
  | TyVar _ => 0
  | TyFun A B => 1 + size A + size B
  | TyOption A => 1 + size A
  end
.

(*|

A type environment is viewed as a total function of variables to types.

In principle, an environment should be modeled as a list of types, which
represents a partial function of variables to types. This introduces a few
complications, and is left as an exercise for the reader.

|*)

Definition tyenv := var -> ty.

(*|

--------------------
The typing judgement
--------------------

The simply-typed lambda-calculus is defined by the following three
typing rules.

|*)

Inductive jt : tyenv -> term -> ty -> Prop :=
| JTVar:
    forall Gamma x T,
    Gamma x = T ->
    jt Gamma (Var x) T
| JTLam:
    forall Gamma t T U,
    jt (T .: Gamma) t U ->
    jt Gamma (Lam t) (TyFun T U)
| JTApp:
    forall Gamma t1 t2 T U,
    jt Gamma t1 (TyFun T U) ->
    jt Gamma t2 T ->
    jt Gamma (App t1 t2) U
| JtNone:
  forall Gamma T,
  jt Gamma VariantNone (TyOption T)
| JtSome:
  forall Gamma t T,
  jt Gamma t T ->
  jt Gamma (VariantSome t) (TyOption T)
| JtMatch:
  forall Gamma tc t1 t2 T U,
  jt Gamma tc (TyOption U) ->
  jt Gamma t1 T ->
  jt ( U .: Gamma) t2 T ->
  jt Gamma (Match tc t1 t2) T
.

Lemma empty_is_sound:
  forall t T Gamma,
  jt Gamma t T ->
  forall k,
  fv k t ->
  forall Gamma',
  (forall i, i < k  -> Gamma' i = Gamma i) -> jt Gamma' t T.
Proof.
  intros t T Gamma H; induction H; intros.
  * econstructor.
    rewrite H1; eauto.
    fv.
  * econstructor.
    eapply IHjt.
    fv.
    induction i; eauto.
    simpl; intros. apply H1. lia.
  * econstructor; fv; unpack.
    - eapply IHjt1; eauto.
    - eapply IHjt2; eauto.
  * admit.
  * admit.
  * admit.
Admitted.

Lemma jt_determ:
  forall Gamma x T,
  jt Gamma (Var x) T ->
  forall U,
  jt Gamma (Var x) U ->
  T = U.
Proof.
  intros Gamma t x Hjtx.
  inverts Hjtx.
  intros.
  now inverts H.
Qed.

Lemma exists_diff (T: ty):
  exists U, T <> U.
Proof.
  exists (TyFun T T).
  remember (size T).
  assert (size T <> 1 + size T + size T).
  { lia. }
  intro.
  eapply H.
  rewrite H0 at 1. simpl; eauto.
Qed.

Require Import PeanoNat.
Require Import Bool.

Lemma reflect_lt_ltb:
  forall n m, reflect (n < m) (n <? m).
Proof.
  intros.
  remember (n <? m).
  induction b; econstructor.
  * eapply Nat.ltb_lt; eauto.
  * eapply Nat.ltb_nlt; eauto.
Qed.

(*|

The tactic [pick_jt t] picks a hypothesis [h] whose statement is a typing
judgement about the term [t], and passes [h] to the Ltac continuation [k].

Thus, for instance, [pick_jt t invert] selects a typing judgement that is
at hand for the term [t] and inverts it.

|*)

Ltac pick_jt t k :=
  match goal with h: jt _ t _ |- _ => k h end.

(*|

The following hint allows `eauto with jt` to apply the above typing rules.

|*)

Global Hint Constructors jt : jt.

Require Import FunctionalExtensionality.

Lemma empty_is_complete:
forall t T Gamma,
  jt Gamma t T ->
  forall k,
  (forall Gamma', (forall i, i < k  -> Gamma' i = Gamma i) -> jt Gamma' t T) ->
  fv k t.
Proof. (*| Let's start the proof. |*)
  introv Hjt.
  induction Hjt.
  * introv Hsame; fv.
    (*| Case JtVar. Either x < k or x >= k. In the first case, we are ok. In the second one, we build Gamma' as (fun i => if i <? k then Gamma i else U) where U is an element such that U <> T. |*)
    destruct reflect_lt_ltb with x k.
    - eauto.
    - false.
      forwards [U HU]: exists_diff T.
      eapply HU.
      eapply jt_determ with (fun i => if i <? k then Gamma i else U) x.
      + eapply Hsame.
        { intros.
          replace (i <? k) with true; eauto.
            { symmetry. destruct Nat.ltb_lt with i k. eauto. }
        }
      + econstructor.
        replace (x <? k) with false; eauto.
          { symmetry. eapply Nat.ltb_nlt. eauto. }
  * (*| Case JtLam. By induction hypothesis, it suffice to prove |*)
    introv Hsame; fv.
    eapply IHHjt; intros.
    assert (
      exists Gamma'', T.: Gamma'' = Gamma' ).
    { exists (fun x => Gamma' (S x)).
      eapply functional_extensionality; intros.
      induction x.
      - rewrite H; simpl; eauto with lia.
      - now simpl.
    } unpack; replace Gamma' with (T .: Gamma'') in *; clear Gamma'; rename Gamma'' into Gamma'; clear H0.

    forwards: Hsame Gamma'.
    { intros. eapply (H (S i)). lia. }
    now match goal with h: jt _ _ _ |- _ => inverts h end.

  * (*| Case JtApp |*)
    introv Hsame; fv.
    split.
    - eapply IHHjt1; intros.
      forwards tmp: Hsame Gamma' ; eauto. inverts tmp.
      admit. (* ??? *)
    - eapply IHHjt2; intros.
      forwards tmp: Hsame Gamma'; eauto; inverts tmp.

      admit.

      (* eapply H1.
      eapply jt_determ.
      eapply Hsame.

      eapply jt_determ. *)

    (* eapply (H0 (fun i => if i <=? k then Gamma i else U)).  *)
  * set (Gamma' := (fun x: nat => TyFun T T)).
    admit.
    (*
    assert (T = TyFun T T).
    {
      eapply jt_determ.
      eapply (H Gamma').
      econstructor.
      subst Gamma'.
      eauto.
    }
    false.
    admit. (* with a size on types *) *)
  *
Admitted.


Require Import Coq.Lists.List.
Require Import Coq.omega.Omega.

Fixpoint delete_nth {A} (n: nat) (xs: list A) {struct n} : list A :=
 match n, xs with
 | O, y::ys => ys
 | S n', y::ys =>y :: delete_nth n' ys
 | _ , _ => nil
 end.

Inductive find_nth_preds_rec {A: Type} (pred: A -> Prop): nat -> list A -> option (nat * A) -> Prop :=
| find_nth_preds_rec_cons_head: forall n R0 R, pred R0 -> find_nth_preds_rec pred n (R0 :: R) (Some (n, R0))
| find_nth_preds_rec_cons_tail: forall n R0 R R_res, find_nth_preds_rec pred (S n) R R_res -> find_nth_preds_rec pred n (R0 :: R) R_res
| find_nth_preds_rec_nil: forall n, find_nth_preds_rec pred n nil None.

Local Unset Elimination Schemes. (* ensure that we avoid name collision with the above *)
Inductive find_nth_preds {A: Type} (pred: A -> Prop): list A -> option (nat * A) -> Prop :=
| find_nth_preds_constr: forall R R_res, find_nth_preds_rec pred 0 R R_res -> find_nth_preds pred R R_res.
Scheme Minimality for find_nth_preds Sort Prop.
Local Set Elimination Schemes.

Lemma find_nth_preds_Some: forall {A: Type} (pred: A -> Prop) R n R0, find_nth_preds pred R (Some (n, R0)) ->
  nth_error R n = Some R0 /\ pred R0.
Proof.
  intros.
  inversion H; subst; clear H.
  replace n with (n - 0)%nat by omega.
  assert ((n >= 0)%nat /\ nth_error R (n - 0) = Some R0 /\ pred R0); [| tauto].
  revert H0; generalize 0%nat as m; intros.
  remember (Some (n, R0)) as R_res eqn:?H in H0.
  induction H0.
  + inversion H; subst; clear H.
    replace (n - n)%nat with 0%nat by omega.
    simpl; auto.
  + apply IHfind_nth_preds_rec in H.
    destruct H as [? [? ?]].
    replace (n - n0)%nat with (S (n - S n0)) by omega.
    split; [omega |].
    simpl; auto.
  + inversion H.
Qed.

(* Current not used. *)
Lemma find_nth_preds_rec_S: forall {A: Type} (pred: A -> Prop) z R n Rn,
  find_nth_preds_rec pred z R (Some (n, Rn)) ->
  find_nth_preds_rec pred (S z) R (Some (S n, Rn)).
Proof.
  intros.
  remember (Some (n, Rn)) as Res eqn:?H.
  revert n Rn H0; induction H; intros.
  + inversion H0; subst; clear H0.
    eapply find_nth_preds_rec_cons_head; eauto.
  + subst R_res.
    apply find_nth_preds_rec_cons_tail; auto.
  + inversion H0.
Qed.

(* Current not used. *)
Lemma find_nth_preds_rec_delete_nth: forall {A: Type} (pred: A -> Prop) z m R Rn,
  (exists n, find_nth_preds_rec pred z (delete_nth m R) (Some (n, Rn))) ->
  (exists n, find_nth_preds_rec pred z R (Some (n, Rn))).
Proof.
  intros.
  revert z R H; induction m; intros; destruct R; auto.
  + simpl in *.
    destruct H as [n ?].
    eexists.
    eapply find_nth_preds_rec_cons_tail.
    apply find_nth_preds_rec_S.
    exact H.
  + simpl in *.
    destruct H as [n ?].
    inversion H; subst; clear H.
    - eexists; apply find_nth_preds_rec_cons_head; auto.
    - specialize (IHm (S z) _ (ex_intro _ _ H4)).
      clear n H4; destruct IHm as [n ?].
      exists n.
      apply find_nth_preds_rec_cons_tail; auto.
Qed.

(* Current not used. *)
Lemma find_nth_preds_delete_nth: forall {A: Type} (pred: A -> Prop) m R Rn,
  (exists n, find_nth_preds pred (delete_nth m R) (Some (n, Rn))) ->
  (exists n, find_nth_preds pred R (Some (n, Rn))).
Proof.
  intros ? ? ? ? ? [n ?].
  inversion H; subst; clear H.
  pose proof (ex_intro _ n H0): exists n, find_nth_preds_rec pred 0 (delete_nth m R) (Some (n, Rn)).
  apply find_nth_preds_rec_delete_nth in H.
  clear n H0.
  destruct H as [n ?].
  exists n.
  apply find_nth_preds_constr; auto.
Qed.

Ltac find_nth_rec tac :=
  first [ simple eapply find_nth_preds_rec_cons_head; tac
        | simple eapply find_nth_preds_rec_cons_tail; find_nth_rec tac
        | simple eapply find_nth_preds_rec_nil].

Ltac find_nth tac :=
  eapply find_nth_preds_constr; find_nth_rec tac.
(* The reason to use "eapply" instead of "simple eapply" is because "find_nth" may be buried in definitions. *)


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Require Import Arith.
From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint less (less_arg0 : natural) (less_arg1 : natural) : bool
           := match less_arg0, less_arg1 with
              | x, Zero => false
              | Zero, Succ x => true
              | Succ x, Succ y => less x y
              end.

Fixpoint eqb (n m: natural) : bool :=
  match n, m with
    | Zero, Zero => true
    | Zero, Succ _ => false
    | Succ _, Zero => false
    | Succ n', Succ m' => eqb n' m'
  end.

Fixpoint count  (count_arg1 : lst) (count_arg0 : natural): natural
           := match  count_arg1,count_arg0 with
              | Nil, x => Zero
              | Cons y z, x => if eqb x y then Succ (count z x) else count z x
              end.

              Fixpoint insort  (insort_arg1 : lst) (insort_arg0 : natural) : lst
              := match insort_arg1, insort_arg0 with
                 |  Nil, i => Cons i Nil
                 | Cons x y, i => if less i x then Cons i (Cons x y) else Cons x (insort y i)
                 end.

                 Fixpoint sort (sort_arg0 : lst) : lst
                 := match sort_arg0 with
                    | Nil => Nil
                    | Cons x y => insort (sort y) x
                    end.

Theorem eqb_refl: forall n, eqb n n = true.
Proof.
   induction n; simpl.
   { assumption. }
   { reflexivity. }
Qed.

Theorem eqb_diff: forall (x y: natural), x <> y -> eqb x y = false.
Proof.
   induction x; induction y; simpl.
   {
   intros.
   apply IHx.
   intro.
   subst.
   assert (Succ y = Succ y). reflexivity.
   apply H in H0.
   destruct H0.
   }
   {
   intros. reflexivity.
   }
   {
   intros. reflexivity.
   }
   {
   intros.
   assert (Zero = Zero). reflexivity.
   apply H in H0.
   destruct H0.
   }
Qed.

Theorem eqb_elim: forall (x y: natural), Bool.Is_true (eqb x y) -> x = y.
Proof.
   induction x; induction y; simpl in *.
   intros.
   {
   apply IHx in H.
   subst.
   reflexivity.
   }
   {
   intros.
   destruct H.
   }
   { intros; destruct H. }
   {
   intros. reflexivity.
   }
Qed.

Theorem count_cons: forall (x: natural) (l: lst), count (Cons x l) x = Succ (count l x).
Proof.
   intros.
   simpl.
   rewrite eqb_refl.
   reflexivity.
Qed.

Theorem count_insort: forall (x: natural) (l: lst), count (insort l x) x= Succ (count l x).
Proof.
   intros.
   induction l.
   {
   simpl in *.
   destruct (less x n).
   {
      rewrite count_cons.
      f_equal.
   }
   {
      destruct (eqb x n) eqn:E.
      {
         apply Bool.Is_true_eq_left in E.
         apply eqb_elim in E.
         rewrite E in *.
         rewrite count_cons.
         rewrite IHl.
         reflexivity.
      }
      {
         simpl.
         rewrite E.
         assumption.
      }
   }
   }
   {
   simpl.
   rewrite eqb_refl.
   reflexivity.
   }
Qed.

Theorem count_cons_diff: forall (x y: natural) (l: lst), x <> y -> count (Cons y l) x= count l x.
Proof.
   intros. simpl.
   apply eqb_diff in H.
   rewrite H.
   reflexivity.
Qed.

Theorem count_insort_diff: forall (x y: natural) (l: lst), x <> y -> count (insort l y) x= count l x.
Proof.
   intros.
   induction l.
   {
   simpl.
   destruct (less y n) eqn:El; destruct (eqb x n) eqn:Ee.
   {
      simpl.
      apply eqb_diff in H. rewrite H.
      rewrite Ee.
      reflexivity.
   }
   {
      rewrite count_cons_diff.
      { simpl. rewrite Ee. reflexivity. }
      { assumption. }
   }
   {
      simpl. rewrite Ee. f_equal.
      assumption.
   }
   {
      simpl. rewrite Ee. assumption.
   }
   }
   {
   simpl.
   apply eqb_diff in H.
   rewrite H.
   reflexivity.
   }
Qed.

Theorem theorem0 : forall (x : natural) (y : lst), eq (count (sort y) x) (count y x).
Proof.
   intros.
   induction y.
   {
   simpl.
   destruct (eqb x n) eqn:E.
   {
      apply Bool.Is_true_eq_left in E.
      apply eqb_elim in E.
      subst.
      rewrite count_insort.
      f_equal. assumption.
   }
   {
      simpl.
      rewrite count_insort_diff.
      assumption.
      intro.
      rewrite H in E.
      lfind. Admitted.


Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Classes.Morphisms.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Pow2.
Require Import Crypto.Util.ZUtil.Log2.
Require Import Crypto.Util.ZUtil.Tactics.PeelLe.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.ReplaceNegWithPos.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Tactics.RewriteModSmall.
Require Import Crypto.Util.ZUtil.Tactics.LinearSubstitute.
Require Import Crypto.Util.ZUtil.Tactics.SplitMinMax.
Require Import Crypto.Util.ZUtil.Modulo.PullPush.
Require Import Crypto.Util.ZUtil.LandLorShiftBounds.
Require Import Crypto.Util.ZUtil.Modulo.
Require Import Crypto.Util.ZUtil.Ones.
Require Import Crypto.Util.ZUtil.Lnot.
Require Import Crypto.Util.ZUtil.Land.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.
Local Open Scope Z_scope.

Module Z.
  Lemma round_lor_land_bound_bounds x
  : (0 <= x <= Z.round_lor_land_bound x) \/ (Z.round_lor_land_bound x <= x <= -1).
  Proof.
    cbv [Z.round_lor_land_bound]; break_innermost_match; Z.ltb_to_lt.
    all: constructor; split; try lia; [].
    all: Z.replace_all_neg_with_pos.
    all: match goal with |- context[2^Z.log2_up ?x] => pose proof (Z.log2_up_le_full x) end.
    all: lia.
  Qed.
  Hint Resolve round_lor_land_bound_bounds : zarith.

  Lemma round_lor_land_bound_bounds_pos x
  : (0 <= Z.pos x <= Z.round_lor_land_bound (Z.pos x)).
  Proof. generalize (round_lor_land_bound_bounds (Z.pos x)); lia. Qed.
  Hint Resolve round_lor_land_bound_bounds_pos : zarith.

  Lemma round_lor_land_bound_bounds_neg x
  : Z.round_lor_land_bound (Z.neg x) <= Z.neg x <= -1.
  Proof. generalize (round_lor_land_bound_bounds (Z.neg x)); lia. Qed.
  Hint Resolve round_lor_land_bound_bounds_neg : zarith.

  Local Ltac saturate :=
    repeat first [ progress cbv [Z.round_lor_land_bound Proper respectful Basics.flip] in *
                 | progress Z.ltb_to_lt
                 | progress intros
                 | break_innermost_match_step
                 | lia
                 | rewrite !Pos2Z.opp_neg
                 | match goal with
                   | [ |- context[Z.log2_up ?x] ]
                     => unique pose proof (Z.log2_up_nonneg x)
                   | [ |- context[2^?x] ]
                     => unique assert (0 <= 2^x) by (apply Z.pow_nonneg; lia)
                   | [ H : 0 <= ?x |- context[2^?x] ]
                     => unique assert (0 < 2^x) by (apply Z.pow_pos_nonneg; lia)
                   | [ H : Pos.le ?x ?y |- context[Z.pos ?x] ]
                     => unique assert (Z.pos x <= Z.pos y) by lia
                   | [ H : Pos.le ?x ?y |- context[Z.pos (?x+1)] ]
                     => unique assert (Z.pos (x+1) <= Z.pos (y+1)) by lia
                   | [ H : Z.le ?x ?y |- context[?x+1] ]
                     => unique assert (x+1 <= y+1) by lia
                   | [ H : Z.le ?x ?y |- context[2^Z.log2_up ?x] ]
                     => unique assert (2^Z.log2_up x <= 2^Z.log2_up y) by (Z.peel_le; lia)
                   | [ H : ?a^?b <= ?a^?c |- _ ]
                     => unique assert (a^(c-b) = a^c/a^b) by auto with zarith;
                       unique assert (a^c mod a^b = 0) by auto with zarith
                   end ].
  Local Ltac do_rewrites_step :=
    match goal with
    | [ |- ?R ?x ?x ] => reflexivity
    (*| [ |- context[Z.land (-2^_) (-2^_)] ]
      => rewrite <- !Z.lnot_ones_equiv, <- !Z.lnot_lor, !Z.lor_ones_ones, !Z.lnot_ones_equiv
    | [ |- context[Z.lor (-2^_) (-2^_)] ]
      => rewrite <- !Z.lnot_ones_equiv, <- !Z.lnot_land, !Z.land_ones_ones, !Z.lnot_ones_equiv
    | [ |- context[Z.land (2^_-1) (2^_-1)] ]
      => rewrite !Z.sub_1_r, <- !Z.ones_equiv, !Z.land_ones_ones, !Z.ones_equiv, <- !Z.sub_1_r
    | [ |- context[Z.lor (2^_-1) (2^_-1)] ]
      => rewrite !Z.sub_1_r, <- !Z.ones_equiv, !Z.lor_ones_ones, !Z.ones_equiv, <- !Z.sub_1_r
    | [ |- context[Z.land (2^?x-1) (-2^?y)] ]
      => rewrite (@Z.land_comm (2^x-1) (-2^y))
    | [ |- context[Z.lor (2^?x-1) (-2^?y)] ]
      => rewrite (@Z.lor_comm (2^x-1) (-2^y))
    | [ |- context[Z.land (-2^_) (2^_-1)] ]
      => rewrite !Z.sub_1_r, <- !Z.ones_equiv, !Z.land_ones, ?Z.ones_equiv, <- ?Z.sub_1_r by lia
    | [ |- context[Z.lor (-2^?x) (2^?y-1)] ]
      => rewrite <- !Z.lnot_ones_equiv, <- (Z.lnot_involutive (2^y-1)), <- !Z.lnot_land, ?Z.lnot_ones_equiv, (Z.lnot_sub1 (2^y)), !Z.ones_equiv, ?Z.lnot_equiv, <- !Z.sub_1_r
    | [ |- context[-?x mod ?y] ]
      => rewrite (@Z.opp_mod_mod_push x y) by Z.NoZMod*)
    | [ |- context[Z.land (2^?y-1) ?x] ]
      => is_var x; rewrite (Z.land_comm (2^y-1) x)
    | [ |- context[Z.lor (2^?y-1) ?x] ]
      => is_var x; rewrite (Z.lor_comm (2^y-1) x)
    | [ |- context[Z.land (-2^?y) ?x] ]
      => is_var x; rewrite (Z.land_comm (-2^y) x)
    | [ |- context[Z.lor (-2^?y) ?x] ]
      => is_var x; rewrite (Z.lor_comm (-2^y) x)
    | [ |- context[Z.land _ (2^_-1)] ]
      => rewrite !Z.sub_1_r, <- !Z.ones_equiv, !Z.land_ones by auto with zarith
    | [ |- context[Z.land ?x (-2^?y)] ]
      => is_var x;
        rewrite <- !Z.lnot_ones_equiv, <- (Z.lnot_involutive x), <- !Z.lnot_lor, !Z.ones_equiv, !Z.lnot_equiv, <- !Z.sub_1_r;
        let x' := fresh in
        remember (-x-1) as x' eqn:?; Z.linear_substitute x;
        rename x' into x
    | [ |- context[Z.lor ?x (-2^?y)] ]
      => is_var x;
        rewrite <- !Z.lnot_ones_equiv, <- (Z.lnot_involutive x), <- !Z.lnot_land, !Z.ones_equiv, !Z.lnot_equiv, <- !Z.sub_1_r;
        let x' := fresh in
        remember (-x-1) as x' eqn:?; Z.linear_substitute x;
        rename x' into x
    | [ |- Z.lor ?x (?y-1) <= Z.lor ?x (?y'-1) ]
      => rewrite (Z.div_mod'' (Z.lor x (y-1)) y), (Z.div_mod'' (Z.lor x (y'-1)) y') by auto with zarith
    | [ |- Z.lor ?x (?y-1) = _ ]
      => rewrite (Z.div_mod'' (Z.lor x (y-1)) y) by auto with zarith
    | [ |- context[?m1 - 1 + (?x - ?x mod ?m1)] ]
      => replace (m1 - 1 + (x - x mod m1)) with ((m1 - x mod m1) + (x - 1)) by lia
    | _ => progress rewrite ?Z.lor_pow2_div_pow2_r, ?Z.lor_pow2_div_pow2_l, ?Z.lor_pow2_mod_pow2_r, ?Z.lor_pow2_mod_pow2_l by auto with zarith
    | _ => rewrite !Z.mul_div_eq by lia
    | _ => progress rewrite ?(Z.add_comm 1) in *
    | [ |- context[?x mod 2^(Z.log2_up (?x + 1))] ]
      => rewrite (Z.mod_small x (2^Z.log2_up (x+1))) by (rewrite <- Z.le_succ_l, <- Z.add_1_r, Z.log2_up_le_pow2 by lia; lia)
    | [ H : ?a^?b <= ?a^?c |- context[?x mod ?a^?b] ]
      => rewrite (@Z.mod_pow_r_split x a b c) by auto with zarith;
        (Z.div_mod_to_quot_rem; nia)
    | _ => progress Z.peel_le
    (*| [ H : ?x <= ?x |- _ ] => clear H
    | [ H : ?x < ?y, H' : ?y <= ?z |- _ ] => unique assert (x < z) by lia
    | [ H : ?x < ?y, H' : ?a <= ?x |- _ ] => unique assert (a < y) by lia
    | [ H : 2^?x < 2^?y |- context[2^?x mod 2^?y] ]
      => repeat first [ rewrite (Z.mod_small (2^x) (2^y)) by lia
                      | rewrite !(@Z_mod_nz_opp_full (2^x) (2^y)) ]
    | [ H : ?x < ?y, H' : context[?x mod ?y] |- _ ] => rewrite (Z.mod_small x y) in H' by lia
    | [ |- context[2^?x mod 2^?y] ]
      => let H := fresh in
         destruct (@Z.pow2_lt_or_divides x y ltac:(lia)) as [H|H];
         [ repeat first [ rewrite (Z.mod_small (2^x) (2^y)) by lia
                        | rewrite !(@Z_mod_nz_opp_full (2^x) (2^y)) ]
         | rewrite H ]*)
    | _ => progress autorewrite with zsimplify_fast in *
    | [ |- context[-(-?x-1)] ] => replace (-(-x-1)) with (1+x) by lia
    | [ H : 0 > -(1+?x) |- _ ] => assert (0 <= x) by (clear -H; lia); clear H
    | [ H : 0 > -(?x+1) |- _ ] => assert (0 <= x) by (clear -H; lia); clear H
    | [ |- ?a - ?b = ?a' - ?b' ] => apply f_equal2; try reflexivity; []
    | [ |- -?a = -?a' ] => apply f_equal
    | _ => rewrite <- !Z.sub_1_r
    | _ => lia
    end.
  Local Ltac do_rewrites := repeat do_rewrites_step.
  Local Ltac fin_t :=
    repeat first [ progress destruct_head'_and
                 | match goal with
                   | [ H : orb _ _ = _ |- _ ]
                     => progress rewrite ?Bool.orb_true_iff, ?Bool.orb_false_iff, ?Z.ltb_lt, ?Z.ltb_ge in *
                   end
                 | break_innermost_match_step
                 | progress destruct_head'_or
                 | lia
                 | progress Z.peel_le ].
  Local Ltac t :=
    saturate; do_rewrites.

  Local Instance land_round_Proper_pos_r x
    : Proper (Pos.le ==> Z.le) (fun y => Z.land x (Z.round_lor_land_bound (Z.pos y))).
  Proof. t. Qed.

  Local Instance land_round_Proper_pos_l y
    : Proper (Pos.le ==> Z.le) (fun x => Z.land (Z.round_lor_land_bound (Z.pos x)) y).
  Proof. t. Qed.

  Local Instance lor_round_Proper_pos_r x
    : Proper (Pos.le ==> Z.le) (fun y => Z.lor x (Z.round_lor_land_bound (Z.pos y))).
  Proof. t. Qed.

  Local Instance lor_round_Proper_pos_l y
    : Proper (Pos.le ==> Z.le) (fun x => Z.lor (Z.round_lor_land_bound (Z.pos x)) y).
  Proof. t. Qed.

  Local Instance land_round_Proper_neg_r x
    : Proper (Basics.flip Pos.le ==> Z.le) (fun y => Z.land x (Z.round_lor_land_bound (Z.neg y))).
  Proof. t. Qed.

  Local Instance land_round_Proper_neg_l y
    : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.land (Z.round_lor_land_bound (Z.neg x)) y).
  Proof. t. Qed.

  Local Instance lor_round_Proper_neg_r x
    : Proper (Basics.flip Pos.le ==> Z.le) (fun y => Z.lor x (Z.round_lor_land_bound (Z.neg y))).
  Proof. t. Qed.

  Local Instance lor_round_Proper_neg_l y
    : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.lor (Z.round_lor_land_bound (Z.neg x)) y).
  Proof. t. Qed.

  Lemma land_round_lor_land_bound_r x
    : Z.land x (Z.round_lor_land_bound x) = if (0 <=? x) then x else Z.round_lor_land_bound x.
  Proof. t. Qed.
  Hint Rewrite land_round_lor_land_bound_r : zsimplify_fast zsimplify.
  Lemma land_round_lor_land_bound_l x
    : Z.land (Z.round_lor_land_bound x) x = if (0 <=? x) then x else Z.round_lor_land_bound x.
  Proof. rewrite Z.land_comm, land_round_lor_land_bound_r; reflexivity. Qed.
  Hint Rewrite land_round_lor_land_bound_l : zsimplify_fast zsimplify.

  Lemma lor_round_lor_land_bound_r x
    : Z.lor x (Z.round_lor_land_bound x) = if (0 <=? x) then Z.round_lor_land_bound x else x.
  Proof. t. Qed.
  Hint Rewrite lor_round_lor_land_bound_r : zsimplify_fast zsimplify.
  Lemma lor_round_lor_land_bound_l x
    : Z.lor (Z.round_lor_land_bound x) x = if (0 <=? x) then Z.round_lor_land_bound x else x.
  Proof. rewrite Z.lor_comm, lor_round_lor_land_bound_r; reflexivity. Qed.
  Hint Rewrite lor_round_lor_land_bound_l : zsimplify_fast zsimplify.

  Lemma land_round_bound_pos_r v x
    : 0 <= Z.land v (Z.pos x) <= Z.land v (Z.round_lor_land_bound (Z.pos x)).
  Proof.
    rewrite Z.land_nonneg; split; [ lia | ].
    replace (Z.pos x) with (Z.land (Z.pos x) (Z.round_lor_land_bound (Z.pos x))) at 1
      by now rewrite land_round_lor_land_bound_r.
    rewrite (Z.land_comm (Z.pos x)), Z.land_assoc.
    apply Z.land_upper_bound_l; rewrite ?Z.land_nonneg; t.
  Qed.
  Hint Resolve land_round_bound_pos_r (fun v x => proj1 (land_round_bound_pos_r v x)) (fun v x => proj2 (land_round_bound_pos_r v x)) : zarith.
  Lemma land_round_bound_pos_l v x
    : 0 <= Z.land (Z.pos x) v <= Z.land (Z.round_lor_land_bound (Z.pos x)) v.
  Proof. rewrite <- !(Z.land_comm v); apply land_round_bound_pos_r. Qed.
  Hint Resolve land_round_bound_pos_l (fun v x => proj1 (land_round_bound_pos_l v x)) (fun v x => proj2 (land_round_bound_pos_l v x)) : zarith.

  Lemma land_round_bound_neg_r v x
    : Z.land v (Z.round_lor_land_bound (Z.neg x)) <= Z.land v (Z.neg x) <= v.
  Proof.
    assert (0 < 2 ^ Z.log2_up (Z.pos x)) by auto with zarith.
    split; [ | apply Z.land_le; lia ].
    replace (Z.round_lor_land_bound (Z.neg x)) with (Z.land (Z.neg x) (Z.round_lor_land_bound (Z.neg x)))
      by now rewrite land_round_lor_land_bound_r.
    rewrite !Z.land_assoc.
    etransitivity; [ apply Z.land_le; cbn; lia | ]; lia.
  Qed.
  Hint Resolve land_round_bound_neg_r (fun v x => proj1 (land_round_bound_neg_r v x)) (fun v x => proj2 (land_round_bound_neg_r v x)) : zarith.
  Lemma land_round_bound_neg_l v x
    : Z.land (Z.round_lor_land_bound (Z.neg x)) v <= Z.land (Z.neg x) v <= v.
  Proof. rewrite <- !(Z.land_comm v); apply land_round_bound_neg_r. Qed.
  Hint Resolve land_round_bound_neg_l (fun v x => proj1 (land_round_bound_neg_l v x)) (fun v x => proj2 (land_round_bound_neg_l v x)) : zarith.

  Lemma lor_round_bound_neg_r v x
    : Z.lor v (Z.round_lor_land_bound (Z.neg x)) <= Z.lor v (Z.neg x) <= -1.
  Proof.
    change (-1) with (Z.pred 0); rewrite <- Z.lt_le_pred.
    rewrite Z.lor_neg; split; [ | lia ].
    replace (Z.neg x) with (Z.lor (Z.neg x) (Z.round_lor_land_bound (Z.neg x))) at 2
      by now rewrite lor_round_lor_land_bound_r.
    rewrite (Z.lor_comm (Z.neg x)), Z.lor_assoc.
    cbn; rewrite <- !Z.lnot_ones_equiv, <- (Z.lnot_involutive v), <- (Z.lnot_involutive (Z.neg x)), <- !Z.lnot_land, !Z.ones_equiv, !Z.lnot_equiv, <- !Z.sub_1_r, !Pos2Z.opp_neg.
    Z.peel_le.
    apply Z.land_upper_bound_l; rewrite ?Z.land_nonneg; t.
  Qed.
  Hint Resolve lor_round_bound_neg_r (fun v x => proj1 (lor_round_bound_neg_r v x)) (fun v x => proj2 (lor_round_bound_neg_r v x)) : zarith.
  Lemma lor_round_bound_neg_l v x
    : Z.lor (Z.round_lor_land_bound (Z.neg x)) v <= Z.lor (Z.neg x) v <= -1.
  Proof. rewrite <- !(Z.lor_comm v); apply lor_round_bound_neg_r. Qed.
  Hint Resolve lor_round_bound_neg_l (fun v x => proj1 (lor_round_bound_neg_l v x)) (fun v x => proj2 (lor_round_bound_neg_l v x)) : zarith.

  Lemma lor_round_bound_pos_r v x
    : v <= Z.lor v (Z.pos x) <= Z.lor v (Z.round_lor_land_bound (Z.pos x)).
  Proof.
    assert (0 < 2 ^ Z.log2_up (Z.pos (x + 1))) by auto with zarith.
    split; [ apply Z.lor_lower; lia | ].
    replace (Z.round_lor_land_bound (Z.pos x)) with (Z.lor (Z.pos x) (Z.round_lor_land_bound (Z.pos x)))
      by now rewrite lor_round_lor_land_bound_r.
    rewrite !Z.lor_assoc.
    etransitivity; [ | apply Z.lor_lower; rewrite ?Z.lor_nonneg; cbn; lia ]; lia.
  Qed.
  Hint Resolve lor_round_bound_pos_r (fun v x => proj1 (lor_round_bound_pos_r v x)) (fun v x => proj2 (lor_round_bound_pos_r v x)) : zarith.
  Lemma lor_round_bound_pos_l v x
    : v <= Z.lor (Z.pos x) v <= Z.lor (Z.round_lor_land_bound (Z.pos x)) v.
  Proof. rewrite <- !(Z.lor_comm v); apply lor_round_bound_pos_r. Qed.
  Hint Resolve lor_round_bound_pos_l (fun v x => proj1 (lor_round_bound_pos_l v x)) (fun v x => proj2 (lor_round_bound_pos_l v x)) : zarith.

  Lemma land_round_bound_pos_r' v x : Z.land v (Z.pos x) <= Z.land v (Z.round_lor_land_bound (Z.pos x)). Proof. auto with zarith. Qed.
  Lemma land_round_bound_pos_l' v x : Z.land (Z.pos x) v <= Z.land (Z.round_lor_land_bound (Z.pos x)) v. Proof. auto with zarith. Qed.
  Lemma land_round_bound_neg_r' v x : Z.land v (Z.round_lor_land_bound (Z.neg x)) <= Z.land v (Z.neg x). Proof. auto with zarith. Qed.
  Lemma land_round_bound_neg_l' v x : Z.land (Z.round_lor_land_bound (Z.neg x)) v <= Z.land (Z.neg x) v. Proof. auto with zarith. Qed.
  Lemma lor_round_bound_neg_r' v x : Z.lor v (Z.round_lor_land_bound (Z.neg x)) <= Z.lor v (Z.neg x). Proof. auto with zarith. Qed.
  Lemma lor_round_bound_neg_l' v x : Z.lor (Z.round_lor_land_bound (Z.neg x)) v <= Z.lor (Z.neg x) v. Proof. auto with zarith. Qed.
  Lemma lor_round_bound_pos_r' v x : Z.lor v (Z.pos x) <= Z.lor v (Z.round_lor_land_bound (Z.pos x)). Proof. auto with zarith. Qed.
  Lemma lor_round_bound_pos_l' v x : Z.lor (Z.pos x) v <= Z.lor (Z.round_lor_land_bound (Z.pos x)) v. Proof. auto with zarith. Qed.
End Z.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) : natural := Succ y.


Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import riscv.Utility.
Require Import riscv.util.Monads.
Require Import riscv.Memory.
Import ListNotations.
Local Open Scope Z_scope.

Section Memory.

  Definition mem := list (word 8).
  Definition mem_size(m: mem): Z := Zlength m.

  Definition read_byte(m: mem)(a: Z): word 8 := Znth m a (ZToWord _ 0).

  Definition write_byte'(m: mem)(a: Z)(v: word 8): mem :=
    (Zfirstn a m) ++ [v] ++ (Zskipn (a + 1) m).

  (* fix for the case when a is out of bounds to make sure length is always preserved:
     allows for _preserves_mem_size lemmas with no hypotheses, and ensures things which
     should not work because out of bounds writes-then-reads don't work *)
  Definition write_byte(m: mem)(a: Z)(v: word 8): mem :=
    firstn (length m) (write_byte' m a v).

  Definition read_half(m: mem)(a: Z): word 16 :=
    let v0 := read_byte m a in let v1 := read_byte m (a + 1) in wappend v1 v0.
  Definition read_word(m: mem)(a: Z): word 32 :=
    let v0 := read_half m a in let v1 := read_half m (a + 2) in wappend v1 v0.
  Definition read_double(m: mem)(a: Z): word 64 :=
    let v0 := read_word m a in let v1 := read_word m (a + 4) in wappend v1 v0.

  Definition write_half(m: mem)(a: Z)(v: word 16): mem :=
    let m := write_byte m a (lobits 8 v) in write_byte m (a + 1) (hibits 8 v).
  Definition write_word(m: mem)(a: Z)(v: word 32): mem :=
    let m := write_half m a (lobits 16 v) in write_half m (a + 2) (hibits 16 v).
  Definition write_double(m: mem)(a: Z)(v: word 64): mem :=
    let m := write_word m a (lobits 32 v) in write_word m (a + 4) (hibits 32 v).

  Definition const_mem(default: word 8)(size: Z): mem :=
    map_range (fun _: Z => default) size.

  Lemma const_mem_mem_size: forall default size,
      0 <= size ->
      mem_size (const_mem default size) = size.
  Proof.
    intros. unfold mem_size, const_mem. apply Zlength_map_range. assumption.
  Qed.

  Definition zero_mem: Z -> mem := const_mem (ZToWord 8 0).

End Memory.

Ltac omega' := zify; rewrite Z2Nat.id in *; omega.

Lemma write_read_byte_eq': forall m a1 a2 v,
    0 <= a1 < mem_size m ->
    a2 = a1 ->
    read_byte (write_byte' m a1 v) a2 = v.
Proof.
  intros. subst. unfold write_byte', read_byte, mem_size in *.
  unfold Zfirstn, Zskipn, Znth, Zlength in *.
  pose proof (@firstn_length_le _ m (Z.to_nat a1)).
  rewrite app_nth2 by omega'.
  rewrite H0 by omega'.
  replace (Z.to_nat a1 - Z.to_nat a1)%nat with 0%nat by omega.
  reflexivity.
Qed.

Lemma Z_bounds_to_nat_bound: forall (a: Z) (n: nat),
    0 <= a < Z.of_nat n ->
    (Z.to_nat a < n)%nat.
Proof.
  intros. omega'.
Qed.

Lemma Z_ne_to_nat_ne: forall (a b: Z),
    0 <= a ->
    0 <= b ->
    a <> b ->
    Z.to_nat a <> Z.to_nat b.
Proof.
  intros. intro. apply H1. apply Z2Nat.inj; assumption.
Qed.

Lemma write_read_byte_ne': forall m a1 a2 v,
    0 <= a1 < mem_size m ->
    0 <= a2 < mem_size m ->
    a2 <> a1 ->
    read_byte (write_byte' m a1 v) a2 = read_byte m a2.
Proof.
  intros. unfold write_byte', read_byte, mem_size in *.
  pose proof (@firstn_length_le _ m (Z.to_nat a1)).
  pose proof (@firstn_length_le _ m (Z.to_nat a2)).
  unfold Znth, Zfirstn, Zskipn, Zlength in *.
  rewrite Z2Nat.inj_add by omega.
  apply Z_ne_to_nat_ne in H1; [|omega..].
  apply Z_bounds_to_nat_bound in H.
  apply Z_bounds_to_nat_bound in H0.
  remember (Z.to_nat a1) as a1'. clear Heqa1' a1. rename a1' into a1.
  remember (Z.to_nat a2) as a2'. clear Heqa2' a2. rename a2' into a2.
  replace (a1 + Z.to_nat 1)%nat with (S a1) by omega'.
  assert (a2 < a1 \/ a1 < a2 < length m)%nat as P by omega.
  destruct P as [P | P].
  - rewrite app_nth1 by omega.
    clear H2 H3.
    generalize dependent m. generalize dependent a1.
    induction a2; intros.
    + destruct a1; [omega|simpl]. destruct m; reflexivity.
    + destruct a1; [omega|simpl]. destruct m.
      * simpl in H; omega.
      * simpl in *. apply IHa2; omega.
  - rewrite app_nth2 by omega.
    rewrite app_nth2 by (simpl; omega).
    rewrite H2 by omega.
    replace (a2 - a1 - length [v])%nat with (a2 - (S a1))%nat by (simpl; omega).
    clear H2 H3.
    generalize dependent m. generalize dependent a1.
    induction a2; intros.
    + omega.
    + replace (S a2 - S a1)%nat with (a2 - a1)%nat by omega.
      destruct a1.
      * replace (a2 - 0)%nat with a2 by omega. destruct m; [simpl in *; omega|reflexivity].
      * destruct m; [simpl in *; omega|].
        change (skipn (S (S a1)) (w :: m)) with (skipn (S a1) m).
        change (nth (S a2) (w :: m)) with (nth a2 m).
        apply IHa2; simpl in *; try omega.
Qed.

Lemma skipn_length_le: forall A n (l: list A),
    (n <= length l)%nat ->
    length (skipn n l) = (length l - n)%nat.
Proof.
  induction n; intros.
  - simpl. omega.
  - simpl. destruct l; [simpl in *; omega|].
    simpl in *.
    apply IHn; omega.
Qed.

Lemma write_byte_preserves_mem_size': forall m a v,
    0 <= a < mem_size m ->
    mem_size (write_byte' m a v) = mem_size m.
Proof.
  intros. unfold mem_size, write_byte' in *.
  unfold Zlength, Zfirstn, Zskipn in *.
  repeat rewrite app_length.
  rewrite firstn_length_le by omega'.
  rewrite skipn_length_le by omega'.
  simpl.
  omega'.
Qed.

Lemma firstn_all_write_byte': forall m a1 v,
    0 <= a1 < mem_size m ->
    firstn (length m) (write_byte' m a1 v) = write_byte' m a1 v.
Proof.
  intros.
  replace (length m) with (length (write_byte' m a1 v)).
  - rewrite firstn_all. reflexivity.
  - pose proof (write_byte_preserves_mem_size' m a1 v H) as P.
    unfold mem_size, Zlength in *.
    apply Nat2Z.inj in P.
    assumption.
Qed.

Lemma write_read_byte_eq: forall m a1 a2 v,
    0 <= a1 < mem_size m ->
    a2 = a1 ->
    read_byte (write_byte m a1 v) a2 = v.
Proof.
  intros. unfold write_byte in *.
  erewrite <- write_read_byte_eq' by eassumption.
  rewrite firstn_all_write_byte' by assumption.
  reflexivity.
Qed.

Lemma write_read_byte_ne: forall m a1 a2 v,
    0 <= a1 < mem_size m ->
    0 <= a2 < mem_size m ->
    a2 <> a1 ->
    read_byte (write_byte m a1 v) a2 = read_byte m a2.
Proof.
  intros. unfold write_byte in *.
  rewrite <- (write_read_byte_ne' m a1 a2 v);
    rewrite? firstn_all_write_byte' by assumption;
    rewrite? write_byte_preserves_mem_size' by assumption;
    [reflexivity | eassumption ..].
Qed.

Lemma Z2Nat_nonpos: forall (a: Z),
    a <= 0 ->
    Z.to_nat a = 0%nat.
Proof.
  intros.
  destruct a.
  - reflexivity.
  - lia.
  - apply Z2Nat.inj_neg.
Qed.

Lemma write_byte_preserves_mem_size: forall m a v,
    mem_size (write_byte m a v) = mem_size m.
Proof.
  intros. unfold write_byte.
  assert (a < 0 \/ 0 <= a < mem_size m \/ a >= mem_size m) as C by omega.
  destruct C as [H | [H | H]].
  - unfold write_byte', Zfirstn, Zskipn.
    rewrite! Z2Nat_nonpos by omega.
    simpl.
    unfold mem_size, Zlength in *.
    apply Znat.inj_eq.
    apply firstn_length_le.
    simpl.
    repeat constructor.
  - pose proof write_byte_preserves_mem_size' as P.
    specialize P with (1 := H).
    unfold mem_size, Zlength in *.
    rewrite <- (P v) at 1.
    rewrite firstn_all_write_byte' by assumption.
    reflexivity.
  - unfold mem_size, Zlength in *.
    apply Znat.inj_eq.
    apply firstn_length_le.
    unfold write_byte', Zfirstn, Zskipn.
    rewrite? app_length.
    rewrite firstn_length.
    omega'.
Qed.

Lemma write_read_half_eq: forall m a1 a2 v,
    0 <= a1 ->
    a1 + 1 < mem_size m ->
    a2 = a1 ->
    read_half (write_half m a1 v) a2 = v.
Proof.
  intros. subst. unfold write_half, read_half in *.
  pose proof H.
  rewrite (write_read_byte_eq _ (a1 + 1) (a1 + 1)); try reflexivity.
  - rewrite write_read_byte_ne; try omega.
    + rewrite write_read_byte_eq; try reflexivity; try omega.
      apply (wappend_split 8 8); omega.
    + rewrite write_byte_preserves_mem_size; omega.
    + rewrite write_byte_preserves_mem_size; omega.
  - rewrite write_byte_preserves_mem_size; omega.
Qed.

Lemma write_read_half_ne: forall m a1 a2 v,
    a1 + 1 < mem_size m ->
    a1 mod 2 = 0 ->
    a2 + 1 < mem_size m ->
    a2 mod 2 = 0 ->
    a2 <> a1 ->
    0 <= a1 ->
    0 <= a2 ->
    read_half (write_half m a1 v) a2 = read_half m a2.
Proof.
  intros. unfold write_half, read_half in *.
  f_equal.
  - rewrite write_read_byte_ne.
    + apply write_read_byte_ne; try omega.
      intro. subst. rewrite Z.add_mod in H0; try omega.
      rewrite H2 in H0.
      simpl in H0.
      discriminate.
    + rewrite write_byte_preserves_mem_size; omega.
    + rewrite write_byte_preserves_mem_size; omega.
    + omega.
  - rewrite write_read_byte_ne.
    + apply write_read_byte_ne; omega.
    + rewrite write_byte_preserves_mem_size; omega.
    + rewrite write_byte_preserves_mem_size; omega.
    + intro. subst. rewrite Z.add_mod in H2; try omega.
      rewrite H0 in H2.
      simpl in H2.
      discriminate.
Qed.

Lemma add_mod_r: forall a m,
    m <> 0 ->
    (a + m) mod m = a mod m.
Proof.
  intros.
  rewrite Z.add_mod by assumption.
  rewrite Z.mod_same by assumption.
  rewrite Z.add_0_r.
  apply Z.mod_mod.
  assumption.
Qed.

Lemma weaken_alignment: forall n al,
    n mod (al * 2) = 0 ->
    al <> 0 ->
    n mod al = 0.
Proof.
  intros.
  pose proof H.
  apply Z.mod_divide in H; try omega.
  destruct H as [n' H]. subst.
  replace (n' * (al * 2)) with (n' * 2 * al) by ring.
  apply Z.mod_mul.
  assumption.
Qed.

Lemma write_half_preserves_mem_size: forall m a v,
    mem_size (write_half m a v) = mem_size m.
Proof.
  intros. unfold write_half, mem_size in *.
  repeat rewrite write_byte_preserves_mem_size; unfold mem_size; omega.
Qed.

Lemma diviBy4_implies_diviBy2: forall n,
    n mod 4 = 0 ->
    n mod 2 = 0.
Proof.
  intros.
  apply weaken_alignment; [assumption | omega].
Qed.

Lemma write_read_word_eq: forall m a1 a2 v,
    a1 + 4 <= mem_size m ->
    a1 mod 4 = 0 ->
    a2 = a1 ->
    0 <= a1 ->
    read_word (write_word m a1 v) a2 = v.
Proof.
  intros. subst. unfold write_word, read_word in *.
  pose proof H.
  rewrite (write_read_half_eq _ (a1 + 2) (a1 + 2)); try reflexivity; try omega.
  - rewrite write_read_half_ne; try omega.
    + rewrite write_read_half_eq; try reflexivity; try omega.
      apply (wappend_split 16 16); omega.
    + rewrite write_half_preserves_mem_size; omega.
    + apply diviBy4_implies_diviBy2 in H0. rewrite Z.add_mod by omega.
      rewrite H0.
      reflexivity.
    + rewrite write_half_preserves_mem_size; omega.
    + apply diviBy4_implies_diviBy2. assumption.
  - rewrite write_half_preserves_mem_size; omega.
Qed.

Lemma write_read_word_ne: forall m a1 a2 v,
    a1 + 4 <= mem_size m ->
    a1 mod 4 = 0 ->
    a2 + 4 <= mem_size m ->
    a2 mod 4 = 0 ->
    a2 <> a1 ->
    0 <= a1 ->
    0 <= a2 ->
    read_word (write_word m a1 v) a2 = read_word m a2.
Proof.
  intros. unfold write_word, read_word in *.
  rename H4 into H6, H5 into H7.
  pose proof (diviBy4_implies_diviBy2 _ H0).
  pose proof (diviBy4_implies_diviBy2 _ H2).
  f_equal.
  - rewrite write_read_half_ne.
    + apply write_read_half_ne; try omega.
      * rewrite add_mod_r; omega.
      * intro. subst. rewrite Z.add_mod in H0; try omega.
        rewrite H2 in H0.
        simpl in H0.
        discriminate.
    + rewrite write_half_preserves_mem_size; omega.
    + rewrite add_mod_r; omega.
    + rewrite write_half_preserves_mem_size; omega.
    + rewrite add_mod_r; omega.
    + omega.
    + omega.
    + omega.
  - rewrite write_read_half_ne.
    + apply write_read_half_ne; omega.
    + rewrite write_half_preserves_mem_size; omega.
    + rewrite Z.add_mod by omega.
      rewrite H4.
      reflexivity.
    + rewrite write_half_preserves_mem_size; omega.
    + assumption.
    + intro. subst. rewrite Z.add_mod in H2; try omega.
      rewrite H0 in H2.
      simpl in H2.
      discriminate.
    + omega.
    + assumption.
Qed.

Lemma write_word_preserves_mem_size: forall m a v,
    mem_size (write_word m a v) = mem_size m.
Proof.
  intros. unfold write_word, mem_size in *.
  repeat rewrite write_half_preserves_mem_size; unfold mem_size; omega.
Qed.

Lemma diviBy8_implies_diviBy4: forall n,
    n mod 8 = 0 ->
    n mod 4 = 0.
Proof.
  intros.
  apply weaken_alignment; [assumption | omega].
Qed.

Lemma write_read_double_eq: forall m a1 a2 v,
    a1 + 8 <= mem_size m ->
    a1 mod 8 = 0 ->
    a2 = a1 ->
    0 <= a1 ->
    read_double (write_double m a1 v) a2 = v.
Proof.
  intros. subst. unfold write_double, read_double in *.
  pose proof H.
  rewrite (write_read_word_eq _ (a1 + 4) (a1 + 4)); try reflexivity; try omega.
  - rewrite write_read_word_ne; try omega.
    + rewrite write_read_word_eq; try reflexivity; try omega.
      * apply (wappend_split 32 32); omega.
      * apply diviBy8_implies_diviBy4. assumption.
    + rewrite write_word_preserves_mem_size; omega.
    + apply diviBy8_implies_diviBy4 in H0. rewrite Z.add_mod by omega.
      rewrite H0.
      reflexivity.
    + rewrite write_word_preserves_mem_size; omega.
    + apply diviBy8_implies_diviBy4. assumption.
  - rewrite write_word_preserves_mem_size; omega.
  - rewrite add_mod_r by omega.
    apply diviBy8_implies_diviBy4. assumption.
Qed.

Lemma write_read_double_ne: forall m a1 a2 v,
    a1 + 8 <= mem_size m ->
    a1 mod 8 = 0 ->
    a2 + 8 <= mem_size m ->
    a2 mod 8 = 0 ->
    a2 <> a1 ->
    0 <= a1 ->
    0 <= a2 ->
    read_double (write_double m a1 v) a2 = read_double m a2.
Proof.
  intros. unfold write_double, read_double in *.
  rename H4 into H6, H5 into H7.
  pose proof (diviBy8_implies_diviBy4 _ H0).
  pose proof (diviBy8_implies_diviBy4 _ H2).
  f_equal.
  - rewrite write_read_word_ne.
    + apply write_read_word_ne; try omega.
      * rewrite add_mod_r; omega.
      * intro. subst. rewrite Z.add_mod in H0; try omega.
        rewrite H2 in H0.
        simpl in H0.
        discriminate.
    + rewrite write_word_preserves_mem_size; omega.
    + rewrite add_mod_r; omega.
    + rewrite write_word_preserves_mem_size; omega.
    + rewrite add_mod_r; omega.
    + omega.
    + omega.
    + omega.
  - rewrite write_read_word_ne.
    + apply write_read_word_ne; omega.
    + rewrite write_word_preserves_mem_size; omega.
    + rewrite Z.add_mod by omega.
      rewrite H4.
      reflexivity.
    + rewrite write_word_preserves_mem_size; omega.
    + assumption.
    + intro. subst. rewrite Z.add_mod in H2; try omega.
      rewrite H0 in H2.
      simpl in H2.
      discriminate.
    + omega.
    + omega.
Qed.

Lemma write_double_preserves_mem_size: forall m a v,
    mem_size (write_double m a v) = mem_size m.
Proof.
  intros. unfold write_double, mem_size in *.
  repeat rewrite write_word_preserves_mem_size; unfold mem_size; omega.
Qed.