Require Import Ensembles.
Require Import Coq.Lists.List.
Require Import ListExt.
Require Import folProof.
Require Import folProp.
Require Vector.
Require Import Peano_dec.
Require Import misc.
Require Import Arith.

Section Model_Theory.

Variable L : Language.

Fixpoint naryFunc (A : Set) (n : nat) {struct n} : Set :=
  match n with
  | O => A
  | S m => A -> naryFunc A m
  end.

Fixpoint naryRel (A : Set) (n : nat) {struct n} : Type :=
  match n with
  | O => Prop
  | S m => A -> naryRel A m
  end.

Record Model : Type := model
  {U : Set;
   func : forall f : Functions L, naryFunc U (arity L (inr _ f));
   rel : forall r : Relations L, naryRel U (arity L (inl _ r))}.

Variable M : Model.

Fixpoint interpTerm (value : nat -> U M) (t : Term L) {struct t} :
 U M :=
  match t with
  | var v => value v
  | apply f ts => interpTerms _ (func M f) value ts
  end

 with interpTerms (m : nat) (f : naryFunc (U M) m)
 (value : nat -> U M) (ts : Terms L m) {struct ts} :
 U M :=
  match ts in (Terms _ n) return (naryFunc (U M) n -> U M) with
  | Tnil => fun f => f
  | Tcons m t ts => fun f => interpTerms m (f (interpTerm value t)) value ts
  end f.

Fixpoint interpRels (m : nat) (r : naryRel (U M) m)
 (value : nat -> U M) (ts : Terms L m) {struct ts} : Prop :=
  match ts in (Terms _ n) return (naryRel (U M) n -> Prop) with
  | Tnil => fun r => r
  | Tcons m t ts => fun r => interpRels m (r (interpTerm value t)) value ts
  end r.

Definition updateValue (value : nat -> U M) (n : nat)
  (v : U M) (x : nat) : U M :=
  match eq_nat_dec n x with
  | left _ => v
  | right _ => value x
  end.

Fixpoint interpFormula (value : nat -> U M) (f : Formula L) {struct f} :
 Prop :=
  match f with
  | equal t s => interpTerm value t = interpTerm value s
  | atomic r ts => interpRels _ (rel M r) value ts
  | impH A B => interpFormula value A -> interpFormula value B
  | notH A => interpFormula value A -> False
  | forallH v A => forall x : U M, interpFormula (updateValue value v x) A
  end.

Lemma freeVarInterpTerm :
 forall (v1 v2 : nat -> U M) (t : Term L),
 (forall x : nat, In x (freeVarTerm L t) -> v1 x = v2 x) ->
 interpTerm v1 t = interpTerm v2 t.
Proof.
intros v1 v2 t.
elim t using
 Term_Terms_ind
  with
    (P0 := fun (n : nat) (ts : Terms L n) =>
           forall f : naryFunc (U M) n,
           (forall x : nat, In x (freeVarTerms L n ts) -> v1 x = v2 x) ->
           interpTerms n f v1 ts = interpTerms n f v2 ts);
 simpl in |- *; intros.
apply H.
auto.
apply H.
intros.
apply H0.
apply H1.
auto.
rewrite H.
apply H0.
intros.
apply H1.
unfold freeVarTerms in |- *.
apply in_or_app.
right.
apply H2.
intros.
apply H1.
unfold freeVarTerms in |- *.
apply in_or_app.
left.
apply H2.
Qed.

Lemma freeVarInterpRel :
 forall (v1 v2 : nat -> U M) (n : nat) (ts : Terms L n) (r : naryRel (U M) n),
 (forall x : nat, In x (freeVarTerms L n ts) -> v1 x = v2 x) ->
 interpRels n r v1 ts -> interpRels n r v2 ts.
Proof.
intros v1 v2 n ts r H.
induction ts as [| n t ts Hrects]; simpl in |- *.
auto.
rewrite (freeVarInterpTerm v1 v2).
apply Hrects.
intros.
apply H.
unfold freeVarTerms in |- *.
apply in_or_app.
right.
apply H0.
intros.
apply H.
unfold freeVarTerms in |- *.
apply in_or_app.
left.
apply H0.
Qed.

Lemma freeVarInterpFormula :
 forall (v1 v2 : nat -> U M) (g : Formula L),
 (forall x : nat, In x (freeVarFormula L g) -> v1 x = v2 x) ->
 interpFormula v1 g -> interpFormula v2 g.
Proof.
intros v1 v2 g.
generalize v1 v2.
clear v1 v2.
induction g as [t t0| r t| g1 Hrecg1 g0 Hrecg0| g Hrecg| n g Hrecg];
 simpl in |- *; intros v1 v2 H.
repeat rewrite (freeVarInterpTerm v1 v2).
auto.
intros.
apply H.
simpl in |- *.
auto with datatypes.
intros.
apply H.
simpl in |- *.
auto with datatypes.
intros.
apply (freeVarInterpRel v1 v2).
apply H.
apply H0.
assert (interpFormula v2 g1 -> interpFormula v1 g1).
apply Hrecg1.
intros.
symmetry  in |- *.
apply H.
simpl in |- *.
auto with datatypes.
assert (interpFormula v1 g0 -> interpFormula v2 g0).
apply Hrecg0.
intros.
apply H.
simpl in |- *.
auto with datatypes.
tauto.
intros.
apply H0.
apply Hrecg with v2.
intros.
symmetry  in |- *.
auto.
assumption.
intros.
apply Hrecg with (updateValue v1 n x).
intros.
unfold updateValue in |- *.
induction (eq_nat_dec n x0).
reflexivity.
apply H.
apply In_list_remove3; auto.
auto.
Qed.

Lemma subInterpTerm :
 forall (value : nat -> U M) (t : Term L) (v : nat) (s : Term L),
 interpTerm (updateValue value v (interpTerm value s)) t =
 interpTerm value (substituteTerm L t v s).
Proof.
intros.
elim t using
 Term_Terms_ind
  with
    (P0 := fun (n : nat) (ts : Terms L n) =>
           forall f : naryFunc (U M) n,
           interpTerms n f (updateValue value v (interpTerm value s)) ts =
           interpTerms n f value (substituteTerms L n ts v s));
 simpl in |- *; intros.
unfold updateValue in |- *.
induction (eq_nat_dec v n); reflexivity.
rewrite H.
reflexivity.
reflexivity.
rewrite H.
apply H0.
Qed.

Lemma subInterpRel :
 forall (value : nat -> U M) (n : nat) (ts : Terms L n)
   (v : nat) (s : Term L) (r : naryRel (U M) n),
 interpRels n r (updateValue value v (interpTerm value s)) ts <->
 interpRels n r value (substituteTerms L n ts v s).
Proof.
intros.
induction ts as [| n t ts Hrects].
simpl in |- *.
tauto.
simpl in |- *.
rewrite <- subInterpTerm.
apply Hrects.
Qed.

Lemma subInterpFormula :
 forall (value : nat -> U M) (f : Formula L) (v : nat) (s : Term L),
 interpFormula (updateValue value v (interpTerm value s)) f <->
 interpFormula value (substituteFormula L f v s).
