Require Import String.
Require Import Bool.
Require Import core.utils.Utils.
Require Import core.modeling.Metamodel.
Require Import core.Model.
Require Import core.Engine.
Require Import core.Syntax.
Require Import core.Semantics.
Require Import core.Certification.
Require Import core.EqDec.
Require Import core.modeling.iteratetraces.IterateTracesSemantics.
Require Import Coq.Logic.FunctionalExtensionality.

Section IterateTracesCertification.

Context {tc: TransformationConfiguration} {mtc: ModelingTransformationConfiguration tc}.

(** EXECUTE TRACE *)

Lemma tr_executeTraces_in_elements :
forall (tr: Transformation) (sm : SourceModel) (te : TargetModelElement),
      In te (allModelElements (executeTraces tr sm)) <->
      (exists (tl : TraceLink) (sp : list SourceModelElement),
          In sp (allTuples tr sm) /\
          In tl (tracePattern tr sm sp) /\
          te = TraceLink_getTargetElement tl).
Proof.
  intros.
  split.
  + intro.
    assert (exists (tl : TraceLink),
                In tl (trace tr sm) /\
                te = (TraceLink_getTargetElement tl) ).
    { simpl in H.
          induction (trace tr sm).
          ++ crush.
          ++ intros.
              simpl in H.
              destruct H.
              +++ exists a.
                  crush.
              +++ specialize (IHl H).
                  destruct IHl.
                  exists x.
                  crush. }
    destruct H0.
    destruct H0.
    assert (exists (sp : list SourceModelElement),
                In sp (allTuples tr sm) /\
                In x (tracePattern tr sm sp)).
    { apply in_flat_map. crush. }
    destruct H2.
    destruct H2.
    exists x. exists x0.
    crush.
  + intros.
    destruct H.
    destruct H.
    destruct H.
    destruct H0.
    rewrite H1.
    apply in_map.
    apply in_flat_map.
    exists x0.
    split.
    ++ exact H.
    ++ exact H0.
Qed.

(** Instantiate *)

(* Please check the lemma formula *)

(* These lemmas of traces are useful when we get sth like (In e traces) *)

Lemma tr_trace_in:
forall (tr: Transformation) (sm : SourceModel) (tl : TraceLink),
  In tl (trace tr sm) <->
  (exists (sp : list SourceModelElement),
      In sp (allTuples tr sm) /\
      In tl (tracePattern tr sm sp)).
Proof.
  intros.
  apply in_flat_map.
Qed.

Lemma tr_tracePattern_in:
forall (tr: Transformation) (sm : SourceModel) (sp : list SourceModelElement) (tl : TraceLink),
  In tl (tracePattern tr sm sp) <->
  (exists (r:Rule),
      In r (matchPattern tr sm sp) /\
      In tl (traceRuleOnPattern r sm sp)).
Proof.
  intros.
  apply in_flat_map.
Qed.

Lemma tr_traceRuleOnPattern_in:
forall (r: Rule) (sm : SourceModel) (sp : list SourceModelElement) (tl : TraceLink),
  In tl (traceRuleOnPattern r sm sp) <->
  (exists (iter: nat),
      In iter (seq 0 (evalIteratorExpr r sm sp)) /\
      In tl (traceIterationOnPattern r sm sp iter)).
Proof.
  intros.
  apply in_flat_map.
Qed.

Lemma tr_traceIterationOnPattern_in:
forall (r: Rule) (sm : SourceModel) (sp : list SourceModelElement) (iter: nat) (tl : TraceLink),
  In tl (traceIterationOnPattern r sm sp iter) <->
  (exists (o: OutputPatternElement),
      In o (Rule_getOutputPatternElements r) /\
      In tl ((fun o => optionToList (traceElementOnPattern o sm sp iter)) o)).
Proof.
  intros.
  apply in_flat_map.
Qed.

(* TODO works inside TwoPhaseSemantics.v *)
Lemma tr_traceElementOnPattern_leaf:
forall (o: OutputPatternElement) (sm : SourceModel) (sp : list SourceModelElement) (iter: nat) (o: OutputPatternElement) (tl : TraceLink),
  Some tl = (traceElementOnPattern o sm sp iter) <->
  (exists (e: TargetModelElement),
      Some e = (instantiateElementOnPattern o sm sp iter) /\
      tl = (buildTraceLink (sp, iter, OutputPatternElement_getName o) e)).
Proof.
  intros.
  split.
  - intros.
    unfold traceElementOnPattern in H.
    destruct (instantiateElementOnPattern o0 sm sp iter) eqn: e1.
    -- exists t.
      split. crush. crush.
    -- crush.
  - intros.
    destruct H.
    destruct H.
    unfold traceElementOnPattern.
    destruct (instantiateElementOnPattern o0 sm sp iter).
    -- crush.
    -- crush.
Qed.

(** * Apply **)

Lemma tr_applyPatternTraces_in:
forall (tr: Transformation) (sm : SourceModel) (sp: list SourceModelElement) (tl : TargetModelLink) (tls: list TraceLink),
  In tl (applyPatternTraces tr sm sp tls) <->
  (exists (r : Rule),
          In r (matchPattern tr sm sp) /\
          In tl (applyRuleOnPatternTraces r tr sm sp tls)).
Proof.
  intros.
  apply in_flat_map.
Qed.

Lemma tr_applyRuleOnPatternTraces_in :
forall (tr: Transformation) (r : Rule) (sm : SourceModel) (sp: list SourceModelElement) (tl : TargetModelLink) (tls: list TraceLink),
    In tl (applyRuleOnPatternTraces r tr sm sp tls) <->
    (exists (i: nat),
        In i (seq 0 (evalIteratorExpr r sm sp)) /\
        In tl (applyIterationOnPatternTraces r tr sm sp i tls)).
Proof.
  intros.
  apply in_flat_map.
Qed.

Lemma tr_applyIterationOnPatternTraces_in :
    forall (tr: Transformation) (r : Rule) (sm : SourceModel) (sp: list SourceModelElement) (tl : TargetModelLink) (i:nat)  (tls: list TraceLink),
      In tl (applyIterationOnPatternTraces r tr sm sp i tls) <->
      (exists (ope: OutputPatternElement),
          In ope (Rule_getOutputPatternElements r) /\
          In tl (applyElementOnPatternTraces ope tr sm sp i tls)).
Proof.
  intros.
  apply in_flat_map.
Qed.

Lemma tr_applyElementOnPatternTraces_in :
    forall (tr: Transformation) (sm : SourceModel) (sp: list SourceModelElement) (tl : TargetModelLink)
            (i:nat) (ope: OutputPatternElement)  (tls: list TraceLink),
      In tl (applyElementOnPatternTraces ope tr sm sp i tls) <->
      (exists (oper: OutputPatternLink) (te: TargetModelElement),
          In oper (OutputPatternElement_getOutputLinks ope) /\
          (evalOutputPatternElementExpr sm sp i ope) = Some te /\
          applyLinkOnPatternTraces oper tr sm sp i te tls = Some tl).
Proof.
  split.
  * intros.
    apply in_flat_map in H.
    destruct H.
    exists x.
    unfold optionToList in H.
    destruct H.
    destruct (evalOutputPatternElementExpr sm sp i ope) eqn: eval_ca.
    - destruct (applyLinkOnPatternTraces x tr sm sp i t) eqn: ref_ca.
      -- eexists t.
          split; crush.
      -- contradiction.
    - contradiction.
  * intros.
    apply in_flat_map.
    destruct H.
    exists x.
    unfold optionToList.
    destruct H.
    destruct H.
    destruct H0.
    split.
    - assumption.
    - crush.
Qed.

Lemma tr_applyLinkOnPatternTraces_leaf :
    forall (oper: OutputPatternLink)
            (tr: Transformation)
            (sm: SourceModel)
            (sp: list SourceModelElement) (iter: nat) (te: TargetModelElement) (tls: list TraceLink),
      applyLinkOnPatternTraces oper tr sm sp iter te tls  = evalOutputPatternLinkExpr sm sp te iter tls oper.
Proof.
  crush.
Qed.

Lemma tr_applyTraces_in :
forall (tr: Transformation) (sm : SourceModel) (tl : TargetModelLink),
  In tl (applyTraces tr sm (trace tr sm)) <->
  (exists (sp : list SourceModelElement),
      In sp (allTuples tr sm) /\
      In tl (applyPatternTraces tr sm sp (trace tr sm))).
Proof.
  split.
  - intros.
    apply in_flat_map in H.
    destruct H.
    exists x.
    crush.
    apply In_noDup_sp in H0.
    unfold trace in H0.
    induction (allTuples tr sm).
    * simpl in H0. contradiction.
    * simpl. simpl in H0.
      rewrite map_app in H0.
Admitted. (*
      apply in_app_or in H0.
      destruct H0.
      + left.
        unfold tracePattern in H.
        induction (matchPattern tr sm a).
        -- simpl in H. contradiction.
        -- simpl in H.
          rewrite map_app in H.
          apply in_app_or in H.
          destruct H.
          ** apply in_map_iff in H.
            destruct H. destruct H.
            apply tr_traceRuleOnPattern_in in H0.
            destruct H0. destruct H0.
            apply tr_traceIterationOnPattern_in in H2.
            destruct H2. destruct H2.
            unfold traceElementOnPattern in H3.
            destruct (instantiateElementOnPattern x2 sm a x1) eqn:inst.
            simpl in H3.
            destruct H3.
            *** rewrite <- H3 in H. simpl in H.
                assumption.
            *** contradiction.
            *** contradiction.
          ** apply IHl0 in H. assumption.
      + auto.
    - intros.
      destruct H. destruct H.
      unfold applyTraces.
      apply in_flat_map.
      exists x.
      crush.
      unfold trace.
      unfold tracePattern.

      apply tr_applyPatternTraces_in in H0.
      repeat destruct H0.
      apply tr_matchPattern_in in H0.
      repeat destruct H0.
      induction (allTuples tr sm).
      + contradiction.
      + simpl in H. simpl.
Admitted.*)

Lemma tr_executeTraces_in_links :
forall (tr: Transformation) (sm : SourceModel) (tl : TargetModelLink),
      In tl (allModelLinks (executeTraces tr sm)) <->
          (exists (sp : list SourceModelElement),
          In sp (allTuples tr sm) /\
          In tl (applyPatternTraces tr sm sp (trace tr sm))).
Proof.
  apply tr_applyTraces_in.
Qed.

Theorem exe_preserv :
  forall (tr: Transformation) (sm : SourceModel),
    core.modeling.iteratetraces.IterateTracesSemantics.executeTraces tr sm = core.Semantics.execute tr sm.
Proof.
  intros.
  unfold core.Semantics.execute, executeTraces. simpl.
  f_equal.

  unfold trace.
  rewrite flat_map_concat_map. rewrite flat_map_concat_map.
  rewrite concat_map. f_equal.
  rewrite map_map. f_equal.

  unfold tracePattern, Semantics.instantiatePattern.
  apply functional_extensionality. intros.
  rewrite flat_map_concat_map. rewrite flat_map_concat_map.
  rewrite concat_map. f_equal.
  rewrite map_map. f_equal.

  unfold traceRuleOnPattern, Semantics.instantiateRuleOnPattern.
  apply functional_extensionality. intros.
  rewrite flat_map_concat_map. rewrite flat_map_concat_map.
  rewrite concat_map. f_equal.
  rewrite map_map. f_equal.

  unfold traceIterationOnPattern, Semantics.instantiateIterationOnPattern.
  apply functional_extensionality. intros.
  rewrite flat_map_concat_map. rewrite flat_map_concat_map.
  rewrite concat_map. f_equal.
  rewrite map_map. f_equal.

  unfold traceElementOnPattern.
  apply functional_extensionality. intros.
  (* TODO FACTOR OUT *)
  assert ((Semantics.instantiateElementOnPattern x2 sm x x1) = (instantiateElementOnPattern x2 sm x x1)).
  { crush. }
  destruct (instantiateElementOnPattern x2 sm x x1).
  reflexivity. reflexivity.
Admitted.

Lemma tr_execute_in_elements' :
forall (tr: Transformation) (sm : SourceModel) (te : TargetModelElement),
  In te (allModelElements (executeTraces tr sm)) <->
  (exists (sp : list SourceModelElement),
      In sp (allTuples tr sm) /\
      In te (instantiatePattern tr sm sp)).
Proof.
  intros.
  assert ((executeTraces tr sm) = (execute tr sm)). { apply exe_preserv. }
  rewrite H.
  specialize (Certification.tr_execute_in_elements tr sm te).
  crush.
Qed.

Lemma tr_execute_in_links' :
forall (tr: Transformation) (sm : SourceModel) (tl : TargetModelLink),
  In tl (allModelLinks (executeTraces tr sm)) <->
  (exists (sp : list SourceModelElement),
      In sp (allTuples tr sm) /\
      In tl (applyPattern tr sm sp)).
Proof.
  intros.
  assert ((executeTraces tr sm) = (execute tr sm)). { apply exe_preserv. }
  rewrite H.
  specialize (Certification.tr_execute_in_links tr sm tl).
  crush.
