Require Import RelationClasses.
Require Import Setoid.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Structures.MonadLaws.
Require Import ExtLib.Data.Option.
Require Import ExtLib.Data.Monads.OptionMonad.

Set Implicit Arguments.
Set Strict Implicit.

(*
Section Laws.
  Variable m : Type -> Type.
  Variable Monad_m : Monad m.
  Variable mtype : forall T, type T -> type (m T).
  Variable mtypeOk : forall T (tT : type T), typeOk tT -> typeOk (mtype tT).
  Variable ML_m : MonadLaws Monad_m mtype.

  Section parametric.
    Variable T : Type.
    Variable tT : type T.

    Definition optionT_eq (a b : optionT m T) : Prop :=
      equal (unOptionT a) (unOptionT b).

    Global Instance type_optionT : type (optionT m T) :=
      type_from_equal optionT_eq.

    Variable tokT : typeOk tT.

    Global Instance typeOk_readerT : typeOk type_optionT.
    Proof.
      eapply typeOk_from_equal.
      { simpl. unfold optionT_eq. intros.
        generalize (only_proper _ _ _ H); intros.
        split; solve_equal. }
      { red. unfold equal; simpl. unfold optionT_eq; simpl.
        unfold Morphisms.respectful; simpl. symmetry. auto. }
      { red. unfold equal; simpl. unfold optionT_eq; simpl.
        unfold Morphisms.respectful; simpl. intros.
        etransitivity; eauto. }
    Qed.

    Global Instance proper_unOptionT : proper (@unOptionT m T).
    Proof. do 3 red; eauto. Qed.

    Global Instance proper_mkOptionT : proper (@mkOptionT m T).
    Proof. do 5 red; eauto. Qed.
  End parametric.

  Theorem equal_match : forall (A B : Type) (eA : type A) (eB : type B),
    typeOk eA -> typeOk eB ->
    forall (x y : option A) (a b : B) (f g : A -> B),
      equal x y ->
      equal a b ->
      equal f g ->
      equal match x with
              | Some a => f a
              | None => a
            end
            match y with
              | Some a => g a
              | None => b
            end.
  Proof.
    destruct x; destruct y; intros; eauto with typeclass_instances; type_tac.
    { inversion H1. assumption. }
    { inversion H1. }
    { inversion H1. }
  Qed.

  Instance proper_match : forall (A B : Type) (eA : type A) (eB : type B),
    typeOk eA -> typeOk eB ->
    forall (x : option A),
    proper x ->
    forall f : A -> optionT m B,
      proper f ->
      proper match x with
               | Some a => unOptionT (f a)
               | None => ret None
             end.
  Proof.
    destruct x; intros; eauto with typeclass_instances; type_tac.
  Qed.

  Global Instance MonadLaws_optionT : MonadLaws (@Monad_optionT _ Monad_m) type_optionT.
  Proof.
    constructor.
    { (* bind_of_return *)
      intros. do 3 red. unfold bind, optionT_eq; simpl.
      rewrite bind_of_return; eauto with typeclass_instances; type_tac.
      eapply equal_match; eauto with typeclass_instances; type_tac. }
    { (* return_of_bind *)
      simpl; unfold optionT_eq; simpl; intros.
      rewrite return_of_bind; eauto with typeclass_instances; intros; type_tac.
      destruct x; type_tac. }
    { (* bind_associativity *)
      simpl; unfold optionT_eq; simpl; intros.
      rewrite bind_associativity; eauto with typeclass_instances; intros; type_tac.
      destruct x; destruct y; try solve [ inversion H5 ]; type_tac.
      inversion H5; assumption.
      eapply equal_match; eauto with typeclass_instances; type_tac.
      rewrite bind_of_return; eauto with typeclass_instances; type_tac.
      eapply equal_match; eauto with typeclass_instances; type_tac.
      eapply equal_match; eauto with typeclass_instances; type_tac.
      eapply equal_match; eauto with typeclass_instances; type_tac. }
    { simpl; unfold optionT_eq; simpl; intros. red; simpl; intros. type_tac. }
    { simpl; unfold optionT_eq; simpl; intros. red; simpl; intros.
      red; simpl; intros. type_tac.
      eapply equal_match; eauto with typeclass_instances; type_tac. }
  Qed.

(*  Theorem equal_match_option : forall T U (tT : type T) (tU : type U),
    typeOk tT -> typeOk tU ->
    forall (a b : option T) (f g : T -> U) (x y : U),
      equal a b -> equal f g -> equal x y ->
      equal match a with
              | Some a => f a
              | None => x
            end
            match b with
              | Some b => g b
              | None => y
            end.
  Proof.
    clear. destruct a; destruct b; simpl; intros; try contradiction; auto.
  Qed.
*)

  Global Instance MonadTLaws_optionT : MonadTLaws _ _ _ _ (@MonadT_optionT _ Monad_m).
  Proof.
    constructor.
    { simpl. unfold optionT_eq; simpl; intros.
      unfold liftM. rewrite bind_of_return; eauto with typeclass_instances; type_tac. }
    { simpl; unfold lift, optionT_eq; simpl; intros.
      unfold liftM.
      rewrite bind_associativity; eauto with typeclass_instances; type_tac.
      rewrite bind_associativity; eauto with typeclass_instances; type_tac.
      rewrite bind_of_return; eauto with typeclass_instances; type_tac.
      eapply equal_match; eauto with typeclass_instances; type_tac.
      eapply equal_match; eauto with typeclass_instances; type_tac. }
    { unfold lift, liftM; simpl; intros. unfold liftM. red; simpl; intros.
      unfold optionT_eq; simpl. type_tac. }
  Qed.

  Global Instance MonadReaderLaws_optionT (s : Type) (t : type s) (tT : typeOk t) (Mr : MonadReader s m) (MLr : MonadReaderLaws Monad_m _ _ Mr) : MonadReaderLaws _ _ _ (@Reader_optionT _ _ _ Mr).
  Proof.
    constructor.
    { simpl. unfold optionT_eq; simpl; intros; unfold liftM.
      rewrite local_bind; eauto with typeclass_instances.
      (erewrite bind_proper; [ | | | | eapply ask_local | ]); eauto with typeclass_instances.
      rewrite bind_associativity; eauto with typeclass_instances.
      rewrite bind_associativity; eauto with typeclass_instances.
      type_tac. 6: eapply preflexive.
      repeat rewrite bind_of_return; eauto with typeclass_instances.
      rewrite local_ret; eauto with typeclass_instances. type_tac.
      type_tac. eapply equal_match; eauto with typeclass_instances; type_tac.
      apply proper_fun; intros. repeat rewrite local_ret; eauto with typeclass_instances.
      type_tac; eauto with typeclass_instances. type_tac.
      type_tac. eapply equal_match; eauto with typeclass_instances; type_tac.
      type_tac.
      apply proper_fun; intros. repeat rewrite local_ret; eauto with typeclass_instances.
      type_tac. eauto with typeclass_instances.
      type_tac. type_tac. }
    { simpl. unfold optionT_eq; simpl; intros; unfold liftM.
      rewrite local_bind; eauto with typeclass_instances.
      type_tac.
      destruct x; destruct y; try solve [ inversion H4 ]; type_tac.
      inversion H4; assumption.
      rewrite local_ret; eauto with typeclass_instances; type_tac.
      type_tac. eapply equal_match; eauto with typeclass_instances; type_tac. }
    { simpl. unfold optionT_eq; simpl; intros; unfold liftM.
      rewrite local_ret; eauto with typeclass_instances; type_tac. }
    { simpl. unfold optionT_eq; simpl; intros; unfold liftM.
      rewrite local_local; eauto with typeclass_instances; type_tac. }
    { unfold local; simpl; intros. red. red. intros. red in H0.
      red; simpl. type_tac. }
    { Opaque lift. unfold ask; simpl; intros. red. type_tac.
      eapply lift_proper; eauto with typeclass_instances. Transparent lift. }
  Qed.

(*
  Global Instance MonadStateLaws_optionT (s : Type) (t : type s) (tT : typeOk t) (Ms : MonadState s m) (MLs : MonadStateLaws Monad_m _ _ Ms) : MonadStateLaws _ _ _ (@State_optionT _ _ _ Ms).
  Proof.
    constructor.
    { simpl; unfold optionT_eq; simpl; intros; unfold liftM; simpl.
      rewrite bind_associativity; eauto with typeclass_instances; type_tac.
      erewrite bind_proper; eauto with typeclass_instances.
      2: instantiate (1 := get); type_tac.
      instantiate (1 := fun a => bind (put a) (fun x : unit => ret (Some x))).
      { rewrite <- bind_associativity; eauto with typeclass_instances; type_tac.
        erewrite bind_proper; eauto with typeclass_instances.
        2: eapply get_put; eauto with typeclass_instances.
        rewrite bind_of_return; eauto with typeclass_instances.
        instantiate (1 := fun x => ret (Some x)). simpl. type_tac.
        type_tac. type_tac. }
      { type_tac. rewrite bind_of_return; eauto with typeclass_instances.
        type_tac. type_tac.
        eapply equal_match_option; eauto with typeclass_instances; type_tac. }
      { eapply equal_match_option; eauto with typeclass_instances; type_tac. } }
    { simpl; unfold optionT_eq; simpl; intros; unfold liftM; simpl.
      repeat rewrite bind_associativity; eauto with typeclass_instances;
        try solve [ type_tac; eapply equal_match_option; eauto with typeclass_instances; type_tac ].
      rewrite bind_proper; eauto with typeclass_instances.
      2: eapply preflexive; eauto with typeclass_instances; type_tac.
      instantiate (1 := fun a : unit => bind get (fun x0 : s => ret (Some x0))).
      { rewrite <- bind_associativity; eauto with typeclass_instances.
        Require Import MonadTac.
        {
          Ltac cl := eauto with typeclass_instances.
          Ltac tcl := solve [ cl ].
Ltac monad_rewrite t :=
          first [ t
                | rewrite bind_rw_0; [ | tcl | tcl | tcl | t | type_tac ]
                | rewrite bind_rw_1 ].
monad_rewrite ltac:(eapply put_get; eauto with typeclass_instances).
rewrite bind_associativity; cl; try solve_proper.
rewrite bind_rw_1; [ | tcl | tcl | tcl | intros | type_tac ].
Focus 2.
etransitivity. eapply bind_of_return; cl; type_tac.
instantiate (1 := fun _ => ret (Some x)). simpl. type_tac.
Add Parametric Morphism (T : Type) (tT : type T) (tokT : typeOk tT) : (@equal _ tT)
  with signature (equal ==> equal ==> iff)
  as equal_mor.
Proof.
  clear - tokT. intros. split; intros.
  { etransitivity. symmetry; eassumption. etransitivity; eassumption. }
  { etransitivity; eauto. etransitivity; eauto. symmetry; auto. }
Qed.
Add Parametric Morphism (T : Type) (tT : type T) (tokT : typeOk tT) : (@equal _ tT)
  with signature (equal ==> eq ==> iff)
  as equal_left_mor.
Proof.
  clear - tokT. intros. split; intros.
  { etransitivity. symmetry; eassumption. eassumption. }
  { etransitivity; eauto. }
Qed.
Add Parametric Morphism (T : Type) (tT : type T) (tokT : typeOk tT) : (@equal _ tT)
  with signature (eq ==> equal ==> iff)
  as equal_right_mor.
Proof.
  clear - tokT. intros. split; intros.
  { etransitivity. eassumption. eassumption. }
  { etransitivity; eauto. symmetry; auto. }
Qed.
assert (Morphisms.Proper (equal ==> Basics.flip Basics.impl)
                (equal (bind (put x) (fun _ : unit => ret (Some x))))) by cl.
assert (Morphisms.Proper
                (Morphisms.pointwise_relation unit equal ==> equal)
                (bind (@put _ _ Ms x))).
{ red. red. intros. eapply bind_proper; cl. solve_proper.
  red; simpl. red in H1. red.

assert bind_proper.
debug eauto with typeclass_instances.

setoid_rewrite bind_of_return.
2: rewrite bind_of_return; eauto with typeclass_instances; type_tac.

        rewrite bind_rw_0
        3: instantiate (1 := (bind (put x) (fun _ : unit => get))).

        Theorem bind_rw_0 : forall A B (tA : type A) (tB : type B),
          typeOk tA -> typeOk tB ->
          forall (x z : m A) (y : A -> m B)z,
            equal x z ->
            proper y ->
            equal (bind x y) (bind z y).
        Proof.

 }
      { type_tac. rewrite bind_of_return; eauto with typeclass_instances; type_tac.
        eapply equal_match_option; eauto with typeclass_instances; type_tac. } }

      Print MonadStateLaws.
*)

  Global Instance MonadZeroLaws_optionT : MonadZeroLaws (@Monad_optionT _ Monad_m) type_optionT _.
  Proof.
    constructor.
    { simpl; unfold optionT_eq; simpl; intros.
      rewrite bind_of_return; eauto with typeclass_instances; type_tac.
      eapply equal_match; eauto with typeclass_instances; type_tac. }
    { unfold mzero; simpl; intros. red; simpl. type_tac. }
  Qed.

End Laws.
*)


Require Import Coqlib.
Require Import AST.
Require Import Globalenvs.
Require Import Events.
Require Import Smallstep.
Require Import Asm.
Require Import Integers.
Require Import Maps.
Require Import Errors.

Require Import Zlen.
Require Import SplitLib.
Require Import FindInstrLib.
Require Import PeekLib.
Require Import PeekTactics.

Definition no_PC_overflow (c : code):=
  forall z i,
    find_instr z c = Some i ->
    0 <= z < Int.max_unsigned.

Definition no_PC_overflow_dec :
  forall c,
    { no_PC_overflow c } + { ~ no_PC_overflow c }.
Proof.
  intros.
  destruct (zlt (Int.max_unsigned) (zlen c)).
  right. unfold not. intros.
  unfold no_PC_overflow in H.
  assert (Int.max_unsigned >= 0).
    unfold Int.max_unsigned. unfold Int.modulus.
    unfold Int.wordsize. unfold Wordsize_32.wordsize.
    simpl. omega.
  assert (exists i, find_instr (Int.max_unsigned) c = Some i).
    apply in_range_find_instr. omega.
  break_exists. app H H1. omega.
  left. unfold no_PC_overflow. intros.
  assert (exists i, find_instr z c = Some i).
  eexists; eauto.
  apply in_range_find_instr in H0.
  omega.
Defined.

Definition labels_valid (c : code) :=
  forall l z, label_pos l 0 c = Some z ->
              exists i, find_instr z c = Some i.

Definition is_any_label (i : instruction) :=
  match i with
    | Plabel _ => True
    | _ => False
  end.

Definition is_any_label_dec :
  forall i,
    { l | i = Plabel l } + { ~ is_any_label i }.
Proof.
  intros.
  destruct i eqn:?; try solve [left; eauto];
  right; unfold not; intros; inversion H.
Defined.

Definition lab (i : instruction) : label :=
  match i with
    | Plabel l => l
    | _ => xH
  end.

Fixpoint front {A : Type} (l : list A) :=
  match l with
    | nil => nil
    | a :: b :: nil => a :: nil
    | a :: b =>
      match b with
        | nil => nil
        | x :: y => a :: front b
      end
  end.

Lemma front_length :
  forall {A} (l : list A),
    l = nil \/ length l = (1 + length (front l))%nat.
Proof.
  induction l; intros.
  left. reflexivity.
  right. destruct IHl. simpl. rewrite H. reflexivity.
  unfold front. fold (@front A).
  repeat break_match; simpl; auto.
Qed.

Lemma front_back :
  forall {A} (l : list A),
    l = nil \/ ((exists x, l = (front l) ++ (x :: nil) /\ l <> nil)).
Proof.
  induction l; intros.
  left. reflexivity.
  right. destruct IHl. subst l. exists a. simpl. split. reflexivity. congruence.
  break_exists. exists x. destruct H.
  rewrite H at 1.
  simpl. repeat break_match; split; auto; try congruence.
Qed.

Lemma find_label_front :
  forall c l,
    find_instr (zlen c - 1) c = Some (Plabel l) ->
    ~ In (Plabel l) (front c) ->
    label_pos l 0 c = Some (zlen c).
Proof.
   induction c; intros.
  * simpl in H. inv H.
  * destruct (front_back (a :: c)).
    inv H1. break_exists. break_and.
    simpl in H1. destruct c. simpl in H1. inv H1.
    simpl in H. inv H.
    simpl. rewrite peq_true. f_equal.
    destruct c. simpl in H1. inv H1.
    simpl in H0. simpl.
    break_match. unfold not in H0. destruct H0.
    left. destruct a; simpl in Heqb; inv Heqb.
    break_match_hyp; inversion H1. subst l. reflexivity.
    simpl in H. inv H. simpl. rewrite peq_true.
    f_equal.
    assert (~ In (Plabel l) (front (i :: i0 :: c))).
      assert (front (a :: i :: i0 :: c) = a :: (front (i :: i0 :: c))).
        simpl. reflexivity.
      rewrite H3 in H0.
      assert (~ ((a = Plabel l) \/ In (Plabel l) (front (i :: i0 :: c)))).
        simpl. simpl in H0. assumption.
      unfold not in H4. unfold not. intros. apply H4. right. assumption.
    name H3 Hin.
    apply IHc in H3.
    remember (i :: i0 :: c) as c'.
    simpl in H0. rewrite Heqc' in H0. rewrite <- Heqc' in H0.
    simpl in H0. apply Decidable.not_or in H0. break_and.
    simpl. break_match. destruct a; simpl in Heqb; inv Heqb.
    break_match_hyp; inv H6; congruence.
    rewrite zlen_cons.
    replace 1 with (0 + 1) by omega.
    rewrite <- label_pos_1. assumption.
    remember (i :: i0 :: c) as c'.
    replace (zlen (a :: c') - 1) with (1 + ((zlen c') - 1)) in H.
    rewrite find_instr_head in H. assumption.
    rewrite Heqc'. repeat rewrite zlen_cons.
    name (zlen_nonneg instruction c) zlnc. omega.
    rewrite zlen_cons. omega.
Qed.

Lemma find_label_front_in :
  forall c l,
    find_instr (zlen c - 1) c = Some (Plabel l) ->
    In (Plabel l) (front c) ->
    exists z,
      label_pos l 0 c = Some z /\ 0 <= z < zlen c.
Proof.
  induction c; intros. simpl in H0. inv H0.
  simpl in H0. destruct c.
  simpl in H0. inv H0.
  destruct c. simpl in H0.
  destruct H0. subst a. simpl.
  rewrite peq_true. exists 1. split. reflexivity.
  repeat rewrite zlen_cons. simpl. omega.
  inv H0.
  remember (i :: i0 :: c) as c'.
  simpl in H0. destruct H0.
  rewrite H0. exists 1. simpl. rewrite peq_true.
  split. reflexivity.
  rewrite Heqc'.
  repeat rewrite zlen_cons.
  name (zlen_nonneg instruction c) zln. omega.
  app IHc H0. simpl. break_match. exists 1.
  simpl.
  split. reflexivity.
  rewrite Heqc'.
  repeat rewrite zlen_cons.
  name (zlen_nonneg instruction c) zln. omega.
  replace 1 with (0 + 1) by omega.
  exists (x + 1).
  rewrite <- label_pos_1. break_and.
  split. assumption.
  repeat rewrite zlen_cons. omega.
  rewrite zlen_cons in H.
  replace (zlen c' + 1 - 1) with (1 + (zlen c' - 1)) in H by omega.
  rewrite find_instr_head in H. assumption.
  rewrite Heqc'.
  repeat rewrite zlen_cons.
  name (zlen_nonneg instruction c) zln. omega.
