{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE RecordWildCards #-}
module Graphics.SceneGraph.Visualise
  ( toDot
  , toSvg
  ) where

import qualified Data.GraphViz                   as GV
import qualified Data.GraphViz.Attributes.Colors as C
import qualified Data.GraphViz.Attributes.HTML   as H
import           Data.Maybe                      (catMaybes)
import qualified Data.Text                       as T
import qualified Data.Text.Lazy                  as LT
import           Data.Word                       (Word8)
import           Graphics.SceneGraph.Types
import           Linear                          (M44, V4 (..))


-------------------- Graph Visualisation --------------------

instance GV.Labellable (SceneNode g) where
  toLabelValue :: SceneNode g -> Label
toLabelValue (SceneNode Node
_ String
_ SceneData g
sd) = SceneData g -> Label
forall a. Labellable a => a -> Label
GV.toLabelValue SceneData g
sd

instance GV.Labellable SceneEdge where
  toLabelValue :: SceneEdge -> Label
toLabelValue SceneEdge
DefaultEdge = String -> Label
forall a. Labellable a => a -> Label
GV.toLabelValue String
""

instance GV.Labellable (SceneData g) where
  toLabelValue :: SceneData g -> Label
toLabelValue SceneData g
Group               = String -> Label
forall a. Labellable a => a -> Label
GV.toLabelValue String
"Group"
  toLabelValue (Geode Text
n g
_)         = String -> Label
forall a. Labellable a => a -> Label
GV.toLabelValue (String -> Label) -> String -> Label
forall a b. (a -> b) -> a -> b
$ String
"Geode " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
n
  toLabelValue SceneData g
LOD                 = String -> Label
forall a. Labellable a => a -> Label
GV.toLabelValue String
"LOD"
  toLabelValue (MatrixTransform M44 Float
m) = Label -> Label
forall a. Labellable a => a -> Label
GV.toLabelValue (Label -> Label) -> Label -> Label
forall a b. (a -> b) -> a -> b
$ M44 Float -> Label
matrixToHtml M44 Float
m
  toLabelValue (Switch Node
i)          = String -> Label
forall a. Labellable a => a -> Label
GV.toLabelValue (String -> Label) -> String -> Label
forall a b. (a -> b) -> a -> b
$ String
"Switch " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Node -> String
forall a. Show a => a -> String
show Node
i
  toLabelValue (Material Phong
m)        = Label -> Label
forall a. Labellable a => a -> Label
GV.toLabelValue (Label -> Label) -> Label -> Label
forall a b. (a -> b) -> a -> b
$ Phong -> Label
materialToHtml Phong
m
  toLabelValue (Handler Maybe (ClickHandler g, Sink ())
_ Maybe (DragHandler g, Sink Float)
_)       = String -> Label
forall a. Labellable a => a -> Label
GV.toLabelValue String
"Handler"
  toLabelValue SceneData g
Light               = String -> Label
forall a. Labellable a => a -> Label
GV.toLabelValue String
"Light"
  toLabelValue SceneData g
Camera              = String -> Label
forall a. Labellable a => a -> Label
GV.toLabelValue String
"Camera"
  toLabelValue (Texture String
_)         = String -> Label
forall a. Labellable a => a -> Label
GV.toLabelValue String
"Texture"
  toLabelValue (Text Text
t)            = String -> Label
forall a. Labellable a => a -> Label
GV.toLabelValue (String -> Label) -> String -> Label
forall a b. (a -> b) -> a -> b
$ String
"Text " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
t


cell :: String -> H.Cell
cell :: String -> Cell
cell String
text = Attributes -> Label -> Cell
H.LabelCell [] (Label -> Cell) -> Label -> Cell
forall a b. (a -> b) -> a -> b
$ Text -> Label
H.Text [Text -> TextItem
H.Str (Text -> TextItem) -> Text -> TextItem
forall a b. (a -> b) -> a -> b
$ String -> Text
LT.pack String
text]

colourCell :: V4 Float -> String -> H.Cell
colourCell :: V4 Float -> String -> Cell
colourCell V4 Float
col String
text = Attributes -> Label -> Cell
H.LabelCell [Color -> Attribute
H.BGColor (Color -> Attribute) -> Color -> Attribute
forall a b. (a -> b) -> a -> b
$ V4 Float -> Color
toRGB V4 Float
col] (Label -> Cell) -> Label -> Cell
forall a b. (a -> b) -> a -> b
$ Text -> Label
H.Text [Text -> TextItem
H.Str (Text -> TextItem) -> Text -> TextItem
forall a b. (a -> b) -> a -> b
$ String -> Text
LT.pack String
text]

toRGB :: V4 Float -> C.Color
toRGB :: V4 Float -> Color
toRGB (V4 Float
r Float
g Float
b Float
_) = Word8 -> Word8 -> Word8 -> Color
C.RGB (Float -> Word8
w8 Float
r) (Float -> Word8
w8 Float
g) (Float -> Word8
w8 Float
b)
  where
    w8 :: Float -> Word8
    w8 :: Float -> Word8
w8 Float
c = Float -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
round (Float -> Word8) -> Float -> Word8
forall a b. (a -> b) -> a -> b
$ Float
c Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
255

table :: [H.Row] -> H.Label
table :: [Row] -> Label
table [Row]
rows = Table -> Label
H.Table (Table -> Label) -> Table -> Label
forall a b. (a -> b) -> a -> b
$ HTable :: Maybe Attributes -> Attributes -> [Row] -> Table
H.HTable
  { tableFontAttrs :: Maybe Attributes
H.tableFontAttrs = Maybe Attributes
forall a. Maybe a
Nothing
  , tableAttrs :: Attributes
H.tableAttrs = []
  , tableRows :: [Row]
H.tableRows = [Row]
rows
  }

matrixToHtml :: M44 Float -> H.Label
matrixToHtml :: M44 Float -> Label
matrixToHtml (V4 V4 Float
a V4 Float
b V4 Float
c V4 Float
d) = Table -> Label
H.Table (Table -> Label) -> Table -> Label
forall a b. (a -> b) -> a -> b
$ HTable :: Maybe Attributes -> Attributes -> [Row] -> Table
H.HTable
  { tableFontAttrs :: Maybe Attributes
H.tableFontAttrs = Maybe Attributes
forall a. Maybe a
Nothing
  , tableAttrs :: Attributes
H.tableAttrs = []
  , tableRows :: [Row]
H.tableRows = (V4 Float -> Row) -> [V4 Float] -> [Row]
forall a b. (a -> b) -> [a] -> [b]
map ([Cell] -> Row
H.Cells ([Cell] -> Row) -> (V4 Float -> [Cell]) -> V4 Float -> Row
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V4 Float -> [Cell]
vectorToHtml) [V4 Float
a, V4 Float
b, V4 Float
c, V4 Float
d]
  }

vectorToHtml :: V4 Float -> [H.Cell]
vectorToHtml :: V4 Float -> [Cell]
vectorToHtml (V4 Float
a Float
b Float
c Float
d) = (Float -> Cell) -> [Float] -> [Cell]
forall a b. (a -> b) -> [a] -> [b]
map Float -> Cell
forall a. Show a => a -> Cell
tableCell [Float
a, Float
b, Float
c, Float
d]
  where
    tableCell :: a -> Cell
tableCell a
v = String -> Cell
cell (String -> Cell) -> String -> Cell
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
v

materialToHtml :: Phong -> H.Label
materialToHtml :: Phong -> Label
materialToHtml Phong{Maybe Float
Maybe (V4 Float)
phTransparency :: Phong -> Maybe Float
phTransparent :: Phong -> Maybe (V4 Float)
phReflectivity :: Phong -> Maybe Float
phReflective :: Phong -> Maybe (V4 Float)
phShine :: Phong -> Maybe Float
phSpecular :: Phong -> Maybe (V4 Float)
phDiffuse :: Phong -> Maybe (V4 Float)
phAmbient :: Phong -> Maybe (V4 Float)
phEmission :: Phong -> Maybe (V4 Float)
phTransparency :: Maybe Float
phTransparent :: Maybe (V4 Float)
phReflectivity :: Maybe Float
phReflective :: Maybe (V4 Float)
phShine :: Maybe Float
phSpecular :: Maybe (V4 Float)
phDiffuse :: Maybe (V4 Float)
phAmbient :: Maybe (V4 Float)
phEmission :: Maybe (V4 Float)
..} = [Row] -> Label
table [Row]
rows
  where
    colourToHtml :: String -> f (V4 Float) -> f Row
colourToHtml String
name f (V4 Float)
col = (V4 Float -> Row) -> f (V4 Float) -> f Row
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\V4 Float
v -> [Cell] -> Row
H.Cells [String -> Cell
cell String
name, Attributes -> Label -> Cell
H.LabelCell [] (Label -> Cell) -> Label -> Cell
forall a b. (a -> b) -> a -> b
$ [Row] -> Label
table [[Cell] -> Row
H.Cells ([Cell] -> Row) -> [Cell] -> Row
forall a b. (a -> b) -> a -> b
$ V4 Float -> String -> Cell
colourCell V4 Float
v String
"RGBA" Cell -> [Cell] -> [Cell]
forall a. a -> [a] -> [a]
: V4 Float -> [Cell]
vectorToHtml V4 Float
v]]) f (V4 Float)
col
    valueToHtml :: String -> f a -> f Row
