content: {-# 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 ()
  