Load loadpath.
Require Import ZArith Znumtheory Coq.Lists.List.
Require Import veristar.variables veristar.datatypes veristar.clauses
               veristar.superpose veristar.basic veristar.compare.
Import Superposition.
Require Recdef.

Module HeapResolve.

(** Normalization Rules *)

Definition normalize1_3 (pc sc : clause) : clause :=
  match pc , sc with
  | PureClause gamma (Eqv (Var x) y :: delta) _ _,
    PosSpaceClause gamma' delta' sigma =>
        PosSpaceClause (rsort_uniq pure_atom_cmp (gamma++gamma'))
                       (rsort_uniq pure_atom_cmp (delta++delta'))
                       (subst_spaces x y sigma)
  | PureClause gamma (Eqv (Var x) y :: delta) _ _,
    NegSpaceClause gamma' sigma delta' =>
         NegSpaceClause (rsort_uniq pure_atom_cmp (gamma++gamma'))
                        (subst_spaces x y sigma)
                        (rsort_uniq pure_atom_cmp (delta++delta'))
  | _ , _  => sc
  end.

Definition normalize2_4 (sc : clause) : clause :=
  match sc with
  | PosSpaceClause gamma delta sigma =>
        PosSpaceClause gamma delta (drop_reflex_lseg sigma)
  | NegSpaceClause gamma sigma delta =>
        NegSpaceClause gamma (drop_reflex_lseg sigma) delta
  | _ => sc
  end.

Definition norm (s:  M.t) (sc: clause) : clause :=
  normalize2_4 (List.fold_right normalize1_3 sc
    (rsort (rev_cmp compare_clause2) (M.elements s))).

(** Wellformedness Rules *)

Fixpoint do_well1_2 (sc: list space_atom) : list (list pure_atom) :=
  match sc with
  | Next Nil _ :: sc' => nil :: do_well1_2 sc'
  | Lseg Nil y :: sc' => [Eqv y Nil] :: do_well1_2 sc'
  | _ :: sc' => do_well1_2 sc'
  | nil => nil
  end.

(** Next x ? \in sc *)
Fixpoint next_in_dom (x : Ident.t) (sc : list space_atom) : bool :=
  match sc with
  | nil => false
  | Next (Var x') y :: sc' =>
    if Ident.eq_dec x x' then true
    else next_in_dom x sc'
  | _ :: sc' => next_in_dom x sc'
  end.

(** Next x ? \in sc, ?=y *)
Fixpoint next_in_dom1 (x : Ident.t) (y : expr) (sc : list space_atom) : bool :=
  match sc with
  | nil => false
  | Next (Var x') y' :: sc' =>
    if Ident.eq_dec x x' then if expr_eq y y' then true
    else next_in_dom1 x y sc' else next_in_dom1 x y sc'
  | _ :: sc' => next_in_dom1 x y sc'
  end.

(** Next x ? \in sc, ?<>y *)

Fixpoint next_in_dom2 (x : Ident.t) (y : expr) (sc : list space_atom)
  : option expr :=
  match sc with
  | nil => None
  | Next (Var x') y' :: sc' =>
    if Ident.eq_dec x x' then if expr_eq y y' then next_in_dom2 x y sc'
                                 else Some y'
    else next_in_dom2 x y sc'
  | _ :: sc' => next_in_dom2 x y sc'
  end.

Fixpoint do_well3 (sc: list space_atom) : list (list pure_atom) :=
  match sc with
  | Next (Var x) y :: sc' =>
    if next_in_dom x sc'
      then nil :: do_well3 sc'
      else do_well3 sc'
  | _ :: sc' => do_well3 sc'
  | nil => nil
  end.

(** Lseg x ?, ?<>y *)

Fixpoint lseg_in_dom2 (x : Ident.t) (y : expr) (sc : list space_atom)
  : option expr :=
  match sc with
  | Lseg (Var x' as x0) y0 :: sc' =>
    if Ident.eq_dec x x'
      then if negb (expr_eq y0 y) then Some y0 else lseg_in_dom2 x y sc'
      else lseg_in_dom2 x y sc'
  | _ :: sc' => lseg_in_dom2 x y sc'
  | nil => None
  end.

Fixpoint lseg_in_dom_atoms (x : Ident.t) (sc : list space_atom)
  : list pure_atom :=
  match sc with
  | Lseg (Var x' as x0) y0 :: sc' =>
    if Ident.eq_dec x x'
      then order_eqv_pure_atom (Eqv x0 y0) :: lseg_in_dom_atoms x sc'
      else lseg_in_dom_atoms x sc'
  | _ :: sc' => lseg_in_dom_atoms x sc'
  | nil => nil
  end.

Fixpoint do_well4_5 (sc : list space_atom) : list (list pure_atom) :=
  match sc with
  | Next (Var x') y :: sc' =>
    let atms := map (fun a => [a]) (lseg_in_dom_atoms x' sc') in
      atms ++ do_well4_5 sc'
  | Lseg (Var x' as x0) y :: sc' =>
    let l0 := lseg_in_dom_atoms x' sc' in
      match l0 with
      | nil => do_well4_5 sc'
      | _ :: _ =>
        let atms := map (fun a => normalize_atoms [Eqv x0 y, a]) l0 in
          atms ++ do_well4_5 sc'
      end
  | _ as a :: sc' => do_well4_5 sc'
  | nil => nil
  end.

Definition do_well (sc : list space_atom) : list (list pure_atom) :=
  do_well1_2 sc ++ do_well3 sc ++ do_well4_5 sc.

Definition do_wellformed (sc: clause) : M.t :=
 match sc with
 | PosSpaceClause gamma delta sigma =>
   let sigma' := rsort (rev_cmp compare_space_atom) sigma in
     clause_list2set
       (map (fun ats => mkPureClause gamma (normalize_atoms (ats++delta)))
         (do_well sigma'))
 | _ => M.empty
 end.

(** Unfolding Rules *)

Definition spatial_resolution (pc nc : clause) : M.t :=
  match pc , nc with
  | PosSpaceClause gamma' delta' sigma' , NegSpaceClause gamma sigma delta =>
    match eq_space_atomlist (rsort compare_space_atom sigma)
                            (rsort compare_space_atom sigma') with
    | true => M.singleton (order_eqv_clause (mkPureClause (gamma++gamma') (delta++delta')))
    | false => M.empty
      end
  | _ , _ => M.empty
  end.

Fixpoint unfolding1' (sigma0 sigma1 sigma2 : list space_atom)
  : list (pure_atom * list space_atom) :=
  match sigma2 with
  | Lseg (Var x' as x) z :: sigma2' =>
    if next_in_dom1 x' z sigma1
    (*need to reinsert since replacing lseg with next doesn't always preserve
    sorted order*)
      then
        (Eqv x z,
          insert (rev_cmp compare_space_atom) (Next x z) (rev sigma0 ++ sigma2'))
        :: unfolding1' (Lseg x z :: sigma0) sigma1 sigma2'
      else unfolding1' (Lseg x z :: sigma0) sigma1 sigma2'
  | a :: sigma2' => unfolding1' (a :: sigma0) sigma1 sigma2'
  | nil => nil
  end.

Definition unfolding1 (sc1 sc2 : clause) : list clause :=
  match sc1 , sc2 with
  | PosSpaceClause gamma delta sigma1 , NegSpaceClause gamma' sigma2 delta' =>
    let l0 := unfolding1' nil sigma1 sigma2 in
    let build_clause p :=
      match p with (atm, sigma2') =>
        NegSpaceClause gamma' sigma2'
          (insert_uniq pure_atom_cmp (order_eqv_pure_atom atm) delta')
      end in
      map build_clause l0
  | _ , _ => nil
  end.

Fixpoint unfolding2' (sigma0 sigma1 sigma2 : list space_atom)
  : list (pure_atom * list space_atom) :=
  match sigma2 with
  | Lseg (Var x' as x) z :: sigma2' =>
    match next_in_dom2 x' z sigma1 with
    | Some y =>
      (Eqv x z,
          insert (rev_cmp compare_space_atom) (Next x y)
            (insert (rev_cmp compare_space_atom) (Lseg y z) (rev sigma0 ++ sigma2')))
        :: unfolding2' (Lseg x z :: sigma0) sigma1 sigma2'
    | None => unfolding2' (Lseg x z :: sigma0) sigma1 sigma2'
    end
  | a :: sigma2' => unfolding2' (a :: sigma0) sigma1 sigma2'
  | nil => nil
  end.

Definition unfolding2 (sc1 sc2 : clause) : list clause :=
  match sc1 , sc2 with
  | PosSpaceClause gamma delta sigma1 , NegSpaceClause gamma' sigma2 delta' =>
    let l0 := unfolding2' nil sigma1 sigma2 in
    let build_clause p :=
      match p with (atm, sigma2') =>
        NegSpaceClause gamma' sigma2'
          (insert_uniq pure_atom_cmp (order_eqv_pure_atom atm) delta')
      end in
      map build_clause l0
  | _ , _ => nil
  end.

Fixpoint unfolding3' (sigma0 sigma1 sigma2 : list space_atom) :
  list (list space_atom) :=
  match sigma2 with
  | Lseg (Var x' as x) Nil :: sigma2' =>
    match lseg_in_dom2 x' Nil sigma1 with
    | Some y =>
          insert (rev_cmp compare_space_atom) (Lseg x y)
            (insert (rev_cmp compare_space_atom) (Lseg y Nil) (rev sigma0 ++ sigma2'))
        :: unfolding3' (Lseg x Nil :: sigma0) sigma1 sigma2'
    | None => unfolding3' (Lseg x Nil :: sigma0) sigma1 sigma2'
    end
  | a :: sigma2' => unfolding3' (a :: sigma0) sigma1 sigma2'
  | nil => nil
  end.

Definition unfolding3 (sc1 sc2 : clause) : list clause :=
  match sc1 , sc2 with
  | PosSpaceClause gamma delta sigma1 , NegSpaceClause gamma' sigma2 delta' =>
    let l0 := unfolding3' nil sigma1 sigma2 in
    let build_clause sigma2' := NegSpaceClause gamma' sigma2' delta' in
      map build_clause l0
  | _ , _ => nil
  end.

(** NPR's rule given in the paper. Confirmed unsound by NP.*)

Fixpoint unfolding4NPR' (sigma0 sigma1 sigma2 : list space_atom)
  : list (list space_atom) :=
  match sigma2 with
  | Lseg (Var x' as x) (Var z' as z) :: sigma2' =>
    match lseg_in_dom2 x' z sigma1 with
    | Some y =>
      if next_in_dom z' sigma1 then
          insert (rev_cmp compare_space_atom) (Lseg x y)
            (insert (rev_cmp compare_space_atom) (Lseg y z) (rev sigma0 ++ sigma2'))
        :: unfolding4NPR' (Lseg x z :: sigma0) sigma1 sigma2'
      else unfolding4NPR' (Lseg x z :: sigma0) sigma1 sigma2'
    | None => unfolding4NPR' (Lseg x z :: sigma0) sigma1 sigma2'
    end
  | a :: sigma2' => unfolding4NPR' (a :: sigma0) sigma1 sigma2'
  | nil => nil
  end.

Definition unfoldingNPR4 (sc1 sc2 : clause) : list clause :=
  match sc1 , sc2 with
  | PosSpaceClause gamma delta sigma1 , NegSpaceClause gamma' sigma2 delta' =>
    let l0 := unfolding4NPR' nil sigma1 sigma2 in
    let build_clause sigma2' := NegSpaceClause gamma' sigma2' delta' in
      map build_clause l0
  | _ , _ => nil
  end.

(** Our rule; also suggested by NP. *)

Definition unfolding4 (sc1 sc2 : clause) : list clause :=
  match sc1 , sc2 with
  | PosSpaceClause gamma delta sigma1 , NegSpaceClause gamma' sigma2 delta' =>
    let l0 := unfolding4NPR' nil sigma1 sigma2 in
    let GG' := rsort_uniq pure_atom_cmp (gamma ++ gamma') in
    let DD' := rsort_uniq pure_atom_cmp (delta ++ delta') in
    let build_clause sigma2' := NegSpaceClause GG' sigma2' DD' in
      map build_clause l0
  | _ , _ => nil
  end.

(** Unsound rule as given in NPR's paper *)

Fixpoint unfolding5NPR' (sigma0 sigma1 sigma2 : list space_atom)
  : list (pure_atom * list space_atom) :=
  match sigma2 with
  | Lseg (Var x' as x) (Var z' as z) :: sigma2' =>
    match lseg_in_dom2 x' z sigma1 with
    | Some y =>
      let atms := lseg_in_dom_atoms z' sigma1 in
      let build_res atm :=
        (atm,
          insert (rev_cmp compare_space_atom) (Lseg x y)
            (insert (rev_cmp compare_space_atom) (Lseg y z)
              (rev sigma0 ++ sigma2'))) in
        map build_res atms ++ unfolding5NPR' (Lseg x z :: sigma0) sigma1 sigma2'
    | None => unfolding5NPR' (Lseg x z :: sigma0) sigma1 sigma2'
    end
  | a :: sigma2' => unfolding5NPR' (a :: sigma0) sigma1 sigma2'
  | nil => nil
  end.

Definition unfolding5NPR (sc1 sc2 : clause) : list clause :=
  match sc1 , sc2 with
  | PosSpaceClause gamma delta sigma1 , NegSpaceClause gamma' sigma2 delta' =>
    let l0 := unfolding5NPR' nil sigma1 sigma2 in
    let build_clause p :=
      match p with (atm, sigma2') =>
        NegSpaceClause gamma' sigma2'
          (insert_uniq pure_atom_cmp (order_eqv_pure_atom atm) delta')
      end in
      map build_clause l0
  | _ , _ => nil
  end.

(** Rule as given in NPR's paper, corrected variable uses *)

Fixpoint unfolding5NPRALT' (sigma0 sigma1 sigma2 : list space_atom)
  : list (pure_atom * list space_atom) :=
  match sigma2 with
  | Lseg (Var x' as x) (Var z' as z) :: sigma2' =>
    match lseg_in_dom2 x' z sigma1, lseg_in_dom2 x' z sigma1 with
    | Some y, _ =>
      let atms := lseg_in_dom_atoms z' sigma1 in
      let build_res atm :=
        (atm,
          insert (rev_cmp compare_space_atom) (Lseg x y)
            (insert (rev_cmp compare_space_atom) (Lseg y z)
              (rev sigma0 ++ sigma2'))) in
        map build_res atms ++ unfolding5NPR' (Lseg x z :: sigma0) sigma1 sigma2'
    | None, _ => unfolding5NPR' (Lseg x z :: sigma0) sigma1 sigma2'
    end
  | a :: sigma2' => unfolding5NPR' (a :: sigma0) sigma1 sigma2'
  | nil => nil
  end.

(** Our version - also suggested by NP in his reply. *)

Definition unfolding5 (sc1 sc2 : clause) : list clause :=
  match sc1 , sc2 with
  | PosSpaceClause gamma delta sigma1 , NegSpaceClause gamma' sigma2 delta' =>
    let l0 := unfolding5NPR' nil sigma1 sigma2 in
    let GG' := rsort_uniq pure_atom_cmp (gamma ++ gamma') in
    let DD' := rsort_uniq pure_atom_cmp (delta ++ delta') in
    let build_clause p :=
      match p with (atm, sigma2') =>
        NegSpaceClause GG' sigma2'
          (insert_uniq pure_atom_cmp (order_eqv_pure_atom atm) DD')
      end in
      map build_clause l0
  | _ , _ => nil
  end.

(** Same as unfolding5NPR', but with added side-condition *)

Fixpoint unfolding6NPR' (sigma0 sigma1 sigma2 : list space_atom)
  : list (pure_atom * list space_atom) :=
  match sigma2 with
  | Lseg (Var x' as x) (Var z' as z) :: sigma2' =>
    if Ident.eq_dec x' z' then unfolding6NPR' sigma0 sigma1 sigma2' else
    match lseg_in_dom2 x' z sigma1 with
    | Some y =>
      let atms := lseg_in_dom_atoms z' sigma1 in
      let build_res atm :=
        (atm,
          insert (rev_cmp compare_space_atom) (Lseg x y)
            (insert (rev_cmp compare_space_atom) (Lseg y z)
              (rev sigma0 ++ sigma2'))) in
        map build_res atms ++ unfolding6NPR' (Lseg x z :: sigma0) sigma1 sigma2'
    | None =>
       unfolding6NPR' (Lseg x z :: sigma0) sigma1 sigma2'
    end
  | a :: sigma2' => unfolding6NPR' (a :: sigma0) sigma1 sigma2'
  | nil => nil
  end.

Definition unfolding6 (sc1 sc2 : clause) : list clause :=
  match sc1 , sc2 with
  | PosSpaceClause gamma delta sigma1 , NegSpaceClause gamma' sigma2 delta' =>
    let l0 := unfolding6NPR' nil sigma1 sigma2 in
    let GG' := rsort_uniq pure_atom_cmp (gamma ++ gamma') in
    let DD' := rsort_uniq pure_atom_cmp (delta ++ delta') in
    let build_clause p :=
      match p with (atm, sigma2') =>
        NegSpaceClause GG' sigma2'
          (insert_uniq pure_atom_cmp (order_eqv_pure_atom atm) DD')
      end in
      (map build_clause l0)
  | _ , _ => nil
  end.

Definition mem_add (x: M.elt) (s: M.t) : option M.t :=
 if M.mem x s then None else Some (M.add x s).

Definition add_list_to_set_simple (l: list M.elt) (s: M.t) : M.t :=
  fold_left (Basics.flip M.add) l s.

Fixpoint add_list_to_set (l: list M.elt) (s: M.t) : option M.t :=
 match l with
 | x::xs => match mem_add x s with
                  | None => add_list_to_set xs s
                  | Some s' => Some (add_list_to_set_simple xs s')
                  end
 | nil => None
 end.

Definition do_unfold' pc nc l :=
  unfolding1 pc nc ++
  unfolding2 pc nc ++ unfolding3 pc nc ++
  unfolding4 pc nc ++ unfolding6 pc nc ++ l.

Fixpoint do_unfold (n: nat) (pc : clause) (s : M.t) : M.t :=
  match n with
  | O => s
  | S n' =>
   match add_list_to_set  (M.fold (do_unfold' pc) s nil)  s with
   | Some s'' => do_unfold n' pc s''
   | None => s
   end
  end.

Definition unfolding (pc nc : clause) : M.t :=
  M.fold (fun c => M.union (spatial_resolution pc c))
            (do_unfold 500 pc (M.add nc M.empty)) M.empty.

End HeapResolve.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import ZArith EqNat Classical.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrnat_ext.
Require Import integral_type seplog frag.
Require Import topsy_hm topsy_hmInit_prg.

Require Import expr_b_dp.
Import seplog_Z_m.assert_m.expr_m.
Import seplog_Z_m.assert_m.
Import seplog_Z_m.

Local Close Scope Z_scope.
Local Open Scope heap_scope.
Local Open Scope seplog_expr_scope.
Local Open Scope seplog_assert_scope.
Local Open Scope seplog_cmd_scope.
Local Open Scope seplog_hoare_scope.

(** This file contains the verification of hmInit in two flavors:
  (1) semi-automatic using the "frag" tactic, (2) manual. *)

Definition hmInit_specif := forall p sz, sz >= 4 ->
  {{ Array p sz }} hmInit p sz {{ Heap_List ((sz - 4, topsy_hm.free) :: nil) p }}.

Definition hmInit_precond (adr sz : nat) :=
  (true_b, star
    (star (cell (nat_e adr)) (cell (nat_e adr \+ cst_e 1%Z)))
    (star (cell (nat_e adr \+ nat_e sz \- cst_e 2%Z)) (cell (nat_e adr \+ nat_e sz \- cst_e 1%Z)))).

Definition hmInit_postcond (adr sz : nat):=
  (true_b, star
    (star (singl (nat_e adr) Free) (singl (nat_e adr \+ cst_e 1%Z) (nat_e adr \+ nat_e sz \- cst_e 2%Z)))
    (star (singl (nat_e adr \+ nat_e sz \- cst_e 2%Z) Allocated)
      (singl (nat_e adr \+ nat_e sz \- cst_e 1%Z) (nat_e 0)))).

Lemma frag_precond startp sizep : sizep >= 4 ->
  Array startp sizep ===> assrt_interp (hmInit_precond startp sizep) ** Array (startp + 2) (sizep - 4).
Proof.
move=> H.
rewrite /while.entails => s h H0.
TArray_concat_split_l_l 2 H; clear H0.
case_sepcon H1.
TArray_concat_split_l_r 2 H1_h2; clear H1_h2.
case_sepcon H0.
Compose_sepcon (h1 \U h22) h21.
rewrite /=; split; first by done.
Compose_sepcon h1 h22.
simpl in H1_h1.
case_sepcon H1_h1.
case_sepcon H1_h1_h12.
Compose_sepcon h11 h121; auto.
case: H1_h1_h12_h121 => x ?; exists x; by Mapsto.
simpl in H0_h22.
case_sepcon H0_h22.
case_sepcon H0_h22_h222.
Compose_sepcon h221 h2221; auto.
case: H0_h22_h221 => x ?; exists x; by Mapsto.
case: H0_h22_h222_h2221 => x ?; exists x; by Mapsto.
by Array_equiv.
Qed.

Lemma frag_postcond startp sizep : sizep >= 4 ->
  assrt_interp (hmInit_postcond startp sizep) ** Array (startp + 2) (sizep - 4) ===>
  Heap_List ((sizep - 4, true) :: nil) startp.
Proof.
move=> H s h H0.
case_sepcon H0.
rewrite /= in H0_h1; case H0_h1 => _ H5.
case_sepcon H5.
Compose_sepcon (h11 \U h2) h12.
eapply hl_Free with (h1 := h11 \U h2) (h2 := heap.emp); [by map_tac_m.Disj | by map_tac_m.Equal | auto | intuition | idtac | idtac].
case_sepcon H5_h11.
Compose_sepcon h11 h2; [idtac | by Array_equiv].
simpl; Compose_sepcon h111 h112; first by done.
Compose_sepcon h112 heap.emp; by [Mapsto | red; auto].
by apply hl_last.
case_sepcon H5_h12.
simpl; Compose_sepcon h121 h122.
by Mapsto.
Compose_sepcon h122 assert_m.heap.emp; by [Mapsto | red; auto].
Qed.

Lemma hmInit_verif_auto : hmInit_specif.
Proof.
rewrite /hmInit_specif /hmInit.
move=> p size H.
eapply hoare_prop_m.hoare_weak.
- by apply (frag_postcond p size H).
- eapply hoare_prop_m.hoare_stren.
  by apply (frag_precond p size H).
  Frame_rule (Array (p + 2) (size - 4)); [idtac | eapply Array_inde_list].
  rewrite /hmInit_precond /hmInit_postcond /hmStart /hmEnd /next /status /Allocated /Free.
  eapply LWP_use.
  + rewrite /=; reflexivity.
  + by LWP_Resolve.
Qed.

Lemma hmInit_verif_manual : hmInit_specif.
Proof.
rewrite /hmInit_specif /hmInit => p sz H.

(**
<<
hmStart <- nat_e p;
>>
*)

Step (fun s h => Array p sz s h /\ [ var_e hmStart \= nat_e p ]b_s).

rewrite /wp_assign.
Resolve_topsy.
by Array_equiv.

(**
<<
hmStart -.> next *<- (nat_e p \+ nat_e size) \- cst_e 2%Z;
>>
*)

Step (fun s h => (Array p 1 **
  (var_e hmStart \+ nat_e 1 |~> nat_e p \+ nat_e sz \- cst_e 2%Z) **
  Array (p + 2) (sz - 2)) s h /\ [ var_e hmStart \= nat_e p ]b_s).

case : H0 => H1 H2.
TArray_concat_split_l_l 2 H2.
case_sepcon H0.
rewrite /= in H0_h1; case_sepcon H0_h1.
case_sepcon H0_h1_h12.
case : H0_h1_h12_h121 => x H0_h1_h12_h121.
exists (cst_e x).
Compose_sepcon h121 (h2 \U h11).
- rewrite /next; by Mapsto.
- rewrite /imp => h121' [X1 X2] h' Hh'.
  split; last by assumption.
  rewrite -conAE.
  Compose_sepcon (h11 \U h121') h2; last by assumption.
  Compose_sepcon h11 h121'; last by assumption.
  by Compose_sepcon h11 heap.emp.

(**
<<
hmStart -.> status *<- Free;
>>
*)

Step (fun s h => (var_e hmStart |~> Free **
    var_e hmStart \+ nat_e 1 |~> nat_e p \+ nat_e sz \- cst_e 2%Z **
    Array (p + 2) (sz - 2)) s h /\ [ var_e hmStart \= nat_e p ]b_s).

case : H0 => H1 H2.
rewrite -conAE in H1.
case_sepcon H1.
case_sepcon H1_h1.
rewrite /= in H1_h1_h11; case_sepcon H1_h1_h11.
case : H1_h1_h11_h111 => x H1_h1_h11_h111.
exists (cst_e x).
Compose_sepcon h111 (h12 \U h2).
- rewrite /status; by Mapsto.
- rewrite /imp => h111' [X1 X2] h' Hh'.
  split; last by assumption.
  rewrite -conAE.
  Compose_sepcon (h111' \U h12) h2; last by assumption.
  Compose_sepcon h111' h12; last by assumption.
  rewrite /status in X2; by Mapsto.

(**
<<
hmEnd <-* hmStart -.> next;
>>
*)

Step (fun s h => (var_e hmStart |~> Free **
    var_e hmStart \+ nat_e 1 |~> nat_e p \+ nat_e sz \- cst_e 2%Z **
    Array (p + 2) (sz - 2)) s h /\ [ var_e hmStart \= nat_e p ]b_s /\
  [ var_e hmEnd \= nat_e p \+ nat_e sz \- cst_e 2%Z ]b_s).

case : H0 => H1 H2.
rewrite -conAE in H1.
case_sepcon H1.
case_sepcon H1_h1.
exists ((nat_e p \+ nat_e sz) \- cst_e 2%Z).
Compose_sepcon h12 (h11 \U h2).
- rewrite /next; by Mapsto.
- rewrite /imp => h12' [X1 X2] h' Hh'.
  rewrite /wp_assign; split.
  + rewrite -conAE.
    Compose_sepcon (h11 \U h12') h2.
    Compose_sepcon h11 h12'; apply mapsto_store_upd_subst => /=; by Mapsto.
    by Array_equiv.
  + by Resolve_topsy.

(**
<<
hmEnd -.> next *<- cst_e 0%Z;
>>
*)

Step (fun s h => (var_e hmStart |~> Free **
  var_e hmStart \+ nat_e 1 |~> nat_e p \+ nat_e sz \- cst_e 2%Z **
    Array (p + 2) (sz - 4) ** Array (p + sz - 2) 1 **
    (var_e hmEnd \+ nat_e 1|~> cst_e 0%Z)) s h /\
  [ var_e hmStart \= nat_e p ]b_s /\
  [ var_e hmEnd \= nat_e p \+ nat_e sz \- cst_e 2%Z ]b_s ).

case: H0 => H1 [H3 H4].
rewrite -conAE in H1.
case_sepcon H1.
case_sepcon H1_h1.
TArray_concat_split_l_l (sz - 4) H6.
case_sepcon H0.
rewrite (_ : sz - 2 - (sz - 4) = 2) /= in H0_h22; last by ssromega.
case_sepcon H0_h22.
case_sepcon H0_h22_h222.
case: H0_h22_h222_h2221 => x H0_h22_h222_h2221.
exists (cst_e x).
Compose_sepcon h2221 (h221 \U h21 \U h1).
- rewrite /next; by Mapsto.
- rewrite /imp => h2221' [X1 X2] h' Hh'.
  split.
    rewrite -3!conAE.
    Compose_sepcon (h221 \U h21 \U h1) h2221'; last by Mapsto.
    Compose_sepcon (h21 \U h1) h221.
    Compose_sepcon h1 h21.
    Compose_sepcon h11 h12; by Mapsto.
    by Array_equiv.
  rewrite /=; Compose_sepcon h221 heap.emp; last by done.
  case: H0_h22_h221 => x0 H0_h22_h221.
  exists x0; by Mapsto.
  by Resolve_topsy.

(**
<<
hmEnd -.> status *<- Allocated
>>
*)

Step TT.

rewrite /while.entails => s h [H1 [H3 h4]].
rewrite -3!conAE in H1.
case_sepcon H1.
case_sepcon H1_h1.
case_sepcon H1_h1_h11.
case_sepcon H1_h1_h11_h111.
rewrite /= in H1_h1_h12; case_sepcon H1_h1_h12.
case: H1_h1_h12_h121 => x H1_h1_h12_h121.
exists (cst_e x).
Compose_sepcon h121 (h122 \U h11 \U h2).
- rewrite /status; by Mapsto.
- rewrite /imp => h121' [X1 X2] h' Hh'.
  Compose_sepcon (h11 \U h122) (h121' \U h2).
  + eapply hl_Free with (h1 := h11 \U h122) (h2 := heap.emp).
    * by map_tac_m.Disj.
    * by map_tac_m.Equal.
    * reflexivity.
    * reflexivity.
    * Compose_sepcon (h1111 \U h1112) h112; last by assumption.
      Compose_sepcon h1111 h1112; first by Mapsto.
      Compose_sepcon h1112 heap.emp; [by Mapsto | done].
    * by apply hl_last.
  + rewrite /mapstos /=.
    Compose_sepcon h121' h2.
    rewrite /status in X2; by Mapsto.
    Compose_sepcon h2 heap.emp; [by Mapsto | done].
Qed.


From Perennial.base_logic.lib Require Import iprop own.
From iris.proofmode Require Import base tactics classes.
From iris.algebra Require Import auth dfrac gmap.
From Perennial.algebra Require Import auth_frac.
From iris.bi.lib Require Import fractional.
From iris.prelude Require Import options.

(* Monotone list. Almost exactly the "mlist" construction code by Hai Dang from the sra-gps proof of RCU,
   just generalized slightly to operate over arbitrary lists instead of RCU data *)

Section cmra_mlist.

  Context (A: Type) `{EqDecision A}.
  Implicit Types (D: list A).

  Inductive mlist :=
    | MList D : mlist
    | MListBot : mlist.

  Inductive mlist_equiv : Equiv mlist :=
    | MList_equiv D1 D2:
        D1 = D2 → MList D1 ≡ MList D2
    | MListBot_equiv : MListBot ≡ MListBot.

  Existing Instance mlist_equiv.
  Local Instance mlist_equiv_Equivalence : @Equivalence mlist equiv.
  Proof.
    split.
    - move => [|]; by constructor.
    - move => [?|] [?|]; inversion 1; subst; by constructor.
    - move => [?|] [?|] [?|];
      inversion 1; inversion 1; subst; by constructor.
  Qed.

  Canonical Structure mlistC : ofe := discreteO mlist.

  Local Instance mlist_valid : Valid mlist :=
    λ x, match x with MList _ => True | MListBot => False end.

  Local Instance mlist_op : Op mlist := λ x y,
    match x, y with
    | MList D1, MList D2 =>
        if (decide (D1 `prefix_of` D2))
        then MList D2
        else
          if (decide (D2 `prefix_of` D1))
          then MList D1
          else MListBot
    | _, _ => MListBot
    end.

  Local Arguments op _ _ !_ !_ /.

  Local Instance mlist_PCore : PCore mlist := Some.

  Local Instance anti_symm_prefix_of : AntiSymm eq (@prefix A).
  Proof.
    intros l1 l2 Hpre1 Hpre2.
    destruct Hpre1 as (D1'&Hpre1). destruct Hpre2 as (D2'&Hpre2).
    rewrite Hpre2 in Hpre1.
    apply (f_equal (length)) in Hpre1. rewrite ?app_length in Hpre1.
    destruct D2', D1'; simpl in Hpre1; try lia.
    by rewrite Hpre2 right_id.
  Qed.

  Global Instance mlist_op_comm: Comm equiv mlist_op.
  Proof.
    intros [D1|] [D2|]; auto. simpl.
    destruct (decide _) as [Hpre1|Hnpre]; last auto.
    destruct (decide _) as [Hpre2|Hnpre]; last auto.
    constructor.
    apply (anti_symm prefix); auto.
  Qed.

  Global Instance mlist_op_idemp : IdemP eq mlist_op.
  Proof. intros [|]; [by simpl; rewrite decide_True|auto]. Qed.

  Lemma mlist_op_l D1 D2 (Le: D1 `prefix_of` D2) :
    MList D1 ⋅ MList D2 = MList D2.
  Proof. simpl. case_decide; done. Qed.

  Lemma mlist_op_r D1 D2 (Le: D1 `prefix_of` D2) :
    MList D2 ⋅ MList D1 ≡ MList D2.
  Proof. by rewrite (comm (op: Op mlist)) mlist_op_l. Qed.

  Lemma prefix_of_down_total {X: Type} (l1 l2 l3: list X):
    l1 `prefix_of` l3 →
    l2 `prefix_of` l3 →
    (l1 `prefix_of` l2 ∨ l2 `prefix_of` l1).
  Proof.
    destruct 1 as (l1'&Heq1).
    destruct 1 as (l2'&Heq2).
    rewrite Heq2 in Heq1.
    apply app_eq_inv in Heq1 as [H2_is_prefix|H1_is_prefix].
    { left. destruct H2_is_prefix as (k&?&?). exists k. eauto. }
    { right. destruct H1_is_prefix as (k&?&?). exists k. eauto. }
  Qed.

  Global Instance mlist_op_assoc: Assoc equiv (op: Op mlist).
  Proof.
    intros [D1|] [D2|] [D3|]; eauto; simpl.
    - repeat (case_decide; auto).
      + rewrite !mlist_op_l; auto. etrans; eauto.
      + simpl. repeat case_decide; last done; exfalso.
        * feed pose proof (prefix_of_down_total D1 D2 D3); auto.
          intuition.
        * apply H1. by etrans.
      + rewrite mlist_op_l; [by rewrite mlist_op_r|auto].
      + rewrite !mlist_op_r; auto. by etrans.
      + simpl. rewrite !decide_False; auto.
      + simpl. rewrite !decide_False; auto.
      + simpl. case_decide.
        * exfalso. apply H. by etrans.
        * case_decide; last done. exfalso.
          feed pose proof (prefix_of_down_total D2 D3 D1); auto.
          intuition.
    - simpl. repeat case_decide; auto.
  Qed.

  Lemma mlist_included D1 D2 :
    MList D1 ≼ MList D2 ↔ D1 `prefix_of` D2.
  Proof.
    split.
    - move => [[?|]]; simpl; last inversion 1.
      case_decide; first by (inversion 1; subst).
      case_decide; inversion 1. by subst.
    - intros. exists (MList D2). by rewrite mlist_op_l.
  Qed.

  Lemma mlist_valid_op D1 D2 :
    ✓ (MList D1 ⋅ MList D2) → D1 `prefix_of` D2 ∨ D2 `prefix_of` D1.
  Proof. simpl. case_decide; first by left. case_decide; [by right|done]. Qed.

  Lemma mlist_core_self (X: mlist) : core X = X.
  Proof. done. Qed.

  Local Instance mlist_unit : Unit mlist := MList [].

  Definition mlist_ra_mixin : RAMixin mlist.
  Proof.
    apply ra_total_mixin; eauto.
    - intros [?|] [?|] [?|]; auto; inversion 1.
      subst. simpl. repeat case_decide; done.
    - by destruct 1; constructor.
    - by destruct 1.
    - apply mlist_op_assoc.
    - apply mlist_op_comm.
    - intros ?. by rewrite mlist_core_self idemp_L.
    - intros [|] [|]; simpl; done.
  Qed.

  Canonical Structure mlistR := discreteR mlist mlist_ra_mixin.

  Global Instance mlistR_cmra_discrete : CmraDiscrete mlistR.
  Proof. apply discrete_cmra_discrete. Qed.

  Definition mlist_ucmra_mixin : UcmraMixin mlist.
  Proof.
    split; [done| |auto]. intros [|]; [simpl|done].
    reflexivity.
  Qed.

  Canonical Structure mlistUR :=
    Ucmra mlist mlist_ucmra_mixin.

  Lemma mlist_local_update D1 X D2 :
    D1 `prefix_of` D2 → (MList D1, X) ~l~> (MList D2, MList D2).
  Proof.
    intros Le. rewrite local_update_discrete.
    move => [[D3|]|] /= ? Eq; split => //; last first; move : Eq.
    - destruct X; by inversion 1.
    - destruct X; rewrite /cmra_op /= => Eq;
      repeat case_decide; auto; inversion Eq; subst.
      + constructor. by apply: anti_symm.
      + by exfalso.
      + constructor. apply : anti_symm; [done|by etrans].
      + exfalso. apply H2. by etrans.
  Qed.

  Global Instance mlist_core_id (x : mlist) : CoreId x.
  Proof. by constructor. Qed.

End cmra_mlist.

Global Arguments MList {_} _.

Definition fmlistUR (A: Type) {Heq: EqDecision A} := authUR (mlistUR A).
Class fmlistG (A: Type) {Heq: EqDecision A} Σ :=
  { fmlist_inG :> inG Σ (fmlistUR A) }.
Definition fmlistΣ (A: Type) {Heq: EqDecision A} : gFunctors :=
  #[GFunctor (fmlistUR A)].

Global Instance subG_fmlistΣ (A: Type) {Heq: EqDecision A} {Σ} : subG (fmlistΣ A) Σ → (fmlistG A) Σ.
Proof. solve_inG. Qed.

Section fmlist_props.
Context `{fmlistG A Σ}.
Implicit Types l : list A.

Definition fmlist γ (dq : dfrac) l:= own γ (●{dq} (MList l)).
Definition fmlist_lb γ l := own γ (◯ (MList l)).
Definition fmlist_idx γ i a := (∃ l, ⌜ l !! i = Some a ⌝ ∗ fmlist_lb γ l)%I.

Local Instance inj_MList_equiv : Inj eq equiv (@MList A).
Proof. intros l1 l2. inversion 1. subst; eauto. Qed.

Lemma fmlist_agree_1 γ q1 q2 l1 l2:
  fmlist γ q1 l1 -∗ fmlist γ q2 l2 -∗ ⌜ l1 = l2 ⌝.
Proof.
  iIntros "Hγ1 Hγ2". iDestruct (own_valid_2 with "Hγ1 Hγ2") as %Hval.
  apply auth_auth_dfrac_op_inv in Hval.
  iPureIntro. apply (inj MList); auto.
Qed.

Lemma fmlist_agree_2 γ q1 l1 l2 :
  fmlist γ q1 l1 -∗ fmlist_lb γ l2 -∗ ⌜ l2 `prefix_of` l1 ⌝.
Proof.
  iIntros "Hγ1 Hγ2". iDestruct (own_valid_2 with "Hγ1 Hγ2") as %Hval.
  by apply @auth_both_dfrac_valid_discrete in Hval as (?&Hle%mlist_included&?); last apply _.
Qed.

Lemma fmlist_lb_agree γ l1 l2 :
  fmlist_lb γ l1 -∗ fmlist_lb γ l2 -∗ ⌜ l1 `prefix_of` l2 ∨ l2 `prefix_of` l1⌝.
Proof.
  iIntros "Hγ1 Hγ2". iDestruct (own_valid_2 with "Hγ1 Hγ2") as %Hval.
  revert Hval; rewrite -auth_frag_op auth_frag_valid => Hval.
  iPureIntro. by apply mlist_valid_op in Hval.
Qed.

Lemma fmlist_idx_agree_1 γ i a1 a2:
  fmlist_idx γ i a1 -∗ fmlist_idx γ i a2 -∗ ⌜ a1 = a2 ⌝.
Proof.
  iDestruct 1 as (l1 Hlookup1) "H1".
  iDestruct 1 as (l2 Hlookup2) "H2".
  iDestruct (fmlist_lb_agree with "H1 H2") as %Hprefix.
  iPureIntro.
  destruct Hprefix as [Hpre|Hpre]; eapply prefix_lookup in Hpre; eauto; congruence.
Qed.

Lemma fmlist_idx_agree_2 γ q l i a :
  fmlist γ q l -∗ fmlist_idx γ i a -∗ ⌜ l !! i = Some a ⌝.
Proof.
  iIntros "H1".
  iDestruct 1 as (l2 Hlookup2) "H2".
  iDestruct (fmlist_agree_2 with "H1 H2") as %Hpre.
  iPureIntro.
  eapply prefix_lookup in Hpre; eauto; congruence.
Qed.

Lemma fmlist_lb_mono γ l1 l2:
  l1 `prefix_of` l2 ->
  fmlist_lb γ l2 -∗ fmlist_lb γ l1.
Proof.
  iIntros (Hle) "Hlb".
  rewrite /fmlist_lb.
  iApply (own_mono with "Hlb").
  apply @auth_frag_mono.
  apply mlist_included; auto.
Qed.

Lemma fmlist_sep γ dq1 dq2 l:
  fmlist γ (dq1 ⋅ dq2) l ⊣⊢ fmlist γ dq1 l ∗ fmlist γ dq2 l.
Proof.
  iSplit.
  - iIntros "(Hm1&Hm2)". iFrame.
  - iIntros "(Hm1&Hm2)". iCombine "Hm1 Hm2" as "$".
Qed.

Lemma fmlist_to_lb γ dq l:
  fmlist γ dq l ==∗ fmlist_lb γ l.
Proof.
  iIntros "Hm".
  iMod (own_update _ _ ((●{dq} (MList l)) ⋅ ◯ (MList l)) with "Hm") as "(?&$)"; last done.
  { apply auth_frac_update_core_id; eauto. apply _. }
Qed.

Lemma fmlist_get_lb γ dq l:
  fmlist γ dq l ==∗ fmlist γ dq l ∗ fmlist_lb γ l.
Proof.
  iIntros "Hm".
  iMod (own_update _ _ ((●{dq} (MList l)) ⋅ ◯ (MList l)) with "Hm") as "(?&$)"; last done.
  { apply auth_frac_update_core_id; eauto. apply _. }
Qed.

Lemma fmlist_lb_to_idx γ l i a:
  l !! i = Some a →
  fmlist_lb γ l -∗ fmlist_idx γ i a.
Proof. iIntros (Hlookup) "H". iExists l. iFrame. eauto. Qed.

Lemma fmlist_update l' γ l:
  l `prefix_of` l' ->
  fmlist γ (DfracOwn 1) l ==∗ fmlist γ (DfracOwn 1) l' ∗ fmlist_lb γ l'.
Proof.
  iIntros (Hlt) "Hm".
  iMod (own_update with "Hm") as "($&?)"; last done.
  apply auth_update_alloc, mlist_local_update; auto.
Qed.

Lemma fmlist_freeze γ l q :
  fmlist γ (DfracOwn q) l ==∗ fmlist γ (DfracDiscarded) l.
Proof.
  iIntros "Hm".
  iMod (own_update with "Hm") as "$"; last done.
  apply auth_update_auth_persist.
Qed.

Lemma fmlist_alloc l :
  ⊢ |==> ∃ γ, fmlist γ (DfracOwn 1) l.
Proof.
  iStartProof.
  iMod (own_alloc (● (MList l))) as (γ) "H".
  { apply auth_auth_valid.
    cbv; auto. }
  iModIntro.
  iExists _; iFrame.
Qed.

Global Instance fmlist_lb_pers γ l: Persistent (fmlist_lb γ l).
Proof. rewrite /fmlist_lb. apply _. Qed.

Global Instance fmlist_lb_timeless γ l: Timeless (fmlist_lb γ l).
Proof. apply _. Qed.

Global Instance fmlist_idx_pers γ i a: Persistent (fmlist_idx γ i a).
Proof. apply _. Qed.

Global Instance fmlist_idx_timeless γ i a: Timeless (fmlist_idx γ i a).
Proof. apply _. Qed.

Global Instance fmlist_timeless γ q n: Timeless (fmlist γ q n).
Proof. apply _. Qed.

Global Instance fmlist_fractional γ n: Fractional (λ q, fmlist γ (DfracOwn q) n).
Proof. intros p q. rewrite -fmlist_sep //. Qed.

Global Instance fmlist_as_fractional γ q n :
  AsFractional (fmlist γ (DfracOwn q) n) (λ q, fmlist γ (DfracOwn q) n) q.
Proof. split; first by done. apply _. Qed.

Global Instance fmlist_into_sep γ n :
  IntoSep (fmlist γ (DfracOwn 1) n) (fmlist γ (DfracOwn (1/2)) n) (fmlist γ (DfracOwn (1/2)) n).
Proof. apply _. Qed.

Global Instance fmlist_discarded_pers γ l: Persistent (fmlist γ DfracDiscarded l).
Proof. apply _. Qed.

End fmlist_props.

Typeclasses Opaque fmlist fmlist_lb fmlist_idx.


Require Export VST.floyd.proofauto.
Require Export CertiGraph.lib.find_lemmas.
Require Export CertiGraph.priq.is_empty_lemmas.
Require Export CertiGraph.priq.priq_arr.

(* Specs for Anshuman's simple array-based PQ *)
Section PQSpec.

Context {size : Z}.
Context {inf : Z}.
Parameter free_tok : val -> Z -> mpred.
Context {Z_EqDec : EquivDec.EqDec Z eq}.

Definition weight_inrange_priq item :=
  Int.min_signed <= item <= inf.

Definition inrange_priq (priq : list Z) :=
  Forall (fun x => Int.min_signed <= x <= inf + 1) priq.

Definition mallocN_spec {CS: compspecs} :=
  DECLARE _mallocN
  WITH 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 (data_at_ Tsh (tarray tint (n / sizeof tint)) (pointer_val_val v) *
       free_tok (pointer_val_val v) n).

Definition freePQ_spec {CS: compspecs} :=
  DECLARE _freePQ
  WITH sh: share, p: pointer_val, n: Z, contents: list Z
    PRE [tptr tvoid]
    PROP ()
    PARAMS (pointer_val_val p)
    GLOBALS ()
    SEP (data_at sh (tarray tint n)
                 (map Vint (map Int.repr contents))
                 (pointer_val_val p) *
        free_tok (pointer_val_val p) (sizeof tint * n))
  POST [tvoid]
    PROP () LOCAL () SEP (emp).

Definition init_spec {CS: compspecs} :=
  DECLARE _init
  WITH _: unit (* how to take nothing? *)
  PRE [tint]
  PROP (Int.min_signed <= size * 4 <= Int.max_signed;
       0 < size)
  PARAMS (Vint (Int.repr size))
  GLOBALS ()
  SEP ()
  POST [tptr tint]
  EX pq: pointer_val,
  PROP ()
  LOCAL (temp ret_temp (pointer_val_val pq))
  SEP (data_at_ Tsh (tarray tint size) (pointer_val_val pq) *
      free_tok (pointer_val_val pq) (sizeof tint * size)).

Definition push_spec {CS: compspecs} :=
  DECLARE _push
  WITH pq: val, vertex : Z, weight : Z, priq_contents_val: list val
  PRE [tint, tint, tptr tint]
  PROP (0 <= vertex < size;
       (@weight_inrange_priq weight))
  PARAMS (Vint (Int.repr vertex);
          Vint (Int.repr weight);
          pq)
  GLOBALS ()
  SEP (data_at Tsh (tarray tint size) priq_contents_val pq)
  POST [tvoid]
  PROP ()
  LOCAL ()
  SEP (data_at Tsh (tarray tint size)
               (upd_Znth vertex
                         priq_contents_val (Vint (Int.repr weight))) pq).

Definition pq_emp_spec {CS: compspecs} :=
  DECLARE _pq_emp
  WITH pq: val, priq_contents: list Z
  PRE [tint, tint, tptr tint]
  PROP (@inrange_priq priq_contents;
       0 <= size <= Int.max_signed;
       0 <= inf;
       Int.min_signed < inf + 1 <= Int.max_signed)
   PARAMS (Vint (Int.repr size);
           Vint (Int.repr inf);
           pq)
   GLOBALS ()
   SEP (data_at Tsh (tarray tint size) (map Vint (map Int.repr priq_contents)) pq)
  POST [ tint ]
   PROP ()
   LOCAL (temp ret_temp (@isEmpty inf priq_contents))
   SEP (data_at Tsh (tarray tint size) (map Vint (map Int.repr priq_contents)) pq).

Definition adjustWeight_spec {CS: compspecs} :=
  DECLARE _adjustWeight
  WITH pq: val, vertex : Z, newWeight : Z, priq_contents: list Z
  PRE [tint, tint, tptr tint]
  PROP (0 <= vertex < size;
       @weight_inrange_priq newWeight)
  PARAMS (Vint (Int.repr vertex);
          Vint (Int.repr newWeight);
          pq)
  GLOBALS ()
  SEP (data_at Tsh (tarray tint size) (map Vint (map Int.repr priq_contents)) pq)
  POST [tvoid]
  PROP ()
  LOCAL ()
  SEP (data_at Tsh (tarray tint size)
               (upd_Znth vertex
                  (map Vint (map Int.repr priq_contents)) (Vint (Int.repr newWeight))) pq).

Definition popMin_spec {CS: compspecs} :=
  DECLARE _popMin
  WITH pq: val, priq_contents: list Z
  PRE [tint, tint, tptr tint]
   PROP (@inrange_priq priq_contents;
        @isEmpty inf priq_contents = Vzero;
        0 < size <= Int.max_signed;
        0 <= inf;
        Int.min_signed < inf + 1 <= Int.max_signed)
   PARAMS (Vint (Int.repr size);
           Vint (Int.repr inf);
           pq)
   GLOBALS ()
   SEP   (data_at Tsh (tarray tint size) (map Vint (map Int.repr priq_contents)) pq)
  POST [ tint ]
   EX rt : Z,
   PROP (rt = find priq_contents (fold_right Z.min (hd 0 priq_contents) priq_contents) 0)
   LOCAL (temp ret_temp  (Vint (Int.repr rt)))
   SEP   (data_at Tsh (tarray tint size) (upd_Znth
                                            (find priq_contents (fold_right Z.min (Znth 0 priq_contents) priq_contents) 0)
                                            (map Vint (map Int.repr priq_contents)) (Vint (Int.repr (inf+1)))) pq).

Definition Gprog {CS: compspecs}: funspecs :=
  ltac:(with_library prog
                     [mallocN_spec;
                     freePQ_spec;
                     init_spec;
                     push_spec;
                     pq_emp_spec;
                     adjustWeight_spec;
                     popMin_spec]).

End PQSpec.


Require Export Ascii String.

Require Import QArith.
Require Export DTimeQ.

Require Export MinBFT.
Require Export RunSM.

Require Export ComponentSM2.
Require Export ComponentSM4.

(* ================== MINBFT CONTEXT ================== *)

Definition minbft_digest : Set := list nat.

Definition minbft_digest_def : minbft_digest := [].

Lemma minbft_digest_deq : Deq minbft_digest.
Proof.
  introv; apply list_eq_dec.
  apply deq_nat.
Defined.

Inductive sending_key_stub : Set :=
| minbft_sending_key_stub.

Inductive receiving_key_stub : Set :=
| minbft_receiving_key_stub.

Definition minbft_sending_key   : Set := sending_key_stub.
Definition minbft_receiving_key : Set := receiving_key_stub.

(*Definition F : nat := 1.*)
Definition nreps (F : nat) : nat := 2 * F + 1.

Definition replica (F : nat) : Set := nat_n (nreps F).

Lemma replica_deq (F : nat) : Deq (replica F).
Proof.
  apply nat_n_deq.
Defined.

Definition reps2nat (F : nat) : replica F -> nat_n (nreps F) := fun n => n.

Lemma bijective_reps2nat (F : nat) : bijective (reps2nat F).
Proof.
  exists (fun n : nat_n (nreps F) => n); introv; unfold reps2nat; auto.
Defined.

Definition replica0 (F : nat) : replica F.
Proof.
  exists 0.
  apply leb_correct.
  unfold nreps.
  omega.
Defined.

Definition replica1 : replica 1.
Proof.
  exists 1.
  apply leb_correct.
  unfold nreps.
  omega.
Defined.

Definition replica2 : replica 1.
Proof.
  exists 2.
  apply leb_correct.
  unfold nreps.
  omega.
Defined.

Definition nclients (C : nat) : nat := S C.

Definition client (C : nat) : Set := nat_n (nclients C).

Definition client0 (C : nat) : client C.
Proof.
  exists 0.
  apply leb_correct.
  unfold nclients.
  omega.
Defined.

Lemma client_deq (C : nat) : Deq (client C).
Proof.
  apply nat_n_deq.
Defined.

Definition clients2nat (C : nat) : client C -> nat_n (nclients C) := fun n => n.

Lemma bijective_clients2nat (C : nat) : bijective (clients2nat C).
Proof.
  exists (fun n : nat_n (nclients C) => n); introv; unfold clients2nat; auto.
Defined.

Inductive minbft_data_message :=
| minbft_data_message_plus (n : nat)
| minbft_data_message_minus (n : nat).

Lemma minbft_data_message_deq : Deq minbft_data_message.
Proof.
  introv; destruct x as [x|x], y as [y|y];
    destruct (deq_nat x y); prove_dec.
Defined.

Definition minbft_result := nat.

Lemma minbft_result_deq : Deq minbft_result.
Proof.
  introv; apply deq_nat.
Defined.

Definition minbft_sm_state := nat.

Definition minbft_sm_initial_state : minbft_sm_state := 0.

Definition minbft_sm_update
           (C : nat)
           (c : client C)
           (s : minbft_sm_state)
           (m : minbft_data_message) : minbft_result * minbft_sm_state :=
  match m with
  | minbft_data_message_plus  n => let x := s + n in (x,x)
  | minbft_data_message_minus n => let x := s - n in (x,x)
  end.

Definition F := 1.
Definition C := 0.

Global Instance MinBFT_I_context : MinBFT_context :=
  Build_MinBFT_context
    minbft_digest
    minbft_digest_deq
    minbft_sending_key
    minbft_receiving_key
    F
    (replica F)
    (replica_deq F)
    (reps2nat F)
    (bijective_reps2nat F)
    (nclients C)
    (client C)
    (client_deq C)
    (clients2nat C)
    (bijective_clients2nat C)
    minbft_data_message
    minbft_data_message_deq
    minbft_result
    minbft_result_deq
    minbft_sm_state
    minbft_sm_initial_state
    (minbft_sm_update C).

(* =========================== *)
(* ====== GENERIC STUFF ====== *)

(* Replace during extraction *)
Inductive ref_stub (T : Type) :=
| ref_stub_cons (t : T).
Global Arguments ref_stub_cons [T] _.

(* Replace during extraction *)
Definition ref_stub_get {T : Type} (t : ref_stub T) : T :=
  match t with
  | ref_stub_cons t => t
  end.

(* Replace during extraction *)
Definition ref_stub_update {T : Type} (r : ref_stub T) (t : T) : unit := tt.

Definition lookup_table : ref_stub (list {cn : CompName & {n : nat & cio_I (fio cn) -> (unit * cio_O (fio cn))}}) :=
  ref_stub_cons [].

Definition update_lookup (level : nat) (name : CompName) (sm : cio_I (fio name) -> (unit * cio_O (fio name))) :=
  ref_stub_update
    lookup_table
    ((existT _ name (existT _ level sm)) :: ref_stub_get lookup_table).

Module Type SM.
  Parameter level : nat.
  Parameter name  : CompName.
  Parameter sm    : n_proc level name.
End SM.

Module Type SMat.
  Parameter level : nat.
  Parameter name  : CompName.
  Parameter sm    : n_proc_at level name.
End SMat.

Module Msm (sm : SM).
  Definition state : ref_stub (sf sm.name) := ref_stub_cons (sm2state sm.sm).

  Definition update (i : cio_I (fio sm.name)) : unit * cio_O (fio sm.name) :=
    let (sop,o) := M_break_nil (sm2update sm.sm (ref_stub_get state) i) in
    let u := match sop with | Some s => ref_stub_update state s| None => tt end in
    (u,o).

  Fixpoint run (l : list (cio_I (fio sm.name))) : list (cio_O (fio sm.name)) :=
    match l with
    | [] => []
    | i :: rest => snd (update i) :: run rest
    end.

  Definition upd_lkup := update_lookup sm.level sm.name update.
End Msm.

Module Msmat (sm : SMat).
  Definition state : ref_stub (sf sm.name) := ref_stub_cons (ComponentSM.sm_state sm.sm).

  Definition update (i : cio_I (fio sm.name)) : unit * cio_O (fio sm.name) :=
    let (sop,o) := M_break_nil (sm_update sm.sm (ref_stub_get state) i) in
    let u := match sop with | Some s => ref_stub_update state s | None => tt end in
    (u,o).

  Fixpoint run (l : list (cio_I (fio sm.name))) : list (cio_O (fio sm.name)) :=
    match l with
    | [] => []
    | i :: rest => snd (update i) :: run rest
    end.

  Definition upd_lkup := update_lookup sm.level sm.name update.
End Msmat.

(* =========================== *)

(* ================== SIGNATURE ================== *)

Definition minbft_create_signature
           (m  : MinBFT_Bare_Msg)
           (ks : sending_keys) : list MinBFT_digest := [minbft_digest_def].

Definition minbft_verify_signature
           (m : MinBFT_Bare_Msg)
           (n : name)
           (k : receiving_key)
           (a : MinBFT_digest) : bool := true.

Global Instance MinBFT_I_auth : MinBFT_auth :=
  MkMinBFT_auth minbft_create_signature minbft_verify_signature.

Definition minbft_lookup_replica_sending_key   (src : Rep)    : minbft_sending_key   := minbft_sending_key_stub.
Definition minbft_lookup_replica_receiving_key (dst : Rep)    : minbft_receiving_key := minbft_receiving_key_stub.
Definition minbft_lookup_client_sending_key    (c   : Client) : minbft_sending_key   := minbft_sending_key_stub.
Definition minbft_lookup_client_receiving_key  (c   : Client) : minbft_receiving_key := minbft_receiving_key_stub.

Definition initial_minbft_local_key_map_replicas (src : name) : local_key_map :=
  match src with
  | MinBFT_replica i =>
    MkLocalKeyMap
      (map (fun c => MkDSKey [MinBFT_client c] (minbft_lookup_client_sending_key c)) clients)
      (map (fun c => MkDRKey [MinBFT_client c] (minbft_lookup_client_receiving_key c)) clients)
  | MinBFT_client _ => MkLocalKeyMap [] []
  end.

Global Instance MinBFT_I_keys : MinBFT_initial_keys :=
  MkMinBFT_initial_keys initial_minbft_local_key_map_replicas.

(* ================== USIG HASH ================== *)

Definition minbft_create_hash_usig
           (hd : HashData)
           (lk : local_key_map) : MinBFT_digest := [].

Definition minbft_verify_hash_usig
           (hd : HashData)
           (d  : MinBFT_digest)
           (lk : local_key_map) : bool := true.

Lemma minbft_verify_create_hash_usig :
  forall (hd : HashData) (keys : local_key_map),
    minbft_verify_hash_usig hd (minbft_create_hash_usig hd keys) keys = true.
Proof.
  tcsp.
Qed.

Global Instance MinBFT_I_usig_hash : USIG_hash :=
  MkMinBFThash
    minbft_create_hash_usig
    minbft_verify_hash_usig
    minbft_verify_create_hash_usig.

(* ================== TIME ================== *)

Definition time_I_type : Set := unit.

Definition time_I_get_time : unit -> time_I_type := fun _ => tt.

Definition time_I_sub : time_I_type -> time_I_type -> time_I_type := fun _ _ => tt.

Definition time_I_2string : time_I_type -> string := fun _ => "".

Global Instance TIME_I : Time.
Proof.
  exists time_I_type.
  { exact time_I_get_time. }
  { exact time_I_sub. }
  { exact time_I_2string. }
Defined.

(* ================== PRETTY PRINTING ================== *)

(* Fix: to finish *)
Definition tokens2string (toks : Tokens) : string := "-".

(* Fix: to finish *)
Definition minbft_digest2string (d : minbft_digest) : string := "-".

(* Fix: to finish *)
Definition minbft_result2string (r : minbft_result) : string := nat2string r.

(* Fix: there's only one client anyway *)
Definition client2string (c : client C) : string := "-".

Definition timestamp2string (ts : Timestamp) : string :=
  match ts with
  | time_stamp n => nat2string n
  end.

Definition view2string (v : View) : string :=
  match v with
  | view n => nat2string n
  end.

Definition seq2string (s : SeqNum) : string :=
  match s with
  | seq_num n => nat2string n
  end.

Definition minbft_data_message2string (opr : minbft_data_message) : string :=
  match opr with
  | minbft_data_message_plus  n => str_concat ["+", nat2string n]
  | minbft_data_message_minus n => str_concat ["-", nat2string n]
  end.

Definition nat_n2string {m} (n : nat_n m) : string := nat2string (proj1_sig n).

Definition replica2string (r : replica F) : string := nat_n2string r.

Definition bare_request2string (br : Bare_Request) : string :=
  match br with
  | bare_request c ts m =>
    str_concat [client2string c,
                ",",
                timestamp2string ts,
                ",",
                minbft_data_message2string m]
  end.

Definition request2string (r : Request) : string :=
  match r with
  | request br a => str_concat ["REQUEST(", bare_request2string br, ",", tokens2string a, ")"]
  end.

Definition bare_prepare2string (bp : Bare_Prepare) : string :=
  match bp with
  | bare_prepare v m =>
    str_concat [view2string v,
                ",",
                request2string m]
  end.

Definition pre_ui2string (pui : preUI) : string :=
  match pui with
  | Build_preUI id counter =>
    str_concat [replica2string id,
                ",",
                nat2string counter]
  end.

Definition ui2string (ui : UI) : string :=
  match ui with
  | Build_UI pui d =>
    str_concat [pre_ui2string pui,
                ",",
                minbft_digest2string d]
  end.

Definition bare_commit2string (bc : Bare_Commit) : string :=
  match bc with
  | bare_commit v m ui =>
    str_concat [view2string v,
                ",",
                request2string m,
                ",",
                ui2string ui]
  end.

Definition prepare2string (p : Prepare) : string :=
  match p with
  | prepare bp a => str_concat ["PREPARE(", bare_prepare2string bp, ",", ui2string a, ")"]
  end.

Definition commit2string (c : Commit) : string :=
  match c with
  | commit bc a => str_concat ["COMMIT(", bare_commit2string bc, ",", ui2string a, ")"]
  end.

Definition accept2string (r : Accept) : string :=
  match r with
  | accept r c => str_concat ["ACCEPT(", request2string r, ",", nat2string c, ")"]
  end.

Definition bare_reply2string (br : Bare_Reply) : string :=
  match br with
  | bare_reply req res i v => str_concat [request2string req, ",", nat2string res, ",", replica2string i, ",", view2string v]
  end.

Definition reply2string (r : Reply) : string :=
  match r with
  | reply br a => str_concat ["REPLY(", bare_reply2string br, ",", tokens2string a, ")"]
  end.

Definition msg2string (m : MinBFT_msg) : string :=
  match m with
  | MinBFT_request r => request2string r
  | MinBFT_reply r   => reply2string r
  | MinBFT_prepare p => prepare2string p
  | MinBFT_commit  c => commit2string  c
  | MinBFT_accept  a => accept2string  a
  | MinBFT_debug   s => s
  end.

Definition name2string (n : name) : string :=
  match n with
  | MinBFT_replica r => replica2string r
  | MinBFT_client c => client2string c
  end.

Fixpoint names2string (l : list name) : string :=
  match l with
  | [] => ""
  | [n] => name2string n
  | n :: ns => str_concat [name2string n, ",", names2string ns]
  end.

Definition delay2string (delay : nat) : string := nat2string delay.

Definition z2string (z : Z) : string := "".
Definition pos2string (p : positive) : string := "".

Definition q2string (q : Q) : string :=
  str_concat ["(" ,
              z2string (Qnum q),
              "/",
              pos2string (Qden q),
              ")"].

Definition posdtime2string (p : PosDTime) : string :=
  q2string (pos_dt_t p).

Definition DirectedMsg2string (dm : DirectedMsg) : string :=
  match dm with
  | MkDMsg msg dst delay =>
    str_concat [msg2string msg, ":", "[", names2string dst, "]", ":", posdtime2string delay]
  end.

Fixpoint DirectedMsgs2string (l : DirectedMsgs) : string :=
  match l with
  | [] => ""
  | [dm] => DirectedMsg2string dm
  | dm :: dmsgs => str_concat [DirectedMsg2string dm, CR, DirectedMsgs2string dmsgs]
  end.

Definition TimedDirectedMsg2string (m : TimedDirectedMsg) : string :=
  match m with
  | MkTimedDMsg dm time => str_concat [DirectedMsg2string dm, ":", time_I_2string time]
  end.

Fixpoint TimedDirectedMsgs2string (l : TimedDirectedMsgs) : string :=
  match l with
  | [] => ""
  | [dm] => TimedDirectedMsg2string dm
  | dm :: dmsgs => str_concat [TimedDirectedMsg2string dm, CR, TimedDirectedMsgs2string dmsgs]
  end.

Definition SimState2string (s : SimState) : string :=
  match s with
  | MkSimState fls sys step out_inflight in_inflight delivered =>
    str_concat
      [CR,
       "====== STEP ======",
       CR,
       nat2string step,
       CR,
       "====== IN FLIGHT (from outside the system) ======",
       CR,
       DirectedMsgs2string out_inflight,
       CR,
       "====== IN FLIGHT (from inside the system) ======",
       CR,
       DirectedMsgs2string in_inflight,
       CR,
       "====== DELIVERED ======",
       CR,
       TimedDirectedMsgs2string delivered,
       CR]
  end.

  (* ================== SYSTEM ================== *)

  (* FIX: do we need this one? *)
  Definition dummy_usig_initial_state : USIG_state :=
    Build_USIG
      replica1
      0
      (MkLocalKeyMap [] []).

  (* do we need this one? *)
  Definition dummy_log_initial_state : LOG_state := [].

  (* do we need this one? *)
  Definition dummy_initial_state : MAIN_state :=
    Build_State
      (MkLocalKeyMap [] [])
      initial_view
      MinBFT_sm_initial_state
      initial_latest_executed_counter
      initial_latest_executed_request
      initial_highest_received_counter_value
      None.

  Definition dummy_LocalSystem : MLocalSystem 0 1 :=
    MkLocalSystem
      (MP_haltedSM munit_comp_name 0 tt)
      [].

  Definition MinBFT_instance_sys : M_USystem MinBFTfunLevelSpace :=
    fun name =>
      match name with
      | MinBFT_replica n => MinBFTlocalSys n
      | _ =>  MkLocalSystem (MP_haltedSM munit_comp_name 0 tt) []
      end.

(* ================== STATE ================== *)

Definition mk_request
           (c  : Client)
           (ts : Timestamp)
           (m  : MinBFT_data_message) : msg :=
  MinBFT_request (request (bare_request c ts m) [minbft_digest_def]).

Definition send_request
           (c  : Client)
           (ts : Timestamp)
           (m  : MinBFT_data_message) :=
  MkDMsg
    (mk_request c ts m)
    [MinBFT_replica (MinBFTprimary (view 0))]
    ('0).

Definition minbft_init_sim_state : SimState :=
  let c  := client0 C in
  let ts := time_stamp 0 in
  let m  := minbft_data_message_plus 17 in
  MkInitSimState
    MinBFTsys
    [send_request c ts m].

Definition minbft_sim_state1 : SimState :=
  run_n_steps [0,0] minbft_init_sim_state.

Eval compute in (let p0  := replica0 F in
                 let km  := initial_minbft_local_key_map_replicas (MinBFT_replica p0) in
                 let c   := client0 C in
                 let ts  := time_stamp 0 in
                 let m   := minbft_data_message_plus 17 in
                 let r   := request (bare_request c ts m) [minbft_digest_def] in
                 let s   := initial_state p0 in
                 valid_request p0 km r s).

Eval compute in (let v   := view 0 in
                 let p0  := replica0 F in
                 let p1  := replica1 in
                 let km  := initial_minbft_local_key_map_replicas (MinBFT_replica p1) in
                 let c   := client0 C in
                 let ts  := time_stamp 0 in
                 let m   := minbft_data_message_plus 17 in
                 let r   := request (bare_request c ts m) [minbft_digest_def] in
                 let ui  := snd (create_UI v r (USIG_initial p0)) in
                 let p   := prepare (bare_prepare v r) ui in
                 let s   := initial_state p1 in
                 valid_prepare p1 km v p s).

(* ================== EXTRACTION ================== *)

Extraction Language Ocaml.

(* printing stuff *)
Extract Inlined Constant print_endline => "Prelude.print_coq_endline".
Extract Inlined Constant nat2string    => "Prelude.char_list_of_int".
Extract Inlined Constant CR            => "['\n']".

(* numbers *)
Extract Inlined Constant Nat.modulo    => "(mod)".

(* lists *)
Extract Inlined Constant forallb => "List.for_all".
Extract Inlined Constant existsb => "List.exists".
Extract Inlined Constant length  => "List.length".
Extract Inlined Constant app     => "List.append".
Extract Inlined Constant map     => "List.map".
Extract Inlined Constant filter  => "List.filter".

(* timing stuff *)
Extract Inlined Constant time_I_type     => "float".
Extract Inlined Constant time_I_get_time => "Prelude.Time.get_time".
Extract Inlined Constant time_I_sub      => "Prelude.Time.sub_time".
Extract Inlined Constant time_I_2string  => "Prelude.Time.time2string".

Require Export ExtrOcamlBasic.
Require Export ExtrOcamlNatInt.
Require Export ExtrOcamlString.

(* do we still need this one?
Definition MinBFT_sim_state_pp : unit :=
  print_endline (SimState2string minbft_sim_state1).

Extraction "MinBFTtest.ml" MinBFT_sim_state_pp.
*)

Definition local_system:=
  @MinBFTlocalSys.

(* ================== MODULES ================== *)

Parameter self : Rep.

(* ====== USIG ====== *)

Module SMUSIG <: SM.
  Definition level := 1.
  Definition name  := USIGname.
  Definition sm    := USIG_comp self.
End SMUSIG.

Module MUSIG := Msm (SMUSIG).

(* ====== LOG ====== *)

Module SMLOG <: SM.
  Definition level := 1.
  Definition name  := LOGname.
  Definition sm    := LOG_comp.
End SMLOG.

Module MLOG := Msm (SMLOG).

(* ====== Main ====== *)

Module SMMAIN <: SMat.
  Definition level := 1.
  Definition name  := MAINname.
  Definition sm    := MAIN_comp self.
End SMMAIN.

Module MMAIN := Msmat (SMMAIN).

Definition mtest : unit :=
  let c  := client0 C in
  let ts := time_stamp 0 in
  let m  := minbft_data_message_plus 17 in
  print_endline (DirectedMsgs2string (snd (MMAIN.update (mk_request c ts m)))).

(* =========================== *)
(* =========================== *)

Extract Inductive ref_stub => "ref" ["ref"].
Extract Inlined Constant ref_stub_get => "!".
Extract Inlined Constant ref_stub_update => "(:=)".

Extract Inductive sigT => "(*)" [""].

Extract Inductive Proc => "Prelude.SM.id" ["Prelude.SM.ret"
                                             "Prelude.SM.bind"
                                             "Prelude.SM.call_proc lookup_table"].
(*Extract Inductive MP_StateMachine => "MP_SM" ["Prelude.SM.mk_sm"].*)

(*Extract Constant MP_SM "'p" => "n_proc".*)
Extract Constant n_proc => "unit mP_StateMachine".
Extract Constant M_n "'a" => "'a".
Extract Constant M_p "'a" "'b" => "'b".
Extract Constant UProc "'s" => "'s -> cio_I -> ('s * cio_O) m_n".

Extract Constant bind => "fun _ _ _ _ _ _ _ _ _ m f -> Prelude.SM.bind (m,f)".
Extract Constant ret => "fun _ _ _ _ _ _ _ _ _ a -> Prelude.SM.ret a".
Extract Constant M_on_pred => "fun _ _ _ _ _ _ _ _ _ x -> x".
Extract Constant M_simple_break => "fun _ _ _ _ _ _ _ _ _ sm subs f -> f sm".
Extract Constant M_break_nil => "fun _ _ _ _ _ _ _ _ _ sm -> sm".

Extraction Inline interp_s_proc.
Extraction Inline proc_bind_pair.
Extraction Inline to_proc_some_state.

Extract Inlined Constant interp_proc => "(fun _ _ _ _ _ _ _ _ _ x -> x)".
(*Extract Inlined Constant interp_s_proc => "".
Extract Inlined Constant incr_n_proc => "".
Extract Inlined Constant incr_n_nproc => "".
Extract Inlined Constant incr_n_procs => "".
Extract Inlined Constant incr_pred_n_proc => "".
Extract Inlined Constant incr_pred_n_nproc => "".
Extract Inlined Constant incr_pred_n_procs => "".*)

Extract Inlined Constant M_StateMachine => "n_proc".
Extract Inlined Constant n_proc_at => "n_proc".
Extract Inlined Constant n_procs => "((unit mP_StateMachine) p_nproc) list".
(*Extract Inlined Constant sm_halted => "Prelude.SM.sm_halted".
Extract Inlined Constant sm_update => "Prelude.SM.sm_update".
Extract Inlined Constant sm_state => "Prelude.SM.sm_state".*)

(*Extraction Implicit lift_M_O [1].*)

(*Extract Constant M_Update "'a" => "'a -> cio_I -> option 'a * cio_O".*)
(*Extract Constant n_nproc => "unit MP_StateMachine".*)
(*Extract Constant n_proc_at => "unit MP_StateMachine".*)

Extraction "MinbftReplica.ml" lookup_table MUSIG MLOG MMAIN mtest.

(*
Then:
    (1) Move [lookup_table] to just above its first use (I'll fix that later)
    (2) change the definition of self into [Obj.magic 0]
    (3) Compile using: ocamlbuild -tag thread -use-ocamlfind -package ppx_jane,async,core_extended,batteries,rpc_parallel,nocrypto.unix MinbftReplica.native
*)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU Lesser General Public License for more details.                *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************
    Proof of Huffman algorithm: Weight.v

                                    Laurent.Thery@inria.fr (2003)
 **********************************************************************)

From Huffman Require Export Code.
From Huffman Require Export Frequency.
From Huffman Require Export ISort.
From Huffman Require Export Permutation.
From Huffman Require Export UniqueKey.

Section Weight.
Variable A : Type.
Variable eqA_dec : forall a b : A, {a = b} + {a <> b}.

Theorem fold_plus_split :
 forall (B : Type) (l : list B) (c : nat) (f : B -> nat),
 c + fold_left (fun (a : nat) (b : B) => a + f b) l 0 =
 fold_left (fun (a : nat) (b : B) => a + f b) l c.
Proof using.
intros B l; elim l; simpl in |- *; auto.
intros a l0 H c f.
rewrite <- (H (f a)).
rewrite <- (H (c + f a)).
rewrite plus_assoc_reverse; auto.
Qed.

Theorem fold_plus_permutation :
 forall (B : Type) (l1 l2 : list B) (c : nat) (f : B -> nat),
 permutation l1 l2 ->
 fold_left (fun (a : nat) (b : B) => a + f b) l1 c =
 fold_left (fun (a : nat) (b : B) => a + f b) l2 c.
Proof using.
intros B l1 l2 c f H; generalize c f; elim H; clear H l1 l2 c f;
 simpl in |- *; auto.
intros a b L c f; repeat rewrite <- plus_assoc; rewrite (plus_comm (f a));
 auto.
intros L1 L2 L3 H H0 H1 H2 c f; apply trans_equal with (1 := H0 c f); auto.
Qed.

Theorem length_encode_nId :
 forall a l1 l n,
 length (encode eqA_dec ((a, l1) :: l) (id_list a n)) = n * length l1.
Proof using.
intros a l1 l n; elim n; simpl in |- *; auto.
intros n0 H; case (eqA_dec a a); auto.
intros e; rewrite length_app; rewrite H; auto.
intros H1; case H1; auto.
Qed.

Theorem frequency_length :
 forall (m : list A) (c : code A),
 unique_key c ->
 length (encode eqA_dec c m) =
 fold_left
   (fun a b => a + number_of_occurrences eqA_dec (fst b) m * length (snd b))
   c 0.
Proof using.
intros m c; generalize m; elim c; clear c m; simpl in |- *; auto.
intros m; elim m; simpl in |- *; auto.
intros (a, l1) l Rec m H; simpl in |- *.
case (number_of_occurrences_permutation_ex A eqA_dec m a);
 intros m1 (Hm1, Hm2).
rewrite
 permutation_length
                    with
                    (1 :=
                      encode_permutation_val _ eqA_dec _ _ ((a, l1) :: l) Hm1).
rewrite encode_app; auto.
rewrite length_app; auto.
rewrite length_encode_nId.
rewrite encode_cons_inv; auto.
rewrite Rec; simpl in |- *; auto.
rewrite <-
 fold_plus_split
                 with
                 (f :=
                   fun b : A * list bool =>
                   number_of_occurrences eqA_dec (fst b) m * length (snd b))
                (c := number_of_occurrences eqA_dec a m * length l1).
apply f_equal2 with (f := plus); auto.
cut (forall l2, ~ In (a, l2) l).
elim l; simpl in |- *; auto.
intros (a2, l2) l3; simpl in |- *; intros Rec1 H4.
rewrite <-
 fold_plus_split
                 with
                 (c := number_of_occurrences eqA_dec a2 m1 * length l2)
                (f :=
                  fun b : A * list bool =>
                  number_of_occurrences eqA_dec (fst b) m1 * length (snd b)).
rewrite <-
 fold_plus_split
                 with
                 (c := number_of_occurrences eqA_dec a2 m * length l2)
                (f :=
                  fun b : A * list bool =>
                  number_of_occurrences eqA_dec (fst b) m * length (snd b)).
apply f_equal2 with (f := plus); auto.
2: apply Rec1; auto.
2: intros l0; red in |- *; intros H0; case (H4 l0); auto.
2: intros l2; red in |- *; intros H0;
    case unique_key_in with (1 := H) (a := a) (b2 := l2);
    auto.
2: apply unique_key_inv with (1 := H); auto.
apply f_equal2 with (f := mult); auto.
apply
 trans_equal
  with
    (2 := number_of_occurrences_permutation _ eqA_dec _ _ a2
            (permutation_sym _ _ _ Hm1)).
rewrite number_of_occurrences_app.
replace
 (number_of_occurrences eqA_dec a2
    (id_list a (number_of_occurrences eqA_dec a m))) with 0;
 auto.
cut (a2 <> a).
elim (number_of_occurrences eqA_dec a m); simpl in |- *; auto.
intros n H0 H1; case (eqA_dec a2 a); simpl in |- *; auto.
intros e; case H1; auto.
red in |- *; intros H0; case (H4 l2); left;
 apply f_equal2 with (f := pair (A:=A) (B:=list bool));
 auto.
Qed.

Definition weight m c := length (encode eqA_dec c m).

Theorem weight_permutation :
 forall m c1 c2,
 unique_prefix c1 -> permutation c1 c2 -> weight m c1 = weight m c2.
Proof using.
intros m c1 c2 H H0; unfold weight in |- *.
apply f_equal with (f := length (A:=bool)).
apply encode_permutation; auto.
Qed.

Definition restrict_code (m : list A) (c : code A) :
  code A :=
  map (fun x => (fst x, find_code eqA_dec (fst x) c))
    (frequency_list eqA_dec m).

Theorem ulist_unique_key :
 forall (A B : Type) (l : list (A * B)),
 ulist (map (fst (B:=_)) l) -> unique_key l.
Proof using.
intros AA BB l; elim l; simpl in |- *; auto.
intros a; case a.
intros a0 b l0 H H0; apply unique_key_cons; auto.
intros b0; red in |- *; intros H1; absurd (In a0 (map (fst (B:=_)) l0)); auto.
inversion H0; auto.
change (In (fst (a0, b0)) (map (fst (B:=_)) l0)) in |- *; auto with datatypes.
apply in_map; auto.
apply H; apply ulist_inv with (1 := H0); auto.
Qed.

Theorem restrict_code_unique_key :
 forall (m : list A) (c : code A), unique_key (restrict_code m c).
Proof using.
intros m c; apply ulist_unique_key.
unfold restrict_code in |- *.
replace
 (map (fst (B:=_))
    (map (fun x : A * nat => (fst x, find_code eqA_dec (fst x) c))
       (frequency_list eqA_dec m))) with
 (map (fst (B:=_)) (frequency_list eqA_dec m)).
apply unique_key_ulist; auto.
elim (frequency_list eqA_dec m); simpl in |- *; auto with datatypes.
intros a l H; apply f_equal2 with (f := cons (A:=A)); auto.
Qed.

Theorem restrict_code_in :
 forall (m : list A) (a : A) (c : code A),
 In a m -> find_code eqA_dec a c = find_code eqA_dec a (restrict_code m c).
Proof using.
intros m a c H.
apply sym_equal; apply find_code_correct2; auto.
apply restrict_code_unique_key.
generalize (in_frequency_map _ eqA_dec m a H).
unfold restrict_code in |- *; elim (frequency_list eqA_dec m); simpl in |- *;
 auto with datatypes.
intros a0; case a0; simpl in |- *; auto with datatypes.
intros a1 n l H0 [H1| H1]; try rewrite H1; auto.
Qed.

Theorem restrict_code_encode_length_inc :
 forall (m m1 : list A) (c : code A),
 incl m1 m -> encode eqA_dec c m1 = encode eqA_dec (restrict_code m c) m1.
Proof using.
intros m m1 c; elim m1; simpl in |- *; auto.
intros a l H H0.
apply f_equal2 with (f := app (A:=bool)); auto with datatypes.
apply restrict_code_in; auto with datatypes.
apply H; apply incl_tran with (2 := H0); auto with datatypes.
Qed.

Theorem restrict_code_encode_length :
 forall (m : list A) (c : code A),
 encode eqA_dec c m = encode eqA_dec (restrict_code m c) m.
Proof using.
intros m c; apply restrict_code_encode_length_inc; auto with datatypes.
Qed.

End Weight.
Arguments weight [A].
Arguments restrict_code [A].


(* * Syntax and semantics of the Jasmin source language *)

(* ** Imports and settings *)
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp Require Import word_ssrZ.
Require Import Psatz xseq.
Require Export array type expr gen_map low_memory warray_ sem_type sem_op_typed values.
Require Export
  flag_combination
  sem_params.
Import Utf8.

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

(* ** Variable map
 * -------------------------------------------------------------------- *)

Notation vmap     := (Fv.t (fun t => exec (sem_t t))).

Definition undef_addr t :=
  match t return exec (sem_t t) with
  | sbool | sint | sword _ => undef_error
  | sarr n => ok (WArray.empty n)
  end.

Definition vmap0 : vmap :=
  @Fv.empty (fun t => exec (sem_t t)) (fun x => undef_addr x.(vtype)).

Definition on_vu t r (fv: t -> r) (fu:exec r) (v:exec t) : exec r :=
  match v with
  | Ok v => ok (fv v)
  | Error ErrAddrUndef => fu
  | Error e            => Error e
  end.

Lemma on_vuP T R (fv: T -> R) (fu: exec R) (v:exec T) r P:
  (forall t, v = ok t -> fv t = r -> P) ->
  (v = undef_error -> fu = ok r -> P) ->
  on_vu fv fu v = ok r -> P.
Proof. by case: v => [a | []] Hfv Hfu //=;[case; apply: Hfv | apply Hfu]. Qed.

(* An access to a undefined value, leads to an error *)
Definition get_var (m:vmap) x :=
  on_vu (@to_val (vtype x)) undef_error (m.[x]%vmap).

(* Assigning undefined value is allowed only for bool *)
Definition set_var (m:vmap) x v : exec vmap :=
  on_vu (fun v => m.[x<-ok v]%vmap)
        (if is_sbool x.(vtype) then ok m.[x<-undef_addr x.(vtype)]%vmap
         else type_error)
        (of_val (vtype x) v).

Lemma set_varP (m m':vmap) x v P :
   (forall t, of_val (vtype x) v = ok t -> m.[x <- ok t]%vmap = m' -> P) ->
   ( is_sbool x.(vtype) -> of_val (vtype x) v = undef_error ->
     m.[x<-undef_addr x.(vtype)]%vmap = m' -> P) ->
   set_var m x v = ok m' -> P.
Proof.
  move=> H1 H2;apply on_vuP => //.
  by case:ifPn => // hb herr []; apply : H2.
Qed.

(* ** Parameter expressions
 * -------------------------------------------------------------------- *)

Definition sem_sop1 (o: sop1) (v: value) : exec value :=
  let t := type_of_op1 o in
  Let x := of_val _ v in
  ok (to_val (sem_sop1_typed o x)).

Lemma sem_sop1I y x f:
  sem_sop1 f x = ok y →
  exists2 w : sem_t (type_of_op1 f).1,
    of_val _ x = ok w &
    y = to_val (sem_sop1_typed f w).
Proof. by rewrite /sem_sop1; t_xrbindP => w ok_w <-; eauto. Qed.

Definition sem_sop2 (o: sop2) (v1 v2: value) : exec value :=
  let t := type_of_op2 o in
  Let x1 := of_val _ v1 in
  Let x2 := of_val _ v2 in
  Let r  := sem_sop2_typed o x1 x2 in
  ok (to_val r).

Lemma sem_sop2I v v1 v2 f:
  sem_sop2 f v1 v2 = ok v →
  ∃ (w1 : sem_t (type_of_op2 f).1.1) (w2 : sem_t (type_of_op2 f).1.2)
    (w3: sem_t (type_of_op2 f).2),
    [/\ of_val _ v1 = ok w1,
        of_val _ v2 = ok w2,
        sem_sop2_typed f w1 w2 = ok w3 &
        v = to_val w3].
Proof.
  by rewrite /sem_sop2; t_xrbindP => w1 ok_w1 w2 ok_w2 w3 ok_w3 <- {v}; exists w1, w2, w3.
Qed.

Definition sem_opN
  {cfcd : FlagCombinationParams} (op: opN) (vs: values) : exec value :=
  Let w := app_sopn _ (sem_opN_typed op) vs in
  ok (to_val w).

Record estate
  {syscall_state : Type}
  {ep : EstateParams syscall_state} := Estate
  {
    escs : syscall_state;
    emem : mem;
    evm  : vmap
  }.

Arguments Estate {syscall_state}%type_scope {ep} _ _ _.

Definition get_global_value (gd: glob_decls) (g: var) : option glob_value :=
  assoc gd g.

Definition gv2val (gd:glob_value) :=
  match gd with
  | Gword ws w => Vword w
  | Garr p a   => Varr a
  end.

Definition get_global gd g : exec value :=
  if get_global_value gd g is Some ga then
    let v := gv2val ga in
    if type_of_val v == vtype g then ok v
    else type_error
  else type_error.

Lemma get_globalI gd g v :
  get_global gd g = ok v →
  exists gv : glob_value, [/\ get_global_value gd g = Some gv, v = gv2val gv & type_of_val v = vtype g].
Proof.
  rewrite /get_global; case: get_global_value => // gv.
  by case:eqP => // <- [<-];exists gv.
Qed.

Definition get_gvar (gd: glob_decls) (vm: vmap) (x:gvar) :=
  if is_lvar x then get_var vm x.(gv)
  else get_global gd x.(gv).

Definition on_arr_var A (v:exec value) (f:forall n, WArray.array n -> exec A) :=
  Let v := v  in
  match v with
  | Varr n t => f n t
  | _ => type_error
  end.

Notation "'Let' ( n , t ) ':=' s '.[' v ']' 'in' body" :=
  (@on_arr_var _ (get_var s.(evm) v) (fun n (t:WArray.array n) => body)) (at level 25, s at level 0).

Notation "'Let' ( n , t ) ':=' gd ',' s '.[' v ']' 'in' body" :=
  (@on_arr_var _ (get_gvar gd s.(evm) v) (fun n (t:WArray.array n) => body)) (at level 25, gd at level 0, s at level 0).

Lemma type_of_get_var x vm v :
  get_var vm x = ok v ->
  type_of_val v = x.(vtype).
Proof. by rewrite /get_var; apply : on_vuP => // t _ <-; apply type_of_to_val. Qed.

Lemma on_arr_varP {syscall_state : Type} {ep : EstateParams syscall_state}
  A (f : forall n, WArray.array n -> exec A) v s x P :
  (forall n t, vtype x = sarr n ->
               get_var (evm s) x = ok (@Varr n t) ->
               f n t = ok v -> P) ->
  on_arr_var (get_var (evm s) x) f = ok v -> P.
Proof.
  rewrite /on_arr_var=> H;apply: rbindP => vx hx.
  have h := type_of_get_var hx; case: vx h hx => // len t h.
  by apply: H;rewrite -h.
Qed.

Lemma type_of_get_global gd g v :
  get_global gd g = ok v -> type_of_val v = vtype g.
Proof. by move=> /get_globalI [?[]]. Qed.

Lemma type_of_get_gvar x gd vm v :
  get_gvar gd vm x = ok v ->
  type_of_val v = vtype x.(gv).
Proof.
  rewrite /get_gvar;case:ifP => ?.
  + by apply type_of_get_var.
  by apply type_of_get_global.
Qed.

Lemma on_arr_gvarP A (f : forall n, WArray.array n -> exec A) v gd s x P:
  (forall n t, vtype x.(gv) = sarr n ->
               get_gvar gd s x = ok (@Varr n t) ->
               f n t = ok v -> P) ->
  on_arr_var (get_gvar gd s x) f = ok v -> P.
Proof.
  rewrite /on_arr_var=> H;apply: rbindP => vx hx.
  have h := type_of_get_gvar hx; case: vx h hx => // len t h.
  by apply: H;rewrite -h.
Qed.

Section SEM_PEXPR.

Context
  {asm_op syscall_state : Type}
  {ep : EstateParams syscall_state}
  {spp : SemPexprParams}
  (gd : glob_decls).

Fixpoint sem_pexpr (s:estate) (e : pexpr) : exec value :=
  match e with
  | Pconst z => ok (Vint z)
  | Pbool b  => ok (Vbool b)
  | Parr_init n => ok (Varr (WArray.empty n))
  | Pvar v => get_gvar gd s.(evm) v
  | Pget aa ws x e =>
      Let (n, t) := gd, s.[x] in
      Let i := sem_pexpr s e >>= to_int in
      Let w := WArray.get aa ws t i in
      ok (Vword w)
  | Psub aa ws len x e =>
      Let (n, t) := gd, s.[x] in
      Let i := sem_pexpr s e >>= to_int in
      Let t' := WArray.get_sub aa ws len t i in
      ok (Varr t')
  | Pload sz x e =>
    Let w1 := get_var s.(evm) x >>= to_pointer in
    Let w2 := sem_pexpr s e >>= to_pointer in
    Let w  := read s.(emem) (w1 + w2)%R sz in
    ok (@to_val (sword sz) w)
  | Papp1 o e1 =>
    Let v1 := sem_pexpr s e1 in
    sem_sop1 o v1
  | Papp2 o e1 e2 =>
    Let v1 := sem_pexpr s e1 in
    Let v2 := sem_pexpr s e2 in
    sem_sop2 o v1 v2
  | PappN op es =>
    Let vs := mapM (sem_pexpr s) es in
    sem_opN op vs
  | Pif t e e1 e2 =>
    Let b := sem_pexpr s e >>= to_bool in
    Let v1 := sem_pexpr s e1 >>= truncate_val t in
    Let v2 := sem_pexpr s e2 >>= truncate_val t in
    ok (if b then v1 else v2)
  end.

Definition sem_pexprs s := mapM (sem_pexpr s).

Definition write_var (x:var_i) (v:value) (s:estate) : exec estate :=
  Let vm := set_var s.(evm) x v in
  ok ({| escs := s.(escs); emem := s.(emem); evm := vm |}).

Definition write_vars xs vs s :=
  fold2 ErrType write_var xs vs s.

Definition write_none (s:estate) ty v :=
  on_vu (fun v => s) (if is_sbool ty then ok s else type_error)
          (of_val ty v).

Definition write_lval (l:lval) (v:value) (s:estate) : exec estate :=
  match l with
  | Lnone _ ty => write_none s ty v
  | Lvar x => write_var x v s
  | Lmem sz x e =>
    Let vx := get_var (evm s) x >>= to_pointer in
    Let ve := sem_pexpr s e >>= to_pointer in
    let p := (vx + ve)%R in (* should we add the size of value, i.e vx + sz * se *)
    Let w := to_word sz v in
    Let m :=  write s.(emem) p w in
    ok {| escs := s.(escs); emem := m;  evm := s.(evm) |}
  | Laset aa ws x i =>
    Let (n,t) := s.[x] in
    Let i := sem_pexpr s i >>= to_int in
    Let v := to_word ws v in
    Let t := WArray.set t aa i v in
    write_var x (@to_val (sarr n) t) s
  | Lasub aa ws len x i =>
    Let (n,t) := s.[x] in
    Let i := sem_pexpr s i >>= to_int in
    Let t' := to_arr (Z.to_pos (arr_size ws len)) v in
    Let t := @WArray.set_sub n aa ws len t i t' in
    write_var x (@to_val (sarr n) t) s
  end.

Definition write_lvals (s:estate) xs vs :=
   fold2 ErrType write_lval xs vs s.

End SEM_PEXPR.

Section EXEC_SYSCALL.

Context
  {syscall_state : Type}
  {scs : syscall_sem syscall_state} .

Definition exec_getrandom (scs : syscall_state) len vs :=
  Let _ :=
    match vs with
    | [:: v] => to_arr len v
    | _ => type_error
    end in
  let sd := get_random scs (Zpos len) in
  Let t := WArray.fill len sd.2 in
  ok (sd.1, [::Varr t]).

Definition exec_syscall
  {pd : PointerData}
  (scs : syscall_state_t)
  (m : mem)
  (o : syscall_t)
  (vs : values) :
  exec (syscall_state_t * mem * values) :=
  match o with
  | RandomBytes len =>
      Let sv := exec_getrandom scs len vs in
      ok (sv.1, m, sv.2)
  end.

End EXEC_SYSCALL.

Section EXEC_ASM.

Context
  {asm_op syscall_state : Type}
  {ep : EstateParams syscall_state}
  {spp : SemPexprParams}
  {asmop : asmOp asm_op}.

Definition exec_sopn (o:sopn) (vs:values) : exec values :=
  let semi := sopn_sem o in
  Let t := app_sopn _ semi vs in
  ok (list_ltuple t).

Lemma sopn_toutP o vs vs' : exec_sopn o vs = ok vs' ->
  List.map type_of_val vs' = sopn_tout o.
Proof.
  rewrite /exec_sopn /sopn_tout /sopn_sem.
  t_xrbindP => p _ <-;apply type_of_val_ltuple.
Qed.

Definition sem_sopn gd o m lvs args :=
  sem_pexprs gd m args >>= exec_sopn o >>= write_lvals gd m lvs.

End EXEC_ASM.

Section SEM.

Context
  {asm_op syscall_state : Type}
  {ep : EstateParams syscall_state}
  {spp : SemPexprParams}
  {sip : SemInstrParams asm_op syscall_state}
  (P : uprog).

Notation gd := (p_globs P).

Inductive sem : estate -> cmd -> estate -> Prop :=
| Eskip s :
    sem s [::] s

| Eseq s1 s2 s3 i c :
    sem_I s1 i s2 -> sem s2 c s3 -> sem s1 (i::c) s3

with sem_I : estate -> instr -> estate -> Prop :=
| EmkI ii i s1 s2:
    sem_i s1 i s2 ->
    sem_I s1 (MkI ii i) s2

with sem_i : estate -> instr_r -> estate -> Prop :=
| Eassgn s1 s2 (x:lval) tag ty e v v':
    sem_pexpr gd s1 e = ok v ->
    truncate_val ty v = ok v' →
    write_lval gd x v' s1 = ok s2 ->
    sem_i s1 (Cassgn x tag ty e) s2

| Eopn s1 s2 t o xs es:
    sem_sopn gd o s1 xs es = ok s2 ->
    sem_i s1 (Copn xs t o es) s2

| Esyscall s1 scs m s2 xs o es ves vs:
    sem_pexprs gd s1 es = ok ves →
    exec_syscall s1.(escs) s1.(emem) o ves = ok (scs, m, vs) →
    write_lvals gd {| escs := scs; emem := m; evm := s1.(evm) |} xs vs = ok s2 →
    sem_i s1 (Csyscall xs o es) s2

| Eif_true s1 s2 e c1 c2 :
    sem_pexpr gd s1 e = ok (Vbool true) ->
    sem s1 c1 s2 ->
    sem_i s1 (Cif e c1 c2) s2

| Eif_false s1 s2 e c1 c2 :
    sem_pexpr gd s1 e = ok (Vbool false) ->
    sem s1 c2 s2 ->
    sem_i s1 (Cif e c1 c2) s2

| Ewhile_true s1 s2 s3 s4 a c e c' :
    sem s1 c s2 ->
    sem_pexpr gd s2 e = ok (Vbool true) ->
    sem s2 c' s3 ->
    sem_i s3 (Cwhile a c e c') s4 ->
    sem_i s1 (Cwhile a c e c') s4

| Ewhile_false s1 s2 a c e c' :
    sem s1 c s2 ->
    sem_pexpr gd s2 e = ok (Vbool false) ->
    sem_i s1 (Cwhile a c e c') s2

| Efor s1 s2 (i:var_i) d lo hi c vlo vhi :
    sem_pexpr gd s1 lo = ok (Vint vlo) ->
    sem_pexpr gd s1 hi = ok (Vint vhi) ->
    sem_for i (wrange d vlo vhi) s1 c s2 ->
    sem_i s1 (Cfor i (d, lo, hi) c) s2

| Ecall s1 scs2 m2 s2 ii xs f args vargs vs :
    sem_pexprs gd s1 args = ok vargs ->
    sem_call s1.(escs) s1.(emem) f vargs scs2 m2 vs ->
    write_lvals gd {|escs := scs2; emem:= m2; evm := s1.(evm) |} xs vs = ok s2 ->
    sem_i s1 (Ccall ii xs f args) s2

with sem_for : var_i -> seq Z -> estate -> cmd -> estate -> Prop :=
| EForDone s i c :
    sem_for i [::] s c s

| EForOne s1 s1' s2 s3 i w ws c :
    write_var i (Vint w) s1 = ok s1' ->
    sem s1' c s2 ->
    sem_for i ws s2 c s3 ->
    sem_for i (w :: ws) s1 c s3

with sem_call : syscall_state_t -> mem -> funname -> seq value -> syscall_state_t -> mem -> seq value -> Prop :=
| EcallRun scs1 m1 scs2 m2 fn f vargs vargs' s1 vm2 vres vres' :
    get_fundef (p_funcs P) fn = Some f ->
    mapM2 ErrType truncate_val f.(f_tyin) vargs' = ok vargs ->
    write_vars f.(f_params) vargs (Estate scs1 m1 vmap0) = ok s1 ->
    sem s1 f.(f_body) (Estate scs2 m2 vm2) ->
    mapM (fun (x:var_i) => get_var vm2 x) f.(f_res) = ok vres ->
    mapM2 ErrType truncate_val f.(f_tyout) vres = ok vres' ->
    sem_call scs1 m1 fn vargs' scs2 m2 vres'.

(* We define a custom induction principle for program semantics. *)
Section SEM_IND.

  Variables
    (Pc   : estate -> cmd -> estate -> Prop)
    (Pi_r : estate -> instr_r -> estate -> Prop)
    (Pi : estate -> instr -> estate -> Prop)
    (Pfor : var_i -> seq Z -> estate -> cmd -> estate -> Prop)
    (Pfun : syscall_state_t -> mem -> funname -> seq value -> syscall_state_t -> mem -> seq value -> Prop).

  Definition sem_Ind_nil : Prop :=
    forall s : estate, Pc s [::] s.

  Definition sem_Ind_cons : Prop :=
    forall (s1 s2 s3 : estate) (i : instr) (c : cmd),
      sem_I s1 i s2 -> Pi s1 i s2 -> sem s2 c s3 -> Pc s2 c s3 -> Pc s1 (i :: c) s3.

  Hypotheses
    (Hnil: sem_Ind_nil)
    (Hcons: sem_Ind_cons)
  .

  Definition sem_Ind_mkI : Prop :=
    forall (ii : instr_info) (i : instr_r) (s1 s2 : estate),
      sem_i s1 i s2 -> Pi_r s1 i s2 -> Pi s1 (MkI ii i) s2.

  Hypothesis HmkI : sem_Ind_mkI.

  Definition sem_Ind_assgn : Prop :=
    forall (s1 s2 : estate) (x : lval) (tag : assgn_tag) ty (e : pexpr) v v',
      sem_pexpr gd s1 e = ok v ->
      truncate_val ty v = ok v' →
      write_lval gd x v' s1 = Ok error s2 ->
      Pi_r s1 (Cassgn x tag ty e) s2.

  Definition sem_Ind_opn : Prop :=
    forall (s1 s2 : estate) t (o : sopn) (xs : lvals) (es : pexprs),
      sem_sopn gd o s1 xs es = Ok error s2 ->
      Pi_r s1 (Copn xs t o es) s2.

  Definition sem_Ind_syscall : Prop :=
    forall s1 scs m s2 xs o es ves vs,
      sem_pexprs gd s1 es = ok ves →
      exec_syscall s1.(escs) s1.(emem) o ves = ok (scs, m, vs) →
      write_lvals gd {| escs := scs; emem := m; evm := s1.(evm) |} xs vs = ok s2 →
      Pi_r s1 (Csyscall xs o es) s2.

  Definition sem_Ind_if_true : Prop :=
    forall (s1 s2 : estate) (e : pexpr) (c1 c2 : cmd),
      sem_pexpr gd s1 e = ok (Vbool true) ->
      sem s1 c1 s2 -> Pc s1 c1 s2 -> Pi_r s1 (Cif e c1 c2) s2.

  Definition sem_Ind_if_false : Prop :=
    forall (s1 s2 : estate) (e : pexpr) (c1 c2 : cmd),
      sem_pexpr gd s1 e = ok (Vbool false) ->
      sem s1 c2 s2 -> Pc s1 c2 s2 -> Pi_r s1 (Cif e c1 c2) s2.

  Definition sem_Ind_while_true : Prop :=
    forall (s1 s2 s3 s4 : estate) a (c : cmd) (e : pexpr) (c' : cmd),
      sem s1 c s2 -> Pc s1 c s2 ->
      sem_pexpr gd s2 e = ok (Vbool true) ->
      sem s2 c' s3 -> Pc s2 c' s3 ->
      sem_i s3 (Cwhile a c e c') s4 -> Pi_r s3 (Cwhile a c e c') s4 -> Pi_r s1 (Cwhile a c e c') s4.

  Definition sem_Ind_while_false : Prop :=
    forall (s1 s2 : estate) a (c : cmd) (e : pexpr) (c' : cmd),
      sem s1 c s2 -> Pc s1 c s2 ->
      sem_pexpr gd s2 e = ok (Vbool false) ->
      Pi_r s1 (Cwhile a c e c') s2.

  Hypotheses
    (Hasgn: sem_Ind_assgn)
    (Hopn: sem_Ind_opn)
    (Hsyscall: sem_Ind_syscall)
    (Hif_true: sem_Ind_if_true)
    (Hif_false: sem_Ind_if_false)
    (Hwhile_true: sem_Ind_while_true)
    (Hwhile_false: sem_Ind_while_false)
  .

  Definition sem_Ind_for : Prop :=
    forall (s1 s2 : estate) (i : var_i) (d : dir) (lo hi : pexpr) (c : cmd) (vlo vhi : Z),
      sem_pexpr gd s1 lo = ok (Vint vlo) ->
      sem_pexpr gd s1 hi = ok (Vint vhi) ->
      sem_for i (wrange d vlo vhi) s1 c s2 ->
      Pfor i (wrange d vlo vhi) s1 c s2 -> Pi_r s1 (Cfor i (d, lo, hi) c) s2.

  Definition sem_Ind_for_nil : Prop :=
    forall (s : estate) (i : var_i) (c : cmd),
      Pfor i [::] s c s.

  Definition sem_Ind_for_cons : Prop :=
    forall (s1 s1' s2 s3 : estate) (i : var_i) (w : Z) (ws : seq Z) (c : cmd),
      write_var i w s1 = Ok error s1' ->
      sem s1' c s2 -> Pc s1' c s2 ->
      sem_for i ws s2 c s3 -> Pfor i ws s2 c s3 -> Pfor i (w :: ws) s1 c s3.

  Hypotheses
    (Hfor: sem_Ind_for)
    (Hfor_nil: sem_Ind_for_nil)
    (Hfor_cons: sem_Ind_for_cons)
  .

  Definition sem_Ind_call : Prop :=
    forall (s1 : estate) (scs2 : syscall_state_t) (m2 : mem) (s2 : estate)
           (ii : inline_info) (xs : lvals)
           (fn : funname) (args : pexprs) (vargs vs : seq value),
      sem_pexprs gd s1 args = Ok error vargs ->
      sem_call (escs s1) (emem s1) fn vargs scs2 m2 vs -> Pfun (escs s1) (emem s1) fn vargs scs2 m2 vs ->
      write_lvals gd {| escs := scs2; emem := m2; evm := evm s1 |} xs vs = Ok error s2 ->
      Pi_r s1 (Ccall ii xs fn args) s2.

  Definition sem_Ind_proc : Prop :=
    forall (scs1 : syscall_state_t) (m1 : mem) (scs2 : syscall_state_t) (m2 : mem) (fn:funname) (f : fundef) (vargs vargs': seq value)
           (s1 : estate) (vm2 : vmap) (vres vres': seq value),
      get_fundef (p_funcs P) fn = Some f ->
      mapM2 ErrType truncate_val f.(f_tyin) vargs' = ok vargs ->
      write_vars (f_params f) vargs {| escs := scs1; emem := m1; evm := vmap0 |} = ok s1 ->
      sem s1 (f_body f) {| escs := scs2; emem := m2; evm := vm2 |} ->
      Pc s1 (f_body f) {| escs := scs2; emem := m2; evm := vm2 |} ->
      mapM (fun x : var_i => get_var vm2 x) (f_res f) = ok vres ->
      mapM2 ErrType truncate_val f.(f_tyout) vres = ok vres' ->
      Pfun scs1 m1 fn vargs' scs2 m2 vres'.

  Hypotheses
    (Hcall: sem_Ind_call)
    (Hproc: sem_Ind_proc)
  .

  Fixpoint sem_Ind (e : estate) (l : cmd) (e0 : estate) (s : sem e l e0) {struct s} :
    Pc e l e0 :=
    match s in (sem e1 l0 e2) return (Pc e1 l0 e2) with
    | Eskip s0 => Hnil s0
    | @Eseq s1 s2 s3 i c s0 s4 =>
        @Hcons s1 s2 s3 i c s0 (@sem_I_Ind s1 i s2 s0) s4 (@sem_Ind s2 c s3 s4)
    end

  with sem_i_Ind (e : estate) (i : instr_r) (e0 : estate) (s : sem_i e i e0) {struct s} :
    Pi_r e i e0 :=
    match s in (sem_i e1 i0 e2) return (Pi_r e1 i0 e2) with
    | @Eassgn s1 s2 x tag ty e1 v v' h1 h2 h3 => @Hasgn s1 s2 x tag ty e1 v v' h1 h2 h3
    | @Eopn s1 s2 t o xs es e1 => @Hopn s1 s2 t o xs es e1
    | @Esyscall s1 scs m s2 xs o es ves vs h1 h2 h3 => @Hsyscall s1 scs m s2 xs o es ves vs h1 h2 h3
    | @Eif_true s1 s2 e1 c1 c2 e2 s0 =>
      @Hif_true s1 s2 e1 c1 c2 e2 s0 (@sem_Ind s1 c1 s2 s0)
    | @Eif_false s1 s2 e1 c1 c2 e2 s0 =>
      @Hif_false s1 s2 e1 c1 c2 e2 s0 (@sem_Ind s1 c2 s2 s0)
    | @Ewhile_true s1 s2 s3 s4 a c e1 c' h1 h2 h3 h4 =>
      @Hwhile_true s1 s2 s3 s4 a c e1 c' h1 (@sem_Ind s1 c s2 h1) h2 h3 (@sem_Ind s2 c' s3 h3)
          h4 (@sem_i_Ind s3 (Cwhile a c e1 c') s4 h4)
    | @Ewhile_false s1 s2 a c e1 c' s0 e2 =>
      @Hwhile_false s1 s2 a c e1 c' s0 (@sem_Ind s1 c s2 s0) e2
    | @Efor s1 s2 i0 d lo hi c vlo vhi e1 e2 s0 =>
      @Hfor s1 s2 i0 d lo hi c vlo vhi e1 e2 s0
        (@sem_for_Ind i0 (wrange d vlo vhi) s1 c s2 s0)
    | @Ecall s1 scs2 m2 s2 ii xs f13 args vargs vs e2 s0 e3 =>
      @Hcall s1 scs2 m2 s2 ii xs f13 args vargs vs e2 s0
        (@sem_call_Ind (escs s1) (emem s1) f13 vargs scs2 m2 vs s0) e3
    end

  with sem_I_Ind (e : estate) (i : instr) (e0 : estate) (s : sem_I e i e0) {struct s} :
    Pi e i e0 :=
    match s in (sem_I e1 i0 e2) return (Pi e1 i0 e2) with
    | @EmkI ii i0 s1 s2 s0 => @HmkI ii i0 s1 s2 s0 (@sem_i_Ind s1 i0 s2 s0)
    end

  with sem_for_Ind (v : var_i) (l : seq Z) (e : estate) (l0 : cmd) (e0 : estate)
         (s : sem_for v l e l0 e0) {struct s} : Pfor v l e l0 e0 :=
    match s in (sem_for v0 l1 e1 l2 e2) return (Pfor v0 l1 e1 l2 e2) with
    | EForDone s0 i c => Hfor_nil s0 i c
    | @EForOne s1 s1' s2 s3 i w ws c e1 s0 s4 =>
      @Hfor_cons s1 s1' s2 s3 i w ws c e1 s0 (@sem_Ind s1' c s2 s0)
         s4 (@sem_for_Ind i ws s2 c s3 s4)
    end

  with sem_call_Ind (scs : syscall_state_t) (m : mem) (f13 : funname) (l : seq value) (scs0 : syscall_state_t) (m0 : mem)
         (l0 : seq value) (s : sem_call scs m f13 l scs0 m0 l0) {struct s} : Pfun scs m f13 l scs0 m0 l0 :=
    match s with
    | @EcallRun scs1 m1 scs2 m2 fn f vargs vargs' s1 vm2 vres vres' Hget Hctin Hw Hsem Hvres Hctout =>
       @Hproc scs1 m1 scs2 m2 fn f vargs vargs' s1 vm2 vres vres' Hget Hctin Hw Hsem (sem_Ind Hsem) Hvres Hctout
    end.

End SEM_IND.

End SEM.