spirals/Main.hs

module Main where

import Control.Monad (forM_)
import Data.List (intercalate)
import Debug.Trace (trace)
import Math.NumberTheory.Roots (integerSquareRoot, integerCubeRoot)

type Cell = Int  -- ^ The index of a cell in the cube
type Peel = Int -- ^ A peel of our cube
type Ring = Int -- ^ A ring of a 2D spiral
type Length = Int -- ^ The length of an line segment
type X = Int
type Y = Int
type Z = Int
type Point2D = (X, Y)
type Point3D = (X, Y, Z)

area :: Int -> Int
area a = a * a

cube :: Int -> Int
cube a = a * a * a

ring :: Cell -> Ring
ring o = integerSquareRoot o `div` 2

peel :: Cell -> Peel
peel c = integerCubeRoot c `div` 2

edge :: Peel -> Length
edge l = 2 * l + 2

atZ :: Z -> Point2D -> Point3D
atZ z (x, y) = (x, y, z)

reflectY :: Point2D -> Point2D
reflectY (x, y) = (x, -y - 1)

reflectX :: Point2D -> Point2D
reflectX (x, y) = (-x - 1, y)

reflectX3 :: Point3D -> Point3D
reflectX3 (x, y, z) = (-x - 1, y, z)

reflectZ3 :: Point3D -> Point3D
reflectZ3 (x, y, z) = (x, y, -z - 1)

rotate :: Length -> Point2D -> Point2D
rotate l (x, y) = (-y - 1, -x - 1)

spirals :: Length -> Cell -> Point3D
spirals l c = atZ h $ case h `mod` 4 of
    0 -> growingSpiral l o
    1 -> rotate l $ shrinkingSpiral l o
    2 -> reflectX . reflectY $ growingSpiral l o
    3 -> reflectX . reflectY . rotate l $ shrinkingSpiral l o
  where h = c `div` area l
        o = c - h * area l
        z = h - l `div` 2 - 1

growingSpiral :: Length -> Cell -> Point2D
growingSpiral l o | o == 0         = (0, 0)
                  | ro <     e - 1 = (r, ro - r) -- 64
                  | ro < 2 * e - 2 = (3 * r - ro, r)
                  | ro < 3 * e - 3 = (0 - r - 1, 5 * r - ro + 1)
                  | otherwise      = (ro - 7 * r - 3, 0 - r - 1)
  where r = ring o                   -- ^ the current spiral ring
        ro = o - area (edge $ r - 1) -- ^ offset within this ring
        e = edge r                   -- ^ edge of the this ring

shrinkingSpiral :: Length -> Cell -> Point2D
shrinkingSpiral l o = growingSpiral l (area l - o - 1)

peeledCubes :: Length -> Cell -> Point3D
peeledCubes _ c | o < a = reverseIfOdd
                        . atZ (e `div` 2 - 1) -- on top of the cube
                        $ growingSpiral e o
                | o < a + (e - 2) * (e - 1) * 4
                        = reverseIfOdd
                        $ mantel p e (o - a)
                | otherwise
                        = reverseIfOdd
                        . atZ (-e `div` 2) -- on the bottom of the cube
                        . reflectX
                        $ shrinkingSpiral e (o - a - (e - 2) * (e - 1) * 4)
  where p = peel c -- ^ the current peel
        o = c - cube (edge $ p - 1) -- ^ offset within the current peel
        e = edge p -- ^ the length of the edge of the current peel
        a = area e -- ^ the area of a side of the current peel
        reverseIfOdd = if p `mod` 2 == 0 then id else (reflectX3 . reflectZ3)

mantel :: Peel -> Length -> Cell -> Point3D
mantel p e m | o <= r             = (p - r + o, 0 - p - 1, p - r - 1)
             | o <= r +     e - 1 = (p, 0 - p - 1 + o - r, p - r - 1)
             | o <= r + 2 * e - 2 = (p - o + r + e - 1, p, p - r - 1)
             | o <= r + 3 * e - 3 = (0 - p - 1, p - o + r + 2 * e - 2, p - r - 1)
             | otherwise          = (0 - p - 1 + o - r - 3 * e + 3, 0 - p - 1, p - r - 1)
  where r = m `div` (4 * e - 4) -- ^ revolutions since starting on the side
        o = m - (4 * e - 4) * r -- ^ offset within this revolution

asMatrix :: Length -> [[[Cell]]]
asMatrix e = foldl (\c (i, x, y, z) -> replace c z $ replace (c!!z) y $ replace (c!!z!!y) x i)
                   (replicate e $ replicate e $ replicate e (-1))
                   [ (i, x + div e 2, y + div e 2, z + div e 2)
                   | i <- [0..cube e - 1]
                   , let (x, y, z) = peeledCubes e i
                   ]
  where replace :: [a] -> Int -> a -> [a]
        replace l i e = take i l ++ [e] ++ drop (i+1) l

main :: IO ()
main = forM_ (reverse $ asMatrix 6) $ \plane -> do
           forM_ (reverse plane) $ \row -> do
               putStrLn $ intercalate ",\t" $ map show row
           putStrLn ""