{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Graphics.SceneGraph.Types where

import           Data.Default         (Default (..))
import           Data.Graph.Inductive (Node, (&))
import qualified Data.Graph.Inductive as G
import qualified Data.Text            as T
import           Linear               (M44, V2 (..), V3 (..), V4 (..))


-- | Scene Graph based on a Graph
type SceneGraph g = G.Gr (SceneNode g) SceneEdge

-- | Empty edge label for scene graphs.
data SceneEdge = DefaultEdge
  deriving (SceneEdge -> SceneEdge -> Bool
(SceneEdge -> SceneEdge -> Bool)
-> (SceneEdge -> SceneEdge -> Bool) -> Eq SceneEdge
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SceneEdge -> SceneEdge -> Bool
$c/= :: SceneEdge -> SceneEdge -> Bool
== :: SceneEdge -> SceneEdge -> Bool
$c== :: SceneEdge -> SceneEdge -> Bool
Eq, Eq SceneEdge
Eq SceneEdge
-> (SceneEdge -> SceneEdge -> Ordering)
-> (SceneEdge -> SceneEdge -> Bool)
-> (SceneEdge -> SceneEdge -> Bool)
-> (SceneEdge -> SceneEdge -> Bool)
-> (SceneEdge -> SceneEdge -> Bool)
-> (SceneEdge -> SceneEdge -> SceneEdge)
-> (SceneEdge -> SceneEdge -> SceneEdge)
-> Ord SceneEdge
SceneEdge -> SceneEdge -> Bool
SceneEdge -> SceneEdge -> Ordering
SceneEdge -> SceneEdge -> SceneEdge
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SceneEdge -> SceneEdge -> SceneEdge
$cmin :: SceneEdge -> SceneEdge -> SceneEdge
max :: SceneEdge -> SceneEdge -> SceneEdge
$cmax :: SceneEdge -> SceneEdge -> SceneEdge
>= :: SceneEdge -> SceneEdge -> Bool
$c>= :: SceneEdge -> SceneEdge -> Bool
> :: SceneEdge -> SceneEdge -> Bool
$c> :: SceneEdge -> SceneEdge -> Bool
<= :: SceneEdge -> SceneEdge -> Bool
$c<= :: SceneEdge -> SceneEdge -> Bool
< :: SceneEdge -> SceneEdge -> Bool
$c< :: SceneEdge -> SceneEdge -> Bool
compare :: SceneEdge -> SceneEdge -> Ordering
$ccompare :: SceneEdge -> SceneEdge -> Ordering
$cp1Ord :: Eq SceneEdge
Ord)

instance Show SceneEdge where
  show :: SceneEdge -> String
show = String -> SceneEdge -> String
forall a b. a -> b -> a
const String
"()"

-- | Scene Node. Made up of data and maybe a widget
data SceneNode g = SceneNode
  { SceneNode g -> Int
nodeId    :: Node
  , SceneNode g -> String
nodeLabel :: String
  , SceneNode g -> SceneData g
nodeData  :: SceneData g
  }
  deriving (Int -> SceneNode g -> ShowS
[SceneNode g] -> ShowS
SceneNode g -> String
(Int -> SceneNode g -> ShowS)
-> (SceneNode g -> String)
-> ([SceneNode g] -> ShowS)
-> Show (SceneNode g)
forall g. Int -> SceneNode g -> ShowS
forall g. [SceneNode g] -> ShowS
forall g. SceneNode g -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SceneNode g] -> ShowS
$cshowList :: forall g. [SceneNode g] -> ShowS
show :: SceneNode g -> String
$cshow :: forall g. SceneNode g -> String
showsPrec :: Int -> SceneNode g -> ShowS
$cshowsPrec :: forall g. Int -> SceneNode g -> ShowS
Show)

