--------------------------------------------------------------------------------
-- |
-- Module      :  Utils
-- Copyright   :  (c) Vladimir Lopatin 2022
-- License     :  BSD3
--
-- Maintainer  :  Vladimir Lopatin <madjestic13@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- Utilities and helper functions for varios aspects of graphics pipeline.
--
--------------------------------------------------------------------------------


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}

module Graphics.RedViz.Utils
  ( toIdxVAO
  , toIdxVAO'
  , Graphics.RedViz.Utils.fromList
  , (<$.>)
  , (<*.>)
  , toV3
  , rotateList
  , rotateList'
  , fromUUID
  , encodeStringUUID
  ) where

import Control.Lens ( view )
import Graphics.Rendering.OpenGL as GL (GLfloat)
import Data.ByteString.Char8           (pack
                                       ,unpack)
import Data.Set                  as DS (fromList, toList)
import Data.List.Index                 (indexed)
import Data.List                       (elemIndex)
import Data.Locator
import Data.UUID                 as U
import Data.Vector               as DV (fromList, (!), map, toList)
import Data.VectorSpace          as DV
import Graphics.Rendering.OpenGL (GLuint)
import Linear.V3
import Linear.V4
import Linear.Matrix
import Linear.Metric             as LM
import System.Random

-- import Debug.Trace as DT

instance VectorSpace (V3 Double) Double where
  zeroVector :: V3 Double
zeroVector                   = (Double -> Double -> Double -> V3 Double
forall a. a -> a -> a -> V3 a
V3 Double
0 Double
0 Double
0)
  *^ :: Double -> V3 Double -> V3 Double
(*^) Double
s (V3 Double
x Double
y Double
z)            = (Double -> Double -> Double -> V3 Double
forall a. a -> a -> a -> V3 a
V3 (Double
sDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
x) (Double
sDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
y) (Double
sDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
z))
  ^+^ :: V3 Double -> V3 Double -> V3 Double
(^+^)  (V3 Double
x Double
y Double
z) (V3 Double
k Double
l Double
m) = (Double -> Double -> Double -> V3 Double
forall a. a -> a -> a -> V3 a
V3 (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
k) (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
l) (Double
zDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
m))
  dot :: V3 Double -> V3 Double -> Double
dot    (V3 Double
x Double
y Double
z) (V3 Double
k Double
l Double
m) = (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
k) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
l) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
zDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
m)

instance VectorSpace (V4 (V4 Double)) Double where
  zeroVector :: V4 (V4 Double)
zeroVector                   = V4 (V4 Double)
forall a (t :: * -> *).
(Num a, Traversable t, Applicative t) =>
t (t a)
identity :: M44 Double
  *^ :: Double -> V4 (V4 Double) -> V4 (V4 Double)
(*^) Double
s (V4 (V4 Double)
m :: M44 Double)     = V4 (V4 Double)
m V4 (V4 Double) -> Double -> V4 (V4 Double)
forall (m :: * -> *) (r :: * -> *) a.
(Functor m, Functor r, Num a) =>
m (r a) -> a -> m (r a)
!!* Double
s
  ^+^ :: V4 (V4 Double) -> V4 (V4 Double) -> V4 (V4 Double)
(^+^)  (V4 (V4 Double)
m :: M44 Double) (V4 (V4 Double)
n :: M44 Double) = 
    M33 Double -> V3 Double -> V4 (V4 Double)
forall a. Num a => M33 a -> V3 a -> M44 a
mkTransformationMat
    M33 Double
rot
    V3 Double
tr
     where
      rot :: M33 Double
