module Brick3D.Rasterization where
import Brick3D.Type

import Data.Map (Map)
import Data.Bool (bool)
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Map as M
import Graphics.Vty.Attributes (Attr, defAttr)
import Lens.Micro.Platform
import Linear.V2 (V2(..))
import Linear.V3 (_x, _y, _z)
import Linear.Vector ((^*), (^+^))
import Linear.Metric (dot, distance)

-- | Represents one Pixel
type PixelAttr = (Char, Attr)

-- | Merge two 'Map' of Pixels into one by comparing zBuffer
mergeAttr :: Map (Int, Int) (Float, PixelAttr) -> Map (Int, Int) (Float, PixelAttr) -> Map (Int, Int) (Float, PixelAttr)
mergeAttr :: Map (Int, Int) (Float, PixelAttr)
-> Map (Int, Int) (Float, PixelAttr)
-> Map (Int, Int) (Float, PixelAttr)
mergeAttr Map (Int, Int) (Float, PixelAttr)
m1 Map (Int, Int) (Float, PixelAttr)
m2 = ((Float, PixelAttr) -> (Float, PixelAttr) -> (Float, PixelAttr))
-> Map (Int, Int) (Float, PixelAttr)
-> Map (Int, Int) (Float, PixelAttr)
-> Map (Int, Int) (Float, PixelAttr)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith (\(Float, PixelAttr)
a1 (Float, PixelAttr)
a2 -> (Float, PixelAttr)
-> (Float, PixelAttr) -> Bool -> (Float, PixelAttr)
forall a. a -> a -> Bool -> a
bool (Float, PixelAttr)
a2 (Float, PixelAttr)
a1 ((Float, PixelAttr)
a1(Float, PixelAttr)
-> Getting Float (Float, PixelAttr) Float -> Float
forall s a. s -> Getting a s a -> a
^.Getting Float (Float, PixelAttr) Float
forall s t a b. Field1 s t a b => Lens s t a b
_1 Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= (Float, PixelAttr)
a2(Float, PixelAttr)
-> Getting Float (Float, PixelAttr) Float -> Float
forall s a. s -> Getting a s a -> a
^.Getting Float (Float, PixelAttr) Float
forall s t a b. Field1 s t a b => Lens s t a b
_1)) Map (Int, Int) (Float, PixelAttr)
m1 Map (Int, Int) (Float, PixelAttr)
m2
                  Map (Int, Int) (Float, PixelAttr)
-> Map (Int, Int) (Float, PixelAttr)
-> Map (Int, Int) (Float, PixelAttr)
forall a. Semigroup a => a -> a -> a
<> Map (Int, Int) (Float, PixelAttr)
m1 Map (Int, Int) (Float, PixelAttr)
-> Map (Int, Int) (Float, PixelAttr)
-> Map (Int, Int) (Float, PixelAttr)
forall a. Semigroup a => a -> a -> a
<> Map (Int, Int) (Float, PixelAttr)
m2

-- | Convert 'Map' to list so that 'canvasSetMany' can treat
toCanvasPixels :: Map (Int, Int) (Char, Attr) -> [((Int, Int), Char, Attr)]
toCanvasPixels :: Map (Int, Int) PixelAttr -> [((Int, Int), Char, Attr)]
toCanvasPixels = ([((Int, Int), Char, Attr)]
 -> (Int, Int) -> PixelAttr -> [((Int, Int), Char, Attr)])
-> [((Int, Int), Char, Attr)]
-> Map (Int, Int) PixelAttr
-> [((Int, Int), Char, Attr)]
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey (\[((Int, Int), Char, Attr)]
acc (Int, Int)
k PixelAttr
v -> ((Int, Int)
k, PixelAttr
vPixelAttr -> Getting Char PixelAttr Char -> Char
forall s a. s -> Getting a s a -> a
^.Getting Char PixelAttr Char
forall s t a b. Field1 s t a b => Lens s t a b
_1, PixelAttr
vPixelAttr -> Getting Attr PixelAttr Attr -> Attr
forall s a. s -> Getting a s a -> a
^.Getting Attr PixelAttr Attr
forall s t a b. Field2 s t a b => Lens s t a b
_2) ((Int, Int), Char, Attr)
-> [((Int, Int), Char, Attr)] -> [((Int, Int), Char, Attr)]
forall a. a -> [a] -> [a]
: [((Int, Int), Char, Attr)]
acc ) []