-- | Creates an empty scene graph
nullNode :: Node -> SceneNode g
nullNode :: Int -> SceneNode g
nullNode Int
n = Int -> String -> SceneData g -> SceneNode g
forall g. Int -> String -> SceneData g -> SceneNode g
SceneNode Int
n (Int -> String
forall a. Show a => a -> String
show Int
n) SceneData g
forall g. SceneData g
Group

-- | Creates a scene graph containing the supplied node
trivialGr :: SceneNode g -> SceneGraph g
trivialGr :: SceneNode g -> SceneGraph g
trivialGr SceneNode g
n = ([], Int
1, SceneNode g
n, []) Context (SceneNode g) SceneEdge -> SceneGraph g -> SceneGraph g
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& SceneGraph g
forall (gr :: * -> * -> *) a b. Graph gr => gr a b
G.empty

-- | Scene Graph with indicate root node
data Scene g = Scene
  { Scene g -> SceneGraph g
sceneGraph :: SceneGraph g
  , Scene g -> Int
sceneRoot  :: Node
  }

-- | View port refers to a camera node and has its own Scene which is drawn flattened
data Viewport g = Viewport
  { Viewport g -> Int
viewCamera :: Node
  , Viewport g -> Scene g
viewScene  :: Scene g
  }

-- | A scene with a number of view ports looking onto it.
data World g = World
  { World g -> Scene g
worldScene     :: Scene g
  , World g -> [Viewport g]
worldViewports :: [Viewport g]
  }

instance Eq (SceneNode g) where
  (SceneNode Int
id1 String
lbl1 SceneData g
_) == :: SceneNode g -> SceneNode g -> Bool
== (SceneNode Int
id2 String
lbl2 SceneData g
_) = Int
id1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
id2 Bool -> Bool -> Bool
&& String
lbl1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
lbl2

data KeyState
  = Up
  | Down
  deriving (KeyState -> KeyState -> Bool
(KeyState -> KeyState -> Bool)
-> (KeyState -> KeyState -> Bool) -> Eq KeyState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyState -> KeyState -> Bool
$c/= :: KeyState -> KeyState -> Bool
== :: KeyState -> KeyState -> Bool
$c== :: KeyState -> KeyState -> Bool
Eq, Int -> KeyState -> ShowS
[KeyState] -> ShowS
KeyState -> String
(Int -> KeyState -> ShowS)
-> (KeyState -> String) -> ([KeyState] -> ShowS) -> Show KeyState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyState] -> ShowS
$cshowList :: [KeyState] -> ShowS
show :: KeyState -> String
$cshow :: KeyState -> String
showsPrec :: Int -> KeyState -> ShowS
$cshowsPrec :: Int -> KeyState -> ShowS
Show)

type ClickHandler g = Scene g -> KeyState -> IO (SceneGraph g)
type DragHandler g = Scene g -> V3 Float -> IO (SceneGraph g, Float)

instance Show (ClickHandler g) where
  show :: ClickHandler g -> String
show ClickHandler g
_ = String
"<a ClickHandler>"

instance Show (DragHandler g) where
  show :: DragHandler g -> String
show DragHandler g
_ = String
"<a DragHandler>"

type Sink a = a -> IO ()

-- | Scene Node Data.
data SceneData g
  = Group
  | Geode T.Text g
  | LOD
  | MatrixTransform (M44 Float)
  | Switch Int
  | Material Phong
  | Handler (Maybe (ClickHandler g, Sink ())) (Maybe (DragHandler g, Sink Float))
  | Light
  | Camera
  | Texture FilePath
  | Text T.Text

instance Show (SceneData g) where
  show :: SceneData g -> String
show SceneData g
Group               = String
"Group"
  show (Geode Text
n g
_)         = String
"Geode " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
n
  show SceneData g
LOD                 = String
"LOD"
  show (MatrixTransform M44 Float
_) = String
"MatrixTransform"
  show (Switch Int
i)          = String
"Switch " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
  show (Material Phong
_)        = String
"Material"
  show (Handler Maybe (ClickHandler g, Sink ())
_ Maybe (DragHandler g, Sink Float)
_)       = String
"Handler"
  show SceneData g
