import field_definition
import field_results
import numbers

/- We can apply an additional contraint onto a field that it has some notion of square roots.
   It is not necessary to define any properties of square roots other than (sqrt (a) * sqrt (a) = a) . -/
class fld_with_sqrt (f : Type) [myfld f] :=
(sqrt : f -> f)
(sqrt_mul_sqrt : ∀ (a : f), myfld.mul (sqrt a) (sqrt a) = a)

lemma sqrt_eq (f : Type) [myfld f] [fld_with_sqrt f] (a b : f) :
  a = b -> (fld_with_sqrt.sqrt a) = (fld_with_sqrt.sqrt b) :=
begin
  intros h, rw h,
end

prefix ` sqroot `:1000002 := fld_with_sqrt.sqrt

@[simp] lemma sqrt_simp (f : Type _) [myfld f] [fld_with_sqrt f] (a : f) :
      (sqroot a) .* (sqroot a) = a :=
begin rw fld_with_sqrt.sqrt_mul_sqrt a, end

@[simp] lemma sqrt_squared (f : Type) [myfld f] [fld_with_sqrt f] (a : f) :
    square f (sqroot  a) = a :=
begin
  unfold square, rw fld_with_sqrt.sqrt_mul_sqrt a,
end

/- We prove that a number can only have two square roots. This will be necessary for proving that
      the quadratic formula gives all the solutions to a quadratic.
      The formulation of the lemma is slightly awkward but this way we can do it constructively.-/
lemma only_two_square_roots (f : Type) [myfld f] [fld_with_sqrt f] (x y : f) :
          (x ≠ (sqroot  y)) -> (x ≠ (.- (sqroot  y))) -> (square f x) ≠ y :=
begin
  unfold square,
  intros not_sqrt not_minus_sqrt h,

  have h1 : (x .* x) .+ (.- y) = myfld.zero,
    rw h, rw myfld.add_negate y,
  clear h, rename h1 h,
  have h1 : (x .* x) .+ (((x .* (sqroot  y)) .+ (.- (x .* (sqroot  y)))) .+ (.- y)) = myfld.zero,
    rw myfld.add_negate (x .* (sqroot  y)), rw simp_zero f _, exact h,
  clear h, rename h1 h,
  rw myfld.add_comm (x .* (sqroot  y)) (.- (x .* (sqroot  y))) at h,
  rw <- myfld.add_assoc (.- (x .* (sqroot  y))) _ _ at h,
  rw myfld.add_assoc (x .* x) (.- (x .* (sqroot  y))) _ at h,
  rw mul_negate_alt f x _ at h,
  rw <- distrib_simp_alt f x x (.- (sqroot  y)) at h,
  have tmp : (.- y) = .- ((sqroot  y) .* (sqroot  y)),
    rw fld_with_sqrt.sqrt_mul_sqrt y,
  rw tmp at h, clear tmp,
  rw <- mul_negate f (sqroot  y) (sqroot  y) at h,
  rw <- distrib_simp f _ _ _ at h,
  rw myfld.mul_comm (x .+ (.- (sqroot  y))) (sqroot  y) at h,
  rw <- distrib_simp f _ _ _ at h,

  have tmp : x .+ (sqroot  y) ≠ myfld.zero,
    intros h1, rw myfld.add_comm at h1, have tmp1 : x = .- (sqroot  y),
      exact only_one_negation f (sqroot  y) x h1, exact not_minus_sqrt tmp1,
  have tmp1 : x .+ (.- (sqroot  y)) ≠ myfld.zero,
    intros h1, rw myfld.add_comm at h1, have tmp1 : x = .- (.- (sqroot  y)),
      exact only_one_negation f (.- (sqroot  y)) x h1, rw double_negative at tmp1, exact not_sqrt tmp1,
  exact mul_nonzero f (x .+ (sqroot  y)) (x .+ (.- (sqroot  y))) tmp tmp1 h,
end

lemma negative_sqrt (f : Type) [myfld f] [fld_with_sqrt f] (a : f) :
    ((.- (sqroot  a)) .* (.- (sqroot  a))) = a :=
begin
  rw mul_negate f _ _, rw <- mul_negate_alt f _ _, rw double_negative f _,
  exact fld_with_sqrt.sqrt_mul_sqrt a,
end

lemma sqrt_ne_zero (f : Type) [myfld f] [fld_with_sqrt f] (a : f) :
  (a ≠ myfld.zero) -> (sqroot a) ≠ myfld.zero :=
begin
  intros h1 h2,
  have h3 : (sqroot a) .* (sqroot a) = myfld.zero,
    rw h2, rw zero_mul,
  rw fld_with_sqrt.sqrt_mul_sqrt at h3, cc,
end

class fld_with_cube_root (f : Type) [myfld f] :=
(cubrt : f -> f)
(cubrt_cubed : ∀ (a : f), ((cubrt a) .* (cubrt a)) .* (cubrt a) = a)
/- At one point I also had a requirement that (cubrt a) * (cubrt b) = (cubrt (a * b)) .
This doesn't work. If you have that as a requirement then the following applies:
Let x = (sqrt (three) - one) /two. (This is one of the alternative cube roots of one)
Then cubrt (x) * cubrt (x) * cubrt (x) = cubrt (x) * cubrt (x) * cubrt (x)
Therefore cubrt (x * x * x) = x
Therefore cubrt (1) = x
But you can do a similar argument with
    cubrt (1) * cubrt (1) * cubrt (1) = cubrt (1) * cubrt (1) * cubrt (1)
  => cubrt (1 * 1 * 1) = 1
  => cubrt (1) = 1
  => x = 1
Therefore all the cube roots of a given number are equal to each other, which is nonsense.
So we can't do that.-/

lemma cubrt_eq (f : Type) [myfld f] [fld_with_cube_root f] (a b : f) :
  a = b -> (fld_with_cube_root.cubrt a) = (fld_with_cube_root.cubrt b) :=
begin
  intros h, rw h,
end

lemma cubrt_cubed (f : Type) [myfld f] [fld_with_cube_root f] (a : f) : (cubed f (fld_with_cube_root.cubrt a)) = a :=
begin
  unfold cubed, rw myfld.mul_assoc _ _ _, exact fld_with_cube_root.cubrt_cubed _,
end

def cubrt_nonzero (f : Type) [myfld f] [fld_with_cube_root f] (a : f) :
    a ≠ myfld.zero -> (fld_with_cube_root.cubrt a ≠ myfld.zero) :=
begin
  intros h1 h2,
  have h3 : cubed f (fld_with_cube_root.cubrt a) = cubed f (myfld.zero),
    rw h2,
  rw cubrt_cubed at h3, unfold cubed at h3, rw mul_zero f _ at h3, cc,
end

def cube_root_of_unity (f : Type) [myfld f] [fld_not_char_two f] (rt_minus_three : f)
                           (rt_proof : rt_minus_three .* rt_minus_three = (.- (three f))) : f :=
    (((.- myfld.one) .+ rt_minus_three) .* (myfld.reciprocal (two f) (two_ne_zero f)))

lemma cubrt_unity_correct (f : Type) [myfld f] [fld_not_char_two f] (rt_minus_three : f)
                          (rt_proof : rt_minus_three .* rt_minus_three = (.- (three f))) :
            (cubed f (cube_root_of_unity f rt_minus_three rt_proof)) = myfld.one :=
begin
  have one_minus_three : myfld.one .+ (.- (three f)) = .- (two f),
    unfold three, unfold two, rw add_negate f _ _, rw myfld.add_assoc _ _ _,
    rw myfld.add_negate myfld.one, rw <- zero_add f (.- (myfld.one .+ myfld.one)),

  /- Start by just doing the root squared.
     (-1 + sqrt (-3)) ^2 = 1 - sqrt (-3) - sqrt (-3) -3 = -2 (1 + sqrt (-3))
     Doing this as a separate calculation is easier because there's less ambiguity in what I want the prover to do,
        hence the "have". -/
  have square_unfolded : square f ((.- myfld.one) .+ rt_minus_three) =
                          (.- (two f)) .* (myfld.one .+ rt_minus_three) ,
    unfold square, rw distrib_simp f _ _ _, rw distrib_simp_alt f _ _ _, rw distrib_simp_alt f _ _ _,
    rw mul_negate f _ _, rw <- mul_negate_alt f _ _, rw mul_negate f _ _, rw double_negative f _,
    rw one_mul_simp f _, rw one_mul_simp f _, rw rt_proof, rw <- mul_negate_alt f _ _,
    repeat {rw <- myfld.add_assoc _ _ _}, rw myfld.add_comm myfld.one _, repeat {rw <- myfld.add_assoc _ _ _},
    rw myfld.add_comm (.- (three f)) myfld.one, rw one_minus_three,
    have tmp : (.- rt_minus_three) = rt_minus_three .* (.- myfld.one) ,
      rw <- mul_negate_alt f _ _, rw <- myfld.mul_one rt_minus_three,
    rw tmp, rw mul_negate_alt f _ _, rw myfld.add_assoc _ _ _, rw <- distrib_simp_alt f rt_minus_three _ _,
    rw <- add_negate f _ _,
    clear tmp, have tmp : myfld.one .+ myfld.one = (two f), unfold two, rw tmp, clear tmp,
    have tmp : (.- (two f)) = (.- (two f)) .* myfld.one,
      exact myfld.mul_one (.- (two f)), rw [tmp] {occs := occurrences.pos [2]}, clear tmp,
    rw myfld.mul_comm rt_minus_three _, rw <- distrib_simp_alt f (.- (two f)) _ _,
    rw myfld.add_comm _ _,

  unfold square at square_unfolded,
  unfold cube_root_of_unity, rw cube_of_product f _ _, rw cube_of_reciprocal f (two f) _,
  unfold cubed, rw square_unfolded, clear square_unfolded,
  /- First cancel the two from the unfolded square with one of the 1/2s.-/
  rw myfld.mul_comm ((.- myfld.one) .+ rt_minus_three) _,
  rw <- myfld.mul_assoc (.- (two f)),
  rw <- mul_two_reciprocals f (two f) _ _ _,
  rw myfld.mul_assoc _ (myfld.reciprocal (two f) _) _, rw myfld.mul_comm _ (myfld.reciprocal (two f) _),
  rw myfld.mul_assoc (myfld.reciprocal (two f) _) (.- (two f)) _,
  rw myfld.mul_comm (myfld.reciprocal (two f) _) (.- (two f)),
  rw mul_negate f (two f) _, rw myfld.mul_reciprocal (two f) _, rw mul_negate f _ _, rw one_mul_simp f _,
  /- Now just a bit of rearranging.-/
  rw distrib_simp f _ _ _, rw one_mul_simp f _, rw distrib_simp_alt f _ _ _,
  rw <- mul_negate_alt f _ _, rw <- myfld.mul_one rt_minus_three, rw rt_proof,
  repeat {rw <- myfld.add_assoc _ _ _}, rw myfld.add_assoc rt_minus_three (.- rt_minus_three),
  rw myfld.add_negate rt_minus_three, rw <- zero_add f (.- (three f)),
  rw <- add_negate f _ _, rw double_negative f _, rw one_plus_three f,
  rw only_one_reciprocal f ((two f) .* (two f)) _ (mul_nonzero f (two f) (two f) (two_ne_zero f) (two_ne_zero f)),
  rw myfld.mul_reciprocal ((two f) .* (two f)) (mul_nonzero f (two f) (two f) (two_ne_zero f) (two_ne_zero f)),
  exact two_ne_zero f, exact (mul_nonzero f (two f) (two f) (two_ne_zero f) (two_ne_zero f)),
end

def cubrt_unity_a (f : Type) [myfld f] [fld_with_sqrt f] [fld_not_char_two f] : f :=
((.- myfld.one) .+ (sqroot  (.- (three f)))) .* (myfld.reciprocal (two f) (two_ne_zero f))

def cubrt_unity_b (f : Type) [myfld f] [fld_with_sqrt f] [fld_not_char_two f] : f :=
((.- myfld.one) .+ (.- (sqroot  (.- (three f))))) .* (myfld.reciprocal (two f) (two_ne_zero f))

lemma cubrts_unity_sum_zero (f : Type) [myfld f] [fld_with_sqrt f] [fld_not_char_two f] :
      myfld.one .+ ((cubrt_unity_a f) .+ (cubrt_unity_b f)) = myfld.zero :=
begin
  unfold cubrt_unity_a, unfold cubrt_unity_b,
  rw <- distrib_simp f _ _ (myfld.reciprocal (two f) _),
  repeat {rw <- myfld.add_assoc}, rw myfld.add_comm _ (.- (sqroot  _)),
  rw myfld.add_assoc (sqroot  _) (.- (sqroot  _)) _,
  rw myfld.add_negate (sqroot  _), rw simp_zero f _,
  rw <- add_negate f myfld.one myfld.one, rw mul_negate f _ _,
  unfold two, rw myfld.mul_reciprocal (myfld.one .+ myfld.one) _,
  rw myfld.add_negate myfld.one,
