From mathcomp Require Import all_ssreflect zify finmap.
From Projection Require Export intermediateProj.
Require Import Paco.paco.

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

Let eqs := intermediateProj.eqs.

Require Import Program.
From Equations Require Import Equations.

Definition has_tree g := next_rec nil has_treeP (fun _ => true) g.

Fixpoint inp p g :=
  match g with
  | GRec g0 => inp p g0
  | GMsg a _ g0 => (comp_dir p a) || (inp p g0)
  | GBranch a gs => (comp_dir p a) || (has (inp p) gs)
  | _ => false
  end.

Fixpoint inp_all p g :=
  match g with
  | GRec g0 => inp_all p g0
  | GMsg a _ g0 => (comp_dir p a) || (inp_all p g0)
  | GBranch a gs => (comp_dir p a) || (all (inp_all p) gs)
  | _ => false
  end.

Lemma inp_ren : forall g sigma p,  inp p (g ⟨g sigma ⟩) = inp p g.
Proof.
elim;rewrite //=;intros. f_equal.  rewrite H //=.
f_equal. rewrite has_map. apply/eq_in_has. move=> x xIn.
simpl.
auto.
Qed.

Lemma inp_all_ren : forall g sigma p,  inp_all p (g ⟨g sigma ⟩) = inp_all p g.
Proof.
elim;rewrite //=;intros. f_equal.  rewrite H //=.
f_equal. rewrite all_map. apply/eq_in_all. move=> x xIn.
simpl.
auto.
Qed.

Lemma inp_subst : forall g sigma p, inp p (g [g sigma ]) -> inp p g \/ exists n, inp p (sigma n).
Proof.
elim;rewrite //=;intros.
right. exists n. auto.
apply H in H0. destruct H0. auto.
destruct H0. right. move : H0. asimpl.
destruct x. done. simpl. asimpl. rewrite inp_ren. exists x. auto.
destruct (orP H0).  lia.
auto.
apply H in H1. destruct H1. lia. auto.
destruct (orP H0). lia. rewrite has_map /= in H1.
destruct (hasP H1). simpl in H3. apply H in H3;auto.
destruct H3. left. apply/orP. right. apply/hasP. exists x. done. done.
auto.
Qed.

Lemma inp_all_subst : forall g sigma p, inp_all p (g [g sigma ]) -> inp_all p g \/ exists n, inp_all p (sigma n).
Proof.
elim;rewrite //=;intros.
right. exists n. auto.
apply H in H0. destruct H0. auto.
destruct H0. right. move : H0. asimpl.
destruct x. done. simpl. asimpl. rewrite inp_all_ren. exists x. auto.
destruct (orP H0).  lia.
auto.
apply H in H1. destruct H1. lia. auto.
destruct (comp_dir p a) eqn:Heqn.  simpl. auto.
simpl in *.
rewrite all_map in H0.
elim : l H0 H. ssa.
move => a0 l IH /= /andP => [] [] . ssa.
move : (H a0). rewrite inE eqxx //=.  move => HH2.
apply HH2 in a1=>//=. destruct (inp_all p a0) eqn:Heqn2.  simpl. auto.
simpl. eauto.
Qed.

Lemma inp_subst2 : forall g sigma p, (forall n, inp p (sigma n) -> inp p g) ->  inp p (g [g sigma ]) ->  inp p g.
Proof.
intros. apply inp_subst in H0. destruct H0. done. destruct H0. eauto.
Qed.

Lemma inp_all_subst2 : forall g sigma p, (forall n, inp_all p (sigma n) -> inp_all p g) ->  inp_all p (g [g sigma ]) ->  inp_all p g.
Proof.
intros. apply inp_all_subst in H0. destruct H0. done. destruct H0. eauto.
Qed.

Lemma ptcps_subst2 : forall g sigma p, inp p g -> inp p (g [g sigma ]).
Proof.
elim;rewrite //=;intros. auto.
destruct (orP H0);try lia.
rewrite H //=.   lia.
destruct (orP H0);try lia.
apply/orP. right. rewrite has_map.
destruct (hasP H1). eapply H in H3.
apply/hasP. eauto. exists x.  done. simpl.  eauto. done.
Qed.

Lemma ptcps_all_subst2 : forall g sigma p, inp_all p g -> inp_all p (g [g sigma ]).
Proof.
elim;rewrite //=;intros. auto.
destruct (orP H0);try lia.
rewrite H //=.   lia.
destruct (orP H0);try lia.
apply/orP. right. rewrite all_map.
apply/allP=> x xIn /=. eauto. apply/H=>//=. apply (allP H1)=>//=.
Qed.

Lemma inp_subst_iff : forall g sigma p, (forall n, inp p (sigma n) -> inp p g) ->  inp p (g [g sigma ]) =  inp p g.
Proof.
intros. apply/eq_iff.  split. move/inp_subst2=>HH. apply/HH. auto.
intros.  apply/ptcps_subst2. done.
Qed.

Lemma inp_all_subst_iff : forall g sigma p, (forall n, inp_all p (sigma n) -> inp_all p g) ->  inp_all p (g [g sigma ]) =  inp_all p g.
Proof.
intros. apply/eq_iff.  split. move/inp_all_subst2=>HH. apply/HH. auto.
intros.  apply/ptcps_all_subst2. done.
Qed.

Inductive Unfg (R : gType -> Prop) : gType -> Prop :=
 | UnfgC g : Unfg R (g [g GRec g .: GVar]) ->  Unfg R (GRec g)
 | UnfgR  g :  R g -> Unfg R g.
Hint Constructors Unfg.

Print part_of2. Print part_ofFU. Print part_ofF.   Check ApplyF1.
Print part_of2. Print part_ofFU.
Inductive part_of3 (p : ptcp) : gType -> Prop :=
    part_of3C g : Unfg ((part_ofF p) (part_of3 p)) g -> part_of3 p g.
Hint Constructors part_of3.

Check part_of3_ind.