rot = M33 Double -> M33 Double
forall a (f :: * -> *).
(Floating a, Metric f, Epsilon a) =>
f a -> f a
LM.normalize (M33 Double -> M33 Double) -> M33 Double -> M33 Double
forall a b. (a -> b) -> a -> b
$ (M33 Double -> M33 Double
forall a. Fractional a => M33 a -> M33 a
inv33 M33 Double
m') M33 Double -> M33 Double -> M33 Double
forall (m :: * -> *) (t :: * -> *) (n :: * -> *) a.
(Functor m, Foldable t, Additive t, Additive n, Num a) =>
m (t a) -> t (n a) -> m (n a)
!*! (M33 Double
n')
        where
          m' :: M33 Double
m' = Getting (M33 Double) (V4 (V4 Double)) (M33 Double)
-> V4 (V4 Double) -> M33 Double
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (M33 Double) (V4 (V4 Double)) (M33 Double)
forall (t :: * -> *) (v :: * -> *) a.
(Representable t, R3 t, R3 v) =>
Lens' (t (v a)) (M33 a)
_m33 V4 (V4 Double)
m
          n' :: M33 Double
n' = Getting (M33 Double) (V4 (V4 Double)) (M33 Double)
-> V4 (V4 Double) -> M33 Double
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (M33 Double) (V4 (V4 Double)) (M33 Double)
forall (t :: * -> *) (v :: * -> *) a.
(Representable t, R3 t, R3 v) =>
Lens' (t (v a)) (M33 a)
_m33 V4 (V4 Double)
n
      tr :: V3 Double
tr = (Getting (V3 Double) (V4 (V4 Double)) (V3 Double)
-> V4 (V4 Double) -> V3 Double
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (V3 Double) (V4 (V4 Double)) (V3 Double)
forall (t :: * -> *) (v :: * -> *) a.
(Representable t, R3 t, R4 v) =>
Lens' (t (v a)) (V3 a)
translation V4 (V4 Double)
m) V3 Double -> V3 Double -> V3 Double
forall v a. VectorSpace v a => v -> v -> v
^+^ (Getting (V3 Double) (V4 (V4 Double)) (V3 Double)
-> V4 (V4 Double) -> V3 Double
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (V3 Double) (V4 (V4 Double)) (V3 Double)
forall (t :: * -> *) (v :: * -> *) a.
(Representable t, R3 t, R4 v) =>
Lens' (t (v a)) (V3 a)
translation V4 (V4 Double)
n)
          
  dot :: V4 (V4 Double) -> V4 (V4 Double) -> Double
dot    (V4 (V4 Double)
m :: M44 Double) (V4 (V4 Double)
n :: M44 Double) = V4 (V4 Double) -> V4 (V4 Double) -> Double
forall v a. VectorSpace v a => v -> v -> a
DV.dot V4 (V4 Double)
m V4 (V4 Double)
n

-- | [Float]  ~= vertex
--  [[Float]] ~= VAO
toIdxVAO :: [[Float]] -> ([Int],[Float])
toIdxVAO :: [[Float]] -> ([Int], [Float])
toIdxVAO [[Float]]
vao = ([Int]
idx, [Float]
idxVAO)
  where
    iListSet :: [(Int, [Float])]
iListSet = [[Float]] -> [(Int, [Float])]
forall a. [a] -> [(Int, a)]
indexed ([[Float]] -> [(Int, [Float])]) -> [[Float]] -> [(Int, [Float])]
forall a b. (a -> b) -> a -> b
$ Set [Float] -> [[Float]]
forall a. Set a -> [a]
DS.toList (Set [Float] -> [[Float]]) -> Set [Float] -> [[Float]]
forall a b. (a -> b) -> a -> b
$ [[Float]] -> Set [Float]
forall a. Ord a => [a] -> Set a
DS.fromList ([[Float]] -> Set [Float]) -> [[Float]] -> Set [Float]
forall a b. (a -> b) -> a -> b
$ [[Float]]
vao                       :: [(Int,[Float])]
    iList :: [(Int, [Float])]
iList    = [[Float]] -> [(Int, [Float])]
forall a. [a] -> [(Int, a)]
indexed [[Float]]
vao                                                   :: [(Int, [GLfloat])]
    idx :: [Int]
idx      = ((Int, [Float]) -> Int) -> [(Int, [Float])] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, [Float]) -> Int
forall a b. (a, b) -> a
fst ([(Int, [Float])] -> [(Int, [Float])] -> [(Int, [Float])]
matchLists [(Int, [Float])]
iListSet [(Int, [Float])]
iList) :: [Int]
    idxVAO :: [Float]
idxVAO   = [[Float]] -> [Float]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Float]] -> [Float]) -> [[Float]] -> [Float]
forall a b. (a -> b) -> a -> b
$ ((Int, [Float]) -> [Float]) -> [(Int, [Float])] -> [[Float]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Int, [Float])
x -> (Int, [Float]) -> [Float]
forall a b. (a, b) -> b
snd (Int, [Float])
x) [(Int, [Float])]
iListSet                          :: [Float]

toIdxVAO' :: [[Float]] -> ([Int],[Float])
toIdxVAO' :: [[Float]] -> ([Int], [Float])
toIdxVAO' [[Float]]
vao = ([Int]
idx, [Float]
idxVAO)
  where
    --iListSet = indexed $ DS.toList $ DS.fromList $ vao                       :: [(Int,[Float])]
    iList :: [(Int, [Float])]
iList    = [[Float]] -> [(Int, [Float])]
forall a. [a] -> [(Int, a)]
indexed [[Float]]
vao                             :: [(Int, [GLfloat])]
    idx :: [Int]
idx      = ((Int, [Float]) -> Int) -> [(Int, [Float])] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, [Float]) -> Int
forall a b. (a, b) -> a
fst [(Int, [Float])]
iList :: [Int]
    idxVAO :: [Float]
