From ZornsLemma Require Export ImageImplicit.
From ZornsLemma Require Import EnsemblesImplicit.
From ZornsLemma Require Import FunctionProperties.

Lemma option_Full_set_Im (X : Type) :
  Full_set = Add (Im Full_set (@Some X)) None.
Proof.
apply Extensionality_Ensembles; split; red; intros.
2: { constructor. }
destruct x.
- left. exists x; constructor.
- right. constructor.
Qed.

Lemma Im_Full_set_surj {X Y : Type} (f : X -> Y) :
  surjective f ->
  Full_set = Im Full_set f.
Proof.
intros. apply Extensionality_Ensembles; split; red; intros.
2: { constructor. }
destruct (H x) as [y].
subst. apply Im_def.
constructor.
Qed.

Lemma Im_monotonous {X Y : Type} (f : X -> Y) (U V : Ensemble X) :
  Included U V ->
  Included (Im U f) (Im V f).
Proof.
  intros.
  red. intros.
  inversion H0; subst; clear H0.
  apply H in H1.
  exists x0; auto.
Qed.

Lemma Im_Included_injective {X Y : Type} (f : X -> Y) :
  injective f <->
  forall U V : Ensemble X,
    Included U V <->
    Included (Im U f) (Im V f).
Proof.
  split.
  - intros. split.
    { apply Im_monotonous. }
    intros.
    red; intros.
    specialize (H0 (f x)).
    unshelve epose proof (H0 _); [|clear H0].
    { exists x; auto. }
    inversion H2; subst; clear H2.
    apply H in H3.
    subst. assumption.
  - intros.
    red; intros.
    specialize (H (Singleton x) (Singleton y)) as [_].
    unshelve epose proof (H _); [|clear H].
    { red; intros.
      inversion H1; subst; clear H1.
      inversion H2; subst; clear H2.
      exists y; auto with sets.
    }
    unshelve epose proof (H1 x _); [|clear H1].
    { constructor. }
    inversion H; subst; clear H.
    reflexivity.
Qed.

Lemma Union_Im {X Y : Type} (f : X -> Y) (U V : Ensemble X) :
  Union (Im U f) (Im V f) = Im (Union U V) f.
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  - destruct H.
    all: inversion H; subst; clear H.
    all: apply Im_def.
    1: left.
    2: right.
    all: assumption.
  - inversion H; subst; clear H.
    destruct H0; [left|right].
    all: apply Im_def.
    all: assumption.
Qed.

Lemma Im_id {X : Type} (U : Ensemble X) :
  Im U id = U.
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  - inversion H; subst; clear H. assumption.
  - exists x; auto.
Qed.

Lemma Im_compose_inj_surj {X Y Z : Type} (f : X -> Y) (g : Y -> Z) :
  injective g -> Im Full_set (compose g f) = Im Full_set g ->
  surjective f.
Proof.
  intros ? ? ?.
  assert (In (Im Full_set g) (g y)).
  { apply Im_def. constructor. }
  rewrite <- H0 in H1.
  inversion H1; subst; clear H1.
  unfold compose in H3.
  exists x. apply H in H3.
  congruence.
Qed.


Require Import MapProofs.Common.
Set Bullet Behavior "Strict Subproofs".
Require Import MapProofs.Bounds.
Require Import MapProofs.Tactics.
Require Import MapProofs.UnionIntersectDifferenceProofs.
Require Import MapProofs.LookupProofs.
Require Import MapProofs.InsertProofs.
Require Import MapProofs.DeleteUpdateProofs.
Require Import MapProofs.ToListProofs.
Require Import MapProofs.FilterPartitionProofs.
Require Import MapProofs.MaxMinProofs.
Require Import MapProofs.MapFunctionProofs.
Require Import MapProofs.TypeclassProofs.
Require Import MapProofs.ContainerFacts.
(** * Instantiating the [FMapInterface] *)

Require Import Coq.FSets.FMapInterface.
Require Import Coq.Structures.Equalities.
From Coq Require Import ssrbool ssreflect.
Require Import OrdTheories.

Module MapFMap (E : OrderedType)<: WSfun(E) <: WS <: Sfun(E) <: S.
  Module E := E.

  Include OrdTheories.OrdTheories E.
  Definition key := E.t.

  Definition WFMap (e: Type) :=
  {m : Map key e | WF m}.

  Definition t: Type -> Type := WFMap.
