{-# LANGUAGE TemplateHaskell #-}

module Graphics.RedViz.Project.Project 
  ( Project  (..)
  , ProjectCamera (..)
  , pTransform
  , pApt
  , pFoc
  , pMouseS
  , pKeyboardRS
  , pKeyboardTS
  , Model    (..)
  , name
  , resx
  , resy
  , camMode
  , models
  , objects
  , background
  , PreObject (..)
  , pname
  , modelIDXs
  , uuid 
  , solvers
  , solverAttrs
  , fonts
  , cameras
  , Graphics.RedViz.Project.Project.read
  , write
  , defaultProject
  ) where

import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import Data.Aeson.Encode.Pretty
import Data.ByteString.Lazy as B hiding (drop, pack)
import Data.Maybe                       (fromMaybe)
import Data.Sort                        (sortOn)                              
import Data.Text ( Text, pack )
import Data.UUID

import Graphics.RedViz.Project.Model
-- import Graphics.RedViz.Camera

-- import Debug.Trace as DT

data PreObject
  =  PreObject
     {
       PreObject -> String
_pname       :: String
     , PreObject -> UUID
_uuid        :: UUID
     , PreObject -> [Int]
_modelIDXs   :: [Int]
     , PreObject -> [String]
_solvers     :: [String]
     , PreObject -> [[Double]]
_solverAttrs :: [[Double]]
     } deriving Int -> PreObject -> ShowS
[PreObject] -> ShowS
PreObject -> String
(Int -> PreObject -> ShowS)
-> (PreObject -> String)
-> ([PreObject] -> ShowS)
-> Show PreObject
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PreObject] -> ShowS
$cshowList :: [PreObject] -> ShowS
show :: PreObject -> String
$cshow :: PreObject -> String
showsPrec :: Int -> PreObject -> ShowS
$cshowsPrec :: Int -> PreObject -> ShowS
Show

$(makeLenses ''PreObject)
deriveJSON defaultOptions {fieldLabelModifier = drop 1} ''PreObject

data ProjectCamera
  =  ProjectCamera
     { ProjectCamera -> String
_pcname      :: String
     , ProjectCamera -> Double
_pApt        :: Double
     , ProjectCamera -> Double
_pFoc        :: Double
     , ProjectCamera -> [Float]
_pTransform  :: [Float]
     , ProjectCamera -> Double
_pMouseS     :: Double -- | mouse    "sensitivity"
     , ProjectCamera -> Double
_pKeyboardRS :: Double -- | keyboard "sensitivity"
     , ProjectCamera -> Double
_pKeyboardTS :: Double
     } deriving Int -> ProjectCamera -> ShowS
[ProjectCamera] -> ShowS
ProjectCamera -> String
(Int -> ProjectCamera -> ShowS)
-> (ProjectCamera -> String)
-> ([ProjectCamera] -> ShowS)
-> Show ProjectCamera
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProjectCamera] -> ShowS
$cshowList :: [ProjectCamera] -> ShowS
show :: ProjectCamera -> String
$cshow :: ProjectCamera -> String
showsPrec :: Int -> ProjectCamera -> ShowS
$cshowsPrec :: Int -> ProjectCamera -> ShowS
Show
$(makeLenses ''ProjectCamera)
deriveJSON defaultOptions {fieldLabelModifier = drop 1} ''ProjectCamera

data Project
  =  Project
     {
       Project -> String
_name       :: String
     , Project -> Int
_resx       :: Int
     , Project -> Int
_resy       :: Int
     , Project -> String
_camMode    :: String
     , Project -> [Model]
_models     :: [Model] -- is that used?
     , Project -> [PreObject]
_objects    :: [PreObject]
     , Project -> [PreObject]
_background :: [PreObject]
     , Project -> [Model]
_fonts      :: [Model]
     , Project -> [ProjectCamera]
_cameras    :: [ProjectCamera]
     } deriving Int -> Project -> ShowS
[Project] -> ShowS
Project -> String
(Int -> Project -> ShowS)
-> (Project -> String) -> ([Project] -> ShowS) -> Show Project
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Project] -> ShowS
$cshowList :: [Project] -> ShowS
show :: Project -> String
$cshow :: Project -> String
showsPrec :: Int -> Project -> ShowS
$cshowsPrec :: Int -> Project -> ShowS
Show
$(makeLenses ''Project)
deriveJSON defaultOptions {fieldLabelModifier = drop 1} ''Project

emptyProject :: Project
emptyProject :: Project
emptyProject =
  String
-> Int
-> Int
-> String
-> [Model]
-> [PreObject]
-> [PreObject]
-> [Model]
-> [ProjectCamera]
-> Project
Project String
"foobar" (-Int
1) (-Int
1) String
"AbsoluteLocation" [] [] [] [] []

defaultProject :: Project
defaultProject :: Project
defaultProject =
  String
-> Int
-> Int
-> String
-> [Model]
-> [PreObject]
-> [PreObject]
-> [Model]
-> [ProjectCamera]
-> Project
Project
  String
"Test Project"
  Int
800
  Int
600
  String
