(*! Tactics for proofs about bit vectors !*)
Require Import Coq.micromega.Lia.
Require Export Koika.EqDec Koika.Vect Koika.Primitives Koika.PrimitiveProperties.
Import BitFuns.

(* This definition is useful for the next tactics *)
Definition bits_get_size {sz} (bs: bits sz) :=
  sz.

Ltac Bits_to_N_t :=
  unfold PrimSpecs.sigma1, CircuitPrimSpecs.sigma1,
  PrimSpecs.sigma2, CircuitPrimSpecs.sigma2,
  Bits.plus, Bits.mul in *;
  simpl arg1Sig;
  repeat match goal with
         | _ => progress bool_step
         | _ => progress (rewrite Bits.of_N_to_N in * )
         | [ H: Ob~_ = Ob~_ |- _ ] => injection H as H
         | [ H: Bits.single (Bits.neg _) = true |- _ ] =>
           apply negb_true_iff in H
         | [ H: Bits.single (Bits.neg _) = false |- _ ] =>
           apply negb_false_iff in H
         | [ H: Bits.single (Bits.and _ _) = true |- _ ] =>
           apply andb_true_iff in H; destruct H
         | [ H: Bits.single (Bits.and _ _) = false |- _ ] =>
           apply andb_false_iff in H
         | [ H: Bits.single (BitFuns._eq _ _) = true |- _ ] =>
           apply beq_dec_iff in H
         | [ H: Bits.single (BitFuns._eq _ _) = false |- _ ] =>
           apply beq_dec_false_iff in H
         | [ H: Bits.single ?bs = _ |- _ ] =>
           apply Bits.single_to_bits in H
         | _ => progress (rewrite sel_spec in * )
         | [ H: context[Bits.to_N (BitFuns.lsl ?x ?y)] |- _ ] =>
           rewrite to_N_lsl in H
         | [ |- context[Bits.to_N (BitFuns.lsl ?x ?y)] ] =>
           rewrite to_N_lsl
         | [ H: context[Bits.to_N (Bits.extend_end ?bs ?sz' false)] |- _ ] =>
           setoid_rewrite (to_N_extend_end_false (bits_get_size bs) bs sz') in H
         | [ |- context[Bits.to_N (Bits.extend_end ?bs ?sz' false)] ] =>
           setoid_rewrite (to_N_extend_end_false (bits_get_size bs) bs sz')
         | [ H: _ = _ |- _ ] =>
           apply (f_equal Bits.to_N) in H
         | [ H: _ <> _ |- _ ] =>
           apply Bits.to_N_inj_contra in H
         end.

Ltac remember_bits_to_N :=
  repeat match goal with
         | [ |- context[Bits.to_N ?bs] ] =>
           remember_once (Bits.to_N bs)
         | [ H: context[Bits.to_N ?bs] |- _ ] =>
           remember_once (Bits.to_N bs)
         end.

Ltac pose_bits_bound_proofs :=
  repeat match goal with
         | [ H: context[Bits.to_N ?bs] |- _ ] =>
           pose_once Bits.to_N_bounded bs
         | [ |- context[Bits.to_N ?bs] ] =>
           pose_once Bits.to_N_bounded bs
         end.

(** Lia with some support for the Bits.to_N function **)
Ltac lia_bits :=
  Bits_to_N_t; cbn in *; pose_bits_bound_proofs; remember_bits_to_N; cbn in *; lia.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
Copyright (C) 2009-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** Basic operations on floats: alignment, addition, multiplication *)
Require Import Raux Defs Float_prop.

Set Implicit Arguments.
Set Strongly Strict Implicit.

Section Float_ops.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Arguments Float {beta}.

Definition Falign (f1 f2 : float beta) :=
  let '(Float m1 e1) := f1 in
  let '(Float m2 e2) := f2 in
  if Zle_bool e1 e2
  then (m1, (m2 * Zpower beta (e2 - e1))%Z, e1)
  else ((m1 * Zpower beta (e1 - e2))%Z, m2, e2).

Theorem Falign_spec :
  forall f1 f2 : float beta,
  let '(m1, m2, e) := Falign f1 f2 in
  F2R f1 = @F2R beta (Float m1 e) /\ F2R f2 = @F2R beta (Float m2 e).
Proof.
unfold Falign.
intros (m1, e1) (m2, e2).
generalize (Zle_cases e1 e2).
case (Zle_bool e1 e2) ; intros He ; split ; trivial.
now rewrite <- F2R_change_exp.
rewrite <- F2R_change_exp.
apply refl_equal.
omega.
Qed.

Theorem Falign_spec_exp:
  forall f1 f2 : float beta,
  snd (Falign f1 f2) = Zmin (Fexp f1) (Fexp f2).
Proof.
intros (m1,e1) (m2,e2).
unfold Falign; simpl.
generalize (Zle_cases e1 e2);case (Zle_bool e1 e2); intros He.
case (Zmin_spec e1 e2); intros (H1,H2); easy.
case (Zmin_spec e1 e2); intros (H1,H2); easy.
Qed.

Definition Fopp (f1 : float beta) : float beta :=
  let '(Float m1 e1) := f1 in
  Float (-m1)%Z e1.

Theorem F2R_opp :
  forall f1 : float beta,
  (F2R (Fopp f1) = -F2R f1)%R.
intros (m1,e1).
apply F2R_Zopp.
Qed.

Definition Fabs (f1 : float beta) : float beta :=
  let '(Float m1 e1) := f1 in
  Float (Zabs m1)%Z e1.

Theorem F2R_abs :
  forall f1 : float beta,
  (F2R (Fabs f1) = Rabs (F2R f1))%R.
intros (m1,e1).
apply F2R_Zabs.
Qed.

Definition Fplus (f1 f2 : float beta) : float beta :=
  let '(m1, m2 ,e) := Falign f1 f2 in
  Float (m1 + m2) e.

Theorem F2R_plus :
  forall f1 f2 : float beta,
  F2R (Fplus f1 f2) = (F2R f1 + F2R f2)%R.
Proof.
intros f1 f2.
unfold Fplus.
generalize (Falign_spec f1 f2).
destruct (Falign f1 f2) as ((m1, m2), e).
intros (H1, H2).
rewrite H1, H2.
unfold F2R. simpl.
rewrite plus_IZR.
apply Rmult_plus_distr_r.
Qed.

Theorem Fplus_same_exp :
  forall m1 m2 e,
  Fplus (Float m1 e) (Float m2 e) = Float (m1 + m2) e.
Proof.
intros m1 m2 e.
unfold Fplus.
simpl.
now rewrite Zle_bool_refl, Zminus_diag, Zmult_1_r.
Qed.

Theorem Fexp_Fplus :
  forall f1 f2 : float beta,
  Fexp (Fplus f1 f2) = Zmin (Fexp f1) (Fexp f2).
Proof.
intros f1 f2.
unfold Fplus.
rewrite <- Falign_spec_exp.
now destruct (Falign f1 f2) as ((p,q),e).
Qed.

Definition Fminus (f1 f2 : float beta) :=
  Fplus f1 (Fopp f2).

Theorem F2R_minus :
  forall f1 f2 : float beta,
  F2R (Fminus f1 f2) = (F2R f1 - F2R f2)%R.
Proof.
intros f1 f2; unfold Fminus.
rewrite F2R_plus, F2R_opp.
ring.
Qed.

Theorem Fminus_same_exp :
  forall m1 m2 e,
  Fminus (Float m1 e) (Float m2 e) = Float (m1 - m2) e.
Proof.
intros m1 m2 e.
unfold Fminus.
apply Fplus_same_exp.
Qed.

Definition Fmult (f1 f2 : float beta) : float beta :=
  let '(Float m1 e1) := f1 in
  let '(Float m2 e2) := f2 in
  Float (m1 * m2) (e1 + e2).

Theorem F2R_mult :
  forall f1 f2 : float beta,
  F2R (Fmult f1 f2) = (F2R f1 * F2R f2)%R.
Proof.
intros (m1, e1) (m2, e2).
unfold Fmult, F2R. simpl.
rewrite mult_IZR, bpow_plus.
ring.
Qed.

End Float_ops.


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** Handler for FMap properties, provides the [find_tac] tactic. *)

Require Import FMaps.
Require Import Common.
Require Import BoolView.

Module MyMapProps (X : FMapInterface.S).
  Include FMapFacts.Properties X.
  Include F.

  Import X.

  Lemma mapsto_in: forall T x (y: T) d, MapsTo x y d -> In x d.
  Proof. intros. exists y. assumption. Qed.

  Lemma in_add_1: forall T x (y: T) d, In x (add x y d).
  Proof. intros. exists y. apply add_1. apply E.eq_refl. Qed.

  Lemma in_add_2: forall T x y (z: T) d, In x d -> In x (add y z d).
  Proof.
    intros. destruct (E.eq_dec y x).
     exists z. auto with map.
     destruct H as [w ?]. exists w. auto with map.
  Qed.

  Global Hint Resolve mapsto_in in_add_1 in_add_2 : map.

  Inductive find_spec_ind A k s : option A -> Prop :=
  | find_spec_1 : forall x, MapsTo k x s -> find_spec_ind A k s (Some x)
  | find_spec_2 : ~In k s -> find_spec_ind A k s (None).

  Lemma find_spec : forall A k s, find_spec_ind A k s (find k s).
  Proof.
    intros. case_eq (find k s); intros; constructor; auto with map.
    intros [x Hx]. apply find_1 in Hx. rewrite H in Hx. discriminate.
  Qed.

  Instance find_view : Type_View find := {type_view := find_spec}.

  (** * Destructor for find *)
  Ltac find_analyse :=
    repeat type_view find.

  Ltac find_tac :=
     repeat (
       match goal with
         | |- ?x = ?x => reflexivity

         | H : @MapsTo _   ?s ?x1 ?eps, H' : @MapsTo _ ?s ?x2 ?eps |- _ =>
           let H'' := fresh in
             assert (H'' : x1 = x2) by (eapply MapsTo_fun; eauto); clear H'; destruct H''
         | H : @MapsTo _ ?s ?x (@add _ ?t ?y ?eps) |- _ =>
           revert H; map_iff; intros [[? ?] | [? ?]]
         | H : @MapsTo _ ?x ?b (@map _ _ ?f ?m) |- _ =>
           rewrite map_mapsto_iff in H;
             destruct H as [?x [?H ?H]]
         | H : ~(@In _ ?x (@map _ _ ?f ?m)) |- _ => rewrite map_in_iff in H
         | H : @In _ ?x (map ?f ?m) |- _ => rewrite map_in_iff in H
         | H :  ~ (@In _ ?k (@add _ ?k ?y ?s)) |- _ => exfalso; apply H; clear H; map_iff; firstorder
         | H :  ~ (@In _ ?k (@add _ ?k' ?y ?s)), H' : @MapsTo _ ?k ?x ?s |- _ =>
           exfalso; apply H; clear H; map_iff; firstorder
         | H :  ~ (@In _ ?k ?s), H' : @MapsTo _ ?k ?x ?s |- _ =>
           exfalso; apply H; clear H; map_iff; firstorder
         | H :  ~ (@In _ ?k (@add  _ ?k' ?y ?s)) |- _ => revert H; rewrite add_in_iff; intro H
         | H : ?s = ?s |- _ => clear H
         | H : ?s <> ?s |- _ => elim H; reflexivity
         | H : ?s = ?t |- _ => subst
       end); trivial.

End MyMapProps.


Require Import VST.floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha_lemmas.
Local Open Scope nat.
Local Open Scope logic.

Lemma Zlength_list_repeat:
  forall {A} n (x:A), Zlength (list_repeat (Z.to_nat n) x) = Z.max 0 n.
Proof.
intros.
rewrite Zlength_correct, length_list_repeat.
destruct (zlt n 0).
rewrite Z.max_l by omega.
rewrite Z2Nat_neg by auto. reflexivity.
rewrite Z2Nat.id by omega.
rewrite Z.max_r by omega.
auto.
Qed.

Import field_at_wand.SegmentHole.

Lemma splice_into_list_simplify0:
  forall {A} n (src dst: list A),
    Zlength src = n ->
    Zlength dst = n ->
    splice_into_list 0 n src dst = src.
Proof.
 intros.
 unfold splice_into_list.
rewrite !sublist_nil.
rewrite app_nil_l.
pose proof (Zlength_nonneg src).
rewrite sublist_nil' by omega.
rewrite app_nil_r.
auto.
Qed.

Lemma splice_into_list_self:
  forall {A} lo hi (l: list A),
    (0 <= lo <= hi)%Z ->
    (hi <= Zlength l)%Z ->
    splice_into_list lo hi (sublist lo hi l) l = l.
Proof.
 intros.
 unfold splice_into_list.
 autorewrite with sublist.
 auto.
Qed.
(*
Lemma splice_into_list_simplify1:
  forall lo hi src tgt,
    lo = Zlength tgt ->
    (hi-lo = Zlength src)%Z ->
    splice_into_list lo hi src tgt = tgt++src.
Proof.
intros; subst; unfold splice_into_list.
pose proof (Zlength_nonneg tgt).
pose proof (Zlength_nonneg src).
rewrite H0.
rewrite Z.sub_diag.
change (Z.to_nat 0) with 0%nat; simpl.
rewrite <- app_nil_end.
rewrite sublist_same by omega.
f_equal.
rewrite (sublist_nil hi), <- app_nil_end.
rewrite sublist_app by (rewrite ?Zlength_list_repeat, ?Z.max_r; omega).
rewrite ?Z.min_l by omega.
rewrite ?Z.max_r by omega.
rewrite sublist_nil, <- app_nil_end.
apply sublist_same; omega.
Qed.

Lemma splice_into_list_simplify2:
  forall lo hi src tgt,
    lo = Zlength tgt ->
    (lo <= hi)%Z ->
    (hi-lo <= Zlength src)%Z ->
    splice_into_list lo hi hi src tgt = tgt++ sublist 0 (hi-lo) src.
Proof.
intros; subst; unfold splice_into_list.
pose proof (Zlength_nonneg tgt).
pose proof (Zlength_nonneg src).
repeat rewrite Z.sub_diag.
change (Z.to_nat 0) with 0.
unfold list_repeat at 1.
rewrite <- app_nil_end.
rewrite sublist_same by omega.
f_equal.
rewrite sublist_nil, <- app_nil_end by omega.
rewrite sublist_app by (rewrite ?Zlength_list_repeat, ?Z.max_r; omega).
rewrite ?Z.min_l by omega.
rewrite ?Z.max_r by omega.
rewrite sublist_nil, <- app_nil_end by omega.
auto.
Qed.
*)
Lemma JMeq_skipn:
  forall ta tb n (la: list ta) (lb: list tb),
     ta=tb ->
     JMeq la lb ->
     JMeq (skipn n la) (skipn n lb).
Proof.
intros. subst tb. apply JMeq_eq in H0. subst lb. auto.
Qed.

Lemma JMeq_firstn:
  forall ta tb n (la: list ta) (lb: list tb),
    ta=tb -> JMeq la lb -> JMeq (firstn n la) (firstn n lb).
Proof.
intros. subst tb. apply JMeq_eq in H0. subst lb. auto.
Qed.

Lemma JMeq_length:
  forall ta tb (la: list ta) (lb: list tb),
     ta=tb -> JMeq la lb -> length la = length lb.
Proof.
intros. subst tb.  apply JMeq_eq in H0. subst lb. auto.
Qed.

Lemma JMeq_sublist:
  forall ta tb lo hi (la: list ta) (lb: list tb),
    ta=tb -> JMeq la lb -> JMeq (sublist lo hi la) (sublist lo hi lb).
Proof.
intros. subst tb. apply JMeq_eq in H0. subst lb. auto.
Qed.

 Definition fsig_of_funspec (fs: funspec)  :=
  match fs with mk_funspec fsig _ _ _ _ _ _=> fsig end.

Lemma part1_splice_into_list:
  forall {A} lo hi (al bl: list A),
    (0 <= lo <= Zlength bl)%Z ->
    sublist 0 lo (splice_into_list lo hi al bl) = sublist 0 lo bl.
Proof.
 intros.
 unfold splice_into_list.
 rewrite (sublist_app); rewrite ?Zlength_list_repeat, ?Z.max_l by omega; try omega;
 rewrite ?Zlength_sublist by omega;
 try (rewrite ?Zlength_correct; omega).
rewrite ?Z.min_l by omega.
rewrite ?Z.max_r by omega.
rewrite sublist_nil, <- app_nil_end by omega.
rewrite sublist_same; auto.
rewrite Zlength_sublist; omega.
Qed.

Lemma part3_splice_into_list:
  forall {A} lo hi n (al bl: list A),
    (0 <= lo <= hi)%Z -> (hi <= n)%Z ->
   (Zlength bl = n)%Z ->
   (Zlength al = hi-lo)%Z ->
    sublist hi n (splice_into_list lo hi al bl) = sublist hi n bl.
Proof.
 intros.
 unfold splice_into_list.
rewrite <- app_ass.
 rewrite (sublist_app); rewrite ?Zlength_list_repeat, ?Z.max_r, ?Z.max_l by omega; try omega;
 rewrite ?Zlength_sublist by omega;
 try (rewrite ?Zlength_correct; omega).
rewrite !Zlength_app.
rewrite Zlength_sublist; try omega.
rewrite ?Z.min_r by omega.
rewrite ?Z.max_r by omega.
rewrite sublist_nil by omega.
simpl.
rewrite Z.max_l by omega.
rewrite sublist_sublist by omega.
f_equal. omega.
rewrite !Zlength_app.
rewrite !Zlength_sublist; omega.
Qed.

Lemma Zlength_splice_into_list:
  forall {A} lo hi (al bl: list A),
    (0 <= lo <= hi)%Z -> (hi <= Zlength bl)%Z ->
    (hi - lo = Zlength al)%Z ->
    Zlength (splice_into_list lo hi al bl) = Zlength bl.
Proof.
intros.
unfold splice_into_list.
rewrite !Zlength_app.
rewrite !Zlength_sublist; rewrite ?Zlength_app; rewrite ?Zlength_list_repeat; try omega.
Qed.

Local Arguments nested_field_type cs t gfs : simpl never.

Lemma semax_call_id0_alt:
 forall Espec {cs: compspecs} Delta P Q R id bl argsig tfun retty cc A x Pre Post
   (GLBL: (var_types Delta) ! id = None),
       (glob_specs Delta) ! id = Some (NDmk_funspec (argsig, retty) cc A Pre Post) ->
       (glob_types Delta) ! id = Some (type_of_funspec (NDmk_funspec (argsig, retty) cc A Pre Post)) ->
   tfun = type_of_params argsig ->
  @semax cs Espec Delta (|> (tc_exprlist Delta (argtypes argsig) bl
                  && (`(Pre x) (make_args' (argsig,retty) (eval_exprlist (argtypes argsig) bl))
                         * PROPx P (LOCALx Q (SEPx R)))))
    (Scall None (Evar id (Tfunction tfun retty cc)) bl)
    (normal_ret_assert
       ((ifvoid retty (`(Post x) (make_args nil nil))
                                                   (EX v:val, `(Post x) (make_args (ret_temp::nil) (v::nil))))
         * PROPx P (LOCALx Q (SEPx R)))).
Proof.
intros.
subst tfun.
apply (@semax_call_id0 Espec cs Delta P Q R id bl (NDmk_funspec (argsig, retty) cc A Pre Post) argsig retty cc (rmaps.ConstType A) nil x
                  (fun _ => Pre) (fun _ => Post)
               (const_super_non_expansive _ _)
               (const_super_non_expansive _ _)); auto.
apply subsume_funspec_refl.
Qed.

Lemma call_memcpy_tuchar:  (* Uses CompSpecs from sha. *)
  forall (shp : share) (tp: type) (pathp: list gfield) (lop: Z) (vp': list val) (p: val)
           (shq: share) (tq: type) (pathq: list gfield) (loq: Z) (contents: list int) (q: val)
           (len : Z)
           (R': list mpred)
           (np nq : Z)
           (vp vp'': reptype (nested_field_type tp pathp))
           (vq : reptype (nested_field_type tq pathq))
           (e_p e_q e_n : expr)
           Espec Delta P Q R,
      typeof e_p = tptr tuchar ->
      typeof e_q = tptr tuchar ->
      typeof e_n = tuint ->
      (var_types Delta) ! _memcpy = None ->
     (glob_specs Delta) ! _memcpy = Some (snd memcpy_spec) ->
     (glob_types Delta) ! _memcpy = Some (type_of_funspec (snd memcpy_spec)) ->
     writable_share shp ->  readable_share shq ->
     nested_field_type tp pathp = tarray tuchar np ->
     nested_field_type tq pathq = tarray tuchar nq ->
     (0 <= lop)%Z ->
     (0 <= len <= Int.max_unsigned)%Z ->
     (lop + len <= np)%Z ->
     (0 <= loq)%Z ->  (loq + len <=  (*Zlength contents <=*) nq)%Z ->
     JMeq vq (map Vint contents) ->
     JMeq vp vp' ->
     JMeq vp'' (splice_into_list lop (lop+len) (sublist loq (loq + len) (map Vint contents)) vp') ->
     ENTAIL Delta, PROPx P (LOCALx Q (SEPx R)) |--
         tc_exprlist Delta [tptr tvoid; tptr tvoid; tuint] [e_p; e_q; e_n]  &&
         local (`(eq (field_address0 tp (ArraySubsc lop :: pathp) p)) (eval_expr e_p)) &&
         local (`(eq (field_address0 tq (ArraySubsc loq :: pathq) q)) (eval_expr e_q)) &&
         local (`(eq (Vint (Int.repr len))) (eval_expr e_n)) &&
         PROP () (LOCALx Q (SEPx (field_at shp tp pathp vp p ::
                                                 field_at shq tq pathq vq q :: R'))) ->
   @semax _ Espec Delta
    (PROPx P (LOCALx Q (SEPx R)))
    (Scall None
             (Evar _memcpy
               (Tfunction
                (Tcons (tptr tvoid) (Tcons (tptr tvoid) (Tcons tuint Tnil)))
                  (tptr tvoid) cc_default))
              [e_p; e_q; e_n])
    (normal_ret_assert (PROPx P (LOCALx Q
     (SEPx (field_at shp tp pathp vp'' p ::
               field_at shq tq pathq vq q :: R'))))).
Proof.
intros until R.
intros TCp TCq TCn Hvar Hspec Hglob ? SHq ? ? Hlop Hlen Hnp Hloq Hnq; intros.
assert_PROP (fold_right and True P); [ old_go_lower; entailer! | ].
apply semax_post' with
   (PROPx nil   (LOCALx Q
           (SEPx
              (field_at shp tp pathp vp'' p
               :: field_at shq tq pathq vq q :: R'))));
 [ old_go_lower; entailer! | ].
clear H6. rename H5 into Hpre.
assert_PROP (Zlength vp' = np /\ Zlength contents = nq). {
eapply derives_trans; [apply Hpre |].
apply andp_left2.
old_go_lower; entailer!.
clear - H7 H9 H0 H1 H2 H3 H Hlop Hloq Hnp Hnq Hlen.
forget (nested_field_type tp pathp) as t0.
forget (nested_field_type tq pathq) as t1.
subst t0 t1.
simplify_value_fits in H7. destruct H7 as [H7 _].
simplify_value_fits in H9. destruct H9 as [H9 _].
apply JMeq_eq in H3. subst vp; auto.
apply JMeq_eq in H2. subst vq; auto.
rewrite Zlength_map in H9.
split; auto.
} destruct H5 as [Hvp' Hvq'].

assert (reptype (tarray tuchar np) = list val) by reflexivity.
rewrite <- H0 in H5.
assert (H99: reptype (nested_field_type tp (ArraySubsc 0 :: pathp)) = val)
  by (rewrite nested_field_type_ind, H0; reflexivity).
assert (exists vpx : list (reptype (nested_field_type tp (ArraySubsc 0 :: pathp))),
                    JMeq vp vpx)
  by (rewrite H99, <- H5; exists vp; auto).
destruct H6 as [vpx Hvpx].
assert_PROP (legal_nested_field tp pathp /\ legal_nested_field tq pathq). {
  eapply derives_trans; [apply Hpre | apply andp_left2].
old_go_lower; entailer!.
} destruct H6 as [LNFp LNFq].

pose (witness := ((shq,shp),
                              field_address0 tp (ArraySubsc lop :: pathp) p,
                              field_address0 tq (ArraySubsc loq :: pathq) q,
                              len,  sublist loq (loq+len) contents)).
pose (Frame :=
        array_with_hole shq tuchar loq (loq + len) nq (map Vint contents) (field_address tq pathq q)
          :: array_with_hole shp tuchar lop (lop + len) np vp' (field_address tp pathp p) :: R').
eapply semax_pre_post';
  [ | | eapply semax_call_id0_alt with (x:=witness)(P:=nil)(Q:=Q);
       try eassumption;
       try (rewrite ?Hspec, ?Hglob; reflexivity)].

*
 eapply derives_trans, now_later.
 rewrite <- (andp_dup (local (tc_environ _))), andp_assoc.
 eapply derives_trans; [ apply andp_derives; [apply derives_refl | apply Hpre] | ].
 rewrite !andp_assoc.
 apply andp_right; [apply andp_left2, andp_left1, derives_refl |].
 assert_PROP (field_address0 tp (pathp SUB lop) p <> Vundef) as DEFp.
 {
   unfold tc_exprlist.
   simpl typecheck_exprlist.
   rewrite !denote_tc_assert_andp.
   apply derives_trans with (local (tc_environ Delta) && denote_tc_assert (typecheck_expr Delta e_p) && local ((` (eq (field_address0 tp (pathp SUB lop) p))) (eval_expr e_p))); [solve_andp |].
   go_lowerx.
   eapply derives_trans; [apply typecheck_expr_sound; auto |].
   apply prop_derives; intros.
   rewrite <- H7 in H8.
   intro.
   rewrite H9 in H8.
   revert H8; apply tc_val_Vundef.
 }
 assert_PROP (field_address0 tq (pathq SUB loq) q <> Vundef) as DEFq.
 {
   unfold tc_exprlist.
   simpl typecheck_exprlist.
   rewrite !denote_tc_assert_andp.
   apply derives_trans with (local (tc_environ Delta) && denote_tc_assert (typecheck_expr Delta e_q) && local ((` (eq (field_address0 tq (pathq SUB loq) q))) (eval_expr e_q))); [solve_andp |].
   go_lowerx.
   eapply derives_trans; [apply typecheck_expr_sound; auto |].
   apply prop_derives; intros.
   rewrite <- H7 in H8.
   intro.
   rewrite H9 in H8.
   revert H8; apply tc_val_Vundef.
 }
 apply andp_left2, andp_left2.
 subst witness. cbv beta iota. simpl @fst; simpl @snd.
 clear Hpre.
 autorewrite with norm1 norm2.
 rewrite PROP_combine.
 unfold app at 1.
 instantiate (1:=Frame).
 unfold app at 2.
 go_lowerx.
 apply andp_right.
 apply prop_right.
 unfold make_args'. simpl.
 unfold eval_id, env_set.
 rewrite TCp, TCq, TCn.  simpl.
 unfold_lift; simpl.
 rewrite <- H6, <- H7, <- H8.
 split3; try (repeat split; auto; congruence).
 apply andp_right.
 apply prop_right; split3; auto.
 subst Frame.
 normalize.
 cancel.
 rewrite !field_at_data_at.
 rewrite (data_at_type_changable _ _ _ _ _ H0 H3).
 rewrite (data_at_type_changable _ _ _ _ _ H1 H2).
 sep_apply (array_with_hole_intro shp tuchar lop (lop + len) np vp' (field_address tp pathp p)); [omega | ].
 sep_apply (array_with_hole_intro shq tuchar loq (loq + len) nq (map Vint contents) (field_address tq pathq q)); [omega | ].
 cancel.
 apply sepcon_derives.
 - apply derives_refl'.
   rewrite <- H1.
   rewrite <- field_address0_app by congruence.
   simpl app.
   apply equal_f.
   apply data_at_type_changable.
   + f_equal; clear; omega.
   + rewrite <- sublist_map.
     apply JMeq_sublist; auto.
 - replace (memory_block shp len) with
     (memory_block shp (sizeof (nested_field_array_type tp pathp lop (lop + len)))).
   2: {
     f_equal. unfold nested_field_array_type.
     rewrite nested_field_type_ind. rewrite H0. simpl.
     rewrite Z.max_r by omega. rewrite Z.mul_1_l. clear; omega.
   }
   eapply derives_trans; [ | apply data_at__memory_block_cancel]; cancel.
   rewrite <- H0.
   rewrite <- field_address0_app by congruence.
   simpl app.
   unfold nested_field_array_type, tarray.
   rewrite nested_field_type_ind, H0.
   apply data_at_data_at_.
 *
 intros. apply andp_left2.
 go_lowerx. unfold_lift.
 simpl.
 Intros x. rewrite prop_true_andp by auto.
 rewrite map_sublist.
 clear witness Frame.
 normalize in H7.
 subst x.
 simpl.
 clear Hpre H6 P Q rho .
assert (exists (vpy : list (reptype (nested_field_type tp (ArraySubsc 0 :: pathp)))),
                  JMeq vp'' vpy)
  by (rewrite H99; eauto).
destruct H6 as [vpy H7].
assert (Zlength vpy = np). {
 assert (JMeq vpy  (splice_into_list lop (lop + len)
          (sublist loq (loq + len) (map Vint contents)) vp')) by (eapply JMeq_trans; [apply @JMeq_sym |]; eassumption).
 transitivity (Zlength  (splice_into_list lop (lop + len)
          (sublist loq (loq + len) (map Vint contents)) vp')).
 clear - H6 H99 H5.
 forget (splice_into_list lop (lop + len)
          (sublist loq (loq + len) (map Vint contents)) vp') as vv.
 forget val as t. subst t. apply JMeq_eq in H6. subst; auto.
 rewrite Zlength_splice_into_list; try omega.
 autorewrite with sublist; auto.
}
cancel.
change (ArraySubsc loq :: pathq) with ([ArraySubsc loq] ++ pathq).
change (ArraySubsc lop :: pathp) with ([ArraySubsc lop] ++ pathp).
rewrite !field_address0_app by congruence.
rewrite H0, H1.
erewrite (data_at_type_changable shq _ (tarray tuchar (loq + len - loq)));
[| f_equal; omega | apply JMeq_refl].
erewrite (data_at_type_changable shp _ (tarray tuchar (lop + len - lop)));
[| f_equal; omega | apply JMeq_refl].
sep_apply (array_with_hole_elim shp tuchar lop (lop + len) np (sublist loq (loq + len) (map Vint contents)) vp' (field_address tp pathp p)).
sep_apply (array_with_hole_elim shq tuchar loq (loq + len) nq (sublist loq (loq + len) (map Vint contents)) (map Vint contents) (field_address tq pathq q)).
rewrite !field_at_data_at.
rewrite sepcon_comm.
apply sepcon_derives.
- apply derives_refl'.
  apply equal_f.
  apply data_at_type_changable; auto.
- apply derives_refl'.
  apply equal_f.
  apply data_at_type_changable; auto.
  eapply JMeq_trans; [| apply JMeq_sym, H2].
  apply eq_JMeq.
  apply splice_into_list_self.
  { omega. }
  { autorewrite with sublist. omega. }
Qed.

Lemma call_memset_tuchar:
  forall (shp : share) (tp: type) (pathp: list gfield) (lop: Z) (vp': list val) (p: val)
           (c: int) (len : Z)
           (R': list mpred)
           (np : Z)
           (vp vp'': reptype (nested_field_type tp pathp))
           (e_p e_c e_n : expr)
           Espec Delta P Q R (s: signedness)
   (TCp : typeof e_p = tptr tuchar)
   (TCc : typeof e_c = tint)
   (TCn : typeof e_n = Tint I32 s noattr)
   (Hvar : (var_types Delta) ! _memset = None)
   (Hspec : (glob_specs Delta) ! _memset = Some (snd memset_spec))
   (Hglob : (glob_types Delta) ! _memset =
        Some (type_of_funspec (snd memset_spec)))
   (H:  writable_share shp)
   (Hlop : (0 <= lop)%Z)
   (Hlen: (0 <= len <= Int.max_unsigned)%Z)
   (H0:  nested_field_type tp pathp = tarray tuchar np)
   (Hnp : (lop + len <= np)%Z)
   (H3:  JMeq vp vp')
   (H4:  JMeq vp'' (splice_into_list lop (lop+len) (list_repeat (Z.to_nat len) (Vint c)) vp'))
   (H5: ENTAIL Delta, PROPx P (LOCALx Q (SEPx R)) |--
         tc_exprlist Delta [tptr tvoid; tint; tuint] [e_p; e_c; e_n] &&
         local (`(eq (field_address0 tp (ArraySubsc lop :: pathp) p)) (eval_expr e_p)) &&
         local (`(eq (Vint c)) (eval_expr e_c)) &&
         local (`(eq (Vint (Int.repr len))) (eval_expr e_n)) &&
         PROP () (LOCALx Q (SEPx (field_at shp tp pathp vp p :: R')))),
   @semax _ Espec Delta
    (PROPx P (LOCALx Q (SEPx R)))
    (Scall None
             (Evar _memset
               (Tfunction
                (Tcons (tptr tvoid) (Tcons tint (Tcons tuint Tnil)))
                  (tptr tvoid) cc_default))
              [e_p; e_c; e_n])
    (normal_ret_assert (PROPx P (LOCALx Q
     (SEPx (field_at shp tp pathp vp'' p :: R'))))).
Proof.
intros.
assert_PROP (fold_right and True P)
  by (old_go_lower; entailer!).
apply semax_post' with
   (PROPx nil   (LOCALx Q
           (SEPx (field_at shp tp pathp vp'' p :: R'))));
 [ old_go_lower; entailer! | ].
rename H5 into Hpre.
clear H1.
assert_PROP (Zlength vp' = np). {
eapply derives_trans; [apply Hpre | apply andp_left2].
old_go_lower; entailer!.
clear - H5 H4 H3 Hnp H0 Hlen Hlop.
forget (nested_field_type tp pathp) as t0.
subst t0.
simplify_value_fits in H5. destruct H5 as [H5 _].
apply JMeq_eq in H3. subst vp; auto.
} rename H1 into Hvp'.
assert (H5: reptype (tarray tuchar np) = list val) by reflexivity.
rewrite <- H0 in H5.
assert (H99: reptype (nested_field_type tp (ArraySubsc 0 :: pathp)) = val).
 clear - H0. unfold nested_field_type in *; simpl in *.
  destruct (nested_field_rec tp pathp); inv H0. destruct p. subst.
 reflexivity.
assert (H6: exists vpx : list (reptype (nested_field_type tp (ArraySubsc 0 :: pathp))),
                    JMeq vp' vpx).
rewrite H99. eauto.
destruct H6 as [vpx Hvpx].
assert_PROP (legal_nested_field tp pathp). {
  eapply derives_trans; [apply Hpre | apply andp_left2].
old_go_lower; entailer!.
} rename H1 into LNFp.
apply (fun H => JMeq_trans H Hvpx) in H3.
assert (LENvpx: Zlength vpx = np). {
clear - H99 Hvp' Hvpx.
forget val as t. subst t.
apply JMeq_eq in Hvpx. subst; auto.
}
erewrite field_at_Tarray in Hpre; try eassumption; auto; try omega.
rewrite (split3seg_array_at shp tp pathp 0 lop (lop+len)) in Hpre by omega.
rewrite !Z.sub_0_r in Hpre.

assert_PROP (field_compatible0 tp (pathp SUB lop) p /\
            field_compatible0 tp (pathp SUB (lop + len)) p)
  as FC. {
 eapply derives_trans; [apply Hpre | clear Hpre].
 go_lowerx. apply andp_left2. normalize.
 saturate_local.
 apply prop_right.
 split; auto.
}
pose (witness := (shp,
                              field_address0 tp (ArraySubsc lop :: pathp) p,
                              len,  c)).
pose (Frame :=
         array_at shp tp pathp (lop + len) np
              (sublist (lop+len) np vpx) p
          :: array_at shp tp pathp 0 lop (sublist 0 lop vpx) p
              :: R').
eapply semax_pre_post';
  [ | | eapply semax_call_id0_alt with (x:=witness)(P:=nil)(Q:=Q);
       try eassumption;
       try (rewrite ?Hspec, ?Hglob; reflexivity)].
*
 eapply derives_trans, now_later.
 rewrite <- (andp_dup (local (tc_environ _))), andp_assoc.
 eapply derives_trans; [ apply andp_derives; [apply derives_refl | apply Hpre] | ].
 rewrite !andp_assoc.
 apply andp_right; [apply andp_left2, andp_left1, derives_refl |].
 assert_PROP (field_address0 tp (pathp SUB lop) p <> Vundef) as DEFp.
 {
   unfold tc_exprlist.
   simpl typecheck_exprlist.
   rewrite !denote_tc_assert_andp.
   apply derives_trans with (local (tc_environ Delta) && denote_tc_assert (typecheck_expr Delta e_p) && local ((` (eq (field_address0 tp (pathp SUB lop) p))) (eval_expr e_p))); [solve_andp |].
   go_lowerx.
   eapply derives_trans; [apply typecheck_expr_sound; auto |].
   apply prop_derives; intros.
   rewrite <- H2 in H6.
   intro.
   rewrite H7 in H6.
   revert H6; apply tc_val_Vundef.
 }
 apply andp_left2, andp_left2.
 subst witness. cbv beta iota. simpl @fst; simpl @snd.
 clear Hpre.
 autorewrite with norm1 norm2.
 rewrite PROP_combine.
 unfold app at 1.
 instantiate (1:=Frame).
 unfold app at 2.
 simpl argtypes. unfold eval_exprlist.
 unfold make_args'. simpl map at 2.
 rewrite TCp, TCc, TCn.
 go_lowerx. unfold env_set, eval_id. unfold_lift. simpl.
 autorewrite with gather_prop.
 apply andp_right.
 apply prop_right. split3; try (repeat split; auto; congruence).
 normalize.
 subst Frame.
 cancel.
 rewrite array_at_data_at' by  (try solve [clear - FC; intuition]; omega).
 eapply derives_trans; [apply data_at_data_at_ | ].
 eapply derives_trans; [apply data_at__memory_block_cancel | ].
 apply derives_refl'; f_equal.
  unfold nested_field_array_type.
   rewrite nested_field_type_ind, H0. simpl.
  rewrite Z.max_r by omega. omega.
*
 intros. apply andp_left2.
 unfold ifvoid. unfold tptr at 1.
 Intros v. subst witness. cbv beta zeta iota.
 clear Hpre.
 autorewrite with norm1 norm2.
 rewrite PROP_combine.
 unfold app at 1.
 subst Frame.
 simpl map.
 old_go_lower. normalize.
 cancel.
 clear H1 H2.
 assert (H2: exists (vpy : list (reptype (nested_field_type tp (ArraySubsc 0 :: pathp)))),
                  JMeq vp'' vpy).
 rewrite H99. eauto.
destruct H2 as [vpy H8].
erewrite field_at_Tarray; try eassumption; auto; try omega.
apply (JMeq_trans (JMeq_sym H4)) in H8.
clear dependent vp''. clear dependent e_c. clear dependent e_p. clear dependent e_n.
clear dependent Delta.
assert (Zlength vpy = np). {
clear - H0 H8 Hvp' Hnp Hlop Hlen.
generalize dependent vpy.
rewrite nested_field_type_ind, H0. simpl. rewrite reptype_eq; simpl.
intros.
apply JMeq_eq in H8.
subst.
clear H0.
rewrite Zlength_splice_into_list; try omega.
autorewrite with sublist.
auto.
}
rewrite (split3seg_array_at shp tp pathp 0 lop (lop+len) np) by omega.
rewrite !Z.sub_0_r.
replace (sublist 0 lop vpx) with (sublist 0 lop vpy).
2:{
generalize dependent vpy.
generalize dependent vpx.
rewrite H99.
intros.
apply JMeq_eq in H8. apply JMeq_eq in Hvpx.
subst.
apply part1_splice_into_list; omega.
}
replace (sublist (lop+len) np vpx) with (sublist (lop+len) np vpy).
2:{
generalize dependent vpy.
generalize dependent vpx.
rewrite H99.
intros.
apply JMeq_eq in H8. apply JMeq_eq in Hvpx.
subst.
apply part3_splice_into_list; try omega.
rewrite Zlength_list_repeat. rewrite Z.max_r by omega. omega.
}
cancel.
 rewrite array_at_data_at' by  (try solve [clear - FC; intuition]; omega).
   apply derives_refl'.
   apply equal_f. apply data_at_type_changable.
   unfold nested_field_array_type.
   rewrite nested_field_type_ind, H0.
   unfold tarray; f_equal. clear; omega.
   apply (JMeq_sublist _ _ lop (lop + len) _ _ (eq_sym H99)) in H8.
   eapply JMeq_trans, H8.
   apply eq_JMeq.
   unfold splice_into_list.
   autorewrite with sublist. auto.
Qed.


Require Import HoTT.

(*ap12 and ap12' are badly named. ap12' is the same as ap_to_conjp *)
Definition ap12 {A B : Type} {a b : A} (p : a = b) {f g : A->B} (q : f=g)  :
  (ap10 q a)^ @ (ap f p) @ (ap10 q b) = ap g p.
Proof.
  destruct p, q. reflexivity.
Defined.

(*Needs better name, I guess. . .*)
Definition ap12' `{Funext} {A B : Type} {a b : A} (p : a = b) {f g : A->B} (q : f==g)  :
  (q a)^ @ (ap f p) @ q b = ap g p.
Proof.
  refine (_ @ ap12 p (path_arrow _ _ q)).
  apply concat2.
  { apply whiskerR.
    apply inverse2. exact (inverse (ap10_path_arrow f g q _)). }
  exact (inverse (ap10_path_arrow f g q _)).
Defined.

Definition ap011_pp_pp {A B C : Type} (f : A -> B -> C) {x x' x'' : A} {y y' y'' : B}
           (p : x = x') (p' : x' = x'') (q : y = y') (q' : y' = y'') :
  ap011 f (p @ p') (q @ q') = ap011 f p q @ ap011 f p' q'.
Proof.
  by path_induction.
  (* destruct p, p', q, q'. exact idpath. *)
Qed.

Definition path_triple_prod {A B C : Type} (a1 a2 : A * (B * C)) :
  (fst a1 = fst a2) * ((fst (snd a1) = fst (snd a2)) * (snd (snd a1) = snd (snd a2))) -> a1 = a2.
Proof.
  intros [p [q r]].
  apply (path_prod a1 a2 p (path_prod (_,_) (_,_) q r)).
Defined.

Definition equiv_path_triple_prod {A B C : Type} (a1 a2 : A * (B * C)) :
  (fst a1 = fst a2) * ((fst (snd a1) = fst (snd a2)) * (snd (snd a1) = snd (snd a2))) <~> a1 = a2.
Proof.
  srapply (@equiv_adjointify _ _ (path_triple_prod a1 a2)).
  - intro p.
    exact (ap fst p, (ap fst (ap snd p), (ap snd (ap snd p)))).
  - intros []. reflexivity.
  - intros [p [q r]].
    destruct a2 as [a2 [b2 c2]]. simpl in *.
    destruct p,q,r. reflexivity.
Defined.

Definition double_pathover {A B : Type} (P : A -> B -> Type)
           {a a' : A} (p : a = a')
           {b b' : B} (q : b = b')
           (c : P a b) (c' : P a' b') : Type.
Proof.
  destruct p,q. exact (c = c').
Defined.

Definition double_pathover_to_path {A B : Type} (P : A -> B -> Type)
           {a a' : A} (p : a = a')
           {b b' : B} (q : b = b')
           (c : P a b) (c' : P a' b')
  : double_pathover P p q c c' ->
    transport (uncurry P) (path_prod (a,b) (a',b') p q) c = c'.
Proof.
  destruct p, q. exact idmap.
Defined.

Definition apd_po011
           (A B : Type) (C : A -> B -> Type) (f : forall (a : A) (b : B), C a b)
           (a1 a2 : A) (b1 b2 : B)
           (p : a1 = a2) (q : b1 = b2)
  : double_pathover C p q (f a1 b1) (f a2 b2).
Proof.
  destruct p. destruct q. reflexivity.
Defined.

Definition path_to_double_pathover {A B : Type} (P : A -> B -> Type)
           {a a' : A} (p : a = a')
           {b b' : B} (q : b = b') (c : P a b) (c' : P a' b')
  : transport (uncurry P) (path_prod (a, b) (a', b') p q) c = c' ->
    double_pathover P p q c c'.
Proof.
  destruct p. destruct q. exact idmap.
Defined.

Lemma ap011_VV
  : forall {A B C: Type} (f : A -> B -> C)
           {a0 a1 : A} {b0 b1 : B}
           (p : a0 = a1) (q : b0 = b1),
    (ap011 f p q)^ = ap011 f p^ q^.
Proof.
  intros. destruct p. destruct q. reflexivity.
Defined.

(* Definition pathover {A : Type} (B : A -> Type) {a a' : A} (p : a = a') (b : B a) (b' : B a') *)
(*   := transport B p b = b'.            *)

(* Notation "a =^ B [ p ] b" := (pathover B p a b) (at level 20, format "a  =^ B [ p ]  b"). *)
(* Notation "a =[ p ] b" := (pathover _ p a  b) (at level 20, format "a  =[ p ]  b"). *)

(*For now, define pathovers just as notation. *)

(* Notation "'pathover' B p a b" := (transport B p a = b) (at level 20) : pathover_scope. *)
(* Notation "a =[ p ] b" := (transport _ p a = b) *)
(*                            (at level 20, format "a  =[ p ]  b") : pathover_scope. *)
(* Notation "a =^ ( B ) [ p ] b" := (transport B p a = b) *)
(*                                (at level 20, format "a  =^ ( B ) [ p ]  b") : pathover_scope. *)

(* (*Make another scope where the explicit notation is parsing only*) *)
(* Notation "'pathover' B p a b" := (transport B p a = b) (at level 20) : implicit_pathover_scope. *)
(* Notation "a =[ p ] b" := (transport _ p a = b) *)
(*                            (at level 20, format "a  =[ p ]  b") : implicit_pathover_scope. *)
(* Notation "a =^ B [ p ] b" := (transport B p a = b) *)
(*                                (at level 20, only parsing, format "a  =^ B [ p ]  b") : implicit_pathover_scope. *)

(*This is already defined as [transport_apD_transportD], but I like this name better. . .*)
Definition transport_composeD {A : Type} (B : A -> Type) (C : forall a : A, B a -> Type)
           (f : forall a : A, B a)
           {a a' : A} (p : a = a') (c : C a (f a)) :
  transport (fun a0 : A => C a0 (f a0)) p c = transport (C a') (apD f p) (transportD B C p (f a) c).
Proof.
  induction p. reflexivity.
Defined.

(* Definition path_sigma' {A : Type} {B : A -> Type} {ab ab' : {a : A & B a}} *)
(*            (p : ab.1 = ab'.1) (q : path_over B p (ab.2) (ab'.2)) *)
(*   : ab = ab'. *)
(* Proof. *)
(*   destruct ab as [a b]. destruct ab' as [a' b']. simpl in *. *)
(*   destruct q. reflexivity. *)
(* Defined. *)

(* Definition path_sigma_concat' {A : Type} {B : A -> Type} {x y z : {a : A & B a}} *)
(*            (p : x.1 = y.1) (q : path_over B p (x.2) (y.2)) *)
(*            (p' : y.1 = z.1) (q' : path_over B p' (y.2) (z.2)) *)
(*   : path_sigma' p q @ path_sigma' p' q' = *)
(*     path_sigma' (p @ p') (path_over_concat q q'). *)
(* Proof. *)
(*   destruct x as [x1 x2]. destruct y as [y1 y2]. destruct z as [z1 z2]. simpl in *. *)
(*   destruct q'. destruct q. reflexivity. *)
(* Defined. *)

(* Definition equiv_path_sigma' {A : Type} {B : A -> Type} (ab ab' : {a : A & B a}) : *)
(*   {p : ab.1 = ab'.1 & path_over B p (ab.2) (ab'.2)} <~> ab = ab'. *)
(* Proof. *)
(*   srapply @equiv_adjointify. *)
(*   - intros [p q]. exact (path_sigma' p q). *)
(*   - intros []. exists idpath. apply path_over_id. *)
(*   - intros []. reflexivity. *)
(*   - intros [p q]. *)
(*     destruct ab as [a b]. destruct ab' as [a' b']. simpl in *. *)
(*     destruct p. destruct q. reflexivity. *)
(* Defined. *)

(*   Lemma equiv_path_over_id {A : Type} {B : A -> Type} (a : A) (b1 b2 : B a) *)
(*     : path_over B (idpath a) b1 b2 <~> b1 = b2. *)
(*   Proof. *)
(*     srapply @equiv_adjointify. *)
(*     - apply (path_over_to_path (p := idpath a)). *)
(*     - apply (path_to_path_over (p := idpath a)). *)
(*     - simpl. intros []. reflexivity. *)
(*     - intro q. destruct q. reflexivity. *)
(*   Defined.       *)

(*   Definition isequiv_path_over_concat {A : Type} {B : A -> Type} *)
(*              {a1 a2 a3: A} {p1 : a1 = a2} (p2 : a2 = a3) *)
(*              {b1 : B a1} {b2 : B a2} (q : path_over B p1 b1 b2) *)
(*              (b3 : B a3)  *)
(*     : IsEquiv (path_over_concat (p₂ := p2) (c₃ := b3) q). *)
(*   Proof. *)
(*     srapply @isequiv_adjointify. *)
(*     - destruct p2. destruct q. exact idmap. *)
(*     - destruct q. destruct p2.  *)
(*       intro q. simpl in q. revert q. *)
(*       apply (equiv_functor_forall_pf (equiv_path_over_id a c b3)). *)
(*       intros []. reflexivity. *)
(*     - destruct q. destruct p2. simpl. *)
(*       apply (equiv_functor_forall_pf (equiv_path_over_id a c b3)). *)
(*       intros []. reflexivity. *)
(*   Defined. *)

Section Dependent_paths.

  Definition apD_composeD {A : Type} {B : Type} {C : B -> Type}
             (f : forall b : B, C b)
             (g : A -> B)
             {a a' : A} (p : a = a') :
    apD (f oD g) p = transport_compose C g p (f (g a)) @ apD f (ap g p).
  Proof.
    destruct p. reflexivity.
  Defined.

  Definition composeDD {A : Type} {B : A -> Type} {C : forall a : A, B a -> Type}
             (f : forall a : A, forall b : B a, C a b)
             (g : forall a : A, B a)
  : forall a : A, C a (g a)
    := fun a => f a (g a).

  (* Notation "f 'oDD' g" := (composeDD f g) (at level 0): function_scope. *)

  (*. . . *)
  Definition apD_composeDD {A : Type} {B : A -> Type} {C : forall a : A, B a -> Type}
             (f : forall a : A, forall b : B a, C a b)
             (g : forall a : A, B a)
             {a a' : A} (p : a = a') :
    apD (composeDD f g) p =
    transport_composeD B C g p (f a (g a)) @ apD011 f p (apD g p).
  Proof.
    destruct p; reflexivity.
  Defined.

  (* Definition apD_composeDD' {A : Type} {B : A -> Type} {C : forall a : A, B a -> Type} *)
  (*            (f : forall a : A, forall b : B a, C a b) *)
  (*            (g : forall a : A, B a) *)
  (*            {a a' : A} (p : a = a') : *)
  (*   apD (composeDD f g) p = apD (f a') (apD g p) *)

  (* Notation "a =^ P p b" := (transport P p a = b) (at level 20, format *)
  (*                                                      "a  =^ P  p  b"). *)

  (* Definition concat_over {A : Type} (B : A -> Type) {a1 a2 a3 : A} (p : a1 = a2) (q : a2 = a3) *)
  (*            {b1 : B a1} {b2 : B a2} {b3 : B a3} :  *)

  (*   b1 =[p] b2 -> b2 =[q] b3 -> b1 =[p @ q] b3 *)
  (*   := fun over_p over_q => (transport_pp B p q b1 @ ap (transport B q) over_p @ over_q). *)

  (* Notation "r @[ p , q ] s" := (concat_over _ p q r s) (at level 20, format "r  @[ p , q ]  s"). *)

  (* Definition apD_pp {A : Type} {B : A -> Type} (f : forall a : A, B a) *)
  (*            {a1 a2 a3 : A} (p : a1 = a2) (q : a2 = a3) :  *)
  (*   apD f (p @ q) = (apD f p @[p, q] apD f q). *)
  (* Proof. *)
  (*   destruct p. destruct q. reflexivity. *)
  (* Qed. *)

  (* Definition transport_PQ {A : Type} {P : A -> Type} {Q : A -> Type} (h : P == Q) *)
  (*            {a b : A} (pth : a = b) *)
  (*            (p : P a) *)
  (* :  transport idmap (h b) (transport P pth p) = transport Q pth (transport idmap (h a) p). *)
  (*   destruct pth. reflexivity. Defined. *)

  Definition transport_PequivQ  {A : Type} {P : A -> Type} {Q : A -> Type} (h : forall a : A, P a <~> Q a)
             {a b : A} (pth : a = b)
             (p : P a)
  :  transport P pth p = (h b)^-1 (transport Q pth (h a p)).
    destruct pth. simpl. apply moveL_equiv_V. reflexivity. Defined.

  (* (*A version of transport_compose I need now*) *)
  (* Definition transport_compose_mine {A B : Type} (C : forall a : A, B -> Type) (f : A -> B) *)
  (*            {a a' : A} (p : a = a') (c : C a (f a)) : *)
  (*              transport (fun a => C a (f a)) p c = *)
  (*               ap ? @ (transport (C a) (ap f p) c). *)
  (* Proof. *)
  (*   destruct p. reflexivity. *)
  (* Defined. *)

End Dependent_paths.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal8.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons (Succ Zero) (Cons (Succ Zero) Nil)).
Definition lfind_example_2  := ( Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_3  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_4  := ( Cons Zero Nil).
Definition lfind_example_5  := ( Nil).
Definition lfind_example_6  := ( Cons (Succ (Succ Zero))         (Cons (Succ Zero) (Cons (Succ (Succ (Succ Zero))) Nil))).
Definition lfind_example_7  := ( Cons (Succ Zero) Nil).
Definition lfind_example_8  := ( Cons Zero (Cons (Succ Zero) (Cons Zero Nil))).
Definition lfind_example_9  := ( Nil).
Definition lfind_example_10  := ( Cons Zero (Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil)))).
Definition lfind_example_11  := ( Nil).
Definition lfind_example_12  := ( Cons Zero (Cons Zero (Cons (Succ Zero) Nil))).
Definition lfind_example_13  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_14  := ( Nil).
Definition lfind_example_15  := ( Nil).
Definition lfind_example_16  := ( Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil))).
Definition lfind_example_17  := ( Cons Zero (Cons (Succ Zero) (Cons (Succ Zero) Nil))).
Definition lfind_example_18  := ( Cons Zero (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_19  := ( Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)).
Definition lfind_example_20  := ( Cons Zero (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_21  := ( Cons (Succ Zero) (Cons Zero (Cons Zero Nil))).
Definition lfind_example_22  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_23  := ( Cons Zero (Cons (Succ Zero) (Cons Zero Nil))).
Definition lfind_example_24  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_25  := ( Cons Zero Nil).
Definition lfind_example_26  := ( Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)).
Definition lfind_example_27  := ( Nil).
Definition lfind_example_28  := ( Nil).
Definition lfind_example_29  := ( Nil).
Definition lfind_example_30  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_31  := ( Cons (Succ Zero) Nil).
Definition lfind_example_32  := ( Cons (Succ Zero) Nil).
Definition lfind_example_33  := ( Cons Zero Nil).
Definition lfind_example_34  := ( Nil).
Definition lfind_example_35  := ( Nil).
Definition lfind_example_36  := ( Nil).
Definition lfind_example_37  := ( Nil).
Definition lfind_example_38  := ( Cons Zero Nil).
Definition lfind_example_39  := ( Cons (Succ Zero) Nil).
Definition lfind_example_40  := ( Cons Zero Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal8_drop_Cons_assoc_33_drop_Cons/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 lfind_example_21 lfind_example_22 lfind_example_23 lfind_example_24 lfind_example_25 lfind_example_26 lfind_example_27 lfind_example_28 lfind_example_29 lfind_example_30 lfind_example_31 lfind_example_32 lfind_example_33 lfind_example_34 lfind_example_35 lfind_example_36 lfind_example_37 lfind_example_38 lfind_example_39 lfind_example_40 .


From Undecidability.FOL.Arithmetics Require Import FA Signature.
From Undecidability.FOL Require Import PA.
Require Import Lia List Vector.
Import Vector.VectorNotations.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Notation "x 'i=' y" := (i_atom (P:=Eq) [x ; y]) (at level 40) : PA_Notation.
Notation "'iO'" := (i_func (Σ_funcs:=PA_funcs_signature) (f:=Zero) []) (at level 2) : PA_Notation.
Notation "'iσ' d" := (i_func (Σ_funcs:=PA_funcs_signature) (f:=Succ) [d]) (at level 37) : PA_Notation.
Notation "x 'i⊕' y" := (i_func (f:=Plus) [x ; y]) (at level 39) : PA_Notation.
Notation "x 'i⊗' y" := (i_func (f:=Mult) [x ; y]) (at level 38) : PA_Notation.

Section FA_models.

  Variable D : Type.
  Variable I : interp D.

  Hypothesis ext_model : extensional I.
  Hypothesis FA_model : forall ax rho, List.In ax FA -> rho ⊨ ax.
  Arguments FA_model _ _ _ : clear implicits.

  (* # <a id="imu" /> #*)
  Fixpoint iμ k := match k with
                   | O => iO
                   | S n => iσ (iμ n)
                   end.

  Fact eval_num sigma n : eval sigma (num n) = iμ n.
  Proof.
    induction n.
    - reflexivity.
    - cbn. now rewrite IHn.
  Qed.

  Lemma add_zero : forall d : D, iO i⊕ d = d.
  Proof using ext_model FA_model.
    intros d.
    assert (List.In ax_add_zero FA) as H by firstorder.
    specialize (FA_model ax_add_zero (d.:(fun _ => iO)) H).
    cbn in FA_model. now apply ext_model.
  Qed.

  Lemma add_rec : forall n d : D, iσ n i⊕ d = iσ (n i⊕ d).
  Proof using ext_model FA_model.
    intros n d.
    assert (List.In ax_add_rec FA) as H by firstorder.
    specialize (FA_model ax_add_rec (d.:(fun _ => iO))  H).
    cbn in FA_model. now apply ext_model.
  Qed.

  Lemma mult_zero : forall d : D, iO i⊗ d = iO.
  Proof using ext_model FA_model.
    intros d.
    assert (List.In ax_mult_zero FA) as H by firstorder.
    specialize (FA_model ax_mult_zero (d.:(fun _ => iO)) H).
    cbn in FA_model. now apply ext_model.
  Qed.

  Lemma mult_rec : forall n d : D, iσ d i⊗ n = n i⊕ d i⊗ n.
  Proof using ext_model FA_model.
    intros n d.
    assert (List.In ax_mult_rec FA) as H by firstorder.
    specialize (FA_model ax_mult_rec (d.:(fun _ => iO)) H).
    cbn in FA_model. now apply ext_model.
  Qed.

  Corollary add_hom x y : iμ (x + y) = iμ x i⊕ iμ y.
  Proof using ext_model FA_model.
    induction x.
    - now rewrite add_zero.
    - change (iσ iμ (x + y) = iσ iμ x i⊕ iμ y).
      now rewrite add_rec, IHx.
  Qed.

  Corollary add_nat_to_model : forall x y z, x + y = z -> (iμ x i⊕ iμ y = iμ z).
  Proof using ext_model FA_model.
    intros x y z H. now rewrite <- add_hom, H.
  Qed.

  Corollary mult_hom x y : iμ (x * y) = iμ x i⊗ iμ y.
  Proof using ext_model FA_model.
    induction x.
    - now rewrite mult_zero.
    - change (iμ (y + x * y) = (iσ iμ x) i⊗ iμ y ).
      now rewrite add_hom, IHx, mult_rec.
  Qed.

  Corollary mult_nat_to_model : forall z x y, x * y = z -> (iμ x i⊗ iμ y = iμ z).
  Proof using ext_model FA_model.
    intros x y z H. now rewrite <- mult_hom, H.
  Qed.

End FA_models.

Arguments iμ {_ _} _.

Section PA_to_Q.

  Variable D : Type.
  Variable I : interp D.
  Notation "⊨ phi" := (forall rho, rho ⊨ phi) (at level 21).
  Variable axioms : forall ax, PAeq ax -> ⊨ ax.

  Lemma sat_Qeq : (forall ax, List.In ax Qeq -> ⊨ ax).
  Proof using axioms.
    intros x [<- |[<- |[<- |[<- |[<- |[<- |[<- |[<- |[<- |[<- |[<- |[<- |[<- |[]]]]]]]]]]]]]].
    1-10: apply axioms; apply PAeq_FA; cbn; eauto 15; fail.
    - apply axioms. apply PAeq_discr.
    - apply axioms. apply PAeq_inj.
    - intros ρ d. unfold ax_cases. evar (phi : form).
      specialize (axioms (PAeq_induction phi)) as Hax. cbn in Hax. apply Hax.
      + cbn. left. specialize (@axioms (∀ $0 == $0)). unshelve eapply axioms. 1:easy.
        apply PAeq_FA; cbn; eauto 15.
      + intros dd _. cbn. right. exists dd.
        specialize (@axioms (∀ $0 == $0)). unshelve eapply axioms. 1:easy.
        apply PAeq_FA; cbn; eauto 15.
  Qed.

End PA_to_Q.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e255m19_5limbs_donna.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import String.
Require Import Functors.
Require Import MonadLib.
Require Import Names.
Require Import PNames.
Require Import EffPure.
Require Import EffExcept.
Require Import EffReader.
Require Import Arith.
Require Import Lambda.
Require Import Lambda_Arith.
Require Import Exception.
Require Import Lambda_Exception.
Require Import ESoundER.

Section Test_Section.

  Definition D := AType :+: LType.
  Definition E (A : Set) := Arith :+: Lambda D A :+: ExceptE D.

  Global Instance Fun_E : forall (A : Set),
    Functor (E A).
  Proof.
    eauto with typeclass_instances.
  Defined.

  Definition V := StuckValue :+: NatValue :+: (ClosValue E).

  Variable MT : Set -> Set.
  Context `{Fail_MT : FailMonad MT}.
  Context {Inj_MT : InjMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.
  Context {MT_eq_dec : forall (A : Set) (mta : MT A),
    {exists a, mta = return_ a} + {mta = fail}}.

  Variable ME : Set -> Set.
  Context `{Mon_ME : Environment ME (list (Value V))}.
  Context {Fail_ME : FailMonad ME}.
  Context {FailEnvM : FailEnvironmentMonad (Env (Value V)) ME}.
  Context {Exception_ME : Exception ME Datatypes.unit}.
  Context {Reasonable_ME : Reasonable_Monad ME}.

  Definition EQV_E (A B : Set) := (Arith_eqv E A B) ::+:: (Lambda_eqv D E A B)
    ::+:: (Exception_eqv D E A B).

  Definition WFV := (WFValue_VI V D (list (Names.DType D)))
    ::+:: (WFValue_Clos D E MT V EQV_E _).

  Definition WFVM := (WFValueM_base D V MT ME _ WFV)
    ::+:: (WFValueM_Environment (TypContextCE := GammaTypContextCE _) D MT V ME _ WFV)
    ::+:: (WFValueM_Bot D V MT ME _)
    ::+:: (WFValueM_Except (TypContextCE := GammaTypContextCE _) D V MT ME _).

  Instance eval_alg : FAlgebra EvalName (Exp (E nat)) (evalMR V ME) (E nat).
  Proof.
    eauto 250 with typeclass_instances.
  Defined.

  Instance typeof_alg : forall T, FAlgebra TypeofName T (typeofR D MT) (E (DType D)).
  Proof.
    intros; eauto 150 with typeclass_instances.
  Defined.

  Instance eqv_soundness_X_alg eval_rec :
    iPAlgebra soundness_X'_Name
    (soundness_X'_P D V E MT ME _ EQV_E WFVM (fun e => typeof _ _ MT (proj1_sig e)) eval_rec
      (f_algebra (FAlgebra := typeof_alg _))
      (f_algebra (FAlgebra := eval_alg))) (EQV_E _ _).
  Proof.
    repeat apply iPAlgebra_Plus.
    apply eqv_soundness_X'_Arith_eqv with (WFV := WFV) (Fail_MT := Fail_MT)
      (TypContextCE := GammaTypContextCE _) (monad := monad0) (Sub_AType_D := _)
      (Sub_StuckValue_V := _) (Sub_NatValue_V := _);
      intros; eauto 550 with typeclass_instances.
    apply eqv_soundness_X'_Lambda_eqv with (WFV := WFV) (Fail_MT := Fail_MT)
      (TypContextCE := GammaTypContextCE _)
      (Environment_ME := Mon_ME) (Sub_LType_D := _)
      (Sub_StuckValue_V := _) (Sub_ClosValue_V := _)
      (eq_DType_DT := _); intros; eauto 550 with typeclass_instances.
    apply eqv_soundness_X'_Except_eqv with (TypContextCE := GammaTypContextCE _)
      (Fail_MT := Fail_MT) (Exception_ME := Exception_ME) (eq_DType_DT := _);
      intros; eauto 550 with typeclass_instances.
  Qed.

  Variable local_throw : forall (A : Set) f t,
    local f (throw t) = throw t (A := A).
  Variable local_catch : forall (A : Set) e h f,
    local f (catch (A := A) e h) = catch (local f e) (fun t => local f (h t)).
  Variable catch_fail : forall (A : Set) h,
    catch (A := A) fail h = fail.

    Context {throw_neq_fail : forall A t,
      throw (A := A) t <> fail (M := ME)}.

    Context {ME_eq_dec' : forall (A : Set) (mte : ME A) (gamma'' : list (Names.Value V)),
      (exists a : A,
        local (fun _ => gamma'') mte = return_ a) \/
      (local (fun _ => gamma'') mte = fail) \/
      (local (fun _ => gamma'') mte = throw tt)}.

  Instance Except_State_Sound_X_WFVM :
    iPAlgebra Except_Sound_X_Name (Except_Sound_X_P D V MT ME WFV) WFVM.
  Proof.
    eauto 850 with typeclass_instances.
  Qed.

  Theorem eval_Sound :
    forall (n : nat) Sigma gamma gamma' gamma'' e' e'',
      E_eqvC E EQV_E gamma' gamma e'' e' ->
      forall (WF_gamma : forall n b, lookup gamma' n = Some b ->
        exists T, lookup gamma b = Some T)
      (WF_gamma'' : WF_Environment _ _ _ WFV Sigma gamma'' gamma)
      (WF_gamma2 : List.length gamma = List.length gamma')
      (WF_gamma' : forall n b, lookup gamma' n = Some b -> b = n)
      (WF_Sigma : Gamma _ Sigma = gamma) (T : DType D),
      typeof D (E (DType D)) MT (proj1_sig e') = return_ T ->
      (local (M := ME) (fun _ => gamma'') (bevalM V E ME n e'') = fail) \/
      (exists t, local (M := ME) (fun _ => gamma'') (bevalM V E ME n e'') = throw t) \/
        exists v : Value V,
          local (M := ME) (fun _ => gamma'') (bevalM V E ME n e'') =
          return_ (M := ME) v /\ WFValueC _ _ _ WFV Sigma v T.
  Proof.
    intros.
    apply Except_Sound_X with (EQV_E := EQV_E) (WFVM' := WFVM) (Mon_MT := monad)
      (Typeof_E := typeof_alg) (gamma := gamma) (gamma' := gamma') (e' := e');
      eauto 250 with typeclass_instances.
  Qed.

  Open Scope string_scope.

  Eval compute in ("Type Soundness for Arith + Lambda + Exception Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


From Hammer Require Import Hammer.

Theorem injection_is_involution_in_Prop
(f : Prop -> Prop)
(inj : forall A B, (f A <-> f B) -> (A <-> B))
(ext : forall A B, A <-> B -> f A <-> f B)
: forall A, f (f A) <-> A.
Proof. hammer_hook "PropFacts" "PropFacts.injection_is_involution_in_Prop".
intros.
enough (f (f (f A)) <-> f A) by (apply inj; assumption).
split; intro H.
- now_show (f A).
enough (f A <-> True) by firstorder.
enough (f (f A) <-> f True) by (apply inj; assumption).
split; intro H'.
+ now_show (f True).
enough (f (f (f A)) <-> f True) by firstorder.
apply ext; firstorder.
+ now_show (f (f A)).
enough (f (f A) <-> True) by firstorder.
apply inj; firstorder.
- now_show (f (f (f A))).
enough (f A <-> f (f (f A))) by firstorder.
apply ext.
split; intro H'.
+ now_show (f (f A)).
enough (f A <-> f (f A)) by firstorder.
apply ext; firstorder.
+ now_show A.
enough (f A <-> A) by firstorder.
apply inj; firstorder.
Defined.


From Coq Require Import List.
Import List.ListNotations.
Open Scope list_scope.
From Coq Require Import Setoid.
From Coq Require Import Morphisms.
From Coq Require Import NPeano.
From Coq Require Import Omega.
From Coq Require Import Program.Tactics.

From Velus Require Import Common.
From Velus Require Import Environment.
From Velus Require Import Operators.
From Velus Require Import IndexedStreams.
From Velus Require Import CoindStreams.

Module Type INDEXEDTOCOIND
       (Import Op    : OPERATORS)
       (Import OpAux : OPERATORS_AUX Op)
       (Import IStr  : INDEXEDSTREAMS Op OpAux)
       (Import CStr  : COINDSTREAMS Op OpAux).

  (** * BASIC CORRESPONDENCES *)

  (** ** Definitions  *)

  (** A generic function to build a coinductive Stream. *)
  CoFixpoint init_from {A} (n: nat) (f: nat -> A) : Stream A :=
    f n ⋅ init_from (S n) f.

  (** Translate an indexed stream into a coinductive Stream.
        The [n]th element of the result Stream is the result of the application
        of the input stream on [n]. *)
  Definition tr_stream_from {A} (n: nat) (xs: stream A) : Stream A :=
    init_from n xs.

  Definition tr_stream {A} : stream A -> Stream A := tr_stream_from 0.

  (** Build a list of coinductive streams from an the integer range [0..m]. *)
  Definition seq_streams {A} (f: nat -> Stream A) (m: nat) : list (Stream A) :=
    List.map f (seq 0 m).

  (** Build the indexed stream corresponding to the [i]th elements of
        the input stream of lists. *)
  Definition streams_nth (k: nat) (xss: stream (list value)): stream value :=
    fun n => nth k (xss n) absent.

  (** Build a coinductive Stream extracting the [i]th element of the list
        obtained at each instant [n]. *)
  Definition nth_tr_streams_from (n: nat) (xss: stream (list value)) (k: nat)
    : Stream value :=
    tr_stream_from n (streams_nth k xss).

  (** Translate an indexed stream of list into a list of coinductive Streams
        using the two previous functions. *)
  Definition tr_streams_from (n: nat) (xss: stream (list value))
    : list (Stream value) :=
    seq_streams (nth_tr_streams_from n xss) (length (xss n)).

  Definition tr_streams: stream (list value) -> list (Stream value) :=
    tr_streams_from 0.

  Ltac unfold_tr_streams :=
    unfold tr_streams, tr_streams_from.

  (** Translate an history from indexed to coinductive world.
        Every element of the history is translated. *)
  Definition tr_history_from (n: nat) (H: IStr.history) : history :=
    Env.mapi (fun x _ => init_from n (fun n => match Env.find x (H n) with
                                         | Some v => v
                                         | None => absent
                                         end)) (H 0).

  (** Translate an history from coinductive to indexed world.
      Every element of the history is translated.
   *)
  Definition tr_history : IStr.history -> history :=
    tr_history_from 0.

  (** The counterpart of [tr_stream_from_tl] for histories. *)
  Lemma tr_history_from_tl:
    forall n H,
      history_tl (tr_history_from n H) = tr_history_from (S n) H.
  Proof.
    now setoid_rewrite Env.mapi_mapi.
  Qed.

  (** ** Properties  *)

  (** A basic definition-rewriting lemma.  *)
  Lemma init_from_n:
    forall {A} (f: nat -> A) n,
      init_from n f = f n ⋅ init_from (S n) f.
  Proof.
    intros; now rewrite unfold_Stream at 1.
  Qed.

  (** [init_from] is compatible wrt to extensional equality. *)
  Add Parametric Morphism A : (@init_from A)
      with signature eq ==> eq_str ==> @EqSt A
        as init_from_morph.
  Proof.
    cofix Cofix. intros x xs xs' E.
    rewrite init_from_n; rewrite (init_from_n xs').
    constructor; simpl; auto.
  Qed.

  (** The [m]th element of the built stream, starting from [n],
        is the result of the application of [f] at [(m+n)]. *)
  Lemma init_from_nth:
    forall {A} m n (f: nat -> A),
      (init_from n f) # m = f (m + n).
  Proof.
    unfold Str_nth; induction m; intros; simpl; auto.
    now rewrite IHm, <-plus_n_Sm.
  Qed.

  (** Taking the tail of a built Stream from [n] is building it from [S n]. *)
  Lemma init_from_tl:
    forall {A} n (f: nat -> A),
      tl (init_from n f) = init_from (S n) f.
  Proof.
    intros; rewrite init_from_n; auto.
  Qed.

  (** A generalization for multiple tails. *)
  Lemma init_from_nth_tl:
    forall {A} n m (f: nat -> A),
      Str_nth_tl n (init_from m f) = init_from (n + m) f.
  Proof.
    induction n; intros; simpl; auto.
    now rewrite IHn, Nat.add_succ_r.
  Qed.

  (** The length of the range-built list of Streams is simply the difference *)
  (*  between the bounds of the range.  *)
  Lemma seq_streams_length:
    forall {A} m (str: nat -> Stream A),
      length (seq_streams str m) = m.
  Proof.
    intros; unfold seq_streams.
    now rewrite map_length, seq_length.
  Qed.

  (** The [n]th element of the range-built list of Streams starting at 0 is *)
  (*  the result of the function at [n]. *)
  Lemma nth_seq_streams:
    forall {A} m str n (xs_d: Stream A),
      n < m ->
      nth n (seq_streams str m) xs_d = str n.
  Proof.
    unfold seq_streams; intros.
    rewrite map_nth' with (d':=0); simpl.
    - rewrite seq_nth; auto; omega.
    - rewrite seq_length; omega.
  Qed.

  Corollary nth_tr_streams_from_nth:
    forall n k xss xs_d,
      k < length (xss n) ->
      nth k (tr_streams_from n xss) xs_d =
      nth_tr_streams_from n xss k.
  Proof.
    unfold_tr_streams.
    intros; now rewrite nth_seq_streams.
  Qed.

  (** A generalization of [tr_stream_from_tl] for lists. *)
  Lemma tr_streams_from_tl:
    forall n xss,
      wf_streams xss ->
      List.map (@tl value) (tr_streams_from n xss) = tr_streams_from (S n) xss.
  Proof.
    intros * Len.
    apply Forall2_eq, Forall2_forall2.
    split; unfold_tr_streams; rewrite map_length.
    - now rewrite 2 seq_streams_length.
    - intros * Hlen E1 E2; rewrite <-E1, <-E2.
      rewrite map_nth' with (d':=a); auto.
      rewrite seq_streams_length in Hlen.
      rewrite 2 nth_seq_streams; try omega.
      + reflexivity.
      + rewrite (Len n); omega.
  Qed.

  Lemma tr_streams_from_length:
    forall n xss,
      length (tr_streams_from n xss) = length (xss n).
  Proof.
    unfold_tr_streams; intros.
    rewrite seq_streams_length; simpl; omega.
  Qed.

  (** If at instant [n], a property is true for all elements of the list *)
  (*  obtained from the indexed stream, then it is true for the first element *)
  (*  of the Streams starting at [n] in the translated list. *)
  Lemma Forall_In_tr_streams_from_hd:
    forall n P xss x,
      Forall P (xss n) ->
      In x (tr_streams_from n xss) ->
      P (hd x).
  Proof.
    unfold_tr_streams; intros * Ps Hin.
    apply In_nth with (d:=x) in Hin as (k & Len & Nth).
    rewrite seq_streams_length in Len.
    rewrite nth_seq_streams in Nth; auto.
    apply eq_EqSt in Nth.
    unfold nth_tr_streams_from in Nth.
    rewrite init_from_n in Nth.
    inversion Nth as (Hhd).
    rewrite <-Hhd; simpl.
    unfold streams_nth.
    eapply Forall_forall; eauto.
    apply nth_In; auto.
  Qed.

  Lemma Exists_In_tr_streams_from_hd:
    forall n P xss,
      List.Exists P (xss n) ->
      List.Exists (fun v => P (hd v)) (tr_streams_from n xss).
  Proof.
    intros * Hin.
    apply Exists_exists in Hin as (v & Hin & Hv).
    apply In_nth with (d:=absent) in Hin as (k & Len & Nth); subst.
    apply Exists_exists.
    exists (nth k (tr_streams_from n xss) (Streams.const absent)).
    split.
    - apply nth_In.
      rewrite tr_streams_from_length; auto.
    - rewrite nth_tr_streams_from_nth; auto.
  Qed.

  (** * SEMANTICS CORRESPONDENCE *)

  Lemma sem_var_impl_from:
    forall n H x xs,
      IStr.sem_var H x xs ->
      sem_var (tr_history_from n H) x (tr_stream_from n xs).
  Proof.
    unfold IStr.sem_var, IStr.lift', sem_var_instant.
    intros * Sem.
    econstructor.
    - unfold Env.MapsTo. setoid_rewrite Env.gmapi.
      rewrite Sem; simpl; eauto.
    - unfold tr_stream_from.
      apply ntheq_eqst; intro.
      now rewrite 2 init_from_nth, Sem.
  Qed.

  Corollary sem_var_impl:
    forall H x xs,
      IStr.sem_var H x xs ->
      sem_var (tr_history H) x (tr_stream xs).
  Proof. apply sem_var_impl_from. Qed.
  Hint Resolve sem_var_impl_from sem_var_impl.

  (** This tactic automatically uses the interpretor to give a witness stream. *)
  Ltac interp_str b H x Sem :=
    let Sem_x := fresh "Sem_" x in
    let sol sem interp sound :=
        assert (sem b H x (interp b H x)) as Sem_x
            by (intro; match goal with n:nat |- _ => specialize (Sem n) end;
                unfold interp, lift_interp; inv Sem; erewrite <-sound; eauto)
    in
    let sol' sem interp sound :=
        assert (sem H x (interp H x)) as Sem_x
            by (intro; match goal with n:nat |- _ => specialize (Sem n) end;
                unfold interp, lift_interp'; inv Sem; erewrite <-sound; eauto)
    in
    match type of x with
    | ident => sol' IStr.sem_var interp_var interp_var_instant_sound
    | clock => sol IStr.sem_clock interp_clock interp_clock_instant_sound
    end.

  (** An inversion principle for [sem_clock] which also uses the interpretor. *)
  Lemma sem_clock_inv:
    forall H b bs ck x k,
      IStr.sem_clock b H (Con ck x k) bs ->
      exists bs' xs,
        IStr.sem_clock b H ck bs'
        /\ IStr.sem_var H x xs
        /\
        (forall n,
            (exists c,
                bs' n = true
                /\ xs n = present c
                /\ val_to_bool c = Some k
                /\ bs n = true)
            \/
            (bs' n = false
             /\ xs n = absent
             /\ bs n = false)
            \/
            (exists c,
                bs' n = true
                /\ xs n = present c
                /\ val_to_bool c = Some (negb k)
                /\ bs n = false)
        ).
  Proof.
    intros * Sem.
    interp_str b H ck Sem.
    interp_str b H x Sem.
    do 2 eexists; intuition; eauto.
       specialize (Sem_ck n); specialize (Sem_x n); specialize (Sem n); inv Sem.
       - left; exists c; repeat split; auto; intuition sem_det.
       - right; left; repeat split; auto; intuition sem_det.
       - right; right; exists c; intuition; try sem_det.
         now rewrite Bool.negb_involutive.
  Qed.

  (** We can then deduce the correspondence lemma for [sem_clock].
        We go by induction on the clock [ck] then we use the above inversion
        lemma. *)
  Corollary sem_clock_impl_from:
    forall H b ck bs,
      IStr.sem_clock b H ck bs ->
      forall n, sem_clock (tr_history_from n H) (tr_stream_from n b) ck
                     (tr_stream_from n bs).
  Proof.
    induction ck; intros * Sem n.
    - constructor.
      revert Sem n; cofix CoFix; intros.
      rewrite init_from_n; rewrite (init_from_n bs).
      constructor; simpl; auto.
      specialize (Sem n); now inv Sem.
    - apply sem_clock_inv in Sem as (bs' & xs & Sem_bs' & Sem_xs & Spec).
      revert Spec n; cofix CoFix; intros.
      rewrite (init_from_n bs).
      apply IHck with (n:=n) in Sem_bs';
        rewrite (init_from_n bs') in Sem_bs'.
      apply (sem_var_impl_from n) in Sem_xs;
        rewrite (init_from_n xs) in Sem_xs.
      destruct (Spec n) as [|[]]; destruct_conjs;
        repeat match goal with H:_ n = _ |- _ => rewrite H in *; clear H end.
      + econstructor; eauto.
        rewrite init_from_tl, tr_history_from_tl; auto.
      + econstructor; eauto.
        rewrite init_from_tl, tr_history_from_tl; auto.
      + rewrite <-(Bool.negb_involutive b0).
        eapply Son_abs2; eauto.
        rewrite init_from_tl, tr_history_from_tl; auto.
        rewrite Bool.negb_involutive; auto.
  Qed.
  Hint Resolve sem_clock_impl_from.

  Corollary sem_clock_impl:
    forall H b ck bs,
      IStr.sem_clock b H ck bs ->
      sem_clock (tr_history H) (tr_stream b) ck (tr_stream bs).
  Proof. intros; apply sem_clock_impl_from; auto. Qed.
  Hint Resolve sem_clock_impl.

End INDEXEDTOCOIND.

Module IndexedToCoindFun
       (Op      : OPERATORS)
       (OpAux   : OPERATORS_AUX          Op)
       (IStr    : INDEXEDSTREAMS         Op OpAux)
       (CStr    : COINDSTREAMS           Op OpAux)
<: INDEXEDTOCOIND Op OpAux IStr CStr.
  Include INDEXEDTOCOIND Op OpAux IStr CStr.
End IndexedToCoindFun.


Inductive BTree (A : Type) : Type :=
| E : BTree A
| N : A -> BTree A -> BTree A -> BTree A.

Arguments E {A}.
Arguments N {A} _ _ _.

(*Parameter elem : forall A : Type, A -> BTree A -> Prop.

Parameter elem_decb :
  {A : LinDec} (x : A) (t : BTree A) : bool.
Parameter isHeap {A : LinDec} : BTree A -> Prop.*)

(** Helper constructors. *)
Parameter leaf : forall A : Type, A -> BTree A.

(** Basic observers *)
Parameter isEmpty : forall A : Type, BTree A -> bool.

Parameter root : forall A : Type, BTree A -> option A.
Parameter left : forall A : Type, BTree A -> option (BTree A).
Parameter right : forall A : Type, BTree A -> option (BTree A).

Parameter unN : forall A : Type, BTree A -> option (A * BTree A * BTree A).

Parameter size : forall A : Type, BTree A -> nat.
Parameter height : forall A : Type, BTree A -> nat.

Parameter leftmost : forall A : Type, BTree A -> option A.
Parameter rightmost : forall A : Type, BTree A -> option A.

Parameter inorder : forall A : Type, BTree A -> list A.
Parameter preorder : forall A : Type, BTree A -> list A.
Parameter postorder : forall A : Type, BTree A -> list A.

Parameter bfs_aux :
  forall A : Type, list (BTree A) -> list A -> list A.

Parameter bfs : forall A : Type, BTree A -> list A.

(** Basic operations *)
Parameter mirror' : forall A : Type, BTree A -> BTree A.

Fixpoint mirror {A : Type} (t : BTree A) : BTree A :=
match t with
| E => E
| N v l r => N v (mirror r) (mirror l)
end.

(*
From Typonomikon Require Import H2.

Lemma mirror_bijective :
  forall A : Type, bijective (@mirror A).
Proof.
  unfold bijective, injective, surjective. split.
    induction x; destruct x'; cbn; inversion 1; subst; clear H.
      reflexivity.
      rewrite (IHx1 _ H3), (IHx2 _ H2). reflexivity.
    induction b.
      exists E. cbn. reflexivity.
      destruct IHb1 as [r Hr], IHb2 as [l Hl].
        exists (N a l r). cbn. rewrite Hl, Hr. reflexivity.
Qed.
*)

(** like replicate *)
Parameter complete : forall A : Type, nat -> A -> BTree A.

Parameter iterate : forall A : Type, (A -> A) -> nat -> A -> BTree A.

Parameter index : forall A : Type, list bool -> BTree A -> option A.
Parameter nth : forall A : Type, nat -> BTree A -> option A.

Parameter take : forall A : Type, nat -> BTree A -> BTree A.
Parameter drop : forall A : Type, nat -> BTree A -> list (BTree A).
Parameter takedrop :
  forall A : Type, nat -> BTree A -> BTree A * list (BTree A).

Parameter intersperse : forall A : Type, A -> BTree A -> BTree A.

Parameter insertAtLeaf :
  forall A : Type, list bool -> BTree A -> BTree A.

(** Operacje z predykatem boolowskim. *)
Parameter any : forall A : Type, (A -> bool) -> BTree A -> bool.
Parameter all : forall A : Type, (A -> bool) -> BTree A -> bool.

Parameter find : forall A : Type, (A -> bool) -> BTree A -> option A.
Parameter findIndex :
  forall A : Type, (A -> bool) -> BTree A -> option (list bool).

Parameter count : forall A : Type, (A -> bool) -> BTree A -> nat.

Parameter takeWhile : forall A : Type, (A -> bool) -> BTree A -> BTree A.

Parameter findIndices :
  forall A : Type, (A -> bool) -> BTree A -> list (list bool).

(** Operacje z funkcją. *)
Parameter map : forall A B : Type, (A -> B) -> BTree A -> BTree B.

Parameter zipWith :
  forall A B C : Type, (A -> B -> C) -> BTree A -> BTree B -> BTree C.

Parameter unzipWith :
 forall A B C : Type, (A -> B * C) -> BTree A -> BTree B * BTree C.

(** foldy i scany *)

(** Predykaty *)

Parameter Elem : forall A : Type, A -> BTree A -> Prop.

Parameter Any : forall A : Type, (A -> Prop) -> BTree A -> Prop.
Parameter All : forall A : Type, (A -> Prop) -> BTree A -> Prop.

Parameter Dup : forall A : Type, BTree A -> Prop.

Parameter Exactly : forall A : Type, (A -> Prop) -> nat -> BTree A -> Prop.
Parameter AtLeast : forall A : Type, (A -> Prop) -> nat -> BTree A -> Prop.
Parameter AtMost : forall A : Type, (A -> Prop) -> nat -> BTree A -> Prop.

Parameter SameStructure : forall A B : Type, BTree A -> BTree B -> Prop.
Parameter SameShape : forall A B : Type, BTree A -> BTree B -> Prop.

Parameter subtree : forall A : Type, BTree A -> BTree A -> Prop.
Parameter Subterm : forall A : Type, BTree A -> BTree A -> Prop.


Set Implicit Arguments.
Require Import List Lia.
Import ListNotations.
From Undecidability.HOU Require Import calculus.terms calculus.prelim std.std.

Set Default Proof Using "Type".

(* * Syntax *)
Definition isVar X (e: exp X) :=
  match e with var _ => True | _ => False end.

Definition isLam X (e: exp X) :=
  match e with lambda _ => True | _ => False end.

Definition isApp X (e: exp X) :=
  match e with app _ _ => True | _ => False end.

Definition isAtom X (e: exp X) :=
  match e with lambda _ => False | app _ _ => False | _ => True end.

Ltac syn :=
  match goal with
  | [H1: isVar ?X, H2: isLam ?X |- _] => solve [destruct X; cbn in *; intuition]
  | [H1: isVar ?X, H2: isApp ?X |- _] => solve [destruct X; cbn in *; intuition]
  | [H1: isApp ?X, H2: isLam ?X |- _] => solve [destruct X; cbn in *; intuition]
  | [H1: isApp ?X, H2: isAtom ?X |- _] => solve [destruct X; cbn in *; intuition]
  | [H1: isLam ?X, H2: isAtom ?X |- _] => solve [destruct X; cbn in *; intuition]
  | [ |- isLam (lambda _)] => constructor
  | [ |- isApp (app _ _)] => constructor
  | [ |- isAtom (var _)] => constructor
  | [ |- isAtom (const _)] => constructor
  | [ |- isVar (var _)] => constructor
  end.

(* ** Atoms *)
Section Atoms.

  Variable (X: Const).

  Lemma atom_lifting (s: exp X) (sigma: fin -> exp X):
    (forall x, isAtom (sigma x)) -> isAtom s -> isAtom (sigma • s).
  Proof.
    induction s in sigma |-*; cbn; intuition.
  Qed.

  Lemma atom_var (s: exp X):
    isVar s -> isAtom s.
  Proof.
    destruct s; cbn in *; intuition.
  Qed.

End Atoms.

Ltac atom :=
  match goal with
  | [ |- isAtom _] => cbn in *; intuition
  end.

#[export] Hint Extern 4 => syn : core.

Section DiscreteTypes.

  Global Instance Const_dis (C: Const) : Dis C.
  Proof.
    eapply const_dis.
  Qed.

  Global Instance exp_dis X: Dis (exp X).
  Proof.
    intros ??; unfold Dec; decide equality. decide equality. eapply const_dis.
  Qed.

  Global Instance type_dis: Dis type.
  Proof.
    intros ??; unfold Dec; decide equality; decide equality.
  Qed.

End DiscreteTypes.

(* ** Applicative Head *)
Section ApplicativeHead.

  Variable (X: Const).

  Fixpoint head (e: exp X) :=
    match e with
    | const b => const b
    | var x => var x
    | lambda s => lambda s
    | app e1 e2 => head e1
    end.

  Lemma var_head (s: exp X):
    isVar s -> isVar (head s).
  Proof.
    destruct s; cbn; intuition.
  Qed.

  Lemma atom_head (s: exp X):
    isAtom s -> isAtom (head s).
  Proof.
    destruct s; cbn; intuition.
  Qed.

  Lemma atom_head_lifting (s: exp X) (sigma: fin -> exp X):
    (forall x, isAtom (head (sigma x))) -> isAtom (head s) -> isAtom (head (sigma • s)).
  Proof.
    induction s; cbn; intuition.
  Qed.

  Lemma head_subst (s: exp X) sigma:
   (forall x, ~ isApp (sigma x))  -> sigma • (head s) = head (sigma • s).
  Proof.
    intros H; induction s.
    - cbn; specialize (H f).
      destruct (sigma f); cbn in *; intuition.
    - reflexivity.
    - reflexivity.
    - cbn; congruence.
  Qed.

End ApplicativeHead.

#[export] Hint Resolve atom_var var_head atom_head : core.

(* ** Type Functions *)
Section TypeFunctions.

  Fixpoint target (A: type) :=
    match A with
    | typevar beta => typevar beta
    | A → B => target B
    end.

  Definition target' (Gamma: list type) :=  map target Gamma.

  Fixpoint arity (A: type) :=
    match A with
    | typevar _ => 0
    | A → B => S (arity B)
    end.

End TypeFunctions.

(* ** Free Variables *)
Section FreeVariables.
  Context {X: Const}.

  Fixpoint vars (s: exp X) :=
    match s with
    | var x => [x]
    | const x => nil
    | lambda s => map pred (remove eq_dec 0 (vars s))
    | app s1 s2 => vars s1 ++ vars s2
    end.

  Inductive varof (x: nat) : exp X -> Prop :=
  | varofVar: varof x (var x)
  | varofAppL (s t: exp X): varof x s -> varof x (s t)
  | varofAppR (s t: exp X): varof x t -> varof x (s t)
  | varofLambda s: varof (S x) s -> varof x (lambda s).

  Hint Constructors varof : core.

  Lemma varof_vars x s:
    varof x s -> x ∈ vars s.
  Proof.
    induction 1; cbn; eauto.
    1 - 2: eapply in_app_iff; intuition.
    eapply in_map_iff. exists (S x). intuition.
    eapply remove_remain; eauto.
  Qed.

  Lemma vars_varof x s:
    x ∈ vars s -> varof x s.
  Proof.
    induction s in x |-*; cbn; intuition.
    - subst; eauto.
    - econstructor. eapply IHs.
      mapinj. destruct x0.
      + eapply remove_In in H1; intuition.
      + cbn. now eapply remove_prev in H1.
    - simplify in H; intuition.
  Qed.

  Hint Resolve varof_vars vars_varof : core.

  Global Instance dec_varof: Dec2 (varof).
  Proof.
    intros x s; eapply iff_dec with (P := x ∈ vars s);
      intuition; eauto.
  Qed.

  Lemma subst_extensional sigma tau s:
    (forall x, x ∈ vars s -> sigma x = tau x) -> sigma • s = tau • s.
  Proof.
    induction s in sigma, tau |-*; eauto.
    - intros H; cbn; f_equal; eapply IHs.
      intros [] ?; cbn; eauto.
      unfold funcomp; rewrite H; eauto.
    - intros; cbn; erewrite IHs1, IHs2; eauto.
  Qed.

  Lemma varof_ren f x (s: exp X):
    varof x (ren f s) -> exists y, x = f y /\ varof y s.
  Proof.
    induction s in x, f |-*; cbn; intuition.
    - exists f0; intuition. now inv H.
    - inv H.
    - inv H. eapply IHs in H1 as [].
      intuition. destruct x0; try discriminate.
      exists x0. intuition.
    - inv H; [edestruct IHs1 | edestruct IHs2]; eauto; eexists; intuition; eauto.
  Qed.

  Lemma vars_ren f x s:
    x ∈ vars (ren f s) -> exists y, x = f y /\ y ∈ vars s.
  Proof.
    intros; edestruct varof_ren as [y]; [|exists y]; intuition; eauto.
  Qed.

  Lemma varof_subst x sigma (s: exp X):
    varof x (sigma • s) -> exists y, varof y s /\ varof x (sigma y).
  Proof.
    induction s in sigma, x |-*; cbn.
    - intros; exists f; intuition.
    - inversion 1.
    - intros H; inv H. eapply IHs in H1 as []; intuition.
      destruct x0; cbn in *. inv H1.
      exists (x0); intuition. unfold funcomp in H1.
      now eapply varof_ren in H1 as [y [[= ->] ?]].
    - intros H; inv H; [edestruct IHs1 | edestruct IHs2]; eauto; eexists; intuition; eauto.
  Qed.

    Lemma vars_subst sigma x s:
    x ∈ vars (sigma • s) -> exists y, y ∈ vars s /\ x ∈ vars (sigma y).
  Proof.
    intros; edestruct varof_subst as [y]; [|exists y]; intuition; eauto.
  Qed.

  Lemma ren_varof x f (s: exp X):
    varof x s -> varof (f x) (ren f s).
  Proof.
    enough (varof x s -> forall y, y = f x -> varof y (ren f s)) by eauto.
    induction 1 in f |-*; cbn; eauto.
    - intros ? ->; eauto.
    - intros ? ->; econstructor; now eapply IHvarof.
  Qed.

  Lemma ren_vars x f (s: exp X):
    x ∈ vars s -> f x ∈ vars (ren f s).
  Proof.
    eauto using ren_varof.
  Qed.

  Lemma subst_varof x sigma y (s: exp X):
    varof y s -> varof x (sigma y) -> varof x (sigma • s).
  Proof.
    induction 1 in sigma, x |-*; cbn; eauto.
    intros H'; econstructor; eapply IHvarof; cbn; unfold funcomp.
    now eapply ren_varof.
  Qed.

  Lemma subst_vars x sigma y (s: exp X):
    y ∈ vars s -> x ∈ vars (sigma y) -> x ∈ vars (sigma • s).
  Proof.
    eauto using subst_varof.
  Qed.

End FreeVariables.

#[export] Hint Constructors varof : core.
#[export] Hint Resolve varof_vars vars_varof : core.


Require Import String List Program.Equality.
Require Import syntax.
Set Implicit Arguments.

Definition heap_context := list heap_var.
Definition prop_context := list proposition.

Definition var_binding := (var * type)%type.
Definition var_context := list var_binding.

Inductive in_var_context : var -> var_context -> Prop :=
| InHead : forall x A D, in_var_context x ((x,A)::D)
| InTail : forall x y A D, in_var_context x D -> in_var_context x ((y,A)::D).

Fixpoint delete x D : var_context :=
  match D with
  | nil => nil
  | (y,A)::D' => let D'' := delete x D' in if var_dec x y then D'' else (y,A)::D''
  end.

Lemma nin_nil : forall x, ~ in_var_context x nil.
Proof.
  intros; inversion 1.
Qed.
Lemma neq_in : forall x y A D, x <> y -> in_var_context x ((y,A)::D) -> in_var_context x D.
  intros; inversion H0; try contradiction; auto.
Qed.

Definition in_context_dec : forall x D, {in_var_context x D} + {~ in_var_context x D}.
  refine (fix var_in_dec x D :=
  match D as D0 return {in_var_context x D0} + {~ in_var_context x D0} with
  | nil => right _
  | (y,A)::D' => if var_dec x y then left _ else
    if var_in_dec x D' then left _ else right _
  end).
  inversion 1.
  destruct _H; apply InHead.
  apply InTail; auto.
  intro H. inversion H; contradiction.
Defined.

Definition get : forall x D, in_var_context x D -> type.
  refine (fix get x D :=
  match D as D0 return in_var_context x D0 -> type with
  | nil => fun pf => match nin_nil pf with end
  | (y,A)::D' => if var_dec x y then fun _ => A else fun _ => get x D' _
  end).
  apply neq_in with y A; auto.
Defined.
Implicit Arguments get [].

Fixpoint get_dec (x:var) (D : var_context) : option type :=
  match D with
  | nil => None
  | (y,A)::D' => if string_dec x y then Some A else get_dec x D'
  end.

Lemma get_pf_irrelevance : forall x D (pf1 pf2 : in_var_context x D), get x D pf1 = get x D pf2.
Proof.
  induction D; intros; simpl.
    destruct (nin_nil pf1).
  destruct a as [y A].
  destruct (var_dec x y); auto.
Qed.

Lemma get_neq : forall x y A D pf pf',
                x <> y -> get x D pf = get x ((y,A)::D) pf'.
  intros. rewrite get_pf_irrelevance with _ _ _ (InTail y A pf).
  revert pf pf' H.
  induction D as [ | [z B]]; intros; simpl; auto.
  (*nil*) destruct (var_dec x y); auto. absurd (x=y); auto.
    destruct (nin_nil pf).
  (*cons*) simpl; destruct (var_dec x z); destruct (var_dec x y); auto;
    try (absurd (x=y); auto; fail).
    rewrite IHD; auto. simpl.
    destruct (var_dec x y); auto; try (absurd (x=y); auto; fail).
    apply get_pf_irrelevance.
    constructor; auto.
    inversion pf; auto.
    absurd (x=z); auto.
Qed.
Hint Resolve get_neq.

Definition domain_subset VC1 VC2 : Prop :=
  forall x, in_var_context x VC1 -> in_var_context x VC2.
Definition domain_equiv VC1 VC2 : Prop :=
  forall x, in_var_context x VC1 <-> in_var_context x VC2.
Definition vals_equiv VC1 VC2 : Prop :=
  forall x pf1 pf2, get x VC1 pf1 = get x VC2 pf2.
Definition var_context_subset VC1 VC2 : Prop :=
  domain_subset VC1 VC2 /\ vals_equiv VC1 VC2.
Definition var_context_equiv VC1 VC2 : Prop :=
  domain_equiv VC1 VC2 /\ vals_equiv VC1 VC2.

Lemma equiv_nil_nil : forall VC, var_context_equiv VC nil ->
                      VC = nil.
Proof.
  destruct VC as [ | (x,A) VC]; intros; auto.
  absurd (in_var_context x nil).
    inversion 1.
    destruct H as [H H']. apply H. apply InHead.
Qed.

Lemma equiv_refl : forall VC, var_context_equiv VC VC.
Proof.
  split.
  (*domain_equiv*) split; auto.
  (*vals_equiv*) intros x pf1 pf2; apply get_pf_irrelevance.
Qed.

Lemma equiv_symm : forall VC1 VC2,
      var_context_equiv VC1 VC2 ->
      var_context_equiv VC2 VC1.
Proof.
  destruct 1.
  split; auto.
  (*domain_equiv*) split; apply H.
  (*vals_equiv*) intros x pf1 pf2. rewrite H0 with _ _ pf1; auto.
Qed.

Lemma equiv_trans : forall VC1 VC2 VC3,
      var_context_equiv VC1 VC2 ->
      var_context_equiv VC2 VC3 ->
      var_context_equiv VC1 VC3.
Proof.
  do 2 destruct 1. split.
  (*domain_equiv*) split; intros. apply H1; apply H; auto.
    apply H; apply H1; auto.
  (*vals_equiv*) intros x pf1 pf3.
    assert (pf2 : in_var_context x VC2).
      apply H; auto.
    rewrite H0 with _ _ pf2. apply H2.
Qed.

Lemma equiv_cons : forall VC1 VC2 x A,
      var_context_equiv VC1 VC2 ->
      var_context_equiv ((x,A)::VC1) ((x,A)::VC2).
Proof.
  destruct 1; split.
  (*domain_equiv*) intro z; split; intros.
    (*->*) destruct (var_dec x z); [
      (*x=z*) rewrite e in *; clear x e; apply InHead |
      (*x<>z*) apply InTail; inversion H1; auto;
        [ absurd (x=z); auto | apply H; auto ] ].
    (*<-*) destruct (var_dec x z); [
      (*x=z*) rewrite e in *; clear x e; apply InHead |
      (*x<>z*) apply InTail; inversion H1; auto;
        [ absurd (x=z); auto | apply H; auto ] ].
  (*vals_equiv*) intros z pf1 pf2; simpl.
    destruct (var_dec z x); auto.
Qed.
Hint Resolve equiv_cons.


Require
  MathClasses.varieties.monoids MathClasses.theory.groups MathClasses.theory.strong_setoids.
Require Import
  Coq.setoid_ring.Ring MathClasses.interfaces.abstract_algebra.

Definition is_ne_0 `(x : R) `{Equiv R} `{Zero R} `{p : PropHolds (x ≠ 0)} : x ≠ 0 := p.
Definition is_nonneg `(x : R) `{Equiv R} `{Le R} `{Zero R} `{p : PropHolds (0 ≤ x)} : 0 ≤ x := p.
Definition is_pos `(x : R) `{Equiv R} `{Lt R} `{Zero R} `{p : PropHolds (0 < x)} : 0 < x := p.

Lemma stdlib_semiring_theory R `{SemiRing R} : Ring_theory.semi_ring_theory 0 1 (+) (.*.) (=).
Proof.
  constructor; intros.
         apply left_identity.
        apply commutativity.
       apply associativity.
      apply left_identity.
     apply left_absorb.
    apply commutativity.
   apply associativity.
  rewrite commutativity, distribute_l.
  now setoid_rewrite commutativity at 2 3.
Qed.

(* We cannot apply [left_cancellation (.*.) z] directly in case we have
  no [PropHolds (0 ≠ z)] instance in the context. *)
Section cancellation.
  Context `{Ae : Equiv A} (op : A → A → A) `{!Zero A}.

  Lemma left_cancellation_ne_0 `{∀ z, PropHolds (z ≠ 0) → LeftCancellation op z} z : z ≠ 0 → LeftCancellation op z.
  Proof. auto. Qed.

  Lemma right_cancellation_ne_0 `{∀ z, PropHolds (z ≠ 0) → RightCancellation op z} z : z ≠ 0 → RightCancellation op z.
  Proof. auto. Qed.

  Lemma right_cancel_from_left `{!Setoid A} `{!Commutative op} `{!LeftCancellation op z} :
    RightCancellation op z.
  Proof.
    intros x y E.
    apply (left_cancellation op z).
    now rewrite 2!(commutativity z _).
  Qed.
End cancellation.

Section strong_cancellation.
  Context `{StrongSetoid A} (op : A → A → A).

  Lemma strong_right_cancel_from_left `{!Commutative op} `{!StrongLeftCancellation op z} :
    StrongRightCancellation op z.
  Proof.
    intros x y E.
    rewrite 2!(commutativity _ z).
    now apply (strong_left_cancellation op z).
  Qed.

  Global Instance strong_left_cancellation_cancel `{!StrongLeftCancellation op z} : LeftCancellation op z | 20.
  Proof.
    intros x y. rewrite <-!tight_apart. intros E1 E2.
    destruct E1. now apply (strong_left_cancellation op).
  Qed.

  Global Instance strong_right_cancellation_cancel `{!StrongRightCancellation op z} : RightCancellation op z | 20.
  Proof.
    intros x y. rewrite <-!tight_apart. intros E1 E2.
    destruct E1. now apply (strong_right_cancellation op).
  Qed.
End strong_cancellation.

Section semiring_props.
  Context `{SemiRing R}.
  Add Ring SR : (stdlib_semiring_theory R).

  Instance mult_ne_0 `{!NoZeroDivisors R} x y : PropHolds (x ≠ 0) → PropHolds (y ≠ 0) → PropHolds (x * y ≠ 0).
  Proof.
    intros Ex Ey Exy.
    unfold PropHolds in *.
    apply (no_zero_divisors x); split; eauto.
  Qed.

  Global Instance plus_0_r: RightIdentity (+) 0 := right_identity.
  Global Instance plus_0_l: LeftIdentity (+) 0 := left_identity.
  Global Instance mult_1_l: LeftIdentity (.*.) 1 := left_identity.
  Global Instance mult_1_r: RightIdentity (.*.) 1 := right_identity.

  Global Instance plus_assoc: Associative (+) := simple_associativity.
  Global Instance mult_assoc: Associative (.*.) := simple_associativity.

  Global Instance plus_comm: Commutative (+) := commutativity.
  Global Instance mult_comm: Commutative (.*.) := commutativity.

  Global Instance mult_0_l: LeftAbsorb (.*.) 0 := left_absorb.

  Global Instance mult_0_r: RightAbsorb (.*.) 0.
  Proof. intro. ring. Qed.

  Global Instance: RightDistribute (.*.) (+).
  Proof. intros x y z. ring. Qed.

  Lemma plus_mult_distr_r x y z: (x + y) * z = x * z + y * z. Proof. ring. Qed.
  Lemma plus_mult_distr_l x y z: x * (y + z) = x * y + x * z. Proof. ring. Qed.

  Global Instance: ∀ r : R, @Monoid_Morphism R R _ _ (0:R) (0:R) (+) (+) (r *.).
  Proof.
   repeat (constructor; try apply _).
    apply distribute_l.
   apply right_absorb.
  Qed.
End semiring_props.

(* Due to bug #2528 *)
#[global]
Hint Extern 3 (PropHolds (_ * _ ≠ 0)) => eapply @mult_ne_0 : typeclass_instances.

Section semiringmor_props.
  Context `{SemiRing_Morphism A B f}.

  Lemma preserves_0: f 0 = 0.
  Proof (preserves_mon_unit (f:=f)).
  Lemma preserves_1: f 1 = 1.
  Proof (preserves_mon_unit (f:=f)).
  Lemma preserves_mult: ∀ x y, f (x * y) = f x * f y.
  Proof. intros. apply preserves_sg_op. Qed.
  Lemma preserves_plus: ∀ x y, f (x + y) = f x + f y.
  Proof. intros. apply preserves_sg_op. Qed.

  Instance: SemiRing B := semiringmor_b.

  Lemma preserves_2: f 2 = 2.
  Proof. rewrite preserves_plus. now rewrite preserves_1. Qed.

  Lemma preserves_3: f 3 = 3.
  Proof. now rewrite ?preserves_plus, ?preserves_1. Qed.

  Lemma preserves_4: f 4 = 4.
  Proof. now rewrite ?preserves_plus, ?preserves_1. Qed.

  Context `{!Injective f}.
  Instance injective_ne_0 x : PropHolds (x ≠ 0) → PropHolds (f x ≠ 0).
  Proof. intros. rewrite <-preserves_0. now apply (jections.injective_ne f). Qed.

  Lemma injective_ne_1 x : x ≠ 1 → f x ≠ 1.
  Proof. intros. rewrite <-preserves_1. now apply (jections.injective_ne f). Qed.
End semiringmor_props.

(* Due to bug #2528 *)
#[global]
Hint Extern 12 (PropHolds (_ _ ≠ 0)) => eapply @injective_ne_0 : typeclass_instances.

Lemma stdlib_ring_theory R `{Ring R} :
  Ring_theory.ring_theory 0 1 (+) (.*.) (λ x y, x - y) (-) (=).
Proof.
 constructor; intros.
         apply left_identity.
        apply commutativity.
       apply associativity.
      apply left_identity.
     apply commutativity.
    apply associativity.
   rewrite commutativity, distribute_l.
   now setoid_rewrite commutativity at 2 3.
  reflexivity.
 apply (right_inverse x).
Qed.

Section ring_props.
  Context `{Ring R}.

  Add Ring R: (stdlib_ring_theory R).

  Instance: LeftAbsorb (.*.) 0.
  Proof. intro. ring. Qed.

  Global Instance Ring_Semi: SemiRing R.
  Proof. repeat (constructor; try apply _). Qed.

  Definition negate_involutive x : - - x = x := groups.negate_involutive x. (* alias for convinience *)
  Lemma plus_negate_r x : x + -x = 0. Proof. ring. Qed.
  Lemma plus_negate_l x : -x + x = 0. Proof. ring. Qed.
  Lemma negate_swap_r x y : x - y = -(y - x). Proof. ring. Qed.
  Lemma negate_swap_l x y : -x + y = -(x - y). Proof. ring. Qed.
  Lemma negate_plus_distr x y : -(x + y) = -x + -y. Proof. ring. Qed.
  Lemma negate_mult x : -x = -1 * x. Proof. ring. Qed.
  Lemma negate_mult_distr_l x y : -(x * y) = -x * y. Proof. ring. Qed.
  Lemma negate_mult_distr_r x y : -(x * y) = x * -y. Proof. ring. Qed.
  Lemma negate_mult_negate x y : -x * -y = x * y. Proof. ring. Qed.
  Lemma negate_0: -0 = 0. Proof. ring. Qed.

  Global Instance minus_0_r: RightIdentity (λ x y, x - y) 0.
  Proof. intro x; rewrite negate_0; apply plus_0_r. Qed.

  Lemma equal_by_zero_sum x y : x - y = 0 ↔ x = y.
  Proof.
    split; intros E.
     rewrite <- (plus_0_l y). rewrite <- E. ring.
    rewrite E. ring.
  Qed.

  Lemma flip_negate x y : -x = y ↔ x = -y.
  Proof. split; intros E. now rewrite <-E, involutive. now rewrite E, involutive. Qed.

  Lemma flip_negate_0 x : -x = 0 ↔ x = 0.
  Proof. now rewrite flip_negate, negate_0. Qed.

  Lemma flip_negate_ne_0 x : -x ≠ 0 ↔ x ≠ 0.
  Proof. split; intros E ?; apply E; now apply flip_negate_0. Qed.

  Lemma negate_zero_prod_l x y : -x * y = 0 ↔ x * y = 0.
  Proof.
    split; intros E.
     apply (injective (-)). now rewrite negate_mult_distr_l, negate_0.
    apply (injective (-)). now rewrite negate_mult_distr_l, negate_involutive, negate_0.
  Qed.

  Lemma negate_zero_prod_r x y : x * -y = 0 ↔ x * y = 0.
  Proof. rewrite (commutativity x (-y)), (commutativity x y). apply negate_zero_prod_l. Qed.

  Lemma unit_no_zero_divisor (x : R) {unit : RingUnit x}: ¬ZeroDivisor x.
  Proof.
    destruct unit as [y x_y_unit].
    intros [_ [z [z_nonzero xz_zero]]].
    destruct z_nonzero.
    transitivity ((x * z) * y); try (rewrite xz_zero; ring).
    transitivity (x * y * z); try (rewrite x_y_unit; ring). ring.
  Qed.

  Context `{!NoZeroDivisors R} `{∀ x y, Stable (x = y)}.

  Global Instance mult_left_cancel:  ∀ z, PropHolds (z ≠ 0) → LeftCancellation (.*.) z.
  Proof.
   intros z z_nonzero x y E.
   apply stable.
   intro U.
   apply (mult_ne_0 z (x - y) (is_ne_0 z)).
    intro. apply U. now apply equal_by_zero_sum.
   rewrite distribute_l, E. ring.
  Qed.

  Global Instance: ∀ z, PropHolds (z ≠ 0) → RightCancellation (.*.) z.
  Proof. intros ? ?. apply (right_cancel_from_left (.*.)). Qed.
End ring_props.

Section integral_domain_props.
  Context `{IntegralDomain R}.

  Instance intdom_nontrivial_apart `{Apart R} `{!TrivialApart R} :
    PropHolds (1 ≶ 0).
  Proof. apply strong_setoids.ne_apart. solve_propholds. Qed.
End integral_domain_props.

(* Due to bug #2528 *)
#[global]
Hint Extern 6 (PropHolds (1 ≶ 0)) => eapply @intdom_nontrivial_apart : typeclass_instances.

Section ringmor_props.
  Context `{Ring A} `{Ring B} `{!SemiRing_Morphism (f : A → B)}.

  Definition preserves_negate x : f (-x) = -f x := groups.preserves_negate x. (* alias for convinience *)

  Lemma preserves_minus x y : f (x - y) = f x - f y.
  Proof.
    rewrite <-preserves_negate.
    apply preserves_plus.
  Qed.

  Lemma injective_preserves_0 : (∀ x, f x = 0 → x = 0) → Injective f.
  Proof.
    intros E1.
    split; try apply _. intros x y E.
    apply equal_by_zero_sum.
    apply E1.
    rewrite preserves_minus, E.
    now apply plus_negate_r.
  Qed.
End ringmor_props.

Section from_another_ring.
  Context `{Ring A} `{Setoid B}
   `{Bplus : Plus B} `{Zero B} `{Bmult : Mult B} `{One B} `{Bnegate : Negate B}
    (f : B → A) `{!Injective f}
    (plus_correct : ∀ x y, f (x + y) = f x + f y) (zero_correct : f 0 = 0)
    (mult_correct : ∀ x y, f (x * y) = f x * f y) (one_correct : f 1 = 1) (negate_correct : ∀ x, f (-x) = -f x).

  Lemma projected_ring: Ring B.
  Proof.
    split.
      now apply (groups.projected_ab_group f).
     now apply (groups.projected_com_monoid f mult_correct one_correct).
    repeat intro; apply (injective f). rewrite plus_correct, !mult_correct, plus_correct.
    now rewrite distribute_l.
  Qed.
End from_another_ring.

Section from_stdlib_semiring_theory.
  Context
    `(H: @semi_ring_theory R Rzero Rone Rplus Rmult Re)
    `{!@Setoid R Re}
    `{!Proper (Re ==> Re ==> Re) Rplus}
    `{!Proper (Re ==> Re ==> Re) Rmult}.

  Add Ring R2: H.

  Definition from_stdlib_semiring_theory: @SemiRing R Re Rplus Rmult Rzero Rone.
  Proof.
   repeat (constructor; try assumption); repeat intro
   ; unfold equiv, mon_unit, sg_op, zero_is_mon_unit, plus_is_sg_op,
     one_is_mon_unit, mult_is_sg_op, zero, mult, plus; ring.
  Qed.
End from_stdlib_semiring_theory.

Section from_stdlib_ring_theory.
  Context
    `(H: @ring_theory R Rzero Rone Rplus Rmult Rminus Rnegate Re)
    `{!@Setoid R Re}
    `{!Proper (Re ==> Re ==> Re) Rplus}
    `{!Proper (Re ==> Re ==> Re) Rmult}
    `{!Proper (Re ==> Re) Rnegate}.

  Add Ring R3: H.

  Definition from_stdlib_ring_theory: @Ring R Re Rplus Rmult Rzero Rone Rnegate.
  Proof.
   repeat (constructor; try assumption); repeat intro
   ; unfold equiv, mon_unit, sg_op, zero_is_mon_unit, plus_is_sg_op,
     one_is_mon_unit, mult_is_sg_op, mult, plus, negate; ring.
  Qed.
End from_stdlib_ring_theory.

#[global]
Instance id_sr_morphism `{SemiRing A}: SemiRing_Morphism (@id A) := {}.

Section morphism_composition.
  Context `{Equiv A} `{Mult A} `{Plus A} `{One A} `{Zero A}
    `{Equiv B} `{Mult B} `{Plus B} `{One B} `{Zero B}
    `{Equiv C} `{Mult C} `{Plus C} `{One C} `{Zero C}
    (f : A → B) (g : B → C).

  Instance compose_sr_morphism:
    SemiRing_Morphism f → SemiRing_Morphism g → SemiRing_Morphism (g ∘ f).
  Proof. split; try apply _; firstorder. Qed.
  Instance invert_sr_morphism:
    ∀ `{!Inverse f}, Bijective f → SemiRing_Morphism f → SemiRing_Morphism (f⁻¹).
  Proof. split; try apply _; firstorder. Qed.
End morphism_composition.

#[global]
Hint Extern 4 (SemiRing_Morphism (_ ∘ _)) => class_apply @compose_sr_morphism : typeclass_instances.
#[global]
Hint Extern 4 (SemiRing_Morphism (_⁻¹)) => class_apply @invert_sr_morphism : typeclass_instances.

#[global]
Instance semiring_morphism_proper {A B eA eB pA mA zA oA pB mB zB oB} :
  Proper ((=) ==> (=)) (@SemiRing_Morphism A B eA eB pA mA zA oA pB mB zB oB).
Proof.
  assert (∀ (f g : A → B), g = f → SemiRing_Morphism f → SemiRing_Morphism g) as P.
   intros f g E [? ? ? ?].
   now split; try apply _; eapply groups.monoid_morphism_proper; eauto.
  intros f g ?; split; intros Mor.
   apply P with f. destruct Mor. now symmetry. now apply _.
  now apply P with g.
Qed.