(* Default settings (from HsToCoq.Coq.Preamble) *)

Generalizable All Variables.

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

Require Coq.Program.Tactics.
Require Coq.Program.Wf.

(* Preamble *)

(* Converted imports: *)

Require Data.Bits.
Require Data.Either.
Require Data.Foldable.
Require Data.Functor.Classes.
Require GHC.Base.
Require GHC.Err.
Require GHC.Num.
Require GHC.Tuple.
Require HsToCoq.DeferredFix.
Require Nat.
Require Utils.Containers.Internal.PtrEquality.
Import GHC.Base.Notations.
Import GHC.Num.Notations.

(* Converted type declarations: *)

Definition Size :=
  GHC.Num.Int%type.

Inductive Set_ a : Type :=
  | Bin : Size -> a -> (Set_ a) -> (Set_ a) -> Set_ a
  | Tip : Set_ a.

Inductive MergeSet a : Type :=
  | Mk_MergeSet (getMergeSet : Set_ a) : MergeSet a.

Arguments Bin {_} _ _ _ _.

Arguments Tip {_}.

Arguments Mk_MergeSet {_} _.

Definition getMergeSet {a} (arg_0__ : MergeSet a) :=
  let 'Mk_MergeSet getMergeSet := arg_0__ in
  getMergeSet.

(* Midamble *)

Require Omega.

Ltac termination_by_omega :=
  Coq.Program.Tactics.program_simpl;
  simpl;Omega.omega.

Fixpoint set_size {a} (s : Set_ a) : nat :=
  match s with
  | Tip => 0
  | Bin _ _ s1 s2 => 1 + set_size s1 + set_size s2
  end.

Require Import HsToCoq.Err.

Instance Set_Default {a} : Default (Set_ a) :=
  Build_Default _ Tip.
Instance MergeSetDefault {a} : Default (MergeSet a) :=
  Build_Default _ (Mk_MergeSet default).

(* Converted value declarations: *)

Definition delta : GHC.Num.Int :=
  #3.

Definition ratio : GHC.Num.Int :=
  #2.

Definition size {a : Type} : Set_ a -> GHC.Num.Int :=
  fun arg_0__ => match arg_0__ with | Tip => #0 | Bin sz _ _ _ => sz end.

