haskell_dice.hs

{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Object where

import qualified Csg
import Data.List
import Data.Serialize
import Data.Semigroup
import Data.Vec3 as V3

dieFaces :: [[[Int]]]
dieFaces = [[
    [0, 0, 0],
    [0, 1, 0],
    [0, 0, 0]],

   [[1, 0, 0], 
    [0, 0, 0], 
    [0, 0, 1]], 

   [[1, 0, 0], 
    [0, 1, 0], 
    [0, 0, 1]], 

   [[1, 0, 1], 
    [0, 0, 0], 
    [1, 0, 1]], 

   [[1, 0, 1], 
    [0, 1, 0], 
    [1, 0, 1]], 

   [[1, 0, 1], 
    [1, 0, 1], 
    [1, 0, 1]]]

reifyFace :: Csg.BspTree -> [[Int]] -> Csg.BspTree
reifyFace shape f = foldl1 Csg.union shapes
    where 
         inds = concatMap (\(i, js) -> map (\j->(fromIntegral i, fromIntegral j)) js) $ zip [0..] $ map (elemIndices 1) f
         shapes = map (\(i, j)-> Csg.translate (fromIntegral i - 1.0, fromIntegral j - 1.0, 0.0) shape) inds

axisX = (1.0, 0.0, 0.0)
axisY = (0.0, 1.0, 0.0)
axisZ = (0.0, 0.0, 1.0)

rotations :: [Csg.BspTree -> Csg.BspTree]
rotations = [
    Csg.rotate axisX 0.0,
    Csg.rotate axisY (pi/2), 
    Csg.rotate axisX (pi/2), 
    Csg.rotate axisX (-pi/2), 
    Csg.rotate axisY (-pi/2),
    Csg.rotate axisX pi
    ]

center :: Csg.BspTree -> Csg.BspTree
center o = Csg.translate (-mx, -my, -mz) o
  where 
    ((x1, y1, z1), (x2, y2, z2))  = Csg.aabb o
    mx = (x1 + x2)/2
    my = (y1 + y2)/2
    mz = (z1 + z2)/2

logo :: Csg.BspTree
logo = mask `Csg.intersection` Csg.unionConcat [chevron, 
    Csg.translate (translationUnit*1.5, 0, 0) lambda, 
    Csg.translate (translationUnit*2, 0, 0) equals
    ]
  where
    chevronTop = 
        Csg.rotate (0, 0, 1) (pi/6) $
        Csg.scale (1, 5, 1) $
        Csg.translate (-0.5 ,0.5, 0) Csg.unitCube
    chevronBottom = Csg.scale (1, -1, 1) chevronTop
    chevron = Csg.union chevronTop chevronBottom
    translationUnit = 1/(cos (pi/6))
    lambdaLeg = 
        Csg.rotate (0, 0, 1) (pi/6) $
        Csg.scale (1, 5, 1) $
        Csg.translate (-0.5 ,-0.5, 0) Csg.unitCube
    lambda = Csg.union chevron lambdaLeg
    equalsUncropped = Csg.translate (1, 0, 0) $
        (Csg.scale (4, 2.5, 1) Csg.unitCube) `Csg.subtract` 
        (Csg.scale (6, 0.5, 2) Csg.unitCube)
    equalsMask = 
        Csg.rotate (0, 0, 1) (pi/6) $
        Csg.uniformScale 6 $
        Csg.translate (-0.5 ,0, 0) Csg.unitCube
    equals = equalsUncropped `Csg.subtract` equalsMask
    mask = Csg.scale (10, 6, 2) Csg.unitCube

object :: Csg.BspTree
object = combinedFaces `Csg.intersection` sphere
    where 
        holeShape = Csg.uniformScale 0.5 $ Csg.unitCone 16
        theLogo = center $ Csg.scale (1, -1, 1) $ Csg.uniformScale (1/3)  logo 
        facePatterns = theLogo : (tail $ map (reifyFace holeShape) dieFaces)
        translateFaceIntoPlace = Csg.translate (0.0, 0.0, -0.75) . Csg.uniformScale 0.35
        positionedPatterns = map (\(r, f) -> r f) $ zip rotations $ map translateFaceIntoPlace facePatterns
        cube = Csg.uniformScale 1.5 Csg.unitCube
        combinedFaces = foldl Csg.subtract cube positionedPatterns
        sphere = Csg.unitSphere 32 16