Light               = String
"Light"
  show SceneData g
Camera              = String
"Camera"
  show (Texture String
_)         = String
"Texture"
  show (Text Text
t)            = String
"Text " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
t

-- | Geometry. Either a basic GL object or a mesh.
--
data Geometry
  = Mesh2D [V2 Float]
  | Mesh3D [(V3 Float, V3 Float)]
  deriving (Geometry -> Geometry -> Bool
(Geometry -> Geometry -> Bool)
-> (Geometry -> Geometry -> Bool) -> Eq Geometry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Geometry -> Geometry -> Bool
$c/= :: Geometry -> Geometry -> Bool
== :: Geometry -> Geometry -> Bool
$c== :: Geometry -> Geometry -> Bool
Eq, Int -> Geometry -> ShowS
[Geometry] -> ShowS
Geometry -> String
(Int -> Geometry -> ShowS)
-> (Geometry -> String) -> ([Geometry] -> ShowS) -> Show Geometry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Geometry] -> ShowS
$cshowList :: [Geometry] -> ShowS
show :: Geometry -> String
$cshow :: Geometry -> String
showsPrec :: Int -> Geometry -> ShowS
$cshowsPrec :: Int -> Geometry -> ShowS
Show)

-- | Simple colors
data Color
  = Grey
  | JustWhite
  | Red
  | Green
  | Blue
  | Black
  | LightBlue
  | White
  | Yellow
  deriving (Int -> Color -> ShowS
[Color] -> ShowS
Color -> String
(Int -> Color -> ShowS)
-> (Color -> String) -> ([Color] -> ShowS) -> Show Color
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Color] -> ShowS
$cshowList :: [Color] -> ShowS
show :: Color -> String
$cshow :: Color -> String
showsPrec :: Int -> Color -> ShowS
$cshowsPrec :: Int -> Color -> ShowS
Show, Color -> Color -> Bool
(Color -> Color -> Bool) -> (Color -> Color -> Bool) -> Eq Color
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Color -> Color -> Bool
$c/= :: Color -> Color -> Bool
== :: Color -> Color -> Bool
$c== :: Color -> Color -> Bool
Eq)

mapColor :: Color -> V4 Float
mapColor :: Color -> V4 Float
mapColor Color
Red       = Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
1 Float
0 Float
0 Float
1
mapColor Color
Green     = Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
0 Float
1 Float
0 Float
1
mapColor Color
Blue      = Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
0 Float
0 Float
1 Float
1
mapColor Color
Grey      = Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
0.4 Float
0.4 Float
0.4 Float
1
mapColor Color
LightBlue = Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
0.3 Float
0.3 Float
1.0 Float
1
mapColor Color
Black     = Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
0 Float
0 Float
0 Float
1
mapColor Color
White     = Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
1 Float
1 Float
1 Float
1
mapColor Color
Yellow    = Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
1 Float
1 Float
0 Float
1
mapColor Color
JustWhite = Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
0.9 Float
0.9 Float
0.9 Float
1

