Require Import VST.floyd.proofauto.
Require Import VST.progs.list_dt.
Require Import VST.progs.insertionsort.
Require Import Sorted.
Require Import Omega.
Require Import Coq.Sorting.Permutation.

Local Open Scope logic.

Instance LS: listspec t_struct_list _tail.
Proof. eapply mk_listspec; reflexivity. Defined.

Fixpoint insert x xs :=
  match xs with
    | [] => [x]
    | h :: t => if Int.cmp Cle x h then x :: xs else h :: (insert x t)
  end.

Definition insertion_sort xs :=
    fold_right insert [] xs.

Definition insert_spec :=
  DECLARE _insert
    WITH sh: share, contents : list int, insert_val : int, sorted_ptr : val, insert_ptr: val
    PRE [_insert_node OF (tptr t_struct_list), _sorted OF (tptr t_struct_list)]
        PROP (writable_share sh)
        LOCAL (temp _sorted sorted_ptr; temp _insert_node insert_ptr)
        SEP (lseg LS sh (map Vint contents) sorted_ptr nullval;
               data_at sh t_struct_list (Vint insert_val, nullval) insert_ptr)
    POST [tptr t_struct_list]
      EX v: val,
        PROP() LOCAL(temp ret_temp v)
        SEP(lseg LS sh (map Vint (insert insert_val contents)) v nullval).

Definition insertionsort_spec :=
  DECLARE  _insertionsort
    WITH sh: share, contents : list int, list_ptr : val
    PRE [_p OF (tptr t_struct_list)]
        PROP (writable_share sh)
        LOCAL (temp _p list_ptr)
        SEP (lseg LS sh (map Vint contents) list_ptr nullval)
    POST [tptr t_struct_list]
      EX v: val,
        PROP() LOCAL(temp ret_temp v)
        SEP(lseg LS sh (map Vint (insertion_sort contents)) v nullval).

Definition main_spec :=
 DECLARE _main
  WITH u : unit
  PRE  [] main_pre prog u
  POST [ tint ] main_post prog u.

Definition Vprog : varspecs := nil.

Definition Gprog : funspecs :=   ltac:(with_library prog
     [insert_spec; insertionsort_spec]).

Lemma list_cell_eq: forall sh,
   list_cell LS sh = field_at sh t_struct_list [StructField _head].
Proof. admit. Qed.

Definition isptrb v :=
   match v with | Vptr _ _ => true | _ => false end.

Definition Igt a b:=
Int.cmp Cgt a b = true.

Definition fst_3 {A B C} (a: A* B*C) := fst (fst a).
Definition snd_3 {A B C} (a: A * B * C) := snd (fst a).
Definition third_3 {A B C} (a: A * B * C) := snd a.

Definition insert_invariant sh insert_val contents :=
EX prev_ptr : val,
EX index_ptr : val,
EX sorted_val : int,
EX next_ptr : val,
EX prev_val : int,
EX contents_lt: list int,
EX contents_rest : list int,
PROP ( if (isptrb prev_ptr)
      then
        (Forall (Igt insert_val) (contents_lt ++ [prev_val]))
      else Forall (Igt insert_val) contents_lt;
      if (isptrb index_ptr)
      then
        if (isptrb prev_ptr)
        then
             (contents_lt) ++ (prev_val)::(sorted_val)::(contents_rest) = contents
        else sorted_val::contents_rest = contents
      else
        if (isptrb prev_ptr)
        then
          contents_lt ++ (prev_val :: nil) = contents
        else
          nil = contents)
LOCAL (temp _index index_ptr; temp _insert_value (Vint insert_val);
        if (isptrb index_ptr)
        then temp _sortedvalue (Vint (sorted_val))
        else `(next_ptr = nullval);
        `eq (eval_id _guard)
         (`logical_and_result `(tptr t_struct_list)
           (eval_id _index) `tint
           (`(eval_binop Ogt tint tint) (eval_id _insert_value)
             (eval_id _sortedvalue)));
        temp _previous prev_ptr;
        if (isptrb prev_ptr)
        then `True
        else temp _sorted index_ptr)
SEP (
     (if(isptrb index_ptr)
      then
       (list_cell LS sh (index_ptr) (Vint (sorted_val)) *
        field_at sh t_struct_list [StructField _tail] next_ptr index_ptr)
      else
         emp);
      (if(isptrb prev_ptr)
       then lseg LS sh (map Vint (contents_lt))) (eval_id _sorted) `(prev_ptr) *
             `(list_cell LS sh (prev_ptr) (Vint (prev_val))) *
             `(field_at sh t_struct_list [StructField _tail] index_ptr prev_ptr)
       else emp);
     `(lseg LS sh (map Vint (contents_rest))) `(next_ptr) `nullval;
     `(field_at sh t_struct_list [StructField _head] (Vint insert_val)) (eval_id _insert_node);
     `(field_at sh t_struct_list [StructField _tail] nullval) (eval_id _insert_node) ).

Definition insert_post sh insert_val contents :=
EX prev_ptr : val,
EX index_ptr : val,
EX sorted_val : int,
EX next_ptr : val,
EX prev_val : int,
EX contents_lt: list int,
EX contents_rest : list int,
PROP (
      if (isptrb prev_ptr)
      then
        (Forall (Igt insert_val) (contents_lt ++ [prev_val]))
      else Forall (Igt insert_val) contents_lt;
        if (isptrb index_ptr)
      then
        if (isptrb prev_ptr)
        then
             (contents_lt) ++ (prev_val)::(sorted_val)::(contents_rest) = contents
        else sorted_val::contents_rest = contents
      else
        if (isptrb prev_ptr)
        then
          contents_lt ++ (prev_val :: nil) = contents
        else
          nil = contents)
LOCAL ( lift1 (typed_false (typeof (Etempvar _guard tint)))
              (eval_expr (Etempvar _guard tint));
        `(eq index_ptr) (eval_id _index);
        `(eq (Vint insert_val)) (eval_id _insert_value);
        if (isptrb index_ptr)
        then
          `(eq (Vint (sorted_val))) (eval_id _sortedvalue)
        else
          `(next_ptr = nullval);
        `eq (eval_id _guard)
         (`logical_and_result `(tptr t_struct_list)
           (eval_id _index) `tint
           (`(eval_binop Ogt tint tint) (eval_id _insert_value)
             (eval_id _sortedvalue)));
        `(eq prev_ptr) (eval_id _previous);
      if (isptrb prev_ptr)
        then `True
        else `(eq index_ptr) (eval_id _sorted))
SEP (
     (if(isptrb index_ptr)
      then
        (*NOTE:: Can't use (eval_expr _index) here or it will be missed by go_lower *)
       (`(list_cell LS sh (index_ptr) (Vint sorted_val)) *
        `(field_at sh t_struct_list [StructField _tail] next_ptr index_ptr))
      else
         emp);
      (if(isptrb prev_ptr)
       then  `(lseg LS sh (map Vint (contents_lt))) (eval_id _sorted) `(prev_ptr) *
             `(list_cell LS sh (prev_ptr) (Vint prev_val)) *
             `(field_at sh t_struct_list [StructField _tail] index_ptr prev_ptr)
       else emp);
     `(lseg LS sh (map Vint contents_rest)) `(next_ptr) `nullval;
     `(field_at sh t_struct_list [StructField _head] (Vint insert_val)) (eval_id _insert_node);
     `(field_at sh t_struct_list [StructField _tail] nullval) (eval_id _insert_node)).

Lemma lseg_cons_non_nill : forall {ls ll} LS sh h r v1 v2 , @lseg ls ll LS sh (h::r) v1 v2 =
!!isptr v1 && @lseg ls ll LS sh (h::r) v1 v2.
intros.
apply pred_ext.
  + apply andp_right; auto. rewrite lseg_unfold.
     normalize. rewrite field_at_isptr.
     normalize.
  +  normalize.
Qed.

Lemma Forall_app :
forall {A} P (l1 l2 :list A),
Forall P (l1 ++ l2) <->
Forall P l1 /\ Forall P l2.
intros.
split; induction l1; intros.
inv H. destruct l2; inv H0. auto.
split. auto. simpl in H2. inv H2.
constructor; auto.
split. inv H. constructor; auto. apply IHl1 in H3.
intuition.
inv H. apply IHl1 in H3. intuition.
simpl. intuition.
simpl. constructor.
destruct H. inv H. auto.
apply IHl1. intuition.
inv H0; auto.
Qed.