Qed.

Definition labels_valid_dec :
  forall c,
    { labels_valid c } + { ~ labels_valid c }.
Proof.
  intros.
  destruct (find_instr (zlen c - 1) c) eqn:?.
  destruct (is_any_label_dec i). destruct s.
  destruct (in_dec instr_eq (Plabel x) (front c)).
  left. unfold labels_valid. intros.
  destruct (peq l x). subst x.
  app find_label_front_in i0. break_and.
  rewrite H in H1. inv H1.
  apply in_range_find_instr. omega. subst i. assumption.
  apply in_range_find_instr.
  app label_pos_lt H.
  app label_pos_answer_valid H0.
  assert (z < zlen c \/ z = zlen c) by omega.
  destruct H2. omega.
  subst z. app label_pos_find_instr H1.
  subst i. rewrite H1 in Heqo. inv Heqo. congruence.
  right. subst i. app find_label_front Heqo.
  unfold labels_valid. unfold not. intros.
  app H0 Heqo.
  assert (exists i, find_instr (zlen c) c = Some i).
    eauto.
  apply in_range_find_instr in H3. omega.
  left. unfold labels_valid. intros.
  app label_pos_find_instr H.
  apply in_range_find_instr.
  app label_pos_lt H0.
  app label_pos_answer_valid H1.
  assert (z < zlen c \/ z = zlen c) by omega.
  destruct H3. omega. subst z.
  rewrite Heqo in H. inv H. simpl in n.
  unfold not in n. specialize (n I). inv n.
  left. destruct c. unfold labels_valid. intros. simpl in H. inv H.
  unfold labels_valid. intros.
  assert (exists instr, find_instr (zlen (i :: c) - 1) (i :: c) = Some instr).
    apply in_range_find_instr. split; try omega.
    rewrite zlen_cons. name (zlen_nonneg instruction c) zln.
    omega.
  rewrite Heqo in H0. break_exists. inv H0.
