lambdale_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 = Csg.translate (-1.5, -1, 0) $ Csg.unionConcat [innerLeft, innerRight, lowerBox, upperBox, handleA, handleB, handleC, handleCrossA, handleCrossB]
  where
    innerLeft = Csg.translate (1, 0, 0) $ Csg.scale (3, 6, 1) Csg.unitCube 
    innerRight = Csg.translate (-2, 0, 0) $ Csg.scale (1, 6, 1) Csg.unitCube 
    lowerBox = (Csg.scale (9, 10, 1) Csg.unitCube) `Csg.subtract` (Csg.scale (7, 8, 2) Csg.unitCube)
    upperBox = Csg.translate (0, 6, 0) $ (Csg.scale (9, 4, 1) Csg.unitCube) `Csg.subtract` (Csg.scale (7, 2, 2) Csg.unitCube)
    handleA = Csg.translate (5.25, -1.5, 0) $ Csg.scale (1.5, 1, 1) Csg.unitCube 
    handleB = Csg.translate (5.25, 4.5, 0) $ Csg.scale (1.5, 1, 1) Csg.unitCube
    handleC = Csg.translate (8.25, -1.5, 0) $ Csg.scale (1.5, 1, 1) Csg.unitCube
    handleCrossA = Csg.translate (4.5 + 1.5 + 1.5/2, 1.5, 0) $ 
                    Csg.rotate (0, 0, 1) ((atan (1.5/7)) + (atan (1/7))) $
                        Csg.scale (1, 7, 1) Csg.unitCube 
    handleCrossB = Csg.translate (4.5 + 1.5 + 1.5/2, 1.5, 0) $ 
                    Csg.rotate (0, 0, -1) ((atan (1.5/7)) + (atan (1/7))) $
                        Csg.scale (1, 3.5, 1) $ Csg.translate (0, -0.5, 0) Csg.unitCube 


object :: Csg.BspTree
object = combinedFaces `Csg.intersection` sphere
    where 
        holeShape = Csg.uniformScale 0.5 $ Csg.unitCone 10
        theLogo = Csg.scale (-1, 1, 2) $ Csg.uniformScale (1/6)  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 24 10