(** Concurrent bag specification from the HOCAP paper.
    "Modular Reasoning about Separation of Concurrent Data Structures"
    <http://www.kasv.dk/articles/hocap-ext.pdf>

Fine-grained implementation of a bag
*)
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.proofmode Require Import proofmode.
From iris.heap_lang Require Import proofmode notation.
From iris.algebra Require Import cmra agree frac.
From iris.heap_lang.lib Require Import lock spin_lock.
From iris_examples.hocap Require Import abstract_bag.
From iris.prelude Require Import options.

(** Fine-grained bag implementation using CAS *)
Definition newBag : val := λ: <>,
  ref NONE.
Definition pushBag : val := rec: "push" "b" "v" :=
  let: "oHead" := !"b" in
  if: CAS "b" "oHead" (SOME (ref ("v", "oHead")))
  then #()
  else "push" "b" "v".

Definition popBag : val := rec: "pop" "b" :=
  match: !"b" with
    NONE => NONE
  | SOME "l" =>
    let: "hd" := !"l" in
    let: "v" := Fst "hd" in
    let: "tl" := Snd "hd" in
    if: CAS "b" (SOME "l") "tl"
    then SOME "v"
    else "pop" "b"
  end.

Canonical Structure valmultisetO := leibnizO (gmultiset valO).
Class bagG Σ := BagG
{ bag_bagG :> inG Σ (prodR fracR (agreeR valmultisetO));
}.

(** Generic specification for the bag, using view shifts. *)
Section proof.
  Context `{heapGS Σ, bagG Σ}.
  Variable N : namespace.

  Definition oloc_to_val (ol: option loc) : val :=
    match ol with
    | None => NONEV
    | Some loc => SOMEV (#loc)
    end.
  Local Instance oloc_to_val_inj : Inj (=) (=) oloc_to_val.
  Proof. intros [|][|]; simpl; congruence. Qed.

  Fixpoint is_list (hd : option loc) (xs : list val) : iProp Σ :=
    match xs, hd with
    | [], None => True
    | x::xs, Some l => ∃ (tl : option loc),
                   l ↦□ (x, oloc_to_val tl) ∗ is_list tl xs
    | _, _ => False
    end%I.

  Lemma is_list_duplicate hd xs : is_list hd xs -∗ is_list hd xs ∗ is_list hd xs.
  Proof.
    iInduction xs as [ | x xs ] "IH" forall (hd); simpl; eauto.
    destruct hd; last by auto.
    iDestruct 1 as (tl) "[#Hro Htl]".
    iDestruct ("IH" with "Htl") as "[Htl Htl']".
    iSplitL "Hro Htl"; iExists _; iFrame; eauto.
  Qed.

  Lemma is_list_agree hd xs ys : is_list hd xs -∗ is_list hd ys -∗ ⌜xs = ys⌝.
  Proof.
    iInduction xs as [ | x xs ] "IH" forall (hd ys); simpl; eauto.
    - destruct hd; first by auto.
      destruct ys; eauto.
    - destruct hd; last by auto.
      destruct ys as [| y ys]; eauto. simpl.
      iDestruct 1 as (tl) "(Hro & Hls)".
      iDestruct 1 as (tl') "(Hro' & Hls')".
      iDestruct (mapsto_agree with "Hro Hro'") as %?; simplify_eq/=.
      iDestruct ("IH" with "Hls Hls'") as %->. done.
  Qed.

  Definition bag_inv (γb : gname) (b : loc) : iProp Σ :=
    (∃ (hd : option loc) (ls : list val),
        b ↦ oloc_to_val hd ∗ is_list hd ls ∗ own γb ((1/2)%Qp, to_agree (list_to_set_disj ls)))%I.
  Definition is_bag (γb : gname) (x : val) :=
    (∃ (b : loc), ⌜x = #b⌝ ∗ inv N (bag_inv γb b))%I.
  Definition bag_contents (γb : gname) (X : gmultiset val) : iProp Σ :=
    own γb ((1/2)%Qp, to_agree X).

  Global Instance is_bag_persistent γb x : Persistent (is_bag γb x).
  Proof. apply _. Qed.
  Global Instance bag_contents_timeless γb X : Timeless (bag_contents γb X).
  Proof. apply _. Qed.

  Lemma bag_contents_agree γb X Y :
    bag_contents γb X -∗ bag_contents γb Y -∗ ⌜X = Y⌝.
  Proof.
    rewrite /bag_contents. apply bi.wand_intro_r.
    rewrite -own_op own_valid uPred.discrete_valid.
    f_equiv=> /=. rewrite -pair_op.
    by intros [_ ?%to_agree_op_inv_L].
  Qed.

  Lemma bag_contents_update γb X X' Y :
    bag_contents γb X ∗ bag_contents γb X' ==∗ bag_contents γb Y ∗ bag_contents γb Y.
  Proof.
    iIntros "[Hb1 Hb2]".
    iDestruct (bag_contents_agree with "Hb1 Hb2") as %<-.
    iMod (own_update_2 with "Hb1 Hb2") as "Hb".
    { rewrite -pair_op frac_op.
      assert ((1 / 2 + 1 / 2)%Qp = 1%Qp) as -> by apply Qp_div_2.
      by apply (cmra_update_exclusive (1%Qp, to_agree Y)). }
    iDestruct "Hb" as "[Hb1 Hb2]".
    rewrite /bag_contents. by iFrame.
  Qed.

  Lemma newBag_spec :
    {{{ True }}}
      newBag #()
    {{{ x γ, RET x; is_bag γ x ∗ bag_contents γ ∅ }}}.
  Proof.
    iIntros (Φ) "_ HΦ".
    unfold newBag. wp_rec.
    wp_alloc r as "Hr".
    iMod (own_alloc (1%Qp, to_agree ∅)) as (γb) "[Ha Hf]"; first done.
    iMod (inv_alloc N _ (bag_inv γb r) with "[Ha Hr]") as "#Hinv".
    { iNext. iExists None,[]. simpl. iFrame. }
    iModIntro. iApply "HΦ".
    rewrite /is_bag /bag_contents. iFrame.
    iExists _. by iFrame "Hinv".
  Qed.

  Lemma pushBag_spec (P Q : iProp Σ) γ (x v : val)  :
    □ (∀ (X : gmultiset val), bag_contents γ X ∗ P
                     ={⊤∖↑N}=∗ ▷ (bag_contents γ ({[+ v +]} ⊎ X) ∗ Q)) -∗
    {{{ is_bag γ x ∗ P }}}
      pushBag x (of_val v)
    {{{ RET #(); Q }}}.
  Proof.
    iIntros "#Hvs".
    iIntros (Φ). iModIntro. iIntros "[#Hbag HP] HΦ".
    unfold pushBag.
    iLöb as "IH". wp_rec. wp_pures.
    rewrite /is_bag.
    iDestruct "Hbag" as (b) "[% #Hinv]"; simplify_eq/=.
    wp_bind (! #b)%E.
    iInv N as (o ls) "[Ho [Hls >Hb]]" "Hcl".
    wp_load.
    iMod ("Hcl" with "[Ho Hls Hb]") as "_".
    { iNext. iExists _,_. iFrame. } clear ls.
    iModIntro.
    wp_alloc n as "Hn".
    wp_pures. wp_bind (CmpXchg _ _ _).
    iInv N as (o' ls) "[Ho [Hls >Hb]]" "Hcl".
    destruct (decide (o = o')) as [->|?].
    - wp_cmpxchg_suc. { destruct o'; left; done. }
      iMod (mapsto_persist with "Hn") as "#Hn".
      iMod ("Hvs" with "[$Hb $HP]") as "[Hb HQ]".
      iMod ("Hcl" with "[Ho Hn Hls Hb]") as "_".
      { iNext. iExists (Some _),(v::ls). iFrame "Ho Hb".
        simpl. iExists _. by iFrame. }
      iModIntro. wp_pures. by iApply "HΦ".
    - wp_cmpxchg_fail.
      { destruct o, o'; simpl; congruence. }
      { destruct o'; left; done. }
      iMod ("Hcl" with "[Ho Hls Hb]") as "_".
      { iNext. iExists _,ls. by iFrame "Ho Hb". }
      iModIntro. wp_proj. wp_if.
      by iApply ("IH" with "HP [HΦ]").
  Qed.

  Lemma popBag_spec (P : iProp Σ) (Q : val → iProp Σ) γ x :
    □ (∀ (X : gmultiset val) (y : val),
               bag_contents γ ({[+ y +]} ⊎ X) ∗ P
               ={⊤∖↑N}=∗ ▷ (bag_contents γ X ∗ Q (SOMEV y))) -∗
    □ (bag_contents γ ∅ ∗ P ={⊤∖↑N}=∗ ▷ (bag_contents γ ∅ ∗ Q NONEV)) -∗
    {{{ is_bag γ x ∗ P }}}
      popBag x
    {{{ v, RET v; Q v }}}.
  Proof.
    iIntros "#Hvs1 #Hvs2".
    iIntros (Φ). iModIntro. iIntros "[#Hbag HP] HΦ".
    unfold popBag.
    iLöb as "IH". wp_rec.
    rewrite /is_bag.
    iDestruct "Hbag" as (b) "[% #Hinv]"; simplify_eq/=.
    wp_bind (!#b)%E.
    iInv N as (o ls) "[Ho [Hls >Hb]]" "Hcl".
    wp_load.
    destruct ls as [|x ls]; simpl.
    - destruct o; first done.
      iMod ("Hvs2" with "[$Hb $HP]") as "[Hb HQ]".
      iMod ("Hcl" with "[Ho Hb]") as "_".
      { iNext. iExists _,[]. by iFrame. }
      iModIntro. repeat wp_pure _.
      by iApply "HΦ".
    - destruct o as [hd|]; last done.
      iDestruct "Hls" as (tl) "[#Hhd Hls]"; simplify_eq/=.
      rewrite is_list_duplicate. iDestruct "Hls" as "[Hls Hls']".
      iMod ("Hcl" with "[Ho Hb Hhd Hls]") as "_".
      { iNext. iExists (Some _),(x::ls). simpl; iFrame; eauto. }
      iModIntro. repeat wp_pure _.
      wp_load. wp_pures.
      wp_bind (CmpXchg _ _ _).
      iInv N as (o' ls') "[Ho [Hls >Hb]]" "Hcl".
      destruct (decide (o' = (Some hd))) as [->|?].
      + wp_cmpxchg_suc.
        (* The list is still the same *)
        rewrite (is_list_duplicate tl). iDestruct "Hls'" as "[Hls' Htl]".
        iAssert (is_list (Some hd) (x::ls)) with "[Hhd Hls']" as "Hls'".
        { simpl. iExists tl. by iFrame. }
        iDestruct (is_list_agree with "Hls Hls'") as %?. simplify_eq.
        iClear "Hls'".
        iDestruct "Hls" as (tl') "(Hro' & Htl')".
        iMod ("Hvs1" with "[$Hb $HP]") as "[Hb HQ]".
        iMod ("Hcl" with "[Ho Htl Hb]") as "_".
        { iNext. iExists _,ls. by iFrame "Ho Hb". }
        iModIntro. wp_pures. by iApply "HΦ".
      + wp_cmpxchg_fail. { destruct o'; simpl; congruence. }
        iMod ("Hcl" with "[Ho Hls Hb]") as "_".
        { iNext. iExists _,ls'. by iFrame "Ho Hb". }
        iModIntro. wp_proj. wp_if.
        by iApply ("IH" with "HP [HΦ]").
  Qed.
End proof.

Typeclasses Opaque bag_contents is_bag.

Definition cg_bag `{!heapGS Σ, !bagG Σ} : bag Σ :=
  {| abstract_bag.is_bag := is_bag;
     abstract_bag.is_bag_persistent := is_bag_persistent;
     abstract_bag.bag_contents_timeless := bag_contents_timeless;
     abstract_bag.bag_contents_agree := bag_contents_agree;
     abstract_bag.bag_contents_update := bag_contents_update;
     abstract_bag.newBag_spec := newBag_spec;
     abstract_bag.pushBag_spec := pushBag_spec;
     abstract_bag.popBag_spec := popBag_spec |}.


From Fiat.Narcissus Require Import Examples.TutorialPrelude.

Record person := { age : word 8; salary : word 8 }.
Record msg := { data : word 8; who : person }.
(* Note that sometimes we have a dedicated format for the nested record. *)
Definition format :=
  format_word ◦ data ++
  format_word ◦ age ◦ who ++
  format_word ◦ salary ◦ who.
Definition invariant (_ : msg) := True.

Definition dec : CorrectAlignedDecoderFor invariant format.
Proof.
  synthesize_aligned_decoder.
Defined.


Require Import Coq.Classes.Morphisms.

Require Import Crypto.Spec.WeierstrassCurve.
Require Import Crypto.Util.Decidable Crypto.Algebra.Field.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.SetoidSubst.
Require Import Crypto.Util.Notations Crypto.Util.LetIn.
Require Import Crypto.Util.Sum Crypto.Util.Prod Crypto.Util.Sigma.
Require Import Crypto.Util.FsatzAutoLemmas.

