An extension field of ℚ

Q2357.hs

{- -*- coding: utf-8-unix -*-  -}

module Q2357
 ( ExtR2(..)
 , ExtR3(..)
 , ExtR5(..)
 , ExtR7(..)
 , Q2357
 , factor
 , root2
 , root3
 , root5
 , root7
 , flatten
 ) where

import Data.Ratio

data ExtR2 a = ExtR2 a a deriving Eq

instance (Show a, Num a, Ord a) => Show (ExtR2 a) where
  show (ExtR2 0 0) = "0"
  show (ExtR2 0 y) = "(" ++ show y ++ ")√2"
  show (ExtR2 x 0) = show x
  show (ExtR2 x y) = show x ++ " + (" ++ show y ++ ")√2"

data ExtR3 a = ExtR3 a a deriving Eq

instance (Show a, Num a, Ord a) => Show (ExtR3 a) where
  show (ExtR3 0 0) = "0"
  show (ExtR3 0 y) = "(" ++ show y ++ ")√3"
  show (ExtR3 x 0) = show x
  show (ExtR3 x y) = show x ++ " + (" ++ show y ++ ")√3"

data ExtR5 a = ExtR5 a a deriving Eq

instance (Show a, Num a, Ord a) => Show (ExtR5 a) where
  show (ExtR5 0 0) = "0"
  show (ExtR5 0 y) = "(" ++ show y ++ ")√5"
  show (ExtR5 x 0) = show x
  show (ExtR5 x y) = show x ++ " + (" ++ show y ++ ")√5"

data ExtR7 a = ExtR7 a a deriving Eq

instance (Show a, Num a, Ord a) => Show (ExtR7 a) where
  show (ExtR7 0 0) = "0"
  show (ExtR7 0 y) = "(" ++ show y ++ ")√7"
  show (ExtR7 x 0) = show x
  show (ExtR7 x y) = show x ++ " + (" ++ show y ++ ")√7"

positive_r :: (Num a, Ord a) => a -> a -> a -> Bool
positive_r r x y | (x >= 0) && (y >= 0)  = True
                 | (x >= 0) && (y <  0)  = (  x*x - r*y*y) >= 0
                 | (x <  0) && (y >= 0)  = (- x*x + r*y*y) >= 0
                 | otherwise             = False

instance (Num a, Ord a) => Num (ExtR2 a) where
  (ExtR2 x y) + (ExtR2 z w) = ExtR2 (x+z) (y+w)
  (ExtR2 x y) * (ExtR2 z w) = ExtR2 x' y'
    where x' = x*z + 2*y*w
          y' = y*z + x*w
  (ExtR2 x y) - (ExtR2 z w) = ExtR2 (x-z) (y-w)
  negate (ExtR2 x y) = ExtR2 (negate x) (negate y)
  abs z@(ExtR2 x y)  | positive_r 2 x y  = z
                     | otherwise         = negate z
  signum (ExtR2 0 0) = 0
  signum (ExtR2 x y) | positive_r 2 x y  = 1
                     | otherwise         = -1
  fromInteger x      = ExtR2 (fromInteger x) 0

instance (Num a, Ord a) => Ord (ExtR2 a) where
  x <= y  = positive_r 2 z w
    where ExtR2 z w = y - x

instance (Num a, Ord a) => Num (ExtR3 a) where
  (ExtR3 x y) + (ExtR3 z w) = ExtR3 (x+z) (y+w)
  (ExtR3 x y) * (ExtR3 z w) = ExtR3 x' y'
    where x' = x*z + 3*y*w
          y' = y*z + x*w
  (ExtR3 x y) - (ExtR3 z w) = ExtR3 (x-z) (y-w)
  negate (ExtR3 x y) = ExtR3 (negate x) (negate y)
  abs z@(ExtR3 x y)  | positive_r 3 x y  = z
                     | otherwise         = negate z
  signum (ExtR3 0 0) = 0
  signum (ExtR3 x y) | positive_r 3 x y  = 1
                     | otherwise         = -1
  fromInteger x      = ExtR3 (fromInteger x) 0

instance (Num a, Ord a) => Ord (ExtR3 a) where
  x <= y  = positive_r 3 z w
    where ExtR3 z w = y - x

instance (Num a, Ord a) => Num (ExtR5 a) where
  (ExtR5 x y) + (ExtR5 z w) = ExtR5 (x+z) (y+w)
  (ExtR5 x y) * (ExtR5 z w) = ExtR5 x' y'
    where x' = x*z + 5*y*w
          y' = y*z + x*w
  (ExtR5 x y) - (ExtR5 z w) = ExtR5 (x-z) (y-w)
  negate (ExtR5 x y) = ExtR5 (negate x) (negate y)
  abs z@(ExtR5 x y)  | positive_r 5 x y  = z
                     | otherwise         = negate z
  signum (ExtR5 0 0) = 0
  signum (ExtR5 x y) | positive_r 5 x y  = 1
                     | otherwise         = -1
  fromInteger x      = ExtR5 (fromInteger x) 0

instance (Num a, Ord a) => Ord (ExtR5 a) where
  x <= y  = positive_r 5 z w
    where ExtR5 z w = y - x

