Require Export CatSem.CAT.retype_functor_po.
Require Export CatSem.CAT.rmonad_gen_type_po.
Require Export CatSem.CAT.TLC_types.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Definition TY := TLC.types.

Notation "'IP'" := (IPO TY).
Notation "a '~>' b" := (TLC.arrow a b)
   (at level 69, right associativity).
Notation "a 'x' b" := (product a b) (at level 30).
Notation "M [ z ]" := (FIB_RMOD _ z M) (at level 35).
Notation "'d' M // s" := (DER_RMOD _ _ s M) (at level 25).
Notation "'*'" := (Term (C:=RMOD _ PO)).

Notation "f 'X' g" := (product_mor _ f g)(at level 30).

Notation "'FM'" := (#(FIB_RMOD _ _ )).
Notation "'FPB'":= (FIB_RPB _ _ _ ).
Notation "'PRPB'":= (PROD_RPB _ _ _ _ ).
(*Notation "'PBF'":= (PB_FIB _ _ _ ).*)
Notation "'PBM'":= (#(PbRMOD _ _ )).
Notation "'DM'":= (#(DER_RMOD _ _ _ )).
Notation "'DPB'":= (DER_RPB _ _ _ ).

Notation "y [* := z ]":= (Rsubstar z _ y)(at level 55).

Section TLC_rep.

Variable U : Type.
Variable P : RMonad (SM_ipo U).
Variable f : TY -> U.

(** a monad is a representation if it is accompagnied by
    - a lot of morphisms of modules
    - beta-reduction
*)

Class TLCPO_rep_struct := {
  App : forall r s, (P[f (r~>s)]) x (P[f r]) ---> P[f s];
  Abs : forall r s, (d P //(f r))[f s] ---> P[f (r ~> s)];

  beta_red : forall r s V y z,
        App r s V (Abs r s V y, z) << y[*:= z] ;

  propag_App1: forall r s V y y' z,
        y << y' -> App r s V (y,z) << App _ _ _ (y',z) ;

  propag_App2: forall r s V y z z',
        z << z' -> App r s V (y,z) << App _ _ _ (y,z') ;

  propag_Abs: forall r s V y y',
        y << y' -> Abs r s V y << Abs _ _ _ y'
 }.

End TLC_rep.

Record TLCPO_rep := {
  type_type : Type;
  tlc_rep_monad :> RMonad (SM_ipo type_type);
  type_mor : TY -> type_type;
  tlc_rep_struct :> TLCPO_rep_struct tlc_rep_monad type_mor
}.

Existing Instance tlc_rep_struct.

(** morphisms of representations *)

Section rep_hom.

Variables P R : TLCPO_rep.

Section Rep_Hom_Class.

(** a morphism of representations
        - (U, f, P, Rep)
        - (U', f', Q, Rep')
   is given by
        - g : U -> U'
        - H : f ; g = f'
        - generalized monad morphism P -> Q (with F = RETYPE g)
        - properties
*)

Variable f : type_type P -> type_type R.
Variable H : forall t, f (type_mor P t) = type_mor R t.
Check gen_RMonad_Hom.
Variable M : gen_RMonad_Hom P R
    (G1:=RETYPE f)
    (G2:=RETYPE_PO f) (NNNT1 f).

Definition MM := gen_PbRMod_ind_Hom M.
Check FFib_Mod_Hom. Check FIB_RMOD_HOM.
Print FIB_RMOD_eq.
Check (fun r s => FIB_RMOD_eq (gen_PbRMod M R) (H (r ~> s))).
Check (fun r s => App (P:=P) r s ;;
                  FIB_RMOD_HOM M _  ).
Check (fun r s => App (P:=P) r s ;;
                  FIB_RMOD_HOM M _  ;;
                  FIB_RMOD_eq (gen_PbRMod M R) (H _) ;;
                  gen_pb_fib _ _ _ ).

Check (fun r s =>
           product_mor _
             (FIB_RMOD_HOM M (type_mor _ (r~>s)) ;;
              FIB_RMOD_eq _ (H _ );;
              gen_pb_fib _ _ _ )
             (FIB_RMOD_HOM M (type_mor _ r) ;;
              FIB_RMOD_eq _ (H _ );;
              gen_pb_fib _ _ _ )
            ;;
           gen_PROD_PM _ _ _ _
            ;;
           gen_PbRMod_Hom _ (App r s)).

Check FFib_DER_Mod_Hom_eqrect.
Check der_fib_hom.

Check (fun r  s => der_fib_hom _ _ (H _ ) ;;
                  FIB_RMOD_eq _ (H s);;
                  gen_pb_fib _ _ _ ;;
                  gen_PbRMod_Hom M (Abs r s)).

Check (fun r s => Abs r s ;;
                  FIB_RMOD_HOM M _ ;;
                  FIB_RMOD_eq _ (H _ );;
                  gen_pb_fib _ _ _ ).

Class TLCPO_rep_Hom_struct := {
  App_Hom : forall r s,
          App (P:=P) r s ;;
                  FIB_RMOD_HOM M _  ;;
                  FIB_RMOD_eq (gen_PbRMod M R) (H _) ;;
                  gen_pb_fib _ _ _
              ==
          product_mor _
             (FIB_RMOD_HOM M (type_mor _ (r~>s)) ;;
              FIB_RMOD_eq _ (H _ );;
              gen_pb_fib _ _ _ )
             (FIB_RMOD_HOM M (type_mor _ r) ;;
              FIB_RMOD_eq _ (H _ );;
              gen_pb_fib _ _ _ )
            ;;
           gen_PROD_PM _ _ _ _
            ;;
           gen_PbRMod_Hom _ (App r s)
;
  Abs_Hom : forall r s,
       der_fib_hom _ _ (H _ ) ;;
                  FIB_RMOD_eq _ (H s);;
                  gen_pb_fib _ _ _ ;;
                  gen_PbRMod_Hom M (Abs r s)
       ==
       Abs r s ;;
                  FIB_RMOD_HOM M _ ;;
                  FIB_RMOD_eq _ (H _ );;
                  gen_pb_fib _ _ _
}.

End Rep_Hom_Class.

(** the type of morphismes of representations P -> R *)

Record TLCPO_rep_Hom := {
  tcomp : type_type P -> type_type R ;
  ttriag : forall t, tcomp (type_mor P t) = type_mor R t;
  rep_Hom_monad :> gen_RMonad_Hom P R (NNNT1 tcomp);
  rep_gen_Hom_monad_struct :> TLCPO_rep_Hom_struct ttriag rep_Hom_monad
}.

End rep_hom.

Existing Instance rep_gen_Hom_monad_struct.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                             Lemmas_on_fcts.v                             *)
(****************************************************************************)

Require Import Bool_Compl.
Require Import SuccessfulInput.
Require Import Base_Struct.

Set Implicit Arguments.
Unset Strict Implicit.

Lemma Ackor_true_RequestsToArbitrate :
 forall l : d_list bool 4,
 Ackor l = true ->
 {b : T_Inportno 4 &
 {l' : list (T_Inportno 4) | RequestsToArbitrate l = b :: l'}}.

intros l.
elim (non_empty l).
intros x0 X0; elim X0.
clear X0; intros X0 H0.
rewrite H0.
unfold Ackor in |- *; unfold RequestsToArbitrate in |- *.
unfold Fold_with_f_S in |- *; simpl in |- *.
case x0; simpl in |- *.
intros H; clear H.
exists (exist (fun p : nat => p < 4) 0 lt_O_4).
exists
 (test_port (Scd_of_l4 (d_cons true X0))
    (exist (fun p : nat => p < 4) 1 lt_1_4) ++
  test_port (Thd_of_l4 (d_cons true X0))
    (exist (fun p : nat => p < 4) 2 lt_2_4) ++
  test_port (Fth_of_l4 (d_cons true X0))
    (exist (fun p : nat => p < 4) 3 lt_3_4)); auto.
unfold Scd_of_l4 in |- *; simpl in |- *.
case (d_Head X0); simpl in |- *.
intro H; clear H.
exists (exist (fun p : nat => p < 4) 1 lt_1_4).
exists
 (test_port (Thd_of_l4 (d_cons false X0))
    (exist (fun p : nat => p < 4) 2 lt_2_4) ++
  test_port (Fth_of_l4 (d_cons false X0))
    (exist (fun p : nat => p < 4) 3 lt_3_4)); auto.
unfold Thd_of_l4 in |- *; simpl in |- *.
case (d_Head (d_tl X0)); simpl in |- *.
intro H; clear H.
exists (exist (fun p : nat => p < 4) 2 lt_2_4).
exists
 (test_port (Fth_of_l4 (d_cons false X0))
    (exist (fun p : nat => p < 4) 3 lt_3_4)); auto.
unfold Fth_of_l4 in |- *; simpl in |- *.
elim (non_empty X0).
intros x X; elim X; clear X.
intros X HX; rewrite HX; simpl in |- *.
case (d_Head (d_tl X)); simpl in |- *.
intros H; clear H.
exists (exist (fun p : nat => p < 4) 3 lt_3_4).
exists (nil (A:=T_Inportno 4)); auto.
intros Abs; absurd (false = true); auto.
Qed.

Lemma RoundRobinArbiter_simpl :
 forall l : d_list bool 4,
 Ackor l = true ->
 RoundRobinArbiter (list_dlist (RequestsToArbitrate l)) =
 RoundRobin 4 (list_dlist (RequestsToArbitrate l)).
intros l H.
elim (Ackor_true_RequestsToArbitrate H).
intros x H'; elim H'; clear H'.
intros X H'.
rewrite H'.
auto.
Qed.

(*****************************************************************************)

Definition SM4 := SUC_MODN (i:=4).

Lemma lt_4_4cases :
 forall n : nat, n < 4 -> {n = 0} + {n = 1} + {n = 2} + {n = 3}.
simple induction n; auto.
clear n; intros n H_rec H; elim H_rec.
intro H1; elim H1.
intro H2; elim H2.
auto.
auto.
auto.
intros H'; generalize H; rewrite H'.
intros Abs; absurd (4 < 4); auto with arith.
auto with arith.
Qed.

Lemma eq_n_SM4_4_times :
 forall n : T_Inportno 4, no_in n = no_in (SM4 (SM4 (SM4 (SM4 n)))).
simple destruct n.
clear n.
intros n lt_4.
generalize lt_4.
unfold SM4 in |- *; unfold SUC_MODN at 4 in |- *; simpl in |- *.
elim (lt_4_4cases (n:=n)).
intro H; elim H.
clear H; intro H; elim H.

       (** Port 0**)

clear H.
intro H.
rewrite H.
intro H'.
elim (less_or_eq (exist (fun x : nat => x < 4) 0 H')); simpl in |- *.
intro y.
unfold SUC_MODN at 3 in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun n0 : nat => n0 < 4) 1 y)); simpl in |- *.
intro y1.
unfold SUC_MODN at 2 in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun n0 : nat => n0 < 4) 2 y1)); simpl in |- *.
intro y2.
unfold SUC_MODN in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun n0 : nat => n0 < 4) 3 y2)); simpl in |- *.
intro y'; absurd (4 < 4); auto with arith.
 intro y'.
auto.
intro y'; absurd (3 = 4); auto with arith.
intro y'; absurd (2 = 4); auto with arith.
intro y'; absurd (1 = 4); auto.

       (** Port 1**)

clear H.
intros H; rewrite H; intros H'.
elim (less_or_eq (exist (fun x : nat => x < 4) 1 H')); simpl in |- *.
intro y.
unfold SUC_MODN at 3 in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun n0 : nat => n0 < 4) 2 y)); simpl in |- *.
intro y1.
unfold SUC_MODN at 2 in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun n0 : nat => n0 < 4) 3 y1)); simpl in |- *.
intro y2; absurd (4 < 4); auto with arith.
intros y2.
unfold SUC_MODN in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun n0 : nat => n0 < 4) 0 (Ex_n_lt_gen y2)));
 simpl in |- *.
auto.
intro y3; absurd (1 = 4); auto.
intro y1; absurd (3 = 4); auto.
intro y; absurd (2 = 4); auto.

       (** Port 2**)

clear H.
intros H; rewrite H; intros H'.
elim (less_or_eq (exist (fun x : nat => x < 4) 2 H')); simpl in |- *.
intro y.
unfold SUC_MODN at 3 in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun n0 : nat => n0 < 4) 3 y)); simpl in |- *.
intros y1; absurd (4 < 4); auto with arith.
intro y1.
unfold SUC_MODN at 2 in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun n0 : nat => n0 < 4) 0 (Ex_n_lt_gen y1)));
 simpl in |- *.
intro y2.
unfold SUC_MODN in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 1 y2)); simpl in |- *.
auto.
intro y3; absurd (2 = 4); auto.
intro y2; absurd (1 = 4); auto.
intro y; absurd (3 = 4); auto.

       (** Port 3**)

intro H; rewrite H; intro H'.
elim (less_or_eq (exist (fun x : nat => x < 4) 3 H')); simpl in |- *.
intro y.
absurd (4 < 4); auto with arith.
intro y.
unfold SUC_MODN at 3 in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun n0 : nat => n0 < 4) 0 (Ex_n_lt_gen y)));
 simpl in |- *.
