(** This defines an example instance of the memory model.

The stack grows towards lower addresses, from the root to the bottom.

The stack is full when the “top” reaches the stack limit.

Stack frames are made of data (for local variables), meta-data (for code
introduced by the compiler) and padding (for enforcing alignment).

The pointer to the top is aligned during allocation
thanks to the introduction of enough padding.

The basic model maps each address to one bit (is this address allocated) and one
byte (the contents).

We additionally maintain two invariants:

 - the data part of each stack frame is allocated
 - the memory below the stack is free

*)

Require memory_model array type.

Import Utf8.
Import all_ssreflect all_algebra.
Import ZArith.
Import word_ssrZ.
Import type word utils gen_map.
Import memory_model.
Import GRing.Theory.
Import ssrring.

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

Local Open Scope Z_scope.

Lemma orX (a b: bool) (P: Prop) :
  (a → P) →
  (a = false → b → P) →
  a || b → P.
Proof. by case: a => // _ /(_ erefl); case: b. Qed.

(* -------------------------------------------------------------------------- *)

Section WITH_POINTER_DATA.
Context {pd: PointerData}.

Lemma add_p_opp_sub_add_p (p q: pointer) (n: Z) :
  add p (- sub (add p n) q + n) = q.
Proof.
  rewrite !addE !subE !(wrepr_add, wrepr_opp, wrepr_unsigned).
  ssring.
Qed.

Corollary add_p_opp_sub_p (p q: pointer):
  add p (- sub p q) = q.
Proof.
  have := add_p_opp_sub_add_p p q 0.
  by rewrite add_0 Z.add_0_r.
Qed.

End WITH_POINTER_DATA.