Proof.
intros value f.
generalize value.
clear value.
elim f using Formula_depth_ind2; simpl in |- *; intros.
repeat rewrite subInterpTerm.
tauto.
apply subInterpRel.
rewrite (subFormulaImp L).
simpl in |- *.
assert
 (interpFormula (updateValue value v (interpTerm value s)) f1 <->
  interpFormula value (substituteFormula L f1 v s)).
auto.
assert
 (interpFormula (updateValue value v (interpTerm value s)) f0 <->
  interpFormula value (substituteFormula L f0 v s)).
auto.
tauto.
rewrite (subFormulaNot L).
simpl in |- *.
assert
 (interpFormula (updateValue value v (interpTerm value s)) f0 <->
  interpFormula value (substituteFormula L f0 v s)).
auto.
tauto.
rewrite (subFormulaForall L).
induction (eq_nat_dec v v0).
rewrite a0.
simpl in |- *.
unfold updateValue in |- *.
split.
intros.
apply
 freeVarInterpFormula
  with
    (fun x0 : nat =>
     match eq_nat_dec v0 x0 with
     | left _ => x
     | right _ =>
         match eq_nat_dec v0 x0 with
         | left _ => interpTerm value s
         | right _ => value x0
         end
     end).
intros.
induction (eq_nat_dec v0 x0); reflexivity.
auto.
intros.
apply
 freeVarInterpFormula
  with
    (fun x0 : nat =>
     match eq_nat_dec v0 x0 with
     | left _ => x
     | right _ => value x0
     end).
intros.
induction (eq_nat_dec v0 x0); reflexivity.
auto.
induction (In_dec eq_nat_dec v (freeVarTerm L s)).
simpl in |- *.
set (nv := newVar (v0 :: freeVarTerm L s ++ freeVarFormula L a)) in *.
assert (~ In nv (v0 :: freeVarTerm L s ++ freeVarFormula L a)).
unfold nv in |- *.
apply newVar1.
assert
 (forall (x : U M) (x0 : nat),
  In x0 (freeVarFormula L a) ->
  updateValue (updateValue value v0 (interpTerm value s)) v x x0 =
  updateValue
    (updateValue (updateValue value nv x) v0
       (interpTerm (updateValue value nv x) s)) v
    (interpTerm
       (updateValue (updateValue value nv x) v0
          (interpTerm (updateValue value nv x) s))
       (var L nv)) x0).
intros.
unfold updateValue in |- *.
simpl in |- *.
induction (eq_nat_dec v x0).
induction (eq_nat_dec v0 nv).
elim H0.
rewrite a2.
simpl in |- *.
auto.
induction (eq_nat_dec nv nv).
reflexivity.
elim b1.
reflexivity.
induction (eq_nat_dec v0 x0).
apply freeVarInterpTerm.
intros.
induction (eq_nat_dec nv x1).
elim H0.
rewrite a2.
simpl in |- *.
auto with datatypes.
reflexivity.
induction (eq_nat_dec nv x0).
elim H0.
rewrite a1.
auto with datatypes.
reflexivity.
assert
 ((forall x : U M,
   interpFormula
     (updateValue
        (updateValue (updateValue value nv x) v0
           (interpTerm (updateValue value nv x) s)) v
        (interpTerm
           (updateValue (updateValue value nv x) v0
              (interpTerm (updateValue value nv x) s))
           (var L nv))) a) <->
  (forall x : U M,
   interpFormula (updateValue value nv x)
     (substituteFormula L (substituteFormula L a v (var L nv)) v0 s))).
split.
assert
 (forall b : Formula L,
  lt_depth L b (forallH L v a) ->
  forall (value : nat -> U M) (v : nat) (s : Term L),
  interpFormula (updateValue value v (interpTerm value s)) b ->
  interpFormula value (substituteFormula L b v s)).
intros.
induction (H b0 H2 value0 v1 s0).
auto.
intros.
apply H2.
eapply eqDepth.
symmetry  in |- *.
apply subFormulaDepth.
apply depthForall.
apply H2.
apply depthForall.
apply H3.
intros.
assert
 (forall b : Formula L,
  lt_depth L b (forallH L v a) ->
  forall (value : nat -> U M) (v : nat) (s : Term L),
  interpFormula value (substituteFormula L b v s) ->
  interpFormula (updateValue value v (interpTerm value s)) b).
intros.
induction (H b0 H3 value0 v1 s0).
auto.
clear H.
intros.
apply H3.
apply depthForall.
apply H3.
eapply eqDepth.
symmetry  in |- *.
apply subFormulaDepth.
apply depthForall.
auto.
assert
 ((forall x : U M,
   interpFormula
     (updateValue (updateValue value v0 (interpTerm value s)) v x) a) <->
  (forall x : U M,
   interpFormula
     (updateValue
        (updateValue (updateValue value nv x) v0
           (interpTerm (updateValue value nv x) s)) v
        (interpTerm
           (updateValue (updateValue value nv x) v0
              (interpTerm (updateValue value nv x) s))
           (var L nv))) a)).
split.
intros.
apply
 freeVarInterpFormula
  with (updateValue (updateValue value v0 (interpTerm value s)) v x).
auto.
auto.
intros.
apply
 freeVarInterpFormula
  with
    (updateValue
       (updateValue (updateValue value nv x) v0
          (interpTerm (updateValue value nv x) s)) v
       (interpTerm
          (updateValue (updateValue value nv x) v0
             (interpTerm (updateValue value nv x) s))
          (var L nv))).
intros.
symmetry  in |- *.
auto.
auto.
tauto.
simpl in |- *.
assert
 (forall (x : U M) (x0 : nat),
  In x0 (freeVarFormula L a) ->
  updateValue (updateValue value v0 (interpTerm value s)) v x x0 =
  updateValue (updateValue value v x) v0
    (interpTerm (updateValue value v x) s) x0).
intros.
unfold updateValue in |- *.
induction (eq_nat_dec v x0).
induction (eq_nat_dec v0 x0).
elim b.
transitivity x0; auto.
reflexivity.
induction (eq_nat_dec v0 x0).
apply freeVarInterpTerm.
intros.
induction (eq_nat_dec v x1).
elim b0.
rewrite a1.
auto.
reflexivity.
reflexivity.
split.
intros.
assert
 (forall b : Formula L,
  lt_depth L b (forallH L v a) ->
  forall (value : nat -> U M) (v : nat) (s : Term L),
  interpFormula (updateValue value v (interpTerm value s)) b ->
  interpFormula value (substituteFormula L b v s)).
intros.
induction (H b1 H2 value0 v1 s0).
auto.
apply H2.
apply depthForall.
apply
 freeVarInterpFormula
  with (updateValue (updateValue value v0 (interpTerm value s)) v x).
apply (H0 x).
apply H1.
assert
 (forall b : Formula L,
  lt_depth L b (forallH L v a) ->
  forall (value : nat -> U M) (v : nat) (s : Term L),
  interpFormula value (substituteFormula L b v s) ->
  interpFormula (updateValue value v (interpTerm value s)) b).
