Require Import ZArith List Bool.
Import ListNotations.
From Minirust.def Require Import ty int_encoding.

Section wf.

Context {memory: Memory}.

Definition valid_size (size: Size) : Prop := (int_in_range (Z.of_nat size) PTR_SIZE Signed) = true.

Definition fields_fit_size (fields: Fields) (size : Size) :=
let f := (fun field =>
  let start := fst field in
  let ty := snd field in
  let stop := start + ty_size ty in

  size >= stop
) in Forall f fields.

Definition chunks_fit_size (chunks: Chunks) (size: Size) :=
let f := (fun chunk =>
  let start := fst chunk in
  let len := snd chunk in
  let stop := start + len in

  size >= stop
) in Forall f chunks.

Definition fields_wf (fields: Fields) (wf_call: Ty -> Prop) :=
(fix fields_wf (fields: Fields) :=
  match fields with
  | [] => True
  | (_, ty)::fields' => wf_call ty /\ fields_wf fields'
  end
) fields.

(* an interval is (offset, size) in bytes *)
Notation Interval := (Size * Size)%type.

(* checks whether i1 stops before i2 starts *)
Definition interval_pair_sorted_disjoint (i1 i2: Interval) :=
  match (i1,i2) with
  | ((o1,s1), (o2,s2)) => o1+s1 <= o2
  end.

(* checks whether i1 is fully contained in i2 *)
Definition interval_pair_contained_in (i1 i2: Interval) :=
  match (i1,i2) with
  | ((o1,s1), (o2,s2)) => o2 <= o1 /\ o2+s2 >= o1+s2
  end.