-- | Rasterize many of 'DCPrimitive's
rasterizeMany :: (Foldable t, Functor t) => (Int, Int) -> t DCPrimitive -> [((Int, Int), Char, Attr)]
rasterizeMany :: (Int, Int) -> t DCPrimitive -> [((Int, Int), Char, Attr)]
rasterizeMany (Int, Int)
screenSize t DCPrimitive
prims =
  Map (Int, Int) PixelAttr -> [((Int, Int), Char, Attr)]
toCanvasPixels (Map (Int, Int) PixelAttr -> [((Int, Int), Char, Attr)])
-> (t (Map (Int, Int) (Float, PixelAttr))
    -> Map (Int, Int) PixelAttr)
-> t (Map (Int, Int) (Float, PixelAttr))
-> [((Int, Int), Char, Attr)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Float, PixelAttr) -> PixelAttr)
-> Map (Int, Int) (Float, PixelAttr) -> Map (Int, Int) PixelAttr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Float, PixelAttr)
-> Getting PixelAttr (Float, PixelAttr) PixelAttr -> PixelAttr
forall s a. s -> Getting a s a -> a
^.Getting PixelAttr (Float, PixelAttr) PixelAttr
forall s t a b. Field2 s t a b => Lens s t a b
_2) (Map (Int, Int) (Float, PixelAttr) -> Map (Int, Int) PixelAttr)
-> (t (Map (Int, Int) (Float, PixelAttr))
    -> Map (Int, Int) (Float, PixelAttr))
-> t (Map (Int, Int) (Float, PixelAttr))
-> Map (Int, Int) PixelAttr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Int, Int) (Float, PixelAttr)
 -> Map (Int, Int) (Float, PixelAttr)
 -> Map (Int, Int) (Float, PixelAttr))
-> Map (Int, Int) (Float, PixelAttr)
-> t (Map (Int, Int) (Float, PixelAttr))
-> Map (Int, Int) (Float, PixelAttr)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Map (Int, Int) (Float, PixelAttr)
-> Map (Int, Int) (Float, PixelAttr)
-> Map (Int, Int) (Float, PixelAttr)
mergeAttr Map (Int, Int) (Float, PixelAttr)
forall a. Monoid a => a
mempty (t (Map (Int, Int) (Float, PixelAttr))
 -> [((Int, Int), Char, Attr)])
-> t (Map (Int, Int) (Float, PixelAttr))
-> [((Int, Int), Char, Attr)]
forall a b. (a -> b) -> a -> b
$ (DCPrimitive -> Map (Int, Int) (Float, PixelAttr))
-> t DCPrimitive -> t (Map (Int, Int) (Float, PixelAttr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int, Int) -> DCPrimitive -> Map (Int, Int) (Float, PixelAttr)
rasterize (Int, Int)
screenSize) t DCPrimitive
prims

-- | Rasterize one 'DCPrimitive'
rasterize :: (Int, Int) -> DCPrimitive -> Map (Int, Int) (Float, PixelAttr)
rasterize :: (Int, Int) -> DCPrimitive -> Map (Int, Int) (Float, PixelAttr)
rasterize (Int
sx, Int
sy) (DCPrimitive PrimitiveBase DCVertex
shape Normal
normal) =
  case PrimitiveBase DCVertex
shape of
    Point DCVertex
v ->
      (Int, Int)
-> (Float, PixelAttr) -> Map (Int, Int) (Float, PixelAttr)
forall k a. k -> a -> Map k a
M.singleton (SCVertex -> (Int, Int)
toTuple (SCVertex -> (Int, Int)) -> SCVertex -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ DCVertex -> SCVertex
screenMapping DCVertex
v) (DCVertex
vDCVertex -> Getting Float DCVertex Float -> Float
forall s a. s -> Getting a s a -> a
^.Getting Float DCVertex Float
Lens' DCVertex Float
zBuffer, (Char
'*', Attr
defAttr))
    tri :: PrimitiveBase DCVertex
tri@(Triangle DCVertex
v1 DCVertex
v2 DCVertex
v3) ->
      let v1' :: SCVertex
v1' = DCVertex -> SCVertex
screenMapping DCVertex
v1
          v2' :: SCVertex