Module Jacobian.
  Section Jacobian.
    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv} {a b:F}
            {field:@Algebra.Hierarchy.field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {char_ge_3:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul (BinNat.N.succ_pos (BinNat.N.two))}
            {Feq_dec:DecidableRel Feq}.
    Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
    Local Notation "0" := Fzero.  Local Notation "1" := Fone.
    Local Infix "+" := Fadd. Local Infix "-" := Fsub.
    Local Infix "*" := Fmul. Local Infix "/" := Fdiv.
    Local Notation "x ^ 2" := (x*x). Local Notation "x ^ 3" := (x^2*x).
    Local Notation Wpoint := (@W.point F Feq Fadd Fmul a b).

    Definition point : Type := { P : F*F*F | let '(X,Y,Z) := P in
                                             if dec (Z=0) then True else Y^2 = X^3 + a*X*(Z^2)^2 + b*(Z^3)^2 }.
    Definition eq (P Q : point) : Prop :=
      match proj1_sig P, proj1_sig Q with
      | (X1, Y1, Z1), (X2, Y2, Z2) =>
        if dec (Z1 = 0) then Z2 = 0
        else Z2 <> 0 /\
             X1*Z2^2 = X2*Z1^2
             /\ Y1*Z2^3 = Y2*Z1^3
      end.

    (* These cases are not needed to solve the goal, but handling them early speeds things up considerably *)
    Ltac prept_step_opt :=
      match goal with
      | [ H : ?T |- ?T ] => exact H
      | [ |- ?x = ?x ] => reflexivity
      | [ H : ?T, H' : ~?T |- _ ] => solve [ exfalso; apply H', H ]
      end.

    Ltac prept_step :=
      match goal with
      | _ => progress prept_step_opt
      | _ => progress intros
      (*| _ => progress specialize_by_assumption*)
      (*| _ => progress specialize_by trivial*)
      | _ => progress cbv [proj1_sig fst snd] in *
      | _ => progress autounfold with points_as_coordinates in *
      | _ => progress destruct_head'_True
      | _ => progress destruct_head'_unit
      | _ => progress destruct_head'_prod
      | _ => progress destruct_head'_sig
      | _ => progress destruct_head'_and
      | _ => progress destruct_head'_sum
      | _ => progress destruct_head'_bool
      | _ => progress destruct_head'_or
      | H: context[@dec ?P ?pf] |- _ => destruct (@dec P pf)
      | |- context[@dec ?P ?pf]      => destruct (@dec P pf)
      | |- ?P => lazymatch type of P with Prop => split end
      end.
    Ltac prept := repeat prept_step.
    Ltac t := prept; trivial; try contradiction; fsatz.

    Create HintDb points_as_coordinates discriminated.
    Hint Unfold Proper respectful Reflexive Symmetric Transitive : points_as_coordinates.
    Hint Unfold point eq W.eq W.point W.coordinates proj1_sig fst snd : points_as_coordinates.

    Global Instance Equivalence_eq : Equivalence eq.
    Proof. t. Qed.

    Program Definition of_affine (P:Wpoint) : point :=
      match W.coordinates P return F*F*F with
      | inl (x, y) => (x, y, 1)
      | inr _ => (0, 0, 0)
      end.
    Next Obligation. Proof. t. Qed.

    Program Definition to_affine (P:point) : Wpoint :=
      match proj1_sig P return F*F+_ with
      | (X, Y, Z) =>
        if dec (Z = 0) then inr tt
        else inl (X/Z^2, Y/Z^3)
      end.
    Next Obligation. Proof. t. Qed.

    Hint Unfold to_affine of_affine : points_as_coordinates.
    Global Instance Proper_of_affine : Proper (W.eq ==> eq) of_affine. Proof. t. Qed.
    Global Instance Proper_to_affine : Proper (eq ==> W.eq) to_affine. Proof. t. Qed.
    Lemma to_affine_of_affine P : W.eq (to_affine (of_affine P)) P. Proof. t. Qed.
    Lemma of_affine_to_affine P : eq (of_affine (to_affine P)) P. Proof. t. Qed.

    Program Definition opp (P:point) : point :=
      match proj1_sig P return F*F*F with
      | (X, Y, Z) => (X, Fopp Y, Z)
      end.
    Next Obligation. Proof. t. Qed.

    (** See http://www.hyperelliptic.org/EFD/g1p/auto-shortw-jacobian.html#doubling-dbl-2007-bl *)
    Program Definition double (P : point) : point :=
      match proj1_sig P return F*F*F with
      | (x_in, y_in, z_in) =>
        let xx := x_in^2 in
        let yy := y_in^2 in
        let yyyy := yy^2 in
        let zz := z_in^2 in
        (** [s = 2*((x_in + yy)^2 - xx - yyyy)] *)
        let s := x_in + yy in
        let s := s^2 in
        let s := s - xx in
        let s := s - yyyy in
        let s := s + s in
        (** [m = 3*xx + a*zz^2] *)
        let m := zz^2 in
        let m := a * m in
        let m := m + xx in
        let m := m + xx in
        let m := m + xx in
        (** [x_out = m^2 - 2*s] *)
        let x_out := m^2 in
        let x_out := x_out - s in
        let x_out := x_out - s in
        (** [z_out = (y_in + z_in)^2 - yy - zz] *)
        let z_out := y_in + z_in in
        let z_out := z_out^2 in
        let z_out := z_out - yy in
        let z_out := z_out - zz in
        (** [y_out = m*(s-x_out) - 8*yyyy] *)
        let yyyy := yyyy + yyyy in
        let yyyy := yyyy + yyyy in
        let yyyy := yyyy + yyyy in
        let y_out := s - x_out in
        let y_out := y_out * m in
        let y_out := y_out - yyyy in
        (x_out, y_out, z_out)
      end.
    Next Obligation. Proof. t. Qed.

    Definition z_is_zero_or_one (Q : point) : Prop :=
      match proj1_sig Q with
      | (_, _, z) => z = 0 \/ z = 1
      end.

    Definition add_precondition (Q : point) (mixed : bool) : Prop :=
      match mixed with
      | false => True
      | true => z_is_zero_or_one Q
      end.

    Local Ltac clear_neq :=
      repeat match goal with
             | [ H : _ <> _ |- _ ] => clear H
             end.
    Local Ltac clear_eq :=
      repeat match goal with
             | [ H : _ = _ |- _ ] => clear H
             end.
    Local Ltac clear_eq_and_neq :=
      repeat (clear_eq || clear_neq).
    Local Ltac clean_up_speed_up_fsatz :=
      repeat match goal with
             | [ H : forall a : F, _ = _ -> _ = _ |- _ ] => clear H
             | [ H : forall a : F, _ <> _ -> _ = _ |- _ ] => clear H
             | [ H : forall a : F, _ <> _ -> _ <> _ |- _ ] => clear H
             | [ H : forall a b : F, _ = _ |- _ ] => clear H
             | [ H : forall a b : F, _ = _ -> _ = _ |- _ ] => clear H
             | [ H : forall a b : F, _ <> _ -> _ = _ |- _ ] => clear H
             | [ H : forall a b : F, _ <> _ -> _ <> _ |- _ ] => clear H
             | [ H : forall a b : F, _ = _ -> _ <> _ -> _ = _ |- _ ] => clear H
             | [ H : forall a b : F, _ <> _ -> _ <> _ -> _ = _ |- _ ] => clear H
             | [ H : forall a b : F, _ <> _ -> _ <> _ -> _ <> _ |- _ ] => clear H
             | [ H : forall a b c : F, _ |- _ ] => clear H
             | [ H : ?T, H' : ?T |- _ ] => clear H'
             | [ H : ?x = ?x |- _ ] => clear H
             | [ H : ?x <> 0, H' : ?x = 1 |- _ ] => clear H
             | [ H : ?x = 0 |- _ ] => is_var x; clear H x
             | [ H : ?x = 1 |- _ ] => is_var x; clear H x
             | [ H : Finv (?x^3) <> 0, H' : ?x <> 0 |- _ ] => clear H
             end.
    Local Ltac find_and_do_or_prove_by ty by_tac tac :=
      lazymatch goal with
      | [ H' : ty |- _ ]
        => tac H'
      | _
        => assert ty by by_tac
      end.
    Local Ltac find_and_do_or_prove_by_fsatz ty tac :=
      find_and_do_or_prove_by ty ltac:(clear_eq_and_neq; intros; fsatz) tac.
    Local Ltac find_and_do_or_prove_by_fsatz_with_neq ty tac :=
      find_and_do_or_prove_by ty ltac:(clear_neq; intros; fsatz) tac.
    Local Ltac find_and_goal_apply_or_prove_by_fsatz ty :=
      find_and_do_or_prove_by_fsatz ty ltac:(fun H' => apply H').
    Local Ltac find_and_apply_or_prove_by_fsatz H ty :=
      find_and_do_or_prove_by_fsatz ty ltac:(fun H' => apply H' in H).
    Local Ltac find_and_apply_or_prove_by_fsatz2 H0 H1 ty :=
      find_and_do_or_prove_by_fsatz ty ltac:(fun H' => apply H' in H0; [ | exact H1 ]).
    Local Ltac find_and_apply_or_prove_by_fsatz' H ty preapp :=
      find_and_do_or_prove_by_fsatz ty ltac:(fun H' => let H' := preapp H' in apply H' in H).
    Local Ltac speed_up_fsatz_step_on pkg :=
      let goal_if_var_neq_zero (* we want to keep lazymatch below, so we hack backtracking on is_var *)
          := match goal with
             | [ |- ?x <> 0 ] => let test := match goal with _ => is_var x end in
                                 constr:(x <> 0)
             | _ => I
             end in
      lazymatch goal with
      | [ H : False |- _ ] => solve [ exfalso; exact H ]
      | [ H : ?T |- ?T ] => exact H
      | [ H : ?x <> ?x |- _ ] => solve [ exfalso; apply H; reflexivity ]
      | [ H : ?x = ?y, H' : ?x <> ?y |- _ ] => solve [ exfalso; apply H', H ]
      | [ H : ?x = 0 |- ?x * ?y <> 0 ] => exfalso
      | [ H : ?y = 0 |- ?x * ?y <> 0 ] => exfalso
      | [ H : ~?T |- ?T ] => exfalso
      | [ H : ?T |- ~?T ] => exfalso
      | [ H : ?x - ?x = 0 |- _ ] => clear H
      | [ H : ?x * ?y = 0, H' : ?x = 0 |- _ ] => clear H
      | [ H : ?x * ?y = 0, H' : ?y = 0 |- _ ] => clear H
      | [ |- goal_if_var_neq_zero ] => intro
      | [ H : ?x = Fopp ?x |- _ ]
        => F.apply_lemma_in_on pkg H (forall a, a = Fopp a -> a = 0)
      | [ H : ?x <> Fopp ?x |- _ ]
        => F.apply_lemma_in_on pkg H (forall a, a <> Fopp a -> a <> 0)
      | [ H : ?x + ?x = 0 |- _ ]
        => F.apply_lemma_in_on pkg H (forall y, y + y = 0 -> y = 0)
      | [ H : Finv (?x^3) = 0, H' : ?x <> 0 |- _ ]
        => F.apply2_lemma_in_on pkg H H' (forall a, Finv (a^3) = 0 -> a <> 0 -> False)
      | [ H : ?x - ?y = 0, H' : ?y <> ?x |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b, a - b = 0 -> b = a)
      | [ H : ?x - ?y = 0, H' : ?x <> ?y |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b, a - b = 0 -> a = b)
      | [ H : ?x * ?y * ?z <> 0, H' : ?y <> 0 |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b c, a * b * c <> 0 -> a * c <> 0)
      | [ H : ?x * ?y^3 <> 0, H' : ?y <> 0 |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b, a * b <> 0 -> a <> 0)
      | [ H : ?x * ?y^2 <> 0, H' : ?y <> 0 |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b, a * b <> 0 -> a <> 0)
      | [ H : ?x^2 - ?y^2 = ?z |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b c, a^2 - b^2 = c -> (a - b) * (a + b) = c)
      | [ H : ?x + ?y * ?z = 0, H' : ?x <> Fopp (?z * ?y) |- _ ]
        => F.apply2_lemma_in_on pkg H H' (forall a b c, a + b * c = 0 -> a <> Fopp (c * b) -> False)
      | [ H : ?x + ?x <> 0 |- _ ]
        => F.apply_lemma_in_on pkg H (forall a, a + a <> 0 -> a <> 0)
      | [ H : ?x - ?y <> 0, H' : ?y = ?x |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b, a - b <> 0 -> b <> a)
      | [ H : ?x - ?y <> 0, H' : ?x = ?y |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b, a - b <> 0 -> a <> b)
      | [ H : (?x + ?y)^2 - (?x^2 + ?y^2) = 0 |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b, (a + b)^2 - (a^2 + b^2) = 0 -> a * b = 0)
      | [ H : (?x + ?y)^2 - (?x^2 + ?y^2) <> 0 |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b, (a + b)^2 - (a^2 + b^2) <> 0 -> a * b <> 0)
      | [ H : ?x * ?y = 0, H' : ?x <> 0 |- _ ]
        => F.apply2_lemma_in_on pkg H H' (forall a b, a * b = 0 -> a <> 0 -> b = 0)
      | [ H : ?x * ?y = 0, H' : ?y <> 0 |- _ ]
        => F.apply2_lemma_in_on pkg H H' (forall a b, a * b = 0 -> b <> 0 -> a = 0)
      | [ H : ?x * ?y <> 0, H' : ?x <> 0 |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b, a * b <> 0 -> b <> 0)
      | [ H : ?x * ?y <> 0, H' : ?y <> 0 |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b, a * b <> 0 -> a <> 0)
      | [ H : ?x * ?y <> 0, H' : ?x = 0 |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b, a * b <> 0 -> a <> 0)
      | [ H : ?x * ?y <> 0, H' : ?y = 0 |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b, a * b <> 0 -> b <> 0)
      | [ |- (?x + ?y)^2 - (?x^2 + ?y^2) = 0 ]
        => F.goal_apply_lemma_on pkg (forall a b, a * b = 0 -> (a + b)^2 - (a^2 + b^2) = 0)
      | [ |- (?x + ?y)^2 - (?x^2 + ?y^2) <> 0 ]
        => F.goal_apply_lemma_on pkg (forall a b, a * b <> 0 -> (a + b)^2 - (a^2 + b^2) <> 0)
      | [ |- (?x + ?y)^2 - ?x^2 - ?y^2 = 0 ]
        => F.goal_apply_lemma_on pkg (forall a b, a * b = 0 -> (a + b)^2 - a^2 - b^2 = 0)
      | [ |- (?x + ?y)^2 - ?x^2 - ?y^2 <> 0 ]
        => F.goal_apply_lemma_on pkg (forall a b, a * b <> 0 -> (a + b)^2 - a^2 - b^2 <> 0)
      | [ H : (?x + ?y)^2 - (?x^2 + ?y^2) = 0 |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b, (a + b)^2 - (a^2 + b^2) = 0 -> a * b = 0)
      | [ H : (?x + ?y)^2 - (?x^2 + ?y^2) <> 0 |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b, (a + b)^2 - (a^2 + b^2) <> 0 -> a * b <> 0)
      | [ H : (?x + ?y)^2 - ?x^2 - ?y^2 = 0 |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b, (a + b)^2 - a^2 - b^2 = 0 -> a * b = 0)
      | [ H : (?x + ?y)^2 - ?x^2 - ?y^2 <> 0 |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b, (a + b)^2 - a^2 - b^2 <> 0 -> a * b <> 0)
      | [ H : ?x = 0 |- ?x * ?y = 0 ]
        => F.goal_apply_lemma_on pkg (forall a b, a = 0 -> a * b = 0)
      | [ H : ?y = 0 |- ?x * ?y = 0 ]
        => F.goal_apply_lemma_on pkg (forall a b, b = 0 -> a * b = 0)
      | [ H : ?x <> 0 |- ?x * ?y <> 0 ]
        => F.goal_apply_lemma_on pkg (forall a b, a <> 0 -> b <> 0 -> a * b <> 0)
      | [ H : ?y <> 0 |- ?x * ?y <> 0 ]
        => F.goal_apply_lemma_on pkg (forall a b, a <> 0 -> b <> 0 -> a * b <> 0)
      | [ H : ?x <> 0 |- ?x * ?y = 0 ]
        => F.goal_apply_lemma_on pkg (forall a b, b = 0 -> a * b = 0)
      | [ H : ?y <> 0 |- ?x * ?y = 0 ]
        => F.goal_apply_lemma_on pkg (forall a b, a = 0 -> a * b = 0)

      | [ H : ?x - ?y * ?z <> ?w, H' : ?y = 1 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c d, a - b * c <> d -> b = 1 -> a - c <> d) ltac:(fun H'' => constr:(fun Hv => H'' x y z w Hv H'))
      | [ H : ?x - ?y * ?z = ?w, H' : ?y = 1 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c d, a - b * c = d -> b = 1 -> a - c = d) ltac:(fun H'' => constr:(fun Hv => H'' x y z w Hv H'))
      | [ H : ?x - ?y * ?z * ?w <> ?v, H' : ?y = 1 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c d e, a - b * c * d <> e -> b = 1 -> a - c * d <> e) ltac:(fun H'' => constr:(fun Hv => H'' x y z w v Hv H'))
      | [ H : ?x - ?y * ?z * ?w = ?v, H' : ?y = 1 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c d e, a - b * c * d = e -> b = 1 -> a - c * d = e) ltac:(fun H'' => constr:(fun Hv => H'' x y z w v Hv H'))
      | [ H : ?x - ?y * ?z^2 <> ?w, H' : ?z = 1 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c d, a - b * c^2 <> d -> c = 1 -> a - b <> d) ltac:(fun H'' => constr:(fun Hv => H'' x y z w Hv H'))
      | [ H : ?x - ?y * ?z^2 = ?w, H' : ?z = 1 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c d, a - b * c^2 = d -> c = 1 -> a - b = d) ltac:(fun H'' => constr:(fun Hv => H'' x y z w Hv H'))

      | [ H : ?x - ?y + ?z <> ?w, H' : ?y = 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c d, a - b + c <> d -> b = 0 -> a + c <> d) ltac:(fun H'' => constr:(fun Hv => H'' x y z w Hv H'))
      | [ H : ?x - ?y <> ?z, H' : ?y = 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c, a - b <> c -> b = 0 -> a <> c) ltac:(fun H'' => constr:(fun Hv => H'' x y z Hv H'))
      | [ H : ?x * ?y + ?z <> ?w, H' : ?x = 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c d, a * b + c <> d -> a = 0 -> c <> d) ltac:(fun H'' => constr:(fun Hv => H'' x y z w Hv H'))
      | [ H : ?x * ?y + ?z <> ?w, H' : ?y = 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c d, a * b + c <> d -> b = 0 -> c <> d) ltac:(fun H'' => constr:(fun Hv => H'' x y z w Hv H'))
      | [ H : ?x * ?y <> ?z, H' : ?x = 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c, a * b <> c -> a = 0 -> c <> 0) ltac:(fun H'' => constr:(fun Hv => H'' x y z Hv H'))
      | [ H : ?x * ?y <> ?z, H' : ?y = 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c, a * b <> c -> b = 0 -> c <> 0) ltac:(fun H'' => constr:(fun Hv => H'' x y z Hv H'))
      | [ H : Fopp (?x * ?y) <> ?z, H' : ?x = 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c, Fopp (a * b) <> c -> a = 0 -> c <> 0) ltac:(fun H'' => constr:(fun Hv => H'' x y z Hv H'))
      | [ H : Fopp (?x * ?y) <> ?z, H' : ?y = 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c, Fopp (a * b) <> c -> b = 0 -> c <> 0) ltac:(fun H'' => constr:(fun Hv => H'' x y z Hv H'))
      | [ H : ?x * ?y^3 = ?z, H' : ?y = 0 |- _ ]
        => F.apply2_lemma_in_on pkg H H' (forall a b c, a * b^3 = c -> b = 0 -> c = 0)
      | [ H : ?x * ?y = ?z, H' : ?x = 0 |- _ ]
        => F.apply2_lemma_in_on pkg H H' (forall a b c, a * b = c -> a = 0 -> c = 0)
      | [ H : ?x * ?y - ?z <> 0, H' : ?x = 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c, a * b - c <> 0 -> a = 0 -> c <> 0) ltac:(fun H'' => constr:(fun Hv => H'' x y z Hv H'))
      | [ H : ?x * ?y - ?z <> 0, H' : ?y = 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c, a * b - c <> 0 -> b = 0 -> c <> 0) ltac:(fun H'' => constr:(fun Hv => H'' x y z Hv H'))
      | [ H : ?x * ?y - ?z = 0, H' : ?x = 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c, a * b - c = 0 -> a = 0 -> c = 0) ltac:(fun H'' => constr:(fun Hv => H'' x y z Hv H'))
      | [ H : ?x * ?y - ?z = 0, H' : ?y = 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c, a * b - c = 0 -> b = 0 -> c = 0) ltac:(fun H'' => constr:(fun Hv => H'' x y z Hv H'))
      | [ H : ?x - ?y * ?z = 0, H' : ?z = 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c, a - b * c = 0 -> c = 0 -> a = 0) ltac:(fun H'' => constr:(fun Hv => H'' x y z Hv H'))
      | [ H : ?x * (?y * ?y^2) - ?z <> ?w |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b c d, a * (b * b^2) - c <> d -> a * (b^3) - c <> d)
      | [ H : ?x * (?y * ?y^2) - ?z = ?w |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b c d, a * (b * b^2) - c = d -> a * (b^3) - c = d)
      | [ H : ?x - (?y * ?y^2) * ?z <> ?w |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b c d, a - (b * b^2) * c <> d -> a - (b^3) * c <> d)
      | [ H : ?x - (?y * ?y^2) * ?z = ?w |- _ ]
        => F.apply_lemma_in_on pkg H (forall a b c d, a - (b * b^2) * c = d -> a - (b^3) * c = d)
      | [ H : ?x * (?y * ?y^2) = 0, H' : ?y <> 0 |- _ ]
        => F.apply2_lemma_in_on pkg H H' (forall a b, a * (b * b^2) = 0 -> b <> 0 -> a = 0)
      | [ H : ?x * (?y * ?z) = 0, H' : ?z <> 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c, c <> 0 -> a * (b * c) = 0 -> a * b = 0) ltac:(fun lem => constr:(lem x y z H'))
      | [ H : ?x = ?y * ?z, H' : ?y = 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c, a = b * c -> b = 0 -> a = 0) ltac:(fun lem => constr:(fun H => lem x y z H H'))
      | [ H : ?x * ?y + ?z = 0, H' : ?x = 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c, a = 0 -> a * b + c = 0 -> c = 0) ltac:(fun lem => constr:(lem x y z H'))
      | [ H : ?x * (?y * ?y^2) - ?z * ?z^2 * ?w = 0, H' : ?x * ?y^3 + ?w * ?z^3 = 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c d, a * b^3 + d * c^3 = 0 -> a * (b * b^2) - c * c^2 * d = 0 -> a * b^3 = 0) ltac:(fun lem => constr:(lem x y z w H'))
      | [ H : ?x * Finv (?y^2) <> ?z * Finv (?w^2), Hy : ?y <> 0, Hw : ?w <> 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c d, a * Finv (b^2) <> c * Finv (d^2) -> b <> 0 -> d <> 0 -> a * (d^2) <> c * (b^2)) ltac:(fun Hv => constr:(fun H => Hv x y z w H Hy Hw))
      | [ H : ?x * Finv (?y^2) = ?z * Finv (?w^2), Hy : ?y <> 0, Hw : ?w <> 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c d, a * Finv (b^2) = c * Finv (d^2) -> b <> 0 -> d <> 0 -> a * (d^2) = c * (b^2)) ltac:(fun Hv => constr:(fun H => Hv x y z w H Hy Hw))
      | [ H : ?x * Finv (?y^3) = Fopp (?z * Finv (?w^3)), Hy : ?y <> 0, Hw : ?w <> 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c d, a * Finv (b^3) = Fopp (c * Finv (d^3)) -> b <> 0 -> d <> 0 -> a * (d^3) = Fopp (c * (b^3))) ltac:(fun Hv => constr:(fun H => Hv x y z w H Hy Hw))
      | [ H : ?x * Finv (?y^3) <> Fopp (?z * Finv (?w^3)), Hy : ?y <> 0, Hw : ?w <> 0 |- _ ]
        => F.apply_lemma_in_on' pkg H (forall a b c d, a * Finv (b^3) <> Fopp (c * Finv (d^3)) -> b <> 0 -> d <> 0 -> a * (d^3) <> Fopp (c * (b^3))) ltac:(fun Hv => constr:(fun H => Hv x y z w H Hy Hw))
      | [ H : ?x = Fopp (?y * ?z), H' : ?x - ?z * ?y = 0 |- _ ]
        => F.apply2_lemma_in_on pkg H H' (forall a b c, a = Fopp (b * c) -> a - c * b = 0 -> a = 0)
      | [ H : ?x = Fopp (?y * ?z), H' : ?x - ?z * ?y = 0 |- _ ]
        => F.apply2_lemma_in_on pkg H H' (forall a b c, a = Fopp (b * c) -> a - c * b = 0 -> a = 0)
      | [ H : ?x <> Fopp (?y * ?z), H' : ?x - ?z * ?y = 0 |- _ ]
        => F.apply2_lemma_in_on pkg H H' (forall a b c, a <> Fopp (b * c) -> a - c * b = 0 -> a * b * c <> 0)
      | [ H : ?x <> Fopp (?y * ?z), H' : ?x - ?z * ?y = 0 |- _ ]
        => F.apply2_lemma_in_on pkg H H' (forall a b c, a <> Fopp (b * c) -> a - c * b = 0 -> a * b * c <> 0)
      | [ H : ?y^2 = ?c^3 + ?a * ?c * (?x^2)^2 + ?b * (?x^3)^2,
              H' : ?y'^2 = ?c'^3 + ?a * ?c' * (?x'^2)^2 + ?b * (?x'^3)^2,
                   H0 : ?c' * ?x^2 - ?c * ?x'^2 = 0
          |- _ ]
        => F.apply_lemma_in_on' pkg H (forall X Y X' Y' A B C C', Y^2 = C^3 + A * C * (X^2)^2 + B * (X^3)^2 -> Y'^2 = C'^3 + A * C' * (X'^2)^2 + B * (X'^3)^2 -> C' * X^2 - C * X'^2 = 0 -> (Y' * (X^3))^2 - ((X'^3) * Y)^2 = 0) ltac:(fun Hv => constr:(fun H => Hv x y x' y' a b c c' H H' H0))
      | [ H : ?y^2 = ?c^3 + ?a * ?c * (?x^2)^2 + ?b * (?x^3)^2,
              H' : ?y'^2 = ?c'^3 + ?a * ?c' * (?x'^2)^2 + ?b * (?x'^3)^2,
                   H0 : ?c' * ?x^2 = ?c * ?x'^2
          |- _ ]
        => F.apply_lemma_in_on' pkg H (forall X Y X' Y' A B C C', Y^2 = C^3 + A * C * (X^2)^2 + B * (X^3)^2 -> Y'^2 = C'^3 + A * C' * (X'^2)^2 + B * (X'^3)^2 -> C' * X^2 = C * X'^2 -> (Y' * (X^3))^2 - ((X'^3) * Y)^2 = 0) ltac:(fun Hv => constr:(fun H => Hv x y x' y' a b c c' H H' H0))

      | [ H0 : ?x * ?y^3 = ?A * ?B^3,
               H1 : ?x * ?z^3 - ?B^3 * ?D = 0,
                    H2 : ?D * ?C^3 = ?w * ?z^3,
                         H3 : ?A * ?C^3 - ?y^3 * ?w <> 0,
                              Hz : ?z <> 0,
                                   HB : ?B <> 0
          |- _ ]
        => exfalso; revert H0 H1 H2 H3 Hz HB;
           generalize x, y, z, w, A, B, C, D;
           F.goal_exact_lemma_on pkg
      | [ H0 : ?x * ?y^3 = ?A * ?B^3,
               H1 : ?x * ?z^3 - ?B^3 * ?D <> 0,
                    H2 : ?D * ?C^3 = ?w * ?z^3,
                         H3 : ?A * ?C^3 - ?y^3 * ?w = 0,
                              Hy : ?y <> 0,
                                   HC : ?C <> 0
          |- _ ]
        => exfalso; revert H0 H1 H2 H3 Hy HC;
           generalize x, y, z, w, A, B, C, D;
           F.goal_exact_lemma_on pkg
      | [ H0 : ?x * ?y^2 = ?A * ?B^2,
               H1 : ?x * ?z^2 - ?D * ?B^2 = 0,
                    H2 : ?D * ?C^2 = ?w * ?z^2,
                         H3 : ?A * ?C^2 - ?w * ?y^2 <> 0,
                              Hz : ?z <> 0,
                                   HB : ?B <> 0
          |- _ ]
        => exfalso; revert H0 H1 H2 H3 Hz HB;
           generalize x, y, z, w, A, B, C, D;
           F.goal_exact_lemma_on pkg
      | [ H0 : ?A * ?B^2 = ?x * ?y^2,
               H1 : ?x * ?z^2 - ?D * ?B^2 = 0,
                    H2 : ?w * ?z^2 = ?D * ?C^2,
                         H3 : ?A * ?C^2 - ?w * ?y^2 <> 0,
                              Hz : ?z <> 0,
                                   HB : ?B <> 0
          |- _ ]
        => exfalso; revert H0 H1 H2 H3 Hz HB;
           generalize x, y, z, w, A, B, C, D;
           F.goal_exact_lemma_on pkg
      | [ H : ?x <> 0 |- context[Finv (?x^2)] ]
        => F.with_lemma_on pkg (forall a, a <> 0 -> Finv (a^2) = (Finv a)^2) ltac:(fun H' => rewrite !(H' x H))
      | [ H : ?x <> 0 |- context[Finv (?x^3)] ]
        => F.with_lemma_on pkg (forall a, a <> 0 -> Finv (a^3) = (Finv a)^3) ltac:(fun H' => rewrite !(H' x H))
      | [ H : ?x <> 0 |- context[Finv (Finv ?x)] ]
        => F.with_lemma_on pkg (forall a, a <> 0 -> Finv (Finv a) = a) ltac:(fun H' => rewrite !(H' x H))
      | [ |- context[Finv ((?x + ?y)^2 - ?x^2 - ?y^2)] ]
        => F.with_lemma_on pkg (forall a b, (a + b)^2 - a^2 - b^2 = (1+1) * a * b) ltac:(fun H' => rewrite !(H' x y))
      | [ |- context[Finv ((?x + ?y)^2 - (?x^2 + ?y^2))] ]
        => F.with_lemma_on pkg (forall a b, (a + b)^2 - (a^2 + b^2) = (1+1) * a * b) ltac:(fun H' => rewrite !(H' x y))
      | [ |- context[Finv (?x * ?y)] ]
        => F.with_lemma_on
             pkg
             (forall a b, a * b <> 0 -> Finv (a * b) = Finv a * Finv b)
             ltac:(fun H' => rewrite !(H' x y) by (clear_eq; fsatz))
      | _ => idtac
      end.
    Local Ltac speed_up_fsatz :=
      let fld := guess_field in
      let pkg := F.get_package_on fld in
      divisions_to_inverses fld;
      repeat speed_up_fsatz_step_on pkg.
    (* sanity check to get error messages that would otherwise be gobbled by [repeat] *)
    Local Ltac speed_up_fsatz_check :=
      let fld := guess_field in
      let pkg := F.get_package_on fld in
      speed_up_fsatz_step_on pkg.

    (* Everything this can solve, [t] can also solve, but this does some extra work to go faster *)
    Local Ltac pre_pre_faster_t :=
      prept; try contradiction; speed_up_fsatz.
    Local Ltac pre_faster_t :=
      pre_pre_faster_t; speed_up_fsatz_check; clean_up_speed_up_fsatz.
    Local Ltac faster_t_noclear :=
      pre_faster_t; fsatz.
    Local Ltac faster_t :=
      pre_faster_t;
      try solve [ lazymatch goal with
                  | [ |- _ = _ ] => clear_neq
                  | _ => idtac
                  end;
                  fsatz ].

    Hint Unfold double negb andb add_precondition z_is_zero_or_one : points_as_coordinates.
    Program Definition add_impl (mixed : bool) (P Q : point)
            (H : add_precondition Q mixed) : point :=
      match proj1_sig P, proj1_sig Q return F*F*F with
      | (x1, y1, z1), (x2, y2, z2) =>
        let z1nz := if dec (z1 = 0) then false else true in
        let z2nz := if dec (z2 = 0) then false else true in
        let z1z1 := z1^2 in
        let '(u1, s1, two_z1z2) := if negb mixed
                                   then
                                     let z2z2 := z2^2 in
                                     let u1 := x1 * z2z2 in
                                     let two_z1z2 := z1 + z2 in
                                     let two_z1z2 := two_z1z2^2 in
                                     let two_z1z2 := two_z1z2 - z1z1 in
                                     let two_z1z2 := two_z1z2 - z2z2 in
                                     let s1 := z2 * z2z2 in
                                     let s1 := s1 * y1 in
                                     (u1, s1, two_z1z2)
                                   else
                                     let u1 := x1 in
                                     let two_z1z2 := z1 + z1 in
                                     let s1 := y1 in
                                     (u1, s1, two_z1z2)
        in
        let u2 := x2 * z1z1 in
        let h := u2 - u1 in
        let xneq := if dec (h = 0) then false else true in
        let z_out := h * two_z1z2 in
        let z1z1z1 := z1 * z1z1 in
        let s2 := y2 * z1z1z1 in
        let r := s2 - s1 in
        let r := r + r in
        let yneq := if dec (r = 0) then false else true in
        if (negb xneq && negb yneq && z1nz && z2nz)%bool
        then proj1_sig (double P)
        else
          let i := h + h in
          let i := i^2 in
          let j := h * i in
          let v := u1 * i in
          let x_out := r^2 in
          let x_out := x_out - j in
          let x_out := x_out - v in
          let x_out := x_out - v in
          let y_out := v - x_out in
          let y_out := y_out * r in
          let s1j := s1 * j in
          let y_out := y_out - s1j in
          let y_out := y_out - s1j in
          let x_out := if z1nz then x_out else x2 in
          let x3 := if z2nz then x_out else x1 in
          let y_out := if z1nz then y_out else y2 in
          let y3 := if z2nz then y_out else y1 in
          let z_out := if z1nz then z_out else z2 in
          let z3 := if z2nz then z_out else z1 in
          (x3, y3, z3)
      end.
    Next Obligation. Proof. faster_t_noclear. Qed.

    Definition add (P Q : point) : point :=
      add_impl false P Q I.
    Definition add_mixed (P : point) (Q : point) (H : z_is_zero_or_one Q) :=
      add_impl true P Q H.

    Hint Unfold W.eq W.add to_affine add add_mixed add_impl : points_as_coordinates.

    Lemma Proper_double : Proper (eq ==> eq) double. Proof. faster_t_noclear. Qed.
    Lemma to_affine_double P :
      W.eq (to_affine (double P)) (W.add (to_affine P) (to_affine P)).
    Proof. faster_t_noclear. Qed.

    Lemma add_mixed_eq_add (P : point) (Q : point) (H : z_is_zero_or_one Q) :
      eq (add P Q) (add_mixed P Q H).
    Proof. faster_t. Qed.

    Lemma Proper_add : Proper (eq ==> eq ==> eq) add. Proof. faster_t_noclear. Qed.
    Import BinPos.
    Lemma to_affine_add P Q
      : W.eq (to_affine (add P Q)) (W.add (to_affine P) (to_affine Q)).
    Proof.
      Time prept; try contradiction; speed_up_fsatz; clean_up_speed_up_fsatz. (* 15.009 secs (14.871u,0.048s) *)
      Time all: fsatz. (* 6.335 secs (6.172u,0.163s) *)
      Time Qed. (* 1.924 secs (1.928u,0.s) *)

    (** If [a] is -3, one can substitute a faster implementation of [double]. *)
    Section AEqMinus3.
      Context (a_eq_minus3 : a = Fopp (1+1+1)).

      Program Definition double_minus_3 (P : point) : point :=
        match proj1_sig P return F*F*F with
        | (x_in, y_in, z_in) =>
          let delta := z_in^2 in
          let gamma := y_in^2 in
          let beta := x_in * gamma in
          let ftmp := x_in - delta in
          let ftmp2 := x_in + delta in
          let tmptmp := ftmp2 + ftmp2 in
          let ftmp2 := ftmp2 + tmptmp in
          let alpha := ftmp * ftmp2 in
          let x_out := alpha^2 in
          let fourbeta := beta + beta in
          let fourbeta := fourbeta + fourbeta in
          let tmptmp := fourbeta + fourbeta in
          let x_out := x_out - tmptmp in
          let delta := gamma + delta in
          let ftmp := y_in + z_in in
          let z_out := ftmp^2 in
          let z_out := z_out - delta in
          let y_out := fourbeta - x_out in
          let gamma := gamma + gamma in
          let gamma := gamma^2 in
          let y_out := alpha * y_out in
          let gamma := gamma + gamma in
          let y_out := y_out - gamma in
          (x_out, y_out, z_out)
        end.
      Next Obligation. Proof. t. Qed.

      Hint Unfold double_minus_3 : points_as_coordinates.

      Lemma double_minus_3_eq_double (P : point) :
        eq (double P) (double_minus_3 P).
      Proof. faster_t. Qed.
    End AEqMinus3.
  End Jacobian.
End Jacobian.


Require Import Coq.Lists.List.
Import ListNotations.

Definition SetVars  := nat.

Definition FuncSymb := nat.

Record FSV := {
 fs : FuncSymb;
 fsv : nat;
}.

Inductive preTerms :=
|Vari : SetVars -> preTerms
|Node : FSV -> list preTerms -> preTerms.

Fixpoint isNTerm (n:nat) (x : preTerms) {struct n}: Prop
:=match n with
  | 0 => True
  | S n =>
   match x with
   | Vari v => True
   | Node f lp => (and ((length lp)=(fsv f)) (Forall (isNTerm n) lp))
   end
  end.

Notation isTerm := (fun x =>  (forall (n:nat), isNTerm n x)).
Record Terms := {
 Terms_x : preTerms;
 Terms_H : isTerm Terms_x;
}.

(* Good *)
Theorem VariIsTerm s y: isNTerm y (Vari s).
Proof.
destruct y.
exact I.
simpl in * |- *.
exact I.
Show Proof.
Defined.

Fixpoint ArgIsTerm (f:FSV) (ls:_) A:
(isTerm (Node f ls)) -> (In A ls) -> (isTerm A).
Proof.
intros H H0.
destruct A.
- apply VariIsTerm.
- intro n.
  pose (Q:= H (S n)).
  destruct H.
pose (GQ := Forall_forall (isNTerm n) ls).
destruct GQ.
apply H1.
assumption.
assumption.
Defined.

(* This function doesn't work properly. *)
Definition prototype (te:Terms) : list Terms.
Proof.
destruct (Terms_x te) eqn:a1.
exact [].
destruct l eqn:a2.
exact [].
refine [_].                              (** Here must be refine (_ :: _) ! **)
unshelve simple eapply Build_Terms.
exact p.
eapply (ArgIsTerm f (p::l0) p).
rewrite <- a1.
exact (Terms_H te).
constructor.
reflexivity.
Defined.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C P X : Universe, ((wd_ A P /\ (wd_ P C /\ (wd_ B C /\ (wd_ B X /\ (wd_ C X /\ (wd_ B A /\ (wd_ X A /\ (wd_ A C /\ (col_ B P X /\ (col_ B C X /\ col_ A P C)))))))))) -> col_ B A X)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Undecidability.L.L.
Require Import Undecidability.Synthetic.Undecidability.
From Undecidability.Synthetic Require Import
  DecidabilityFacts EnumerabilityFacts.
Require Import Undecidability.L.Enumerators.term_enum.

Require Import Undecidability.TM.TM.
Require Import Undecidability.TM.TM_undec.
Require Import Undecidability.L.Reductions.TM_to_L.

(** ** HaltL is undecidable *)

Lemma HaltL_undec :
  undecidable (HaltL).
Proof.
  apply (undecidability_from_reducibility HaltMTM_undec).
  eapply HaltMTM_to_HaltL.
Qed.


(**This document illustrate the space which we work in and the hypo we
     have already taken to construct this space**)
From CReal.MetricSpace Require Export M_pack.
From CReal.MetricSpace Require Export M_new.

Section BaseSpace.
Existing Instance EquR_trans.
Existing Instance leC_rewrite.
Variables X : Type.
Variables eqX : relation X.
Variables HE : Equivalence eqX.
Variables leX : relation X.
Variables pofX : Pre_Order_Field eqX leX.
Variables plusX : X -> X -> X.
Variables zeroX : X.
Variables pfX : Plus_Field eqX leX plusX zeroX.
Variables distX : X -> X -> X.
Variables MX : Metric eqX eqX _ _ _ pfX distX.

Definition ltX : X -> X -> Prop :=@lt X eqX leX pofX.

Variables Dp : Density eqX pfX.
Variables HPD : forall a b c : X, eqX (distX (plusX a b) (plusX a c)) (distX b c).

Variables A : Type.
Variables eqA : relation A.
Variables HEA : Equivalence eqA.
Variables dist : A -> A -> X.

Variables M : Metric eqX eqA leX plusX _ pfX dist.

Definition CX : Type := Cauchilize eqX eqX _ _ _ _.
Definition CA : Type := Cauchilize eqX eqA _ _ _ _.
Definition equCX : CX -> CX -> Prop :=@equC X X eqX eqX leX plusX zeroX distX pfX MX.
Definition leCX :=@leC X eqX leX plusX _ _ pfX MX HE.

Variables PB : PropBucket.
Definition pofCX :Pre_Order_Field equCX leCX :=@preOrder_trans X eqX leX plusX _ HE pfX _ MX Dp PB.

Definition plusCX :CX -> CX -> CX := M_new.plusCX X eqX HE leX plusX zeroX distX pfX MX Dp HPD .

Definition zeroCX :CX := M_new.zeroX X eqX HE leX plusX zeroX distX pfX MX.

Variables HIN : (forall a b : X, eqX (distX a b) (distX (inv a) (inv b))).
Definition pfCX : Plus_Field equCX leCX plusCX zeroCX  :=@pf_trans X eqX HE leX plusX zeroX distX pfX MX Dp HPD PB HIN.

Definition equCA : CA -> CA -> Prop := @equC A X eqX eqA leX plusX zeroX dist pfX M.

Variable HDD_pre : forall (x : X), leX zeroX x -> eqX (distX zeroX x) x.
(*Variables HDD : forall (a b c : A), eqX (distX (dist a b) (dist a c)) (dist b c).
Variables HDDX : forall (a b c : X), eqX (distX (distX a b) (distX a c)) (distX b c).
*)
Notation "a + b" := (plusX a b)
    (at level 50, left associativity).
Notation "a <= b" := (leX a b)
    (at level 70, no associativity).
Notation "a >= b" := (leX b a)
    (at level 70, no associativity).
Theorem dist_eq : forall (a b : A), eqX (distX zeroX (dist a b)) (dist a b).
Proof.
  intros.  apply HDD_pre. apply mle.
Qed.
Theorem distX_eq : forall (a b : X), eqX (distX zeroX (distX a b)) (distX a b).
Proof.
  intros.  apply HDD_pre. apply mle.
Qed.

Definition leseq (a b : CX) : Prop.
destruct a, b. apply(forall (x y : X) (n : nat), Cseq n x -> Cseq0 n y -> leX x y).
Defined.
Theorem le_leC : forall (a b : CX), leseq a b -> leCX a b.
Proof.
    intros. destruct(classic (equCX a b)).
    -rewrite H0. destruct b. simpl. left. intros. exists 0. intros. assert(eqX a1 a2).
     apply HCseq3 with (m := n);auto. rewrite H6. pose proof (mre a2 a2) as [Hex ?].
     rewrite Hex;auto. reflexivity.
   -destruct a. destruct b. simpl. simpl in H0. simpl in H. right.
    apply not_all_ex_not in H0. destruct H0 as [eps]. apply not_all_ex_not in H0.
    destruct H0 as [H3].
    destruct (division_of_eps _ _ _ _ _ _ eps) as [eps1 [eps2 [Heps1 [Heps2 Heq]]]];auto.
    destruct (division_of_eps _ _ _ _ _ _ eps1) as [epsex1 [epsex2[Hex1[Hex2 Hexeq]]]];auto.
    destruct H1. destruct H2. destruct HCA with (eps := epsex1) as [N1];auto.
    destruct HCA0 with (eps := epsex2) as [N2];auto. destruct (always_greater N1 N2) as [G].
    destruct H4. exists G. intros. apply not_ex_all_not with (n := n) in H0.
    apply not_all_ex_not in H0 as [N]. apply not_all_ex_not in H0 as [H9].
    apply not_all_ex_not in H0 as [a1pin]. apply not_all_ex_not in H0 as [a2pin].
    apply not_all_ex_not in H0 as [H10]. apply not_all_ex_not in H0 as [H11]. apply lt_not in H0.
    destruct H1 with (m := n) (n := N) (a := a1) (b := a1pin);split;auto.
    apply (lt_trans _ G _);auto. apply (lt_trans _ G _);[auto |apply (lt_trans _ n _);auto].
    apply H with (n := n);auto.
    destruct H2 with (m := n) (n := N) (a := a2) (b := a2pin). split.
    apply (lt_trans _ G _);auto. apply (lt_trans _ G _);[auto|apply (lt_trans _ n _); auto].
    split;auto. assert(epsex1 > distX a1 a1pin). apply lt_intro;auto.
    assert(epsex2 > distX a2 a2pin). apply lt_intro;auto.
    pose proof (lt_two_plus_two X eqX _ _ plusX zeroX).
    assert(epsex1 + epsex2> distX a1 a1pin + distX a2 a2pin).
    destruct (H14 (distX a1 a1pin) (distX a2 a2pin) (epsex1) (epsex2));apply lt_intro;auto.
    rewrite Hexeq in H15. unfold not. intros. rewrite H16 in H15. rewrite msy in H15.
    assert(distX a1pin a2 + distX a2 a2pin >= distX a1pin a2pin). apply mtr.
    assert(eps1 > distX a1pin a2pin).
    destruct (le_lt_eq _ _ _ (distX a1pin a2pin) (distX a1pin a2 + distX a2 a2pin)).
    apply H18 in H17. destruct H17. apply lttr with (y := distX a1pin a2 + distX a2 a2pin);auto.
    rewrite H17. auto. assert(distX a1pin a2pin < eps).
    assert(eps1 < eps). pose proof (lt_div X eqX _ leX plusX zeroX).
    destruct H19 with (a:=eps1) (b := eps2) (c := eps);auto. apply lt_intro;auto.
    apply lttr with (y := eps1);auto. pose proof (lt_not X eqX _ leX).
    destruct H20 with (x := distX a1pin a2pin) (y := eps). apply H22 in H0. unfold not in H0.
    apply H0. auto. auto.
Qed.

Theorem ms_trans : Metric equCX equCA leCX plusCX zeroCX pfCX
        (@distC _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ HDD_pre HPD _).
Proof.
    split.
    -intros. destruct(classic (equCA p1 p2)).
      +destruct p1. destruct p2. simpl. left. intros. simpl in H.
         destruct H with (eps := eps) as [N];auto. exists N. intros.
         destruct H6. rewrite He. assert(eqX zeroX a1). destruct H5;[reflexivity | auto].
         rewrite <-H6. pose proof orderPres2. pose proof mle.
         destruct (@le_lt_eq X eqX leX pofX zeroX (dist a b)). apply H9 in H8. destruct H8.
         assert(distX zeroX (dist a b) < distX zeroX eps). assert(eps > dist a b).
         destruct H3 with (n := n) (a1 := a) (a2 := b);auto. apply lt_intro;auto.
         destruct H7 with (a := zeroX) (b := dist a b) (c := eps);auto.
         { apply lt_intro;destruct H8;auto. }
         { apply lt_intro;destruct H11;auto. }
         { apply lt_intro;auto. }
         { rewrite dist_eq. apply H3 with (n := n);auto. }
        rewrite <- H8. pose proof (mre zeroX zeroX) as [Hex1 Hex2];rewrite Hex1.
        auto. reflexivity.
      +destruct p1. destruct p2. simpl. right. simpl in H. apply not_all_ex_not in H.
        destruct H as [eps]. apply not_all_ex_not in H. destruct H as [H2].
        destruct (division_of_eps _ _ _ _ _ _ eps) as [eps1[eps2 [Heps1 [Heps2 Heq]]]];auto.
        destruct(division_of_eps _ _ _ _ _ _ eps1) as [epsex1[epsex2 [Hepsex1 [Hepsex2 Hexeq]]]];auto.
        destruct H0. destruct HCA with (eps := epsex1) as [N1];auto.
        destruct H1. destruct HCA0 with (eps := epsex2) as [N2];auto.
        destruct (always_greater N1 N2) as [G1]. destruct H3. exists G1.
        intros. apply not_ex_all_not with (n := n) in H. apply not_all_ex_not in H.
        destruct H as [N3]. apply not_all_ex_not in H. destruct H as [H8].
        apply not_all_ex_not in H. destruct H7. rewrite He. destruct H as [apin].
        apply not_all_ex_not in H. destruct H as [bpin]. apply not_all_ex_not in H. destruct H as [H7].
        apply not_all_ex_not in H. destruct H as [H9]. apply lt_not in H. assert(eqX a1 zeroX).
        destruct H6. reflexivity. symmetry. auto. rewrite H10. assert(~eqA a b). unfold not. intros.
        destruct H0 with (m := n) (a := a) (n := N3) (b := apin). split;apply (lt_trans _ G1 _);auto.
        apply (lt_trans _ n _);auto. split;auto. destruct H1 with (m := n) (a := b) (n := N3) (b := bpin).
        split;apply(lt_trans _ G1 _);auto. apply (lt_trans _ n _);auto. split;auto.
        assert(epsex1 > dist a apin). apply lt_intro;auto. assert(epsex2 > dist b bpin).
        apply lt_intro;auto. rewrite H11 in H12. rewrite msy in H12.
        assert(dist apin b + dist b bpin >= dist apin bpin). apply mtr.
        assert(dist apin b + dist b bpin < epsex1 + epsex2).
        pose proof (lt_two_plus_two _ eqX _ leX plusX zeroX  (dist apin b) (dist b bpin) (epsex1) (epsex2)) as [H15];auto. apply lt_intro;destruct H12;auto. apply lt_intro;destruct H13;auto.
        apply lt_intro;auto. rewrite Hexeq in H15. assert(eps1 < eps).
        pose proof (lt_div X eqX _ leX plusX zeroX eps1 eps2 eps) as [H16]. auto. auto. auto.
        apply lt_intro;auto. assert(dist apin b + dist b bpin < eps). apply lttr with (y := eps1);auto.
        assert(eps > dist apin bpin).
        destruct (le_lt_eq _ _ _(dist apin bpin)  (dist apin b + dist b bpin) ). apply H18 in H14.
        destruct H14. apply lttr with (y := dist apin b + dist b bpin);auto. rewrite H14;auto.
        assert(~eps > dist apin bpin). apply lt_not;auto. unfold not in H19. apply H19. auto.
        assert(dist a b >= zeroX). apply mle. assert(~(eqX (dist a b) zeroX)).
        unfold not. intros. apply mre in H13. unfold not in H11. apply H11. auto.
        apply lt_intro; auto. unfold not. intros. unfold not in H13. apply H13. symmetry;auto.
        auto.
     -intros. destruct p1. destruct p2. simpl. intros. exists 0. intros. destruct H3.
      destruct H4. rewrite He. rewrite He0. assert(eqA a b0). destruct H.
      apply HCseq3 with (m:= n);auto. assert(eqA b a0). destruct H0.
      apply HCseq3 with (m:=n);auto. rewrite H3. rewrite H4. rewrite (msy b0 a0).
      pose proof (mre (dist a0 b0) (dist a0 b0)) as [Hex1 ?];rewrite Hex1;auto;reflexivity.
     -intros. split.
        +intros. destruct p1. destruct p2. simpl. simpl in H. intros.
        destruct H with (eps := eps) as [N];auto. exists N. intros. destruct H5. rewrite He.
        assert(eqX a2 zeroX). destruct H6. reflexivity. symmetry. auto. rewrite H5.
        rewrite msy. rewrite dist_eq. apply H3 with (n := n);auto.
      +intros. destruct p1. destruct p2. simpl. simpl in H. intros.
        destruct H with (eps := eps) as[N];auto.
         exists N. intros. rewrite <-dist_eq. rewrite msy. apply H3 with (n := n);auto.
         apply dit with (a := a1) (b := a2);auto. reflexivity. apply sig.
     -intros. apply le_leC. destruct p1, p2, p3. simpl. intros. destruct H2. destruct H3. rewrite He.
       rewrite He0. destruct Ha0. rewrite He1. destruct Hb0. rewrite He2.
       assert(eqA a1 b1). destruct H0. apply HCseq3 with (m := n);auto. rewrite H2.
       assert(eqA a0 a). destruct H. apply HCseq3 with (m := n);auto. rewrite H3.
       assert(eqA b0 b). destruct H1. apply HCseq3 with (m := n);auto. rewrite H4.
       apply mtr.
     -intros. destruct p1,p2,p3,p4. simpl. intro. simpl in H0,H. intros.
      destruct(division_of_eps _ _ _ _ _ _ eps) as [eps1 [eps2 [Heps1 [Heps2 Heq]]]];auto.
      destruct H with (eps := eps1) as [N1];auto. destruct H0 with (eps := eps2) as [N2];auto.
      destruct (always_greater N1 N2) as [G]. exists G. intros. destruct H10. destruct H11.
      rewrite He. rewrite He0.
      assert(distX (dist a b) (dist a0 b0) <= distX (dist a b) (dist a b0) + distX (dist a b0) (dist a0 b0)).
      apply mtr.
      assert (distX (dist a b) (dist a b0) <= dist b b0).
      specialize(HDD_l X eqX leX plusX zeroX _ A eqA _
                       dist distX _ _ HPD _ HDD_pre).
      intros. apply H11.
      assert (distX (dist a b0) (dist a0 b0) <= dist a a0).
      specialize(HDD_l X eqX leX plusX zeroX _ A eqA _
                       dist distX _ _ HPD _ HDD_pre).
      intros.
      repeat (rewrite (msy _ b0)).
      apply H12.
      assert(dist b b0 + dist a a0 < eps). rewrite <-Heq.
      pose proof (lt_two_plus_two X eqX _ leX plusX zeroX).
      destruct H13 with (a := dist b b0) (b := dist a a0) (c := eps2) (d := eps1).
      destruct H7 with (n := n) (a1 := b) (a2 := b0). destruct H8. apply (lt_trans _ G _);auto.
      auto. auto. apply lt_intro;auto. destruct H6 with (n := n) (a1 := a) (a2 := a0).
      destruct H8. apply (lt_trans _ G _);auto. auto. auto. apply lt_intro;auto.
      rewrite (pfc eps1 _). apply lt_intro;auto.
      assert (distX (dist a b) (dist a0 b0) <= dist b b0 + dist a a0).
      apply poft with
          (b1 := distX (dist a b) (dist a b0) +
                 distX (dist a b0) (dist a0 b0)).
      auto.
      apply (le_two_plus_two X eqX _ leX plusX _);auto.
      destruct (le_lt_eq _ _ _ (distX (dist a b) (dist a0 b0)) (dist b b0 + dist a a0)).
      apply H15 in H14. destruct H14. apply lttr with (y := dist b b0 + dist a a0);auto.
      rewrite (msy a0 b0). apply lt_intro;destruct H13;auto.
      auto. rewrite (msy b0 a0); auto.
      rewrite (msy b0 a0);apply H14.
      apply lt_intro;apply H13.
      rewrite  H14.
      apply lt_intro; destruct H13; auto.
Qed.

End BaseSpace.


Require Export Bool.Bool.
Require Export List.
Require Export Coq.Unicode.Utf8_core.

Require Import VarAssign.

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).
Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).

Inductive boolExpr : Type :=
| BAtom : nat -> bool -> boolExpr
| BAnd  : boolExpr -> boolExpr -> boolExpr
| BOr   : boolExpr -> boolExpr -> boolExpr.

Inductive vtree : Type :=
| VNode : vtree -> vtree -> vtree
| VAtom : nat -> vtree.

Inductive atom : Type :=
| AFalse : atom
| ATrue : atom
| AVar :  nat -> bool -> atom.

Inductive sdd : Type :=
          (*prime sub   next *)
| Or: ((sdd * sdd)*(sdd * sdd)) -> sdd
| Atom : atom -> sdd.

Inductive op : Type :=
| OAnd.

(* the magic of the Vtree lets us turn SDD sat/unsat testing into syntactic queries of the SDD *)

(* idea: a false atom is unsat, a false atom conjoined with anything is unsat,
   in order for an OR to be unsat all its children must be unsat *)
Inductive sdd_unsat : sdd -> Prop :=
| UnsatAtom : sdd_unsat (Atom AFalse)
| UnsatOrPrime : forall (prime0 sub0 prime1 sub1 : sdd),
    sdd_unsat prime0 ->
    sdd_unsat prime1 ->
    sdd_unsat (Or ((prime0, sub0),(prime1, sub1)))
| UnsatOrSub: forall (prime0 sub0 prime1 sub1 : sdd),
    sdd_unsat sub0 ->
    sdd_unsat sub1 ->
    sdd_unsat (Or ((prime0, sub0),(prime1, sub1))).

Example sdd_unsat_ex0:
  sdd_unsat (Or ((Atom ATrue, Atom AFalse), (Atom (AVar 1 true), Atom AFalse))).
Proof.
  apply UnsatOrSub; constructor.
Qed.

(* idea: a true atom is sat, a var is sat,
   SAT /\ SAT is SAT, a single or-child must be sat for the
   OR to be sat *)
Inductive sdd_sat : sdd -> Prop :=
| SatAtom : sdd_sat (Atom ATrue)
| SatVar : forall n b, sdd_sat (Atom (AVar n b))
| SatOrLeft : forall tl (prime sub : sdd),
    sdd_sat prime ->
    sdd_sat sub ->
    sdd_sat (Or ((prime, sub), tl))
| SatOrRight : forall tl (prime sub : sdd),
    sdd_sat prime ->
    sdd_sat sub ->
    sdd_sat (Or (tl, (prime, sub))).

Example sdd_sat_ex0 :
  sdd_sat (Or ((Atom ATrue, Atom AFalse), (Atom ATrue, Atom (AVar 1 true)))).
Proof.
  apply SatOrRight; constructor.
Qed.

Inductive atom_apply : op → atom → atom → atom → Prop :=
| AndTT : atom_apply OAnd ATrue ATrue ATrue
| AndTF : atom_apply OAnd ATrue AFalse AFalse
| AndFT : atom_apply OAnd AFalse ATrue AFalse
| AndFF : atom_apply OAnd AFalse AFalse AFalse
| AndVT : forall (n:nat) (b:bool), atom_apply OAnd (AVar n b) ATrue (AVar n b)
| AndTV : forall (n:nat) (b:bool), atom_apply OAnd ATrue (AVar n b) (AVar n b)
| AndVF : forall (n:nat) (b:bool), atom_apply OAnd (AVar n b) AFalse AFalse
| AndFV : forall (n:nat) (b:bool), atom_apply OAnd AFalse (AVar n b) AFalse
| AndVVEq : forall (n:nat) (b:bool), atom_apply OAnd (AVar n b) (AVar n b) (AVar n b)
| AndVVNeq : forall (n:nat) (b1:bool) (b2:bool), (b1 <> b2) → atom_apply OAnd (AVar n b1) (AVar n b2) (AFalse).

Inductive sdd_apply : op -> sdd -> sdd -> sdd -> Prop :=
| ApplyAtom : forall (a1:atom) (a2:atom) (a3:atom) (o:op),
    atom_apply o a1 a2 a3 → sdd_apply o (Atom a1) (Atom a2) (Atom a3)
| ApplyOr : forall o p1 s1 p2 s2 pa sa pb sb pRes1 sRes1 pRes2 sRes2,
    cross_and_prune o (p1,s1) (p2,s2) (pa,sa) (pb,sb) (pRes1,sRes1) (pRes2,sRes2) ->
    sdd_apply o (Or ((p1,s1),(p2,s2))) (Or ((pa,sa),(pb,sb))) (Or ((pRes1,sRes1),(pRes2,sRes2)))

with

cross_and_prune : op -> (sdd*sdd) -> (sdd*sdd) -> (sdd*sdd) -> (sdd*sdd) -> (sdd*sdd) -> (sdd*sdd)
                  -> Prop :=
| OneSatA1 : forall o p1 s1 p2 s2 pa sa pb sb pa1 sa1,
  sdd_apply OAnd p1 pa pa1 ->
  sdd_apply OAnd p2 pa (Atom AFalse) ->
  sdd_apply OAnd p1 pb (Atom AFalse) ->
  sdd_apply OAnd p2 pb (Atom AFalse) ->
  sdd_sat pa1 -> sdd_apply o s1 sa sa1 ->
  cross_and_prune o (p1,s1) (p2,s2) (pa,sa) (pb,sb) (pa1,sa1) ((Atom ATrue), (Atom AFalse))
| OneSatA2 : forall o p1 s1 p2 s2 pa sa pb sb pa2 sa2,
  sdd_apply OAnd p1 pa (Atom AFalse) ->
  sdd_apply OAnd p2 pa pa2 ->
  sdd_apply OAnd p1 pb (Atom AFalse) ->
  sdd_apply OAnd p2 pb (Atom AFalse) ->
  sdd_sat pa2 -> sdd_apply o s2 sa sa2 ->
  cross_and_prune o (p1,s1) (p2,s2) (pa,sa) (pb,sb) (pa2,sa2) ((Atom ATrue), (Atom AFalse))
| OneSatB1 : forall o p1 s1 p2 s2 pa sa pb sb pb1 sb1,
  sdd_apply OAnd p1 pa (Atom AFalse) ->
  sdd_apply OAnd p2 pa (Atom AFalse) ->
  sdd_apply OAnd p1 pb pb1 ->
  sdd_apply OAnd p2 pb (Atom AFalse) ->
  sdd_sat pb1 -> sdd_apply o s1 sb sb1 ->
  cross_and_prune o (p1,s1) (p2,s2) (pa,sa) (pb,sb) (pb1,sb1) ((Atom ATrue), (Atom AFalse))
| OneSatB2 : forall o p1 s1 p2 s2 pa sa pb sb pb2 sb2,
  sdd_apply OAnd p1 pa (Atom AFalse) ->
  sdd_apply OAnd p2 pa (Atom AFalse) ->
  sdd_apply OAnd p1 pb (Atom AFalse) ->
  sdd_apply OAnd p2 pb pb2 ->
  sdd_sat pb2 -> sdd_apply o s1 sb sb2 ->
  cross_and_prune o (p1,s1) (p2,s2) (pa,sa) (pb,sb) (pb2,sb2) ((Atom ATrue), (Atom AFalse))
| TwoSatA1A2 : forall o p1 s1 p2 s2 pa sa pb sb pa1 sa1 pa2 sa2,
  sdd_apply OAnd p1 pa pa1 ->
  sdd_apply OAnd p2 pa pa2 ->
  sdd_apply OAnd p1 pb (Atom AFalse) ->
  sdd_apply OAnd p2 pb (Atom AFalse) ->
  sdd_sat pa1 -> sdd_sat pa2 ->
  sdd_apply o s1 sa sa1 -> sdd_apply o s2 sa sa2 ->
  cross_and_prune o (p1,s1) (p2,s2) (pa,sa) (pb,sb) (pa1,sa1) (pa2, sa2)
| TwoSatA1B1 : forall o p1 s1 p2 s2 pa sa pb sb pa1 sa1 pb1 sb1,
  sdd_apply OAnd p1 pa pa1 ->
  sdd_apply OAnd p2 pa (Atom AFalse) ->
  sdd_apply OAnd p1 pb pb1 ->
  sdd_apply OAnd p2 pb (Atom AFalse) ->
  sdd_sat pa1 -> sdd_sat pb1 ->
  sdd_apply o s1 sa sa1 -> sdd_apply o s1 sb sb1 ->
  cross_and_prune o (p1,s1) (p2,s2) (pa,sa) (pb,sb) (pa1,sa1) (pb1, sb1)
| TwoSatA1B2 : forall o p1 s1 p2 s2 pa sa pb sb pa1 sa1 pb2 sb2,
  sdd_apply OAnd p1 pa pa1 ->
  sdd_apply OAnd p2 pa (Atom AFalse) ->
  sdd_apply OAnd p1 pb (Atom AFalse) ->
  sdd_apply OAnd p2 pb pb2 ->
  sdd_sat pa1 -> sdd_sat pb2 ->
  sdd_apply o s1 sa sa1 -> sdd_apply o s2 sb sb2 ->
  cross_and_prune o (p1,s1) (p2,s2) (pa,sa) (pb,sb) (pa1,sa1) (pb2, sb2)
| TwoSatA2B1 : forall o p1 s1 p2 s2 pa sa pb sb pa2 sa2 pb1 sb1,
  sdd_apply OAnd p1 pa (Atom AFalse) ->
  sdd_apply OAnd p2 pa pa2 ->
  sdd_apply OAnd p1 pb pb1 ->
  sdd_apply OAnd p2 pb (Atom AFalse) ->
  sdd_sat pa2 -> sdd_sat pb1 ->
  sdd_apply o s1 sa sa2 -> sdd_apply o s2 sb sb1 ->
  cross_and_prune o (p1,s1) (p2,s2) (pa,sa) (pb,sb) (pa2,sa2) (pb1, sb1)
| TwoSatA2B2 : forall o p1 s1 p2 s2 pa sa pb sb pa2 sa2 pb2 sb2,
  sdd_apply OAnd p1 pa (Atom AFalse) ->
  sdd_apply OAnd p2 pa pa2 ->
  sdd_apply OAnd p1 pb (Atom AFalse) ->
  sdd_apply OAnd p2 pb pb2 ->
  sdd_sat pa2 -> sdd_sat pb2 ->
  sdd_apply o s1 sa sa2 -> sdd_apply o s2 sb sb2 ->
  cross_and_prune o (p1,s1) (p2,s2) (pa,sa) (pb,sb) (pa2,sa2) (pb2, sb2)
| TwoSatB1B2 : forall o p1 s1 p2 s2 pa sa pb sb pb1 sb1 pb2 sb2,
  sdd_apply OAnd p1 pa (Atom AFalse) ->
  sdd_apply OAnd p2 pa (Atom AFalse) ->
  sdd_apply OAnd p1 pb pb1 ->
  sdd_apply OAnd p2 pb pb2 ->
  sdd_sat pb1 -> sdd_sat pb2 ->
  sdd_apply o s1 sb sb1 -> sdd_apply o s2 sb sb2 ->
  cross_and_prune o (p1,s1) (p2,s2) (pa,sa) (pb,sb) (pb1,sb1) (pb2, sb2).

Inductive sdd_vtree : sdd -> vtree -> Prop :=
| OrSingle: forall p1 s1 p2 s2 lvtree rvtree,
    sdd_vtree p1 lvtree ->
    sdd_vtree p2 lvtree ->
    sdd_vtree s1 rvtree ->
    sdd_vtree s2 rvtree ->
    sdd_vtree (Or ((p1,s1),(p2,s2))) (VNode lvtree rvtree)
| AtomTrue : forall n, sdd_vtree (Atom ATrue) (VAtom n)
| AtomFalse : forall n, sdd_vtree (Atom AFalse) (VAtom n)
| AtomVar : forall n b, sdd_vtree (Atom (AVar n b)) (VAtom n).

Example sdd_vtree_ex0:
  sdd_vtree (Or ((Atom (AVar 0 true), Atom (AVar 1 false)), ((Atom AFalse),(Atom AFalse))))
            (VNode (VAtom 0) (VAtom 1)).
Proof.
  constructor; constructor.
Qed.

(* an interesting theorem: all valid SDDs are either SAT or UNSAT. *)
Theorem sdd_sat_or_unsat :
  forall (sdd : sdd) vtree,
    sdd_vtree sdd vtree ->
    sdd_unsat sdd \/ sdd_sat sdd.
Proof.
Admitted.

(*Inductive expanded_sdd : vtree -> atom -> sdd -> Prop :=
| ExpandAtomT : forall n, expanded_sdd (VAtom n) ATrue (Atom ATrue)
| ExpandAtomF : forall n, expanded_sdd (VAtom n) AFalse (Atom AFalse)
| ExpandFalseNode : forall lvtree rvtree lsdd rsdd,
    expanded_sdd lvtree ATrue lsdd ->
    expanded_sdd rvtree AFalse rsdd ->
    expanded_sdd (VNode lvtree rvtree) AFalse (Or [(lsdd, rsdd)])
| ExpandTrueNode : forall lvtree rvtree lsdd rsdd,
    expanded_sdd lvtree ATrue lsdd ->
    expanded_sdd rvtree ATrue lsdd ->
    expanded_sdd (VNode lvtree rvtree) ATrue (Or [(lsdd, rsdd)]).*)

(* need to handle cases when the derived primes are sat/unsat, otherwise
   you get false primes in the generated SDD *)
(*Inductive sdd_of_var : nat -> vtree -> bool -> sdd -> Prop :=
| VarOfLeafMatchT : forall n b, sdd_of_var n (VAtom n) b (Atom (AVar n b))
| VarOfLeafNonmatchT : forall n1 n2 b,
    n1 <> n2 ->
    sdd_of_var n1 (VAtom n2) b (Atom ATrue)
| VarOfLeafNonmatchF : forall n1 n2 b,
    n1 <> n2 ->
    sdd_of_var n1 (VAtom n2) b (Atom AFalse)
| VarOfNode : forall n b lvtree rvtree lsdd_t rsdd_t lsdd_f false_expanded,
    sdd_of_var n lvtree b lsdd_t ->
    sdd_of_var n lvtree (negb b) lsdd_f ->
    sdd_of_var n rvtree b rsdd_t ->
    expanded_sdd rvtree AFalse false_expanded ->
    sdd_of_var n (VNode lvtree rvtree) b
               (Or [(lsdd_t, rsdd_t); (lsdd_f, false_expanded)]).*)

(*
The generated term containing the unsat branch:
(Or
 (((Atom True)
   (Or
    (((Atom (Var 1 true)) (Atom True)) ((Atom (Var 1 false)) (Atom False)))))
  ((Atom True) (Or (((Atom True) (Atom False)))))))
*)
(*Example sdd_of_var_ex0:
  sdd_of_var 2 (VNode (VAtom 1) (VNode (VAtom 2) (VAtom 3))) true
             (Or [(Atom ATrue,
                   (Or [(Atom (AVar 2 true), (Atom ATrue));
                          (Atom (AVar 2 false), Atom AFalse)]));
                    (Atom ATrue, Or ([(Atom ATrue, Atom AFalse)]))]).
Proof.
  (* coming up with this term SUCKS... *)
  eapply (VarOfNode 2 true (VAtom 1)
                    (VNode (VAtom 2) (VAtom 3))
                    (Atom ATrue)
                    (Or [(Atom (AVar 2 true), Atom ATrue); (Atom (AVar 2 false), Atom AFalse)])
                    (Atom ATrue)
                    (Or ([(Atom ATrue, Atom AFalse)]))
         ).
  - constructor. discriminate.
  - constructor. discriminate.
  - constructor. constructor.
    + constructor.
    + constructor. discriminate.
    + constructor.
  - apply ExpandFalseNode.
    + constructor.
    + constructor.
Qed.*)

Example ex_sdd_apply0:
  sdd_apply OAnd
            (Or ((Atom ATrue, Atom ATrue), (Atom ATrue, Atom AFalse)))
            (Or ((Atom ATrue, Atom ATrue), (Atom ATrue, Atom AFalse)))
            (Or ((Atom ATrue, Atom ATrue), (Atom ATrue, Atom AFalse))).
Proof.
  apply ApplyOr. apply TwoSatA1B2. Admitted.

Example ex_sdd_apply1:
  sdd_apply OAnd (Atom ATrue) (Atom AFalse) (Atom AFalse).
Proof.
  apply ApplyAtom. constructor.
Qed.

Example ex_sdd_apply2:
  sdd_apply OAnd
            (Or ((Atom (AVar 0 true), Atom (AVar 1 true)), (Atom (AVar 0 false), Atom(AFalse))))
            (Or ((Atom (AVar 0 true), Atom (AVar 1 true)), (Atom (AVar 0 false), Atom(AFalse))))
            (Or ((Atom (AVar 0 true), Atom (AVar 1 true)), (Atom (AVar 0 false), Atom(AFalse)))).
Proof.
  constructor. constructor; constructor; constructor; discriminate.
Qed.

Example sdd_and_eq:
  forall  (v : vtree) (a : sdd),
    sdd_vtree a v ->
    sdd_apply OAnd a a a.
Proof.
  intros. destruct a. induction H.
  - constructor. constructor. Admitted.
(*  - constructor. constructor.
  - constructor. constructor.
  - constructor. apply TwoSatA1B2.
    + assumption.
    + Admitted.*) (*decomposability*)

(* Apply preserves vtree consistency
  forall v sdd1 sdd2 sddRes, sdd_vtree sdd1 v → sdd_vtree sdd2 v → sdd_apply OAnd sdd1 sdd2 sddRes → sdd_vtree sddRes v.
*)

(* Inductive orList : list bool -> bool -> Prop :=
| OrListEmpty    : orList [] false
| OrListNonEmpty : forall b bs rest, orList bs rest -> orList (b::bs) (orb b rest).

Inductive sdd_eval : sdd -> bool → varAssign → Prop :=
| SDDEvalATrue    : forall va, sdd_eval (Atom ATrue) true va
| SDDEvalAFalse   : forall va, sdd_eval (Atom AFalse) false va
| SDDEvalAVarSame : forall va n res, assigns va n res → sdd_eval (Atom (AVar n true)) res va
| SDDEvalAVarDiff : forall va n res, assigns va n res → sdd_eval (Atom (AVar n false)) (negb res) va
| SDDEvalOr       : forall va pairs disjuncts res, sdd_eval_orList pairs disjuncts va ->
                                               orList disjuncts res ->
                                               sdd_eval (Or pairs) res va

with

sdd_eval_orList : list (sdd*sdd) → list bool → varAssign → Prop :=
| SDDEvalEmpty    : forall va, sdd_eval_orList [] [] va
| SDDEvalNonEmpty : forall va prime sub tail pRes sRes tailRes,
    sdd_eval prime pRes va →
    sdd_eval sub sRes va →
    sdd_eval_orList tail tailRes va →
    sdd_eval_orList ((prime, sub)::tail) ((andb pRes sRes)::tailRes) va.

Example sdd_eval_1_true :
  sdd_eval (Or [((Atom (AVar 1 true)), (Atom ATrue))]) true (Var 1 true Empty).
Proof.
  eapply SDDEvalOr.
  - apply SDDEvalNonEmpty.
    * apply SDDEvalAVarSame. constructor.
    * apply SDDEvalATrue.
    * apply SDDEvalEmpty.
  - simpl. eapply (OrListNonEmpty true []). apply OrListEmpty.
Qed.*)

(* Inductive compile *)

Ltac rewAndInvert :=
  match goal with
  | [ H1: _ = ?x, H2: _ = ?x |- _ ] =>
      rewrite <- H2 in H1; inversion H1
  end.

Check sdd_ind.

Section sdd_ind'.
  Variable P : sdd -> Prop.
  Hypothesis Or_case : forall p1 s1 p2 s2,
      P p1 -> P p2 -> P s1 -> P s2 -> P (Or ((p1,s1),(p2,s2))).
  Hypothesis Atom_case : forall a,  P (Atom a).

  Fixpoint sdd_ind' (s:sdd) : P s :=
    match s with
    | Atom a => Atom_case a
    | Or ((p1,s1),(p2,s2)) => Or_case p1 s1 p2 s2
                                      (sdd_ind' p1) (sdd_ind' p2) (sdd_ind' s1) (sdd_ind' s2)
   end.
End sdd_ind'.

Theorem apply_preserves_vtree :
  forall sdd1 sdd2 sddRes v o,
    sdd_vtree sdd1 v →
    sdd_vtree sdd2 v →
    sdd_apply o sdd1 sdd2 sddRes →
    sdd_vtree sddRes v.
Proof.
  induction sdd1 using sdd_ind'; induction sdd2 using sdd_ind'.
  - intros sddRes v o Hsdd1 Hsdd2 Happ.
    inversion Happ. inversion H9.
    + inversion Hsdd1; inversion Hsdd2. apply OrSingle.
      * rewrite <- H43 in H34. inversion H34. rewrite <- H48 in H42. rewrite <- H48.
        apply (IHsdd1_1 sdd2_1 pRes1 lvtree OAnd H33 H42 H22).
      *

  - inversion Happ. rewrite <- H in Hsdd1. rewrite <- H1 in Hsdd2.
    inversion Hsdd1. rewrite <- H9 in Hsdd1. rewrite <- H9 in Hsdd2.
    constructor. inversion H2.
    +

Theorem compile_correct :
  forall (boolExp:boolExpr) (sdd:sdd) (input:varAssign) (result:bool),
    compile boolExp sdd →
    eval_sdd sdd result input →
    eval boolExp result input.


Require Import Coq.Logic.Classical_Prop.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.GeneralLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.GeneralLogic.Complete.Canonical_Kripke.
Require Import Logic.GeneralLogic.Complete.Complete_Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimumLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.MinimumLogic.Complete.Truth_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.PropositionalLogic.Complete.Truth_Kripke.
Require Import Logic.PropositionalLogic.Complete.Canonical_Kripke.
Require Logic.PropositionalLogic.DeepEmbedded.PropositionalLanguage.
Require Logic.PropositionalLogic.DeepEmbedded.ProofTheories.
Require Logic.PropositionalLogic.DeepEmbedded.KripkeSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Local Open Scope kripke_model_class.
Import PropositionalLanguageNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.
Import KripkeModelClass.

Section Complete.

Context {Sigma: PropositionalLanguage.PropositionalVariables}
        {CV: Countable PropositionalLanguage.Var}.

Existing Instances PropositionalLanguage.L PropositionalLanguage.minL PropositionalLanguage.pL.

Existing Instances KripkeSemantics.MD KripkeSemantics.kMD KripkeSemantics.R KripkeSemantics.SM KripkeSemantics.kminSM KripkeSemantics.kpSM.

Section General_Completeness.

  Context {GammaP: Provable PropositionalLanguage.L}
          {GammaD: Derivable PropositionalLanguage.L}.

Definition cP : context -> Prop := Intersection _ (Intersection _ derivable_closed orp_witnessed) consistent.

Lemma AL_DC: at_least derivable_closed cP.
Proof. solve_at_least. Qed.

Lemma AL_OW: at_least orp_witnessed cP.
Proof. solve_at_least. Qed.

Lemma AL_CONSI: at_least consistent cP.
Proof. solve_at_least. Qed.

Context {SC: NormalSequentCalculus _ GammaP GammaD}
        {bSC: BasicSequentCalculus _ GammaD}
        {fwSC: FiniteWitnessedSequentCalculus _ GammaD}
        {minSC: MinimumSequentCalculus _ GammaD}
        {ipSC: IntuitionisticPropositionalSequentCalculus _ GammaD}
        {AX: NormalAxiomatization _ GammaP GammaD}
        {minAX: MinimumAxiomatization _ GammaP}
        {ipAX: IntuitionisticPropositionalLogic _ GammaP}.

Lemma LIN_CD: forall x: expr, Lindenbaum_constructable (cannot_derive x) cP.
Proof.
  intros.
  apply Lindenbaum_constructable_suffice; auto.
  + apply PropositionalLanguage.formula_countable; auto.
  + apply Lindenbaum_preserves_cannot_derive.
  + unfold cP.
    repeat apply Lindenbaum_ensures_by_conjunct.
    - apply Lindenbaum_cannot_derive_ensures_derivable_closed.
    - apply Lindenbaum_cannot_derive_ensures_orp_witnessed.
    - apply Lindenbaum_cannot_derive_ensures_consistent.
Qed.

Definition canonical_frame: KripkeSemantics.frame :=
  KripkeSemantics.Build_frame (sig cP) (fun a b => Included _ (proj1_sig a) (proj1_sig b)).

Definition canonical_eval: PropositionalLanguage.Var -> KripkeSemantics.sem canonical_frame :=
  fun p a => proj1_sig a (PropositionalLanguage.varp p).

Definition canonical_Kmodel: @Kmodel KripkeSemantics.MD KripkeSemantics.kMD :=
  KripkeSemantics.Build_Kmodel canonical_frame canonical_eval.

Definition rel: bijection (Kworlds canonical_Kmodel) (sig cP) := bijection_refl.

Definition H_R:
  forall m n Phi Psi, rel m Phi -> rel n Psi ->
    (m <= n <-> Included _ (proj1_sig Phi) (proj1_sig Psi)).
Proof.
  intros.
  change (m = Phi) in H.
  change (n = Psi) in H0.
  subst; reflexivity.
Qed.
Existing Instances PropositionalLanguage.L PropositionalLanguage.minL PropositionalLanguage.pL.

Lemma TRUTH:
  forall x:  expr, forall m Phi, rel m Phi ->
    (KRIPKE: canonical_Kmodel, m |= x <-> proj1_sig Phi x).
Proof.
  induction x.
  + exact (truth_lemma_andp cP rel AL_DC x1 x2 IHx1 IHx2).
  + exact (truth_lemma_orp cP rel AL_DC AL_OW x1 x2 IHx1 IHx2).
  + exact (truth_lemma_impp cP rel H_R AL_DC LIN_CD x1 x2 IHx1 IHx2).
  + exact (truth_lemma_falsep cP rel AL_CONSI).
  + intros; change (m = Phi) in H; subst; reflexivity.
Qed.

End General_Completeness.

Section Intuitionistic_Completeness.

Existing Instances ProofTheories.IntuitionisticPropositionalLogic.GP ProofTheories.IntuitionisticPropositionalLogic.GD ProofTheories.IntuitionisticPropositionalLogic.AX ProofTheories.IntuitionisticPropositionalLogic.minAX ProofTheories.IntuitionisticPropositionalLogic.ipAX.

Existing Instances Axiomatization2SequentCalculus_SC Axiomatization2SequentCalculus_bSC Axiomatization2SequentCalculus_fwSC Axiomatization2SequentCalculus_minSC Axiomatization2SequentCalculus_ipSC.

Import Logic.PropositionalLogic.DeepEmbedded.KripkeSemantics.

Theorem complete_intuitionistic_Kripke_all:
  strongly_complete ProofTheories.IntuitionisticPropositionalLogic.GD KripkeSemantics.SM
    (KripkeModelClass _ (Kmodel_Monotonic + Kmodel_PreOrder)).
Proof.
  apply (@general_completeness _ _ _ _ _ _ _ _ cP rel LIN_CD TRUTH).
  constructor; hnf.
  + intros.
    exact (denote_monotonic cP rel H_R
             (PropositionalLanguage.varp v)
             (TRUTH (PropositionalLanguage.varp v))).
  + exact (po_R cP rel H_R).
Qed.

End Intuitionistic_Completeness.

Section DeMorgan_Completeness.

Existing Instances ProofTheories.DeMorganPropositionalLogic.GP ProofTheories.DeMorganPropositionalLogic.GD ProofTheories.DeMorganPropositionalLogic.AX ProofTheories.DeMorganPropositionalLogic.minAX ProofTheories.DeMorganPropositionalLogic.ipAX ProofTheories.DeMorganPropositionalLogic.dmpAX.

Existing Instances Axiomatization2SequentCalculus_SC Axiomatization2SequentCalculus_bSC Axiomatization2SequentCalculus_fwSC Axiomatization2SequentCalculus_minSC Axiomatization2SequentCalculus_ipSC.

Import Logic.PropositionalLogic.DeepEmbedded.KripkeSemantics.

Theorem complete_DeMorgan_Kripke_branch_join:
  strongly_complete ProofTheories.DeMorganPropositionalLogic.GD KripkeSemantics.SM
    (KripkeModelClass _ (Kmodel_Monotonic + Kmodel_PreOrder + Kmodel_BranchJoin)).
Proof.
  apply (@general_completeness _ _ _ _ _ _ _ _ cP rel LIN_CD TRUTH).
  constructor; [split |]; hnf.
  + intros.
    exact (denote_monotonic cP rel H_R
             (PropositionalLanguage.varp v)
             (TRUTH (PropositionalLanguage.varp v))).
  + exact (po_R cP rel H_R).
  + exact (DeMorgan_canonical_branch_join cP rel H_R AL_DC AL_OW AL_CONSI LIN_CD).
Qed.

End DeMorgan_Completeness.

Section GodelDummett_Completeness.

Existing Instances ProofTheories.GodelDummettPropositionalLogic.GP ProofTheories.GodelDummettPropositionalLogic.GD ProofTheories.GodelDummettPropositionalLogic.AX ProofTheories.GodelDummettPropositionalLogic.minAX ProofTheories.GodelDummettPropositionalLogic.ipAX ProofTheories.GodelDummettPropositionalLogic.gdpAX.

Existing Instances Axiomatization2SequentCalculus_SC Axiomatization2SequentCalculus_bSC Axiomatization2SequentCalculus_fwSC Axiomatization2SequentCalculus_minSC Axiomatization2SequentCalculus_ipSC.

Import Logic.PropositionalLogic.DeepEmbedded.KripkeSemantics.

Theorem complete_GodelDummett_Kripke_no_branch:
  strongly_complete ProofTheories.GodelDummettPropositionalLogic.GD KripkeSemantics.SM
    (KripkeModelClass _ (Kmodel_Monotonic + Kmodel_PreOrder + Kmodel_NoBranch)).
Proof.
  apply (@general_completeness _ _ _ _ _ _ _ _ cP rel LIN_CD TRUTH).
  constructor; [split |]; hnf.
  + intros.
    exact (denote_monotonic cP rel H_R
             (PropositionalLanguage.varp v)
             (TRUTH (PropositionalLanguage.varp v))).
  + exact (po_R cP rel H_R).
  + exact (GodelDummett_canonical_no_branch cP rel H_R AL_DC AL_OW).
Qed.

End GodelDummett_Completeness.

Section Classical_Completeness.

Import Logic.PropositionalLogic.DeepEmbedded.KripkeSemantics.

Existing Instances ProofTheories.ClassicalPropositionalLogic.GP ProofTheories.ClassicalPropositionalLogic.GD ProofTheories.ClassicalPropositionalLogic.AX ProofTheories.ClassicalPropositionalLogic.minAX ProofTheories.ClassicalPropositionalLogic.ipAX ProofTheories.ClassicalPropositionalLogic.cpAX.

Existing Instances Axiomatization2SequentCalculus_SC Axiomatization2SequentCalculus_bSC Axiomatization2SequentCalculus_fwSC Axiomatization2SequentCalculus_minSC Axiomatization2SequentCalculus_ipSC Axiomatization2SequentCalculus_cpSC.

Theorem complete_Classical_Kripke_identity:
  strongly_complete ProofTheories.ClassicalPropositionalLogic.GD KripkeSemantics.SM
    (KripkeModelClass _ (Kmodel_Monotonic + Kmodel_PreOrder + Kmodel_Identity)).
Proof.
  apply (@general_completeness _ _ _ _ _ _ _ _ cP rel LIN_CD TRUTH).
  constructor; [split |]; hnf.
  + intros.
    exact (denote_monotonic cP rel H_R
             (PropositionalLanguage.varp v)
             (TRUTH (PropositionalLanguage.varp v))).
  + exact (po_R cP rel H_R).
  + exact (classical_canonical_ident cP rel H_R AL_DC AL_OW AL_CONSI).
Qed.

End Classical_Completeness.

End Complete.


Require Import Relations
               Program.
Require Export rewriting_system.

(* Signature for languages with reduction semantics. *)

Module Type RED_SEM.

  Parameters
  (term         : Set)
  (elem_context : Set)
  (ckind        : Set)
  (ckind_trans  : ckind -> elem_context -> ckind)
  (elem_plug     : term -> elem_context -> term)
  (redex         : ckind -> Set)
  (value         : ckind -> Set)
  (value_to_term : forall {k}, value k -> term)
  (redex_to_term : forall {k}, redex k -> term)
  (init_ckind    : ckind)
  (dead_ckind    : ckind -> Prop)
  (contract : forall {k}, redex k -> option term).

  Infix "+>"           := ckind_trans (at level 50, left associativity).
  Notation "ec :[ t ]" := (elem_plug t ec) (at level 0).
  Coercion  value_to_term : value >-> term.
  Coercion  redex_to_term : redex >-> term.

  Inductive context (k1 : ckind) : ckind -> Set :=
  | empty : context k1 k1
  | ccons : forall (ec : elem_context) {k2}, context k1 k2 -> context k1 (k2+>ec).
  Arguments empty {k1}. Arguments ccons {k1} _ {k2} _.
  Notation "[.]"      := empty.
  Notation "[.]( k )" := (@empty k).
  Infix    "=:"       := ccons (at level 60, right associativity).

  Fixpoint compose {k1 k2} (c0 : context k1 k2)
                      {k3} (c1 : context k3 k1) : context k3 k2 :=
      match c0 in context _ k2' return context k3 k2' with
      | [.]     => c1
      | ec=:c0' => ec =: compose c0' c1
      end.
  Infix "~+" := compose (at level 60, right associativity).

  Fixpoint plug (t : term) {k1 k2} (c : context k1 k2) : term :=
      match c with
      | [.]    => t
      | ec=:c' => plug ec:[t] c'
      end.
  Notation "c [ t ]" := (plug t c) (at level 0).

  Definition immediate_ec ec t := exists t', ec:[t'] = t.

  Inductive decomp k : Set :=
  | d_red : forall {k'}, redex k' -> context k k' -> decomp k
  | d_val : value k -> decomp k.
  Arguments d_val {k} _. Arguments d_red {k} {k'} _ _.

  Definition decomp_to_term {k} (d : decomp k) :=
      match d with
      | d_val v   => value_to_term v
      | d_red r c => c[r]
      end.
  Coercion decomp_to_term : decomp >-> term.

  Definition dec (t : term) k (d : decomp k) : Prop :=
      ~dead_ckind k /\ t = d.

  Definition reduce k t1 t2 :=
      exists {k'} (c : context k k') (r : redex k') t,  dec t1 k (d_red r c) /\
          contract r = Some t /\ t2 = c[t].

  Instance lrws : LABELED_REWRITING_SYSTEM ckind term :=
  { ltransition := reduce }.

  Instance rws : REWRITING_SYSTEM term :=
  { transition := reduce init_ckind }.

  Axioms
  (init_ckind_alive :
       ~dead_ckind init_ckind)

  (death_propagation :                                                       forall k ec,
       dead_ckind k -> dead_ckind (k+>ec))

  (proper_death :                                                               forall k,
       dead_ckind k -> ~ exists (r : redex k), True)

  (value_to_term_injective :                                 forall {k} (v v' : value k),
       value_to_term v = value_to_term v' -> v = v')

  (redex_to_term_injective :                                 forall {k} (r r' : redex k),
       redex_to_term r = redex_to_term r' -> r = r')

  (elem_plug_injective1 :                                                forall ec t0 t1,
       ec:[t0] = ec:[t1] -> t0 = t1)

  (value_trivial1 :                                                    forall {k} ec {t},
       forall v : value k,  ~dead_ckind (k+>ec)  ->  ec:[t] = v ->
           exists (v' : value (k+>ec)), t = v')

  (value_redex :                                                              forall {k},
       forall (v : value k) (r : redex k), value_to_term v <> redex_to_term r)

  (decompose :                                                                forall t k,
       ~dead_ckind k -> exists d : decomp k, dec t k d).

  Class SafeKRegion (k : ckind) (P : term -> Prop) :=
  {
      preservation :                                                        forall t1 t2,
          P t1  ->  k |~ t1 → t2  ->  P t2;
      progress :                                                               forall t1,
          P t1  ->  (exists (v : value k), t1 = v) \/ (exists t2, k |~ t1 → t2)
  }.

End RED_SEM.

Module Type RED_SEM_DET (R : RED_SEM). Import R.

  Axiom dec_is_det :                                      forall {t k} {d d0 : decomp k},
      dec t k d -> dec t k d0 -> d = d0.

End RED_SEM_DET.