intro y1.
unfold SUC_MODN at 2 in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun n0 : nat => n0 < 4) 1 y1)); simpl in |- *.
intro y2.
unfold SUC_MODN in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun n0 : nat => n0 < 4) 2 y2)); simpl in |- *.
auto.
intro y3; absurd (3 = 4); auto.
intro y2; absurd (2 = 4); auto.
intro y1; absurd (1 = 4); auto.
trivial.
Qed.

(*****************************************************************************)

Lemma d_In_SUC0_l2 :
 forall l : d_list bool 4,
 d_In (no_in (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4)))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Scd_of_l4 l = true.
replace (no_in (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4))) with 1.
intros l.
elim (non_empty l).
intros x0 X0; elim X0; clear X0.
intros X0 H.
elim (non_empty X0).
intros x1 X1; elim X1; clear X1.
intros X1 H1.
elim (non_empty X1).
intros x2 X2; elim X2; clear X2.
intros X2 H2.
elim (non_empty X2).
intros x3 X3; elim X3; clear X3.
intros X3 H3.
rewrite H; rewrite H1; rewrite H2; rewrite H3.
unfold Scd_of_l4 in |- *; simpl in |- *.
unfold RequestsToArbitrate in |- *.
unfold Fst_of_l4 in |- *; unfold Scd_of_l4 in |- *; unfold Thd_of_l4 in |- *;
 unfold Fth_of_l4 in |- *; simpl in |- *.
elim x1; simpl in |- *; auto.
elim x0; elim x2; elim x3; simpl in |- *.
intro H'.
elim H'; clear H'.
intros Abs.
absurd (0 = 1); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (2 = 1); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (3 = 1); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (0 = 1); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (2 = 1); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (0 = 1); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (3 = 1); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (0 = 1); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (2 = 1); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (2 = 1); auto.
absurd (3 = 1); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (2 = 1); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intro Abs; absurd (3 = 1); auto.
intros Abs; absurd False; auto.
intros Abs; absurd False; auto.
unfold SUC_MODN in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 0 lt_O_4)); simpl in |- *;
 auto.
intros Abs; absurd (1 = 4); auto.
Qed.

Lemma not_d_In_SUC0_l2 :
 forall l : d_list bool 4,
 ~
 d_In (no_in (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4)))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Scd_of_l4 l = false.
replace (no_in (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4))) with 1.
intros l.
elim (non_empty l).
intros x0 X0; elim X0; clear X0.
intros X0 H.
elim (non_empty X0).
intros x1 X1; elim X1; clear X1.
intros X1 H1.
elim (non_empty X1).
intros x2 X2; elim X2; clear X2.
intros X2 H2.
elim (non_empty X2).
intros x3 X3; elim X3; clear X3.
intros X3 H3.
rewrite H; rewrite H1; rewrite H2; rewrite H3.
unfold Scd_of_l4 in |- *; simpl in |- *.
unfold RequestsToArbitrate in |- *.
unfold Fst_of_l4 in |- *; unfold Scd_of_l4 in |- *; unfold Thd_of_l4 in |- *;
 unfold Fth_of_l4 in |- *; simpl in |- *.
elim x1; simpl in |- *; auto.
elim x0; elim x2; elim x3; simpl in |- *.
intro H'.
elim H'; clear H'.
right; auto.
intros H'; elim H'; clear H'.
right; auto.
intros H'; elim H'; clear H'.
right; auto.
intros H'; elim H'; clear H'.
right; auto.
intros H'; elim H'; clear H'.
auto.
intros H'; elim H'; clear H'.
auto.
intros H'; elim H'; clear H'.
auto.
intros H'; elim H'; clear H'.
auto.
unfold SUC_MODN in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 0 lt_O_4)); simpl in |- *;
 auto.
intros Abs; absurd (1 = 4); auto.
Qed.

Lemma d_In_SUC1_l3 :
 forall l : d_list bool 4,
 d_In (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4))))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Thd_of_l4 l = true.
replace (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4))))
 with 2.
intros l.
elim (non_empty l).
intros x0 X0; elim X0; clear X0.
intros X0 H.
elim (non_empty X0).
intros x1 X1; elim X1; clear X1.
intros X1 H1.
elim (non_empty X1).
intros x2 X2; elim X2; clear X2.
intros X2 H2.
elim (non_empty X2).
intros x3 X3; elim X3; clear X3.
intros X3 H3.
rewrite H; rewrite H1; rewrite H2; rewrite H3.
unfold Thd_of_l4 in |- *; simpl in |- *.
unfold RequestsToArbitrate in |- *.
unfold Fst_of_l4 in |- *; unfold Scd_of_l4 in |- *; unfold Thd_of_l4 in |- *;
 unfold Fth_of_l4 in |- *; simpl in |- *.
elim x2; simpl in |- *; auto.
elim x0; elim x1; elim x3; simpl in |- *.
intros H'; elim H'; clear H'.
intros Abs; absurd (0 = 2); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (2 = 1); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (3 = 1); auto.
absurd (3 = 2); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (0 = 1); auto.
absurd (0 = 2); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (2 = 1); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (0 = 2); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (3 = 2); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (0 = 2); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (2 = 1); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (3 = 2); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (2 = 1); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intro Abs; absurd (3 = 2); auto.
intros Abs; absurd False; auto.
intros Abs; absurd False; auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 0 lt_O_4)); simpl in |- *.
intro a.
elim (less_or_eq (exist (fun n : nat => n < 4) 1 a)); simpl in |- *.
auto.
intros Abs; absurd (2 = 4); auto.
intro b.
elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen b)));
 simpl in |- *.
absurd (1 = 4); auto.
absurd (1 = 4); auto.
Qed.

Lemma not_d_In_SUC1_l3 :
 forall l : d_list bool 4,
 ~
 d_In (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4))))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Thd_of_l4 l = false.
replace (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4))))
 with 2.
intros l.
elim (non_empty l).
intros x0 X0; elim X0; clear X0.
intros X0 H.
elim (non_empty X0).
intros x1 X1; elim X1; clear X1.
intros X1 H1.
elim (non_empty X1).
intros x2 X2; elim X2; clear X2.
intros X2 H2.
elim (non_empty X2).
intros x3 X3; elim X3; clear X3.
intros X3 H3.
rewrite H; rewrite H1; rewrite H2; rewrite H3.
unfold Thd_of_l4 in |- *; simpl in |- *.
unfold RequestsToArbitrate in |- *.
unfold Fst_of_l4 in |- *; unfold Scd_of_l4 in |- *; unfold Thd_of_l4 in |- *;
 unfold Fth_of_l4 in |- *; simpl in |- *.
elim x2; simpl in |- *; auto.
elim x0; elim x1; elim x3; simpl in |- *.
intro H'.
elim H'; clear H'.
right; right; auto.
intros H'; elim H'; clear H'.
right; right; auto.
intros H'; elim H'; clear H'.
right; auto.
intros H'; elim H'; clear H'.
right; auto.
intros H'; elim H'; clear H'.
right; auto.
intros H'; elim H'; clear H'.
right; auto.
intros H'; elim H'; clear H'.
auto.
intros H'; elim H'; clear H'.
auto.
unfold SUC_MODN in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 0 lt_O_4)); simpl in |- *.
intro a.
elim (less_or_eq (exist (fun n : nat => n < 4) 1 a)); simpl in |- *.
auto.
intros Abs; absurd (2 = 4); auto.
intro b.
elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen b)));
 simpl in |- *.
absurd (1 = 4); auto.
absurd (1 = 4); auto.
Qed.

Lemma d_In_SUC2_l4 :
 forall l : d_list bool 4,
 d_In
   (no_in
      (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4)))))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Fth_of_l4 l = true.
replace
 (no_in
    (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4)))))
 with 3.
intros l.
elim (non_empty l).
intros x0 X0; elim X0; clear X0.
intros X0 H.
elim (non_empty X0).
intros x1 X1; elim X1; clear X1.
intros X1 H1.
elim (non_empty X1).
intros x2 X2; elim X2; clear X2.
intros X2 H2.
elim (non_empty X2).
intros x3 X3; elim X3; clear X3.
intros X3 H3.
rewrite H; rewrite H1; rewrite H2; rewrite H3.
unfold Fth_of_l4 in |- *; simpl in |- *.
unfold RequestsToArbitrate in |- *.
unfold Fst_of_l4 in |- *; unfold Scd_of_l4 in |- *; unfold Thd_of_l4 in |- *;
 unfold Fth_of_l4 in |- *; simpl in |- *.
elim x3; simpl in |- *; auto.
elim x0; elim x1; elim x2; simpl in |- *.
intros H'; elim H'; clear H'.
intros Abs; absurd (0 = 3); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (3 = 1); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (3 = 2); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (0 = 3); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (3 = 1); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (0 = 3); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (3 = 2); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (3 = 2); auto.
elim Abs; clear Abs; intros Abs.
absurd (0 = 3); auto.
absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (3 = 1); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (3 = 2); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (3 = 1); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (3 = 2); auto.
intros Abs; absurd False; auto.
intros Abs; absurd False; auto.
unfold SUC_MODN in |- *; simpl in |- *.
 elim (less_or_eq (exist (fun p : nat => p < 4) 0 lt_O_4)); simpl in |- *.
intro a.
elim (less_or_eq (exist (fun n : nat => n < 4) 1 a)); simpl in |- *.
intro a0; elim (less_or_eq (exist (fun n : nat => n < 4) 2 a0)).
simpl in |- *; auto.
simpl in |- *.
intros Abs; absurd (3 = 4); auto.
intro b.
elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen b)));
 simpl in |- *.
absurd (2 = 4); auto.
absurd (1 = 4); auto.
absurd (2 = 4); auto.
intro Abs; absurd (1 = 4); auto.
Qed.

Lemma not_d_In_SUC2_l4 :
 forall l : d_list bool 4,
 ~
 d_In
   (no_in
      (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4)))))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Fth_of_l4 l = false.
replace
 (no_in
    (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4)))))
 with 3.
intros l.
elim (non_empty l).
intros x0 X0; elim X0; clear X0.
intros X0 H.
elim (non_empty X0).
intros x1 X1; elim X1; clear X1.
intros X1 H1.
elim (non_empty X1).
intros x2 X2; elim X2; clear X2.
intros X2 H2.
elim (non_empty X2).
intros x3 X3; elim X3; clear X3.
intros X3 H3.
rewrite H; rewrite H1; rewrite H2; rewrite H3.
unfold Fth_of_l4 in |- *; simpl in |- *.
unfold RequestsToArbitrate in |- *.
unfold Fst_of_l4 in |- *; unfold Scd_of_l4 in |- *; unfold Thd_of_l4 in |- *;
 unfold Fth_of_l4 in |- *; simpl in |- *.
elim x3; simpl in |- *; auto.
elim x0; elim x1; elim x2; simpl in |- *.
intro H'; elim H'; clear H'.
right; right; auto.
intros H'; elim H'; clear H'.
right; right; auto.
intros H'; elim H'; clear H'.
right; right; auto.
intros H'; elim H'; clear H'.
right; auto.
intros H'; elim H'; clear H'.
right; right; auto.
intros H'; elim H'; clear H'.
right; auto.
intros H'; elim H'; clear H'.
right; auto.
intros H'; elim H'; clear H'.
auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 0 lt_O_4)); simpl in |- *;
 auto.
intro a; elim (less_or_eq (exist (fun n : nat => n < 4) 1 a)); simpl in |- *.
intro a0; elim (less_or_eq (exist (fun n : nat => n < 4) 2 a0));
 simpl in |- *; auto.
intro Abs; absurd (3 = 4); auto.
intro Abs; absurd (2 = 4); auto.
intro Abs; absurd (1 = 4); auto.
Qed.

Lemma d_In_SUC1_l4 :
 forall l : d_list bool 4,
 d_In (no_in (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4)))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Thd_of_l4 l = true.
replace (no_in (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4))) with 2.
intros l H.
apply d_In_SUC1_l3.
replace (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4))))
 with 2.
auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 0 lt_O_4)); simpl in |- *.
intro a; elim (less_or_eq (exist (fun n : nat => n < 4) 1 a)); simpl in |- *.
auto.
intro Abs; absurd (2 = 4); auto.
intro Abs; absurd (1 = 4); auto.
unfold SUC_MODN in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 1 lt_1_4)); simpl in |- *;
 auto.
intros Abs; absurd (2 = 4); auto.
Qed.

Lemma not_d_In_SUC1_l4 :
 forall l : d_list bool 4,
 ~
 d_In (no_in (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4)))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Thd_of_l4 l = false.
replace (no_in (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4))) with 2.
intros l H.
apply not_d_In_SUC1_l3.
replace (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4))))
 with 2.
auto.
unfold SUC_MODN in |- *; simpl in |- *.

elim (less_or_eq (exist (fun p : nat => p < 4) 0 lt_O_4)); simpl in |- *.
intro a; elim (less_or_eq (exist (fun n : nat => n < 4) 1 a)); simpl in |- *.
auto.
intro Abs; absurd (2 = 4); auto.
intro Abs; absurd (1 = 4); auto.
unfold SUC_MODN in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 1 lt_1_4)); simpl in |- *;
 auto.
intros Abs; absurd (2 = 4); auto.
Qed.