Qed.
(*
Instance CoqTLEngine :
  TransformationEngine :=
  {
    SourceModelElement := SourceModelElement;
    SourceModelClass := SourceModelClass;
    SourceModelLink := SourceModelLink;
    SourceModelReference := SourceModelReference;
    TargetModelElement := TargetModelElement;
    TargetModelClass := TargetModelClass;
    TargetModelLink := TargetModelLink;
    TargetModelReference := TargetModelReference;

    (* syntax and accessors *)

    Transformation := Transformation;
    Rule := Rule;
    OutputPatternElement := OutputPatternElement;
    OutputPatternLink := OutputPatternLink;

    TraceLink := TraceLink;

    Transformation_getRules := Transformation_getRules;

    Rule_getInTypes := Rule_getInTypes;
    Rule_getOutputPatternElements := Rule_getOutputPatternElements;

    OutputPatternElement_getOutputLinks := OutputPatternElement_getOutputLinks;

    TraceLink_getSourcePattern := TraceLink_getSourcePattern;
    TraceLink_getIterator := TraceLink_getIterator;
    TraceLink_getName := TraceLink_getName;
    TraceLink_getTargetElement := TraceLink_getTargetElement;

    (* semantic functions *)

    execute := executeTraces;

    matchPattern := matchPattern;
    matchRuleOnPattern := matchRuleOnPattern;

    instantiatePattern := instantiatePattern;
    instantiateRuleOnPattern := instantiateRuleOnPattern;
    instantiateIterationOnPattern := instantiateIterationOnPattern;
    instantiateElementOnPattern := instantiateElementOnPattern;

    applyPattern := applyPattern;
    applyRuleOnPattern := applyRuleOnPattern;
    applyIterationOnPattern := applyIterationOnPattern;
    applyElementOnPattern := applyElementOnPattern;
    applyLinkOnPattern := applyLinkOnPattern;

    evalOutputPatternElementExpr := evalOutputPatternElementExpr;
    evalIteratorExpr := evalIteratorExpr;
    evalOutputPatternLinkExpr := evalOutputPatternLinkExpr;
    evalGuardExpr := evalGuardExpr;

    trace := trace;

    resolveAll := resolveAllIter;
    resolve := resolveIter;

    (* lemmas *)

    tr_execute_in_elements := tr_execute_in_elements';
    tr_execute_in_links := tr_execute_in_links';

    tr_matchPattern_in := tr_matchPattern_in;
    tr_matchRuleOnPattern_Leaf := tr_matchRuleOnPattern_Leaf;

    tr_instantiatePattern_in := tr_instantiatePattern_in;
    tr_instantiateRuleOnPattern_in := tr_instantiateRuleOnPattern_in;
    tr_instantiateIterationOnPattern_in := tr_instantiateIterationOnPattern_in;
    tr_instantiateElementOnPattern_leaf := tr_instantiateElementOnPattern_leaf;

    tr_applyPattern_in := tr_applyPattern_in;
    tr_applyRuleOnPattern_in := tr_applyRuleOnPattern_in;
    tr_applyIterationOnPattern_in := tr_applyIterationOnPattern_in;
    tr_applyElementOnPattern_in := tr_applyElementOnPattern_in;
    tr_applyLinkOnPatternTraces_leaf := tr_applyLinkOnPattern_leaf;

    tr_resolveAll_in := tr_resolveAllIter_in;
    tr_resolve_Leaf := tr_resolveIter_leaf;

    (*tr_matchPattern_None := tr_matchPattern_None;

    tr_matchRuleOnPattern_None := tr_matchRuleOnPattern_None;

    tr_instantiatePattern_non_None := tr_instantiatePattern_non_None;
    tr_instantiatePattern_None := tr_instantiatePattern_None;

    tr_instantiateRuleOnPattern_non_None := tr_instantiateRuleOnPattern_non_None;

    tr_instantiateIterationOnPattern_non_None := tr_instantiateIterationOnPattern_non_None;

    tr_instantiateElementOnPattern_None := tr_instantiateElementOnPattern_None;
    tr_instantiateElementOnPattern_None_iterator := tr_instantiateElementOnPattern_None_iterator;

    tr_applyPattern_non_None := tr_applyPattern_non_None;
    tr_applyPattern_None := tr_applyPattern_None;

    tr_applyRuleOnPattern_non_None := tr_applyRuleOnPattern_non_None;

    tr_applyIterationOnPattern_non_None := tr_applyIterationOnPattern_non_None;

    tr_applyElementOnPattern_non_None := tr_applyElementOnPattern_non_None;

    tr_applyLinkOnPattern_None := tr_applyLinkOnPattern_None;
    tr_applyLinkOnPattern_None_iterator := tr_applyLinkOnPattern_None_iterator;

    tr_maxArity_in := tr_maxArity_in;

    tr_instantiateElementOnPattern_Leaf := tr_instantiateElementOnPattern_Leaf;
    tr_applyLinkOnPattern_Leaf := tr_applyLinkOnPattern_Leaf;
    tr_matchRuleOnPattern_Leaf := tr_matchRuleOnPattern_Leaf;

    tr_resolveAll_in := tr_resolveAllIter_in;
    tr_resolve_Leaf := tr_resolveIter_Leaf';*)
  }.

Instance CoqTLEngineTrace :
  (TransformationEngineTrace CoqTLEngine).
Proof.
  eexists.
(* tr_executeTraces_in_elements *) exact tr_executeTraces_in_elements.
(* tr_executeTraces_in_links *) exact tr_executeTraces_in_links.

(* tr_tracePattern_in *) exact tr_tracePattern_in.
(* tr_traceRuleOnPattern_in *) exact tr_traceRuleOnPattern_in.
(* tr_traceIterationOnPattern_in *) exact tr_traceIterationOnPattern_in.
(* tr_traceElementOnPattern_leaf *) exact tr_traceElementOnPattern_leaf.

(* tr_applyPatternTraces_in  *) exact tr_applyPatternTraces_in.
(* tr_applyRuleOnPattern_in *) exact tr_applyRuleOnPatternTraces_in.
(* tr_applyIterationOnPattern_in *) exact tr_applyIterationOnPatternTraces_in.
(* tr_applyElementOnPatternTraces_in *) exact tr_applyElementOnPatternTraces_in.
(* tr_applyLinkOnPatternTraces_leaf *) exact tr_applyLinkOnPatternTraces_leaf.

Qed.
*)

End IterateTracesCertification.


(* -*- mode: coq; coq-prog-args: ("-indices-matter"); mode: visual-line -*- *)
Set Universe Polymorphism.
Set Primitive Projections.
Close Scope nat_scope.

Record prod (A B : Type) := pair { fst : A ; snd : B }.
Arguments pair {A B} _ _.
Arguments fst {A B} _ / .
Arguments snd {A B} _ / .
Notation "x * y" := (prod x y) : type_scope.
Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.

Unset Strict Universe Declaration.

Definition Type1 := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}.
Definition Type2 := Eval hnf in let gt := (Type1 : Type@{i}) in Type@{i}.

Inductive paths {A : Type} (a : A) : A -> Type :=
  idpath : paths a a.
Arguments idpath {A a} , [A] a.
Notation "x = y" := (@paths _ x y) : type_scope.
Definition concat {A} {x y z : A} (p : x = y) (q : y = z) : x = z
  := match p, q with idpath, idpath => idpath end.

