module Brick3D.Renderer where
import Brick3D.State
import Brick3D.Camera
import Brick3D.Type
import Brick3D.Rasterization

import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Vector (Vector)
import qualified Data.Vector as V
import Graphics.Vty.Attributes (Attr)
import Lens.Micro.Platform
import Linear.V3 (V3(..), _x, _y, _z, _xyz)
import Linear.V4 (V4(..))
import Linear.Matrix (mkTransformationMat, (!*), identity)
import Tart.Canvas

-- | Renders 'ThreeDState' to one 'Tart.Canvas.Canvas',
-- which will be shown in 'Widget'
render  :: MonadIO m => ThreeDState -> m ThreeDState
render :: ThreeDState -> m ThreeDState
render ThreeDState
s = do
  let rasteriezd :: [((Int, Int), Char, Attr)]
rasteriezd = ThreeDState -> [((Int, Int), Char, Attr)]
render' ThreeDState
s
  Canvas
screen' <- IO Canvas -> m Canvas
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Canvas -> m Canvas) -> IO Canvas -> m Canvas
forall a b. (a -> b) -> a -> b
$ Canvas -> IO Canvas
clearCanvas (ThreeDState
sThreeDState -> Getting Canvas ThreeDState Canvas -> Canvas
forall s a. s -> Getting a s a -> a
^.Getting Canvas ThreeDState Canvas
Lens' ThreeDState Canvas
screen) IO Canvas -> (Canvas -> IO Canvas) -> IO Canvas
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Canvas -> [((Int, Int), Char, Attr)] -> IO Canvas)
-> [((Int, Int), Char, Attr)] -> Canvas -> IO Canvas
forall a b c. (a -> b -> c) -> b -> a -> c
flip Canvas -> [((Int, Int), Char, Attr)] -> IO Canvas
canvasSetMany [((Int, Int), Char, Attr)]
rasteriezd
  ThreeDState -> m ThreeDState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThreeDState -> m ThreeDState) -> ThreeDState -> m ThreeDState
forall a b. (a -> b) -> a -> b
$ ThreeDState
sThreeDState -> (ThreeDState -> ThreeDState) -> ThreeDState
forall a b. a -> (a -> b) -> b
&(Canvas -> Identity Canvas) -> ThreeDState -> Identity ThreeDState
Lens' ThreeDState Canvas
screen((Canvas -> Identity Canvas)
 -> ThreeDState -> Identity ThreeDState)
-> Canvas -> ThreeDState -> ThreeDState
forall s t a b. ASetter s t a b -> b -> s -> t
.~Canvas
screen'

