Require Import ZArith.
Require Import Ensembles.
Require Import util.

Set Implicit Arguments.

Ltac decide_equality := decide equality; auto with equality arith.

Definition Word := nat.

Definition Address := Word.

Definition Value := Word.
Hypothesis eqValue_dec : forall (x y: Value), {x=y} + {x <> y}.
(*Hint Resolve eqValue_dec : equality.*)

Definition Proc := nat.
Hypothesis eqProc_dec : forall (x y: Proc), {x=y} + {x <> y}.
(*Hint Resolve eqProc_dec : equality.*)

Definition program_order_index := nat.
Lemma eqPoi_dec : forall (x y: program_order_index), {x=y} + {x <> y}.
Proof.
decide_equality.
Defined.
Hint Resolve eqPoi_dec : equality.

Record Iiid  : Set := mkiiid {
  proc : Proc;
  poi: program_order_index }.
Lemma eqIiid_dec : forall (x y: Iiid), {x=y} + {x <> y}.
Proof.
decide_equality.
Defined.
(*Hint Resolve eqIiid_dec : equality.*)

Definition Eiid := nat.
Lemma eqEiid_dec : forall (x y: Eiid), {x=y} + {x<>y}.
Proof.
decide_equality.
Defined.
(*Hint Resolve eqEiid_dec : equality.*)

Inductive Dirn : Set :=
  | R : Dirn
  | W : Dirn.
Lemma eqDirn_dec : forall (x y: Dirn), {x=y} + {x <> y}.
Proof.
decide_equality.
Defined.
Hint Resolve eqDirn_dec.

Definition Location := Address.

Lemma eqLoc_dec : forall (x y: Location), {x=y} + {x <> y}.
Proof.
decide_equality.
Defined.
Hint Resolve eqLoc_dec : equality.

Inductive Action : Set :=
  | Access : Dirn -> Location -> Value -> Action.
Lemma eqAction_dec : forall (x y: Action), {x=y} + {x <> y}.
Proof.
decide_equality.
Defined.
Hint Resolve eqAction_dec : equality.

Record Event := mkev {
  eiid : Eiid;
  iiid : Iiid;
  action : Action}.
Lemma eqEv_dec : forall (x y: Event), {x=y} + {x <> y}.
Proof.
decide_equality.
decide_equality.
Defined.
Hint Resolve eqEv_dec : equality.

Lemma eqEvc_dec : forall (x y: Event*Event), {x=y} + {x <> y}.
Proof.
decide_equality.
Defined.
Hint Resolve eqEvc_dec : equality.

(*Module OEEvt.
Parameter LE : Rln Event -> Rln Event.
Hypothesis OE : forall (s S:set Event) (r:Rln Event),
  Included _ s S ->
  partial_order r s ->
  rel_incl r (LE r) /\
  linear_strict_order (LE r) S.
Hypothesis le_lso : forall (s:set Event) (r:Rln Event),
  linear_strict_order r s -> LE r = r.
End OEEvt.
Import OEEvt.*)

Record Event_struct : Type := mkes {
  events : set Event;
  iico : Rln Event}.

Definition po (es: Event_struct) : set (Event*Event) :=
  fun c => match c with (e1,e2) =>
   (* both events have same processor *)
  (e1.(iiid).(proc) = e2.(iiid).(proc)) /\
  (* the program order index of e1 is less than the program order index of e2 *)
  (le e1.(iiid).(poi) e2.(iiid).(poi)) /\
  (* both e1 and e2 are in the events of e *)
  (In _ es.(events) e1) /\
  (In _ es.(events) e2)
  end.

Definition po_strict (es: Event_struct) : Rln Event :=
  fun e1 => fun e2 =>
   (* both events have same processor *)
  (e1.(iiid).(proc) = e2.(iiid).(proc)) /\
  (* the program order index of e1 is less than the program order index of e2 *)
  (lt e1.(iiid).(poi) e2.(iiid).(poi)) /\
  (* both e1 and e2 are in the events of e *)
  (In _ es.(events) e1) /\
  (In _ es.(events) e2).

Definition po_iico (E:Event_struct) : Rln Event :=
  fun e1 => fun e2 =>
    (po_strict E) e1 e2 \/ (iico E) e1 e2.

Definition loc (e:Event) : (*option*) Location :=
match e.(action) with
  | Access _ l _ => (*Some*) l
end.

Definition value_of (e:Event) : (*option*) Value :=
  match e.(action) with
  | Access _ _ v => (*Some*) v
  end.

Definition proc_of (e:Event) : Proc := e.(iiid).(proc).

Definition procs (es: Event_struct) : set Proc :=
   fun p => exists e,
     In _ es.(events) e /\
     p = proc_of e.

Definition to_shared (s:set Event) : set (Event) :=
  fun e => In _ s e /\ exists l, exists a, l = a /\ loc e = (*Some*) l.

Definition reads (es:Event_struct) : set Event :=
  fun e => (In _ es.(events) e) /\ (exists l, exists v, e.(action) = Access R l v).

Definition writes (es:Event_struct) : set Event :=
  fun e => (In _ es.(events) e) /\ (exists l, exists v, e.(action) = Access W l v).

Definition po_loc (E:Event_struct) : Rln Event :=
  fun e1 => fun e2 => loc e1 = loc e2 /\ po_iico E e1 e2.
Definition po_loc_llh (E:Event_struct) : Rln Event :=
  fun e1 => fun e2 => loc e1 = loc e2 /\ po_iico E e1 e2 /\
    ~(reads E e1 /\ reads E e2).

Definition well_formed_event_structure (E:Event_struct) : Prop :=
  (forall x y, po_iico E x y -> proc_of x = proc_of y) /\
  (forall e1 e2, In _ E.(events) e1 -> In _ E.(events) e2 ->
   (e1.(eiid) = e2.(eiid)) /\ (e1.(iiid) = e2.(iiid)) -> (e1 = e2)) /\
   Included _ (dom (iico E)) E.(events) /\
   Included _ (ran (iico E)) E.(events) /\
   acyclic (iico E) /\ (forall x y, events E x /\ events E y /\ poi (iiid x) = poi (iiid y) /\ proc_of x = proc_of y -> x <> y -> iico E x y) /\
    (forall e1 e2, (iico E) e1 e2 -> (e1.(iiid) = e2.(iiid))) /\
   trans (iico E).

Definition Coherence := Rln Event.

Definition write_to (e:Event) (l:Location) : Prop :=
  exists v, action e = Access W l v.

Definition writes_to_same_loc_l (s:set Event) (l:Location) : set Event :=
  fun e => In _ s e /\ write_to e l.

Definition coherence_well_formed (s:set Event) (co:Coherence) : Prop :=
  (forall l, linear_strict_order
     (rrestrict co (writes_to_same_loc_l s l)) (writes_to_same_loc_l s l)) (*Hws_tot*) /\
  (forall x e, co x e ->
   (exists l : Location,
    In _ (writes_to_same_loc_l s l) x /\
    In _ (writes_to_same_loc_l s l) e)) (*Hws_cands*).
Definition write_serialization_well_formed (s:set Event) (co:Coherence) :=
  coherence_well_formed s co.

Ltac destruct_ws H :=
  destruct H as [Hws_tot Hws_cands].

Definition Rfmap := Rln Event.

Definition read_from (e:Event) (l:Location) : Prop :=
  exists v, action e = Access R l v.

Definition rfmaps (s:set Event) : Rln Event :=
  fun e1 => fun e2 =>
  In _ s e1 /\ In _ s e2 /\
  exists l, write_to e1 l /\ read_from e2 l /\
    value_of e1 = value_of e2.

Definition no_intervening_write (e1 e2:Event) (s:Rln Event): Prop :=
  s e1 e2 /\
  forall l, write_to e1 l ->
    ~(exists e3, write_to e3 l /\ s e1 e3 /\ s e3 e2).

Definition ls (E:Event_struct) : Rln Event :=
  fun e1 => fun e2 =>
    In _ (reads E) e1 /\ In _ (writes E) e2 /\ (po_iico E) e1 e2.

Definition rfmaps_well_formed (E:Event_struct) (s:set Event) (rf:Rfmap) : Prop :=
  (forall er, In _ (reads E) er -> exists ew,
     ((In _ s ew) /\ rf ew er)) /\ (*Hrf_init*)
  (forall e1 e2, rf e1 e2 -> (rfmaps s) e1 e2) /\ (*Hrf_cands*)
   (forall x w1 w2, rf w1 x -> rf w2 x ->
    w1 = w2).  (*Hrf_uni*)

Ltac destruct_rf H :=
  destruct H as [Hrf_init [Hrf_cands Hrf_uni]].

Definition Frmap := Rln Event.

Definition frmaps (s:set Event) (rf:Rfmap) (co:Coherence) : Frmap :=
  fun er => fun ew => In _ s er /\ In _ s ew /\
    exists wr, rf wr er /\ co wr ew.

Definition AB := Rln Event.

Definition ab_well_formed (s:set Event) (abc : AB) :=
  (forall x y, abc x y -> In _ s x /\ In _ s y /\ x<>y).

Record Execution_witness : Type := mkew {
  co : Coherence;
  rf : Rfmap}.
Definition ws X := co X.

Definition fr (E:Event_struct) (X:Execution_witness) : Frmap :=
  frmaps (events E) (rf X) (co X).
Definition rfi (X:Execution_witness) : Rfmap :=
  fun ew => fun er => (rf X) ew er /\ proc_of ew = proc_of er.
Definition rfe (X:Execution_witness) : Rfmap :=
  fun ew => fun er => (rf X) ew er /\ proc_of ew <> proc_of er.

Definition com (E:Event_struct) (X:Execution_witness) : Rln Event :=
  rel_union (rel_union (rf X) (fr E X)) (co X).

Module Type Dp.
Parameter dp : Event_struct -> Rln Event.
Hypothesis dp_valid : forall (E:Event_struct),
  rel_incl (dp E) (po_iico E) /\ trans (dp E) /\
  forall x y, dp E x y -> reads E x.
(*Hypothesis dp_fun :
  forall E s x y,
  dp E x y /\ s x /\ s y <->
  dp (mkes (Intersection Event (events E) s) (rrestrict (iico E) s)) x y.*)
End Dp.

Set Implicit Arguments.
Definition rfc (A:Type) (rfe:Rln A) (r:Rln A) :=
  rel_union r (rel_union (rel_seq rfe r) (rel_union (rel_seq r rfe) (rel_seq rfe (rel_seq r rfe)))).
Unset Implicit Arguments.

Module Type Archi.
Parameter llh : bool.
Parameter ppo : Event_struct -> Rln Event.
Hypothesis ppo_valid : forall (E:Event_struct),
  rel_incl (ppo E) (po_iico E).
Parameter fences : Event_struct -> Rln Event.
Hypothesis fences_valid : forall (E:Event_struct),
  rel_incl (fences E) (po_iico E).