intros.
induction (H b1 H1 value0 v1 s0).
auto.
intros.
apply
 freeVarInterpFormula
  with
    (updateValue (updateValue value v x) v0
       (interpTerm (updateValue value v x) s)).
intros.
symmetry  in |- *.
auto.
apply H1.
apply depthForall.
auto.
Qed.

Lemma subInterpFormula1 :
 forall (value : nat -> U M) (f : Formula L) (v : nat) (s : Term L),
 interpFormula (updateValue value v (interpTerm value s)) f ->
 interpFormula value (substituteFormula L f v s).
Proof.
intros.
induction (subInterpFormula value f v s).
auto.
Qed.

Lemma subInterpFormula2 :
 forall (value : nat -> U M) (f : Formula L) (v : nat) (s : Term L),
 interpFormula value (substituteFormula L f v s) ->
 interpFormula (updateValue value v (interpTerm value s)) f.
Proof.
intros.
induction (subInterpFormula value f v s).
auto.
Qed.

Fixpoint nnHelp (f : Formula L) : Formula L :=
  match f with
  | equal t s => equal L t s
  | atomic r ts => atomic L r ts
  | impH A B => impH L (nnHelp A) (nnHelp B)
  | notH A => notH L (nnHelp A)
  | forallH v A => forallH L v (notH L (notH L (nnHelp A)))
  end.

Definition nnTranslate (f : Formula L) : Formula L :=
  notH L (notH L (nnHelp f)).

Lemma freeVarNNHelp :
 forall f : Formula L, freeVarFormula L f = freeVarFormula L (nnHelp f).
Proof.
intros.
induction f as [t t0| r t| f1 Hrecf1 f0 Hrecf0| f Hrecf| n f Hrecf];
 try reflexivity.
simpl in |- *.
rewrite Hrecf1.
rewrite Hrecf0.
reflexivity.
simpl in |- *.
assumption.
simpl in |- *.
rewrite Hrecf.
reflexivity.
Qed.

Lemma subNNHelp :
 forall (f : Formula L) (v : nat) (s : Term L),
 substituteFormula L (nnHelp f) v s = nnHelp (substituteFormula L f v s).
Proof.
intro f.
elim f using Formula_depth_ind2; intros; try reflexivity.
simpl in |- *.
rewrite subFormulaImp.
rewrite H.
rewrite H0.
rewrite subFormulaImp.
reflexivity.
simpl in |- *.
rewrite subFormulaNot.
rewrite H.
rewrite subFormulaNot.
reflexivity.
simpl in |- *.
do 2 rewrite subFormulaForall.
simpl in |- *.
induction (eq_nat_dec v v0).
simpl in |- *.
reflexivity.
induction (In_dec eq_nat_dec v (freeVarTerm L s)).
simpl in |- *.
repeat rewrite subFormulaNot.
repeat rewrite H.
rewrite <- freeVarNNHelp.
reflexivity.
eapply eqDepth.
symmetry  in |- *.
apply subFormulaDepth.
apply depthForall.
apply depthForall.
repeat rewrite subFormulaNot.
rewrite H.
simpl in |- *.
reflexivity.
apply depthForall.
Qed.

Section Consistent_Theory.

Variable T : System L.

Fixpoint interpTermsVector (value : nat -> U M) (n : nat)
 (ts : Terms L n) {struct ts} : Vector.t (U M) n :=
  match ts in (Terms _ n) return (Vector.t (U M) n) with
  | Tnil => Vector.nil (U M)
  | Tcons m t ts =>
      Vector.cons (U M) (interpTerm value t) m (interpTermsVector value m ts)
  end.

Lemma preserveValue :
 forall value : nat -> U M,
 (forall f : Formula L,
  mem _ T f -> interpFormula value (nnTranslate f)) ->
 forall g : Formula L, SysPrf L T g -> interpFormula value (nnTranslate g).
Proof.
intros.
induction H0 as (x, H0).
induction H0 as (x0, H0).
cut (forall g : Formula L, In g x -> interpFormula value (nnTranslate g)).
clear H H0.
generalize value.
clear value.
induction x0
 as
  [A|
   Axm1 Axm2 A B x0_1 Hrecx0_1 x0_0 Hrecx0_0|
   Axm A v n x0 Hrecx0|
   A B|
   A B C|
   A B|
   A v t|
   A v n|
   A B v|
   |
   |
   |
   R|
   f]; intros; try (simpl in |- *; tauto).
apply H.
auto with datatypes.
assert (interpFormula value (nnTranslate A)).
auto with datatypes.
assert (interpFormula value (nnTranslate (impH L A B))).
auto with datatypes.
clear Hrecx0_1 Hrecx0_0.
simpl in H0.
simpl in H1.
simpl in |- *.
tauto.
simpl in |- *.
intros.
apply H0.
clear H0.
intros.
simpl in Hrecx0.
apply (Hrecx0 (updateValue value v x)).
intros.
simpl in H.
eapply H.
apply H1.
intros.
apply H2.
apply freeVarInterpFormula with value.
intros.
rewrite <- freeVarNNHelp in H4.
unfold updateValue in |- *.
induction (eq_nat_dec v x1).
elim n.
rewrite a.
clear n x0 Hrecx0 H.
induction Axm as [| a0 Axm HrecAxm].
apply H1.
simpl in |- *.
simpl in H1.
induction H1 as [H| H].
rewrite H.
auto with datatypes.
auto with datatypes.
reflexivity.
assumption.
assumption.
simpl in |- *.
intros.
apply H0.
intros.
elim H1 with (interpTerm value t).
intros.
apply H0.
intros.
rewrite <- subNNHelp.
apply subInterpFormula1.
auto.
simpl in |- *.
intros.
apply H0.
intros.
apply H2.
apply freeVarInterpFormula with value.
intros.
unfold updateValue in |- *.
induction (eq_nat_dec v x0).
elim n.
rewrite a.
rewrite freeVarNNHelp.
assumption.
reflexivity.
assumption.
simpl in |- *.
intros.
apply H0.
clear H0.
intros.
apply H0 with x.
intros.
apply H1 with x.
auto.
simpl in |- *.
auto.
simpl in |- *.
intros.
apply H0.
intros.
transitivity (value 1); auto.
simpl in |- *.
intros.
apply H0.
clear H H0.
unfold AxmEq4 in |- *.
cut
 (forall a b : Terms L (arity L (inl (Functions L) R)),
  interpTermsVector value _ a = interpTermsVector value _ b ->
  interpFormula value (nnHelp (iffH L (atomic L R a) (atomic L R b)))).
assert
 (forall A,
  (forall a b : Terms L (arity L (inl (Functions L) R)),
   interpTermsVector value (arity L (inl (Functions L) R)) a =
   interpTermsVector value (arity L (inl (Functions L) R)) b ->
   interpFormula value (nnHelp (A a b))) ->
  interpFormula value
    (nnHelp
       (nat_rec (fun _ : nat => Formula L)
          (prod_rec
             (fun
                _ : Terms L (arity L (inl (Functions L) R)) *
                    Terms L (arity L (inl (Functions L) R)) =>
              Formula L)
             (fun a b : Terms L (arity L (inl (Functions L) R)) => A a b)
             (nVars L (arity L (inl (Functions L) R))))
          (fun (n : nat) (Hrecn : Formula L) =>
           impH L (equal L (var L (n + n)) (var L (S (n + n)))) Hrecn)
          (arity L (inl (Functions L) R))))).
