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 tt 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 *. lia.
      * 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 *.
          lia.
          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 List.
Require Import Arith.Plus.
Require Import ZArith.
Require Import FunctionalExtensionality.
Require Import Setoid.

Require Import Terms.
Require Import Equivalence.
Require Import Transformations.

Definition good_continuation (k:Cont) (s:list var) :=
  forall (f:var) (t:Ctriv) (s':list var),
    CtrivValid t s' s -> CexpValid (k f t) s'.

Hint Unfold good_continuation.

Theorem cps_transform_valid :
  forall r:Droot, CrootValid (cps_transform r).
Proof.
apply (Droot_mut (fun r => CrootValid (cps_transform r))
                 (fun e => forall (k:Cont) (f:var) (s:list var),
                             good_continuation k s ->
                             CexpValid (cps_exp_transform f e k) s)
                 (fun t => forall (s:list var), CtrivValid (cps_triv_transform t) s s));
intros; unfold good_continuation in *; simpl; eauto.
Qed.

(* Main development below *)

Lemma equal_arguments :
  forall {A B:Type} (f:A -> B) (x y:A), x = y -> f x = f y.
Proof.
intros; eauto.
rewrite H; auto.
Qed.

Lemma length_zero_is_nil :
  forall {A:Type} (es:list A), length es = 0 -> es = nil.
Proof.
intros A es H.
destruct es as [| x xs].
trivial.
simpl in H.
inversion H.
Qed.

Definition is_app (e:Dexp) : Prop :=
match e with
| Dexp_app _ _ => True
| Dexp_triv _  => False
end.

Definition is_app_list (es:list Dexp) : Prop :=
  Forall is_app es.

Definition nice_continuation (k:Cont) :=
  (forall (v n n' v0 v1:var), rename_exp_v v (k n (Ctriv_vvar v0)) = rename_exp_v v (k n' (Ctriv_vvar v1))) /\
  (forall (v n n':var) (t:Ctriv), rename_exp_v v (k n t) = rename_exp_v v (k n' t)).

Ltac destruct_exists :=
repeat match goal with
| [ H : exists _, _ |- _ ] => destruct H
end.

Ltac nice_cont := unfold nice_continuation; split; intros; simpl; eauto.

Ltac level_down :=
  apply equal_arguments; try (apply equal_arguments);
   try (apply functional_extensionality; intros); try (apply functional_extensionality; intros).

Lemma continuation_rename_0 :
  forall (e:Dexp) (k:Cont) (f v:var), nice_continuation k ->
    rename_exp_v v (cps_exp_transform f e k) =
    rename_exp_v v (cps_exp_transform 0 e (fun _ t => rename_exp_v v (k 0 t))).
Proof.
induction e; intros; unfold nice_continuation in H; simpl; intuition;
[rewrite IHe1; [symmetry; rewrite IHe1; [
      level_down
    | idtac]
  | idtac];

  repeat (simpl in *; match goal with
  | |- context[rename_exp_v _ (cps_exp_transform _ _ (fun f _ => Cexp_app _ _ f _)) =
               rename_exp_v _ (cps_exp_transform _ _ (fun g _ => Cexp_app _ _ g _))] =>
    (rewrite IHe2; [ symmetry; rewrite IHe2; [simpl; level_down | idtac] | idtac ])
  | |- context[rename_exp_v _ (rename_exp_v _ _)] => rewrite rename_exp_v_inv
  | |- nice_continuation _ => nice_cont
  | |- context [rename_exp_v _ (_ ?N (Ctriv_vvar ?V0))] => rewrite H0 with (n := N) (v0 := V0) (n' := 0) (v1 := 0)
  end; simpl in *; eauto)
| idtac ].

rewrite rename_exp_v_inv.
symmetry; rewrite H1 with (n' := f); auto.
Qed.

Ltac a_exp_eq_crusher :=
simpl; match goal with
| |- rename_exp_v _ (cps_exp_transform _ _ _) = rename_exp_v _ (cps_exp_transform _ _ _) =>
  rewrite continuation_rename_0; [ symmetry;
                                   rewrite continuation_rename_0;
                                   [level_down | idtac ] | idtac ]; idtac
| |- nice_continuation _ => nice_cont; idtac
end.

Lemma app_produces_vvar :
  forall (e:Dexp) (k:Cont) (v f f':var), is_app e -> nice_continuation k ->
    rename_exp_v v (cps_exp_transform f e k) =
    rename_exp_v v (cps_exp_transform f e (fun _ _ => k f' (Ctriv_vvar v))).
Proof.
destruct e; simpl in *; unfold nice_continuation; intros; eauto; intuition.
assert (forall v n v0:var, rename_exp_v v (k n (Ctriv_vvar v0)) =
                            rename_exp_v v (k 0 (Ctriv_vvar 0))) as R by eauto.

repeat (simpl in *; a_exp_eq_crusher); simpl; repeat (rewrite R; symmetry; eauto).
Qed.

Definition mold (rest:Cexp) (e:Dexp) : Cexp :=
  cps_exp_transform 0 e (fun _ t => rest).

Lemma fold_left_is_right :
  forall (ds:list Dexp) (c c':Cexp), a_exp_eq c c' -> a_exp_eq (fold_left mold ds c) (fold_left mold ds c').
Proof.
induction ds; intros; unfold a_exp_eq in *; simpl; eauto.
rewrite IHds with (c' := (mold c' a)); auto.
unfold mold; simpl.
rewrite continuation_rename_0; [ symmetry; rewrite continuation_rename_0; [ rewrite H; auto | nice_cont] | nice_cont ].
Qed.

Lemma has_exactly_one_element :
  forall {A:Type} (es:list A), length es = 1 -> exists a:A, es = a :: nil.
Proof.
intros A es H; destruct es as [|x xs]; auto.
inversion H.
exists x.
simpl in H.
assert (length xs = 0).
replace (length xs) with (pred (S (length xs))).
replace 0 with (pred (S 0)).
rewrite H.
trivial.
trivial.
trivial.
destruct xs; auto.
inversion H0.
Qed.

Lemma has_two_elements :
  forall {A:Type} (es:list A) (n:nat), length es = S (S n) ->
         exists (a b:A), exists es':list A, es = a::b::es'.
Proof.
intros.
destruct es; simpl in *; eauto.
inversion H.
destruct es.
simpl in H; inversion H.
destruct es.
exists a.
exists a0.
exists nil.
trivial.
exists a; exists a0; exists (a1::es); trivial.
Qed.

Lemma start_irrevelant :
  forall (e:Dexp) (k:Cont) (v f f':var), nice_continuation k ->
    rename_exp_v v (cps_exp_transform f e k) = rename_exp_v v (cps_exp_transform f' e k).
Proof.
intros.
rewrite continuation_rename_0 with (f := f); auto.
rewrite continuation_rename_0 with (f := f'); auto.
Qed.

Ltac cont_rename := rewrite continuation_rename_0; [ idtac | nice_cont ].

Theorem cps_inverse_exists :
  forall r:Croot, CrootValid r -> exists r':Droot, a_eq (cps_transform r') r.
Proof.
apply (CrootValid_mut
         (fun r rv => exists r':Droot, a_eq (cps_transform r') r)
         (fun t l0 l1 tv => ((exists e, l0 = e::l1) /\ (exists v, t = Ctriv_vvar v)) \/
                            (exists e, a_triv_eq (cps_triv_transform e) t /\ l0 = l1))
         (fun e l ev => forall (f:var) (es:list Dexp),
           length l = length es -> is_app_list es ->
           exists e':Dexp,
             a_exp_eq (cps_exp_transform f e' (fun _ t => Cexp_cont t))
             (fold_left mold es e)))
;intros; eauto; simpl in *.

(* Croot case *)
specialize (H 0 nil).
simpl in H.
specialize (H eq_refl (Forall_nil is_app)).
destruct H.
exists (Droot_exp x).
simpl.
unfold a_eq.
unfold a_exp_eq in H.
simpl.
rewrite H.
trivial.

(* Ctriv_var case *)
right.
exists (Dtriv_var x).
simpl; split; unfold a_triv_eq; simpl; auto.

(* Ctriv_lam case *)
right.
destruct H as [r'].
exists (Dtriv_lam x r').
unfold a_eq in H; simpl in H.
unfold a_triv_eq; split; simpl; auto.
rewrite H; trivial.

(* Cexp_cont case *)
destruct H.
destruct H.
destruct H.
destruct H2.
subst.
simpl in H0.
symmetry in H0.
specialize (has_exactly_one_element es H0); intros.
destruct H as [d]; subst.

exists d.
unfold mold; simpl.
inversion c; subst.
unfold a_exp_eq.
rewrite app_produces_vvar with (e := d) (v := 0) (f := f) (f' := 0).
rewrite continuation_rename_0 with (v := 0) (f := 0).
rewrite continuation_rename_0 with (v := 0) (f := f).
simpl; auto.
nice_cont.
nice_cont.

unfold is_app_list in H1.
inversion H1; subst.
assert (nice_continuation (fun (_:var) t => Cexp_cont t)).
nice_cont.
auto.
nice_cont.
destruct H.
exists (Dexp_triv x).
unfold a_exp_eq; simpl.
destruct H.
subst.
unfold a_triv_eq in H.
rewrite H.
symmetry in H0.
specialize (length_zero_is_nil es H0); intros; subst.
simpl; auto.

(* Cexp_app case *)
intuition; destruct_exists; subst; simpl in *; symmetry in H2.
(* v v case *)
specialize (has_two_elements es (length ksi2) H2); intros; destruct_exists; subst; simpl in *.
specialize (H1 f (Dexp_app x4 x3::x5)).
simpl in H1.
inversion H2.
rewrite H0 in H1.
specialize (H1 eq_refl).

assert (is_app_list (Dexp_app x4 x3 :: x5)).
constructor; simpl; eauto.
inversion H3; subst.
inversion H6; subst.
trivial.

specialize (H1 H).
destruct H1 as [e'].
exists e'.
unfold a_exp_eq in *.
rewrite H1.
apply fold_left_is_right.
unfold a_exp_eq; simpl.

unfold mold; simpl.
assert (forall t0:Ctriv, nice_continuation (fun f1 t1 => Cexp_app t0 t1 f1 e)) by nice_cont.
assert (nice_continuation (fun f0 t0 => cps_exp_transform f0 x3
                             (fun f1 t1 => Cexp_app t0 t1 f1 e))).
nice_cont.
cont_rename.
symmetry.
cont_rename.
level_down; simpl; auto.

rewrite start_irrevelant with (f' := n'); auto.
rewrite continuation_rename_0 with (e := x4) (f := 1); [ idtac | eauto; nice_cont ].
rewrite app_produces_vvar with (f' := 0).
rewrite app_produces_vvar with (f' := 0) (e := x3).
rewrite continuation_rename_0 with (e := x3); [ idtac | eauto; nice_cont ].
symmetry.
rewrite continuation_rename_0 with (e := x4); [ idtac | eauto; nice_cont ].
rewrite continuation_rename_0 with (e := x3); [ idtac | eauto; nice_cont ].
simpl.
auto.

unfold is_app_list in H3.
inversion H3.
auto.

nice_cont.

unfold is_app_list in H3.
inversion H3.
inversion H9; auto.

nice_cont.
rewrite rename_exp_v_inv.
rewrite rename_exp_v_inv.

rewrite continuation_rename_0.
symmetry.
rewrite continuation_rename_0.
simpl.
auto.

nice_cont.
nice_cont.

(* v t case *)
destruct H0; subst.
destruct es; [inversion H2 | idtac]; simpl in *.
specialize (H1 f (Dexp_app (Dexp_triv x) d::es)).
inversion H2.
simpl in H1; rewrite H4 in H1.
specialize (H1 eq_refl).

inversion H3; subst.
assert (is_app_list (Dexp_app (Dexp_triv x) d :: es)).
constructor; simpl; eauto.

specialize (H1 H0).
destruct H1 as [e'].
exists e'.
unfold a_exp_eq in *.
rewrite H1.
apply fold_left_is_right.
unfold mold.
unfold a_exp_eq.

assert (nice_continuation (fun _ _ => Cexp_app t0 (Ctriv_vvar x0) v e)) by nice_cont.

simpl.
cont_rename.
symmetry.
cont_rename.
simpl.
unfold a_triv_eq in H; rewrite H; auto.

symmetry.
rewrite app_produces_vvar with (f' := 0).
simpl; auto.
auto.
nice_cont.

(* t v case *)
destruct H4; subst.
destruct es; [inversion H2 | idtac]; simpl in *.
specialize (H1 f (Dexp_app d (Dexp_triv x1) ::es)).
inversion H2.
simpl in H1; rewrite H4 in H1.
specialize (H1 eq_refl).

inversion H3; subst.
assert (is_app_list (Dexp_app d (Dexp_triv x1) :: es)).
constructor; simpl; eauto.

specialize (H1 H0).
destruct H1 as [e'].
exists e'.
unfold a_exp_eq in *.
rewrite H1.
apply fold_left_is_right.
unfold mold.
unfold a_exp_eq.

assert (nice_continuation (fun _ _ => Cexp_app t1 (Ctriv_vvar x0) v e)) by nice_cont.

simpl.
cont_rename.
symmetry.
cont_rename.
simpl.

unfold a_triv_eq in H.
symmetry.
rewrite app_produces_vvar with (f' := 0).
simpl; auto.
rewrite <- H.
simpl; eauto.
auto.
nice_cont.

destruct H0; destruct H; subst.
rewrite <- H2 in H1.
specialize (H1 f (Dexp_app (Dexp_triv x) (Dexp_triv x0) :: es) eq_refl).

assert (is_app_list (Dexp_app (Dexp_triv x) (Dexp_triv x0) :: es)).
constructor; simpl; eauto.

specialize (H1 H4).
destruct H1 as [e'].
exists e'.
unfold a_exp_eq in *.
rewrite H1.
simpl.
unfold a_triv_eq in *.
apply fold_left_is_right.
unfold a_exp_eq; simpl.
rewrite H0.
rewrite H; auto.

Qed.


Require Import TM.Prelim.
Require Import TM.Code.Code.
Require Import Semantics.

(** * Alphabets *)

Inductive ACom : Type := retAT | lamAT | appAT.

Coercion ACom2Com (a : ACom) : Com :=
  match a with
  | retAT => retT
  | lamAT => lamT
  | appAT => appT
  end.

Instance ACom_eq_dec : eq_dec ACom.
Proof. intros x y; hnf. decide equality. Defined.

Instance ACom_finType : finTypeC (EqType ACom).
Proof. split with (enum := [retAT; lamAT; appAT]). intros [ | | ]; cbn; reflexivity. Defined.

Instance ACom_inhab : inhabitedC ACom := ltac:(repeat constructor).

Instance Encode_ACom : codable ACom ACom := Encode_Finite (FinType(EqType ACom)).

Coercion Com_to_sum (t : Com) : (nat + ACom) :=
  match t with
  | varT x => inl x
  | appT => inr appAT
  | lamT => inr lamAT
  | retT => inr retAT
  end.

Definition sigCom := sigSum sigNat ACom.
Definition sigCom_fin := FinType (EqType sigCom).

Instance Encode_Com : codable sigCom Com :=
  {|
    encode x := encode (Com_to_sum x)
  |}.

Definition Encode_Com_size (t : Com) : nat :=
  size _ (Com_to_sum t).

Lemma Encode_Com_hasSize (t : Com) :
  size _ t = Encode_Com_size t.
Proof. reflexivity. Qed.

Definition sigHAdd := sigNat.
Definition sigHAdd_fin := FinType(EqType sigHAdd).

Definition sigPro := sigList sigCom.
Instance Encode_Prog : codable sigPro Pro := _.
Definition sigPro_fin := FinType(EqType sigPro).

Definition sigHClos := sigPair sigHAdd sigPro.
Definition sigHClos_fin := FinType(EqType sigHClos).
Instance Encode_HClos : codable sigHClos HClos := _.

Definition sigHEntr' := sigPair sigHClos sigHAdd.
Instance Encode_HEntr' : codable (sigHEntr') (HClos*HAdd) := _.
Definition sigHEntr'_fin := FinType(EqType sigHEntr').

Definition sigHEntr := sigOption sigHEntr'.
Instance Encode_HEntr : codable (sigHEntr) HEntr := _.
Definition sigHEntr_fin := FinType(EqType sigHEntr).

Definition sigHeap := sigList sigHEntr.
Instance Encode_Heap : codable (sigHeap) Heap := _.
Definition sigHeap_fin := FinType(EqType sigHeap).


Require Import Coq.Classes.Morphisms.
Require Import Coq.micromega.Lia.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.EnumEnsembles.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.graph_gen.
Require Import CertiGraph.graph.MathGraph.
Require Import CertiGraph.graph.FiniteGraph.

Section LstGraph.

  Context {Vertex: Type}.
  Context {Edge: Type}.
  Context {EV: EqDec Vertex eq}.
  Context {EE: EqDec Edge eq}.

  Class LstGraph (pg: PreGraph Vertex Edge) (out_edge: Vertex -> Edge): Prop :=
    {
      only_one_edge: forall x e, vvalid pg x -> (src pg e = x /\ evalid pg e <-> e = out_edge x);
      no_loop_path: forall x p, pg |= p is x ~o~> x satisfying (fun _ => True) -> p = (x, nil)
    }.

  Variable (g: PreGraph Vertex Edge).
  Context {out_edge: Vertex -> Edge}.
  Context (gLst: LstGraph g out_edge).

  Lemma lst_valid_path_unique: forall v p1 p2, valid_path g (v, p1) -> valid_path g (v, p2) -> length p1 <= length p2 -> exists p3, p2 = p1 ++ p3.
  Proof.
    intros. revert p1 H H1.
    apply (rev_ind (fun p1 => (valid_path g (v, p1) -> length p1 <= length p2 -> exists p3 : list Edge, p2 = p1 ++ p3))); intros.
    - exists p2. simpl. auto.
    - pose proof H1. apply valid_path_app in H3. destruct H3 as [? _]. apply H in H3.
      + destruct H3 as [p4 ?]. destruct p4.
        * rewrite app_nil_r in H3. subst p2. rewrite app_length in H2. simpl in H2. exfalso; intuition.
        * exists p4. subst p2. rewrite <- app_assoc. simpl. f_equal. f_equal. clear H H2. pose proof H1. pose proof H0. apply pfoot_split in H. apply pfoot_split in H2.
          assert (strong_evalid g x) by (apply (valid_path_strong_evalid _ _ _ _ H1); rewrite in_app_iff; right; intuition). destruct H3 as [? _].
          assert (strong_evalid g e) by (apply (valid_path_strong_evalid _ _ _ _ H0); rewrite in_app_iff; right; intuition). destruct H4 as [? [? _]]. rewrite <- H2 in H5.
          assert (x = out_edge (pfoot g (v, l))) by (apply only_one_edge; auto). assert (e = out_edge (pfoot g (v, l))) by (apply only_one_edge; auto).
          rewrite <- H6 in H7. auto.
      + rewrite app_length in H2. simpl in H2. intuition.
  Qed.

  Lemma lst_reachable_unique: forall v1 p1 v2 p2 x r1 r2 P,
      g |= (v1, p1) is x ~o~> r1 satisfying P -> g |= (v2, p2) is x ~o~> r2 satisfying P -> length p1 <= length p2 ->
      exists p3, p2 = p1 ++ p3 /\ g |= (r1, p3) is r1 ~o~> r2 satisfying P.
  Proof.
    intros. destruct H as [[? ?] ?]. destruct H0 as [[? ?] ?]. simpl in H, H0. subst v1 v2.
    pose proof H3. pose proof H5. destruct H as [? _]. destruct H0 as [? _]. destruct (lst_valid_path_unique _ _ _ H H0 H1) as [p3 ?]. clear H H0.
    exists p3. split; auto. split; [split |].
    - simpl. auto.
    - destruct p3.
      + rewrite app_nil_r in H6. subst p2. simpl. rewrite H2 in H4. auto.
      + rewrite H6 in H4. rewrite pfoot_app_cons with (v2 := r1) in H4. auto.
    - subst p2. apply good_path_app in H5. destruct H5 as [_ ?]. rewrite H2 in H. auto.
  Qed.

  Lemma lst_reachable_unique':
    forall p1 p2 x r1 r2 P, g |= p1 is x ~o~> r1 satisfying P -> g |= p2 is x ~o~> r2 satisfying P -> length (snd p1) <= length (snd p2) -> g |= r1 ~o~> r2 satisfying P.
  Proof.
    intros. destruct p1 as [v1 p1]. destruct p2 as [v2 p2]. simpl in H1. destruct (lst_reachable_unique v1 p1 v2 p2 x r1 r2 P H H0 H1) as [p3 [? ?]]. exists (r1, p3); auto.
  Qed.

  Lemma lst_src_dst_determine_path: forall p x y P, g |= p is x ~o~> y satisfying P -> unique (fun pa : path => g |= pa is x ~o~> y satisfying P) p.
  Proof.
    intros. hnf. split; auto. intros p2 ?. destruct p as [v1 p1]. destruct p2 as [v2 p2]. f_equal.
    - destruct H as [[? _] _]. destruct H0 as [[? _] _]. simpl in H, H0. subst v1 v2; auto.
    - destruct (Compare_dec.le_dec (length p1) (length p2)).
      + destruct (lst_reachable_unique v1 p1 v2 p2 x y y P H H0 l) as [p3 [? ?]].
        assert (g |= (y, p3) is y ~o~> y satisfying (fun _ => True)) by (apply reachable_by_path_weaken with P; auto; unfold Included, Ensembles.In; intros; auto).
        apply no_loop_path in H3. inversion H3. subst p3 p2. rewrite app_nil_r; auto.
      + assert (length p2 <= length p1) by intuition. rename H1 into l. destruct (lst_reachable_unique v2 p2 v1 p1 x y y P H0 H l) as [p3 [? ?]].
        assert (g |= (y, p3) is y ~o~> y satisfying (fun _ => True)) by (apply reachable_by_path_weaken with P; auto; unfold Included, Ensembles.In; intros; auto).
        apply no_loop_path in H3. inversion H3. subst p3 p1. rewrite app_nil_r; auto.
  Qed.

  Lemma lst_path_NoDup: forall p x y P, g |= p is x ~o~> y satisfying P -> NoDup (snd p).
  Proof.
    intros. destruct p as [v p]. simpl. destruct (ListDec.NoDup_dec EE p); auto. exfalso. destruct (Dup_cyclic _ n) as [e [p1 [p2 [p3 ?]]]]. subst p. clear n. simpl in H.
    pose proof H. apply reachable_by_path_app_cons in H0. destruct H0 as [? _]. replace (p1 ++ e :: p2 ++ e :: p3) with ((p1 ++ e :: p2) ++ e :: p3) in H.
    - apply reachable_by_path_app_cons in H. destruct H as [? _]. apply lst_src_dst_determine_path in H0. destruct H0. apply H1 in H. inversion H.
      rewrite <- (app_nil_r p1) in H3 at 1. apply app_inv_head in H3. inversion H3.
    - rewrite <- app_assoc. simpl. auto.
  Qed.

  Lemma lst_reachable_or: forall x r1 r2, reachable g x r1 -> reachable g x r2 -> reachable g r1 r2 \/ reachable g r2 r1.
  Proof.
    intros. destruct H as [p1 ?]. destruct H0 as [p2 ?]. destruct (Compare_dec.le_dec (length (snd p1)) (length (snd p2))); [left | right].
    - apply (lst_reachable_unique' p1 p2 x); auto.
    - apply (lst_reachable_unique' p2 p1 x); intuition.
  Qed.

  Lemma lst_self_loop: forall x y, dst g (out_edge x) = x -> reachable g x y -> x = y.
  Proof.
    intros. destruct H0 as [[v p] ?]. assert (v = x) by (destruct H0 as [[? _] _]; simpl in H0; auto). subst v. induction p.
    - destruct H0 as [[_ ?] _]. simpl in H0. auto.
    - assert (g |= (dst g a, p) is (dst g a) ~o~> y satisfying (fun _ => True)). {
        clear IHp. destruct H0 as [[? ?] [? ?]]. pose proof H2. apply valid_path_cons in H4. split; split; auto.
        - rewrite pfoot_cons in H1. auto.
        - rewrite path_prop_equiv; intros; auto. }
      assert (dst g a = x). {
        destruct H0 as [_ [? _]]. simpl in H0. destruct H0. assert (strong_evalid g a) by (destruct p; intuition). clear H2. destruct H3 as [? [? ?]]. rewrite <- H0 in H3.
        assert (a = out_edge x) by (apply only_one_edge; auto). rewrite <- H5 in H. auto.
      } apply IHp. rewrite H2 in H1. auto.
  Qed.

  Lemma lst_out_edge_only_one: forall x z y, dst g (out_edge x) = z -> reachable g x y -> ~ reachable g z y -> x = y.
  Proof.
    intros. apply reachable_ind.reachable_ind in H0. destruct H0; auto. destruct H0 as [z' [? [? ?]]]. hnf in H0. destruct H0 as [? [? ?]].
    rewrite step_spec in H5. destruct H5 as [e [? [? ?]]]. assert (e = out_edge x) by (apply only_one_edge; auto). rewrite <- H8 in H. rewrite H in H7.
    subst z'. exfalso; auto.
  Qed.

  Lemma dst_step: forall x pa, vvalid g x -> dst g (out_edge x) =  pa -> forall y, step g x y <-> y = pa.
  Proof.
    intros. subst pa. rewrite step_spec; split; intros.
    - destruct H0 as [e [? [? ?]]]. pose proof (only_one_edge x e H). simpl in H3. pose proof (proj1 H3 (conj H1 H0)). subst e. auto.
    - exists (out_edge x). subst y. pose proof (only_one_edge x (out_edge x) H). simpl in H0. assert ((out_edge x) = (out_edge x)) by auto. rewrite <- H0 in H1. intuition.
  Qed.

  Lemma vvalid_src_evalid: forall x, vvalid g x -> src g (out_edge x) = x /\ evalid g (out_edge x).
  Proof. intros. assert ((out_edge x) = (out_edge x)) by auto. pose proof (only_one_edge x (out_edge x) H). rewrite <- H1 in H0. auto. Qed.

  Lemma dst_not_reachable: forall x pa y, vvalid g x -> dst g (out_edge x) = pa -> reachable g pa y -> ~ reachable g y x.
  Proof.
    intros. intro. assert (g |= (x, (out_edge x) :: nil) is x ~o~> pa satisfying (fun _ => True)). {
      split; split; auto.
      - simpl. unfold strong_evalid. rewrite H0. pose proof (vvalid_src_evalid x H). destruct H3. rewrite H3.
        split; [|split; [|split]]; auto. apply reachable_head_valid in H1. auto.
      - red. rewrite Forall_forall. split; intros; auto.
    } assert (reachable g pa x) by (apply reachable_trans with y; auto). destruct H4 as [ppa ?].
    pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H3 H4). apply no_loop_path in H5. unfold path_glue in H5. simpl in H5. inversion H5.
  Qed.

  Lemma gen_dst_preserve_lst: forall x pa, ~ reachable g pa x -> vvalid g x -> LstGraph (pregraph_gen_dst g (out_edge x) pa) out_edge.
  Proof.
    intros. constructor. 1: simpl; apply only_one_edge. intro y; intros. destruct (in_dec EE (out_edge x) (snd p)).
    - destruct p as [p l]. simpl in i. apply (in_split_not_in_first EE) in i. destruct i as [l1 [l2 [? ?]]]. rewrite H2 in H1. apply reachable_by_path_app_cons in H1.
      destruct H1. simpl src in H1. simpl dst in H4. unfold updateEdgeFunc in H4. destruct (equiv_dec (out_edge x) (out_edge x)).
      2: compute in c; exfalso; apply c; auto. clear e. rewrite no_edge_gen_dst_equiv in H1. 2: simpl; auto.
      pose proof (vvalid_src_evalid x H0). destruct H5. rewrite H5 in H1. destruct (in_dec EE (out_edge x) l2).
      + apply (in_split_not_in_last EE) in i. destruct i as [l3 [l4 [? ?]]]. rewrite H7 in H4. apply reachable_by_path_app_cons in H4. destruct H4 as [_ ?].
        simpl in H4. unfold updateEdgeFunc in H4. destruct (equiv_dec (out_edge x) (out_edge x)). 2: compute in c; exfalso; apply c; auto. clear e.
        rewrite no_edge_gen_dst_equiv in H4. 2: simpl; auto. pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H4 H1). apply reachable_by_path_is_reachable in H9. exfalso; auto.
      + rewrite no_edge_gen_dst_equiv in H4. 2: simpl; auto. pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H4 H1). apply reachable_by_path_is_reachable in H7. exfalso; auto.
    - rewrite no_edge_gen_dst_equiv in H1; auto. apply no_loop_path in H1. auto.
  Qed.

End LstGraph.


Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.Ensembles_ext.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.lib.relation_list.
Require Import CertiGraph.lib.Equivalence_ext.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.graph_gen.
Require Import CertiGraph.graph.MathGraph.

Section BiGraph.

Context {V E: Type} {EV: EqDec V eq} {EE: EqDec E eq}.

Class BiGraph (pg: PreGraph V E) (left_out_edge right_out_edge: V -> E): Prop :=
{
  bi_consist: forall x, vvalid pg x -> left_out_edge x <> right_out_edge x;
  only_two_edges: forall x e, vvalid pg x -> (src pg e = x /\ evalid pg e <-> e = left_out_edge x \/ e = right_out_edge x)
}.

Context {left_out_edge right_out_edge: V -> E}.

Lemma left_valid (pg: PreGraph V E) {bi: BiGraph pg left_out_edge right_out_edge}: forall x, vvalid pg x -> evalid pg (left_out_edge x).
Proof.
  intros.
  pose proof only_two_edges x (left_out_edge x).
  tauto.
Qed.

Lemma right_valid (pg: PreGraph V E) {bi: BiGraph pg left_out_edge right_out_edge}: forall x, vvalid pg x -> evalid pg (right_out_edge x).
Proof.
  intros.
  pose proof only_two_edges x (right_out_edge x).
  tauto.
Qed.

Lemma left_sound (pg: PreGraph V E) {bi: BiGraph pg left_out_edge right_out_edge}: forall x, vvalid pg x -> src pg (left_out_edge x) = x.
Proof.
  intros.
  pose proof only_two_edges x (left_out_edge x).
  pose proof left_valid pg x.
  tauto.
Qed.

Lemma right_sound (pg: PreGraph V E) {bi: BiGraph pg left_out_edge right_out_edge}: forall x, vvalid pg x -> src pg (right_out_edge x) = x.
Proof.
  intros.
  pose proof only_two_edges x (right_out_edge x).
  pose proof right_valid pg x.
  tauto.
Qed.

Lemma left_or_right (pg: PreGraph V E) (bi: BiGraph pg left_out_edge right_out_edge): forall x e, vvalid pg x -> evalid pg e -> src pg e = x -> {e = left_out_edge x} + {e = right_out_edge x}.
Proof.
  intros.
  pose proof only_two_edges x e.
  destruct_eq_dec e (left_out_edge x); [left | right]; tauto.
Qed.

Lemma biGraph_out_edges (pg: PreGraph V E) (bi: BiGraph pg left_out_edge right_out_edge): forall x e, vvalid pg x -> (In e (left_out_edge x :: right_out_edge x :: nil) <-> out_edges pg x e).
Proof.
  intros.
  unfold out_edges.
  simpl.
  pose proof only_two_edges x e H.
  firstorder; subst; tauto.
Qed.

Definition biE (pg : PreGraph V E) {bi: BiGraph pg left_out_edge right_out_edge} (v: V) : V * V := (dst pg (left_out_edge v), dst pg (right_out_edge v)).

Lemma biE_only2 (pg : PreGraph V E) {bi: BiGraph pg left_out_edge right_out_edge} :
  forall v v1 v2 n, vvalid pg v -> biE pg v = (v1 ,v2) -> (step pg v n <-> n = v1 \/ n = v2).
Proof.
  intros; unfold biE in H.
  split; intros.
  + inversion H1; subst.
    inversion H0; subst.
    assert (e = left_out_edge (src pg e) \/ e = right_out_edge (src pg e)) by (rewrite <- only_two_edges; eauto).
    destruct H3; rewrite <- H3; auto.
  + rewrite step_spec; inversion H0; subst.
    destruct H1; [exists (left_out_edge v) | exists (right_out_edge v)]; subst.
    - split; [| split]; [eapply left_valid | rewrite left_sound |]; eauto.
    - split; [| split]; [eapply right_valid | rewrite right_sound |]; eauto.
Qed.

Lemma bi_graph_si: forall (g1 g2: PreGraph V E),
  g1 ~=~ g2 ->
  BiGraph g1 left_out_edge right_out_edge ->
  BiGraph g2 left_out_edge right_out_edge.
Proof.
  intros.
  constructor.
  + intros.
    apply (bi_consist).
    rewrite (proj1 H); auto.
  + destruct H as [? [? [? ?]]].
    intros.
    pose proof only_two_edges x e.
    rewrite <- H in H4.
    rewrite <- H1.
    rewrite <- H5 by auto.
    apply and_iff_compat_r_weak.
    intros.
    pose proof proj1 (H1 e) H6.
    rewrite H2 by auto.
    reflexivity.
Qed.

Lemma gen_dst_preserve_bi: forall (g: PreGraph V E) e t,
    BiGraph g left_out_edge right_out_edge -> BiGraph (pregraph_gen_dst g e t) left_out_edge right_out_edge.
Proof.
  intros. apply Build_BiGraph; intros.
  + apply bi_consist; auto.
  + simpl. apply (only_two_edges); auto.
Qed.

Context {is_null: DecidablePred V}.

Lemma bi_graph_join: forall (g: PreGraph V E) (PV1 PV2 PV: V -> Prop) (PE1 PE2 PE: E -> Prop),
  Prop_join PV1 PV2 PV ->
  Prop_join PE1 PE2 PE ->
  MathGraph (gpredicate_subgraph PV1 PE1 g) is_null ->
  MathGraph (gpredicate_subgraph PV2 PE2 g) is_null ->
  BiGraph (gpredicate_subgraph PV1 PE1 g) left_out_edge right_out_edge ->
  BiGraph (gpredicate_subgraph PV2 PE2 g) left_out_edge right_out_edge ->
  BiGraph (gpredicate_subgraph PV PE g) left_out_edge right_out_edge.
Proof.
  intros.
  constructor.
  + intros.
    simpl in H5.
    rewrite Intersection_spec in H5.
    destruct H5.
    destruct H as [? _].
    rewrite H in H6; destruct H6.
    - apply (@bi_consist _ _ _ H3).
      split; auto.
    - apply (@bi_consist _ _ _ H4).
      split; auto.
  + intros.
    simpl in H5.
    rewrite Intersection_spec in H5.
    destruct H5.
    destruct H as [HH HH0].
    rewrite HH in H6.
    destruct H6 as [H6 | H6]; [pose proof HH0 _ H6 | pose proof (fun H => HH0 _ H H6)].
    - pose proof @only_two_edges _ _ _ H3 x e.
      simpl in H7; rewrite !Intersection_spec in H7; specialize (H7 (conj H5 H6)).
      rewrite <- H7; simpl.
      rewrite Intersection_spec.
      apply and_iff_compat_l_weak; intros.
      apply and_iff_compat_l_weak; intros.
      destruct H0 as [HH1 HH2].
      rewrite HH1.
      assert (~ PE2 e); [intro | tauto].
      pose proof valid_graph (gpredicate_subgraph PV2 PE2 g) e.
      simpl in H10; rewrite !Intersection_spec in H10.
      specialize (H10 (conj H9 H0)).
      subst x.
      pose proof (fun H => HH2 _ H H0).
      tauto.
    - pose proof @only_two_edges _ _ _ H4 x e.
      simpl in H7; rewrite !Intersection_spec in H7; specialize (H7 (conj H5 H6)).
      rewrite <- H7; simpl.
      rewrite Intersection_spec.
      apply and_iff_compat_l_weak; intros.
      apply and_iff_compat_l_weak; intros.
      destruct H0 as [HH1 HH2].
      rewrite HH1.
      assert (~ PE1 e); [intro | tauto].
      pose proof valid_graph (gpredicate_subgraph PV1 PE1 g) e.
      simpl in H10; rewrite !Intersection_spec in H10.
      specialize (H10 (conj H9 H0)).
      subst x.
      pose proof (HH2 _ H0).
      tauto.
Qed.

Lemma bi_graph_join': forall (g: PreGraph V E) (PV1 PV2 PV: V -> Prop) (PE1 PE2 PE: E -> Prop),
  Prop_join PV1 PV2 PV ->
  Prop_join PE1 PE2 PE ->
  MathGraph' (gpredicate_subgraph PV1 PE1 g) is_null ->
  MathGraph' (gpredicate_subgraph PV2 PE2 g) is_null ->
  BiGraph (gpredicate_subgraph PV1 PE1 g) left_out_edge right_out_edge ->
  BiGraph (gpredicate_subgraph PV2 PE2 g) left_out_edge right_out_edge ->
  BiGraph (gpredicate_subgraph PV PE g) left_out_edge right_out_edge.
Proof.
  intros.
  constructor.
  + intros.
    simpl in H5.
    rewrite Intersection_spec in H5.
    destruct H5.
    destruct H as [? _].
    rewrite H in H6; destruct H6.
    - apply (@bi_consist _ _ _ H3).
      split; auto.
    - apply (@bi_consist _ _ _ H4).
      split; auto.
  + intros.
    simpl in H5.
    rewrite Intersection_spec in H5.
    destruct H5.
    destruct H as [HH HH0].
    rewrite HH in H6.
    destruct H6 as [H6 | H6]; [pose proof HH0 _ H6 | pose proof (fun H => HH0 _ H H6)].
    - pose proof @only_two_edges _ _ _ H3 x e.
      simpl in H7; rewrite !Intersection_spec in H7; specialize (H7 (conj H5 H6)).
      rewrite <- H7; simpl.
      rewrite Intersection_spec.
      apply and_iff_compat_l_weak; intros.
      apply and_iff_compat_l_weak; intros.
      destruct H0 as [HH1 HH2].
      rewrite HH1.
      assert (~ PE2 e); [intro | tauto].
      pose proof valid_graph' (gpredicate_subgraph PV2 PE2 g) e.
      simpl in H10; rewrite !Intersection_spec in H10.
      specialize (H10 (conj H9 H0)).
      subst x.
      pose proof (fun H => HH2 _ H H0).
      tauto.
    - pose proof @only_two_edges _ _ _ H4 x e.
      simpl in H7; rewrite !Intersection_spec in H7; specialize (H7 (conj H5 H6)).
      rewrite <- H7; simpl.
      rewrite Intersection_spec.
      apply and_iff_compat_l_weak; intros.
      apply and_iff_compat_l_weak; intros.
      destruct H0 as [HH1 HH2].
      rewrite HH1.
      assert (~ PE1 e); [intro | tauto].
      pose proof valid_graph' (gpredicate_subgraph PV1 PE1 g) e.
      simpl in H10; rewrite !Intersection_spec in H10.
      specialize (H10 (conj H9 H0)).
      subst x.
      pose proof (HH2 _ H0).
      tauto.
Qed.

End BiGraph.


Require Import SyntaxExpr SemanticsExpr.
Require Import List.

Fixpoint varsIn expr:=
match expr with
  | Var s => s :: nil
  | Const w => nil
  | SyntaxExpr.Binop op a b => varsIn a ++ varsIn b
  | SyntaxExpr.TestE op a b => varsIn a ++ varsIn b
end.


Require Import core core_axioms fintype fintype_axioms.
Import ScopedNotations.
(* From Chapter9 Require Export stlc. *)
Load stlc.
Set Implicit Arguments.
Unset Strict Implicit.
Require Import Setoid Morphisms.

(*** Rewriting laws that have to hold ***)
(* one of the rewriting laws of lambda-sigma *)
(* Goal forall m (s: tm (S m)), (ren_tm (var_zero .: shift) s) = s. *)
(* Proof. *)
(*   (* can be proved by asimpl both in the original form and reformulated as a substitution *) *)
(*   intros m s. *)
(*   asimpl. *)
(*   reflexivity. *)
(*   Restart. *)
(*   intros m s. *)
(*   substify. *)
(*   asimpl. *)
(*   reflexivity. *)
(* Qed. *)

(*** Iea for normalization ***)
(* I want to be able to say assert (H: s[sigma] = _) by (now asimpl)
 * so that it fills in the normal form in the evar.
 * With normal setoid rewriting this is not directly possible because setoid rewriting seems to behave differently on goals of the form
 * `s[sigma] = t[tau]` where it normalizes both sides.
than on goals of the form
 * `s[sigma] = ?E` where it fails to normalize the left side.
 *
 * A hack around this is the following tactic that asserts the trivial equality, then normalizes both sides and then builds another equality where we already know the normal form on the right hand side and proves it again with asimpl.
 * Of course it's slow since it uses asimpl twice.
 * Plus `asimpl in H` is naive and reverts H so asimpl is also applied to the rest of the goal which is not desirable and often defeeats the purpose of the tactic. But we might be able to write a more performant `asimpl in H` tactic.
 *)
Ltac normalize t :=
  let H := fresh "H" in
  assert (H: t = t) by (reflexivity);
  asimpl in H;
  match goal with
  | [ H: ?t2 = ?t2 |- _ ] =>
    clear H;
    let H := fresh "H" in
    assert (H: t = t2) by (now asimpl)
  end.

(*** Testing out asimpl. ***)
(* Ltac apply_subst_morphism := *)
(*   match goal with *)
(*     | [|- eq (subst_tm ?sigma ?s) (subst_tm ?tau ?t)] => *)
(*       apply subst_morphism; intros ? *)
(*     | [|- context[(subst_tm ?sigma ?s)]] => *)
(*       erewrite subst_morphism *)
(*   end. *)

Inductive Foo {n} : tm n -> Type :=
  FooC : forall s:tm n, Foo s.

Goal forall {m n} (f : fin m -> tm n) (s : tm (S m)) (t : tm m),
    Foo (s[t[f] .: f]) -> Foo (s[t..][f]).
Proof.
  intros * H.
  (* unfortunately it's not practicable to use the normalize tactic because apply is too simple (would have to use rewrite with the morphisms but that has its own set of problems with normalize).
   Idea: use the setoid rewriting version (or the funext version) to find out the normal form and then use the fast tactic to prove it
   If using the setoid rewrite tactic I would need some way of caching it otherwise it's useless
*)
  assert (s[t..][f] = s[t[f] .: f]) as -> by (now asimpl).
  assumption.
(*   normalize (s[t..][f]). *)
(*   asimpl. *)
(*   apply_subst_morphism. *)
(*   2: { *)
(*     intros ?. *)
(*     (* If we just have ?g x on the right hand side of the equality, we can always rewrite with rinstId_tm' (or instId_tm' but the other comes first) *) *)
(* (*      which would then constrain the evar to be ?g = ?s <id> *) *)
(* (*      That's the reason why I always got these <id> terms when I tried to normalize something with this tactic. *) *)
(*     rewrite rinstId_tm'. *)
(*     asimpl. *)
(*   } *)
Abort.

(* this subsitution equation that appears for example in step_inst is pretty nice to test since it uses a lot of the lemmas.

 Experience shows that if asimpl works here it works for a lot of other lemmas of Chapter9 *)
Lemma default_subst_lemma {m n} (f : fin m -> tm n) (s : tm (S m)) (t : tm m) :
  s[t..][f] = s[up_tm_tm f][(t[f])..].
Proof.
  assert (s[t..][f] = _) by (asimpl; reflexivity).
  evar (x : tm n).
  assert (s[t..][f] = x).
  {
    subst x.
    auto_unfold.
    rewrite compComp_tm.
    simple apply subst_morphism; intros ?.
    (* it does not make sense to do simple apply scons_comp' here since that would abort the normalization. simple apply only makes sense with the morphisms since they have a hypothesis *)
      erewrite scons_comp'.
      simple apply scons_morphism; intros ?.
        erewrite varL_tm''.
        fsimpl.
        reflexivity.
  }
    eta_reduce.
    reflexivity.
  }
  (* assert (s[t..][f] = s[t[f] .: f]) by (now asimpl). *)
  (* assert (s[up_tm_tm f][(t[f])..] = _) by (now asimpl). *)
  (* there are still too many differences *)

  now asimpl.
  (* rewrite renComp_tm. *)
  (* asimpl. *)
  (* apply subst_morphism. *)
  (* but how do I continue from here.
   Apply subst_morphism is also not promising because of the next lemma, s and t might be different and the equation still holds. *)
  (* Ok it appears I cannot construct an instantiation with two different terms (out of literals, else it's impossible anyways) that does not work. The reason seems to be that anything constructed from literals (variables, var_zero and shift) can be simplified by fsimpl. Then we unfold the definition of subst_tm/ren_tm and can argue about extensional equality of functions again. *)
  Restart.
  (* auto_unfold. *)
  (* asimpl'. *)
  (* simple apply subst_morphism; intros ?. *)
  (* asimpl'. *)
  (* simple apply scons_morphism; intros ?. *)
  (* asimpl'. *)
  (* (* asimpl. *) *)
  (* repeat unfold_funcomp. *)
  (* rewrite renComp_tm. *)
  (* cbn [subst_tm ren_tm]. *)
  (* fsimpl. *)
  (* rewrite instId_tm'. *)
  (* reflexivity. *)
Abort.

Lemma default_subst_lemma2 {m n} (f : fin m -> tm n) (s : tm (S m)) (t : tm m) :
  (var_tm var_zero)[t..][f] = subst_tm (@scons (tm n) (S n) t[f] (@scons (tm n) n t[f] var_tm)) (var_tm (shift var_zero)).
Proof.
  now asimpl.
  Restart.
  auto_unfold.
  rewrite compComp_tm.
  cbn [subst_tm ren_tm].
  fsimpl.
  reflexivity.
Qed.

Definition const {n} (a: fin (S n)) := @var_zero n.

Lemma default_subst_lemma3 {n} (x: fin (S n)):
  @subst_tm (S n) (S n) (@const n >> @var_tm (S n)) (var_tm x) = @subst_tm (S (S n)) (S n) (var_tm x .: @const n >> var_tm) (var_tm (shift x)).
Proof.
  asimpl.
  unfold const.
  reflexivity.
Qed.


(* In this file, we now propagate the theories in the ops_for_x files to
   prove results on our concrete sequences defined in seq_defs.v. *)

From mathcomp Require Import all_ssreflect all_algebra.
Require Import tactics shift binomialz rat_of_Z seq_defs.
Require annotated_recs_c annotated_recs_z annotated_recs_d.
Require ops_for_a ops_for_b ops_for_s ops_for_u ops_for_v.

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

Local Open Scope ring_scope.

Import GRing.Theory.

(* First, a few lemmas to avoid repeated 'have ...' in the proofs. *)

Lemma alt_sign (a : int) : (-1) ^ (a + 1) = - (-1) ^ a :> rat.
Proof. by rewrite exprzDr // expr1z mulrN1. Qed.

(* Then, the propagation of the theories.*)

Lemma c_Sn : annotated_recs_c.Sn c.
Proof.
rewrite /annotated_recs_c.Sn /annotated_recs_c.precond.Sn /c => n k ?.
rewrite addrAC !binSz /annotated_recs_c.Sn_cf0_0; [| lia..].
by field; ring_lia.
Qed.

Lemma c_Sk : annotated_recs_c.Sk c.
Proof.
rewrite /annotated_recs_c.Sk /annotated_recs_c.precond.Sk /c => n k ?.
rewrite int.zshiftP addrA !(binSz, binzS); [ | lia ..].
rewrite /annotated_recs_c.Sk_cf0_0.
by field; ring_lia.
Qed.

Definition c_ann := annotated_recs_c.ann c_Sn c_Sk.

Lemma a_Sn2 (n : int) : 2 <= n :> int -> annotated_recs_c.P_horner a n = 0.
Proof. by move=> h; exact: (ops_for_a.recAperyA c_ann h). Qed.

Lemma d_Sn : annotated_recs_d.Sn d.
Proof.
rewrite /annotated_recs_d.Sn /annotated_recs_d.precond.Sn /d => n k m ?.
rewrite addrAC !binSz /annotated_recs_d.Sn_cf0_0_0; [ | lia ..].
have b1_pos: 0 < binomialz n m by apply: bin_nonneg; lia.
have b2_pos: 0 < binomialz (n + m) m by apply: bin_nonneg; lia.
by field; ring_lia.
Qed.

(* This is a fake recurrence, because d does not really depend on k *)
Lemma d_Sk : annotated_recs_d.Sk d.
Proof.
rewrite /annotated_recs_d.Sk /annotated_recs_d.precond.Sk => n k m ?.
by rewrite /annotated_recs_d.Sk_cf0_0_0 rat_of_ZEdef mul1r.
Qed.

Lemma d_Sm : annotated_recs_d.Sm d.
Proof.
rewrite /annotated_recs_d.Sm /annotated_recs_d.precond.Sm /d => n k m ?.
rewrite int.zshiftP !alt_sign addrA !(binzS, binSz); [ | lia ..].
rewrite /annotated_recs_d.Sm_cf0_0_0.
have b1_pos: 0 < binomialz n m by apply: bin_nonneg; lia.
have b2_pos: 0 < binomialz (n + m) m by apply: bin_nonneg; lia.
by field; ring_lia.
Qed.

Definition d_ann := annotated_recs_d.ann d_Sn d_Sk d_Sm.

Lemma s_Sn2 : annotated_recs_s.Sn2 s.
Proof. exact: ops_for_s.s_Sn2 d_ann. Qed.

Lemma s_SnSk : annotated_recs_s.SnSk s.
Proof. exact: ops_for_s.s_SnSk d_ann. Qed.

Lemma s_Sk2 : annotated_recs_s.Sk2 s.
Proof. exact: ops_for_s.s_Sk2 d_ann. Qed.

Definition s_ann := annotated_recs_s.ann s_Sn2 s_SnSk s_Sk2.

Lemma z_Sn2 : annotated_recs_z.Sn2 ghn3.
Proof.
rewrite /annotated_recs_z.Sn2 /annotated_recs_z.precond.Sn2 => n ?.
rewrite /ghn3 harmonic_numbers.ghn_Sn2 -/ghn3; last lia.
rewrite /annotated_recs_z.Sn2_cf0 /annotated_recs_z.Sn2_cf1.
by field; ring_lia.
Qed.

Definition z_ann := annotated_recs_z.ann z_Sn2.

Lemma u_Sn2 : annotated_recs_s.Sn2 u.
Proof. exact: ops_for_u.u_Sn2 z_ann s_ann. Qed.

Lemma u_SnSk : annotated_recs_s.SnSk u.
Proof. exact: ops_for_u.u_SnSk z_ann s_ann. Qed.

Lemma u_Sk2 : annotated_recs_s.Sk2 u.
Proof. exact: ops_for_u.u_Sk2 z_ann s_ann. Qed.

Definition u_ann := annotated_recs_s.ann u_Sn2 u_SnSk u_Sk2.

Lemma v_Sn2 : annotated_recs_v.Sn2 v.
Proof. exact: ops_for_v.v_Sn2 c_ann u_ann. Qed.

Lemma v_SnSk : annotated_recs_v.SnSk v.
Proof. exact: ops_for_v.v_SnSk c_ann u_ann. Qed.

Lemma v_Sk2 : annotated_recs_v.Sk2 v.
Proof. exact: ops_for_v.v_Sk2 c_ann u_ann. Qed.

Definition v_ann := annotated_recs_v.ann v_Sn2 v_SnSk v_Sk2.

Lemma b_Sn4 (n : int) : 2 <= n :> int -> annotated_recs_v.P_horner b n = 0.
Proof. exact: ops_for_b.recAperyB v_ann _. Qed.