(* checks that the intervals are sorted, and don't overlap *)
Definition intervals_sorted_disjoint (l: list Interval) :=
  ForallOrdPairs interval_pair_sorted_disjoint l.

Definition interval_of_field (f: Size * Ty) :=
  match f with
  | (o,t) => (o, ty_size t)
  end.

Definition contains i (interval: nat * nat) := (
  (fst interval <=? i) &&
  (i <? fst interval + snd interval)
).

Definition fields_disjoint (fields: Fields) : Prop := forall i j1 j2, j1 < length fields -> j2 < length fields -> j1 <> j2 ->
contains i (interval_of_field (nth j1 fields (0,TBool))) = true ->
contains i (interval_of_field (nth j2 fields (0, TBool))) = false.

(* checks that every field is completely contained a chunk *)
(* note that a chunk is already an `Interval` *)
Definition fields_in_chunks (fields: Fields) (chunks: Chunks) :=
  let fn := (fun f c => interval_pair_contained_in (interval_of_field f) c) in
  Forall (fun f => Exists (fun c => fn f c) chunks) fields.

Definition chunks_sorted_and_disjoint (chunks: Chunks) := intervals_sorted_disjoint chunks.

Fixpoint pow2 (x: nat) :=
  match x with
  | 0 => 1
  | S y => 2 * pow2 y
  end.

Fixpoint wf (t: Ty) : Prop :=
  valid_size (ty_size t)
  /\
  match t with
  | TInt size signedness => exists n, (pow2 n) = size
  | TBool => True
  | TPtr _ _ => True
  | TTuple fields size => fields_fit_size fields size
                      /\ fields_wf fields wf
                      /\ fields_disjoint fields
  | TArray elem_ty count => wf elem_ty
                        /\ (count >= 0)%Z
  | TUnion fields chunks size => fields_fit_size fields size
                             /\ fields_wf fields wf
                             /\ fields_in_chunks fields chunks
                             /\ chunks_sorted_and_disjoint chunks
                             /\ chunks_fit_size chunks size
  end.

End wf.


Require Import Algebra.Utils Algebra.SetoidCat Algebra.SetoidCat.PairUtils Algebra.Monad Algebra.Monoid Algebra.SetoidCat.SetoidUtils Algebra.Tactics Algebra.SetoidCat.BoolUtils.

Require Import RelationClasses Relation_Definitions Morphisms SetoidClass.

Require Import Coq.Lists.List.

Import ListNotations.

Program Instance listS {A} (SA : Setoid A) : Setoid (list A).

Instance map_Proper {A B : Type} {SA : Setoid A} {SB : Setoid B} : Proper ((equiv ==> equiv) ==> equiv ==> equiv) (@map A B).
Proof.
  unfold Proper, respectful in *. intros x y H lx ly. generalize x y H.
  apply list_ind_2 with (l1 := lx) (l2 := ly).
  intros.  simpl. constructor.
  intros. inversion H2.
  intros. inversion H2.
  intros. simpl in *. inversion H2. constructor. auto. auto.
Qed.

Instance cons_Proper {A} {SA : Setoid A} : Proper (equiv ==> equiv ==> equiv) (@cons A).
Proof.
  unfold Proper, respectful in *. intros x y H lx ly. generalize x y H.
  apply list_ind_2 with (l1 := lx) (l2 := ly).
  intros. constructor. auto. auto.
  intros. inversion H2.
  intros. inversion H2.
  intros. simpl. constructor. auto. auto.
Qed.

Instance app_Proper {A} {SA : Setoid A}  : Proper ( equiv ==> equiv ==> equiv) (@app A).
Proof.
  unfold Proper in *. unfold respectful in *. intros x y.
  apply list_ind_2 with (l1:=x)(l2:=y).
  auto.
  intros. inversion H0.
  intros. inversion H0.
  intros. simpl in *. inversion H0. constructor. auto. auto.
Qed.

Instance concat_Proper {A} {SA : Setoid A}  : Proper ( equiv ==> equiv) (@concat A).
Proof.
  unfold Proper in *. unfold respectful in *. intros x y.
  apply list_ind_2 with (l1:=x) (l2:=y).
  intros. reflexivity.
  intros. inversion H0.
  intros. inversion H0.
  intros. simpl in *. inversion H0. apply app_Proper. auto. apply H. auto.
Qed.

Instance fold_right_Proper {A B : Type} {SA : Setoid A} {SB : Setoid B} : Proper ((equiv ==> equiv ==> equiv) ==> equiv ==> equiv ==> equiv) (@fold_right B A).
Proof.
  unfold Proper, respectful in *. intros f g H x y H2 lx ly.
  apply list_ind_2 with (l1 := lx) (l2 := ly).
  auto.
  intros. inversion H1.
  intros. inversion H1.
  intros. simpl in *. inversion H1. apply H. auto. auto.
Qed.

Instance fold_left_Proper {A B : Type} {SA : Setoid A} {SB : Setoid B} : Proper ((equiv ==> equiv ==> equiv) ==> equiv ==> equiv ==> equiv) (@fold_left B A).
Proof.
  unfold Proper, respectful in *. intros f g H lx ly.
  apply list_ind_2 with (l1 := lx) (l2 := ly).
  auto.
  intros. inversion H1.
  intros. inversion H1.
  intros. simpl in *. inversion H1. apply H0. auto. apply H. auto. auto.
Qed.

Instance null_Proper {A} {SA : Setoid A}  : Proper (equiv ==> equiv) (@null A).
Proof.
  unfold Proper, respectful in *. intros. unfold null. generalize H. clear H. apply list_ind_2 with (l1:=x)(l2:=y).
  intros. reflexivity.
  intros. inversion H0.
  intros. inversion H0.
  intros. reflexivity.
Qed.

Section ConcatS.
  Context
    {A : Type}
    {SA : Setoid A}.

  Definition concatS : listS (listS SA) ~> listS SA.
    refine (injF (@concat A) _).
  Defined.
End ConcatS.

Section ConsS.
  Context
    {A : Type}
    {SA : Setoid A}.

  Definition consS : SA ~> listS SA ~~> listS SA.
    simple refine (injF2 (@cons A) _).
  Defined.
End ConsS.

Section MapS.

  Context
    {A B : Type}
    {SA : Setoid A}
    {SB : Setoid B}.

  Definition mapS : (SA ~~> SB) ~> listS SA ~~> listS SB.
    simple refine (injF (fun f => injF (map (fun a => f @ a)) _) _).
    Lemma mapProper0_1 :forall f, Proper (equiv ==> equiv) (map (fun a : A => f @ a)).
    Proof.
      unfold Proper, respectful. intros. generalize H. clear H. apply list_ind_2 with (l1:=x) (l2:=y).
      intros. simpl. auto.
      intros. inversion H0.
      intros. inversion H0.
      intros. inversion H0. simpl. constructor.
      rewrite H4. reflexivity.
      apply H. auto.
    Qed.
    apply mapProper0_1.
    Lemma mapProper0_2 : forall pr, Proper (equiv ==> equiv)
                                           (fun f : SA ~> SB => injF (map (fun a : A => f @ a)) (pr f)).
    Proof.
      unfold Proper, respectful. intros. arrequiv. induction a.
      simpl. auto.
      simpl. constructor.
      apply H.
      apply IHa.
    Qed.
    apply mapProper0_2.
  Defined.

  Lemma mapS_cons : forall  (f : SA ~> SB) (a : A) (n : list A), mapS @ f @ (a :: n) == (f @ a) :: (mapS @ f @ n).
  Proof.
    intros. reflexivity.
  Qed.

  Lemma mapS_app :
    forall (l0 l1 : list A) (f : SA ~> SB),
      mapS @ f @ (l0 ++ l1) == mapS @ f @ l0 ++ mapS @ f @ l1.
  Proof.
    intros. induction l0.
    reflexivity.
    simpl.  constructor. reflexivity. auto.
  Qed.
  Lemma map_nil: forall A B (BS : Setoid B) (f : A -> B),
                   map f [] == [].
  Proof.
    reflexivity.
  Qed.

End MapS.
 Lemma mapS_mapS : forall A (AS : Setoid A) B (BS : Setoid B) C (CS : Setoid C) (f : AS ~> BS) (g : BS ~> CS) (l : list A),
                        mapS @ g @ (mapS @ f @ l) = mapS @ (comp f g) @ l.
    Proof.
      intros. unfold mapS. normalize. rewrite map_map. reflexivity.
    Qed.

Section Fold_rightS.
  Context
    {A B} {SA : Setoid A} {SB : Setoid B}.

  Definition fold_rightS : (SA ~~> SB ~~> SB) ~> SB ~~> listS SA ~~> SB.
    simple refine (injF3 (fun (f : SA ~> SB ~~> SB) (b : B) (l : list A) => fold_right (fun a b => f @ a @ b) b l) _).
    Lemma fold_rightProper_1 : Proper (equiv ==> equiv ==> equiv ==> equiv)
                                      (fun (f : SA ~> SB ~~> SB) (b : B) (l : list A) =>
                                         fold_right (fun (a : A) (b0 : B) => f @ a @ b0) b l).

    Proof.
      autounfold. intros. generalize H1. clear H1. apply list_ind_2 with (l1:=x1) (l2:=y1).
      intros. auto.
      intros. inversion H2.
      intros. inversion H2.
      intros. inversion H2. simpl. rewrite H1. rewritesr. auto.
    Qed.
    apply fold_rightProper_1.
  Defined.

  Lemma fold_rightS_cons : forall (f : SA ~> SB ~~> SB) (b : B) (a : A) (l : list A),
                             fold_rightS @ f @ b @ (a :: l) == f @ a @ (fold_rightS @ f @ b @ l).
  Proof.
    intros. simpl. reflexivity.
  Qed.
  Lemma fold_rightS_app : forall (f : SA ~> SB ~~> SB) (b : B) (l n : list A),
                            fold_rightS @ f @ b @ (l ++ n) == fold_rightS @ f @ (fold_rightS @ f @ b @ n) @ l.
  Proof.
    intros. induction l.
    reflexivity.
    simpl ((_ :: _) ++ _).  repeat  rewrite fold_rightS_cons. rewritesr.
  Qed.
  Lemma fold_right_cons : forall A B (f : A -> B -> B) (b : B) (a : A) (l : list A),
                            fold_right f b (a :: l) = f a (fold_right f b l).
  Proof.
    reflexivity.
  Qed.

  Lemma fold_right_app :
    forall {A B} {SA : Setoid A} {SB : Setoid B} (f : A -> B -> B) (b : B) (l l2 : list A) ,
      fold_right f b (l ++ l2) = fold_right f (fold_right f b l2) l.
  Proof.
    intros. induction l.
    auto.
    simpl. congruence.
  Qed.

End Fold_rightS.

Section AppS.
  Context
    {A : Type}
    {SA : Setoid A}.

  Definition appS : listS SA ~> listS SA ~~> listS SA.
    simple refine (injF2 (@app A) _).
  Defined.
End AppS.


(************************************************************************)
(*  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        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

(*i $Id: Ensembles.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Section Ensembles.
  Variable U : Type.

  Definition Ensemble := U -> Prop.

  Definition In (A:Ensemble) (x:U) : Prop := A x.

  Definition Included (B C:Ensemble) : Prop := forall x:U, In B x -> In C x.

  Inductive Empty_set : Ensemble :=.

  Inductive Full_set : Ensemble :=
    Full_intro : forall x:U, In Full_set x.

(** NB: The following definition builds-in equality of elements in [U] as
     Leibniz equality.

     This may have to be changed if we replace [U] by a Setoid on [U]
     with its own equality [eqs], with
     [In_singleton: (y: U)(eqs x y) -> (In (Singleton x) y)]. *)

  Inductive Singleton (x:U) : Ensemble :=
    In_singleton : In (Singleton x) x.

  Inductive Union (B C:Ensemble) : Ensemble :=
    | Union_introl : forall x:U, In B x -> In (Union B C) x
    | Union_intror : forall x:U, In C x -> In (Union B C) x.

  Definition Add (B:Ensemble) (x:U) : Ensemble := Union B (Singleton x).

  Inductive Intersection (B C:Ensemble) : Ensemble :=
    Intersection_intro :
    forall x:U, In B x -> In C x -> In (Intersection B C) x.

  Inductive Couple (x y:U) : Ensemble :=
    | Couple_l : In (Couple x y) x
    | Couple_r : In (Couple x y) y.

  Inductive Triple (x y z:U) : Ensemble :=
    | Triple_l : In (Triple x y z) x
    | Triple_m : In (Triple x y z) y
    | Triple_r : In (Triple x y z) z.

  Definition Complement (A:Ensemble) : Ensemble := fun x:U => ~ In A x.

  Definition Setminus (B C:Ensemble) : Ensemble :=
    fun x:U => In B x /\ ~ In C x.

  Definition Subtract (B:Ensemble) (x:U) : Ensemble := Setminus B (Singleton x).

  Inductive Disjoint (B C:Ensemble) : Prop :=
    Disjoint_intro : (forall x:U, ~ In (Intersection B C) x) -> Disjoint B C.

  Inductive Inhabited (B:Ensemble) : Prop :=
    Inhabited_intro : forall x:U, In B x -> Inhabited B.

  Definition Strict_Included (B C:Ensemble) : Prop := Included B C /\ B <> C.

  Definition Same_set (B C:Ensemble) : Prop := Included B C /\ Included C B.

  (** Extensionality Axiom *)

  Axiom Extensionality_Ensembles : forall A B:Ensemble, Same_set A B -> A = B.

End Ensembles.

Hint Unfold In Included Same_set Strict_Included Add Setminus Subtract: sets
  v62.

Hint Resolve Union_introl Union_intror Intersection_intro In_singleton
  Couple_l Couple_r Triple_l Triple_m Triple_r Disjoint_intro
  Extensionality_Ensembles: sets v62.


Require Export P07.

Hint Constructors is_redblack.
Hint Resolve is_redblack_toblack.
Lemma makeblack_fiddle:
  forall s n, is_redblack s Black n ->
            exists n, is_redblack (makeBlack s) Red n.
Proof.
  intros.
  induction H.
  { simpl. eauto. }
  { exists (S n). constructor; eauto. }
  { exists (S n). constructor; eauto. }
Qed.


From Usuba Require Import usuba_AST.
From Coq Require Import MSets.
Require Import Coq.Structures.OrdersEx.

Module iset := Make String_as_OT.

Fixpoint collect_aexpr (e : arith_expr) : iset.t :=
    match e with
    | Var_e i => iset.singleton i
    | Const_e _ => iset.empty
    | Op_e _ e1 e2 => iset.union (collect_aexpr e1) (collect_aexpr e2)
    end.

Fixpoint collect_aexprl (e : list arith_expr) : iset.t :=
    match e with
    | nil => iset.empty
    | h :: tl => iset.union (collect_aexpr h) (collect_aexprl tl)
    end.

Function collect_var (v : var) : iset.t :=
    match v with
    | Var var => iset.singleton var
    | Index v i => iset.union (collect_var v) (collect_aexpr i)
    | Range v s e => iset.union (collect_var v) (iset.union (collect_aexpr s) (collect_aexpr e))
    | Slice v el => iset.union (collect_var v) (collect_aexprl el)
    end.

Fixpoint collect_varl (vl : list var) : iset.t :=
    match vl with
    | nil => iset.empty
    | v :: tl => iset.union (collect_var v) (collect_varl tl)
    end.

Function collect_expr (e : expr) : iset.t :=
    match e with
    | Const _ _ => iset.empty
    | ExpVar v => collect_var v
    | Tuple el => collect_exprl el
    | Not e => collect_expr e
    | Log _ e1 e2 | Arith _ e1 e2 => iset.union (collect_expr e1) (collect_expr e2)
    | Shift _ expr aexpr => iset.union (collect_expr expr) (collect_aexpr aexpr)
    | Shuffle v _ => collect_var v
    | Bitmask expr aexpr => iset.union (collect_expr expr) (collect_aexpr aexpr)
    | Pack e1 e2 _ => iset.union (collect_expr e1) (collect_expr e2)
    | Fun f exprl => iset.union (iset.singleton f) (collect_exprl exprl)
    | Fun_v f aexpr exprl => iset.union (iset.singleton f) (iset.union (collect_aexpr aexpr) (collect_exprl exprl))
    end
with collect_exprl el :=
    match el with
    | Enil => iset.empty
    | ECons e el => iset.union (collect_expr e) (collect_exprl el)
    end.

Function collect_vdecl (p : p) : iset.t :=
    match p with
    | nil => iset.empty
    | v :: tl => iset.add (VD_ID v) (collect_vdecl tl)
    end.

Function collect_deq (d : deq) : iset.t :=
    match d with
    | Eqn v e _ => iset.union (collect_varl v) (collect_expr e)
    | Loop i aei1 aei2 eqns opt =>
        iset.add i (iset.union
            (iset.union (collect_aexpr aei1) (collect_aexpr aei2)) (collect_deqs eqns))
    end
with collect_deqs (dl : list_deq) : iset.t :=
    match dl with
    | Dnil => iset.empty
    | Dcons hd tl => iset.union (collect_deq hd) (collect_deqs tl)
    end.

Function collect_bounddeq (d : deq) : iset.t :=
    match d with
    | Eqn v e _ => (collect_varl v)
    | Loop i aei1 aei2 eqns opt =>
        iset.add i (collect_bounddeqs eqns)
    end
with collect_bounddeqs (dl : list_deq) : iset.t :=
    match dl with
    | Dnil => iset.empty
    | Dcons hd tl => iset.union (collect_bounddeq hd) (collect_bounddeqs tl)
    end.


(**********************************************************************************
 * PredomSum.v                                                                    *
 * Formalizing Domains, Ultrametric Spaces and Semantics of Programming Languages *
 * Nick Benton, Lars Birkedal, Andrew Kennedy and Carsten Varming                 *
 * Jan 2012                                                                       *
 * Build with Coq 8.3pl2 plus SSREFLECT                                           *
 **********************************************************************************)

(*==========================================================================
  Definition of co-products and associated lemmas
  ==========================================================================*)
Require Import PredomCore.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(*==========================================================================
  Order-theoretic definitions
  ==========================================================================*)

Section OrdSum.

Variable O1 O2 : ordType.

Lemma sum_ordAxiom : PreOrd.axiom (fun (x y:O1+O2) => match x, y with | inl x, inl y => x <= y | inr x, inr y => x <= y | _,_ =>  False end).
case => x0. split ; first by []. by case => x1 ; case => x2 ; try apply Ole_trans.
split ; first by []. by case => x1 ; case => x2 ; try apply Ole_trans.
Qed.

Canonical Structure sum_ordMixin := OrdMixin sum_ordAxiom.
Canonical Structure sum_ordType := Eval hnf in OrdType sum_ordMixin.

Lemma inl_mono : monotonic (@inl O1 O2).
by move => x y l.
Qed.

Definition Inl : O1 =-> sum_ordType := Eval hnf in mk_fmono inl_mono.

Lemma inr_mono : monotonic (@inr O1 O2).
by move => x y l.
Qed.

Definition Inr : O2 =-> sum_ordType := Eval hnf in mk_fmono inr_mono.

Lemma sum_fun_mono (O3:ordType) (f:O1 =-> O3) (g:O2 =-> O3) : monotonic (fun x => match x with inl x => f x | inr y => g y end).
by case => x ; case => y ; try done ; move => X ; apply fmonotonic.
Qed.

Definition Osum_fun (O3:ordType) (f:O1 =-> O3) (g:O2 =-> O3) := Eval hnf in mk_fmono (sum_fun_mono f g).

End OrdSum.

Lemma sumOrdAxiom : @CatSum.axiom _ (sum_ordType) (@Inl) (@Inr) (@Osum_fun).
move => O0 O1 O2 f g. split ; first by split ; apply: fmon_eq_intro.
move => m [A B]. apply: fmon_eq_intro. case => x.
- by apply (fmon_eq_elim A x).
- by apply (fmon_eq_elim B x).
Qed.

Canonical Structure sum_ordCatMixin := sumCatMixin sumOrdAxiom.
Canonical Structure sum_ordCatType := Eval hnf in sumCatType sum_ordCatMixin.

Add Parametric Morphism (D E F:ordType) : (@Osum_fun D E F)
with signature (@Ole _ : (D =-> F) -> (D =-> F) -> Prop) ++> (@Ole _ : (E =-> F) -> (E =-> F) -> Prop) ++>
   (@Ole (sum_ordType _ _ -=> _) : ((D + E) =-> F) -> (_ =-> _) -> Prop)
as Osum_fun_le_compat.
intros f f' lf g g' lg.
simpl. intros x ; case x ; clear x ; auto.
Qed.

Add Parametric Morphism (D E F:ordType) : (@Osum_fun D E F)
with signature (@tset_eq _ : (D =-> F) -> (D =-> F) -> Prop ) ==>
      (@tset_eq _ : (E =-> F) -> (E =-> F) -> Prop) ==> (@tset_eq ((sum_ordType D E) -=> F))
as Osum_fun_eq_compat.
intros f f' lf g g' lg.
simpl. apply fmon_eq_intro.
destruct lg. destruct lf.
intros x ; split ; case x ; clear x ; auto.
Qed.

Section CPOSum.

Variable D1 D2 : cpoType.

Lemma sum_left_mono (c:natO =-> sum_ordType D1 D2) (ex:{d| c O = inl D2 d}) :
   monotonic (fun x => match c x with | inl y => y | inr _ => projT1 ex end).
case:ex => x X. simpl.
move => z z' l. simpl.
have H:= fmonotonic c (leq0n z). have HH:=fmonotonic c (leq0n z').
rewrite -> X in H,HH.
have A:=fmonotonic c l. case: (c z) H A ; last by [].
move => x0 _. by case: (c z') HH.
Qed.

Definition sum_left (c:natO =-> sum_ordType D1 D2) (ex:{d| c O = inl D2 d}) : natO =-> D1 :=
   Eval hnf in mk_fmono (sum_left_mono ex).

Lemma sum_right_mono (c:natO =-> sum_ordType D1 D2) (ex:{d| c O = inr D1 d}) :
   monotonic (fun x => match c x with | inr y => y | inl _ => projT1 ex end).
case:ex => x X. simpl.
move => z z' l. simpl.
have H:= fmonotonic c (leq0n z). have HH:=fmonotonic c (leq0n z').
rewrite -> X in H,HH.
have A:=fmonotonic c l. case: (c z) H A ; first by [].
move => x0 _. by case: (c z') HH.
Qed.

Definition sum_right (c:natO =-> sum_ordType D1 D2) (ex:{d| c O = inr D1 d}) : natO =-> D2 :=
   Eval hnf in mk_fmono (sum_right_mono ex).

Definition SuminjProof (c:natO =-> sum_ordType D1 D2) (n:nat) :
      {d | c n = inl D2 d} + {d | c n = inr D1 d}.
case: (c n) => cn.
- left. by exists cn.
- right. by exists cn.
Defined.

Definition sum_lub (c: natO =-> sum_ordType D1 D2) : sum_ordType D1 D2 :=
match (SuminjProof c 0) with
| inl X => (inl D2 (lub (sum_left X)))
| inr X => (inr D1 (lub (sum_right X)))
end.

(*==========================================================================
  Domain-theoretic definitions
  ==========================================================================*)

Lemma Dsum_ub (c : natO =-> sum_ordType D1 D2) (n : nat) : c n <= sum_lub c.
have L:=fmonotonic c (leq0n n).
unfold sum_lub. case: (SuminjProof c 0) ; case => c0 e ; rewrite e in L.
-  move: L. case_eq (c n) ; last by []. move => cn e' L. apply: (Ole_trans _ (le_lub _ n)).
  simpl. by rewrite e'.
-  move: L. case_eq (c n) ; first by []. move => cn e' L. apply: (Ole_trans _ (le_lub _ n)).
  simpl. by rewrite e'.
Qed.

Lemma Dsum_lub (c : natO =-> sum_ordType D1 D2) (x : sum_ordType D1 D2) :
   (forall n : natO, c n <= x) -> sum_lub c <= x.
case x ; clear x ; intros x cn. unfold sum_lub.
case (SuminjProof c 0).
- intros s. assert (lub (sum_left s) <= x).
  apply (lub_le). intros n. specialize (cn n). destruct s as [d c0].
  simpl. case_eq (c n).
  + intros dn dnl. rewrite dnl in cn. by auto.
  + intros dn cnr. rewrite cnr in cn. by inversion cn.
  by auto.
- intros s. destruct s. simpl. specialize (cn 0). rewrite e in cn. by inversion cn.
- unfold sum_lub. case (SuminjProof c 0) ; first case.
  + move => y e. simpl. specialize (cn 0). rewrite e in cn. by inversion cn.
  + intros s. assert (lub (sum_right s) <= x).
    * apply lub_le. intros n. specialize (cn n). destruct s as [d c0].
      simpl. case_eq (c n).
      - intros dl cnl. rewrite cnl in cn. by inversion cn.
      - intros dl dll. rewrite dll in cn. by auto.
    by auto.
Qed.

Lemma sum_cpoAxiom : CPO.axiom sum_lub.
move => c s n.
split ; first by apply Dsum_ub.
by apply Dsum_lub.
Qed.

Canonical Structure sum_cpoMixin := CpoMixin sum_cpoAxiom.
Canonical Structure sum_cpoType := Eval hnf in CpoType sum_cpoMixin.

(*
(** Printing +c+ %\ensuremath{+}% *)
Infix "+c+" := Dsum (at level 28, left associativity).*)

Variable D3:cpoType.

Lemma SUM_fun_cont (f:D1 =-> D3) (g:D2 =-> D3) : @continuous sum_cpoType _ (Osum_fun f g).
intros c. simpl.
case_eq (lub c).
- move => ll sl. unfold lub in sl. simpl in sl. unfold sum_lub in sl. destruct (SuminjProof c 0) ; last by [].
  case: sl => e. rewrite <- e. clear ll e. rewrite -> (fcontinuous f (sum_left s)).
  apply lub_le_compat => n. simpl. case: s => d s. simpl. move: (fmonotonic c (leq0n n)).
  case: (c 0) s ; last by []. move => s e. rewrite -> e ; clear s e. by case: (c n).
- move => ll sl. unfold lub in sl. simpl in sl. unfold sum_lub in sl. destruct (SuminjProof c 0) ; first by [].
  case: sl => e. rewrite <- e. clear ll e. rewrite -> (fcontinuous g (sum_right s)).
  apply lub_le_compat => n. simpl. case: s => d s. simpl. move: (fmonotonic c (leq0n n)).
  case: (c 0) s ; first by []. move => s e. rewrite -> e ; clear s e. by case: (c n).
Qed.

Definition SUM_funX (f:D1 =-> D3) (g:D2 =-> D3) : sum_cpoType =-> D3 := Eval hnf in mk_fcont (SUM_fun_cont f g).
Definition SUM_fun f g := locked (SUM_funX f g).

Lemma SUM_fun_simpl f g x : SUM_fun f g x =-= match x with inl x => f x | inr x => g x end.
unlock SUM_fun. simpl. by case: x.
Qed.

(** printing [| %\ensuremath{[} *)
(** printing |] %\ensuremath{]} *)
(* Notation "'[|' f , g '|]'" := (SUM_fun f g) (at level 30).*)

Lemma Inl_cont : continuous (Inl D1 D2).
move => c. simpl. by apply: lub_le_compat => n.
Qed.

Definition INL : D1 =-> sum_cpoType := Eval hnf in mk_fcont Inl_cont.

Lemma Inr_cont : continuous (Inr D1 D2).
move => c. simpl. by apply: lub_le_compat => n.
Qed.

Definition INR : D2 =-> sum_cpoType := Eval hnf in mk_fcont Inr_cont.

End CPOSum.

Lemma sumCpoAxiom : @CatSum.axiom _ sum_cpoType (@INL) (@INR) (@SUM_fun).
move => D0 D1 D2 f g. split. unlock SUM_fun. apply: (proj1 (@sumOrdAxiom D0 D1 D2 f g)).
move => m. unlock SUM_fun. apply: (proj2 (@sumOrdAxiom D0 D1 D2 f g)).
Qed.

Canonical Structure cpoSumCatMixin := sumCatMixin sumCpoAxiom.
Canonical Structure cpoSumCatType := Eval hnf in sumCatType cpoSumCatMixin.

Lemma SUM_fun_simplx (X Y Z : cpoType) (f:X =-> Z) (g : Y =-> Z) x : [|f,g|] x =-= match x with inl x => f x | inr x => g x end.
case:x => x ; unfold sum_fun ; simpl ; by rewrite SUM_fun_simpl.
Qed.

Definition getmorph (D E : cpoType) (f:D -=> E) : D =-> E := ev << <| const _ f, Id |>.

Lemma SUM_Fun_mon (D E F:cpoType) : monotonic (fun (P:(D -=> F) * (E -=> F)) => [|getmorph (fst P), getmorph (snd P)|]).
case => f g. case => f' g'. case ; simpl => l l' x.
unfold sum_fun. simpl. do 2 rewrite SUM_fun_simpl.
by case x ; [apply l | apply l'].
Qed.

Definition SUM_Funm (D E F:cpoType) : fmono_ordType ((D -=> F) * (E -=> F)) (D + E -=> F) :=
  Eval hnf in mk_fmono (@SUM_Fun_mon D E F).

Lemma SUM_Fon_cont (D E F:cpoType) : continuous (@SUM_Funm D E F).
move => c. simpl. unfold getmorph. unfold sum_fun. simpl.
by case => x ; simpl ; rewrite SUM_fun_simpl ; apply: lub_le_compat => n ; simpl ; rewrite SUM_fun_simpl.
Qed.

Definition SUM_Fun (D E F:cpoType) : ((D -=> F) * (E -=> F)) =-> (D + E -=> F) := Eval hnf in  mk_fcont (@SUM_Fon_cont D E F).
Implicit Arguments SUM_Fun [D E F].

Lemma SUM_Fun_simpl (D E F:cpoType) (f:D =-> F) (g:E =-> F) : SUM_Fun (f,g) =-= SUM_fun f g.
apply: fmon_eq_intro => x. simpl. unfold sum_fun. simpl. by do 2 rewrite SUM_fun_simpl.
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


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

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

Print Assumptions add.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


Require Import FP.CoreData.
Require Import FP.CoreClasses.

Import CoreClassesNotation.
Import CoreDataNotation.

Class Functor (t:Type->Type) : Type :=
  { fmap : forall {A B}, (A -> B) -> t A -> t B }.
Arguments fmap {t Functor A B} _ _ : simpl never.

Section Functor.
  Context {t u} `{! Functor t ,! Functor u }.

  Definition fmap2 {A} {B} : (A -> B) -> u (t A) -> u (t B) := fmap '.' fmap.

  Context {v} `{! Functor v }.

  Definition fmap3 {A} {B} : (A -> B) -> v (u (t A)) -> v (u (t B)) := fmap '.' fmap2.
End Functor.

Module FunctorNotation.
  Infix "<$>" := fmap (at level 47, left associativity).
  Infix "<$$>" := fmap2 (at level 47, left associativity).
  Infix "<$$$>" := fmap3 (at level 47, left associativity).
End FunctorNotation.

Section FunctorWF.
  Context {t} `{! Functor t ,! F_Eqv t ,! F_PER_WF t }.

  Class FunctorWF :=
    { fmap_id :
        forall
          {A} `{! Eqv A ,! PER_WF A }
          (f:A -> A) `{! Proper eqv f }
          (aT:t A) `{! Proper eqv aT },
        fmap id aT ~= aT
    ; fmap_compose :
        forall
          {A} `{! Eqv A ,! PER_WF A }
          {B} `{! Eqv B ,! PER_WF B }
          {C} `{! Eqv C ,! PER_WF C }
          (f:A -> B) `{! Proper eqv f }
          (g:B -> C) `{! Proper eqv g }
          (aT:t A) `{! Proper eqv aT },
        fmap (g '.' f) aT ~= (fmap g '.' fmap f) aT
    ; fmap_respect :>
        forall
          {A} `{! Eqv A ,! PER_WF A }
          {B} `{! Eqv B ,! PER_WF B },
        Proper eqv (fmap (A:=A) (B:=B))
    }.
End FunctorWF.
Arguments FunctorWF t {_ _}.


Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
Require Import fintype paths finfun ssralg bigops finset prime.
Require Import groups normal morphisms automorphism cyclic nilpotent.
Require Import commutators center pgroups sylow abelian.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.
Import GroupScope.

Section CriticalThompson.

Variable gT : finGroupType.
Implicit Type M P: {group gT}.

(* Gorenstein 5.3.12 *)
Lemma crit_lem : forall P M,
  p_group P -> [max M of H | (H <| P) && abelian H] -> 'C_P(M) = M.
Proof.
move=> P M PgP; case/maxgroupP; case/andP=> NMP AM MM.
have: M \subset 'C_P(M) by rewrite subsetI (normal_sub NMP).
rewrite subEproper; case/orP => PMC; first by move/eqP: PMC.
set H := 'C_P(M)%G; pose P' := (P / M)%G; pose H' := (H / M)%G.
have F1: H' <| P'.
  rewrite morphim_normal // /normal subIset ?subxx //=.
  apply/normsP=> p IpP; rewrite /H conjIg conjGid // -centJ.
  by case/andP: NMP => _; move/normsP; move/(_ _ IpP) => ->.
have F2: H' :!=: 1.
  by rewrite -subG1 quotient_sub1 ?proper_subn ?subIset // normal_norm.
have F3: H' :&: 'Z(P') != 1.
 apply: contra F2; move/eqP; move/nil_TI_Z=> -> //.
 by apply: quotient_nil; apply: (pgroup_nil PgP).
pose p := pdiv #|P|.
have F4: H \subset P by rewrite subIset // subxx.
have F5: prime p.
  rewrite prime_pdiv // (leq_trans _ (subset_leq_card F4)) //
          (leq_trans _ (proper_card PMC)) //.
  by exact: ltn_0group _ M.
have: p %| #|H' :&: 'Z(P')|; rewrite /P' /H' /H.
  have: p.-group (H' :&: 'Z(P')); rewrite /P' /H' /H.
    apply: (@pgroupS  _ _ (P/M)); last by apply: morphim_pgroup.
    by rewrite subIset // (normal_sub F1).
  case/pgroup_1Vpr=> [F3'| [p_pr _ [k ->]]]; last by rewrite dvdn_mulr.
  by case/eqP: F3.
case/(Cauchy F5) => X'; rewrite in_setI; case/andP=> IX'H' IX'ZP' CX'.
have F6: <[X']> <| P'.
  rewrite /normal;  have->: <[X']> \subset P'.
    move: IX'ZP'; rewrite /P' /H'/H.
    by rewrite -cycle_subG subsetI; case/andP.
  rewrite norms_gen // cents_norm // centsC sub1set.
  by move: IX'ZP'; rewrite in_setI; case/andP.
case: (inv_quotientN NMP F6) => X /= DX SMX SXP.
move: CX' F5; rewrite /order DX.
suff->: X :=: M by rewrite trivg_quotient cards1 => <-.
rewrite MM // SXP; apply /setIidPl; symmetry; apply: center_cyclic_abelian.
suff F7: M \subset 'Z(X).
  apply: (isog_cyclic (third_isog F7 _ (center_normal _))).
    by apply: normalS NMP => //;  move/normal_sub: SXP.
  by rewrite quotient_cyclic //= -DX;  apply/cyclicP; exists X'.
have F7: M \subset H by case/andP: PMC.
rewrite subsetI SMX centsC.
have: <[X']> \subset H'.
  by rewrite /H' /H cycle_subG.
rewrite DX quotientSGK //; first by rewrite subsetI; case/andP.
by rewrite normal_norm // (normalS _ _ NMP) //; case/andP: SXP.
Qed.

(* Gorenstein 5.3.11 *)
Lemma pgroup_crit: forall P, p_group P ->
  {C: {group gT} | [/\ C \char P,
                       (nil_class C <= 2 /\ abelem (C/'Z(C))),
                       [~: P , C] \subset 'Z(C) &
                       'C_P(C) = 'Z(C)]}.
Proof.
move=> P PgP; pose f (x: {set gT}) := (x \char P) && abelian x.
case: (@maxgroup_exists _ f 1); rewrite /f {f}; first by rewrite trivg_char abelian1.
move=> {f}D; case/maxgroupP; case/andP => ChD AD MD _.
pose f (x: {set gT}) := [&& (x <| P), abelian x & D \subset x].
case: (@maxgroup_exists _ f D); rewrite /f {f}.
  by rewrite (char_normal ChD) AD subxx.
move=> M HM; case/maxgroupP: (HM); case/and3P => NMP AM SDM MM _.
case ChM: (M \char P); move/idP: ChM => ChM.
  have AC: 'Z(M) = M by apply/setIidPl; case/maxgroupP: HM; case/andP.
  exists M; split=> //; last first.
  - rewrite AC; apply: (crit_lem) => //.
    apply/maxgroupP; split; first by rewrite NMP.
    move=> H; case/andP=> NHP AH SMH.
    by apply: MM => //; rewrite NHP AH (subset_trans SDM).
  - by rewrite AC commg_subr; case/andP: (char_normal ChM).
  split.
    rewrite /nil_class;case: #|M| => [|[|n]] //=; case: (_ == 1) => //.
    by rewrite ucn_lcnP ucn1 AC eqxx.
  by rewrite AC trivg_quotient abelem1.
pose P' := (P / D)%G; pose H := 'C_P(D)%G; pose H' := (H / D :&: P')%G.
pose C' := (H' :&: 'Ohm_1('Z(P')))%G.
pose C := (coset_morphism D @*^-1 C')%G.
exists C.
have ECC': C' :=: C / D by rewrite /= cosetpreK.
move: SDM; rewrite subEproper; case/orP => PDM.
  by case: ChM; rewrite -(eqP PDM).
have PDH: D \proper H.
  by rewrite (proper_sub_trans PDM) // subsetI (normal_sub NMP)
             centsC (subset_trans (proper_sub PDM)).
have ChH: H \char P := subcent_char (char_refl _) ChD.
have nTH: H' :!=: 1.
  rewrite -subG1 /= -quotientIG // ?(char_sub ChD) // quotient_sub1 //.
    apply: proper_subn.
    by rewrite (proper_sub_trans PDH) // !(subsetI, subIset) ?subxx ?orbT.
  by rewrite setIC subIset // char_norm.
pose K := (coset_morphism D @*^-1 'Ohm_1('Z(P')))%G.
have EKOZP': 'Ohm_1('Z(P')) = K / D by rewrite /= cosetpreK.
have ChK: K \char P.
  apply: (char_from_quotient _ ChD); first by rewrite normal_cosetpre.
  by rewrite cosetpreK; apply: char_trans (center_char _); exact: Ohm_char.
have CE: C :=: H :&: K.
  rewrite /= !morphpreI /= !quotientGK //=; last exact: char_normal.
    by congr (_ :&: _); rewrite setIAC setIid.
  apply: (normalS _ _ (char_normal ChD)); first exact: (proper_sub PDH).
  exact: (char_sub ChH).
have ChC: C \char P by rewrite CE; apply: charI.
have SD'ZC: D \subset 'Z(C).
  by rewrite subsetI {1}/C /C' /H' /P' /H sub_cosetpre centsC CE setIAC subsetIr.
have EZCD: 'Z(C) :=: D.
  rewrite /C /C' /H' /H /P'; apply: MD => //.
  apply/andP=> //; split; first by apply: (char_trans (center_char _)).
  by rewrite /abelian subIset // centsC subsetIr.
have F1: [~: P, C] \subset 'Z(C).
  rewrite EZCD /= -quotient_cents2 //=.
  - by rewrite cosetpreK centsC (subset_trans (subsetIr _ _)) //
               (subset_trans (@Ohm_sub 1 _ _)) // subsetIr.
  - exact: char_norm ChD.
  by rewrite cents_norm // centsC -{1}EZCD subsetIr.
split => //.
  - split; last first.
      by rewrite EZCD cosetpreK /= (abelemS (subsetIr _ _)) //
        Ohm_abelian // ?abelian_center // (@pgroup_p _ (pdiv #|P|)) //
                (@pgroupS _ _ (P/D)) // (center_sub,  morphim_pgroup).
   rewrite /nil_class; case: #|C| => [|[|[|n]]] //=;
     case: (_ == _) => //; case: (_ == _) => //.
   suff->: 'L_2(C) == 1 by done.
   rewrite (@ucn_lcnP _ C) ucnSnR ucn1 /=.
   rewrite eqEsubset; apply/andP; split; apply/subsetP=> x; rewrite in_set.
       by case/andP.
   move=> IxC; rewrite IxC; apply: subset_trans F1.
   apply/subsetP=> z; case/imsetP=> y IyC->; rewrite  mem_commg //.
   by apply: (subsetP (char_sub ChC)).
apply/eqP; rewrite eqEsubset.
rewrite {2}/center setSI ?andbT ?(char_sub ChC) //.
suff SCCC: 'C_P(C) \subset C.
  by rewrite /center subsetI SCCC subsetIr.
set Q := 'C_P(C)%G.
case E1: (Q \subset C); move/idPn: E1 => E1 //.
have QICD: Q :&: C = D.
  rewrite -EZCD /center /Q -setIA setIC -(setIA 'C(C)).
  suff->: C :&: P = C by rewrite setIC.
  by apply/setIidPl; apply: char_sub.
have QIH: Q \subset H by rewrite setIS // centS // -QICD subsetIr.
have NDQ: D <| Q.
  apply: normalS (char_normal ChD); last by rewrite subsetIl.
  by rewrite -QICD; rewrite subsetIl.
pose Q' := (Q / D)%G.
have Q'IH': Q' \subset H'.
  rewrite subsetI quotientSGK ?(proper_sub PDH) //; last by case/andP: NDQ.
  rewrite QIH quotientSGK //; last by apply: (char_sub ChD).
    by rewrite (subset_trans QIH) // (char_sub ChH) //.
  by case/andP: NDQ.
have TQ'C': Q' :&: C' = 1.
  rewrite ECC'.
  suff<-: (Q :&: C) / D = Q' :&: C / D by rewrite QICD trivg_quotient.
  by   apply: quotientIG; rewrite -{1}QICD subsetIr.
have NQ'P': Q' <| P'.
  apply: morphim_normal.
  rewrite /normal subIset ?subxx; last by done.
  apply/normsP=> p IpP; rewrite /H conjIg conjGid -?centJ; last by done.
  have: C <| P by apply: char_normal.
  by case/andP => _; move/normsP; move/(_ _ IpP) => ->.
have TQ': Q' :!=: 1.
  rewrite -subG1 quotient_sub1 -QICD.
  apply: contra E1 => TDQ'.
  apply: (subset_trans TDQ'); first by rewrite subsetIr.
  by rewrite QICD; case/andP: NDQ.
have NTQ'ZP': Q' :&: 'Z(P') != 1.
  apply: contra TQ'; move/eqP; move/nil_TI_Z=> -> //.
  by apply: quotient_nil; apply: (pgroup_nil PgP).
have NTQ'OZP': Q' :&: 'Ohm_1('Z(P')) != 1.
  by apply: contra NTQ'ZP'; move/eqP; move/TI_Ohm1->.
case/negP: NTQ'OZP'; rewrite -subG1 -TQ'C'.
rewrite subsetI subsetIl subsetI subsetIr andbT.
by apply: (subset_trans _  Q'IH'); rewrite subsetIl.
Qed.

End CriticalThompson.


Require Import TypeclassHierarchy.Interfaces.Semigroup.
Require Import TypeclassHierarchy.Interfaces.Functor.

Definition SG_Writer (W : Set) {SW : Semigroup W} (A : Type) : Type := (W * A).

Section SG_Writer_Bind.
  Context `{Semigroup W}.

  Definition SG_Writer_fmap (A B : Type) (f : A -> B) (a : SG_Writer W A) : SG_Writer W B :=
    match a with
      | (first, second) => (first, f second)
    end.

  Instance SG_Writer_Functor : Functor (SG_Writer W) :=
    { fmap := SG_Writer_fmap }.

  Proof.
    { (* fmap is proper w/r/t extensional equality *)
      (* this proof is turn-key, might want to consider something better *)
      intros A B.
      unfold Morphisms.Proper.
      unfold Morphisms.respectful.
      intros f g.
      unfold FunctionSetoid.extensional_equality.
      intros Hyp.
      destruct a as [log a'].
      unfold SG_Writer_fmap.
      now rewrite Hyp.
    }
    { (* fmap id = id *)
      intros A.
      unfold FunctionSetoid.extensional_equality.
      intros a.
      unfold SG_Writer_fmap.
      destruct a as [log a'].
      now unfold canonical_names.id.
    }
    { (* fmap f . fmap g = fmap (f . g) *)
      intros A B C h g.
      unfold FunctionSetoid.extensional_equality.
      intros a.
      destruct a as [log a'].
      now unfold SG_Writer_fmap.
    }
  Defined.

  Definition SG_Writer_ap
    (A B : Type) (f : SG_Writer W (A -> B)) (a : SG_Writer W A)
      : SG_Writer W B :=
    match f with
      | (log1, f') =>
        match a with
          | (log2, a') => (sg_op log1 log2, f' a')
        end
    end.

  Instance SG_Writer_Apply : Apply (SG_Writer W) :=
    { apply_functor := SG_Writer_Functor
    ; ap            := SG_Writer_ap
    }.
  Proof.
    intros A B C f g a.
    (* Managing complexity using clever names? Maybe. *)
    destruct a as [log_a a'].
    destruct f as [log_f f'].
    destruct g as [log_g g'].
    unfold SG_Writer_ap.
    now rewrite sg_op_associative.
  Defined.

  Definition SG_Writer_bind
             (A B : Type) (a : SG_Writer W A) (f : A -> SG_Writer W B) : SG_Writer W B :=
    match a with
      | (log1, a') =>
        match f a' with
          | (log2, fa) => (sg_op log1 log2, fa)
        end
    end.

  Instance SG_Writer_Bind : Bind (SG_Writer W) := { bind := SG_Writer_bind }.
  Proof.
    intros A B C x f g.
    destruct x as [log_x x'].
    unfold SG_Writer_bind.
    destruct f as [log_f b].
    destruct g as [log_g c].
    now rewrite sg_op_associative.
  Defined.
End SG_Writer_Bind.

Definition Writer (W : Set) {MW : Monoid W} (A : Type) : Type :=
  @SG_Writer W monoid_semigroup A.

Section Writer_Monad.
  Context `{Monoid W}.

  (* This is used a couplle times in the next proof *)
  Ltac unfold_applicative :=
    unfold ap; unfold SG_Writer_Apply; unfold SG_Writer_ap.

  Instance Writer_Applicative : Applicative (Writer W) :=
      { applicative_apply := SG_Writer_Apply
      ; pure              := (fun _ x => (unit : W, x))
      }.
  Proof.
    { (* ap pure id = id *)
      intros A a.
      destruct a as [log_a a].
      unfold canonical_names.id.
      unfold_applicative.
      now rewrite left_identity.
    }
    { (* ap_homomorphism *)
      intros A B f a.
      unfold_applicative.
      now rewrite left_identity.
    }
    { (* ap_interchange *)
      intros A B f a.
      unfold_applicative.
      case f.
      intros w b.
      rewrite left_identity.
      now rewrite right_identity.
    }
    { (* ap_composition *)
      intros A B C f g a.
      unfold_applicative.
      destruct f as [log_f f'].
      destruct g as [log_g g'].
      destruct a as [log_a a'].
      rewrite sg_op_associative.
      rewrite left_identity.
      now unfold Basics.compose.
    }
  Defined.

  Instance Writer_Monad : Monad (Writer W) :=
      { monad_applicative := Writer_Applicative
      ; monad_bind        := SG_Writer_Bind
      }.
  Proof.
    { (* left bind identity *)
      intros A B f x.
      unfold pure; unfold Writer_Applicative.
      unfold bind; unfold SG_Writer_Bind; unfold SG_Writer_bind.
      destruct f as [log_f f'].
      now rewrite left_identity.
    }
    { (* right bind identity *)
      intros A B f x.
      destruct x as [log_x x'].
      unfold pure; unfold Writer_Applicative.
      unfold bind; unfold SG_Writer_Bind; unfold SG_Writer_bind.
      now rewrite right_identity.
    }
  Defined.
End Writer_Monad.


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

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

Print Assumptions carry.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.NISTP256.AMD64.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


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

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


Require Export SepTypes.OrderedType.
Require Export Coq.Classes.Morphisms.
Require Export Coq.Relations.Relation_Operators.
Require Export Coq.Classes.RelationClasses.

Record perm (A:Type) `{OType A} : Type :=
  {
    view : A -> A -> Prop;  (* PER over configs *)
    view_Proper :> Proper (oleq ==> oleq ==> oleq) view;
    view_PER :> PER view;
    upd  : A -> A -> Prop;  (* allowed transitions *)
    upd_Proper :> Proper (oleq ==> oleq ==> oleq) upd;
    upd_PO :> PreOrder upd;
  }.

Arguments view {_ _} p.
Arguments upd {_ _} p.

Instance PER_view A `{OType A} p : PER (view p) := view_PER A p.
Instance PreOrder_upd A `{OType A} p : PreOrder (upd p) := upd_PO A p.

Instance Proper_view `{OType} (p:perm A) :
  Proper (oleq ==> oleq ==> oleq) (view p) :=
  view_Proper _ p.

Instance Proper_upd `{OType} (p:perm A) :
  Proper (oleq ==> oleq ==> oleq) (upd p) :=
  upd_Proper _ p.

Program Instance OType_perm A `{OType A} : OType (perm A) :=
  {| oleq :=
       fun p q =>
         forall x y,
           (view q) x y <o= (view p) x y /\ (upd p) x y <o= (upd q) x y;
  |}.
Next Obligation.
  constructor.
  - intros p x y; split; reflexivity.
  - intros p1 p2 p3 leq12 leq23 x y; destruct (leq12 x y); destruct (leq23 x y).
    split; etransitivity; eassumption.
Defined.

Program Definition meet_perm `{OType} (Ps: perm A -> Prop) : perm A :=
  {|
    view := clos_trans _ (fun x y => exists2 p, Ps p & view p x y);
    upd  := fun x y => forall p, Ps p -> upd p x y
  |}.
Next Obligation.
  intros x1 x2 leq_x y1 y2 leq_y in_vew_trans. revert x2 y2 leq_x leq_y.
  induction in_vew_trans; intros.
  - destruct H0. apply t_step. exists x0; try assumption.
    rewrite <- leq_x. rewrite <- leq_y. assumption.
  - eapply t_trans.
    + apply IHin_vew_trans1; [ assumption | reflexivity ].
    + apply IHin_vew_trans2; [ reflexivity | assumption ].
Defined.
Next Obligation.
  constructor.
  - intros x y r_xy; induction r_xy.
    + destruct H0. apply t_step. exists x0; [ | symmetry ]; assumption.
    + eapply t_trans; eassumption.
  - intros x y z r_xy r_yz. eapply t_trans; eassumption.
Defined.
Next Obligation.
  intros x1 x2 leq_x y1 y2 leq_y in_upd p in_p.
  rewrite <- leq_x. rewrite <- leq_y. apply in_upd. assumption.
Defined.
Next Obligation.

(* FIXME HERE:
+ prove that meet_perm is a glb
+ define top and bottom perms
+ define sep_at
+ prove sep_at_anti_monotone
+ prove bottom is separate from everything (that is valid)
+ define separating conjunction
+ prove sep_conj bottom p = p
+ prove sep_conj is Proper
+ define Perms as upwards-closed sets
+ define singleton Perms as the upward closure of a single perm
+ define meet on Perms
+ prove that Perms_meet is a glb
+ Define binary meet as a special case
+ Define conjunction of Perms pointwise
+ Define the top and bottom Perms sets
+ Define entailment as the inverse of lte_Perms
+ Define impl_Perms as the adjoint (w.r.t. entailment) of conjunction
*)


(*************************************************************************)
(* Copyright (C) 2013 - 2015                                             *)
(* Author C. Cohen                                                       *)
(* DRAFT - PLEASE USE WITH CAUTION                                       *)
(* License CeCILL-B                                                      *)
(*************************************************************************)

From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp Require Import choice path finset finfun fintype bigop tuple.
Require Import finmap.

(*****************************************************************************)
(* This file provides a representation of multisets based on fsfun           *)
(*   {mset T} == the type of multisets on a choiceType T                     *)
(* The following notations are in the %mset scope                            *)
(*             mset0 == the empty multiset                                   *)
(*          mset n a == the multiset with n times element a                  *)
(*          [mset a] == the singleton multiset {k} := mset 1 a               *)
(* [mset a1; ..; an] == the multiset obtained from the elements a1,..,an     *)
(*           A `&` B == the intersection of A and B (the min of each)        *)
(*           A `|` B == the union of A and B (the max of each)               *)
(*           A `+` B == the sum of A and B                                   *)
(*            a |` B == the union of singleton a and B                       *)
(*            a +` B == the addition of singleton a to B                     *)
(*           A `\` B == the difference A minus B                             *)
(*            A `\ b == A without one b                                      *)
(*           A `*` B == the product of A and B                               *)
(*  [disjoint A & B] := A `&` B == 0                                         *)
(*          A `<=` B == A is a sub-multiset of B                             *)
(*           A `<` B == A is a proper sub-multiset of B                      *)
(*****************************************************************************)

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

Lemma sumn_map I (f : I -> nat) s :
   sumn [seq f i | i <- s] = \sum_(i <- s) f i.
Proof. by elim: s => [|i s IHs] in f *; rewrite ?(big_nil, big_cons) //= IHs. Qed.

Lemma sumn_filter s P : sumn [seq i <- s | P i] = \sum_(i <- s | P i) i.
Proof. by rewrite -big_filter -sumn_map map_id. Qed.

Lemma sumn_map_filter I s (f : I -> nat) P :
   sumn [seq f i | i <- s & P i] = \sum_(i <- s | P i) f i.
Proof. by rewrite sumn_map big_filter. Qed.

Declare Scope mset_scope.
Delimit Scope mset_scope with mset.
Local Open Scope fset_scope.
Local Open Scope fmap_scope.
Local Open Scope mset_scope.
Local Open Scope nat_scope.

Definition multiset (T : choiceType) := {fsfun T -> nat with 0}.
Definition multiset_of (T : choiceType) of phant T := @multiset T.
Notation "'{mset' T }" := (@multiset_of _ (Phant T))
  (format "'{mset'  T }") : mset_scope.

Notation "[ 'mset[' key ] x 'in' aT => F ]" := ([fsfun[key] x in aT => F] : {mset _})
  (at level 0, x ident, only parsing) : mset_scope.
Notation "[ 'mset' x 'in' aT => F ]" := ([fsfun x in aT => F] : {mset _})
  (at level 0, x ident, only parsing) : mset_scope.
Notation "[ 'm' 'set' x 'in' aT => F ]" := ([fsfun[_] x in aT => F] : {mset _})
  (at level 0, x ident, format "[ 'm' 'set'  x  'in'  aT  =>  F ]") : mset_scope.

Identity Coercion multiset_multiset_of : multiset_of >-> multiset.

Notation enum_mset_def A :=
  (flatten [seq nseq (A%mset x) x | x <- finsupp A%mset]).

Module Type EnumMsetSig.
Axiom f : forall K, multiset K -> seq K.
Axiom E : f = (fun K (A : multiset K) => enum_mset_def A).
End EnumMsetSig.
Module EnumMset : EnumMsetSig.
Definition f K (A : multiset K) := enum_mset_def A.
Definition E := (erefl f).
End EnumMset.
Notation enum_mset := EnumMset.f.
Coercion enum_mset : multiset >-> seq.
Canonical enum_mset_unlock := Unlockable EnumMset.E.

Canonical multiset_predType (K : choiceType) :=
  PredType (fun (A : multiset K) a => a \in enum_mset A).
Canonical mset_finpredType (T: choiceType) :=
  mkFinPredType (multiset T) (fun A => undup (enum_mset A))
                (fun _ => undup_uniq _) (fun _ _ => mem_undup _ _).

Section MultisetOps.

Context {K : choiceType}.
Implicit Types (a b c : K) (A B C D : {mset K}) (s : seq K).

Definition mset0 : {mset K} := [fsfun].

Fact msetn_key : unit. Proof. exact: tt. Qed.
Definition msetn n a := [mset[msetn_key] x in [fset a] => n].

Fact seq_mset_key : unit. Proof. exact: tt. Qed.
Definition seq_mset (s : seq K) :=
  [mset[seq_mset_key] x in [fset x in s] => count (pred1 x) s].

Fact msetU_key : unit. Proof. exact: tt. Qed.
Definition msetU A B :=
  [mset[msetU_key] x in finsupp A `|` finsupp B => maxn (A x) (B x)].

Fact msetI_key : unit. Proof. exact: tt. Qed.
Definition msetI A B :=
  [mset[msetI_key] x in finsupp A `|` finsupp B => minn (A x) (B x)].

Fact msetD_key : unit. Proof. exact: tt. Qed.
Definition msetD A B :=
  [mset[msetD_key] x in finsupp A `|` finsupp B => A x + B x].

Fact msetB_key : unit. Proof. exact: tt. Qed.
Definition msetB A B :=
  [mset[msetB_key] x in finsupp A `|` finsupp B => A x - B x].

Fact msetM_key : unit. Proof. exact: tt. Qed.
Definition msetM A B :=
  [mset[msetM_key] x in finsupp A `*` finsupp B => A x.1 * B x.2].

Definition msubset A B := [forall x : finsupp A, A (val x) <= B (val x)].

Definition mproper A B := msubset A B && ~~ msubset B A.

Definition mdisjoint A B := (msetI A B == mset0).

End MultisetOps.

Notation "[ 'mset' a ]" := (msetn 1 a)
  (at level 0, a at level 99, format "[ 'mset'  a ]") : mset_scope.
Notation "[ 'mset' a : T ]" := [mset (a : T)]
  (at level 0, a at level 99, format "[ 'mset'  a   :  T ]") : mset_scope.
Notation "A `|` B" := (msetU A B) : mset_scope.
Notation "A `+` B" := (msetD A B) : mset_scope.
Notation "A `\` B" := (msetB A B) : mset_scope.
Notation "A `\ a" := (A `\` [mset a]) : mset_scope.
Notation "a |` A" := ([mset (a)] `|` A) : mset_scope.
Notation "a +` A" := ([mset (a)] `+` A) : mset_scope.
Notation "A `*` B" := (msetM A B) : mset_scope.

Notation "A `<=` B" := (msubset A B)
  (at level 70, no associativity) : mset_scope.

Notation "A `<` B" := (mproper A B)
  (at level 70, no associativity) : mset_scope.

(* This is left-associative due to historical limitations of the .. Notation. *)
Notation "[ 'mset' a1 ; a2 ; .. ; an ]" :=
  (msetD .. (a1 +` (msetn 1 a2)) .. (msetn 1 an))
  (at level 0, a1 at level 99,
   format "[ 'mset'  a1 ;  a2 ;  .. ;  an ]") : mset_scope.
Notation "A `&` B" := (msetI A B) : mset_scope.

Section MSupp.

Context {K : choiceType}.
Implicit Types (a b c : K) (A B C D : {mset K}) (s : seq K).

Lemma enum_msetE a A :
   (a \in A) = (a \in flatten [seq nseq (A x) x | x <- finsupp A]).
Proof. by transitivity (a \in enum_mset A); rewrite // unlock. Qed.

Lemma msuppE a A : (a \in finsupp A) = (a \in A).
Proof.
rewrite enum_msetE.
apply/idP/flattenP => [aA|/=[_ /mapP[x xA -> /nseqP[->//]]]].
exists (nseq (A a) a); first by apply/mapP; exists a.
by apply/nseqP; split=> //; rewrite lt0n -mem_finsupp.
Qed.

End MSupp.

Section MSetTheory.

Context {K : choiceType}.
Implicit Types (a b c : K) (A B C D : {mset K}) (s : seq K).

Lemma msetP {A B} : A =1 B <-> A = B.
Proof. exact: fsfunP. Qed.

Lemma mset_neq0 a A : (A a != 0) = (a \in A).
Proof. by rewrite -msuppE mem_finsupp. Qed.

Lemma in_mset a A : (a \in A) = (A a > 0).
Proof. by rewrite -mset_neq0 lt0n. Qed.

Lemma mset_eq0 a A : (A a == 0) = (a \notin A).
Proof. by rewrite -mset_neq0 negbK. Qed.

Lemma mset_eq0P {a A} : reflect (A a = 0) (a \notin A).
Proof. by rewrite -mset_eq0; apply: eqP. Qed.

Lemma mset_gt0 a A : (A a > 0) = (a \in A).
Proof. by rewrite -in_mset. Qed.

Lemma mset_eqP {A B} : reflect (A =1 B) (A == B).
Proof. exact: (equivP eqP (iff_sym msetP)). Qed.

Lemma mset0E a : mset0 a = 0.
Proof. by rewrite /mset0 fsfunE. Qed.

Lemma msetnE n a b : (msetn n a) b = if b == a then n else 0.
Proof. by rewrite fsfunE inE. Qed.

Lemma msetnxx n a : (msetn n a) a = n. Proof. by rewrite msetnE eqxx. Qed.

Lemma msetE2 A B a :
 ((A `+` B) a = A a + B a) * ((A `|` B) a = maxn (A a) (B a))
* ((A `&` B) a = minn (A a) (B a)) * ((A `\` B) a = (A a) - (B a)).
Proof.
rewrite !fsfunE !inE !msuppE -!mset_neq0; case: ifPn => //.
by rewrite negb_or !negbK => /andP [/eqP-> /eqP->].
Qed.

Lemma count_mem_mset a A : count_mem a A = A a.
Proof.
rewrite unlock count_flatten sumn_map big_map.
rewrite (eq_bigr _ (fun _ _ => esym (sum1_count _ _))) /=.
rewrite (eq_bigr _ (fun _ _ => big_nseq_cond _ _ _ _ _ _)) /= -big_mkcond /=.
have [aNA|aA] := finsuppP.
  by rewrite big1_fset // => i iA /eqP eq_ia; rewrite -eq_ia iA in aNA.
rewrite big_fset_condE/= (big_fsetD1 a) ?inE ?eqxx ?andbT //= iter_addn mul1n.
rewrite (_ : (_ `\ _)%fset = fset0) ?big_seq_fset0 ?addn0//.
by apply/fsetP=> i; rewrite !inE; case: (i == a); rewrite ?(andbF, andbT).
Qed.

Lemma perm_undup_mset A : perm_eq (undup A) (finsupp A).
Proof.
apply: uniq_perm; rewrite ?undup_uniq // => a.
by rewrite mem_undup msuppE.
Qed.

Section big_com.
Variables (R : Type) (idx : R) (op : Monoid.com_law idx).
Implicit Types (X : {mset K}) (P : pred K) (F : K -> R).

Lemma big_mset X P F :
  \big[op/idx]_(i <- X | P i) F i =
  \big[op/idx]_(i <- finsupp X | P i) iterop (X i) op (F i) idx.
Proof.
rewrite [in RHS](perm_big (undup X)) 1?perm_sym ?perm_undup_mset//.
rewrite -[in LHS]big_undup_iterop_count; apply: eq_bigr => i _.
by rewrite count_mem_mset.
Qed.

End big_com.

Lemma sum_mset (X : {mset K}) (P : pred K) (F : K -> nat) :
  \sum_(i <- X | P i) F i = \sum_(i <- finsupp X | P i) X i * F i.
Proof.
rewrite big_mset; apply: eq_bigr => i _ //.
by rewrite Monoid.iteropE iter_addn addn0 mulnC.
Qed.

Lemma prod_mset (X : {mset K}) (P : pred K) (F : K -> nat) :
  \prod_(i <- X | P i) F i = \prod_(i <- finsupp X | P i) F i ^ X i.
Proof. by rewrite big_mset. Qed.

Lemma mset_seqE s a : (seq_mset s) a = count_mem a s.
Proof. by rewrite fsfunE inE/=; case: ifPn => // /count_memPn ->. Qed.

Lemma perm_eq_seq_mset s : perm_eq (seq_mset s) s.
Proof. by apply/allP => a _ /=; rewrite count_mem_mset mset_seqE. Qed.

Lemma seq_mset_id A : seq_mset A = A.
Proof. by apply/msetP=> a; rewrite mset_seqE count_mem_mset. Qed.

Lemma eq_seq_msetP s s' : reflect (seq_mset s = seq_mset s') (perm_eq s s').
Proof.
apply: (iffP idP) => [/permP perm_ss'|eq_ss'].
  by apply/msetP => a; rewrite !mset_seqE perm_ss'.
by apply/allP => a _ /=; rewrite -!mset_seqE eq_ss'.
Qed.

Lemma msetME A B (u : K * K) : (A `*` B) u = A u.1 * B u.2.
Proof.
rewrite !fsfunE inE; case: ifPn => //=.
by rewrite negb_and !memNfinsupp => /orP [] /eqP->; rewrite ?muln0.
Qed.

Lemma mset1DE a A b : (a +` A) b = (b == a) + A b.
Proof. by rewrite msetE2 msetnE; case: (b == a). Qed.

Lemma mset1UE a A b : (a |` A) b = maxn (b == a) (A b).
Proof. by rewrite msetE2 msetnE; case: (b == a). Qed.

Lemma msetB1E a A b : (A `\ a) b = (A b) - (b == a).
Proof. by rewrite msetE2 msetnE; case: (b == a). Qed.

Let msetE := (mset0E, msetE2, msetnE, msetnxx,
              mset1DE, mset1UE, msetB1E,
              mset_seqE, msetME).

Lemma in_mset0 a : a \in mset0 = false.
Proof. by rewrite in_mset !msetE. Qed.

Lemma in_msetn n a' a : a \in msetn n a' = (n > 0) && (a == a').
Proof. by rewrite in_mset msetE; case: (a == a'); rewrite ?andbT ?andbF. Qed.

Lemma in_mset1 a' a : a \in [mset a'] = (a == a').
Proof. by rewrite in_msetn. Qed.

Lemma in_msetD A B a : (a \in A `+` B) = (a \in A) || (a \in B).
Proof. by rewrite !in_mset !msetE addn_gt0. Qed.

Lemma in_msetU A B a : (a \in A `|` B) = (a \in A) || (a \in B).
Proof. by rewrite !in_mset !msetE leq_max. Qed.

Lemma in_msetDU A B a : (a \in A `+` B) = (a \in A `|` B).
Proof. by rewrite in_msetU in_msetD. Qed.

Lemma in_msetI A B a : (a \in A `&` B) = (a \in A) && (a \in B).
Proof. by rewrite !in_mset msetE leq_min. Qed.

Lemma in_msetB A B a : (a \in A `\` B) = (B a < A a).
Proof. by rewrite -mset_neq0 msetE subn_eq0 ltnNge. Qed.

Lemma in_mset1U a' A a : (a \in a' |` A) = (a == a') || (a \in A).
Proof. by rewrite in_msetU in_mset msetE; case: (_ == _). Qed.

Lemma in_mset1D a' A a : (a \in a' +` A) = (a == a') || (a \in A).
Proof. by rewrite in_msetDU in_mset1U. Qed.

Lemma in_msetB1 A b a : (a \in A `\ b) = ((a == b) ==> (A a > 1)) && (a \in A).
Proof.
by rewrite in_msetB msetE in_mset; case: (_ == _); rewrite -?geq_max.
Qed.

Lemma in_msetM A B (u : K * K) : (u \in A `*` B) = (u.1 \in A) && (u.2 \in B).
Proof. by rewrite -!msuppE !mem_finsupp msetE muln_eq0 negb_or. Qed.

Definition in_msetE := (in_mset0, in_msetn,
                        in_msetB1, in_msetU, in_msetI, in_msetD, in_msetM).

Let inE := (inE, in_msetE, (@msuppE K)).

Lemma enum_mset0 : mset0 = [::] :> seq K.
Proof. by rewrite unlock finsupp0. Qed.

Lemma msetn0 (a : K) : msetn 0 a = mset0.
Proof. by apply/msetP=> i; rewrite !msetE if_same. Qed.

Lemma finsupp_msetn n a : finsupp (msetn n a) = if n > 0 then [fset a] else fset0.
Proof.  by apply/fsetP => i; rewrite !inE; case: ifP => //=; rewrite inE. Qed.

Lemma enum_msetn n a : msetn n a = nseq n a :> seq K.
Proof.
case: n => [|n]; first by rewrite msetn0 /= enum_mset0.
rewrite unlock finsupp_msetn /= enum_fsetE /= enum_fset1 /= cats0.
by rewrite msetE eqxx.
Qed.

Section big.
Variables (R : Type) (idx : R) (op : Monoid.law idx).
Implicit Types (X : {mset K}) (P : pred K) (F : K -> R).

Lemma big_mset0 P F : \big[op/idx]_(i <- mset0 | P i) F i = idx.
Proof. by rewrite enum_mset0 big_nil. Qed.

Lemma big_msetn n a P F :
   \big[op/idx]_(i <- msetn n a | P i) F i =
   if P a then iterop n op (F a) idx else idx.
Proof. by rewrite enum_msetn big_nseq_cond Monoid.iteropE. Qed.
End big.

Lemma msetDC (A B : {mset K}) : A `+` B = B `+` A.
Proof. by apply/msetP=> a; rewrite !msetE addnC. Qed.

Lemma msetIC (A B : {mset K}) : A `&` B = B `&` A.
Proof. by apply/msetP=> a; rewrite !msetE minnC. Qed.

Lemma msetUC (A B : {mset K}) : A `|` B = B `|` A.
Proof. by apply/msetP => a; rewrite !msetE maxnC. Qed.

(* intersection *)

Lemma mset0I A : mset0 `&` A = mset0.
Proof. by apply/msetP => x; rewrite !msetE min0n. Qed.

Lemma msetI0 A : A `&` mset0 = mset0.
Proof. by rewrite msetIC mset0I. Qed.

Lemma msetIA A B C : A `&` (B `&` C) = A `&` B `&` C.
Proof. by apply/msetP=> x; rewrite !msetE minnA. Qed.

Lemma msetICA A B C : A `&` (B `&` C) = B `&` (A `&` C).
Proof. by rewrite !msetIA (msetIC A). Qed.

Lemma msetIAC A B C : A `&` B `&` C = A `&` C `&` B.
Proof. by rewrite -!msetIA (msetIC B). Qed.

Lemma msetIACA A B C D : (A `&` B) `&` (C `&` D) = (A `&` C) `&` (B `&` D).
Proof. by rewrite -!msetIA (msetICA B). Qed.

Lemma msetIid A : A `&` A = A.
Proof. by apply/msetP=> x; rewrite !msetE minnn. Qed.

Lemma msetIIl A B C : A `&` B `&` C = (A `&` C) `&` (B `&` C).
Proof. by rewrite msetIA !(msetIAC _ C) -(msetIA _ C) msetIid. Qed.

Lemma msetIIr A B C : A `&` (B `&` C) = (A `&` B) `&` (A `&` C).
Proof. by rewrite !(msetIC A) msetIIl. Qed.

(* union *)

Lemma mset0U A : mset0 `|` A = A.
Proof. by apply/msetP => x; rewrite !msetE max0n. Qed.

Lemma msetU0 A : A `|` mset0 = A.
Proof. by rewrite msetUC mset0U. Qed.

Lemma msetUA A B C : A `|` (B `|` C) = A `|` B `|` C.
Proof. by apply/msetP=> x; rewrite !msetE maxnA. Qed.

Lemma msetUCA A B C : A `|` (B `|` C) = B `|` (A `|` C).
Proof. by rewrite !msetUA (msetUC B). Qed.

Lemma msetUAC A B C : A `|` B `|` C = A `|` C `|` B.
Proof. by rewrite -!msetUA (msetUC B). Qed.

Lemma msetUACA A B C D : (A `|` B) `|` (C `|` D) = (A `|` C) `|` (B `|` D).
Proof. by rewrite -!msetUA (msetUCA B). Qed.

Lemma msetUid A : A `|` A = A.
Proof. by apply/msetP=> x; rewrite !msetE maxnn. Qed.

Lemma msetUUl A B C : A `|` B `|` C = (A `|` C) `|` (B `|` C).
Proof. by rewrite msetUA !(msetUAC _ C) -(msetUA _ C) msetUid. Qed.

Lemma msetUUr A B C : A `|` (B `|` C) = (A `|` B) `|` (A `|` C).
Proof. by rewrite !(msetUC A) msetUUl. Qed.

(* adjunction *)

Lemma mset0D A : mset0 `+` A = A.
Proof. by apply/msetP => x; rewrite !msetE add0n. Qed.

Lemma msetD0 A : A `+` mset0 = A.
Proof. by rewrite msetDC mset0D. Qed.

Lemma msetDA A B C : A `+` (B `+` C) = A `+` B `+` C.
Proof. by apply/msetP=> x; rewrite !msetE addnA. Qed.

Lemma msetDCA A B C : A `+` (B `+` C) = B `+` (A `+` C).
Proof. by rewrite !msetDA (msetDC B). Qed.

Lemma msetDAC A B C : A `+` B `+` C = A `+` C `+` B.
Proof. by rewrite -!msetDA (msetDC B). Qed.

Lemma msetDACA A B C D : (A `+` B) `+` (C `+` D) = (A `+` C) `+` (B `+` D).
Proof. by rewrite -!msetDA (msetDCA B). Qed.

(* adjunction, union and difference with one element *)

Lemma msetU1l x A B : x \in A -> x \in A `|` B.
Proof. by move=> Ax /=; rewrite inE Ax. Qed.

Lemma msetU1r A b : b \in A `|` [mset b].
Proof. by rewrite !inE eqxx orbT. Qed.

Lemma msetB1P x A b : reflect ((x = b -> A x > 1) /\ x \in A) (x \in A `\ b).
Proof.
rewrite !inE. apply: (iffP andP); first by move=> [/implyP Ax ->]; split => // /eqP.
by move=> [Ax ->]; split => //; apply/implyP => /eqP.
Qed.

Lemma msetB11 b A : (b \in A `\ b) = (A b > 1).
Proof. by rewrite inE eqxx /= in_mset -geq_max. Qed.

Lemma msetB1K a A : a \in A -> a +` (A `\ a) = A.
Proof.
move=> aA; apply/msetP=> x; rewrite !msetE subnKC //=.
by have [->|//] := altP eqP; rewrite mset_gt0.
Qed.

Lemma msetD1K a B : (a +` B) `\ a = B.
Proof. by apply/msetP => x; rewrite !msetE addKn. Qed.

Lemma msetU1K a B : a \notin B -> (a |` B) `\ a = B.
Proof.
move=> aB; apply/msetP=> x; rewrite !msetE.
have [->|] := altP eqP; first by rewrite (mset_eq0P _).
by rewrite max0n subn0.
Qed.

Lemma mset1U1 x B : x \in x |` B. Proof. by rewrite !inE eqxx. Qed.
Lemma mset1D1 x B : x \in x +` B. Proof. by rewrite !inE eqxx. Qed.

Lemma mset1Ur x a B : x \in B -> x \in a |` B.
Proof. by move=> Bx; rewrite !inE predU1r. Qed.
Lemma mset1Dr x a B : x \in B -> x \in a +` B.
Proof. by move=> Bx; rewrite !inE predU1r. Qed.

Lemma mset2P x a b : reflect (x = a \/ x = b) (x \in [mset a; b]).
Proof. by rewrite !inE; apply: (iffP orP) => [] [] /eqP; intuition. Qed.

Lemma in_mset2 x a b : (x \in [mset a; b]) = (x == a) || (x == b).
Proof. by rewrite !inE. Qed.

Lemma mset21 a b : a \in [mset a; b]. Proof. by rewrite mset1D1. Qed.

Lemma mset22 a b : b \in [mset a; b]. Proof. by rewrite in_mset2 eqxx orbT. Qed.

Lemma msetUP x A B : reflect (x \in A \/ x \in B) (x \in A `|` B).
Proof. by rewrite !inE; exact: orP. Qed.

Lemma msetDP x A B : reflect (x \in A \/ x \in B) (x \in A `+` B).
Proof. by rewrite !inE; exact: orP. Qed.

Lemma msetULVR x A B : x \in A `|` B -> (x \in A) + (x \in B).
Proof. by rewrite inE; case: (x \in A); [left|right]. Qed.

Lemma msetDLVR x A B : x \in A `+` B -> (x \in A) + (x \in B).
Proof. by rewrite inE; case: (x \in A); [left|right]. Qed.

(* distribute /cancel *)

Lemma msetIUr A B C : A `&` (B `|` C) = (A `&` B) `|` (A `&` C).
Proof. by apply/msetP=> x; rewrite !msetE minn_maxr. Qed.

Lemma msetIUl A B C : (A `|` B) `&` C = (A `&` C) `|` (B `&` C).
Proof. by apply/msetP=> x; rewrite !msetE minn_maxl. Qed.

Lemma msetUIr A B C : A `|` (B `&` C) = (A `|` B) `&` (A `|` C).
Proof. by apply/msetP=> x; rewrite !msetE maxn_minr. Qed.

Lemma msetUIl A B C : (A `&` B) `|` C = (A `|` C) `&` (B `|` C).
Proof. by apply/msetP=> x; rewrite !msetE maxn_minl. Qed.

Lemma msetUKC A B : (A `|` B) `&` A = A.
Proof. by apply/msetP=> x; rewrite !msetE maxnK. Qed.

Lemma msetUK A B : (B `|` A) `&` A = A.
Proof. by rewrite msetUC msetUKC. Qed.

Lemma msetKUC A B : A `&` (B `|` A) = A.
Proof. by rewrite msetIC msetUK. Qed.

Lemma msetKU A B : A `&` (A `|` B) = A.
Proof. by rewrite msetIC msetUKC. Qed.

Lemma msetIKC A B : (A `&` B) `|` A = A.
Proof. by apply/msetP=> x; rewrite !msetE minnK. Qed.

Lemma msetIK A B : (B `&` A) `|` A = A.
Proof. by rewrite msetIC msetIKC. Qed.

Lemma msetKIC A B : A `|` (B `&` A) = A.
Proof. by rewrite msetUC msetIK. Qed.

Lemma msetKI A B : A `|` (A `&` B) = A.
Proof. by rewrite msetIC msetKIC. Qed.

Lemma msetUKid A B : B `|` A `|` A = B `|` A.
Proof. by rewrite -msetUA msetUid. Qed.

Lemma msetUKidC A B : A `|` B `|` A = A `|` B.
Proof. by rewrite msetUAC msetUid. Qed.

Lemma msetKUid A B : A `|` (A `|` B) = A `|` B.
Proof. by rewrite msetUA msetUid. Qed.

Lemma msetKUidC A B : A `|` (B `|` A) = B `|` A.
Proof. by rewrite msetUCA msetUid. Qed.

Lemma msetIKid A B : B `&` A `&` A = B `&` A.
Proof. by rewrite -msetIA msetIid. Qed.

Lemma msetIKidC A B : A `&` B `&` A = A `&` B.
Proof. by rewrite msetIAC msetIid. Qed.

Lemma msetKIid A B : A `&` (A `&` B) = A `&` B.
Proof. by rewrite msetIA msetIid. Qed.

Lemma msetKIidC A B : A `&` (B `&` A) = B `&` A.
Proof. by rewrite msetICA msetIid. Qed.

Lemma msetDIr A B C : A `+` (B `&` C) = (A `+` B) `&` (A `+` C).
Proof. by apply/msetP=> x; rewrite !msetE addn_minr. Qed.

Lemma msetDIl A B C : (A `&` B) `+` C = (A `+` C) `&` (B `+` C).
Proof. by apply/msetP=> x; rewrite !msetE addn_minl. Qed.

Lemma msetDKIC A B : (A `+` B) `&` A = A.
Proof. by apply/msetP=> x; rewrite !msetE (minn_idPr _) // leq_addr. Qed.

Lemma msetDKI A B : (B `+` A) `&` A = A.
Proof. by rewrite msetDC msetDKIC. Qed.

Lemma msetKDIC A B : A `&` (B `+` A) = A.
Proof. by rewrite msetIC msetDKI. Qed.

Lemma msetKDI A B : A `&` (A `+` B) = A.
Proof. by rewrite msetDC msetKDIC. Qed.

(* adjunction / subtraction *)

Lemma msetDKB A : cancel (msetD A) (msetB^~ A).
Proof. by move=> B; apply/msetP => a; rewrite !msetE addKn. Qed.

Lemma msetDKBC A : cancel (msetD^~ A) (msetB^~ A).
Proof. by move=> B; rewrite msetDC msetDKB. Qed.

Lemma msetBSKl A B a : ((a +` A) `\` B) `\ a = A `\` B.
Proof.
apply/msetP=> b; rewrite !msetE; case: ifPn; rewrite ?add0n ?subn0 //.
by rewrite add1n subn1 subSKn.
Qed.

Lemma msetBDl C A B : (C `+` A) `\` (C `+` B) = A `\` B.
Proof. by apply/msetP=> a; rewrite !msetE subnDl. Qed.

Lemma msetBDr C A B : (A `+` C) `\` (B `+` C) = A `\` B.
Proof. by apply/msetP=> a; rewrite !msetE subnDr. Qed.

Lemma msetBDA A B C : B `\` (A `+` C) = B `\` A `\` C.
Proof. by apply/msetP=> a; rewrite !msetE subnDA. Qed.

Lemma msetUE A B C : msetU A B = A `+` (B `\` A).
Proof. by apply/msetP=> a; rewrite !msetE maxnE. Qed.

(* subset *)

Lemma msubsetP {A B} : reflect (forall x, A x <= B x) (A `<=` B).
Proof.
apply: (iffP forallP)=> // ? x; case: (in_fsetP (finsupp A) x) => //.
by rewrite msuppE => /mset_eq0P->.
Qed.

Lemma msubset_subset {A B} : A `<=` B -> {subset A <= B}.
Proof.
by move=> /msubsetP AB x; rewrite !in_mset => ?; exact: (leq_trans _ (AB _)).
Qed.

Lemma msetB_eq0 (A B : {mset K}) : (A `\` B == mset0) = (A `<=` B).
Proof.
apply/mset_eqP/msubsetP => AB a;
by have := AB a; rewrite !msetE -subn_eq0 => /eqP.
Qed.

Lemma msubset_refl A : A `<=` A. Proof. exact/msubsetP. Qed.
Hint Resolve msubset_refl : core.

Lemma msubset_trans : transitive (@msubset K).
Proof.
move=> y x z /msubsetP xy /msubsetP yz ; apply/msubsetP => a.
by apply: (leq_trans (xy _)).
Qed.
Arguments msubset_trans {C A B} _ _ : rename.

Lemma msetUS C A B : A `<=` B -> C `|` A `<=` C `|` B.
Proof.
move=> sAB; apply/msubsetP=> x; rewrite !msetE.
by rewrite geq_max !leq_max leqnn (msubsetP sAB) orbT.
Qed.

Lemma msetDS C A B : A `<=` B -> C `+` A `<=` C `+` B.
Proof.
by move=> /msubsetP sAB; apply/msubsetP=> x; rewrite !msetE leq_add2l.
Qed.

Lemma msetSU C A B : A `<=` B -> A `|` C `<=` B `|` C.
Proof. by move=> sAB; rewrite -!(msetUC C) msetUS. Qed.

Lemma msetSD C A B : A `<=` B -> A `+` C `<=` B `+` C.
Proof. by move=> sAB; rewrite -!(msetDC C) msetDS. Qed.

Lemma msetUSS A B C D : A `<=` C -> B `<=` D -> A `|` B `<=` C `|` D.
Proof. by move=> /(msetSU B) /msubset_trans sAC /(msetUS C)/sAC. Qed.

Lemma msetDSS A B C D : A `<=` C -> B `<=` D -> A `+` B `<=` C `+` D.
Proof. by move=> /(msetSD B) /msubset_trans sAC /(msetDS C)/sAC. Qed.

Lemma msetIidPl {A B} : reflect (A `&` B = A) (A `<=` B).
Proof.
apply: (iffP msubsetP) => [?|<- a]; last by rewrite !msetE geq_min leqnn orbT.
by apply/msetP => a; rewrite !msetE (minn_idPl _).
Qed.

Lemma msetIidPr {A B} : reflect (A `&` B = B) (B `<=` A).
Proof. by rewrite msetIC; apply: msetIidPl. Qed.

Lemma msubsetIidl A B : (A `<=` A `&` B) = (A `<=` B).
Proof.
apply/msubsetP/msubsetP=> sAB a; have := sAB a; rewrite !msetE.
  by rewrite leq_min leqnn.
by move/minn_idPl->.
Qed.

Lemma msubsetIidr A B : (B `<=` A `&` B) = (B `<=` A).
Proof. by rewrite msetIC msubsetIidl. Qed.

Lemma msetUidPr A B : reflect (A `|` B = B) (A `<=` B).
Proof.
apply: (iffP msubsetP) => [AB|<- a]; last by rewrite !msetE leq_max leqnn.
by apply/msetP=> a; rewrite !msetE (maxn_idPr _).
Qed.

Lemma msetUidPl A B : reflect (A `|` B = A) (B `<=` A).
Proof. by rewrite msetUC; apply/msetUidPr. Qed.

Lemma msubsetUl A B : A `<=` A `|` B.
Proof. by apply/msubsetP=> a; rewrite !msetE leq_maxl. Qed.
Hint Resolve msubsetUl : core.

Lemma msubsetUr A B : B `<=` (A `|` B).
Proof. by rewrite msetUC. Qed.
Hint Resolve msubsetUr : core.

Lemma msubsetU1 x A : A `<=` (x |` A).
Proof. by rewrite msubsetUr. Qed.
Hint Resolve msubsetU1 : core.

Lemma msubsetU A B C : (A `<=` B) || (A `<=` C) -> A `<=` (B `|` C).
Proof. by move=> /orP [] /msubset_trans ->. Qed.

Lemma eqEmsubset A B : (A == B) = (A `<=` B) && (B `<=` A).
Proof.
apply/eqP/andP => [<-|[/msubsetP AB /msubsetP BA]]; first by split.
by apply/msetP=> a; apply/eqP; rewrite eqn_leq AB BA.
Qed.

Lemma msubEproper A B : A `<=` B = (A == B) || (A `<` B).
Proof. by rewrite eqEmsubset -andb_orr orbN andbT. Qed.

Lemma mproper_sub A B : A `<` B -> A `<=` B.
Proof. by rewrite msubEproper orbC => ->. Qed.

Lemma eqVmproper A B : A `<=` B -> A = B \/ A `<` B.
Proof. by rewrite msubEproper => /predU1P. Qed.

Lemma mproperEneq A B : A `<` B = (A != B) && (A `<=` B).
Proof. by rewrite andbC eqEmsubset negb_and andb_orr andbN. Qed.

Lemma mproper_neq A B : A `<` B -> A != B.
Proof. by rewrite mproperEneq; case/andP. Qed.

Lemma eqEmproper A B : (A == B) = (A `<=` B) && ~~ (A `<` B).
Proof. by rewrite negb_and negbK andb_orr andbN eqEmsubset. Qed.

Lemma msub0set A : msubset mset0 A.
Proof. by apply/msubsetP=> x; rewrite msetE. Qed.
Hint Resolve msub0set : core.

Lemma msubset0 A : (A `<=` mset0) = (A == mset0).
Proof. by rewrite eqEmsubset msub0set andbT. Qed.

Lemma mproper0 A : (mproper mset0 A) = (A != mset0).
Proof. by rewrite /mproper msub0set msubset0. Qed.

Lemma mproperE A B : (A `<` B) = (A `<=` B) && ~~ (msubset B A).
Proof. by []. Qed.

Lemma mproper_sub_trans B A C : A `<` B -> B `<=` C -> A `<` C.
Proof.
move=> /andP [AB NBA] BC; rewrite /mproper (msubset_trans AB) //=.
by apply: contra NBA=> /(msubset_trans _)->.
Qed.

Lemma msub_proper_trans B A C :
  A `<=` B -> B `<` C -> A `<` C.
Proof.
move=> AB /andP [CB NCB]; rewrite /mproper (msubset_trans AB) //=.
by apply: contra NCB=> /msubset_trans->.
Qed.

Lemma msubset_neq0 A B : A `<=` B -> A != mset0 -> B != mset0.
Proof. by rewrite -!mproper0 => sAB /mproper_sub_trans->. Qed.

(* msub is a morphism *)

Lemma msetBDKC A B : A `<=` B -> A `+` (B `\` A) = B.
Proof. by move=> /msubsetP AB; apply/msetP=> a; rewrite !msetE subnKC. Qed.

Lemma msetBDK A B : A `<=` B -> B `\` A `+` A = B.
Proof. by move=> /msubsetP AB; apply/msetP => a; rewrite !msetE subnK. Qed.

Lemma msetBBK A B : A `<=` B -> B `\` (B `\` A) = A.
Proof. by move=> /msubsetP AB; apply/msetP => a; rewrite !msetE subKn. Qed.

Lemma msetBD1K A B a : A `<=` B -> A a < B a -> a +` (B `\` (a +` A)) = B `\` A.
Proof.
move=> /msubsetP AB ABa; apply/msetP => b; rewrite !msetE.
by case: ifP => //= /eqP->; rewrite !add1n subnSK.
Qed.

Lemma subset_msetBLR A B C : (msubset (A `\` B) C) = (A `<=` B `+` C).
Proof.
apply/msubsetP/msubsetP => [] sABC a;
by have := sABC a; rewrite !msetE ?leq_subLR.
Qed.

Lemma msetnP n x a : reflect (0 < n /\ x = a) (x \in msetn n a).
Proof. by do [apply: (iffP idP); rewrite !inE] => [/andP[]|[]] -> /eqP. Qed.

Lemma gt0_msetnP n x a : 0 < n -> reflect (x = a) (x \in msetn n a).
Proof. by move=> n_gt0; rewrite inE n_gt0 /=; exact: eqP. Qed.

Lemma msetn1 n a : a \in msetn n a = (n > 0).
Proof. by rewrite inE eqxx andbT. Qed.

Lemma mset1P x a : reflect (x = a) (x \in [mset a]).
Proof. by rewrite inE; exact: eqP. Qed.

Lemma mset11 a : a \in [mset a]. Proof. by rewrite inE /=. Qed.

Lemma msetn_inj n : n > 0 -> injective (@msetn K n).
Proof.
move=> n_gt0 a b eqsab; apply/(gt0_msetnP _ _ n_gt0).
by rewrite -eqsab inE n_gt0 eqxx.
Qed.

Lemma mset1UP x a B : reflect (x = a \/ x \in B) (x \in a |` B).
Proof. by rewrite !inE; exact: predU1P. Qed.

Lemma mset_cons a s : seq_mset (a :: s) = a +` (seq_mset s).
Proof. by apply/msetP=> x; rewrite !msetE /= eq_sym. Qed.

(* intersection *)

Lemma msetIP x A B : reflect (x \in A /\ x \in B) (x \in A `&` B).
Proof. by rewrite inE; apply: andP. Qed.

Lemma msetIS C A B : A `<=` B -> C `&` A `<=` C `&` B.
Proof.
move=> sAB; apply/msubsetP=> x; rewrite !msetE.
by rewrite leq_min !geq_min leqnn (msubsetP sAB) orbT.
Qed.

Lemma msetSI C A B : A `<=` B -> A `&` C `<=` B `&` C.
Proof. by move=> sAB; rewrite -!(msetIC C) msetIS. Qed.

Lemma msetISS A B C D : A `<=` C -> B `<=` D -> A `&` B `<=` C `&` D.
Proof. by move=> /(msetSI B) /msubset_trans sAC /(msetIS C) /sAC. Qed.

(* difference *)

Lemma msetSB C A B : A `<=` B -> A `\` C `<=` B `\` C.
Proof.
by move=> /msubsetP sAB; apply/msubsetP=> x; rewrite !msetE leq_sub2r.
Qed.

Lemma msetBS C A B : A `<=` B -> C `\` B `<=` C `\` A.
Proof.
by move=> /msubsetP sAB; apply/msubsetP=> x; rewrite !msetE leq_sub2l.
Qed.

Lemma msetBSS A B C D : A `<=` C -> D `<=` B -> A `\` B `<=` C `\` D.
Proof. by move=> /(msetSB B) /msubset_trans sAC /(msetBS C) /sAC. Qed.

Lemma msetB0 A : A `\` mset0 = A.
Proof. by apply/msetP=> x; rewrite !msetE subn0. Qed.

Lemma mset0B A : mset0 `\` A = mset0.
Proof. by apply/msetP=> x; rewrite !msetE sub0n. Qed.

Lemma msetBxx A : A `\` A = mset0.
Proof. by apply/msetP=> x; rewrite !msetE subnn. Qed.

(* other inclusions *)

Lemma msubsetIl A B : A `&` B `<=` A.
Proof. by apply/msubsetP=> x; rewrite msetE geq_minl. Qed.

Lemma msubsetIr A B : A `&` B `<=` B.
Proof. by apply/msubsetP=> x; rewrite msetE geq_minr. Qed.

Lemma msubsetDl A B : A `\` B `<=` A.
Proof. by apply/msubsetP=> x; rewrite msetE leq_subLR leq_addl. Qed.

Lemma msubD1set A x : A `\ x `<=` A.
Proof. by rewrite msubsetDl. Qed.

Hint Resolve msubsetIl msubsetIr msubsetDl msubD1set : core.

(* cardinal lemmas for msets *)

Lemma mem_mset1U a A : a \in A -> a |` A = A.
Proof.
rewrite in_mset => aA; apply/msetP => x; rewrite !msetE (maxn_idPr _) //.
by have [->|//] := altP eqP; rewrite (leq_trans _ aA).
Qed.

Lemma mem_msetD1 a A : a \notin A -> A `\ a = A.
Proof.
move=> /mset_eq0P aA; apply/msetP => x; rewrite !msetE.
by have [->|] := altP eqP; rewrite ?aA ?subn0.
Qed.

Lemma msetIn a A n : A `&` msetn n a = msetn (minn (A a) n) a.
Proof.
by apply/msetP => x; rewrite !msetE; have [->|] := altP eqP; rewrite ?minn0.
Qed.

Lemma msubIset A B C : (B `<=` A) || (C `<=` A) -> (B `&` C `<=` A).
Proof. by case/orP; apply: msubset_trans; rewrite (msubsetIl, msubsetIr). Qed.

Lemma msubsetI A B C : (A `<=` B `&` C) = (A `<=` B) && (A `<=` C).
Proof.
rewrite !(sameP msetIidPl eqP) msetIA; have [-> //| ] := altP (A `&` B =P A).
by apply: contraNF => /eqP <-; rewrite -msetIA -msetIIl msetIAC.
Qed.

Lemma msubsetIP A B C : reflect (A `<=` B /\ A `<=` C) (A `<=` B `&` C).
Proof. by rewrite msubsetI; exact: andP. Qed.

Lemma msubUset A B C : (B `|` C `<=` A) = (B `<=` A) && (C `<=` A).
Proof.
apply/idP/idP => [subA|/andP [AB CA]]; last by rewrite -[A]msetUid msetUSS.
by rewrite !(msubset_trans _ subA).
Qed.

Lemma msubUsetP A B C : reflect (A `<=` C /\ B `<=` C) (A `|` B `<=` C).
Proof. by rewrite msubUset; exact: andP. Qed.

Lemma msetU_eq0 A B : (A `|` B == mset0) = (A == mset0) && (B == mset0).
Proof. by rewrite -!msubset0 msubUset. Qed.

Lemma setD_eq0 A B : (A `\` B == mset0) = (A `<=` B).
Proof. by rewrite -msubset0 subset_msetBLR msetD0. Qed.

Lemma msub1set A a : ([mset a] `<=` A) = (a \in A).
Proof.
apply/msubsetP/idP; first by move/(_ a); rewrite msetnxx in_mset.
by move=> ainA b; rewrite msetnE; case: eqP => // ->; rewrite -in_mset.
Qed.

Lemma msetDBA A B C : C `<=` B -> A `+` B `\` C = (A `+` B) `\` C.
Proof.
by move=> /msubsetP CB; apply/msetP=> a; rewrite !msetE2 addnBA.
Qed.

Lemma mset_0Vmem A : (A = mset0) + {x : K | x \in A}.
Proof.
have [/fsetP Aisfset0 | [a ainA]] := fset_0Vmem (finsupp A); last first.
  by right; exists a; rewrite -msuppE.
left; apply/msetP => a; rewrite mset0E; apply/mset_eq0P.
by rewrite -msuppE Aisfset0 inE.
Qed.

Definition size_mset A : size A = \sum_(a <- finsupp A) A a.
Proof. by rewrite -sum1_size sum_mset; apply: eq_bigr => i; rewrite muln1. Qed.

Lemma size_mset0 : size (mset0 : {mset K}) = 0.
Proof. by rewrite -sum1_size big_mset0. Qed.

Lemma sum_nat_seq_eq0 (I : eqType) r (P : pred I) (E : I -> nat) :
   (\sum_(i <- r | P i) E i == 0) = all [pred i | P i ==> (E i == 0)] r.
Proof.
rewrite big_tnth sum_nat_eq0; apply/forallP/allP => /= HE x.
  by move=> /seq_tnthP[i ->]; apply: HE.
by apply: HE; rewrite mem_tnth.
Qed.

Lemma size_mset_eq0 A : (size A == 0) = (A == mset0).
Proof.
apply/idP/eqP => [|->]; last by rewrite size_mset0.
rewrite size_mset sum_nat_seq_eq0 => /allP AP.
apply/msetP => a /=; rewrite msetE.
by have /= := AP a; case: finsuppP => // _ /(_ _)/eqP->.
Qed.

End MSetTheory.


Require Import Coq.Unicode.Utf8.
Require Export StdlibMisc.

Local Coercion toBool : sumbool >->bool.

Require Export Arith.
Require Export Arith.EqNat.
Require Import Omega.

Definition Fin (n:nat)
  := sig (fun m => if lt_dec m n then True else False).

Lemma sdjflksdjsdlkf2: forall n mm: nat,
  (if lt_dec (S mm) n then True else False)
  -> (if lt_dec mm n then True else False).
Proof.
  intros.
  destruct (lt_dec (S mm) n) as [? | nlt]; [| contradiction].
  destruct (lt_dec mm n);trivial.
  omega.
Qed.

Lemma sdjflksdjsdlkf3: forall n mm: nat,
  (if lt_dec (S mm) (S n) then True else False)
  -> (if lt_dec mm n then True else False).
Proof.
  intros.
  destruct (lt_dec (S mm) (S n)) as [? | nlt]; [| contradiction].
  destruct (lt_dec mm n);trivial.
  omega.
Qed.

Lemma sdjflksdjsdlkf: forall n mm: nat,
  (if lt_dec mm n then True else False)
  -> (if lt_dec mm (S n) then True else False).
Proof.
  intros.
  destruct (lt_dec mm (S n)) as [? | nlt];[exact I |].
  destruct (lt_dec mm n);[| trivial].
  omega.
Qed.

Definition FinCast {n : nat} (m : Fin n) : Fin (S n).
  destruct m as [mm  Hlt].
  exists mm.
  apply sdjflksdjsdlkf. trivial.
Defined.

Coercion FinCast : Fin >-> Fin.

Lemma Fin_eq:
  ∀ (n: nat) (fa fb : Fin n),
    (proj1_sig fa) = (proj1_sig fb)
    → fa = fb.
Proof.
  intros ? ? ? Heq.
  destruct fa as [a ap].
  destruct fb as [b bp].
  simpl in Heq. simpl.
  subst.
  apply eq_existsT with (ea := eq_refl).
  remember (lt_dec b n); destruct s; destruct ap, bp; auto.
Qed.

Instance Fin_decidable : ∀ (n:nat),  DecEq (Fin n).
Proof.
  constructor.
  intros.
  destruct (NPeano.Nat.eq_dec (proj1_sig a) (proj1_sig b)) as [T|F];[left|right].
  - apply Fin_eq; auto.
  - intro Heq. destruct F. destruct a. destruct b.
    inversion Heq.  subst. simpl. reflexivity.
Defined.

(** never used since there might [A] often depends on [n] *)
Fixpoint toList {A : Type} (n : nat) (la : Fin n -> A) {struct n} : list A.
Abort.

Lemma lessThanLtDec: forall m n,
  m < n
  -> if lt_dec m n then True else False.
Proof.
  intros ? ? Hlt.
  destruct (lt_dec m n); auto.
Defined.

Definition f0 {A : Type}  (n : Fin 0) : A.
  destruct n as [nn pr]. contradiction.
Defined.

Definition fromList {A : Type} (la : list A): Fin (length la) -> A.
Proof.
  induction la; intro fn; destruct fn as [fnn pr];
    simpl in pr;[contradiction |].
  destruct (lt_dec fnn ((length la))) as [ltl |nltl].
  - apply IHla. exists fnn. apply lessThanLtDec; trivial.
  - exact a. (** outermost element has greatest index *)
Defined.

(*
Definition finFunCast {TA : Type} {n: nat} (fsn : Fin (S n) → TA)
  (fn : Fin n) : TA := (fsn fn).
*)

Definition N2Fin (n: nat) : Fin (S n).
exists n. unfold lt_dec.
destruct (le_dec (S n) (S n)) as [Hs | Hn];[exact I|].
apply Hn. constructor.
Defined.

Definition Fin2N {n : nat} (fn : Fin n): nat := proj1_sig fn.

Definition predF {n: nat} (fn : Fin n) : Fin n.
  destruct fn as [nn np].
  destruct nn.
- exists 0. trivial.
- exists nn. apply sdjflksdjsdlkf2. trivial.
Defined.

Definition mkFin (m n: nat) (p: if lt_dec m n then True else False) : Fin n:=
  exist _ m p.

Coercion N2Fin : nat >-> Fin.

Definition firstIndexSat {TA : Type} (pred: TA → bool) {n: nat}
    (fl: Fin n → TA) : option (Fin n).
induction n;[exact None|].
specialize (IHn fl).
destruct IHn as [sn|];[apply Some;  exact sn; fail|].
destruct (pred (fl n));[apply Some;  exact n; fail | exact None].
Defined.

Generalizable Variable TA.

Definition firstIndexEq `{DecEq TA} {n: nat}
    (fl: Fin n → TA) (a: TA): option (Fin n) :=
  firstIndexSat (λ p, p =?= a) fl.

Definition firstIndexPi1Eq `{DecEq TA} {B: Type} {n: nat}
    (fl: Fin n → (TA × B)) (a: TA): option (Fin n) :=
  firstIndexSat (λ p, (fst p) =?= a) fl.

Definition notNone {T : Type} (op : option T) : bool :=
match op with
| Some _ => true
| None => false
end.

Definition fnil {A : Fin 0 -> Type} (fn : Fin 0) : A fn.
destruct fn as [? Hc]. simpl in Hc. contradiction.
Defined.

(*
Definition FinSD {n:nat} (f : Fin (S n)) : (projT1 f = n) + {fp : Fin n | projT1 fp = projT1 f}.
induction n;[]
simpl.
*)


(** Proof Reflection in Coq ; check.v ; 050128 ; Dimitri Hendriks; Coq 8.0pl1 *)

Require Export subst.

Set Implicit Arguments.

Section checksec.

Variable l1 l2 : list nat.

Let T := trm l1.
Let Ts := trms l1.
Let F := frm l1 l2.
Let P := prf l1 l2.

Fixpoint check (G : list F) (h : P) {struct h} : opt F :=
  match h with
  | top_intro => val (top _ _)
  | hyp n => opt_nth n G
  | bot_elim h0 p =>
      match check G h0 with
      | val bot => val p
      | _ => err _
      end
  | imp_intro p h0 =>
      match check (p :: G) h0 with
      | val p0 => val (imp p p0)
      | _ => err _
      end
  | imp_elim h1 h2 =>
      match check G h1, check G h2 with
      | val (imp p p0), val p' => if frm_eqb p p' then val p0 else err _
      | _, _ => err _
      end
  | cnj_intro h1 h2 =>
      match check G h1, check G h2 with
      | val p1, val p2 => val (cnj p1 p2)
      | _, _ => err _
      end
  | cnj_elim1 h0 =>
      match check G h0 with
      | val (cnj p _) => val p
      | _ => err _
      end
  | cnj_elim2 h0 =>
      match check G h0 with
      | val (cnj _ p) => val p
      | _ => err _
      end
  | dsj_intro1 p h0 =>
      match check G h0 with
      | val p0 => val (dsj p0 p)
      | _ => err _
      end
  | dsj_intro2 p h0 =>
      match check G h0 with
      | val p0 => val (dsj p p0)
      | _ => err _
      end
  | dsj_elim h0 h1 h2 =>
      match check G h0 with
      | val (dsj p1 p2) =>
          match check (p1 :: G) h1, check (p2 :: G) h2 with
          | val c, val c' => if frm_eqb c c' then val c else err _
          | _, _ => err _
          end
      | _ => err _
      end
  | uvq_intro h0 =>
      match check (lift_cxt 0 G) h0 with
      | val p => val (uvq p)
      | _ => err _
      end
  | uvq_elim t h0 =>
      match check G h0 with
      | val (uvq p) => val (subst_frm 0 p t)
      | _ => err _
      end
  | exq_intro p t h0 =>
      match check G h0 with
      | val q => if frm_eqb (subst_frm 0 p t) q then val (exq p) else err _
      | _ => err _
      end
  | exq_elim h1 h2 =>
      match check G h1 with
      | val (exq q) =>
          match check (q :: lift_cxt 0 G) h2 with
          | val r => if free_inb_frm 0 r then err _ else val (proj_frm 0 r)
          | _ => err _
          end
      | _ => err _
      end
  end.

End checksec.


Require Export PTS.
Require Import CR.
Require Import Meta.

Axiom func_ax : forall (s t t' : sort), axiom s t -> axiom s t' -> t = t'.
Axiom func_rule : forall (s1 s2 s3 s3' : sort), rule s1 s2 s3 -> rule s1 s2 s3' -> s3 = s3'.

Theorem Unique_Types :
  forall n (M : term n) Gamma A B, Gamma |- M ; A -> Gamma |- M ; B -> A ~= B.
Proof.
  induction M; intros.
(* Variable f *)
  apply conv_trans with (typeof f Gamma).
   apply conv_sym.
     apply Gen_var.
     assumption.
   apply Gen_var.
     assumption.
(* Sort s *)
  elim Gen_srt with n Gamma s A.
   intro t.
     destruct 1.
     elim Gen_srt with n Gamma s B.
      intro t'.
        destruct 1.
	apply conv_trans with (srt (n:=n) t).
	 apply conv_red.
	   assumption.
	 rewrite func_ax with s t t'; auto.
	   apply conv_sym.
	   apply conv_red.
	   assumption.
      assumption.
   assumption.
(* Application *)
   elim Gen_app with n Gamma M1 M2 A.
    intro C.
      destruct 1.
      rename x into D.
      destruct H1.
      destruct H2.
      elim Gen_app with n Gamma M1 M2 B.
       intro C'.
         destruct 1.
	 rename x into D'.
	 destruct H4.
	 destruct H5.
	 apply conv_trans with (subbot D M2).
	  assumption.
	  apply conv_trans with (subbot D' M2).
	   apply conv_subbot.
	    apply conv_pi_injr with C C'.
	      apply IHM1 with Gamma; assumption.
	    apply conv_ref.
           apply conv_sym.
	     assumption.
       assumption.
    assumption.
(* Product *)
   elim Gen_pi with n Gamma M1 M2 A.
    intro s1.
      destruct 1.
      rename x into s2.
      destruct H1.
      rename x into s3.
      destruct H1.
      destruct H2.
      destruct H3.
      elim Gen_pi with n Gamma M1 M2 B.
       intro t1.
         destruct 1.
	 rename x into t2.
	 destruct H5.
	 rename x into t3.
	 destruct H5.
	 destruct H6.
	 destruct H7.
	 apply conv_trans with (srt (n:=n) s3).
	  apply conv_red.
	    assumption.
	  rewrite func_rule with s1 s2 s3 t3.
	   apply conv_sym.
	     apply conv_red.
	     assumption.
	   assumption.
	   rewrite conv_srt_inj with n s1 t1.
	    rewrite conv_srt_inj with (S n) s2 t2.
	     assumption.
	     apply IHM2 with (Gamma, M1); assumption.
	     apply IHM1 with Gamma; assumption.
       assumption.
    assumption.
(* Abstraction *)
   elim Gen_lda with n Gamma M1 M2 A.
    intro C.
      destruct 1.
      rename x into s3.
      destruct H1.
      destruct H2.
      elim Gen_lda with n Gamma M1 M2 B.
       intro C'.
         destruct 1.
	 rename x into t3.
	 destruct H4.
	 destruct H5.
	 apply conv_trans with (pi M1 C).
	  assumption.
	  apply conv_trans with (pi M1 C').
	   apply conv_pi.
	    apply conv_ref.
	    apply IHM2 with (Gamma, M1); assumption.
	   apply conv_sym.
	     assumption.
       assumption.
    assumption.
Qed.


From Mtac2 Require Import Mtac2 CompoundTactics.

Import T.
Import T.notations.
Import CT.
Import CT.notations.
Example exabs (x : nat) : x = 1 -> 1 = x.
MProof.
intro H.
simple_rewrite H.
reflexivity.
Qed.

Example exabs2 (x : nat) : S x = 1 -> 1 = S x.
MProof.
intro H.
simple_rewrite H.
reflexivity.
Qed.

Require Import Strings.String.
Example exabs2' (x : nat) : S x = 1 -> 1 = S x.
MProof.
intro H.
variabilize (S x) as t.
assert (B:t = S x).
reflexivity.
Abort.

Require Import Arith.

Example exif (x : nat) : if beq_nat (S x) 1 then x = 0 : Type else True.
MProof.
variabilize (beq_nat (S x) (S 0)) as t.
assert (B:t = beq_nat (S x) 1).
reflexivity.
Abort.

Definition sillyfun (n : nat) : bool :=
  if beq_nat n 3 then false
  else if beq_nat n 5 then false
  else false.

Theorem sillyfun_false : forall (n : nat),
  (sillyfun n = false) : Type.
MProof.
  intros n. unfold sillyfun.
  variabilize (beq_nat n 3) as t3.
  destruct t3.
  simpl. reflexivity.
  simpl.
  variabilize (beq_nat _ _) as t5.
  destruct t5 &> reflexivity.
Qed.

Definition sillyfun1 (n : nat) : bool :=
  if beq_nat n 3 then true
  else if beq_nat n 5 then true
  else false.

Fixpoint evenb (n:nat) : bool :=
  match n with
  | O        => true
  | S O      => false
  | S (S n') => evenb n'
  end.

Definition oddb (n:nat) : bool   :=   negb (evenb n).

Theorem sillyfun1_odd : forall (n : nat),
     (sillyfun1 n = true ->
     oddb n = true) : Type .
MProof.
  intros n. unfold sillyfun1.
  variabilize (beq_nat n 3) as t.
  assert (Heqe3 : t = (n =? 3)%nat) |1> reflexivity.
  move_back Heqe3.
  destruct t &> intro Heqe3.
Abort.


Welcome to Coq ciosx:/builds/workspace/coq-8.5pl3-macos,(detached from 2290dbb) (2290dbb9c95b63e693ced647731623e64297f5c8)

Coq < Module Playground2.
Interactive Module Playground2 started

Coq < Require Import Arith Classical.
[Loading ML file z_syntax_plugin.cmxs ... done]
[Loading ML file quote_plugin.cmxs ... done]
[Loading ML file newring_plugin.cmxs ... done]
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked

Coq < Fixpoint plus (n : nat) (m : nat) : nat := match n with | O => m | S n' => S (plus n' m) end.
plus is defined
plus is recursively defined (decreasing on 1st argument)

Coq < Compute (plus 3 2).
     = 5
     : nat

Coq < Compute (plus 1 7).
     = 8
     : nat


Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.
Require Import Coq.NArith.NArith.
Require Import Coq.ZArith.ZArith.
Require Import Printf.Scanf.

Local Open Scope string_scope.

Definition ret {A B : Type} (a : A) (_ : B) : option A := Some a.

Goal sscanf "Hello, %s" ret "Hello, world!" = Some "world!".
Proof.
  reflexivity.
Qed.

Goal sscanf "%d, %d, %d, ..." (fun a b c _ => Some (a, b, c)) "1, 2, 3, ..."
  = Some (1, 2, 3).
Proof.
  reflexivity.
Qed.

Goal sscanf "%d%%" ret "100%" = Some 100.
Proof.
  reflexivity.
Qed.

Goal sscanf "%c" ret "x" = Some "x"%char.
Proof.
  reflexivity.
Qed.

Goal sscanf "%o" ret "2322" = Some 1234.
Proof.
  reflexivity.
Qed.

Goal sscanf "%x" ret "4d2" = Some 1234.
Proof.
  reflexivity.
Qed.

Goal sscanf "%X" ret "4D2" = Some 1234.
Proof.
  reflexivity.
Qed.

Goal sscanf "%b" ret "10011010010" = Some 1234.
Proof.
  reflexivity.
Qed.

Goal sscanf "%Nd" ret "1234" = Some 1234%N.
Proof.
  reflexivity.
Qed.

Goal sscanf "%NX" ret "4D2" = Some 1234%N.
Proof.
  reflexivity.
Qed.

Goal sscanf "%Nx" ret "4d2" = Some 1234%N.
Proof.
  reflexivity.
Qed.

Goal sscanf "%Zd" ret "1234" = Some 1234%Z.
Proof.
  reflexivity.
Qed.

Goal sscanf "%Zd" ret "-1234" = Some (-1234)%Z.
Proof.
  reflexivity.
Qed.

Goal sscanf "%Zd" ret "+1234" = Some 1234%Z.
Proof.
  reflexivity.
Qed.

Goal sscanf "%o, %x, %X, %b, ..."
            (fun a b c d _ => Some (a, b, c, d))
            "2322, 4d2, 4D2, 10011010010, ..."
  = Some (1234, 1234, 1234, 1234).
Proof.
  reflexivity.
Qed.

Goal sscanf " %3X" (fun n s => Some (n, s)) " 4D2ABC" = Some (1234, "ABC").
Proof.
  reflexivity.
Qed.

Goal sscanf "%5X" (fun n s => Some (n, s)) "004D21" = Some (1234, "1").
Proof.
  reflexivity.
Qed.

Goal sscanf "%d" ret "+1234" = Some 1234.
Proof.
  reflexivity.
Qed.

Goal sscanf "%X" ret "0X4D2" = Some 1234.
Proof.
  reflexivity.
Qed.

Goal sscanf "%x" ret "0x4d2" = Some 1234.
Proof.
  reflexivity.
Qed.

Goal sscanf "%Zd" ret "-32" = Some (-32)%Z.
Proof.
  reflexivity.
Qed.


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

  An attempt at a variable module in a context.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.
Require Import Coq.Bool.Bool.

Require Export BoolEqualitySigDef.

Add LoadPath "/home/milnes/Desktop/Research/Cyclone/CycloneCoq/3".
Require Export CpdtTactics.
Require Export Case.
Require Export NatLemmas.

Module KappaModule <: BoolEqualitySig.

Inductive Kappa : Type :=
 | B                         (* 'boxed' kind. *)
 | A.                        (* 'any'   kind. *)

Definition T := Kappa.

Function beq_kappa (k k' : Kappa) : bool :=
   match k, k' with
     |  A, A => true
     |  B, B => true
     |  _, _ => false
  end.

Definition beq_t := beq_kappa.

Lemma beq_kappa_refl:
  forall (k : Kappa),
    beq_kappa k k = true.
Proof.
  destruct k.
  reflexivity.
  reflexivity.
Qed.
Hint Resolve beq_kappa_refl.
Definition beq_t_refl := beq_kappa_refl.

Lemma beq_kappa_sym : forall x y : Kappa, beq_kappa x y = beq_kappa y x.
Proof.
  intros.
  destruct x;  destruct y; crush.
Qed.
Hint Immediate beq_kappa_sym.
Definition beq_t_sym := beq_kappa_sym.

Lemma beq_kappa_trans :
  forall x y z,
    beq_kappa x y = true -> beq_kappa y z = true -> beq_kappa x z = true.
Proof.
   destruct x; destruct y; destruct z; crush.
Qed.
Hint Resolve beq_kappa_trans.
Definition beq_t_trans := beq_kappa_trans.

Lemma beq_kappa_eq:
  forall (k k': Kappa),
    beq_kappa k k' = true ->
    k = k'.
Proof.
  intros.
  destruct k; destruct k'.
  reflexivity.
  inversion H.
  inversion H.
  reflexivity.
Qed.
Hint Resolve beq_kappa_eq.
Definition beq_t_eq := beq_kappa_eq.

Lemma beq_kappa_neq:
  forall (k k': Kappa),
    beq_kappa k k' = false ->
    k <> k'.
Proof.
  intros.
  destruct k; destruct k'.
  inversion H.
  discriminate.
  discriminate.
  inversion H.
Qed.
Hint Resolve beq_kappa_neq.
Definition beq_t_neq := beq_kappa_neq.

End KappaModule.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo79:
  prime  208870589->
  prime  1405283683061.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      1405283683061
      6728
      ((208870589,1)::nil)
      1405283683025
      0
      12
      36)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.