Definition path_prod {A B : Type} (z z' : A * B)
: (fst z = fst z') -> (snd z = snd z') -> (z = z').
Proof.
  destruct z, z'; simpl; intros [] []; reflexivity.
Defined.

Module Type TypeM.
  Parameter m : Type2.
End TypeM.

Module ProdM (XM : TypeM) (YM : TypeM) <: TypeM.
  Definition m := XM.m * YM.m.
End ProdM.

Module Type FunctionM (XM YM : TypeM).
  Parameter m : XM.m -> YM.m.
End FunctionM.

Module IdmapM (XM : TypeM) <: FunctionM XM XM.
  Definition m := (fun x => x) : XM.m -> XM.m.
End IdmapM.

Module Type HomotopyM (XM YM : TypeM) (fM gM : FunctionM XM YM).
  Parameter m : forall x, fM.m x = gM.m x.
End HomotopyM.

Module ComposeM (XM YM ZM : TypeM)
       (gM : FunctionM YM ZM) (fM : FunctionM XM YM)
       <: FunctionM XM ZM.
  Definition m := (fun x => gM.m (fM.m x)).
End ComposeM.

Module Type CorecM (YM ZM : TypeM) (fM : FunctionM YM ZM)
       (XM : TypeM) (gM : FunctionM XM ZM).
  Parameter m : XM.m -> YM.m.
  Parameter m_beta : forall x, fM.m (m x) = gM.m x.
End CorecM.

Module Type CoindpathsM (YM ZM : TypeM) (fM : FunctionM YM ZM)
       (XM : TypeM) (hM kM : FunctionM XM YM).
  Module fhM := ComposeM XM YM ZM fM hM.
  Module fkM := ComposeM XM YM ZM fM kM.
  Declare Module mM (pM : HomotopyM XM ZM fhM fkM)
    : HomotopyM XM YM hM kM.
End CoindpathsM.

Module Type Comodality (XM : TypeM).
  Parameter m : Type2.
  Module mM <: TypeM.
    Definition m := m.
  End mM.
  Parameter from : m -> XM.m.
  Module fromM <: FunctionM mM XM.
    Definition m := from.
  End fromM.
  Declare Module corecM : CorecM mM XM fromM.
  Declare Module coindpathsM : CoindpathsM mM XM fromM.
End Comodality.

Module Comodality_Theory (F : Comodality).

  Module F_functor_M (XM YM : TypeM) (fM : FunctionM XM YM)
         (FXM : Comodality XM) (FYM : Comodality YM).
    Module f_o_from_M <: FunctionM FXM.mM YM.
      Definition m := fun x => fM.m (FXM.from x).
    End f_o_from_M.
    Module mM := FYM.corecM FXM.mM f_o_from_M.
    Definition m := mM.m.
  End F_functor_M.

  Module F_prod_cmp_M (XM YM : TypeM)
         (FXM : Comodality XM) (FYM : Comodality YM).
    Module PM := ProdM XM YM.
    Module PFM := ProdM FXM FYM.
    Module fstM <: FunctionM PM XM.
      Definition m := @fst XM.m YM.m.
    End fstM.
    Module sndM <: FunctionM PM YM.
      Definition m := @snd XM.m YM.m.
    End sndM.
    Module FPM := F PM.
    Module FfstM := F_functor_M PM XM fstM FPM FXM.
    Module FsndM := F_functor_M PM YM sndM FPM FYM.
    Definition m : FPM.m -> PFM.m
      := fun z => (FfstM.m z , FsndM.m z).
  End F_prod_cmp_M.

  Module isequiv_F_prod_cmp_M
         (XM YM : TypeM)
         (FXM : Comodality XM) (FYM : Comodality YM).
    (** The comparison map *)
    Module cmpM := F_prod_cmp_M XM YM FXM FYM.
    Module FPM := cmpM.FPM.
    (** We construct an inverse to it using corecursion. *)
    Module prod_from_M <: FunctionM cmpM.PFM cmpM.PM.
      Definition m : cmpM.PFM.m -> cmpM.PM.m
        := fun z => ( FXM.from (fst z) , FYM.from (snd z) ).
    End prod_from_M.
    Module cmpinvM <: FunctionM cmpM.PFM FPM
      := FPM.corecM cmpM.PFM prod_from_M.
    (** We prove the first homotopy *)
    Module cmpinv_o_cmp_M <: FunctionM FPM FPM
      := ComposeM FPM cmpM.PFM FPM cmpinvM cmpM.
    Module idmap_FPM <: FunctionM FPM FPM
      := IdmapM FPM.
    Module cip_FPM := FPM.coindpathsM FPM cmpinv_o_cmp_M idmap_FPM.
    Module cip_FPHM <: HomotopyM FPM cmpM.PM cip_FPM.fhM cip_FPM.fkM.
      Definition m : forall x, cip_FPM.fhM.m x = cip_FPM.fkM.m x.
      Proof.
        intros x.
        refine (concat (cmpinvM.m_beta (cmpM.m x)) _).
        apply path_prod@{i i i}; simpl.
        - exact (cmpM.FfstM.mM.m_beta x).
        - exact (cmpM.FsndM.mM.m_beta x).
      Defined.
    End cip_FPHM.
  End isequiv_F_prod_cmp_M.

End Comodality_Theory.


Require Import FunctionalExtensionality.
Require Import Program.
Require Import ClassicalDescription.
Require Import Coq.Relations.Relation_Operators.

Set Implicit Arguments.
Set Automatic Coercions Import.

Require Import Functor.

(* Categories *)

Section UniversalFunctor.
  Variable (Sh1 Sh2: Type).

  Definition UF := Expn Sh1 (Coprod Ident (Const Sh2)).
  Hint Unfold UF.

  Global Instance UF_FunctorData : FunctorData UF.
  Proof.
    unfold UF. auto.
  Defined.

  Global Instance UF_SFunctorData : @SFunctorData UF UF_FunctorData
    := function_sFunctorData Sh1 (Coprod Ident (Const Sh2)).

  Hint Resolve UF_FunctorData UF_SFunctorData.

  Global Instance UF_FunctorProp : FunctorProp UF.
  Proof.
    constructor.
    - intro. extensionality s. extensionality s1. simplify.
      destruct (s s1) eqn : EQ; auto.
    - intros. extensionality s. simplify.
      destruct (x1 s); auto.
  Qed.
  Hint Resolve UF_FunctorProp.

  Global Instance UF_SFunctorProp : SFunctorProp UF.
  Proof.
    constructor.
    intros. inv MEM. apply Function_mem with (d := d). simplify.
    destruct (fx d); simplify; subst; auto.
  Qed.

  Lemma UF_map_injective X Y (f: X -> Y) (u1 u2: UF X)
        (INJ: forall x1 x2 (EQ: f x1 = f x2), x1 = x2)
        (EQ: map f u1 = map f u2):
    u1 = u2.
  Proof.
    extensionality s. apply equal_f with (x:=s) in EQ. simplify.
    destruct (u1 s), (u2 s); inv EQ; auto.
    apply INJ in H0. subst; auto.
  Qed.

  Lemma UF_map_pointwise X Y (u: UF X) (f g: X -> Y)
        (ALL: forall x, mem u x -> f x = g x):
    map f u = map g u.
  Proof.
    extensionality s. simplify.
    destruct (u s) eqn : EQ; auto. simplify.
    specialize (ALL i). f_equal. apply ALL.
    econstructor. simplify. rewrite EQ. constructor.
  Qed.

  Lemma UF_rel_monotone X (u1 u2: UF X) (r r': X -> X -> Prop)
        (LE: forall x0 x1: X, r x0 x1 -> r' x0 x1) (R: rel r u1 u2)
        : rel r' u1 u2.
  Proof.
    simplify. intro d. specialize (R d).
    inv R; constructor; simplify; auto.
  Qed.

  Lemma UF_map_mem X Y (f: X -> Y) (u: UF X) (x: X) (MEM: mem u x)
        : mem (map f u) (f x).
  Proof.
    inv MEM. econstructor. instantiate (1:=d). simplify.
    destruct (u d); inversion MEM0. constructor.
  Qed.

End UniversalFunctor.

Class SPFunctor (F : Type -> Type) `{SFunctorData F}
  := {
      Sh1 : Type;
      Sh2 : Type;
      emb :> @NatTrans F (UF Sh1 Sh2) _ _;
      emb_s_prop :> @SNatTransProp F (UF Sh1 Sh2) _ _ _ _ emb;
      INJECTIVE : forall T (x1 x2 : F T) (EQ : emb _ x1 = emb _ x2), x1 = x2;
      TAG : forall X (x: F X), map (@projT1 X _) (tag x) = x;
    }.
Arguments SPFunctor F {H} {H0}.

Section SPFunctorFacts.

  Context {F : Type -> Type}.
  Context `{SPFunctor F}.

  Global Instance toFunctorProp : FunctorProp F.
  Proof.
    constructor.
    - intros. extensionality s.
      apply INJECTIVE.
      rewrite MAP_COMMUTE. rewrite MAP_ID. auto.
    - intros. apply INJECTIVE.
      repeat rewrite MAP_COMMUTE. rewrite MAP_COMPOSE. auto.
  Qed.

  Global Instance toSFunctorProp : SFunctorProp F.
  Proof.
    constructor; intros.
    apply MEM_COMMUTE. apply MEM_COMMUTE in MEM.
    rewrite MAP_COMMUTE. apply (MAP_MEM f _ _ MEM).
  Qed.

  Lemma map_injective X Y (f: X -> Y) (u1 u2: F X)
        (INJ: forall x1 x2 (EQ: f x1 = f x2), x1 = x2)
        (EQ: map f u1 = map f u2):
    u1 = u2.
  Proof.
    apply INJECTIVE. apply (UF_map_injective INJ).
    repeat rewrite <- MAP_COMMUTE.
    rewrite EQ. auto.
  Qed.

  Lemma map_pointwise X Y (f g: X -> Y) (m: F X)
        (ALL: forall x, mem m x -> f x = g x):
    map f m = map g m.
  Proof.
    apply INJECTIVE.  repeat rewrite MAP_COMMUTE.
    apply UF_map_pointwise.
    intros. apply ALL, MEM_COMMUTE, H2.
  Qed.

  Lemma rel_monotone X (u1 u2: F X) (r r': X -> X -> Prop)
        (LE: forall x0 x1: X, r x0 x1 -> r' x0 x1) (R: rel r u1 u2)
    : rel r' u1 u2.
  Proof.
    apply REL_COMMUTE. apply REL_COMMUTE in R.
    apply (UF_rel_monotone _ LE). auto.
  Qed.

  Lemma MAP_DEP X Y fx (f: forall x (MEM:mem fx x), Y) (g: Y -> X)
        (INV: forall x r, g (f x r) = x) : map g (map_dep fx f) = fx.
  Proof.
    unfold map_dep. rewrite MAP_COMPOSE. unfold compose.
    replace (fun x : {H2 : X & mem fx H2} => g (let (x0, m) := x in f x0 m)) with
        (@projT1 X (mem fx)).
    - apply TAG.
    - extensionality s. destruct s. auto.
  Qed.

End SPFunctorFacts.


(** This file is the backbone of our development. It contains
   the definition of the DPLL procedure, the proofs of its soundness
   and completeness. It also contains a naive but functional
   proof search function that implements our DPLL system.
*)

Require Import Arith Bool List.
Require Import DoubleNegUtils Cnf.
Require Import Semantics Env.
Require Containers.SetProperties. Module Props := SetProperties.
Require Containers.SetEqProperties. Module EProps := SetEqProperties.

(** Cannot Require Import Omega because the notations for positive conflict
    with the { C ~ D } notation in sets. *)
Declare ML Module "omega_plugin".

(** * The main functor [SAT] *)
Module SAT (CNF : CNF)(Import E : ENV_INTERFACE CNF).
  (** The functor [SAT] is parameterized by a module of type [CNF].
     The procedure and functions will be defined on the literals
     and formulas brought by the [CNF] module.

     The functor starts by constructing a semantic interface for
     [CNF] and also some properties about sets and sets of sets
     of literals. *)
(*   Declare Module Import E : ENV_INTERFACE CNF. *)
  Module EnvF := EnvFacts CNF E.
  Import CNF.
  Module SemF := SemFacts(L)(Sem).

  (** ** Definition of the proof derivation system *)
  (** A [sequent] is just the pairing of a partial assignment [G]
     and a set of clauses [D] to be satisfied. It is denoted [G |- D]. *)
  Record sequent : Type := mk_sequent {
    G : E.t;
    D : cset
  }.
  Notation "G |- D" := (mk_sequent G D) (at level 80).

  (** A sequent [G |- D] is said to be [incompatible] if no model
     extending [G] is a model of [D]. *)
  Definition incompatible (S : sequent) : Prop :=
    Sem.incompatible (dom (G S)) (D S).

  (** Our proof system is formalized as a set of inference rules. We encode it
     as an inductive predicate on sequents. Each constructor corresponds
     to an inference rule. *)
  Inductive derivable : sequent -> Prop :=
  | AConflict :
    forall G D (i : {} \In D),
      derivable (G |- D)
  | AAssume :
    forall G D l (i : (singleton l) \In D) newG
      (Hass : assume l G = Normal newG),
      derivable (newG |- (cfl (L.expand l)) ++ ({D ~ (singleton l)})) ->
      derivable (G |- D)
  | AElim :
    forall G D l C (e : G |= l) (i : l \In C) (i0 : C \In D),
      derivable (G |- {D ~ C}) ->
      derivable (G |- D)
  | ARed :
    forall G D reds C
      (e: forall l, l \In reds -> G |= L.mk_not l)
      (s : reds [<=] C) (i : C \In D),
      derivable (G |- {(C \ reds); D}) ->
      derivable (G |- D)
  | AUnsat :
    forall G D l G1 G2
      (Hass1 : assume l G = Normal G1)
      (Hass2 : assume (L.mk_not l) G = Normal G2),
      derivable (G1 |- (cfl (L.expand l)) ++ D) ->
      derivable (G2 |- (cfl (L.expand (L.mk_not l))) ++ D)->
      derivable (G |- D).

  (** ** Correctness of the inference rules *)
  (** The first thing we want to do is prove the soundness of our
     derivation system, ie. that if a sequent is derivable, then
     it is incompatible. *)

  (** We start by a couple of useful weakening and morphism properties
     about derivability. *)
  Section Weakening.

    Definition sub_sequent (S S' : sequent) : Prop :=
      G S = G S' /\ D S [<=] D S'.

    Lemma weakening : forall S, derivable S ->
      forall S', sub_sequent S S' -> derivable S'.
    Proof.
      intros S Hder; induction Hder; intros S' H; intros;
        destruct S'; destruct H; simpl in *; subst.
      constructor 1; exact (H0 _ i).
      constructor 2 with l newG; auto; apply IHHder.
      split; simpl; auto; intro a.
      set_iff; intuition.
      constructor 3 with (l := l) (C := C); intuition eauto.
      apply IHHder; split; auto; simpl; intro a;
        try (rewrite remove_iff); intuition.
      constructor 4 with (reds := reds) (C := C); intuition eauto.
      apply IHHder; split; auto; simpl; intro a; auto.
      do 2 (rewrite add_iff); intuition.
      constructor 5 with l G1 G2; auto; [apply IHHder1 | apply IHHder2];
        split; simpl; auto; intro a; try (set_iff; intuition);
          rewrite assumed_assume in H1 |- *;
            revert H1 H; clear; set_iff; intuition.
    Qed.

    Definition eq_Seq (S S' : sequent) :=
      G S = G S' /\ (D S) [=] (D S').

    Lemma derivable_m : forall S, derivable S ->
      forall S', eq_Seq S S' -> derivable S'.
    Proof.
      intros S HS S' Heq; apply (weakening S HS S').
      destruct Heq as [HG HD]; split;
        [rewrite HG | rewrite HD]; reflexivity.
    Qed.

    Instance eq_Seq_Equivalence : Equivalence eq_Seq.
    Proof.
      constructor.
      intro x; split; reflexivity.
      intros x y [H1 H2]; split; symmetry; auto.
      intros x y z [H1 H2] [H1' H2']; split; eapply transitivity; eauto.
    Qed.

    Global Instance eq_Seq_m (G0 : E.t) :
      Proper (Equal ==> eq_Seq) (mk_sequent G0).
    Proof.
      intros d d' H; split; auto; reflexivity.
    Qed.

    Global Instance derivable_morphism : Proper (eq_Seq ==> iff) derivable.
    Proof.
      intros S S' H; destruct S; destruct S';
        simpl; split; intro Z; refine (derivable_m _ Z _ _);
          auto; symmetry; auto.
    Qed.
  End Weakening.

  (** An Application of weakening : a strong version of reduction
     where the subsumed clause is removed as well. *)
  Theorem AStrongRed : forall (G : t) (D : cset) (reds C : clause),
    (forall l : L.t, l \In reds -> G |= L.mk_not l) ->
    reds[<=]C ->
    C \In D -> derivable (G |- {C \ reds; {D ~ C}}) -> derivable (G |- D).
  Proof.
    intros.
    apply ARed with reds C; auto.
    refine (weakening _ H2 _ _); split; simpl; intuition.
  Qed.

  (** Soundness of expand function *)
  Lemma expand_models :
    forall (M : Sem.model) (l : L.t),
      M l -> Sem.sat_goal M (cfl (L.expand l)).
  Proof.
    intros M l Hl.
    assert (H := SemF.model_expand M l Hl).
    assert (R := cfl_1 (L.expand l)).
    revert H R; generalize (L.expand l); clear.
    intro l; generalize (cfl l).
    induction l; simpl; intros s H R c Hc.
    crewrite R Hc; contradiction (empty_1 Hc).
    crewrite R Hc; rewrite add_iff in Hc; destruct Hc.

    clear IHl; assert (Ha := H a (or_introl _ (refl_equal a))).
    clear H l; revert c H0 Ha; induction a; simpl; intros;
      destruct Ha as [x [Hx Hx']]; try contradiction.
    destruct Hx; subst.
    exists x; split; auto. rewrite <- H0; intuition.
    destruct (IHa _ (reflexivity _)) as [y [Hy Hy']].
    exists x; tauto.
    exists y; split; auto.
    rewrite <- H0; apply add_2; assumption.

    refine (IHl _ _ _ c H0).
    intuition. reflexivity.
  Qed.

  Lemma submodel_add :
    forall (M : Sem.model) (G G' : E.t) (l : L.t),
      assume l G = Normal G' ->
      Sem.submodel (dom G) M -> M l -> Sem.submodel (dom G') M.
  Proof.
    intros M G0 G1 l Hass Hsub Hl l' Hl'.
    rewrite (assumed_assume Hass), add_iff in Hl'.
    destruct Hl'; [exact (SemF.model_m _ _ _ H Hl) | exact (Hsub l' H)].
  Qed.

  (** This theorem states the [soundness] of the derivation system.
     It is proven by induction on the derivation of the sequent [S]. *)
  Theorem soundness : forall S : sequent, derivable S -> incompatible S.
  Proof with (auto with typeclass_instances).
    intros S p; induction p; unfold incompatible; unfold Sem.incompatible;
      simpl; unfold Sem.sat_goal; intros; intro abs.
    (** - AAxiom : the empty clause is not satisfiable *)
    destruct (abs {} i) as [x [_ Hx]].
    rewrite empty_iff in Hx; contradiction.
    (** - AAssume : the unitary clause would have to be satisfied *)
    destruct (abs {l} i) as [m [Hm1 Hm2]].
    assert (Hl : M l).
    exact (SemF.model_m M _ _ (symmetry (singleton_1 Hm2)) Hm1).
    refine (IHp M (submodel_add M G0 newG l Hass H Hl) _); simpl.
    intros C; simpl; set_iff; intros [HC|[HC _]].
    exact (expand_models M l Hl C HC).
    exact (abs C HC).
    (** - AElim : the removed clause is satisfiable anyway *)
    exact (IHp M H (fun C HC => abs C (remove_3 HC))).
    (** - ARed : the removed literal is false anyway *)
    apply (IHp M H); intro C';
      case_eq (equal C' (C \ reds)); intros Hd HC'.
    rewrite <- equal_iff in Hd.
    destruct (abs C i) as [x [Hx1 Hx2]]; exists x; rewrite Hd.
    refine (conj Hx1 (diff_3 Hx2 _))...
    intro absx; pose (Ml := query_true (e x absx) H).
    exact (SemF.model_em M x Hx1 Ml).
    refine (abs C' (add_3 _ HC'))...
    intro abs1; symmetry in abs1;
      rewrite (equal_1 abs1) in Hd; discriminate.
    (** - AUnsat : in a model, [l] would have to be either true or false *)
    elim (dnc (M l)); intro Hl; destruct Hl as [Hl | Hl].
    refine (IHp1 M (submodel_add M G0 _ l Hass1 H Hl) (fun C HC => _)).
    simpl in HC; rewrite union_iff in HC; destruct HC; auto.
    exact (expand_models M l Hl C H0).
    elim (SemF.model_full M l); intro Hfull.
    refine (IHp2 M (submodel_add M G0 _ _ Hass2 H (Hfull Hl)) _).
    intro C; simpl; set_iff; intros [HC|HC]; auto.
    exact (expand_models M _ (Hfull Hl) C HC).
  Qed.

  (** ** A naive strategy for proof search *)
  (** Now we will prove the completeness of the derivation system
     by constructing a function that tries to build a derivation
     and showing that this function is correct and complete. *)

  (** During the proof search, we will use a certain number of predicates
     to find clauses that have some properties. Their definition follows,
     with some useful lemmas (e.g. compatibility lemmas) *)
  Set Implicit Arguments. Unset Strict Implicit.
  Section Filtering.
    Variable G : E.t.
    Variable D : cset.

    Section Finding.
      Variable f : clause -> bool.
      Variable compatf : Proper (_eq ==> @eq bool) f.

      Definition select :=
        (fun c p =>
          match p with
            | Some _ => p
            | None => if f c then Some c else None
          end).

      Definition find (D : cset) := fold select D None.

      Lemma find_1 :
        forall D C, find D = Some C -> C \In D.
      Proof.
        intros D0 C0; unfold find; rewrite fold_1.
        rewrite elements_iff; revert C0.
        generalize (elements D0); clear D0; intro l; pattern l.
        apply rev_ind; simpl.
        intros C0 abs; inversion abs.
        intros x l0 IH; rewrite (fold_left_app); simpl.
        intro C0;
          match goal with | |- select x ?F = _ -> _ => case_eq F end; intros.
        unfold select in H0; inversion H0; subst.
        pose (IHH := IH C0 H); rewrite InA_alt in *; destruct IHH.
        exists x0; split; [exact (proj1 H1) | ].
        rewrite In_rev; rewrite rev_unit; simpl; right.
        rewrite In_rev; rewrite rev_involutive; exact (proj2 H1).
        unfold select in H0; destruct (f x); inversion H0.
        apply In_InA; auto using Equal_pw_Equivalence with *.
      Qed.

      Lemma find_2 : forall D C, find D = Some C -> f C = true.
      Proof.
        intros D0 C0; unfold find; rewrite fold_1;
          generalize C0; generalize (elements D0);
            clear D0; clear C0; intro l; pattern l.
        apply rev_ind; simpl.
        intros C0  abs; discriminate.
        intros x l0 IH; rewrite (fold_left_app); simpl.
        intro C;
          match goal with | |- select x ?F = _ -> _ => case_eq F end; intros.
        unfold select in H0; inversion H0; subst; exact (IH _ H).
        simpl in H0; case_eq (f x); intro eq; rewrite eq in H0.
        inversion H0; subst; assumption.
        discriminate.
      Qed.

      Lemma find_3 :
        forall D, find D = None -> forall C, C \In D -> f C = false.
      Proof.
        intros D0; unfold find; rewrite fold_1.
        intros IH C; rewrite elements_iff; revert C; revert IH.
        generalize (elements D0); clear D0; intro l; pattern l.
        apply rev_ind; simpl.
        intros _ C0 abs; inversion abs.
        intros x l0 IH; rewrite (fold_left_app); simpl.
        match goal with | |- select x ?F = _ -> _ => case_eq F end; intros.
        unfold select in IH0; inversion H0; discriminate.
        destruct (InA_app H0); [exact (IH H C H1) |].
        unfold select in IH0; case_eq (f x); intros.
        rewrite H2 in IH0; discriminate.
        inversion H1; [| inversion H4].
        rewrite H4; assumption.
      Qed.

    End Finding.

    (** - [is_empty] is compatible : it is already in SetFacts. *)

    (** - [eliminable C] filters clauses that contain a true atom *)
    Definition eliminable (c : clause) := exists_ (fun l : L.t => query l G) c.
    Global Instance compat_mem :
      Proper (_eq ==> @eq bool) (fun l : L.t => query l G).
    Proof.
      repeat intro; rewrite H; auto.
    Qed.
    Global Instance compat_elim : Proper (_eq ==> @eq bool) eliminable.
    Proof.
      repeat intro; unfold eliminable.
      do 2 rewrite (EProps.exists_filter (f:=_)).
      rewrite H; reflexivity.
    Qed.

    (** - [reducible C] finds clauses that contain a false atom *)
    Definition reducible (c : clause) :=
      exists_ (fun l : L.t => query (L.mk_not l) G) c.
    Global Instance compat_mem2 :
      Proper (_eq ==> @eq bool) (fun l : L.t => query (L.mk_not l) G).
    Proof.
      repeat intro; rewrite H; auto.
    Qed.
    Global Instance compat_red : Proper (_eq ==> @eq bool) reducible.
    Proof.
      repeat intro; unfold reducible.
      do 2 rewrite (EProps.exists_filter (f:=_)).
      rewrite H; reflexivity.
    Qed.

    (** - other interesting clauses are unitary clauses, ie singletons.
       [unitary] filters those clauses. *)
    Definition unitary (C : clause) :=
      match choose C with
        | Some x => is_empty {C ~ x}
        | _ => false
      end.
    Global Instance compat_unitary : Proper (_eq ==> @eq bool) unitary.
    Proof.
      repeat intro; unfold unitary.
      case_eq (choose x); intros; case_eq (choose y); intros.
      assert (Hx := choose_1 H0); clear H0.
      assert (Hy := choose_1 H1); clear H1.
      rewrite H in Hx |- *; destruct (eq_dec t0 t1) as [E|N].
      rewrite E; reflexivity.
      transitivity false; [|symmetry]; apply not_true_is_false;
        rewrite <- is_empty_iff; intro A.
      apply A with t1; set_iff; intuition.
      apply A with t0; set_iff; intuition symmetry; auto.
      assert (Hx := choose_1 H0).
      assert (Hy := choose_2 H1).
      rewrite H in Hx; contradiction (Hy t0 Hx).
      assert (Hx := choose_1 H1).
      assert (Hy := choose_2 H0).
      rewrite H in Hy; contradiction (Hy t0 Hx).
      reflexivity.
    Qed.

    (** A unitary clause containing [l] is the singleton [l]. *)
    Lemma unitary_singl : forall C l,
      unitary C = true -> l \In C -> C [=] singleton l.
    Proof.
      unfold Equal; unfold unitary; intros C l Hunit HC a.
      rewrite singleton_iff in *; split; intro H.
      case_eq (choose C); [intros z Hz | intro Hz]; rewrite Hz in Hunit.
      rewrite <- is_empty_iff in Hunit.
      destruct (eq_dec l a); auto.
      assert (Hz' := choose_1 Hz).
      destruct (eq_dec l z) as [e|n]. rewrite e in *.
      contradiction (Hunit a); set_iff; intuition.
      contradiction (Hunit l); set_iff; intuition (symmetry; auto).
      discriminate.
      rewrite H in HC; auto.
    Qed.

  End Filtering.
  Unset Implicit Arguments.
  Implicit Arguments find_3 [[compatf] D C].

  (** A context should be a valid partial model, the following
     property expresses what this means in practice. *)
  Definition wf_context (G : lset) : Prop :=
    forall l, l \In G -> (L.mk_not l) \In G -> False.

  (** The result of our proof search will be either [Sat M] where [M]
     is a partial assignment satisfying the problem, or [Unsat] if
     no assignment has been found. *)
  Inductive Res : Type :=
    Sat : E.t -> Res
  | Unsat.

  (** The proof-search procedure takes a sequent as argument and
     tries to build a derivation for this sequent. It also takes an
     extra integer argument which bounds the depth of recursive calls
     that the proof search can do. We will later show that we can find
     a measure such that we never reach that bound.

     The proof search in itself consists in trying to apply one rule
     after the other as long as the set of clauses is not empty. Rules
     are tried in a sensible way : [AConflict], [AElim], [ARed], [AUnit]
     and finally [AUnsat] which splits on a literal.
  *)
  Fixpoint proof_search (S : sequent) (n : nat)
    {struct n} : Res :=
    match n with
      | O => Sat empty (* assert false *)
      | S n0 =>
        if is_empty (D S) then Sat (G S)
        else
          match find is_empty (D S) with
            | Some EC => Unsat
            | None =>
              match find (eliminable (G S)) (D S) with
                | Some C =>
                  proof_search ((G S) |- {(D S) ~ C}) n0
                | None =>
                  let reducers (C : clause) :=
                    filter (fun l => query (L.mk_not l) (G S)) C in
                    match find (reducible (G S)) (D S) with
                      | Some C =>
                        match choose (reducers C) with
                          | Some l =>
                            let Cred := C \ (singleton l) in
                              proof_search ((G S) |- {Cred; {D S ~ C}}) n0
                          | None => Sat empty (* assert false *)
                        end
                      | None =>
                        match find unitary (D S) with
                          | Some C =>
                            match choose C with
                              | Some l =>
                                match assume l (G S) with
                                  | Normal newG =>
                                    let D' :=
                                      (cfl (L.expand l)) ++
                                      (remove (singleton l) (D S)) in
                                      proof_search (newG |- D') n0
                                  | Inconsistent => Sat empty (* assert false *)
                                end
                              | None => Sat empty (* assert false *)
                            end
                          | None =>
                            match pick (D S) with
                              | Some (C, l) =>
                                match assume l (G S) with
                                  | Normal G1 =>
                                    match proof_search
                                      (G1 |- remove C
                                        (cfl (L.expand l) ++ D S)) n0 with
                                      | Sat M => Sat M
                                      | Unsat =>
                                        match assume (L.mk_not l) (G S) with
                                          | Normal G2 =>
                                            let Cred := C \ (singleton l) in
                                              proof_search
                                              (G2 |- {Cred ;
                                                {(cfl (L.expand (L.mk_not l)))
                                                  ++(D S) ~ C}})
                                              n0
                                          | Inconsistent =>
                                            Sat empty (* assert false *)
                                        end
                                    end
                                  | Inconsistent => Sat empty (* assert false *)
                                end
                              | None => Sat empty (* assert false *)
                            end
                        end
                    end
              end
          end
    end.

  (** ** Soundness and completeness proofs for the proof search *)
  (** The first proof we want about [proof_search] is its soundness with
     respect to our informal specification above, namely that it should not
     return [Unsat] unless it has found a derivation of the sequent. *)
  Theorem proof_search_unsat :
    forall n S, proof_search S n = Unsat -> derivable S.
  Proof.
    intro n; induction n; intro S; unfold proof_search.
    (** - Case n = 0 is absurd *)
    intro abs; discriminate abs.

    fold proof_search; destruct S; simpl in * |- *.
    case_eq (is_empty D0); intro empty_goal.
    (** - If the problem is empty... *)
    intro abs; discriminate abs.

    case_eq (find is_empty D0); [| intro empty_clause].
    (** - If there is an empty clause, we have a derivation *)
    intros C HC _; apply AConflict.
    assert (Cempty := find_2 HC).
    rewrite EProps.is_empty_equal_empty in Cempty.
    rewrite <- equal_iff in Cempty.
    rewrite <- Cempty; exact (find_1 HC).

    case_eq (find (eliminable G0) D0).
    (** - The next step is to try some BCP, first Elim ... *)
    intros C HC; pose (HC1 := find_1 HC); pose (HC2 := find_2 HC).
    destruct (EProps.exists_mem_4 (s:=C) HC2) as [l [HCl Hl]].
    intro IH; assert (IP := IHn _ IH).
    exact (AElim G0 D0 l C Hl (mem_2 HCl) HC1 IP).

    intro elim; case_eq (find (reducible G0) D0).
    (** - and then Red *)
    intros C HC; pose (HC1 := find_1 HC); pose (HC2 := find_2 HC).
    destruct (EProps.exists_mem_4 (s:=C) HC2) as [m [HCm Hm]].
    case_eq (choose (filter (fun l => query (L.mk_not l) G0) C)); [|intro abs].
    intros l Hl.
    assert (Hl1 := filter_1 (choose_1 Hl)).
    assert (Hl2 := filter_2 (choose_1 Hl)).
    simpl in Hl2; intro IH; assert (IP := IHn _ IH).
    apply (AStrongRed G0 D0 {l} C); auto.
    intros k Hk; assert (e := singleton_1 Hk);
      rewrite L.mk_not_compat in e; rewrite <- e; exact Hl2.
    intros k Hk; rewrite <- (singleton_1 Hk); exact Hl1.
    intro dis; discriminate dis.

    intro red; case_eq (find unitary D0).
    (** - When all possible BCP has been done, we turn to unitary clauses *)
    intros C HC; pose (HC1 := find_1 HC); pose (HC2 := find_2 HC).
    unfold unitary in HC2; case_eq (choose C).
    2:intro H; rewrite H in HC2; discriminate.
    intros l Hchoose; assert (Hl := unitary_singl HC2 (choose_1 Hchoose)).
    case_eq (assume l G0); [intros newG Hass | intros; discriminate].
    intro IH; pose (IP := IHn _ IH).
    apply (AAssume G0 D0 l) with newG; auto.
    rewrite <- Hl; exact HC1.

    (** - Now, our only alternative left is to pick any literal that
       appears in Delta and try it in an Unsat rule *)
    case_eq (pick D0). intros [C l] Hl.
    destruct (pick_1 _ _ _ Hl) as [Hpick1 Hpick2].
    (** -- we first use the IH on the left branch *)
    case_eq (assume l G0); [intros G1 Hass1 | intros; discriminate].
    intro unit; case_eq (proof_search
      (G1 |- (remove C (union (cfl (L.expand l)) D0))) n);
    intro IH1.
    intros _ abs;  discriminate.
    (** -- and then on the second one *)
    case_eq (assume (L.mk_not l) G0); [intros G2 Hass2 | intros; discriminate].
    case_eq (proof_search (G2 |- (add (diff C (singleton l))
      (remove C (union (cfl (L.expand (L.mk_not l))) D0)))) n); intro IH2.
    intros _ abs; discriminate abs.
    intros _; refine (AUnsat G0 D0 l _ _ Hass1 Hass2 _ _).
    (** -- here we do more than one rule to ensure the measure decreases *)
    refine (AElim _ _ l C _ Hpick2 _ (IHn _ IH1)).
    apply (EnvF.query_assume Hass1); auto. apply union_3; exact Hpick1.
    refine (AStrongRed _ _ _ _ _ _ _ (IHn _ IH2)).
    intros k Hk; apply (EnvF.query_assume Hass2);
      rewrite <- L.mk_not_compat; exact (singleton_1 Hk).
    intros k Hk; exact (In_1 (singleton_1 Hk) Hpick2).
    apply union_3; exact Hpick1.

    (** There remain cases where we were unable to pick a literal, but
       this means the problem is empty or all clauses are empty, which
       has already been treated before. *)
    intro abs; cut (Empty D0).
    intro P; rewrite (is_empty_iff) in P;
      rewrite P in empty_goal; discriminate.
    refine (pick_2 D0 (fun C HC Hemp => _) abs).
    rewrite (is_empty_iff) in Hemp.
    rewrite (find_3 is_empty empty_clause HC) in Hemp.
    discriminate.
  Qed.

  (** In order to prove the converse of this property, namely that
     [proof_search] only returns [Sat _] if there is no derivation,
     we need a measure of sequents. *)
  Import Arith.
  Section Measure.

    (** The size of a sequent is the sum of the sizes of the literals
     that appear in the rhs of the sequent. *)
    Definition lsize l acc := L.size l + acc.
    Definition csize (C : clause) := fold lsize C.
    Definition size (S : sequent) := fold (A:=clause) csize (D S) 0.

    (** Quick facts about csize and
       in order to be able to use results about fold *)
    Global Instance C_lsize : Proper (_eq ==> @eq nat ==> @eq nat) lsize.
    Proof.
      repeat intro; unfold lsize; subst.
      rewrite H; reflexivity.
    Qed.
    Fact T_lsize : transpose (eq (A:=nat)) lsize.
    Proof.
      unfold transpose; intros; unfold lsize; omega.
    Qed.

    Global Instance C_csize : Proper (_eq ==> @eq nat ==> @eq nat) csize.
    Proof.
      repeat intro; unfold csize; subst.
      apply (Props.fold_equal T_lsize _ H).
    Qed.
    Fact T_csize : transpose (eq (A:=nat)) csize.
    Proof.
      unfold transpose; unfold csize; intros.
      generalize T_lsize.
      generalize (fun l acc => L.size l + acc); intros f Hf.
      repeat rewrite fold_1; generalize (elements x).
      repeat rewrite fold_1; generalize (elements y).
      intro l; pattern l; apply rev_ind; intros l0; simpl.
      reflexivity.
      intros; do 2 rewrite fold_left_app; simpl; rewrite <- (H l2).
      clear x y H l; pattern l2; apply rev_ind; simpl.
      reflexivity.
      intros; do 2 rewrite fold_left_app; simpl.
      rewrite H; apply Hf.
    Qed.

    (** Straightforward properties about [lsize] *)
    Property lsize_monotonic : forall l acc1 acc2,
      acc1 <= acc2 -> lsize l acc1 <= lsize l acc2.
    Proof.
      intros; unfold lsize; omega.
    Qed.
    Property lsize_lt_compat : forall l acc1 acc2,
      acc1 < acc2 -> lsize l acc1 < lsize l acc2.
    Proof.
      intros; unfold lsize; omega.
    Qed.
    Property lsize_acc : forall l acc, acc <= lsize l acc.
    Proof.
      intros; unfold lsize; omega.
    Qed.

    (** A couple of properties about [csize] *)
    Property csize_acc : forall c acc, csize c acc = csize c 0 + acc.
    Proof.
      intros; unfold csize; do 2 rewrite fold_1.
      generalize (elements c) acc; clear.
      intro l; pattern l; apply rev_ind; intros; simpl.
      reflexivity.
      do 2 rewrite fold_left_app; rewrite H;
        simpl; unfold lsize; omega.
    Qed.
    Property csize_monotonic : forall c acc1 acc2,
      acc1 <= acc2 -> csize c acc1 <= csize c acc2.
    Proof.
      intros; rewrite csize_acc; rewrite (csize_acc c acc2); omega.
    Qed.
    Property csize_lt_compat : forall c acc1 acc2,
      acc1 < acc2 -> csize c acc1 < csize c acc2.
    Proof.
      intros; rewrite csize_acc; rewrite (csize_acc c acc2); omega.
    Qed.
    Property csize_acc_ge : forall c acc, csize c acc >= acc.
    Proof.
      intros; rewrite csize_acc; omega.
    Qed.

    Property csize_in :
      forall c l acc, l \In c ->
        csize c acc = lsize l (csize {c ~ l} acc).
    Proof.
      intros; unfold csize.
      rewrite <- (Props.remove_fold_1 T_lsize acc H).
      reflexivity.
    Qed.

    (** Finally some similar properties about [size]. *)
    Property size_m : forall G G' D D',
      D [=] D' -> size (G |- D) = size (G' |- D').
    Proof.
      intros G0 G1 D0 D1 Heq; unfold size; simpl in *.
      rewrite (Props.fold_equal T_csize 0 Heq).
      reflexivity.
    Qed.
    Property size_in :
      forall G D C, C \In D ->
        size (G |- D) = csize C 0 + size (G |- {D ~ C}).
    Proof.
      intros G0 D0 C HC; unfold size; simpl.
      rewrite <- (Props.remove_fold_1 T_csize 0 HC).
      generalize (fold csize (remove C D0) 0); intro n.
      unfold csize; do 2 rewrite fold_1; generalize (elements C).
      clear; intro l; revert n; pattern l; apply rev_ind; simpl.
      reflexivity.
      intros; repeat rewrite fold_left_app; simpl; unfold lsize in *.
      rewrite H; omega.
    Qed.
    Property size_add :
      forall G D C, ~C \In D -> size (G |- {C; D}) = csize C 0 + size (G |- D).
    Proof.
      intros G0 D0 C HC; unfold size; simpl.
      rewrite (Props.fold_add T_csize); auto.
      generalize (fold csize D0 0); intro n.
      unfold csize; do 2 rewrite fold_1; generalize (elements C).
      clear; intro l; revert n; pattern l; apply rev_ind; simpl.
      reflexivity.
      intros; repeat rewrite fold_left_app; simpl; unfold lsize in *.
      rewrite H; omega.
    Qed.

    (** [size] decreases when a clause is eliminated. *)
    Lemma size_elim_dec :
      forall G G' (D : cset) C l,
        C \In D -> l \In C -> size (G |- {D ~ C}) < size (G' |- D).
    Proof.
      intros G0 G1 D0 C l HC Hl; unfold size; simpl.
      rewrite <- (Props.remove_fold_1 T_csize 0 HC).
      generalize (fold csize {D0 ~ C} 0); intro n.
      rewrite (csize_in C l n Hl); unfold lsize.
      set (L.size_pos l); set (csize_acc (remove l C) n); omega.
    Qed.

    (** [size] decreases when a clause is reduced. *)
    Lemma size_red_dec :
      forall G D C l, C \In D -> l \In C ->
        size (G |- add (remove l C) (remove C D)) < size (G |- D).
    Proof.
      intros G0 D0 C l HC Hl; unfold size; simpl.
      case_eq (mem (remove l C) (remove C D0)); intro Hin.
      rewrite (Props.add_fold T_csize 0 (mem_2 Hin)).
      exact (size_elim_dec G0 G0 D0 C l HC Hl).
      rewrite (Props.fold_add T_csize).
      rewrite <- (Props.remove_fold_1 T_csize 0 HC).
      rewrite (csize_in C l _ Hl); set (L.size_pos l); unfold lsize; omega.
      intro abs; rewrite (mem_1 abs) in Hin; discriminate.
    Qed.

    (** Before we continue, two lemmas about size and expansion. *)
    Lemma size_union :
      forall G D D', size (G |- D ++ D') <= size (G |- D) + size (G |- D').
    Proof.
      intros G0 D0 D1; unfold size; simpl.
      revert D1; pattern D0; apply Props.set_induction; intros.
      rewrite (Props.fold_union T_csize).
      2:(intros x [absx _]; contradiction (H x absx)).
      generalize (fold csize D1 0); intro n.
      rewrite 2!fold_1; generalize (elements s); intro l.
      clear; pattern l; apply rev_ind; simpl; auto.
      intros; rewrite 2!fold_left_app; simpl.
      rewrite csize_acc. rewrite (csize_acc x (fold_left _ _ _)).
      omega.
      assert (R := (proj1 (Props.Add_Equal _ _ _) H1)).
      rewrite (Props.fold_equal T_csize 0 R).
      rewrite (Props.fold_add T_csize 0 H0).
      rewrite csize_acc.
      assert (Heq : (s' ++ D1) [=] (add x (s ++ D1))).
      rewrite R; apply Props.union_add.
      rewrite (Props.fold_equal T_csize 0 Heq).
      case_eq (mem x D1); intro Hmem.
      rewrite (Props.add_fold T_csize 0 (union_3 _ (mem_2 Hmem))).
      set (H D1); omega.
      rewrite (Props.fold_add T_csize 0).
      rewrite csize_acc; set (H D1); omega.
      intro abs; destruct (union_1 abs) as [a1|a2].
      contradiction (H0 a1).
      rewrite (mem_1 a2) in Hmem; discriminate.
    Qed.

    Lemma size_expand :
      forall l, fold csize (cfl (L.expand l)) 0 < L.size l.
    Proof.
      intros; assert (Hl := cfl_1 (L.expand l)).
      assert (Hsz : L.llsize (L.expand l) < L.size l).
      set (L.size_expand l); omega.
      rewrite (Props.fold_equal T_csize 0 Hl).
      refine (Arith.Lt.le_lt_trans _ _ _ _ Hsz).
      generalize (L.expand l); clear; induction l; simpl.
      rewrite Props.fold_1b; intuition.

      case_eq (mem (fold_right add {} a)
        (fold_right (fun (l0 : list L.t) (cl : cset) =>
          add (fold_right add {} l0) cl) {} l));
      intro Hmem.
      rewrite (Props.add_fold T_csize 0 (mem_2 Hmem)).
      refine (le_trans _ _ _ IHl _); clear.
      induction a; simpl; omega.
      rewrite (Props.fold_add T_csize 0).
      2:(intro abs; rewrite (mem_1 abs) in Hmem; discriminate).
      rewrite csize_acc; clear Hmem.
      cut (forall a b b' c, a + b <= c -> b' <= b -> a + b' <= c).
      2:intros; omega.
      intro cut; refine (cut _ _ _ _ _ IHl); clear.
      induction a; simpl; unfold csize in *.
      rewrite Props.fold_1b; intuition.
      case_eq (mem a (fold_right add ({} : clause) a0)); intro Hmem.
      rewrite (Props.add_fold T_lsize 0 (mem_2 Hmem)); omega.
      rewrite (Props.fold_add T_lsize 0).
      2:(intro abs; rewrite (mem_1 abs) in Hmem; discriminate).
      unfold lsize in *; omega.
    Qed.

    (** [size] decreases when a clause is assumed and expanded. *)
    Lemma size_assume_dec :
      forall G D l, In {l} D ->
        forall newG, assume l G = Normal newG ->
          size (newG |- cfl (L.expand l) ++ (remove {l} D))
          < size (G |- D).
    Proof.
      intros G0 D0 l HCl newG Hass; simpl.
      refine (Arith.Lt.le_lt_trans
        _ _ _ (size_union G0 _ _) _); unfold size; simpl.
      rewrite <- (Props.remove_fold_1 T_csize 0 HCl).
      assert (Hl : (singleton l : clause) [=] {l; {}}) by
        (exact (Props.singleton_equal_add l)).
      generalize (fold csize (remove (singleton l) D0) 0).
      intro n; rewrite Hl; unfold csize.
      rewrite (Props.fold_add T_lsize n).
      rewrite (Props.fold_empty); auto with typeclass_instances.
      apply plus_lt_compat_r; apply size_expand.
      intro abs; contradiction (empty_1 abs).
    Qed.

    (** [size] decreases when removing a clause that contains a literal
       and expanding a same-sized literal at the same time. *)
    Lemma size_left_unsat_dec :
      forall G G' D C l l', C \In D -> l \In C ->
        L.size l = L.size l' ->
        size (G' |- remove C (cfl (L.expand l') ++ D))
        < size (G |- D).
    Proof.
      intros G0 G1 D0 C l l' HC Hl Heq.
      apply plus_lt_reg_l with (csize C 0).
      rewrite <- (size_in G1 _ C (union_3 (cfl (L.expand l')) HC)).
      unfold size; simpl.
      refine (Arith.Lt.le_lt_trans
        _ _ _ (size_union G0 _ _) _); unfold size; simpl.
      set (size_expand l').
      set (csize_in _ _ 0 Hl); unfold lsize in e. omega.
    Qed.

    (** [size] decreases when reducing a clause by a literal and expanding
       a same-sized literal at the same time *)
    Lemma size_right_unsat_dec :
      forall G G' D C l l', C \In D -> l \In C ->
        L.size l = L.size l' ->
        let Cred := C \ (singleton l) in
          size (G |- {Cred; (remove C (cfl (L.expand l') ++ D))})
          < size (G' |- D).
    Proof.
      intros G0 G1 D0 C l l' HC Hl Heq.
      case_eq (mem (diff C {l})
        (remove C (cfl (L.expand l') ++ D0))); intro Hin.
      unfold size; simpl;
        rewrite (Props.add_fold T_csize 0 (mem_2 Hin)).
      exact (size_left_unsat_dec G0 G0 D0 C l l' HC Hl Heq).
      simpl; rewrite size_add.
      apply plus_lt_reg_l with (csize C 0); rewrite plus_permute.
      rewrite <- (size_in G0 _ _ (union_3 _ HC)).
      assert (Hu := size_union G0 (cfl (L.expand l')) D0);
        unfold size in *; simpl in *.
      set (size_expand l').
      cut (csize (diff C {l}) 0+L.size l = csize C 0).
      intros; rewrite Heq in *; omega.
      revert Hl; clear; intro Hl.
      rewrite (csize_in _ _ _ Hl); unfold lsize; rewrite plus_comm.
      f_equal; apply C_csize; auto.
      symmetry; exact (Props.remove_diff_singleton C l).
      intro abs; rewrite (mem_1 abs) in Hin; discriminate.
    Qed.

  End Measure.

  (** In addition to [wf_context], the current context and the
     returned model must be consistent with literals' expansion.
     It is expressed in a different manner for the context and the
     counter model. *)
  Definition sat_clause_e (M : E.t) (C : clause) :=
    exists l, M |= l /\ l \In C.
  Definition sat_goal_e (M : E.t) (D : cset) :=
    forall C, C \In D -> sat_clause_e M C.

  Definition wf_expand (S : sequent) : Prop :=
    forall M, dom (G S) [<=] dom M -> sat_goal_e M (D S) ->
      forall l, G S |= l -> sat_goal_e M (cfl (L.expand l)).
  Definition model_expand (M : E.t) : Prop :=
    forall l, M |= l -> sat_goal_e M (cfl (L.expand l)).

  (** A quick lemma : [cfl (L.expand .)] is a morphism for literal equality *)
  Lemma cfl_expand_m : forall (l l' : L.t),
      l === l' -> (cfl (L.expand l)) [=] (cfl (L.expand l')).
  Proof.
    intros l l' Heq.
    assert (Hleq := L.expand_compat l l' Heq).
    revert Hleq; generalize (L.expand l'); generalize (L.expand l).
    clear; induction l; intro l'; destruct l'; intro Hleq; inversion Hleq.
    reflexivity.
    subst; rewrite 2!cfl_1; simpl.
    assert (R := IHl l' H4); clear IHl.
    apply add_m.
    revert H2; clear; revert l0.
    induction a; intro a'; destruct a'; intro Hleq; inversion Hleq; simpl.
    reflexivity.
    subst; apply add_m. assumption. apply IHa; auto.
    rewrite 2!cfl_1 in R; exact R.
  Qed.

  (** We finally reach the wanted theorem about [proof_search].
     When it returns [Sat M], the proof search function should return a
     correct counter-model [M]. This proof also ensures that the abortion
     case (n=0) is never reached, ie. that our measure is adequate. This
     means that it is big enough at the start, and strictly decreases
     at each recursive call. *)
  Theorem proof_search_sat :
    forall n S M,
      size S < n -> wf_context (dom (G S)) -> wf_expand S ->
      proof_search S n = Sat M ->
      wf_context (dom M) /\ model_expand M /\
      dom (G S) [<=] dom M /\ sat_goal_e M (D S).
  Proof with (eauto with typeclass_instances).
    intro n; induction n; intros S M Hm Hwf Hexp; unfold proof_search.
    (** - Case n = 0 is absurd *)
    contradiction (lt_n_O _ Hm).

    fold proof_search; destruct S; simpl in * |- *.
    case_eq (is_empty D0); intro empty_goal.
    (** - If the problem is empty, we have found a partial model *)
    rewrite <- is_empty_iff in empty_goal.
    intros X; inversion X; subst.
    refine (conj Hwf (conj _ (conj (fun x Hx => Hx) _))).
    refine (Hexp M (@Subset_refl _ _ _ _ (dom M)) _)...
    intros C HC; contradiction (empty_goal C HC).
    intros C HC; contradiction (empty_goal C HC).

    case_eq (find is_empty D0); [| intro empty_clause].
    intros; discriminate.
    case_eq (find (eliminable G0) D0).
    (** - The next step is to try some BCP, first Elim ... *)
    intros C HC; pose (HC1 := find_1 HC); pose (HC2 := find_2 HC).
    destruct (EProps.exists_mem_4 (s:=C) HC2) as [l [HCl Hl]].
    intro IH; destruct (IHn (G0 |- remove C D0) M)
      as [Mwf [Mexp [Msub Msat]]].
    apply lt_S_n; refine (Arith.Lt.le_lt_trans _ _ _ (lt_le_S _ _ _) Hm).
    exact (size_elim_dec G0 G0 D0 C l HC1 (mem_2 HCl)).
    exact Hwf.
    intros m Hm1 Hm2; apply (Hexp m Hm1).
    intros C' HC'; case_eq (equal C C'); intro Heq.
    rewrite <- equal_iff in Heq.
    exists l; split; [exact (query_monotonic Hm1 Hl) |].
    rewrite <- Heq; exact (mem_2 HCl).
    refine (Hm2 C' (remove_2 _ HC'))...
    intro abs; rewrite (equal_1 abs) in Heq; discriminate.
    exact IH.
    refine (conj Mwf (conj Mexp (conj Msub _))).
    intros C' HC'; case_eq (equal C C'); intro Heq.
    rewrite <- equal_iff in Heq.
    exists l; split; [exact (query_monotonic Msub Hl) |].
    rewrite <- Heq; exact (mem_2 HCl).
    refine (Msat C' (remove_2 _ HC'))...
    intro abs; rewrite (equal_1 abs) in Heq; discriminate.

    intro elim; case_eq (find (reducible G0) D0).
    (** - and then Red *)
    intros C HC; pose (HC1 := find_1 HC); pose (HC2 := find_2 HC).
    destruct (EProps.exists_mem_4 (s:=C) HC2) as [k [HCk Hk]].
    case_eq (choose (filter (fun l => query (L.mk_not l) G0) C)); [|intro abs].
    intros l Hl.
    pose (Hl1 := filter_1 (choose_1 Hl)).
    pose (Hl2 := filter_2 (choose_1 Hl)).
    assert (Hrew := Props.remove_diff_singleton C l).
    2:(contradiction ((choose_2 abs) k
      (filter_3 (H1:=compat_mem2 G0) (mem_2 HCk) Hk))).
    simpl in Hl2; intro IH; destruct (IHn (G0 |- add (diff C
      (singleton l)) (remove C D0)) M) as [Mwf [Mexp [Msub Msat]]].
    assert (Rew : {C \ singleton l; {D0 ~ C}} ===  {{C ~ l}; {D0 ~ C}}).
    rewrite Hrew; reflexivity.
    rewrite (size_m G0 G0 _ _ Rew).
    apply lt_S_n; refine (Arith.Lt.le_lt_trans _ _ _ (lt_le_S _ _ _) Hm).
    exact (size_red_dec G0 D0 C l HC1 Hl1).
    exact Hwf.
    intros m Hm1 Hm2; apply (Hexp m Hm1).
    intros C' HC'; case_eq (equal C C'); intro Heq.
    rewrite <- equal_iff in Heq.
    destruct (Hm2 {C ~ l}); try (apply add_1; symmetry; auto).
    exists x; split; [exact (proj1 H) |].
    rewrite <- Heq; exact (remove_3 (proj2 H)).
    refine (Hm2 C' (add_2 _ (remove_2 _ HC')))...
    intro abs; rewrite (equal_1 abs) in Heq; discriminate.
    exact IH.
    refine (conj Mwf (conj Mexp (conj Msub _))).
    intros C' HC'; case_eq (equal C C'); intro Heq.
    rewrite <- equal_iff in Heq.
    destruct (Msat {C ~ l}); try (apply add_1; symmetry; auto).
    exists x; split; [exact (proj1 H) |].
    rewrite <- Heq; exact (remove_3 (proj2 H)).
    refine (Msat C' (add_2 _ (remove_2 _ HC')))...
    intro abs; rewrite (equal_1 abs) in Heq; discriminate.

    (** Since we did all the BCP, we now know l and mk_not l are fresh for G
       as soon as l appears in D. This invariant guarantees that G will
       remain well-formed. *)
    intro red.
    assert (fresh1 : forall C0 l, In C0 D0 -> In l C0 -> ~ G0 |= l).
    intros C0 l HC0 Hl abs; assert (abs1 : eliminable G0 C0 = true).
    unfold eliminable; refine (EProps.exists_mem_3
      (s:=C0) (Comp := compat_mem G0) (mem_1 Hl) _)...
    rewrite (find_3 (eliminable G0) elim HC0) in abs1; discriminate.
    assert (fresh2 : forall C0 l,
      In C0 D0 -> In l C0 -> ~ G0 |= L.mk_not l).
    intros C0 l HC0 Hl abs; assert (abs2 : reducible G0 C0 = true).
    unfold eliminable; refine (EProps.exists_mem_3
      (s:=C0) (Comp := compat_mem2 G0) (mem_1 Hl) _)...
    rewrite (find_3 _ red HC0) in abs2; discriminate.
    assert (fresh_add1 : forall G1 C0 l,
      In C0 D0 -> In l C0 -> assume l G0 = Normal G1 -> wf_context (dom G1)).
    intros G1 C0 l HC0 Hl Hass a Ha Hnota; simpl in * |-;
      rewrite (assumed_assume Hass), add_iff in Ha, Hnota.
    destruct Ha; destruct Hnota.
    rewrite H in H0; exact (L.mk_not_fix a H0).
    refine (fresh2 C0 a HC0 _ (query_assumed H0)). rewrite <- H; exact Hl.
    refine (fresh2 C0 (L.mk_not a) HC0 _ _).
    rewrite <- H0; exact Hl.
    rewrite L.mk_not_invol; apply query_assumed; assumption.
    exact (Hwf a H H0).
    assert (fresh_add2 : forall G2 C0 l,
      In C0 D0 -> In l C0 -> assume (L.mk_not l) G0 = Normal G2 ->
      wf_context (dom G2)).
    intros G1 C0 l HC0 Hl Hass a Ha Hnota; simpl in * |-;
      rewrite (assumed_assume Hass), add_iff in Ha, Hnota.
    destruct Ha; destruct Hnota.
    rewrite H in H0; exact (L.mk_not_fix a H0).
    refine (fresh1 C0 (L.mk_not a) HC0 _ (query_assumed H0)).
    rewrite <- (L.mk_not_invol a) in H;
      rewrite <- (L.mk_not_compat l (L.mk_not a)) in H.
    rewrite <- H; exact Hl.
    rewrite <- (L.mk_not_compat l a) in H0; rewrite H0 in Hl.
    exact (fresh1 C0 a HC0 Hl (query_assumed H)).
    exact (Hwf a H H0).

    case_eq (find unitary D0); [|intro unit].
    (** - When all possible BCP has been done, we turn to unitary clauses *)
    intros C HC; pose (HC1 := find_1 HC); pose (HC2 := find_2 HC).
    unfold unitary in HC2; case_eq (choose C).
    2:(intro H; rewrite H in HC2; discriminate).
    intros l Hchoose;
      pose (Hl := unitary_singl HC2 (choose_1 Hchoose)).
    assert (temp : In {l} D0) by (apply In_1 with C; auto).
    case_eq (assume l G0); [intros newG Hass | intro Hass].
    intro IH; destruct (IHn (newG |-
      (union (cfl (L.expand l)) (remove {l} D0))) M)
    as [Mwf [Mexp [Msub Msat]]].
    apply lt_S_n; refine (Arith.Lt.le_lt_trans _ _ _ (lt_le_S _ _ _) Hm).
    apply size_assume_dec; auto; exact temp.
    exact (fresh_add1 newG C l HC1 (choose_1 Hchoose) Hass).
    intros m Hm1 Hm2 k Hk; case_eq (L.is_proxy k); intro Hproxy.
    simpl in Hk; assert (Hk' := query_expand Hproxy Hk);
      rewrite (assumed_assume Hass) in Hk'.
    destruct (eq_dec l k) as [e|n0].
    intros c' Hc'; apply Hm2; apply union_2.
    rewrite (cfl_expand_m l k e); assumption.
    apply (Hexp m).
    simpl in Hm1; rewrite (assumed_assume Hass) in Hm1.
    exact (fun l' Hl' => Hm1 l' (add_2 l Hl')).
    intros C' HC'; case_eq (equal (singleton l) C'); intro Heq.
    rewrite <- equal_iff in Heq.
    simpl in Hm1; rewrite (assumed_assume Hass) in Hm1.
    exists l; split; [exact (query_assumed
      (Hm1 l (add_1 (dom G0) (reflexivity l)))) |].
    rewrite <- Heq; exact (singleton_2 (reflexivity l)).
    refine (Hm2 C' (union_3 _ (remove_2 _ HC')))...
    intro abs; rewrite (equal_1 abs) in Heq; discriminate.
    apply query_assumed; apply add_3 with l; assumption.
    rewrite (L.is_proxy_nil _ Hproxy); intros C' HC';
      rewrite cfl_1 in HC'; simpl in HC'; contradiction (empty_1 HC').
    exact IH.
    refine (conj Mwf (conj Mexp (conj _ _ ))).
    simpl in Msub; rewrite (assumed_assume Hass) in Msub.
    exact (fun l' Hl' => Msub l' (add_2 l Hl')).
    intros C' HC'; case_eq (equal (singleton l) C'); intro Heq.
    rewrite <- equal_iff in Heq.
    exists l; split;
      [exact (query_monotonic Msub
        (EnvF.query_assume Hass (reflexivity l))) |].
    rewrite <- Heq; exact (singleton_2 (reflexivity l)).
    refine (Msat C' (union_3 _ (remove_2 _ HC')))...
    intro abs; rewrite (equal_1 abs) in Heq; discriminate.
    contradiction (fresh2 {l} l); intuition.
    exact (assumed_inconsistent Hass).

    (** - Now, our only alternative left is to pick any literal that
       appears in Delta and try it in an Unsat rule *)
    case_eq (pick D0).
    intros [C0 l] Hpick; destruct (pick_1 D0 C0 l Hpick) as [HC0 Hl].
    (** -- we first use the IH on the left branch if it is Sat *)
    case_eq (assume l G0); [intros G1 Hass1 | intros Hass1].
    case_eq (proof_search (G1 |-
      remove C0 (union (cfl (L.expand l)) D0)) n); intro M'.
    intros IH1 X; inversion X; subst.
    destruct (IHn (G1 |- remove C0
      (union (cfl (L.expand l)) D0)) M) as [Mwf [Mexp [Msub Msat]]].
    apply lt_S_n; refine (Arith.Lt.le_lt_trans _ _ _ (lt_le_S _ _ _) Hm).
    apply size_left_unsat_dec with l; auto.
    exact (fresh_add1 G1 C0 l HC0 Hl Hass1).
    intros m Hm1 Hm2 k Hk; case_eq (L.is_proxy k); intro Hproxy.
    simpl in Hk; assert (Hk' := query_expand Hproxy Hk);
      rewrite (assumed_assume Hass1) in Hk'.
    destruct (eq_dec l k) as [e|n0].
    intros c' Hc'; destruct (eq_dec C0 c') as [E|N].
    exists l; split.
    apply (query_monotonic Hm1); apply (EnvF.query_assume Hass1); auto.
    rewrite <- E; auto.
    apply Hm2; apply remove_2; auto.
    apply union_2; rewrite (cfl_expand_m l k e); assumption.
    apply (Hexp m).
    simpl in Hm1; rewrite (assumed_assume Hass1) in Hm1.
    exact (fun l' Hl' => Hm1 l' (add_2 l Hl')).
    intros C HC; simpl in Hm1.
    destruct (eq_dec C0 C) as [E|N].
    exists l; split.
    apply (query_monotonic Hm1); apply (EnvF.query_assume Hass1); auto.
    rewrite <- E; auto.
    apply Hm2; apply remove_2; auto. apply union_3; auto.
    simpl in Hm1; rewrite (assumed_assume Hass1) in Hm1.
    apply query_assumed; apply add_3 with l; assumption.
    rewrite (L.is_proxy_nil _ Hproxy); intros C' HC';
      rewrite cfl_1 in HC'; simpl in HC'; contradiction (empty_1 HC').
    exact IH1.
    simpl in Msub; rewrite (assumed_assume Hass1) in Msub.
    refine (conj Mwf (conj Mexp
      (conj (fun l' Hl' => Msub l' (add_2 _ Hl')) _)))...
    intros C HC; simpl in Msat; revert HC Hl Msat Msub; clear; intros.
    destruct (eq_dec C0 C) as [E|N].
    exists l; split.
    apply query_assumed; apply Msub; apply add_1; auto.
    rewrite <- E; auto.
    apply Msat; apply remove_2; auto. apply union_3; auto.
    2:contradiction (fresh2 C0 l HC0 Hl (assumed_inconsistent Hass1)).

    (** -- and then we second one *)
    case_eq (assume (L.mk_not l) G0); [intros G2 Hass2 | intros Hass2].
    intros IH2; destruct (IHn (G2 |- add (diff C0 (singleton l))
      (remove C0 (union (cfl (L.expand (L.mk_not l))) D0))) M)
    as [Mwf [Mexp [Msub Msat]]].
    apply lt_S_n; refine (Arith.Lt.le_lt_trans _ _ _ (lt_le_S _ _ _) Hm).
    apply size_right_unsat_dec; auto; rewrite L.size_mk_not; trivial.
    exact (fresh_add2 G2 C0 l HC0 Hl Hass2).
    intros m Hm1 Hm2 k Hk; case_eq (L.is_proxy k); intro Hproxy.
    simpl in Hk; assert (Hk' := query_expand Hproxy Hk);
      rewrite (assumed_assume Hass2) in Hk'.
    destruct (eq_dec (L.mk_not l) k).
    intros c' Hc'; destruct (eq_dec C0 c') as [E|N].
    destruct (Hm2 (diff C0 (singleton l))).
    apply add_1; reflexivity.
    exists x; intuition; rewrite <- E; exact (diff_1 H2).
    apply Hm2; apply add_2; apply remove_2; auto.
    apply union_2; rewrite (cfl_expand_m (L.mk_not l) k); assumption.
    apply (Hexp m).
    simpl in *; rewrite (assumed_assume Hass2) in Hm1.
    exact (fun l' Hl' => Hm1 l' (add_2 (L.mk_not l) Hl')).
    intros C HC; simpl in Hm2; revert HC Hl Hm2 Hm1; clear; intros.
    destruct (eq_dec C0 C) as [E|N].
    destruct (Hm2 (diff C0 (singleton l))); auto with set.
    apply add_1; auto.
    exists x; intuition; rewrite <- E; exact (diff_1 H1).
    apply Hm2; apply add_2; apply remove_2; auto.
    apply union_3; auto.
    apply query_assumed; apply add_3 with (L.mk_not l); assumption.
    rewrite (L.is_proxy_nil _ Hproxy); intros C' HC';
      rewrite cfl_1 in HC'; simpl in HC'; contradiction (empty_1 HC').
    exact IH2.
    simpl in Msub; rewrite (assumed_assume Hass2) in Msub.
    refine (conj Mwf (conj Mexp
      (conj (fun l' Hl' => Msub l' (add_2 _ Hl')) _)))...
    intros C HC; simpl in Msat; revert HC Hl Msat Msub; clear; intros.
    destruct (eq_dec C0 C) as [E|N].
    destruct (Msat (diff C0 (singleton l))); auto with set.
    apply add_1; auto.
    exists x; intuition; rewrite <- E; exact (diff_1 H1).
    apply Msat; apply add_2; apply remove_2; auto.
    apply union_3; auto.
    assert (Z := assumed_inconsistent Hass2).
    rewrite L.mk_not_invol in Z.
    contradiction (fresh1 C0 l HC0 Hl Z).

    (** There remain cases where we were unable to pick a literal, but
       this means the problem is empty or all clauses are empty, which
       has already been treated before. *)
    intro abs; cut (Empty D0).
    intro P; rewrite is_empty_iff in P;
      rewrite P in empty_goal; discriminate.
    refine (pick_2 D0 (fun C HC Hemp => _) abs).
    rewrite is_empty_iff in Hemp.
    rewrite (find_3 _ empty_clause HC) in Hemp.
    discriminate.
  Qed.

  (** ** The main entry point to the SAT-solver

     We can now define a function that takes a [formula], builds
     a sequent with an empty partial assignment out of it, and
     applies [proof_search] to try and find a derivation for this
     sequent. It uses our measure in order to pass a suitable
     bound at the start.
     This function [dpll] is correct as a consequence the correctness
     of [proof_search] and of the derivation system. It is a decision
     procedure for the satisfiability of [formula]s.
     *)
  Definition dpll (Pb : formula) :=
    let S := empty |- make Pb in
      let mu := Datatypes.S (size S) in
        proof_search S mu.
  Lemma dpll_correct :
    forall Pb, dpll Pb = Unsat -> Sem.incompatible {} (make Pb).
  Proof.
    intros Pb Hunsat; unfold dpll in Hunsat.
    intros M HM; apply (soundness (empty |- make Pb)).
    exact (proof_search_unsat _ _ Hunsat).
    simpl; intros l; rewrite assumed_empty; set_iff; intro Hl.
    rewrite <- (Sem.morphism _ _ _ Hl); apply Sem.wf_true.
  Qed.

(*   (** ** Completion *)

(*      Using the completion implemented in the [SemFacts], we can complete *)
(*      a partial model as returned by [proof_search] in a total model (due *)
(*      to expansion of literals, this is not a trivial proof, cf. [SemFacts]. *)
(*      Together with [dpll_correct], this means that [dpll] is a correct *)
(*      and complete decision procedure. *)

(*      Note that completeness is not used when using [dpll] to prove *)
(*      things by reflection. It is satsifactory nonetheless to be able *)
(*      to prove this completeness result. *) *)
(*   Fact wf_empty : wf_context (dom empty). *)
(*   Proof. *)
(*     unfold wf_context; intros l Hl Hnotl. *)
(*     apply (query_consistent (query_assumed Hl) (query_assumed Hnotl)). *)
(*   Qed. *)
(*   Fact wexp_empty : *)
(*     forall Pb, wf_expand (empty |- make Pb). *)
(*   Proof. *)
(*     intros Pb M Hm1 Hm2 l Hl; simpl in *. *)
(*     intros c Hc; rewrite cfl_1 in Hc; simpl in Hc. *)
(*     case_eq (L.is_proxy l); intro Hproxy. *)
(*     assert (Hl' := query_expand Hproxy Hl). *)
(*     rewrite assumed_empty, singleton_iff in Hl'. *)
(*     rewrite <- Hl', L.is_proxy_true in Hproxy; discriminate. *)
(*     rewrite (L.is_proxy_nil _ Hproxy) in Hc; simpl in Hc. *)
(*     contradiction (empty_1 Hc). *)
(*   Qed. *)

(*   (** We reformulate the constraint on M and expansion of literals *) *)
(*   Lemma model_expand_1 : *)
(*     forall M, model_expand M -> *)
(*       (forall l, M |= l -> *)
(*         (forall c, List.In c (L.expand l) -> *)
(*           exists y, List.In y c /\ M |= y)). *)
(*   Proof. *)
(*     intros M Mexp l Hl; generalize (Mexp l Hl); clear; unfold model_expand. *)
(*     generalize (L.expand l); clear; induction l; intro Hsat. *)
(*     intros c Hc; contradiction Hc. *)
(*     intros c [Ha|Hc]; subst; *)
(*       set (C := fold_right add ({} : clause) c); *)
(*         assert (Hsat'  := Hsat C); rewrite cfl_1 in Hsat'; simpl in Hsat'. *)
(*     fold C in Hsat'; destruct Hsat' as [x Hx]. apply add_1; auto. *)
(*     revert Hx; clear; induction c. *)
(*     simpl in C; unfold C; intros [_ abs]; *)
(*       contradiction (empty_1 abs). *)
(*     simpl in C; unfold C; set_iff; intuition. *)
(*     exists a; intuition. rewrite H; exact H0. *)
(*     destruct IHc as [y Hy]. intuition. *)
(*     exists y; intuition. *)
(*     apply IHl; auto. *)
(*     intros d Hd; apply Hsat; rewrite cfl_1 in Hd |- *; simpl. *)
(*     apply add_2; assumption. *)
(*   Qed. *)
(*   Remark model_expand_2 : *)
(*     forall M, model_expand M -> *)
(*       (forall l, l \In dom M -> *)
(*         (forall c, List.In c (L.expand l) -> *)
(*           exists y, List.In y c /\ M |= y)). *)
(*   Proof. *)
(*     intros; apply model_expand_1 with l; auto. *)
(*   Qed. *)

(*   Theorem dpll_dec (Pb : formula) : *)
(*     { incompatible (empty |- make Pb) } + *)
(*     { ~ incompatible (empty |- make Pb) }. *)
(*   Proof. *)
(*     intro Pb; case_eq (dpll Pb); unfold dpll. *)
(*     intros M Hsat; destruct (proof_search_sat *)
(*       (S (size (empty |- make Pb))) (empty |- make Pb) M *)
(*       (lt_n_Sn _) wf_empty (wexp_empty Pb) Hsat) *)
(*     as [Mwf [Mexp [Msub Msat]]]. *)

(*     (** Case where [proof_search] returns [Sat M] : *)
(*        We show that [completion M] is a model of our problem. *) *)
(*     assert (Mtrue : L.ltrue \In (dom M)) by *)
(*       (apply Msub; simpl; rewrite assumed_empty; apply singleton_2; auto). *)
(*     set (Model := @E.completion_model M Mwf Mtrue (model_expand_2 _ Mexp)). *)
(*     pose (Hsub := SemF.submodel_empty Model). *)
(*     right; intro Hincomp; apply (Hincomp Model). *)
(*     simpl; intro; rewrite assumed_empty; set_iff; intro Hl. *)
(*     rewrite <- (Sem.morphism _ _ _ Hl); apply Sem.wf_true. *)
(*     intros C HC; destruct (Msat C HC) as [l [Hl Hl']]. *)
(*     exists l; split; [ | exact Hl']. *)
(*     apply completion_extends; auto. *)

(*     (** Case where [proof_search] returns [Unsat] : trivial *)
(*        because derivability implies incompatibilty. *) *)
(*     intro Hsat; left; assert (H:=soundness _ (proof_search_unsat _ _ Hsat)). *)
(*     intros M HM; apply (H M); simpl; intros k. *)
(*     rewrite assumed_empty; set_iff; intro Hk. *)
(*     rewrite <- (Sem.morphism _ _ _ Hk); apply Sem.wf_true. *)
(*   Qed. *)

(*   (** A propositional version of completeness *) *)
(*   Lemma complete_model : *)
(*     forall (S : sequent) (M : E.t), *)
(*       wf_context (dom M) -> model_expand M -> *)
(*       dom (G S) [<=] dom M -> L.ltrue \In dom M -> *)
(*       sat_goal_e M (D S) -> *)
(*       {Mf : Sem.model | Sem.submodel (dom (G S)) Mf /\ Sem.sat_goal Mf (D S)}. *)
(*   Proof. *)
(*     intros S M Hwf Hwe Hsub Htrue Hsat. *)
(*     unfold model_expand in Hwe. *)
(*     pose (Model := @E.completion_model M Hwf Htrue (model_expand_2 M Hwe)). *)
(*     exists Model; split. *)
(*     intros l Hl; unfold Model; apply completion_extends. *)
(*     apply query_assumed; apply Hsub; auto. *)
(*     intros C HC; destruct (Hsat C HC) as [x [Hx1 Hx2]]; exists x; intuition. *)
(*     unfold Model; apply completion_extends; auto. *)
(*   Qed. *)

(*   Corollary completeness : *)
(*     forall S, *)
(*       wf_context (dom (G S)) -> wf_expand S -> L.ltrue \In dom (G S) -> *)
(*       incompatible S -> derivable S. *)
(*   Proof. *)
(*     intros S Hwf Hwe Htrue; case_eq (proof_search S (Datatypes.S (size S))). *)
(*     intros M HM Hinc. *)
(*     assert (wf_context (dom M) /\ model_expand M /\ *)
(*       dom (G S) [<=] dom M /\ sat_goal_e M (D S)). *)
(*     refine (proof_search_sat _ _ _ _ _ _ HM); auto. *)
(*     destruct H as [H1 [H2 [H3 H4]]]; *)
(*       destruct (complete_model _ M H1 H2 H3 (H3 _ Htrue) H4) as [Mf [Mf1 Mf2]]. *)
(*     contradiction (Hinc Mf Mf1 Mf2). *)
(*     intros Hunsat _; exact (proof_search_unsat _ _ Hunsat). *)
(*   Qed. *)
End SAT.


(* Notations for easy dependently typed programming --- these are defined in CPDT book*)

Set Implicit Arguments.

(* notations for subset types -- sig types *)

Notation "!" := (False_rec _ _).
Notation "[ e ]" := (exist _ e _).

(* notations for sumbool types *)

Notation "'Yes'" := (left _ _).
Notation "'No'" := (right _ _).
Notation "'Reduce' x" := (if x then Yes else No) (at level 50).
Notation "x || y" := (if x then Yes else Reduce y).

(* notations for sumor *)

Notation "!!" := (inright _ _).
Notation "[|| x ||]" := (inleft _ [x]).

Notation "x <-- e1 ; e2" := (match e1 with
                               | inright _ => !!
                               | inleft (exist _ x _) => e2
                             end)
                             (right associativity, at level 60).

Notation "e1 ;;; e2" := (if e1 then e2 else !!)
                          (right associativity, at level 60).

(* partial subset types *)

Inductive Maybe (A : Type) (P : A -> Type) : Type :=
| Unknown : Maybe P
| Found : forall x : A, P x -> Maybe P.

Notation "{{ x | P }}" := (Maybe (fun x => P)).
Notation "??" := (Unknown _).
Notation "[| x |]" := (Found _ x _).


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
Copyright (C) 2010-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Helper functions and theorems for computing the rounded square root of a floating-point number. *)

Require Import Raux Defs Digits Generic_fmt Float_prop Bracket.

Set Implicit Arguments.
Set Strongly Strict Implicit.

Section Fcalc_sqrt.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.

(** Computes a mantissa of precision p, the corresponding exponent,
    and the position with respect to the real square root of the
    input floating-point number.

The algorithm performs the following steps:
- Shift the mantissa so that it has at least 2p-1 digits;
  shift it one digit more if the new exponent is not even.
- Compute the square root s (at least p digits) of the new
  mantissa, and its remainder r.
- Compute the position according to the remainder:
  -- r == 0  =>  Eq,
  -- r <= s  =>  Lo,
  -- r >= s  =>  Up.

Complexity is fine as long as p1 <= 2p-1.
*)

Lemma mag_sqrt_F2R :
  forall m1 e1,
  (0 < m1)%Z ->
  mag beta (sqrt (F2R (Float beta m1 e1))) = Z.div2 (Zdigits beta m1 + e1 + 1) :> Z.
Proof.
intros m1 e1 Hm1.
rewrite <- (mag_F2R_Zdigits beta m1 e1) by now apply Zgt_not_eq.
apply mag_sqrt.
now apply F2R_gt_0.
Qed.

Definition Fsqrt_core m1 e1 e :=
  let d1 := Zdigits beta m1 in
  let m1' := (m1 * Zpower beta (e1 - 2 * e))%Z in
  let (q, r) := Z.sqrtrem m1' in
  let l :=
    if Zeq_bool r 0 then loc_Exact
    else loc_Inexact (if Zle_bool r q then Lt else Gt) in
  (q, l).

Theorem Fsqrt_core_correct :
  forall m1 e1 e,
  (0 < m1)%Z ->
  (2 * e <= e1)%Z ->
  let '(m, l) := Fsqrt_core m1 e1 e in
  inbetween_float beta m e (sqrt (F2R (Float beta m1 e1))) l.
Proof.
intros m1 e1 e Hm1 He.
unfold Fsqrt_core.
set (m' := Zmult _ _).
assert (0 <= m')%Z as Hm'.
{ apply Z.mul_nonneg_nonneg.
  now apply Zlt_le_weak.
  apply Zpower_ge_0. }
assert (sqrt (F2R (Float beta m1 e1)) = sqrt (IZR m') * bpow e)%R as Hf.
{ rewrite <- (sqrt_Rsqr (bpow e)) by apply bpow_ge_0.
  rewrite <- sqrt_mult.
  unfold Rsqr, m'.
  rewrite mult_IZR, IZR_Zpower by omega.
  rewrite Rmult_assoc, <- 2!bpow_plus.
  now replace (_ + _)%Z with e1 by ring.
  now apply IZR_le.
  apply Rle_0_sqr. }
generalize (Z.sqrtrem_spec m' Hm').
destruct Z.sqrtrem as [q r].
intros [Hq Hr].
rewrite Hf.
unfold inbetween_float, F2R. simpl Fnum.
apply inbetween_mult_compat.
apply bpow_gt_0.
rewrite Hq.
case Zeq_bool_spec ; intros Hr'.
(* .. r = 0 *)
rewrite Hr', Zplus_0_r, mult_IZR.
fold (Rsqr (IZR q)).
rewrite sqrt_Rsqr.
now constructor.
apply IZR_le.
clear -Hr ; omega.
(* .. r <> 0 *)
constructor.
split.
(* ... bounds *)
apply Rle_lt_trans with (sqrt (IZR (q * q))).
rewrite mult_IZR.
fold (Rsqr (IZR q)).
rewrite sqrt_Rsqr.
apply Rle_refl.
apply IZR_le.
clear -Hr ; omega.
apply sqrt_lt_1.
rewrite mult_IZR.
apply Rle_0_sqr.
rewrite <- Hq.
now apply IZR_le.
apply IZR_lt.
omega.
apply Rlt_le_trans with (sqrt (IZR ((q + 1) * (q + 1)))).
apply sqrt_lt_1.
rewrite <- Hq.
now apply IZR_le.
rewrite mult_IZR.
apply Rle_0_sqr.
apply IZR_lt.
ring_simplify.
omega.
rewrite mult_IZR.
fold (Rsqr (IZR (q + 1))).
rewrite sqrt_Rsqr.
apply Rle_refl.
apply IZR_le.
clear -Hr ; omega.
(* ... location *)
rewrite Rcompare_half_r.
generalize (Rcompare_sqr (2 * sqrt (IZR (q * q + r))) (IZR q + IZR (q + 1))).
rewrite 2!Rabs_pos_eq.
intros <-.
replace ((2 * sqrt (IZR (q * q + r))) * (2 * sqrt (IZR (q * q + r))))%R
  with (4 * Rsqr (sqrt (IZR (q * q + r))))%R by (unfold Rsqr ; ring).
rewrite Rsqr_sqrt.
rewrite <- plus_IZR, <- 2!mult_IZR.
rewrite Rcompare_IZR.
replace ((q + (q + 1)) * (q + (q + 1)))%Z with (4 * (q * q) + 4 * q + 1)%Z by ring.
generalize (Zle_cases r q).
case (Zle_bool r q) ; intros Hr''.
change (4 * (q * q + r) < 4 * (q * q) + 4 * q + 1)%Z.
omega.
change (4 * (q * q + r) > 4 * (q * q) + 4 * q + 1)%Z.
omega.
rewrite <- Hq.
now apply IZR_le.
rewrite <- plus_IZR.
apply IZR_le.
clear -Hr ; omega.
apply Rmult_le_pos.
now apply IZR_le.
apply sqrt_ge_0.
Qed.

Definition Fsqrt (x : float beta) :=
  let (m1, e1) := x in
  let e' := (Zdigits beta m1 + e1 + 1)%Z in
  let e := Z.min (fexp (Z.div2 e')) (Z.div2 e1) in
  let '(m, l) := Fsqrt_core m1 e1 e in
  (m, e, l).

Theorem Fsqrt_correct :
  forall x,
  (0 < F2R x)%R ->
  let '(m, e, l) := Fsqrt x in
  (e <= cexp beta fexp (sqrt (F2R x)))%Z /\
  inbetween_float beta m e (sqrt (F2R x)) l.
Proof.
intros [m1 e1] Hm1.
apply gt_0_F2R in Hm1.
unfold Fsqrt.
set (e := Z.min _ _).
assert (2 * e <= e1)%Z as He.
{ assert (e <= Z.div2 e1)%Z by apply Z.le_min_r.
  rewrite (Zdiv2_odd_eqn e1).
  destruct Z.odd ; omega. }
generalize (Fsqrt_core_correct m1 e1 e Hm1 He).
destruct Fsqrt_core as [m l].
apply conj.
apply Z.le_trans with (1 := Z.le_min_l _ _).
unfold cexp.
rewrite (mag_sqrt_F2R m1 e1 Hm1).
apply Z.le_refl.
Qed.

End Fcalc_sqrt.