Gifcurry 0.1.1.0 → 2.0.0.0
raw patch · 5 files changed
+479/−272 lines, 5 filesdep +cmdargs
Dependencies added: cmdargs
Files
- Gifcurry.cabal +7/−2
- Gifcurry.hs +227/−99
- README.md +12/−8
- cli_src/Main.hs +75/−20
- gui_src/Main.hs +158/−143
Gifcurry.cabal view
@@ -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
Gifcurry.hs view
@@ -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)
README.md view
@@ -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
cli_src/Main.hs view
@@ -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/"+ ]
gui_src/Main.hs view
@@ -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 ()