module Graphics.UI.Handa.Setup (
Setup(..)
, Stereo(..)
, Viewer(..)
, setup
, handleArguments
, idle
) where
import Control.Monad (when)
import Data.AdditiveGroup (AdditiveGroup)
import Data.Aeson (FromJSON)
import Data.Binary (Binary(..))
import Data.Data (Data)
import Data.Default (Default(def))
import Data.List ((\\))
import Data.Typeable (Typeable)
import Foreign.Storable (Storable)
import GHC.Generics (Generic)
import Graphics.Rendering.DLP (DlpEncoding)
import Graphics.Rendering.Handa.Viewer (ViewerParameters(eyeSeparation), desktopViewer, glassesViewer, laptopViewer, phoneViewer, projectorViewer, reshape)
import Graphics.Rendering.OpenGL (BlendingFactor(..), Capability(Enabled), ComparisonFunction(Less), MatrixComponent, ($=), blend, blendFunc)
import Graphics.UI.GLUT (DisplayMode(..), IdleCallback, createWindow, depthFunc, fullScreen, idleCallback, initialDisplayMode, initialize, postRedisplay, reshapeCallback)
import qualified Graphics.Rendering.DLP as D (DlpEncoding(..))
data Setup a =
Setup
{
stereo :: Stereo
, switchEyes :: Bool
, viewer :: Either (ViewerParameters a) Viewer
, fullscreen :: Bool
}
deriving (Binary, Data, Eq, FromJSON, Generic, Read, Show, Typeable)
instance Functor Setup where
fmap f Setup{..} =
Setup
{
stereo = stereo
, switchEyes = switchEyes
, viewer = case viewer of
Left x -> Left $ fmap f x
Right x -> Right x
, fullscreen = fullscreen
}
instance Default (Setup a) where
def = Setup def False (Right def) False
data Stereo =
DLP
| QuadBuffer
| Cardboard
| Mono
deriving (Binary, Bounded, Data, Enum, Eq, FromJSON, Generic, Ord, Read, Show, Typeable)
instance Default Stereo where
def = Mono
data Viewer =
Phone
| Laptop
| Desktop
| Projector
| Glasses
deriving (Binary, Bounded, Data, Enum, Eq, FromJSON, Generic, Ord, Read, Show, Typeable)
instance Default Viewer where
def = Laptop
setup :: (AdditiveGroup a, MatrixComponent a, RealFloat a, Storable a)
=> String
-> String
-> [String]
-> Setup a
-> IO (DlpEncoding, ViewerParameters a, [String])
setup title program arguments Setup{..} =
do
arguments' <- initialize program arguments
initialDisplayMode $=
(if stereo == QuadBuffer then (Stereoscopic :) else id)
[WithDepthBuffer, DoubleBuffered]
_window <- createWindow title
depthFunc $= Just Less
blend $= Enabled
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
when fullscreen fullScreen
let
dlp = case stereo of
DLP -> D.FrameSequential
QuadBuffer -> D.QuadBuffer
Cardboard -> D.SideBySide
Mono -> D.LeftOnly
viewerParameters = case viewer of
Right Phone -> phoneViewer
Right Laptop -> laptopViewer
Right Desktop -> desktopViewer
Right Projector -> projectorViewer
Right Glasses -> glassesViewer
Left parameters -> parameters
viewerParameters' =
if switchEyes
then viewerParameters {eyeSeparation = negate <$> eyeSeparation viewerParameters}
else viewerParameters
reshapeCallback $= Just (reshape viewerParameters')
idleCallback $= Just idle
return (dlp, viewerParameters', arguments')
handleArguments :: [String]
-> (Setup a, [String])
handleArguments arguments =
let
stereo
| "--dlp" `elem` arguments = DLP
| "--cardboard" `elem` arguments = Cardboard
| "--quadbuffer" `elem` arguments = QuadBuffer
| otherwise = Mono
switchEyes = "--switchEyes" `elem` arguments
viewer
| "--phone" `elem` arguments = Right Phone
| "--laptop" `elem` arguments = Right Laptop
| "--desktop" `elem` arguments = Right Desktop
| "--projector" `elem` arguments = Right Projector
| otherwise = Right Laptop
fullscreen = "--fullscreen" `elem` arguments
keywords = ["--dlp", "--cardboard", "--switchEyes", "--phone", "--laptop", "--desktop", "--projector", "--fullscreen"]
in
(Setup{..}, arguments \\ keywords)
idle :: IdleCallback
idle = postRedisplay Nothing