Lemma d_In_SUCSUC1_l4 :
 forall l : d_list bool 4,
 d_In (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4))))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Fth_of_l4 l = true.
replace (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4))))
 with 3.
intros l H.
apply d_In_SUC2_l4.
replace
 (no_in
    (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4)))))
 with 3.
auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 0 lt_O_4)); simpl in |- *.
intro a; elim (less_or_eq (exist (fun n : nat => n < 4) 1 a)); simpl in |- *.
intro a0; elim (less_or_eq (exist (fun n : nat => n < 4) 2 a0));
 simpl in |- *; auto.
intros Abs; absurd (3 = 4); auto.
intro Abs; absurd (2 = 4); auto.
intro Abs; absurd (1 = 4); auto.
unfold SUC_MODN in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 1 lt_1_4)); simpl in |- *;
 auto.
intro a; elim (less_or_eq (exist (fun n : nat => n < 4) 2 a)); simpl in |- *.
auto.
intros Abs; absurd (3 = 4); auto.
intros Abs; absurd (2 = 4); auto.
Qed.

Lemma not_d_In_SUCSUC1_l4 :
 forall l : d_list bool 4,
 ~
 d_In (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4))))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Fth_of_l4 l = false.
replace (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4))))
 with 3.
intros l H.
apply not_d_In_SUC2_l4.
replace
 (no_in
    (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4)))))
 with 3.
auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 0 lt_O_4)); simpl in |- *.

intro a; elim (less_or_eq (exist (fun n : nat => n < 4) 1 a)); simpl in |- *.
intro a0; elim (less_or_eq (exist (fun n : nat => n < 4) 2 a0));
 simpl in |- *; auto.
intros Abs; absurd (3 = 4); auto.
intro Abs; absurd (2 = 4); auto.
intro Abs; absurd (1 = 4); auto.
unfold SUC_MODN in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 1 lt_1_4)); simpl in |- *;
 auto.
intro a; elim (less_or_eq (exist (fun n : nat => n < 4) 2 a)); simpl in |- *.
auto.
intros Abs; absurd (3 = 4); auto.
intros Abs; absurd (2 = 4); auto.
Qed.

Lemma d_In_SUC_SSO_l4 :
 forall l : d_list bool 4,
 d_In (no_in (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4)))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Fth_of_l4 l = true.
replace (no_in (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4))) with 3.
intros l H.
apply d_In_SUCSUC1_l4.
replace (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4))))
 with 3.
auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 1 lt_1_4)); simpl in |- *;
 auto.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 2 y)); simpl in |- *;
 auto.
intros Abs; absurd (3 = 4); auto.
intros Abs; absurd (2 = 4); auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 2 lt_2_4)); simpl in |- *;
 auto.
intros Abs; absurd (3 = 4); auto.
Qed.

Lemma not_d_In_SUC_SSO_l4 :
 forall l : d_list bool 4,
 ~
 d_In (no_in (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4)))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Fth_of_l4 l = false.
replace (no_in (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4))) with 3.
intros l H.
apply not_d_In_SUCSUC1_l4.
replace (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4))))
 with 3.
auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 1 lt_1_4)); simpl in |- *;
 auto.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 2 y)); simpl in |- *;
 auto.
intros Abs; absurd (3 = 4); auto.
intros Abs; absurd (2 = 4); auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 2 lt_2_4)); simpl in |- *;
 auto.
intros Abs; absurd (3 = 4); auto.
Qed.

Lemma d_In_SUCSUC_SSO_l4 :
 forall l : d_list bool 4,
 d_In (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4))))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Fst_of_l4 l = true.
replace (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4))))
 with 0.
intros l.
elim (non_empty l).
intros x0 X0; elim X0; clear X0.
intros X0 H.
elim (non_empty X0).
intros x1 X1; elim X1; clear X1.
intros X1 H1.
elim (non_empty X1).
intros x2 X2; elim X2; clear X2.
intros X2 H2.
elim (non_empty X2).
intros x3 X3; elim X3; clear X3.
intros X3 H3.
rewrite H; rewrite H1; rewrite H2; rewrite H3.
unfold Fst_of_l4 in |- *; simpl in |- *.
unfold RequestsToArbitrate in |- *.
unfold Fst_of_l4 in |- *; unfold Scd_of_l4 in |- *; unfold Thd_of_l4 in |- *;
 unfold Fth_of_l4 in |- *; simpl in |- *.
elim x0; simpl in |- *; auto.
elim x1; elim x2; elim x3; simpl in |- *.
intros H'.
elim H'; clear H'.
intros Abs.
absurd (1 = 0); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (2 = 0); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (3 = 0); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (1 = 0); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (2 = 0); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (1 = 0); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (3 = 0); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (1 = 0); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (2 = 0); auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (3 = 0); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intros Abs; absurd (2 = 0); auto.
intros Abs; absurd False; auto.
intros H'; elim H'; clear H'.
intro Abs; absurd (3 = 0); auto.
intros Abs; absurd False; auto.
intros Abs; absurd False; auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 2 lt_2_4)); simpl in |- *;
 auto.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 3 y)); simpl in |- *;
 auto.
intro Abs; absurd (4 < 4); auto with arith.
intro Abs; absurd (3 = 4); auto.
Qed.

Lemma not_d_In_SUCSUC_SSO_l4 :
 forall l : d_list bool 4,
 ~
 d_In (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4))))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Fst_of_l4 l = false.
replace (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4))))
 with 0.
intro l.
elim (non_empty l).
intros x0 X0; elim X0; clear X0.
intros X0 H.
elim (non_empty X0).
intros x1 X1; elim X1; clear X1.
intros X1 H1.
elim (non_empty X1).
intros x2 X2; elim X2; clear X2.
intros X2 H2.
elim (non_empty X2).
intros x3 X3; elim X3; clear X3.
intros X3 H3.
rewrite H; rewrite H1; rewrite H2; rewrite H3.
unfold Fst_of_l4 in |- *; simpl in |- *.
unfold RequestsToArbitrate in |- *.
unfold Fst_of_l4 in |- *; unfold Scd_of_l4 in |- *; unfold Thd_of_l4 in |- *;
 unfold Fth_of_l4 in |- *; simpl in |- *.
elim x0; simpl in |- *; auto.
elim x1; elim x2; elim x3; simpl in |- *.
intro H'.
elim H'; clear H'.
auto.
intros H'; elim H'; clear H'.
auto.
intros H'; elim H'; clear H'.
auto.
intros H'; elim H'; clear H'.
auto.
intros H'; elim H'; clear H'.
auto.
intros H'; elim H'; clear H'.
auto.
intros H'; elim H'; clear H'.
auto.
intros H'; elim H'; clear H'.
auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 2 lt_2_4)); simpl in |- *;
 auto.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 3 y)); simpl in |- *;
 auto.
intro Abs; absurd (4 < 4); auto with arith.
intro Abs; absurd (3 = 4); auto.
Qed.

Lemma d_In_SUCSUCSUC_SSO_l4 :
 forall l : d_list bool 4,
 d_In
   (no_in
      (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4)))))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Scd_of_l4 l = true.
replace
 (no_in
    (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4)))))
 with 1.
intros l H.
apply d_In_SUC0_l2.
replace (no_in (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4))) with 1.
auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 0 lt_O_4)); simpl in |- *;
 auto.
intros Abs; absurd (1 = 4); auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 2 lt_2_4)); simpl in |- *;
 auto.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 3 y)); simpl in |- *;
 auto.
intro Abs; absurd (4 < 4); auto with arith.
intro y'; elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen y')));
 simpl in |- *; auto.
intro Abs; absurd (1 = 4); auto.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen y)));
 simpl in |- *; auto.
absurd (3 = 4); auto.
absurd (3 = 4); auto.
Qed.

Lemma not_d_In_SUCSUCSUC_SSO_l4 :
 forall l : d_list bool 4,
 ~
 d_In
   (no_in
      (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4)))))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Scd_of_l4 l = false.
replace
 (no_in
    (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4)))))
 with 1.
intros l H.
apply not_d_In_SUC0_l2.
replace (no_in (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4))) with 1.
auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 0 lt_O_4)); simpl in |- *;
 auto.
intros Abs; absurd (1 = 4); auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 2 lt_2_4)); simpl in |- *;
 auto.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 3 y)); simpl in |- *;
 auto.
intros Abs; absurd (4 < 4); auto with arith.
intro y'; elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen y')));
 simpl in |- *; auto.
intro Abs; absurd (1 = 4); auto with arith.
intro Abs; absurd (3 = 4); auto with arith.
Qed.

Lemma d_In_SUC_SSSO_l4 :
 forall l : d_list bool 4,
 d_In (no_in (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4)))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Fst_of_l4 l = true.
replace (no_in (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4))) with 0.
intros l H.
apply d_In_SUCSUC_SSO_l4.
replace (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4))))
 with 0.
auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 2 lt_2_4)); simpl in |- *;
 auto.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 3 y)); simpl in |- *;
 auto.
intro Abs; absurd (4 < 4); auto with arith.
intro Abs; absurd (3 = 4); auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 3 lt_3_4)); simpl in |- *;
 auto.
intros Abs; absurd (4 < 4); auto with arith.
Qed.

Lemma not_d_In_SUC_SSSO_l4 :
 forall l : d_list bool 4,
 ~
 d_In (no_in (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4)))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Fst_of_l4 l = false.
replace (no_in (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4))) with 0.
intros l H.
apply not_d_In_SUCSUC_SSO_l4.
replace (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4))))
 with 0.
auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 2 lt_2_4)); simpl in |- *;
 auto.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 3 y)); simpl in |- *;
 auto.
intros Abs; absurd (4 < 4); auto with arith.
intros Abs; absurd (3 = 4); auto with arith.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 3 lt_3_4)); simpl in |- *;
 auto.
intros Abs; absurd (4 < 4); auto with arith.
Qed.

Lemma d_In_SUCSUC_SSSO_l4 :
 forall l : d_list bool 4,
 d_In (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4))))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Scd_of_l4 l = true.
replace (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4))))
 with 1.
intros l H.
apply d_In_SUCSUCSUC_SSO_l4.
replace
 (no_in
    (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4)))))
 with 1.
auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 2 lt_2_4)); simpl in |- *;
 auto.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 3 y)); simpl in |- *;
 auto.
intros Abs; absurd (4 < 4); auto with arith.
intro y'; elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen y')));
 simpl in |- *; auto.
intros Abs; absurd (1 = 4); auto.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen y)));
 simpl in |- *; auto.
absurd (3 = 4); auto.
absurd (3 = 4); auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 3 lt_3_4)); simpl in |- *;
 auto.
intros Abs; absurd (4 < 4); auto with arith.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen y)));
 simpl in |- *; auto.
intro Abs; absurd (1 = 4); auto.
Qed.

Lemma not_d_In_SUCSUC_SSSO_l4 :
 forall l : d_list bool 4,
 ~
 d_In (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4))))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Scd_of_l4 l = false.
replace (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4))))
 with 1.
intros l H.
apply not_d_In_SUCSUCSUC_SSO_l4.
replace
 (no_in
    (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4)))))
 with 1.
auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 2 lt_2_4)); simpl in |- *;
 auto.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 3 y)); simpl in |- *;
 auto.
intro Abs; absurd (4 < 4); auto with arith.
intro y'; elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen y')));
 simpl in |- *; auto.
intro Abs; absurd (1 = 4); auto.
intro Abs; absurd (3 = 4); auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 3 lt_3_4)); simpl in |- *;
 auto.
intros Abs; absurd (4 < 4); auto with arith.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen y)));
 simpl in |- *; auto.
intro Abs; absurd (1 = 4); auto.
Qed.

Lemma d_In_SUCSUCSUC_SO_l4 :
 forall l : d_list bool 4,
 d_In
   (no_in
      (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4)))))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Fst_of_l4 l = true.
replace
 (no_in
    (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4)))))
 with 0.
intros l H.
apply d_In_SUC_SSSO_l4.
replace (no_in (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4))) with 0.
auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 3 lt_3_4)); simpl in |- *;
 auto.
intros Abs; absurd (4 < 4); auto with arith.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 1 lt_1_4)); simpl in |- *;
 auto.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 2 y)); simpl in |- *;
 auto.
intro y'; elim (less_or_eq (exist (fun n : nat => n < 4) 3 y'));
 simpl in |- *; auto.
intros Abs; absurd (4 < 4); auto with arith.
intro Abs; absurd (3 = 4); auto.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen y)));
 simpl in |- *; auto.
absurd (2 = 4); auto.
absurd (2 = 4); auto.
Qed.

Lemma not_d_In_SUCSUCSUC_SO_l4 :
 forall l : d_list bool 4,
 ~
 d_In
   (no_in
      (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4)))))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Fst_of_l4 l = false.
replace
 (no_in
    (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4)))))
 with 0.
intros l H.
apply not_d_In_SUC_SSSO_l4.
replace (no_in (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4))) with 0.
auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 3 lt_3_4)); simpl in |- *;
 auto.
intros Abs; absurd (4 < 4); auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 1 lt_1_4)); simpl in |- *;
 auto.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 2 y)); simpl in |- *;
 auto.
intro y'; elim (less_or_eq (exist (fun n : nat => n < 4) 3 y'));
 simpl in |- *; auto.