v2' = DCVertex -> SCVertex
screenMapping DCVertex
v2
          v3' :: SCVertex
v3' = DCVertex -> SCVertex
screenMapping DCVertex
v3
          wireframeVertices :: Vector SCVertex
wireframeVertices = SCVertex -> SCVertex -> Vector SCVertex
rasterizeLine SCVertex
v1' SCVertex
v3' Vector SCVertex -> Vector SCVertex -> Vector SCVertex
forall a. Semigroup a => a -> a -> a
<> SCVertex -> SCVertex -> Vector SCVertex
rasterizeLine SCVertex
v1' SCVertex
v2' Vector SCVertex -> Vector SCVertex -> Vector SCVertex
forall a. Semigroup a => a -> a -> a
<> SCVertex -> SCVertex -> Vector SCVertex
rasterizeLine SCVertex
v2' SCVertex
v3'
          fill :: Vector SCVertex
fill = SCVertex -> SCVertex -> SCVertex -> Vector SCVertex
fillTriangle SCVertex
v1' SCVertex
v2' SCVertex
v3'
          toOutput :: Char -> Vector SCVertex -> Vector ((Int,Int), (Float, PixelAttr))
          toOutput :: Char -> Vector SCVertex -> Vector ((Int, Int), (Float, PixelAttr))
toOutput Char
c = (SCVertex -> ((Int, Int), (Float, PixelAttr)))
-> Vector SCVertex -> Vector ((Int, Int), (Float, PixelAttr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SCVertex -> ((Int, Int), (Float, PixelAttr)))
 -> Vector SCVertex -> Vector ((Int, Int), (Float, PixelAttr)))
-> (SCVertex -> ((Int, Int), (Float, PixelAttr)))
-> Vector SCVertex
-> Vector ((Int, Int), (Float, PixelAttr))
forall a b. (a -> b) -> a -> b
$ \SCVertex
v -> (SCVertex -> (Int, Int)
toTuple SCVertex
v, (SCVertex
vSCVertex -> Getting Float SCVertex Float -> Float
forall s a. s -> Getting a s a -> a
^.Getting Float SCVertex Float
Lens' SCVertex Float
depth, (Char
c, Attr
defAttr)))
          fillOutput :: Vector ((Int, Int), (Float, PixelAttr))
fillOutput = Char -> Vector SCVertex -> Vector ((Int, Int), (Float, PixelAttr))
toOutput Char
'B' Vector SCVertex
fill
          wireframeOutput :: Vector ((Int, Int), (Float, PixelAttr))
wireframeOutput = Char -> Vector SCVertex -> Vector ((Int, Int), (Float, PixelAttr))
toOutput Char
'*' Vector SCVertex
wireframeVertices
      in [((Int, Int), (Float, PixelAttr))]
-> Map (Int, Int) (Float, PixelAttr)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((Int, Int), (Float, PixelAttr))]
 -> Map (Int, Int) (Float, PixelAttr))
-> (Vector ((Int, Int), (Float, PixelAttr))
    -> [((Int, Int), (Float, PixelAttr))])
