diff --git a/Gifcurry.cabal b/Gifcurry.cabal --- a/Gifcurry.cabal +++ b/Gifcurry.cabal @@ -1,5 +1,5 @@ name: Gifcurry -version: 0.1.1.0 +version: 2.0.0.0 synopsis: Create animated GIFs, overlaid with optional text, from video files. description: GIF creation utility. homepage: https://github.com/lettier/gifcurry @@ -19,6 +19,11 @@ type: git location: https://github.com/lettier/gifcurry +library + exposed-modules: Gifcurry + build-depends: base >=4.7 && <4.9, process >=1.2 && <1.3, temporary >=1.2 && <1.3, directory ==1.2.* + default-language: Haskell2010 + executable gifcurry_gui main-is: Main.hs build-depends: base >=4.7 && <4.9, gtk3 >=0.14 && <0.15, process >=1.2 && <1.3, temporary >=1.2 && <1.3, directory ==1.2.* @@ -29,7 +34,7 @@ executable gifcurry_cli main-is: Main.hs - build-depends: base >=4.7 && <4.9, process >=1.2 && <1.3, temporary >=1.2 && <1.3, directory == 1.2.* + build-depends: base >=4.7 && <4.9, process >=1.2 && <1.3, temporary >=1.2 && <1.3, directory == 1.2.*, cmdargs ==0.10.* other-modules: Gifcurry hs-source-dirs: cli_src, ./ default-language: Haskell2010 diff --git a/Gifcurry.hs b/Gifcurry.hs --- a/Gifcurry.hs +++ b/Gifcurry.hs @@ -1,6 +1,13 @@ -- David Lettier (C) 2016. http://www.lettier.com/ -module Gifcurry (gif) where +-- | Produces GIFs using FFmpeg and ImageMagick. +-- The main function is 'gif'. +module Gifcurry ( + gif + , GifParams(..) + , defaultGifParams + , gifParamsValid + ) where import System.Environment import System.Process @@ -8,109 +15,230 @@ import System.Directory import System.Exit import Data.List +import Text.Printf import Control.Exception +import Control.Monad -gif [is, os, st, dr, wd, qa, ttx, btx] = - withTempDirectory "." "frames" $ \tmpDir -> do - putStrLn $ "\nInput file: " ++ is - putStrLn $ "Start second: " ++ st - putStrLn $ "Duration: " ++ dr ++ " seconds" - putStrLn $ "GIF width: " ++ wd ++ "px" - putStrLn $ "Quality: " ++ (quality qa) ++ "%" - putStrLn $ "Top text: " ++ ttx - putStrLn $ "Bottom text: " ++ btx - putStrLn $ "\nWriting temporary frames to... " ++ tmpDir - fileExists <- doesFileExist is - if fileExists +-- | The data type record required by 'gif'. +data GifParams = GifParams { + inputFile :: [Char] + , outputFile :: [Char] + , startTime :: Float + , durationTime :: Float + , widthSize :: Int + , qualityPercent :: Float + , topText :: [Char] + , bottomText :: [Char] + } deriving (Show, Read) + +-- | Specifies default parameters for 'startTime', 'durationTime', 'widthSize', and 'qualityPercent'. +defaultGifParams = GifParams { + inputFile = "" + , outputFile = "" + , startTime = 0.0 + , durationTime = 1.0 + , widthSize = 500 + , qualityPercent = 100.0 + , topText = "" + , bottomText = "" + } + +-- | Inputs 'GifParams' and outputs either an IO IOError or IO String. +-- +-- @ +-- import qualified Gifcurry (gif, GifParams(..), defaultGifParams, gifParamsValid) +-- main :: IO () +-- main = do +-- let params = Gifcurry.defaultGifParams { Gifcurry.inputFile = ".\/in.mov", Gifcurry.outputFile = ".\/out.gif" } +-- valid <- Gifcurry.gifParamsValid params +-- if valid +-- then do +-- result <- Gifcurry.gif params +-- print result +-- else return () +-- @ +gif :: GifParams -> IO (Either IOError String) +gif gifParams = + withTempDirectory "." "frames" $ \tmpdir -> do + printGifParams gifParams tmpdir + validParams <- gifParamsValid gifParams + if validParams then do - result <- try (readProcess "ffmpeg" [ - "-nostats", - "-loglevel", - "panic", - "-an", - "-ss", - st, - "-i", - is, - "-t", - dr, - "-r", - "15", - "-q:v", - "2", - "-vf", - "scale=" ++ wd ++ ":-1", - "-f", - "image2", - tmpDir ++ "/%010d.png" ] "") :: IO (Either IOError String) - result <- case result of - Left ex -> return 1 - Right val -> return 0 - putStrLn $ "Writing your GIF to... " ++ os - result <- try (convert qa tmpDir os wd ttx btx) :: IO (Either IOError String) - result <- case result of - Left ex -> return 1 - Right val -> return 0 - putStrLn "Done." - return result - else do - putStrLn "Video file does not exist." - return 0 + result <- tryFfmpeg gifParams tmpdir + result' <- case result of + Left err -> return False + Right val -> return True + if result' + then do + putStrLn $ "Writing your GIF to... " ++ outputFile gifParams + result <- tryConvert gifParams tmpdir + result' <- case result of + Left err -> return False + Right val -> return True + if result' + then putStrLn "Done." + else putStrLn "[Error] Something when wrong with ImageMagick." + return result + else do + putStrLn "[Error] Something went wrong with FFmpeg." + return result + else return $ Left (userError "[Error] Invalid params.") -convert qa dr os wd ttx btx = readProcess "convert" ([ - "-quiet", - "-delay", - "6", - "-colors", - ncolors qa, - "-coalesce", - "-layers", - "OptimizeTransparency", - "-layers", - "RemoveDups", - dr ++ "/*.png", - "-dither", - "FloydSteinberg", - "-loop", - "0" ] ++ annotate wd ttx "north" ++ annotate wd btx "south" ++ [os]) "" +-- | Outputs True or False if a GifParams record parameters are valid. +-- Looks at 'inputFile', 'outputFile', 'startTime', 'durationTime', 'widthSize', and 'qualityPercent'. +gifParamsValid :: GifParams -> IO Bool +gifParamsValid GifParams { + inputFile = ipf + , outputFile = opf + , startTime = st + , durationTime = dt + , widthSize = ws + , qualityPercent = qp + , topText = tt + , bottomText = bt + } = do + inputFileExists <- case length ipf of + 0 -> return False + _ -> doesFileExist ipf + unless inputFileExists $ putStrLn "\n[Error] Input video file does not exist." + let outputFileValid = length opf > 5 + unless outputFileValid $ putStrLn "\n[Error] Output video file blank." + let valid = inputFileExists && outputFileValid && (st >= 0.0) && (dt >= 0.0) && (ws > 0) && (qp > 0.0) + unless valid $ putStrLn "\n[Error] Invalid params." + return valid -quality qa - | n > 100 = show 100 - | n < 0 = show 2 - | otherwise = show n - where n = read qa :: Float +printGifParams :: GifParams -> [Char] -> IO () +printGifParams + GifParams { + inputFile = ipf + , outputFile = opf + , startTime = st + , durationTime = dt + , widthSize = ws + , qualityPercent = qp + , topText = tt + , bottomText = bt + } + tmpdir = mapM_ putStrLn [ + "\nInput file: " ++ ipf + , "Output file: " ++ opf + , "Start second: " ++ printf "%.3f" st + , "Duration: " ++ printf "%.3f" dt ++ " seconds" + , "GIF width: " ++ show ws ++ "px" + , "Quality: " ++ show (qualityPercentClamp qp) ++ "%" + , "Top text: " ++ tt + , "Bottom text: " ++ bt + , "\nWriting temporary frames to... " ++ tmpdir + ] -ncolors qa - | n < 0.0 = show 1 - | n >= 100.0 = show 256 - | otherwise = show $ truncate (n / 100.0 * 256.0) - where n = read (quality qa) :: Float +tryFfmpeg :: GifParams -> [Char] -> IO (Either IOError String) +tryFfmpeg + GifParams { + inputFile = ipf + , startTime = st + , durationTime = dt + , widthSize = ws + } + tmpdir = try( + readProcess "ffmpeg" [ + "-nostats" + , "-loglevel" + , "panic" + , "-an" + , "-ss" + , sts + , "-i" + , ipf + , "-t" + , dts + , "-r" + , "15" + , "-q:v" + , "2" + , "-vf" + , "scale=" ++ wss ++ ":-1" + , "-f" + , "image2" + , tmpdir ++ "/%010d.png" + ] "" + ) :: IO (Either IOError String) + where sts = printf "%.3f" st + dts = printf "%.3f" dt + wss = show ws -annotate wd tx dr = [ - "-gravity", - dr, - "-stroke", - "#000C", - "-strokewidth", - "10", - "-pointsize", - pointsize wd tx, - "-annotate", - "+0+10", - tx, - "-stroke", - "none", - "-fill", - "white", - "-pointsize", - pointsize wd tx, - "-annotate", - "+0+10", - tx ] +tryConvert :: GifParams -> [Char] -> IO (Either IOError String) +tryConvert + GifParams { + outputFile = opf + , widthSize = ws + , qualityPercent = qp + , topText = tt + , bottomText = bt + } + tmpdir = try( + readProcess "convert" ( + [ + "-quiet" + , "-delay" + , "6" + , "-colors" + , show $ ncolors qp + , "-coalesce" + , "-layers" + , "OptimizeTransparency" + , "-layers" + , "RemoveDups" + , tmpdir ++ "/*.png" + , "-dither" + , "FloydSteinberg" + , "-loop" + , "0" + ] ++ annotate ws tt "north" ++ annotate ws bt "south" ++ [opf] + ) "" + ) -pointsize wd tx - | length tx == 0 = show 0 - | n <= 0 = show 0 - | otherwise = show $ truncate ((n * 0.4) / l * (72.0 / 34.0)) - where n = read wd :: Float - l = fromIntegral (length tx) +qualityPercentClamp :: Float -> Float +qualityPercentClamp qp + | qp > 100.0 = 100.0 + | qp < 0.0 = 2.0 + | otherwise = qp + +ncolors :: Float -> Int +ncolors qp + | qpc < 0.0 = 1 + | qpc >= 100.0 = 256 + | otherwise = truncate (qpc / 100.0 * 256.0) + where qpc = qualityPercentClamp qp + +annotate :: Int -> [Char] -> [Char] -> [[Char]] +annotate widthSize text topBottom = [ + "-gravity" + , topBottom + , "-stroke" + , "#000C" + , "-strokewidth" + , "10" + , "-pointsize" + , ps + , "-annotate" + , "+0+10" + , text + , "-stroke" + , "none" + , "-fill" + , "white" + , "-pointsize" + , ps + , "-annotate" + , "+0+10" + , text + ] + where ps = show $ pointSize widthSize text + +pointSize :: Int -> [Char] -> Int +pointsize _ "" = 0 +pointSize widthSize text + | widthSize <= 0 = 0 + | otherwise = truncate ((wsf * 0.4) / l * (72.0 / 34.0)) + where wsf = fromIntegral widthSize + l = fromIntegral (length text) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -18,13 +18,13 @@ ## CLI Usage ```bash -gifcurry ./in.mp4 ./out.gif start_second duration quality 'Optional top text.' 'Optional bottom text.' +$ gifcurry_cli -i inputFile -o outputFile -s startTime -d durationTime -w widthSize -q qualityPercent -t topText -b bottomText ``` ## CLI Example ```Bash -~/gifcurry ❯❯❯ gifcurry ./02_gran_dillama_1080p.mp4 ./out.gif 32 8 500 100 'What is' 'Gifcurry?' +~/gifcurry ❯❯❯ ./gifcurry_cli -i ./02_gran_dillama_1080p.mp4 -o ./out.gif -s 32 -d 8 -w 500 -q 100 -t 'What is' -b 'Gifcurry?' _____ _ __ | __ (_)/ _| | | \/_| |_ ___ _ _ _ __ _ __ _ _ @@ -37,6 +37,7 @@ Gifcurry (C) 2016 David Lettier. http://www.lettier.com/ Input file: ./02_gran_dillama_1080p.mp4 +Output file: ./out.gif Start second: 32 Duration: 8 seconds GIF width: 500px @@ -56,6 +57,7 @@ * [Graphics.UI.Gtk (gtk)](https://hackage.haskell.org/package/gtk3) * [System.Directory (directory)](https://hackage.haskell.org/package/directory) * [gtk2hs-buildtools](https://hackage.haskell.org/package/gtk2hs-buildtools) + * [cmdargs](https://hackage.haskell.org/package/cmdargs) * [FFmpeg](https://www.ffmpeg.org/download.html) * [ImageMagick](http://www.imagemagick.org/script/download.php) * [GTK+](http://www.gtk.org/download/index.php) @@ -64,7 +66,7 @@ ### Ubuntu/Mint -``` +```bash # Install FFmpeg & ImageMagick sudo add-apt-repository ppa:kirillshkrogalev/ffmpeg-next sudo apt-get update @@ -79,7 +81,7 @@ ### Arch Linux -``` +```bash # Install FFmpeg and ImageMagick # Install yaourt (https://archlinux.fr/yaourt-en) # AUR package: https://aur.archlinux.org/packages/gifcurry/ @@ -92,13 +94,14 @@ #### Prebuilt -``` +```bash # If you don't have Homebrew /usr/bin/ruby -e "$(curl -fsSL https://raw.githubusercontent.com/Homebrew/install/master/install)" brew install ffmpeg brew install imagemagick brew install ghostscript brew install wget +brew install gnome-icon-theme # Find the latest release at https://github.com/lettier/gifcurry/releases wget https://github.com/lettier/gifcurry/releases/download/*/gifcurry-macosx*.tar.gz tar xvfz gifcurry-macosx*.tar.gz @@ -109,7 +112,7 @@ #### Build -``` +```bash # If you don't have Homebrew /usr/bin/ruby -e "$(curl -fsSL https://raw.githubusercontent.com/Homebrew/install/master/install)" brew update @@ -127,6 +130,7 @@ brew install ffmpeg brew install imagemagick brew install ghostscript +brew install gnome-icon-theme git clone git@github.com:lettier/gifcurry.git cd gifcurry cabal sandbox init @@ -142,7 +146,7 @@ ### Hackage -``` +```bash # Install ghc and cabal-install # Install ffmpeg and imagemagick cabal update @@ -156,7 +160,7 @@ ### Github -``` +```bash # Install ghc and cabal-install # Install ffmpeg and imagemagick git clone git@github.com:lettier/gifcurry.git diff --git a/cli_src/Main.hs b/cli_src/Main.hs --- a/cli_src/Main.hs +++ b/cli_src/Main.hs @@ -1,34 +1,89 @@ -- David Lettier (C) 2016. http://www.lettier.com/ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NamedFieldPuns #-} + import System.Environment import System.Process import System.IO.Temp import System.Exit +import System.Console.CmdArgs +import Control.Monad import Data.List -import Gifcurry (gif) +import qualified Gifcurry (gif, GifParams(..), defaultGifParams, gifParamsValid) +data CliArgs = CliArgs { + inputFile :: [Char] + , outputFile :: [Char] + , startTime :: Float + , durationTime :: Float + , widthSize :: Int + , qualityPercent :: Float + , topText :: [Char] + , bottomText :: [Char] + } deriving (Data, Typeable, Show, Eq) + +cliargs = CliArgs { + inputFile = "" &= help "The input file path and name." + , outputFile = "" &= help "The output file path and name." + , startTime = 0.0 &= help "The start time in seconds for the first frame." + , durationTime = 1.0 &= help "How long in seconds from the start time." + , widthSize = 500 &= help "How wide the gif needs to be. Height will scale to match." + , qualityPercent = 100.0 &= help "Ranges from 0.0 to 100.0." + , topText = "" &= help "Any text you want to add to the top of the GIF." + , bottomText = "" &= help "Any text you want to add to the bottom of the GIF." + } &= summary "Gifcurry 2.0.0.0 (C) 2016 David Lettier" + main :: IO () main = do - args <- getArgs - if length args < 8 + args <- cmdArgs cliargs + let params = makeGifParams args + printHeader + paramsValid <- Gifcurry.gifParamsValid params + if paramsValid then do - prntheader - putStrLn "\nUsage: $ gifcurry input_file output_file start_sec duration width quality top_text bottom_text" - putStrLn "Example: $ gifcurry ./in.mp4 ./out.gif 3 10 600 80 'Top' 'Bottom'" - exitWith (ExitFailure 1) - else do - prntheader - result <- gif $ take 8 args + Gifcurry.gif params return () + else printUsage + return () -prntheader = do - putStrLn " _____ _ __ " - putStrLn "| __ (_)/ _| " - putStrLn "| | \\/_| |_ ___ _ _ _ __ _ __ _ _ " - putStrLn "| | __| | _/ __| | | | '__| '__| | | |" - putStrLn "| |_\\ \\ | || (__| |_| | | | | | |_| |" - putStrLn " \\____/_|_| \\___|\\__,_|_| |_| \\__, |" - putStrLn " __/ |" - putStrLn " |___/ " - putStrLn "\nGifcurry (C) 2016 David Lettier. http://www.lettier.com/" +makeGifParams :: CliArgs -> Gifcurry.GifParams +makeGifParams CliArgs { + inputFile + , outputFile + , startTime + , durationTime + , widthSize + , qualityPercent + , topText + , bottomText + } = Gifcurry.GifParams { + Gifcurry.inputFile = inputFile + , Gifcurry.outputFile = outputFile + , Gifcurry.startTime = startTime + , Gifcurry.durationTime = durationTime + , Gifcurry.widthSize = widthSize + , Gifcurry.qualityPercent = qualityPercent + , Gifcurry.topText = topText + , Gifcurry.bottomText = bottomText + } + +printUsage :: IO () +printUsage = mapM_ putStrLn [ + "\nUsage: \n\t$ gifcurry_cli -i inputFile -o outputFile -s startTime " ++ + "-d durationTime -w widthSize -q qualityPercent -t topText -b bottomText" + ] + +printHeader :: IO () +printHeader = mapM_ putStrLn [ + " _____ _ __ " + , "| __ (_)/ _| " + , "| | \\/_| |_ ___ _ _ _ __ _ __ _ _ " + , "| | __| | _/ __| | | | '__| '__| | | |" + , "| |_\\ \\ | || (__| |_| | | | | | |_| |" + , " \\____/_|_| \\___|\\__,_|_| |_| \\__, |" + , " __/ |" + , " |___/ " + , "\nGifcurry (C) 2016 David Lettier. http://www.lettier.com/" + ] diff --git a/gui_src/Main.hs b/gui_src/Main.hs --- a/gui_src/Main.hs +++ b/gui_src/Main.hs @@ -5,201 +5,216 @@ import System.Process import System.Info import System.IO.Temp -import Control.Monad +import Text.Read import Data.Char import Data.List +import Control.Monad import Control.Concurrent +import Control.Exception import Graphics.UI.Gtk import Graphics.UI.Gtk.Builder import Paths_Gifcurry -import Gifcurry (gif) +import Gifcurry (gif, GifParams(..), defaultGifParams, gifParamsValid) +main :: IO () main = do initGUI - builder <- build_builder + builder <- buildBuilder - window <- load_window builder "gifcurry_window" - start_time_entry <- load_entry builder "start_time_text_entry" - duration_entry <- load_entry builder "duration_text_entry" - width_entry <- load_entry builder "width_text_entry" - quality_entry <- load_entry builder "quality_text_entry" - top_text_entry <- load_entry builder "top_text_text_entry" - bottom_text_entry <- load_entry builder "bottom_text_text_entry" - output_file_name_entry <- load_entry builder "output_file_name_text_entry" - status_entry <- load_entry builder "status_text_entry" - input_file_button <- load_fc_button builder "input_file_button" - output_file_path_button <- load_fc_button builder "output_file_path_button" - create_button <- load_button builder "create_button" - open_button <- load_button builder "open_button" - giphy_button <- load_button builder "giphy_link_button" - imgur_button <- load_button builder "imgur_link_button" - first_frame_image <- load_image builder "first_frame_image" - last_frame_image <- load_image builder "last_frame_image" + window <- loadWindow builder "gifcurry_window" + startTimeEntry <- loadEntry builder "start_time_text_entry" + durationTimeEntry <- loadEntry builder "duration_text_entry" + widthEntry <- loadEntry builder "width_text_entry" + qualityEntry <- loadEntry builder "quality_text_entry" + topTextEntry <- loadEntry builder "top_text_text_entry" + bottomTextEntry <- loadEntry builder "bottom_text_text_entry" + outputFileNameEntry <- loadEntry builder "output_file_name_text_entry" + statusEntry <- loadEntry builder "status_text_entry" + inputFileButton <- loadFcButton builder "input_file_button" + outputFilePathButton <- loadFcButton builder "output_file_path_button" + createButton <- loadButton builder "create_button" + openButton <- loadButton builder "open_button" + giphyButton <- loadButton builder "giphy_link_button" + imgurButton <- loadButton builder "imgur_link_button" + firstFrameImage <- loadImage builder "first_frame_image" + lastFrameImage <- loadImage builder "last_frame_image" -- Bug in Glade does not allow setting the link button label. - buttonSetLabel giphy_button "Giphy" - buttonSetLabel imgur_button "Imgur" - - entrySetText quality_entry "100" - entrySetText width_entry "500" - - input_file_button `on` fileChooserButtonFileSet $ do - imageSetFromIconName first_frame_image "gtk-missing-image" IconSizeButton - imageSetFromIconName last_frame_image "gtk-missing-image" IconSizeButton - - start_time_entry `on` editableChanged $ - make_first_frame_preview input_file_button start_time_entry duration_entry first_frame_image last_frame_image - - duration_entry `on` editableChanged $ - make_last_frame_preview input_file_button start_time_entry duration_entry last_frame_image + buttonSetLabel giphyButton "Giphy" + buttonSetLabel imgurButton "Imgur" - create_button `on` buttonActivated $ do - input_file_text <- fileChooserGetFilename input_file_button - input_file_path_name <- case input_file_text of - Nothing -> return "" - Just file_path_name -> return file_path_name + entrySetText qualityEntry "100" + entrySetText widthEntry "500" - start_time <- entryGetText start_time_entry - duration <- entryGetText duration_entry + inputFileButton `on` fileChooserButtonFileSet $ do + imageSetFromIconName firstFrameImage "gtk-missing-image" IconSizeButton + imageSetFromIconName lastFrameImage "gtk-missing-image" IconSizeButton - width <- entryGetText width_entry - quality <- entryGetText quality_entry + startTimeEntry `on` editableChanged $ + makeFirstFramePreview inputFileButton startTimeEntry durationTimeEntry firstFrameImage lastFrameImage - top_text <- entryGetText top_text_entry - bottom_text <- entryGetText bottom_text_entry + durationTimeEntry `on` editableChanged $ + makeLastFramePreview inputFileButton startTimeEntry durationTimeEntry lastFrameImage - (output_gif_file_name, output_file_path_name) <- assemble_output_file_path_name output_file_path_button output_file_name_entry + createButton `on` buttonActivated $ do + inputFilePathName <- inputFileButtonGetText inputFileButton + startTime <- entryGetFloat startTimeEntry (-1.0) + durationTime <- entryGetFloat durationTimeEntry (-1.0) + widthSize' <- entryGetFloat widthEntry 0.0 + let widthSize = truncate widthSize' + qualityPercent <- entryGetFloat qualityEntry (-1.0) + topText <- entryGetText topTextEntry + bottomText <- entryGetText bottomTextEntry + (outputGifFileName, outputFilePathName) <- assembleOutputFilePathName outputFilePathButton outputFileNameEntry + let params = defaultGifParams { + inputFile = inputFilePathName + , outputFile = outputFilePathName + , startTime = startTime + , durationTime = durationTime + , widthSize = widthSize + , qualityPercent = qualityPercent + , topText = topText + , bottomText = bottomText + } + paramsValid <- gifParamsValid params - if ((length input_file_path_name) > 0 && (length output_file_path_name) > 5 && (length output_gif_file_name) > 4) + if paramsValid then do - forkIO $ do - entrySetText status_entry "One GIF coming up!" - result <- gif [ - input_file_path_name, - output_file_path_name, - start_time, - duration, - width, - quality, - top_text, - bottom_text ] - if result == 1 - then entrySetText status_entry "Did not work. Check your settings." - else entrySetText status_entry "Ready." - forkIO $ do - open_gif output_file_path_name - return () - return () + forkOS $ do + entrySetText statusEntry "One GIF coming up!" + success <- (ioSuccess . gif) params + if not success + then entrySetText statusEntry "Did not work. Check your settings." + else do + forkOS $ openGifCommand outputFilePathName + entrySetText statusEntry "Ready." return () - else entrySetText status_entry "File paths are wrong. Check your settings." - + else entrySetText statusEntry "Settings are wrong." return () - open_button `on` buttonActivated $ do - (_, output_file_path_name) <- assemble_output_file_path_name output_file_path_button output_file_name_entry - - fileExists <- doesFileExist output_file_path_name + openButton `on` buttonActivated $ do + (_, outputFilePathName) <- assembleOutputFilePathName outputFilePathButton outputFileNameEntry + fileExists <- doesFileExist outputFilePathName if fileExists then do - forkIO $ do - open_gif output_file_path_name - return () + forkIO $ openGifCommand outputFilePathName return () - else entrySetText status_entry "GIF does not exist. Check your settings." - + else entrySetText statusEntry "GIF does not exist. Check your settings." return () on window objectDestroy mainQuit widgetShowAll window mainGUI -load_window b = builderGetObject b castToWindow +loadWindow :: Builder -> (String -> IO Window) +loadWindow b = builderGetObject b castToWindow -load_entry b = builderGetObject b castToEntry +loadEntry :: Builder -> (String -> IO Entry) +loadEntry b = builderGetObject b castToEntry -load_fc_button b = builderGetObject b castToFileChooserButton +loadFcButton :: Builder -> (String -> IO FileChooserButton) +loadFcButton b = builderGetObject b castToFileChooserButton -load_button b = builderGetObject b castToButton +loadButton :: Builder -> (String -> IO Button) +loadButton b = builderGetObject b castToButton -load_image b = builderGetObject b castToImage +loadImage :: Builder -> (String -> IO Image) +loadImage b = builderGetObject b castToImage -build_builder = do +buildBuilder :: IO Builder +buildBuilder = do builder <- builderNew - glade_file <- getDataFileName "data/gui.glade" - builderAddFromFile builder glade_file - + gladeFile <- getDataFileName "data/gui.glade" + builderAddFromFile builder gladeFile return builder -assemble_output_file_path_name output_file_path_button output_file_name_entry = do - output_file_path_text <- fileChooserGetFilename output_file_path_button - output_file_path <- case output_file_path_text of +inputFileButtonGetText :: FileChooserButton -> IO [Char] +inputFileButtonGetText inputFileButton = do + inputFileButtonText <- fileChooserGetFilename inputFileButton + inputFilePathName <- case inputFileButtonText of Nothing -> return "" - Just dir -> return dir + Just inputFilePathName -> return inputFilePathName + fileExist <- doesFileExist inputFilePathName + if fileExist then return inputFilePathName else return "" - output_file_name <- entryGetText output_file_name_entry - let output_gif_file_name = output_file_name ++ ".gif" - let output_file_path_name = output_file_path ++ "/" ++ output_gif_file_name +entryGetFloat :: Entry -> Float -> IO Float +entryGetFloat e nothing = do + text <- entryGetText e + case readMaybe text :: Maybe Float of + Nothing -> return nothing + Just x -> return x - return (output_gif_file_name, output_file_path_name) +assembleOutputFilePathName :: FileChooserButton -> Entry -> IO ([Char], [Char]) +assembleOutputFilePathName outputFilePathButton outputFileNameEntry = do + outputFilePathText <- fileChooserGetFilename outputFilePathButton + outputFilePath <- case outputFilePathText of + Nothing -> return "" + Just dir -> return dir + outputFileName <- entryGetText outputFileNameEntry + let outputGifFileName = outputFileName ++ ".gif" + let outputFilePathName = outputFilePath ++ "/" ++ outputGifFileName + return (outputGifFileName, outputFilePathName) -open_gif output_file_path_name = spawnCommand $ command ++ output_file_path_name +openGifCommand :: [Char] -> IO () +openGifCommand outputFilePathName = do + fileExists <- doesFileExist outputFilePathName + when fileExists $ do + spawnCommand $ command ++ outputFilePathName + return () where command = if "linux" `isInfixOf` (fmap toLower System.Info.os) then "xdg-open " else "open " -reset_image i = imageSetFromIconName i "gtk-missing-image" IconSizeButton +resetImage :: Image -> IO () +resetImage image = imageSetFromIconName image "gtk-missing-image" IconSizeButton -make_gif_preview ifpn ofpn st btxt = gif [ - ifpn, - ofpn, - st, - "0.001", - "200", - "50", - "", - btxt ] +makeGifPreview :: [Char] -> [Char] -> Float -> [Char] -> IO (Either IOError String) +makeGifPreview inputFile outputFile startTime bottomText = gif $ defaultGifParams { + inputFile = inputFile + , outputFile = outputFile + , startTime = startTime + , durationTime = 0.001 + , widthSize = 200 + , qualityPercent = 50.0 + , bottomText = bottomText + } -make_last_frame_preview ifb ste de lfi = do +ioSuccess :: IO (Either IOError String) -> IO Bool +ioSuccess r = do + result <- r + case result of + Left err -> return False + Right val -> return True + +makeLastFramePreview :: FileChooserButton -> Entry -> Entry -> Image -> IO () +makeLastFramePreview inputFileButton startTimeEntry durationTimeEntry lastFrameImage = do forkIO $ - withTempDirectory "." "previews" $ \tmpDir -> do - input_file_text <- fileChooserGetFilename ifb - input_file_path_name <- case input_file_text of - Nothing -> return "" - Just file_path_name -> return file_path_name - start_time_text <- case (return $ entryGetText ste) of - Nothing -> return "" - Just start_time_text -> start_time_text - duration_text <- case (return $ entryGetText de) of - Nothing -> return "" - Just duration_text -> duration_text - if ((not (null input_file_path_name)) && (not (null start_time_text)) && (not (null duration_text))) then do - let output_file_path_name = tmpDir ++ "/end.gif" - let start_time_flt = read start_time_text :: Float - let duration_flt = read duration_text :: Float - let start_time = show $ start_time_flt + duration_flt - result <- make_gif_preview input_file_path_name output_file_path_name start_time " LAST FRAME " - if (result == 0) - then imageSetFromFile lfi output_file_path_name - else reset_image lfi - else reset_image lfi + withTempDirectory "." "previews" $ \tmpdir -> do + inputFilePathName <- inputFileButtonGetText inputFileButton + startTime <- entryGetFloat startTimeEntry (-1.0) + durationTime <- entryGetFloat durationTimeEntry 0.001 + let startTime' = startTime + durationTime + if not (null inputFilePathName) && (startTime' > 0.0) then do + let outputFilePathName = tmpdir ++ "/end.gif" + success <- ioSuccess $ makeGifPreview inputFilePathName outputFilePathName startTime' " LAST FRAME " + if success + then imageSetFromFile lastFrameImage outputFilePathName + else resetImage lastFrameImage + else resetImage lastFrameImage return () -make_first_frame_preview ifb ste de ffi lfi = do +makeFirstFramePreview :: FileChooserButton -> Entry -> Entry -> Image -> Image -> IO () +makeFirstFramePreview inputFileButton startTimeEntry durationTimeEntry firstFrameImage lastFrameImage = do forkIO $ do withTempDirectory "." "previews" $ \tmpDir -> do - input_file_text <- fileChooserGetFilename ifb - input_file_path_name <- case input_file_text of - Nothing -> return "" - Just file_path_name -> return file_path_name - start_time <- case (return $ entryGetText ste) of - Nothing -> return "" - Just start_time -> start_time - if ((not (null input_file_path_name)) && (not (null start_time))) then do - let output_file_path_name = tmpDir ++ "/start.gif" - result <- make_gif_preview input_file_path_name output_file_path_name start_time " FIRST FRAME " - if (result == 0) - then imageSetFromFile ffi output_file_path_name - else reset_image ffi - else reset_image ffi - make_last_frame_preview ifb ste de lfi + inputFilePathName <- inputFileButtonGetText inputFileButton + startTime <- entryGetFloat startTimeEntry (-1.0) + if (not $ null inputFilePathName) && (startTime >= 0.0) then do + let outputFilePathName = tmpDir ++ "/start.gif" + success <- ioSuccess $ makeGifPreview inputFilePathName outputFilePathName startTime " FIRST FRAME " + if success + then imageSetFromFile firstFrameImage outputFilePathName + else resetImage firstFrameImage + else resetImage firstFrameImage + makeLastFramePreview inputFileButton startTimeEntry durationTimeEntry lastFrameImage return ()