end

/-The first of a couple of smaller proofs to move *some* of the tedious algebra away from the proof that has actual interesting
stuff. Steer clear unless you really like boring algebra. -/
/- This first one is a proof that the x^2 term in the cubic for the main proof is zero.-/
lemma no_other_cubrts_unity_sub_proof_a (f : Type) [myfld f] [fld_with_sqrt f] [fld_not_char_two f] [fld_with_cube_root f] (a x : f) :
          (.- (((fld_with_cube_root.cubrt a) .+ (((fld_with_cube_root.cubrt a) .* (cubrt_unity_a f)) .+ ((fld_with_cube_root.cubrt a) .* (cubrt_unity_b f)))) .* (x .* x)))
                        = myfld.zero :=
begin
  have proof_without_roota : ((myfld.one .+ ((cubrt_unity_a f) .+ (cubrt_unity_b f))) .* (x .* x)) = myfld.zero,
    unfold cubrt_unity_a, unfold cubrt_unity_b,
    repeat {rw distrib_simp f _ _ _}, repeat {rw distrib_simp_alt f _ _ _}, repeat {rw distrib_simp f _ _ _},
    rw myfld.add_comm ((_ .* (myfld.reciprocal (two f) _)) .* (x .* x))
                      (((.- (sqroot  (.- (three f)))) .* (myfld.reciprocal (two f) _)) .* (x .* x)),
    repeat {rw myfld.add_assoc _ _ _}, repeat {rw <- myfld.add_assoc _ _ _},
    rw myfld.add_assoc (((sqroot  (.- (three f))) .* (myfld.reciprocal (two f) _)) .* (x .* x)) _ _,
    repeat {rw mul_negate f _ _}, rw myfld.add_negate _,
    rw <- zero_add f (.- ((myfld.one .* (myfld.reciprocal (two f) _)) .* (x .* x))),
    repeat {rw one_mul f _}, rw <- add_negate f _ _, rw <- distrib_simp f _ _ (x .* x),
    rw only_one_reciprocal f (two f) _ (two_ne_zero f), rw add_two_halves f, rw one_mul_simp f,
    rw myfld.add_negate _,
  repeat {rw <- myfld.mul_assoc (fld_with_cube_root.cubrt a) _ _},
  repeat {rw <- distrib_simp_alt f (fld_with_cube_root.cubrt a) _ _},
  rw <- distrib_simp f _ _ (x .* x),
  rw [myfld.mul_one (x .* x) ] {occs := occurrences.pos [1]},
  rw myfld.mul_comm _ (x .* x), rw <- distrib_simp_alt f (x .* x) _ _,
  rw myfld.mul_comm (x .* x) _, rw proof_without_roota, rw zero_mul f _, rw negate_zero_zero f,
end

lemma no_other_cubrts_unity_sub_proof_b (f : Type) [myfld f] [fld_with_sqrt f] [fld_not_char_two f] [fld_with_cube_root f] (a x : f) :
      (x .* ((((fld_with_cube_root.cubrt a) .* ((fld_with_cube_root.cubrt a) .* (cubrt_unity_a f))) .+ ((fld_with_cube_root.cubrt a) .* ((fld_with_cube_root.cubrt a) .* (cubrt_unity_b f)))) .+ (((fld_with_cube_root.cubrt a) .* (cubrt_unity_a f)) .* ((fld_with_cube_root.cubrt a) .* (cubrt_unity_b f)))))
      = myfld.zero :=
begin
/- More tedious algebra rearranging. Nothing of interest here.-/
  /- This one is proving that the x term in the cubic is zero.-/
  repeat {rw myfld.mul_assoc _ (fld_with_cube_root.cubrt a) _},
  rw myfld.mul_comm ((fld_with_cube_root.cubrt a) .* (cubrt_unity_a f)) (fld_with_cube_root.cubrt a),
  rw myfld.mul_assoc (fld_with_cube_root.cubrt a) (fld_with_cube_root.cubrt a) _,
  rw <- myfld.mul_assoc ((fld_with_cube_root.cubrt a) .* (fld_with_cube_root.cubrt a)) _ _,
  repeat {rw <- distrib_simp_alt f ((fld_with_cube_root.cubrt a) .* (fld_with_cube_root.cubrt a)) _ _},
  unfold cubrt_unity_a, unfold cubrt_unity_b,
  rw only_one_reciprocal f (two f) _ fld_not_char_two.not_char_two,
  repeat {rw one_mul_simp f _}, repeat {rw myfld.mul_comm _ (myfld.reciprocal (two f) fld_not_char_two.not_char_two) },
  rw <- distrib_simp_alt f (myfld.reciprocal (two f) fld_not_char_two.not_char_two) _ _,
  rw <- myfld.mul_assoc (myfld.reciprocal (two f) fld_not_char_two.not_char_two) _ _,
  rw <- distrib_simp_alt f (myfld.reciprocal (two f) fld_not_char_two.not_char_two) _ _,
  rw myfld.add_comm (.- myfld.one) (.- (sqroot  (.- (three f)))),
  repeat {rw <- myfld.add_assoc _ _ _}, rw myfld.add_assoc (sqroot  (.- (three f))) _ _,
  rw myfld.add_negate (sqroot  (.- (three f))), rw simp_zero f _,
  rw <- add_negate f _ _, rw <- mul_negate_alt f _ _, rw <- mul_negate_alt f _ _,
  rw <- add_negate f _ _, rw <- add_negate f _ _, rw <- mul_negate_alt f _ _, rw <- mul_negate_alt f _ _,
  rw distrib_simp f (.- myfld.one) _ _,
  rw mul_negate f myfld.one _, rw one_mul f _,
  rw distrib_simp_alt f _ (sqroot  (.- (three f))) _,
  rw distrib_simp_alt f _ ((myfld.reciprocal (two f) fld_not_char_two.not_char_two) .* (sqroot  (.- (three f)))) _,
  rw add_negate f ((myfld.reciprocal (two f) fld_not_char_two.not_char_two) .* (sqroot  (.- (three f)))) _,
  repeat {rw myfld.mul_assoc _ (myfld.reciprocal (two f) fld_not_char_two.not_char_two) _},
  repeat {rw myfld.mul_comm _ (myfld.reciprocal (two f) fld_not_char_two.not_char_two) },
  repeat {rw <- myfld.mul_assoc (myfld.reciprocal (two f) fld_not_char_two.not_char_two) _ _},
  repeat {rw mul_negate_alt f (myfld.reciprocal (two f) fld_not_char_two.not_char_two) _},
  repeat {rw <- distrib_simp_alt f (myfld.reciprocal (two f) fld_not_char_two.not_char_two) _ _},
  rw fld_with_sqrt.sqrt_mul_sqrt _, rw simp_mul_one f _,
  repeat {rw myfld.add_assoc _ _ _}, rw myfld.add_comm _ (sqroot  (.- (three f))),
  repeat {rw myfld.add_assoc _ _ _}, rw myfld.add_negate _, rw simp_zero f _,
  have three_plus_one : ((.- myfld.one) .+ (.- (three f))) = .- ((two f) .* (two f)),
    unfold three, unfold two, rw <- add_negate f _ _, rw distrib_simp f _ _ _, rw distrib_simp_alt f _ _ _,
    rw simp_mul_one f _, repeat {rw myfld.add_assoc _ _ _},
  rw three_plus_one, clear three_plus_one, rw <- mul_negate_alt f _ ((two f) .* (two f)),
  rw myfld.mul_assoc _ (two f) (two f), rw myfld.mul_comm (myfld.reciprocal (two f) _) (two f),
  rw myfld.mul_reciprocal (two f) _, rw one_mul f _, unfold two,
  rw myfld.add_negate (myfld.one .+ myfld.one),
  rw zero_mul f _, rw negate_zero_zero f, rw zero_mul f _, rw zero_mul f _,
end

lemma no_other_cubrts (f : Type) [myfld f] [fld_with_sqrt f] [fld_not_char_two f] [fld_with_cube_root f] (a x : f) :
    (x ≠ (fld_with_cube_root.cubrt a)) ->
    (x ≠ (fld_with_cube_root.cubrt a) .* (cubrt_unity_a f)) ->
    (x ≠ (fld_with_cube_root.cubrt a) .* (cubrt_unity_b f)) ->
    (cubed f x) ≠ a :=
begin
  /- We demonstrate that multiplying out the cubic formed by (x - 1) (x - root_a) (x - root_b) gives x^3 - 1.
    Ergo, as we have said that x^3 = 1, one of (x - 1) (x - root_a) (x - root_b) has to be zero, as
    we cannot multiply nonzero values to get zero.-/
  unfold cubrt_unity_a, unfold cubrt_unity_b,
  intros x_not_one x_not_root_a x_not_root_b, intros h,
  have multiplied_out_eqn : (factorized_cubic_expression f x (fld_with_cube_root.cubrt a) ((fld_with_cube_root.cubrt a) .* (cubrt_unity_a f)) ((fld_with_cube_root.cubrt a) .* (cubrt_unity_b f)))
             = (cubed f x) .+ (.- a) ,
    rw multiply_out_cubic f _ _ _,
    /- To make the proof a little cleaner, we simplify the x^2 term, the x term, and the constant separately.-/
    rw no_other_cubrts_unity_sub_proof_a f a x, rw simp_zero f _,
    rw no_other_cubrts_unity_sub_proof_b f a x, rw simp_zero f _,
    repeat {rw myfld.mul_assoc _ (fld_with_cube_root.cubrt a) _},
    rw myfld.mul_comm ((fld_with_cube_root.cubrt a) .* (cubrt_unity_a f)) (fld_with_cube_root.cubrt a),
    rw myfld.mul_assoc (fld_with_cube_root.cubrt a) (fld_with_cube_root.cubrt a) _,
    repeat {rw <- myfld.mul_assoc ((fld_with_cube_root.cubrt a) .* (fld_with_cube_root.cubrt a)) _ _},
    rw myfld.mul_assoc (fld_with_cube_root.cubrt a) ((fld_with_cube_root.cubrt a) .* (fld_with_cube_root.cubrt a)) _,
    rw myfld.mul_assoc (fld_with_cube_root.cubrt a) (fld_with_cube_root.cubrt a) (fld_with_cube_root.cubrt a),
    rw fld_with_cube_root.cubrt_cubed a,
    unfold cubrt_unity_a, unfold cubrt_unity_b,
    rw only_one_reciprocal f (two f) _ fld_not_char_two.not_char_two,
    repeat {rw myfld.mul_comm _ (myfld.reciprocal (two f) fld_not_char_two.not_char_two) },
    repeat {rw myfld.mul_assoc _ (myfld.reciprocal (two f) fld_not_char_two.not_char_two) _},
    repeat {rw myfld.mul_comm _ (myfld.reciprocal (two f) fld_not_char_two.not_char_two) },
    repeat {rw <- myfld.mul_assoc _ _ _},
    rw myfld.mul_assoc (myfld.reciprocal (two f) fld_not_char_two.not_char_two) (myfld.reciprocal (two f) fld_not_char_two.not_char_two) _,
    rw mul_two_reciprocals f (two f) (two f) _ _,
    repeat {rw distrib_simp f (.- myfld.one) _ _}, repeat {rw distrib_simp_alt f _ (.- myfld.one) _},
    repeat {rw mul_negate f _ _}, repeat {rw <- mul_negate_alt f _ _}, rw double_negative f _,
    rw simp_mul_one f _, rw one_mul_simp f _, rw simp_mul_one f _, rw double_negative f _,
    rw fld_with_sqrt.sqrt_mul_sqrt (.- (three f)), rw double_negative f _,
    repeat {rw <- myfld.add_assoc _ _ _},
    rw myfld.add_assoc (sqroot  (.- (three f))) (.- (sqroot  (.- (three f)))) _,
    rw myfld.add_negate (sqroot  (.- (three f))), rw <- zero_add f (three f),
    have three_plus_one : (myfld.one .+ (three f)) = ((two f) .* (two f)),
        unfold three, unfold two, rw distrib_simp f _ _ _, rw distrib_simp_alt f _ _ _,
        rw simp_mul_one f _, repeat {rw myfld.add_assoc _ _ _},
    rw three_plus_one, rw myfld.mul_comm (myfld.reciprocal ((two f) .* (two f)) _) ((two f) .* (two f)),
    rw myfld.mul_reciprocal _ _, rw simp_mul_one f _,
     /- We have proven that x^3 - 1 = (x - (cubrt (a))) (x - root_1_a* (cubrt (a))) (x - root_1_b* (cubrt (a))) . It is therefore straightforward to prove that no
      other cube roots of 1 can exist.-/
  unfold factorized_cubic_expression at multiplied_out_eqn,
  have tmp : (cubed f x) .+ (.- a) = myfld.zero,
    rw h, exact myfld.add_negate a,
  rw tmp at multiplied_out_eqn, clear tmp, clear h,
  have h1 : x .+ (.- (fld_with_cube_root.cubrt a)) ≠ myfld.zero,
    exact ne_diff_not_zero f x (fld_with_cube_root.cubrt a) x_not_one,
  rw only_one_reciprocal f (two f) _ fld_not_char_two.not_char_two at x_not_root_a, clear x_not_one,
  have h2 : (x .+ (.- ((fld_with_cube_root.cubrt a) .* (cubrt_unity_a f)))) ≠ myfld.zero,
    exact ne_diff_not_zero f x ((fld_with_cube_root.cubrt a) .* (cubrt_unity_a f)) x_not_root_a,
  clear x_not_root_a,
  rw only_one_reciprocal f (two f) _ fld_not_char_two.not_char_two at x_not_root_b,
  have h3 : (x .+ (.- ((fld_with_cube_root.cubrt a) .* (cubrt_unity_b f)))) ≠ myfld.zero,
    exact ne_diff_not_zero f x ((fld_with_cube_root.cubrt a) .* (cubrt_unity_b f)) x_not_root_b,
  clear x_not_root_b,
  exact (mul_nonzero f _ _ (mul_nonzero f (x .+ _) _ h1 h2) h3) multiplied_out_eqn,
