Task
Draw a rotating cube.

It should be oriented with one vertex pointing straight up, and its opposite vertex on the main diagonal (the one farthest away) straight down. It can be solid or wire-frame, and you can use ASCII art if your language doesn't have graphical capabilities. Perspective is optional.




Related tasks
 Draw a cuboid
 write language name in 3D ASCII


{-# LANGUAGE RecursiveDo #-} 
import Reflex.Dom 
import Data.Map as DM (Map, lookup, insert, empty, fromList)
import Data.Matrix 
import Data.Time.Clock 
import Control.Monad.Trans 
 
size = 500
updateFrequency = 0.2
rotationStep = pi/10
 
data Color = Red | Green | Blue | Yellow | Orange | Purple | Black deriving (Show,Eq,Ord,Enum)
 
zRot :: Float -> Matrix Float
zRot rotation = 
    let c = cos rotation
        s = sin rotation
    in fromLists [[ c,  s,  0,  0 ]
                 ,[-s,  c,  0,  0 ]
                 ,[ 0,  0,  1,  0 ]
                 ,[ 0,  0,  0,  1 ]
                 ]
 
xRot :: Float -> Matrix Float
xRot rotation = 
    let c = cos rotation
        s = sin rotation
    in fromLists [[ 1,  0,  0,  0 ]
                 ,[ 0,  c,  s,  0 ]
                 ,[ 0, -s,  c,  0 ]
                 ,[ 0,  0,  0,  1 ]
                 ]
 
yRot :: Float -> Matrix Float
yRot rotation = 
    let c = cos rotation
        s = sin rotation
    in fromLists [[ c,  0, -s,  0 ]
                 ,[ 0,  1,  0,  0 ]
                 ,[ s,  0,  c,  0 ]
                 ,[ 0,  0,  0,  1 ]
                 ]
 
translation :: (Float,Float,Float) -> Matrix Float
translation (x,y,z) =
    fromLists  [[ 1,  0,  0,  0 ]
               ,[ 0,  1,  0,  0 ]
               ,[ 0,  0,  1,  0 ]
               ,[ x,  y,  z,  1 ]
               ]
 
scale :: Float -> Matrix Float
scale s =
    fromLists  [[ s,  0,  0,  0 ]
               ,[ 0,  s,  0,  0 ]
               ,[ 0,  0,  s,  0 ]
               ,[ 0,  0,  0,  1 ]
               ]
 
-- perspective transformation; 
perspective :: Matrix Float
perspective = 
    fromLists  [[ 1,  0,  0,  0 ]
               ,[ 0,  1,  0,  0 ]
               ,[ 0,  0,  1,  1 ]
               ,[ 0,  0,  1,  1 ] ]
 
transformPoints :: Matrix Float -> Matrix Float -> [(Float,Float)]
transformPoints transform points = 
    let result4d = points `multStd2` transform
        result2d = (\[x,y,z,w] -> (x/w,y/w)) <$> toLists result4d
    in result2d
 
showRectangle :: MonadWidget t m => Float -> Float -> Float -> Float -> Color -> Dynamic t (Matrix Float) -> m ()
showRectangle x0 y0 x1 y1 faceColor dFaceView = do
    let points = fromLists [[x0,y0,0,1],[x0,y1,0,1],[x1,y1,0,1],[x1,y0,0,1]]
        pointsToString = concatMap (\(x,y) -> show x ++ ", " ++ show y ++ " ") 
    dAttrs <- mapDyn (\fvk -> DM.fromList [ ("fill", show faceColor)
                                          , ("points", pointsToString (transformPoints fvk points))
                                          ] ) dFaceView
    elDynAttrSVG "polygon" dAttrs $ return ()
 
showUnitSquare :: MonadWidget t m => Color -> Float -> Dynamic t (Matrix Float) -> m ()
showUnitSquare faceColor margin dFaceView = 
    showRectangle margin margin (1.0 - margin) (1.0 - margin) faceColor dFaceView
 
-- show colored square on top of black square for outline effect
showFace :: MonadWidget t m => Color -> Dynamic t (Matrix Float) -> m ()
showFace faceColor dFaceView = do  
    showUnitSquare Black 0 dFaceView
    showUnitSquare faceColor 0.03 dFaceView
 
facingCamera :: [Float] -> Matrix Float -> Bool
facingCamera viewPoint modelTransform =
    let cross [x0,y0,z0] [x1,y1,z1] = [y0*z1-z0*y1, z0*x1-x0*z1, x0*y1-y0*x1 ] 
        dot v0 v1 = sum $ zipWith (*) v0 v1
        vMinus = zipWith (-) 
 
        untransformedPoints = fromLists [ [0,0,0,1]   -- lower left 
                                        , [1,0,0,1]   -- lower right 
                                        , [0,1,0,1] ] -- upper left 
 
        transformedPoints = toLists $ untransformedPoints `multStd2` modelTransform
        pt00 = take 3 $ head transformedPoints         -- transformed lower left
        pt10 = take 3 $ transformedPoints !! 1         -- transformed upper right
        pt01 = take 3 $ transformedPoints !! 2         -- transformed upper left
 
        tVec_10_00 = pt10 `vMinus` pt00                -- lower right to lower left
        tVec_01_00 = pt01 `vMinus` pt00                -- upper left to lower left
        perpendicular = tVec_10_00 `cross` tVec_01_00  -- perpendicular to face
        cameraToPlane = pt00 `vMinus` viewPoint        -- line of sight to face
 
        -- Perpendicular points away from surface;
        -- Camera vector points towards surface
        -- Opposed vectors means that face will be visible.
    in cameraToPlane `dot` perpendicular < 0
 
faceView :: Matrix Float -> Matrix Float -> (Bool, Matrix Float)
faceView modelOrientation faceOrientation = 
    let modelTransform =            translation (-1/2,-1/2,1/2) -- unit square to origin + z offset
                         `multStd2` faceOrientation             -- orientation specific to each face
                         `multStd2` scale (1/2)                 -- shrink cube to fit in view.
                         `multStd2` modelOrientation            -- position the entire cube
 
 
        isFacingCamera = facingCamera [0,0,-1] modelTransform   -- backface elimination
 
        -- combine to get single transform from 2d face to 2d display
        viewTransform =            modelTransform
                        `multStd2` perspective
                        `multStd2` scale size                       -- scale up to svg box scale
                        `multStd2` translation (size/2, size/2, 0)  -- move to center of svg box
 
    in (isFacingCamera, viewTransform)
 
updateFaceViews :: Matrix Float -> Map Color (Matrix Float) -> (Color, Matrix Float) -> Map Color (Matrix Float)
updateFaceViews modelOrientation prevCollection (faceColor, faceOrientation) = 
    let (isVisible, newFaceView) = faceView modelOrientation faceOrientation
    in  if isVisible 
        then insert faceColor newFaceView prevCollection
        else prevCollection
 
faceViews :: Matrix Float -> Map Color (Matrix Float)
faceViews modelOrientation  =
    foldl (updateFaceViews modelOrientation) empty 
          [ (Purple , xRot (0.0) )  
          , (Yellow , xRot (pi/2) )  
          , (Red    , yRot (pi/2) )  
          , (Green  , xRot (-pi/2) )  
          , (Blue   , yRot (-pi/2) )  
          , (Orange , xRot (pi) )
          ]
 
viewModel :: MonadWidget t m => Dynamic t (Matrix Float) -> m ()
viewModel modelOrientation = do
    faceMap <- mapDyn faceViews modelOrientation
    listWithKey faceMap showFace
    return ()
 
view :: MonadWidget t m => Dynamic t (Matrix Float) -> m ()
view modelOrientation = do
    el "h1" $ text "Rotating Cube"
    elDynAttrSVG "svg" 
        (constDyn $  DM.fromList [ ("width",  show size), ("height", show size) ]) 
        $ viewModel modelOrientation
 
main = mainWidget $ do 
    let initialOrientation = xRot (pi/4) `multStd2` zRot (atan(1/sqrt(2)))
        update _ modelOrientation = modelOrientation `multStd2` (yRot (rotationStep) ) 
 
    tick <- tickLossy  updateFrequency =<< liftIO getCurrentTime
    rec
        view modelOrientation
        modelOrientation <- foldDyn update initialOrientation tick
    return ()
 
-- At end because of Rosetta Code handling of unmatched quotes.
elDynAttrSVG a2 a3 a4 = do 
    elDynAttrNS' (Just "http://www.w3.org/2000/svg") a2 a3 a4
    return ()