idxVAO   = [[Float]] -> [Float]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Float]] -> [Float]) -> [[Float]] -> [Float]
forall a b. (a -> b) -> a -> b
$ ((Int, [Float]) -> [Float]) -> [(Int, [Float])] -> [[Float]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Int, [Float])
x -> (Int, [Float]) -> [Float]
forall a b. (a, b) -> b
snd (Int, [Float])
x) [(Int, [Float])]
iList       :: [Float]

-- | matchLists - cross-match 2 listst, replacing the elements of list2 with matching
-- |          with elements of list1, concatenating the non-matched elements.
-- |   il - indexed list
-- |  nil - non-indexed list
matchLists :: [(Int, [GLfloat])] -> [(Int, [GLfloat])] -> [(Int, [GLfloat])]
matchLists :: [(Int, [Float])] -> [(Int, [Float])] -> [(Int, [Float])]
matchLists [(Int, [Float])]
il [(Int, [Float])]
nil' =
  ((Int, [Float]) -> (Int, [Float]))
-> [(Int, [Float])] -> [(Int, [Float])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Int, [Float])] -> (Int, [Float]) -> (Int, [Float])
forall p. p -> (Int, [Float]) -> (Int, [Float])
mFunc [(Int, [Float])]
il) [(Int, [Float])]
nil' -- mFunc - matching function
  where
    -- | il      - indexed list
    -- | nile    - non indexed list element
    -- | Replaces the target element with the first match from the matching list il
    il' :: Vector (Int, [Float])
il' = [(Int, [Float])] -> Vector (Int, [Float])
forall a. [a] -> Vector a
DV.fromList [(Int, [Float])]
il
    cxs' :: Vector [Float]
cxs'  = ((Int, [Float]) -> [Float])
-> Vector (Int, [Float]) -> Vector [Float]
forall a b. (a -> b) -> Vector a -> Vector b
DV.map (Int, [Float]) -> [Float]
forall a b. (a, b) -> b
snd Vector (Int, [Float])
il'
    mFunc :: p -> (Int, [Float]) -> (Int, [Float])
mFunc p
_ (Int
iy, [Float]
cy) =
      (\case
          Just Int
idx -> Vector (Int, [Float])
il' Vector (Int, [Float]) -> Int -> (Int, [Float])
forall a. Vector a -> Int -> a
! Int
idx
          Maybe Int
Nothing  -> (-Int
iy, [Float]
cy) ) Maybe Int
nili      -- if a unique index idx found - flip the sign
                                            -- the idea idx to separate normal indexes
                                            -- and unique indexes -> [idx:uidx] later
      where
        nili :: Maybe Int
