module Interface.TV.Gtk
(
In, Out, GTV, gtv, runGTV, runOut, runOutIO
, R, sliderRIn, sliderIIn, clockIn
, rateSliderIn, integralIn
, fileNameIn, renderOut
, emptyTexture, textureIsEmpty, textureIn
, module Interface.TV
) where
import Control.Applicative (liftA2,(<$>),(<*>),(<$))
import Control.Monad (when)
import Data.IORef
import Data.Maybe (fromMaybe)
import Data.Time (getCurrentTime,utctDayTime)
import Graphics.UI.Gtk hiding (Action)
import Graphics.UI.Gtk.OpenGL
import qualified Graphics.Rendering.OpenGL as G
import Graphics.Rendering.OpenGL hiding (Sink,get)
import Data.Bitmap.OpenGL
import Codec.Image.STB
import Data.VectorSpace
import Data.Title
import Data.Pair
import Data.Lambda
import Control.Compose (ToOI(..),Cofunctor(..),Flip(..),result,argument,(~>))
import Interface.TV
type In = Input MkI
type Out = Output MkI MkO
type GTV = TV MkI MkO
gtv :: Out a -> a -> GTV a
gtv = tv
runGTV :: GTV a -> IO ()
runGTV = runTV
type Action = IO ()
type Sink a = a -> Action
infixl 1 >+>
(>+>) :: Sink a -> Sink b -> Sink (a,b)
(snka >+> snkb) (a,b) = snka a >> snkb b
newtype MkI a = MkI { unMkI :: MkI' a }
inMkI :: (MkI' a -> MkI' b) -> (MkI a -> MkI b)
inMkI = unMkI ~> MkI
inMkI2 :: (MkI' a -> MkI' b -> MkI' c) -> (MkI a -> MkI b -> MkI c)
inMkI2 = unMkI ~> inMkI
type MkI' a = Action -> IO (Widget, IO a, Action)
newtype MkO a = MkO { unMkO :: MkO' a }
inMkO :: (MkO' a -> MkO' b) -> (MkO a -> MkO b)
inMkO = unMkO ~> MkO
inMkO2 :: (MkO' a -> MkO' b -> MkO' c) -> (MkO a -> MkO b -> MkO c)
inMkO2 = unMkO ~> inMkO
type MkO' a = IO (Widget, Sink a, Action)
instance Functor MkI where
fmap f = inMkI ((result.fmap) f')
where
f' (wid,poll,clean) = (wid, fmap f poll, clean)
instance Cofunctor MkO where
cofmap f = inMkO (fmap f')
where
f' (wid,sink,cleanup) = (wid,sink . f,cleanup)
instance CommonIns MkI where
getString start = MkI $ \ refresh ->
do entry <- entryNew
entrySetText entry start
forget $ onEntryActivate entry refresh
return (toWidget entry, entryGetText entry, return ())
getRead = getReadF
getBool start = MkI $ \ refresh ->
do w <- checkButtonNew
toggleButtonSetActive w start
forget $ onToggled w refresh
return (toWidget w, toggleButtonGetActive w, return ())
instance CommonOuts MkO where
putString = MkO $
do entry <- entryNew
return (toWidget entry, entrySetText entry, return ())
putShow = putShowC
putBool = MkO $
do w <- checkButtonNew
return (toWidget w, toggleButtonSetActive w, return ())
instance Pair MkI where
pair = inMkI2 $ \ ia ib -> \ refresh ->
do box <- boxNew Horizontal False 10
(wa,geta,cleana) <- ia refresh
(wb,getb,cleanb) <- ib refresh
set box [ containerChild := wa , containerChild := wb ]
return (toWidget box, liftA2 (,) geta getb, cleana >> cleanb)
instance Pair MkO where
pair = inMkO2 $ \ oa ob ->
do box <- boxNew Horizontal False 10
(wa,snka,cleana) <- oa
(wb,snkb,cleanb) <- ob
set box [ containerChild := wa , containerChild := wb ]
return (toWidget box, snka >+> snkb, cleana >> cleanb)
instance Title_f MkI where
title_f str = inMkI $ \ ia -> \ refresh ->
do (widget,geta,cleana) <- ia refresh
frame <- frameNew
set frame [ frameLabel := str
, containerChild := widget ]
return (toWidget frame, geta, cleana)
instance Title_f MkO where
title_f str = inMkO $ \ oa ->
do (widget,sink,clean) <- oa
frame <- frameNew
set frame [ frameLabel := str
, containerChild := widget ]
return (toWidget frame, sink, clean)
instance Lambda MkI MkO where
lambda = (unMkI ~> unMkO ~> MkO) $ \ ia ob ->
do box <- boxNew Vertical False 0
reff <- newIORef (error "mkLambda: no function yet")
rec let refresh = readIORef reff <*> geta >>= snkb
(wa,geta,cleana) <- ia refresh
(wb,snkb,cleanb) <- ob
boxPackStart box wa PackNatural 0
boxPackStart box wb PackGrow 0
return ( toWidget box
, \ f -> writeIORef reff f >> refresh
, cleana >> cleanb)
runMkO :: String -> MkO a -> a -> Action
runMkO = (result.result.argument) return runMkOIO
runMkOIO :: String -> MkO a -> IO a -> Action
runMkOIO name (MkO mko') mkA = do
forget $ initGUI
(wid,sink,cleanup) <- mko'
window <- windowNew
set window [ windowDefaultWidth := 200
, containerChild := wid
, windowTitle := name
]
forget $ onDestroy window (cleanup >> mainQuit)
widgetShowAll window
mkA >>= sink
mainGUI
return ()
instance ToOI MkO where
toOI mkO = Flip (runMkO "GtkTV" mkO)
runOutIO :: String -> Out a -> IO a -> Action
runOutIO name out = runMkOIO name (output out)
runOut :: String -> Out a -> a -> Action
runOut = (result.result.argument) return runOutIO
data Orient = Horizontal | Vertical deriving (Read,Show)
boxNew :: Orient -> Bool -> Int -> IO Box
boxNew Vertical = boxer vBoxNew
boxNew Horizontal = boxer hBoxNew
boxer :: BoxClass box => (a -> b -> IO box) -> (a -> b -> IO Box)
boxer = (result.result.fmap) toBox
primMkI :: MkI' a -> In a
primMkI = iPrim . MkI
primMkO :: MkO' a -> Out a
primMkO = oPrim . MkO
type R = Float
sliderRIn :: (R,R) -> R -> In R
sliderRIn = sliderGIn realToFrac realToFrac 0.005 5
sliderIIn :: (Int,Int) -> Int -> In Int
sliderIIn = sliderGIn fromIntegral round 1 0
sliderGIn :: (Show a, Eq a) => (a -> Double) -> (Double -> a) -> a -> Int
-> (a,a) -> a -> In a
sliderGIn toD fromD step digits
(lo,hi) a0 = primMkI $ \ refresh ->
do oldRef <- newIORef a0
w <- hScaleNewWithRange (toD lo) (toD hi) (toD step)
set w [ rangeValue := toD a0, scaleDigits := digits ]
let getter = fromD <$> get w rangeValue
changeTo new =
do old <- readIORef oldRef
when (old /= new) $
do refresh
writeIORef oldRef new
forget $ afterRangeChangeValue w (\ _ x -> changeTo (fromD x) >> return False)
return (toWidget w, getter, return ())
clockDtI :: R -> In R
clockDtI period = primMkI $ \ refresh ->
do start <- time
timeout <- timeoutAddFull (refresh >> return True)
priorityDefaultIdle (round (period * 1000))
w <- vBoxNew True 0
return (toWidget w, subtract start <$> time, timeoutRemove timeout)
clockIn :: In R
clockIn = clockDtI (1/60)
time :: IO R
time = (fromRational . toRational . utctDayTime) <$> getCurrentTime
rateSliderDtIn :: R -> (R,R) -> R -> In R
rateSliderDtIn period = (result.result) (integralDtIn period) sliderRIn
rateSliderIn :: (R,R) -> R -> In R
rateSliderIn = rateSliderDtIn (1/60)
integralDtIn :: (VectorSpace v, Eq v, Scalar v ~ Float) =>
R -> In v -> In v
integralDtIn period inp = primMkI $ \ refresh ->
do refT <- time >>= newIORef
refX <- newIORef zeroV
(w,getV,cleanV) <- mkI' (return ())
timeout <- timeoutAddFull (refresh >> return True)
priorityDefaultIdle (round (period * 1000))
let getX = do v <- getV
prevX <- readIORef refX
if (v /= zeroV) then
do t <- time
prevT <- readIORef refT
let x = prevX ^+^ (t prevT) *^ v
writeIORef refT t
writeIORef refX x
return x
else
return prevX
return (w, getX, timeoutRemove timeout >> cleanV)
where
MkI mkI' = input inp
integralIn :: (VectorSpace v, Eq v, Scalar v ~ Float) =>
In v -> In v
integralIn = integralDtIn (1/60)
mkCanvas :: IO GLDrawingArea
mkCanvas =
glConfigNew [ GLModeRGBA, GLModeDepth , GLModeDouble, GLModeAlpha ]
>>= glDrawingAreaNew
renderOut :: Out Action
renderOut = primMkO $
do forget $ initGL
canvas <- mkCanvas
widgetSetSizeRequest canvas 300 300
forget $ onRealize canvas $ withGLDrawingArea canvas $ const $
do
depthFunc $= Just Less
drawBuffer $= BackBuffers
clearColor $= Color4 0 0 0.2 1
drawRef <- newIORef (return ())
let display draw =
withGLDrawingArea canvas $ \ glwindow ->
do clear [DepthBuffer, ColorBuffer]
flipY
draw
flipY
finish
glDrawableSwapBuffers glwindow
writeIORef drawRef draw
forget $ onExpose canvas $ \_ ->
do (w',h') <- widgetGetSize canvas
let w = fromIntegral w' :: GLsizei
h = fromIntegral h'
maxWH = w `max` h
start s = fromIntegral ((s maxWH) `div` 2)
viewport $= (Position (start w) (start h), Size maxWH maxWH)
readIORef drawRef >>= display
return True
return (toWidget canvas, display, return ())
flipY :: Action
flipY = scale 1 (1 :: GLfloat) 1
emptyTexture :: TextureObject
emptyTexture = TextureObject bogusTO
bogusTO :: G.GLuint
bogusTO = 1
textureIsEmpty :: TextureObject -> Bool
textureIsEmpty (TextureObject i) = i == bogusTO
loadTexture :: FilePath -> IO (Either String TextureObject)
loadTexture path =
do e <- loadImage path
case e of
Left err -> return (Left err)
Right im -> Right <$> makeSimpleBitmapTexture im
fileNameIn :: FilePath -> In FilePath
fileNameIn start = primMkI $ \ refresh ->
do w <- fileChooserButtonNew "Select file" FileChooserActionOpen
forget $ fileChooserSetFilename w start
forget $ onCurrentFolderChanged w refresh
return ( toWidget w
, fromMaybe start <$> fileChooserGetFilename w
, return () )
textureIn :: In TextureObject
textureIn = fileMungeIn loadTexture deleteTexture emptyTexture
deleteTexture :: Sink TextureObject
deleteTexture tex | textureIsEmpty tex = return ()
| otherwise =
do
deleteObjectNames [tex]
fileMungeIn ::
(FilePath -> IO (Either String a)) -> Sink a -> a -> In a
fileMungeIn munge free start = primMkI $ \ refresh ->
do w <- fileChooserButtonNew "Select file" FileChooserActionOpen
current <- newIORef start
forget $ onUpdatePreview w $
do
mb <- fileChooserGetFilename w
case mb of
Nothing -> return ()
Just path ->
do e <- munge path
case e of
Left _ -> return ()
Right a -> do readIORef current >>= free
writeIORef current a
refresh
return (toWidget w, readIORef current, return ())
forget :: Functor f => f a -> f ()
forget = (() <$)