Lemma part_of3_ind2
     : forall (p : ptcp) (P : gType -> Prop),
       (forall (a : action) (u : value) (g0 : gType), comp_dir p a -> P (GMsg a u g0)) ->
       (forall (a : action) (u : value) (g0 : gType), ~ comp_dir p a -> part_of3 p g0 -> P g0 -> P (GMsg a u g0)) ->
       (forall (a : action) (gs : seq gType), comp_dir p a -> P (GBranch a gs)) ->
       (forall (a : action) (g : gType) (gs : seq gType), ~ comp_dir p a -> In g gs -> part_of3 p g -> P g -> P (GBranch a gs)) ->
       (forall g,  part_of3 p (g [g GRec g .: GVar]) -> P (g [g GRec g .: GVar]) -> P (GRec g) )
 ->
       forall g : gType, part_of3 p g -> P g.
Proof.
intros. move : g H4. fix IH 2. intros. destruct H4.
move : g H4. fix IH2 2. intros. destruct H4. apply/H3. con. done. apply/IH2. done.
destruct H4. apply/H. done.
destruct (comp_dir p a) eqn:Heqn. apply H. rewrite Heqn. done.
apply H0. rewrite Heqn. done. done. auto.
destruct (comp_dir p a) eqn:Heqn. apply H1. rewrite Heqn. done. done.
destruct (comp_dir p a) eqn:heqn. apply/H1. comp_disc.
eapply H2. comp_disc. eauto. done. apply/IH. done.
Qed.

Lemma part_of3_subst : forall p g sigma, part_of3 p g -> part_of3 p g [g sigma].
Proof.
intros. elim/part_of3_ind2 : H sigma;intros;simpl. econstructor 1. eauto.
eauto. con. con. con. done.
con. con. econstructor 4. 2 : {  apply/H2. apply : sigma. } apply/inP.
apply/map_f.   apply/inP. done.
con. asimpl. move : (H0 ( sigma)).  asimpl.
intros. con.   asimpl. inv H1. move : H2. done.
Qed.

Lemma inp_part_of2 : forall p g, inp p g -> part_of3 p g.
Proof.
move => p. elim;intros;try done.
con. con.  simpl in H0. move/H : H0.
intros. suff : part_of3 p (g [gGRec g .: var]). case. done.
apply/part_of3_subst. done. ssa. destruct (orP H0).
con. con. con. done.
con. con. econstructor 2. auto.
simpl in H0. destruct (orP H0).
con. con. con. done.
move/hasP : H1. case=> x. intros.
con. con. econstructor 4. apply/inP. eauto. apply/H. done. done.
Qed.

Lemma part_of23 : forall p g, part_of3 p g -> part_of2 p g.
Proof.
intros. elim/part_of3_ind2 : H;intros. con. con. con. done.
con. con. cbn. constructor 2. done.
con. con. con. done.
con. con. econstructor 4. eauto. done.
con. con. rewrite full_unf_subst. inv H0. inv H1. done.
Qed.

Lemma inp_unf : forall g p, inp p (unf g) =  inp p g.
Proof.
destruct g;try done. simpl. intros. rewrite  inp_subst_iff //=.
case. done. done.
Qed.

Lemma inp_full_unf : forall g p, inp p g = inp p (full_unf g).
Proof.
intros. rewrite /full_unf. remember (mu_height g).
clear Heqn. elim : n g. done. intros. simpl.  rewrite inp_unf.
done.
Qed.

Lemma inp_complete : forall g p, part_of2 p g  -> inp p g.
Proof. intros.
elim/part_of2_ind2 : H;intros. rewrite inp_full_unf H0 //= H //=.
rewrite inp_full_unf H2 /=. lia.
rewrite inp_full_unf H0. ssa. lia.
rewrite inp_full_unf. rewrite H3 /=. apply/orP. right.
apply/hasP. exists g0. apply/inP=>//=. done.
Qed.

(*It is hard to show inp -> part_of2 because of structural induction of inp computation clashes with full unfolding of part_of2, so we make an intermediate judgment, part_of3, prove an induction principle*)
Lemma inp_iff : forall g p, inp p g <-> part_of2 p g.
Proof.
intros. split;intros.  apply/part_of23. apply/inp_part_of2. done.
apply/inp_complete. done.
Qed.

Inductive part_of_all3 (p : ptcp) : gType -> Prop :=
    part_of_all3C g : Unfg ((part_of_allF p) (part_of_all3 p)) g -> part_of_all3 p g.
Hint Constructors part_of_all3.

Check part_of_all3_ind.

Lemma part_of_all3_ind2
     : forall (p : ptcp) (P : gType -> Prop),
       (forall (a : action) (u : value) (g0 : gType), comp_dir p a -> P (GMsg a u g0)) ->
       (forall (a : action) (u : value) (g0 : gType), ~ comp_dir p a -> part_of_all3 p g0 -> P g0 -> P (GMsg a u g0)) ->
       (forall (a : action) (gs : seq gType), comp_dir p a -> P (GBranch a gs)) ->
       (forall (a : action) (gs : seq gType), ~ comp_dir p a -> (forall g, In g gs -> part_of_all3 p g -> P g) -> (forall g, In g gs -> part_of_all3 p g) -> P (GBranch a gs)) ->
       (forall g,  part_of_all3 p (g [g GRec g .: GVar]) -> P (g [g GRec g .: GVar]) -> P (GRec g) )
 ->
       forall g : gType, part_of_all3 p g -> P g.
Proof.
intros. move : g H4. fix IH 2. intros. destruct H4.
move : g H4. fix IH2 2. intros. destruct H4. apply/H3. con. done. apply/IH2. done.
destruct H4. apply/H. done.
destruct (comp_dir p a) eqn:Heqn. apply H. rewrite Heqn. done.
apply H0. rewrite Heqn. done. done. auto.
destruct (comp_dir p a) eqn:Heqn. apply H1. rewrite Heqn. done. done.
destruct (comp_dir p a) eqn:heqn. apply/H1. comp_disc.
eapply H2. comp_disc. intros.  apply/IH. apply H4. done. eauto.
Qed.

