From Hammer Require Import Hammer.

From compcert Require Import Coqlib.
From compcert Require Import Iteration.
From compcert Require Import Maps.
From compcert Require Import Lattice.

Local Unset Elimination Schemes.
Local Unset Case Analysis Schemes.

Module Type DATAFLOW_SOLVER.

Declare Module L: SEMILATTICE.

Parameter fixpoint:
forall {A: Type} (code: PTree.t A) (successors: A -> list positive)
(transf: positive -> L.t -> L.t)
(ep: positive) (ev: L.t),
option (PMap.t L.t).

Axiom fixpoint_solution:
forall A (code: PTree.t A) successors transf ep ev res n instr s,
fixpoint code successors transf ep ev = Some res ->
code!n = Some instr -> In s (successors instr) ->
(forall n, L.eq (transf n L.bot) L.bot) ->
L.ge res!!s (transf n res!!n).

Axiom fixpoint_entry:
forall A (code: PTree.t A) successors transf ep ev res,
fixpoint code successors transf ep ev = Some res ->
L.ge res!!ep ev.

Axiom fixpoint_invariant:
forall A (code: PTree.t A) successors transf ep ev
(P: L.t -> Prop),
P L.bot ->
(forall x y, P x -> P y -> P (L.lub x y)) ->
(forall pc instr x, code!pc = Some instr -> P x -> P (transf pc x)) ->
P ev ->
forall res pc,
fixpoint code successors transf ep ev = Some res ->
P res!!pc.

End DATAFLOW_SOLVER.

Module Type NODE_SET.

Parameter t: Type.
Parameter empty: t.
Parameter add: positive -> t -> t.
Parameter pick: t -> option (positive * t).
Parameter all_nodes: forall {A: Type}, PTree.t A -> t.

Parameter In: positive -> t -> Prop.
Axiom empty_spec:
forall n, ~In n empty.
Axiom add_spec:
forall n n' s, In n' (add n s) <-> n = n' \/ In n' s.
Axiom pick_none:
forall s n, pick s = None -> ~In n s.
Axiom pick_some:
forall s n s', pick s = Some(n, s') ->
forall n', In n' s <-> n = n' \/ In n' s'.
Axiom all_nodes_spec:
forall A (code: PTree.t A) n instr,
code!n = Some instr -> In n (all_nodes code).

End NODE_SET.

Section REACHABLE.

Context {A: Type} (code: PTree.t A) (successors: A -> list positive).

Inductive reachable: positive -> positive -> Prop :=
| reachable_refl: forall n, reachable n n
| reachable_left: forall n1 n2 n3 i,
code!n1 = Some i -> In n2 (successors i) -> reachable n2 n3 ->
reachable n1 n3.

Scheme reachable_ind := Induction for reachable Sort Prop.

Lemma reachable_trans:
forall n1 n2, reachable n1 n2 -> forall n3, reachable n2 n3 -> reachable n1 n3.
Proof. hammer_hook "Kildall" "Kildall.reachable_trans".
induction 1; intros.
- auto.
- econstructor; eauto.
Qed.

Lemma reachable_right:
forall n1 n2 n3 i,
reachable n1 n2 -> code!n2 = Some i -> In n3 (successors i) ->
reachable n1 n3.
Proof. hammer_hook "Kildall" "Kildall.reachable_right".
intros. apply reachable_trans with n2; auto. econstructor; eauto. constructor.
Qed.

End REACHABLE.

Module Dataflow_Solver (LAT: SEMILATTICE) (NS: NODE_SET) <:
DATAFLOW_SOLVER with Module L := LAT.

Module L := LAT.

Section Kildall.

Context {A: Type}.
Variable code: PTree.t A.
Variable successors: A -> list positive.
Variable transf: positive -> L.t -> L.t.

Record state : Type :=
mkstate { aval: PTree.t L.t; worklist: NS.t; visited: positive -> Prop }.

Definition abstr_value (n: positive) (s: state) : L.t :=
match s.(aval)!n with
| None => L.bot
| Some v => v
end.

Definition propagate_succ (s: state) (out: L.t) (n: positive) :=
match s.(aval)!n with
| None =>
{| aval := PTree.set n out s.(aval);
worklist := NS.add n s.(worklist);
visited := fun p => p = n \/ s.(visited) p |}
| Some oldl =>
let newl := L.lub oldl out in
if L.beq oldl newl
then s
else {| aval := PTree.set n newl s.(aval);
worklist := NS.add n s.(worklist);
visited := fun p => p = n \/ s.(visited) p |}
end.

Fixpoint propagate_succ_list (s: state) (out: L.t) (succs: list positive)
{struct succs} : state :=
match succs with
| nil => s
| n :: rem => propagate_succ_list (propagate_succ s out n) out rem
end.

Definition step (s: state) : PMap.t L.t + state :=
match NS.pick s.(worklist) with
| None =>
inl _ (L.bot, s.(aval))
| Some(n, rem) =>
match code!n with
| None =>
inr _ {| aval := s.(aval); worklist := rem; visited := s.(visited) |}
| Some instr =>
inr _ (propagate_succ_list
{| aval := s.(aval); worklist := rem; visited := s.(visited) |}
(transf n (abstr_value n s))
(successors instr))
end
end.

Definition fixpoint_from (start: state) : option (PMap.t L.t) :=
PrimIter.iterate _ _ step start.

Definition start_state (enode: positive) (eval: L.t) :=
{| aval := PTree.set enode eval (PTree.empty L.t);
worklist := NS.add enode NS.empty;
visited := fun n => n = enode |}.

Definition fixpoint (enode: positive) (eval: L.t) :=
fixpoint_from (start_state enode eval).

Definition start_state_nodeset (enodes: NS.t) :=
{| aval := PTree.empty L.t;
worklist := enodes;
visited := fun n => NS.In n enodes |}.

Definition fixpoint_nodeset (enodes: NS.t) :=
fixpoint_from (start_state_nodeset enodes).

Definition start_state_allnodes :=
{| aval := PTree.empty L.t;
worklist := NS.all_nodes code;
visited := fun n => exists instr, code!n = Some instr |}.

Definition fixpoint_allnodes :=
fixpoint_from start_state_allnodes.

Inductive optge: option L.t -> option L.t -> Prop :=
| optge_some: forall l l',
L.ge l l' -> optge (Some l) (Some l')
| optge_none: forall ol,
optge ol None.

Remark optge_refl: forall ol, optge ol ol.
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.optge_refl". destruct ol; constructor. apply L.ge_refl; apply L.eq_refl. Qed.

Remark optge_trans: forall ol1 ol2 ol3, optge ol1 ol2 -> optge ol2 ol3 -> optge ol1 ol3.
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.optge_trans".
intros. inv H0.
inv H. constructor. eapply L.ge_trans; eauto.
constructor.
Qed.