end

lemma cubrt_unity_nonzero (f : Type) [myfld f] [fld_not_char_two f] (rt_minus_three : f)
                      (rt_proof : rt_minus_three .* rt_minus_three = (.- (three f))) :
              (cube_root_of_unity f rt_minus_three rt_proof) ≠ myfld.zero :=
begin
  intros h,
  have h1 : cubed f (cube_root_of_unity f rt_minus_three rt_proof) = myfld.zero,
    rw h, unfold cubed, rw mul_zero f _,
  rw cubrt_unity_correct f rt_minus_three rt_proof at h1,
  exact myfld.zero_distinct_one h1,
end

/- We make the other cube roots explicit and give explicit proofs of their correctness.
    This is tedious and a bit redundant, but it'll be useful later when we prove that a cubic has three solutions.-/

def alt_cubrt_a (f : Type) [myfld f] [fld_with_cube_root f] [fld_with_sqrt f] [fld_not_char_two f] (a : f) : f :=
        myfld.mul
          (cube_root_of_unity f (sqroot  (.- (three f))) (fld_with_sqrt.sqrt_mul_sqrt (.- (three f))))
          (fld_with_cube_root.cubrt a)

lemma alt_cubrt_a_nonzero (f : Type) [myfld f] [fld_with_cube_root f] [fld_with_sqrt f] [fld_not_char_two f]
    (a : f) (a_ne_zero : a ≠ myfld.zero) : (alt_cubrt_a f a) ≠ myfld.zero :=
begin
  unfold alt_cubrt_a,
  exact mul_nonzero f (cube_root_of_unity f (sqroot  (.- (three f))) _) (fld_with_cube_root.cubrt a)
      (cubrt_unity_nonzero f (sqroot  (.- (three f))) _) (cubrt_nonzero f a a_ne_zero),
end

def alt_cubrt_b (f : Type) [myfld f] [fld_with_cube_root f] [fld_with_sqrt f] [fld_not_char_two f] (a : f) : f :=
        myfld.mul
          (cube_root_of_unity f (.- (sqroot  (.- (three f)))) (negative_sqrt f (.- (three f))))
          (fld_with_cube_root.cubrt a)

lemma alt_cubrt_b_nonzero (f : Type) [myfld f] [fld_with_cube_root f] [fld_with_sqrt f] [fld_not_char_two f]
    (a : f) (a_ne_zero : a ≠ myfld.zero) : (alt_cubrt_b f a) ≠ myfld.zero :=
begin
  unfold alt_cubrt_b,
  exact mul_nonzero f (cube_root_of_unity f _ _) (fld_with_cube_root.cubrt a)
      (cubrt_unity_nonzero f (.- (sqroot  (.- (three f)))) _) (cubrt_nonzero f a a_ne_zero),
end

lemma three_cubrts (f : Type) [myfld f] [fld_not_char_two f] [fld_with_cube_root f] (rt_minus_three : f) (a : f)
                          (rt_proof : rt_minus_three .* rt_minus_three = (.- (three f))) :
            (cubed f ((fld_with_cube_root.cubrt a) .* (cube_root_of_unity f rt_minus_three rt_proof))) = a :=
begin
  rw cube_of_product f _ _, rw cubrt_unity_correct f rt_minus_three rt_proof,
  rw cubrt_cubed f a, rw simp_mul_one f _,
end

lemma no_other_cubrts_simple (f : Type) [myfld f] [fld_with_sqrt f] [fld_not_char_two f] [fld_with_cube_root f] (a1 x : f) :
    (x ≠ (fld_with_cube_root.cubrt a1)) ->
    (x ≠ (alt_cubrt_a f a1)) ->
    (x ≠ (alt_cubrt_b f a1)) ->
    (cubed f x) ≠ a1 :=
begin
  unfold alt_cubrt_a, unfold alt_cubrt_b,
  have prev_version : (x ≠ (fld_with_cube_root.cubrt a1)) ->
    (x ≠ (fld_with_cube_root.cubrt a1) .* (cubrt_unity_a f)) ->
    (x ≠ (fld_with_cube_root.cubrt a1) .* (cubrt_unity_b f)) ->
    (cubed f x) ≠ a1,
    exact no_other_cubrts f a1 x,
  unfold cubrt_unity_a at prev_version, unfold cubrt_unity_b at prev_version,
  unfold cube_root_of_unity, rw myfld.mul_comm _ (fld_with_cube_root.cubrt _),
  rw myfld.mul_comm _ (fld_with_cube_root.cubrt _),
  exact prev_version,
end

lemma alt_cubrt_a_correct (f : Type) [myfld f] [fld_with_cube_root f] [fld_with_sqrt f] [fld_not_char_two f] (a : f) :
        cubed f (alt_cubrt_a f a) = a :=
begin
  unfold alt_cubrt_a, rw cube_of_product f _ _, rw cubrt_unity_correct f _,
  rw one_mul_simp, rw cubrt_cubed f a,
end

lemma alt_cubrt_b_correct (f : Type) [myfld f] [fld_with_cube_root f] [fld_with_sqrt f] [fld_not_char_two f] (a : f) :
        cubed f (alt_cubrt_b f a) = a :=
begin
  unfold alt_cubrt_b, rw cube_of_product f _ _, rw cubrt_unity_correct f _,
  rw one_mul_simp, rw cubrt_cubed f a,
end


lemma and_or_distrib_left (P Q R : Prop) : P ∧ (Q ∨ R) ↔ (P ∧ Q) ∨ (P ∧ R) :=
begin
split,
intro paqor,
cases paqor with p qor,
cases qor with q r,
left,
split,
exact p,
exact q,
right,
split,
exact p,
exact r,

intro long,
split,
cases long with paq par,
exact paq.left,
exact par.left,
cases long with paq par,
left,
exact paq.right,
right,
exact par.right,

end


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov

! This file was ported from Lean 3 source module algebra.bounds
! leanprover-community/mathlib commit dd71334db81d0bd444af1ee339a29298bef40734
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Order.Group.OrderIso
import Mathlib.Algebra.Order.Monoid.OrderDual
import Mathlib.Data.Set.Pointwise.Basic
import Mathlib.Order.Bounds.OrderIso
import Mathlib.Order.ConditionallyCompleteLattice.Basic

/-!
# Upper/lower bounds in ordered monoids and groups

In this file we prove a few facts like “`-s` is bounded above iff `s` is bounded below”
(`bddAbove_neg`).
-/

open Function Set

open Pointwise

section InvNeg

variable {G : Type _} [Group G] [Preorder G] [CovariantClass G G (· * ·) (· ≤ ·)]
  [CovariantClass G G (swap (· * ·)) (· ≤ ·)] {s : Set G} {a : G}

@[to_additive (attr := simp)]
theorem bddAbove_inv : BddAbove s⁻¹ ↔ BddBelow s :=
  (OrderIso.inv G).bddAbove_preimage
#align bdd_above_inv bddAbove_inv
#align bdd_above_neg bddAbove_neg

@[to_additive (attr := simp)]
theorem bddBelow_inv : BddBelow s⁻¹ ↔ BddAbove s :=
  (OrderIso.inv G).bddBelow_preimage
#align bdd_below_inv bddBelow_inv
#align bdd_below_neg bddBelow_neg

@[to_additive]
theorem BddAbove.inv (h : BddAbove s) : BddBelow s⁻¹ :=
  bddBelow_inv.2 h
#align bdd_above.inv BddAbove.inv
#align bdd_above.neg BddAbove.neg

@[to_additive]
theorem BddBelow.inv (h : BddBelow s) : BddAbove s⁻¹ :=
  bddAbove_inv.2 h
#align bdd_below.inv BddBelow.inv
#align bdd_below.neg BddBelow.neg

@[to_additive (attr := simp)]
theorem isLUB_inv : IsLUB s⁻¹ a ↔ IsGLB s a⁻¹ :=
  (OrderIso.inv G).isLUB_preimage
#align is_lub_inv isLUB_inv
#align is_lub_neg isLUB_neg

@[to_additive]
theorem isLUB_inv' : IsLUB s⁻¹ a⁻¹ ↔ IsGLB s a :=
  (OrderIso.inv G).isLUB_preimage'
#align is_lub_inv' isLUB_inv'
#align is_lub_neg' isLUB_neg'

@[to_additive]
theorem IsGLB.inv (h : IsGLB s a) : IsLUB s⁻¹ a⁻¹ :=
  isLUB_inv'.2 h
#align is_glb.inv IsGLB.inv
#align is_glb.neg IsGLB.neg

@[to_additive (attr := simp)]
theorem isGLB_inv : IsGLB s⁻¹ a ↔ IsLUB s a⁻¹ :=
  (OrderIso.inv G).isGLB_preimage
#align is_glb_inv isGLB_inv
#align is_glb_neg isGLB_neg

@[to_additive]
theorem isGLB_inv' : IsGLB s⁻¹ a⁻¹ ↔ IsLUB s a :=
  (OrderIso.inv G).isGLB_preimage'
#align is_glb_inv' isGLB_inv'
#align is_glb_neg' isGLB_neg'

@[to_additive]
theorem IsLUB.inv (h : IsLUB s a) : IsGLB s⁻¹ a⁻¹ :=
  isGLB_inv'.2 h
#align is_lub.inv IsLUB.inv
#align is_lub.neg IsLUB.neg

end InvNeg

section mul_add

variable {M : Type _} [Mul M] [Preorder M] [CovariantClass M M (· * ·) (· ≤ ·)]
  [CovariantClass M M (swap (· * ·)) (· ≤ ·)]

@[to_additive]
theorem mul_mem_upperBounds_mul {s t : Set M} {a b : M} (ha : a ∈ upperBounds s)
    (hb : b ∈ upperBounds t) : a * b ∈ upperBounds (s * t) :=
  forall_image2_iff.2 fun _ hx _ hy => mul_le_mul' (ha hx) (hb hy)
#align mul_mem_upper_bounds_mul mul_mem_upperBounds_mul
#align add_mem_upper_bounds_add add_mem_upperBounds_add

@[to_additive]
theorem subset_upperBounds_mul (s t : Set M) :
    upperBounds s * upperBounds t ⊆ upperBounds (s * t) :=
  image2_subset_iff.2 fun _ hx _ hy => mul_mem_upperBounds_mul hx hy
#align subset_upper_bounds_mul subset_upperBounds_mul
#align subset_upper_bounds_add subset_upperBounds_add

@[to_additive]
theorem mul_mem_lowerBounds_mul {s t : Set M} {a b : M} (ha : a ∈ lowerBounds s)
    (hb : b ∈ lowerBounds t) : a * b ∈ lowerBounds (s * t) :=
  @mul_mem_upperBounds_mul Mᵒᵈ _ _ _ _ _ _ _ _ ha hb
#align mul_mem_lower_bounds_mul mul_mem_lowerBounds_mul
#align add_mem_lower_bounds_add add_mem_lowerBounds_add

@[to_additive]
theorem subset_lowerBounds_mul (s t : Set M) :
    lowerBounds s * lowerBounds t ⊆ lowerBounds (s * t) :=
  @subset_upperBounds_mul Mᵒᵈ _ _ _ _ _ _
