(* This file formalizes (Waldmann 2017) which does a good job
    on constructing a transition system on CDCL algorithm.
  http://rg1-teaching.mpi-inf.mpg.de/autrea-ws17/script.pdf, P29

*)
Require Import src.rproof.

Require Import Coq.Classes.Equivalence.
Require Import Coq.Classes.EquivDec.
Require Import Coq.Logic.Decidable.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.

Open Scope type_scope.
Open Scope list_scope.

Module CDCLtransition.

Section CDCLtransitionNeedEqDec.

Context {V:Set}.

Context {H: EqDec_eq V}.

Notation "t '[' x ':=' s ']' h" := (assign_pa x s t h) (at level 201).
Notation "∅" := empty_pa.

(* Assignment Stack records the decision point and partial assignment *)
(* The first PAssignment V is the guessed literal, the second is deduced literals *)
(* Definition AssignmentStack (V: Set) := list ( PAssignment V * PAssignment V). *)
(*
Maintain the invariance that
  AS f (g,d)
(f conj g) imply d
*)
(* We choose to use CNF to represent formula here
    but in the resolution proof we uses Formula V to represent formula
The specfication for assignment stack is that
  the invariance of
    {AS f ((g,d)::s) ->
    RProof (fconj f g) d}
  holds all the time
    *)
Inductive AssignmentStack  (f : CNF V) :
  list (PAssignment V * PAssignment V) -> Set :=
  | empty_as : AssignmentStack f ((∅,∅)::nil)
  | guess_as : forall {g} {d} x b {s},
      AssignmentStack f ((g, d)::s) ->
      forall (h : PA g x = None) (h2 : PA d x = None),
      AssignmentStack f (((g[x := b]h), d[x:=b]h2)::(g,d)::s)
  (* Decide *)
  | deduce_as : forall {g} {d} {s} x b,
      AssignmentStack f ((g, d)::s) ->
      forall (h : PA d x = None),
      RProof (fconj (CNFFormula f) (LiteralsFormPA g)) (flit (ToLiteral x b)) ->
      AssignmentStack f ((g, d[x := b]h)::s).
  (* Unit Prop *)
(* change_goal is used to implement learn and forget *)
(* The invariant include the later one must
  have consistent assignment as the
  former ones
*)

Hint Constructors AssignmentStack.

Notation AS := AssignmentStack.

Theorem LiteralsFormPAcomm:
  forall  {g} {x : V} {b} {h},
    (LiteralsFormPA (g [x := b] h)) = fconj (flit (ToLiteral x b)) (LiteralsFormPA g).
  intros g.
  induction g; intros; cbn in *; eauto.
Qed.

Theorem PA_assign_comm:
  forall  {g : PAssignment V} {x b v h},
  PA (g [x := b] h) v =
    if (eq_dec v x) then Some b else PA g v.
  intros g.
  destruct g as [fg fp].
  induction fp; intros; cbn in *; eauto.
Qed.

Hint Constructors RProof.

Proposition AssignmentStackHasRProof:
  forall  {f : CNF V} {g d s},
    AS f ((g,d)::s) ->
    RProof (fconj (CNFFormula f) (LiteralsFormPA g)) (LiteralsFormPA d).

intros f g d s.
remember ((g, d) :: s) as s'.
intros h.
generalize dependent g. generalize dependent d. generalize dependent s.
induction h; intros;
repeat match goal with
| [h : (?u :: ?v) = (?a :: ?b) |- _] =>
  inversion h; subst; cbn in *
end;
repeat rewrite LiteralsFormPAcomm;
try (pose (IHh _ _ _ eq_refl)).
+ eauto.
+ eapply rp_trans. eapply rp_comm_conj. eapply rp_weaken3.
  eauto.
+ eapply rp_rconj; eauto.
Qed.

Theorem AssignmentStackGSubD:
  forall  {f : CNF V} {g d s},
  AS f ((g, d) :: s) ->
  forall v T,
    PA g v = Some T ->
    PA d v = Some T.
  intros f g d s.
  remember ((g, d) :: s) as s'.
  intros h.
  generalize dependent g. generalize dependent d. generalize dependent s.
  induction h; intros; eauto;
  repeat match goal with
  | [h : (?u :: ?v) = (?a :: ?b) |- _] =>
  inversion h; subst; cbn in *
  end;
eauto;
repeat rewrite PA_assign_comm in *;
try match goal with
  | [h : PA (?g [?x := ?b ] ?h0) ?v = _ |- _] =>
    rewrite PA_assign_comm in h
end;
match goal with
| [|- context[eq_dec ?a ?b]] =>
  destruct (eq_dec a b); subst; eauto; try contradiction
end.
pose (IHh _ _ _ eq_refl _ _ H0) as Heqn.
clear Heqs'.
rewrite Heqn in *;
match goal with
| [h : Some _ = None |- _] => inversion h
end.
Qed.

Proposition AssignmentStackMonotoncity:
  forall  {f : CNF V} { t s},
  AS f (t::s) ->
  s <> nil ->
  AS f s.

intros f t s.
remember (t :: s) as s'.
intros h.
generalize dependent t. generalize dependent s.

induction h; intros;
repeat match goal with
| [h : (?u :: ?v) = (?a :: ?b) |- _] =>
  inversion h; subst; cbn in *
end; try contradiction; eauto.
Qed.

Proposition AssignmentStackMonotoncity2:
  forall  {f : CNF V} {k s},
  AS f (k ++ s) ->
  s <> nil ->
  AS f s.

intros f k.
generalize dependent f.
induction k; intros; subst; eauto.

rewrite <- List.app_comm_cons in *.
eapply IHk; eauto.
eapply AssignmentStackMonotoncity; eauto.
intro hh.
destruct (List.app_eq_nil _ _ hh); subst; try contradiction.
Qed.

Theorem change_goal:
  forall  {g} {s} (f : CNF V),
    AssignmentStack g s ->
    RProof (CNFFormula f) (CNFFormula g) ->
    AssignmentStack f s.
  intros g s f h.
  generalize dependent f.
  induction h; intros; subst; eauto.
  pose (IHh _ H0).
  eapply deduce_as; [eauto | idtac].
  eauto.
Qed.

(*
Definition RProofInv
    (orginal : Formula V)
    (guessedLiterals deducedLiterals: PAssignment V) :=
    RProof (fconj orginal (LiteralsFormPA guessedLiterals)) (LiteralsFormPA deducedLiterals).

Fixpoint RProofInvAStack {V}
    (original : Formula V)
    (astack : AssignmentStack V) : Prop :=
  match astack with
  | nil => *)

(* Note that
  CDCL are really doing proof search for undecdiability proof
  We can consider the invariant for each step here is that
    Assignment
*)

(* Inductive FinalState {V : Set} : CDCLState (V := V) -> Prop :=
  | failst : forall a c, (CNFByPAssignment c a = Some false) -> FinalState (a::nil, c)
  | succeedst : forall a b c, (CNFByPAssignment c a = Some true) -> FinalState (a::b, c). *)

Definition PeelOffPA
  {pa : PAssignment V} (h : forall x, PA pa x <> None) :
  {f : V -> bool | forall x, PA pa x = Some (f x)}.

  refine
  (exist _ (fun v =>
    match (PA pa v) with
    | Some k =>  k
    | None => true
    end ) _).
  intros.
  destruct (PA pa x) eqn:hc; eauto.
  destruct (h _ hc).
Qed.

Definition FullPA
{pa : PAssignment V} (h : forall x, PA pa x <> None) :
  forall v, {result : bool | PA pa v = Some result } :=
  fun v =>
  let (fa, p2) := PeelOffPA h
  in let result  := fa v
  in  exist _ result (p2 v).

Corollary AssignmentStackGSubD2:
  forall  {f : CNF V} {g d s},
  AS f ((g, d) :: s) ->
  forall v,
    PA d v = None ->
    PA g v = None.
  intros f g d s h0 v hh.
  pose (AssignmentStackGSubD h0) as h1.
  destruct (PA g v) eqn:Heq2; subst; eauto.
  pose (h1 _ _ Heq2) as h3.
  rewrite h3 in hh; try inversion hh.
Qed.

(* | guess_as : forall {g} {d} x b {s},
AssignmentStack f ((g, d)::s) ->
forall (h : PA g x = None) (h2 : PA d x = None),
AssignmentStack f (((g[x := b]h), d[x:=b]h2)::(g,d)::s)  *)

(* Now we should be able to construct the four basic methods
    unit_propagation, decide, fail, backjump
*)

Definition VofLiteral {V : Set} (l : Literal V) : V :=
  match l with
  | positive x => x
  | negative x => x
  end.

Definition PolarityofLiteral {V : Set} (l : Literal V) : bool :=
  match l with
  | positive x => true
  | negative x => false
  end.

Definition unit_prop_AS_spec: forall  {l c g d s f x b},
  (*
    We later need to relax this - l doesn't have to be the first
    term; l::c doesn't have to be the first term
  *)
  AS ((l::c)::f) ((g,d) :: s) ->
  l = ToLiteral x b ->
  (* eval C under d = false -> *)
  ClauseByPAssignment c d = Some false ->
  (* PA d l = None -> *)
  forall (h : PA d x = None),
  AS ((l::c)::f) ((g,d[x := b]h) :: s).
  intros. eapply deduce_as; [eauto | idtac].
  pose (AssignmentStackHasRProof H0) as HH0. cbn in *.
  match goal with
  | [HH0 := _ : RProof (fconj (fconj ?a ?d) ?b) ?c |- _] =>
      assert (RProof (fconj (fconj a d) b) a) as HH1
  end; subst;
  [eapply rp_trans; eapply rp_weaken | idtac].
  pose (rp_byassign2 H2) as HH3.
  pose (rp_trans HH0 HH3) as HH4.
  pose (rp_res HH1 HH4) as HH5. auto.
Qed.

(* TODO: prove it by crush *)

Definition decide_AS_spec  {f g d s} x b
  (stack : AS f ((g, d)::s))
  (h : PA d x = None) :
  AS f (((g[x := b](AssignmentStackGSubD2 stack _ h)), d[x:=b] h)::(g,d)::s).
  eauto.
Defined.

Lemma AS_no_guessing:
  forall {f g d},
  AS f ((g, d) :: nil) ->
  g = ∅.
intros f g d. remember ((g, d) :: nil) as s.
intros H0. generalize dependent g. generalize dependent d.
induction H0; intros; subst; eauto; try discriminate; try contradiction;
match goal with
| [h : ?a::?b = ?c::?d |- _] =>
    inversion h; intros; subst; eauto
end.
Qed.

Definition fail_AS_spec: forall {c f g d},
  AS (c::f) ((g, d) ::nil) ->
  ClauseByPAssignment c d = Some false ->
  RProof (CNFFormula (c:: f)) fbot.

intros c f g d H0 H1.
pose (AS_no_guessing H0) as HH'.
generalize HH'. intros HH. clear HH'. subst.
pose (AssignmentStackHasRProof H0) as H2.
pose (rp_byassign2 H1) as H3. cbn in *.
pose (rp_trans H2 H3) as H4.
eapply rp_trans; [idtac | eapply rp_contra]; eauto.
Qed.

Ltac breakAssumpt1:=
  match goal with
  | [h0 : match ?exp with _ => _ end = _ |- _ ] =>
    let heq := fresh "heq" in
    destruct exp eqn:heq; try discriminate; try contradiction
  end.
Ltac try_injection :=
    match goal with
    | [h : Some _ = Some _ |- _] =>
      injection h; intros; subst; eauto;  generalize h; clear h;
      try_injection;
      intro h
    | _ => idtac
    end.

Theorem PA_consistent_with_A'':
forall {f pa g q},
  LiteralByPAssignment f pa = Some q ->
  (forall x t,
      PA pa x = Some t ->
      PA pa x = Some (g x)
    ) ->
    LiteralByPAssignment f pa = Some (LiteralByAssignment f g).
  unfold LiteralByAssignment. unfold LiteralByPAssignment.
  intros f pa g q H0 h. repeat breakAssumpt3; cbn in *; try_injection; subst; eauto.
  erewrite h in heq0; eauto; try_injection .
Qed.

Theorem PA_consistent_with_A''':
forall {f pa g q},
  LiteralByPAssignment f pa = Some q ->
  (forall x t,
      PA pa x = Some t ->
      PA pa x = Some (g x)
    ) ->
    LiteralByAssignment f g = q.
intros f pa g q H0 H1. erewrite PA_consistent_with_A'' in H0; eauto; try_injection; auto.
Qed.

Theorem PA_consistent_with_A':
  forall {f pa g q},
    ClauseByPAssignment f pa = Some q ->
    (forall x t,
        PA pa x = Some t ->
        PA pa x = Some (g x)
      ) ->
      (ClauseByAssignment f g) = q.
  intros f.
  induction f; intros pa g q h0 h1;  subst; cbn in *; subst; eauto;
  repeat breakAssumpt1; try_injection; subst; eauto; cbn in *.

  repeat erewrite PA_consistent_with_A'''; eauto;
  repeat try_injection; cbn in *; auto.

  repeat erewrite PA_consistent_with_A'''; eauto;
  repeat try_injection; cbn in *; auto.

  Ltac try_injection2 :=
    match goal with
    | [h : Some _ = Some _ |- _] =>
      injection h; intros; subst; eauto;
      clear h;
      try_injection
    | _ => idtac
    end.

  try_injection2;subst; eauto;
  repeat erewrite IHf; eauto;
  repeat erewrite PA_consistent_with_A'''; eauto;
  repeat try_injection; cbn in *; auto.

  try_injection2. erewrite IHf; eauto. simpl_bool. auto.
Qed.

Theorem PA_consistent_with_A0:
  forall {f pa g q},
    CNFByPAssignment f pa = Some q ->
    (forall x t,
        PA pa x = Some t ->
        PA pa x = Some (g x)
      ) ->
      (CNFByAssignment f g) = q.
  intros f.
  induction f; intros pa g q h0 h1; cbn in *; subst; eauto; try_injection2; auto .
  repeat breakAssumpt1; try_injection2; subst; eauto;
  try (
    repeat erewrite PA_consistent_with_A'; eauto; cbn in *; auto;
    repeat erewrite IHf; eauto; cbn in *; simpl_bool; eauto; fail
  ).
  cbn in *.

  erewrite IHf; eauto; simpl_bool; auto.
Qed.

