Exact platonic solids

Platonic.hs

{-# language DeriveTraversable #-}
{-# language DefaultSignatures #-}
{-# language NegativeLiterals #-}

-- no zero divisors, decidable equality, other nice stuff as needed
class (Eq a, Num a) => Nice a 
instance Nice Float
instance Nice Double
instance Nice Integer

-- @Fib a b :: Fib r@ denotes @aΦ + b@ ∈ r[Φ]
data Fib a = Fib !a !a 
  deriving (Functor, Foldable, Traversable, Eq)

-- allow somewhat prettier printing
instance (Nice a, Show a) => Show (Fib a) where
  showsPrec d (Fib 0 b) = showsPrec d b 
  showsPrec d (Fib 1 b) = showParen (d > 6) $ showString "φ + " . showsPrec 6 b
  showsPrec d (Fib -1 b) = showParen (d > 6) $ showString "-φ + " . showsPrec 6 b
  showsPrec d (Fib a b) = showParen (d > 6) $ showsPrec 7 a . showString "*φ + " . showsPrec 6 b

instance (Nice a, Ord a) => Ord (Fib a) where
  compare (Fib a b) (Fib c d) = case compare a c of
    LT | b <= d    -> LT
       | otherwise -> go compare (a-c) (b-d)
    EQ -> compare b d
    GT | b >= d    -> GT
       | otherwise -> go (flip compare) (a-c) (b-d)
   where
     -- convert to a(√5) and compare squares
     go k e f = k (sq (e+2*f)) (5*sq e)
     sq x = x*x

instance Num a => Num (Fib a) where
  Fib a b + Fib c d = Fib (a + c) (b + d)
  -- Φ^2 = Φ+1, so (aΦ+b)(cΦ+d) = ac(Φ+1) + (ad+bc)Φ + bd == (ac+ad+bc)Φ + (ac+bd)
  Fib a b * Fib c d = Fib (a*(c + d) + b*c) (a*c + b*d)
  Fib a b - Fib c d = Fib (a - c) (b - d)
  negate (Fib a b) = Fib (negate a) (negate b)
  abs x = x
  signum _ = Fib 0 1 -- with our current constraints this is all we can say, not willing to give up instances to do better.
  fromInteger n = Fib 0 (fromInteger n)

instance Fractional a => Fractional (Fib a) where
  recip (Fib a b) = Fib (-a/d) ((a+b)/d) where
    d = b*b + a*b - a*a
  fromRational r = Fib 0 (fromRational r)

instance Nice a => Nice (Fib a)

class Nice a => Golden a where
  φ :: a
  default φ :: Floating a => a
  φ = (1 + sqrt 5)*0.5

  sqrt5 :: a
  sqrt5 = 2*φ - 1

  iφ :: a
  iφ = φ - 1

instance Golden Float
instance Golden Double
instance Nice a => Golden (Fib a) where
  φ = Fib 1 0

unfib :: Golden a => Fib a -> a
unfib (Fib a b) = a*φ + b

-- fast fibonacci transform
fib :: Nice a => Integer -> a
fib n
  | n >= 0 = getPhi (φ ^ n)
  | otherwise = getPhi (iφ ^ negate n)

-- @unfib . nofib = id@
nofib :: Num a => a -> Fib a
nofib = Fib 0

getPhi :: Fib a -> a
getPhi (Fib a _) = a

data V3 a = V3 !a !a !a
  deriving (Eq,Show,Functor,Foldable,Traversable)

-- these points form the hull of each platonic solid

cube :: Num a => [V3 a]
cube = V3 <$> [1,-1] <*> [1,-1] <*> [1,-1]

octahedron :: Num a => [V3 a]
octahedron = [V3 0 0 1, V3 0 0 -1, V3 1 0 0, V3 0 1 0, V3 0 -1 0, V3 -1 0 0]

tetrahedron :: Num a => [V3 a]
tetrahedron = [V3 1 1 1, V3 -1 -1 1, V3 1 -1 -1, V3 -1 1 -1]

nφ, niφ :: Golden a => a
nφ = -φ
niφ = -iφ

icosahedron :: Golden a => [V3 a]
icosahedron = 
  [ V3 0 nφ 1
  , V3 0 φ 1
  , V3 0 φ -1
  , V3 0 nφ -1
  , V3 1 0 φ
  , V3 -1 0 φ
  , V3 -1 0 nφ
  , V3 1 0 nφ
  , V3 φ 1 0
  , V3 nφ 1 0
  , V3 nφ -1 0
  , V3 φ -1 0
  ]

dodecahedron :: Golden a => [V3 a]
dodecahedron =
  cube ++
  [ V3 φ 0 iφ
  , V3 nφ 0 iφ
  , V3 nφ 0 niφ
  , V3 φ 0 niφ
  , V3 iφ φ 0
  , V3 iφ nφ 0
  , V3 niφ nφ 0
  , V3 niφ φ 0
  , V3 0 iφ φ
  , V3 0 iφ nφ
  , V3 0 niφ nφ
  , V3 0 niφ φ
  ]

main :: IO ()
main = do
  -- we can compute with doubles, and get messy inexact representations
  print (dodecahedron :: [V3 Double])
-- [V3 1.0 1.0 1.0,V3 1.0 1.0 (-1.0),V3 1.0 (-1.0) 1.0,V3 1.0 (-1.0) (-1.0),V3 (-1.0) 1.0 1.0,V3 (-1.0) 1.0 (-1.0),V3 (-1.0) (-1.0) 1.0,V3 (-1.0) (-1.0) (-1.0),V3 1.618033988749895 0.0 0.6180339887498949,V3 (-1.618033988749895) 0.0 0.6180339887498949,V3 (-1.618033988749895) 0.0 (-0.6180339887498949),V3 1.618033988749895 0.0 (-0.6180339887498949),V3 0.6180339887498949 1.618033988749895 0.0,V3 0.6180339887498949 (-1.618033988749895) 0.0,V3 (-0.6180339887498949) (-1.618033988749895) 0.0,V3 (-0.6180339887498949) 1.618033988749895 0.0,V3 0.0 0.6180339887498949 1.618033988749895,V3 0.0 0.6180339887498949 (-1.618033988749895),V3 0.0 (-0.6180339887498949) (-1.618033988749895),V3 0.0 (-0.6180339887498949) 1.618033988749895]
--
  -- with pairs of integers, getting exact representations, but not allowing nice rotations and things
  print (dodecahedron :: [V3 (Fib Integer)])
-- [V3 1 1 1,V3 1 1 (-1),V3 1 (-1) 1,V3 1 (-1) (-1),V3 (-1) 1 1,V3 (-1) 1 (-1),V3 (-1) (-1) 1,V3 (-1) (-1) (-1),V3 (φ + 0) 0 (φ + -1),V3 (-φ + 0) 0 (φ + -1),V3 (-φ + 0) 0 (-φ + 1),V3 (φ + 0) 0 (-φ + 1),V3 (φ + -1) (φ + 0) 0,V3 (φ + -1) (-φ + 0) 0,V3 (-φ + 1) (-φ + 0) 0,V3 (-φ + 1) (φ + 0) 0,V3 0 (φ + -1) (φ + 0),V3 0 (φ + -1) (-φ + 0),V3 0 (-φ + 1) (-φ + 0),V3 0 (-φ + 1) (φ + 0)]

  -- or with pairs of doubles, getting a nice compromise
  print (dodecahedron :: [V3 (Fib Double)])
-- [V3 1.0 1.0 1.0,V3 1.0 1.0 (-1.0),V3 1.0 (-1.0) 1.0,V3 1.0 (-1.0) (-1.0),V3 (-1.0) 1.0 1.0,V3 (-1.0) 1.0 (-1.0),V3 (-1.0) (-1.0) 1.0,V3 (-1.0) (-1.0) (-1.0),V3 (φ + 0.0) 0.0 (φ + -1.0),V3 (-φ + -0.0) 0.0 (φ + -1.0),V3 (-φ + -0.0) 0.0 (-φ + 1.0),V3 (φ + 0.0) 0.0 (-φ + 1.0),V3 (φ + -1.0) (φ + 0.0) 0.0,V3 (φ + -1.0) (-φ + -0.0) 0.0,V3 (-φ + 1.0) (-φ + -0.0) 0.0,V3 (-φ + 1.0) (φ + 0.0) 0.0,V3 0.0 (φ + -1.0) (φ + 0.0),V3 0.0 (φ + -1.0) (-φ + -0.0),V3 0.0 (-φ + 1.0) (-φ + -0.0),V3 0.0 (-φ + 1.0) (φ + 0.0)]