absurd (4 < 4); auto with arith.
absurd (4 < 4); auto with arith.
absurd (4 < 4); auto with arith.
absurd (4 < 4); auto with arith.
unfold SUC_MODN in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 1 lt_1_4)); simpl in |- *;
 auto.
intro a; elim (less_or_eq (exist (fun n : nat => n < 4) 2 a)); simpl in |- *;
 auto.
intro a0; elim (less_or_eq (exist (fun n : nat => n < 4) 3 a0));
 simpl in |- *; auto.
intros Abs; absurd (4 < 4); auto.
absurd (4 < 4); auto with arith.
intro b; elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen b)));
 simpl in |- *; auto.
absurd (3 = 4); auto with arith.
intro Abs; absurd (2 = 4); auto.
Qed.

Lemma d_In_SUCSUCSUC_SSSO_l4 :
 forall l : d_list bool 4,
 d_In
   (no_in
      (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4)))))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Thd_of_l4 l = true.
replace
 (no_in
    (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4)))))
 with 2.
intros l H.
apply d_In_SUC1_l4.
replace (no_in (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4))) with 2.
auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 1 lt_1_4)); simpl in |- *;
 auto.
intros Abs; absurd (2 = 4); auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 3 lt_3_4)); simpl in |- *;
 auto.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 4 y)); simpl in |- *;
 auto.
absurd (4 < 4); auto with arith.
absurd (4 < 4); auto with arith.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen y)));
 simpl in |- *; auto.
intro y'; elim (less_or_eq (exist (fun n : nat => n < 4) 1 y'));
 simpl in |- *; auto.
intro Abs; absurd (2 = 4); auto.
intro Abs; absurd (1 = 4); auto.
Qed.

Lemma not_d_In_SUCSUCSUC_SSSO_l4 :
 forall l : d_list bool 4,
 ~
 d_In
   (no_in
      (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4)))))
   (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))) ->
 Thd_of_l4 l = false.
replace
 (no_in
    (SUC_MODN (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4)))))
 with 2.
intros l H.
apply not_d_In_SUC1_l4.
replace (no_in (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4))) with 2.
auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 1 lt_1_4)); simpl in |- *;
 auto.
intros Abs; absurd (2 = 4); auto.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 3 lt_3_4)); simpl in |- *;
 auto.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 4 y)); simpl in |- *;
 auto.
absurd (4 < 4); auto with arith.
absurd (4 < 4); auto with arith.
intro y; elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen y)));
 simpl in |- *; auto.
intro y'; elim (less_or_eq (exist (fun n : nat => n < 4) 1 y'));
 simpl in |- *; auto.
intro Abs; absurd (2 = 4); auto.
intro Abs; absurd (1 = 4); auto.
Qed.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

Require Import Field_tac.
Require Import EGroup.
Require Import FGroup.
Require Import UList.
Require Import Arith.
Require Import ZAux.
Require Import Znumtheory.
Require Export Operators.
Require Import Arith.Euclid.
Require Import Padding.
Require Import SMain.

Require Import ssreflect eqtype
 ssrbool ssrfun fingroup Ssreflect.choice fintype ssrnat seq finalg ssralg.

Require Import abelian Ssreflect.cyclic bigop gproduct finset div.

Open Scope nat_scope.

Set Implicit Arguments.

Module Type FIELD <: FINITE_TYPE.

  Parameter t : nat -> Type.

  Parameter default : forall k, t k.

  Parameter eqb : forall k, t k -> t k -> bool.

  Parameter eqb_spec : forall k (x y:t k),
   if eqb x y then x = y else x <> y.

  Parameter eqb_refl : forall k (x:t k), eqb x x.

  Parameter elems : forall k, list (t k).

  Parameter elems_poly : polynomial.

  Parameter elems_full : forall k (x:t k), In x (elems k).

  Parameter elems_NoDup : forall k, NoDup (elems k).

  Parameter elems_size_nat : forall k,
    le (size_nat (List.length (elems k))) (peval elems_poly k).

  Parameter elems_notnil : forall k, elems k <> List.nil.

  Parameters kO kI : forall k, t k.

  Parameters kplus kmul ksub kdiv: forall k, t k -> t k -> t k.

  Parameters kopp kinv : forall k, t k-> t k.

  Parameter is_zero : forall k, t k -> bool.

  Parameter K_field : forall k,
   field_theory (kO k) (kI k) (@kplus k) (@kmul k) (@ksub k)
   (@kopp k) (@kdiv k) (@kinv k) (@eq (t k)).

  Parameter kinv_kO : forall k,
    kinv (@kO k) = (@kO k).

  Parameter diff_2_0 : forall k, kplus (kI k) (kI k) <> (kO k).
  Parameter diff_3_0 : forall k, kplus (kplus (kI k) (kI k)) (kI k) <> (kO k).

  Parameter diff_mul_0: forall k (x1 x2:t k),
   x1 <> (kO k) -> x2 <> kO k -> kmul x1 x2 <> kO k.

  Definition order k := length (elems k).

  Definition orderZ k := Z_of_nat (length (elems k)).

  Fixpoint kpow (k:nat) x (n:nat) : t k :=
   match n with
    | O => kI k
    | S n' => kmul x (kpow k x n')
   end.

  Parameter one_not_zero : forall k, (kI k) <> (kO k).

  Parameter two_not_zero : forall k, kplus (kI k) (kI k) <> (kO k).

  Parameter is_zero_correct : forall k n , is_zero n = true <-> n = (kO k).

  Parameter fermat : forall k x, kpow x (order k - 1)  = kI k.

  Parameter order_mod1 order_mod2 : nat -> Z.

  Parameter order_mod : forall k,
   ((orderZ k) mod (order_mod1 k) = (order_mod2 k))%Z.

End FIELD.

Module Type CURVE_PROPERTIES (A : FIELD).

  Import A.

  Parameter A B : forall k, A.t k.

  Parameter NonSingular : forall k, kplus  (kmul (kmul (kmul (kmul (kplus (kI k) (kI k)) (kplus (kI k) (kI k))) (A k)) (A k)) (A k))
  (kmul (kmul (kmul (kmul (kplus (kplus (kI k) (kI k)) (kI k)) (kplus (kplus (kI k) (kI k)) (kI k)))
    (kplus (kplus (kI k) (kI k)) (kI k))) (B k)) (B k)) <> (kO k).

End CURVE_PROPERTIES.

 Lemma NoDup_ulist : forall A (l : list A),
   NoDup l <-> ulist l.
 Proof.
  induction l; split; intros; constructor; inversion H; auto; tauto.
 Qed.

Module EC_BASE  (A : FIELD) (CP : CURVE_PROPERTIES A).

 Import A CP.

 Lemma Eth : forall k, ell_theory (kO k) (kI k) (@kplus k) (@kmul k) (@ksub k) (@kopp k) (@kinv k) (@kdiv k) (A k) (B k) (@is_zero k).
 Proof.
  intros; constructor.
  apply K_field.
  apply NonSingular.
  apply one_not_zero.
  apply two_not_zero.
  apply is_zero_correct.
 Qed.

 Definition t (k : nat) : Type := elt (kI k) (@kplus k) (@kmul k) (A k) (B k).

 Definition eqb k (x y : t k) : bool :=
  match ceqb (Eth k) x y with
   | left _ => true
   | right _ => false
  end.

 Lemma eqb_spec : forall k (x y:t k), if eqb x y then x = y else x <> y.
 Proof.
  intros k x y; unfold eqb.
  case (ceqb (Eth k) x y); intro; trivial.
 Qed.

 Definition e (k : nat) := inf_elt (kI k) (@kplus k) (@kmul k) (A k) (B k).

 Definition inv (k : nat) (x : t k) : t k := opp (Eth k) x.

 Definition mul (k : nat) (x y : t k) : t k := add (Eth k) x y.

 Lemma mul_comm : forall k (x y: t k), mul x y = mul y x.
 Proof.
  intros k x y; unfold mul.
  rewrite add_comm; trivial.
 Qed.

 Lemma mul_assoc : forall k (x y z:t k), mul x (mul y z) = mul (mul x y) z.
 Proof.
  intros k x y z ; unfold mul.
  rewrite add_assoc; trivial.
 Qed.

 Lemma inv_spec : forall k (x:t k), mul x (inv x) = e k.
 Proof.
  intros k x; unfold mul, inv, e; simpl.
  apply add_opp.
 Qed.

 Lemma mul_e_r : forall k (x:t k), mul x (e k) = x.
 Proof.
  intros k x; unfold mul, e; simpl.
  apply add_0_r.
 Qed.

 (** Complexity specification *)
 Parameter cost_mul : forall k (x y:t k), nat.

 Parameter cost_inv : forall k (x:t k), nat.

 Parameter cost_mul_poly : polynomial.

 Parameter cost_mul_poly_spec : forall k (x y:t k),
   le (@cost_mul k x y) (peval cost_mul_poly k).

End EC_BASE.

Module EC   (A : FIELD) (CP : CURVE_PROPERTIES A) <: CFG.

  Import A CP.

  Module ECB := EC_BASE A CP.
  Import ECB.

 Lemma ULK : forall k, ulist (A.elems k).
 Proof. intros; apply NoDup_ulist; apply A.elems_NoDup. Qed.

 Lemma CLK : forall k (x : A.t k), In x (A.elems k).
 Proof. intros; apply A.elems_full. Qed.

 Definition efgroup k := EFGroup (@Eth k) (ULK k) (@CLK k).

 Section K.

   Variable k : nat.

 (* A is an EqType *)
 Add Field Kfield : (@A.K_field k) (abstract).

 Lemma eqbA : Equality.axiom (@A.eqb k).
 Proof.
  move => a b.
  have H := A.eqb_spec a b.
  apply: (iffP idP); move => H1.
    by rewrite H1 /= in H.
  move: H; rewrite H1.
  by case (A.eqb b b).
 Qed.

 Canonical Structure A_eqMixin := Eval hnf in EqMixin eqbA.
 Canonical Structure A_eqType :=
   Eval hnf in EqType (@A.t k) A_eqMixin.

 (* A is ChoiceType and CountType *)
 Definition pickle (a : A.t k) : nat :=
   find (fun x => A.eqb x a) (A.elems k).

 Definition unpickle (n:nat) : option (A.t k) :=
   if n < (length (A.elems k))
   then Some (seq.nth (A.kO k) (A.elems k) n)
     else None.

 Lemma A_has_In : forall x,
   has (fun x0 : A.t k => @A.eqb k x0 x) (A.elems k) = true.
 Proof.
  move=> x.
  move: (A.elems_full x).
  elim: (A.elems k); rewrite /= //.
  move=> a l IH; case.
  move ->.
  by apply /orP; left; apply /eqP.
  move => H.
  by apply /orP; right; apply: IH.
 Qed.

 Lemma pickleK : pcancel pickle unpickle.
 Proof.
  move=> x.
  rewrite /unpickle /pickle.
  case H : (find (fun a => A.eqb a x) (A.elems k) < length (A.elems k)).
  f_equal.
  apply: eqP.
  apply: (@nth_find _ (A.kO k) (fun x0 : A.t k => @A.eqb k x0 x) (A.elems k)).
  rewrite has_find.
  have <- : (length (A.elems k) = size (A.elems k)).
  elim: (A.elems k) => //=.
  by move => y l ->.
  apply: H.
  move: H.
  have ->  : (length (A.elems k) = size (A.elems k)).
  elim: (A.elems k) => //=.
  by move => _ l ->.
  by rewrite -has_find A_has_In.
 Qed.

Definition ACountMixin := PcanCountMixin pickleK.
Definition AChoiceMixin := PcanChoiceMixin pickleK.

Canonical Structure AChoiceType :=
  Eval hnf in ChoiceType _ AChoiceMixin.
Canonical Structure ACountType :=
  Eval hnf in CountType _ ACountMixin.

(* A is a FinType *)
Lemma In_count : forall (t : eqType) (x : t) l,
  ~In x l -> count (pred1 x) l= 0.
Proof.
 move => t x l; elim: l => //=.
 move => a l IH H.
 apply Decidable.not_or in H.
 case: H; move => H1 H2.
 case: (boolP (a == x)); move => Hb.
 by elim H1; apply /eqP.
 rewrite IH //=.
 Qed.

Lemma NoDup_count : forall (t : eqType) (x : t) l,
  In x l ->
  NoDup l ->
  count (pred1 x) l = 1.
Proof.
 move => t x l.
 elim: l => //=.
 move => a l IH; case => Ha.
 rewrite Ha.
 rewrite eqxx // => H.
 inversion H; subst.
 rewrite In_count //=.
 move => H; inversion H; subst.
 rewrite IH //=.
 case: (boolP (a == x)); move => Hb //=.
 by move /eqP : Hb H2 => ->.
Qed.

 Lemma A_enumP : Finite.axiom (A.elems k).
 Proof.
  unfold Finite.axiom; intros.
  apply NoDup_count.
  apply: A.elems_full.
  apply: A.elems_NoDup.
 Qed.

Definition AfinMixin := Eval hnf in FinMixin A_enumP.
Canonical Structure AfinType := Eval hnf in FinType _ AfinMixin.