"AbsoluteLocation"
  [ (String -> Model
Model   String
"models/box.bgeo")]
  [ (String -> UUID -> [Int] -> [String] -> [[Double]] -> PreObject
PreObject
    String
"Box"
    UUID
nil
    [Int
0]
    [String
"rotate", String
"translate"]
    [[Double
0,Double
0,Double
0,Double
0,Double
0,Double
1000]
    ,[Double
1000,Double
0,Double
0]]
    )
  ]
  []
  [(String -> Model
Model   String
"models/fnt_0.bgeo")
  ,(String -> Model
Model   String
"models/fnt_1.bgeo")
  ,(String -> Model
Model   String
"models/fnt_2.bgeo")
  ,(String -> Model
Model   String
"models/fnt_3.bgeo")
  ,(String -> Model
Model   String
"models/fnt_4.bgeo")
  ,(String -> Model
Model   String
"models/fnt_5.bgeo")
  ,(String -> Model
Model   String
"models/fnt_6.bgeo")
  ,(String -> Model
Model   String
"models/fnt_7.bgeo")
  ,(String -> Model
Model   String
"models/fnt_8.bgeo")
  ,(String -> Model
Model   String
"models/fnt_9.bgeo")
  ,(String -> Model
Model   String
"models/fnt_a.bgeo")
  ,(String -> Model
Model   String
"models/fnt_b.bgeo")
  ,(String -> Model
Model   String
"models/fnt_c.bgeo")
  ,(String -> Model
Model   String
"models/fnt_d.bgeo")
  ,(String -> Model
Model   String
"models/fnt_e.bgeo")
  ,(String -> Model
Model   String
"models/fnt_f.bgeo")
  ,(String -> Model
Model   String
"models/fnt_g.bgeo")
  ,(String -> Model
Model   String
"models/fnt_h.bgeo")
  ,(String -> Model
Model   String
"models/fnt_i.bgeo")
  ,(String -> Model
Model   String
"models/fnt_j.bgeo")
  ,(String -> Model
Model   String
"models/fnt_k.bgeo")
  ,(String -> Model
Model   String
"models/fnt_l.bgeo")
  ,(String -> Model
Model   String
"models/fnt_m.bgeo")
  ,(String -> Model
Model   String
"models/fnt_n.bgeo")
  ,(String -> Model
Model   String
"models/fnt_o.bgeo")
  ,(String -> Model
Model   String
"models/fnt_p.bgeo")
  ,(String -> Model
Model   String
"models/fnt_q.bgeo")
  ,(String -> Model
Model   String
"models/fnt_r.bgeo")
  ,(String -> Model
Model   String
"models/fnt_s.bgeo")
  ,(String -> Model
Model   String
"models/fnt_t.bgeo")
  ,(String -> Model
Model   String
"models/fnt_u.bgeo")
  ,(String -> Model
Model   String
"models/fnt_v.bgeo")
  ,(String -> Model
Model   String
"models/fnt_w.bgeo")
  ,(String -> Model
Model   String
"models/fnt_x.bgeo")
  ,(String -> Model
Model   String
"models/fnt_y.bgeo")
  ,(String -> Model
Model   String
"models/fnt_z.bgeo")
  ,(String -> Model
Model   String
"models/fnt_plus.bgeo")
  ,(String -> Model
Model   String
"models/fnt_minus.bgeo")
  ,(String -> Model
Model   String
"models/fnt_equal.bgeo")
  ,(String -> Model
Model   String
"models/fnt_GT.bgeo")
  ,(String -> Model
Model   String
"models/fnt_comma.bgeo")
  ,(String -> Model
Model   String
"models/fnt_dot.bgeo")
  ,(String -> Model
Model   String
"models/fnt_question.bgeo")
  ,(String -> Model
Model   String
"models/fnt_exclam.bgeo")
  ,(String -> Model
Model   String
"models/fnt_space.bgeo")
  ,(String -> Model
Model   String
"models/fnt_asterics.bgeo")
  ,(String -> Model
Model   String
"models/fnt_slash.bgeo")
  ,(String -> Model
Model   String
"models/fnt_semicolon.bgeo")
  ,(String -> Model
Model   String
"models/fnt_quote.bgeo")  
  ]
  [(String
-> Double
-> Double
-> [Float]
-> Double
-> Double
-> Double
-> ProjectCamera
ProjectCamera
    String
"PlayerCamera"
    Double
50.0
    Double
100.0
    [Float
1, Float
0, Float
0, Float
0,
     Float
0, Float
1, Float
0, Float
0,
     Float
0, Float
0, Float
1,-Float
10,
     Float
0, Float
0, Float
0, Float
1])
    Double
1.0
    Double
1.0
    Double
1.0
  ]

write :: Project -> FilePath -> IO ()
write :: Project -> String -> IO ()
write Project
prj String
fileOut =
  String -> ByteString -> IO ()