Theorem PA_consistent_with_A:
  forall {f pa g},
    CNFByPAssignment f pa <> None ->
    (forall x,
        PA pa x <> None ->
        PA pa x = Some (g x)
      ) ->
      CNFByPAssignment f pa = Some (CNFByAssignment f g).

  intros f pa g H0 H1.
  assert (forall x t,
    PA pa x = Some t ->
    PA pa x = Some (g x)) as H2.
  + intros x t h. eapply H1; subst; rewrite h in *; eauto.
    try discriminate.
  +
  destruct (CNFByPAssignment f pa) eqn:H3;
  try (try rewrite H3 in H0; try discriminate; try contradiction; fail).
  pose (PA_consistent_with_A0 H3 H2) as res; eauto.
  rewrite res in *; try_injection; eauto.
Qed.

Definition extendPA (pa : PAssignment V) : Assignment V :=
  fun v =>
    match PA pa v with
    | Some k => k
    | None => true
    end.

Corollary PA_consistent_with_ExtendedA:
  forall {f pa},
  CNFByPAssignment f pa <> None ->
  CNFByPAssignment f pa = Some (CNFByAssignment f (extendPA pa)).
  intros; eapply PA_consistent_with_A; eauto.
  unfold extendPA. intros; destruct (PA pa x); subst; eauto; try discriminate; try contradiction.
Qed.

