(** * IndistRelations.v: indistinguishability relation for annotated programs *)
Require FFun.
Require Export DEX_BigStepAnnot.
Require Export Annotated.

Open Scope type_scope.

Import DEX_BigStepAnnot.DEX_BigStepAnnot DEX_BigStep.DEX_BigStep DEX_Dom DEX_Prog.

Inductive Value_in  (b b':FFun.t DEX_Location) : DEX_value -> DEX_value -> Prop :=
| Value_in_null: Value_in b b' Null Null
| Value_in_num: forall n,
  Value_in b b' (Num n) (Num n)
| Value_in_ref: forall loc loc' n,
  FFun.lookup b n = Some loc ->
  FFun.lookup b' n = Some loc' ->
  Value_in b b' (Ref loc) (Ref loc').

Inductive Value_in_opt (b b':FFun.t DEX_Location) :
  option DEX_value -> option DEX_value -> Prop :=
| Value_in_opt_some:
  forall v v',
    Value_in b b' v v' ->
    Value_in_opt b b' (Some v) (Some v')
| Value_in_opt_none: Value_in_opt b b' None None.

Inductive Reg_in (observable:L.t) (b b':FFun.t DEX_Location)
  (r r': DEX_Registers.t) (rt rt': TypeRegisters) (rn:DEX_Reg) : Prop :=
| Reg_high_in : forall k k', MapList.get rt rn = Some k -> MapList.get rt' rn = Some k' ->
    ~(L.leql k observable) -> ~(L.leql k' observable) ->
    Reg_in observable b b' r r' rt rt' rn
| Reg_nhigh_in : Value_in_opt b b' (DEX_Registers.get r rn) (DEX_Registers.get r' rn)
    -> Reg_in observable b b' r r' rt rt' rn.

Inductive Regs_in (observable:L.t) (b b':FFun.t DEX_Location)
  (r r': DEX_Registers.t) (rt rt': TypeRegisters) : Prop :=
| Build_Regs_in : eq_set (MapList.dom rt) (MapList.dom rt') ->
  (forall (rn:DEX_Reg), Reg_in observable b b' r r' rt rt' rn) ->
  Regs_in observable b b' r r' rt rt'.

Definition ffun_heap_compat (b:FFun.t DEX_Location) (h:DEX_Heap.t) : Prop :=
  forall loc, FFun.image b loc -> DEX_Heap.typeof h loc <> None.

Record hp_in (observable:L.t) (ft:DEX_FieldSignature -> L.t)
    (b b': FFun.t DEX_Location) (h h': DEX_Heap.t) : Prop :=
  make_hp_in {
    object_in : forall n loc loc' f cn cn',
      FFun.lookup b n = Some loc ->
      FFun.lookup b' n = Some loc' ->
      DEX_Heap.typeof h loc = Some (DEX_Heap.DEX_LocationObject cn) ->
      DEX_Heap.typeof h' loc' = Some (DEX_Heap.DEX_LocationObject cn') ->
      L.leql (ft f) observable->
      Value_in_opt b b'
      (DEX_Heap.get h (DEX_Heap.DEX_DynamicField loc f))
      (DEX_Heap.get h' (DEX_Heap.DEX_DynamicField loc' f));
    class_object_in : forall n loc loc',
      FFun.lookup b n = Some loc ->
      FFun.lookup b' n = Some loc' ->
      DEX_Heap.typeof h loc = DEX_Heap.typeof h' loc';
    compat_ffun : FFun.compat b b';
(*     static_heap_in : True; *)
    left_inj : FFun.is_inj b;
    right_inj : FFun.is_inj b';
    left_heap_compat : ffun_heap_compat b h;
    right_heap_compat : ffun_heap_compat b' h'
  }.

Inductive st_in (observable:L.t) (ft:DEX_FieldSignature -> L.t) (b b':FFun.t DEX_Location)
    (rt rt':TypeRegisters) :
  DEX_PC * DEX_Heap.t * DEX_Registers.t ->
  DEX_PC * DEX_Heap.t * DEX_Registers.t -> Prop :=
| Build_st_in: forall pc pc' h h' r r',
    Regs_in observable b b' r r' rt rt' ->
    hp_in observable ft b b' h h' ->
    st_in observable ft b b' rt rt' (pc,h,r) (pc',h',r').

Inductive indist_return_value (observable:L.t) (h1 h2:DEX_Heap.t) (s:DEX_sign) :
    DEX_ReturnVal -> DEX_ReturnVal -> FFun.t DEX_Location -> FFun.t DEX_Location -> Prop :=
| indist_return_val : forall v1 v2 b1 b2 k,
  s.(DEX_resType) = Some k ->
  (L.leql k observable -> Value_in b1 b2 v1 v2) ->
  indist_return_value observable h1 h2 s (Normal (Some v1)) (Normal (Some v2)) b1 b2
| indist_return_void : forall b1 b2,
  s.(DEX_resType) = None ->
  indist_return_value observable h1 h2 s (Normal None) (Normal None) b1 b2.

Inductive high_result (observable:L.t) (s:DEX_sign) : DEX_ReturnState -> Prop :=
| high_result_void : forall h,
  s.(DEX_resType) = None ->
  high_result observable s (h, Normal None)
| high_result_value : forall h v k,
  s.(DEX_resType) = Some k ->
  ~ L.leql k observable ->
  high_result observable s (h, Normal (Some v)).

Inductive state : Type :=
  intra : DEX_IntraNormalState -> TypeRegisters -> FFun.t DEX_Location -> state
| ret : DEX_Heap.t -> DEX_ReturnVal -> FFun.t DEX_Location -> state.

Inductive indist (observable:L.t) (p:DEX_ExtendedProgram) (m:DEX_Method)
  (sgn:DEX_sign) : state -> state -> Prop :=
| indist_intra : forall pc pc' h h' r r' rt rt' b b',
  st_in observable (DEX_ft p) b b' rt rt' (pc,h,r) (pc',h',r') ->
  indist observable p m sgn (intra (pc,(h,r)) rt b) (intra (pc',(h',r')) rt' b')
| indist_return : forall b b' h h' v v',
  indist_return_value observable h h' sgn v v' b b' ->
  indist observable p m sgn (ret h v b) (ret h' v' b').

 (** Indistinguishability relations *)

Section p.
  Variable kobs : L.t.
  Variable p : DEX_ExtendedProgram.
  Notation ft := (DEX_ft p).

 (** Basic results on indistinguishability relations *)

  Lemma Value_in_sym : forall v1 v2 b1 b2,
    Value_in b1 b2 v1 v2 ->
    Value_in b2 b1 v2 v1.
  Proof.
    intros.
    inversion_clear H; try constructor.
    constructor 3 with n; auto.
  Qed.

  Lemma Value_in_opt_sym : forall b1 b2 v1 v2,
    Value_in_opt b1 b2 v1 v2 ->
    Value_in_opt b2 b1 v2 v1.
  Proof.
    intros.
    inversion_clear H; try constructor.
    apply Value_in_sym; auto.
  Qed.

  Lemma Value_in_trans : forall b1 b2 b3 v1 v2 v3,
    FFun.is_inj b2 ->
    Value_in b1 b2 v1 v2 ->
    Value_in b2 b3 v2 v3 ->
    Value_in b1 b3 v1 v3.
  Proof.
    intros.
    inversion_clear H0 in H1; inversion_clear H1; try constructor.
    rewrite <- (H _ _ _ H3 H0) in H4.
    constructor 3 with n; auto.
  Qed.

  Lemma Value_in_opt_trans : forall b1 b2 b3 v1 v2 v3,
    FFun.is_inj b2 ->
    Value_in_opt b1 b2 v1 v2->
    Value_in_opt b2 b3 v2 v3 ->
    Value_in_opt b1 b3 v1 v3.
  Proof.
    intros.
    inversion_clear H0 in H1; inversion_clear H1; try constructor.
    eapply Value_in_trans; eauto.
  Qed.

  Lemma leql_join1 : forall k1 k2 k3,
    L.leql k2 k3 ->
    L.leql k2 (L.join k1 k3).
  Proof.
    intros.
    apply L.leql_trans with (1:=H).
    apply L.join_right.
  Qed.

  Lemma leql_join2 : forall k1 k2 k3,
    L.leql k2 k1 ->
    L.leql k2 (L.join k1 k3).
  Proof.
    intros.
    apply L.leql_trans with (1:=H).
    apply L.join_left.
  Qed.

  Lemma not_leql_trans : forall k1 k2 k3,
    ~ L.leql k1 k3 ->
    L.leql k1 k2 ->
    ~ L.leql k2 k3.
  Proof.
    red; intros.
    elim H.
    apply L.leql_trans with (1:=H0); auto.
  Qed.

  Lemma not_leql_join1 : forall k1 k2 k3,
    ~ L.leql k1 k3 ->
    ~ L.leql (L.join k1 k2) k3.
  Proof.
    intros; apply not_leql_trans with k1; auto.
    apply L.join_left.
  Qed.

  Lemma not_leql_join2 : forall k1 k2 k3,
    ~ L.leql k2 k3 ->
    ~ L.leql (L.join k1 k2) k3.
  Proof.
    intros; apply not_leql_trans with k2; auto.
    apply L.join_right.
  Qed.

  Lemma leql_join_each: forall k k1 k2, L.leql (L.join k k1) k2 -> L.leql k k2 /\ L.leql k1 k2.
  Proof. intros.
    split. apply L.leql_trans with (l2:=L.join k k1); auto. apply L.join_left.
    apply L.leql_trans with (l2:=L.join k k1); auto. apply L.join_right.
  Qed.

  Lemma Reg_in_sym : forall obs b b' r r' rt rt' rn,
    Reg_in obs b b' r r' rt rt' rn ->
    Reg_in obs b' b r' r rt' rt rn.
  Proof.
    intros.
    inversion H.
      constructor 1 with (k:=k') (k':=k); auto.
      constructor 2; auto.
      apply Value_in_opt_sym; auto.
  Qed.

 Lemma Regs_in_sym : forall b1 b2 r1 r2 rt1 rt2,
    Regs_in kobs b1 b2 r1 r2 rt1 rt2 ->
    Regs_in kobs b2 b1 r2 r1 rt2 rt1.
  Proof.
    induction 1.
    constructor. apply eq_set_sym; auto.
    intros.
    apply Reg_in_sym; auto.
  Qed.

  Lemma hp_in_sym : forall h1 h2 b1 b2,
    hp_in kobs ft b1 b2 h1 h2 -> hp_in kobs ft b2 b1 h2 h1.
  Proof.
    intros.
    destruct H; constructor; auto.
    intros.
    apply Value_in_opt_sym; auto.
    eapply object_in0; eauto.
    intros.
    rewrite (class_object_in0 n loc' loc); auto.
    intros n; generalize (compat_ffun0 n); intuition.
  Qed.

  Lemma st_in_sym : forall b b' rt rt' r r',
    st_in kobs ft b b' rt rt' r r' ->
    st_in kobs ft b' b rt' rt r' r.
  Proof.
    intros.
    inversion_clear H; constructor.
    apply Regs_in_sym; auto.
    apply hp_in_sym; auto.
  Qed.
  Implicit Arguments st_in_sym.

  Lemma hp_in_trans : forall h1 h2 h3 b1 b2 b3,
    hp_in kobs ft b1 b2 h1 h2 ->
    hp_in kobs ft b2 b3 h2 h3 ->
    hp_in kobs ft b1 b3 h1 h3.
  Proof.
    intros.
    destruct H; destruct H0.
    constructor; auto.
    intros.
    destruct (compat_ffun1 n).
    caseeq (FFun.lookup b2 n); intros.
    apply Value_in_opt_trans with
      (v2:=(DEX_Heap.get h2 (DEX_Heap.DEX_DynamicField d f))) (b2:=b2); auto.
    eapply object_in0; eauto.
    rewrite <- (class_object_in0 n loc d); eauto.
    eapply object_in1; eauto.
    rewrite <- (class_object_in0 n loc d); eauto.
    rewrite H4 in H0; auto; discriminate.
    intros.
    destruct (compat_ffun1 n).
    caseeq (FFun.lookup b2 n); intros.
    rewrite (class_object_in0 n loc d); auto.
    rewrite (class_object_in1 n d loc'); auto.
    rewrite H1 in H0; auto; discriminate.
    intros n.
    generalize (compat_ffun0 n);
      generalize (compat_ffun1 n); intuition.
  Qed.

  Lemma Value_in_opt_some_aux: forall b b' ov ov' v v',
    Value_in b b' v v' ->
    ov=(Some v)  ->
    ov'= (Some v') ->
    Value_in_opt b b' ov ov'.
  Proof.
    intros;  subst; constructor; auto.
  Qed.

  Lemma Reg_in_upd_low:
    forall k (v v' : DEX_value) (r r' : DEX_Registers.t) (rt rt' : TypeRegisters)
      (reg : DEX_Reg) (b b': FFun.t DEX_Location),
      Reg_in kobs b b' r r' rt rt' reg ->
      Value_in b b' v v' ->
      L.leql k kobs ->
      Reg_in kobs b b' (DEX_Registers.update r reg v) (DEX_Registers.update r' reg v')
      (MapList.update rt reg k) (MapList.update rt' reg k) reg.
  Proof.
    intros k v v' r r' rt rt' reg b b' HRegIn HValIn Hleq.
    constructor 2. rewrite ?DEX_Registers.get_update_new.
    constructor; auto.
  Qed.

  Lemma Reg_in_upd_high:
    forall k k' (v v' : DEX_value) (r r' : DEX_Registers.t) (rt rt' : TypeRegisters)
      (reg : DEX_Reg) (b b': FFun.t DEX_Location),
      Reg_in kobs b b' r r' rt rt' reg ->
      ~L.leql k kobs ->
      ~L.leql k' kobs ->
      Reg_in kobs b b' (DEX_Registers.update r reg v) (DEX_Registers.update r' reg v')
      (MapList.update rt reg k) (MapList.update rt' reg k') reg.
  Proof.
    intros k k' v v' r r' rt rt' reg b b' HRegIn Hnleq1 Hnleq2.
    constructor 1 with (k:=k) (k':=k'); try (rewrite MapList.get_update1); auto.
  Qed.

  Lemma ffun_extends_val_in: forall b b' v v' loc loc',
    Value_in b b' v v' ->
    Value_in (FFun.extends b loc) (FFun.extends b' loc')
    v v'.
  Proof.
    intros; inversion_clear H; try constructor.
    constructor 3 with n; auto.
    apply FFun.extends_old; auto.
    apply FFun.extends_old; auto.
  Qed.

  Lemma ffun_extends_val_in_opt: forall b b' v v' loc loc',
    Value_in_opt b b' v v' ->
    Value_in_opt (FFun.extends b loc) (FFun.extends b' loc')
    v v'.
  Proof.
    intros; inversion H; subst; try constructor.
    apply ffun_extends_val_in; auto.
  Qed.

  Lemma Value_in_extends_object : forall b1 b2 loc1 loc2 h1 h2,
    ffun_heap_compat b1 h1 ->
    ffun_heap_compat b2 h2 ->
    DEX_Heap.typeof h1 loc1 = None ->
    DEX_Heap.typeof h2 loc2 = None ->
    FFun.compat b1 b2 ->
    Value_in
    (FFun.extends b1 loc1) (FFun.extends b2 loc2)
    (Ref loc1) (Ref loc2) .
  Proof.
    intros.
    constructor 3 with (FFun.next b1); auto.
    apply FFun.extends_new.
    rewrite (FFun.compat_implies_next _ b1 b2); auto.
    apply FFun.extends_new.
  Qed.

  Lemma ffun_extends_Regs_in: forall s s' rt rt' b b' loc loc',
    Regs_in kobs b b' s s' rt rt' ->
    Regs_in kobs (FFun.extends b loc) (FFun.extends b' loc')
    s s' rt rt'.
  Proof.
    intros.
    induction H; intros; auto.
    constructor; auto.
    intros. specialize H0 with rn.
    inversion H0. constructor 1 with (k:=k) (k':=k'); auto.
    constructor 2. apply ffun_extends_val_in_opt; auto.
  Qed.

  Lemma ffun_heap_compat_update : forall h b am v,
    ffun_heap_compat b h ->
    ffun_heap_compat b (DEX_Heap.update h am v).
  Proof.
    unfold ffun_heap_compat; intros.
    rewrite DEX_Heap.typeof_update_same; auto.
  Qed.

  Lemma ffun_heap_compat_extends : forall h c h' b loc,
    ffun_heap_compat b h ->
    DEX_Heap.new h p c = Some (loc,h') ->
    ffun_heap_compat (FFun.extends b loc) h'.
  Proof.
    unfold ffun_heap_compat; intros.
    destruct (DEX_Location_dec loc loc0).
    subst.
    rewrite (@DEX_Heap.new_typeof h p c loc0 h' H0).
    discriminate.
    rewrite (@DEX_Heap.new_typeof_old h p c loc loc0 h' H0); auto.
    apply H.
    destruct H1.
    elim FFun.extends_case with DEX_Location b x loc loc0; auto; intros.
    exists x; auto.
    elim n; intuition.
  Qed.

  Lemma ffun_heap_compat_new : forall h c h' b loc,
    ffun_heap_compat b h ->
    DEX_Heap.new h p c = Some (loc,h') ->
    ffun_heap_compat b h'.
  Proof.
    unfold ffun_heap_compat; intros.
    destruct (DEX_Location_dec loc loc0).
    subst.
    rewrite (@DEX_Heap.new_typeof h p c loc0 h' H0).
    discriminate.
    rewrite (@DEX_Heap.new_typeof_old h p c loc loc0 h' H0); auto.
  Qed.

  Lemma hp_in_putfield_ffun : forall loc loc' b b' h h' f v v' cn cn',
    hp_in kobs ft b b' h h' ->
    Value_in b b' v v' ->
    Value_in b b' (Ref loc) (Ref loc') ->
    DEX_Heap.typeof h loc = Some (DEX_Heap.DEX_LocationObject cn) ->
    DEX_Heap.typeof h' loc' = Some (DEX_Heap.DEX_LocationObject cn') ->
    hp_in kobs ft b b'
    (DEX_Heap.update h (DEX_Heap.DEX_DynamicField loc f) v)
    (DEX_Heap.update h' (DEX_Heap.DEX_DynamicField loc' f) v').
  Proof.
    intros; constructor; auto; intros.

    elim (DEX_Location_dec loc loc0);
      elim (eq_excluded_middle _ f f0); intros; subst.
    rewrite DEX_Heap.get_update_same; auto.
    replace loc'0 with loc'.
    rewrite DEX_Heap.get_update_same; auto.
    constructor; auto.
    constructor 1 with cn'; auto.
    inversion_mine H1.
    apply FFun.inv_aux with n0 n b b' loc0 loc0; auto.
    eapply left_inj; eauto.
    eapply right_inj; eauto.
    constructor 1 with cn; auto.

    rewrite DEX_Heap.get_update_old.
    rewrite DEX_Heap.get_update_old.
    eapply (object_in _ _ _ _ _ _ H); eauto.
    rewrite DEX_Heap.typeof_update_same in H7; eauto.
    intros HH; elim H9; congruence.
    intros HH; elim H9; congruence.

    rewrite DEX_Heap.get_update_old.
    rewrite DEX_Heap.get_update_old.
    eapply (object_in _ _ _ _ _ _ H); eauto.
    rewrite DEX_Heap.typeof_update_same in H6; eauto.
    rewrite DEX_Heap.typeof_update_same in H7; eauto.
    intros HH; injection HH; intros; subst.
    elim b0.
    inversion_mine H1.
    apply (FFun.inv_aux _ n0 n b' b loc'0 loc loc'0 loc0); auto.
    eapply right_inj; eauto.
    eapply left_inj; eauto.
    intros HH; elim b0; congruence.

    rewrite DEX_Heap.get_update_old.
    rewrite DEX_Heap.get_update_old.
    eapply (object_in _ _ _ _ _ _ H); eauto.
    rewrite DEX_Heap.typeof_update_same in H6; eauto.
    rewrite DEX_Heap.typeof_update_same in H7; eauto.
    intros HH; elim b0; congruence.
    intros HH; elim b0; congruence.

    repeat rewrite DEX_Heap.typeof_update_same.
    eapply class_object_in; eauto.
    destruct H; auto.
    destruct H; auto.
    destruct H; auto.
    apply ffun_heap_compat_update; destruct H; auto.
    apply ffun_heap_compat_update; destruct H; auto.
  Qed.

  Lemma hp_in_putfield_high_update_left : forall loc b b' h h' f v cn,
    hp_in kobs ft b b' h h' ->
    ~ (L.leql (ft f) kobs) ->
    DEX_Heap.typeof h loc = Some (DEX_Heap.DEX_LocationObject cn) ->
    hp_in kobs ft b b'
    (DEX_Heap.update h (DEX_Heap.DEX_DynamicField loc f) v) h'.
  Proof.
    intros; constructor; auto; intros.
    assert (f<>f0).
    intro; subst; intuition.
    repeat rewrite DEX_Heap.get_update_old.
    eapply (object_in _ _ _ _ _ _ H); eauto.
    rewrite DEX_Heap.typeof_update_same in H4; eauto.
    intros HH; elim H7; congruence.
    rewrite DEX_Heap.typeof_update_same.
    eapply class_object_in; eauto.
    destruct H; auto.
    destruct H; auto.
    destruct H; auto.
    apply ffun_heap_compat_update; destruct H; auto.
    destruct H; auto.
  Qed.

  Lemma hp_in_putfield_high_update_right : forall loc b b' h h' f v cn,
    hp_in kobs ft b b' h h' ->
    ~ (L.leql (ft f) kobs) ->
    DEX_Heap.typeof h' loc = Some (DEX_Heap.DEX_LocationObject cn) ->
    hp_in kobs ft b b'
    h (DEX_Heap.update h' (DEX_Heap.DEX_DynamicField loc f) v).
  Proof.
    intros.
    apply hp_in_sym.
    eapply hp_in_putfield_high_update_left; eauto.
    apply hp_in_sym; auto.
  Qed.

  Lemma hp_in_putfield_high : forall loc loc' b b' h h' f v v' cn cn',
    hp_in kobs ft b b' h h' ->
    ~ (L.leql (ft f) kobs) ->
    DEX_Heap.typeof h loc = Some (DEX_Heap.DEX_LocationObject cn) ->
    DEX_Heap.typeof h' loc' = Some (DEX_Heap.DEX_LocationObject cn') ->
    hp_in kobs ft b b'
    (DEX_Heap.update h (DEX_Heap.DEX_DynamicField loc f) v)
    (DEX_Heap.update h' (DEX_Heap.DEX_DynamicField loc' f) v').
  Proof.
    intros.
    apply hp_in_putfield_high_update_left with cn; auto.
    apply hp_in_putfield_high_update_right with cn'; auto.
  Qed.

  Lemma Compat_ex : forall h am, DEX_Heap.Compat h am \/ ~ DEX_Heap.Compat h am.
  Proof.
    intros.
    apply excluded_middle.
  Qed.

  Lemma ffun_extends_hp_in: forall c b b' h h' hn hn' loc loc',
    hp_in kobs ft b b' h h' ->
    DEX_Heap.new h p (DEX_Heap.DEX_LocationObject c) = Some (pair loc hn) ->
    DEX_Heap.new h' p (DEX_Heap.DEX_LocationObject c) = Some (pair loc' hn') ->
    hp_in kobs ft (FFun.extends b loc) (FFun.extends b' loc') hn hn'.
  Proof.
    intros.
    inversion_clear H; constructor; intros; try trivial.
    elim FFun.extends_case with DEX_Location b n loc loc0; intros; Cleanand; auto.
    assert (Haux:=FFun.compat_extends _ _ _ _ _ _ _ compat_ffun0 H6 H2).
    apply ffun_extends_val_in_opt.
    rewrite (@DEX_Heap.new_object_no_change h p c loc hn); auto.
    rewrite (@DEX_Heap.new_object_no_change h' p c loc' hn'); auto.

    assert (Hclass:=class_object_in0 _ _ _ H6 Haux).
    elim Compat_ex with h (@DEX_Heap.DEX_DynamicField loc0 f); intros Hcomp.
    inversion_clear Hcomp.
    generalize H7; rewrite Hclass; intros.
    apply object_in0 with n cn0 cn0; auto.
    rewrite (@DEX_Heap.get_uncompat h); auto.
    rewrite (@DEX_Heap.get_uncompat h').
    constructor.
    intros HH; inversion_clear HH.
    elim Hcomp; constructor 1 with cn0.
    rewrite Hclass; auto.
    intros fs Hi; injection Hi; intros; subst.
    elim right_heap_compat0 with loc'.
    exists n; auto.
    apply DEX_Heap.new_fresh_location with (1:=H1).
    intros fs Hi; injection Hi; intros; subst.
    elim left_heap_compat0 with loc.
    exists n; auto.
    apply DEX_Heap.new_fresh_location with (1:=H0).

  (***)

    subst.
    rewrite (FFun.compat_implies_next _ _ _ compat_ffun0) in H2.
    rewrite FFun.extends_new in H2.
    injection H2; clear H2; intros; subst.
    destruct (excluded_middle (defined_field p c f)) as [d|d].
    inversion_clear d.
    rewrite (@DEX_Heap.new_defined_object_field h p c f x loc0 hn); auto.
    rewrite (@DEX_Heap.new_defined_object_field h' p c f x loc'0 hn'); auto.
    constructor.
    unfold init_field_value.
    destruct (DEX_FIELD.initValue x); try constructor.
    unfold init_value.
    destruct DEX_FIELDSIGNATURE.type; constructor.
    rewrite (@DEX_Heap.new_undefined_object_field h p c f loc0 hn); auto.
    rewrite (@DEX_Heap.new_undefined_object_field h' p c f loc'0 hn'); auto.
    constructor.

    elim FFun.extends_case with (1:= H); intros.
    assert (FFun.lookup b' n = Some loc'0).
    apply FFun.compat_extends with b loc0 loc'; auto.
    destruct (DEX_Location_dec loc loc0); destruct (DEX_Location_dec loc' loc'0); subst.
    rewrite (@DEX_Heap.new_typeof h p (DEX_Heap.DEX_LocationObject c) loc0 hn); auto.
    rewrite (@DEX_Heap.new_typeof h' p (DEX_Heap.DEX_LocationObject c) loc'0 hn'); auto.
    assert (T:=@DEX_Heap.new_fresh_location h p (DEX_Heap.DEX_LocationObject c) loc0 hn H0).
    elim (left_heap_compat0 loc0); auto.
    exists n; auto.
    assert (T:=@DEX_Heap.new_fresh_location h' p (DEX_Heap.DEX_LocationObject c) loc'0 hn' H1).
    elim (right_heap_compat0 loc'0); auto.
    exists n; auto.
    rewrite (@DEX_Heap.new_typeof_old h p (DEX_Heap.DEX_LocationObject c) loc loc0 hn); auto.
    rewrite (@DEX_Heap.new_typeof_old h' p (DEX_Heap.DEX_LocationObject c) loc' loc'0 hn'); auto.
    eapply class_object_in0; eauto.
    destruct H3; subst.
    rewrite (@DEX_Heap.new_typeof h p (DEX_Heap.DEX_LocationObject c) loc0 hn); auto.
    rewrite (FFun.compat_implies_next _ _ _ compat_ffun0) in H2.
    rewrite (FFun.extends_new _ b' loc') in H2.
    injection H2; intros; subst.
    rewrite (@DEX_Heap.new_typeof h' p (DEX_Heap.DEX_LocationObject c) loc'0 hn'); auto.
    apply FFun.compat_preserved_by_extends; auto.
    apply FFun.extends_inj; auto.
    intro.
    elim (left_heap_compat0 _ H).
    eapply DEX_Heap.new_fresh_location; eauto.
    apply FFun.extends_inj; auto.
    intro.
    elim (right_heap_compat0 _ H).
    eapply DEX_Heap.new_fresh_location; eauto.
    apply ffun_heap_compat_extends with (2:=H0); auto.
    apply ffun_heap_compat_extends with (2:=H1); auto.
  Qed.

  Lemma ffun_extends_hp_in_new_left: forall c b b' h h' hn loc,
    hp_in kobs ft b b' h h' ->
    DEX_Heap.new h p (DEX_Heap.DEX_LocationObject c) = Some (pair loc hn) ->
    hp_in kobs ft b b' hn h'.
  Proof.
    intros.
    inversion_clear H; constructor; intros; try trivial.
    rewrite (@DEX_Heap.new_object_no_change h p c loc hn); auto.
    assert (Hclass:=class_object_in0 _ _ _ H H1).
    elim Compat_ex with h (DEX_Heap.DEX_DynamicField loc0 f); intros Hcomp.
    inversion_clear Hcomp.
    generalize H5; rewrite Hclass; intros.
    apply object_in0 with n cn0 cn0; auto.
    rewrite (@DEX_Heap.get_uncompat h); auto.
    rewrite (@DEX_Heap.get_uncompat h').
    constructor.
    intros HH; inversion_clear HH.
    elim Hcomp; constructor 1 with cn0.
    rewrite Hclass; auto.
    intros fs Hi; injection Hi; intros; subst.
    elim left_heap_compat0 with loc.
    exists n; auto.
    apply DEX_Heap.new_fresh_location with (1:=H0).

    destruct (DEX_Location_dec loc0 loc); subst.
    rewrite (@DEX_Heap.new_typeof h p (DEX_Heap.DEX_LocationObject c) loc hn); auto.
    elim left_heap_compat0 with loc.
    exists n; auto.
    eapply DEX_Heap.new_fresh_location; eauto.
    rewrite (@DEX_Heap.new_typeof_old h p (DEX_Heap.DEX_LocationObject c) loc loc0 hn); auto.
    eauto.

    repeat intro.
    elim left_heap_compat0 with loc0; auto.
    destruct (DEX_Location_dec loc0 loc); subst.
    rewrite (@DEX_Heap.new_typeof h p (DEX_Heap.DEX_LocationObject c) loc hn) in H1; auto; discriminate.
    rewrite (@DEX_Heap.new_typeof_old h p (DEX_Heap.DEX_LocationObject c) loc loc0 hn) in H1; auto.
  Qed.

  Lemma ffun_extends_hp_in_new_right: forall c b b' h h' hn' loc,
    hp_in kobs ft b b' h h' ->
    DEX_Heap.new h' p (DEX_Heap.DEX_LocationObject c) = Some (pair loc hn') ->
    hp_in kobs ft b b' h hn'.
  Proof.
    intros.
    apply hp_in_sym; eapply ffun_extends_hp_in_new_left; eauto.
    apply hp_in_sym; auto.
  Qed.

  Lemma ffun_extends_hp_in_simpl: forall c c' b b' h h' hn hn' loc loc',
    hp_in kobs ft b b' h h' ->
    DEX_Heap.new h p (DEX_Heap.DEX_LocationObject c) = Some (pair loc hn) ->
    DEX_Heap.new h' p (DEX_Heap.DEX_LocationObject c') = Some (pair loc' hn') ->
    hp_in kobs ft b b' hn hn'.
  Proof.
    intros.
    eapply ffun_extends_hp_in_new_left; eauto.
    eapply ffun_extends_hp_in_new_right; eauto.
  Qed.

  Lemma indist_same_class : forall h1 h2 loc1 loc2 b1 b2,
    hp_in kobs ft b1 b2 h1 h2 ->
    Value_in b1 b2 (Ref loc1) (Ref loc2) ->
    DEX_Heap.typeof h1 loc1 = DEX_Heap.typeof h2 loc2.
  Proof.
    intros.
    inversion_clear H0.
    apply (class_object_in _ _ _ _ _ _ H n) ;auto.
  Qed.

  Lemma ex_comp_Z : forall x y z:Z,
    (x <= y < z \/ ~ x <= y < z)%Z.
  Proof.
    intros.
    destruct (Z_le_dec x y).
    destruct (Z_lt_dec y z); intuition.
    intuition.
  Qed.

  Lemma nth_error_none_length : forall (A:Set) (l:list A) i,
    nth_error l i = None -> (length l <= i)%nat.
  Proof.
    induction l; destruct i; simpl; intros; try omega.
    discriminate.
    generalize (IHl _ H); omega.
  Qed.

  Lemma nth_error_some_length : forall (A:Set) (l:list A) i a,
    nth_error l i = Some a -> (length l > i)%nat.
  Proof.
    induction l; destruct i; simpl; intros; try discriminate; try omega.
    generalize (IHl _ _ H); omega.
  Qed.

  Definition beta_pre_order (b1 b2:FFun.t DEX_Location) : Prop :=
    forall loc n, FFun.lookup b1 n = Some loc -> FFun.lookup b2 n = Some loc.

  Lemma beta_pre_order_value_in: forall v v' b1 b2 b1' b2',
    beta_pre_order b1 b2 ->
    beta_pre_order b1' b2' ->
    Value_in b1 b1' v v'->
    Value_in b2 b2' v v'.
  Proof.
    intros.
    inversion_clear H1; try constructor.
    constructor 3 with n; auto.
  Qed.

  Lemma beta_pre_order_value_in_opt:  forall v v' b1 b2 b1' b2',
    beta_pre_order b1 b2 ->
    beta_pre_order b1' b2' ->
    Value_in_opt b1 b1' v v' ->
    Value_in_opt b2 b2' v v'.
  Proof.
    intros.
    inversion_clear H1; constructor.
    eapply beta_pre_order_value_in; eauto.
  Qed.

  Lemma beta_pre_order_Regs_in:  forall s s' rt rt' b1 b2 b1' b2',
    beta_pre_order b1 b2 ->
    beta_pre_order b1' b2' ->
    Regs_in kobs b1 b1' s s' rt rt' ->
    Regs_in kobs b2 b2' s s' rt rt' .
  Proof.
    induction 3.
    constructor; auto.
    intros; specialize H2 with rn.
    inversion H2.
    constructor 1 with k k'; auto.
    constructor 2; auto.
    eapply beta_pre_order_value_in_opt; eauto.
  Qed.

  Lemma hp_in_getfield : forall b2 b2' v v0 h2 h2' loc loc0 cn cn0 f,
    DEX_Heap.typeof h2 loc = Some (DEX_Heap.DEX_LocationObject cn) ->
    DEX_Heap.get h2 (DEX_Heap.DEX_DynamicField loc f) = Some v ->
    DEX_Heap.typeof h2' loc0 = Some (DEX_Heap.DEX_LocationObject cn0) ->
    DEX_Heap.get h2' (DEX_Heap.DEX_DynamicField loc0 f) = Some v0 ->
    hp_in kobs ft b2 b2' h2 h2' ->
    L.leql (ft f) kobs ->
    Value_in b2 b2' (Ref loc) (Ref loc0) ->
    Value_in b2 b2' v v0.
  Proof.
    intros.
    inversion_clear H5.
    assert (HH:=object_in _ _ _ _ _ _ H3 _ _ _ f cn cn0 H6 H7 H H1 H4).
    rewrite H0 in HH; rewrite H2 in HH.
    inversion_clear HH; auto.
  Qed.

  Lemma Value_in_assign_compatible : forall h1 h2 loc1 loc2 t b1 b2,
    Value_in b1 b2 (Ref loc1) (Ref loc2) ->
    hp_in kobs ft b1 b2 h1 h2 ->
    assign_compatible p h1 (Ref loc1) (DEX_ReferenceType t) ->
    assign_compatible p h2 (Ref loc2) (DEX_ReferenceType t).
  Proof.
    intros.
    generalize (indist_same_class _ _ _ _ _ _ H0 H); intros.
    inversion_mine H1.
    constructor 2 with cn; auto; congruence.
  Qed.

  Lemma Value_in_assign_compatible' : forall h1 h2 v1 v2 t b1 b2,
    Value_in b1 b2 v1 v2 ->
    hp_in kobs ft b1 b2 h1 h2 ->
    assign_compatible p h1 v1 t ->
    assign_compatible p h2 v2 t.
  Proof.
    intros.
    destruct t.
    destruct v1; destruct v2; try (inversion_mine H; inversion_mine H1; fail).
    eapply Value_in_assign_compatible; eauto.
    constructor.
    inversion_mine H; inversion_mine H1; constructor; auto.
  Qed.

  Lemma Value_in_extends : forall b1 b2 loc1 loc2 h1 h2,
    hp_in kobs ft b1 b2 h1 h2 ->
    DEX_Heap.typeof h1 loc1 = None ->
    DEX_Heap.typeof h2 loc2 = None ->
    Value_in
    (FFun.extends b1 loc1) (FFun.extends b2 loc2)
    (Ref loc1) (Ref loc2) .
  Proof.
    intros.
    destruct H.
    eapply Value_in_extends_object; eauto.
  Qed.

(*  Lemma SemCompRef_Value_in : forall cmp v1 v2 v0 v3 b2 b2' h1 h2 ft,
    hp_in kobs ft b2 b2' h1 h2 ->
    DEX_SemCompRef cmp v1 v2 ->
    Value_in b2 b2' v2 v0 ->
    Value_in b2 b2' v1 v3 ->
    SemCompRef cmp v3 v0.
  Proof.
    intros.
    assert (Il:=left_inj _ _ _ _ _ _ _ H).
    assert (Ir:=right_inj _ _ _ _ _ _ _ H).
    inversion_mine H0;
    inversion_mine H1; inversion_mine H2; econstructor; auto;
      try constructor; try discriminate.
    rewrite (FFun.inv_aux Location n n0 b2 b2' loc loc' loc loc'0); auto.
    intro HH; elim H5; inversion_mine HH.
    rewrite (FFun.inv_aux Location n n0 b2' b2 loc' loc loc' loc0); auto.
  Qed. *)

End p.

  Hint Resolve
    not_leql_join1 not_leql_join2 not_leql_trans
    L.join_left L.join_right
    L.leql_trans : lattice.


(** * Facts about Well-defined H-VHDL Designs *)

Require Import common.CoqLib.
Require Import common.proofs.CoqTactics.
Require Import common.InAndNoDup.
Require Import common.proofs.ListPlusFacts.
Require Import common.proofs.ListPlusTactics.

Require Import hvhdl.WellDefinedDesign.
Require Import hvhdl.AbstractSyntax.
Require Import hvhdl.proofs.AbstractSyntaxFacts.

Open Scope abss_scope.
Import HVhdlCsNotations.

(** ** Facts about [AreCsCompIds]  *)

Lemma AreCsCompIds_determ :
  forall cstmt compids compids',
    AreCsCompIds cstmt compids ->
    AreCsCompIds cstmt compids' ->
    compids = compids'.
Proof. intros *; eapply FoldLCs_determ. Qed.

Lemma AreCsCompIds_ex : forall cstmt, exists compids, AreCsCompIds cstmt compids.
Proof. intros; eapply FoldLCs_ex. Qed.

Lemma AreCsCompIds_app1 :
  forall cstmt compids',
    let comp2id :=
        fun (cids : list HVhdlTypes.ident) (cstmt0 : cs) =>
          match cstmt0 with
          | cs_comp id _ _ _ _ => cids ++ [id]
          | _ => cids
          end in
    AreCsCompIds cstmt compids' ->
    forall compids, FoldLCs comp2id cstmt compids (compids ++ compids').
Proof.
  induction cstmt; intros; inversion H;
    try ((rewrite app_nil_r; constructor) || (rewrite app_nil_l; constructor)).
  destruct (AreCsCompIds_ex cstmt2) as (compids2, AreCsCompIds2).
  constructor 4 with (a' := compids ++ a').
  eapply IHcstmt1; eauto.
  erewrite @FoldLCs_determ with (res := compids') (res' := a' ++ compids2); eauto.
  rewrite app_assoc; apply IHcstmt2 with (compids := compids ++ a'); auto.
Qed.

Lemma AreCsCompIds_app :
  forall cstmt cstmt' compids compids',
    AreCsCompIds cstmt compids ->
    AreCsCompIds cstmt' compids' ->
    AreCsCompIds (cs_par cstmt cstmt') (compids ++ compids').
Proof.
  intros; econstructor. eexact H.
  apply AreCsCompIds_app1; auto.
Qed.

Lemma AreCsCompIds_eq_app :
  forall cstmt cstmt' compids compids' compids'',
    AreCsCompIds cstmt compids ->
    AreCsCompIds cstmt' compids' ->
    AreCsCompIds (cstmt // cstmt') compids'' ->
    compids'' = compids ++ compids'.
Proof.
  intros; eapply AreCsCompIds_determ; eauto.
  eapply AreCsCompIds_app; eauto.
Qed.

Lemma AreCsCompIds_compid_iff :
  forall {behavior compids},
    AreCsCompIds behavior compids ->
    (forall id__c, List.In id__c compids -> exists id__e gm ipm opm, InCs (cs_comp id__c id__e gm ipm opm) behavior)
    /\ (forall id__c id__e gm ipm opm, InCs (cs_comp id__c id__e gm ipm opm) behavior -> List.In id__c compids).
Proof.
  induction behavior; inversion 1; (try inversion_clear 1); split;
    tryif (solve [inversion_clear 1]) then (inversion_clear 1) else auto.

  (* CASE behavior = comp(...) *)
  - rewrite app_nil_l; inversion_clear 1;
      [ try subst; exists id__e, g, i, o; reflexivity | contradiction ].
  - rewrite app_nil_l; inversion_clear 1; constructor; reflexivity.

  (* CASE behavior = beh1 || beh2 *)
  - rename a' into compids1.
    destruct (AreCsCompIds_ex behavior2) as (compids2, AreCsCompIds2).
    erewrite AreCsCompIds_eq_app with (compids'' := compids) (compids := compids1); eauto.
    intros id__c In_app; destruct_in_app_or.
    + edestruct IHbehavior1 with (compids := compids1) as ((id__e, (gm, (ipm, (opm, InCs_beh1)))), _); eauto.
      do 4 eexists; simpl; left; eexact InCs_beh1.
    + edestruct IHbehavior2 with (compids := compids2) as ((id__e, (gm, (ipm, (opm, InCs_beh2)))), _); eauto.
      do 4 eexists; simpl; right; eexact InCs_beh2.
  - rename a' into compids1.
    destruct (AreCsCompIds_ex behavior2) as (compids2, AreCsCompIds2).
    erewrite AreCsCompIds_eq_app with (compids'' := compids) (compids := compids1); eauto.
    simpl; inversion_clear 1.
    + eapply in_or_app; left; eapply IHbehavior1 with (compids := compids1); eauto.
    + eapply in_or_app; right; eapply IHbehavior2 with (compids := compids2); eauto.
Qed.

Lemma AreCsCompIds_ex_app :
  forall {cstmt1 cstmt2 compids},
    AreCsCompIds (cstmt1 // cstmt2) compids ->
    exists compids1 compids2,
      AreCsCompIds cstmt1 compids1 /\
      AreCsCompIds cstmt2 compids2 /\
      compids = compids1 ++ compids2.
Proof.
  do 3 intro.
  destruct (AreCsCompIds_ex cstmt1) as (compids1, AreCsCompIds1).
  destruct (AreCsCompIds_ex cstmt2) as (compids2, AreCsCompIds2).
  exists compids1, compids2.
  split_and; try (solve [assumption]).
  eapply AreCsCompIds_eq_app; eauto.
Qed.

(** ** Facts about [ArePortIds] Relation *)

Lemma ports_in_portids :
  forall {id τ ports portids},
    (List.In (pdecl_in id τ) ports \/ List.In (pdecl_out id τ) ports) ->
    ArePortIds ports portids ->
    List.In id portids.
Proof.
  inversion 1; intros;
    lazymatch goal with
    | [ H: List.In ?p _ |- _ ] =>
      change id with ((fun pd : pdecl =>
                         match pd with
                         | pdecl_in id _ | pdecl_out id _ => id
                         end) p);
        eapply Map_in; eauto
    end.
Qed.

(** ** Facts about [AreSigIds] Relation *)

Lemma sigs_in_sigids :
  forall {id τ sigs sigids},
    List.In (sdecl_ id τ) sigs ->
    AreSigIds sigs sigids ->
    List.In id sigids.
Proof.
  intros;
    lazymatch goal with
    | [ H: List.In ?s _ |- _ ] =>
      change id with ((fun sd : sdecl =>
                         match sd with
                         | sdecl_ id _ => id
                         end) s);
        eapply Map_in; eauto
    end.
Qed.


Require Setoid.
Require Import Equivalence.
Require Import Program.Equality.
Require Import Ynot.

Definition ptsto_any_tot (p : ptr) :=
  ptsto_any p (Qcanon.Q2Qc (QArith_base.Qmake BinInt.Z0 BinPos.xH)).

Require Import Array.
Require Import List.
Require Import Relations.
Open Local Scope hprop_scope.
Open Local Scope stsepi_scope.
Require Import Arith.

Generalizable All Variables.
Set Automatic Introduction.
Unset Implicit Arguments.

Ltac t := sep fail simpl.

Ltac dest_unpack f :=
  case_eq f; intros; rewrite <- ! hiff_unpack.

Ltac move_one_pure :=
  match goal with
    | |- hprop_inj _ * _ ==> _ => apply himp_inj_prem; intro
    | |- _ * ?Q ==> _ =>
      match Q with
        context [ hprop_inj _ ] =>
        rewrite hstar_comm; rewrite <- ! hstar_assoc
      end
  end.

Ltac move_one_pure_concl :=
  match goal with
    | |- ?p ==> hprop_inj ?P * ?q =>
      match goal with
        | H' : P |- _ => apply (himp_inj_conc H'); try move_one_pure_concl
        | _ =>
          let H := fresh in
            cut P; [intro H; apply (himp_inj_conc H); try move_one_pure_concl|idtac]
      end
    | |- _ ==>  ?P * ?Q =>
      match Q with
        context [ hprop_inj _ ] =>
        rewrite (hstar_comm P Q); rewrite <- ! hstar_assoc
      end
  end.

Ltac move_pure := rewrite <- ! hstar_assoc; repeat move_one_pure;
  try move_one_pure_concl.

Ltac safe_injection H :=
  revert H; progress (intro H ; injection H ; clear H; intros).

Ltac discriminates :=
  match goal with
    | H : ?n <> ?n |- _ => elim H; reflexivity
    | H : ?n = ?n |- _ => clear H
    | H : ?x = ?y |- _ => (subst x || subst y ||
      (safe_injection H ; intros))
    | |- ?n <> ?n => elimtype False
    | |- _ <> _ => intro
  end.

Ltac contradictions := contradiction ||
  match goal with
    H : ?x = ?y |- _ => symmetry in H; contradiction
  end.

Create HintDb dest discriminated.

Ltac simplify_goal :=
  autounfold with dest in *;
  repeat dest_conj;
  try discriminates;
  try contradictions;
  try congruence.

Definition block {A} (a : A) : A := a.
Ltac block H := let T := type of H in change (block T) in H.
Ltac unblock := unfold block in *.

Ltac myauto := simplify_goal; try typeclasses eauto with dest.
Set Firstorder Solver myauto.

Lemma pair_equal {A B} (x x' : A) (y y' : B) : (x, y) = (x', y') -> x = x' /\ y = y'.
Proof. intros. injection H. intuition. Qed.

Ltac pack_injections := repeat
  match goal with
    H : [_]%inhabited = [_]%inhabited |- _ =>
      apply pack_injective in H
  end.

Definition hprop_or (P Q : hprop) : hprop :=
  fun h => P h \/ Q h.

Lemma hprop_or_prem p q r : (p ==> r) /\ (q ==> r) -> hprop_or p q ==> r.
Proof. firstorder. Qed.

Lemma hprop_or_left p q r : p ==> q -> p ==> hprop_or q r.
Proof. firstorder. Qed.

Lemma hprop_or_right p q r : p ==> r -> p ==> hprop_or q r.
Proof. firstorder. Qed.

Theorem himp_ex_conc : forall p T (p1 : T -> _),
  (exists v, p ==> p1 v)
  -> p ==> hprop_ex p1.
Proof. red.
  intros. destruct H.
  generalize (H _ H0); clear H H0. simp_heap. eauto 7 with Ynot.
Qed.

Theorem himp_pure2 (P Q : Prop) : [P] * [Q] <==> [P /\ Q].
Proof. reduce. simp_heap. split; simp_heap. red in Hrl, Hrr. subst.
  red. intuition. subst. myauto. myauto. auto. destruct H. do 2 econstructor. intuition.
Qed.

Definition hprop_all {A} (p : A -> hprop) : hprop :=
  fun h => forall x : A, p x h.

Notation "'Forall' v :@ T , p" := (hprop_all (fun v : T => p)) (at level 90, T at next level) : hprop_scope.
Lemma hprop_all_conc {A} (P : A -> hprop) p : (forall x : A, p ==> P x) -> p ==> Forall x :@ A, P x.
Proof. intros. red. intros. intro. apply (H x). apply H0. Qed.

Section Make.
  Context {A : Set}.

  Definition valid_array a start len points_to :=
    iter_sep (fun i => p :~~ array_plus a i in points_to p i) start len.

  Definition points_f (f : nat -> A) :=
    fun p i => p --> f i.

  Definition rep_array a n (f : nat -> A) :=
    [array_length a = n] *
    valid_array a 0 n (points_f f).

  Section Init.
    Variable init : nat -> A.

    Definition initialize_pre(f:array)(n:nat) :=
      valid_array f (array_length f - n) n (fun p _ => ptsto_any_tot p).

    Definition initialize_post(f:array)(n:nat)(_:unit) :=
      valid_array f (array_length f - n) n (points_f init).

    Definition initialize_array_spec (f:array)(n:nat) := (n <= array_length f)%nat ->
      STsep (initialize_pre f n) (initialize_post f n).

    Definition initialize_array_aux (a : array) (n : nat) : initialize_array_spec a n.
    Proof. revert n.
      refine(fix make(n:nat) : initialize_array_spec a n :=
        IfZero n
        Then fun _ => {{Return tt}}
        Else fun _ =>
          upd_array a (array_length a - S n) (init (array_length a - S n)) <@> (initialize_pre a n) ;;
          {{make n _ <@> _}}); clear make;
      unfold initialize_post, initialize_pre, initialize_array_spec, ptsto_any_tot, valid_array, points_f,
        ptsto_any; t;
        assert(Hi : (S (array_length a - S n0) = array_length a - n0)%nat) by omega; try rewrite Hi; t.
    Defined.

    Definition initialize_array (a : array) :
      STsep (valid_array a 0 (array_length a) (fun p i => ptsto_any_tot p))
      (fun (_ : unit) => rep_array a (array_length a) init).
    Proof. intros. unfold rep_array.
      refine {{@initialize_array_aux a (array_length a) (le_n (array_length a))}};
        unfold initialize_pre, initialize_post, points_f; rewrite minus_diag; t.
    Qed.

    Definition make_array : forall (n : nat), STsep emp
      (fun a : array => rep_array a n init).
    Proof.
      refine (fun n =>
        a <- new_array n <@> _;
        @initialize_array a <@> ([array_length a = n]) ;;
        {{Return a}}); t.
    Qed.
  End Init.

  Definition get_array (n : nat) (a : array)
    (f : [nat -> A]) : (n < array_length a)%nat ->
    STsep (f ~~ rep_array a (array_length a) f)
    (fun r : A => f ~~ rep_array a (array_length a) f * [r = f n]).
  Proof.
    intros.
    refine (x <- sub_array a n (fun v => f ~~ [v = f n])
      <@> (f ~~ valid_array a 0 n (fun p i => p --> f i) * valid_array a (S n) (array_length a - n - 1) (fun p i => p --> f i)) ;
      {{Return x}}).
    unfold rep_array, valid_array. t.
    rewrite hstar_assoc. setoid_rewrite hstar_comm at 2.
    rewrite (split_index_sep _ 0 H). t.
    t. t. t.

    unfold rep_array. t.
    rewrite hstar_assoc. setoid_rewrite hstar_comm at 2.
    unfold valid_array.
    assert (x1 --> x2 n <==> hprop_unpack (array_plus a n) (fun p => p --> x2 n)).
    rewrite H0. rewrite <- hiff_unpack. reflexivity.
    rewrite H1.
    rewrite join_index_sep; auto.
  Qed.

  Lemma model_array_split_at (a : array) (f : nat -> A) (i : nat) : (i < array_length a)%nat ->
    forall p : ptr, array_plus a i = [p]%inhabited ->
      rep_array a (array_length a) f ==>
    (valid_array a 0 i (points_f f) *
      points_f f p i *
      valid_array a (S i) (array_length a - i - 1) (points_f f))%hprop.
  Proof.
    intros. unfold rep_array, valid_array, points_f.
    rewrite (split_index_sep (fun i =>
      hprop_unpack (array_plus a i) (fun p0 : ptr => p0 --> f i)) 0 H). t.
  Qed.

  Definition upd_model (f : nat -> A) (n : nat) (v : A) :=
    fun i => if eq_nat_dec i n then v else f i.

  Lemma valid_array_update a start len f n v :
    (n < start \/ len + start <= n)%nat ->
    valid_array a start len (points_f f) ==>
    valid_array a start len (points_f (upd_model f n v)).
  Proof. intros.
    unfold valid_array. apply iter_imp. intros.
    dest_unpack (array_plus a i).
    unfold upd_model, points_f.
    case_eq (eq_nat_dec i n). intros. subst.
    destruct H; elimtype False; omega. myauto.
  Qed.

  Definition set_array (a : array) (n : nat) (v : A) (f : [nat -> A]) : (n < array_length a)%nat ->
    STsep (f ~~ rep_array a (array_length a) f)
    (fun _ : unit => f ~~ rep_array a (array_length a) (upd_model f n v)).
  Proof. intros.
    refine {{upd_array a n v <@> (f ~~
      valid_array a 0 n (points_f f) * valid_array a (S n) (array_length a - n - 1)
      (points_f f))%hprop}}.
    unfold rep_array; t.
    setoid_rewrite hstar_comm at 1.
    setoid_rewrite <- hstar_assoc.
    setoid_rewrite hstar_comm at 2.
    setoid_rewrite hstar_assoc.
    Existential 1 := A. Existential 1 := (x n). instantiate.
    change (x0 --> x n) with (points_f x x0 n).
    rewrite <- model_array_split_at; auto. unfold rep_array. t.

    t. rewrite <- hstar_assoc. setoid_rewrite hstar_comm at 2. rewrite hstar_assoc.

    unfold rep_array.
    dest_unpack (array_plus a n).
    rewrite (@valid_array_update a 0 n x n v); try omega.
    rewrite (@valid_array_update a (S n) (array_length a - n - 1) x n v); try omega.
    change (p --> v) with ((fun p => p --> v) p).
    rewrite (hiff_unpack p). rewrite <- H0.
    assert (hprop_unpack (array_plus a n) (fun p => p --> v) <==> (p :~~ array_plus a n in points_f (upd_model x n v) p n))%hprop.
    unfold points_f, upd_model. dest_unpack (array_plus a n).
    case_eq (eq_nat_dec n n); intros; subst. reflexivity. intuition.
    rewrite H1. clear H0 H1.
    t. apply join_index_sep. auto.
  Qed.

  Lemma valid_array_model a start len f : valid_array a start len (points_f f) <==>
    {@ p :~~ array_plus a i in p --> f i | i <- start + len}.
  Proof. unfold valid_array. reflexivity. Qed.

End Make.

Section Fin.

  Definition fin size := sig (fun n : nat => n < size).

  Definition fin_eq {size} (x y : fin size) := proj1_sig x = proj1_sig y.
  Definition fin_neq {size} (x y : fin size) := not (fin_eq x y).

  Definition eq_fin_dec {n} (x y : fin n) : { x = y } + { x <> y }.
  Proof. intros. destruct x; destruct y.
    case (eq_nat_dec x x0). intros. subst. left.
    f_equal.
    apply proof_irrelevance.
    intros. right.
    intro. apply n0. injection H. auto.
  Defined.

  Definition build_fin {size} (i : nat) : option (fin size) :=
    match lt_dec i size with
      | left prf => Some (exist _ i prf)
      | right _ => None
    end.

End Fin.

Definition upd_model_fin {A : Set} {size} (f : fin size -> A) (n : fin size) (v : A) :=
  fun i => if eq_fin_dec i n then v else f i.

Section ArrayFin.
  Context {A : Set}.

  Definition repr_fn {size} a (points_to : fin size -> A) :=
    iter_sep (fun i => p :~~ array_plus a i in
      Exists prf :@ i < size,
      p --> points_to (exist (fun i => i < size) i prf)) 0 size.

  Definition repr_array {size} a (f : fin size -> A) :=
    ([array_length a = size] * repr_fn a f)%hprop.

  Definition make_array_fin (n : nat) (f : fin n -> A) : STsep emp
    (fun a => repr_array a f)%hprop.
  Proof. destruct n.
    refine {{new_array 0}}; t.
    assert(prf : 0 < S n) by omega.
    refine {{make_array (fun i : nat => match build_fin i return A with
                                    | Some prf => f prf
                                    | None => f (exist _ 0 prf)
                                  end) (S n)}}.
    t. t. unfold repr_array, repr_fn, rep_array, valid_array.
    apply himp_split. t. apply iter_imp. intros.
    dest_unpack (array_plus v i). apply himp_ex_conc.
    assert(Hi:i < S n) by omega. exists Hi. unfold points_f.
    unfold build_fin. destruct lt_dec. t. f_equal. f_equal. apply proof_irrelevance.
    contradiction.
  Qed.

  Lemma upd_model_refl {size} f (i : fin size) : f i = i ->
    Morphisms.pointwise_relation (fin size) eq (upd_model_fin f i i) f.
  Proof. intros. red; intros. unfold upd_model_fin. case eq_fin_dec; myauto. Qed.

  Context {size : nat}.

  Definition get_array_fin (a : array) (n : fin size)
    (f : [fin size -> A]) : array_length a = size ->
    STsep (f ~~ repr_array a f)
    (fun r : A => f ~~ repr_array a f * [r = f n])%hprop.
  Proof.
    destruct size. depelim n. exfalso; inversion l.
    destruct n. intros. assert(x < array_length a) by omega.
    assert(0 < S n0) by omega.
    refine (x <- get_array x a
      (f ~~~ fun i => match build_fin i return A with
                       | Some prf => f prf
                       | None => f (exist _ 0 H1) end)
      H0 <@> [array_length a = S n0] ;
    {{Return x}}); t.

    unfold repr_array, repr_fn, rep_array.
    unfold valid_array. apply himp_split. t. rewrite H. apply iter_imp. intros.
    unfold points_f, build_fin. t.
    case lt_dec. intros. f_equal. f_equal. apply proof_irrelevance.
    myauto.
    unfold repr_array, repr_fn, rep_array.
    setoid_rewrite <- hstar_assoc.
    apply himp_split; [t|].
    setoid_rewrite hstar_comm.
    unfold valid_array. apply himp_inj_conc.
    unfold build_fin. case lt_dec.
    intros. f_equal. f_equal. apply proof_irrelevance.
    myauto.

    rewrite H.
    apply iter_imp. intros.
    dest_unpack (array_plus a i).
    unfold points_f, build_fin.
    case lt_dec. intros. t.
    intros. elimtype False; omega.
  Qed.

  Definition set_array_fin (a : array) (n : fin size) (v : A)
    (f : [fin size -> A]) : array_length a = size ->
    STsep (f ~~ repr_array a f)
    (fun r : unit => f ~~ repr_array a (upd_model_fin f n v))%hprop.
  Proof. destruct n. destruct size. exfalso; depelim l.
    intro Hlen. assert(x < array_length a) by omega.
    assert(Hs:0 < S n) by omega.
    refine (x <- set_array a x v
      (f ~~~ fun i => match build_fin i return A with
                       | Some prf => f prf
                       | None => f (exist _ 0 Hs) end)
      H <@> [array_length a = S n] ;
    {{Return x}}); unfold repr_array; t.

    unfold repr_fn, rep_array. apply himp_inj_conc. auto.
    unfold valid_array. rewrite Hlen.

    apply iter_imp. intros.
    dest_unpack (array_plus a i).
    unfold points_f. unfold build_fin. t.
    case lt_dec. intros. do 2 f_equal. apply proof_irrelevance.
    intros. elimtype False; omega.

    unfold rep_array. t. unfold valid_array, repr_fn.
    rewrite <- H0 at 1.
    apply iter_imp. intros.
    dest_unpack (array_plus a i).
    unfold points_f, build_fin. apply himp_ex_conc.
    assert(His:i < S n) by omega. exists His.
    t.
    unfold upd_model, upd_model_fin.
    unfold eq_fin_dec. simpl. case eq_nat_dec.
    intros. subst x. unfold eq_rec_r, eq_rec, eq_rect, eq_sym. reflexivity.
    intros.
    case lt_dec. intros. do 2 f_equal. apply proof_irrelevance.
    intros. elimtype False; omega.
  Qed.

End ArrayFin.

Module Type ArrayF.

  Parameter t : Set -> nat -> Set.

  Parameter repr : forall {A size}, t A size -> (fin size -> A) -> hprop.

  Parameter create : Π {A : Set} (size : nat) (f : fin size -> A), STsep emp (fun x : t A size => repr x f).

  Parameter get : Π {A : Set} {size : nat} (a : t A size) (f : [fin size -> A]) (n : fin size),
    STsep (f ~~ repr a f) (fun x : A => f ~~ repr a f * [x = f n]).

  Parameter set : Π {A : Set} {size : nat} (a : t A size)
    (f : [fin size -> A]) (n : fin size) (v : A),
    STsep (f ~~ repr a f) (fun _ : unit => f ~~ repr a (upd_model_fin f n v)).

End ArrayF.

Axiom get_prf : Π {P : Prop} {p}, STsep ([P] * p) (fun _ : P => [P] * p).

(** It is safe as the variable is irrelevant, right?
   Otherwise you lose the ability to hide model updates.
 *)

Axiom get_irr : Π (T : Set) (p : T -> hprop),
  STsep (@hprop_ex T p) (fun x : [T] => x ~~ p x).

Module Array_fin <: ArrayF.

  Definition t (A : Set) (n : nat) := sig (fun a : array => array_length a = n).

  Definition repr {A size} (a : t A size) (f : fin size -> A) :=
    let (a, p) := a in
      repr_array a f.

  Definition create {A : Set} {size} (f : fin size -> A) :
    STsep emp (fun x : t A size => repr x f).
  Proof. refine (x <- make_array_fin size f;
    prf <- get_prf ;
    {{Return (exist _ x prf)}});
    unfold repr_array; t.
    unfold repr_array; t.
  Qed.

  Definition get {A : Set} {size : nat} (a : t A size) (f : [fin size -> A]) (n : fin size) :
    STsep (f ~~ repr a f) (fun x : A => f ~~ repr a f * [x = f n]) :=
    let 'exist a p := a in get_array_fin a n f p.

  Definition set {A : Set} {size : nat} (a : t A size)
    (f : [fin size -> A]) (n : fin size) (v : A) :
    STsep (f ~~ repr a f) (fun _ : unit => f ~~ repr a (upd_model_fin f n v)) :=
    let 'exist a p := a in set_array_fin a n v f p.

End Array_fin.

Module Array : ArrayF := Array_fin.

Section UnionFind.

  Definition partition size := fin size -> fin size.

  Definition partition_eq {size} (p q : partition size) : Prop :=
    forall i j : fin size, p i = p j <-> q i = q j.

  Instance: Reflexive (@partition_eq size).
  Proof. intros size p i j. reflexivity. Qed.

  Instance: Symmetric (@partition_eq size).
  Proof. intros size p p' H i j. red in H. rewrite H. reflexivity. Qed.

  Instance: Transitive (@partition_eq size).
  Proof. intros size p p' p'' H H' i j. red in H, H'. etransitivity; eauto. Qed.

  Definition representation size := fin size -> fin size.

  Record uf {size} : Set := {
    parent : Array.t (fin size) size;
    rank : Array.t nat size
  }.

  Definition t (size : nat) := @uf size.

  Open Local Scope nat_scope.

  Inductive repr {size} (p : partition size) : fin size -> fin size -> Prop :=
    repr_zero : forall i, p i = i -> repr p i i
  | repr_succ : forall i j, p i = j -> i <> j ->
    forall r, repr p j r -> repr p i r.

  Hint Constructors repr : repr.

  Definition models_partition {size} (f : representation size) (p : partition size) :=
    forall x, repr f x (p x).

  Definition repr_partition {size} (a : Array.t (fin size) size) (f : representation size) (p : partition size) :=
    (Array.repr a f * [models_partition f p])%hprop.

  Notation "'Exists' v :@ T , p" := (hprop_ex (fun v : T => p%hprop)) (at level 90, T at next level) : hprop_scope.

  Definition repr_uf {size} uf (p : partition size) :=
    Exists pmodel :@ representation size,
    Exists rmodel :@ fin size -> nat,
      repr_partition uf.(parent) pmodel p *
      Array.repr uf.(rank) rmodel.

  Definition repr_t {size} (x : t size) (p : partition size) : hprop :=
    repr_uf x p.

  Hint Extern 4 => intro : dest.
  Ltac myauto ::=
    autounfold with repr dest in *; intros;
    simplify_goal; try typeclasses eauto with repr dest.

  Typeclasses eauto :=.

  Hint Extern 4 (exists _ : _, _) => econstructor : dest.
  Hint Constructors and or : dest.
  Hint Extern 0 (_ = _) => reflexivity : dest.
  Hint Extern 0 (_ <-> _) => reflexivity : dest.
  Hint Extern 0 (_ ==> _) => reflexivity : dest.
  Hint Extern 0 (_ <==> _) => reflexivity : dest.
  Lemma empty_split : empty ~> empty * empty.
  Proof. t. Qed.
  Hint Resolve empty_split : dest.

  Hint Unfold hprop_inj : dest.

  Hint Constructors repr : Ynot.
  Set Firstorder Solver auto.

  Definition make {size} : STsep __ (fun x : t size => repr_t x (fun i : fin size => i))%hprop.
  Proof. intros. refine (
    parents <- Array.create size (fun i => i) ;
    ranks <- Array.create size (fun i => 0%nat) <@> (Array.repr parents (fun i => i)) ;
    {{Return {| parent := parents; rank := ranks |}}});
      unfold ptsto_any_tot, ptsto_any; t.

    unfold repr_t, repr_uf, repr_partition. t.
    apply himp_pure'. intro. constructor; auto.
  Qed.

  Definition repr_eq {size} (f g : partition size) :=
    forall n : fin size, forall c, repr f n c <-> repr g n c.

  Instance repr_equiv size : Equivalence (@repr_eq size).
  Proof. constructor; reduce.

    reflexivity.

    symmetry. red in H. auto.

    red in H, H0. rewrite H; auto.
  Qed.

  Context {size : nat}.

(* unfold model_partition, model_array, models_partition. t. *)

  Lemma repr_inj {x n c} : repr (size:=size) x n c -> forall {c'}, repr x n c' -> c = c'.
  Proof. induction 1; intros. depelim H0. myauto.
    rewrite H0 in H. myauto.

    depelim H2. rewrite H2 in H. myauto.
    rewrite H2 in H. myauto.
  Qed.

  Hint Unfold models_partition : repr.

  Lemma models_partition_repr {f p : partition size} : models_partition f p ->
    forall i : fin size, repr f i (p i).
  Proof. myauto. Qed.
  Hint Resolve @models_partition_repr : repr.

  Lemma models_partition_f (f p : partition size) :
    models_partition f p -> forall i : fin size, p i = p (f i).
  Proof.
    intros. pose (models_partition_repr H i).
    apply (repr_inj r).
    case (eq_fin_dec i (f i)). intros. rewrite e at 1. apply H.
    intros. econstructor 2 with (f i); myauto.
  Qed.
  Hint Resolve @models_partition_f : repr.

  Lemma repr_f_fi_not_i (f : partition size) (i : fin size) :
    forall v, repr f i v -> repr f (f i) v.
  Proof. intros. induction H.

    rewrite H; myauto. myauto.
  Qed.

  Lemma repr_f_fi {f : representation size} {p : partition size} {i : fin size} : models_partition f p ->
    forall {v}, repr f (f i) v -> repr f i v.
  Proof. intros rfp v rfv. depind rfv.
    case (eq_fin_dec (f i) i) ; intros; auto.
    rewrite e. myauto.
    econstructor 2 with (f i); myauto.
    econstructor 2 with (f i); myauto.
  Qed.

  Lemma repr_f_fi_eq {f : representation size} {i : fin size} :
    forall {v}, repr f i v -> f v = v.
  Proof. intros. induction H. auto.
    subst j. auto.
  Qed.

  Ltac inst H :=
    match type of H with
      ?X -> _ => let H' := fresh in assert (H':X) by typeclasses eauto with repr; specialize (H H')
    end.

  Lemma repr_f_fi_eq' {f : representation size} {p : partition size} {i : fin size} :
    models_partition f p ->
    repr f (f i) i -> f i = i.
  Proof. intros rfp rfi.
    apply (repr_f_fi rfp) in rfi. depind rfi. auto.
    generalize (models_partition_repr rfp (f i)). intros.
    assert (Hi:=repr_inj rfi H).
    pose (repr_f_fi_eq H). rewrite <- Hi in e. myauto.
  Qed.

  Lemma models_partition_f' {f : representation size} {p : partition size} :
    models_partition f p -> forall {i : fin size}, f (p i) = p i.
  Proof.
    intros.
    red in H. apply (repr_f_fi_eq (i:=i)). myauto.
  Qed.

  Infix "===>" := Morphisms.respectful (at level 90, right associativity).

  Class Have (P : Prop) := have : P.
  Hint Extern 0 (Have _) => unfold Have; auto with repr : typeclass_instances.

  Definition subset_eq {A} (R : relation A) (P : A -> Prop) : relation A :=
    fun x y => R x y /\ P x /\ P y.

  Instance subset_proper {A} (R : relation A) `(Reflexive A R) (P : A -> Prop) (x : A) (p : Have (P x)) :
    Morphisms.Proper (subset_eq R P) x.
  Proof. reduce. intuition. Qed.

  Instance subset_proper_proxy {A} (R : relation A) `(Reflexive A R) (P : A -> Prop) (x : A) (p : Have (P x)) :
    Morphisms.ProperProxy (subset_eq R P) x.
  Proof. reduce. intuition. Qed.

  Instance: Morphisms.Proper (repr_eq ===> eq ===> eq ===> iff) (@repr size).
  Proof. reduce. red in H. subst. apply H. Qed.

  Instance: Morphisms.Proper (repr_eq ===>
    Morphisms.pointwise_relation (fin size) eq ===> iff) models_partition.
  Proof. reduce. red in H. unfold models_partition.
    split; intros. rewrite <- H0.
    now rewrite <- H.

    rewrite H0. now rewrite H.
  Qed.

  Instance: RelationClasses.subrelation (Morphisms.pointwise_relation (fin size) eq) repr_eq.
  Proof. intros f g Hfg x y.
    split. intros rf. induction rf. setoid_rewrite Hfg in H. constructor; auto.
    setoid_rewrite Hfg in H. constructor 2 with (g i) ; subst j; auto.

    induction 1. setoid_rewrite <- Hfg in H. constructor; auto.
    setoid_rewrite <- Hfg in H. constructor 2 with (f i) ; subst j; auto.
  Qed.

  Require Import Logic.FunctionalExtensionality.
  Lemma repr_model_refl f (i : fin size) : f i = i -> upd_model_fin f i i = f.
  Proof. intros. extensionality a. apply upd_model_refl; auto. Qed.

  Lemma repr_f_refl {f p} {i : fin size} : models_partition f p -> (f i = i <-> p i = i).
  Proof. intros rfp. split; intros H.
    assert (H':=models_partition_repr rfp i). depelim H'; myauto.

    assert (H':=models_partition_repr rfp i). depelim H'; myauto.
    rewrite <- H. apply models_partition_f'; auto.
  Qed.

  Lemma repr_f_refl_left {f p} : models_partition f p -> forall {i : fin size}, f i = i -> p i = i.
  Proof. intros. now rewrite <- (repr_f_refl H). Qed.

  Lemma repr_f_refl_right {f p} : models_partition f p -> forall {i : fin size}, p i = i -> f i = i.
  Proof. intros. now rewrite (repr_f_refl H). Qed.

  Lemma repr_eq_refl (i : fin size) x y : repr_eq x y -> x i = i -> y i = i.
  Proof. intros rxy xi. red in rxy. apply repr_zero in xi.
    rewrite rxy in xi. eapply repr_f_fi_eq; myauto.
  Qed.

  Lemma repr_eq_succ {x y p} {i c : fin size} : models_partition x p -> repr_eq x y ->
    repr x i c -> repr y i c.
  Proof. intros rfp rxy H. rewrite <- rxy. assumption. Qed.

  Lemma repr_canon {f} {i : fin size} {c p} : models_partition f p -> (repr f i c <-> p i = c).
  Proof. intros rfp. split; intros H.
    apply (repr_inj (models_partition_repr rfp i) H).
    pose (H':=models_partition_repr rfp i).
    now rewrite H in H'.
  Qed.

  Lemma repr_canon_right {x} {i : fin size} {c p} : models_partition x p -> repr x i c -> p i = c.
  Proof. intros. rewrite <- @repr_canon; eauto. Qed.

  Lemma repr_f_invol {f p} {i : fin size} : models_partition f p ->
    f i = i -> repr f i (f i).
  Proof. intros rfp fii. rewrite <- fii at 1. eapply repr_f_fi_not_i. rewrite fii. myauto. Qed.

  Hint Resolve @repr_f_fi_not_i : repr.
  Hint Resolve @repr_canon_right : repr.

  Lemma repr_elim {f p} (H : models_partition f p)
    (P : forall n i, Prop)
    (Pzero : forall i : fin size, f i = i -> i = p i -> P i (p i))
    (Psucc : forall i : fin size, f i <> i -> i <> p i -> P (f i) (p i) -> P i (p i)) :
    forall i c, repr f i c -> P i c.
  Proof.
    intros i c rf. assert (ri:=repr_inj (models_partition_repr H i) rf).
    rewrite <- ri in rf |- *. clear ri c.
    depind rf.
    apply Pzero; auto.
    apply Psucc; auto.
    pose (repr_f_refl (i:=i) H). destruct i0.
    intro. symmetry in H3. intuition.
    specialize (IHrf p H P Pzero Psucc).
    assert(Hpi:p i = p (f i)). apply models_partition_f; auto.
    specialize (IHrf Hpi).
    rewrite <- Hpi in IHrf.
    auto.
  Qed.

  Lemma models_partition_invol {f} {p : partition size} : models_partition f p -> forall {i}, p (p i) = p i.
  Proof. intros rfp i.
    assert (ri:=models_partition_repr rfp i). depind ri.
    rewrite <- x. auto.
    specialize (IHri p rfp).
    assert(Hpi:p i = p (f i)). apply models_partition_f; auto.
    specialize (IHri Hpi). rewrite <- Hpi in IHri. auto.
  Qed.

  Ltac upd_model_simpl :=
    unfold upd_model_fin; case eq_fin_dec; auto; intros; try discriminates; try contradictions.
  Hint Resolve @models_partition_f' : repr.

  Lemma models_partition_upd {f : representation size} {p : partition size} {n v} :
    models_partition f p -> n <> f n -> repr f (f n) v -> models_partition (upd_model_fin f n v) p.
  Proof.
    intros fp nfn rfv. intro.
    eapply repr_f_fi in rfv; eauto.
    assert (hi:=repr_inj rfv (models_partition_repr fp n)). subst v.
    assert (r:=models_partition_repr fp x). remember (p x) as px. revert Heqpx.
    elim r using (repr_elim fp); auto with repr.

    intros i fii ipi _.
    rewrite <- ipi. constructor; auto.
    upd_model_simpl.

    intros i fii ipi H _.
    assert (Hpi:p i = p (f i)). auto with repr. specialize (H Hpi).
    case (eq_fin_dec i n). intros <-.
    econstructor 2 with (p i); auto. upd_model_simpl.
    constructor; auto. upd_model_simpl. auto with repr.

    intros.
    econstructor 2 with (f i); auto.
    upd_model_simpl. myauto.
  Qed.

  Lemma repr_upd_model (f : representation size) (p : partition size) (n v : fin size) :
    models_partition f p ->
    n <> f n ->
    repr f (f n) v ->
    repr_eq f (upd_model_fin f n v).
  Proof. intros rfp nfn rfv. red; intros x c.
    assert (rx':=models_partition_upd rfp nfn rfv x).
    split; intro H.
    assert(Hcp:=repr_inj (c':=c) (models_partition_repr rfp x) H). subst c. apply rx'.

    assert(Hcp:=repr_inj rx' H). subst c. auto with repr.
  Qed.

  Hint Resolve @models_partition_upd repr_upd_model : repr.

  Definition cast A (a : A) : A := a.

  Notation array := (Array.t (fin size) size).

  Definition find_post (a : array) (i : fin size) (f : fin size -> fin size) (p : partition size) (c : fin size) :=
    (repr_partition a f p * [p i = c])%hprop.

  Definition dest_pair {A B C : Type} (p : A * B) (cont : forall (a : A) (b : B), p = (a, b) -> C) : C.
  Proof. destruct p. eapply cont; auto. Defined.

  Definition find_aux (a : array) (i : fin size) (f : [representation size]) (p : [partition size]) :
    STsep (f ~~ p ~~ repr_partition a f p)
    (fun (res : fin size * [partition size]) => let (c, g) := res in
      f ~~ p ~~ g ~~ repr_partition a g p * [p i = c] * [repr_eq f g])%hprop.
  Proof. revert i f.
    refine (Fix2
      (fun i f => f ~~ p ~~ repr_partition a f p)
      (fun i f (res : fin size * [partition size]) =>
        let (c, g) := res in f ~~ p ~~ g ~~ repr_partition a g p * [p i = c] * [repr_eq f g])%hprop
      (fun self i (f : [representation size]) =>
        pi <- Array.get a f i
        <@> (f ~~ p ~~ [models_partition f p]) ;
        if eq_fin_dec pi i then {{Return (i, f)}}
        else
          res <- self pi f <@> (f ~~ p ~~ [f i = pi /\ pi <> i])%hprop ;
          let '(ci, g) := res in
            Array.set a g i ci <@> (f ~~ p ~~ g ~~
              [f i = pi /\ pi <> i /\
                repr f pi ci /\ models_partition f p /\ repr_eq f g])%hprop ;;
            {{Return (ci, (g ~~~ upd_model_fin g i ci))}}
          ));
    unfold find_post, repr_partition, models_partition; clear self; t. t.
    subst b.
    apply pair_equal in H0. destruct H0. subst a0.
    pack_injections. subst x1. t. apply himp_pure'.
    eauto with repr.

    apply himp_pure'. intuition auto. rewrite H0 at 1. apply H.
    rewrite H0. apply H.

    rename H3 into Hrepr. rename H5 into req. rename H2 into rci.
    apply pair_equal in H. destruct H; subst a1 b0.
    rewrite <- ! hiff_unpack. t. rewrite ! himp_pure2. apply himp_pure'.
    rewrite req at 1.
    change (models_partition x0 x1) in Hrepr.

    assert(x i <> i).
    intro.
    apply (repr_eq_refl i _ _ (symmetry req)) in H. congruence.
    assert(repr x (x i) ci).
    eapply repr_f_fi_not_i. rewrite <- req. eauto with repr.

    intuition auto with repr.

    rewrite req in Hrepr.
    intuition auto with repr.
    eapply repr_canon_right; eauto with repr.
    rewrite req in Hrepr.
    eapply repr_upd_model; eauto.
  Qed.

  Notation "inh ~~ p" := (hprop_unpack inh (fun inh => p%hprop)) (at level 91, right associativity) : hprop_scope.

  Axiom get_irr' : Π (T : Set) (p : T -> hprop),
  STsep (Exists x :@ T, p x) (fun x : [T] => x ~~ p x).

  Definition find (x : @t size) (p : [partition size]) (i : fin size) :
    STsep (p ~~ repr_t x p)
    (fun c : fin size => p ~~ repr_t x p * [p i = c]).
  Proof. unfold repr_t, repr_uf.
    refine
      (pmodel <- get_irr' (representation size) _ ;
       rmodel <- get_irr' (fin size -> nat) _ ;
       x <- find_aux x.(parent) i pmodel p <@> (rmodel ~~ Array.repr x.(rank) rmodel) ;
       {{Return (fst x)}}); try solve [t]. intuition t.
  Qed.

  (* Definition find (a : array) (i : fin size) (f : [representation size]) (p : [partition size]) :  *)
  (*   STsep (f ~~ p ~~ repr_partition a f p)  *)
  (*   (fun res : (fin size * [representation size]), *)
  (*     let (c, g) := res in *)
  (*     (p ~~ g ~~ f ~~ repr_partition a g p * [p i = c /\ repr_eq f g]))%hprop. *)
  (* Proof. intros. refine ({{find_aux a i f p}}); t. t. Qed. *)

  Definition partition_union (p : partition size) (i j : fin size) (r : fin size) : partition size :=
    fun x =>
      if eq_fin_dec (p x) (p i) then r
      else if eq_fin_dec (p x) (p j) then r
      else p x.

  Lemma models_partition_union {f p} (i j : fin size) : models_partition f p -> p i <> p j ->
    models_partition (upd_model_fin f (p j) (p i)) (partition_union p i j (p i)).
  Proof.
    intros. red in H. intro.
    generalize (H x). intros Hx.
    unfold upd_model_fin. unfold partition_union.
    depind Hx.
    case eq_fin_dec. intros.
    case (eq_fin_dec i0 (p j)); intros. subst i0.
    rewrite <- e in H0. contradictions. rewrite <- e.
    rewrite x at 1. constructor. case eq_fin_dec; auto. intros.
    auto with repr.

    intros. case eq_fin_dec. intros. rewrite <- x in e. subst i0.
    econstructor 2 with (p i); auto. case eq_fin_dec; auto.
    intros. discriminates.
    constructor; auto. case eq_fin_dec. auto. intros.
    auto with repr.

    intros. rewrite <- x. constructor. case eq_fin_dec; auto. intros.
    rewrite x in e. congruence.
    specialize (IHHx p i j H H0).
    assert(p i0 = p (f i0)). auto with repr. specialize (IHHx H1).
    rewrite <- H1 in IHHx.
    case eq_fin_dec. intros.
    econstructor 2 with (f i0). case eq_fin_dec. intros. subst i0.
    rewrite <- e. rewrite (models_partition_invol H). symmetry. auto with repr.
    intros. auto. auto.

    generalize IHHx. case eq_fin_dec. intros. auto. intros. contradictions.

    intros. revert IHHx.
    case eq_fin_dec. intros. contradictions.
    intros. revert IHHx. case eq_fin_dec. intros.
    econstructor 2 with (f i0); auto. case eq_fin_dec; auto. intros.
    subst i0.
    elim H2. symmetry. auto with repr.

    intros.
    econstructor 2 with (f i0); auto.
    case eq_fin_dec. intros. subst i0.
    elim n1. rewrite (models_partition_invol H). auto.
    intros.
    auto.
  Qed.

  Require Import Compare_dec.

  Lemma partition_union_sym (p : partition size) (i j : fin size) (c : fin size) :
    Morphisms.pointwise_relation (fin size) eq (partition_union p i j c) (partition_union p j i c).
  Proof.
    unfold partition_union. intro. repeat case eq_fin_dec; intros; congruence.
  Qed.

  Lemma partition_union_idem (p : partition size) (i j : fin size) : p i = p j ->
    Morphisms.pointwise_relation (fin size) eq p (partition_union p i j (p i)).
  Proof.
    unfold partition_union. intros H x. repeat case eq_fin_dec; intros; congruence.
  Qed.

  Lemma partition_eq_union (p : partition size) (i j : fin size) : p i = p j ->
    partition_eq p (partition_union p i j (p i)).
  Proof.
    intros. unfold partition_union. red.
    intros. repeat case eq_fin_dec; simpl_dep_elim; split; congruence.
  Qed.

  Lemma partition_eq_union_union (p : partition size) (i j : fin size) :
    partition_eq (partition_union p i j (p j)) (partition_union p i j (p i)).
  Proof.
    intros. unfold partition_union. red.
    intros. repeat case eq_fin_dec; simpl_dep_elim; split; congruence.
  Qed.

  Definition union_aux (x : @t size) (i j : fin size) (f : [representation size]) (r : [fin size -> nat])
    (p : [partition size]) :
    STsep (f ~~ r ~~ p ~~ repr_partition x.(parent) f p * Array.repr x.(rank) r)
    (fun res : ([representation size * partition size * (fin size -> nat)])%type =>
      res ~~ let 'pair (pair g p') r' := res in
        p ~~
        repr_partition x.(parent) g p' *
        Array.repr x.(rank) r' *
        [partition_eq p' (partition_union p i j (p i))]).
  Proof.
    destruct x as [pars ranks]. simpl.
    refine (cip <- find_aux pars i f p <@> (r ~~ Array.repr ranks r) ;
      dest_pair cip (fun ci g prf =>
      cjp <- find_aux pars j g p <@> (p ~~ r ~~ [p i = ci] * Array.repr ranks r) ;
      dest_pair cjp (fun cj g' prf' =>
        if eq_fin_dec ci cj then {{Return (inhabit_unpack3 g' p r (fun g' p r => (g', p, r)))}}
        else (
          rci <- Array.get ranks r ci <@>
          (g' ~~ p ~~ Array.repr pars g' * [models_partition g' p /\ p i = ci /\ p j = cj /\ ci <> cj]) ;
          rcj <- Array.get ranks r cj <@> (g' ~~ p ~~ r ~~
            Array.repr pars g' * [rci = r ci /\ models_partition g' p /\ p i = ci /\ p j = cj /\ ci <> cj]) ;
          match nat_compare rci rcj as comp return comp = nat_compare rci rcj -> _ with
          | Lt => fun prf =>
            (Array.set pars g' cj ci <@>
              (g' ~~ p ~~ r ~~
                Array.repr ranks r * [rci = r ci /\ rcj = r cj /\
                  models_partition g' p /\ p i = ci /\ p j = cj /\ ci <> cj]) ;;
            {{Return (inhabit_unpack3 g' p r (fun g' p r =>
              (upd_model_fin g' cj ci, (partition_union p i j (p i)), r)))}})
          | Gt => fun prf =>
            (Array.set pars g' ci cj <@>
              (g' ~~ p ~~ r ~~
                Array.repr ranks r * [rci = r ci /\ rcj = r cj /\
                  models_partition g' p /\ p i = ci /\ p j = cj /\ ci <> cj]) ;;
              {{Return (inhabit_unpack3 g' p r (fun g' p r =>
                (upd_model_fin g' ci cj, (partition_union p i j (p j)), r)))}})
          | Eq => fun prf =>
            (Array.set ranks r ci (S rci) <@>
              (g' ~~ p ~~ r ~~
                Array.repr pars g' * [rci = r ci /\ rcj = r cj /\
                  models_partition g' p /\ p i = ci /\ p j = cj /\ ci <> cj]) ;;
            Array.set pars g' cj ci <@>
              (g' ~~ p ~~ r ~~
                Array.repr ranks (upd_model_fin r ci (S rci)) * [rci = r ci /\ rcj = r cj /\
                  models_partition g' p /\ p i = ci /\ p j = cj /\ ci <> cj]) ;;
            {{Return (inhabit_unpack3 g' p r (fun g' p r =>
              (upd_model_fin g' cj ci, (partition_union p i j (p i)), upd_model_fin r ci (S rci))))}})
          end eq_refl
          )))); unfold repr_partition; t;
    repeat match goal with
      H : (_, _) = (_, _) |- _ => apply pair_equal in H; destruct H
    end;
    sep ltac:fail ltac:(auto using @partition_eq_union, @models_partition_union).

    rewrite himp_pure2.
    apply himp_pure'. split.
    rewrite partition_union_sym.
    apply models_partition_union; auto.
    apply partition_eq_union_union.
  Qed.

  Definition union (x : @t size) (p : [partition size]) (i j : fin size) :
    STsep (p ~~ repr_t x p)
    (fun p' : [partition size] => p' ~~ p ~~
      repr_t x p' * [partition_eq p' (partition_union p i j (p i))]).
  Proof. intros. unfold repr_t. unfold repr_uf.
    refine (pmodel <- get_irr' _ _ ;
      rmodel <- get_irr' _ _ ;
      x <- union_aux x i j pmodel rmodel p <@> _ ;
      {{Return (x ~~~ let 'pair (pair p'model p') r' := x in
        p')}}); t.
  Qed.

End UnionFind.

Module Type UF.
  Parameter t : nat -> Type.
  Parameter repr : forall {size}, t size -> partition size -> hprop.

  Parameter create : Π size : nat, STsep emp (fun x : t size => repr x (fun i => i)).

  Parameter union : Π {size : nat} (x : t size) (p : [partition size]) (i j : fin size),
    STsep (p ~~ repr x p)
      (fun p' : [partition size] =>
        p ~~ p' ~~ repr x p' * [partition_eq p' (partition_union p i j (p i))]).

  Parameter find : Π {size : nat} (x : t size) (p : [partition size]) (i : fin size),
    STsep (p ~~ repr x p)
      (fun ci => p ~~ repr x p * [ci = p i]).

End UF.

Module UFArray <: UF.

  Definition t (n : nat) := @t n.

  Definition repr {size} (uf : t size) (p : partition size) : hprop :=
    repr_t uf p.

  Definition create : Π size : nat, STsep emp (fun x : t size => repr x (fun i => i)).
  Proof. intros. refine make. Defined.

  Definition union : Π {size : nat} (x : t size) (p : [partition size]) (i j : fin size),
    STsep (p ~~ repr x p)
      (fun p' : [partition size] => p ~~ p' ~~
        repr x p' * [partition_eq p' (partition_union p i j (p i))]).
  Proof. intros. refine {{union x p i j}}; t. Qed.

  Definition find : Π {size : nat} (x : t size) (p : [partition size]) (i : fin size),
    STsep (p ~~ repr x p)
      (fun ci => p ~~ repr x p * [ci = p i]).
  Proof. intros. refine {{find x p i}}; t. Qed.

End UFArray.


Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Structures.Monoid.

Set Implicit Arguments.
Set Strict Implicit.

Section StateType.
  Variable S : Type.

  Record state (t : Type) : Type := mkState
  { runState : S -> t * S }.

  Definition evalState {t} (c : state t) (s : S) : t :=
    fst (runState c s).

  Definition execState {t} (c : state t) (s : S) : S :=
    snd (runState c s).

  Global Instance Monad_state : Monad state :=
  { ret  := fun _ v => mkState (fun s => (v, s))
  ; bind := fun _ _ c1 c2 =>
    mkState (fun s =>
      let (v,s) := runState c1 s in
      runState (c2 v) s)
  }.

  Global Instance MonadState_state : MonadState S state :=
  { get := mkState (fun x => (x,x))
  ; put := fun v => mkState (fun _ => (tt, v))
  }.

  Variable m : Type -> Type.

  Record stateT (t : Type) : Type := mkStateT
  { runStateT : S -> m (t * S)%type }.

  Variable M : Monad m.

  Definition evalStateT {t} (c : stateT t) (s : S) : m t :=
    bind (runStateT c s) (fun x => ret (fst x)).

  Definition execStateT {t} (c : stateT t) (s : S) : m S :=
    bind (runStateT c s) (fun x => ret (snd x)).

  (** [Monad_stateT] is not a Global Instance because it can cause an infinite loop
     in typeclass inference under certain circumstances. Use [Existing Instance
     Monad_stateT.] to bring the instance into context. *)
  Instance Monad_stateT : Monad stateT :=
  { ret := fun _ x => mkStateT (fun s => @ret _ M _ (x,s))
  ; bind := fun _ _ c1 c2 =>
    mkStateT (fun s =>
      @bind _ M _ _ (runStateT c1 s) (fun vs =>
        let (v,s) := vs in
        runStateT (c2 v) s))
  }.

  Global Instance MonadState_stateT : MonadState S stateT :=
  { get := mkStateT (fun x => ret (x,x))
  ; put := fun v => mkStateT (fun _ => ret (tt, v))
  }.

  Global Instance MonadT_stateT : MonadT stateT m :=
  { lift := fun _ c => mkStateT (fun s => bind c (fun t => ret (t, s)))
  }.

  Global Instance State_State_stateT T (MS : MonadState T m) : MonadState T stateT :=
  { get := lift get
  ; put := fun x => lift (put x)
  }.

  Global Instance MonadReader_stateT T (MR : MonadReader T m) : MonadReader T stateT :=
  { ask := mkStateT (fun s => bind ask (fun t => ret (t, s)))
  ; local := fun _ f c => mkStateT (fun s => local f (runStateT c s))
  }.

  Global Instance MonadWriter_stateT T (Mon : Monoid T) (MR : MonadWriter Mon m) : MonadWriter Mon stateT :=
  { tell := fun x => mkStateT (fun s => bind (tell x) (fun v => ret (v, s)))
  ; listen := fun _ c => mkStateT (fun s => bind (listen (runStateT c s))
    (fun x => let '(a,s,t) := x in
    ret (a,t,s)))
  ; pass := fun _ c => mkStateT (fun s => bind (runStateT c s) (fun x =>
    let '(a,t,s) := x in pass (ret ((a,s),t))))
  }.

  Global Instance Exc_stateT T (MR : MonadExc T m) : MonadExc T stateT :=
  { raise := fun _ e => lift (raise e)
  ; catch := fun _ body hnd =>
    mkStateT (fun s => catch (runStateT body s) (fun e => runStateT (hnd e) s))
  }.

  Global Instance MonadZero_stateT (MR : MonadZero m) : MonadZero stateT :=
  { mzero _A := lift mzero
  }.

  Global Instance MonadFix_stateT (MF : MonadFix m) : MonadFix stateT :=
  { mfix := fun _ _ r v =>
    mkStateT (fun s => mfix2 _ (fun r v s => runStateT (mkStateT (r v)) s) v s)
  }.

  Global Instance MonadPlus_stateT (MP : MonadPlus m) : MonadPlus stateT :=
  { mplus _A _B a b :=
      mkStateT (fun s => bind (mplus (runStateT a s) (runStateT b s))
               (fun res => match res with
                             | inl (a,s) => ret (inl a, s)
                             | inr (b,s) => ret (inr b, s)
                           end))
  }.

End StateType.

Arguments mkStateT {S} {m} {t} (_).
Arguments evalState {S} {t} (c) (s).
Arguments execState {S} {t} (c) (s).
Arguments evalStateT {S} {m} {M} {t} (c) (s).
Arguments execStateT {S} {m} {M} {t} (c) (s).
Arguments MonadWriter_stateT {S} {m} {_} {T} {Mon} (_).


From iris Require Import program_logic.weakestpre.
From iris.proofmode Require Import tactics.
From st.STLCmuVS Require Import lang typing wkpre generic.lift contexts logrel.definitions tactics.
From st.STLCmu Require Import types.
From st.prelude Require Import big_op_three.
From st Require Import resources.

Canonical Structure typeO := leibnizO type.

Section definition.

  Context `{Σ : !gFunctors} `{semΣ_inst : !semΣ Σ}.

  (* We define a stuckness-sensistive and insensitive one *)
  Context (s : stuckness).

  Lemma compat_Var (Γ : list type) (x : var) (τ : type) :
    Γ !! x = Some τ → open_exprel_typed s Γ (%x)%Eₙₒ (%x)%Eₙₒ τ.
  Proof.
    intros H. iIntros (vs vs') "Hvsvs".
    iDestruct (big_sepL3_length _ _ _ _ with "Hvsvs") as "[%eq %eq']".
    destruct (Var_subst_list_closed_n_length vs x) as [v [eqv ->]]. apply ids_lt_Closed_n. rewrite -eq. by eapply lookup_lt_Some.
    destruct (Var_subst_list_closed_n_length vs' x) as [v' [eqv' ->]]. apply ids_lt_Closed_n. rewrite -eq' -eq. by eapply lookup_lt_Some.
    rewrite /exprel_typed /=. iApply lift_val.
    iApply ((big_sepL3_lookup _ _ _ _ x _ _ _ H eqv eqv') with "Hvsvs").
  Qed.

  Lemma lift_bind (Kᵢ Kₛ : list ectx_item) (Φ Ψ : valO -n> valO -n> iPropO Σ) (eᵢ eₛ : expr) :
    ⊢ lift s Φ eᵢ eₛ -∗ (∀ vᵢ vₛ, Φ vᵢ vₛ -∗ lift s Ψ (fill Kᵢ (of_val vᵢ)) (fill Kₛ (of_val vₛ))) -∗ lift s Ψ (fill Kᵢ eᵢ) (fill Kₛ eₛ).
  Proof. iIntros "H H2". iApply lift.lift_bind. iFrame. Qed.

  Lemma compat_Unit (Γ : list type) :
    open_exprel_typed s Γ ()%Eₙₒ ()%Eₙₒ TUnit.
  Proof.
    iIntros (vs vs') "Hvsvs". asimpl.
    change ()%Eₙₒ with (of_val ()%Vₙₒ). iApply lift_val.
    by rewrite valrel_typed_TUnit_unfold.
  Qed.

  Lemma compat_Bool (Γ : list type) (b : bool) :
    open_exprel_typed s Γ b b TBool.
  Proof.
    iIntros (vs vs') "Hvsvs". asimpl.
    change (Lit b)%Eₙₒ with (of_val b). iApply lift_val.
    rewrite valrel_typed_TBool_unfold. by iExists _.
  Qed.

  Lemma compat_Int (Γ : list type) (z : Z) :
    open_exprel_typed s Γ z z TInt.
  Proof.
    iIntros (vs vs') "Hvsvs". asimpl.
    change (Lit z)%Eₙₒ with (of_val z). iApply lift_val.
    rewrite valrel_typed_TInt_unfold. by iExists _.
  Qed.

  Lemma compat_BinOp (Γ : list type) (op : bin_op) (e1 e1' e2 e2' : expr) :
      open_exprel_typed s Γ e1 e1' TInt → open_exprel_typed s Γ e2 e2' TInt →
      open_exprel_typed s Γ (BinOp op e1 e2) (BinOp op e1' e2') (binop_res_type op).
  Proof.
    intros IHe1 IHe2.
    iIntros (vs vs') "#Hvsvs".
    iApply (lift_bind [BinOpLCtx op _] [BinOpLCtx op _]). by iApply IHe1. iIntros (v1 v1') "#Hv1".
    iApply (lift_bind [BinOpRCtx op _] [BinOpRCtx op _]). by iApply IHe2. iIntros (v2 v2') "#Hv2".
    rewrite !valrel_typed_TInt_unfold. iDestruct "Hv1" as (z1) "[-> ->]". iDestruct "Hv2" as (z2) "[-> ->]".
    iApply lift_step. auto_STLCmuVS_step.
    iApply lift_step_later. auto_STLCmuVS_step. iNext. simpl.
    iApply lift_val.
    destruct op; simpl; (rewrite valrel_typed_TInt_unfold || rewrite valrel_typed_TBool_unfold); by iExists _.
  Qed.

  Lemma compat_Seq (Γ : list type) (e1 e1' e2 e2' : expr) (τ : type) :
      open_exprel_typed s Γ e1 e1' TUnit → open_exprel_typed s Γ e2 e2' τ →
      open_exprel_typed s Γ (Seq e1 e2) (Seq e1' e2') τ.
  Proof.
    intros IHe1 IHe2.
    iIntros (vs vs') "#Hvsvs".
    iApply (lift_bind [SeqCtx _] [SeqCtx _]). by iApply IHe1. iIntros (v1 v1') "#Hv1".
    rewrite !valrel_typed_TUnit_unfold. iDestruct "Hv1" as "[-> ->]".
    iApply lift_step. auto_STLCmuVS_step.
    iApply lift_step_later. auto_STLCmuVS_step. iNext. simpl.
    by iApply IHe2.
  Qed.

  Lemma compat_Pair (Γ : list type) (e1 e1' e2 e2' : expr) (τ1 τ2 : type) :
      open_exprel_typed s Γ e1 e1' τ1 → open_exprel_typed s Γ e2 e2' τ2 →
      open_exprel_typed s Γ (e1, e2)%Eₙₒ (e1', e2')%Eₙₒ (τ1 × τ2)%Tₙₒ.
  Proof.
    intros IHe1 IHe2.
    iIntros (vs vs') "#Hvsvs".
    iApply (lift_bind [PairLCtx _] [PairLCtx _]). by iApply IHe1. iIntros (v1 v1') "#Hv1".
    iApply (lift_bind [PairRCtx _] [PairRCtx _]). by iApply IHe2. iIntros (v2 v2') "#Hv2".
    simpl. change (of_val ?v1, of_val ?v2)%Eₙₒ with (of_val (PairV v1 v2)). iApply lift_val.
    rewrite valrel_typed_TProd_unfold. repeat iExists _; eauto.
  Qed.

  Lemma compat_Fst (Γ : list type) (e e' : expr) (τ1 τ2 : type) :
      open_exprel_typed s Γ e e' (τ1 × τ2)%Tₙₒ → open_exprel_typed s Γ (Fst e) (Fst e') τ1.
  Proof.
    intros IHe.
    iIntros (vs vs') "#Hvsvs".
    iApply (lift_bind [FstCtx] [FstCtx]). by iApply IHe. iIntros (v v') "#Hv".
    rewrite !valrel_typed_TProd_unfold. iDestruct "Hv" as (v1 v2 v1' v2') "(-> & -> & H1 & H2)".
    iApply lift_step. auto_STLCmuVS_step.
    iApply lift_step_later. auto_STLCmuVS_step. iNext. simplify_custom. by iApply lift_val.
  Qed.

  Lemma compat_Snd (Γ : list type) (e e' : expr) (τ1 τ2 : type) :
      open_exprel_typed s Γ e e' (τ1 × τ2)%Tₙₒ → open_exprel_typed s Γ (Snd e) (Snd e') τ2.
  Proof.
    intros IHe.
    iIntros (vs vs') "#Hvsvs".
    iApply (lift_bind [SndCtx] [SndCtx]). by iApply IHe. iIntros (v v') "#Hv".
    rewrite !valrel_typed_TProd_unfold. iDestruct "Hv" as (v1 v2 v1' v2') "(-> & -> & H1 & H2)".
    iApply lift_step. auto_STLCmuVS_step.
    iApply lift_step_later. auto_STLCmuVS_step. iNext. simplify_custom. by iApply lift_val.
  Qed.

  Lemma compat_InjL (Γ : list type) (e e' : expr) (τ1 τ2 : type) :
    open_exprel_typed s Γ e e' τ1 → open_exprel_typed s Γ (InjL e) (InjL e') (τ1 + τ2)%Tₙₒ.
  Proof.
    intros IHe.
    iIntros (vs vs') "#Hvsvs".
    iApply (lift_bind [InjLCtx] [InjLCtx]). by iApply IHe. iIntros (v1 v1') "#Hv1".
    simpl. change (InjL (of_val ?v))%Eₙₒ with (of_val (InjLV v)). iApply lift_val.
    rewrite valrel_typed_TSum_unfold. repeat iExists _; eauto.
  Qed.

  Lemma compat_InjR (Γ : list type) (e e' : expr) (τ1 τ2 : type) :
    open_exprel_typed s Γ e e' τ2 → open_exprel_typed s Γ (InjR e) (InjR e') (τ1 + τ2)%Tₙₒ.
  Proof.
    intros IHe.
    iIntros (vs vs') "#Hvsvs".
    iApply (lift_bind [InjRCtx] [InjRCtx]). by iApply IHe. iIntros (v2 v2') "#Hv2".
    simpl. change (InjR (of_val ?v))%Eₙₒ with (of_val (InjRV v)). iApply lift_val.
    rewrite valrel_typed_TSum_unfold. repeat iExists _; eauto.
  Qed.

  Lemma compat_Case (Γ : list type) (e0 e0' e1 e1' e2 e2' : expr) (τ1 τ2 τ3 : type) :
      open_exprel_typed s Γ e0 e0' (τ1 + τ2)%Tₙₒ
      → open_exprel_typed s (τ1 :: Γ) e1 e1' τ3
      → open_exprel_typed s (τ2 :: Γ) e2 e2' τ3 → open_exprel_typed s Γ (Case e0 e1 e2) (Case e0' e1' e2') τ3.
  Proof.
    intros IHe0 IHe1 IHe2.
    iIntros (vs vs') "#Hvsvs".
    iApply (lift_bind [CaseCtx _ _] [CaseCtx _ _]). by iApply IHe0. iIntros (v v') "#Hv".
    rewrite !valrel_typed_TSum_unfold. iDestruct "Hv" as (vi vi') "[(-> & -> & H) | (-> & -> & H)]".
    - iApply lift_step. auto_STLCmuVS_step. iApply lift_step_later. auto_STLCmuVS_step. iNext. simplify_custom.
      rewrite !subst_list_val_cons. iApply IHe1. simpl. auto.
    - iApply lift_step. auto_STLCmuVS_step. iApply lift_step_later. auto_STLCmuVS_step. iNext. simplify_custom.
      rewrite !subst_list_val_cons. iApply IHe2. simpl. auto.
  Qed.

  Lemma compat_If (Γ : list type) (e0 e0' e1 e1' e2 e2' : expr) (τ : type) :
    open_exprel_typed s Γ e0 e0' TBool → open_exprel_typed s Γ e1 e1' τ → open_exprel_typed s Γ e2 e2' τ →
    open_exprel_typed s Γ (If e0 e1 e2) (If e0' e1' e2') τ.
  Proof.
    intros IHe0 IHe1 IHe2.
    iIntros (vs vs') "#Hvsvs".
    iApply (lift_bind [IfCtx _ _] [IfCtx _ _]). by iApply IHe0. iIntros (v v') "#Hv".
    rewrite !valrel_typed_TBool_unfold. iDestruct "Hv" as (b) "[-> ->]".
    destruct b; (iApply lift_step; first by auto_STLCmuVS_step); (iApply lift_step_later; first by auto_STLCmuVS_step); iNext; simpl;
      [by iApply IHe1 | by iApply IHe2].
  Qed.

  Lemma compat_LetIn (Γ : list type) (e1 e1' e2 e2' : expr) (τ1 τ2 : type) :
      open_exprel_typed s Γ e1 e1' τ1 → open_exprel_typed s (τ1 :: Γ) e2 e2' τ2 →
      open_exprel_typed s Γ (LetIn e1 e2) (LetIn e1' e2') τ2.
  Proof.
    intros IHe1 IHe2.
    iIntros (vs vs') "#Hvsvs".
    iApply (lift_bind [LetInCtx _] [LetInCtx _]). by iApply IHe1. iIntros (v1 v1') "#Hv1".
    iApply lift_step; first by auto_STLCmuVS_step. iApply lift_step_later; first by auto_STLCmuVS_step. iNext. simplify_custom.
    rewrite !subst_list_val_cons. iApply IHe2. simpl. auto.
  Qed.

  Lemma compat_Lam (Γ : list type) (e e' : expr) (τ1 τ2 : type) :
    open_exprel_typed s (τ1 :: Γ) e e' τ2 →
    open_exprel_typed s Γ (Lam e) (Lam e') (τ1 ⟶ τ2)%Tₙₒ.
  Proof.
    intros IHe.
    iIntros (vs vs') "#Hvsvs". simpl.
    change (Lam ?e) with (of_val (LamV e)). iApply lift_val.
    rewrite valrel_typed_TArrow_unfold. iModIntro. iIntros (w w') "Hww".
    iApply lift_step; first by auto_STLCmuVS_step. iApply lift_step_later; first by auto_STLCmuVS_step. iNext. simplify_custom.
    rewrite !subst_list_val_cons. iApply IHe. simpl. auto.
  Qed.

  Lemma compat_App (Γ : list type) (e1 e1' e2 e2' : expr) (τ1 τ2 : type) :
      open_exprel_typed s Γ e1 e1' (τ1 ⟶ τ2)%Tₙₒ → open_exprel_typed s Γ e2 e2' τ1 →
      open_exprel_typed s Γ (e1 e2) (e1' e2') τ2.
  Proof.
    intros IHe1 IHe2.
    iIntros (vs vs') "#Hvsvs".
    iApply (lift_bind [AppLCtx _] [AppLCtx _]). by iApply IHe1. iIntros (v1 v1') "#Hv1".
    iApply (lift_bind [AppRCtx _] [AppRCtx _]). by iApply IHe2. iIntros (v2 v2') "#Hv2".
    rewrite /= valrel_typed_TArrow_unfold. by iApply "Hv1".
  Qed.

  Lemma compat_Fold (Γ : list type) (e e' : expr) (τ : {bind type}) :
      open_exprel_typed s Γ e e' τ.[TRec τ/] → open_exprel_typed s Γ (Fold e) (Fold e') (TRec τ).
  Proof.
    intros IHe.
    iIntros (vs vs') "#Hvsvs". simpl.
    iApply (lift_bind [FoldCtx] [FoldCtx]). by iApply IHe. iLöb as "IHlob". iIntros (v v') "#Hv".
    simpl. change (Fold (of_val ?v)) with (of_val (FoldV v)). iApply lift_val.
    rewrite valrel_typed_TRec_unfold. repeat iExists _; eauto.
  Qed.

  Lemma compat_Unfold (Γ : list type) (e e' : expr) (τ : {bind type}) :
    open_exprel_typed s Γ e e' (TRec τ) → open_exprel_typed s Γ (Unfold e) (Unfold e') τ.[TRec τ/].
  Proof.
    intros IHe.
    iIntros (vs vs') "#Hvsvs". simpl.
    iApply (lift_bind [UnfoldCtx] [UnfoldCtx]). by iApply IHe. iIntros (v v') "#Hv".
    rewrite valrel_typed_TRec_unfold. iDestruct "Hv" as (w w') "(-> & -> & Hw)".
    iApply lift_step; first by auto_STLCmuVS_step. iApply lift_step_later; first by auto_STLCmuVS_step. iNext. simplify_custom.
    by iApply lift_val.
  Qed.

End definition.

Ltac unfold_valrel_typed :=
  (rewrite valrel_typed_TUnit_unfold) ||
  (rewrite valrel_typed_TBool_unfold) ||
  (rewrite valrel_typed_TInt_unfold) ||
  (rewrite valrel_typed_TArrow_unfold) ||
  (rewrite valrel_typed_TSum_unfold) ||
  (rewrite valrel_typed_TProd_unfold) ||
  (rewrite valrel_typed_TRec_unfold).

Ltac simpl_valrel_typed := fold (valrel_typed_gen_pre); repeat rewrite valrel_typed_gen_pre_gen -valrel_typed_unfold; fold (valrel_typed).


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

Generalizable All Variables.

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

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

(* Converted imports: *)

Require Data.Graph.Inductive.Graph.
Require Data.Graph.Inductive.Internal.Heap.
Require Data.Graph.Inductive.Internal.RootPath.
Require GHC.Base.
Require GHC.Err.
Require GHC.Num.
Require GHC.Real.
Require HsToCoq.DeferredFix.
Require HsToCoq.Err.
Import GHC.Base.Notations.
Import GHC.Num.Notations.

(* No type declarations to convert. *)

(* Midamble *)

Program Instance Dijkstra_Default {b} `{Err.Default b} : Err.Default (b * Data.Graph.Inductive.Graph.LPath b *
                                    Data.Graph.Inductive.Internal.Heap.Heap b (Data.Graph.Inductive.Graph.LPath b)).
Next Obligation.
destruct H. apply (default, Data.Graph.Inductive.Graph.LP nil, Data.Graph.Inductive.Internal.Heap.empty).
Defined.
(* Converted value declarations: *)

Definition expand {b} {a} `{(GHC.Real.Real b)}
   : b ->
     Data.Graph.Inductive.Graph.LPath b ->
     Data.Graph.Inductive.Graph.Context a b ->
     list (Data.Graph.Inductive.Internal.Heap.Heap b
           (Data.Graph.Inductive.Graph.LPath b)) :=
  fun arg_0__ arg_1__ arg_2__ =>
    match arg_0__, arg_1__, arg_2__ with
    | d, Data.Graph.Inductive.Graph.LP p, pair (pair (pair _ _) _) s =>
        GHC.Base.map (fun '(pair l v) =>
                        Data.Graph.Inductive.Internal.Heap.unit (l GHC.Num.+ d)
                        (Data.Graph.Inductive.Graph.LP (cons (pair v (l GHC.Num.+ d)) p))) s
    end.

Definition dijkstra {gr} {b} {a} `{Data.Graph.Inductive.Graph.Graph gr}
  `{GHC.Real.Real b} `{HsToCoq.Err.Default b}
   : Data.Graph.Inductive.Internal.Heap.Heap b (Data.Graph.Inductive.Graph.LPath
                                              b) ->
     gr a b -> Data.Graph.Inductive.Internal.RootPath.LRTree b :=
  HsToCoq.DeferredFix.deferredFix2 (fun dijkstra
                                    (arg_0__
                                      : Data.Graph.Inductive.Internal.Heap.Heap b (Data.Graph.Inductive.Graph.LPath
                                                                                b))
                                    (arg_1__ : gr a b) =>
                                      match arg_0__, arg_1__ with
                                      | h, g =>
                                          if orb (Data.Graph.Inductive.Internal.Heap.isEmpty h)
                                             (Data.Graph.Inductive.Graph.isEmpty g) : bool then nil else (match arg_0__
                                                                                , arg_1__ with
                                                                                | h, g =>
                                                                                match Data.Graph.Inductive.Internal.Heap.splitMin
                                                                                h with
                                                                                | pair (pair _
                                                                                (Data.Graph.Inductive.Graph.LP
                                                                                (cons (pair v d)
                                                                                _) as p)) h' =>
                                                                                match Data.Graph.Inductive.Graph.match_
                                                                                v g with
                                                                                | pair (Some c)
                                                                                g' =>
                                                                                cons p (dijkstra
                                                                                (Data.Graph.Inductive.Internal.Heap.mergeAll
                                                                                (cons h'
                                                                                (expand
                                                                                d
                                                                                p
                                                                                c)))
                                                                                g')
                                                                                | pair None g' =>
                                                                                dijkstra h' g'
                                                                                end
                                                                                | _ =>
                                                                                GHC.Err.patternFailure
                                                                                end
                                                                                end)
                                      end).

Definition spTree {gr : Type -> Type -> Type} {b : Type} {a : Type}
  `{Data.Graph.Inductive.Graph.Graph gr} `{GHC.Real.Real b}
   : Data.Graph.Inductive.Graph.Node ->
     gr a b -> Data.Graph.Inductive.Internal.RootPath.LRTree b :=
  fun v =>
    dijkstra (Data.Graph.Inductive.Internal.Heap.unit #0
              (Data.Graph.Inductive.Graph.LP (cons (pair v #0) nil))).

Definition spLength {gr : Type -> Type -> Type} {b : Type} {a : Type}
  `{Data.Graph.Inductive.Graph.Graph gr} `{GHC.Real.Real b}
   : Data.Graph.Inductive.Graph.Node ->
     Data.Graph.Inductive.Graph.Node -> gr a b -> option b :=
  fun s t =>
    Data.Graph.Inductive.Internal.RootPath.getDistance t GHC.Base.∘ spTree s.

Definition sp {gr : Type -> Type -> Type} {b : Type} {a : Type}
  `{Data.Graph.Inductive.Graph.Graph gr} `{GHC.Real.Real b}
   : Data.Graph.Inductive.Graph.Node ->
     Data.Graph.Inductive.Graph.Node ->
     gr a b -> option Data.Graph.Inductive.Graph.Path :=
  fun s t g =>
    match Data.Graph.Inductive.Internal.RootPath.getLPathNodes t (spTree s g) with
    | nil => None
    | p => Some p
    end.

(* External variables:
     None Some Type bool cons else if list nil option orb pair then
     Data.Graph.Inductive.Graph.Context Data.Graph.Inductive.Graph.Graph
     Data.Graph.Inductive.Graph.LP Data.Graph.Inductive.Graph.LPath
     Data.Graph.Inductive.Graph.Node Data.Graph.Inductive.Graph.Path
     Data.Graph.Inductive.Graph.isEmpty Data.Graph.Inductive.Graph.match_
     Data.Graph.Inductive.Internal.Heap.Heap
     Data.Graph.Inductive.Internal.Heap.isEmpty
     Data.Graph.Inductive.Internal.Heap.mergeAll
     Data.Graph.Inductive.Internal.Heap.splitMin
     Data.Graph.Inductive.Internal.Heap.unit
     Data.Graph.Inductive.Internal.RootPath.LRTree
     Data.Graph.Inductive.Internal.RootPath.getDistance
     Data.Graph.Inductive.Internal.RootPath.getLPathNodes GHC.Base.map
     GHC.Base.op_z2218U__ GHC.Err.patternFailure GHC.Num.fromInteger GHC.Num.op_zp__
     GHC.Real.Real HsToCoq.DeferredFix.deferredFix2 HsToCoq.Err.Default
*)