-- | Do rendering process other than IO operation (which is done in 'render'
render' :: ThreeDState -> [((Int, Int), Char, Attr)]
render' :: ThreeDState -> [((Int, Int), Char, Attr)]
render' ThreeDState
s =
  -- Convert to viewport coordinate
  let cam :: Camera
cam = ThreeDState
sThreeDState -> Getting Camera ThreeDState Camera -> Camera
forall s a. s -> Getting a s a -> a
^.Getting Camera ThreeDState Camera
Lens' ThreeDState Camera
camera
      focalLength :: Float
focalLength = Float -> Float
forall a. Num a => a -> a
abs (Float -> Float) -> Float -> Float
forall a b. (a -> b) -> a -> b
$ Float
1Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/(Float -> Float
forall a. Floating a => a -> a
tan (Float -> Float) -> Float -> Float
forall a b. (a -> b) -> a -> b
$ (Float
forall a. Floating a => a
piFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
180)Float -> Float -> Float
forall a. Num a => a -> a -> a
*(Camera
camCamera -> Getting Float Camera Float -> Float
forall s a. s -> Getting a s a -> a
^.Getting Float Camera Float
Lens' Camera Float
hFov)Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
2)
      -- Apply camera transform
      prims' :: Vector Primitive
prims' = Camera -> Primitive -> Primitive
applyCameraTransform Camera
cam (Primitive -> Primitive) -> Vector Primitive -> Vector Primitive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ThreeDState
sThreeDState
-> Getting (Vector Primitive) ThreeDState (Vector Primitive)
-> Vector Primitive
forall s a. s -> Getting a s a -> a
^.Getting (Vector Primitive) ThreeDState (Vector Primitive)
Lens' ThreeDState (Vector Primitive)
prims
      -- Convert to device coordinate
      -- Also, calculate Normal for later use(e.g. shading)
      dcprims :: Vector DCPrimitive
      dcprims :: Vector DCPrimitive
dcprims = Vector (Maybe DCPrimitive) -> Vector DCPrimitive
forall a. Vector (Maybe a) -> Vector a
V.catMaybes (Vector (Maybe DCPrimitive) -> Vector DCPrimitive)
-> Vector (Maybe DCPrimitive) -> Vector DCPrimitive
forall a b. (a -> b) -> a -> b
$ Float -> Primitive -> Maybe DCPrimitive
projectPrimitive Float
focalLength (Primitive -> Maybe DCPrimitive)
-> Vector Primitive -> Vector (Maybe DCPrimitive)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Primitive -> Bool) -> Vector Primitive -> Vector Primitive
forall a. (a -> Bool) -> Vector a -> Vector a
V.filter (Camera -> Primitive -> Bool
farNearClip Camera
cam) Vector Primitive
prims'
      screen' :: Canvas
screen' = ThreeDState
sThreeDState -> Getting Canvas ThreeDState Canvas -> Canvas
forall s a. s -> Getting a s a -> a
^.Getting Canvas ThreeDState Canvas
Lens' ThreeDState Canvas
screen
  -- Geometry Construction
  -- Shading by using property
  -- Rasterize
  in  (Int, Int) -> Vector DCPrimitive -> [((Int, Int), Char, Attr)]
forall (t :: * -> *).
(Foldable t, Functor t) =>
(Int, Int) -> t DCPrimitive -> [((Int, Int), Char, Attr)]
rasterizeMany (Canvas -> (Int, Int)
canvasSize Canvas
screen') Vector DCPrimitive
dcprims

-- | 'True' if given 'Primitive' is not clipped
-- by far/near plane
-- 
-- far/near平面によって描画されているかを確認する。
-- x,y方向の確認はしない
farNearClip :: Camera -> Primitive -> Bool
farNearClip :: Camera -> Primitive -> Bool
farNearClip Camera
cam Primitive
target = let camZ :: Float
camZ = Camera
camCamera -> Getting Float Camera Float -> Float
forall s a. s -> Getting a s a -> a
^.(Position -> Const Float Position) -> Camera -> Const Float Camera
Lens' Camera Position
position((Position -> Const Float Position)
 -> Camera -> Const Float Camera)
-> ((Float -> Const Float Float)
    -> Position -> Const Float Position)
-> Getting Float Camera Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Float -> Const Float Float) -> Position -> Const Float Position
forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z :: Float
                             far :: Float
far = Camera
camCamera -> Getting Float Camera Float -> Float
forall s a. s -> Getting a s a -> a
^.Getting Float Camera Float
Lens' Camera Float
farClip
                             near :: Float
near = Camera
camCamera -> Getting Float Camera Float -> Float
forall s a. s -> Getting a s a -> a
^.Getting Float Camera Float
Lens' Camera Float
nearClip
                         in (Vertex -> Bool) -> [Vertex] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Float -> Float -> Float -> Vertex -> Bool
farNearClipVertex Float
far Float
near Float
camZ) (Primitive
targetPrimitive -> Getting (Endo [Vertex]) Primitive Vertex -> [Vertex]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^..Getting (Endo [Vertex]) Primitive Vertex
Traversal' Primitive Vertex
vertices)
  where
    farNearClipVertex :: Float -> Float -> Float -> Vertex -> Bool
    farNearClipVertex :: Float -> Float -> Float -> Vertex -> Bool