#align subset_lower_bounds_mul subset_lowerBounds_mul
#align subset_lower_bounds_add subset_lowerBounds_add

@[to_additive]
theorem BddAbove.mul {s t : Set M} (hs : BddAbove s) (ht : BddAbove t) : BddAbove (s * t) :=
  (Nonempty.mul hs ht).mono (subset_upperBounds_mul s t)
#align bdd_above.mul BddAbove.mul
#align bdd_above.add BddAbove.add

@[to_additive]
theorem BddBelow.mul {s t : Set M} (hs : BddBelow s) (ht : BddBelow t) : BddBelow (s * t) :=
  (Nonempty.mul hs ht).mono (subset_lowerBounds_mul s t)
#align bdd_below.mul BddBelow.mul
#align bdd_below.add BddBelow.add

end mul_add

section ConditionallyCompleteLattice

section Right

variable {ι G : Type _} [Group G] [ConditionallyCompleteLattice G]
  [CovariantClass G G (Function.swap (· * ·)) (· ≤ ·)] [Nonempty ι] {f : ι → G}

@[to_additive]
theorem csupᵢ_mul (hf : BddAbove (Set.range f)) (a : G) : (⨆ i, f i) * a = ⨆ i, f i * a :=
  (OrderIso.mulRight a).map_csupᵢ hf
#align csupr_mul csupᵢ_mul
#align csupr_add csupᵢ_add

@[to_additive]
theorem csupᵢ_div (hf : BddAbove (Set.range f)) (a : G) : (⨆ i, f i) / a = ⨆ i, f i / a := by
  simp only [div_eq_mul_inv, csupᵢ_mul hf]
#align csupr_div csupᵢ_div
#align csupr_sub csupᵢ_sub

end Right

section Left

variable {ι G : Type _} [Group G] [ConditionallyCompleteLattice G]
  [CovariantClass G G (· * ·) (· ≤ ·)] [Nonempty ι] {f : ι → G}

@[to_additive]
theorem mul_csupᵢ (hf : BddAbove (Set.range f)) (a : G) : (a * ⨆ i, f i) = ⨆ i, a * f i :=
  (OrderIso.mulLeft a).map_csupᵢ hf
#align mul_csupr mul_csupᵢ
#align add_csupr add_csupᵢ

end Left

end ConditionallyCompleteLattice


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.linear_algebra.finite_dimensional
import Mathlib.ring_theory.ideal.basic
import Mathlib.PostPort

universes u l v w

namespace Mathlib

/-!
# Invariant basis number property

We say that a ring `R` satisfies the invariant basis number property if there is a well-defined
notion of the rank of a finitely generated free (left) `R`-module. Since a finitely generated free
module with a basis consisting of `n` elements is linearly equivalent to `fin n → R`, it is
sufficient that `(fin n → R) ≃ₗ[R] (fin m → R)` implies `n = m`.

## Main definitions

`invariant_basis_number R` is a type class stating that `R` has the invariant basis number property.

## Main results

We show that every nontrivial commutative ring has the invariant basis number property.

## Future work

So far, there is no API at all for the `invariant_basis_number` class. There are several natural
ways to formulate that a module `M` is finitely generated and free, for example
`M ≃ₗ[R] (fin n → R)`, `M ≃ₗ[R] (ι → R)`, where `ι` is a fintype, or prividing a basis indexed by
a finite type. There should be lemmas applying the invariant basis number property to each
situation.

The finite version of the invariant basis number property implies the infinite analogue, i.e., that
`(ι →₀ R) ≃ₗ[R] (ι' →₀ R)` implies that `cardinal.mk ι = cardinal.mk ι'`. This fact (and its
variants) should be formalized.

## References

* https://en.wikipedia.org/wiki/Invariant_basis_number

## Tags

free module, rank, invariant basis number, IBN

-/

/-- We say that `R` has the invariant basis number property if `(fin n → R) ≃ₗ[R] (fin m → R)`
    implies `n = m`. This gives rise to a well-defined notion of rank of a finitely generated free
    module. -/
class invariant_basis_number (R : Type u) [ring R] where
  eq_of_fin_equiv : ∀ {n m : ℕ}, linear_equiv R (fin n → R) (fin m → R) → n = m

theorem eq_of_fin_equiv (R : Type u) [ring R] [invariant_basis_number R] {n : ℕ} {m : ℕ} :
    linear_equiv R (fin n → R) (fin m → R) → n = m :=
  invariant_basis_number.eq_of_fin_equiv

theorem nontrivial_of_invariant_basis_number (R : Type u) [ring R] [invariant_basis_number R] :
    nontrivial R :=
  sorry

/-- A field has invariant basis number. This will be superseded below by the fact that any nonzero
    commutative ring has invariant basis number. -/
theorem invariant_basis_number_field {K : Type u} [field K] : invariant_basis_number K := sorry

/-!
  We want to show that nontrivial commutative rings have invariant basis number. The idea is to
  take a maximal ideal `I` of `R` and use an isomorphism `R^n ≃ R^m` of `R` modules to produce an
  isomorphism `(R/I)^n ≃ (R/I)^m` of `R/I`-modules, which will imply `n = m` since `R/I` is a field
  and we know that fields have invariant basis number.

  We construct the isomorphism in two steps:
  1. We construct the ring `R^n/I^n`, show that it is an `R/I`-module and show that there is an
     isomorphism of `R/I`-modules `R^n/I^n ≃ (R/I)^n`. This isomorphism is called
    `ideal.pi_quot_equiv` and is located in the file `ring_theory/ideals.lean`.
  2. We construct an isomorphism of `R/I`-modules `R^n/I^n ≃ R^m/I^m` using the isomorphism
     `R^n ≃ R^m`.
-/

/-- An `R`-linear map `R^n → R^m` induces a function `R^n/I^n → R^m/I^m`. -/
/-- An isomorphism of `R`-modules `R^n ≃ R^m` induces an isomorphism `R/I`-modules
    `R^n/I^n ≃ R^m/I^m`. -/
/-- Nontrivial commutative rings have the invariant basis number property. -/
protected instance invariant_basis_number_of_nontrivial_of_comm_ring {R : Type u} [comm_ring R]
    [nontrivial R] : invariant_basis_number R :=
  invariant_basis_number.mk fun (n m : ℕ) (e : linear_equiv R (fin n → R) (fin m → R)) => sorry

end Mathlib


def fact : Nat → Nat
| 0     => 1
| (n+1) => (n+1)*fact n

#check fact 6

#eval fact 10

-- set_option pp.all true
theorem tst1 : 100000000000 + 200000000000 = 300000000000 :=
rfl

theorem tst2 : 100000000000 * 200000000000 = 20000000000000000000000 :=
rfl

theorem tst3 : fact 7 = 5040 :=
rfl

theorem tst4 : fact 10 = 3628800 :=
rfl

theorem tst5 : 100000000001 < 300000000000 :=
ofDecideEqTrue rfl

theorem tst6 : "hello".length = 5 :=
rfl

theorem tst7 : "helloworld".length = 10 :=
rfl

theorem tst8 : "hello" ++ "world" = "helloworld" :=
rfl

theorem tst9 : "abc" ≠ "cde" :=
by decide

theorem tst10 : "helloWorld" ≠ "helloworld" :=
by decide

theorem tst11 : "helloWorld" = "helloWorld" :=
by decide

theorem tst12 : 'a' ≠ 'c' :=
by decide

#check tst10


import ...fglib
import ...basic
import ...linear_space3

namespace FG

/- ## Example: Z₃

  The cyclic group of order 3

   \ | e | a | b |
  ----------------
   e | e | a | b |
   a | a | b | e |
   b | b | e | a |
-/
namespace example_Z₃

inductive Z₃ : Type
| e : Z₃
| a : Z₃
| b : Z₃

namespace Z₃

@[simp] def mul : Z₃ → Z₃ → Z₃
| x e := x
| e y := y
| a a := b
| a b := e
| b a := e
| b b := a

@[simp] def inv : Z₃ → Z₃
| e := e
| a := b
| b := a