Lemma part_of_all3_subst : forall p g sigma, part_of_all3 p g -> part_of_all3 p g [g sigma].
Proof.
intros. elim/part_of_all3_ind2 : H sigma;intros;simpl. econstructor 1. eauto.
eauto. con. con. con. done.
con. con. econstructor 4. move => g0. move/inP. move/mapP=>[]. intros. subst. apply/H0.
apply/inP. done. apply/H1. apply/inP. done.
con. asimpl. move : (H0 ( sigma)).  asimpl.
intros. con.   asimpl. inv H1. move : H2. done.
Qed.

Lemma inp_part_of_all2 : forall p g, inp_all p g -> part_of_all3 p g.
Proof.
move => p. elim;intros;try done.
con. con.  simpl in H0. move/H : H0.
intros. suff : part_of_all3 p (g [gGRec g .: var]). case. done.
apply/part_of_all3_subst. done. ssa. destruct (orP H0).
con. con. con. done.
con. con. econstructor 2. auto.
simpl in H0. destruct (orP H0).
con. con. con. done. con.  con. econstructor 4.
intros. apply/H. apply/inP. done. apply (allP H1). apply/inP. done.
Qed.

Lemma part_of_all23 : forall p g, part_of_all3 p g -> part_of_all2 p g.
Proof.
intros. elim/part_of_all3_ind2 : H;intros. con. con. con. done.
con. con. cbn. constructor 2. done.
con. con. con. done.
con. con. econstructor 4. eauto.
con. con. rewrite full_unf_subst. inv H0. inv H1. done.
Qed.

Lemma inp_all_unf : forall g p, inp_all p (unf g) =  inp_all p g.
Proof.
destruct g;try done. simpl. intros. rewrite  inp_all_subst_iff //=.
case. done. done.
Qed.

Lemma inp_all_full_unf : forall g p, inp_all p g = inp_all p (full_unf g).
Proof.
intros. rewrite /full_unf. remember (mu_height g).
clear Heqn. elim : n g. done. intros. simpl.  rewrite inp_all_unf.
done.
Qed.

Lemma inp_all_complete : forall g p, part_of_all2 p g  -> inp_all p g.
Proof. intros.
elim/part_of_all2_ind2 : H;intros. rewrite inp_all_full_unf H0 //= H //=.
rewrite inp_all_full_unf H2 /=. lia.
rewrite inp_all_full_unf H0. ssa. lia.
rewrite inp_all_full_unf. rewrite H2 /=. apply/orP. right.
apply/allP. move => x xIn. apply/H1. apply/inP.  done. apply/H0. apply/inP. done.
Qed.

(*It is hard to show inp -> part_of2 because of structural induction of inp computation clashes with full unfolding of part_of2, so we make an intermediate judgment, part_of3, prove an induction principle*)
Lemma inp_all_iff : forall g p, inp_all p g <-> part_of_all2 p g.
Proof.
intros. split;intros.  apply/part_of_all23. apply/inp_part_of_all2. done.
apply/inp_all_complete. done.
Qed.

Definition size_pred g :=
match g with
| GBranch a gs => 0 < size gs
| _ => true
end.

Definition full_geunf ge := (full_unf ge.1,full_eunf ge.2).
Definition nextge p ge :=
match ge.1 with
| GMsg a _ g0 => if comp_dir p a then if ge.2 is EMsg _ _ _ e0 then ((g0,e0)::nil) else nil else  ((g0,ge.2)::nil)
| GBranch a gs  => if comp_dir p a then if ge.2 is EBranch  d c es then zip gs es else nil else map (fun g => (g,ge.2)) gs
| _ => nil
end.

Definition nextge_unf p ge :=nextge p (full_geunf ge).

Definition enumge ge := utils.compose (enumg ge.1) (enum ge.2) pair.

Definition g_top_act p g :=
match g with
| GMsg a u _ => if comp_dir p a is Some d then Some (d, action_ch a,inl u) else None
| GBranch a gs => if comp_dir p a is Some d then Some (d, action_ch a,inr (size gs)) else None
| _ => None
end.

Definition e_top_act e  :=
match e with
| EMsg d c u _ => Some (d,c,inl u)
| EBranch d c es => Some (d,c,inr (size es))
| _ => None
end.