Remark optge_abstr_value:
forall st st' n,
optge st.(aval)!n st'.(aval)!n ->
L.ge (abstr_value n st) (abstr_value n st').
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.optge_abstr_value".
intros. unfold abstr_value. inv H. auto. apply L.ge_bot.
Qed.

Lemma propagate_succ_charact:
forall st out n,
let st' := propagate_succ st out n in
optge st'.(aval)!n (Some out)
/\ (forall s, n <> s -> st'.(aval)!s = st.(aval)!s)
/\ (forall s, optge st'.(aval)!s st.(aval)!s)
/\ (NS.In n st'.(worklist) \/ st'.(aval)!n = st.(aval)!n)
/\ (forall n', NS.In n' st.(worklist) -> NS.In n' st'.(worklist))
/\ (forall n', NS.In n' st'.(worklist) -> n' = n \/ NS.In n' st.(worklist))
/\ (forall n', st.(visited) n' -> st'.(visited) n')
/\ (forall n', st'.(visited) n' -> NS.In n' st'.(worklist) \/ st.(visited) n')
/\ (forall n', st.(aval)!n' = None -> st'.(aval)!n' <> None -> st'.(visited) n').
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.propagate_succ_charact".
unfold propagate_succ; intros; simpl.
destruct st.(aval)!n as [v|] eqn:E;
[predSpec L.beq L.beq_correct v (L.lub v out) | idtac].
-
repeat split; intros.
+ rewrite E. constructor. eapply L.ge_trans. apply L.ge_refl. apply H; auto. apply L.ge_lub_right.
+ apply optge_refl.
+ right; auto.
+ auto.
+ auto.
+ auto.
+ auto.
+ congruence.
-
simpl; repeat split; intros.
+ rewrite PTree.gss. constructor. apply L.ge_lub_right.
+ rewrite PTree.gso by auto. auto.
+ rewrite PTree.gsspec. destruct (peq s n).
subst s. rewrite E. constructor. apply L.ge_lub_left.
apply optge_refl.
+ rewrite NS.add_spec. auto.
+ rewrite NS.add_spec. auto.
+ rewrite NS.add_spec in H0. intuition.
+ auto.
+ destruct H0; auto. subst n'. rewrite NS.add_spec; auto.
+ rewrite PTree.gsspec in H1. destruct (peq n' n). auto. congruence.
-
simpl; repeat split; intros.
+ rewrite PTree.gss. apply optge_refl.
+ rewrite PTree.gso by auto. auto.
+ rewrite PTree.gsspec. destruct (peq s n).
subst s. rewrite E. constructor.
apply optge_refl.
+ rewrite NS.add_spec. auto.
+ rewrite NS.add_spec. auto.
+ rewrite NS.add_spec in H. intuition.
+ auto.
+ destruct H; auto. subst n'. rewrite NS.add_spec. auto.
+ rewrite PTree.gsspec in H0. destruct (peq n' n). auto. congruence.
Qed.

Lemma propagate_succ_list_charact:
forall out l st,
let st' := propagate_succ_list st out l in
(forall n, In n l -> optge st'.(aval)!n (Some out))
/\ (forall n, ~In n l -> st'.(aval)!n = st.(aval)!n)
/\ (forall n, optge st'.(aval)!n st.(aval)!n)
/\ (forall n, NS.In n st'.(worklist) \/ st'.(aval)!n = st.(aval)!n)
/\ (forall n', NS.In n' st.(worklist) -> NS.In n' st'.(worklist))
/\ (forall n', NS.In n' st'.(worklist) -> In n' l \/ NS.In n' st.(worklist))
/\ (forall n', st.(visited) n' -> st'.(visited) n')
/\ (forall n', st'.(visited) n' -> NS.In n' st'.(worklist) \/ st.(visited) n')
/\ (forall n', st.(aval)!n' = None -> st'.(aval)!n' <> None -> st'.(visited) n').
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.propagate_succ_list_charact".
induction l; simpl; intros.
- repeat split; intros.
+ contradiction.
+ apply optge_refl.
+ auto.
+ auto.
+ auto.
+ auto.
+ auto.
+ congruence.
- generalize (propagate_succ_charact st out a).
set (st1 := propagate_succ st out a).
intros (A1 & A2 & A3 & A4 & A5 & A6 & A7 & A8 & A9).
generalize (IHl st1).
set (st2 := propagate_succ_list st1 out l).
intros (B1 & B2 & B3 & B4 & B5 & B6 & B7 & B8 & B9). clear IHl.
repeat split; intros.
+ destruct H.
* subst n. eapply optge_trans; eauto.
* auto.
+ rewrite B2 by tauto. apply A2; tauto.
+ eapply optge_trans; eauto.
+ destruct (B4 n). auto.
destruct (peq n a).
* subst n. destruct A4. left; auto. right; congruence.
* right. rewrite H. auto.
+ eauto.
+ exploit B6; eauto. intros [P|P]. auto.
exploit A6; eauto. intuition.
+ eauto.
+ specialize (B8 n'); specialize (A8 n'). intuition.
+ destruct st1.(aval)!n' eqn:ST1.
apply B7. apply A9; auto. congruence.
apply B9; auto.
Qed.

Inductive steps: state -> state -> Prop :=
| steps_base: forall s, steps s s
| steps_right: forall s1 s2 s3, steps s1 s2 -> step s2 = inr s3 -> steps s1 s3.

Scheme steps_ind := Induction for steps Sort Prop.

Lemma fixpoint_from_charact:
forall start res,
fixpoint_from start = Some res ->
exists st, steps start st /\ NS.pick st.(worklist) = None /\ res = (L.bot, st.(aval)).
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.fixpoint_from_charact".
unfold fixpoint; intros.
eapply (PrimIter.iterate_prop _ _ step
(fun st => steps start st)
(fun res => exists st, steps start st /\ NS.pick (worklist st) = None /\ res = (L.bot, aval st))); eauto.
intros. destruct (step a) eqn:E.
exists a; split; auto.
unfold step in E. destruct (NS.pick (worklist a)) as [[n rem]|].
destruct (code!n); discriminate.
inv E. auto.
eapply steps_right; eauto.
constructor.
Qed.

Lemma step_incr:
forall n s1 s2, step s1 = inr s2 ->
optge s2.(aval)!n s1.(aval)!n /\ (s1.(visited) n -> s2.(visited) n).
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.step_incr".
unfold step; intros.
destruct (NS.pick (worklist s1)) as [[p rem] | ]; try discriminate.
destruct (code!p) as [instr|]; inv H.
+ generalize (propagate_succ_list_charact
(transf p (abstr_value p s1))
(successors instr)
{| aval := aval s1; worklist := rem; visited := visited s1 |}).
simpl.
set (s' := propagate_succ_list {| aval := aval s1; worklist := rem; visited := visited s1 |}
(transf p (abstr_value p s1)) (successors instr)).
intros (A1 & A2 & A3 & A4 & A5 & A6 & A7 & A8 & A9).
auto.
+ split. apply optge_refl. auto.
Qed.

Lemma steps_incr:
forall n s1 s2, steps s1 s2 ->
optge s2.(aval)!n s1.(aval)!n /\ (s1.(visited) n -> s2.(visited) n).
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.steps_incr".
induction 1.
- split. apply optge_refl. auto.
- destruct IHsteps. exploit (step_incr n); eauto. intros [P Q].
split. eapply optge_trans; eauto. eauto.
Qed.

Record good_state (st: state) : Prop := {
gs_stable: forall n,
st.(visited) n ->
NS.In n st.(worklist) \/
(forall i s,
code!n = Some i -> In s (successors i) ->
optge st.(aval)!s (Some (transf n (abstr_value n st))));
gs_defined: forall n v,
st.(aval)!n = Some v -> st.(visited) n
}.

Lemma step_state_good:
forall st pc rem instr,
NS.pick st.(worklist) = Some (pc, rem) ->
code!pc = Some instr ->
good_state st ->
good_state (propagate_succ_list (mkstate st.(aval) rem st.(visited))
(transf pc (abstr_value pc st))
(successors instr)).
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.step_state_good".
intros until instr; intros PICK CODEAT [GOOD1 GOOD2].
generalize (NS.pick_some _ _ _ PICK); intro PICK2.
set (out := transf pc (abstr_value pc st)).
generalize (propagate_succ_list_charact out (successors instr) {| aval := aval st; worklist := rem; visited := visited st |}).
set (st' := propagate_succ_list {| aval := aval st; worklist := rem; visited := visited st |} out
(successors instr)).
simpl; intros (A1 & A2 & A3 & A4 & A5 & A6 & A7 & A8 & A9).
constructor; intros.
-
destruct (A8 n H); auto. destruct (A4 n); auto.
replace (abstr_value n st') with (abstr_value n st)
by (unfold abstr_value; rewrite H1; auto).
exploit GOOD1; eauto. intros [P|P].
+
rewrite PICK2 in P; destruct P.
*
subst n. fold out. right; intros.
assert (i = instr) by congruence. subst i.
apply A1; auto.
*
left. apply A5; auto.
+
right; intros. apply optge_trans with st.(aval)!s; eauto.
-
destruct st.(aval)!n as [v'|] eqn:ST.
+ apply A7. eapply GOOD2; eauto.
+ apply A9; auto. congruence.
Qed.

Lemma step_state_good_2:
forall st pc rem,
good_state st ->
NS.pick (worklist st) = Some (pc, rem) ->
code!pc = None ->
good_state (mkstate st.(aval) rem st.(visited)).
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.step_state_good_2".
intros until rem; intros [GOOD1 GOOD2] PICK CODE.
generalize (NS.pick_some _ _ _ PICK); intro PICK2.
constructor; simpl; intros.
-
exploit GOOD1; eauto. intros [P | P].
+ rewrite PICK2 in P. destruct P; auto.
subst n. right; intros. congruence.
+ right; exact P.
-
eapply GOOD2; eauto.
Qed.

Lemma steps_state_good:
forall st1 st2, steps st1 st2 -> good_state st1 -> good_state st2.
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.steps_state_good".
induction 1; intros.
- auto.
- unfold step in e.
destruct (NS.pick (worklist s2)) as [[n rem] | ] eqn:PICK; try discriminate.
destruct (code!n) as [instr|] eqn:CODE; inv e.
eapply step_state_good; eauto.
eapply step_state_good_2; eauto.
Qed.

Lemma start_state_good:
forall enode eval, good_state (start_state enode eval).
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.start_state_good".
intros. unfold start_state; constructor; simpl; intros.
- subst n. rewrite NS.add_spec; auto.
- rewrite PTree.gsspec in H. rewrite PTree.gempty in H.
destruct (peq n enode). auto. discriminate.
Qed.

Lemma start_state_nodeset_good:
forall enodes, good_state (start_state_nodeset enodes).
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.start_state_nodeset_good".
intros. unfold start_state_nodeset; constructor; simpl; intros.
- left. auto.
- rewrite PTree.gempty in H. congruence.
Qed.

Lemma start_state_allnodes_good:
good_state start_state_allnodes.
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.start_state_allnodes_good".
unfold start_state_allnodes; constructor; simpl; intros.
- destruct H as [instr CODE]. left. eapply NS.all_nodes_spec; eauto.
- rewrite PTree.gempty in H. congruence.
Qed.

Lemma reachable_visited:
forall st, good_state st -> NS.pick st.(worklist) = None ->
forall p q, reachable code successors p q -> st.(visited) p -> st.(visited) q.
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.reachable_visited".
intros st [GOOD1 GOOD2] PICK. induction 1; intros.
- auto.
- eapply IHreachable; eauto.
exploit GOOD1; eauto. intros [P | P].
eelim NS.pick_none; eauto.
exploit P; eauto. intros OGE; inv OGE. eapply GOOD2; eauto.
Qed.

Theorem fixpoint_solution:
forall ep ev res n instr s,
fixpoint ep ev = Some res ->
code!n = Some instr ->
In s (successors instr) ->
(forall n, L.eq (transf n L.bot) L.bot) ->
L.ge res!!s (transf n res!!n).
Proof. hammer_hook "Kildall" "Kildall.DATAFLOW_SOLVER.fixpoint_solution".
unfold fixpoint; intros.
exploit fixpoint_from_charact; eauto. intros (st & STEPS & PICK & RES).
exploit steps_state_good; eauto. apply start_state_good. intros [GOOD1 GOOD2].
rewrite RES; unfold PMap.get; simpl.
destruct st.(aval)!n as [v|] eqn:STN.
- destruct (GOOD1 n) as [P|P]; eauto.
eelim NS.pick_none; eauto.
exploit P; eauto. unfold abstr_value; rewrite STN. intros OGE; inv OGE. auto.
- apply L.ge_trans with L.bot. apply L.ge_bot. apply L.ge_refl. apply L.eq_sym. eauto.
Qed.

Theorem fixpoint_entry:
forall ep ev res,
fixpoint ep ev = Some res ->
L.ge res!!ep ev.
Proof. hammer_hook "Kildall" "Kildall.DATAFLOW_SOLVER.fixpoint_entry".
unfold fixpoint; intros.
exploit fixpoint_from_charact; eauto. intros (st & STEPS & PICK & RES).
exploit (steps_incr ep); eauto. simpl. rewrite PTree.gss. intros [P Q].
rewrite RES; unfold PMap.get; simpl. inv P; auto.
Qed.

Theorem fixpoint_allnodes_solution:
forall res n instr s,
fixpoint_allnodes = Some res ->
code!n = Some instr ->
In s (successors instr) ->
L.ge res!!s (transf n res!!n).
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.fixpoint_allnodes_solution".
unfold fixpoint_allnodes; intros.
exploit fixpoint_from_charact; eauto. intros (st & STEPS & PICK & RES).
exploit steps_state_good; eauto. apply start_state_allnodes_good. intros [GOOD1 GOOD2].
exploit (steps_incr n); eauto. simpl. intros [U V].
exploit (GOOD1 n). apply V. exists instr; auto. intros [P|P].
eelim NS.pick_none; eauto.
exploit P; eauto. intros OGE. rewrite RES; unfold PMap.get; simpl.
inv OGE. assumption.
Qed.

Theorem fixpoint_nodeset_solution:
forall enodes res e n instr s,
fixpoint_nodeset enodes = Some res ->
NS.In e enodes ->
reachable code successors e n ->
code!n = Some instr ->
In s (successors instr) ->
L.ge res!!s (transf n res!!n).
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.fixpoint_nodeset_solution".
unfold fixpoint_nodeset; intros.
exploit fixpoint_from_charact; eauto. intros (st & STEPS & PICK & RES).
exploit steps_state_good; eauto. apply start_state_nodeset_good. intros GOOD.
exploit (steps_incr e); eauto. simpl. intros [U V].
assert (st.(visited) n).
{ eapply reachable_visited; eauto. }
destruct GOOD as [GOOD1 GOOD2].
exploit (GOOD1 n); eauto. intros [P|P].
eelim NS.pick_none; eauto.
exploit P; eauto. intros OGE. rewrite RES; unfold PMap.get; simpl.
inv OGE. assumption.
Qed.

Theorem fixpoint_invariant:
forall ep ev
(P: L.t -> Prop)
(P_bot: P L.bot)
(P_lub: forall x y, P x -> P y -> P (L.lub x y))
(P_transf: forall pc instr x, code!pc = Some instr -> P x -> P (transf pc x))
(P_entrypoint: P ev)
res pc,
fixpoint ep ev = Some res ->
P res!!pc.
Proof. hammer_hook "Kildall" "Kildall.DATAFLOW_SOLVER.fixpoint_invariant".
intros.
set (inv := fun st => forall x, P (abstr_value x st)).
assert (inv (start_state ep ev)).
{
red; simpl; intros. unfold abstr_value, start_state; simpl.
rewrite PTree.gsspec. rewrite PTree.gempty.
destruct (peq x ep). auto. auto.
}
assert (forall st v n, inv st -> P v -> inv (propagate_succ st v n)).
{
unfold inv, propagate_succ. intros.
destruct (aval st)!n as [oldl|] eqn:E.
destruct (L.beq oldl (L.lub oldl v)).
auto.
unfold abstr_value. simpl. rewrite PTree.gsspec. destruct (peq x n).
apply P_lub; auto. replace oldl with (abstr_value n st). auto.
unfold abstr_value; rewrite E; auto.
apply H1.
unfold abstr_value. simpl. rewrite PTree.gsspec. destruct (peq x n).
auto.
apply H1.
}
assert (forall l st v, inv st -> P v -> inv (propagate_succ_list st v l)).
{
induction l; intros; simpl. auto.
apply IHl; auto.
}
assert (forall st1 st2, steps st1 st2 -> inv st1 -> inv st2).
{
induction 1; intros.
auto.
unfold step in e. destruct (NS.pick (worklist s2)) as [[n rem]|]; try discriminate.
destruct (code!n) as [instr|] eqn:INSTR; inv e.
apply H2. apply IHsteps; auto. eapply P_transf; eauto. apply IHsteps; auto.
apply IHsteps; auto.
}
unfold fixpoint in H. exploit fixpoint_from_charact; eauto.
intros (st & STEPS & PICK & RES).
replace (res!!pc) with (abstr_value pc st). eapply H3; eauto.
rewrite RES; auto.
Qed.

End Kildall.

End Dataflow_Solver.

Definition successors_list (successors: PTree.t (list positive)) (pc: positive) : list positive :=
match successors!pc with None => nil | Some l => l end.

Notation "a !!! b" := (successors_list a b) (at level 1).

Section Predecessor.

Context {A: Type}.
Variable code: PTree.t A.
Variable successors: A -> list positive.

Fixpoint add_successors (pred: PTree.t (list positive))
(from: positive) (tolist: list positive)
{struct tolist} : PTree.t (list positive) :=
match tolist with
| nil => pred
| to :: rem => add_successors (PTree.set to (from :: pred!!!to) pred) from rem
end.

Lemma add_successors_correct:
forall tolist from pred n s,
In n pred!!!s \/ (n = from /\ In s tolist) ->
In n (add_successors pred from tolist)!!!s.
Proof. hammer_hook "Kildall" "Kildall.add_successors_correct".
induction tolist; simpl; intros.
tauto.
apply IHtolist.
unfold successors_list at 1. rewrite PTree.gsspec. destruct (peq s a).
subst a. destruct H. auto with coqlib.
destruct H. subst n. auto with coqlib.
fold (successors_list pred s). intuition congruence.
Qed.

Definition make_predecessors : PTree.t (list positive) :=
PTree.fold (fun pred pc instr => add_successors pred pc (successors instr))
code (PTree.empty (list positive)).

Lemma make_predecessors_correct_1:
forall n instr s,
code!n = Some instr -> In s (successors instr) ->
In n make_predecessors!!!s.
Proof. hammer_hook "Kildall" "Kildall.make_predecessors_correct_1".
intros until s.
set (P := fun m p => m!n = Some instr -> In s (successors instr) ->
In n p!!!s).
unfold make_predecessors.
apply PTree_Properties.fold_rec with (P := P); unfold P; intros.

apply H0; auto. rewrite H; auto.

rewrite PTree.gempty in H; congruence.

apply add_successors_correct.
rewrite PTree.gsspec in H2. destruct (peq n k).
inv H2. auto.
auto.
Qed.

Lemma make_predecessors_correct_2:
forall n instr s,
code!n = Some instr -> In s (successors instr) ->
exists l, make_predecessors!s = Some l /\ In n l.
Proof. hammer_hook "Kildall" "Kildall.make_predecessors_correct_2".
intros. exploit make_predecessors_correct_1; eauto.
unfold successors_list. destruct (make_predecessors!s); simpl; intros.
exists l; auto.
contradiction.
Qed.

Lemma reachable_predecessors:
forall p q,
reachable code successors p q ->
reachable make_predecessors (fun l => l) q p.
Proof. hammer_hook "Kildall" "Kildall.reachable_predecessors".
induction 1.
- constructor.
- exploit make_predecessors_correct_2; eauto. intros [l [P Q]].
eapply reachable_right; eauto.
Qed.

End Predecessor.

Module Type BACKWARD_DATAFLOW_SOLVER.

Declare Module L: SEMILATTICE.

Parameter fixpoint:
forall {A: Type} (code: PTree.t A) (successors: A -> list positive)
(transf: positive -> L.t -> L.t),
option (PMap.t L.t).

Axiom fixpoint_solution:
forall A (code: PTree.t A) successors transf res n instr s,
fixpoint code successors transf = Some res ->
code!n = Some instr -> In s (successors instr) ->
(forall n a, code!n = None -> L.eq (transf n a) L.bot) ->
L.ge res!!n (transf s res!!s).

Parameter fixpoint_allnodes:
forall {A: Type} (code: PTree.t A) (successors: A -> list positive)
(transf: positive -> L.t -> L.t),
option (PMap.t L.t).

Axiom fixpoint_allnodes_solution:
forall A (code: PTree.t A) successors transf res n instr s,
fixpoint_allnodes code successors transf = Some res ->
code!n = Some instr -> In s (successors instr) ->
L.ge res!!n (transf s res!!s).

End BACKWARD_DATAFLOW_SOLVER.

Module Backward_Dataflow_Solver (LAT: SEMILATTICE) (NS: NODE_SET):
BACKWARD_DATAFLOW_SOLVER with Module L := LAT.

Module L := LAT.

Module DS := Dataflow_Solver L NS.

Section Kildall.

Context {A: Type}.
Variable code: PTree.t A.
Variable successors: A -> list positive.
Variable transf: positive -> L.t -> L.t.

Section Exit_points.

Definition sequential_node (pc: positive) (instr: A): bool :=
existsb (fun s => match code!s with None => false | Some _ => plt s pc end)
(successors instr).

Definition exit_points : NS.t :=
PTree.fold
(fun ep pc instr =>
if sequential_node pc instr
then ep
else NS.add pc ep)
code NS.empty.

Lemma exit_points_charact:
forall n,
NS.In n exit_points <-> exists i, code!n = Some i /\ sequential_node n i = false.
Proof. hammer_hook "Kildall" "Kildall.Backward_Dataflow_Solver.exit_points_charact".
intros n. unfold exit_points. eapply PTree_Properties.fold_rec.
-
intros. rewrite <- H. auto.
-
simpl. split; intros.
eelim NS.empty_spec; eauto.
destruct H as [i [P Q]]. rewrite PTree.gempty in P. congruence.
-
intros. destruct (sequential_node k v) eqn:SN.
+ rewrite H1. rewrite PTree.gsspec. destruct (peq n k).
subst. split; intros [i [P Q]]. congruence. inv P. congruence.
tauto.
+ rewrite NS.add_spec. rewrite H1. rewrite PTree.gsspec. destruct (peq n k).
subst. split. intros. exists v; auto. auto.
split. intros [P | [i [P Q]]]. congruence. exists i; auto.
intros [i [P Q]]. right; exists i; auto.
Qed.

Lemma reachable_exit_points:
forall pc i,
code!pc = Some i -> exists x, NS.In x exit_points /\ reachable code successors pc x.
Proof. hammer_hook "Kildall" "Kildall.Backward_Dataflow_Solver.reachable_exit_points".
intros pc0. pattern pc0. apply (well_founded_ind Plt_wf).
intros pc HR i CODE.
destruct (sequential_node pc i) eqn:SN.
-
unfold sequential_node in SN. rewrite existsb_exists in SN.
destruct SN as [s [P Q]]. destruct (code!s) as [i'|] eqn:CS; try discriminate. InvBooleans.
exploit (HR s); eauto. intros [x [U V]].
exists x; split; auto. eapply reachable_left; eauto.
-
exists pc; split.
rewrite exit_points_charact. exists i; auto. constructor.
Qed.

Lemma reachable_exit_points_predecessor:
forall pc i,
code!pc = Some i ->
exists x, NS.In x exit_points /\ reachable (make_predecessors code successors) (fun l => l) x pc.
Proof. hammer_hook "Kildall" "Kildall.Backward_Dataflow_Solver.reachable_exit_points_predecessor".
intros. exploit reachable_exit_points; eauto. intros [x [P Q]].
exists x; split; auto. apply reachable_predecessors. auto.
Qed.

End Exit_points.

Definition fixpoint :=
DS.fixpoint_nodeset
(make_predecessors code successors) (fun l => l)
transf exit_points.

Theorem fixpoint_solution:
forall res n instr s,
fixpoint = Some res ->
code!n = Some instr -> In s (successors instr) ->
(forall n a, code!n = None -> L.eq (transf n a) L.bot) ->
L.ge res!!n (transf s res!!s).
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.fixpoint_solution".
intros.
exploit (make_predecessors_correct_2 code); eauto. intros [l [P Q]].
destruct code!s as [instr'|] eqn:CS.
- exploit reachable_exit_points_predecessor. eexact CS. intros (ep & U & V).
unfold fixpoint in H. eapply DS.fixpoint_nodeset_solution; eauto.
- apply L.ge_trans with L.bot. apply L.ge_bot.
apply L.ge_refl. apply L.eq_sym. auto.
Qed.

Definition fixpoint_allnodes :=
DS.fixpoint_allnodes
(make_predecessors code successors) (fun l => l)
transf.

Theorem fixpoint_allnodes_solution:
forall res n instr s,
fixpoint_allnodes = Some res ->
code!n = Some instr -> In s (successors instr) ->
L.ge res!!n (transf s res!!s).
Proof. hammer_hook "Kildall" "Kildall.BACKWARD_DATAFLOW_SOLVER.fixpoint_allnodes_solution".
intros.
exploit (make_predecessors_correct_2 code); eauto. intros [l [P Q]].
unfold fixpoint_allnodes in H.
eapply DS.fixpoint_allnodes_solution; eauto.
Qed.

End Kildall.

End Backward_Dataflow_Solver.

Module Type ORDERED_TYPE_WITH_TOP.

Parameter t: Type.
Parameter ge: t -> t -> Prop.
Parameter top: t.
Axiom top_ge: forall x, ge top x.
Axiom refl_ge: forall x, ge x x.

End ORDERED_TYPE_WITH_TOP.

Module Type BBLOCK_SOLVER.

Declare Module L: ORDERED_TYPE_WITH_TOP.

Parameter fixpoint:
forall {A: Type} (code: PTree.t A) (successors: A -> list positive)
(transf: positive -> L.t -> L.t)
(entrypoint: positive),
option (PMap.t L.t).

Axiom fixpoint_solution:
forall A (code: PTree.t A) successors transf entrypoint res n instr s,
fixpoint code successors transf entrypoint = Some res ->
code!n = Some instr -> In s (successors instr) ->
L.ge res!!s (transf n res!!n).

Axiom fixpoint_entry:
forall A (code: PTree.t A) successors transf entrypoint res,
fixpoint code successors transf entrypoint = Some res ->
res!!entrypoint = L.top.

Axiom fixpoint_invariant:
forall A (code: PTree.t A) successors transf entrypoint
(P: L.t -> Prop),
P L.top ->
(forall pc instr x, code!pc = Some instr -> P x -> P (transf pc x)) ->
forall res pc,
fixpoint code successors transf entrypoint = Some res ->
P res!!pc.

End BBLOCK_SOLVER.

Module BBlock_solver(LAT: ORDERED_TYPE_WITH_TOP):
BBLOCK_SOLVER with Module L := LAT.

Module L := LAT.

Section Solver.

Context {A: Type}.
Variable code: PTree.t A.
Variable successors: A -> list positive.
Variable transf: positive -> L.t -> L.t.
Variable entrypoint: positive.
Variable P: L.t -> Prop.
Hypothesis Ptop: P L.top.
Hypothesis Ptransf: forall pc instr x, code!pc = Some instr -> P x -> P (transf pc x).

Definition bbmap := positive -> bool.
Definition result := PMap.t L.t.

Record state : Type := mkstate
{ aval: result; worklist: list positive }.

Fixpoint propagate_successors
(bb: bbmap) (succs: list positive) (l: L.t) (st: state)
{struct succs} : state :=
match succs with
| nil => st
| s1 :: sl =>
if bb s1 then
propagate_successors bb sl l st
else
propagate_successors bb sl l
(mkstate (PMap.set s1 l st.(aval))
(s1 :: st.(worklist)))
end.

Definition step (bb: bbmap) (st: state) : result + state :=
match st.(worklist) with
| nil => inl _ st.(aval)
| pc :: rem =>
match code!pc with
| None =>
inr _ (mkstate st.(aval) rem)
| Some instr =>
inr _ (propagate_successors
bb (successors instr)
(transf pc st.(aval)!!pc)
(mkstate st.(aval) rem))
end
end.

Definition is_basic_block_head
(preds: PTree.t (list positive)) (pc: positive) : bool :=
if peq pc entrypoint then true else
match preds!!!pc with
| nil => false
| s :: nil => peq s pc
| _ :: _ :: _ => true
end.

Definition basic_block_map : bbmap :=
is_basic_block_head (make_predecessors code successors).

Definition basic_block_list (bb: bbmap) : list positive :=
PTree.fold (fun l pc instr => if bb pc then pc :: l else l)
code nil.

Definition fixpoint : option result :=
let bb := basic_block_map in
PrimIter.iterate _ _ (step bb) (mkstate (PMap.init L.top) (basic_block_list bb)).

Definition predecessors := make_predecessors code successors.

Lemma predecessors_correct:
forall n instr s,
code!n = Some instr -> In s (successors instr) -> In n predecessors!!!s.
Proof. hammer_hook "Kildall" "Kildall.BBlock_solver.predecessors_correct".
intros. unfold predecessors. eapply make_predecessors_correct_1; eauto.
Qed.

Lemma multiple_predecessors:
forall s n1 instr1 n2 instr2,
code!n1 = Some instr1 -> In s (successors instr1) ->
code!n2 = Some instr2 -> In s (successors instr2) ->
n1 <> n2 ->
basic_block_map s = true.
Proof. hammer_hook "Kildall" "Kildall.BBlock_solver.multiple_predecessors".
intros.
assert (In n1 predecessors!!!s). eapply predecessors_correct; eauto.
assert (In n2 predecessors!!!s). eapply predecessors_correct; eauto.
unfold basic_block_map, is_basic_block_head.
destruct (peq s entrypoint). auto.
fold predecessors.
destruct (predecessors!!!s).
auto.
destruct l.
apply proj_sumbool_is_true. simpl in *. intuition congruence.
auto.
Qed.

Lemma no_self_loop:
forall n instr,
code!n = Some instr -> In n (successors instr) -> basic_block_map n = true.
Proof. hammer_hook "Kildall" "Kildall.BBlock_solver.no_self_loop".
intros. unfold basic_block_map, is_basic_block_head.
destruct (peq n entrypoint). auto.
fold predecessors.
exploit predecessors_correct; eauto. intros.
destruct (predecessors!!!n).
contradiction.
destruct l. apply proj_sumbool_is_true. simpl in H1. tauto.
auto.
Qed.

Definition state_invariant (st: state) : Prop :=
(forall n, basic_block_map n = true -> st.(aval)!!n = L.top)
/\
(forall n,
In n st.(worklist) \/
(forall instr s, code!n = Some instr -> In s (successors instr) ->
L.ge st.(aval)!!s (transf n st.(aval)!!n))).

Lemma propagate_successors_charact1:
forall bb succs l st,
incl st.(worklist)
(propagate_successors bb succs l st).(worklist).
Proof. hammer_hook "Kildall" "Kildall.BBlock_solver.propagate_successors_charact1".
induction succs; simpl; intros.
apply incl_refl.
case (bb a).
auto.
apply incl_tran with (a :: worklist st).
apply incl_tl. apply incl_refl.
set (st1 := (mkstate (PMap.set a l (aval st)) (a :: worklist st))).
change (a :: worklist st) with (worklist st1).
auto.
Qed.

Lemma propagate_successors_charact2:
forall bb succs l st n,
let st' := propagate_successors bb succs l st in
(In n succs -> bb n = false -> In n st'.(worklist) /\ st'.(aval)!!n = l)
/\ (~In n succs \/ bb n = true -> st'.(aval)!!n = st.(aval)!!n).
Proof. hammer_hook "Kildall" "Kildall.BBlock_solver.propagate_successors_charact2".
induction succs; simpl; intros.

split. tauto. auto.

caseEq (bb a); intro.
elim (IHsuccs l st n); intros U V.
split; intros. apply U; auto.
elim H0; intro. subst a. congruence. auto.
apply V. tauto.
set (st1 := mkstate (PMap.set a l (aval st)) (a :: worklist st)).
elim (IHsuccs l st1 n); intros U V.
split; intros.
elim H0; intros.
subst n. split.
apply propagate_successors_charact1. simpl. tauto.
case (In_dec peq a succs); intro.
elim (U i H1); auto.
rewrite V. unfold st1; simpl. apply PMap.gss. tauto.
apply U; auto.
rewrite V. unfold st1; simpl. apply PMap.gso.
red; intro; subst n. elim H0; intro. tauto. congruence.
tauto.
Qed.

Lemma propagate_successors_invariant:
forall pc instr res rem,
code!pc = Some instr ->
state_invariant (mkstate res (pc :: rem)) ->
state_invariant
(propagate_successors basic_block_map (successors instr)
(transf pc res!!pc)
(mkstate res rem)).
Proof. hammer_hook "Kildall" "Kildall.BBlock_solver.propagate_successors_invariant".
intros until rem. intros CODE [INV1 INV2]. simpl in INV1. simpl in INV2.
set (l := transf pc res!!pc).
generalize (propagate_successors_charact1 basic_block_map
(successors instr) l (mkstate res rem)).
generalize (propagate_successors_charact2 basic_block_map
(successors instr) l (mkstate res rem)).
set (st1 := propagate_successors basic_block_map
(successors instr) l (mkstate res rem)).
intros U V. simpl in U.

split; intros.
elim (U n); intros C D. rewrite D. simpl. apply INV1. auto. tauto.

destruct (peq pc n). subst n.
right; intros.
assert (instr0 = instr) by congruence. subst instr0.
elim (U s); intros C D.
replace (st1.(aval)!!pc) with res!!pc. fold l.
destruct (basic_block_map s) eqn:BB.
rewrite D. simpl. rewrite INV1. apply L.top_ge. auto. tauto.
elim (C H0 (eq_refl _)). intros X Y. rewrite Y. apply L.refl_ge.
elim (U pc); intros E F. rewrite F. reflexivity.
destruct (In_dec peq pc (successors instr)).
right. eapply no_self_loop; eauto.
left; auto.

elim (INV2 n); intro.

left. apply V. simpl. tauto.

assert (INV3: forall s instr', code!n = Some instr' -> In s (successors instr') -> st1.(aval)!!s = res!!s).

intros. elim (U s); intros C D. rewrite D. reflexivity.
destruct (In_dec peq s (successors instr)).
right. eapply multiple_predecessors with (n1 := pc) (n2 := n); eauto.
left; auto.
destruct (In_dec peq n (successors instr)).

destruct (basic_block_map n) eqn:BB.
right; intros.
elim (U n); intros C D. rewrite D. erewrite INV3; eauto.
tauto.
left. elim (U n); intros C D. elim (C i BB); intros. auto.

right; intros.
elim (U n); intros C D. rewrite D.
erewrite INV3; eauto.
tauto.
Qed.

Lemma propagate_successors_invariant_2:
forall pc res rem,
code!pc = None ->
state_invariant (mkstate res (pc :: rem)) ->
state_invariant (mkstate res rem).
Proof. hammer_hook "Kildall" "Kildall.BBlock_solver.propagate_successors_invariant_2".
intros until rem. intros CODE [INV1 INV2]. simpl in INV1. simpl in INV2.
split; simpl; intros.
apply INV1; auto.
destruct (INV2 n) as [[U | U] | U].
subst n. right; intros; congruence.
auto.
auto.
Qed.

Lemma initial_state_invariant:
state_invariant (mkstate (PMap.init L.top) (basic_block_list basic_block_map)).
Proof. hammer_hook "Kildall" "Kildall.BBlock_solver.initial_state_invariant".
split; simpl; intros.
apply PMap.gi.
right. intros. repeat rewrite PMap.gi. apply L.top_ge.
Qed.

Lemma analyze_invariant:
forall res,
fixpoint = Some res ->
state_invariant (mkstate res nil).
Proof. hammer_hook "Kildall" "Kildall.BBlock_solver.analyze_invariant".
unfold fixpoint; intros. pattern res.
eapply (PrimIter.iterate_prop _ _ (step basic_block_map)
state_invariant).

intros st INV. destruct st as [stin stwrk].
unfold step. simpl. destruct stwrk as [ | pc rem ] eqn:WRK.
auto.
destruct (code!pc) as [instr|] eqn:CODE.
eapply propagate_successors_invariant; eauto.
eapply propagate_successors_invariant_2; eauto.

eauto. apply initial_state_invariant.
Qed.

Theorem fixpoint_solution:
forall res n instr s,
fixpoint = Some res ->
code!n = Some instr -> In s (successors instr) ->
L.ge res!!s (transf n res!!n).
Proof. hammer_hook "Kildall" "Kildall.BACKWARD_DATAFLOW_SOLVER.fixpoint_solution".
intros.
assert (state_invariant (mkstate res nil)).
eapply analyze_invariant; eauto.
elim H2; simpl; intros.
elim (H4 n); intros.
contradiction.
eauto.
Qed.

Theorem fixpoint_entry:
forall res,
fixpoint = Some res ->
res!!entrypoint = L.top.
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.fixpoint_entry".
intros.
assert (state_invariant (mkstate res nil)).
eapply analyze_invariant; eauto.
elim H0; simpl; intros.
apply H1. unfold basic_block_map, is_basic_block_head.
fold predecessors. apply peq_true.
Qed.

Definition Pstate (st: state) : Prop :=
forall pc, P st.(aval)!!pc.

Lemma propagate_successors_P:
forall bb l,
P l ->
forall succs st,
Pstate st ->
Pstate (propagate_successors bb succs l st).
Proof. hammer_hook "Kildall" "Kildall.BBlock_solver.propagate_successors_P".
induction succs; simpl; intros.
auto.
case (bb a). auto.
apply IHsuccs. red; simpl; intros.
rewrite PMap.gsspec. case (peq pc a); intro.
auto. apply H0.
Qed.

Theorem fixpoint_invariant:
forall res pc, fixpoint = Some res -> P res!!pc.
Proof. hammer_hook "Kildall" "Kildall.Dataflow_Solver.fixpoint_invariant".
unfold fixpoint; intros. pattern res.
eapply (PrimIter.iterate_prop _ _ (step basic_block_map) Pstate).

intros st PS. unfold step. destruct (st.(worklist)).
apply PS.
assert (PS2: Pstate (mkstate st.(aval) l)).
red; intro; simpl. apply PS.
destruct (code!p) as [instr|] eqn:CODE.
apply propagate_successors_P. eauto. auto.
auto.

eauto.
red; intro; simpl. rewrite PMap.gi. apply Ptop.
Qed.

End Solver.

End BBlock_solver.

From compcert Require Import Heaps.

Module NodeSetForward <: NODE_SET.
Definition t := PHeap.t.
Definition empty := PHeap.empty.
Definition add (n: positive) (s: t) : t := PHeap.insert n s.
Definition pick (s: t) :=
match PHeap.findMax s with
| Some n => Some(n, PHeap.deleteMax s)
| None => None
end.
Definition all_nodes {A: Type} (code: PTree.t A) :=
PTree.fold (fun s pc instr => PHeap.insert pc s) code PHeap.empty.
Definition In := PHeap.In.

Lemma empty_spec:
forall n, ~In n empty.
Proof. hammer_hook "Kildall" "Kildall.NODE_SET.empty_spec".
intros. apply PHeap.In_empty.
Qed.

Lemma add_spec:
forall n n' s, In n' (add n s) <-> n = n' \/ In n' s.
Proof. hammer_hook "Kildall" "Kildall.NODE_SET.add_spec".
intros. rewrite PHeap.In_insert. unfold In. intuition.
Qed.

Lemma pick_none:
forall s n, pick s = None -> ~In n s.
Proof. hammer_hook "Kildall" "Kildall.NODE_SET.pick_none".
intros until n; unfold pick. caseEq (PHeap.findMax s); intros.
congruence.
apply PHeap.findMax_empty. auto.
Qed.

Lemma pick_some:
forall s n s', pick s = Some(n, s') ->
forall n', In n' s <-> n = n' \/ In n' s'.
Proof. hammer_hook "Kildall" "Kildall.NODE_SET.pick_some".
intros until s'; unfold pick. caseEq (PHeap.findMax s); intros.
inv H0.
generalize (PHeap.In_deleteMax s n n' H). unfold In. intuition.
congruence.
Qed.

Lemma all_nodes_spec:
forall A (code: PTree.t A) n instr,
code!n = Some instr -> In n (all_nodes code).
Proof. hammer_hook "Kildall" "Kildall.NODE_SET.all_nodes_spec".
intros A code n instr.
apply PTree_Properties.fold_rec with
(P := fun m set => m!n = Some instr -> In n set).

intros. apply H0. rewrite H. auto.

rewrite PTree.gempty. congruence.

intros. rewrite PTree.gsspec in H2. rewrite add_spec.
destruct (peq n k). auto. eauto.
Qed.
End NodeSetForward.

Module NodeSetBackward <: NODE_SET.
Definition t := PHeap.t.
Definition empty := PHeap.empty.
Definition add (n: positive) (s: t) : t := PHeap.insert n s.
Definition pick (s: t) :=
match PHeap.findMin s with
| Some n => Some(n, PHeap.deleteMin s)
| None => None
end.
Definition all_nodes {A: Type} (code: PTree.t A) :=
PTree.fold (fun s pc instr => PHeap.insert pc s) code PHeap.empty.
Definition In := PHeap.In.

Lemma empty_spec:
forall n, ~In n empty.
Proof. hammer_hook "Kildall" "Kildall.NodeSetForward.empty_spec". exact (NodeSetForward.empty_spec). Qed.

Lemma add_spec:
forall n n' s, In n' (add n s) <-> n = n' \/ In n' s.
Proof. hammer_hook "Kildall" "Kildall.NodeSetForward.add_spec". exact (NodeSetForward.add_spec). Qed.

Lemma pick_none:
forall s n, pick s = None -> ~In n s.
Proof. hammer_hook "Kildall" "Kildall.NodeSetForward.pick_none".
intros until n; unfold pick. caseEq (PHeap.findMin s); intros.
congruence.
apply PHeap.findMin_empty. auto.
Qed.

Lemma pick_some:
forall s n s', pick s = Some(n, s') ->
forall n', In n' s <-> n = n' \/ In n' s'.
Proof. hammer_hook "Kildall" "Kildall.NodeSetForward.pick_some".
intros until s'; unfold pick. caseEq (PHeap.findMin s); intros.
inv H0.
generalize (PHeap.In_deleteMin s n n' H). unfold In. intuition.
congruence.
Qed.

Lemma all_nodes_spec:
forall A (code: PTree.t A) n instr,
code!n = Some instr -> In n (all_nodes code).
Proof. hammer_hook "Kildall" "Kildall.NodeSetForward.all_nodes_spec". exact (NodeSetForward.all_nodes_spec). Qed.
End NodeSetBackward.


(** * Classification of path spaces of precategories *)
Require Import Category.Core.
Require Import HoTT.Basics.Equivalences HoTT.Basics.PathGroupoids HoTT.Basics.Trunc HoTT.Basics.Tactics.
Require Import HoTT.Types.Sigma HoTT.Types.Arrow HoTT.Types.Forall.
Require Import HoTT.Tactics.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope morphism_scope.
Local Open Scope category_scope.

Section path_category.
  Local Open Scope path_scope.

  (** We add a prime ([']) as an arbitrary convention to denote that
      we are talking about equality of functions (less convenient for
      use) rather than pointwise equality of functions (more
      convenient for use, but more annoying for proofs).  We add two
      primes to denote the even less convenient version, which
      requires an identity equality proof. *)
  Local Notation path_precategory''_T C D
    := { Hobj : object C = object D
       | { Hmor : transport (fun obj => obj -> obj -> Type)
                            Hobj
                            (morphism C)
                  = morphism D
         | transport _
                     Hmor
                     (transportD (fun obj => obj -> obj -> Type)
                                 (fun obj mor => forall s d d', mor d d' -> mor s d -> mor s d')
                                 Hobj
                                 (morphism C)
                                 (@compose C))
           = @compose D
           /\ transport _
                        Hmor
                        (transportD (fun obj => obj -> obj -> Type)
                                    (fun obj mor => forall x, mor x x)
                                    Hobj
                                    (morphism C)
                                    (@identity C))
              = @identity D }}.

  Local Notation path_precategory'_T C D
    := { Hobj : object C = object D
       | { Hmor : transport (fun obj => obj -> obj -> Type)
                            Hobj
                            (morphism C)
                  = morphism D
         | transport _
                     Hmor
                     (transportD (fun obj => obj -> obj -> Type)
                                 (fun obj mor => forall s d d', mor d d' -> mor s d -> mor s d')
                                 Hobj
                                 (morphism C)
                                 (@compose C))
           = @compose D }}.

  (** ** Classify sufficient conditions to prove precategories equal *)
  Lemma path_precategory_uncurried__identity_helper `{Funext} (C D : PreCategory)
        (Heq : path_precategory'_T C D)
  : transport _
              Heq.2.1
              (transportD (fun obj => obj -> obj -> Type)
                          (fun obj mor => forall x, mor x x)
                          Heq.1
                          (morphism C)
                          (@identity C))
    = @identity D.
  Proof.
    destruct Heq as [? [? ?]]; cbn in *.
    repeat (intro || apply path_forall).
    apply identity_unique; cbn in *; auto with morphism.
    destruct C, D; cbn in *.
    path_induction; cbn in *.
    auto.
  Qed.

  Definition path_precategory''_T__of__path_precategory'_T `{Funext} C D
  : path_precategory'_T C D -> path_precategory''_T C D
    := fun H => (H.1; (H.2.1; (H.2.2, path_precategory_uncurried__identity_helper C D H))).

  Lemma eta2_sigma_helper A B P Q `{forall a b, IsHProp (Q a b)}
        (x : { a : A & { b : B a & P a b /\ Q a b }})
        q'
  : (x.1; (x.2.1; (fst x.2.2, q'))) = x.
  Proof.
    destruct x as [? [? [? ?]]]; cbn in *.
    repeat f_ap; apply path_ishprop.
  Defined.

  Global Instance isequiv__path_precategory''_T__of__path_precategory'_T `{fs : Funext} C D
  : IsEquiv (@path_precategory''_T__of__path_precategory'_T fs C D)
    := isequiv_adjointify
         (@path_precategory''_T__of__path_precategory'_T fs C D)
         (fun H => (H.1; (H.2.1; fst H.2.2)))
         (fun x => eta2_sigma_helper _ _ _ x _)
         eta2_sigma.

  Definition path_precategory_uncurried' `{fs : Funext} (C D : PreCategory)
  : path_precategory''_T C D -> C = D.
  Proof.
    intros [? [? [? ?]]].
    destruct C, D; cbn in *.
    path_induction; cbn in *.
    f_ap;
      eapply @center; abstract exact _.
  Defined.

  (** *** Said proof respects [object] *)
  Lemma path_precategory_uncurried'_fst `{Funext} C D HO HM HC HI
  : ap object (@path_precategory_uncurried' _ C D (HO; (HM; (HC, HI)))) = HO.
  Proof.
    destruct C, D; cbn in *.
    path_induction_hammer.
  Qed.

  (** *** Said proof respects [idpath] *)
  Lemma path_precategory_uncurried'_idpath `{Funext} C
  : @path_precategory_uncurried' _ C C (idpath; (idpath; (idpath, idpath))) = idpath.
  Proof.
    destruct C; cbn in *.
    rewrite !(contr idpath).
    reflexivity.
  Qed.

  (** ** Equality of precategorys gives rise to an inhabitant of the path-classifying-type *)
  Definition path_precategory_uncurried'_inv (C D : PreCategory)
  : C = D -> path_precategory''_T C D.
  Proof.
    intro H'.
    exists (ap object H').
    exists ((transport_compose _ object _ _) ^ @ apD (@morphism) H').
    split.
    - refine (_ @ apD (@compose) H'); cbn.
      refine (transport_pp _ _ _ _ @ _).
      refine ((ap _ (transportD_compose
                       (fun obj => obj -> obj -> Type)
                       (fun obj mor =>
                          forall s d d' : obj, mor d d' -> mor s d -> mor s d') object H'
                       (morphism C) (@compose C))^)
                @ (transport_apD_transportD
                     _
                     morphism
                     (fun x mor => forall s d d' : x, mor d d' -> mor s d -> mor s d') H'
                     (@compose C))).
    - refine (_ @ apD (@identity) H'); cbn.
      refine (transport_pp _ _ _ _ @ _).
      refine ((ap _ (transportD_compose
                       (fun obj => obj -> obj -> Type)
                       (fun obj mor =>
                          forall x : obj, mor x x) object H'
                       (morphism C) (@identity C))^)
                @ (transport_apD_transportD
                     _
                     morphism
                     (fun x mor => forall s : x, mor s s) H'
                     (@identity C))).
  Defined.

  (** ** Classify equality of precategorys up to equivalence *)
  Lemma equiv_path_precategory_uncurried'__eissect `{Funext} (C D : PreCategory)
  : forall x : path_precategory''_T C D,
      path_precategory_uncurried'_inv (path_precategory_uncurried' C D x) = x.
  Proof.
    destruct C, D; cbn in *.
    intros [H0' [H1' [H2' H3']]].
    path_induction.
    cbn.
    repeat (edestruct (center (_ = _)); try reflexivity).
  Qed.

  Lemma equiv_path_precategory_uncurried' `{Funext} (C D : PreCategory)
  : path_precategory''_T C D <~> C = D.
  Proof.
    apply (equiv_adjointify (@path_precategory_uncurried' _ C D)
                            (@path_precategory_uncurried'_inv C D)).
    - hnf.
      intros [].
      apply path_precategory_uncurried'_idpath.
    - hnf.
      apply equiv_path_precategory_uncurried'__eissect.
  Defined.

  Definition equiv_path_precategory_uncurried `{Funext} (C D : PreCategory)
  : path_precategory'_T C D <~> C = D
    := ((equiv_path_precategory_uncurried' C D)
          oE (Build_Equiv
                _ _ _
                (isequiv__path_precategory''_T__of__path_precategory'_T C D))).

  Definition path_precategory_uncurried `{Funext} C D : _ -> _
    := equiv_path_precategory_uncurried C D.

  (** ** Curried version of path classifying lemma *)
  Lemma path_precategory' `{fs : Funext} (C D : PreCategory)
  : forall (Hobj : object C = object D)
           (Hmor : transport (fun obj => obj -> obj -> Type)
                             Hobj
                             (morphism C)
                   = morphism D),
      transport _
                Hmor
                (transportD (fun obj => obj -> obj -> Type)
                            (fun obj mor => forall s d d', mor d d' -> mor s d -> mor s d')
                            Hobj
                            (morphism C)
                            (@compose C))
      = @compose D
      -> C = D.
  Proof.
    intros.
    apply path_precategory_uncurried.
    repeat esplit; eassumption.
  Defined.

  (** ** Curried version of path classifying lemma, using [forall] in place of equality of functions *)
  Lemma path_precategory `{fs : Funext} (C D : PreCategory)
  : forall (Hobj : object C = object D)
           (Hmor : forall s d,
                     morphism C (transport idmap Hobj^ s) (transport idmap Hobj^ d)
                     = morphism D s d),
      (forall s d d' m m',
         transport idmap (Hmor _ _)
                   (@compose C _ _ _
                             (transport idmap (Hmor _ _)^ m)
                             (transport idmap (Hmor _ _)^ m'))
         = @compose D s d d' m m')
      -> C = D.
  Proof.
    intros Hobj Hmor Hcomp.
    pose (path_forall
            _ _
            (fun s =>
               path_forall
                 _ _
                 (fun d =>
                    (ap10 (@transport_arrow Type idmap (fun x => x -> Type) _ _ Hobj (@morphism C) _) _)
                      @ (@transport_arrow Type idmap _ _ _ Hobj (@morphism C _) _)
                      @ (transport_const _ _)
                      @ Hmor s d)))
      as Hmor'.
    eapply (path_precategory' C D Hobj Hmor').
    repeat (apply path_forall; intro).
    refine (_ @ Hcomp _ _ _ _ _); clear Hcomp.
    subst Hmor'.
    cbn.
    abstract (
        destruct C, D;
        cbn in *;
          destruct Hobj;
        cbn in *;
          repeat match goal with
                   | _ => reflexivity
                   | _ => rewrite !concat_1p
                   | _ => rewrite !transport_forall_constant, !transport_arrow
                   | _ => progress transport_path_forall_hammer
                   | [ |- transport ?P ?p^ ?u = ?v ]
                     => (apply (@moveR_transport_V _ P _ _ p u v); progress transport_path_forall_hammer)
                   | [ |- ?u = transport ?P ?p^ ?v ]
                     => (apply (@moveL_transport_V _ P _ _ p u v); progress transport_path_forall_hammer)
                   | [ |- context[?H ?x ?y] ]
                     => (destruct (H x y); clear H)
                   | _ => progress f_ap
                 end
      ).
  Defined.
End path_category.

(** ** Tactic for proving equality of precategories *)
(** We move the funext inference outside the loop. *)
Ltac path_category :=
  idtac;
  let lem := constr:(@path_precategory _) in
  repeat match goal with
           | _ => intro
           | _ => reflexivity
           | _ => simple refine (lem _ _ _ _ _); cbn
         end.


(*|
============================================================
Core definition of the [ctrees] datatype and its combinators
============================================================

We develop a data-structure strongly inspired by Interaction Trees,
but offering native support for internal non-determinism: the [ctree]s.
Interaction trees took the position to not be the free monad per se,
but to give a special status to divergence by implementing it coinductively.
Here, we take a similar stance toward non-determinism by adding a new
constructor to the structure encoding (finite) non-deterministic branching.
These internal branching nodes are furthermore tagged by whether they can be
observed or not.

The resulting structure is still an iterative monad parametered by an
interface of interactions, supporting monadic interpretations of these
interfaces. But the equivalence relation over [ctree] is more complex, and
account natively for this non-determinism. More specifically, we provide
a structural, coinductive equality; a notion of strong bisimulation observing
visible internal brs; a notion of weak bisimulation observing no internal
br.

.. coq:: none
|*)

From ITree Require Import Basics.Basics Core.Subevent Indexed.Sum.

From CTree Require Import
	   Core.Utils Core.Index.

From ExtLib Require Import
	   Structures.Functor
	   Structures.Monads.

Set Implicit Arguments.
Set Contextual Implicit.
Set Primitive Projections.

(*|
.. coq::
|*)

Section ctree.

  Context {E : Type -> Type} {B : Type -> Type} {R : Type}.

(*|
The type [ctree] is defined as the final coalgebra ("greatest fixed point") of the functor [ctreeF].
A [ctree] can locally provide three kind of observations:
- A pure value, terminating the computation
- An interaction with the environment, emitting the corresponding
indexed event and non-deterministically continuing indexed by the
value returned by the environment
- A (finite) internal non-deterministic branching

TODO YZ:

- Do we want to name the sources of the brs?
  For instance if we want to support simultaneously different schedulers for different kind of non-determinism in a language.
- Do we want non-finite internal branching? Indexed by arbitrary types?
- Or crazier, do we want non-uniform branching, modelling non-uniform random brs for instance?
- Could ctrees be parameterized by:

  + a bound on nested brs before reaching a Vis/Ret
  + a general domain of br events

.. coq::
|*)

  Variant ctreeF (ctree : Type) :=
    | RetF (r : R)                                       (* a pure computation *)
    | VisF {X : Type} (e : E X) (k : X -> ctree)          (* an external event *)
    | BrF (vis : bool) {X : Type} (c : B X) (k : X -> ctree) (* an internal non-deterministic branching *)
  .

  CoInductive ctree : Type :=
    go { _observe : ctreeF ctree }.

End ctree.

(*|
.. coq:: none
|*)

Declare Scope ctree_scope.
Bind Scope ctree_scope with ctree.
Delimit Scope ctree_scope with ctree.
Local Open Scope ctree_scope.

Arguments ctree _ _ : clear implicits.
Arguments ctreeF _ _ : clear implicits.
Arguments BrF {E B R} [ctree] vis {X} c k.

(*|
A [ctree'] is a "forced" [ctree]. It is the type of inputs
of [go], and outputs of [observe].

.. coq::
|*)

Notation ctree' E B R := (ctreeF E B R (ctree E B R)).

(*|
We wrap the primitive projection [_observe] in a function [observe].
|*)

Definition observe {E B R} (t : ctree E B R) : ctree' E B R := @_observe E B R t.

Notation Ret x        := (go (RetF x)).
Notation Vis e k      := (go (VisF e k)).
Notation Br b n k     := (go (BrF b n k)).
Notation BrS n k      := (go (BrF true n k)).
Notation BrD n k      := (go (BrF false n k)).
Notation BrSF         := (BrF true).
Notation BrDF         := (BrF false).

Notation vis e k      := (Vis (subevent _ e) k).
Notation br b c k     := (Br b (subevent _ c) k).
Notation brS c k      := (br true c k).
Notation brD c k      := (br false c k).
Notation brSF c       := (BrSF (subevent _ c)).
Notation brDF c       := (BrDF (subevent _ c)).

Section Branching.

  Context {E B : Type -> Type}.
  Context {R : Type}.

(*|
Silent failure: contrary to an event-based failure, this
stuck state cannot be observed, it will be indistinguishable
from [spin] w.r.t. the bisimulations introduced.
|*)
  Definition stuck `{B0 -< B} vis : ctree E B R :=
    br vis branch0 (fun x : void => match x with end).

(*|
Guards similar to [itree]'s taus.
|*)
  Definition Guard `{B1 -< B} t : ctree E B R :=
    brD branch1 (fun _ => t).

  Definition Step `{B1 -< B} t : ctree E B R :=
    brS branch1 (fun _ => t).

(*|
Bounded branching
|*)
  Definition brD2 `{B2 -< B} t u : ctree E B R :=
    brD branch2 (fun b => if b : bool then t else u).
  Definition brS2 `{B2 -< B} t u : ctree E B R :=
    brS branch2 (fun b => if b : bool then t else u).
  Definition brD3 `{B3 -< B} t u v : ctree E B R :=
    brD branch3 (fun n => match n with
                           | t31 => t
                           | t32 => u
                           | t33 => v
                           end).
  Definition brS3 `{B3 -< B} t u v : ctree E B R :=
    brS branch3 (fun n => match n with
                           | t31 => t
                           | t32 => u
                           | t33 => v
                           end).
  Definition brD4 `{B4 -< B} t u v w : ctree E B R :=
    brD branch4 (fun n => match n with
                           | t41 => t
                           | t42 => u
                           | t43 => v
                           | t44 => w
                           end).
  Definition brS4 `{B4 -< B} t u v w : ctree E B R :=
    brS branch4 (fun n => match n with
                           | t41 => t
                           | t42 => u
                           | t43 => v
                           | t44 => w
                           end).

(*|
Finite branch
|*)
  Definition brDn `{Bn -< B} n k : ctree E B R :=
    brD (branchn n) k.
  Definition brSn `{Bn -< B} n k : ctree E B R :=
    brS (branchn n) k.

(*|
Countable branch
|*)
  Definition brIN `{BN -< B} k : ctree E B R :=
    brD branchN k.
  Definition brSN `{BN -< B} k : ctree E B R :=
    brS branchN k.

End Branching.

(*|
Main operations on [ctree]
--------------------------

The core definitions are wrapped in a module for namespacing. They are meant to be used qualified (e.g., CTree.bind) or via notations (e.g., [>>=]).

Note on how to write cofixpoints
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We define cofixpoints in two steps:

first a plain definition (prefixed with an [_], e.g., [_bind], [_iter]) defines the body of the function:

- it takes the recursive call ([bind]) as a parameter;
- if we are deconstructing an ctree, this body takes the unwrapped [ctreeF];

second the actual [CoFixpoint] (or, equivalently, [cofix]) ties the knot, applying [observe] to any [ctree] parameters.

This style allows us to keep [cofix] from ever appearing in proofs, which could otherwise get quite unwieldly.
For every [CoFixpoint] (such as [bind]), we prove an unfolding lemma to rewrite it as a term whose head is [_bind], without any [cofix] above it.

    unfold_bind : observe (bind t k)
                = observe (_bind (fun t' => bind t' k) t)

Note that this is an equality "up to" [observe]. It would not be provable if it were a plain equality:

    bind t k = _bind (...) t
    (cofix bind' t1 := _bind (...) t1) t = _bind (...) t1

The [cofix] is stuck, and can only be unstuck under the primitive projection [_observe] (which is wrapped by [observe]).

Definitions

These are meant to be imported qualified, e.g., [CTree.bind],
[CTree.trigger], to avoid ambiguity with identifiers of the same
name (some of which are overloaded generalizations of these).
|*)

Module CTree.

  Section CTree.

    Context {E B : Type -> Type}.

(*|
[bind]: monadic composition, tree substitution, sequencing of
computations. [bind t k] is also denoted by [t >>= k] and using
"do-notation" [x <- t ;; k x].
|*)

(*|
[subst]: [bind] with its arguments flipped.
We keep the continuation [k] outside the cofixpoint.
In particular, this allows us to nest [bind] in other cofixpoints,
as long as the recursive occurences are in the continuation
(i.e., this makes it easy to define tail-recursive functions).
|*)
    Definition subst {T U : Type} (k : T -> ctree E B U)
      : ctree E B T -> ctree E B U :=
      cofix _subst (u : ctree E B T) : ctree E B U :=
        match observe u with
        | RetF r => k r
        | VisF e h => Vis e (fun x => _subst (h x))
        | BrF b n h => Br b n (fun x => _subst (h x))
        end.

    Definition bind {T U : Type} (u : ctree E B T) (k : T -> ctree E B U)
      : ctree E B U :=
      subst k u.

(*|
Monadic composition of continuations (i.e., Kleisli composition).
|*)

    Definition cat {T U V}
      (k : T -> ctree E B U) (h : U -> ctree E B V) :
      T -> ctree E B V :=
      fun t => bind (k t) h.

(*|
Functorial map ([fmap] in Haskell)
|*)

    Definition map {R S} (f : R -> S)  (t : ctree E B R) : ctree E B S :=
      bind t (fun x => Ret (f x)).

(*|
Atomic itrees triggering a single event.
|*)

    Definition trigger : E ~> ctree E B :=
      fun R e => Vis e (fun x => Ret x).

(*|
Atomic ctrees with choice.
|*)

    Definition branch b {X : Type} : forall (c : B X), ctree E B X :=
      fun c => Br b c (fun x => Ret x).

(*|
Ignore the result of a tree.
|*)

    Definition ignore {R} : ctree E B R -> ctree E B unit :=
      map (fun _ => tt).

  End CTree.

  Ltac fold_bind :=
    repeat match goal with
      | h: context [CTree.subst ?k ?t] |- _ => fold (CTree.bind t k) in h
      | |- context [CTree.subst ?k ?t] => fold (CTree.bind t k)
      end.

(*|
[on_left lr l t]: run a computation [t] if the first argument is an [inl l].
[l] must be a variable (used as a pattern), free in the expression [t]:

   - [on_left (inl x) l t = t{l := x}]
   - [on_left (inr y) l t = Ret y]
|*)

  Notation on_left lr l t :=
    (match lr with
     | inl l => t
     | inr r => Ret r
     end) (only parsing).

(*|
Combinators for loops must be guarded, we hence assume that
unary choices are available.
|*)
  Section withGuard.

    Context {E B : Type -> Type}.
    Context `{B1 -< B}.

    CoFixpoint spinD {R} : ctree E B R := Guard spinD.
    CoFixpoint spinS {R} : ctree E B R := Step spinS.
(*|
Repeat a computation infinitely.
|*)

    Definition forever {E R S} (t : ctree E B R) : ctree E B S :=
      cofix forever_t := bind t (fun _ => Guard (forever_t)).

(*|
[iter]: See [Basics.Basics.MonadIter].
Note: here we must be careful to call [iter\_ l] under [Tau] to avoid an eager
infinite loop if [step i] is always of the form [Ret (inl _)] (cf. issue #182).
|*)

    Definition iter {R I: Type}
      (step : I -> ctree E B (I + R)) : I -> ctree E B R :=
      cofix iter_ i := bind (step i) (fun lr => on_left lr l (Guard (iter_ l))).

  End withGuard.

(*|
Infinite taus.
|*)

  CoFixpoint spinD_gen {E C R X} (x : C X) : ctree E C R :=
	  BrD x (fun _ => spinD_gen x).
  CoFixpoint spinS_gen {E C R X} (x : C X) : ctree E C R :=
	  BrS x (fun _ => spinS_gen x).

  Ltac fold_subst :=
    repeat (change (CTree.subst ?k ?t) with (CTree.bind t k)).

  Ltac fold_monad :=
    repeat (change (@CTree.bind ?E) with (@Monad.bind (ctree E) _));
    repeat (change (go (@RetF ?E _ _ _ ?r)) with (@Monad.ret (ctree E) _ _ r));
    repeat (change (@CTree.map ?E) with (@Functor.fmap (ctree E) _)).

End CTree.

Notation branch b c := (CTree.branch b (subevent _ c)).
Notation branchD c := (CTree.branch false (subevent _ c)).
Notation branchS c := (CTree.branch true (subevent _ c)).
Notation trigger e := (CTree.trigger (subevent _ e)).
Notation stuckD := (stuck false).
Notation stuckS := (stuck true).

(*|
=========
Notations
=========

Sometimes it's more convenient to work without the type classes [Monad], etc. When functions using type classes are specialized,
they simplify easily, so lemmas without classes are easier to apply than lemmas with.

We can also make ExtLib's [bind] opaque, in which case it still doesn't hurt to have these notations around.
|*)

Module CTreeNotations.
Notation "t1 >>= k2" := (CTree.bind t1 k2)
  (at level 58, left associativity) : ctree_scope.
Notation "x <- t1 ;; t2" := (CTree.bind t1 (fun x => t2))
  (at level 62, t1 at next level, right associativity) : ctree_scope.
Notation "t1 ;; t2" := (CTree.bind t1 (fun _ => t2))
  (at level 62, right associativity) : ctree_scope.
Notation "' p <- t1 ;; t2" :=
  (CTree.bind t1 (fun x_ => match x_ with p => t2 end))
  (at level 62, t1 at next level, p pattern, right associativity) : ctree_scope.
End CTreeNotations.

(*|
=========
Instances
=========
|*)

#[global] Instance Functor_ctree {E B} : Functor (ctree E B) :=
{ fmap := @CTree.map E B }.

#[global] Instance Monad_ctree {E B} : Monad (ctree E B) :=
{| ret := fun _ x => Ret x
;  bind := @CTree.bind E B
|}.

#[global] Instance MonadIter_ctree {E B} `{B1 -< B} : MonadIter (ctree E B) :=
  fun R I => @CTree.iter E B _ R I.

(* #[global] Instance MonadTrigger_ctree {E B} : MonadTrigger E (ctree E B) | 1 := *)
(*   @CTree.trigger _ _. *)

#[global] Instance MonadTrigger_ctree {E F B} `{E -< F} : MonadTrigger E (ctree F B) :=
  fun _ e => trigger e.

(* #[global] Instance MonadBr_ctree {E B} : MonadBr B (ctree E B) | 1 := *)
(*   @CTree.branch _ _. *)

#[global] Instance MonadBr_ctree {E C D} `{C -< D} : MonadBr C (ctree E D) :=
  fun b _ c => branch b c.

(*|
====================================
Inversion lemma relying on [JMeq_eq]
====================================
Since the [Vis] and [Br] constructors take dependent
pairs as argument, their inversion is not straightforward.
The ITree library goes to great length to avoid the use of
axioms where possible. Here for now we fully embrace [JMeq_eq]
-- it is introduced under the scene by [dependent destruction].
|*)

Lemma Vis_eq1 E C R T Y e k Z f h: @VisF E C R T Y e k = @VisF E C R T Z f h -> Y=Z.
Proof. intro H. now dependent destruction H. Qed.

Lemma Vis_eq2 E C R T Y e k f h: @VisF E C R T Y e k = @VisF E C R T Y f h -> e=f /\ k=h.
Proof. intro H. now dependent destruction H. Qed.

Lemma Br_eq1 E B R T b b' Y Z c c' k h:
  @BrF E B R T b Y c k = @BrF E B R T b' Z c' h -> b = b' /\ Y = Z.
Proof. intro H. now dependent destruction H. Qed.

Lemma Br_eq2 E B R T b Y c c' k h:
  @BrF E B R T b Y c k = @BrF E B R T b Y c' h -> c = c' /\ k = h.
Proof. intro H. now dependent destruction H. Qed.

(*|
=======
Tactics
=======
|*)

Tactic Notation "hinduction" hyp(IND) "before" hyp(H)
  := move IND before H; Tactics.revert_until IND; induction IND.

Ltac inv H := inversion H; clear H; subst.

Ltac rewrite_everywhere lem :=
  progress ((repeat match goal with [H: _ |- _] => rewrite lem in H end); repeat rewrite lem).

Ltac rewrite_everywhere_except lem X :=
  progress ((repeat match goal with [H: _ |- _] =>
                 match H with X => fail 1 | _ => rewrite lem in H end
             end); repeat rewrite lem).

Ltac genobs x ox := remember (observe x) as ox.
Ltac genobs_clear x ox := genobs x ox; match goal with [H: ox = observe x |- _] => clear H x end.
Ltac simpobs := repeat match goal with [H: _ = observe _ |- _] =>
                    rewrite_everywhere_except (@eq_sym _ _ _ H) H
                end.
Ltac desobs x := destruct (observe x) .

Ltac fold_subst :=
  repeat (change (CTree.subst ?k ?t) with (CTree.bind t k)).

(*|
==================
Compute with fuel
==================

Remove [Guard]s and [Step]s from the front of an [ctree].
|*)
Fixpoint burn (n : nat) {E B : Type -> Type} {R} (t : ctree E (B01 +' B) R) : ctree E (B01 +' B) R :=
  match n with
  | 0 => t
  | S n =>
      match observe t with
      | RetF r => Ret r
      | VisF e k => Vis e k
      | BrF b (inl1 (inr1 c)) k =>
          match c in (B1 T) return (T -> _) -> _ with
          | branch1 => fun k => burn n (k tt)
          end k
      | BrF b c k => Br b c k
      end
  end.


Require Coq.Classes.EquivDec.
Require Coq.Lists.List.
Import List.ListNotations.
Require Import Coq.Program.Program.

Require Import Leapfrog.Syntax.
Require Import Leapfrog.FinType.
Require Import Leapfrog.Sum.
Require Import Leapfrog.Notations.
Require Import Leapfrog.BisimChecker.

Open Scope p4a.

Ltac prep_equiv :=
  unfold Equivalence.equiv, RelationClasses.complement in *;
  program_simpl; try congruence.

Obligation Tactic := prep_equiv.

Module Plain.
  Inductive state :=
  | ParseMPLS
  | ParseUDP.

  Scheme Equality for state.
  Global Instance state_eqdec: EquivDec.EqDec state eq := state_eq_dec.
  Global Instance state_finite: @Finite state _ state_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Inductive header :=
  | HdrMPLS
  | HdrUDP.

  Definition sz (h: header) : nat :=
    match h with
    | HdrMPLS => 32
    | HdrUDP => 64
    end.

  Scheme Equality for header.
  Global Instance header_eqdec: EquivDec.EqDec header eq := header_eq_dec.
  Global Instance header_finite: @Finite header _ header_eqdec.
  Proof.
    solve_finiteness.
  Defined.

  Definition states (s: state) :=
    match s with
    | ParseMPLS =>
      {| st_op :=
          extract(HdrMPLS) ;
         st_trans := transition select (| (@EHdr header sz HdrMPLS)[23 -- 23] |) {{
            [| exact #b|1 |] ==> inl ParseUDP ;;;
            [| exact #b|0 |] ==> inl ParseMPLS ;;;
              reject
          }}
      |}
    | ParseUDP =>
      {| st_op := extract(HdrUDP);
         st_trans := transition accept |}
    end.

  Program Definition aut: Syntax.t state _ :=
    {| t_states := states |}.
  Solve Obligations with (destruct h || destruct s; cbv; Lia.lia).

End Plain.

Module Unrolled.
  Inductive state :=
  | ParseMPLS
  | ParseUDP
  | Cleanup.

  Scheme Equality for state.
  Global Instance state_eqdec: EquivDec.EqDec state eq := state_eq_dec.
  Global Instance state_finite: @Finite state _ state_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Inductive header :=
  | HdrMPLS0
  | HdrMPLS1
  | Tmp
  | HdrUDP .

  Scheme Equality for header.
  Global Instance header_eqdec: EquivDec.EqDec header eq := header_eq_dec.
  Global Instance header_finite: @Finite header _ header_eqdec.
  Proof.
    solve_finiteness.
  Defined.

  Definition sz (h: header) : nat :=
    match h with
    | HdrMPLS0 => 32
    | HdrMPLS1 => 32
    | Tmp => 32
    | HdrUDP => 64
    end.

  Notation EHdr' := (@EHdr header sz).

  Definition states (s: state) :=
    match s with
    | ParseMPLS =>
      {| st_op :=
          extract(HdrMPLS0) ;;
          extract(HdrMPLS1) ;
         st_trans := transition select (| (EHdr' HdrMPLS0)[23 -- 23], (EHdr' HdrMPLS1)[23 -- 23]|) {{
          [| exact (#b|1), * |] ==> inl Cleanup ;;;
          [| exact (#b|0), exact (#b|1) |] ==> inl ParseUDP ;;;
          [| exact (#b|0), exact (#b|0) |] ==> inl ParseMPLS ;;;
            reject
          }}
      |}
    | ParseUDP =>
      {| st_op := extract(HdrUDP) ;
         st_trans := transition accept |}
    | Cleanup =>
      {| st_op :=
        extract(Tmp) ;;
        HdrUDP <- EConcat (EHdr' HdrMPLS1) (EHdr Tmp);
        st_trans := transition accept |}
    end.

  Program Definition aut: Syntax.t state _ :=
    {| t_states := states |}.
  Solve Obligations with (destruct h || destruct s; cbv; Lia.lia).

End Unrolled.

Module MPLSVect.
  Definition aut := Sum.sum Plain.aut Unrolled.aut.
End MPLSVect.


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

Require Export orthogonalite_espace.
Require Export affine_classiques.
Set Implicit Arguments.
Unset Strict Implicit.

Definition tetraedre (A B C D : PO) := ~ coplanaires A B C D.

Lemma tetraedre_non_alignes :
 forall A B C D : PO, tetraedre A B C D -> ~ alignes A B C.
unfold tetraedre in |- *; intros.
elim non_coplanaires_expl with (A := A) (B := B) (C := C) (D := D);
 [ intros H0 H1; try clear non_coplanaires_expl; try exact H0 | auto ].
Qed.
#[export] Hint Resolve tetraedre_non_alignes: geo.

Lemma deux_milieux_tetraedre :
 forall A B C D I J K L : PO,
 tetraedre A B C D ->
 I = milieu D A ->
 J = milieu D B -> K = milieu C A -> L = milieu C B -> vec I J = vec K L.
intros.
cut (mult_PP 2 (vec I J) = vec A B); intros.
cut (mult_PP 2 (vec K L) = vec A B); intros.
apply mult_PP_regulier with 2; auto with real.
rewrite H5; auto.
apply droite_milieu with C; auto.
apply droite_milieu with D; auto.
Qed.

Definition parallelepipede (A B C D E F G H : PO) :=
  (vec A B = vec D C /\ vec D C = vec H G) /\
  vec H G = vec E F /\ vec E H = vec A D.

Definition parallelepipede_rectangle (A B C D E F G H : PO) :=
  parallelepipede A B C D E F G H /\
  orthogonal (vec A B) (vec A D) /\
  orthogonal (vec A B) (vec A E) /\ orthogonal (vec A D) (vec A E).

Definition carre (A B C D : PO) :=
  vec A B = vec D C /\
  orthogonal (vec A B) (vec A D) /\
  scalaire (vec A B) (vec A B) = 1 /\ scalaire (vec A D) (vec A D) = 1.

Definition cube (A B C D E F G H : PO) :=
  parallelepipede_rectangle A B C D E F G H /\
  carre A B C D /\ scalaire (vec A E) (vec A E) = 1.

Lemma parallelepipede_parallelogramme :
 forall A B C D E F G H : PO,
 parallelepipede A B C D E F G H -> vec F G = vec A D.
unfold parallelepipede in |- *; intros A B C D E F G H' H.
elim H; intros H0 H1; elim H1; intros H2 H3; try clear H1 H; try exact H3.
elim H0; intros H H1; try clear H0; try exact H1.
rewrite <- H3.
apply egalite_vecteur.
VReplace (vec F E) (mult_PP (-1) (vec E F)).
rewrite <- H2.
Ringvec.
Qed.

Lemma diagonales_carre :
 forall A B C D : PO, carre A B C D -> orthogonal (vec A C) (vec D B).
intros.
elim H; clear H; intros.
apply def_orthogonal2.
elim H0; intros H2 H3; elim H3; intros H4 H5; try clear H3 H0; try exact H5.
cut (scalaire (vec A B) (vec A D) = 0); intros.
replace (vec A C) with (add_PP (mult_PP 1 (vec A B)) (mult_PP 1 (vec A D))).
replace (vec D B) with
 (add_PP (mult_PP (-1) (vec A D)) (mult_PP 1 (vec A B))).
rewrite scalaire_bilineaire.
rewrite H4; rewrite H5; rewrite H0.
rewrite scalaire_sym; rewrite H0; ring.
Ringvec.
rewrite H.
Ringvec.
apply def_orthogonal; auto.
Qed.

Lemma centre_gravite_coplanaire :
 forall A B C : PO,
 ~ alignes A B C -> coplanaires A B C (centre_gravite A B C).
unfold centre_gravite, milieu, coplanaires in |- *; intros.
right; try assumption.
exists (/ 3); exists (/ 3).
cut (3 <> 0); intros; auto with real.
apply mult_PP_regulier with 3; auto with real.
FVReplace
 (mult_PP 3
    (add_PP (cons (/ 3) A)
       (add_PP (cons (/ 3) B) (cons (1 + - (/ 3 + / 3)) C))))
 (add_PP (cons 1 A) (add_PP (cons 1 B) (cons 1 C))) 3.
VReplace
 (mult_PP 3
    (cons 1
       (barycentre (cons 1 A) (cons 2 (barycentre (cons 1 B) (cons 1 C))))))
 (cons 3 (barycentre (cons 1 A) (cons 2 (barycentre (cons 1 B) (cons 1 C))))).
replace 3 with (1 + 2) by ring.
rewrite <- add_PP_barycentre; auto with real.
replace 2 with (1 + 1) by ring.
rewrite <- add_PP_barycentre; auto with real.
Qed.

#[export] Hint Resolve centre_gravite_coplanaire: geo.

Lemma exercice :
 forall A B C D E F G H I : PO,
 D <> F ->
 ~ alignes E B G ->
 parallelepipede A B C D E F G H ->
 I = centre_gravite E B G -> coplanaires E B G I /\ alignes F D I.
intros A B C D E F G H I H20 H0 H1 H51; try assumption.
rewrite H51.
split; [ auto with geo | idtac ].
cut (vec F G = vec A D).
intros H10.
unfold parallelepipede in H1.
elim H1; intros H2 H3; elim H2; intros H4 H5; try clear H2 H1; try exact H4.
elim H3; intros H2 H12; try clear H3.
cut (vec F D = mult_PP 3 (vec F (centre_gravite E B G))); intros.
cut (3 <> 0); intros; auto with real.
apply colineaire_alignes with (/ 3); auto.
rewrite H1.
Fieldvec 3; auto.
cut (add_PP (mult_PP 3 (vec (centre_gravite E B G) F)) (vec F D) = zero);
 intros.
VReplace (vec F D) (add_PP (vec F D) (mult_PP (-1) zero)).
rewrite <- H1.
Ringvec.
VReplace (vec F D) (add_PP (vec F B) (add_PP (vec B A) (vec A D))).
replace (vec B A) with (vec F E); auto.
replace (vec A D) with (vec F G); auto.
VReplace (add_PP (vec F B) (add_PP (vec F E) (vec F G)))
 (add_PP (vec F E) (add_PP (vec F B) (vec F G))).
replace (add_PP (vec F E) (add_PP (vec F B) (vec F G))) with
 (mult_PP 3
    (vec F
       (barycentre (cons 1 E) (cons 2 (barycentre (cons 1 B) (cons 1 G))))));
 auto.
unfold vec, centre_gravite, milieu in |- *; RingPP.
VReplace (add_PP (vec F B) (vec F G))
 (add_PP (mult_PP 1 (vec F B)) (mult_PP 1 (vec F G))).
rewrite
 (prop_vecteur_bary (a:=1) (b:=1) (A:=B) (B:=G)
    (G:=barycentre (cons 1 B) (cons 1 G)) F); auto.
VReplace (vec F E) (mult_PP 1 (vec F E)).
replace (1 + 1) with 2 by ring.
rewrite (prop_vecteur_bary (a:=1) (b:=2) (A:=E)
    (B:=barycentre (cons 1 B) (cons 1 G))
    (G:=barycentre (cons 1 E) (cons 2 (barycentre (cons 1 B) (cons 1 G)))) F)
 ; auto.
discrR.
discrR.
cut (vec A B = vec E F); intros; auto.
VReplace (vec B A) (mult_PP (-1) (vec A B)).
rewrite H1.
Ringvec.
rewrite H4.
rewrite H5; auto.
apply parallelepipede_parallelogramme with (1 := H1).
Qed.

Lemma exercice_cube :
 forall A B C D E F G H I : PO,
 D <> F ->
 ~ alignes E B G ->
 cube A B C D E F G H ->
 I = centre_gravite E B G ->
 alignes F D I /\ orthogonaux (droite F D) (plan E B G).
intros A B C D E F G H I H0 H1 H2 H51; try assumption.
elim H2; intros; clear H2.
elim H3; intros; clear H3.
elim H5; intros H3 H6; elim H6; intros H7 H8; try clear H6 H5; try exact H8.
elim H4; intros H5 H6; try clear H4; try exact H6.
split; [ try assumption | idtac ].
elim
 exercice
  with
    (A := A)
    (B := B)
    (C := C)
    (D := D)
    (E := E)
    (F := F)
    (G := G)
    (H := H)
    (I := I); [ try clear exercice; auto | auto | auto | auto | auto ].
elim H5; intros; clear H5.
elim H9; intros H5 H10; elim H10; intros H11 H12; try clear H10 H9;
 try exact H12.
elim H2; intros.
elim H10; intros H13 H14; try clear H10; try exact H14.
elim H9; intros H10 H15; try clear H9; try exact H15.
cut (scalaire (vec A B) (vec A E) = 0); intros.
cut (scalaire (vec A B) (vec A D) = 0); intros.
cut (scalaire (vec A D) (vec A E) = 0); intros.
cut (E <> B); intros.
cut (E <> G); intros.
cut (vec F D = add_PP (vec F A) (vec A D)); intros.
apply def_orthogonaux; auto.
apply def_orthogonales; auto.
apply def_orthogonal2.
rewrite scalaire_sym.
rewrite H20.
rewrite scalaire_somme_g.
replace (scalaire (vec F A) (vec E B)) with 0.
replace (scalaire (vec A D) (vec E B)) with 0.
ring.
replace (vec E B) with
 (add_PP (mult_PP (-1) (vec A E)) (mult_PP 1 (vec A B))).
rewrite scalaire_lineaire_d.
rewrite H17.
rewrite scalaire_sym.
rewrite H16.
ring.
Ringvec.
replace (vec E B) with
 (add_PP (mult_PP (-1) (vec A E)) (mult_PP 1 (vec A B))).
replace (vec F A) with
 (add_PP (mult_PP (-1) (vec A E)) (mult_PP (-1) (vec A B))).
rewrite scalaire_bilineaire.
rewrite H11; rewrite H6; rewrite H9.
rewrite scalaire_sym.
rewrite H9.
ring.
rewrite H10; rewrite H15; rewrite H13.
Ringvec.
Ringvec.
apply def_orthogonales; auto.
apply def_orthogonal2.
replace (vec E G) with (add_PP (vec A B) (vec A D)).
rewrite scalaire_somme_g.
rewrite scalaire_sym.
rewrite (scalaire_sym A D F D).
rewrite H20.
rewrite scalaire_somme_g.
rewrite scalaire_somme_g.
rewrite H12.
rewrite (scalaire_sym A D A B).
rewrite H16.
replace (vec F A) with
 (add_PP (mult_PP (-1) (vec A E)) (mult_PP (-1) (vec A B))).
rewrite scalaire_lineaire_g.
rewrite scalaire_lineaire_g.
rewrite H11; rewrite H16.
rewrite scalaire_sym.
rewrite H9.
rewrite scalaire_sym.
rewrite H17.
ring.
rewrite H10; rewrite H15; rewrite H13.
Ringvec.
replace (vec E G) with (add_PP (vec E F) (vec F G)).
rewrite H10; rewrite H15; rewrite H13.
rewrite parallelepipede_parallelogramme with (1 := H2); auto.
Ringvec.
Ringvec.
apply distance_non_nulle.
replace (vec E G) with (add_PP (mult_PP 1 (vec A B)) (mult_PP 1 (vec A D))).
rewrite scalaire_bilineaire.
rewrite H11; rewrite H12; rewrite H16.
rewrite scalaire_sym; rewrite H16.
replace (1 * 1 * 1 + 1 * 1 * 0 + (1 * 1 * 0 + 1 * 1 * 1)) with 2.
discrR.
ring.
replace (vec E G) with (add_PP (vec E F) (vec F G)).
rewrite H10; rewrite H15; rewrite H13.
rewrite parallelepipede_parallelogramme with (1 := H2); auto.
Ringvec.
Ringvec.
apply distance_non_nulle.
replace (vec E B) with
 (add_PP (mult_PP (-1) (vec A E)) (mult_PP 1 (vec A B))).
rewrite scalaire_bilineaire.
rewrite H11; rewrite H9; rewrite H6.
rewrite scalaire_sym; rewrite H9.
replace (-1 * -1 * 1 + -1 * 1 * 0 + (1 * -1 * 0 + 1 * 1 * 1)) with 2.
discrR.
ring.
Ringvec.
apply def_orthogonal; auto.
apply def_orthogonal; auto.
apply def_orthogonal; auto.
Qed.

Lemma equilateral_non_alignes :
 forall A B C : PO,
 A <> B ->
 scalaire (vec A B) (vec A B) = scalaire (vec A C) (vec A C) ->
 scalaire (vec A B) (vec A B) = scalaire (vec B C) (vec B C) ->
 ~ alignes A B C.
intros A B C H H0 H1; red in |- *; intros H2; try exact H2.
halignes H2 k.
rewrite H3 in H0.
cut (vec B C = mult_PP (k + -1) (vec A B)); intros.
rewrite H4 in H1.
cut (k * k = 1); intros.
cut ((k + -1) * (k + -1) = 1); intros.
cut (k = 1 \/ k = -1); intros.
elim H7; [ intros H8; try clear H7; try exact H8 | intros H8; try clear H7 ].
rewrite H8 in H6.
absurd (0 = 1); auto with *.
rewrite <- H6; ring.
rewrite H8 in H6.
absurd ((-1 + -1) * (-1 + -1) = 1).
try discrR.
try assumption.
cut (k + -1 = 0 \/ k + 1 = 0); intros.
elim H7; [ intros H8; try clear H7; try exact H8 | intros H8; try clear H7 ].
left; try assumption.
replace k with (k + -1 + 1).
rewrite H8; ring.
ring.
right; try assumption.
replace k with (k + 1 + -1).
rewrite H8; ring.
ring.
apply Rmult_integral.
replace 0 with (k * k + -1).
ring.
rewrite H5; ring.
apply Rmult_eq_reg_l with (scalaire (vec A B) (vec A B)).
replace (scalaire (vec A B) (vec A B) * 1) with
 (scalaire (vec A B) (vec A B)).
pattern (scalaire (vec A B) (vec A B)) at 2 in |- *.
rewrite H1.
rewrite scalaire_mult_mult; ring.
ring.
unfold not in |- *; intros; apply H.
apply distance_nulle; auto.
apply Rmult_eq_reg_l with (scalaire (vec A B) (vec A B)).
replace (scalaire (vec A B) (vec A B) * 1) with
 (scalaire (vec A B) (vec A B)).
pattern (scalaire (vec A B) (vec A B)) at 2 in |- *.
rewrite H0.
rewrite scalaire_mult_mult; ring.
ring.
unfold not in |- *; intros; apply H.
apply distance_nulle; auto.
replace (vec B C) with (add_PP (vec A C) (mult_PP (-1) (vec A B))).
rewrite H3.
Ringvec.
Ringvec.
Qed.

Theorem the_cube :
 forall A B C D E F G H I : PO,
 cube A B C D E F G H ->
 I = centre_gravite E B G ->
 alignes F D I /\ orthogonaux (droite F D) (plan E B G).
intros A B C D E F G H I H0 H51; try assumption.
elim H0; intros.
elim H1; intros.
elim H3; intros.
elim H6; intros H7 H8; try clear H6; try exact H8.
elim H5; intros H6 H9; try clear H5; try exact H9.
elim H4; intros H5 H10; elim H10; intros H11 H12; try clear H10 H4;
 try exact H12.
elim H2; intros H4 H10; try clear H2; try exact H10.
elim H4; intros.
elim H13; intros H14 H15; elim H15; intros H16 H17; try clear H15 H13;
 try exact H16.
cut (vec A F = add_PP (mult_PP 1 (vec A B)) (mult_PP 1 (vec A E))); intros.
cut (scalaire (vec A B) (vec A E) = 0); intros.
cut (scalaire (vec A B) (vec A D) = 0); intros.
cut (scalaire (vec A D) (vec A E) = 0); intros.
apply exercice_cube with (3 := H0); auto.
apply distance_non_nulle.
replace (vec D F) with
 (add_PP (mult_PP 1 (vec A F)) (mult_PP (-1) (vec A D))).
rewrite scalaire_bilineaire.
replace (scalaire (vec A F) (vec A F)) with 2.
cut (scalaire (vec A F) (vec A D) = 0); intros.
rewrite H20; rewrite H17.
rewrite scalaire_sym; rewrite H20.
try discrR.
rewrite H13.
rewrite scalaire_lineaire_g.
rewrite H18.
rewrite scalaire_sym; rewrite H19.
ring.
rewrite H13.
rewrite scalaire_bilineaire.
rewrite H15; rewrite H10; rewrite H16.
rewrite scalaire_sym; rewrite H15.
ring.
Ringvec.
cut (vec E B = add_PP (mult_PP 1 (vec A B)) (mult_PP (-1) (vec A E))); intros.
cut (vec E G = add_PP (mult_PP 1 (vec A B)) (mult_PP 1 (vec A D))); intros.
apply equilateral_non_alignes; auto.
apply distance_non_nulle.
rewrite H20.
rewrite scalaire_bilineaire.
rewrite H15; rewrite H10; rewrite H16.
rewrite scalaire_sym; rewrite H15.
try discrR.
rewrite H20.
rewrite scalaire_bilineaire.
rewrite H21.
rewrite scalaire_bilineaire.
rewrite H15; rewrite H10; rewrite H16.
rewrite scalaire_sym; rewrite H15.
rewrite H17; rewrite H18.
rewrite scalaire_sym; rewrite H18.
ring.
replace (vec B G) with
 (add_PP (mult_PP 1 (vec E G)) (mult_PP (-1) (vec E B))).
rewrite scalaire_bilineaire.
rewrite H20.
rewrite scalaire_bilineaire.
rewrite H21.
repeat rewrite scalaire_bilineaire.
rewrite H15; rewrite H10; rewrite H16.
rewrite scalaire_sym; rewrite H15.
rewrite H17; rewrite H18.
rewrite scalaire_sym; rewrite H18.
rewrite H19; rewrite scalaire_sym; rewrite H19.
ring.
Ringvec.
rewrite <- H8.
rewrite H6; rewrite H9.
Ringvec.
Ringvec.
apply def_orthogonal; auto.
apply def_orthogonal; auto.
apply def_orthogonal; auto.
rewrite H6; rewrite H9; rewrite H7.
Ringvec.
Qed.


From Coq Require Import Zify.
From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun zify.
From fcsl
Require Import prelude pred pcm unionmap heap.
From HTT
Require Import stmod stsep stlog stlogR.
From Hammer Require Import Tactics.
Require Import ZArith.

(* The empty heap *)
Definition empty := @PCM.unit heapPCM.

(* No-op at the end of a program branch *)

Definition skip := ret tt.

Inductive ltac_No_arg : Set :=
| ltac_no_arg : ltac_No_arg.

(* Utilities to move a heaplet around within a heap *)

Ltac put_to_tail_ptr p :=
  try rewrite ptrA; rewrite -?joinA; rewrite ?(joinC (p :-> _) _); rewrite ?joinA.

Ltac put_to_tail h :=
  try rewrite ptrA; rewrite -?joinA; rewrite ?(joinC h _); rewrite ?joinA.

Ltac put_to_head_ptr p :=
  put_to_tail p;
  try rewrite (joinC _ (p :-> _)).

Ltac put_to_head h :=
  put_to_tail h;
  try rewrite (joinC _ h).

(* Store heap validity assertions *)
Ltac store_valid :=
  rewrite ?unitL ?unitR;
  try match goal with
  | [|- is_true (valid _) -> _] =>
    let hyp := fresh "H_valid" in move=>hyp;
    store_valid
  end.

(* If goal is to prove a pointer is not null, derive that fact from one of the heap validity assertions *)
Ltac assert_not_null :=
  let derive H x := (
    rewrite ?joinA in H;
    rewrite -?(joinC (x :-> _)) in H;
    rewrite ?joinA in H;
    move:(H);
    rewrite defPtUnO;
    case/andP;
    let not_null := fresh "not_null" in move=>not_null _;
    assumption) in
  match goal with
  | [H: is_true (valid ?h) |- is_true (?x != null)] =>
    derive H x
  end.

(* Theory about predicates (to be filled by each certificate) *)

Create HintDb ssl_pred.

(* Theory about pure constraints (to be filled by each certificate) *)

Create HintDb ssl_pure.

(* Extend auto with additional strategies *)

Ltac eq_bool_to_prop :=
  repeat match goal with
         | [H: is_true (_ == _) |- _] => move/eqP in H
         end.

Ltac solve_perm_eq :=
  let n := fresh "n" in
  apply/permP=>n;
  repeat match goal with
         | [H: is_true (perm_eq _ _) |- _] => move/permP in H; move:(H n)
         end;
  move=>//=;
  rewrite ?count_cat;
  zify; lia.

Ltac solve_pure := (timeout 2 progress eauto 2 with ssl_pure) + (sauto depth: 3).

Ltac sslauto :=
  let simplify := eq_bool_to_prop; subst in
  repeat apply conj;
  match goal with
  | [|- {subset _ <= _}] => simplify; unshelve solve_pure; done
  | [|- is_true (perm_eq _ _)] => solve_perm_eq
  | [|- _ = _] => simplify; rewrite ?unitL ?unitR; hhauto
  | [|- is_true (_ == _)] => simplify; apply/eqP; unshelve solve_pure; done
  | [|- is_true (_ < _)] => simplify; unshelve solve_pure; done
  | [|- is_true (_ <= _)] => simplify; unshelve solve_pure; done
  | _ => idtac
  end.

Ltac ex_elim1 A := try clear dependent A; move=>[A].
Ltac ex_elim2 A B := try clear dependent A; try clear dependent B; move=>[A][B].
Ltac ex_elim3 A B C := try clear dependent A; try clear dependent B; try clear dependent C; move=>[A][B][C].

Tactic Notation "ex_elim" ident(A) := ex_elim1 A.
Tactic Notation "ex_elim" ident(A) ident(B) := ex_elim2 A B.
Tactic Notation "ex_elim" ident(A) ident(B) ident(C) := ex_elim3 A B C.
Tactic Notation "ex_elim" ident(A) ident(B) ident(C) ident(D) := ex_elim2 A B; ex_elim2 C D.
Tactic Notation "ex_elim" ident(A) ident(B) ident(C) ident(D) ident(E) := ex_elim2 A B; ex_elim3 C D E.
Tactic Notation "ex_elim" ident(A) ident(B) ident(C) ident(D) ident(E) ident(F) := ex_elim3 A B C; ex_elim3 D E F.

(***********)
(* Tactics *)
(***********)

(* After binding program variables to their correct labels, we use the Coq's default simplification algorithm *)

Ltac ssl_program_simpl := Tactics.program_simpl.

(* Ghost Variable Elim *)

Ltac ssl_ghostelim_pre := try apply: ghR; move=>h_self//=.

Ltac ssl_ghostelim_post := store_valid.

(* Read Rule *)

Ltac ssl_read from :=
  put_to_head_ptr from;
  apply: bnd_readR=>/=.

(* Write Rule *)

Ltac ssl_write x :=
  put_to_head_ptr x; (* this significantly speeds up bnd_writeR *)
  apply: bnd_writeR=>/=.

Ltac ssl_write_post x :=
  (put_to_tail_ptr x + rewrite -(unitL (x :-> _))); apply frame.

(* Alloc Rule *)

Ltac ssl_alloc x :=
  apply: bnd_allocbR=>x//=.

(* Free Rule *)

Ltac ssl_dealloc x :=
  apply: bnd_seq;
  put_to_head_ptr x;
  apply: val_deallocR=>//=_;
  rewrite ?unitR.

(* Call Rule *)

Ltac ssl_call_pre_aux h :=
  match h with
  | ?h1 \+ ?h2 => put_to_head h2; ssl_call_pre_aux h1
  | _ => put_to_head h
  end.

Ltac ssl_call_pre h :=
  ssl_call_pre_aux h;
  rewrite ?joinA;
  rewrite -?(joinA h).

Ltac ssl_call' ex :=
  apply: bnd_seq;
  match ex with
  | ltac_No_arg => idtac
  | _ => apply: (gh_ex ex)
  end;
  apply: val_do=>//=;
  move=>_.

Tactic Notation "ssl_call" := ssl_call' ltac_No_arg.
Tactic Notation "ssl_call" constr(ex) := ssl_call' ex.

(* Emp Rule *)

Ltac ssl_emp := apply: val_ret; rewrite ?unitL; store_valid; move=>//.

(* Open Rule *)

Ltac conjuncts_to_ctx :=
  match goal with
  | [|- is_true (_ && _) -> _ ] => case/andP; conjuncts_to_ctx; let H := fresh "H_cond" in move=>H
  | _ => let H := fresh "H_cond" in move=>H
  end.

Ltac demorgan' :=
  match goal with
  | [|- context [~~ (_ && _)]] => rewrite Bool.negb_andb; demorgan'
  | [|- context [~~ (_ || _)]] => rewrite Bool.negb_orb; demorgan'
  | _ => idtac
  end.

Ltac demorgan :=
  demorgan';
  conjuncts_to_ctx.

Ltac ssl_open sel hyp :=
  let H := fresh "H_cond" in
  case: hyp;
  (case: (ifP sel); try move/negbT; demorgan; move=>_//) + demorgan .

(* Branch Rule *)

Ltac ssl_branch sel :=
  let H := fresh "H_cond" in
  try case: (ifP sel);
  try move/negbT;
  try demorgan.

(* Inconsistency Rule *)

Ltac ssl_inconsistency :=
  match goal with
  | [H_true: is_true ?sel, H_false: is_true (~~ ?sel) |- _] => rewrite H_true in H_false=>//=
  end.

(* Close Rule *)

Ltac ssl_close n :=
  match n with
  | 1 => constructor 1=>//
  | 2 => constructor 2=>//
  | 3 => constructor 3=>//
  | _ => constructor=>//
  end;
  match goal with
  | [|- is_true (_ != null)] => assert_not_null
  | [|- (_ == null) = false] => apply negbTE; assert_not_null
  | _ => idtac
  end.

(* Frame Unfold Rule *)

Ltac ssl_frame_unfold :=
  (eq_bool_to_prop; subst; assumption) + (timeout 3 eauto 2 with ssl_pred).