Defined.

Definition no_builtin_clobber_PC (c : code) : Prop :=
  forall z ef args res,
    find_instr z c = Some (Pbuiltin ef args res) ->
    ~ In PC res /\ ~ In PC (map preg_of (Machregs.destroyed_by_builtin ef)).

Definition is_builtin (i : instruction) : Prop :=
  match i with
    | Pbuiltin _ _ _ => True
    | _ => False
  end.

Definition is_builtin_dec :
  forall i,
    { x | i = Pbuiltin (fst (fst x)) (snd (fst x)) (snd x) } + { ~ is_builtin i }.
Proof.
  destruct i; try solve [left; exists ((ef,args),res); simpl; auto];
  right; simpl; unfold not; intros; inv H.
Defined.

Definition no_builtin_clobber_PC_dec :
  forall c,
    { no_builtin_clobber_PC c } + { ~ no_builtin_clobber_PC c }.
Proof.
  induction c; intros.
  left. unfold no_builtin_clobber_PC. intros. simpl in H. inv H.
  destruct IHc. destruct (is_builtin_dec a).
  destruct s. destruct x. destruct p. simpl in e.
  destruct (in_dec preg_eq PC l). right.
  unfold not. intros. unfold no_builtin_clobber_PC in H.
  specialize (H 0). simpl in H. rewrite e in H.
  specialize (H _ _ _ eq_refl). destruct H. congruence.
  destruct (in_dec preg_eq PC (map preg_of (Machregs.destroyed_by_builtin e0))).
  right. unfold not. intros. unfold no_builtin_clobber_PC in H.
  specialize (H 0). simpl in H. rewrite e in H.
  specialize (H _ _ _ eq_refl). destruct H. congruence.
  subst a.
  left. unfold no_builtin_clobber_PC. intros.
  simpl in H. break_match_hyp. inv H. split; auto.
  unfold no_builtin_clobber_PC in n. app n H.
  left. unfold no_builtin_clobber_PC. intros.
  simpl in H. break_match_hyp. inv H. simpl in n0. auto.
  unfold no_builtin_clobber_PC in n. app n H.
  right. unfold not. intros. unfold not in n. apply n.
  clear n. unfold no_builtin_clobber_PC in *. intros.
  rewrite <- find_instr_head with (a := a) in H0. app H H0.
  assert (exists i, find_instr z c = Some i).
    eexists; eauto.
  apply in_range_find_instr in H1. omega.
Qed.

(* what it means for a piece of code to be part of a program *)
Definition code_of_prog(c : code)(p : Asm.program) : Prop :=
  exists b s,
    In (b,Gfun (Internal (mkfunction s c))) (prog_defs p).

Definition no_PC_overflow_prog (p : Asm.program) : Prop :=
  forall c,
    code_of_prog c p ->
    no_PC_overflow c.

Lemma unsigned_repr_PC :
  forall prog b z f i,
    no_PC_overflow_prog prog ->
    Genv.find_funct_ptr (Genv.globalenv prog) b = Some (Internal f) ->
    (find_instr (z - 1) (fn_code f) = Some i \/ find_instr z (fn_code f) = Some i) ->
    Int.unsigned (Int.repr z) = z.
Proof.
  intros.
  unfold no_PC_overflow_prog in *.
  destruct f.
  assert (code_of_prog fn_code prog).
  unfold code_of_prog.
  app Genv.find_funct_ptr_inversion H0.
  eauto.
  exploit Int.unsigned_repr; eauto.
  app H H2.
  unfold no_PC_overflow in H2.
  break_or;
    simpl in *;
    app H2 H4;
    omega.
Qed.

Definition labels_valid_prog (p : Asm.program) : Prop :=
  forall c,
    code_of_prog c p ->
    labels_valid c.

Definition no_builtin_clobber_PC_prog (p : Asm.program) : Prop :=
  forall c,
    code_of_prog c p ->
    no_builtin_clobber_PC c.