Definition project_predP (p : ptcp) (ge : gType * lType) (bs : seq bool) : bool :=
  let ge' := full_geunf ge in
 if (inp_all p ge.1) && (inp p ge.1) then if g_top_act p ge'.1 is Some l then (Some l == e_top_act ge'.2) && (all id bs) else (size_pred ge'.1) && (all id bs)
  else (has_tree ge.1) && (~~ inp p ge.1) &&  (full_eunf ge'.2 == EEnd).

Lemma enumge_subst_nextg_unf : forall e e' e'' p, e' \in nextge_unf p e -> e'' \in enumge e'  -> e'' \in enumge e.
Proof.
intros. rewrite /nextge_unf in H.  rewrite /enumge. destruct e''.
apply mem_compose2 in H0. destruct H0.
destruct e. simpl. destruct e'. simpl in H0,H1.
have : s1 \in nextg_unf g.
rewrite /nextge in H.
rewrite /full_geunf /= in H. rewrite /nextg_unf.
destruct (full_unf g);try done.
move : H. case_if. destruct (full_eunf l);try done.
rewrite inE. move/eqP. case. intros. subst. simpl. auto.
rewrite inE. move/eqP. case. intros. subst. simpl. auto.
move : H. case_if. destruct (full_eunf l);try done.
move/mem_zip. ssa.  move/mapP=>[].
intros. inv q. simpl. done.
intros.
have : s2 \in (full_eunf l)::(nexte_unf l).
rewrite /nextge in H.
rewrite /full_geunf /= in H. rewrite /nexte_unf.
destruct (full_unf g);try done.
move : H. case_if. destruct (full_eunf l);try done.
rewrite inE. move/eqP. case. intros. subst. simpl. auto.
rewrite inE. move/eqP. case. intros. subst. simpl. auto.
move : H. case_if. destruct (full_eunf l);try done.
move/mem_zip. ssa.  lia.
move/mapP=>[].
intros. inv q. auto.
intros. rewrite inE in x0. destruct (orP x0).
rewrite (eqP H2) in H1.
apply/mem_compose. apply/enumg_subst_nextg_unf.  eauto. done.
apply/enum_subst_iter_eunf.  eauto.
apply/mem_compose.
apply/enumg_subst_nextg_unf. eauto. done.
apply/enum_subst_nexte_unf. eauto. done.
Qed.

Lemma selfge : forall e, e \in enumge e.
Proof. intros. rewrite /enumge. destruct e. apply/mem_compose=>//=.
apply/coGlobal.selfe.  apply/selfe.
Qed.

Definition gemeasure (ge : gType * lType) (visited : seq ( gType * lType)) :=
size (rep_rem visited (undup (enumge ge))).
Check nextge_unf.
Equations pair_next_rec (A : Set ) (p : ptcp) (visited : seq  (gType * lType))  (P : gType * lType -> seq A ->  A)
    (b : A)
    (ge : gType * lType): A by wf (gemeasure ge visited) :=
 pair_next_rec p  visited P b ge  with (dec (ge \in visited)) => {
  pair_next_rec _  _ _ _ _ (in_left) := b;
  pair_next_rec p visited  P b ge _ :=  (P ge (foldInMap (nextge_unf p ge) (fun e0 _ => pair_next_rec p (ge::visited) P b e0)))

 }.
Next Obligation.
apply/ltP.
simpl. rewrite /gemeasure /=.
destruct ((g0,l0) \in ((enumge (g,l)))) eqn:Heqn.
apply/size_strict_sub.
apply/rem_uniq/rep_rem_uniq/undup_uniq.
intros. destruct (eqVneq x (g0,l0)).  subst. rewrite -mem_rep_iff.  rewrite mem_undup.
apply/selfge. rewrite e1 //=.
apply mem_rem2 in H;eauto.
destruct (x \in visited) eqn:Heqn2.
eapply rep_rem_uniq2 in Heqn2. 2 : { apply/undup_uniq. apply (enumge (g,l)). }
rewrite H in Heqn2. done.
move : H.
rewrite -!mem_rep_iff. rewrite  !mem_undup. intros. apply/enumge_subst_nextg_unf.  apply/inP. eauto.
done. rewrite Heqn2. done. rewrite Heqn2. done.
instantiate (1 := (g0,l0)).  apply/negP=>HH. rewrite mem_rem_uniqF in HH. done.
apply/rep_rem_uniq/undup_uniq.
rewrite -mem_rep_iff.  rewrite mem_undup. apply/enumge_subst_nextg_unf. apply/inP. eauto. done.
rewrite e1 //=.
rewrite rem_id. 2 : {
apply/negP=>HH. move : Heqn. move/negP=>H2. apply/H2.
apply/mem_rep_iff.  apply/negP. clear H2. eauto. apply/rep_rem2. rewrite e1.  done.
  2 : { eauto. } intros. rewrite mem_undup in H. done.  }
apply/size_strict_sub.  apply/rep_rem_uniq. apply/undup_uniq.
intros. 2 : {  apply/negP=>HH. move : Heqn. move/negP=>HH2. apply/HH2.
rewrite -mem_undup.
rewrite mem_rep_iff.  eauto.  rewrite e1 //=. }
destruct (x \in visited) eqn:Heqn2.
eapply rep_rem_uniq2 in Heqn2. 2 : { apply/undup_uniq. apply (enumge (g,l)). }
rewrite H in Heqn2. done.
move : H.
rewrite -!mem_rep_iff. rewrite  !mem_undup. intros. apply/enumge_subst_nextg_unf.  apply/inP. eauto.
done. rewrite Heqn2. done. rewrite Heqn2. done.
rewrite -mem_rep_iff. rewrite mem_undup. apply/selfge.
rewrite e1 //=.
Defined.

Print Project.
Lemma projectb_sound_aux : forall g e l p  (R : gType -> lType -> Prop) , gInvPred g -> pair_next_rec p l (project_predP p) true (g,e) ->  (forall g0 e0, (g0,e0) \in l -> R g0 e0) ->
upaco2 (UnfProj \o  project_gen p) R g e.
Proof.
intros.
funelim (pair_next_rec p l (project_predP p) true (g,e)).
right. apply/H1. done.
rewrite -Heqcall in H1.
left. pcofix CIH.
rewrite {1}/project_predP /= in H1.
destruct (inp_all p g && (inp p g)) eqn:Heqn.
pfold. constructor.

rewrite /nextge_unf in H1.
rewrite foldInMapP in H1.
rewrite /full_geunf /= in H1.
punfold H0. inv H0. clear H0.
destruct (full_unf g) eqn:Heqn2; try solve [ con | done].
inv H3. rewrite inp_all_full_unf in Heqn. rewrite Heqn2 in Heqn. done.
inv H3.
simpl in H1.
destruct (comp_dir p a) eqn:Heqn3.
ssa. move : H0. move/eqP. destruct (full_eunf e) eqn:Heqn4;try done.
simpl. case. intros. subst. con. eauto.
apply/H. 7 : { con. } repeat constructor.
apply/inP.  rewrite /nextge_unf /full_geunf /=.
rewrite Heqn2 Heqn4 /=. rewrite /nextge /=.
rewrite Heqn3 //=. repeat constructor.
inv H3. pclearbot. done.
simpl in H4. rewrite /nextge /= in H4.
rewrite Heqn3 /= in H4. ssa.
intros. rewrite inE in H0. destruct (orP H0).
move : H6. move/eqP. case. move=>->->. auto. auto.

simpl in H1. rewrite /nextge /= in H1.
rewrite Heqn3 /= in H1. ssa.
rewrite /id in H0.
con. done.
apply/H. 7 : { con. } repeat constructor.
apply/inP.  rewrite /nextge_unf /full_geunf /=.
rewrite Heqn2  /=. rewrite /nextge /=.
rewrite Heqn3 /=. auto.
repeat constructor.
inv H3. pclearbot. done.
rewrite /nextge /= in H4.
done.
intros. rewrite inE in H6.
destruct (orP H6).
move : H7. move/eqP. case. move=>->->. auto.
auto.
apply/inp_all_iff=>//=. rewrite inp_all_full_unf Heqn2 /= Heqn3 //= in H1.

simpl in H1.

destruct (comp_dir p a) eqn:Heqn3.
ssa. move : H0. move/eqP. destruct (full_eunf e) eqn:Heqn4;try done.
simpl. case. intros. subst. con. eauto.
done.
rewrite /nextge /= in H4.
rewrite Heqn3 /= in H4.
intros. apply/H. repeat constructor.
rewrite /nextge_unf /full_geunf /= Heqn2 Heqn4 /=.
rewrite /nextge /= Heqn3 /=. destruct p0.
simpl.  auto. repeat constructor.
inv H3. move : H8.
destruct p0. simpl.
move/List.Forall_forall=>HH.
suff : upaco1 (ApplyF1 full_unf \o gInvPred_gen) bot1 g0.
intros. pclearbot. done.
apply/HH. move : H0. move/inP. move/mem_zip. ssa.
apply/inP. done.
destruct p0. simpl in *.
rewrite all_map in H4.
move : H0. move/inP. move/(allP H4). done.
intros. destruct (orP H6). move: H8. move/eqP. case.
intros. subst. auto. auto. con.

rewrite /nextge  /=  Heqn3 /= in H1.
rewrite -map_comp all_map /=  in H1.
intros. have : exists g, In g l.   ssa. destruct l;eauto. done. exists g0. simpl. eauto. move => Hin. destruct Hin. econstructor=>//=. eauto. ssa. apply/inp_all_iff.  rewrite inp_all_full_unf Heqn2 /= Heqn3 /= in H1.
apply (allP H1). apply/inP. done.
apply/H. repeat con.
apply/inP. rewrite /nextge_unf /full_geunf /= Heqn2.
rewrite /nextge /= Heqn3 /=.
apply/map_f. apply/inP=>//=. repeat con.
inv H3. move : H9.  move/List.Forall_forall=>HH. move : H4.
move/HH. intros. pclearbot. done.
apply (allP H6). apply/inP=>//=.
intros. destruct (orP H8). move: H9. move/eqP. case.
intros. subst. auto. auto. con.

ssa.  apply/Project_eunf. rewrite full_eunf_idemp in H4. rewrite (eqP H4).
pfold. con. con. rewrite -part_of2_iff. rewrite -inp_iff. apply/negP=>//=.
apply/Unravel_gInvPred. rewrite -gUnravel2_iff. apply/next_rec_sound. done.
Qed.

Lemma Project_not_part2_aux : forall p g e, Project g p e -> ~ part_of2 p g -> EQ2 e  EEnd.
Proof.
move => p.
pcofix CIH. intros. apply part_of2_or_end in H0 as H0'. destruct H0'.
elim/part_of_all2_ind2 : H e H0  H1;intros. rewrite part_of2_iff H0 in H2.
have : ~ comp_dir p a.  eauto. comp_disc.
punfold H3. inv H3. rewrite H2 in H5. inv H5. comp_disc. pc.
apply H1. apply/Project_eunf. eauto. rewrite part_of2_iff H2 in H4. eauto.
pfold. con. rewrite -H6. con.
rewrite part_of2_iff H0 in H2.
have : ~ comp_dir p a.  eauto. comp_disc.
rewrite part_of2_iff H2 in H4. punfold H3. inv H3. rewrite H2 in H5. inv H5. comp_disc.
eapply H1.   eauto. move/H11 : H9. ssa. move/H11 : H9. ssa. pc. apply/Project_eunf. done.
eauto.  pfold. con. rewrite -H6. con. pfold. con. rewrite H. con.
Qed.

Lemma Project_not_part2 : forall p g e, Project g p e -> ~ part_of2 p g -> full_eunf e = EEnd.
Proof.
intros. have : EQ2 e EEnd. apply/Project_not_part2_aux;eauto. intros. punfold x. inv x. inv H1. done.
Qed.

Lemma projectb_complete_aux: forall g e l p, paco2 (UnfProj \o  project_gen p) bot2 g e -> pair_next_rec p l (project_predP p) true (g,e).
Proof.
intros. funelim (pair_next_rec p l (project_predP p) true (g,e)).
done.
rewrite -Heqcall foldInMapP.
rewrite {1}/nextge_unf /full_geunf /=. apply part_of2_or_end in H0 as H0'.  destruct H0'.
- rewrite {1}/project_predP /=. rewrite -inp_all_iff in H1. rewrite H1. simpl.
  destruct (inp p g) eqn: Hinp.

punfold H0.  inv H0.
inv H2=>//=.
rewrite H5 /=. ssa.
rewrite /nextge /=.
rewrite H5 /=. ssa.
rewrite /id. apply/H. repeat con.
rewrite /nextge_unf /full_geunf /=.
rewrite -H4 -H3 /nextge /= H5 /=. auto.
pclearbot. done. con.
rewrite H4.
rewrite /nextge_unf /full_geunf /=.
rewrite /nextge /=  H4 /=. ssa.
rewrite /id. apply/H. repeat con.
rewrite /nextge_unf /nextge /= -H3 H4 /=.  auto.
pclearbot. done. con.
rewrite H5. ssa.
rewrite H6 //=.
rewrite /nextge /= H5 /=.
rewrite all_map. apply/allP=> x xIn.
simpl. rewrite /id.
move : H7. move/List.Forall_forall=>HH2. destruct x.
apply/H. repeat con.
apply/inP. rewrite /nextge_unf /full_geunf /= -H4 /=.
rewrite /nextge /= -H3 H5 //=.
move : xIn. move/inP=>Hin. forallApp HH2 Hin. move => HH3.  pclearbot. simpl in HH3. auto. con.
rewrite H4. rewrite /nextge /= H4 /=.
rewrite -map_comp all_map. ssa. destruct gs;try done.
apply/allP=> x xIn.
simpl. rewrite /id. apply/H. repeat con.
apply/inP. rewrite /nextge_unf /full_geunf /= -H3 /=.
rewrite /nextge /= H4 /=. apply/map_f. done.
move : xIn. move/inP. move/H6. ssa. pclearbot. done. con.
rewrite -part_of2_iff in H4. rewrite -inp_iff in H4. rewrite Hinp in H4. done. ssa.
apply/next_rec_complete_aux. apply/Project_gtree.  eauto. rewrite full_eunf_idemp. apply/eqP.
apply/ Project_not_part2. eauto. rewrite -inp_iff Hinp //=.
rewrite H1. rewrite /project_predP /=.
apply Project_eunf2 in H0. rewrite H1 in H0. apply Project_not_part in H0 as H0'.
rewrite -inp_iff in H0'. move : H0'. move/negP. move/negbTE.  move=>->.
rewrite andbC /=. rewrite full_eunf_idemp H1 eqxx.    ssa.
apply/next_rec_complete_aux. apply/Project_gtree. eauto.
Qed.

Lemma has_tree_unf : forall g, has_tree (full_unf g) -> has_tree g.
Proof.
intros. apply/next_rec_complete_aux. apply next_rec_sound in H. pfold. con. punfold H. inv H.
rewrite full_unf_idemp in H0. eauto.
Qed.

(*Lemma pair_imp_has_tree  : forall g e p l, (forall ge, ge \in l -> has_tree ge.1) ->  pair_next_rec p l (project_predP p) true (g,e) -> has_tree g.
Proof.
intros. funelim ( pair_next_rec p l (project_predP p) true (g, e)).
have : (g,e0) \in visited. rewrite e //=. move/H. ssa.
rewrite -Heqcall in H1. ssa.
move : H1. rewrite /project_predP /=. rewrite !foldInMapP.  case_if. ssa.
apply/has_tree_unf. destruct (full_unf g)eqn:Heqn. ssa.
rewrite inp_full_unf in H4. rewrite Heqn in H4. done.
rewrite inp_full_unf in H4. rewrite Heqn in H4. done.
apply inp_iff in H4.
rewrite /nextge_unf /full_geunf /= Heqn /= in H2. ssa.

lia.
have : has_tree (g,e).1. apply H.
apply H in e. *)

Definition projectb g p e := (has_tree g) && (pair_next_rec p nil (project_predP p) true (g,e)).

(*Theorem 27*)
Lemma projectb_iff : forall g p e, projectb g p e <-> Project g p e.
Proof.
intros;split. move/andP=>[]. ssa. move/projectb_sound_aux : b.
move/next_rec_sound : a. move/gUnravel2_Rol. intros.  edestruct b; eauto.
done. done. rewrite /projectb. ssa. apply/next_rec_complete_aux. apply/Project_gtree. eauto.
apply/projectb_complete_aux. eauto.
Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2005-02-17

general lemmas and tactics
*)

Set Implicit Arguments.

Require Import LogicUtil Structures.Equalities RelUtil BoolUtil.
Require Export EqdepFacts Eqdep_dec.
Require Setoid.

(*COQ: shouldn't it be part of the standard lib?*)
Instance Equiv_is_PreOrder A (R : rel A) : Equivalence R -> PreOrder R.

Proof. split; class. Qed.

(***********************************************************************)
(** Leibniz equality is an Equivalence. *)

Instance eq_refl t : Reflexive (@eq t).

Proof. class. Qed.

Instance eq_sym t : Symmetric (@eq t).

Proof. class. Qed.

Instance eq_trans t : Transitive (@eq t).

Proof. class. Qed.

(*COQ: to be removed: why not solved by class?*)
Instance eq_PreOrder t : PreOrder (@eq t).

Proof. split; class. Qed.

(***********************************************************************)
(** Functor providing properties the basic properties of Leibniz
equality on some type. *)

Module LeibnizFacts (Import T : Typ).

  Definition eq : relation t := @Logic.eq t.

  Instance eq_refl : Reflexive eq.

  Proof. fo. Qed.

  Instance eq_sym : Symmetric eq.

  Proof. fo. Qed.

  Instance eq_trans : Transitive eq.

  Proof. unfold eq; class. Qed.

End LeibnizFacts.

(***********************************************************************)
(** Type equipped with a boolean equility. *)

Record Bool_eq_type : Type := mkBool_eq_type {
  bet_type :> Type;
  bet_eq : bet_type -> bet_type -> bool;
  bet_ok : forall x y, bet_eq x y = true <-> x = y }.

(***********************************************************************)
(** Properties of Leibniz equality on decidable types. *)

Section eq_dep.

  Variables (A : Type) (eq_dec : forall x y : A, {x=y}+{~x=y}).

  Lemma eq_rect_eq : forall (p : A) Q x h, x = eq_rect p Q x p h.

  Proof. exact (eq_rect_eq_dec eq_dec). Qed.

  Lemma eq_dep_eq : forall P (p : A) x y, eq_dep A P p x p y -> x = y.

  Proof. exact (eq_rect_eq__eq_dep_eq A eq_rect_eq). Qed.

  Lemma UIP : forall (x y : A) (p1 p2 : x = y), p1 = p2.

  Proof. exact (eq_dep_eq__UIP A eq_dep_eq). Qed.

  Lemma UIP_refl : forall (x : A) (p : x = x), p = refl_equal x.

  Proof. exact (UIP__UIP_refl A UIP). Qed.

  Lemma Streicher_K :
    forall (x : A) (P : x = x -> Prop), P (refl_equal x) -> forall p, P p.

  Proof. exact (K_dec_type eq_dec). Qed.

  Lemma inj_existT :
    forall P (x : A) (p q : P x), existT p = existT q -> p = q.

  Proof. exact (eq_dep_eq__inj_pairT2 A eq_dep_eq). Qed.

  Lemma inj_ex_intro :
    forall P (x : A) p q, ex_intro P x p = ex_intro P x q -> p = q.

  Proof.
    intros. apply inj_right_pair with (A:=A).
    intros x0 y0; case (eq_dec x0 y0); [left|right]; hyp.
    hyp.
  Qed.

End eq_dep.

Implicit Arguments UIP_refl [A x].

(***********************************************************************)
(** Properties of a boolean function testing Leibniz equality. *)

Section beq.

  Variable A : Type.
  Variable beq : A -> A -> bool.
  Variable beq_ok : forall x y, beq x y = true <-> x = y.

  Lemma beq_refl : forall x, beq x x = true.

  Proof. intro. ded (beq_ok x x). rewrite H. refl. Qed.

  Lemma beq_ko : forall x y, beq x y = false <-> x <> y.

  Proof.
    intros. destruct (beq_ok x y). case_eq (beq x y); intuition.
    rewrite H1 in H4. discr.
  Defined.

  Lemma dec_beq : forall x y : A, {x=y}+{~x=y}.

  Proof.
    intros. set (b := beq x y). case_eq b; intros.
    left. exact (proj1 (beq_ok x y) H).
    right. intro. unfold b in H. subst. rewrite beq_refl in H. discr.
  Defined.

  Lemma beq_com : forall x y, beq x y = beq y x.

  Proof.
    intros. case_eq (beq x y); intros; sym.
    rewrite beq_ok. sym. rewrite <- beq_ok. hyp.
    rewrite beq_ko. cut (x<>y). auto. rewrite <- beq_ko. hyp.
  Qed.

  Lemma beq_sym : forall x y, beq x y = true -> beq y x = true.

  Proof. intros. rewrite beq_com. exact H. Qed.

  Lemma beq_trans : forall x y z,
    beq x y = true -> beq y z = true -> beq x z = true.

  Proof.
    intros. rewrite beq_ok in H. rewrite beq_ok in H0.
    assert (x = z). apply trans_eq with y; hyp.
    rewrite beq_ok. exact H1.
  Qed.

End beq.

Implicit Arguments beq_refl [A beq].
Implicit Arguments dec_beq [A beq].
Implicit Arguments beq_com [A beq].
Implicit Arguments beq_ko [A beq].

Ltac case_beq beq beq_ok x y := case_eq (beq x y);
  [let h := fresh in intro h; rewrite beq_ok in h;
    match type of h with ?x = ?y => subst y end
    | intro].

(***********************************************************************)
(** Boolean function testing Leibniz equality when it is decidable. *)

Section eq_dec.

  Variable A : Type.
  Variable eq_dec : forall x y : A, {x=y}+{~x=y}.

  Definition beq_dec x y :=
    match eq_dec x y with
      | left _ => true
      | right _ => false
    end.

  Lemma beq_dec_ok : forall x y, beq_dec x y = true <-> x = y.

  Proof. intros. unfold beq_dec. case (eq_dec x y); intuition. discr. Qed.

  Lemma beq_dec_refl : forall x, beq_dec x x = true.

  Proof. intro. unfold beq_dec. case (eq_dec x x); intros. refl. irrefl. Qed.

  Lemma beq_dec_sym : forall x y, beq_dec x y = beq_dec y x.

  Proof.
    intros. unfold beq_dec. case (eq_dec x y); case (eq_dec y x); intros;
    (refl || irrefl).
  Qed.

  Lemma beq_dec_trans : forall x y z,
    implb (beq_dec x y && beq_dec y z) (beq_dec x z) = true.

  Proof.
    intros. unfold beq_dec.
    case (eq_dec x y); case (eq_dec y z); case (eq_dec x z);
      intros; (refl || (irrefl || idtac)).
  Qed.

  Lemma beq_dec_ko : forall x y, beq_dec x y = false <-> x <> y.

  Proof.
    intros. case (eq_dec x y); case_eq (beq_dec x y); intuition.
    subst y. rewrite beq_dec_refl in H. discr.
    rewrite beq_dec_ok in H. contr.
  Qed.

End eq_dec.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.HoareLogic.ImperativeLanguage.
Require Import Logic.HoareLogic.ProgramState.
Require Import Logic.HoareLogic.BigStepSemantics.
Require Import Logic.HoareLogic.HoareTriple_BigStepSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelSingleNotation.
Import KripkeModelNotation_Intuitionistic.

Section soundness.

Existing Instance unit_kMD.

Context {P: ProgrammingLanguage}
        {MD: Model}
        {BSS: BigStepSemantics P model}.

Context {L: Language}
        {minL: MinimumLanguage L}
        {orpL: OrLanguage L}
        {andpL: AndLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {SM: Semantics L MD}
        {R: Relation model}
        {po_R: PreOrder Krelation}
        {kiSM: KripkeIntuitionisticSemantics L MD (tt: @Kmodel MD (unit_kMD _)) SM}
        {kminSM: KripkeMinimumSemantics L MD (tt: @Kmodel MD (unit_kMD _)) SM}
        {korpSM: KripkeOrSemantics L MD (tt: @Kmodel MD (unit_kMD _)) SM}
        {kandpSM: KripkeAndSemantics L MD (tt: @Kmodel MD (unit_kMD _)) SM}.

Lemma hoare_consequence_partial_sound: forall c P1 P2 Q1 Q2,
  valid (AllModel _) (P2 --> P1) ->
  valid (AllModel _) (Q1 --> Q2) ->
  triple_partial_valid P1 c Q1 ->
  triple_partial_valid P2 c Q2.
Proof.
  intros.
  unfold triple_partial_valid in *.
  intros s ms ? ?.
  specialize (H1 s ms).
  specialize (H (KRIPKE: s) I).
  rewrite sat_impp in H.
  apply (H s) in H2; [| reflexivity].
  specialize (H1 H2 H3); clear H2 H3.
  destruct ms as [| | s']; auto.
  specialize (H0 (KRIPKE: s') I).
  rewrite sat_impp in H0.
  apply (H0 s'); auto.
  reflexivity.
Qed.

Lemma hoare_consequence_total_sound: forall c P1 P2 Q1 Q2,
  valid (AllModel _) (P2 --> P1) ->
  valid (AllModel _) (Q1 --> Q2) ->
  triple_total_valid P1 c Q1 ->
  triple_total_valid P2 c Q2.
Proof.
  intros.
  unfold triple_total_valid in *.
  intros s ms ? ?.
  specialize (H1 s ms).
  specialize (H (KRIPKE: s) I).
  rewrite sat_impp in H.
  apply (H s) in H2; [| reflexivity].
  specialize (H1 H2 H3); clear H2 H3.
  destruct ms as [| | s']; auto.
  specialize (H0 (KRIPKE: s') I).
  rewrite sat_impp in H0.
  apply (H0 s'); auto.
  reflexivity.
Qed.

Lemma hoare_conjunction_partial_sound: forall c P1 P2 Q1 Q2,
    triple_partial_valid P1 c Q1 ->
    triple_partial_valid P2 c Q2 ->
    triple_partial_valid (P1 && P2) c (Q1 && Q2).
Proof.
  intros.
  unfold triple_partial_valid in *.
  intros.
  specialize (H s_pre ms_post).
  specialize (H0 s_pre ms_post).
  rewrite sat_andp in H1. destruct H1.
  apply H in H1; auto.
  apply H0 in H3; auto.
  destruct ms_post; auto.
  apply sat_andp. split; assumption.
Qed.

Lemma hoare_conjuntion_total_sound: forall c P1 P2 Q1 Q2,
    triple_total_valid P1 c Q1 ->
    triple_total_valid P2 c Q2 ->
    triple_total_valid (P1 && P2) c (Q1 && Q2).
Proof.
  intros.
  unfold triple_total_valid in *.
  intros.
  specialize (H s_pre ms_post).
  specialize (H0 s_pre ms_post).
  apply sat_andp in H1. destruct H1.
  apply H in H1; auto.
  apply H0 in H3; auto.
  destruct ms_post; auto.
  apply sat_andp. split; assumption.
Qed.

Lemma hoare_disjunction_parial_sound: forall c P1 P2 Q1 Q2,
    triple_partial_valid P1 c Q1 ->
    triple_partial_valid P2 c Q2 ->
    triple_partial_valid (P1 || P2) c (Q1 || Q2).
Proof.
  intros.
  unfold triple_partial_valid in *.
  intros.
  specialize (H s_pre ms_post).
  specialize (H0 s_pre ms_post).
  rewrite sat_orp in H1. destruct H1.
  - apply H in H1; auto.
    destruct ms_post; auto.
    apply sat_orp. left. assumption.
  - apply H0 in H1; auto.
    destruct ms_post; auto.
    apply sat_orp. right. assumption.
Qed.

Lemma hoare_disjunction_total_sound: forall c P1 P2 Q1 Q2,
    triple_total_valid P1 c Q1 ->
    triple_total_valid P2 c Q2 ->
    triple_total_valid (P1 || P2) c (Q1 || Q2).
Proof.
  intros.
  unfold triple_total_valid in *.
  intros.
  specialize (H s_pre ms_post).
  specialize (H0 s_pre ms_post).
  rewrite sat_orp in H1. destruct H1.
  - apply H in H1; auto.
    destruct ms_post; auto.
    rewrite sat_orp. left. assumption.
  - apply H0 in H1; auto.
    destruct ms_post; auto.
    rewrite sat_orp. right. assumption.
Qed.

End soundness.


Require Import AutoSep.
Require Import List.

Require Import SepHintsUtil.

Set Implicit Arguments.

Section TopSection.

  Local Open Scope nat.

  Definition splittable A (ls : list A) pos := pos <= length ls.

  Definition array_to_split ls p (_ : nat) := array ls p.

  Lemma replace_array_to_split : forall ls p pos, array ls p = array_to_split ls p pos.
    eauto.
  Qed.

  Opaque mult.

  Lemma array_split : forall ls p pos, splittable ls pos -> array_to_split ls p pos ===> array (firstn pos ls) p * array (skipn pos ls) (p ^+ $(4 * pos)).
    intros.
    eapply Himp_trans; [ apply ptsto32m'_in | ].
    eapply Himp_trans; [ | apply Himp_star_frame; apply ptsto32m'_out ].
    apply ptsto32m'_split; auto.
  Qed.

  Definition to_elim (_ : list W) := True.

  Lemma array_elim : forall ls p, to_elim ls -> array ls p ===> p =?> length ls.
    intros.
    eapply Himp_trans; [ apply ptsto32m'_in | ].
    eapply Himp_trans; [ apply ptsto32m'_elim | ].
    replace (p ^+ $0) with p by words.
    apply Himp_refl.
  Qed.

  Definition buf_to_split p len (_ : nat) := (p =?> len)%Sep.

  Definition buf_splittable (len pos : nat) := pos <= len.

  Lemma buf_split_bwd : forall p len pos, buf_splittable len pos -> p =?> pos * (p ^+ $(4 * pos)) =?> (len - pos) ===> buf_to_split p len pos.
    intros.
    eapply Himp_trans; [ | apply allocated_join ].
    apply Himp_star_frame.
    apply Himp_refl.
    2: auto.
    apply allocated_shift_base; auto.
    rewrite <- wplus_assoc.
    do 2 f_equal.
    rewrite <- natToWord_plus.
    f_equal; omega.
  Qed.

  Definition hints_array_split : TacPackage.
    prepare array_split tt.
  Defined.

  Definition hints_array_elim : TacPackage.
    prepare array_elim tt.
  Defined.

  Definition hints_buf_split_bwd : TacPackage.
    prepare tt buf_split_bwd.
  Defined.

End TopSection.