(* A is a Field *)
 Definition AZmodMixin : GRing.Zmodule.mixin_of (A.t k).
 refine (@ZmodMixin (A.t k) (A.kO k) (@A.kopp k) (@A.kplus k) _ _ _ _ ); move => *; field.
 Defined.

 Canonical Structure AZmodType := Eval hnf in ZmodType (A.t k) AZmodMixin.
 Canonical Structure AfinZmodType := Eval hnf in [finZmodType of (A.t k)].

 Lemma Acomm : commutative (@A.kmul k).
 Proof. move => *; field. Qed.

 Lemma Aass : associative (@A.kmul k).
 Proof. move => *; field. Qed.

 Lemma Aleft_id :  left_id (@A.kI k) (@A.kmul k).
 Proof. move => *; field. Qed.

 Lemma Aleft_dist :  left_distributive (@A.kmul k) (@A.kplus k).
 Proof. move => *; field. Qed.

 Lemma Aone_diff_zero : ~~ (A.kI k == 0%R).
 Proof. by apply /eqP => H; apply: (@A.one_not_zero k). Qed.

 Definition AringMixin := ComRingMixin Aass Acomm Aleft_id  Aleft_dist Aone_diff_zero.

 Canonical Structure AringType := Eval hnf in RingType (A.t k) AringMixin.
 Canonical Structure AfinRingType := Eval hnf in [finRingType of (A.t k)].

 Lemma AmulC : commutative (GRing.Ring.mul (GRing.Ring.class AringType)).
 Proof. move => * /=; field. Qed.

 Canonical Structure AcomRingType := Eval hnf in ComRingType (@A.t k) AmulC.
 Canonical Structure AfinComRingType := Eval hnf in [finComRingType of (A.t k)].

 Lemma AmulVz : forall x, ~~ A.eqb x (A.kO k) -> A.kmul (A.kinv x) x = A.kI k.
 Proof. by move=> x H; field; move=> W; move /eqP: H. Qed.

 Lemma Ainv_out : forall x, ~~ ~~ A.eqb x (A.kO k) -> A.kinv x = x.
 Proof.
   move => x H; rewrite negb_involutive in H.
   move /eqP : H ->; apply A.kinv_kO.
  Qed.

Lemma Aintro_unit : forall x y, A.kmul y x = A.kI k -> ~~ A.eqb x (A.kO k).
Proof.
  move=> x y H.
  apply /eqP => W.
  rewrite W in H.
  move: H.
  have -> : ( A.kmul y (A.kO k) = A.kO k) by field.
  move => H.
  by apply: (@one_not_zero k).
Qed.

 Definition AunitRingMixin :=
  ComUnitRingMixin AmulVz Aintro_unit Ainv_out.

 Canonical Structure AunitRingType :=
   Eval hnf in UnitRingType (A.t k) AunitRingMixin.
 Canonical Structure AfinUnitRingType := Eval hnf in [finUnitRingType of (A.t k)].
 Canonical Structure AcomUnitRingType := Eval hnf in [comUnitRingType of (A.t k)].
 Canonical Structure AfinComUnitRingType :=
   Eval hnf in [finComUnitRingType of (A.t k)].

 Lemma AfieldMixin : GRing.Field.mixin_of [the unitRingType of (A.t k)].
 Proof. by move=> x nzx; rewrite /GRing.unit /=. Qed.

 Definition AidomainMixin := FieldIdomainMixin AfieldMixin.

 Canonical Structure AidomainType :=
   Eval hnf in IdomainType (A.t k)  AidomainMixin.
 Canonical Structure AfinIdomainType := Eval hnf in [finIdomainType of (A.t k)].
 Canonical Structure AfieldType := Eval hnf in FieldType (A.t k) AfieldMixin.
 Canonical Structure AfinFieldType := Eval hnf in [finFieldType of (A.t k)].
 Canonical Structure AdecFieldType :=
   Eval hnf in [decFieldType of (A.t k) for AfinFieldType].

 (* G is a EqType *)

 Lemma eqbP : Equality.axiom (@eqb k).
 Proof.
  move => a b.
  have H := eqb_spec a b.
  apply: (iffP idP); move => H1.
    by rewrite H1 /= in H.
  move: H; rewrite H1.
  by case (eqb b b).
 Qed.

 Canonical Structure G_eqMixin := Eval hnf in EqMixin eqbP.
 Canonical Structure G_eqType :=
   Eval hnf in EqType (@t k) G_eqMixin.

(*
   G is a ChoiceType :
   Bijection between A*A and elt to proof ChoiceType for elt
   A * A => A * A + proof => option (A * A + proof) => elt
*)

 (* A * A *)
 Definition prodA : choiceType := prod_choiceType ACountType AChoiceType.

 (* A * A => A * A + proof *)
 Definition in_curve : pred prodA :=
   fun pair => A.eqb
     (pow (A.kI k) (@A.kmul k) pair.2 2)
     (A.kplus (A.kplus (pow (@A.kI k) (@A.kmul k) pair.1 3) (A.kmul (CP.A k) pair.1)) (CP.B k)).

 Definition prodA_sig_choiceMixin :=
   [choiceMixin of {x | in_curve x} by <:].
 Canonical Structure prodA_sig_choiceType :=
   Eval hnf in ChoiceType {x | in_curve x} prodA_sig_choiceMixin.

 (* A * A + proof => option (A * A + proof) *)
 Definition opt_prod_A : choiceType := option_choiceType prodA_sig_choiceType.

 (* option (A * A + proof) => elt *)
 Definition f_inj (x : t k) : opt_prod_A.
 case; first by exact: None.
 move => x y H.
 refine (Some (exist _ (x, y) _)).
 by rewrite /in_curve //=; apply /eqP.
 Defined.

 Definition f'_inj (x : opt_prod_A) : t k.
 case; last by (exact: inf_elt).
 case; case => x y; rewrite /in_curve => /eqP H.
 by refine (@curve_elt _ _ _ _ _ _ x y _).
 Defined.

 Lemma K_f_inf : cancel f_inj f'_inj.
 Proof. case => //= x y H; apply: (curve_elt_irr (Eth k)) => //. Qed.

 Definition GChoiceMixin := CanChoiceMixin K_f_inf.
 Canonical Structure GChoiceType :=
   Eval hnf in ChoiceType _ GChoiceMixin.

 (* G is a CountType *)
 Definition elems : list (t k) :=
   FELLK (Eth k) (A.elems k) (@A.elems_full k).

 Definition Gpickle (a : t k) : nat :=
   find (fun x => x == a) elems.

 Definition Gunpickle (n:nat) : option (@t k) :=
   if n < (length elems)
   then Some (@nth (@t k) (@e k)  elems n)
     else None.

 Lemma G_has_In : forall x,
   has (fun x0 : t k => x0 == x) elems = true.
 Proof.
  move=> x.
  move: (@FELLK_in _ _ _ _ _ _ _ _ _ _ _ _ (@Eth k) (A.elems k) (@A.elems_full k) x).
  rewrite /elems.
  elim: (FELLK (Eth k) (A.elems k) (@A.elems_full k)); rewrite //=.
  move=> a l IH; case.
  by move ->; apply /orP; left; apply /eqP.
  by move => H; apply /orP; right; apply: IH.
 Qed.

 Lemma GpickleK : pcancel (@Gpickle) (@Gunpickle).
 Proof.
  move=> x; rewrite /Gunpickle /Gpickle.
  case_eq ((seq.find (fun a => a == x)  elems) < (length elems) ); intros.
  f_equal.
  apply /eqP.
  apply: (@nth_find _ (e k) (fun x0 : t k => @eqb k x0 x) elems).
  rewrite has_find.
  have <- : (length elems = size  elems).
  elim: elems => //=.
  by move => y l ->.
  apply: H.
  move: H.
  have -> : (length elems = size elems).
  elim: elems => //=.
  by move => _ l ->.
  by rewrite -has_find G_has_In.
 Qed.

 Definition GCountMixin := PcanCountMixin GpickleK.
 Canonical Structure GCountType := Eval hnf in CountType _ GCountMixin.

 (* G is a FinType *)
 Lemma GenumP : Finite.axiom elems.
 Proof.
  rewrite /Finite.axiom; move=> x.
  apply NoDup_count.
  apply: FELLK_in.
  apply NoDup_ulist.
  apply: FELLK_ulist.
  apply NoDup_ulist.
  apply: A.elems_NoDup.
 Qed.

 Definition GfinMixin := Eval hnf in FinMixin GenumP.
 Canonical Structure GfinType := Eval hnf in FinType _ GfinMixin.

 (* G is a FinGroup *)
 Definition GroupMixin : FinGroup.mixin_of (@t k).
  refine (@FinGroup.BaseMixin (@t k) (@mul k) (@e k) (@inv k) _ _ _ _).
  apply: mul_assoc.
  move=> x; rewrite mul_comm; apply: mul_e_r.
  apply: opp_opp.
  move=> x y /=; rewrite mul_comm; apply: opp_add.
 Defined.

 Lemma left_inv : left_inverse (e k) (@inv k) (@mul k).
 Proof. move=> x; rewrite mul_comm; apply: inv_spec. Qed.

 Canonical Structure T :=
   Eval hnf in BaseFinGroupType _ GroupMixin.

  Lemma mulg_comm : forall (x y:T), mulg x y = mulg y x.
  Proof.
   move=> x y.
   rewrite /mulg /=.
   apply mul_comm.
  Qed.

  (* Definition elems : forall k, list (T k). *)
  Lemma elems_full : forall t, In t elems.
  Proof.
   move=> t.
   apply: (@FELLK_in _ _ _ _ _ _ _ _ _ _ _ _ (@Eth k) (A.elems k) (@A.elems_full k) t).
  Qed.

  Lemma elems_NoDup : NoDup elems.
  Proof.
    rewrite NoDup_ulist.
    apply FELLK_ulist.
    rewrite -NoDup_ulist.
    apply A.elems_NoDup.
  Qed.

  End K.

  End EC.


Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.LetIn.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Rewriter.Language.UnderLets.
Require Import Crypto.AbstractInterpretation.AbstractInterpretation.
Require Import Crypto.Rewriter.All.
Require Import Crypto.MiscCompilerPasses.
Require Import Crypto.Stringification.C.
Import ListNotations. Local Open Scope Z_scope.

Import Language.Compilers.
Import UnderLets.Compilers.
Import AbstractInterpretation.Compilers.
Import Rewriter.All.Compilers.
Import MiscCompilerPasses.Compilers.
Import Stringification.C.Compilers.
Import Language.API.Compilers.
Local Coercion Z.of_nat : nat >-> Z.
Import Compilers.API.

Local Existing Instance AbstractInterpretation.default_Options.

