Require Import EqNat.
Require Import Bool.
Require Import String.
Require Import Arith.Bool_nat.
Require Import Div2.
Require Import Heap.
Require Import RefinementNew.
Require Import Program.Tactics.
Module Language.

Definition Ptr := Addr.t.

Inductive WhileL (a : Type) : Type :=
  | New    : forall v, v -> (Ptr -> WhileL a) -> WhileL a
  | Read   : forall v, Ptr -> (v -> WhileL a) -> WhileL a
  | Write : forall {v}, Ptr -> v -> WhileL a  -> WhileL a
  | While  : (S -> Prop) -> (S -> bool) -> WhileL a -> WhileL a (*TODO add variant *)
  | Spec   : PT a -> WhileL a
  | Return : a -> WhileL a.

Notation "addr ≔ exp" := (Write id addr) (at level 52).

(* Joao: is this strong enough? or should we add to the post-condition "find s p = None" ? *)
(* Wouter: we could add this... but that would only be useful if we wanted to access unallocated memory... *)
Definition NewPT {a : Type} (x : a) : PT Ptr :=
  Predicate _ (fun s => True) (* trivial precondition *)
              (fun s _ p s' => (* given initial state s, result pointer p, and final state s' *)
                 (forall p', p' <> p -> find s p = find s' p') (* all existing addresses are unmodified *)
                 /\ find s' p = Some (dyn _ x)). (* and the heap now lets p point to x *)

Definition ReadPT {a : Type} (ptr : Ptr) : PT a :=
  Predicate _ (fun s => exists v, find s ptr = Some (dyn a v)) (* if there is a value for the ptr *)
              (fun s pres v s' => s = s' /\ find s ptr = Some (dyn a v)). (* we need to return this value and leave the heap untouched *)
