Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.sample_mark.env_unionfind_arr.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.graph_relation.
Require Import CertiGraph.graph.reachable_computable.
Require Import CertiGraph.graph.UnionFind.
Require Import CertiGraph.msl_application.UnionFindGraph.
Require Import CertiGraph.msl_application.ArrayGraph.
Require Import CertiGraph.floyd_ext.share.
Require Import CertiGraph.sample_mark.spatial_array_graph.
Require Import Coq.Lists.List.

Local Coercion UFGraph_LGraph: UFGraph >-> LGraph.
Local Identity Coercion ULGraph_LGraph: LGraph >-> UnionFindGraph.LGraph.
Local Identity Coercion LGraph_LabeledGraph: UnionFindGraph.LGraph >-> LabeledGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.
Existing Instances maGraph finGraph liGraph.

Local Open Scope Z_scope.

Definition mallocN_spec :=
 DECLARE _mallocN
  WITH sh:wshare, n: Z
  PRE [tint]
     PROP (4 <= n <= Int.max_unsigned)
     PARAMS (Vint (Int.repr n))
     GLOBALS ()
     SEP ()
  POST [ tptr tvoid ]
     EX v: pointer_val,
     PROP (malloc_compatible n (pointer_val_val v))
     LOCAL (temp ret_temp (pointer_val_val v))
     SEP (memory_block sh n (pointer_val_val v)).
(*Basically collapses everything into the mpred defined by SAG_VST
takes in a lst of rank-parent pairs(from where? g?)
  which is converted into the Cdata structures
sh is the only parameter needed
data_at sh (tarray vertex_type (Z.of_nat (length lst)))
                               (map vgamma2cdata lst) (pointer_val_val x)
*)
Definition whole_graph sh g x :=
  (@full_graph_at mpred SAGA_VST pointer_val (SAG_VST sh) g x).

Definition makeSet_spec :=
  DECLARE _makeSet
  WITH sh: wshare, V: Z
    PRE [tint]
      PROP (0 < V <= Int.max_signed / 8)
      PARAMS (Vint (Int.repr V))
      GLOBALS ()
      SEP ()
    POST [tptr vertex_type]
      EX g: UFGraph, EX rt: pointer_val, (*creates a graph where*)
      PROP (forall i: Z, 0 <= i < V -> vvalid g i) (*anything between 0 and V is a vertex*)
      LOCAL (temp ret_temp (pointer_val_val rt))
      SEP (whole_graph sh g rt). (*representation in heap...*)