B.writeFile String
fileOut (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Config -> Project -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
encodePretty' Config
config Project
prj
  where
    config :: Config
config = Config
defConfig { confCompare :: Text -> Text -> Ordering
confCompare = Text -> Text -> Ordering
comp }

comp :: Text -> Text -> Ordering
comp :: Text -> Text -> Ordering
comp = [Text] -> Text -> Text -> Ordering
keyOrder ([Text] -> Text -> Text -> Ordering)
-> ([String] -> [Text]) -> [String] -> Text -> Text -> Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
pack) ([String] -> Text -> Text -> Ordering)
-> [String] -> Text -> Text -> Ordering
forall a b. (a -> b) -> a -> b
$ [String
"name", String
"resx", String
"resy", String
"camMode", String
"models", String
"objects", String
"background", String
"pname", String
"uuid ", String
"modelIDXs", String
"solvers", String
"solverAttrs", String
"fonts", String
"cameras", String
"pApt", String
"pFoc", String
"pTransform", String
"pMouseS", String
"pKeyboardRS", String
"pKeyboardTS"]

read :: FilePath -> IO Project
read :: String -> IO Project
read String
filePath =
  do
    Either String Project
d <- (ByteString -> Either String Project
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String Project)
-> IO ByteString -> IO (Either String Project)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
filePath) :: IO (Either String Project)
    let name' :: String
name'     = (Project -> String
_name     (Project -> String)
-> (Either String Project -> Project)
-> Either String Project
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String Project -> Project
forall a. Either a Project -> Project
fromEitherDecode) Either String Project
d
        resx' :: Int
resx'     = (Project -> Int
_resx     (Project -> Int)
-> (Either String Project -> Project)
-> Either String Project
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String Project -> Project
forall a. Either a Project -> Project
fromEitherDecode) Either String Project
d
        resy' :: Int
resy'     = (Project -> Int
_resy     (Project -> Int)
-> (Either String Project -> Project)
-> Either String Project
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String Project -> Project
forall a. Either a Project -> Project
fromEitherDecode) Either String Project
d
        camMode' :: String
camMode'  = (Project -> String
_camMode  (Project -> String)
-> (Either String Project -> Project)
-> Either String Project
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String Project -> Project
forall a. Either a Project -> Project
fromEitherDecode) Either String Project
d
        models' :: [Model]
models'   = (Project -> [Model]
_models   (Project -> [Model])
-> (Either String Project -> Project)
-> Either String Project
-> [Model]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String Project -> Project
forall a. Either a Project -> Project
fromEitherDecode) Either String Project
d
        preObjs' :: [PreObject]
preObjs'  = (Project -> [PreObject]
_objects  (Project -> [PreObject])
-> (Either String Project -> Project)
-> Either String Project
-> [PreObject]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String Project -> Project
forall a. Either a Project -> Project
fromEitherDecode) Either String Project
d
        bgrObjs' :: [PreObject]
bgrObjs'  = (Project -> [PreObject]
_background (Project -> [PreObject])
-> (Either String Project -> Project)
-> Either String Project
-> [PreObject]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String Project -> Project
forall a. Either a Project -> Project
fromEitherDecode) Either String Project
d
        fonts' :: [Model]
fonts'    = (Project -> [Model]
_fonts    (Project -> [Model])
-> (Either String Project -> Project)
-> Either String Project
-> [Model]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String Project -> Project
forall a. Either a Project -> Project
fromEitherDecode) Either String Project
d
        cameras' :: [ProjectCamera]
cameras'  = (Project -> [ProjectCamera]
_cameras  (Project -> [ProjectCamera])
-> (Either String Project -> Project)
-> Either String Project
-> [ProjectCamera]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String Project -> Project
forall a. Either a Project -> Project
fromEitherDecode) Either String Project
d
    Project -> IO Project
forall (m :: * -> *) a. Monad m => a -> m a
return (Project -> IO Project) -> Project -> IO Project
forall a b. (a -> b) -> a -> b
$
      String
-> Int
-> Int
-> String
-> [Model]
-> [PreObject]
-> [PreObject]
-> [Model]
-> [ProjectCamera]
-> Project
Project
      String
name'
      Int
resx'
      Int
resy'
      String
camMode'
      [Model]
models'
      ((PreObject -> UUID) -> [PreObject] -> [PreObject]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Getting UUID PreObject UUID -> PreObject -> UUID
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UUID PreObject UUID
Lens' PreObject UUID
uuid ) [PreObject]
preObjs')
      ((PreObject -> UUID) -> [PreObject] -> [PreObject]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Getting UUID PreObject UUID -> PreObject -> UUID
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UUID PreObject UUID
Lens' PreObject UUID
uuid ) [PreObject]
bgrObjs')
      [Model]
fonts'
      [ProjectCamera]
cameras'
      
      where
        fromEitherDecode :: Either a Project -> Project
fromEitherDecode = Project -> Maybe Project -> Project
forall a. a -> Maybe a -> a
fromMaybe Project
emptyProject (Maybe Project -> Project)
-> (Either a Project -> Maybe Project)
-> Either a Project
-> Project
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either a Project -> Maybe Project
forall a a. Either a a -> Maybe a
fromEither
        fromEither :: Either a a -> Maybe a
fromEither Either a a
d =
          case Either a a
d of
            Right a
pt -> a -> Maybe a
forall a. a -> Maybe a
Just a
pt            
            Either a a
_ -> Maybe a
forall a. Maybe a
Nothing