(** An example instance of the memory *)
Module MemoryI : MemoryT.

  Section WITH_POINTER_DATA.
  Context {pd: PointerData}.

  Lemma addP p k: add p k = (p + wrepr Uptr k)%R.
  Proof. done. Qed.

  Definition is_zalloc T (m: Mz.t T) (p:Z) : bool :=
    if Mz.get m p is Some _ then true else false.

  Record frame := { frame_off : Z; frame_size : Z ; frame_padding : Z }.

  Definition footprint_of_frame (f: frame) : Z :=
    frame_size f + frame_padding f.

  (** Total size of the stack, padding included *)
  Definition footprint_of_stack (frames: seq frame) :=
    foldr (λ f, Z.add (footprint_of_frame f)) 0 frames.

  (** Frames are valid when:
    - sizes are positive
    - stack does not overflow
  *)
  Definition valid_frame (f: frame) : bool :=
    [&& 0 <=? frame_off f, frame_off f <=? frame_size f & 0 <=? frame_padding f].

  Definition valid_frames (stk_limit stk_root: pointer) (frames: seq frame) :=
    all valid_frame frames && (footprint_of_stack frames <=? wunsigned stk_root - wunsigned stk_limit).

  (* The address [ptr] belongs to one stack frame *)
  Fixpoint pointer_into_stack (ptr: Z) (stk_root: pointer) (frames: seq frame) : bool :=
    if frames is f :: frames'
    then
      let: base := wunsigned stk_root - footprint_of_stack frames in
      (* pointer to this frame *)
      ((base + frame_off f <=? ptr) && (ptr <? base + frame_size f))
      ||
      (* pointer to an other frame *)
      pointer_into_stack ptr stk_root frames'
    else false (* no stack *).

  Record mem_ := {
    data      : Mz.t u8;
    alloc     : Mz.t unit;
    stk_root  : pointer; (* root of the stack *)
    stk_limit : pointer; (* limit of the stack *)
    frames    : seq frame; (* shape of the frames on the stack *)
    framesP   : valid_frames stk_limit stk_root frames;
    stk_allocP x : pointer_into_stack x stk_root frames → is_zalloc alloc x;
    stk_freeP x : 0 <= x < wunsigned stk_root - footprint_of_stack frames → is_zalloc alloc x = false;
  }.

  #[ global ] Arguments stk_allocP : clear implicits.
  #[ global ] Arguments stk_freeP : clear implicits.

  Definition mem := mem_.

  Definition is_alloc (m:mem) (p:pointer) :=
    is_zalloc m.(alloc) (wunsigned p).

  Definition is_init (m:mem) (p:pointer) :=
    is_zalloc m.(data) (wunsigned p).

  Definition get (m:mem) (p:pointer) :=
    Let _ := assert (is_alloc m p && is_init m p) ErrAddrInvalid in
    ok (odflt 0%R (Mz.get m.(data) (wunsigned p))).

  Definition set (m:mem) (p:pointer) (w:u8) :=
    Let _ := assert (is_alloc m p) ErrAddrInvalid in
    ok {| data      := Mz.set m.(data) (wunsigned p) w ;
          alloc     := m.(alloc);
          stk_root  := m.(stk_root);
          stk_limit := m.(stk_limit);
          frames    := m.(frames);
          framesP   := m.(framesP);
          stk_allocP   := m.(stk_allocP);
          stk_freeP   := m.(stk_freeP);
       |}.

  Lemma is_allocP m p w : reflect (exists m', set m p w = ok m') (is_alloc m p).
  Proof.
    by (rewrite /set; case:is_alloc => /=; constructor) => [ | []//]; eexists;eauto.
  Qed.

  Lemma is_alloc_set m p w m' p' : set m p w = ok m' -> is_alloc m' p' = is_alloc m p'.
  Proof. by rewrite /set; t_xrbindP => _ <-. Qed.

  Lemma setP m p w p' m' :
    set m p w = ok m' ->
    get m' p' = if p == p' then ok w else get m p'.
  Proof.
    rewrite /set /get; t_xrbindP => ha <- /=.
    rewrite /is_init /is_alloc /=.
    case heq: is_zalloc => //=; last by move: ha heq; rewrite /is_alloc; case:eqP => // <- ->.
    rewrite /is_zalloc Mz.setP.
    have -> : (wunsigned p == wunsigned p') = (p == p'); last by case: eqP.
    apply: sameP; first by apply eqP.
    by apply (iffP eqP) => [-> | /wunsigned_inj].
  Qed.

  Lemma get_valid8 m p w : get m p = ok w -> is_alloc m p.
  Proof. by rewrite /get; t_xrbindP => /andP []. Qed.

  #[ global ]
  Instance CM : coreMem pointer mem :=
    CoreMem setP is_allocP get_valid8 is_alloc_set.

  Lemma is_align_wunsigned_add ptr ws i :
    is_align ptr ws →
    0 <= i < wsize_size ws →
    wunsigned (add ptr i) = wunsigned ptr + i.
  Proof.
    move => /is_align_no_overflow /lezP ??.
    rewrite wunsigned_add //.
    have := wunsigned_range ptr.
    Psatz.lia.
  Qed.

  Definition bounded (z1 z2 z3: Z) := (z1 <=? z2) && (z2 <? z3).

  Lemma footprint_of_valid_frame f :
    valid_frame f →
    0 <= footprint_of_frame f.
  Proof.
    case: f => off s e /and3P /= []; rewrite !zify /footprint_of_frame => /= *.
    Psatz.lia.
  Qed.

  Lemma footprint_of_valid_frames frames :
    all valid_frame frames →
    0 <= footprint_of_stack frames.
  Proof.
    elim: frames; first reflexivity.
    move => f frames ih /= /andP[] /footprint_of_valid_frame ok_f /ih{ih}.
    Psatz.lia.
  Qed.

  Lemma frame_size_in_footprint f :
    valid_frame f →
    0 <= frame_size f <= footprint_of_frame f.
  Proof.
    case/and3P; rewrite !zify => o_pos o_s e_pos; split; first Psatz.lia.
    rewrite /footprint_of_frame.
    Psatz.lia.
  Qed.

  Lemma stack_range ptr stk_root frames :
    all valid_frame frames →
    pointer_into_stack ptr stk_root frames →
    wunsigned stk_root - footprint_of_stack frames <= ptr ∧ ptr < wunsigned stk_root.
  Proof.
    elim: frames => // f frames ih /andP[] ok_f ok_fr /orP[]; last first.
    - move => /ih{ih} /(_ ok_fr).
      have /= := footprint_of_valid_frame ok_f.
      Psatz.lia.
    rewrite !zify => {ih}.
    have := footprint_of_valid_frames ok_fr.
    have /= := frame_size_in_footprint ok_f.
    case/and3P: ok_f; rewrite !zify.
    Psatz.lia.
  Qed.

  Definition top_stack (m:mem) :=
    add m.(stk_root) (- footprint_of_stack m.(frames)).

  Definition set_alloc_aux T b (m:Mz.t T) (ptr sz:Z) :=
    foldl (fun m k => if b is Some t then Mz.set m k t else Mz.remove m k) m (ziota ptr sz).

  Definition set_alloc b (m:Mz.t unit) (ptr sz:Z) :=
    set_alloc_aux (if b then Some tt else None) m ptr sz.

  Definition clear_data (m:Mz.t u8) (ptr sz:Z) :=
    set_alloc_aux None m ptr sz.

  Lemma set_alloc_auxP (T:eqType) (b:option T) m p sz x :
    Mz.get (set_alloc_aux b m p sz) x =
      if (p <=? x) && (x <? p + sz) then b else Mz.get m x.
  Proof.
    rewrite /set_alloc_aux -in_ziota; elim: ziota m => //= i l hrec m.
    rewrite in_cons hrec orbC; case: {hrec} b => [t | ];
    by case: ifP => //= ?;rewrite /is_zalloc (Mz.setP, Mz.removeP) eq_sym; case: ifP.
  Qed.

  Lemma set_allocP b m p sz x :
    is_zalloc (set_alloc b m p sz) x =
      if (p <=? x) && (x <? p + sz) then b else is_zalloc m x.
  Proof. by rewrite /is_zalloc set_alloc_auxP; case: ifP => //; case: b. Qed.

  Lemma clear_dataP m p sz x :
    is_zalloc (clear_data m p sz) x =
      is_zalloc m x && ~~((p <=? x) && (x <? p + sz)).
  Proof. by rewrite /is_zalloc set_alloc_auxP; case: ifP; rewrite /= (andbT, andbF). Qed.

  (** Stack blocks: association list of frame pointers to frame sizes (data only) *)
  Definition stack_blocks_rec stk_root (frames: seq frame) :=
    foldr (λ f '(p, blk), let: s := footprint_of_frame f in let: q := add p (- s) in (q, q :: blk)) (stk_root, [::]) frames.

  Definition stack_blocks stk_root frames : seq pointer :=
    (stack_blocks_rec stk_root frames).2.

  Definition stack_frames (m: mem) : seq pointer :=
    stack_blocks m.(stk_root) m.(frames).

  Lemma stack_blocks_rec_fst stk_root frames :
    (stack_blocks_rec stk_root frames).1 = add stk_root (- footprint_of_stack frames).
  Proof.
    elim: frames; first by rewrite add_0.
    move => f stk /=.
    case: (stack_blocks_rec _ _) => /= _ _ ->; rewrite addC; congr (add stk_root).
    Psatz.lia.
  Qed.

  Lemma stack_blocks_rec_snd stk_root frames :
    if (stack_blocks_rec stk_root frames).2 is p :: tl
    then p = add stk_root (- footprint_of_stack frames)
    else frames = [::].
  Proof.
    elim: frames => // f fr.
    have /= := (stack_blocks_rec_fst stk_root fr).
    case: (stack_blocks_rec _ _) => /= top [] //=.
    - move => -> -> /=; rewrite addC; congr (add _); Psatz.lia.
    case => _ _ _ -> _; rewrite addC; congr (add _); Psatz.lia.
  Qed.

  (** Allocation of a fresh block. *)
  Lemma alloc_stack_framesP C (m: mem) s :
     [&& valid_frame s, footprint_of_frame s + footprint_of_stack m.(frames) <=? wunsigned m.(stk_root) - wunsigned m.(stk_limit) & C] →
    valid_frames m.(stk_limit) m.(stk_root) (s :: m.(frames)).
  Proof.
    case/and3P => ok_s ofs _; apply/andP; split; first (apply/andP; split).
    - exact: ok_s.
    - by have /andP[? _] := m.(framesP).
    exact: ofs.
  Qed.

  Lemma alloc_stack_stk_allocP (m: mem) f x :
    pointer_into_stack x (stk_root m) (f :: frames m) →
    is_zalloc (set_alloc true (alloc m)
                         (wunsigned m.(stk_root) - (footprint_of_frame f + footprint_of_stack m.(frames)) + frame_off f)
                         (frame_size f - frame_off f)) x.
  Proof.
    rewrite set_allocP /pointer_into_stack -/pointer_into_stack.
    have -> : wunsigned (stk_root m) - (footprint_of_frame f + footprint_of_stack (frames m)) + frame_off f +
                 (frame_size f - frame_off f) =
              wunsigned (stk_root m) - (footprint_of_frame f + footprint_of_stack (frames m))+
                 frame_size f by ring.
    apply: orX => /= -> //.
    exact: m.(stk_allocP).
  Qed.
  Arguments alloc_stack_stk_allocP [m f] x.

  Lemma alloc_stack_stk_freeP C (m: mem) f x :
    [&& valid_frame f, footprint_of_frame f + footprint_of_stack (frames m) <=? wunsigned (stk_root m) - wunsigned (stk_limit m) & C] →
    0 <= x < wunsigned (stk_root m) - footprint_of_stack (f :: frames m) →
    is_zalloc (set_alloc true (alloc m)
        (wunsigned (stk_root m) - (footprint_of_frame f + footprint_of_stack (frames m)) + frame_off f)
        (frame_size f - frame_off f)) x = false.
  Proof.
    case/andP => /dup [] /footprint_of_valid_frame ok_f /and3P [] /ZleP h0fo /ZleP hfo _ ok_ws /= range.
    rewrite set_allocP.
    case: ifPn; rewrite !zify; first Psatz.lia.
    move => nrange; apply: m.(stk_freeP); Psatz.lia.
  Qed.

  Definition alloc_stack (m: mem) (ws: wsize) (sz ioff sz': Z) : exec mem :=
    let: top := align_word ws (add (top_stack m) (- (sz + sz'))) in
    let: padding := sub (top_stack m) top - sz in
    let: f := {| frame_off := ioff; frame_size := sz ; frame_padding := padding |} in
    let: ok_f := valid_frame f in
    let: no_overflow := footprint_of_frame f + footprint_of_stack (frames m) <=? wunsigned (stk_root m) - wunsigned (stk_limit m) in
    let: enough_padding := sz' <=? padding in
    match Sumbool.sumbool_of_bool [&& ok_f, no_overflow & enough_padding ] with
    | right _ => Error ErrStack
    | left C =>
      ok
        {| data := clear_data m.(data) (wunsigned m.(stk_root) - (footprint_of_frame f + footprint_of_stack m.(frames)) + frame_off f) (f.(frame_size) - frame_off f);
           alloc := set_alloc true m.(alloc) (wunsigned m.(stk_root) - (footprint_of_frame f + footprint_of_stack m.(frames)) + frame_off f) (f.(frame_size) - frame_off f);
           stk_root := m.(stk_root);
           stk_limit := m.(stk_limit);
           frames := f :: m.(frames);
           framesP := alloc_stack_framesP C;
           stk_allocP x := alloc_stack_stk_allocP x;
           stk_freeP x :=  alloc_stack_stk_freeP C;
        |}
    end.

  (** Free *)
  Lemma free_stack_framesP (m: mem) :
    valid_frames (stk_limit m) (stk_root m) (behead (frames m)).
  Proof.
    have /andP[h /lezP k] := m.(framesP).
    apply/andP; split.
    - by case: {k} (frames m) h => //= ? ? /andP[].
    rewrite zify.
    have [??] := wunsigned_range m.(stk_root).
    case: (frames m) h k => // f fs /andP[] /footprint_of_valid_frame ? _ /=.
    Psatz.lia.
  Qed.

  Lemma free_stack_stk_allocP (m: mem) x :
    pointer_into_stack x (stk_root m) (behead (frames m)) →
    is_zalloc (set_alloc false (alloc m) (wunsigned (stk_root m) - footprint_of_stack (frames m)) (odflt 0 (omap footprint_of_frame (ohead (frames m))))) x.
  Proof.
    case: (frames m) m.(framesP) m.(stk_allocP) => // f frames /andP[] /= /andP[] ok_f valid_frames /lezP no_overflow /(_ x) old_allocated range.
    rewrite set_allocP.
    move: old_allocated; rewrite range orbT => /(_ erefl) ->.
    have := stack_range valid_frames range.
    case: andP => //; rewrite !zify {range}.
    Psatz.lia.
  Qed.
  #[ global ] Arguments free_stack_stk_allocP : clear implicits.

  Lemma free_stack_stk_freeP (m: mem) x :
    0 <= x < wunsigned (stk_root m) - footprint_of_stack (behead (frames m)) →
    is_zalloc (set_alloc false (alloc m) (wunsigned (stk_root m) - footprint_of_stack (frames m)) (odflt 0 (omap footprint_of_frame (ohead (frames m))))) x = false.
  Proof.
    move => range.
    have old_free := m.(stk_freeP) x.
    rewrite set_allocP; case: ifPn => // nrange.
    apply: old_free.
    split; first Psatz.lia.
    case: (frames m) m.(framesP) range nrange => //= f stk; first Psatz.lia.
    case/andP => /= /andP[] _ valid_frames _.
    have := footprint_of_valid_frames valid_frames.
    rewrite !zify; Psatz.lia.
  Qed.
  #[ global ] Arguments free_stack_stk_freeP : clear implicits.

  Definition free_stack (m: mem) : mem :=
    let sz := odflt 0 (omap footprint_of_frame (ohead m.(frames))) in
    {| data := m.(data);
       alloc := set_alloc false m.(alloc) (wunsigned m.(stk_root) - (footprint_of_stack m.(frames))) sz;
       stk_root := m.(stk_root);
       stk_limit := m.(stk_limit);
       frames := behead m.(frames);
       framesP := free_stack_framesP m;
       stk_allocP := free_stack_stk_allocP m;
       stk_freeP := free_stack_stk_freeP m;
    |}.

  (** Initial memory: empty with pre-allocated blocks.
    The stack is rooted at the higest aligned pointer below the lowest allocated address.
   *)
  Definition init_mem_alloc (s: seq (pointer * Z)) : Mz.t unit :=
    foldl (fun a pz => set_alloc true a (wunsigned pz.1) pz.2) (Mz.empty _) s.

  Definition all_above (s: seq (pointer * Z)) (stk: pointer) : bool :=
    all (λ '(p, _), wlt Unsigned stk p) s.

  Lemma init_mem_framesP stk_root :
    valid_frames 0 stk_root [::].
  Proof. apply/lezP; rewrite Z.sub_0_r; exact: (proj1 (wunsigned_range _)). Qed.

  Lemma init_mem_stk_allocP (stk_root: pointer) s x :
    false →
    is_zalloc (init_mem_alloc s) x.
  Proof. by []. Qed.

  Lemma init_mem_stk_freeP_aux s stk m :
    all_above s stk →
    ∀ x,
      0 <= x <= wunsigned stk →
      is_zalloc (foldl (λ a pz, set_alloc true a (wunsigned pz.1) pz.2) m s) x = is_zalloc m x.
  Proof.
    rewrite /all_above.
    elim: s m => //= - [p z] s ih m /andP[] /ltzP ok_p {}/ih ih x x_range.
    rewrite (ih _ _ x_range) {ih} set_allocP /=.
    move: ok_p; rewrite -/(wunsigned stk) -/(wunsigned p) => ok_p.
    case: andP => //; rewrite !zify.
    Psatz.lia.
  Qed.

  Lemma init_mem_stk_freeP s stk x :
   all_above s stk →
    0 <= x < wunsigned stk - 0 →
    is_zalloc (init_mem_alloc s) x = false.
  Proof.
    move => all_above x_range.
    rewrite /init_mem_alloc (init_mem_stk_freeP_aux (Mz.empty _) all_above) //; Psatz.lia.
  Qed.
  #[ global ] Arguments init_mem_stk_freeP : clear implicits.

  Definition init_mem (s: seq (pointer * Z)) (stk: pointer) : exec mem :=
    match Sumbool.sumbool_of_bool (is_align stk U256) with
    | right _ => Error ErrStack
    | left stk_align =>
    match Sumbool.sumbool_of_bool (all_above s stk) with
    | right _ => Error ErrStack
    | left stk_below =>
      ok
        {| data := Mz.empty _;
           alloc := init_mem_alloc s;
           stk_limit := 0%R;
           stk_root := stk;
           frames := [::];
           framesP := init_mem_framesP stk;
           stk_allocP := init_mem_stk_allocP stk s;
           stk_freeP p := init_mem_stk_freeP s stk p stk_below;
        |}
    end end.

  Lemma _top_stackE (m: mem) :
    head (stk_root m) (stack_frames m) = top_stack m.
  Proof.
    rewrite /stack_frames /top_stack /stack_blocks.
    have := stack_blocks_rec_snd (stk_root m) (frames m).
    case: (stack_blocks_rec _ _) => /= _ [] //.
    by move => ->; rewrite add_0.
  Qed.

  Lemma stack_region_is_free (m: mem) (p: pointer) :
    wunsigned (stk_limit m) <= wunsigned p < wunsigned (head (stk_root m) (stack_frames m)) →
    ~~ validw m p U8.
  Proof.
    rewrite _top_stackE => - [] p_lo p_hi.
    rewrite /validw is_align8 /= add_0 andbT /is_alloc (stk_freeP m) //; split.
    + by have [] := wunsigned_range p.
    move: p_hi; rewrite /top_stack.
    rewrite wunsigned_add //.
    have /andP[/footprint_of_valid_frames] := framesP m.
    rewrite zify.
    have := wunsigned_range (stk_root m).
    have := wunsigned_range (stk_limit m).
    Psatz.lia.
  Qed.

  Lemma top_stack_below_root (m: mem) :
    wunsigned (head (stk_root m) (stack_frames m)) <= wunsigned (stk_root m).
    Proof.
      have /andP[/footprint_of_valid_frames] := framesP m.
      rewrite zify _top_stackE /top_stack.
      move => fp_lo fp_hi.
      have limit_range := wunsigned_range (stk_limit m).
      rewrite wunsigned_add.
      2: have := wunsigned_range (stk_root m).
      all: Lia.lia.
    Qed.

  #[ global ]
  Instance M : memory CM  :=
    Memory stk_root stk_limit stack_frames alloc_stack free_stack init_mem stack_region_is_free top_stack_below_root.

  Lemma top_stackE (m: mem) :
    memory_model.top_stack m = top_stack m.
  Proof. exact: _top_stackE. Qed.

  Lemma write_mem_invariant T (P: mem → T) :
    (∀ m p v,
      is_alloc m p →
      P {| data := Mz.set (data m) (wunsigned p) v;
           alloc := alloc m;
           stk_root := stk_root m;
           stk_limit := stk_limit m;
           frames := frames m;
           framesP := framesP m;
           stk_allocP := stk_allocP m;
           stk_freeP := stk_freeP m |} = P m) →
    ∀ m p s (v: word s) m',
      write m p v = ok m' →
      P m  = P m'.
  Proof.
    move => K m p s v m'; rewrite /write; t_xrbindP => _.
    elim: ziota m => //=; first by move=> ? [->].
    by move=> ?? hrec; rewrite {2}/set; t_xrbindP => ?? /K h <- /hrec <-.
  Qed.

  Lemma top_stack_write_mem m p s (v: word s) m' :
    write m p v = ok m' →
    top_stack m = top_stack m'.
  Proof. by apply write_mem_invariant. Qed.

  Lemma write_mem_stable m m' p s (v:word s) :
    write m p v = ok m' -> stack_stable m m'.
  Proof. by move => ok_m'; split => /=; exact: write_mem_invariant ok_m'. Qed.

  (** Allocation *)
  Lemma footprint_of_stack_pos (m: mem) :
    0 <= footprint_of_stack m.(frames).
  Proof.
    have /andP[h _] := m.(framesP).
    exact: footprint_of_valid_frames.
  Qed.
  #[ global ] Arguments footprint_of_stack_pos : clear implicits.

  Lemma Zleb_succ (x y: Z) :
    (x + 1 <=? y) = (x <? y).
  Proof. case: Z.leb_spec; case: Z.ltb_spec => //; Psatz.lia. Qed.

  Lemma ass_above_limit m ws_stk sz ioff sz' m' :
    alloc_stack m ws_stk sz ioff sz' = ok m' →
    wunsigned (stack_limit m) <= wunsigned (top_stack m')
    ∧ wunsigned (top_stack m') + sz + Z.max 0 sz' <= wunsigned (top_stack m).
  Proof.
    rewrite /alloc_stack; case: Sumbool.sumbool_of_bool => // h [<-].
    rewrite /top_stack /=.
    rewrite !addE.
    case/and3P: h => ok_f /ZleP.
    case/and3P: (ok_f) => /ZleP /= ioff_pos /ZleP ioff_sz /ZleP padding_pos.
    have {ok_f} := footprint_of_valid_frame ok_f.
    set f := {| frame_size := sz |}.
    move => f_pos h.
    move => /lezP large_padding.
    have fs_pos := footprint_of_stack_pos m.
    have limit_range := wunsigned_range (stk_limit m).
    have root_range := wunsigned_range (stk_root m).
    rewrite !wunsigned_add; first split.
    1, 3-4: Psatz.lia.
    rewrite /f /footprint_of_frame /=.
    Psatz.lia.
  Qed.

  Lemma alloc_stack_ioff  m ws_stk sz ioff sz' m' :
    alloc_stack m ws_stk sz ioff sz' = ok m' →
    0 <= ioff /\ ioff <= sz.
  Proof.
    rewrite /alloc_stack; case: Sumbool.sumbool_of_bool => //= + _ => /and3P [] /and3P /= [].
    by rewrite !zify.
  Qed.

  Lemma ass_valid m ws_stk sz ioff sz' m' :
    alloc_stack m ws_stk sz ioff sz' = ok m' →
    ∀ p,
    validw m' p U8 =
    validw m p U8 || between (top_stack m' + wrepr _ ioff) (sz - ioff) p U8.
  Proof.
    move=> h p.
    have [h1 h2] := alloc_stack_ioff h.
    have := ass_above_limit h.
    move: h; rewrite /alloc_stack; case: Sumbool.sumbool_of_bool => // h [<-] /=.
    rewrite -!valid8_validw /valid8 /= /is_alloc /top_stack /=.
    case/and3P: h.
    set fr := {| frame_size := sz |} => /dup [] ok_f /and3P[] /ZleP h0fo hfo _ /lezP no_ovf _.
    rewrite set_allocP /between /zbetween Zleb_succ.
    have b_pos := wunsigned_range m.(stk_root).
    have l_pos := wunsigned_range m.(stk_limit).
    have f_pos := footprint_of_stack_pos m.
    have s_pos := footprint_of_valid_frame ok_f.
    assert (h := wunsigned_range (add (stk_root m) (- footprint_of_stack (frames m)))).
    move=> habove.
    rewrite !wunsigned_add.
    + by case: ifP => _;rewrite (orbT, orbF).
    1,3:Psatz.lia.
    split; first Psatz.lia.
    move: habove; rewrite wunsigned_add; last Psatz.lia.
    Psatz.lia.
  Qed.

  Lemma ass_fresh m ws_stk sz ioff sz' m' :
    alloc_stack m ws_stk sz ioff sz' = ok m' →
    ∀ p s,
      validw m p s →
      (wunsigned p + wsize_size s <= wunsigned (top_stack m') ∨ wunsigned (top_stack m') + sz <= wunsigned p).
  Proof.
    move => X; have := m.(stk_freeP); move: X.
    rewrite /alloc_stack; case: Sumbool.sumbool_of_bool => // h [<-] /= stk_fresh p s /andP[] p_align p_alloc.
    rewrite /top_stack /=.
    right. apply/lezP; case: lezP => // /Z.nle_gt X.
    rewrite -(stk_fresh (wunsigned p)).
    - by move/allP: p_alloc => /(_ 0); rewrite in_ziota /= (proj2 (Z.ltb_lt _ _) (wsize_size_pos s)) add_0 => /(_ erefl).
    split. apply wunsigned_range.
    apply: (Z.lt_le_trans _ _ _ X).
    clear X.
    case/and3P: h => ok_f /lezP ovf _.
    have rt_range := wunsigned_range (stk_root m).
    have l_range := wunsigned_range (stk_limit m).
    have {ok_f}/= := frame_size_in_footprint ok_f.
    move: (footprint_of_frame _) ovf => fr ovf fr_pos.
    have /andP[/footprint_of_valid_frames ok_s _] := framesP m.
    rewrite wunsigned_add; Psatz.lia.
  Qed.

  Lemma ass_init m ws_stk sz ioff sz' m' :
    alloc_stack m ws_stk sz ioff sz' = ok m' →
    ∀ p,
     is_init m' p = is_init m p && ~~between (top_stack m' + wrepr _ ioff) (sz - ioff) p U8.
  Proof.
    move=> h p.
    have [h1 h2] := alloc_stack_ioff h.
    have := ass_above_limit h.
    move: h; rewrite /alloc_stack; case: Sumbool.sumbool_of_bool => // h [<-].
    rewrite /= /is_init /top_stack /=.
    case/and3P: h.
    set fr := {| frame_size := sz |} => ok_f /lezP no_ovf _.
    rewrite clear_dataP /between /zbetween.
    have b_pos := wunsigned_range m.(stk_root).
    have l_pos := wunsigned_range m.(stk_limit).
    have f_pos := footprint_of_stack_pos m.
    have s_pos := footprint_of_valid_frame ok_f.
    move=> h; rewrite !wunsigned_add. 2,4: by Psatz.lia.
    + by rewrite Zleb_succ.
    assert (add_pos := wunsigned_range  (add (stk_root m) (- footprint_of_stack (frames m)))).
    move: h; rewrite wunsigned_add; Psatz.lia.
  Qed.

  Lemma ass_read_old8 m ws_stk sz ioff sz' m' :
    alloc_stack m ws_stk sz ioff sz' = ok m' →
    ∀ p,
    validw m p U8 →
    read m p U8 = read m' p U8.
  Proof.
    move => ok_m' p ok_m_p.
    have : validw m' p U8 by rewrite (ass_valid ok_m') ok_m_p.
    have := ass_fresh ok_m' ok_m_p.
    move: ok_m_p; rewrite -!valid8_validw -!get_read8 /memory_model.get /= /get wsize8.
    move=> -> hfresh ->; rewrite (ass_init ok_m').
    have -> : ~~ between (top_stack m' + wrepr _ ioff) (sz - ioff) p U8.
    + rewrite /between !zify wsize8.
      have ? := ass_above_limit ok_m'. have ? := alloc_stack_ioff ok_m'.
      rewrite wunsigned_add; first by Psatz.lia.
      by assert (h1 := wunsigned_range (top_stack m)); assert (h2 := wunsigned_range (top_stack m')); Psatz.lia.
    rewrite /= andbT.
    move: ok_m' hfresh.
    rewrite /alloc_stack; case: Sumbool.sumbool_of_bool => // h [<-].
    rewrite /top_stack /= => /= hfresh.
    case heq: is_init => //=; do 2!f_equal.
    rewrite /= /clear_data set_alloc_auxP.
    case: ifP => //.
    case/and3P: h hfresh.
    set fr := {| frame_size := sz |} => ok_f /lezP no_ovf _.
    have b_pos := wunsigned_range m.(stk_root).
    have l_pos := wunsigned_range m.(stk_limit).
    have f_pos := footprint_of_stack_pos m.
    have s_pos := footprint_of_valid_frame ok_f.
    rewrite !zify wunsigned_add; last Psatz.lia.
    case /and3P: ok_f; rewrite !zify /=; Psatz.lia.
  Qed.

  Lemma ass_read_new m ws_stk sz ioff sz' m' :
    alloc_stack m ws_stk sz ioff sz' = ok m' →
    ∀ p,
    ~validw m p U8 → validw m' p U8 →
    read m' p U8 = Error ErrAddrInvalid.
  Proof.
    move=> ha p.
    rewrite (ass_valid ha) => /negP /negbTE -> /=.
    rewrite -get_read8 /memory_model.get /= /get (ass_init ha) => ->.
    by rewrite !andbF.
  Qed.

  Lemma ass_align m ws_stk sz ioff sz' m' :
    alloc_stack m ws_stk sz ioff sz' = ok m' →
    is_align (top_stack m') ws_stk.
  Proof.
    rewrite /alloc_stack; case: Sumbool.sumbool_of_bool => // h [<-].
    rewrite /top_stack /=.
    move: h => /andP[] /and3P[] /= /ZleP ok_f /ZleP hioffsz.
    have /andP[ok_fs _] := framesP m.
    have fs_pos := footprint_of_valid_frames ok_fs.
    rewrite /footprint_of_frame /=.
    move: (footprint_of_stack _) fs_pos => fs sz_pos fs_pos _.
    rewrite !addE !subE !(wrepr_opp, wrepr_add, wrepr_unsigned, align_wordE).
    set x := (X in is_align X).
    have -> : x = align_word ws_stk (stk_root m - wrepr _ fs - (wrepr _ sz + wrepr _ sz')).
    + by rewrite /x; ssring.
    rewrite /is_align p_to_zE; apply align_word_aligned.
  Qed.

  Lemma ass_root m ws_stk sz ioff sz' m' :
    alloc_stack m ws_stk sz ioff sz' = ok m' →
    stack_root m' = stack_root m.
  Proof. by rewrite /alloc_stack; case: Sumbool.sumbool_of_bool => // h [<-]. Qed.

  Lemma ass_limit m ws_stk sz ioff sz' m' :
    alloc_stack m ws_stk sz ioff sz' = ok m' →
    stack_limit m' = stack_limit m.
  Proof. by rewrite /alloc_stack; case: Sumbool.sumbool_of_bool => // h [<-]. Qed.

  Lemma ass_frames m ws_stk sz ioff sz' m' :
    alloc_stack m ws_stk sz ioff sz' = ok m' →
    stack_frames m' = top_stack_after_alloc (top_stack m) ws_stk (sz + sz') :: stack_frames m.
  Proof.
    rewrite /alloc_stack; case: Sumbool.sumbool_of_bool => // h [<-] /=.
    rewrite /stack_frames /=.
    rewrite {1}/stack_blocks /=.
    case heq: (stack_blocks_rec _ _) => [p blk].
    rewrite /stack_blocks heq /=.
    rewrite {1}/top_stack -stack_blocks_rec_fst heq /=.
    congr cons.
    rewrite /top_stack_after_alloc.
    move: (align_word _ _) => q.
    rewrite /footprint_of_frame /=.
    by rewrite Zplus_minus add_p_opp_sub_p.
  Qed.

  Lemma alloc_stackP m m' ws_stk sz ioff sz' :
    alloc_stack m ws_stk sz ioff sz' = ok m' -> alloc_stack_spec m ws_stk sz ioff sz' m'.
  Proof.
    move => o.
    split; rewrite ?top_stackE.
    - exact: ass_read_old8 o.
    - exact: ass_read_new o.
    - exact: ass_valid o.
    - exact: ass_align o.
    - exact: ass_above_limit o.
    - exact: alloc_stack_ioff o.
    - exact: ass_fresh o.
    - exact: ass_root o.
    - exact: ass_limit o.
    exact: ass_frames o.
  Qed.

  Lemma first_frameE (m: mem) :
    odflt 0 (omap footprint_of_frame (ohead (frames m))) = wunsigned (top_stack (free_stack m)) - wunsigned (top_stack m).
  Proof.
    rewrite /top_stack /=.
    have /andP[] := framesP m.
    case: (frames m) => /=.
    + rewrite add_0; Psatz.lia.
    move => f fr /andP[] ok_f ok_fr /lezP noovf.
    have ff := footprint_of_valid_frame ok_f.
    have fs := footprint_of_valid_frames ok_fr.
    have rr := wunsigned_range (stk_root m).
    have lr := wunsigned_range (stk_limit m).
    rewrite !wunsigned_add; Psatz.lia.
  Qed.

  Lemma wunsigned_top_stack m :
    wunsigned (top_stack m) = wunsigned (stk_root m) - footprint_of_stack (frames m).
  Proof.
    have /andP[ /footprint_of_valid_frames ? /lezP h ] := framesP m.
    rewrite /top_stack wunsigned_add //.
    have := wunsigned_range (stk_root m).
    have := wunsigned_range (stk_limit m).
    Psatz.lia.
  Qed.

  Lemma fss_valid m p :
    validw (free_stack m) p U8 = validw m p U8 && ~~ pointer_range (top_stack m) (top_stack (free_stack m)) p.
  Proof.
    rewrite -!valid8_validw /valid8 /=.
    rewrite /is_alloc /= set_allocP.
    set B := (X in if X then _ else _).
    suff -> : B = pointer_range (top_stack m) (top_stack (free_stack m)) p.
    + by case: ifP => _; rewrite ?andbF ?andbT.
    subst B.
    have P (a b: bool) : a ↔ b → a = b :> bool.
    + case: a b => - [] //; last by intuition.
      by case => /(_ erefl).
    apply: P.
    rewrite !zify first_frameE !wunsigned_top_stack.
    change (stk_root (free_stack m)) with (stk_root m).
    Psatz.lia.
  Qed.

  Lemma fss_read_old8 m p :
    validw (free_stack m) p U8 →
    read m p U8 = read (free_stack m) p U8.
  Proof.
    move => /dup [] hv'; rewrite (fss_valid m) => /andP[] hv hp.
    by move: hv' hv; rewrite -!valid8_validw -!get_read8 /memory_model.get /= /get => -> ->.
  Qed.

  Lemma free_stackP m :
    free_stack_spec m (free_stack m).
  Proof.
    split => *.
    - exact: fss_read_old8.
    - rewrite !top_stackE; exact: fss_valid.
    - by [].
    - by [].
    rewrite /memory_model.frames /= /stack_frames /= /stack_blocks.
    case: (frames m) => //= f fr.
    by case: (stack_blocks_rec _ _).
  Qed.

  Lemma alloc_stack_complete m ws sz ioff sz' :
    let: old_size:= wunsigned (stack_root m) - wunsigned (memory_model.top_stack m) in
    let: max_size := wunsigned (stack_root m) - wunsigned (stack_limit m) in
    let: available := max_size - old_size in
    [&& 0 <=? ioff, ioff <=? sz, 0 <=? sz' &
    if is_align (memory_model.top_stack m) ws
    then round_ws ws (sz + sz') <=? available (* tight bound *)
    else sz + sz' + wsize_size ws - 1 <=? available (* loose bound, exact behavior is under-specified *)
    ] →
    ∃ m', alloc_stack m ws sz ioff sz' = ok m'.
  Proof.
    rewrite !top_stackE !zify => - [ioff_pos] [ioff_sz] [sz'_pos].
    rewrite /alloc_stack.
    rewrite /valid_frame /=.
    case: Sumbool.sumbool_of_bool; first by eauto.
    rewrite /footprint_of_frame /=.
    move => /negbT; rewrite !zify => X no_overflow; elim: X.
    refine ((λ x, conj (conj ioff_pos (conj ioff_sz (proj1 x))) (proj2 x)) _).
    have -> : footprint_of_stack (frames m) = wunsigned (stk_root m) - wunsigned (top_stack m).
    - by rewrite wunsigned_top_stack; ring.
    rewrite !subE.
    rewrite -/(top_stack_after_alloc (top_stack m) ws (sz + sz')).
    case: ifPn no_overflow => top_align; rewrite zify => no_overflow.
    { (* old top stack is aligned for ws *)
      have size_big := @round_ws_range ws (sz + sz').
      have size_small : 0 <= round_ws ws (sz + sz') <= wunsigned (top_stack m).
      - have := wunsigned_range (stk_limit m).
        Psatz.lia.
      rewrite top_stack_after_aligned_alloc //.
      rewrite GRing.opprD GRing.addrA GRing.subrr wrepr_opp GRing.opprK GRing.add0r.
      by have ? := wunsigned_range (top_stack m); rewrite wunsigned_repr_small; Psatz.lia.
    }
    (* old top stack is not aligned *)
    rewrite /top_stack_after_alloc.
    rewrite -(wrepr_unsigned (align_word _ _)).
    rewrite align_wordE wrepr_sub wrepr_unsigned.
    rewrite 2!GRing.opprD !GRing.addrA GRing.subrr GRing.add0r wrepr_opp !GRing.opprK.
    set x := (_ mod _).
    have ? := wsize_size_pos ws.
    have ? : 0 <= x < wsize_size ws by apply Z.mod_pos_bound.
    rewrite -wrepr_add.
    have ? := wunsigned_range (stk_limit m).
    have ? := wunsigned_range (top_stack m).
    rewrite wunsigned_repr_small; Psatz.lia.
  Qed.

  End WITH_POINTER_DATA.
End MemoryI.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Efficient implementation of [MSetInterface.S] for positive keys,
    inspired from the [FMapPositive] module.

   This module was adapted by Alexandre Ren, Damien Pous, and Thomas
   Braibant (2010, LIG, CNRS, UMR 5217), from the [FMapPositive]
   module of Pierre Letouzey and Jean-Christophe Filliâtre, which in
   turn comes from the [FMap] framework of a work by Xavier Leroy and
   Sandrine Blazy (used for building certified compilers).
*)

Require Import Bool BinPos Orders OrdersEx MSetInterface.

Set Implicit Arguments.
Local Open Scope lazy_bool_scope.
Local Open Scope positive_scope.
Local Unset Elimination Schemes.

Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.

  Module E:=PositiveOrderedTypeBits.

  Definition elt := positive : Type.

  Inductive tree :=
    | Leaf : tree
    | Node : tree -> bool -> tree -> tree.

  Scheme tree_ind := Induction for tree Sort Prop.

  Definition t := tree : Type.

  Definition empty : t := Leaf.

  Fixpoint is_empty (m : t) : bool :=
   match m with
    | Leaf => true
    | Node l b r => negb b &&& is_empty l &&& is_empty r
   end.

  Fixpoint mem (i : positive) (m : t) {struct m} : bool :=
    match m with
    | Leaf => false
    | Node l o r =>
        match i with
        | 1 => o
        | i~0 => mem i l
        | i~1 => mem i r
        end
    end.

  Fixpoint add (i : positive) (m : t) : t :=
    match m with
    | Leaf =>
        match i with
        | 1 => Node Leaf true Leaf
        | i~0 => Node (add i Leaf) false Leaf
        | i~1 => Node Leaf false (add i Leaf)
        end
    | Node l o r =>
        match i with
        | 1 => Node l true r
        | i~0 => Node (add i l) o r
        | i~1 => Node l o (add i r)
        end
    end.

  Definition singleton i := add i empty.

  (** helper function to avoid creating empty trees that are not leaves *)

  Definition node (l : t) (b: bool) (r : t) : t :=
    if b then Node l b r else
     match l,r with
       | Leaf,Leaf => Leaf
       | _,_ => Node l false r end.

  Fixpoint remove (i : positive) (m : t) {struct m} : t :=
    match m with
      | Leaf => Leaf
      | Node l o r =>
        match i with
          | 1 => node l false r
          | i~0 => node (remove i l) o r
          | i~1 => node l o (remove i r)
        end
    end.

  Fixpoint union (m m': t) : t :=
    match m with
      | Leaf => m'
      | Node l o r =>
        match m' with
          | Leaf => m
          | Node l' o' r' => Node (union l l') (o||o') (union r r')
        end
    end.

  Fixpoint inter (m m': t) : t :=
    match m with
      | Leaf => Leaf
      | Node l o r =>
        match m' with
          | Leaf => Leaf
          | Node l' o' r' => node (inter l l') (o&&o') (inter r r')
        end
    end.

  Fixpoint diff (m m': t) : t :=
    match m with
      | Leaf => Leaf
      | Node l o r =>
        match m' with
          | Leaf => m
          | Node l' o' r' => node (diff l l') (o&&negb o') (diff r r')
        end
    end.

  Fixpoint equal (m m': t): bool :=
    match m with
      | Leaf => is_empty m'
      | Node l o r =>
        match m' with
          | Leaf => is_empty m
          | Node l' o' r' => eqb o o' &&& equal l l' &&& equal r r'
        end
    end.

  Fixpoint subset (m m': t): bool :=
    match m with
      | Leaf => true
      | Node l o r =>
        match m' with
          | Leaf => is_empty m
          | Node l' o' r' => (negb o ||| o') &&& subset l l' &&& subset r r'
        end
    end.

  (** reverses [y] and concatenate it with [x] *)

  Fixpoint rev_append (y x : elt) : elt :=
    match y with
      | 1 => x
      | y~1 => rev_append y x~1
      | y~0 => rev_append y x~0
    end.
  Infix "@" := rev_append (at level 60).
  Definition rev x := x@1.

  Section Fold.

    Variables B : Type.
    Variable f : positive -> B -> B.

    (** the additional argument, [i], records the current path, in
       reverse order (this should be more efficient: we reverse this argument
       only at present nodes only, rather than at each node of the tree).
       we also use this convention in all functions below
     *)

    Fixpoint xfold (m : t) (v : B) (i : positive) :=
      match m with
        | Leaf => v
        | Node l true r =>
          xfold r (f (rev i) (xfold l v i~0)) i~1
        | Node l false r =>
          xfold r (xfold l v i~0) i~1
      end.
    Definition fold m i := xfold m i 1.

  End Fold.

  Section Quantifiers.

    Variable f : positive -> bool.

    Fixpoint xforall (m : t) (i : positive) :=
      match m with
        | Leaf => true
        | Node l o r =>
          (negb o ||| f (rev i)) &&& xforall r i~1 &&& xforall l i~0
      end.
    Definition for_all m := xforall m 1.

    Fixpoint xexists (m : t) (i : positive) :=
      match m with
        | Leaf => false
        | Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0
      end.
    Definition exists_ m := xexists m 1.

    Fixpoint xfilter (m : t) (i : positive) : t :=
      match m with
        | Leaf => Leaf
        | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1)
      end.
    Definition filter m := xfilter m 1.

    Fixpoint xpartition (m : t) (i : positive) : t * t :=
      match m with
        | Leaf => (Leaf,Leaf)
        | Node l o r =>
          let (lt,lf) := xpartition l i~0 in
          let (rt,rf) := xpartition r i~1 in
             if o then
               let fi := f (rev i) in
                 (node lt fi rt, node lf (negb fi) rf)
             else
                 (node lt false rt, node lf false rf)
      end.
    Definition partition m := xpartition m 1.

  End Quantifiers.

  (** uses [a] to accumulate values rather than doing a lot of concatenations *)

  Fixpoint xelements (m : t) (i : positive) (a: list positive) :=
    match m with
      | Leaf => a
      | Node l false r => xelements l i~0 (xelements r i~1 a)
      | Node l true r => xelements l i~0 (rev i :: xelements r i~1 a)
    end.

  Definition elements (m : t) := xelements m 1 nil.

  Fixpoint cardinal (m : t) : nat :=
    match m with
      | Leaf => O
      | Node l false r => (cardinal l + cardinal r)%nat
      | Node l true r => S (cardinal l + cardinal r)
    end.

  (** would it be more efficient to use a path like in the above functions ? *)

  Fixpoint choose (m: t) : option elt :=
    match m with
      | Leaf => None
      | Node l o r => if o then Some 1 else
        match choose l with
          | None => option_map xI (choose r)
          | Some i => Some i~0
        end
    end.

  Fixpoint min_elt (m: t) : option elt :=
    match m with
      | Leaf => None
      | Node l o r =>
        match min_elt l with
          | None => if o then Some 1 else option_map xI (min_elt r)
          | Some i => Some i~0
        end
    end.

  Fixpoint max_elt (m: t) : option elt :=
    match m with
      | Leaf => None
      | Node l o r =>
        match max_elt r with
          | None => if o then Some 1 else option_map xO (max_elt l)
          | Some i => Some i~1
        end
    end.

  (** lexicographic product, defined using a notation to keep things lazy *)

  Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end.

  Definition compare_bool a b :=
    match a,b with
      | false, true => Lt
      | true, false => Gt
      | _,_ => Eq
    end.

  Fixpoint compare (m m': t): comparison :=
    match m,m' with
      | Leaf,_ => if is_empty m' then Eq else Lt
      | _,Leaf => if is_empty m then Eq else Gt
      | Node l o r,Node l' o' r' =>
        lex (compare_bool o o') (lex (compare l l') (compare r r'))
    end.

  Definition In i t := mem i t = true.
  Definition Equal s s' := forall a : elt, In a  s <-> In a  s'.
  Definition Subset s s' := forall a : elt, In a s -> In a s'.
  Definition Empty s := forall a : elt, ~ In a s.
  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.

  Notation "s  [=]  t" := (Equal s t) (at level 70, no associativity).
  Notation "s  [<=]  t" := (Subset s t) (at level 70, no associativity).

  Definition eq := Equal.
  Definition lt m m' := compare m m' = Lt.

  (** Specification of [In] *)

  Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In.
  Proof.
   intros s s' Hs x x' Hx. rewrite Hs, Hx; intuition.
  Qed.

  (** Specification of [eq] *)

  Local Instance eq_equiv : Equivalence eq.
  Proof. firstorder. Qed.

  (** Specification of [mem] *)

  Lemma mem_spec: forall s x, mem x s = true <-> In x s.
  Proof. unfold In. intuition. Qed.

  (** Additional lemmas for mem  *)

  Lemma mem_Leaf: forall x, mem x Leaf = false.
  Proof. destruct x; trivial. Qed.

  (** Specification of [empty] *)

  Lemma empty_spec : Empty empty.
  Proof. unfold Empty, In. intro. rewrite mem_Leaf. discriminate. Qed.

  (** Specification of node  *)

  Lemma mem_node: forall x l o r, mem x (node l o r) = mem x (Node l o r).
  Proof.
    intros x l o r.
    case o; trivial.
    destruct l; trivial.
    destruct r; trivial.
    destruct x; reflexivity.
  Qed.
  Local Opaque node.

  (** Specification of [is_empty] *)

  Lemma is_empty_spec: forall s, is_empty s = true <-> Empty s.
  Proof.
    unfold Empty, In.
    induction s as [|l IHl o r IHr]; simpl.
      firstorder.
      rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear IHl IHr.
      destruct o; simpl; split.
        intuition discriminate.
        intro H. elim (H 1). reflexivity.
        intros H [a|a|]; apply H || intro; discriminate.
        intro H. split. split. reflexivity.
          intro a. apply (H a~0).
          intro a. apply (H a~1).
  Qed.

  (** Specification of [subset] *)

  Lemma subset_Leaf_s: forall s, Leaf [<=] s.
  Proof. intros s i Hi. apply empty_spec in Hi. elim Hi. Qed.

  Lemma subset_spec: forall s s', subset s s' = true <-> s [<=] s'.
  Proof.
    induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl.
      split; intros. apply subset_Leaf_s. reflexivity.

      split; intros. apply subset_Leaf_s. reflexivity.

      rewrite <- 2andb_lazy_alt, 2andb_true_iff, 2is_empty_spec.
      destruct o; simpl.
        split.
          intuition discriminate.
          intro H. elim (@empty_spec 1). apply H. reflexivity.
        split; intro H.
          destruct H as [[_ Hl] Hr].
          intros [i|i|] Hi.
            elim (Hr i Hi).
            elim (Hl i Hi).
            discriminate.
          split. split. reflexivity.
          unfold Empty. intros a H1. apply (@empty_spec (a~0)), H. assumption.
          unfold Empty. intros a H1. apply (@empty_spec (a~1)), H. assumption.

      rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear.
      destruct o; simpl.
       split; intro H.
         destruct H as [[Ho' Hl] Hr]. rewrite Ho'.
          intros i Hi. destruct i.
            apply (Hr i). assumption.
            apply (Hl i). assumption.
            assumption.
         split. split.
          destruct o'; trivial.
          specialize (H 1). unfold In in H. simpl in H. apply H. reflexivity.
          intros i Hi. apply (H i~0). apply Hi.
          intros i Hi. apply (H i~1). apply Hi.
       split; intros.
         intros i Hi. destruct i; destruct H as [[H Hl] Hr].
           apply (Hr i). assumption.
           apply (Hl i). assumption.
            discriminate Hi.
         split. split. reflexivity.
           intros i Hi. apply (H i~0). apply Hi.
           intros i Hi. apply (H i~1). apply Hi.
  Qed.

  (** Specification of [equal] (via subset) *)

  Lemma equal_subset: forall s s', equal s s' = subset s s' && subset s' s.
  Proof.
    induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl; trivial.
      destruct o. reflexivity. rewrite andb_comm. reflexivity.
      rewrite <- 6andb_lazy_alt. rewrite eq_iff_eq_true.
       rewrite 7andb_true_iff, eqb_true_iff.
      rewrite IHl, IHr, 2andb_true_iff. clear IHl IHr. intuition subst.
       destruct o'; reflexivity.
       destruct o'; reflexivity.
       destruct o; auto. destruct o'; trivial.
  Qed.

  Lemma equal_spec: forall s s', equal s s' = true <-> Equal s s'.
  Proof.
    intros. rewrite equal_subset. rewrite andb_true_iff.
    rewrite 2subset_spec. unfold Equal, Subset. firstorder.
  Qed.

  Lemma eq_dec : forall s s', { eq s s' } + { ~ eq s s' }.
  Proof.
    unfold eq.
    intros. case_eq (equal s s'); intro H.
     left. apply equal_spec, H.
     right. rewrite <- equal_spec. congruence.
  Defined.

  (** (Specified) definition of [compare] *)

  Lemma lex_Opp: forall u v u' v', u = CompOpp u' -> v = CompOpp v' ->
    lex u v = CompOpp (lex u' v').
  Proof. intros ? ? u' ? -> ->. case u'; reflexivity. Qed.

  Lemma compare_bool_inv: forall b b',
    compare_bool b b' = CompOpp (compare_bool b' b).
  Proof. intros [|] [|]; reflexivity. Qed.

  Lemma compare_inv: forall s s', compare s s' = CompOpp (compare s' s).
  Proof.
    induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']; trivial.
    unfold compare. case is_empty; reflexivity.
    unfold compare. case is_empty; reflexivity.
    simpl. rewrite compare_bool_inv.
     case compare_bool; simpl; trivial; apply lex_Opp; auto.
  Qed.

  Lemma lex_Eq: forall u v, lex u v = Eq <-> u=Eq /\ v=Eq.
  Proof. intros u v; destruct u; intuition discriminate. Qed.

  Lemma compare_bool_Eq: forall b1 b2,
    compare_bool b1 b2 = Eq <-> eqb b1 b2 = true.
  Proof. intros [|] [|]; intuition discriminate. Qed.

  Lemma compare_equal: forall s s', compare s s' = Eq <-> equal s s' = true.
  Proof.
    induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r'].
     simpl. tauto.
     unfold compare, equal. case is_empty; intuition discriminate.
     unfold compare, equal. case is_empty; intuition discriminate.
     simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff.
     rewrite <- IHl, <- IHr, <- compare_bool_Eq. clear IHl IHr.
     rewrite and_assoc. rewrite <- 2lex_Eq. reflexivity.
  Qed.

  Lemma compare_gt: forall s s', compare s s' = Gt -> lt s' s.
  Proof.
    unfold lt. intros s s'. rewrite compare_inv.
     case compare; trivial; intros; discriminate.
  Qed.

  Lemma compare_eq: forall s s', compare s s' = Eq -> eq s s'.
  Proof.
    unfold eq. intros s s'. rewrite compare_equal, equal_spec. trivial.
  Qed.

  Lemma compare_spec : forall s s' : t, CompSpec eq lt s s' (compare s s').
  Proof.
    intros. case_eq (compare s s'); intro H; constructor.
    apply compare_eq, H.
    assumption.
    apply compare_gt, H.
  Qed.

  Section lt_spec.

  Inductive ct: comparison -> comparison -> comparison -> Prop :=
  | ct_xxx: forall x, ct x  x  x
  | ct_xex: forall x, ct x  Eq x
  | ct_exx: forall x, ct Eq x  x
  | ct_glx: forall x, ct Gt Lt x
  | ct_lgx: forall x, ct Lt Gt x.

  Lemma ct_cxe: forall x, ct (CompOpp x) x Eq.
  Proof. destruct x; constructor. Qed.

  Lemma ct_xce: forall x, ct x (CompOpp x) Eq.
  Proof. destruct x; constructor. Qed.

  Lemma ct_lxl: forall x, ct Lt x Lt.
  Proof. destruct x; constructor. Qed.

  Lemma ct_gxg: forall x, ct Gt x Gt.
  Proof. destruct x; constructor. Qed.

  Lemma ct_xll: forall x, ct x Lt Lt.
  Proof. destruct x; constructor. Qed.

  Lemma ct_xgg: forall x, ct x Gt Gt.
  Proof. destruct x; constructor. Qed.

  Local Hint Constructors ct: ct.
  Local Hint Resolve ct_cxe ct_xce ct_lxl ct_xll ct_gxg ct_xgg: ct.
  Ltac ct := trivial with ct.

  Lemma ct_lex: forall u v w u' v' w',
    ct u v w -> ct u' v' w' -> ct (lex u u') (lex v v') (lex w w').
  Proof.
    intros u v w u' v' w' H H'.
    inversion_clear H; inversion_clear H'; ct; destruct w; ct; destruct w'; ct.
  Qed.

  Lemma ct_compare_bool:
    forall a b c, ct (compare_bool a b) (compare_bool b c) (compare_bool a c).
  Proof.
    intros [|] [|] [|]; constructor.
  Qed.

  Lemma compare_x_Leaf: forall s,
    compare s Leaf = if is_empty s then Eq else Gt.
  Proof.
    intros. rewrite compare_inv. simpl. case (is_empty s); reflexivity.
  Qed.

  Lemma compare_empty_x: forall a, is_empty a = true ->
    forall b, compare a b = if is_empty b then Eq else Lt.
  Proof.
    induction a as [|l IHl o r IHr]; trivial.
    destruct o. intro; discriminate.
    simpl is_empty. rewrite <- andb_lazy_alt, andb_true_iff.
    intros [Hl Hr].
    destruct b as [|l' [|] r']; simpl compare; trivial.
     rewrite Hl, Hr. trivial.
     rewrite (IHl Hl), (IHr Hr). simpl.
     case (is_empty l'); case (is_empty r'); trivial.
  Qed.

  Lemma compare_x_empty: forall a, is_empty a = true ->
    forall b, compare b a = if is_empty b then Eq else Gt.
  Proof.
    setoid_rewrite <- compare_x_Leaf.
    intros. rewrite 2(compare_inv b), (compare_empty_x _ H). reflexivity.
  Qed.

  Lemma ct_compare:
    forall a b c, ct (compare a b) (compare b c) (compare a c).
  Proof.
    induction a as [|l IHl o r IHr]; intros s' s''.
     destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']; ct.
      rewrite compare_inv. ct.
      unfold compare at 1. case_eq (is_empty (Node l' o' r')); intro H'.
       rewrite (compare_empty_x _ H'). ct.
       unfold compare at 2. case_eq (is_empty (Node l'' o'' r'')); intro H''.
        rewrite (compare_x_empty _ H''), H'. ct.
        ct.

     destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r''].
      ct.
      unfold compare at 2. rewrite compare_x_Leaf.
      case_eq (is_empty (Node l o r)); intro H.
       rewrite (compare_empty_x _ H). ct.
       case_eq (is_empty (Node l'' o'' r'')); intro H''.
        rewrite (compare_x_empty _ H''), H. ct.
        ct.

      rewrite 2 compare_x_Leaf.
      case_eq (is_empty (Node l o r)); intro H.
       rewrite compare_inv, (compare_x_empty _ H). ct.
       case_eq (is_empty (Node l' o' r')); intro H'.
        rewrite (compare_x_empty _ H'), H. ct.
        ct.

      simpl compare. apply ct_lex. apply ct_compare_bool.
       apply ct_lex; trivial.
  Qed.

  End lt_spec.

  Instance lt_strorder : StrictOrder lt.
  Proof.
   unfold lt. split.
   intros x H.
   assert (compare x x = Eq).
    apply compare_equal, equal_spec. reflexivity.
   congruence.
   intros a b c. assert (H := ct_compare a b c).
    inversion_clear H; trivial; intros; discriminate.
  Qed.

  Local Instance compare_compat_1 : Proper (eq==>Logic.eq==>Logic.eq) compare.
  Proof.
   intros x x' Hx y y' Hy. subst y'.
   unfold eq in *. rewrite <- equal_spec, <- compare_equal in *.
   assert (C:=ct_compare x x' y). rewrite Hx in C. inversion C; auto.
  Qed.

  Instance compare_compat : Proper (eq==>eq==>Logic.eq) compare.
  Proof.
   intros x x' Hx y y' Hy. rewrite Hx.
   rewrite compare_inv, Hy, <- compare_inv. reflexivity.
  Qed.

  Local Instance lt_compat : Proper (eq==>eq==>iff) lt.
  Proof.
   intros x x' Hx y y' Hy. unfold lt. rewrite Hx, Hy. intuition.
  Qed.

  (** Specification of [add] *)

  Lemma add_spec: forall s x y, In y (add x s) <-> y=x \/ In y s.
  Proof.
    unfold In. intros s x y; revert x y s.
    induction x; intros [y|y|] [|l o r]; simpl mem;
    try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; intuition congruence.
  Qed.

  (** Specification of [remove] *)

  Lemma remove_spec: forall s x y, In y (remove x s) <-> In y s /\ y<>x.
  Proof.
    unfold In. intros s x y; revert x y s.
    induction x; intros [y|y|] [|l o r]; simpl remove; rewrite ?mem_node;
     simpl mem; try (rewrite IHx; clear IHx); rewrite ?mem_Leaf;
     intuition congruence.
  Qed.

  (** Specification of [singleton] *)

  Lemma singleton_spec : forall x y, In y (singleton x) <-> y=x.
  Proof.
    unfold singleton. intros x y. rewrite add_spec. intuition.
    unfold In in *. rewrite mem_Leaf in *. discriminate.
  Qed.

  (** Specification of [union] *)

  Lemma union_spec: forall s s' x, In x (union s s') <-> In x s \/ In x s'.
  Proof.
    unfold In. intros s s' x; revert x s s'.
    induction x; destruct s; destruct s'; simpl union; simpl mem;
      try (rewrite IHx; clear IHx); try intuition congruence.
      apply orb_true_iff.
  Qed.

  (** Specification of [inter] *)

  Lemma inter_spec: forall s s' x, In x (inter s s') <-> In x s /\ In x s'.
  Proof.
    unfold In. intros s s' x; revert x s s'.
    induction x; destruct s; destruct s'; simpl inter; rewrite ?mem_node;
     simpl mem; try (rewrite IHx; clear IHx); try intuition congruence.
     apply andb_true_iff.
  Qed.

  (** Specification of [diff] *)

  Lemma diff_spec: forall s s' x, In x (diff s s') <-> In x s /\ ~ In x s'.
  Proof.
    unfold In. intros s s' x; revert x s s'.
    induction x; destruct s; destruct s' as [|l' o' r']; simpl diff;
     rewrite ?mem_node; simpl mem;
      try (rewrite IHx; clear IHx); try intuition congruence.
      rewrite andb_true_iff. destruct o'; intuition discriminate.
  Qed.

  (** Specification of [fold] *)

  Lemma fold_spec: forall s (A : Type) (i : A) (f : elt -> A -> A),
      fold f s i = fold_left (fun a e => f e a) (elements s) i.
  Proof.
    unfold fold, elements. intros s A i f. revert s i.
    set (f' := fun a e => f e a).
    assert (H: forall s i j acc,
      fold_left f' acc (xfold f s i j) =
      fold_left f' (xelements s j acc) i).

    induction s as [|l IHl o r IHr]; intros; trivial.
      destruct o; simpl xelements; simpl xfold.
        rewrite IHr, <- IHl. reflexivity.
        rewrite IHr. apply IHl.

    intros. exact (H s i 1 nil).
  Qed.

  (** Specification of [cardinal] *)

  Lemma cardinal_spec: forall s, cardinal s = length (elements s).
  Proof.
    unfold elements.
    assert (H: forall s j acc,
                (cardinal s + length acc)%nat = length (xelements s j acc)).

    induction s as [|l IHl b r IHr]; intros j acc; simpl; trivial. destruct b.
      rewrite <- IHl. simpl. rewrite <- IHr.
       rewrite <- plus_n_Sm, Plus.plus_assoc. reflexivity.
      rewrite <- IHl, <- IHr. rewrite Plus.plus_assoc. reflexivity.

    intros. rewrite <- H. simpl. rewrite Plus.plus_comm. reflexivity.
  Qed.

  (** Specification of [filter] *)

  Lemma xfilter_spec: forall f s x i,
    In x (xfilter f s i) <-> In x s /\ f (i@x) = true.
  Proof.
    intro f. unfold In.
    induction s as [|l IHl o r IHr]; intros x i; simpl xfilter.
     rewrite mem_Leaf. intuition discriminate.
     rewrite mem_node. destruct x; simpl.
       rewrite IHr. reflexivity.
       rewrite IHl. reflexivity.
       rewrite <- andb_lazy_alt. apply andb_true_iff.
  Qed.

  Lemma filter_spec: forall s x f, @compat_bool elt E.eq f ->
    (In x (filter f s) <-> In x s /\ f x = true).
  Proof. intros. apply xfilter_spec. Qed.

  (** Specification of [for_all] *)

  Lemma xforall_spec: forall f s i,
    xforall f s i = true <-> For_all (fun x => f (i@x) = true) s.
  Proof.
    unfold For_all, In. intro f.
    induction s as [|l IHl o r IHr]; intros i; simpl.
    intuition discriminate.
     rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff.
     rewrite IHl, IHr. clear IHl IHr.
      split.
       intros [[Hi Hr] Hl] x. destruct x; simpl; intro H.
        apply Hr, H.
        apply Hl, H.
        rewrite H in Hi. assumption.
       intro H; intuition.
        specialize (H 1). destruct o. apply H. reflexivity. reflexivity.
        apply H. assumption.
        apply H. assumption.
  Qed.

  Lemma for_all_spec: forall s f, @compat_bool elt E.eq f ->
    (for_all f s = true <-> For_all (fun x => f x = true) s).
  Proof. intros. apply xforall_spec. Qed.

  (** Specification of [exists] *)

  Lemma xexists_spec: forall f s i,
    xexists f s i = true <-> Exists (fun x => f (i@x) = true) s.
  Proof.
    unfold Exists, In. intro f.
    induction s as [|l IHl o r IHr]; intros i; simpl.
     firstorder.
     rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff.
     rewrite IHl, IHr. clear IHl IHr.
      split.
       intros [[Hi|[x Hr]]|[x Hl]].
        exists 1. exact Hi.
        exists x~1. exact Hr.
        exists x~0. exact Hl.
       intros [[x|x|] H]; eauto.
  Qed.

  Lemma exists_spec : forall s f, @compat_bool elt E.eq f ->
    (exists_ f s = true <-> Exists (fun x => f x = true) s).
  Proof. intros. apply xexists_spec. Qed.

  (** Specification of [partition] *)

  Lemma partition_filter : forall s f,
    partition f s = (filter f s, filter (fun x => negb (f x)) s).
  Proof.
    unfold partition, filter. intros s f. generalize 1 as j.
    induction s as [|l IHl o r IHr]; intro j.
      reflexivity.
      destruct o; simpl; rewrite IHl, IHr; reflexivity.
  Qed.

  Lemma partition_spec1 : forall s f, @compat_bool elt E.eq f ->
      Equal (fst (partition f s)) (filter f s).
  Proof. intros. rewrite partition_filter. reflexivity. Qed.

  Lemma partition_spec2 : forall s f, @compat_bool elt E.eq f ->
      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
  Proof. intros. rewrite partition_filter. reflexivity. Qed.

  (** Specification of [elements] *)

  Notation InL := (InA E.eq).

  Lemma xelements_spec: forall s j acc y,
    InL y (xelements s j acc)
    <->
    InL y acc \/ exists x, y=(j@x) /\ mem x s = true.
  Proof.
    induction s as [|l IHl o r IHr]; simpl.
      intros. split; intro H.
        left. assumption.
        destruct H as [H|[x [Hx Hx']]]. assumption. discriminate.

      intros j acc y. case o.
        rewrite IHl. rewrite InA_cons. rewrite IHr. clear IHl IHr. split.
          intros [[H|[H|[x [-> H]]]]|[x [-> H]]]; eauto.
            right. exists x~1. auto.
            right. exists x~0. auto.
          intros [H|[x [-> H]]].
            eauto.
            destruct x.
              left. right. right. exists x; auto.
              right. exists x; auto.
              left. left. reflexivity.

        rewrite IHl, IHr. clear IHl IHr. split.
          intros [[H|[x [-> H]]]|[x [-> H]]].
            eauto.
            right. exists x~1. auto.
            right. exists x~0. auto.
          intros [H|[x [-> H]]].
            eauto.
            destruct x.
              left. right.  exists x; auto.
              right. exists x; auto.
              discriminate.
  Qed.

  Lemma elements_spec1: forall s x, InL x (elements s) <-> In x s.
  Proof.
   unfold elements. intros. rewrite xelements_spec.
   split; [ intros [A|(y & B & C)] | intros IN ].
   inversion A. simpl in *. congruence.
   right. exists x. auto.
  Qed.

  Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y).
  Proof. induction j; intros; simpl; auto. Qed.

  Lemma elements_spec2: forall s, sort E.lt (elements s).
  Proof.
    unfold elements.
    assert (H: forall s j acc,
      sort E.lt acc ->
      (forall x y, In x s ->  InL y acc -> E.lt (j@x) y) ->
      sort E.lt (xelements s j acc)).

    induction s as [|l IHl o r IHr]; simpl; trivial.
    intros j acc Hacc Hsacc. destruct o.
      apply IHl. constructor.
       apply IHr. apply Hacc.
       intros x y Hx Hy. apply Hsacc; assumption.
       case_eq (xelements r j~1 acc). constructor.
       intros z q H. constructor.
       assert (H': InL z (xelements r j~1 acc)).
        rewrite H. constructor. reflexivity.
       clear H q. rewrite xelements_spec in H'. destruct H' as [Hy|[x [-> Hx]]].
         apply (Hsacc 1 z); trivial. reflexivity.
         simpl. apply lt_rev_append. exact I.
       intros x y Hx Hy. inversion_clear Hy.
         rewrite H. simpl. apply lt_rev_append. exact I.
         rewrite xelements_spec in H. destruct H as [Hy|[z [-> Hy]]].
           apply Hsacc; assumption.
           simpl. apply lt_rev_append. exact I.

      apply IHl. apply IHr. apply Hacc.
       intros x y Hx Hy. apply Hsacc; assumption.
       intros x y Hx Hy. rewrite xelements_spec in Hy.
        destruct Hy as [Hy|[z [-> Hy]]].
         apply Hsacc; assumption.
         simpl. apply lt_rev_append. exact I.

    intros. apply H. constructor.
      intros x y _ H'. inversion H'.
  Qed.

  Lemma elements_spec2w: forall s, NoDupA E.eq (elements s).
  Proof.
    intro. apply SortA_NoDupA with E.lt; auto with *.
    apply elements_spec2.
  Qed.

  (** Specification of [choose] *)

  Lemma choose_spec1: forall s x, choose s = Some x -> In x s.
  Proof.
    induction s as [| l IHl o r IHr]; simpl.
      intros. discriminate.
      destruct o.
        intros x H. injection H; intros; subst. reflexivity.
        revert IHl. case choose.
          intros p Hp x H. injection H as <-. apply Hp.
           reflexivity.
          intros _ x. revert IHr. case choose.
            intros p Hp H. injection H as <-. apply Hp.
            reflexivity.
            intros. discriminate.
  Qed.

  Lemma choose_spec2: forall s, choose s = None -> Empty s.
  Proof.
    unfold Empty, In. intros s H.
    induction s as [|l IHl o r IHr].
      intro. apply empty_spec.
      destruct o.
        discriminate.
        simpl in H. destruct (choose l).
          discriminate.
          destruct (choose r).
            discriminate.
            intros [a|a|].
              apply IHr. reflexivity.
              apply IHl. reflexivity.
              discriminate.
  Qed.

  Lemma choose_empty: forall s, is_empty s = true -> choose s = None.
  Proof.
    intros s Hs. case_eq (choose s); trivial.
    intros p Hp. apply choose_spec1 in Hp. apply is_empty_spec in Hs.
     elim (Hs _ Hp).
  Qed.

  Lemma choose_spec3': forall s s', Equal s s' -> choose s = choose s'.
  Proof.
    setoid_rewrite <- equal_spec.
    induction s as [|l IHl o r IHr].
      intros. symmetry. apply choose_empty. assumption.

      destruct s' as [|l' o' r'].
        generalize (Node l o r) as s. simpl. intros. apply choose_empty.
        rewrite equal_spec in H. symmetry in H. rewrite <- equal_spec in H.
        assumption.

        simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff, eqb_true_iff.
        intros [[<- Hl] Hr]. rewrite (IHl _ Hl), (IHr _ Hr). reflexivity.
  Qed.

  Lemma choose_spec3: forall s s' x y,
    choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y.
  Proof. intros s s' x y Hx Hy H. apply choose_spec3' in H. congruence. Qed.

  (** Specification of [min_elt] *)

  Lemma min_elt_spec1: forall s x, min_elt s = Some x -> In x s.
  Proof.
   unfold In.
   induction s as [| l IHl o r IHr]; simpl.
     intros. discriminate.
     intros x. destruct (min_elt l); intros.
       injection H as <-. apply IHl. reflexivity.
       destruct o; simpl.
         injection H as <-. reflexivity.
         destruct (min_elt r); simpl in *.
           injection H as <-. apply IHr. reflexivity.
           discriminate.
  Qed.

  Lemma min_elt_spec3: forall s, min_elt s = None -> Empty s.
  Proof.
    unfold Empty, In. intros s H.
    induction s as [|l IHl o r IHr].
      intro. apply empty_spec.
      intros [a|a|].
        apply IHr. revert H. clear. simpl. destruct (min_elt r); trivial.
          case min_elt; intros; try discriminate. destruct o; discriminate.
        apply IHl. revert H. clear. simpl. destruct (min_elt l); trivial.
         intro; discriminate.
        revert H. clear. simpl. case min_elt; intros; try discriminate.
         destruct o; discriminate.
  Qed.

  Lemma min_elt_spec2: forall s x y, min_elt s = Some x -> In y s -> ~ E.lt y x.
  Proof.
    unfold In.
    induction s as [|l IHl o r IHr]; intros x y H H'.
      discriminate.
      simpl in H. case_eq (min_elt l).
        intros p Hp. rewrite Hp in H. injection H as <-.
        destruct y as [z|z|]; simpl; intro; trivial. apply (IHl p z); trivial.
        intro Hp; rewrite Hp in H. apply min_elt_spec3 in Hp.
        destruct o.
          injection H as <-. intros Hl.
          destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').

          destruct (min_elt r).
            injection H as <-.
            destruct y as [z|z|].
              apply (IHr e z); trivial.
              elim (Hp _ H').
              discriminate.
            discriminate.
  Qed.

  (** Specification of [max_elt] *)

  Lemma max_elt_spec1: forall s x, max_elt s = Some x -> In x s.
  Proof.
   unfold In.
   induction s as [| l IHl o r IHr]; simpl.
     intros. discriminate.
     intros x. destruct (max_elt r); intros.
       injection H as <-. apply IHr. reflexivity.
       destruct o; simpl.
         injection H as <-. reflexivity.
         destruct (max_elt l); simpl in *.
           injection H as <-. apply IHl. reflexivity.
           discriminate.
  Qed.

  Lemma max_elt_spec3: forall s, max_elt s = None -> Empty s.
  Proof.
    unfold Empty, In. intros s H.
    induction s as [|l IHl o r IHr].
      intro. apply empty_spec.
      intros [a|a|].
        apply IHr. revert H. clear. simpl. destruct (max_elt r); trivial.
         intro; discriminate.
        apply IHl. revert H. clear. simpl. destruct (max_elt l); trivial.
          case max_elt; intros; try discriminate. destruct o; discriminate.
        revert H. clear. simpl. case max_elt; intros; try discriminate.
         destruct o; discriminate.
  Qed.

  Lemma max_elt_spec2: forall s x y, max_elt s = Some x -> In y s -> ~ E.lt x y.
  Proof.
    unfold In.
    induction s as [|l IHl o r IHr]; intros x y H H'.
      discriminate.
      simpl in H. case_eq (max_elt r).
        intros p Hp. rewrite Hp in H. injection H as <-.
        destruct y as [z|z|]; simpl; intro; trivial. apply (IHr p z); trivial.
        intro Hp; rewrite Hp in H. apply max_elt_spec3 in Hp.
        destruct o.
          injection H as <-. intros Hl.
          destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').

          destruct (max_elt l).
            injection H as <-.
            destruct y as [z|z|].
              elim (Hp _ H').
              apply (IHl e z); trivial.
              discriminate.
            discriminate.
  Qed.

End PositiveSet.


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

 The enriched category of dialgebras

 We construct an enrichment over the category of dialgebras between
 two enriched functors. In addition, we show that this gives rise to
 inserters in the bicategory of enriched categories.

 Note that to construct this enrichment, we assume that the monoidal
 category `V` has equalizers. This is because morphisms in the
 category of dialgebras come with a requirement that a certain diagram
 commutes. As such, this requirement must also be present in the
 enrichment. To formulate this requirement, we use equalizers.

 Contents
 1. The enrichment of dialgebras
 2. Enrichment of the first projection
 3. Enrichment of functors to dialgebras
 4. Enrichment of natural transformations to dialgebras

 **********************************************************************)
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.categories.Dialgebras.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.limits.equalizers.

Import MonoidalNotations.

Local Open Scope cat.
Local Open Scope moncat.

Section EnrichedDialgebras.
  Context (V : monoidal_cat)
          (EV : Equalizers V)
          {C₁ C₂ : category}
          {F G : C₁ ⟶ C₂}
          {E₁ : enrichment C₁ V}
          {E₂ : enrichment C₂ V}
          (FE : functor_enrichment F E₁ E₂)
          (GE : functor_enrichment G E₁ E₂).

  (**
   1. The enrichment of dialgebras
   *)
  Definition dialgebra_enrichment_mor_left
             {x y : C₁}
             (f : F x --> G x)
             (g : F y --> G y)
    : E₁ ⦃ x , y ⦄ --> E₂ ⦃ F x , G y ⦄
    := GE x y
       · mon_rinvunitor _
       · identity _ #⊗ enriched_from_arr E₂ f
       · enriched_comp _ _ _ _.

  Definition dialgebra_enrichment_mor_right
             {x y : C₁}
             (f : F x --> G x)
             (g : F y --> G y)
    : E₁ ⦃ x , y ⦄ --> E₂ ⦃ F x , G y ⦄
    := FE x y
       · mon_linvunitor _
       · enriched_from_arr E₂ g #⊗ identity _
       · enriched_comp _ _ _ _.

  Definition dialgebra_enrichment_mor
             {x y : C₁}
             (f : F x --> G x)
             (g : F y --> G y)
    : V
    := EV _ _
         (dialgebra_enrichment_mor_left f g)
         (dialgebra_enrichment_mor_right f g).

  Definition dialgebra_enrichment_mor_incl
             {x y : C₁}
             (f : F x --> G x)
             (g : F y --> G y)
    : dialgebra_enrichment_mor f g --> E₁ ⦃ x , y ⦄
    := EqualizerArrow
         (EV _ _
             (dialgebra_enrichment_mor_left f g)
             (dialgebra_enrichment_mor_right f g)).

  Definition dialgebra_enrichment_mor_incl_eq
             {x y : C₁}
             (f : F x --> G x)
             (g : F y --> G y)
    : dialgebra_enrichment_mor_incl f g · dialgebra_enrichment_mor_left f g
      =
      dialgebra_enrichment_mor_incl f g · dialgebra_enrichment_mor_right f g.
  Proof.
    exact (EqualizerEqAr
             (EV _ _
                (dialgebra_enrichment_mor_left f g)
                (dialgebra_enrichment_mor_right f g))).
  Qed.

  Definition dialgebra_enrichment_mor_eq_of_mor
             {x y : C₁}
             (f : F x --> G x)
             (g : F y --> G y)
             {v : V}
             {φ₁ φ₂ : v --> dialgebra_enrichment_mor f g}
             (p : φ₁ · dialgebra_enrichment_mor_incl f g
                  =
                  φ₂ · dialgebra_enrichment_mor_incl f g)
    : φ₁ = φ₂.
  Proof.
    use (isEqualizerInsEq
           (pr22 (EV _ _
                     (dialgebra_enrichment_mor_left f g)
                     (dialgebra_enrichment_mor_right f g)))).
    exact p.
  Qed.

  Definition dialgebra_enrichment_id_eq
             {x : C₁}
             (f : F x --> G x)
    : enriched_id E₁ x · dialgebra_enrichment_mor_left f f
      =
      enriched_id E₁ x · dialgebra_enrichment_mor_right f f.
  Proof.
    unfold dialgebra_enrichment_mor_left, dialgebra_enrichment_mor_right.
    etrans.
    {
      apply maponpaths.
      do 2 apply maponpaths_2.
      apply tensor_rinvunitor.
    }
    rewrite !assoc'.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !assoc.
      apply maponpaths_2.
      refine (!_).
      apply tensor_comp_mor.
    }
    rewrite id_left, id_right.
    rewrite !assoc.
    rewrite tensor_rinvunitor.
    refine (!_).
    etrans.
    {
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      rewrite tensor_linvunitor.
      apply idpath.
    }
    rewrite !assoc'.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !assoc.
      apply maponpaths_2.
      refine (!_).
      apply tensor_comp_mor.
    }
    rewrite id_left, id_right.
    rewrite !assoc.
    rewrite tensor_linvunitor.
    rewrite !assoc'.
    rewrite mon_linvunitor_I_mon_rinvunitor_I.
    apply maponpaths.
    rewrite !assoc.
    etrans.
    {
      apply maponpaths_2.
      refine (!_).
      apply tensor_comp_mor.
    }
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      refine (!_).
      apply tensor_comp_mor.
    }
    refine (!_).
    rewrite !id_left.
    rewrite (functor_enrichment_id FE).
    rewrite (functor_enrichment_id GE).
    rewrite tensor_split'.
    rewrite !assoc'.
    rewrite <- enrichment_id_right.
    refine (!_).
    rewrite tensor_split.
    rewrite !assoc'.
    rewrite <- enrichment_id_left.
    rewrite tensor_lunitor.
    rewrite tensor_runitor.
    apply maponpaths_2.
    apply mon_lunitor_I_mon_runitor_I.
  Qed.

  Definition dialgebra_enrichment_id
             {x : C₁}
             (f : F x --> G x)
    : I_{V} --> dialgebra_enrichment_mor f f.
  Proof.
    use EqualizerIn.
    - exact (enriched_id E₁ x).
    - exact (dialgebra_enrichment_id_eq f).
  Defined.

  Definition dialgebra_enrichment_id_incl
             {x : C₁}
             (f : F x --> G x)
    : dialgebra_enrichment_id f · dialgebra_enrichment_mor_incl f f
      =
      enriched_id E₁ x.
  Proof.
    apply EqualizerCommutes.
  Qed.

  Definition dialgebra_enrichment_comp_mor
             {x y z : C₁}
             (f₁ : F x --> G x)
             (f₂ : F y --> G y)
             (f₃ : F z --> G z)
    : dialgebra_enrichment_mor f₂ f₃ ⊗ dialgebra_enrichment_mor f₁ f₂
      -->
      E₁ ⦃ x, z ⦄
    := dialgebra_enrichment_mor_incl f₂ f₃ #⊗ dialgebra_enrichment_mor_incl f₁ f₂
       · enriched_comp _ _ _ _.

  Definition dialgebra_enrichment_comp_eq
             {x y z : C₁}
             (f₁ : F x --> G x)
             (f₂ : F y --> G y)
             (f₃ : F z --> G z)
    : dialgebra_enrichment_comp_mor f₁ f₂ f₃
      · dialgebra_enrichment_mor_left f₁ f₃
      =
      dialgebra_enrichment_comp_mor f₁ f₂ f₃
      · dialgebra_enrichment_mor_right f₁ f₃.
  Proof.
    unfold dialgebra_enrichment_comp_mor.
    unfold dialgebra_enrichment_mor_left, dialgebra_enrichment_mor_right.
    rewrite !assoc'.
    rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)).
    rewrite (functor_enrichment_comp FE).
    rewrite (functor_enrichment_comp GE).
    rewrite !assoc.
    rewrite <- !tensor_comp_mor.
    rewrite !assoc'.
    rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)).
    etrans.
    {
      apply maponpaths.
      do 2 apply maponpaths_2.
      apply tensor_rinvunitor.
    }
    refine (!_).
    etrans.
    {
      apply maponpaths.
      do 2 apply maponpaths_2.
      apply tensor_linvunitor.
    }
    refine (!_).
    rewrite !assoc'.
    rewrite !(maponpaths (λ z, _ · (_ · z)) (assoc _ _ _)).
    etrans.
    {
      do 2 apply maponpaths.
      apply maponpaths_2.
      refine (!(tensor_split' _ _) @ _).
      apply tensor_split.
    }
    refine (!_).
    etrans.
    {
      do 2 apply maponpaths.
      apply maponpaths_2.
      refine (!(tensor_split _ _) @ _).
      apply tensor_split'.
    }
    rewrite !assoc'.
    refine (!_).
    etrans.
    {
      do 3 apply maponpaths.
      apply enrichment_assoc.
    }
    refine (!_).
    etrans.
    {
      do 3 apply maponpaths.
      apply enrichment_assoc'.
    }
    rewrite !assoc'.
    rewrite !(maponpaths (λ z, _ · (_ · z)) (assoc _ _ _)).
    etrans.
    {
      do 2 apply maponpaths.
      do 2 apply maponpaths_2.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths.
        refine (!_).
        apply tensor_id_id.
      }
      apply tensor_rassociator.
    }
    refine (!_).
    etrans.
    {
      do 2 apply maponpaths.
      do 2 apply maponpaths_2.
      etrans.
      {
        do 2 apply maponpaths_2.
        refine (!_).
        apply tensor_id_id.
      }
      apply tensor_lassociator.
    }
    rewrite <- mon_rinvunitor_triangle.
    rewrite <- mon_linvunitor_triangle.
    rewrite !assoc'.
    rewrite !(maponpaths (λ z, _ · (_ · z)) (assoc _ _ _)).
    etrans.
    {
      do 2 apply maponpaths.
      do 3 apply maponpaths_2.
      apply mon_rassociator_lassociator.
    }
    refine (!_).
    etrans.
    {
      do 2 apply maponpaths.
      do 3 apply maponpaths_2.
      apply mon_lassociator_rassociator.
    }
    rewrite !assoc.
    rewrite <- !tensor_comp_mor.
    rewrite !id_right.
    etrans.
    {
      do 2 apply maponpaths_2.
      refine (!_).
      apply tensor_comp_mor.
    }
    etrans.
    {
      apply maponpaths_2.
      refine (!_).
      apply tensor_comp_mor.
    }
    refine (!_).
    etrans.
    {
      do 2 apply maponpaths_2.
      refine (!_).
      apply tensor_comp_mor.
    }
    etrans.
    {
      apply maponpaths_2.
      refine (!_).
      apply tensor_comp_mor.
    }
    rewrite !id_right.
    etrans.
    {
      apply maponpaths_2.
      apply maponpaths.
      refine (_ @ dialgebra_enrichment_mor_incl_eq f₁ f₂).
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      apply idpath.
    }
    unfold dialgebra_enrichment_mor_right.
    refine (!_).
    etrans.
    {
      do 2 apply maponpaths_2.
      refine (_ @ !(dialgebra_enrichment_mor_incl_eq f₂ f₃)).
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      apply idpath.
    }
    unfold dialgebra_enrichment_mor_left.
    rewrite !tensor_comp_mor.
    rewrite !assoc'.
    apply maponpaths.
    rewrite tensor_comp_r_id_r.
    rewrite tensor_comp_l_id_r.
    rewrite !assoc'.
    apply maponpaths.
    rewrite !assoc.
    rewrite tensor_comp_r_id_r.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      apply enrichment_assoc.
    }
    rewrite !assoc.
    rewrite tensor_comp_l_id_r.
    do 2 apply maponpaths_2.
    rewrite tensor_comp_r_id_r.
    rewrite tensor_comp_l_id_r.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      apply tensor_lassociator.
    }
    rewrite !assoc.
    apply maponpaths_2.
    refine (!_).
    apply mon_inv_triangle.
  Qed.

  Definition dialgebra_enrichment_comp
             {x y z : C₁}
             (f₁ : F x --> G x)
             (f₂ : F y --> G y)
             (f₃ : F z --> G z)
    : dialgebra_enrichment_mor f₂ f₃ ⊗ dialgebra_enrichment_mor f₁ f₂
      -->
      dialgebra_enrichment_mor f₁ f₃.
  Proof.
    use EqualizerIn.
    - exact (dialgebra_enrichment_comp_mor f₁ f₂ f₃).
    - exact (dialgebra_enrichment_comp_eq f₁ f₂ f₃).
  Defined.

  Definition dialgebra_enrichment_comp_incl
             {x y z : C₁}
             (f₁ : F x --> G x)
             (f₂ : F y --> G y)
             (f₃ : F z --> G z)
    : dialgebra_enrichment_comp f₁ f₂ f₃ · dialgebra_enrichment_mor_incl f₁ f₃
      =
      dialgebra_enrichment_comp_mor f₁ f₂ f₃.
  Proof.
    apply EqualizerCommutes.
  Qed.

  Definition dialgebra_enrichment_from_arr_eq
             {x y : C₁}
             {f : F x --> G x}
             {g : F y --> G y}
             (h : x --> y)
             (p : f · # G h = # F h · g)
    : enriched_from_arr E₁ h · dialgebra_enrichment_mor_left f g
      =
      enriched_from_arr E₁ h · dialgebra_enrichment_mor_right f g.
  Proof.
    unfold dialgebra_enrichment_mor_left, dialgebra_enrichment_mor_right.
    rewrite !assoc.
    rewrite tensor_rinvunitor.
    rewrite tensor_linvunitor.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      apply maponpaths_2.
      refine (!_).
      apply tensor_comp_mor.
    }
    refine (!_).
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      apply maponpaths_2.
      refine (!_).
      apply tensor_comp_mor.
    }
    rewrite !id_left, !id_right.
    rewrite <- (functor_enrichment_from_arr FE).
    rewrite <- (functor_enrichment_from_arr GE).
    use (invmaponpathsweq (_ ,, isweq_enriched_to_arr E₂ _ _)).
    cbn.
    rewrite mon_rinvunitor_I_mon_linvunitor_I.
    rewrite !assoc.
    rewrite <- !(enriched_to_arr_comp E₂).
    exact (!p).
  Qed.

  Definition dialgebra_enrichment_from_arr
             {x y : C₁}
             {f : F x --> G x}
             {g : F y --> G y}
             (h : x --> y)
             (p : f · # G h = # F h · g)
    : I_{V} --> dialgebra_enrichment_mor f g.
  Proof.
    use EqualizerIn.
    - exact (enriched_from_arr E₁ h).
    - exact (dialgebra_enrichment_from_arr_eq h p).
  Defined.

  Definition dialgebra_enrichment_from_arr_incl
             {x y : C₁}
             {f : F x --> G x}
             {g : F y --> G y}
             (h : x --> y)
             (p : f · # G h = # F h · g)
    : dialgebra_enrichment_from_arr h p · dialgebra_enrichment_mor_incl f g
      =
      enriched_from_arr E₁ h.
  Proof.
    apply EqualizerCommutes.
  Defined.

  Definition dialgebra_enrichment_to_arr_mor
             {x y : C₁}
             {f : F x --> G x}
             {g : F y --> G y}
             (h : I_{V} --> dialgebra_enrichment_mor f g)
    :  x --> y
    := enriched_to_arr E₁ (h · dialgebra_enrichment_mor_incl _ _).

  Definition dialgebra_enrichment_to_arr_eq
             {x y : C₁}
             {f : F x --> G x}
             {g : F y --> G y}
             (h : I_{V} --> dialgebra_enrichment_mor f g)
    : f · # G (dialgebra_enrichment_to_arr_mor h)
      =
      # F (dialgebra_enrichment_to_arr_mor h) · g.
  Proof.
    unfold dialgebra_enrichment_to_arr_mor.
    use (invmaponpathsweq (_ ,, isweq_enriched_from_arr E₂ _ _)).
    cbn.
    rewrite !enriched_from_arr_comp.
    rewrite (functor_enrichment_from_arr FE).
    rewrite (functor_enrichment_from_arr GE).
    rewrite !enriched_from_to_arr.
    pose (dialgebra_enrichment_mor_incl_eq f g) as p.
    unfold dialgebra_enrichment_mor_left in p.
    unfold dialgebra_enrichment_mor_right in p.
    rewrite !assoc in p.
    rewrite tensor_rinvunitor in p.
    rewrite mon_linvunitor_I_mon_rinvunitor_I.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      apply maponpaths_2.
      apply tensor_comp_r_id_l.
    }
    rewrite !assoc.
    etrans.
    {
      do 2 apply maponpaths_2.
      refine (!_).
      apply tensor_rinvunitor.
    }
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      refine (_ @ p).
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      apply maponpaths_2.
      refine (!_).
      etrans.
      {
        refine (!_).
        apply tensor_comp_mor.
      }
      rewrite id_right, id_left.
      apply idpath.
    }
    clear p.
    rewrite !assoc.
    apply maponpaths_2.
    rewrite tensor_linvunitor.
    rewrite mon_linvunitor_I_mon_rinvunitor_I.
    rewrite !assoc'.
    apply maponpaths.
    etrans.
    {
      refine (!_).
      apply tensor_comp_mor.
    }
    rewrite id_left, id_right.
    apply idpath.
  Qed.

  Definition dialgebra_enrichment_data
    : enrichment_data (dialgebra F G) V.
  Proof.
    simple refine (_ ,, _ ,, _ ,, _ ,, _).
    - exact (λ f g, dialgebra_enrichment_mor (pr2 f) (pr2 g)).
    - exact (λ f, dialgebra_enrichment_id (pr2 f)).
    - exact (λ f₁ f₂ f₃, dialgebra_enrichment_comp (pr2 f₁) (pr2 f₂) (pr2 f₃)).
    - exact (λ f g τ, dialgebra_enrichment_from_arr (pr1 τ) (pr2 τ)).
    - refine (λ f g τ, dialgebra_enrichment_to_arr_mor τ ,, _).
      exact (dialgebra_enrichment_to_arr_eq τ).
  Defined.

  Definition dialgebra_enrichment_laws
    : enrichment_laws dialgebra_enrichment_data.
  Proof.
    repeat split.
    - intros f g.
      use dialgebra_enrichment_mor_eq_of_mor.
      cbn.
      rewrite !assoc'.
      rewrite dialgebra_enrichment_comp_incl.
      unfold dialgebra_enrichment_comp_mor.
      rewrite !assoc.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        refine (!_).
        apply tensor_comp_mor.
      }
      rewrite id_left.
      rewrite dialgebra_enrichment_id_incl.
      rewrite tensor_split.
      rewrite !assoc'.
      rewrite <- enrichment_id_left.
      rewrite tensor_lunitor.
      apply idpath.
    - intros f g.
      use dialgebra_enrichment_mor_eq_of_mor.
      cbn.
      rewrite !assoc'.
      rewrite dialgebra_enrichment_comp_incl.
      unfold dialgebra_enrichment_comp_mor.
      rewrite !assoc.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        refine (!_).
        apply tensor_comp_mor.
      }
      rewrite id_left.
      rewrite dialgebra_enrichment_id_incl.
      rewrite tensor_split'.
      rewrite !assoc'.
      rewrite <- enrichment_id_right.
      rewrite tensor_runitor.
      apply idpath.
    - intros w x y z.
      use dialgebra_enrichment_mor_eq_of_mor.
      cbn.
      rewrite !assoc'.
      rewrite !dialgebra_enrichment_comp_incl.
      unfold dialgebra_enrichment_comp_mor.
      rewrite !assoc.
      etrans.
      {
        apply maponpaths_2.
        refine (!_).
        apply tensor_comp_mor.
      }
      rewrite id_left.
      rewrite !dialgebra_enrichment_comp_incl.
      unfold dialgebra_enrichment_comp_mor.
      etrans.
      {
        apply maponpaths_2.
        apply tensor_comp_r_id_r.
      }
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        apply enrichment_assoc.
      }
      rewrite !assoc.
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths_2.
        apply tensor_lassociator.
      }
      rewrite !assoc'.
      apply maponpaths.
      refine (!(tensor_comp_mor _ _ _ _) @ _ @ tensor_comp_mor _ _ _ _).
      rewrite id_left, id_right.
      apply maponpaths.
      rewrite dialgebra_enrichment_comp_incl.
      apply idpath.
    - intros x y f.
      use subtypePath.
      {
        intro.
        apply homset_property.
      }
      cbn.
      unfold dialgebra_enrichment_to_arr_mor.
      rewrite dialgebra_enrichment_from_arr_incl.
      apply enriched_to_from_arr.
    - intros x y f.
      cbn.
      use dialgebra_enrichment_mor_eq_of_mor.
      rewrite dialgebra_enrichment_from_arr_incl.
      unfold dialgebra_enrichment_to_arr_mor.
      rewrite enriched_from_to_arr.
      apply idpath.
    - intros f.
      use subtypePath.
      {
        intro.
        apply homset_property.
      }
      cbn.
      unfold dialgebra_enrichment_to_arr_mor.
      rewrite dialgebra_enrichment_id_incl.
      rewrite enriched_to_arr_id.
      apply idpath.
    - intros x y z f g.
      use subtypePath.
      {
        intro.
        apply homset_property.
      }
      cbn.
      unfold dialgebra_enrichment_to_arr_mor.
      rewrite !assoc'.
      rewrite dialgebra_enrichment_comp_incl.
      etrans.
      {
        apply (enriched_to_arr_comp E₁ (pr1 f) (pr1 g)).
      }
      apply maponpaths.
      rewrite !assoc'.
      apply maponpaths.
      unfold dialgebra_enrichment_comp_mor.
      rewrite !assoc.
      apply maponpaths_2.
      refine (_ @ tensor_comp_mor _ _ _ _).
      rewrite !dialgebra_enrichment_from_arr_incl.
      apply idpath.
  Qed.

  Definition dialgebra_enrichment
    : enrichment (dialgebra F G) V.
  Proof.
    simple refine (_ ,, _).
    - exact dialgebra_enrichment_data.
    - exact dialgebra_enrichment_laws.
  Defined.

  (**
   2. Enrichment of the first projection
   *)
  Definition dialgebra_pr1_enrichment
    : functor_enrichment (dialgebra_pr1 F G) dialgebra_enrichment E₁.
  Proof.
    simple refine (_ ,, _).
    - exact (λ f g, dialgebra_enrichment_mor_incl (pr2 f) (pr2 g)).
    - repeat split.
      + abstract
          (intro f ; cbn ;
           apply dialgebra_enrichment_id_incl).
      + abstract
          (intros x y z ; cbn ;
           apply dialgebra_enrichment_comp_incl).
      + abstract
          (intros x y f ; cbn ;
           refine (!_) ;
           apply dialgebra_enrichment_from_arr_incl).
  Defined.

  Definition dialgebra_nat_trans_enrichment
    : nat_trans_enrichment
        (dialgebra_nat_trans F G)
        (functor_comp_enrichment dialgebra_pr1_enrichment FE)
        (functor_comp_enrichment dialgebra_pr1_enrichment GE).
  Proof.
    intros f g ; cbn.
    unfold dialgebra_nat_trans_data.
    rewrite tensor_comp_r_id_l.
    rewrite !assoc.
    etrans.
    {
      do 2 apply maponpaths_2.
      refine (!_).
      apply tensor_rinvunitor.
    }
    pose (dialgebra_enrichment_mor_incl_eq (pr2 f) (pr2 g)) as p.
    refine (_ @ p @ _).
    - unfold dialgebra_enrichment_mor_left.
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      apply maponpaths_2.
      rewrite tensor_rinvunitor.
      rewrite !assoc'.
      apply maponpaths.
      refine (_ @ tensor_comp_mor _ _ _ _).
      rewrite id_left, id_right.
      apply idpath.
    - unfold dialgebra_enrichment_mor_right.
      refine (!_).
      rewrite tensor_comp_l_id_l.
      rewrite !assoc.
      etrans.
      {
        do 2 apply maponpaths_2.
        refine (!_).
        apply tensor_linvunitor.
      }
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      apply maponpaths_2.
      rewrite tensor_linvunitor.
      rewrite !assoc'.
      apply maponpaths.
      refine (_ @ tensor_comp_mor _ _ _ _).
      rewrite id_left, id_right.
      apply idpath.
  Qed.

  (**
   3. Enrichment of functors to dialgebras
   *)
  Section FunctorToDialgebraEnrichment.
    Context {C₀ : category}
            {E₀ : enrichment C₀ V}
            {K : C₀ ⟶ C₁}
            {EK : functor_enrichment K E₀ E₁}
            (τ : K ∙ F ⟹ K ∙ G)
            (Eτ : nat_trans_enrichment
                    τ
                    (functor_comp_enrichment EK FE)
                    (functor_comp_enrichment EK GE)).

    Definition nat_trans_to_dialgebra_enrichment_mor_eq
               (x y : C₀)
      : EK x y · dialgebra_enrichment_mor_left (τ x) (τ y)
        =
        EK x y · dialgebra_enrichment_mor_right (τ x) (τ y).
    Proof.
      unfold dialgebra_enrichment_mor_left.
      unfold dialgebra_enrichment_mor_right.
      rewrite !assoc.
      rewrite tensor_rinvunitor.
      rewrite tensor_linvunitor.
      rewrite !assoc'.
      rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)).
      etrans.
      {
        apply maponpaths.
        apply maponpaths_2.
        refine (!_).
        apply tensor_comp_mor.
      }
      refine (!_).
      etrans.
      {
        apply maponpaths.
        apply maponpaths_2.
        refine (!_).
        apply tensor_comp_mor.
      }
      refine (!_).
      rewrite !id_left, !id_right.
      rewrite !assoc.
      exact (Eτ x y).
    Qed.

    Definition nat_trans_to_dialgebra_enrichment_mor
               (x y : C₀)
      : E₀ ⦃ x , y ⦄ --> dialgebra_enrichment_mor (τ x) (τ y).
    Proof.
      use EqualizerIn.
      - exact (EK x y).
      - exact (nat_trans_to_dialgebra_enrichment_mor_eq x y).
    Defined.

    Definition nat_trans_to_dialgebra_enrichment_mor_incl
               (x y : C₀)
      : nat_trans_to_dialgebra_enrichment_mor x y
        · dialgebra_enrichment_mor_incl (τ x) (τ y)
        =
        EK x y.
    Proof.
      apply EqualizerCommutes.
    Qed.

    Definition nat_trans_to_dialgebra_enrichment
      : functor_enrichment
          (nat_trans_to_dialgebra K τ)
          E₀
          dialgebra_enrichment.
    Proof.
      simple refine (_ ,, _).
      - exact nat_trans_to_dialgebra_enrichment_mor.
      - repeat split.
        + abstract
            (intros x ;
             use dialgebra_enrichment_mor_eq_of_mor ; cbn ;
             rewrite !assoc' ;
             rewrite nat_trans_to_dialgebra_enrichment_mor_incl ;
             rewrite dialgebra_enrichment_id_incl ;
             apply (functor_enrichment_id EK)).
        + abstract
            (intros x y z ;
             use dialgebra_enrichment_mor_eq_of_mor ; cbn ;
             rewrite !assoc' ;
             rewrite nat_trans_to_dialgebra_enrichment_mor_incl ;
             rewrite dialgebra_enrichment_comp_incl ;
             refine (functor_enrichment_comp EK x y z @ _) ;
             unfold dialgebra_enrichment_comp_mor ;
             rewrite !assoc ;
             apply maponpaths_2 ;
             refine (_ @ tensor_comp_mor _ _ _ _) ;
             rewrite !nat_trans_to_dialgebra_enrichment_mor_incl ;
             apply idpath).
        + abstract
            (intros x y f ;
             use dialgebra_enrichment_mor_eq_of_mor ; cbn ;
             rewrite !assoc' ;
             rewrite nat_trans_to_dialgebra_enrichment_mor_incl ;
             rewrite dialgebra_enrichment_from_arr_incl ;
             apply (functor_enrichment_from_arr EK)).
    Defined.

    Definition nat_trans_to_dialgebra_pr1_enrichment
      : nat_trans_enrichment
          (nat_trans_to_dialgebra_pr1 K τ)
          (functor_comp_enrichment
             nat_trans_to_dialgebra_enrichment
             dialgebra_pr1_enrichment)
          EK.
    Proof.
      intros x y ; cbn.
      rewrite nat_trans_to_dialgebra_enrichment_mor_incl.
      rewrite !enriched_from_arr_id.
      etrans.
      {
        rewrite tensor_split'.
        rewrite !assoc'.
        rewrite <- enrichment_id_right.
        rewrite tensor_runitor.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          apply mon_rinvunitor_runitor.
        }
        apply id_left.
      }
      refine (!_).
      rewrite tensor_split.
      rewrite !assoc'.
      rewrite <- enrichment_id_left.
      rewrite tensor_lunitor.
      rewrite !assoc.
      etrans.
      {
        apply maponpaths_2.
        apply mon_linvunitor_lunitor.
      }
      apply id_left.
    Qed.

    Definition nat_trans_to_dialgebra_pr1_enrichment_inv
      : nat_trans_enrichment
          (nat_z_iso_inv
             (nat_trans_to_dialgebra_pr1_nat_z_iso K τ))
          EK
          (functor_comp_enrichment
             nat_trans_to_dialgebra_enrichment
             dialgebra_pr1_enrichment).
    Proof.
      intros x y ; cbn.
      rewrite nat_trans_to_dialgebra_enrichment_mor_incl.
      rewrite !enriched_from_arr_id.
      etrans.
      {
        rewrite tensor_split'.
        rewrite !assoc'.
        rewrite <- enrichment_id_right.
        rewrite tensor_runitor.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          apply mon_rinvunitor_runitor.
        }
        apply id_left.
      }
      refine (!_).
      rewrite tensor_split.
      rewrite !assoc'.
      rewrite <- enrichment_id_left.
      rewrite tensor_lunitor.
      rewrite !assoc.
      etrans.
      {
        apply maponpaths_2.
        apply mon_linvunitor_lunitor.
      }
      apply id_left.
    Qed.
  End FunctorToDialgebraEnrichment.

  (**
   4. Enrichment of natural transformations to dialgebras
   *)
  Definition build_nat_trans_to_dialgebra_enrichment
             {C₀ : category}
             {E₀ : enrichment C₀ V}
             {H₁ H₂ : C₀ ⟶ dialgebra F G}
             {EH₁ : functor_enrichment H₁ E₀ dialgebra_enrichment}
             {EH₂ : functor_enrichment H₂ E₀ dialgebra_enrichment}
             {τ : H₁ ∙ dialgebra_pr1 F G ⟹ H₂ ∙ dialgebra_pr1 F G}
             (Eτ : nat_trans_enrichment
                     τ
                     (functor_comp_enrichment EH₁ dialgebra_pr1_enrichment)
                     (functor_comp_enrichment EH₂ dialgebra_pr1_enrichment))
             (p : ∏ (x : C₀), pr2 (H₁ x) · # G (τ x) = # F (τ x) · pr2 (H₂ x))
    : nat_trans_enrichment
        (build_nat_trans_to_dialgebra _ _ τ p)
        EH₁
        EH₂.
  Proof.
    intros x y ; cbn.
    use dialgebra_enrichment_mor_eq_of_mor.
    rewrite !assoc'.
    rewrite !dialgebra_enrichment_comp_incl.
    unfold dialgebra_enrichment_comp_mor.
    rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)).
    etrans.
    {
      apply maponpaths.
      apply maponpaths_2.
      refine (!_).
      apply tensor_comp_mor.
    }
    refine (!_).
    etrans.
    {
      apply maponpaths.
      apply maponpaths_2.
      refine (!_).
      apply tensor_comp_mor.
    }
    refine (!_).
    rewrite !dialgebra_enrichment_from_arr_incl.
    rewrite !assoc.
    exact (Eτ x y).
  Qed.
End EnrichedDialgebras.


Require Export Iron.Language.SystemF2Cap.Type.
Require Export Iron.Language.SystemF2Cap.Value.Exp.
Require Export Iron.Language.SystemF2Cap.Value.Relation.TyJudge.

Inductive
  (* All computations in this value are permitted to evaluate. *)
  PermitV :  kienv -> tyenv -> stenv -> stprops -> val -> Prop :=

  | PvVar
    :  forall  ke te se sp i
    ,  PermitV ke te se sp (VVar i)

  | PvLoc
    :  forall  ke te se sp l
    ,  PermitV ke te se sp (VLoc l)

  | PvBox
    :  forall  ke te se sp x
    ,  PermitX ke te se sp x
    -> PermitV ke te se sp (VBox x)

  | PvLam
    :  forall  ke  te se sp t x
    ,  PermitX ke (te :> t) se sp x
    -> PermitV ke  te       se sp (VLam t x)

  | PvLAM
    :  forall  ke te se sp k x
    ,  PermitX (ke :> (OAbs, k)) (liftTE 0 te) se sp x
    -> PermitV ke te se sp (VLAM k x)

  | PvConst
    :  forall  ke te se sp c
    ,  PermitV ke te se sp (VConst c)

 with
  (* All computations in this expression are permitted to evaluate. *)
  PermitX : kienv -> tyenv -> stenv -> stprops -> exp -> Prop :=

  | PxVal
    :  forall  ke te se sp v
    ,  PermitV ke te se sp v
    -> PermitX ke te se sp (XVal v)

  | PxLet
    :  forall  ke  te se sp t1 x1 x2
    ,  PermitX ke  te se sp x1
    -> PermitX ke (te :> t1) se sp x2
    -> PermitX ke  te se sp (XLet t1 x1 x2)

  | PxApp
    :  forall  ke te se sp v1 v2
    ,  PermitV ke te se sp v1
    -> PermitV ke te se sp v2
    -> PermitX ke te se sp (XApp v1 v2)

  | PxAPP
    :  forall  ke te se sp v1 t2
    ,  PermitV ke te se sp v1
    -> PermitX ke te se sp (XAPP v1 t2)

  | PxPrivate
    :  forall  ke te se sp ts x t e ke' te'
    ,  ke' = ke :> (OCon, KRegion)
    -> te' = liftTE 0 te >< ts
    -> TypeX   ke' te' se sp x t e
    -> PermitT ke' te' e
    -> PermitX ke' te' se sp x
    -> PermitX ke  te  se sp (XPrivate ts x)

  | PxExtend
    :  forall  ke te se sp r x ke' te'
    ,  ke' = ke :> (OCon, KRegion)
    -> te' = liftTE 0 te
    -> PermitX ke' te' se sp x
    -> PermitX ke  te  se sp (XExtend r x)

  | PxRun
    :  forall  ke te se sp v e t
    ,  TypeV   ke te se sp v (TSusp e t)
    -> PermitT ke te e
    -> PermitV ke te se sp v
    -> PermitX ke te se sp (XRun v)

  | PxOpAlloc
    :  forall  ke te se sp r v
    ,  PermitV ke te se sp v
    -> PermitX ke te se sp (XAlloc r v)

  | PxOpRead
    :  forall  ke te se sp r v
    ,  PermitV ke te se sp v
    -> PermitX ke te se sp (XRead r v)

  | PxOpWrite
    :  forall  ke te se sp r v1 v2
    ,  PermitV ke te se sp v1
    -> PermitV ke te se sp v2
    -> PermitX ke te se sp (XWrite r v1 v2)

  | PxOpPrim
    :  forall  ke te se sp op v
    ,  PermitV ke te se sp v
    -> PermitX ke te se sp (XOp1 op v).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime B : Universe, ((wd_ O Eprime /\ (wd_ B O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ B O /\ (col_ O E O /\ (col_ O E B /\ (col_ O E O /\ (col_ O Eprime O /\ (col_ O B O /\ col_ Eprime B O))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.