module HCube.OrientGroup (
Group(..),
Orient(..),
cons,
to,
eid,
getVec,
vecToSide,
sideToVec,
rawToOrientNumber,
orientNumberToRaw,
rawOrientNum,
spanDomain,
vecToColor,
colorToVec,
orientChrDomain,
) where
import Data.Monoid
import Data.List (find,sort)
import Data.Char (ord, chr)
import HCube.Data
import HCube.Utility
orientChrDomain = ['a'..'x']
getVec :: Orient -> [Vec]
getVec (Orient vs) = vs
class Monoid a => Group a where
inv :: a -> a
data Orient = Orient [Vec] deriving (Show, Read, Eq)
instance Monoid Orient where
mempty = Orient [(1,0,0),(0,1,0)]
mappend lhs rhs = from $ (to lhs |**| to rhs)
instance Group Orient where
inv = from . inverse . to
to :: Orient -> Matrix
to ori = mapVec f (getVec ori) where
f v1 v2 = Matrix v1 v2 g where
g = multVec (vecDet v1 v2 h) h
h = cross v1 v2
from :: Matrix -> Orient
from mx = Orient $ map (mx |*|) (getVec $ mempty)
eid :: Orient -> Char
eid = f . rawToOrientNumber . rawOrientNum where
f 0 = '-'
f nm = chr $ nm 1 + ord 'a'
cons :: Char -> Orient
cons = Orient . f . orientNumberToRaw . g where
f cd = [i . j $ (h 2, h 3, h 5), j (h 7, h 11,h 13)] where
h = modNot cd
i = gateMinus cd
j = modMinus cd 17
g ch = ord ch + 1 ord 'a'
vecToSide :: Vec -> Side
vecToSide (1,0,0) = RightS
vecToSide (1,0,0) = LeftS
vecToSide (0,1,0) = BackS
vecToSide (0,1,0) = FrontS
vecToSide (0,0,1) = UpS
vecToSide (0,0,1) = DownS
vecToSide (0,0,0) = NoSide
sideToVec :: Side -> Vec
sideToVec RightS = (1,0,0)
sideToVec LeftS = (1,0,0)
sideToVec BackS = (0,1,0)
sideToVec FrontS = (0,1,0)
sideToVec UpS = (0,0,1)
sideToVec DownS = (0,0,1)
sideToVec NoSide = (0,0,0)
colorToVec :: Color -> Vec
colorToVec = sideToVec . colorToSide
vecToColor :: Vec -> Color
vecToColor = sideToColor . vecToSide
rawToOrientNumber :: Numb -> Numb
rawToOrientNumber nm = maybe 0 fst f where
f = find (g nm) orientMap
g nm el = nm == snd el
orientNumberToRaw :: Numb -> Numb
orientNumberToRaw nm = maybe 0 snd f where
f = find (g nm) orientMap
g nm el = nm == fst el
spanDomain :: (Enum a, Num a, Ord b) => (Orient -> b) -> [(a, b)]
spanDomain fn = zip [1..] $ sort $ f where
f = [fn (Orient [a, b]) | a <- vecs, b <- vecs, a /=b, a /= minus b]
orientMap :: [(Numb,Numb)]
orientMap = spanDomain rawOrientNum
rawOrientNum :: Orient -> Numb
rawOrientNum or = mapVec f (getVec or) where
f v1 v2 = (dot v1 (2,3,5))
* (signDiscrim 17 $ dot v2 (7,11,13))
signDiscrim :: Numb -> Numb -> Numb
signDiscrim sc si
| si < 0 = sc * si
| otherwise = si