generalize (arity L (inl (Functions L) R)).
simple induction n.
simpl in |- *.
intros.
apply H.
reflexivity.
intros.
simpl in |- *.
induction (nVars L n0).
simpl in |- *.
simpl in H.
intros.
apply
 (H
    (fun x y : Terms L n0 =>
     A (Tcons L n0 (var L (n0 + n0)) x) (Tcons L n0 (var L (S (n0 + n0))) y))).
intros.
apply H0.
simpl in |- *.
rewrite H1.
rewrite H2.
reflexivity.
apply (H (fun a b => iffH L (atomic L R a) (atomic L R b))).
simpl in |- *.
generalize (rel M R).
generalize (arity L (inl (Functions L) R)).
intros.
induction a as [| n t a Hreca].
assert (b = Tnil L).
symmetry  in |- *.
apply nilTerms.
rewrite H1 in H0.
auto.
induction (consTerms L n b).
induction x as (a0, b0).
simpl in p.
rewrite <- p in H0.
rewrite <- p in H.
simpl in H.
inversion H.
simpl in H0.
rewrite H2 in H0.
apply (Hreca (n0 (interpTerm value a0)) b0).
apply (inj_right_pair2 _ eq_nat_dec _ _ _ _ H3).
auto.
simpl in |- *.
intros.
apply H0.
clear H H0.
unfold AxmEq5 in |- *.
cut
 (forall a b : Terms L (arity L (inr (Relations L) f)),
  interpTermsVector value _ a = interpTermsVector value _ b ->
  interpFormula value (nnHelp (equal L (apply L f a) (apply L f b)))).
assert
 (forall A,
  (forall a b : Terms L (arity L (inr (Relations L) f)),
   interpTermsVector value (arity L (inr (Relations L) f)) a =
   interpTermsVector value (arity L (inr (Relations L) f)) b ->
   interpFormula value (nnHelp (A a b))) ->
  interpFormula value
    (nnHelp
       (nat_rec (fun _ : nat => Formula L)
          (prod_rec
             (fun
                _ : Terms L (arity L (inr (Relations L) f)) *
                    Terms L (arity L (inr (Relations L) f)) =>
              Formula L)
             (fun a b : Terms L (arity L (inr (Relations L) f)) => A a b)
             (nVars L (arity L (inr (Relations L) f))))
          (fun (n : nat) (Hrecn : Formula L) =>
           impH L (equal L (var L (n + n)) (var L (S (n + n)))) Hrecn)
          (arity L (inr (Relations L) f))))).
generalize (arity L (inr (Relations L) f)).
simple induction n.
simpl in |- *.
intros.
auto.
intros.
simpl in |- *.
induction (nVars L n0).
simpl in |- *.
simpl in H.
intros.
apply
 (H
    (fun x y : Terms L n0 =>
     A (Tcons L n0 (var L (n0 + n0)) x) (Tcons L n0 (var L (S (n0 + n0))) y))).
intros.
apply H0.
simpl in |- *.
rewrite H1.
rewrite H2.
reflexivity.
apply (H (fun a b => equal L (apply L f a) (apply L f b))).
simpl in |- *.
generalize (func M f).
generalize (arity L (inr (Relations L) f)).
intros.
induction a as [| n t a Hreca].
assert (b = Tnil L).
symmetry  in |- *.
apply nilTerms.
rewrite H0.
reflexivity.
induction (consTerms L n b).
induction x as (a0, b0).
simpl in p.
rewrite <- p.
rewrite <- p in H.
simpl in H.
inversion H.
simpl in |- *.
rewrite H1.
apply Hreca.
apply (inj_right_pair2 _ eq_nat_dec _ _ _ _ H2).
auto.
Qed.

Lemma ModelConsistent :
 forall value : nat -> U M,
 (forall f : Formula L,
  mem _ T f -> interpFormula value (nnTranslate f)) ->
 Consistent L T.
Proof.
intros.
unfold Consistent in |- *.
exists (notH L (equal L (var  L 0) (var L 0))).
unfold not in |- *; intros.
assert
 (interpFormula value
    (nnTranslate (notH L (equal L (var L 0) (var L 0))))).
apply preserveValue.
assumption.
auto.
simpl in *.
auto.
Qed.

End Consistent_Theory.

End Model_Theory.


(*
 * Closed forms for the sum of the p-th power of the first n natural numbers.
 * TODO: Faulhaber’s formula
 *)

From Coq Require Import
  Arith
  List
  Lia.
From FunProofs.Lib Require Import
  Series
  Util.

Import NSum.

Section TriangleSum.
  Notation numer n := (n * (n + 1)) (only parsing).

  Lemma tri_div_2 n : numer n mod 2 = 0.
  Proof.
    apply Nat.mod_divides, Nat.even_spec; try lia.
    rewrite Nat.even_mul, Nat.add_1_r, Nat.even_succ.
    apply Nat.orb_even_odd.
  Qed.

  Lemma triangle_sum n : sum (seq 1 n) = numer n / 2.
  Proof.
    induction n; auto.
    cbn [seq]; rewrite <- seq_shift; cbn -[Nat.div Nat.mul]; normalize_sums.
    rewrite sum_succ, sum_shift, IHn, seq_length.
    apply Nat.div_unique_exact; [lia |].
    unfold NSumOps.Tadd, NSumOps.T_of_nat, NSumOps.T0, id.
    enough (numer n = 2 * (numer n / 2)) by lia.
    apply Nat.div_exact; [lia | apply tri_div_2].
  Qed.
End TriangleSum.

Section SumSquare.
  Notation numer n := (n * (n + 1) * (2 * n + 1)) (only parsing).

  Lemma square_succ n : Nat.square (S n) = Nat.square n + 2 * n + 1.
  Proof. unfold Nat.square; lia. Qed.

  Lemma sum_square_succ ns n :
    sum' n (map (fun m => Nat.square (S m)) ns) =
    sum' n (map Nat.square ns) + 2 * sum ns + length ns.
  Proof.
    erewrite map_ext by (apply square_succ).
    rewrite !sum_add; fold (@const _ NSumOps.T 1).
    rewrite sum_const, sum_mul_id; cbn.
    unfold NSumOps.Tadd, NSumOps.T_of_nat, NSumOps.T, id in *; lia.
  Qed.

  Lemma square_div_6 n : numer n mod 6 = 0.
  Proof.
    induction n; auto.
    apply Nat.mod_divides in IHn as (m & IHn); try lia.
    match goal with |- ?x mod _ = _ => remember x as lhs end.
    replace lhs with (6 * (m + n * n + 2 * n + 1)) by lia.
    rewrite Nat.mul_comm; apply Nat.mod_mul; lia.
  Qed.

  Lemma sum_square n : sum (map Nat.square (seq 1 n)) = numer n / 6.
  Proof.
    induction n; auto.
    cbn [seq]; rewrite <- seq_shift; cbn -[Nat.div Nat.mul]; normalize_sums.
    change (Nat.square 1) with 1; rewrite sum_shift.
    rewrite map_map, sum_square_succ, IHn, triangle_sum, seq_length.
    apply Nat.div_unique_exact; [lia |].
    pose proof (tri_div_2 n) as Htri; apply Nat.div_exact in Htri; try lia.
    unfold NSumOps.Tadd, NSumOps.T_of_nat, NSumOps.T0, id.
    enough (numer n = 6 * (numer n / 6)) by lia.
    apply Nat.div_exact; [lia | apply square_div_6].
  Qed.