(* Make higher order assignment into
    First order data.
*)
(* Definition allfalse: Assignment V := fun _ => false.
Definition newAssignment   {V : Set} `{EqDec_eq V} v b f : (Assignment V) :=
  fun k =>
    match (eq_dec k v) with
    | left _ => b
    | right _ => f k
    end.
Inductive TruthTable : (Assignment V) -> Set :=
| empty_tb : TruthTable allfalse
| assign_fa : forall {f} (v : V) (b : bool),
  TruthTable f ->
  TruthTable (newAssignment v b f). *)

(* Definition succeed_AS_spec: forall {f g d s},
  AS f ((g, d) ::s) ->
  CNFByPAssignment f d = Some true ->
  {g2 | CNFByAssignment f g2 = true}.
intros f g d s H0 H1. exists (extendPA d).
assert (CNFByPAssignment f d <> None) as H2. repeat rewrite H1 in *.
intro; try discriminate; try contradiction.
pose (PA_consistent_with_ExtendedA H2) as H3.
rewrite H3 in H1. inversion H1; subst; eauto.
Qed. *)

Definition succeed_AS_spec: forall {f g d s},
  AS f ((g, d) ::s) ->
  CNFByPAssignment f d = Some true ->
  {g2  | CNFByPAssignment f g2 = Some true}.
intros f g d s H0 H1.
exists d; eauto.
Qed.

Definition backjump_AS_spec: forall  {f C k g d s l} x b,
  (*
    We later need to relax this - l doesn't have to be the first
    term; l::c doesn't have to be the first term
  *)
  AS f (k ++ (g,d) :: s) ->
  l = ToLiteral x b ->
  (* f ⊧ C ∨ l*)
  RProof (CNFFormula f) (fdisj C (flit l)) ->
  (* eval C under d = false -> *)
  FormulaByPAssignment C d = Some false ->
  (* PA d l = None -> *)
  forall (h : PA d x = None),
  AS f ((g,d[x := b]h) :: s).

intros f C k g d s l x b h0.

assert (AS f ((g,d) :: s)) as H0; try eapply AssignmentStackMonotoncity2; try eapply h0.
intro HC. inversion HC.
assert (RProof (fconj (CNFFormula f) (LiteralsFormPA g)) (LiteralsFormPA d)) as H2; try eapply AssignmentStackHasRProof; eauto.
intros h1 h2 h3 h.
assert (RProof (LiteralsFormPA d) (fneg C)) as H4; try eapply rp_byassign4; eauto.
assert (RProof (fconj (CNFFormula f) (LiteralsFormPA g)) (fneg C)) as H5; eauto.
assert (RProof (fconj (CNFFormula f) (LiteralsFormPA g)) (fdisj C (flit l))) as H6; eauto.
assert (RProof (fconj (CNFFormula f) (LiteralsFormPA g))  (flit l)) as H7.
+ eapply rp_res; [idtac | eauto]. eapply rp_comm_disj. eauto.
+ subst. eauto.
Qed.

(* We will have a non-determinism state transition machine
   We need to introduce monad to make/effect it "effect-free"
      (Maybe into a step : state -> Set(state))

   And make sure we have a terminating state transition.
    So let's first not focus on terminating

    Let's focus on satisfiable and unsatisfiability proof.
    Satisfiability is trivial.

    But Unsatisfiaibility is not,
    we need to track the resolution proof as well

    We need to show the invariant that
    Theorem 2.16 in (Waldmann 2017), basically
    N together with the guessing decision of literals
        implies all the current literals
*)

(*
Definition SucceedAS  {f s} (st : AS f s) : Prop :=
    match s with
    | nil => False
    | (_, d) :: _ => CNFByPAssignment f d = Some true
    end.

Definition FailedAS  {f s} (st : AS f s) : Set :=
    RProof (CNFFormula f) fbot.

Definition FinalAS  {f s} (st : AS f s) := FailedState st + {SucceedState st} .
   *)

(* A CDCL state targeting to solve formula f
      g is the learned clauses
      s is the current assignment stack
*)

Definition CDCLState  (f learned: CNF V)  :=
  {s & (AS (learned ++ f) s) * RProof (CNFFormula f) (CNFFormula learned)}.

Lemma all_clause_are_derivable: forall {f l},
  CDCLState f l ->
  RProof (CNFFormula f) (CNFFormula (l ++ f)).

  intros f l h.
  destruct h as [st [h1 h2]].
  eapply rp_cnf_conj; eauto.
Qed.

(* This learned clause is not only useful for learning/forgetting
    But it is also useful for unit-prop, because the current unit-prop
      can only resolve  the very first clause in the f : CNF V (as a list)
    thus we can hack with learning the resolvent clause at the front and do the unit prop
    and then forgetting, this gives us a better unit-prop
*)

Definition SucceedState  {f l} (st : CDCLState f l) : Prop :=
  match st with
  | existT _ s _ =>
    match s with
    | (_, d) :: _ => CNFByPAssignment f d = Some true
    | _ => False
    end
  end.

Definition FailedState  {f l} (st : CDCLState f l) : Prop :=
    match st with
    | existT _ s _ =>
      match s with
      | (_, d) :: nil => CNFByPAssignment f d = Some false
      | _ => False
      end
    end.

Definition ConflictingState  {f l} (st : CDCLState f l) : Prop :=
      match st with
      | existT _ s _ =>
        match s with
        | (_, d) :: _ => CNFByPAssignment (l ++ f) d = Some false
        | _ => False
        end
      end.

Definition FinalState {f l} (st : CDCLState f l) :=
  SucceedState st \/ FailedState st.

Ltac try_both_side:=
  try (left; eauto; try contradiction; try discriminate; fail);
  try (right; eauto; try contradiction; try discriminate; fail).

Definition SucceedState_Dec {f l} (st : CDCLState f l):
  {SucceedState st} + {~SucceedState st}.
destruct st as [st1 st2]. cbn in *.
destruct st1 as [_ | [g d] t];try_both_side.
destruct (CNFByPAssignment f d); try_both_side.
destruct b; try_both_side.
Qed.

Definition FailedState_Dec {f l} (st : CDCLState f l):
  {FailedState st} + {~FailedState st}.
destruct st as [st1 st2]. cbn in *.
destruct st1 as [_ | [g d] t];try_both_side.
destruct t; try_both_side.
destruct (CNFByPAssignment f d); try_both_side.
destruct b; try_both_side.
Qed.

Ltac try_all_branch :=
  match goal with
  | [|- _ + {_}] =>
    try (left;try_all_branch; eauto; try contradiction; try discriminate; fail);
    try (right;try_all_branch; eauto; try contradiction; try discriminate; fail)

  |  [|- {_} + {_}] =>
    try (left;try_all_branch; eauto; try contradiction; try discriminate; fail);
    try (right;try_all_branch; eauto; try contradiction; try discriminate; fail)
  | _ => idtac
  end.

Definition FinalState_Dec:
  forall {f l} (st : CDCLState f l),
    {SucceedState st} + {FailedState st} + {~ FinalState st}.
intros. unfold FinalState.
destruct (SucceedState_Dec st); try_all_branch.
destruct (FailedState_Dec st); try_all_branch.
right. intro H0. destruct H0; try contradiction.
Qed.

Definition ConflictingState_Dec:
  forall {f l} (st : CDCLState f l),
    {ConflictingState st} + {~ ConflictingState st}.
destruct st as [st1 st2]. cbn in *.
destruct st1 as [_ | [g d] t];try_both_side.

destruct (CNFByPAssignment (l ++ f) d); try_both_side.
destruct b; try_both_side.
Qed.

Theorem SucceedSt_extract:
  forall {f l} (st : CDCLState f l),
    SucceedState st ->
    {g2 | CNFByPAssignment f g2 = Some true}.

  unfold SucceedState. intros.
  destruct st as [s  other].
  destruct s; cbn in *; try contradiction.
  destruct p. eauto.
Qed.

Theorem find_false_clause':
  forall {f : CNF V} {a h t},
    f = h :: t ->
    CNFByPAssignment f a = Some false ->
    {ClauseByPAssignment h a = Some false} +
    {CNFByPAssignment t a = Some false}.
  intros f. induction f; intros assign h t h0 h1; try contradiction; try discriminate.
  cbn in *.
  repeat breakAssumpt1; injection h0; intros; subst; eauto.
  try (destruct b0;  subst; eauto; cbn in *; try contradiction; try discriminate; eauto; fail).

Qed.

Theorem find_false_clause:
  forall {f : CNF V} {a h t},
    f = h :: t ->
    CNFByPAssignment f a = Some false ->
    {i | ClauseByPAssignment (nth i f nil) a = Some false /\ i < length f}.
    intros f. induction f;intros assign h t h0 h1; try contradiction; try discriminate.
    injection h0; intros; subst; eauto.
    destruct (find_false_clause' h0 h1).
    + exists 0; cbn in *; split; eauto. lia.
    + destruct t; try (cbn in *; try contradiction; try discriminate; fail).
      destruct (IHf _ _ _ eq_refl e) as [i' [hi1 hi2]].
      exists (S i'); cbn in *; split; eauto. lia.
Qed.

Theorem FailedSt_extract:
  forall {f l} (st : CDCLState f l),
  f <> nil ->
  FailedState st ->
  RProof (CNFFormula f) fbot.

  unfold FailedState. intros.  pose st as org_st.
  destruct f; try contradiction.
  destruct st as [s other].
  destruct s; try contradiction.
  destruct p as [other2 d].
  destruct s; try contradiction.
  destruct (find_false_clause eq_refl H1)
    as [index [h1 h2]].
  pose (rp_cnf_weaken3 h2) as r.
  pose (rp_byassign2 h1) as r0.
  eapply rp_trans; [idtac | eapply rp_contra0].
  eapply rp_rconj; [eauto | idtac ].
  eapply rp_trans; [idtac | eapply r0].
  eapply rp_trans; [eapply (all_clause_are_derivable org_st) |idtac].
  destruct other as [theAS r00].
  assert (other2 = ∅); [eapply AS_no_guessing; eauto | idtac]; subst.
  pose (AssignmentStackHasRProof theAS) as res. cbn in res.
  eapply rp_trans;[idtac| exact res]; eauto.
Qed.

  (* The invariant here for (k : CDCLState f)
  1. if SucceedState k
      then assignment from k can evaluate f into true
  2. if FailedState k
      then I can extract (RProof (CNFFormula f) fbot)
*)

(* The following are the extracted functions
    they all have similar signature as
    CDCL f * (... sth else needed) -> CDCL f
    basically these can be seen as
    non-determinstic transition in a (CDCL f) world
*)

Definition lift_AS_op
  (f : forall {L s1}, AS L s1 -> {s2 & AS L s2}): forall {F L}, CDCLState F L -> CDCLState F L.
  intros F L st.
  destruct st as [s1 [as1 other]].
  destruct (f _ _ as1) as [s2 as2].
  exact  (existT _ s2 (as2, other)).
Qed.

(* One step unit-prop spec*)

Lemma nth_error_overbound:
  forall {T}  {l : list T} {i}
    (H0: nth_error l i = None),
    i >= length l.
  intros T l. induction l; intros; cbn in *; subst;  eauto.
  lia. destruct i; subst; try contradiction; try discriminate.
  cbn in *. pose (IHl _ H0). lia.
Defined.

(* Definition nthsafe {T} (i : nat) (l : list T) (h : i < length l) : T.
  destruct (nth_error l i) eqn:heq0.
  + exact t.
  + pose (nth_error_overbound heq0); lia.
Defined. *)

Definition UnitClause (c : Clause V) a :=
  {i | exists h : i < length c,
       LiteralByPAssignment (nthsafe i c h) a = None
       /\ forall j (h2 : j < length c),
            j <> i ->
            LiteralByPAssignment (nthsafe j c h2) a = Some false
  }.

Lemma UnitClauseNeverEmpty c :
  forall {a}, UnitClause c a ->
  c <> nil.
intros a h.
destruct c; try (intro; eauto; try discriminate).
destruct h as [i [h _]]; cbn in *; try contradiction. lia.
Qed.

Lemma UnitClauseNeverEmpty' :
  forall {a}, UnitClause nil a ->
  False.
intros a h.
destruct h as [i [h _]]; cbn in *; try contradiction. lia.
Qed.

(* Definition AllFalseClause (c : Clause V) a :=
  forall j (h2 : j < length c),
    LiteralByPAssignment (nthsafe j c h2) a = Some false *)

Definition isSomefalse k :=
  match k with
  | Some false => true
  | _ => false
  end.

Definition isNone {A : Type} (k : option A) :=
    match k with
    | None => true
    | _ => false
  end.

(* Theorem find_index {A:Type} (f : A -> bool) (l : list A) :
  {i : nat | {h : i < length l |  f(nthsafe i l h) = true}}
  + {forall i (h : i < length l), f(nthsafe i l h) = false}.
  induction l.
  + right. intros. cbn in *. lia.
  + destruct IHl as [[i [h hindex]] | hfail].
    ++ left.  exists (S i). assert (S i < length (a :: l)) as hlt; try (cbn in *; try lia; fail).
    exists hlt. cbn in hlt. erewrite nthsafe_red. eauto.
    ++ destruct (f a) eqn:hfa.
        +++ left. exists 0. cbn in *. eexists; eauto. lia.
        +++ right. intros i h2. destruct i; try (cbn in *; eauto; fail).
Qed.     *)

Theorem find_index {A:Type} (f : A -> bool) (l : list A) :
  {i : nat | exists h : i < length l, f(nthsafe i l h) = true}
  + {(forall (i:nat) (h : i < length l), f(nthsafe i l h) = false)}.
  induction l.
  + right. intros. cbn in *. lia.
  + destruct IHl as [[i hindex] | hfail].
    ++ left.  exists (S i). destruct hindex as [h hindex]. assert (S i < length (a :: l)) as hlt; try (cbn in *; try lia; fail).

    exists hlt. cbn in hlt. erewrite nthsafe_red.  eauto.
    ++ destruct (f a) eqn:hfa.
        +++ left. exists 0. cbn in *. eexists; eauto. lia.
        +++ right. intros i h2. destruct i; try (cbn in *; eauto; fail).
Qed.

(* We postulate the following axio m for computation, which makes things easier
   TODO: prove it
*)
Axiom UnitClauseComputable0:
  forall {c i} a (h : i < length c),
  (
  (LiteralByPAssignment (nthsafe i c h) a) = None
  /\ forall j (h2 : j < length c),
      j <> i ->
      LiteralByPAssignment (nthsafe j c h2) a = Some false) ->
  (
  (LiteralByPAssignment (nthsafe i c h) a) = None
  /\ length (filter (fun x => isSomefalse (LiteralByPAssignment x a)) c) = (length c) - 1
  /\ c <> nil
  ).

Axiom UnitClauseComputable1:
  forall {c i} a (h : i < length c),
  (
  (LiteralByPAssignment (nthsafe i c h) a) = None
  /\ length (filter (fun x => isSomefalse (LiteralByPAssignment x a)) c) = (length c) - 1
  /\ c <> nil
  ) ->
  (
  (LiteralByPAssignment (nthsafe i c h) a) = None
  /\ forall j (h2 : j < length c),
      j <> i ->
      LiteralByPAssignment (nthsafe j c h2) a = Some false)
  .

Lemma UnitClause_computable_chara:
  forall {c a},
    UnitClause c a ->
    {i | exists h : i < length c, (
  (LiteralByPAssignment (nthsafe i c h) a) = None
  /\ length (filter (fun x => isSomefalse (LiteralByPAssignment x a)) c) = (length c) - 1
  /\ c <> nil
  )} .
  intros c a h.
  destruct h as [index h0].
  exists index.
  destruct h0 as [h01 h02].
  exists h01.
  eapply UnitClauseComputable0; eauto.
Qed.

Theorem UnitClause_Dec:
  forall (c : Clause V) a,
  UnitClause c a + {UnitClause c a -> False}.

destruct c eqn:heqc;[right; eapply UnitClauseNeverEmpty'; eauto | idtac].
assert (c <> nil); [try intro; subst; try contradiction; try discriminate | idtac].
intros a.
destruct (find_index (fun x => isNone (LiteralByPAssignment x a)) c) as [[i hhf] | hk]; unfold isSomefalse in *;
try (right; intro HC; destruct (UnitClause_computable_chara HC) as [index [h1 [h11 [h12 h13]]]]; subst; try contradiction; fail).
+
  (* repeat breakAssumpt1. *)
  destruct (eq_dec
    (length (filter (fun x => isSomefalse (LiteralByPAssignment x a)) c))
    ((length c) - 1)
  ); try (right; intro HC; destruct (UnitClause_computable_chara HC) as [index [h1 [h11 [h12 h13]]]]; subst; try contradiction; fail).
  left. exists i. subst.
      destruct hhf as [h hf].
      exists h. unfold isNone in hf. repeat breakAssumpt1.
      split; eauto.
      eapply (UnitClauseComputable1 a h). split; eauto.
+ right. intro HC. destruct HC as [index [h2 [h21 h22]]].
  subst. clean_pose (hk index h2).
  unfold isNone in *. repeat breakAssumpt1.
Qed.
(*
Theorem partition (f : A -> bool) (l : list A):
  {l1 : list {i : nat & {h : i < length l | f (nthsafe ) }} &

  }
*)

Definition UnitClause_UnitLiteral {c a} (u : UnitClause c a) : Literal V.
  destruct u as [i hhh].
  assert (i < length c) as hindex; [destruct hhh; auto | idtac].
  exact (nthsafe i c hindex).
Defined.

Theorem UnitClauseLiteral_None {c a x b} (u : UnitClause c a):
  UnitClause_UnitLiteral u = ToLiteral x b ->
  PA a x = None.
  unfold UnitClause_UnitLiteral.
  intros H0. destruct u as [i [h [h1 h2]]].
  destruct b; cbn in *; rewrite H0 in *; cbn in *; eauto.
  repeat breakAssumpt1; eauto.
Qed.

(*
  unit_prop_AS_spec:
  forall  {l c g d s f x b},

    AS ((l::c)::f) ((g,d) :: s) ->
    l = ToLiteral x b ->
    (* eval C under d = false -> *)
    ClauseByPAssignment c d = Some false ->
    (* PA d l = None -> *)
    forall (h : PA d x = None),
    AS ((l::c)::f) ((g,d[x := b]h) :: s).
*)

(*
Theorem UnitClause_AS_spec:
  forall  {c f g d s x b} (u : UnitClause c d),
    AS (c::f) ((g,d) :: s) ->
    UnitClause_UnitLiteral u = ToLiteral x b ->
    forall (h : PA d x = None),
    AS (c::f) ((g,d[x := b]h) :: s).
intros c f g d s x b u H0 H1 H2. eapply deduce_as; auto.
destruct u as [index [h0 [h1 h2]]]; cbn in *.
rewrite <- H1 in *.
eapply rp_trans; [idtac | eapply rp_unitprop; eauto].
assert (RProof
          (fconj
            (fconj (ClauseFormula c)
              (CNFFormula f))
            (LiteralsFormPA g))
            (ClauseFormula c)) as Hproof2; [eauto | idtac].
eapply rp_rconj; [exact Hproof2 | idtac].
pose (AssignmentStackHasRProof H0) as hproof1. cbn in *. eauto.
Qed. *)

Lemma AS_no_nil:
  forall {f}, AS f nil -> False.
  intros. inversion H0.
Qed.

Definition HasUnitClause_in_st {f l} (st : CDCLState f l): Set.
(* refine (
  match st with
  | existT _ ((_, d) :: _ ) _ =>

  | _ => _
  end
). *)
  destruct st as [[ | [g d] s ] [astack]].
  destruct (AS_no_nil astack).
  exact {i & {h : i < length (l ++ f) &
  UnitClause (nthsafe i (l ++ f) h) d}}.
Defined.

Fixpoint lenFA {T} (f : FiniteAssignment T) :=
  match f with
  | empty_fa => 0
  | assign_fa _ _ t _ => S (lenFA t)
  end.
(* Print isUnitClause. *)
Definition deducedLitNum {f l} (st : CDCLState f l) : nat.
  destruct st as [atrail [hf1 hf2]].
  destruct atrail as [_ | [g [d1 d2]] t].
  exact 0.
  exact (lenFA d2).
Defined.

Lemma ToLiteralInjective:
  forall y,
    {x & {b | y = ToLiteral x b}}.
  intro y. unfold ToLiteral.
  destruct y as [v | v]; exists v; [
    exists true | exists false
  ]; cbn in *; auto.
Qed.

Lemma nthsafe_nthdefault:
  forall {A} {l : list A} {i h k},
    nthsafe i l h = nth i l k.
  intros A l. induction l; intros; try (cbn in *; try lia; fail).
  destruct i.
  cbn in *; auto.
  erewrite nthsafe_red. simpl. eauto.
  Unshelve. cbn in *. lia.
Qed.

Ltac repeat_extract_le_inf :=
  match goal with
  | [h : exists _ : ?a < ?b, _ |- _] =>
      let hname := fresh "h"
      in assert (a < b) as hname;[destruct h; auto | idtac];
      generalize h; clear h;
      repeat_extract_le_inf;
      intro h
  | _ => idtac
  end.

Ltac proof_irrelevance h1 h2:=
  assert (h1 = h2);[eapply Coq.Logic.ProofIrrelevance.proof_irrelevance; eauto | idtac];
  subst.

Lemma UnitClause_AS_spec_in_st:
  forall  {f l}  (st : CDCLState f l),
    HasUnitClause_in_st st ->
    {st2 : CDCLState f l | deducedLitNum st2 > deducedLitNum st}.
  intros f l [a [astack p]] h.
  destruct a as [hnil | [g d] t];
  try (destruct (AS_no_nil astack); fail); cbn in h.
  destruct h as [i0 [hle [i1 hl2huc0huc1 ]]].
  repeat_extract_le_inf.
  remember (nthsafe i1 (nthsafe i0 (l ++ f) hle) h) as targetL.
  remember (nthsafe i0 (l ++ f) hle) as targetC.
  destruct (ToLiteralInjective targetL) as [v [b htv]].
  assert (PA d v = None) as hdnvb.
  + destruct  hl2huc0huc1 as [hl2 [huc0 huc1]].
    unfold LiteralByPAssignment in huc0.
    unfold ToLiteral in htv.
    proof_irrelevance h hl2.
    repeat breakAssumpt1;
    destruct b; cbn in *; try (injection htv; intros; subst; eauto; try discriminate; fail);
    try discriminate.
  + assert (AS (l ++ f) ((g, d[v:=b]hdnvb) :: t)) as nextAS.

    ++  subst. apply deduce_as;auto. try rewrite <- htv.
        (* rewrite HeqtargetL in *. *)
        eapply rp_trans; [idtac | apply rp_unitprop; auto].
        eapply rp_rconj;[idtac | eapply AssignmentStackHasRProof; eauto].
        eapply rp_trans; [eapply rp_weaken; eauto | idtac].
        erewrite nthsafe_nthdefault; eauto.
        destruct  hl2huc0huc1 as [hl2 [huc0 huc1]]. eauto.
    ++  eexists (existT _ ((g, d [v := b] hdnvb) :: t) (nextAS, p)).
        destruct d. cbn in *. lia.
Qed.

Theorem UnitClauseAsLiteral:
  forall  {c d} (u : UnitClause c d),
    {x & {b | UnitClause_UnitLiteral u = ToLiteral x b}}.
  intros c d [index hlehindexhu4 ].
  cbn in *. apply ToLiteralInjective.
Qed.

(* Definition isUnitClause (c : Clause V) (a : PAssignment V) : bool.
  destruct (UnitClause_Dec c a).
  exact true.
  exact false.
Defined. *)

Fixpoint CountUnitClauses (f : CNF V) (assign : PAssignment V) : nat :=
  match f with
  | nil => 0
  | cons h t =>
    if (UnitClause_Dec h assign) then 1 else 0 + CountUnitClauses t assign
  end.

Definition CountUnitClausesIn {f l} (st : CDCLState f l) : nat.
  destruct st as [atrail [hatrail hp]].
  destruct atrail as [_ | [g d] t]; try (inversion hatrail; fail).
  exact (CountUnitClauses (l ++ f) d).
Defined.

Ltac breakAssumpt2:=
  match goal with
  | [h0 : context[match ?exp with _ => _ end] |- _ ] =>
    let heq := fresh "heq" in
    destruct exp eqn:heq; try discriminate; try contradiction
  end.

Lemma CountUnitClauses0_iff_allnotunitclauseA: forall {l assign},
  CountUnitClauses l assign = 0 ->
  (forall i (h : i < length l), UnitClause (nthsafe i l h) assign -> False).
  intros l. induction l; intros; subst; cbn in *; intros; repeat breakAssumpt2; eauto; try lia.
Qed.

Lemma CountUnitClauses0_iff_allnotunitclauseB: forall {l assign},
(forall i (h : i < length l), UnitClause (nthsafe i l h) assign -> False) ->
  CountUnitClauses l assign = 0.
  intros l. induction l; intros assign H0; subst; intros; repeat breakAssumpt2; auto; try lia.
  simpl CountUnitClauses.
  destruct (UnitClause_Dec a assign) as [u | u]; subst; auto; try contradiction; try discriminate.
  + assert False; try contradiction.
    assert (0 < length (a::l)) as hle; try (cbn in *; try lia; fail).
    apply (H0 0 hle u).
  + apply IHl; auto. intros.
    assert (S i < length (a::l)) as hle2; try (cbn in *; try lia; fail).
    apply (H0 (S i) hle2); auto. erewrite nthsafe_red; auto.
  exact H1.
Qed.

Definition NoUnitClause {f l}
  (st : CDCLState f l)
  (* (atrail : list (PAssignment V * PAssignment V))
  (h2 : atrail <> nil)  *)
  : Prop.
  destruct st as [atrail [AT rp]].
  destruct atrail as [_ | h t]; subst; eauto; try contradiction; try discriminate.
  + inversion AT.
  + destruct h as [g d].
    exact (
      forall i (h : i < length (l ++ f)), UnitClause (nthsafe i (l ++ f) h) d -> False).
  Defined.

Theorem NoUnitClause_computable: forall {f l} {st : CDCLState f l},
  NoUnitClause st <-> (CountUnitClausesIn st = 0).
  split; intros; destruct st as [atrail [AT rp]];
    destruct atrail as [_ | [g d] t]; subst; eauto; try contradiction; try discriminate;
    try (inversion AT; fail); cbn in *.
  + eapply CountUnitClauses0_iff_allnotunitclauseB; auto.
  + eapply CountUnitClauses0_iff_allnotunitclauseA; auto.
Qed.

Theorem HasUnitClause_Dec:
  forall {f l} (st : CDCLState f l),
    HasUnitClause_in_st st + {NoUnitClause st}.
  intros f l [a [astack p]].
  destruct a as [| [g d] s];
    try (destruct (AS_no_nil astack); fail).
    cbn in *.
  pose (fun x =>
    match UnitClause_Dec x d with
    | inleft _ => true
    | inright _ => false
    end
  ) as ff.
  destruct (find_index ff (l++f)) as
  [[index hleh2] | hnonfound]; cbn in *;
  repeat_extract_le_inf.
  + unfold ff in *.
    destruct (UnitClause_Dec (nthsafe index (l ++ f) h) d); try discriminate; try contradiction.
    left. exists index. exists h. auto.
    assert False; auto. destruct hleh2 as [hle h2]; try discriminate; try contradiction.
    proof_irrelevance h hle.
    destruct (UnitClause_Dec (nthsafe index (l ++ f) hle) d); try discriminate; try contradiction.

  + right. intros index hle2 H0.
  unfold ff in hnonfound.
  clean_pose (hnonfound index hle2).
  destruct (UnitClause_Dec (nthsafe index (l ++ f) hle2) d); try discriminate; try contradiction.
Qed.

Lemma CNFByAssignmentImplication:
  forall {l f d},
  CNFByPAssignment f d = Some false ->
  CNFByPAssignment (l ++ f) d = Some false.
  intros l. induction l; intros;
  cbn in *; try discriminate. auto.
  repeat erewrite IHl in *; eauto; cbn in *.
  breakAssumpt3; cbn in *; simpl_bool; auto.
  destruct b; auto.
  Qed.

Lemma FailedSt_ConflictSt {f l} (st : CDCLState f l):
    FailedState st ->
    ConflictingState st.
  intros.
  destruct st as [atrail [hf1 hf2]].
  destruct atrail as [_ | [g d] t]; subst; eauto; try contradiction; try discriminate;
  try (inversion hf1; fail); cbn in *.
  repeat breakAssumpt2.
   eapply CNFByAssignmentImplication; auto.
Qed.

Lemma nConflictSt_nFailedSt {f l} (st : CDCLState f l):
    ~ConflictingState st ->
    ~FailedState st.
  intros H0 H1. pose (FailedSt_ConflictSt _ H1); try contradiction.
Qed.

(* UnitProp until cannot spec*)

(* Guess One Literal spec*)

(*

decide_AS_spec  {f g d s} x b
  (stack : AS f ((g, d)::s))
  (h : PA d x = None) :
  AS f (((g[x := b](AssignmentStackGSubD2 stack _ h)), d[x:=b] h)::(g,d)::s).

*)

(* Check Success spec*)

(*
succeed_AS_spec: forall {f g d s},
  AS f ((g, d) ::s) ->
  CNFByPAssignment f d = Some true ->
  {g2 | CNFByAssignment f g2 = true}
*)

(* Check Failure spec*)

(*

fail_AS_spec: forall {c f g d},
  AS (c::f) ((g, d) ::nil) ->
  ClauseByPAssignment c d = Some false ->
  RProof (CNFFormula (c:: f)) fbot.

  *)

(* Back Jump spec*)

(*

backjump_AS_spec: forall  {f C k g d s l} x b,
  AS f (k ++ (g,d) :: s) ->
  l = ToLiteral x b ->
  (* f ⊧ C ∨ l*)
  RProof (CNFFormula f) (fdisj C (flit l)) ->
  (* eval C under d = false -> *)
  FormulaByPAssignment C d = Some false ->
  (* PA d l = None -> *)
  forall (h : PA d x = None),
  AS f ((g,d[x := b]h) :: s).

*)

Definition FinalState_Dec2
  {f l} (st : CDCLState f l) (h : f <> nil):
    {g | CNFByPAssignment f g =  Some true}
    + RProof (CNFFormula f) fbot
    + {~ FinalState st}.
intros. unfold FinalState.
destruct (SucceedState_Dec st).
+ left. left. apply (SucceedSt_extract st); auto.
+ destruct (FailedState_Dec st).
  ++ left. right. apply (FailedSt_extract st); auto.
  ++ right. intro H0. destruct H0; try contradiction.
Qed.

Lemma not_all_assigned1  {f d} :
  CNFByPAssignment f d = None ->
  exists i, exists (h : i < length f),
    ClauseByPAssignment (nthsafe i f h) d = None.
Admitted.

Lemma not_all_assigned2  {c d} :
  ClauseByPAssignment c d = None ->
  exists i, exists (h : i < length c),
    LiteralByPAssignment (nthsafe i c h) d = None.
Admitted.

Lemma EvalOnLess:
  forall {l f d},
    CNFByPAssignment (l ++ f) d = Some true ->
    CNFByPAssignment f d = Some true.

intros l. induction l; intros; eauto; cbn in *.
repeat breakAssumpt1; cbn in *. inversion H0; subst; eauto.
Qed.

Lemma not_all_assigned3: forall {f l} (st: CDCLState f l),
~ SucceedState st /\ ~ ConflictingState st -> forall g d t q,
st = existT _ ((g,d)::t) q ->

  CNFByPAssignment (l ++ f) d = None.
  unfold FinalState.
  intros f l st [h0 h1]  g d t [astack p]  heq. subst; cbn in *.
  destruct (CNFByPAssignment (l ++ f) d) eqn: heqCNF; auto.
  destruct b; try contradiction.
  destruct (h0 (EvalOnLess heqCNF)); eauto.
Qed.

Lemma LiteralByPAssignmentNone_PANone: forall {b x l d},
  l = ToLiteral x b ->
  LiteralByPAssignment l d = None <->
  PA d x = None.
  intros b. unfold LiteralByPAssignment.
  intros; subst;
  destruct b; cbn in *; auto. split; auto.
  split; intros; repeat breakAssumpt3; auto.
Qed.

(* Learn New Clause *)
Definition learn_CS_spec0 {f learned g}
  (h0 : RProof (CNFFormula (learned ++ f)) (CNFFormula g))
  (h1 : CDCLState f learned):
  CDCLState f (g ++ learned).
  destruct h1 as [s1 [as1 proof1]].
  eexists. split.
    (* Constructing AS using change goal*)
    + rewrite <- List.app_assoc.
      eapply change_goal; [idtac | eapply rp_cnf_weaken]; eauto.
    (* Constructing RProof using rproof *)
    + eapply rp_cnf_conj;
      [idtac | eauto].
      eapply rp_trans;
      [idtac | eauto].
      eapply rp_cnf_conj; eauto.
Defined.

Definition learn_CS_spec1 {f learned g}
  (h0 : RProof (CNFFormula (learned ++ f)) (CNFFormula g))
  (h1 : CDCLState f learned):
  {st2 : CDCLState f (g ++ learned)
    | projT1 st2 = projT1 h1
    }.
  exists (learn_CS_spec0 h0 h1).
  unfold learn_CS_spec0.
  destruct h1 as [s1 p].
  destruct p as [as1 proof1]. cbn in *. auto.
Qed.

Lemma NoUnitClause_NoConflictOneMoreDeduced:
 forall {f l} (st st2: CDCLState f l) (hnnil : f <> nil),
  NoUnitClause st ->
  ((deducedLitNum st2) = S (deducedLitNum st)) ->
  ~ConflictingState st2.
Admitted.

Theorem guess_new_literal_and_no_conflict {f l} (st: CDCLState f l) (hnnil : f <> nil)
  (h0: ~ SucceedState st /\ ~ ConflictingState st) :
  NoUnitClause st ->
  {l2 & {st2 : CDCLState f l2 | (deducedLitNum st2 > deducedLitNum st \/ length l2 > length l) /\ length l2 >= length l /\ ~ConflictingState st2}}.
intros.
clean_pose (not_all_assigned3 _ h0). clear h0.
destruct st as [a [astack hp]] eqn:heqst.
destruct a as [_ | [ag ad] att];[try (destruct (AS_no_nil astack); auto; fail) | idtac].
clean_pose (h _ _ _ _ eq_refl). clear h.
clean_pose (not_all_assigned1 h0). clear h0.
pose (
  fun x =>
  match (ClauseByPAssignment x ad) with
  | None => true
  | _ => false
  end
) as f1.
pose (
  fun x =>
  match (LiteralByPAssignment x ad) with
  | None => true
  | _ => false
  end
) as f2.
destruct (find_index f1 (l ++ f)) as [[index1 hindex1p1] | hh].
unfold f1 in hindex1p1. repeat breakAssumpt1.
repeat_extract_le_inf.
destruct (find_index f2 ((nthsafe index1 (l ++ f) h0))) as [[index2 hindex2p2] | hh2].
unfold f2 in hindex2p2. repeat breakAssumpt1.
repeat_extract_le_inf.
proof_irrelevance h0 h2.
remember (nthsafe index2 (nthsafe index1 (l ++ f) h2) h1) as targetL.
destruct (ToLiteralInjective targetL) as [x [b hxb]].

assert (PA ad x = None) as heq0.
destruct hindex2p2 as [hindex2 p2]; repeat breakAssumpt1. proof_irrelevance hindex2 h1.
eapply  LiteralByPAssignmentNone_PANone; eauto. subst; eauto.
clean_pose (AssignmentStackGSubD2 astack _ heq0).
assert (AS (l ++ f) ((ag[x:=b]h0, ad[x:=b]heq0)::(ag, ad) :: att)) as nextStack.
eapply guess_as. apply astack.
pose ((existT _ ((ag [x := b] h0, ad [x := b] heq0) :: (ag, ad) :: att) (nextStack, hp)): CDCLState f l) as nextState.
(* destruct (vanilla_no_conflict  hnnil nextState) as [l3 [st3 [hst31 [hst32 hst33]]]]. *)
exists l.
exists nextState.
repeat split; try lia; try auto. destruct ad; cbn in *. try lia.
eapply NoUnitClause_NoConflictOneMoreDeduced; eauto.
destruct ad. cbn in *. auto.

+ (* Contradictions happen here *)
assert False;[idtac | try contradiction].

destruct hindex1p1 as [hindex1 p1]; proof_irrelevance hindex1 h0.
repeat breakAssumpt1.
destruct (not_all_assigned2 heq) as [index2 [hindex2 hhindex2]].
clean_pose (hh2 index2 hindex2). unfold f2 in *. repeat breakAssumpt1.
+ assert False;[idtac | try contradiction].
destruct h as [index1 [hindex1 hhindex1]].
clean_pose (hh index1 hindex1). unfold f1 in *. repeat breakAssumpt1; auto.
Qed.

  (*
change_goal:
  forall  {g} {s} (f : CNF V),
    AssignmentStack g s ->
    RProof (CNFFormula f) (CNFFormula g) ->
    AssignmentStack f s.
*)

(* Use to fuel *)
Definition CountLiteral (c : CNF V) :=
  fold_right Nat.add 0 (map (fun (l: Clause V) => length l) c).

(*
  The following three heuristic oriented function
  As long as the
*)
End CDCLtransitionNeedEqDec.

Module Type CDCLHeuristics.

Parameter propagate_all_unit_clause:
  forall {V : Set} `{EqDec_eq V} (fuel : nat) {f l : CNF V} (st : CDCLState f l),
{st2 : CDCLState f l | deducedLitNum st2 >= deducedLitNum st /\ NoUnitClause st2 /\ ~ConflictingState st2}
+ {st2 : CDCLState f l | ConflictingState st2}
+ {st2 : CDCLState f l | deducedLitNum st2 > deducedLitNum st /\  ~ ConflictingState st2 }.

Parameter conflicting_analysis:
  forall {V : Set} `{EqDec_eq V}  {f l : CNF V} (h : f <> nil) {st : CDCLState f l}
    (H0 :ConflictingState st),
    {l2 & {_: RProof (CNFFormula (l ++ f)) (CNFFormula l2) | l2 <> nil}}.

Parameter backtracking :
  forall {V : Set} `{EqDec_eq V}  {f l : CNF V} (st : CDCLState f l),
    CNFByPAssignment (l ++ f) ∅ = None ->
    ConflictingState st ->
    {st2 : CDCLState f l | ~ ConflictingState st2}.

End CDCLHeuristics.

Module Main (H : CDCLHeuristics).

Section CDCLtransitionNeedEqDec.

Context {V:Set}.

Context {H: EqDec_eq V}.

Import H.

Hint Constructors AssignmentStack.

Hint Constructors RProof.

Definition CDCLOneStep {f l: CNF V} (st : CDCLState f l) (h : f <> nil) (suggest_fuel : nat):
{g | CNFByPAssignment f g =  Some true}
+ RProof (CNFFormula f) fbot
+ {l2 & {st2 : CDCLState f l2 | (length l2 > length l \/ deducedLitNum st2 > deducedLitNum st) /\ ~ FinalState st2 /\ ~ ConflictingState st2  /\ (length l2 >= length l)}}. (* Progress on Learned! *)

Ltac check_final_state_and_return st h:=
  let hfinal := fresh "hfinal"
  in let    H := fresh "H"
  in destruct (FinalState_Dec2 st h) as [Hfinal | H]; [left; auto | idtac].

  check_final_state_and_return st h.
 (* Main function starts here  *)
 (* First Do All the Unit Propagation *)
    destruct (propagate_all_unit_clause suggest_fuel st) as [[[st2 [hnuc [hnfail1 hnfail2]]] | [st2 hcflict]] | [st2 [hprog hnfail]]].
    + (* If no conflict, and successfully propagate all *)
      (* check fully assigned or not *)
      destruct (SucceedState_Dec st2).
        (* if it is fully assigned, then success extract*)
        ++ left. left. eapply (SucceedSt_extract st2); auto.
        (* If it is not,
            guess a literal and progress.
            we know no conflict will happen, but we haven't proved it yet TODO!  *)
        ++ destruct (guess_new_literal_and_no_conflict st2) as [l3 [st3 [hprog31 [hprog32 hprog33]]]].
        unfold FinalState. auto. split; [idtac | auto]. intro HH. try contradiction. auto.
        check_final_state_and_return st3 h.
        right. exists l3. exists st3. repeat split; try auto.
          destruct hprog31; [try lia | auto].
    (* If conflict happens *)
    + destruct (FailedState_Dec st2).
      (* check if failure state *)
          (* if failure, uses failure extract *)
          ++ left. right. eapply (FailedSt_extract st2); auto.
          (* if not *)
          ++
             (*TODO we know here it is not final for st2
                Because we can prove ConflictingState st2 -> ~ SucceedState st2.
             *)
            check_final_state_and_return st2 h.
            (* Do conflict analysis to get a new learned clause *)
            destruct (conflicting_analysis h  hcflict) as [l2 [hl2 hl2n0]].
            destruct (learn_CS_spec1 hl2 st2) as [st3 hst3info].
            destruct (ConflictingState_Dec st3) as [hst3cflict | hst3ncflict].
            +++
              destruct (CNFByPAssignment ((l2 ++ l) ++ f) ∅) eqn:htrybacktrack.
              destruct b.
              ++++ left. left. exists ∅. eapply EvalOnLess; eauto.
              ++++ left. right. eapply rp_trans;[idtac | eapply rp_false_by_eval; eauto].
                    destruct st2 as [a [b hp]].
                    eapply rp_cnf_conj;[idtac| auto].
                    eapply rp_cnf_conj;[idtac | auto].
                    eapply rp_trans; [idtac | eapply hl2].
                    eapply rp_cnf_conj; eauto.
              ++++ destruct (backtracking st3 htrybacktrack hst3cflict) as [st4 hncflict].

            (*TODO we know here it is not final for st4
                Because we can make backtrack more strict --
                make it return state s.t. CNFByPAssignment f
             *)
            check_final_state_and_return st4 h.
            right.
            exists (l2 ++ l). exists st4.
            repeat split; eauto.
            +++++ left. rewrite app_length. destruct (eq_dec (length l2) 0) as [ll20 | ll2n0].
            assert (l2 = nil) as Hl2nil; [try eapply  length_zero_iff_nil; eauto | idtac]. try contradiction. lia.

            +++++  rewrite app_length. lia.
            +++
            check_final_state_and_return st3 h.
            right. exists (l2 ++ l). exists st3.
            repeat split; eauto.
            ++++ left. rewrite app_length. destruct (eq_dec (length l2) 0) as [ll20 | ll2n0].
            assert (l2 = nil) as Hl2nil; [try eapply  length_zero_iff_nil; eauto | idtac]. try contradiction. lia.
            ++++  rewrite app_length. lia.
+ check_final_state_and_return st2 h.
  right.  exists l. exists st2.
  repeat split; eauto.
Qed.

(* The multi-step CDCL Alg *)
Fixpoint CDCLMultiStep  (fuel : nat) {f l: CNF V} (st : CDCLState f l) (h : f <> nil) {struct fuel}:
{g | CNFByPAssignment f g =  Some true}
+ RProof (CNFFormula f) fbot
+ {l2 & {st2 : CDCLState f l2 | (length l2 > length l \/ deducedLitNum st2 > deducedLitNum st) /\ ~ FinalState st2 /\ ~ ConflictingState st2  /\ (length l2 >= length l)}}. (* Progress on Learned! *)
pose (CountLiteral (f ++ l)) as total_literal.
destruct fuel eqn:heqnfuel; intros.
+ apply (CDCLOneStep st h total_literal).
+ (* Some more Fuel*)
destruct (CDCLOneStep st h total_literal) as [hfinal | [l2 [st2 [hnfinal11 [hnfinal12 [hnfinal13 hnfinal14]]]]]].
++ left. apply hfinal.
++ destruct (CDCLMultiStep n _ _ st2 h) as [hfinal3 | [l3 [st3 [hnfinal31 [hnfinal32 [hnfinal33 hnfinal34]]]]]].
  +++ left. apply hfinal3.
  +++ right. exists l3. exists st3. split; auto.
  destruct hnfinal31 as [hnfinal311 | hnfinal312];
  destruct hnfinal11 as [hnfinal111 | hnfinal112];
  try lia.
  repeat split; auto. try lia.
Qed.

(* The main Procedure to be extract *)
Definition CDCLAlg  (fuel : nat) {f: CNF V}:
{g | CNFByPAssignment f g =  Some true}
+ RProof (CNFFormula f) fbot
+ {l2 & {st2 : CDCLState f l2 |  ~ FinalState st2 /\ ~ ConflictingState st2}}. (* Progress on Learned! *)
destruct f eqn:heqf.
+ (* f = nil*)
  left. left. exists ∅. cbn in *; auto.
+ assert (f <> nil) as hneqnil;[intro Hcontra; subst; auto; try discriminate | idtac].
  assert (CDCLState f nil) as initialState.
  unfold CDCLState. cbn in *. exists ((∅,∅)::nil). split; [apply empty_as; auto | auto].
  destruct (CDCLMultiStep fuel initialState hneqnil) as [[h1 | h2 ]| h3]; subst.
  ++ left. left.  subst. apply h1.
  ++ left. right. auto.
  ++ right. destruct h3 as [h31 [h32 h33]]. exists h31. exists h32. auto.
      destruct h33 as [h331 [h332 [h333 h334]]]; auto.
Qed.

End CDCLtransitionNeedEqDec.

End Main.

End CDCLtransition.

(* We implement the easiest  *)
Module VanillaCDCL.

Import CDCLtransition.

Module VanillaCDCLHeur <: CDCLHeuristics.

Section CDCLtransitionNeedEqDec.

Definition vanilla_conflicting_analysis:
  forall {V:Set} `{EqDec_eq V} {f l : CNF V} (h : f <> nil) {st : CDCLState f l}
    (H0 :ConflictingState st),
    {l2 & {_: RProof (CNFFormula (l ++ f)) (CNFFormula l2) | l2 <> nil}}.
  unfold ConflictingState.
  intros. destruct st as [s [h1 h2]].
  destruct s as [_ | [g d] t]; try contradiction.
  exists (((negLiteralFormPA d)::nil)).
  eexists (rp_cnf_false_neg _); eauto. intro. try discriminate.
  Unshelve. auto.
Qed.

Definition conflicting_analysis:
forall {V : Set} `{EqDec_eq V}  {f l : CNF V} (h : f <> nil) {st : CDCLState f l}
    (H0 :ConflictingState st),
    {l2 & {_: RProof (CNFFormula (l ++ f)) (CNFFormula l2) | l2 <> nil}}.
intros.
    eapply vanilla_conflicting_analysis; eauto.
Qed.

Lemma vanilla_propagate_all_unit_clause_onestep {V : Set} `{EqDec_eq V}:
  forall  {f l : CNF V} (st : CDCLState f l),
  CountUnitClausesIn st <> 0 /\ ~ConflictingState st ->
  {st2 : CDCLState f l | deducedLitNum st2 > deducedLitNum st /\ ~ConflictingState st2}
  + {st2 : CDCLState f l | ConflictingState st2}.

Ltac check_conflicting_state_and_return st:=
  let hfinal := fresh "hfinal"
  in let    H := fresh "H"
  in destruct (ConflictingState_Dec st) as [Hfinal | H]; [right; exists st; auto | idtac].

  intros f l st [h0 h1].
  destruct (HasUnitClause_Dec st) as [h2 | h2].
  + destruct (UnitClause_AS_spec_in_st _ h2) as [st2 h3].
    check_conflicting_state_and_return st2.
    left. exists st2. eauto.
  + rewrite (NoUnitClause_computable) in h2. try contradiction.
Qed.

(* TODO Prove the termination of unit propagation *)
Theorem vanilla_propagate_all_unit_clause {V : Set} `{EqDec_eq V}
    (fuel : nat): forall {f l} (st : CDCLState f l),
    {st2 : CDCLState f l | deducedLitNum st2 >= deducedLitNum st /\ NoUnitClause st2 /\ ~ConflictingState st2}
    + {st2 : CDCLState f l | ConflictingState st2}
    + {st2 : CDCLState f l | deducedLitNum st2 > deducedLitNum st /\  ~ ConflictingState st2 }.
  induction fuel.
  + intros f l st.
    (* When fuel used up *)
    destruct (ConflictingState_Dec st) as [hfail | hnfail].
    ++ left. right. exists st. auto.
    ++ destruct (CountUnitClausesIn st) eqn:hucn.
       assert (NoUnitClause st) as HNUC; [try (eapply NoUnitClause_computable; eauto; fail) | idtac].
       left. left. exists st. repeat split; [try auto | try apply HNUC | try apply hnfail].
       assert (CountUnitClausesIn st <> 0) as hucn0; [try lia | idtac].
       destruct (vanilla_propagate_all_unit_clause_onestep st) as [[st2 [h1 h2]] | [st2 h1]].
       split; auto.
       right. exists st2. auto.
       left. right. exists st2. auto.
  + (* When fuel has left*)
    intros f l st.
    (* Still check if failed *)
    destruct (ConflictingState_Dec st) as [hfail | hnfail].
    ++ left. right. exists st. auto.
    ++ destruct (CountUnitClausesIn st) eqn:hucn.
    +++
       (* No Unit Clause! We are done *)
       assert (NoUnitClause st) as HNUC; [try (eapply NoUnitClause_computable; eauto; fail) | idtac].
       left. left. exists st. repeat split; [try auto | try apply HNUC | apply hnfail].
    +++
       (* Still Unit Clause...  *)
       assert (CountUnitClausesIn st <> 0) as hucn0; [try lia | idtac].
    (* We progress one step and see if the result is good *)
      destruct (vanilla_propagate_all_unit_clause_onestep st) as [[st2 [h1 h2]] | [st2 h1]].
      split; auto.
      ++++
        destruct (IHfuel _ _ st2) as [[[st3 hrec] | [st3 hrec]] | [st3 hrec]].
        +++++ left. left. exists st3. destruct hrec as [hrec1 [hrec2 hrec3]]; repeat split; try auto. try lia.
        +++++ left. right. exists st3. auto.
        +++++ destruct (ConflictingState_Dec st3) as [fail0 | nfail0].
          ++++++
                left. right. exists st3. auto.
          ++++++      right.  exists st3. split; auto; try lia.
      ++++ left. right. exists st2. apply h1.
    (* NOT Failure yet, check if it has any more unit clause*)

Qed.

Definition propagate_all_unit_clause:
forall {V : Set} `{EqDec_eq V} (fuel : nat) {f l : CNF V} (st : CDCLState f l),
{st2 : CDCLState f l | deducedLitNum st2 >= deducedLitNum st /\ NoUnitClause st2 /\ ~ConflictingState st2}
+ {st2 : CDCLState f l | ConflictingState st2}
+ {st2 : CDCLState f l | deducedLitNum st2 > deducedLitNum st /\  ~ ConflictingState st2 }.

intros. eapply (vanilla_propagate_all_unit_clause fuel st); eauto.
Qed.

Notation AS := AssignmentStack.

Theorem vanilla_backtracking_helper {V : Set} `{EqDec_eq V} t  :
  forall {f : CNF V} (stack : AS f t) {b g1 d1 t1},
    CNFByPAssignment f ∅ = None ->
    t = ((g1,d1)::t1) ->
    CNFByPAssignment f d1 = Some b ->
    {g2 & {d2 & {t2 & {a : AS f ((g2,d2)::t2) & CNFByPAssignment f d2 = None}}}}.
induction t.
+ intros f h. destruct (AS_no_nil h).
+ intros f stack b g1 d1 t1 H0 H1 H2.
inversion H1; subst.
destruct t1 as [_ | [t1g t1d] t1t].
++ exists ∅. exists ∅. exists nil. exists (empty_as f). auto.
++
assert (AS f ((t1g, t1d) :: t1t)) as nextSearch; [eapply (AssignmentStackMonotoncity stack); eauto; try (intro; discriminate) | idtac].
destruct (CNFByPAssignment f t1d) eqn:heqcnf.
    apply  (IHt _ nextSearch b0 _ _ _ H0 eq_refl). auto.
    exists t1g. exists t1d. exists t1t. exists nextSearch. auto.
Qed.

Definition vanilla_backtracking  {V : Set} `{EqDec_eq V}:
  forall {f l : CNF V} (st : CDCLState f l),
  CNFByPAssignment (l ++ f) ∅ = None ->
  ConflictingState st ->
  {st2 : CDCLState f l | ~ ConflictingState st2}.

intros f l [trail [astack p]] h0 h1.
destruct trail as [_ | [g d] t];
[try destruct (AS_no_nil astack) | idtac].
cbn in *.
destruct (vanilla_backtracking_helper _ astack h0 eq_refl h1) as [g2 [d2 [t2 [astack2 h2]]]].
exists (existT _ ((g2, d2) :: t2) (astack2, p)).
cbn in *. rewrite h2. intro. try discriminate.
Qed.

Definition backtracking :
forall {V : Set} `{EqDec_eq V}  {f l : CNF V} (st : CDCLState f l),
  CNFByPAssignment (l ++ f) ∅ = None ->
  ConflictingState st ->
  {st2 : CDCLState f l | ~ ConflictingState st2}.

intros. eapply vanilla_backtracking; eauto.
Qed.

End CDCLtransitionNeedEqDec.

End VanillaCDCLHeur.

Module Main := CDCLtransition.Main VanillaCDCLHeur.

End VanillaCDCL.

Print VanillaCDCL.Main.

(* Extraction "CDCLCompute.ml" VanillaCDCLAlg. *)


(************************************************************************)
(* Copyright (c) 2017, Ajay Kumar Eeralla <ae266@mail.missouri.edu>     *)
(*                   University of Missouri-Columbia.                   *)
(*                                                                      *)
(*                                                                      *)
(*                                                                      *)
(************************************************************************)

Load "ex7_1".

(** This library defines a theorem that states,[ [[ msg x]] ~ [[ msg y]] -> x # y.] *)

Theorem Example10_M: forall (x  F z : message), [msg x] ~ [msg (const F z )] -> x # (const F z) .
 Proof.
intros.
simpl in H.
unfold const in H.
unfold const.
apply FUNCApp_const with (a := [msg F])(ml1 := ([msg x]))(ml2 := [msg F]) in H.
unfold const in H.
unfold app_mylist in H.
apply FUNCApp_eqm with (p1 := 1) (p2:=2) in H.
simpl in H.
unfold eqm_at_pos in H.
unfold chkmsg_os in H. unfold getelt_at_pos in H.
simpl in H.
unfold app_mylist in H.
restr_proj_in 1 H.
restr_proj_in 1 H.
assert (J:[bol (eqm F F) ] ~[bol TRue]) .
assert(K: (EQI_msg F F)).
reflexivity.
apply K.
assert (K:[bol (eqm x F)] ~[bol TRue]) .
apply EQI_trans with (ml2 := [bol (eqm F F)]).
assumption. assumption. assumption.
Qed.

(** The following theorem states that [x~f -> x=f] *)

Theorem Example10_B: forall (x  F z : Bool), [bol x] ~ [bol (const F z )] ->  x ## (const F  z) .
 Proof.
intros.
simpl in H.
unfold const in H.
unfold const.
apply FUNCApp_const with (a := [bol F])(ml1 := ([bol x]))(ml2 := [bol F]) in H.
unfold const in H.
simpl in H.
pose proof (FUNCApp_eqb).
apply FUNCApp_eqb with ( p1:=1)(p2:=2) in H.
unfold app_mylist in H.
unfold eqb_at_pos in H.
simpl in H.
restr_proj_in 1 H.
restr_proj_in 1 H.
assert (J:[bol (eqb F F) ] ~[bol TRue]) .
assert(K: (EQI_bol F F)).
reflexivity.
apply K.
assert (K:[bol (eqb x F)] ~[bol TRue]) .
apply EQI_trans with (ml2 := [bol (eqb F F)]).
apply H.
apply J.
apply K.
Qed.


Require Import Orders.
Require Import OrdersFacts.
Require Import RelationClasses.
Require Import PArith.
Require Import FMapPositive.

Require Import sflib.

Require Import Axioms.
Require Import Basic.
Require Import DataStructure.
Require Import UsualFMapPositive.

Set Implicit Arguments.

Module Type IsDense (Import T:EqLtLe).
  Parameter bot: t.
  Axiom bot_spec: forall x, le bot x.

  Parameter incr: t -> t.
  Axiom incr_spec: forall x, lt x (incr x).

  Parameter middle: forall (lhs rhs:t), t.
  Axiom middle_spec:
    forall (lhs rhs:t)
      (LT: lt lhs rhs),
      lt lhs (middle lhs rhs) /\
      lt (middle lhs rhs) rhs.
End IsDense.

Module Type DenseOrderType := UsualOrderedTypeFull <+ IsDense <+ HasCaseJoin.

Module DOAux.
  Definition t := positive.
  Definition elt: t := xH.

  Definition eq := @eq t.
  Global Program Instance eq_equiv : Equivalence eq.

  Inductive lt_: forall (lhs rhs:t), Prop :=
  | lt_xO_xH lhs:
      lt_ (xO lhs) xH
  | lt_xH_xI rhs:
      lt_ xH (xI rhs)
  | lt_xO_xI lhs rhs:
      lt_ (xO lhs) (xI rhs)
  | lt_xO
      lhs rhs
      (LT: lt_ lhs rhs):
      lt_ (xO lhs) (xO rhs)
  | lt_xI
      lhs rhs
      (LT: lt_ lhs rhs):
      lt_ (xI lhs) (xI rhs)
  .
  Definition lt := lt_.

  Global Program Instance lt_strorder: StrictOrder lt.
  Next Obligation.
    intro x. induction x; intro X; inv X; eauto.
  Qed.
  Next Obligation.
    intros x y z XY. revert z.
    induction XY; i; inv H; econs.
    - apply IHXY. auto.
    - apply IHXY. auto.
  Qed.

  Global Program Instance lt_compat: Proper (eq ==> eq ==> iff) lt.
  Next Obligation.
    ii. unfold eq in *. subst. auto.
  Qed.

  Fixpoint compare (lhs rhs:t): comparison :=
    match lhs, rhs with
    | xH, xH =>
      Eq
    | xO _, xI _
    | xH, xI _
    | xO _, xH =>
      Lt
    | xI _, xO _
    | xH, xO _
    | xI _, xH =>
      Gt
    | xO ltl, xO rtl
    | xI ltl, xI rtl =>
      compare ltl rtl
    end.

  Lemma compare_spec :
    forall x y : t,
      CompareSpec (x = y) (lt x y) (lt y x) (compare x y).
  Proof.
    induction x; i; destruct y;
      try (destruct a);
      try (destruct b);
      repeat (try econs; s).
    - destruct (IHx y); subst; repeat econs; auto.
    - destruct (IHx y); subst; repeat econs; auto.
  Qed.

  Lemma eq_dec: forall x y : t, {x = y} + {x <> y}.
  Proof.
    apply Pos.eq_dec.
  Defined.
  Global Opaque eq_dec.

  Definition le := fun x y => lt x y \/ eq x y.
  Lemma le_lteq : forall x y : t, le x y <-> lt x y \/ x = y.
  Proof.
    auto.
  Qed.
  Global Opaque le.

  Fixpoint decr (x:t) :=
    match x with
    | xH => xO xH
    | xO x => xO (decr x)
    | xI x => xI (decr x)
    end.

  Lemma decr_spec: forall x, lt (decr x) x.
  Proof.
    induction x; ss; econs; eauto.
  Qed.

  Fixpoint incr (x:t) :=
    match x with
    | xH => xI xH
    | xO x => xO (incr x)
    | xI x => xI (incr x)
    end.

  Lemma incr_spec: forall x, lt x (incr x).
  Proof.
    induction x; ss; econs; eauto.
  Qed.

  Fixpoint middle (lhs rhs:t): t :=
    match lhs, rhs with
    | lhs, xH => incr lhs
    | xH, rhs => decr rhs
    | xO ltl, xO rtl => xO (middle ltl rtl)
    | xO ltl, xI rtl => xI (decr rtl)
    | xI ltl, xO rtl => xI (middle ltl rtl)
    | xI ltl, xI rtl => xI (middle ltl rtl)
    end.

  Lemma middle_spec:
    forall (lhs rhs:t)
      (LT: lt lhs rhs),
      lt lhs (middle lhs rhs) /\
      lt (middle lhs rhs) rhs.
  Proof.
    induction lhs; s; i; inv LT; splits; econs;
      (try by apply IHlhs; auto);
      (try by apply incr_spec; auto);
      (try by apply decr_spec; auto).
  Qed.

  Lemma le_lt_dec (lhs rhs:t): {le lhs rhs} + {lt rhs lhs}.
  Proof.
    generalize (compare_spec lhs rhs).
    destruct (compare lhs rhs).
    - left. inv H. right. ss.
    - left. inv H. apply le_lteq. auto.
    - right. inv H. auto.
  Defined.

  Definition join (lhs rhs:t): t :=
    if le_lt_dec lhs rhs
    then rhs
    else lhs.

  Lemma join_comm lhs rhs: join lhs rhs = join rhs lhs.
  Proof.
    unfold join.
    destruct (le_lt_dec lhs rhs), (le_lt_dec rhs lhs); auto.
    - apply le_lteq in l. apply le_lteq in l0.
      des; auto. rewrite l in l0. apply lt_strorder in l0. done.
    - rewrite l in l0. apply lt_strorder in l0. done.
  Qed.

  Lemma join_assoc a b c: join (join a b) c = join a (join b c).
  Proof.
    unfold join.
    repeat
      (try match goal with
           | [H: le _ _ |- _] =>
             apply le_lteq in H
           | [|- context[le_lt_dec ?a ?b]] =>
             destruct (le_lt_dec a b)
           | [H: context[le_lt_dec ?a ?b] |- _] =>
             destruct (le_lt_dec a b)
           | [H1: lt ?a ?b, H2: lt ?b ?a |- _] =>
             rewrite H2 in H1; apply lt_strorder in H1; inv H1
           end; unfold eq in *; try subst; des; ss).
    - rewrite l in l2. rewrite l0 in l2.
      apply lt_strorder in l2. inv l2.
    - rewrite l in l2. rewrite l1 in l2.
      apply lt_strorder in l2. inv l2.
  Qed.

  Lemma join_l lhs rhs:
    le lhs (join lhs rhs).
  Proof.
    unfold join. destruct (le_lt_dec lhs rhs); auto.
    apply le_lteq. auto.
  Qed.

  Lemma join_r lhs rhs:
    le rhs (join lhs rhs).
  Proof.
    rewrite join_comm. apply join_l.
  Qed.

  Lemma join_spec lhs rhs o
        (LHS: le lhs o)
        (RHS: le rhs o):
    le (join lhs rhs) o.
  Proof.
    unfold join. destruct (le_lt_dec lhs rhs); auto.
  Qed.

  Lemma join_cases lhs rhs:
    join lhs rhs = lhs \/ join lhs rhs = rhs.
  Proof.
    unfold join. destruct (le_lt_dec lhs rhs); auto.
  Qed.

  Definition meet (lhs rhs:t): t :=
    if le_lt_dec lhs rhs
    then lhs
    else rhs.

  Lemma meet_comm lhs rhs: meet lhs rhs = meet rhs lhs.
  Proof.
    unfold meet.
    destruct (le_lt_dec lhs rhs), (le_lt_dec rhs lhs); auto.
    - apply le_lteq in l. apply le_lteq in l0.
      des; auto. rewrite l in l0. apply lt_strorder in l0. done.
    - rewrite l in l0. apply lt_strorder in l0. done.
  Qed.

  Lemma meet_assoc a b c: meet (meet a b) c = meet a (meet b c).
  Proof.
    unfold meet.
    repeat
      (try match goal with
           | [H: le _ _ |- _] =>
             apply le_lteq in H
           | [|- context[le_lt_dec ?a ?b]] =>
             destruct (le_lt_dec a b)
           | [H: context[le_lt_dec ?a ?b] |- _] =>
             destruct (le_lt_dec a b)
           | [H1: lt ?a ?b, H2: lt ?b ?a |- _] =>
             rewrite H2 in H1; apply lt_strorder in H1; inv H1
           end; unfold eq in *; try subst; des; ss).
    - rewrite l2 in l. rewrite l1 in l.
      apply lt_strorder in l. inv l.
    - rewrite l2 in l. rewrite l0 in l.
      apply lt_strorder in l. inv l.
  Qed.

  Lemma meet_l lhs rhs:
    le (meet lhs rhs) lhs.
  Proof.
    unfold meet. destruct (le_lt_dec lhs rhs); auto.
    - apply le_lteq. auto.
    - apply le_lteq. auto.
  Qed.

  Lemma meet_r lhs rhs:
    le (meet lhs rhs) rhs.
  Proof.
    rewrite meet_comm. apply meet_l.
  Qed.

  Lemma meet_spec lhs rhs o
        (LHS: le o lhs)
        (RHS: le o rhs):
    le o (meet lhs rhs).
  Proof.
    unfold meet. destruct (le_lt_dec lhs rhs); auto.
  Qed.

  Lemma meet_cases lhs rhs:
    meet lhs rhs = lhs \/ meet lhs rhs = rhs.
  Proof.
    unfold meet. destruct (le_lt_dec lhs rhs); auto.
  Qed.

  Lemma eq_dec_eq A i (a1 a2:A):
    (if eq_dec i i then a1 else a2) = a1.
  Proof.
    destruct (eq_dec i i); [|congruence]. auto.
  Qed.

  Lemma eq_dec_neq A i1 i2 (a1 a2:A)
        (NEQ: i1 <> i2):
    (if eq_dec i1 i2 then a1 else a2) = a2.
  Proof.
    destruct (eq_dec i1 i2); [congruence|]. auto.
  Qed.

  Lemma le_xI
        lhs rhs
        (LE: le lhs rhs):
    le (xI lhs) (xI rhs).
  Proof.
    inv LE.
    - left. econs. auto.
    - inv H. right. refl.
  Qed.

  Lemma le_xO
        lhs rhs
        (LE: le lhs rhs):
    le (xO lhs) (xO rhs).
  Proof.
    inv LE.
    - left. econs. auto.
    - inv H. right. refl.
  Qed.
End DOAux.

Definition _DOAux_eq_transitive := Equivalence_Transitive DOAux.eq_equiv.
#[export]
Hint Resolve _DOAux_eq_transitive: core.
#[export]
Hint Resolve DOAux.lt_strorder_obligation_2: core.

Global Program Instance DOAux_le_PreOrder: PreOrder DOAux.le.
Next Obligation.
  ii. apply DOAux.le_lteq. right. auto.
Qed.
Next Obligation.
  ii. apply DOAux.le_lteq.
  apply DOAux.le_lteq in H.
  apply DOAux.le_lteq in H0.
  des; subst; auto.
  left. rewrite H. auto.
Qed.
#[export]
Hint Resolve DOAux_le_PreOrder_obligation_2: core.

Module DenseOrder.
  Definition t := positive.

  Definition eq := @eq t.
  Global Program Instance eq_equiv : Equivalence eq.

  Inductive lt_: forall (lhs rhs:t), Prop :=
  | lt_xH_xO lhs:
      lt_ xH (xO lhs)
  | lt_xH_xI lhs:
      lt_ xH (xI lhs)
  | lt_xO_xI lhs rhs:
      lt_ (xO lhs) (xI rhs)
  | lt_xO
      lhs rhs
      (LT: DOAux.lt lhs rhs):
      lt_ (xO lhs) (xO rhs)
  | lt_xI
      lhs rhs
      (LT: DOAux.lt lhs rhs):
      lt_ (xI lhs) (xI rhs)
  .

  Definition lt := lt_.

  Global Program Instance lt_strorder: StrictOrder lt.
  Next Obligation.
    ii. inv H.
    - eapply DOAux.lt_strorder. eauto.
    - eapply DOAux.lt_strorder. eauto.
  Qed.
  Next Obligation.
    ii. inv H; inv H0; econs.
    - etrans; eauto.
    - etrans; eauto.
  Qed.

  Global Program Instance lt_compat: Proper (eq ==> eq ==> iff) lt.
  Next Obligation.
    ii. unfold eq in *. subst. auto.
  Qed.

  Definition compare (lhs rhs:t): comparison :=
    match lhs, rhs with
    | xH, xH =>
      Eq
    | xH, xO _
    | xH, xI _
    | xO _, xI _ =>
      Lt
    | xO _, xH
    | xI _, xO _
    | xI _, xH =>
      Gt
    | xO ltl, xO rtl
    | xI ltl, xI rtl =>
      DOAux.compare ltl rtl
    end.

  Lemma compare_spec :
    forall x y : t,
      CompareSpec (x = y) (lt x y) (lt y x) (compare x y).
  Proof.
    i. destruct x, y; s; try by repeat econs.
    - generalize (DOAux.compare_spec x y).
      destruct (DOAux.compare x y); i; inv H.
      + econs 1. auto.
      + econs 2. econs. auto.
      + econs 3. econs. auto.
    - generalize (DOAux.compare_spec x y).
      destruct (DOAux.compare x y); i; inv H.
      + econs 1. auto.
      + econs 2. econs. auto.
      + econs 3. econs. auto.
  Qed.

  Lemma eq_dec: forall x y : t, {x = y} + {x <> y}.
  Proof.
    apply Pos.eq_dec.
  Defined.
  Global Opaque eq_dec.

  Definition le := fun x y => lt x y \/ eq x y.
  Lemma le_lteq : forall x y : t, le x y <-> lt x y \/ x = y.
  Proof. auto. Qed.
  Global Opaque le.

  Definition bot: t := xH.

  Lemma bot_spec: forall x, le bot x.
  Proof.
    i. destruct x.
    - left. econs.
    - left. econs.
    - right. refl.
  Qed.

  (* Definition incr (x:t) := *)
  (*   match x with *)
  (*   | xH => xI xH *)
  (*   | xO x => xO (DOAux.incr x) *)
  (*   | xI x => xI (DOAux.incr x) *)
  (*   end. *)

  (* Lemma incr_spec: forall x, lt x (incr x). *)
  (*   i. destruct x; econs. *)
  (*   - apply DOAux.incr_spec. *)
  (*   - apply DOAux.incr_spec. *)
  (* Qed. *)

  Definition incr (x: t) :=
    match x with
    | xH => xO xH
    | xO x => xO (xI x)
    | xI x => xI (xI x)
    end.

  Lemma incr_spec_aux: forall x, DOAux.lt x (xI x).
  Proof.
    induction x.
    - econs. ss.
    - econs.
    - econs.
  Qed.

  Lemma incr_spec: forall x, lt x (incr x).
  Proof.
    i. destruct x; ss.
    - econs. apply incr_spec_aux.
    - econs. apply incr_spec_aux.
    - econs.
  Qed.

  Lemma incr_mon: forall x y, lt x y -> lt (incr x) (incr y).
  Proof.
    i. inv H; ss; try by repeat econs.
  Qed.

  Definition middle (lhs rhs:t): t :=
    match lhs, rhs with
    | _, xH => lhs
    | xH, xO rtl => xO (DOAux.decr rtl)
    | xH, xI _ => xO xH
    | xO ltl, xO rtl => xO (DOAux.middle ltl rtl)
    | xO ltl, xI rtl => xI (DOAux.decr rtl)
    | xI ltl, xO rtl => xI (DOAux.middle ltl rtl)
    | xI ltl, xI rtl => xI (DOAux.middle ltl rtl)
    end.

  Lemma middle_spec:
    forall (lhs rhs:t)
      (LT: lt lhs rhs),
      lt lhs (middle lhs rhs) /\
      lt (middle lhs rhs) rhs.
  Proof.
    i. inv LT; s; splits; econs;
         (try apply DOAux.decr_spec);
         (try apply DOAux.middle_spec; auto).
  Qed.

  Lemma le_lt_dec (lhs rhs:t): {le lhs rhs} + {lt rhs lhs}.
  Proof.
    generalize (compare_spec lhs rhs).
    destruct (compare lhs rhs).
    - left. inv H. right. ss.
    - left. inv H. apply le_lteq. auto.
    - right. inv H. auto.
  Defined.

  Definition join (lhs rhs:t): t :=
    if le_lt_dec lhs rhs
    then rhs
    else lhs.

  Lemma join_comm lhs rhs: join lhs rhs = join rhs lhs.
  Proof.
    unfold join.
    destruct (le_lt_dec lhs rhs), (le_lt_dec rhs lhs); auto.
    - apply le_lteq in l. apply le_lteq in l0.
      des; auto. rewrite l in l0. apply lt_strorder in l0. done.
    - rewrite l in l0. apply lt_strorder in l0. done.
  Qed.

  Lemma join_assoc a b c: join (join a b) c = join a (join b c).
  Proof.
    unfold join.
    repeat
      (try match goal with
           | [H: le _ _ |- _] =>
             apply le_lteq in H
           | [|- context[le_lt_dec ?a ?b]] =>
             destruct (le_lt_dec a b)
           | [H: context[le_lt_dec ?a ?b] |- _] =>
             destruct (le_lt_dec a b)
           | [H1: lt ?a ?b, H2: lt ?b ?a |- _] =>
             rewrite H2 in H1; apply lt_strorder in H1; inv H1
           end; unfold eq in *; try subst; des; ss).
    - rewrite l in l2. rewrite l0 in l2.
      apply lt_strorder in l2. inv l2.
    - rewrite l in l2. rewrite l1 in l2.
      apply lt_strorder in l2. inv l2.
  Qed.

  Lemma join_l lhs rhs:
    le lhs (join lhs rhs).
  Proof.
    unfold join. destruct (le_lt_dec lhs rhs); auto.
    apply le_lteq. auto.
  Qed.

  Lemma join_r lhs rhs:
    le rhs (join lhs rhs).
  Proof.
    rewrite join_comm. apply join_l.
  Qed.

  Lemma join_spec lhs rhs o
        (LHS: le lhs o)
        (RHS: le rhs o):
    le (join lhs rhs) o.
  Proof.
    unfold join. destruct (le_lt_dec lhs rhs); auto.
  Qed.

  Lemma join_cases lhs rhs:
    join lhs rhs = lhs \/ join lhs rhs = rhs.
  Proof.
    unfold join. destruct (le_lt_dec lhs rhs); auto.
  Qed.

  Definition meet (lhs rhs:t): t :=
    if le_lt_dec lhs rhs
    then lhs
    else rhs.

  Lemma meet_comm lhs rhs: meet lhs rhs = meet rhs lhs.
  Proof.
    unfold meet.
    destruct (le_lt_dec lhs rhs), (le_lt_dec rhs lhs); auto.
    - apply le_lteq in l. apply le_lteq in l0.
      des; auto. rewrite l in l0. apply lt_strorder in l0. done.
    - rewrite l in l0. apply lt_strorder in l0. done.
  Qed.

  Lemma meet_assoc a b c: meet (meet a b) c = meet a (meet b c).
  Proof.
    unfold meet.
    repeat
      (try match goal with
           | [H: le _ _ |- _] =>
             apply le_lteq in H
           | [|- context[le_lt_dec ?a ?b]] =>
             destruct (le_lt_dec a b)
           | [H: context[le_lt_dec ?a ?b] |- _] =>
             destruct (le_lt_dec a b)
           | [H1: lt ?a ?b, H2: lt ?b ?a |- _] =>
             rewrite H2 in H1; apply lt_strorder in H1; inv H1
           end; unfold eq in *; try subst; des; ss).
    - rewrite l2 in l. rewrite l1 in l.
      apply lt_strorder in l. inv l.
    - rewrite l2 in l. rewrite l0 in l.
      apply lt_strorder in l. inv l.
  Qed.

  Lemma meet_l lhs rhs:
    le (meet lhs rhs) lhs.
  Proof.
    unfold meet. destruct (le_lt_dec lhs rhs); auto.
    - apply le_lteq. auto.
    - apply le_lteq. auto.
  Qed.

  Lemma meet_r lhs rhs:
    le (meet lhs rhs) rhs.
  Proof.
    rewrite meet_comm. apply meet_l.
  Qed.

  Lemma meet_spec lhs rhs o
        (LHS: le o lhs)
        (RHS: le o rhs):
    le o (meet lhs rhs).
  Proof.
    unfold meet. destruct (le_lt_dec lhs rhs); auto.
  Qed.

  Lemma meet_cases lhs rhs:
    meet lhs rhs = lhs \/ meet lhs rhs = rhs.
  Proof.
    unfold meet. destruct (le_lt_dec lhs rhs); auto.
  Qed.

  Lemma eq_dec_eq A i (a1 a2:A):
    (if eq_dec i i then a1 else a2) = a1.
  Proof.
    destruct (eq_dec i i); [|congruence]. auto.
  Qed.

  Lemma eq_dec_neq A i1 i2 (a1 a2:A)
        (NEQ: i1 <> i2):
    (if eq_dec i1 i2 then a1 else a2) = a2.
  Proof.
    destruct (eq_dec i1 i2); [congruence|]. auto.
  Qed.

  Lemma le_xI
        lhs rhs
        (LE: DOAux.le lhs rhs):
    le (xI lhs) (xI rhs).
  Proof.
    inv LE.
    - left. econs. auto.
    - inv H. right. refl.
  Qed.

  Lemma le_xO
        lhs rhs
        (LE: DOAux.le lhs rhs):
    le (xO lhs) (xO rhs).
  Proof.
    inv LE.
    - left. econs. auto.
    - inv H. right. refl.
  Qed.
End DenseOrder.

Definition _DenseOrder_eq_transitive := Equivalence_Transitive DenseOrder.eq_equiv.
#[export]
Hint Resolve _DenseOrder_eq_transitive: core.
#[export]
Hint Resolve DenseOrder.lt_strorder_obligation_2: core.

Global Program Instance DenseOrder_le_PreOrder: PreOrder DenseOrder.le.
Next Obligation.
  ii. apply DenseOrder.le_lteq. right. auto.
Qed.
Next Obligation.
  ii. apply DenseOrder.le_lteq.
  apply DenseOrder.le_lteq in H.
  apply DenseOrder.le_lteq in H0.
  des; subst; auto.
  left. rewrite H. auto.
Qed.
#[export]
Hint Resolve DenseOrder_le_PreOrder_obligation_2: core.

Module DOSet := UsualSet DenseOrder.

Module DOMap.
  Include UsualPositiveMap.

  Fixpoint raw_max_key A (m:Raw.t A): option DOAux.t :=
    match m with
    | Raw.Leaf _ => None
    | Raw.Node l o r =>
      match raw_max_key r, o, raw_max_key l with
      | Some k, _, _ => Some (xI k)
      | None, Some _, _ => Some xH
      | None, None, Some k => Some (xO k)
      | None, None, None => None
      end
    end.

  Lemma raw_max_key_spec1 A (m:Raw.t A)
        (KEY: raw_max_key m = None):
    forall k', Raw.find k' m = None.
  Proof.
    revert KEY. induction m; s; i.
    { apply Raw.gleaf. }
    destruct (raw_max_key m2) eqn:K2; [congr|].
    destruct o eqn:O; [congr|].
    destruct (raw_max_key m1) eqn:K1; [congr|].
    destruct k'; eauto.
  Qed.

  Lemma raw_max_key_spec2 A (m:Raw.t A) k
        (KEY: raw_max_key m = Some k):
    <<FIND: Raw.find k m <> None>> /\
    <<MAX: forall k' (FIND': Raw.find k' m <> None), DOAux.le k' k>>.
  Proof.
    revert k KEY. induction m; s; [congr|].
    destruct (raw_max_key m2) eqn:K2.
    { i. inv KEY. s. exploit IHm2; eauto. i. des.
      splits; eauto. i. destruct k'; ss.
      - apply DOAux.le_xI. auto.
      - left. econs.
      - left. econs.
    }
    destruct o.
    { i. inv KEY. s. splits; [congr|].
      i. destruct k'; ss.
      - erewrite raw_max_key_spec1 in FIND'; eauto. congr.
      - left. econs.
      - refl.
    }
    destruct (raw_max_key m1) eqn:K1.
    { i. inv KEY. s. exploit IHm1; eauto. i. des.
      splits; eauto. i. destruct k'; ss.
      - erewrite raw_max_key_spec1 in FIND'; eauto. congr.
      - apply DOAux.le_xO. auto.
    }
    i. congr.
  Qed.

  Definition max_key A (m:t A): DenseOrder.t :=
    match proj1_sig m with
    | Raw.Leaf _ => DenseOrder.bot
    | Raw.Node l o r =>
      match raw_max_key r, raw_max_key l, o with
      | Some k, _, _ => xI k
      | None, Some k, _ => xO k
      | None, None, Some _ => xH
      | None, None, None => DenseOrder.bot
      end
    end.

  Lemma max_key_spec A (m:t A):
    <<FIND: forall k', find k' m <> None -> find (max_key m) m <> None>> /\
    <<MAX: forall k' (FIND': find k' m <> None), DenseOrder.le k' (max_key m)>>.
  Proof.
    destruct m.
    unfold max_key, find. s. destruct x eqn:X; subst.
    { splits; i.
      + rewrite PositiveMap.gleaf in H. congr.
      + rewrite PositiveMap.gleaf in FIND'. congr.
    }
    destruct (raw_max_key t0_2) eqn:Y.
    { exploit raw_max_key_spec2; eauto. i. des. splits; i; auto.
      destruct k'; ss.
      - exploit MAX; eauto. intro LE. inv LE.
        + left. econs. eauto.
        + right. inv H. refl.
      - left. econs.
      - left. econs.
    }
    destruct (raw_max_key t0_1) eqn:Z.
    { exploit raw_max_key_spec2; eauto. i. des. splits; i; auto.
      destruct k'; ss.
      - erewrite raw_max_key_spec1 in FIND'; eauto. congr.
      - exploit MAX; eauto. intro LE. inv LE.
        + left. econs. eauto.
        + right. inv H. refl.
      - left. econs.
    }
    destruct o.
    { s. i. splits; i; [congr|].
      destruct k'; ss.
      - erewrite raw_max_key_spec1 in FIND'; eauto. congr.
      - erewrite raw_max_key_spec1 in FIND'; eauto. congr.
      - refl.
    }
    s. splits; i.
    - destruct k'; ss.
      + erewrite raw_max_key_spec1 in H; eauto.
      + erewrite raw_max_key_spec1 in H; eauto.
    - destruct k'; ss.
      + erewrite raw_max_key_spec1 in FIND'; eauto. congr.
      + erewrite raw_max_key_spec1 in FIND'; eauto. congr.
  Qed.
End DOMap.

Module DenseOrderFacts.
  Include (OrderedTypeFacts DenseOrder).
  Include (OrderedTypeTest DenseOrder).

  Lemma lt_le_lt a b c
        (AB: DenseOrder.lt a b)
        (BC: DenseOrder.le b c):
    DenseOrder.lt a c.
  Proof.
    apply DenseOrder.le_lteq in BC. des; subst; auto.
    etrans; eauto.
  Qed.

  Lemma le_lt_lt a b c
        (AB: DenseOrder.le a b)
        (BC: DenseOrder.lt b c):
    DenseOrder.lt a c.
  Proof.
    apply DenseOrder.le_lteq in AB. des; subst; auto.
    etrans; eauto.
  Qed.

  Lemma join_lt_des a b c
        (LT: DenseOrder.lt (DenseOrder.join a b) c):
    <<AC: DenseOrder.lt a c>> /\
    <<BC: DenseOrder.lt b c>>.
  Proof.
    splits.
    - eapply le_lt_lt; eauto. apply DenseOrder.join_l.
    - eapply le_lt_lt; eauto. apply DenseOrder.join_r.
  Qed.

  Lemma antisym a b
        (AB: DenseOrder.le a b)
        (BA: DenseOrder.le b a):
    a = b.
  Proof.
    apply le_antisym; ii.
    - eapply DenseOrder.lt_strorder. eapply lt_le_lt; eauto.
    - eapply DenseOrder.lt_strorder. eapply lt_le_lt; eauto.
  Qed.

  Lemma le_lt_dec (lhs rhs:DenseOrder.t): {DenseOrder.le lhs rhs} + {DenseOrder.lt rhs lhs}.
  Proof.
    generalize (DenseOrder.compare_spec lhs rhs).
    destruct (DenseOrder.compare lhs rhs).
    - left. inv H. refl.
    - left. inv H. apply DenseOrder.le_lteq. auto.
    - right. inv H. auto.
  Defined.

  Lemma join_spec_lt lhs rhs o
        (LHS: DenseOrder.lt lhs o)
        (RHS: DenseOrder.lt rhs o):
    DenseOrder.lt (DenseOrder.join lhs rhs) o.
  Proof.
    exploit DenseOrder.join_spec.
    - apply DenseOrder.le_lteq. left. apply LHS.
    - apply DenseOrder.le_lteq. left. apply RHS.
    - i. apply DenseOrder.le_lteq in x0. des; auto. subst.
      generalize (DenseOrder.join_cases lhs rhs). i. des.
      + rewrite H at 1. auto.
      + rewrite H at 1. auto.
  Qed.

  Lemma le_join_l
        lhs rhs
        (LE: DenseOrder.le rhs lhs):
    DenseOrder.join lhs rhs = lhs.
  Proof.
    unfold DenseOrder.join. condtac; auto.
    apply antisym; auto.
  Qed.

  Lemma le_join_r
        lhs rhs
        (LE: DenseOrder.le lhs rhs):
    DenseOrder.join lhs rhs = rhs.
  Proof.
    rewrite DenseOrder.join_comm.
    apply le_join_l; auto.
  Qed.
End DenseOrderFacts.


From VLSM.Lib Require Import Itauto.
From stdpp Require Import prelude.
From VLSM.Lib Require Import Preamble StdppListFinSet.

Section sec_defs.

Context `{FinSet A C}.

Definition set := C.

Definition empty_set : set := ∅.

Definition set_add (a : A) (x : set) : set := {[ a ]} ∪ x.

Definition set_remove (a : A) (x : set) : set := x ∖ {[ a ]}.

Definition set_union (x y : set) : set := x ∪ y.

Definition set_diff (x y : set) : set := x ∖ y.

Lemma set_union_subseteq_left :
  forall (s1 s2 : set), s1 ⊆ set_union s1 s2.
Proof. by intros s1 s2 x Hincl; apply set_union_intro; left. Qed.

Lemma set_union_subseteq_iff :
  forall (s1 s2 s : set), set_union s1 s2 ⊆ s <-> s1 ⊆ s /\ s2 ⊆ s.
Proof.
  intros s1 s2 s.
  unfold subseteq, set_subseteq_instance, set_subseteq_instance.
  setoid_rewrite set_union_iff.
  by split; itauto.
Qed.

Lemma elem_of_submseteq' :
  forall (a : A) (s1 s2 : set), a ∈ s1 -> s1 ⊆ s2 -> a ∈ s2.
Proof. by intros a s1 s2 Ha Hincl; apply Hincl. Qed.

Lemma empty_subseteq :
  forall (s : set), ∅ ⊆ s.
Proof. by intros s x Hin; contradict Hin; apply not_elem_of_empty. Qed.

#[export] Instance elem_of_dec : RelDecision (@elem_of A C _) := elem_of_dec_slow.

End sec_defs.


Require Import VST.floyd.proofauto.
Require Import EulerProject1.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Definition nat_divide_dec a b: { Nat.divide a b } + { ~ Nat.divide a b }.
Proof.
  destruct (Zdivide_dec (Z.of_nat a) (Z.of_nat b)).
  + left. destruct d. exists (Z.to_nat x). lia.
  + right. intro. apply n. destruct H. rewrite H. exists (Z.of_nat x). lia.
Defined.

Definition criterion (n: Z): bool :=
  if (Zdivide_dec 3 n)
    then true
    else if (Zdivide_dec 5 n)
      then true
      else false.
Definition sum_Z: list Z -> Z := fold_right Z.add 0.

Lemma sum_Z_app:
  forall a b, sum_Z (a++b) = sum_Z a + sum_Z b.
Proof.
  intros. induction a; simpl; lia.
Qed.

Definition seq_Z (n: Z): list Z := map Z.of_nat (seq 1 (Z.to_nat n)).

Definition result (n: Z): Z := sum_Z (filter criterion (seq_Z n)).

Definition aux n: Z := n * (n + 1) / 2.
Definition faster_result n := 3 * aux (n / 3) + 5 * aux (n / 5) - 15 * aux (n / 15).

Eval compute in (faster_result 999).

Theorem thm_0 n (H: 0 <= n) (H0: Zeven n): aux n = (n / 2) * (n + 1).
Proof.
  unfold aux. apply Zeven_div2 in H0. remember (Z.div2 n) as x. rewrite H0.
  replace (2 * x * (2 * x + 1)) with (x * (x * 2 + 1) * 2) by ring.
  replace (2 * x) with (x * 2) by ring.
  repeat rewrite Z_div_mult; lia.
Qed.

Theorem thm_1 n (H: 0 <= n) (H0: Zodd n): aux n = n * ((n + 1) / 2).
Proof.
  unfold aux. apply Zodd_div2 in H0. remember (Z.div2 n) as x. rewrite H0.
  replace ((2 * x + 1) * (2 * x + 1 + 1)) with ((2 * x + 1) * (x + 1) * 2) by ring.
  replace (2 * x + 1 + 1) with ((x + 1) * 2) by ring.
  repeat rewrite Z_div_mult; lia.
Qed.

Theorem thm_2 n (H: 0 <= n): aux (n + 1) = aux n + n + 1.
Proof.
  revert n H. apply natlike_ind.
  + compute. auto.
  + intros. destruct (Zeven_odd_dec x).
    - pose proof (Zodd_Sn _ z). pose proof (Zeven_Sn _ H1).
      repeat rewrite <- Z.add_1_r in *.
      apply thm_0 in H2; try lia. apply thm_1 in H1; try lia. rewrite H1, H2.
      apply Zeven_div2 in z. remember (Z.div2 x) as w. rewrite z.
      replace (2 * w + 1 + 1) with ((w + 1) * 2) by ring.
      repeat rewrite Z_div_mult; lia.
    - pose proof (Zeven_Sn _ z). pose proof (Zodd_Sn _ H1).
      repeat rewrite <- Z.add_1_r in *.
      apply thm_0 in H1; try lia. apply thm_1 in H2; try lia. rewrite H1, H2.
      apply Zodd_div2 in z. remember (Z.div2 x) as w. rewrite z.
      replace (2 * w + 1 + 1 + 1 + 1) with ((w + 2) * 2) by ring.
      replace (2 * w + 1 + 1) with ((w + 1) * 2) by ring.
      repeat rewrite Z_div_mult; lia.
Qed.

Theorem thm_3 a n (Ha: 0 < a) (Hn: 0 <= n):
  (n + 1) / a = if Zdivide_dec a (n + 1) then n / a + 1 else n / a.
Proof.
  pose proof Hn as Hn'. revert Hn. pattern n. apply Z_lt_induction.
  + intros. assert (0 <= x <= a - 2 \/ a - 1 = x \/ a <= x) by lia.
    destruct H0; [|destruct H0].
    - assert (1 <= x + 1 < a) by lia. rewrite Z.div_small; try lia.
      destruct Zdivide_dec.
      * destruct d. assert (x0 = 0 \/ 1 <= x0) by lia. destruct H3.
        ++ lia.
        ++ nia.
      * rewrite Z.div_small; lia.
    - subst. replace (a - 1 + 1) with a by ring.
      rewrite Z.div_same; try lia. destruct Zdivide_dec.
      * rewrite Z.div_small; lia.
      * exfalso. apply n0. exists 1. lia.
    - assert (0 <= x - a < x) by lia. pose proof (H _ H1 (proj1 H1)).
      destruct (Zdivide_dec a (x - a + 1)).
      * destruct d. destruct Zdivide_dec.
        ++ assert (x + 1 = (x0 + 1) * a) by lia. rewrite H4.
           assert (x = x0 * a + (a - 1)) by lia. rewrite H5.
           rewrite Z_div_mult; try lia.
           rewrite Z.div_add_l; try lia.
           rewrite Z.div_small; lia.
        ++ exfalso. apply n0. exists (x0 + 1). lia.
      * destruct Zdivide_dec.
        ++ destruct d. exfalso. apply n0. exists (x0 - 1). lia.
        ++ replace (x + 1) with (1 * a + (x - a + 1)) by ring.
           rewrite Z.div_add_l; try lia.
           replace x with (1 * a + (x - a)) at 2 by ring.
           rewrite Z.div_add_l; lia.
  + auto.
Qed.

Theorem thm_4 a n (Ha: 0 < a) (Hn: 0 <= n) (H: (a | Z.succ n)): a * aux (Z.succ n / a) = a * aux (n / a) + Z.succ n.
Proof.
  ring_simplify. rewrite thm_3; auto. destruct Zdivide_dec.
  + rewrite thm_2. ring_simplify.
    destruct d. assert (n = (x - 1) * a + (a - 1)) by lia.
    assert (n / a = x - 1).
    { rewrite H1. rewrite Z.div_add_l; try lia. rewrite Z.div_small; lia. }
    rewrite H2. rewrite H1. lia. apply Z_div_pos; lia.
  + replace (Z.succ n) with (n + 1) in H by lia. tauto.
Qed.

Theorem thm_5 a n (Ha: 0 < a) (Hn: 0 <= n) (H: ~ (a | Z.succ n)): a * aux (Z.succ n / a) = a * aux (n / a).
Proof.
  ring_simplify. rewrite thm_3; auto. destruct Zdivide_dec.
  + replace (Z.succ n) with (n + 1) in H by ring. tauto.
  + auto.
Qed.

Theorem both_results_equal (n: Z) (H: 0 <= n): result n = faster_result n.
Proof.
  revert n H. apply natlike_ind.
  + compute. auto.
  + intros. unfold result, faster_result in *.
    replace (seq_Z (Z.succ x)) with (seq_Z x ++ Z.succ x :: nil).
    rewrite filter_app, sum_Z_app. rewrite H0. clear H0.
    unfold criterion. simpl. destruct (Zdivide_dec 3 (Z.succ x)).
    - simpl. replace (Z.succ x + 0) with (Z.succ x) by ring.
      rewrite thm_4; try lia; auto.
      destruct (Zdivide_dec 5 (Z.succ x)).
      * assert (15 | Z.succ x).
        { assert (Z.lcm 3 5 = 15) by reflexivity. rewrite <- H0. apply Z.lcm_least; auto. }
        rewrite thm_4; try lia; auto.
        rewrite thm_4; try lia; auto.
      * rewrite thm_5; try lia; auto.
        assert (~ (15 | Z.succ x)).
        { intro. apply n. clear n. destruct H0. exists (3 * x0). lia. }
        rewrite thm_5; try lia; auto.
     - rewrite thm_5; try lia; auto. destruct Zdivide_dec.
       * rewrite thm_4; try lia; auto.
         assert (~ (15 | Z.succ x)).
         { intro. apply n. clear n. destruct H0. exists (5 * x0). lia. }
         rewrite thm_5; try lia; auto. simpl. lia.
       * assert (~ (15 | Z.succ x)).
         { intro. apply n. destruct H0. exists (x0 * 5). lia. }
         rewrite thm_5; try lia; auto.
         rewrite thm_5; try lia; auto. simpl. lia.
    - unfold seq_Z. rewrite Z2Nat.inj_succ; auto. rewrite seq_S.
      simpl. rewrite map_app. f_equal. simpl. f_equal. lia.
Qed.

Definition aux_spec: ident * funspec :=
DECLARE _aux
  WITH number: Z
  PRE [ tuint ]
    PROP(0 <= number <= 1000)
    PARAMS(Vint (Int.repr number))
    SEP()
  POST [ tuint ]
    PROP()
    RETURN(Vint (Int.repr (aux number)))
    SEP().

Definition solution_spec: ident * funspec :=
DECLARE _solution
  WITH number: Z
  PRE [ tuint ]
    PROP(0 <= number <= 1000)
    PARAMS(Vint (Int.repr number))
    SEP()
  POST [ tuint ]
    PROP()
    RETURN(Vint (Int.repr (result number)))
    SEP().

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
     PROP()
     RETURN (Vint (Int.repr (result 999)))
     SEP(TT).

Definition Gprog := [aux_spec; solution_spec; main_spec].

Lemma body_aux: semax_body Vprog Gprog f_aux aux_spec.
Proof.
  start_function.
  forward.
  entailer!.
  unfold aux.
  unfold Int.divu.
  change (Int.unsigned (Int.repr 2)) with 2.
  rewrite Int.unsigned_repr.
  reflexivity.
  change Int.max_unsigned with 4294967295.
  nia.
Qed.

Lemma body_solution: semax_body Vprog Gprog f_solution solution_spec.
Proof.
  start_function.
  forward_call (number / 3).
  + entailer!. simpl. unfold Int.divu.
    rewrite Int.unsigned_repr. rewrite Int.unsigned_repr. reflexivity.
    { rep_lia. }
    { rep_lia. }
  + split.
    - apply Z.div_pos. lia. lia.
    - assert (number / 3 <= 333).
      change 333 with (1000/3). apply Z.div_le_mono. lia. lia. lia.
  + forward_call (number / 5).
    - entailer!. simpl. unfold Int.divu.
      rewrite Int.unsigned_repr. rewrite Int.unsigned_repr. reflexivity.
      { rep_lia. }
      { rep_lia. }
    - split.
      * apply Z.div_pos. lia. lia.
      * assert (number / 5 <= 200).
        change 200 with (1000/5). apply Z.div_le_mono. lia. lia. lia.
    - forward_call (number / 15).
      ++ entailer!. simpl. unfold Int.divu.
         repeat rewrite Int.unsigned_repr. reflexivity.
         { rep_lia. }
         { rep_lia. }
      ++ split.
         -- apply Z.div_pos. lia. lia.
         -- assert (number / 15 <= 66).
            change 66 with (1000/15). apply Z.div_le_mono. lia. lia. lia.
      ++ deadvars!. time forward.
         -- entailer!.
            assert (0 <= number / 15 <= 66).
            { split.
              + apply Z.div_pos. lia. lia.
              + change 66 with (1000 / 15). apply Z.div_le_mono. lia. lia. }
            assert (0 <= number / 15 * (number / 15 + 1) <= 4422) by nia.
            assert (0 <= number / 15 * (number / 15 + 1) / 2 <= 2211).
            { split.
              + apply Z.div_pos. lia. lia.
              + change 2211 with (4422 / 2). apply Z.div_le_mono. lia. lia. }
            assert (0 <= number / 3 <= 333).
            { split.
              + apply Z.div_pos. lia. lia.
              + change 333 with (1000 / 3). apply Z.div_le_mono. lia. lia. }
            assert (0 <= number / 3 * (number / 3 + 1) <= 111222) by nia.
            assert (0 <= number / 3 * (number / 3 + 1) / 2 <= 55611).
            { split.
              + apply Z.div_pos. lia. lia.
              + change 55611 with (111222 / 2). apply Z.div_le_mono. lia. lia. }
            assert (0 <= number / 5 <= 200).
            { split.
              + apply Z.div_pos. lia. lia.
              + change 200 with (1000 / 5). apply Z.div_le_mono. lia. lia. }
            assert (0 <= number / 5 * (number / 5 + 1) <= 40200) by nia.
            assert (0 <= number / 5 * (number / 5 + 1) / 2 <= 20100).
            { split.
              + apply Z.div_pos. lia. lia.
              + change 20100 with (40200 / 2). apply Z.div_le_mono. lia. lia. }
            unfold aux. repeat rewrite Int.signed_repr; try rep_lia.
         -- entailer!. rewrite both_results_equal; try lia.
            unfold faster_result. reflexivity.
Qed.

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
  start_function. forward_call 999.
  remember (result 999) as W. clear HeqW. time forward.
Qed.