Gifcurry 2.0.0.2 → 2.1.0.0
raw patch · 17 files changed
+1264/−1020 lines, 17 filesdep +filepathdep +textbinary-added
Dependencies added: filepath, text
Files
- Gifcurry.cabal +60/−30
- Gifcurry.hs +0/−244
- README.md +61/−28
- cli_src/Main.hs +0/−89
- data/gui.glade +0/−403
- data/icon.ico binary
- dev/Paths_Gifcurry.hs +0/−6
- gui_src/Main.hs +0/−220
- sample.gif too large to diff
- src/cli/Main.hs +110/−0
- src/data/gui.glade +439/−0
- src/data/icon.ico binary
- src/data/icon2.ico binary
- src/dev/Paths_Gifcurry.hs +6/−0
- src/gui/Main.hs +215/−0
- src/lib/Gifcurry.hs +373/−0
- ui.gif too large to diff
Gifcurry.cabal view
@@ -1,40 +1,70 @@-name: Gifcurry-version: 2.0.0.2-synopsis: Create animated GIFs, overlaid with optional text, from video files.-description: GIF creation utility.-homepage: https://github.com/lettier/gifcurry-license: Apache-2.0-license-file: LICENSE-author: Lettier-maintainer: Lettier-copyright: (C) 2016 David Lettier-category: Graphics-build-type: Simple-extra-source-files: README.md, sample.gif, ui.gif, ./dev/Paths_Gifcurry.hs, ./data/icon.ico-data-files: data/gui.glade, data/icon.ico-data-dir: ./-cabal-version: >=1.10+name: Gifcurry+version: 2.1.0.0+synopsis: Create animated GIFs, overlaid with optional text, from video files.+description: GIF creation utility.+homepage: https://github.com/lettier/gifcurry+license: Apache-2.0+license-file: LICENSE+author: Lettier+maintainer: Lettier+copyright: (C) 2016 David Lettier+category: Graphics+build-type: Simple+extra-source-files: README.md+ , ./src/dev/Paths_Gifcurry.hs+ , ./src/data/icon.ico+ , ./src/data/icon2.ico+data-files: data/gui.glade+ , data/icon.ico+ , data/icon2.ico+data-dir: ./src/+cabal-version: >=1.10 source-repository head type: git location: https://github.com/lettier/gifcurry library- exposed-modules: Gifcurry- build-depends: base >=4.7 && <=4.9.0.0, process >=1.2 && <=1.4.2.0, temporary >=1.2 && <1.3, directory ==1.2.*- default-language: Haskell2010+ exposed-modules: Gifcurry+ build-depends: base >=4.7 && <=4.9.0.0+ , process >=1.2 && <=1.4.2.0+ , temporary >=1.2 && <1.3+ , directory ==1.2.*+ , text ==1.2.*+ , filepath ==1.4.*+ hs-source-dirs: ./src+ , ./src/lib/+ ghc-options: -Wall+ default-language: Haskell2010 executable gifcurry_gui- main-is: Main.hs- build-depends: base >=4.7 && <=4.9.0.0, gtk3 >=0.14 && <0.15, process >=1.2 && <=1.4.2.0, temporary >=1.2 && <1.3, directory ==1.2.*- other-modules: Paths_Gifcurry, Gifcurry- ghc-options: -O3 -threaded -with-rtsopts=-N- hs-source-dirs: gui_src, ./- default-language: Haskell2010+ main-is: Main.hs+ build-depends: base >=4.7 && <=4.9.0.0+ , gtk3 >=0.14 && <0.15+ , process >=1.2 && <=1.4.2.0+ , temporary >=1.2 && <1.3+ , directory ==1.2.*+ , text ==1.2.*+ , filepath ==1.4.*+ other-modules: Paths_Gifcurry, Gifcurry+ ghc-options: -O3 -threaded -with-rtsopts=-N -Wall+ hs-source-dirs: ./src/+ , ./src/gui/+ , ./src/lib/+ default-language: Haskell2010 executable gifcurry_cli- main-is: Main.hs- build-depends: base >=4.7 && <=4.9.0.0, process >=1.2 && <=1.4.2.0, temporary >=1.2 && <1.3, directory == 1.2.*, cmdargs ==0.10.*- other-modules: Gifcurry- hs-source-dirs: cli_src, ./- default-language: Haskell2010+ main-is: Main.hs+ build-depends: base >=4.7 && <=4.9.0.0+ , process >=1.2 && <=1.4.2.0+ , temporary >=1.2 && <1.3+ , directory == 1.2.*+ , cmdargs ==0.10.*+ , text ==1.2.*+ , filepath ==1.4.*+ other-modules: Gifcurry+ ghc-options: -Wall+ hs-source-dirs: ./src/+ , ./src/cli/+ , ./src/lib/+ default-language: Haskell2010
− Gifcurry.hs
@@ -1,244 +0,0 @@--- David Lettier (C) 2016. http://www.lettier.com/---- | Produces GIFs using FFmpeg and ImageMagick.--- The main function is 'gif'.-module Gifcurry (- gif- , GifParams(..)- , defaultGifParams- , gifParamsValid- ) where--import System.Environment-import System.Process-import System.IO.Temp-import System.Directory-import System.Exit-import Data.List-import Text.Printf-import Control.Exception-import Control.Monad---- | The data type record required by 'gif'.-data GifParams = GifParams {- inputFile :: String- , outputFile :: String- , startTime :: Float- , durationTime :: Float- , widthSize :: Int- , qualityPercent :: Float- , topText :: String- , bottomText :: String- } 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 <- 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.")---- | 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--printGifParams :: GifParams -> String -> 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- ]--tryFfmpeg :: GifParams -> String -> 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--tryConvert :: GifParams -> String -> 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]- ) ""- )--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 -> String -> String -> [String]-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 -> String -> 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
@@ -1,15 +1,15 @@-+ # Gifcurry -## UI+## GUI -+ ## Sample GIF - -Credit: [Caminandes: Gran Dillama - Blender Foundation](http://www.caminandes.com/)+ +Credit: [Caminandes 3: Llamigos (2016) - Blender Foundation](http://www.caminandes.com/) ## Description @@ -18,13 +18,32 @@ ## CLI Usage ```bash-$ gifcurry_cli -i inputFile -o outputFile -s startTime -d durationTime -w widthSize -q qualityPercent -t topText -b bottomText+$ gifcurry_cli \+ -i inputFile \+ -o outputFile \+ -s startTime \+ -d durationTime \+ -w widthSize \+ -q qualityPercent \+ -f fontChoice \+ -t topText \+ -b bottomText ``` ## CLI Example ```Bash-~/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?'+~/gifcurry ❯❯❯ ./gifcurry_cli \+ -i ./03_caminandes_llamigos_1080p.mp4 \+ -o ./out.gif \+ -s 42 \+ -d 4 \+ -w 600 \+ -q 100 \+ -f 'Roboto Condensed Bold Italic' \+ -t 'Download' \+ -b 'Gifcurry'+ _____ _ __ | __ (_)/ _| | | \/_| |_ ___ _ _ _ __ _ __ _ _ @@ -36,16 +55,18 @@ Gifcurry (C) 2016 David Lettier. http://www.lettier.com/ -Input file: ./02_gran_dillama_1080p.mp4+Input file: ./03_caminandes_llamigos_1080p.mp4 Output file: ./out.gif-Start second: 32-Duration: 8 seconds-GIF width: 500px+Start second: 42.000+Duration: 4.000 seconds+GIF width: 600px Quality: 100.0%-Top text: What is-Bottom text: Gifcurry?+Font Choice: Roboto Condensed Bold Italic+Top text: Download+Bottom text: Gifcurry -Writing temporary frames to... ./frames3617+Writing temporary frames to... ./frames13465+Font matched: Roboto-Condensed-Bold-Italic Writing your GIF to... ./out.gif Done. ```@@ -60,6 +81,7 @@ * [System.IO.Temp (temporary)](https://hackage.haskell.org/package/temporary) * [Graphics.UI.Gtk (gtk)](https://hackage.haskell.org/package/gtk3) * [System.Directory (directory)](https://hackage.haskell.org/package/directory)+ * [System.FilePath (filepath)](https://hackage.haskell.org/package/filepath) * [FFmpeg](https://www.ffmpeg.org/download.html) * [ImageMagick](http://www.imagemagick.org/script/download.php) * [GTK+](http://www.gtk.org/download/index.php)@@ -78,7 +100,7 @@ tar xvfz gifcurry-linux*.tar.gz cd gifcurry-linux*/bin ./gifcurry_gui-./gifcurry_cli+./gifcurry_cli -? ``` ### Arch Linux@@ -89,12 +111,12 @@ # AUR package: https://aur.archlinux.org/packages/gifcurry/ yaourt -S gifcurry gifcurry_gui-gifcurry_cli+gifcurry_cli -? ``` -### Mac OS X El Capitan+### macOS Sierra -#### Prebuilt+#### Binaries ```bash # If you don't have Homebrew@@ -109,10 +131,10 @@ tar xvfz gifcurry-macosx*.tar.gz cd gifcurry-macosx*/bin ./gifcurry_gui-./gifcurry_cli+./gifcurry_cli -? ``` -#### Build+#### Compile ```bash # If you don't have Homebrew@@ -133,17 +155,16 @@ brew install imagemagick brew install ghostscript brew install gnome-icon-theme-git clone git@github.com:lettier/gifcurry.git+mkdir gifcurry cd gifcurry cabal sandbox init cabal update-cabal configure cabal install alex happy -j cabal install gtk2hs-buildtools -j cabal install gifcurry -j cd .cabal-sandbox/bin/ ./gifcurry_gui-./gifcurry_cli+./gifcurry_cli -? ``` ### Hackage@@ -152,13 +173,12 @@ # Install ghc and cabal-install # Install ffmpeg and imagemagick cabal update-cabal configure cabal install alex happy -j cabal install gtk2hs-buildtools -j cabal install gifcurry -j cd ~/.cabal/bin ./gifcurry_gui-./gifcurry_cli+./gifcurry_cli -? ``` ### Github@@ -166,16 +186,29 @@ ```bash # Install ghc and cabal-install # Install ffmpeg and imagemagick+# Install GNU Make git clone git@github.com:lettier/gifcurry.git cd gifcurry/+make+make run_gui+make run_cli CLI_ARGS='-?'++# Or you can do++# Install ghc and cabal-install+# Install ffmpeg and imagemagick+git clone git@github.com:lettier/gifcurry.git+cd gifcurry/ cabal sandbox init cabal update-cabal configure cabal install alex happy -j cabal install gtk2hs-buildtools -j-cabal install -j+cabal install -j --dependencies-only+cabal configure+cabal build -j+cabal install -j --enable-relocatable ./.cabal-sandbox/bin/gifcurry_gui-./.cabal-sandbox/bin/gifcurry_cli+./.cabal-sandbox/bin/gifcurry_cli -? ``` ## License
− cli_src/Main.hs
@@ -1,89 +0,0 @@--- 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 qualified Gifcurry (gif, GifParams(..), defaultGifParams, gifParamsValid)--data CliArgs = CliArgs {- inputFile :: String- , outputFile :: String- , startTime :: Float- , durationTime :: Float- , widthSize :: Int- , qualityPercent :: Float- , topText :: String- , bottomText :: String- } 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 <- cmdArgs cliargs- let params = makeGifParams args- printHeader- paramsValid <- Gifcurry.gifParamsValid params- if paramsValid- then do- Gifcurry.gif params- return ()- else printUsage- return ()--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/"- ]
− data/gui.glade
@@ -1,403 +0,0 @@-<?xml version="1.0" encoding="UTF-8"?>-<!-- Generated with glade 3.19.0 -->-<interface>- <requires lib="gtk+" version="3.10"/>- <object class="GtkImage" id="create_icon">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="ypad">5</property>- <property name="stock">gtk-save</property>- </object>- <object class="GtkImage" id="open_icon">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="xpad">13</property>- <property name="ypad">5</property>- <property name="stock">gtk-open</property>- </object>- <object class="GtkWindow" id="gifcurry_window">- <property name="width_request">400</property>- <property name="can_focus">False</property>- <property name="valign">center</property>- <property name="title">Gifcurry - lettier.com</property>- <property name="resizable">False</property>- <property name="window_position">mouse</property>- <property name="default_width">400</property>- <property name="icon">icon.ico</property>- <property name="gravity">center</property>- <child>- <object class="GtkBox" id="app_box">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="orientation">vertical</property>- <child>- <object class="GtkFileChooserButton" id="input_file_button">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="tooltip_text" translatable="yes">Select an input file.</property>- <property name="do_overwrite_confirmation">True</property>- <property name="local_only">False</property>- <property name="title" translatable="yes">Select an Input File</property>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="position">0</property>- </packing>- </child>- <child>- <object class="GtkBox" id="start_duration_box">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="homogeneous">True</property>- <child>- <object class="GtkEntry" id="start_time_text_entry">- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="tooltip_text" translatable="yes">Start time.</property>- <property name="shadow_type">none</property>- <property name="primary_icon_stock">gtk-media-play</property>- <property name="placeholder_text" translatable="yes">Start Time (seconds)</property>- <property name="input_purpose">number</property>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="position">0</property>- </packing>- </child>- <child>- <object class="GtkEntry" id="duration_text_entry">- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="tooltip_text" translatable="yes">Duration.</property>- <property name="width_chars">0</property>- <property name="primary_icon_stock">gtk-media-stop</property>- <property name="placeholder_text" translatable="yes">Duration (seconds)</property>- <property name="input_purpose">number</property>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="position">1</property>- </packing>- </child>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="position">1</property>- </packing>- </child>- <child>- <object class="GtkBox" id="optional_text_box">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="orientation">vertical</property>- <child>- <object class="GtkBox" id="width_quality_box">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="homogeneous">True</property>- <child>- <object class="GtkEntry" id="width_text_entry">- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="tooltip_text" translatable="yes">GIF width in px.</property>- <property name="shadow_type">none</property>- <property name="primary_icon_stock">gtk-justify-fill</property>- <property name="secondary_icon_tooltip_text" translatable="yes">The width of the GIF.</property>- <property name="placeholder_text" translatable="yes">Width</property>- <property name="input_purpose">number</property>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="position">0</property>- </packing>- </child>- <child>- <object class="GtkEntry" id="quality_text_entry">- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="tooltip_text" translatable="yes">GIF quality from 1 to 100.</property>- <property name="max_length">3</property>- <property name="width_chars">3</property>- <property name="max_width_chars">3</property>- <property name="primary_icon_stock">gtk-preferences</property>- <property name="secondary_icon_tooltip_text" translatable="yes">The quality of the GIF between 1 and 100.</property>- <property name="placeholder_text" translatable="yes">Quality [1-100]</property>- <property name="input_purpose">number</property>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="position">1</property>- </packing>- </child>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="position">0</property>- </packing>- </child>- <child>- <object class="GtkEntry" id="top_text_text_entry">- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="tooltip_text" translatable="yes">Optional top text.</property>- <property name="primary_icon_stock">gtk-italic</property>- <property name="secondary_icon_tooltip_text" translatable="yes">Text will show up at the top of the GIF.</property>- <property name="placeholder_text" translatable="yes">Optional top text.</property>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="position">1</property>- </packing>- </child>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="position">2</property>- </packing>- </child>- <child>- <object class="GtkEntry" id="bottom_text_text_entry">- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="tooltip_text" translatable="yes">Optional bottom text.</property>- <property name="primary_icon_stock">gtk-italic</property>- <property name="secondary_icon_tooltip_text" translatable="yes">Text will show up at the bottom of the GIF.</property>- <property name="placeholder_text" translatable="yes">Optional bottom text.</property>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="position">3</property>- </packing>- </child>- <child>- <object class="GtkFileChooserButton" id="output_file_path_button">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="tooltip_text" translatable="yes">Select an output folder.</property>- <property name="action">select-folder</property>- <property name="title" translatable="yes">Select an Output Folder</property>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="position">4</property>- </packing>- </child>- <child>- <object class="GtkSeparator" id="separator1">- <property name="visible">True</property>- <property name="can_focus">False</property>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="position">5</property>- </packing>- </child>- <child>- <object class="GtkEntry" id="output_file_name_text_entry">- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="tooltip_text" translatable="yes">Output file name.</property>- <property name="shadow_type">none</property>- <property name="primary_icon_stock">gtk-file</property>- <property name="placeholder_text" translatable="yes">Output file name.</property>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="position">6</property>- </packing>- </child>- <child>- <object class="GtkBox" id="frame_images_box">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="homogeneous">True</property>- <child>- <object class="GtkImage" id="first_frame_image">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="tooltip_text" translatable="yes">First frame preview.</property>- <property name="halign">center</property>- <property name="valign">center</property>- <property name="stock">gtk-missing-image</property>- </object>- <packing>- <property name="expand">True</property>- <property name="fill">True</property>- <property name="position">0</property>- </packing>- </child>- <child>- <object class="GtkImage" id="last_frame_image">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="tooltip_text" translatable="yes">Last frame preview.</property>- <property name="opacity">0.96999999999999997</property>- <property name="halign">center</property>- <property name="valign">center</property>- <property name="stock">gtk-missing-image</property>- </object>- <packing>- <property name="expand">True</property>- <property name="fill">True</property>- <property name="pack_type">end</property>- <property name="position">1</property>- </packing>- </child>- </object>- <packing>- <property name="expand">True</property>- <property name="fill">True</property>- <property name="position">7</property>- </packing>- </child>- <child>- <placeholder/>- </child>- <child>- <object class="GtkBox" id="save_open_box">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="homogeneous">True</property>- <child>- <object class="GtkButton" id="create_button">- <property name="label">Create</property>- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="receives_default">True</property>- <property name="tooltip_text" translatable="yes">Create the GIF.</property>- <property name="image">create_icon</property>- <property name="relief">half</property>- <property name="image_position">top</property>- <property name="always_show_image">True</property>- </object>- <packing>- <property name="expand">True</property>- <property name="fill">True</property>- <property name="position">0</property>- </packing>- </child>- <child>- <object class="GtkButton" id="open_button">- <property name="label" translatable="yes">Open</property>- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="receives_default">True</property>- <property name="tooltip_text" translatable="yes">Open the GIF.</property>- <property name="image">open_icon</property>- <property name="relief">half</property>- <property name="image_position">top</property>- <property name="always_show_image">True</property>- </object>- <packing>- <property name="expand">True</property>- <property name="fill">True</property>- <property name="pack_type">end</property>- <property name="position">1</property>- </packing>- </child>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="position">11</property>- </packing>- </child>- <child>- <object class="GtkBox" id="link_box">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="homogeneous">True</property>- <child>- <object class="GtkLinkButton" id="giphy_link_button">- <property name="label" translatable="yes">button</property>- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="receives_default">True</property>- <property name="tooltip_text" translatable="yes">https://giphy.com/create/upload</property>- <property name="relief">half</property>- <property name="uri">https://giphy.com/create/upload</property>- </object>- <packing>- <property name="expand">True</property>- <property name="fill">True</property>- <property name="position">0</property>- </packing>- </child>- <child>- <object class="GtkLinkButton" id="imgur_link_button">- <property name="label" translatable="yes">button</property>- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="receives_default">True</property>- <property name="tooltip_text" translatable="yes">https://www.imgur.com/</property>- <property name="relief">half</property>- <property name="uri">https://www.imgur.com/</property>- </object>- <packing>- <property name="expand">True</property>- <property name="fill">True</property>- <property name="position">1</property>- </packing>- </child>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="position">12</property>- </packing>- </child>- <child>- <object class="GtkBox" id="status_box">- <property name="visible">True</property>- <property name="sensitive">False</property>- <property name="can_focus">False</property>- <property name="hexpand">True</property>- <property name="vexpand">True</property>- <property name="baseline_position">top</property>- <child>- <object class="GtkEntry" id="status_text_entry">- <property name="visible">True</property>- <property name="sensitive">False</property>- <property name="app_paintable">True</property>- <property name="can_focus">False</property>- <property name="hexpand">True</property>- <property name="vexpand">True</property>- <property name="editable">False</property>- <property name="has_frame">False</property>- <property name="text" translatable="yes">Ready.</property>- <property name="shadow_type">none</property>- <property name="caps_lock_warning">False</property>- <property name="primary_icon_stock">gtk-info</property>- <property name="secondary_icon_activatable">False</property>- <property name="secondary_icon_sensitive">False</property>- </object>- <packing>- <property name="expand">True</property>- <property name="fill">True</property>- <property name="position">0</property>- </packing>- </child>- </object>- <packing>- <property name="expand">True</property>- <property name="fill">True</property>- <property name="position">13</property>- </packing>- </child>- </object>- </child>- </object>-</interface>
− data/icon.ico
binary file changed (4286 → absent bytes)
− dev/Paths_Gifcurry.hs
@@ -1,6 +0,0 @@-module Paths_Gifcurry where--getDataFileName :: FilePath -> IO FilePath-getDataFileName a = do- putStrLn "You are using a fake Paths_Gifcurry."- return a
− gui_src/Main.hs
@@ -1,220 +0,0 @@--- David Lettier (C) 2016. http://www.lettier.com/--import System.Environment-import System.Directory-import System.Process-import System.Info-import System.IO.Temp-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, GifParams(..), defaultGifParams, gifParamsValid)--main :: IO ()-main = do- initGUI-- builder <- buildBuilder-- 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 giphyButton "Giphy"- buttonSetLabel imgurButton "Imgur"-- entrySetText qualityEntry "100"- entrySetText widthEntry "500"-- inputFileButton `on` fileChooserButtonFileSet $ do- imageSetFromIconName firstFrameImage "gtk-missing-image" IconSizeButton- imageSetFromIconName lastFrameImage "gtk-missing-image" IconSizeButton-- startTimeEntry `on` editableChanged $- makeFirstFramePreview inputFileButton startTimeEntry durationTimeEntry firstFrameImage lastFrameImage-- durationTimeEntry `on` editableChanged $- makeLastFramePreview inputFileButton startTimeEntry durationTimeEntry lastFrameImage-- 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 paramsValid- then do- forkOS $ do- postGUIAsync $ entrySetText statusEntry "One GIF coming up!"- success <- (ioSuccess . gif) params- if not success- then postGUIAsync $ entrySetText statusEntry "Did not work. Check your settings."- else do- forkOS $ openGifCommand outputFilePathName- postGUIAsync $ entrySetText statusEntry "Ready."- return ()- else entrySetText statusEntry "Settings are wrong."- return ()-- openButton `on` buttonActivated $ do- (_, outputFilePathName) <- assembleOutputFilePathName outputFilePathButton outputFileNameEntry- fileExists <- doesFileExist outputFilePathName- if fileExists- then do- forkIO $ openGifCommand outputFilePathName- return ()- else entrySetText statusEntry "GIF does not exist. Check your settings."- return ()-- on window objectDestroy mainQuit- widgetShowAll window- mainGUI--loadWindow :: Builder -> (String -> IO Window)-loadWindow b = builderGetObject b castToWindow--loadEntry :: Builder -> (String -> IO Entry)-loadEntry b = builderGetObject b castToEntry--loadFcButton :: Builder -> (String -> IO FileChooserButton)-loadFcButton b = builderGetObject b castToFileChooserButton--loadButton :: Builder -> (String -> IO Button)-loadButton b = builderGetObject b castToButton--loadImage :: Builder -> (String -> IO Image)-loadImage b = builderGetObject b castToImage--buildBuilder :: IO Builder-buildBuilder = do- builder <- builderNew- gladeFile <- getDataFileName "data/gui.glade"- builderAddFromFile builder gladeFile- return builder--inputFileButtonGetText :: FileChooserButton -> IO String-inputFileButtonGetText inputFileButton = do- inputFileButtonText <- fileChooserGetFilename inputFileButton- inputFilePathName <- case inputFileButtonText of- Nothing -> return ""- Just inputFilePathName -> return inputFilePathName- fileExist <- doesFileExist inputFilePathName- if fileExist then return inputFilePathName else return ""--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--assembleOutputFilePathName :: FileChooserButton -> Entry -> IO (String, String)-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)--openGifCommand :: String -> 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 "--resetImage :: Image -> IO ()-resetImage image = imageSetFromIconName image "gtk-missing-image" IconSizeButton--makeGifPreview :: String -> String -> Float -> String -> 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- }--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- 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 postGUISync $ imageSetFromFile lastFrameImage outputFilePathName- else postGUISync $ resetImage lastFrameImage- else postGUIAsync $ resetImage lastFrameImage- return ()--makeFirstFramePreview :: FileChooserButton -> Entry -> Entry -> Image -> Image -> IO ()-makeFirstFramePreview inputFileButton startTimeEntry durationTimeEntry firstFrameImage lastFrameImage = do- forkIO $ do- withTempDirectory "." "previews" $ \tmpDir -> do- 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 postGUISync $ imageSetFromFile firstFrameImage outputFilePathName- else postGUISync $ resetImage firstFrameImage- else postGUISync $ resetImage firstFrameImage- makeLastFramePreview inputFileButton startTimeEntry durationTimeEntry lastFrameImage- return ()
− sample.gif
file too large to diff
+ src/cli/Main.hs view
@@ -0,0 +1,110 @@+-- David Lettier (C) 2016. http://www.lettier.com/++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NamedFieldPuns #-}++import System.Console.CmdArgs++import qualified Gifcurry++data CliArgs = CliArgs {+ inputFile :: String+ , outputFile :: String+ , startTime :: Float+ , durationTime :: Float+ , widthSize :: Int+ , qualityPercent :: Float+ , fontChoice :: String+ , topText :: String+ , bottomText :: String+ } deriving (Data, Typeable, Show, Eq)++cliArgs :: CliArgs+cliArgs = CliArgs {+ inputFile = "" &= typFile &= help "The input video file path and name."+ , outputFile = "" &= typFile &= help "The output GIF file path and name."+ , startTime = 0.0 &= help "The start time (in seconds) for the first frame."+ , durationTime = 1.0 &= help "How long the GIF lasts (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."+ , fontChoice = "default" &= help "Choose your desired font for the top and bottom text."+ , topText = "" &= help "The text you wish to add to the top of the GIF."+ , bottomText = "" &= help "The text you wish to add to the bottom of the GIF."+ -- VERSION+ } &= summary "Gifcurry 2.1.0.0 (C) 2016 David Lettier"+ &= program "gifcurry_cli"++main :: IO ()+main = do+ cliArgs' <- cmdArgs cliArgs+ let params = makeGifParams cliArgs'+ printHeader+ paramsValid <- Gifcurry.gifParamsValid params+ if paramsValid+ then do+ _ <- Gifcurry.gif params+ return ()+ else printUsage+ return ()++makeGifParams :: CliArgs -> Gifcurry.GifParams+makeGifParams CliArgs {+ inputFile+ , outputFile+ , startTime+ , durationTime+ , widthSize+ , qualityPercent+ , fontChoice+ , topText+ , bottomText+ } = Gifcurry.GifParams {+ Gifcurry.inputFile = inputFile+ , Gifcurry.outputFile = outputFile+ , Gifcurry.startTime = startTime+ , Gifcurry.durationTime = durationTime+ , Gifcurry.widthSize = widthSize+ , Gifcurry.qualityPercent = qualityPercent+ , Gifcurry.fontChoice = fontChoice+ , Gifcurry.topText = topText+ , Gifcurry.bottomText = bottomText+ }++printUsage :: IO ()+printUsage = putStrLn $ unwords [+ "\n"+ , "Usage:"+ , "\n\t"+ , "$ gifcurry_cli \\"+ , "\n\t"+ , "-i inputFile \\"+ , "\n\t"+ , "-o outputFile \\"+ , "\n\t"+ , "-s startTime \\"+ , "\n\t"+ , "-d durationTime \\"+ , "\n\t"+ , "-w widthSize \\"+ , "\n\t"+ , "-q qualityPercent \\"+ , "\n\t"+ , "-f fontChoice \\"+ , "\n\t"+ , "-t topText \\"+ , "\n\t"+ , "-b bottomText"+ ]++printHeader :: IO ()+printHeader = mapM_ putStrLn [+ " _____ _ __ "+ , "| __ (_)/ _| "+ , "| | \\/_| |_ ___ _ _ _ __ _ __ _ _ "+ , "| | __| | _/ __| | | | '__| '__| | | |"+ , "| |_\\ \\ | || (__| |_| | | | | | |_| |"+ , " \\____/_|_| \\___|\\__,_|_| |_| \\__, |"+ , " __/ |"+ , " |___/ "+ , "\nGifcurry (C) 2016 David Lettier. https://www.lettier.com/"+ ]
+ src/data/gui.glade view
@@ -0,0 +1,439 @@+<?xml version="1.0" encoding="UTF-8"?>+<!-- Generated with glade 3.20.0 -->+<interface>+ <requires lib="gtk+" version="3.10"/>+ <object class="GtkImage" id="create_icon">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="margin_top">5</property>+ <property name="margin_bottom">5</property>+ <property name="stock">gtk-save</property>+ <property name="icon_size">2</property>+ </object>+ <object class="GtkImage" id="open_icon">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="margin_top">5</property>+ <property name="margin_bottom">5</property>+ <property name="stock">gtk-open</property>+ <property name="icon_size">2</property>+ </object>+ <object class="GtkWindow" id="gifcurry_window">+ <property name="width_request">400</property>+ <property name="can_focus">False</property>+ <property name="valign">center</property>+ <property name="title">Gifcurry - lettier.com</property>+ <property name="resizable">False</property>+ <property name="window_position">mouse</property>+ <property name="default_width">400</property>+ <property name="icon">icon2.ico</property>+ <property name="gravity">center</property>+ <child>+ <object class="GtkBox" id="app_box">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="orientation">vertical</property>+ <child>+ <object class="GtkFileChooserButton" id="input_file_button">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="tooltip_text" translatable="yes">Select an input file.</property>+ <property name="do_overwrite_confirmation">True</property>+ <property name="local_only">False</property>+ <property name="title" translatable="yes">Select an Input File</property>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkBox" id="start_duration_box">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="homogeneous">True</property>+ <child>+ <object class="GtkEntry" id="start_time_text_entry">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="tooltip_text" translatable="yes">Start time.</property>+ <property name="shadow_type">none</property>+ <property name="primary_icon_stock">gtk-media-play</property>+ <property name="placeholder_text" translatable="yes">Start Time (seconds)</property>+ <property name="input_purpose">number</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkEntry" id="duration_text_entry">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="tooltip_text" translatable="yes">Duration.</property>+ <property name="width_chars">0</property>+ <property name="primary_icon_stock">gtk-media-stop</property>+ <property name="placeholder_text" translatable="yes">Duration (seconds)</property>+ <property name="input_purpose">number</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="position">1</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="position">1</property>+ </packing>+ </child>+ <child>+ <object class="GtkBox" id="width_quality_box">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="homogeneous">True</property>+ <child>+ <object class="GtkEntry" id="width_text_entry">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="tooltip_text" translatable="yes">GIF width in px.</property>+ <property name="shadow_type">none</property>+ <property name="primary_icon_stock">gtk-justify-fill</property>+ <property name="placeholder_text" translatable="yes">Width (pixels)</property>+ <property name="input_purpose">number</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkEntry" id="quality_text_entry">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="tooltip_text" translatable="yes">GIF quality from 1 to 100.</property>+ <property name="max_length">3</property>+ <property name="width_chars">3</property>+ <property name="max_width_chars">3</property>+ <property name="primary_icon_stock">gtk-preferences</property>+ <property name="placeholder_text" translatable="yes">Quality [1-100]</property>+ <property name="input_purpose">number</property>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">1</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">2</property>+ </packing>+ </child>+ <child>+ <object class="GtkFontButton" id="font_chooser_button">+ <property name="name">font_chooser_button</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ <property name="tooltip_text" translatable="yes">Choose your desired font for the bottom and top text.</property>+ <property name="font">Sans 12</property>+ <property name="preview_text">I love making GIFs with Gifcurry!</property>+ <property name="title" translatable="yes">Choose a Font</property>+ <property name="use_font">True</property>+ <property name="show_style">False</property>+ <property name="show_size">False</property>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">4</property>+ </packing>+ </child>+ <child>+ <object class="GtkEntry" id="top_text_text_entry">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="tooltip_text" translatable="yes">Optional top text.</property>+ <property name="primary_icon_stock">gtk-italic</property>+ <property name="placeholder_text" translatable="yes">Optional top text.</property>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">5</property>+ </packing>+ </child>+ <child>+ <object class="GtkEntry" id="bottom_text_text_entry">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="tooltip_text" translatable="yes">Optional bottom text.</property>+ <property name="primary_icon_stock">gtk-italic</property>+ <property name="secondary_icon_tooltip_text" translatable="yes">Text will show up at the bottom of the GIF.</property>+ <property name="placeholder_text" translatable="yes">Optional bottom text.</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="position">6</property>+ </packing>+ </child>+ <child>+ <object class="GtkSeparator" id="separator1">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="position">7</property>+ </packing>+ </child>+ <child>+ <object class="GtkFileChooserButton" id="output_file_path_button">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="tooltip_text" translatable="yes">Select an output folder.</property>+ <property name="action">select-folder</property>+ <property name="title" translatable="yes">Select an Output Folder</property>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">8</property>+ </packing>+ </child>+ <child>+ <object class="GtkEntry" id="output_file_name_text_entry">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="tooltip_text" translatable="yes">Output file name.</property>+ <property name="shadow_type">none</property>+ <property name="primary_icon_stock">gtk-file</property>+ <property name="placeholder_text" translatable="yes">Output file name.</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="position">9</property>+ </packing>+ </child>+ <child>+ <object class="GtkBox" id="frame_images_box">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <child>+ <object class="GtkImage" id="first_frame_image">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="tooltip_text" translatable="yes">First frame preview.</property>+ <property name="halign">center</property>+ <property name="valign">center</property>+ <property name="stock">gtk-discard</property>+ <property name="pixel_size">0</property>+ <property name="icon_size">0</property>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkImage" id="last_frame_image">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="tooltip_text" translatable="yes">Last frame preview.</property>+ <property name="halign">center</property>+ <property name="valign">center</property>+ <property name="stock">gtk-discard</property>+ <property name="pixel_size">0</property>+ <property name="icon_size">0</property>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="pack_type">end</property>+ <property name="position">1</property>+ </packing>+ </child>+ <child>+ <object class="GtkSeparator">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="orientation">vertical</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="position">2</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">10</property>+ </packing>+ </child>+ <child>+ <object class="GtkBox" id="save_open_box">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="homogeneous">True</property>+ <child>+ <object class="GtkButton" id="create_button">+ <property name="label">Create</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ <property name="tooltip_text" translatable="yes">Create the GIF.</property>+ <property name="image">create_icon</property>+ <property name="relief">half</property>+ <property name="image_position">top</property>+ <property name="always_show_image">True</property>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkButton" id="open_button">+ <property name="label" translatable="yes">Open</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ <property name="tooltip_text" translatable="yes">Open the GIF.</property>+ <property name="image">open_icon</property>+ <property name="relief">half</property>+ <property name="image_position">top</property>+ <property name="always_show_image">True</property>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="pack_type">end</property>+ <property name="position">1</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="position">11</property>+ </packing>+ </child>+ <child>+ <object class="GtkBox" id="link_box">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="homogeneous">True</property>+ <child>+ <object class="GtkLinkButton" id="giphy_link_button">+ <property name="label" translatable="yes">button</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ <property name="tooltip_text" translatable="yes">https://giphy.com/create/upload</property>+ <property name="halign">end</property>+ <property name="uri">https://giphy.com/create/upload</property>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkSeparator">+ <property name="visible">True</property>+ <property name="sensitive">False</property>+ <property name="can_focus">False</property>+ <property name="double_buffered">False</property>+ <property name="halign">baseline</property>+ <property name="valign">baseline</property>+ <property name="orientation">vertical</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">1</property>+ </packing>+ </child>+ <child>+ <object class="GtkLinkButton" id="imgur_link_button">+ <property name="label" translatable="yes">button</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ <property name="tooltip_text" translatable="yes">https://www.imgur.com/</property>+ <property name="halign">start</property>+ <property name="uri">https://imgur.com/upload</property>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="pack_type">end</property>+ <property name="position">2</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="position">12</property>+ </packing>+ </child>+ <child>+ <object class="GtkBox" id="status_box">+ <property name="visible">True</property>+ <property name="sensitive">False</property>+ <property name="can_focus">False</property>+ <property name="hexpand">True</property>+ <property name="vexpand">True</property>+ <property name="baseline_position">top</property>+ <child>+ <object class="GtkEntry" id="status_text_entry">+ <property name="visible">True</property>+ <property name="sensitive">False</property>+ <property name="app_paintable">True</property>+ <property name="can_focus">False</property>+ <property name="hexpand">True</property>+ <property name="vexpand">True</property>+ <property name="editable">False</property>+ <property name="has_frame">False</property>+ <property name="text" translatable="yes">Ready.</property>+ <property name="shadow_type">none</property>+ <property name="caps_lock_warning">False</property>+ <property name="primary_icon_stock">gtk-about</property>+ <property name="secondary_icon_activatable">False</property>+ <property name="secondary_icon_sensitive">False</property>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">0</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">13</property>+ </packing>+ </child>+ </object>+ </child>+ </object>+</interface>
+ src/data/icon.ico view
binary file changed (absent → 4286 bytes)
+ src/data/icon2.ico view
binary file changed (absent → 16958 bytes)
+ src/dev/Paths_Gifcurry.hs view
@@ -0,0 +1,6 @@+module Paths_Gifcurry where++getDataFileName :: FilePath -> IO FilePath+getDataFileName a = do+ putStrLn "You are using a fake Paths_Gifcurry."+ return a
+ src/gui/Main.hs view
@@ -0,0 +1,215 @@+-- David Lettier (C) 2016. http://www.lettier.com/++import System.Directory+import System.Process+import System.Info+import System.IO.Temp+import Text.Read+import Data.Maybe+import Data.Either+import Data.Char+import Data.List+import Control.Monad+import Control.Concurrent+import Graphics.UI.Gtk++import Paths_Gifcurry+import qualified Gifcurry (gif, GifParams(..), defaultGifParams, gifParamsValid)++main :: IO ()+main = do+ _ <- initGUI++ builder <- buildBuilder++ 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 <- loadFileChooserButton builder "input_file_button"+ outputFilePathButton <- loadFileChooserButton builder "output_file_path_button"+ fontChooserButton <- loadFontChooserButton builder "font_chooser_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 giphyButton "Giphy"+ buttonSetLabel imgurButton "Imgur"++ entrySetText qualityEntry "100"+ entrySetText widthEntry "500"++ _ <- inputFileButton `on` fileChooserButtonFileSet $ do+ imageSetFromIconName firstFrameImage blankPreviewIcon IconSizeButton+ imageSetFromIconName lastFrameImage blankPreviewIcon IconSizeButton++ _ <- startTimeEntry `on` editableChanged $+ makeFirstFramePreview inputFileButton startTimeEntry durationTimeEntry firstFrameImage lastFrameImage++ _ <- durationTimeEntry `on` editableChanged $+ makeLastFramePreview inputFileButton startTimeEntry durationTimeEntry lastFrameImage++ _ <- 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)+ fontChoice <- fontButtonGetFontName fontChooserButton+ topText <- entryGetText topTextEntry+ bottomText <- entryGetText bottomTextEntry+ (_, outputFilePathName) <- assembleOutputFilePathName outputFilePathButton outputFileNameEntry+ let params = Gifcurry.defaultGifParams {+ Gifcurry.inputFile = inputFilePathName+ , Gifcurry.outputFile = outputFilePathName+ , Gifcurry.startTime = startTime+ , Gifcurry.durationTime = durationTime+ , Gifcurry.widthSize = widthSize+ , Gifcurry.qualityPercent = qualityPercent+ , Gifcurry.fontChoice = fontChoice+ , Gifcurry.topText = topText+ , Gifcurry.bottomText = bottomText+ }+ paramsValid <- Gifcurry.gifParamsValid params+ if paramsValid+ then void $ forkOS $ do+ postGUIAsync $ entrySetText statusEntry "One GIF coming up!"+ success <- (ioSuccess . Gifcurry.gif) params+ if not success+ then postGUIAsync $ entrySetText statusEntry "Did not work. Check your settings."+ else do+ _ <- forkOS $ postGUIAsync $ openGifCommand outputFilePathName+ postGUIAsync $ entrySetText statusEntry "Ready."+ else entrySetText statusEntry "Settings are wrong."++ _ <- openButton `on` buttonActivated $ do+ (_, outputFilePathName) <- assembleOutputFilePathName outputFilePathButton outputFileNameEntry+ fileExists <- doesFileExist outputFilePathName+ if fileExists+ then void $ forkIO $ postGUIAsync $ openGifCommand outputFilePathName+ else entrySetText statusEntry "GIF does not exist. Check your settings."++ _ <- on window objectDestroy mainQuit++ widgetShowAll window+ mainGUI++loadWindow :: Builder -> (String -> IO Window)+loadWindow b = builderGetObject b castToWindow++loadEntry :: Builder -> (String -> IO Entry)+loadEntry b = builderGetObject b castToEntry++loadFileChooserButton :: Builder -> (String -> IO FileChooserButton)+loadFileChooserButton b = builderGetObject b castToFileChooserButton++loadFontChooserButton :: Builder -> (String -> IO FontButton)+loadFontChooserButton b = builderGetObject b castToFontButton++loadButton :: Builder -> (String -> IO Button)+loadButton b = builderGetObject b castToButton++loadImage :: Builder -> (String -> IO Image)+loadImage b = builderGetObject b castToImage++buildBuilder :: IO Builder+buildBuilder = do+ builder <- builderNew+ gladeFile <- getDataFileName "data/gui.glade"+ builderAddFromFile builder gladeFile+ return builder++inputFileButtonGetText :: FileChooserButton -> IO String+inputFileButtonGetText inputFileButton = do+ inputFileButtonText <- fileChooserGetFilename inputFileButton+ inputFilePathName <- case inputFileButtonText of+ Nothing -> return ""+ Just inputFilePathName -> return inputFilePathName+ fileExist <- doesFileExist inputFilePathName+ if fileExist then return inputFilePathName else return ""++entryGetFloat :: Entry -> Float -> IO Float+entryGetFloat e nothing = fmap (\ t -> fromMaybe nothing (readMaybe t :: Maybe Float)) (entryGetText e)++assembleOutputFilePathName :: FileChooserButton -> Entry -> IO (String, String)+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)++openGifCommand :: String -> IO ()+openGifCommand outputFilePathName = do+ fileExists <- doesFileExist outputFilePathName+ when fileExists $ void (spawnCommand (command ++ outputFilePathName))+ where+ command :: String+ command = if "linux" `isInfixOf` fmap toLower System.Info.os then "xdg-open " else "open "++blankPreviewIcon :: String+blankPreviewIcon = "gtk-discard"++resetImage :: Image -> IO ()+resetImage image = imageSetFromIconName image blankPreviewIcon IconSizeButton++makeGifPreview :: String -> String -> Float -> String -> String -> IO (Either IOError String)+makeGifPreview inputFile outputFile startTime fontChoice bottomText = Gifcurry.gif $ Gifcurry.defaultGifParams {+ Gifcurry.inputFile = inputFile+ , Gifcurry.outputFile = outputFile+ , Gifcurry.startTime = startTime+ , Gifcurry.durationTime = 0.001+ , Gifcurry.widthSize = 200+ , Gifcurry.qualityPercent = 50.0+ , Gifcurry.fontChoice = fontChoice+ , Gifcurry.bottomText = bottomText+ }++ioSuccess :: IO (Either IOError String) -> IO Bool+ioSuccess = fmap isRight++makeLastFramePreview :: FileChooserButton -> Entry -> Entry -> Image -> IO ()+makeLastFramePreview inputFileButton startTimeEntry durationTimeEntry lastFrameImage = do+ _ <- forkIO $+ 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' "default" " LAST FRAME "+ if success+ then postGUISync $ imageSetFromFile lastFrameImage outputFilePathName+ else postGUISync $ resetImage lastFrameImage+ else postGUIAsync $ resetImage lastFrameImage+ return ()++makeFirstFramePreview :: FileChooserButton -> Entry -> Entry -> Image -> Image -> IO ()+makeFirstFramePreview inputFileButton startTimeEntry durationTimeEntry firstFrameImage lastFrameImage = do+ _ <- forkIO $ do+ withTempDirectory "." "previews" $ \tmpDir -> do+ 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 "default" " FIRST FRAME "+ if success+ then postGUISync $ imageSetFromFile firstFrameImage outputFilePathName+ else postGUISync $ resetImage firstFrameImage+ else postGUISync $ resetImage firstFrameImage+ makeLastFramePreview inputFileButton startTimeEntry durationTimeEntry lastFrameImage+ return ()
+ src/lib/Gifcurry.hs view
@@ -0,0 +1,373 @@+-- David Lettier (C) 2016. http://www.lettier.com/++{-# LANGUAGE OverloadedStrings #-}++-- | Produces GIFs using FFmpeg and ImageMagick.+-- The main function is 'gif'.+module Gifcurry (+ gif+ , GifParams(..)+ , defaultGifParams+ , gifParamsValid+ ) where++import System.Process+import System.IO.Temp+import System.Directory+import System.FilePath+import Text.Read+import Data.Maybe+import Data.List+import Data.Text+import Text.Printf+import Control.Exception+import Control.Monad++-- | The data type record required by 'gif'.+data GifParams = GifParams {+ inputFile :: String+ , outputFile :: String+ , startTime :: Float+ , durationTime :: Float+ , widthSize :: Int+ , qualityPercent :: Float+ , fontChoice :: String+ , topText :: String+ , bottomText :: String+ } deriving (Show, Read)++-- | Specifies default parameters for 'startTime', 'durationTime', 'widthSize', 'qualityPercent', and 'fontChoice'.+defaultGifParams :: GifParams+defaultGifParams = GifParams {+ inputFile = ""+ , outputFile = ""+ , startTime = 0.0+ , durationTime = 1.0+ , widthSize = 500+ , qualityPercent = 100.0+ , fontChoice = "default"+ , 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+ fFMpegResult <- tryFfmpeg gifParams tmpdir+ let fFMpegSuccess = eitherBool fFMpegResult+ if fFMpegSuccess+ then do+ fontMatch <- getFontMatch gifParams+ let gifParams' = gifParams { fontChoice = fontMatch }+ putStrLn $ "Writing your GIF to... " ++ outputFile gifParams+ convertResult <- tryConvert gifParams' tmpdir+ let convertSuccess = eitherBool convertResult+ if convertSuccess+ then putStrLn "Done."+ else putStrLn "[Error] Something went wrong with ImageMagick."+ return convertResult+ else do+ putStrLn "[Error] Something went wrong with FFmpeg."+ return fFMpegResult+ else return $ Left (userError "[Error] Invalid params.")+ where+ runFontMatch :: GifParams -> Bool+ runFontMatch GifParams { fontChoice = _, topText = "", bottomText = "" } = False+ runFontMatch GifParams { fontChoice = "default", topText = _, bottomText = _ } = False+ runFontMatch _ = True+ getFontMatch :: GifParams -> IO String+ getFontMatch gifParams'+ | runFontMatch gifParams' = do+ fontNames <- getListOfFontNames+ let match = bestFontNameMatch (fontChoice gifParams') fontNames+ putStrLn $ "Font matched: " ++ match+ return match+ | otherwise = defaultAction+ where+ defaultAction :: IO String+ defaultAction = putStrLn "Using the default font." >> return "default"+ eitherBool :: Either a b -> Bool+ eitherBool = either (const False) (const True)++-- | Outputs True or False if the parameters in the GifParams record 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 = _+ , bottomText = _+ } = do+ inputFileExists <- case Prelude.length ipf of+ 0 -> return False+ _ -> doesFileExist ipf+ unless inputFileExists $ putStrLn "\n[Error] Input video file does not exist."+ let outputFileValid = Prelude.length opf > 5+ unless outputFileValid $ putStrLn "\n[Error] Output GIF file is 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++printGifParams :: GifParams -> String -> IO ()+printGifParams+ GifParams {+ inputFile = ipf+ , outputFile = opf+ , startTime = st+ , durationTime = dt+ , widthSize = ws+ , qualityPercent = qp+ , fontChoice = fc+ , 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) ++ "%"+ , "Font Choice: " ++ fc+ , "Top text: " ++ tt+ , "Bottom text: " ++ bt+ , "\nWriting temporary frames to... " ++ tmpdir+ ]++tryFfmpeg :: GifParams -> String -> IO (Either IOError String)+tryFfmpeg+ GifParams {+ inputFile = ipf+ , startTime = st+ , durationTime = dt+ , widthSize = ws+ }+ tmpdir = try(readProcess "ffmpeg" params [])+ where+ sts = printf "%.3f" st+ dts = printf "%.3f" dt+ wss = show ws+ params = [+ "-nostats"+ , "-loglevel"+ , "panic"+ , "-an"+ , "-ss"+ , sts+ , "-i"+ , ipf+ , "-t"+ , dts+ , "-r"+ , "15"+ , "-q:v"+ , "2"+ , "-vf"+ , "scale=" ++ wss ++ ":-1"+ , "-f"+ , "image2"+ , tmpdir ++ "/%010d.png"+ ]++tryConvert :: GifParams -> String -> IO (Either IOError String)+tryConvert+ GifParams {+ outputFile = opf+ , qualityPercent = qp+ , fontChoice = fc+ , topText = tt+ , bottomText = bt+ }+ tmpdir = do+ maybeWidthHeight <- maybeGetFirstFrameFilePath tmpdir >>= maybeGetFirstFrameWidthHeight+ let params = [+ "-quiet"+ , "-delay"+ , "6"+ , "-colors"+ , show $ ncolors qp+ , "-coalesce"+ , "-layers"+ , "OptimizeTransparency"+ , "-layers"+ , "RemoveDups"+ , tmpdir ++ "/*.png"+ , "-dither"+ , "FloydSteinberg"+ , "-loop"+ , "0"+ ]+ ++ annotate fc maybeWidthHeight tt "north"+ ++ annotate fc maybeWidthHeight bt "south"+ ++ [opf]+ try (readProcess "convert" params [])++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 :: String -> Maybe (Int, Int) -> String -> String -> [String]+annotate fontChoiceArg maybeWidthHeight text topBottom = [+ "-gravity"+ , topBottom+ ] ++ fontSetting fontChoiceArg ++ [+ "-stroke"+ , "#000C"+ , "-strokewidth"+ , "10"+ , "-density"+ , "96"+ , "-pointsize"+ , pointsize+ , "-annotate"+ , "+0+10"+ , text+ , "-stroke"+ , "none"+ , "-fill"+ , "white"+ , "-density"+ , "96"+ , "-pointsize"+ , pointsize+ , "-annotate"+ , "+0+10"+ , text+ ]+ where+ pointsize :: String+ pointsize = show $ pointSize maybeWidthHeight text++-- @96 PPI: w 71 px x h 96 px+pointSize :: Maybe (Int, Int) -> String -> Int+pointSize Nothing _ = 0+pointSize (Just (width, height)) text+ | width <= 0 || height <= 0 = 0+ | textLength <= 0 = 0+ | otherwise = Prelude.minimum [widthLTHeight, widthGTEHeight]+ where+ textLength :: Int+ textLength = Prelude.length text+ width' :: Double+ width' = fromIntegral width+ height' :: Double+ height' = fromIntegral height+ textLength' :: Double+ textLength' = fromIntegral textLength+ widthLTHeight :: Int+ widthLTHeight = truncate $ ((width' * (5.0 / 7.0)) / textLength') * (96.0 / 71.0)+ widthGTEHeight :: Int+ widthGTEHeight = truncate $ height' * (1.0 / 5.0)++fontSetting :: String -> [String]+fontSetting "" = []+fontSetting "default" = []+fontSetting fc = ["-font", fc]++bestFontNameMatch :: String -> [Text] -> String+bestFontNameMatch _ [] = "default"+bestFontNameMatch _ [""] = "default"+bestFontNameMatch query fontNames = Data.Text.unpack $ bestMatch $ maximumMatch $ Data.Text.pack query+ where+ bestMatch :: (Int, Text) -> Text+ bestMatch (s, f) = if s <= 0 then "default" else f+ maximumMatch :: Text -> (Int, Text)+ maximumMatch query' =+ maximumBy (\ (ls, _) (rs, _) -> if ls >= rs then GT else LT) $+ Prelude.map (\ fontName -> (score query' (Data.Text.toLower fontName), fontName)) fontNames+ score :: Text -> Text -> Int+ score query' fontName = sum $ Prelude.map tokenScore (queryTokens query')+ where+ queryTokens :: Text -> [Text]+ queryTokens = Prelude.map cleanQueryToken . Data.Text.splitOn " "+ where+ cleanQueryToken :: Text -> Text+ cleanQueryToken = Data.Text.replace "," "" . Data.Text.toLower . Data.Text.strip+ tokenScore :: Text -> Int+ tokenScore token+ | Data.Text.length token < 1 = 0+ | Data.Text.isInfixOf token fontName = isInfixOfFontName token+ | otherwise = 0+ where+ isInfixOfFontName :: Text -> Int+ isInfixOfFontName token'+ | token' `elem` ["bold", "medium", "light", "regular", "italic"] = 1+ | isNothing (readMaybe (Data.Text.unpack token') :: Maybe Int) = 3+ | otherwise = 0++getListOfFontNames :: IO [Text]+getListOfFontNames = do+ (_, stdout, _) <- readProcessWithExitCode "convert" ["-list", "font"] []+ let fontNames = Prelude.map (Data.Text.strip . Data.Text.drop 5 . Data.Text.strip) $+ Prelude.filter (Data.Text.isInfixOf "font:" . Data.Text.toLower) $+ Data.Text.splitOn "\n" $+ Data.Text.strip $+ Data.Text.pack stdout+ return fontNames++maybeGetFirstFrameFilePath :: String -> IO (Maybe FilePath)+maybeGetFirstFrameFilePath tmpdir = try (makeAbsolute tmpdir) >>= tryListDir >>= maybeFirstFilePath+ where+ tryListDir :: Either IOError FilePath -> IO (FilePath, Either IOError [FilePath])+ tryListDir (Left y) = return ("", Left y)+ tryListDir (Right dir) = try (listDirectory dir) >>= \ e -> return (dir, e)+ maybeFirstFilePath :: (FilePath, Either IOError [FilePath]) -> IO (Maybe FilePath)+ maybeFirstFilePath (_, Left _) = return Nothing+ maybeFirstFilePath (_, Right []) = return Nothing+ maybeFirstFilePath (dir, Right (x:_)) = return (Just (normalise $ joinPath [dir, x]))++maybeGetFirstFrameWidthHeight :: Maybe FilePath -> IO (Maybe (Int, Int))+maybeGetFirstFrameWidthHeight Nothing = return Nothing+maybeGetFirstFrameWidthHeight (Just dir) =+ readProcessWithExitCode "identify" [dir] [] >>=+ \ (_, stdout, _) -> maybeConvertWidthHeightString $ findWidthHeightString $ splitOn " " $ Data.Text.pack stdout+ where+ findWidthHeightString :: [Text] -> Text+ findWidthHeightString (_:_:c:_:_:_:_:_:_:_) = c+ findWidthHeightString _ = ""+ maybeConvertWidthHeightString :: Text -> IO (Maybe (Int, Int))+ maybeConvertWidthHeightString "" = return Nothing+ maybeConvertWidthHeightString s = if Prelude.length splitOnX == 2+ then return (Just (pluckWidth splitOnX, pluckHeight splitOnX))+ else return Nothing+ where+ splitOnX :: [Text]+ splitOnX = splitOn "x" $ Data.Text.toLower s+ pluckWidth :: [Text] -> Int+ pluckWidth (x:_:_) = read (Data.Text.unpack x) :: Int+ pluckWidth _ = 0+ pluckHeight :: [Text] -> Int+ pluckHeight (_:y:_) = read (Data.Text.unpack y) :: Int+ pluckHeight _ = 0
− ui.gif
file too large to diff