nili = [Float] -> [[Float]] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex [Float]
cy (Vector [Float] -> [[Float]]
forall a. Vector a -> [a]
DV.toList Vector [Float]
cxs')
        -- cxs  = DV.map (\(i,s) -> s) il' -- :: [[GLfloat]]

-- TODO: create a fromList typeclass?
-- [a] -> V3 a
-- [a] -> M44 a
-- etc.
fromList :: [Float] -> M44 Double
fromList :: [Float] -> V4 (V4 Double)
fromList [Float]
xs' = V4 Double -> V4 Double -> V4 Double -> V4 Double -> V4 (V4 Double)
forall a. a -> a -> a -> a -> V4 a
V4 V4 Double
x V4 Double
y V4 Double
z V4 Double
w
  where
    x :: V4 Double
x  = Double -> Double -> Double -> Double -> V4 Double
forall a. a -> a -> a -> a -> V4 a
V4 ([Double]
xs[Double] -> Int -> Double
forall a. [a] -> Int -> a
!!Int
0 ) ([Double]
xs[Double] -> Int -> Double
forall a. [a] -> Int -> a
!!Int
1 ) ([Double]
xs[Double] -> Int -> Double
forall a. [a] -> Int -> a
!!Int
2 ) ([Double]
xs[Double] -> Int -> Double
forall a. [a] -> Int -> a
!!Int
3 ) 
    y :: V4 Double
y  = Double -> Double -> Double -> Double -> V4 Double
forall a. a -> a -> a -> a -> V4 a
V4 ([Double]
xs[Double] -> Int -> Double
forall a. [a] -> Int -> a
!!Int
4 ) ([Double]
xs[Double] -> Int -> Double
forall a. [a] -> Int -> a
!!Int
5 ) ([Double]
xs[Double] -> Int -> Double
forall a. [a] -> Int -> a
!!Int
6 ) ([Double]
xs[Double] -> Int -> Double
forall a. [a] -> Int -> a
!!Int
7 ) 
    z :: V4 Double
z  = Double -> Double -> Double -> Double -> V4 Double
forall a. a -> a -> a -> a -> V4 a
V4 ([Double]
xs[Double] -> Int -> Double
forall a. [a] -> Int -> a
!!Int
8 ) ([Double]
xs[Double] -> Int -> Double
forall a. [a] -> Int -> a
!!Int
9 ) ([Double]
xs[Double] -> Int -> Double
forall a. [a] -> Int -> a
!!Int
10) ([Double]
xs[Double] -> Int -> Double
forall a. [a] -> Int -> a
!!Int
11) 
    w :: V4 Double
w  = Double -> Double -> Double -> Double -> V4 Double
forall a. a -> a -> a -> a -> V4 a
V4 ([Double]
xs[Double] -> Int -> Double
forall a. [a] -> Int -> a
!!Int
12) ([Double]
xs[Double] -> Int -> Double
forall a. [a] -> Int -> a
!!Int
13) ([Double]
xs[Double] -> Int -> Double
forall a. [a] -> Int -> a
!!Int
14) ([Double]
xs[Double] -> Int -> Double
forall a. [a] -> Int -> a
!!Int
15)
    xs :: [Double]
xs = (Float -> Double) -> [Float] -> [Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac [Float]
xs' :: [Double]

(<$.>) :: (a -> b) -> [a] -> [b]
<$.> :: (a -> b) -> [a] -> [b]
(<$.>) = (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

(<*.>) :: [a -> b] -> [a] -> [b]
<*.> :: [a -> b] -> [a] -> [b]
(<*.>) = ((a -> b) -> a -> b) -> [a -> b] -> [a] -> [b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($)

toV3 :: [a] -> V3 a
toV3 :: [a] -> V3 a
toV3 [a]
xs = a -> a -> a -> V3 a
forall a. a -> a -> a -> V3 a
V3 ([a] -> a
forall a. [a] -> a
head [a]
xs) ([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!Int
1) ([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!Int
2)

rotateList :: Int -> [a] -> [a]
rotateList :: Int -> [a] -> [a]
rotateList Int
_ [] = []
rotateList Int
n [a]
xs = (a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> a
forall a b. a -> b -> a
const (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
n ([a] -> [a]
forall a. [a] -> [a]
cycle [a]
xs)) [a]
xs

rotateList' :: (Int, [a]) -> [a]
rotateList' :: (Int, [a]) -> [a]
rotateList' (Int
_, []) = []
rotateList' (Int
n, [a]
xs) = (a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> a
forall a b. a -> b -> a
const (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
n ([a] -> [a]
forall a. [a] -> [a]
cycle [a]
xs)) [a]
xs

fromUUID :: UUID -> GLuint
fromUUID :: UUID -> GLuint
fromUUID = String -> GLuint
forall a. Read a => String -> a
read (String -> GLuint) -> (UUID -> String) -> UUID -> GLuint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> String) -> [Integer] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Integer -> String
forall a. Show a => a -> String
show ([Integer] -> String) -> (UUID -> [Integer]) -> UUID -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ (GLuint
x,GLuint
y,GLuint
z,GLuint
w)-> (GLuint -> Integer) -> [GLuint] -> [Integer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GLuint -> Integer
forall a. Integral a => a -> Integer
toInteger [GLuint
x,GLuint
y,GLuint
z,GLuint
w]) ((GLuint, GLuint, GLuint, GLuint) -> [Integer])
-> (UUID -> (GLuint, GLuint, GLuint, GLuint)) -> UUID -> [Integer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> (GLuint, GLuint, GLuint, GLuint)
toWords

-- | Generate a UUID, based on FilePath
-- | e.g. fromUUID $ encodeStringUUID "./projects/.temp1"
-- | > 2836415114
encodeStringUUID :: String -> UUID
encodeStringUUID :: String -> UUID
encodeStringUUID String
x = Int -> UUID
genSeedUUID (Int -> UUID) -> (ByteString -> Int) -> ByteString -> UUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> (ByteString -> Integer) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Integer
fromBase62 (String -> Integer)
-> (ByteString -> String) -> ByteString -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
unpack (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
hashStringToBase62 Int
6 (ByteString -> UUID) -> ByteString -> UUID
forall a b. (a -> b) -> a -> b
$ String -> ByteString
pack String
x

encodeStringInteger :: String -> Integer
encodeStringInteger :: String -> Integer
encodeStringInteger String
x = String -> Integer
fromBase62 (String -> Integer)
-> (ByteString -> String) -> ByteString -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
unpack (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
hashStringToBase62 Int
1 (ByteString -> Integer) -> ByteString -> Integer
forall a b. (a -> b) -> a -> b
$ String -> ByteString
pack String
x

genSeedUUID :: Int -> UUID
genSeedUUID :: Int -> UUID
genSeedUUID Int
seed =
  let
      g0 :: StdGen
g0      = Int -> StdGen
mkStdGen Int
seed -- RNG from seed
      (UUID
u1, StdGen
_) = StdGen -> (UUID, StdGen)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random StdGen
g0
  in UUID
u1