Lemma lseg_is_ptr_or_null :
forall  sh c v1 v2 R,
@lseg t_struct_list _tail LS sh (c) v1 v2 * R |-- !!is_pointer_or_null v1 && (@lseg t_struct_list _tail LS sh c v1 v2)  * R.
Proof.
intros.
cancel.
apply andp_right.
rewrite lseg_unroll.
apply orp_left. rewrite andp_assoc.
unfold ptr_eq. destruct v1; normalize. destruct v2; normalize.
unfold Int.cmpu in *. simpl.
destruct H.
apply int_eq_e in H.
apply int_eq_e in H0.
subst. unfold Int.zero. entailer.
unfold lseg_cons. normalize.
assert (X := @list_cell_eq). entailer.
cancel.
Qed.

Lemma eval_id_initialized : forall v id rho t,
tc_val t v ->
v = eval_id id rho ->
denote_tc_initialized id t rho.
Proof.
intros.
unfold eval_id in *.
unfold denote_tc_initialized.
exists v. split.
destruct (Map.get (te_of rho) id).
simpl in H0. inv H0.
auto.
inv H0.
inv H.
auto.
Qed.

Ltac destruct_ptr :=
  match goal with
    | [ H: isptr (?X) |- _] => let v := fresh "pt" in (remember X as v; destruct v; inv H)
  end.

Lemma lt_lemma : forall v1 v2 b1 t1,
                   typed_true tint (logical_and_result t1 b1 tint
                                                (eval_binop Ogt tint tint
                                                (Vint v1) (Vint v2))) ->
                                    Forall (Igt v1) [v2].
Proof.
  intros.
  simpl in *.
  unfold logical_and_result in *.
  simpl in *. constructor. unfold Igt.
  replace (Int.lt v2 v1) with
  (Int.cmp Clt v2 v1) in * by auto.
  remember (Int.cmp Clt v2 v1).
  destruct b; inv H.
  rewrite <- Int.swap_cmp in Heqb. simpl swap_comparison in Heqb.
  auto. destruct (strict_bool_val b1 t1); inv H1. destruct b; simpl; inv H0.
  auto.
Qed.

Lemma body_insertionsort : semax_body Vprog Gprog f_insertionsort insertionsort_spec.
Proof.
start_function.
name p _p.
name sorted _sorted.
name index _index.
name next _next.

forward. (*  sorted = NULL; *)
forward. (*   index = p; *)

Definition body_invariant sh contents :=
EX sorted_list : list int,
EX unsorted_list : list int,
EX p: val, EX i: val,
PROP (contents = sorted_list ++ unsorted_list)
LOCAL (temp _sorted p; temp _index i)
SEP (`(lseg LS sh (map Vint (insertion_sort sorted_list)) p nullval);
     `(lseg LS sh (map Vint unsorted_list) i nullval)).

Definition body_post sh contents :=
EX p: val,
PROP ()
LOCAL (temp _sorted p)
SEP (`(lseg LS sh (map Vint (insertion_sort contents)) p nullval)).

forward_while
    (body_invariant sh contents)
    (body_post sh contents)
     [[[sorted_list unsorted_list] p0] i].

(*pre implies invariant*)
apply (exp_right nil).
apply (exp_right contents).
apply (exp_right (Vint (Int.repr 0))).
apply (exp_right list_ptr).
entailer!.

(*invariant implies tc *)
entailer.

(*invariant implies post *)
apply (exp_right p0).
entailer!.
destruct unsorted_list; inv H0.
rewrite <- app_nil_end. auto.

(*invariant across body *)
focus_SEP 1.
normalize.
apply semax_lseg_nonnull.
entailer!.
intros insert_val' unsorted_list2' ? ? ?.
simpl valinject.
assert (exists insert_val, exists unsorted_list2,
   insert_val' = Vint insert_val /\ unsorted_list2' = map Vint unsorted_list2
    /\ unsorted_list = insert_val :: unsorted_list2)
  as [insert_val [unsorted_list2 [? [? ?]]]].
clear - H0. admit.
unfold POSTCONDITION; subst.
abbreviate_semax.
rename unsorted_list2 into unsorted_list.
forward. (* next = index -> tail; *)
forward. (* index -> tail = NULL; *)
(* fold t_struct_list. *)
rewrite list_cell_eq.
(*put fact about sorted into pre so I can instantiate it with a value later *)
simpl.
clear H1.
apply semax_pre with
(EX v : val,
 PROP  ()
   LOCAL  (temp _next y;  temp _sorted v; temp _index i)
   SEP
   (`(data_at sh t_struct_list (Vint insert_val, nullval) i);
   `(lseg LS sh (map Vint unsorted_list) y nullval);
   `(lseg LS sh (map Vint (insertion_sort sorted_list)) v nullval))).
apply (exp_right p0).
go_lower. ent_iter. apply andp_right. apply prop_right; repeat split; auto.
unfold_data_at 1%nat.
entailer.

apply extract_exists_pre. intros sorted_val.
forward_call  (* sorted = insert(index, sorted); *)
  (sh, (insertion_sort sorted_list), insert_val, sorted_val, i).
Intros vret.
forward index_old. (* index = next;*)
unfold body_invariant.
entailer.
apply (exp_right (sorted_list ++ [insert_val],
                           unsorted_list, sorted, next)).
entailer!.
rewrite app_ass; reflexivity.

Lemma insert_reorder : forall v1 v2 l,
insert v1 (insert v2 (l)) = insert v2 (insert v1 l).
Proof.
induction l. simpl. remember (Int.lt v2 v1); remember (Int.lt v1 v2).
destruct b; destruct b0; auto.
replace (Int.lt v2 v1) with (Int.cmp Clt v2 v1) in * by auto.
replace (Int.lt v1 v2) with (Int.cmp Clt v1 v2) in * by auto.
rewrite <- Int.swap_cmp in Heqb. simpl swap_comparison in Heqb.
symmetry in Heqb.
rewrite <- negb_false_iff in Heqb.
rewrite <- Int.negate_cmp in Heqb.
simpl negate_comparison in *.
Admitted.

Lemma insert_insertion_sort : forall v l,
insert v (insertion_sort l) = insertion_sort (l ++ [v]).
intros.
induction l.
auto.
simpl.
rewrite insert_reorder. rewrite IHl. auto.
Qed.

rewrite insert_insertion_sort. cancel.
unfold body_post.
forward_intro sorted_list.
forward.
apply exp_right with sorted.
entailer!.
Qed.

