(*
 * Copyright (C) BedRock Systems Inc. 2019-2021

 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)
From Coq Require Import ZArith.BinInt Lists.List.

From iris.proofmode Require Import proofmode.

Require Import bedrock.prelude.base.
From bedrock.lang.bi Require Import prelude observe.
From bedrock.lang.cpp.semantics Require Import values.
From bedrock.lang.cpp.logic Require Import arr heap_pred (* pred *).

Import ChargeNotation.
#[local] Open Scope Z_scope.

(** * [zstring]s

    [zstring]s reflect the "character array" which backs null-terminated strings
    in C++. These arrays include the null-terminator
 *)
Module zstring.
  Definition t := list N.
  Bind Scope list_scope with t.

Section with_ct.
  Variable ct : char_type.
  #[local] Notation Tchar := (Tchar_ ct).

  (* [size] reflects the in-memory footprint of the null-terminated string (i.e. the
     length is one greater than that of the string as given by `std::strlen`).
   *)
  Definition _size (zs : t) : Z :=
    Z.of_nat (List.length zs).
  #[global] Arguments _size zs : simpl never.
  Notation size zs := (_size zs%Z).

  (* [strlen] mirrors the behavior of the standard-library function of the same name
     (i.e. the length DOES NOT include the null-terminator).
   *)
  Definition _strlen (zs : t) : Z :=
    (size zs - 1)%Z.
  #[global] Arguments _strlen zs : simpl never.
  Notation strlen zs := (_strlen zs%Z).

  Definition _WF_alt {σ : genv} (zs : t) : Prop :=
    let zs' := take (length zs - 1) zs in
    last zs = Some 0%N /\ 0%N ∉ zs' /\
    List.Forall (λ c, 0 <= c < 2 ^ char_type.bitsN ct)%N zs'.
  #[global] Instance _WF_alt_dec {σ : genv} zs : Decision (_WF_alt zs) := _.

  Definition _WF {σ : genv} (zs : t) : Prop :=
    exists zs', zs = zs' ++ [0]%N /\ not (In 0%N zs') /\
    List.Forall (λ c : N, has_type (Vchar c) Tchar) zs.
  #[global] Arguments _WF {σ} zs : simpl never.

  Lemma _WF_WF_alt {σ : genv} zs : _WF zs <-> _WF_alt zs.
  Proof.
    rewrite /_WF /_WF_alt elem_of_list_In; setoid_rewrite <-has_type_char'; split. {
      move=> [] zs' [] -> [].
      rewrite last_app /= app_length Nat.add_sub take_app Forall_app Forall_singleton.
      naive_solver.
    }
    move=> [] Hl [] Hin Hall; exists (take (length zs - 1) zs).
    destruct zs as [|z zs] using rev_ind => //= {IHzs}.
    move: Hl Hin Hall;
      rewrite last_app app_length /=. rewrite Nat.add_sub take_app.
      rewrite Forall_app Forall_singleton.
    intros [= ->]; intros; split_and! => //.
    lia.
  Qed.

  Notation WF zs := (_WF zs%N).
  #[global, program] Instance _WF_dec {σ : genv} zs : Decision (_WF zs) :=
    cast_if (decide (_WF_alt zs)).
  Solve All Obligations with intros; exact /_WF_WF_alt.

  (* this definition is less intensional, and seems to work more
     smoothly wrt. automation: *)
  Definition _WF' {σ : genv} (zs : t) : Prop :=
    (exists v, nth_error zs 0 = Some v) /\
    (forall i, Z.of_nat i <= strlen zs ->
          exists z, nth_error zs i = Some z /\ has_type (Vchar z) Tchar) /\
    (forall i, Z.of_nat i < strlen zs ->
          exists z, nth_error zs i = Some z /\ z <> 0%N) /\
    forall i, Z.of_nat i = strlen zs -> nth_error zs i = Some 0%N.
  #[global] Arguments _WF' {σ} zs : simpl never.
  Notation WF' zs := (_WF' zs%Z).

  Section WF_Theory.
    Context {σ : genv}.
    Remark not_WF_nil : not (WF []).
    Proof.
      rewrite /_WF; intro CONTRA;
        destruct CONTRA as [? [CONTRA ?]];
        eapply app_cons_not_nil; eauto.
    Qed.

    Remark WF_singleton : WF [0%N].
    Proof.
      rewrite /_WF; exists []; repeat split.
      - intro CONTRA; by inversion CONTRA.
      - repeat constructor. apply has_type_char_0.
    Qed.

    Lemma WF_singleton_inj :
      forall (z : N),
        WF [z] ->
        z = 0%N.
    Proof.
      intros * [zs [Hzs [Hin Hbounds]]].
      destruct zs; simpl in *; inversion Hzs.
      - reflexivity.
      - exfalso; eapply app_cons_not_nil; by eauto.
    Qed.

    Lemma WF_nonempty_inj :
      forall (zs : t),
        WF zs ->
        exists z zs', zs = z :: zs'.
    Proof.
      move=> zs Hzstring; induction zs; [ | by eauto].
      unfold WF in Hzstring.
      destruct Hzstring as [? [CONTRA ?]].
      now apply app_cons_not_nil in CONTRA.
    Qed.

    Lemma WF_cons :
      forall (z : N) (zs : t),
        (z <> 0)%N ->
        has_type (Vchar z) Tchar ->
        WF (z :: zs) <->
        WF zs.
    Proof.
      intros * Hnonzero Hz; split; [intro WF_zs | intro WF_z]; unfold WF in *.
      - destruct WF_zs as [zs' [Hzs' [Hin Hbounds]]].
        exists (tail zs'); split; destruct zs'=> //=;
          [rewrite app_nil_l in Hzs' | | |];
          inversion Hzs'=> //.
        split.
        + intro; apply Hin=> //=; auto.
        + inversion Hbounds; by subst.
      - destruct WF_z as [zs' [Hzs' [Hin Hbounds]]];
          exists (z :: zs'); split.
        + by subst.
        + split.
          * intro CONTRA; apply Hin; by inversion CONTRA.
          * by constructor.
    Qed.

    (* Unlike WF_cons, here the explicit tail [++ [0]] lets us write a more elegant lemma. *)
    Lemma WF_cons' (z : N) (zs : t) :
      WF (z :: zs ++ [0%N]) <->
      (z <> 0)%N /\ has_type (Vchar z) Tchar /\ WF (zs ++ [0%N]).
    Proof.
      rewrite /_WF/=. setoid_rewrite Forall_cons.
      split.
      - case => [[|z' zs'] [/= [-> Hzs']]]; first by destruct zs.
        move: Hzs' => /(app_inj_2 _ _ _ _ eq_refl) [-> _].
        move=> [/Decidable.not_or [Hz Hin] [Hz'Bounds Hrest]].
        split_and! => //.
        by exists zs'.
      - case => Hz [HzBounds] [] zs' [] /(app_inj_2 _ _ _ _ eq_refl) [-> _] [Hin].
        exists (z :: zs'); split_and! => //.
        intros ?%in_inv. naive_solver.
    Qed.

    (* WF is prefix-free predicate *)
    Lemma WF_eq_prefix_eq a1 a2 :
      WF a1
      -> WF a2
      -> a1 = take (length a1) a2
      -> a1 = a2.
    Proof.
      move=>[xs [-> [Nin _]]] [xs' [-> [Nin' _]]] H.
      f_equal; move: xs' H Nin'.
      rewrite app_length //= Nat.add_1_r.
      induction xs.
      - by case=>[//|??[<-][]];left.
      - rewrite -app_comm_cons.
        case; first by case: (xs).
        move=>a' l' [<-] ? Hin'; f_equal.
        apply: IHxs=>//= ?.
        + by apply: Nin; right.
        + by apply: Hin'; right.
    Qed.

  End WF_Theory.

  Section size_Theory.
    Context {σ : genv}.

    (* Use [rewrite size_unfold/=] to reduce away a [size] application to a
       concrete string; if complete reduction is not possible, this is
       equivalent to unfolding the [size] notation.
     *)
    Lemma size_unfold (zs : t) :
      size zs = Unfold _size (size zs).
    Proof. by unfold size. Qed.

    Lemma size_strlen (zs : t) :
      size zs = strlen zs + 1.
    Proof. unfold strlen; by rewrite Z.sub_simpl_r. Qed.

    Remark size_nil : size [] = 0.
    Proof. by rewrite size_unfold. Qed.

    Lemma size_cons :
      forall (z : N) (zs : t),
        size (z :: zs) = 1 + size zs.
    Proof. intros *; rewrite !size_unfold/=; by lia. Qed.

    Lemma size_cons':
      forall (z : N) (zs : t),
        (z <> 0)%N ->
        WF (z :: zs) ->
        Z.to_nat (size (z :: zs)) = S (Z.to_nat (size zs)).
    Proof.
      move=> z zs Hz Hzstring; inversion Hzstring as [zs' [Hzs' HIn]];
        unfold strlen, size; simpl.
      replace ((length zs + 1)%nat - 1)%Z
        with (Z.of_nat (length zs))
        by lia.
      destruct zs=> //=.
      lia.
    Qed.

    Lemma size_app :
      forall (zs zs' : t),
        size (zs ++ zs') = size zs + size zs'.
    Proof.
      intros *; induction zs as [| z zs'' IHzs'']; simpl in *.
      - by rewrite size_nil Z.add_0_l.
      - by rewrite !size_cons IHzs'' Z.add_assoc.
    Qed.

    Lemma size_nil_cons_contra :
      forall (z : _) (zs : t),
        not (size (z :: zs) = size []).
    Proof. intros *; intro CONTRA; unfold size in CONTRA; by inversion CONTRA. Qed.

    Lemma size_nonneg : forall (zs : t), (0 <= size zs).
    Proof. intros *; destruct zs; unfold size; simpl; by lia. Qed.

    Lemma size_neg_inj : forall (zs : t), (0 = size zs)%Z -> zs = [].
    Proof. move=> [ | a s] Hlen=> //. Qed.
  End size_Theory.

  Section strlen_Theory.
    Context {σ : genv}.

    (* Use [rewrite strlen_unfold/=] to reduce away a [strlen] application to a
       concrete string; if complete reduction is not possible, this is
       equivalent to unfolding the [strlen] notation.
     *)
    Lemma strlen_unfold (zs : t) :
      strlen zs = Unfold _size (Unfold _strlen (strlen zs)).
    Proof. by unfold strlen. Qed.

    Lemma strlen_size (zs : t) :
      strlen zs = size zs - 1.
    Proof. by unfold strlen. Qed.

    Remark strlen_nil : strlen [] = -1.
    Proof. by rewrite strlen_unfold. Qed.

    Lemma strlen_cons (zs : t) :
      forall (z : _),
        strlen (z :: zs) = 1 + strlen zs.
    Proof. intros *; rewrite !strlen_unfold/=; by lia. Qed.

    Lemma strlen_cons':
      forall (z : N) (zs : t),
        (z <> 0)%N ->
        WF (z :: zs) ->
        Z.to_nat (strlen (z :: zs)) = S (Z.to_nat (strlen zs)).
    Proof.
      move=> z zs Hz Hzstring; inversion Hzstring as [zs' [Hzs' HIn]];
        unfold strlen, size; simpl.
      replace ((length zs + 1)%nat - 1)%Z
        with (Z.of_nat (length zs))
        by lia.
      destruct zs=> //=.
      - apply WF_singleton_inj in Hzstring; subst; lia.
      - lia.
    Qed.

    Lemma strlen_app :
      forall (zs zs' : t),
        strlen (zs ++ zs') = size zs + strlen zs'.
    Proof.
      intros *; induction zs as [| z zs'' IHzs'']; simpl in *.
      - rewrite !size_unfold !strlen_unfold/=; by lia.
      - by rewrite !strlen_cons !size_cons IHzs'' Z.add_assoc.
    Qed.

    Lemma strlen_nil_cons_contra :
      forall (z : _) (zs : t),
        not (strlen (z :: zs) = strlen []).
    Proof.
      intros *.
      unfold strlen.
      pose proof (size_nil_cons_contra z zs).
      by lia.
    Qed.

    Lemma strlen_lowerbound : forall (zs : t), (-1 <= strlen zs)%Z.
    Proof.
      intros *; destruct zs;
        unfold strlen, size;
        simpl; by lia.
    Qed.

    Lemma strlen_nonneg : forall (zs : t),
        WF zs ->
        (0 <= strlen zs).
    Proof.
      intros * Hzstring.
      inversion Hzstring as [zs' [Hzs' HIn]].
      rewrite Hzs' strlen_app.
      pose proof (strlen_lowerbound zs').
      pose proof (size_nonneg zs').
      unfold strlen; unfold size at 2.
      simpl; by lia.
    Qed.

    Lemma strlen_neg_inj : forall (zs : t), (-1 = strlen zs)%Z -> zs = [].
    Proof.
      move=> [ | a s] Hlen=> //; exfalso.
      pose proof (strlen_nil_cons_contra a s) as H.
      apply H; by rewrite strlen_nil.
    Qed.
  End strlen_Theory.

  Section WFs_equiv_Theory.
    Context {σ : genv}.
    Section helpers.
      Lemma len0_take (zs : t)
            (H0 : 0 < List.length zs)
            (H : forall i : nat, Z.of_nat i = strlen zs -> nth_error zs i = Some 0%N) :
        zs = take (List.length zs - 1) zs ++ [0%N].
      Proof.
        rewrite -[zs](firstn_skipn (List.length zs - 1)). f_equal.
        { rewrite app_length take_length drop_length.
          set x := List.length zs.
          have ->: ((x - 1) `min` x + (x - (x - 1)) - 1 = x - 1)%nat by lia.
            by rewrite firstn_skipn. }
        elim: zs H0 H; first by inversion 1.
        move => z zs IH /= H0 H. have ->: (List.length zs - 0 = List.length zs)%nat by lia.
        destruct zs; first by move: (H 0%nat eq_refl); inversion 1.
        destruct zs; first by move: (H 1%nat eq_refl); inversion 1.
        apply: IH; first by simpl; lia.
        case; unfold strlen, size; rewrite /List.length -/List.length; first by lia.
        move => n' ?. simpl. move: (H (S (S n'))). apply.
        rewrite Nat2Z.inj_succ; unfold strlen, size; rewrite /List.length -/List.length. lia.
      Qed.

      Lemma forall_not0 (zs : t)
            (H : ∀ i : nat, (i <= strlen zs)%Z →
                          ∃ z : N, nth_error zs i = Some z ∧ has_type (Vchar z) Tchar)
            (H' : forall i : nat, (i < strlen zs)%Z ->
                          ∃ z : N, nth_error zs i = Some z /\ z <> 0%N):
        List.Forall (fun z : N => z <> 0%N /\ has_type (Vchar z) Tchar) (take (List.length zs - 1) zs).
      Proof.
        induction zs; first by constructor.
        simpl. have ->: (List.length zs - 0 = List.length zs)%nat by lia. destruct zs.
        { simpl. constructor. }
        simpl. constructor.
        { move: (H 0%nat); case.
          { unfold strlen, size; rewrite /List.length -/List.length. lia. }
            move => x /= []; inversion 1; subst; intuition.
            specialize (H' 0%nat ltac:(rewrite !strlen_cons;
                                     pose proof (strlen_lowerbound zs);
                                     by lia)) as [? [? CONTRA]];
              simpl in *; inversion H1; congruence. }
        have <-: (List.length zs - 0 = List.length zs)%nat by lia. apply: IHzs.
        case.
        { move => h1; exists n. split => //.
          destruct zs. 1: {
            specialize (H 1%nat ltac:(rewrite strlen_unfold/=; lia))
              as [z' [Hnth Htype]].
            simpl in Hnth; inversion Hnth; by subst.
          }
          move: (H 1%nat); unfold strlen, size; case => //.
          { rewrite /List.length -/List.length. lia. }
            by move => x /=; case; inversion 1; subst. }
        move => n'; unfold strlen, size; rewrite /List.length -/List.length => h.
        move: (H (S (S n'))); case.
        { unfold strlen, size; rewrite /List.length -/List.length. lia. }
        move => x /=; case => h1 h2; exists x; split => //.
        intros i Hstrlen.
        rewrite [strlen (_ :: _ :: _)]strlen_cons in H'.
        specialize (H' (S i) ltac:(lia)) as [x [? ?]].
        exists x; by intuition.
      Qed.

      Lemma nth_error_strlen_contra :
        forall (n : nat) (zs : t),
          strlen zs < Z.of_nat n ->
          forall z, not (nth_error zs n = Some z).
      Proof.
        intros n; induction n; intros **.
        - destruct zs=> //.
          rewrite strlen_cons in H.
          pose proof (strlen_lowerbound zs).
          by lia.
        - destruct zs=> //.
          simpl; apply IHn.
          rewrite strlen_cons in H.
          pose proof (strlen_lowerbound zs).
          by lia.
      Qed.
    End helpers.

    Lemma WFs_equiv (zs : t) : WF' zs <-> WF zs.
    Proof.
      (* this is a horrible proof *)
      unfold WF, WF'; split.
      { case; case => x h1 []h2 []h3 h4.
        exists (take (List.length zs - 1) zs). repeat split.
        { apply: len0_take => //.
          clear - h1; case: zs h1 => //= a l _; lia. }
        2: {
          apply List.Forall_forall; intros z Hin.
          pose proof (In_nth_error zs z Hin) as [n Hnth].
          assert (n < strlen zs \/ Z.of_nat n = strlen zs \/ strlen zs < n)
            as [Hn | [Hn | Hn]] by lia.
          - specialize (h2 n ltac:(lia)) as [? ?]; intuition; congruence.
          - specialize (h4 n Hn).
            rewrite h4 in Hnth; inversion Hnth.
            apply has_type_char_0.
          - exfalso; eapply nth_error_strlen_contra; by eauto.
        }
        suff: List.Forall (fun x => x <> 0%N /\ has_type (σ:=σ) (Vchar x) Tchar)
                          (take (Datatypes.length zs - 1) zs).
        { clear - zs. elim: zs => //= [_ [] //|a zs IH /=]. rewrite Nat.sub_0_r.
          destruct zs as [|z zs]; first done. move => /= /Forall_cons [[??]?].
          move => [//|]. simpl in IH. rewrite Nat.sub_0_r in IH. apply IH. done. }
        apply: forall_not0. apply h2. apply h3. }
      case => zs' []-> h1. split.
      { destruct zs'; simpl; first by exists 0%N.
        by exists n. }
      split.
      { move => i. unfold strlen, size; rewrite app_length Nat2Z.inj_add /= => h2.
        assert (i < List.length zs' \/ i = List.length zs')%nat
          as [h2' | h2'] by lia; clear h2. 2: {
          subst; exists 0%N; clear h1; split.
          - by induction zs'=> //=.
          - apply has_type_char_0.
        }
        rewrite nth_error_app1 => //.
        elim: zs' i h1 h2' => /=; first by lia.
        move => a lx IH i h1 h2. destruct i.
        { exists a; split => //.
          inversion h1 as [? Hforall].
          apply Forall_cons in Hforall.
          by intuition. }
        case: (IH i). 1: {
          split.
          - move => X; apply h1; by right.
          - destruct h1 as [? Hforall]; by apply List.Forall_inv_tail in Hforall. }
        1: by lia.
        move => x []h3 h4; exists x => /=; split => //. }

      split. 1: {
        move => i; unfold strlen, size.
        rewrite app_length/=; intros Hi.
        assert (i < length zs')%nat as Hzs' by lia; clear Hi.
        pose proof (nth_error_app1 zs' [0%N] Hzs') as Hnth.
        pose proof (nth_In zs' 0%N Hzs') as Hin.
        rewrite Hnth; erewrite nth_error_nth' with (d:=0%N); eauto; eexists;
          split; eauto.
        intro CONTRA; rewrite CONTRA in Hin.
        inversion h1; by congruence.
      }
      move => i; unfold strlen, size.
      rewrite app_length Nat2Z.inj_add /= => h2.
      have ->: i = List.length zs' by lia. clear h2.
      rewrite nth_error_app2 //.
      have ->: (List.length zs' - List.length zs' = 0)%nat by lia. by [].
    Qed.

    Lemma WF'_singleton_inj :
      forall (z : N),
        WF' [z] ->
        z = 0%N.
    Proof. intros *; rewrite WFs_equiv; by apply WF_singleton_inj. Qed.

    Remark not_WF'_nil : not (WF' []).
    Proof. rewrite WFs_equiv; by apply not_WF_nil. Qed.

    Lemma WF'_nonempty_inj :
      forall (zs : t),
        WF' zs ->
        exists z zs', zs = z :: zs'.
    Proof. intros *; rewrite WFs_equiv; by apply WF_nonempty_inj. Qed.

    Lemma WF'_cons :
      forall (z : _) (zs : t),
        (z <> 0)%N ->
        has_type (Vchar z) Tchar ->
        WF' (z :: zs) <->
        WF' zs.
    Proof. intros *; rewrite !WFs_equiv; by apply WF_cons. Qed.
  End WFs_equiv_Theory.

  Section with_Σ.
    Context `{Σ : cpp_logic} `{σ : genv}.

    (* The toplevel definition of [zstring.bufR]: *)

    Definition bufR (q : cQp.t) (sz : Z) (zs : t) : Rep :=
      [| size zs <= sz |] **
      arrayR Tchar (fun c => primR Tchar q (Vchar c)) zs ** [| WF zs |] **
      .[Tchar ! size zs]
         |-> arrayR Tchar (fun _ => primR Tchar q (Vchar 0)) (repeat () (Z.to_nat (sz - size zs))).
    (* The toplevel definition of [zstring.bufR']: *)
    Definition bufR' (q : cQp.t) (sz : Z) (zs : t) : Rep :=
      [| size zs <= sz |] **
      arrayR Tchar (fun c => primR Tchar q (Vchar c)) zs ** [| WF' zs |] **
      .[Tchar ! size zs]
         |-> arrayR Tchar (fun _ => primR Tchar q (Vchar 0)) (repeat () (Z.to_nat (sz - size zs))).

    #[global] Instance bufR_WF_observe :
      forall q (sz : Z) (zs : t),
        Observe [| WF zs |] (bufR q sz zs).
    Proof. refine _. Qed.

    #[global] Instance bufR'_WF_observe :
      forall q (sz : Z) (zs : t),
        Observe [| WF' zs |] (bufR' q sz zs).
    Proof. refine _. Qed.

    Lemma bufRs_equiv (q : cQp.t) (sz : Z) (zs : t) :
      bufR q sz zs -|- bufR' q sz zs.
    Proof. intros *; by rewrite /bufR/bufR' WFs_equiv. Qed.

    (* The toplevel definition of [zstring.R]: *)
    Definition R (q : cQp.t) (zs : t) : Rep :=
      arrayR Tchar (fun c => primR Tchar q (Vchar c)) zs ** [| WF zs |].
    (* The toplevel definition of [zstring.R']: *)
    Definition R' (q : cQp.t) (zs : t) : Rep :=
      arrayR Tchar (fun c => primR Tchar q (Vchar c)) zs ** [| WF' zs |].

    #[global] Instance R_WF_observe :
      forall q (zs : t),
        Observe [| WF zs |] (R q zs).
    Proof. refine _. Qed.

    #[global] Instance R'_WF'_observe :
      forall q (zs : t),
        Observe [| WF' zs |] (R' q zs).
    Proof. refine _. Qed.

    Lemma Rs_equiv :
      forall (q : cQp.t) (zs : t),
        R q zs -|- R' q zs.
    Proof. intros *; by rewrite /R/R' WFs_equiv. Qed.

    Section Theory.
      #[local] Open Scope string_scope.

      Section bufR.
        Remark bufR_nil : forall (q : cQp.t) (sz : Z), bufR q sz [] |-- False.
        Proof.
          intros *.
          iIntros "rest"; rewrite /bufR.
          iDestruct "rest" as "(?&?& %CONTRA &?)".
          by apply not_WF_nil in CONTRA.
        Qed.

        (* TODO (AUTO): Investigate whether or not this hint actually fires. *)
        #[global] Instance bufR_sz_contra :
          forall (q : cQp.t) (sz : Z) (zs : t),
            Observe2 False [| sz < size zs |] (bufR q sz zs).
        Proof. intros *; rewrite /Observe2/bufR; iIntros "%H [%CONTRA ?]"; by lia. Qed.

        #[global] Instance bufR_singleton :
          forall (q : cQp.t) (sz : Z) (z : _),
            Observe [| z = 0%N |] (bufR q sz [z]).
        Proof.
          intros *; rewrite /Observe/bufR; iIntros "(% & Hz & %HWF & rest)".
          iModIntro; iPureIntro; by apply WF_singleton_inj.
        Qed.

        Lemma bufR_cons :
          forall (q : cQp.t) (sz : Z) (z : _) (zs : t),
            z <> 0%N ->
            bufR q sz (z :: zs) -|-
            primR Tchar q (Vchar z) ** .[Tchar ! 1] |-> bufR q (sz - 1) zs.
        Proof.
          intros * Hz; split'.
          - rewrite /bufR arrayR_cons.
            iIntros "[%Hsz [[? [Hz Hzs]] [%HWF Hrest]]]".
            assert (size zs <= sz - 1) by (rewrite size_cons in Hsz; by lia).
            iDestruct (observe [| has_type (Vchar z) _ |] with "Hz") as "%".
            assert (WF zs) by (apply WF_cons in HWF; assumption).
            rewrite !_offsetR_sep !_offsetR_only_provable
                    size_cons -_offsetR_sub_sub
                    Z.sub_add_distr.
              iFrame "∗%".
          - rewrite /bufR arrayR_cons !_offsetR_sep !_offsetR_only_provable;
              iIntros "[H [%Hsz [? [%HWF Hrest]]]]".
            iDestruct (observe (type_ptrR Tchar) with "H") as "#?".
            assert (size (z :: zs) <= sz) by (rewrite size_cons; by lia).
            iDestruct (observe [| has_type (Vchar z) _ |] with "H") as "%".
            assert (WF (z :: zs)) by (apply WF_cons; assumption).
            rewrite size_cons -!_offsetR_sub_sub Z.sub_add_distr.
            iFrame "∗#%"; iPureIntro; by lia.
        Qed.

        #[global] Instance bufR_cons_cons_head_nonzero :
          forall (q : cQp.t) (sz : Z) (z z' : _) (zs : t),
            Observe [| z <> 0 |]%N (bufR q sz (z :: z' :: zs)).
        Proof.
          intros *.
          apply: observe_intro_only_provable.
          rewrite /bufR; unfold WF; iIntros "[%Hsz [Hzs [%WF Hrest]]]"; iPureIntro.
          destruct WF as [zs' [Hzs' HIn]].
          destruct zs'=> //=.
          inversion Hzs'.
          intro CONTRA; apply HIn; subst.
            by constructor.
        Qed.

        Lemma bufR_has_type :
          forall (q : cQp.t) (sz : Z) (zs : t),
            strlen zs < sz ->
                bufR q sz zs
            |-- bufR q sz zs ** [| List.Forall (fun c => has_type (Vchar c) Tchar) zs |].
        Proof.
          intros **; generalize dependent sz; induction zs; intros **.
          - rewrite {1}bufR_nil; by iIntros.
          - destruct zs=> //=.
            + iIntros "H"; iDestruct (observe [| a = 0 |]%N with "H") as "%H'".
              iFrame "∗"; iPureIntro.
              try repeat constructor; subst.
              apply has_type_char_0.
            + iIntros "H"; iDestruct (observe [| WF (a :: n :: zs) |] with "H") as "%H'".
              assert (1 <= size (a :: n :: zs)). {
                rewrite -> size_cons in *.
                pose proof (size_nonneg (n :: zs)).
                by lia.
              }
              iDestruct (observe [| a <> 0 |]%N with "H") as "%H''"; iStopProof.
              rewrite {1}bufR_cons; auto; rewrite primR_has_type IHzs.
              iIntros "[[? %has_type] ?]"; iStopProof.
              rewrite _offsetR_sep _offsetR_only_provable.
              iIntros "[head [tail %has_types]]"; iCombine "head tail" as "H".
              rewrite -bufR_cons; [| done]; iFrame "∗"; iPureIntro.
              apply Forall_cons_2; auto.
              rewrite -> !strlen_cons in *.
              pose proof (size_nonneg (n :: zs)).
              by lia.
        Qed.

        (* TODO (AUTO): Fix this once we add the correct observations for arrayR *)
        #[global] Instance bufR_type_ptrR_observe :
          forall q (sz : Z) (zs : t),
            Observe (type_ptrR Tchar) (bufR q sz zs).
        Proof.
          move=> q sz zs; rewrite /bufR; destruct zs.
          - rewrite /Observe. iIntros "[? [? [%CONTRA ?]]]";
              exfalso; now apply not_WF_nil.
          - rewrite arr.arrayR_cons; refine _.
        Qed.

        #[global] Instance bufR_validR_end_observe :
          forall q (sz : Z) (zs : t),
            Observe (.[Tchar ! sz] |-> validR) (bufR q sz zs).
        Proof.
          move=> q sz zs; rewrite /bufR/Observe.
          iIntros "[%Hsz [array [%HWF rest]]]".
          iAssert (arrayR Tchar (fun c => primR Tchar q (Vchar c))
                          (zs ++ repeat 0%N (Z.to_nat (sz - size zs))))
            with "[array rest]" as "array'". 2: {
            assert (Z.to_nat sz <= length (zs ++ repeat 0%N (Z.to_nat (sz - size zs))))%nat
              as AUX. 1: {
              rewrite app_length repeat_length.
              unfold strlen in Hsz.
              unfold size in *.
              lia.
            }
            pose proof (arrayR_valid_obs (λ c : N, primR Tchar q (Vchar c)) Tchar (Z.to_nat sz)
                                         (zs ++ repeat 0%N (Z.to_nat (sz - size zs)))
                                         AUX).
            iDestruct (observe (.[ Tchar ! sz ] |-> validR) with "array'")
              as "#?"; auto.
            rewrite Z2Nat.id in H; auto.
            pose proof (size_nonneg zs).
            lia.
          }
          rewrite arrayR_eq/arrayR_def fmap_app arrR_append fmap_length; unfold size.
          iFrame.
          rewrite arrR_proper; [by iFrame |].
          generalize (Z.to_nat (sz - length zs)); intros n.
          induction n=> //=.
          setoid_rewrite IHn.
          rewrite /fmap.
          reflexivity.
        Qed.

        #[global] Instance bufR_validR_inbounds_observe :
          forall q sz (z : Z) (zs : t),
            (0 <= z <= sz)%Z ->
            Observe (.[Tchar ! z] |-> validR) (bufR q sz zs).
        Proof.
          intros **; generalize dependent zs; induction z; intros **; simpl in *.
          - rewrite ->o_sub_0 by eauto; rewrite _offsetR_id; refine _.
          - assert (Z.pos p < sz \/ Z.pos p = sz)%Z
              as [Hp | Hp] by lia; last by (rewrite Hp; refine _).
            unfold Observe, bufR.
            move: H Hp; generalize (Z.pos p).
            iIntros (z H Hz) "[%SZ [zs [_ zeros]]]".
            assert (z <= length zs \/ length zs < z)%Z
              as [Hz' | Hz'] by lia.
            + iClear "zeros".
              iDestruct (observe (.[ Tchar ! z] |-> validR) with "zs")
                as "#valid"; last by iFrame "#".
              pose proof (arrayR_valid_obs
                            (fun c => primR Tchar q (Vchar c))
                            Tchar (Z.to_nat z) zs ltac:(lia)).
              by rewrite ->Z2Nat.id in H0 by lia.
            + iClear "zs".
              iDestruct (observe (.[Tchar ! z] |-> validR) with "zeros")
                as "#valid"; last by iFrame "#".
              assert (exists z', size zs + z' = z /\ 0 <= z')
                as [z' [Hz'' Hneg]]
                by (exists (z - size zs)%Z; unfold size; lia);
                subst.
              rewrite -_offsetR_sub_sub; apply _offsetR_observe.
              pose proof (arrayR_valid_obs
                            (fun c => primR Tchar q (Vchar 0))
                            Tchar (Z.to_nat z')
                            (repeat () (Z.to_nat (sz - size zs)))
                            ltac:(rewrite repeat_length; lia)).
              by rewrite ->Z2Nat.id in H0 by lia.
          - by lia.
        Qed.
      End bufR.

      Section bufR'.
        #[local] Ltac lift_WF2WF' H :=
          intros **; rewrite -!bufRs_equiv; by apply H.

        Remark bufR'_nil : forall (q : cQp.t) (sz : Z), bufR' q sz [] |-- False.
        Proof. lift_WF2WF' bufR_nil. Qed.

        (* TODO (AUTO): Investigate whether or not this hint actually fires. *)
        #[global] Instance bufR'_sz_contra :
          forall (q : cQp.t) (sz : Z) (zs : t),
            Observe2 False [| sz < size zs |] (bufR' q sz zs).
        Proof. lift_WF2WF' bufR_sz_contra. Qed.

        #[global] Instance bufR'_singleton :
          forall (q : cQp.t) (sz : Z) (z : _),
            0 <= sz ->
            Observe [| z = 0 |]%N (bufR' q sz [z]).
        Proof. lift_WF2WF' bufR_singleton. Qed.

        Lemma bufR'_cons :
          forall (q : cQp.t) (sz : Z) (z : _) (zs : t),
            z <> 0%N ->
            bufR' q sz (z :: zs) -|-
            primR Tchar q (Vchar z) ** .[Tchar ! 1] |-> bufR' q (sz - 1) zs.
        Proof. lift_WF2WF' bufR_cons. Qed.

        #[global] Instance bufR'_cons_cons_head_nonzero :
          forall (q : cQp.t) (sz : Z) (z z' : _) (zs : t),
            Observe [| z <> 0 |]%N (bufR' q sz (z :: z' :: zs)).
        Proof.  lift_WF2WF' bufR_cons_cons_head_nonzero. Qed.

        Lemma bufR'_has_type :
          forall (q : cQp.t) (sz : Z) (zs : t),
            strlen zs < sz ->
                bufR' q sz zs
            |-- bufR' q sz zs ** [| List.Forall (fun c => has_type (Vchar c) Tchar) zs |].
        Proof. lift_WF2WF' bufR_has_type. Qed.

        #[global] Instance bufR'_type_ptrR_observe :
          forall q (sz : Z) (zs : t),
            Observe (type_ptrR Tchar) (bufR' q sz zs).
        Proof. lift_WF2WF' bufR_type_ptrR_observe. Qed.

        #[global] Instance bufR'_validR_end_observe :
          forall q (sz : Z) (zs : t),
            Observe (.[Tchar ! sz] |-> validR) (bufR' q sz zs).
        Proof. lift_WF2WF' bufR_validR_end_observe. Qed.

        #[global] Instance bufR'_validR_inbounds_observe :
          forall q sz (z : Z) (zs : t),
            (0 <= z <= sz)%Z ->
            Observe (.[Tchar ! z] |-> validR) (bufR' q sz zs).
        Proof. lift_WF2WF' bufR_validR_inbounds_observe. Qed.
      End bufR'.

      Lemma bufR_unfold :
        forall (q : cQp.t) (sz : Z) (zs : t),
          bufR q sz zs -|-
          [| size zs <= sz |] ** R q zs **
          .[ Tchar ! size zs] |-> arrayR Tchar (fun _ => primR Tchar q (Vchar 0))
                                           (repeat () (Z.to_nat (sz - size zs))).
      Proof.
        intros **; split'.
        - rewrite /bufR/R; iIntros "(%&?&%&?)"; by iFrame "∗%".
        - rewrite /bufR/R; iIntros "[% [[? %] ?]]"; by iFrame "∗%".
      Qed.

      Lemma bufR'_unfold :
        forall (q : cQp.t) (sz : Z) (cstr : t),
          bufR' q sz cstr -|-
          [| size cstr <= sz |] ** R' q cstr **
          .[ Tchar ! size cstr] |-> arrayR Tchar (fun _ => primR Tchar q (Vchar 0))
                                             (repeat () (Z.to_nat (sz - size cstr))).
      Proof. intros **; rewrite -!bufRs_equiv -!Rs_equiv; by apply bufR_unfold. Qed.

      Section R_Theory.
        Lemma R_bufR_equiv :
          forall q (zs : t),
            R q zs ≡ bufR q (size zs) zs.
        Proof.
          intros **; rewrite /R/bufR; split'.
          - iIntros "[array %HWF]".
            assert (size zs <= size zs) by lia.
            rewrite Z.sub_diag/= arrayR_nil.
            iDestruct (observe (.[Tchar ! size zs] |-> validR) with "array") as "#?". 1: {
              unfold size; apply arrayR_valid_obs; by lia.
            }
            rewrite _offsetR_sep _offsetR_only_provable;
              iFrame "#∗%"; iPureIntro; by eauto.
          - iIntros "[%Hzs [array [%HWF rest]]]"; by iFrame "∗%".
        Qed.

        #[local] Ltac try_lift_bufR H :=
          intros **; rewrite !R_bufR_equiv; eapply H; eauto.

        Remark R_nil : forall (q : cQp.t), R q [] |-- False.
        Proof. try_lift_bufR bufR_nil. Qed.

        #[global] Instance R_singleton :
          forall (q : cQp.t) (z : _),
            Observe [| z = 0 |]%N (R q [z]).
        Proof. try_lift_bufR bufR_singleton. Qed.

        Lemma R_cons :
          forall (q : cQp.t) (z : _) (zs : t),
            z <> 0%N ->
            R q (z :: zs) -|-
            primR Tchar q (Vchar z) ** .[Tchar ! 1] |-> R q zs.
        Proof.
          intros **; rewrite !R_bufR_equiv.
          replace (size zs) with ((size (z :: zs)) - 1)
            by (rewrite size_cons; lia).
          eapply bufR_cons; eauto.
        Qed.

        #[global] Instance R_cons_cons_head_nonzero :
          forall (q : cQp.t) (z z' : _) (zs : t),
            Observe [| z <> 0 |]%N (R q (z :: z' :: zs)).
        Proof. try_lift_bufR bufR_cons_cons_head_nonzero. Qed.

        Lemma R_has_type :
          forall (q : cQp.t) (zs : t),
                R q zs
            |-- R q zs ** [| List.Forall (fun c => has_type (Vchar c) Tchar) zs |].
        Proof.
          try_lift_bufR bufR_has_type.
          unfold strlen; by lia.
        Qed.

        (* TODO (AUTO): Fix this once we add the correct observations for arrayR *)
        #[global] Instance R_type_ptrR_observe :
          forall q (zs : t),
            Observe (type_ptrR Tchar) (R q zs).
        Proof. try_lift_bufR bufR_type_ptrR_observe. Qed.

        #[global] Instance R_validR_end_observe :
          forall q (zs : t),
            Observe (.[Tchar ! size zs] |-> validR) (R q zs).
        Proof. try_lift_bufR bufR_validR_end_observe. Qed.

        #[global] Instance R_validR_end_observe' :
          forall q (zs : t),
            Observe (.[Tchar ! strlen zs] |-> .[Tchar ! 1] |-> validR) (R q zs).
        Proof.
          intros *; pose proof (R_validR_end_observe q zs).
          rewrite _offsetR_sub_sub; unfold size, strlen in *.
          unfold size in *.
          by replace (length zs - 1 + 1)%Z
            with (Z.of_nat (length zs))
            by lia.
        Qed.

        #[global] Instance R_validR_inbounds_observe :
          forall q (z : Z) (zs : t),
            (0 <= z <= size zs)%Z ->
            Observe (.[Tchar ! z] |-> validR) (R q zs).
        Proof.
          intros * Hsize; unfold R; unfold size in Hsize.
          apply observe_sep_l.
          pose proof (arrayR_valid_obs
                        (fun c => primR Tchar q (Vchar c))
                        Tchar (Z.to_nat z) zs ltac:(lia)).
          by rewrite ->Z2Nat.id in H by lia.
        Qed.
      End R_Theory.

      Section R'_Theory.
        #[local] Ltac lift_WF2WF' H :=
          intros **; rewrite -!Rs_equiv; by apply H.

        Lemma R'_bufR'_equiv :
          forall q (zs : t),
            R' q zs ≡ bufR' q (size zs) zs.
        Proof. intros **; rewrite -Rs_equiv -bufRs_equiv; by apply R_bufR_equiv. Qed.

        Remark R'_nil : forall (q : cQp.t), R' q [] |-- False.
        Proof. lift_WF2WF' R_nil. Qed.

        #[global] Instance R'_singleton :
          forall (q : cQp.t) (z : _),
            Observe [| z = 0 |]%N (R' q [z]).
        Proof. lift_WF2WF' R_singleton. Qed.

        Lemma R'_cons :
          forall (q : cQp.t) (z : _) (zs : t),
            z <> 0%N ->
            R' q (z :: zs) -|-
            primR Tchar q (Vchar z) ** .[Tchar ! 1] |-> R' q zs.
        Proof. lift_WF2WF' R_cons. Qed.

        #[global] Instance R'_cons_cons_head_nonzero :
          forall (q : cQp.t) (z z' : _) (zs : t),
            Observe [| z <> 0 |]%N (R' q (z :: z' :: zs)).
        Proof. lift_WF2WF' R_cons_cons_head_nonzero. Qed.

        Lemma R'_has_type :
          forall (q : cQp.t) (zs : t),
                R' q zs
            |-- R' q zs ** [| List.Forall (fun c => has_type (Vchar c) Tchar) zs |].
        Proof. lift_WF2WF' R_has_type. Qed.

        #[global] Instance R'_type_ptrR_observe :
          forall q (zs : t),
            Observe (type_ptrR Tchar) (R' q zs).
        Proof. lift_WF2WF' R_type_ptrR_observe. Qed.

        #[global] Instance R'_validR_end_observe :
          forall q (zs : t),
            Observe (.[Tchar ! size zs] |-> validR) (R' q zs).
        Proof. lift_WF2WF' R_validR_end_observe. Qed.

        #[global] Instance R'_validR_end_observe' :
          forall q (zs : t),
            Observe (.[Tchar ! strlen zs] |-> .[Tchar ! 1] |-> validR) (R' q zs).
        Proof. lift_WF2WF' R_validR_end_observe'. Qed.

        #[global] Instance R'_validR_inbounds_observe :
          forall q (z : Z) (zs : t),
            (0 <= z <= size zs)%Z ->
            Observe (.[Tchar ! z] |-> validR) (R' q zs).
        Proof. lift_WF2WF' R_validR_inbounds_observe. Qed.
      End R'_Theory.

      Lemma R_unfold :
        forall (q : cQp.t) (zs : t),
              R q zs
          -|- arrayR Tchar (fun c => primR Tchar q (Vchar c)) zs ** [| WF zs |].
      Proof. intros **; split'; by rewrite /R. Qed.

      Lemma R'_unfold :
        forall (q : cQp.t) (zs : t),
              R' q zs
          -|- arrayR Tchar (fun c => primR Tchar q (Vchar c)) zs ** [| WF' zs |].
      Proof. intros **; split'; by rewrite /R'. Qed.
    End Theory.
  End with_Σ.
End with_ct.

(* refresh notation outside of the section *)
Notation size zs := (_size zs%Z).
Notation strlen zs := (_strlen zs%Z).
Notation WF zs := (_WF zs%Z).
Notation WF' zs := (_WF' zs%Z).

End zstring.

Section zstring_pure_hint_test_pre.
  (* TODO (AUTO; cc/ @paolo): globally setting this prevents the use
       of the [Fail] vernacular.
   *)
  Goal not True.
  Proof.
    (* by auto. *)
    (* > In nested Ltac calls to "by (tactic)" and "tactics.done", last call failed. *)
    (* > No applicable tactic. *)

    Fail (by auto).
    (* > In nested Ltac calls to "by (tactic)" and "tactics.done", last call failed. *)
    (* > No applicable tactic. *)
  Abort.
  #[local] Unset Ltac Backtrace.

  Goal forall {σ : genv}, not (zstring.WF char_type.Cchar []).
  Proof. Fail (by auto with pure). Abort.

  Goal
    forall z z' z'' zs n,
      zstring.strlen zs = n ->
      zstring.strlen (z :: z' :: z'' :: zs) = 3 + n.
  Proof. intros * Hzs. Fail (by auto with pure). Abort.
End zstring_pure_hint_test_pre.

(* TODO (AUTO; JH): talk with @janno w.r.t the appropriate way to package these; hopefully
     further porting work will elucidate the appropriate export strategy.
 *)
#[global] Hint Resolve
   (* WF lemmas *)
   zstring.not_WF_nil zstring.WF_cons zstring.WFs_equiv
   zstring.WF_singleton zstring.WF_singleton_inj
   zstring.WF_nonempty_inj

   (* Bound Lemmas *)
   zstring.strlen_nonneg zstring.strlen_lowerbound
   zstring.size_nonneg

   (* Symbolic reasoning about [size]/[strlen]; check out the
      [zstring.{size, strlen}_unfold*] lemmas if you wish to
      manually reduce applications which involve ground terms.
    *)
   zstring.strlen_cons zstring.strlen_cons'
   zstring.size_cons zstring.size_cons'
  : pure.

Section zstring_pure_hint_test_post.
  #[local] Unset Ltac Backtrace.

  Goal forall {σ : genv}, not (zstring.WF char_type.Cchar []).
  Proof. by auto with pure. Abort.

  Goal
    forall z z' z'' zs n,
      zstring.strlen zs = n ->
      zstring.strlen (z :: z' :: z'' :: zs) = 3 + n.
  Proof. intros * Hzs. Fail (by auto with pure). Abort.
End zstring_pure_hint_test_post.


(*===========================================================================
    State of the registers
  ===========================================================================*)
Require Import ssreflect ssrfun ssrbool eqtype seq fintype finfun .
Require Import reg bitsrep update.
Local Open Scope update_scope.

(* State of the registers, including IP and flags *)
(* Lookup is just function application *)
(*=RegState *)
Definition RegState := AnyReg -> DWORD.
(*=End *)

(* Avoid == to permit extraction *)
Instance RegStateUpdateOps : UpdateOps RegState AnyReg DWORD :=
  fun rs r v => fun r' => if r == r' then v else rs r'.

Lemma setThenGetDistinct r1 v r2 (rs: RegState) :
  ~~ (r1 == r2) -> (rs !r1:=v) r2 = rs r2.
Proof. move => neq. rewrite /update /RegStateUpdateOps. by rewrite (negbTE neq). Qed.

Lemma setThenGetSame r v rs : (rs !r:=v) r = v.
Proof. rewrite /update /RegStateUpdateOps.
by rewrite (introT (eqP) (refl_equal _)).
Qed.

Require Import FunctionalExtensionality.

Instance RegStateUpdate : Update RegState AnyReg DWORD.
apply Build_Update.
(* Same register *)
move => rs r v w. rewrite /update /RegStateUpdateOps.
apply functional_extensionality => r'. by case: (r == r').
(* Different register *)
move => rs r1 r2 v1 v2 neq. rewrite /update /RegStateUpdateOps.
apply functional_extensionality => r.
case E1: (r2 == r).
case E2: (r1 == r). rewrite (elimT (eqP) E1) in neq.
rewrite (elimT (eqP) E2) in neq. done. done.
done.
Qed.

Definition initialReg : RegState := fun _ => #0.

Require Import Coq.Strings.String.
Definition regStateToString (rs:RegState) :=
  (" EIP=" ++ toHex (rs EIP) ++
   " ESP=" ++ toHex (rs ESP) ++
   " EBP=" ++ toHex (rs EBP) ++
   " EAX=" ++ toHex (rs EAX) ++
   " EBX=" ++ toHex (rs EBX) ++
   " ECX=" ++ toHex (rs ECX) ++
   " EDX=" ++ toHex (rs EDX) ++
   " ESI=" ++ toHex (rs ESI) ++
   " EDI=" ++ toHex (rs EDI) ++
   " EBP=" ++ toHex (rs EBP)
   )%string.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
Require Import Relation_Operators.
From fcsl
Require Import pred prelude ordtype finmap pcm unionmap heap.
From DiSeL
Require Import Domain Freshness State EqTypeX DepMaps Protocols Worlds NetworkSem Rely.
From DiSeL
Require Import Actions Injection Process Always HoareTriples InductiveInv.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

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

[Unary Hoare-style specifications and auxiliary lemmas].

This file borrows basic definition of binary-to-unary Hoare triple
encoding (i.e., logvar and binarify definitions) from the development
of FCSL by Nanevski et al.

(FCSL is available at http://software.imdea.org/fcsl)

*****************************************************************************)

(* Spec s is parametrized by a ghost variable of type A *)
Definition logvar {B A} (s : A -> spec B) : spec B :=
  (fun i => exists x : A, (s x).1 i,
   fun y i m => forall x : A, (s x).2 y i m).

(* Representing q as a unary postcondition, including the precondition *)
Definition binarify {A} (p : pre) (q : cont A) : spec A :=
  (p, fun i y m => p i -> q y m).

Notation "'DHT' [ this , W ] ( p , q ) " :=
  (DTbin this W (binarify p q)) (at level 0,
   format "'[hv ' DHT  [ this , W ]  ( '[' p , '/' q ']' ) ']'").

(* A unary Hoare-style specification  *)
Notation "{ x .. y }, 'DHT' [ this , W ] ( p , q )" :=
  (DTbin this W (logvar (fun x => .. (logvar (fun y => binarify p q)) .. )))
   (at level 0, x binder, y binder, right associativity,
    format "'[hv ' { x .. y }, '/ ' DHT  [ this , W ]  ( '[' p , '/' q ']' ) ']'").

Section BasicRules.

Variable this : nid.

(* We can always assume coherence of the state *)
Lemma vrf_coh W A (e : DT this W A) i r :
        (i \In Coh W -> verify i e r) -> verify i e r.
Proof.
by move=>H C; apply: H.
Qed.

(* stability of preconditions *)
Lemma vrf_pre W A (e : DT this W A) i i' (k : cont A) :
        verify i e k -> network_rely W this i i' -> verify i' e k.
Proof.
move=>H M Ci' t H'; case: (rely_coh M)=>Ci _.
by apply: aft_imp (alw_envs (H Ci t H') M).
Qed.

(* stability of postconditions *)
Lemma vrf_post W A (e : DT this W A) i (k : cont A) :
        verify i e k ->
        verify i e (fun x m => forall m', network_rely W this m m' -> k x m').
Proof.
move=>H Ci t H'; move: (alw_envsq (H Ci t H')).
apply: alw_imp=>s p Cs H2 s3 M v E; apply: H2 E _ M.
Qed.

(* An inference rule for the sequential composition *)
Lemma bind_rule W A B (e1 : DT this W A) (e2 : A -> DT this W B) i
             (q : cont A) (r : cont B) :
        verify i e1 q ->
        (forall y j, q y j -> j \In Coh W  -> verify j (e2 y) r) ->
        verify i (bind e1 e2) r.
Proof.
move=>H1 H2 Ci t [->|[t'][H3 H4]].
- by apply: alw_unfin=>//; move/alw_coh: (H1 Unfinished (prog_unfin e1)).
by apply: aft_bnd H3 _; move/(H1 Ci): H4; apply: aft_imp=>y j Cj H; apply: H2.
Qed.

Arguments bind_rule [W A B e1 e2 i].

Lemma step W A B (e1 : DT this W A) (e2 : A -> DT this W B) i (r : cont B) :
        verify i e1 (fun y m => verify m (e2 y) r) ->
        verify i (bind e1 e2) r.
Proof. by move=>H; apply: (bind_rule (fun y m => verify m (e2 y) r)). Qed.

(* Inference rules for the calls to an already verified function f *)
Lemma call_rule' W A i (f : DT this W A) (k : cont A) :
  (* Verify precondition of the call *)
  (i \In Coh W -> pre_of f i) ->
  (* Verify the rest out of the postcondition *)
  (forall x m, post_of f i x m -> m \In Coh W -> k x m) ->
  verify i f k.
Proof.
case: f=>s [e] /= H H1 H2 Ci t H3.
apply: aft_imp (H i t (H1 Ci) Ci H3).
by move=>v m Cm H4; apply: H2.
Qed.

(* Same lemma for unary postconidtions *)
Lemma call_rule W A (p : Pred state) (q : A -> Pred state) i
      {e} (k : cont A) :
        (i \In Coh W -> p i) ->
        (forall x m, q x m -> m \In Coh W -> k x m) ->
        verify i (@with_spec this W A (binarify p q) e) k.
Proof.
move=>H1 H2; apply: vrf_coh=>C; apply: call_rule'=>//.
by move=>x m /(_ (H1 C)); apply: H2.
Qed.

(* Lemmas for manipulating with ghost variables *)
Section GhostRules.

Variables (W : world) (A B C : Type).

(* Weakening of the continuation postcondition *)
Lemma vrf_mono (e : DT this W A) i (r1 r2 : cont A) :
        r1 <== r2 -> verify i e r1 -> verify i e r2.
Proof. by move=>T H1 C' t; move/(H1 C'); apply: aft_imp=>v m _; apply: T. Qed.

Variable (e : DT this W A).

(* "Uncurrying" the ghosts in the specification s *)
Lemma ghE (s : B -> C -> spec A) :
        conseq e (logvar (fun x => logvar (s x))) <->
        conseq e (logvar (fun xy => s xy.1 xy.2)).
Proof.
split.
- move=>/= H1 i [[x y]] H2.
  have: exists x1 y1, (s x1 y1).1 i by exists x, y.
  by move/H1; apply: vrf_mono=>y1 m1 T1 [x2 y2]; apply: (T1 x2 y2).
move=>/= H1 i [x][y] H2.
have: exists x, (s x.1 x.2).1 i by exists (x, y).
by move/H1; apply: vrf_mono=>y1 m1 T1 x2 y2; apply: (T1 (x2, y2)).
Qed.

(* Pulling the ghosts out of the specification *)
Lemma ghC (p : B -> pre) (q : B -> A -> pre) :
        (forall i x, p x i -> i \In Coh W -> verify i e (q x)) ->
        conseq e (logvar (fun x => binarify (p x) (q x))).
Proof.
move=>H i /= [x Hp] Ci t Ht.
have S : alwsafe i t by apply: alw_imp (H i x Hp Ci Ci t Ht).
by apply/aftA=>// y; apply/aftI=>// /H; apply.
Qed.

(********************************************)
(* Lemmas for instantiating ghost variables *)
(********************************************)
Variables (s : C -> spec A) (f : DTbin this W (logvar s)).

(* helper lemma, to express the instantiation *)
Lemma gh_conseq t : conseq f (s t).
Proof.
case E: (s t)=>[a b] h /= H; apply: call_rule'=>[|x m].
- by exists t; rewrite E.
by move/(_ t); rewrite E.
Qed.

(* Instantiating the ghost of a call *)
Lemma gh_ex g i (k : cont A) :
        verify i (do' (@gh_conseq g)) k ->
        verify i (@with_spec this W A (logvar s) f) k.
Proof. by []. Qed.

End GhostRules.

Arguments gh_ex [W A C s f].

Lemma act_rule W A (a: action W A this) i (r : cont A) :
  (forall j, network_rely W this i j -> a_safe a j /\
   forall y k m, (exists pf : a_safe a j, a_step pf k y) -> network_rely W this k m -> r y m) ->
        verify i (act a) r.
Proof.
move=>H C p; case=>Z; subst p; first by apply: (alw_unfin C).
apply: (alw_act C)=>j R; case: (H j R)=>{H}S H; exists S.
split=>//k v m St R' v'[]<-.
have X: (exists pf : a_safe a j, a_step pf k v) by exists S.
by apply: (H _ _ _ X R').
Qed.

Lemma ret_rule W A i (v : A) (r : cont A) :
       (forall m, network_rely W this i m -> r v m) ->
       verify i (ret this W v) r.
Proof.
move=>H C p; case=>Z; subst p; first by apply: alw_unfin.
by apply: alw_ret=>//m R v'[]<-; apply: H.
Qed.

End BasicRules.

Section InjectLemmas.

Variable this : nid.
Variables (W V : world) (K : hooks) (A : Type) (w : injects V W K).
Notation W2 := (inj_ext w).

Variable (e1 : DT this V A).

Lemma inject_rule i j (r : cont A) :
        i \In Coh V ->
        verify i e1 (fun x i' => forall j',
          i' \+ j' \In Coh W -> network_rely W2 this j j' -> r x (i' \+ j')) ->
        verify (i \+ j) (inject w e1) r.
Proof.
move=>Ci H C t [->|[t' [H' ->{t}]]]; first by apply: alw_unfin.
move/aft_inject: {H H'} (H Ci _ H'); move/(_ _ _ w _ C).
apply: aft_imp=>v s Cs [i'][j'][E] Ci' S'.
by rewrite {s}E in Cs *; apply.
Qed.

End InjectLemmas.

Section InductiveInvLemmas.

Variable pr : protocol.

Notation l := (plab pr).
Variable I : dstatelet -> pred nid -> Prop.
Variable ii : InductiveInv pr I.

(* Tailored modal always-lemma *)

Variables (A : Type) (this: nid).
Notation V := (mkWorld pr).
Notation W := (mkWorld (ProtocolWithIndInv ii)).

Variable (e : DT this V A).

(*

[Inferences rule for invariant strengthening]

This rule essentially means that we can always verify the program in
stronger assumptions (i.e., in a protocol, enriched with the inductive
invariant), if we can provide this protocol in the first place. We can
then also make use of the invariant.

 *)

Notation getS i := (getStatelet i l).

Lemma with_inv_rule' i (r : cont A) :
  verify i e (fun x m =>
              I (getS m) (nodes pr (getS m)) -> r x m) ->
        verify i (with_inv ii e) r.
Proof.
move=> H C t [->|[t' [H' ->{t}]]]; first by apply: alw_unfin.
move/aft_ind_inv: {H H'}(H (with_inv_coh C) _ H')=>/(_ _ _ C).
apply: aft_imp=>v m _[C']; apply.
by case: C'=>_ _ _ _/(_ l); rewrite prEq; case.
Qed.

Lemma with_inv_rule i (r : cont A) :
        verify i e (fun x m => r x m) ->
        verify i (with_inv ii e) r.
Proof.
move=>H; apply: with_inv_rule'.
by move=>H1 p H2; move: (H H1 p H2)=>G; apply: (aft_imp _ G).
Qed.

End InductiveInvLemmas.


From elpi.apps Require Import derive.

Require Import type.

(* Should we measure the time used to derive the dependencies? *)
#[only(eqOK)] derive nat.
#[only(eqOK)] derive bool.
#[only(eqOK),verbose] derive t.

Fail Check t_eq_OK.

Module M.

Section S.

Inductive dummy (n : nat) := C0 : bool -> dummy.

Variable (n:nat).

Inductive t := | C : dummy n -> t.

#[only(eqOK),verbose] derive dummy.
#[only(eqOK),verbose] derive t.

Fail Check t_eqOK.

End S.

End M.


From Undecidability Require Import L.Util.L_facts.

From Undecidability.Shared.Libs.PSL Require Import FinTypes Vectors.
Require Import List.

Require Import Undecidability.TM.Util.TM_facts.

From Undecidability Require Import ProgrammingTools LM_heap_def (*WriteValue CaseList Copy*) ListTM Hoare.
From Undecidability.TM.L Require Import (*JumpTargetTM*) Alphabets StepTM M_LHeapInterpreter LMBounds_Loop.
From Undecidability Require Import L.AbstractMachines.FlatPro.LM_heap_correct.

Require Import List.

Import Vector.VectorNotations.
Import ListNotations ResourceMeasures.

(*From Undecidability.TM.L Require Import UnfoldClos.*)

Require Import Equations.Prop.DepElim.

Import CasePair Code.CaseList.

Set Default Proof Using "Type".

Section inEnc.
  Variable (sig : finType).

  Variable (sigX : Type) (X : Type) (cX : codable sigX X) (I : Retract sigX sig).

  Definition inTape (x : X) : tape sig^+ :=
    midtape [] (inl START) (map inr (Encode_map cX I x) ++ [inl STOP]).

  Lemma inTape_correct x:
    inTape x ≃ x.
  Proof. eexists. reflexivity. Qed.

  Definition inVoid : tape sig^+ := midtape [] (inl STOP) nil.
  Lemma inVoid_correct:
  isVoid inVoid.
  Proof. do 2 eexists. reflexivity. Qed.

End inEnc.

Lemma TripleT_loopM_correct {sig : finType} {n : nat} {F : Type} P k (pM : pTM sig F n) Q t:
  TripleT P k pM Q -> P t -> exists q t', loopM (initc (projT1 pM) t) k = Some (mk_mconfig q t') /\ Q (projT2 pM q) t'.
Proof.
  intros [H1%Triple_iff H2]%TripleT_iff Ht. edestruct H2 as [[q t'] H2'].
  {split. eassumption. reflexivity. }
  exists q, t'. split. easy. apply H1 in H2'. hnf in H2'. apply H2'. easy.
Qed.

Lemma Triple_loopM_sound {sig : finType} {n : nat} {F : Type} P k (pM : pTM sig F n) Q t q t':
  Triple P pM Q -> P t -> loopM (initc (projT1 pM) t) k = Some (mk_mconfig q t') -> Q (projT2 pM q) t'.
Proof.
  intros H1%Triple_iff Ht Hloop. apply H1 in Hloop. now eapply Hloop.
Qed.


Require Export RecTypes.SpecTypes.
Require Export RecTypes.InstTy.
Require Export RecTypes.LemmasTypes.

Require StlcEqui.TypeSafety.
Require Import StlcEqui.LemmasTyping.
Require Import StlcEqui.CanForm.
Require Import StlcFix.CanForm.
Require Import StlcFix.LemmasTyping.
(* Require Import StlcEqui.LemmasScoping. *)
Require Export LogRelFE.PseudoType.
Require Import UValFE.UVal.

Section RepEmul.
  Lemma repEmul_embed_leftinv τ :
    repEmul (embed τ) = τ.
  Proof.
    induction τ; simpl; try f_equal; intuition.
  Qed.

  Lemma repEmulCtx_embedCtx_leftinv Γ :
    repEmulCtx (embedCtx Γ) = Γ.
  Proof.
    induction Γ; simpl; try f_equal; eauto using repEmul_embed_leftinv.
  Qed.
End RepEmul.

Ltac crushRepEmulEmbed :=
  match goal with
      [ |- context[ repEmul( embed ?τ) ] ] => rewrite -> (repEmul_embed_leftinv τ)
    | [ |- context[ repEmulCtx( embedCtx ?Γ) ] ] => rewrite -> (repEmulCtx_embedCtx_leftinv Γ)
  end.

(* TODO: equivalent section for fxToIs? *)

Lemma getevar_repEmulCtx {i τ Γ} :
  ⟪ i : τ ∈ repEmulCtx Γ ⟫ →
  exists τ', ⟪ i : τ' p∈ Γ ⟫ ∧ τ = repEmul τ'.
Proof.
  revert i. induction Γ as [|Γ IHΓ τ''];
  inversion 1; [idtac| destruct (IHΓ _ H4) as [? [? ?]]];
  eauto using GetEvarP.
Qed.

Lemma getevar_fxToIsCtx {i τ Γ} :
  ⟪ i : τ r∈ fxToIsCtx Γ ⟫ →
  exists τ', ⟪ i : τ' p∈ Γ ⟫ ∧ τ = fxToIs τ'.
Proof.
  revert i. induction Γ as [|Γ IHΓ τ''];
  inversion 1; [idtac| destruct (IHΓ _ H4) as [? [? ?]]];
  eauto using GetEvarP.
Qed.

Section ValidTy.

  Fixpoint ValidPTy (τ : PTy) : Prop :=
    match τ with
    | ptarr τ1 τ2 => ValidPTy τ1 /\ ValidPTy τ2
    | ptunit => True
    | ptbool => True
    | ptprod τ1 τ2 => ValidPTy τ1 /\ ValidPTy τ2
    | ptsum τ1 τ2 => ValidPTy τ1 /\ ValidPTy τ2
    | pEmulDV n p τ => ValidTy τ
    end.

  Lemma ValidPTy_invert_ptarr {τ1 τ2} :
    ValidPTy (ptarr τ1 τ2) ->
    ValidPTy τ1 /\ ValidPTy τ2.
  Proof.
    now induction 1.
  Qed.
  Hint Resolve ValidPTy_invert_ptarr : tyvalid_inv.

  Lemma ValidPTy_invert_ptprod {τ1 τ2} :
    ValidPTy (ptprod τ1 τ2) ->
    ValidPTy τ1 /\ ValidPTy τ2.
  Proof.
    now induction 1.
  Qed.
  Hint Resolve ValidPTy_invert_ptprod : tyvalid_inv.

  Lemma ValidPTy_invert_ptsum {τ1 τ2} :
    ValidPTy (ptsum τ1 τ2) ->
    ValidPTy τ1 /\ ValidPTy τ2.
  Proof.
    now induction 1.
  Qed.
  Hint Resolve ValidPTy_invert_ptsum : tyvalid_inv.

  Lemma ValidPTy_invert_pEmulDV {n p τ} :
    ValidPTy (pEmulDV n p τ) ->
    ValidTy τ.
  Proof.
    now induction 1.
  Qed.
  Hint Resolve ValidPTy_invert_pEmulDV : tyvalid_inv.

  Lemma validTy_fxToIs {τ} : ValidPTy τ -> ValidTy (fxToIs τ).
  Proof.
    induction τ;
      intros vpτ;
      cbn in vpτ;
      destruct_conjs;
      repeat match goal with
      | H: ValidPTy ?τ, H2: ValidPTy ?τ -> _ |- _ => specialize (H2 H)
      end;
      cbn;
      crushValidTy.
  Qed.

  Lemma validPTy_embed {τ} : ValidPTy (embed τ).
  Proof.
    induction τ; now cbn.
  Qed.

  Definition ValidPEnv (Γ : PEnv) : Prop :=
    ∀ i τ, ⟪ i : τ p∈ Γ ⟫ → ValidPTy τ.
  (* Inductive ValidPEnv : PEnv → Prop := *)
  (* | ValidPEnvEmpty : ValidPEnv pempty *)
  (* | ValidPEnvEvar {Γ τ} : *)
  (*   ValidPEnv Γ → *)
  (*   ValidPTy τ → *)
  (*   ValidPEnv (Γ p▻ τ). *)

  Lemma ValidPEnvEmpty : ValidPEnv pempty.
  Proof.
    intros i τ x; inversion x.
  Qed.

  Lemma ValidPEnvCons {Γ τ} : ValidPEnv Γ → ValidPTy τ → ValidPEnv (Γ p▻ τ).
  Proof.
    intros vΓ vτ i τ' x.
    inversion x; subst; try assumption.
    eapply (vΓ _ _ H3).
  Qed.

  Lemma validPEnv_embedCtx {Γ} : ValidPEnv (embedCtx Γ).
  Proof.
    induction Γ; eauto using ValidPEnvEmpty, ValidPEnvCons, validPTy_embed.
  Qed.

End ValidTy.

Section OfType.

  Local Ltac crush :=
    unfold OfType, OfTypeStlcFix, OfTypeStlcEqui; intros;
    repeat
      (subst;
       F.stlcCanForm;
       E.stlcCanForm;
       F.crushTyping;
       E.crushTyping;
       destruct_conjs;
       repeat
         match goal with
           | H: False |- _ => elim H
           | H: True  |- _ => clear H
           | H: _ ∧ _ |- _ => destruct  H
           | H: match ?tu with _ => _ end |- _ =>
             destruct tu eqn: ?; cbn in H
           | H: _ ∨ _ |- _ => destruct  H
           | [ |- _ ∧ _ ] => split
         | |- ValidTy (fxToIs _) => eapply validTy_fxToIs
         end); eauto.

  Lemma OfType_unit : OfType ptunit F.unit E.unit.
  Proof. crush. Qed.

  Lemma OfType_true : OfType ptbool F.true E.true.
  Proof. crush. Qed.

  Lemma OfType_false : OfType ptbool F.false E.false.
  Proof. crush. Qed.

  Lemma OfType_inl {τ₁ τ₂ ts tu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    OfType τ₁ ts tu →
    OfType (ptsum τ₁ τ₂) (F.inl ts) (E.inl tu).
  Proof. crush. Qed.

  Lemma OfType_inr {τ₁ τ₂ ts tu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    OfType τ₂ ts tu →
    OfType (ptsum τ₁ τ₂) (F.inr ts) (E.inr tu).
  Proof. crush. Qed.

  Lemma OfType_pair {τ₁ τ₂ ts₁ ts₂ tu₁ tu₂} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    OfType τ₁ ts₁ tu₁ →
    OfType τ₂ ts₂ tu₂ →
    OfType (ptprod τ₁ τ₂) (F.pair ts₁ ts₂) (E.pair tu₁ tu₂).
  Proof. crush. Qed.

  Lemma OfType_lambda {τ₁ τ₂ τ₁' τ₁'' tsb tub} :
    ValidPTy τ₁ -> ValidPTy τ₂ -> ValidTy τ₁'' ->
    τ₁' = repEmul τ₁ →
    ⟪ τ₁'' ≗ fxToIs τ₁ ⟫ ->
    ⟪ E.empty e⊢ E.abs (fxToIs τ₁) tub : E.tarr (fxToIs τ₁) (fxToIs τ₂) ⟫ →
    ⟪ F.empty ⊢ F.abs (repEmul τ₁) tsb : repEmul τ₁ ⇒ repEmul τ₂ ⟫ →
    OfType (ptarr τ₁ τ₂) (F.abs τ₁' tsb) (E.abs τ₁'' tub).
  Proof.
    crush;
      eauto using ValidTy_arr, validTy_fxToIs.
    eapply E.invert_ty_abs in H4; crushValidTy.
    destruct_conjs.
    eapply tyeq_invert_tarr in H7.
    destruct_conjs.
    eapply E.eqctx_implies_eqty.
    - constructor.
      eapply tyeq_symm.
      exact H3.
      constructor.
    - eauto using validTy_fxToIs with tyvalid.
    - eauto using validTy_fxToIs with tyvalid.
    - refine (WtEq _ _ _ _ H8);
      eauto using typed_terms_are_valid, validTy_fxToIs with tyvalid.
  Qed.

  Lemma OfType_inversion_ptunit {ts tu} :
    OfType ptunit ts tu →
    ts = F.unit ∧ tu = E.unit.
  Proof.
    crush.
  Qed.

  Lemma OfType_inversion_ptbool {ts tu} :
    OfType ptbool ts tu →
    ts = F.true ∧ tu = E.true ∨
    ts = F.true ∧ tu = E.false ∨
    ts = F.false ∧ tu = E.true ∨
    ts = F.false ∧ tu = E.false.
  Proof. crush. Qed.

  Lemma OfType_inversion_ptsum {τ₁ τ₂ ts tu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    OfType (ptsum τ₁ τ₂) ts tu →
    ∃ ts' tu',
      ts = F.inl ts' ∧ tu = E.inl tu' ∧ OfType τ₁ ts' tu' ∨
      ts = F.inl ts' ∧ tu = E.inr tu' ∨
      ts = F.inr ts' ∧ tu = E.inl tu' ∨
      ts = F.inr ts' ∧ tu = E.inr tu' ∧ OfType τ₂ ts' tu'.
  Proof.
    crush.
    - repeat eexists. left. crush.
    - repeat eexists. right. left. crush.
    - repeat eexists. right. right. left. crush.
    - repeat eexists. right. right. right. crush.
  Qed.

  Lemma OfType_inversion_ptprod {τ₁ τ₂ ts tu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    OfType (ptprod τ₁ τ₂) ts tu →
    ∃ ts₁ tu₁ ts₂ tu₂,
      ts = F.pair ts₁ ts₂ ∧
      tu = E.pair tu₁ tu₂ ∧
      OfType τ₁ ts₁ tu₁ ∧
      OfType τ₂ ts₂ tu₂.
  Proof. crush. repeat eexists; crush. Qed.

  (* Lemma OfTypeUtlc_inversion_ptarr {τ₁ τ₂ tu} : *)
  (*   OfTypeUtlc (ptarr τ₁ τ₂) tu → *)
  (*   ∃ tu', tu = E.abs tu' ∧ ⟨ 1 ⊢ tu' ⟩. *)
  (* Proof. crush. Qed. *)

  (* Lemma OfTypeUtlc_inversion_ptprod {τ₁ τ₂ tu} : *)
  (*   OfTypeUtlc (ptprod τ₁ τ₂) tu → *)
  (*   ∃ tu₁ tu₂, tu = E.pair tu₁ tu₂ ∧ OfTypeUtlc τ₁ tu₁ ∧ OfTypeUtlc τ₂ tu₂. *)
  (* Proof. crush. Qed. *)

  (* Lemma OfTypeUtlc_inversion_ptsum {τ₁ τ₂ tu} : *)
  (*   OfTypeUtlc (ptsum τ₁ τ₂) tu → *)
  (*   ∃ tu', (tu = E.inl tu' ∧ OfTypeUtlc τ₁ tu') ∨ *)
  (*          (tu = E.inr tu' ∧ OfTypeUtlc τ₂ tu'). *)
  (* Proof. crush. Qed. *)

  Lemma OfType_inversion_ptarr {τ₁ τ₂ ts tu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    OfType (ptarr τ₁ τ₂) ts tu →
    ∃ ts' tu' τ₁',
      ts = F.abs (repEmul τ₁) ts' ∧
      tu = E.abs τ₁' tu' ∧
        ValidTy τ₁' /\
        ⟪ τ₁' ≗ fxToIs τ₁ ⟫ /\
      ⟪ F.empty ▻ repEmul τ₁ ⊢ ts' : repEmul τ₂ ⟫ ∧
        ⟪ E.empty r▻ fxToIs τ₁ e⊢ tu' : fxToIs τ₂ ⟫.
  Proof.
    crush.
    - eapply ValidTy_arr; crush.
    - repeat eexists; crush;
      crushValidTy.
  Qed.

  Lemma OfType_inversion_pEmulDV {n p ts tu T} :
    OfType (pEmulDV n p T) ts tu →
    F.Value ts ∧ E.Value tu ∧
    ⟪ F.empty ⊢ ts : UValFE n T ⟫ ∧
    E.Typing E.empty tu T.
  Proof. crush. Qed.

  Lemma OfTypeStlcEqui_implies_Value {τ tu} :
    OfTypeStlcEqui τ tu →
    E.Value tu.
  Proof.
    crush.
  Qed.

  Lemma OfTypeStlcFix_implies_Value {τ ts} :
    OfTypeStlcFix τ ts →
    F.Value ts.
  Proof.
    crush.
  Qed.

  Lemma OfType_implies_Value {τ ts tu} :
    OfType τ ts tu →
    F.Value ts ∧ E.Value tu.
  Proof.
    crush.
  Qed.

  Lemma OfType_pEmulDV {n p ts tu T} :
    F.Value ts ∧ E.Value tu ∧
    ⟪ F.empty ⊢ ts : UValFE n T ⟫ →
    E.Typing E.empty tu T →
    OfType (pEmulDV n p T) ts tu.
  Proof. crush. Qed.

End OfType.

Ltac crushOfType :=
  repeat
    (match goal with
     | [ H: OfType _ _ _ |- ValidPTy _ ] => clear H   (* prevent an infinite loop *)
      | [ H: OfType ptunit _ _ |- _ ] => apply OfType_inversion_ptunit in H
      | [ H: OfType ptbool _ _ |- _ ] => apply OfType_inversion_ptbool in H
      | [ H: OfType (ptsum ?τ₁ ?τ₂) _ _ |- _ ] => apply OfType_inversion_ptsum in H
      | [ H: OfType (ptprod ?τ₁ ?τ₂) _ _ |- _ ] => apply OfType_inversion_ptprod in H
      | [ H: OfType (ptarr ?τ₁ ?τ₂) _ _ |- _ ] => apply OfType_inversion_ptarr in H
      | [ |- OfType ptunit F.unit E.unit ] => apply OfType_unit
      | [ |- OfType ptbool F.true E.true ] => apply OfType_true
      | [ |- OfType ptbool F.false E.false ] => apply OfType_false
      | [ |- OfType (ptsum _ _) (F.inl _) (E.inl _)] => apply OfType_inl
      | [ |- OfType (ptsum _ _) (F.inr _) (E.inr _)] => apply OfType_inr
      | [ |- OfType (ptprod _ _) (F.pair _ _) (E.pair _ _) ] => apply OfType_pair
      | [ |- OfType (ptarr _ _) (F.abs _ _) (E.abs _ _) ] => apply OfType_lambda
      (* | [ |- OfTypeUtlc _ _ ] => split *)
      | [ |- OfType (pEmulDV _ _ _) _ _ ] => apply OfType_pEmulDV
    end; try assumption; try reflexivity).


(* Support for complex constructions in recursive notations, especially "match". *)

Definition Let_In {A P} (x : A) (f : forall a : A, P a) : P x := let y := x in f y.
Notation "'dlet' x , y := v 'in' ( a , b , .. , c )"
  := (Let_In v (fun '(x, y) => pair .. (pair a b) .. c))
       (at level 0).


Inductive set : Type :=
| mkset : forall (a:Type) (f:a -> set), set
.


Require Coq.Lists.List.
Require Export TypeClasses.Monad.

(** * The Monad Transformer Type Class. *)

Class MonadTrans
      (T : (Type -> Type) -> Type -> Type) :=
  { (** Monadic Substructure *)
    Trans_Monad :> forall (M : Type -> Type) `{Monad M}, Monad (T M);
    lift : forall {M : Type -> Type} `{Monad M}
             {A : Type}, M A -> T M A;
    (** Lift with pure is idempotent. *)
    lift_pure : forall {M : Type -> Type} `{Monad M} {A : Type},
      lift (M := M) (A := A) ∘ (pure (F := M)) = pure (F := T M);
    (** Lift composes with bind. *)
    lift_bind : forall {M : Type -> Type} `{Monad M}
                  {A B : Type} (m : M A) (f : A -> M B),
      lift (m >>= f) = lift m >>= lift ∘ f }.

(** Specification. *)
Module Type MonadTransSpec.
  Parameter T : (Type -> Type) -> Type -> Type.

  Parameter TMonad : forall (M : Type -> Type) `{Monad M}, Monad (T M).

  Parameter lift : forall {M : Type -> Type} `{Monad M}
                     {A : Type}, M A -> T M A.

  Axiom lift_pure : forall {M : Type -> Type} `{Monad M} {A : Type},
      @lift M _ A ∘ (@pure M _ A) =
      @pure (T M) (@Monad_Applicative (T M) (TMonad M)) A.

  Axiom lift_bind : forall {M : Type -> Type} `{Monad M}
                          {A B : Type} (m : M A) (f : A -> M B),
      lift (m >>= f) = @bind (T M) (TMonad M) _ _ (lift m) (lift ∘ f).
End MonadTransSpec.

Module MonadTransFactory (MS : MonadTransSpec).
  Include MS.

  Instance MonadTransInstance : MonadTrans MS.T :=
    { lift := @MS.lift;
      lift_pure := @MS.lift_pure;
      lift_bind := @MS.lift_bind }.
End MonadTransFactory.

(** Identity. *)
Module IdentityMonadTransSpec <: MonadTransSpec.
  Definition T : (Type -> Type) -> Type -> Type := fun M => M.

  Instance TMonad (M : Type -> Type) `{HM : Monad M} : Monad M := HM.

  Definition lift {M : Type -> Type} `{Monad M}
             {A : Type} : M A -> M A := fun m => m.

  Lemma lift_pure : forall {M : Type -> Type} `{Monad M} {A : Type},
      @lift M _ A ∘ (@pure M _ A) =
      @pure M (@Monad_Applicative M (TMonad M)) A.
  Proof. intros. unfold lift. extensionality m. reflexivity. Qed.

  Lemma lift_bind : forall {M : Type -> Type} `{Monad M}
                      {A B : Type} (m : M A) (f : A -> M B),
      lift (m >>= f) = lift m >>= lift ∘ f.
  Proof. intros. reflexivity. Qed.
End IdentityMonadTransSpec.

Module IdentityMonadTransFactory :=
  MonadTransFactory IdentityMonadTransSpec.
Instance IdentityMonadTrans : MonadTrans (fun M : Type -> Type => M) :=
  IdentityMonadTransFactory.MonadTransInstance.

(** Option. *)
Module OptionMonadTransSpec <: MonadTransSpec.
  Definition T (M : Type -> Type) : Type -> Type := M ∘ option.

  Instance TApplicative (M : Type -> Type)
           `{HM : Monad M} : Applicative (M ∘ option) :=
    ComposeApplicative option M.

  Section TMonadSpec.
    Context {M : Type -> Type}.

    Context `{HM : Monad M}.

    Definition bindt {A B : Type}
               (m : M (option A)) (f : A -> M (option B)) : M (option B) :=
      let* o := m in
      match o with
      | None   => pure None
      | Some a => (f a)
      end.

    Lemma pure_leftt : forall {A B : Type} (a : A) (f : A -> M (option B)),
        bindt (pure (F := M ∘ option)a) f = f a.
    Proof.
      intros. pose proof @pure_left M HM (option A) (option B) as H.
      unfold bindt. simpl. unfold purec. unfold compose.
      rewrite H. simpl. reflexivity.
    Qed.

    Lemma pure_rightt : forall {A : Type} (m : M (option A)),
        bindt m (pure (F := M ∘ option) (A:=A)) = m.
    Proof.
      intros. unfold bindt. simpl. unfold purec.
      unfold compose.
      assert (H : (fun o : option A =>
                     match o with
                     | Some a => @pure M _ _ (@pure option _ _ a)
                     | None => @pure M _ _ None
                     end) = (fun o : option A =>
                               @pure M _ _
                                     (match o with
                                      | Some a => @pure option _ _ a
                                      | None => None
                                      end))).
      { extensionality o; destruct o; auto. }
      rewrite H; clear H.
      assert (H : (fun o : option A =>
                     @pure M _ _
                           match o with
                           | Some a => pure a
                           | None => None
                           end) =
                  (fun o : option A => @pure M _ _ o)).
      { extensionality o; destruct o; auto. }
      rewrite H. apply pure_right.
    Qed.

    Lemma bind_assoct :
      forall {A B C : Type} (m : M (option A))
        (k : A -> M (option B)) (h : B -> M (option C)),
        bindt m (fun a => bindt (k a) h) = bindt (bindt m k) h.
    Proof.
      intros. unfold bindt.
      rewrite <- (@bind_assoc M). apply f_equal.
      extensionality o. destruct o as [a |]; auto.
      rewrite pure_left. reflexivity.
    Qed.

    Lemma fmap_bindt : forall {A B : Type} (m : M (option A)) (f : A -> B),
        fmap (F := M ∘ option) f m = bindt m (pure (F := M ∘ option) ∘ f).
    Proof.
      intros. unfold bindt.
      assert (hanon :
               (fun o =>
                  match o with
                  | Some a => (pure (F := M ∘ option) ∘ f) a
                  | None => pure (F := M) None
                  end)
               = pure (F := M) ∘ (fmap f)).
      { extensionality o. unfold "∘".
        destruct o; reflexivity. }
      unfold "∘" in *.
      rewrite hanon; clear hanon.
      pose proof fmap_bind m (fmap f) as h.
      unfold "∘" in *.
      unfold OptionMonadSpec.F in h.
      rewrite <- h; clear h. reflexivity.
    Qed.
  End TMonadSpec.

  Instance TMonad : forall (M : Type -> Type) `{Monad M}, Monad (M ∘ option) :=
    { bind := @bindt M _;
      pure_left := @pure_leftt M _;
      pure_right := @pure_rightt M _;
      bind_assoc := @bind_assoct M _;
      fmap_bind := @fmap_bindt M _ }.

  Definition lift {M : Type -> Type} `{Monad M}
             {A : Type} (m : M A) : M (option A) :=
    @fmap M _ _ _ (@pure option _ _) m.

  Lemma lift_pure : forall {M : Type -> Type} `{Monad M} {A : Type},
      @lift M _ A ∘ (@pure M _ A) =
      @pure (M ∘ option) (@Monad_Applicative (M ∘ option) (TMonad M)) A.
  Proof.
    intros. extensionality a. unfold compose, lift.
    cbn. unfold purec. unfold compose, OptionMonadSpec.pure.
    simpl. unfold OptionMonadSpec.pure.
    rewrite app_fmap_pure.
    apply app_homomorphism.
  Qed.

  Lemma lift_bind : forall {M : Type -> Type} `{Monad M}
                      {A B : Type} (m : M A) (f : A -> M B),
      lift (m >>= f) =
        @bind (M ∘ option) (TMonad M) _ _ (lift m) (lift ∘ f).
  Proof.
    intros. unfold compose. simpl. unfold lift.
    unfold bindt. cbn.
    unfold OptionMonadSpec.pure.
    unfold fmapc, purec, "∘"(*,"<$>"*) in *. cbn in *.
    do 2 rewrite fmap_bind; unfold "∘".
    do 2 rewrite <- bind_assoc. f_equal.
    extensionality a.
    rewrite pure_left. rewrite fmap_bind; reflexivity.
  Qed.
End OptionMonadTransSpec.

Module OptionMonadTransFactory :=
  MonadTransFactory OptionMonadTransSpec.
Instance OptionMonadTrans : MonadTrans (fun M : Type -> Type => M ∘ option) :=
  OptionMonadTransFactory.MonadTransInstance.

Definition StateT (ST : Type) (M : Type -> Type) (A : Type) : Type :=
  ST -> M (A * ST)%type.

Lemma StateT_state : forall ST A, StateT ST (fun x => x) A = state ST A.
Proof. intros; reflexivity. Qed.

Definition map_fst {A B C : Type} (f : A -> B) '((a,c) : A * C) : B * C :=
  (f a, c).

Module StateTransformer.
  Section Transformers.
    Context {ST : Type} {M : Type -> Type} `{M_Functor : Functor M}.

    Definition fmapt {A B : Type} (f : A -> B) (m : StateT ST M A)
      : StateT ST M B :=
      fun st => map_fst f <$> m st.

    Lemma fmapt_id : forall {A : Type},
        fmapt (fun x : A => x) = (fun x : StateT ST M A => x).
    Proof.
      intros; extensionality bruh.
      extensionality st; unfold fmapt, map_fst.
      assert (duh : (fun '((a, c) : A * ST) => (a, c)) = fun x => x).
      { extensionality ast. destruct ast; reflexivity. }
      rewrite duh; rewrite fmap_id; reflexivity.
    Qed.

    Lemma fmapt_compose : forall {A B C : Type} (f : A -> B) (g : B -> C),
        fmapt (g ∘ f) = fmapt g ∘ fmapt f.
    Proof.
      intros; unfold fmapt; extensionality bruh;
        extensionality st; unfold map_fst.
      unfold "∘".
      pose proof fmap_compose
           (A := A * ST) (B := B * ST)
           (C := C * ST) (F := M) as h.
      unfold "∘" in h.
      specialize h with
        (f := fun '(a,st) => (f a, st))
        (g := fun '(b,st) => (g b, st)).
      apply equal_f with (bruh st) in h.
      rewrite <- h; clear h; f_equal.
      extensionality ast.
      destruct ast as [a st']; reflexivity.
    Qed.
  End Transformers.

  Instance StateTransFunctor (ST : Type) (M : Type -> Type)
           `{M_Functor : Functor M} : Functor (StateT ST M) :=
    { fmap := @fmapt ST M M_Functor
    ; fmap_id := @fmapt_id ST M M_Functor
    ; fmap_compose := @fmapt_compose ST M M_Functor }.

  Section Transformers.
    Context {ST : Type} {M : Type -> Type} `{M_Monad : Monad M}.

    Definition puret {A : Type} (a : A) : StateT ST M A :=
      fun st => pure (a, st).

    Definition
      fappt
      {A B : Type} (f : StateT ST M (A -> B))
      (m : StateT ST M A) : StateT ST M B :=
      fun st : ST => let* '((f,st) : (A -> B) * ST) := f st in
                  map_fst f <$> m st.

    Lemma appt_identity : forall {A : Type} (m : StateT ST M A),
        fappt (puret (fun x => x)) m = m.
    Proof.
      intros; extensionality st; unfold fappt, puret.
      rewrite pure_left. unfold map_fst.
      assert (h: (fun '(a, c) => (a, c)) = fun x : A * ST => x)
        by (extensionality ac; destruct ac; reflexivity).
      rewrite h, fmap_id; reflexivity.
    Qed.

    Lemma appt_homomorphism : forall {A B : Type} (f : A -> B) (a : A),
        fappt (puret f) (puret a) = puret (f a).
    Proof.
      intros; unfold fappt, puret.
      extensionality st; rewrite pure_left.
      rewrite app_fmap_pure.
      rewrite app_homomorphism.
      reflexivity.
    Qed.

    Lemma appt_interchange : forall {A B : Type} (f : StateT ST M (A -> B)) (a : A),
        fappt f (puret a) = fappt (puret (fun h => h a)) f.
    Proof.
      intros; unfold fappt, puret.
      extensionality st.
      rewrite pure_left.
      rewrite fmap_bind. unfold "∘".
      f_equal. extensionality gst; clear st f.
      destruct gst as [g st']; cbn.
      rewrite app_fmap_pure, app_homomorphism; reflexivity.
    Qed.

    Lemma appt_composition :
      forall {A B C : Type}
        (f : StateT ST M (A -> B)) (h : StateT ST M (B -> C)) (a : StateT ST M A),
        fappt h (fappt f a) = fappt (fappt (fappt (puret (@compose A B C)) h) f) a.
    Proof.
      intros; unfold fappt,puret.
      extensionality st.
      repeat rewrite <- bind_assoc.
      rewrite pure_left.
      rewrite fmap_bind.
      rewrite <- bind_assoc.
      f_equal. clear st.
      unfold "∘". extensionality gst.
      destruct gst as [g st].
      rewrite pure_left; cbn.
      do 2 rewrite fmap_bind.
      do 2 rewrite <- bind_assoc; unfold "∘".
      f_equal. clear st.
      extensionality wst.
      destruct wst as [w st].
      rewrite pure_left, fmap_bind,<- bind_assoc.
      unfold "∘". cbn. rewrite fmap_bind; unfold "∘".
      f_equal; clear st.
      extensionality ast.
      rewrite pure_left.
      destruct ast; reflexivity.
    Qed.

    Lemma appt_fmapt_puret : forall {A B : Type} (f : A -> B),
        fmapt f = fappt (puret f).
    Proof.
      intros; unfold fmapt, fappt, puret.
      extensionality m. extensionality st.
      rewrite pure_left; reflexivity.
    Qed.
  End Transformers.

  Instance StateTransApplicative (ST : Type) (M : Type -> Type)
           `{HM : Monad M} : Applicative (StateT ST M) :=
    { pure := @puret ST M HM
    ; fapp := @fappt ST M HM
    ; app_identity := @appt_identity ST M HM
    ; app_homomorphism := @appt_homomorphism ST M HM
    ; app_interchange := @appt_interchange ST M HM
    ; app_composition := @appt_composition ST M HM
    ; app_fmap_pure := @appt_fmapt_puret ST M HM }.

  Section Transformers.
    Context {ST : Type} {M : Type -> Type} `{M_Monad : Monad M}.

    Definition
      bindt {A B : Type} (m : StateT ST M A)
      (f : A -> StateT ST M B) : StateT ST M B :=
      fun st => let* '(a,st) := m st in f a st.

    Lemma puret_left : forall {A B : Type} (a : A) (f : A -> StateT ST M B),
        bindt (puret a) f = f a.
    Proof.
      intros; unfold bindt, puret.
      extensionality st. rewrite pure_left; reflexivity.
    Qed.

    Lemma puret_right : forall {A : Type} (m : StateT ST M A),
        bindt m puret = m.
    Proof.
      intros; unfold bindt, puret.
      extensionality st.
      assert (h: (fun '(a, st) => pure (F := M) (a, st)) = (fun ast : A * ST => pure ast))
        by (extensionality ast; destruct ast; reflexivity).
      rewrite h, pure_right. reflexivity.
    Qed.

    Lemma bindt_assoc :
      forall {A B C : Type} (m : StateT ST M A)
        (k : A -> StateT ST M B) (h : B -> StateT ST M C),
        bindt m (fun a => bindt (k a) h) = bindt (bindt m k) h.
    Proof.
      intros; unfold bindt; extensionality st.
      rewrite <- bind_assoc. f_equal.
      clear st. extensionality ast.
      destruct ast as [a ast]; reflexivity.
    Qed.

    Lemma fmapt_bindt : forall {A B : Type} (m : StateT ST M A) (f : A -> B),
        fmapt f m = bindt m (puret ∘ f).
    Proof.
      intros; unfold fmapt, bindt, puret, "∘".
      extensionality st.
      rewrite fmap_bind.
      f_equal. clear st; extensionality ast.
      destruct ast; reflexivity.
    Qed.
  End Transformers.

  Instance StateTransFormerMonad (M : Type -> Type) (ST : Type)
           `{HM : Monad M} : Monad (StateT ST M) :=
    { bind := @bindt ST M HM
    ; pure_left := @puret_left ST M HM
    ; pure_right := @puret_right ST M HM
    ; bind_assoc := @bindt_assoc ST M HM
    ; fmap_bind := @fmapt_bindt ST M HM }.

  Section Transformers.
    Context {ST : Type} {M : Type -> Type} `{M_Monad : Monad M}.

    Definition liftt {A : Type} (m : M A) : StateT ST M A :=
      fun st => let* a := m in pure (a, st).

    Lemma liftt_pure : forall {A : Type},
        liftt (A := A) ∘ (pure (F := M)) = puret.
    Proof.
      intros; unfold liftt, puret.
      extensionality m. extensionality st.
      unfold compose. rewrite pure_left.
      reflexivity.
    Qed.

    Lemma liftt_bindt : forall {A B : Type} (m : M A) (f : A -> M B),
        liftt (m >>= f) = bindt (liftt m) (liftt ∘ f).
    Proof.
      intros; unfold bindt,liftt,"∘".
      extensionality st.
      do 2 rewrite <- bind_assoc.
      f_equal.
      extensionality a.
      rewrite pure_left. reflexivity.
    Qed.
  End Transformers.
End StateTransformer.

Instance StateMonadTransformer (ST : Type) : MonadTrans (StateT ST) :=
  { lift := @StateTransformer.liftt ST
  ; lift_pure := @StateTransformer.liftt_pure ST
  ; lift_bind := @StateTransformer.liftt_bindt ST }.


From iris.algebra Require Export cmra.
From iris.algebra Require Import proofmode_classes.
From iris.prelude Require Import options.
Require Import cpdt.CpdtTactics.

From stdpp Require Import gmap.
From stdpp Require Import mapset.
From stdpp Require Import sets.
From stdpp Require Import list.
Require Import Burrow.trees.
Require Import Burrow.indexing.
Require Import Burrow.tactics.
Require Import Burrow.locations.
Require Import Burrow.resource_proofs.
Require Import Burrow.exchanges.
Require Import Burrow.assoc_comm.
Require Import coq_tricks.Deex.

Section LiveRec.

Context {M} `{!EqDecision M} `{!TPCM M}.
Context {RI} `{!EqDecision RI, !Countable RI, !RefinementIndex M RI}.

Fixpoint live_rec (loc: Loc RI) (m: M) :=
      match loc with
    | BaseLoc _ _ => live loc m
    | ExtLoc _ _ _ => live loc m
    | CrossLoc l r =>
          (live_rec l (rel M M (refinement_of (left_ri RI)) m)) ⋅
          (live_rec r (rel M M (refinement_of (right_ri RI)) m))
  end.

Lemma live_rec_eq (l r : Loc RI) (m1 m2 : M)
    : live_rec (CrossLoc l r) (pair_up RI m1 m2) = live_rec l m1 ⋅ live_rec r m2.
Proof.
  cbn [live_rec]. f_equal.
  - f_equal. apply refinement_of_left_pair_up.
  - f_equal. apply refinement_of_right_pair_up.
Qed.

Lemma update_a (a a' b c : State M RI)
  (u: ∀ p , ✓(a ⋅ p) → ✓(a' ⋅ p))
  : ✓(a ⋅ b ⋅ c) -> ✓(a' ⋅ b ⋅ c).
Proof.
   setoid_replace (a ⋅ b ⋅ c) with (a ⋅ (b ⋅ c)) by solve_assoc_comm.
   setoid_replace (a' ⋅ b ⋅ c) with (a' ⋅ (b ⋅ c)) by solve_assoc_comm.
   apply u.
Qed.

Lemma update_b (a b b' c : State M RI)
  (u: ∀ p , ✓(b ⋅ p) → ✓(b' ⋅ p))
  : ✓(a ⋅ b ⋅ c) -> ✓(a ⋅ b' ⋅ c).
Proof.
   setoid_replace (a ⋅ b ⋅ c) with (b ⋅ (a ⋅ c)) by solve_assoc_comm.
   setoid_replace (a ⋅ b' ⋅ c) with (b' ⋅ (a ⋅ c)) by solve_assoc_comm.
   apply u.
Qed.

Lemma unit_unit_pair_is_unit (loc1 loc2: Loc RI)
  : live (CrossLoc loc1 loc2) (pair_up RI (unit: M) unit) ≡ (state_unit : State M RI).
Proof.
  rewrite pair_up_unit_unit. apply live_unit.
Qed.

Lemma op_state_unit_left x : state_unit ⋅ x ≡ x.
Proof. setoid_rewrite state_comm. apply op_state_unit. Qed.

Lemma live_split1 (loc1 loc2 : Loc RI) (m1 m2 : M) p
  (Q : ✓ (live (CrossLoc loc1 loc2) (pair_up RI m1 m2) ⋅ p))
  : ✓ (live loc1 m1 ⋅ live loc2 m2 ⋅ p).
Proof.
  assert (live loc1 m1 ≡ live loc1 m1 ⋅ live (CrossLoc loc1 loc2) (pair_up RI unit unit)) as X.
  { setoid_rewrite unit_unit_pair_is_unit. setoid_rewrite op_state_unit. trivial. }
  setoid_rewrite X.
  apply update_a with (a :=
    live loc1 unit ⋅ live (CrossLoc loc1 loc2) (pair_up RI m1 unit)
  ).
  { intro. apply swap_cross_left_valid. }
  setoid_rewrite live_unit.
  setoid_rewrite op_state_unit_left.
  setoid_replace (live (CrossLoc loc1 loc2) (pair_up RI m1 unit) ⋅ live loc2 m2) with
                 (live loc2 m2 ⋅ live (CrossLoc loc1 loc2) (pair_up RI m1 unit))
                 by (apply state_comm).
  apply swap_cross_right_valid.
  setoid_rewrite live_unit.
  setoid_rewrite op_state_unit_left.
  trivial.
Qed.

Lemma live_join1 (loc1 loc2 : Loc RI) (m1 m2 : M) p
  (Q: ✓ (live loc1 m1 ⋅ live loc2 m2 ⋅ p))
  : ✓ (live (CrossLoc loc1 loc2) (pair_up RI m1 m2) ⋅ p).
Proof.
  setoid_replace (live (CrossLoc loc1 loc2) (pair_up RI m1 m2))
      with (live loc1 unit ⋅ live (CrossLoc loc1 loc2) (pair_up RI m1 m2))
      by (setoid_rewrite live_unit; setoid_rewrite op_state_unit_left; trivial).
  apply swap_cross_left_valid.
  setoid_replace (live (CrossLoc loc1 loc2) (pair_up RI unit m2))
      with (live loc2 unit ⋅ live (CrossLoc loc1 loc2) (pair_up RI unit m2))
      by (setoid_rewrite live_unit; setoid_rewrite op_state_unit_left; trivial).
  apply update_b with (b :=
    live loc2 m2 ⋅ live (CrossLoc loc1 loc2) (pair_up RI unit unit)
  ).
  { intro. apply swap_cross_right_valid. }
  setoid_rewrite unit_unit_pair_is_unit.
  setoid_rewrite op_state_unit.
  trivial.
Qed.

Lemma live_split (loc1 loc2 : Loc RI) (m : M) p
  (Q: ✓ (live (CrossLoc loc1 loc2) m ⋅ p))
  : ✓ (live loc1 (rel M M (refinement_of (left_ri RI)) m)
     ⋅ live loc2 (rel M M (refinement_of (right_ri RI)) m) ⋅ p).
Proof.
  rewrite (self_eq_pair m) in Q. apply live_split1. trivial.
Qed.

Lemma live_join (loc1 loc2 : Loc RI) (m : M) p
  (Q: ✓ (live loc1 (rel M M (refinement_of (left_ri RI)) m)
     ⋅ live loc2 (rel M M (refinement_of (right_ri RI)) m) ⋅ p))
  : ✓ (live (CrossLoc loc1 loc2) m ⋅ p).
Proof.
  rewrite (self_eq_pair m). apply live_join1. trivial.
Qed.

Lemma live_to_live_rec (loc: Loc RI) (m: M) p
   : ✓(live loc m ⋅ p) -> ✓(live_rec loc m ⋅ p).
Proof.
  generalize p. clear p. generalize m. clear m. induction loc.
  - trivial.
  - trivial.
  - cbn [live_rec]. intros.
      apply update_a with (a := live loc1 (rel M M (refinement_of (left_ri RI)) m)).
      { intro. apply IHloc1. }
      apply update_b with (b := live loc2 (rel M M (refinement_of (right_ri RI)) m)).
      { intro. apply IHloc2. }
      apply live_split. trivial.
Qed.

Lemma live_rec_to_live (loc: Loc RI) (m: M) p
   : ✓(live_rec loc m ⋅ p) -> ✓(live loc m ⋅ p).
Proof.
  generalize p. clear p. generalize m. clear m. induction loc.
  - trivial.
  - trivial.
  - cbn [live_rec]. intros.
      apply live_join.
      apply update_a with (a := live_rec loc1 (rel M M (refinement_of (left_ri RI)) m)).
      { intro. apply IHloc1. }
      apply update_b with (b := live_rec loc2 (rel M M (refinement_of (right_ri RI)) m)).
      { intro. apply IHloc2. }
      trivial.
Qed.

Lemma live_rec_dot_live_rec
    (gamma: Loc RI) (m1 m2: M)
    : live_rec gamma m1 ⋅ live_rec gamma m2 ≡ live_rec gamma (dot m1 m2).
Proof.
  generalize m1. clear m1. generalize m2. clear m2. induction gamma.
  - intros. unfold live_rec. apply live_dot_live.
  - intros. unfold live_rec. apply live_dot_live.
  - intros. cbn [live_rec].
      rewrite ref_left_dot.
      rewrite ref_right_dot.
      setoid_rewrite <- IHgamma1.
      setoid_rewrite <- IHgamma2.
      solve_assoc_comm.
Qed.

End LiveRec.


(*
    run this file in order to extract to ocaml
    In default, this file won't be compiled use "make"
*)

(* pure algorithm code *)
From Taxiway Require Export Algorithm.

Require Coq.extraction.Extraction.
Extraction "extraction/path_finding_algorithm.ml" path_finding_algorithm.

(* algorithm with example *)
Require Import Coq.Lists.List.
Require Import Io.All.
Require Import Io.System.All.
Require Import ListString.All.
Require Import Coq.Strings.String.

Import ListNotations.
Import C.Notations.

Open Scope string_scope.
Example print_start := "[".
Example print_end := "]".
Example print_empty := "".
Example print_concat := ";".
Close Scope string_scope.

Definition print_line (s:string) : C.t System.effect unit :=
    System.log (LString.s s ++ LString.s print_concat).

Fixpoint print_path (ls : list string) : C.t System.effect unit :=
    match ls with
        | [] => System.log (LString.s "]")
        | h::t => do! (print_line h) in print_path t
    end.

Fixpoint print_result (res: list (list string)) : C.t System.effect unit :=
    match res with
        | [] => System.log (LString.s print_empty)
        | h::t => do! System.log (LString.s print_start) in do! (print_path (h)) in (print_result t)
    end.

From Taxiway Require Import Example.

Definition print_example (argv : list LString.t) : C.t System.effect unit :=
    print_result path_finding_example_string.

Definition main := Extraction.launch print_example.

Extraction "extraction/coq_print" main.

(* If you don't have IO library, it's an alternative choice*)

(* From Taxiway Require Import Example.
Extraction "extraction/path_finding_example.ml" path_finding_example_string. *)