End SumSquare.

Section SumCube.
  Notation numer n := (n * n * (n + 1) * (n + 1)) (only parsing).

  Definition cube n := n * n * n.

  Lemma cube_succ n : cube (S n) = cube n + 3 * Nat.square n + 3 * n + 1.
  Proof. unfold cube, Nat.square; lia. Qed.

  Lemma sum_cube_succ ns n :
    sum' n (map (fun m => cube (S m)) ns) =
    sum' n (map cube ns) + 3 * sum (map (Nat.square) ns) + 3 * sum ns + length ns.
  Proof.
    erewrite map_ext by (apply cube_succ).
    rewrite !sum_add; fold (@const _ NSumOps.T 1).
    rewrite sum_const, sum_mul_id, sum_mul; cbn.
    unfold NSumOps.Tadd, NSumOps.T_of_nat, NSumOps.T, id in *; lia.
  Qed.

  Lemma cube_div_4 n : numer n mod 4 = 0.
  Proof.
    replace (numer n) with ((n * (n + 1)) * (n * (n + 1))) by lia.
    pose proof (tri_div_2 n) as Htri.
    apply Nat.mod_divides in Htri as (m & ->); try lia.
    replace (2 * m * (2 * m)) with (m * m * 4) by lia.
    apply Nat.mod_mul; lia.
  Qed.

  Lemma cube_square n : sum (map cube (seq 1 n)) = numer n / 4.
  Proof.
    induction n; auto.
    cbn [seq]; rewrite <- seq_shift; cbn -[Nat.div Nat.mul]; normalize_sums.
    change (cube 1) with 1; rewrite sum_shift.
    rewrite map_map, sum_cube_succ, IHn, sum_square, triangle_sum, seq_length.
    apply Nat.div_unique_exact; [lia |].
    pose proof (tri_div_2 n) as Htri; apply Nat.div_exact in Htri; try lia.
    pose proof (square_div_6 n) as Hsq; apply Nat.div_exact in Hsq; try lia.
    unfold NSumOps.Tadd, NSumOps.T_of_nat, NSumOps.T0, id.
    enough (numer n = 4 * (numer n / 4)) by lia.
    apply Nat.div_exact; [lia | apply cube_div_4].
  Qed.
End SumCube.


Require Export C11_Mediatrice.

Section OPPOSED_ANGLE.

Lemma BetweenHalfLineBetween : forall A B C D : Point,
	Between A B C ->
	HalfLine B C D ->
	Between A B D.
Proof.
	intros.
	autoClockwise.
Qed.

Lemma CongruentOppParallelogramm : forall A B C D E : Point,
		Between B A D ->
		Between C A E ->
		Distance A B = Distance A C ->
		Distance A B = Distance A D ->
		Distance A B = Distance A E ->
		~Collinear A B C ->
		Angle B A C = Angle E A D.
Proof.
	intros.
	apply CongruentStrictTrianglesA; repeat split.
	 trivial.
	 apply (CongruentStrictTrianglesCA C D B D C E).
	   apply CongruentStrictTrianglesSASB.
	  autoDistance.
	  rewrite <- (Chasles D A B).
	   rewrite <- (Chasles C A E).
	    rewrite (DistSym D A); rewrite (DistSym C A).
	      rewrite <- H1; rewrite <- H2; autoDistance.
	    apply BetweenHalfLine; trivial.
	    apply BetweenSymHalfLine; trivial.
	   apply BetweenSymHalfLine; trivial.
	   apply BetweenHalfLine; trivial.
	  assert (H5 : C <> D).
	   intro; elim H4; subst.
	     apply CollinearBAC; apply BetweenCollinear; trivial.
	   rewrite (CongruentItself D C B C A).
	    rewrite (CongruentItself C D E D A).
	     apply CongruentStrictTrianglesB; repeat split.
	      autoDistance.
	      autoDistance.
	      rewrite (DistSym C A); rewrite <- H1; rewrite H2; autoDistance.
	      intro; elim H4; apply (CollinearTrans A D B C).
	       apply (BetweenDistinctBC _ _ _ H).
	       apply CollinearBCA; apply BetweenCollinear; trivial.
	       trivial.
	     trivial.
	     apply sym_not_eq; apply (BetweenDistinctCA _ _ _ H0).
	     canonize.
	     apply HalfLineSym.
	      apply (BetweenDistinctAB _ _ _ H0).
	      apply BetweenHalfLine; trivial.
	    auto.
	    apply (BetweenDistinctCA _ _ _ H).
	    canonize.
	    apply HalfLineSym.
	     apply sym_not_eq; apply (BetweenDistinctBC _ _ _ H).
	     apply BetweenHalfLine; apply BetweenSym; auto.
	  intro; elim H4; apply CollinearBAC; apply (CollinearTrans B D A C).
	   apply sym_not_eq; apply (BetweenDistinctCA _ _ _ H).
	   apply CollinearACB; apply BetweenCollinear; trivial.
	   autoCollinear.
	 rewrite (DistSym C A); rewrite <- H1; rewrite H2; autoDistance.
	 trivial.
 Qed.

Lemma CongruentOpp : forall A B C D E : Point,
		Between B A D ->
		Between C A E ->
		~Collinear A B C ->
		Angle B A C = Angle E A D.
