diff --git a/Gifcurry.cabal b/Gifcurry.cabal
--- a/Gifcurry.cabal
+++ b/Gifcurry.cabal
@@ -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
diff --git a/Gifcurry.hs b/Gifcurry.hs
deleted file mode 100644
--- a/Gifcurry.hs
+++ /dev/null
@@ -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)
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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
diff --git a/cli_src/Main.hs b/cli_src/Main.hs
deleted file mode 100644
--- a/cli_src/Main.hs
+++ /dev/null
@@ -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/"
- ]
diff --git a/data/gui.glade b/data/gui.glade
deleted file mode 100644
--- a/data/gui.glade
+++ /dev/null
@@ -1,403 +0,0 @@
-
-
-
-
-
-
-
-
diff --git a/data/icon.ico b/data/icon.ico
deleted file mode 100644
Binary files a/data/icon.ico and /dev/null differ
diff --git a/dev/Paths_Gifcurry.hs b/dev/Paths_Gifcurry.hs
deleted file mode 100644
--- a/dev/Paths_Gifcurry.hs
+++ /dev/null
@@ -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
diff --git a/gui_src/Main.hs b/gui_src/Main.hs
deleted file mode 100644
--- a/gui_src/Main.hs
+++ /dev/null
@@ -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 ()
diff --git a/sample.gif b/sample.gif
deleted file mode 100644
# file too large to diff: sample.gif
diff --git a/src/cli/Main.hs b/src/cli/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/cli/Main.hs
@@ -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/"
+ ]
diff --git a/src/data/gui.glade b/src/data/gui.glade
new file mode 100644
--- /dev/null
+++ b/src/data/gui.glade
@@ -0,0 +1,439 @@
+
+
+
+
+
+
+
+
diff --git a/src/data/icon.ico b/src/data/icon.ico
new file mode 100644
Binary files /dev/null and b/src/data/icon.ico differ
diff --git a/src/data/icon2.ico b/src/data/icon2.ico
new file mode 100644
Binary files /dev/null and b/src/data/icon2.ico differ
diff --git a/src/dev/Paths_Gifcurry.hs b/src/dev/Paths_Gifcurry.hs
new file mode 100644
--- /dev/null
+++ b/src/dev/Paths_Gifcurry.hs
@@ -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
diff --git a/src/gui/Main.hs b/src/gui/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/gui/Main.hs
@@ -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 ()
diff --git a/src/lib/Gifcurry.hs b/src/lib/Gifcurry.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/Gifcurry.hs
@@ -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
diff --git a/ui.gif b/ui.gif
deleted file mode 100644
# file too large to diff: ui.gif