(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Declare ML Module "quote_plugin".

(***********************************************************************
  The "abstract" type index is defined to represent variables.

  index : Set
  index_eq : index -> bool
  index_eq_prop: (n,m:index)(index_eq n m)=true -> n=m
  index_lt : index -> bool
  varmap : Type -> Type.
  varmap_find : (A:Type)A -> index -> (varmap A) -> A.

  The first arg. of varmap_find is the default value to take
  if the object is not found in the varmap.

  index_lt defines a total well-founded order, but we don't prove that.

***********************************************************************)

Set Implicit Arguments.

Section variables_map.

Variable A : Type.

Inductive varmap : Type :=
  | Empty_vm : varmap
  | Node_vm : A -> varmap -> varmap -> varmap.

Inductive index : Set :=
  | Left_idx : index -> index
  | Right_idx : index -> index
  | End_idx : index.

Fixpoint varmap_find (default_value:A) (i:index) (v:varmap) {struct v} : A :=
  match i, v with
  | End_idx, Node_vm x _ _ => x
  | Right_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v2
  | Left_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v1
  | _, _ => default_value
  end.

Fixpoint index_eq (n m:index) {struct m} : bool :=
  match n, m with
  | End_idx, End_idx => true
  | Left_idx n', Left_idx m' => index_eq n' m'
  | Right_idx n', Right_idx m' => index_eq n' m'
  | _, _ => false
  end.

Fixpoint index_lt (n m:index) {struct m} : bool :=
  match n, m with
  | End_idx, Left_idx _ => true
  | End_idx, Right_idx _ => true
  | Left_idx n', Right_idx m' => true
  | Right_idx n', Right_idx m' => index_lt n' m'
  | Left_idx n', Left_idx m' => index_lt n' m'
  | _, _ => false
  end.

Lemma index_eq_prop : forall n m:index, index_eq n m = true -> n = m.
  simple induction n; simple induction m; simpl in |- *; intros.
  rewrite (H i0 H1); reflexivity.
  discriminate.
  discriminate.
  discriminate.
  rewrite (H i0 H1); reflexivity.
  discriminate.
  discriminate.
  discriminate.
  reflexivity.
Qed.

End variables_map.

Unset Implicit Arguments.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A1 A2 B1 B2 C1 C2 P : Universe, ((wd_ A1 A2 /\ (wd_ C1 C2 /\ (wd_ B1 B2 /\ (wd_ A1 B1 /\ (wd_ A1 B2 /\ (col_ A1 A2 B1 /\ (col_ A1 A2 B2 /\ (col_ P B1 B2 /\ (col_ A1 A2 C1 /\ (col_ A1 A2 C2 /\ (col_ P C1 C2 /\ col_ A1 C1 C2))))))))))) -> col_ C1 B1 B2)).
Proof.
  time tac.
Qed.

End FOFProblem.


From HoTT Require Import HoTT.

Record Polynomial := makePolynomial
  { Position : Type
  ; Direction : Position -> Type
  }.

Definition CoproductOfFunctors {I : Type} (F : I -> (Type -> Type))
    : Type -> Type :=
  fun A => {i : I & F i A}.

#[export] Instance CoproductOfFunctorsIs0Functor {I : Type}
  (F : I -> (Type -> Type)) `{forall i : I, Is0Functor (F i)}
  : Is0Functor (CoproductOfFunctors F).
Proof.
  constructor.
  exact (fun A B f => functor_sigma idmap (fun i => fmap (F i) f)).
Defined.

Definition Extension (p : Polynomial) : Type -> Type :=
  CoproductOfFunctors (opyon o Direction p).

Class IsPolynomialFunctor (F : Type -> Type) `{!Is0Functor F} :=
  makeIsPolynomialFunctor
    { polynomial : Polynomial
    ; equivalenceToExtension : NatEquiv F (Extension polynomial)
    }.

Arguments makeIsPolynomialFunctor F {_}.
Arguments polynomial              F {_ _}.
Arguments equivalenceToExtension  F {_ _}.

Notation List := list.
Notation indList := @list_rect.
Arguments cons {A}.

Definition recList (A X : Type) (x1 : X) (x2 : A -> X -> X) : List A -> X :=
  indList A (fun _ => X) x1 (fun a _ => x2 a).

#[export] Instance ListIs0Functor : Is0Functor List.
Proof.
  constructor.
  exact (fun A B f => recList A (List B) nil (fun a l => cons (f a) l)).
Defined.

Definition List' : Polynomial := makePolynomial nat Fin.
Definition nil' {A : Type} : Extension List' A := (O; Empty_rec).
Definition cons' {A : Type} : A -> Extension List' A -> Extension List' A :=
  fun a '(n; f) => (succ n; sum_ind _ f (fun _ => a)).

Definition recList' (A X : Type) (x1 : X) (x2 : A -> X -> X)
    : Extension List' A -> X :=
  sig_ind _ (
    fix f (n : nat) : (Fin n -> A) -> X :=
      match n with
      | O       => fun _ => x1
      | succ n' => fun a => x2 (a (inr tt)) (f n' (a o inl))
      end
  ).