@[simps] instance finite_group : finite_group Z₃ :=
{ one       := e,
  mul       := mul,
  mul_one   := by intro a; cases' a; refl,
  one_mul   := by intro a; cases' a; refl,
  mul_assoc :=
    by intros a b c; cases' a; cases' b; cases' c; refl,
  inv          := inv,
  mul_left_inv := by intro a; cases' a; refl,
  elems := ⟨ ⟦ [e, a, b] ⟧, by simp ⟩,
  complete := by intro x; cases' x; simp }

/- Z₃ is Abelian -/
@[simps] instance abelian : comm_group Z₃ :=
{ mul_comm :=
    by intros a b; cases' a; cases' b; refl,
  ..Z₃.finite_group }

/- A representation of Z₃ -/
noncomputable def rep1 : Z₃ → ℂ
| e := 1
| a := ⟨ -0.5,  real.sqrt 3 / 2 ⟩ -- exp(2πi/3)
| b := ⟨ -0.5, -real.sqrt 3 / 2 ⟩ -- exp(4πi/3)

noncomputable instance rep1.representation : representation Z₃ ℂ ℂ :=
{ map := λz, complex.to_linear_operator z.rep1,
  id_mapped := begin
    apply linear_map.ext,
    intro x,
    simp,
    calc e.rep1 * x = 1 * x
        : rfl
      ... = x
        : by rw one_mul
  end,
  mul_mapped := begin
    intros z₁ z₂,
    apply linear_map.ext,
    intro x,
    simp,
    cases' classical.em (x = 0),
    { apply or.intro_right, exact h },
    { apply or.intro_left,
      /- noncomputable since depends on ℂ * ℂ -/
      sorry }
  end }

/- ## The regular representation -/
def rep2 : Z₃ → mat3
| e := mat3.I
| a := ⟨ ⟨0, 0, 1⟩,
  ⟨1, 0, 0⟩,
  ⟨0, 1, 0⟩ ⟩
| b := ⟨ ⟨0, 1, 0⟩,
  ⟨0, 0, 1⟩,
  ⟨1, 0, 0⟩ ⟩

namespace rep2

/- The regular representation is a `mat3_representation`. -/
@[simps] instance representation : mat3_representation rep2 :=
{ id_mapped := by calc
    (1 : Z₃).rep2 = mat3.I
      : by refl,
  mul_mapped := begin
    intros g₁ g₂,
    cases' g₁,
    repeat { cases' g₂,
      repeat { simp [rep2, group.mul] } }
  end }

/- `P` is the projection operator of the invariant subspace -/
lemma is_reducible : mat3_representation.is_reducible rep2 :=
begin
  let P : mat3 :=
  ⟨ ⟨ 1/3, 1/3, 1/3 ⟩,
    ⟨ 1/3, 1/3, 1/3 ⟩,
    ⟨ 1/3, 1/3, 1/3 ⟩ ⟩,
  apply exists.intro P,
  intro x,
  cases' x,
  repeat { simp [rep2], ring }
end

end rep2

end Z₃

end example_Z₃

end FG


import incidence_world.level01 --hide
open IncidencePlane --hide

/-
The next lemma is not hard to prove, but it will be useful
in the coming levels.
-/

/- Hint : Click here for a hint, in case you get stuck.
Remember that `¬ P` is the same as `P → false`, so `intro` may
get you going.
-/

variables {Ω : Type} [IncidencePlane Ω] --hide
variables  {P Q: Ω} {r : Line Ω}  -- hide

/- Lemma :
If a point P is in a line and a point Q is not, then they are different.
-/
lemma point_in_line_not_point (hP : P ∈ r) (hQ : Q ∉ r): P ≠ Q :=
begin
  intro H,
  rw H at hP,
  exact hQ hP,

end


import ..lectures.love07_metaprogramming_alt_demo

/-! # LoVe Exercise 7: Metaprogramming -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-! ## Question 1: A Term Exploder
In this question, we develop a string format for the `expr` metatype. By
default, there is no `has_repr` instance to print a nice string. For example: -/

#eval (expr.app (expr.var 0) (expr.var 1) : expr)   -- result: `[external]`
#eval (`(λx : ℕ, x + x) : expr)                     -- result: `[external]`

/-! 1.1. Define a metafunction `expr.repr` that converts an `expr` into a
`string`. It is acceptable to leave out some fields from the `expr`
constructors, such as the level `l` of a sort, the binder information `bi` of
a `λ` or `∀` binder, and the arguments of the `macro` constructor.
Hint: Use `name.to_string` to convert a name to a string, and `repr` for other
types that belong to the `has_repr` type class. -/

meta def expr.repr : expr → string
| (expr.var n)                := "(var " ++ repr n ++ ")"
-- fill in the remaining cases!

/-! We register `expr.repr` in the `has_repr` type class, so that we can use
`repr` without qualification in the future, and so that it is available to
`#eval`. We need the `meta` keyword in front of the command we enter. -/

meta instance expr.has_repr : has_repr expr :=
{ repr := expr.repr }

/-! 1.2. Test your setup. -/

#eval (expr.app (expr.var 0) (expr.var 1) : expr)
#eval (`(λx : ℕ, x + x) : expr)

/-! ## Question 2: `destruct_and` on Steroids
Recall from the lecture that `destruct_and` fails on easy goals such as -/

lemma abc_ac₂ (a b c : Prop) (h : a ∧ b ∧ c) :
  a ∧ c := sorry

/-! We will now address this by developing a new tactic called `destro_and`,
which applies both **des**truction and in**tro**duction rules for conjunction.
It will also go automatically through the hypotheses instead of taking an
argument. We will develop it in three steps.
2.1. Develop a tactic `intro_ands` that replaces all goals of the form
`a ∧ b` with two new goals `a` and `b` systematically, until all top-level
conjunctions are gone.
For this, we can use tactics such as `tactic.repeat` (which repeatedly applies a
tactic on all goals and subgoals until the tactic fails on each of the goal) and
`tactic.applyc` (which can be used to apply a rule, in connection with backtick
quoting). -/

#check tactic.repeat
#check tactic.applyc

meta def intro_ands : tactic unit := sorry

lemma abcd_bd (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ d :=
begin
  intro_ands,
  /- The proof state should be as follows:
  2 goals
  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ b
  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ d -/
  repeat { sorry }
end

lemma abcd_bacb (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ (a ∧ (c ∧ b)) :=
begin
  intro_ands,
  /- The proof state should be as follows:
  4 goals
  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ b
  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ a
  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ c
  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ b -/
  repeat { sorry }
end

/-! 2.2. Develop a tactic `destruct_ands` that replaces hypotheses of the form
`h : a ∧ b` by two new hypotheses `h_left : a` and `h_right : b` systematically,
until all top-level conjunctions are gone.
Here is some pseudocode that you can follow:
1. Retrieve the list of hypotheses from the context. This is provided by the
   metaconstant `tactic.local_context`.
2. Find the first hypothesis (= term) with a type (= proposition) of the form
   `_ ∧ _`. Here, you can use the `list.mfirst` function, in conjunction with
   pattern matching. You can use `tactic.infer_type` to query the type of a
   term.
3. Perform a case split on the first found hypothesis. This can be achieved
   using `tactic.cases`, a metaprogram that corresponds roughly to `cases'`.
4. Repeat.
The above procedure might fail if there exists no hypotheses of the required
form. Make sure to handle this failure gracefully, for example using
`tactic.try` or `<|> pure ()`. -/

meta def destruct_ands : tactic unit := sorry

lemma abcd_bd₂ (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ d :=
begin
  destruct_ands,
  /- The proof state should be as follows:
  a b c d : Prop,
  h_left : a,
  h_right_right : d,
  h_right_left_left : b,
  h_right_left_right : c
  ⊢ b ∧ d -/
  sorry
end

/-! 2.3. Combine the two tactics developed above and `tactic.assumption` to
implement the desired `destro_and` tactic. -/

meta def destro_and : tactic unit := sorry

lemma abcd_bd₃ (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ d :=
by destro_and

lemma abcd_bacb₂ (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ (a ∧ (c ∧ b)) :=
by destro_and

lemma abd_bacb (a b c d : Prop) (h : a ∧ b ∧ d) :
  b ∧ (a ∧ (c ∧ b)) :=
begin
  destro_and,
  /- The proof state should be roughly as follows:
  a b c d : Prop,
  h_left : a,
  h_right_left : b,
  h_right_right : d
  ⊢ c -/
  sorry   -- unprovable
end

/-! 2.4. Provide some more examples for `destro_and` to convince yourself that
it works as expected also on more complicated examples. -/

/-! ## Question 3 (**optional**): A Theorem Finder
We will implement a function that allows us to find theorems by constants
appearing in their statements. So given a list of constant names, the function
will list all theorems in which all these constants appear.
You can use the following metaconstants:
* `declaration` contains all data (name, type, value) associated with a
  declaration understood broadly (e.g., axiom, lemma, constant, etc.).
* `tactic.get_env` gives us access to the `environment`, a metatype that lists
  all `declaration`s (including all theorems).
* `environment.fold` allows us to walk through the environment and collect data.
* `expr.fold` allows us to walk through an expression and collect data.
3.1 (**optional**). Write a metafunction that checks whether an expression
contains a specific constant.
You can use `expr.fold` to walk through the expression, `||` and `ff` for
Booleans, and `expr.is_constant_of` to check whether an expression is a
constant. -/

meta def term_contains (e : expr) (nam : name) : bool := sorry

/-! 3.2 (**optional**). Write a metafunction that checks whether an expression
contains **all** constants in a list.
You can use `list.band` (Boolean and). -/

meta def term_contains_all (nams : list name) (e : expr) : bool := sorry

/-! 3.3 (**optional**). Produce the list of all theorems that contain all
constants `nams` in their statement.
`environment.fold` allows you to walk over the list of declarations. With
`declaration.type`, you get the type of a theorem, and with
`declaration.to_name` you get the name. -/

meta def list_constants (nams : list name) (e : environment) : list name := sorry

/-! Finally, we develop a tactic that uses the above metafunctions to log all
found theorems: -/

meta def find_constants (nams : list name) : tactic unit :=
do
  env ← tactic.get_env,
  list.mmap' tactic.trace (list_constants nams env)

/-! We test the solution. -/

run_cmd find_constants []   -- lists all theorems
run_cmd find_constants [`list.map, `function.comp]

end LoVe


import SciLean.Categories

namespace SciLean

namespace Symbolic

inductive Expr (V : Type) (K : Type) where
| zero : Expr V K
| one  : Expr V K
| var (v : V) : Expr V K
| neg (a : Expr V K) : Expr V K
| add (a b : Expr V K) : Expr V K
| mul (p q : Expr V K) : Expr V K
| smul (a : K) (p : Expr V K) : Expr V K
-- This complicate things but allows working with polynomials with very high degree.
-- This is currently not important.
-- | pow (p : Expr V K) (n : Int) : Expr V K
-- | sub (a b : Expr' V K) : Expr' V K

structure Monomial (V K : Type) where
  coeff : K
  vars  : List V

structure SMonomial (V K : Type) [Enumtype V] where
  coeff : K
  powers : {a : Array Nat // a.size = Enumtype.numOf V}

-- do radix sort and count the number of occurences
def Monomial.toSMonomial {V K} [Enumtype V] (m : Monomial V K)  : SMonomial V K := sorry
def SMonomial.toMonomial {V K} [Enumtype V] (m : SMonomial V K) : Monomial V K := sorry

open Expr in
def Monomial.toExpr {V K} (m : Monomial V K) : Expr V K :=
  match m.vars with
  | [] => zero
  | x :: xs => smul m.coeff $ xs.foldl (λ x v => mul x (var v)) (var x)

instance {V K} [Zero K] : Inhabited (Monomial V K) := ⟨0, []⟩

def Monomial.toString {V K} [ToString V] [ToString K] (m : Monomial V K) : String :=
  s!"{m.coeff} " ++ ((m.vars.map λ v => s!" x[{v}]") |> String.join)

-- TODO: Move this somewhere
inductive Comparison : Type where
  | lt | eq | gt

open Comparison in
instance : ToString Comparison :=
  ⟨λ c => match c with | lt => "lt" | eq => "eq" | gt => "gt"⟩

def List.decGradedLexComparison {α}
  [LT α] [∀ a b : α, Decidable (a < b)] [DecidableEq α]
  (l1 l2 : List α) : Comparison
  :=
    match l1, l2 with
    | x1 :: xs1, x2 :: xs2 =>
     if x1 == x2 then
       decGradedLexComparison xs1 xs2
     else
       let n1 := xs1.length
       let n2 := xs2.length
       if n1 == n2 then
         if x1 < x2 then
           Comparison.lt
         else
           Comparison.gt
       else if n1 < n2 then
         Comparison.lt
       else
         Comparison.gt
     | [], x2 :: xs2 => Comparison.lt
     | x1 :: xs1 , [] => Comparison.gt
     | [], [] => Comparison.eq

open Comparison in
def List.decGradedLexLt {α}
  [LT α] [∀ a b : α, Decidable (a < b)] [DecidableEq α]
  (l1 l2 : List α) : Bool
  :=
  match List.decGradedLexComparison l1 l2 with
  | eq => false
  | lt => true
  | gt => false

#eval #[[1], [0,0], [0,1]].qsort List.decGradedLexLt

def Monomial.decComparison {V K}
  [LT V] [∀ x y : V, Decidable (x < y)] [DecidableEq V]
  [LT K] [∀ a b : K, Decidable (a < b)] [DecidableEq K]
  (m1 m2 : Monomial V K) : Comparison
  :=
  match List.decGradedLexComparison m1.vars m2.vars with
  | Comparison.eq =>
    if m1.coeff == m2.coeff then
      Comparison.eq
    else if m1.coeff < m2.coeff then
      Comparison.lt
    else
      Comparison.gt
  | Comparison.lt => Comparison.lt
  | Comparison.gt => Comparison.gt

def Monomial.decLt {V K}
  [LT V] [∀ x y : V, Decidable (x < y)] [DecidableEq V]
  [LT K] [∀ a b : K, Decidable (a < b)] [DecidableEq K]
  (m1 m2 : Monomial V K) : Bool
  :=
  match decComparison m1 m2 with
  | Comparison.lt => true
  | _ => false

def Monomial.decEq {V K}
  [LT V] [∀ x y : V, Decidable (x < y)] [DecidableEq V]
  [LT K] [∀ a b : K, Decidable (a < b)] [DecidableEq K]
  (m1 m2 : Monomial V K) : Bool
  :=
  match decComparison m1 m2 with
  | Comparison.eq => true
  | _ => false

def Monomial.symReduce {ι K} [LT ι] [∀ i j : ι, Decidable (i < j)] [Inhabited ι]
  (m : Monomial ι K) : Monomial ι K :=
  ⟨m.coeff, (m.vars.toArray.qsort (λ i j => i < j)).toList⟩

instance {V K} [ToString V] [ToString K] : ToString (Monomial V K) := ⟨λ m => m.toString⟩

namespace Expr

  instance {V K} : Add (Expr V K) := ⟨λ x y => add x y⟩
  instance {V K} : Mul (Expr V K) := ⟨λ x y => mul x y⟩
  instance {V K} : HMul K (Expr V K) (Expr V K) := ⟨λ a x => smul a x⟩

  instance {V K} : Neg (Expr V K) := ⟨λ x => neg x⟩

  instance {V K} : Zero (Expr V K) := ⟨zero⟩
  instance {V K} : One (Expr V K) := ⟨one⟩

  inductive EqAlgebra {V K} [Add K] [Mul K] [One K] : Expr V K → Expr V K → Prop where
  -- additive commutative group
  | add_assoc (p q r : Expr V K) : EqAlgebra ((p + q) + r) (p + (q + r))
  | add_comm (p q : Expr V K)    : EqAlgebra (p + q) (q + p)
  | zero_add (p : Expr V K)      : EqAlgebra (0 + p) p
  | add_neg (p : Expr V K)       : EqAlgebra (p + - p) 0

  -- left K Module
  | smul_add (a : K) (p q : Expr V K)  : EqAlgebra (a * (p + q)) (r * p + r * q)
  | smul_smul (a b : K) (p : Expr V K) : EqAlgebra (a * (b * p)) ((a * b) * p)
  | add_smul (a b : K) (p : Expr V K)  : EqAlgebra ((a + b) * p) (a * p + b * p)
  | one_smul (p : Expr V K)            : EqAlgebra ((1 : K) * p) p

  -- Algebra over K - i.e. (· * ·) is bilinear
  | mul_add  (p q r : Expr V K)  : EqAlgebra (r * (p + q)) (r * p + r * q)
  | add_mul  (p q r : Expr V K)  : EqAlgebra ((p + q) * r) (p * r + q * r)
  | smul_mul_smul (a b : K) (p q : Expr V K) : EqAlgebra ((a * p) * (b * q)) ((a * b) * (p * q))

  -- Associative
  | mul_assoc (p q r : Expr V K) : EqAlgebra ((p * q) * r) (p * (q * r))

  -- Unital
  | one_mul  (p : Expr V K)      : EqAlgebra (1 * p) p

  -- Free algebra is compatible with the K-module structure of V
  inductive EqAlgebraOverV {V K} [Add V] [HMul K V V] : Expr V K → Expr V K → Prop where
  | add_var (u v : V) : EqAlgebraOverV (Expr.var u + Expr.var v) (Expr.var (u + v))
  | smul_var (a : K) (u : V) : EqAlgebraOverV (a * (Expr.var (K := K) u)) (Expr.var (a * u))

  inductive EqCommutative {V K} : Expr V K → Expr V K → Prop where
  | mul_comm (p q : Expr V K) : EqCommutative (p * q) (q * p)

  inductive EqAntiCommutative {V K} : Expr V K → Expr V K → Prop where
  | mul_anti_comm (p q : Expr V K) : EqAntiCommutative (p * q) (- (q * p))

  def toVal {X V K} [Add X] [Neg X] [Mul X] [Zero X] [One X] [HMul K X X]
    (e : Expr V K) (vars : V → X) : X :=
    match e with
    | zero => 0
    | one  => 1
    | var v => vars v
    | neg x => - (x.toVal vars)
    | add x y => (x.toVal vars) + (y.toVal vars)
    | mul x y => (x.toVal vars) * (y.toVal vars)
    | smul a x => a * (x.toVal vars)

  def min_rank {V K} (e : Expr V K) : Nat :=
    match e with
    | zero => 0
    | one  => 0
    | var v => 1
    | neg x => min_rank x
    | add x y => min (min_rank x) (min_rank y)
    | mul x y => (min_rank x) + (min_rank y)
    | smul a x => min_rank x

  def max_rank {V K} (e : Expr V K) : Nat :=
    match e with
    | zero => 0
    | one  => 0
    | var v => 1
    | neg x => max_rank x
    | add x y => max (max_rank x) (max_rank y)
    | mul x y => (max_rank x) + (max_rank y)
    | smul a x => max_rank x

  inductive is_homogenous {V K} : Nat → Expr V K → Prop where
    | one  : is_homogenous 0 one
    | zero (n) : is_homogenous n zero
    | var (v : V) : is_homogenous 1 (var v)
    | neg (x : Expr V K) (n) (h : is_homogenous n x) : is_homogenous n (- x)
    | add (x y : Expr V K) (n) (hx : is_homogenous n x) (hy : is_homogenous n y) : is_homogenous n (x + y)
    | mul (x y : Expr V K) (k l) (hx : is_homogenous k x) (hy : is_homogenous l y) : is_homogenous (k+l) (x * y)
    | smul a (x : Expr V K) (n) (h : is_homogenous n x) : is_homogenous n (a * x)

  def expand_to_monomials {V K} [One K] [Zero K] [Neg K] [Mul K] (e : Expr V K) : Array (Monomial V K) :=
    match e with
    | 0 => #[]
    | 1 => #[⟨1, []⟩]
    | var v => #[⟨1, [v]⟩]
    | neg x => x.expand_to_monomials.map λ m => ⟨-m.coeff, m.vars⟩
    | add x y => x.expand_to_monomials.append y.expand_to_monomials
    | mul x y => Id.run do
      let mx := x.expand_to_monomials
      let my := y.expand_to_monomials
      let mut m : Array (Monomial V K) := Array.mkEmpty (mx.size * my.size)
      for i in [0:mx.size] do
        for j in [0:my.size] do
          m := m.push ⟨mx[i].coeff * my[j].coeff, mx[i].vars.append my[j].vars⟩
      m
    | smul a x => x.expand_to_monomials.map λ m => ⟨a*m.coeff, m.vars⟩

  def expand {V K} [One K] [Zero K] [Neg K] [Mul K]
    (e : Expr V K) : (Expr V K)
    :=
    Id.run do
      let m := e.expand_to_monomials

      let mut e' : Expr V K := m[0].toExpr
      for i in [1:m.size] do
        e' := e' + m[i].toExpr
      e'

  -- partial def expand {V K} [Mul K] [Neg K] (e : Expr V K) : Expr V K :=
  --   match e with
  --   | 0 => zero
  --   | 1 => one
  --   | var v => var v
  --   | - (- x) => (expand x)
  --   | - (smul a x) => expand ((-a) * x)
  --   | - x => - (expand x)
  --   | x + y =>
  --     match (expand x), (expand y) with
  --     | x', y' + y'' => expand ((x' + y') + y'')
  --     | x', y' => x' + y'
  --   | x * y =>
  --     match (expand x), (expand y) with
  --     | x' + x'', y' + y'' => expand (x' * y' + x' * y'' + x'' * y' + x'' * y'')
  --     | x', y' + y'' => expand (x' * y' + x' * y'')
  --     | x' + x'', y' => expand (x' * y' + x'' * y')
  --     | x', y' * y'' => expand ((x' * y') * y'')
  --     | smul a x', smul b y' => expand ((a*b) * (x' * y'))
  --     | smul a x', y' => expand (a * (x' * y'))
  --     | x', smul a y' => expand (a * (x' * y'))
  --     | x', neg y' => expand $ neg $ expand (x' * y')
  --     | neg x', y' => expand $ neg $ expand (x' * y')
  --     | x', y' => x' * y'
  --   | smul a x =>
  --     match (expand x) with
  --     | x' + x'' => expand (a * x' + a * x'')
  --     | smul b x' => expand ((a*b) * x')
  --     | - x' => expand ((-a) * x')
  --     | x' => a * (expand x')

  -- Sorts variables using bubble sort
  -- Assumes expr is already in expanded form.
  partial def sort_vars {V K} [LT V] [∀ a b : V, Decidable (a < b)] (e : Expr V K) : Expr V K :=
    match e with
    | x * var b =>
      match (sort_vars x) with
      | x' * var a =>
        if a < b
        then x' * var a * var b
        else (sort_vars (x' * var b)) * var a
      | var a =>
        if a < b
        then var a * var b
        else var b * var a
      | x' => x' * var b
    | x * y => sort_vars ((sort_vars x) * y)
    | - x => - sort_vars x
    | x + y => sort_vars x + sort_vars y
    | smul a x => smul a (sort_vars x)
    | x => x

  -- -- This does not work as I would hope
  -- partial def reduce {V K} [Mul K] [Neg K] (e : Expr V K) : Expr V K :=
  --   match e with
  --   | 0 + x => reduce $ x
  --   | x + 0 => reduce $ x
  --   | 1 * x => reduce $ x
  --   | x * 1 => reduce $ x
  --   | var v => var v
  --   | - - x => reduce x
  --   | x + (y + z) => reduce $ reduce (x + y) + reduce z
  --   | x * (y * z) => reduce $ reduce (x * y) * reduce z
  --   | (x + y) * z => reduce $ reduce (x * z) + reduce (y * z)
  --   | x * (y + z) => reduce $ reduce (x * y) + reduce (x * z)
  --   | smul a (smul b x) => reduce $ (a*b) * reduce x
  --   | smul a x * y => reduce $ a * reduce (x * y)
  --   | x * smul b y => reduce $ b * reduce (x * y)
  --   | smul a (x + y) => reduce $ a * reduce x + a * reduce y
  --   | smul a (-x) => reduce $ (-a) * reduce x
  --   | - smul a x => reduce $ (-a) * reduce x
  --   | (- x) * y => reduce $ - reduce (x * y)
  --   | x * (- y) => reduce $ - reduce (x * y)
  --   | x + y => reduce x + reduce y
  --   | x * y => reduce x * reduce y
  --   | smul a x => smul a (reduce x)
  --   | - x => - reduce x
  --   | e => e

  def simplify {V K} [Zero K] [DecidableEq K] (e : Expr V K) : Expr V K :=
    match e with
    | 0 * x => 0
    | x * 0 => 0
    | 1 * x => x
    | x * 1 => x
    | 0 + x => x
    | x + 0 => x
    | smul a 0 => 0
    | x + y => simplify x + simplify y
    | x * y => simplify x * simplify y
    | smul a x => if a == 0 then 0 else smul a (simplify x)
    | x => x

  --- expand all brackes, factor `smul` from products,
  def algebra_norm_form {V K} (e : Expr V K) : Expr V K := sorry

  def diff {V K} (e : Expr V K) (v : V) [DecidableEq V] : Expr V K :=
    match e with
    | var v' => if v == v' then 1 else 0
    | - x => - x.diff v
    | x + y => x.diff v + y.diff v
    | x * y => x.diff v * y + x * y.diff v
    | smul a x => a * x.diff v
    | _ => 0

  open Expr in
  def toString {V K} [ToString V] [ToString K] (e : Expr V K): String :=
    match e with
    | zero => "0"
    | one  => "1"
    | var v => s!"x[{v}]"
    | neg x => s!"- {toString x}"
    | add x y => s!"({toString x} + {toString y})"
    | mul x y => s!"{toString x} * {toString y}"
    | smul a x => s!"{a} {toString x}"

  instance {V K} [ToString V] [ToString K] : ToString (Expr V K) := ⟨toString⟩

  def x : Expr Int Int := var 0
  def y : Expr Int Int := var 1
  def z : Expr Int Int := var 2

  #eval ((y + x * (x + y))).expand
  #eval (((2 : Int) * x + (3 : Int) * y + - x * (- x + y)) * ((5 : Int) * y + (7 : Int) * - x)).expand
  #eval (((2 : Int) * x + (3 : Int) * y + - z * x * (- x + y)) * ((5 : Int) * y + (7 : Int) * - x)).expand
  -- #eval (((2 : Int) * x + (3 : Int) * y + - z * x * (- x + y)) * ((5 : Int) * y + (7 : Int) * - x)).expand.sort_vars

  #eval ((y + x * (x + y))).expand_to_monomials
  #eval ((y + x * (x + y))).expand_to_monomials.qsort Monomial.decLt
  #eval (((2 : Int) * x + (3 : Int) * y + - x * (- x + y)) * ((5 : Int) * y + (7 : Int) * - x)).expand_to_monomials

end Expr

end Symbolic

def Quot.lift_arg2 {X Y} {r : X → X → Prop} (f : X → X → Y) (h : ∀ x y y', r y y' → f x y = f x y') : X → Quot r → Y
  := (λ x => Quot.lift (f x) (h x))

def Quot.lift₂ {X Y} {r : X → X → Prop} (f : X → X → Y)
  (h : ∀ x y y', r y y' → f x y = f x y')
  (h' : ∀ x x', r x x' → (Quot.lift_arg2 f h) x = (Quot.lift_arg2 f h) x')
  : Quot r → Quot r → Y :=
  (λ x y =>
    Quot.lift (Quot.lift_arg2 f h) h' x y)

section BasicDefinitions
  open Symbolic Expr

  variable (V : Type) (K : Type) [Add K] [Mul K] [One K]

  variable [Add V] [HMul K V V]

  -- Vector space structure of V is compatible with the algebra
  def TensorAlgebra := Quot
    (λ x y : Expr V K =>
      (EqAlgebra x y) ∨
      (EqAlgebraOverV x y))

  def ExteriorAlgebra := Quot
    (λ x y : Expr V K =>
      (EqAlgebra x y) ∨
      (EqAlgebraOverV x y) ∨
      (EqAntiCommutative x y))

  class TensorMul (X : Type u) where
    tmul : X → X → X

  class OuterMul (X : Type u) where
    omul : X → X → X

  infixl:75 " ⊗ " => TensorMul.tmul
  infixl:75 " ∧ " => OuterMul.omul

end BasicDefinitions

namespace TensorAlgebra

  variable {V : Type} {K : Type} [Add V] [Add K] [Mul K] [One K] [HMul K V V]

  open Symbolic

  instance : Add (TensorAlgebra V K) :=
    ⟨λ x y => Quot.mk _ <| Quot.lift₂ (Expr.add) sorry sorry x y⟩

  instance : TensorMul (TensorAlgebra V K) :=
    ⟨λ x y => Quot.mk _ <| Quot.lift₂ (Expr.mul) sorry sorry x y⟩

  instance : Neg (TensorAlgebra V K) :=
    ⟨λ x => Quot.mk _ <| Quot.lift (Expr.neg) sorry x⟩

  instance : HMul K (TensorAlgebra V K) (TensorAlgebra V K) :=
    ⟨λ a x => Quot.mk _ <| Quot.lift (Expr.smul a) sorry x⟩

  variable [ToString V] [ToString K]

  open Expr in
  def toString (e : Expr V K): String :=
    match e with
    | zero => "0"
    | one  => "1"
    | var v => s!"{v}"
    | neg x => s!"- {toString x}"
    | add x y => s!"({toString x} + {toString y})"
    | mul x y => s!"{toString x} ⊗ {toString y}"
    | smul a x => s!"{a} {toString x}"

  -- The string actually depends on the represenative element, thus it has to be hidden behind an opaque constant
  -- The sorry here is impossible to be proven
  constant toString' (p : TensorAlgebra V K)  : String :=
    Quot.lift (λ e : Expr V K => toString e) sorry p

  instance : ToString (TensorAlgebra V K) := ⟨toString'⟩

  def x : TensorAlgebra Int Int := Quot.mk _ (Expr.var 0)
  def y : TensorAlgebra Int Int := Quot.mk _ (Expr.var 1)

  #eval (3 : Int) * x ⊗ y + (5 : Int) * x

end TensorAlgebra

namespace ExteriorAlgebra

  variable {V : Type} {K : Type} [Add V] [Add K] [Mul K] [One K] [HMul K V V]

  open Symbolic

  instance : Add (ExteriorAlgebra V K) :=
    ⟨λ x y => Quot.mk _ <| Quot.lift₂ (Expr.add) sorry sorry x y⟩

  instance : OuterMul (ExteriorAlgebra V K) :=
    ⟨λ x y => Quot.mk _ <| Quot.lift₂ (Expr.mul) sorry sorry x y⟩

  instance : Neg (ExteriorAlgebra V K) :=
    ⟨λ x => Quot.mk _ <| Quot.lift (Expr.neg) sorry x⟩

  instance : HMul K (ExteriorAlgebra V K) (ExteriorAlgebra V K) :=
    ⟨λ a x => Quot.mk _ <| Quot.lift (Expr.smul a) sorry x⟩

  variable [ToString V] [ToString K]

  open Expr in
  def toString (e : Expr V K): String :=
    match e with
    | zero => "0"
    | one  => "1"
    | var v => s!"{v}"
    | neg x => s!"- {toString x}"
    | add x y => s!"({toString x} + {toString y})"
    | mul x y => s!"{toString x} ∧ {toString y}"
    | smul a x => s!"{a} {toString x}"

  -- The string actually depends on the represenative element, thus it has to be hidden behind an opaque constant
  -- The sorry here is impossible to be proven
  constant toString' (p : ExteriorAlgebra V K)  : String :=
    Quot.lift (λ e : Expr V K => toString e) sorry p

  instance : ToString (ExteriorAlgebra V K) := ⟨toString'⟩

  def x : ExteriorAlgebra Int Int := Quot.mk _ (Expr.var 0)
  def y : ExteriorAlgebra Int Int := Quot.mk _ (Expr.var 1)

  #eval (3 : Int) * x ∧ y + (5 : Int) * x

  -- def 𝓒Λₖ (X : Type) (k : Nat) [FinEnumVec X] := ExteriorAlgebra X (X ⟿ ℝ)   -- smoot

end ExteriorAlgebra

namespace NewApproach

-- used for symmetric polynomials
structure FreeAbelRepr where
  coef : Array Int

instance : Add FreeAbelRepr :=
  ⟨λ a b => Id.run do
    let mut r : Array Int := #[]
    if a.1.size > b.1.size then
      r := a.1
    else
      r := b.1
    for i in [0,min a.1.size b.1.size] do
        r := r.set (!i) (a.1[i] + b.1[i])
    ⟨r⟩⟩

instance : Sub FreeAbelRepr :=
  ⟨λ a b => Id.run do
    let mut r : Array Int := #[]
    if a.1.size > b.1.size then
      r := a.1
    else
      r := b.1
    for i in [0,min a.1.size b.1.size] do
        r := r.set (!i) (a.1[i] - b.1[i])
    ⟨r⟩⟩

instance : Neg FreeAbelRepr :=
  ⟨λ a => ⟨a.1.map λ ai => -ai⟩⟩

instance : Zero FreeAbelRepr := ⟨⟨#[]⟩⟩

def FreeAbelRepr.decEq (a b : FreeAbelRepr) := Id.run do
  let mut r := true
  for i in [0:max a.1.size b.1.size] do
    r := r ∧ (a.1[i] == b.1[i])
  r

def FreeAbelRepr.Eq (a b : FreeAbelRepr) : Prop := (∀ i, a.1[i] = b.1[i])

def FreeAbelRepr.toString (a : FreeAbelRepr) (s op : String) : String := Id.run do
  let mut r := ""
  for i in [0:a.1.size] do
    if a.1[i] ≠ 0 then
      let xi :=
        if a.1[i] = 1
        then s!"{s}⟦{i}⟧"
        else s!"{s}⟦{i}⟧^{a.1[i]}"
      if r = "" then
        r := xi
      else
        r := s!"{r} {op} {xi}"
  if r = "" then
    "1"
  else
    r

def FreeAbel := Quot FreeAbelRepr.Eq

instance : Add FreeAbel :=
  ⟨Quot.lift₂
    (λ x y : FreeAbelRepr => Quot.mk _ (x + y)) sorry sorry⟩

instance : Sub FreeAbel :=
  ⟨Quot.lift₂
    (λ x y : FreeAbelRepr => Quot.mk _ (x - y)) sorry sorry⟩

instance : Neg FreeAbel :=
  ⟨Quot.lift
    (λ x : FreeAbelRepr => Quot.mk _ (-x)) sorry⟩

instance : Zero FreeAbel := ⟨Quot.mk _ 0⟩

def FreeAbel.decEq (a b : FreeAbel) : Bool :=
  Quot.lift₂
    (λ x y => x.decEq y)
    sorry sorry
    a b

instance : DecidableEq FreeAbel :=
  λ a b : FreeAbel =>
    if a.decEq b then
      isTrue sorry
    else
      isFalse sorry

structure FreeMonoid (X : Type) where
  vars : List X

instance {X} : Mul (FreeMonoid X) := ⟨λ x y => ⟨x.1.append y.1⟩⟩
instance {X} : One (FreeMonoid X) := ⟨⟨[]⟩⟩

inductive FreeMonoid.Lt {X} [LT X] : FreeMonoid X → FreeMonoid X → Prop  where
  | grading  {xs ys : FreeMonoid X}
             (h : xs.1.length < ys.1.length) : Lt xs ys
  | lex_head {x y : X} {xs ys : FreeMonoid X}
             (h : x < y) (h' : xs.1.length = ys.1.length)
             : Lt ⟨x :: xs.1⟩ ⟨y :: ys.1⟩
  | lex_tail {x : X} {xs ys : FreeMonoid X} (h : Lt xs ys)
             : Lt ⟨x :: xs.1⟩ ⟨x :: ys.1⟩

instance {X} [LT X] : LT (FreeMonoid X) := ⟨FreeMonoid.Lt⟩
instance {X} [LT X] : LE (FreeMonoid X) := ⟨λ x y => x = y ∨ x < y⟩

inductive DecComparison {X : Type u} [LT X] (x y : X) where
  | cpEq (h : x = y) : DecComparison x y
  | cpLt (h : x < y) : DecComparison x y
  | cpGt (h : x > y) : DecComparison x y

export DecComparison (cpEq cpLt cpGt)

class DecComp (X : Type u) [LT X] where
  compare (x y : X) : DecComparison x y

abbrev compare {X} [LT X] [DecComp X] (x y : X) : DecComparison x y := DecComp.compare x y

instance : DecComp Nat :=
  ⟨λ x y =>
    if h : x = y
    then cpEq h
    else if h : x < y
    then cpLt h
    else cpGt sorry⟩ -- use total order

instance : DecComp Int :=
  ⟨λ x y =>
    if h : x = y
    then cpEq h
    else if h : x < y
    then cpLt h
    else cpGt sorry⟩ -- use total order

def FreeMonoid.compare {X} [LT X] [DecComp X] (x y : List X) : DecComparison (X := FreeMonoid X) ⟨x⟩ ⟨y⟩ :=
  match x, y with
  | [], [] => cpEq rfl
  | x :: xs, [] => cpGt sorry
  | [], y :: ys => cpLt sorry
  | x' :: xs, y' :: ys =>
    match DecComp.compare x' y' with
    | cpEq h =>
      match compare xs ys with
      | cpEq h' => cpEq sorry  -- here is maybe aproblem, as I'm not sure if `⟨x⟩ = ⟨y⟩ → x = y`
      | cpLt h' => cpLt sorry
      | cpGt h' => cpGt sorry
    | cpLt h =>
      match DecComp.compare xs.length ys.length with
      | cpEq h' => cpLt (FreeMonoid.Lt.lex_head h h')
      | cpLt h' => cpLt sorry
      | cpGt h' => cpGt sorry
    | cpGt h =>
      match DecComp.compare xs.length ys.length with
      | cpEq h' => cpGt sorry
      | cpLt h' => cpLt sorry
      | cpGt h' => cpGt sorry

instance {X} [LT X] [DecComp X] : DecComp (FreeMonoid X) := ⟨λ x y => FreeMonoid.compare x.1 y.1⟩

-- sorts variables assuming:
--   1. x * y = y * x
def FreeMonoid.symSort {X} [Ord X] (m : FreeMonoid X)
  : FreeMonoid X := sorry

theorem FreeMonoid.symSortIdmp {X} [Ord X] (m : FreeMonoid X)
  : m.symSort.symSort = m.symSort := sorry

-- sorts variables assuming:
--   1. x * y = - y * x
--   2. x * x = sig x
def FreeMonoid.altSort {X K} [LT X] [DecComp X] [Mul K] [One K] [Neg K]
  (m : FreeMonoid X) (sig : X → K) : K × FreeMonoid X := sorry

-- maybe rename to `StrictlySorted`
inductive FreeMonoid.AltSorted {X} [LT X] : FreeMonoid X → Prop where
  | one : AltSorted 1
  | var (x : X) : AltSorted (⟨[x]⟩)
  | mul (x y : X) (m : FreeMonoid X)
        (h : AltSorted (⟨[y]⟩*m))
        (lt  : x < y) : AltSorted (⟨[x,y]⟩*m)

theorem FreeMonoid.altSortIdmpCoef {X K} [LT X] [DecComp X] [Mul K] [One K] [Neg K]
  (m : FreeMonoid X) (sig : X → K)
  :
  (((m.altSort sig).2.altSort sig).1 = 1) := sorry

theorem FreeMonoid.altSortIdmpVars {X K} [LT X] [DecComp X] [Mul K] [One K] [Neg K]
  (m : FreeMonoid X) (sig : X → K)
  :
  (((m.altSort sig).2.altSort sig).2 = (m.altSort sig).2) := sorry

class Coef (X : Type) (K : outParam $ Type) [outParam $ Monoid K] [outParam $ MulAction K X] where
  coef : X → K
  base : X → X
  coef_base : ∀ x, coef (base x) = 1
  smul_coef : ∀ (a : K) (x : X), coef (a * x) = a * coef x
  coef_base_ext : ∀ x, ((coef x = coef y) ∧ (base x = base y)) ↔ (x = y)

class Rank (X : Type) where
  rank : X → Int

namespace SymMonomial

structure Repr (X : Type) (K : Type) [Enumtype X] where
  coef : K
  vars : FreeAbel  -- maybe fix the size of variable here

variable {X K} [Enumtype X] [DecidableEq K] [Zero K] [One K] [Mul K]

instance [One K] : One (Repr X K) := ⟨⟨1, (0 : FreeAbel)⟩⟩
instance [Zero K] : Zero (Repr X K) := ⟨⟨0, (0 : FreeAbel)⟩⟩

instance : Mul (Repr X K) :=
  ⟨λ x y =>
    if (x.coef = 0) ∨ (y.coef = 0)
    then 0
    else ⟨x.coef * y.coef , x.vars + y.vars⟩⟩

instance [Div K] : Div (Repr X K) :=
  ⟨λ x y =>
    if (x.coef = 0) ∨ (y.coef = 0)
    then 0
    else ⟨x.coef / y.coef , x.vars - y.vars⟩⟩

instance [Inv K] : Inv (Repr X K) :=
  ⟨λ x =>
     if x.coef = 0
     then 0
     else ⟨x.coef⁻¹, -x.vars⟩⟩

instance : HMul K (Repr X K) (Repr X K) :=
  ⟨λ a x =>
    if a = 0 ∨ x.coef = 0
    then 0
    else ⟨a * x.coef, x.vars⟩⟩

def Repr.Eq (x y : Repr X K) : Prop :=
  ((x.coef = 0) ∧ (y.coef = 0))
  ∨
  (x = y)

end SymMonomial

def SymMonomial (X : Type) (K : Type) [Enumtype X] [Zero K] :=
  Quot (SymMonomial.Repr.Eq (X := X) (K := K))

namespace SymMonomial

  variable {X K} [Enumtype X] [DecidableEq K] [Zero K] [One K] [Mul K]

  instance : One  (SymMonomial X K) := ⟨Quot.mk _ 1⟩
  instance : Zero (SymMonomial X K) := ⟨Quot.mk _ 0⟩

  instance : Mul (SymMonomial X K) :=
    ⟨λ x y => Quot.mk _ <| Quot.lift₂ (λ x y => x * y) sorry sorry x y⟩

  instance [Div K] : Div (SymMonomial X K) :=
    ⟨λ x y => Quot.mk _ <| Quot.lift₂ (λ x y => x / y) sorry sorry x y⟩

  instance [Inv K] : Inv (SymMonomial X K) :=
    ⟨λ x => Quot.mk _ <| Quot.lift (λ x => x⁻¹) sorry x⟩

  instance : HMul K (SymMonomial X K) (SymMonomial X K) :=
    ⟨λ a x => Quot.mk _ <| Quot.lift
      (λ x => a * x) sorry x⟩

end SymMonomial

namespace AltMonomial

  structure Repr (X : Type) (K : Type) (sig : X → K) where
    coef : K
    vars : FreeMonoid X

  namespace Repr

    variable {X K sig} [LT X] [DecComp X]
             [Mul K] [Zero K] [One K] [Neg K]

    instance : Mul (Repr X K sig) :=
      ⟨λ x y => ⟨x.coef * y.coef, x.vars * y.vars⟩⟩
    instance : HMul K (Repr X K sig) (Repr X K sig) :=
      ⟨λ a x => ⟨a * x.coef, x.vars⟩⟩
    instance [Neg K] : Neg (Repr X K sig) :=
      ⟨λ x => ⟨-x.coef, x.vars⟩⟩

    instance : Zero (Repr X K sig) := ⟨⟨0,1⟩⟩
    instance : One  (Repr X K sig) := ⟨⟨1,1⟩⟩

    def RedForm (m : Repr X K sig) : Prop :=
      ((m.coef = 0) ∧ (m.vars = 1))
      ∨
      ((m.coef ≠ 0) ∧ (m.vars.AltSorted))

    abbrev RedRepr (X K sig) [LT X] [Zero K]
      := {x' : Repr X K sig // x'.RedForm}

    def reduce (x : Repr X K sig) : RedRepr X K sig
      := let (a', x') := x.vars.altSort sig
         !⟨x.coef * a', x'⟩

    theorem reduceIdmp {X K sig} [LT X] [DecComp X] [CommMonoid K] [Zero K] [Neg K]
      (x : Repr X K sig)
      : x.reduce.1.reduce = x.reduce
      := sorry

    def NormForm (m : Repr X K sig) : Prop :=
      ((m.coef = 0) ∧ (m.vars = 1))
      ∨
      ((m.coef ≠ 0) ∧ (m.vars.AltSorted))

    abbrev NormRepr (X K sig) [LT X] [Zero K]
      := {x' : Repr X K sig // x'.NormForm}

    def normalize (x : Repr X K sig) [DecidableEq K] : NormRepr X K sig
      := let y := x.reduce.1
         if y.coef = 0
         then !⟨0, 1⟩
         else !y

    theorem normalizeIdmp (x : Repr X K sig) [DecidableEq K]
      : x.normalize.1.normalize = x.normalize
      := sorry

    def Eq (x y : Repr X K sig) : Prop :=
      let x' := x.reduce.1
      let y' := y.reduce.1
      ((x'.coef = 0) ∧ (y'.coef = 0))
      ∨
      (x' = y')

    def RedEq  (x y :  RedRepr X K sig) : Prop := Eq x.1 y.1
    def NormEq (x y : NormRepr X K sig) : Prop := Eq x.1 y.1

  end Repr

end AltMonomial

#check AltMonomial.Repr.RedEq

abbrev AltMonomial (X : Type) (K : Type) (sig : X → K)
  [LT X] [DecComp X] [Mul K] [Zero K] [One K] [Neg K]
  := Quot λ x y : AltMonomial.Repr.RedRepr X K sig => AltMonomial.Repr.RedEq x y

namespace AltMonomial

  variable {X K} {sig}
           [LT X] [DecComp X]
           [CommMonoid K] [Zero K] [Neg K]

  -- def beq (x y : AltMonomial X K sig)
  --   : Bool :=
  --   (x.1.coef = y.1.coef) ∧ (x.1.vars.1 = y.1.vars.1)

  -- instance : DecidableEq (AltMonomial X K sig) :=
  --   (λ x y =>
  --      match x.beq y with
  --      | true  => isTrue sorry
  --      | false => isFalse sorry)

  instance : Mul (AltMonomial X K sig) :=
    ⟨λ x y =>
      Quot.mk _ <| Quot.lift₂
      (λ x y => Repr.reduce (x.1 * y.1))
      sorry sorry x y⟩

  instance : HMul K (AltMonomial X K sig) (AltMonomial X K sig) :=
    ⟨λ a x =>
      Quot.mk _ <| Quot.lift
      (λ x => !⟨a * x.1.coef, x.1.vars⟩) -- No need for reduction here
      sorry x⟩

  instance : Zero (AltMonomial X K sig) := ⟨Quot.mk _ !0⟩
  instance : One  (AltMonomial X K sig) := ⟨Quot.mk _ !1⟩

  -- Define `AltMonoid`
  instance : Monoid (AltMonomial X K sig) :=
  {
    mul_assoc := sorry  -- I think for this we need K to be commutative monoid
    mul_one := sorry
    one_mul := sorry
    npow_zero' := sorry
    npow_succ' := sorry
  }

  instance : MulAction K (AltMonomial X K sig) :=
  {
    one_smul := sorry
    mul_smul := sorry
  }

  def coef (x : AltMonomial X K sig) : K :=
    Quot.lift (λ x => x.1.coef) sorry x

  def base (x : AltMonomial X K sig) [DecidableEq K] : AltMonomial X K sig :=
    Quot.mk _ <| Quot.lift
      (λ x =>
        if x.1.coef = (0 : K)
        then !⟨1,1⟩
        else !⟨1,x.1.vars⟩) sorry x

  instance [DecidableEq K] : Coef (AltMonomial X K sig) K :=
  {
    coef := λ x => x.coef
    base := λ x => x.base
    coef_base := sorry
    smul_coef := sorry
    coef_base_ext := sorry
  }

  -- Graded Lexicographical ordering - not a total order
  -- instance : LT (AltMonomial X K sig) :=
  --   ⟨λ x y =>
  --     Quot.lift₂ (λ x y => (y.1.coef = 0 → x.1.coef = 0) ∧ (x.1.vars < y.1.vars)) sorry sorry x y⟩

  -- -- Graded Lexicographical ordering - not a total order
  -- instance : LE (AltMonomial X K sig) :=
  --   ⟨λ x y =>
  --     Quot.lift₂ (λ x y => (y.1.coef = 0 → x.1.coef = 0) ∧ x.1.vars ≤ y.1.vars) sorry sorry x y⟩

  -- We can compare monoials based on rank
  -- But we can get only `less or *equal*` as we cannot determine
  -- zero monomial without decidable equality on K
  -- def rankLe (x y : AltMonomial X K sig) [DecidableEq K] : Bool :=
  --   Quot.lift₂
  --     (λ x y =>
  --       if x.1.coeff = 0
  --       then true
  --       else if x.2.coeff = 0
  --       then false
  --       else
  --       match compare (X := FreeMonoid X) x.1.vars y.1.vars with
  --       | cpEq _ => true
  --       | cpLt _ => true
  --       | cpGt _ => false
  --     ) sorry sorry x y

  -- def rankLt (x y : AltMonomial X K sig) [DecidableEq K] : Bool :=
  --   Quot.lift₂
  --     (λ x y =>
  --       match compare (X := FreeMonoid X) x.1.vars y.1.vars with
  --       | cpEq _ => if y.1.coef = 0 then false else true
  --       | cpLt _ => true
  --       | cpGt _ => false
  --     ) sorry sorry x y

  -- instance [LT X] [LT K] : LT (AltMonomial X K sig) := sorry

  -- instance [LT X] [LT K] : LT (AltMonomial X K sig) := sorry

  -- abbrev coef (x : (AltMonomial X K sig)) : K := Coef.coef x
  -- abbrev base (x : (AltMonomial X K sig)) : (AltMonomial X K sig) := Coef.base x

end AltMonomial

namespace Algebra

  inductive Repr (X : Type) (K : Type) where
  | mon (x : X) : Repr X K
  | add (xs : List (Repr X K)) : Repr X K
  | mul (xs : List (Repr X K)) : Repr X K
  | smul (a : K) (x : Repr X K) : Repr X K

  instance {X K} [Zero X] : Zero (Repr X K) := ⟨Repr.add []⟩
  instance {X K} [One X]  : One  (Repr X K) := ⟨Repr.mul []⟩

  open Repr in
  partial def reduce {X K} (x : Repr X K) [HMul K X X] [Mul X] [Mul K] [Zero X] [One X] : Repr X K :=
    match x with
    | smul a (mon x) => mon (a * x)
    | smul a (smul b x) => reduce (smul (a*b) x)
    | add [x] => reduce x
    | add (0 :: xs) => reduce (add xs)
    | mul [x] => reduce x
    | mul (1 :: xs) => reduce (mul xs)
    | mul (mon x :: xs) =>
      match reduce (mul xs) with
      | mul (mon y :: xs') => reduce (mul (mon (x * y) :: xs))
      | smul a x' => reduce (mul [mon (a * x), x'])
      | xs' => mul [mon x, xs']
    | add (add xs :: ys) => reduce (add (xs.append ys))
    | mul (mul xs :: ys) => reduce (mul (xs.append ys))
    | add (x :: xs) =>
      match reduce (add xs) with
      | 0 => x
      | add xs' => add (x :: xs')
      | xs' => add [x, xs']
    | mul (x :: xs) =>
      match reduce (mul xs) with
      | 1 => x
      | mul xs' => mul (x :: xs')
      | xs' => mul [x, xs']
    | x => x

  def Repr.isMon {X K} (x : Repr X K) : Bool :=
  match x with
  | mon _ => true
  | _ => false

  def Repr.isAdd {X K} (x : Repr X K) : Bool :=
  match x with
  | add _ => true
  | _ => false

  def Repr.isMul {X K} (x : Repr X K) : Bool :=
  match x with
  | add _ => true
  | _ => false

  -- inductive Repr'.RedForm {X K} [One X] [Zero X] : List Repr' X K → Prop where
  -- | mon_id (x : X) : RedForm ([mon x])
  -- | mul_list (x : Repr X K)
  --            (xs : List (Repr X K))
  --            (h : xs ≠ [] ∨ xs
  -- | add_red (x : (Repr X K))
  --           (xs : List (Repr X K))
  --           (h : xs ≠ [])
  --           (h' : x ≠ 0 ∨ xs ≠ [0])
  --           (h'' : )
  --           -- addition is non tirivial
  --           (h : xs.size > 2)
  --           -- elements must be reduced, non-zero and can't be addition
  --           (h' : ∀ i : Fin xs.size,
  --                 let xi := xs.get i
  --                 (RedForm xi) ∧ (xi ≠ 0) ∧ (¬ xi.isAdd))
  --           : RedForm (add xs)

  -- inductive Repr.RedForm {X K} [One X] [Zero X] : Repr X K → Prop where
  -- | mon_id (x : X) : RedForm (mon x)
  -- | add_red (xs : Array (Repr X K))
  --           -- addition is non tirivial
  --           (h : xs.size > 2)
  --           -- elements must be reduced, non-zero and can't be addition
  --           (h' : ∀ i : Fin xs.size,
  --                 let xi := xs.get i
  --                 (RedForm xi) ∧ (xi ≠ 0) ∧ (¬ xi.isAdd))
  --           : RedForm (add xs)
  -- | mul_red (xs : Array (Repr X K))
  --           -- product is non trivial
  --           (h : xs.size > 2)
  --           -- every element of a product should be reduced
  --           -- and can't be zero or one
  --           (h' : ∀ i, let xi := xs.get i
  --                 (RedForm xi) ∧ (xi ≠ 0) ∧ (xi ≠ 1))
  --           -- consecutive elements can be monomials
  --           (h' : ∀ i : Fin (xs.size - 1),
  --                 let xi      := xs.get !i.1
  --                 let xi_succ := xs.get !(i.1+1)
  --                 ¬(xi.isMon ∧ xi_succ.isMon))
  --           : RedForm (mul xs)
  -- | smul_red (a : K) (x : Repr X K)
  --            (h : RedForm x)
  --            -- scalar multiplication can be only over addition
  --            (h' : x.isAdd)
  --            : RedForm (smul a x)

  -- def Repr.reduce {X K} [Ring K] [Monoid X] : Repr X K → Repr X K
  -- | add zero x => reduce x
  -- | add x zero => reduce x
  -- | mul (mon x) (mon y) => mon (x * y)
  -- | add
  -- | mul x (mon 1) => reduce x

  -- open Repr in
  -- inductive NormRepr {X K} [One X] [Zero X] : Repr X K → Prop where
  -- | zero_id : NormRepr zero
  -- | mon_id (x : X) : NormRepr (mon x)
  -- | add_lassoc (x : Repr X K) (y : X) (h : NormRepr x)
  --              (h' : x ≠ zero) (h'' : y ≠ 0) : NormRepr (add x (mon y))

end Algebra

end NewApproach