Gifcurry-3.0.0.0: src/gui/GuiPreview.hs
{-
Gifcurry
(C) 2018 David Lettier
lettier.com
-}
{-# LANGUAGE
OverloadedStrings
, NamedFieldPuns
#-}
module GuiPreview where
import GHC.Float
import System.FilePath
import System.IO.Temp
import Data.Int
import Data.Maybe
import Data.Text
import Data.List
import Data.Bits
import Data.IORef
import Data.GI.Base.Properties
import Control.Monad
import Control.Concurrent
import qualified GI.GLib
import qualified GI.Gtk
import qualified GI.Gst
import qualified GI.Cairo
import qualified GiCairoCairoBridge
import qualified Graphics.Rendering.Cairo as GRC
import qualified Gifcurry
( gif
, GifParams(..)
, defaultGifParams
)
import qualified GtkMainSyncAsync (gtkMainSync, gtkMainAsync)
import qualified GuiRecords as GR
import GuiMisc
blankPreviewIcon :: String
blankPreviewIcon = "gtk-discard"
framePreviewDirectoryName :: String
framePreviewDirectoryName = "gifcurry-frame-previews"
buildVideoPreviewWidgetAndPlaybinElement :: IO (Maybe GI.Gtk.Widget, Maybe GI.Gst.Element)
buildVideoPreviewWidgetAndPlaybinElement = do
maybeGtkSink <- GI.Gst.elementFactoryMake "gtksink" (Just "MultimediaPlayerGtkSink")
maybeVideoPreviewWidget <-
case maybeGtkSink of
Nothing -> return Nothing
Just gtkSink ->
Data.GI.Base.Properties.getObjectPropertyObject gtkSink "widget" GI.Gtk.Widget
maybePlaybinElement <- GI.Gst.elementFactoryMake "playbin" (Just "MultimediaPlayerPlaybin")
case (maybeVideoPreviewWidget, maybePlaybinElement) of
(Just videoPreviewWidget, Just playbinElement) -> do
-- Turns off the subtitles.
let flags = flip setBit 10 $ flip setBit 9 $ flip setBit 4 $ flip setBit 1 $ bit 0
_ <- Data.GI.Base.Properties.setObjectPropertyObject playbinElement "video-sink" maybeGtkSink
_ <- Data.GI.Base.Properties.setObjectPropertyBool playbinElement "force-aspect-ratio" True
_ <- Data.GI.Base.Properties.setObjectPropertyDouble playbinElement "volume" 0.0
_ <- Data.GI.Base.Properties.setObjectPropertyInt playbinElement "flags" flags
_ <- GI.Gtk.widgetShow videoPreviewWidget
return ()
_ -> return ()
return (maybeVideoPreviewWidget, maybePlaybinElement)
runGuiPreview :: GR.GuiComponents -> IO ()
runGuiPreview
guiComponents@GR.GuiComponents
{ GR.maybeVideoPreviewWidget = (Just videoPreviewWidget)
, GR.maybePlaybinElement = (Just _)
, GR.mainPreviewBox
, GR.videoPreviewBox
, GR.videoPreviewOverlayChildBox
, GR.videoPreviewDrawingArea
}
= do
mainPreviewBoxChildCount <-
Data.List.length <$> GI.Gtk.containerGetChildren mainPreviewBox
when (mainPreviewBoxChildCount <= 0) $
GI.Gtk.boxPackStart mainPreviewBox videoPreviewBox True True 0
videoPreviewOverlayChildBoxChildCount <-
Data.List.length <$> GI.Gtk.containerGetChildren videoPreviewOverlayChildBox
when (videoPreviewOverlayChildBoxChildCount <= 0) $ do
_ <- GI.Gtk.boxPackStart videoPreviewOverlayChildBox videoPreviewWidget True True 0
_ <- GI.Gtk.onWidgetDraw
videoPreviewDrawingArea
(drawCropGrid guiComponents videoPreviewDrawingArea)
return ()
runPreviewLoopIfNotRunning
guiComponents $
preview guiComponents videoPreview
runGuiPreview
guiComponents@GR.GuiComponents
{ GR.mainPreviewBox
, GR.imagesPreviewBox
, GR.firstFramePreviewImageDrawingArea
, GR.lastFramePreviewImageDrawingArea
}
= do
childrenCount <- Data.List.length <$> GI.Gtk.containerGetChildren mainPreviewBox
when (childrenCount <= 0) $ do
_ <- GI.Gtk.boxPackStart mainPreviewBox imagesPreviewBox True True 0
_ <- GI.Gtk.onWidgetDraw
firstFramePreviewImageDrawingArea
(drawCropGrid guiComponents firstFramePreviewImageDrawingArea)
_ <- GI.Gtk.onWidgetDraw
lastFramePreviewImageDrawingArea
(drawCropGrid guiComponents lastFramePreviewImageDrawingArea)
return ()
runPreviewLoopIfNotRunning
guiComponents $
preview guiComponents firstAndLastFramePreview
runPreviewLoopIfNotRunning :: GR.GuiComponents -> IO Bool -> IO ()
runPreviewLoopIfNotRunning
GR.GuiComponents
{ GR.guiPreviewStateRef }
f
= do
loopRunning <- getLoopRunning
unless loopRunning $
void $
GI.GLib.timeoutAdd
GI.GLib.PRIORITY_DEFAULT
1
f
where
getLoopRunning :: IO Bool
getLoopRunning =
readIORef guiPreviewStateRef >>=
\ x -> return $ GR.loopRunning x
preview
:: GR.GuiComponents
-> ( GR.GuiComponents
-> GR.GuiPreviewState
-> String
-> Float
-> Float
-> Float
-> Float
-> IO ()
)
-> IO Bool
preview
guiComponents@GR.GuiComponents
{ GR.inFileChooserButton
, GR.startTimeSpinButton
, GR.durationTimeSpinButton
, GR.guiPreviewStateRef
, GR.inVideoPropertiesRef
}
f
= do
GR.InVideoProperties
{ GR.inVideoWidth
, GR.inVideoHeight
} <- readIORef inVideoPropertiesRef
guiPreviewState <- readIORef guiPreviewStateRef
inFilePath <- fileChooserButtonGetFilePath inFileChooserButton
startTime <- double2Float <$> GI.Gtk.spinButtonGetValue startTimeSpinButton
durationTime <- double2Float <$> GI.Gtk.spinButtonGetValue durationTimeSpinButton
let invalidInFilePath = inFilePath == ""
let invalidStartTime = startTime < 0.0
let invalidDurationTime = durationTime <= 0.0
let invalidInVideoWidth = inVideoWidth <= 0.0
let invalidInVideoHeight = inVideoHeight <= 0.0
let inputInvalid =
invalidInFilePath
|| invalidStartTime
|| invalidDurationTime
|| invalidInVideoWidth
|| invalidInVideoHeight
if not inputInvalid
then
f
guiComponents
guiPreviewState
inFilePath
startTime
durationTime
inVideoWidth
inVideoHeight
else
resetWindow guiComponents
atomicWriteIORef guiPreviewStateRef
guiPreviewState
{ GR.maybeInFilePath = if invalidInFilePath then Nothing else Just inFilePath
, GR.maybeStartTime = if invalidStartTime then Nothing else Just startTime
, GR.maybeDurationTime = if invalidDurationTime then Nothing else Just durationTime
, GR.loopRunning = True
}
return True
videoPreview
:: GR.GuiComponents
-> GR.GuiPreviewState
-> String
-> Float
-> Float
-> Float
-> Float
-> IO ()
videoPreview
GR.GuiComponents
{ GR.window
, GR.cropToggleButton
, GR.mainPreviewBox
, GR.videoPreviewBox
, GR.maybePlaybinElement = (Just playbinElement)
}
GR.GuiPreviewState
{ GR.maybeInFilePath
, GR.maybeStartTime
}
inFilePath
startTime
durationTime
inVideoWidth
inVideoHeight
= do
GI.Gtk.widgetShow videoPreviewBox
sizePreviewAndWindow
handleChanges
handleCropMode
where
sizePreviewAndWindow :: IO ()
sizePreviewAndWindow = do
let widthRatio = inVideoWidth / inVideoHeight
let heightRatio = inVideoHeight / inVideoWidth
let previewWidth =
if inVideoWidth >= inVideoHeight
then desiredPreviewSize
else desiredPreviewSize * widthRatio
let previewHeight =
if inVideoWidth < inVideoHeight
then desiredPreviewSize
else desiredPreviewSize * heightRatio
let previewWidth' = floatToInt32 previewWidth
let previewHeight' = floatToInt32 previewHeight
GI.Gtk.widgetSetSizeRequest
window
previewWidth'
(-1)
GI.Gtk.widgetSetSizeRequest
mainPreviewBox
previewWidth'
previewHeight'
resizeWindow window
handleChanges :: IO ()
handleChanges = do
(couldQueryDuration, videoDuration) <-
GI.Gst.elementQueryDuration playbinElement GI.Gst.FormatTime
(couldQueryPosition, videoPosition) <-
GI.Gst.elementQueryPosition playbinElement GI.Gst.FormatTime
let endTime = startTime + durationTime
let startTimeInNano = secondsToNanoseconds startTime
let endTimeInNano = secondsToNanoseconds endTime
let inFilePathChanged = fromMaybe "" maybeInFilePath /= inFilePath
let startTimeChanged = fromMaybe (-1.0) maybeStartTime /= startTime
let startOver =
(couldQueryDuration && couldQueryPosition && videoDuration > 0)
&& ( videoPosition >= videoDuration
|| videoPosition >= endTimeInNano
|| videoPosition < startTimeInNano
)
let seekToStart = startTimeChanged || inFilePathChanged || startOver
when inFilePathChanged $ do
_ <- GI.Gst.elementSetState playbinElement GI.Gst.StateNull
Data.GI.Base.Properties.setObjectPropertyString
playbinElement
"uri"
(Just $ pack $ "file://" ++ inFilePath)
_ <- Data.GI.Base.Properties.setObjectPropertyDouble playbinElement "volume" 0.0
resizeWindow window
when seekToStart $ do
_ <- GI.Gst.elementSetState playbinElement GI.Gst.StatePaused
_ <- GI.Gst.elementSeekSimple
playbinElement
GI.Gst.FormatTime
[GI.Gst.SeekFlagsFlush]
startTimeInNano
_ <- GI.Gst.elementSetState playbinElement GI.Gst.StatePlaying
return ()
handleCropMode :: IO ()
handleCropMode = do
cropModeEnabled <- GI.Gtk.getToggleButtonActive cropToggleButton
if cropModeEnabled
then
void $ Data.GI.Base.Properties.setObjectPropertyBool
playbinElement
"force-aspect-ratio"
False
else
void $ Data.GI.Base.Properties.setObjectPropertyBool
playbinElement
"force-aspect-ratio"
True
videoPreview _ _ _ _ _ _ _ = return ()
firstAndLastFramePreview
:: GR.GuiComponents
-> GR.GuiPreviewState
-> String
-> Float
-> Float
-> Float
-> Float
-> IO ()
firstAndLastFramePreview
GR.GuiComponents
{ GR.window
, GR.imagesPreviewBox
, GR.firstFrameImage
, GR.lastFrameImage
, GR.firstFramePreviewImageDrawingArea
, GR.lastFramePreviewImageDrawingArea
, GR.temporaryDirectory
}
GR.GuiPreviewState
{ GR.maybeInFilePath
, GR.maybeStartTime
, GR.maybeDurationTime
}
inFilePath
startTime
durationTime
_
_
= do
GI.Gtk.widgetShow imagesPreviewBox
handleChanges
redrawDrawingAreas
where
handleChanges :: IO ()
handleChanges = do
let inFilePathChanged =
fromMaybe "" maybeInFilePath /= inFilePath
let startTimeChanged =
fromMaybe (-1.0) maybeStartTime /= startTime
let durationTimeChanged =
fromMaybe (-1.0) maybeDurationTime /= durationTime
let firstAndLastFrameDirty = inFilePathChanged || startTimeChanged
let lastFrameDirty = not firstAndLastFrameDirty && durationTimeChanged
when firstAndLastFrameDirty $
makeFirstAndLastFramePreview
inFilePath
startTime
durationTime
firstFrameImage
lastFrameImage
temporaryDirectory
window
when lastFrameDirty $
makeLastFramePreview
inFilePath
startTime
durationTime
lastFrameImage
temporaryDirectory
window
redrawDrawingAreas :: IO ()
redrawDrawingAreas = do
GI.Gtk.widgetQueueDraw firstFramePreviewImageDrawingArea
GI.Gtk.widgetQueueDraw lastFramePreviewImageDrawingArea
drawCropGrid :: GR.GuiComponents -> GI.Gtk.DrawingArea -> GI.Cairo.Context -> IO Bool
drawCropGrid
GR.GuiComponents
{ GR.cropToggleButton
, GR.leftCropSpinButton
, GR.rightCropSpinButton
, GR.topCropSpinButton
, GR.bottomCropSpinButton
, GR.inVideoPropertiesRef
}
drawingArea
context
= do
GR.InVideoProperties
{ GR.inVideoWidth
, GR.inVideoHeight
} <- readIORef inVideoPropertiesRef
cropModeEnabled <- GI.Gtk.getToggleButtonActive cropToggleButton
drawingAreaWidth <-
int32ToDouble <$> GI.Gtk.widgetGetAllocatedWidth drawingArea
drawingAreaHeight <-
int32ToDouble <$> GI.Gtk.widgetGetAllocatedHeight drawingArea
left <- (/ 100.0) <$> GI.Gtk.spinButtonGetValue leftCropSpinButton
right <- (/ 100.0) <$> GI.Gtk.spinButtonGetValue rightCropSpinButton
top <- (/ 100.0) <$> GI.Gtk.spinButtonGetValue topCropSpinButton
bottom <- (/ 100.0) <$> GI.Gtk.spinButtonGetValue bottomCropSpinButton
when (cropModeEnabled && inVideoWidth >= 0.0 && inVideoHeight >= 0.0) $
GiCairoCairoBridge.renderWithContext context $ do
GRC.setSourceRGBA 0.0 0.0 0.0 0.8
GRC.setLineWidth 1.0
-- Left
GRC.rectangle 0.0 0.0 (left * drawingAreaWidth) drawingAreaHeight
GRC.fill
-- Right
GRC.rectangle
(drawingAreaWidth - right * drawingAreaWidth)
0.0
(right * drawingAreaWidth)
drawingAreaHeight
GRC.fill
-- Top
GRC.rectangle 0.0 0.0 drawingAreaWidth (top * drawingAreaHeight)
GRC.fill
-- Bottom
GRC.rectangle
0.0
(drawingAreaHeight - bottom * drawingAreaHeight)
drawingAreaWidth
(bottom * drawingAreaHeight)
GRC.fill
return False
resetWindow :: GR.GuiComponents -> IO ()
resetWindow
GR.GuiComponents
{ GR.window
, GR.mainPreviewBox
, GR.imagesPreviewBox
, GR.videoPreviewBox
}
= do
GI.Gtk.widgetSetSizeRequest
window
900
(-1)
GI.Gtk.widgetSetSizeRequest
mainPreviewBox
(floatToInt32 desiredPreviewSize)
(-1)
GI.Gtk.widgetHide imagesPreviewBox
GI.Gtk.widgetHide videoPreviewBox
resizeWindow window
resizeWindow :: GI.Gtk.Window -> IO ()
resizeWindow window =
void $ GI.Gtk.windowResize window 1 1
makeFirstAndLastFramePreview
:: String
-> Float
-> Float
-> GI.Gtk.Image
-> GI.Gtk.Image
-> System.FilePath.FilePath
-> GI.Gtk.Window
-> IO ()
makeFirstAndLastFramePreview
inFilePath
startTime
durationTime
firstFrameImage
lastFrameImage
temporaryDirectory
window
= do
void $ forkIO $
withTempDirectory
temporaryDirectory
framePreviewDirectoryName $
\ tmpDir -> do
let outFilePath = tmpDir ++ "/gifcurry-first-frame-preview.gif"
let inputValid = not (Data.List.null inFilePath) && startTime >= 0.0
void $
setOrResetFramePrevew
inputValid
inFilePath
outFilePath
startTime
firstFrameImage
""
window
makeLastFramePreview
inFilePath
startTime
durationTime
lastFrameImage
temporaryDirectory
window
makeLastFramePreview
:: String
-> Float
-> Float
-> GI.Gtk.Image
-> System.FilePath.FilePath
-> GI.Gtk.Window
-> IO ()
makeLastFramePreview
inFilePath
startTime
durationTime
lastFrameImage
temporaryDirectory
window
=
void $ forkIO $
withTempDirectory
temporaryDirectory
framePreviewDirectoryName $
\ tmpdir -> do
let startTime' = startTime + durationTime
let outFilePath = tmpdir ++ "/gifcurry-last-frame-preview.gif"
let inputValid = startTime' > 0.0 && not (Data.List.null inFilePath)
void $
setOrResetFramePrevew
inputValid
inFilePath
outFilePath
startTime'
lastFrameImage
""
window
setOrResetFramePrevew
:: Bool
-> String
-> String
-> Float
-> GI.Gtk.Image
-> String
-> GI.Gtk.Window
-> IO ()
setOrResetFramePrevew False _ _ _ image _ window =
GtkMainSyncAsync.gtkMainAsync $ do
resetImage image
resizeWindow window
setOrResetFramePrevew
True
inFilePath
outFilePath
time
image
overlay
window
= do
result <- makeImagePreview inFilePath outFilePath time overlay
case result of
Left _ ->
void $ updatePreviewFrame "" image False
Right filePath ->
void $ updatePreviewFrame filePath image True
GtkMainSyncAsync.gtkMainAsync $ resizeWindow window
makeImagePreview
:: String
-> String
-> Float
-> String
-> IO (Either IOError String)
makeImagePreview inputFile outputFile startTime bottomText =
Gifcurry.gif $
Gifcurry.defaultGifParams
{ Gifcurry.inputFile = inputFile
, Gifcurry.outputFile = outputFile
, Gifcurry.saveAsVideo = False
, Gifcurry.startTime = startTime
, Gifcurry.durationTime = 0.001
, Gifcurry.widthSize = 300
, Gifcurry.qualityPercent = 50.0
, Gifcurry.bottomText = bottomText
}
updatePreviewFrame :: String -> GI.Gtk.Image -> Bool -> IO ()
updatePreviewFrame filePath image True =
GtkMainSyncAsync.gtkMainSync (GI.Gtk.imageSetFromFile image (Just filePath))
updatePreviewFrame _ image False =
GtkMainSyncAsync.gtkMainSync (resetImage image)
resetImage :: GI.Gtk.Image -> IO ()
resetImage image =
GI.Gtk.imageSetFromIconName
image
(Just $ pack blankPreviewIcon)
(enumToInt32 GI.Gtk.IconSizeButton)
secondsToNanoseconds :: Float -> Int64
secondsToNanoseconds s =
fromIntegral (round (s * 1000000000.0) :: Integer) :: Int64
desiredPreviewSize :: Float
desiredPreviewSize = 600.0