181 lines
6.9 KiB
Haskell
181 lines
6.9 KiB
Haskell
{-# 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 ()
|