Definition find_spec :=
  DECLARE _find
  WITH sh: wshare, g: UFGraph, subsets: pointer_val, i: Z
    PRE [tptr vertex_type, tint]
      PROP (vvalid g i)
      PARAMS (pointer_val_val subsets; Vint (Int.repr i))
      GLOBALS ()
      SEP (whole_graph sh g subsets)
    POST [tint]
      EX g': UFGraph, EX rt: Z,
      PROP (uf_equiv g g' ; uf_root g' i rt)
      LOCAL (temp ret_temp (Vint (Int.repr rt)))
      SEP (whole_graph sh g' subsets).

Definition union_spec :=
 DECLARE _Union
  WITH sh: wshare, g: UFGraph, subsets: pointer_val, x: Z, y: Z
  PRE [tptr vertex_type, tint, tint]
          PROP  (vvalid g x; vvalid g y)
          PARAMS (pointer_val_val subsets; Vint (Int.repr x); Vint (Int.repr y))
          GLOBALS ()
          SEP   (whole_graph sh g subsets)
  POST [ Tvoid ]
        EX g': UFGraph,
        PROP (uf_union g x y g')
        LOCAL ()
        SEP (whole_graph sh g' subsets).

Definition Gprog : funspecs :=
  ltac:(with_library prog [mallocN_spec; makeSet_spec; find_spec; union_spec]).

Fixpoint prog_list_helper (i: nat) (n: nat) : list (val * val) :=
  match n with
  | O => nil
  | S n' => if (le_dec i n') then (Vundef, Vundef) :: prog_list_helper i n'
            else (Vint (Int.repr (Z.of_nat (n'))),
                  Vint (Int.repr 0)) :: prog_list_helper i n'
  end.

Definition progressive_list (i: nat) (n: nat) := rev (prog_list_helper i n).

Lemma progressive_list_repeat:
  forall n, list_repeat n (Vundef, Vundef) = progressive_list O n.
Proof.
  induction n; unfold progressive_list; simpl; auto. unfold progressive_list in IHn.
  rewrite <- IHn. change ((Vundef, Vundef) :: list_repeat n (Vundef, Vundef)) with
                      (((Vundef, Vundef) :: nil) ++ list_repeat n (Vundef, Vundef)).
  change ((Vundef, Vundef) :: nil) with (list_repeat 1 (Vundef, Vundef)).
  rewrite !list_repeat_app. rewrite Nat.add_comm. auto.
Qed.

Lemma progressive_list_length: forall i n, length (progressive_list i n) = n.
Proof.
  intros. unfold progressive_list. rewrite rev_length. induction n; simpl; auto.
  destruct (le_dec i n); simpl; rewrite IHn; auto.
Qed.

Definition progressive_array sh i V rt :=
  data_at sh (tarray vertex_type V) (progressive_list (Z.to_nat i) (Z.to_nat V))
          (pointer_val_val rt).

Lemma upd_Znth_twice: forall {A: Type} i (l: list A) v1 v2,
    0 <= i < Zlength l -> upd_Znth i (upd_Znth i l v1) v2 = upd_Znth i l v2.
Proof.
  intros. rewrite !upd_Znth_unfold; auto. 2: now rewrite upd_Znth_Zlength.
  f_equal; [|f_equal].
  - rewrite sublist0_app1.
    + rewrite sublist_same; auto. rewrite Zlength_sublist; lia.
    + rewrite Zlength_sublist; lia.
  - assert (Zlength (sublist 0 i l) = i) by (rewrite Zlength_sublist; lia).
    rewrite sublist_app2; rewrite H0. 2: lia.
    assert (i + 1 - i = 1) by lia. rewrite H1. clear H1. rewrite Zlength_app.
    rewrite H0. simpl. rewrite Zlength_cons. unfold Z.succ.
    rewrite Zlength_sublist; [|lia..].
    assert (i + (Zlength l - (i + 1) + 1) - i = Zlength l - i) by lia.
    rewrite H1; clear H1. rewrite sublist_1_cons.
    rewrite sublist_same; [auto | lia |]. rewrite Zlength_sublist; lia.
Qed.

Lemma prog_list_helper_gt: forall i j n,
    (i >= n)%nat -> (j >= n)%nat -> prog_list_helper i n = prog_list_helper j n.
Proof.
  intros. revert i j H H0. induction n; intros; simpl; auto.
  destruct (le_dec i n), (le_dec j n); [exfalso; lia ..|]. f_equal. apply IHn; lia.
Qed.

Lemma upd_Znth_progressive_list: forall i V,
    0 <= i < Z.of_nat V -> upd_Znth i (progressive_list (Z.to_nat i) V) (Vint (Int.repr i), Vint (Int.repr 0)) = progressive_list (Z.to_nat (i + 1)) V.
Proof.
  intros. induction V. 1: exfalso; simpl in H; intuition. rewrite Nat2Z.inj_succ in H. unfold Z.succ in H. unfold progressive_list. simpl. destruct (le_dec (Z.to_nat i) V).
  - destruct (le_dec (Z.to_nat (i + 1)) V).
    + simpl. assert (0 <= i < Z.of_nat V) by (apply inj_le in l0; rewrite Z2Nat.id in l0; lia). unfold progressive_list in IHV. rewrite <- IHV; auto.
      rewrite upd_Znth_app1; auto. change (rev (prog_list_helper (Z.to_nat i) V)) with (progressive_list (Z.to_nat i) V).
      rewrite Zlength_correct, progressive_list_length. auto.
    + assert (Z.to_nat (i + 1) > V)%nat by lia. apply inj_gt in H0. rewrite Z2Nat.id in H0. 2: lia. assert (i = Z.of_nat V) by lia. subst i.
      clear IHV l n H0 H. rewrite Nat2Z.id. simpl. rewrite upd_Znth_char.
      * f_equal. change 1 with (Z.of_nat 1). rewrite <- Nat2Z.inj_add, Nat2Z.id. f_equal. apply prog_list_helper_gt; lia.
      * change (rev (prog_list_helper V V)) with (progressive_list V V). rewrite Zlength_correct, progressive_list_length. auto.
  - exfalso. assert (Z.to_nat i > V)%nat by lia. apply inj_gt in H0. rewrite Z2Nat.id in H0; lia.
Qed.

Lemma progressive_nat_inc_list: forall n i, (i >= n)%nat -> map (fun x : Z => (Vint (Int.repr x), Vint (Int.repr 0))) (nat_inc_list n) = progressive_list i n.
Proof.
  induction n; intros; unfold progressive_list in *; simpl; auto. destruct (le_dec i n). 1: exfalso; lia. rewrite map_app. simpl. rewrite <- IHn; intuition.
Qed.

Lemma body_makeSet: semax_body Vprog Gprog f_makeSet makeSet_spec.
Proof.
  start_function. forward_call (sh, Z.mul V 8).
  - assert (Int.min_signed <= 8 <= Int.max_signed) by rep_lia.
    assert (Int.min_signed <= V <= Int.max_signed). {
      split; rewrite Z.le_lteq; left.
      - rep_lia.
      - apply Z.le_lt_trans with (Int.max_signed / 8); [intuition | apply Z.div_lt; lia].
    } rewrite !Int.signed_repr; auto. split. 1: lia.
    assert (Z.mul 8 (Int.max_signed /8) <= Int.max_signed) by (apply Z_mult_div_ge; intuition). rep_lia.
  - split. 1: lia. assert (Z.mul 8 (Int.max_signed /8) <= Int.max_signed) by (apply Z_mult_div_ge; intuition). rep_lia.
  - Intros rt.
    assert (memory_block sh (V * 8) (pointer_val_val rt) = data_at_ sh (tarray vertex_type V) (pointer_val_val rt)). {
      assert (memory_block sh (V * 8) (pointer_val_val rt) = memory_block sh (sizeof (tarray vertex_type V)) (pointer_val_val rt)). {
        simpl sizeof. rewrite Zmax0r. 2: intuition. assert (V * 8 = 8 * V)%Z by lia. rewrite H1. auto.
      } rewrite <- memory_block_data_at_; auto. apply malloc_compatible_field_compatible; auto.
      unfold malloc_compatible in *. destruct (pointer_val_val rt); auto. destruct H0. split; auto. simpl sizeof. rewrite Zmax0r; intuition.
    } rewrite H1. clear H1.
    assert (data_at_ sh (tarray vertex_type V) (pointer_val_val rt) = data_at sh (tarray vertex_type V) (progressive_list O (Z.to_nat V)) (pointer_val_val rt)). {
      unfold data_at_, field_at_, data_at. assert (default_val (nested_field_type (tarray vertex_type V) []) = list_repeat (Z.to_nat V) (Vundef, Vundef)) by reflexivity.
      rewrite H1. rewrite progressive_list_repeat. auto.
    } rewrite H1. clear H1.
    forward_for_simple_bound V
      (EX i: Z,
       PROP ()
       LOCAL (temp _subsets (pointer_val_val rt); temp _V (Vint (Int.repr V)))
       SEP (progressive_array sh i V rt)); unfold progressive_array.
    + destruct H. apply Z.le_trans with (Int.max_signed / 8); auto. rewrite Z.lt_eq_cases. left. apply Z_div_lt; intuition.
    + entailer.
    + Opaque Znth. forward. remember (Znth i (progressive_list (Z.to_nat i) (Z.to_nat V))) as lll. destruct lll. forward.
      assert (0 <= i < Zlength (progressive_list (Z.to_nat i) (Z.to_nat V))) by (split; [|rewrite Zlength_correct, progressive_list_length, Z2Nat.id]; lia).
      rewrite upd_Znth_same, upd_Znth_twice; [|auto ..]. unfold progressive_array, data_at.
      rewrite upd_Znth_progressive_list. 2: rewrite Z2Nat.id; lia. entailer. Transparent Znth.
    + forward. Exists (makeSet_discrete_Graph (Z.to_nat V)) rt. entailer!.
      * intros. simpl. rewrite makeSet_vvalid. rewrite Z2Nat.id; lia.
      * unfold whole_graph, full_graph_at. simpl. Exists (Z.to_nat V). apply andp_right; intros; [apply andp_right; apply prop_right|].
        -- intros. rewrite makeSet_vvalid. intuition.
        -- rewrite Z2Nat.id; lia.
        -- simpl. unfold vcell_array_at, SAG_VST. rewrite map_length, nat_inc_list_length. rewrite Z2Nat.id. 2: intuition.
           assert (map (fun x : Z => vgamma (makeSet_discrete_LabeledGraph (Z.to_nat V)) x) (nat_inc_list (Z.to_nat V)) =
                   map (fun x => (0%nat, x)) (nat_inc_list (Z.to_nat V))). {
             apply list_map_exten. intros. unfold vgamma, UnionFindGraph.vgamma. simpl. rewrite makeSet_dst. simpl. auto.
           } rewrite H6. clear H6. rewrite list_map_compose. unfold vgamma2cdata. simpl. rewrite <- progressive_nat_inc_list; intuition.
Qed.

Lemma whole_graph_fold: forall n sh g p,
    (forall v : Z, 0 <= v < Z.of_nat n <-> vvalid (lg_gg g) v) -> Z.of_nat n <= Int.max_signed / 8 ->
    data_at sh (tarray vertex_type (Z.of_nat n)) (map (fun x : Z => vgamma2cdata (vgamma (lg_gg g) x)) (nat_inc_list n)) (pointer_val_val p) = whole_graph sh g p.
Proof.
  intros. apply pred_ext; unfold whole_graph, full_graph_at, vcell_array_at, SAG_VST; [apply (exp_right n)|Intros n']; rewrite map_length, nat_inc_list_length, list_map_compose.
  - apply andp_right; auto. apply andp_right; apply prop_right; auto.
  - destruct (lt_eq_lt_dec n n') as [[? | ?] | ?]; [exfalso | subst n' | exfalso]; auto.
    + assert (vvalid (lg_gg g) (Z.of_nat n)) by (rewrite <- H1; intuition). rewrite <- H in H3. intuition.
    + assert (vvalid (lg_gg g) (Z.of_nat n')) by (rewrite <- H; intuition). rewrite <- H1 in H3. intuition.
Qed.

Lemma whole_graph_unfold: forall sh g p,
    whole_graph sh g p =
    EX n: nat, !! (forall v : Z, 0 <= v < Z.of_nat n <-> vvalid (lg_gg g) v) && !!(Z.of_nat n <= Int.max_signed / 8) &&
                  (data_at sh (tarray vertex_type (Z.of_nat n)) (map (fun x : Z => vgamma2cdata (vgamma (lg_gg g) x)) (nat_inc_list n)) (pointer_val_val p)).
Proof.
  intros. unfold whole_graph, full_graph_at, vcell_array_at, SAG_VST.
  apply pred_ext; Intros n; apply (exp_right n); apply andp_right; [apply andp_right; apply prop_right| |apply andp_right; apply prop_right|];
    auto; rewrite map_length, nat_inc_list_length, list_map_compose; auto.
Qed.

Lemma Znth_nat_inc_list: forall {A: Type} {d: Inhabitant A} n (f: Z -> A) i, 0 <= i < Z.of_nat n -> Znth i (map f (nat_inc_list n)) = f i.
Proof.
  intros. rewrite Znth_map. 2: rewrite Zlength_correct, nat_inc_list_length; auto. f_equal. induction n.
  - exfalso. simpl in H. intuition.
  - simpl. assert (0 <= i < Z.of_nat n \/ i = Z.of_nat n). {
      rewrite Nat2Z.inj_succ in H. destruct H. rewrite Z.lt_succ_r, Z.lt_eq_cases in H0. destruct H0; [left | right]; auto.
    } assert (Zlength (nat_inc_list n) = Z.of_nat n) by (rewrite Zlength_correct, nat_inc_list_length; auto). destruct H0.
    + rewrite app_Znth1. 2: rewrite H1; destruct H0; auto. apply IHn; auto.
    + rewrite app_Znth2. 2: rewrite H1; intuition. rewrite H0, H1. replace (Z.of_nat n - Z.of_nat n) with 0 by lia. rewrite Znth_0_cons. auto.
Qed.

Lemma graph_same_size: forall (g g': UFGraph) n n', (forall x : Z, vvalid g x <-> vvalid g' x) -> (forall v : Z, 0 <= v < Z.of_nat n' <-> vvalid (lg_gg g') v) ->
                                                  (forall v : Z, 0 <= v < Z.of_nat n <-> vvalid (lg_gg g) v) -> n = n'.
Proof.
  intros. assert (forall v, 0 <= v < Z.of_nat n' <-> 0 <= v < Z.of_nat n). intros. rewrite H0. rewrite H1. symmetry. apply H. clear -H2.
  destruct (lt_eq_lt_dec n n'); [destruct s|]; auto; exfalso.
  - specialize (H2 (Z.of_nat n)). lia.
  - specialize (H2 (Z.of_nat n')). lia.
Qed.

Lemma list_eq_Znth {A} {d: Inhabitant A}: forall (l1 l2: list A) n, length l1 = n -> length l2 = n -> (forall j, 0 <= j < Z.of_nat n -> Znth j l1 = Znth j l2) -> l1 = l2.
Proof.
  intros l1 l2 n. revert l1 l2. induction n; intros.
  - simpl in *. destruct l1, l2; simpl in *; [auto | exfalso; intuition..].
  - destruct l1, l2; simpl in H, H0; [exfalso; intuition..| ]. assert (a = a0) by (specialize (H1 0); rewrite !Znth_0_cons in H1; apply H1; rewrite Nat2Z.inj_succ; lia).
    subst a0. cut (l1 = l2); intros. 1: subst l2; auto. inversion H. inversion H0. apply (IHn _ _); auto. intros. specialize (H1 (j + 1)).
    assert (0 < j + 1) by lia. assert (j + 1 - 1 = j) by lia. rewrite !Znth_pos_cons in H1; auto. rewrite !H6 in H1. apply H1. rewrite Nat2Z.inj_succ. lia.
Qed.

Lemma upd_Znth_Graph_redirect_parent: forall (i root : Z) (g: UFGraph) n (Hw: weak_valid g root) (Hv: vvalid g i) (Hi: ~ reachable g root i),
    0 <= i < Z.of_nat n -> 0 <= root < Z.of_nat n -> upd_Znth i (map (fun m : Z => vgamma2cdata (vgamma (lg_gg g) m)) (nat_inc_list n))
                                                              (Vint (Int.repr root), Vint (Int.repr (Z.of_nat (vlabel (lg_gg g) i)))) =
                                                     map (fun m : Z => vgamma2cdata (vgamma (lg_gg (Graph_gen_redirect_parent g i root Hw Hv Hi)) m))(nat_inc_list n).
Proof.
  intros.
  assert (Zlength (map (fun m : Z => vgamma2cdata (vgamma (lg_gg g) m)) (nat_inc_list n)) = Z.of_nat n) by (rewrite Zlength_map, Zlength_correct, nat_inc_list_length; auto).
  apply (list_eq_Znth _ _ n).
  - rewrite <- (Nat2Z.id n) at 2. rewrite <- Zlength_length. 2: lia. rewrite upd_Znth_Zlength; auto. rewrite <- H1 in H. auto.
  - rewrite list_length_map, nat_inc_list_length; auto.
  - intros. rewrite Znth_nat_inc_list; auto. rewrite (upd_Znth_lookup' (Z.of_nat n)); auto. rewrite Znth_nat_inc_list; auto.
    unfold vgamma2cdata, vgamma, UnionFindGraph.vgamma. simpl. unfold graph_gen.updateEdgeFunc. unfold EquivDec.equiv_dec, Z_EqDec, zeq. destruct (Z.eq_dec j i).
    + subst j. destruct (Z.eq_dec i i). 2: exfalso; apply n0; auto. f_equal. destruct (Z_lt_dec root 0); [exfalso; lia | auto].
    + f_equal. destruct (Z.eq_dec i j). 1: exfalso; intuition. auto.
Qed.

Lemma body_find: semax_body Vprog Gprog f_find find_spec.
Proof.
  start_function. rewrite whole_graph_unfold. Intros n. forward.
  assert (H_BOUND: 0 <= i < Zlength (nat_inc_list n)) by (rewrite Zlength_correct, nat_inc_list_length, H0; assumption). forward.
  - apply prop_right. rewrite H0. auto.
  - rewrite <- (map_id (nat_inc_list n)) at 1. rewrite Znth_nat_inc_list. 2: rewrite H0; auto. simpl id.
    forward_if
      (EX g': UFGraph, EX rt: Z,
       PROP (uf_equiv g g' /\ uf_root g' i rt)
       LOCAL (temp _p (Vint (Int.repr rt)); temp _subsets (pointer_val_val subsets); temp _i (Vint (Int.repr i)))
       SEP (whole_graph sh g' subsets)).
    + rewrite whole_graph_fold; [|intuition..]. destruct (vgamma (lg_gg g) i) eqn: ?. forward_call (sh, g, subsets, z).
      * unfold vgamma, UnionFindGraph.vgamma in Heqp. inversion Heqp. clear Heqp. destruct (Z_lt_dec (dst (lg_gg g) i) 0). 1: exfalso; apply H2; auto.
        destruct ((proj2 (@only_one_edge _ _ _ _ _ _ (liGraph g) _ i H)) (eq_refl i)) as [_ ?]. destruct (valid_graph g _ H3) as [_ [? | ?]]; auto.
        hnf in H6. exfalso. apply n1. auto.
      * Intros vret. destruct vret as [g' root]. simpl fst in *. simpl snd in *. rewrite whole_graph_unfold. Intros n'. forward. Opaque Znth. forward. Transparent Znth.
        -- apply prop_right. rewrite H5. destruct H3. rewrite <- H3. auto.
        -- assert (n' = n). {
             destruct H3, (lt_eq_lt_dec n n'); [destruct s|]; auto; exfalso.
             - specialize (H3 (Z.of_nat n)). specialize (H0 (Z.of_nat n)). specialize (H5 (Z.of_nat n)). rewrite <- H0 in H3. rewrite <- H3 in H5. lia.
             - specialize (H3 (Z.of_nat n')). specialize (H0 (Z.of_nat n')). specialize (H5 (Z.of_nat n')). rewrite <- H0 in H3. rewrite <- H3 in H5. lia.
           } subst n'. assert (z <> i) by (unfold vgamma, UnionFindGraph.vgamma in Heqp; inversion Heqp; intro; apply H2; rewrite H9 in H7; rewrite H9; subst i; auto).
           assert (weak_valid g' root) by (right; destruct H4; apply reachable_foot_valid in H4; auto).
           assert (vvalid g' i) by (destruct H3 as [? _]; rewrite <- H3; apply H).
           assert (~ reachable g' root i) by (apply (uf_equiv_not_reachable g g' i n0 z root); auto).
           apply (exp_right (Graph_gen_redirect_parent g' i root H8 H9 H10)). apply (exp_right root). rewrite Znth_nat_inc_list. 2: rewrite H0; auto.
           Opaque vgamma2cdata. Opaque vgamma. entailer !; [split|]. Transparent vgamma. Transparent vgamma2cdata.
           ++ apply (graph_gen_redirect_parent_equiv g g' i n0 z); auto.
           ++ apply (uf_root_gen_dst_same g' (liGraph g') i i root); auto.
              ** rewrite <- (uf_equiv_root_the_same g g' i root); auto.
                 apply (uf_root_edge _ (liGraph g) _ z); [| apply (vgamma_not_dst g i n0 z) | rewrite (uf_equiv_root_the_same g g')]; auto.
              ** apply reachable_refl; auto.
           ++ rewrite whole_graph_unfold. apply (exp_right n). entailer. unfold vgamma2cdata at 2. unfold vgamma at 2. unfold UnionFindGraph.vgamma.
              cut ((upd_Znth i (map (fun x : Z => vgamma2cdata (vgamma (lg_gg g') x)) (nat_inc_list n))
                             (Vint (Int.repr root), Vint (Int.repr (Z.of_nat (vlabel (lg_gg g') i))))) =
                   (map (fun x : Z => vgamma2cdata (vgamma (lg_gg (Graph_gen_redirect_parent g' i root H8 H9 H10)) x)) (nat_inc_list n))); intros.
              ** rewrite <- H15. apply derives_refl.
              ** rewrite <- H0 in H. destruct H4. apply reachable_foot_valid in H4. rewrite <- H5 in H4. clear -H H4. rewrite <- upd_Znth_Graph_redirect_parent; auto.
    + unfold vgamma2cdata at 1. unfold vgamma at 1. unfold UnionFindGraph.vgamma. forward. rewrite whole_graph_fold; [|intuition..]. apply (exp_right g).
      simpl projT2. simpl id. apply (exp_right i). entailer !.
      split; [|split]. 1: apply (uf_equiv_refl _  (liGraph g)). 2: rewrite <- H2; reflexivity. destruct (Z_lt_dec (dst (lg_gg g) i) 0).
      * split. 1: apply reachable_refl; auto. intros. destruct H4 as [[? ?] ?]. destruct H4 as [[? ?] [? ?]]. simpl in H4. subst z. destruct l0.
        -- simpl in H5. auto.
        -- simpl in H6. destruct H6. assert (strong_evalid g z) by (destruct l0; [|destruct H6]; auto). destruct H8 as [? [? ?]]. symmetry in H4.
           destruct (@only_one_edge _ _ _ _ _ _ (liGraph g) _ z H) as [? _]. specialize (H11 (conj H4 H8)). simpl in H11. subst z. rewrite <- H0 in H10.
           destruct H10. assert (dst g i < 0) by apply l. exfalso; lia.
      * destruct (vvalid_src_evalid _ (liGraph g) i H) as [_ ?]. destruct (valid_graph g _ H4) as [_ [? | ?]]. 1: simpl in H5; exfalso; auto. simpl id in *.
        rewrite <- H0 in H5. rewrite <- H0 in H. apply repr_inj_unsigned in H2.
        -- exfalso. rewrite H0 in H. assert (reachable g i i) by (apply reachable_refl; auto). pose proof (dst_not_reachable _ (liGraph g) _ _ _ H H2 H6). auto.
        -- split. 1: lia. rewrite Z.lt_eq_cases. left. apply Z.lt_trans with (Int.max_signed / 8). 2: reflexivity. destruct H5. apply Z.lt_le_trans with (Z.of_nat n); auto.
        -- split. 1: lia. rewrite Z.lt_eq_cases. left. apply Z.lt_trans with (Int.max_signed / 8). 2: compute; auto. destruct H. apply Z.lt_le_trans with (Z.of_nat n); auto.
    + Intros g' rt. forward. apply (exp_right g'). apply (exp_right rt). entailer !.
Qed.

Lemma bounded_vertex: forall v n, 0 <= v < n -> n <= Int.max_signed / 8 -> Int.min_signed <= v <= Int.max_signed.
Proof.
  intros. destruct H. split.
  - apply Z.le_trans with 0; auto. rewrite Z.lt_eq_cases. left. apply Int.min_signed_neg.
  - apply Z.le_trans with n. 1: rewrite Z.lt_eq_cases; left; auto. apply Z.le_trans with (Int.max_signed / 8); auto. rewrite Z.lt_eq_cases; left. apply Z_div_lt; intuition.
Qed.

Lemma body_union: semax_body Vprog Gprog f_Union union_spec.
Proof.
  start_function.
  forward_call (sh, g, subsets, x). Intros vret. destruct vret as [g1 x_root].
  simpl fst in *. simpl snd in *.
  assert (vvalid g1 y) by (destruct H1 as [? _]; rewrite <- H1; apply H0).
  forward_call (sh, g1, subsets, y). Intros vret. destruct vret as [g2 y_root].
  simpl fst in *. simpl snd in *.
  forward_if
    (PROP (x_root <> y_root)
     LOCAL (temp _yroot (Vint (Int.repr y_root)); temp _xroot (Vint (Int.repr x_root));
     temp _subsets (pointer_val_val subsets); temp _x (Vint (Int.repr x));
     temp _y (Vint (Int.repr y)))  SEP (whole_graph sh g2 subsets)).
  - forward. apply (exp_right g2). entailer. rewrite whole_graph_unfold. Intros n. apply prop_right. apply (the_same_root_union g g1 g2 x y y_root); auto.
    assert (x_root = y_root). {
      assert (Int.signed (Int.repr x_root) = Int.signed (Int.repr y_root)) by (rewrite H6; auto). rewrite !Int.signed_repr in H10; auto.
      - apply (bounded_vertex _ (Z.of_nat n)); auto. destruct H5. apply reachable_foot_valid in H5. rewrite <- H8 in H5; auto.
      - apply (bounded_vertex _ (Z.of_nat n)); auto. destruct H4. destruct H2. apply reachable_foot_valid in H2. rewrite H4 in H2. rewrite <- H8 in H2; auto.
    } subst y_root. apply H2.
  - forward. entailer!.
  - rewrite whole_graph_unfold. Intros n.
    assert (0 <= x_root < Z.of_nat n) by (destruct H4; destruct H2; apply reachable_foot_valid in H2; rewrite H4 in H2; rewrite <- H7 in H2; auto).
    assert (H_XROOT_BOUND: 0 <= x_root < Zlength (nat_inc_list n)) by (rewrite Zlength_correct, nat_inc_list_length; apply H9). forward.
    rewrite <- (map_id (nat_inc_list n)) at 1. rewrite Znth_nat_inc_list; auto. simpl id. unfold vgamma2cdata at 1. unfold vgamma at 1.
    unfold UnionFindGraph.vgamma. assert (0 <= y_root < Z.of_nat n) by (destruct H5; apply reachable_foot_valid in H5; rewrite <- H7 in H5; auto).
    assert (H_YROOT_BOUND: 0 <= y_root < Zlength (nat_inc_list n)) by (rewrite Zlength_correct, nat_inc_list_length; apply H10). forward.
    rewrite <- (map_id (nat_inc_list n)) at 1. rewrite Znth_nat_inc_list; auto. unfold vgamma2cdata at 1. unfold vgamma at 1. unfold UnionFindGraph.vgamma. simpl id.
    forward_if
      (EX g': UFGraph,
       PROP (uf_union g x y g')
       LOCAL (temp _yRank (Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) y_root)))); temp _xRank (Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) x_root))));
              temp _yroot (Vint (Int.repr y_root)); temp _xroot (Vint (Int.repr x_root)); temp _subsets (pointer_val_val subsets); temp _x (Vint (Int.repr x));
              temp _y (Vint (Int.repr y)))
       SEP (whole_graph sh g' subsets)).
    + Opaque Znth. forward. rewrite Znth_nat_inc_list; auto.
      assert (weak_valid g2 y_root) by (right; rewrite <- H7; auto). assert (vvalid g2 x_root) by (rewrite <- H7; auto).
      assert (~ reachable g2 y_root x_root) by (intro; destruct H5; specialize (H15 _ H14); auto).
      apply (exp_right (Graph_gen_redirect_parent g2 x_root y_root H12 H13 H14)). unfold vgamma2cdata at 2. unfold vgamma at 2. unfold UnionFindGraph.vgamma.
      Opaque vgamma2cdata. Opaque vgamma. entailer !. Transparent vgamma. Transparent vgamma2cdata.
      * apply (diff_root_union_1 g g1 g2 x y x_root y_root); auto.
      * rewrite whole_graph_unfold. apply (exp_right n). rewrite <- upd_Znth_Graph_redirect_parent; auto. entailer!.
    + assert (weak_valid g2 x_root) by (right; rewrite <- H7; auto). assert (vvalid g2 y_root) by (rewrite <- H7; auto).
      assert (~ reachable g2 x_root y_root) by (intro; rewrite (uf_equiv_root_the_same g1 g2) in H2; auto; destruct H2; specialize (H15 _ H14); auto).
      forward_if
        (EX g': UFGraph,
         PROP (uf_union g x y g')
         LOCAL (temp _yRank (Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) y_root)))); temp _xRank (Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) x_root))));
                temp _yroot (Vint (Int.repr y_root)); temp _xroot (Vint (Int.repr x_root)); temp _subsets (pointer_val_val subsets); temp _x (Vint (Int.repr x));
                temp _y (Vint (Int.repr y)))
         SEP (whole_graph sh g' subsets)).
      * forward. rewrite Znth_nat_inc_list; auto. apply (exp_right (Graph_gen_redirect_parent g2 y_root x_root H12 H13 H14)). unfold vgamma2cdata at 2. unfold vgamma at 2.
        unfold UnionFindGraph.vgamma. Opaque vgamma2cdata. Opaque vgamma. entailer!. Transparent vgamma. Transparent vgamma2cdata.
        -- apply (diff_root_union_2 g g1 g2 x y x_root y_root); auto.
        -- rewrite whole_graph_unfold. apply (exp_right n). rewrite <- upd_Znth_Graph_redirect_parent; auto. entailer!.
      * forward. rewrite Znth_nat_inc_list; auto. remember (Graph_gen_redirect_parent g2 y_root x_root H12 H13 H14) as g3.
        assert (uf_union g x y g3) by (rewrite Heqg3; simpl; apply (diff_root_union_2 g g1 g2 x y x_root y_root); auto).
        unfold vgamma2cdata at 2. unfold vgamma at 2. unfold UnionFindGraph.vgamma. forward. apply (exp_right (Graph_vgen g3 x_root ((vlabel (lg_gg g2) x_root) + 1)%nat)).
        Opaque vgamma2cdata. Opaque vgamma. entailer !. Transparent vgamma. Transparent vgamma2cdata.
        rewrite upd_Znth_diff; auto; [|rewrite Zlength_map, Zlength_correct, nat_inc_list_length; auto..]. rewrite Znth_nat_inc_list; auto.
        rewrite whole_graph_unfold. apply (exp_right n). entailer !.
        cut (upd_Znth x_root (upd_Znth y_root (map (fun x0 : Z => vgamma2cdata (vgamma (lg_gg g2) x0)) (nat_inc_list n))
                                        (Vint (Int.repr x_root), Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) y_root)))))
                       (let (x0, _) := vgamma2cdata (vgamma (lg_gg g2) x_root) in x0, Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) x_root) + 1))) =
             map (fun x0 : Z => vgamma2cdata (vgamma (lg_gg (Graph_vgen (Graph_gen_redirect_parent g2 y_root x_root H12 H13 H14) x_root
                                                                        (vlabel (lg_gg g2) x_root + 1)%nat)) x0)) (nat_inc_list n)); intros.
        -- rewrite <- H23. apply derives_refl.
        -- clear -H6 H9 H10. assert (Zlength (map (fun m : Z => vgamma2cdata (vgamma (lg_gg g2) m)) (nat_inc_list n)) = Z.of_nat n) by
               (rewrite Zlength_map, Zlength_correct, nat_inc_list_length; auto).
           assert (Zlength (upd_Znth y_root (map (fun x0 : Z => vgamma2cdata (vgamma (lg_gg g2) x0)) (nat_inc_list n))
                                     (Vint (Int.repr x_root), Vint (Int.repr (Z.of_nat (vlabel (lg_gg g2) y_root))))) = Z.of_nat n) by
               (rewrite upd_Znth_Zlength; auto; rewrite <- H in H10; auto). apply (list_eq_Znth _ _ n).
           ++ rewrite <- (Nat2Z.id n) at 2. rewrite <- Zlength_length. 2: lia. rewrite <- H in H10, H9. rewrite upd_Znth_Zlength; auto; rewrite upd_Znth_Zlength; auto.
           ++ rewrite list_length_map, nat_inc_list_length; auto.
           ++ intros. rewrite Znth_nat_inc_list; auto. rewrite (upd_Znth_lookup' (Z.of_nat n)); auto. rewrite (upd_Znth_lookup' (Z.of_nat n)); auto.
              rewrite Znth_nat_inc_list; auto. unfold vgamma2cdata, vgamma, UnionFindGraph.vgamma. simpl.
              unfold graph_gen.updateEdgeFunc, graph_gen.update_vlabel, EquivDec.equiv_dec, Z_EqDec, zeq. destruct (Z.eq_dec j x_root).
              ** subst j. destruct (Z.eq_dec y_root x_root). 1: exfalso; auto. destruct (Z.eq_dec x_root x_root). 2: exfalso; apply n1; auto. do 3 f_equal.
                 transitivity (Z.succ (Z.of_nat (vlabel (lg_gg g2) x_root))). 2: rewrite <- Nat2Z.inj_succ; f_equal; unfold Z_EqDec; lia. rewrite Z.add_1_r. auto.
              ** destruct (Z.eq_dec j y_root).
                 --- subst j. destruct (Z.eq_dec y_root y_root). 2: exfalso; apply n1; auto. destruct (Z.eq_dec x_root y_root). 1: exfalso; auto. destruct (Z_lt_dec x_root 0).
                     1: destruct H9; exfalso; lia. auto.
                 --- destruct (Z.eq_dec y_root j). 1: exfalso; apply n1; auto. destruct (Z.eq_dec x_root j). 1: exfalso; auto. auto.
    + Intros g'. apply (exp_right g'). entailer!.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*                Xavier Leroy, INRIA Paris                            *)
(*                Jacques-Henri Jourdan, INRIA Paris                   *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Architecture-dependent parameters for x86 in 32-bit mode *)

Require Import ZArith List.
(*From Flocq*)
Require Import Binary Bits.

Definition ptr64 := false.

Definition big_endian := false.

Definition align_int64 := 4%Z.
Definition align_float64 := 4%Z.

Definition splitlong := negb ptr64.

Lemma splitlong_ptr32: splitlong = true -> ptr64 = false.
Proof.
  unfold splitlong. destruct ptr64; simpl; congruence.
Qed.

Definition default_nan_64 := (true, iter_nat 51 _ xO xH).
Definition default_nan_32 := (true, iter_nat 22 _ xO xH).

(* Always choose the first NaN argument, if any *)

Definition choose_nan_64 (l: list (bool * positive)) : bool * positive :=
  match l with nil => default_nan_64 | n :: _ => n end.

Definition choose_nan_32 (l: list (bool * positive)) : bool * positive :=
  match l with nil => default_nan_32 | n :: _ => n end.

Lemma choose_nan_64_idem: forall n,
  choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil).
Proof. auto. Qed.

Lemma choose_nan_32_idem: forall n,
  choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil).
Proof. auto. Qed.

Definition fma_order {A: Type} (x y z: A) := (x, y, z).

Definition fma_invalid_mul_is_nan := false.

Definition float_of_single_preserves_sNaN := false.

Global Opaque ptr64 big_endian splitlong
              default_nan_64 choose_nan_64
              default_nan_32 choose_nan_32
              fma_order fma_invalid_mul_is_nan
              float_of_single_preserves_sNaN.


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

Record Foldable1__Dict (t : Type -> Type) := Foldable1__Dict_Build {
  foldl1__ : forall {a}, (a -> a -> a) -> t a -> a  }.

Definition Foldable1 a :=
  forall r, (Foldable1__Dict a -> r) -> r.

Existing Class Foldable1.

Definition foldl1 `{g : Foldable1 t} : forall {a}, (a -> a -> a) -> t a -> a :=
  g _ (foldl1__ t).

Definition Digit_foldl1 {a} (f : a -> a -> a) (t : Digit a) : a :=
  match t with
  | One x => x
  | Two x y => f x y
  | Three x y z => f (f x y) z
  | Four x y z w => f (f (f x y) z) w
  end.

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

Program Instance Foldable1_Digit : Foldable1 Digit := fun _ k =>
  k {| foldl1__ := fun {a} => Digit_foldl1 |}.

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

Instance Unpeel_Elem a : GHC.Prim.Unpeel (Elem a) a :=
  GHC.Prim.Build_Unpeel _ _ (fun x => match x with Mk_Elem y => y end) Mk_Elem.

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

Notation "'_:<_'" := (op_ZCzl__).

Infix ":<" := (_:<_) (at level 99).

Notation "'_:>_'" := (op_ZCzg__).

Infix ":>" := (_:>_) (at level 99).

Notation "'_:&_'" := (op_ZCza__).

Infix ":&" := (_:&_) (at level 99).

(*  ----------------------------------------------------------- *)
(* CHANGE to Default.panic *)

Parameter error : forall {a}, a.

(* Move to base: missing record selectors *)
Definition runIdentity {a} (x: Data.Functor.Identity.Identity a) : a :=
  match x with
  | Data.Functor.Identity.Mk_Identity y => y
  end.

Definition unwrapMonad {m}{a} (x: Control.Applicative.WrappedMonad m a) :=
  match x with
  | Control.Applicative.WrapMonad y => y
  end.

(*  ----------------------------------------------------------- *)
(* Needs a termination argument *)

Definition map_elem {a} : list a -> list (Elem a) := fun xs => GHC.Prim.coerce xs.
Definition getNodes {a} : GHC.Num.Int -> a -> list a -> (list (Node a) * Digit a)%type :=
    fix getNodes arg_1__ arg_2__ arg_3__
          := let j_9__ :=
               match arg_1__ , arg_2__ , arg_3__ with
                 | _ , x1 , nil => pair nil (One x1)
                 | _ , x1 , cons x2 nil => pair nil (Two x1 x2)
                 | _ , x1 , cons x2 (cons x3 nil) => pair nil (Three x1 x2 x3)
                 | s , x1 , cons x2 (cons x3 (cons x4 xs)) =>
                   match getNodes s x4 xs with
                   | pair ns d => pair (cons (Node3 s x1 x2 x3) ns) d
                   end
               end in
             match arg_1__ , arg_2__ , arg_3__ with
             | arg , _ , _ => j_9__
             end.

(*
Require Import Omega.
Program Fixpoint  mkTree {a} `{(Sized a)} (s: GHC.Num.Int) (x : list a) {measure (length x)} : FingerTree a :=
    match x with
    | nil => Empty
    | cons x1 nil => Single x1
    | cons x1 (cons x2 nil) => Deep (GHC.Num.fromInteger 2 GHC.Num.* s) (One x1)
                                   Empty (One x2)
    | cons x1 (cons x2 (cons x3 nil)) => Deep (GHC.Num.fromInteger 3 GHC.Num.*
                                                                  s) (One x1) Empty (Two x2 x3)
    | cons x1 (cons x2 (cons x3 (cons x4 xs))) =>
      match getNodes (GHC.Num.fromInteger 3 GHC.Num.* s) x4 xs with
      | pair ns sf => match mkTree (GHC.Num.fromInteger 3 GHC.Num.* s) ns with
                     | m => GHC.Prim.seq m (Deep (((GHC.Num.fromInteger 3 GHC.Num.* size x1)
                                                    GHC.Num.+ size m)
                                                   GHC.Num.+ size sf)
                                                (Three x1 x2 x3) m sf)
                     end
      end
    end.
Obligation 1.
admit.
Admitted.

Definition fromList {a} : list a -> Seq a :=
  Mk_Seq GHC.Base.∘ ((@mkTree (Elem a) _ (GHC.Num.fromInteger 1)) GHC.Base.∘ map_elem). *)

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

Definition  mapWithIndexNode {a} {b} `{Sized a}
                             : (GHC.Num.Int -> a -> b) -> GHC.Num.Int -> Node a -> Node b :=
                             fun arg_2__ arg_3__ arg_4__ =>
                               match arg_2__ , arg_3__ , arg_4__ with
                                 | f , s , Node2 ns a b => let sPsa := s GHC.Num.+ size a in
                                                           GHC.Prim.seq sPsa (Node2 ns (f s a) (f sPsa b))
                                 | f , s , Node3 ns a b c => let sPsa := s GHC.Num.+ size a in
                                                             let sPsab := sPsa GHC.Num.+ size b in
                                                             GHC.Prim.seq sPsa (GHC.Prim.seq sPsab (Node3 ns (f s a) (f
                                                                                sPsa
                                                                                b)
                                                                                (f sPsab c)))
                               end.

Definition  mapWithIndexDigit {a} {b} `{Sized a}
  : (GHC.Num.Int -> a -> b) -> GHC.Num.Int -> Digit a -> Digit b :=
  fun arg_11__ arg_12__ arg_13__ =>
    match arg_11__ , arg_12__ , arg_13__ with
    | f , s , One a => One (f s a)
    | f , s , Two a b => let sPsa := s GHC.Num.+ size a in
                        GHC.Prim.seq sPsa (Two (f s a) (f sPsa b))
    | f , s , Three a b c => let sPsa := s GHC.Num.+ size a in
                            let sPsab := sPsa GHC.Num.+ size b in
                            GHC.Prim.seq sPsa (GHC.Prim.seq sPsab (Three (f s a) (f sPsa
                                                                                b) (f
                                                                                sPsab
                                                                                c)))
    | f , s , Four a b c d => let sPsa := s GHC.Num.+ size a in
                             let sPsab := sPsa GHC.Num.+ size b in
                             let sPsabc := sPsab GHC.Num.+ size c in
                             GHC.Prim.seq sPsa (GHC.Prim.seq sPsab (GHC.Prim.seq sPsabc
                                                                                (Four (f
                                                                                s
                                                                                a)
                                                                                (f sPsa
                                                                                b) (f
                                                                                sPsab
                                                                                c) (f
                                                                                sPsabc
                                                                                d))))
    end.

(*
Fixpoint mapWithIndexTree {a} {b} `{Sized a} (f : GHC.Num.Int -> a -> b) (s : GHC.Num.Int) (ft: FingerTree a) : FingerTree b :=
  match ft with
  | Empty => GHC.Prim.seq s Empty
  | Single xs => Single GHC.Base.$ f s xs
  | Deep n pr m sf => let sPsprm := (s GHC.Num.+ n) GHC.Num.- size sf in
                             let sPspr := s GHC.Num.+ size pr in
                             GHC.Prim.seq sPspr (GHC.Prim.seq sPsprm (Deep n
                                                                           (mapWithIndexDigit
                                                                              f s pr)
                                                                           (mapWithIndexTree
                                                                              (mapWithIndexNode
                                                                                f) sPspr m)
                                                                           (mapWithIndexDigit
                                                                              f sPsprm sf)))
  end.

Definition mapWithIndex {a} {b} : (GHC.Num.Int -> a -> b) -> Seq a -> Seq b :=
  fun arg_0__ arg_1__ =>
    match arg_0__ , arg_1__ with
      | f' , Mk_Seq xs' =>  Mk_Seq GHC.Base.$ mapWithIndexTree (fun arg_34__ arg_35__ =>
                                                                match arg_34__ , arg_35__ with
                                                                  | s , Mk_Elem a => Mk_Elem (f' s a)
                                                                end) (GHC.Num.fromInteger 0) xs'
    end.
*)

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

Parameter viewLTree : forall {a} `{Sized a}, (FingerTree a) -> Maybe2 a (FingerTree a).
(*
Fixpoint viewLTree {a} `{Sized a} ( arg_0__ : FingerTree a) : Maybe2 a (FingerTree a) :=
  let pullL {a} : GHC.Num.Int -> FingerTree (Node a) -> Digit
                       a -> FingerTree a :=
  fun s m sf =>
    match viewLTree m with
      | Nothing2 => digitToTree' s sf
      | Just2 pr m' => Deep s (nodeToDigit pr) m' sf
    end in

    match arg_0__ with
      | Empty => Nothing2
      | Single a => Just2 a Empty
      | Deep s (One a) m sf => Just2 a (pullL (s GHC.Num.- size a) m sf)
      | Deep s (Two a b) m sf => Just2 a (Deep (s GHC.Num.- size a) (One b) m sf)
      | Deep s (Three a b c) m sf => Just2 a (Deep (s GHC.Num.- size a) (Two b c) m
                                             sf)
      | Deep s (Four a b c d) m sf => Just2 a (Deep (s GHC.Num.- size a) (Three b c d)
                                              m sf)
    end. *)

Parameter viewRTree : forall {a} `{Sized a}, (FingerTree a) -> Maybe2 (FingerTree a) a.

(*
Fixpoint viewRTree {a} `{Sized a} (arg_0__ : FingerTree a) : Maybe2 (FingerTree a) a :=
  let pullR {a} : GHC.Num.Int -> Digit a -> FingerTree (Node
                                                            a) -> FingerTree a :=
  fun s pr m =>
    match viewRTree m with
      | Nothing2 => digitToTree' s pr
      | Just2 m' sf => Deep s pr m' (nodeToDigit sf)
    end in

    match arg_0__ with
      | Empty => Nothing2
      | Single z => Just2 Empty z
      | Deep s pr m (One z) => Just2 (pullR (s GHC.Num.- size z) pr m) z
      | Deep s pr m (Two y z) => Just2 (Deep (s GHC.Num.- size z) pr m (One y)) z
      | Deep s pr m (Three x y z) => Just2 (Deep (s GHC.Num.- size z) pr m (Two x y))
                                     z
      | Deep s pr m (Four w x y z) => Just2 (Deep (s GHC.Num.- size z) pr m (Three w x
                                                                            y)) z
    end.
*)

(*
Fixpoint initsTree {a} {b} `{_:Sized a} (f : (FingerTree a) -> b) (arg_1__ : FingerTree a) : FingerTree b :=
      match arg_1__ with
             | Empty => Empty
             | Single x => Single (f (Single x))
             | Deep n pr m sf =>
                let f' := fun ms =>
                            (match viewRTree ms with
                            | Just2 m' node => GHC.Base.fmap (fun sf' => f (deep pr m' sf')) (initsNode node)
                            | Nothing2 => error
                            end) in
                Deep n (GHC.Base.fmap (f GHC.Base.∘ digitToTree) (initsDigit pr)) (initsTree f' m)
                     (GHC.Base.fmap (f GHC.Base.∘ deep pr m) (initsDigit sf))
           end. *)

Parameter applicativeTree : forall {f} {a} `{GHC.Base.Applicative f},
     GHC.Num.Int -> GHC.Num.Int -> f a -> f (FingerTree a).

Parameter cycleNMiddle : forall {c}, GHC.Num.Int -> Rigid c -> FingerTree (Node c).

Parameter initsTree : forall {a} {b} `{_:Sized a}, ((FingerTree a) -> b) -> (FingerTree a) -> FingerTree b.

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


Require Import MirrorCore.Lambda.ExprCore.
Require Import MirrorCore.Lambda.ExprD.
Require Import MirrorCore.Lambda.Red.
Require Import MirrorCore.Lambda.ExprLift.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.ExprI.

Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Data.Nat.
Require Import ExtLib.Tactics.
Require Import MirrorCore.syms.SymSum.

Require Import Charge.SetoidRewrite.AutoSetoidRewrite.
Require Import Charge.ModularFunc.BaseFunc.

Set Implicit Arguments.
Set Strict Implicit.

Section SetoidRewrite.
  Context {typ func : Type} {RType_typ : RType typ}.
  Context {HB : BaseFunc typ func}.

  Context {RelDec_typ_eq : RelDec (@eq typ)}
          {RelDecCorrect_typ_eq : RelDec_Correct RelDec_typ_eq}.

  Context {RelDec_func_eq : RelDec (@eq (expr typ func))}.

  Let Rbase := expr typ func.

  Definition m (T : Type) : Type :=
    rsubst Rbase -> option (T * rsubst Rbase).

  Definition rewriter :=
    expr typ func ->
    list (AutoSetoidRewrite.RG Rbase) ->
    AutoSetoidRewrite.RG Rbase -> m (expr typ func).

  Definition rw_type :=
    expr typ func -> list (RG Rbase) -> RG Rbase -> m (expr typ func).

  Definition rw_under (r : RG Rbase) (rw : rw_type) : rw_type :=
    fun e rvars => rw e (r :: rvars).

  Definition rg_bind {T U} (a : m T) (b : T -> m U) : m U :=
    fun s => match a s with
               | None => None
               | Some (val,s') => b val s'
             end.

  Definition rg_fail {T} : m T := fun _ => None.
  Definition rg_ret {T} (v : T) : m T := fun s => Some (v, s).
  Definition rg_plus {T} (l r : m T) : m T :=
    fun s =>
      let v := l s in
      match v with
        | None => r s
        | Some _ => v
      end.
  Definition rg_fmap {T U} (f : T -> U) (l : m T) : m U :=
    fun s =>
      match l s with
        | None => None
        | Some (x,y) => Some (f x, y)
      end.

  Section do_several.
    Variable (rw : rewriter).

    Fixpoint do_several (n : nat) a b c {struct n} :=
      match n with
        | 0 => rg_ret a
        | S n => fun d => match rw a b c d with
                            | None => rg_ret a d
                            | Some (a',d') => do_several n a' b c d'
                          end
      end.
  End do_several.

  Section do_severalK.
    Variable (rw : rewriter -> rewriter).

    Fixpoint do_severalK  (n : nat) (rw' : rewriter)
             (a : expr typ func) (b : list (AutoSetoidRewrite.RG Rbase))
             (c :  AutoSetoidRewrite.RG Rbase) {struct n} :=
      match n with
        | 0 => rg_ret a
        | S n => fun d =>
                   AutoSetoidRewrite.tryRewrite
                     (rw (fun a b c d => do_severalK n rw' a b c d))
                     a b c d
      end.
  End do_severalK.

  Definition rw_fail : rewriter := fun _ _ _ => rg_fail.

  Definition sr_combine (f g : expr typ func -> list (RG (expr typ func)) -> RG (expr typ func) -> m (expr typ func))
    (e : (expr typ func)) (rvars : list (RG (expr typ func))) (rg : RG (expr typ func)) :
  	m (expr typ func) :=
    rg_plus (f e rvars rg) (g e rvars rg).

  Definition sr_combineK (f g : rw_type -> rw_type)
             (k : rw_type)
             (e : (expr typ func)) (rvars : list (AutoSetoidRewrite.RG (expr typ func))) (rg : AutoSetoidRewrite.RG (expr typ func)) :
    m (expr typ func) :=
    rg_plus (f k e rvars rg) (g k e rvars rg).

  Definition setoid_rewrite vars :=
  fun (RelDec_func_eq : RelDec.RelDec eq) =>
  let Rbase := expr typ func in
  fun (rel : typ -> Rbase)
    (rewrite_start : rewriter)
    (rewrite_respects : rewriter)
    (rewrite_exs : rewriter -> rewriter)
    (l : typ) (e : expr typ func) =>
    (AutoSetoidRewrite.setoid_rewrite
       RelDec.rel_dec
       rewrite_start
       rewrite_respects
       (do_severalK rewrite_exs 1024 (fun a _ _ => rg_ret a)))
      e (map (fun t => RGinj (Inj (fEq t))) vars) (AutoSetoidRewrite.RGinj (rel l))
      (AutoSetoidRewrite.rsubst_empty Rbase).

End SetoidRewrite.


Require Export MinBFTcount.
Require Export MinBFTacc_exec.
Require Export MinBFTacc_new.
Require Export MinBFTvreq_mon.

Section MinBFTprops1.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext        }.
  Context { minbft_context      : MinBFT_context      }.
  Context { m_initial_keys      : MinBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys   }.
  Context { usig_hash           : USIG_hash           }.
  Context { minbft_auth         : MinBFT_auth         }.

  Lemma accepted_counter_if_know_UI_primary :
    forall {eo    : EventOrdering}
           (e     : Event)
           (R     : Rep)
           (r     : Request)
           (i     : nat)
           (l     : list name),
      In (send_accept (accept r i) l) (M_output_ls_on_event (MinBFTlocalSys R) e)
      ->
      exists (s  : MAIN_state)
             (s1 : USIG_state)
             (s2 : LOG_state)
             (ui : UI),
        M_run_ls_on_event (MinBFTlocalSys R) e = Some (MinBFTlocalSys_new R s s1 s2)
        /\ kc_knows (minbft_data_rdata (request_data (current_view s) r ui)) s2
        /\ kc_Tknows ui s2
        /\ kc_trust2owner ui = Some (MinBFTprimary (current_view s))
        /\ kc_trust_has_id ui i.
  Proof.
    introv h.
    apply accepted_counter_if_received_UI_primary in h.
    exrepnd.
    exists s s1 s2 ui.
    simpl.
    dands; auto; unfold MinBFT_data_knows; simpl; subst; allrw; eauto 3 with minbft;[].
    unfold request_data_in_log; simpl.
    allrw <-; autorewrite with minbft; allrw; auto.
  Qed.

  Lemma kc_Tknows_implies :
    forall  (ui : UI) (l : LOG_state),
      kc_Tknows ui l
      -> exists en,
        In en l                     (* FIX: Do we need this one instead? find_entry rd l = Some e *)
        /\ ui_in_log ui l = true    (* FIX: do we need this one? *)
        /\
        (
          (exists rd, request_data2ui rd = ui )
          \/
          (In ui (log_entry_commits en))
        ).
  Proof.
    introv H.
    unfold kc_Tknows in *.
    unfold kc_knows in *. simpl in *.
    unfold MinBFT_data_knows in *.
    unfold MinBFT_data_in_log in *.

    unfold ui_in_log in *.
    eapply existsb_exists in H.
    exrepnd.
    rename x into en.

    unfold ui_in_log_entry in *.
    dest_cases w;[|].
    {
      exists en; dands; eauto.
      eapply existsb_exists.
      exists en. dands; eauto.
      dest_cases x.
    }
    {
      dest_cases x;[].
      exists en; dands; eauto.
      eapply existsb_exists.
      exists en; dands; eauto.
      dest_cases x;[].
      dest_cases y.
    }
  Qed.

(*  Lemma uis_where_verified :
    forall {eo : EventOrdering} (e : Event) (l : LOG_state) (u : USIG_state) (ui : UI),
      is_replica e
      -> M_state_sys_on_event MinBFTsys e LOGname = Some l
      -> M_state_sys_on_event MinBFTsys e USIGname = Some u
      -> kc_Tknows ui l
      ->
      exists hd,
        kc_knows (minbft_data_hdata hd) l
        /\ verify_hash_usig hd (ui2digest ui) (usig_local_keys u) = true.
  Proof.
    introv isr eqst1 eqst2 unl.

    unfold kc_Tknows in unl; simpl in unl.
    unfold MinBFT_data_knows in unl; simpl in unl.

    rewrite M_state_sys_on_event_unfold in eqst1.
    rewrite M_state_sys_on_event_unfold in eqst2.

    apply map_option_Some in eqst1.
    apply map_option_Some in eqst2.
    exrepnd; try rev_Some.

    rewrite eqst1 in eqst2; ginv.

    unfold is_replica in *; exrepnd.

    revert dependent u.
    revert dependent l.
    revert dependent a.
    rewrite isr0; simpl.

    (* WARNING *)
    clear isr0.

    induction e as [e ind] using predHappenedBeforeInd;[]; introv run stl inlog stu.

    rewrite M_run_ls_on_event_unroll in run.
    rewrite M_run_ls_before_event_unroll_on in run.

    destruct (dec_isFirst e) as [d|d].

    {
      clear ind.

      unfold M_run_ls_on_this_one_event in run; simpl in *.
      apply map_option_Some in run; exrepnd; rev_Some.
      unfold M_break in run0; simpl in *; smash_minbft; repnd; simpl in *.
      apply option_map_Some in run0; exrepnd; subst; simpl in *.

      minbft_dest_msg Case a0; simpl in *;
        try (complete (inversion Heqx; subst; simpl in *;
                       unfold state_of_subcomponents in *;
                       simpl in *; ginv));
        [| |].

      { Case "Request".

        unfold call_create_ui, bind in *; simpl in *.
        inversion Heqx; subst; simpl in *; clear Heqx;
          unfold state_of_subcomponents in *; simpl in *; ginv.
        unfold ui_in_log in *; simpl in *.
        unfold ui_in_log_entry in *; simpl in *.
        smash_minbft; simpl in *.
        unfold MinBFT_data_knows; simpl.
        unfold hash_data_in_log_entry, RequestData2HashData; simpl.
        exists (Build_HashData initial_view (request_b m) (Build_preUI r 1)).
        simpl; smash_minbft; GC; dands; auto. }

      { Case "Prepare".

        unfold call_verify_ui, bind in *; simpl in *; smash_minbft;
          try (complete (unfold state_of_subcomponents in *; simpl in *;
                         ginv; eapply ind in run1; eauto; eauto 3 with eo)).

        { unfold state_of_subcomponents in *; simpl in *; ginv.
          unfold ui2rep, ui_in_log in *; simpl in *; autorewrite with bool in *; subst.
          unfold ui_in_log_entry in *; simpl in *; autorewrite with minbft in *; smash_minbft.
          unfold verify_UI in *; simpl in *; autorewrite with minbft in *.
          exists (prepare2hash_data p); dands; auto.
          unfold MinBFT_data_knows; simpl.
          unfold hash_data_in_log_entry; simpl; smash_minbft. }

        { unfold state_of_subcomponents in *; simpl in *; ginv.
          unfold ui2rep, ui_in_log in *; simpl in *; autorewrite with bool in *; subst.
          unfold ui_in_log_entry in *; simpl in *; autorewrite with minbft in *; smash_minbft.

          { unfold verify_UI in *; simpl in *; autorewrite with minbft in *.
            exists (prepare2hash_data p); dands; auto.
            unfold MinBFT_data_knows; simpl.
            unfold hash_data_in_log_entry; simpl; smash_minbft. }

          { exists (Build_HashData
                      (prepare2view p)
                      (request_b (prepare2request p))
                      (Build_preUI r 1)); simpl.
            autorewrite with minbft; dands; auto.
            unfold MinBFT_data_knows; simpl.
            unfold hash_data_in_log_entry; simpl; smash_minbft. } }

        { unfold state_of_subcomponents in *; simpl in *; ginv.
          unfold ui2rep, ui_in_log in *; simpl in *; autorewrite with bool in *; subst.
          unfold ui_in_log_entry in *; simpl in *; autorewrite with minbft in *; smash_minbft.

          { unfold verify_UI in *; simpl in *; autorewrite with minbft in *.
            exists (prepare2hash_data p); dands; auto.
            unfold MinBFT_data_knows; simpl.
            unfold hash_data_in_log_entry; simpl; smash_minbft. }

          { unfold invalid_prepare in *; smash_minbft.
            apply valid_prepare_implies_view in Heqx0; rewrite Heqx0 in *.
            autorewrite with minbft in *; tcsp. } }
      }

      { Case "Commit".
        unfold call_verify_ui, bind in *; simpl in *; smash_minbft;
          try (complete (unfold state_of_subcomponents in *; simpl in *; ginv));[].

        unfold call_prepare_already_in_log, bind_pair, bind in *; simpl in *; smash_minbft;[].
        unfold call_log_commit, bind in *; simpl in *; smash_minbft;[|].

        { unfold invalid_commit, valid_commit in *; smash_minbft. }

        { unfold call_is_committed, bind in *; simpl in *; smash_minbft;[|].

          { unfold state_of_subcomponents in *; simpl in *; ginv; simpl in *.
            smash_minbft; repndors; ginv.
            unfold ui_in_log_entry in *; simpl in *; autorewrite with minbft in *; smash_minbft;[|].

            { exists (commit2hash_data_i c).
              unfold verify_UI in *; autorewrite with minbft in *; dands; auto.
              unfold MinBFT_data_knows; simpl.
              unfold hash_data_in_log_entry; simpl; smash_minbft. }

            { unfold add_commit2commits, ui2rep in *; simpl in *; smash_minbft;
                repndors; subst; tcsp;[| |].
              { exists (Build_HashData
                          (commit2view c)
                          (request_b (commit2request c))
                          (Build_preUI (commit2sender_j c) 1)); simpl.
                autorewrite with minbft; dands; auto.
                unfold MinBFT_data_knows; simpl.
                unfold hash_data_in_log_entry; simpl; smash_minbft; tcsp. }
              { exists (commit2hash_data_j c).
                unfold verify_UI in *; autorewrite with minbft in *; dands; auto.
                unfold MinBFT_data_knows; simpl.
                unfold hash_data_in_log_entry; simpl; smash_minbft. }
              { unfold ui2digest; simpl.
                exists (Build_HashData
                          (commit2view c)
                          (request_b (commit2request c))
                          (Build_preUI r 1)); simpl.
                autorewrite with minbft; dands; auto;[].
                unfold MinBFT_data_knows; simpl.
                unfold hash_data_in_log_entry; simpl; smash_minbft; tcsp. }
            }
          }

          { unfold state_of_subcomponents in *; simpl in *; ginv.
            unfold ui_in_log in *; simpl in *; autorewrite with bool in *.
            unfold ui_in_log_entry in *; simpl in *; smash_minbft;[|].

            { exists (commit2hash_data_i c).
              unfold verify_UI in *; autorewrite with minbft in *; dands; auto.
              unfold MinBFT_data_knows; simpl.
              unfold hash_data_in_log_entry; simpl; smash_minbft. }

            { unfold add_commit2commits, ui2rep in *; simpl in *; smash_minbft;
                repndors; subst; tcsp;[| |].
              { exists (Build_HashData
                          (commit2view c)
                          (request_b (commit2request c))
                          (Build_preUI (commit2sender_j c) 1)); simpl.
                autorewrite with minbft; dands; auto.
                unfold MinBFT_data_knows; simpl.
                unfold hash_data_in_log_entry; simpl; smash_minbft; tcsp. }
              { exists (commit2hash_data_j c).
                unfold verify_UI in *; autorewrite with minbft in *; dands; auto.
                unfold MinBFT_data_knows; simpl.
                unfold hash_data_in_log_entry; simpl; smash_minbft. }
              { unfold ui2digest; simpl.
                exists (Build_HashData
                          (commit2view c)
                          (request_b (commit2request c))
                          (Build_preUI r 1)); simpl.
                autorewrite with minbft; dands; auto;[].
                unfold MinBFT_data_knows; simpl.
                unfold hash_data_in_log_entry; simpl; smash_minbft; tcsp. }
            }
          }
        }
      }
    }

    {
      apply map_option_Some in run; exrepnd; rev_Some.
      applydup M_run_ls_on_event_ls_is_minbft in run1; exrepnd; subst.

      unfold M_run_ls_on_this_one_event in run0; simpl in *.
      apply map_option_Some in run0; exrepnd; rev_Some.
      unfold M_break in run2; simpl in *; smash_minbft; repnd; simpl in *.
      apply option_map_Some in run2; exrepnd; subst; simpl in *.

      minbft_dest_msg Case a0; simpl in *;
        try (complete (inversion Heqx; subst; simpl in *;
                       unfold state_of_subcomponents in *;
                       simpl in *; ginv;
                       eapply ind in run1; eauto; eauto 3 with eo));
        [| |].

      { Case "Request".

        unfold call_create_ui, bind in *; simpl in *.
        inversion Heqx; subst; simpl in *; clear Heqx;
          unfold state_of_subcomponents in *; simpl in *; ginv.

        rewrite ui_in_log_log_new_prepare in inlog; simpl in *.
        smash_minbft; simpl in *.

        { unfold MinBFT_data_knows; simpl.
          exists (Build_HashData
                    (current_view s)
                    (request_b m)
                    (Build_preUI (usig_id s1) (S (usig_counter s1)))).
          rewrite hash_data_in_log_log_new_prepare.
          Opaque HashData_Deq.
          simpl.
          unfold RequestData2HashData; simpl.
          smash_minbft. }

        eapply ind in run1; try exact inlog; try reflexivity; eauto 3 with eo;[].
        exrepnd.
        exists hd.

        unfold MinBFT_data_knows; simpl.
        rewrite hash_data_in_log_log_new_prepare; simpl in *.
        unfold RequestData2HashData; simpl; allrw.
        smash_minbft. }

      { Case "Prepare".

        unfold call_verify_ui, bind in Heqx; simpl in *; smash_minbft;
          try (complete (unfold state_of_subcomponents in *; simpl in *;
                         ginv; eapply ind in run1; eauto; eauto 3 with eo));[].
        unfold call_prepare_already_in_log, bind in Heqx2; simpl in *; smash_minbft;
          try (complete (unfold state_of_subcomponents in *; simpl in *;
                         ginv; eapply ind in run1; eauto; eauto 3 with eo));[].
        unfold state_of_subcomponents in *; simpl in *; ginv.
        unfold invalid_prepare in *; smash_minbft.
        rewrite ui_in_log_log_new_commit in inlog ;simpl in *.
        unfold commit2ui_i in inlog; simpl in *.
        unfold commit_ui_j_rep_not_in_log in inlog; simpl in *.
        unfold commit2sender_j in inlog; simpl in *.
        unfold MinBFT_data_knows; simpl.
        applydup valid_prepare_implies_view in Heqx0 as eqv.
        rewrite eqv in inlog; autorewrite with minbft in *.
        rewrite prepare_not_already_in_log_implies_find_entry in inlog; auto;[].
        simpl in *; autorewrite with minbft in *.

        smash_minbft;[| |].

        { exists (prepare2hash_data p); simpl.
          unfold verify_UI in *; autorewrite with minbft in *.
          dands; auto;[].
          rewrite hash_data_in_log_log_new_commit_eq.
          unfold commit2hash_data_i; simpl.
          unfold commit_ui_j_rep_not_in_log; simpl.
          unfold commit2sender_j in *; simpl in *.
          unfold commit2hash_data_j; simpl.
          unfold RequestData2HashData; simpl in *.
          rewrite eqv; autorewrite with minbft.
          smash_minbft. }

        { rewrite ui_in_log_log_new_prepare in Heqx2; smash_minbft;[]; GC.
          eapply ind in run1; try exact Heqx2; try reflexivity; eauto 3 with eo.
          exrepnd.
          exists hd; dands; auto.
          unfold MinBFT_data_knows; simpl.
          rewrite hash_data_in_log_log_new_commit_eq; simpl.
          unfold commit2hash_data_i; simpl.
          unfold commit_ui_j_rep_not_in_log; simpl.
          unfold commit2sender_j in *; simpl in *.
          unfold commit2hash_data_j; simpl.
          unfold RequestData2HashData; simpl in *.
          rewrite eqv; autorewrite with minbft.
          rewrite prepare_not_already_in_log_implies_find_entry; auto;[].
          simpl in *; autorewrite with minbft.
          unfold MinBFT_data_knows in run1;simpl in run1.
          smash_minbft; allrw MinBFTprops0.not_over_or; repnd; tcsp; GC;
            try rewrite @hash_data_in_log_log_new_prepare in *; smash_minbft. }

        { exists (Build_HashData
                    (prepare2view p)
                    (request_b (prepare2request p))
                    (Build_preUI (usig_id s1) (S (usig_counter s1)))); simpl.
          autorewrite with minbft; dands; auto;[].
          allrw not_over_or; repnd; GC.
          Opaque UI_dec.
          rewrite @ui_in_log_log_new_prepare in *; simpl in *.
          smash_minbft;[]; GC.
          rewrite hash_data_in_log_log_new_commit_eq; simpl.
          unfold commit2hash_data_i; simpl.
          unfold commit_ui_j_rep_not_in_log; simpl.
          unfold commit2sender_j in *; simpl in *.
          unfold commit2hash_data_j; simpl.
          unfold RequestData2HashData; simpl in *.
          rewrite eqv; autorewrite with minbft.
          rewrite prepare_not_already_in_log_implies_find_entry; auto;[].
          simpl in *; autorewrite with minbft.
          smash_minbft. }
      }

      { Case "Commit".

        unfold call_verify_ui, bind in Heqx; simpl in *; smash_minbft;
          try (complete (unfold state_of_subcomponents in *; simpl in *;
                         ginv; eapply ind in run1; eauto; eauto 3 with eo));[].
        unfold call_prepare_already_in_log, bind_pair, bind in *; simpl in *; smash_minbft;
          try (complete (unfold state_of_subcomponents in *; simpl in *;
                         ginv; eapply ind in run1; eauto; eauto 3 with eo));[|].

        {
          unfold call_log_commit, bind in Heqx4; simpl in *; smash_minbft;
            try (complete (unfold state_of_subcomponents in *; simpl in *;
                           ginv; eapply ind in run1; eauto; eauto 3 with eo));[].
          unfold call_is_committed, bind in Heqx; simpl in *; smash_minbft;
            try (complete (unfold state_of_subcomponents in *; simpl in *;
                           ginv; eapply ind in run1; eauto; eauto 3 with eo));[|].

          { unfold state_of_subcomponents in *; simpl in *; ginv.
            rewrite ui_in_log_log_new_commit in inlog; smash_minbft;
              try (complete (eapply ind in run1; eauto; eauto 3 with eo));
              [| |].

            { exists (commit2hash_data_i c); simpl.
              unfold verify_UI in *; simpl in *; autorewrite with minbft in *.
              dands; auto;[].
              unfold MinBFT_data_knows in *; simpl in *.
              rewrite hash_data_in_log_log_new_commit_eq; smash_minbft. }

            { eapply ind in run1; try exact Heqx; simpl in *;
                unfold state_of_subcomponents in *; simpl in *; try reflexivity;
                  eauto 3 with eo; exrepnd; exists hd; dands; auto.
              unfold MinBFT_data_knows in *; simpl in *.
              rewrite hash_data_in_log_log_new_commit_eq; smash_minbft. }

            { exists (commit2hash_data_j c).
              unfold verify_UI in *; simpl in *; autorewrite with minbft in *.
              dands; auto;[].
              unfold MinBFT_data_knows in *; simpl in *.
              rewrite hash_data_in_log_log_new_commit_eq; smash_minbft. }
          }

          { unfold state_of_subcomponents in *; simpl in *; ginv.
            rewrite ui_in_log_log_new_commit in inlog; smash_minbft;
              try (complete (eapply ind in run1; eauto; eauto 3 with eo));
              [| |].

            { exists (commit2hash_data_i c); simpl.
              unfold verify_UI in *; simpl in *; autorewrite with minbft in *.
              dands; auto;[].
              unfold MinBFT_data_knows in *; simpl in *.
              rewrite hash_data_in_log_log_new_commit_eq; smash_minbft. }

            { eapply ind in run1; try exact Heqx; simpl in *;
                unfold state_of_subcomponents in *; simpl in *; try reflexivity;
                  eauto 3 with eo; exrepnd; exists hd; dands; auto.
              unfold MinBFT_data_knows in *; simpl in *.
              rewrite hash_data_in_log_log_new_commit_eq; smash_minbft. }

            { exists (commit2hash_data_j c).
              unfold verify_UI in *; simpl in *; autorewrite with minbft in *.
              dands; auto;[].
              unfold MinBFT_data_knows in *; simpl in *.
              rewrite hash_data_in_log_log_new_commit_eq; smash_minbft. }
          }
        }

        {
          unfold call_log_commit, bind in Heqx4; simpl in *; smash_minbft;
            try (complete (unfold state_of_subcomponents in *; simpl in *;
                           ginv; eapply ind in run1; eauto; eauto 3 with eo));[].
          unfold call_is_committed, bind in Heqx; simpl in *; smash_minbft;
            try (complete (unfold state_of_subcomponents in *; simpl in *;
                           ginv; eapply ind in run1; eauto; eauto 3 with eo));[|].

          { unfold state_of_subcomponents in *; simpl in *; ginv.
            rewrite ui_in_log_log_new_commit in inlog; smash_minbft;
              try (complete (eapply ind in run1; eauto; eauto 3 with eo));
              [| |].

            { exists (commit2hash_data_i c); simpl.
              unfold verify_UI in *; simpl in *; autorewrite with minbft in *.
              dands; auto;[].
              unfold MinBFT_data_knows in *; simpl in *.
              rewrite hash_data_in_log_log_new_commit_eq; smash_minbft. }

            { rewrite ui_in_log_log_new_commit in Heqx; smash_minbft;
                try (complete (eapply ind in run1; eauto; eauto 3 with eo));
                [| |].

              { exists (commit2hash_data_i c); simpl.
                unfold verify_UI in *; simpl in *; autorewrite with minbft in *.
                dands; auto;[].
                unfold MinBFT_data_knows in *; simpl in *.
                rewrite hash_data_in_log_log_new_commit_eq; smash_minbft. }

              { eapply ind in run1; try exact Heqx; simpl in *;
                  unfold state_of_subcomponents in *; simpl in *; try reflexivity;
                    eauto 3 with eo; exrepnd; exists hd; dands; auto.
                unfold MinBFT_data_knows in *; simpl in *.
                unfold commit2ui_i in *; simpl in *.
                autorewrite with minbft in *.
                rewrite hash_data_in_log_log_new_commit_eq; smash_minbft.
                { rewrite hash_data_in_log_log_new_commit_eq in Heqx; simpl in *.
                  unfold commit_ui_j_rep_not_in_log in *; simpl in *; smash_minbft. }
                { rewrite hash_data_in_log_log_new_commit_eq in Heqx; simpl in *.
                  unfold commit_ui_j_rep_not_in_log in *; simpl in *; smash_minbft. }
              }

              { exists (Build_HashData
                          (commit2view c)
                          (request_b (commit2request c))
                          (Build_preUI (usig_id s1) (S (usig_counter s1)))); simpl.
                unfold verify_UI in *; simpl in *; autorewrite with minbft in *.
                dands; auto;[].
                unfold MinBFT_data_knows in *; simpl in *.
                rewrite hash_data_in_log_log_new_commit_eq; smash_minbft.
                { rewrite hash_data_in_log_log_new_commit_eq in Heqx; simpl in *.
                  unfold commit_ui_j_rep_not_in_log in *; simpl in *; smash_minbft. }
                { rewrite hash_data_in_log_log_new_commit_eq in Heqx; simpl in *.
                  unfold commit_ui_j_rep_not_in_log in *; simpl in *; smash_minbft. }
              }
            }

            { exists (commit2hash_data_j c).
              unfold verify_UI in *; simpl in *; autorewrite with minbft in *.
              dands; auto;[].
              unfold MinBFT_data_knows in *; simpl in *.
              rewrite hash_data_in_log_log_new_commit_eq; smash_minbft. }
          }

          { unfold state_of_subcomponents in *; simpl in *; ginv.
            rewrite ui_in_log_log_new_commit in inlog; smash_minbft;
              try (complete (eapply ind in run1; eauto; eauto 3 with eo));
              [| |].

            { exists (commit2hash_data_i c); simpl.
              unfold verify_UI in *; simpl in *; autorewrite with minbft in *.
              dands; auto;[].
              unfold MinBFT_data_knows in *; simpl in *.
              rewrite hash_data_in_log_log_new_commit_eq; smash_minbft. }

            { rewrite ui_in_log_log_new_commit in Heqx; smash_minbft;
                try (complete (eapply ind in run1; eauto; eauto 3 with eo));
                [| |].

              { exists (commit2hash_data_i c); simpl.
                unfold verify_UI in *; simpl in *; autorewrite with minbft in *.
                dands; auto;[].
                unfold MinBFT_data_knows in *; simpl in *.
                rewrite hash_data_in_log_log_new_commit_eq; smash_minbft. }

              { eapply ind in run1; try exact Heqx; simpl in *;
                  unfold state_of_subcomponents in *; simpl in *; try reflexivity;
                    eauto 3 with eo; exrepnd; exists hd; dands; auto.
                unfold MinBFT_data_knows in *; simpl in *.
                unfold commit2ui_i in *; simpl in *.
                autorewrite with minbft in *.
                rewrite hash_data_in_log_log_new_commit_eq; smash_minbft.
                { rewrite hash_data_in_log_log_new_commit_eq in Heqx; simpl in *.
                  unfold commit_ui_j_rep_not_in_log in *; simpl in *; smash_minbft. }
                { rewrite hash_data_in_log_log_new_commit_eq in Heqx; simpl in *.
                  unfold commit_ui_j_rep_not_in_log in *; simpl in *; smash_minbft. }
              }

              { exists (Build_HashData
                          (commit2view c)
                          (request_b (commit2request c))
                          (Build_preUI (usig_id s1) (S (usig_counter s1)))); simpl.
                unfold verify_UI in *; simpl in *; autorewrite with minbft in *.
                dands; auto;[].
                unfold MinBFT_data_knows in *; simpl in *.
                rewrite hash_data_in_log_log_new_commit_eq; smash_minbft.
                { rewrite hash_data_in_log_log_new_commit_eq in Heqx; simpl in *.
                  unfold commit_ui_j_rep_not_in_log in *; simpl in *; smash_minbft. }
                { rewrite hash_data_in_log_log_new_commit_eq in Heqx; simpl in *.
                  unfold commit_ui_j_rep_not_in_log in *; simpl in *; smash_minbft. }
              }
            }

            { exists (commit2hash_data_j c).
              unfold verify_UI in *; simpl in *; autorewrite with minbft in *.
              dands; auto;[].
              unfold MinBFT_data_knows in *; simpl in *.
              rewrite hash_data_in_log_log_new_commit_eq; smash_minbft. }
          }
        }
      }
    }
  Qed.*)

  Lemma are_procs_n_procs_minbft_subs_new :
    forall u l, are_procs_n_procs (MinBFTsubs_new u l).
  Proof.
    introv i; simpl in *; repndors; subst; tcsp;
      unfold is_proc_n_nproc; simpl; eauto 3 with minbft;
        unfold is_proc_n_proc; simpl; eexists; introv; try reflexivity.
  Qed.
  Hint Resolve are_procs_n_procs_minbft_subs_new : minbft.

  Lemma similar_minbft_implies_subs_new :
    forall (subs : n_procs 1) u l,
      similar_subs (MinBFTsubs_new u l) subs
      -> exists u' l', subs = MinBFTsubs_new u' l'.
  Proof.
    introv sim.
    inversion sim; subst; clear sim.
    inversion sims; subst; clear sims.
    inversion sims0; subst; clear sims0.
    applydup @similar_procs_implies_same_name in simp; simpl in *.
    applydup @similar_procs_implies_same_name in simp0; simpl in *.
    destruct p2, p0; simpl in *; subst; simpl in *.
    destruct pp_proc, pp_proc0; simpl in *; tcsp;[].
    apply @similar_procs_implies_same_proc in simp.
    apply @similar_procs_implies_same_proc in simp0.
    simpl in *; repnd; subst.
    destruct a, a0; simpl in *; subst; simpl in *; tcsp;[].
    unfold similar_sms_at in *; repnd; simpl in *; subst; tcsp.
    unfold MinBFTsubs_new, build_m_sm, build_mp_sm, at2sm; simpl; eauto.
  Qed.

  Lemma M_run_ls_on_input_ls_is_minbft_new :
    forall cn i o r s u l ls,
      M_run_ls_on_input (MinBFTlocalSys_new r s u l) cn i = (ls, o)
      -> exists s' u' l',
        ls = MinBFTlocalSys_new r s' u' l'.
  Proof.
    introv run.
    apply M_run_ls_on_input_ls_is_minbft_newP in run; eauto 3 with minbft; tcsp;
      try (complete (unfold get_names; simpl; introv xx; repndors; tcsp; inversion xx)).
    exrepnd; subst; simpl in *.
    apply similar_minbft_implies_subs_new in run1; exrepnd; subst.
    eexists; eexists; eexists; try reflexivity.
  Qed.

  Lemma request_data_was_verified :
    forall {eo : EventOrdering} (e : Event) (l : LOG_state) (u : USIG_state) v r ui,
      is_replica e
      -> M_state_sys_on_event MinBFTsys e LOGname = Some l
      -> M_state_sys_on_event MinBFTsys e USIGname = Some u
      -> kc_knows (minbft_data_rdata (request_data v r ui)) l
      -> verify_hash_usig (Build_HashData v r (ui_pre ui)) (ui2digest ui) (usig_local_keys u) = true.
  Proof.
    introv isr eqst1 eqst2 unl.

    unfold kc_Tknows in unl; simpl in unl.
    unfold MinBFT_data_knows in unl; simpl in unl.

    rewrite M_state_sys_on_event_unfold in eqst1.
    rewrite M_state_sys_on_event_unfold in eqst2.

    apply map_option_Some in eqst1.
    apply map_option_Some in eqst2.
    exrepnd; try rev_Some.

    rewrite eqst1 in eqst2; ginv.

    unfold is_replica in *; exrepnd.

    revert dependent u.
    revert dependent l.
    revert dependent a.
    rewrite isr0; simpl.

    (* WARNING *)
    clear isr0.

    induction e as [e ind] using predHappenedBeforeInd;[]; introv run stl inlog stu.

    rewrite M_run_ls_on_event_unroll2 in run.

    (*rewrite M_run_ls_before_event_unroll_on in run.

    destruct (dec_isFirst e) as [d|d].

    {
      clear ind.

      unfold M_run_ls_on_this_one_event in run; simpl in *.
      apply map_option_Some in run; exrepnd; rev_Some.
      autorewrite with minbft in *.

      Time minbft_dest_msg Case;
        repeat (simpl in *; autorewrite with minbft in *; smash_minbft2);
        ginv; simpl in *; autorewrite with minbft in *; auto;
          unfold verify_UI in *; simpl in *; autorewrite with minbft in *;
            first [destruct p as [b pui], b
                  |destruct c as [b pui], b]; simpl in *; ginv;
              unfold prepare2hash_data, RequestData2HashData, prepare2request in *; simpl in *; auto;
                unfold invalid_prepare, valid_prepare in *; simpl in *; smash_minbft;
                  unfold prepare2view in *; simpl in *; subst; tcsp;
                    try (complete (unfold state_of_subcomponents in *; simpl in *; ginv)).
    }*)

    {
      apply map_option_Some in run; exrepnd; rev_Some.
      applydup M_run_ls_before_event_ls_is_minbft in run1; exrepnd; subst.

      unfold M_run_ls_on_this_one_event in run0; simpl in *.
      apply map_option_Some in run0; exrepnd; rev_Some; minbft_simp.
      unfold M_run_ls_on_input_ls in *; simpl in *.
      remember (M_run_ls_on_input (MinBFTlocalSys_new r0 s s1 s2) (msg_comp_name 0) a0) as run.
      symmetry in Heqrun; repnd; simpl in *.
      applydup (M_run_ls_on_input_ls_is_minbft_new (msg_comp_name 0)) in Heqrun; exrepnd; subst; simpl in *.
      autorewrite with minbft in *; minbft_simp.
      unfold M_run_ls_on_input in Heqrun; simpl in *.
      autorewrite with minbft in *; simpl in *.

      Time minbft_dest_msg Case;
        repeat (simpl in *; autorewrite with minbft in *; smash_minbft2);
        (unfold lower_out_break in *; simpl in *; minbft_simp;
                  repeat (smash_minbft1; ginv; simpl in *;tcsp);
                  rewrite M_run_ls_before_event_unroll_on in run1;
                  destruct (dec_isFirst e); simpl in *;
                    minbft_simp; simpl in *; repeat (smash_minbft1; ginv; simpl in *;tcsp);
                      try (complete (eapply ind in run1; eauto; eauto 3 with eo));
                      first [destruct p as [b pui], b
                            |destruct c as [b pui], b]; simpl in *; ginv;
                        unfold prepare2hash_data, RequestData2HashData, prepare2request in *; simpl in *; auto;
                          unfold invalid_prepare, valid_prepare in *; simpl in *; smash_minbft3;
                            unfold prepare2view in *; simpl in *; subst; tcsp; ginv; auto).
    }
  Qed.

  Lemma M_run_ls_on_event_MinBFT_to_components :
    forall i {eo : EventOrdering} (e : Event) j s l u,
      loc e = MinBFT_replica i
      -> M_run_ls_on_event (MinBFTlocalSys i) e = Some (MinBFTlocalSys_new j s u l)
      -> M_state_sys_on_event MinBFTsys e MAINname = Some s
         /\ M_state_sys_on_event MinBFTsys e USIGname = Some u
         /\ M_state_sys_on_event MinBFTsys e LOGname = Some l.
  Proof.
    introv eqrep h.
    unfold M_state_sys_on_event; allrw; simpl.
    unfold M_state_ls_on_event.
    allrw; simpl.
    unfold state_of_component; simpl; tcsp.
  Qed.

End MinBFTprops1.


Require Import bedrock2.Syntax bedrock2.NotationsCustomEntry Coq.Strings.String.
Require Import coqutil.Z.div_mod_to_equations.
Require Import coqutil.Z.Lia.
Require Import coqutil.Word.Interface.
Require Import coqutil.Byte.

Import BinInt String List.ListNotations ZArith.
Local Open Scope Z_scope. Local Open Scope string_scope. Local Open Scope list_scope.

Local Notation MMIOWRITE := "MMIOWRITE".
Local Notation MMIOREAD := "MMIOREAD".

Require bedrock2Examples.lightbulb_spec.
Local Notation patience := lightbulb_spec.patience.

Definition spi_write : function :=
  let SPI_WRITE_ADDR := 0x10024048 in
  ("spi_write", (["b"], ["busy"], bedrock_func_body:(
    busy = ($-1);
    i = ($patience); while (i) { i = (i - $1);
      io! busy = $MMIOREAD($SPI_WRITE_ADDR);
      if !(busy >> $31) {
        i = (i^i)
      }
    };
    if !(busy >> $31) {
      output! $MMIOWRITE($SPI_WRITE_ADDR, b);
      busy = (busy ^ busy)
    }
  ))).

Definition spi_read : function :=
  let SPI_READ_ADDR := 0x1002404c in
  ("spi_read", (nil, ("b"::"busy"::nil), bedrock_func_body:(
    busy = ($-1);
    b = ($0x5a);
    i = ($patience); while (i) { i = (i - $1);
      io! busy = $MMIOREAD($SPI_READ_ADDR);
      if !(busy >> $31) {
        b = (busy & $0xff);
        i = (i^i);
        busy = (busy ^ busy)
      }
    }
  ))).

Definition spi_xchg : function :=
  ("spi_xchg", ("b"::nil, "b"::"busy"::nil, bedrock_func_body:(
    unpack! busy = spi_write(b);
    require !busy;
    unpack! b, busy = spi_read()
  ))).

Require Import bedrock2.ProgramLogic.
Require Import bedrock2.FE310CSemantics bedrock2.Semantics.
Require Import Coq.Lists.List. Import ListNotations.
Require Import bedrock2.TracePredicate. Import TracePredicateNotations.
Require Import bedrock2.ZnWords.

Import coqutil.Map.Interface.
Import ReversedListNotations.

Section WithParameters.
  Context {word: word.word 32} {mem: map.map word Byte.byte}.
  Context {word_ok: word.ok word} {mem_ok: map.ok mem}.

  Definition mmio_event_abstraction_relation
    (h : lightbulb_spec.OP word)
    (l : mem * string * list word * (mem * list word)) :=
    Logic.or
      (exists a v, h = ("st", a, v) /\ l = (map.empty, "MMIOWRITE", [a; v], (map.empty, [])))
      (exists a v, h = ("ld", a, v) /\ l = (map.empty, "MMIOREAD", [a], (map.empty, [v]))).
  Definition mmio_trace_abstraction_relation := List.Forall2 mmio_event_abstraction_relation.

  Global Instance spec_of_spi_write : spec_of "spi_write" := fun functions => forall t m b,
    word.unsigned b < 2 ^ 8 ->
    WeakestPrecondition.call functions "spi_write" t m [b] (fun T M RETS =>
      M = m /\ exists iol, T = t ;++ iol /\ exists ioh, mmio_trace_abstraction_relation ioh iol /\ exists err, RETS = [err] /\ Logic.or
        (((word.unsigned err <> 0) /\ lightbulb_spec.spi_write_full _ ^* ioh /\ Z.of_nat (length ioh) = patience))
        (word.unsigned err = 0 /\ lightbulb_spec.spi_write word (byte.of_Z (word.unsigned b)) ioh)).

  Global Instance spec_of_spi_read : spec_of "spi_read" := fun functions => forall t m,
    WeakestPrecondition.call functions "spi_read" t m [] (fun T M RETS =>
      M = m /\ exists iol, T = t ;++ iol /\ exists ioh, mmio_trace_abstraction_relation ioh iol /\ exists (b: byte) (err : word), RETS = [word.of_Z (byte.unsigned b); err] /\ Logic.or
        (word.unsigned err <> 0 /\ lightbulb_spec.spi_read_empty _ ^* ioh /\ Z.of_nat (length ioh) = patience)
        (word.unsigned err = 0 /\ lightbulb_spec.spi_read word b ioh)).

  Lemma nonzero_because_high_bit_set (x : word) (H : word.unsigned (word.sru x (word.of_Z 31)) <> 0)
    : word.unsigned x <> 0.
  Proof. ZnWords. Qed.

  Add Ring wring : (Properties.word.ring_theory (word := word))
        (preprocess [autorewrite with rew_word_morphism],
         morphism (Properties.word.ring_morph (word := word)),
         constants [Properties.word_cst]).

  Import coqutil.Tactics.letexists.
  Import Loops.
  Lemma spi_write_ok : program_logic_goal_for_function! spi_write.
  Proof.
    repeat straightline.
    rename H into Hb.

    (* WHY do theese parentheses matter? *)
    refine ((atleastonce ["b"; "busy"; "i"] (fun v T M B BUSY I =>
       b = B /\ v = word.unsigned I /\ word.unsigned I <> 0 /\ M = m /\
       exists tl, T = tl++t /\
       exists th, mmio_trace_abstraction_relation th tl /\
       lightbulb_spec.spi_write_full _ ^* th /\
       Z.of_nat (length th) + word.unsigned I = patience
       )) _ _ _ _ _ _ _);
      cbn [reconstruct map.putmany_of_list HList.tuple.to_list
           HList.hlist.foralls HList.tuple.foralls
           HList.hlist.existss HList.tuple.existss
           HList.hlist.apply  HList.tuple.apply
           HList.hlist
           List.repeat Datatypes.length
           HList.polymorphic_list.repeat HList.polymorphic_list.length
           PrimitivePair.pair._1 PrimitivePair.pair._2] in *.
    { repeat straightline. }
    { eapply (Z.lt_wf 0). }
    { eexists; split; repeat straightline.
      exfalso. ZnWords. }
    { repeat (split; trivial; []).
      subst i. rewrite word.unsigned_of_Z.
      split.
      { discriminate. }
      split; trivial.
      eexists; split.
      { rewrite app_nil_l; trivial. }
      eexists; split.
      { constructor. }
      split.
      { constructor. }
      exact eq_refl. }
    repeat straightline.
    eapply WeakestPreconditionProperties.interact_nomem; repeat straightline.
    letexists; split; [exact eq_refl|]; split; [split; trivial|].
    {
      cbv [isMMIOAddr addr].
      ZnWords. }
    repeat straightline. split; trivial.
    letexists. split.
    { repeat straightline. exact eq_refl. }
    (* evaluate condition then split if *) letexists; split; [solve[repeat straightline]|split].
    all: intros.
    { (* CASE if-condition was true (word.unsigned v0 <> 0), i.e. NOP, loop exit depends on whether timeout *)
    repeat straightline. (* <-- does split on a postcondition of the form
                        (word.unsigned br <> 0 -> loop invariant still holds) /\
                        (word.unsigned br =  0 -> code after loop is fine)
                        which corresponds to case distinction over whether loop was exited *)
    { (* SUBCASE loop condition was true (do loop again) *)
      eexists; split.
      { repeat (split; trivial; []). subst t0.
        eexists (_ ;++ cons _ nil); split; [exact eq_refl|].
        eexists; split.
        { refine (List.Forall2_app _ _); try eassumption.
          econstructor; [|constructor].
          right; eexists _, _; repeat split. }
        split.
        { eapply kleene_app; eauto.
          refine (kleene_step _ _ nil _ (kleene_empty _)).
          repeat econstructor.
          ZnWords. }
        { ZnWordsL. } }
        { ZnWords. } }
    { (* SUBCASE loop condition was false (exit loop because of timeout *)
      letexists; split; [solve[repeat straightline]|split]; repeat straightline; try contradiction.
      split; eauto.
      subst t0.
      eexists (_ ;++ cons _ nil); split.
      { rewrite <-app_assoc; cbn [app]; f_equal. }
      eexists. split.
      { eapply Forall2_app; eauto.
        constructor; [|constructor].
        right; eauto. }
      eexists. split; trivial.
      { left; repeat split; eauto using nonzero_because_high_bit_set.
        { (* copied from above -- trace element for "fifo full" *)
          eapply kleene_app; eauto.
          refine (kleene_step _ _ nil _ (kleene_empty _)).
          repeat econstructor.
          ZnWords. }
        { ZnWordsL. } } }
    }
    (* CASE if-condition was false (word.unsigned v0 = 0), i.e. we'll set i=i^i and exit loop *)
    repeat straightline.
    { subst i.
      rewrite Properties.word.unsigned_xor_nowrap in *; rewrite Z.lxor_nilpotent in *; contradiction. }
    (* evaluate condition then split if *) letexists; split; [solve[repeat straightline]|split].
    1:contradiction.
    repeat straightline.
    eapply WeakestPreconditionProperties.interact_nomem; repeat straightline.
    letexists; letexists; split; [exact eq_refl|]; split; [split; trivial|].
    { cbv [isMMIOAddr]. ZnWords. }
    repeat straightline. split; trivial.
    repeat straightline.
    split; trivial. subst t0.
    eexists (_ ;++ cons _ (cons _ nil)). split.
    { rewrite <-app_assoc. cbn [app]. f_equal. }
    eexists. split.
    { eapply List.Forall2_app; eauto.
      { constructor.
        { left. eexists _, _; repeat split. }
        { right; [|constructor].
          right; eexists _, _; repeat split. } } }
    eexists; split; trivial.
    right.
    subst busy.
    split.
    { f_equal. rewrite Properties.word.unsigned_xor_nowrap; rewrite Z.lxor_nilpotent; reflexivity. }
    cbv [lightbulb_spec.spi_write].
    eexists _, _; split; eauto; []; split; eauto.
    eexists (cons _ nil), (cons _ nil); split; cbn [app]; eauto.
    split; repeat econstructor.
    { ZnWords. }
    { cbv [lightbulb_spec.spi_write_enqueue one].
      repeat f_equal.
      eapply Properties.word.unsigned_inj.
      rewrite byte.unsigned_of_Z; cbv [byte.wrap]; rewrite Z.mod_small; ZnWords. }
  Qed.

  Local Ltac split_if :=
    lazymatch goal with
      |- WeakestPrecondition.cmd _ ?c _ _ _ ?post =>
      let c := eval hnf in c in
          lazymatch c with
          | cmd.cond _ _ _ => letexists; split; [solve[repeat straightline]|split]
          end
    end.

  Lemma spi_read_ok : program_logic_goal_for_function! spi_read.
    repeat straightline.
    refine ((atleastonce ["b"; "busy"; "i"] (fun v T M B BUSY I =>
       v = word.unsigned I /\ word.unsigned I <> 0 /\ M = m /\
       B = word.of_Z (byte.unsigned (byte.of_Z (word.unsigned B))) /\
       exists tl, T = tl++t /\
       exists th, mmio_trace_abstraction_relation th tl /\
       lightbulb_spec.spi_read_empty _ ^* th /\
       Z.of_nat (length th) + word.unsigned I = patience
            ))
            _ _ _ _ _ _ _);
      cbn [reconstruct map.putmany_of_list HList.tuple.to_list
           HList.hlist.foralls HList.tuple.foralls
           HList.hlist.existss HList.tuple.existss
           HList.hlist.apply  HList.tuple.apply
           HList.hlist
           List.repeat Datatypes.length
           HList.polymorphic_list.repeat HList.polymorphic_list.length
           PrimitivePair.pair._1 PrimitivePair.pair._2] in *; repeat straightline.
    { exact (Z.lt_wf 0). }
    { exfalso. ZnWords. }
    { split; trivial.
      subst i. rewrite word.unsigned_of_Z.
      split; [inversion 1|].
      split; trivial.
      subst b; rewrite byte.unsigned_of_Z; cbv [byte.wrap];
        rewrite Z.mod_small; rewrite word.unsigned_of_Z.
      2: { cbv. split; congruence. }
      split; trivial.
      eexists nil; split; trivial.
      eexists nil; split; try split; solve [constructor]. }
    { eapply WeakestPreconditionProperties.interact_nomem; repeat straightline.
      letexists; split; [exact eq_refl|]; split; [split; trivial|].
    { cbv [isMMIOAddr]. ZnWords. }
      repeat ((split; trivial; []) || straightline || split_if).
      {
        letexists. split; split.
        { subst v'; exact eq_refl. }
        { split; trivial.
          split; trivial.
          split; trivial.
          eexists (x2 ;++ cons _ nil); split; cbn [app]; eauto.
          eexists. split.
          { econstructor; try eassumption; right; eauto. }
          split.
          {
            refine (kleene_app _ (cons _ nil) _ x3 _); eauto.
            refine (kleene_step _ (cons _ nil) nil _ (kleene_empty _)).
            eexists; split.
            { exact eq_refl. }
            { ZnWords. } }
          { ZnWordsL. } }
          { ZnWords. }
          { ZnWords. } }
      { letexists; split; repeat straightline.
        split; trivial.
        eexists (x2 ;++ cons _ nil); split; cbn [app]; eauto.
        eexists. split.
        { econstructor; try eassumption; right; eauto. }
        eexists (byte.of_Z (word.unsigned x)), _; split.
        { f_equal. eassumption. }
        left; repeat split; eauto using nonzero_because_high_bit_set.
        { refine (kleene_app _ (cons _ nil) _ x3 _); eauto.
          refine (kleene_step _ (cons _ nil) nil _ (kleene_empty _)).
          eexists; split.
          { exact eq_refl. }
          { ZnWords. } }
        { ZnWordsL. } }
      { repeat straightline.
        repeat letexists; split.
        1: split.
        { repeat straightline. }
        2: {
          subst v'.
          subst v.
          subst i.
          rewrite Properties.word.unsigned_xor_nowrap, Z.lxor_nilpotent.
          ZnWords. }
        repeat straightline.
        repeat (split; trivial; []).
        split.
        { subst b.
          (* automatable: multi-word bitwise *)
          change (255) with (Z.ones 8).
          pose proof Properties.word.unsigned_range v0.
          eapply Properties.word.unsigned_inj.
          repeat (
              cbv [byte.wrap word.wrap];
              rewrite ?byte.unsigned_of_Z, ?word.unsigned_of_Z, ?Properties.word.unsigned_and_nowrap,
                      ?Z.land_ones, ?Z.mod_mod, ?Z.mod_small
                by blia;
              change (Z.ones 8 mod 2 ^ 32) with (Z.ones 8)).
          symmetry; eapply Z.mod_small.
          pose proof Z.mod_pos_bound (word.unsigned v0) (2^8) eq_refl.
          clear. Z.div_mod_to_equations. blia. }
        { (* copy-paste from above, trace manipulation *)
          eexists (x2 ;++ cons _ nil); split; cbn [app]; eauto.
          eexists. split.
          { econstructor; try eassumption; right; eauto. }
          subst i.
          rewrite Properties.word.unsigned_xor_nowrap, Z.lxor_nilpotent in H1; contradiction. } }
      { eexists _; split.
        { repeat straightline. }
        split; trivial.
        (* copy-paste from above, trace manipulation *)
        eexists (x2 ;++ cons _ nil); split; cbn [app]; eauto.
        eexists. split.
        { econstructor; try eassumption; right; eauto. }
        eexists (byte.of_Z (word.unsigned b)), _; split.
        { subst b; f_equal.
          (* tag:bitwise *)
          (* automatable: multi-word bitwise *)
          change (255) with (Z.ones 8).
          pose proof Properties.word.unsigned_range v0.
          eapply Properties.word.unsigned_inj.
          repeat (
              cbv [byte.wrap word.wrap];
              rewrite ?byte.unsigned_of_Z, ?word.unsigned_of_Z, ?Properties.word.unsigned_and_nowrap,
                      ?Z.land_ones, ?Z.mod_mod, ?Z.mod_small
                by blia;
              change (Z.ones 8 mod 2 ^ 32) with (Z.ones 8)).
          symmetry; eapply Z.mod_small.
          pose proof Z.mod_pos_bound (word.unsigned v0) (2^8) eq_refl.
          clear. Z.div_mod_to_equations. blia. }
        (* tag:symex *)
        { right; split.
          { subst busy. rewrite Properties.word.unsigned_xor_nowrap, Z.lxor_nilpotent; exact eq_refl. }
          eexists x3, (cons _ nil); split; cbn [app]; eauto.
          split; eauto.
          eexists; split; cbv [one]; trivial.
          split.
          (* tag:bitwise *)
          { ZnWords. }
          subst b.
          (* automatable: multi-word bitwise *)
          change (255) with (Z.ones 8).
          pose proof Properties.word.unsigned_range v0.
          eapply byte.unsigned_inj.
          repeat (
              cbv [byte.wrap word.wrap];
              rewrite ?byte.unsigned_of_Z, ?word.unsigned_of_Z, ?Properties.word.unsigned_and_nowrap,
                      ?Z.land_ones, ?Z.mod_mod, ?Z.mod_small
                by blia;
              change (Z.ones 8 mod 2 ^ 32) with (Z.ones 8)).
          trivial. } } }
  Qed.

  Global Instance spec_of_spi_xchg : spec_of "spi_xchg" := fun functions => forall t m b_out,
    word.unsigned b_out < 2 ^ 8 ->
    WeakestPrecondition.call functions "spi_xchg" t m [b_out] (fun T M RETS =>
      M = m /\ exists iol, T = t ;++ iol /\ exists ioh, mmio_trace_abstraction_relation ioh iol /\ exists (b_in:byte) (err : word), RETS = [word.of_Z (byte.unsigned b_in); err] /\ Logic.or
        (word.unsigned err <> 0 /\ (any +++ lightbulb_spec.spi_timeout _) ioh)
        (word.unsigned err = 0 /\ lightbulb_spec.spi_xchg word (byte.of_Z (word.unsigned b_out)) b_in ioh)).

  Lemma spi_xchg_ok : program_logic_goal_for_function! spi_xchg.
  Proof.
    repeat (
    match goal with
    | |- ?F ?a ?b ?c =>
        match F with WeakestPrecondition.get => idtac end;
        let f := (eval cbv beta delta [WeakestPrecondition.get] in F) in
        change (f a b c); cbv beta
      | H :  _ /\ _ \/ ?Y /\ _, G : not ?X |- _ =>
          constr_eq X Y; let Z := fresh in destruct H as [|[Z ?]]; [|case (G Z)]
      | H :  not ?Y /\ _ \/ _ /\ _, G : ?X |- _ =>
          constr_eq X Y; let Z := fresh in destruct H as [[Z ?]|]; [case (Z G)|]
    end ||

    straightline || straightline_call || split_if || refine (conj _ _) || eauto).

  { eexists. split.
    { exact eq_refl. }
    eexists. split.
    { eauto. }
    eexists. eexists. split.
    { repeat f_equal.
      instantiate (1 := byte.of_Z (word.unsigned b_out)).
      (* automatable: multi-word bitwise *)
      change (255) with (Z.ones 8).
      pose proof Properties.word.unsigned_range b_out.
      eapply Properties.word.unsigned_inj;
      repeat (
      cbv [word.wrap byte.wrap];
      rewrite ?byte.unsigned_of_Z, ?word.unsigned_of_Z, ?Properties.word.unsigned_and_nowrap, ?Z.land_ones, ?Z.mod_mod, ?Z.mod_small by blia;
      change (Z.ones 8 mod 2 ^ 32) with (Z.ones 8));
      rewrite ?Z.mod_small; rewrite ?Z.mod_small; trivial; blia. }
      left; split; eauto.
      eexists nil, x0; repeat split; cbv [any choice lightbulb_spec.spi_timeout]; eauto.
      rewrite app_nil_r; trivial. }

      { destruct H10; intuition eauto.
        { eexists. split.
          { subst a0. subst a.
            rewrite List.app_assoc; trivial. }
            eexists. split.
            { eapply Forall2_app; eauto. }
            eexists _, _; split.
            { subst v; trivial. }
            left; split; eauto.
            eapply concat_app; cbv [any choice lightbulb_spec.spi_timeout]; eauto. }
            eexists.
            subst a0.
            subst a.
            split.
            { rewrite List.app_assoc; trivial. }
            eexists.
            split.
            { eapply Forall2_app; eauto. }
            eexists _, _; split.
            { subst v. eauto. }
            right. split; eauto.
            cbv [lightbulb_spec.spi_xchg].

  assert (Trace__concat_app : forall T (P Q:list T->Prop) x y, P x -> Q y -> (P +++ Q) (y ++ x)). {
    cbv [concat]; eauto. }

    eauto using Trace__concat_app. }
  Qed.
End WithParameters.