-- | Phong lighting
data Phong = Phong
  { Phong -> Maybe (V4 Float)
phEmission     :: Maybe (V4 Float)
  , Phong -> Maybe (V4 Float)
phAmbient      :: Maybe (V4 Float)
  , Phong -> Maybe (V4 Float)
phDiffuse      :: Maybe (V4 Float)
  , Phong -> Maybe (V4 Float)
phSpecular     :: Maybe (V4 Float)
  , Phong -> Maybe Float
phShine        :: Maybe Float
  , Phong -> Maybe (V4 Float)
phReflective   :: Maybe (V4 Float)
  , Phong -> Maybe Float
phReflectivity :: Maybe Float
  , Phong -> Maybe (V4 Float)
phTransparent  :: Maybe (V4 Float)
  , Phong -> Maybe Float
phTransparency :: Maybe Float
  }
  deriving (Phong -> Phong -> Bool
(Phong -> Phong -> Bool) -> (Phong -> Phong -> Bool) -> Eq Phong
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Phong -> Phong -> Bool
$c/= :: Phong -> Phong -> Bool
== :: Phong -> Phong -> Bool
$c== :: Phong -> Phong -> Bool
Eq, Int -> Phong -> ShowS
[Phong] -> ShowS
Phong -> String
(Int -> Phong -> ShowS)
-> (Phong -> String) -> ([Phong] -> ShowS) -> Show Phong
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Phong] -> ShowS
$cshowList :: [Phong] -> ShowS
show :: Phong -> String
$cshow :: Phong -> String
showsPrec :: Int -> Phong -> ShowS
$cshowsPrec :: Int -> Phong -> ShowS
Show)

instance Default Phong where
  def :: Phong
def = Maybe (V4 Float)
-> Maybe (V4 Float)
-> Maybe (V4 Float)
-> Maybe (V4 Float)
-> Maybe Float
-> Maybe (V4 Float)
-> Maybe Float
-> Maybe (V4 Float)
-> Maybe Float
-> Phong
Phong Maybe (V4 Float)
forall a. Maybe a
Nothing Maybe (V4 Float)
forall a. Maybe a
Nothing Maybe (V4 Float)
forall a. Maybe a
Nothing Maybe (V4 Float)
forall a. Maybe a
Nothing Maybe Float
forall a. Maybe a
Nothing Maybe (V4 Float)
forall a. Maybe a
Nothing Maybe Float
forall a. Maybe a
Nothing Maybe (V4 Float)
forall a. Maybe a
Nothing Maybe Float
forall a. Maybe a
Nothing

-- | Convert from simple color to Phong
colorToPhong :: Color -> Phong
colorToPhong :: Color -> Phong
colorToPhong Color
c = Phong
forall a. Default a => a
def
  { phDiffuse :: Maybe (V4 Float)
phDiffuse = V4 Float -> Maybe (V4 Float)
forall a. a -> Maybe a
Just (V4 Float -> Maybe (V4 Float)) -> V4 Float -> Maybe (V4 Float)
forall a b. (a -> b) -> a -> b
$ Color -> V4 Float
mapColor Color
c
  , phAmbient :: Maybe (V4 Float)
phAmbient = V4 Float -> Maybe (V4 Float)
forall a. a -> Maybe a
Just (V4 Float -> Maybe (V4 Float)) -> V4 Float -> Maybe (V4 Float)
forall a b. (a -> b) -> a -> b
$ Color -> V4 Float
mapColor Color
c
  , phSpecular :: Maybe (V4 Float)
phSpecular = V4 Float -> Maybe (V4 Float)
forall a. a -> Maybe a
Just (V4 Float -> Maybe (V4 Float)) -> V4 Float -> Maybe (V4 Float)
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
0.4 Float
0.4 Float
0.4 Float
1.0
  , phShine :: Maybe Float
phShine = Float -> Maybe Float
forall a. a -> Maybe a
Just Float
5.0
  }


llab :: SceneGraph g -> Node -> SceneNode g
llab :: SceneGraph g -> Int -> SceneNode g
llab SceneGraph g
gr Int
n =
  case SceneGraph g -> Int -> Maybe (SceneNode g)
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
G.lab SceneGraph g
gr Int
n of
    Maybe (SceneNode g)
Nothing -> String -> SceneNode g
forall a. HasCallStack => String -> a
error (String -> SceneNode g) -> String -> SceneNode g
forall a b. (a -> b) -> a -> b
$ String
"Should not happen gr=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SceneGraph g -> String
forall a. Show a => a -> String
show SceneGraph g
gr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"n = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
    Just SceneNode g
n' -> SceneNode g
n'