(* Double colimits *)

Require Import HoTT HoTT.HIT.Colimits.

Axiom todo : forall A, A.

(** Note: this definition works well when the vertices of [G1] and [G2] are sets.
    We shall add the assumption that they are separately when needed. *)
Definition graph_prod (G1 G2 : graph) : graph :=
  {| graph0 := G1 * G2 ;
     graph1 := (fun u v => (fst u = fst v) * G2 (snd u) (snd v)  + (snd u = snd v) * G1 (fst u) (fst v))
  |}.

Section HIT_colimit_graph.
(** As an example we define the diagram for the construction of HITS.
    We will probably move this section elsewhere. *)

Inductive coeq_graph_vertex := coeq_graph_source | coeq_graph_target.

Inductive coeq_graph_edge := coeq_graph_edge_l | coeq_graph_edge_r.

Definition coeq_graph : graph :=
  {| graph0 := coeq_graph_vertex ;
     graph1 := (fun u v => match u, v with
                           | coeq_graph_source, coeq_graph_target => coeq_graph_edge
                           | _, _ => Empty
                           end)
  |}.

(* [n] is successor of [m]. *)
Fixpoint is_succ (m n : nat) {struct m} : Type :=
  match m, n with
  | 0, S 0 => Unit
  | m' .+1, n' .+1 => is_succ m' n'
  | _, _ => Empty
  end.

Fixpoint succ_is_succ (m : nat) : is_succ m (S m) :=
  match m with
  | 0 => tt
  | S m' => succ_is_succ m'
  end.

Definition telescope_graph : graph :=
  {| graph0 := nat ;
     graph1 := is_succ
  |}.

Definition hit_graph := graph_prod coeq_graph telescope_graph.

Definition truncated_telescope_graph (n : nat) : graph :=
  {| graph0 := { k : nat & k <= n } ;
     graph1 := (fun i j => is_succ i.1 j.1)
  |}.

End HIT_colimit_graph.

Section HIT_colimit_diagram.

Definition HIT_graph_truncated (n : nat) := graph_prod coeq_graph (truncated_telescope_graph n).

Lemma nat_lt_leq {m n : nat} : m < n -> m <= n.
Proof.
  apply todo.
Defined.

Lemma nat_lt_leqS {m n : nat} : m < n -> S m <= n.
  apply todo.
Defined.

(** This structure expresses an intermediate stage of the construction.
    It contains a truncated version of the entire diagram, and commutativity of the squares. *)
Structure HIT_diagram_truncated (n : nat) := {
  hdt_diagram : diagram (HIT_graph_truncated n) ;
  hdt_left_commute :
    forall (k : nat) (k_leq_n : k < n),
      let v1 := (coeq_graph_source, (k; nat_lt_leq k_leq_n)) in
      let v2 := (coeq_graph_target, (k; nat_lt_leq k_leq_n)) in
      let v3 := (coeq_graph_source, (S k; nat_lt_leqS k_leq_n)) in
      let v4 := (coeq_graph_target, (S k; nat_lt_leqS k_leq_n)) in
      let l_k := hdt_diagram _f (inr (idpath, coeq_graph_edge_l) : HIT_graph_truncated n v1 v2) in
      let l_Sk := hdt_diagram _f (inr (idpath, coeq_graph_edge_l) : HIT_graph_truncated n v3 v4) in
      let up_k := hdt_diagram _f (inl (idpath, (succ_is_succ k)) : HIT_graph_truncated n v1 v3) in
      let down_k := hdt_diagram _f (inl (idpath, (succ_is_succ k)) : HIT_graph_truncated n v2 v4) in
      down_k o l_k = l_Sk o up_k ;
  hdt_right_commute :
    forall (k : nat) (k_leq_n : k < n),
      let v1 := (coeq_graph_source, (k; nat_lt_leq k_leq_n)) in
      let v2 := (coeq_graph_target, (k; nat_lt_leq k_leq_n)) in
      let v3 := (coeq_graph_source, (S k; nat_lt_leqS k_leq_n)) in
      let v4 := (coeq_graph_target, (S k; nat_lt_leqS k_leq_n)) in
      let r_k := hdt_diagram _f (inr (idpath, coeq_graph_edge_r) : HIT_graph_truncated n v1 v2) in
      let r_Sk := hdt_diagram _f (inr (idpath, coeq_graph_edge_r) : HIT_graph_truncated n v3 v4) in
      let up_k := hdt_diagram _f (inl (idpath, (succ_is_succ k)) : HIT_graph_truncated n v1 v3) in
      let down_k := hdt_diagram _f (inl (idpath, (succ_is_succ k)) : HIT_graph_truncated n v2 v4) in
      down_k o r_k = r_Sk o up_k
}.
End HIT_colimit_diagram.


Require Import String.
Require Import NPeano.
Require Import PeanoNat.
Require Import Coq.Strings.Ascii.
Require FMapWeakList.
Require Export Coq.Structures.OrderedTypeEx.
Require Import Lists.List.
Import ListNotations.
Require Import JaSyntax.
Require Import Jafun.

Require Export FMapAVL.
Require Export Coq.Structures.OrderedTypeEx.

Module StrMap := FMapAVL.Make(String_as_OT).

Inductive JFIVarType : Set :=
| JFILoc
| JFIObj.

Inductive JFITermEnvItem : Type :=
| JFIEnvLoc (l : Loc)
| JFIEnvObj (o : Obj).

Definition JFITermEnv : Type := StrMap.t JFITermEnvItem.

Inductive JFITerm : Set :=
| JFITrue
| JFIFalse
| JFIAnd (t1 : JFITerm) (t2 : JFITerm)
| JFIOr (t1 : JFITerm) (t2 : JFITerm)
| JFIExists (type : JFIVarType) (name : string) (t : JFITerm)
| JFIForall (type : JFIVarType) (name : string) (t : JFITerm)
| JFIHoare (t1 : JFITerm) (e : JFExpr) (t2 : JFITerm)
| JFISep (t1 : JFITerm) (t2 : JFITerm)
| JFIWand (t1 : JFITerm) (t2 : JFITerm)
| JFIEq (type : JFIVarType) (var1 : string) (var2 : string)
| JFIPointsTo (loc : string) (obj : string).

Definition JFEval : JFExpr -> Heap -> list Heap -> Heap -> Prop :=
  fun e h0 hs hn => True.

Fixpoint JFIHeapSatisfies (h : Heap) (t : JFITerm) (env : JFITermEnv) : Prop :=
  match t with
    | JFITrue => True
    | JFIFalse => False
    | JFIAnd t1 t2 => JFIHeapSatisfies h t1 env /\ JFIHeapSatisfies h t2 env
    | JFIOr t1 t2 => JFIHeapSatisfies h t1 env \/ JFIHeapSatisfies h t2 env
    | JFIExists JFILoc name term => exists l : Loc,
        let env1 := StrMap.add name (JFIEnvLoc l) env in JFIHeapSatisfies h term env1
    | JFIExists JFIObj name term => True (* TODO *)
    | JFIForall type name term => True (* TODO *)
    | JFIHoare t1 e t2 =>
        forall h0 hs hn, (JFIHeapSatisfies h0 t1 env) -> (JFEval e h0 hs hn) -> (JFIHeapSatisfies hn t2 env)
    | JFISep t1 t2 => True (* TODO *)
    | JFIWand t1 t2 => True (* TODO *)
    | JFIEq JFILoc loc1 loc2 => True (* TODO *)
    | JFIEq JFIObj obj1 obj2 => True (* TODO *)
    | JFIPointsTo loc obj => True (* TODO *)
  end.

Inductive JFIProof : Set := (* TODO *)
| JFIEmpty.

Definition JFIProofValid : JFIProof -> JFITerm -> Prop := (* TODO *)
  fun p t => True.

Theorem JFISoundness : forall p t h, (JFIProofValid p t) -> (JFIHeapSatisfies h t (StrMap.empty JFIQuantifierVar)).
Proof.
admit. (*TODO*)
Admitted.


Require Import Coq.omega.Omega.
(* Laying out labels, and generally coming up with final "machine code" programs *)

Require Import Coq.NArith.NArith.

Require Import Bedrock.Nomega Bedrock.Word Bedrock.IL Bedrock.LabelMap Bedrock.PropX Bedrock.XCAP Bedrock.Memory.

Set Implicit Arguments.