-> Vector ((Int, Int), (Float, PixelAttr))
-> Map (Int, Int) (Float, PixelAttr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector ((Int, Int), (Float, PixelAttr))
-> [((Int, Int), (Float, PixelAttr))]
forall a. Vector a -> [a]
V.toList (Vector ((Int, Int), (Float, PixelAttr))
 -> Map (Int, Int) (Float, PixelAttr))
-> Vector ((Int, Int), (Float, PixelAttr))
-> Map (Int, Int) (Float, PixelAttr)
forall a b. (a -> b) -> a -> b
$ Vector ((Int, Int), (Float, PixelAttr))
fillOutput Vector ((Int, Int), (Float, PixelAttr))
-> Vector ((Int, Int), (Float, PixelAttr))
-> Vector ((Int, Int), (Float, PixelAttr))
forall a. Semigroup a => a -> a -> a
<> Vector ((Int, Int), (Float, PixelAttr))
wireframeOutput
  where
    halfX :: Int
halfX = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> (Int -> Integer) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
sx Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 :: Int
    halfY :: Int
halfY = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> (Int -> Integer) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
sy Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 :: Int

    toTuple :: SCVertex -> (Int, Int)
    toTuple :: SCVertex -> (Int, Int)
toTuple SCVertex
v = (SCVertex
vSCVertex -> Getting Int SCVertex Int -> Int
forall s a. s -> Getting a s a -> a
^.(SCPosition -> Const Int SCPosition)
-> SCVertex -> Const Int SCVertex
Lens' SCVertex SCPosition
scv_position((SCPosition -> Const Int SCPosition)
 -> SCVertex -> Const Int SCVertex)
-> ((Int -> Const Int Int) -> SCPosition -> Const Int SCPosition)
-> Getting Int SCVertex Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const Int Int) -> SCPosition -> Const Int SCPosition
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x, SCVertex
vSCVertex -> Getting Int SCVertex Int -> Int
forall s a. s -> Getting a s a -> a
^.(SCPosition -> Const Int SCPosition)
-> SCVertex -> Const Int SCVertex
Lens' SCVertex SCPosition
scv_position((SCPosition -> Const Int SCPosition)
 -> SCVertex -> Const Int SCVertex)
-> ((Int -> Const Int Int) -> SCPosition -> Const Int SCPosition)
-> Getting Int SCVertex Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const Int Int) -> SCPosition -> Const Int SCPosition
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y)

    -- Be careful: This is __Not `DCPosition -> SCPosition'__
    --   Because 'halfX' and 'halfY' are both 'SCPosition' value.
    moveOriginToCenter :: SCPosition -> SCPosition
    moveOriginToCenter :: SCPosition -> SCPosition
moveOriginToCenter (V2 Int
x Int
y) =  Int -> Int -> SCPosition
forall a. a -> a -> V2 a
V2 (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
halfX) (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
halfY)

    screenMapping :: DCVertex -> SCVertex
    screenMapping :: DCVertex -> SCVertex
screenMapping DCVertex
v = let mappedPos :: SCPosition
mappedPos = DCPosition -> SCPosition
screenMapping' (DCPosition -> SCPosition) -> DCPosition -> SCPosition
forall a b. (a -> b) -> a -> b
$ DCVertex
vDCVertex -> Getting DCPosition DCVertex DCPosition -> DCPosition
forall s a. s -> Getting a s a -> a
^.Getting DCPosition DCVertex DCPosition
Lens' DCVertex DCPosition
dcv_position
                      in SCPosition -> Float -> SCVertex
SCVertex SCPosition
mappedPos (DCVertex
vDCVertex -> Getting Float DCVertex Float -> Float
forall s a. s -> Getting a s a -> a
^.Getting Float DCVertex Float
Lens' DCVertex Float
zBuffer)

    screenMapping' :: DCPosition -> SCPosition
    screenMapping' :: DCPosition -> SCPosition
screenMapping' DCPosition
v = SCPosition -> SCPosition
moveOriginToCenter
                         (SCPosition -> SCPosition) -> SCPosition -> SCPosition
forall a b. (a -> b) -> a -> b
$ Int -> Int -> SCPosition
forall a. a -> a -> V2 a
V2 (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Float -> Int) -> Float -> Int
forall a b. (a -> b) -> a -> b
$ (Integer -> Float
forall a. Num a => Integer -> a
fromInteger (Integer -> Float) -> (Int -> Integer) -> Int -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Float) -> Int -> Float
forall a b. (a -> b) -> a -> b
$ Int
sx) Float -> Float -> Float
forall a. Num a => a -> a -> a
* DCPosition
vDCPosition -> Getting Float DCPosition Float -> Float
forall s a. s -> Getting a s a -> a
^.Getting Float DCPosition Float
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x)
                         (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Float -> Int) -> Float -> Int
forall a b. (a -> b) -> a -> b
$ -((Integer -> Float
forall a. Num a => Integer -> a
fromInteger (Integer -> Float) -> (Int -> Integer) -> Int -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Float) -> Int -> Float
forall a b. (a -> b) -> a -> b
$ Int
sy) Float -> Float -> Float
forall a. Num a => a -> a -> a
* DCPosition
vDCPosition -> Getting Float DCPosition Float -> Float
forall s a. s -> Getting a s a -> a
^.Getting Float DCPosition Float
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y))

-- | 'DCVertex's which constructs line begin at 'begin' and end at 'end'
--
-- JP: 与えられた 'begin' と 'end' を両端に持つ線分を構成する 'DCVertex' を返します
rasterizeLine :: SCVertex -> SCVertex -> Vector SCVertex
rasterizeLine :: SCVertex -> SCVertex -> Vector SCVertex
rasterizeLine SCVertex
begin SCVertex
end = let begin' :: SCPosition
begin' = SCVertex
beginSCVertex -> Getting SCPosition SCVertex SCPosition -> SCPosition
forall s a. s -> Getting a s a -> a
^.Getting SCPosition SCVertex SCPosition
Lens' SCVertex SCPosition
scv_position
                              end' :: SCPosition
end' = SCVertex
endSCVertex -> Getting SCPosition SCVertex SCPosition -> SCPosition
forall s a. s -> Getting a s a -> a
^.Getting SCPosition SCVertex SCPosition
Lens' SCVertex SCPosition
scv_position
                              v :: SCPosition
v = SCPosition
end'SCPosition -> SCPosition -> SCPosition
forall a. Num a => a -> a -> a
-SCPosition
begin'
                              y :: Int -> Int
                              y :: Int -> Int
y Int
x = Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Float -> Int) -> Float -> Int
forall a b. (a -> b) -> a -> b
$ ((Rational -> Float
forall a. Fractional a => Rational -> a
fromRational (Rational -> Float) -> (Int -> Rational) -> Int -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Rational
forall a. Real a => a -> Rational
toRational (Int -> Float) -> Int -> Float
forall a b. (a -> b) -> a -> b
$ SCPosition
vSCPosition
-> ((Int -> Const Int Int) -> SCPosition -> Const Int SCPosition)
-> Int
forall s a. s -> Getting a s a -> a
^.(Int -> Const Int Int) -> SCPosition -> Const Int SCPosition
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y)
                                             Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/(Rational -> Float
forall a. Fractional a => Rational -> a
fromRational (Rational -> Float) -> (Int -> Rational) -> Int -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Rational
forall a. Real a => a -> Rational
toRational (Int -> Float) -> Int -> Float
forall a b. (a -> b) -> a -> b
$ SCPosition
vSCPosition
-> ((Int -> Const Int Int) -> SCPosition -> Const Int SCPosition)
-> Int
forall s a. s -> Getting a s a -> a
^.(Int -> Const Int Int) -> SCPosition -> Const Int SCPosition
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x :: Float))
                                    Float -> Float -> Float
forall a. Num a => a -> a -> a
*Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x
                          in (\Int
x -> SCVertex
beginSCVertex -> (SCVertex -> SCVertex) -> SCVertex
forall a b. a -> (a -> b) -> b
&(SCPosition -> Identity SCPosition)
-> SCVertex -> Identity SCVertex
Lens' SCVertex SCPosition
scv_position((SCPosition -> Identity SCPosition)
 -> SCVertex -> Identity SCVertex)
-> (SCPosition -> SCPosition) -> SCVertex -> SCVertex
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~(SCPosition -> SCPosition -> SCPosition
forall a. Num a => a -> a -> a
+ Int -> Int -> SCPosition
forall a. a -> a -> V2 a
V2 Int
x (Int -> Int
y Int
x))) (Int -> SCVertex) -> Vector Int -> Vector SCVertex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> (Int -> Int) -> Vector Int
forall a. Int -> (Int -> a) -> Vector a
V.generate (SCPosition
end'SCPosition
-> ((Int -> Const Int Int) -> SCPosition -> Const Int SCPosition)
-> Int
forall s a. s -> Getting a s a -> a
^.(Int -> Const Int Int) -> SCPosition -> Const Int SCPosition
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_xInt -> Int -> Int
forall a. Num a => a -> a -> a
-SCPosition
begin'SCPosition
-> ((Int -> Const Int Int) -> SCPosition -> Const Int SCPosition)
-> Int
forall s a. s -> Getting a s a -> a
^.(Int -> Const Int Int) -> SCPosition -> Const Int SCPosition
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) (Integer -> Int
forall a. Num a => Integer -> a
fromInteger(Integer -> Int) -> (Int -> Integer) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> Integer
forall a. Integral a => a -> Integer
toInteger)

-- | Returns 'DCVertex's that constructs one filled-triangle
--
-- Note that depth of those 'DCVertex's are not calculated properly.
-- Currently it inherits depth of 'v1'
-- I want to fix this later.
fillTriangle :: SCVertex -> SCVertex -> SCVertex -> Vector SCVertex
fillTriangle :: SCVertex -> SCVertex -> SCVertex -> Vector SCVertex
fillTriangle SCVertex
v1 SCVertex
v2 SCVertex
v3 = (SCPosition -> SCVertex -> SCVertex)
-> SCVertex -> SCPosition -> SCVertex
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((SCPosition -> Identity SCPosition)
-> SCVertex -> Identity SCVertex
Lens' SCVertex SCPosition
scv_position((SCPosition -> Identity SCPosition)
 -> SCVertex -> Identity SCVertex)
-> SCPosition -> SCVertex -> SCVertex
forall s t a b. ASetter s t a b -> b -> s -> t
.~) SCVertex
v1
                        (SCPosition -> SCVertex) -> Vector SCPosition -> Vector SCVertex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SCPosition -> Bool) -> Vector SCPosition -> Vector SCPosition
forall a. (a -> Bool) -> Vector a -> Vector a
V.filter (SCPosition -> (SCPosition, SCPosition, SCPosition) -> Bool
`isInsideOfTri` (SCVertex
v1SCVertex -> Getting SCPosition SCVertex SCPosition -> SCPosition
forall s a. s -> Getting a s a -> a
^.Getting SCPosition SCVertex SCPosition
Lens' SCVertex SCPosition
scv_position, SCVertex
v2SCVertex -> Getting SCPosition SCVertex SCPosition -> SCPosition
forall s a. s -> Getting a s a -> a
^.Getting SCPosition SCVertex SCPosition
Lens' SCVertex SCPosition
scv_position, SCVertex
v3SCVertex -> Getting SCPosition SCVertex SCPosition -> SCPosition
forall s a. s -> Getting a s a -> a
^.Getting SCPosition SCVertex SCPosition
Lens' SCVertex SCPosition
scv_position))
                        Vector SCPosition
boundaryRectVertices
  where
    maxX :: Int
maxX = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (SCVertex -> Getting Int SCVertex Int -> Int
forall s a. s -> Getting a s a -> a
^.(SCPosition -> Const Int SCPosition)
-> SCVertex -> Const Int SCVertex
Lens' SCVertex SCPosition
scv_position((SCPosition -> Const Int SCPosition)
 -> SCVertex -> Const Int SCVertex)
-> ((Int -> Const Int Int) -> SCPosition -> Const Int SCPosition)
-> Getting Int SCVertex Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const Int Int) -> SCPosition -> Const Int SCPosition
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) (SCVertex -> Int) -> [SCVertex] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SCVertex
v1, SCVertex
v2, SCVertex
v3]
    minX :: Int
minX = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (SCVertex -> Getting Int SCVertex Int -> Int
forall s a. s -> Getting a s a -> a
^.(SCPosition -> Const Int SCPosition)
-> SCVertex -> Const Int SCVertex
Lens' SCVertex SCPosition
scv_position((SCPosition -> Const Int SCPosition)
 -> SCVertex -> Const Int SCVertex)
-> ((Int -> Const Int Int) -> SCPosition -> Const Int SCPosition)
-> Getting Int SCVertex Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const Int Int) -> SCPosition -> Const Int SCPosition
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) (SCVertex -> Int) -> [SCVertex] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SCVertex
v1, SCVertex
v2, SCVertex
v3]
    maxY :: Int
maxY = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (SCVertex -> Getting Int SCVertex Int -> Int
forall s a. s -> Getting a s a -> a
^.(SCPosition -> Const Int SCPosition)
-> SCVertex -> Const Int SCVertex
Lens' SCVertex SCPosition
scv_position((SCPosition -> Const Int SCPosition)
 -> SCVertex -> Const Int SCVertex)
-> ((Int -> Const Int Int) -> SCPosition -> Const Int SCPosition)
-> Getting Int SCVertex Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const Int Int) -> SCPosition -> Const Int SCPosition
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) (SCVertex -> Int) -> [SCVertex] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SCVertex
v1, SCVertex
v2, SCVertex
v3]
    minY :: Int
minY = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (SCVertex -> Getting Int SCVertex Int -> Int
forall s a. s -> Getting a s a -> a
^.(SCPosition -> Const Int SCPosition)
-> SCVertex -> Const Int SCVertex
Lens' SCVertex SCPosition
scv_position((SCPosition -> Const Int SCPosition)
 -> SCVertex -> Const Int SCVertex)
-> ((Int -> Const Int Int) -> SCPosition -> Const Int SCPosition)
-> Getting Int SCVertex Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const Int Int) -> SCPosition -> Const Int SCPosition
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) (SCVertex -> Int) -> [SCVertex] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SCVertex
v1, SCVertex
v2, SCVertex
v3]
    boundaryRectVertices :: Vector SCPosition
boundaryRectVertices = [SCPosition] -> Vector SCPosition
forall a. [a] -> Vector a
V.fromList [Int -> Int -> SCPosition
forall a. a -> a -> V2 a
V2 Int
x Int
y | Int
x <- [Int
minX..Int
maxX]
                                              , Int
y <- [Int
minY..Int
maxY]]

-- | 'True' if given coordinate is within given Triangle
--
-- It doesn't care if the triangle is formed well.
-- (e.g. one vertex is on the line made of other two vertex, two of them are the same.)
-- This is because projection could
--
-- JP: この関数は「三角形がきちんと三角形であるか」を考慮しません。
-- (例えば: 頂点が一直線上に並んでしまっている, 複数の頂点が同じ位置にあるなど)
isInsideOfTri :: SCPosition -> (SCPosition, SCPosition, SCPosition) -> Bool
isInsideOfTri :: SCPosition -> (SCPosition, SCPosition, SCPosition) -> Bool
isInsideOfTri SCPosition
candidate (SCPosition
v1, SCPosition
v2, SCPosition
v3)
  = ((SCPosition, SCPosition, SCPosition) -> Bool)
-> [(SCPosition, SCPosition, SCPosition)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (SCPosition -> (SCPosition, SCPosition, SCPosition) -> Bool
oneLineTest SCPosition
candidate)  [(SCPosition
v1, SCPosition
v2, SCPosition
v3), (SCPosition
v2, SCPosition
v3, SCPosition
v1), (SCPosition
v3, SCPosition
v1, SCPosition
v2)]
  where
    -- | Test wether 'cand' and 'a' is at the same side of line made of vs and ve
    --
    -- JP: 'cand' と 'a' が, vs,ve を両端に持つ直線の同じ側にあるかを判定する。
    -- 同じ側にあれば, その直線と 'cand' 及び 'a' の内積の符号が等しくなる=0以上になる
    -- はずなので判定ができる。
    --
    -- TODO: Float判定をした方が精度が良い？
    oneLineTest :: V2 Int -> (V2 Int, V2 Int, V2 Int) -> Bool
    oneLineTest :: SCPosition -> (SCPosition, SCPosition, SCPosition) -> Bool
oneLineTest SCPosition
cand (SCPosition
vs, SCPosition
ve, SCPosition
a) = (SCPosition
vl SCPosition -> SCPosition -> Int
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` (SCPosition
cand SCPosition -> SCPosition -> SCPosition
forall a. Num a => a -> a -> a
- SCPosition
vs))Int -> Int -> Int
forall a. Num a => a -> a -> a
*(SCPosition
vl SCPosition -> SCPosition -> Int
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` (SCPosition
a SCPosition -> SCPosition -> SCPosition
forall a. Num a => a -> a -> a
- SCPosition
vs)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 -- 線上にある場合も含めている
      where
        -- | JP: 確かめたい対象の直線ベクトル
        line :: SCPosition
line = SCPosition
ve SCPosition -> SCPosition -> SCPosition
forall a. Num a => a -> a -> a
- SCPosition
vs
        -- | JP: 対象の線分に直交する直線ベクトル
        -- 直交する場合内積が0になる性質を利用して定義する
        vl :: SCPosition
vl = Int -> Int -> SCPosition
forall a. a -> a -> V2 a
V2 (SCPosition
lineSCPosition
-> ((Int -> Const Int Int) -> SCPosition -> Const Int SCPosition)
-> Int
forall s a. s -> Getting a s a -> a
^.(Int -> Const Int Int) -> SCPosition -> Const Int SCPosition
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) (-SCPosition
lineSCPosition
-> ((Int -> Const Int Int) -> SCPosition -> Const Int SCPosition)
-> Int
forall s a. s -> Getting a s a -> a
^.(Int -> Const Int Int) -> SCPosition -> Const Int SCPosition
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x)