Definition indList' `{Funext} (A : Type0)
    (X : Extension List' A -> Type)
    (x1 : X nil')
    (x2 : forall (a : A) (l' : Extension List' A), X l' -> X (cons' a l'))
    : forall l' : Extension List' A, X l' :=
  sig_ind _ (
    fix f (n : nat) : forall a : Fin n -> A, X (n; a) :=
      match n with
      | O       => fun a => transport (X o exist _ 0) (contr a) x1
      | succ n' => fun a => transport (X o exist _ (succ n'))
          (ap (fun a' => sum_ind _ (a o inl) a')
              (eisretr (fun x => unit_name x) (a o inr))
            @ eisretr (sum_ind_uncurried _) a)
          (x2 (a (inr tt)) _ (f n' (a o inl)))
      end
  ).

#[export] Instance ListIsPolynomialFunctor `{Funext} : IsPolynomialFunctor List.
Proof.
  apply (makeIsPolynomialFunctor List List'), natequiv_inverse.
  snrapply Build_NatEquiv.
  - intro A; srapply equiv_adjointify.
    + exact (recList' A (List A) nil cons).
    + exact (recList A (Extension List' A) nil' cons').
    + rapply indList.
      * reflexivity.
      * exact (fun a l w => ap (cons a) w).
    + rapply indList'.
      * reflexivity.
      * exact (fun a l' w => ap (cons' a) w).
  - intros A B f; rapply indList'.
    + reflexivity.
    + exact (fun a l' w => ap (cons (f a)) w).
Defined.

Inductive Tree (A : Type) : Type :=
  | leaf : Tree A
  | node : Tree A -> A -> Tree A -> Tree A.

Arguments leaf {A}.
Arguments node {A}.

Notation indTree := Tree_rect.

Definition recTree (A X : Type) (x1 : X) (x2 : X -> A -> X -> X)
    : Tree A -> X :=
  indTree A (fun _ => X) x1 (fun _ x a _ => x2 x a).

#[export] Instance TreeIs0Functor : Is0Functor Tree.
Proof.
  constructor.
  exact (fun A B f =>
    recTree A (Tree B) leaf (fun t1 a t2 => node t1 (f a) t2)
  ).
Defined.

Fixpoint TreeDirection (t : Tree Unit) : Type :=
  match t with
  | leaf         => Empty
  | node t1 _ t2 => TreeDirection t1 + Unit + TreeDirection t2
  end.

Definition Tree' : Polynomial := makePolynomial (Tree Unit) TreeDirection.
Definition leaf' {A : Type} : Extension Tree' A := (leaf; Empty_rec).
Definition node' {A : Type}
    : Extension Tree' A -> A -> Extension Tree' A -> Extension Tree' A :=
  fun '(t1; f1) a '(t2; f2) =>
    (node t1 tt t2; sum_ind _ (sum_ind _ f1 (fun _ => a)) f2).

Definition recTree' (A X : Type) (x1 : X) (x2 : X -> A -> X -> X)
    : Extension Tree' A -> X :=
  sig_ind _ (
    fix f (t : Tree Unit) : (TreeDirection t -> A) -> X :=
      match t with
      | leaf         => fun _ => x1
      | node t1 _ t2 => fun a =>
          x2 (f t1 (a o inl o inl)) (a (inl (inr tt))) (f t2 (a o inr))
      end
  ).

Definition indTree' `{Funext} (A : Type)
    (X : Extension Tree' A -> Type)
    (x1 : X leaf')
    (x2 : forall t1', X t1' -> forall a t2', X t2' -> X (node' t1' a t2'))
    : forall t' : Extension Tree' A, X t' :=
  sig_ind X (
    fix f (t : Tree Unit) : forall a : TreeDirection t -> A, X (t; a) :=
      match t with
      | leaf          => fun a => transport (X o exist _ leaf) (contr a) x1
      | node t1 tt t2 => fun a => transport (X o exist _ (node t1 tt t2))
          (ap (fun a' => sum_ind _ (sum_ind _ (a o inl o inl) a') (a o inr))
              (eisretr (fun x => unit_name x) (a o inl o inr))
            @ ap (fun a' => sum_ind _ a' (a o inr))
              (eisretr (sum_ind_uncurried _) (a o inl))
            @ eisretr (sum_ind_uncurried _) a)
          (x2 _ (f t1 (a o inl o inl)) (a (inl (inr tt))) _ (f t2 (a o inr)))
      end
  ).

#[export] Instance TreeIsPolynomialFunctor `{Funext} : IsPolynomialFunctor Tree.
Proof.
  apply (makeIsPolynomialFunctor Tree Tree'), natequiv_inverse.
  snrapply Build_NatEquiv.
  - intro A; srapply equiv_adjointify.
    + exact (recTree' A (Tree A) leaf node).
    + exact (recTree A (Extension Tree' A) leaf' node').
    + rapply indTree.
      * reflexivity.
      * exact (fun t1 w1 a t2 w2 =>
          ap011 (fun t1' t2' => node t1' a t2') w1 w2
        ).
    + rapply indTree'.
      * reflexivity.
      * exact (fun t1' w1 a t2' w2 =>
          ap011 (fun t1'' t2'' => node' t1'' a t2'') w1 w2
        ).
  - intros A B f; rapply indTree'.
    + reflexivity.
    + exact (fun t1' w1 a t2' w2 =>
        ap011 (fun t1 t2 => node t1 (f a) t2) w1 w2
      ).
Defined.


From mathcomp.ssreflect Require Import all_ssreflect seq.
From mathcomp Require Import finmap.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

From Paco Require Import paco paco2.

Require Import MPST.Common.
Require Import MPST.Global.
Require Import MPST.Local.

Open Scope fmap.

Definition qproj_rel := ig_ty -> {fmap role * role -> seq (lbl * mty) } -> Prop.
Inductive qProject : qproj_rel :=
| qprj_end G : qProject (ig_end G) [fmap]%fmap

| qprj_none p p' CONT Q :
    (forall l Ty G, CONT l = Some (Ty, G) -> qProject G Q) ->
    Q.[? (p,p')] = None ->
    qProject (ig_msg None p p' CONT) Q

| qprj_some p p' CONT l Ty G Q Q':
    CONT l = Some (Ty, G) ->
    deq Q' (p, p') == Some ((l, Ty), Q) ->
    qProject G Q ->
    qProject (ig_msg (Some l) p p' CONT) Q'
.
Hint Constructors qProject.

Lemma qProject_end_inv_aux Q iG G:
  qProject iG Q ->  iG = (ig_end G) ->
  Q = ([fmap]%fmap).
Proof.
  case =>//=.
Qed.

Lemma qProject_end_inv Q G:
  qProject (ig_end G) Q ->
  Q = ([fmap]%fmap).
Proof.
    by move=> hp; apply: (@qProject_end_inv_aux Q _ G hp).
Qed.

Lemma qProject_None_inv_aux F T C Q GG:
  qProject GG Q ->
  GG = (ig_msg None F T C) ->
  Q.[? (F,T)] = None /\ forall l Ty G,
      (C l = Some (Ty, G) -> qProject G Q).
Proof.
  case =>//=.
  move=> p p' CONT Q0 IH neq [eq1 eq2 eq3].
  split; [by rewrite -eq1 -eq2| rewrite -eq3].
    by apply IH.
Qed.

Lemma qProject_None_inv F T C Q :
  qProject (ig_msg None F T C) Q ->
  Q.[? (F,T)] = None /\ forall l Ty G,
      (C l = Some (Ty, G) -> qProject G Q).
Proof.
    by move=> hp; move: (@ qProject_None_inv_aux F T C _ _ hp)=>H; apply/H.
Qed.

Lemma qProject_Some_inv_aux l F T C Q GG:
  qProject GG Q ->
  GG = (ig_msg (Some l) F T C) ->
  (exists Ty G Q',
      C l = Some (Ty, G) /\
      deq Q (F, T) == Some ((l, Ty), Q') /\
      qProject G Q').
Proof.
  case =>//.
  move=> p p' CONT l0 Ty G Q0 Q' CONTL0 deqQ' qpro [eq1 eq2 eq3 eq4].
  rewrite -eq1 -eq2 -eq3 -eq4;  exists Ty, G, Q0.
  by split; [| split; [|]].
Qed.

Lemma qProject_Some_inv l F T C Q:
  qProject (ig_msg (Some l) F T C) Q ->
  exists Ty G Q', C l = Some (Ty, G) /\
                  deq Q (F, T) == Some ((l, Ty), Q') /\
                  qProject G Q'.
Proof.
  move=> hp; move: (@qProject_Some_inv_aux l F T C Q _ hp).
  by move=> triv; apply triv.
Qed.

Lemma deq_elsewhere Q Q' k0 k L Ty:
  deq Q' k0 == Some (L, Ty, Q) -> k != k0 ->
  Q'.[?k]=Q.[?k].
Proof.
  rewrite /deq; case E: (Q'.[? k0]) =>[qs|] //=; case qs => [|q qs0] //=.
  case: ifP; move=> _; rewrite -(rwP eqP); move=> [_ <-].
  + by rewrite fnd_rem1; case: ifP.
  + by rewrite fnd_set; case: ifP.
Qed.

Lemma deq_singleton (Q:{fmap role * role -> seq (lbl * mty) }) p q v:
  Q.[?(p,q)] == None ->
  deq Q.[(p, q) <- [:: v]] (p, q) = Some (v, Q).
Proof.
  move=> Qnone; rewrite /deq fnd_set; case: ifP; rewrite eq_refl //=; elim.
  apply: f_equal; apply: injective_projections =>//=.
  rewrite -fmapP; move=> pq; rewrite fnd_rem1; case: ifP.
  + move=> neq; rewrite fnd_set; case: ifP =>//=.
    by rewrite (negbTE neq) //=.
  + move=> eq; move: (negbNE (negbT eq)).
    by rewrite -(rwP eqP) =>->; rewrite (rwP eqP) eq_sym.
Qed.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export approx_props1.
(** printing #  $\times$ #×# *)
(** printing <=>  $\Leftrightarrow$ #⇔# *)
(** printing $  $\times$ #×# *)
(** printing &  $\times$ #×# *)

(* begin hide *)

Definition blift_sub {o}
           (op : @Opid o)
           (R : NTrel)
           (b1 b2: @BTerm o) : [univ] :=
  {lv : list NVar
   $ {nt1,nt2 : NTerm
   $ (
      (op <> NCan NFresh # R nt1 nt2)
      [+]
      {sub : Sub
       & op = NCan NFresh
       # R (lsubst nt1 sub) (lsubst nt2 sub)
       # nrut_sub (get_utokens nt1 ++ get_utokens nt2) sub
       # lv = dom_sub sub}
     )
   # alpha_eq_bterm b1 (bterm lv nt1)
   # alpha_eq_bterm b2 (bterm lv nt2) }}.

Definition lblift_sub {o}
           (op : Opid)
           (R : NTrel)
           (tls trs: list (@BTerm o)) : [univ] :=
  length tls = length trs
  # forall n : nat, n < length tls -> blift_sub op R (tls{[n]}) (trs{[n]}).

(* end hide *)

(** %\noindent% To prove that [approx] is a cogruence, Howe defined a
    relation
    [approx_star] that contains [approx_open] and is a congruence by
    definition. The main challenge then is to prove that [approx_star]
    implies [approx_open], and hence they are equivalent.
    Howe reduced this
    property to a set of conditions(called extensionality) on
    each non-canonical [Opid] in the computation system.
    We managed to mechanize this reduction in Coq and also
    proved that all the [Opid]s of Nuprl satisfy his extensionality
    condition.

    We begin by defining his [approx_star] relation. It is a relation
    on well formed (possibly open) [NTerm]s. So we need not use [olift]
    before applying [lblift] in the [apso] constructor. %\\*%

 *)

(*
 A reader who is not intersted in these details might
    want to just look at the statement of the theorem [approx_congruence]
    toward the end of this section move to the next sections. *)

Inductive approx_star {p} :
  @library p -> @NTerm p -> @NTerm p -> [univ] :=
| apsv: forall lib v t2,
          (approx_open lib (vterm v) t2)
          -> (approx_star lib (vterm v) t2)
| apss: forall lib t (f1 f2 : ntseq),
          (forall n, alpha_eq (f1 n) (f2 n))
          -> approx_open lib (sterm f2) t
          -> approx_star lib (sterm f1) t
| apso: forall lib
               (op : Opid)
               (t2: NTerm)
               (lbt1 lbt1' : list BTerm),
          length lbt1 = length lbt1'
          -> lblift_sub op (approx_star lib) lbt1 lbt1'
          -> approx_open lib (oterm op lbt1') t2
          -> approx_star lib (oterm op lbt1) t2.
Hint Constructors approx_star : slow.

Definition approx_star_bterm {o} (lib : @library o) op :=
  blift_sub op (approx_star lib).
Definition approx_starbts {o} (lib : @library o) op :=
  lblift_sub op (approx_star lib).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tT_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable tG_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable deftogetherfour_1 : (forall A B C D E F G H : Universe, (exists X : Universe, (tT_ A B C D E F G H -> (betS_ E F X /\ (cong_ F X G H /\ tG_ A B C D E X))))).
Variable deftogetherfour2_2 : (forall A B C D E F G H X : Universe, ((betS_ E F X /\ (cong_ F X G H /\ tG_ A B C D E X)) -> tT_ A B C D E F G H)).
Variable lemma_TGflip_3 : (forall A B C Xa Xb Xc : Universe, (tG_ A Xa B Xb C Xc -> (tG_ Xa A B Xb C Xc /\ tG_ A Xa B Xb Xc C))).
Variable lemma_TGsymmetric_4 : (forall A B C Xa Xb Xc : Universe, (tG_ A Xa B Xb C Xc -> tG_ B Xb A Xa C Xc)).

Theorem lemma_TTflip_5 : (forall A B C D E F G H : Universe, (tT_ A B C D E F G H -> tT_ B A D C E F G H)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e336m17_13limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e152m17_4limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import proofmode notation.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac auth gmap csum.
From iris.base_logic Require Import big_op.
From iris_atomic Require Export treiber misc.
From iris.base_logic.lib Require Import invariants namespaces.

Section defs.
  Context `{heapG Σ} (N: namespace).
  Context (R: val → iProp Σ) `{∀ x, TimelessP (R x)}.

  Fixpoint is_list_R (hd: loc) (xs: list val) : iProp Σ :=
    match xs with
    | [] => (∃ q, hd ↦{ q } NONEV)%I
    | x :: xs => (∃ (hd': loc) q, hd ↦{q} SOMEV (x, #hd') ∗ inv N (R x) ∗ is_list_R hd' xs)%I
    end.

  Definition is_bag_R xs s := (∃ hd: loc, s ↦ #hd ∗ is_list_R hd xs)%I.

  Lemma dup_is_list_R : ∀ xs hd,
    is_list_R hd xs ⊢ |==> is_list_R hd xs ∗ is_list_R hd xs.
  Proof.
    induction xs as [|y xs' IHxs'].
    - iIntros (hd) "Hs".
      simpl. iDestruct "Hs" as (q) "[Hhd Hhd']". iSplitL "Hhd"; eauto.
    - iIntros (hd) "Hs". simpl.
      iDestruct "Hs" as (hd' q) "([Hhd Hhd'] & #Hinv & Hs')".
      iDestruct (IHxs' with "[Hs']") as ">[Hs1 Hs2]"; first by iFrame.
      iModIntro. iSplitL "Hhd Hs1"; iExists hd', (q / 2)%Qp; by iFrame.
  Qed.

  Definition f_spec (R: iProp Σ) (f: val) (Rf: iProp Σ) x :=
    {{{ inv N R ∗ Rf }}}
      f x
    {{{ RET #(); Rf }}}.

End defs.

Section proofs.
  Context `{heapG Σ} (N: namespace).
  Context (R: val → iProp Σ).

  Definition bag_inv s: iProp Σ := inv N (∃ xs, is_bag_R N R xs s)%I.

  Lemma new_bag_spec:
    {{{ True }}} new_stack #() {{{ s, RET #s; bag_inv s }}}.
  Proof.
    iIntros (Φ) "HΦ". iApply wp_fupd.
    wp_seq. wp_bind (ref NONE)%E. wp_alloc l as "Hl".
    wp_alloc s as "Hs".
    iAssert ((∃ xs, is_bag_R N R xs s))%I with "[-HΦ]" as "Hxs".
    { iFrame. iExists [], l.
      iFrame. simpl. eauto. }
    iMod (inv_alloc N _ (∃ xs : list val, is_bag_R N R xs s)%I with "[-HΦ]") as "#?"; first eauto.
    iApply "HΦ". iFrame "#".
  Qed.

  Lemma push_spec (s: loc) (x: val):
    {{{ R x ∗ bag_inv s }}} push #s x {{{ RET #() ; inv N (R x) }}}.
  Proof.
    iIntros (Φ) "(HRx & #?) HΦ".
    iLöb as "IH". wp_rec. wp_let.
    wp_bind (! _)%E.
    iInv N as "H1" "Hclose".
    iDestruct "H1" as (xs hd) "[>Hs H1]".
    wp_load. iMod ("Hclose" with "[Hs H1]").
    { iNext. iFrame. iExists xs, hd. iFrame. }
    iModIntro. wp_let. wp_alloc l as "Hl".
    wp_let. wp_bind (CAS _ _ _)%E.
    iInv N as "H1" "Hclose".
    iDestruct "H1" as (xs' hd') "[>Hs H1]".
    destruct (decide (hd = hd')) as [->|Hneq].
    - wp_cas_suc.
      iMod (inv_alloc N _ (R x) with "[HRx]") as "#HRx"; first eauto.
      iMod ("Hclose" with "[Hs Hl H1]").
      { iNext. iFrame. iExists (x::xs'), l.
        iFrame. simpl. iExists hd', 1%Qp. iFrame.
        by iFrame "#". }
      iModIntro. wp_if. by iApply "HΦ".
    - wp_cas_fail.
      iMod ("Hclose" with "[Hs H1]").
      { iNext. iFrame. iExists (xs'), hd'. iFrame. }
      iModIntro. wp_if. iApply ("IH" with "HRx").
      by iNext.
  Qed.

End proofs.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj7eqsynthconj2 : forall  (lv0 : lst), (@eq natural (Succ (len lv0)) (len (Cons (len Nil) lv0))).
Admitted.
QuickChick conj7eqsynthconj2.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e255m19_6limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e190m11_4limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^338 - 15
Base: 48 + 2/7
***)

Definition curve : CurveParameters :=
  {|
    sz := 7%nat;
    base := 48 + 2/7;
    bitwidth := 64;
    s := 2^338;
    c := [(1, 15)];
    carry_chains := Some [seq 0 (pred 7); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e174m3_4limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Load loadpath.
Require Import ZArith Coq.Lists.List Permutation.
Require Import VST.msl.Axioms veric.Coqlib2.
Require Import VST.msl.predicates_sa.
Require Import veristar.variables veristar.datatypes veristar.list_denote
               veristar.heapresolve veristar.model_type veristar.model
               veristar.superpose veristar.clauses.

Import HeapResolve.

Module Type NORM_SOUND.
Declare Module VSM: VERISTAR_MODEL.
Import VSM VeriStarLogic Superposition.

Axiom norm_sound : forall sigma sc s,
  clause_denote sc s -> setd clause_denote (@andp _) TT sigma s ->
  clause_denote (HeapResolve.norm sigma sc) s.

End NORM_SOUND.

Module Norm_Sound (VSM: VERISTAR_MODEL) : NORM_SOUND with Module VSM := VSM.
Module VSM := VSM.
Import VSM VeriStarLogic Superposition.

Import sepalg.

Lemma subst_expr_sound v e e' s :
  (Var v === e) s -> (expr_denote e' s = expr_denote (subst_expr v e e') s).
Proof with simpl in *; auto.
unfold var_eq. intro A. destruct e'... if_tac... rewrite <- H...
Qed.

Lemma join_var_eq : forall (s0 s1 s : state) x y,
  join s0 s1 s -> (x === y) s0 -> (x === y) s.
Proof.
intros.
destruct s; destruct s0; destruct s1. destruct H. simpl in *. destruct H.
unfold var_eq in *; subst; auto.
Qed.

Lemma join_var_eq' : forall (s0 s1 s : state) x y,
  join s0 s1 s -> (x === y) s -> (x === y) s0.
Proof.
intros.
destruct s; destruct s0; destruct s1. destruct H. simpl in *. destruct H.
unfold var_eq in *; subst; auto.
Qed.

Lemma subst_space_atom_sound:
   forall (v : datatypes.var) (e : expr) (s : state) (Heq : (Var v === e) s) sa,
  space_atom_denote sa s = space_atom_denote (subst_space v e sa) s.
Proof with simpl in *; auto.
destruct sa... rewrite <- subst_expr_sound...
destruct (val2loc (expr_denote e0 s))... rewrite <- subst_expr_sound...
rewrite <- subst_expr_sound... rewrite <- subst_expr_sound...
Qed.

Lemma subst_space_atoms_sound v e sigma s :
  (Var v === e) s ->
  space_denote sigma s = space_denote (map (subst_space v e) sigma) s.
Proof with simpl; auto.
intro A; revert s A; induction sigma... simpl; intros s A.
apply prop_ext. split; intro B. destruct B as [x [y [B [C D]]]].
exists x; exists y. rewrite (subst_space_atom_sound v e) in C.
split; auto. split; auto. rewrite <- IHsigma; auto.
eapply join_var_eq'; eauto. eapply join_var_eq'; eauto.
destruct B as [x [y [B [C D]]]]. exists x; exists y. split; auto.
rewrite <- subst_space_atom_sound in C; auto. split; auto.
rewrite IHsigma; auto. eapply join_var_eq'; eauto. eapply join_var_eq'; eauto.
Qed.

Lemma normalize1_3_sound pc sc s :
  clause_denote pc s -> clause_denote sc s ->
  clause_denote (normalize1_3 pc sc) s.
Proof with destruct delta; try destruct p; try destruct e; simpl; auto.
intros A B; unfold normalize1_3; destruct pc...
simpl in A. destruct sc; auto; intro C; rewrite (@listd_sort_uniq_un _ state);
try solve [apply pure_atom_cmp_eq]. rewrite listd_app, listd_unfold_un.
rewrite (@listd_sort_uniq_inter _ state) in C. 2: apply pure_atom_cmp_eq.
rewrite listd_app, listd_unfold_inter in C; destruct C as [C D].
specialize (A C). specialize (B D). rewrite (@listd_unfold_un _ state) in B.
destruct A as [A | A]; [ destruct B as [B | B]; right | left; auto].
rewrite listd_unfold_un; left... rewrite listd_unfold_un. right.
unfold space_denote in B; unfold subst_spaces.
solve[rewrite <- subst_space_atoms_sound; auto].
rewrite listd_app, listd_unfold_un.
rewrite (@listd_sort_uniq_inter _ state) in C. 2: apply pure_atom_cmp_eq.
rewrite listd_app, listd_unfold_inter in C; destruct C as [C D].
specialize (A C). destruct A as [A | A]; [ | left; auto].
rewrite listd_unfold_inter in D. destruct D as [D E].
unfold subst_spaces in E. rewrite <- subst_space_atoms_sound in E; auto.
simpl in B. rewrite (@listd_unfold_inter _ state) in B. right; apply B.
split; auto.
Qed.

Require Import Bool.

Lemma empty_state (s : state) : exists s0, emp s0 /\ join s0 s s.
Proof with auto.
generalize (join_ex_identities s); intros [s0 [A [s' B]]].
exists s0; split... assert (s = s'). apply (A _ _ B). subst s...
Qed.

Lemma lseg_nilnil sigma s :
  space_denote sigma s =
  (space_atom_denote (Lseg Nil Nil) * space_denote sigma)%pred s.
Proof with simpl; auto; try congruence.
apply prop_ext; split; intro A. destruct (empty_state s) as [s0 [B C]].
exists s0; exists s. split... split... simpl. rewrite empstate_empheap in B.
constructor... constructor...
destruct A as [x [y [A [B C]]]]. simpl in B. inversion B; subst...
cut (y = s); [ intro X; rewrite <- X; auto | ].
inversion A; subst. destruct y as [y1 y2], s as [s1 s2]; f_equal...
apply A.
Qed.

Lemma lseg_vv sigma v s :
  space_denote sigma s =
  (space_atom_denote (Lseg (Var v) (Var v)) * space_denote sigma)%pred s.
Proof with simpl; auto; try congruence.
apply prop_ext; split; intro A. destruct (empty_state s) as [s0 [B C]].
exists s0; exists s. split... split... simpl.
constructor... apply empstate_empheap...
apply var_nil_or_loc.
destruct A as [x [y [A [B C]]]]. simpl in B. inversion B; subst...
cut (y = s); [ intro X; rewrite <- X; auto | ].
inversion A; subst. destruct y as [y1 y2], s as [s1 s2]; f_equal...
apply A.
Qed.

Lemma drop_reflex_lseg_sound sigma s :
  space_denote sigma s = space_denote (drop_reflex_lseg sigma) s.
Proof with simpl; auto; try congruence.
apply prop_ext; split; intro A.
revert s A; induction sigma... intros s [x [y [A [B C]]]].
generalize A; intros [[A0 A1] A2].
destruct a; [exists x; exists y; split; auto | ].
destruct e; destruct e0. inversion B; simpl; auto; try congruence; subst. apply IHsigma.
cut (y = s); [ intro X; rewrite <- X; auto | ].
destruct y as [y1 y2], s as [s1 s2]; f_equal...
exists x; exists y; split...
exists x; exists y; split...
rewrite if_negb; remember (eq_var v v0) as b; destruct b.
2: exists x; exists y; split...
unfold eq_var in Heqb. apply eq_pos_var_eqZ in Heqb. inversion Heqb; subst.
inversion B; subst.
cut (y = s); [ intro X; rewrite <- X; auto | ].
destruct y as [y1 y2], s as [s1 s2]; f_equal... apply IHsigma...
(* <-- *)
revert s A; induction sigma... intros s A. destruct a in A |- *.
destruct A as [x [y [A [B C]]]]. exists x; exists y; split...
remember e as b1; remember  e0 as b2. destruct b1, b2 in A |- *.
rewrite <- lseg_nilnil...
destruct A as [x [y [A [B C]]]]; exists x; exists y; split...
destruct A as [x [y [A [B C]]]]; exists x; exists y; split...
rewrite if_negb in A; remember (eq_var v v0) as b; destruct b.
apply eq_pos_var_eqZ in Heqb; inversion Heqb; subst. rewrite <- lseg_vv...
destruct A as [x [y [A [B C]]]]; exists x; exists y; split...
Qed.

Lemma normalize2_4_sound sc s :
  clause_denote sc s -> clause_denote (normalize2_4 sc) s.
Proof with try solve [simpl; auto; congruence].
intro A; destruct sc... intro B. specialize (A B). clear B.
rewrite (@listd_unfold_un _ state) in A |- *. destruct A; [ left; auto | ].
right; rewrite <- drop_reflex_lseg_sound...
intro B. rewrite (@listd_unfold_inter _ state) in B. destruct B as [B C].
rewrite <- drop_reflex_lseg_sound in C. apply A.
rewrite (@listd_unfold_inter _ state); split...
Qed.

Lemma norm_sound sigma sc s :
  clause_denote sc s -> setd clause_denote (@andp _) TT sigma s ->
  clause_denote (norm sigma sc) s.
Proof with simpl; auto; try congruence.
unfold norm. intros A B. apply normalize2_4_sound. apply listd_foldr_pred...
intros x a C. apply normalize1_3_sound...
rewrite (@listd_sort_inter _ state) with (cmp := (rev_cmp compare_clause2)); auto.
Qed.

End Norm_Sound.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj23eqsynthconj1 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus Zero (plus lv0 lv1))).
Admitted.
QuickChick conj23eqsynthconj1.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^369 - 25
Base: 23 + 1/16
***)

Definition curve : CurveParameters :=
  {|
    sz := 16%nat;
    base := 23 + 1/16;
    bitwidth := 32;
    s := 2^369;
    c := [(1, 25)];
    carry_chains := Some [seq 0 (pred 16); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e379m19_15limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Coqlib.
Require Import ITreelib.
Require Import ImpPrelude.
Require Import STS.
Require Import Behavior.
Require Import ModSem.
Require Import Skeleton.
Require Import PCM.
Require Import Imp.
Require Import ImpNotations.

Set Implicit Arguments.

(***
f.f(n) {
  if (n == 42) { r := ... }
  else {
    if (n == 0) {
      r := 0
    } else if (n < 0) {
      log.log("error")
      r := -1
    } else {
      r := 2 + call g.g(n)
    }
  }
  r
}
***)

Section F.
  Context `{Σ: GRA.t}.

  Import ImpNotations.
  Local Open Scope expr_scope.
  Local Open Scope stmt_scope.

  Definition fF :=
    mk_function
      ["n"]
      ["r"]
      (if# ("n" =? 42%Z)
       then# return# 210%Z
       else#
         (if# ("n" =? 0%Z)
          then# return# 0%Z
          else#
            (if# ("n" < 0%Z)
             then# @ "log" ["n" : expr] ;# return# (- 1)%Z
             else# "r" =@ "g" ["n" : expr] ;# return# ("r" + 2%Z)
             fi#)
          fi#)
       fi#).

  Definition f_prog : program :=
    mk_program
      "F"
      []
      [("g", 1)]
      []
      [("f", fF)]
  .

  Definition FSem ge: ModSem.t := ImpMod.modsem f_prog ge.
  Definition F : Mod.t := ImpMod.get_mod f_prog.

End F.


From Tealeaves Require Export
  Classes.Functor
  Applicative.

Import Functor.Notations.
Import Applicative.Notations.

#[local] Generalizable Variable X Y T U G ϕ A.

(** * Traversable functors *)
(******************************************************************************)
Section TraversableFunctor_operation.

  Context
    (F : Type -> Type).

  Class Dist :=
    dist : forall (G : Type -> Type) `{Fmap G} `{Pure G} `{Mult G}, F ○ G ⇒ G ○ F.

End TraversableFunctor_operation.

Section TraversableFunctor.

  Context
    (F : Type -> Type)
    `{Functor F}
    `{Dist F}.

  Class TraversableFunctor :=
    { trav_functor :> Functor F;
      dist_natural :> forall `{Applicative G},
          @Natural (F ∘ G) _ (G ∘ F) _ (dist F G);
      dist_morph : forall `{ApplicativeMorphism G1 G2 ϕ} A,
          dist F G2 A ∘ fmap F (ϕ A) = ϕ (F A) ∘ dist F G1 A;
      dist_unit :
        `(dist F (fun A => A) A = id);
      dist_linear : forall `{Applicative G1} `{Applicative G2},
          `(dist F (G1 ∘ G2) A = fmap G1 (dist F G2 A) ∘ dist F G1 (G2 A));
    }.

End TraversableFunctor.

#[global] Arguments dist F%function_scope {Dist} G%function_scope {H H0 H1} {A}%type_scope.

(** ** Distribution-respecting natural transformations *)
(******************************************************************************)
Section TraversableMorphism.

  Context
    `{TraversableFunctor T}
    `{TraversableFunctor U}.

  Class TraversableMorphism (ϕ : T ⇒ U) :=
    { trvmor_trv_F : TraversableFunctor T;
      trvmor_trv_G : TraversableFunctor U;
      trvmor_nat :> Natural ϕ;
      trvmor_hom : forall `{Applicative G},
          `(fmap G (ϕ A) ∘ dist T G = dist U G ∘ ϕ (G A));
    }.

End TraversableMorphism.

(** * Monoid structure of traversable functors *)
(******************************************************************************)

(** ** The identity functor is traversable *)
(******************************************************************************)
#[export] Instance Dist_I : Dist (fun A => A) := fun F fmap mult pure A a => a.

#[export, program] Instance Traversable_I : TraversableFunctor (fun A => A).

Next Obligation.
  constructor; try typeclasses eauto.
  intros. ext a. unfold transparent tcs.
  reflexivity.
Qed.

Next Obligation.
  unfold transparent tcs. ext a.
  symmetry. now rewrite (fun_fmap_id G1).
Qed.

(** ** Traversable functors are closed under composition *)
(******************************************************************************)
Section TraversableFunctor_compose.

  Context
    `{TraversableFunctor T}
    `{TraversableFunctor U}.

  #[export] Instance Dist_compose : Dist (T ∘ U) :=
    fun G map mult pure A =>
      dist T G ∘ fmap T (dist U G (A := A)).

  Lemma dist_unit_compose : forall A,
      dist (T ∘ U) (fun A => A) = @id (T (U A)).
  Proof.
    intros. unfold transparent tcs.
    rewrite (dist_unit T).
    rewrite (dist_unit U).
    now rewrite (fun_fmap_id T).
  Qed.

  Lemma dist_natural_compose : forall `{Applicative G} `(f : X -> Y),
      fmap (G ∘ (T ∘ U)) f ∘ dist (T ∘ U) G = dist (T ∘ U) G ∘ fmap ((T ∘ U) ∘ G) f.
  Proof.
    intros. unfold transparent tcs.
    change_left (fmap (G ∘ T) (fmap U f) ∘ dist T G ∘ fmap T (dist U G)).
    #[local] Set Keyed Unification.
    rewrite (natural (ϕ := @dist T _ G _ _ _ ) (F := T ∘ G)).
    #[local] Unset Keyed Unification.
    unfold_ops @Fmap_compose.
    reassociate -> on left.
    reassociate -> on right.
    unfold_compose_in_compose.
    rewrite (fun_fmap_fmap T).
    rewrite (fun_fmap_fmap T).
    change (fmap ?F (fmap ?G ?f)) with (fmap (F ∘ G) f).
    now rewrite <- (natural (ϕ := @dist U _ G _ _ _)).
  Qed.

  Instance dist_natural_compose_ : forall `{Applicative G}, Natural (@dist (T ∘ U) _ G _ _ _).
  Proof.
    constructor; try typeclasses eauto.
    intros. apply dist_natural_compose.
  Qed.

  Lemma dist_morph_compose : forall `{ApplicativeMorphism G1 G2 ϕ} (A : Type),
      dist (T ∘ U) G2 ∘ fmap (T ∘ U) (ϕ A) = ϕ (T (U A)) ∘ dist (T ∘ U) G1.
  Proof.
    intros. unfold transparent tcs.
    reassociate -> on left.
    unfold_compose_in_compose.
    rewrite (fun_fmap_fmap T).
    rewrite (dist_morph U).
    rewrite <- (fun_fmap_fmap T).
    reassociate <- on left.
    now rewrite (dist_morph T).
  Qed.

  Lemma dist_linear_compose : forall `{Applicative G1} `{Applicative G2} (A : Type),
      dist (T ∘ U) (G1 ∘ G2) = fmap G1 (dist (T ∘ U) G2) ∘ dist (T ∘ U) G1 (A := G2 A).
  Proof.
    intros. unfold transparent tcs.
    rewrite <- (fun_fmap_fmap G1).
    reassociate -> on right;
      change (fmap ?F (fmap ?G ?f)) with (fmap (F ∘ G) f);
      reassociate <- near (fmap (G1 ∘ T) (dist U G2)).
    #[local] Set Keyed Unification.
    rewrite (natural (ϕ := @dist T _ G1 _ _ _)).
    #[local] Unset Keyed Unification.
    reassociate -> on right;
      unfold_ops @Fmap_compose;
      rewrite (fun_fmap_fmap T).
    #[local] Set Keyed Unification.
    rewrite (dist_linear U).
    rewrite (dist_linear T).
    #[local] Unset Keyed Unification.
    reflexivity.
  Qed.

  #[export] Instance Traversable_compose : TraversableFunctor (T ∘ U) :=
    {| dist_morph := @dist_morph_compose;
       dist_unit := @dist_unit_compose;
       dist_linear := @dist_linear_compose;
    |}.

End TraversableFunctor_compose.

(** * Basic properties of traversable functors *)
(******************************************************************************)

(** ** <<pure>> is an applicative homomorphism *)
(******************************************************************************)
Section pure_as_applicative_transformation.

  Context
    `{Applicative G}.

  Lemma pure_appmor_1 : forall A B (f : A -> B) (t : A),
      pure G (fmap (fun A : Type => A) f t) = fmap G f (pure G t).
  Proof.
    intros. now rewrite (app_pure_natural G).
  Qed.

  Lemma pure_appmor_2 : forall (A : Type) (a : A),
      pure G (pure (fun A => A) a) = pure G a.
  Proof.
    intros. reflexivity.
  Qed.

  Lemma pure_appmor_3 : forall (A B : Type) (a : A) (b : B),
      pure G (mult (fun A => A) (a, b)) = mult G (pure G a, pure G b).
  Proof.
    unfold transparent tcs. intros. now rewrite (app_mult_pure G).
  Qed.

  #[export] Instance ApplicativeMorphism_pure :
    ApplicativeMorphism (fun A => A) G (@pure G _) :=
    {| appmor_natural := pure_appmor_1;
       appmor_pure := pure_appmor_2;
       appmor_mult := pure_appmor_3;
    |}.

End pure_as_applicative_transformation.

(** ** Other rules for <<pure>> *)
(******************************************************************************)
Section purity_law.

  Context
    (T : Type -> Type)
    `{TraversableFunctor T}.

  Corollary fmap_purity_1 `{Applicative G} : forall A,
    dist T G ∘ fmap T (pure G) (A := A) = pure G.
  Proof.
    intros. rewrite (dist_morph T (ϕ := @pure G _)).
    now rewrite (dist_unit T).
  Qed.

  Corollary fmap_purity_2 {B} `{Applicative G1} `{Applicative G2} : forall `(f : A -> G1 B),
      dist T (G2 ∘ G1) ∘ fmap T (pure G2 ∘ f) = pure G2 ∘ dist T G1 ∘ fmap T f.
  Proof.
    intros. rewrite <- (fun_fmap_fmap T).
    reassociate <-. rewrite (dist_linear T).
    reassociate -> near (fmap T (pure G2)).
    rewrite fmap_purity_1.
    fequal. ext t. unfold compose.
    now rewrite (app_pure_natural G2).
  Qed.

End purity_law.

(** * Kleisi presentation of traversable functors *)
(******************************************************************************)

From Tealeaves Require
  Classes.Kleisli.Traversable.Functor.

Module ToKleisli.

  Import Classes.Kleisli.Traversable.Functor.

  Section operation.

    Context
      (T : Type -> Type)
      `{Fmap T} `{Dist T}.

    #[export] Instance Traverse_dist : Traverse T :=
      fun (G : Type -> Type) `{Fmap G} `{Pure G} `{Mult G}
        (A B : Type) (f : A -> G B) => dist T G ∘ fmap T f.

  End operation.

  Section with_functor.

    Generalizable All Variables.

    Context
      (T : Type -> Type)
      `{Classes.Traversable.Functor.TraversableFunctor T}.

    Theorem traverse_id : forall (A : Type),
        traverse T (fun A => A) id = @id (T A).
    Proof.
      intros. unfold traverse. unfold_ops @Traverse_dist.
      ext t. rewrite (dist_unit T).
      now rewrite (fun_fmap_id T).
    Qed.

    Theorem traverse_id_purity : forall `{Applicative G} (A : Type),
        traverse T G (pure G) = @pure G _ (T A).
    Proof.
      intros. unfold traverse.
      unfold_ops @Traverse_dist.
      ext t. now rewrite fmap_purity_1.
    Qed.

    Lemma traverse_traverse (G1 G2 : Type -> Type) `{Applicative G2} `{Applicative G1} :
      forall `(g : B -> G2 C) `(f : A -> G1 B),
        fmap G1 (traverse T G2 g) ∘ traverse T G1 f = traverse T (G1 ∘ G2) (fmap G1 g ∘ f).
    Proof.
      introv. unfold traverse.
      unfold_ops @Traverse_dist.
      rewrite (dist_linear T).
      repeat reassociate <-.
      rewrite <- (fun_fmap_fmap T).
      repeat reassociate <-.
      reassociate -> near (fmap T (fmap G1 g)).
      change (fmap T (fmap G1 g)) with (fmap (T ∘ G1) g).
      rewrite <- (natural (ϕ := @dist T _ G1 _ _ _)).
      unfold_ops @Fmap_compose.
      reassociate <-.
      unfold_compose_in_compose.
      now rewrite (fun_fmap_fmap G1).
    Qed.

    Lemma traverse_morphism `{morph : ApplicativeMorphism G1 G2 ϕ} : forall `(f : A -> G1 B),
        ϕ (T B) ∘ traverse T G1 f = traverse T G2 (ϕ B ∘ f).
    Proof.
      intros. unfold traverse.  unfold_ops @Traverse_dist.
      reassociate <-.
      inversion morph.
      rewrite <- (dist_morph T).
      reassociate ->.
      now rewrite (fun_fmap_fmap T).
    Qed.

    #[export] Instance: Kleisli.Traversable.Functor.TraversableFunctor T :=
      {| trf_traverse_id := @traverse_id;
        trf_traverse_traverse := @traverse_traverse;
        trf_traverse_morphism := @traverse_morphism;
      |}.

  End with_functor.

End ToKleisli.

(** * Traversable instance for [list] *)
(******************************************************************************)
#[global] Instance Dist_list : Dist list :=
  fun G map mlt pur A =>
    (fix dist (l : list (G A)) :=
       match l with
       | nil => pure G nil
       | cons x xs =>
         (pure G (@cons A) <⋆> x) <⋆> (dist xs)
       end).

Require Import Tealeaves.Classes.Monad.
Require Import Tealeaves.Functors.List.
Import List.ListNotations.

(** ** Rewriting lemmas for <<dist>> *)
(******************************************************************************)
Section list_dist_rewrite.

  Context
    `{Applicative G}.

  Variable (A : Type).

  Lemma dist_list_nil :
    dist list G (@nil (G A)) = pure G nil.
  Proof.
    reflexivity.
  Qed.

  Lemma dist_list_cons_1 : forall (x : G A) (xs : list (G A)),
      dist list G (x :: xs) =
      (pure G cons <⋆> x) <⋆> (dist list G xs).
  Proof.
    reflexivity.
  Qed.

  Lemma dist_list_cons_2 : forall (x : G A) (xs : list (G A)),
      dist list G (x :: xs) =
      (fmap G (@cons A) x) <⋆> (dist list G xs).
  Proof.
    intros. rewrite dist_list_cons_1.
    now rewrite fmap_to_ap.
  Qed.

  Lemma dist_list_one (a : G A) : dist list G [ a ] = fmap G (ret list) a.
  Proof.
    cbn. rewrite fmap_to_ap. rewrite ap3.
    rewrite <- ap4. now do 2 rewrite ap2.
  Qed.

  Lemma dist_list_app : forall (l1 l2 : list (G A)),
      dist list G (l1 ++ l2) = pure G (@app _) <⋆> dist list G l1 <⋆> dist list G l2.
  Proof.
    intros. induction l1.
    - cbn. rewrite ap2. change (app []) with (@id (list A)).
      now rewrite ap1.
    - cbn [app]. rewrite dist_list_cons_2.
      rewrite dist_list_cons_2.
      rewrite IHl1; clear IHl1.
      rewrite <- fmap_to_ap.
      rewrite <- fmap_to_ap.
      rewrite <- ap4. rewrite <- fmap_to_ap.
      fequal. rewrite <- ap_fmap.
      rewrite fmap_ap. fequal.
      compose near a.
      rewrite (fun_fmap_fmap G).
      rewrite (fun_fmap_fmap G).
      compose near a on left.
      now rewrite (fun_fmap_fmap G).
  Qed.

End list_dist_rewrite.

#[export] Hint Rewrite @dist_list_nil @dist_list_cons_1
     @dist_list_one @dist_list_app : tea_list.

Section dist_list_properties.

  #[local] Arguments dist _%function_scope {Dist} _%function_scope {H H0 H1}
    A%type_scope _.

  Generalizable All Variables.

  Lemma dist_list_1 : forall `{Applicative G} `(f : A -> B) (a : G A) (l : list (G A)),
      fmap G (fmap list f) ((fmap G (@cons A) a) <⋆> dist list G A l) =
      (fmap G (@cons B ○ f) a) <⋆> fmap G (fmap list f) (dist list G A l).
  Proof.
    intros. rewrite fmap_ap. rewrite <- ap_fmap.
    fequal. compose near a. now rewrite 2(fun_fmap_fmap G).
  Qed.

  Lemma dist_list_2 : forall `{Applicative G} `(f : A -> B) (a : G A) (l : list (G A)),
      fmap G (fmap list f) ((pure G (@cons A) <⋆> a) <⋆> dist list G A l) =
      (pure G cons <⋆> fmap G f a) <⋆> fmap G (fmap list f) (dist list G A l).
  Proof.
    intros. rewrite <- fmap_to_ap.
    rewrite fmap_ap.
    compose near a on left.
    rewrite (fun_fmap_fmap G).
    rewrite pure_ap_fmap.
    unfold ap. rewrite (app_mult_natural G).
    rewrite (app_mult_natural_1 G).
    compose near ((a ⊗ dist list G A l)) on right.
    rewrite (fun_fmap_fmap G). fequal. ext [? ?].
    reflexivity.
  Qed.

  Lemma dist_natural_list : forall `{Applicative G} `(f : A -> B),
      fmap (G ∘ list) f ∘ dist list G A =
      dist list G B ∘ fmap (list ∘ G) f.
  Proof.
    intros; cbn. unfold_ops @Fmap_compose. unfold compose.
    ext l. induction l.
    + cbn. now rewrite (app_pure_natural G).
    + rewrite dist_list_cons_2.
      rewrite fmap_list_cons, dist_list_cons_2.
      rewrite <- IHl. rewrite dist_list_1.
      compose near a on right. now rewrite (fun_fmap_fmap G).
  Qed.

  Instance dist_natural_list_ : forall `{Applicative G}, Natural (@dist list _ G _ _ _).
  Proof.
    constructor; try typeclasses eauto.
    intros. eapply (dist_natural_list f).
  Qed.

  Lemma dist_morph_list : forall `{ApplicativeMorphism G1 G2 ϕ} A,
      dist list G2 A ∘ fmap list (ϕ A) = ϕ (list A) ∘ dist list G1 A.
  Proof.
    intros. ext l. unfold compose. induction l.
    - cbn. now rewrite (appmor_pure G1 G2).
    - specialize (appmor_app_F G1 G2);
        specialize (appmor_app_G G1 G2);
        intros.
      rewrite fmap_list_cons, dist_list_cons_2.
      rewrite dist_list_cons_2.
      rewrite IHl. rewrite ap_morphism_1.
      fequal. now rewrite (appmor_natural G1 G2 A).
  Qed.

  Lemma dist_unit_list : forall (A : Type),
      dist list (fun A => A) A = @id (list A).
  Proof.
    intros. ext l. induction l.
    - reflexivity.
    - cbn. now rewrite IHl.
  Qed.

  #[local] Set Keyed Unification.
  Lemma dist_linear_list
    : forall `{Applicative G1} `{Applicative G2} (A : Type),
      dist list (G1 ∘ G2) A =
      fmap G1 (dist list G2 A) ∘ dist list G1 (G2 A).
  Proof.
    intros. unfold compose. ext l. induction l.
    - cbn. unfold_ops @Pure_compose.
      rewrite fmap_to_ap. now rewrite ap2.
    - rewrite (dist_list_cons_2 (G := G1 ○ G2)).
      rewrite (dist_list_cons_2 (G := G1)).
      rewrite IHl; clear IHl.
      unfold_ops @Mult_compose @Pure_compose @Fmap_compose.
      rewrite (ap_compose2 G2 G1).
      compose near a on left.
      rewrite (fun_fmap_fmap G1).
      unfold ap at 1.
      rewrite (app_mult_natural G1).
      unfold ap at 2. rewrite (app_mult_natural_1 G1).
      fequal. compose near (a ⊗ dist list G1 (G2 A) l).
      repeat rewrite (fun_fmap_fmap G1). fequal.
      ext [? ?]. cbn. unfold compose. now rewrite fmap_to_ap.
  Qed.
  #[local] Unset Keyed Unification.

End dist_list_properties.

#[export] Instance Traversable_list : Classes.Traversable.Functor.TraversableFunctor list :=
  {| dist_natural := @dist_natural_list_;
     dist_morph := @dist_morph_list;
     dist_unit := @dist_unit_list;
     dist_linear := @dist_linear_list;
  |}.

Require Import Tealeaves.Functors.Environment.

(** * Traversable instance for <<prod>> *)
(******************************************************************************)
Section TraversableFunctor_prod.

  Generalizable All Variables.

  Context
    (X : Type).

  #[global] Instance Dist_prod : Dist (prod X) :=
    fun F map mlt pur A '(x, a) => fmap F (pair x) a.

  Lemma dist_natural_prod : forall `{Applicative G} `(f : A -> B),
      fmap (G ∘ prod X) f ∘ dist (prod X) G = dist (prod X) G ∘ fmap (prod X ∘ G) f.
  Proof.
    intros; unfold compose; cbn. ext [x a]; cbn.
    unfold_ops @Fmap_compose. compose near a.
    now do 2 rewrite (fun_fmap_fmap G).
  Qed.

  Instance dist_natural_prod_ : forall `{Applicative G}, Natural (@dist (prod X) _ G _ _ _).
  Proof.
    constructor; try typeclasses eauto.
    intros. eapply (dist_natural_prod f).
  Qed.

  Lemma dist_morph_prod : forall `{ApplicativeMorphism G1 G2 ϕ} A,
      dist (prod X) G2 ∘ fmap (prod X) (ϕ A) = ϕ (X * A) ∘ dist (prod X) G1.
  Proof.
    intros; unfold compose; cbn. ext [x a]; cbn.
    specialize (appmor_app_F G1 G2);
        specialize (appmor_app_G G1 G2);
        intros.
    now rewrite (appmor_natural G1 G2).
  Qed.

  Lemma dist_unit_prod : forall (A : Type),
      dist (prod X) (fun A => A) = @id (prod X A).
  Proof.
    intros; unfold compose; cbn. ext [x a]; now cbn.
  Qed.

  Lemma dist_linear_prod : forall `{Applicative G1} `{Applicative G2} (A : Type),
      dist (prod X) (G1 ∘ G2) (A := A) =
      fmap G1 (dist (prod X) G2) ∘ dist (prod X) G1.
  Proof.
    intros; unfold compose; cbn. ext [x a].
    unfold_ops @Dist_prod @Fmap_compose.
    compose near a on right. now rewrite (fun_fmap_fmap G1).
  Qed.

  #[global] Instance Traversable_prod : Classes.Traversable.Functor.TraversableFunctor (prod X) :=
    {| dist_natural := @dist_natural_prod_;
       dist_morph := @dist_morph_prod;
       dist_unit := @dist_unit_prod;
       dist_linear := @dist_linear_prod;
    |}.

End TraversableFunctor_prod.

From Tealeaves Require Import Classes.Monoid Functors.Constant.

(** * Operations involving constant applicative functors *)
(******************************************************************************)
(** To distributive over constant applicative functors, i.e. to fold
    over monoidal values, we can use the <<Const>> applicative
    functor. Unfortunately this tends to clutter operations with
    <<unconst>> operations which get in the way of convenient
    rewriting. We provide a lighter-weight alternative in this section
    and some specifications proving equivalence with the <<Const>>
    versions. *)
Section TraversableFunctor_const.

  Generalizable Variable M.

  Context
    (T : Type -> Type)
    `{TraversableFunctor T}.

  (** *** Distribution over <<const>> is agnostic about the tag. *)
  (** Distribution over a constant applicative functor is agnostic
      about the type argument ("tag") to the constant functor. On
      paper it is easy to ignore this, but in Coq this must be
      proved. Observe this equality is ill-typed if [Const] is used instead. *)
  (******************************************************************************)
  Lemma dist_const1 : forall (X : Type) `{Monoid M},
      (@dist T _ (const M)
             (Fmap_const) (Pure_const) (Mult_const) X)
      =
      (@dist T _ (const M)
             (Fmap_const) (Pure_const) (Mult_const) False).
  Proof.
    intros. symmetry. change (?f = ?g) with (f = g ∘ (@id (T M))).
    rewrite <- (fun_fmap_id T).
    change (@id M) with
        (fmap (A := False) (B:=X) (const M) exfalso).
    change (fmap T (fmap (const M) ?f))
      with (fmap (T ∘ const M) f).
    rewrite <- (natural (ϕ := @dist T _ (const M) _ _ _) (B := X) (A := False)).
    reflexivity.
  Qed.

  Lemma dist_const2 : forall (X Y : Type) `{Monoid M},
      (@dist T _ (const M)
             (Fmap_const) (Pure_const) (Mult_const) X)
      =
      (@dist T _ (const M)
             (Fmap_const) (Pure_const) (Mult_const) Y).
  Proof.
    intros. now rewrite (dist_const1 X), (dist_const1 Y).
  Qed.

  (** *** Distribution over [Const] vs <<const>> *)
  (******************************************************************************)
  Theorem traversable_const_spec (tag : Type) `{Monoid M} :
    unconst ∘ @dist T _ (Const M)
            (Fmap_Const)
            (Pure_Const)
            (Mult_Const) tag ∘ fmap T (mkConst)
    = @dist T _ (const M)
            (Fmap_const)
            (Pure_const)
            (Mult_const) tag.
  Proof.
    intros. rewrite <- (dist_morph T (ϕ := @unconst _)).
    reassociate -> on left. rewrite (fun_fmap_fmap T).
    change (unconst ∘ mkConst) with (@id M).
    now rewrite (fun_fmap_id T).
  Qed.

End TraversableFunctor_const.

From Tealeaves Require Import Functors.ProductFunctor.
Import ProductFunctor.Notations.

Definition traversal_combine {F G A B} `(f : A -> F B) `(g : A -> G B) : A -> (F ◻ G) B :=
  fun a => product (f a) (g a).

#[local] Notation "f <◻> g" := (traversal_combine f g) (at level 60) : tealeaves_scope.

(** * Characterization of distribution w.r.t. (F ◻ G) *)
(******************************************************************************)
Section traversable_product.

  Context
    (T : Type -> Type)
    `{TraversableFunctor T}
    `{Applicative G1}
    `{Applicative G2}.

  Export Classes.Kleisli.Traversable.Functor.
  Import Traversable.Functor.ToKleisli.

  Variables
    (A B : Type)
    (f : A -> G1 B) (g : A -> G2 B).

  Lemma dist_combine1 : forall (t : T A),
    pi1 (traverse T (G1 ◻ G2) (f <◻> g) t) = traverse T G1 f t.
  Proof.
    intros. pose (ApplicativeMorphism_pi1 G1 G2).
    compose near t on left.
    now rewrite (trf_traverse_morphism T).
  Qed.

  Lemma dist_combine2 : forall (t : T A),
    pi2 (traverse T (G1 ◻ G2) (f <◻> g) t) = traverse T G2 g t.
  Proof.
    intros. pose (ApplicativeMorphism_pi2 G1 G2).
    compose near t on left.
    now rewrite (traverse_morphism T).
  Qed.

  Theorem dist_combine : forall (t : T A),
    dist T (G1 ◻ G2) (fmap T (f <◻> g) t) =
    product (traverse T G1 f t) (traverse T G2 g t).
  Proof.
    intros. compose near t on left.
    erewrite <- (dist_combine1).
    erewrite <- (dist_combine2).
    now rewrite <- product_eta.
  Qed.

  Theorem traverse_combine :
    traverse T (G1 ◻ G2) (f <◻> g) = (traverse T G1 f) <◻> (traverse T G2 g).
  Proof.
    intros. unfold_ops Traverse_dist.
    ext t. unfold compose.
    now rewrite dist_combine.
  Qed.

End traversable_product.

(** * Notations *)
(******************************************************************************)
Module Notations.
  Notation "'δ'" := (dist) : tealeaves_scope.
  Notation "f <◻> g" := (traversal_combine f g) (at level 60) : tealeaves_scope.
End Notations.

(** * Decomposing <<dist>> in terms of <<iterate>> *)
(******************************************************************************)
Section traversal_iterate.

  Import Classes.Kleisli.Traversable.Functor.

  Context
    `{Classes.Traversable.Functor.TraversableFunctor T}.

  Import Traversable.Functor.ToKleisli.

  Lemma dist_to_runBatch `{Applicative G} {A : Type} :
    dist T G (A := A) = runBatch (@id (G A)) ∘ Functor.toBatch T A.
  Proof.
    ext t.
    replace t with (fmap T id t) at 1 by (now rewrite (fun_fmap_id T)).
    change_left (traverse T G (@id (G A)) t).
    now rewrite (traverse_to_runBatch T).
  Qed.

End traversal_iterate.


From iris.bi Require Import bi.
From iris.proofmode Require Export classes.
From iris Require Import options.
Import bi.

Section modalities.
  Context {PROP : bi}.

  Lemma modality_persistently_mixin :
    modality_mixin (@bi_persistently PROP) MIEnvId MIEnvClear.
  Proof.
    split; simpl; eauto using equiv_entails_sym, persistently_intro,
      persistently_mono, persistently_sep_2 with typeclass_instances.
  Qed.
  Definition modality_persistently :=
    Modality _ modality_persistently_mixin.

  Lemma modality_affinely_mixin :
    modality_mixin (@bi_affinely PROP) MIEnvId (MIEnvForall Affine).
  Proof.
    split; simpl; eauto using equiv_entails_sym, affinely_intro, affinely_mono,
      affinely_sep_2 with typeclass_instances.
  Qed.
  Definition modality_affinely :=
    Modality _ modality_affinely_mixin.

  Lemma modality_intuitionistically_mixin :
    modality_mixin (@bi_intuitionistically PROP) MIEnvId MIEnvIsEmpty.
  Proof.
    split; simpl; eauto using equiv_entails_sym, intuitionistically_emp,
      affinely_mono, persistently_mono, intuitionistically_idemp,
      intuitionistically_sep_2 with typeclass_instances.
  Qed.
  Definition modality_intuitionistically :=
    Modality _ modality_intuitionistically_mixin.

  Lemma modality_embed_mixin `{BiEmbed PROP PROP'} :
    modality_mixin (@embed PROP PROP' _)
      (MIEnvTransform IntoEmbed) (MIEnvTransform IntoEmbed).
  Proof.
    split; simpl; split_and?;
      eauto using equiv_entails_sym, embed_emp_2, embed_sep, embed_and.
    - intros P Q. rewrite /IntoEmbed=> ->. by rewrite embed_intuitionistically_2.
    - by intros P Q ->.
  Qed.
  Definition modality_embed `{BiEmbed PROP PROP'} :=
    Modality _ modality_embed_mixin.

  Lemma modality_plainly_mixin `{BiPlainly PROP} :
    modality_mixin (@plainly PROP _) (MIEnvForall Plain) MIEnvClear.
  Proof.
    split; simpl; split_and?; eauto using equiv_entails_sym, plainly_intro,
      plainly_mono, plainly_and, plainly_sep_2 with typeclass_instances.
  Qed.
  Definition modality_plainly `{BiPlainly PROP} :=
    Modality _ modality_plainly_mixin.

  Lemma modality_laterN_mixin n :
    modality_mixin (@bi_laterN PROP n)
      (MIEnvTransform (MaybeIntoLaterN false n)) (MIEnvTransform (MaybeIntoLaterN false n)).
  Proof.
    split; simpl; split_and?; eauto using equiv_entails_sym, laterN_intro,
      laterN_mono, laterN_and, laterN_sep with typeclass_instances.
    rewrite /MaybeIntoLaterN=> P Q ->. by rewrite laterN_intuitionistically_2.
  Qed.
  Definition modality_laterN n :=
    Modality _ (modality_laterN_mixin n).
End modalities.


(* Claim: *)
Require Import Syntax.
Require Import TypeSyntax.
Require Import TypeSpec.

Section Test.
    Variables f x z : variable.
    Variables rho rho' : ls_var.
    Variable X : le_var.

    Variable H_rhos_diff : rho <> rho'.
    Variable H_f_x_diff : f <> x.
    Variable H_f_z_diff : f <> z.
    Variable H_x_z_diff : x <> z.

    Hint Constructors abstrstate_order.

    Definition typeToScheme (a : annotatedtype) : scheme := sc_Quant nil nil c_Empty a.
    Coercion typeToScheme : annotatedtype >-> scheme.

    Definition le_singelton rho n := le_Append le_Empty (ls_Var rho) (Zinf_Z n).

    Definition C := c_LockEnv (le_singelton rho 1) (le_Var X).
    Definition Gamma := G_Empty.
    Definition AT_lock := (at_Lock (ls_Var rho)).

    Definition AT_arrow := at_Arrow AT_lock (EffectIntro le_Empty (le_Var X)) AT_lock.
    Definition ST_arrow := st_Arrow st_Lock st_Lock.

    Definition body := t_Let z st_Lock (e_AcqLock (v_VarRef x))
                        (t_Value (v_VarRef z)).
    Definition expr := e_Thread (t_Value (v_RecFun f ST_arrow x st_Lock body)).

    Definition eff_working := EffectIntro le_Empty le_Empty.

    Lemma Working:
        welltyped_spec C Gamma expr AT_arrow eff_working.
    Proof.
        apply T_Abs2 with (phi := eff_working); auto.
        apply T_Let with (SC_1 := AT_lock) (D_2 := le_Var X); auto.
        - apply T_Lock.
            * apply T_Var, CL_found.
            *


Require Export SystemFR.RedTactics.
Require Export SystemFR.ErasedEquivalentIte.

Opaque reducible_values.
Opaque makeFresh.

Lemma equivalent_split_ite:
  forall ρ Γ1 Γ2 b e1 e2 t t' e x y l,
    [ support ρ; Γ2 ⊨ b : T_bool ] ->
    valid_interpretation ρ ->
    (forall z, z ∈ support Γ1 -> z ∈ fv e1 -> False) ->
    (forall z, z ∈ support Γ1 -> z ∈ fv e2 -> False) ->
    (forall z, z ∈ support Γ1 -> z ∈ fv e -> False) ->
    (forall z, z ∈ support Γ1 -> z ∈ fv b -> False) ->
    ~(x ∈ fv_context Γ1) ->
    ~(x ∈ fv t) ->
    ~(x ∈ fv t') ->
    ~(y ∈ fv e) ->
    ~(y ∈ fv e1) ->
    ~(y ∈ fv e2) ->
    ~(y ∈ fv b) ->
    ~(y ∈ fv t) ->
    ~(y ∈ fv t') ->
    ~(y ∈ fv_context Γ1) ->
    ~(y ∈ fv_context Γ2) ->
    ~(x = y) ->
    subset (fv b ++ fv e1 ++ fv e2) (support Γ2) ->
    subset (fv e) (support Γ2) ->
    wf e 0 ->
    wf b 0 ->
    wf e1 0 ->
    wf e2 0 ->
    (forall l,
       satisfies (reducible_values ρ)
                 (Γ1 ++ (x, T_equiv e1 e) :: (y, T_equiv b ttrue) :: Γ2)
                 l ->
       [ substitute t l ≡ substitute t' l ]) ->
    (forall l,
       satisfies (reducible_values ρ)
                 (Γ1 ++ (x, T_equiv e2 e) :: (y, T_equiv b tfalse) :: Γ2)
                 l ->
       [ substitute t l ≡ substitute t' l ]) ->
    satisfies (reducible_values ρ) (Γ1 ++ (x, T_equiv (ite b e1 e2) e) :: Γ2) l ->
    [ substitute t l ≡ substitute t' l ].
Proof.
  unfold open_reducible,reduces_to;
    repeat step || list_utils || satisfies_cut || t_instantiate_sat3 || t_termlist || step_inversion satisfies ||
           simp_red.

  - unshelve epose proof (H23 (l1 ++ (x, uu) :: (y, uu) :: lterms) _);
      repeat step || apply satisfies_insert || list_utils || t_substitutions || simp_red;
      t_closer;
      eauto using equivalent_ite_true3;
      eauto using satisfies_drop;
      try solve [ equivalent_star ].

  - unshelve epose proof (H24 (l1 ++ (x, uu) :: (y, uu) :: lterms) _);
      repeat step || apply satisfies_insert || list_utils || t_substitutions || simp_red;
      t_closer;
      eauto using equivalent_ite_false3;
      eauto using satisfies_drop;
      try solve [ equivalent_star ].
Qed.


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

(** %\subsection*{ support :  Map2.v }%*)
(** This file introduces [Map2] which is to [A->B->C] like [Map] is to [A->B]
 Similarly a setoid [MAP2] is introduced and we have tools for (un)currying
 and using / filling in arguments. This is not linear algebra-specific and
 could all have been done inside the  algebra contribution; it just facilitates
 using fuctions of two arguments *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export equal_syntax.
From Algebra Require Export Cartesian.

(* We have setoid-compatible functions called "Map" *)

(* These are 1-ary functions; more general n-ary functions are defined by *)
(* (un)currying, (repeatedly) using (cart A B), the cartesian product *)
(* setoid construction. Still, it's nicer to have a more direct way of *)
(* dealing with 2-ary functions because these occur relatively often. *)

(* I call these "Map2" - and here I provide also tools to jump between *)
(* the two representations. *)

(** %\label{Map2}% *)
Record Map2 (A B C : Setoid) : Type :=
  {Ap2 :> A -> B -> C; Ap2_comp_proof : fun2_compatible Ap2}.

Definition Map2_Mapcart :
  forall A B C : Setoid, Map2 A B C -> Map (cart A B) C.
intros.
apply (Build_Map (Ap:=fun ab : cart A B => X (proj1 ab) (proj2 ab))).
red in |- *.
intros.
elim X.
intros.
red in Ap2_comp_proof0.
simpl in |- *.
apply Ap2_comp_proof0; auto with algebra.
Defined.

Definition Mapcart_Map2 :
  forall A B C : Setoid, Map (cart A B) C -> Map2 A B C.
intros.
apply (Build_Map2 (Ap2:=fun (a : A) (b : B) => X (couple a b))).
red in |- *.
intros.
apply Ap_comp; auto with algebra.
Defined.

(* The setoid of 2-ary functions *)
Definition MAP2 (A B C : Setoid) : Setoid.
intros.
apply
 (Build_Setoid
    (Equal:=fun f g : Map2 A B C =>
            forall (a a' : A) (b b' : B),
            a =' a' in _ -> b =' b' in _ -> f a b =' g a' b' in _)).
split; try split; red in |- *; unfold app_rel in |- *.
intros; destruct x.
simpl in |- *.
apply Ap2_comp_proof0; auto with algebra.
intros.
apply Trans with (y a b); auto with algebra.
intros.
apply Sym; auto with algebra.
Defined.

(* Tools for filling in first and second arguments. *)
Definition Map2_ap_Map : forall A B C : Setoid, Map2 A B C -> A -> MAP B C.
intros.
apply (Build_Map (Ap:=X X0)).
destruct X; red in |- *; simpl in |- *.
intros.
apply Ap2_comp_proof0; auto with algebra.
Defined.

Definition Ap2_Map : forall A B C : Setoid, Map2 A B C -> Map A (MAP B C).
intros.
apply (Build_Map (Ap:=fun a => Map2_ap_Map X a)).
red in |- *.
intros; simpl in |- *.
red in |- *; simpl in |- *.
intros; destruct X.
simpl in |- *.
apply Ap2_comp_proof0; auto with algebra.
Defined.

Definition Map2_ap'_Map : forall A B C : Setoid, Map2 A B C -> B -> MAP A C.
intros.
apply (Build_Map (Ap:=fun a => X a X0)).
destruct X; red in |- *; simpl in |- *.
intros.
apply Ap2_comp_proof0; auto with algebra.
Defined.

Definition Ap2_Map' : forall A B C : Setoid, Map2 A B C -> Map B (MAP A C).
intros.
apply (Build_Map (Ap:=fun b => Map2_ap'_Map X b)).
red in |- *.
intros; simpl in |- *.
red in |- *; simpl in |- *.
intros; destruct X.
simpl in |- *.
apply Ap2_comp_proof0; auto with algebra.
Defined.


Require Import Poulet4.P4light.Syntax.P4defs.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import Coq.Program.Program.
Require Import ProD3.core.Core.
Require Import ProD3.core.Tofino.
Require Import ProD3.examples.sbf.p4ast.
Require Import ProD3.examples.sbf.ConFilter.

Open Scope func_spec.

Notation ident := string.
Notation path := (list ident).
Notation Val := (@ValueBase bool).
Notation Sval := (@ValueBase (option bool)).

Definition am_ge := ltac:(get_am_ge prog).
(* Finished transaction in 4.375 secs (4.218u,0.156s) (successful) *)
Definition ge := ltac:(get_ge am_ge prog).

(* Constants *)

Definition NOOP := 0.
Definition CLEAR := 1.
Definition INSERT := 2.
Definition QUERY := 3.
Definition INSQUERY := 4.

Definition index_w := 18%N.
Definition num_slots := Eval compute in 2 ^ (Z.of_N index_w).
Definition num_rows := 3.
Definition num_frames := 4.
Definition frame_tick_tocks := 7034.
Definition tick_time := 2097152.
Definition frame_time := frame_tick_tocks * tick_time * 2.

Definition poly1 : Tofino.CRC_polynomial :=
  {|
    Tofino.CRCP_width := 32;
    Tofino.CRCP_coeff := P4Arith.to_lbool 32 79764919;
    Tofino.CRCP_reversed := true;
    Tofino.CRCP_msb := false;
    Tofino.CRCP_extended := false;
    Tofino.CRCP_init := P4Arith.to_lbool 32 0;
    Tofino.CRCP_xor := P4Arith.to_lbool 32 4294967295
  |}.

Definition hash1 (v : Val) :=
  hash_Z 32 poly1 v mod 2 ^ (Z.of_N index_w).

Definition poly2 : Tofino.CRC_polynomial :=
  {|
    Tofino.CRCP_width := 32;
    Tofino.CRCP_coeff := P4Arith.to_lbool 32 517762881;
    Tofino.CRCP_reversed := true;
    Tofino.CRCP_msb := false;
    Tofino.CRCP_extended := false;
    Tofino.CRCP_init := P4Arith.to_lbool 32 0;
    Tofino.CRCP_xor := P4Arith.to_lbool 32 4294967295
  |}.

Definition hash2 (v : Val) :=
  hash_Z 32 poly2 v mod 2 ^ Z.of_N index_w.

Definition poly3 : Tofino.CRC_polynomial :=
  {|
    Tofino.CRCP_width := 32;
    Tofino.CRCP_coeff := P4Arith.to_lbool 32 2821953579;
    Tofino.CRCP_reversed := true;
    Tofino.CRCP_msb := false;
    Tofino.CRCP_extended := false;
    Tofino.CRCP_init := P4Arith.to_lbool 32 0;
    Tofino.CRCP_xor := P4Arith.to_lbool 32 4294967295
  |}.

Definition hash3 (v : Val) :=
  hash_Z 32 poly3 v mod 2 ^ Z.of_N index_w.

Definition header_type : Set := Z * Z.

Definition header_to_val '((x, y) : header_type) : Val :=
  ValBaseBit ((P4Arith.to_lbool 32 y) ++ (P4Arith.to_lbool 32 x)).

Definition hashes := [hash1 ∘ header_to_val; hash2 ∘ header_to_val; hash3 ∘ header_to_val].

Lemma H_Zlength_hashes : Zlength hashes = num_rows.
Proof. auto. Qed.

Lemma b2z_range : forall b,
  0 <= Z.b2z b < 2.
Proof.
  destruct b; simpl; lia.
Qed.

Ltac add_b2z_range b :=
  assert_fails (assert (0 <= Z.b2z b < 2) by assumption);
  pose proof (b2z_range b).

Ltac saturate_b2z :=
  repeat match goal with
  | H : context [Z.b2z ?b] |- _ =>
      add_b2z_range b
  | |- context [Z.b2z ?b] =>
      add_b2z_range b
  end.

Ltac Zify.zify_pre_hook ::=
  unfold is_true, index_w, num_slots, num_rows, num_frames, frame_tick_tocks,
    NOOP, CLEAR, INSERT, QUERY, INSQUERY in *;
  saturate_b2z.

Definition rows := ["row_1"; "row_2"; "row_3"].
Definition panes := ["win_1"; "win_2"; "win_3"; "win_4"].

Definition H_num_slots : 0 < num_slots := eq_refl.
Definition H_num_rows : 0 < num_rows := eq_refl.
Definition H_num_frames : 1 < num_frames := eq_refl.

Notation row := (row num_slots).
Notation frame := (frame num_rows num_slots).

#[export] Instance Inhabitant_row : Inhabitant row :=
  Inhabitant_row H_num_slots.

#[export] Instance Inhabitant_frame : Inhabitant frame :=
  Inhabitant_frame H_num_rows H_num_slots.

(* NoAction *)

Definition NoAction_fundef : @fundef Info :=
  ltac:(get_fd ["NoAction"] ge).

Definition NoAction_spec : func_spec :=
  WITH,
    PATH []
    MOD None []
    WITH,
      PRE
        (ARG []
        (MEM []
        (EXT [])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM []
        (EXT []))).

Lemma NoAction_body :
  func_sound ge NoAction_fundef nil NoAction_spec.
Proof.
  start_function.
  step.
  entailer.
Qed.


From extructures Require Export ord fmap fset.
From mathcomp Require Export ssrbool. (* TODO, strange *)
From mathcomp Require Import ssreflect ssrfun seq.
Require Import Lib.Extra.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Set Bullet Behavior "Strict Subproofs".

Definition NMap T := {fmap nat -> T}.

Definition elementsm {A: Type} : NMap A -> list (nat * A).
Proof.
     exact (@FMap.fmval nat_ordType A _)
  ||
     idtac "ExStructures 0.1 legacy definition inactive";
     exact (@FMap.fmval nat_ordType A).
Defined.

(* RB: TODO: These lemmas, with their clean proofs, probably belong in CoqUtils. *)

Lemma mapm_empty: forall (T : ordType) (S S' : Type) (f : S -> S'),
  mapm f (@emptym T S) = emptym.
Proof.
    by move => T S S' f; apply /eq_fmap => n; rewrite emptymE.
Qed.

Lemma mapm_unionm (T T' : Type) (m1 m2 : NMap T) (f : T -> T') :
  mapm f (unionm m1 m2) = unionm (mapm f m1) (mapm f m2).
Proof.
  apply /eq_fmap => n. rewrite !(mapmE, unionmE). by case: (m1 n).
Qed.

Lemma filterm_predT (T : Type) (m : NMap T) :
  filterm (fun (k : nat) (_ : T) => true) m = m.
Proof.
  apply /eq_fmap => n. rewrite filtermE. by case: (m n).
Qed.

Lemma filterm_predF (T : Type) (m : NMap T) :
  filterm (fun (k : nat) (_ : T) => false) m = emptym.
Proof.
  apply /eq_fmap => n. rewrite filtermE. by case: (m n).
Qed.

Lemma eq_in_filterm (T:Type) f1 f2 (m : NMap T) :
  (forall k v, m k = Some v -> f1 k v = f2 k v) ->
  filterm f1 m = filterm f2 m.
Proof.
  move=> e. apply/eq_fmap=> k. rewrite 2!filtermE.
  case H : (m k) => [v|] //=.
  now rewrite e.
Qed.

Lemma fdisjoint_filterm_full (T T' : Type) (m1 : NMap T) (m2 : NMap T') :
  fdisjoint (domm m1) (domm m2) ->
  filterm (fun (k : nat) (_ : T) => k \notin domm m2) m1 = m1.
Proof.
  move => /fdisjointP H.
  rewrite -[RHS]filterm_predT. apply eq_in_filterm => k v kv.
  apply H. apply /dommP. by exists v.
Qed.

(* RB: TODO: Fix name! There is no disjointness condition here, even though its
   counterpart does have it. *)
Lemma fdisjoint_filterm_empty (T : Type) (m1 m2 : NMap T) :
  domm m1 = domm m2 ->
  filterm (fun (k : nat) (_ : T) => k \notin domm m1) m2 = emptym.
Proof.
  move => H.
  rewrite -[RHS](filterm_predF m2). apply eq_in_filterm => k v kv.
  apply negbTE. apply /negPn. rewrite H. apply /dommP. by exists v.
Qed.

(* RB: NOTE: This generalizes the above result. *)
Lemma fsubset_filterm_domm_emptym (T : Type) (m1 m2 : NMap T) :
  fsubset (domm m2) (domm m1) ->
  filterm (fun (k : nat) (_ : T) => k \notin domm m1) m2 = emptym.
Proof.
  move=> H.
  rewrite -[RHS](filterm_predF m2). apply eq_in_filterm => k v kv.
  apply negbTE. apply /negPn.
  apply /fsubsetP. apply H. apply /dommP. by exists v.
Qed.

Lemma fdisjoint_filterm_mapm_empty (T T' : Type) (m : NMap T) (f : T -> T') :
  filterm (fun (k : nat) (_ : T') => k \notin domm m) (mapm f m) = emptym.
Proof.
  rewrite -[RHS](filterm_predF (mapm f m)). apply eq_in_filterm => k v kv.
  rewrite -(domm_map f).
  apply negbTE. apply /negPn. apply /dommP. by exists v.
Qed.

Lemma fdisjoint_filterm_mapm_unionm (T T' : Type) (m1 m2 : NMap T) (f : T -> T') :
  fdisjoint (domm m1) (domm m2) ->
  filterm (fun (k : nat) (_ : T') => k \notin domm m2) (mapm f (unionm m1 m2)) =
  filterm (fun (k : nat) (_ : T') => k \notin domm m2) (mapm f m1).
Proof.
  move => Hdisjoint. rewrite mapm_unionm filterm_union.
  - by rewrite -(fdisjoint_filterm_full Hdisjoint) fdisjoint_filterm_mapm_empty unionm0.
  - by rewrite! domm_map.
Qed.

(* Filter has no effect on reads outside its domain. *)
Lemma getm_filterm_notin_domm :
  forall (T T' : Type) (m1 : NMap T) (m2 : NMap T') k,
    k \notin domm m1 ->
    (filterm (fun (k : nat) (_ : T') => k \notin domm m1) m2) k = m2 k.
Proof.
  intros T T' m1 m2 k Hnotin.
  rewrite filtermE Hnotin.
  destruct (m2 k) as [v |] eqn:Hcase;
    rewrite Hcase || idtac "ExStructures 0.1 legacy rewrite inactive";
    done.
Qed.

(* Set and filter commute if the key is outside the domain of filter. *)
Lemma setm_filterm_notin_domm :
  forall (T T' : Type) (m1 : NMap T) (m2 : NMap T') k (v : T'),
    k \notin domm m1 ->
    setm (filterm (fun (k : nat_ordType) (_ : T') => k \notin domm m1) m2) k v =
    filterm (fun (k : nat_ordType) (_ : T') => k \notin domm m1) (setm m2 k v).
Proof.
  intros T T' m1 m2 k v Hnotin.
  apply /eq_fmap => n.
  rewrite filtermE !setmE filtermE.
  destruct (eqtype.eq_op n k) eqn:Hcase.
  - pose proof eqtype.eqP Hcase; subst n. now rewrite Hnotin.
  - reflexivity.
Qed.

(* RB: NOTE: filterm_union, a related lemma, does not include the final 'm' in
   its name. *)
(* JT: this proof needs a lot of cleaning *)
Lemma filterm_domm_unionm (T T' : Type) (m : NMap T) (m1 m2 : NMap T') :
  filterm (fun (k : nat) (_ : T) => k \notin domm m1)
          (filterm (fun (k : nat) (_ : T) => k \notin domm m2) m) =
  filterm (fun (k : nat) (_ : T) => k \notin domm (unionm m1 m2)) m.
Proof.
  apply /eq_fmap => n.
  rewrite !filtermE.
  unfold obind. unfold oapp.
  destruct (m n) eqn:Hcase;
    rewrite Hcase || idtac "ExStructures 0.1 legacy rewrite inactive".
  -  destruct (n \notin domm m2) eqn:Hcase'; rewrite Hcase'.
     + destruct (n \notin domm m1) eqn:Hcase''; rewrite Hcase''.
       ++ assert (n \notin domm (unionm m1 m2)).
          rewrite domm_union.
          apply /fsetUP /orP.
          apply Bool.negb_true_iff in Hcase'; apply Bool.negb_true_iff in Hcase''.
          rewrite Hcase' Hcase''. by [].
            by rewrite H.
       ++ assert (n \notin domm (unionm m1 m2) = false).
          rewrite domm_union.
          apply /fsetUP /orP.
          apply Bool.negb_false_iff in Hcase''; rewrite Hcase''. by [].
          by rewrite H.
    + destruct (n \notin domm (unionm m1 m2)) eqn:Hcase''; rewrite Hcase''.
      ++ rewrite domm_union in Hcase''.
         move: Hcase''. move=> /fsetUP Hcase''.
         destruct (n \in domm m2) eqn:Hcase'''.
         +++ move: Hcase''. move=> /orP. rewrite orbC. simpl. by [].
         +++ by [].
      ++ by reflexivity.
  - by reflexivity.
Qed.

(* CA: not really needed *)
Lemma mapm_id : forall (T : Type) (i: NMap T), mapm id i = i.
Proof.
  move=> T i. apply /eq_fmap => n.
  rewrite mapmE. unfold omap, obind, oapp.
  remember (i n) as v; simpl in *;
    rewrite <- Heqv || idtac "ExStructures 0.1 legacy rewrite inactive".
  now destruct v.
Qed.

(* needed in the proof of domm_filterm_fdisjoint_unionm *)
Lemma filterm_id : forall (T : Type) (i : NMap T) p,

    domm (filterm p i) = domm (filterm p (mapm id i)).
Proof.
  move => T i. by rewrite mapm_id.
Qed.

Lemma domm_filterm_fdisjoint_unionm
      (T T' : Type) (i1 i2 : NMap T) (m : NMap T') :
  fdisjoint (domm i1) (domm i2) ->
  domm m = domm (unionm i1 i2) ->
  domm (filterm (fun (k : nat) (_ : T') => k \notin domm i2) m) = domm i1.
Proof.
  rewrite domm_union => Hdisjoint Hunion.
  have HH: domm (filterm (fun (k : nat) (_ : T') => k \notin domm i2) m) =
           domm (filterm (fun (k : nat) (_ : T) => k \notin domm i2) (unionm i1 i2))
  by admit.
  rewrite HH filterm_id fdisjoint_filterm_mapm_unionm; auto.
  rewrite -filterm_id fdisjoint_filterm_full; auto.
  Grab Existential Variables.
  (* have HHH: domm m = (domm i1 :|: domm i2)%fset -> exists m1 m2, m = unionm m1 m2 /\ *)
  (*                                                          domm m1 = domm i1 /\ domm m2 = domm i2 *)
  (*       by admit. *)
  (* specialize (HHH Hunion). destruct HHH as [m1 [m2 [Hu [H1 H2]]]]. *)
  (* subst. Search _ domm filterm unionm. *)
  rewrite filterm_union.
  rewrite (@fdisjoint_filterm_empty T i2 i2). rewrite unionm0.
  rewrite (@fdisjoint_filterm_full T T).
  have HHH: exists m1 m2, m = unionm m1 m2 /\ domm m1 = domm i1 /\ domm m2 = domm i2 by admit.
  destruct HHH as [m1 [m2 [Hu [H1 H2]]]].
  rewrite Hu. rewrite <- H2.
  rewrite filterm_id.
  rewrite fdisjoint_filterm_mapm_unionm. rewrite <- filterm_id.
  rewrite fdisjoint_filterm_full.

  assumption. rewrite H1 H2; assumption. rewrite H1 H2; assumption.
  assumption.
  reflexivity. assumption.
  Grab Existential Variables.
  exists (filterm (fun (k : nat) (_ : T') => in_mem k (mem (domm i1))) m).
  exists (filterm (fun (k : nat) (_ : T') => in_mem k (mem (domm i2))) m).
  (* exists (filterm (fun (k : nat) (_ : T') => k \notin domm i1) m). *)
  split; try split.
Admitted.

Lemma domm_eq_filterm (T T' T'' : Type) (i1 : NMap T) (m1 : NMap T') (m2 : NMap T''):
    domm m1 = domm m2 ->
    domm (filterm (fun (k : nat) (_ : T') => k \notin domm i1) m1) =
    domm (filterm (fun (k : nat) (_ : T'') => k \notin domm i1) m2).
Proof.
  move=> H.
  set (fn := fun (k0 : nat) (_ : T') => k0 \notin domm i1) in *.
  set (fn' := fun (k0 : nat) (_ : T'') => k0 \notin domm i1) in *.

  (* Attempt *)
  apply /eq_fset => k.
  (* subst fn. *)
  destruct (k \notin domm i1) eqn:Heq;
    destruct (k \in domm (filterm fn m1)) eqn:Heq1;
    destruct (k \in domm (filterm fn' m2)) eqn:Heq2;
    try now auto.
  - subst fn fn'.
    rewrite mem_domm in Heq1.
    erewrite getm_filterm_notin_domm in Heq1; last eauto.
    rewrite mem_domm in Heq2.
    erewrite getm_filterm_notin_domm in Heq2; last eauto.
    (* contradiction: the domain of m1 and m2 is the same *)
    move: Heq1 Heq2.
    rewrite -2!mem_domm.
    rewrite H; move=> ? ?; eauto.
  - subst fn fn'.
    rewrite mem_domm in Heq1.
    erewrite getm_filterm_notin_domm in Heq1; last eauto.
    rewrite mem_domm in Heq2.
    erewrite getm_filterm_notin_domm in Heq2; last eauto.
    move: Heq1 Heq2; rewrite -2!mem_domm H => ? ?; eauto.
  - subst fn fn'.
    rewrite mem_domm in Heq1; rewrite mem_domm in Heq2.
    move: Heq1 Heq2. rewrite 2!filtermE. unfold obind. unfold oapp.
    destruct (m1 k) eqn:H';
      rewrite H' || idtac "ExStructures 0.1 legacy rewrite inactive";
      rewrite Heq => //=.
  - subst fn fn'.
    rewrite mem_domm in Heq1; rewrite mem_domm in Heq2.
    move: Heq1 Heq2. rewrite 2!filtermE. unfold obind. unfold oapp.
    destruct (m2 k) eqn:H';
      rewrite H' || idtac "ExStructures 0.1 legacy rewrite inactive";
      rewrite Heq => //=.
Qed.

Lemma domm_filterm_partial_memory
      (T T' : Type) (i1 i2 : NMap T) (m0 m1 m2 : NMap T') :
  fdisjoint (domm i1) (domm i2) ->
  domm m0 = domm m1 ->
  domm m2 = domm (unionm i1 i2) ->
  filterm (fun (k : nat) (_ : T') => k \notin domm i1) m0 =
  filterm (fun (k : nat) (_ : T') => k \notin domm i1) m2 ->
  domm (filterm (fun (k : nat) (_ : T') => k \notin domm i1) m1) = domm i2.
Proof.
  move=> H H0 H1 H2.
  symmetry in H0.
  rewrite (domm_eq_filterm _ H0).
  rewrite H2.
  rewrite (domm_eq_filterm _ H1).
  rewrite filterm_union; last assumption.
  rewrite fdisjoint_filterm_empty; last reflexivity.
  rewrite fdisjoint_filterm_full. reflexivity.
  now rewrite fdisjointC.
Qed.

Lemma filterm_partial_memory_fsubset
      (T T' : Type) (i1 i2 : NMap T) (m0 m1 m2 : NMap T') :
  fdisjoint (domm i1) (domm i2) ->
  domm m0 = domm m1 ->
  domm m2 = domm (unionm i1 i2) ->
  filterm (fun (k : nat) (_ : T') => k \notin domm i1) m0 =
  filterm (fun (k : nat) (_ : T') => k \notin domm i1) m2 ->
  fsubset (domm m1) (domm m2).
Proof.
  move => disj_i1_i2 m0_eq_m2 m2_eq_union Hfilter.
  rewrite m2_eq_union -m0_eq_m2 domm_union.
  apply (* /fsubsetU /orP. *) /fsubsetP => x Hx.
  assert (x \in (domm i1) \/ x \notin (domm i1)).
  { apply /orP. by destruct (x \in domm i1). } (* CA: do we have classical reasoning? *)
  case: H => H.
  move: H. apply /fsubsetP /fsubsetU /orP.
  left. by apply: fsubsetxx.

  have x_in_i2 : x \in domm i2.
  { have x_in_m2 : x\in domm m2 by admit.
    move: x_in_m2.
    rewrite m2_eq_union domm_union.
    case /fsetUP => [| //].
    move: H => /negP //.
  } (*CA: by Hfilter deduce x \in domm m2
               then by m2_eq_union, x \in domm i1 \/x \in domm i2
               together with H we get x \in domm i2
              *)
   move: x_in_i2. apply /fsubsetP /fsubsetU /orP.
   right. by apply: fsubsetxx.
Admitted.

(* RB: NOTE: This is not a map lemma proper. More generally, absorption on
   arbitrary subsets. *)
Lemma fsetU1in (T : ordType) (x : T) (s : {fset T}) :
  x \in s -> (x |: s)%fset = s.
Proof.
  rewrite -eq_fset.
  move => x_in_s x0.
  case: (@in_fsetU1 T x0 x s) => H0.
  destruct (x0 \in s) eqn: Hx0.
     by rewrite H0 orbT.
  rewrite H0 orbF.
  destruct (eqtype.eq_op x0 x) eqn: Hx0_x; auto.
    rewrite -(eqtype.eqP Hx0_x) in x_in_s.
    now inversion x_in_s.
Qed.

(* notation filtermI isn't quite right since idempotent (in SSReflect
   conventions) applies to binary operators *)
(* Since a function is pure in coq, this should hold *)
Lemma filtermIdempotent (T : ordType) (S : Type) p (m : {fmap T -> S}) :
  filterm p (filterm p m) = filterm p m.
Proof.
  apply/eq_fmap=> k; rewrite !filtermE.
  case get_k: (m k)=> [v|] //=.
  case: ifP => //= pkv ; by rewrite pkv.
Qed.

Lemma domm_map_zip_unzip_same_length_is_equal (T : ordType) (U V : Type) (l : list (T * U)) (l' : list V) :
  length l = length l' ->
  domm (mkfmap (T := T) (seq.zip (seq.unzip1 l) l')) = domm (mkfmap (T := T) l).
Proof.
  generalize dependent l'.
  induction l; intros l' H.
  - now destruct l'.
  - destruct l'; inversion H.
    simpl.
    rewrite 2!domm_set. rewrite IHl. reflexivity.
    assumption.
Qed.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^336 - 3
Base: 56
***)

Definition curve : CurveParameters :=
  {|
    sz := 6%nat;
    base := 56;
    bitwidth := 64;
    s := 2^336;
    c := [(1, 3)];
    carry_chains := Some [seq 0 (pred 6); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


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

 This defines the formal syntax, pg. 61.

*)
Set Implicit Arguments.
Require Export LanguageModuleDef.
Require Import TestUtilities.
Require Import DynamicSemanticsTypeSubstitution.

(* Test substitution in types. *)
Example subst_Tau_alpha: (subst_Tau (tv_t alpha) tau alpha) = tau.
Proof.
  reflexivity.
Qed.

Example subst_Tau_beta: (subst_Tau (tv_t beta) tau alpha) = (tv_t beta).
Proof.
  reflexivity.
Qed.

Example subst_Tau_cint: (subst_Tau cint tau alpha) = cint.
Proof.
  reflexivity.
Qed.

Example subst_Tau_cross_none :
  (subst_Tau (cross t0 t1) tau alpha) = cross t0 t1.
Proof.

  reflexivity.
Qed.

Example subst_Tau_cross_l :
  (subst_Tau (cross (tv_t alpha) t1) tau alpha) = cross tau t1.
Proof.
  reflexivity.
Qed.

Example subst_Tau_cross_r :
  (subst_Tau (cross t0 (tv_t alpha)) tau alpha) = cross t0 tau.
Proof.
  reflexivity.
Qed.

Example subst_Tau_arrow_l:
  (subst_Tau (arrow (tv_t alpha) t1) tau alpha) = arrow tau t1.
Proof.
  reflexivity.
Qed.

Example subst_Tau_arrow_l_beta:
  (subst_Tau (arrow (tv_t beta) t1) tau alpha) = arrow (tv_t beta) t1.
Proof.
  reflexivity.
Qed.

Example subst_Tau_arrow_r:
  (subst_Tau (arrow t0 (tv_t alpha)) tau alpha) = arrow t0 tau.
Proof.
  reflexivity.
Qed.

Example subst_Tau_arrow_r_beta:
  (subst_Tau (arrow t0 (tv_t beta)) tau alpha) = arrow t0 (tv_t beta).
Proof.
  reflexivity.
Qed.

Example subst_Tau_ptype_beta:
  subst_Tau (ptype (tv_t beta)) tau alpha = (ptype (tv_t beta)).
Proof.
  reflexivity.
Qed.

Example subst_Tau_ptype_alpha:
  subst_Tau (ptype (tv_t alpha)) tau alpha = (ptype tau).
Proof.
  reflexivity.
Qed.

Example subst_Tau_utype:
  (subst_Tau (utype beta k t0) tau alpha) = (utype beta k t0).
Proof.
  reflexivity.
Qed.

Example subst_Tau_utype_alpha:
  (subst_Tau (utype beta k (tv_t alpha)) tau alpha) = (utype beta k tau).
Proof.
  reflexivity.
Qed.

Example subst_Tau_utype_beta:
  (subst_Tau (utype beta k (tv_t beta)) tau alpha) =
  (utype beta k (tv_t beta)).
Proof.
  reflexivity.
Qed.

Example subst_Tau_etype:
  (subst_Tau (etype aliases beta k t0) tau alpha) =
  (etype aliases beta k t0).
Proof.
  reflexivity.
Qed.

Example subst_Tau_etype_alpha:
  (subst_Tau (etype aliases beta k (tv_t alpha)) tau alpha) =
  (etype aliases beta k tau).
Proof.
  reflexivity.
Qed.

Example subst_Tau_etype_beta:
  (subst_Tau (etype aliases beta k (tv_t beta)) tau alpha) =
  (etype aliases beta k (tv_t beta)).
Proof.
  reflexivity.
Qed.

(* Test substitution in expressions. *)
Example subst_E_i_e_i : (subst_E (i_e i) tau alpha) = (i_e i).
Proof.
 reflexivity.
Qed.

Example subst_E_p_e : (subst_E (p_e x pdot) tau alpha) = p_e x pdot.
Proof.
 reflexivity.
Qed.

(* TODO Need to be actually recursing into the F here.
   So I need an f with an alpha in it. *)
Example subst_E_f_e  :
  (subst_E (f_e f) tau alpha) = f_e f.
Proof.
  reflexivity.
Qed.

Example subst_E_f_e_alpha  :
  (subst_E (f_e faa) tau alpha) = f_e f.
Proof.
  compute.
  reflexivity.
Qed.

Example subst_E_f_e_beta  :
  (subst_E (f_e fbb) tau alpha) = f_e fbb.
Proof.
  reflexivity.
Qed.

(* Bug 5, not recursing through function wrapper. *)
Example subst_E_dfun :
  (subst_E (f_e (dfun tau x tau (retn (p_e x pdot)))) tau alpha) =
  (f_e (dfun tau x tau (retn (p_e x pdot)))).
Proof.
 reflexivity.
Qed.

Example subst_E_amp_no_alpha : (subst_E (amp e') tau alpha) = amp e'.
Proof.
 reflexivity.
Qed.

Example subst_E_star : (subst_E (star e') tau alpha) = star e'.
Proof.
 reflexivity.
Qed.

Example subst_E_cpair :
  (subst_E (cpair e1 e2) tau alpha) = cpair e1 e2.
Proof.
 reflexivity.
Qed.

Example subst_E_dot : (subst_E (dot e' zero_pe) tau alpha) = dot e' zero_pe.
Proof.
 reflexivity.
Qed.

Example subst_E_assign :
  (subst_E (assign e1 e2) tau alpha) = assign e1 e2.
Proof.
 reflexivity.
Qed.

Example subst_E_appl : (subst_E (appl  e1 e2) tau alpha) = appl  e1 e2.
Proof.
 reflexivity.
Qed.

Example subst_E_call : (subst_E (call s) tau alpha) = call s.
Proof.
 reflexivity.
Qed.

Example subst_E_inst : (subst_E (inst e' t0) tau alpha) = inst e' t0.
Proof.
 reflexivity.
Qed.

Example subst_E_pack :
  (subst_E (pack t e' t1) tau alpha) = pack t e' t1.
Proof.
 reflexivity.
Qed.

(* Test substitution in statements. *)

Example subst_St_e_s_none:
  (subst_St (e_s e) tau alpha) = (e_s e).
Proof.
 reflexivity.
Qed.

Example subst_St_e_s_alpha:
  (subst_St (e_s (f_e faa)) tau alpha) = (e_s (f_e f)).
Proof.
 reflexivity.
Qed.

Example subst_St_e_s_beta:
  (subst_St (e_s (f_e fbb)) tau alpha) = (e_s (f_e fbb)).
Proof.
  reflexivity.
Qed.

Example subst_St_retn_none:
  (subst_St (retn (f_e f)) tau alpha) = retn (f_e f).
Proof.
 reflexivity.
Qed.

Example subst_St_retn_alpha:
  (subst_St (retn (f_e faa)) tau alpha) =
                       retn (f_e f).
Proof.
 reflexivity.
Qed.

Example subst_St_retn_beta:
  (subst_St (retn (f_e fbb)) tau alpha) =
                       retn (f_e fbb).
Proof.
 reflexivity.
Qed.

Example subst_St_seq_none:
  (subst_St (seq applff applff) tau alpha) = (seq applff applff).
Proof.
 reflexivity.
Qed.

Example subst_St_seq_alpha:
  (subst_St (seq applfaa applfaa) tau alpha) = (seq applff applff).
Proof.
 reflexivity.
Qed.

Example subst_St_seq_beta:
  (subst_St (seq applfbb applfbb) tau alpha) = (seq applfbb applfbb).
Proof.
 reflexivity.
Qed.

Example subst_St_if_s_none:
  (subst_St (if_s e s1 s2) tau alpha) = (if_s e s1 s2).
Proof.
 reflexivity.
Qed.

Example subst_St_if_s_alpha:
  (subst_St (if_s (f_e faa) applfaa applfaa) tau alpha) =
            (if_s (f_e f)   applff   applff).
Proof.
 reflexivity.
Qed.

Example subst_St_if_s_beta:
  (subst_St (if_s (f_e fbb) applfbb applfbb) tau alpha) =
            (if_s (f_e fbb)  applfbb applfbb).
Proof.
 reflexivity.
Qed.

Example subst_St_while_none:
  (subst_St (while e s) tau alpha) = (while e s).
Proof.
 reflexivity.
Qed.

Example subst_St_while_alpha:
  (subst_St (while (f_e faa) applfaa) tau alpha) =
            (while (f_e f) applff).
Proof.
 reflexivity.
Qed.

Example subst_St_while_beta:
  (subst_St (while (f_e fbb) applfbb) tau alpha) =
            (while (f_e fbb) applfbb).
Proof.
 reflexivity.
Qed.

Example subst_St_letx_none:
  (subst_St (letx x e s) tau alpha) = (letx x e s).
Proof.
 reflexivity.
Qed.

Example subst_St_letx_alpha:
  (subst_St (letx x (f_e faa) applfaa) tau alpha) =
            (letx x (f_e f) applff).
Proof.
 reflexivity.
Qed.

Example subst_St_letx_beta:
  (subst_St (letx x (f_e fbb) applfbb) tau alpha) =
            (letx x (f_e fbb) applfbb).
Proof.
 reflexivity.
Qed.

Example subst_St_open_none:
  (subst_St (open e gamma x s) tau alpha) =
            (open e gamma x s).
Proof.
 reflexivity.
Qed.

Example subst_St_open_alpha:
  (subst_St (open (f_e faa) gamma x applfaa) tau alpha) =
            (open (f_e f  ) gamma x applff).
Proof.
 reflexivity.
Qed.

Example subst_St_open_beta:
  (subst_St (open (f_e fbb) gamma x applfbb) tau alpha) =
            (open (f_e fbb) gamma x applfbb).
Proof.
 reflexivity.
Qed.

Example subst_St_openstar_none:
  (subst_St (openstar e gamma x s) tau alpha) =
            (openstar e gamma x s).
Proof.
 reflexivity.
Qed.

Example subst_St_openstar_alpha:
  (subst_St (openstar (f_e faa) gamma x applfaa) tau alpha) =
            (openstar (f_e f  ) gamma x applff).
Proof.
 reflexivity.
Qed.

Example subst_St_openstar_beta:
  (subst_St (openstar (f_e fbb) gamma x applfbb) tau alpha) =
            (openstar (f_e fbb) gamma x applfbb).
Proof.
 reflexivity.
Qed.

Example subst_F_dfun_none:
  (subst_F f tau alpha) = f.
Proof.
  reflexivity.
Qed.

Example subst_F_dfun_alpha:
  (subst_F faa tau alpha) = f.
Proof.
  reflexivity.
Qed.

Example subst_F_dfun_beta:
  (subst_F fbb tau alpha) = fbb.
Proof.
  reflexivity.
Qed.

Example subst_F_ufun_non:
  (subst_F (ufun gamma k f) tau alpha) =
           (ufun gamma k f).
Proof.
 reflexivity.
Qed.

Example subst_F_ufun_alpha:
  (subst_F (ufun gamma k faa) tau alpha) =
           (ufun gamma k f).
Proof.
 reflexivity.
Qed.

Example subst_F_ufun_beta:
  (subst_F (ufun gamma k fbb) tau alpha) =
           (ufun gamma k fbb).
Proof.
 reflexivity.
Qed.

(* Bug 7 found here, did not get alpha binding in subst_F right. *)
Example subst_F_ufun_alpha_bound:
  (subst_F (ufun alpha k faa) tau alpha) =
           (ufun alpha k faa).
Proof.
 reflexivity.
Qed.

Example NotFreeInTau_int :
  NotFreeInTau beta cint.
Proof.
  reflexivity.
Qed.

Example NotFreeInTau_intcrossint :
  NotFreeInTau beta (cross cint cint).
Proof.
  constructor; try reflexivity.
Qed.

Example NotFreeInTau_intcrossint_1 :
  ~(NotFreeInTau beta (cross (tv_t beta) cint)).
Proof.
  compute.
  tauto.
Qed.

Example NotFreeInTau_intcrossint_2 :
  ~NotFreeInTau beta (cross cint (tv_t beta)).
Proof.
  compute.
  tauto.
Qed.

Example NotFreeInTau_intarrow :
  NotFreeInTau beta (arrow cint cint).
Proof.
  constructor; try reflexivity.
Qed.

Example NotFreeInTau_intarrow_1:
  ~NotFreeInTau beta (arrow (tv_t beta) cint).
Proof.
  compute.
  tauto.
Qed.

Example NotFreeInTau_intarrow_2:
 ~ NotFreeInTau beta (arrow cint (tv_t beta)).
Proof.
  compute.
  tauto.
Qed.

Example NotFreeInTau_ptype:
  NotFreeInTau beta (ptype cint).
Proof.
  reflexivity.
Qed.

Example NotFreeInTau_ptype_false:
 ~NotFreeInTau beta (ptype (tv_t beta)).
Proof.
  compute.
  tauto.
Qed.

Example NotFreeInTau_utype_bound:
  NotFreeInTau beta (utype beta A cint).
Proof.
  reflexivity.
Qed.

Example NotFreeInTau_utype_bound_2:
  NotFreeInTau beta (utype beta A (tv_t beta)).
Proof.
  reflexivity.
Qed.

Example NotFreeInTau_utype_bound_3:
  ~NotFreeInTau beta (utype alpha A (tv_t beta)).
Proof.
  compute.
  tauto.
Qed.

Example NotFreeInTau_etype_bound:
  NotFreeInTau beta (etype aliases beta A cint).
Proof.
  reflexivity.
Qed.

Example NotFreeInTau_etype_bound_2:
  NotFreeInTau beta (etype aliases beta A (tv_t beta)).
Proof.
  reflexivity.
Qed.

Example NotFreeInTau_etype_bound_3:
  ~NotFreeInTau beta (etype aliases alpha A (tv_t beta)).
Proof.
  compute.
  tauto.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(* Compiling the theories allows to test parsing and typing but not printing *)
(* This file tests that pretty-printing does not fail                        *)
(* Test of exact output is not specified                                     *)

Check 0.
Check S.
Check nat.