Lemma code_eq_dec :
  forall (c c' : code),
    { c = c' } + { c <> c' }.
Proof.
  intros. decide equality. apply instr_eq.
Defined.

Lemma prog_dec :
  forall (P : code -> Prop),
    (forall c, { P c } + { ~ P c }) ->
    (forall p, { forall c, code_of_prog c p -> P c } + { ~ forall c, code_of_prog c p -> P c }).
Proof.
  intro. intro. intro. destruct p.
  induction prog_defs.
  * left. intros.
    unfold code_of_prog in H0. repeat break_exists.
    simpl in H0. inv H0.
  * intros.
    destruct a. destruct g. destruct f. destruct f. rename fn_code into c.
    destruct (IHprog_defs).
    destruct (H c). left. intros. unfold code_of_prog in H0.
    simpl in H0. destruct (code_eq_dec c c0). subst c0. assumption.
    break_exists. destruct H0. inv H0. congruence.
    apply p. unfold code_of_prog. simpl. eauto.
    right. unfold not. intros.
    unfold not in n. apply n. apply H0. unfold code_of_prog. simpl.
    exists i. exists fn_sig. left. reflexivity.
    unfold not in n. right. unfold not. intros. apply n. intros. apply H0.
    unfold code_of_prog. unfold code_of_prog in H1. repeat break_exists. exists x. exists x0. simpl. right. auto.
    destruct IHprog_defs. left. intros. apply p.
    unfold code_of_prog in *. repeat break_exists. simpl in H0.
    destruct H0. inv H0.
    exists x. exists x0. simpl. auto.
    right. unfold not in *. intros. apply n.
    intros. unfold code_of_prog in *. apply H0. repeat break_exists. exists x. exists x0. simpl in H1. simpl.
    right. auto.
    destruct IHprog_defs. left. intros. apply p. unfold code_of_prog in *. simpl in *.
    repeat break_exists. destruct H0. inv H0.
    exists x. exists x0. auto.
    right. unfold not in *. intros. apply n. intros.
    apply H0. unfold code_of_prog in *.
    repeat break_exists. exists x. exists x0. simpl in *. right. auto.
Defined.

Definition labels_valid_prog_dec : forall p, { labels_valid_prog p } + { ~ labels_valid_prog p}.
  intros. unfold labels_valid_prog. apply prog_dec.
  apply labels_valid_dec.
Defined.

Definition no_PC_overflow_prog_dec : forall p, { no_PC_overflow_prog p } + { ~ no_PC_overflow_prog p }.
  intros. unfold no_PC_overflow_prog. apply prog_dec.
  apply no_PC_overflow_dec.
Defined.

Definition no_builtin_clobber_PC_prog_dec : forall p, { no_builtin_clobber_PC_prog p } + { ~ no_builtin_clobber_PC_prog p }.
  intros. unfold no_builtin_clobber_PC_prog. apply prog_dec.
  apply no_builtin_clobber_PC_dec.
Defined.

Definition is_allocframe_pos (i : instruction) : Prop :=
  match i with
    | Pallocframe sz _ _ => sz > 0
    | _ => True
  end.

Definition is_allocframe_pos_dec :
  forall i,
    {is_allocframe_pos i} + {~is_allocframe_pos i}.
Proof.
  destruct i; simpl; try solve [left; auto].
  apply Z_gt_dec.
Qed.

Definition all_allocframes_positive_code (c : code) :=
  forall z sz x y,
    find_instr z c = Some (Pallocframe sz x y) ->
    sz > 0.

Definition all_allocframes_positive (p : program) :=
  forall c,
    code_of_prog c p ->
    all_allocframes_positive_code c.

Lemma all_allocframes_positive_code_dec :
  forall c,
    { all_allocframes_positive_code c } + { ~ all_allocframes_positive_code c }.
Proof.
  induction c; intros.
  * left. unfold all_allocframes_positive_code. intros.
    simpl in H. congruence.
  * destruct IHc. destruct (is_allocframe_pos_dec a).
    left. unfold all_allocframes_positive_code in *. intros.
    destruct (Z.eq_dec z 0). subst. simpl in H. inv H.
    unfold is_allocframe_pos in i. auto.
    apex in_range_find_instr H. break_and.
    replace z with (1 + (z -1)) in H by omega.
    rewrite find_instr_head in H; try omega.
    app a0 H.
    destruct a; simpl in n; try intuition.
    intros.
    right. intros. unfold all_allocframes_positive_code in H.
    specialize (H 0 sz ofs_ra ofs_link eq_refl). simpl in H.
    intuition.
    right. intro.
    apply n.
    clear n. unfold all_allocframes_positive_code in *.
    intros. erewrite <- find_instr_head in H0.
    eapply H. eauto.
    apex in_range_find_instr H0. omega.
Qed.

Lemma all_allocframes_positive_prog_dec :
  forall p,
    { all_allocframes_positive p } + { ~ all_allocframes_positive p }.
Proof.
  intros. destruct p.
  induction prog_defs; unfold all_allocframes_positive.
  * unfold code_of_prog. left. intros.
    repeat break_exists. simpl in H. inv H.
  * destruct IHprog_defs.
    destruct a. destruct g. destruct f.
    destruct (all_allocframes_positive_code_dec (fn_code f)).
    left. intros.
    unfold code_of_prog in H. repeat break_exists.
    simpl in H. destruct H. inv H.
    simpl in a. assumption.
    unfold all_allocframes_positive in a0.
    apply a0. unfold code_of_prog. eexists. eexists. eapply H.
    right. intro. apply n. apply H.
    unfold code_of_prog. exists i. exists (fn_sig f).
    simpl. left. destruct f. reflexivity.
    left. intros.
    unfold code_of_prog in H. repeat break_exists.
    simpl in H. destruct H. inv H.
    unfold all_allocframes_positive in a0.
    apply a0. unfold code_of_prog. eexists. eexists. eapply H.
    left. intros.
    unfold code_of_prog in H. repeat break_exists.
    simpl in H. destruct H. inv H.
    unfold all_allocframes_positive in a0.
    apply a0. unfold code_of_prog. eexists. eexists. eapply H.
    right. intro. apply n. clear n.
    unfold all_allocframes_positive. intros. apply H.
    unfold code_of_prog in *.
    repeat break_exists. eexists. eexists.
    simpl. right.
    simpl in H0. eapply H0.
Qed.


Require Import VST.floyd.base.
Require Import VST.floyd.canon.

Local Open Scope logic.

Definition wp {cs: compspecs} {Ora: OracleKind} (Delta: tycontext) (c: statement) (Q: ret_assert): environ -> mpred :=
  EX P: environ -> mpred, !! semax Delta P c Q && P.

Definition wp_spec: forall {cs: compspecs} {Ora: OracleKind} (Delta: tycontext) P c Q,
  P |-- wp Delta c Q <-> semax Delta P c Q.
Proof.
  intros.
  split; intros.
  + eapply semax_pre.
    - apply andp_left2, H.
    - unfold wp.
      apply semax_extract_exists.
      clear P H.
      intros P.
      apply semax_extract_prop.
      auto.
  + unfold wp.
    apply (exp_right P).
    apply andp_right.
    - apply prop_right; auto.
    - auto.
Qed.

Section wp_seq.

Parameter semax_seq_inv': forall {CS: compspecs} {Espec: OracleKind} Delta P R h t,
    @semax CS Espec Delta P (Ssequence h t) R ->
    @semax CS Espec Delta P h (overridePost (EX Q: environ -> mpred, !! (@semax CS Espec Delta Q t R) && Q) R).
(* line 478 in SeparationLogicAsLogic *)
Check semax_conseq.
Lemma wp_seq: forall {CS: compspecs} {Espec: OracleKind} Delta P c1 c2,
  wp Delta (Ssequence c1 c2) P = wp Delta c1 (overridePost (wp Delta c2 P) P).
Proof.
  intros.
  rename P into R.
  apply pred_ext.
  + unfold wp at 1.
    apply exp_left; intros P.
    apply derives_extract_prop.
    intros.
    unfold wp at 1.
    apply (exp_right P).
    apply andp_right; [apply prop_right | auto].
    apply semax_seq_inv' in H.
    exact H.
  + unfold wp at 1.
    apply exp_left; intros P.
    apply derives_extract_prop.
    intros.
    unfold wp at 1.
    apply (exp_right P).
    apply andp_right; [apply prop_right | auto].
    apply semax_seq with (wp Delta c2 R); auto.
    apply wp_spec.
    auto.
Qed.

End wp_seq.


(** Bag with contributions specification *)
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang proofmode notation.
From iris.proofmode Require Import proofmode.
From iris.algebra Require Import gmultiset frac_auth.
From iris_examples.hocap Require Import abstract_bag.
From iris.prelude Require Import options.

Section proof.
  Context `{heapGS Σ}.
  Variable b : bag Σ.
  Variable N : namespace.
  Definition NB := N.@"bag".
  Definition NI := N.@"inv".

  Context `{inG Σ (frac_authR (gmultisetUR val))}.

  Definition bagM_inv (γb : name Σ b) (γ : gname) : iProp Σ :=
    inv NI (∃ X, bag_contents b γb X ∗ own γ (●F X))%I.
  Definition bagM (γb : name Σ b) (γ : gname) (x : val) : iProp Σ :=
    (is_bag b NB γb x ∗ bagM_inv γb γ)%I.
  Definition bagPart (γ : gname) (q : Qp) (X : gmultiset val) : iProp Σ :=
    (own γ (◯F{q} X))%I.

  Lemma bagPart_compose (γ: gname) (q1 q2: Qp) (X Y : gmultiset val) :
    bagPart γ q1 X -∗ bagPart γ q2 Y -∗ bagPart γ (q1+q2) (X ⊎ Y).
  Proof.
    iIntros "Hp1 Hp2".
    rewrite /bagPart -gmultiset_op -frac_op.
    rewrite frac_auth_frag_op own_op. iFrame.
  Qed.
  Lemma bagPart_decompose (γ: gname) (q: Qp) (X Y : gmultiset val) :
    bagPart γ q (X ⊎ Y) -∗ bagPart γ (q/2) X ∗ bagPart γ (q/2) Y.
  Proof.
    iIntros "Hp".
    assert (q = (q/2)+(q/2))%Qp as Hq by (by rewrite Qp_div_2).
    rewrite /bagPart {1}Hq.
    rewrite -gmultiset_op -frac_op.
    rewrite frac_auth_frag_op own_op. iFrame.
  Qed.

  Global Instance bagM_persistent γb γ x : Persistent (bagM γb γ x).
  Proof. apply _. Qed.

  Lemma newBag_spec :
    {{{ True }}}
      newBag b #()
    {{{ x, RET x; ∃ γb γ, bagM γb γ x ∗ bagPart γ 1 ∅ }}}.
  Proof.
    iIntros (Φ) "_ HΦ". iApply wp_fupd.
    iApply (newBag_spec b NB); eauto.
    iNext. iIntros (v γb) "[#Hbag Hcntn]".
    iMod (own_alloc (●F ∅ ⋅ ◯F ∅)) as (γ) "[Hown Hpart]"; first by apply auth_both_valid_discrete.
    iMod (inv_alloc NI _ (∃ X, bag_contents b γb X ∗ own γ (●F X))%I with "[Hcntn Hown]") as "#Hinv".
    { iNext. iExists _. iFrame. }
    iApply "HΦ". iModIntro. iExists _,_. iFrame "Hinv Hbag Hpart".
  Qed.

  Lemma pushBag_spec γb γ x v q Y :
    {{{ bagM γb γ x ∗ bagPart γ q Y }}}
       pushBag b x (of_val v)
    {{{ RET #(); bagPart γ q ({[+ v +]} ⊎ Y) }}}.
  Proof.
    iIntros (Φ) "[#[Hbag Hinv] HP] HΦ". rewrite /bagM_inv.
    iApply (pushBag_spec b NB (bagPart γ q Y)%I (bagPart γ q ({[+ v +]} ⊎ Y))%I with "[] [Hbag HP]"); eauto.
    iModIntro. iIntros (X) "[Hb1 HP]".
    iInv NI as (X') "[>Hb2 >Hown]" "Hcl".
    iDestruct (bag_contents_agree with "Hb1 Hb2") as %<-.
    iMod (bag_contents_update b ({[+ v +]} ⊎ X) with "[$Hb1 $Hb2]") as "[Hb1 Hb2]".
    rewrite /bagPart.
    iMod (own_update_2 with "Hown HP") as "[Hown HP]".
    { apply (frac_auth_update _ _ _ ({[+ v +]} ⊎ X) ({[+ v +]} ⊎ Y)).
      do 2 rewrite (comm _ {[+ v +]}).
      apply gmultiset_local_update_alloc. }
    iFrame. iApply "Hcl".
    iNext. iExists _; iFrame.
  Qed.

  Local Ltac multiset_solver :=
    intro;
    repeat (rewrite multiplicity_difference || rewrite multiplicity_disj_union);
    (lia || naive_solver).

  Lemma popBag_spec γb γ x X :
    {{{ bagM γb γ x ∗ bagPart γ 1 X }}}
       popBag b x
    {{{ v, RET v;
        (⌜v = NONEV⌝ ∧ ⌜X = ∅⌝ ∗ bagPart γ 1 X)
       ∨ (∃ y, ⌜v = SOMEV y⌝ ∧ ⌜y ∈ X⌝ ∗ bagPart γ 1 (X ∖ {[+ y +]})) }}}.
  Proof.
    iIntros (Φ) "[[#Hbag #Hinv] Hpart] HΦ".
    iApply (popBag_spec b NB (bagPart γ 1 X)%I
             (fun v => (⌜v = NONEV⌝ ∧ ⌜X = ∅⌝ ∗ bagPart γ 1 X)
                     ∨ (∃ y, ⌜v = SOMEV y⌝ ∧ ⌜y ∈ X⌝ ∗ bagPart γ 1 (X ∖ {[+ y +]})))%I with "[] [] [Hpart]"); eauto.
    { iModIntro. iIntros (Y y) "[Hb1 Hpart]".
      iInv NI as (X') "[>Hb2 >HPs]" "Hcl".
      iDestruct (bag_contents_agree with "Hb1 Hb2") as %<-.
      iMod (bag_contents_update b Y with "[$Hb1 $Hb2]") as "[Hb1 Hb2]".
      rewrite /bagPart.
      iAssert (⌜X = ({[+ y +]} ⊎ Y)⌝)%I with "[Hpart HPs]" as %->.
      { iDestruct (own_valid_2 with "HPs Hpart") as %Hfoo.
        apply frac_auth_agree in Hfoo. by unfold_leibniz. }
      iMod (own_update_2 with "HPs Hpart") as "Hown".
      { apply (frac_auth_update _ _ _ (({[+ y +]} ⊎ Y) ∖ {[+ y +]}) (({[+ y +]} ⊎ Y) ∖ {[+ y +]})).
        apply gmultiset_local_update_dealloc; multiset_solver. }
      iDestruct "Hown" as "[HPs Hpart]".
      iMod ("Hcl" with "[-Hpart Hb1]") as "_".
      { iNext. iExists _; iFrame.
        assert (Y = (({[+ y +]} ⊎ Y) ∖ {[+ y +]})) as <-
          by (unfold_leibniz; multiset_solver).
        iFrame. }
      iModIntro. iNext. iFrame. iRight. iExists y; repeat iSplit; eauto.
      iPureIntro. apply gmultiset_elem_of_disj_union. left.
      by apply gmultiset_elem_of_singleton. }
    { iModIntro. iIntros "[Hb1 Hpart]".
      iInv NI as (X') "[>Hb2 >HPs]" "Hcl".
      iDestruct (bag_contents_agree with "Hb1 Hb2") as %<-.
      iAssert (⌜X = ∅⌝)%I with "[Hpart HPs]" as %->.
      { rewrite /bagPart.
        iDestruct (own_valid_2 with "HPs Hpart") as %Hfoo.
        apply frac_auth_agree in Hfoo. by unfold_leibniz. }
      iMod ("Hcl" with "[Hb2 HPs]") as "_".
      { iNext. iExists _; iFrame. }
      iModIntro. iNext. iFrame. iLeft; eauto. }
  Qed.

End proof.


Require Export Coercion_WF_Coerciongen.
Set Undo 100000.

Hint Constructors coercion.
Hint Unfold coerciongen.
Hint Resolve in_eq in_cons in_inv in_nil insingleton.
Hint Resolve coercion_pi_strengthening.
Require Import Classical.
Hint Resolve altnosub_to_altsub.

Ltac case_eq f :=
  generalize (refl_equal f); pattern f at -1; case f.

Hint Constructors nd_typing.
Hint Resolve coercion_sub_rel coerce_non_identity.
Hint Unfold id compose funcompose paircompose.

Lemma non_unique_path_witness: forall sigma d,
  (ok sigma) ->
  ~(WF_uniquepath d sigma) ->
  (exists t, exists t', exists m, exists m',
    coerciongen sigma t d t' m /\
    coerciongen sigma t d t' m' /\
    m <> m' /\ (forall t, m <> (id t)) /\ (forall t, m' <> (id t))).
Proof.
intros sigma d ok_sigma not_wf.
unfold WF_uniquepath in not_wf.
(* UGLY UGLY ... how to do this programmatically? *)
destruct (not_all_ex_not _ _ not_wf) as [a rest1].
destruct (not_all_ex_not _ _ rest1) as [s rest2].
destruct (not_all_ex_not _ _ rest2) as [s' rest3].
destruct (not_all_ex_not _ _ rest3) as [C1 rest4].
destruct (not_all_ex_not _ _ rest4) as [C2 rest5].
destruct (not_all_ex_not _ _ rest5) as [pi rest].
clear not_wf rest1 rest2 rest3 rest4 rest5.
exists s; exists s'; exists C1; exists C2.
destruct (imply_to_and _ _ rest) as [inpi rest1].
destruct (imply_to_and _ _ rest1) as [cg1 rest2].
destruct (imply_to_and _ _ rest2) as [cg2 rest3].
clear rest rest1 rest2.
repeat split;
  (unfold coerciongen; eauto) || idtac.
Case "C1 <> id".
intro t.
unfold not; intro C_eq_id.
subst.
assert ((s=s') /\ (s' = t)) as s_eq_s'.
  eauto using identity_coercions_equate_types.
destruct s_eq_s'; subst.
assert ((t=t) /\ (C2 = (id t))).
  unfold id. eauto using cycles_are_identity.
intuition.
Case "C2 <> id".
intro t.
unfold not; intro C_eq_id.
subst.
assert ((s=s') /\ (s' = t)) as s_eq_s'.
  eauto using identity_coercions_equate_types.
destruct s_eq_s'; subst.
assert ((t=t) /\ (C1 = (id t))).
  unfold id. eauto using cycles_are_identity.
intuition.
Qed.

Lemma non_unique_pair_witness: forall sigma d,
  (ok sigma) ->
  ~(WF_to_uniquepair d sigma) ->
  (exists t, exists t1, exists t2, exists s1, exists s2, exists m, exists m',
    coerciongen sigma t d (typ_pair t1 t2) m /\
    coerciongen sigma t d (typ_pair s1 s2) m' /\
    (m <> m' /\ ((forall t, m <> (id t)) \/ (forall t, m' <> (id t))))).
Proof.
intros sigma d ok_sigma not_wf.
unfold WF_to_uniquepair in not_wf.
(* UGLY UGLY ... how to do this programmatically? *)
destruct (not_all_ex_not _ _ not_wf) as [a rest1].
destruct (not_all_ex_not _ _ rest1) as [s rest2].
destruct (not_all_ex_not _ _ rest2) as [s1 rest3].
destruct (not_all_ex_not _ _ rest3) as [s1' rest4].
destruct (not_all_ex_not _ _ rest4) as [s2 rest5].
destruct (not_all_ex_not _ _ rest5) as [s2' rest6].
destruct (not_all_ex_not _ _ rest6) as [C rest7].
destruct (not_all_ex_not _ _ rest7) as [C' rest8].
destruct (not_all_ex_not _ _ rest8) as [pi rest].
clear not_wf rest1 rest2 rest3 rest4 rest5 rest6 rest7 rest8.
exists s; exists s1; exists s2; exists s1'; exists s2'; exists C; exists C'.
destruct (imply_to_and _ _ rest) as [inpi rest1].
destruct (imply_to_and _ _ rest1) as [cg1 rest2].
destruct (imply_to_and _ _ rest2) as [cg2 rest3].
clear rest rest1 rest2.
split.
unfold coerciongen. eauto.
split.
unfold coerciongen. eauto.
destruct (not_and_or _ _ rest3) as [C_neq_C' | rest].
Case "C <> C'".
 split.
 auto.
 destruct (classic (exists t, C = id t)) as [[t' C_eq_id_t'] | C_neq_id_t].
 SCase "C eq id t'".
   right.
   destruct (classic (exists t, C' = id t)) as [[t'' C'_eq_id_t''] | C'_neq_id_t].
   SSCase "C' = id t''".
   subst.
   assert ((s=(typ_pair s1 s2)) /\ ((typ_pair s1 s2)=t')) as eq1.
     eauto using identity_coercions_equate_types.
   assert ((s=(typ_pair s1' s2')) /\ ((typ_pair s1' s2')=t'')) as eq2.
     eauto using identity_coercions_equate_types.
   destruct eq1 as [eq11 eq12]. destruct eq2 as [eq21 eq22]. subst. injection eq21; intros; subst.
   unfold id in C_neq_C'. eauto.
   SSCase "C' <> id t''".
      apply (not_ex_all_not _ _ C'_neq_id_t).
 SCase "C <> id t".
  left.
  apply (not_ex_all_not _ _ C_neq_id_t).
Case "s1 <> s1' \/ s2 <> s2'".
assert ((typ_pair s1 s2) <> (typ_pair s1' s2')).
  destruct (not_and_or _ _ rest) as [s1_neq_s1' | s2_neq_s2']; injection; intros; eauto.
assert (C <> C') as C_neq_C'.
 eauto using coercion_between_distinct_types.
split. auto.
 destruct (classic (exists t, C = id t)) as [[t' C_eq_id_t'] | C_neq_id_t].
 SCase "C eq id t'".
   right.
   destruct (classic (exists t, C' = id t)) as [[t'' C'_eq_id_t''] | C'_neq_id_t].
   SSCase "C' = id t''".
   subst.
   assert ((s=(typ_pair s1 s2)) /\ ((typ_pair s1 s2)=t')) as eq1.
     eauto using identity_coercions_equate_types.
   assert ((s=(typ_pair s1' s2')) /\ ((typ_pair s1' s2')=t'')) as eq2.
     eauto using identity_coercions_equate_types.
   destruct eq1 as [eq11 eq12]. destruct eq2 as [eq21 eq22]. subst. injection eq21; intros; subst.
   unfold id in C_neq_C'. eauto.
   SSCase "C' <> id t''".
      apply (not_ex_all_not _ _ C'_neq_id_t).
 SCase "C <> id t".
  left.
  apply (not_ex_all_not _ _ C_neq_id_t).
Qed.

Lemma non_nac_app_witness : forall sigma d d',
  ~(WF_app d d' sigma) ->
  (exists t, exists t1, exists t2, exists s1, exists s2, exists t', exists m1, exists m2, exists m3, exists m4,
    coerciongen sigma t d (typ_fun t1 t2) m1 /\
    coerciongen sigma t d (typ_fun s1 s2) m2 /\
    coerciongen sigma t' d' t1 m3 /\
    coerciongen sigma t' d' s1 m4 /\
    (t1 <> s1 \/ t2 <> s2)).
Proof.
intros sigma d d' not_wf.
unfold WF_app in not_wf.
(* UGLY UGLY ... how to do this programmatically? *)
destruct (not_all_ex_not _ _ not_wf) as [s rest1].
destruct (not_all_ex_not _ _ rest1) as [s' rest2].
destruct (not_all_ex_not _ _ rest2) as [s1 rest3].
destruct (not_all_ex_not _ _ rest3) as [s2 rest4].
destruct (not_all_ex_not _ _ rest4) as [s3 rest5].
destruct (not_all_ex_not _ _ rest5) as [s4 rest6].
destruct (not_all_ex_not _ _ rest6) as [n1 rest7].
destruct (not_all_ex_not _ _ rest7) as [n2 rest8].
destruct (not_all_ex_not _ _ rest8) as [n3 rest9].
destruct (not_all_ex_not _ _ rest9) as [n4 rest].
clear rest1 rest2 rest3 rest4 rest5 rest6 rest7 rest8 rest9.
exists s1. exists s2. exists s.
exists s3. exists s'.
exists s4. exists n1. exists n3. exists n2. exists n4.
destruct (imply_to_and _ _ rest) as [cg1 rest1].
destruct (imply_to_and _ _ rest1) as [cg2 rest2].
destruct (imply_to_and _ _ rest2) as [cg3 rest3].
destruct (imply_to_and _ _ rest3) as [cg4 rest4].
clear rest1 rest2 rest3 rest.
pose proof (not_and_or _ _ rest4). intuition.
Qed.

Hint Unfold coerciongen.

Theorem nonambiguity_core_sufficient :
  forall sigma gamma e e1 t1 e2 t2 d d',
    (NAC sigma d d') ->
    (ok sigma) ->
    (ok gamma) ->
    (nd_typing sigma gamma d d' e e1 t1) ->
    (nd_typing sigma gamma d d' e e2 t2) ->
    ((e1,t1) = (e2,t2)).
Proof.
intros until 1. rename H into WF. intros ok_sigma gOK T1 T2.
generalize dependent e2.
generalize dependent t2.
induction T1.
Case "typing_Var". intros.
inversion T2. subst.  assert (t=t2). eauto using binds_id.
subst. eauto.
Case "typing_Base". intros.
inversion T2. subst.  assert (t=t2). eauto using binds_id.
subst. eauto.
Case "typing_Ascription".
intros.
inversion T2. subst. firstorder.
Case "typing_Abs".
intros.
inversion T2. subst.
destruct (freevars_totality e') as [fvs_e' freevars_e'].
destruct (freevars_totality e'0) as [fvs_e'0 freevars_e'0].
pick fresh y.
assert (y `notin` L) as ynotinL.
 fsetdec.
assert (y `notin` L0) as ynotinL0.
 fsetdec.
assert (ok ([(y,t_x)]++G)) as ok_yG.
 rewrite_env ((y,t_x)::G).
 eapply ok_cons; [eauto | fsetdec].
pose proof (H9 y ynotinL0) as typing_e2_body.
pose proof (H0 y ynotinL WF ok_sigma ok_yG _ _ typing_e2_body) as fromIH.
injection fromIH; intros. subst.
assert (e' = e'0). eapply (open_exp_injection e' e'0 y); try eauto || fsetdec.
subst; eauto.
Case "typing_Pair".
intros. inversion T2. subst.
firstorder.
pose proof (H4 _ _ H5) as eq1.
pose proof (H3 _ _ H8) as eq2.
injection eq1. injection eq2. intros; subst; auto.
Case "typing_App".
intros. inversion T2. subst.
pose proof (IHT1_1 WF ok_sigma gOK _ _ H3) as e1_eq.
pose proof (IHT1_2 WF ok_sigma gOK _ _ H4) as e2_eq.
injection e1_eq; injection e2_eq; intros; subst.
clear IHT1_1 IHT1_2 e1_eq e2_eq.
rename e1'0 into e1'.
rename e2'0 into e2'.
unfold NAC in WF.
destruct WF as [WF_up_prim [WF_up_sub [WF_upair WF_a]]].
unfold WF_app in WF_a.
destruct (WF_a _ _ _ _ _ _ _ _ _ _ H H0 H9 H12) as [targ_eq tret_eq].
subst.
clear WF_a WF_upair.
unfold WF_uniquepath in WF_up_prim.
  unfold coerciongen in H, H9.
  assert (m1=m0). eauto.
unfold WF_uniquepath in WF_up_sub.
  unfold coerciongen in H0, H12.
  assert (m2=m3). eauto.
subst. auto.
Case "typing_Proj One".
intros. inversion T2. subst.
firstorder.
pose proof (H5 _ _ H1) as fromIH.
injection fromIH; intros; subst.
rename e'0 into e'.
rename H0 into WF_up. rename H3 into WF_upair.
unfold WF_to_uniquepair in  WF_upair.
   unfold coerciongen in H6, H.
   assert (m=m0 /\ t1=t0 /\ t2=t5) as eqs. eauto.
destruct eqs as [eq1 [eq2 eq3]]. subst. auto.
Case "typing_Proj Two".
intros. inversion T2. subst.
firstorder.
pose proof (H5 _ _ H1) as fromIH.
injection fromIH; intros; subst.
rename e'0 into e'.
rename H0 into WF_up. rename H3 into WF_upair.
unfold WF_to_uniquepair in  WF_upair.
   unfold coerciongen in H6, H.
   assert (m=m0 /\ t1=t4 /\ t2=t0) as eqs. eauto.
destruct eqs as [eq1 [eq2 eq3]]. subst. auto.
Qed.

Lemma nonamb_core_necessary_not_uniquepath_right:
  forall sigma d d',
    (ok sigma) ->
    ~(WF_uniquepath d' sigma) ->
    (exists gamma, exists e, exists e1, exists e2, exists t1, exists t2,
      nd_typing sigma gamma d d' e e1 t1 /\
      nd_typing sigma gamma d d' e e2 t2 /\
      (e1 <> e2 \/ t1 <> t2)).
Proof.
intros sigma d d' ok_sigma not_wf_up.
 destruct (non_unique_path_witness _ _ ok_sigma not_wf_up) as [t [t' [m [m' [C_m [C_m' [m_neq_m' [m_neq_id m'_neq_id]]]]]]]].
 pick fresh f.
 pick fresh x.
 exists ([(f, (typ_fun t' t'))]++[(x, t)]).
 exists (exp_app (exp_fvar f) (exp_fvar x)).
 exists (exp_app (coerce (id (typ_fun t' t')) (exp_fvar f)) (coerce m (exp_fvar x))).
 exists (exp_app (coerce (id (typ_fun t' t')) (exp_fvar f)) (coerce m' (exp_fvar x))).
 exists t'. exists t'.
 split.
 SCase "nd_typing 1". unfold id.
   induction d; eapply nd_typing_App; eauto.
 split.
 SCase "nd_typing 2". unfold id.
   induction d; eapply nd_typing_App; eauto.
 SCase "neq". left. simpl.
   rewrite (coerce_non_identity m (exp_fvar x) m_neq_id).
   rewrite (coerce_non_identity m' (exp_fvar x) m'_neq_id).
   injection; eauto.
Qed.

Lemma nonamb_core_necessary_not_uniquepath_left:
  forall sigma d d',
    (ok sigma) ->
    ~(WF_uniquepath d sigma) ->
    (exists gamma, exists e, exists e1, exists e2, exists t1, exists t2,
      nd_typing sigma gamma d d' e e1 t1 /\
      nd_typing sigma gamma d d' e e2 t2 /\
      (e1 <> e2 \/ t1 <> t2)).
Proof.
intros sigma d d' ok_sigma not_wf_up.
 destruct (classic (d=d')) as [d_eq_d' | d_neq_d'].
 subst. eauto using nonamb_core_necessary_not_uniquepath_right.
 Case "d <> d'".
 induction d.
   SCase "d = RelPrim".
     induction d'. destruct d_neq_d'; eauto.
     SSCase "d' = RelSub". clear d_neq_d'.
      destruct (non_unique_path_witness _ _ ok_sigma not_wf_up) as [t [t' [m [m' [C_m [C_m' [m_neq_m' [m_neq_id m'_neq_id]]]]]]]].
      assert (coerciongen sigma t RelPrim t' m) as C_m_sub.
          unfold coerciongen in *; eauto using coercion_sub_rel.
      assert (coerciongen sigma t RelPrim t' m') as C_m'_sub.
          unfold coerciongen in *; eauto using coercion_sub_rel.
      pick fresh f.
      pick fresh x.
      exists ([(f, (typ_fun t' t'))]++[(x, t)]).
      exists (exp_app (exp_fvar f) (exp_fvar x)).
      exists (exp_app (coerce (id (typ_fun t' t')) (exp_fvar f)) (coerce m (exp_fvar x))).
      exists (exp_app (coerce (id (typ_fun t' t')) (exp_fvar f)) (coerce m' (exp_fvar x))).
      exists t'. exists t'.
      split.
      SSSCase "nd_typing 1". unfold id.
        eapply nd_typing_App; eauto.
        split.
      SSSCase "nd_typing 2". unfold id.
        eapply nd_typing_App; eauto.
      SSSCase "neq". left. simpl.
        rewrite (coerce_non_identity m (exp_fvar x) m_neq_id).
        rewrite (coerce_non_identity m' (exp_fvar x) m'_neq_id).
        injection; eauto.
  SCase "d=RelSub".
      induction d'.
      SSCase "d'=RelPrim".
      destruct (non_unique_path_witness _ _ ok_sigma not_wf_up) as [t [t' [m [m' [C_m [C_m' [m_neq_m' [m_neq_id m'_neq_id]]]]]]]].
      pick fresh f.
      pick fresh x.
      exists ([(f, (typ_fun t t))]++[(x, t)]).
      exists (exp_app (exp_fvar f) (exp_fvar x)).
      exists (exp_app (coerce (compose (typ_fun t t) (id (typ_fun t t'))
                                  (funcompose (typ_fun t t) t (id t) m))
                       (exp_fvar f))
                       (coerce (id t) (exp_fvar x))).
      exists (exp_app (coerce (compose (typ_fun t t) (id (typ_fun t t'))
                                  (funcompose (typ_fun t t) t (id t) m'))
                       (exp_fvar f))
                       (coerce (id t) (exp_fvar x))).
      exists t'. exists t'.
      split.
      SSSCase "nd_typing 1".
        unfold coerciongen in *.
        eapply nd_typing_App; try solve [unfold coerciongen in *; eauto].
        unfold coerciongen.  eapply coercion_FunTrans.
           assert (~In (typ_fun t t') [typ_fun t t]) as HH.
             assert (t <> t') as t_neq_t'. eapply (nonidentity_implies_inequality sigma ([t])); eauto.
             eapply not_in_singleton. unfold not; intros. injection H; intros; subst; eauto.
           apply HH. unfold id; eauto. eauto. unfold id; eauto. unfold id; eauto.
      split.
      SSSCase "nd_typing 2".
        unfold coerciongen in *.
        eapply nd_typing_App; try solve [unfold coerciongen in *; eauto].
        unfold coerciongen.  eapply coercion_FunTrans.
           assert (~In (typ_fun t t') [typ_fun t t]) as HH.
             assert (t <> t') as t_neq_t'. eapply (nonidentity_implies_inequality sigma ([t])); eauto.
             eapply not_in_singleton. unfold not; intros. injection H; intros; subst; eauto.
           apply HH. unfold id; eauto. eauto. unfold id; eauto. unfold id; eauto.
       left. simpl. unfold compose. unfold funcompose. simpl. unfold not. intros HH.
       injection HH. eauto.
     SSCase "d' = RelSub".
       destruct d_neq_d'. eauto.
Qed.

Theorem nonambiguity_core_necessary :
  forall sigma d d',
    (ok sigma) ->
    ~(NAC sigma d d') ->
    (exists gamma, exists e, exists e1, exists e2, exists t1, exists t2,
      nd_typing sigma gamma d d' e e1 t1 /\
      nd_typing sigma gamma d d' e e2 t2 /\
      (e1 <> e2 \/ t1 <> t2)).
Proof.
intros sigma d d' ok_sigma nac.
unfold NAC in nac.
destruct (not_and_or _ _ nac) as [not_wf_up | nac_1].
Case "not uniquepath left".
  eauto using nonamb_core_necessary_not_uniquepath_left.
destruct (not_and_or _ _ nac_1) as [not_wf_up | nac_2].
Case "not uniquepath relsub".
 eauto using nonamb_core_necessary_not_uniquepath_right.
destruct (not_and_or _ _ nac_2) as [not_wf_to_unique_pair | nac_3].
 clear nac nac_1 nac_2.
Case "not to uniquepair".
 destruct (non_unique_pair_witness _ _ ok_sigma not_wf_to_unique_pair) as [t [t1 [t2 [s1 [s2 [m [m' [C_m [C_m' diseqs]]]]]]]]].
 pick fresh x.
 exists ([(x, t)]).
 exists (exp_proj One (exp_fvar x)).
 exists (exp_proj One (coerce m (exp_fvar x))).
 exists (exp_proj One (coerce m' (exp_fvar x))).
 exists t1. exists s1.
 split.
 SCase "nd_typing 1". eauto.
 split.
 SCase "nd_typing 2". eauto.
 left.
 destruct diseqs as [m_neq_m' [m_neq_id | m'_neq_id]].
 SSCase "m_neq_id".
 rewrite (coerce_non_identity m (exp_fvar x) m_neq_id).
 destruct (coerce_disjunct m' (exp_fvar x)) as [eq_id | eq_app].
   rewrite eq_id. discriminate.
   rewrite eq_app. injection; eauto.
 SSCase "m'_neq_id".
 rewrite (coerce_non_identity m' (exp_fvar x) m'_neq_id).
 destruct (coerce_disjunct m (exp_fvar x)) as [eq_id | eq_app].
   rewrite eq_id. discriminate.
   rewrite eq_app. injection; eauto.
Case "not unique app".
 clear - nac_3 case ok_sigma.
 destruct (non_nac_app_witness _ _ _ nac_3) as [t [t1 [t2 [s1 [s2 [t' [m1 [m2 [m3 [m4 [cgen_f_1 [cgen_f_2 [cgen_3 [cgen_4 neq_disj]]]]]]]]]]]]]].
 pick fresh f.
 pick fresh x.
 exists ([(f, t)] ++ [(x,t')]).
 exists (exp_app (exp_fvar f) (exp_fvar x)).
 exists (exp_app (coerce m1 (exp_fvar f)) (coerce m3 (exp_fvar x))).
 exists (exp_app (coerce m2 (exp_fvar f)) (coerce m4 (exp_fvar x))).
 exists t2.
 exists s2.
 split.
 SCase "nd_typing 1".
   eapply nd_typing_App; eauto.
 split.
 SCase "nd_typing 2".
   eapply nd_typing_App; eauto.
 SCase "neq".
   destruct neq_disj as [t1_neq_s1 | t2_neq_s2].
   SSCase "t1_neq_s1".
   clear cgen_3 cgen_4.
   left.
   assert (m1 <> m2).
     assert ((typ_fun t1 t2) <> (typ_fun s1 s2)) as fun_neq.
       injection; intros. eauto.
     unfold coerciongen in cgen_f_1.
     unfold coerciongen in cgen_f_2.
     eapply (coercion_between_distinct_types sigma ([t]) ([t])); eauto.
     assert (~((t=(typ_fun t1 t2)) /\ (t=(typ_fun s1 s2)))) as not_t_eq_both.
       unfold not; intros eq_both.
       destruct eq_both as [eql eqr].
         subst t. injection eqr. intros; eauto.
     destruct (not_and_or _ _ not_t_eq_both) as [t_neq_t1t2 | t_neq_s1s2].
     SSSCase "t_neq_t1t2".
       assert ((coerce m1 (exp_fvar f)) = (exp_app m1 (exp_fvar f))) as cm1_eq.
       eapply coerce_non_identity.
         unfold coerciongen in cgen_f_1.
         eauto using inequality_implies_nonidentity.
       rewrite cm1_eq.
       destruct (coerce_disjunct m2 (exp_fvar f)) as [cm2l | cm2r].
       rewrite cm2l. discriminate.
       rewrite cm2r. injection; intros; eauto.
     SSSCase "t_neq_s1s2".
       assert ((coerce m2 (exp_fvar f)) = (exp_app m2 (exp_fvar f))) as cm2_eq.
       eapply coerce_non_identity.
         unfold coerciongen in cgen_f_2.
         eauto using inequality_implies_nonidentity.
       rewrite cm2_eq.
       destruct (coerce_disjunct m1 (exp_fvar f)) as [cm1l | cm1r].
       rewrite cm1l. discriminate.
       rewrite cm1r. injection; intros; eauto.
   SSCase "t2_neq_s2".
     right; eauto.
Qed.


(* This file is generated by Why3's Coq 8.4 driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Import ZOdiv.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.ComputerDivision.
Require map.Map.

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Inductive ref (a:Type) {a_WT:WhyType a} :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a] [a_WT]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a} (v:(@ref a a_WT)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 assumption *)
Inductive array
  (a:Type) {a_WT:WhyType a} :=
  | mk_array : Z -> (@map.Map.map Z _ a a_WT) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a] [a_WT]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(@array a a_WT)): (@map.Map.map
  Z _ a a_WT) := match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a} (v:(@array a a_WT)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(@array a a_WT)) (i:Z): a :=
  (map.Map.get (elts a1) i).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(@array a a_WT)) (i:Z)
  (v:a): (@array a a_WT) := (mk_array (length a1) (map.Map.set (elts a1) i
  v)).

(* Why3 assumption *)
Definition make {a:Type} {a_WT:WhyType a} (n:Z) (v:a): (@array a a_WT) :=
  (mk_array n (map.Map.const v:(@map.Map.map Z _ a a_WT))).

(* Why3 assumption *)
Definition container := (@map.Map.map Z _ Z _).

Parameter sum: (@map.Map.map Z _ Z _) -> Z -> Z -> Z.

Axiom Sum_def_empty : forall (c:(@map.Map.map Z _ Z _)) (i:Z) (j:Z),
  (j <= i)%Z -> ((sum c i j) = 0%Z).

Axiom Sum_def_non_empty : forall (c:(@map.Map.map Z _ Z _)) (i:Z) (j:Z),
  (i < j)%Z -> ((sum c i j) = ((map.Map.get c i) + (sum c (i + 1%Z)%Z j))%Z).

Axiom Sum_right_extension : forall (c:(@map.Map.map Z _ Z _)) (i:Z) (j:Z),
  (i < j)%Z -> ((sum c i j) = ((sum c i (j - 1%Z)%Z) + (map.Map.get c
  (j - 1%Z)%Z))%Z).

Axiom Sum_transitivity : forall (c:(@map.Map.map Z _ Z _)) (i:Z) (k:Z) (j:Z),
  ((i <= k)%Z /\ (k <= j)%Z) -> ((sum c i j) = ((sum c i k) + (sum c k
  j))%Z).

Axiom Sum_eq : forall (c1:(@map.Map.map Z _ Z _)) (c2:(@map.Map.map Z _ Z _))
  (i:Z) (j:Z), (forall (k:Z), ((i <= k)%Z /\ (k < j)%Z) -> ((map.Map.get c1
  k) = (map.Map.get c2 k))) -> ((sum c1 i j) = (sum c2 i j)).

(* Why3 assumption *)
Definition sum1 (a:(@array Z _)) (l:Z) (h:Z): Z := (sum (elts a) l h).

(* Why3 assumption *)
Definition maxsublo (a:(@array Z _)) (maxlo:Z) (s:Z): Prop := forall (l:Z)
  (h:Z), ((0%Z <= l)%Z /\ (l < maxlo)%Z) -> (((l <= h)%Z /\
  (h <= (length a))%Z) -> ((sum1 a l h) <= s)%Z).

(* Why3 assumption *)
Definition maxsub (a:(@array Z _)) (s:Z): Prop := forall (l:Z) (h:Z),
  ((0%Z <= l)%Z /\ ((l <= h)%Z /\ (h <= (length a))%Z)) -> ((sum1 a l
  h) <= s)%Z.

(* Why3 goal *)
Theorem WP_parameter_maximum_subarray_rec : forall (a:Z) (a1:(@map.Map.map
  Z _ Z _)) (l:Z) (h:Z), ((0%Z <= a)%Z /\ ((0%Z <= l)%Z /\ ((l <= h)%Z /\
  (h <= a)%Z))) -> ((~ (h = l)) -> let mid :=
  (l + (ZOdiv (h - l)%Z 2%Z))%Z in forall (lo:Z), (lo = mid) ->
  forall (hi:Z), (hi = mid) -> ((l <= (mid - 1%Z)%Z)%Z -> forall (s:Z) (ms:Z)
  (lo1:Z), ((((l <= lo1)%Z /\ ((lo1 <= mid)%Z /\ (mid = hi))) /\
  (ms = (sum a1 lo1 hi))) /\ ((forall (l':Z), (((l - 1%Z)%Z < l')%Z /\
  (l' <= mid)%Z) -> ((sum a1 l' mid) <= ms)%Z) /\ (s = (sum a1
  ((l - 1%Z)%Z + 1%Z)%Z mid)))) -> ((forall (l':Z), ((l <= l')%Z /\
  (l' <= mid)%Z) -> ((sum a1 l' mid) <= (sum a1 lo1 mid))%Z) ->
  forall (s1:Z), (s1 = ms) -> let o := (h - 1%Z)%Z in ((mid <= o)%Z ->
  forall (s2:Z) (ms1:Z) (hi1:Z), forall (i:Z), ((mid <= i)%Z /\
  (i <= o)%Z) -> (((((l <= lo1)%Z /\ ((lo1 <= mid)%Z /\ ((mid <= hi1)%Z /\
  (hi1 <= h)%Z))) /\ (ms1 = (sum a1 lo1 hi1))) /\ ((forall (l':Z) (h':Z),
  ((l <= l')%Z /\ ((l' <= mid)%Z /\ ((mid <= h')%Z /\ (h' <= i)%Z))) ->
  ((sum a1 l' h') <= ms1)%Z) /\ (s2 = (sum a1 lo1 i)))) -> (((0%Z <= i)%Z /\
  (i < a)%Z) -> forall (s3:Z), (s3 = (s2 + (map.Map.get a1 i))%Z) ->
  ((s3 = (sum a1 lo1 (i + 1%Z)%Z)) -> ((s3 = ((sum a1 lo1 mid) + (sum a1 mid
  (i + 1%Z)%Z))%Z) -> ((ms1 < s3)%Z -> forall (ms2:Z), (ms2 = s3) ->
  forall (hi2:Z), (hi2 = (i + 1%Z)%Z) -> forall (l':Z) (h':Z),
  ((l <= l')%Z /\ ((l' <= mid)%Z /\ ((mid <= h')%Z /\
  (h' <= (i + 1%Z)%Z)%Z))) -> ((sum a1 l' h') <= ms2)%Z))))))))).
intros a a1 l h (h1,(h2,(h3,h4))) h5 mid lo h6 hi h7 h8 s ms lo1
        (((h9,(h10,h11)),h12),(h13,h14)) h15 s1 h16 o h17 s2 ms1 hi1 i
        (h18,h19) (((h20,(h21,(h22,h23))),h24),(h25,h26)) (h27,h28) s3 h29
        h30 h31 h32 ms2 h33 hi2 h34 l' h' (h35,(h36,(h37,h38))).
destruct (Z_le_dec h' i).
apply Zle_trans with ms1.
apply h25.
omega.
omega.
assert (h' = i + 1)%Z by omega.
rewrite H.
rewrite Sum_right_extension by omega.
rewrite h33, h29.
replace (i + 1 - 1)%Z with i by ring.
apply Zplus_le_compat_r.
rewrite h26.
rewrite Sum_transitivity with (k := mid).
rewrite Sum_transitivity with (i := lo1) (k := mid).
apply Zplus_le_compat_r.
apply h15.
omega.
omega.
omega.
Qed.


Require Import Coq.Classes.Morphisms Coq.Setoids.Setoid.
Require Import Coq.Structures.Equalities.
Require Import Coq.Structures.Orders.
Require Import Crypto.Util.Structures.Orders.
Require Import Crypto.Util.Structures.Equalities.Iso.
Require Import Crypto.Util.GlobalSettings.
Require Import Crypto.Util.FixCoqMistakes.

Local Set Implicit Arguments.

Module Type IsSectLt (E : EqLt) (Import T:EqLt) (Import I : HasIso E T).
  Axiom Proper_to_lt : Proper (lt ==> E.lt) to_.
End IsSectLt.

Module Type IsRetrLt (E : EqLt) (Import T:EqLt) (Import I : HasIso E T).
  Axiom Proper_of_lt : Proper (E.lt ==> lt) of_.
End IsRetrLt.

Module Type IsIsoLt (E : EqLt) (T:EqLt) (I : HasIso E T) := Nop <+ IsSectLt E T I <+ IsRetrLt E T I.

Module Type IsSectLe (E : EqLe) (Import T:EqLe) (Import I : HasIso E T).
  Axiom Proper_to_le : Proper (le ==> E.le) to_.
End IsSectLe.

Module Type IsRetrLe (E : EqLe) (Import T:EqLe) (Import I : HasIso E T).
  Axiom Proper_of_le : Proper (E.le ==> le) of_.
End IsRetrLe.

Module Type IsIsoLe (E : EqLe) (T:EqLe) (I : HasIso E T) := Nop <+ IsSectLe E T I <+ IsRetrLe E T I.

Module Type IsoEqLt (E : EqLt) := EqLt <+ HasIso E <+ IsIso E <+ IsIsoLt E.
Module Type IsoEqLe (E : EqLe) := EqLe <+ HasIso E <+ IsIso E <+ IsIsoLe E.
Module Type IsoEqLtLe (E : EqLtLe) := EqLtLe <+ HasIso E <+ IsIso E <+ IsIsoLt E <+ IsIsoLe E.
Module Type IsoEqLt' (E : EqLt) := EqLt' <+ HasIso E <+ IsIso E <+ IsIsoLt E.
Module Type IsoEqLe' (E : EqLe) := EqLe' <+ HasIso E <+ IsIso E <+ IsIsoLe E.
Module Type IsoEqLtLe' (E : EqLtLe) := EqLtLe' <+ HasIso E <+ IsIso E <+ IsIsoLt E <+ IsIsoLe E.
Module Type IsoStrOrder (E : EqLt) := StrOrder <+ HasIso E <+ IsIso E <+ IsIsoLt E.
Module Type IsoStrOrder' (E : EqLt) := StrOrder' <+ HasIso E <+ IsIso E <+ IsIsoLt E.
Module Type IsoDecStrOrder (E : EqLt) := DecStrOrder <+ HasIso E <+ IsIso E <+ IsIsoLt E.
Module Type IsoDecStrOrder' (E : EqLt) := DecStrOrder' <+ HasIso E <+ IsIso E <+ IsIsoLt E.
Module Type IsoOrderedType (E : EqLt) := Orders.OrderedType <+ HasIso E <+ IsIso E <+ IsIsoLt E.
Module Type IsoOrderedType' (E : EqLt) := OrderedType' <+ HasIso E <+ IsIso E <+ IsIsoLt E.
Module Type IsoOrderedTypeFull (E : EqLt) := OrderedTypeFull <+ HasIso E <+ IsIso E <+ IsIsoLt E.
Module Type IsoOrderedTypeFull' (E : EqLt) := OrderedTypeFull' <+ HasIso E <+ IsIso E <+ IsIsoLt E.

Module Type IsoMiniOrderedType (E : EqLt) := MiniOrderedType <+ HasIso E <+ IsIso E <+ IsIsoLt E.
Module Type IsoOrderedTypeOrig (E : EqLt) := OrderedTypeOrig <+ HasIso E <+ IsIso E <+ IsIsoLt E.
Module Type IsoUsualMiniOrderedType (E : UsualEqLt) := UsualMiniOrderedType <+ HasIso E <+ IsIso E <+ IsIsoLt E.
Module Type IsoUsualOrderedTypeOrig (E : UsualEqLt) := UsualOrderedTypeOrig <+ HasIso E <+ IsIso E <+ IsIsoLt E.

Module LiftIsoHasLt (E : EqLt) (Import I : Iso.Iso E) <: HasLt I.
  Definition lt : relation t := fun x y => E.lt (to_ x) (to_ y).
End LiftIsoHasLt.

Module LiftIsoHasLe (E : EqLe) (Import I : Iso.Iso E) <: HasLe I.
  Definition le : relation t := fun x y => E.le (to_ x) (to_ y).
End LiftIsoHasLe.

Module LiftSectIsLt (E : EqLt) (Import I : Iso.Iso E).
  Module Import _LiftSectIsLt.
    Module Import I' := LiftIsoHasLt E I.
  End _LiftSectIsLt.
  Global Instance Proper_to_lt : Proper (I'.lt ==> E.lt) I.to_ | 5.
  Proof. cbv; intros *; exact id. Qed.
End LiftSectIsLt.

Module LiftRetrIsLt (E : StrOrder) (Import I : IsoEqualityType E).
  Module Import _LiftRetrIsLt.
    Module Import I' := LiftIsoHasLt E I.
  End _LiftRetrIsLt.
  Global Instance Proper_of_lt : Proper (E.lt ==> I'.lt) I.of_ | 5.
  Proof. cbv; intros *. rewrite !I.to_of. exact id. Qed.
End LiftRetrIsLt.

Module LiftUsualRetrIsLt (E : UsualEqLt) (Import I : IsoEqualityType E).
  Module Import _LiftRetrIsLt.
    Module Import I' := LiftIsoHasLt E I.
  End _LiftRetrIsLt.
  Global Instance Proper_of_lt : Proper (E.lt ==> I'.lt) I.of_ | 5.
  Proof. cbv; intros *. rewrite !I.to_of. exact id. Qed.
End LiftUsualRetrIsLt.

Module LiftIsoLtTrans (E : MiniOrderedType) (Import I : Iso.Iso E).
  Module Import _LiftSectLtTrans.
    Module Import I' := LiftIsoHasLt E I.
  End _LiftSectLtTrans.
  Lemma lt_trans : forall x y z : I.t, I'.lt x y -> I'.lt y z -> I'.lt x z.
  Proof. cbv; intros *; apply E.lt_trans. Qed.
End LiftIsoLtTrans.

Module LiftIsoLtNotEq (E : MiniOrderedType) (Import I : SectEqualityType E).
  Module Import _LiftSectLtNotEq.
    Module Import I' := LiftIsoHasLt E I.
  End _LiftSectLtNotEq.
  Lemma lt_not_eq : forall x y : t, I'.lt x y -> ~ I.eq x y.
  Proof. cbv; intros * H H'; apply E.lt_not_eq in H; apply H. f_equiv; assumption. Qed.
End LiftIsoLtNotEq.

Module LiftSectCompareOrig (E : MiniOrderedType) (Import I : SectEqualityType E).
  Module Import _LiftSectCompareOrig.
    Module Import I' := LiftIsoHasLt E I.
  End _LiftSectCompareOrig.
  Definition compare : forall x y : t, OrderedType.Compare I'.lt I.eq x y.
  Proof.
    intros x y.
    destruct (E.compare (to_ x) (to_ y)) as [H|H|H]; try (constructor; assumption).
    apply Proper_of_ in H.
    rewrite !of_to in H.
    constructor; assumption.
  Defined.
End LiftSectCompareOrig.

Module LiftSectHasMiniOrderedType (E : MiniOrderedType) (I : SectEqualityType E) := LiftIsoLtTrans E I <+ LiftIsoLtNotEq E I <+ LiftSectCompareOrig E I.

Module Type SectEqLt (E : EqLt) := EqLt <+ HasIso E <+ IsSect E <+ IsSectLt E.
Module Type SectEqLe (E : EqLe) := EqLe <+ HasIso E <+ IsSect E <+ IsSectLe E.
Module Type SectEqLtLe (E : EqLtLe) := EqLtLe <+ HasIso E <+ IsSect E <+ IsSectLt E <+ IsSectLe E.
Module Type SectEqLt' (E : EqLt) := EqLt' <+ HasIso E <+ IsSect E <+ IsSectLt E.
Module Type SectEqLe' (E : EqLe) := EqLe' <+ HasIso E <+ IsSect E <+ IsSectLe E.
Module Type SectEqLtLe' (E : EqLtLe) := EqLtLe' <+ HasIso E <+ IsSect E <+ IsSectLt E <+ IsSectLe E.
Module Type SectStrOrder (E : EqLt) := StrOrder <+ HasIso E <+ IsSect E <+ IsSectLt E.
Module Type SectStrOrder' (E : EqLt) := StrOrder' <+ HasIso E <+ IsSect E <+ IsSectLt E.
Module Type SectDecStrOrder (E : EqLt) := DecStrOrder <+ HasIso E <+ IsSect E <+ IsSectLt E.
Module Type SectDecStrOrder' (E : EqLt) := DecStrOrder' <+ HasIso E <+ IsSect E <+ IsSectLt E.
Module Type SectOrderedType (E : EqLt) := Orders.OrderedType <+ HasIso E <+ IsSect E <+ IsSectLt E.
Module Type SectOrderedType' (E : EqLt) := OrderedType' <+ HasIso E <+ IsSect E <+ IsSectLt E.
Module Type SectOrderedTypeFull (E : EqLt) := OrderedTypeFull <+ HasIso E <+ IsSect E <+ IsSectLt E.
Module Type SectOrderedTypeFull' (E : EqLt) := OrderedTypeFull' <+ HasIso E <+ IsSect E <+ IsSectLt E.

Module Type SectMiniOrderedType (E : EqLt) := MiniOrderedType <+ HasIso E <+ IsSect E <+ IsSectLt E.
Module Type SectOrderedTypeOrig (E : EqLt) := OrderedTypeOrig <+ HasIso E <+ IsSect E <+ IsSectLt E.
Module Type SectUsualMiniOrderedType (E : UsualEqLt) := UsualMiniOrderedType <+ HasIso E <+ IsSect E <+ IsSectLt E.
Module Type SectUsualOrderedTypeOrig (E : UsualEqLt) := UsualOrderedTypeOrig <+ HasIso E <+ IsSect E <+ IsSectLt E.

Module Type RetrEqLt (E : EqLt) := EqLt <+ HasIso E <+ IsRetr E <+ IsRetrLt E.
Module Type RetrEqLe (E : EqLe) := EqLe <+ HasIso E <+ IsRetr E <+ IsRetrLe E.
Module Type RetrEqLtLe (E : EqLtLe) := EqLtLe <+ HasIso E <+ IsRetr E <+ IsRetrLt E <+ IsRetrLe E.
Module Type RetrEqLt' (E : EqLt) := EqLt' <+ HasIso E <+ IsRetr E <+ IsRetrLt E.
Module Type RetrEqLe' (E : EqLe) := EqLe' <+ HasIso E <+ IsRetr E <+ IsRetrLe E.
Module Type RetrEqLtLe' (E : EqLtLe) := EqLtLe' <+ HasIso E <+ IsRetr E <+ IsRetrLt E <+ IsRetrLe E.
Module Type RetrStrOrder (E : EqLt) := StrOrder <+ HasIso E <+ IsRetr E <+ IsRetrLt E.
Module Type RetrStrOrder' (E : EqLt) := StrOrder' <+ HasIso E <+ IsRetr E <+ IsRetrLt E.
Module Type RetrDecStrOrder (E : EqLt) := DecStrOrder <+ HasIso E <+ IsRetr E <+ IsRetrLt E.
Module Type RetrDecStrOrder' (E : EqLt) := DecStrOrder' <+ HasIso E <+ IsRetr E <+ IsRetrLt E.
Module Type RetrOrderedType (E : EqLt) := Orders.OrderedType <+ HasIso E <+ IsRetr E <+ IsRetrLt E.
Module Type RetrOrderedType' (E : EqLt) := OrderedType' <+ HasIso E <+ IsRetr E <+ IsRetrLt E.
Module Type RetrOrderedTypeFull (E : EqLt) := OrderedTypeFull <+ HasIso E <+ IsRetr E <+ IsRetrLt E.
Module Type RetrOrderedTypeFull' (E : EqLt) := OrderedTypeFull' <+ HasIso E <+ IsRetr E <+ IsRetrLt E.

Module Type RetrMiniOrderedType (E : EqLt) := MiniOrderedType <+ HasIso E <+ IsRetr E <+ IsRetrLt E.
Module Type RetrOrderedTypeOrig (E : EqLt) := OrderedTypeOrig <+ HasIso E <+ IsRetr E <+ IsRetrLt E.
Module Type RetrUsualMiniOrderedType (E : UsualEqLt) := UsualMiniOrderedType <+ HasIso E <+ IsRetr E <+ IsRetrLt E.
Module Type RetrUsualOrderedTypeOrig (E : UsualEqLt) := UsualOrderedTypeOrig <+ HasIso E <+ IsRetr E <+ IsRetrLt E.