Section Types.

  Variable elt : Type.

  Program Definition empty: t elt := empty.
  Next Obligation. constructor. Qed.

  Program Definition is_empty: t elt -> bool := null.

  Program Definition add: key -> elt -> t elt -> t elt := insert.
  Next Obligation. unfold proj1_sig. destruct x1. apply insert_WF; assumption.
  Defined.

  Program Definition find: key -> t elt -> option elt := lookup.

  Program Definition remove: key -> t elt -> t elt := delete.
  Next Obligation. destruct x0. simpl. eapply delete_Desc.
  - apply w.
  - intros. apply H.
  Defined.

  Program Definition mem : key -> t elt -> bool := member.

  Variable elt' elt'' : Type.

  Program Definition map : (elt -> elt') -> t elt -> t elt' := Internal.map.
  Next Obligation. destruct x0. simpl. apply map_preserves_WF. apply w. Defined.

  (*A few lemmas useful in proving mapWithKey's well formdedness*)
  Lemma mapWithKey_pres_size: forall {a : Type} {b : Type} (m: Map key b) (f: key -> b -> a) lb ub,
  Bounded m lb ub ->
  size m = size (mapWithKey f m).
  Proof.
  intros. inversion H; reflexivity.
  Qed.
  Lemma mapWithKey_pres_WF: forall {a : Type} {b : Type} (m: Map key b) (f: key -> b -> a) lb ub,
  Bounded m lb ub ->
  Bounded (mapWithKey f m) lb ub.
  Proof.
    intros. induction H.
    - simpl. constructor.
    - simpl. apply BoundedBin; try(assumption); erewrite <- mapWithKey_pres_size;
      try(erewrite <- mapWithKey_pres_size); try (assumption); try (eassumption).
  Qed.

  Program Definition mapi : (key -> elt -> elt') -> t elt -> t elt' := mapWithKey.
  Next Obligation. destruct x0. simpl. apply mapWithKey_pres_WF. apply w. Defined.

  (*[map2] is a particularly complex function to write, since there is no direct analogue. It is possible
  to write several ways, including folding over both maps in order or folding over the [toList] of the
  two maps. Instead, I defined it by first mapping each map to a map of (key, option elt''), then
  unioning the two together [map2_map], and then folding this combined map into a map of (key, elt''),
  keeping only the values with Some [map2_fix]. This makes the proofs more manageable, though it is not
  particularly efficient*)

  Definition map2_map (m1: Map key elt) (m2: Map key elt') (f: option elt -> option elt' -> option elt'') :
    Map key (option elt'') :=
    union (mapWithKey (fun k v =>(f (sem m1 k)(sem m2 k))) m1)
   (mapWithKey (fun k v => f (sem m1 k) (sem m2 k)) m2).

  Definition map2_fix (m1: Map key (option elt'')) (m2: Map key elt''): Map key elt'' :=
   foldrWithKey (fun k v t => match v with
                             |Some x => insert k x t
                             |None => t
                             end) m2 m1.

(*A few helper lemmas that each of these functions preserve well formed maps*)
  Lemma map2_map_wf : forall m1 m2 f,
    WF m1 ->
    WF m2 ->
    WF (map2_map m1 m2 f).
  Proof.
    intros. unfold map2_map. eapply union_Desc.
    - apply mapWithKey_pres_WF. apply H.
    - apply mapWithKey_pres_WF. apply H0.
    - intros. apply H1.
  Qed.
  Lemma map2_fix_pres_wf: forall m m',
  WF m ->
  WF m' ->
  WF (map2_fix m m').
  Proof.
  intros. unfold map2_fix. generalize dependent m'. induction H; intros.
  - simpl. assumption.
  - simpl. apply IHBounded1. destruct v eqn : ?.
    + eapply insert_Desc. apply IHBounded2. assumption. reflexivity. reflexivity. intros.
      apply H6.
    + apply IHBounded2. apply H5.
Qed.

  Program Definition map2 : (option elt -> option elt' -> option elt'') -> t elt -> t elt' -> t elt'' :=
    fun f m1 m2 =>
    map2_fix (map2_map m1 m2 f) Tip.
  Next Obligation. destruct m1. destruct m2. simpl. apply map2_fix_pres_wf.
  apply map2_map_wf. assumption. assumption. constructor. Defined.

  Program Definition elements : t elt -> list (key * elt) := toList.

  Program Definition cardinal : t elt -> nat := map_size.

  Definition foldlWithKey2 {a} := fun (f : key -> elt -> a -> a) (m : Map key elt) b =>
  foldlWithKey (fun t k v => f k v t) b m.

  Program Definition fold : forall (A : Type), (key -> elt -> A -> A) -> t elt -> A -> A :=
   @foldlWithKey2.

  (*Possibly defined elsewhere, this just compares two lists using a comparison function f
  on the values and checking the keys for (decidable) equality*)
  Fixpoint cmp_list (l1 : list (key * elt)) l2 (f: elt -> elt -> bool) :=
  match l1, l2 with
  | nil, nil => true
  | (k1, v1) :: xs, (k2, v2) :: ys => E.eq_dec k1 k2 && f v1 v2 && cmp_list xs ys f
  | _, _ => false
  end.

  Program Definition equal : (elt -> elt -> bool) -> t elt -> t elt -> bool :=
  fun cmp m1 m2 => cmp_list (toList m1) (toList m2) cmp.

Section Spec.

Variable m m' m'' : t elt.
Variable x y z: key.
Variable e e' : elt.

  Program Definition MapsTo: key -> elt -> t elt -> Prop :=
  fun k v m => sem m k = Some v.

  Definition In (k: key) (m : t elt) : Prop := exists e, MapsTo k e m.

  Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.

  Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p').

  Definition eq_key_elt (p p':key*elt) :=
          E.eq (fst p) (fst p') /\ (snd p) = (snd p').

  (*Theories*)

  Lemma MapsTo_1: E.eq x y -> MapsTo x e m -> MapsTo y e m.
  Proof.
    intros. unfold MapsTo in *. erewrite sem_resp_eq. apply H0.
    epose proof elt_eqP. inversion H1. symmetry. apply H2.
    apply E.eq_sym in H. contradiction.
  Qed.

  Lemma mem_1 :In x m -> mem x m = true.
  Proof.
    intros. destruct m.  unfold mem. unfold In in H. simpl.
    unfold MapsTo in H. simpl in H. eapply member_spec. apply w. apply H.
  Qed.

  Lemma mem_2 :mem x m = true -> In x m.
  Proof.
    intros. destruct m. unfold mem in H. unfold In. unfold MapsTo. simpl in *.
    eapply member_spec. apply w. apply H.
  Qed.

  Lemma empty_1 : Empty empty.
  Proof.
    unfold Empty. intros. unfold MapsTo. simpl. intro contra. discriminate contra.
  Qed.

  Lemma is_empty_1: Empty m -> is_empty m = true.
  Proof.
    intros. destruct m. unfold Empty in H. unfold is_empty. unfold MapsTo in H. simpl in *.
    assert (forall a, sem x0 a = None). intros. specialize (H a). destruct (sem x0 a) eqn : ?.
    specialize (H e0). contradiction. reflexivity. rewrite null_empty_iff.
    rewrite <- empty_no_elts. apply H0.
  Qed.

  Lemma is_empty_2 :is_empty m = true -> Empty m.
  Proof.
    intros. destruct m. unfold is_empty in H. unfold Empty. unfold MapsTo. simpl in *.
    intros. erewrite null_empty_iff in H. rewrite <- empty_no_elts in H.
    specialize (H a). rewrite H. intro contra. discriminate contra.
  Qed.

  Lemma elt_neq: ~E.eq x y <-> x == y = false.
  Proof.
    intros. split; intros.
    - destruct (x == y) eqn : ?. apply elt_eq in Heqb. contradiction. reflexivity.
    - intro. apply elt_eq in H0. rewrite H0 in H. inversion H.
  Qed.

  Lemma add_1 : E.eq x y -> MapsTo y e (add x e m).
  Proof.
    intros. destruct m. unfold MapsTo. unfold add. simpl. eapply insert_Desc.
    - apply w.
    - reflexivity.
    - reflexivity.
    - intros. specialize (H2 y). apply E.eq_sym in H. apply elt_eq in H.
      rewrite H in H2. simpl in H2. assumption.
  Qed.

  Lemma add_2 :~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
  Proof.
    intros. destruct m. unfold MapsTo in *. unfold add. simpl in *. eapply insert_Desc.
    - apply w.
    - reflexivity.
    - reflexivity.
    - intros. specialize (H3 y). assert (EqLaws E.t). apply EqLaws_elt. destruct H4.
      apply elt_neq in H. assert (y == x = false) by (order key). rewrite H4 in H3.
       simpl in H3. rewrite H3.
      assumption.
  Qed.

  Lemma add_3 :~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
  Proof.
    intros. destruct m. unfold MapsTo in *. unfold add in H0. simpl in *.
    erewrite sem_insert in H0.
    - apply elt_neq in H. assert (y == x = false) by (order key). rewrite H1 in H0.
      simpl in H0. assumption.
    - apply w.
    - reflexivity.
    - reflexivity.
  Qed.

  (*A sem rule for delete*)
  Lemma delete_sem: forall (m: Map key elt) k i,
  WF m ->
  sem (delete k m) i = if i == k then None else sem m i.
  Proof.
    intros. eapply delete_Desc.
    - apply H.
    - intros. specialize (H2 i). rewrite H2. reflexivity.
  Qed.

  Lemma remove_1 : E.eq x y -> ~ In y (remove x m).
  Proof.
    intros. destruct m. unfold In. unfold MapsTo. unfold remove. simpl. intro.
    destruct H0. rewrite delete_sem in H0. apply elt_eq in H.
    assert ( x == y = true) by (apply H). assert (y == x = true) by (order key).
     rewrite H2 in H0. inversion H0. apply w.
  Qed.

  Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
  Proof.
    intros. unfold MapsTo in *. unfold remove. destruct m. simpl in *.
    rewrite delete_sem. apply elt_neq in H.  assert (y == x = false) by (order key).
    rewrite H1. assumption. apply w.
  Qed.

  Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
  Proof.
    intros. unfold MapsTo in *. destruct m. unfold remove in *. simpl in *.
    rewrite delete_sem in H.  destruct (y == x). inversion H. assumption. apply w.
  Qed.

  Lemma find_1 : MapsTo x e m -> find x m = Some e.
  Proof.
    intros. unfold MapsTo in *. unfold find. destruct m. simpl in *.
    erewrite lookup_spec. apply H. apply w.
  Qed.

  Lemma find_2 : find x m = Some e -> MapsTo x e m.
  Proof.
    intros. unfold find in *. unfold MapsTo. destruct m. simpl in *.
    erewrite lookup_spec in H. assumption. apply w.
  Qed.

  (*Proves the equivalence of Top.In and InA, since both are used in different lemmas*)
  Lemma In_InA_equiv: forall l k v,
    Key_In k v l <-> InA eq_key_elt (k, v) l.
  Proof.
    intros. induction l.
    - simpl. split; intros.
      + destruct H.
      + inversion H.
    - simpl. unfold eq_key_elt in *. split; intros.
      + destruct a. destruct H.
        * destruct H. apply InA_cons_hd. simpl. split.
          apply elt_eq. assert (k == k0 = true) by (order key). apply H1. symmetry.
          apply H0.
        * apply InA_cons_tl. apply IHl. apply H.
      + destruct a. inversion H; subst.
        * simpl in H1. destruct H1. left. split. assert (k == k0 = true) by (apply elt_eq; apply H0).
          order key. symmetry. apply H1.
        * right. apply IHl. apply H1.
  Qed.

(*This is a stronger version of toList_sem that does not require {EqLaws a}. The other
  actually should be implied by this, and can be replaced*)
Lemma toList_sem_again :
  forall (m: Map key elt) lb ub, Bounded m lb ub ->
  forall key value, sem m key = Some value <-> Key_In key value (toList m).
Proof.
  clear.
  intros. generalize dependent value. induction H.
  - simpl. intros. split; intros. discriminate H. destruct H.
  - intros. simpl. rewrite toList_Bin. rewrite elem_or.
    assert (((x, v) :: nil ++ toList s2) = (((x, v) :: nil) ++ toList s2)).
    simpl. reflexivity. simpl.  split; intros.
      + destruct (sem s1 key0) eqn : ?; simpl in H6.
      * apply IHBounded1 in H6. left. apply H6.
      * destruct (key0 == x) eqn : ?; simpl in H6.
        { right. left. simpl. split. order key. inversion H6; subst; reflexivity. }
        { apply IHBounded2 in H6. right. right. assumption. }
     + destruct H6.
      * apply IHBounded1 in H6. rewrite H6. simpl. reflexivity.
      * destruct H6. destruct H6.
        assert (sem s1 key0 = None). { eapply sem_outside_above.
        apply H. unfold isUB. order key. }
        rewrite H8. simpl. apply Eq_Symmetric in H6. rewrite H6. simpl.
        rewrite H7. reflexivity. apply IHBounded2 in H6.
        assert (sem s1 key0 = None). { eapply sem_outside_above. apply H. unfold isUB.
        apply (sem_inside H0 ) in H6. destruct H6. unfold isLB in H6. order key. }
        rewrite H7. assert (key0 == x = false). { apply (sem_inside H0) in H6.
        destruct H6. unfold isLB in H6. order key. } rewrite H8. simpl.
        assumption.
Qed.

  Lemma elements_1 :
        MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
  Proof.
    intros. destruct m. unfold elements. unfold MapsTo in H. simpl in *.
    setoid_rewrite toList_sem_again in H. rewrite <- In_InA_equiv. apply H. apply w.
  Qed.

  Lemma elements_2:
        InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
  Proof.
    intros. unfold MapsTo. unfold elements in *. destruct m. simpl in *.
    eapply toList_sem_again.  apply w. rewrite In_InA_equiv. apply H.
  Qed.

  Import Coq.Sorting.Sorted.

  (*For proving things about elements, we need to redo some of the sorting lemmas, since the
    assumptions are slightly difference (no OrdLaws a)*)
  Local Definition lt : key * elt -> key * elt -> Prop
  := fun x1 x2 => let (e1, a1) := x1 in let (e2, a2) := x2 in (e1 < e2) = true.

  Lemma All_lt_elem:
  forall x i xs,
  Forall (lt x) xs ->
  InA eq_key i xs->
  lt x i.
  Proof.
    intros. unfold eq_key in H0.
    induction H.
    * inversion H0.
    * destruct x0. destruct i. inversion H0; subst.
      - simpl in H3. unfold lt. unfold lt in H. destruct x1.
        assert (k0 == k1 = true) by (apply elt_eq; apply H3). order key.
      - apply IHForall. apply H3.
  Qed.

  (*Unfortunately, we know that the list is sorted, which is much stronger than than there
    are no duplicates. We must prove one implies the other*)
  Lemma sorted_no_dups: forall (l: list (key * elt)),
  StronglySorted lt l -> NoDupA (eq_key) l.
  Proof.
    intros. induction H.
    - constructor.
    - constructor. intro. pose proof All_lt_elem. specialize (H2 a a l H0 H1).
      unfold lt in H2. destruct a. order key.
      apply IHStronglySorted.
  Qed.

  Lemma elements_3w : NoDupA eq_key (elements m).
  Proof.
    intros. unfold elements. destruct m. simpl. apply sorted_no_dups.
    eapply to_List_sorted. apply w.
  Qed.

  Lemma size_equiv: forall (m: Map key elt),
  WF m ->
  Internal.size m = Z.of_nat (map_size m).
  Proof.
    intros. induction H.
    - simpl. reflexivity.
    - simpl. rewrite Zpos_P_of_succ_nat. rewrite Nat2Z.inj_add.
      rewrite <- IHBounded1. rewrite <- IHBounded2. rewrite size_size. omega.
  Qed.

  Lemma cardinal_1 : cardinal m = length (elements m).
  Proof.
    intros. unfold cardinal. unfold elements. destruct m. simpl.
    assert (Z.of_nat (map_size x0) = Z.of_nat (length (toList x0))). {
    rewrite <- size_equiv. eapply size_spec. apply w. apply w. }
    omega.
  Qed.

Lemma foldlWithKey2_fold_left:
    forall {a} (f: key -> elt -> a -> a) (n : a) (map: Map key elt),
  foldlWithKey2 f map n = fold_left (fun t (x : key * elt) => let (a0, b0) := x in f a0 b0 t) (toList map) n.
Proof.
  intros. revert n. revert f. induction map0; intros.
  - simpl. rewrite IHmap0_1. rewrite IHmap0_2. rewrite toList_Bin. rewrite fold_left_app.
    simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Lemma fold_1 :
        forall (m: t elt) (A : Type) (i : A) (f : key -> elt -> A -> A),
        fold _ f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
Proof.
  intros. destruct m0. unfold fold.  unfold elements. simpl.
  rewrite foldlWithKey2_fold_left. unfold fst. unfold snd.  revert i. revert f.
  induction w.
  - simpl. reflexivity.
  - intros. rewrite toList_Bin. simpl. rewrite fold_left_app. rewrite fold_left_app. simpl.
    rewrite IHw1. rewrite IHw2. reflexivity.
Qed.

Definition Equal m m' := forall y, find y m = find y m'.

Definition Equiv (eq_elt: elt -> elt -> Prop) m m' :=
  (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').

Definition Equivb (cmp: elt -> elt -> bool) := Equiv (Cmp cmp).

Variable cmp: elt -> elt -> bool.

(*If the (key, value) pair is in a list, so is just the key*)
Lemma eq_key_elt_implies_key: forall k v l,
  InA eq_key_elt (k,v) l ->
  InA eq_key (k, v) l.
Proof.
  intros. generalize dependent k. generalize dependent v. induction l; intros.
  - inversion H.
  - inversion H; subst.
    + constructor. unfold eq_key. simpl. unfold eq_key_elt in H1. destruct H1. simpl in H0.
      apply H0.
    + apply InA_cons_tl. apply IHl. apply H1.
Qed.

(*Annoyingly, we cannot use the results about StronglySortedness from before, since they
all deal with haskell equality and require EqLaws a. So we have to prove a similar, but
not quite identical, claim*)
Lemma strongly_sorted_cmp_unique: forall (xs ys : list (key * elt)) (cmp: elt -> elt -> bool),
  StronglySorted lt xs ->
  StronglySorted lt ys ->
  (forall x, ((exists y, Key_In x y xs) <-> (exists z, Key_In x z ys)) /\
   (forall y z, Key_In x y xs /\ Key_In x z ys -> cmp y z = true )) ->
  cmp_list xs ys cmp = true.
Proof.
  clear.
  intros. generalize dependent ys. generalize dependent cmp. induction xs; intros.
  - destruct ys.
    + reflexivity.
    + destruct p. specialize (H1 k). destruct H1. destruct H1. simpl in H3.
      assert (exists (e: elt), False). apply H3. exists e. left. split. apply Eq_Reflexive.
      reflexivity. destruct H4. destruct H4.
  - destruct ys.
    + destruct a. specialize (H1 k). destruct H1. destruct H1. simpl in H1.
      assert (exists (e: elt), False). apply H1. exists e. left. split. apply Eq_Reflexive.
      reflexivity. destruct H4. destruct H4.
    + simpl. destruct a. destruct p. rewrite andb_true_iff. split.
      * rewrite andb_true_iff. split.
        -- inversion H; subst. inversion H0; subst. assert (A:=H1). specialize (H1 k). destruct H1.
           destruct H1. assert (exists z : elt, Key_In k z ((k0, e0) :: ys)). apply H1.
           simpl. exists e. left. split. apply Eq_Reflexive. reflexivity. destruct H8.
           simpl in H8. destruct H8.
           ++ destruct H8. apply elt_eq. apply Eq_Symmetric in H8. apply elt_eq in H8. apply H8.
           ++ specialize (A k0). destruct A. destruct H9. assert (exists y : elt, Key_In k0 y ((k, e) :: xs)).
              apply H11. exists e0. simpl. left. split. apply Eq_Reflexive. reflexivity. destruct H12.
              simpl in H12. destruct H12.
              ** destruct H12. apply H12.
              ** apply (All_lt_elem _ (k, x) _) in H7. apply (All_lt_elem _ (k0, x0) _) in H5.
                  unfold lt in H7. unfold lt in H5. order key.
                  setoid_rewrite (In_InA_equiv xs k0 x0) in H12. setoid_rewrite In_InA_equiv in H8.
                  unfold eq_key_elt in H8. apply eq_key_elt_implies_key. apply H12.
                  apply eq_key_elt_implies_key. apply In_InA_equiv. apply H8.
        -- assert (A:=H1). specialize (H1 k). specialize (A k0). destruct H1. destruct A.
           destruct H1. destruct H3. assert (exists z : elt, Key_In k z ((k0, e0) :: ys)).
           apply H1. exists e. simpl. left. split. apply Eq_Reflexive. reflexivity.
           destruct H7. assert (exists y : elt, Key_In k0 y ((k, e) :: xs)). apply H6.
           exists e0. simpl. left. split. apply Eq_Reflexive. reflexivity. destruct H8.
           simpl in H7. simpl in H8. destruct H7. destruct H8.
           destruct H7. destruct H8. subst. apply H4. split. simpl. left. split. order key.
           reflexivity. simpl. left. split. apply Eq_Reflexive. reflexivity.
            inversion H; subst. apply (All_lt_elem _ (k0, x0) _) in H12. unfold lt in H12.
            order key. apply eq_key_elt_implies_key. apply In_InA_equiv. apply H8.
            inversion H0; subst. apply (All_lt_elem _ (k, x) _) in H12. simpl in H12.
            destruct H8. order key. inversion H; subst. apply (All_lt_elem _ (k0, x0) _) in H14.
            unfold lt in H14. order key. apply eq_key_elt_implies_key. apply In_InA_equiv.
            apply H8. apply eq_key_elt_implies_key. apply In_InA_equiv. apply H7.
      * inversion H; subst. inversion H0; subst. apply IHxs. apply H4. apply H6. intros.
        split.
        -- assert (k == k0 = true). { assert (A:=H1). specialize (H1 k).
              specialize (A k0). destruct H1. destruct H1. destruct A. destruct H8.
              assert (exists z : elt, Key_In k z ((k0, e0) :: ys)). apply H1. exists e.
              simpl. left. split. apply Eq_Reflexive. reflexivity.
              assert (exists y : elt, Key_In k0 y ((k, e) :: xs)). apply H10. exists e0.
              left. split. apply Eq_Reflexive. reflexivity. destruct H11. destruct H12.
              simpl in H11. simpl in H12. destruct H11. order key. destruct H12. order key.
              apply (All_lt_elem _ (k, x0) _ ) in H7. apply (All_lt_elem _ (k0, x1) _ ) in H5.
              unfold lt in *. order key. apply  eq_key_elt_implies_key. apply In_InA_equiv.
              apply H12. apply eq_key_elt_implies_key. apply In_InA_equiv. apply H11. }
              split; intros.
           ++ assert (k < x = true). destruct H3. apply (All_lt_elem _ (x, x0) _) in H5.
              unfold lt in H5. assumption. apply eq_key_elt_implies_key. apply In_InA_equiv.
              apply H3.
              assert (k0 < x = true) by (order key).
              specialize (H1 x). destruct H1. destruct H1.
              assert (exists z : elt, Key_In x z ((k0, e0) :: ys)). apply H1. destruct H3.
              exists x0. simpl. right. assumption. destruct H12. simpl in H12.
              destruct H12. order key. exists x0. assumption.
            ++ assert (k0 < x = true). destruct H3. apply (All_lt_elem _ (x, x0) _) in H7.
                unfold lt in H7. assumption. apply eq_key_elt_implies_key. apply In_InA_equiv.
                apply H3. assert (k < x = true ) by (order key).
                specialize (H1 x). destruct H1. destruct H1.
                assert (exists y : elt, Key_In x y ((k, e) :: xs)). apply H11. destruct H3.
                exists x0. simpl. right. assumption. destruct H12. simpl in H12. destruct H12.
                order key. exists x0. assumption.
          -- intros. specialize (H1 x). destruct H1. apply H3. destruct H2. split.
              ++ simpl. right. assumption.
              ++ simpl. right. assumption.
Qed.

Lemma equal_1: Equivb cmp m m' -> equal cmp m m' = true.
Proof.
  clear.
  intros. unfold equal. unfold Equivb in H. unfold Equiv in H. unfold MapsTo in H.
  unfold Cmp in H. unfold In in H. unfold MapsTo in H. destruct m. destruct m'.
  simpl in *. apply strongly_sorted_cmp_unique. eapply to_List_sorted. apply w.
  eapply to_List_sorted. apply w0. intros. split.
  - setoid_rewrite <- toList_sem_again. destruct H. apply H. apply w. apply w0.
  - intros. destruct H. destruct H0. eapply H1. rewrite toList_sem_again.
    apply H0. apply w. rewrite toList_sem_again. apply H2. apply w0.
Qed.

Lemma eq_list_prop: forall (l: list (key * elt)) l' (cmp: elt -> elt -> bool),
  StronglySorted lt l ->
  StronglySorted lt l' ->
  cmp_list l l' cmp = true ->
  (forall k, (exists v, Key_In k v l) <-> (exists v, Key_In k v l')) /\
  (forall k v v', Key_In k v l /\ Key_In k v' l' -> cmp v v' = true).
Proof.
  clear.
  intros. generalize dependent l'. generalize dependent cmp. induction l; intros.
  - destruct l'.
    + split; intros.
      * simpl. reflexivity.
      * simpl in H2. destruct H2. destruct H2.
    + split; intros.
      * inversion H1.
      * simpl in H2. destruct H2. destruct H2.
  - destruct l'.
    + simpl in H1. destruct a. inversion H1.
    + simpl in H1. destruct a. destruct p. setoid_rewrite andb_true_iff in H1. destruct H1.
      setoid_rewrite andb_true_iff in H1. destruct H1. split; intros.
      * split; intros.
        -- destruct H4. simpl in H4. destruct H4.
           ++ destruct H4. subst. simpl. exists e0. left. split. assert (k == k0 = true). apply elt_eq.
              apply elt_eq in H1. apply H1. order key. reflexivity.
           ++ simpl. apply IHl in H2. destruct H2. assert ((exists v : elt, Key_In k1 v l')).
              apply H2. exists x. assumption. destruct H6. exists x0. right. assumption. inversion H; assumption.
              inversion H0; assumption.
        -- simpl in H4. destruct H4. destruct H4.
           ++ destruct H4. subst. simpl. exists e. left. split. assert (k == k0 = true). apply elt_eq.
              apply elt_eq in H1. apply H1. order key. reflexivity.
           ++ simpl. apply IHl in H2. destruct H2.
              assert (exists v : elt, Key_In k1 v l). apply H2. exists x. assumption. destruct H6.
              exists x0. right. assumption. inversion H; assumption. inversion H0; assumption.
      * simpl in H4. destruct H4. destruct H4.
         -- destruct H5.
            ++ destruct H4. destruct H5. subst. apply H3.
            ++ inversion H0; subst. apply (All_lt_elem _ (k1, v') _) in H9. unfold lt in H9.
               assert (k == k0 = true). apply elt_eq. apply elt_eq in H1. assumption. order key.
               apply eq_key_elt_implies_key. apply In_InA_equiv. apply H5.
          -- inversion H; subst. apply (All_lt_elem _ (k1, v) _) in H9. unfold lt in H9. destruct H5.
             ++ assert (k == k0 = true). apply elt_eq. apply elt_eq in H1. assumption. order key.
             ++ inversion H0; subst. specialize (IHl H8 cmp0 l' H10 H2). destruct IHl.
                eapply H7. split. apply H4. apply H5.
             ++ apply eq_key_elt_implies_key. apply In_InA_equiv. assumption.
Qed.

Lemma equal_2: equal cmp m m' = true -> Equivb cmp m m'.
Proof.
  clear.
  intros. unfold equal in H. unfold Equivb. unfold Cmp. unfold Equiv. unfold In. unfold MapsTo.
  destruct m. destruct m'. simpl in *. apply eq_list_prop in H.
  destruct H. split; intros.
  - specialize (H k). setoid_rewrite toList_sem_again. apply H. apply w. apply w0.
  - eapply H0. setoid_rewrite toList_sem_again in H1. setoid_rewrite toList_sem_again in H2.
    split. apply H1. apply H2. apply w0. apply w.
  - eapply to_List_sorted. apply w.
  - eapply to_List_sorted. apply w0.
Qed.

End Spec.
End Types.

Lemma map_1 :forall (elt elt' : Type) (m: t elt) (x : key) (e : elt) (f: elt -> elt'),
  MapsTo _ x e m -> MapsTo _ x (f e) (map _ _ f m).
Proof.
  intros. unfold MapsTo in *. destruct m. simpl in *. eapply map_Desc.
  apply w. intros. specialize (H2 x). rewrite H in H2. assumption.
Qed.

Lemma map_2: forall (elt elt' : Type) (m : t elt) (x : key) (f : elt -> elt'),
  In _ x (map _ _ f m) -> In _ x m.
Proof.
  intros. unfold In in *. unfold MapsTo in *. destruct m. simpl in *.
  rewrite map_mapWithKey_equiv in H.
  destruct (sem x0 x) eqn : ?.
  - exists e. reflexivity.
  - destruct H. eapply map_none_spec in Heqo. setoid_rewrite H in Heqo. inversion Heqo.
    apply w.
Qed.

(*If sem of the mapped map is Some v, then there was an equivalent (Haskell) key in the
  original map*)
Lemma mapWithKey_reverse: forall (elt elt' : Type) (m: Map key elt) (f: key -> elt -> elt'),
  WF m ->
  (forall i v, sem (mapWithKey f m) i = Some v -> exists i', E.eq i i' /\ exists value, sem m i' = Some value).
Proof.
  intros. generalize dependent f. revert i. revert v. induction H; intros.
  - inversion H0.
  - simpl. simpl in H5. destruct (sem (mapWithKey f s1) i) eqn : ?. inversion H5; subst.
    apply IHBounded1 in Heqo. destruct Heqo. destruct H3. destruct H6. exists i. split. auto.
    exists x1. assert (sem s1 i = Some x1). erewrite sem_resp_eq. apply H6. apply elt_eq. apply H3.
    rewrite H7. reflexivity. eapply map_none_spec in Heqo.
    simpl in H5. destruct (i == x) eqn : ?. simpl in H5. inversion H5. exists x.
    split. apply elt_eq in Heqb. assumption. rewrite Eq_Reflexive. simpl. exists v.
    assert (sem s1 x = None). erewrite sem_resp_eq. apply Heqo. order key. rewrite H6.
    simpl. reflexivity. simpl in H5. exists i. split. auto. apply IHBounded2 in H5.
    destruct H5. destruct H5. destruct H6. exists x1. rewrite Heqo. rewrite Heqb. simpl.
    erewrite sem_resp_eq. apply H6. apply elt_eq. assumption. apply H.
Qed.

Lemma mapi_1: forall (elt elt' : Type) (m: t elt) (x: key) (e: elt) (f: key -> elt -> elt'),
  MapsTo _ x e m -> exists y, E.eq y x /\ MapsTo _ x (f y e) (mapi _ _ f m).
Proof.
  intros. unfold MapsTo in *. destruct m. simpl in *. induction w.
  - inversion H.
  - simpl. simpl in H. destruct (sem s1 x) eqn : ?. simpl in H; inversion H; subst.
    apply IHw1 in H. destruct H. exists x1. destruct H. split. assumption. rewrite H2. simpl. reflexivity.
    simpl in H. destruct (x == x0) eqn : ?. exists x0. split. apply elt_eq in Heqb. auto.
    simpl in H. inversion H; subst. apply (map_none_spec f s1 lb (Some x0)) in Heqo. rewrite Heqo. simpl. reflexivity.
    apply w1. simpl in H. apply IHw2 in H. destruct H. destruct H. exists x1. split.
    auto. apply (map_none_spec f s1 lb (Some x0)) in Heqo. rewrite Heqo. simpl. apply H4. apply w1.
Qed.

Lemma mapi_2: forall (elt elt' : Type) (m: t elt) (x : key) (f: key -> elt -> elt'),
  In _ x (mapi _ _ f m) -> In _ x m.
Proof.
  intros. unfold In in *. unfold MapsTo in *. destruct m. simpl in *. destruct H.
  apply mapWithKey_reverse in H. destruct H. destruct H. destruct H0. exists x3.
  erewrite sem_resp_eq. apply H0. apply elt_eq. apply H. apply w.
Qed.

(*For [map2], there are a lot of lemmas to prove. First, we further split map2_map into two functions
  (proving equivalence) so we can prove things about each of them. This gets a bit redundant, but
  ultimately we want to prove that if a key is is 1 of the two maps, then k, f (sem m1 k) (sem m2 k)
  is in the resulting map, and if it is in neither maps, then k is not in the resulting map *)

Definition map2_map_part1 (elt elt' elt'' : Type) (m1: Map key elt) (m2: Map key elt')
  (f: option elt -> option elt' -> option elt'') :
  Map key (option elt'') :=
  mapWithKey (fun k v => f (sem m1 k) (sem m2 k)) m1.

Definition map2_map_part2 (elt elt' elt'' : Type) (m1: Map key elt) (m2: Map key elt')
  (f: option elt -> option elt' -> option elt'') :
  Map key (option elt'') :=
  mapWithKey (fun k v => f (sem m1 k) (sem m2 k)) m2.

Definition map2_map_alt (elt elt' elt'' : Type) (m1: Map key elt) (m2: Map key elt')
  (f: option elt -> option elt' -> option elt'') : Map key (option elt'') :=
  union (map2_map_part1 _ _ _ m1 m2 f) (map2_map_part2 _ _ _ m1 m2 f).

Lemma map2_map_equiv: forall (elt elt' elt'' : Type) (m1: Map key elt) (m2: Map key elt')
  (f: option elt -> option elt' -> option elt''),
  map2_map _ _ _ m1 m2 f = map2_map_alt _ _ _ m1 m2 f.
Proof.
  intros. unfold map2_map. unfold map2_map_alt. unfold map2_map_part1.
  unfold map2_map_part2. reflexivity.
Qed.

Lemma map2_map_part_1_in : forall (elt elt' elt'' : Type)(m: Map key elt) (m': Map key elt') (x: key)
  (f: option elt -> option elt' -> option elt''),
  WF m ->
  WF m' ->
  (exists v, sem m x = Some v) ->
  sem (map2_map_part1 _ _ _ m m' f) x = Some (f (sem m x) (sem m' x)).
Proof.
  intros. destruct H1. unfold map2_map_part1. erewrite map_spec_coq.
  - reflexivity.
  - apply H.
  - unfold respectful. unfold Proper. intros. assert (sem m x1 = sem m y). {
    apply sem_resp_eq. assumption. }
    assert (sem m' x1 = sem m' y). { apply sem_resp_eq. assumption. }
    rewrite H3. rewrite H4. reflexivity.
  - apply H1.
Qed.

Lemma map2_map_part_1_notin : forall (elt elt' elt'' : Type)(m: Map key elt) (m': Map key elt') (x: key)
  (f: option elt -> option elt' -> option elt''),
  WF m ->
  WF m' ->
  sem m x = None ->
  sem m' x = None ->
  sem (map2_map_part1 _ _ _ m m' f) x = None.
Proof.
  intros. unfold map2_map_part1. apply (map_none_spec (fun k e => f (sem m k)  (sem m' k)) m None None).
  apply H. apply H1.
Qed.

(*See if I can cut down on repetition*)
Lemma map2_map_part_2_in : forall (elt elt' elt'' : Type)(m: Map key elt) (m': Map key elt') (x: key)
  (f: option elt -> option elt' -> option elt''),
  WF m ->
  WF m' ->
  (exists v, sem m' x = Some v) ->
  sem (map2_map_part2 _ _ _ m m' f) x = Some (f (sem m x) (sem m' x)).
Proof.
  intros. destruct H1. unfold map2_map_part2. erewrite map_spec_coq.
  - reflexivity.
  - apply H0.
  - intros. unfold respectful. unfold Proper. intros. assert (sem m x1 = sem m y). { apply sem_resp_eq. assumption. }
    assert (sem m' x1 = sem m' y). { apply sem_resp_eq. assumption. }
    rewrite H4. rewrite H3. reflexivity.
  - apply H1.
Qed.

Lemma map2_map_part_2_notin : forall (elt elt' elt'' : Type)(m: Map key elt) (m': Map key elt') (x: key)
  (f: option elt -> option elt' -> option elt''),
  WF m ->
  WF m' ->
  sem m x = None ->
  sem m' x = None ->
  sem (map2_map_part2 _ _ _ m m' f) x = None.
Proof.
  intros. unfold map2_map_part2. apply (map_none_spec (fun k e => f (sem m k)  (sem m' k)) m' None None).
  apply H0. apply H2.
Qed.

(*Putting the parts together*)

Lemma map2_map_in: forall (elt elt' elt'' : Type)(m: Map key elt) (m': Map key elt') (x: key)
  (f: option elt -> option elt' -> option elt'') x,
  WF m ->
  WF m' ->
  (exists v, sem m x = Some v) \/ (exists v, sem m' x = Some v) ->
  sem (map2_map _ _ _ m m' f) x = Some (f (sem m x) (sem m' x)).
Proof.
  intros. rewrite map2_map_equiv. unfold map2_map_alt.
  erewrite sem_union_equiv. unfold sem_union.
  destruct H1.
  - pose proof (map2_map_part_1_in _ _ _ _ _ _ f H H0 H1).
    rewrite H2. reflexivity.
  - pose proof (map2_map_part_2_in _ _ _ _ _ _ f H H0 H1).
    rewrite H2. destruct (sem m x0) eqn : ?.
    + assert (exists v, sem m x0 = Some v). exists e. assumption.
      pose proof (map2_map_part_1_in _ _ _ _ _ _ f H H0 H3). rewrite H4.
      rewrite Heqo. reflexivity.
    + assert (sem (map2_map_part1 elt0 elt' elt'' m m' f) x0 = None).
      unfold map2_map_part1. rewrite <- map_none_spec. apply Heqo. apply H.
      rewrite H3. reflexivity.
  - unfold map2_map_part1. apply mapWithKey_pres_WF. apply H.
  - unfold map2_map_part2. apply mapWithKey_pres_WF. apply H0.
Qed.

Lemma map2_map_notin: forall (elt elt' elt'' : Type)(m: Map key elt) (m': Map key elt') (x: key)
  (f: option elt -> option elt' -> option elt'') x,
  WF m ->
  WF m' ->
  sem m x = None /\ sem m' x = None ->
  sem (map2_map _ _ _ m m' f) x = None.
Proof.
  intros. rewrite map2_map_equiv. unfold map2_map_alt. erewrite sem_union_equiv.
  unfold sem_union. destruct H1.
  assert (sem (map2_map_part1 elt0 elt' elt'' m m' f) x0 = None). {
  apply map2_map_part_1_notin; assumption. }
  assert (sem (map2_map_part2 elt0 elt' elt'' m m' f) x0 = None). {
  apply map2_map_part_2_notin; assumption. }
  rewrite H3. rewrite H4. reflexivity.
  unfold map2_map_part1. apply mapWithKey_pres_WF. apply H.
  unfold map2_map_part2. apply mapWithKey_pres_WF. apply H0.
Qed.

(*Some lemmas and ltac to prove that any m such that Bounded m lb ub is well formed*)

Lemma expand_bounds_l : forall (a : Type) (m: Map key a) lb x,
  Bounded m lb x ->
  Bounded m None x.
Proof.
  intros. induction H.
  - constructor.
  - constructor; try (reflexivity); try (assumption).
Qed.

Lemma expand_bounds_r : forall (a : Type) (m: Map key a) ub x,
  Bounded m x ub ->
  Bounded m x None.
Proof.
  intros. induction H.
  - constructor.
  - constructor; try (reflexivity); try (assumption).
Qed.

Ltac wf_bounds:= eapply expand_bounds_l; eapply expand_bounds_r; eassumption.

(*Several helper lemmas for map2_fix. We need extremely strong claims to get a general enough
  hypothesis, necessitating lots of extra lemmas. This states that if the base map and the folded map
  both do not contain a key, then the result will not contain it either*)

Lemma map2_fix_none: forall (elt'' : Type) (m: Map key (option elt'')) m' x,
  WF m ->
  WF m' ->
  sem m' x = None ->
  sem m x = None ->
  sem (map2_fix _ m m') x = None.
Proof.
  intros. generalize dependent m'. induction H; intros.
  - simpl. assumption.
  - simpl in H2. simpl. destruct (sem s1 x) eqn : ?. inversion H2.
    destruct (x == x0) eqn : ?. inversion H2. destruct (sem s2 x) eqn : ?.
    inversion H2. apply IHBounded1.
    + reflexivity.
    + destruct v. apply insert_WF. apply map2_fix_pres_wf. wf_bounds. assumption.
      apply map2_fix_pres_wf. wf_bounds. assumption.
    + destruct v.
      * erewrite sem_insert. rewrite Heqb. simpl. apply IHBounded2. assumption.
        assumption. assumption. apply map2_fix_pres_wf. wf_bounds. assumption.
        reflexivity. reflexivity.
      * apply IHBounded2. reflexivity. assumption. assumption.
Qed.

(*If a key is not in the folded map, but it maps to y in the base, then it maps to y in the
  result map. Note that map2 defines the base as Tip, so the premise of this is always false for
  map2. But it is necessary to prove other lemmas*)
Lemma map2_fix_base: forall (elt'' : Type)(m: Map key (option elt'')) m' (x: key) y,
  WF m ->
  WF m' ->
  sem m x = None  ->
  sem m' x = (Some y) <->
  sem (map2_fix _ m m') x = Some y.
Proof.
  intros. generalize dependent m'. induction H; intros; split; intros.
  - simpl. assumption.
  - simpl in H. assumption.
  - simpl. simpl in H1. destruct (sem s1 x) eqn : ?. inversion H1. destruct (x == x0) eqn : ?.
    inversion H1. destruct (sem s2 x) eqn : ?. inversion H1. destruct v.
    + eapply insert_Desc. apply map2_fix_pres_wf. wf_bounds. assumption. reflexivity.
      reflexivity. intros. specialize (H10 x). rewrite Heqb in H10. simpl in H10.
      rewrite <- IHBounded1. rewrite H10. rewrite <- IHBounded2. assumption.
      reflexivity. assumption. reflexivity. assumption.
    + rewrite  <- IHBounded1. rewrite <- IHBounded2. assumption. reflexivity. assumption.
      reflexivity. apply map2_fix_pres_wf. wf_bounds. assumption.
  - simpl in H1. destruct (sem s1 x) eqn : ?. inversion H1. destruct (x == x0) eqn : ?.
    inversion H1. destruct (sem s2 x) eqn : ?. inversion H1.
    simpl in H7. destruct v. rewrite <- IHBounded1 in H7.
    erewrite sem_insert in H7. rewrite Heqb in H7. simpl in H7. apply IHBounded2.
    reflexivity. assumption. assumption. apply map2_fix_pres_wf. wf_bounds. assumption.
    reflexivity. reflexivity. reflexivity. apply insert_WF. apply map2_fix_pres_wf.
    wf_bounds. assumption. rewrite <- IHBounded1 in H7. apply IHBounded2.
    reflexivity. assumption. assumption. reflexivity. apply map2_fix_pres_wf.
    wf_bounds. assumption.
Qed.

(*The main helper lemma: If a key is not in the base map but it maps to (Some (Some y)) in the map
  we are folding over, then it maps to (Some y) in the result*)
Lemma map2_fix_some: forall (elt'' : Type)(m: Map key (option elt'')) m' (x: key) y,
  WF m ->
  WF m' ->
  sem m' x = None ->
  sem m x = Some (Some y) <-> sem (map2_fix _ m m') x = Some y.
Proof.
  intros. revert y. generalize dependent m'. induction H; split; intros.
  - inversion H.
  - inversion H. rewrite H3 in H1. inversion H1.
  - simpl in H7. simpl. destruct (sem s1 x) eqn : ?.
    + simpl in H7. rewrite <- IHBounded1. apply H7. destruct v. apply insert_WF.
      apply map2_fix_pres_wf. wf_bounds. apply H5. eapply map2_fix_pres_wf. wf_bounds. apply H5.
      assert (x < x0 = true). { eapply (sem_inside H) in Heqo. destruct Heqo. unfold isUB in *.
      assumption. } assert (sem s2 x = None). { eapply sem_outside_below. apply H0. unfold isLB.
      order key. } destruct v.
      * erewrite sem_insert. assert (x == x0 = false) by (order key). rewrite H10. simpl.
        apply map2_fix_none. wf_bounds. assumption. assumption. assumption. apply map2_fix_pres_wf.
        wf_bounds. assumption. reflexivity. reflexivity.
      * apply map2_fix_none. wf_bounds. assumption. assumption. assumption.
    + simpl in H7. destruct (x == x0) eqn : ?.
      * inversion H7. eapply insert_Desc. apply map2_fix_pres_wf. wf_bounds. assumption.
        reflexivity. reflexivity. intros. specialize (H11 x). simpl in H7. inversion H7.
        rewrite Heqb in H11. simpl in H11. eapply map2_fix_base in H11. apply H11.
        wf_bounds. assumption. assumption.
      * simpl in H7. destruct v.
        -- eapply insert_Desc. apply map2_fix_pres_wf. wf_bounds. assumption. reflexivity.
          reflexivity. intros. specialize (H10 x). rewrite Heqb in H10. simpl in H10.
          apply map2_fix_base. wf_bounds. assumption. assumption. rewrite H10. apply IHBounded2.
          assumption. assumption. assumption.
        -- apply map2_fix_base. wf_bounds. apply map2_fix_pres_wf. wf_bounds. assumption.
          assumption. apply IHBounded2. assumption. assumption. assumption.
  - simpl in H7. simpl. destruct v.
    + destruct (sem (insert x0 e (map2_fix elt'' s2 m')) x) eqn : ?.
      * setoid_rewrite sem_insert in Heqo. destruct (x == x0) eqn : ?.
        -- simpl. assert (sem s1 x = None). eapply sem_outside_above. eassumption.
            unfold isUB. order key. rewrite H8. simpl. simpl in Heqo.
            apply map2_fix_base in H7. erewrite sem_insert in H7.
            rewrite Heqb in H7. inversion H7. reflexivity.
            apply map2_fix_pres_wf. wf_bounds. assumption. reflexivity.
            reflexivity. wf_bounds. apply insert_WF. apply map2_fix_pres_wf.
            wf_bounds. assumption. assumption.
          -- simpl. simpl in Heqo. rewrite oro_None_r. apply map2_fix_base in H7.
            erewrite sem_insert in H7. rewrite Heqb in H7. simpl in H7. rewrite Heqo in H7.
            inversion H7. rewrite H9 in Heqo. rewrite <- IHBounded2 in Heqo.
            rewrite Heqo. assert (sem s1 x = None). eapply sem_outside_above.
            eassumption. unfold isUB. apply (sem_inside H0) in Heqo.
            destruct Heqo. unfold isLB in H8. order key. rewrite H8. reflexivity.
            assumption. assumption. apply map2_fix_pres_wf. wf_bounds. assumption.
            reflexivity. reflexivity. wf_bounds. apply insert_WF.
            apply map2_fix_pres_wf. wf_bounds. assumption. rewrite <- IHBounded2 in Heqo.
            eapply sem_outside_above. eassumption. unfold isUB. apply (sem_inside H0) in Heqo.
            destruct Heqo. unfold isLB in H9. order key. assumption. assumption.
          -- apply map2_fix_pres_wf. wf_bounds. assumption.
          -- reflexivity.
          -- reflexivity.
      * rewrite <- IHBounded1 in H7. rewrite H7. reflexivity. apply insert_WF.
        apply map2_fix_pres_wf. wf_bounds. assumption. assumption.
   + destruct (sem (map2_fix elt'' s2 m') x) eqn : ?.
     * rewrite <- map2_fix_base in H7. rewrite <- IHBounded2 in H7.
       rewrite H7. assert (x > x0 = true). apply (sem_inside H0) in H7.
       destruct H7. unfold isLB in H7. order key. assert (sem s1 x = None).
       eapply sem_outside_above. eassumption. unfold isUB. order key. rewrite H9.
       assert (x == x0 = false) by (order key). rewrite H10. simpl. reflexivity.
       assumption. assumption. wf_bounds. apply map2_fix_pres_wf. wf_bounds.
       assumption. rewrite <- IHBounded2 in Heqo. eapply sem_outside_above.
       eassumption. unfold isUB. apply (sem_inside H0) in Heqo. destruct Heqo.
        unfold isLB in H8. order key. assumption. assumption.
     * rewrite <- IHBounded1 in H7. rewrite H7. reflexivity. apply map2_fix_pres_wf.
      wf_bounds. assumption. assumption.
Qed.

(*Finally, if the key is not in the base but it maps to Some None in the source map, then it
  does not appear in the output*)
Lemma map2_fix_some_none: forall (elt'' : Type)(m: Map key (option elt'')) m' (x: key),
  WF m ->
  WF m' ->
  sem m' x = None ->
  sem m x = Some None -> sem (map2_fix _ m m') x = None.
Proof.
  intros. generalize dependent m'. induction H; intros.
  - simpl. assumption.
  - simpl in H2. simpl. destruct (sem s1 x) eqn : ?.
    + assert (x < x0 = true). { apply (sem_inside H) in Heqo. destruct Heqo.
      unfold isUB in H9. assumption. }
      inversion H2. rewrite IHBounded1. subst. reflexivity. subst. reflexivity.
      destruct v.  apply insert_WF. apply map2_fix_pres_wf. wf_bounds. assumption.
      apply map2_fix_pres_wf. wf_bounds. assumption. destruct v.
       erewrite sem_insert.
      assert (x == x0 = false) by (order key). rewrite H9. simpl.
      apply map2_fix_none. wf_bounds. assumption. assumption.
      eapply sem_outside_below. eassumption. unfold isLB. order key.
      apply map2_fix_pres_wf. wf_bounds. assumption. reflexivity. reflexivity.
      apply map2_fix_none. wf_bounds. assumption. assumption.
      eapply sem_outside_below. eassumption. unfold isLB. order key.
    + simpl in H2. destruct (x == x0) eqn : ?.
      * simpl in H2. inversion H2. apply map2_fix_none. wf_bounds. apply map2_fix_pres_wf.
        wf_bounds. assumption. apply map2_fix_none. wf_bounds. assumption. assumption.
        eapply sem_outside_below. eassumption. unfold isLB. order key.
        eapply sem_outside_above. eassumption. unfold isUB. order key.
      * simpl in H2. assert (x > x0 = true). { apply (sem_inside H0) in H2. destruct H2.
        unfold isLB in H2. order key. } apply map2_fix_none. wf_bounds.
        destruct v. apply insert_WF. apply map2_fix_pres_wf. wf_bounds. assumption.
        apply map2_fix_pres_wf. wf_bounds. assumption. destruct v.
        erewrite sem_insert. rewrite Heqb. simpl. apply IHBounded2. assumption.
        assumption. assumption. apply map2_fix_pres_wf. wf_bounds. assumption.
        reflexivity. reflexivity. apply IHBounded2. assumption. assumption.
        assumption. assumption.
Qed.

(*Finally, we can prove the properties we want.*)

Lemma map2_1: forall (elt elt' elt'' : Type) (m : t elt) (m': t elt') (x: key)
  (f: option elt -> option elt' -> option elt''),
  In _ x m \/ In _ x m' -> find _ x (map2 _ _ _ f m m') = f (find _ x m) (find _ x m').
Proof.
  intros. unfold find. unfold In in *. unfold MapsTo in *. destruct m. destruct m'. simpl in *.
  erewrite lookup_spec. erewrite lookup_spec. erewrite lookup_spec.
  - apply (map2_map_in elt0 elt' elt'' _ _ x f) in H. destruct (f (sem x0 x) (sem x1 x)) eqn : ?.
    + assert (exists e, sem (map2_map elt0 elt' elt'' x0 x1 f) x = Some (Some e)). { exists e.
      apply H. } rewrite Heqo. rewrite <- (map2_fix_some elt'' _ Tip x).
      * apply H.
      * apply map2_map_wf; assumption.
      * constructor.
      * reflexivity.
    + rewrite Heqo. apply map2_fix_some_none.
      * apply map2_map_wf; assumption.
      * constructor.
      * reflexivity.
      * assumption.
    + assumption.
    + assumption.
  - apply w0.
  - apply w.
  - apply map2_fix_pres_wf. apply map2_map_wf. assumption. assumption. constructor.
Qed.

Lemma map2_2: forall (elt elt' elt'' : Type) (m: t elt) (m': t elt') (x: key) (f: option elt ->
  option elt' -> option elt''),
  In _ x (map2 _ _ _ f m m') -> In _ x m \/ In _ x m'.
Proof.
  intros. unfold In in *. unfold MapsTo in *. destruct m. destruct m'. simpl in *.
  destruct (sem x0 x) eqn : ?. left. exists e. reflexivity.
  destruct (sem x1 x) eqn : ?. right. exists e. reflexivity. destruct H.
  rewrite <- map2_fix_base in H. inversion H. apply map2_map_wf; assumption.
  constructor. apply map2_map_notin. apply x. apply w. apply w0. split; assumption.
Qed.

Section Elt'.

Variable elt: Type.

Definition lt_key (p p': key * elt) := E.lt (fst p) (fst p').

(*These two definitions of lt can only be proved equivalent by functional extensionality,
so instead we prove that if sorted by 1, it is sorted by the other*)
Lemma lt_lt_key_sort: forall (l: list (key * elt)),
  StronglySorted (lt elt) l ->
  StronglySorted lt_key l.
Proof.
  intros. unfold lt in *. unfold lt_key. induction H; subst.
  - constructor.
  - constructor. apply IHStronglySorted. destruct a. simpl.
    induction H0.
    + constructor.
    + constructor. destruct x. simpl. apply elt_lt in H0. apply H0.
      apply IHForall. inversion H; subst. apply H4. inversion IHStronglySorted; subst.
      apply H4.
Qed.

Lemma elements_3:  forall (m : t elt), sort lt_key (elements _ m).
Proof.
  intros. apply StronglySorted_Sorted. unfold elements. apply lt_lt_key_sort.
  destruct m. simpl. eapply to_List_sorted. apply w.
Qed.
End Elt'.
End MapFMap.


(*
This exercise introduces the basic Iris Proof Mode tactics by proving a simple
example: a function that swaps the contents of two pointers. We will use this
function to implement two other functions.
*)
From iris.heap_lang Require Import proofmode notation.

(* The swap function, defined as a heap-lang value. This looks like an ordinary
Coq function, but it is not: heap-lang is a deeply embedded language in Coq. It
uses strings for name binding and notations close to Coq's (but typically
augmented with a colon to avoid ambiguity) to make it easy to read and write
programs. *)
Definition swap : val := λ: "x" "y",
  let: "tmp" := !"x" in
  "x" <- !"y";;
  "y" <- "tmp".

(* Using swap, we can define functions that rotate three pointers in left and
right direction. *)
Definition rotate_r : val := λ: "x" "y" "z",
  swap "y" "z";; swap "x" "y".

Definition rotate_l : val := λ: "x" "y" "z",
  swap "x" "y";; swap "y" "z".

Section proof.
(* Iris is parameterized by the type of ghost state that is needed to carry out
a proof. As such, the type of Iris propositions [iProp] is indexed by a [Σ]: a
list of cameras (actually, functors from OFEs to cameras). To make our proofs
generic, we abstract over any such [Σ] and use type classes to ensure that the
necessary cameras are present in [Σ].

For this proof, we do not need any special ghost state (i.e. cameras) apart from
the ghost state that's the heap-lang uses internally for modeling the [l ↦ v]
connective. The cameras for this ghost state is provided by the class [heapG].
*)
Context `{!heapG Σ}.

Lemma swap_spec x y v1 v2 :
  {{{ x ↦ v1 ∗ y ↦ v2 }}} swap #x #y {{{ RET #(); x ↦ v2 ∗ y ↦ v1 }}}.

  (* The "Texan triple" [ {{{ P }}} e {{{ RET v, Q }}} ] is syntactic sugar for:

         ∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e {{ v, Φ v }}

     Which is logically equivalent to [ P -∗ WP e {{ x, x = v ∗ Q }} ]

     In practice, the "Texan triple" is not more difficult to prove, but usually
     easier to use in other proofs, because the post-condition does not have to
     syntactically match [Q]. Using this way of stating specifications, the
     consequence and framing rule is implicitly applied on the post-condition.

     Note that [ # v ] is the embedding of values ([bool], [Z], [loc]) into
     heap-lang values.*)
Proof.
  iIntros (Φ) "[Hx Hy] Post".
  unfold swap.
  wp_lam. wp_let.
  wp_load. wp_let.
  wp_load. wp_store.
  wp_store.
  iApply "Post".
  iSplitL "Hx".
  - iApply "Hx".
  - iApply "Hy".
Qed.

(* Same lemma, but using a bit of automation to shorten the proof. *)
Lemma swap_spec_2 x y v1 v2 :
  {{{ x ↦ v1 ∗ y ↦ v2 }}} swap #x #y {{{ RET #(); x ↦ v2 ∗ y ↦ v1 }}}.
Proof.
  iIntros (Φ) "[??] Post".
  wp_lam. wp_let. wp_load. wp_let. wp_load. wp_store. wp_store.
  iApply "Post". iFrame. done.
Qed.

(* We can further automate the lemma by defining a simple Ltac tactic for
symbolic executing. *)
Ltac wp_exec := repeat (wp_lam || wp_pure _ || wp_load || wp_store).

(* This tactic repeatedly tries to symbolically execute pure redexes, loads and
stores. It makes use of the tactic [wp_pure t], which tries to find the redex
[t] in the goal, and executes that redex. The redex [t] may contain holes, and
as such, tactics like [wp_seq] are actually defined as [wp_pure (_ ;; _)%E]. By
using [wp_pure _] it will symbolically execute *any* pure redex. *)

(* Same lemma again, but now using the tactic we just defined. *)
Lemma swap_spec_2_more_automation x y v1 v2 :
  {{{ x ↦ v1 ∗ y ↦ v2 }}} swap #x #y {{{ RET #(); x ↦ v2 ∗ y ↦ v1 }}}.
Proof.
  iIntros (Φ) "[??] Post". wp_exec.
  iApply "Post". iFrame. done.
Qed.

Lemma rotate_r_spec x y z v1 v2 v3 :
  {{{ x ↦ v1 ∗ y ↦ v2 ∗ z ↦ v3 }}}
    rotate_r #x #y #z
  {{{ RET #(); x ↦ v3 ∗ y ↦ v1 ∗ z ↦ v2 }}}.
Proof.
  (* As in Coq, the IPM introduction pattern (p1 & p2 & .. & pn) ] is syntactic
  sugar for [ [p1 [p2 [... pn]]] ]. *)
  iIntros (Φ) "(Hx & Hy & Hz) Post".
  unfold rotate_r. wp_lam. do 2 wp_let.
  wp_bind (swap _ _).
  iApply (swap_spec with "[Hy Hz]").
  { iFrame. }
  (* Inspired by ssreflect, the IPM introduction pattern [ /= ] performs
  [simpl]. *)
  iNext. iIntros "[Hy Hz] /=". wp_seq.
  (* We can also immediately frame hypothesis when using a lemma: *)
  iApply (swap_spec with "[$Hx $Hy]"); iNext; iIntros "[Hx Hy]".
  iApply "Post". iFrame.
Qed.

Lemma rotate_r_spec_again x y z v1 v2 v3 :
  {{{ x ↦ v1 ∗ y ↦ v2 ∗ z ↦ v3 }}}
    rotate_r #x #y #z
  {{{ RET #(); x ↦ v3 ∗ y ↦ v1 ∗ z ↦ v2 }}}.
Proof.
  iIntros (Φ) "(Hx & Hy & Hz) Post". wp_lam. do 2 wp_let.
  (* We can shorten the above a bit: Instead of using the [iApply] tactic, we
  can use [wp_apply] which automatically uses [wp_bind] first. Also, it strips
  the later [▷] by calling [iNext] afterwards. *)
  wp_apply (swap_spec with "[$Hy $Hz]"); iIntros "[Hy Hz] /="; wp_seq.
  wp_apply (swap_spec with "[$Hx $Hy]"); iIntros "[Hx Hy] /=".
  iApply "Post". iFrame.
Qed.

(* *Exercise*: Do this proof yourself. Try a couple of variations of the tactics
we have seen before:
- Do the whole proof explicitly by proving [swap] inline,
- Use the specification of [swap] in combination with [iApply],
- Use the specification of [swap] in combination with [wp_apply]
*)
Lemma rotate_l_spec x y z v1 v2 v3 :
  {{{ x ↦ v1 ∗ y ↦ v2 ∗ z ↦ v3 }}}
    rotate_l #x #y #z
  {{{ RET #(); x ↦ v2 ∗ y ↦ v3 ∗ z ↦ v1 }}}.
(* SOLUTION *) Proof.
  iIntros (Φ) "(Hx & Hy & Hz) Post". unfold rotate_l. wp_lam. do 2 wp_let.
  wp_apply (swap_spec with "[$Hx $Hy]"); iIntros "[Hx Hy]"; wp_seq.
  wp_apply (swap_spec with "[$Hy $Hz]"); iIntros "[Hy Hz]".
  iApply ("Post" with "[$]").
Qed.
End proof.


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** Lattice constructor: sum of two mem.  *)

Set Implicit Arguments.

Require Import ZArith.
Require Import Setoid.
Require Import Morphisms.
Require Import hpattern vgtac.
Require Import TStr VocabA DLat DFSetAVL.
Require Import DMap DPow.

Module Make (A : KEY) (B : LAT) (PowA : DPow.POW A) <: LAT.

Include Map A B.

Definition subtract (ls : PowA.t) (x : t) :=
  filter (fun k => negb (PowA.mem k ls)) x.

Lemma subtract_1 :
  forall k ls x (Hmem : PowA.mem k ls = true),
    B.eq (find k (subtract ls x)) B.bot.
Proof.
unfold subtract. i. apply filter_2; [|by rewrite Hmem].
intros l1 l2 Hl. f_equal. apply PowA.mem_mor; [by auto|by apply PowA.eq_refl].
Qed.

Lemma subtract_2 :
  forall k ls x (Hmem : PowA.mem k ls = false),
    B.eq (find k (subtract ls x)) (find k x).
Proof.
unfold subtract. i. apply filter_1; [|by rewrite Hmem].
intros l1 l2 Hl. f_equal. apply PowA.mem_mor; [by auto|by apply PowA.eq_refl].
Qed.

Lemma subtract_mor' :
  forall ls, Proper (le ==> le) (subtract ls).
Proof.
unfold subtract; intros ls m1 m2 Hm k.
apply find_mor'; [by apply A.eq_refl|].
apply filter_mor'; [|by auto].
intros l1 l2 Hl. f_equal.
apply PowA.mem_mor; [by auto|by apply PowA.eq_refl].
Qed.

Lemma subtract_mor :
  forall ls, Proper (eq ==> eq) (subtract ls).
Proof.
unfold subtract; intros ls m1 m2 Hm k.
apply find_mor; [by apply A.eq_refl|].
apply filter_mor; [|by auto].
intros l1 l2 Hl. f_equal.
apply PowA.mem_mor; [by auto|by apply PowA.eq_refl].
Qed.

Lemma subtract_mor'_spec :
  forall k ls x y (Hle : B.le (find k x) (find k y)),
    B.le (find k (subtract ls x)) (find k (subtract ls y)).
Proof.
unfold subtract; i.
remember (negb (PowA.mem k ls)) as b; destruct b.
- eapply B.le_trans; [eapply B.le_trans; [|by apply Hle]|].
  + apply B.le_refl; apply filter_1; [|by auto].
    intros l1 l2 Hl; f_equal.
    apply PowA.mem_mor; [by auto|by apply PowA.eq_refl].
  + apply B.le_refl; apply B.eq_sym; apply filter_1; [|by auto].
    intros l1 l2 Hl; f_equal.
    apply PowA.mem_mor; [by auto|by apply PowA.eq_refl].
- apply B.le_trans with B.bot; [|by apply B.bot_prop].
  apply B.le_refl; apply filter_2; [|by auto].
  intros l1 l2 Hl; f_equal.
  apply PowA.mem_mor; [by auto|by apply PowA.eq_refl].
Qed.

Lemma subtract_in :
  forall k ls x (Hin : M.In k (subtract ls x)), PowA.mem k ls = false.
Proof.
unfold subtract, filter, M.filter; i.
apply find_mapsto in Hin.
apply M.P.filter_iff in Hin.
- destruct Hin as [Hmaps Hmem].
  by apply Bool.negb_true_iff in Hmem.
- unfold Proper, respectful; i; f_equal.
  apply PowA.mem_mor; [by auto|by apply PowA.eq_refl].
Qed.

Definition restrict (ls : PowA.t) (x : t) := filter (fun k => PowA.mem k ls) x.

Lemma restrict_1 :
  forall k ls x (Hmem : PowA.mem k ls = true),
    B.eq (find k (restrict ls x)) (find k x).
Proof.
unfold restrict. i. apply filter_1; [|by rewrite Hmem].
intros l1 l2 Hl. apply PowA.mem_mor; [by auto|by apply PowA.eq_refl].
Qed.

Lemma restrict_2 :
  forall k ls x (Hmem : PowA.mem k ls = false),
    B.eq (find k (restrict ls x)) B.bot.
Proof.
unfold restrict. i. apply filter_2; [|by rewrite Hmem].
intros l1 l2 Hl. apply PowA.mem_mor; [by auto|by apply PowA.eq_refl].
Qed.

Lemma restrict_mor' :
  forall ls, Proper (le ==> le) (restrict ls).
Proof.
unfold restrict; intros ls m1 m2 Hm k.
apply find_mor'; [by apply A.eq_refl|].
apply filter_mor'; [|by auto].
intros l1 l2 Hl. apply PowA.mem_mor; [by auto|by apply PowA.eq_refl].
Qed.

Lemma restrict_mor :
  forall ls, Proper (eq ==> eq) (restrict ls).
Proof.
unfold restrict; intros ls m1 m2 Hm k.
apply find_mor; [by apply A.eq_refl|].
apply filter_mor; [|by auto].
intros l1 l2 Hl.
apply PowA.mem_mor; [by auto|by apply PowA.eq_refl].
Qed.

Lemma restrict_mor'_spec :
  forall k ls x y (Hle : B.le (find k x) (find k y)),
    B.le (find k (restrict ls x)) (find k (restrict ls y)).
Proof.
unfold restrict; i.
remember (PowA.mem k ls) as b; destruct b.
- eapply B.le_trans; [eapply B.le_trans; [|by apply Hle]|].
  + apply B.le_refl; apply filter_1; [|by auto].
    intros l1 l2 Hl.
    apply PowA.mem_mor; [by auto|by apply PowA.eq_refl].
  + apply B.le_refl; apply B.eq_sym; apply filter_1; [|by auto].
    intros l1 l2 Hl.
    apply PowA.mem_mor; [by auto|by apply PowA.eq_refl].
- apply B.le_trans with B.bot; [|by apply B.bot_prop].
  apply B.le_refl; apply filter_2; [|by auto].
  intros l1 l2 Hl.
  apply PowA.mem_mor; [by auto|by apply PowA.eq_refl].
Qed.

Lemma restrict_in :
  forall k ls x (Hin : M.In k (restrict ls x)), PowA.mem k ls = true.
Proof.
unfold restrict, filter, M.filter; i.
apply find_mapsto in Hin.
apply M.P.filter_iff in Hin.
- destruct Hin as [Hmaps Hmem]; by auto.
- unfold Proper, respectful; i.
  apply PowA.mem_mor; [by auto|by apply PowA.eq_refl].
Qed.

Lemma powa_mem_mor (ls : PowA.t) :
  Proper (A.eq ==> Logic.eq) (fun k => PowA.mem k ls).
Proof.
intros l1 l2 Hl. apply PowA.mem_mor; [by auto | by apply PowA.eq_refl].
Qed.

Lemma negb_powa_mem_mor (ls : PowA.t) :
  Proper (A.eq ==> Logic.eq) (fun k => negb (PowA.mem k ls)).
Proof.
intros l1 l2 Hl. f_equal.
apply PowA.mem_mor; [by auto | by apply PowA.eq_refl].
Qed.

Lemma restrict_subtract_1 :
  forall ls m, eq m (join (restrict ls m) (subtract ls m)).
Proof.
unfold eq; i.
eapply B.eq_trans; [|apply B.eq_sym; apply join_find].
remember (PowA.mem k ls) as b; destruct b; symmetry in Heqb.
- eapply B.eq_trans; [|by apply B.join_comm_eq].
  eapply B.eq_trans; [|apply B.join_le_idem].
  + apply B.eq_sym; by apply restrict_1.
  + apply B.le_trans with (find k m).
    * unfold subtract. apply filter_le. by apply negb_powa_mem_mor.
    * apply B.le_refl; apply B.eq_sym. by apply restrict_1.
- eapply B.eq_trans; [|apply B.join_le_idem].
  + apply B.eq_sym. by apply subtract_2.
  + apply B.le_trans with (find k m).
    * unfold subtract. apply filter_le. by apply powa_mem_mor.
    * apply B.le_refl; apply B.eq_sym. by apply subtract_2.
Qed.

Definition eq_wrt (wrt : PowA.t) (x y : t) : bool :=
  let eq_wrt' k :=
    if B.eq_dec (find k x) (find k y) then true else false in
  PowA.for_all print eq_wrt' wrt.

Lemma eq_wrt_1 :
  forall k wrt x y (Hk: PowA.mem k wrt) (Heq: eq_wrt wrt x y = true),
    B.eq (find k x) (find k y).
Proof.
unfold eq_wrt. i. apply (PowA.for_all_1 (k:=k)) in Heq.
- dest_if.
- by auto.
- intros k1 k2 Hk'.
  destruct (B.eq_dec (find k1 x) (find k1 y))
  ; destruct (B.eq_dec (find k2 x) (find k2 y)); try reflexivity.
  + elim f.
    eapply B.eq_trans. eapply B.eq_trans; [|by apply e].
    * apply find_mor; [by apply A.eq_sym|by apply eq_refl].
    * apply find_mor; [by auto|by apply eq_refl].
  + elim f.
    eapply B.eq_trans. eapply B.eq_trans; [|by apply e].
    * apply find_mor; [by auto|by apply eq_refl].
    * apply find_mor; [by apply A.eq_sym|by apply eq_refl].
Qed.

End Make.


Require Import
  HoTT
  Nat.
Require Export
  lList
  austere_nCk.

Fixpoint nCk_lt (n k : nat) : nCkList (lt (S n) k) n k.
Proof.
  destruct n.
    destruct k.
      exact tt.
      exact tt.
    destruct k.
      exact tt.
    split.
      change (nCkList (lt (S n) k) n k). apply nCk_lt.
      change (nCkList (lt (S n) k) n (S k)).
      refine (nCkApply (nCkKMap _ _ _) (nCk_lt n (S k))).
      intro.
      refine (lt_trans (lt_S _) X).
Defined.

Fixpoint l_nck_nck_l { k l m : nat } :
  lList (nCkType k l) m -> nCkList (lType m) k l.
Proof.
  destruct k.
    destruct l.
      exact lT_S.
    intros. exact tt.
    destruct l.
      exact lT_S.
    intros.
    exact
      ( l_nck_nck_l _ _ _ (l_Lfst X),
        l_nck_nck_l _ _ _ (l_Lsnd X) ).
Defined.

Fixpoint ln_nl_alt { k l m : nat } :
  lList (nCkType k l) m -> nCkList (lType m) k l.
Proof.
  intros.
  destruct m.
    exact (nCkKonst tt _ _).
    exact (nCkLPair (fst X) (ln_nl_alt _ _ _ (snd X))).
Defined.

Fixpoint nck_l_l_nck { k l m : nat } :
  nCkList (lType m) k l -> lList (nCkType k l) m.
Proof.
  destruct k.
    destruct l.
    apply lS_T.
    intro. apply lKonst.
      exact tt.
    intro L.
    destruct l.
    exact (lS_T L).
    destruct L as [ Lkl LkSl ].
    refine ( l_LPair (nck_l_l_nck _ _ _ Lkl)
             (nck_l_l_nck _ _ _ LkSl)).
Defined.

Fixpoint nckt_nck_l { k l m : nat } :
  lList (nCkType k l) m -> lType m :=
match m with
  | O => fun _ => tt
  | S m' => fun LcxL =>
    ( nCkSect (fst LcxL) , nckt_nck_l (snd LcxL) ) end.

Fixpoint lt_l_nck { k l m : nat } :
  nCkList (lType m) k l -> nCkType k l :=
match k return nCkList (lType m) k l -> nCkType k l with
  | O =>
    match l with
      | O => fun X : lType m => lSect X
      | S l' => fun _ => tt end
  | S k' =>
    match l with
      | O => fun X : lType m => lSect X
      | S l' => fun X =>
        ( lt_l_nck (fst X) , lt_l_nck (snd X)) end end.

Fixpoint lt_l_nck_alt { k l m : nat } :
 nCkList (lType m) k l -> nCkType k l :=
match m with
  | O => fun _ => nCkLT Unit k l
  | S m' =>
    fun ( w : nCkList (Type * lType m') k l) =>
      nCkProd (nCkT_S (nCkLfst w)) (lt_l_nck_alt (nCkLsnd w)) end.

Fixpoint noneOfAnything { l m } :
    forall (LNCK : lList ( nCkType l m ) 0),
      nCkSect ( lt_l_nck ( l_nck_nck_l LNCK )).
Proof.
  intros.
  destruct l.
    destruct m.
      exact tt.
      exact tt.
    destruct m.
      exact tt.
      split.
      refine ( noneOfAnything l m _ ).
      refine ( noneOfAnything l (S m) _).
Defined.

Fixpoint nckls_step { k l m : nat } :
  forall t1 : nCkType k l,
   forall lnck : lList (nCkType k l) m,
    nCkSect t1 -> nCkSect (lt_l_nck (l_nck_nck_l lnck)) ->
      nCkSect (lt_l_nck (@l_nck_nck_l _ _ (S m) (t1, lnck))).
Proof.
  intros.
   destruct k.
    destruct l.
      exact ( X , X0 ).
      exact tt.
    destruct l.
      exact ( X, X0 ).
   destruct t1 as [ tkl tkSl ].
    simpl.
    split.
    refine ( nckls_step _ _ _ _ _ (fst X) (fst X0) ).
    refine ( nckls_step _ _ _ _ _ (snd X) (snd X0) ).
Defined.

(*
Fixpoint lnck_fst { k l m : nat } :
  forall LNCK : lList (nCkType (S k) (S l)) m,
     lSect (nckt_nck_l LNCK) -> lSect (nckt_nck_l (l_Lfst LNCK)).
Proof.
  intros.
  destruct m.
    exact tt.
    simpl.
    destruct X as [ [ X1a X1b ] X2 ].
    refine ( X1a , lnck_fst _ _ _ _ X2).
Defined.

Fixpoint lnck_snd { k l m : nat } :
  forall LNCK : lList (nCkType (S k) (S l)) m,
     lSect (nckt_nck_l LNCK) -> lSect (nckt_nck_l (l_Lsnd LNCK)).
Proof.
  intros.
  destruct m.
    exact tt.
    simpl.
    destruct X as [ [ X1a X1b ] X2 ].
    refine ( X1b , lnck_snd _ _ _ _ X2 ).
Defined.
*)

Fixpoint nckls_lncks { k l m : nat }:
  forall LNCK : lList (nCkType k l) m ,
    lSect (nckt_nck_l LNCK) ->
      nCkSect (lt_l_nck (l_nck_nck_l LNCK)).
Proof.
  intros.
  destruct m.
   exact (noneOfAnything LNCK).
   destruct LNCK as [ t1 lnck ].
  refine (nckls_step _ _ (fst X)
                 (nckls_lncks _ _ _ _ (snd X))).
Defined.

Fixpoint fstpair_elim { n k } :
forall { A : nCkType n k }
 {B : Type}{ b : nCkList B n k},
  nCkSect A ->
    nCkSect (nCkT_S (nCkLfst (nCkLPair A b ))).
Proof.
  intros.
  destruct n.
    destruct k.
      exact X.
      exact tt.
    destruct k.
      exact X.
      simpl. destruct A. destruct b.
      exact (fstpair_elim _ _ _ _ _ (fst X),
             fstpair_elim _ _ _ _ _ (snd X)).
Defined.

Fixpoint sndpair_elim { n k } :
forall { A: Type } { a : nCkList A _ _ }
 { B : nCkType n k },
 nCkSect B -> (nCkSect (nCkT_S (nCkLsnd (nCkLPair a B)))).
Proof.
  intros.
  destruct n.
    destruct k.
      exact X.
      exact tt.
    destruct k.
      exact X.
      destruct a, B.
      exact (sndpair_elim _ _ _ _ _ (fst X),
             sndpair_elim _ _ _ _ _ (snd X)).
Defined.

(*
Fixpoint nckls_lncks_alt { k l m : nat }:
  forall LNCK : lList (nCkType k l) m,
    lSect (nckt_nck_l LNCK) ->
      nCkSect (lt_l_nck_alt (ln_nl_alt LNCK)).
Proof.
  intros.
  destruct m.
    exact (nCkKonst tt _ _).
    destruct LNCK.
    destruct X.
    apply nCkPair.
    simpl.
     apply fstpair_elim.
     exact n0.
    simpl.
    refine (nckls_lncks_alt _ l _ _ l1).
    apply sndpair_elim.
    apply
      (nckls_lncks_alt _ _ _ l0 l1).
*)


(**
 Duality involutions of bicategories

 Contents:
 1. Duality involution on categories
 2. Classifying discrete opfibration
 3. Cartesian closed
 4. Cores
 4.1 Groupoidal objects
 4.2 The coreflection
 *)
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.Elements.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.Groupoids.
Require Import UniMath.CategoryTheory.Core.
Require Import UniMath.CategoryTheory.categories.StandardCategories.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.
Require Import UniMath.CategoryTheory.DisplayedCats.Projection.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.StreetOpFibration.
Require Import UniMath.CategoryTheory.DisplayedCats.Examples.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Univalence.
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.DisplayMapBicatSlice.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.BicatOfInvertibles.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.
Require Import UniMath.Bicategories.Morphisms.Eso.
Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration.
Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms.
Require Import UniMath.Bicategories.Morphisms.Examples.MorphismsInBicatOfUnivCats.
Require Import UniMath.Bicategories.Morphisms.Examples.FibrationsInBicatOfUnivCats.
Require Import UniMath.Bicategories.Morphisms.Examples.EsosInBicatOfUnivCats.
Require Import UniMath.Bicategories.Limits.Products.
Require Import UniMath.Bicategories.Limits.Pullbacks.
Require Import UniMath.Bicategories.Limits.PullbackFunctions.
Require Import UniMath.Bicategories.Limits.Examples.BicatOfUnivCatsLimits.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.UniversalArrow.
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.OpFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.ConstProduct.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Modifications.Modification.
Require Import UniMath.Bicategories.OtherStructure.ClassifyingDiscreteOpfib.
Require Import UniMath.Bicategories.OtherStructure.DualityInvolution.
Require Import UniMath.Bicategories.OtherStructure.Exponentials.
Require Import UniMath.Bicategories.OtherStructure.Cores.

Local Open Scope cat.

(**
 1. Duality involution on categories
 *)
Definition op_unit_data
  : pstrans_data
      (id_psfunctor _)
      (comp_psfunctor op_psfunctor (op2_psfunctor op_psfunctor)).
Proof.
  use make_pstrans_data.
  - exact (λ C, functor_identity _).
  - intros C₁ C₂ F.
    use nat_z_iso_to_invertible_2cell.
    exact (op_unit_nat_z_iso F).
Defined.

Definition op_unit_is_pstrans
  : is_pstrans op_unit_data.
Proof.
  repeat split ; intro ; intros ;
    (use nat_trans_eq ; [ apply homset_property | ]) ; intro ; cbn ;
    rewrite ?id_left, ?id_right.
  - apply idpath.
  - apply idpath.
  - exact (!(functor_id _ _)).
Qed.

Definition op_unit
  : pstrans
      (id_psfunctor _)
      (comp_psfunctor op_psfunctor (op2_psfunctor op_psfunctor)).
Proof.
  use make_pstrans.
  - exact op_unit_data.
  - exact op_unit_is_pstrans.
Defined.

Definition op_unit_inv_data
  : pstrans_data
      (comp_psfunctor op_psfunctor (op2_psfunctor op_psfunctor))
      (id_psfunctor _).
Proof.
  use make_pstrans_data.
  - exact (λ C, functor_identity _).
  - intros C₁ C₂ F.
    use nat_z_iso_to_invertible_2cell.
    exact (op_unit_inv_nat_z_iso F).
Defined.

Definition op_unit_inv_is_pstrans
  : is_pstrans op_unit_inv_data.
Proof.
  repeat split ; intro ; intros ;
    (use nat_trans_eq ; [ apply homset_property | ]) ; intro ; cbn ;
    rewrite ?id_left, ?id_right.
  - apply idpath.
  - apply idpath.
  - exact (!(functor_id _ _)).
Qed.

Definition op_unit_inv
  : pstrans
      (comp_psfunctor op_psfunctor (op2_psfunctor op_psfunctor))
      (id_psfunctor _).
Proof.
  use make_pstrans.
  - exact op_unit_inv_data.
  - exact op_unit_inv_is_pstrans.
Defined.

Definition op_triangle
           (C : op2_bicat bicat_of_univ_cats)
  : invertible_2cell
      (op_unit (op_psfunctor C))
      (# op_psfunctor (op_unit C)).
Proof.
  use nat_z_iso_to_invertible_2cell.
  exact (op_triangle_nat_z_iso _).
Defined.

Definition op_unit_unit_inv_data
  : invertible_modification_data
      (id₁ _)
      (op_unit · op_unit_inv).
Proof.
  intro C.
  use nat_z_iso_to_invertible_2cell.
  exact (op_unit_unit_inv_nat_z_iso _).
Defined.

Definition op_unit_unit_inv_is_modif
  : is_modification op_unit_unit_inv_data.
Proof.
  intros C₁ C₂ F.
  use nat_trans_eq.
  {
    apply homset_property.
  }
  intro x ; cbn.
  rewrite !id_left, !id_right.
  exact (!(functor_id _ _)).
Qed.

Definition op_unit_unit_inv
  : invertible_modification
      (id₁ _)
      (op_unit · op_unit_inv).
Proof.
  use make_invertible_modification.
  - exact op_unit_unit_inv_data.
  - exact op_unit_unit_inv_is_modif.
Defined.

Definition op_unit_inv_unit_data
  : invertible_modification_data
      (op_unit_inv · op_unit)
      (id₁ _).
Proof.
  intro C.
  use nat_z_iso_to_invertible_2cell.
  exact (op_unit_inv_unit_nat_z_iso _).
Defined.

Definition op_unit_inv_unit_is_modif
  : is_modification op_unit_inv_unit_data.
Proof.
  intros C₁ C₂ F.
  use nat_trans_eq.
  {
    apply homset_property.
  }
  intro x ; cbn.
  rewrite !id_left, !id_right.
  exact (!(functor_id _ _)).
Qed.

Definition op_unit_inv_unit
  : invertible_modification
      (op_unit_inv · op_unit)
      (id₁ _).
Proof.
  use make_invertible_modification.
  - exact op_unit_inv_unit_data.
  - exact op_unit_inv_unit_is_modif.
Defined.

Definition bicat_of_univ_cat_duality_involution_data
  : duality_involution_data op_psfunctor.
Proof.
  use make_duality_involution_data.
  - exact op_unit.
  - exact op_unit_inv.
  - exact op_unit_unit_inv.
  - exact op_unit_inv_unit.
  - exact op_triangle.
Defined.

Definition bicat_of_univ_cat_duality_laws
  : duality_involution_laws bicat_of_univ_cat_duality_involution_data.
Proof.
  split.
  - intro C.
    use nat_trans_eq.
    {
      apply homset_property.
    }
    intro x ; cbn.
    apply id_left.
  - intros C₁ C₂ F.
    use nat_trans_eq ; [ apply homset_property | ].
    intro  ; cbn.
    rewrite !id_left.
    exact (!(functor_id _ _)).
Qed.

Definition bicat_of_univ_cat_duality
  : duality_involution op_psfunctor
  := bicat_of_univ_cat_duality_involution_data ,, bicat_of_univ_cat_duality_laws.

(** 2. Classifying discrete opfibration *)
Definition disc_sopfib_cat_of_elems_forgetful
           {C : univalent_category}
           (P : C ⟶ HSET)
  : @disc_sopfib
      bicat_of_univ_cats
      (univalent_cat_of_elems P) C
      (cat_of_elems_forgetful P).
Proof.
  split.
  - apply street_opfib_is_internal_sopfib.
    apply opfibration_is_street_opfib.
    apply disp_cat_of_elems_opcleaving.
  - split.
    + apply cat_faithful_is_faithful_1cell.
      apply pr1_category_faithful.
      intro ; intros.
      apply disp_mor_elems_isaprop.
    + apply cat_conservative_is_conservative_1cell.
      apply groupoidal_disp_cat_to_conservative.
      intro ; intros.
      apply is_z_iso_disp_cat_of_elems.
Defined.

Section CategoryOfElementsHasPbUMP.
  Context {C : bicat_of_univ_cats}
          (P : C --> HSET_univalent_category).

  Let F₁ : bicat_of_univ_cats ⟦ univalent_cat_of_elems P , pointed_sets_univalent ⟧
    := cat_of_elems_to_pointed P.
  Let F₂ : bicat_of_univ_cats ⟦ univalent_cat_of_elems P, C ⟧
    := cat_of_elems_forgetful P.

  Definition cat_of_elems_inv2cell
    : invertible_2cell
        (F₁ · set_of_pointed_set)
        (F₂ · P).
  Proof.
    use invertible_2cell_is_nat_z_iso.
    exact (cat_of_elems_commute_z_iso P).
  Defined.

  Let cone
    : @pb_cone bicat_of_univ_cats _ _ _ set_of_pointed_set P
    := make_pb_cone
         _ _ _
         cat_of_elems_inv2cell.

  Definition cat_of_elems_pb_ump_1
    : pb_ump_1 cone.
  Proof.
    intro q.
    use make_pb_1cell.
    - cbn.
      apply (functor_to_cat_of_elems
               _
               (pb_cone_pr1 q)
               (pb_cone_pr2 q)).
      apply invertible_2cell_to_nat_z_iso.
      apply (pb_cone_cell q).
    - apply nat_z_iso_to_invertible_2cell.
      apply functor_to_cat_of_elems_pointed.
    - apply nat_z_iso_to_invertible_2cell.
      apply functor_to_cat_of_elems_forgetful.
    - abstract
        (use nat_trans_eq ; [ apply homset_property | ] ;
         intro x ; cbn ;
         use funextsec ;
         intro z ; cbn ;
         cbn in * ;
         refine (_ @ !(eqtohomot (functor_id P (pr1 (pb_cone_pr2 q) x)) _)) ;
         exact (!(eqtohomot
                    (nat_trans_eq_pointwise (vcomp_linv (pb_cone_cell q)) x) z))).
  Defined.

  Definition cat_of_elems_pb_ump_2
    : pb_ump_2 cone.
  Proof.
    intros C' G₁ G₂ τ₁ τ₂ p.
    use iscontraprop1.
    - abstract
        (use invproofirrelevance ;
         intros φ₁ φ₂ ;
         use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ;
         use nat_trans_eq ; [ apply homset_property | ] ;
         intro x ;
         use subtypePath ; [ intro ; apply disp_mor_elems_isaprop | ] ;
         exact (nat_trans_eq_pointwise (pr22 φ₁) x @ !(nat_trans_eq_pointwise (pr22 φ₂) x))).
    - simple refine (_ ,, _ ,, _).
      + refine (nat_trans_to_cat_of_elems P τ₁ τ₂ _).
        abstract
          (intro x ;
           pose (q := eqtohomot (nat_trans_eq_pointwise p x)) ;
           cbn in q ;
           apply q).
      + abstract
          (use nat_trans_eq ; [ apply homset_property | ] ;
           cbn ;
           intro ;
           use subtypePath ; [ intro ; apply (pr1 P _) | ] ;
           exact (nat_trans_eq_pointwise p x)).
      + abstract
          (use nat_trans_eq ; [ apply homset_property | ] ;
           cbn ;
           intro ;
           apply idpath).
  Defined.

  Definition cat_of_elems_has_pb_ump
    : has_pb_ump cone.
  Proof.
    split.
    - exact cat_of_elems_pb_ump_1.
    - exact cat_of_elems_pb_ump_2.
  Defined.
End CategoryOfElementsHasPbUMP.

Definition pb_via_cat_of_elems
  : @map_to_disp_sopfib bicat_of_univ_cats _ _ set_of_pointed_set.
Proof.
  intros C P.
  simple refine ((_ ,, (_ ,, _)) ,, (_ ,, (_ ,, _))).
  - exact (univalent_cat_of_elems P).
  - exact (cat_of_elems_forgetful P).
  - exact (disc_sopfib_cat_of_elems_forgetful P).
  - exact (cat_of_elems_to_pointed P).
  - exact (cat_of_elems_inv2cell P).
  - exact (cat_of_elems_has_pb_ump P).
Defined.

Definition disc_sopfib_set_of_pointed_set
  : @disc_sopfib
      bicat_of_univ_cats
      _ _
      set_of_pointed_set.
Proof.
  split.
  - apply street_opfib_is_internal_sopfib.
    apply opfibration_is_street_opfib.
    apply opcleaving_elements_universal.
  - split.
    + apply cat_faithful_is_faithful_1cell.
      apply pr1_category_faithful.
      intros X Y f x y.
      apply Y.
    + apply cat_conservative_is_conservative_1cell.
      apply groupoidal_disp_cat_to_conservative.
      intros X Y f Hf x y ff.
      apply is_z_iso_disp_elements_universal.
Defined.

Section IsClassifyingFull.
  Context {C : univalent_category}
          {F G : C ⟶ HSET_univalent_category}
          (n : disc_sopfib_slice
                 univalent_cat_is_univalent_2_1
                 C
               ⟦ pr1 (pb_via_cat_of_elems C F)
               , pr1 (pb_via_cat_of_elems C G) ⟧).

  Definition is_classifying_nat_trans_data
    : nat_trans_data F G.
  Proof.
    intros x z.
    exact (cat_of_elems_iso_lift
             G
             (pr2 C)
             (pr1 (pr122 n) (x ,, z))
             (z_iso_is_z_isomorphism
                (nat_z_iso_pointwise_z_iso
                   (make_nat_z_iso
                      _ _ _
                      (is_invertible_2cell_to_is_nat_z_iso _ (pr222 n)))
                   (x ,, z)))
             (pr2 (pr1 (pr1 n) (x ,, z)))).
  Defined.

  Definition is_classifying_nat_trans_is_nat_trans
    : is_nat_trans _ _ is_classifying_nat_trans_data.
  Proof.
    intros x y f ; cbn.
    use funextsec.
    intro z.
    unfold is_classifying_nat_trans_data ; cbn.
    unfold cat_of_elems_iso_lift ; cbn.
    pose (p := pr212 (pr2 n) (x ,, z) (y,, # F f z) (f ,, idpath _)).
    refine (cat_of_elems_z_iso_natural _ _ _ _ _ _ _ _ _ _ p (!_)) ; cbn.
    exact (pr2 (@functor_on_morphisms
                  _ _
                  (pr11 n)
                  (x ,, z) (y,, # F f z)
                  (f ,, idpath _))).
  Qed.

  Definition is_classifying_nat_trans
    : F ⟹ G.
  Proof.
    use make_nat_trans.
    - exact is_classifying_nat_trans_data.
    - exact is_classifying_nat_trans_is_nat_trans.
  Defined.

  Definition is_classifying_bicat_of_univ_cats_eq_nat_trans_data
    : nat_trans_data
        (mor_of_pb_disc_sopfib_mor
           _
           disc_sopfib_set_of_pointed_set
           pb_via_cat_of_elems
           (is_classifying_nat_trans) : _ ⟶ _)
        (pr1 n : _ ⟶ _).
  Proof.
    intro x.
    simple refine (pr1 (pr122 n) x ,, _).
    apply cat_of_elems_iso_path.
  Defined.

  Definition is_classifying_bicat_of_univ_cats_eq_is_nat_trans
    : is_nat_trans _ _ is_classifying_bicat_of_univ_cats_eq_nat_trans_data.
  Proof.
    intros x y f.
    use subtypePath.
    {
      intro.
      apply disp_mor_elems_isaprop.
    }
    cbn.
    exact (nat_trans_ax (pr122 n) _ _ f).
  Qed.

  Definition is_classifying_bicat_of_univ_cats_nat_trans
    : mor_of_pb_disc_sopfib_mor
        _
        disc_sopfib_set_of_pointed_set
        pb_via_cat_of_elems
        (is_classifying_nat_trans)
      ==>
      pr1 n.
  Proof.
    use make_nat_trans.
    - exact is_classifying_bicat_of_univ_cats_eq_nat_trans_data.
    - exact is_classifying_bicat_of_univ_cats_eq_is_nat_trans.
  Defined.

  Definition invertible_is_classifying_bicat_of_univ_cats_nat_trans
    : is_invertible_2cell is_classifying_bicat_of_univ_cats_nat_trans.
  Proof.
    use is_nat_z_iso_to_is_invertible_2cell.
    intros x.
    use is_z_iso_cat_of_elems.
    cbn.
    exact (z_iso_is_z_isomorphism
             (nat_z_iso_pointwise_z_iso
                (make_nat_z_iso
                   _ _ _
                   (is_invertible_2cell_to_is_nat_z_iso _ (pr222 n)))
                x)).
  Defined.

  Definition is_classifying_bicat_of_univ_cats_nat_trans_coh
    : is_classifying_bicat_of_univ_cats_nat_trans ▹ _
      =
      pb_ump_mor_pr2
        (cat_of_elems_has_pb_ump G)
        (mor_of_pb_disc_sopfib_mor_cone
           _
           disc_sopfib_set_of_pointed_set
           pb_via_cat_of_elems (is_classifying_nat_trans))
      • pr122 n.
  Proof.
    use nat_trans_eq.
    {
      apply homset_property.
    }
    intro x.
    cbn.
    rewrite id_left.
    apply idpath.
  Qed.
End IsClassifyingFull.

Definition is_classifying_full_help_in_bicat_of_univ_cats
  : is_classifying_full_help
      univalent_cat_is_univalent_2_1
      set_of_pointed_set
      disc_sopfib_set_of_pointed_set
      pb_via_cat_of_elems.
Proof.
  intros C F G n.
  simple refine (_ ,, _ ,, (_ ,, _)).
  - exact (is_classifying_nat_trans n).
  - exact (is_classifying_bicat_of_univ_cats_nat_trans n).
  - exact (invertible_is_classifying_bicat_of_univ_cats_nat_trans n).
  - exact (is_classifying_bicat_of_univ_cats_nat_trans_coh n).
Defined.

Definition is_classifying_faithful_help_in_bicat_of_univ_cats
  : is_classifying_faithful_help
      _
      disc_sopfib_set_of_pointed_set
      pb_via_cat_of_elems.
Proof.
  intros C F G n₁ n₂ γ p.
  use nat_trans_eq.
  {
    apply homset_property.
  }
  intro x.
  use funextsec.
  intro z.
  pose (pr11 γ (x ,, z)) as q.
  cbn in q.
  refine (_ @ pr2 q).
  unfold q ; clear q.
  pose (nat_trans_eq_pointwise p (x ,, z)) as q.
  cbn in q.
  refine (!_).
  etrans.
  {
    apply maponpaths_2.
    refine (!(id_right _) @ _).
    exact q.
  }
  apply (eqtohomot (functor_id G x)).
Qed.

Definition is_classifying_in_bicat_of_univ_cats
  : is_classifying
      univalent_cat_is_univalent_2_1
      set_of_pointed_set
      disc_sopfib_set_of_pointed_set
      pb_via_cat_of_elems.
Proof.
  use make_is_classifying.
  - exact is_classifying_full_help_in_bicat_of_univ_cats.
  - exact is_classifying_faithful_help_in_bicat_of_univ_cats.
Defined.

(**
 3. Cartesian closed
 *)
Definition bicat_of_univ_cats_is_cartesian_closed
  : is_cartesian_closed_bicat (_ ,, has_binprod_bicat_of_univ_cats).
Proof.
  intros C.
  use make_right_universal_arrow'.
  - exact univalent_cat_is_univalent_2_1.
  - exact (λ D, univalent_functor_category C D).
  - exact (λ D, evaluation_functor).
  - intros D₁ D₂ F G α.
    simple refine (_ ,, _).
    + exact (evaluation_nat_trans F G α).
    + abstract
        (cbn in F, G, α ;
         use nat_trans_eq ; [ apply homset_property | ] ;
         intro x ; cbn ;
         rewrite !id_left, !id_right ;
         rewrite (functor_id (F _)) ;
         rewrite id_left ;
         apply idpath).
  - abstract
      (intros D₁ D₂ F G α β₁ β₂ p₁ p₂ ;
       use nat_trans_eq ; [ apply homset_property | ] ;
       intro ;
       use nat_trans_eq ; [ apply homset_property | ] ;
       intro y ;
       pose (q := nat_trans_eq_pointwise p₁ (x ,, y)
                  @
                  !(nat_trans_eq_pointwise p₂ (x ,, y))) ;
       cbn in q ;
       rewrite !id_right, !id_left in q ;
       unfold bindelta_pair_pr2_data in q ;
       cbn in q ;
       rewrite !(functor_id (pr1 F _)) in q ;
       rewrite !id_left in q ;
       exact q).
  - intros D₁ D₂ F.
    simple refine (_ ,, _).
    + exact (curry_functor' F).
    + use nat_z_iso_to_invertible_2cell.
      exact (evaluate_curry_functor'_nat_z_iso F).
Defined.

(**
 4. Cores
 *)

(**
 4.1 Groupoidal objects
 *)
Definition groupoid_is_groupoidal_obj
           (C : bicat_of_univ_cats)
           (HC : is_pregroupoid (pr1 C))
  : groupoidal C.
Proof.
  intros C' F₁ F₂ n.
  use is_nat_z_iso_to_is_invertible_2cell.
  intro.
  apply HC.
Defined.

Definition groupoidal_obj_is_groupoid
           (C : bicat_of_univ_cats)
           (HC : groupoidal C)
  : is_pregroupoid (pr1 C).
Proof.
  intros x y f.
  exact (is_invertible_2cell_to_is_nat_z_iso
           _
           (HC unit_category
               (functor_from_unit x)
               (functor_from_unit y)
               (nat_trans_from_unit f))
           tt).
Defined.

Definition groupoid_weq_groupoidal_obj
           (C : bicat_of_univ_cats)
  : is_pregroupoid (pr1 C) ≃ groupoidal C.
Proof.
  use weqimplimpl.
  - exact (groupoid_is_groupoidal_obj C).
  - exact (groupoidal_obj_is_groupoid C).
  - apply isaprop_is_pregroupoid.
  - apply isaprop_groupoidal.
Defined.

(**
 4.2 The coreflection
 *)
Definition bicat_of_univ_cats_has_cores_map
           (C : bicat_of_inv2cells bicat_of_univ_cats)
  : bicat_of_groupoidal bicat_of_univ_cats.
Proof.
  refine (univalent_core (pr1 C) ,, _).
  apply groupoid_is_groupoidal_obj.
  apply is_pregroupoid_core.
Defined.

Definition bicat_of_univ_cats_has_cores_counit
           (C : bicat_of_inv2cells bicat_of_univ_cats)
  : groupoidal_to_inv2cells bicat_of_univ_cats (bicat_of_univ_cats_has_cores_map C)
    -->
    C
  := functor_core _ ,, tt.

Definition bicat_of_univ_cats_has_cores_nat_trans
           {C₀ : bicat_of_groupoidal bicat_of_univ_cats}
           {C₀' : bicat_of_inv2cells bicat_of_univ_cats}
           (F₁ F₂ : C₀ --> bicat_of_univ_cats_has_cores_map C₀')
           (α : # (groupoidal_to_inv2cells bicat_of_univ_cats) F₁
                · bicat_of_univ_cats_has_cores_counit C₀'
                ==>
                # (groupoidal_to_inv2cells bicat_of_univ_cats) F₂
                · bicat_of_univ_cats_has_cores_counit C₀')
  : pr11 F₁ ⟹ pr11 F₂.
Proof.
  use (@nat_trans_to_core
         (pr11 C₀')
         (pr11 C₀ ,, groupoidal_obj_is_groupoid _ (pr2 C₀))).
  use make_nat_z_iso.
  - exact (pr1 α).
  - apply is_invertible_2cell_to_is_nat_z_iso.
    exact (pr2 α).
Defined.

Definition bicat_of_univ_cats_has_cores_coreflection
  : right_universal_arrow (groupoidal_to_inv2cells bicat_of_univ_cats).
Proof.
  use make_right_universal_arrow'.
  - apply is_univalent_2_1_bicat_of_groupoidal.
    exact univalent_cat_is_univalent_2_1.
  - exact bicat_of_univ_cats_has_cores_map.
  - exact bicat_of_univ_cats_has_cores_counit.
  - intros C₀ C₀' F₁ F₂ α.
    simple refine ((_ ,, tt) ,, _).
    + exact (bicat_of_univ_cats_has_cores_nat_trans _ _ α).
    + abstract
        (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ;
         use nat_trans_eq ; [ apply homset_property | ] ;
         intro ;
         apply idpath).
  - abstract
      (intros C₀ C₀' F₁ F₂ α β₁ β₂ p q ;
       use subtypePath ; [ intro ; apply isapropunit | ] ;
       use nat_trans_eq ; [ apply homset_property | ] ;
       intro x ;
       use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ;
       refine (nat_trans_eq_pointwise (maponpaths pr1 p) x @ !_) ;
       exact (nat_trans_eq_pointwise (maponpaths pr1 q) x)).
  - intros C₀ C₀' F.
    simple refine ((_ ,, tt) ,, _).
    + exact (@factor_through_core
               (pr11 C₀')
               (pr11 C₀ ,, groupoidal_obj_is_groupoid _ (pr2 C₀))
               (pr1 F)).
    + cbn.
      use make_invertible_2cell.
      * simple refine (_ ,, _) ; cbn.
        ** exact (@factor_through_core_commute
                    (pr11 C₀')
                    (pr11 C₀ ,, groupoidal_obj_is_groupoid _ (pr2 C₀))
                    (pr1 F)).
        ** apply is_nat_z_iso_to_is_invertible_2cell.
           intro x.
           apply identity_is_z_iso.
      * apply is_invertible_2cell_bicat_of_inv2cells.
Defined.

Definition bicat_of_univ_cats_has_cores
  : has_cores bicat_of_univ_cats.
Proof.
  simple refine (_ ,, _).
  - exact bicat_of_univ_cats_has_cores_coreflection.
  - intro C.
    split ; cbn.
    + apply essentially_surjective_is_eso.
      apply functor_core_eso.
    + apply cat_pseudmonic_is_pseudomonic_1cell.
      apply functor_core_pseudomonic.
Defined.


From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat ssrfun seq.
Set Implicit Arguments.

(* This file defines the type of stacks used to model callstacks in       *)
(* linking.v.                                                             *)

Module SeqStack. Section seqStack.
Variable T : Type.

Definition updStack (newStack : seq T) := newStack.
Definition push (stack: seq T) (t: T) := updStack [:: t & stack].
Definition peek (stack: seq T) : option T :=
  if stack is [:: topT & rest] then Some topT else None.
Definition pop  (stack: seq T) : seq T := behead stack.
Definition empty : seq T := [::].

Definition nonempty : pred (seq T) :=
  [pred s | if s is [::] then false else true].

Lemma peek_nonempty (stack : seq T) t :
  peek stack = Some t -> nonempty stack.
Proof. by rewrite/peek; case: stack. Qed.

Lemma nonempty_nempty (stack: seq T) : nonempty stack -> [::] = stack -> T.
Proof. by case: stack. Qed.

Definition head (stack: seq T) (pf: nonempty stack) : T :=
  (match stack as s return (s = stack -> T) with
    | nil => fun pf' => nonempty_nempty pf pf'
    | s :: stack' => fun pf' => s
  end) erefl.

Lemma nonempty_peek (stack : seq T) (pf : nonempty stack) :
  peek stack = Some (head stack pf).
Proof. by move: pf; case: stack=>// a l _. Qed.

Lemma peeksome_head stack t :
  peek stack = Some t ->
  forall pf : nonempty stack, head stack pf = t.
Proof. by rewrite/head; case: stack=> //=; move=> ? ?; case. Qed.

Lemma all_pop (stack : seq T) p : all p stack -> all p (pop stack).
Proof. by case: stack=>//= a l; move/andP=> [H1 H2]. Qed.

End seqStack.

Arguments empty / {T}.
Arguments push {T} _ _ /.
Arguments pop {T} !_ /.
Arguments peek {T} !_ /.
Arguments nonempty {T} !_ /.
Arguments head {T} !_ _ /.

End SeqStack.

Module STACK.

Record type (T : Type) : Type :=
  { t : Type
  ; empty: t
  ; push : t -> T -> t
  ; pop  : t -> t
  ; peek : t -> option T
  ; nonempty : pred t
  ; head : forall t, nonempty t -> T
  ; all  : pred T -> t -> bool
  ; all_pop : forall t p, all p t -> all p (pop t) }.

End STACK.

Arguments STACK.empty {T t} /.
Arguments STACK.push {T t} _ _ /.
Arguments STACK.pop {T t} _ /.
Arguments STACK.peek {T t} _ /.
Arguments STACK.nonempty {T t} _ /.
Arguments STACK.head {T t} _ _ /.

Coercion STACK.t : STACK.type >-> Sortclass.

Module Stack.

Import SeqStack.

Section Stack.

Variable T : Type.

Definition t : STACK.type T :=
  @STACK.Build_type T (seq T) empty push pop peek nonempty head
  all (@all_pop T).

End Stack.

End Stack.

Canonical Structure seq_stackTy T : STACK.type T := Stack.t T.

Lemma pop_size U T (stack1 : seq U) (stack2 : seq T)
  (pf1 : 1 <= size stack1) (pf2 : 1 <= size stack2) :
  size (STACK.pop stack1) = size (STACK.pop stack2) ->
  size stack1 = size stack2.
Proof.
by case: stack1 pf1=> // a s1 ? /=; case: stack2 pf2=> // b s2 ? /= => ->.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.Init.Peano.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.PArith.BinPosDef.
Require Import Coq.ZArith.BinInt Coq.ZArith.ZArith Coq.ZArith.Zdiv Coq.ZArith.Znumtheory Coq.NArith.NArith. (* import Zdiv before Znumtheory *)
Require Import Coq.NArith.Nnat.

Require Import Crypto.Algebra.Hierarchy Crypto.Algebra.Field.
Require Import Crypto.Spec.ModularArithmetic.
Require Import Crypto.Arithmetic.ModularArithmeticTheorems Crypto.Arithmetic.PrimeFieldTheorems.

Require Import Crypto.Util.Decidable. (* Crypto.Util.Notations. *)
Require Import Coq.setoid_ring.Ring_theory Coq.setoid_ring.Field_theory Coq.setoid_ring.Field_tac.
Require Import Ring.

From Circom Require Import Circom Default Util DSL Tuple ListUtil LibTactics Simplify.
From Circom Require Import Repr ReprZ.
From Circom.CircomLib Require Import Bitify Comparators.

(* Circuit:
* https://github.com/yi-sun/circom-pairing/blob/master/circuits/bigint.circom
*)

Module ModProd.

Module D := DSL.
Module Cmp := Comparators.
Module RZU := ReprZUnsigned.
Module RZ := RZU.RZ.
Module R := Repr.

Local Open Scope list_scope.
Local Open Scope Z_scope.
Local Open Scope F_scope.
Local Open Scope circom_scope.
Local Open Scope tuple_scope.

Local Coercion Z.of_nat: nat >-> Z.
Local Coercion N.of_nat: nat >-> N.

Module N := Bitify.Num2Bits.
Module B := Bitify.Bits2Num.

Section _ModProd.
Context {n: nat}.

Definition cons (a b prod carry: F) :=
  exists n2b: (@N.t (2*n)),
  n2b.(N._in) = a*b /\
  exists (b2n1: @B.t n) (b2n2: @B.t n),
  D.iter (fun (i: nat) (cons : Prop) => cons /\
    b2n1.(B._in)[i] = n2b.(N.out)[i] /\
    b2n2.(B._in)[i] = n2b.(N.out)[i + n])
  n True /\
  prod = b2n1.(B.out) /\
  carry = b2n2.(B.out).

Record t := { a: F; b: F; prod: F; carry: F; _cons: cons a b prod carry}.

End _ModProd.
End ModProd.


From Mtac2 Require Import Mtac2 Tactics Ttactics.
Set Printing Universes.

Import Ttactics.TT.
Import TT.notations.

Module Test.
Polymorphic Section With.
  Monomorphic Parameter MyGoal : Prop.
  Polymorphic Parameter MyAssum1@{U1}: forall T1:Type@{U1}, Prop.
  Polymorphic Parameter MyAssum2@{U2}: forall T2:Type@{U2}, Prop.
  Polymorphic Parameter MyProof@{U1 U2+|U1 < U2+} : forall (T1 : Type) (T2 : Type),
      MyAssum1@{U1} T1 -> MyAssum2@{U2} T2 -> MyGoal.

  Set Printing Depth 1000.
  Polymorphic Definition my_tactic@{U1 U2 U1' U2'+} : tactic :=
    Eval cbv beta fix match
           delta
             [
               MatchGoalTT.match_goal_base
                 MatchGoalTT.match_goal_pattern
                 MatchGoalTT.match_goal_pattern'
                 M.mmatch''
                 M.open_branch
                 M.open_pattern
             ] in
    (match_goal with
    | [[? (T1: Type@{U1'}) (T2:Type@{U2'})
        | (H1 : MyAssum1@{U1} T1) (H2 : MyAssum2@{U2} T2) |- MyGoal ]] =>
      TT.apply (MyProof@{U1 U2 U1' U2'} T1 T2 H1 H2)
     end
    )%TT%MC.

  Polymorphic Universe poly U1 U2.

  Parameter T1 : Type@{U1}.
  Parameter T2 : Type@{U2}.

  Polymorphic Example test1 (H1 : MyAssum1@{U1} T1) (H2 : MyAssum2@{U2} T2) : MyGoal.
  Proof.
    mrun (my_tactic).
  Qed. (* <-- there used to be a Fail here :-) *)
End With.
End Test.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj22synthconj2 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus lv0 lv1) (Succ lv2)) (plus lv1 (plus lv2 (Succ lv0)))).
Admitted.
QuickChick conj22synthconj2.