Initial data commit
This commit is contained in:
Ingy döt Net
parent
72d218235f
commit
f23f22d71c
199087 changed files with 3378941 additions and 0 deletions
180
Task/Draw-a-rotating-cube/Haskell/draw-a-rotating-cube.hs
Normal file
180
Task/Draw-a-rotating-cube/Haskell/draw-a-rotating-cube.hs
Normal file
|
|
@ -0,0 +1,180 @@
|
|||
{-# 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 ()
|
||||
Loading…
Add table
Add a link
Reference in a new issue