Local Notation "x + y"
  := ((#ident.Z_add @ x @ y)%expr)
     : expr_scope.
Local Notation "x * y"
  := ((#ident.Z_mul @ x @ y)%expr)
     : expr_scope.
Local Notation "x" := (expr.Var x) (only printing, at level 9) : expr_scope.
Local Notation cstZ r := (#ident.Z_cast @ #(@ident.Literal base.type.zrange r%zrange))%expr.
Local Notation cstZZ r1 r2 := (#ident.Z_cast2 @ (#(@ident.Literal base.type.zrange r1%zrange), #(@ident.Literal base.type.zrange r2%zrange)))%expr.

Example test1 : True.
Proof.
  let v := Reify ((fun x => 2^x) 255)%Z in
  pose v as E.
  vm_compute in E.
  pose (PartialEvaluate RewriteRules.default_opts E) as E'.
  vm_compute in E'.
  lazymatch (eval cbv delta [E'] in E') with
  | (fun var => expr.Ident (ident.Literal ?v)) => idtac
  end.
  constructor.
Qed.
Module testrewrite.
  Import expr.
  Import ident.

  Redirect "log" Eval compute in RewriteRules.RewriteNBE RewriteRules.default_opts (fun var =>
                          (#ident.fst @ (expr_let x := ##10 in ($x, $x)))%expr).

  Notation "x + y" := (@expr.Ident base.type ident _ _ ident.Z_add @ x @ y)%expr : expr_scope.

  Redirect "log" Eval compute in RewriteRules.RewriteNBE RewriteRules.default_opts (fun var =>
                          ((\ x , expr_let y := ##5 in #ident.fst @ $x + (#ident.fst @ $x + ($y + $y)))
                             @ (##1, ##1))%expr).

  Redirect "log" Eval compute in RewriteRules.RewriteNBE RewriteRules.default_opts (fun var =>
                          ((\ x , expr_let y := ##5 in $y + ($y + (#ident.fst @ $x + #ident.snd @ $x)))
                             @ (##1, ##7))%expr).

  Redirect "log" Eval cbv in partial.eval_with_bound partial.default_relax_zrange false (@ident.is_comment) false
                                      (RewriteRules.RewriteNBE RewriteRules.default_opts (fun var =>
                (\z , ((\ x , expr_let y := ##5 in $y + ($z + (#ident.fst @ $x + #ident.snd @ $x)))
                         @ (##1, ##7)))%expr) _)
                (Datatypes.Some r[0~>100]%zrange, Datatypes.tt).
End testrewrite.
Module testpartial.
  Import expr.
  Import ident.

  Redirect "log" Eval compute in partial.eval
                          (#ident.fst @ (expr_let x := ##10 in ($x, $x)))%expr.

  Notation "x + y" := (@expr.Ident base.type ident _ _ (ident.Z_add) @ x @ y)%expr : expr_scope.

  Redirect "log" Eval compute in partial.eval
                          ((\ x , expr_let y := ##5 in #ident.fst @ $x + (#ident.fst @ $x + ($y + $y)))
                             @ (##1, ##1))%expr.

  Redirect "log" Eval compute in partial.eval
                          ((\ x , expr_let y := ##5 in $y + ($y + (#ident.fst @ $x + #ident.snd @ $x)))
                             @ (##1, ##7))%expr.

  Redirect "log" Eval cbv in partial.eval_with_bound
                partial.default_relax_zrange
                false (@ident.is_comment) false
                (\z , ((\ x , expr_let y := ##5 in $y + ($z + (#ident.fst @ $x + #ident.snd @ $x)))
                         @ (##1, ##7)))%expr
                (Datatypes.Some r[0~>100]%zrange, Datatypes.tt).
End testpartial.

Module test2.
  Example test2 : True.
  Proof.
    let v := Reify (fun y : Z
                    => (fun k : Z * Z -> Z * Z
                        => dlet_nd x := (y * y) in
                            dlet_nd z := (x * x) in
                            k (z, z))
                         (fun v => v)) in
    pose v as E.
    vm_compute in E.
    pose (partial.Eval E) as E'.
    vm_compute in E'.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var : type -> Type =>
         (λ x : var _,
                expr_let x0 := ($x * $x) in
              expr_let x1 := ($x0 * $x0) in
              ($x1, $x1))%expr) => idtac
    end.
    pose (partial.EvalWithBound partial.default_relax_zrange false (@ident.is_comment) false E' (Some r[0~>10]%zrange, tt)) as E''.
    lazy in E''.
     lazymatch (eval cbv delta [E''] in E'') with
     | (fun var : type -> Type =>
          (λ x : var _,
                 expr_let y := (cstZ r[0 ~> 100]) @ (((cstZ r[0 ~> 10]) @ $x) * ((cstZ r[0 ~> 10]) @ $x)) in
               expr_let y0 := (cstZ r[0 ~> 10000]) @ (((cstZ r[0 ~> 100]) @ $y) * ((cstZ r[0 ~> 100]) @ $y)) in
               ((cstZ r[0 ~> 10000]) @ $y0, (cstZ r[0 ~> 10000]) @ $y0))%expr)
      => idtac
    end.
    constructor.
  Qed.
End test2.
Module test3.
  Example test3 : True.
  Proof.
    let v := Reify (fun y : Z
                    => dlet_nd x := dlet_nd x := (y * y) in
                        (x * x) in
                        dlet_nd z := dlet_nd z := (x * x) in
                        (z * z) in
                        (z * z)) in
    pose v as E.
    vm_compute in E.
    pose (partial.Eval E) as E'.
    vm_compute in E'.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var : type -> Type =>
         (λ x : var _,
                expr_let x0 := $x * $x in
              expr_let x1 := $x0 * $x0 in
              expr_let x2 := $x1 * $x1 in
              expr_let x3 := $x2 * $x2 in
              $x3 * $x3)%expr)
      => idtac
    end.
    pose (partial.EvalWithBound partial.default_relax_zrange false (@ident.is_comment) false E' (Some r[0~>10]%zrange, tt)) as E'''.
    lazy in E'''.
    lazymatch (eval cbv delta [E'''] in E''') with
    | (fun var : type -> Type =>
          (λ x : var _,
           expr_let y := (cstZ r[0 ~> 100]) @ (((cstZ r[0 ~> 10]) @ $x) * ((cstZ r[0 ~> 10]) @ $x)) in
           expr_let y0 := (cstZ r[0 ~> 10000]) @ (((cstZ r[0 ~> 100]) @ $y) * ((cstZ r[0 ~> 100]) @ $y)) in
           expr_let y1 := (cstZ r[0 ~> 100000000]) @ (((cstZ r[0 ~> 10000]) @ $y0) * ((cstZ r[0 ~> 10000]) @ $y0)) in
           expr_let y2 := (cstZ r[0 ~> 10000000000000000]) @ (((cstZ r[0 ~> 100000000]) @ $y1) * ((cstZ r[0 ~> 100000000]) @ $y1)) in
           (cstZ r[0 ~> 100000000000000000000000000000000]) @ (((cstZ r[0 ~> 10000000000000000]) @ $y2) * ((cstZ r[0 ~> 10000000000000000]) @ $y2)))%expr)
      => idtac
    end.
    constructor.
  Qed.
End test3.
Module test3point5.
  Example test3point5 : True.
  Proof.
    let v := Reify (fun y : (list Z) => List.nth_default (-1) y 0) in
    pose v as E.
    vm_compute in E.
    pose (partial.EvalWithBound partial.default_relax_zrange false (@ident.is_comment) false E (Some [Some r[0~>10]%zrange], tt)) as E'.
    lazy in E'.
    clear E.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var : type -> Type =>
         (λ x : var _,
          (cstZ r[0 ~> 10]) @ (#ident.List_nth_default @ #(ident.Literal (0)%Z) @ $x @ #(ident.Literal 0%nat)))%expr)
      => idtac
    end.
    constructor.
  Qed.
End test3point5.
Module test4.
  Example test4 : True.
  Proof.
    let v := Reify (fun y : (list Z * list Z)
                    => dlet_nd x := List.nth_default (-1) (fst y) 0 in
                        dlet_nd z := List.nth_default (-1) (snd y) 0 in
                        dlet_nd xz := (x * z) in
                        (xz :: xz :: nil)) in
    pose v as E.
    vm_compute in E.
    pose (partial.Eval E) as E'.
    lazy in E'.
    clear E.
    pose (Some [Some r[0~>10]%zrange],Some [Some r[0~>10]%zrange], Datatypes.tt) as bound.
    pose (partial.EtaExpandWithListInfoFromBound E' bound) as E''.
    lazy in E''.
    clear E'.
    pose (PartialEvaluate RewriteRules.default_opts E'') as E'''.
    lazy in E'''.
    pose (partial.EvalWithBound partial.default_relax_zrange false (@ident.is_comment) false E''' bound) as E''''.
    lazy in E''''.
    clear E'' E'''.
    lazymatch (eval cbv delta [E''''] in E'''') with
    | (fun var : type -> Type =>
         (λ x : var _,
          expr_let y := (cstZ r[0 ~> 10]) @
                        (#ident.List_nth_default @ #(ident.Literal (0)%Z) @ (#ident.fst @ $x) @ #(ident.Literal 0%nat)) in
          expr_let y0 := (cstZ r[0 ~> 10]) @
                          (#ident.List_nth_default @ #(ident.Literal (0)%Z) @ (#ident.snd @ $x) @ #(ident.Literal 0%nat)) in
          expr_let y1 := (cstZ r[0 ~> 100]) @ (((cstZ r[0 ~> 10]) @ $y) * ((cstZ r[0 ~> 10]) @ $y0)) in
          (cstZ r[0 ~> 100]) @ $y1 :: (cstZ r[0 ~> 100]) @ $y1 :: [])%expr)
      => idtac
    end.
    constructor.
  Qed.
End test4.
Module test5.
  Example test5 : True.
  Proof.
    let v := Reify (fun y : (Z * Z)
                    => dlet_nd x := (13 * (fst y * snd y)) in
                        x) in
    pose v as E.
    vm_compute in E.
    pose (RewriteRules.RewriteArith (2^8) RewriteRules.default_opts (partial.Eval E)) as E'.
    lazy in E'.
    clear E.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var =>
         expr.Abs (fun v
              => (expr_let v0 := (#ident.Z_mul @ (#ident.fst @ $v) @ (#ident.Z_mul @ (#ident.snd @ $v) @ #(ident.Literal 13))) in
                      $v0)%expr))
      => idtac
    end.
    constructor.
  Qed.

  Example test5_2 : True.
  Proof.
    let v := Reify (fun y : (Z * Z)
                    => dlet_nd x := (2 * (19 * (fst y * snd y))) in
                        x) in
    pose v as E.
    vm_compute in E.
    pose (RewriteRules.RewriteArith (2^8) RewriteRules.default_opts (partial.Eval E)) as E'.
    lazy in E'.
    clear E.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var =>
         expr.Abs (fun v
              => (expr_let v0 := (#ident.Z_mul @ (#ident.fst @ $v) @ (#ident.Z_mul @ (#ident.snd @ $v) @ (#ident.Z_mul @ #(ident.Literal 2) @ #(ident.Literal 19)))) in
                      $v0)%expr))
      => idtac
    end.
    constructor.
  Qed.
End test5.
Module test6.
  (* check for no dead code with if *)
  Example test6 : True.
  Proof.
    let v := Reify (fun y : Z
                    => if 0 =? 1
                       then dlet_nd x := (y * y) in
                                x
                       else y) in
    pose v as E.
    vm_compute in E.
    pose (PartialEvaluate RewriteRules.default_opts E) as E''.
    lazy in E''.
    lazymatch eval cbv delta [E''] in E'' with
    | fun var : type -> Type => (λ x : var _, $x)%expr
      => idtac
    end.
    exact I.
  Qed.
End test6.
Module test7.
  Example test7 : True.
  Proof.
    let v := Reify (fun y : Z
                    => dlet_nd x := y + y in
                        dlet_nd z := x in
                        dlet_nd z' := z in
                        dlet_nd z'' := z in
                        z'' + z'') in
    pose v as E.
    vm_compute in E.
    pose (Subst01.Subst01 ident.is_comment (DeadCodeElimination.EliminateDead ident.is_comment E)) as E''.
    lazy in E''.
    lazymatch eval cbv delta [E''] in E'' with
    | fun var : type -> Type => (λ x : var _, expr_let v0 := $x + $x in $v0 + $v0)%expr
      => idtac
    end.
    exact I.
  Qed.
End test7.
Module test8.
  Example test8 : True.
  Proof.
    let v := Reify (fun y : Z
                    => dlet_nd x := y + y in
                        dlet_nd z := x in
                        dlet_nd z' := z in
                        dlet_nd z'' := z in
                        z'' + z'') in
    pose v as E.
    vm_compute in E.
    pose (GeneralizeVar.GeneralizeVar (E _)) as E''.
    lazy in E''.
    unify E E''.
    exact I.
  Qed.
End test8.
Module test9.
  Example test9 : True.
  Proof.
    let v := Reify (fun y : list Z => (hd 0%Z y, tl y)) in
    pose v as E.
    vm_compute in E.
    pose (PartialEvaluate RewriteRules.default_opts E) as E'.
    lazy in E'.
    clear E.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var
       => (λ x,
           (#ident.list_case
              @ (λ _, #(ident.Literal 0%Z))
              @ (λ x0 _, $x0)
              @ $x,
            #ident.list_case
              @ (λ _, #ident.nil)
              @ (λ _ x1, $x1)
              @ $x))%expr)
      => idtac
    end.
    exact I.
  Qed.
End test9.
(*
Module test10.
  Example test10 : True.
  Proof.
    let v := Reify (fun (f : Z -> Z -> Z) x y => f (x + y) (x * y))%Z in
    pose v as E.
    vm_compute in E.
    pose (Uncurry.expr.Uncurry (partial.Eval true (canonicalize_list_recursion E))) as E'.
    lazy in E'.
    clear E.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var =>
         (λ v,
          ident.fst @@@ $v @
                    (ident.fst @@@ (ident.snd @@@ $v) + ident.snd @@@ (ident.snd @@@ $v)) @
                    (ident.fst @@@ (ident.snd @@@ $v) * ident.snd @@@ (ident.snd @@@ $v)))%expr)
      => idtac
    end.
    constructor.
  Qed.
End test10.
 *)
(*
Module test11.
  Example test11 : True.
  Proof.
    let v := Reify (fun x y => (fun f a b => f a b) (fun a b => a + b) (x + y) (x * y))%Z in
    pose v as E.
    vm_compute in E.
    pose (Uncurry.expr.Uncurry (partial.Eval true (canonicalize_list_recursion E))) as E'.
    lazy in E'.
    clear E.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var =>
         (λ x,
          ident.fst @@@ $x + ident.snd @@@ $x + ident.fst @@@ $x * ident.snd @@@ $x)%expr)
      => idtac
    end.
    constructor.
  Qed.
End test11.
 *)
Module test12.
  Example test12 : True.
  Proof.
    let v := Reify (fun y : list Z => repeat y 2) in
    pose v as E.
    vm_compute in E.
    pose (Some (repeat (@None zrange) 3), Datatypes.tt) as bound.
    pose (PartialEvaluate RewriteRules.default_opts (partial.EtaExpandWithListInfoFromBound E bound)) as E'.
    lazy in E'.
    clear E.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var
       => (λ x, [ [ $x[[0]] ; $x[[1]]; $x[[2]] ] ; [ $x[[0]] ; $x[[1]]; $x[[2]] ] ])%expr)
      => idtac
    end.
    exact I.
  Qed.
End test12.
Module test13.
  Example test13 : True.
  Proof.
    let v0 := constr:(nat_rect (fun _ => nat -> nat) (fun v => v) (fun n' rec v => (n' + rec (S v))%nat) 3 0%nat) in
    let v := Reify v0 in
    pose v as E;
      pose v0 as exp.
    vm_compute in E.
    vm_compute in exp.
    pose (PartialEvaluate RewriteRules.default_opts E) as E'.
    vm_compute in E'.
    clear E.
    let r := Reify exp in
    unify r E'.
    exact I.
  Qed.
End test13.
Module test14.
  Import PreExtra.
  Local Open Scope string_scope.
  Example test14 : True.
  Proof.
    let v := Reify (fun y : Z
                    => dlet_nd x := y + y in
                        dlet_nd z := y + y in
                        dlet_nd w := y + y in
                        dlet_nd v := y + y in
                        dlet_nd __ := ident.comment ("note", (x, x, z, z)) in
                        dlet_nd __ := ident.comment_no_keep ("note", (w, w, v, v)) in
                        y) in
    pose v as E.
    vm_compute in E.
    pose (Subst01.Subst01 ident.is_comment (DeadCodeElimination.EliminateDead ident.is_comment E)) as E''.
    lazy in E''.
    pose (PartialEvaluate RewriteRules.default_opts E'') as E'''.
    vm_compute in E'''.
    pose (partial.EvalWithBound partial.default_relax_zrange false (@ident.is_comment) true E''' (Some r[0~>1]%zrange, tt)) as E''''.
    lazy in E''''.
    unify E E''.
    unify E'' E'''.
    lazymatch (eval cbv [E''''] in E'''') with
    | fun var : type -> Type =>
        (λ x : var (type.base (base.type.type_base Compilers.Z)),
               expr_let v := cstZ r[0 ~> 2] @
                                  (cstZ r[0 ~> 1] @ $x + cstZ r[0 ~> 1] @ $x) in
             expr_let v0 := cstZ r[0 ~> 2] @
                                 (cstZ r[0 ~> 1] @ $x + cstZ r[0 ~> 1] @ $x) in
             expr_let v1 := cstZ r[0 ~> 2] @
                                 (cstZ r[0 ~> 1] @ $x + cstZ r[0 ~> 1] @ $x) in
             expr_let v2 := cstZ r[0 ~> 2] @
                                 (cstZ r[0 ~> 1] @ $x + cstZ r[0 ~> 1] @ $x) in
             expr_let _ := #Compilers.ident_comment @ (###_, ($v, $v, $v0, $v0)) in
             expr_let _ := #Compilers.ident_comment_no_keep @
                            (###_, ($v1, $v1, $v2, $v2)) in
             cstZ r[0 ~> 1] @ $x)%expr
      => idtac
    end.
    exact I.
  Qed.
End test14.


(** This file collects general purpose definitions and theorems on the option
data type that are not in the Coq standard library. *)
From stdpp Require Export tactics.
From stdpp Require Import options.

Inductive option_reflect {A} (P : A → Prop) (Q : Prop) : option A → Type :=
  | ReflectSome x : P x → option_reflect P Q (Some x)
  | ReflectNone : Q → option_reflect P Q None.

(** * General definitions and theorems *)
(** Basic properties about equality. *)
Lemma None_ne_Some {A} (x : A) : None ≠ Some x.
Proof. congruence. Qed.
Lemma Some_ne_None {A} (x : A) : Some x ≠ None.
Proof. congruence. Qed.
Lemma eq_None_ne_Some {A} (mx : option A) x : mx = None → mx ≠ Some x.
Proof. congruence. Qed.
Instance Some_inj {A} : Inj (=) (=) (@Some A).
Proof. congruence. Qed.

(** The [from_option] is the eliminator for option. *)
Definition from_option {A B} (f : A → B) (y : B) (mx : option A) : B :=
  match mx with None => y | Some x => f x end.
Instance: Params (@from_option) 3 := {}.
Arguments from_option {_ _} _ _ !_ / : assert.

(** The eliminator with the identity function. *)
Notation default := (from_option id).

(** An alternative, but equivalent, definition of equality on the option
data type. This theorem is useful to prove that two options are the same. *)
Lemma option_eq {A} (mx my: option A): mx = my ↔ ∀ x, mx = Some x ↔ my = Some x.
Proof. split; [by intros; by subst |]. destruct mx, my; naive_solver. Qed.
Lemma option_eq_1 {A} (mx my: option A) x : mx = my → mx = Some x → my = Some x.
Proof. congruence. Qed.
Lemma option_eq_1_alt {A} (mx my : option A) x :
  mx = my → my = Some x → mx = Some x.
Proof. congruence. Qed.

Definition is_Some {A} (mx : option A) := ∃ x, mx = Some x.
Instance: Params (@is_Some) 1 := {}.

Lemma is_Some_alt {A} (mx : option A) :
  is_Some mx ↔ match mx with Some _ => True | None => False end.
Proof. unfold is_Some. destruct mx; naive_solver. Qed.

Lemma mk_is_Some {A} (mx : option A) x : mx = Some x → is_Some mx.
Proof. intros; red; subst; eauto. Qed.
Hint Resolve mk_is_Some : core.
Lemma is_Some_None {A} : ¬is_Some (@None A).
Proof. by destruct 1. Qed.
Hint Resolve is_Some_None : core.

Lemma eq_None_not_Some {A} (mx : option A) : mx = None ↔ ¬is_Some mx.
Proof. rewrite is_Some_alt; destruct mx; naive_solver. Qed.
Lemma not_eq_None_Some {A} (mx : option A) : mx ≠ None ↔ is_Some mx.
Proof. rewrite is_Some_alt; destruct mx; naive_solver. Qed.

Instance is_Some_pi {A} (mx : option A) : ProofIrrel (is_Some mx).
Proof.
  set (P (mx : option A) := match mx with Some _ => True | _ => False end).
  set (f mx := match mx return P mx → is_Some mx with
    Some _ => λ _, ex_intro _ _ eq_refl | None => False_rect _ end).
  set (g mx (H : is_Some mx) :=
    match H return P mx with ex_intro _ _ p => eq_rect _ _ I _ (eq_sym p) end).
  assert (∀ mx H, f mx (g mx H) = H) as f_g by (by intros ? [??]; subst).
  intros p1 p2. rewrite <-(f_g _ p1), <-(f_g _ p2). by destruct mx, p1.
Qed.

Instance is_Some_dec {A} (mx : option A) : Decision (is_Some mx) :=
  match mx with
  | Some x => left (ex_intro _ x eq_refl)
  | None => right is_Some_None
  end.

Definition is_Some_proj {A} {mx : option A} : is_Some mx → A :=
  match mx with Some x => λ _, x | None => False_rect _ ∘ is_Some_None end.

Definition Some_dec {A} (mx : option A) : { x | mx = Some x } + { mx = None } :=
  match mx return { x | mx = Some x } + { mx = None } with
  | Some x => inleft (x ↾ eq_refl _)
  | None => inright eq_refl
  end.

(** Lifting a relation point-wise to option *)
Inductive option_Forall2 {A B} (R: A → B → Prop) : option A → option B → Prop :=
  | Some_Forall2 x y : R x y → option_Forall2 R (Some x) (Some y)
  | None_Forall2 : option_Forall2 R None None.
Definition option_relation {A B} (R: A → B → Prop) (P: A → Prop) (Q: B → Prop)
    (mx : option A) (my : option B) : Prop :=
  match mx, my with
  | Some x, Some y => R x y
  | Some x, None => P x
  | None, Some y => Q y
  | None, None => True
  end.

Section Forall2.
  Context {A} (R : relation A).

  Global Instance option_Forall2_refl : Reflexive R → Reflexive (option_Forall2 R).
  Proof. intros ? [?|]; by constructor. Qed.
  Global Instance option_Forall2_sym : Symmetric R → Symmetric (option_Forall2 R).
  Proof. destruct 2; by constructor. Qed.
  Global Instance option_Forall2_trans : Transitive R → Transitive (option_Forall2 R).
  Proof. destruct 2; inversion_clear 1; constructor; etrans; eauto. Qed.
  Global Instance option_Forall2_equiv : Equivalence R → Equivalence (option_Forall2 R).
  Proof. destruct 1; split; apply _. Qed.
End Forall2.

(** Setoids *)
Instance option_equiv `{Equiv A} : Equiv (option A) := option_Forall2 (≡).

Section setoids.
  Context `{Equiv A}.
  Implicit Types mx my : option A.

  Lemma equiv_option_Forall2 mx my : mx ≡ my ↔ option_Forall2 (≡) mx my.
  Proof. done. Qed.

  Global Instance option_equivalence :
    Equivalence (≡@{A}) → Equivalence (≡@{option A}).
  Proof. apply _. Qed.
  Global Instance Some_proper : Proper ((≡) ==> (≡@{option A})) Some.
  Proof. by constructor. Qed.
  Global Instance Some_equiv_inj : Inj (≡) (≡@{option A}) Some.
  Proof. by inversion_clear 1. Qed.
  Global Instance option_leibniz `{!LeibnizEquiv A} : LeibnizEquiv (option A).
  Proof. intros x y; destruct 1; f_equal; by apply leibniz_equiv. Qed.

  Lemma equiv_None mx : mx ≡ None ↔ mx = None.
  Proof. split; [by inversion_clear 1|intros ->; constructor]. Qed.
  Lemma equiv_Some_inv_l mx my x :
    mx ≡ my → mx = Some x → ∃ y, my = Some y ∧ x ≡ y.
  Proof. destruct 1; naive_solver. Qed.
  Lemma equiv_Some_inv_r mx my y :
    mx ≡ my → my = Some y → ∃ x, mx = Some x ∧ x ≡ y.
  Proof. destruct 1; naive_solver. Qed.
  Lemma equiv_Some_inv_l' my x : Some x ≡ my → ∃ x', Some x' = my ∧ x ≡ x'.
  Proof. intros ?%(equiv_Some_inv_l _ _ x); naive_solver. Qed.
  Lemma equiv_Some_inv_r' `{!Equivalence (≡@{A})} mx y :
    mx ≡ Some y → ∃ y', mx = Some y' ∧ y ≡ y'.
  Proof. intros ?%(equiv_Some_inv_r _ _ y); naive_solver. Qed.

  Global Instance is_Some_proper : Proper ((≡@{option A}) ==> iff) is_Some.
  Proof. inversion_clear 1; split; eauto. Qed.
  Global Instance from_option_proper {B} (R : relation B) (f : A → B) :
    Proper ((≡) ==> R) f → Proper (R ==> (≡) ==> R) (from_option f).
  Proof. destruct 3; simpl; auto. Qed.
End setoids.

Typeclasses Opaque option_equiv.

(** Equality on [option] is decidable. *)
Instance option_eq_None_dec {A} (mx : option A) : Decision (mx = None) :=
  match mx with Some _ => right (Some_ne_None _) | None => left eq_refl end.
Instance option_None_eq_dec {A} (mx : option A) : Decision (None = mx) :=
  match mx with Some _ => right (None_ne_Some _) | None => left eq_refl end.
Instance option_eq_dec `{dec : EqDecision A} : EqDecision (option A).
Proof.
 refine (λ mx my,
  match mx, my with
  | Some x, Some y => cast_if (decide (x = y))
  | None, None => left _ | _, _ => right _
  end); clear dec; abstract congruence.
Defined.

(** * Monadic operations *)
Instance option_ret: MRet option := @Some.
Instance option_bind: MBind option := λ A B f mx,
  match mx with Some x => f x | None => None end.
Instance option_join: MJoin option := λ A mmx,
  match mmx with Some mx => mx | None => None end.
Instance option_fmap: FMap option := @option_map.
Instance option_guard: MGuard option := λ P dec A f,
  match dec with left H => f H | _ => None end.

Lemma fmap_is_Some {A B} (f : A → B) mx : is_Some (f <$> mx) ↔ is_Some mx.
Proof. unfold is_Some; destruct mx; naive_solver. Qed.
Lemma fmap_Some {A B} (f : A → B) mx y :
  f <$> mx = Some y ↔ ∃ x, mx = Some x ∧ y = f x.
Proof. destruct mx; naive_solver. Qed.
Lemma fmap_Some_1 {A B} (f : A → B) mx y :
  f <$> mx = Some y → ∃ x, mx = Some x ∧ y = f x.
Proof. apply fmap_Some. Qed.
Lemma fmap_Some_2 {A B} (f : A → B) mx x : mx = Some x → f <$> mx = Some (f x).
Proof. intros. apply fmap_Some; eauto. Qed.
Lemma fmap_Some_equiv {A B} `{Equiv B} `{!Equivalence (≡@{B})} (f : A → B) mx y :
  f <$> mx ≡ Some y ↔ ∃ x, mx = Some x ∧ y ≡ f x.
Proof.
  destruct mx; simpl; split.
  - intros ?%(inj Some). eauto.
  - intros (? & ->%(inj Some) & ?). constructor. done.
  - intros ?%symmetry%equiv_None. done.
  - intros (? & ? & ?). done.
Qed.
Lemma fmap_Some_equiv_1 {A B} `{Equiv B} `{!Equivalence (≡@{B})} (f : A → B) mx y :
  f <$> mx ≡ Some y → ∃ x, mx = Some x ∧ y ≡ f x.
Proof. by rewrite fmap_Some_equiv. Qed.
Lemma fmap_None {A B} (f : A → B) mx : f <$> mx = None ↔ mx = None.
Proof. by destruct mx. Qed.
Lemma option_fmap_id {A} (mx : option A) : id <$> mx = mx.
Proof. by destruct mx. Qed.
Lemma option_fmap_compose {A B} (f : A → B) {C} (g : B → C) mx :
  g ∘ f <$> mx = g <$> (f <$> mx).
Proof. by destruct mx. Qed.
Lemma option_fmap_ext {A B} (f g : A → B) mx :
  (∀ x, f x = g x) → f <$> mx = g <$> mx.
Proof. intros; destruct mx; f_equal/=; auto. Qed.
Lemma option_fmap_equiv_ext {A} `{Equiv B} (f g : A → B) (mx : option A) :
  (∀ x, f x ≡ g x) → f <$> mx ≡ g <$> mx.
Proof. destruct mx; constructor; auto. Qed.
Lemma option_fmap_bind {A B C} (f : A → B) (g : B → option C) mx :
  (f <$> mx) ≫= g = mx ≫= g ∘ f.
Proof. by destruct mx. Qed.
Lemma option_bind_assoc {A B C} (f : A → option B)
  (g : B → option C) (mx : option A) : (mx ≫= f) ≫= g = mx ≫= (mbind g ∘ f).
Proof. by destruct mx; simpl. Qed.
Lemma option_bind_ext {A B} (f g : A → option B) mx my :
  (∀ x, f x = g x) → mx = my → mx ≫= f = my ≫= g.
Proof. destruct mx, my; naive_solver. Qed.
Lemma option_bind_ext_fun {A B} (f g : A → option B) mx :
  (∀ x, f x = g x) → mx ≫= f = mx ≫= g.
Proof. intros. by apply option_bind_ext. Qed.
Lemma bind_Some {A B} (f : A → option B) (mx : option A) y :
  mx ≫= f = Some y ↔ ∃ x, mx = Some x ∧ f x = Some y.
Proof. destruct mx; naive_solver. Qed.
Lemma bind_None {A B} (f : A → option B) (mx : option A) :
  mx ≫= f = None ↔ mx = None ∨ ∃ x, mx = Some x ∧ f x = None.
Proof. destruct mx; naive_solver. Qed.
Lemma bind_with_Some {A} (mx : option A) : mx ≫= Some = mx.
Proof. by destruct mx. Qed.

Instance option_fmap_proper `{Equiv A, Equiv B} :
  Proper (((≡) ==> (≡)) ==> (≡@{option A}) ==> (≡@{option B})) fmap.
Proof. destruct 2; constructor; auto. Qed.
Instance option_mbind_proper `{Equiv A, Equiv B} :
  Proper (((≡) ==> (≡)) ==> (≡@{option A}) ==> (≡@{option B})) mbind.
Proof. destruct 2; simpl; try constructor; auto. Qed.
Instance option_mjoin_proper `{Equiv A} :
  Proper ((≡) ==> (≡@{option (option A)})) mjoin.
Proof. destruct 1 as [?? []|]; simpl; by constructor. Qed.

(** ** Inverses of constructors *)
(** We can do this in a fancy way using dependent types, but rewrite does
not particularly like type level reductions. *)
Class Maybe {A B : Type} (c : A → B) :=
  maybe : B → option A.
Arguments maybe {_ _} _ {_} !_ / : assert.
Class Maybe2 {A1 A2 B : Type} (c : A1 → A2 → B) :=
  maybe2 : B → option (A1 * A2).
Arguments maybe2 {_ _ _} _ {_} !_ / : assert.
Class Maybe3 {A1 A2 A3 B : Type} (c : A1 → A2 → A3 → B) :=
  maybe3 : B → option (A1 * A2 * A3).
Arguments maybe3 {_ _ _ _} _ {_} !_ / : assert.
Class Maybe4 {A1 A2 A3 A4 B : Type} (c : A1 → A2 → A3 → A4 → B) :=
  maybe4 : B → option (A1 * A2 * A3 * A4).
Arguments maybe4 {_ _ _ _ _} _ {_} !_ / : assert.

Instance maybe_comp `{Maybe B C c1, Maybe A B c2} : Maybe (c1 ∘ c2) := λ x,
  maybe c1 x ≫= maybe c2.
Arguments maybe_comp _ _ _ _ _ _ _ !_ / : assert.

Instance maybe_inl {A B} : Maybe (@inl A B) := λ xy,
  match xy with inl x => Some x | _ => None end.
Instance maybe_inr {A B} : Maybe (@inr A B) := λ xy,
  match xy with inr y => Some y | _ => None end.
Instance maybe_Some {A} : Maybe (@Some A) := id.
Arguments maybe_Some _ !_ / : assert.

(** * Union, intersection and difference *)
Instance option_union_with {A} : UnionWith A (option A) := λ f mx my,
  match mx, my with
  | Some x, Some y => f x y
  | Some x, None => Some x
  | None, Some y => Some y
  | None, None => None
  end.
Instance option_intersection_with {A} : IntersectionWith A (option A) :=
  λ f mx my, match mx, my with Some x, Some y => f x y | _, _ => None end.
Instance option_difference_with {A} : DifferenceWith A (option A) := λ f mx my,
  match mx, my with
  | Some x, Some y => f x y
  | Some x, None => Some x
  | None, _ => None
  end.
Instance option_union {A} : Union (option A) := union_with (λ x _, Some x).

Lemma option_union_Some {A} (mx my : option A) z :
  mx ∪ my = Some z → mx = Some z ∨ my = Some z.
Proof. destruct mx, my; naive_solver. Qed.

Class DiagNone {A B C} (f : option A → option B → option C) :=
  diag_none : f None None = None.

Section union_intersection_difference.
  Context {A} (f : A → A → option A).

  Global Instance union_with_diag_none : DiagNone (union_with f).
  Proof. reflexivity. Qed.
  Global Instance intersection_with_diag_none : DiagNone (intersection_with f).
  Proof. reflexivity. Qed.
  Global Instance difference_with_diag_none : DiagNone (difference_with f).
  Proof. reflexivity. Qed.
  Global Instance union_with_left_id : LeftId (=) None (union_with f).
  Proof. by intros [?|]. Qed.
  Global Instance union_with_right_id : RightId (=) None (union_with f).
  Proof. by intros [?|]. Qed.
  Global Instance union_with_comm :
    Comm (=) f → Comm (=@{option A}) (union_with f).
  Proof. by intros ? [?|] [?|]; compute; rewrite 1?(comm f). Qed.
  Global Instance intersection_with_left_ab : LeftAbsorb (=) None (intersection_with f).
  Proof. by intros [?|]. Qed.
  Global Instance intersection_with_right_ab : RightAbsorb (=) None (intersection_with f).
  Proof. by intros [?|]. Qed.
  Global Instance difference_with_comm :
    Comm (=) f → Comm (=@{option A}) (intersection_with f).
  Proof. by intros ? [?|] [?|]; compute; rewrite 1?(comm f). Qed.
  Global Instance difference_with_right_id : RightId (=) None (difference_with f).
  Proof. by intros [?|]. Qed.
End union_intersection_difference.

(** * Tactics *)
Tactic Notation "case_option_guard" "as" ident(Hx) :=
  match goal with
  | H : context C [@mguard option _ ?P ?dec] |- _ =>
    change (@mguard option _ P dec) with (λ A (f : P → option A),
      match @decide P dec with left H' => f H' | _ => None end) in *;
    destruct_decide (@decide P dec) as Hx
  | |- context C [@mguard option _ ?P ?dec] =>
    change (@mguard option _ P dec) with (λ A (f : P → option A),
      match @decide P dec with left H' => f H' | _ => None end) in *;
    destruct_decide (@decide P dec) as Hx
  end.
Tactic Notation "case_option_guard" :=
  let H := fresh in case_option_guard as H.

Lemma option_guard_True {A} P `{Decision P} (mx : option A) :
  P → (guard P; mx) = mx.
Proof. intros. by case_option_guard. Qed.
Lemma option_guard_False {A} P `{Decision P} (mx : option A) :
  ¬P → (guard P; mx) = None.
Proof. intros. by case_option_guard. Qed.
Lemma option_guard_iff {A} P Q `{Decision P, Decision Q} (mx : option A) :
  (P ↔ Q) → (guard P; mx) = guard Q; mx.
Proof. intros [??]. repeat case_option_guard; intuition. Qed.

Tactic Notation "simpl_option" "by" tactic3(tac) :=
  let assert_Some_None A mx H := first
    [ let x := fresh in evar (x:A); let x' := eval unfold x in x in clear x;
      assert (mx = Some x') as H by tac
    | assert (mx = None) as H by tac ]
  in repeat match goal with
  | H : context [@mret _ _ ?A] |- _ =>
     change (@mret _ _ A) with (@Some A) in H
  | |- context [@mret _ _ ?A] => change (@mret _ _ A) with (@Some A)
  | H : context [mbind (M:=option) (A:=?A) ?f ?mx] |- _ =>
    let Hx := fresh in assert_Some_None A mx Hx; rewrite Hx in H; clear Hx
  | H : context [fmap (M:=option) (A:=?A) ?f ?mx] |- _ =>
    let Hx := fresh in assert_Some_None A mx Hx; rewrite Hx in H; clear Hx
  | H : context [from_option (A:=?A) _ _ ?mx] |- _ =>
    let Hx := fresh in assert_Some_None A mx Hx; rewrite Hx in H; clear Hx
  | H : context [ match ?mx with _ => _ end ] |- _ =>
    match type of mx with
    | option ?A =>
      let Hx := fresh in assert_Some_None A mx Hx; rewrite Hx in H; clear Hx
    end
  | |- context [mbind (M:=option) (A:=?A) ?f ?mx] =>
    let Hx := fresh in assert_Some_None A mx Hx; rewrite Hx; clear Hx
  | |- context [fmap (M:=option) (A:=?A) ?f ?mx] =>
    let Hx := fresh in assert_Some_None A mx Hx; rewrite Hx; clear Hx
  | |- context [from_option (A:=?A) _ _ ?mx] =>
    let Hx := fresh in assert_Some_None A mx Hx; rewrite Hx; clear Hx
  | |- context [ match ?mx with _ => _ end ] =>
    match type of mx with
    | option ?A =>
      let Hx := fresh in assert_Some_None A mx Hx; rewrite Hx; clear Hx
    end
  | H : context [decide _] |- _ => rewrite decide_True in H by tac
  | H : context [decide _] |- _ => rewrite decide_False in H by tac
  | H : context [mguard _ _] |- _ => rewrite option_guard_False in H by tac
  | H : context [mguard _ _] |- _ => rewrite option_guard_True in H by tac
  | _ => rewrite decide_True by tac
  | _ => rewrite decide_False by tac
  | _ => rewrite option_guard_True by tac
  | _ => rewrite option_guard_False by tac
  | H : context [None ∪ _] |- _ => rewrite (left_id_L None (∪)) in H
  | H : context [_ ∪ None] |- _ => rewrite (right_id_L None (∪)) in H
  | |- context [None ∪ _] => rewrite (left_id_L None (∪))
  | |- context [_ ∪ None] => rewrite (right_id_L None (∪))
  end.
Tactic Notation "simplify_option_eq" "by" tactic3(tac) :=
  repeat match goal with
  | _ => progress simplify_eq/=
  | _ => progress simpl_option by tac
  | _ : maybe _ ?x = Some _ |- _ => is_var x; destruct x
  | _ : maybe2 _ ?x = Some _ |- _ => is_var x; destruct x
  | _ : maybe3 _ ?x = Some _ |- _ => is_var x; destruct x
  | _ : maybe4 _ ?x = Some _ |- _ => is_var x; destruct x
  | H : _ ∪ _ = Some _ |- _ => apply option_union_Some in H; destruct H
  | H : mbind (M:=option) ?f ?mx = ?my |- _ =>
    match mx with Some _ => fail 1 | None => fail 1 | _ => idtac end;
    match my with Some _ => idtac | None => idtac | _ => fail 1 end;
    let x := fresh in destruct mx as [x|] eqn:?;
      [change (f x = my) in H|change (None = my) in H]
  | H : ?my = mbind (M:=option) ?f ?mx |- _ =>
    match mx with Some _ => fail 1 | None => fail 1 | _ => idtac end;
    match my with Some _ => idtac | None => idtac | _ => fail 1 end;
    let x := fresh in destruct mx as [x|] eqn:?;
      [change (my = f x) in H|change (my = None) in H]
  | H : fmap (M:=option) ?f ?mx = ?my |- _ =>
    match mx with Some _ => fail 1 | None => fail 1 | _ => idtac end;
    match my with Some _ => idtac | None => idtac | _ => fail 1 end;
    let x := fresh in destruct mx as [x|] eqn:?;
      [change (Some (f x) = my) in H|change (None = my) in H]
  | H : ?my = fmap (M:=option) ?f ?mx |- _ =>
    match mx with Some _ => fail 1 | None => fail 1 | _ => idtac end;
    match my with Some _ => idtac | None => idtac | _ => fail 1 end;
    let x := fresh in destruct mx as [x|] eqn:?;
      [change (my = Some (f x)) in H|change (my = None) in H]
  | _ => progress case_decide
  | _ => progress case_option_guard
  end.
Tactic Notation "simplify_option_eq" := simplify_option_eq by eauto.