Definition labelsOf' (M : LabelMap.t (assert * block)) (acc : (W * ((label -> option W) * (W -> option block))))
  : (label -> option W) * (W -> option block) :=
  snd (LabelMap.fold (fun k (v : assert * block) p => let (_, bl) := v in let '(w, (labels, prog)) := p in
    (natToWord _ 1 ^+ w,
      ((fun k' => if LabelKey.eq_dec k' k then Some w else labels k'),
        (fun w' => if weq w' w then Some bl else prog w'))))
  M acc).

Definition labelsOf (M : LabelMap.t (assert * block)) : (label -> option W) * (W -> option block) :=
  labelsOf' M (wzero _, (fun _ => None, fun _ => None)).

Lemma lt_trans : forall n m o, (n < o)%N -> m = n -> (m < o)%N.
  congruence.
Qed.

Lemma labelsOf'_inj : forall M l1 l2 w w' labels prog,
  let labels' := fst (labelsOf' M (w', (labels, prog))) in
    labels' l1 = Some w
    -> labels' l2 = Some w
    -> (forall l1' l2' w'', labels l1' = Some w'' -> labels l2' = Some w'' -> l1' = l2')
    -> (forall l w'', labels l = Some w'' -> (wordToNat w'' < wordToNat w')%nat)
    -> (wordToN w' + N_of_nat (LabelMap.cardinal M) < Npow2 32)%N
    -> l1 = l2.
  unfold labelsOf'; simpl; intros.
  rewrite LabelMap.fold_1 in *.
  rewrite LabelMap.cardinal_1 in *.
  generalize dependent prog.
  generalize dependent labels.
  generalize dependent w'.
  induction (LabelMap.elements M); simpl; intuition.
  eauto.
  simpl in *.
  eapply IHl; clear IHl; try (apply H || apply H0); simpl; intuition.
  generalize H3; clear.
  unfold wplus, wordBin.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  intro; eapply lt_trans; eauto.
  replace (Npos (P_of_succ_nat (length l))) with (1 + N_of_nat (length l))%N in *.
  replace (wordToN (NToWord 32 (1 + wordToN w'))) with (1 + wordToN w')%N.
  ring.
  rewrite NToWord_nat.
  assert (1 + wordToN w' < 4294967296)%N.

  Lemma lt_rearrange : forall n p m k,
    (n + (p + m) < k)%N
    -> (p + n < k)%N.
    intros; nomega.
  Qed.

  eapply lt_rearrange; eauto.

  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  repeat rewrite wordToN_nat.
  rewrite nat_of_N_of_nat.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite H1.
  rewrite N_of_minus.
  rewrite N_of_plus.
  rewrite N_of_mult.
  change (N_of_nat 1) with 1%N.
  destruct x.
  change (N_of_nat 0) with 0%N.
  rewrite Nmult_0_l.
  clear.
  nomega.
  elimtype False.
  clear H1.

  Lemma contra : forall x b n,
    (n < b)%nat
    -> (S x * b <= n)%nat
    -> False.
    simpl; intros.
    assert (b <= n)%nat.
    generalize dependent (x * b)%nat.
    intros; omega.
    omega.
  Qed.

  eapply contra; [ | eassumption ].
  generalize H; clear; intro.
  rewrite <- Npow2_nat.
  change 1 with (nat_of_N 1) at 1.
  rewrite <- (nat_of_N_of_nat (wordToNat w')).
  rewrite <- nat_of_Nplus.
  apply Nlt_out.
  rewrite wordToN_nat in H.
  apply H.
  clear.
  apply nat_of_N_eq.
  change (nat_of_N (Npos (P_of_succ_nat (length l)))) with (nat_of_P (P_of_succ_nat (length l))).
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ.
  rewrite nat_of_Nplus.
  simpl.
  autorewrite with N; reflexivity.

  repeat match goal with
           | [ _ : context[if ?E then _ else _] |- _ ] => destruct E
           | [ H : LabelKey.eq _ _ |- _ ] => hnf in H; subst
         end; auto.
  elimtype False.
  injection H5; clear H5; intro; subst.
  apply H2 in H4; omega.
  elimtype False.
  injection H4; clear H4; intro; subst.
  apply H2 in H5; omega.
  eauto.

  repeat match goal with
           | [ _ : context[if ?E then _ else _] |- _ ] => destruct E
           | [ H : LabelKey.eq _ _ |- _ ] => hnf in H; subst
         end; auto.
  injection H4; clear H4; intro; subst.
  generalize H3; clear; intros.
  apply Nlt_out in H3.
  autorewrite with N in *.
  change (nat_of_N (Npos (P_of_succ_nat (length l)))) with (nat_of_P (P_of_succ_nat (length l))) in H3.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H3.
  rewrite wordToN_nat in H3.
  autorewrite with N in *.
  unfold wplus, wordBin.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite NToWord_nat.
  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  rewrite wordToN_nat.
  autorewrite with N.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w'')); intuition.
  rewrite H0; clear H0.
  destruct x.
  omega.
  elimtype False.
  change 4294967296%N with (Npow2 32) in *.
  rewrite Npow2_nat in *.
  eapply contra; [ | eassumption ].
  generalize H3; clear; intro.
  generalize dependent (pow2 32).
  intros; omega.

  apply H2 in H4.
  generalize H3 H4; clear; intros.
  change 4294967296%N with (Npow2 32) in *.
  unfold wplus, wordBin.
  rewrite NToWord_nat.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  rewrite wordToN_nat.
  autorewrite with N.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite H0; clear H0.
  destruct x.
  omega.
  elimtype False.
  eapply contra; [ | eassumption ].
  generalize H3; clear; intro.
  apply Nlt_out in H3.
  autorewrite with N in *.
  change (nat_of_N (Npos (P_of_succ_nat (length l)))) with (nat_of_P (P_of_succ_nat (length l))) in H3.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H3.
  rewrite wordToN_nat in H3.
  autorewrite with N in *.
  rewrite Npow2_nat in *.
  generalize dependent (pow2 32).
  intros; omega.
Qed.

Theorem labelsOf_inj : forall M l1 l2 w, fst (labelsOf M) l1 = Some w
  -> fst (labelsOf M) l2 = Some w
  -> (N_of_nat (LabelMap.cardinal M) < Npow2 32)%N
  -> l1 = l2.
  intros; eapply labelsOf'_inj; eauto; simpl; intuition; discriminate.
Qed.

Lemma labelsOf'_agree : forall M l pre bl w' labels prog, LabelMap.MapsTo l (pre, bl) M
  -> (forall l w'', labels l = Some w'' -> (wordToNat w'' < wordToNat w')%nat)
  -> (wordToN w' + N_of_nat (LabelMap.cardinal M) < Npow2 32)%N
  -> exists w, fst (labelsOf' M (w', (labels, prog))) l = Some w
    /\ snd (labelsOf' M (w', (labels, prog))) w = Some bl.
  unfold labelsOf'; simpl; intros.
  rewrite LabelMap.fold_1 in *.
  rewrite LabelMap.cardinal_1 in *.
  apply LabelMap.elements_1 in H.
  generalize dependent prog.
  generalize dependent labels.
  generalize dependent w'.
  generalize (LabelMap.elements_3w M).
  induction 1; simpl; intuition.
  inversion H.

  inversion H; clear H; intros; subst.
  hnf in H5; simpl in H5; intuition; subst.
  destruct x; simpl in *; subst.

  exists w'; intuition.

  Lemma labels_keep : forall k v w ls w' labels prog,
    labels k = Some w
    -> ~SetoidList.InA (@LabelMap.eq_key _) (k, v) ls
    -> fst (snd (List.fold_left
      (fun
        (a : word 32 *
          ((LabelKey.t -> option (word 32)) *
            (word 32 -> option block)))
        (p : LabelMap.key * (assert * block)) =>
        let (_, bl0) := snd p in
          let '(w, (labels0, prog0)) := a in
            (WO~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1
              ^+ w,
              (fun k' : LabelKey.t =>
                if LabelFacts.eq_dec k' (fst p) then Some w else labels0 k',
                  fun w'0 : word 32 =>
                    if weq w'0 w then Some bl0 else prog0 w'0))) ls
      (w', (labels, prog))))
     k = Some w.
    induction ls as [ | [ ? [ ] ] ]; simpl; intuition.
    apply IHls; auto.
    destruct (LabelFacts.eq_dec k k0).
    elimtype False; apply H0.
    hnf in e; subst.
    constructor; hnf; auto.
    auto.
  Qed.

  eapply labels_keep; eauto.
  destruct (LabelFacts.eq_dec k k); auto.
  elimtype False; apply n; reflexivity.

  Lemma prog_keep : forall w bl ls w' labels prog,
    prog w = Some bl
    -> w < w'
    -> (wordToN w' + N_of_nat (length ls) < Npow2 32)%N
    -> snd (snd (List.fold_left
      (fun
        (a : word 32 *
          ((LabelKey.t -> option (word 32)) *
            (word 32 -> option block)))
        (p : LabelMap.key * (assert * block)) =>
        let (_, bl0) := snd p in
          let '(w, (labels0, prog0)) := a in
            (WO~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1
              ^+ w,
              (fun k' : LabelKey.t =>
                if LabelFacts.eq_dec k' (fst p) then Some w else labels0 k',
                  fun w'0 : word 32 =>
                    if weq w'0 w then Some bl0 else prog0 w'0))) ls
      (w', (labels, prog))))
     w = Some bl.
    induction ls as [ | [ ? [ ] ] ]; simpl; intuition.
    apply IHls; auto.
    destruct (weq w w').
    subst.
    elimtype False.
    unfold wlt in H0.
    apply Nlt_not_eq in H0; tauto.
    auto.

    generalize H0 H1; clear; intros.
    change 4294967296%N with (Npow2 32) in *.
    destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
    rewrite <- Npow2_nat in *.
    generalize dependent (Npow2 32); intros.
    apply Nlt_out in H1.
    autorewrite with N in *.
    change (nat_of_N (Npos (P_of_succ_nat (length ls)))) with (nat_of_P (P_of_succ_nat (length ls))) in H1.
    rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H1.
    rewrite wordToN_nat in H1.
    autorewrite with N in *.
    unfold wlt in *.
    unfold wplus, wordBin.
    rewrite NToWord_nat.
    repeat rewrite wordToN_nat in *.
    autorewrite with N in *.
    match goal with
      | [ |- context[wordToNat ?N] ] =>
        match N with
          | _~1 => change (wordToNat N) with 1
        end
    end.
    rewrite H2; clear H2.
    destruct x.
    generalize H0; clear.
    intros; nomega.
    elimtype False.
    clear H0.

    Lemma slow : forall x ln w' n,
      (w' + S ln < n)%nat
      -> (S x * n <= 1 + w')%nat
      -> False.
      simpl; intros.
      generalize dependent (x * n); intros; omega.
    Qed.

    eapply slow; eassumption.

    generalize H1; clear; intros.
    change 4294967296%N with (Npow2 32) in *.
    destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
    rewrite <- Npow2_nat in *.
    generalize dependent (Npow2 32); intros.
    unfold wplus, wordBin.
    rewrite NToWord_nat.
    match goal with
      | [ |- context[wordToN ?N] ] =>
        match N with
          | _~1 => change (wordToN N) with 1%N
        end
    end.
    rewrite nat_of_Nplus.
    change (nat_of_N 1) with 1.
    rewrite wordToN_nat.
    autorewrite with N.
    repeat rewrite wordToN_nat in *.
    autorewrite with N in *.
    rewrite H0; clear H0.
    rewrite N_of_minus.
    rewrite N_of_plus.
    rewrite N_of_mult.
    change (N_of_nat 1) with 1%N.
    apply Nlt_out in H1.
    autorewrite with N in *.
    change (nat_of_N (Npos (P_of_succ_nat (length ls)))) with (nat_of_P (P_of_succ_nat (length ls))) in H1.
    rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H1.
    destruct x.
    change (N_of_nat 0) with 0%N.
    apply Nlt_in.
    autorewrite with N.
    change (nat_of_N 1) with 1.
    change (nat_of_N (0 * N_of_nat (pow2 32))) with 0.
    omega.
    elimtype False.
    eapply contra; [ | eassumption ].
    omega.
  Qed.

  apply prog_keep.
  destruct (weq w' w'); tauto.

  generalize H2; clear; intros.
  change 4294967296%N with (Npow2 32) in *.
  apply Nlt_out in H2.
  autorewrite with N in H2.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))) in H2.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H2.
  unfold wlt, wplus, wordBin.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite NToWord_nat in *.
  rewrite wordToN_nat in *.
  autorewrite with N in *.
  rewrite wordToN_nat in *.
  change (nat_of_N 1) with 1.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite H0.
  rewrite <- Npow2_nat in *.
  generalize dependent (Npow2 32); intros.
  apply Nlt_in.
  autorewrite with N.
  destruct x.
  omega.
  elimtype False.
  eapply slow; eauto.

  generalize H2; clear.
  change 4294967296%N with (Npow2 32).
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite <- Npow2_nat in *.
  generalize dependent (Npow2 32); intros.
  eapply lt_trans; eauto.
  apply nat_of_N_eq.
  autorewrite with N.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))).
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ.
  rewrite wordToN_nat.
  autorewrite with N.
  unfold wplus, wordBin.
  rewrite NToWord_nat.
  autorewrite with N.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  change (nat_of_N 1) with 1.
  rewrite wordToN_nat; autorewrite with N.
  rewrite H0; clear H0.
  apply Nlt_out in H2.
  autorewrite with N in *.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))) in H2.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H2.
  destruct x.
  omega.
  elimtype False.
  eapply slow; eauto.
  rewrite wordToN_nat; autorewrite with N; eauto.

  destruct x as [ ? [ ] ]; simpl in *.
  apply IHNoDupA; auto.
  generalize H2; clear.
  change 4294967296%N with (Npow2 32) in *.
  unfold wplus, wordBin.
  rewrite NToWord_nat.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  repeat rewrite wordToN_nat.
  autorewrite with N.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite H0; clear H0.
  repeat rewrite <- Npow2_nat in *.
  generalize dependent (Npow2 32); intros.
  rewrite N_of_minus.
  rewrite N_of_plus.
  rewrite N_of_mult.
  change (N_of_nat 1) with 1%N.
  apply Nlt_out in H2.
  autorewrite with N in H2.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))) in H2.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H2.
  autorewrite with N.
  destruct x.
  apply Nlt_in.
  autorewrite with N.
  change (nat_of_N 1) with 1.
  change (nat_of_N (N_of_nat 0 * n))%N with 0.
  omega.
  elimtype False.
  eapply contra; [ | eassumption ].
  omega.

  intros.
  repeat match goal with
           | [ _ : context[if ?E then _ else _] |- _ ] => destruct E
           | [ H : LabelKey.eq _ _ |- _ ] => hnf in H; subst
         end; auto.
  injection H; clear H; intro; subst.
  generalize H2; clear; intros.
  apply Nlt_out in H2.
  autorewrite with N in *.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))) in H2.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H2.
  rewrite wordToN_nat in H2.
  autorewrite with N in *.
  unfold wplus, wordBin.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite NToWord_nat.
  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  rewrite wordToN_nat.
  autorewrite with N.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w'')); intuition.
  rewrite H0; clear H0.
  destruct x.
  omega.
  elimtype False.
  change 4294967296%N with (Npow2 32) in *.
  rewrite Npow2_nat in *.
  eapply contra; [ | eassumption ].
  omega.

  apply H3 in H.
  generalize H H2; clear; intros.
  change 4294967296%N with (Npow2 32) in *.
  unfold wplus, wordBin.
  rewrite NToWord_nat.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  rewrite wordToN_nat.
  autorewrite with N.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite H1; clear H1.
  destruct x.
  omega.
  elimtype False.
  eapply contra; [ | eassumption ].
  generalize H2; clear; intro.
  apply Nlt_out in H2.
  autorewrite with N in *.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))) in H2.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H2.
  rewrite wordToN_nat in H2.
  autorewrite with N in *.
  rewrite Npow2_nat in *.
  generalize dependent (pow2 32).
  intros; omega.
Qed.

Theorem labelsOf_agree : forall M l pre bl, LabelMap.MapsTo l (pre, bl) M
  -> (N_of_nat (LabelMap.cardinal M) < Npow2 32)%N
  -> exists w, fst (labelsOf M) l = Some w
    /\ snd (labelsOf M) w = Some bl.
  intros; eapply labelsOf'_agree; intuition eauto; discriminate.
Qed.

(** * Some default word-size memory accessors *)

Theorem wlt_not_refl : forall n (w : word n), w < w -> False.
  unfold wlt; intros; nomega.
Qed.

Hint Immediate wlt_not_refl.

Lemma use_separated : forall (k : W) q,
  (forall n m, (n < 4)%nat -> (m < 4)%nat -> k ^+ $ q ^+ $ n = k ^+ $ m -> False)
  -> (q < 4)%nat
  -> False.
  intros.
  apply H with 0 q; auto.
  word_eq.
Qed.

Lemma use_separated' : forall (k : W) q,
  (forall n m, (n < 4)%nat -> (m < 4)%nat -> k ^+ $ n = k ^+ $ q ^+ $ m -> False)
  -> (q < 4)%nat
  -> False.
  intros.
  apply H with q 0; auto.
  word_eq.
Qed.

Local Hint Extern 1 False => eapply use_separated; [ eassumption | omega ].
Local Hint Extern 1 False => eapply use_separated'; [ eassumption | omega ].
Local Hint Extern 1 False => match goal with
                               | [ H : forall n m : nat, _ |- _ ] => eapply H; [ | | eassumption ]; omega
                             end.

(** * Finally, we can create settings for testing. *)

Section LittleEndianSettings.
  Variable memHigh : W.
  Variable m : module.

(** NOTE: this is little endian *)
  Definition explode_le (v : W) : B * B * B * B :=
    let dw1 := split1 16 16 v in
    let dw2 := split2 16 16 v in
    let b1 := split1 8 8 dw1 in
    let b2 := split2 8 8 dw1 in
    let b3 := split1 8 8 dw2 in
    let b4 := split2 8 8 dw2 in
    (b1,b2,b3,b4).

  Definition implode_le (bs : B * B * B * B) : W :=
    let '(b1,b2,b3,b4) := bs in
    combine (combine b1 b2) (combine b3 b4).

  Theorem implode_explode_le : forall w,
    implode_le (explode_le w) = w.
  Proof.
    unfold implode_le, explode_le.
    intros. repeat rewrite combine_split. reflexivity.
  Qed.

  Theorem explode_implode_le : forall b,
    explode_le (implode_le b) = b.
  Proof.
    unfold implode_le, explode_le.
    intros. destruct b. destruct p. destruct p.
    repeat (rewrite split1_combine || rewrite split2_combine).
    reflexivity.
  Qed.

  Definition leSettings := {|
    implode := implode_le ;
    explode := explode_le ;
    implode_explode := implode_explode_le ;
    explode_implode := explode_implode_le ;
    Labels := fst (labelsOf (Blocks m))
  |}.

  Hypothesis closed : LabelMap.cardinal (Imports m) = 0.
  Hypothesis notTooBig : (N_of_nat (LabelMap.cardinal (Blocks m)) < Npow2 32)%N.
  Hypothesis ok : moduleOk m.

  Theorem safety : forall mn g pre, LabelMap.find (mn, Global g) (Exports m) = Some pre
    -> forall w, Labels leSettings (mn, Global g) = Some w
      -> forall st, interp (specs m leSettings) (pre (leSettings, st))
        -> safe leSettings (snd (labelsOf (Blocks m))) (w, st).
    intros; eapply safety; intuition eauto.
    apply labelsOf_inj with (Blocks m) w0; auto.
    simpl; eapply labelsOf_agree; eauto.
    apply LabelMap.find_2; eauto.
  Qed.
End LittleEndianSettings.


(****************************************************************)
(*  On monadic parametricity of second-order functionals        *)
(*  by Bauer A., Hofmann M., Karbyshev A.                       *)
(*                                                              *)
(*  Aleksandr Karbyshev                                         *)
(*  May 2012                                                    *)
(*  Build with Coq 8.4 + Ssreflect 1.4                          *)
(****************************************************************)

Set Automatic Coercions Import.
Require Import PredomLiftClassical.
Require Import relations.
Require Import strategy.
Require Import stuff.

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

(*Set Printing Width 65.*)

Section Functional.
Variables A B C : cpoType.
Definition FuncType : Type :=
  forall (T : monadType), (A -=> T B) =-> (T C : cpoType).
End Functional.

Section Purity.
Variables A B C : cpoType.

Definition isPure (F : FuncType A B C) : Prop
  := forall (T T' : monadType) (TRacc : TRelAccType T T'),
    ((IdR (X := A) =R=> TRel TRacc (IdR (X := B))) =R=>
       TRel TRacc (IdR (X := C))) (F T) (F T').
End Purity.

Module Domains : DomainParamsType.
  Parameters DA DB DC : cpoType.
End Domains.

Module Import StrategyTree := StrategyTree (Domains).

Definition STree : cppoType := liftCppoType DInf.
Definition Fold := eta << Roll.
Definition Unfold := eta << Unroll.

Definition Ans := Fold << INL _ _.
Definition Que := exp_fun (Fold << INR _ _).

Definition fun2tree (F : FuncType DA DB DC) := F (Cont STree) Que Ans.

Definition Op1 (A B C : cpoType) (f : A =-> B -=> C) (g : A =-> B) : A =-> C := uncurry f << <| Id, g |> .

Lemma Op1_simpl A B C f g a : @Op1 A B C f g a =-= f a (g a).
Proof.
by [].
Qed.

Definition phi (T : monadType) : (DC + DA * (DB -=> DInf _BOT)) =-> (DInf _BOT -=> ((DA -=> T DB) -=> T DC)) -=> ((DA -=> T DB) -=> T DC)
  := [| exp_fun (
          uncurry (@const _ _ (exp_fun (@tval T _ << FST _ _)))
          << SWAP),
        exp_fun (exp_fun (
          Op1
            (@tbind T _ _ <<
              Op1 (SND _ _) (FST _ _ << FST _ _ << FST _ _))
            (exp_fun (
              (Op1
                (uncurry (SND _ _ << FST _ _))
                (uncurry (@const _ _ (SND _ _)) << SWAP)) <<
              <| FST _ _, uncurry (SND _ _ << FST _ _ << FST _ _) |>)
            )))
      |].

Definition phi_inl_simpl (T : monadType) c f h :
  phi T (inl _ c) f h =-= tval T _ c.
by rewrite SUM_fun_simpl.
Qed.

Definition phi_inr_simpl (T : monadType) a k f h :
  phi T (inr _ (a, k)) f h =-= @tbind T _ _ (h a) (Fcont_app ((f : fcont _ _) << k) h).
rewrite /=. rewrite /phi /=.
rewrite SUM_fun_simpl /=.
apply: fmon_eq_compat; first by reflexivity.
by apply: fmon_eq_intro.
Qed.

Definition G (T : monadType) : (DInf _BOT -=> ((DA -=> T DB) -=> T DC)) =->  DInf _BOT -=> ((DA -=> T DB) -=> T DC)
  := CURRY (uncurry (mu1 (phi T << Unroll)) << SWAP).

Lemma G_PBot_simpl (T : monadType) f h : @G T f PBot h =-= PBot.
Proof.
rewrite /=. by rewrite mu1axiom1.
Qed.

Lemma G_Val_simpl (T : monadType) f h d : @G T f (Val d) h =-= phi T (Unroll d) f h.
Proof.
rewrite /=. by rewrite mu1axiom2.
Qed.

Definition tree2funT (T : monadType)
  : exp_cppoType (DInf _BOT) (exp_cppoType (DA -=> T DB) (T DC))
  := fixp (G T).

Lemma tree2funT_eq (T : monadType) :
  tree2funT T =-= G T (@tree2funT T).
Proof.
by apply: fixp_eq.
Qed.

Lemma tree2funT_PBot_simpl (T : monadType) :
  tree2funT T PBot =-= PBot.
Proof.
rewrite /tree2funT fixp_eq. apply: fcont_eq_intro => h.
change (G T (fixp (G T)) PBot h =-= PBot).
by apply: G_PBot_simpl.
Qed.

Lemma tree2funT_Ans_simpl (T : monadType) c h :
  tree2funT T (Ans c) h =-= tval T _ c.
Proof.
rewrite tree2funT_eq /Ans.
rewrite G_Val_simpl.
change (phi T ((Unroll << Roll) (inl _ c)) (tree2funT T) h =-= tval T DC c).
rewrite UR_id. by apply: phi_inl_simpl.
Qed.

Lemma tree2funT_Que_simpl (T : monadType) a k h :
  tree2funT T (Que a k) h =-= tbind T _ _ (h a) (Fcont_app ((tree2funT T : fcont _ _) << k) h).
Proof.
have H := fcont_eq_compat
  (fcont_eq_compat (tree2funT_eq T) (Oeq_refl (Que a k)))
  (Oeq_refl h).
apply (Oeq_trans H).
rewrite G_Val_simpl.
change (phi T ((Unroll << Roll) (inr _ (a, k))) (tree2funT T) h =-= tbind T _ _ (h a) (Fcont_app ((tree2funT T : fcont _ _) << k) h)).
rewrite UR_id. by apply: phi_inr_simpl.
Qed.

Definition treeQuePBot (a : DA) : STree := eta (Roll (inr _ (a, const _ PBot))).

Lemma tree2funT_State_treeQuePBot S a :
  tree2funT (State S) (treeQuePBot a) =-= PBot.
Proof.
rewrite tree2funT_eq /=.
rewrite mu1axiom2.
apply: fmon_eq_intro => h /=.
change ((phi (State S) << (Unroll << Roll)) (inr DC (a, const DB PBot)) (tree2funT _) h =-= PBot).
rewrite UR_id comp_idR.
rewrite phi_inr_simpl.
apply: (Oeq_trans _ (@bindState_bot S _ _ (h a))).
rewrite /bindState. apply: fcont_eq_compat; first by apply: Oeq_refl.
apply: fmon_eq_intro => b.
change (tree2funT (State S) PBot h =-= PBot).
by rewrite tree2funT_PBot_simpl.
Qed.

Definition tree2fun (t : STree) : FuncType DA DB DC.
move => T. by apply: (tree2funT T t).
Defined.

Lemma tree2fun_simpl (t : STree) (T : monadType) :
  @tree2fun t T = tree2funT _ t.
Proof.
by rewrite /tree2fun.
Qed.

(* TODO: move to PredomCore.v *)
Lemma Fcont_app_simpl X Y Z (f : X =-> Y -=> Z) x y : Fcont_app f y x = f x y.
Proof.
by [].
Qed.

Lemma tree2fun_pure (t : STree) : isPure (@tree2fun t).
Proof.
rewrite /isPure. move => T T' TR.
rewrite !tree2fun_simpl.
pose Q : Rel ((STree : cpoType) =-> (DA -=> T DB) -=> T DC) ((STree : cpoType) =-> (DA -=> T' DB) -=> T' DC)
  := fun f f' (*: STree =-> (DA -=> T DB)-=> T DC)*) =>
    forall t, ((@IdR _ =R=>  (TRel TR) DB DB (@IdR _)) =R=>  (TRel TR) DC DC (@IdR _)) (f t) (f' t).
have admQ : admissibleR Q.
  move => c c' H. rewrite /Q => t0.
  apply: admissibleArrR => /=.
  - apply (@Adm _ _ TR). by apply (admissibleIdR).
  - by move => n; apply: H.
suff : Q (tree2funT T) (tree2funT T'); first by [].
apply: {t} fixpR_ind; first by [].
- move => t /=. move => h h' _ /=. by apply: (Str TR).
- move => f f' Hff'. move => t.
  case: (axiom_liftCpo_dec t).
  + move => Heq.
    have Heq1 := (@fcont_eq_compat _ _ (G T f) (G T f) (Oeq_refl _) _ _ (Oeq_sym Heq)).
    have Heq1' := (@fcont_eq_compat _ _ (G T' f') (G T' f') (Oeq_refl _) _ _ (Oeq_sym Heq)).
    apply (axiom_Rel_compat Heq1 Heq1') => {Heq1 Heq1'}.
    move => h h' Hhh'.
    apply: (axiom_Rel_compat (Oeq_sym (@G_PBot_simpl _ f h)) (Oeq_sym (@G_PBot_simpl _ f' h'))).
    by apply: (Str TR).
  + elim => d Hd.
    have Heq1 := (@fcont_eq_compat _ _ (G T f) (G T f) (Oeq_refl _) _ _ (Oeq_sym Hd)).
    have Heq1' := (@fcont_eq_compat _ _ (G T' f') (G T' f') (Oeq_refl _) _ _ (Oeq_sym Hd)).
    apply (axiom_Rel_compat Heq1 Heq1') => {Heq1 Heq1'}.
    move => h h' Hhh'.
    apply: (axiom_Rel_compat (Oeq_sym (@G_Val_simpl _ f h d)) (Oeq_sym (@G_Val_simpl _ f' h' d))).
    elim: (Unroll d) => x.
    * apply: (axiom_Rel_compat (Oeq_sym (@phi_inl_simpl _ _ f h)) (Oeq_sym (@phi_inl_simpl _ _ f' h'))).
      elim: (Acc TR) => [Hval _]. by intuition.
    * elim: x => a k.
      apply: (axiom_Rel_compat (Oeq_sym (@phi_inr_simpl _ a k f h)) (Oeq_sym (@phi_inr_simpl _ a k f' h'))).
      apply: (proj2 (Acc TR)); first by apply Hhh'.
      move => b b' Hbb' /=.
      have Htmp : f' (k b) h' =-= f' (k b') h'.
        apply: fcont_eq_compat; last by [].
        apply: fmon_eq_compat; first by apply Oeq_refl.
        by apply: fmon_eq_compat; first by apply Oeq_refl.
      apply (axiom_Rel_compat (Oeq_refl _) Htmp) => {Htmp}.
      by apply: Hff'.
Qed.

Lemma kleisli_bot_simpl D1 D2 :
  kleisli (PBot : exp_cppoType D1 (liftCppoType D2)) =-=
  (PBot : exp_cppoType (D1 _BOT) (liftCppoType D2)).
Proof.
apply: fcont_eq_intro => x /=.
split => /=; last by apply: leastP.
apply: DLless_cond => d2 H.
elim: (kleisliValVal H ) => {H} /= d1 [_ Hfalse].
by elim: (PBot_incon_eq (Oeq_sym Hfalse)).
Qed.

Theorem tree2fun2tree : forall t, fun2tree (tree2fun t) =-= t.
Proof.
move => t. rewrite /fun2tree tree2fun_simpl.
suff : Fcont_app (Fcont_app (tree2funT (Cont STree)) Que) Ans =-= Id.
  move => H.
  have H1 := (fcont_eq_compat H (Oeq_refl t)) => {H}.
  by rewrite !Fcont_app_simpl in H1.
clear t.
rewrite -kleisli_unit id_min FIXP_simpl.
rewrite /tree2funT.
pose T := Cont STree.
pose Q : Rel
  (DInf _BOT -=> ((DA -=> T DB) -=> T DC))
  (DInf -=> DInf _BOT)
  := fun f f' => Fcont_app (Fcont_app f Que) Ans =-= kleisli f'.
have admQ : admissibleR Q.
  move => c c' H. rewrite /Q.
  change (Fcont_app (Fcont_app (lub c) Que) Ans =-= KLEISLI (lub c')).
  rewrite lub_comp_eq. apply: fcont_eq_intro => x /=.
  apply: lub_eq_compat. apply: fmon_eq_intro => n /=.
  rewrite /Q in H. by rewrite -(H n).
suff : Q (fixp (G T)) (fixp delta); first by [].
apply: fixpR_ind; first by [].
- rewrite /Q. apply: fcont_eq_intro => x /=.
  apply: Oeq_sym. by rewrite kleisli_bot_simpl.
- move => f f' Hff'.
  rewrite /Q. setoid_rewrite delta_simpl. rewrite /=.
  apply: fcont_eq_intro => t /=.
  case: (axiom_liftCpo_dec t). (* non-constructive step! *)
  + move => Heq. rewrite Heq => {Heq t}.
    rewrite mu1axiom1. by rewrite kleisli_bot.
  + elim => d Hd. rewrite Hd => {Hd t}.
    rewrite mu1axiom2 kleisliVal /=.
    case: (Unroll d) => [c | [a k]] /=.
    * by rewrite !SUM_fun_simpl /= kleisliVal.
    * rewrite (fcont_eq_compat (phi_inr_simpl a k f Que) (Oeq_refl Ans)).
      rewrite SUM_fun_simplx. rewrite bindCont_simpl /=.
      rewrite !kleisliVal /=. apply: Val_eq_compat.
      apply: fcont_eq_compat; first by apply: Oeq_refl.
      change
        (INR DC _ (a, Fcont_app (Fcont_app ((f : fcont _ _) << k) Que) Ans) =-=
         INR DC _ (a, kleisli f' << k)).
      apply: fcont_eq_compat => //.
      apply: pair_cpo_eq_compat => //.
      rewrite /Q in Hff'. rewrite -Hff'.
      by apply: fcont_eq_intro => n.
Qed.

Section conversion.
Variable DS : cppoType.
Variable q : DA =-> (DB -=> DS) -=> (DS (*: cpoType*)).
Variable a : DC =-> (DS : cpoType).

Definition conv := Fcont_app (Fcont_app (@tree2funT (Cont DS)) q) a.

Lemma conv_PBot_simpl : conv PBot =-= PBot.
Proof.
rewrite /conv.
change (tree2funT (Cont DS) PBot q a =-= PBot).
by rewrite tree2funT_PBot_simpl.
Qed.

Lemma conv_Ans_simpl c : conv (Ans c) =-= a c.
Proof.
rewrite /conv.
change (tree2funT (Cont DS) (Ans c) q a =-= a c).
by rewrite tree2funT_Ans_simpl.
Qed.

Lemma conv_Que_simpl a1 h h' : ((@IdR _) =R=>  Gr (conv)) h h' -> conv (Que a1 h) =-= q a1 h'.
Proof.
move => Hhh'.
rewrite /conv.
change (tree2funT (Cont DS) (Que a1 h) q a =-= q a1 h').
rewrite tree2funT_Que_simpl.
rewrite bindCont_simpl.
apply: (fcont_eq_compat (Oeq_refl _)).
apply: fcont_eq_intro => b.
have H := Hhh' b b (IdR_refl _) => {Hhh'}.
rewrite /Gr /conv in H.
rewrite -H /=. by apply: Oeq_refl.
Qed.

Definition TRacc1 : TRelAccType (Cont STree) (Cont DS).
exists
  (fun (X X' : cpoType) (R : Rel X X') => fun (H : Cont STree X) (H' : Cont DS X') =>
    forall h h', (R =R=> Gr conv) h h' -> Gr conv (H h) (H' h')).
- split.
  + intros; simpl; intuition.
  + move => X X' Y Y' Q R f f' t t' H H0.
    move => h h' Hhh'. apply: H => x x' Hxx' /=.
    by eapply H0; eauto.
- move => X X' R Hadm. move => c c' /= H.
  move => h h' Hhh'. rewrite /Gr.
  rewrite lub_comp_eq. apply: lub_eq_compat.
  apply: fmon_eq_intro => n. by apply: H.
- move => X X' R /=. move => _ _ _.
  rewrite /Gr. by rewrite conv_PBot_simpl.
Defined.
End conversion.

Lemma fun2tree2fun_Cont (S : cppoType) (F : FuncType DA DB DC) (Hpure : isPure F) :
  @tree2funT (Cont S) (fun2tree F) =-= F (Cont S).
Proof.
rewrite /tree2funT /=.
apply: fcont_eq_intro => q.
apply: fcont_eq_intro => a.
suff H : Gr (conv q a) (F (Cont STree) Que Ans) (F (Cont S) q a).
  rewrite /Gr in H. rewrite -H. rewrite /conv /=. by apply: lub_eq_compat.
rewrite /isPure in Hpure.
have H := Hpure _ _ (TRacc1 q a) => {Hpure}.
apply: H.
- move => a1 a1' H.
  have Eq : q a1 =-= q a1'
    by apply: (fcont_eq_compat (Oeq_refl _)).
  move => h h' Hhh'. rewrite /Gr.
  have Eqh' : q a1 h' =-= q a1' h'
    by apply: (fcont_eq_compat Eq (Oeq_refl _)).
  apply: (Oeq_trans _ Eqh') => {Eq Eqh'}.
  by apply: conv_Que_simpl.
- move => c c' Hcc'. rewrite /Gr -Hcc'.
  by apply: conv_Ans_simpl.
Qed.

Definition Phi (T : monadType) (F : (DA -=> Cont (T DC) DB) =-> Cont (T DC) DC) : (DA -=> T DB) =-> T DC
  := Fcont_app F (@tval T DC) << CCOMP _ _ _ << <| const _ (@tbind T DB DC) , Id |>.

Definition PHI (T : monadType)
  : ((DA -=> Cont (T DC) DB) -=> Cont (T DC) DC) =-> (DA -=> T DB) -=> T DC
  := exp_fun (EV _ _ <<
     <| EV _ _ <<
        <|
         FST _ _,
         CCOMP _ _ _ << <| const _ (@tbind T DB DC), SND _ _ |>
        |>,
        const _ (@tval T DC)
     |>).

Lemma Phi_simpl (T : monadType) F g :
  Phi F g =-= F (tbind T _ _ << g) (tval T _).
Proof.
rewrite /=.
apply: fcont_eq_compat; last by apply: Oeq_refl.
by apply: fcont_eq_intro => a.
Qed.

Lemma PHI_simpl (T : monadType) F g :
  @PHI T F g =-= F (tbind T _ _ << g) (tval T _).
Proof.
by [].
Qed.

Definition TRacc2 (T : monadType) : TRelAccType (Cont (T DC)) T.
exists
  (fun (X X' : cpoType) (R : Rel X X') => fun (H : Cont (T DC) X) (H' : T X') =>
    forall h h', (R =R=> @IdR (T DC)) h h' ->
      (@IdR (T DC) (H h) (tbind T _ _ H' h'))).
- split.
  + intros. rewrite /IdR /=. rewrite taxiom0. by firstorder.
  + move => X X' Y Y' Q R f f' t t' H H0.
    move => h h' Hhh'. rewrite taxiom2 /=. apply: H => x x' Hxx' /=. by apply: H0.
- move => X X' R Hadm. move => c c' /= H.
  move => h h' Hhh'. rewrite lub_comp_eq. apply: lub_eq_compat.
  apply: fmon_eq_intro => n /=. by apply: H.
- move => X X' R /=. move => h h' _. by rewrite taxiom3.
Defined.

Lemma PHI_Cont (T : monadType) (F : FuncType DA DB DC) (Hpure : isPure F) :
  PHI T (F (Cont (T DC))) =-= F T.
Proof.
apply: fcont_eq_intro => g. rewrite PHI_simpl.
rewrite -(taxiom1 (F T g)).
have H := Hpure _ _ (TRacc2 T) => {Hpure}.
apply: H.
- move => a a' Haa'.
  have Eg : g a =-= g a' by apply: (fcont_eq_compat (Oeq_refl _)).
  move => h h' Hhh' /=.
  have Eh : h =-= h'
    by apply: fcont_eq_intro => b; apply: (Hhh' _ _ (Oeq_refl _)).
  by rewrite -Eg -Eh.
- move => c c' H. by rewrite H.
Qed.

Theorem fun2tree2fun (F : FuncType DA DB DC) (Hpure : isPure F) :
  forall (T : monadType), @tree2fun (fun2tree F) T =-= @F T.
Proof.
move => T.
rewrite -[in X in _ =-= X](@PHI_Cont _ F) => //.
rewrite -[in X in _ =-= X](@fun2tree2fun_Cont _ F) => //.
rewrite [in X in _ =-= X](@PHI_Cont _ (tree2fun (fun2tree F))) => //.
by apply: tree2fun_pure.
Qed.


From Undecidability.L.Computability Require Export Fixpoints Decidability Seval.
From Undecidability.L.Functions Require Export Proc Encoding.
Import ARS.ARSNotations L_Notations.
(* * Scott's Theorem *)

Theorem Scott (M : term -> Prop) : M <=1 closed ->
  (forall s t, M s -> closed t -> t == s -> M t) ->
  (exists t1, closed t1 /\ M t1) -> (exists t2, closed t2 /\ ~ M t2) ->
  ~ ldec M.
Proof.
  intros M_cl M_equiv [s1 [cls_s1 Ms1]] [s2 [cls_s2 nMs2]] [u [[cls_u lam_u] Hu]].
  pose (x := lam(u #0 (lam s2) (lam s1) I)).
  destruct (SecondFixedPoint (s := x)) as [t [cls_t H]]. subst x. Lproc.
  eapply eqTrans with (s := u (enc t) (lam s2) (lam s1) I) in H.
  destruct (Hu t) as [[]  [R C]].
  - eapply nMs2, M_equiv; eauto.
    rewrite <- H,R. symmetry. Lrewrite. LsimplRed.
  - eapply C, M_equiv; eauto.
    rewrite <- H,R. Lrewrite. LsimplRed.
  -symmetry. etransitivity. apply eqStep. apply step_Lproc;Lproc. simpl. now rewrite cls_u,cls_s1,cls_s2.
Qed.

(* * Applications of Scott's Theorem *)

Goal ~ ldec (fun x => closed x /\ converges x).
Proof.
  eapply Scott.
  - tauto.
  - intros s t [cls_s [x [Hx lx]]] cls_t t_e_s; split.
    + eassumption.
    + exists x;split;[|Lproc]. now rewrite t_e_s.
  - exists I. repeat split. exists I;split.  reflexivity. Lproc.
  - exists Omega. repeat split. intros [_ [x [Hx lx]]]. inv lx. eapply Omega_diverges. exact Hx.
Qed.

Lemma I_neq_Omega : ~ I == Omega.
Proof.
  intros H. eapply Omega_diverges. rewrite <- H. unfold I. cbv; reflexivity.
Qed.

Lemma C27 : forall t, closed t -> ~ ldec (fun x => closed x /\ x == t).
Proof.
  intros t cls_t H. cut (ldec (fun x : term => closed x /\ x == t)).
  eapply Scott.
  - tauto.
  - intros s t0 [cls_s H0] cls_t0 H1. split. assumption. rewrite H1. assumption.
  - exists t. repeat split. assumption. assumption. reflexivity.
  - destruct H. destruct H. destruct (H0 I) as [[] [? ?]].
    +destruct H2 as [? ?]. exists Omega. split. intros k r. simpl. reflexivity. intros [_ C]. eapply I_neq_Omega. rewrite C. auto.
    +exists I. split. Lproc. auto.
  - eassumption.
Qed.

Lemma C27_proc : forall t, proc t -> ~ ldec (fun x => x == t).
Proof.
  intros t proc_t H. eapply C27; eauto using ldec_conj, ldec_closed; Lproc.
Qed.

Lemma Eq_ldec : ~ ldec (fun x => exists (s t : term), x = enc (s t) /\ s == t).
Proof.
  intros [u [[cls_u lam_u] Hu]].
  pose (t := I).
  eapply (C27_proc (t := t)). Lproc.
  pose (v := (lam(u ((ext (enc (X:=term))) ((ext app) #0 (ext t)))))).
  exists v. split. subst v;Lproc.
  intros s. destruct (Hu (ext (s t))) as [b [eq C]].
  exists b. split.
  +subst v. Lsimpl. eassumption.
  +destruct b.
   *destruct C as [? [? [eq' ?]]]. apply inj_enc in eq'. congruence.
   *intros eq'. apply C. now repeat eexists.
Qed.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.
Require Import Setoid.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.
Require Import Def.

Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Section TracePropertiesCriterion.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  (*CA: we don't need a particular structure of traces to define preservation
        e.g. traces = values or our defn of traces both make sense
   *)
  Variable trace__S trace__T : Type.

  Local Definition prop__S := prop trace__S.
  Local Definition prop__T := prop trace__T.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition beh__S := beh Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition beh__T := beh Target_Semantics.
  Local Definition prg__S := prg Source.
  Local Definition prg__T := prg Target.
  Local Definition sat__S := sat Source_Semantics.
  Local Definition sat__T := sat Target_Semantics.

  Local Definition cmp := compile_whole Source Target compilation_chain.

  Local Notation "W ↓" := (cmp W) (at level 50).

  Variable rel : trace__S -> trace__T -> Prop.

  Local Definition adjunction :=  induced_connection rel.

  Local Definition τ' : prop__S -> prop__T := α adjunction.
  Local Definition σ' : prop__T -> prop__S := γ adjunction.

  Local Definition rel_adjunction_law : Adjunction_law τ' σ' := adjunction_law adjunction.

  Definition rel_TC := forall W t, sem__T (W ↓) t -> exists s, rel s t /\ sem__S W s.

  Lemma rel_TC' : rel_TC <-> (forall W, beh__T (W ↓) ⊆ (τ' (beh__S W))).
  Proof.
    rewrite /τ' /α //= /low_rel;
    split => H W t__T Wcmp_t; specialize (H W t__T Wcmp_t); firstorder.
  Qed.

  Local Definition τTP := τTP compilation_chain
                          Source_Semantics Target_Semantics
                          τ'.

  Local Definition σTP := σTP compilation_chain
                              Source_Semantics Target_Semantics
                              σ'.

  Lemma σTP_τTP : σTP <-> τTP.
  Proof. apply: Adj_σTP_iff_τTP. by apply: rel_adjunction_law. Qed.

  Theorem rel_TC_τTP : rel_TC <-> τTP.

  Proof.
    setoid_rewrite contra_τTP. split.
    - move => Htilde W π [t [Hsemt Hτ]].
      destruct (Htilde W t Hsemt) as [s [Hrel_s_t Hsems]].
      exists s. split; auto. move => s_in_π. apply: Hτ. by exists s.
    - move => Hτ W t Hsemt. specialize (Hτ W (fun s => ~ rel s t)).
      case: Hτ.
      { exists t. split; auto. unfold τ'. move => [s [Hc Hcc]] //=. }
      move => s [Hsems H]. exists s. split; auto; by apply: NNPP.
  Qed.

  Theorem rel_TC_σTP : rel_TC <-> σTP.
  Proof. by rewrite σTP_τTP rel_TC_τTP. Qed.

  (* rel version of forward compiler correctness *)
  Definition rel_FC1 : Prop :=
    forall W s, sem__S W s -> exists t, rel s t /\ sem__T (W ↓) t.

  Definition σ_fwd : prop__T -> prop__S :=
    fun π__T : prop__T =>
      (fun s => exists t, rel s t /\ π__T t).

  Lemma Galois_fwd_implies_total_rel :
  Adjunction_law τ' σ_fwd -> (total rel).
  Proof.
    move/Galois_equiv => [monotau [monosig [G1 G2]]] s.
    have Hs: (σ_fwd (τ' (fun s' => s' = s))) s by apply: G1.
    destruct Hs as [t Hs]. now exists t.
  Qed.

  Lemma σ_σ_fwd : σ' = σ_fwd <-> (forall t__S, exists! t__T, rel t__S t__T).
  Proof.
    split.
    + move => H_eq t__S.
      have adj_fwd: Adjunction_law τ' σ_fwd.
      { rewrite -H_eq. exact rel_adjunction_law. }
      have: exists t__T, rel t__S t__T by apply: Galois_fwd_implies_total_rel.
      move => [t__T rel_s_t].
      exists t__T. split; auto. move => t__T' rel_s_t'.
      have H: τ' (σ_fwd (eq t__T)) t__T'.
      { exists t__S. split;auto. by exists t__T. }
      have G2: Galois_snd τ' σ_fwd. { move/Galois_equiv: adj_fwd. by intuition. }
        by apply: (G2 (eq t__T) t__T' H).
    + move => Htot. apply: functional_extensionality => π__t.
      apply: functional_extensionality => t__S.
      rewrite /σ_fwd /σ' /γ /= /up_rel.
      apply: prop_extensionality. split.
      - by firstorder.
      - move => [t__T [πt_tT rel_ts_tt]] t__T' H'.
        destruct (Htot t__S) as [t Ht].
        have [eq1 eq2] : t = t__T' /\ t = t__T by split; apply Ht.
        now subst.
  Qed.

  Lemma rel_FC1' : rel_FC1 <-> forall W, beh__S W ⊆ σ_fwd (beh__T (W ↓)).
  Proof.
    split.
    - rewrite /σ_fwd => Hrel W s behWs.
      exact (Hrel W s behWs).
    - move => Hrel' W s behWs. exact (Hrel' W s behWs).
  Qed.

  (* another rel version of forward compiler correctness
     CA: this ensures rel_TC + rel_FC2 -> rel_HC
   *)

  Definition rel_FC2 : Prop :=
    forall W s, sem__S W s -> (forall t, rel s t -> sem__T (W ↓) t).

  Lemma rel_FC2' : rel_FC2 <-> (forall W, beh__S W ⊆ σ' (beh__T (W ↓))).
  Proof. firstorder. Qed.

  (* if the Target semantics is deterministic than
     forward compiler correctness implies target compiler correctness
  *)
  Theorem trg_determinism_relFC1_relTC :
    (forall W__T : prg__T, exists! t__W, sem__T W__T t__W) ->
    rel_FC1 -> rel_TC.
  Proof.
    move => trg_det fcc W t semWt.
    destruct (trg_det (W ↓)) as [t__w [semWt__W Heq]].
    destruct (non_empty_sem  Source_Semantics W) as [s semWs].
    exists s. split; auto.
    destruct (fcc W s semWs) as [t' [rel_s_t' semWt']].
    move: (Heq t semWt) (Heq t' semWt'). move => H1 H2.
      by rewrite -H1 H2.
  Qed.

End TracePropertiesCriterion.


Require Import init.

Require Export cauchy_real_mult.
Require Export order_cone.

Definition real_pos_base (a : real_base) :=
    0 = to_equiv real_equiv a ∨
    ∃ N, ∀ i, N ≤ i → 0 ≤ r_seq a i.

Lemma real_pos_wd1 : ∀ a b, a ~ b → real_pos_base a → real_pos_base b.
Proof.
    intros a b ab [a_z|a_pos].
    {
        left.
        rewrite a_z.
        equiv_simpl.
        exact ab.
    }
    apply or_right.
    intros b_nz.
    assert (0 ≠ to_equiv real_equiv a) as a_nz.
    {
        intros contr.
        rewrite contr in b_nz.
        equiv_simpl in b_nz.
        contradiction.
    }
    apply cauchy_nz in a_nz as [ε [N1 [ε_pos a_nz]]].
    specialize (ab ε ε_pos) as [N2 ab].
    destruct a_pos as [N3 a_pos].
    exists (max N1 (max N2 N3)).
    intros i i_ge.
    specialize (a_pos i (trans (trans (rmax _ _) (rmax _ _)) i_ge)).
    specialize (ab i (trans (trans (lmax _ _) (rmax _ _)) i_ge)).
    specialize (a_nz i (trans (lmax _ _) i_ge)).
    rewrite abs_pos_eq in a_nz by exact a_pos.
    apply (le_lt_trans (abs_le_pos _)) in ab.
    rewrite <- lt_plus_rrmove in ab.
    pose proof (le_lt_trans a_nz ab) as ltq.
    rewrite <- lt_plus_0_a_b_ba in ltq.
    apply ltq.
Qed.

Lemma real_pos_wd : ∀ a b, a ~ b → real_pos_base a = real_pos_base b.
Proof.
    intros a b ab.
    apply propositional_ext.
    split; [>exact (real_pos_wd1 _ _ ab)|].
    apply eq_symmetric in ab.
    exact (real_pos_wd1 _ _ ab).
Qed.

#[refine]
Global Instance real_cone : OrderCone real := {
    cone := unary_op real_pos_wd
}.
Proof.
-   intros a b.
    classic_case (0 = a) as [a_z|a_nz].
    {
        subst a.
        rewrite plus_lid.
        intros a_in b_in; exact b_in.
    }
    classic_case (0 = b) as [b_z|b_nz].
    {
        subst b.
        rewrite plus_rid.
        intros a_in b_in; exact a_in.
    }
    equiv_get_value a b.
    unfold plus; equiv_simpl.
    intros [a_z|a_pos] [b_z|b_pos];
        [>contradiction|contradiction|contradiction|].
    right.
    destruct a_pos as [N1 a_pos].
    destruct b_pos as [N2 b_pos].
    exists (max N1 N2).
    intros i i_ge; cbn.
    specialize (a_pos i (trans (lmax N1 N2) i_ge)).
    specialize (b_pos i (trans (rmax N1 N2) i_ge)).
    apply le_pos_plus; assumption.
-   intros a b.
    classic_case (0 = a) as [a_z|a_nz].
    {
        subst a.
        rewrite mult_lanni.
        intros a_in b_in; exact a_in.
    }
    classic_case (0 = b) as [b_z|b_nz].
    {
        subst b.
        rewrite mult_ranni.
        intros a_in b_in; exact b_in.
    }
    equiv_get_value a b.
    unfold mult; equiv_simpl.
    intros [a_z|a_pos] [b_z|b_pos];
        [>contradiction|contradiction|contradiction|].
    right.
    destruct a_pos as [N1 a_pos].
    destruct b_pos as [N2 b_pos].
    exists (max N1 N2).
    intros i i_ge; cbn.
    specialize (a_pos i (trans (lmax N1 N2) i_ge)).
    specialize (b_pos i (trans (rmax N1 N2) i_ge)).
    apply le_mult; assumption.
-   intros a.
    equiv_get_value a.
    unfold mult; equiv_simpl.
    right; cbn.
    exists 0.
    intros i i_ge.
    apply square_pos.
-   unfold neg, one; cbn.
    unfold rat_to_real; equiv_simpl.
    unfold real_pos_base; cbn.
    unfold zero at 1; cbn.
    unfold rat_to_real; equiv_simpl.
    rewrite not_or.
    split.
    +   intros contr.
        specialize (contr 1 one_pos) as [N contr].
        specialize (contr N (refl N)).
        rewrite neg_neg, plus_lid in contr.
        rewrite abs_one in contr.
        destruct contr; contradiction.
    +   intros [N contr].
        specialize (contr N (refl N)).
        apply neg_pos in contr.
        destruct (le_lt_trans contr one_pos); contradiction.
-   intros a.
    equiv_get_value a.
    unfold neg; equiv_simpl.
    apply or_to_strong.
    apply or_right.
    unfold real_pos_base; cbn.
    rewrite not_or.
    intros [a_nz a_neg].
    right.
    apply cauchy_nz in a_nz as [ε [N1 [ε_pos a_nz]]].
    destruct a as [a a_cauchy]; cbn in *.
    specialize (a_cauchy ε ε_pos) as [N2 a_cauchy].
    rewrite not_ex in a_neg.
    specialize (a_neg (max N1 N2)).
    rewrite not_all in a_neg.
    destruct a_neg as [n a_neg].
    rewrite not_impl, nle_lt in a_neg.
    destruct a_neg as [n_ge a_neg].
    exists (max N1 N2).
    intros i i_ge.
    specialize (a_nz n (trans (lmax N1 N2) n_ge)).
    specialize (a_cauchy i n (trans (rmax _ _) i_ge) (trans (rmax _ _) n_ge)).
    rewrite abs_neg_eq in a_nz by apply a_neg.
    apply (le_lt_trans (abs_le_pos _)) in a_cauchy.
    pose proof (lt_le_trans a_cauchy a_nz) as ltq.
    rewrite <- lt_plus_a_0_ab_b in ltq.
    apply neg_pos.
    apply ltq.
Defined.

Definition real_order := cone_order.
Definition real_le_connex := cone_le_connex.
Definition real_le_antisym := cone_le_antisym.
Definition real_le_trans := cone_le_transitive.
Definition real_le_lplus := cone_le_lplus.
Definition real_le_mult := cone_le_mult.


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model Generate co's (mo's) for c11, ie on atomic writes only ?? *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition A := unknown_set "A".
Definition I := unknown_set "I".
Definition coi := unknown_relation "coi".
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
(* Definition of co_locs already included in the prelude *)
(* Definition of cross already included in the prelude *)
Definition generate_orders s pco := cross (co_locs pco (partition s)).
Definition generate_cos pco := generate_orders W pco.
Definition mobase := co0.
Variable mo : relation events.
Definition moi := mo ⊓ int.
Definition moe := mo ⊓ ext.
Definition co := mo.
Definition coe := moe.
Definition coi_0 := coi.
Definition fr := rf° ⋅ mo ⊓ !id.
Definition fri := fr ⊓ int.
Definition fre := fr ⊓ ext.
Definition witness_conditions := generate_orders (W ⊓ (A ⊔ I)) mobase mo.
Definition model_conditions := True.
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc A I coi tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW generate_orders generate_cos mobase moi moe co coe coi_0 fr fri fre witness_conditions model_conditions : cat.

Definition valid (c : candidate) :=
  exists mo : relation (events c),
    witness_conditions c mo /\
    True.

(* End of translation of model Generate co's (mo's) for c11, ie on atomic writes only ?? *)


Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.universal_algebra MathClasses.interfaces.monads.

Section contents.
  Context (operation: Set) (operation_type: operation → OpType unit).

  Let sign := Build_Signature unit operation operation_type.

  (* The monad's type constructor: *)
  Definition M (T: Type): Type := Term sign T (ne_list.one tt).

  (* We first define equality for arbitrary arities, and then instantiate for constants. *)
  Section equality.
    Context `{Setoid A}.

    Fixpoint geneq {s s'} (x: Term sign A s) (y: Term sign A s'): Prop :=
      match x, y with
      | Var _ _ v _, Var _ _ w _ => v = w
      | App _ _ _ z t t', App _ _ _ z' t'' t''' => geneq t t'' ∧ geneq t' t'''
      | Op _ _ o, Op _ _ o' => o ≡ o'
      | _, _ => False
      end.

    Lemma geneq_sym s (x: Term sign A s): ∀ s' (y: Term sign A s'), geneq x y → geneq y x.
    Proof with intuition.
     induction x.
       destruct y...
       simpl. symmetry...
      destruct y0... simpl in *...
     destruct y... simpl in *...
    Qed.

    Lemma geneq_trans s (x: Term sign A s): ∀ s' (y: Term sign A s') s'' (z: Term sign A s''),
      geneq x y → geneq y z → geneq x z.
    Proof with simpl in *; intuition.
     induction x; simpl.
       destruct y, z...
      destruct y0...
      destruct z... eauto. eauto.
     destruct y, z...
     transitivity o0...
    Qed.

    Global Instance gen_equiv: Equiv (M A) := geneq.

    Global Instance: Setoid (M A).
    Proof.
      split.
        intros x. unfold M, equiv, gen_equiv in *. induction x; simpl; intuition.
       repeat intro. now apply geneq_sym.
      repeat intro. now apply geneq_trans with _ y.
    Qed.
  End equality.

  (* For bind, we do the same: *)
  Definition gen_bind_aux {A B: Type} (f: A → M B): ∀ {s}, Term sign A s → Term sign B s
    := fix F {s} (t: Term sign A s): Term sign B s :=
      match t with
      | Var _ _ v tt => f v
      | App _ _ o z x y => App _ _ _ z (F x) (F y)
      | Op _ _ o => Op _ _ o
      end.

  Arguments gen_bind_aux {A B} _ {s} _.

  Instance gen_bind: MonadBind M := λ _ _ f z, gen_bind_aux f z.

  Instance: ∀ `{Equiv A} `{Equiv B},
    Proper (((=) ==> (=)) ==> (=) ==> (=)) (@bind M _ A B).
  Proof with intuition.
   intros A H1 B H2 x0 y0 E' x y E.
   revert x y E.
   change (∀ x y : M A, geneq x y → geneq (gen_bind_aux x0 x) (gen_bind_aux y0 y)).
   cut (∀ s (x: Term sign A s) s' (y: Term sign A s'),
      geneq x y → geneq (gen_bind_aux x0 x) (gen_bind_aux y0 y))...
   revert s' y H.
   induction x.
     destruct y... simpl in *.
     destruct a, a1. apply E'...
    simpl in *. destruct y... destruct y...
    simpl in *... destruct y...
  Qed.

  (* return: *)
  Instance gen_ret: MonadReturn M := λ _ x, Var sign _ x tt.

  Instance: ∀ `{Equiv A}, Proper ((=) ==> (=)) (@ret M _ A).
  Proof. repeat intro. assumption. Qed.

  (* What remains are the laws: *)
  Instance: Monad M.
  Proof with intuition.
   constructor; intros; try apply _.
     (* law 1 *)
     now apply setoids.ext_equiv_refl.
    (* law 2 *)
    intros m n E. rewrite <-E. clear E n. unfold M in m.
    change (geneq (gen_bind_aux (λ x : A, Var sign A x tt) m) m).
    induction m; simpl...
    destruct a... simpl...
   (* law 3 *)
   intros m n E. rewrite E. clear E m.
   unfold bind, gen_bind, equiv, gen_equiv.
   revert n. assert (∀ o (m : Term sign A o),
     geneq (gen_bind_aux f (gen_bind_aux g m))
     (gen_bind_aux (λ x : A, gen_bind_aux f (g x)) m)) as H.
    induction m; simpl...
    destruct a.
    change (gen_bind_aux f (g v) = gen_bind_aux f (g v))...
   now apply H.
  Qed.
End contents.


Require Import GHC.Base.
Import GHC.Base.Notations.
Require Import Proofs.GHC.Base.
Require Import Data.Map.Internal.
Import GHC.Num.Notations.
Require Import OrdTactic.
Require Import Psatz.
Require Import Tactics.
Set Bullet Behavior "Strict Subproofs".
Require Import MapProofs.Bounds.
Require Import MapProofs.Tactics.
Require Import MapProofs.UnionIntersectDifferenceProofs.
Require Import MapProofs.ToListProofs.
Require Import Coq.Classes.Morphisms.

Section WF.
Context {e : Type} {a : Type} {HEq : Eq_ e} {HOrd : Ord e} {HEqLaws : EqLaws e}  {HOrdLaws : OrdLaws e}.

(** ** Verification of [submap] *)
Lemma submap'_spec:
  forall (m1: Map e a) (m2: Map e a) lb ub f,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  submap' f m1 m2 = true <->
  (forall i value, sem m1 i = Some value -> exists v, (sem m2 i = Some v /\ f value v = true)).
Proof.
  intros ????? HB1 HB2.
  revert dependent m2.
  induction HB1; intros; simpl; subst.
  * intuition. discriminate H0.
  * destruct m2 eqn:Hs0.
    - rewrite <- Hs0 in *.
      clear s e0 a0 m1 m3 Hs0.
      eapply splitLookup_Desc; [solve_Bounded e|].
      intros sr1 b sr2 HBsr1 HBsr2 Hb Hsem.
      destruct HB2.
      + simpl. split; intros. simpl in Hb. subst. discriminate H1. specialize (H1 x v).
        assert (sem s1 x = None). { eapply sem_outside_above. apply HB1_1. unfold isUB. order e. }
        rewrite H3 in H1. simpl in H1. rewrite Eq_Reflexive in H1. simpl in H1.
        assert (exists v0 : a, None = Some v0 /\ f v v0 = true) by  (apply H1; reflexivity).
        destruct H4. destruct H4. discriminate H4.
      + destruct b. rewrite andb_true_iff. rewrite andb_true_iff. rewrite IHHB1_1 by eassumption.
        rewrite IHHB1_2 by eassumption. split; intro.
        -- destruct H6. destruct H7. intros i value Hi. rewrite Hsem. destruct (sem s1 i) eqn : ?.
            ** apply H7 in Heqo. destruct Heqo. destruct H9. exists x1.
               destruct (i == x) eqn : ?. solve_Bounds e. rewrite H9. simpl. simpl in Hi. split. reflexivity.
              inversion Hi. subst. apply H10.
            ** simpl in Hi. destruct (i == x) eqn : ?. simpl in Hi. exists a0. split.
              eapply sem_resp_eq in Heqb. rewrite <- Hb in Heqb. assumption. inversion Hi; subst.
              assumption. simpl in Hi. apply H8 in Hi. destruct Hi. exists x1.
              assert (sem sr1 i = None). { eapply sem_outside_above. apply HBsr1.
              destruct H9. apply (sem_inside HBsr2) in H9. destruct H9. solve_Bounds e. }
              rewrite H10. simpl. apply H9.
       -- split. specialize (H6 x v). assert (sem s1 x = None). { eapply sem_outside_above.
          apply HB1_1. unfold isUB. order e. } rewrite H7 in H6. simpl in H6. rewrite Eq_Reflexive in H6.
          simpl in H6.
          assert (exists v1 : a, sem s0 x ||| SomeIf (_GHC.Base.==_ x x0) v0 ||| sem s3 x = Some v1
          /\ f v v1 = true) by (apply H6; reflexivity). destruct H8. simpl in Hb. rewrite <- Hb in H8.
          destruct H8. inversion H8; subst. assumption.
          split.
          ** intros. specialize (H6 i value). rewrite H7 in H6. simpl in H6.
             assert (exists v : a, sem s0 i ||| SomeIf (_GHC.Base.==_ i x0) v0 ||| sem s3 i = Some v
             /\ f value v = true) by (apply H6; reflexivity). destruct H8. destruct H8.
            specialize (Hsem i). simpl in Hsem. rewrite H8 in Hsem. destruct (i==x) eqn : ?.
            ++ solve_Bounds e.
            ++ assert (sem sr2 i = None). { eapply (sem_inside HB1_1) in H7. destruct H7.
              unfold isUB in H10. eapply (sem_outside_below). apply HBsr2. solve_Bounds e. }
              rewrite H10 in Hsem. rewrite oro_None_r in Hsem. exists x1. split. symmetry.
              apply Hsem. apply H9.
          ** intros. specialize (H6 i value). rewrite H7 in H6.
              assert (sem s1 i = None). eapply sem_outside_above. apply HB1_1. eapply (sem_inside HB1_2) in H7.
              destruct H7. solve_Bounds e. rewrite H8 in H6. simpl in H6. destruct (i == x) eqn : ?.
              ++ solve_Bounds e.
              ++ simpl in H6. assert ( exists v : a, sem s0 i |||
              SomeIf (_GHC.Base.==_ i x0) v0 ||| sem s3 i = Some v /\ f value v = true) by (apply H6; reflexivity).
             destruct H9. specialize (Hsem i). simpl in Hsem. destruct H9. rewrite H9 in Hsem.
              rewrite Heqb in Hsem. assert (sem sr1 i = None). { eapply (sem_inside HB1_2) in H7.
              destruct H7. unfold isLB in H7. eapply sem_outside_above. apply HBsr1. solve_Bounds e. }
              rewrite H11 in Hsem. simpl in Hsem. exists x1. split. symmetry. apply Hsem. apply H10.
          -- split; intros. discriminate H6. specialize (H6 x). assert (sem s1 x = None). {
              eapply sem_outside_above. apply HB1_1. unfold isUB.  order e. } rewrite H7 in H6. simpl in H6.
              specialize (H6 v). rewrite Eq_Reflexive in H6. simpl in H6. destruct H6. reflexivity.
              simpl in Hb. rewrite <- Hb in H6. destruct H6. discriminate H6.
    - intuition.
      + discriminate H1.
      + subst. simpl in H1. specialize (H1 x v). assert (sem s1 x = None). { eapply sem_outside_above.
        apply HB1_1. unfold isUB. order e. } rewrite H3 in H1. simpl in H1. rewrite Eq_Reflexive in H1.
        simpl in H1. destruct H1. reflexivity. destruct H1. discriminate H1.
Qed.

Lemma submap_size :
  forall (m1: Map e a) (m2: Map e a) lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  (forall i value, sem m1 i = Some value ->  exists v, sem m2 i = Some v) ->
  (size m1 <= size m2)%Z.
Proof.
  intros ???? HB1 HB2 Hsubmap.
  revert dependent m2.
  induction HB1; intros; simpl; subst.
  * simpl. solve_size.
  * assert (exists v, sem m2 x = Some v). { specialize (Hsubmap x v). simpl in Hsubmap.
    assert (sem s1 x = None). { eapply sem_outside_above. apply HB1_1. unfold isUB. order e. }
    rewrite H1 in Hsubmap. simpl in Hsubmap. rewrite Eq_Reflexive in Hsubmap. simpl in Hsubmap.
    destruct Hsubmap. reflexivity. exists x0. assumption. }
    assert (size m2 = let '(sl,sr) := split x m2 in 1 + size sl + size sr)%Z.
    { eapply split_Desc; [eassumption|]. intros. destruct H1. rewrite H1 in H5. simpl in H5. lia. }
    rewrite H3.
    eapply split_Desc; [eassumption|]. intros.
    assert (size s1 <= size s0)%Z.
    { apply IHHB1_1; try assumption.
      intros i v1 Hi.
      specialize (Hsubmap i). simpl in Hsubmap.
      rewrite Hi in Hsubmap. simpl in Hsubmap.
      specialize (Hsubmap v1). destruct Hsubmap. reflexivity.
      specialize (H7 i). destruct (i == x) eqn : ?.
      { solve_Bounds e. }
      { assert (sem s3 i = None). { assert (i < x = true) by solve_Bounds e. eapply sem_outside_below.
        apply H5. unfold isLB. order e. }
        rewrite H9 in H7. rewrite oro_None_r  in H7. exists x0. rewrite <- H7. assumption. }
   }
    assert (size s2 <= size s3)%Z.
    { apply IHHB1_2; try assumption.
      intros i v1 Hi.
      specialize (Hsubmap i). simpl in Hsubmap.
      rewrite Hi in Hsubmap. simpl in Hsubmap.
      specialize (Hsubmap v1).
      assert (sem s1 i = None). { eapply sem_outside_above. apply HB1_1. solve_Bounds e. }
      rewrite H9 in Hsubmap. simpl in Hsubmap.
      assert (i == x = false) by solve_Bounds e. rewrite H10 in Hsubmap. simpl in Hsubmap.
      destruct Hsubmap. reflexivity. specialize (H7 i). rewrite H11 in H7. rewrite H10 in H7.
     assert (sem s0 i = None). { assert (x < i = true) by solve_Bounds e. eapply sem_outside_above.
      apply H4. solve_Bounds e. }
      rewrite H12 in H7. simpl in H7. exists x0. symmetry. apply H7. }
    lia.
Qed.

Lemma isSubmapOfBy_spec:
  forall (m1: Map e a) (m2: Map e a) f lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  isSubmapOfBy f m1 m2 = true <-> (forall i value, sem m1 i = Some value -> exists v, sem m2 i =
  Some v /\ f value v = true).
Proof.
  intros. unfold isSubmapOfBy. split; intros.
  - eapply submap'_spec. apply H. apply H0. rewrite andb_true_iff in H1. destruct H1. apply H3.
    apply H2.
  - apply andb_true_iff. split. unfold op_zlze__. unfold Ord_Integer___. unfold op_zlze____.
    rewrite size_size. rewrite Z.leb_le. eapply submap_size. apply H. apply H0. intros.
    specialize (H1 i value). apply H1 in H2. destruct H2. destruct H2. exists x. apply H2.
    eapply submap'_spec. apply H. apply H0. apply H1.
Qed.

Lemma isSubmapOf_spec:
  forall `{Eq_ a} m1 m2 lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  isSubmapOf m1 m2 = true <-> (forall i value, sem m1 i = Some value -> exists v, sem m2 i = Some v /\
  value == v = true).
Proof.
  intros. eapply isSubmapOfBy_spec. apply H0. apply H1.
Qed.

(** ** Verification of [isProperSubmapOfBy] *)
Lemma isProperSubmapOfBy_spec:
  forall (m1: Map e a) (m2: Map e a) lb ub f,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
    isProperSubmapOfBy f m1 m2 = true <-> isSubmapOfBy f m1 m2 = true /\ size m1 < size m2 = true.
Proof.
  intros. unfold isProperSubmapOfBy. unfold isSubmapOfBy. repeat (rewrite andb_true_iff in *). split; intros.
   - destruct H1. split. split. order Int. assumption. order Int.
   - destruct H1. destruct H1. split. order Int. apply H3.
Qed.

(** ** Veriticcation of [isProperSubmpaOf] *)
Lemma isProperSubmapOf:
  forall `{EqLaws a} (m1: Map e a) (m2: Map e a) lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  isProperSubmapOf m1 m2 = true <-> isSubmapOf m1 m2 = true /\ size m1 < size m2 = true.
Proof.
  intros. unfold isProperSubmapOf. unfold isSubmapOf. eapply isProperSubmapOfBy_spec; eassumption.
Qed.

(** ** Verification of [filter] *)

(**
For filter we need two lemmas: We need to know that [filter P s] is
well-formed even if P does not respect equality (this is
required by the [FSetInterface]). But to prove something about its
semantics, we need to assume that [P] respects equality.
*)

Lemma filterWithKey_Bounded:
  forall (P : e -> a -> bool) map lb ub,
  Bounded map lb ub ->
  Bounded (Internal.filterWithKey P map) lb ub.
Proof.
  intros.
  induction H.
  * simpl. solve_Bounded e.
  * simpl.
    destruct (P x v) eqn:HPx.
    - destruct_ptrEq.
      + solve_Bounded e.
      + applyDesc e (@link_Desc e a).
    - applyDesc e (@link2_Desc e a).
Qed.

Lemma filterWithKey_Desc:
  forall (P : e -> a -> bool) map lb ub,
  Bounded map lb ub ->
  Proper ((fun i j : e => _GHC.Base.==_ i j = true) ==> eq) P ->
  Desc' (Internal.filterWithKey P map) lb ub (fun x => match sem map x with
                                                      | Some y => if P x y then Some y else None
                                                      | None => None
                                                      end).
Proof.
  intros.
  induction H.
  * simpl. solve_Desc e. reflexivity.
  * simpl.
    applyDesc e IHBounded1.
    applyDesc e IHBounded2.
    destruct (P x v) eqn:HPx.
    - destruct_ptrEq.
      + solve_Desc e. f_solver e. assert (P i v = true). { erewrite H0. apply HPx. apply Heqb. }
        rewrite Heqb0 in H4. inversion H4.
      + applyDesc e (@link_Desc e a).
        solve_Desc e. f_solver e. assert (P i a0 = true). { erewrite H0. apply HPx. apply Heqb. }
        rewrite Heqb0 in H4. inversion H4.
    - applyDesc e (@link2_Desc e a).
      solve_Desc e. f_solver e. assert (P x v = true). { erewrite H0. apply Heqb0. apply Eq_Symmetric.
      apply Heqb. } rewrite HPx in H6. inversion H6.
Qed.

(*This requires no conditions on the function P*)
Lemma filter_Desc:
  forall  (P : a -> bool) map lb ub,
  Bounded map lb ub ->
  Desc' (Internal.filter P map) lb ub (fun x => match sem map x with
                                                |Some y => if P y then Some y else None
                                                |None => None
                                                end).
Proof.
  intros. eapply filterWithKey_Desc. apply H. f_solver e.
Qed.

(** ** Verification of [partition] *)

Lemma partitionWithKey_Bounded:
  forall p map lb ub,
  Bounded map lb ub ->
  forall (P : (Map e a * Map e a) -> Prop),
  (forall m1 m2, Bounded m1 lb ub /\ Bounded m2 lb ub -> P (m1, m2)) ->
  P (partitionWithKey p map).
Proof.
  intros ???? HB.
  induction HB.
  * intros X HX; apply HX; clear X HX; split; solve_Bounded e.
  * simpl.
    apply IHHB1; intros sl1 sl2 [HDsl1 HDsl2]; clear IHHB1.
    apply IHHB2; intros sr1 sr2 [HDsr1 HDsr2]; clear IHHB2.
    destruct (p x) eqn:?.
    - intros X HX; apply HX; clear X HX; split.
      + destruct_ptrEq.
        -- solve_Bounded e.
        -- applyDesc e (@link_Desc e a).
      + applyDesc e (@link2_Desc e a).
    - intros X HX; apply HX; clear X HX; split.
      + applyDesc e (@link2_Desc e a).
      + destruct_ptrEq.
        -- solve_Bounded e.
        -- applyDesc e (@link_Desc e a).
Qed.

Lemma partitionWithKey_spec:
  forall (p : e -> a -> bool) map lb ub,
  Bounded map lb ub ->
  Proper ((fun i j : e => i == j = true) ==> eq) p ->
  forall (P : (Map e a * Map e a) -> Prop),
  (forall m1 m2,
    Desc' m1 lb ub (fun i => match sem map i with
                             | Some y => if p i y then Some y else None
                             | None => None
                              end)  /\
    Desc' m2 lb ub (fun i => match sem map i with
                             | Some y => if p i y then None else Some y
                             | None => None
                             end) ->
    P (m1, m2)) ->
  P (partitionWithKey p map).
Proof.
  intros ???? HB HProper.
  induction HB.
  * intros X HX; apply HX; clear X HX; split; solve_Desc e; f_solver e.
  * simpl.
    apply IHHB1; intros sl1 sl2 [HDsl1 HDsl2]; clear IHHB1.
    applyDesc e HDsl1; clear HDsl1.
    applyDesc e HDsl2; clear HDsl2.
    apply IHHB2; intros sr1 sr2 [HDsr1 HDsr2]; clear IHHB2.
    applyDesc e HDsr1; clear HDsr1.
    applyDesc e HDsr2; clear HDsr2.
    destruct (p x) eqn:?.
    - intros X HX; apply HX; clear X HX; split.
      + destruct_ptrEq.
        -- solve_Desc e. f_solver e. assert (p i v = p x v). apply equal_f. apply HProper. assumption.
            rewrite Heqb in H1. rewrite Heqb1 in H1. inversion H1.
        -- applyDesc e (@link_Desc e a). solve_Desc e. f_solver e. assert (p i a0 = p x a0). apply equal_f.
           apply HProper. assumption. rewrite Heqb1 in H1. rewrite Heqb in H1. inversion H1.
      + applyDesc e (@link2_Desc e a). solve_Desc e. f_solver e. assert (p i v = p x v). apply equal_f.
        apply HProper. assumption. rewrite Heqb in H3. rewrite Heqb1 in H3. inversion H3.
    - intros X HX; apply HX; clear X HX; split.
      + applyDesc e (@link2_Desc e a). solve_Desc e. f_solver e. assert (p i v = p x v). apply equal_f.
        apply HProper. assumption. rewrite Heqb in H3. rewrite Heqb1 in H3. inversion H3.
      + destruct_ptrEq.
        -- solve_Desc e. f_solver e. assert (p x v = p i v). apply equal_f. apply HProper. order e.
           rewrite Heqb in H1. rewrite Heqb1 in H1. inversion H1.
        -- applyDesc e (@link_Desc e a). solve_Desc e. f_solver e. assert (p x a0 = p i a0). apply equal_f.
           apply HProper. order e. rewrite Heqb in H1. rewrite Heqb1 in H1. inversion H1.
Qed.

Lemma partition_spec:
  forall (p : a -> bool) map lb ub,
  Bounded map lb ub ->
  forall (P : (Map e a * Map e a) -> Prop),
  (forall m1 m2,
    Desc' m1 lb ub (fun i => match sem map i with
                             | Some y => if p y then Some y else None
                             | None => None
                              end)  /\
    Desc' m2 lb ub (fun i => match sem map i with
                             | Some y => if p y then None else Some y
                             | None => None
                             end) ->
    P (m1, m2)) ->
  P (partition p map).
Proof.
  intros. unfold partition. eapply partitionWithKey_spec. apply H. f_solver e. apply H0.
Qed.

(** ** Verification of [take] *)
(*This is exactly the same as SetProofs, since the take function works the exact same way*)
Definition takeGo : Int -> Map e a -> Map e a.
Proof.
  let rhs := eval unfold take in (@take e a) in
  match rhs with fun n s => if _ then _ else ?go _ _  => exact go end.
Defined.

Lemma take_neg: forall a n (l : list a), (n <= 0)%Z -> List.take n l = nil.
Proof.
  intros. destruct l; simpl; destruct (Z.leb_spec n 0); try lia; try reflexivity.
Qed.

Lemma take_all:
  forall a n (xs : list a), (Z.of_nat (length xs) <= n)%Z -> List.take n xs = xs.
Proof.
  intros. revert n H.
  induction xs; intros n Hall.
  * simpl. destruct (Z.leb_spec n 0); reflexivity.
  * simpl.
    simpl length in Hall. rewrite Nat2Z.inj_succ, <- Z.add_1_l in Hall.
    rewrite IHxs by lia.
    destruct (Z.leb_spec n 0); [lia|reflexivity].
Qed.

Lemma take_app_cons:
  forall a n (l1 : list a) (x : a) (l2 : list a),
  List.take n (l1 ++ x :: l2) = match (n ?= Z.of_nat (length l1))%Z with
    | Lt => List.take n l1
    | Eq => l1
    | Gt => l1 ++ (x :: nil) ++ List.take (n - Z.of_nat (length l1) - 1)%Z l2
  end.
Proof.
  intros. revert n.
  induction l1; intros n.
  * simpl.
    rewrite Z.sub_0_r.
    destruct (Z.leb_spec n 0), (Z.compare_spec n 0)%Z; try reflexivity; lia.
  * cbn -[Z.add Z.of_nat].
    rewrite IHl1. clear IHl1.
    rewrite Nat2Z.inj_succ, <- Z.add_1_l.
    replace (n - (1 + Z.of_nat (length l1)) - 1)%Z with (n - 2 - Z.of_nat (length l1))%Z by lia.
    replace (n - 1 - (Z.of_nat (length l1)) - 1)%Z with (n - 2 - Z.of_nat (length l1))%Z by lia.
    destruct (Z.leb_spec n 0),
             (Z.compare_spec (n - 1) (Z.of_nat (length l1)))%Z,
             (Z.compare_spec n (1 + Z.of_nat (length l1)))%Z; try reflexivity; lia.
Qed.

Lemma takeGo_spec :
  forall n map lb ub,
  Bounded map lb ub ->
  forall (P : Map e a -> Prop),
  (forall m',
    Bounded m' lb ub /\
    toList m' = List.take n (toList map) ->
    P m') ->
  P (takeGo n map).
Proof.
  intros ???? HD. revert n.
  induction HD; intros n.
  * intros X HX; apply HX. split.
    + simpl. destruct_match; solve_Bounded e.
    + simpl. do 2 destruct_match; reflexivity.
  * simpl.
    intros X HX; apply HX.
    rewrite toList_Bin.
    unfold op_zlze__ , Ord_Integer___, op_zlze____.
    unfold compare , Ord_Integer___, compare__.
    rewrite size_size.
    apply IHHD1. intros s1' [HBs1' Hs1']. clear IHHD1.
    apply IHHD2. intros s2' [HBs2' Hs2']. clear IHHD2.
    destruct (Z.leb_spec n 0).
    + rewrite take_neg by assumption. split.
      - solve_Bounded e.
      - reflexivity.
    + simpl app.
      rewrite take_app_cons.
      erewrite <- size_spec by eassumption.
      destruct (Z.compare_spec n (size s1)).
      - split.
        ** eapply Bounded_relax_ub; eassumption.
        ** reflexivity.
      - split.
        ** eapply Bounded_relax_ub; eassumption.
        ** assumption.
      - split.
        ** applyDesc e (@link_Desc e a).
        ** erewrite toList_link by solve_Precondition e.
           rewrite Hs2'.
           reflexivity.
Qed.

Lemma toList_take:
  forall n map lb ub,
  Bounded map lb ub ->
  forall (P : Map e a -> Prop),
  (forall m',
    Bounded m' lb ub /\
    toList m' = List.take n (toList map) ->
    P m') ->
  P (take n map).
Proof.
  intros. apply H0.
  unfold take. fold takeGo.
  unfold op_zgze__ , Ord_Integer___, op_zgze____.
  rewrite size_size.
  destruct (Z.leb_spec (size map) n).
  * split; [assumption|].
    rewrite take_all. reflexivity.
    erewrite <- size_spec by eassumption.
    assumption.
  * eapply takeGo_spec; [solve_Precondition e..|].
    intros. assumption.
Qed.

(** ** Verification of [drop] *)

Definition dropGo : Int -> Map e a -> Map e a.
Proof.
  let rhs := eval unfold drop in (@drop e a) in
  match rhs with fun n s => if _ then _ else ?go _ _  => exact go end.
Defined.

Lemma drop_neg: forall a n (l : list a), (n <= 0)%Z -> List.drop n l = l.
Proof.
  intros. destruct l; simpl; destruct (Z.leb_spec n 0); try lia; try reflexivity.
Qed.

Lemma drop_all:
  forall a n (xs : list a), (Z.of_nat (length xs) <= n)%Z -> List.drop n xs = nil.
Proof.
  intros. revert n H.
  induction xs; intros n Hall.
  * simpl. destruct (Z.leb_spec n 0); reflexivity.
  * simpl.
    simpl length in Hall. rewrite Nat2Z.inj_succ, <- Z.add_1_l in Hall.
    rewrite IHxs by lia.
    destruct (Z.leb_spec n 0); [lia|reflexivity].
Qed.

Lemma drop_app_cons:
  forall a n (l1 : list a) (x : a) (l2 : list a),
  List.drop n (l1 ++ x :: l2) = match (n ?= Z.of_nat (length l1))%Z with
    | Lt => List.drop n l1 ++ (x :: nil) ++ l2
    | Eq => (x :: nil) ++ l2
    | Gt => List.drop (n - Z.of_nat (length l1) - 1)%Z l2
  end.
Proof.
  intros. revert n.
  induction l1; intros n.
  * simpl.
    rewrite Z.sub_0_r.
    destruct (Z.leb_spec n 0), (Z.compare_spec n 0)%Z; try reflexivity; lia.
  * cbn -[Z.add Z.of_nat].
    rewrite IHl1. clear IHl1.
    rewrite Nat2Z.inj_succ, <- Z.add_1_l.
    replace (n - (1 + Z.of_nat (length l1)) - 1)%Z with (n - 2 - Z.of_nat (length l1))%Z by lia.
    replace (n - 1 - (Z.of_nat (length l1)) - 1)%Z with (n - 2 - Z.of_nat (length l1))%Z by lia.
    destruct (Z.leb_spec n 0),
             (Z.compare_spec (n - 1) (Z.of_nat (length l1)))%Z,
             (Z.compare_spec n (1 + Z.of_nat (length l1)))%Z; try reflexivity; lia.
Qed.

Lemma dropGo_spec :
  forall n map lb ub,
  Bounded map lb ub ->
  forall (P : Map e a -> Prop),
  (forall m',
    Bounded m' lb ub /\
    toList m' = List.drop n (toList map) ->
    P m') ->
  P (dropGo n map).
Proof.
  intros ???? HD. revert n.
  induction HD; intros n.
  * intros X HX; apply HX. split.
    + simpl. destruct_match; solve_Bounded e.
    + simpl. do 2 destruct_match; reflexivity.
  * simpl.
    intros X HX; apply HX.
    rewrite toList_Bin.
    unfold op_zlze__ , Ord_Integer___, op_zlze____.
    unfold compare , Ord_Integer___, compare__.
    rewrite size_size.
    apply IHHD1. intros s1' [HBs1' Hs1']. clear IHHD1.
    apply IHHD2. intros s2' [HBs2' Hs2']. clear IHHD2.
    destruct (Z.leb_spec n 0).
    + rewrite drop_neg by assumption. split.
      - solve_Bounded e.
      - rewrite toList_Bin.
        reflexivity.
    + simpl app.
      rewrite drop_app_cons.
      erewrite <- size_spec by eassumption.
      destruct (Z.compare_spec n (size s1)).
      - split.
        ** applyDesc e (@insertMin_Desc e a).
        ** erewrite toList_insertMin  by solve_Precondition e.
           reflexivity.
      - split.
        ** applyDesc e (@link_Desc e a).
        ** erewrite toList_link by solve_Precondition e.
           rewrite Hs1'.
           reflexivity.
      - split.
        ** eapply Bounded_relax_lb; eassumption.
        ** assumption.
Qed.

Lemma toList_drop:
  forall n map lb ub,
  Bounded map lb ub ->
  forall (P : Map e a -> Prop),
  (forall m',
    Bounded m' lb ub /\
    toList m' = List.drop n (toList map) ->
    P m') ->
  P (drop n map).
Proof.
  intros. apply H0.
  unfold drop. fold dropGo.
  unfold op_zgze__ , Ord_Integer___, op_zgze____.
  rewrite size_size.
  destruct (Z.leb_spec (size map) n).
  * split; [solve_Precondition e|].
    rewrite drop_all. reflexivity.
    erewrite <- size_spec by eassumption.
    assumption.
  * eapply dropGo_spec; [solve_Precondition e..|].
    intros. assumption.
Qed.

(** ** Verification of [splitAt] *)

Definition splitAtGo : Int -> Map e a -> (Map e a * Map e a).
Proof.
  let rhs := eval unfold splitAt in (@splitAt e a) in
  match rhs with fun n s => if _ then _ else Datatypes.id (?go _ _)  => exact go end.
Defined.

Lemma splitAtGo_spec :
  forall n s, splitAtGo n s = (takeGo n s, dropGo n s).
Proof.
  intros ??.
  revert n.
  induction s; intros n.
  * simpl.
    repeat destruct_match; try congruence.
  * simpl. repeat destruct_match; reflexivity.
Qed.

End WF.