Proof.
	intros.
	assert (A <> B).
	 apply sym_not_eq; apply (BetweenDistinctAB _ _ _ H).
	 assert (A <> C).
	  apply sym_not_eq; apply (BetweenDistinctAB _ _ _ H0).
	  assert (A <> D).
	   apply (BetweenDistinctBC _ _ _ H).
	   assert (A <> E).
	    apply (BetweenDistinctBC _ _ _ H0).
	    destruct (ExistsHalfLineEquidistant A B A C H2 H3) as (B', (H6, H7)).
	      destruct (ExistsHalfLineEquidistant A D A C H4 H3) as (D', (H8, H9)).
	      destruct (ExistsHalfLineEquidistant A E A C H5 H3) as (E', (H10, H11)).
	      rewrite (CongruentItself A B C B' C H2 H3 H6).
	     rewrite (CongruentItself A E D E' D' H5 H4 H10 H8).
	       apply (CongruentOppParallelogramm A C B' E' D').
	      autoClockwise.
	      apply (BetweenHalfLineBetween B' A D D').
	       apply BetweenSym; apply (BetweenHalfLineBetween D A B B').
	        apply BetweenSym; trivial.
	        trivial.
	       trivial.
	      auto.
	      auto.
	      auto.
	      intro; elim H1.
	        apply (CollinearTrans A B' B C).
	       apply (EquiDistantDistinct A C A B' H3); auto.
	       apply CollinearACB; apply HalfLineCollinear; trivial.
	       autoCollinear.
	     autoCollinear.
 Qed.

Lemma CongruentOpposedStrictTriangles : forall A B C D I : Point,
	Between A I C ->
	Between B I D ->
	Distance I A = Distance I C ->
	Distance I B = Distance I D ->
	~Collinear A I B ->
	CongruentStrictTriangles A I B C I D.
Proof.
	intros.
	apply CongruentStrictTrianglesSASB.
	 trivial.
	 trivial.
	 rewrite (AngleSym I A B).
	  apply CongruentOpp.
	   trivial.
	   trivial.
	   intro; elim H3; autoCollinear.
	  apply sym_not_eq; apply (BetweenDistinctAB _ _ _ H).
	  apply sym_not_eq; apply (BetweenDistinctAB _ _ _ H0).
	 trivial.
Qed.

End OPPOSED_ANGLE.


(** %\chapter{Equality and Rewriting Principles}% *)

From mathcomp
Require Import ssreflect ssrfun eqtype ssrnat ssrbool.

Module Rewriting.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Propositional equality in Coq *)

Locate "_ = _".

(**
[[
"x = y" := eq x y    : type_scope
]]
*)

Print eq.

(**
[[
Inductive eq (A : Type) (x : A) : A -> Prop :=  eq_refl : eq x x
]]

The type of its only constructor [eq_refl] is a bit misleading, as it
looks like it is applied to two arguments: [x] and ... [x]. To
disambiguate it, we shall put some parentheses, so, it fact, it should
read as

[[
Inductive eq (A : Type) (x : A) : A -> Prop :=  eq_refl : (eq x) x
]]

That is, the constructor [eq_refl] delivers an element of type [(eq
x)], whose _parameter_ is some [x] (and [eq] is directly applied to
it), and its _index_ (which comes second) is constrained to be [x] as
well. That is, case-analysing on an instance of [eq x y] in the
process of the proof construction will inevitably lead the side
condition implying that [x] and [y] actually correspond to the _same
object_. Coq will take advantage of this fact immediately, by
performing the _unification_ and substituting all occurrences of [y]
in the subsequent goal with [x].  Let us see how it works in practice.

** Case analysis on an equality witness

To demonstrate the actual proofs on the case analysis by equality, we
will have to perform an awkward twist: define _our own_ equality
predicate.

*)

Set Implicit Arguments.
Inductive my_eq (A : Type) (x : A) : A -> Prop :=  my_eq_refl : my_eq x x.
Notation "x === y" := (my_eq x y) (at level 70).

(**

As we can see, this definition literally repeats the Coq's standard
definition of propositional equality. The reason for the code
duplication is that SSReflect provides a specific treatment of Coq's
standard equality predicate, so the case-analysis on its instances is
completely superseded by the powerful [rewrite] tactics, which we will
see in %Section~\ref{sec:rewriting}% of this chapter. Alas, this
special treatment also leads to a non-standard behaviour of
case-analysis on equality. This is why, for didactical purposes, we
will have to stick with or own home-brewed definition until the end of
this section.

*)

Lemma my_eq_sym A (x y: A) : x === y -> y === x.

case.

(**

[[
  A : Type
  x : A
  y : A
  ============================
   x === x
]]
*)

done.
Qed.

(**

Our next exercise will be to show that the predicate we have just
defined implies Leibniz equality. The proof is accomplished in one
line by first moving the assumption [P x]
to the top and then case-analysing on the equality, which leads to the
automatic replacements of [y] by [x].

*)

Lemma my_eq_Leibniz A (x y: A) (P: A -> Prop) : x === y -> P x -> P y.
Proof. by case. Qed.

(** ** Implementing discrimination

Another important application of the equality predicate family and
similar ones are _proofs by discrimination_, in which the
contradiction is reached (i.e., the falsehood is derived) out of the
fact that two clearly non-equal elements are assumed to be equal. The
next lemma demonstrates the essence of the proof by discrimination
using the [my_eq] predicate.

*)

Lemma disaster : 2 === 1 -> False.
Proof.
move=> H.

(**

[[
  H : 2 === 1
  ============================
   False
]]

*)

pose D x := if x is 2 then False else True.

(**

[[
  H : 2 === 1
  D := fun x : nat =>
       match x with
       | 0 => True
       | 1 => True
       | 2 => False
       | S (S (S _)) => True
       end : nat -> Prop
  ============================
   False
]]
*)

have D1: D 1.
by [].

(**

[[
  H : 2 === 1
  D := ...
  D1 : D 1
  ============================
   False
]]
*)

case: H D1.

(**

[[
  D := ...
  ============================
   D 2 -> False
]]
*)

move=>/=.

(**

The tactical [/=], coming after [=>] runs all possible simplifications
on the result obtained by the tactics, preceding [=>], finishing the
proof.

*)

done.
Qed.

(**

** Reasoning with Coq's standard equality

Now we know what drives the reasoning by equality and discrimination,
so let us forget about the home-brewed predicate [my_eq] and use the
standard equality instead. Happily, the discrimination pattern we used
to implement "by hand" now is handled by Coq/SSReflect automatically,
so the trivially false equalities deliver the proofs right away by
simply typing [done].

*)

Lemma disaster3: 2 = 1 -> False.
Proof. done. Qed.

(**

* Proofs by rewriting

The vast majority of the steps when constructing real-life proofs in
Coq are _rewriting_ steps. The general flow of the interactive proof
is typically targeted on formulating and proving small auxiliary
hypotheses about equalities in the forward-style reasoning and then
exploiting the derived equalities by means of rewriting in the goal
and, occasionally, other assumptions in the context. All rewriting
machinery is handled by SSReflect's enhanced [rewrite]%\ssrt{rewrite}%
tactics, and in this section we focus on its particular uses.

** Unfolding definitions and in-place rewritings

One of the common uses of the [rewrite] tactic is to fold/unfold
transparent definitions. In general, Coq is capable to perform the
unfoldings itself, whenever it's required. Nevertheless, manual
unfolding of a definition might help to understand the details of the
implementation, as demonstrated by the following example.

*)

Definition double A (f: A -> A) (x: A) := f (f x).

Fixpoint nat_iter (n : nat) {A} (f : A -> A) (x : A) : A :=
  if n is S n' then f (nat_iter n' f x) else x.

Lemma double2 A (x: A) f t:
  t = double f x -> double f t = nat_iter 4 f x.
Proof.

move=>Et; rewrite Et.

(**

[[
  A : Type
  x : A
  f : A -> A
  t : A
  Et : t = double f x
  ============================
   double f (double f x) = nat_iter 4 f x
]]

Even though the remaining goal is simple enough to be completed by
[done], let us unfold both definition to make sure that the two terms
are indeed equal structurally. Such unfoldings can be _chained_, just
as any other rewritings.

*)

rewrite /double /nat_iter.

(**
[[
  x : A
  f : A -> A
  ============================
   f (f (f (f x))) = f (f (f (f x)))
]]

An alternative way to prove the same statement would be to use the
[->] tactical, which is usually combined with
[move] or [case], but instead of moving the assumption to the top, it
makes sure that the assumption is an equality and rewrites by it.

 *)

Restart.
by move=>->.
Qed.

(**

Notice that the tactical has a companion one [<-], which performs the
rewriting by an equality assumption from right to left, in contrast to
[->], which rewrites left to right.

The reverse operation to folding is done by using [rewrite -/...]
instead of [rewrite /...].

** Proofs by congruence and rewritings by lemmas

*)

Definition f x y :=  x + y.

Goal forall x y, x + y + (y + x) = f y x + f y x.
Proof.
move=> x y.

rewrite /f.

(**

[[
  x : nat
  y : nat
  ============================
   x + y + (y + x) = y + x + (y + x)
]]
*)

congr (_ + _).

(**

[[
  x : nat
  y : nat
  ============================
   x + y = y + x
]]
*)

Check addnC.

(**
[[
addnC
     : commutative addn
]]
*)

Print ssrfun.commutative.

(**
[[
ssrfun.commutative =
  fun (S T : Type) (op : S -> S -> T) => forall x y : S, op x y = op y x
       : forall S T : Type, (S -> S -> T) -> Prop
]]

So, after specializing the definition appropriately, the type of
[addnC] should be read as:

[[
addnC
     : forall n m: nat, n + m = m + n
]]

Now, we can take advantage of this equality and rewrite by it a part
of the goal. Notice that Coq will figure out how the
universally-quantified variables should be instantiated (i.e., with
[y] and [x], respectively):

*)

by rewrite [y + _]addnC.
Qed.

Goal forall x y z, (x + (y + z)) = (z + y + x).
Proof.
by move=>x y z; rewrite [y + _]addnC; rewrite [z + _ + _]addnC.
Qed.

(** ** Naming in subgoals and optional rewritings

When working with multiple cases, it is possible to "chain" the
execution of several tactics. Then, in the case of a script [tac1;
tac2], if the goal is replaced by several after applying [tac1], then
[tac2] will be applied to _all_ subgoals, generated by [tac1]. For
example, let us consider a proof of the following lemma from the
standard [ssrnat] %\ssrm{ssrnat}% module:

*)

Lemma addnCA: forall m n p, m + (n + p) = n + (m + p).
Proof.
move=>m n.

(**

[[
  m : nat
  n : nat
  ============================
   forall p : nat, m + (n + p) = n + (m + p)
]]

The proof will proceed by induction on [m]. We have already seen the
use of the [case] tactics, which just performs the case
analysis. Another SSReflect tactic [elim]  generalizes
[case] by applying the default induction principle ([nat_ind] in this
case) with the respect to the remaining goal (that is, the predicate
[[forall p : nat, m + (n + p) = n + (m + p)]]) is to be proven by
induction.  The following sequence of tactics proceeds by induction on
[m] with the default induction principle. It also names some of the
generated assumptions.

*)

elim: m=>[ | m Hm ] p.

(**

In particular, the following steps are performed:

- [m] is pushed as a top assumption of the goal;
- [elim] is run, which leads to generation of the two goals;

  - The first goal is of the shape
[[
forall p : nat, 0 + (n + p) = n + (0 + p)
]]

  - The second goal has the shape
[[
forall n0 : nat,
 (forall p : nat, n0 + (n + p) = n + (n0 + p)) ->
 forall p : nat, n0.+1 + (n + p) = n + (n0.+1 + p)
]]

- The subsequent structured naming [=> [ |m Hm ] p] names zero
  assumptions in the first goal and the two top assumptions, [m] and
  [Hm], in the second goal. It then next names the assumption [p] in
  _both_ goals and moves it to the top.

The first goal can now be proved by multiple rewritings via the lemma
[add0n], stating that [0] is the left unit with respect to the
addition:

*)

by rewrite !add0n.

(**

The second goal can be proved by a series of rewritings using the fact
about the [(_ + 1)] function:

*)

by rewrite !addSnnS -addnS.

(**

Notice that the conclusion of the [addnS] lemma is rewritten
right-to-left.

The whole proof could be, however, accomplished in one line using the
_optional_ rewritings.
*)

Restart.

by move=>m n; elim: m=>[ | m Hm ] p; rewrite ?add0n ?addSnnS -?addnS.
Qed.

(**

Notice that the optional rewritings (e.g., [?addSnnS]) are
performed as many times as they can be.

** Selective occurrence rewritings

Sometimes, instead of providing an r-pattern to specialize the
rewriting, it is more convenient to specify, which particular
syntactic occurrences in the goal term should be rewritten. This is
demonstrated by the following alternative proof of commutativity of
addition from the lemma [addnCA], which we have proved before:

*)

Lemma addnC: forall m n, m + n = n + m.
Proof.
move=> m n.
rewrite -{1}[n]addn0.
by rewrite addnCA addn0.
Qed.

(**

The first rewriting with [addn0] "adds" [0] to the first occurrence of
[addn0], so the left-hand side of the equality becomes [m + (n +
0)]. The next rewriting employs the lemma [addnCA], so we get [n + (m
+ 0) = n + m] as the goal, and the last one "removes" zero, so the
result trivially follows.

*)

(** * Indexed datatype families as rewriting rules

In this chapter we have already seen how defining indexed datatype
families makes it possible for Coq to provide a convenient rewriting
machinery, which is implicitly invoked by case analysis on such
families' refined types, thanks to sophisticated Coq's unification
procedure.

Although so far this approach has been demonstrated by only one
indexed type family example---propositional equality, defined by means
of the [eq] family, in this section, concluding the chapter, we will
show how to define other client-specific rewriting rules. Let us start
from a motivating example in the form of an "obvious" lemma.

*)

Lemma huh n m: (m <= n) /\ (m > n) -> False.

(**

From now on, we will be consistently including yet another SSReflect
modules, [ssrbool] and [eqtype], %\ssrm{ssrbool}\ssrm{eqtype}% into
our development. The need for them is due to the smooth combination of
reasoning with [Prop]ositions and [bool]eans, which is a subject of
the next chapter. Even though in SSReflect's library, relations on
natural numbers, such as [<=] and [>], are defined as _boolean_
functions, so far we recommend to the reader to think of them as of
predicates defined in [Prop] and, therefore, valid arguments to the
[/\] connective.

Although the statement is somewhat obvious, in the setting of Coq's
inductive definition of natural numbers it should be no big surprise
that it is proved by induction. We present the proof here, leaving the
details aside, so the reader could figure them out on his own, as a
simple exercise.%\ssrt{elim}\ssrt{suff:}\ssrtl{//}%

*)

Proof.
suff X: m <= n -> ~(m > n) by case=>/X.
by elim: m n => [ | m IHm ] [ | n] //; exact: IHm n.
Qed.

Definition maxn m n := if m < n then n else m.

Lemma max_is_max m n: n <= maxn m n /\ m <= maxn m n.

(**

The stated lemma [max_is_max] can be, indeed, proved by induction on
[m] and [n], which is a rather tedious exercise, so we will not be
following this path.
*)

Abort.

(* ** Encoding custom rewriting rules *)

Inductive leq_xor_gtn m n : bool -> bool -> Set :=
  | LeqNotGtn of m <= n : leq_xor_gtn m n true false
  | GtnNotLeq of n < m  : leq_xor_gtn m n false true.

(**

However, this is not yet enough to enjoy the custom rewriting and case
analysis on these two variant. At this moment, the datatype family
[leq_xor_gtn], whose constructors' indices encode a truth table's
"rows", specifies two substitutions in the case when [m <= n] and [n <
m], respectively and diagrammatically looks as follows:

<<
         |   C1  |   C2
-------------------------
m <= n   | true  | false
-------------------------
n < m    | false | true
>>

The boolean values in the cells specify what the values of C1 and C2
will be substituted _with_ in each of the two cases. However, the
table does not capture, what to substitute them _for_.  Therefore, our
next task is to provide suitable variants for C1 and C2, so the table
would describe a real situation and capture exactly the "case
analysis" intuition. This values of the columns are captured by the
following lemma, which, informally speaking, states that the table
with this particular values of C1 and C2 "makes sense".
*)

Lemma leqP m n : leq_xor_gtn m n (m <= n) (n < m).
Proof.
rewrite ltnNge.
by case X: (m <= n); constructor=>//; rewrite ltnNge X.
Qed.

(*
Moreover, the lemma [leqP], which we have just proved, delivers the
necessary instance of the "truth" table, which we can now case-analyse
against.

*)

(** ** Using custom rewriting rules  *)

Lemma huh' n m: (m <= n) /\ (m > n) -> False.
Proof.

move/andP.

(**

[[
  n : nat
  m : nat
  ============================
   m <= n < m -> False
]]

The top assumption [m <= n < m] of the goal is just a syntactic sugar
for [(m <= n) && (n < m)].
*)

case:leqP.

(**

[[
  n : nat
  m : nat
  ============================
   m <= n -> true && false -> False

subgoal 2 (ID 638) is:
 n < m -> false && true -> False
]]

Now, considering a boolean value [true && false] in a goal simply as a
proposition [(true && false) = true], the proof is trivial by
simplification of the boolean conjunction.

*)

done.
done.
Qed.

(**

The proof of [huh'] is now indeed significantly shorter than the proof
of its predecessor, [huh]. However, it might look like the definition
of the rewriting rule [leq_xor_gtn] and its accompanying lemma [leqP]
is quite narrowly-scoped, and it is not clear how useful it might be
for other proofs.
*)

Lemma max_is_max m n: n <= maxn m n /\ m <= maxn m n.
Proof.
(**

The proof begins by unfolding the definition of [maxn].

*)
rewrite /maxn.

(**
[[
  m : nat
  n : nat
  ============================
   n <= (if m < n then n else m) /\ m <= (if m < n then n else m)
]]

We are now in the position to unleash our rewriting rule, which,
together with simplifications by means of the [//] tactical
%\ssrtl{//}% does most of the job.

*)

case: leqP=>//.

(**

[[
  m : nat
  n : nat
  ============================
   m < n -> n <= n /\ m <= n
]]

The res of the proof employs rewriting by some trivial lemmas from [ssrnat],
%\ssrm{ssrnat}% but conceptually is very easy.

*)

move=>H; split.

Search _ (?X <= ?X).

by apply: leqnn.

Search _ (?x < ?y) (?x <= ?y).

by rewrite ltn_neqAle in H; case/andP: H.
Qed.

(**

The key advantage we got out of using the custom rewriting rule,
defined as an indexed datatype family is lifting the need to prove _by
induction_ a statement, which one would intuitively prove by means of
_case analysis_. In fact, all inductive reasoning was conveniently
"sealed" by the proof of [leqP] and the lemmas it made use of, so just
the tailored "truth table"-like interface for case analysis was given
to the client.
*)

(*******************************************************************)
(**                     * Exercices *                              *)
(*******************************************************************)

(**
---------------------------------------------------------------------
Exercise [Discriminating [===]]
---------------------------------------------------------------------
Let us change the statement of a lemma [disaster] for a little bit:
*)

Lemma disaster2 : 1 === 2 -> False.

(**
Now, try to prove it using the same scheme. What goes wrong and how to
fix it?
*)
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

(**
---------------------------------------------------------------------
Exercise [Fun with rewritings]
---------------------------------------------------------------------
Prove the following lemma by using the [rewrite] tactics.

*)

Lemma rewrite_is_fun T (f : T -> T -> T) (a b c : T):
  commutative f -> associative f ->
  f (f b a) c = f a (f c b).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

(**
---------------------------------------------------------------------
Exercise [Properties of maxn]
---------------------------------------------------------------------
Prove the following lemmas about [maxn].
*)

Lemma max_l m n: n <= m -> maxn m n = m.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

Lemma succ_max_distr_r n m : (maxn n m).+1 = maxn (n.+1) (m.+1).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

Lemma plus_max_distr_l m n p: maxn (p + n) (p + m) = p + maxn n m.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

(**

Hint: it might be useful to employ the lemmas [ltnNge], [leqNgt],
[ltnS] and similar to them from SSReflect's [ssrnat] module. Use the
[Search] command to find propositions that might help you to deal with
the goal.

Hint: Forward-style reasoning via [suff] and [have] might be more
intuitive.

Hint: A hypothesis of the shape [H: n < m] is a syntactic sugar for
[H: n < m = true], since [n < m] in fact has type [bool], as will be
explained in the next lecture.

*)

(**
---------------------------------------------------------------------
Exercise [More custom rewriting rules]
---------------------------------------------------------------------

Let us consider an instance of a more sophisticated custom rewriting
rule, which now encodes a three-variant truth table for the ordering
relations on natural numbers.

*)

Inductive nat_rels m n : bool -> bool -> bool -> Set :=
  | CompareNatLt of m < n : nat_rels m n true false false
  | CompareNatGt of m > n : nat_rels m n false true false
  | CompareNatEq of m = n : nat_rels m n false false true.

(**

The following rewriting lemma establishes a truth table for
[nat_rels]. Step through the proofs (splitting the combined tactics
whenever it's necessary) to see what's going on.

*)

Lemma natrelP m n : nat_rels m n (m < n) (n < m) (m == n).
Proof.
rewrite ltn_neqAle eqn_leq; case: ltnP; first by constructor.
by rewrite leq_eqVlt orbC; case: leqP; constructor; first exact/eqnP.
Qed.

(**
Let us define the minimum function [minn] on natural numbers as
follows:
*)

Definition minn m n := if m < n then m else n.

(**
Prove the following lemma about [minm] and [maxn]:
*)

Lemma addn_min_max m n : minn m n + maxn m n = m + n.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

End Rewriting.