valueToHtml String
name f a
val = (a -> Row) -> f a -> f Row
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
v -> [Cell] -> Row
H.Cells [String -> Cell
cell String
name, String -> Cell
cell (String -> Cell) -> String -> Cell
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
v]) f a
val

    rows :: [Row]
rows = [Maybe Row] -> [Row]
forall a. [Maybe a] -> [a]
catMaybes
      [ String -> Maybe (V4 Float) -> Maybe Row
forall (f :: * -> *). Functor f => String -> f (V4 Float) -> f Row
colourToHtml String
"Emission" Maybe (V4 Float)
phEmission
      , String -> Maybe (V4 Float) -> Maybe Row
forall (f :: * -> *). Functor f => String -> f (V4 Float) -> f Row
colourToHtml String
"Ambient" Maybe (V4 Float)
phAmbient
      , String -> Maybe (V4 Float) -> Maybe Row
forall (f :: * -> *). Functor f => String -> f (V4 Float) -> f Row
colourToHtml String
"Diffuse" Maybe (V4 Float)
phDiffuse
      , String -> Maybe (V4 Float) -> Maybe Row
forall (f :: * -> *). Functor f => String -> f (V4 Float) -> f Row
colourToHtml String
"Specular" Maybe (V4 Float)
phSpecular
      , String -> Maybe Float -> Maybe Row
forall (f :: * -> *) a.
(Functor f, Show a) =>
String -> f a -> f Row
valueToHtml String
"Shine" Maybe Float
phShine
      , String -> Maybe (V4 Float) -> Maybe Row
forall (f :: * -> *). Functor f => String -> f (V4 Float) -> f Row
colourToHtml String
"Reflective" Maybe (V4 Float)
phReflective
      , String -> Maybe Float -> Maybe Row
forall (f :: * -> *) a.
(Functor f, Show a) =>
String -> f a -> f Row
valueToHtml String
"Reflectivity" Maybe Float
phReflectivity
      , String -> Maybe (V4 Float) -> Maybe Row
forall (f :: * -> *). Functor f => String -> f (V4 Float) -> f Row
colourToHtml String
"Transparent" Maybe (V4 Float)
phTransparent
      , String -> Maybe Float -> Maybe Row
forall (f :: * -> *) a.
(Functor f, Show a) =>
String -> f a -> f Row
valueToHtml String
"Transparency" Maybe Float
phTransparency
      ]