Parameter prop : Event_struct -> Execution_witness -> Rln Event.
Hypothesis prop_valid : forall E X, ~(exists x, (prop E X) x x).
Hypothesis prop_trans : forall E X, trans (prop E X).
Hypothesis wit_incl :
  forall E X X' e1 e2,
  ((rf X) e1 e2 -> (rf X') e1 e2) ->
  prop E X e1 e2 ->
  prop E X' e1 e2.
End Archi.

Module Wmm (A : Archi) (dp : Dp).
Import A.
Import dp.

Definition hb (E:Event_struct) (X:Execution_witness) : Rln Event :=
  rel_union (rfe X) (tc (rel_union (A.ppo E) (A.fences E))).

Definition com' (E:Event_struct) (X:Execution_witness) : util.Rln Event :=
  fun e1 => fun e2 => (rel_union (rel_union (com E X) (rel_seq (ws X) (rf X))) (rel_seq (fr E X) (rf X))) e1 e2.

Definition com_vs_po E X (r:Rln Event) :=
  (forall e1 e2, r e1 e2 -> ~(com' E X e2 e1)).

Definition uniproc E X :=
  (*if llh then*) com_vs_po E X (po_loc_llh E)
  (*else com_vs_po E X (po_loc E)*).

Definition valid_execution (E:Event_struct) (X:Execution_witness) : Prop :=
  coherence_well_formed (events E) (co X) /\
  rfmaps_well_formed E (events E) (rf X) /\
  uniproc E X /\
  acyclic (hb E X) /\ (*<<< would need irrefl(hb) for C++ as of today*)
  irrefl (rel_seq (fr E X) (rel_seq (prop E X) (hb E X))) /\
  acyclic (rel_union (co X) (prop E X)).

Ltac destruct_valid H :=
  destruct H as [[Hws_tot Hws_cands] [[Hrf_init [Hrf_cands Hrf_uni]] [Huni [Hth [Hlc Hvalid]]]]];
  unfold coherence_well_formed in Hws_tot(*; unfold uniproc in Hsp*).

(*Goal forall E X, valid_execution E X -> True.
intros E X Hvalid.
destruct_valid Hvalid. *)

End Wmm.


(* cP systems*)
From Coq Require Import Lists.List.
Import ListNotations.

Definition bag := list.

Inductive atom :=
  | a | b | c | d | e | f | g | h .

Inductive variable :=
  | X | Y | Z | W | U | V.

Definition functor := atom.

Inductive g_term :=
  | Num (n1: nat)
  | Atom (a1: atom)
  | Term (label : functor) (b1: bag g_term).

Definition g_multiset := bag g_term.

Inductive state := s (n : nat).

(*cPsystem_configuration*)
Inductive cPsystem_conf := cP_sys (s1: state) (terms: g_multiset).

Definition cP_rule : Type := cPsystem_conf -> cPsystem_conf.
Definition cP_ruleset : Type:= list cP_rule.

Notation "f @num x" := (Term f [Num x]) (at level 50).


Require Import Strings.String.
Require Import Coq.Reals.Rdefinitions.
Require Import Coq.Reals.RIneq.

(************************************************)
(* The syntax of differential dynamic logic.    *)
(************************************************)
Definition Var := string.
Definition Value := R.
Definition state : Type := Var -> Value.

(* Real-valued terms built using variables, constants
   and arithmetic. *)
Inductive Term :=
| VarNowT : Var -> Term
| VarNextT : Var -> Term
| NatT : nat -> Term
| RealT : R -> Term
| PlusT : Term -> Term -> Term
| MinusT : Term -> Term -> Term
| MultT : Term -> Term -> Term
| InvT : Term -> Term
| CosT : Term -> Term
| SinT : Term -> Term
| SqrtT : Term -> Term
| ArctanT : Term -> Term
| ExpT : Term -> Term
| MaxT : Term -> Term -> Term
| Unop : (R -> R) -> Term -> Term
| Binop : (R -> R -> R) -> Term -> Term -> Term
.

(* Comparison operations *)
Inductive CompOp :=
| Gt : CompOp
| Ge : CompOp
| Lt : CompOp
| Le : CompOp
| Eq : CompOp.

(* Map from variable to term. Essentially
   a refinement mapping from TLA. *)
Definition RenameMap := Var->Term.

(* Temporal formulas *)
Inductive Formula :=
| TRUE : Formula
| FALSE : Formula
| Comp : Term -> Term -> CompOp -> Formula
| And : Formula -> Formula -> Formula
| Or : Formula -> Formula -> Formula
| Imp : Formula -> Formula -> Formula
| PropF : Prop -> Formula
| Exists : forall T, (T -> Formula) -> Formula
| Forall : forall T, (T -> Formula) -> Formula
| Enabled : Formula -> Formula
| Always : Formula -> Formula
| Eventually : Formula -> Formula
| Embed : (state -> state -> Prop) -> Formula
| Rename : RenameMap -> Formula -> Formula.

(* Aliases for documentation purposes *)
Definition StateFormula := Formula.
Definition ActionFormula := Formula.

(************************************************)
(* Some notation for the logic.                 *)
(************************************************)
Delimit Scope HP_scope with HP.

(*Term notation *)
Definition NatC (n:nat) : Term :=
  NatT n.
Coercion NatC : nat >-> Term.
Definition ConstC (c:R) : Term :=
  RealT c.
Coercion ConstC : R >-> Term.
Definition VarC (x:string) : Term :=
  VarNowT x.
Coercion VarC : string >-> Term.
Notation "x !" :=
  (VarNextT x) (at level 0) : HP_scope.
Infix "+" := (PlusT) : HP_scope.
Infix "-" := (MinusT) : HP_scope.
Notation "-- x" := (MinusT (RealT R0) x)
                     (at level 0) : HP_scope.
Infix "*" := (MultT) : HP_scope.
Fixpoint pow (t : Term) (n : nat) :=
  match n with
  | O => RealT 1
  | S n => MultT t (pow t n)
  end.
Notation "t ^^ n" := (pow t n) (at level 10) : HP_scope.
Notation "/ x" := (InvT x) : HP_scope.
Notation "x / y" := (MultT x (InvT y)) : HP_scope.
Notation "cos( x )" := (CosT x).
Notation "sin( x )" := (SinT x).
Notation "exp( x )" := (ExpT x).
Notation "MAX( x1 , x2 )" := (MaxT x1 x2).
Notation "[ f ]( x )" := (Unop f x).
Notation "[ f ]( x , y )" := (Binop f x y).

(* Comparisons *)
Notation "t1 > t2" := (Comp t1 t2 Gt) : HP_scope.
Notation "t1 >= t2" := (Comp t1 t2 Ge) : HP_scope.
Notation "t1 < t2" := (Comp t1 t2 Lt) : HP_scope.
Notation "t1 <= t2" := (Comp t1 t2 Le) : HP_scope.
Notation "t1 = t2" := (Comp t1 t2 Eq) : HP_scope.
Notation "x <= y <= z" :=
  (And (Comp x y Le) (Comp y z Le)) : HP_scope.
Notation "x < y <= z" :=
  (And (Comp x y Lt) (Comp y z Le)) : HP_scope.
Notation "x <= y < z" :=
  (And (Comp x y Le) (Comp y z Lt)) : HP_scope.
Notation "x < y < z" :=
  (And (Comp x y Lt) (Comp y z Lt)) : HP_scope.

Notation "[] f" := (Always f)
                     (at level 72) : HP_scope.
Notation "<> f" := (Eventually f)
                     (at level 72) : HP_scope.

Bind Scope HP_scope with Term.
Bind Scope HP_scope with Formula.


From Coq Require Import
     List Arith NArith ZArith Ascii String
     Orders Sorting
     OrderedTypeEx FSetAVL FMapAVL
     extraction.ExtrOcamlIntConv
     Lia.
Import ListNotations.

From SimpleIO Require SimpleIO.

From ExtLib Require Import
     Structures.Monads.
Import MonadNotation.
Local Open Scope monad.

From advent Require Import lib.

(* Sets indexed by natural numbers. *)
Module NSet := FSetAVL.Make N_as_OT.

Variant rectangle : Type :=
| Rectangle (id : N) (left top width height : N)
.

(* We sort rectangles by the position of their top side
   (remember that the Y axis points downwards). *)
Module RectangleOrder <: TotalLeBool.
  Definition t : Type := rectangle.
  Definition leb (r1 r2 : rectangle) :=
    let '(Rectangle _ _ t1 _ _) := r1 in
    let '(Rectangle _ _ t2 _ _) := r2 in
    (t1 <=? t2)%N.
  Theorem leb_total : forall r1 r2,
      leb r1 r2 = true \/ leb r2 r1 = true.
  Proof.
    intros [] []; simpl.
    destruct N.leb eqn:e; auto.
    right. apply N.leb_le, N.lt_le_incl, N.leb_gt. auto.
  Qed.
End RectangleOrder.

Module Import RectangleSort := Sort RectangleOrder.

Definition close_overlap (r1 r2 : rectangle) : bool :=
  let '(Rectangle _ l1 _ w1 _) := r1 in
  let '(Rectangle _ l2 _ w2 _) := r2 in
  ((l1 <=? l2)%N && (l2 <? l1 + w1)%N) ||
  ((l2 <=? l1)%N && (l1 <? l2 + w2)%N).

Fixpoint take_while {A : Type} (p : A -> bool) (xs : list A) : list A :=
  match xs with
  | [] => []
  | x :: xs =>
    if p x then x :: take_while p xs
    else []
  end.

(* Having sorted the list of rectangles, given a rectangle [r1]
   with top side at [t1] and with height [h1], we can first filter
   out rectangles whose top side is lower than [t1 + h1].  *)
Definition high_enough (r1 r2 : rectangle) : bool :=
  let '(Rectangle _ _ t1 _ h1) := r1 in
  let '(Rectangle _ _ t2 _ _) := r2 in
  (t2 <? t1 + h1)%N.

(* Get the identifier of a rectangle. *)
Definition id (r : rectangle) : N :=
  let '(Rectangle id _ _ _ _) := r in id.

Fixpoint search_aux
         (* Set of rectangles known to overlap with some higher one. *)
         (overlaps : NSet.t) (rs : list rectangle) : option N :=
  match rs with
  | [] => None
  | r :: rs =>
    (* List of rectangles overlapping with [r] *)
    let olapping := filter (close_overlap r)
                        (take_while (high_enough r) rs) in
    match olapping with
    | [] =>
      let i := id r in
      if NSet.mem i overlaps then
        search_aux overlaps rs
      else
        Some i
    | _ :: _ =>
      search_aux
        (fold_left (fun s x => NSet.add (id x) s) olapping overlaps)
        rs
    end
  end.

Definition search : list rectangle -> option N :=
  search_aux NSet.empty.

Section main.

Context {m : Type -> Type} `{Monad m} `{MonadFix m}
        `{MonadError m}
        `{MonadI rectangle m} `{MonadO N m}.

Definition main : m unit :=
  rs <- read_all;;
  match search (sort rs) with
  | None => error "Rectangle not found"
  | Some r => print r
  end.

End main.

Module io.

Import SimpleIO.
Import IO.Notations.

Parameter parse_rectangle : ocaml_string -> int * int * int * int * int.
Extract Constant parse_rectangle =>
  "fun s -> Scanf.sscanf s ""#%d @ %d,%d: %dx%d""
              (fun i l t w h -> (((i, l), t), w), h)".

Instance MonadI_rectangle_IO : MonadI rectangle IO := {
  read := catch_eof (
    s <- read_line';;
    let '(i, l, t, w, h) := parse_rectangle s in
    ret (Rectangle (n_of_int i) (n_of_int l) (n_of_int t) (n_of_int w) (n_of_int h)))
}.

End io.

Import SimpleIO.

Definition exec : io_unit := IO.unsafe_run main.
Extraction "day03_2.ml" exec.


Require Import Coq.Bool.Bool.

Require Import CoqStock.comparable.
Require Import CoqStock.List.
Require Import CoqStock.reduce_orb.
Require Import CoqStock.Truthy.

Require Import Reexamined.compare_regex.
Require Export Reexamined.derive_def.
Require Import Reexamined.nullable.
Require Import Reexamined.regex.
Require Import Reexamined.setoid.

Theorem fail_is_terminating : forall {A: Type} {cmp: comparable A} (xs: list A),
  matchesb fail xs = false.
Proof.
  induction xs; intros; simpl_matchesb; trivial.
Qed.

(* or_simple simplifies or expressions *)
Ltac or_simple := repeat
  (  truthy
  || rewrite or_is_logical_or
  || rewrite fail_is_terminating
  ).

Section Derive.

Context {A: Type}.
Context {cmp: comparable A}.

(* r&r = r *)
Theorem and_idemp : forall (xs: list A) (r1 r2: regex A) (p: compare_regex r1 r2 = Eq),
  matchesb (and r1 r2) xs = matchesb r1 xs.
Proof.
unfold matchesb.
induction xs.
- simpl.
  intros.
  rewrite (regex_proof_compare_eq_is_equal r1 r2 p).
  apply Bool.andb_diag.
- simpl.
  intros.
  rewrite (regex_proof_compare_eq_is_equal r1 r2 p).
  apply IHxs.
  apply regex_proof_compare_eq_reflex.
Qed.

(* r&s = s&r *)
Theorem and_comm : forall (xs: list A) (r1 r2: regex A),
  matchesb (and r1 r2) xs = matchesb (and r2 r1) xs.
Proof.
unfold matchesb.
induction xs.
- simpl.
  SearchPattern (?X && ?Y = ?Y && ?X).
  intros.
  apply andb_comm.
- simpl.
  intros.
  apply IHxs.
Qed.

(* (r&s)&t = r&(s&t) *)
Theorem and_assoc : forall (xs: list A) (r s t: regex A),
    matchesb (and (and r s) t) xs = matchesb (and r (and s t)) xs.
Proof.
unfold matchesb.
induction xs.
- simpl.
  intros.
  truthy.
- simpl.
  intros.
  apply IHxs.
Qed.

(* fail&r = fail *)
Theorem and_fail : forall (xs: list A) (r: regex A),
  matchesb (and fail r) xs = matchesb fail xs.
Proof.
unfold matchesb.
induction xs.
- simpl.
  trivial.
- simpl.
  intros.
  apply IHxs.
Qed.

(* not(fail)&r = r *)
Theorem and_not_fail : forall (xs: list A) (r: regex A),
    matchesb (and (not fail) r) xs = matchesb r xs.
Proof.
unfold matchesb.
induction xs.
- simpl.
  trivial.
- simpl.
  intros.
  apply IHxs.
Qed.

(* concat (or r s) t => or (concat r t) (concat s t) *)
Theorem concat_or_distrib_r': forall
  (xs: list A)
  (r s t: regex A),
  matchesb (concat (or r s) t) xs
  = matchesb (or (concat r t) (concat s t)) xs.
Proof.
induction xs.
- intros. simpl_matchesb.
  truthy.
- intros. simpl_matchesb.
  case (nullable r), (nullable s).
  + cbn.
    repeat rewrite or_is_logical_or.
    rewrite IHxs.
    or_simple.
  + cbn.
    repeat rewrite or_is_logical_or.
    rewrite IHxs.
    or_simple.
  + cbn.
    repeat rewrite or_is_logical_or.
    rewrite IHxs.
    or_simple.
  + cbn.
    repeat rewrite or_is_logical_or.
    rewrite IHxs.
    or_simple.
Qed.

(* (r.s).t = r.(s.t) *)
Theorem concat_assoc': forall
  (xs: list A)
  (r s t: regex A),
  matchesb (concat (concat r s) t) xs
  = matchesb (concat r (concat s t)) xs.
Proof.
induction xs.
- intros.
  cbn.
  truthy.
- intros.
  simpl_matchesb.
  case (nullable r), (nullable s);
  try ( cbn;
    repeat rewrite or_is_logical_or;
    try rewrite concat_or_distrib_r';
    repeat rewrite or_is_logical_or;
    rewrite IHxs;
    truthy).
Qed.

(* fail.r = fail *)
Theorem concat_fail_l : forall (xs: list A) (r: regex A),
  matchesb (concat fail r) xs = matchesb fail xs.
Proof.
unfold matchesb.
induction xs.
- simpl.
  reflexivity.
- simpl.
  exact IHxs.
Qed.

Theorem concat_fail_r :
  forall (xs : list A)
         (r : regex A),
    matchesb (concat r fail) xs = matchesb fail xs.
Proof.
  induction xs; intros; simpl_matchesb.
  - rewrite andb_false_r.
    reflexivity.
  - destruct (nullable r).
    + rewrite or_is_logical_or.
      rewrite IHxs.
      rewrite orb_diag.
      reflexivity.
    + rewrite IHxs.
      reflexivity.
Qed.

(* concat (or r s) t => or (concat r t) (concat s t) *)
Lemma concat_or_distrib_r:
  forall (xs: list A)
         (r s t: regex A),
    matchesb (concat (or r s) t) xs = matchesb (or (concat r t) (concat s t)) xs.
Proof.
  induction xs; intros; simpl_matchesb.
  - rewrite andb_orb_distrib_l.
    reflexivity.
  - destruct (nullable r), (nullable s);
      simpl_matchesb;
      repeat rewrite or_is_logical_or;
      try apply IHxs;
      try rewrite IHxs;
      repeat rewrite or_is_logical_or;
      truthy.
Qed.

(* (r.s).t = r.(s.t) *)
Theorem concat_assoc: forall (xs: list A) (r s t: regex A),
  matchesb (concat (concat r s) t) xs = matchesb (concat r (concat s t)) xs.
Proof.
  induction xs; intros; simpl_matchesb.
  - intros.
    truthy.
  - destruct (nullable r), (nullable s);
      simpl_matchesb;
      repeat rewrite or_is_logical_or;
      try apply IHxs;
      try rewrite IHxs;
      rewrite concat_or_distrib_r;
      repeat rewrite or_is_logical_or;
      rewrite IHxs;
      truthy.
Qed.

Lemma fold_at_fail : forall (xs : list A), (fold_left derive xs fail = fail).
Proof.
simpl.
intros.
induction xs.
- simpl.
  trivial.
- simpl.
  apply IHxs.
Qed.

Lemma nullable_fold : forall (xs : list A) (r s: regex A), (nullable (fold_left derive xs (or r s))) = (orb (nullable (fold_left derive xs r)) (nullable (fold_left derive xs s))).
Proof.
induction xs.
- intros.
  simpl.
  reflexivity.
- intros.
  simpl.
  apply IHxs.
Qed.

(* r.fail = fail *)
Theorem concat_fail_r' : forall (xs: list A) (r: regex A),
  matchesb (concat r fail) xs = matchesb fail xs.
Proof.
unfold matchesb.
induction xs.
- intros.
  simpl.
  apply Bool.andb_false_r.
- simpl.
  intros.
  remember (nullable r).
  destruct b.
  + rewrite nullable_fold.
    case (nullable(fold_left derive xs fail)).
    * intros.
      truthy.
    * rewrite IHxs.
      rewrite fold_at_fail.
      simpl.
      trivial.
  + apply IHxs.
Qed.

(* empty.r = r *)
Theorem concat_empty : forall (xs: list A) (r: regex A),
  matchesb (concat empty r) xs = matchesb r xs.
Proof.
  induction xs; intros; simpl_matchesb.
  - reflexivity.
  - rewrite or_is_logical_or.
    rewrite concat_fail_l.
    rewrite fail_is_terminating.
    rewrite orb_false_l.
    reflexivity.
Qed.

(* r.empty = r *)
Theorem concat_empty2: forall (xs: list A) (r: regex A),
  matchesb (concat r empty) xs = matchesb r xs.
Proof.
  induction xs; intros; simpl_matchesb.
  - rewrite andb_true_r.
    reflexivity.
  - case (nullable r).
    + rewrite or_is_logical_or.
      rewrite IHxs.
      rewrite fail_is_terminating.
      rewrite orb_false_r.
      reflexivity.
    + apply IHxs.
Qed.

(* r|r = r *)
Theorem or_idemp : forall (xs: list A) (r1 r2: regex A) (p: compare_regex r1 r2 = Eq),
  matchesb (or r1 r2) xs = matchesb r1 xs.
Proof.
unfold matchesb.
induction xs.
- simpl.
  intros.
  rewrite (regex_proof_compare_eq_is_equal r1 r2 p).
  induction (nullable r2); compute; reflexivity.
- simpl.
  intros.
  rewrite (regex_proof_compare_eq_is_equal r1 r2 p).
  apply IHxs.
  apply regex_proof_compare_eq_reflex.
Qed.

(* r|s = s|r *)
Theorem or_comm : forall (xs: list A) (r s: regex A),
  matchesb (or r s) xs = matchesb (or s r) xs.
Proof.
unfold matchesb.
induction xs.
- simpl.
  intros.
  truthy.
- simpl.
  intros.
  apply IHxs.
Qed.

(* (r|s)|t = r|(s|t) *)
Theorem or_assoc : forall (xs: list A) (r s t: regex A),
  matchesb (or r (or s t)) xs = matchesb (or (or r s) t) xs.
Proof.
unfold matchesb.
induction xs.
- simpl.
  intros.
  truthy.
- intros.
  apply IHxs.
Qed.

(* not(fail)|r = not(fail) *)
Theorem or_not_fail : forall (xs: list A) (r: regex A),
  matchesb (or (not fail) r) xs = matchesb (not fail) xs.
Proof.
  induction xs; intros; simpl_matchesb; trivial.
Qed.

(* fail|r = r *)
Theorem or_id : forall (xs: list A) (r: regex A),
  matchesb (or r fail) xs = matchesb r xs.
Proof.
unfold matchesb.
induction xs.
- simpl.
  intros.
  truthy.
- intros.
  simpl.
  apply IHxs.
Qed.

(* star(star(r)) = star(r) *)
Theorem star_star : forall (xs: list A) (r: regex A),
  matchesb (star (star r)) xs = matchesb (star r) xs.
(* TODO: Help Wanted *)
Admitted.

(* (empty)* = empty *)
Theorem star_empty : forall (xs: list A),
  matchesb (star empty) xs = matchesb empty xs.
Proof.
  induction xs; intros; simpl_matchesb.
  - trivial.
  - rewrite concat_fail_l.
    reflexivity.
Qed.

(* (fail)* = empty *)
Theorem fail_star : forall (xs: list A),
  matchesb (star fail) xs = matchesb empty xs.
Proof.
unfold matchesb.
induction xs.
- simpl.
  reflexivity.
- simpl.
  apply concat_fail_l.
Qed.

(* not(not(r)) = r *)
Theorem not_not : forall (xs: list A) (r: regex A),
  matchesb (not (not r)) xs = matchesb r xs.
Proof.
  induction xs; intros; simpl_matchesb.
  - rewrite negb_involutive.
    reflexivity.
  - apply IHxs.
Qed.

Theorem not_fail_is_terminating : forall (xs: list A),
  matchesb (not fail) xs = true.
Proof.
  induction xs; intros; simpl_matchesb.
  - trivial.
  - apply IHxs.
Qed.

End Derive.


Require Import Setoid Morphisms.
From mathcomp Require Import all_ssreflect.
(* Note: ssrbool is empty and shadows Coq.ssr.ssrbool, use Coq.ssrbool for "Find" *)

From GraphTheory Require Import edone preliminaries set_tac digraph.
From GraphTheory Require Import sgraph treewidth minor connectivity.

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

Set Bullet Behavior "Strict Subproofs".

(** * Tree Decompositions for K4-free graphs *)

Ltac notHyp b ::= assert_fails (assert b by assumption).

Prenex Implicits vseparator.
Implicit Types G H : sgraph.
Arguments sdecomp : clear implicits.
Arguments rename_decomp [T G H D].

(* Pushing M-freeness (for some excluded minor M) to the subgraphs of
[add_edge G x y] induced by [V1] and [V2] where [V1,V2] is a proper
separation whose shared part is the minimal separator [[set x;y]]. *)

Section AddEdgeMinor.
Variables (G : sgraph) (x y : G) (V1 V2 : {set G}).
Let G' := add_edge x y.

Lemma unused_add_edge_connect_r (A : {pred G}) :
  y \notin A -> subrel (restrict A (@sedge G')) (restrict A (@sedge G)).
Proof.
move=> yNA u v /=; rewrite -!andbA => /and3P [uA vA].
gen have H,-> : u uA / u == y = false; first by apply:contraTF uA => /eqP->.
by rewrite (H v) // !andbF !orbF uA vA.
Qed.

Lemma unused_rmap_add_edge_r (M : sgraph) (phi : M -> {set G'}) :
  (forall i, y \notin phi i) -> minor_rmap phi -> @minor_rmap G M phi.
Proof.
move => y_unused [P1 P2 P3 P4].
have Y u i : u \in phi i -> u == y = false by apply: contraTF => /eqP ->.
split => //; last by move => i j ij; apply: neighbor_del_edge2 (P4 i j ij).
move => i u v u_pi v_pi; have:= P2 i u v u_pi v_pi.
exact/connect_mono/unused_add_edge_connect_r/y_unused.
Qed.

Hypothesis xDy : x != y.
Hypothesis psepV : proper_separation V1 V2.
Let S := V1 :&: V2.
Hypothesis defS : S = [set x;y].
Hypothesis ssepS : smallest vseparator S.

Lemma add_edge_rmap_separation_minor (M : sgraph) (phi : M -> {set G'}) :
  minor_rmap phi -> (forall u, phi u \subset V1) -> minor G M.
Proof.
move => rmap_phi sub_phi.
have [/existsP[i] y_phi_i|/existsPn Y] := boolP [exists i, y \in phi i]; last first.
  by have := unused_rmap_add_edge_r Y rmap_phi; apply: minor_of_rmap.
have x_S : x \in S by rewrite defS !inE eqxx.
have [_ [z [_ zNV1 _ xz]]] := svseparator_neighbours psepV ssepS x_S.
have [p irp dis] : exists2 p : Path z y, irred p & [disjoint p & [set x]].
{ apply: (@avoid_nonseperator G [set x] z y).
  - by apply: below_smallest ssepS _; rewrite defS cards1 cards2 xDy.
  - by rewrite inE eq_sym ?(sg_edgeNeq xz).
  - by rewrite inE eq_sym. }
rewrite disjoint_sym disjoints1 in dis.
have pV2: p \subset V2.
{ apply: contraTT isT => /subsetPn [z' z'p z'NV2].
  case/psplitP: _ / z'p irp dis => {p} [p1 p2] /irred_catE [_ _ Ip] s1p.
  move/proper_separation_symmetry : (psepV) => psepV'.
  case: (separation_separates psepV'.1 zNV1 z'NV2) => _ _ /(_ p1) [s S1].
  rewrite setIC -/S defS => /set2P [?|?]; subst s; first by set_tac.
  rewrite -(Ip y) // in z'NV2.
  by move/setP/(_ y) : defS; rewrite /S !inE (negbTE z'NV2) eqxx orbT andbF. }
pose g := phi[upd i := phi i :|: [set v in p]] : M -> {set G}.
suff: minor_rmap g by apply minor_of_rmap.
have [P1 P2 P3 P4] := rmap_phi.
rewrite /g; split.
- move=> j; have [->{j}|jDi] := eqVneq j i; rewrite updateE //.
  by case/set0Pn : (P1 i) => v v_pi; apply/set0Pn; exists v; rewrite inE v_pi.
- move=> j; have [->{j}|jDi] := eqVneq j i; rewrite updateE //; last first.
    move => u v u_pj v_pj; apply: connect_mono (P2 j u v u_pj v_pj).
    by apply/unused_add_edge_connect_r; rewrite (disjointFl (P3 _ _ jDi)).
  apply: (@connected_center _ y) => [u|]; last by rewrite inE y_phi_i.
  case/setUP => [u_phi_i|]; last first.
  + rewrite !inE srestrict_sym => u_p.
    case/psplitP def_p : _  / u_p => [p1 p2].
    by apply: (connectRI p2) => v; rewrite !inE => ->.
  + have [<- //|yDu] := eqVneq y u.
    have/connect_irredRP-/(_ yDu) [q Iq q_sub_i] := P2 _ _ _ y_phi_i u_phi_i.
    have [v [yv [q' [def_q _]]]] := splitL q yDu.
    have v_phi_i : v \in phi i by rewrite (subsetP q_sub_i) // def_q !inE.
    apply: (@connect_trans _ _ v); last first.
    * have yNq : y \notin q' by move: Iq; rewrite def_q irred_edgeL => /andP[->].
      have := add_edge_avoid q'; rewrite yNq orbT /= => /(_ isT) [q'' eq_q].
      apply: (connectRI q'') => w; rewrite !inE mem_path eq_q => w_q.
      by rewrite (subsetP q_sub_i) // def_q !inE !mem_path w_q.
    * move: (yv). rewrite /edge_rel/= eqxx [v == y]eq_sym (sg_edgeNeq yv).
      rewrite !(andbF,andbT)/= orbC => /predU1P [eq_vx|yvG]; last first.
        by apply: connect1 => /=; rewrite !inE v_phi_i.
      subst v. apply: (@connect_trans _ _ z); last first.
        by apply: connect1 => /=; rewrite !inE v_phi_i sgP.
      by rewrite srestrict_sym; apply: (connectRI p) => w; rewrite !inE => ->.
- move => j k jDk; have [i_jk|] := boolP (i \in [set j; k]); last first.
    rewrite !inE negb_or ![i == _]eq_sym => /andP[? ?].
    by rewrite !updateE // P3.
  wlog ?: j k jDk {i_jk} / i = j => [W|]; last subst j.
    case/set2P : i_jk; last rewrite disjoint_sym; apply: W => //.
    by rewrite eq_sym.
  rewrite !updateE 1?eq_sym // disjointsU // ?P3 // disjoint_subset.
  apply/subsetP => v; rewrite !inE => v_p; apply: contraNN dis => v_phi_k.
  have: v \in S by apply/setIP; rewrite (subsetP pV2) // (subsetP (sub_phi k)).
  rewrite defS => /set2P [<- //|vEy].
  by rewrite vEy (disjointFr (P3 _ _ jDk)) in v_phi_k.
- move=> j k jk; have [i_jk|] := boolP (i \in [set j; k]); last first.
  { rewrite !inE negb_or ![i == _]eq_sym => /andP[A B].
    rewrite !updateE // neighbor_del_edge2 // ?P4 //.
    all: by rewrite ?(disjointFl (P3 _ _ A)) ?(disjointFl (P3 _ _ B)). }
  wlog ?: j k jk {i_jk} / i = j => [W|]; last subst j.
    case/set2P : i_jk; first exact: W.
    by rewrite neighborC; apply: W; rewrite // sgP.
  rewrite !updateE 1?eq_sym ?sg_edgeNeq //.
  have/neighborP[u[v [u_phi_i v_phi_k]]] := P4 _ _ jk.
  have dis_ij w w' : w \in phi i -> w' \in phi k -> w' == w = false.
  { move => A B. apply: contraTF jk => /eqP ?; subst w'.
    by rewrite (rmap_disjE rmap_phi A B) sgP. }
  rewrite /edge_rel/= (dis_ij _ _ y_phi_i v_phi_k) !andbF.
  rewrite (dis_ij _ _ u_phi_i v_phi_k) /= => /orP [uv|/andP[/eqP? /eqP?]].
    by apply/neighborP; exists u,v; rewrite !inE u_phi_i v_phi_k uv.
  by subst v u; apply/neighborP; exists z,x; rewrite !inE v_phi_k sgP xz.
Qed.

Lemma add_edge_separation_minor M : minor (@induced G' V1) M -> minor G M.
Proof.
move=> minorM.
suff [phi]: exists2 phi : M -> {set G'}, minor_rmap phi & forall u, phi u \subset V1.
  exact: add_edge_rmap_separation_minor.
case/minorRE : minorM => phi rmap_phi.
pose phi' (u : M) := \bigcup_(v in phi u) induced_rmap v : {set G'}.
exists phi'; first by apply: minor_rmap_comp => //; apply: induced_rmapP.
move=> u. apply/bigcupsP=> v ?. exact: induced_rmap_sub.
Qed.

Lemma add_edge_separation_excluded M :
  ~ minor G M -> ~ minor (@induced G' V1) M.
Proof. exact/contra_not/add_edge_separation_minor. Qed.

End AddEdgeMinor.

Lemma connectedI_clique (G : sgraph) (A B S : {set G}) :
  connected A -> clique S ->
  (forall x y (p : Path x y), p \subset A -> x \in B -> y \notin B ->
     exists2 z, z \in p & z \in S :&: B) ->
  connected (A :&: B).
Proof.
  move => conA clS H x y /setIP [X1 X2] /setIP [Y1 Y2].
  case: (altP (x =P y)) => [->|xDy]; first exact: connect0.
  case/connect_irredRP : (conA _ _ X1 Y1) => // p Ip subA.
  case: (boolP (p \subset B)) => subB.
  - apply connectRI with p => z zp. by set_tac.
  - case/subsetPn : subB => z Z1 Z2.
    gen have C,Cx : x y p Ip subA X1 X2 Y1 Y2 Z1 Z2 {xDy} /
        exists2 s, s \in S :&: A :&: B & connect (restrict (A :&: B) sedge) x s.
    { case: (split_at_first (A := [predC B]) Z2 Z1) => u' [p1] [p2] [P1 P2 P3].
      subst p. case/irred_catE : Ip => Ip1 Ip2 Ip.
      case/splitR : (p1); first by apply: contraNneq P2 => <-.
      move => u [p1'] [uu'] E. subst p1.
      have uB : u \in B. apply: contraTT (uu') => C. by rewrite [u]P3 ?sgP // !inE.
      exists u. case: (H _ _ (edgep uu')) => //.
      - apply: subset_trans subA.
        apply: subset_trans (subset_pcatL _ _). exact: subset_pcatR.
      - move => ?. rewrite !inE mem_edgep. case/orP => /eqP-> /andP[U1 U2].
        + by rewrite U1 U2 (subsetP subA) // !inE.
        + by rewrite !inE U2 in P2.
      - apply connectRI with p1' => v Hv.
        rewrite !inE (subsetP subA) ?inE ?Hv //=.
        move: Ip1. rewrite irred_edgeR andbC => /andP [Ip1].
        apply: contraNT => C. by rewrite -(P3 v) // !inE Hv. }
    case: Cx => s. rewrite !inE -andbA => /and3P [S1 S2 S3 S4].
    case: (C _ _ (prev p)); rewrite ?mem_prev ?irred_rev //.
    + apply: subset_trans subA. apply/subsetP => ?. by rewrite !inE.
    + move => t. rewrite !inE -andbA => /and3P [T1 T2 T3 T4].
      apply: connect_trans S4 _. rewrite srestrict_sym.
      apply: connect_trans T4 _. case: (altP (t =P s)) => [-> //|E].
      apply: connect1 => /=. by rewrite !inE clS.
Qed.

(** only needed for [K4_free_add_edge_sep_size2] *)
Lemma separation_K4side G (V1 V2 : {set G}) :
  separation V1 V2 -> clique (V1 :&: V2) -> #|V1 :&: V2| <= 2 ->
  minor G K4 ->
  exists2 phi : K4 -> {set G}, minor_rmap phi &
     (forall x, phi x \subset V1) \/ (forall x, phi x \subset V2).
Proof.
  move => sepV clV12 cardV12 /minorRE [phi] [P1 P2 P3 P4].
  wlog/forallP cutV1 : V1 V2 sepV clV12 cardV12 / [forall x, phi x :&: V1 != set0].
  { move => W.
    case: (boolP [forall x, phi x :&: V1 != set0]) => A; first exact: (W V1 V2).
    case: (boolP [forall x, phi x :&: V2 != set0]) => B.
    { setoid_rewrite <- or_comm. by apply: W; rewrite 1?setIC // separation_sym. }
    case: notF. case/forallPn : A => i /negPn Hi. case/forallPn : B => j /negPn Hj.
    case: (altP (i =P j)) => [E|E].
    - subst j. case/set0Pn : (P1 i) => x Hx. case/setUP : (sepV.1 x) => Hx'.
      + move/eqP/setP/(_ x) : Hi. by rewrite !inE Hx Hx'.
      + move/eqP/setP/(_ x) : Hj. by rewrite !inE Hx Hx'.
    - move/neighborP : (P4 i j E) => [x] [y] [A B]. rewrite sgP sepV //.
      apply: contraTN Hj => Hy. by apply/set0Pn; exists y; rewrite inE B.
      apply: contraTN Hi => Hx. by apply/set0Pn; exists x; rewrite inE A. }
  set S := V1 :&: V2 in clV12 cardV12.
  have phiP i y : y \in phi i -> y \notin V1 -> phi i :&: S != set0.
  { case/set0Pn : (cutV1 i) => x /setIP [xpi xV1 ypi yV1].
    case: (boolP (x \in V2)) => xV2; first by apply/set0Pn; exists x; rewrite !inE.
    case/connect_irredRP : (P2 i x y xpi ypi); first by apply: contraNneq yV1 => <-.
    move => p Ip subP.
    have [_ _ /(_ p)] := separation_separates sepV xV2 yV1.
    case => z /(subsetP subP) => ? ?. apply/set0Pn; exists z. by rewrite /S inD. }
  pose phi' (i : K4) := phi i :&: V1.
  exists phi'; first split.
  - move => i. exact:cutV1.
  - move => i. apply connectedI_clique with S => //.
    + move => x y p sub_phi Hx Hy. case: (boolP (x \in V2)) => Hx'.
      * exists x => //. by rewrite /S inD.
      * have [_ _ /(_ p) [z ? ?]] := (separation_separates sepV Hx' Hy).
        exists z => //. by rewrite /S inD.
  - move => i j /P3 => D. apply: disjointW D; exact: subsetIl.
  - move => i j ij. move/P4/neighborP : (ij) => [x] [y] [H1 H2 H3].
    have S_link u v : u \in S -> v \in S -> u \in phi i -> v \in phi j -> u -- v.
    { have D: [disjoint phi i & phi j] by apply: P3; rewrite sg_edgeNeq.
      (* TOTHINK: make set_tac use/prove [x == y] or [x != u]. *)
      move => H *. apply: clV12 => //. by apply: contraTneq H => ?; set_tac. }
    have/subsetP subV : S \subset V1 by exact: subsetIl.
    have inS u v : u -- v -> u \in V1 -> v \notin V1 -> u \in S.
    { move => uv HVu HVv. apply: contraTT uv => /= C. subst S.
      by rewrite sepV // notinD. }
    apply/neighborP. case: (boolP (x \in V1)) => HVx; case: (boolP (y \in V1)) => HVy.
    + exists x; exists y. by rewrite !inE HVx HVy.
    + case/set0Pn : (phiP _ _ H2 HVy) => s /setIP [S1 S2].
      exists x; exists s. rewrite !inE H1 HVx S1 S_link // ?subV //. exact: inS HVy.
    + case/set0Pn : (phiP _ _ H1 HVx) => s /setIP [S1 S2].
      exists s; exists y. rewrite !inE H2 HVy S1 S_link // ?subV //.
      apply: inS HVx => //. by rewrite sgP.
    + case/set0Pn : (phiP _ _ H1 HVx) => s /setIP [S1 S2].
      case/set0Pn : (phiP _ _ H2 HVy) => s' /setIP [S3 S4].
      exists s; exists s'. by rewrite !inE S1 S3 S_link // !subV.
  - left => x. exact: subsetIr.
Qed.

Lemma K4_of_paths (G : sgraph) x y s0 s1' (p0 p1 p2 : Path x y) (q1 : Path s0 s1') :
  x!=y -> independent p0 p1 -> independent p0 p2 -> independent p1 p2 ->
  s0 \in interior p0 -> s1' \in interior p1 ->
  irred p0 -> irred p1 -> irred p2 -> irred q1 ->
  [disjoint q1 & [set x; y]] ->
  (forall z' : G, z' \in [predU interior p1 & interior p2] -> z' \in q1 -> z' = s1') ->
  minor G K4.
Proof.
  move => xDy ind01 ind02 ind12 sp0 in_p1 Ip0 Ip1 Ip2 Iq av_xy s1'firstp12.
  pose phi (i : K4) := match i with
                  | Ordinal 0 _ => [set x]
                  | Ordinal 1 _ => interior p0 :|: interior q1
                  | Ordinal 2 _ => interior p1
                  | Ordinal 3 _ => y |: interior p2
                  | Ordinal p n => set0
                  end.
  suff: minor_rmap phi by apply minor_of_rmap.
  split.
  - move => [m i]. case m as [|[|[|[|m]]]] => //=; apply /set0Pn.
    + exists x. by set_tac.
    + exists (s0). by rewrite inE sp0.
    + by exists s1'.
    + exists y. by set_tac.
  - move => [m i]. case m as [|[|[|[|m]]]] => //=.
    + exact: connected1.
    + case: (altP (interior q1 =P set0)) => [->|H].
      * rewrite setU0. exact: connected_interior.
      * apply: neighbor_connected; try exact: connected_interior.
        exact: path_neighborL.
    + exact: connected_interior.
    + exact: connected_interiorR.
  - move => i j iNj. wlog iltj: i j {iNj} / i < j.
    { move => H. rewrite /= neq_ltn in iNj.
      move: iNj => /orP [iltj|jlti]; [|rewrite disjoint_sym]; exact: H. }
    destruct i as [m i]. destruct j as [n j].
    case m as [|[|[|[|m]]]] => //=; case n as [|[|[|[|m']]]] => //=.
    + rewrite disjoints1. rewrite inE negb_or /interior notinD /=.
      have: (x \in [set x; y]); by set_tac.
    + rewrite disjoints1. by rewrite /interior; set_tac.
    + rewrite disjoints1. by rewrite /interior; set_tac.
    + apply: disjointsU => //. apply/disjointP => z Z1 Z2.
      suff: z = s1' by move: Z1 Z2; rewrite /interior; set_tac.
      apply: s1'firstp12. by rewrite inE /= Z2. exact: interiorW.
    + apply: disjointsU => //.
      * rewrite disjoint_sym. apply: disjointsU.
        -- rewrite /interior. apply/disjointP; by set_tac.
        -- by rewrite disjoint_sym.
      * rewrite disjoint_sym. apply: disjointsU.
        -- apply/disjointP. rewrite /interior. have: (y \in [set x; y]); by set_tac.
        -- apply/disjointP => z Z1 Z2.
           suff: z = s1' by move: Z1 Z2; rewrite /interior; set_tac.
           apply: s1'firstp12. by rewrite inE /= Z1. exact: interiorW.
    + rewrite disjoint_sym. apply: disjointsU.
      * rewrite disjoints1 /interior. by set_tac.
      * by rewrite disjoint_sym.
  - move => i j iNj. wlog iltj: i j {iNj} / i < j.
    { move => H. rewrite /edge_rel /= neq_ltn in iNj.
      move: iNj => /orP [iltj|jlti]; [|rewrite neighborC]; exact: H. }
    destruct i as [m i]. destruct j as [n j].
    (* Hints for automation *)
    have [[? ?] ?] := (valP (p0),valP p1, valP p2).
    case m as [|[|[|[|m]]]] => //=; case n as [|[|[|[|m']]]] => //=.
    + apply: neighborUl. apply: path_neighborL => //; by set_tac.
    + apply: path_neighborL => //; by set_tac.
    + exact: neighbor_interiorL.
    + case: (altP (interior q1 =P set0)) => [E|H].
      * rewrite E setU0. apply/neighborP; exists (s0); exists s1'. split => //.
        case/interior0E : E => //. apply: contraTneq ind01.
        rewrite /independent; set_tac.
      * rewrite neighborC. apply: neighborUr. exact: path_neighborR.
    + apply: neighborUl. rewrite neighborC. apply: neighborUl.
      apply: path_neighborR => //; by set_tac.
    + apply: neighborUl. rewrite neighborC. apply: path_neighborR => //; by set_tac.
Qed.

Lemma K4_of_vseparators (G : sgraph) :
  3 < #|G| -> (forall S : {set G}, vseparator S -> 2 < #|S|) -> minor G K4.
Proof.
  move => G4elt minsep3.
  case: (boolP (cliqueb [set: G])) => [|/cliquePn [x] [y] [_ _ xNy xNEy]].
  { move/cliqueP. apply: minor_of_clique. by rewrite cardsT. }
  have minsep_xy S : separates x y S -> 3 <= #|S|.
  { move => A. apply: minsep3. by exists x; exists y. }
  case: (theta xNEy xNy minsep_xy) => p ind_p.
  case: (theta_vertices p xNy xNEy) => s Hs.
  (* name [p1] and [p2] (plus assumptions) because we will need to generalize over them *)
  pose p1 := p ord1. pose p2 := p ord2.
  pose s1 := s ord1. pose s2 := s ord2.
  have ind12 : independent p1 p2 by apply: ind_p.
  have ind01 : independent (p ord0) p1 by apply: ind_p.
  have ind02 : independent (p ord0) p2 by apply: ind_p.
  have sp1 : s1 \in interior p1 by rewrite Hs.
  have sp2 : s2 \in interior p2 by rewrite Hs.
  case (@avoid_nonseperator G [set x; y] (s ord0) (s1)) => //; try (apply: interiorN; eauto).
  { move/minsep3. by rewrite cards2 xNy. }
  move => q Iq av_xy.
  case: (@split_at_first G [predU interior p1 & interior p2] (s ord0) s1 q s1) => //.
  { by rewrite inE /= sp1. }
  move => s1' [q1 [q2 [catp s1'p12 s1'firstp12]]].
  subst q. case/irred_catE : Iq => Iq _ _.
  have {av_xy} av_xy : [disjoint q1 & [set x; y]] by apply/disjointP => z; set_tac.
  wlog in_p1: p1 p2 s1 s2 ind01 ind02 ind12 sp1 {sp2} {q2 s1'p12} s1'firstp12 / s1' \in interior p1.
  { move => W. case/orP: (s1'p12) => /= [s1'p1|s1'p2].
    - by apply W with p1 p2 s1.
    - apply W with p2 p1 s2 => //. by apply: independent_sym.
      move => z' H1 H2. apply s1'firstp12 => //. move: H1. by rewrite !inE orbC. }
  apply K4_of_paths with x y (s ord0) s1' (p ord0) p1 p2 q1 => //; exact: valP.
Qed.

Lemma no_K4_smallest_vseparator (G : sgraph) :
  ~ minor G K4 -> #|G| <= 3 \/ (exists S : {set G}, smallest vseparator S /\ #|S| <= 2).
Proof.
  move => HM. case (boolP (3 < #|G|)) => sizeG; last by rewrite leqNgt; left.
  right. case: (boolP ([exists (S : {set G} | #|S| <= 2), vseparatorb S])).
  - case/exists_inP => /= S sizeS sepS.
    case: (arg_minnP (fun a : {set G} => #|a|) sepS) => U /vseparatorP sepU HU.
    exists U. repeat split => //.
    + move => V /vseparatorP. exact: HU.
    + move: (HU S sepS) => ?. exact: leq_trans sizeS.
  - move/exists_inPn => H. exfalso. apply HM. apply K4_of_vseparators => //.
    move => S. move: (H S). rewrite unfold_in (rwP (vseparatorP _)) => H'.
    apply: contraTT. by rewrite ltnNge negbK.
Qed.

Theorem TW2_of_K4F (G : sgraph) :
  K4_free G -> exists (T : forest) (B : T -> {set G}), sdecomp T G B /\ width B <= 3.
Proof.
  elim/card_ind : G => G Hind K4free.
  (* Either G is small, or it has a smallest vseparator of size at most two *)
  case (no_K4_smallest_vseparator K4free) =>[|[S [ssepS Ssmall2]]].
  { exact: decomp_small. }
  move: (vseparator_separation ssepS.1) => [V1 [V2 [[sep prop] SV12]]].
  move: (prop) => [x0 [y0 [Hx0 Hy0]]].
  case: (ltngtP #|S| 2) Ssmall2 => // [Sless2|/eqP Ssize2] _.
  - have V1properG: #|induced V1| < #|G|.
    { rewrite card_sig. eapply card_ltnT. simpl. eauto. }
    have {x0 Hx0 y0 Hy0} V2properG: #|induced V2| < #|G|.
    { rewrite card_sig. eapply card_ltnT. simpl. eauto. }
    case: (Hind (induced V1)) => // [|T1 [B1 [sd1 w1]]].
      apply: subgraph_K4_free K4free; exact: induced_sub.
    case: (Hind (induced V2)) => // [|T2 [B2 [sd2 w2]]].
      apply: subgraph_K4_free K4free; exact: induced_sub.
    have [|T[B [sdB wB]]] := separation_decomp sd1 sd2 sep _.
      by rewrite -SV12; exact: small_clique.
    by exists T,B; split => //; apply: leq_trans wB _; rewrite geq_max w1 w2.
  - case/cards2P : Ssize2 => s1 [s2] [s1Ns2 S12]; pose G' := add_edge s1 s2.
    suff [T[B [dcB wB]]] :
      exists (T : forest) (B : T -> {set G'}), sdecomp T G' B /\ width B <= 3.
    { exists T,B; split => //; move: dcB.
      destruct G; apply sdecomp_subrel. exact: subrelUl. }
    have V1properG: #|@induced G' V1| < #|G|.
    { rewrite card_sig. eapply card_ltnT. simpl. eauto. }
    have {x0 Hx0 y0 Hy0} V2properG: #|@induced G' V2| < #|G|.
    { rewrite card_sig. eapply card_ltnT. simpl. eauto. }
    case: (Hind (@induced G' V1)) => // [|T1 [B1 [sd1 w1]]].
    { apply: (@add_edge_separation_excluded G s1 s2 V1 V2) => //.
      by rewrite -SV12 S12. by rewrite -SV12. }
    case: (Hind (@induced G' V2)) => // [|T2 [B2 [sd2 w2]]].
    { apply: (@add_edge_separation_excluded G s1 s2 V2 V1) => //.
      - rewrite proper_separation_symmetry //.
      - by rewrite setIC -SV12 S12.
      - by rewrite setIC -SV12. }
    have [||T [B [sdB wB]]] := @separation_decomp G' _ _ _ _ _ _ sd1 sd2 _ _.
      by apply: add_edge_separation => //; rewrite -SV12 S12 !inE eqxx.
      by rewrite -SV12 S12; apply: clique2; rewrite /edge_rel/= !eqxx s1Ns2.
    by exists T,B; split => //; apply: leq_trans wB _; rewrite geq_max w1 w2.
Qed.

Theorem excluded_minor_TW2 (G : sgraph) :
  K4_free G <->
  exists (T : forest) (B : T -> {set G}), sdecomp T G B /\ width B <= 3.
Proof. split => [|[T][B][]]. exact: TW2_of_K4F. exact: TW2_K4_free. Qed.

Lemma K4_free_add_edge_sep_size2 (G : sgraph) (s1 s2 : G):
  K4_free G -> smallest vseparator [set s1; s2] -> s1 != s2 -> K4_free (add_edge s1 s2).
Proof.
  move S12 : [set s1;s2] => S. move/esym in S12. move => K4free ssepS s1Ns2 K4G'.
  case: (vseparator_separation ssepS.1) => V1 [V2] [psep SV12].
  wlog [phi rmapphi HphiV1] : {K4G'} V1 V2 psep SV12 / exists2 phi : K4 -> {set add_edge s1 s2},
         minor_rmap phi & forall x : K4, phi x \subset V1.
  { move => W.  case: (@separation_K4side (add_edge s1 s2) V1 V2) => //.
    - apply: add_edge_separation psep.1; by rewrite -SV12 S12 !inE eqxx.
    - rewrite -SV12 S12. apply: clique2. by rewrite /edge_rel/= !eqxx s1Ns2.
    - by rewrite -SV12 S12 cards2 s1Ns2.
    - move => phi map_phi [subV1|subV2]; first by apply: (W V1 V2) => //; exists phi.
      apply: (W V2 V1) => //; rewrite 1?proper_separation_symmetry 1?setIC //.
      by exists phi. }
  apply: K4free.
  apply: add_edge_rmap_separation_minor psep _ _ _ _ rmapphi HphiV1 => //.
  all: by rewrite -SV12.
Qed.


From iris.algebra Require Import agree.
From iris_ora.algebra Require Export ora.
(* From iris_ora.algebra Require Import list. *)
From iris_ora.logic Require Import oupred.
Local Arguments validN _ _ _ !_ /.
Local Arguments valid _ _  !_ /.
Local Arguments op _ _ _ !_ /.
Local Arguments pcore _ _ !_ /.

Local Coercion agree_car : agree >-> list.

Section agree.
Local Set Default Proof Using "Type".
Context {A : ofe}.
Implicit Types a b : A.
Implicit Types x y : agree A.

Instance agree_orderN : OraOrderN (agree A) :=
  λ n x y, ∀ a, a ∈ agree_car x → ∃ b, b ∈ agree_car y ∧ a ≡{n}≡ b.
Instance agree_order : OraOrder (agree A) := λ x y, ∀ n, x ≼ₒ{n} y.

Lemma agree_order_dist n x y : ✓{n} y → x ≼ₒ{n} y → x ≡{n}≡ y.
Proof.
  intros Hnv Hxy; split => a Ha.
  - by apply Hxy.
  - destruct x as [[|xh xc] xnn]; first done.
    destruct (Hxy xh) as [z [Hz1 Hz2]]; simpl; auto using elem_of_list_here.
    exists xh; split; first apply elem_of_list_here.
    etrans; first apply Hz2.
    eapply agree_validN_def; eauto.
Qed.

Lemma agree_increasing x : Increasing x.
Proof.
  intros y n a Ha. exists a; split; last done.
  apply elem_of_list_lookup in Ha; destruct Ha as [i Ha].
  apply elem_of_list_lookup. exists (length x + i).
  rewrite lookup_app_r; last lia.
  by replace (length x + i - length x) with i by lia.
Qed.

Lemma agree_dist_orderN n x y : x ≡{n}≡ y → x ≼ₒ{n} y.
Proof. by intros Hxy a Ha; apply Hxy. Qed.

Instance agree_orderN_proper n :
  Proper ((dist n) ==> (dist n) ==> iff) (agree_orderN n).
Proof.
  intros x y [Hxy1 Hxy2] x' y' [Hx'y'1 Hx'y'2]; split => Hs z Hz.
  - destruct (Hxy2 _ Hz) as [u [Hu1 Hu2]].
    destruct (Hs _ Hu1) as [w [Hw1 Hw2]].
    destruct (Hx'y'1 _ Hw1) as [q [Hq1 Hq2]].
    exists q; split; auto.
    rewrite -Hu2; etrans; eauto.
  - destruct (Hxy1 _ Hz) as [u [Hu1 Hu2]].
    destruct (Hs _ Hu1) as [w [Hw1 Hw2]].
    destruct (Hx'y'2 _ Hw1) as [q [Hq1 Hq2]].
    exists q; split; auto.
    rewrite Hu2; etrans; eauto.
Qed.

Instance agree_orderN_proper' n :
  Proper ((≡) ==> (≡) ==> iff) (agree_orderN n).
Proof.
  intros x y Hxy x' y' Hx'y'; split => Hs.
  - eapply agree_orderN_proper; try symmetry; eauto.
  - eapply agree_orderN_proper; eauto.
Qed.

Instance agree_order_proper :
  Proper ((≡) ==> (≡) ==> iff) agree_order.
Proof.
  intros x y Hxy x' y' Hx'y'; split => Hs n.
  - eapply agree_orderN_proper; try symmetry; eauto.
    apply Hs.
  - eapply agree_orderN_proper; eauto.
    apply Hs.
Qed.

Instance agree_orderN_Trans n : Transitive (agree_orderN n).
Proof.
  intros x y z Hxy Hyz u Hu.
  destruct (Hxy _ Hu) as [w [Hw1 Hw2]].
  destruct (Hyz _ Hw1) as [q [Hq1 Hq2]].
  exists q; split; auto.
  etrans; eauto.
Qed.

Instance agree_order_Trans : Transitive agree_order.
Proof.
  intros x y z Hxy Hyz n u Hu.
  eapply agree_orderN_Trans; eauto; apply Hxy || apply Hyz.
Qed.

Definition agree_ora_mixin : OraMixin (agree A).
Proof.
  apply ora_total_mixin; try apply _ ||
    by eauto using agree_increasing, agree_dist_orderN.
  - intros n x y1 y2 Hx Hysx.
    pose proof (agree_order_dist _ _ _ Hx Hysx) as Hysx'.
    eapply agree_validN_ne in Hx; last by symmetry.
    exists x, x. split; last split.
    + apply agree_dist_orderN. by rewrite agree_idemp.
    + rewrite -Hysx'. by rewrite (agree_op_invN _ _ _ Hx) agree_idemp.
    + rewrite -Hysx'. by rewrite (agree_op_invN _ _ _ Hx) agree_idemp.
  - intros n x y Hx Hyx. exists x; split.
    + by apply agree_dist_orderN.
    + symmetry. eapply agree_order_dist; eauto.
  - intros n x y. intros Hxy a Ha.
    destruct (Hxy _ Ha) as [z [Hz1 Hz2]].
    eexists z; split; auto. by apply dist_S.
  - intros n x x' y Hxx' a Ha.
    apply elem_of_app in Ha. destruct Ha as [Ha|Ha].
    + destruct (Hxx' _ Ha) as [z [Hz1 Hz2]].
      exists z; split; auto. by apply elem_of_app; left.
    + exists a; split; auto. by apply elem_of_app; right.
  - intros n x y Hx Hxy. apply agree_validN_def => a b Ha Hb.
    destruct (Hxy _ Ha) as [z1 [Hz11 Hz12]].
    destruct (Hxy _ Hb) as [z2 [Hz21 Hz22]].
    rewrite Hz12 Hz22. eapply agree_validN_def; eauto.
  - intros x cx y; inversion 1 as [?? Hcx|]; subst.
    exists (x ⋅ y); split; auto. rewrite Hcx.
    intros n a Ha. exists a; split; auto. by apply elem_of_app; left.
Qed.
Canonical Structure agreeR : ora := Ora (agree A) agree_ora_mixin.

Global Instance agree_ora_total : OraTotal agreeR.
Proof. rewrite /OraTotal; eauto. Qed.
Global Instance agree_core_id (x : agree A) : OraCoreId x.
Proof. by constructor. Qed.

Global Instance agree_ora_discrete : OfeDiscrete A → OraDiscrete agreeR.
Proof.
  intros HD. split.
  - intros x y [H H'] n; split=> a; setoid_rewrite <-(discrete_iff_0 _ _); auto.
  - intros x; rewrite agree_validN_def=> Hv n. apply agree_validN_def=> a b ??.
    apply discrete_iff_0; auto.
  - intros x y Hxy n a Ha.
    destruct (Hxy _ Ha) as [z [Hz1 Hz2]].
    exists z; split; auto. by setoid_rewrite <-(discrete_iff_0 _ _).
Qed.

Lemma to_agree_order a b : to_agree a ≼ₒ to_agree b ↔ a ≡ b.
Proof.
  split; last by intros ->.
  intros Hab. apply equiv_dist=>n.
  destruct (Hab n a) as [z [Hz1 Hz2]]; first by apply elem_of_list_singleton.
  by apply elem_of_list_singleton in Hz1; subst.
Qed.

Global Instance agree_cancelable x : OraCancelable x.
Proof.
  intros n y z Hv Heq.
  destruct (to_agree_uninjN n x) as [x' EQx]; first by eapply cmra_validN_op_l.
  destruct (to_agree_uninjN n y) as [y' EQy]; first by eapply cmra_validN_op_r.
  destruct (to_agree_uninjN n z) as [z' EQz].
  { eapply (cmra_validN_op_r n x z). by rewrite -Heq. }
  assert (Hx'y' : x' ≡{n}≡ y').
  { apply (inj to_agree), agree_op_invN. by rewrite EQx EQy. }
  assert (Hx'z' : x' ≡{n}≡ z').
  { apply (inj to_agree), agree_op_invN. by rewrite EQx EQz -Heq. }
  by rewrite -EQy -EQz -Hx'y' -Hx'z'.
Qed.

(** Internalized properties *)
Lemma agree_equivI {M} a b : to_agree a ≡ to_agree b ⊣⊢ (a ≡ b : ouPred M).
Proof.
  rewrite /internal_eq /bi_internal_eq_internal_eq /=. ouPred.unseal. do 2 split.
  - intros Hx. exact: to_agree_injN.
  - intros Hx. exact: to_agree_ne.
Qed.
Lemma agree_validI {M} x y : ✓ (x ⋅ y) ⊢ (x ≡ y : ouPred M).
Proof.
  rewrite /internal_eq /bi_internal_eq_internal_eq /=.
  ouPred.unseal; split=> r n _ ?; by apply: agree_op_invN.
Qed.
End agree.

Arguments agreeR : clear implicits.

Section agree_map.
  Context {A B : ofe} (f : A → B) `{Hf: NonExpansive f}.

  Global Instance agree_map_morphism : OraMorphism (agree_map f).
  Proof using Hf.
    split; first apply _.
    - intros n x y Hxy a; setoid_rewrite elem_of_list_fmap; intros [z [-> Hz]].
      destruct (Hxy _ Hz) as [w [Hw1 Hw2]].
      exists (f w); split; eauto.
      by rewrite Hw2.
    - intros x Hx. apply agree_increasing.
  Qed.
End agree_map.

Program Definition agreeRF (F : oFunctor) : OrarFunctor := {|
  orarFunctor_car A _ B _ := agreeR (oFunctor_car F A B);
  orarFunctor_map A1 _ A2 _ B1 _ B2 _ fg := agreeO_map (oFunctor_map F fg)
|}.
Next Obligation.
  intros ? A1 ? A2 ? B1 ? B2 ? n ???; simpl. by apply agreeO_map_ne, oFunctor_map_ne.
Qed.
Next Obligation.
  intros F A ? B ? x; simpl. rewrite -{2}(agree_map_id x).
  apply (agree_map_ext _)=>y. by rewrite oFunctor_map_id.
Qed.
Next Obligation.
  intros F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x; simpl. rewrite -agree_map_compose.
  apply (agree_map_ext _)=>y; apply oFunctor_map_compose.
Qed.

#[export] Instance agreeRF_contractive F :
  oFunctorContractive F → OrarFunctorContractive (agreeRF F).
Proof.
  intros ? A1 ? A2 ? B1 ? B2 ? n ???; simpl.
  by apply agreeO_map_ne, oFunctor_map_contractive.
Qed.


Declare ML Module "coq-paramcoq.plugin".

Require Import NPeano.
Require Import Recdef.
Set Implicit Arguments.

Fixpoint subS (n m : nat) {struct n} : nat :=
  match n return  nat with
  | 0 => 0(* originally n*)
  | S k => match m return nat with
           | 0 => S k (* originally n*)
           | S l => subS k l
           end
  end.

Definition modS :=
fun x y : nat => match y with
                 | 0 => y
                 | S y' => subS y' (snd (divmod x y' 0 y'))
                 end.

(*
Lemma subS_same : forall n m, subS  n m = Nat.sub n m.
Proof.
  induction n; destruct m; simpl; auto.
Qed.

Lemma modS_same : forall n m, modS  n m = Nat.modulo n m.
Proof.
   destruct m; simpl; auto.
    rewrite  subS_same. reflexivity.
Qed.
*)
Lemma NNmod_upper_boundA
     : forall a b : nat, b <> 0 -> modS a  b < b.
Admitted.

Definition T := forall a b : nat, b <> 0 -> modS a  b < b.
Parametricity Recursive T.
Print T_R.

Axiom NNmod_upper_boundA_R : (fun H H0 : forall a b : nat, b <> 0 -> modS a b < b =>
forall (a₁ a₂ : nat) (a_R : nat_R a₁ a₂) (b₁ b₂ : nat) (b_R : nat_R b₁ b₂)
  (H1 : b₁ <> 0) (H2 : b₂ <> 0),
not_R (eq_R nat_R b_R nat_R_O_R) H1 H2 ->
lt_R (modS_R a_R b_R) b_R (H a₁ b₁ H1)
  (H0 a₂ b₂ H2)) NNmod_upper_boundA NNmod_upper_boundA.

Realizer  NNmod_upper_boundA as NNmod_upper_boundA_RR := NNmod_upper_boundA_R.

Lemma NNmod_upper_bound
     : forall a b : nat, b <> 0 -> modS a  b < b.
Proof.

  intros. apply NNmod_upper_boundA. assumption.
Qed.

Function GcdS (a b : nat) {wf lt a} : nat :=
match a with
 | O => b
 | S k =>  GcdS (modS b (S k))  (S k)
end.
Proof.
- intros m n k Heq. apply  NNmod_upper_bound.
  intros Hc. inversion Hc.
- apply Wf_nat.lt_wf.
Defined.

Require Import ProofIrrelevance.
Parametricity Recursive sig_rec.

Ltac destruct_reflexivity :=
  intros ; repeat match goal with
    | [ x : _ |- _ = _ ] => destruct x; reflexivity; fail
  end.

Ltac destruct_construct x :=
    (destruct x; [ constructor 1 ]; auto; fail)
 || (destruct x; [ constructor 1 | constructor 2 ]; auto; fail)
 || (destruct x; [ constructor 1 | constructor 2 | constructor 3]; auto; fail).

Ltac unfold_cofix := intros; match goal with
 [ |- _ = ?folded ] =>
    let x := fresh "x" in
    let typ := type of folded in
    (match folded with _ _ => pattern folded | _ => pattern folded at 2 end);
    match goal with [ |- ?P ?x ] =>
    refine (let rebuild : typ -> typ := _ in
            let path : rebuild folded = folded := _ in
            eq_rect _ P _ folded path) end;
    [ intro x ; destruct_construct x; fail
    | destruct folded; reflexivity
    | reflexivity]; fail
end.

Ltac destruct_with_nat_arg_pattern x :=
  pattern x;
  match type of x with
   | ?I 0 => refine (let gen : forall m (q : I m),
     (match m return I m -> Type with
         0 => fun p => _ p
     | S n => fun _  => unit end q) := _ in gen 0 x)
   | ?I (S ?n) => refine (let gen : forall m (q : I m),
     (match m return I m -> Type with
         0 => fun _  => unit
     | S n => fun p => _ p end q) := _ in gen (S n) x)
  end; intros m q; destruct q.

Ltac destruct_reflexivity_with_nat_arg_pattern :=
  intros ; repeat match goal with
    | [ x : _ |- _ = _ ] => destruct_with_nat_arg_pattern x; reflexivity; fail
  end.

Global Parametricity Tactic := ((destruct_reflexivity; fail)
                            || (unfold_cofix; fail)
                            || (destruct_reflexivity_with_nat_arg_pattern; fail)
                            ||  auto).

Parametricity Recursive GcdS qualified.

(*
1 subgoal
______________________________________(1/1)
forall (a₁ a₂ : nat) (a_R : nat_R a₁ a₂) (b₁ b₂ : nat) (b_R : nat_R b₁ b₂),
sig_R nat_R
  (fun (v₁ v₂ : nat) (v_R : nat_R v₁ v₂) =>
   ex_R nat_R
     (fun (p₁ p₂ : nat) (p_R : nat_R p₁ p₂)
        (H : forall k : nat,
             p₁ < k ->
             forall def : nat -> nat -> nat,
             iter (nat -> nat -> nat) k GcdS_F def a₁ b₁ = v₁)
        (H0 : forall k : nat,
              p₂ < k ->
              forall def : nat -> nat -> nat,
              iter (nat -> nat -> nat) k GcdS_F def a₂ b₂ = v₂) =>
      forall (k₁ k₂ : nat) (k_R : nat_R k₁ k₂) (H1 : p₁ < k₁) (H2 : p₂ < k₂),
      Coq__o__Init__o__Peano__o__lt_R p_R k_R H1 H2 ->
      forall (def₁ def₂ : nat -> nat -> nat)
        (def_R : forall a₁0 a₂0 : nat,
                 nat_R a₁0 a₂0 ->
                 forall b₁0 b₂0 : nat,
                 nat_R b₁0 b₂0 -> nat_R (def₁ a₁0 b₁0) (def₂ a₂0 b₂0)),
      eq_R nat_R
        (Coq__o__funind__o__Recdef__o__iter_R
           (fun H3 H4 : nat -> nat -> nat =>
            forall a₁0 a₂0 : nat,
            nat_R a₁0 a₂0 ->
            forall b₁0 b₂0 : nat,
            nat_R b₁0 b₂0 -> nat_R (H3 a₁0 b₁0) (H4 a₂0 b₂0)) k_R GcdS_F
           GcdS_F Top__o__GcdS_F_R def₁ def₂ def_R a₁ a₂ a_R b₁ b₂ b_R) v_R
        (H k₁ H1 def₁) (H0 k₂ H2 def₂))) (GcdS_terminate a₁ b₁)
  (GcdS_terminate a₂ b₂)
*)

(*
DepRefs:
GcdS_F
iter
and
iff
Basics.impl
unit
Init.Unconvertible
Relation_Definitions.relation
Morphisms.Proper
RelationClasses.subrelation
Morphisms.subrelation_proper
eq_rect
eq_ind
eq_sym
eq_ind_r
PeanoNat.Nat.succ_wd_obligation_1
PeanoNat.Nat.succ_wd
Morphisms.subrelation_refl
Morphisms.respectful
RelationClasses.Transitive
RelationClasses.transitivity
Morphisms.trans_co_impl_morphism_obligation_1
Morphisms.trans_co_impl_morphism
RelationClasses.Symmetric
RelationClasses.Reflexive
RelationClasses.Equivalence
RelationClasses.Equivalence_Transitive
RelationClasses.PER
RelationClasses.PER_Symmetric
RelationClasses.symmetry
RelationClasses.PER_Transitive
Morphisms.PER_morphism_obligation_1
Morphisms.PER_morphism
Init.Nat.pred
RelationClasses.Equivalence_Symmetric
RelationClasses.Equivalence_PER
PeanoNat.Nat.pred_succ
Morphisms.reflexive_proper_proxy
and_rect
and_ind
Morphisms.iff_impl_subrelation
PeanoNat.Nat.pred_wd_obligation_1
PeanoNat.Nat.pred_wd
RelationClasses.Equivalence_Reflexive
Morphisms.subrelation_respectful
RelationClasses.eq_Reflexive
eq_trans
RelationClasses.eq_Transitive
RelationClasses.eq_Symmetric
RelationClasses.eq_equivalence
PeanoNat.Nat.eq_equiv
PeanoNat.Nat.succ_inj
PeanoNat.Nat.succ_inj_wd
Morphisms.ProperProxy
Morphisms.Reflexive_partial_app_morphism
False_rect
False_ind
iff_sym
RelationClasses.iff_Symmetric
iff_trans
RelationClasses.iff_Transitive
iff_refl
RelationClasses.iff_Reflexive
RelationClasses.iff_equivalence
Morphisms.per_partial_app_morphism_obligation_1
Morphisms.per_partial_app_morphism
Morphisms.trans_sym_co_inv_impl_morphism_obligation_1
Morphisms.trans_sym_co_inv_impl_morphism
Basics.flip
RelationClasses.reflexivity
comparison
Init.Nat.compare
or
or_ind
Morphisms.trans_co_eq_inv_impl_morphism_obligation_1
Morphisms.trans_co_eq_inv_impl_morphism
Morphisms.eq_proper_proxy
Morphisms_Prop.or_iff_morphism_obligation_1
Morphisms_Prop.or_iff_morphism
nat_rect
nat_ind
f_equal
f_equal_nat
eq_add_S
True
PeanoNat.Nat.compare_eq_iff
le_0_n
le_ind
le_pred
le_S_n
le_n_S
PeanoNat.Nat.compare_le_iff
PeanoNat.Nat.compare_lt_iff
PeanoNat.Nat.lt_eq_cases
PeanoNat.Nat.le_refl
Morphisms.iff_flip_impl_subrelation
PeanoNat.Nat.lt_succ_r
PeanoNat.Nat.lt_succ_diag_r
PeanoNat.Nat.lt_wd_obligation_1
PeanoNat.Nat.lt_wd
PeanoNat.Nat.compare_refl
Morphisms_Prop.not_iff_morphism_obligation_1
Morphisms_Prop.not_iff_morphism
PeanoNat.Nat.lt_irrefl
PeanoNat.Nat.neq_succ_diag_l
PeanoNat.Nat.lt_le_incl
PeanoNat.Nat.nlt_succ_diag_l
PeanoNat.Nat.nle_succ_diag_l
PeanoNat.Nat.bi_induction
Morphisms_Prop.iff_iff_iff_impl_morphism_obligation_1
Morphisms_Prop.iff_iff_iff_impl_morphism
PeanoNat.Nat.central_induction
PeanoNat.Nat.le_wd
or_iff_compat_r
or_cancel_r
PeanoNat.Nat.le_succ_l
PeanoNat.Nat.succ_lt_mono
Lt.lt_S_n
Acc
Acc_inv
RelationClasses.complement
RelationClasses.Irreflexive
RelationClasses.StrictOrder
RelationClasses.StrictOrder_Transitive
PeanoNat.Nat.lt_asymm
PeanoNat.Nat.lt_trans
PeanoNat.Nat.lt_strorder
PeanoNat.Nat.Private_OrderTac.IsTotal.lt_strorder
PeanoNat.Nat.le_lteq
PeanoNat.Nat.Private_OrderTac.IsTotal.le_lteq
PeanoNat.Nat.lt_compat
PeanoNat.Nat.Private_OrderTac.IsTotal.lt_compat
OrdersTac.ord
OrdersTac.trans_ord
PeanoNat.Nat.Private_OrderTac.IsTotal.eq_equiv
PeanoNat.Nat.Private_OrderTac.Tac.interp_ord
PeanoNat.Nat.Private_OrderTac.Tac.trans
PeanoNat.Nat.Private_OrderTac.Tac.le_lt_trans
RelationClasses.StrictOrder_Irreflexive
PeanoNat.Nat.Private_OrderTac.Tac.lt_irrefl
PeanoNat.Nat.le_gt_cases
PeanoNat.Nat.lt_trichotomy
PeanoNat.Nat.lt_total
PeanoNat.Nat.Private_OrderTac.IsTotal.lt_total
PeanoNat.Nat.Private_OrderTac.Tac.not_ge_lt
PeanoNat.Nat.lt_le_trans
Wf_nat.ltof
Lt.lt_n_Sm_le
PeanoNat.Nat.Private_OrderTac.Tac.lt_eq
PeanoNat.Nat.Private_OrderTac.Tac.not_gt_le
PeanoNat.Nat.eq_le_incl
PeanoNat.Nat.Private_OrderTac.Tac.lt_trans
PeanoNat.Nat.le_le_succ_r
PeanoNat.Nat.le_succ_r
PeanoNat.Nat.pred_0
PeanoNat.Nat.neq_succ_0
PeanoNat.Nat.le_0_l
PeanoNat.Nat.le_ngt
PeanoNat.Nat.nlt_0_r
well_founded
Wf_nat.well_founded_ltof
Wf_nat.lt_wf
NNmod_upper_bound
GcdS_tcc
max_type
max_type_rect
max_type_ind
ex
ex_ind
Lt.lt_n_S
nat_rec
gt
Lt.lt_le_S
Gt.gt_le_S
all
Morphisms.pointwise_relation
Morphisms_Prop.all_iff_morphism_obligation_1
Morphisms_Prop.all_iff_morphism
PeanoNat.Nat.lt_exists_pred_strong
PeanoNat.Nat.lt_exists_pred
PeanoNat.Nat.rs_rs'
PeanoNat.Nat.A'A_right
PeanoNat.Nat.rbase
PeanoNat.Nat.lt_lt_succ_r
PeanoNat.Nat.rs'_rs''
PeanoNat.Nat.strong_right_induction
PeanoNat.Nat.right_induction
PeanoNat.Nat.induction
PeanoNat.Nat.lt_0_succ
Le.le_n_S
sumbool
sumbool_rect
sumbool_rec
Compare_dec.le_lt_dec
Compare_dec.le_gt_dec
max
and_rec
PeanoNat.Nat.le_lt_trans
GcdS_terminate
GcdS
Top__o__GcdS_F_R is defined
'Top__o__GcdS_F_R' is now a registered translation.
Coq__o__funind__o__Recdef__o__iter_R is defined
'Coq__o__funind__o__Recdef__o__iter_R' is now a registered translation.
and_R is defined
and_R_rect is defined
and_R_ind is defined
and_R_rec is defined
Coq__o__Init__o__Logic__o__iff_R is defined
'Coq__o__Init__o__Logic__o__iff_R' is now a registered translation.
Coq__o__Program__o__Basics__o__impl_R is defined
'Coq__o__Program__o__Basics__o__impl_R' is now a registered translation.
unit_R is defined
unit_R_rect is defined
unit_R_ind is defined
unit_R_rec is defined
Coq__o__Classes__o__Init__o__Unconvertible_R is defined
'Coq__o__Classes__o__Init__o__Unconvertible_R' is now a registered translation.
Coq__o__Relations__o__Relation_Definitions__o__relation_R is defined
'Coq__o__Relations__o__Relation_Definitions__o__relation_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__Proper_R is defined
'Coq__o__Classes__o__Morphisms__o__Proper_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__subrelation_R is defined
'Coq__o__Classes__o__RelationClasses__o__subrelation_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__subrelation_proper_R is defined
'Coq__o__Classes__o__Morphisms__o__subrelation_proper_R' is now a registered translation.
Coq__o__Init__o__Logic__o__eq_rect_R is defined
'Coq__o__Init__o__Logic__o__eq_rect_R' is now a registered translation.
Coq__o__Init__o__Logic__o__eq_ind_R is defined
'Coq__o__Init__o__Logic__o__eq_ind_R' is now a registered translation.
Coq__o__Init__o__Logic__o__eq_sym_R is defined
'Coq__o__Init__o__Logic__o__eq_sym_R' is now a registered translation.
Coq__o__Init__o__Logic__o__eq_ind_r_R is defined
'Coq__o__Init__o__Logic__o__eq_ind_r_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_wd_obligation_1_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_wd_obligation_1_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_wd_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_wd_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__subrelation_refl_R is defined
'Coq__o__Classes__o__Morphisms__o__subrelation_refl_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__respectful_R is defined
'Coq__o__Classes__o__Morphisms__o__respectful_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__Transitive_R is defined
'Coq__o__Classes__o__RelationClasses__o__Transitive_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__transitivity_R is defined
'Coq__o__Classes__o__RelationClasses__o__transitivity_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__trans_co_impl_morphism_obligation_1_R is defined
'Coq__o__Classes__o__Morphisms__o__trans_co_impl_morphism_obligation_1_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__trans_co_impl_morphism_R is defined
'Coq__o__Classes__o__Morphisms__o__trans_co_impl_morphism_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__Symmetric_R is defined
'Coq__o__Classes__o__RelationClasses__o__Symmetric_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__Reflexive_R is defined
'Coq__o__Classes__o__RelationClasses__o__Reflexive_R' is now a registered translation.
Equivalence_R is defined
Coq__o__Classes__o__RelationClasses__o__Equivalence_Transitive_R is defined
'Coq__o__Classes__o__RelationClasses__o__Equivalence_Transitive_R' is now a registered translation.
PER_R is defined
Coq__o__Classes__o__RelationClasses__o__PER_Symmetric_R is defined
'Coq__o__Classes__o__RelationClasses__o__PER_Symmetric_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__symmetry_R is defined
'Coq__o__Classes__o__RelationClasses__o__symmetry_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__PER_Transitive_R is defined
'Coq__o__Classes__o__RelationClasses__o__PER_Transitive_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__PER_morphism_obligation_1_R is defined
'Coq__o__Classes__o__Morphisms__o__PER_morphism_obligation_1_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__PER_morphism_R is defined
'Coq__o__Classes__o__Morphisms__o__PER_morphism_R' is now a registered translation.
Coq__o__Init__o__Nat__o__pred_R is defined
'Coq__o__Init__o__Nat__o__pred_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__Equivalence_Symmetric_R is defined
'Coq__o__Classes__o__RelationClasses__o__Equivalence_Symmetric_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__Equivalence_PER_R is defined
'Coq__o__Classes__o__RelationClasses__o__Equivalence_PER_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_succ_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_succ_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__reflexive_proper_proxy_R is defined
'Coq__o__Classes__o__Morphisms__o__reflexive_proper_proxy_R' is now a registered translation.
Coq__o__Init__o__Logic__o__and_rect_R is defined
'Coq__o__Init__o__Logic__o__and_rect_R' is now a registered translation.
Coq__o__Init__o__Logic__o__and_ind_R is defined
'Coq__o__Init__o__Logic__o__and_ind_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__iff_impl_subrelation_R is defined
'Coq__o__Classes__o__Morphisms__o__iff_impl_subrelation_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_wd_obligation_1_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_wd_obligation_1_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_wd_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_wd_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__Equivalence_Reflexive_R is defined
'Coq__o__Classes__o__RelationClasses__o__Equivalence_Reflexive_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__subrelation_respectful_R is defined
'Coq__o__Classes__o__Morphisms__o__subrelation_respectful_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__eq_Reflexive_R is defined
'Coq__o__Classes__o__RelationClasses__o__eq_Reflexive_R' is now a registered translation.
Coq__o__Init__o__Logic__o__eq_trans_R is defined
'Coq__o__Init__o__Logic__o__eq_trans_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__eq_Transitive_R is defined
'Coq__o__Classes__o__RelationClasses__o__eq_Transitive_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__eq_Symmetric_R is defined
'Coq__o__Classes__o__RelationClasses__o__eq_Symmetric_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__eq_equivalence_R is defined
'Coq__o__Classes__o__RelationClasses__o__eq_equivalence_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__eq_equiv_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__eq_equiv_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_inj_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_inj_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_inj_wd_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_inj_wd_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__ProperProxy_R is defined
'Coq__o__Classes__o__Morphisms__o__ProperProxy_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__Reflexive_partial_app_morphism_R is defined
'Coq__o__Classes__o__Morphisms__o__Reflexive_partial_app_morphism_R' is now a registered translation.
Coq__o__Init__o__Logic__o__False_rect_R is defined
'Coq__o__Init__o__Logic__o__False_rect_R' is now a registered translation.
Coq__o__Init__o__Logic__o__False_ind_R is defined
'Coq__o__Init__o__Logic__o__False_ind_R' is now a registered translation.
Coq__o__Init__o__Logic__o__iff_sym_R is defined
'Coq__o__Init__o__Logic__o__iff_sym_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__iff_Symmetric_R is defined
'Coq__o__Classes__o__RelationClasses__o__iff_Symmetric_R' is now a registered translation.
Coq__o__Init__o__Logic__o__iff_trans_R is defined
'Coq__o__Init__o__Logic__o__iff_trans_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__iff_Transitive_R is defined
'Coq__o__Classes__o__RelationClasses__o__iff_Transitive_R' is now a registered translation.
Coq__o__Init__o__Logic__o__iff_refl_R is defined
'Coq__o__Init__o__Logic__o__iff_refl_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__iff_Reflexive_R is defined
'Coq__o__Classes__o__RelationClasses__o__iff_Reflexive_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__iff_equivalence_R is defined
'Coq__o__Classes__o__RelationClasses__o__iff_equivalence_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__per_partial_app_morphism_obligation_1_R is defined
'Coq__o__Classes__o__Morphisms__o__per_partial_app_morphism_obligation_1_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__per_partial_app_morphism_R is defined
'Coq__o__Classes__o__Morphisms__o__per_partial_app_morphism_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__trans_sym_co_inv_impl_morphism_obligation_1_R is defined
'Coq__o__Classes__o__Morphisms__o__trans_sym_co_inv_impl_morphism_obligation_1_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__trans_sym_co_inv_impl_morphism_R is defined
'Coq__o__Classes__o__Morphisms__o__trans_sym_co_inv_impl_morphism_R' is now a registered translation.
Coq__o__Program__o__Basics__o__flip_R is defined
'Coq__o__Program__o__Basics__o__flip_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__reflexivity_R is defined
'Coq__o__Classes__o__RelationClasses__o__reflexivity_R' is now a registered translation.
comparison_R is defined
comparison_R_rect is defined
comparison_R_ind is defined
comparison_R_rec is defined
Coq__o__Init__o__Nat__o__compare_R is defined
'Coq__o__Init__o__Nat__o__compare_R' is now a registered translation.
or_R is defined
or_R_ind is defined
Coq__o__Init__o__Logic__o__or_ind_R is defined
'Coq__o__Init__o__Logic__o__or_ind_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__trans_co_eq_inv_impl_morphism_obligation_1_R is defined
'Coq__o__Classes__o__Morphisms__o__trans_co_eq_inv_impl_morphism_obligation_1_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__trans_co_eq_inv_impl_morphism_R is defined
'Coq__o__Classes__o__Morphisms__o__trans_co_eq_inv_impl_morphism_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__eq_proper_proxy_R is defined
'Coq__o__Classes__o__Morphisms__o__eq_proper_proxy_R' is now a registered translation.
Coq__o__Classes__o__Morphisms_Prop__o__or_iff_morphism_obligation_1_R is defined
'Coq__o__Classes__o__Morphisms_Prop__o__or_iff_morphism_obligation_1_R' is now a registered translation.
Coq__o__Classes__o__Morphisms_Prop__o__or_iff_morphism_R is defined
'Coq__o__Classes__o__Morphisms_Prop__o__or_iff_morphism_R' is now a registered translation.
Coq__o__Init__o__Datatypes__o__nat_rect_R is defined
'Coq__o__Init__o__Datatypes__o__nat_rect_R' is now a registered translation.
Coq__o__Init__o__Datatypes__o__nat_ind_R is defined
'Coq__o__Init__o__Datatypes__o__nat_ind_R' is now a registered translation.
Coq__o__Init__o__Logic__o__f_equal_R is defined
'Coq__o__Init__o__Logic__o__f_equal_R' is now a registered translation.
Coq__o__Init__o__Peano__o__f_equal_nat_R is defined
'Coq__o__Init__o__Peano__o__f_equal_nat_R' is now a registered translation.
Coq__o__Init__o__Peano__o__eq_add_S_R is defined
'Coq__o__Init__o__Peano__o__eq_add_S_R' is now a registered translation.
True_R is defined
True_R_rect is defined
True_R_ind is defined
True_R_rec is defined
Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_eq_iff_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_eq_iff_R' is now a registered translation.
Coq__o__Init__o__Peano__o__le_0_n_R is defined
'Coq__o__Init__o__Peano__o__le_0_n_R' is now a registered translation.
Coq__o__Init__o__Peano__o__le_ind_R is defined
'Coq__o__Init__o__Peano__o__le_ind_R' is now a registered translation.
Coq__o__Init__o__Peano__o__le_pred_R is defined
'Coq__o__Init__o__Peano__o__le_pred_R' is now a registered translation.
Coq__o__Init__o__Peano__o__le_S_n_R is defined
'Coq__o__Init__o__Peano__o__le_S_n_R' is now a registered translation.
Coq__o__Init__o__Peano__o__le_n_S_R is defined
'Coq__o__Init__o__Peano__o__le_n_S_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_le_iff_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_le_iff_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_lt_iff_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_lt_iff_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_eq_cases_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_eq_cases_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__le_refl_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_refl_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__iff_flip_impl_subrelation_R is defined
'Coq__o__Classes__o__Morphisms__o__iff_flip_impl_subrelation_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_succ_r_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_succ_r_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_succ_diag_r_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_succ_diag_r_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_wd_obligation_1_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_wd_obligation_1_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_wd_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_wd_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_refl_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_refl_R' is now a registered translation.
Coq__o__Classes__o__Morphisms_Prop__o__not_iff_morphism_obligation_1_R is defined
'Coq__o__Classes__o__Morphisms_Prop__o__not_iff_morphism_obligation_1_R' is now a registered translation.
Coq__o__Classes__o__Morphisms_Prop__o__not_iff_morphism_R is defined
'Coq__o__Classes__o__Morphisms_Prop__o__not_iff_morphism_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_irrefl_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_irrefl_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__neq_succ_diag_l_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__neq_succ_diag_l_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_le_incl_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_le_incl_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__nlt_succ_diag_l_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__nlt_succ_diag_l_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__nle_succ_diag_l_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__nle_succ_diag_l_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__bi_induction_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__bi_induction_R' is now a registered translation.
Coq__o__Classes__o__Morphisms_Prop__o__iff_iff_iff_impl_morphism_obligation_1_R is defined
'Coq__o__Classes__o__Morphisms_Prop__o__iff_iff_iff_impl_morphism_obligation_1_R' is now a registered translation.
Coq__o__Classes__o__Morphisms_Prop__o__iff_iff_iff_impl_morphism_R is defined
'Coq__o__Classes__o__Morphisms_Prop__o__iff_iff_iff_impl_morphism_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__central_induction_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__central_induction_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__le_wd_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_wd_R' is now a registered translation.
Coq__o__Init__o__Logic__o__or_iff_compat_r_R is defined
'Coq__o__Init__o__Logic__o__or_iff_compat_r_R' is now a registered translation.
Coq__o__Init__o__Logic__o__or_cancel_r_R is defined
'Coq__o__Init__o__Logic__o__or_cancel_r_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__le_succ_l_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_succ_l_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_lt_mono_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_lt_mono_R' is now a registered translation.
Coq__o__Arith__o__Lt__o__lt_S_n_R is defined
'Coq__o__Arith__o__Lt__o__lt_S_n_R' is now a registered translation.
Acc_R is defined
Acc_R_rect is defined
Acc_R_ind is defined
Acc_R_rec is defined
Coq__o__Init__o__Wf__o__Acc_inv_R is defined
'Coq__o__Init__o__Wf__o__Acc_inv_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__complement_R is defined
'Coq__o__Classes__o__RelationClasses__o__complement_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__Irreflexive_R is defined
'Coq__o__Classes__o__RelationClasses__o__Irreflexive_R' is now a registered translation.
StrictOrder_R is defined
Coq__o__Classes__o__RelationClasses__o__StrictOrder_Transitive_R is defined
'Coq__o__Classes__o__RelationClasses__o__StrictOrder_Transitive_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_asymm_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_asymm_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_trans_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_trans_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_strorder_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_strorder_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__lt_strorder_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__lt_strorder_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__le_lteq_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_lteq_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__le_lteq_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__le_lteq_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_compat_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_compat_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__lt_compat_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__lt_compat_R' is now a registered translation.
ord_R is defined
ord_R_rect is defined
ord_R_ind is defined
ord_R_rec is defined
Coq__o__Structures__o__OrdersTac__o__trans_ord_R is defined
'Coq__o__Structures__o__OrdersTac__o__trans_ord_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__eq_equiv_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__eq_equiv_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__interp_ord_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__interp_ord_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__trans_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__trans_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__le_lt_trans_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__le_lt_trans_R' is now a registered translation.
Coq__o__Classes__o__RelationClasses__o__StrictOrder_Irreflexive_R is defined
'Coq__o__Classes__o__RelationClasses__o__StrictOrder_Irreflexive_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__lt_irrefl_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__lt_irrefl_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__le_gt_cases_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_gt_cases_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_trichotomy_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_trichotomy_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_total_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_total_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__lt_total_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__lt_total_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__not_ge_lt_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__not_ge_lt_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_le_trans_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_le_trans_R' is now a registered translation.
Coq__o__Arith__o__Wf_nat__o__ltof_R is defined
'Coq__o__Arith__o__Wf_nat__o__ltof_R' is now a registered translation.
Coq__o__Arith__o__Lt__o__lt_n_Sm_le_R is defined
'Coq__o__Arith__o__Lt__o__lt_n_Sm_le_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__lt_eq_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__lt_eq_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__not_gt_le_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__not_gt_le_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__eq_le_incl_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__eq_le_incl_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__lt_trans_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__lt_trans_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__le_le_succ_r_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_le_succ_r_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__le_succ_r_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_succ_r_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_0_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_0_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__neq_succ_0_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__neq_succ_0_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__le_0_l_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_0_l_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__le_ngt_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_ngt_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__nlt_0_r_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__nlt_0_r_R' is now a registered translation.
Coq__o__Init__o__Wf__o__well_founded_R is defined
'Coq__o__Init__o__Wf__o__well_founded_R' is now a registered translation.
Coq__o__Arith__o__Wf_nat__o__well_founded_ltof_R is defined
'Coq__o__Arith__o__Wf_nat__o__well_founded_ltof_R' is now a registered translation.
Coq__o__Arith__o__Wf_nat__o__lt_wf_R is defined
'Coq__o__Arith__o__Wf_nat__o__lt_wf_R' is now a registered translation.
Top__o__NNmod_upper_bound_R is defined
'Top__o__NNmod_upper_bound_R' is now a registered translation.
Top__o__GcdS_tcc_R is defined
'Top__o__GcdS_tcc_R' is now a registered translation.
max_type_R is defined
max_type_R_rect is defined
max_type_R_ind is defined
max_type_R_rec is defined
Coq__o__funind__o__Recdef__o__max_type_rect_R is defined
'Coq__o__funind__o__Recdef__o__max_type_rect_R' is now a registered translation.
Coq__o__funind__o__Recdef__o__max_type_ind_R is defined
'Coq__o__funind__o__Recdef__o__max_type_ind_R' is now a registered translation.
ex_R is defined
ex_R_ind is defined
Coq__o__Init__o__Logic__o__ex_ind_R is defined
'Coq__o__Init__o__Logic__o__ex_ind_R' is now a registered translation.
Coq__o__Arith__o__Lt__o__lt_n_S_R is defined
'Coq__o__Arith__o__Lt__o__lt_n_S_R' is now a registered translation.
Coq__o__Init__o__Datatypes__o__nat_rec_R is defined
'Coq__o__Init__o__Datatypes__o__nat_rec_R' is now a registered translation.
Coq__o__Init__o__Peano__o__gt_R is defined
'Coq__o__Init__o__Peano__o__gt_R' is now a registered translation.
Coq__o__Arith__o__Lt__o__lt_le_S_R is defined
'Coq__o__Arith__o__Lt__o__lt_le_S_R' is now a registered translation.
Coq__o__Arith__o__Gt__o__gt_le_S_R is defined
'Coq__o__Arith__o__Gt__o__gt_le_S_R' is now a registered translation.
Coq__o__Init__o__Logic__o__all_R is defined
'Coq__o__Init__o__Logic__o__all_R' is now a registered translation.
Coq__o__Classes__o__Morphisms__o__pointwise_relation_R is defined
'Coq__o__Classes__o__Morphisms__o__pointwise_relation_R' is now a registered translation.
Coq__o__Classes__o__Morphisms_Prop__o__all_iff_morphism_obligation_1_R is defined
'Coq__o__Classes__o__Morphisms_Prop__o__all_iff_morphism_obligation_1_R' is now a registered translation.
Coq__o__Classes__o__Morphisms_Prop__o__all_iff_morphism_R is defined
'Coq__o__Classes__o__Morphisms_Prop__o__all_iff_morphism_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_exists_pred_strong_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_exists_pred_strong_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_exists_pred_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_exists_pred_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__rs_rs'_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__rs_rs'_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__A'A_right_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__A'A_right_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__rbase_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__rbase_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_lt_succ_r_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_lt_succ_r_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__rs'_rs''_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__rs'_rs''_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__strong_right_induction_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__strong_right_induction_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__right_induction_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__right_induction_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__induction_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__induction_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_0_succ_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_0_succ_R' is now a registered translation.
Coq__o__Arith__o__Le__o__le_n_S_R is defined
'Coq__o__Arith__o__Le__o__le_n_S_R' is now a registered translation.
sumbool_R is defined
sumbool_R_rect is defined
sumbool_R_ind is defined
sumbool_R_rec is defined
Coq__o__Init__o__Specif__o__sumbool_rect_R is defined
'Coq__o__Init__o__Specif__o__sumbool_rect_R' is now a registered translation.
Coq__o__Init__o__Specif__o__sumbool_rec_R is defined
'Coq__o__Init__o__Specif__o__sumbool_rec_R' is now a registered translation.
Coq__o__Arith__o__Compare_dec__o__le_lt_dec_R is defined
'Coq__o__Arith__o__Compare_dec__o__le_lt_dec_R' is now a registered translation.
Coq__o__Arith__o__Compare_dec__o__le_gt_dec_R is defined
'Coq__o__Arith__o__Compare_dec__o__le_gt_dec_R' is now a registered translation.
Coq__o__funind__o__Recdef__o__max_R is defined
'Coq__o__funind__o__Recdef__o__max_R' is now a registered translation.
Coq__o__Init__o__Logic__o__and_rec_R is defined
'Coq__o__Init__o__Logic__o__and_rec_R' is now a registered translation.
Coq__o__Arith__o__PeanoNat__o__Nat__o__le_lt_trans_R is defined
'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_lt_trans_R' is now a registered translation.

Anomaly: Uncaught exception Not_found. Please report at
http://coq.inria.fr/bugs/.
*)


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

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

Print Assumptions square.


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

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

Print Assumptions square.