```module Language.Mecha.Mesh
( mesh
) where

import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe

import Language.Mecha.Solid
import Language.Mecha.Types hiding (rotateX, rotateY, rotateZ)

-- | Creates a triangle mesh from a solid.
mesh :: Double -> Double -> Int -> Solid -> [(Vector, Vector)]  -- [(normal, vector), ...]
mesh radius p n solid = polygons
where
num = ceiling \$ radius / p
i = [-num .. num]
j = [-num .. num - 1]
vertices :: Map (Int, Int, Int) (Maybe Vertex, Maybe Vertex, Maybe Vertex)
vertices = M.fromList [ ((x, y, z), (f (x + 1, y, z), f (x, y + 1, z), f (x, y, z + 1))) | x <- i, y <- i, z <- i, let f = edge (x,y,z) ]
edge (ax, ay, az) (bx, by, bz) = sdEdge solid n (p * fromIntegral ax, p * fromIntegral ay, p * fromIntegral az) (p * fromIntegral bx, p * fromIntegral by, p * fromIntegral bz)
polygons = concat [ cubePolygons (x, y, z) a | x <- j, y <- j, z <- j, let a = corners solid p (x, y, z), or a, not (and a) ]

cubePolygons :: (Int, Int, Int) -> [Bool] -> [(Vector, Vector)]
cubePolygons cube config = normals \$ map (f . vertexIndex cube) \$ polygonConfigurations M.! config
where
f :: ((Int, Int, Int), Axis) -> Vertex
f ((x, y, z), a) = fromJust \$ case a of
X -> x'
Y -> y'
Z -> z'
where
(x', y', z') = vertices M.! (x, y, z)

sdEdge :: Solid -> Int -> Vertex -> Vertex -> Maybe Vertex
sdEdge (Solid f) n a b
| f a && f b || not (f a) && not (f b) = Nothing
| otherwise = Just \$ sd n a b
where
sd :: Int -> Vertex -> Vertex -> Vertex
sd n a b | n <= 0     = m
| f a == f m = sd (n - 1) m b
| otherwise  = sd (n - 1) a m
where
m = average a b

average :: Vector -> Vector -> Vector
average (aX, aY, aZ) (bX, bY, bZ) = ((aX+bX)/2, (aY+bY)/2, (aZ+bZ)/2)

corners :: Solid -> Double -> (Int, Int, Int) -> [Bool]
corners (Solid f) p (x, y, z) = map m
[ (x,     y,     z)
, (x + 1, y,     z)
, (x + 1, y + 1, z)
, (x,     y + 1, z)
, (x,     y,     z + 1)
, (x + 1, y,     z + 1)
, (x + 1, y + 1, z + 1)
, (x,     y + 1, z + 1)
]
where
m (x, y, z) = f (p * fromIntegral x, p * fromIntegral y, p * fromIntegral z)

normals :: [Vector] -> [(Vector, Vector)]  -- Normals follow right hand rule for triangles.
normals [] = []
normals (a:b:c:d) = [(normal, a), (normal, b), (normal, c)] ++ normals d
where
(ax, ay, az) = a
(bx, by, bz) = b
(cx, cy, cz) = c
vx = bx - ax
vy = by - ay
vz = bz - az
wx = cx - ax
wy = cy - ay
wz = cz - az
mx = vy * wz - vz * wy
my = vz * wx - vx * wz
mz = vx * wy - vy * wx
mag = sqrt \$ mx ** 2 + my ** 2 + mz ** 2
normal = (mx / mag, my / mag, mz / mag)
normals _ = undefined

patterns :: [([Bool], [Edge])]
patterns =
[ ([x, o, o, o, o, o, o, o], [A, D, E])

, ([x, x, o, o, o, o, o, o], [B, D, F, F, D, E])
, ([x, o, o, o, o, x, o, o], [A, D, E, I, J, F])
, ([x, o, o, o, o, o, x, o], [A, D, E, J, K, G])

, ([o, x, x, x, o, o, o, o], [F, G, H, H, D, F, D, A, F])
, ([x, x, o, o, o, o, x, o], [F, B, D, F, D, E, J, K, G])
, ([o, x, o, o, x, o, x, o], [F, B, A, J, K, G, E, L, I])

, ([x, x, x, x, o, o, o, o], [E, F, G, G, H, E])
, ([o, x, x, x, x, o, o, o], [F, G, H, F, H, D, A, F, D, E, L, I])
, ([x, o, x, o, o, x, o, x], [A, D, E, B, G, C, F, I, J, K, L, H])
, ([x, o, x, x, o, o, o, x], [B, G, A, A, G, K, A, K, E, E, K, L])
, ([o, x, x, x, o, o, o, x], [G, K, L, G, L, A, A, L, D])
, ([x, o, x, o, x, o, x, o], [B, J, C, K, C, J, D, I, A, D, L, I])
, ([x, o, x, x, o, o, x, o], [B, J, A, A, J, H, H, J, K, A, H, E])
]
where
x = True
o = False

mirrorX [a,b,c,d,e,f,g,h] = [b,a,d,c,f,e,h,g]
mirrorX _ = undefined
mirrorY [a,b,c,d,e,f,g,h] = [d,c,b,a,h,g,f,e]
mirrorY _ = undefined
rotateX [a,b,c,d,e,f,g,h] = [e,f,b,a,h,g,c,d]
rotateX _ = undefined
rotateY [a,b,c,d,e,f,g,h] = [b,f,g,c,a,e,h,d]
rotateY _ = undefined
rotateZ [a,b,c,d,e,f,g,h] = [d,a,b,c,h,e,f,g]
rotateZ _ = undefined
rotateXZ = rotateZ . rotateX

data Op = Invert | RotateXZ | RotateX | RotateY | MirrorX | MirrorY deriving Show
data Axis = X | Y | Z

polygonConfigurations :: Map [Bool] [Edge]
polygonConfigurations = M.fromList [ (a, f a) | a <- allConfigs ]
where
allConfigs = filter (\ a -> or a && not (and a)) \$ sequence (replicate 8 a) where a = [True, False]
f :: [Bool] -> [Edge]
f config = foldr unOp edges ops
where
(_, ops, edges) = findPattern config

findPattern :: [Bool] -> ([Bool], [Op], [Edge])
findPattern a = head [ (config, ops, fromJust \$ lookup config patterns) | (config, ops) <- orient [Invert, RotateXZ, RotateXZ, RotateX, RotateY, MirrorX, MirrorY] [] a, elem config \$ fst \$ unzip \$ patterns ]
where
orient :: [Op] -> [Op] -> [Bool] -> [([Bool], [Op])]
orient [] ops a = [(a, reverse ops)]
orient (f:fs) ops a = orient fs ops a ++ orient fs (f:ops) (op f a)
op f = case f of
Invert   -> map not
RotateXZ -> rotateXZ
RotateX  -> rotateX
RotateY  -> rotateY
MirrorX  -> mirrorX
MirrorY  -> mirrorY

data Edge = A | B | C | D | E | F | G | H | I | J | K | L deriving Show

unOp :: Op -> [Edge] -> [Edge]
unOp op edges = case op of
Invert   -> unOpInvert edges
RotateXZ -> map unOpRotateXZ edges
RotateX  -> map unOpRotateX  edges
RotateY  -> map unOpRotateY  edges
MirrorX  -> unOpInvert \$ map unOpMirrorX  edges
MirrorY  -> unOpInvert \$ map unOpMirrorY  edges

unOpInvert :: [Edge] -> [Edge]
unOpInvert [] = []
unOpInvert (a:b:c:d) = a : c : b : unOpInvert d
unOpInvert _ = undefined

unOpRotateXZ :: Edge -> Edge
unOpRotateXZ a = case a of
D -> A
H -> B
L -> C
E -> D
A -> E
C -> F
K -> G
I -> H
B -> I
G -> J
J -> K
F -> L

unOpRotateX :: Edge -> Edge
unOpRotateX a = case a of
C -> A
G -> B
K -> C
H -> D
D -> E
B -> F
J -> G
L -> H
A -> I
F -> J
I -> K
E -> L

unOpRotateY :: Edge -> Edge
unOpRotateY a = case a of
E -> A
D -> B
H -> C
L -> D
I -> E
A -> F
C -> G
K -> H
F -> I
B -> J
G -> K
J -> L

unOpMirrorX :: Edge -> Edge
unOpMirrorX a = case a of
E -> F
F -> E
L -> J
J -> L
H -> G
G -> H
D -> B
B -> D
a -> a

unOpMirrorY :: Edge -> Edge
unOpMirrorY a = case a of
A -> C
C -> A
F -> G
G -> F
E -> H
H -> E
I -> K
K -> I
a -> a

vertexIndex :: (Int, Int, Int) -> Edge -> ((Int, Int, Int), Axis)
vertexIndex (x, y, z) a = case a of
A -> ((x, y, z),         X)
B -> ((x + 1, y, z),     Y)
C -> ((x, y + 1, z),     X)
D -> ((x, y, z),         Y)
E -> ((x, y, z),         Z)
F -> ((x + 1, y, z),     Z)
G -> ((x + 1, y + 1, z), Z)
H -> ((x, y + 1, z),     Z)
I -> ((x, y, z + 1),     X)
J -> ((x + 1, y, z + 1), Y)
K -> ((x, y + 1, z + 1), X)
L -> ((x, y, z + 1),     Y)

```