instance (Num a, Ord a) => Num (ExtR7 a) where
  (ExtR7 x y) + (ExtR7 z w) = ExtR7 (x+z) (y+w)
  (ExtR7 x y) * (ExtR7 z w) = ExtR7 x' y'
    where x' = x*z + 7*y*w
          y' = y*z + x*w
  (ExtR7 x y) - (ExtR7 z w) = ExtR7 (x-z) (y-w)
  negate (ExtR7 x y) = ExtR7 (negate x) (negate y)
  abs z@(ExtR7 x y)  | positive_r 7 x y  = z
                     | otherwise         = negate z
  signum (ExtR7 0 0) = 0
  signum (ExtR7 x y) | positive_r 7 x y  = 1
                     | otherwise         = -1
  fromInteger x      = ExtR7 (fromInteger x) 0

instance (Num a, Ord a) => Ord (ExtR7 a) where
  x <= y  = positive_r 7 z w
    where ExtR7 z w = y - x

instance (Fractional a, Ord a) => Fractional (ExtR2 a) where
  fromRational x      = ExtR2 (fromRational x) 0
  recip x@(ExtR2 a b) = ExtR2 (a / c) (negate b / c)
    where y = ExtR2 a (negate b)
          (ExtR2 c _) = x * y

instance (Fractional a, Ord a) => Fractional (ExtR3 a) where
  fromRational x      = ExtR3 (fromRational x) 0
  recip x@(ExtR3 a b) = ExtR3 (a / c) (negate b / c)
    where y = ExtR3 a (negate b)
          (ExtR3 c _) = x * y

instance (Fractional a, Ord a) => Fractional (ExtR5 a) where
  fromRational x      = ExtR5 (fromRational x) 0
  recip x@(ExtR5 a b) = ExtR5 (a / c) (negate b / c)
    where y = ExtR5 a (negate b)
          (ExtR5 c _) = x * y

instance (Fractional a, Ord a) => Fractional (ExtR7 a) where
  fromRational x      = ExtR7 (fromRational x) 0
  recip x@(ExtR7 a b) = ExtR7 (a / c) (negate b / c)
    where y = ExtR7 a (negate b)
          (ExtR7 c _) = x * y

showWithSign :: (Show a, Num a, Ord a) => a -> String
showWithSign x | x >= 0    = "+(" ++ show (abs x) ++ ")"
               | otherwise = "-(" ++ show (abs x) ++ ")"

type Q2357 = ExtR7 (ExtR5 (ExtR3 (ExtR2 Rational)))

flatten :: Q2357 -> String
flatten (ExtR7 (ExtR5 (ExtR3 (ExtR2 xq xr2) (ExtR2 xr3 xr6)) (ExtR3 (ExtR2 xr5 xr10) (ExtR2 xr15 xr30))) (ExtR5 (ExtR3 (ExtR2 xr7 xr14) (ExtR2 xr21 xr42)) (ExtR3 (ExtR2 xr35 xr70) (ExtR2 xr105 xr210))))
  | xq == 0   = rs
  | otherwise = show xq ++ rs
  where xs = [xr2,xr3,xr5,xr6,xr7,xr10,xr14,xr15,xr21,xr30,xr35,xr42,xr70,xr105,xr210]
        cs = map (("√"++).show) [2,3,5,6,7,10,14,15,21,30,35,42,70,105,210]
        ys = map (\(c,x)->showWithSign x++c) $ filter ((/=0).snd) $ zip cs xs
        rs = foldr (++) [] ys

root2 :: Q2357
root2 = ExtR7 (ExtR5 (ExtR3 (ExtR2 0 1) 0) 0) 0

root3 :: Q2357
root3 = ExtR7 (ExtR5 (ExtR3 0 1) 0) 0

root5 :: Q2357
root5 = ExtR7 (ExtR5 0 1) 0

root7 :: Q2357
root7 = ExtR7 0 1

factor :: Q2357 -> Q2357
factor (ExtR7 (ExtR5 (ExtR3 (ExtR2 xq xr2) (ExtR2 xr3 xr6)) (ExtR3 (ExtR2 xr5 xr10) (ExtR2 xr15 xr30))) (ExtR5 (ExtR3 (ExtR2 xr7 xr14) (ExtR2 xr21 xr42)) (ExtR3 (ExtR2 xr35 xr70) (ExtR2 xr105 xr210))))
  = fromInteger num / fromInteger den
  where den = foldr lcm 1 $ map denominator [xq,xr2,xr3,xr5,xr6,xr7,xr10,xr14,xr15,xr21,xr30,xr35,xr42,xr70,xr105,xr210]
        num = foldr gcd 0 $ map numerator [xq,xr2,xr3,xr5,xr6,xr7,xr10,xr14,xr15,xr21,xr30,xr35,xr42,xr70,xr105,xr210]

*Q2357> 1 / (root2 + root3 + root5 + root7)
(37 % 43)√2 + ((-29) % 43)√3 + ((-133) % 215 + ((62 % 215)√2)√3)√5 + (27 % 43 + (((-10) % 43)√2)√3 + (((-34) % 215)√2 + (22 % 215)√3)√5)√7