toDot :: Scene g -> FilePath -> IO FilePath
toDot :: Scene g -> String -> IO String
toDot (Scene SceneGraph g
sg Node
_) = DotGraph Node -> GraphvizOutput -> String -> IO String
forall (dg :: * -> *) n.
PrintDotRepr dg n =>
dg n -> GraphvizOutput -> String -> IO String
GV.runGraphviz (GraphvizParams Node (SceneNode g) SceneEdge () (SceneNode g)
-> SceneGraph g -> DotGraph Node
forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Node nl el cl l -> gr nl el -> DotGraph Node
GV.graphToDot GraphvizParams Node (SceneNode g) SceneEdge () (SceneNode g)
forall nl el n.
(Labellable nl, Labellable el) =>
GraphvizParams n nl el () nl
GV.quickParams SceneGraph g
sg) GraphvizOutput
GV.Canon

toSvg :: Scene g -> FilePath -> IO FilePath
toSvg :: Scene g -> String -> IO String
toSvg (Scene SceneGraph g
sg Node
_) = DotGraph Node -> GraphvizOutput -> String -> IO String
forall (dg :: * -> *) n.
PrintDotRepr dg n =>
dg n -> GraphvizOutput -> String -> IO String
GV.runGraphviz (GraphvizParams Node (SceneNode g) SceneEdge () (SceneNode g)
-> SceneGraph g -> DotGraph Node
forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Node nl el cl l -> gr nl el -> DotGraph Node
GV.graphToDot GraphvizParams Node (SceneNode g) SceneEdge () (SceneNode g)
forall nl el n.
(Labellable nl, Labellable el) =>
GraphvizParams n nl el () nl
GV.quickParams SceneGraph g
sg) GraphvizOutput
GV.Svg