Lemma body_insert: semax_body Vprog Gprog f_insert insert_spec.
Proof.
start_function.
name insert_value _insert_value.
name index _index.
name insert_node _insert_node.
name sorted _sorted.
forward. (*previous = NULL;*)
forward. (*insert_value = insert_node -> head;*)
forward. (*index = sorted; *)
normalize. simpl.
Abort.  (* done up to here, more or less *)
(*
forward_if
 (if isptrb sorted_ptr
  then
  (EX first_val : int, EX tail_vals : list int, EX tail_ptr : val,
   PROP  (contents = first_val :: tail_vals)
      LOCAL
      (`(eq sorted_ptr) (eval_id _index);
       `(eq nullval) (eval_id _previous);
      `(eq (Vint insert_val)) (eval_id _insert_value);
      `(eq (Vint first_val)) (eval_id _sortedvalue);
       `(eq sorted_ptr) (eval_id _sorted))
      SEP  (
         `(field_at sh t_struct_list _head (Vint first_val)) (eval_id _sorted);
         `(field_at sh t_struct_list _tail tail_ptr) (eval_id _sorted);
         `(lseg LS sh (map Vint tail_vals) tail_ptr nullval);
         `(field_at sh t_struct_list _tail nullval) (eval_id _insert_node)))
  else
  (PROP  ()
      LOCAL
      (`(eq sorted_ptr) (eval_id _index);
       `(eq nullval) (eval_id _previous);
      `(eq (Vint insert_val)) (eval_id _insert_value);
       `(eq sorted_ptr) (eval_id _sorted))
      SEP  (
       `(lseg LS sh (map Vint contents) nullval nullval);
      `(field_at sh t_struct_list _head (Vint insert_val)) (eval_id _insert_node);
      `(field_at sh t_struct_list _tail nullval) (eval_id _insert_node)))).
entailer.
{
apply semax_lseg_nonnull.
entailer.
intros first_val' tail_vals' tail_ptr ? ?.
assert (exists first_val, exists tail_vals,
   first_val' = Vint first_val /\ tail_vals' = map Vint tail_vals
    /\ contents = insert_val :: tail_vals)
  as [first_val [tail_vals [? [? ?]]]].
clear - H0. admit.
subst first_val' tail_vals'. clear H0. rename H4 into H0.
rewrite list_cell_eq. simpl.
forward. (*sortedvalue = index -> head;*)
(*  entailer. doesn't work because go_lower doesn't get all the vars in rho *)
go_lowerx.
 entailer!.
 replace (isptrb (eval_id _sorted rho)) with true by (clear - H12; destruct (eval_id _sorted rho); try contradiction; reflexivity).
  apply (exp_right insert_val).
  apply (exp_right tail_vals).
  apply (exp_right tail_ptr).
  entailer!.
  f_equal.  congruence. rewrite H7.

  apply sequential'.
  hoist_later_in_pre.
  eapply semax_post_flipped.
  eapply (semax_load_field''); try reflexivity.
  entailer.
  entailer!.
  intros.
 destruct contents; inv H0; apply I.
  apply andp_left2.
  apply normal_ret_assert_derives'.
  entailer. unfold subst in *.
  apply (exp_right first_val).
  apply (exp_right tail_vals).
  apply (exp_right tail_ptr).
  entailer.
  rewrite H2 in *.
  remember (eval_id _sorted rho).
  destruct (v); try inv H5; simpl;
  entailer!.
  rewrite <- Heqv in *.
  cancel.
}
{
  apply sequential'.
  eapply semax_post_flipped.
  eapply semax_skip.
  intros.
  apply andp_left2.
  apply normal_ret_assert_derives'.
  entailer!.
  rewrite H0 in *.
  rewrite <- H1. simpl.
  entailer!.
  apply (exp_right nil).
  apply (exp_right nullval).
  entailer!.

}

abbreviate_semax.

repeat intro_ex_semax.

forward. (*guard' = index && (value > sortedvalue);*)
admit. admit.   (* need closed lemma *)
entailer. destruct sorted_ptr; inv TC1; simpl in *.
entailer!. apply orp_right1. normalize.
entailer!. apply orp_right2.
apply prop_right.
apply eval_id_initialized with (Vint first_val); auto.

forward. (*guard = guard'*)

simpl typeof.
{
forward_while (insert_invariant sh insert_val contents)
              (insert_post sh insert_val contents).
(*pre implies invariant*)
remember (isptrb sorted_ptr).
{ destruct b; autorewrite with subst.
  + apply (exp_right nullval).
    apply (exp_right sorted_ptr).
    apply (exp_right first_val).
    apply (exp_right tail_ptr).
    apply (exp_right insert_val).
    apply (exp_right nil).
    apply (exp_right tail_vals).
    entailer.
    destruct sorted_ptr; inv Psorted_ptr.
    simpl.
    rewrite <- H1 in *.
    rewrite <- H4 in *.
    entailer!.
  + apply (exp_right nullval).
    apply (exp_right sorted_ptr).
    rewrite <- Heqb.
    apply (exp_right first_val).
    apply (exp_right nullval).
    apply (exp_right insert_val). (*whatever*)
    apply (exp_right nil).
    apply (exp_right nil).
    entailer!. rewrite <- H1 in *; auto.
}

(*guard typechecks*)
entailer.
(*invariant implies post *)
apply (exp_right prev_ptr).
apply (exp_right index_ptr).
apply (exp_right sorted_val).
apply (exp_right next_ptr).
apply (exp_right prev_val).
apply (exp_right contents_lt).
apply (exp_right contents_rest).
entailer!.
(*invariant across command *)

(*get rid of ifs because the index_ptr exists *)
eapply semax_pre with
 (PROP  (if isptrb prev_ptr
       then Forall (Igt insert_val) (contents_lt ++ [prev_val])
       else Forall (Igt insert_val) contents_lt;
      if isptrb prev_ptr
              then
               contents_lt ++ prev_val :: sorted_val :: contents_rest =
               contents
              else sorted_val :: contents_rest = contents)
      LOCAL
      (`(typed_true (typeof (Etempvar _guard tint)))
         (eval_expr (Etempvar _guard tint));
      `(eq index_ptr) (eval_id _index);
      `(eq (Vint insert_val)) (eval_id _insert_value);
      `(eq (Vint sorted_val)) (eval_id _sortedvalue);
      `eq (eval_id _guard)
        (`logical_and_result `(tptr t_struct_list)
           (eval_id _index) `tint
           (`(eval_binop Ogt tint tint) (eval_id _insert_value)
              (eval_id _sortedvalue))); `(eq prev_ptr) (eval_id _previous);
      if isptrb prev_ptr then `True else `(eq index_ptr) (eval_id _sorted))
      SEP  (if isptrb prev_ptr
      then
       `(lseg LS sh contents_lt) (eval_id _sorted) `prev_ptr *
       `(list_cell LS sh prev_ptr prev_val) *
       `(field_at sh t_struct_list _tail prev_ptr index_ptr)
      else emp;
           `(list_cell LS sh index_ptr sorted_val);
       `(field_at sh t_struct_list _tail index_ptr next_ptr);
       `(lseg LS sh contents_rest) `next_ptr `nullval;
      `(field_at sh t_struct_list _head) (eval_id _insert_node)
        `(Vint insert_val);
      `(field_at sh t_struct_list _tail) (eval_id _insert_node) `nullval)).
entailer. rewrite H5 in *. clear H5.
unfold logical_and_result in *.
destruct index; inv H3. destruct (Int.eq i Int.zero); inv H7.
simpl.
entailer!.
forward.  (* previous = index; *)
forward.  (* index = index -> tail; *)
(* if(index) *)
forward_if
     (EX index_val2 : elemtype LS,
      EX index_ptr2 : val,
      EX rest_index_vals : list (elemtype LS),
      EX old : val,
     PROP  (if isptrb prev_ptr
       then Forall (Igt insert_val) (contents_lt ++ [prev_val])
       else Forall (Igt insert_val) (contents_lt);
       (if (isptrb next_ptr)
        then
          if (isptrb prev_ptr)
          then contents_lt ++ prev_val :: sorted_val :: index_val2 :: rest_index_vals = contents
          else sorted_val :: index_val2 :: rest_index_vals = contents
        else
          if (isptrb prev_ptr)
          then contents_lt ++ prev_val :: sorted_val :: nil = contents
          else sorted_val :: nil = contents);
      (if(isptrb next_ptr) then
         index_val2 :: rest_index_vals = contents_rest
       else
         True))
      LOCAL  (`(eq next_ptr) (eval_id _index);
      `eq (eval_id _previous) `index0;
      `(eq index_ptr) `index0;
      `(typed_true (typeof (Etempvar _guard tint))) (eval_id _guard);
      `(eq (Vint insert_val)) (eval_id _insert_value);
      `(eq (Vint sorted_val)) `old;
      (if (isptrb next_ptr) then
        `(eq (Vint index_val2)) (eval_id _sortedvalue)
      else
        `(eq (Vint sorted_val)) (eval_id _sortedvalue));
      `eq (eval_id _guard)
        (`logical_and_result `(tptr t_struct_list)
           `index0 `tint
           (`(eval_binop Ogt tint tint) (eval_id _insert_value)
              `old));
if isptrb prev_ptr then `True else `(eq index_ptr) (eval_id _sorted))
      SEP  (`(list_cell LS sh) `index0 `sorted_val;
      `(field_at sh t_struct_list _tail) `index_ptr `next_ptr;
      (if isptrb prev_ptr
             then
              `(lseg LS sh contents_lt) (eval_id _sorted) `prev_ptr *
              `(list_cell LS sh prev_ptr prev_val) *
              `(field_at sh t_struct_list _tail prev_ptr index_ptr)
             else emp);
      (if (isptrb next_ptr) then
        (`(list_cell LS sh) `next_ptr `index_val2 *
         `(field_at sh t_struct_list _tail) `next_ptr `index_ptr2 *
         `(lseg LS sh rest_index_vals) `index_ptr2 `nullval)
      else `emp);
       `(field_at sh t_struct_list _head) (eval_id _insert_node)
        `(Vint insert_val);
      `(field_at sh t_struct_list _tail) (eval_id _insert_node) `nullval)).
entailer.
focus_SEP 3. apply semax_lseg_nonnull.
entailer.
intros index_val2 rest_index_vals2 index_ptr2 ?.
(*needs work, most of this should be in forward *)
(*sortedvalue = index -> head;*)
{ rewrite lift_list_cell_eq.
  apply sequential'.
  hoist_later_in_pre.
  eapply semax_post_flipped.
  eapply (semax_load_field''); try reflexivity.
  entailer!.
  entailer.
  cancel.
  intros. apply andp_left2.
  apply normal_ret_assert_derives'.
  apply (exp_left); intro old.
  apply (exp_right index_val2).
  apply (exp_right index_ptr2).
  apply (exp_right rest_index_vals2).
  apply (exp_right old).
  autorewrite with subst.
  entailer.
  destruct (eval_id _index rho); inv H4.
  simpl.
  entailer.
  cancel.
  destruct (isptrb x0); unfold subst; simpl; entailer!.
}
(*also needs work *)
(*skip*)
{
  apply sequential'.
  eapply semax_post_flipped.
  eapply semax_skip.
  intros. apply andp_left2.
  apply normal_ret_assert_derives'.
  apply (exp_right sorted_val).
  (*these don't matter *)
  apply (exp_right x).
  apply (exp_right contents_rest).
  (*this does*)
  apply (exp_right (Vint sorted_val)).
  entailer.
  rewrite H2 in *. simpl.
  rewrite <- H4 in *; rewrite <- H5 in *.
  simpl.
  entailer!.
  destruct (isptrb x0); auto. unfold subst. simpl.
  destruct (isptrb x0); entailer.
}

abbreviate_semax.
repeat intro_ex_semax.
rename old into old_sortedvalue.
forward. (* guard = index && (insert_value > sortedvalue); *)
admit.
admit.
go_lower.
subst. destruct index; inv TC1; simpl in *.
entailer!. apply orp_right1. normalize.
entailer!. compute. auto.
apply orp_right2. apply prop_right.
apply eval_id_initialized with (Vint index_val2); auto.

forward. (* guard' = guard *)

(*implies post*)

unfold insert_invariant. autorewrite with ret_assert.

apply (exp_right index0).
apply (exp_right next_ptr).

remember (isptrb next_ptr).
{ destruct b; autorewrite with subst.
    + remember (isptrb prev_ptr).
      destruct b; simpl PROPx;
      apply (exp_right (index_val2));
      apply (exp_right index_ptr2);
      apply (exp_right sorted_val).
        - apply (exp_right (contents_lt ++ prev_val :: nil)).
          apply (exp_right (rest_index_vals)).
          entailer. destruct_ptr. simpl.
          apply andp_right.
            * apply prop_right.
              split.
              simpl.
              repeat (rewrite Forall_app in *; auto; split; auto).
              try eapply lt_lemma; eauto.
              split.
              rewrite app_assoc_reverse. simpl. auto.
              rewrite <- H5 in *. rewrite <- H2 in *.
              auto.
            * unfold subst.
              rewrite eval_id_other; try solve [unfold _guard; unfold _sorted; congruence].
              remember ( field_at sh t_struct_list _tail (Vptr b i) index).
              rewrite Heqm at 1. cancel. rewrite Heqm.
              apply derives_trans with
              (list_cell LS sh prev_ptr prev_val *
               field_at sh t_struct_list _tail prev_ptr (Vptr b i) *
               lseg LS sh contents_lt (eval_id _sorted rho) prev_ptr *
               field_at sh t_struct_list _tail (Vptr b i) index
              ).
              cancel.
              apply @lseg_cons_right_neq.
        -  apply (exp_right (nil)).
           apply (exp_right (rest_index_vals)).
           entailer. unfold subst in H6. rewrite eval_id_other in H6.
           destruct_ptr. simpl.
           apply andp_right.
             * apply prop_right. simpl.
               split; auto.
               repeat (rewrite Forall_app; split; auto).
               eapply lt_lemma; eauto.
               split; auto. rewrite <- H5 in *. rewrite <- H2 in *.  auto.
             * cancel. rewrite <- H6. rewrite lseg_unfold. entailer.
               simpl. intuition. apply Int.eq_true.
             * unfold _guard. unfold _sorted. congruence.
    + apply (exp_right index_val2).
      apply (exp_right nullval).
      apply (exp_right sorted_val).
      remember (isptrb prev_ptr).
      destruct b. simpl PROPx.
           - apply (exp_right (contents_lt ++ [prev_val])).
             apply (exp_right nil).
             entailer!; destruct_ptr; simpl.
               * repeat (rewrite Forall_app in *; auto; split; auto).
                 try eapply lt_lemma; eauto.
               * rewrite app_assoc_reverse. auto.
               * rewrite <- H5 in *. rewrite <- H2 in *; auto.
               * auto.
               * simpl. unfold subst.
                 rewrite eval_id_other; try solve [unfold _guard; unfold _sorted; congruence].
                 remember ( field_at sh t_struct_list _tail (Vptr b i) index).
                 rewrite Heqm at 1. cancel. rewrite Heqm.
                 apply derives_trans with
                 (list_cell LS sh prev_ptr prev_val *
                  field_at sh t_struct_list _tail prev_ptr (Vptr b i) *
                  lseg LS sh contents_lt (eval_id _sorted rho) prev_ptr *
                  field_at sh t_struct_list _tail (Vptr b i) index
                 ).
                 cancel.
                 apply @lseg_cons_right_neq.
           - apply (exp_right nil).
             apply (exp_right nil).
             entailer. unfold subst in *.
             rewrite eval_id_other in H6.
             destruct_ptr; simpl.
             entailer!.
             eapply lt_lemma; eauto.
             rewrite <- H5 in *; rewrite H2 in *; auto.
             rewrite <- H6. simpl. intuition. apply Int.eq_true.
             unfold _guard, _sorted. congruence.
}

unfold insert_post.
repeat intro_ex_semax.
forward. (*insert_node -> tail = index*)
forward_if (
(PROP
    (Forall (Igt insert_val) contents_lt;
    if isptrb index_ptr
    then
      sorted_val :: contents_rest = contents
    else
      [] = contents)
    LOCAL
    (`(typed_false (typeof (Etempvar _previous (tptr t_struct_list))))
       (eval_expr (Etempvar _previous (tptr t_struct_list)));
    lift1 (typed_false (typeof (Etempvar _guard tint)))
      (eval_expr (Etempvar _guard tint)); `(eq index_ptr) (eval_id _index);
    `(eq (Vint insert_val)) (eval_id _insert_value);
    if isptrb index_ptr
    then `(eq (Vint sorted_val)) (eval_id _sortedvalue)
    else `(next_ptr = nullval);
    `eq (eval_id _guard)
      (`logical_and_result `(tptr t_struct_list) (eval_id _index)
         `tint
         (`(eval_binop Ogt tint tint) (eval_id _insert_value)
            (eval_id _sortedvalue))); `(eq prev_ptr) (eval_id _previous))
    SEP
    (if isptrb index_ptr
     then
      `(list_cell LS sh index_ptr sorted_val) *
      `(field_at sh t_struct_list _tail index_ptr next_ptr)
     else emp;
    `(lseg LS sh contents_rest) `next_ptr `nullval;
    `(field_at sh t_struct_list _head) (eval_id _insert_node)
      `(Vint insert_val);
    `(field_at sh
        (Tstruct _struct_list
           (Fcons _head tint
              (Fcons _tail (Tcomp_ptr _struct_list noattr) Fnil)) noattr)
        _tail)
      (eval_lvalue
         (Ederef (Etempvar _insert_node (tptr t_struct_list)) t_struct_list))
      (`(eval_cast (typeof (Etempvar _index (tptr t_struct_list)))
           (tptr t_struct_list))
         (eval_expr (Etempvar _index (tptr t_struct_list))))))
). (* if (previous) *)
entailer!.
{
  (*we know prev_ptr is true*)
  apply semax_pre with (
    (PROP
      (Forall (Igt insert_val) (contents_lt ++ [prev_val]);
      if isptrb index_ptr
      then
       contents_lt ++ prev_val :: sorted_val :: contents_rest = contents
       else
       contents_lt ++ [prev_val] = contents
      )
      LOCAL
      (`(typed_true (typeof (Etempvar _previous (tptr t_struct_list))))
         (eval_expr (Etempvar _previous (tptr t_struct_list)));
      lift1 (typed_false (typeof (Etempvar _guard tint)))
        (eval_expr (Etempvar _guard tint)); `(eq index_ptr) (eval_id _index);
      `(eq (Vint insert_val)) (eval_id _insert_value);
      if isptrb index_ptr
      then `(eq (Vint sorted_val)) (eval_id _sortedvalue)
      else `(next_ptr = nullval);
      `eq (eval_id _guard)
        (`logical_and_result `(tptr t_struct_list)
           (eval_id _index) `tint
           (`(eval_binop Ogt tint tint) (eval_id _insert_value)
              (eval_id _sortedvalue))); `(eq prev_ptr) (eval_id _previous))
      SEP
      (if isptrb index_ptr
       then
        `(list_cell LS sh index_ptr sorted_val) *
        `(field_at sh t_struct_list _tail index_ptr next_ptr)
       else emp;
       `(lseg LS sh contents_lt) (eval_id _sorted) `prev_ptr;
       `(list_cell LS sh prev_ptr prev_val);
       `(field_at sh t_struct_list _tail prev_ptr index_ptr);
       `(lseg LS sh contents_rest) `next_ptr `nullval;
       `(field_at sh t_struct_list _head) (eval_id _insert_node)
        `(Vint insert_val);
       `(field_at sh
          (Tstruct _struct_list
             (Fcons _head tint
                (Fcons _tail (Tcomp_ptr _struct_list noattr) Fnil)) noattr)
          _tail)
        (eval_lvalue
           (Ederef (Etempvar _insert_node (tptr t_struct_list)) t_struct_list))
        (`(eval_cast (typeof (Etempvar _index (tptr t_struct_list)))
             (tptr t_struct_list))
           (eval_expr (Etempvar _index (tptr t_struct_list))))))
  ).
remember (eval_id _sorted).
entailer!;
 destruct (eval_id _previous rho); try inversion H3; simpl in *; auto.
forward. (* previous->tail = insert_node; *)
forward. (* return sorted *)
entailer.
destruct index; inv TC1.
simpl in *.
cancel. fold t_struct_list.
rewrite H5. fold nullval.
apply derives_trans with
(lseg LS sh (contents_lt ++ [prev_val]) sorted insert_node *
 lseg LS sh contents_rest nullval nullval *
 field_at sh t_struct_list _head insert_node (Vint insert_value) *
 field_at sh t_struct_list _tail insert_node nullval).
remember (field_at sh t_struct_list _tail insert_node nullval).
rewrite Heqm at 1.
cancel.
rewrite Heqm.
apply derives_trans with
( list_cell LS sh (eval_id _previous rho) prev_val *
  field_at sh t_struct_list _tail (eval_id _previous rho) insert_node *
  lseg LS sh contents_lt sorted (eval_id _previous rho) *
  field_at sh t_struct_list _tail insert_node nullval
). cancel.
apply @lseg_cons_right_neq.
rewrite <- list_cell_eq.

Lemma insert_value_right : forall contents insert_value,
Forall (Igt insert_value) contents ->
insert insert_value contents = contents ++ [insert_value].
induction contents; intros.
auto.
simpl in *. inv H. remember (Int.lt a insert_value).
destruct b. simpl. rewrite IHcontents; auto.
unfold Igt in H2. clear - H2 Heqb.
 replace (Int.lt a insert_value) with
  (Int.cmp Clt a insert_value) in * by auto.
  rewrite <- Int.swap_cmp in Heqb. simpl swap_comparison in Heqb. congruence.
Qed.

apply insert_value_right in H1. subst. rewrite H1.

apply derives_trans with
(list_cell LS sh insert_node insert_value *
 field_at sh t_struct_list _tail insert_node nullval *
 lseg LS sh (contents_lt ++ [prev_val]) sorted insert_node).
cancel. rewrite lseg_eq. normalize. simpl. auto.
apply @lseg_cons_right_null.
simpl in *.
fold t_struct_list.

rewrite H6 in H4.
clear H6. unfold logical_and_result, typed_false in H4.
simpl in H4. rewrite <- H5 in H4. remember (Int.lt sorted_val insert_value).
destruct b0; inv H4.

Lemma insert_value_result : forall contents_lt insert_value next_value contents_rest,
Forall (Igt insert_value) (contents_lt) ->
false = Int.lt next_value insert_value ->
insert insert_value (contents_lt ++ next_value :: contents_rest) =
contents_lt ++ insert_value :: next_value :: contents_rest.
induction contents_lt;
intros. repeat rewrite app_nil_l.
simpl. rewrite <- H0. auto.
auto.
inv H. simpl.
remember (Int.lt a insert_value).
destruct b. simpl. rewrite IHcontents_lt; auto.
unfold Igt in *. clear - H3 Heqb.
 replace (Int.lt a insert_value) with
  (Int.cmp Clt a insert_value) in * by auto.
  rewrite <- Int.swap_cmp in Heqb. simpl swap_comparison in Heqb. congruence.
Qed.

rewrite app_cons.
rewrite insert_value_result.

apply derives_trans with
( list_cell LS sh (Vptr b i) sorted_val *
   field_at sh t_struct_list _tail (Vptr b i) next_ptr *
   lseg LS sh (contents_lt ++ [prev_val]) sorted insert_node *
   lseg LS sh contents_rest next_ptr nullval *
   field_at sh t_struct_list _head insert_node (Vint insert_value) *
   field_at sh t_struct_list _tail insert_node (Vptr b i)
).
remember (field_at sh t_struct_list _tail insert_node (Vptr b i)).
rewrite Heqm at 1.
cancel.
rewrite Heqm.
eapply derives_trans with
( list_cell LS sh (eval_id _previous rho) prev_val *
  field_at sh t_struct_list _tail (eval_id _previous rho) insert_node *
  lseg LS sh contents_lt sorted (eval_id _previous rho) *
  field_at sh t_struct_list _tail insert_node (Vptr b i)).
cancel.
apply @lseg_cons_right_neq.
apply derives_trans with
(  lseg LS sh (contents_lt ++ [prev_val]) sorted insert_node *
   lseg LS sh (sorted_val :: contents_rest) (Vptr b i) nullval *
   field_at sh t_struct_list _head insert_node (Vint insert_value) *
   field_at sh t_struct_list _tail insert_node (Vptr b i)).
cancel.
rewrite lseg_unfold with (contents :=sorted_val :: contents_rest).
entailer!. apply (exp_right next_ptr).
entailer!.
rewrite <- list_cell_eq.
apply derives_trans with
( lseg LS sh (contents_lt ++ [prev_val]) sorted insert_node *
   lseg LS sh (insert_value :: sorted_val :: contents_rest) insert_node nullval ).
cancel.
rewrite lseg_unfold with (contents := insert_value :: sorted_val :: contents_rest).
entailer.
apply (exp_right (Vptr b i)).
entailer!. destruct insert_node; inv Pinsert_node.
unfold ptr_eq. simpl. auto.
admit. (*believable, need lseg append lemma*) auto. auto.
}
(*skip*)
{
  apply sequential'.
  eapply semax_post_flipped.
  eapply semax_skip.
  intros. apply andp_left2.
  apply normal_ret_assert_derives'.
  entailer!; rewrite H2 in *; simpl in *; auto.
  unfold typed_false, nullval. auto.
}
abbreviate_semax.
forward.
entailer.
destruct index; inv TC1; simpl in *.
fold t_struct_list. subst. simpl.
fold nullval.
Check lseg_neq.
rewrite lseg_neq with (s := [insert_value]).
unfold lseg_cons. apply andp_right. destruct_ptr.
entailer.
apply (exp_right insert_value). apply (exp_right nil).
apply (exp_right nullval).
entailer!.
apply now_later.
destruct insert_node; inv Pinsert_node; unfold ptr_neq; auto.

fold t_struct_list.
subst.
rewrite <- (app_nil_l (sorted_val :: contents_rest)).
rewrite insert_value_result. simpl.
apply derives_trans with
(  lseg LS sh (sorted_val :: contents_rest) (Vptr b i) nullval *
   field_at sh t_struct_list _head insert_node (Vint insert_value) *
   field_at sh t_struct_list _tail insert_node (Vptr b i)
).
cancel.
rewrite lseg_unfold with (contents := (sorted_val :: contents_rest)).
entailer. apply (exp_right next_ptr).
entailer!. rewrite <- list_cell_eq.
apply derives_trans with
(  list_cell LS sh insert_node insert_value *
   field_at sh t_struct_list _tail insert_node (Vptr b i) *
lseg LS sh (sorted_val :: contents_rest) (Vptr b i) nullval
) .
cancel.
rewrite lseg_unfold with (contents := (insert_value :: sorted_val :: contents_rest)).
entailer. apply (exp_right (Vptr b i)).
entailer!. destruct insert_node; intuition.
constructor.
rewrite H6 in *.
clear H6.
rewrite <- H5 in *.
simpl in H4.
unfold typed_false, logical_and_result in *.
simpl in H4. destruct (Int.lt sorted_val insert_value); inv H4; auto.
}
Qed.

Lemma sorted_sound : forall xs, sorted xs = true <-> LocallySorted Z.le xs.
intuition.
+  induction xs.
   - constructor.
   - simpl in H.
     destruct xs.
     * constructor.
     * constructor. simpl in H. apply IHxs. remember (a <=? z)%Z. destruct b.
       simpl. apply H. congruence.
       apply Z.leb_le. destruct (a <=? z)%Z; congruence.
+  induction xs.
   - auto.
   - simpl. destruct xs. auto.
     simpl. remember (a <=? z)%Z. destruct b.
     inv H. intuition.
     inv H. apply Z.leb_le in H4. congruence.
Qed.

Lemma insert_sorted : forall x xs, LocallySorted Z.le xs -> LocallySorted Z.le (insert x xs).
Proof.
intros.
induction xs.
+ constructor.
+ simpl. remember (x <=? a)%Z.
    destruct b.
  - constructor. auto. apply Z.leb_le. auto.
  - inv H.
      * simpl. constructor. constructor.
        apply Z.leb_le. remember (a <=? x)%Z. destruct b. auto.
        symmetry in Heqb, Heqb0. rewrite Z.leb_gt in *. omega.
      * simpl. remember ((x <=? b)%Z). destruct b0.
          repeat (constructor; simpl). auto. symmetry in Heqb.
          apply Z.leb_le. auto. symmetry in Heqb. rewrite Z.leb_gt in *.
          omega.
          constructor. simpl in IHxs. rewrite <- Heqb0 in IHxs. auto. auto.
Qed.

Lemma insertion_sort_sorted : forall xs, LocallySorted Z.le (insertion_sort xs).
Proof.
induction xs.
  + constructor.
  + simpl. apply insert_sorted.  auto.

Qed.

Lemma insert_permutation : forall x xs , Permutation (x::xs) (insert x xs).
Proof.
intros.
induction xs.
+ auto.
+ simpl. destruct (x <=? a)%Z.
  - auto.
  - eapply perm_trans. eapply perm_swap. apply perm_skip. apply IHxs.
Qed.

Lemma insert_permutation2 : forall x xs x2, Permutation xs x2 ->
Permutation (x::xs) (insert x x2).
Proof.
intros.
induction xs.
destruct x2. auto. apply Permutation_nil in H. inv H.
apply Permutation_sym.
eapply perm_trans. eapply Permutation_sym. apply insert_permutation.
apply perm_skip. apply Permutation_sym. auto.
Qed.

Lemma insertion_sort_permutation : forall xs, Permutation xs (insertion_sort xs).
Proof.
intros.
induction xs.
+ auto.
+ simpl. apply insert_permutation2. auto.
Qed.

Lemma insertion_sort_sound : forall xs, LocallySorted Z.le (insertion_sort xs) /\ Permutation xs (insertion_sort xs).
Proof.
intros.
split. apply insertion_sort_sorted.
apply insertion_sort_permutation.
Qed.
*)


Require Import ssreflect ssrbool ssrnat eqtype seq finfun tuple fintype.
Require Import bitsrep ilogic.
Require Import program programassem programassemcorrect imp call.
Require Import reader SPred septac pointsto spec spectac basic reg.
Require Import cursor safe instrrules.
Require Import instr instrsyntax macros Ascii bitsops bitsprops bitsopsprops.
Require Import screenspec screenimp lifeimp.

Open Scope instr_scope.
Local Transparent ILFun_Ops.

Definition codeAddr:DWORD := #x"00300000".

Definition Cgcd :=
  Cseq (Cassign xa (eliteral #100)) (
  Cseq (Cassign xb (eliteral #60)) ( (* their GCD is 20, which is octal 024 *)
  Cwhile (esubtract xa xb) (
    Cif (elessthan xa xb) (
      Cassign xb (esubtract xb xa)
    ) (
      Cassign xa (esubtract xa xb)
    )
  )
  )).

(* TODO: stronger spec *)
Lemma Cgcd_correct:
  |-- triple ltrue Cgcd ltrue.
Proof.
  eapply triple_seq.
  - eapply triple_roc; [|done|apply triple_assign].
    apply subst_true_special_case.
  eapply triple_seq.
  - eapply triple_roc; [|done|apply triple_assign].
    apply subst_true_special_case.
  eapply triple_roc; last apply triple_while.
  - reflexivity.
  - done.
  eapply triple_roc; last apply triple_if.
  - reflexivity.
  - reflexivity.
  - eapply triple_roc; last apply triple_assign; last reflexivity.
    move=> s H. apply I.
  - eapply triple_roc; last apply triple_assign; last reflexivity.
    move=> s H. apply I.
Qed.

Definition gcd_program : program := compile_cmd Cgcd.

Definition gcd_bytes := assemble codeAddr gcd_program.

Definition screenAddr: DWORD := screenBase +# numCols*2*34.
Definition rightpos: DWORD := screenAddr +# (2*(11-1)).
Definition showOctal_program : program :=
    (* A 32-bit octal number can take up 11 digits. Each digit is two bytes. *)
      (* Print EAX in octal, stepping on EBX AND EDX *)
      MOV EBX, rightpos;;
      MOV ECX, 3;;
      while (TEST EAX, EAX) CC_Z false ( (* while EAX <> 0 *)
        MOV EDX, 7;; (* bit mask *)
        AND EDX, EAX;;
        ADD EDX, nat_of_ascii "0";;
        MOV [EBX], DL;; (* write to screen *)
        SHR EAX, 3;; (* shift right *)
        SUB EBX, 2(* move one character left on the screen *)
      ).

Theorem gcd_safe: forall endAddr: DWORD,
  |-- (safe @ (EIP ~= endAddr) -->> safe @ (EIP ~= codeAddr))
        @ (EAX? ** EBX? ** ECX? ** EDX? ** OSZCP?)
       <@ (codeAddr -- endAddr :-> gcd_bytes).
Proof.
  move=> endAddr. rewrite /gcd_bytes.
  rewrite ->assemble_correct; last first. by vm_compute.
  rewrite /gcd_program.
  have H := Cgcd_correct. rewrite /triple in H. autorewrite with push_at in H.
  specapply H.
  - ssimpl. rewrite /asn_denot /stack_denot. rewrite /stateIsAny.
    sdestructs => a b c.
    pose s x := match x with | xa => a | xb => b | xc => c end.
    ssplit. instantiate (2:=s). ssplit; first done. rewrite /s. by ssimpl.
  rewrite <-spec_reads_frame. apply limplValid. autorewrite with push_at.
  cancel1. rewrite /asn_denot /stack_denot /stateIsAny. by sbazooka.
Qed.

(* This is the plain version of the theorem, not obscured by fancy spec logic
   constructs. *)
(*
Corollary gcd_safe_nonfancy: forall (endAddr: DWORD) k R,
  safe k (EIP ~= endAddr ** EAX? ** EBX? ** ECX? ** EDX? ** OSZCP? **
          codeAddr -- endAddr :-> gcd_bytes ** R) ->
  safe k (EIP ~= codeAddr ** EAX? ** EBX? ** ECX? ** EDX? ** OSZCP? **
          codeAddr -- endAddr :-> gcd_bytes ** R).
Proof.
  move=> endAddr k R.
  pose proof (gcd_safe endAddr). rewrite ->spec_reads_entails_at in H; [|apply _].
  autorewrite with push_at in H.
  apply landAdj in H. lforwardL H.
  - apply landR; [apply ltrueR|done].
  specialize (H k R). unfold "|--" in H.
Qed.
*)

Definition gcdEx : option (seq BYTE) :=
  assemble codeAddr (
  gcd_program;;
    clsProg;;
    showOctal_program;;
(*
    oneStepScreen;;
    MOV ECX, 10;; MOV EDX, 10;;
    makeGlider;;
        delay;;
    MOV ECX, 20;; MOV EDX, 20;;
    makeGlider;;
        delay;;
        oneStepScreen;;
*)
    LOCAL busy;
(*      busy:;;*)
        JMP busy
  ).


From stdpp Require Import base.
From iris.algebra Require Export cmra.

Section CommAssocTac.

Context {M: Type}.
Context `{!Op M}.
Context `{!Equiv M}.
Context `{!Assoc (≡) (op: M -> M -> M)}.
Context `{!Comm (≡) (op: M -> M -> M)}.
Context `{!Transitive ((≡) : M -> M -> Prop)}.
Context `{!Symmetric ((≡) : M -> M -> Prop)}.
Context `{!Reflexive ((≡) : M -> M -> Prop)}.
Context `{!Proper ((≡) ==> (≡) ==> (≡)) (op: M -> M -> M)}.

Lemma do_comm (a b : M)
  : (a ⋅ b) ≡ (b ⋅ a). apply Comm0. Qed.

Lemma do_assoc (a b c : M)
  : (a ⋅ (b ⋅ c)) ≡ ((a ⋅ b) ⋅ c). apply Assoc0. Qed.

Lemma comm2 (a b c : M)
  : (a ⋅ b) ⋅ c ≡ (a ⋅ c) ⋅ b.
Proof. setoid_rewrite <- do_assoc.
  setoid_replace (b ⋅ c) with (c ⋅ b) by (apply do_comm).
  trivial. Qed.

Lemma from_r (a b x : M)
  : a ≡ b -> (a ⋅ x) ≡ (b ⋅ x).
Proof. intro. setoid_rewrite H. trivial. Qed.

Lemma from_1 (a b x : M)
  : a ≡ b -> (x ⋅ a) ≡ (b ⋅ x).
Proof. intro. setoid_rewrite H. apply do_comm. Qed.

Lemma from_2_r (a b a1 b1 x : M)
  : (a1 ⋅ a) ≡ (b1 ⋅ b) -> ((a1 ⋅ x) ⋅ a) ≡ ((b1 ⋅ b) ⋅ x).
Proof. intro.
  setoid_replace (a1 ⋅ x ⋅ a) with (a1 ⋅ a ⋅ x) by (apply comm2).
  apply from_r. trivial. Qed.

Lemma from_2_l (a b a1 b1 x : M)
  : (a1 ⋅ a) ≡ (b1 ⋅ b) -> ((x ⋅ a1) ⋅ a) ≡ ((b1 ⋅ b) ⋅ x).
Proof. intro.
  setoid_replace (x ⋅ a1) with (a1 ⋅ x) by (apply do_comm).
  apply from_2_r. trivial.
Qed.

Lemma from_3_r (a b a1 b1 a2 b2 x : M)
  : ((a2 ⋅ a1) ⋅ a) ≡ ((b2 ⋅ b1) ⋅ b) -> ((a2 ⋅ x) ⋅ a1) ⋅ a ≡ ((b2 ⋅ b1) ⋅ b) ⋅ x.
Proof. intro.
  setoid_replace (a2 ⋅ x ⋅ a1) with (a2 ⋅ a1 ⋅ x) by (apply comm2).
  apply from_2_r. trivial.
Qed.

Lemma from_3_l (a b a1 b1 a2 b2 x : M)
  : ((a2 ⋅ a1) ⋅ a) ≡ ((b2 ⋅ b1) ⋅ b) -> ((x ⋅ a2) ⋅ a1) ⋅ a ≡ ((b2 ⋅ b1) ⋅ b) ⋅ x.
Proof. intro.
  setoid_replace (x ⋅ a2) with (a2 ⋅ x) by (apply do_comm).
  apply from_3_r. trivial.
Qed.

Lemma from_4_r (a b a1 b1 a2 b2 a3 b3 x : M)
  : a3 ⋅ a2 ⋅ a1 ⋅ a ≡ b3 ⋅ b2 ⋅ b1 ⋅ b
    -> a3 ⋅ x ⋅ a2 ⋅ a1 ⋅ a ≡ b3 ⋅ b2 ⋅ b1 ⋅ b ⋅ x.
Proof. intro.
  setoid_replace (a3 ⋅ x ⋅ a2) with (a3 ⋅ a2 ⋅ x) by (apply comm2).
  apply from_3_r. trivial.
Qed.

Lemma from_4_l (a b a1 b1 a2 b2 a3 b3 x : M)
  : a3 ⋅ a2 ⋅ a1 ⋅ a ≡ b3 ⋅ b2 ⋅ b1 ⋅ b
    -> x ⋅ a3 ⋅ a2 ⋅ a1 ⋅ a ≡ b3 ⋅ b2 ⋅ b1 ⋅ b ⋅ x.
Proof. intro.
  setoid_replace (x ⋅ a3) with (a3 ⋅ x) by (apply do_comm).
  apply from_4_r. trivial.
Qed.

Lemma from_5_r (a b a1 b1 a2 b2 a3 b3 a4 b4 x : M)
  : a4 ⋅ a3 ⋅ a2 ⋅ a1 ⋅ a ≡ b4 ⋅ b3 ⋅ b2 ⋅ b1 ⋅ b
    -> a4 ⋅ x ⋅ a3 ⋅ a2 ⋅ a1 ⋅ a ≡ b4 ⋅ b3 ⋅ b2 ⋅ b1 ⋅ b ⋅ x.
Proof. intro.
  setoid_replace (a4 ⋅ x ⋅ a3) with (a4 ⋅ a3 ⋅ x) by (apply comm2).
  apply from_4_r. trivial.
Qed.

Lemma from_5_l (a b a1 b1 a2 b2 a3 b3 a4 b4 x : M)
  : a4 ⋅ a3 ⋅ a2 ⋅ a1 ⋅ a ≡ b4 ⋅ b3 ⋅ b2 ⋅ b1 ⋅ b
    -> x ⋅ a4 ⋅ a3 ⋅ a2 ⋅ a1 ⋅ a ≡ b4 ⋅ b3 ⋅ b2 ⋅ b1 ⋅ b ⋅ x.
Proof. intro.
  setoid_replace (x ⋅ a4) with (a4 ⋅ x) by (apply do_comm).
  apply from_5_r. trivial.
Qed.

End CommAssocTac.

Ltac solve_assoc_comm :=
  repeat (setoid_rewrite do_assoc); trivial;
  repeat (
    try apply from_r; trivial;
    try apply do_comm; trivial;
    try apply from_1; trivial;
    try apply from_2_l; trivial;
    try apply from_2_r; trivial;
    try apply from_3_l; trivial;
    try apply from_3_r; trivial;
    try apply from_4_l; trivial;
    try apply from_4_r; trivial;
    try apply from_5_r; trivial;
    try apply from_5_r; trivial
  ).

(*Lemma abcde_state (a b c d e : M)
  : a ⋅ b ⋅ (c ⋅ (d ⋅ e)) ≡ a ⋅ d ⋅ (b ⋅ c ⋅ e).
Proof. solve_assoc_comm.*)

(*Lemma test (a b c d e : M)
  : a ⋅ (b ⋅ c) ⋅ (d ⋅ e) ≡ (b ⋅ e) ⋅ ((c ⋅ d) ⋅ a).
Proof. solve_assoc_comm. *)


(** * General recursive functions

  This file explores a way to formalize general recursive functions
  without worrying about termination proofs, counters or monads.

  The definitions are actually defined by well-founded recursion on the
  total relation (which isn't well-founded).  Using fueling of the
  accessibility proof, we can however compute with these definitions
  inside Coq and reason on them independently of the termination
  proof. *)

(* begin hide *)
(** printing elimination %\coqdoctac{elimination}% *)
(** printing noconf %\coqdoctac{noconf}% *)
(** printing simp %\coqdoctac{simp}% *)
(** printing by %\coqdockw{by}% *)
(** printing rec %\coqdockw{rec}% *)
(** printing Coq %\Coq{}% *)
(** printing funelim %\coqdoctac{funelim}% *)
(** printing Derive %\coqdockw{Derive}% *)
(** printing Signature %\coqdocclass{Signature}% *)
(** printing Subterm %\coqdocclass{Subterm}% *)
(** printing NoConfusion %\coqdocclass{NoConfusion}% *)
From Equations Require Import Equations.
Require Import ZArith Lia.
Require Import Program.
Require Import Psatz.
Require Import NPeano.
Require Import Nat.
Require Import Coq.Vectors.VectorDef.
Require Import Relations.

Set Keyed Unification.
Set Equations Transparent.
(* end hide *)

(** The total relation. *)
Definition total_relation {A : Type} : A -> A -> Prop := fun x y => True.

(** We assume an inconsistent axiom here, one should be added function per function. *)
Axiom wf_total_init : forall {A}, WellFounded (@total_relation A).
#[local]
Remove Hints wf_total_init : typeclass_instances.

(** We fuel it with some Acc_intro constructors so that definitions relying on it
    can unfold a fixed number of times still. *)
#[local]
Instance wf_total_init_compute : forall {A}, WellFounded (@total_relation A).
  exact (fun A => Acc_intro_generator 10 wf_total_init).
Defined.

(** Now we define an obviously non-terminating function. *)
Equations? nonterm (n : nat) : nat by wf n (@total_relation nat) :=
  nonterm 0 := 0;
  nonterm (S n) := S (nonterm (S n)).
Proof.
  (* Every pair of arguments is in the total relation: so
     [total_relation (S n) (S n)] *) red.
  constructor.
Defined.
  Obligation Tactic := idtac.
  (** The automation has a little trouble here as it assumes
      well-founded definitions implicitely.  We show the second
      equation: [nonterm (S n) = S (nonterm (S n))] using the
      unfolding equation. *)
  Next Obligation.
    intros. now rewrite nonterm_unfold_eq at 1.
  Defined.

  (* Note this is a dangerous rewrite rule, so we should remove it from the hints *)
  (* Print Rewrite HintDb nonterm. *)

  (** Make nonterm transparent anyway so we can compute with it *)
  Transparent nonterm.

(** We can compute with it (for closed natural numbers) *)
Definition at_least_five (n : nat) : bool :=
  match n with
  | S (S (S (S (S x)))) => true
  | _ => false
  end.

Transparent wf_total_init_compute.

(** Indeed it unfolds enough so that [at_least_five] gives back a result. *)

Example check_10 := eq_refl : at_least_five (nonterm 10) = true.
Example check_0 := eq_refl : at_least_five (nonterm 0) = false.

(** The elimination principle completely abstracts away from the
    termination argument as well *)
Lemma nonterm_ge n : n <= nonterm n.
Proof.
  funelim (nonterm n).
  reflexivity.
  lia.
Defined.

(** We can go as far as defining the (call-by-name) Y combinator and computing with it. *)
Section Y.
  Context {A : Type}.
  Equations? Y (f : A -> A) : A by wf f (@total_relation (A -> A)) :=
  Y f := f (Y f).
  Proof.
    (* Every pair of arguments is in the total relation: so
     [total_relation f f] *) red. constructor.
  Defined.

  Obligation Tactic := idtac.
  (** The automation has a little trouble here as it assumes
      well-founded definitions implicitely.  We show the second
      equation: [nonterm (S n) = S (nonterm (S n))] using the
      unfolding equation. *)
  Next Obligation.
    intros. now rewrite Y_unfold_eq at 1.
  Defined.
End Y.

(** Using [Y], we can easily define any general recursive function. *)
Definition fact :=
  Y (fun (fact : nat -> nat) (x : nat) =>
       match x with
       | 0 => 1
       | S n => S n * fact n
       end).
Check eq_refl : fact 8 = 40320.

(** [Y] is only good in call-by-name or call-by-need, so we switch to Haskell *)

Extraction Language Haskell.
Recursive Extraction fact.

(*
y :: (a1 -> a1) -> a1
y x =
  x (y x)

fact :: Nat -> Nat
fact =
  y (\fact0 x -> case x of {
                  O -> S O;
                  S n -> mul (S n) (fact0 n)})

*)

(** Let's define an efficient version whose termination is not entirely obvious. *)
Definition factN :=
  Y (fun (fact : N -> N) (x : N) =>
       match x with
       | N0 => 1%N
       | Npos n => (Npos n * fact (Pos.pred_N n))%N
       end).

(** [1001!] is pretty large. *)
Definition fact1001 :=
 402789647337170867317246136356926989705094239074925347176343710340368450911027649612636252695456374205280468598807393254690298539867803367460225153499614535588421928591160833678742451354915921252299285456946271396995850437959540645019696372741142787347450281325324373824456300226871609431497826989489109522725791691167945698509282421538632966523376679891823696900982075223188279465194065489111498586522997573307838057934994706212934291477882221464914058745808179795130018969175605739824237247684512790169648013778158661520384916357285547219660337504067910087936301580874662367543921288988208261944834178369169805682489420504038334529389177845089679546075023305854006141256288633820079940395329251563788399404652902154519302928365169452383531030755684578503851488154092323576150311569325891190105926118761607100286827930472944913272420825078912158741589850136017030887975452922434889688775883386977825215904423682478943313806072144097432418695807412571292308739802481089407002523955080148184062810447564594783139830113821372260474145316521647368313934670783858482781506915288378941348078689691815657785305896912277993200639858696294199549107738635599538328374931258525869323348477334798827676297868823693023377418942304272267800509765805435653787530370118261219994752588866451072715583785495394684524593296728611334955079882857173250037068541860372512693170819259309411027837176612444692649174536429745421086287708588130082168792750697158901737130221751430550976429258055277255676893874108456870904122902259417224707137723406125811549952159629766771063079472679280213882978523785424760309678138268708239764925768714349554665438389311198715040908077757086900159389712443987670244241787904585093011546861502058550090914877900852701619648229332192401075747543562989953271508977501771085759521631427816116191761031257454497039673414248149210836002497114107565960458576525212556159634975715552638678172137468172843066451093984443636560722213668172225585711566558134467392654185460222589723312097599987253417831473939565071006344352518096564427781204200068323913056897090916602712260306869786107237077572445866572945760977721639408338430009976028970539150822336553856613962747814621747092348996915755983464741082000337526945990059365493439921937093368896754791416759604324895514660325913157843796039917819613717350380997781225472000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000%N.

(** We can still compute with our [Y] combinator *)
Time Check (@eq_refl _ (fact1001) <: factN 1001 = fact1001).

(** It takes [0.8sec] using [vm_compute]. *)

(** An alternative is to use the total relation directly. *)

Equations factN' (n : N) : N by wf n (@total_relation N) :=
| N0 => 1;
| Npos n => (Npos n * factN' (Pos.pred_N n)).
Next Obligation. constructor. Defined.

(** Unsurprisingly, this computes just as well *)

Time Check (@eq_refl _ (fact1001) <: factN' 1001 = fact1001).

(** It takes [0.8sec] using [vm_compute] as well. *)

(** [factN'] also makes sense in a strict/call-by-value language like OCaml. *)

Extraction Language OCaml.
Extraction factN'.

(*

(** val factN' : n -> n **)

let rec factN' = function
| N0 -> Npos XH
| Npos p -> N.mul (Npos p) (let y = Pos.pred_N p in factN' y)

*)


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition rvic_clear_flag_spec (intid: Z64) (bitmap: Pointer) (adt: RData) : option RData :=
    match intid with
    | VZ64 intid =>
      rely is_int64 intid;
      let idx := intid / 64 in
      let bit := intid mod 64 in
      let slot := offset bitmap in
      rely prop_dec (0 <= slot < 16);
      rely prop_dec (0 <= idx < 512);
      when gidx == ((buffer (priv adt)) @ slot);
      let gn := (gs (share adt)) @ gidx in
      rely g_tag (ginfo gn) =? GRANULE_STATE_REC;
      rely prop_dec (glock gn = Some CPU_ID);
      if peq (base bitmap) rvic_pending_loc then
        let bits := (r_pending_bits (g_rvic (gnorm gn))) @ idx in
        let bits' := Z.land bits (Z.lnot (Z.shiftl 1 bit)) in
        let rvic' := (g_rvic (gnorm gn)) {r_pending_bits: (r_pending_bits (g_rvic (gnorm gn))) # idx == bits'} in
        let g' := gn {gnorm: (gnorm gn) {g_rvic: rvic'}} in
        Some adt {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}
      else
        let bits := (r_mask_bits (g_rvic (gnorm gn))) @ idx in
        let bits' := Z.land bits (Z.lnot (Z.shiftl 1 bit)) in
        let rvic' := (g_rvic (gnorm gn)) {r_mask_bits: (r_mask_bits (g_rvic (gnorm gn))) # idx == bits'} in
        let g' := gn {gnorm: (gnorm gn) {g_rvic: rvic'}} in
        Some adt {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}
    end.

End Spec.


(* 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: SameSumLeaves.v

    Definition of the equality of sum leaves

    Definition: same_sum_leaves

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

From Huffman Require Export Cover.
From Huffman Require Export WeightTree.

Section SameSumLeaves.
Variable A : Type.
Variable f : A -> nat.

(* the sum leaves are the same upto permutation *)
Definition same_sum_leaves (l1 l2 : list (btree A)) : Prop :=
  exists l3 : list (btree A),
    (exists l4 : list (btree A),
       permutation l1 l3 /\
       permutation l2 l4 /\ map (sum_leaves f) l3 = map (sum_leaves f) l4).

(* if the sum leaves are the same, the list are of same length *)
Theorem same_sum_leaves_length :
 forall l1 l2 : list (btree A),
 same_sum_leaves l1 l2 -> length l1 = length l2.
Proof using.
intros l1 l2 (l3, (l4, (H0, (H1, H2)))).
rewrite (permutation_length _ _ _ H0).
rewrite (permutation_length _ _ _ H1).
repeat rewrite <- (length_map _ _ (sum_leaves f)); auto.
apply f_equal with (f := length (A:=nat)); auto.
Qed.

End SameSumLeaves.
Arguments same_sum_leaves [A].