farNearClipVertex Float
far Float
near Float
camZ Vertex
v = let tZ :: Float
tZ   = Vertex
vVertex -> Getting Float Vertex Float -> Float
forall s a. s -> Getting a s a -> a
^.(Position -> Const Float Position) -> Vertex -> Const Float Vertex
Lens' Vertex Position
v_position((Position -> Const Float Position)
 -> Vertex -> Const Float Vertex)
-> ((Float -> Const Float Float)
    -> Position -> Const Float Position)
-> Getting Float Vertex Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Float -> Const Float Float) -> Position -> Const Float Position
forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z
                                        -- 画面手前方向にz軸は向かっているので, 奥側に伸ばしたい際は
                                        -- 引く。
                                        in Float
camZFloat -> Float -> Float
forall a. Num a => a -> a -> a
-Float
near Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
tZ Bool -> Bool -> Bool
&& Float
tZ Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
camZFloat -> Float -> Float
forall a. Num a => a -> a -> a
-Float
far


-- | Project one 'Primitive' to device coordinate
projectPrimitive :: Float -> Primitive -> Maybe DCPrimitive
projectPrimitive :: Float -> Primitive -> Maybe DCPrimitive
projectPrimitive Float
focalLength Primitive
prim =
  (Vertex -> Maybe DCVertex) -> Primitive -> Maybe DCPrimitive
forall (f :: * -> *).
Applicative f =>
(Vertex -> f DCVertex) -> Primitive -> f DCPrimitive
toDCPrimitive (Float -> Vertex -> Maybe DCVertex
projectVertex Float
focalLength) Primitive
prim

-- | Project one vertex to device coordinate
projectVertex :: Float -> Vertex -> Maybe DCVertex
projectVertex :: Float -> Vertex -> Maybe DCVertex
projectVertex Float
focalLength Vertex
v
  -- focial length <0 means "screen is behind the Camera",
  -- and I don't have any way to render it.
  | Float
focalLength Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 = Maybe DCVertex
forall a. Maybe a
Nothing
  -- Avoid division by zero error
  | Vertex
vVertex -> Getting Float Vertex Float -> Float
forall s a. s -> Getting a s a -> a
^.(Position -> Const Float Position) -> Vertex -> Const Float Vertex
Lens' Vertex Position
v_position((Position -> Const Float Position)
 -> Vertex -> Const Float Vertex)
-> ((Float -> Const Float Float)
    -> Position -> Const Float Position)
-> Getting Float Vertex Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Float -> Const Float Float) -> Position -> Const Float Position
forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0 = DCVertex -> Maybe DCVertex
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DCVertex -> Maybe DCVertex) -> DCVertex -> Maybe DCVertex
forall a b. (a -> b) -> a -> b
$ Vertex -> DCVertex
fromVertex Vertex
v
  | Bool
otherwise =
    let camera2screenVector :: Float
camera2screenVector = -Float
focalLength
        percentage :: Float