(* The postcondition here is slightly crappy -- any ideas? We can't project from the exists as it is in Prop *)
(* Joao: Not really. Unless we change PT def with a precondition like S -> (Prop,a). *)

Definition Is_false (b : bool) :=
  match b with
    | true => False
    | false => True
  end.

Definition WhilePT {a : Type} (inv : Pow S) (cond : S -> bool) (body : PT a) : PT a :=
  let whilePre := (fun s =>   (* The invariant should hold initially *)
                             inv s /\
                              (* If we enter the loop, the precondition of the body should hold *)
                            { H : (forall s, Is_true (cond s) /\ inv s -> pre body s) &
                              (* The loop body should preserve the invariant *)
                            (forall s v s' (t : Is_true (cond s) /\ inv s), post body s (H s t) v s' -> inv s')})
  in
  let whilePost := (fun _ _ _ s' => inv s' /\ Is_false (cond s')) in
  [ whilePre , whilePost ].

Ltac pt_trivial := unfold subset in *; intros; now eauto.

Definition refineTransPT {a} (pt2 pt1 pt3 : PT a) :
  pt1 ⊏ pt2 -> pt2 ⊏ pt3 -> pt1 ⊏ pt3.
    intros [pre12 post12] [pre23 post23].
    set (d (s : S) (pre1s : pre pt1 s) := pre23 s (pre12 s pre1s)).
    refine (Refinement pt1 pt3 d _); pt_trivial.
  Defined.

Definition refineReflPT {a} (pt : PT a) : pt ⊏ pt.
  refine (Refinement pt pt (fun s pres => pres) _); pt_trivial.
  Defined.

Fixpoint semantics {a : Type} (w: WhileL a) : PT a :=
  match w with
    | New _ _ v k => BindPT (NewPT v) (fun p => semantics (k p))
    | Read _ _ ptr k => BindPT (ReadPT ptr) (fun v => semantics (k v))
    | Write _ ptr v k =>
      SeqPT (AssignPT (fun h => M.In ptr h) (fun s => (update s ptr (dyn _ v))))
             (semantics k)
    | While _ inv c body => WhilePT inv c (semantics body)
    | Spec _ s => s
    | Return _ x => Predicate _ (fun s => True) (fun s _ v s' => s = s' /\ v = x)
  end.

Definition preConditionOf {a : Type} (w : WhileL a) : Pow S :=
  match semantics w with
    | Predicate _ p _ => p
  end.

Definition postConditionOf {a : Type} (w : WhileL a)
  : (forall s : S, preConditionOf w s -> a -> Pow S) :=
  match semantics w as x return (forall s : S, match x with | [p, _] => p end s -> a -> Pow S) with
    | [pre, post] => post
  end.

Fixpoint bind {a b : Type} (w : WhileL a) (k : a -> WhileL b) {struct w} : WhileL b :=
  match w with
  | New _ _ v c  => New _ _ v (fun p => bind (c p) k)
  | Read _ _ p c => Read _ _ p (fun v => bind (c v) k)
  | Write _ p v c => Write _ p v (bind c k)
  | While _ Inv cond body => While _ Inv cond (bind body k)
  | Spec _ pt => Spec _
        match pt with
        | [pre, post] =>
            [fun s : S => {h : pre s | forall (s' : S) (v : a), post s h v s' -> preConditionOf (k v) s'},
            fun (s : S)
              (h : {h : pre s |
                     forall (s' : S) (v : a),
                       post s h v s' -> preConditionOf (k v) s'})
              (y : b) (s'' : S) =>
            exists (s' : S) (x : a),
              {p : post s (proj1_sig h) x s' |
              postConditionOf (k x) s' (proj2_sig h s' x p) y s''}]
        end
  | Return _ x => k x
  end.

Notation "a ; b" := (bind a (fun _ => b)) (at level 60).

Fixpoint isExecutable {a : Type} (w: WhileL a) : Prop :=
  match w with
    | New _ _ _ k     => forall ptr, isExecutable (k ptr)
    | Read _ _ _ k    => forall v, isExecutable (k v)
    | Write _ _ _ w   => isExecutable w
    | While _ inv c b => isExecutable b
    | Spec _ pt       => False
    | Return _ a      => True
  end.

Definition wrefines {a : Type} (w1 w2 : WhileL a) := (semantics w1) ⊏ (semantics w2).

Notation "P1 ⊑ P2" := (wrefines P1 P2) (at level 90, no associativity) : type_scope.

Ltac unfold_refinements := unfold wrefines, semantics, preConditionOf, postConditionOf.

Definition refineTrans {a} (w2 w1 w3 : WhileL a) :
  w1 ⊑ w2 -> w2 ⊑ w3 -> w1 ⊑ w3.
    unfold_refinements; now apply refineTransPT.
  Defined.

Definition refineRefl {a} (w : WhileL a) :
  w ⊑ w.
    unfold_refinements; apply refineReflPT.
  Defined.

Lemma refineBind {a} (Pre : Pow S) (Mid Post : a -> Pow S) :
  let w := Spec _ ([ Pre , fun _ _ => Post ]) in
  w ⊑ bind (Spec _ ([Pre , fun _ _ => Mid ]))
           (fun a => Spec _ ([Mid a , fun _ _ => Post ])).
Proof.
  unfold_refinements; simpl.
  assert (d : pre ([Pre, fun (s : S) (_ : Pre s) => Post]) ⊂
       pre ([fun s : S =>
      {_ : Pre s | forall (s' : S) (v : a), Mid v s' -> Mid v s'},
     fun (s : S)
       (_ : {_ : Pre s | forall (s' : S) (v : a), Mid v s' -> Mid v s'})
       (y : a) (s'' : S) =>
       exists (s' : S) (x : a), {_ : Mid x s' | Post y s''}])).
  unfold subset; simpl in *; destruct_conjs; intros; split; auto.
  apply (Refinement _ _ d).
  unfold post, subset; intros; destruct_conjs; now trivial.
Qed.

Lemma refineSeq {a} (Pre Mid Post : Pow S) :
  let w := Spec a ([ Pre , fun _ _ _ => Post ]) in
  w ⊑ bind (Spec a ([Pre , fun _ _ _ => Mid ]))
           (fun _ => Spec a ([Mid , fun _ _ _ => Post ])).
Proof.
  apply refineBind.
Qed.

Lemma refineIf {a} (cond : bool) (pt : PT a) :
  let branchPre (P : S -> Prop) := fun s => prod (pre pt s) (P s) in
  let thenBranch := [branchPre (fun s => Is_true cond),
                     fun s pre s' => post pt s (fst pre) s' ] in
  let elseBranch := [branchPre (fun s => Is_false cond),
                     fun s pre s' => post pt s (fst pre) s' ] in
  (Spec a pt) ⊑ if cond then (Spec a thenBranch) else (Spec a elseBranch).
Proof.
  unfold_refinements; destruct cond; simpl;
  set (d := (fun s pres => pair pres I) : pre pt ⊂ pre ([fun s : S => (pre pt s * True)%type,
                                        fun (s : S) (pre : pre pt s * True) (s' : a) => post pt s (fst pre) s']));
  apply (Refinement _ _ d);
  intros; refine_simpl.
Qed.

Lemma refineWhilePT {a} (inv : Pow S) (cond : S -> bool) (Q : Pow S) :
  let pt := [inv , fun _ _ _ s' => inv s' /\ Q s'] in
  let body : PT a := [fun s => inv s /\ Is_true (cond s), (fun _ _ _ s => inv s)] in
  (forall s, Is_false (cond s) -> Q s) ->
  pt ⊏ WhilePT inv cond body.
  Proof.
    intros pt body QH; simpl in *.
    assert (d: pre pt ⊂ pre (WhilePT inv cond body)).
    unfold subset, pt,WhilePT; simpl; intros; split; [assumption | ].
    split.
    intros s' H1.
    destruct H1; split; assumption.
    intros s' v s'' [H1 H2] H3; assumption.
    apply (Refinement _ _ d).
    intros s PreS v' s' [H1 H2].
    split; [ | apply QH]; assumption.
Qed.

Lemma refineWhile {a} (inv : Pow S) (cond : S -> bool) (Q : Pow S)
  (StrQ : forall s, Is_false (cond s) -> Q s) :
  let w := Spec a ([inv , fun _ _ _ s' => inv s' /\ Q s']) in
  let body := [fun s => inv s /\ Is_true (cond s), (fun _ _ _ s => inv s)] in
  w ⊑ While a inv cond (Spec a body).
  Proof.
    unfold "⊑",semantics.
    now (apply refineWhilePT).
Qed.

Ltac destruct_unit :=
  match goal with
    [ H : unit |- _ ] => destruct H
  end.

Ltac destruct_units := repeat destruct_unit.
Ltac refine_simpl := unfold pre, post, subset; intros; simpl in *; destruct_conjs; repeat split; repeat subst; destruct_units.
Ltac semantic_trivial := unfold semantics, pre, post; simpl; destruct_conjs; repeat split; now intuition.

Lemma refineAssign {a : Type} (w : WhileL unit) (ptr : Ptr) (x : a)
  (h : forall (s : S) (pre : pre (semantics w) s), post (semantics w) s pre tt (update s ptr (dyn a x)))
  (h' : pre (semantics w) ⊂ (fun h => M.In ptr h))
  : w ⊑ Write _ ptr x (Return _ tt).
  Proof.
    assert (d: pre (semantics w) ⊂ pre (semantics (Write _ ptr x (Return _ tt)))) by
      (destruct (semantics w); semantic_trivial).
    apply (Refinement _ _ d); refine_simpl; destruct (semantics w); now eapply h.
  Qed.

Definition subst {a : Type} (ptr : Ptr) (v : a) (s : S) : S :=
   update s ptr (dyn a v).

Definition refineFollowAssignPre {a : Type} (ptr : Ptr) (x : a) (P : Pow S)
           (Q Q' : forall (s : S), P s -> Pow S) :
  let w  := Spec unit ([P,fun s p _ s' => Q s p s']) in
  let w' := Spec unit ([P,fun s p _ s' => Q' s p s']) in
  (forall s pres s', Q' s pres s' -> prod (Q s pres (subst ptr x s')) (M.In ptr s')) ->
  pre (semantics w) ⊂ pre (semantics (w' ; Write unit ptr x (Return unit tt))).
  intros w w' HQ.
  refine_simpl.
  unfold preConditionOf; simpl.
  exists H.
  intros s' v H'.
  apply HQ in H' as [H' HIn].
  exists HIn.
  intros s'' v' H''.
  apply I.
Defined.

Lemma refineFollowAssign {a : Type} (ptr : Ptr) (x : a) (P : Pow S)
(Q Q' : forall (s : S), P s -> Pow S) :
  let w  := Spec _ ([P,fun s p _ s' => Q s p s']) in
  let w' := Spec unit ([P,fun s p _ s' => Q' s p s']) in
  (forall s pres s', Q' s pres s' -> prod (Q s pres (subst ptr x s')) (M.In ptr s')) ->
  w ⊑ (w' ; Write _ ptr x (Return _ tt)).
Proof.
  intros w w' HQ.
  set (d := refineFollowAssignPre _ _ _ _ _ HQ :
             pre (semantics w) ⊂
             pre (semantics (w' ; Write unit ptr x (Return unit tt)))).
  apply (Refinement _ _ d); refine_simpl.
  unfold subset, preConditionOf, postConditionOf in *.
  simpl in *.
  destruct H2.
  repeat destruct H0; subst.
  destruct x3; subst.
  eapply fst.
  apply (HQ _ _ _ H1).
Qed.

Definition refineFollowAssignPre' {a : Type} (ptr : Ptr) (P : Pow S)
(Q : forall (s : S), P s -> Pow S) (Q' : forall (s : S), P s -> a -> Pow S) :
  let w  := Spec unit ([P,fun s pres _ s' => Q s pres s']) in
  let w' := Spec _ ([P,Q']) in
  (forall s pres v s', Q' s pres v s' -> prod (Q s pres (subst ptr v s')) (M.In ptr s')) ->
  (pre (semantics w) ⊂
      pre (semantics (bind w' (fun (v : a) => Write _ ptr v (Return _ tt))))).
Proof.
  intros w w' HQ.
  refine_simpl.
  unfold preConditionOf; simpl.
  exists H.
  intros s' v H'.
  apply HQ in H' as [H' HIn].
  exists HIn.
  intros s'' v' H''.
  apply I.
Defined.

Lemma refineFollowAssign' {a : Type} (ptr : Ptr) (P : Pow S)
(Q : forall (s : S), P s -> Pow S) (Q' : forall (s : S), P s -> a -> Pow S) :
  let w  := Spec unit ([P,fun s pres _ s' => Q s pres s']) in
  let w' := Spec _ ([P,Q']) in
  (forall s pres v s', Q' s pres v s' -> prod (Q s pres (subst ptr v s')) (M.In ptr s')) ->
  w ⊑ (bind w' (fun v => Write _ ptr v (Return _ tt))).
Proof.
  intros w w' HQ.
  unfold "⊑".
  apply (Refinement _ _ (refineFollowAssignPre' _ _ _ _ HQ)); refine_simpl.
  unfold subset, preConditionOf, postConditionOf in *.
  simpl in *.
  repeat destruct H2; subst.
  destruct x2; subst.
  eapply fst.
  apply (HQ _ _ _ _ H1).
Qed.

Ltac refine_assign ptr x := eapply (refineAssign _ ptr x _ _).
(* Wouter: this is a first approximation of this tactic, it probably needs to do quite a bit more... *)

Lemma refineSeqAssocR {a} : forall (w w1 w2 w3 : WhileL a),
  (w ⊑ (w1 ; w2) ; w3) -> (w ⊑ w1 ; w2 ; w3).
Proof.
  intros.
  apply (refineTrans ((w1; w2); w3)).
  assumption.
  unfold "⊑"; simpl.
  set (d := (fun s pres => pres) : pre (semantics ((w1; w2); w3)) ⊂
                                  pre (semantics (w1; w2; w3))).
  apply (Refinement _ _ d).
  refine_simpl.
  apply H0.
Defined.

Lemma refineSeqAssocL {a} : forall (w w1 w2 w3 : WhileL a),
  (w ⊑ w1 ; w2 ; w3) -> (w ⊑ (w1 ; w2) ; w3).
Proof.
  intros.
  apply (refineTrans (w1; w2; w3)).
  assumption.
  unfold "⊑"; simpl.
  set (d := (fun s pres => pres) : pre (semantics (w1; w2; w3)) ⊂
                                  pre (semantics ((w1; w2); w3))).
  apply (Refinement _ _ d).
  refine_simpl.
  apply H0.
Defined.

(* Joao: maybe we want monad associativity laws? For instance: *)
Lemma refineBindAssocR {a b c} :
  forall (w : WhileL a) (w1 : WhileL b) (w2 : b -> WhileL c) (w3 : c -> WhileL a),
  w ⊑ (bind (bind w1 w2) w3) ->
  w ⊑ (bind w1 (fun x => bind (w2 x) w3)).
Proof.
  intros.
  apply (refineTrans (bind (bind w1 w2) w3)).
  assumption.
  unfold "⊑" in *; simpl in *.
  assert (d : pre (semantics (bind (bind w1 w2) w3)) ⊂
                  pre (semantics (bind w1 (fun x : b => bind (w2 x) w3)))).
Admitted.

(** Just a brief example showing how the language currently looks like **)

Definition P : Addr.t := Addr.MkAddr 0.
Definition Q : Addr.t := Addr.MkAddr 1.
Definition N : Addr.t := Addr.MkAddr 2.

Definition SWAP : WhileL unit.

  apply (Spec _).
  refine (Predicate _ (fun s => exists (p : Ptr), M.In p s) _).
  intros s H v s'.
  .... finish me
  Spec a ([ fun s => M.In P s /\ M.In Q s /\ M.In N s
           , fun s _ _ s' => find s P = find s' Q
                            /\ find s Q = find s' P
                            /\ M.In P s'
                            /\ M.In Q s'
                            /\ M.In N s']).

(* SWAP ⊑ (N ::= Var Q ; Q ::= Var P ; P ::= Var N) *)
Definition swapResult (a : Type) :
  let SetQinN (s : WhileL unit) := (Read _ a Q) (fun v => Write _ N v s) in
  let SetPinQ (s : WhileL unit) := (Read _ a P) (fun v => Write _ Q v s) in
  let SetNinP (s : WhileL unit) := (Read _ a N) (fun v => Write _ P v s) in
  SWAP' ⊑ SetQinN (SetPinQ (SetNinP (Return _ tt))).
Proof.
  unfold SWAP'; simpl.
  eapply refineFollowAssign' with (ptr := P).
  (*
                                 (Q' := fun s _ _ s' => find s Q = find s' N
                                                   /\ find s P = find s' Q
                                                   /\ M.In P s' /\ M.In Q s' /\ M.In N s').
  *)
Admitted.

(** End of example **)

(* Joao: I stopped here *)

Definition refineSplit (w1 w2 w3 w4 : WhileL) :
  (w1 ⊑ w3) -> (w2 ⊑ w4) -> (w1 ; w2) ⊑ (w3 ; w4).
    unfold "⊑",semantics; apply refineSplitPT.
  Defined.

Definition refineSplitIf (w1 w2 w3 w4 : WhileL) (cond : BExpr) :
  (w1 ⊑ w3) -> (w2 ⊑ w4) -> If cond w1 w2 ⊑ If cond w3 w4.
    unfold "⊑",semantics; apply refineSplitIfPT.
  Defined.

Definition refineBody : forall (inv : Pow S) (cond : BExpr) (bodyL bodyR : WhileL),
  bodyL ⊑ bodyR ->
  While inv cond bodyL ⊑ While inv cond bodyR.
Proof.
  unfold "⊑",semantics.
  intros.
  assert (d: pre (semantics (While inv cond bodyL)) ⊂
             pre (semantics (While inv cond bodyR))).
  unfold subset; simpl; intros s [Inv [H1 H2]]; split.
  assumption.
  inversion H as [Pre Post].
  set (E := fun s0 H => (Pre s0 (H1 _ H))).
  exists E.
  intros s0 s' P Q.
  eapply H2.
  apply Post.
  unfold E in Q.
  exact Q.

  apply (Refinement _ _ d).
  intros.
  unfold post,pre,subset in *.
  simpl in *.
  intros; assumption.
Defined.

End Semantics.

Module CodeGeneration.

Import Language.
Import Heap.

Open Local Scope string_scope.

Definition t := Addr.t.

Definition identToCode (ident: Identifier) : string :=
  "x_" ++ (Addr.printAddr ident print_nat).

Fixpoint exprToCode (e: Expr) : string :=
  match e with
  | Var n     => identToCode n
  | EConst n  => print_nat n
  | Plus x y  => exprToCode x ++ " + " ++ exprToCode y
  | Minus x y => exprToCode x ++ " - " ++ exprToCode y
  | Mult x y  => exprToCode x ++ " * " ++ exprToCode y
  | Div2 x    => "(" ++ exprToCode x ++ ") / 2"
  end.

Fixpoint bExprToCode (e: BExpr) : string :=
  match e with
  | BConst b  => match b with
                 | true  => "true"
                 | false => "false"
                 end
  | And b1 b2 => "(" ++ bExprToCode b1 ++ " && " ++ bExprToCode b2 ++ ")"
  | Or b1 b2  => "(" ++ bExprToCode b1 ++ " || " ++ bExprToCode b2 ++ ")"
  | Not e     => "!" ++ bExprToCode e
  | Eq e1 e2  => "(" ++ exprToCode e1 ++ " == " ++ exprToCode e2  ++ ")"
  | Lt e1 e2  => "(" ++ exprToCode e1 ++ " < " ++ exprToCode e2  ++ ")"
  | Le e1 e2  => "(" ++ exprToCode e1 ++ " <= " ++ exprToCode e2  ++ ")"
  | Gt e1 e2  => "(" ++ exprToCode e1 ++ " > " ++ exprToCode e2  ++ ")"
  | Ge e1 e2  => "(" ++ exprToCode e1 ++ " >= " ++ exprToCode e2  ++ ")"
  end.

Fixpoint sp (n: nat) : string :=
   match n with
   | 0 => ""
   | Datatypes.S n' => " " ++ (sp n')
end.

Lemma isExecSeq1 : forall w1 w2, isExecutable (Seq w1 w2) -> isExecutable w1.
Proof. intros; destruct H as [H1 H2]; assumption. Qed.

Lemma isExecSeq2 : forall w1 w2, isExecutable (Seq w1 w2) -> isExecutable w2.
Proof. intros; destruct H as [H1 H2]; assumption. Qed.

Lemma isExecThen : forall c t e, isExecutable (If c t e) -> isExecutable t.
Proof. intros; destruct H as [H1 H2]; assumption. Qed.

Lemma isExecElse : forall c t e, isExecutable (If c t e) -> isExecutable e.
Proof. intros; destruct H as [H1 H2]; assumption. Qed.

Lemma isExecBody : forall inv c b, isExecutable (While inv c b) -> isExecutable b.
Proof. intros; assumption. Qed.

Fixpoint toCode (w: WhileL) (p: isExecutable w) (indent: nat) : string :=
  match w as w' return (isExecutable w' -> string) with
  | New x          => fun _ => "FIXME" (*fun _ => do n <- fresh; let varName = "x_" ++ show n ; return (varName ++ "=" ++ exprToCode x) *)
    (* FIXME: should not be x in the above line, but the freshly allocated address *)
  | Skip           => fun _ => ((sp indent) ++ "skip;")
  | Assign id exp  => fun _ =>
                      ((sp indent) ++ (identToCode id) ++ " = " ++ (exprToCode exp)) ++ ";"
  | Seq w1 w2      => fun p' =>
                      (toCode w1 (isExecSeq1 w1 w2 p') indent) ++ "
" ++
                      (toCode w2 (isExecSeq2 w1 w2 p') indent)
  | If c t e       => fun p' =>
                      (sp indent) ++ "if " ++ (bExprToCode c) ++ "
" ++
                      (sp indent) ++ "{
" ++
                      (toCode t (isExecThen c t e p') (indent+4)) ++ "
" ++
                      (sp indent) ++ "}
" ++
                      (sp indent) ++ "else
" ++
                      (sp indent) ++ "{
" ++
                      (toCode e (isExecElse c t e p') (indent+4)) ++ "
" ++
                      (sp indent) ++ "}"
  | While inv c b  => fun p' =>
                      (sp indent) ++ "while (" ++ (bExprToCode c) ++ ")
" ++
                      (sp indent) ++ "{
" ++
                      (toCode b (isExecBody inv c b p') (indent+4)) ++ "
" ++
                      (sp indent) ++ "}"
  | Spec pt        => fun p' => match p' with
                                end
  end p.

Definition wrapMain (code : string) : string :=
"int main() {
    int n,p,q,r;
" ++ code ++ "
    return 0;
}".

Definition whileToCode (w: WhileL) (p: isExecutable w) : string :=
  wrapMain (toCode w p 4).

End CodeGeneration.


(****************************************************************************

          IEEE754  :  Paux

          Laurent Thery

  ******************************************************************************)

Require Export Digit.
Require Export Option.
Require Export Inverse_Image.
Require Export Wf_nat.
Require Import BinPos.

Fixpoint exp (n m : nat) {struct m} : nat :=
  match m with
  | O => 1
  | S m' => n * exp n m'
  end.

Theorem expPlus : forall n p q : nat, exp n (p + q) = exp n p * exp n q.
intros n p; elim p; simpl in |- *; auto with arith.
intros n0 H' q; rewrite mult_assoc_reverse; rewrite <- H'; auto.
Qed.

Fixpoint positive_exp (p n : positive) {struct n} : positive :=
  match n with
  | xH => p
  | xO n1 =>
      match positive_exp p n1 with
      | r =>
          (fun (x : positive) (_ : positive -> positive)
             (y : positive) => (x * y)%positive) r (
            fun x => x) r
      end
  | xI n1 =>
      match positive_exp p n1 with
      | r =>
          (fun (x : positive) (_ : positive -> positive)
             (y : positive) => (x * y)%positive) p (
            fun x => x)
            ((fun (x : positive)
                (_ : positive -> positive)
                (y : positive) => (x * y)%positive) r (
               fun x => x) r)
      end
  end.

Theorem positive_exp_correct :
 forall p n : positive,
 nat_of_P (positive_exp p n) =
 exp (nat_of_P p) (nat_of_P n).
intros p n; elim n; simpl in |- *; auto.
intros p0 H.
repeat
 rewrite
  (fun (x y : positive) (_ : positive -> positive) =>
   nat_of_P_mult_morphism x y); simpl in |- *;
 auto.
rewrite ZL6; rewrite expPlus; rewrite H; auto.
intros p0 H.
repeat
 rewrite
  (fun (x y : positive) (_ : positive -> positive) =>
   nat_of_P_mult_morphism x y); simpl in |- *;
 auto.
rewrite H; rewrite <- expPlus; rewrite <- ZL6; auto.
rewrite mult_comm; simpl in |- *; auto.
Qed.

Fixpoint Pdiv (p q : positive) {struct p} :
 Option positive * Option positive :=
  match p with
  | xH =>
      match q with
      | xH => (Some _ 1%positive, None _)
      | xO r => (None _, Some _ p)
      | xI r => (None _, Some _ p)
      end
  | xI p' =>
      match Pdiv p' q with
      | (None, None) =>
          match (1 - Zpos q)%Z with
          | Z0 => (Some _ 1%positive, None _)
          | Zpos r' => (Some _ 1%positive, Some _ r')
          | Zneg r' => (None _, Some _ 1%positive)
          end
      | (None, Some r1) =>
          match (Zpos (xI r1) - Zpos q)%Z with
          | Z0 => (Some _ 1%positive, None _)
          | Zpos r' => (Some _ 1%positive, Some _ r')
          | Zneg r' => (None _, Some _ (xI r1))
          end
      | (Some q1, None) =>
          match (1 - Zpos q)%Z with
          | Z0 => (Some _ (xI q1), None _)
          | Zpos r' => (Some _ (xI q1), Some _ r')
          | Zneg r' => (Some _ (xO q1), Some _ 1%positive)
          end
      | (Some q1, Some r1) =>
          match (Zpos (xI r1) - Zpos q)%Z with
          | Z0 => (Some _ (xI q1), None _)
          | Zpos r' => (Some _ (xI q1), Some _ r')
          | Zneg r' => (Some _ (xO q1), Some _ (xI r1))
          end
      end
  | xO p' =>
      match Pdiv p' q with
      | (None, None) => (None _, None _)
      | (None, Some r1) =>
          match (Zpos (xO r1) - Zpos q)%Z with
          | Z0 => (Some _ 1%positive, None _)
          | Zpos r' => (Some _ 1%positive, Some _ r')
          | Zneg r' => (None _, Some _ (xO r1))
          end
      | (Some q1, None) => (Some _ (xO q1), None _)
      | (Some q1, Some r1) =>
          match (Zpos (xO r1) - Zpos q)%Z with
          | Z0 => (Some _ (xI q1), None _)
          | Zpos r' => (Some _ (xI q1), Some _ r')
          | Zneg r' => (Some _ (xO q1), Some _ (xO r1))
          end
      end
  end.

Definition oZ h := match h with
                   | None => 0
                   | Some p => nat_of_P p
                   end.

Theorem Pdiv_correct :
 forall p q,
 nat_of_P p =
 oZ (fst (Pdiv p q)) * nat_of_P q + oZ (snd (Pdiv p q)) /\
 oZ (snd (Pdiv p q)) < nat_of_P q.
intros p q; elim p; simpl in |- *; auto.
3: case q; simpl in |- *; try intros q1; split; auto;
    unfold nat_of_P in |- *; simpl in |- *;
    auto with arith.
intros p'; simpl in |- *; case (Pdiv p' q); simpl in |- *;
 intros q1 r1 (H1, H2); split.
unfold nat_of_P in |- *; simpl in |- *.
rewrite ZL6; rewrite H1.
case q1; case r1; simpl in |- *.
intros r2 q2. rewrite Z.pos_sub_spec; unfold Pos.compare.
CaseEq (Pcompare (xI r2) q Datatypes.Eq);
 simpl in |- *; auto.
intros H3; rewrite <- (Pcompare_Eq_eq _ _ H3); simpl in |- *;
 unfold nat_of_P in |- *; simpl in |- *.
apply f_equal with (f := S); repeat rewrite (fun x y => mult_comm x (S y));
 repeat rewrite ZL6; unfold nat_of_P in |- *;
 simpl in |- *; ring.
intros H3; unfold nat_of_P in |- *; simpl in |- *;
 repeat rewrite ZL6; unfold nat_of_P in |- *;
 repeat rewrite (fun x y => plus_comm x (S y)); simpl in |- *;
 apply f_equal with (f := S); ring.
intros H3; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6));
 unfold Pminus in |- *; rewrite H4.
apply
 trans_equal
  with
    (nat_of_P q + nat_of_P h +
     Pmult_nat q2 2 * Pmult_nat q 1);
 [ rewrite <- nat_of_P_plus_morphism; rewrite H5; simpl in |- *;
    repeat rewrite ZL6; unfold nat_of_P in |- *;
    apply f_equal with (f := S)
 | unfold nat_of_P in |- * ]; ring.
intros r2. rewrite Z.pos_sub_spec; unfold Pos.compare.
CaseEq (Pcompare 1 q Datatypes.Eq); simpl in |- *; auto.
intros H3; rewrite <- (Pcompare_Eq_eq _ _ H3); simpl in |- *;
 repeat rewrite ZL6; unfold nat_of_P in |- *; simpl in |- *;
 apply f_equal with (f := S);ring.
intros H3; unfold nat_of_P in |- *; simpl in |- *;
 repeat rewrite (fun x y => plus_comm x (S y));
 simpl in |- *; apply f_equal with (f := S); repeat rewrite ZL6;
   unfold nat_of_P in |- *; simpl in |- *; ring.
intros H3; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6));
 unfold Pminus in |- *; rewrite H4;
 apply
  trans_equal
   with
     (nat_of_P q + nat_of_P h +
      Pmult_nat r2 2 * Pmult_nat q 1);
 [ rewrite <- nat_of_P_plus_morphism; rewrite H5; simpl in |- *;
    repeat rewrite ZL6; unfold nat_of_P in |- *;
    apply f_equal with (f := S)
 | unfold nat_of_P in |- * ]; ring.
intros r2. rewrite Z.pos_sub_spec; unfold Pos.compare.
 CaseEq (Pcompare (xI r2) q Datatypes.Eq); simpl in |- *;
 auto.
intros H3; rewrite <- (Pcompare_Eq_eq _ _ H3); simpl in |- *;
 unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6;
 unfold nat_of_P in |- *; apply f_equal with (f := S);
 ring.
intros H3; unfold nat_of_P in |- *; simpl in |- *;
 repeat rewrite ZL6; unfold nat_of_P in |- *;
 apply f_equal with (f := S); ring.
intros H3; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6));
 unfold Pminus in |- *; rewrite H4;
 apply trans_equal with (nat_of_P q + nat_of_P h);
 [ rewrite <- (nat_of_P_plus_morphism q); rewrite H5;
    unfold nat_of_P in |- *; simpl in |- *;
    repeat rewrite ZL6; unfold nat_of_P in |- *;
    apply f_equal with (f := S)
 | unfold nat_of_P in |- * ]; ring.
case q; simpl in |- *; auto.
generalize H2; case q1; case r1; simpl in |- *; auto.
intros r2 q2. rewrite Z.pos_sub_spec; unfold Pos.compare.
CaseEq (Pcompare (xI r2) q Datatypes.Eq);
 simpl in |- *; auto.
intros; apply lt_O_nat_of_P; auto.
intros H H0; apply nat_of_P_lt_Lt_compare_morphism; auto.
intros H3 H7; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6));
 unfold Pminus in |- *; rewrite H4;
 apply plus_lt_reg_l with (p := nat_of_P q);
 rewrite <- (nat_of_P_plus_morphism q); rewrite H5;
 unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6;
 unfold nat_of_P in |- *;
 apply le_lt_trans with (Pmult_nat r2 1 + Pmult_nat q 1);
 auto with arith.
intros r2 HH; case q; simpl in |- *; auto.
intros p2; case p2; unfold nat_of_P in |- *; simpl in |- *;
 auto with arith.
intros p2; case p2; unfold nat_of_P in |- *; simpl in |- *;
 auto with arith.
intros r2 HH. rewrite Z.pos_sub_spec; unfold Pos.compare.
CaseEq (Pcompare (xI r2) q Datatypes.Eq);
 simpl in |- *.
intros; apply lt_O_nat_of_P; auto.
intros H3; apply nat_of_P_lt_Lt_compare_morphism; auto.
intros H3; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6));
 unfold Pminus in |- *; rewrite H4;
 apply plus_lt_reg_l with (p := nat_of_P q);
 rewrite <- (nat_of_P_plus_morphism q); rewrite H5;
 unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6;
 unfold nat_of_P in |- *;
 apply le_lt_trans with (Pmult_nat r2 1 + Pmult_nat q 1);
 auto with arith.
intros HH; case q; simpl in |- *; auto.
intros p2; case p2; unfold nat_of_P in |- *; simpl in |- *;
 auto with arith.
intros p2; case p2; unfold nat_of_P in |- *; simpl in |- *;
 auto with arith.
intros p'; simpl in |- *; case (Pdiv p' q); simpl in |- *;
 intros q1 r1 (H1, H2); split.
unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; rewrite H1.
case q1; case r1; simpl in |- *; auto.
intros r2 q2. rewrite Z.pos_sub_spec; unfold Pos.compare.
CaseEq (Pcompare (xO r2) q Datatypes.Eq);
 simpl in |- *; auto.
intros H3; rewrite <- (Pcompare_Eq_eq _ _ H3); simpl in |- *;
 unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6;
 unfold nat_of_P in |- *; ring.
intros H3; unfold nat_of_P in |- *; simpl in |- *;
 repeat rewrite ZL6; unfold nat_of_P in |- *;
 ring.
intros H3; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6));
 unfold Pminus in |- *; rewrite H4;
 apply
  trans_equal
   with
     (nat_of_P q + nat_of_P h +
      Pmult_nat q2 2 * Pmult_nat q 1);
 [ rewrite <- (nat_of_P_plus_morphism q); rewrite H5;
    unfold nat_of_P in |- *; simpl in |- *;
    repeat rewrite ZL6; unfold nat_of_P in |- *
 | unfold nat_of_P in |- * ]; ring.
intros H3; unfold nat_of_P in |- *; simpl in |- *;
 repeat rewrite ZL6; unfold nat_of_P in |- *;
 ring.
intros r2. rewrite Z.pos_sub_spec; unfold Pos.compare.
CaseEq (Pcompare (xO r2) q Datatypes.Eq); simpl in |- *;
 auto.
intros H3; rewrite <- (Pcompare_Eq_eq _ _ H3); simpl in |- *;
 unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6;
 unfold nat_of_P in |- *; ring.
intros H3; unfold nat_of_P in |- *; simpl in |- *;
 repeat rewrite ZL6; unfold nat_of_P in |- *;
 ring.
intros H3; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6));
 unfold Pminus in |- *; rewrite H4;
 apply trans_equal with (nat_of_P q + nat_of_P h);
 [ rewrite <- (nat_of_P_plus_morphism q); rewrite H5;
    unfold nat_of_P in |- *; simpl in |- *;
    repeat rewrite ZL6; unfold nat_of_P in |- *
 | unfold nat_of_P in |- * ]; ring.
generalize H2; case q1; case r1; simpl in |- *.
intros r2 q2. rewrite Z.pos_sub_spec; unfold Pos.compare.
CaseEq (Pcompare (xO r2) q Datatypes.Eq);
 simpl in |- *; auto.
intros; apply lt_O_nat_of_P; auto.
intros H H0; apply nat_of_P_lt_Lt_compare_morphism; auto.
intros H3 H7; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6));
 unfold Pminus in |- *; rewrite H4;
 apply plus_lt_reg_l with (p := nat_of_P q);
 rewrite <- (nat_of_P_plus_morphism q); rewrite H5;
 unfold nat_of_P in |- *; simpl in |- *;
 unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6;
 unfold nat_of_P in |- *;
 apply lt_trans with (Pmult_nat r2 1 + Pmult_nat q 1);
 auto with arith.
intros; apply lt_O_nat_of_P; auto.
intros r2 HH. rewrite Z.pos_sub_spec; unfold Pos.compare.
CaseEq (Pcompare (xO r2) q Datatypes.Eq);
 simpl in |- *.
intros; apply lt_O_nat_of_P; auto.
intros H3; apply nat_of_P_lt_Lt_compare_morphism; auto.
intros H3; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6));
 unfold Pminus in |- *; rewrite H4;
 apply plus_lt_reg_l with (p := nat_of_P q);
 rewrite <- (nat_of_P_plus_morphism q); rewrite H5;
 unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6;
 unfold nat_of_P in |- *;
 apply lt_trans with (Pmult_nat r2 1 + Pmult_nat q 1);
 auto with arith.
auto.
Qed.

Section bugFix.
Variable
  PdivAux :
    positive ->
    positive -> Option positive * Option positive.

Fixpoint PdivlessAux (bound p base length : positive) {struct length}
 : Option positive * Option positive * nat :=
  match Pcompare bound p Datatypes.Eq with
  | Datatypes.Gt => (Some _ p, None _, 0)
  | _ =>
      match PdivAux p base with
      | (None, None) => (None _, None _, 1)
      | (None, Some r1) => (None _, Some _ r1, 1)
      | (Some q1, None) =>
          match length with
          | xH => (Some _ q1, None _, 0)
          | xO length' =>
              match PdivlessAux bound q1 base length' with
              | (s2, None, n) => (s2, None _, S n)
              | (s2, Some r2, n) =>
                  (s2,
                  Some _
                    ((fun (x : positive)
                        (_ : positive -> positive)
                        (y : positive) => (x * y)%positive) r2
                       (fun x => x) base), S n)
              end
          | xI length' =>
              match PdivlessAux bound q1 base length' with
              | (s2, None, n) => (s2, None _, S n)
              | (s2, Some r2, n) =>
                  (s2,
                  Some _
                    ((fun (x : positive)
                        (_ : positive -> positive)
                        (y : positive) => (x * y)%positive) r2
                       (fun x => x) base), S n)
              end
          end
      | (Some q1, Some r1) =>
          match length with
          | xH => (Some _ q1, None _, 0)
          | xO length' =>
              match PdivlessAux bound q1 base length' with
              | (s2, None, n) => (s2, Some _ r1, S n)
              | (s2, Some r2, n) =>
                  (s2,
                  Some _
                    ((fun (x : positive)
                        (_ : positive -> positive)
                        (y : positive) => x * y) r2 (
                       fun x => x) base + r1)%positive,
                  S n)
              end
          | xI length' =>
              match PdivlessAux bound q1 base length' with
              | (s2, None, n) => (s2, Some _ r1, S n)
              | (s2, Some r2, n) =>
                  (s2,
                  Some _
                    ((fun (x : positive)
                        (_ : positive -> positive)
                        (y : positive) => x * y) r2 (
                       fun x => x) base + r1)%positive,
                  S n)
              end
          end
      end
  end.
End bugFix.

Definition Pdivless := PdivlessAux Pdiv.

Theorem Pdivless1 :
 forall bound p q base,
 Pcompare bound p Datatypes.Eq = Datatypes.Gt ->
 Pdivless bound p base q = (Some _ p, None _, 0).
intros bound p q base H; case q; simpl in |- *; auto; intros; rewrite H; auto.
Qed.

Theorem Pdivless2 :
 forall bound p length base,
 Pcompare bound p Datatypes.Eq <> Datatypes.Gt ->
 Pdivless bound p base length =
 match Pdiv p base with
 | (None, None) => (None _, None _, 1)
 | (None, Some r1) => (None _, Some _ r1, 1)
 | (Some q1, None) =>
     match length with
     | xH => (Some _ q1, None _, 0)
     | xO length' =>
         match Pdivless bound q1 base length' with
         | (s2, None, n) => (s2, None _, S n)
         | (s2, Some r2, n) =>
             (s2,
             Some _
               ((fun (x : positive)
                   (_ : positive -> positive)
                   (y : positive) => (x * y)%positive) r2 (
                  fun x => x) base), S n)
         end
     | xI length' =>
         match Pdivless bound q1 base length' with
         | (s2, None, n) => (s2, None _, S n)
         | (s2, Some r2, n) =>
             (s2,
             Some _
               ((fun (x : positive)
                   (_ : positive -> positive)
                   (y : positive) => (x * y)%positive) r2 (
                  fun x => x) base), S n)
         end
     end
 | (Some q1, Some r1) =>
     match length with
     | xH => (Some _ q1, None _, 0)
     | xO length' =>
         match Pdivless bound q1 base length' with
         | (s2, None, n) => (s2, Some _ r1, S n)
         | (s2, Some r2, n) =>
             (s2,
             Some _
               ((fun (x : positive)
                   (_ : positive -> positive)
                   (y : positive) => x * y) r2 (
                  fun x => x) base + r1)%positive,
             S n)
         end
     | xI length' =>
         match Pdivless bound q1 base length' with
         | (s2, None, n) => (s2, Some _ r1, S n)
         | (s2, Some r2, n) =>
             (s2,
             Some _
               ((fun (x : positive)
                   (_ : positive -> positive)
                   (y : positive) => x * y) r2 (
                  fun x => x) base + r1)%positive,
             S n)
         end
     end
 end.
intros bound p length base; case length; simpl in |- *;
 case (Pcompare bound p Datatypes.Eq); auto;
 (intros H; case H; auto; fail) || (intros p' H; case H; auto).
Qed.

Theorem compare_SUP_dec :
 forall p q : positive,
 Pcompare p q Datatypes.Eq = Datatypes.Gt \/
 Pcompare p q Datatypes.Eq <> Datatypes.Gt.
intros p q; case (Pcompare p q Datatypes.Eq); auto; right; red in |- *;
 intros; discriminate.
Qed.
Hint Resolve lt_O_nat_of_P: arith.

Theorem odd_even_lem : forall p q, 2 * p + 1 <> 2 * q.
intros p; elim p; auto.
intros q; case q; simpl in |- *.
red in |- *; intros; discriminate.
intros q'; rewrite (fun x y => plus_comm x (S y)); simpl in |- *; red in |- *;
 intros; discriminate.
intros p' H q; case q.
simpl in |- *; red in |- *; intros; discriminate.
intros q'; red in |- *; intros H0; case (H q').
replace (2 * q') with (2 * S q' - 2).
rewrite <- H0; simpl in |- *; auto.
repeat rewrite (fun x y => plus_comm x (S y)); simpl in |- *; auto.
simpl in |- *; repeat rewrite (fun x y => plus_comm x (S y)); simpl in |- *;
 auto.
case q'; simpl in |- *; auto.
Qed.

Theorem Pdivless_correct :
 forall bound p q base,
 1 < nat_of_P base ->
 nat_of_P p <= nat_of_P q ->
 nat_of_P p =
 oZ (fst (fst (Pdivless bound p base q))) *
 exp (nat_of_P base) (snd (Pdivless bound p base q)) +
 oZ (snd (fst (Pdivless bound p base q))) /\
 (oZ (fst (fst (Pdivless bound p base q))) < nat_of_P bound /\
  oZ (snd (fst (Pdivless bound p base q))) <
  exp (nat_of_P base) (snd (Pdivless bound p base q))) /\
 (forall bound',
  nat_of_P bound = nat_of_P base * bound' ->
  nat_of_P bound <= nat_of_P p ->
  nat_of_P bound <=
  nat_of_P base * oZ (fst (fst (Pdivless bound p base q)))).
intros bound p q base Hb; generalize q; pattern p in |- *;
 apply
  well_founded_ind
   with (R := fun a b => nat_of_P a < nat_of_P b);
 auto; clear p q.
apply wf_inverse_image with (R := lt); auto.
exact lt_wf; auto.
intros p Rec q Hq.
case (compare_SUP_dec bound p); intros H1.
rewrite Pdivless1; auto; simpl in |- *.
repeat (split; auto with arith).
ring; auto.
apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; auto.
intros bound' H'1 H2; Contradict H2; apply lt_not_le;
 apply nat_of_P_lt_Lt_compare_morphism; apply ZC1;
 auto.
rewrite Pdivless2; auto; simpl in |- *.
generalize (Pdiv_correct p base); case (Pdiv p base); simpl in |- *.
intros o1; case o1; simpl in |- *.
intros o1' o2; case o2; simpl in |- *.
intros o2' (Ho1, Ho2).
generalize Hq; case q; simpl in |- *; auto.
intros p0 Hq0;
 (cut (nat_of_P o1' <= nat_of_P p0); [ intros Hrec | idtac ]).
cut (nat_of_P o1' < nat_of_P p); [ intros Hrec1 | idtac ].
generalize (Rec _ Hrec1 _ Hrec).
CaseEq (Pdivless bound o1' base p0); simpl in |- *.
intros p1; case p1; simpl in |- *.
intros o3; case o3; simpl in |- *; auto.
intros o3' o4; case o4; simpl in |- *; auto.
intros o4' n Eq1; rewrite nat_of_P_plus_morphism;
 rewrite nat_of_P_mult_morphism.
intros (H'1, ((H'2, H'3), H'4)); repeat (split; auto).
rewrite Ho1; rewrite H'1; ring.
apply lt_le_trans with (S (nat_of_P o4') * nat_of_P base).
simpl in |- *; rewrite (fun x y => plus_comm x (nat_of_P y));
 auto with arith.
rewrite (fun x y => mult_comm x (nat_of_P y)); auto with arith.
intros bound' H'5 H'6;
 case (le_or_lt (nat_of_P bound) (nat_of_P o1'));
 intros H'7; auto.
apply (H'4 bound'); auto.
rewrite Pdivless1 in Eq1; auto.
discriminate.
apply nat_of_P_gt_Gt_compare_complement_morphism; auto.
intros n Eq1 (H'1, ((H'2, H'3), H'4)); repeat (split; auto).
rewrite Ho1; rewrite H'1; ring.
apply lt_le_trans with (nat_of_P base * 1); auto with arith.
rewrite mult_comm; simpl in |- *; auto with arith.
intros bound' H'5 H'6;
 case (le_or_lt (nat_of_P bound) (nat_of_P o1'));
 intros H'7; auto.
apply (H'4 bound'); auto.
rewrite Pdivless1 in Eq1; auto.
inversion Eq1.
rewrite <- H0.
case (le_or_lt bound' (nat_of_P o1')); intros H'8; auto.
rewrite H'5; auto with arith.
Contradict H'6; auto.
apply lt_not_le; rewrite Ho1; auto.
apply
 lt_le_trans
  with
    (nat_of_P o1' * nat_of_P base + 1 * nat_of_P base);
 auto with arith.
simpl in |- *; auto with arith.
rewrite <- mult_plus_distr_r.
replace (nat_of_P o1' + 1) with (S (nat_of_P o1'));
 auto with arith.
rewrite H'5; auto with arith.
rewrite <- (fun x y => mult_comm (nat_of_P x) y); auto with arith.
rewrite plus_comm; auto with arith.
apply nat_of_P_gt_Gt_compare_complement_morphism; auto with arith.
intros o4; case o4; simpl in |- *.
intros o4' n Eq1; rewrite nat_of_P_plus_morphism;
 rewrite nat_of_P_mult_morphism.
intros (H'1, ((H'2, H'3), H'4)); repeat (split; auto).
rewrite Ho1; rewrite H'1; ring.
apply lt_le_trans with (S (nat_of_P o4') * nat_of_P base).
simpl in |- *; rewrite (fun x y => plus_comm x (nat_of_P y));
 auto with arith.
rewrite (fun x y => mult_comm x (nat_of_P y)); auto with arith.
intros bound' H H0; apply (H'4 bound'); auto.
case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'8;
 auto.
rewrite Pdivless1 in Eq1; auto.
discriminate.
apply nat_of_P_gt_Gt_compare_complement_morphism; auto.
intros n Eq1 (H'1, ((H'2, H'3), H'4)); repeat (split; auto).
rewrite Ho1; rewrite H'1; ring.
apply lt_le_trans with (nat_of_P base * 1); auto with arith.
rewrite mult_comm; simpl in |- *; auto with arith.
intros bound' H H0; apply (H'4 bound'); auto.
case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'8;
 auto.
rewrite Pdivless1 in Eq1; auto.
discriminate.
apply nat_of_P_gt_Gt_compare_complement_morphism; auto.
rewrite Ho1; auto.
apply lt_le_trans with (nat_of_P o1' * 1 + nat_of_P o2');
 auto with arith.
rewrite mult_comm; simpl in |- *; auto with arith.
apply le_lt_trans with (nat_of_P o1' + 0); auto with arith.
apply plus_le_lt_compat; auto with arith.
apply mult_S_le_reg_l with (n := pred (nat_of_P base)).
replace (S (pred (nat_of_P base))) with (nat_of_P base).
apply
 (fun p n m : nat => plus_le_reg_l n m p) with (p := nat_of_P o2').
rewrite (plus_comm (nat_of_P o2')); simpl in |- *; auto with arith.
rewrite (mult_comm (nat_of_P base)); simpl in |- *; auto with arith.
rewrite <- Ho1; auto with arith.
apply le_trans with (1 := Hq0); auto with arith.
replace (nat_of_P (xI p0)) with (1 + 2 * nat_of_P p0);
 auto with arith.
apply plus_le_compat; auto with arith.
unfold nat_of_P in |- *; simpl in |- *; (rewrite ZL6; auto).
generalize (lt_O_nat_of_P base); case (nat_of_P base);
 simpl in |- *; auto; intros tmp; inversion tmp.
intros p0 Hq0;
 (cut (nat_of_P o1' <= nat_of_P p0); [ intros Hrec | idtac ]).
cut (nat_of_P o1' < nat_of_P p); [ intros Hrec1 | idtac ].
generalize (Rec _ Hrec1 _ Hrec).
CaseEq (Pdivless bound o1' base p0); simpl in |- *.
intros p1; case p1; simpl in |- *.
intros o3; case o3; simpl in |- *; auto.
intros o3' o4; case o4; simpl in |- *; auto.
intros o4' n Eq1; rewrite nat_of_P_plus_morphism;
 rewrite nat_of_P_mult_morphism.
intros (H'1, ((H'2, H'3), H'4)); repeat (split; auto).
rewrite Ho1; rewrite H'1; ring.
apply lt_le_trans with (S (nat_of_P o4') * nat_of_P base).
simpl in |- *; rewrite (fun x y => plus_comm x (nat_of_P y));
 auto with arith.
rewrite (fun x y => mult_comm x (nat_of_P y)); auto with arith.
intros bound' H'5 H'6;
 case (le_or_lt (nat_of_P bound) (nat_of_P o1'));
 intros H'7; auto.
apply (H'4 bound'); auto.
rewrite Pdivless1 in Eq1; auto.
discriminate.
apply nat_of_P_gt_Gt_compare_complement_morphism; auto.
intros n Eq1 (H'1, ((H'2, H'3), H'4)); repeat (split; auto).
rewrite Ho1; rewrite H'1; ring.
apply lt_le_trans with (nat_of_P base * 1); auto with arith.
rewrite mult_comm; simpl in |- *; auto with arith.
intros bound' H'5 H'6;
 case (le_or_lt (nat_of_P bound) (nat_of_P o1'));
 intros H'7; auto.
apply (H'4 bound'); auto.
rewrite Pdivless1 in Eq1; auto.
inversion Eq1.
rewrite <- H0.
case (le_or_lt bound' (nat_of_P o1')); intros H'8; auto.
rewrite H'5; auto with arith.
Contradict H'6; auto.
apply lt_not_le; rewrite Ho1; auto.
apply
 lt_le_trans
  with
    (nat_of_P o1' * nat_of_P base + 1 * nat_of_P base);
 auto with arith.
simpl in |- *; auto with arith.
rewrite <- mult_plus_distr_r.
replace (nat_of_P o1' + 1) with (S (nat_of_P o1'));
 auto with arith.
rewrite H'5; auto with arith.
rewrite <- (fun x y => mult_comm (nat_of_P x) y); auto with arith.
rewrite plus_comm; auto with arith.
apply nat_of_P_gt_Gt_compare_complement_morphism; auto with arith.
intros o4; case o4; simpl in |- *.
intros o4' n Eq1; rewrite nat_of_P_plus_morphism;
 rewrite nat_of_P_mult_morphism.
intros (H'1, ((H'2, H'3), H'4)); repeat (split; auto).
rewrite Ho1; rewrite H'1; ring.
apply lt_le_trans with (S (nat_of_P o4') * nat_of_P base).
simpl in |- *; rewrite (fun x y => plus_comm x (nat_of_P y));
 auto with arith.
rewrite (fun x y => mult_comm x (nat_of_P y)); auto with arith.
intros bound' H H0; apply (H'4 bound'); auto.
case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'8;
 auto.
rewrite Pdivless1 in Eq1; auto.
discriminate.
apply nat_of_P_gt_Gt_compare_complement_morphism; auto.
intros n Eq1 (H'1, ((H'2, H'3), H'4)); repeat (split; auto).
rewrite Ho1; rewrite H'1; ring.
apply lt_le_trans with (nat_of_P base * 1); auto with arith.
rewrite mult_comm; simpl in |- *; auto with arith.
rewrite Ho1; auto.
intros bound' H H0; apply (H'4 bound'); auto.
case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'8;
 auto.
rewrite Pdivless1 in Eq1; auto.
discriminate.
apply nat_of_P_gt_Gt_compare_complement_morphism; auto.
apply lt_le_trans with (nat_of_P o1' * 1 + nat_of_P o2');
 auto with arith.
rewrite mult_comm; simpl in |- *; auto with arith.
apply le_lt_trans with (nat_of_P o1' + 0); auto with arith.
apply plus_le_lt_compat; auto with arith.
rewrite Ho1; auto with arith.
apply mult_S_le_reg_l with (n := pred (nat_of_P base)).
replace (S (pred (nat_of_P base))) with (nat_of_P base).
apply
 (fun p n m : nat => plus_le_reg_l n m p) with (p := nat_of_P o2').
rewrite (plus_comm (nat_of_P o2')); simpl in |- *; auto with arith.
rewrite (mult_comm (nat_of_P base)); simpl in |- *; auto with arith.
rewrite <- Ho1; auto with arith.
apply le_trans with (1 := Hq0); auto with arith.
replace (nat_of_P (xO p0)) with (0 + 2 * nat_of_P p0);
 auto with arith.
apply plus_le_compat; auto with arith.
unfold nat_of_P in |- *; simpl in |- *; (rewrite ZL6; auto).
generalize (lt_O_nat_of_P base); case (nat_of_P base);
 simpl in |- *; auto; intros tmp; inversion tmp.
replace (nat_of_P 1) with 1; auto with arith.
rewrite Ho1; generalize (lt_O_nat_of_P o2');
 (case (nat_of_P o2'); simpl in |- *).
intros tmp; Contradict tmp; auto with arith.
generalize (lt_O_nat_of_P o1');
 (case (nat_of_P o1'); simpl in |- *).
intros tmp; Contradict tmp; auto with arith.
generalize (lt_O_nat_of_P base);
 (case (nat_of_P base); simpl in |- *).
intros tmp; Contradict tmp; auto with arith.
intros n H n0 H0 n1 H01; rewrite (fun x y => plus_comm x (S y));
 simpl in |- *.
intros tmp; Contradict tmp; auto with arith.
generalize Hq; case q; simpl in |- *; auto.
intros p0 Hq0 (Ho1, Ho2);
 (cut (nat_of_P o1' <= nat_of_P p0); [ intros Hrec | idtac ]).
cut (nat_of_P o1' < nat_of_P p); [ intros Hrec1 | idtac ].
generalize (Rec _ Hrec1 _ Hrec).
CaseEq (Pdivless bound o1' base p0); simpl in |- *.
intros p1; case p1; simpl in |- *.
intros o3; case o3; simpl in |- *; auto.
intros o3' o4; case o4; simpl in |- *; auto.
intros o4' n Eq1; rewrite nat_of_P_mult_morphism.
intros (H'1, ((H'2, H'3), H'4)); repeat (split; auto).
rewrite Ho1; rewrite H'1; ring.
rewrite (fun x y => mult_comm x (nat_of_P y)); auto with arith.
intros bound' H'5 H'6;
 case (le_or_lt (nat_of_P bound) (nat_of_P o1'));
 intros H'7; auto.
apply (H'4 bound'); auto.
rewrite Pdivless1 in Eq1; auto.
discriminate.
apply nat_of_P_gt_Gt_compare_complement_morphism; auto.
intros n Eq1 (H'1, ((H'2, H'3), H'4)); repeat (split; auto).
rewrite Ho1; rewrite H'1; ring.
apply lt_le_trans with (nat_of_P base * 1); auto with arith.
rewrite mult_comm; simpl in |- *; auto with arith.
intros bound' H'5 H'6;
 case (le_or_lt (nat_of_P bound) (nat_of_P o1'));
 intros H'7; auto.
apply (H'4 bound'); auto.
rewrite Pdivless1 in Eq1; auto.
inversion Eq1.
rewrite <- H0.
case (le_or_lt bound' (nat_of_P o1')); intros H'8; auto.
rewrite H'5; auto with arith.
Contradict H'6; auto.
apply lt_not_le; rewrite Ho1; auto.
apply
 lt_le_trans
  with
    (nat_of_P o1' * nat_of_P base + 1 * nat_of_P base);
 auto with arith.
simpl in |- *; auto with arith.
rewrite <- mult_plus_distr_r.
replace (nat_of_P o1' + 1) with (S (nat_of_P o1'));
 auto with arith.
rewrite H'5; auto with arith.
rewrite <- (fun x y => mult_comm (nat_of_P x) y); auto with arith.
rewrite plus_comm; auto with arith.
apply nat_of_P_gt_Gt_compare_complement_morphism; auto with arith.
intros o4; case o4; simpl in |- *.
intros o4' n Eq1; rewrite nat_of_P_mult_morphism.
intros (H'1, ((H'2, H'3), H'4)); repeat (split; auto).
rewrite Ho1; rewrite H'1; ring.
rewrite (fun x y => mult_comm x (nat_of_P y)); auto with arith.
intros bound' H H0; apply (H'4 bound'); auto.
case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'8;
 auto.
rewrite Pdivless1 in Eq1; auto.
discriminate.
apply nat_of_P_gt_Gt_compare_complement_morphism; auto.
intros n Eq1 (H'1, (H'2, H'3)).
generalize (lt_O_nat_of_P o1'); rewrite H'1; intros tmp; inversion tmp.
rewrite Ho1; auto.
apply le_lt_trans with (nat_of_P o1' * 1 + 0); auto with arith.
rewrite mult_comm; simpl in |- *; auto with arith.
repeat rewrite (fun x => plus_comm x 0); simpl in |- *; auto with arith.
apply mult_S_le_reg_l with (n := pred (nat_of_P base)).
replace (S (pred (nat_of_P base))) with (nat_of_P base).
rewrite (mult_comm (nat_of_P base)); simpl in |- *; auto with arith.
rewrite (fun x => plus_comm x 0) in Ho1; simpl in Ho1; rewrite <- Ho1.
generalize Hq0; clear Hq0;
 replace (nat_of_P (xI p0)) with (2 * nat_of_P p0 + 1);
 try intros Hq0.
case (le_lt_or_eq _ _ Hq0); auto.
rewrite (fun x y => plus_comm x (S y)); intros Hl1.
apply le_trans with (2 * nat_of_P p0); auto with arith.
generalize Hb Ho1; case (nat_of_P base); auto.
intros tmp; Contradict tmp; auto with arith.
intros base'; case base'.
intros tmp; Contradict tmp; auto with arith.
intros base''; case base''.
replace (nat_of_P (xI p0)) with (1 + 2 * nat_of_P p0);
 auto with arith.
intros Hb0 Ho0 H; Contradict H; rewrite Ho0.
rewrite (fun x y => mult_comm x (S y)).
apply Compare.not_eq_sym.
apply odd_even_lem.
unfold nat_of_P in |- *; simpl in |- *; (rewrite ZL6; auto).
intros n Hb0 Ho0 H; rewrite H.
apply le_trans with (S (S n) * nat_of_P p0 + nat_of_P p0);
 auto with arith.
apply plus_le_compat; auto with arith.
rewrite plus_comm; simpl in |- *; auto with arith.
rewrite plus_comm; unfold nat_of_P in |- *; simpl in |- *;
 (rewrite ZL6; unfold nat_of_P in |- *; auto).
generalize (lt_O_nat_of_P base); case (nat_of_P base);
 simpl in |- *; auto; intros tmp; inversion tmp.
intros p0 Hq0 (Ho1, Ho2);
 (cut (nat_of_P o1' <= nat_of_P p0); [ intros Hrec | idtac ]).
cut (nat_of_P o1' < nat_of_P p); [ intros Hrec1 | idtac ].
generalize (Rec _ Hrec1 _ Hrec).
CaseEq (Pdivless bound o1' base p0); simpl in |- *.
intros p1; case p1; simpl in |- *.
intros o3; case o3; simpl in |- *; auto.
intros o3' o4; case o4; simpl in |- *; auto.
intros o4' n Eq1; rewrite nat_of_P_mult_morphism.
intros (H'1, ((H'2, H'3), H'4)); repeat (split; auto).
rewrite Ho1; rewrite H'1; ring.
rewrite (fun x y => mult_comm x (nat_of_P y)); auto with arith.
intros bound' H'5 H'6;
 case (le_or_lt (nat_of_P bound) (nat_of_P o1'));
 intros H'7; auto.
apply (H'4 bound'); auto.
rewrite Pdivless1 in Eq1; auto.
discriminate.
apply nat_of_P_gt_Gt_compare_complement_morphism; auto.
intros n Eq1 (H'1, ((H'2, H'3), H'4)); repeat (split; auto).
rewrite Ho1; rewrite H'1; ring.
replace 0 with (0 * exp (nat_of_P base) n); auto with arith.
intros bound' H'5 H'6;
 case (le_or_lt (nat_of_P bound) (nat_of_P o1'));
 intros H'7; auto.
apply (H'4 bound'); auto.
rewrite Pdivless1 in Eq1; auto.
inversion Eq1.
rewrite <- H0.
case (le_or_lt bound' (nat_of_P o1')); intros H'8; auto.
rewrite H'5; auto with arith.
Contradict H'6; auto.
apply lt_not_le; rewrite Ho1; auto.
apply
 lt_le_trans
  with
    (nat_of_P o1' * nat_of_P base + 1 * nat_of_P base);
 auto with arith.
simpl in |- *; auto with arith.
rewrite <- mult_plus_distr_r.
replace (nat_of_P o1' + 1) with (S (nat_of_P o1'));
 auto with arith.
rewrite H'5; auto with arith.
rewrite <- (fun x y => mult_comm (nat_of_P x) y); auto with arith.
rewrite plus_comm; auto with arith.
apply nat_of_P_gt_Gt_compare_complement_morphism; auto with arith.
intros o4; case o4; simpl in |- *.
intros o4' n Eq1; rewrite nat_of_P_mult_morphism.
intros (H'1, ((H'2, H'3), H'4)); repeat (split; auto).
rewrite Ho1; rewrite H'1; ring.
rewrite (fun x y => mult_comm x (nat_of_P y)); auto with arith.
intros bound' H H0; apply (H'4 bound'); auto.
case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'8;
 auto.
rewrite Pdivless1 in Eq1; auto.
discriminate.
apply nat_of_P_gt_Gt_compare_complement_morphism; auto.
intros n Eq1 (H'1, ((H'2, H'3), H'4)); repeat (split; auto).
rewrite Ho1; rewrite H'1; ring.
replace 0 with (0 * exp (nat_of_P base) n); auto with arith.
intros bound' H H0; Contradict H0; rewrite Ho1; rewrite H'1; simpl in |- *;
 auto with arith.
rewrite Ho1; auto with arith.
apply le_lt_trans with (nat_of_P o1' * 1 + 0); auto with arith.
rewrite mult_comm; simpl in |- *; auto with arith.
apply mult_S_le_reg_l with (n := pred (nat_of_P base)).
replace (S (pred (nat_of_P base))) with (nat_of_P base).
apply le_trans with (nat_of_P p); auto.
rewrite Ho1; rewrite (fun x => plus_comm x 0); simpl in |- *; auto.
rewrite (mult_comm (nat_of_P base)); simpl in |- *; auto with arith.
apply le_trans with (1 := Hq0); auto with arith.
replace (nat_of_P (xO p0)) with (2 * nat_of_P p0);
 auto with arith.
unfold nat_of_P in |- *; simpl in |- *; (rewrite ZL6; auto).
generalize (lt_O_nat_of_P base); case (nat_of_P base);
 simpl in |- *; auto; intros tmp; inversion tmp.
replace (nat_of_P 1) with 1; auto with arith.
intros Hq0 (H, H0); Contradict Hq0.
apply lt_not_le.
rewrite H.
generalize (lt_O_nat_of_P o1'); case (nat_of_P o1');
 simpl in |- *; auto.
intros tmp; Contradict tmp; auto with arith.
intros n H2; generalize Hb.
case (nat_of_P base); simpl in |- *; auto.
intros tmp; Contradict tmp; auto with arith.
intros base'; case base'; simpl in |- *; auto with arith.
intros tmp; Contradict tmp; auto with arith.
intros o2; case o2; simpl in |- *; auto with arith.
intros o2' (Ho1, Ho2); repeat (split; auto with arith).
rewrite mult_comm; simpl in |- *; auto with arith.
intros bound' H H0; Contradict Ho2.
apply le_not_lt.
rewrite <- Ho1.
generalize H; case bound'.
rewrite mult_comm; simpl in |- *; auto.
intros Eq2; generalize (lt_O_nat_of_P bound); rewrite Eq2; intros tmp;
 Contradict tmp; auto with arith.
intros n Eq2; apply le_trans with (nat_of_P bound); auto with arith.
rewrite Eq2; auto with arith.
rewrite mult_comm; simpl in |- *; auto with arith.
intros (Ho1, Ho2); generalize (lt_O_nat_of_P p); rewrite Ho1; intros tmp;
 Contradict tmp; auto with arith.
Qed.

Definition PdivBound bound p base := Pdivless bound p base p.

Theorem PdivBound_correct :
 forall bound p base,
 1 < nat_of_P base ->
 nat_of_P p =
 oZ (fst (fst (PdivBound bound p base))) *
 exp (nat_of_P base) (snd (PdivBound bound p base)) +
 oZ (snd (fst (PdivBound bound p base))) /\
 (oZ (fst (fst (PdivBound bound p base))) < nat_of_P bound /\
  oZ (snd (fst (PdivBound bound p base))) <
  exp (nat_of_P base) (snd (PdivBound bound p base))) /\
 (forall bound',
  nat_of_P bound = nat_of_P base * bound' ->
  nat_of_P bound <= nat_of_P p ->
  nat_of_P bound <=
  nat_of_P base * oZ (fst (fst (PdivBound bound p base)))).
intros; unfold PdivBound in |- *; apply Pdivless_correct; auto.
Qed.

Theorem PdivBound_correct1 :
 forall bound p base,
 1 < nat_of_P base ->
 nat_of_P p =
 oZ (fst (fst (PdivBound bound p base))) *
 exp (nat_of_P base) (snd (PdivBound bound p base)) +
 oZ (snd (fst (PdivBound bound p base))).
intros bound p base H; generalize (PdivBound_correct bound p base); intuition.
Qed.

Theorem PdivBound_correct2 :
 forall bound p base,
 1 < nat_of_P base ->
 oZ (fst (fst (PdivBound bound p base))) < nat_of_P bound.
intros bound p base H; generalize (PdivBound_correct bound p base); intuition.
Qed.

Theorem PdivBound_correct3 :
 forall bound p base,
 nat_of_P p < nat_of_P bound ->
 PdivBound bound p base = (Some _ p, None _, 0).
intros bound p base H; (unfold PdivBound in |- *; apply Pdivless1; auto).
apply nat_of_P_gt_Gt_compare_complement_morphism; auto with arith.
Qed.

Theorem PdivBound_correct4 :
 forall bound p base bound',
 1 < nat_of_P base ->
 nat_of_P bound = nat_of_P base * bound' ->
 nat_of_P bound <= nat_of_P p ->
 nat_of_P bound <=
 nat_of_P base * oZ (fst (fst (PdivBound bound p base))).
intros bound p base bound' H H1 H2; case (PdivBound_correct bound p base);
 auto; intros H'1 (H'2, H'3); apply (H'3 bound'); auto with arith.
Qed.
Transparent Pdiv.
(* Eval Compute
in (PdivBound
    (anti_convert (9))
    (times1 (anti_convert (10)) [x : ?]  x (anti_convert (10)))
    (anti_convert (9))).*)


Require Import Util CSet AnnP.

Definition bounded_below
           (c : nat)
           (k : nat)
  : ⦃nat⦄ -> Prop
  :=
    fun a => cardinal (filter (fun x => B[x <= c]) a) <= k.

Instance bounded_in_equal_morph
  : Proper (eq ==> eq ==> Equal ==> iff) bounded_below.
Proof.
  unfold Proper, respectful, bounded_below; intros; subst.
  rewrite H1. reflexivity.
Qed.

Instance bounded_in_subset_morph
  : Proper (eq ==> eq ==> Equal ==> impl) bounded_below.
Proof.
  unfold Proper, respectful, bounded_below, impl, flip; intros; subst.
  rewrite <- H1. rewrite <- H2. reflexivity.
Qed.

Instance bounded_in_equal_ptw
  : Proper (eq ==> eq ==> pointwise_relation _ iff) bounded_below.
Proof.
  unfold Proper, respectful, pointwise_relation; intros; subst.
  reflexivity.
Qed.

Instance bounded_in_impl_ptw'
  : Proper (eq ==> eq ==> pointwise_relation _ impl) bounded_below.
Proof.
  unfold Proper, respectful, pointwise_relation, impl, flip; intros; subst.
  eauto.
Qed.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List Arith Bool Lia Eqdep_dec.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list utils_nat finite.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.TRAKHTENBROT
  Require Import notations utils decidable fol_ops fo_sig fo_terms fo_logic fo_sat.

Import fol_notations.

Set Implicit Arguments.

(* * From signatures with only constants functions to function symbol free signatures *)

Local Reserved Notation "⟪ A ⟫'" (at level 1, format "⟪ A ⟫'").

Local Notation ø := vec_nil.

Section remove_constants.

  Variable (Σ : fo_signature) (HΣ : forall s, ar_syms Σ s = 0)
           (ls : list (syms Σ)).

  Definition Σrem_cst : fo_signature.
  Proof.
    exists Empty_set (rels Σ).
    + intros [].
    + apply ar_rels.
  Defined.

  Notation Σ' := Σrem_cst.

  Notation 𝕋 := (fol_term Σ).
  Notation 𝔽 := (fol_form Σ).

  Notation 𝕋' := (fol_term Σ').
  Notation 𝔽' := (fol_form Σ').

  Implicit Type σ : syms Σ -> nat.

  Let convert_t σ (t : 𝕋) : 𝕋' :=
    match t with
      | in_var n   => in_var n
      | in_fot s _ => in_var (σ s)
    end.

  Local Fixpoint encode σ (A : 𝔽)  : 𝔽' :=
    match A with
      | ⊥              => ⊥
      | fol_atom r v   => @fol_atom Σ' r (vec_map (convert_t σ) v)
      | fol_bin b A B  => fol_bin b (encode σ A) (encode σ B)
      | fol_quant q A  => fol_quant q (encode (fun s => S (σ s)) A)
    end.

  Section soundness.

    Variable (X : Type) (M : fo_model Σ X).

    Definition Σrem_cst_model : fo_model Σ' X.
    Proof.
      split.
      + intros [].
      + apply (fom_rels M).
    Defined.

    Notation M' := Σrem_cst_model.

    Notation "⟪ A ⟫" := (fun φ => fol_sem M φ A).
    Notation "⟪ A ⟫'" := (fun ψ => fol_sem M' ψ A).

    Local Fact soundness σ (A : 𝔽) φ ψ :
            (forall s, In s ls -> In (σ s) (fol_vars A) -> False)
         -> (forall n, In n (fol_vars A) -> φ n = ψ n)
         -> (forall s, In s ls -> ψ (σ s) = fom_syms M s (cast ø (eq_sym (HΣ s))))
         -> incl (fol_syms A) ls
         ->  ⟪A⟫ φ <-> ⟪encode σ A⟫' ψ.
    Proof.
      induction A as [ | r v | b A HA B HB | q A HA ] in σ, φ, ψ |- *;
        intros H1 H2 H3 H4; simpl; try tauto.
      + rewrite vec_map_map.
        apply fol_equiv_ext; f_equal.
        apply vec_pos_ext; intro p; rew vec.
        cut (incl (fo_term_syms (vec_pos v p)) ls).
        2:{ intros s Hs; apply H4; simpl; apply in_flat_map.
            exists (vec_pos v p); split; auto.
            apply in_vec_list, in_vec_pos. }
        cut (forall n, In n (fo_term_vars (vec_pos v p)) -> φ n = ψ n).
        2:{ intros n Hn; apply H2, in_flat_map.
            exists (vec_pos v p); split; auto.
            apply in_vec_list, in_vec_pos. }
        generalize (vec_pos v p); intros [ n | s w ] H5 H6; simpl.
        - apply H5; simpl; auto.
        - rewrite H3; f_equal; auto.
          2: apply H6; rew fot; simpl; auto.
          clear H5 H6.
          revert w; rewrite HΣ; intros w.
          vec nil w; auto.
      + apply fol_bin_sem_ext.
        * apply HA; auto.
          - intros s G1 G2; apply (H1 _ G1), in_app_iff; auto.
          - intros; apply H2, in_app_iff; auto.
          - intros ? ?; apply H4, in_app_iff; auto.
        * apply HB; auto.
          - intros s G1 G2; apply (H1 _ G1), in_app_iff; auto.
          - intros; apply H2, in_app_iff; auto.
          - intros ? ?; apply H4, in_app_iff; auto.
      + apply fol_quant_sem_ext; intros x.
        apply HA; auto.
        * intros s G1 G2; apply (H1 _ G1).
          simpl; apply in_flat_map.
          exists (S (σ s)); simpl; auto.
        * intros [|n] Hn; simpl; auto.
          apply H2; simpl; apply in_flat_map.
          exists (S n); simpl; auto.
    Qed.

  End soundness.

  Section completeness.

    Variable (X : Type) (M' : fo_model Σ' X).

    Definition Σadd_cst_model σ (ψ : nat -> X) : fo_model Σ X.
    Proof.
      split.
      + intros s _; exact (ψ (σ s)).
      + apply (fom_rels M').
    Defined.

    Notation M := Σadd_cst_model.

    Local Fact completeness σ (A : 𝔽) φ ψ :
            (forall s, In s ls -> In (σ s) (fol_vars A) -> False)
         -> (forall n, In n (fol_vars A) -> φ n = ψ n)
         -> incl (fol_syms A) ls
         -> fol_sem (Σadd_cst_model σ ψ) φ A
        <-> fol_sem M' ψ (encode σ A).
    Proof.
      induction A as [ | r v | b A HA B HB | q A HA ] in σ, φ, ψ |- *;
      intros H1 H2 H3; simpl; try tauto.
      + rewrite vec_map_map.
        apply fol_equiv_ext; f_equal.
        apply vec_pos_ext; intro p; rew vec.
        cut (incl (fo_term_syms (vec_pos v p)) ls).
        2:{ intros s Hs; apply H3; simpl; apply in_flat_map.
            exists (vec_pos v p); split; auto.
            apply in_vec_list, in_vec_pos. }
        cut (forall n, In n (fo_term_vars (vec_pos v p)) -> φ n = ψ n).
        2:{ intros n Hn; apply H2, in_flat_map.
            exists (vec_pos v p); split; auto.
            apply in_vec_list, in_vec_pos. }
        generalize (vec_pos v p); intros [ n | s w ] H5 H6; simpl; auto.
        apply H5; simpl; auto.
      + apply fol_bin_sem_ext.
        * apply HA; auto.
          - intros s G1 G2; apply (H1 _ G1), in_app_iff; auto.
          - intros; apply H2, in_app_iff; auto.
          - intros ? ?; apply H3, in_app_iff; auto.
        * apply HB; auto.
          - intros s G1 G2; apply (H1 _ G1), in_app_iff; auto.
          - intros; apply H2, in_app_iff; auto.
          - intros ? ?; apply H3, in_app_iff; auto.
      + apply fol_quant_sem_ext; intros x.
        rewrite <- HA with (φ := x·φ); unfold M; simpl; try tauto.
        * intros s G1 G2; apply (H1 _ G1).
          simpl; apply in_flat_map.
          exists (S (σ s)); simpl; auto.
        * intros [|n] Hn; simpl; auto.
          apply H2; simpl; apply in_flat_map.
          exists (S n); simpl; auto.
    Qed.

  End completeness.

End remove_constants.

Section reduction.

  Variable (Σ  : fo_signature)
           (Σ0 : forall s, ar_syms Σ s = 0)
           (Σd : discrete (syms Σ)).

  Section syms_map.

    Variable A : fol_form Σ.

    Let ls := fol_syms A.
    Let K := list_discr_pos_n Σd ls.

    Let n := projT1 K.
    Let v : vec _ n := projT1 (projT2 K).
    Let g : _ -> option (pos n) := proj1_sig (projT2 (projT2 K)).

    Let HK := proj2_sig (projT2 (projT2 K)).

    Let H1 x : in_vec x v <-> In x ls.
    Proof. apply (proj1 HK). Qed.

    Let H2 x : In x ls <-> g x <> None.
    Proof. apply (proj1 (proj2 HK)). Qed.

    Let H3 p : g (vec_pos v p) = Some p.
    Proof. apply (proj1 (proj2 (proj2 HK))). Qed.

    Let H4 x p : g x = Some p -> vec_pos v p = x.
    Proof. apply (proj2 (proj2 (proj2 HK))). Qed.

    Let σ s :=
      match g s with
        | Some p => pos2nat p
        | None   => 0
      end.

    Let f x : option (syms Σ) :=
      match le_lt_dec n x with
        | left _  => None
        | right H => Some (vec_pos v (nat2pos H))
      end.

    Let Hfσ s : In s ls -> f (σ s) = Some s.
    Proof.
      rewrite H2.
      unfold f, σ.
      generalize (H4 s).
      destruct (g s) as [ p | ].
      + intros E _.
        specialize (E _ eq_refl); subst.
        generalize (pos2nat_prop p).
        destruct (le_lt_dec n (pos2nat p)) as [ | H ].
        * intros; exfalso; lia.
        * rewrite nat2pos_pos2nat; auto.
      + intros _ []; auto.
    Qed.

    Local Fact syms_map : { σ  : syms Σ -> nat           &
                          { f  : nat -> option (syms Σ)  |
                            forall s, In s ls -> f (σ s) = Some s } }.
    Proof. exists σ, f; auto. Qed.

  End syms_map.

  Hint Resolve incl_refl : core.

  Theorem Sig_rem_cst_dep_red A : { B | @fo_form_fin_dec_SAT Σ A <-> @fo_form_fin_dec_SAT (Σrem_cst Σ) B }.
  Proof.
    generalize (fol_vars_max_spec A).
    set (m := fol_vars_max A); intros Hm.
    destruct (syms_map A) as (g & f & Hfg).
    set (σ s := g s + S m).
    exists (encode σ A).
    split.
    + intros (X & M & G1 & G2 & phi & G3).
      exists X, (Σrem_cst_model M), G1.
      exists. { intros r; simpl; apply G2. }
      set (psi n :=
        match le_lt_dec (S m) n with
          | left _  =>
          match f (n - S m) with
            | Some s => fom_syms M s (cast ø (eq_sym (Σ0 _)))
            | None   => phi 0
          end
          | right _ => phi n
        end).
      exists psi.
      revert G3; apply soundness with (HΣ := Σ0) (ls := fol_syms A); auto.
      * intros s Hs; unfold σ; intros H.
        apply Hm in H; lia.
      * intros n Hn; apply Hm in Hn.
        unfold psi.
        destruct (le_lt_dec (S m) n); try lia; auto.
      * intros s Hs.
        unfold psi, σ.
        apply Hfg in Hs.
        replace (g s + S m - S m) with (g s) by lia.
        rewrite Hs.
        destruct (le_lt_dec (S m) (g s + S m)); auto; lia.
    + intros (X & M' & G1 & G2 & psi & G3).
      exists X, (Σadd_cst_model M' σ psi), G1.
      exists. { intros r; simpl; apply G2. }
      exists psi.
      revert G3; apply completeness with (ls := fol_syms A); auto.
      intros s Hs; unfold σ; intros H.
      apply Hm in H; lia.
  Qed.

End reduction.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__3__6b.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__congruenceflip.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export lemma__extension.
Require Export lemma__inequalitysymmetric.
Require Export logic.
Require Export proposition__10.
Definition proposition__12 : forall A B C, (euclidean__axioms.nCol A B C) -> (exists X, euclidean__defs.Perp__at C X A B X).
Proof.
intro A.
intro B.
intro C.
intro H.
assert (* Cut *) (~(B = C)) as H0.
- intro H0.
assert (* Cut *) (euclidean__axioms.Col A B C) as H1.
-- right.
right.
left.
exact H0.
-- apply (@euclidean__tactics.Col__nCol__False A B C H H1).
- assert (* Cut *) (euclidean__axioms.neq C B) as H1.
-- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B C H0).
-- assert (* Cut *) (~(A = B)) as H2.
--- intro H2.
assert (* Cut *) (euclidean__axioms.Col A B C) as H3.
---- left.
exact H2.
---- apply (@euclidean__tactics.Col__nCol__False A B C H H3).
--- assert (* Cut *) (exists E, (euclidean__axioms.BetS C B E) /\ (euclidean__axioms.Cong B E C B)) as H3.
---- apply (@lemma__extension.lemma__extension C B C B H1 H1).
---- destruct H3 as [E H4].
destruct H4 as [H5 H6].
assert (* Cut *) (euclidean__axioms.neq C E) as H7.
----- assert (* Cut *) ((euclidean__axioms.neq B E) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C E))) as H7.
------ apply (@lemma__betweennotequal.lemma__betweennotequal C B E H5).
------ destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
exact H11.
----- assert (* Cut *) (euclidean__axioms.neq E C) as H8.
------ apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric C E H7).
------ assert (* Cut *) (exists F, (euclidean__axioms.BetS E C F) /\ (euclidean__axioms.Cong C F E C)) as H9.
------- apply (@lemma__extension.lemma__extension E C E C H8 H8).
------- destruct H9 as [F H10].
destruct H10 as [H11 H12].
assert (* Cut *) (euclidean__axioms.Cong E C C E) as H13.
-------- apply (@euclidean__axioms.cn__equalityreverse E C).
-------- assert (* Cut *) (euclidean__axioms.Cong C E C E) as H14.
--------- apply (@euclidean__axioms.cn__congruencereflexive C E).
--------- assert (* Cut *) (euclidean__axioms.Cong C F C E) as H15.
---------- apply (@lemma__congruencetransitive.lemma__congruencetransitive C F E C C E H12 H13).
---------- assert (* Cut *) (euclidean__axioms.BetS E B C) as H16.
----------- apply (@euclidean__axioms.axiom__betweennesssymmetry C B E H5).
----------- assert (* Cut *) (euclidean__axioms.BetS E B F) as H17.
------------ apply (@lemma__3__6b.lemma__3__6b E B C F H16 H11).
------------ assert (* Cut *) (exists K, euclidean__axioms.CI K C C E) as H18.
------------- apply (@euclidean__axioms.postulate__Euclid3 C E H7).
------------- destruct H18 as [K H19].
assert (euclidean__axioms.Cong C E C E) as H20 by exact H14.
assert (* Cut *) (euclidean__axioms.Cong C B C B) as H21.
-------------- apply (@euclidean__axioms.cn__congruencereflexive C B).
-------------- assert (* Cut *) (euclidean__axioms.InCirc B K) as H22.
--------------- exists E.
exists B.
exists C.
exists C.
exists E.
split.
---------------- exact H19.
---------------- right.
split.
----------------- exact H5.
----------------- split.
------------------ exact H20.
------------------ exact H21.
--------------- assert (* Cut *) (exists P Q, (euclidean__axioms.Col A B P) /\ ((euclidean__axioms.BetS A B Q) /\ ((euclidean__axioms.OnCirc P K) /\ ((euclidean__axioms.OnCirc Q K) /\ (euclidean__axioms.BetS P B Q))))) as H23.
---------------- apply (@euclidean__axioms.postulate__line__circle A B C K C E H19 H22 H2).
---------------- destruct H23 as [P H24].
destruct H24 as [Q H25].
destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
assert (* Cut *) (euclidean__axioms.Col A B Q) as H34.
----------------- right.
right.
right.
right.
left.
exact H28.
----------------- assert (* Cut *) (euclidean__axioms.Cong C P C E) as H35.
------------------ apply (@euclidean__axioms.axiom__circle__center__radius C C E K P H19 H30).
------------------ assert (* Cut *) (euclidean__axioms.Cong C Q C E) as H36.
------------------- apply (@euclidean__axioms.axiom__circle__center__radius C C E K Q H19 H32).
------------------- assert (* Cut *) (euclidean__axioms.Cong C E C Q) as H37.
-------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric C C Q E H36).
-------------------- assert (* Cut *) (euclidean__axioms.Cong C P C Q) as H38.
--------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive C P C E C Q H35 H37).
--------------------- assert (* Cut *) (euclidean__axioms.Cong P C Q C) as H39.
---------------------- assert (* Cut *) ((euclidean__axioms.Cong P C Q C) /\ ((euclidean__axioms.Cong P C C Q) /\ (euclidean__axioms.Cong C P Q C))) as H39.
----------------------- apply (@lemma__congruenceflip.lemma__congruenceflip C P C Q H38).
----------------------- destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
exact H40.
---------------------- assert (* Cut *) (euclidean__axioms.neq P Q) as H40.
----------------------- assert (* Cut *) ((euclidean__axioms.neq B Q) /\ ((euclidean__axioms.neq P B) /\ (euclidean__axioms.neq P Q))) as H40.
------------------------ apply (@lemma__betweennotequal.lemma__betweennotequal P B Q H33).
------------------------ destruct H40 as [H41 H42].
destruct H42 as [H43 H44].
exact H44.
----------------------- assert (* Cut *) (exists M, (euclidean__axioms.BetS P M Q) /\ (euclidean__axioms.Cong M P M Q)) as H41.
------------------------ apply (@proposition__10.proposition__10 P Q H40).
------------------------ destruct H41 as [M H42].
destruct H42 as [H43 H44].
assert (* Cut *) (euclidean__axioms.Cong P M Q M) as H45.
------------------------- assert (* Cut *) ((euclidean__axioms.Cong P M Q M) /\ ((euclidean__axioms.Cong P M M Q) /\ (euclidean__axioms.Cong M P Q M))) as H45.
-------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip M P M Q H44).
-------------------------- destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
exact H46.
------------------------- assert (* Cut *) (euclidean__axioms.Col P M Q) as H46.
-------------------------- right.
right.
right.
right.
left.
exact H43.
-------------------------- assert (* Cut *) (euclidean__axioms.Col P B Q) as H47.
--------------------------- right.
right.
right.
right.
left.
exact H33.
--------------------------- assert (* Cut *) (euclidean__axioms.Col P Q B) as H48.
---------------------------- assert (* Cut *) ((euclidean__axioms.Col B P Q) /\ ((euclidean__axioms.Col B Q P) /\ ((euclidean__axioms.Col Q P B) /\ ((euclidean__axioms.Col P Q B) /\ (euclidean__axioms.Col Q B P))))) as H48.
----------------------------- apply (@lemma__collinearorder.lemma__collinearorder P B Q H47).
----------------------------- destruct H48 as [H49 H50].
destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
destruct H54 as [H55 H56].
exact H55.
---------------------------- assert (* Cut *) (euclidean__axioms.Col P Q M) as H49.
----------------------------- assert (* Cut *) ((euclidean__axioms.Col M P Q) /\ ((euclidean__axioms.Col M Q P) /\ ((euclidean__axioms.Col Q P M) /\ ((euclidean__axioms.Col P Q M) /\ (euclidean__axioms.Col Q M P))))) as H49.
------------------------------ apply (@lemma__collinearorder.lemma__collinearorder P M Q H46).
------------------------------ destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
destruct H53 as [H54 H55].
destruct H55 as [H56 H57].
exact H56.
----------------------------- assert (* Cut *) (euclidean__axioms.Col Q B M) as H50.
------------------------------ apply (@euclidean__tactics.not__nCol__Col Q B M).
-------------------------------intro H50.
apply (@euclidean__tactics.Col__nCol__False Q B M H50).
--------------------------------apply (@lemma__collinear4.lemma__collinear4 P Q B M H48 H49 H40).

------------------------------ assert (* Cut *) (euclidean__axioms.Col Q B A) as H51.
------------------------------- assert (* Cut *) ((euclidean__axioms.Col B A Q) /\ ((euclidean__axioms.Col B Q A) /\ ((euclidean__axioms.Col Q A B) /\ ((euclidean__axioms.Col A Q B) /\ (euclidean__axioms.Col Q B A))))) as H51.
-------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A B Q H34).
-------------------------------- destruct H51 as [H52 H53].
destruct H53 as [H54 H55].
destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
exact H59.
------------------------------- assert (* Cut *) (euclidean__axioms.neq B Q) as H52.
-------------------------------- assert (* Cut *) ((euclidean__axioms.neq B Q) /\ ((euclidean__axioms.neq P B) /\ (euclidean__axioms.neq P Q))) as H52.
--------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal P B Q H33).
--------------------------------- destruct H52 as [H53 H54].
destruct H54 as [H55 H56].
exact H53.
-------------------------------- assert (* Cut *) (euclidean__axioms.neq Q B) as H53.
--------------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B Q H52).
--------------------------------- assert (* Cut *) (euclidean__axioms.Col B M A) as H54.
---------------------------------- apply (@euclidean__tactics.not__nCol__Col B M A).
-----------------------------------intro H54.
apply (@euclidean__tactics.Col__nCol__False B M A H54).
------------------------------------apply (@lemma__collinear4.lemma__collinear4 Q B M A H50 H51 H53).

---------------------------------- assert (* Cut *) (euclidean__axioms.Col A B M) as H55.
----------------------------------- assert (* Cut *) ((euclidean__axioms.Col M B A) /\ ((euclidean__axioms.Col M A B) /\ ((euclidean__axioms.Col A B M) /\ ((euclidean__axioms.Col B A M) /\ (euclidean__axioms.Col A M B))))) as H55.
------------------------------------ apply (@lemma__collinearorder.lemma__collinearorder B M A H54).
------------------------------------ destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
destruct H59 as [H60 H61].
destruct H61 as [H62 H63].
exact H60.
----------------------------------- assert (* Cut *) (~(M = C)) as H56.
------------------------------------ intro H56.
assert (* Cut *) (euclidean__axioms.Col A B C) as H57.
------------------------------------- apply (@eq__ind__r euclidean__axioms.Point C (fun M0 => (euclidean__axioms.BetS P M0 Q) -> ((euclidean__axioms.Cong M0 P M0 Q) -> ((euclidean__axioms.Cong P M0 Q M0) -> ((euclidean__axioms.Col P M0 Q) -> ((euclidean__axioms.Col P Q M0) -> ((euclidean__axioms.Col Q B M0) -> ((euclidean__axioms.Col B M0 A) -> ((euclidean__axioms.Col A B M0) -> (euclidean__axioms.Col A B C)))))))))) with (x := M).
--------------------------------------intro H57.
intro H58.
intro H59.
intro H60.
intro H61.
intro H62.
intro H63.
intro H64.
exact H64.

-------------------------------------- exact H56.
-------------------------------------- exact H43.
-------------------------------------- exact H44.
-------------------------------------- exact H45.
-------------------------------------- exact H46.
-------------------------------------- exact H49.
-------------------------------------- exact H50.
-------------------------------------- exact H54.
-------------------------------------- exact H55.
------------------------------------- apply (@euclidean__tactics.Col__nCol__False A B C H H57).
------------------------------------ assert (* Cut *) (euclidean__defs.Per P M C) as H57.
------------------------------------- exists Q.
split.
-------------------------------------- exact H43.
-------------------------------------- split.
--------------------------------------- exact H45.
--------------------------------------- split.
---------------------------------------- exact H39.
---------------------------------------- exact H56.
------------------------------------- assert (* Cut *) (M = M) as H58.
-------------------------------------- apply (@logic.eq__refl Point M).
-------------------------------------- assert (* Cut *) (euclidean__axioms.Col C M M) as H59.
--------------------------------------- right.
right.
left.
exact H58.
--------------------------------------- assert (* Cut *) (euclidean__defs.Perp__at C M A B M) as H60.
---------------------------------------- exists P.
split.
----------------------------------------- exact H59.
----------------------------------------- split.
------------------------------------------ exact H55.
------------------------------------------ split.
------------------------------------------- exact H26.
------------------------------------------- exact H57.
---------------------------------------- exists M.
exact H60.
Qed.