Definition balanceL {a} : a -> Set_ a -> Set_ a -> Set_ a :=
  fun x l r =>
    match r with
    | Tip =>
        match l with
        | Tip => Bin #1 x Tip Tip
        | Bin _ _ Tip Tip => Bin #2 x l Tip
        | Bin _ lx Tip (Bin _ lrx _ _) =>
            Bin #3 lrx (Bin #1 lx Tip Tip) (Bin #1 x Tip Tip)
        | Bin _ lx (Bin _ _ _ _ as ll) Tip => Bin #3 lx ll (Bin #1 x Tip Tip)
        | Bin ls lx (Bin lls _ _ _ as ll) (Bin lrs lrx lrl lrr as lr) =>
            if lrs GHC.Base.< (ratio GHC.Num.* lls) : bool
            then Bin (#1 GHC.Num.+ ls) lx ll (Bin (#1 GHC.Num.+ lrs) x lr Tip) else
            Bin (#1 GHC.Num.+ ls) lrx (Bin ((#1 GHC.Num.+ lls) GHC.Num.+ size lrl) lx ll
                                       lrl) (Bin (#1 GHC.Num.+ size lrr) x lrr Tip)
        end
    | Bin rs _ _ _ =>
        match l with
        | Tip => Bin (#1 GHC.Num.+ rs) x Tip r
        | Bin ls lx ll lr =>
            if ls GHC.Base.> (delta GHC.Num.* rs) : bool
            then let scrut_9__ := pair ll lr in
                 match scrut_9__ with
                 | pair (Bin lls _ _ _) (Bin lrs lrx lrl lrr) =>
                     if lrs GHC.Base.< (ratio GHC.Num.* lls) : bool
                     then Bin ((#1 GHC.Num.+ ls) GHC.Num.+ rs) lx ll (Bin ((#1 GHC.Num.+ rs)
                                                                           GHC.Num.+
                                                                           lrs) x lr r) else
                     Bin ((#1 GHC.Num.+ ls) GHC.Num.+ rs) lrx (Bin ((#1 GHC.Num.+ lls) GHC.Num.+
                                                                    size lrl) lx ll lrl) (Bin ((#1 GHC.Num.+ rs)
                                                                                GHC.Num.+
                                                                                size lrr) x lrr r)
                 | _ =>
                     let 'pair _ _ := scrut_9__ in
                     GHC.Err.error (GHC.Base.hs_string__ "Failure in Data.Map.balanceL")
                 end else
            Bin ((#1 GHC.Num.+ ls) GHC.Num.+ rs) x l r
        end
    end.

Definition balanceR {a} : a -> Set_ a -> Set_ a -> Set_ a :=
  fun x l r =>
    match l with
    | Tip =>
        match r with
        | Tip => Bin #1 x Tip Tip
        | Bin _ _ Tip Tip => Bin #2 x Tip r
        | Bin _ rx Tip (Bin _ _ _ _ as rr) => Bin #3 rx (Bin #1 x Tip Tip) rr
        | Bin _ rx (Bin _ rlx _ _) Tip =>
            Bin #3 rlx (Bin #1 x Tip Tip) (Bin #1 rx Tip Tip)
        | Bin rs rx (Bin rls rlx rll rlr as rl) (Bin rrs _ _ _ as rr) =>
            if rls GHC.Base.< (ratio GHC.Num.* rrs) : bool
            then Bin (#1 GHC.Num.+ rs) rx (Bin (#1 GHC.Num.+ rls) x Tip rl) rr else
            Bin (#1 GHC.Num.+ rs) rlx (Bin (#1 GHC.Num.+ size rll) x Tip rll) (Bin ((#1
                                                                                GHC.Num.+
                                                                                rrs) GHC.Num.+
                                                                                size rlr) rx rlr rr)
        end
    | Bin ls _ _ _ =>
        match r with
        | Tip => Bin (#1 GHC.Num.+ ls) x l Tip
        | Bin rs rx rl rr =>
            if rs GHC.Base.> (delta GHC.Num.* ls) : bool
            then let scrut_9__ := pair rl rr in
                 match scrut_9__ with
                 | pair (Bin rls rlx rll rlr) (Bin rrs _ _ _) =>
                     if rls GHC.Base.< (ratio GHC.Num.* rrs) : bool
                     then Bin ((#1 GHC.Num.+ ls) GHC.Num.+ rs) rx (Bin ((#1 GHC.Num.+ ls) GHC.Num.+
                                                                        rls) x l rl) rr else
                     Bin ((#1 GHC.Num.+ ls) GHC.Num.+ rs) rlx (Bin ((#1 GHC.Num.+ ls) GHC.Num.+
                                                                    size rll) x l rll) (Bin ((#1 GHC.Num.+ rrs)
                                                                                GHC.Num.+
                                                                                size rlr) rx rlr rr)
                 | _ =>
                     let 'pair _ _ := scrut_9__ in
                     GHC.Err.error (GHC.Base.hs_string__ "Failure in Data.Map.balanceR")
                 end else
            Bin ((#1 GHC.Num.+ ls) GHC.Num.+ rs) x l r
        end
    end.

Definition singleton {a : Type} : a -> Set_ a :=
  fun x => Bin #1 x Tip Tip.

Definition insert {a : Type} `{GHC.Base.Ord a} : a -> Set_ a -> Set_ a :=
  fun x0 =>
    let go {a} `{GHC.Base.Ord a} : a -> a -> Set_ a -> Set_ a :=
      fix go (arg_0__ arg_1__ : a) (arg_2__ : Set_ a) : Set_ a
        := match arg_0__, arg_1__, arg_2__ with
           | orig, _, Tip => singleton (orig)
           | orig, x, (Bin sz y l r as t) =>
               match GHC.Base.compare x y with
               | Lt =>
                   let l' := go orig x l in
                   if Utils.Containers.Internal.PtrEquality.ptrEq l' l : bool then t else
                   balanceL y l' r
               | Gt =>
                   let r' := go orig x r in
                   if Utils.Containers.Internal.PtrEquality.ptrEq r' r : bool then t else
                   balanceR y l r'
               | Eq =>
                   if (Utils.Containers.Internal.PtrEquality.ptrEq orig y) : bool then t else
                   Bin sz (orig) l r
               end
           end in
    go x0 x0.

Definition insertR {a} `{GHC.Base.Ord a} : a -> Set_ a -> Set_ a :=
  fun x0 =>
    let go {a} `{GHC.Base.Ord a} : a -> a -> Set_ a -> Set_ a :=
      fix go (arg_0__ arg_1__ : a) (arg_2__ : Set_ a) : Set_ a
        := match arg_0__, arg_1__, arg_2__ with
           | orig, _, Tip => singleton (orig)
           | orig, x, (Bin _ y l r as t) =>
               match GHC.Base.compare x y with
               | Lt =>
                   let l' := go orig x l in
                   if Utils.Containers.Internal.PtrEquality.ptrEq l' l : bool then t else
                   balanceL y l' r
               | Gt =>
                   let r' := go orig x r in
                   if Utils.Containers.Internal.PtrEquality.ptrEq r' r : bool then t else
                   balanceR y l r'
               | Eq => t
               end
           end in
    go x0 x0.

Definition bin {a : Type} : a -> Set_ a -> Set_ a -> Set_ a :=
  fun x l r => Bin ((size l GHC.Num.+ size r) GHC.Num.+ #1) x l r.

Fixpoint insertMax {a} (x : a) (t : Set_ a) : Set_ a
  := match t with
     | Tip => singleton x
     | Bin _ y l r => balanceR y l (insertMax x r)
     end.

Fixpoint insertMin {a} (x : a) (t : Set_ a) : Set_ a
  := match t with
     | Tip => singleton x
     | Bin _ y l r => balanceL y (insertMin x l) r
     end.

Program Fixpoint link {a : Type} (arg_0__ : a) (arg_1__ arg_2__ : Set_ a)
                      {measure (Nat.add (set_size arg_1__) (set_size arg_2__))} : Set_ a
  := match arg_0__, arg_1__, arg_2__ with
     | x, Tip, r => insertMin x r
     | x, l, Tip => insertMax x l
     | x, (Bin sizeL y ly ry as l), (Bin sizeR z lz rz as r) =>
         if Bool.Sumbool.sumbool_of_bool ((delta GHC.Num.* sizeL) GHC.Base.< sizeR)
         then balanceL z (link x l lz) rz else
         if Bool.Sumbool.sumbool_of_bool ((delta GHC.Num.* sizeR) GHC.Base.< sizeL)
         then balanceR y ly (link x ry r) else
         bin x l r
     end.
Solve Obligations with (termination_by_omega).

Fixpoint splitS {a} `{GHC.Base.Ord a} (arg_0__ : a) (arg_1__ : Set_ a) : prod
                                                                         (Set_ a) (Set_ a)
  := match arg_0__, arg_1__ with
     | _, Tip => (pair Tip Tip)
     | x, Bin _ y l r =>
         match GHC.Base.compare x y with
         | Lt => let 'pair lt gt := splitS x l in (pair lt (link y gt r))
         | Gt => let 'pair lt gt := splitS x r in (pair (link y l lt) gt)
         | Eq => (pair l r)
         end
     end.

Fixpoint union {a : Type} `{GHC.Base.Ord a} (arg_0__ arg_1__ : Set_ a) : Set_ a
  := match arg_0__, arg_1__ with
     | t1, Tip => t1
     | t1, Bin num_2__ x _ _ =>
         if num_2__ GHC.Base.== #1 : bool then insertR x t1 else
         let j_11__ :=
           match arg_0__, arg_1__ with
           | Tip, t2 => t2
           | (Bin _ x l1 r1 as t1), t2 =>
               let 'pair l2 r2 := splitS x t2 in
               let r1r2 := union r1 r2 in
               let l1l2 := union l1 l2 in
               if andb (Utils.Containers.Internal.PtrEquality.ptrEq l1l2 l1)
                       (Utils.Containers.Internal.PtrEquality.ptrEq r1r2 r1) : bool
               then t1 else
               link x l1l2 r1r2
           end in
         match arg_0__, arg_1__ with
         | Bin num_3__ x _ _, t2 =>
             if num_3__ GHC.Base.== #1 : bool then insert x t2 else
             j_11__
         | _, _ => j_11__
         end
     end.

Local Definition Semigroup__Set__op_zlzlzgzg__ {inst_a : Type} `{GHC.Base.Ord
  inst_a}
   : Set_ inst_a -> Set_ inst_a -> Set_ inst_a :=
  union.

Program Instance Semigroup__Set_ {a : Type} `{GHC.Base.Ord a}
   : GHC.Base.Semigroup (Set_ a) :=
  fun _ k__ =>
    k__ {| GHC.Base.op_zlzlzgzg____ := Semigroup__Set__op_zlzlzgzg__ |}.

Local Definition Monoid__Set__mappend {inst_a : Type} `{GHC.Base.Ord inst_a}
   : Set_ inst_a -> Set_ inst_a -> Set_ inst_a :=
  _GHC.Base.<<>>_.

Definition empty {a : Type} : Set_ a :=
  Tip.

Definition unions {f : Type -> Type} {a : Type} `{Data.Foldable.Foldable f}
  `{GHC.Base.Ord a}
   : f (Set_ a) -> Set_ a :=
  Data.Foldable.foldl' union empty.

Local Definition Monoid__Set__mconcat {inst_a : Type} `{GHC.Base.Ord inst_a}
   : list (Set_ inst_a) -> Set_ inst_a :=
  unions.

Local Definition Monoid__Set__mempty {inst_a : Type} `{GHC.Base.Ord inst_a}
   : Set_ inst_a :=
  empty.

Program Instance Monoid__Set_ {a : Type} `{GHC.Base.Ord a}
   : GHC.Base.Monoid (Set_ a) :=
  fun _ k__ =>
    k__ {| GHC.Base.mappend__ := Monoid__Set__mappend ;
           GHC.Base.mconcat__ := Monoid__Set__mconcat ;
           GHC.Base.mempty__ := Monoid__Set__mempty |}.

Local Definition Foldable__Set__fold
   : forall {m : Type}, forall `{GHC.Base.Monoid m}, Set_ m -> m :=
  fun {m : Type} `{GHC.Base.Monoid m} =>
    let fix go arg_0__
      := match arg_0__ with
         | Tip => GHC.Base.mempty
         | Bin num_1__ k _ _ =>
             if num_1__ GHC.Base.== #1 : bool then k else
             match arg_0__ with
             | Bin _ k l r => GHC.Base.mappend (go l) (GHC.Base.mappend k (go r))
             | _ => GHC.Err.patternFailure
             end
         end in
    go.

Local Definition Foldable__Set__foldMap
   : forall {m : Type},
     forall {a : Type}, forall `{GHC.Base.Monoid m}, (a -> m) -> Set_ a -> m :=
  fun {m : Type} {a : Type} `{GHC.Base.Monoid m} =>
    fun f t =>
      let fix go arg_0__
        := match arg_0__ with
           | Tip => GHC.Base.mempty
           | Bin num_1__ k _ _ =>
               if num_1__ GHC.Base.== #1 : bool then f k else
               match arg_0__ with
               | Bin _ k l r => GHC.Base.mappend (go l) (GHC.Base.mappend (f k) (go r))
               | _ => GHC.Err.patternFailure
               end
           end in
      go t.

Definition foldl {a : Type} {b : Type} : (a -> b -> a) -> a -> Set_ b -> a :=
  fun f z =>
    let fix go arg_0__ arg_1__
      := match arg_0__, arg_1__ with
         | z', Tip => z'
         | z', Bin _ x l r => go (f (go z' l) x) r
         end in
    go z.

Local Definition Foldable__Set__foldl
   : forall {b : Type}, forall {a : Type}, (b -> a -> b) -> b -> Set_ a -> b :=
  fun {b : Type} {a : Type} => foldl.

Definition foldl' {a : Type} {b : Type} : (a -> b -> a) -> a -> Set_ b -> a :=
  fun f z =>
    let fix go arg_0__ arg_1__
      := match arg_0__, arg_1__ with
         | z', Tip => z'
         | z', Bin _ x l r => go (f (go z' l) x) r
         end in
    go z.

Local Definition Foldable__Set__foldl'
   : forall {b : Type}, forall {a : Type}, (b -> a -> b) -> b -> Set_ a -> b :=
  fun {b : Type} {a : Type} => foldl'.

Definition foldr {a : Type} {b : Type} : (a -> b -> b) -> b -> Set_ a -> b :=
  fun f z =>
    let fix go arg_0__ arg_1__
      := match arg_0__, arg_1__ with
         | z', Tip => z'
         | z', Bin _ x l r => go (f x (go z' r)) l
         end in
    go z.

Local Definition Foldable__Set__foldr
   : forall {a : Type}, forall {b : Type}, (a -> b -> b) -> b -> Set_ a -> b :=
  fun {a : Type} {b : Type} => foldr.

Definition foldr' {a : Type} {b : Type} : (a -> b -> b) -> b -> Set_ a -> b :=
  fun f z =>
    let fix go arg_0__ arg_1__
      := match arg_0__, arg_1__ with
         | z', Tip => z'
         | z', Bin _ x l r => go (f x (go z' r)) l
         end in
    go z.

Local Definition Foldable__Set__foldr'
   : forall {a : Type}, forall {b : Type}, (a -> b -> b) -> b -> Set_ a -> b :=
  fun {a : Type} {b : Type} => foldr'.

Local Definition Foldable__Set__length
   : forall {a : Type}, Set_ a -> GHC.Num.Int :=
  fun {a : Type} => size.

Definition null {a : Type} : Set_ a -> bool :=
  fun arg_0__ => match arg_0__ with | Tip => true | Bin _ _ _ _ => false end.

Local Definition Foldable__Set__null : forall {a : Type}, Set_ a -> bool :=
  fun {a : Type} => null.

Local Definition Foldable__Set__product
   : forall {a : Type}, forall `{GHC.Num.Num a}, Set_ a -> a :=
  fun {a : Type} `{GHC.Num.Num a} => foldl' _GHC.Num.*_ #1.

Local Definition Foldable__Set__sum
   : forall {a : Type}, forall `{GHC.Num.Num a}, Set_ a -> a :=
  fun {a : Type} `{GHC.Num.Num a} => foldl' _GHC.Num.+_ #0.

Definition toAscList {a : Type} : Set_ a -> list a :=
  foldr cons nil.

Definition toList {a : Type} : Set_ a -> list a :=
  toAscList.

Local Definition Foldable__Set__toList : forall {a : Type}, Set_ a -> list a :=
  fun {a : Type} => toList.

Program Instance Foldable__Set_ : Data.Foldable.Foldable Set_ :=
  fun _ k__ =>
    k__ {| Data.Foldable.fold__ := fun {m : Type} `{GHC.Base.Monoid m} =>
             Foldable__Set__fold ;
           Data.Foldable.foldMap__ := fun {m : Type} {a : Type} `{GHC.Base.Monoid m} =>
             Foldable__Set__foldMap ;
           Data.Foldable.foldl__ := fun {b : Type} {a : Type} => Foldable__Set__foldl ;
           Data.Foldable.foldl'__ := fun {b : Type} {a : Type} => Foldable__Set__foldl' ;
           Data.Foldable.foldr__ := fun {a : Type} {b : Type} => Foldable__Set__foldr ;
           Data.Foldable.foldr'__ := fun {a : Type} {b : Type} => Foldable__Set__foldr' ;
           Data.Foldable.length__ := fun {a : Type} => Foldable__Set__length ;
           Data.Foldable.null__ := fun {a : Type} => Foldable__Set__null ;
           Data.Foldable.product__ := fun {a : Type} `{GHC.Num.Num a} =>
             Foldable__Set__product ;
           Data.Foldable.sum__ := fun {a : Type} `{GHC.Num.Num a} => Foldable__Set__sum ;
           Data.Foldable.toList__ := fun {a : Type} => Foldable__Set__toList |}.

(* Skipping all instances of class `Data.Data.Data', including
   `Data.Set.Internal.Data__Set_' *)

(* Skipping all instances of class `GHC.Exts.IsList', including
   `Data.Set.Internal.IsList__Set_' *)

Local Definition Eq___Set__op_zeze__ {inst_a : Type} `{GHC.Base.Eq_ inst_a}
   : Set_ inst_a -> Set_ inst_a -> bool :=
  fun t1 t2 =>
    andb (size t1 GHC.Base.== size t2) (toAscList t1 GHC.Base.== toAscList t2).

Local Definition Eq___Set__op_zsze__ {inst_a : Type} `{GHC.Base.Eq_ inst_a}
   : Set_ inst_a -> Set_ inst_a -> bool :=
  fun x y => negb (Eq___Set__op_zeze__ x y).

Program Instance Eq___Set_ {a : Type} `{GHC.Base.Eq_ a}
   : GHC.Base.Eq_ (Set_ a) :=
  fun _ k__ =>
    k__ {| GHC.Base.op_zeze____ := Eq___Set__op_zeze__ ;
           GHC.Base.op_zsze____ := Eq___Set__op_zsze__ |}.

Local Definition Ord__Set__compare {inst_a : Type} `{GHC.Base.Ord inst_a}
   : Set_ inst_a -> Set_ inst_a -> comparison :=
  fun s1 s2 => GHC.Base.compare (toAscList s1) (toAscList s2).

Local Definition Ord__Set__op_zl__ {inst_a : Type} `{GHC.Base.Ord inst_a}
   : Set_ inst_a -> Set_ inst_a -> bool :=
  fun x y => Ord__Set__compare x y GHC.Base.== Lt.

Local Definition Ord__Set__op_zlze__ {inst_a : Type} `{GHC.Base.Ord inst_a}
   : Set_ inst_a -> Set_ inst_a -> bool :=
  fun x y => Ord__Set__compare x y GHC.Base./= Gt.

Local Definition Ord__Set__op_zg__ {inst_a : Type} `{GHC.Base.Ord inst_a}
   : Set_ inst_a -> Set_ inst_a -> bool :=
  fun x y => Ord__Set__compare x y GHC.Base.== Gt.

Local Definition Ord__Set__op_zgze__ {inst_a : Type} `{GHC.Base.Ord inst_a}
   : Set_ inst_a -> Set_ inst_a -> bool :=
  fun x y => Ord__Set__compare x y GHC.Base./= Lt.

Local Definition Ord__Set__max {inst_a : Type} `{GHC.Base.Ord inst_a}
   : Set_ inst_a -> Set_ inst_a -> Set_ inst_a :=
  fun x y => if Ord__Set__op_zlze__ x y : bool then y else x.

Local Definition Ord__Set__min {inst_a : Type} `{GHC.Base.Ord inst_a}
   : Set_ inst_a -> Set_ inst_a -> Set_ inst_a :=
  fun x y => if Ord__Set__op_zlze__ x y : bool then x else y.

Program Instance Ord__Set_ {a : Type} `{GHC.Base.Ord a}
   : GHC.Base.Ord (Set_ a) :=
  fun _ k__ =>
    k__ {| GHC.Base.op_zl____ := Ord__Set__op_zl__ ;
           GHC.Base.op_zlze____ := Ord__Set__op_zlze__ ;
           GHC.Base.op_zg____ := Ord__Set__op_zg__ ;
           GHC.Base.op_zgze____ := Ord__Set__op_zgze__ ;
           GHC.Base.compare__ := Ord__Set__compare ;
           GHC.Base.max__ := Ord__Set__max ;
           GHC.Base.min__ := Ord__Set__min |}.

(* Skipping all instances of class `GHC.Show.Show', including
   `Data.Set.Internal.Show__Set_' *)

Local Definition Eq1__Set__liftEq
   : forall {a : Type},
     forall {b : Type}, (a -> b -> bool) -> Set_ a -> Set_ b -> bool :=
  fun {a : Type} {b : Type} =>
    fun eq m n =>
      andb (size m GHC.Base.== size n) (Data.Functor.Classes.liftEq eq (toList m)
            (toList n)).

Program Instance Eq1__Set_ : Data.Functor.Classes.Eq1 Set_ :=
  fun _ k__ =>
    k__ {| Data.Functor.Classes.liftEq__ := fun {a : Type} {b : Type} =>
             Eq1__Set__liftEq |}.

Local Definition Ord1__Set__liftCompare
   : forall {a : Type},
     forall {b : Type}, (a -> b -> comparison) -> Set_ a -> Set_ b -> comparison :=
  fun {a : Type} {b : Type} =>
    fun cmp m n => Data.Functor.Classes.liftCompare cmp (toList m) (toList n).

Program Instance Ord1__Set_ : Data.Functor.Classes.Ord1 Set_ :=
  fun _ k__ =>
    k__ {| Data.Functor.Classes.liftCompare__ := fun {a : Type} {b : Type} =>
             Ord1__Set__liftCompare |}.

(* Skipping all instances of class `Data.Functor.Classes.Show1', including
   `Data.Set.Internal.Show1__Set_' *)

(* Skipping all instances of class `GHC.Read.Read', including
   `Data.Set.Internal.Read__Set_' *)

(* Skipping all instances of class `Control.DeepSeq.NFData', including
   `Data.Set.Internal.NFData__Set_' *)

Definition maxViewSure {a} : a -> Set_ a -> Set_ a -> prod a (Set_ a) :=
  let fix go arg_0__ arg_1__ arg_2__
    := match arg_0__, arg_1__, arg_2__ with
       | x, l, Tip => pair x l
       | x, l, Bin _ xr rl rr =>
           let 'pair xm r' := go xr rl rr in
           pair xm (balanceL x l r')
       end in
  go.

Definition minViewSure {a} : a -> Set_ a -> Set_ a -> prod a (Set_ a) :=
  let fix go arg_0__ arg_1__ arg_2__
    := match arg_0__, arg_1__, arg_2__ with
       | x, Tip, r => pair x r
       | x, Bin _ xl ll lr, r =>
           let 'pair xm l' := go xl ll lr in
           pair xm (balanceR x l' r)
       end in
  go.

Definition glue {a} : Set_ a -> Set_ a -> Set_ a :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | Tip, r => r
    | l, Tip => l
    | (Bin sl xl ll lr as l), (Bin sr xr rl rr as r) =>
        if sl GHC.Base.> sr : bool
        then let 'pair m l' := maxViewSure xl ll lr in
             balanceR m l' r else
        let 'pair m r' := minViewSure xr rl rr in
        balanceL m l r'
    end.

Program Fixpoint merge {a : Type} (arg_0__ arg_1__ : Set_ a) {measure (Nat.add
                        (set_size arg_0__) (set_size arg_1__))} : Set_ a
  := match arg_0__, arg_1__ with
     | Tip, r => r
     | l, Tip => l
     | (Bin sizeL x lx rx as l), (Bin sizeR y ly ry as r) =>
         if Bool.Sumbool.sumbool_of_bool ((delta GHC.Num.* sizeL) GHC.Base.< sizeR)
         then balanceL y (merge l ly) ry else
         if Bool.Sumbool.sumbool_of_bool ((delta GHC.Num.* sizeR) GHC.Base.< sizeL)
         then balanceR x lx (merge rx r) else
         glue l r
     end.
Solve Obligations with (termination_by_omega).

Local Definition Semigroup__MergeSet_op_zlzlzgzg__ {inst_a : Type}
   : MergeSet inst_a -> MergeSet inst_a -> MergeSet inst_a :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | Mk_MergeSet xs, Mk_MergeSet ys => Mk_MergeSet (merge xs ys)
    end.

Program Instance Semigroup__MergeSet {a : Type}
   : GHC.Base.Semigroup (MergeSet a) :=
  fun _ k__ =>
    k__ {| GHC.Base.op_zlzlzgzg____ := Semigroup__MergeSet_op_zlzlzgzg__ |}.

Local Definition Monoid__MergeSet_mappend {inst_a : Type}
   : MergeSet inst_a -> MergeSet inst_a -> MergeSet inst_a :=
  _GHC.Base.<<>>_.

Local Definition Monoid__MergeSet_mempty {inst_a : Type} : MergeSet inst_a :=
  Mk_MergeSet empty.

Local Definition Monoid__MergeSet_mconcat {inst_a : Type}
   : list (MergeSet inst_a) -> MergeSet inst_a :=
  GHC.Base.foldr Monoid__MergeSet_mappend Monoid__MergeSet_mempty.

Program Instance Monoid__MergeSet {a : Type} : GHC.Base.Monoid (MergeSet a) :=
  fun _ k__ =>
    k__ {| GHC.Base.mappend__ := Monoid__MergeSet_mappend ;
           GHC.Base.mconcat__ := Monoid__MergeSet_mconcat ;
           GHC.Base.mempty__ := Monoid__MergeSet_mempty |}.

Definition split {a : Type} `{GHC.Base.Ord a}
   : a -> Set_ a -> (Set_ a * Set_ a)%type :=
  fun x t => id (splitS x t).

Fixpoint difference {a : Type} `{GHC.Base.Ord a} (arg_0__ arg_1__ : Set_ a)
  : Set_ a
  := match arg_0__, arg_1__ with
     | Tip, _ => Tip
     | t1, Tip => t1
     | t1, Bin _ x l2 r2 =>
         let 'pair l1 r1 := split x t1 in
         let r1r2 := difference r1 r2 in
         let l1l2 := difference l1 l2 in
         if (size l1l2 GHC.Num.+ size r1r2) GHC.Base.== size t1 : bool then t1 else
         merge l1l2 r1r2
     end.

Definition op_zrzr__ {a : Type} `{GHC.Base.Ord a}
   : Set_ a -> Set_ a -> Set_ a :=
  fun m1 m2 => difference m1 m2.

Notation "'_\\_'" := (op_zrzr__).

Infix "\\" := (_\\_) (at level 99).

(* Skipping definition `Data.Set.Internal.fromListConstr' *)

(* Skipping definition `Data.Set.Internal.setDataType' *)

Definition member {a : Type} `{GHC.Base.Ord a} : a -> Set_ a -> bool :=
  let fix go arg_0__ arg_1__
    := match arg_0__, arg_1__ with
       | _, Tip => false
       | x, Bin _ y l r =>
           match GHC.Base.compare x y with
           | Lt => go x l
           | Gt => go x r
           | Eq => true
           end
       end in
  go.

Definition notMember {a : Type} `{GHC.Base.Ord a} : a -> Set_ a -> bool :=
  fun a t => negb (member a t).

Definition lookupLT {a : Type} `{GHC.Base.Ord a} : a -> Set_ a -> option a :=
  let fix goJust arg_0__ arg_1__ arg_2__
    := match arg_0__, arg_1__, arg_2__ with
       | _, best, Tip => Some best
       | x, best, Bin _ y l r =>
           if x GHC.Base.<= y : bool then goJust x best l else
           goJust x y r
       end in
  let fix goNothing arg_7__ arg_8__
    := match arg_7__, arg_8__ with
       | _, Tip => None
       | x, Bin _ y l r =>
           if x GHC.Base.<= y : bool then goNothing x l else
           goJust x y r
       end in
  goNothing.

Definition lookupGT {a : Type} `{GHC.Base.Ord a} : a -> Set_ a -> option a :=
  let fix goJust arg_0__ arg_1__ arg_2__
    := match arg_0__, arg_1__, arg_2__ with
       | _, best, Tip => Some best
       | x, best, Bin _ y l r =>
           if x GHC.Base.< y : bool then goJust x y l else
           goJust x best r
       end in
  let fix goNothing arg_7__ arg_8__
    := match arg_7__, arg_8__ with
       | _, Tip => None
       | x, Bin _ y l r =>
           if x GHC.Base.< y : bool then goJust x y l else
           goNothing x r
       end in
  goNothing.

Definition lookupLE {a : Type} `{GHC.Base.Ord a} : a -> Set_ a -> option a :=
  let fix goJust arg_0__ arg_1__ arg_2__
    := match arg_0__, arg_1__, arg_2__ with
       | _, best, Tip => Some best
       | x, best, Bin _ y l r =>
           match GHC.Base.compare x y with
           | Lt => goJust x best l
           | Eq => Some y
           | Gt => goJust x y r
           end
       end in
  let fix goNothing arg_11__ arg_12__
    := match arg_11__, arg_12__ with
       | _, Tip => None
       | x, Bin _ y l r =>
           match GHC.Base.compare x y with
           | Lt => goNothing x l
           | Eq => Some y
           | Gt => goJust x y r
           end
       end in
  goNothing.

Definition lookupGE {a : Type} `{GHC.Base.Ord a} : a -> Set_ a -> option a :=
  let fix goJust arg_0__ arg_1__ arg_2__
    := match arg_0__, arg_1__, arg_2__ with
       | _, best, Tip => Some best
       | x, best, Bin _ y l r =>
           match GHC.Base.compare x y with
           | Lt => goJust x y l
           | Eq => Some y
           | Gt => goJust x best r
           end
       end in
  let fix goNothing arg_11__ arg_12__
    := match arg_11__, arg_12__ with
       | _, Tip => None
       | x, Bin _ y l r =>
           match GHC.Base.compare x y with
           | Lt => goJust x y l
           | Eq => Some y
           | Gt => goNothing x r
           end
       end in
  goNothing.

Definition delete {a : Type} `{GHC.Base.Ord a} : a -> Set_ a -> Set_ a :=
  let go {a} `{GHC.Base.Ord a} : a -> Set_ a -> Set_ a :=
    fix go (arg_0__ : a) (arg_1__ : Set_ a) : Set_ a
      := match arg_0__, arg_1__ with
         | _, Tip => Tip
         | x, (Bin _ y l r as t) =>
             match GHC.Base.compare x y with
             | Lt =>
                 let l' := go x l in
                 if Utils.Containers.Internal.PtrEquality.ptrEq l' l : bool then t else
                 balanceR y l' r
             | Gt =>
                 let r' := go x r in
                 if Utils.Containers.Internal.PtrEquality.ptrEq r' r : bool then t else
                 balanceL y l r'
             | Eq => glue l r
             end
         end in
  go.

Fixpoint splitMember {a : Type} `{GHC.Base.Ord a} (arg_0__ : a) (arg_1__
                       : Set_ a) : (Set_ a * bool * Set_ a)%type
  := match arg_0__, arg_1__ with
     | _, Tip => pair (pair Tip false) Tip
     | x, Bin _ y l r =>
         match GHC.Base.compare x y with
         | Lt =>
             let 'pair (pair lt found) gt := splitMember x l in
             let gt' := link y gt r in pair (pair lt found) gt'
         | Gt =>
             let 'pair (pair lt found) gt := splitMember x r in
             let lt' := link y l lt in pair (pair lt' found) gt
         | Eq => pair (pair l true) r
         end
     end.

Fixpoint isSubsetOfX {a} `{GHC.Base.Ord a} (arg_0__ arg_1__ : Set_ a) : bool
  := match arg_0__, arg_1__ with
     | Tip, _ => true
     | _, Tip => false
     | Bin _ x l r, t =>
         let 'pair (pair lt found) gt := splitMember x t in
         andb found (andb (isSubsetOfX l lt) (isSubsetOfX r gt))
     end.

Definition isSubsetOf {a : Type} `{GHC.Base.Ord a} : Set_ a -> Set_ a -> bool :=
  fun t1 t2 => andb (size t1 GHC.Base.<= size t2) (isSubsetOfX t1 t2).

Definition isProperSubsetOf {a : Type} `{GHC.Base.Ord a}
   : Set_ a -> Set_ a -> bool :=
  fun s1 s2 => andb (size s1 GHC.Base.< size s2) (isSubsetOf s1 s2).

Fixpoint disjoint {a : Type} `{GHC.Base.Ord a} (arg_0__ arg_1__ : Set_ a) : bool
  := match arg_0__, arg_1__ with
     | Tip, _ => true
     | _, Tip => true
     | Bin _ x l r, t =>
         let 'pair (pair lt found) gt := splitMember x t in
         andb (negb found) (andb (disjoint l lt) (disjoint r gt))
     end.

Fixpoint lookupMinSure {a} (arg_0__ : a) (arg_1__ : Set_ a) : a
  := match arg_0__, arg_1__ with
     | x, Tip => x
     | _, Bin _ x l _ => lookupMinSure x l
     end.

Definition lookupMin {a : Type} : Set_ a -> option a :=
  fun arg_0__ =>
    match arg_0__ with
    | Tip => None
    | Bin _ x l _ => Some (lookupMinSure x l)
    end.

(* Skipping definition `Data.Set.Internal.findMin' *)

Fixpoint lookupMaxSure {a} (arg_0__ : a) (arg_1__ : Set_ a) : a
  := match arg_0__, arg_1__ with
     | x, Tip => x
     | _, Bin _ x _ r => lookupMaxSure x r
     end.

Definition lookupMax {a : Type} : Set_ a -> option a :=
  fun arg_0__ =>
    match arg_0__ with
    | Tip => None
    | Bin _ x _ r => Some (lookupMaxSure x r)
    end.

(* Skipping definition `Data.Set.Internal.findMax' *)

Fixpoint deleteMin {a : Type} (arg_0__ : Set_ a) : Set_ a
  := match arg_0__ with
     | Bin _ _ Tip r => r
     | Bin _ x l r => balanceR x (deleteMin l) r
     | Tip => Tip
     end.

Fixpoint deleteMax {a : Type} (arg_0__ : Set_ a) : Set_ a
  := match arg_0__ with
     | Bin _ _ l Tip => l
     | Bin _ x l r => balanceL x l (deleteMax r)
     | Tip => Tip
     end.

Fixpoint intersection {a : Type} `{GHC.Base.Ord a} (arg_0__ arg_1__ : Set_ a)
  : Set_ a
  := match arg_0__, arg_1__ with
     | Tip, _ => Tip
     | _, Tip => Tip
     | (Bin _ x l1 r1 as t1), t2 =>
         let 'pair (pair l2 b) r2 := splitMember x t2 in
         let l1l2 := intersection l1 l2 in
         let r1r2 := intersection r1 r2 in
         if b : bool
         then if andb (Utils.Containers.Internal.PtrEquality.ptrEq l1l2 l1)
                      (Utils.Containers.Internal.PtrEquality.ptrEq r1r2 r1) : bool
              then t1
              else link x l1l2 r1r2 else
         merge l1l2 r1r2
     end.

Fixpoint filter {a : Type} (arg_0__ : a -> bool) (arg_1__ : Set_ a) : Set_ a
  := match arg_0__, arg_1__ with
     | _, Tip => Tip
     | p, (Bin _ x l r as t) =>
         let r' := filter p r in
         let l' := filter p l in
         if p x : bool
         then if andb (Utils.Containers.Internal.PtrEquality.ptrEq l l')
                      (Utils.Containers.Internal.PtrEquality.ptrEq r r') : bool
              then t
              else link x l' r' else
         merge l' r'
     end.

Definition partition {a : Type}
   : (a -> bool) -> Set_ a -> (Set_ a * Set_ a)%type :=
  fun p0 t0 =>
    let fix go arg_0__ arg_1__
      := match arg_0__, arg_1__ with
         | _, Tip => (pair Tip Tip)
         | p, (Bin _ x l r as t) =>
             let 'pair (pair l1 l2) (pair r1 r2) := pair (go p l) (go p r) in
             if p x : bool
             then pair (if andb (Utils.Containers.Internal.PtrEquality.ptrEq l1 l)
                                (Utils.Containers.Internal.PtrEquality.ptrEq r1 r) : bool
                        then t
                        else link x l1 r1) (merge l2 r2) else
             pair (merge l1 r1) (if andb (Utils.Containers.Internal.PtrEquality.ptrEq l2 l)
                                         (Utils.Containers.Internal.PtrEquality.ptrEq r2 r) : bool
                   then t
                   else link x l2 r2)
         end in
    id (go p0 t0).

Definition fromList {a : Type} `{GHC.Base.Ord a} : list a -> Set_ a :=
  fun arg_0__ =>
    match arg_0__ with
    | nil => Tip
    | cons x nil => Bin #1 x Tip Tip
    | cons x0 xs0 =>
        let fromList' :=
          fun t0 xs =>
            let ins := fun t x => insert x t in Data.Foldable.foldl' ins t0 xs in
        let not_ordered :=
          fun arg_4__ arg_5__ =>
            match arg_4__, arg_5__ with
            | _, nil => false
            | x, cons y _ => x GHC.Base.>= y
            end in
        let create :=
          HsToCoq.DeferredFix.deferredFix2 (fun create arg_8__ arg_9__ =>
                                              match arg_8__, arg_9__ with
                                              | _, nil => pair (pair Tip nil) nil
                                              | s, (cons x xss as xs) =>
                                                  if s GHC.Base.== #1 : bool
                                                  then if not_ordered x xss : bool
                                                       then pair (pair (Bin #1 x Tip Tip) nil) xss
                                                       else pair (pair (Bin #1 x Tip Tip) xss) nil else
                                                  match create (Data.Bits.shiftR s #1) xs with
                                                  | (pair (pair _ nil) _ as res) => res
                                                  | pair (pair l (cons y nil)) zs => pair (pair (insertMax y l) nil) zs
                                                  | pair (pair l (cons y yss as ys)) _ =>
                                                      if not_ordered y yss : bool then pair (pair l nil) ys else
                                                      let 'pair (pair r zs) ws := create (Data.Bits.shiftR s #1) yss in
                                                      pair (pair (link y l r) zs) ws
                                                  end
                                              end) in
        let go :=
          HsToCoq.DeferredFix.deferredFix3 (fun go arg_22__ arg_23__ arg_24__ =>
                                              match arg_22__, arg_23__, arg_24__ with
                                              | _, t, nil => t
                                              | _, t, cons x nil => insertMax x t
                                              | s, l, (cons x xss as xs) =>
                                                  if not_ordered x xss : bool then fromList' l xs else
                                                  match create s xss with
                                                  | pair (pair r ys) nil => go (Data.Bits.shiftL s #1) (link x l r) ys
                                                  | pair (pair r _) ys => fromList' (link x l r) ys
                                                  end
                                              end) in
        if not_ordered x0 xs0 : bool then fromList' (Bin #1 x0 Tip Tip) xs0 else
        go (#1 : GHC.Num.Int) (Bin #1 x0 Tip Tip) xs0
    end.

Definition map {b : Type} {a : Type} `{GHC.Base.Ord b}
   : (a -> b) -> Set_ a -> Set_ b :=
  fun f => fromList GHC.Base.∘ (GHC.Base.map f GHC.Base.∘ toList).

Fixpoint mapMonotonic {a : Type} {b : Type} (arg_0__ : a -> b) (arg_1__
                        : Set_ a) : Set_ b
  := match arg_0__, arg_1__ with
     | _, Tip => Tip
     | f, Bin sz x l r => Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)
     end.

Definition fold {a : Type} {b : Type} : (a -> b -> b) -> b -> Set_ a -> b :=
  foldr.

Definition elems {a : Type} : Set_ a -> list a :=
  toAscList.

Definition toDescList {a : Type} : Set_ a -> list a :=
  foldl (GHC.Base.flip cons) nil.

Definition foldrFB {a} {b} : (a -> b -> b) -> b -> Set_ a -> b :=
  foldr.

Definition foldlFB {a} {b} : (a -> b -> a) -> a -> Set_ b -> a :=
  foldl.

Definition combineEq {a} `{GHC.Base.Eq_ a} : list a -> list a :=
  fun arg_0__ =>
    match arg_0__ with
    | nil => nil
    | cons x xs =>
        let fix combineEq' arg_1__ arg_2__
          := match arg_1__, arg_2__ with
             | z, nil => cons z nil
             | z, cons y ys =>
                 if z GHC.Base.== y : bool then combineEq' z ys else
                 cons z (combineEq' y ys)
             end in
        combineEq' x xs
    end.

Definition fromDistinctAscList {a : Type} : list a -> Set_ a :=
  fun arg_0__ =>
    match arg_0__ with
    | nil => Tip
    | cons x0 xs0 =>
        let create :=
          HsToCoq.DeferredFix.deferredFix2 (fun create arg_1__ arg_2__ =>
                                              match arg_1__, arg_2__ with
                                              | _, nil => (pair Tip nil)
                                              | s, (cons x xs' as xs) =>
                                                  if s GHC.Base.== #1 : bool then (pair (Bin #1 x Tip Tip) xs') else
                                                  match create (Data.Bits.shiftR s #1) xs with
                                                  | (pair _ nil as res) => res
                                                  | pair l (cons y ys) =>
                                                      let 'pair r zs := create (Data.Bits.shiftR s #1) ys in
                                                      (pair (link y l r) zs)
                                                  end
                                              end) in
        let go :=
          HsToCoq.DeferredFix.deferredFix3 (fun go arg_13__ arg_14__ arg_15__ =>
                                              match arg_13__, arg_14__, arg_15__ with
                                              | _, t, nil => t
                                              | s, l, cons x xs =>
                                                  let 'pair r ys := create s xs in
                                                  let t' := link x l r in go (Data.Bits.shiftL s #1) t' ys
                                              end) in
        go (#1 : GHC.Num.Int) (Bin #1 x0 Tip Tip) xs0
    end.

Definition fromAscList {a : Type} `{GHC.Base.Eq_ a} : list a -> Set_ a :=
  fun xs => fromDistinctAscList (combineEq xs).

Definition fromDistinctDescList {a : Type} : list a -> Set_ a :=
  fun arg_0__ =>
    match arg_0__ with
    | nil => Tip
    | cons x0 xs0 =>
        let create :=
          HsToCoq.DeferredFix.deferredFix2 (fun create arg_1__ arg_2__ =>
                                              match arg_1__, arg_2__ with
                                              | _, nil => (pair Tip nil)
                                              | s, (cons x xs' as xs) =>
                                                  if s GHC.Base.== #1 : bool then (pair (Bin #1 x Tip Tip) xs') else
                                                  match create (Data.Bits.shiftR s #1) xs with
                                                  | (pair _ nil as res) => res
                                                  | pair r (cons y ys) =>
                                                      let 'pair l zs := create (Data.Bits.shiftR s #1) ys in
                                                      (pair (link y l r) zs)
                                                  end
                                              end) in
        let go :=
          HsToCoq.DeferredFix.deferredFix3 (fun go arg_13__ arg_14__ arg_15__ =>
                                              match arg_13__, arg_14__, arg_15__ with
                                              | _, t, nil => t
                                              | s, r, cons x xs =>
                                                  let 'pair l ys := create s xs in
                                                  let t' := link x l r in go (Data.Bits.shiftL s #1) t' ys
                                              end) in
        go (#1 : GHC.Num.Int) (Bin #1 x0 Tip Tip) xs0
    end.

Definition fromDescList {a : Type} `{GHC.Base.Eq_ a} : list a -> Set_ a :=
  fun xs => fromDistinctDescList (combineEq xs).

(* Skipping definition `Data.Set.Internal.findIndex' *)

Definition lookupIndex {a : Type} `{GHC.Base.Ord a}
   : a -> Set_ a -> option GHC.Num.Int :=
  let go {a} `{GHC.Base.Ord a}
   : GHC.Num.Int -> a -> Set_ a -> option GHC.Num.Int :=
    fix go (arg_0__ : GHC.Num.Int) (arg_1__ : a) (arg_2__ : Set_ a) : option
                                                                      GHC.Num.Int
      := match arg_0__, arg_1__, arg_2__ with
         | _, _, Tip => None
         | idx, x, Bin _ kx l r =>
             match GHC.Base.compare x kx with
             | Lt => go idx x l
             | Gt => go ((idx GHC.Num.+ size l) GHC.Num.+ #1) x r
             | Eq => Some (idx GHC.Num.+ size l)
             end
         end in
  go #0.

(* Skipping definition `Data.Set.Internal.elemAt' *)

(* Skipping definition `Data.Set.Internal.deleteAt' *)

Definition take {a : Type} : GHC.Num.Int -> Set_ a -> Set_ a :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | i, m =>
        if i GHC.Base.>= size m : bool then m else
        match arg_0__, arg_1__ with
        | i0, m0 =>
            let fix go arg_2__ arg_3__
              := match arg_2__, arg_3__ with
                 | i, _ =>
                     if i GHC.Base.<= #0 : bool then Tip else
                     match arg_2__, arg_3__ with
                     | _, Tip => Tip
                     | i, Bin _ x l r =>
                         let sizeL := size l in
                         match GHC.Base.compare i sizeL with
                         | Lt => go i l
                         | Gt => link x l (go ((i GHC.Num.- sizeL) GHC.Num.- #1) r)
                         | Eq => l
                         end
                     end
                 end in
            go i0 m0
        end
    end.

Definition drop {a : Type} : GHC.Num.Int -> Set_ a -> Set_ a :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | i, m =>
        if i GHC.Base.>= size m : bool then Tip else
        match arg_0__, arg_1__ with
        | i0, m0 =>
            let fix go arg_2__ arg_3__
              := match arg_2__, arg_3__ with
                 | i, m =>
                     if i GHC.Base.<= #0 : bool then m else
                     match arg_2__, arg_3__ with
                     | _, Tip => Tip
                     | i, Bin _ x l r =>
                         let sizeL := size l in
                         match GHC.Base.compare i sizeL with
                         | Lt => link x (go i l) r
                         | Gt => go ((i GHC.Num.- sizeL) GHC.Num.- #1) r
                         | Eq => insertMin x r
                         end
                     end
                 end in
            go i0 m0
        end
    end.

Definition splitAt {a : Type}
   : GHC.Num.Int -> Set_ a -> (Set_ a * Set_ a)%type :=
  fun i0 m0 =>
    let fix go arg_0__ arg_1__
      := match arg_0__, arg_1__ with
         | i, m =>
             if i GHC.Base.<= #0 : bool then pair Tip m else
             match arg_0__, arg_1__ with
             | _, Tip => pair Tip Tip
             | i, Bin _ x l r =>
                 let sizeL := size l in
                 match GHC.Base.compare i sizeL with
                 | Lt => let 'pair ll lr := go i l in pair ll (link x lr r)
                 | Gt =>
                     let 'pair rl rr := go ((i GHC.Num.- sizeL) GHC.Num.- #1) r in
                     pair (link x l rl) rr
                 | Eq => pair l (insertMin x r)
                 end
             end
         end in
    if i0 GHC.Base.>= size m0 : bool then pair m0 Tip else
    id (go i0 m0).

Fixpoint takeWhileAntitone {a : Type} (arg_0__ : a -> bool) (arg_1__ : Set_ a)
  : Set_ a
  := match arg_0__, arg_1__ with
     | _, Tip => Tip
     | p, Bin _ x l r =>
         if p x : bool then link x l (takeWhileAntitone p r) else
         takeWhileAntitone p l
     end.

Fixpoint dropWhileAntitone {a : Type} (arg_0__ : a -> bool) (arg_1__ : Set_ a)
  : Set_ a
  := match arg_0__, arg_1__ with
     | _, Tip => Tip
     | p, Bin _ x l r =>
         if p x : bool then dropWhileAntitone p r else
         link x (dropWhileAntitone p l) r
     end.

Definition spanAntitone {a : Type}
   : (a -> bool) -> Set_ a -> (Set_ a * Set_ a)%type :=
  fun p0 m =>
    let fix go arg_0__ arg_1__
      := match arg_0__, arg_1__ with
         | _, Tip => pair Tip Tip
         | p, Bin _ x l r =>
             if p x : bool then let 'pair u v := go p r in pair (link x l u) v else
             let 'pair u v := go p l in
             pair u (link x v r)
         end in
    id (go p0 m).

(* Skipping definition `Data.Set.Internal.deleteFindMin' *)

(* Skipping definition `Data.Set.Internal.deleteFindMax' *)

Definition minView {a : Type} : Set_ a -> option (a * Set_ a)%type :=
  fun arg_0__ =>
    match arg_0__ with
    | Tip => None
    | Bin _ x l r => Some (id (minViewSure x l r))
    end.

Definition maxView {a : Type} : Set_ a -> option (a * Set_ a)%type :=
  fun arg_0__ =>
    match arg_0__ with
    | Tip => None
    | Bin _ x l r => Some (id (maxViewSure x l r))
    end.

Definition splitRoot {a : Type} : Set_ a -> list (Set_ a) :=
  fun orig =>
    match orig with
    | Tip => nil
    | Bin _ v l r => cons l (cons (singleton v) (cons r nil))
    end.

Definition powerSet {a : Type} : Set_ a -> Set_ (Set_ a) :=
  fun xs0 =>
    let step :=
      fun x pxs =>
        glue (insertMin (singleton x) (mapMonotonic (insertMin x) pxs)) pxs in
    insertMin empty (foldr' step Tip xs0).

Definition cartesianProduct {a : Type} {b : Type}
   : Set_ a -> Set_ b -> Set_ (a * b)%type :=
  fun as_ bs =>
    getMergeSet (Data.Foldable.foldMap (fun a =>
                                          Mk_MergeSet (mapMonotonic (GHC.Tuple.pair2 a) bs)) as_).

Definition disjointUnion {a : Type} {b : Type}
   : Set_ a -> Set_ b -> Set_ (Data.Either.Either a b) :=
  fun as_ bs =>
    merge (mapMonotonic Data.Either.Left as_) (mapMonotonic Data.Either.Right bs).

(* Skipping definition `Data.Set.Internal.showTree' *)

(* Skipping definition `Data.Set.Internal.showTreeWith' *)

(* Skipping definition `Data.Set.Internal.showsTree' *)

(* Skipping definition `Data.Set.Internal.showsTreeHang' *)

(* Skipping definition `Data.Set.Internal.showWide' *)

(* Skipping definition `Data.Set.Internal.showsBars' *)

(* Skipping definition `Data.Set.Internal.node' *)

(* Skipping definition `Data.Set.Internal.withBar' *)

(* Skipping definition `Data.Set.Internal.withEmpty' *)

Fixpoint balanced {a : Type} (t : Set_ a) : bool
  := match t with
     | Tip => true
     | Bin _ _ l r =>
         andb (orb ((size l GHC.Num.+ size r) GHC.Base.<= #1) (andb (size l GHC.Base.<=
                                                                     (delta GHC.Num.* size r)) (size r GHC.Base.<=
                                                                     (delta GHC.Num.* size l)))) (andb (balanced l)
                                                                                (balanced r))
     end.

Definition ordered {a} `{GHC.Base.Ord a} : Set_ a -> bool :=
  fun t =>
    let fix bounded lo hi t'
      := match t' with
         | Tip => true
         | Bin _ x l r =>
             andb (lo x) (andb (hi x) (andb (bounded lo (fun arg_0__ => arg_0__ GHC.Base.< x)
                                             l) (bounded (fun arg_1__ => arg_1__ GHC.Base.> x) hi r)))
         end in
    bounded (GHC.Base.const true) (GHC.Base.const true) t.

Definition validsize {a} : Set_ a -> bool :=
  fun t =>
    let fix realsize t'
      := match t' with
         | Tip => Some #0
         | Bin sz _ l r =>
             match pair (realsize l) (realsize r) with
             | pair (Some n) (Some m) =>
                 if ((n GHC.Num.+ m) GHC.Num.+ #1) GHC.Base.== sz : bool then Some sz else
                 None
             | _ => None
             end
         end in
    (realsize t GHC.Base.== Some (size t)).

Definition valid {a : Type} `{GHC.Base.Ord a} : Set_ a -> bool :=
  fun t => andb (balanced t) (andb (ordered t) (validsize t)).

Module Notations.
Notation "'_Data.Set.Internal.\\_'" := (op_zrzr__).
Infix "Data.Set.Internal.\\" := (_\\_) (at level 99).
End Notations.

(* External variables:
     Bool.Sumbool.sumbool_of_bool Eq Gt Lt None Some Type andb bool comparison cons
     false id list negb nil op_zt__ option orb pair prod set_size true
     Data.Bits.shiftL Data.Bits.shiftR Data.Either.Either Data.Either.Left
     Data.Either.Right Data.Foldable.Foldable Data.Foldable.foldMap
     Data.Foldable.foldMap__ Data.Foldable.fold__ Data.Foldable.foldl'
     Data.Foldable.foldl'__ Data.Foldable.foldl__ Data.Foldable.foldr'__
     Data.Foldable.foldr__ Data.Foldable.length__ Data.Foldable.null__
     Data.Foldable.product__ Data.Foldable.sum__ Data.Foldable.toList__
     Data.Functor.Classes.Eq1 Data.Functor.Classes.Ord1
     Data.Functor.Classes.liftCompare Data.Functor.Classes.liftCompare__
     Data.Functor.Classes.liftEq Data.Functor.Classes.liftEq__ GHC.Base.Eq_
     GHC.Base.Monoid GHC.Base.Ord GHC.Base.Semigroup GHC.Base.compare
     GHC.Base.compare__ GHC.Base.const GHC.Base.flip GHC.Base.foldr GHC.Base.map
     GHC.Base.mappend GHC.Base.mappend__ GHC.Base.max__ GHC.Base.mconcat__
     GHC.Base.mempty GHC.Base.mempty__ GHC.Base.min__ GHC.Base.op_z2218U__
     GHC.Base.op_zeze__ GHC.Base.op_zeze____ GHC.Base.op_zg__ GHC.Base.op_zg____
     GHC.Base.op_zgze__ GHC.Base.op_zgze____ GHC.Base.op_zl__ GHC.Base.op_zl____
     GHC.Base.op_zlze__ GHC.Base.op_zlze____ GHC.Base.op_zlzlzgzg__
     GHC.Base.op_zlzlzgzg____ GHC.Base.op_zsze__ GHC.Base.op_zsze____ GHC.Err.error
     GHC.Err.patternFailure GHC.Num.Int GHC.Num.Num GHC.Num.fromInteger
     GHC.Num.op_zm__ GHC.Num.op_zp__ GHC.Num.op_zt__ GHC.Tuple.pair2
     HsToCoq.DeferredFix.deferredFix2 HsToCoq.DeferredFix.deferredFix3 Nat.add
     Utils.Containers.Internal.PtrEquality.ptrEq
*)


From Coq Require Import Strings.String BinNat List.
From ExtLib Require Import Monad.

(* https://tools.ietf.org/html/rfc7541#section-1.3 *)
(* Header Field:  A name-value pair.  Both the name and value are
      treated as opaque sequences of octets. *)
Definition HeaderField := (string * string)%type.

(* Dynamic Table:  The dynamic table is a table that
      associates stored header fields with index values.  This table is
      dynamic and specific to an encoding or decoding context.

   Static Table:  The static table is a table that
      statically associates header fields that occur frequently with
      index values.  This table is ordered, read-only, always
      accessible, and it may be shared amongst all encoding or decoding
      contexts. *)
Definition Table := list HeaderField.

(* Dynamic Tables are a triple of a size, a maximum size and a table.
   The maximum size is provided by the SETTINGS_HEADER_TABLE_SIZE,
   https://tools.ietf.org/html/rfc7540#section-6.5.2
   The default value for the maximum size is 4096.
   The convention is that the table has size (as defined in
   https://tools.ietf.org/html/rfc7541#section-4.1) less than or equal to the
   maximum size, which is enforced by the functions that add entries.  *)
Definition DTable := (N * N * Table)%type.

(* Header List:  A header list is an ordered collection of header fields
      that are encoded jointly and can contain duplicate header fields.
      A complete list of header fields contained in an HTTP/2 header
      block is a header list. *)
Definition HeaderList := list HeaderField.

(* https://tools.ietf.org/html/rfc7541#section-6 *)
(* Header Field Representation:  A header field can be represented in
      encoded form either as a literal or as an index *)
Inductive HeaderFieldRepresentation :=
(* https://tools.ietf.org/html/rfc7541#section-6.1 *)
| IndexedHF : N -> HeaderFieldRepresentation
(* https://tools.ietf.org/html/rfc7541#section-6.2 *)
| LHFIncrementIndexedName : N -> string -> HeaderFieldRepresentation
| LHFIncrementNewName : string -> string -> HeaderFieldRepresentation
| LHFWithoutIndexIndexedName : N -> string -> HeaderFieldRepresentation
| LHFWithoutIndexNewName : string -> string -> HeaderFieldRepresentation
| LHFNeverIndexIndexedName : N -> string -> HeaderFieldRepresentation
| LHFNeverIndexNewName : string -> string -> HeaderFieldRepresentation
(* https://tools.ietf.org/html/rfc7541#section-6.3 *)
| DTableSizeUpdate : N -> HeaderFieldRepresentation.

(* Header Block:  An ordered list of header field representations,
      which, when decoded, yields a complete header list. *)
Definition HeaderBlock := list HeaderFieldRepresentation.

(* Error type for HPACK *)
Inductive HPACKError :=
| IndexOverrun : N -> HPACKError (* Index is out of range *)
| EosInTheMiddle : HPACKError (* Eos appears in the middle of huffman string *)
| IllegalEos : HPACKError (* Non-eos appears in the end of huffman string *)
| TooLongEos : HPACKError	(* Eos of huffman string is more than 7 bits *)
| EmptyEncodedString : HPACKError (* Encoded string has no length *)
| TooSmallTableSize : HPACKError (* A peer set the dynamic table size less than 32 *)
| TooLargeTableSize : HPACKError (* A peer tried to change the dynamic table size over the limit *)
| IllegalTableSizeUpdate : HPACKError (* Table size update at the non-beginning *)
| HeaderBlockTruncated : HPACKError
| IllegalHeaderName : HPACKError
| IntegerOverflow : HPACKError (* Integer is too large to encode *)
| HeaderBlockOverflow : HPACKError (* Too many headers in header block *).

Definition Err := sum HPACKError.

Instance monadErr : Monad Err :=
  {|
    ret := @inr HPACKError;
    bind _ _ x f := match x with
                | inl e => inl e
                | inr v => f v
                end |}.


Add LoadPath "/home/user/Downloads/archives/cats-in-zfc-2945072aa6c9c328a019d3128c0a725dabca434c".
Require Export CatsInZFC.tactics.

Theorem w1 (x : E):nonempty x -> exists y : E, inc y x.
Proof.
intros.
elim H.
intros.
exists y.
trivial.
Defined.

Definition w2 (x : E): (exists y : E, inc y x) -> nonempty x.
Proof.
intros H.
elim H.
Print nonempty.
intro y.
constructor 1 with (y:=y).
assumption.
Defined.

Definition w3 (x : E):nonempty x <-> exists y : E, inc y x.
Proof.
split.
exact (w1 x).
exact (w2 x).
Defined.

Definition v0 (a b:E): (forall x:E, (inc x a) <-> (inc x b)) <-> (a=b).
Proof.
split.
* intros.
  apply extensionality.
   all: (*par: *)
   intro x;
   elim (H x);
   intros H0 H1;
   assumption.
* intros.
  replace a with b.
  firstorder.
Defined.
(* CTRL+SHFT+L    "<->"  *)
(* A: iff is transparent.  What is not transparent? *)

auto.
  info_auto.

  rewrite a.
  change b with a.
(*in |- *.*)
  split.

intro E.
replace x0 with y .

Inductive mybool:=| a:True->mybool |b:mybool.
Theorem g: mybool.
constructor.
Defined.

(*intros q w.*)

intros.

apply (@nonempty_intro _ _ H0).

Check (@nonempty_intro _ _ H0).

Focus 2.
constructor.
unfold nonempty.
red.
Defined.
(*
elimtype (nonempty x).
cofix x.
fix Q 0.
*)

Proof.
Defined.

Proof.
Defined.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops
        Functor.Representable.Hom_Func.
Require Import Functor.Functor_Extender.
Require Import NatTrans.NatTrans NatTrans.Operations
        NatTrans.Func_Cat NatTrans.NatIso.
Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations
        Ext_Cons.Prod_Cat.Nat_Facts.
Require Import Adjunction.Adjunction.
Require Import KanExt.Local  KanExt.LocalFacts.Uniqueness.
Require Import Basic_Cons.Terminal.

Local Open Scope functor_scope.

(** This module contains conversion from local kan extension defiend as cones
to local kan extensions defined through hom functor. *)

Section Local_Right_KanExt_to_Hom_Local_Right_KanExt.
  Context {C C' : Category} {p : C –≻ C'}
          {D : Category} {F : C –≻ D}
          (lrke : Local_Right_KanExt p F).

  (** The left to right side of Hom_Local_Right_KanExt isomorphism. *)
  Program Definition Local_Right_KanExt_to_Hom_Local_Right_KanExt_Iso_LR :
    (((@Fix_Bi_Func_2 _ (Func_Cat C D) _ F (Hom_Func (Func_Cat C D)))
        ∘ (Left_Functor_Extender p D)^op)
       –≻ (@Fix_Bi_Func_2 _ (Func_Cat C' D)
                          _ lrke (Hom_Func (Func_Cat C' D))))%nattrans :=
    {|
      Trans :=  fun c h => LRKE_morph_ex lrke {|cone_apex := c; cone_edge := h|}
    |}.

  Next Obligation.
  Proof.
    extensionality x.
    repeat rewrite NatTrans_id_unit_left.
    match goal with
      [|- cone_morph (LRKE_morph_ex lrke ?A) = ?X] =>
      match X with
        ((cone_morph ?C) ∘ ?B)%nattrans =>
        change X with
        (cone_morph
           (LoKan_Cone_Morph_compose
              _
              _
              (Build_LoKan_Cone_Morph
                 p F A {|cone_apex := c; cone_edge := x|} h eq_refl) C
           )
        )
      end
    end.
    apply LRKE_morph_unique.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Local_Right_KanExt_to_Hom_Local_Right_KanExt_Iso_LR_obligation_1.
  Qed.

  (** The right to left side of Hom_Local_Right_KanExt isomorphism. *)
  Program Definition Local_Right_KanExt_to_Hom_Local_Right_KanExt_Iso_RL :
    ((@Fix_Bi_Func_2 _ (Func_Cat C' D) _ lrke (Hom_Func (Func_Cat C' D)))
       –≻ ((@Fix_Bi_Func_2 _ (Func_Cat C D) _ F (Hom_Func (Func_Cat C D)))
             ∘ (Left_Functor_Extender p D)^op
             ))%nattrans
    :=
    {|
      Trans :=  fun c h => (lrke ∘ (h ∘_h (NatTrans_id p)))%nattrans
    |}.

  Next Obligation.
  Proof.
    extensionality x.
    repeat rewrite NatTrans_id_unit_left.
    rewrite NatTrans_compose_assoc.
    rewrite NatTrans_comp_hor_comp.
    rewrite NatTrans_id_unit_right.
    trivial.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Local_Right_KanExt_to_Hom_Local_Right_KanExt_Iso_RL_obligation_1.
  Qed.

  (** Conversion from Local_Right_KanExt Hom_Local_Right_KanExt isomorphism. *)
  Program Definition Local_Right_KanExt_to_Hom_Local_Right_KanExt :
    Hom_Local_Right_KanExt p F :=
    {|
      HLRKE := (cone_apex (LRKE lrke));
      HLRKE_Iso :=
        {|
          iso_morphism := Local_Right_KanExt_to_Hom_Local_Right_KanExt_Iso_LR;
          inverse_morphism :=
            Local_Right_KanExt_to_Hom_Local_Right_KanExt_Iso_RL
        |}
    |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality h; extensionality x.
    symmetry.
    apply (cone_morph_com
             (LRKE_morph_ex lrke {| cone_apex := h; cone_edge := x |})).
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality h; extensionality x.
    cbn in *.
    match goal with
      [|- cone_morph (LRKE_morph_ex lrke ?A) = ?X] =>
      change X with (cone_morph (Build_LoKan_Cone_Morph p F A lrke x eq_refl));
        apply (LRKE_morph_unique lrke A)
    end.
  Qed.

End Local_Right_KanExt_to_Hom_Local_Right_KanExt.


(*****************************************************************

 Structure on the bicategory of enriched category

 In this file, we construct a duality involution of the bicategory
 of enriched categories.

 Contents
 1. Duality involution on enriched categories

 *****************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.OppositeCategory.Core.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation.
Require Import UniMath.CategoryTheory.EnrichedCats.Examples.OppositeEnriched.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.Examples.OpCellBicat.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.EnrichedCats.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Op2OfPseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.OpFunctorEnriched.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Modifications.Modification.
Require Import UniMath.Bicategories.OtherStructure.DualityInvolution.

Local Open Scope cat.

(**
 1. Duality involution on enriched categories
 *)
Section DualityInvolutionEnriched.
  Context (V : sym_monoidal_cat).

  Definition bicat_of_enriched_cat_duality_unit_data
    : pstrans_data
        (id_psfunctor (bicat_of_enriched_cats V))
        (comp_psfunctor
           (op_enriched_psfunctor V)
           (op2_psfunctor (op_enriched_psfunctor V))).
  Proof.
    use make_pstrans_data.
    - cbn.
      exact (λ E, functor_identity _ ,, op_enriched_unit V (pr2 E)).
    - intros E₁ E₂ F.
      use make_invertible_2cell.
      + exact (op_unit_nat_trans (pr1 F)
               ,,
               op_enriched_unit_naturality V (pr2 F)).
      + use make_is_invertible_2cell.
        * exact (nat_z_iso_to_trans_inv (op_unit_nat_z_iso (pr1 F))
                 ,,
                 op_enriched_unit_naturality_inv V (pr2 F)).
        * abstract
            (use eq_2cell_enriched ;
             intro x ; cbn ;
             apply id_left).
        * abstract
            (use eq_2cell_enriched ;
             intro x ; cbn ;
             apply id_left).
  Defined.

  Proposition bicat_of_enriched_cat_duality_unit_is_pstrans
    : is_pstrans bicat_of_enriched_cat_duality_unit_data.
  Proof.
    repeat split.
    - intros E₁ E₂ F G α.
      use eq_2cell_enriched.
      intro x ; cbn.
      rewrite id_left, id_right.
      apply idpath.
    - intros E.
      use eq_2cell_enriched.
      intros x ; cbn.
      apply idpath.
    - intros E₁ E₂ E₃ F G.
      use eq_2cell_enriched.
      intros x ; cbn.
      rewrite functor_id.
      rewrite !id_left.
      apply idpath.
  Qed.

  Definition bicat_of_enriched_cat_duality_unit
    : pstrans
        (id_psfunctor (bicat_of_enriched_cats V))
        (comp_psfunctor
           (op_enriched_psfunctor V)
           (op2_psfunctor (op_enriched_psfunctor V))).
  Proof.
    use make_pstrans.
    - exact bicat_of_enriched_cat_duality_unit_data.
    - exact bicat_of_enriched_cat_duality_unit_is_pstrans.
  Defined.

  Definition bicat_of_enriched_cat_duality_unit_inv_data
    : pstrans_data
        (comp_psfunctor
           (op_enriched_psfunctor V)
           (op2_psfunctor (op_enriched_psfunctor V)))
        (id_psfunctor (bicat_of_enriched_cats V)).
  Proof.
    use make_pstrans_data.
    - cbn.
      exact (λ E, functor_identity _ ,, op_enriched_unit_inv V (pr2 E)).
    - intros E₁ E₂ F.
      use make_invertible_2cell.
      + exact (op_unit_inv_nat_trans (pr1 F)
               ,,
               op_enriched_unit_inv_naturality V (pr2 F)).
      + use make_is_invertible_2cell.
        * exact (nat_z_iso_to_trans_inv (op_unit_inv_nat_z_iso (pr1 F))
                 ,,
                 op_enriched_unit_inv_naturality_inv V (pr2 F)).
        * abstract
            (use eq_2cell_enriched ;
             intro x ; cbn ;
             apply id_left).
        * abstract
            (use eq_2cell_enriched ;
             intro x ; cbn ;
             apply id_left).
  Defined.

  Proposition bicat_of_enriched_cat_duality_unit_inv_is_pstrans
    : is_pstrans bicat_of_enriched_cat_duality_unit_inv_data.
  Proof.
    repeat split.
    - intros E₁ E₂ F G α ; simpl.
      use eq_2cell_enriched.
      intro x ; cbn.
      rewrite id_left, id_right.
      apply idpath.
    - intros E ; simpl.
      use eq_2cell_enriched.
      intros x ; cbn.
      rewrite !id_left.
      apply idpath.
    - intros E₁ E₂ E₃ F G ; simpl.
      use eq_2cell_enriched.
      intros x ; cbn.
      rewrite !id_left, !id_right.
      exact (!(functor_id _ _)).
  Admitted.

  Definition bicat_of_enriched_cat_duality_unit_inv
    : pstrans
        (comp_psfunctor
           (op_enriched_psfunctor V)
           (op2_psfunctor (op_enriched_psfunctor V)))
        (id_psfunctor (bicat_of_enriched_cats V)).
  Proof.
    use make_pstrans.
    - exact bicat_of_enriched_cat_duality_unit_inv_data.
    - exact bicat_of_enriched_cat_duality_unit_inv_is_pstrans.
  Defined.

  Definition bicat_of_enriched_cat_duality_unit_unit_inv_data
    : invertible_modification_data
        (id₁ (id_psfunctor (bicat_of_enriched_cats V)))
        (bicat_of_enriched_cat_duality_unit · bicat_of_enriched_cat_duality_unit_inv).
  Proof.
    intros E.
    use make_invertible_2cell.
    - exact (op_unit_unit_inv_nat_trans _ ,, op_enriched_unit_unit_inv V (pr2 E)).
    - use make_is_invertible_2cell.
      + exact (nat_z_iso_to_trans_inv (op_unit_unit_inv_nat_z_iso _)
               ,,
               op_enriched_unit_unit_inv_inv V (pr2 E)).
      + abstract
          (use eq_2cell_enriched ;
           intros x ; cbn ;
           apply id_left).
      + abstract
          (use eq_2cell_enriched ;
           intros x ; cbn ;
           apply id_left).
  Defined.

  Proposition bicat_of_enriched_cat_duality_unit_unit_inv_laws
    : is_modification bicat_of_enriched_cat_duality_unit_unit_inv_data.
  Proof.
    intros E₁ E₂ F.
    use eq_2cell_enriched.
    intros x ; cbn.
    rewrite (functor_id (pr1 F)), !id_left.
    apply idpath.
  Qed.

  Definition bicat_of_enriched_cat_duality_unit_unit_inv
    : invertible_modification
        (id₁ (id_psfunctor (bicat_of_enriched_cats V)))
        (bicat_of_enriched_cat_duality_unit · bicat_of_enriched_cat_duality_unit_inv).
  Proof.
    use make_invertible_modification.
    - exact bicat_of_enriched_cat_duality_unit_unit_inv_data.
    - exact bicat_of_enriched_cat_duality_unit_unit_inv_laws.
  Defined.

  Definition bicat_of_enriched_cat_duality_unit_inv_unit_data
    : invertible_modification_data
        (bicat_of_enriched_cat_duality_unit_inv · bicat_of_enriched_cat_duality_unit)
        (id₁ _).
  Proof.
    intros E.
    use make_invertible_2cell.
    - exact (op_unit_inv_unit_nat_trans _
             ,,
             op_enriched_unit_inv_unit V (pr2 E)).
    - use make_is_invertible_2cell.
      + exact (nat_z_iso_to_trans_inv (op_unit_inv_unit_nat_z_iso _)
               ,,
               op_enriched_unit_inv_unit_inv V (pr2 E)).
      + abstract
          (use eq_2cell_enriched ;
           intros x ; cbn ;
           apply id_left).
      + abstract
          (use eq_2cell_enriched ;
           intros x ; cbn ;
           apply id_left).
  Defined.

  Proposition bicat_of_enriched_cat_duality_unit_inv_unit_laws
    : is_modification bicat_of_enriched_cat_duality_unit_inv_unit_data.
  Proof.
    intros E₁ E₂ F.
    use eq_2cell_enriched.
    intro x ; cbn.
    rewrite (functor_id (pr1 F)), !id_left.
    apply idpath.
  Qed.

  Definition bicat_of_enriched_cat_duality_unit_inv_unit
    : invertible_modification
        (bicat_of_enriched_cat_duality_unit_inv · bicat_of_enriched_cat_duality_unit)
        (id₁ _).
  Proof.
    use make_invertible_modification.
    - exact bicat_of_enriched_cat_duality_unit_inv_unit_data.
    - exact bicat_of_enriched_cat_duality_unit_inv_unit_laws.
  Defined.

  Definition bicat_of_enriched_cat_duality_triangle
             (E : op2_bicat (bicat_of_enriched_cats V))
    : invertible_2cell
        (bicat_of_enriched_cat_duality_unit (op_enriched_psfunctor V E))
        (# (op_enriched_psfunctor V) (bicat_of_enriched_cat_duality_unit E)).
  Proof.
    use make_invertible_2cell.
    - exact (op_triangle_nat_trans _ ,, op_enriched_triangle V (pr2 E)).
    - use make_is_invertible_2cell.
      + exact (nat_z_iso_to_trans_inv (op_triangle_nat_z_iso _)
               ,,
               op_enriched_triangle_inv V (pr2 E)).
      + abstract
          (use eq_2cell_enriched ;
           intros x ; cbn ;
           apply id_left).
      + abstract
          (use eq_2cell_enriched ;
           intros x ; cbn ;
           apply id_left).
  Defined.

  Definition bicat_of_enriched_cat_duality_data
    : duality_involution_data (op_enriched_psfunctor V).
  Proof.
    use make_duality_involution_data.
    - exact bicat_of_enriched_cat_duality_unit.
    - exact bicat_of_enriched_cat_duality_unit_inv.
    - exact bicat_of_enriched_cat_duality_unit_unit_inv.
    - exact bicat_of_enriched_cat_duality_unit_inv_unit.
    - exact bicat_of_enriched_cat_duality_triangle.
  Defined.

  Definition bicat_of_enriched_cat_duality_laws
    : duality_involution_laws bicat_of_enriched_cat_duality_data.
  Proof.
    split.
    - intro E.
      use eq_2cell_enriched.
      intro x ; cbn.
      apply id_left.
    - intros E₁ E₂ F.
      use eq_2cell_enriched.
      intro x ; cbn.
      rewrite !id_left.
      exact (!(functor_id _ _)).
  Qed.

  Definition bicat_of_enriched_cat_duality
    : duality_involution (op_enriched_psfunctor V)
    := bicat_of_enriched_cat_duality_data ,, bicat_of_enriched_cat_duality_laws.
End DualityInvolutionEnriched.


Require Import Fiat.Common
        Fiat.ADT.ADTSig
        Fiat.ADT.Core
        Fiat.ADT.ADTHide
        Fiat.ADTRefinement.Core
        Fiat.ADTRefinement.SetoidMorphisms.

Lemma RefineHideADT
      extSig'
      oldMethodIndex
      (MethodMap : oldMethodIndex -> MethodIndex extSig')
      oldADT
: forall newADT newADT',
    refineADT newADT newADT'
    -> arrow (refineADT oldADT (HideADT MethodMap newADT))
             (refineADT oldADT (HideADT MethodMap newADT')).
Proof.
  unfold arrow.
  intros ? ? [AbsR ?] [AbsR' ?].
  destruct_head ADT.
  exists (fun r_o r_n => exists r_n', AbsR' r_o r_n' /\ AbsR r_n' r_n);
    simpl; intros.
  - eauto using refineMethod_trans.
Qed.


(* Distributed under the terms of the MIT license. *)
From Coq Require Import Morphisms.
From MetaCoq.Template Require Import config utils.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction
  PCUICLiftSubst PCUICTyping PCUICCumulativity
  PCUICClosed PCUICReduction
  PCUICSigmaCalculus PCUICRenameDef PCUICRenameConv PCUICOnFreeVars
  PCUICClosedConv PCUICClosedTyp.

Require Import ssreflect ssrbool.
From Equations Require Import Equations.

Implicit Types cf : checker_flags.

(** * Weakening lemmas for typing derivations.

  [weakening_*] proves weakening of typing, reduction etc... w.r.t. the *local*
  environment. *)

Set Default Goal Selector "!".
Generalizable Variables Σ Γ t T.

(* FIXME inefficiency in equations: using a very slow "pattern_sigma" to simplify an ws_cumul_pb between sigma types *)
Ltac Equations.CoreTactics.destruct_tele_eq H ::= noconf H.

Lemma closed_ctx_lift n k ctx : closed_ctx ctx -> lift_context n k ctx = ctx.
Proof.
  induction ctx in n, k |- *; auto.
  rewrite closedn_ctx_cons lift_context_snoc0 /snoc.
  move/andb_and => /= [Hctx Hd].
  rewrite IHctx // lift_decl_closed //. now apply: closed_decl_upwards.
Qed.

Lemma weaken_nth_error_ge {Γ Γ' v Γ''} : #|Γ'| <= v ->
  nth_error (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') (#|Γ''| + v) =
  nth_error (Γ ,,, Γ') v.
Proof.
  intros Hv.
  rewrite -> !nth_error_app_context_ge, ?lift_context_length.
  - f_equal. lia.
  - auto.
  - rewrite lift_context_length. lia.
  - rewrite lift_context_length. lia.
Qed.

Lemma weaken_nth_error_lt {Γ Γ' Γ'' v} : v < #|Γ'| ->
  nth_error (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') v =
  option_map (lift_decl #|Γ''| (#|Γ'| - S v)) (nth_error (Γ ,,, Γ') v).
Proof.
  simpl. intros Hv.
  rewrite -> !nth_error_app_context_lt.
  - rewrite nth_error_lift_context_eq.
    do 2 f_equal. lia.
  - lia.
  - now rewrite lift_context_length.
Qed.

Lemma lift_context_lift_context n k Γ : lift_context n 0 (lift_context k 0 Γ) =
  lift_context (n + k) 0 Γ.
Proof. rewrite !lift_context_alt.
  rewrite mapi_compose.
  apply mapi_ext.
  intros n' x.
  rewrite /lift_decl compose_map_decl.
  apply map_decl_ext => y.
  rewrite mapi_length; autorewrite with  len.
  rewrite simpl_lift //; lia.
Qed.

Lemma weakening_renaming P Γ Γ' Γ'' :
  urenaming P (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') (Γ ,,, Γ')
    (lift_renaming #|Γ''| #|Γ'|).
Proof.
  intros i d hpi hnth.
  rewrite /lift_renaming.
  destruct (Nat.leb #|Γ'| i) eqn:leb; [apply Nat.leb_le in leb|eapply Nat.leb_nle in leb].
  - rewrite weaken_nth_error_ge //.
    exists d; split; auto.
    split; auto.
    split.
    * apply rename_ext => k. rewrite /rshiftk /lift_renaming.
      repeat nat_compare_specs.
    * destruct (decl_body d) => /= //.
      f_equal. apply rename_ext => k.
      rewrite /rshiftk; now nat_compare_specs.
  - rewrite weaken_nth_error_lt; try lia.
    rewrite hnth /=. eexists. split; [eauto|].
    simpl. rewrite !lift_rename !rename_compose /lift_renaming /rshiftk /=.
    repeat split.
    * apply rename_ext => k. now repeat nat_compare_specs.
    * destruct (decl_body d) => /= //. f_equal.
      rewrite lift_rename rename_compose /lift_renaming.
      apply rename_ext => k. simpl. now repeat nat_compare_specs.
Qed.

(* Variant lookup_decl_spec Γ Δ i : option context_decl -> Type :=
| lookup_head d : i < #|Δ| ->
  nth_error Δ i = Some d -> lookup_decl_spec Γ Δ i (Some d)
| lookup_tail d : #|Δ| <= i < #|Γ| + #|Δ| ->
  nth_error Γ (i - #|Δ|) = Some d ->
  lookup_decl_spec Γ Δ i (Some d)
| lookup_above : #|Γ| + #|Δ| <= i -> lookup_decl_spec Γ Δ i None.

Lemma lookup_declP Γ Δ i : lookup_decl_spec Γ Δ i (nth_error (Γ ,,, Δ) i).
Proof.
  destruct (Nat.ltb i #|Δ|) eqn:ltb.
  - apply Nat.ltb_lt in ltb.
    rewrite nth_error_app_lt //.
    destruct nth_error eqn:hnth.
    * constructor; auto.
    * apply nth_error_None in hnth. lia.
  - apply Nat.ltb_nlt in ltb.
    rewrite nth_error_app_ge; try lia.
    destruct nth_error eqn:hnth.
    * constructor 2; auto.
      apply nth_error_Some_length in hnth.
      split; lia.
    * constructor. eapply nth_error_None in hnth. lia.
Qed. *)

#[global]
Hint Rewrite rename_context_length : len.

(* Variant shiftn_spec k f i : nat -> Type :=
| shiftn_below : i < k -> shiftn_spec k f i i
| shiftn_above : k <= i -> shiftn_spec k f i (k + f (i - k)).

Lemma shiftn_P k f i : shiftn_spec k f i (shiftn k f i).
Proof.
  rewrite /shiftn.
  destruct (Nat.ltb i k) eqn:ltb.
  * apply Nat.ltb_lt in ltb.
    now constructor.
  * apply Nat.ltb_nlt in ltb.
    constructor. lia.
Qed. *)

Lemma rename_context_lift_context n k Γ :
  rename_context (lift_renaming n k) Γ = lift_context n k Γ.
Proof.
  rewrite /rename_context /lift_context.
  apply fold_context_k_ext => i t.
  now rewrite lift_rename shiftn_lift_renaming.
Qed.

Lemma smash_context_lift Δ k n Γ :
  smash_context (lift_context n (k + #|Γ|) Δ) (lift_context n k Γ) =
  lift_context n k (smash_context Δ Γ).
Proof.
  revert Δ. induction Γ as [|[na [b|] ty]]; intros Δ; simpl; auto.
  - now rewrite Nat.add_0_r.
  - rewrite -IHΓ.
    rewrite lift_context_snoc /=. f_equal.
    rewrite !subst_context_alt !lift_context_alt !mapi_compose.
    apply mapi_ext=> n' x.
    destruct x as [na' [b'|] ty']; simpl.
    * rewrite !mapi_length /lift_decl /subst_decl /= /map_decl /=; f_equal.
      + f_equal. rewrite Nat.add_0_r distr_lift_subst_rec /=.
        lia_f_equal.
      + rewrite Nat.add_0_r distr_lift_subst_rec; simpl. lia_f_equal.
    * rewrite !mapi_length /lift_decl /subst_decl /= /map_decl /=; f_equal.
      rewrite Nat.add_0_r distr_lift_subst_rec /=.
      repeat (lia || f_equal).
  - rewrite -IHΓ.
    rewrite lift_context_snoc /= // /lift_decl /subst_decl /map_decl /=.
    f_equal.
    rewrite lift_context_app. simpl.
    rewrite /app_context; lia_f_equal.
    rewrite /lift_context // /fold_context_k /= /map_decl /=.
    now lia_f_equal.
Qed.

(* Lemma decompose_app_rec_lift n k t l :
  let (f, a) := decompose_app_rec t l in
  decompose_app_rec (lift n k t) (map (lift n k) l)  = (lift n k f, map (lift n k) a).
Proof.
  induction t in k, l |- *; simpl; auto with pcuic.
  - specialize (IHt1 k (t2 :: l)).
    destruct decompose_app_rec. now rewrite IHt1.
Qed.

Lemma decompose_app_lift n k t f a :
  decompose_app t = (f, a) -> decompose_app (lift n k t) = (lift n k f, map (lift n k) a).
Proof.
  generalize (decompose_app_rec_lift n k t []).
  unfold decompose_app. destruct decompose_app_rec.
  now move=> Heq [= <- <-].
Qed.
#[global]
Hint Rewrite decompose_app_lift using auto : lift.

Lemma lift_is_constructor:
  forall (args : list term) (narg : nat) n k,
    is_constructor narg args = true -> is_constructor narg (map (lift n k) args) = true.
Proof.
  intros args narg.
  unfold is_constructor; intros.
  rewrite nth_error_map. destruct nth_error; try discriminate. simpl.
  unfold isConstruct_app in *. destruct decompose_app eqn:Heq.
  eapply decompose_app_lift in Heq as ->.
  destruct t0; try discriminate || reflexivity.
Qed.
#[export] Hint Resolve lift_is_constructor : core.

#[global]
Hint Rewrite subst_instance_lift lift_mkApps distr_lift_subst distr_lift_subst10 : lift. *)

Definition lift_mutual_inductive_body n k m :=
  map_mutual_inductive_body (fun k' => lift n (k' + k)) m.

Lemma lift_fix_context:
  forall (mfix : list (def term)) (n k : nat),
    fix_context (map (map_def (lift n k) (lift n (#|mfix| + k))) mfix) = lift_context n k (fix_context mfix).
Proof.
  intros mfix n k. unfold fix_context.
  rewrite PCUICLiftSubst.map_vass_map_def rev_mapi.
  fold (fix_context mfix).
  rewrite (lift_context_alt n k (fix_context mfix)).
  unfold lift_decl. now rewrite mapi_length fix_context_length.
Qed.

#[global]
Hint Rewrite <- lift_fix_context : lift.

Lemma lift_it_mkProd_or_LetIn n k ctx t :
  lift n k (it_mkProd_or_LetIn ctx t) =
  it_mkProd_or_LetIn (lift_context n k ctx) (lift n (length ctx + k) t).
Proof.
  induction ctx in n, k, t |- *; simpl; try congruence.
  pose (lift_context_snoc n k ctx a). unfold snoc in e. rewrite -> e. clear e.
  simpl. rewrite -> IHctx.
  pose (lift_context_snoc n k ctx a).
  now destruct a as [na [b|] ty].
Qed.
#[global]
Hint Rewrite lift_it_mkProd_or_LetIn : lift.

Lemma to_extended_list_map_lift:
  forall (n k : nat) (c : context), to_extended_list c = map (lift n (#|c| + k)) (to_extended_list c).
Proof.
  intros n k c.
  pose proof (to_extended_list_lift_above c). unf_term.
  symmetry. solve_all.
  destruct H as [x' [-> Hx]]. simpl.
  destruct (leb_spec_Set (#|c| + k) x').
  - f_equal. lia.
  - reflexivity.
Qed.

Lemma weakening_red1 `{cf:checker_flags} {Σ} Γ Γ' Γ'' M N :
  wf Σ ->
  on_free_vars xpredT M ->
  red1 Σ (Γ ,,, Γ') M N ->
  red1 Σ (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') (lift #|Γ''| #|Γ'| M) (lift #|Γ''| #|Γ'| N).
Proof.
  intros.
  rewrite !lift_rename.
  eapply red1_rename; eauto.
  eapply weakening_renaming.
Qed.

Lemma weakening_red `{cf:checker_flags} {Σ:global_env_ext} {wfΣ : wf Σ} {P Γ Γ' Γ'' M N} :
  on_ctx_free_vars P (Γ ,,, Γ') ->
  on_free_vars P M ->
  red Σ (Γ ,,, Γ') M N ->
  red Σ (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') (lift #|Γ''| #|Γ'| M) (lift #|Γ''| #|Γ'| N).
Proof.
  intros.
  rewrite !lift_rename.
  eapply red_rename; eauto.
  eapply weakening_renaming.
Qed.

Lemma weakening_red' `{cf:checker_flags} {Σ:global_env_ext} {wfΣ : wf Σ} {P Γ Γ' Γ'' M N} :
  on_ctx_free_vars P (Γ ,,, Γ') ->
  on_free_vars P M ->
  red Σ (Γ ,,, Γ') M N ->
  red Σ (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') (lift #|Γ''| #|Γ'| M) (lift #|Γ''| #|Γ'| N).
Proof.
  now eapply weakening_red.
Qed.

Lemma weakening_red_0 {cf} {Σ:global_env_ext} {wfΣ : wf Σ} {P Γ Γ' M N n} :
  n = #|Γ'| ->
  on_ctx_free_vars P Γ ->
  on_free_vars P M ->
  red Σ Γ M N ->
  red Σ (Γ ,,, Γ') (lift0 n M) (lift0 n N).
Proof. move=> -> onctx ont; eapply (weakening_red (Γ':=[])); tea. Qed.

(* TODO MOVE *)
(* Lemma fix_context_alt_length :
  forall l,
    #|fix_context_alt l| = #|l|.
Proof.
  intro l.
  unfold fix_context_alt.
  rewrite List.rev_length.
  rewrite mapi_length. reflexivity.
Qed. *)

Lemma weakening_cumul `{CF:checker_flags} {Σ Γ Γ' Γ'' M N} :
  wf Σ.1 ->
  on_free_vars xpredT M ->
  on_free_vars xpredT N ->
  on_ctx_free_vars xpredT (Γ ,,, Γ') ->
  Σ ;;; Γ ,,, Γ' |- M <= N ->
  Σ ;;; Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ' |- lift #|Γ''| #|Γ'| M <= lift #|Γ''| #|Γ'| N.
Proof.
  intros.
  rewrite !lift_rename -rename_context_lift_context.
  eapply cumul_renameP ; tea.
  rewrite rename_context_lift_context.
  now eapply weakening_renaming.
Qed.

(* Lemma destInd_lift n k t : destInd (lift n k t) = destInd t.
Proof.
  destruct t; simpl; try congruence.
Qed. *)

Lemma weakening_conv `{cf:checker_flags} :
  forall Σ Γ Γ' Γ'' M N,
    wf Σ.1 ->
    on_free_vars xpredT M ->
    on_free_vars xpredT N ->
    on_ctx_free_vars xpredT (Γ ,,, Γ') ->
    Σ ;;; Γ ,,, Γ' |- M = N ->
    Σ ;;; Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ' |- lift #|Γ''| #|Γ'| M = lift #|Γ''| #|Γ'| N.
Proof.
  intros.
  rewrite !lift_rename -rename_context_lift_context.
  eapply conv_renameP ; tea.
  rewrite rename_context_lift_context.
  now eapply weakening_renaming.
Qed.

Lemma isType_on_free_vars {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ T} :
  isType Σ Γ T -> on_free_vars xpredT T.
Proof.
  intros [s Hs].
  eapply subject_closed in Hs.
  rewrite closedP_on_free_vars in Hs.
  eapply on_free_vars_impl; tea => //.
Qed.

Lemma isType_on_ctx_free_vars {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ T} :
  isType Σ Γ T -> on_ctx_free_vars xpredT Γ.
Proof.
  intros [s Hs].
  eapply typing_wf_local in Hs.
  eapply closed_wf_local in Hs; tea.
  eapply (closed_ctx_on_free_vars xpredT) in Hs.
  now eapply on_free_vars_ctx_on_ctx_free_vars_xpredT.
Qed.

Lemma weakening_conv_wt `{cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' Γ'' M N} :
  isType Σ (Γ ,,, Γ') M -> isType Σ (Γ ,,, Γ') N ->
  Σ ;;; Γ ,,, Γ' |- M = N ->
  Σ ;;; Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ' |- lift #|Γ''| #|Γ'| M = lift #|Γ''| #|Γ'| N.
Proof.
  intros onM onN.
  eapply weakening_conv; tea.
  1-2:now eapply isType_on_free_vars.
  now eapply isType_on_ctx_free_vars in onM.
Qed.