percentage = Float
camera2screenVectorFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/(Vertex
vVertex -> Getting Float Vertex Float -> Float
forall s a. s -> Getting a s a -> a
^.((Position -> Const Float Position) -> Vertex -> Const Float Vertex
Lens' Vertex Position
v_position((Position -> Const Float Position)
 -> Vertex -> Const Float Vertex)
-> ((Float -> Const Float Float)
    -> Position -> Const Float Position)
-> Getting Float Vertex Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Float -> Const Float Float) -> Position -> Const Float Position
forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z))
    in DCVertex -> Maybe DCVertex
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DCVertex -> Maybe DCVertex)
-> (Vertex -> DCVertex) -> Vertex -> Maybe DCVertex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vertex -> DCVertex
fromVertex (Vertex -> Maybe DCVertex) -> Vertex -> Maybe DCVertex
forall a b. (a -> b) -> a -> b
$ Vertex
vVertex -> (Vertex -> Vertex) -> Vertex
forall a b. a -> (a -> b) -> b
&(Position -> Identity Position) -> Vertex -> Identity Vertex
Lens' Vertex Position
v_position((Position -> Identity Position) -> Vertex -> Identity Vertex)
-> ((Float -> Identity Float) -> Position -> Identity Position)
-> (Float -> Identity Float)
-> Vertex
-> Identity Vertex
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Float -> Identity Float) -> Position -> Identity Position
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x((Float -> Identity Float) -> Vertex -> Identity Vertex)
-> (Float -> Float) -> Vertex -> Vertex
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~(Float -> Float
forall p. (Eq p, Fractional p) => p -> p
fixMinusZero (Float -> Float) -> (Float -> Float) -> Float -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
percentage))Vertex -> (Vertex -> Vertex) -> Vertex
forall a b. a -> (a -> b) -> b
&(Position -> Identity Position) -> Vertex -> Identity Vertex
Lens' Vertex Position
v_position((Position -> Identity Position) -> Vertex -> Identity Vertex)
-> ((Float -> Identity Float) -> Position -> Identity Position)
-> (Float -> Identity Float)
-> Vertex
-> Identity Vertex
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Float -> Identity Float) -> Position -> Identity Position
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y((Float -> Identity Float) -> Vertex -> Identity Vertex)
-> (Float -> Float) -> Vertex -> Vertex
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~(Float -> Float
forall p. (Eq p, Fractional p) => p -> p
fixMinusZero (Float -> Float) -> (Float -> Float) -> Float -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
percentage))
  where
    -- | Convert -0.0 to 0
    -- It's same in most cases,
    -- but sometimes causes problem (e.g. hspec test).
    -- So I replace it with 0.0, which means the same value
    fixMinusZero :: p -> p
fixMinusZero p
n | p
n p -> p -> Bool
forall a. Eq a => a -> a -> Bool
== -p
0.0 = p
0
                   | Bool
otherwise = p
n


applyCameraTransform :: Camera -> Primitive -> Primitive
applyCameraTransform :: Camera -> Primitive -> Primitive
applyCameraTransform Camera
cam = ASetter Primitive Primitive Position Position
-> (Position -> Position) -> Primitive -> Primitive
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Vertex -> Identity Vertex) -> Primitive -> Identity Primitive
Traversal' Primitive Vertex
vertices((Vertex -> Identity Vertex) -> Primitive -> Identity Primitive)
-> ((Position -> Identity Position) -> Vertex -> Identity Vertex)
-> ASetter Primitive Primitive Position Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Position -> Identity Position) -> Vertex -> Identity Vertex
Lens' Vertex Position
v_position) (\Position
n -> (M44 Float
transformMatrix M44 Float -> V4 Float -> V4 Float
forall (m :: * -> *) (r :: * -> *) a.
(Functor m, Foldable r, Additive r, Num a) =>
m (r a) -> r a -> m a
!* (Position -> V4 Float
forall a. Num a => V3 a -> V4 a
conv324 Position
n))V4 Float -> Getting Position (V4 Float) Position -> Position
forall s a. s -> Getting a s a -> a
^.Getting Position (V4 Float) Position
forall (t :: * -> *) a. R3 t => Lens' (t a) (V3 a)
_xyz)
  where
    transformMatrix :: M44 Float
transformMatrix = M33 Float -> Position -> M44 Float
forall a. Num a => M33 a -> V3 a -> M44 a
mkTransformationMat (Camera
camCamera -> Getting (M33 Float) Camera (M33 Float) -> M33 Float
forall s a. s -> Getting a s a -> a
^.Getting (M33 Float) Camera (M33 Float)
Lens' Camera (M33 Float)
rotation) (- Camera
camCamera -> Getting Position Camera Position -> Position
forall s a. s -> Getting a s a -> a
^.Getting Position Camera Position
Lens' Camera Position
position) 
    conv324 :: V3 a -> V4 a
conv324 (V3 a
x a
y a
z) = a -> a -> a -> a -> V4 a
forall a. a -> a -> a -> a -> V4 a
V4 a
x a
y a
z a
1