diff --git a/CHANGELOG.md b/CHANGELOG.md index e6076c9..89a7cec 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,52 @@ ------------------------------------------------------------------------------- +### 4.0.0.0 + +#### Added + +- Multiple dynamic text overlays +- Text overlay YAML file option `-t` to CLI +- Text fill and outline color configuration +- Text start and duration time configuration +- Text origin, x translation, and y translation configuration +- Text overlay preview to GUI +- Text left and top placement entries to GUI +- Text rotation configuration +- Text outline size configuration +- Outline and fill color selectors to GUI +- Pattern to GUI crop preview +- `textOverlayOriginFromString` to library API +- `qualityFromString` to library API +- `TextOverlays` to library API +- `TextOverlay` to library API +- `TextOverlayOrigin` to library API +- `Quality` to library API +- Text overlay validation +- Time slices and video position display custom widget +- Video position clock +- Pause button for video preview + +#### Changed + +- Quality percent to quality nominal +- CLI Logo +- CLI help information +- GUI shows only file selection, info, and status on start up +- GUI crop preview color +- GUI preview size +- GUI icon size +- GUI first and last frame preview draw area to match the image size +- GUI takes the video URI from the inVideoPropertiesRef instead of the inFileChooserDialog during save +- Save as video bypasses GIF creation and goes straight to video creation +- Video output configuration + +#### Removed + +- CLI Icon + +------------------------------------------------------------------------------- + ### 3.0.0.2 #### Added diff --git a/Gifcurry.cabal b/Gifcurry.cabal index fa3b22c..1143ba4 100644 --- a/Gifcurry.cabal +++ b/Gifcurry.cabal @@ -1,5 +1,5 @@ name: Gifcurry -version: 3.0.0.2 +version: 4.0.0.0 synopsis: GIF creation utility. description: Your open source video to GIF maker. homepage: https://github.com/lettier/gifcurry @@ -37,13 +37,14 @@ source-repository head location: https://github.com/lettier/gifcurry library - exposed-modules: Gifcurry + exposed-modules: Gifcurry build-depends: base >= 4.7 && < 5 , process >= 1.2 && <= 1.4.4 , temporary >= 1.2 && < 1.3 , directory == 1.3.* , text == 1.2.* , filepath == 1.4.* + , filemanip == 0.3.6.* hs-source-dirs: ./src , ./src/lib/ ghc-options: -Wall -freverse-errors @@ -56,24 +57,28 @@ executable gifcurry_gui , haskell-gi-base == 0.21.* , gi-gobject == 2.0.* , gi-glib == 2.0.* + , gi-pango == 1.0.* , gi-gdk == 3.0.* , gi-gtk == 3.0.* , gi-cairo == 1.0.* , gi-gst == 1.0.* , gi-gstvideo == 1.0.* , cairo == 0.13.* + , pango == 0.13.* , bytestring == 0.10.* , process >= 1.2 && <= 1.4.4 , temporary >= 1.2 && < 1.3 , directory == 1.3.* , text == 1.2.* , filepath == 1.4.* + , filemanip == 0.3.6.* , transformers == 0.5.* other-modules: Paths_Gifcurry , GuiRecords , GuiCapabilities , Gifcurry , GuiStyle + , GuiTextOverlays , GuiPreview , GuiMisc @@ -95,6 +100,10 @@ executable gifcurry_cli , cmdargs == 0.10.* , text == 1.2.* , filepath == 1.4.* + , filemanip == 0.3.6.* + , aeson == 1.1.2.* + , bytestring == 0.10.8.* + , yaml == 0.8.23.* other-modules: Gifcurry ghc-options: -Wall -freverse-errors hs-source-dirs: ./src/ diff --git a/README.md b/README.md index 146cf23..f1f3ee3 100644 --- a/README.md +++ b/README.md @@ -1,8 +1,8 @@ -![Gifcurry](https://i.imgur.com/1omeH3m.png) +![Gifcurry](https://i.imgur.com/9pS8Ibp.png) # Tell me about Gifcurry. -Gifcurry is your only open source video to GIF maker built with Haskell. +Gifcurry is your only open source video-to-GIF maker built with Haskell. Load a video, make some edits, and save it as a GIF—it's that easy. Most video formats should work so go wild. And since it's made with Haskell, you know it's good. @@ -15,102 +15,125 @@ Gifcurry can save your creation as a GIF or as a video. So if you hate GIFs with a passion—no problem! Just select "save as video" and do your part to rid the world of GIFs. -Enjoy memes? Great! Gifcurry can add text to the top and/or the bottom of your GIF. -Just type in some text for the top or type in some text for the bottom or type in -some pithy text for both the top and bottom—Gifcurry don't care. -Oh and you can select the font too so you're never too far from Comic Sans. +Enjoy memes? Great! Gifcurry can add text all over your GIF. +You can change the font, size, color, position, outline, rotation, and the timing. +Create the next viral meme with Gifcurry. -Gifcurry caters to the power user with its crop tool. +Did you know Gifcurry slices...and dices? You can crop from the left, the right, the top, and/or the bottom. -With Gifcurry, you can cut out anything you don't want. +With Gifcurry, you can slice up some tasty GIFs. -Is Gifcurry another Electron app? No way! Gifcurry is 100% #electronfree. +Is Gifcurry another Electron app? No way! Gifcurry is 100% #ElectronFree. No need to download more RAM, Gifcurry is light as a feather. Run it all day, run it all year—you'll never notice. -"So...Gifcurry is just FFmpeg and ImageMagick." Nope. +"So...Gifcurry is just FFmpeg and ImageMagick?"—nope. Gifcurry hides all the goofy details so you can concentrate on what matters—the almighty GIF. Making GIFs with Gifcurry is fun so try it out! ## What do I need Gifcurry for? -Need to show off that new UI feature in a pull request? Gifcurry. +Want to show off that new UI feature in a pull request? Gifcurry. Your template doesn't allow video in the hero image? Gifcurry. No GIF of your favorite movie scene? Gifcurry. Need a custom animated emoji for Slack? Gifcurry. -Have an idea of the perfect GIF to close out that email? Gifcurry. +Can't find the perfect GIF for that reply-all email? Gifcurry. Your README needs a GIF? Gifcurry. +That presentation slide could use some animation? Gifcurry. Video doesn't auto play on iOS? Gifcurry. Gifcurry comes in handy for all sorts of scenarios. ## What does the GUI look like? -![Gifcurry GUI](https://i.imgur.com/dVpQfHq.gif) +![Gifcurry GUI](https://i.imgur.com/0aru7b0.gif) -## Got any sample GIFs? - -![GIF](https://i.imgur.com/alxcMli.gif) -![GIF](https://i.imgur.com/FUjIBm2.gif) ## How do I use the command line interface (CLI)? -```bash +```text gifcurry_cli [OPTIONS] FILE IO: - -i --input-file=FILE The input video file path and name. - -o --output-file=FILE The output GIF file path and name. - -m --save-as-video If present, saves the GIF as a video. + -i --input-file=FILE The input video file path and name. + -o --output-file=FILE The output GIF file path and name. + -m --save-as-video If present, saves the GIF as a video. TIME: - -s --start-time=NUM The start time (in seconds) for the first frame. - -d --duration-time=NUM How long the GIF lasts (in seconds) from the - start time. + -s --start-time=NUM The start time (in seconds) for the first + frame. + -d --duration-time=NUM How long the GIF lasts (in seconds) from the + start time. OUTPUT FILE SIZE: - -w --width-size=INT How wide the GIF needs to be. Height will scale - to match. - -q --quality-percent=NUM From 1 (very low quality) to 100 (the best - quality). Controls how many colors are used and how - many frames per second there are. -TEXT: - -f --font-choice=TEXT Choose your desired font for the top and bottom - text. - -t --top-text=TEXT The text you wish to add to the top of the GIF. - -b --bottom-text=TEXT The text you wish to add to the bottom of the - GIF. + -w --width-size=INT How wide the GIF needs to be. Height will + scale to match. + -q --quality=ITEM Controls how many colors are used and the + frame rate. + The options are High, Medium, and Low. CROP: - -L --left-crop=NUM The amount you wish to crop from the left. - -R --right-crop=NUM The amount you wish to crop from the right. - -T --top-crop=NUM The amount you wish to crop from the top. - -B --bottom-crop=NUM The amount you wish to crop from the bottom. -INFO: - -? --help Display help message - -V --version Print version information + -L --left-crop=NUM The amount you wish to crop from the left. + -R --right-crop=NUM The amount you wish to crop from the right. + -T --top-crop=NUM The amount you wish to crop from the top. + -B --bottom-crop=NUM The amount you wish to crop from the bottom. +TEXT: + -t --text-overlays-file=FILE The text overlays YAML file path and name. + The format is: + - text: ... + fontFamily: ... + fontStyle: ... + fontStretch: ... + fontWeight: ... + fontSize: ... + origin: ... + xTranslation: ... + yTranslation: ... + rotation: ... + startTime: ... + durationTime: ... + outlineSize: ... + outlineColor: ... + fillColor: ... + - text: ... + ... + + + -? --help Display help message + -V --version Print version information + +Visit https://github.com/lettier/gifcurry for more information. ``` ## Got a CLI example? ```text gifcurry_cli \ --i ~/Videos/video.webm -o ~/tmp/test -m \ --L 25 -R 25 -T 25 -B 25 \ --s 149.11 -d 1 \ --f 'fira sans' -t 'Top Text' -b 'Bottom Text' - - ppDPPPDbDDpp - pDPPPP )DPDp ) - PPPPP )pp DPPp ppppp PPP pDbDD - p )PPP PPPD PPPD pDPDPPPDP PPP - bP DPP pPPP )PPPb (PPP PPP )PPPPPP pDPPPDb PPP PPb PPbpDPP PPbpPP ·DPb pPD - (PPb )D (PPD bPPP PPP DDDDD PPP PPP PPb PPP PPb PPPP PPPP (PP pPPC - (PPPp PPP b )PPP DPPp PPP PPP PPP (PPb PPP PPb PPP PPP DPb PPP - PPPb DPPP pPp DPb DPDp PPP PPP PPP DPPp p PPP pPPb PPP PPP PPpPP - )PPPp (DPPP )PPb b (PPDDPPP PPP PPP (PDDDPC PDDP PPC PPP PPP )DPPP - )DPPp )DD DPPPb pbPP - )DPbp (PPPPPb PPC - SPDbDppppPPDPC - -Gifcurry 3.0.0.2 + -i ~/Videos/video.webm \ + -o ~/tmp/test \ + -s 150 \ + -d 1 \ + -t ~/tmp/text-overlays.yaml \ + -w 800 \ + -q High \ + -L 0.1 \ + -R 0.1 \ + -T 0.1 \ + -B 0.1 \ + -m + +         ▄▄▄▄▄▄▄▄                                                                              +     ▄▄████   ▀▀███▄                                                                          +      ████▀   ▄    ▀███           ▄    ▐██▌   ▄███▄                                           +  ▄   ▐███   ████   ▀███      ▄███▀▀██       ███                                              + ▐█▌   ██   ▐███     ████    ███        ▐██ █████▌ ▄█████ ▐██▌  ██▌  ██▄██▌ ██▄██▌ ██▌   ███  + ███   ▐▌   ███      ▐███▌   ███  ████▌ ▐██   ██▌  ███     ▐██▌  ██▌  ███▀   ███▀   ▐██  ███   + ████      ███▀  ▐█   ███▌   ███    ██▌ ▐██   ██▌  ███     ▐██▌  ██▌  ██▌    ██▌     ██▌▐██    + ▐███▄    ▐██▌   ██    ██     ███▄▄▄██▌ ▐██   ██▌   ███▄▄█ ███▄███▌  ██▌    ██▌      ████▌    +  ▀███   ▀███   ▐███   ▀        ▀▀▀▀▀    ▀▀   ▀▀      ▀▀▀    ▀▀▀   ▀▀     ▀▀        ███     +    ███▄   ▀    ████▌                                                                ███▀      +      ▀███▄▄   █████▀                                                                          +          ▀▀▀▀▀▀▀                                                                              + + +Gifcurry 4.0.0.0 (C) 2016 David Lettier lettier.com @@ -121,24 +144,41 @@ lettier.com - Output File: /home/tmp/test.webm - Save As Video: Yes - TIME: - - Start Second: 149.110 + - Start Second: 150.000 - Duration Time: 1.000 seconds - OUTPUT FILE SIZE: - - Width Size: 500px - - Quality Percent: 100.0% + - Width Size: 800px + - Quality: High - TEXT: - - Font Choice: fira sans - - Top Text: Top Text - - Bottom Text: Bottom Text + - Text: This is a test. + - Font: + - Family: Sans + - Size: 30 + - Style: Normal + - Stretch: Normal + - Weight: 800 + - Time: + - Start: 150.000 seconds + - Duration: 20.000 seconds + - Translation: + - Origin: NorthWest + - X: 0.0 + - Y: 0.0 + - Rotation: + - Degrees: 0 + - Outline: + - Size: 10 + - Color: rgb(1,100,10) + - Fill: + - Color: rgb(255,255,0) - CROP: - - Left Crop: 25.000 - - Right crop: 25.000 - - Top Crop: 25.000 - - Bottom Crop: 25.000 - -[INFO] Writing the temporary frames to: /home/.cache/gifcurry/gifcurry-frames17389 -[INFO] Your font choice matched to "Fira-Sans". -[INFO] Saving your GIF to: /home/.cache/gifcurry/gifcurry-frames17389/finished-result.gif + - Left: 0.100 + - Right: 0.100 + - Top: 0.100 + - Bottom: 0.100 + +[INFO] Writing the temporary frames to: /home/.cache/gifcurry/gifcurry-frames30450 +[INFO] Adding text... [INFO] Saving your video to: /home/tmp/test.webm [INFO] All done. ``` @@ -153,15 +193,15 @@ To find the latest version of Gifcurry, head over to the ### I use Linux. If you use Linux then the easiest way to grab a copy of Gifcurry is by downloading the -[AppImage](https://github.com/lettier/gifcurry/releases/download/3.0.0.2/gifcurry-3.0.0.2-x86_64.AppImage). +[AppImage](https://github.com/lettier/gifcurry/releases/download/4.0.0.0/gifcurry-4.0.0.0-x86_64.AppImage). After you download the -[AppImage](https://github.com/lettier/gifcurry/releases/download/3.0.0.2/gifcurry-3.0.0.2-x86_64.AppImage), +[AppImage](https://github.com/lettier/gifcurry/releases/download/4.0.0.0/gifcurry-4.0.0.0-x86_64.AppImage), right click on it, select permissions, and check the box near execute. With that out of the way—you're all set—just double click on the AppImage and the GUI will fire right up. You can also download and install the -[AppImage](https://github.com/lettier/gifcurry/releases/download/3.0.0.2/gifcurry-3.0.0.2-x86_64.AppImage) +[AppImage](https://github.com/lettier/gifcurry/releases/download/4.0.0.0/gifcurry-4.0.0.0-x86_64.AppImage) using the handy [AppImage install script](https://raw.githubusercontent.com/lettier/gifcurry/master/packaging/linux/app-image/gifcurry-app-image-install.sh) (right click and save link as). @@ -169,7 +209,7 @@ Download the script, right click on it, select permissions, check the box near e You should now see Gifcurry listed alongside your other installed programs. If you want the CLI then download the -[prebuilt version](https://github.com/lettier/gifcurry/releases/download/3.0.0.2/gifcurry-linux-3.0.0.2.tar.gz) +[prebuilt version](https://github.com/lettier/gifcurry/releases/download/4.0.0.0/gifcurry-linux-4.0.0.0.tar.gz) for Linux, extract it, open up your terminal, `cd` to the bin folder, and then run `gifcurry_cli -?`. As an added bonus, inside the bin directory is the GUI version @@ -215,7 +255,7 @@ The [Gifcurry snap](https://snapcraft.io/gifcurry) only comes with the GUI. If you want the CLI, download the -[prebuilt version](https://github.com/lettier/gifcurry/releases/download/3.0.0.2/gifcurry-linux-3.0.0.2.tar.gz) +[prebuilt version](https://github.com/lettier/gifcurry/releases/download/4.0.0.0/gifcurry-linux-4.0.0.0.tar.gz) for Linux. ### I use Mac. @@ -250,6 +290,7 @@ $HOME/.local/bin/gifcurry_gui * [GTK+ >= 3.10](http://www.gtk.org/download/index.php) * [FFmpeg >= 3](https://www.ffmpeg.org/download.html) * [GStreamer >= 1.0](https://gstreamer.freedesktop.org/download/) + * [GStreamer Plugins](https://gstreamer.freedesktop.org/modules/) * [ImageMagick >= 6](http://www.imagemagick.org/script/download.php) ### To build Gifcurry. diff --git a/docs/gifcurry-ui-0.gif b/docs/gifcurry-ui-0.gif index 84387f8..8bd8b03 100644 Binary files a/docs/gifcurry-ui-0.gif and b/docs/gifcurry-ui-0.gif differ diff --git a/docs/gifcurry-ui-1.gif b/docs/gifcurry-ui-1.gif index 558dc9d..022b878 100644 Binary files a/docs/gifcurry-ui-1.gif and b/docs/gifcurry-ui-1.gif differ diff --git a/docs/gifcurry-ui-2.gif b/docs/gifcurry-ui-2.gif index 094e725..9189ed6 100644 Binary files a/docs/gifcurry-ui-2.gif and b/docs/gifcurry-ui-2.gif differ diff --git a/docs/gifcurry-ui-3.gif b/docs/gifcurry-ui-3.gif index 5824a74..886c78b 100644 Binary files a/docs/gifcurry-ui-3.gif and b/docs/gifcurry-ui-3.gif differ diff --git a/docs/index.html b/docs/index.html index b4be43d..9ac1773 100644 --- a/docs/index.html +++ b/docs/index.html @@ -125,8 +125,8 @@

ImageMagick.

Linux users can download the - AppImage or - the prebuilt binaries. + AppImage or + the prebuilt binaries. If you'd rather install it, you can do so via pacman (Arch) or diff --git a/docs/screenshot.jpg b/docs/screenshot.jpg index 4a85294..2178c14 100644 Binary files a/docs/screenshot.jpg and b/docs/screenshot.jpg differ diff --git a/logo/logo-3.svg b/logo/logo-3.svg index b96761c..8d43a7e 100644 --- a/logo/logo-3.svg +++ b/logo/logo-3.svg @@ -13,7 +13,10 @@ height="55.272121mm" width="191.61172mm" sodipodi:docname="logo-3.svg" - inkscape:version="0.92.2 2405546, 2018-03-11"> + inkscape:version="0.92.2 2405546, 2018-03-11" + inkscape:export-filename="/home/lettier/tmp/gifcurry-logo.png" + inkscape:export-xdpi="117.64339" + inkscape:export-ydpi="117.64339"> + style="display:inline;fill:#3e2a69;fill-opacity:0.39215687;filter:url(#filter912)"> diff --git a/makefile b/makefile index dfe3630..4c98d67 100644 --- a/makefile +++ b/makefile @@ -10,10 +10,11 @@ STACK_GHC_BIN=`$(STACK) path --compiler-bin` STACK_PATHS=$(STACK_PATH_LOCAL_BIN):$(STACK_GHC_BIN) CABAL=env PATH=$(PATH):$(STACK_PATHS) $(STACK_PATH_LOCAL_BIN)/cabal CABAL_SANDBOX_DIR=".cabal-sandbox" +_METAINFO_DIR="$(CABAL_SANDBOX_DIR)/share/metainfo" _APPLICATIONS_DESKTOP_DIR="$(CABAL_SANDBOX_DIR)/share/applications" _ICONS_HICOLOR_SCALABLE_APPS_DIR="$(CABAL_SANDBOX_DIR)/share/icons/hicolor/scalable/apps" _PACKAGING_LINUX_COMMON_DIR="./packaging/linux/common" -VERSION='3.0.0.2' +VERSION='4.0.0.0' export PATH := $(PATH):$(STACK_PATH_LOCAL_BIN) @@ -57,7 +58,11 @@ install_dependencies: sandbox configure: sandbox $(CABAL) --require-sandbox configure -w $(STACK_GHC_EXE) -applications_desktop: sandbox +appdata_xml: sandbox + mkdir -p $(_METAINFO_DIR) && \ + cp $(_PACKAGING_LINUX_COMMON_DIR)/com.lettier.gifcurry.appdata.xml $(_METAINFO_DIR)/ + +applications_desktop: appdata_xml mkdir -p $(_APPLICATIONS_DESKTOP_DIR) && \ cp $(_PACKAGING_LINUX_COMMON_DIR)/com.lettier.gifcurry.desktop $(_APPLICATIONS_DESKTOP_DIR)/ @@ -68,7 +73,7 @@ icons_hicolor_scalable_apps: applications_desktop build: configure $(CABAL) --require-sandbox build -j -cabal_install: applications_desktop icons_hicolor_scalable_apps build +cabal_install: appdata_xml applications_desktop icons_hicolor_scalable_apps build $(CABAL) --require-sandbox install -j -w $(STACK_GHC_EXE) --enable-relocatable release: check build diff --git a/packaging/linux/app-image/gifcurry-app-image-install.sh b/packaging/linux/app-image/gifcurry-app-image-install.sh index a46b34b..8128110 100755 --- a/packaging/linux/app-image/gifcurry-app-image-install.sh +++ b/packaging/linux/app-image/gifcurry-app-image-install.sh @@ -3,7 +3,7 @@ # (C) 2017 David Lettier # lettier.com -GIFCURRY_VERSION="3.0.0.2" +GIFCURRY_VERSION="4.0.0.0" GIFCURRY_RELEASES_DOWNLOAD="https://github.com/lettier/gifcurry/releases/download/$GIFCURRY_VERSION" GIFCURRY_PACKAGING_LINUX_COMMON="https://raw.githubusercontent.com/lettier/gifcurry/master/packaging/linux/common" GIFCURRY_APP_IMAGE="gifcurry-$GIFCURRY_VERSION-x86_64.AppImage" diff --git a/packaging/linux/arch-aur/PKGBUILD b/packaging/linux/arch-aur/PKGBUILD index e97cf78..edede83 100755 --- a/packaging/linux/arch-aur/PKGBUILD +++ b/packaging/linux/arch-aur/PKGBUILD @@ -1,7 +1,7 @@ # Maintainer: Lettier _name=gifcurry -_ver=3.0.0.2 +_ver=4.0.0.0 _xrev=0 pkgname=${_name} diff --git a/packaging/linux/app-image/com.lettier.gifcurry.appdata.xml b/packaging/linux/common/com.lettier.gifcurry.appdata.xml similarity index 77% rename from packaging/linux/app-image/com.lettier.gifcurry.appdata.xml rename to packaging/linux/common/com.lettier.gifcurry.appdata.xml index 26d2723..96ad6dc 100644 --- a/packaging/linux/app-image/com.lettier.gifcurry.appdata.xml +++ b/packaging/linux/common/com.lettier.gifcurry.appdata.xml @@ -1,7 +1,7 @@ - com.lettier.gifcurry.desktop + com.lettier.gifcurry CC-BY-SA-3.0 BSD-3-Clause Gifcurry @@ -17,12 +17,9 @@ com.lettier.gifcurry.desktop - The main Gifcurry window - https://i.imgur.com/Xw5h21W.png + Gifcurry + https://i.imgur.com/s98zlOU.png https://github.com/lettier/gifcurry - - gifcurry_gui - diff --git a/packaging/linux/snap/snapcraft.yaml b/packaging/linux/snap/snapcraft.yaml index e2ebb71..7b2f690 100644 --- a/packaging/linux/snap/snapcraft.yaml +++ b/packaging/linux/snap/snapcraft.yaml @@ -1,5 +1,5 @@ name: gifcurry -version: '3.0.0.2' +version: '4.0.0.0' summary: Your open source video to GIF maker. type: app description: | diff --git a/src/cli/Main.hs b/src/cli/Main.hs index 311dbf9..f8a1086 100644 --- a/src/cli/Main.hs +++ b/src/cli/Main.hs @@ -6,34 +6,81 @@ {-# LANGUAGE DeriveDataTypeable + , OverloadedStrings , NamedFieldPuns #-} {-# OPTIONS_GHC -fno-cse #-} -import Control.Monad +import System.Directory import System.Console.CmdArgs +import Control.Monad +import Data.Text (pack, unpack, strip) +import Data.Maybe +import Data.Yaml +import qualified Data.ByteString.Char8 as DBC import qualified Gifcurry data CliArgs = CliArgs - { input_file :: String - , output_file :: String - , save_as_video :: Bool - , start_time :: Float - , duration_time :: Float - , width_size :: Int - , quality_percent :: Float - , font_choice :: String - , top_text :: String - , bottom_text :: String - , left_crop :: Float - , right_crop :: Float - , top_crop :: Float - , bottom_crop :: Float + { input_file :: String + , output_file :: String + , save_as_video :: Bool + , start_time :: Float + , duration_time :: Float + , width_size :: Int + , quality :: String + , left_crop :: Float + , right_crop :: Float + , top_crop :: Float + , bottom_crop :: Float + , text_overlays_file :: String } deriving (Data, Typeable, Show, Eq) +data TextOverlay = + TextOverlay + { text :: String + , fontFamily :: String + , fontStyle :: String + , fontStretch :: String + , fontWeight :: Int + , fontSize :: Int + , origin :: String + , xTranslation :: Float + , yTranslation :: Float + , rotation :: Int + , startTime :: Float + , durationTime :: Float + , outlineSize :: Int + , outlineColor :: String + , fillColor :: String + } + deriving (Show) + +instance FromJSON TextOverlay where + parseJSON = + withObject + "TextOverlay" + (\ obj -> + TextOverlay + <$> obj .: "text" + <*> obj .:? "fontFamily" .!= "Sans" + <*> obj .:? "fontStyle" .!= "Normal" + <*> obj .:? "fontStretch" .!= "Normal" + <*> obj .:? "fontWeight" .!= 400 + <*> obj .:? "fontSize" .!= 30 + <*> obj .:? "origin" .!= "Center" + <*> obj .:? "xTranslation" .!= 0.0 + <*> obj .:? "yTranslation" .!= 0.0 + <*> obj .:? "rotation" .!= 0 + <*> obj .: "startTime" + <*> obj .: "durationTime" + <*> obj .:? "outlineSize" .!= 10 + <*> obj .:? "outlineColor" .!= "rgba(0,0,0)" + <*> obj .:? "fillColor" .!= "rgba(255,255,255)" + ) + programName :: String programName = "gifcurry_cli" @@ -77,30 +124,13 @@ cliArgs = = 500 &= groupname "OUTPUT FILE SIZE" &= help "How wide the GIF needs to be. Height will scale to match." - , quality_percent - = 100.0 + , quality + = "medium" &= groupname "OUTPUT FILE SIZE" &= help - ( "From 1 (very low quality) to 100 (the best quality). " - ++ "Controls how many colors are used and how many frames per second there are." + ( "Controls how many colors are used and the frame rate. \n" + ++ "The options are High, Medium, and Low." ) - , font_choice - = Gifcurry.defaultFontChoice - &= groupname "TEXT" - &= typ "TEXT" - &= help "Choose your desired font for the top and bottom text." - , top_text - = "" - &= groupname "TEXT" - &= typ "TEXT" - &= name "t" - &= help "The text you wish to add to the top of the GIF." - , bottom_text - = "" - &= groupname "TEXT" - &= typ "TEXT" - &= name "b" - &= help "The text you wish to add to the bottom of the GIF." , left_crop = 0.0 &= groupname "CROP" @@ -121,17 +151,77 @@ cliArgs = &= groupname "CROP" &= name "B" &= help "The amount you wish to crop from the bottom." + , text_overlays_file + = "" + &= groupname "TEXT" + &= typFile + &= name "t" + &= help + (unlines + [ "The text overlays YAML file path and name." + , "\n" + , "The format is:" + , "\n" + , "- text: ..." + , "\n" + , " fontFamily: ..." + , "\n" + , " fontStyle: ..." + , "\n" + , " fontStretch: ..." + , "\n" + , " fontWeight: ..." + , "\n" + , " fontSize: ..." + , "\n" + , " origin: ..." + , "\n" + , " xTranslation: ..." + , "\n" + , " yTranslation: ..." + , "\n" + , " rotation: ..." + , "\n" + , " startTime: ..." + , "\n" + , " durationTime: ..." + , "\n" + , " outlineSize: ..." + , "\n" + , " outlineColor: ..." + , "\n" + , " fillColor: ..." + , "\n" + , "- text: ..." + , "\n" + , "..." + , " \n" + , " \n" + ] + ) } - &= summary (info icon) + &= summary "" &= program programName &= details ["Visit https://github.com/lettier/gifcurry for more information.", ""] main :: IO () main = do - cliArgs' <- cmdArgs cliArgs - let params = makeGifParams cliArgs' putStrLn $ info logo - paramsValid <- Gifcurry.gifParamsValid params + cliArgs' <- cmdArgs cliArgs + let text_overlays_file' = unpack $ strip $ pack $ text_overlays_file cliArgs' + textOverlays <- + if null text_overlays_file' + then return [] + else do + text_overlays_file_exists <- doesFileExist text_overlays_file' + text_overlays_data <- + if text_overlays_file_exists + then DBC.readFile text_overlays_file' + else return "" + let maybeTextOverlays = Data.Yaml.decode text_overlays_data :: Maybe [TextOverlay] + makeTextOverlays text_overlays_file' maybeTextOverlays + let params = (makeGifParams cliArgs') { Gifcurry.textOverlays = textOverlays } + paramsValid <- Gifcurry.gifParamsValid params if paramsValid then void $ Gifcurry.gif params else @@ -139,6 +229,66 @@ main = do "[INFO] Type \"" ++ programName ++ " -?\" for help." return () +makeTextOverlays :: String -> Maybe [TextOverlay] -> IO [Gifcurry.TextOverlay] +makeTextOverlays text_overlays_file' maybeTextOverlays = + case maybeTextOverlays of + Nothing -> do + putStrLn $ + "[WARNING] Could not parse the " ++ text_overlays_file' ++ " YAML file!" + return [] + Just textOverlays -> + mapM + (\ + TextOverlay + { text + , fontFamily + , fontStyle + , fontStretch + , fontWeight + , fontSize + , origin + , xTranslation + , yTranslation + , rotation + , startTime + , durationTime + , outlineSize + , outlineColor + , fillColor + } + -> do + origin' <- originFromString origin + return + Gifcurry.TextOverlay + { Gifcurry.textOverlayText = text + , Gifcurry.textOverlayFontFamily = fontFamily + , Gifcurry.textOverlayFontStyle = fontStyle + , Gifcurry.textOverlayFontStretch = fontStretch + , Gifcurry.textOverlayFontWeight = fontWeight + , Gifcurry.textOverlayFontSize = fontSize + , Gifcurry.textOverlayOrigin = origin' + , Gifcurry.textOverlayXTranslation = xTranslation + , Gifcurry.textOverlayYTranslation = yTranslation + , Gifcurry.textOverlayRotation = rotation + , Gifcurry.textOverlayStartTime = startTime + , Gifcurry.textOverlayDurationTime = durationTime + , Gifcurry.textOverlayOutlineSize = outlineSize + , Gifcurry.textOverlayOutlineColor = outlineColor + , Gifcurry.textOverlayFillColor = fillColor + } + ) + textOverlays + where + originFromString :: String -> IO Gifcurry.TextOverlayOrigin + originFromString origin' = do + let maybeOrigin = Gifcurry.textOverlayOriginFromString origin' + case maybeOrigin of + Nothing -> do + putStrLn $ + "[WARNING] Origin " ++ origin' ++ " not valid! Defaulting to Center." + return Gifcurry.TextOverlayOriginCenter + Just origin'' -> return origin'' + makeGifParams :: CliArgs -> Gifcurry.GifParams makeGifParams CliArgs @@ -148,10 +298,7 @@ makeGifParams , start_time , duration_time , width_size - , quality_percent - , font_choice - , top_text - , bottom_text + , quality , left_crop , right_crop , top_crop @@ -165,10 +312,9 @@ makeGifParams , Gifcurry.startTime = start_time , Gifcurry.durationTime = duration_time , Gifcurry.widthSize = width_size - , Gifcurry.qualityPercent = quality_percent - , Gifcurry.fontChoice = font_choice - , Gifcurry.topText = top_text - , Gifcurry.bottomText = bottom_text + , Gifcurry.quality = fromMaybe Gifcurry.QualityMedium $ + Gifcurry.qualityFromString quality + , Gifcurry.textOverlays = [] , Gifcurry.leftCrop = left_crop , Gifcurry.rightCrop = right_crop , Gifcurry.topCrop = top_crop @@ -179,36 +325,17 @@ logo :: String logo = unlines [ "" - , " ppDPPPDbDDpp " - , " pDPPPP )DPDp ) " - , " PPPPP )pp DPPp ppppp PPP pDbDD " - , " p )PPP PPPD PPPD pDPDPPPDP PPP " - , " bP DPP pPPP )PPPb (PPP PPP )PPPPPP pDPPPDb PPP PPb PPbpDPP PPbpPP ·DPb pPD " - , " (PPb )D (PPD bPPP PPP DDDDD PPP PPP PPb PPP PPb PPPP PPPP (PP pPPC " - , " (PPPp PPP b )PPP DPPp PPP PPP PPP (PPb PPP PPb PPP PPP DPb PPP " - , " PPPb DPPP pPp DPb DPDp PPP PPP PPP DPPp p PPP pPPb PPP PPP PPpPP " - , " )PPPp (DPPP )PPb b (PPDDPPP PPP PPP (PDDDPC PDDP PPC PPP PPP )DPPP " - , " )DPPp )DD DPPPb pbPP " - , " )DPbp (PPPPPb PPC " - , " SPDbDppppPPDPC " - , "" - ] - -icon :: String -icon = - unlines - [ "" - , " ppDPPPDbDDpp " - , " pDPPPP )DPDp " - , " PPPPP )pp DPPp " - , " p )PPP PPPD PPPD " - , " bP DPP pPPP )PPPb " - , " (PPb )D (PPD bPPP " - , " (PPPp PPP b )PPP " - , " PPPb DPPP pPp DPb " - , " )PPPp (DPPP )PPb b " - , " )DPPp )DD DPPPb " - , " )DPbp (PPPPPb " - , " SPDbDppppPPDPC " + , "         ▄▄▄▄▄▄▄▄                                                                             "  + , "     ▄▄████   ▀▀███▄                                                                         "  + , "      ████▀   ▄    ▀███           ▄    ▐██▌   ▄███▄                                          "  + , "  ▄   ▐███   ████   ▀███      ▄███▀▀██       ███                                             " + , " ▐█▌   ██   ▐███     ████    ███        ▐██ █████▌ ▄█████ ▐██▌  ██▌  ██▄██▌ ██▄██▌ ██▌   ███ "  + , " ███   ▐▌   ███      ▐███▌   ███  ████▌ ▐██   ██▌  ███     ▐██▌  ██▌  ███▀   ███▀   ▐██  ███  "  + , " ████      ███▀  ▐█   ███▌   ███    ██▌ ▐██   ██▌  ███     ▐██▌  ██▌  ██▌    ██▌     ██▌▐██   "  + , " ▐███▄    ▐██▌   ██    ██     ███▄▄▄██▌ ▐██   ██▌   ███▄▄█ ███▄███▌  ██▌    ██▌      ████▌   "  + , "  ▀███   ▀███   ▐███   ▀        ▀▀▀▀▀    ▀▀   ▀▀      ▀▀▀    ▀▀▀   ▀▀     ▀▀        ███    "  + , "    ███▄   ▀    ████▌                                                                ███▀     "  + , "      ▀███▄▄   █████▀                                                                         "  + , "          ▀▀▀▀▀▀▀                                                                             "  , "" ] diff --git a/src/data/gifcurry-icon.svg b/src/data/gifcurry-icon.svg index 6aaa2ce..2faf46c 100644 --- a/src/data/gifcurry-icon.svg +++ b/src/data/gifcurry-icon.svg @@ -9,9 +9,9 @@ xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" id="svg8" version="1.1" - viewBox="0 0 55.240221 55.272122" - height="55.272121mm" - width="55.240219mm" + viewBox="0 0 25.4 25.4" + height="96" + width="96" sodipodi:docname="gifcurry-icon.svg" inkscape:version="0.92.2 2405546, 2018-03-11"> + inkscape:current-layer="g1094" + units="px" /> + d="M 16.375253,49.156239 A 10.463589,10.463589 0 0 1 3.0975771,42.650721 10.463589,10.463589 0 0 1 9.5815634,29.362518 10.463589,10.463589 0 0 1 22.88026,35.824956 10.463589,10.463589 0 0 1 16.439387,49.13411" /> + style="display:inline;opacity:1;fill:#13082a;fill-opacity:0.19607843;fill-rule:nonzero;stroke:none;stroke-width:0.58234793;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;paint-order:fill markers stroke;filter:url(#filter1023)" + inkscape:connector-curvature="0" + transform="matrix(0.45993222,0,0,0.45993222,0.15719867,28.064398)" /> + transform="matrix(0.45993222,0,0,0.45993222,-57.495033,61.62316)"> diff --git a/src/data/gui.glade b/src/data/gui.glade index 9d7552c..28fb9a3 100644 --- a/src/data/gui.glade +++ b/src/data/gui.glade @@ -43,14 +43,25 @@ Author: David Lettier about-dialog-button-image.svg 3 - - 100 - 1 - 10 - - 100 - 1 + 0.98999999999999999 + 0.01 + + + gtk-no + True + True + True + True + True + + + gtk-yes + True + True + True + True + True True @@ -69,26 +80,22 @@ Author: David Lettier True True False - True - True - vertical - + True - True False True True False + center + center True - True False This is the first frame of the GIF. - True gtk-missing-image 0 @@ -99,8 +106,8 @@ Author: David Lettier True + True False - True 1 @@ -108,22 +115,8 @@ Author: David Lettier - True - True - 0 - - - - - True - False - False - vertical - - - False - True - 1 + 0 + 0 @@ -131,13 +124,13 @@ Author: David Lettier True True False + center + center True - True False This is the last frame of the GIF. - True gtk-missing-image 0 @@ -148,8 +141,8 @@ Author: David Lettier True + True False - True 1 @@ -157,66 +150,62 @@ Author: David Lettier - True - True - 2 + 1 + 0 - - - False - True - 1 - - - - - True - False - True - - First Frame + True - False False - False - Last Frame - 0.98999999999999999 True - True - - - True - True - 0 - - - - - Last Frame - True - False - False - False - False - First Frame - True - True + True + + + First Frame + True + False + False + False + Last Frame + 0.99999999977648257 + True + + + False + True + 0 + + + + + Last Frame + True + False + False + False + False + First Frame + True + + + False + True + 1 + + - True - True - end - 1 + 0 + 1 + 2 True True - end - 4 + 0 @@ -242,16 +231,8 @@ Author: David Lettier - 100 - 1 - - - gtk-no - True - True - True - True - True + 0.98999999999999999 + 0.01 True @@ -261,15 +242,9 @@ Author: David Lettier gtk-open 2 - - 1 - 100 - 100 - 1 - - 100 - 1 + 0.98999999999999999 + 0.01 True @@ -287,14 +262,14 @@ Author: David Lettier 1 - + True False gtk-italic - 100 - 1 + 0.98999999999999999 + 0.01 True @@ -311,8 +286,6 @@ Author: David Lettier True False This is a video preview of the GIF. - True - True vertical @@ -336,6 +309,7 @@ Author: David Lettier True + True False @@ -347,6 +321,11 @@ Author: David Lettier + + True + False + gtk-media-pause + 1 3840 @@ -359,21 +338,18 @@ Author: David Lettier gtk-justify-fill - 900 + 1000 True False Gifcurry mouse - 1000 + 1100 gifcurry-icon.svg center True - True False - True - True vertical @@ -384,7 +360,7 @@ Author: David Lettier True False True - Which video do you want to open? + Open which video? True @@ -450,155 +426,35 @@ Author: David Lettier - True - True False - True - True - - 400 + + 300 True False - True - vertical + never - - Width & Quality - width-quality-percent-toggle-button + True - True - False - True - width-toggle-button-image - True - - - False - True - 0 - - - - False - True + natural + natural + none - - width-size-spin-button - True - True - How big is the width? - 500 - 0.13 - gtk-justify-fill - False - False - False - Width Size (pixels) - number - width-size-adjustment - 2 - True - True - if-valid - 500 - - - False - True - 2 - - - - - quality-percent-spin-button - True - True - What is the quality? - 3 - 3 - 100 - 1 - gtk-select-color - False - False - False - Quality Percent - number - quality-percent-adjustment - 2 - True - True - if-valid - 100 - - - False - True - 3 - - - - - False - True - 1 - - - - - True - False - - - False - True - 2 - - - - - Crop - crop-toggle-button - True - True - False - True - crop-toggle-button-image - True - - - False - True - 3 - - - - - False - vertical - - + True False - True + vertical - + + Width & Quality + width-quality-percent-toggle-button True True - How much to crop from the left? - gtk-goto-last - False - False - False - Left Crop - digits - left-crop-adjustment - 2 - 2 - True - if-valid + False + True + width-toggle-button-image + True False @@ -607,21 +463,55 @@ Author: David Lettier - - True - True - How much to crop from the right? - gtk-goto-first - False - False - False - Right Crop - digits - right-crop-adjustment - 2 - 2 - True - if-valid + + False + True + + + width-size-spin-button + True + True + How big is the width? + 500 + 0.13 + gtk-justify-fill + False + False + False + Width Size (pixels) + number + width-size-adjustment + 2 + True + True + if-valid + 500 + + + False + True + 0 + + + + + True + False + Which quality level would you like? + 1 + Medium + + High + Medium + Low + + + + False + True + 1 + + False @@ -629,432 +519,507 @@ Author: David Lettier 1 - - - False - True - 0 - - - - - True - False - True - + + True + False + + + False + True + 2 + + + + + Crop + crop-toggle-button True True - How much to crop from the top? - gtk-goto-bottom - False - False - False - Top Crop - digits - top-crop-adjustment - 2 - 2 - True - if-valid + False + True + crop-toggle-button-image + True False True - 0 + 3 - + + False + vertical + + + True + False + True + + + left-crop-spin-button + True + True + How much to crop from the left? + 0.00 + gtk-goto-last + False + False + False + Left Crop + digits + left-crop-adjustment + 1 + 2 + True + if-valid + + + False + True + 0 + + + + + right-crop-spin-button + True + True + How much to crop from the right? + 0.00 + gtk-goto-first + False + False + False + Right Crop + digits + right-crop-adjustment + 1 + 2 + True + if-valid + + + False + True + 1 + + + + + False + True + 0 + + + + + True + False + True + + + top-crop-spin-button + True + True + How much to crop from the top? + 0.00 + gtk-goto-bottom + False + False + False + Top Crop + digits + top-crop-adjustment + 1 + 2 + True + if-valid + + + False + True + 0 + + + + + bottom-crop-spin-button + True + True + How much to crop from the bottom? + 0.00 + gtk-goto-top + False + False + False + digits + bottom-crop-adjustment + 1 + 2 + True + if-valid + + + False + True + 1 + + + + + False + True + 1 + + + + + False + True + 4 + + + + + True + False + + + False + True + 6 + + + + + Text + text-overlays-toggle-button True True - How much to crop from the bottom? - gtk-goto-top - False - False - False - digits - bottom-crop-adjustment - 2 - 2 - True - if-valid + False + True + text-overlays-toggle-button-image + True False True - 1 + 7 + + + + + False + vertical + + + gtk-add + True + True + True + Add text? + True + True + + + False + True + 0 + + + + + True + False + 2 + 2 + vertical + 5 + + + + + + True + True + 1 + + + + + True + True + 7 - - - False - True - 1 - - - - - False - True - 4 - - - - - True - False - - - False - True - 6 - - - - - Top & Bottom Text - top-bottom-text-toggle-button - True - True - False - True - top-bottom-text-toggle-button-image - True - - - False - True - 7 - - - - - False - vertical - - - True - True - What text should go on top? - gtk-italic - False - False - False - Top Text (optional) - - - True - True - 0 - - - - - True - True - What text should go on the bottom? - gtk-italic - False - False - False - Bottom Text (optional) - - - True - True - 1 - - - - - font_chooser_button - True - True - True - What font would you like? - Sans 12 - I love making GIFs with Gifcurry! - Gifcurry - Choose a Font - True - False - False - - - False - True - 2 - - - - - False - True - 8 - - - - - True - False - - - False - True - 9 - - - - - Save & Open - save-open-toggle-button - True - True - False - True - save-toggle-button-image - True - - - False - True - 10 - - - - - False - vertical - - - True - False - True - - Save as GIF + + True + False + + + False + True + 9 + + + + + Save & Open + save-open-toggle-button True True - False - Save the file as a GIF? - gif-icon-image + False + True + save-toggle-button-image True - False - save-as-video-radio-button False True - 0 + 10 - - Save as Video - True - True - False - Save the file as a video? - video-icon-image - True - False - save-as-gif-radio-button + + False + vertical + + + True + False + True + + + Save as GIF + True + True + False + Save the file as a GIF? + gif-icon-image + True + False + save-as-video-radio-button + + + False + True + 0 + + + + + Save as Video + True + True + False + Save the file as a video? + video-icon-image + True + False + save-as-gif-radio-button + + + False + True + end + 1 + + + + + False + True + 0 + + + + + True + False + Which folder do you want to save to? + select-folder + Gifcurry - Pick a Folder + + + False + True + 1 + + + + + out-file-name-entry + True + True + What is the file name? + gtk-file + False + Output File Name + + + False + True + 2 + + + + + True + False + True + + + False + + + True + True + 0 + + + + + Save + True + True + True + Click here to save the file. + save-icon + True + + + True + True + 1 + + + + + Open + True + True + True + Click here to open the file. + open-icon + True + + + True + True + end + 2 + + + + + False + True + 3 + + False True - end - 1 + 11 - - - False - True - 0 - - - - - True - True - Which folder do you want to save to? - select-folder - Gifcurry - Pick a Folder - - - False - True - 1 - - - - - out-file-name-entry - True - True - What is the file name? - gtk-file - False - Output File Name - - - False - True - 2 - - - - - True - False - True - + + True False - True + False True - 0 + 12 - - Save + + Upload + upload-toggle-button True True + False True - Click here to save the file. - save-icon + upload-toggle-button-image True - True + False True - 1 + 13 - - Open - True - True - True - Click here to open the file. - open-icon - True + + False + + + Giphy + giphy-upload-button + True + True + True + Click here to upload to Giphy. + True + + + False + True + 0 + + + + + True + False + False + False + baseline + vertical + + + False + True + 1 + + + + + Imgur + imgur-upload-button + True + True + True + Click here to upload to Imgur. + True + + + False + True + end + 2 + + - True + False True - end - 2 + 14 - - False - True - 3 - - - - - False - True - 11 - - - - - True - False - - - False - True - 12 - - - - - Upload - upload-toggle-button - True - True - False - True - upload-toggle-button-image - True - - - False - True - 13 - - - - - False - - - Giphy - giphy-upload-button - True - True - True - Click here to upload to Giphy. - True - - - False - True - 0 - - - - - True - False - False - False - baseline - vertical - - - False - True - 1 - - - - - Imgur - imgur-upload-button - True - True - True - Click here to upload to Imgur. - True - - - False - True - end - 2 - - - False - True - 14 - - False + True True 0 @@ -1075,17 +1040,13 @@ Author: David Lettier True False - True - True vertical - 600 + 700 True True False - True - True vertical @@ -1101,8 +1062,37 @@ Author: David Lettier True False - True vertical + + + 102 + True + True + False + True + True + + + True + True + 0 + + + + + Pause + True + False + True + video-preview-pause-toggle-button-image + True + + + False + True + 1 + + True @@ -1165,29 +1155,6 @@ Author: David Lettier - - False - True - 0 - - - - - True - False - - - False - True - 1 - - - - - True - False - True - False True @@ -1198,9 +1165,9 @@ Author: David Lettier False - True + False end - 1 + 0 @@ -1223,14 +1190,14 @@ Author: David Lettier True False False + end True top True False - True - True + False True False False @@ -1276,9 +1243,10 @@ Author: David Lettier gifcurry-window gifcurry-window Gifcurry - 3.0.0.2 + 4.0.0.0 (C) 2016 David Lettier lettier.com + Help Gifcurry by starring it on GitHub. Thanks! https://github.com/lettier/gifcurry WEBSITE BSD 3-Clause License @@ -1335,6 +1303,51 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + 400 + False + Gifcurry - Yes or no? + center-on-parent + True + dialog-question + dialog + True + center + gifcurry-window + gifcurry-window + warning + Yes or no? + + + False + vertical + 2 + + + False + 5 + 5 + True + end + + + + + + + + + False + False + 0 + + + + + + + + False Gifcurry - Select a Video @@ -1405,54 +1418,4 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - False - Gifcurry - Click Yes or No - center-on-parent - True - dialog-question - dialog - True - center - gifcurry-window - gifcurry-window - warning - Are you sure you want to make a GIF that long? - - - False - vertical - 2 - - - False - True - end - - - - - - - - - False - False - 0 - - - - - - - - - - gtk-yes - True - True - True - True - True - diff --git a/src/gui/GuiCapabilities.hs b/src/gui/GuiCapabilities.hs index 2c755ed..ec82a0e 100644 --- a/src/gui/GuiCapabilities.hs +++ b/src/gui/GuiCapabilities.hs @@ -82,7 +82,7 @@ checkCapabilitiesAndNotify setLabelStyle "gifcurry-label-warning" (_:_:_:_:_:_:_:False:_) -> do setImageToIcon "gtk-dialog-error" - setLabelText "\"gtksink\" not found. No video preview. Install the GStreamer 1.0 bad plugins version 1.8 or higher." + setLabelText "\"gtksink\" not found. No video preview. Install all GStreamer 1.0 plugins." setLabelStyle "gifcurry-label-warning" (_:_:_:_:_:_:_:_:False:_) -> do setImageToIcon "gtk-dialog-warning" diff --git a/src/gui/GuiMisc.hs b/src/gui/GuiMisc.hs index 9d23155..b02e760 100644 --- a/src/gui/GuiMisc.hs +++ b/src/gui/GuiMisc.hs @@ -17,20 +17,36 @@ import Data.Int import Data.Maybe import Data.Char import Data.Text +import Data.List import qualified GI.Gtk enumToInt32 :: (Enum a, Ord a) => a -> Int32 -enumToInt32 enum = fromIntegral (fromEnum enum) :: Int32 +enumToInt32 = fromIntegral . fromEnum floatToInt32 :: Float -> Int32 floatToInt32 f = enumToInt32 (round f :: Int) +floatToDouble :: Float -> Double +floatToDouble = realToFrac + +doubleToFloat :: Double -> Float +doubleToFloat = realToFrac + +doubleToInt :: Double -> Int +doubleToInt = truncate + int32ToDouble :: Int32 -> Double int32ToDouble = fromIntegral int32ToFloat :: Int32 -> Float int32ToFloat = fromIntegral +int32ToInt :: Int32 -> Int +int32ToInt = fromIntegral + +int64ToDouble :: Int64 -> Double +int64ToDouble = fromIntegral + entryGetMaybeFloat :: GI.Gtk.Entry -> IO (Maybe Float) entryGetMaybeFloat entry = do text <- Data.Text.strip <$> GI.Gtk.entryGetText entry @@ -70,10 +86,10 @@ safeDivide :: (Fractional a, Eq a) => a -> a -> Maybe a safeDivide n d = if d == 0.0 then Nothing else Just $ n / d clamp :: (Fractional a, Eq a, Ord a) => a -> a -> a -> a -clamp min max v - | v <= min = min - | v >= max = max - | otherwise = v +clamp min' max' v + | v <= min' = min' + | v >= max' = max' + | otherwise = v safeRunProcessGetOutput :: String -> [String] -> IO (System.Exit.ExitCode, String, String) safeRunProcessGetOutput processName args = @@ -98,3 +114,15 @@ hasText needle haystack = Data.Text.isInfixOf needle $ Data.Text.toLower $ Data.Text.pack haystack + +listElementsEqual :: Eq a => [a] -> Bool +listElementsEqual (x:xs) = Data.List.all (== x) xs +listElementsEqual [] = False + +truncatePastDigit :: RealFrac a => a -> Int -> a +truncatePastDigit frac num = fromIntegral int / trunc + where + int :: Int + int = floor (frac * trunc) + trunc :: Fractional b => b + trunc = 10.0^num diff --git a/src/gui/GuiPreview.hs b/src/gui/GuiPreview.hs index 3ab6569..828e39a 100644 --- a/src/gui/GuiPreview.hs +++ b/src/gui/GuiPreview.hs @@ -14,6 +14,10 @@ module GuiPreview where import GHC.Float import System.FilePath import System.IO.Temp +import Control.Monad +import Control.Monad.IO.Class +import Control.Concurrent +import Text.Printf import Data.Int import Data.Maybe import Data.Text @@ -21,24 +25,32 @@ import Data.List import Data.Bits import Data.IORef import Data.GI.Base.Properties -import Control.Monad -import Control.Concurrent import qualified GI.GLib +import qualified GI.Gdk import qualified GI.Gtk import qualified GI.Gst import qualified GI.Cairo import qualified GiCairoCairoBridge import qualified Graphics.Rendering.Cairo as GRC +import qualified Graphics.Rendering.Pango.Cairo as GRPC +import qualified Graphics.Rendering.Pango.Layout as GRPL import qualified Gifcurry ( gif , GifParams(..) + , Quality(QualityLow) , defaultGifParams ) import qualified GtkMainSyncAsync (gtkMainSync, gtkMainAsync) import qualified GuiRecords as GR +import qualified GuiTextOverlays import GuiMisc +data ForFramePreview = + ForFramePreviewFirst + | ForFramePreviewLast + | ForFramePreviewNone + blankPreviewIcon :: String blankPreviewIcon = "gtk-discard" @@ -48,72 +60,66 @@ framePreviewDirectoryName = "gifcurry-frame-previews" buildVideoPreviewWidgetAndPlaybinElement :: IO (Maybe GI.Gtk.Widget, Maybe GI.Gst.Element) buildVideoPreviewWidgetAndPlaybinElement = do maybeGtkSink <- GI.Gst.elementFactoryMake "gtksink" (Just "MultimediaPlayerGtkSink") - maybeVideoPreviewWidget <- - case maybeGtkSink of - Nothing -> return Nothing - Just gtkSink -> - Data.GI.Base.Properties.getObjectPropertyObject gtkSink "widget" GI.Gtk.Widget - maybePlaybinElement <- GI.Gst.elementFactoryMake "playbin" (Just "MultimediaPlayerPlaybin") - case (maybeVideoPreviewWidget, maybePlaybinElement) of - (Just videoPreviewWidget, Just playbinElement) -> do - -- Turns off the subtitles. - let flags = flip setBit 10 $ flip setBit 9 $ flip setBit 4 $ flip setBit 1 $ bit 0 - _ <- Data.GI.Base.Properties.setObjectPropertyObject playbinElement "video-sink" maybeGtkSink - _ <- Data.GI.Base.Properties.setObjectPropertyBool playbinElement "force-aspect-ratio" True - _ <- Data.GI.Base.Properties.setObjectPropertyDouble playbinElement "volume" 0.0 - _ <- Data.GI.Base.Properties.setObjectPropertyInt playbinElement "flags" flags - _ <- GI.Gtk.widgetShow videoPreviewWidget - return () - _ -> return () - return (maybeVideoPreviewWidget, maybePlaybinElement) + case maybeGtkSink of + Nothing -> return (Nothing, Nothing) + Just gtkSink -> do + maybeVideoPreviewWidget <- Data.GI.Base.Properties.getObjectPropertyObject gtkSink "widget" GI.Gtk.Widget + maybePlaybinElement <- GI.Gst.elementFactoryMake "playbin" (Just "MultimediaPlayerPlaybin") + case (maybeVideoPreviewWidget, maybePlaybinElement) of + (Just videoPreviewWidget, Just playbinElement) -> do + -- Turns off the subtitles. + let flags = flip setBit 10 $ flip setBit 9 $ flip setBit 4 $ flip setBit 1 $ bit 0 + _ <- Data.GI.Base.Properties.setObjectPropertyObject playbinElement "video-sink" maybeGtkSink + _ <- Data.GI.Base.Properties.setObjectPropertyBool playbinElement "force-aspect-ratio" True + _ <- Data.GI.Base.Properties.setObjectPropertyDouble playbinElement "volume" 0.0 + _ <- Data.GI.Base.Properties.setObjectPropertyInt playbinElement "flags" flags + _ <- GI.Gtk.widgetShow videoPreviewWidget + return () + _ -> return () + return (maybeVideoPreviewWidget, maybePlaybinElement) runGuiPreview :: GR.GuiComponents -> IO () -runGuiPreview - guiComponents@GR.GuiComponents - { GR.maybeVideoPreviewWidget = (Just videoPreviewWidget) - , GR.maybePlaybinElement = (Just _) - , GR.mainPreviewBox - , GR.videoPreviewBox - , GR.videoPreviewOverlayChildBox - , GR.videoPreviewDrawingArea - } - = do - mainPreviewBoxChildCount <- - Data.List.length <$> GI.Gtk.containerGetChildren mainPreviewBox - when (mainPreviewBoxChildCount <= 0) $ - GI.Gtk.boxPackStart mainPreviewBox videoPreviewBox True True 0 - videoPreviewOverlayChildBoxChildCount <- - Data.List.length <$> GI.Gtk.containerGetChildren videoPreviewOverlayChildBox - when (videoPreviewOverlayChildBoxChildCount <= 0) $ do - _ <- GI.Gtk.boxPackStart videoPreviewOverlayChildBox videoPreviewWidget True True 0 - _ <- GI.Gtk.onWidgetDraw - videoPreviewDrawingArea - (drawCropGrid guiComponents videoPreviewDrawingArea) - return () - runPreviewLoopIfNotRunning - guiComponents $ - preview guiComponents videoPreview -runGuiPreview - guiComponents@GR.GuiComponents - { GR.mainPreviewBox - , GR.imagesPreviewBox - , GR.firstFramePreviewImageDrawingArea - , GR.lastFramePreviewImageDrawingArea - } - = do - childrenCount <- Data.List.length <$> GI.Gtk.containerGetChildren mainPreviewBox - when (childrenCount <= 0) $ do - _ <- GI.Gtk.boxPackStart mainPreviewBox imagesPreviewBox True True 0 - _ <- GI.Gtk.onWidgetDraw - firstFramePreviewImageDrawingArea - (drawCropGrid guiComponents firstFramePreviewImageDrawingArea) - _ <- GI.Gtk.onWidgetDraw - lastFramePreviewImageDrawingArea - (drawCropGrid guiComponents lastFramePreviewImageDrawingArea) - return () - runPreviewLoopIfNotRunning - guiComponents $ - preview guiComponents firstAndLastFramePreview +runGuiPreview guiComponents = do + setupVideoPreviewPauseToggleButton guiComponents + handlePreviewType guiComponents + runPreviewOverlay guiComponents + runTimeSlicesWidget guiComponents + where + handlePreviewType :: GR.GuiComponents -> IO () + handlePreviewType + GR.GuiComponents + { GR.mainPreviewBox + , GR.maybeVideoPreviewWidget = (Just videoPreviewWidget) + , GR.maybePlaybinElement = (Just _) + , GR.videoPreviewBox + , GR.videoPreviewOverlayChildBox + } + = do + mainPreviewBoxChildCount <- + Data.List.length <$> GI.Gtk.containerGetChildren mainPreviewBox + when (mainPreviewBoxChildCount <= 0) $ do + GI.Gtk.boxPackStart mainPreviewBox videoPreviewBox True True 0 + runPreviewLoopIfNotRunning + guiComponents $ + preview guiComponents videoPreview + videoPreviewOverlayChildBoxChildCount <- + Data.List.length <$> GI.Gtk.containerGetChildren videoPreviewOverlayChildBox + when (videoPreviewOverlayChildBoxChildCount <= 0) $ do + _ <- GI.Gtk.boxPackStart videoPreviewOverlayChildBox videoPreviewWidget True True 0 + return () + handlePreviewType + GR.GuiComponents + { GR.mainPreviewBox + , GR.imagesPreviewBox + } + = do + childrenCount <- Data.List.length <$> GI.Gtk.containerGetChildren mainPreviewBox + when (childrenCount <= 0) $ do + _ <- GI.Gtk.boxPackStart mainPreviewBox imagesPreviewBox True True 0 + runPreviewLoopIfNotRunning + guiComponents $ + preview guiComponents firstAndLastFramePreview + return () runPreviewLoopIfNotRunning :: GR.GuiComponents -> IO Bool -> IO () runPreviewLoopIfNotRunning @@ -131,8 +137,7 @@ runPreviewLoopIfNotRunning where getLoopRunning :: IO Bool getLoopRunning = - readIORef guiPreviewStateRef >>= - \ x -> return $ GR.loopRunning x + GR.loopRunning <$> readIORef guiPreviewStateRef preview :: GR.GuiComponents @@ -168,7 +173,7 @@ preview let invalidDurationTime = durationTime <= 0.0 let invalidInVideoWidth = inVideoWidth <= 0.0 let invalidInVideoHeight = inVideoHeight <= 0.0 - let inputInvalid = + let inputInvalid = invalidInFilePath || invalidStartTime || invalidDurationTime @@ -186,13 +191,16 @@ preview inVideoHeight else resetWindow guiComponents - atomicWriteIORef guiPreviewStateRef - guiPreviewState - { GR.maybeInFilePath = if invalidInFilePath then Nothing else Just inFilePath - , GR.maybeStartTime = if invalidStartTime then Nothing else Just startTime - , GR.maybeDurationTime = if invalidDurationTime then Nothing else Just durationTime - , GR.loopRunning = True - } + atomicModifyIORef' guiPreviewStateRef $ + \ guiPreviewState' -> + ( guiPreviewState' + { GR.maybeInFilePath = if invalidInFilePath then Nothing else Just inFilePath + , GR.maybeStartTime = if invalidStartTime then Nothing else Just startTime + , GR.maybeDurationTime = if invalidDurationTime then Nothing else Just durationTime + , GR.loopRunning = True + } + , () + ) return True videoPreview @@ -205,9 +213,10 @@ videoPreview -> Float -> IO () videoPreview - GR.GuiComponents + guiComponents@GR.GuiComponents { GR.window , GR.cropToggleButton + , GR.textOverlaysToggleButton , GR.mainPreviewBox , GR.videoPreviewBox , GR.maybePlaybinElement = (Just playbinElement) @@ -225,47 +234,39 @@ videoPreview GI.Gtk.widgetShow videoPreviewBox sizePreviewAndWindow handleChanges - handleCropMode + updateVideoPreviewAspectRatio where sizePreviewAndWindow :: IO () sizePreviewAndWindow = do - let widthRatio = inVideoWidth / inVideoHeight - let heightRatio = inVideoHeight / inVideoWidth - let previewWidth = - if inVideoWidth >= inVideoHeight - then desiredPreviewSize - else desiredPreviewSize * widthRatio - let previewHeight = - if inVideoWidth < inVideoHeight - then desiredPreviewSize - else desiredPreviewSize * heightRatio - let previewWidth' = floatToInt32 previewWidth - let previewHeight' = floatToInt32 previewHeight + let (previewWidth, previewHeight) = + getPreviewWidthAndHeight inVideoWidth inVideoHeight GI.Gtk.widgetSetSizeRequest window - previewWidth' + (floatToInt32 previewWidth) (-1) GI.Gtk.widgetSetSizeRequest mainPreviewBox - previewWidth' - previewHeight' + (floatToInt32 previewWidth) + (floatToInt32 previewHeight) resizeWindow window + return () handleChanges :: IO () handleChanges = do - (couldQueryDuration, videoDuration) <- - GI.Gst.elementQueryDuration playbinElement GI.Gst.FormatTime - (couldQueryPosition, videoPosition) <- - GI.Gst.elementQueryPosition playbinElement GI.Gst.FormatTime - let endTime = startTime + durationTime - let startTimeInNano = secondsToNanoseconds startTime - let endTimeInNano = secondsToNanoseconds endTime + (playbinDuration, playbinPosition) <- getPlaybinDurationAndPosition guiComponents + let videoDuration = fromMaybe (-1) playbinDuration + let videoPosition = fromMaybe (-1) playbinPosition + let endTime = startTime + durationTime + let startTimeInNano = secondsToNanoseconds startTime + let endTimeInNano = secondsToNanoseconds endTime let inFilePathChanged = fromMaybe "" maybeInFilePath /= inFilePath let startTimeChanged = fromMaybe (-1.0) maybeStartTime /= startTime - let startOver = - (couldQueryDuration && couldQueryPosition && videoDuration > 0) - && ( videoPosition >= videoDuration - || videoPosition >= endTimeInNano - || videoPosition < startTimeInNano + let nearTheEnd = (videoDuration - videoPosition) <= 500000 + let startOver = + videoDuration > 0 + && ( videoPosition >= videoDuration + || videoPosition >= endTimeInNano + || videoPosition < startTimeInNano + || nearTheEnd ) let seekToStart = startTimeChanged || inFilePathChanged || startOver when inFilePathChanged $ do @@ -276,6 +277,7 @@ videoPreview (Just $ pack $ "file://" ++ inFilePath) _ <- Data.GI.Base.Properties.setObjectPropertyDouble playbinElement "volume" 0.0 resizeWindow window + return () when seekToStart $ do _ <- GI.Gst.elementSetState playbinElement GI.Gst.StatePaused _ <- GI.Gst.elementSeekSimple @@ -283,17 +285,18 @@ videoPreview GI.Gst.FormatTime [GI.Gst.SeekFlagsFlush] startTimeInNano - _ <- GI.Gst.elementSetState playbinElement GI.Gst.StatePlaying + playPlaybinElement guiComponents return () - handleCropMode :: IO () - handleCropMode = do - cropModeEnabled <- GI.Gtk.getToggleButtonActive cropToggleButton - if cropModeEnabled + updateVideoPreviewAspectRatio :: IO () + updateVideoPreviewAspectRatio = do + cropModeEnabled <- GI.Gtk.getToggleButtonActive cropToggleButton + textOverlayModeEnabled <- GI.Gtk.getToggleButtonActive textOverlaysToggleButton + if cropModeEnabled || textOverlayModeEnabled then - void $ Data.GI.Base.Properties.setObjectPropertyBool - playbinElement - "force-aspect-ratio" - False + void $ Data.GI.Base.Properties.setObjectPropertyBool + playbinElement + "force-aspect-ratio" + False else void $ Data.GI.Base.Properties.setObjectPropertyBool playbinElement @@ -328,8 +331,8 @@ firstAndLastFramePreview inFilePath startTime durationTime - _ - _ + inVideoWidth + inVideoHeight = do GI.Gtk.widgetShow imagesPreviewBox handleChanges @@ -337,19 +340,18 @@ firstAndLastFramePreview where handleChanges :: IO () handleChanges = do - let inFilePathChanged = - fromMaybe "" maybeInFilePath /= inFilePath - let startTimeChanged = - fromMaybe (-1.0) maybeStartTime /= startTime - let durationTimeChanged = - fromMaybe (-1.0) maybeDurationTime /= durationTime + let inFilePathChanged = fromMaybe "" maybeInFilePath /= inFilePath + let startTimeChanged = fromMaybe (-1.0) maybeStartTime /= startTime + let durationTimeChanged = fromMaybe (-1.0) maybeDurationTime /= durationTime let firstAndLastFrameDirty = inFilePathChanged || startTimeChanged - let lastFrameDirty = not firstAndLastFrameDirty && durationTimeChanged + let lastFrameDirty = not firstAndLastFrameDirty && durationTimeChanged + let (previewWidth, _) = getPreviewWidthAndHeight inVideoWidth inVideoHeight when firstAndLastFrameDirty $ makeFirstAndLastFramePreview inFilePath startTime durationTime + (previewWidth / 2.0) firstFrameImage lastFrameImage temporaryDirectory @@ -359,6 +361,7 @@ firstAndLastFramePreview inFilePath startTime durationTime + (previewWidth / 2.0) lastFrameImage temporaryDirectory window @@ -367,6 +370,69 @@ firstAndLastFramePreview GI.Gtk.widgetQueueDraw firstFramePreviewImageDrawingArea GI.Gtk.widgetQueueDraw lastFramePreviewImageDrawingArea +runPreviewOverlay :: GR.GuiComponents -> IO () +runPreviewOverlay + guiComponents@GR.GuiComponents + { GR.maybeVideoPreviewWidget = (Just _) + , GR.maybePlaybinElement = (Just _) + , GR.videoPreviewDrawingArea + } + = do + _ <- GI.GLib.timeoutAdd + GI.GLib.PRIORITY_DEFAULT + 1 $ do + GI.Gtk.widgetQueueDraw videoPreviewDrawingArea + return True + onPreviewOverlayDraw + guiComponents + videoPreviewDrawingArea + ForFramePreviewNone + True + return () +runPreviewOverlay + guiComponents@GR.GuiComponents + { GR.firstFramePreviewImageDrawingArea + , GR.lastFramePreviewImageDrawingArea + } + = do + _ <- GI.GLib.timeoutAdd + GI.GLib.PRIORITY_DEFAULT + 1 $ do + GI.Gtk.widgetQueueDraw firstFramePreviewImageDrawingArea + GI.Gtk.widgetQueueDraw lastFramePreviewImageDrawingArea + return True + onPreviewOverlayDraw + guiComponents + firstFramePreviewImageDrawingArea + ForFramePreviewFirst + False + onPreviewOverlayDraw + guiComponents + lastFramePreviewImageDrawingArea + ForFramePreviewLast + False + return () + +onPreviewOverlayDraw + :: GR.GuiComponents + -> GI.Gtk.DrawingArea + -> ForFramePreview + -> Bool + -> IO () +onPreviewOverlayDraw + guiComponents + drawingArea + forFramePreview + bool + = + void $ + GI.Gtk.onWidgetDraw + drawingArea $ + \ context -> do + _ <- drawCropGrid guiComponents drawingArea context + _ <- drawTextOverlays guiComponents drawingArea forFramePreview context + return bool + drawCropGrid :: GR.GuiComponents -> GI.Gtk.DrawingArea -> GI.Cairo.Context -> IO Bool drawCropGrid GR.GuiComponents @@ -383,42 +449,457 @@ drawCropGrid GR.InVideoProperties { GR.inVideoWidth , GR.inVideoHeight - } <- readIORef inVideoPropertiesRef - cropModeEnabled <- GI.Gtk.getToggleButtonActive cropToggleButton - drawingAreaWidth <- + } <- readIORef inVideoPropertiesRef + cropModeEnabled <- GI.Gtk.getToggleButtonActive cropToggleButton + drawingAreaWidth <- int32ToDouble <$> GI.Gtk.widgetGetAllocatedWidth drawingArea drawingAreaHeight <- int32ToDouble <$> GI.Gtk.widgetGetAllocatedHeight drawingArea - left <- (/ 100.0) <$> GI.Gtk.spinButtonGetValue leftCropSpinButton - right <- (/ 100.0) <$> GI.Gtk.spinButtonGetValue rightCropSpinButton - top <- (/ 100.0) <$> GI.Gtk.spinButtonGetValue topCropSpinButton - bottom <- (/ 100.0) <$> GI.Gtk.spinButtonGetValue bottomCropSpinButton - when (cropModeEnabled && inVideoWidth >= 0.0 && inVideoHeight >= 0.0) $ + left <- GI.Gtk.spinButtonGetValue leftCropSpinButton + right <- GI.Gtk.spinButtonGetValue rightCropSpinButton + top <- GI.Gtk.spinButtonGetValue topCropSpinButton + bottom <- GI.Gtk.spinButtonGetValue bottomCropSpinButton + when (cropModeEnabled && inVideoWidth > 0.0 && inVideoHeight > 0.0) $ GiCairoCairoBridge.renderWithContext context $ do - GRC.setSourceRGBA 0.0 0.0 0.0 0.8 - GRC.setLineWidth 1.0 + let drawPatternRect a b c d = + GRC.withLinearPattern + 0.0 + 4.0 + 4.0 + 0.0 + (\ p -> do + let addStopZero o = + GRC.patternAddColorStopRGBA p o (241.0 / 255.0) (196.0 / 255.0) (15.0 / 255.0) 0.8 + let addStopOne o = + GRC.patternAddColorStopRGBA p o (192.0 / 255.0) ( 57.0 / 255.0) (43.0 / 255.0) 0.8 + addGradientPatternStops addStopZero addStopOne + GRC.patternSetExtend p GRC.ExtendRepeat + GRC.setSource p + GRC.rectangle a b c d + GRC.fill + ) -- Left - GRC.rectangle 0.0 0.0 (left * drawingAreaWidth) drawingAreaHeight - GRC.fill + drawPatternRect + 0.0 + 0.0 + (left * drawingAreaWidth) + drawingAreaHeight -- Right - GRC.rectangle + drawPatternRect (drawingAreaWidth - right * drawingAreaWidth) 0.0 (right * drawingAreaWidth) drawingAreaHeight - GRC.fill -- Top - GRC.rectangle 0.0 0.0 drawingAreaWidth (top * drawingAreaHeight) - GRC.fill + drawPatternRect + 0.0 + 0.0 + drawingAreaWidth + (top * drawingAreaHeight) -- Bottom - GRC.rectangle + drawPatternRect 0.0 (drawingAreaHeight - bottom * drawingAreaHeight) drawingAreaWidth (bottom * drawingAreaHeight) - GRC.fill return False +drawTextOverlays + :: GR.GuiComponents + -> GI.Gtk.DrawingArea + -> ForFramePreview + -> GI.Cairo.Context + -> IO Bool +drawTextOverlays + guiComponents@GR.GuiComponents + { GR.startTimeSpinButton + , GR.durationTimeSpinButton + , GR.textOverlaysToggleButton + , GR.inVideoPropertiesRef + } + drawingArea + forFramePreview + context + = do + GR.InVideoProperties + { GR.inVideoWidth + , GR.inVideoHeight + , GR.inVideoDuration + } <- readIORef inVideoPropertiesRef + textOverlayModeEnabled <- GI.Gtk.getToggleButtonActive textOverlaysToggleButton + when (textOverlayModeEnabled && inVideoWidth > 0.0 && inVideoHeight > 0.0) $ do + (videoDuration, videoPosition) <- getVideoDurationAndPosition (floatToDouble inVideoDuration) + drawingAreaWidth <- int32ToDouble <$> GI.Gtk.widgetGetAllocatedWidth drawingArea + drawingAreaHeight <- int32ToDouble <$> GI.Gtk.widgetGetAllocatedHeight drawingArea + GuiTextOverlays.updateTextOverlays False guiComponents + textOverlaysData <- GuiTextOverlays.getTextOverlaysData guiComponents + GiCairoCairoBridge.renderWithContext context $ + mapM_ + (renderTextOverlayData videoDuration videoPosition drawingAreaWidth drawingAreaHeight) + textOverlaysData + return False + where + renderTextOverlayData + :: Double + -> Double + -> Double + -> Double + -> GR.GuiTextOverlayData + -> GRC.Render () + renderTextOverlayData + _videoDuration + videoPosition + drawingAreaWidth + drawingAreaHeight + GR.GuiTextOverlayData + { GR.textOverlayText + , GR.textOverlayLeft + , GR.textOverlayTop + , GR.textOverlayStartTime + , GR.textOverlayEndTime + , GR.textOverlayRotation + , GR.textOverlayOutlineSize + , GR.textOverlayOutlineColor + , GR.textOverlayFillColor + , GR.textOverlayMaybeFontDesc + } + = do + GRC.save + + GRC.setLineWidth $ int32ToDouble textOverlayOutlineSize + pangoLayout <- GRPC.createLayout textOverlayText + liftIO $ GRPL.layoutSetAlignment pangoLayout GRPL.AlignCenter + liftIO $ GRPL.layoutSetFontDescription pangoLayout textOverlayMaybeFontDesc + (_, GRPL.PangoRectangle _x _y width height) <- liftIO $ GRPL.layoutGetExtents pangoLayout + let alphaChannel = + if textOverlayStartTime <= videoPosition + && textOverlayEndTime >= videoPosition + then 1.0 + else 0.3 + let x = (textOverlayLeft + 0.5) * drawingAreaWidth + let y = (textOverlayTop + 0.5) * drawingAreaHeight + let x' = x - (width / 2.0) + let y' = y - (height / 2.0) + let r = int32ToDouble textOverlayRotation * pi / 180.0 + + GRC.translate x y + GRC.rotate r + GRC.translate (-1 * x) (-1 * y) + GRC.translate x' y' + + GRPC.layoutPath pangoLayout + (oR, oG, oB) <- liftIO $ getRgb textOverlayOutlineColor + GRC.setSourceRGBA oR oG oB alphaChannel + GRC.stroke + (fR, fG, fB) <- liftIO $ getRgb textOverlayFillColor + GRC.setSourceRGBA fR fG fB alphaChannel + GRPC.showLayout pangoLayout + + GRC.restore + getRgb :: String -> IO (Double, Double, Double) + getRgb string = do + rgba <- GI.Gdk.newZeroRGBA + _ <- GI.Gdk.rGBAParse rgba (Data.Text.pack string) + r <- GI.Gdk.getRGBARed rgba + g <- GI.Gdk.getRGBAGreen rgba + b <- GI.Gdk.getRGBABlue rgba + return (r, g, b) + getVideoDurationAndPosition :: Double -> IO (Double, Double) + getVideoDurationAndPosition inVideoDuration = do + (playbinDuration, playbinPosition) <- getPlaybinDurationAndPosition guiComponents + case (playbinDuration, playbinPosition) of + (Just videoDuration, Just videoPosition) -> + return + ( nanosecondsToSeconds videoDuration + , nanosecondsToSeconds videoPosition + ) + _ -> + case forFramePreview of + ForFramePreviewFirst -> do + videoPosition <- GI.Gtk.spinButtonGetValue startTimeSpinButton + return (inVideoDuration, videoPosition) + ForFramePreviewLast -> do + startTime <- GI.Gtk.spinButtonGetValue startTimeSpinButton + durationTime <- GI.Gtk.spinButtonGetValue durationTimeSpinButton + let videoPosition = startTime + durationTime + return (inVideoDuration, videoPosition) + ForFramePreviewNone -> return (0.0, -1.0) + +runTimeSlicesWidget :: GR.GuiComponents -> IO () +runTimeSlicesWidget + guiComponents@GR.GuiComponents + { GR.maybeVideoPreviewWidget + , GR.maybePlaybinElement + , GR.startTimeSpinButton + , GR.durationTimeSpinButton + , GR.timeSlicesDrawingArea + , GR.inVideoPropertiesRef + } + = do + when (isJust maybeVideoPreviewWidget && isJust maybePlaybinElement) $ do + GI.Gtk.widgetSetTooltipText + timeSlicesDrawingArea $ + Just "Click to change the video position." + addOnMouseClickHandler + void $ + GI.GLib.timeoutAdd + GI.GLib.PRIORITY_DEFAULT + 1 $ do + GI.Gtk.widgetQueueDraw timeSlicesDrawingArea + return True + void $ + GI.Gtk.onWidgetDraw + timeSlicesDrawingArea $ + \ context -> do + GR.InVideoProperties + { GR.inVideoDuration + } <- readIORef inVideoPropertiesRef + when (inVideoDuration > 0.0) $ do + startTime <- GI.Gtk.spinButtonGetValue startTimeSpinButton + durationTime <- GI.Gtk.spinButtonGetValue durationTimeSpinButton + textOverlaysData <- GuiTextOverlays.getTextOverlaysData guiComponents + drawingAreaWidth <- int32ToDouble <$> GI.Gtk.widgetGetAllocatedWidth timeSlicesDrawingArea + drawingAreaHeight <- int32ToDouble <$> GI.Gtk.widgetGetAllocatedHeight timeSlicesDrawingArea + let inVideoDuration' = floatToDouble inVideoDuration + let startTime' = startTime / inVideoDuration' + let durationTime' = durationTime / inVideoDuration' + GiCairoCairoBridge.renderWithContext context $ do + let transparent = (0.0, 0.0, 0.0, 0.0) + let drawPatternRect (r0, g0, b0, a0) (r1, g1, b1, a1) a b c d = + GRC.withLinearPattern + 0.0 + 0.0 + 4.0 + 4.0 + (\ p -> do + let addStopZero o = + GRC.patternAddColorStopRGBA p o r0 g0 b0 a0 + let addStopOne o = + GRC.patternAddColorStopRGBA p o r1 g1 b1 a1 + addGradientPatternStops addStopZero addStopOne + GRC.patternSetExtend p GRC.ExtendRepeat + GRC.setSource p + GRC.rectangle a b c d + GRC.fill + ) + + GRC.setSourceRGBA 0.1 0.1 0.1 1.0 + GRC.rectangle 0.0 0.0 drawingAreaWidth drawingAreaHeight + GRC.fill + + -- GIF time slice. + drawPatternRect + (109.0 / 255.0, 40.0 / 255.0, 255.0 / 255.0, 1.0) + transparent + 0.0 + 0.0 + drawingAreaWidth + (drawingAreaHeight / 2.0) + + -- Video duration. + drawPatternRect + (109.0 / 255.0, 40.0 / 255.0, 255.0 / 255.0, 1.0) + transparent + (startTime' * drawingAreaWidth) + (drawingAreaHeight / 2.0) + (durationTime' * drawingAreaWidth) + (drawingAreaHeight / 2.0) + + mapM_ + (\ GR.GuiTextOverlayData + { GR.textOverlayText + , GR.textOverlayStartTime + , GR.textOverlayDurationTime + } + -> + unless (Data.List.null textOverlayText) $ do + -- GIF time slice. + when (durationTime > 0.0) $ + drawPatternRect + transparent + (0.0 / 255.0, 255.0 / 255.0, 112.0 / 255.0, 1.0) + (((textOverlayStartTime - startTime) / durationTime) * drawingAreaWidth) + 0.0 + ((textOverlayDurationTime / durationTime) * drawingAreaWidth) + (drawingAreaHeight / 2.0) + + -- Video duration. + drawPatternRect + transparent + (0.0 / 255.0, 255.0 / 255.0, 112.0 / 255.0, 1.0) + ((textOverlayStartTime / inVideoDuration') * drawingAreaWidth) + (drawingAreaHeight / 2.0) + ((textOverlayDurationTime / inVideoDuration') * drawingAreaWidth) + (drawingAreaHeight / 2.0) + ) + textOverlaysData + + (playbinDuration, playbinPosition) <- + liftIO $ getPlaybinDurationAndPosition guiComponents + case (playbinDuration, playbinPosition) of + (Just playbinDuration', Just playbinPosition') -> do + let videoDuration' = nanosecondsToSeconds playbinDuration' + let videoPosition' = nanosecondsToSeconds playbinPosition' + when (videoDuration' > 0.0) $ do + when (durationTime > 0.0) $ do + -- GIF time slice. + let videoPositionLineX = + (((videoPosition' - startTime) / durationTime) * drawingAreaWidth - 1.0) + GRC.rectangle + videoPositionLineX + 0.0 + 2.0 + (drawingAreaHeight / 2.0) + GRC.setSourceRGBA 1.0 1.0 1.0 1.0 + GRC.fill + + GRC.selectFontFace + ("monospace" :: String) + GRC.FontSlantNormal + GRC.FontWeightNormal + GRC.setFontSize 15.0 + let videoPosition'' = printf "%.2f" videoPosition' :: String + textWidth <- GRC.textExtentsWidth <$> GRC.textExtents videoPosition'' + textHeight <- GRC.textExtentsHeight <$> GRC.textExtents videoPosition'' + let textX = videoPositionLineX - (textWidth / 2.0) + let textY = drawingAreaHeight / 4.0 - (textHeight / 2.0) + GRC.rectangle textX textY (textWidth + 1.0) (textHeight + 1.0) + GRC.setSourceRGBA 0.1 0.1 0.1 1.0 + GRC.fill + GRC.setSourceRGBA 1.0 1.0 1.0 1.0 + GRC.moveTo textX (textY + textHeight) + GRC.showText videoPosition'' + + -- Video duration. + GRC.rectangle + ((videoPosition' / videoDuration') * drawingAreaWidth - 1.0) + (drawingAreaHeight / 2.0) + 2.0 + (drawingAreaHeight / 2.0) + GRC.setSourceRGBA 1.0 1.0 1.0 1.0 + GRC.fill + _ -> return () + + -- Dividing line. + GRC.setSourceRGBA 0.1 0.1 0.1 1.0 + GRC.rectangle 0.0 (drawingAreaHeight / 2.0 - 1.0) drawingAreaWidth 2.0 + GRC.fill + return True + where + addOnMouseClickHandler :: IO () + addOnMouseClickHandler = do + GI.Gtk.widgetAddEvents timeSlicesDrawingArea [GI.Gdk.EventMaskAllEventsMask] + void $ + GI.Gtk.onWidgetButtonReleaseEvent + timeSlicesDrawingArea $ \ eventButton -> do + eventButtonNumber <- GI.Gdk.getEventButtonButton eventButton + when (eventButtonNumber == 1) $ do + x <- GI.Gdk.getEventButtonX eventButton + y <- GI.Gdk.getEventButtonY eventButton + (playbinDuration, _) <- liftIO $ getPlaybinDurationAndPosition guiComponents + case (maybePlaybinElement, playbinDuration) of + (Just playbinElement, Just playbinDuration') -> do + let videoDuration' = nanosecondsToSeconds playbinDuration' + drawingAreaWidth <- int32ToDouble <$> GI.Gtk.widgetGetAllocatedWidth timeSlicesDrawingArea + drawingAreaHeight <- int32ToDouble <$> GI.Gtk.widgetGetAllocatedHeight timeSlicesDrawingArea + when (videoDuration' > 0.0 && drawingAreaWidth > 0.0) $ do + startTime <- GI.Gtk.spinButtonGetValue startTimeSpinButton + durationTime <- GI.Gtk.spinButtonGetValue durationTimeSpinButton + _ <- GI.Gst.elementSetState playbinElement GI.Gst.StatePaused + let seekPlaybinTo t = + void $ + GI.Gst.elementSeekSimple + playbinElement + GI.Gst.FormatTime + [GI.Gst.SeekFlagsFlush] + t + if y <= (drawingAreaHeight / 2.0) + then do + let a = x / drawingAreaWidth + let b = a * durationTime + let c = startTime + b + let seekToInNano = secondsToNanoseconds $ doubleToFloat c + seekPlaybinTo seekToInNano + else do + let a = x / drawingAreaWidth + let b = a * videoDuration' + when (b >= startTime && b <= startTime + durationTime) $ do + let seekToInNano = secondsToNanoseconds $ doubleToFloat b + seekPlaybinTo seekToInNano + playPlaybinElement guiComponents + _ -> return () + return True + +addGradientPatternStops + :: (Double -> GRC.Render ()) + -> (Double -> GRC.Render ()) + -> GRC.Render () +addGradientPatternStops f0 f1 = do + f0 0.0 + f1 0.25 + f0 0.5 + f1 0.75 + f0 1.0 + +setupVideoPreviewPauseToggleButton :: GR.GuiComponents -> IO () +setupVideoPreviewPauseToggleButton + guiComponents@GR.GuiComponents + { GR.maybeVideoPreviewWidget = (Just _) + , GR.maybePlaybinElement = (Just playbinElement) + , GR.videoPreviewPauseToggleButton + } + = do + GI.Gtk.widgetShow videoPreviewPauseToggleButton + void $ + GI.Gtk.afterToggleButtonToggled + videoPreviewPauseToggleButton $ do + active <- GI.Gtk.getToggleButtonActive videoPreviewPauseToggleButton + (_, playing, _) <- GI.Gst.elementGetState playbinElement (-1) + if active && playing == GI.Gst.StatePlaying + then void $ GI.Gst.elementSetState playbinElement GI.Gst.StatePaused + else playPlaybinElement guiComponents + if active + then GI.Gtk.setButtonLabel videoPreviewPauseToggleButton "Paused" + else GI.Gtk.setButtonLabel videoPreviewPauseToggleButton "Pause" +setupVideoPreviewPauseToggleButton + GR.GuiComponents + { GR.videoPreviewPauseToggleButton + } + = GI.Gtk.widgetHide videoPreviewPauseToggleButton + +playPlaybinElement :: GR.GuiComponents -> IO () +playPlaybinElement + GR.GuiComponents + { GR.maybeVideoPreviewWidget = (Just _) + , GR.maybePlaybinElement = (Just playbinElement) + , GR.videoPreviewPauseToggleButton + } + = do + active <- GI.Gtk.getToggleButtonActive videoPreviewPauseToggleButton + (_, playing, _) <- GI.Gst.elementGetState playbinElement (-1) + when (not active && playing == GI.Gst.StatePaused) $ + void $ GI.Gst.elementSetState playbinElement GI.Gst.StatePlaying +playPlaybinElement _ = return () + +getPlaybinDurationAndPosition :: GR.GuiComponents -> IO (Maybe Int64, Maybe Int64) +getPlaybinDurationAndPosition + GR.GuiComponents + { GR.maybeVideoPreviewWidget = Just _videoPreviewWidget + , GR.maybePlaybinElement = Just playbinElement + } + = do + (couldQueryDuration, playbinDuration) <- + GI.Gst.elementQueryDuration playbinElement GI.Gst.FormatTime + (couldQueryPosition, playbinPosition) <- + GI.Gst.elementQueryPosition playbinElement GI.Gst.FormatTime + if couldQueryDuration + && couldQueryPosition + && playbinDuration > 0 + && playbinPosition >= 0 + then return (Just playbinDuration, Just playbinPosition) + else return (Nothing, Nothing) +getPlaybinDurationAndPosition _ = return (Nothing, Nothing) + resetWindow :: GR.GuiComponents -> IO () resetWindow GR.GuiComponents @@ -430,7 +911,7 @@ resetWindow = do GI.Gtk.widgetSetSizeRequest window - 900 + (floatToInt32 $ desiredPreviewSize + 300.0) (-1) GI.Gtk.widgetSetSizeRequest mainPreviewBox @@ -448,6 +929,7 @@ makeFirstAndLastFramePreview :: String -> Float -> Float + -> Float -> GI.Gtk.Image -> GI.Gtk.Image -> System.FilePath.FilePath @@ -457,6 +939,7 @@ makeFirstAndLastFramePreview inFilePath startTime durationTime + previewWidth firstFrameImage lastFrameImage temporaryDirectory @@ -475,13 +958,14 @@ makeFirstAndLastFramePreview inFilePath outFilePath startTime + previewWidth firstFrameImage - "" window makeLastFramePreview inFilePath startTime durationTime + previewWidth lastFrameImage temporaryDirectory window @@ -490,6 +974,7 @@ makeLastFramePreview :: String -> Float -> Float + -> Float -> GI.Gtk.Image -> System.FilePath.FilePath -> GI.Gtk.Window @@ -498,6 +983,7 @@ makeLastFramePreview inFilePath startTime durationTime + previewWidth lastFrameImage temporaryDirectory window @@ -516,8 +1002,8 @@ makeLastFramePreview inFilePath outFilePath startTime' + previewWidth lastFrameImage - "" window setOrResetFramePrevew @@ -525,11 +1011,11 @@ setOrResetFramePrevew -> String -> String -> Float + -> Float -> GI.Gtk.Image - -> String -> GI.Gtk.Window -> IO () -setOrResetFramePrevew False _ _ _ image _ window = +setOrResetFramePrevew False _ _ _ _ image window = GtkMainSyncAsync.gtkMainAsync $ do resetImage image resizeWindow window @@ -538,11 +1024,11 @@ setOrResetFramePrevew inFilePath outFilePath time + previewWidth image - overlay window = do - result <- makeImagePreview inFilePath outFilePath time overlay + result <- makeImagePreview inFilePath outFilePath time previewWidth case result of Left _ -> void $ updatePreviewFrame "" image False @@ -554,21 +1040,38 @@ makeImagePreview :: String -> String -> Float - -> String + -> Float -> IO (Either IOError String) -makeImagePreview inputFile outputFile startTime bottomText = +makeImagePreview inputFile outputFile startTime previewWidth = Gifcurry.gif $ Gifcurry.defaultGifParams - { Gifcurry.inputFile = inputFile - , Gifcurry.outputFile = outputFile - , Gifcurry.saveAsVideo = False - , Gifcurry.startTime = startTime - , Gifcurry.durationTime = 0.001 - , Gifcurry.widthSize = 300 - , Gifcurry.qualityPercent = 50.0 - , Gifcurry.bottomText = bottomText + { Gifcurry.inputFile = inputFile + , Gifcurry.outputFile = outputFile + , Gifcurry.saveAsVideo = False + , Gifcurry.startTime = startTime + , Gifcurry.durationTime = 0.001 + , Gifcurry.widthSize = round previewWidth :: Int + , Gifcurry.quality = Gifcurry.QualityLow } +getPreviewWidthAndHeight :: Float -> Float -> (Float, Float) +getPreviewWidthAndHeight inVideoWidth inVideoHeight = (previewWidth, previewHeight) + where + widthRatio :: Float + widthRatio = inVideoWidth / inVideoHeight + heightRatio :: Float + heightRatio = inVideoHeight / inVideoWidth + previewWidth :: Float + previewWidth = + if inVideoWidth >= inVideoHeight + then desiredPreviewSize + else (desiredPreviewSize / 2.0) * widthRatio + previewHeight :: Float + previewHeight = + if inVideoWidth >= inVideoHeight + then desiredPreviewSize * heightRatio + else desiredPreviewSize / 2.0 + updatePreviewFrame :: String -> GI.Gtk.Image -> Bool -> IO () updatePreviewFrame filePath image True = GtkMainSyncAsync.gtkMainSync (GI.Gtk.imageSetFromFile image (Just filePath)) @@ -586,5 +1089,9 @@ secondsToNanoseconds :: Float -> Int64 secondsToNanoseconds s = fromIntegral (round (s * 1000000000.0) :: Integer) :: Int64 +nanosecondsToSeconds :: Int64 -> Double +nanosecondsToSeconds s = + int64ToDouble s * (1.0 / 1000000000.0) + desiredPreviewSize :: Float -desiredPreviewSize = 600.0 +desiredPreviewSize = 700.0 diff --git a/src/gui/GuiRecords.hs b/src/gui/GuiRecords.hs index 1bc384c..027f15e 100644 --- a/src/gui/GuiRecords.hs +++ b/src/gui/GuiRecords.hs @@ -7,7 +7,9 @@ module GuiRecords where import Data.IORef +import Data.Int import qualified GI.Gtk +import qualified Graphics.Rendering.Pango.Font as GRPF import GI.Gst data GuiComponents = @@ -16,7 +18,6 @@ data GuiComponents = , startTimeSpinButton :: GI.Gtk.SpinButton , durationTimeSpinButton :: GI.Gtk.SpinButton , widthSizeSpinButton :: GI.Gtk.SpinButton - , qualityPercentSpinButton :: GI.Gtk.SpinButton , leftCropSpinButton :: GI.Gtk.SpinButton , rightCropSpinButton :: GI.Gtk.SpinButton , topCropSpinButton :: GI.Gtk.SpinButton @@ -25,57 +26,58 @@ data GuiComponents = , inFileChooserDialogCancelButton :: GI.Gtk.Button , inFileChooserDialogOpenButton :: GI.Gtk.Button , outFileChooserButton :: GI.Gtk.FileChooserButton - , fontChooserButton :: GI.Gtk.FontButton + , textOverlaysAddButton :: GI.Gtk.Button , saveButton :: GI.Gtk.Button , openButton :: GI.Gtk.Button - , yesGtkButton :: GI.Gtk.Button - , noGtkButton :: GI.Gtk.Button + , confirmMessageDialogYesButton :: GI.Gtk.Button + , confirmMessageDialogNoButton :: GI.Gtk.Button , aboutButton :: GI.Gtk.Button , giphyUploadButton :: GI.Gtk.Button , imgurUploadButton :: GI.Gtk.Button , saveAsVideoRadioButton :: GI.Gtk.RadioButton - , widthQualityPercentToggleButton :: GI.Gtk.ToggleButton + , widthQualityToggleButton :: GI.Gtk.ToggleButton , cropToggleButton :: GI.Gtk.ToggleButton - , topBottomTextToggleButton :: GI.Gtk.ToggleButton + , textOverlaysToggleButton :: GI.Gtk.ToggleButton , saveOpenToggleButton :: GI.Gtk.ToggleButton , uploadToggleButton :: GI.Gtk.ToggleButton + , videoPreviewPauseToggleButton :: GI.Gtk.ToggleButton , inFileChooserDialogLabel :: GI.Gtk.Label , inFileChooserButtonLabel :: GI.Gtk.Label , startTimeAdjustment :: GI.Gtk.Adjustment , durationTimeAdjustment :: GI.Gtk.Adjustment , widthSizeAdjustment :: GI.Gtk.Adjustment - , qualityPercentAdjustment :: GI.Gtk.Adjustment , outFileNameEntry :: GI.Gtk.Entry - , topTextEntry :: GI.Gtk.Entry - , bottomTextEntry :: GI.Gtk.Entry , statusEntry :: GI.Gtk.Entry + , sidebarControlsPreviewbox :: GI.Gtk.Box , mainPreviewBox :: GI.Gtk.Box , imagesPreviewBox :: GI.Gtk.Box , videoPreviewBox :: GI.Gtk.Box , videoPreviewOverlayChildBox :: GI.Gtk.Box - , widthQualityPercentBox :: GI.Gtk.Box + , widthQualityBox :: GI.Gtk.Box , cropSpinButtonsBox :: GI.Gtk.Box - , topBottomTextFontChooserBox :: GI.Gtk.Box + , textOverlaysMainBox :: GI.Gtk.Box + , textOverlaysBox :: GI.Gtk.Box , saveOpenBox :: GI.Gtk.Box , uploadBox :: GI.Gtk.Box + , qualityComboBoxText :: GI.Gtk.ComboBoxText , videoPreviewDrawingArea :: GI.Gtk.DrawingArea + , timeSlicesDrawingArea :: GI.Gtk.DrawingArea , firstFramePreviewImageDrawingArea :: GI.Gtk.DrawingArea , lastFramePreviewImageDrawingArea :: GI.Gtk.DrawingArea , inFileChooserButtonImage :: GI.Gtk.Image , firstFrameImage :: GI.Gtk.Image , lastFrameImage :: GI.Gtk.Image , inFileChooserDialog :: GI.Gtk.Dialog - , longGifGtkMessageDialog :: GI.Gtk.MessageDialog + , confirmMessageDialog :: GI.Gtk.MessageDialog , aboutDialog :: GI.Gtk.AboutDialog - , startTimeProgressBar :: GI.Gtk.ProgressBar - , endTimeProgressBar :: GI.Gtk.ProgressBar , saveSpinner :: GI.Gtk.Spinner , inFileChooserWidget :: GI.Gtk.FileChooserWidget , maybeVideoPreviewWidget :: Maybe GI.Gtk.Widget , maybePlaybinElement :: Maybe GI.Gst.Element , temporaryDirectory :: FilePath - , guiPreviewStateRef :: IORef GuiPreviewState + , textOverlaysRef :: IORef [GuiTextOverlayComponents] , inVideoPropertiesRef :: IORef InVideoProperties + , guiPreviewStateRef :: IORef GuiPreviewState } data GuiPreviewState = @@ -94,20 +96,54 @@ data InVideoProperties = , inVideoHeight :: Float } +data GuiTextOverlayComponents = + GuiTextOverlayComponents + { textOverlayId :: Int + , textOverlayBox :: GI.Gtk.Box + , textOverlayVisibilityBox :: GI.Gtk.Box + , textOverlayVisibilityToggleButton :: GI.Gtk.ToggleButton + , textOverlayLeftSpinButton :: GI.Gtk.SpinButton + , textOverlayTopSpinButton :: GI.Gtk.SpinButton + , textOverlayStartTimeSpinButton :: GI.Gtk.SpinButton + , textOverlayDurationTimeSpinButton :: GI.Gtk.SpinButton + , textOverlayRotationSpinButton :: GI.Gtk.SpinButton + , textOverlayOutlineSizeSpinButton :: GI.Gtk.SpinButton + , textOverlayOutlineColorButton :: GI.Gtk.ColorButton + , textOverlayFillColorButton :: GI.Gtk.ColorButton + , textOverlayTextEntry :: GI.Gtk.Entry + , textOverlayFontButton :: GI.Gtk.FontButton + , textOverlayRemoveButton :: GI.Gtk.Button + } + +data GuiTextOverlayData = + GuiTextOverlayData + { textOverlayText :: String + , textOverlayLeft :: Double + , textOverlayTop :: Double + , textOverlayStartTime :: Double + , textOverlayDurationTime :: Double + , textOverlayEndTime :: Double + , textOverlayRotation :: Int32 + , textOverlayOutlineSize :: Int32 + , textOverlayOutlineColor :: String + , textOverlayFillColor :: String + , textOverlayMaybeFontDesc :: Maybe GRPF.FontDescription + } + defaultGuiPreviewState :: GuiPreviewState defaultGuiPreviewState = GuiPreviewState - { maybeInFilePath = Nothing - , maybeStartTime = Nothing + { maybeInFilePath = Nothing + , maybeStartTime = Nothing , maybeDurationTime = Nothing - , loopRunning = False + , loopRunning = False } defaultInVideoProperties :: InVideoProperties defaultInVideoProperties = InVideoProperties - { inVideoUri = "" + { inVideoUri = "" , inVideoDuration = 0.0 - , inVideoWidth = 0.0 - , inVideoHeight = 0.0 + , inVideoWidth = 0.0 + , inVideoHeight = 0.0 } diff --git a/src/gui/GuiTextOverlays.hs b/src/gui/GuiTextOverlays.hs new file mode 100644 index 0000000..cb1acdf --- /dev/null +++ b/src/gui/GuiTextOverlays.hs @@ -0,0 +1,593 @@ +{- + Gifcurry + (C) 2018 David Lettier + lettier.com +-} + +{-# LANGUAGE + OverloadedStrings + , NamedFieldPuns + , BangPatterns +#-} + +module GuiTextOverlays where + +import Control.Monad +import Control.Exception +import Data.Maybe +import Data.IORef +import qualified Data.Text +import Data.List (sort) +import qualified GI.Gdk +import qualified GI.Gtk +import qualified GI.Pango +import qualified Graphics.Rendering.Pango.Enums as GRPF +import qualified Graphics.Rendering.Pango.Font as GRPF + +import qualified Gifcurry +import qualified GuiRecords as GR +import GuiMisc + +handleTextOverlaysAddButton :: GR.GuiComponents -> IO () +handleTextOverlaysAddButton + guiComponents@GR.GuiComponents + { GR.textOverlaysAddButton + } + = + void $ + GI.Gtk.onButtonClicked + textOverlaysAddButton + (addTextOverlay guiComponents) + +getGifcurryTextOverlays :: GR.GuiComponents -> IO [Gifcurry.TextOverlay] +getGifcurryTextOverlays + guiComponents@GR.GuiComponents + { GR.widthSizeSpinButton + } + = do + guiTextOverlaysData <- getTextOverlaysData guiComponents + (_, previewWidth, _) <- getPreviewDurationWidthAndHeight guiComponents + widthSelection <- GI.Gtk.spinButtonGetValue widthSizeSpinButton + mapM + ( getGifcurryTextOverlay + previewWidth + widthSelection + ) + guiTextOverlaysData + where + getGifcurryTextOverlay + :: Double + -> Double + -> GR.GuiTextOverlayData + -> IO Gifcurry.TextOverlay + getGifcurryTextOverlay + previewWidth + gifWidth + GR.GuiTextOverlayData + { GR.textOverlayText + , GR.textOverlayLeft + , GR.textOverlayTop + , GR.textOverlayStartTime + , GR.textOverlayDurationTime + , GR.textOverlayRotation + , GR.textOverlayOutlineSize + , GR.textOverlayOutlineColor + , GR.textOverlayFillColor + , GR.textOverlayMaybeFontDesc + } + = do + newFontDesc <- GRPF.fontDescriptionNew + let fontDesc = fromMaybe newFontDesc textOverlayMaybeFontDesc + fontFamily <- fromMaybe "" <$> GRPF.fontDescriptionGetFamily fontDesc + fontStyle <- removeQuotes . show . fromMaybe GRPF.StyleNormal <$> GRPF.fontDescriptionGetStyle fontDesc + fontStretch <- removeQuotes . show . fromMaybe GRPF.StretchNormal <$> GRPF.fontDescriptionGetStretch fontDesc + fontWeight <- getFontWeight fontDesc + fontSize <- fromMaybe 30.0 <$> GRPF.fontDescriptionGetSize fontDesc + let fontSize' = doubleToInt $ fontSize * (gifWidth / previewWidth) + let xTranslate = doubleToFloat textOverlayLeft + let yTranslate = doubleToFloat textOverlayTop + let startTime = doubleToFloat textOverlayStartTime + let durationTime = doubleToFloat textOverlayDurationTime + let rotation = int32ToInt textOverlayRotation + let outlineSize = int32ToInt textOverlayOutlineSize + return + Gifcurry.TextOverlay + { Gifcurry.textOverlayText = textOverlayText + , Gifcurry.textOverlayFontFamily = fontFamily + , Gifcurry.textOverlayFontStyle = fontStyle + , Gifcurry.textOverlayFontStretch = fontStretch + , Gifcurry.textOverlayFontWeight = fontWeight + , Gifcurry.textOverlayFontSize = fontSize' + , Gifcurry.textOverlayOrigin = Gifcurry.TextOverlayOriginCenter + , Gifcurry.textOverlayXTranslation = xTranslate + , Gifcurry.textOverlayYTranslation = yTranslate + , Gifcurry.textOverlayRotation = rotation + , Gifcurry.textOverlayStartTime = startTime + , Gifcurry.textOverlayDurationTime = durationTime + , Gifcurry.textOverlayOutlineSize = outlineSize + , Gifcurry.textOverlayOutlineColor = textOverlayOutlineColor + , Gifcurry.textOverlayFillColor = textOverlayFillColor + } + -- `show` adds extra quotes to GRPF.Style* and GRPF.Stretch + removeQuotes :: String -> String + removeQuotes = foldl (\ xs x -> if x /= '\"' then xs ++ [x] else xs) "" + getFontWeight :: GRPF.FontDescription -> IO Int + getFontWeight fontDesc = + catch + getFontWeight' + (\ msg -> do + -- Some font weights, like 860, are not supported by the library. + putStrLn $ "[ERROR] " ++ show (msg :: SomeException) + return $ fromEnum GRPF.WeightNormal + ) + where + getFontWeight' :: IO Int + getFontWeight' = do + !fontWeight <- fromEnum . fromMaybe GRPF.WeightNormal <$> GRPF.fontDescriptionGetWeight fontDesc + return fontWeight + +getTextOverlaysData :: GR.GuiComponents -> IO [GR.GuiTextOverlayData] +getTextOverlaysData + GR.GuiComponents + { GR.textOverlaysRef + } + = do + textOverlays <- readIORef textOverlaysRef + mapM + (\ + GR.GuiTextOverlayComponents + { GR.textOverlayTextEntry + , GR.textOverlayLeftSpinButton + , GR.textOverlayTopSpinButton + , GR.textOverlayStartTimeSpinButton + , GR.textOverlayDurationTimeSpinButton + , GR.textOverlayRotationSpinButton + , GR.textOverlayOutlineSizeSpinButton + , GR.textOverlayOutlineColorButton + , GR.textOverlayFillColorButton + , GR.textOverlayFontButton + } + -> do + text <- Data.Text.unpack <$> GI.Gtk.entryGetText textOverlayTextEntry + left <- GI.Gtk.spinButtonGetValue textOverlayLeftSpinButton + top <- GI.Gtk.spinButtonGetValue textOverlayTopSpinButton + start <- GI.Gtk.spinButtonGetValue textOverlayStartTimeSpinButton + duration <- GI.Gtk.spinButtonGetValue textOverlayDurationTimeSpinButton + rotation <- GI.Gtk.spinButtonGetValueAsInt textOverlayRotationSpinButton + outlineSize <- GI.Gtk.spinButtonGetValueAsInt textOverlayOutlineSizeSpinButton + outlineColor <- getColorButtonString textOverlayOutlineColorButton "rgba(0,0,0,1)" + fillColor <- getColorButtonString textOverlayFillColorButton "rgba(255,255,255,1)" + maybeFontDesc <- GI.Gtk.fontChooserGetFontDesc textOverlayFontButton + maybeFontDesc' <- + case maybeFontDesc of + Nothing -> return Nothing + Just fd -> do + fds <- Data.Text.unpack <$> GI.Pango.fontDescriptionToString fd + fd' <- GRPF.fontDescriptionFromString fds + return $ Just fd' + return + GR.GuiTextOverlayData + { GR.textOverlayText = text + , GR.textOverlayLeft = left + , GR.textOverlayTop = top + , GR.textOverlayStartTime = start + , GR.textOverlayDurationTime = duration + , GR.textOverlayRotation = rotation + , GR.textOverlayEndTime = start + duration + , GR.textOverlayOutlineSize = outlineSize + , GR.textOverlayOutlineColor = outlineColor + , GR.textOverlayFillColor = fillColor + , GR.textOverlayMaybeFontDesc = maybeFontDesc' + } + ) + textOverlays + +updateTextOverlays :: Bool -> GR.GuiComponents -> IO () +updateTextOverlays + reset + guiComponents@GR.GuiComponents + { GR.textOverlaysRef + } + = do + textOverlays <- readIORef textOverlaysRef + (duration, _width, _height) <- getPreviewDurationWidthAndHeight guiComponents + mapM_ updateRotationOutlineSizeButtons textOverlays + mapM_ updatePositionSpinButtons textOverlays + mapM_ (updateTimeSpinButtons duration) textOverlays + when reset $ + mapM_ clearEntry textOverlays + where + clearEntry :: GR.GuiTextOverlayComponents -> IO () + clearEntry + GR.GuiTextOverlayComponents + { GR.textOverlayTextEntry + } + = GI.Gtk.entrySetText textOverlayTextEntry "" + updateRotationOutlineSizeButtons :: GR.GuiTextOverlayComponents -> IO () + updateRotationOutlineSizeButtons + GR.GuiTextOverlayComponents + { GR.textOverlayRotationSpinButton + , GR.textOverlayOutlineSizeSpinButton + } + = do + rotation <- GI.Gtk.spinButtonGetValue textOverlayRotationSpinButton + GI.Gtk.entrySetProgressFraction + textOverlayRotationSpinButton $ + rotation / 360.0 + outlineSize <- GI.Gtk.spinButtonGetValue textOverlayOutlineSizeSpinButton + GI.Gtk.entrySetProgressFraction + textOverlayOutlineSizeSpinButton $ + outlineSize / 10.0 + when reset $ do + GI.Gtk.spinButtonSetValue textOverlayRotationSpinButton 0.0 + GI.Gtk.spinButtonSetValue textOverlayOutlineSizeSpinButton 10.0 + GI.Gtk.entrySetProgressFraction + textOverlayRotationSpinButton + 0.0 + GI.Gtk.entrySetProgressFraction + textOverlayOutlineSizeSpinButton + 10.0 + updatePositionSpinButtons :: GR.GuiTextOverlayComponents -> IO () + updatePositionSpinButtons + GR.GuiTextOverlayComponents + { GR.textOverlayLeftSpinButton + , GR.textOverlayTopSpinButton + } + = do + GI.Gtk.spinButtonSetRange + textOverlayLeftSpinButton + (-0.5) + 0.5 + GI.Gtk.spinButtonSetRange + textOverlayTopSpinButton + (-0.5) + 0.5 + when reset $ do + GI.Gtk.spinButtonSetValue textOverlayLeftSpinButton 0.0 + GI.Gtk.spinButtonSetValue textOverlayTopSpinButton 0.0 + left <- GI.Gtk.spinButtonGetValue textOverlayLeftSpinButton + GI.Gtk.entrySetProgressFraction + textOverlayLeftSpinButton $ + left + 0.5 + top <- GI.Gtk.spinButtonGetValue textOverlayTopSpinButton + GI.Gtk.entrySetProgressFraction + textOverlayTopSpinButton $ + top + 0.5 + updateTimeSpinButtons :: Double -> GR.GuiTextOverlayComponents -> IO () + updateTimeSpinButtons + duration + GR.GuiTextOverlayComponents + { GR.textOverlayStartTimeSpinButton + , GR.textOverlayDurationTimeSpinButton + } + = do + GI.Gtk.spinButtonSetRange + textOverlayStartTimeSpinButton + 0.0 + duration + if reset + then do + GI.Gtk.spinButtonSetRange + textOverlayDurationTimeSpinButton + 0.0 + duration + GI.Gtk.spinButtonSetValue + textOverlayStartTimeSpinButton + 0.0 + GI.Gtk.spinButtonSetValue + textOverlayDurationTimeSpinButton $ + truncatePastDigit duration 2 + GI.Gtk.entrySetProgressFraction + textOverlayStartTimeSpinButton + 0.0 + GI.Gtk.entrySetProgressFraction + textOverlayDurationTimeSpinButton + 1.0 + else do + startTime <- GI.Gtk.spinButtonGetValue textOverlayStartTimeSpinButton + durationTime <- GI.Gtk.spinButtonGetValue textOverlayDurationTimeSpinButton + let maxDurationTime = clamp 0.0 duration (duration - startTime) + GI.Gtk.spinButtonSetRange + textOverlayDurationTimeSpinButton + 0.0 + maxDurationTime + GI.Gtk.entrySetProgressFraction + textOverlayStartTimeSpinButton $ + fromMaybe 0.0 $ safeDivide startTime duration + GI.Gtk.entrySetProgressFraction + textOverlayDurationTimeSpinButton $ + fromMaybe 0.0 $ safeDivide durationTime maxDurationTime + +addTextOverlay :: GR.GuiComponents -> IO () +addTextOverlay + guiComponents@GR.GuiComponents + { GR.textOverlaysBox + , GR.confirmMessageDialog + , GR.textOverlaysRef + } + = do + (duration, width, height) <- getPreviewDurationWidthAndHeight guiComponents + when (duration > 0.0 && width > 0.0 && height > 0.0) $ do + box <- GI.Gtk.boxNew GI.Gtk.OrientationVertical 0 + visibilityBox <- GI.Gtk.boxNew GI.Gtk.OrientationVertical 0 + positionSpinButtonsBox <- GI.Gtk.boxNew GI.Gtk.OrientationHorizontal 0 + timeSpinButtonsBox <- GI.Gtk.boxNew GI.Gtk.OrientationHorizontal 0 + rotationOutlineSizeSpinButtonsBox <- GI.Gtk.boxNew GI.Gtk.OrientationHorizontal 0 + colorButtonsBox <- GI.Gtk.boxNew GI.Gtk.OrientationHorizontal 0 + leftAdjustment <- GI.Gtk.adjustmentNew 0.0 0.0 0.0 0.01 0.0 0.0 + topAdjustment <- GI.Gtk.adjustmentNew 0.0 0.0 0.0 0.01 0.0 0.0 + startTimeAdjustment <- GI.Gtk.adjustmentNew 0.0 0.0 0.0 1.0 0.0 0.0 + durationTimeAdjustment <- GI.Gtk.adjustmentNew 0.0 0.0 0.0 1.0 0.0 0.0 + rotationAdjustment <- GI.Gtk.adjustmentNew 0.0 0.0 360.0 1.0 0.0 0.0 + outlineSizeAdjustment <- GI.Gtk.adjustmentNew 0.0 0.0 10.0 1.0 0.0 0.0 + leftSpinButton <- GI.Gtk.spinButtonNew (Just leftAdjustment) 1.0 2 + topSpinButton <- GI.Gtk.spinButtonNew (Just topAdjustment) 1.0 2 + startTimeSpinButton <- GI.Gtk.spinButtonNew (Just startTimeAdjustment) 1.0 2 + durationTimeSpinButton <- GI.Gtk.spinButtonNew (Just durationTimeAdjustment) 1.0 2 + rotationSpinButton <- GI.Gtk.spinButtonNew (Just rotationAdjustment) 1.0 0 + outlineSizeSpinButton <- GI.Gtk.spinButtonNew (Just outlineSizeAdjustment) 1.0 0 + textEntry <- GI.Gtk.entryNew + visibilityToggleButton <- GI.Gtk.toggleButtonNew + fontButton <- GI.Gtk.fontButtonNew + blackRgba <- GI.Gdk.newZeroRGBA + whiteRgba <- GI.Gdk.newZeroRGBA + _ <- GI.Gdk.rGBAParse blackRgba "rgba(0,0,0,1)" + _ <- GI.Gdk.rGBAParse whiteRgba "rgba(255,255,255,1)" + outlineColorButton <- GI.Gtk.colorButtonNewWithRgba blackRgba + fillColorButton <- GI.Gtk.colorButtonNewWithRgba whiteRgba + removeButton <- GI.Gtk.buttonNewFromIconName (Just "gtk-remove") (enumToInt32 GI.Gtk.IconSizeButton) + editImage <- GI.Gtk.imageNewFromIconName (Just "gtk-edit") (enumToInt32 GI.Gtk.IconSizeButton) + fontDescription <- GI.Pango.fontDescriptionFromString "Sans Regular 30" + GI.Gtk.setToggleButtonDrawIndicator visibilityToggleButton False + GI.Gtk.setToggleButtonActive visibilityToggleButton True + GI.Gtk.buttonSetImage visibilityToggleButton (Just editImage) + GI.Gtk.setWidgetDoubleBuffered visibilityToggleButton True + GI.Gtk.setWidgetDoubleBuffered editImage True + GI.Gtk.setButtonAlwaysShowImage visibilityToggleButton True + GI.Gtk.fontChooserSetFontDesc fontButton fontDescription + GI.Gtk.buttonSetLabel removeButton "Remove" + GI.Gtk.setButtonAlwaysShowImage removeButton True + GI.Gtk.boxSetHomogeneous positionSpinButtonsBox True + GI.Gtk.boxSetHomogeneous timeSpinButtonsBox True + GI.Gtk.boxSetHomogeneous rotationOutlineSizeSpinButtonsBox True + GI.Gtk.boxSetHomogeneous colorButtonsBox True + GI.Gtk.setEntryPrimaryIconName leftSpinButton "gtk-go-forward" + GI.Gtk.setEntryPrimaryIconName topSpinButton "gtk-go-down" + GI.Gtk.setEntryPrimaryIconName startTimeSpinButton "gtk-indent" + GI.Gtk.setEntryPrimaryIconName durationTimeSpinButton "gtk-refresh" + GI.Gtk.setEntryPrimaryIconName rotationSpinButton "gtk-undo" + GI.Gtk.setEntryPrimaryIconName outlineSizeSpinButton "gtk-justify-fill" + GI.Gtk.widgetSetTooltipText leftSpinButton $ Just "How much space from the left?" + GI.Gtk.widgetSetTooltipText topSpinButton $ Just "How much space from the top?" + GI.Gtk.widgetSetTooltipText startTimeSpinButton $ Just "What is the start time?" + GI.Gtk.widgetSetTooltipText durationTimeSpinButton $ Just "How long is the duration?" + GI.Gtk.widgetSetTooltipText rotationSpinButton $ Just "Rotate by how much?" + GI.Gtk.widgetSetTooltipText outlineSizeSpinButton $ Just "How thick is the outline size?" + GI.Gtk.widgetSetTooltipText outlineColorButton $ Just "What is the outline color?" + GI.Gtk.widgetSetTooltipText fillColorButton $ Just "What is the fill color?" + GI.Gtk.widgetSetTooltipText removeButton $ Just "Remove this text?" + GI.Gtk.entrySetPlaceholderText textEntry $ Just "What is the text?" + GI.Gtk.spinButtonSetNumeric leftSpinButton True + GI.Gtk.spinButtonSetNumeric topSpinButton True + GI.Gtk.spinButtonSetNumeric startTimeSpinButton True + GI.Gtk.spinButtonSetNumeric durationTimeSpinButton True + GI.Gtk.spinButtonSetNumeric rotationSpinButton True + GI.Gtk.spinButtonSetNumeric outlineSizeSpinButton True + GI.Gtk.spinButtonSetUpdatePolicy leftSpinButton GI.Gtk.SpinButtonUpdatePolicyIfValid + GI.Gtk.spinButtonSetUpdatePolicy topSpinButton GI.Gtk.SpinButtonUpdatePolicyIfValid + GI.Gtk.spinButtonSetUpdatePolicy startTimeSpinButton GI.Gtk.SpinButtonUpdatePolicyIfValid + GI.Gtk.spinButtonSetUpdatePolicy durationTimeSpinButton GI.Gtk.SpinButtonUpdatePolicyIfValid + GI.Gtk.spinButtonSetUpdatePolicy rotationSpinButton GI.Gtk.SpinButtonUpdatePolicyIfValid + GI.Gtk.spinButtonSetUpdatePolicy outlineSizeSpinButton GI.Gtk.SpinButtonUpdatePolicyIfValid + GI.Gtk.spinButtonSetRange leftSpinButton (-0.5) 0.5 + GI.Gtk.spinButtonSetRange topSpinButton (-0.5) 0.5 + GI.Gtk.spinButtonSetRange startTimeSpinButton 0.0 duration + GI.Gtk.spinButtonSetRange durationTimeSpinButton 0.0 duration + GI.Gtk.spinButtonSetRange rotationSpinButton 0.0 360.0 + GI.Gtk.spinButtonSetRange outlineSizeSpinButton 0.0 10.0 + GI.Gtk.spinButtonSetValue leftSpinButton 0.0 + GI.Gtk.spinButtonSetValue topSpinButton 0.0 + GI.Gtk.spinButtonSetValue startTimeSpinButton 0.0 + GI.Gtk.spinButtonSetValue durationTimeSpinButton duration + GI.Gtk.spinButtonSetValue rotationSpinButton 0.0 + GI.Gtk.spinButtonSetValue outlineSizeSpinButton 10.0 + GI.Gtk.entrySetProgressFraction leftSpinButton 0.5 + GI.Gtk.entrySetProgressFraction topSpinButton 0.5 + GI.Gtk.entrySetProgressFraction startTimeSpinButton 0.0 + GI.Gtk.entrySetProgressFraction durationTimeSpinButton 1.0 + GI.Gtk.entrySetProgressFraction rotationSpinButton 0.0 + GI.Gtk.entrySetProgressFraction outlineSizeSpinButton 1.0 + GI.Gtk.widgetSetMarginTop visibilityToggleButton 2 + GI.Gtk.widgetSetMarginBottom removeButton 2 + GI.Gtk.widgetShow box + GI.Gtk.widgetShow visibilityBox + GI.Gtk.widgetShow visibilityToggleButton + GI.Gtk.widgetShow positionSpinButtonsBox + GI.Gtk.widgetShow timeSpinButtonsBox + GI.Gtk.widgetShow rotationOutlineSizeSpinButtonsBox + GI.Gtk.widgetShow colorButtonsBox + GI.Gtk.widgetShow leftSpinButton + GI.Gtk.widgetShow topSpinButton + GI.Gtk.widgetShow startTimeSpinButton + GI.Gtk.widgetShow durationTimeSpinButton + GI.Gtk.widgetShow rotationSpinButton + GI.Gtk.widgetShow outlineSizeSpinButton + GI.Gtk.widgetShow outlineColorButton + GI.Gtk.widgetShow fillColorButton + GI.Gtk.widgetShow textEntry + GI.Gtk.widgetShow fontButton + GI.Gtk.widgetShow removeButton + GI.Gtk.containerAdd positionSpinButtonsBox leftSpinButton + GI.Gtk.containerAdd positionSpinButtonsBox topSpinButton + GI.Gtk.containerAdd timeSpinButtonsBox startTimeSpinButton + GI.Gtk.containerAdd timeSpinButtonsBox durationTimeSpinButton + GI.Gtk.containerAdd rotationOutlineSizeSpinButtonsBox rotationSpinButton + GI.Gtk.containerAdd rotationOutlineSizeSpinButtonsBox outlineSizeSpinButton + GI.Gtk.containerAdd colorButtonsBox outlineColorButton + GI.Gtk.containerAdd colorButtonsBox fillColorButton + GI.Gtk.containerAdd visibilityBox positionSpinButtonsBox + GI.Gtk.containerAdd visibilityBox timeSpinButtonsBox + GI.Gtk.containerAdd visibilityBox rotationOutlineSizeSpinButtonsBox + GI.Gtk.containerAdd visibilityBox colorButtonsBox + GI.Gtk.containerAdd visibilityBox textEntry + GI.Gtk.containerAdd visibilityBox fontButton + GI.Gtk.containerAdd visibilityBox removeButton + GI.Gtk.containerAdd box visibilityToggleButton + GI.Gtk.containerAdd box visibilityBox + GI.Gtk.containerAdd textOverlaysBox box + textOverlays <- readIORef textOverlaysRef + let ids = sort $ map GR.textOverlayId textOverlays + let (_, minId) = + foldl + (\ (i, m) i' -> if i == i' then (i + 1, i + 1) else (i + 1, m)) + (0, 0) + ids + let minIdText = Data.Text.pack $ show minId + GI.Gtk.buttonSetLabel visibilityToggleButton minIdText + GI.Gtk.widgetSetTooltipText visibilityToggleButton $ + Just $ + Data.Text.concat ["Close text ", minIdText, "?"] + let textOverlay = + GR.GuiTextOverlayComponents + { GR.textOverlayId = minId + , GR.textOverlayBox = box + , GR.textOverlayVisibilityBox = visibilityBox + , GR.textOverlayVisibilityToggleButton = visibilityToggleButton + , GR.textOverlayLeftSpinButton = leftSpinButton + , GR.textOverlayTopSpinButton = topSpinButton + , GR.textOverlayStartTimeSpinButton = startTimeSpinButton + , GR.textOverlayDurationTimeSpinButton = durationTimeSpinButton + , GR.textOverlayRotationSpinButton = rotationSpinButton + , GR.textOverlayOutlineSizeSpinButton = outlineSizeSpinButton + , GR.textOverlayOutlineColorButton = outlineColorButton + , GR.textOverlayFillColorButton = fillColorButton + , GR.textOverlayTextEntry = textEntry + , GR.textOverlayFontButton = fontButton + , GR.textOverlayRemoveButton = removeButton + } + atomicModifyIORef' textOverlaysRef $ + \ textOverlays' -> + ( textOverlays' ++ [textOverlay] + , () + ) + _ <- GI.Gtk.onButtonClicked removeButton $ do + GI.Gtk.setMessageDialogText + confirmMessageDialog $ + Data.Text.concat ["Remove text ", minIdText, "?"] + confirmMessageDialogResponse <- GI.Gtk.dialogRun confirmMessageDialog + when (confirmMessageDialogResponse == enumToInt32 GI.Gtk.ResponseTypeYes) $ do + textOverlays' <- filterTextOverlay minId <$> readIORef textOverlaysRef + atomicModifyIORef' textOverlaysRef $ + const (textOverlays', ()) + GI.Gtk.containerRemove textOverlaysBox box + _ <- GI.Gtk.onWidgetButtonReleaseEvent visibilityToggleButton $ \ _ -> do + active <- GI.Gtk.getToggleButtonActive visibilityToggleButton + if active + then hideAllOtherTextOverlays guiComponents (-1) + else hideAllOtherTextOverlays guiComponents minId + return True + _ <- GI.Gtk.afterWidgetKeyReleaseEvent textEntry $ \ _ -> do + text <- GI.Gtk.entryGetText textEntry + let limit = 27 + let label = Data.Text.concat [minIdText, " ", text] + let label' = + if Data.Text.length label >= limit + then Data.Text.concat [Data.Text.take limit label, "..."] + else label + GI.Gtk.buttonSetLabel + visibilityToggleButton + label' + return False + updateTextOverlays False guiComponents + hideAllOtherTextOverlays guiComponents minId + return () + where + filterTextOverlay :: Int -> [GR.GuiTextOverlayComponents] -> [GR.GuiTextOverlayComponents] + filterTextOverlay textOverlayId = + foldl + (\ x t -> if textOverlayId /= GR.textOverlayId t then x ++ [t] else x) + [] + +removeTextOverlays :: GR.GuiComponents -> IO () +removeTextOverlays + GR.GuiComponents + { GR.textOverlaysBox + , GR.textOverlaysRef + } + = do + textOverlays <- readIORef textOverlaysRef + mapM_ + (\ GR.GuiTextOverlayComponents { GR.textOverlayBox } -> + GI.Gtk.containerRemove textOverlaysBox textOverlayBox + ) + textOverlays + atomicModifyIORef' textOverlaysRef $ const ([], ()) + +hideAllOtherTextOverlays :: GR.GuiComponents -> Int -> IO () +hideAllOtherTextOverlays + GR.GuiComponents + { GR.textOverlaysRef + } + showTextOverlayId + = do + textOverlays <- readIORef textOverlaysRef + mapM_ + (\ GR.GuiTextOverlayComponents + { GR.textOverlayId + , GR.textOverlayVisibilityBox + , GR.textOverlayVisibilityToggleButton + } + -> do + let textOverlayId' = Data.Text.pack $ show textOverlayId + if textOverlayId == showTextOverlayId + then do + GI.Gtk.widgetShow textOverlayVisibilityBox + GI.Gtk.setToggleButtonActive textOverlayVisibilityToggleButton True + GI.Gtk.widgetSetTooltipText textOverlayVisibilityToggleButton $ + Just $ + Data.Text.concat ["Close text ", textOverlayId', "?"] + else do + GI.Gtk.widgetHide textOverlayVisibilityBox + GI.Gtk.setToggleButtonActive textOverlayVisibilityToggleButton False + GI.Gtk.widgetSetTooltipText textOverlayVisibilityToggleButton $ + Just $ + Data.Text.concat ["Open text ", textOverlayId', "?"] + ) + textOverlays + return () + +getPreviewDurationWidthAndHeight :: GR.GuiComponents -> IO (Double, Double, Double) +getPreviewDurationWidthAndHeight + GR.GuiComponents + { GR.maybeVideoPreviewWidget + , GR.videoPreviewDrawingArea + , GR.firstFramePreviewImageDrawingArea + , GR.inVideoPropertiesRef + } + = do + GR.InVideoProperties + { GR.inVideoDuration + , GR.inVideoWidth + , GR.inVideoHeight + } <- readIORef inVideoPropertiesRef + let usingVideoPreview = isJust maybeVideoPreviewWidget + let videoHasSize = if inVideoWidth > 0.0 && inVideoHeight > 0.0 then 1.0 else 0.0 + let drawingArea = if usingVideoPreview + then videoPreviewDrawingArea + else firstFramePreviewImageDrawingArea + width <- (*) videoHasSize . int32ToDouble <$> GI.Gtk.widgetGetAllocatedWidth drawingArea + height <- (*) videoHasSize . int32ToDouble <$> GI.Gtk.widgetGetAllocatedHeight drawingArea + let videoDuration = floatToDouble inVideoDuration + return (videoDuration, width, height) + +getColorButtonString :: GI.Gtk.ColorButton -> String -> IO String +getColorButtonString colorButton defaultString = do + defaultRgba <- GI.Gdk.newZeroRGBA + _ <- GI.Gdk.rGBAParse defaultRgba (Data.Text.pack defaultString) + maybeRgba <- GI.Gtk.getColorButtonRgba colorButton + text <- + case maybeRgba of + Just rgba -> GI.Gdk.rGBAToString rgba + Nothing -> GI.Gdk.rGBAToString defaultRgba + return $ Data.Text.unpack text + diff --git a/src/gui/Main.hs b/src/gui/Main.hs index fd4130b..2a25dac 100644 --- a/src/gui/Main.hs +++ b/src/gui/Main.hs @@ -34,17 +34,20 @@ import Paths_Gifcurry import qualified Gifcurry ( gif , GifParams(..) + , Quality(QualityMedium) , defaultGifParams , gifParamsValid , getVideoDurationInSeconds , getOutputFileWithExtension , getVideoWidthAndHeight , findOrCreateTemporaryDirectory + , qualityFromString ) import qualified GtkMainSyncAsync (gtkMainAsync) import qualified GuiRecords as GR import qualified GuiCapabilities import qualified GuiStyle +import qualified GuiTextOverlays import qualified GuiPreview import GuiMisc @@ -62,7 +65,6 @@ main = do startTimeSpinButton <- builderGetObject GI.Gtk.SpinButton builder "start-time-spin-button" durationTimeSpinButton <- builderGetObject GI.Gtk.SpinButton builder "duration-time-spin-button" widthSizeSpinButton <- builderGetObject GI.Gtk.SpinButton builder "width-size-spin-button" - qualityPercentSpinButton <- builderGetObject GI.Gtk.SpinButton builder "quality-percent-spin-button" leftCropSpinButton <- builderGetObject GI.Gtk.SpinButton builder "left-crop-spin-button" rightCropSpinButton <- builderGetObject GI.Gtk.SpinButton builder "right-crop-spin-button" topCropSpinButton <- builderGetObject GI.Gtk.SpinButton builder "top-crop-spin-button" @@ -71,56 +73,56 @@ main = do inFileChooserDialogCancelButton <- builderGetObject GI.Gtk.Button builder "in-file-chooser-dialog-cancel-button" inFileChooserDialogOpenButton <- builderGetObject GI.Gtk.Button builder "in-file-chooser-dialog-open-button" outFileChooserButton <- builderGetObject GI.Gtk.FileChooserButton builder "out-file-chooser-button" - fontChooserButton <- builderGetObject GI.Gtk.FontButton builder "font-chooser-button" + textOverlaysAddButton <- builderGetObject GI.Gtk.Button builder "text-overlays-add-button" saveButton <- builderGetObject GI.Gtk.Button builder "save-button" openButton <- builderGetObject GI.Gtk.Button builder "open-button" - yesGtkButton <- builderGetObject GI.Gtk.Button builder "yes-button" - noGtkButton <- builderGetObject GI.Gtk.Button builder "no-button" + confirmMessageDialogYesButton <- builderGetObject GI.Gtk.Button builder "confirm-message-dialog-yes-button" + confirmMessageDialogNoButton <- builderGetObject GI.Gtk.Button builder "confirm-message-dialog-no-button" aboutButton <- builderGetObject GI.Gtk.Button builder "about-button" giphyUploadButton <- builderGetObject GI.Gtk.Button builder "giphy-upload-button" imgurUploadButton <- builderGetObject GI.Gtk.Button builder "imgur-upload-button" saveAsVideoRadioButton <- builderGetObject GI.Gtk.RadioButton builder "save-as-video-radio-button" - widthQualityPercentToggleButton <- builderGetObject GI.Gtk.ToggleButton builder "width-quality-percent-toggle-button" + widthQualityToggleButton <- builderGetObject GI.Gtk.ToggleButton builder "width-quality-toggle-button" cropToggleButton <- builderGetObject GI.Gtk.ToggleButton builder "crop-toggle-button" - topBottomTextToggleButton <- builderGetObject GI.Gtk.ToggleButton builder "top-bottom-text-toggle-button" + textOverlaysToggleButton <- builderGetObject GI.Gtk.ToggleButton builder "text-overlays-toggle-button" saveOpenToggleButton <- builderGetObject GI.Gtk.ToggleButton builder "save-open-toggle-button" uploadToggleButton <- builderGetObject GI.Gtk.ToggleButton builder "upload-toggle-button" + videoPreviewPauseToggleButton <- builderGetObject GI.Gtk.ToggleButton builder "video-preview-pause-toggle-button" inFileChooserDialogLabel <- builderGetObject GI.Gtk.Label builder "in-file-chooser-dialog-label" inFileChooserButtonLabel <- builderGetObject GI.Gtk.Label builder "in-file-chooser-button-label" startTimeAdjustment <- builderGetObject GI.Gtk.Adjustment builder "start-time-adjustment" durationTimeAdjustment <- builderGetObject GI.Gtk.Adjustment builder "duration-time-adjustment" widthSizeAdjustment <- builderGetObject GI.Gtk.Adjustment builder "width-size-adjustment" - qualityPercentAdjustment <- builderGetObject GI.Gtk.Adjustment builder "quality-percent-adjustment" outFileNameEntry <- builderGetObject GI.Gtk.Entry builder "out-file-name-entry" - topTextEntry <- builderGetObject GI.Gtk.Entry builder "top-text-entry" - bottomTextEntry <- builderGetObject GI.Gtk.Entry builder "bottom-text-entry" statusEntry <- builderGetObject GI.Gtk.Entry builder "status-entry" + sidebarControlsPreviewbox <- builderGetObject GI.Gtk.Box builder "sidebar-controls-preview-box" mainPreviewBox <- builderGetObject GI.Gtk.Box builder "main-preview-box" imagesPreviewBox <- builderGetObject GI.Gtk.Box builder "images-preview-box" videoPreviewBox <- builderGetObject GI.Gtk.Box builder "video-preview-box" videoPreviewOverlayChildBox <- builderGetObject GI.Gtk.Box builder "video-preview-overlay-child-box" - widthQualityPercentBox <- builderGetObject GI.Gtk.Box builder "width-quality-percent-box" + widthQualityBox <- builderGetObject GI.Gtk.Box builder "width-quality-box" cropSpinButtonsBox <- builderGetObject GI.Gtk.Box builder "crop-spin-buttons-box" - topBottomTextFontChooserBox <- builderGetObject GI.Gtk.Box builder "top-bottom-text-font-chooser-box" + textOverlaysMainBox <- builderGetObject GI.Gtk.Box builder "text-overlays-main-box" + textOverlaysBox <- builderGetObject GI.Gtk.Box builder "text-overlays-box" saveOpenBox <- builderGetObject GI.Gtk.Box builder "save-open-box" uploadBox <- builderGetObject GI.Gtk.Box builder "upload-box" + qualityComboBoxText <- builderGetObject GI.Gtk.ComboBoxText builder "quality-combo-box-text" videoPreviewDrawingArea <- builderGetObject GI.Gtk.DrawingArea builder "video-preview-drawing-area" + timeSlicesDrawingArea <- builderGetObject GI.Gtk.DrawingArea builder "time-slices-drawing-area" firstFramePreviewImageDrawingArea <- builderGetObject GI.Gtk.DrawingArea builder "first-frame-preview-image-drawing-area" lastFramePreviewImageDrawingArea <- builderGetObject GI.Gtk.DrawingArea builder "last-frame-preview-image-drawing-area" inFileChooserButtonImage <- builderGetObject GI.Gtk.Image builder "in-file-chooser-button-image" firstFrameImage <- builderGetObject GI.Gtk.Image builder "first-frame-image" lastFrameImage <- builderGetObject GI.Gtk.Image builder "last-frame-image" inFileChooserDialog <- builderGetObject GI.Gtk.Dialog builder "in-file-chooser-dialog" - longGifGtkMessageDialog <- builderGetObject GI.Gtk.MessageDialog builder "long-gif-message-dialog" + confirmMessageDialog <- builderGetObject GI.Gtk.MessageDialog builder "confirm-message-dialog" aboutDialog <- builderGetObject GI.Gtk.AboutDialog builder "about-dialog" - startTimeProgressBar <- builderGetObject GI.Gtk.ProgressBar builder "start-time-progress-bar" - endTimeProgressBar <- builderGetObject GI.Gtk.ProgressBar builder "end-time-progress-bar" saveSpinner <- builderGetObject GI.Gtk.Spinner builder "save-spinner" inFileChooserWidget <- builderGetObject GI.Gtk.FileChooserWidget builder "in-file-chooser-widget" -- Glade does not allow us to use the response ID nicknames so we set them here. - GI.Gtk.dialogAddActionWidget longGifGtkMessageDialog yesGtkButton $ enumToInt32 GI.Gtk.ResponseTypeYes - GI.Gtk.dialogAddActionWidget longGifGtkMessageDialog noGtkButton $ enumToInt32 GI.Gtk.ResponseTypeNo + GI.Gtk.dialogAddActionWidget confirmMessageDialog confirmMessageDialogYesButton $ enumToInt32 GI.Gtk.ResponseTypeYes + GI.Gtk.dialogAddActionWidget confirmMessageDialog confirmMessageDialogNoButton $ enumToInt32 GI.Gtk.ResponseTypeNo GI.Gtk.dialogAddActionWidget inFileChooserDialog inFileChooserDialogCancelButton $ enumToInt32 GI.Gtk.ResponseTypeCancel GI.Gtk.dialogAddActionWidget inFileChooserDialog inFileChooserDialogOpenButton $ enumToInt32 GI.Gtk.ResponseTypeOk @@ -129,9 +131,9 @@ main = do temporaryDirectory <- Gifcurry.findOrCreateTemporaryDirectory - guiPreviewStateRef <- newIORef GR.defaultGuiPreviewState - inVideoPropertiesRef <- newIORef GR.defaultInVideoProperties + textOverlaysRef <- newIORef [] + guiPreviewStateRef <- newIORef GR.defaultGuiPreviewState let guiComponents = GR.GuiComponents @@ -139,7 +141,6 @@ main = do , GR.startTimeSpinButton = startTimeSpinButton , GR.durationTimeSpinButton = durationTimeSpinButton , GR.widthSizeSpinButton = widthSizeSpinButton - , GR.qualityPercentSpinButton = qualityPercentSpinButton , GR.leftCropSpinButton = leftCropSpinButton , GR.rightCropSpinButton = rightCropSpinButton , GR.topCropSpinButton = topCropSpinButton @@ -148,57 +149,58 @@ main = do , GR.inFileChooserDialogCancelButton = inFileChooserDialogCancelButton , GR.inFileChooserDialogOpenButton = inFileChooserDialogOpenButton , GR.outFileChooserButton = outFileChooserButton - , GR.fontChooserButton = fontChooserButton + , GR.textOverlaysAddButton = textOverlaysAddButton , GR.saveButton = saveButton , GR.openButton = openButton - , GR.yesGtkButton = yesGtkButton - , GR.noGtkButton = noGtkButton + , GR.confirmMessageDialogYesButton = confirmMessageDialogYesButton + , GR.confirmMessageDialogNoButton = confirmMessageDialogNoButton , GR.aboutButton = aboutButton , GR.giphyUploadButton = giphyUploadButton , GR.imgurUploadButton = imgurUploadButton , GR.saveAsVideoRadioButton = saveAsVideoRadioButton - , GR.widthQualityPercentToggleButton = widthQualityPercentToggleButton + , GR.widthQualityToggleButton = widthQualityToggleButton , GR.cropToggleButton = cropToggleButton - , GR.topBottomTextToggleButton = topBottomTextToggleButton + , GR.textOverlaysToggleButton = textOverlaysToggleButton , GR.saveOpenToggleButton = saveOpenToggleButton , GR.uploadToggleButton = uploadToggleButton + , GR.videoPreviewPauseToggleButton = videoPreviewPauseToggleButton , GR.inFileChooserDialogLabel = inFileChooserDialogLabel , GR.inFileChooserButtonLabel = inFileChooserButtonLabel , GR.startTimeAdjustment = startTimeAdjustment , GR.durationTimeAdjustment = durationTimeAdjustment , GR.widthSizeAdjustment = widthSizeAdjustment - , GR.qualityPercentAdjustment = qualityPercentAdjustment , GR.outFileNameEntry = outFileNameEntry - , GR.topTextEntry = topTextEntry - , GR.bottomTextEntry = bottomTextEntry , GR.statusEntry = statusEntry + , GR.sidebarControlsPreviewbox = sidebarControlsPreviewbox , GR.mainPreviewBox = mainPreviewBox , GR.imagesPreviewBox = imagesPreviewBox , GR.videoPreviewBox = videoPreviewBox , GR.videoPreviewOverlayChildBox = videoPreviewOverlayChildBox - , GR.widthQualityPercentBox = widthQualityPercentBox + , GR.widthQualityBox = widthQualityBox , GR.cropSpinButtonsBox = cropSpinButtonsBox - , GR.topBottomTextFontChooserBox = topBottomTextFontChooserBox + , GR.textOverlaysMainBox = textOverlaysMainBox + , GR.textOverlaysBox = textOverlaysBox , GR.saveOpenBox = saveOpenBox , GR.uploadBox = uploadBox + , GR.qualityComboBoxText = qualityComboBoxText , GR.videoPreviewDrawingArea = videoPreviewDrawingArea + , GR.timeSlicesDrawingArea = timeSlicesDrawingArea , GR.firstFramePreviewImageDrawingArea = firstFramePreviewImageDrawingArea , GR.lastFramePreviewImageDrawingArea = lastFramePreviewImageDrawingArea , GR.inFileChooserButtonImage = inFileChooserButtonImage , GR.firstFrameImage = firstFrameImage , GR.lastFrameImage = lastFrameImage , GR.inFileChooserDialog = inFileChooserDialog - , GR.longGifGtkMessageDialog = longGifGtkMessageDialog + , GR.confirmMessageDialog = confirmMessageDialog , GR.aboutDialog = aboutDialog - , GR.startTimeProgressBar = startTimeProgressBar - , GR.endTimeProgressBar = endTimeProgressBar , GR.saveSpinner = saveSpinner , GR.inFileChooserWidget = inFileChooserWidget , GR.maybeVideoPreviewWidget = maybeVideoPreviewWidget , GR.maybePlaybinElement = maybePlaybinElement , GR.temporaryDirectory = temporaryDirectory - , GR.guiPreviewStateRef = guiPreviewStateRef , GR.inVideoPropertiesRef = inVideoPropertiesRef + , GR.textOverlaysRef = textOverlaysRef + , GR.guiPreviewStateRef = guiPreviewStateRef } _ <- hideWidgetsOnRealize guiComponents @@ -212,6 +214,8 @@ main = do _ <- handleWindow guiComponents _ <- handleGuiPreview guiComponents + GuiTextOverlays.handleTextOverlaysAddButton guiComponents + GuiStyle.applyCss guiComponents GuiCapabilities.checkCapabilitiesAndNotify guiComponents @@ -229,23 +233,24 @@ builderGetObject -> a -> String -> IO b -builderGetObject objectTypeClass builder objectId = - fromJust <$> GI.Gtk.builderGetObject builder (pack objectId) >>= - GI.Gtk.unsafeCastTo objectTypeClass +builderGetObject objectTypeClass builder objectId = do + maybeObject <- GI.Gtk.builderGetObject builder $ pack objectId + when (isNothing maybeObject) $ + putStrLn $ "[ERROR] could not build " ++ objectId ++ "." + GI.Gtk.unsafeCastTo objectTypeClass $ fromJust maybeObject handleFileChooserDialogReponse :: GR.GuiComponents -> Int32 -> IO () handleFileChooserDialogReponse guiComponents@GR.GuiComponents - { GR.startTimeSpinButton + { GR.sidebarControlsPreviewbox + , GR.startTimeSpinButton , GR.durationTimeSpinButton , GR.leftCropSpinButton , GR.rightCropSpinButton , GR.topCropSpinButton , GR.bottomCropSpinButton , GR.widthSizeSpinButton - , GR.qualityPercentSpinButton - , GR.topTextEntry - , GR.bottomTextEntry + , GR.qualityComboBoxText , GR.outFileNameEntry , GR.inFileChooserDialog , GR.statusEntry @@ -275,15 +280,15 @@ handleFileChooserDialogReponse , GR.inVideoWidth = width , GR.inVideoHeight = height } - let videoDuration = float2Double videoDuration' + let videoDuration = floatToDouble videoDuration' let startTimeFraction = 0.25 - let startTime = videoDuration * startTimeFraction - let endTime = startTime * 3 - let durationTime = endTime - startTime + let startTime = videoDuration * startTimeFraction + let endTime = startTime * 3 + let durationTime = endTime - startTime let videoDurationText = Data.Text.pack $ printf "%.3f" videoDuration _ <- updateStartAndDurationTimeSpinButtonRanges guiComponents - _ <- GI.Gtk.spinButtonSetValue startTimeSpinButton startTime - _ <- GI.Gtk.spinButtonSetValue durationTimeSpinButton durationTime + _ <- GI.Gtk.spinButtonSetValue startTimeSpinButton $ truncatePastDigit startTime 2 + _ <- GI.Gtk.spinButtonSetValue durationTimeSpinButton $ truncatePastDigit durationTime 2 _ <- updateStatusEntryAsync statusEntry 1 $ Data.Text.concat [ "That video is about " @@ -293,9 +298,11 @@ handleFileChooserDialogReponse GI.Gtk.labelSetText inFileChooserButtonLabel $ Data.Text.pack $ takeFileName inFilePath + _ <- GI.Gtk.widgetShow sidebarControlsPreviewbox return () _ -> do atomicWriteIORef inVideoPropertiesRef GR.defaultInVideoProperties + _ <- GI.Gtk.widgetHide sidebarControlsPreviewbox _ <- updateStartAndDurationTimeSpinButtonRanges guiComponents _ <- GI.Gtk.spinButtonSetValue startTimeSpinButton 0.0 _ <- GI.Gtk.spinButtonSetValue durationTimeSpinButton 0.0 @@ -304,23 +311,22 @@ handleFileChooserDialogReponse return () syncStartAndDurationTimeSpinButtons guiComponents resetTextEntries - resetWidthAndQualityPercentSpinButtons + resetWidthAndQuality resetCropSpinButtons + GuiTextOverlays.removeTextOverlays guiComponents where resetTextEntries :: IO () resetTextEntries = do let textEntries = - [ topTextEntry - , bottomTextEntry - , outFileNameEntry + [ outFileNameEntry ] mapM_ - (flip GI.Gtk.entrySetText "") + (`GI.Gtk.entrySetText` "") textEntries - resetWidthAndQualityPercentSpinButtons :: IO () - resetWidthAndQualityPercentSpinButtons = do - GI.Gtk.spinButtonSetValue widthSizeSpinButton 500 - GI.Gtk.spinButtonSetValue qualityPercentSpinButton 100 + resetWidthAndQuality :: IO () + resetWidthAndQuality = do + GI.Gtk.spinButtonSetValue widthSizeSpinButton 500 + GI.Gtk.setComboBoxActiveId qualityComboBoxText "Medium" resetCropSpinButtons :: IO () resetCropSpinButtons = do let spinButtons = @@ -330,7 +336,7 @@ handleFileChooserDialogReponse , bottomCropSpinButton ] mapM_ - (flip GI.Gtk.spinButtonSetValue 0.0) + (`GI.Gtk.spinButtonSetValue` 0.0) spinButtons handleSpinButtons :: GR.GuiComponents -> IO () @@ -339,7 +345,6 @@ handleSpinButtons { GR.startTimeSpinButton , GR.durationTimeSpinButton , GR.widthSizeSpinButton - , GR.qualityPercentSpinButton , GR.leftCropSpinButton , GR.rightCropSpinButton , GR.topCropSpinButton @@ -357,9 +362,6 @@ handleSpinButtons _ <- GI.Gtk.onSpinButtonValueChanged widthSizeSpinButton handleWidthSizeSpinButton - _ <- GI.Gtk.onSpinButtonValueChanged - qualityPercentSpinButton - handleQualityPercentSpinButton _ <- GI.Gtk.onSpinButtonValueChanged leftCropSpinButton (handleCropSpinButton leftCropSpinButton rightCropSpinButton "left") @@ -395,7 +397,8 @@ handleSpinButtons _ <- setSpinButtonFraction durationTimeSpinButton if durationTime < 0.0 - || durationTime > (videoDuration - startTime) + -- 2.1 > 10.2 - 8.1 + || (10.0 * durationTime) > ((10.0 * videoDuration) - (10.0 * startTime)) || durationTime > videoDuration then do GI.Gtk.entrySetText statusEntry "The duration time is wrong." @@ -415,22 +418,11 @@ handleSpinButtons else do GI.Gtk.entrySetText statusEntry "Ready." unhighlightSpinButton widthSizeSpinButton - handleQualityPercentSpinButton :: IO () - handleQualityPercentSpinButton = do - qualityPercent <- double2Float <$> GI.Gtk.spinButtonGetValue qualityPercentSpinButton - _ <- setSpinButtonFraction qualityPercentSpinButton - if qualityPercent <= 0.0 || qualityPercent > 100.0 - then do - GI.Gtk.entrySetText statusEntry "The quality percent is wrong." - highlightSpinButton qualityPercentSpinButton - else do - GI.Gtk.entrySetText statusEntry "Ready." - unhighlightSpinButton qualityPercentSpinButton handleCropSpinButton :: GI.Gtk.SpinButton -> GI.Gtk.SpinButton -> Text -> IO () handleCropSpinButton a b t = do cropValue <- double2Float <$> GI.Gtk.spinButtonGetValue a _ <- setSpinButtonFraction a - if cropValue < 0.0 || cropValue > 100.0 + if cropValue < 0.0 || cropValue >= 1.0 then do GI.Gtk.entrySetText statusEntry $ Data.Text.concat ["The ", t, " crop is wrong."] highlightSpinButton a @@ -442,8 +434,8 @@ handleSpinButtons syncCropSpinButtons a b = do aValue <- GI.Gtk.spinButtonGetValue a bValue <- GI.Gtk.spinButtonGetValue b - when (aValue + bValue >= 100) $ do - let newValue = 100.0 - aValue - 1.0 + when (aValue + bValue >= 1) $ do + let newValue = 1.0 - aValue - 0.01 let newValue' = if newValue < 0.0 then 0.0 else newValue void $ GI.Gtk.spinButtonSetValue b newValue' return () @@ -453,44 +445,41 @@ handleSpinButtons handleSaveButtonClick :: GR.GuiComponents -> IO () handleSaveButtonClick - GR.GuiComponents + guiComponents@GR.GuiComponents { GR.outFileChooserButton , GR.outFileNameEntry , GR.saveButton , GR.openButton - , GR.fontChooserButton , GR.saveAsVideoRadioButton , GR.startTimeSpinButton , GR.durationTimeSpinButton , GR.widthSizeSpinButton - , GR.qualityPercentSpinButton + , GR.qualityComboBoxText , GR.leftCropSpinButton , GR.rightCropSpinButton , GR.topCropSpinButton , GR.bottomCropSpinButton - , GR.topTextEntry - , GR.bottomTextEntry , GR.statusEntry - , GR.inFileChooserWidget - , GR.longGifGtkMessageDialog + , GR.confirmMessageDialog , GR.saveSpinner + , GR.inVideoPropertiesRef } = void $ GI.Gtk.onWidgetButtonReleaseEvent saveButton $ \ _ -> do - inFilePath <- fileChooserGetFilePath inFileChooserWidget + GR.InVideoProperties + { GR.inVideoUri = inFilePath + } <- readIORef inVideoPropertiesRef startTime <- double2Float <$> GI.Gtk.spinButtonGetValue startTimeSpinButton durationTime <- double2Float <$> GI.Gtk.spinButtonGetValue durationTimeSpinButton widthSize <- double2Float <$> GI.Gtk.spinButtonGetValue widthSizeSpinButton - qualityPercent <- double2Float <$> GI.Gtk.spinButtonGetValue qualityPercentSpinButton + quality <- getQuality leftCrop <- double2Float <$> GI.Gtk.spinButtonGetValue leftCropSpinButton rightCrop <- double2Float <$> GI.Gtk.spinButtonGetValue rightCropSpinButton topCrop <- double2Float <$> GI.Gtk.spinButtonGetValue topCropSpinButton bottomCrop <- double2Float <$> GI.Gtk.spinButtonGetValue bottomCropSpinButton - fontChoice <- GI.Gtk.fontButtonGetFontName fontChooserButton - topText <- GI.Gtk.entryGetText topTextEntry - bottomText <- GI.Gtk.entryGetText bottomTextEntry saveAsVideo <- GI.Gtk.toggleButtonGetActive saveAsVideoRadioButton outFilePath <- outFileChooserButtonGetFilePath outFileChooserButton outFileNameEntry + textOverlays <- GuiTextOverlays.getGifcurryTextOverlays guiComponents let params = Gifcurry.defaultGifParams { Gifcurry.inputFile = inFilePath @@ -499,24 +488,25 @@ handleSaveButtonClick , Gifcurry.startTime = startTime , Gifcurry.durationTime = durationTime , Gifcurry.widthSize = truncate widthSize - , Gifcurry.qualityPercent = qualityPercent - , Gifcurry.fontChoice = unpack fontChoice - , Gifcurry.topText = unpack topText - , Gifcurry.bottomText = unpack bottomText + , Gifcurry.quality = quality , Gifcurry.leftCrop = leftCrop , Gifcurry.rightCrop = rightCrop , Gifcurry.topCrop = topCrop , Gifcurry.bottomCrop = bottomCrop + , Gifcurry.textOverlays = textOverlays } paramsValid <- Gifcurry.gifParamsValid params GI.Gtk.entrySetText statusEntry "Ready." if paramsValid then do - longGifGtkMessageDialogResponse <- + GI.Gtk.setMessageDialogText + confirmMessageDialog + "Create a GIF with that long of a duration?" + confirmMessageDialogResponse <- if durationTime >= durationTimeWarningLevel - then GI.Gtk.dialogRun longGifGtkMessageDialog + then GI.Gtk.dialogRun confirmMessageDialog else return (enumToInt32 GI.Gtk.ResponseTypeYes) - when (longGifGtkMessageDialogResponse == enumToInt32 GI.Gtk.ResponseTypeYes) $ do + when (confirmMessageDialogResponse == enumToInt32 GI.Gtk.ResponseTypeYes) $ do GI.Gtk.widgetSetSensitive saveButton False GI.Gtk.widgetSetSensitive openButton False GI.Gtk.widgetHide saveButton @@ -544,6 +534,14 @@ handleSaveButtonClick GI.Gtk.widgetSetSensitive openButton True else GI.Gtk.entrySetText statusEntry "The settings are wrong." return True + where + getQuality :: IO Gifcurry.Quality + getQuality = + fromMaybe Gifcurry.QualityMedium . + Gifcurry.qualityFromString . + Data.Text.unpack . + fromMaybe "Medium" <$> + GI.Gtk.getComboBoxActiveId qualityComboBoxText handleOpenButtonClick :: GR.GuiComponents -> IO () handleOpenButtonClick @@ -578,7 +576,7 @@ handleDialogs guiComponents@GR.GuiComponents { GR.inFileChooserDialog , GR.aboutDialog - , GR.longGifGtkMessageDialog + , GR.confirmMessageDialog , GR.aboutButton , GR.inFileChooserButton } @@ -587,8 +585,8 @@ handleDialogs aboutButton (\ _ -> GI.Gtk.dialogRun aboutDialog >> return True) _ <- GI.Gtk.onDialogResponse - longGifGtkMessageDialog - (\ _ -> GI.Gtk.widgetHide longGifGtkMessageDialog) + confirmMessageDialog + (\ _ -> GI.Gtk.widgetHide confirmMessageDialog) _ <- GI.Gtk.onDialogResponse aboutDialog (\ _ -> GI.Gtk.widgetHide aboutDialog) @@ -606,29 +604,29 @@ handleDialogs handleSidebarSectionToggleButtons :: GR.GuiComponents -> IO () handleSidebarSectionToggleButtons GR.GuiComponents - { GR.widthQualityPercentToggleButton + { GR.widthQualityToggleButton , GR.cropToggleButton - , GR.topBottomTextToggleButton + , GR.textOverlaysToggleButton , GR.saveOpenToggleButton , GR.uploadToggleButton - , GR.widthQualityPercentBox + , GR.widthQualityBox , GR.cropSpinButtonsBox - , GR.topBottomTextFontChooserBox + , GR.textOverlaysMainBox , GR.saveOpenBox , GR.uploadBox } = do let toggleButtons = - [ widthQualityPercentToggleButton + [ widthQualityToggleButton , cropToggleButton - , topBottomTextToggleButton + , textOverlaysToggleButton , saveOpenToggleButton , uploadToggleButton ] let boxes = - [ widthQualityPercentBox + [ widthQualityBox , cropSpinButtonsBox - , topBottomTextFontChooserBox + , textOverlaysMainBox , saveOpenBox , uploadBox ] @@ -765,17 +763,20 @@ unhighlightSpinButton :: GI.Gtk.SpinButton -> IO () unhighlightSpinButton = styleSpinButtonAndEntry "{}" styleSpinButtonAndEntry :: String -> GI.Gtk.SpinButton -> IO () -styleSpinButtonAndEntry style = +styleSpinButtonAndEntry style spinButton = do + name <- Data.Text.unpack . Data.Text.strip <$> GI.Gtk.widgetGetName spinButton + let name' = if Data.List.null name then "" else "#" ++ name GuiStyle.styleWidget - ( "spinbutton " - ++ style - ++ " .spinbutton " - ++ style - ++ " spinbutton entry " + ( "spinbutton" + ++ name' + ++ " entry " ++ style - ++ " .spinbutton .entry " + ++ " GtkSpinButton" + ++ name' + ++ " GtkEntry " ++ style ) + spinButton updateStatusEntryAsync :: GI.Gtk.Entry -> Word32 -> Text -> IO () updateStatusEntryAsync statusEntry seconds message = @@ -801,23 +802,12 @@ updateStartAndDurationTimeSpinButtonRanges , GR.inVideoPropertiesRef } = do - videoDuration <- float2Double . GR.inVideoDuration <$> readIORef inVideoPropertiesRef + videoDuration <- floatToDouble . GR.inVideoDuration <$> readIORef inVideoPropertiesRef let buffer = if videoDuration * 0.01 > 0.1 then 0.1 else videoDuration * 0.01 _ <- GI.Gtk.spinButtonSetRange startTimeSpinButton 0.0 (videoDuration - buffer) _ <- GI.Gtk.spinButtonSetRange durationTimeSpinButton buffer videoDuration return () -updateStartAndDurationTimeSpinButtonFractions :: GR.GuiComponents -> IO () -updateStartAndDurationTimeSpinButtonFractions - GR.GuiComponents - { GR.startTimeSpinButton - , GR.durationTimeSpinButton - } - = do - _ <- setSpinButtonFraction startTimeSpinButton - _ <- setSpinButtonFraction durationTimeSpinButton - return () - syncStartAndDurationTimeSpinButtons :: GR.GuiComponents -> IO () syncStartAndDurationTimeSpinButtons guiComponents@GR.GuiComponents @@ -826,57 +816,48 @@ syncStartAndDurationTimeSpinButtons , GR.inVideoPropertiesRef } = do - startTime <- GI.Gtk.spinButtonGetValue startTimeSpinButton - durationTime <- GI.Gtk.spinButtonGetValue durationTimeSpinButton - videoDuration <- float2Double . GR.inVideoDuration <$> readIORef inVideoPropertiesRef + startTime <- GI.Gtk.spinButtonGetValue startTimeSpinButton + durationTime <- GI.Gtk.spinButtonGetValue durationTimeSpinButton + videoDuration <- floatToDouble . GR.inVideoDuration <$> readIORef inVideoPropertiesRef let startTime' = if startTime >= videoDuration then videoDuration else startTime let maxDurationTime = if videoDuration - startTime' <= 0.0 then 0.0 else videoDuration - startTime' - let durationTime' = + let durationTime' = if durationTime >= maxDurationTime then maxDurationTime else durationTime _ <- updateStartAndDurationTimeSpinButtonRanges guiComponents - _ <- GI.Gtk.spinButtonSetValue startTimeSpinButton startTime' - _ <- GI.Gtk.spinButtonSetValue durationTimeSpinButton durationTime' + _ <- GI.Gtk.spinButtonSetValue startTimeSpinButton $ truncatePastDigit startTime' 2 + _ <- GI.Gtk.spinButtonSetValue durationTimeSpinButton $ truncatePastDigit durationTime' 2 updateStartAndDurationTimeSpinButtonFractions guiComponents - updateStartAndEndTimeProgressBars guiComponents -updateStartAndEndTimeProgressBars :: GR.GuiComponents -> IO () -updateStartAndEndTimeProgressBars +updateStartAndDurationTimeSpinButtonFractions :: GR.GuiComponents -> IO () +updateStartAndDurationTimeSpinButtonFractions GR.GuiComponents { GR.startTimeSpinButton , GR.durationTimeSpinButton - , GR.startTimeProgressBar - , GR.endTimeProgressBar - , GR.inVideoPropertiesRef } = do - videoDuration <- float2Double . GR.inVideoDuration <$> readIORef inVideoPropertiesRef - startTime <- GuiMisc.clamp 0.0 videoDuration <$> GI.Gtk.spinButtonGetValue startTimeSpinButton - durationTime <- GuiMisc.clamp 0.0 videoDuration <$> GI.Gtk.spinButtonGetValue durationTimeSpinButton - let endTime = startTime + durationTime - let endTime' = GuiMisc.clamp 0.0 videoDuration $ videoDuration - endTime - let startTimeProgressBarFraction = fromMaybe 0.0 $ safeDivide startTime videoDuration - let endTimeProgressBarFraction = fromMaybe 0.0 $ safeDivide endTime' videoDuration - _ <- GI.Gtk.progressBarSetFraction startTimeProgressBar startTimeProgressBarFraction - _ <- GI.Gtk.progressBarSetFraction endTimeProgressBar endTimeProgressBarFraction + _ <- setSpinButtonFraction startTimeSpinButton + _ <- setSpinButtonFraction durationTimeSpinButton return () hideWidgetsOnRealize :: GR.GuiComponents -> IO () hideWidgetsOnRealize GR.GuiComponents { GR.saveSpinner - , GR.widthQualityPercentBox + , GR.sidebarControlsPreviewbox + , GR.widthQualityBox , GR.cropSpinButtonsBox - , GR.topBottomTextFontChooserBox + , GR.textOverlaysMainBox , GR.saveOpenBox , GR.uploadBox } = do hideOnRealize saveSpinner let boxes = - [ widthQualityPercentBox + [ sidebarControlsPreviewbox + , widthQualityBox , cropSpinButtonsBox - , topBottomTextFontChooserBox + , textOverlaysMainBox , saveOpenBox , uploadBox ] diff --git a/src/lib/Gifcurry.hs b/src/lib/Gifcurry.hs index 11931e3..2602442 100644 --- a/src/lib/Gifcurry.hs +++ b/src/lib/Gifcurry.hs @@ -14,14 +14,18 @@ module Gifcurry ( gif , GifParams(..) + , Quality(..) + , TextOverlay(..) + , TextOverlayOrigin(..) , defaultGifParams - , defaultFontChoice , gifParamsValid , versionNumber , getVideoDurationInSeconds , getOutputFileWithExtension , getVideoWidthAndHeight , findOrCreateTemporaryDirectory + , qualityFromString + , textOverlayOriginFromString ) where @@ -29,57 +33,122 @@ import System.Process import System.IO.Temp import System.Directory import System.FilePath +import qualified System.FilePath.Find as SFF +import Control.Exception +import Control.Monad import Text.Read +import Text.ParserCombinators.ReadP +import Text.Printf import Data.Maybe import Data.List import Data.Text import Data.Either -import Text.Printf -import Control.Exception -import Control.Monad -- | The data type record required by 'gif'. data GifParams = GifParams - { inputFile :: String - , outputFile :: String - , saveAsVideo :: Bool - , startTime :: Float - , durationTime :: Float - , widthSize :: Int - , qualityPercent :: Float - , fontChoice :: String - , topText :: String - , bottomText :: String - , leftCrop :: Float - , rightCrop :: Float - , topCrop :: Float - , bottomCrop :: Float + { inputFile :: String + , outputFile :: String + , saveAsVideo :: Bool + , startTime :: Float + , durationTime :: Float + , widthSize :: Int + , quality :: Quality + , textOverlays :: [TextOverlay] + , leftCrop :: Float + , rightCrop :: Float + , topCrop :: Float + , bottomCrop :: Float } deriving (Show, Read) +-- | The data type that holds the needed information to render text on top of the GIF. +data TextOverlay = + TextOverlay + { textOverlayText :: String + , textOverlayFontFamily :: String + , textOverlayFontStyle :: String + , textOverlayFontStretch :: String + , textOverlayFontWeight :: Int + , textOverlayFontSize :: Int + , textOverlayOrigin :: TextOverlayOrigin + , textOverlayXTranslation :: Float + , textOverlayYTranslation :: Float + , textOverlayRotation :: Int + , textOverlayStartTime :: Float + , textOverlayDurationTime :: Float + , textOverlayOutlineSize :: Int + , textOverlayOutlineColor :: String + , textOverlayFillColor :: String + } + deriving (Show, Read) + +-- | The starting point for a text overlay. +data TextOverlayOrigin = + TextOverlayOriginNorthWest + | TextOverlayOriginNorth + | TextOverlayOriginNorthEast + | TextOverlayOriginWest + | TextOverlayOriginCenter + | TextOverlayOriginEast + | TextOverlayOriginSouthWest + | TextOverlayOriginSouth + | TextOverlayOriginSouthEast + deriving (Read) + +instance Show TextOverlayOrigin where + show TextOverlayOriginNorthWest = "NorthWest" + show TextOverlayOriginNorth = "North" + show TextOverlayOriginNorthEast = "NorthEast" + show TextOverlayOriginWest = "West" + show TextOverlayOriginCenter = "Center" + show TextOverlayOriginEast = "East" + show TextOverlayOriginSouthWest = "SouthWest" + show TextOverlayOriginSouth = "South" + show TextOverlayOriginSouthEast = "SouthEast" + +-- | Controls the amount of colors used and the frame rate. +-- Higher values will result in a larger file size. +data Quality = + QualityHigh + | QualityMedium + | QualityLow + deriving (Read) + +instance Show Quality where + show QualityHigh = "High" + show QualityMedium = "Medium" + show QualityLow = "Low" + -- | The version number. versionNumber :: String -versionNumber = "3.0.0.2" +versionNumber = "4.0.0.0" --- | Specifies default parameters for 'startTime', 'durationTime', 'widthSize', 'qualityPercent', and 'fontChoice'. +-- | Specifies the default parameters for the following. +-- * 'startTime' +-- * 'durationTime' +-- * 'widthSize' +-- * 'quality' +-- * 'textOverlays' +-- * 'leftCrop' +-- * 'rightCrop' +-- * 'topCrop' +-- * 'bottomCrop' defaultGifParams :: GifParams defaultGifParams = GifParams - { inputFile = "" - , outputFile = "" - , saveAsVideo = False - , startTime = 0.0 - , durationTime = 1.0 - , widthSize = 500 - , qualityPercent = 100.0 - , fontChoice = defaultFontChoice - , topText = "" - , bottomText = "" - , leftCrop = 0.0 - , rightCrop = 0.0 - , topCrop = 0.0 - , bottomCrop = 0.0 + { inputFile = "" + , outputFile = "" + , saveAsVideo = False + , startTime = 0.0 + , durationTime = 1.0 + , widthSize = 500 + , quality = QualityHigh + , textOverlays = [] + , leftCrop = 0.0 + , rightCrop = 0.0 + , topCrop = 0.0 + , bottomCrop = 0.0 } -- | Inputs 'GifParams' and outputs either an IO IOError or IO String. @@ -98,66 +167,157 @@ defaultGifParams = -- @ gif :: GifParams -> IO (Either IOError String) gif - gifParams@GifParams { saveAsVideo } + gifParams@GifParams + { widthSize + , saveAsVideo + , startTime + , textOverlays + , quality + } = do - temporaryDirectory <- findOrCreateTemporaryDirectory - withTempDirectory temporaryDirectory "gifcurry-frames" $ \ tempDir -> - handleFrameExtraction tempDir - >>= handleFrameMerge tempDir - >>= handleGifToVideoConversion + printGifParams gifParams + validParams <- gifParamsValid gifParams + if validParams + then do + temporaryDirectory <- findOrCreateTemporaryDirectory + withTempDirectory temporaryDirectory "gifcurry-frames" $ \ tempDir -> + handleFrameExtraction tempDir >>= + handleFrameAnnotations tempDir >>= + handleFrameMerge tempDir + else return $ Left $ userError "Invalid params." where handleFrameExtraction :: String -> IO (Either IOError Float) handleFrameExtraction tempDir = do - printGifParams gifParams - validParams <- gifParamsValid gifParams - if validParams - then do - frameRate <- - validateAndAdjustFrameRate gifParams <$> - getVideoAverageFrameRateInSeconds gifParams - result <- extractFrames gifParams tempDir frameRate - case result of - Left x -> do - putStrLn "[ERROR] Something went wrong with FFmpeg." - return $ Left x - Right _ -> return $ Right frameRate - else return $ Left $ userError "Invalid params." - handleFrameMerge :: String -> Either IOError Float -> IO (Either IOError String) - handleFrameMerge tempDir (Right frameRate) = do - fontMatch <- getFontMatch gifParams - let gifParams' = gifParams { fontChoice = fontMatch } - result <- mergeFramesIntoGif gifParams' tempDir frameRate + frameRate <- qualityAndFrameRateToFrameRate quality . fromMaybe defaultFrameRate <$> + getVideoAverageFrameRateInSeconds gifParams + result <- extractFrames gifParams tempDir frameRate case result of - Left x -> do - putStrLn "[ERROR] Something went wrong with ImageMagick." + Left x -> do + putStrLn "[ERROR] Something went wrong with FFmpeg." return $ Left x - Right gifFilePath -> return $ Right gifFilePath - handleFrameMerge _ (Left x) = return $ Left x - handleGifToVideoConversion :: Either IOError String -> IO (Either IOError String) - handleGifToVideoConversion (Right gifFilePath) = + Right _ -> return $ Right frameRate + handleFrameAnnotations :: String -> Either IOError Float -> IO (Either IOError Float) + handleFrameAnnotations tempDir (Right frameRate) + | Prelude.null textOverlays = return $ Right frameRate + | frameRate <= 0.0 = do + let errorString = "Frame rate is less than or equal to zero." + putStrLn $ "[ERROR] " ++ errorString + return $ Left $ userError errorString + | otherwise = do + frameFilePaths <- + SFF.find + SFF.always + (SFF.fileName SFF.~~? "*extracted-frames_*") + tempDir + let maybeFrameNumbers = getFrameNumbers frameFilePaths + case maybeFrameNumbers of + Just frameNumbers -> do + fontFamilies <- getFontFamilies + maybeInVideoWidthHeight <- getVideoWidthAndHeight gifParams + let frameSeconds = + Prelude.map + (\ x -> startTime + ((realToFrac x :: Float) * (1.0 / frameRate))) + frameNumbers + let frameFilePathsFrameSeconds = Prelude.zip frameFilePaths frameSeconds + let widthSize' = fromIntegral widthSize :: Float + let (gifWidthNoCrop, gifHeightNoCrop) = + case maybeInVideoWidthHeight of + Just (w, h) -> (widthSize', widthSize' * (h / w)) + _ -> ( 0.0, 0.0) + putStrLn "[INFO] Adding text..." + results <- + mapM + (\ (filePath, second) -> do + let textOverlays' = + Prelude.foldl + (\ xs x -> + if textOverlayStartTime x <= second && + textOverlayStartTime x + textOverlayDurationTime x >= second + then xs ++ [x] + else xs + ) + [] + textOverlays + annotateImage + gifParams + gifWidthNoCrop + gifHeightNoCrop + fontFamilies + filePath + textOverlays' + ) + frameFilePathsFrameSeconds + if Prelude.any isLeft results + then + case results of + (Left x:_) -> return $ Left x + _ -> return $ Left $ userError "Could not annotate the frames." + else return $ Right frameRate + Nothing -> do + let errorString = "Could not find the frame numbers." + putStrLn $ "[ERROR] " ++ errorString + return $ Left $ userError errorString + handleFrameAnnotations _ (Left x) = return $ Left x + handleFrameMerge :: String -> Either IOError Float -> IO (Either IOError String) + handleFrameMerge tempDir (Right frameRate) = if saveAsVideo then do - result <- convertGifToVideo gifParams gifFilePath + result <- mergeFramesIntoVideo gifParams tempDir frameRate case result of Left x -> do putStrLn "[ERROR] Something went wrong with FFmpeg." return $ Left x - Right outputFileWithExtension -> do + Right videoFilePath -> do putStrLn "[INFO] All done." - return $ Right outputFileWithExtension + return $ Right videoFilePath else do - putStrLn "[INFO] All done." - return $ Right gifFilePath - handleGifToVideoConversion result@(Left _) = return result - getFontMatch :: GifParams -> IO String - getFontMatch GifParams { topText = "", bottomText = "" } = defaultFontMatch - getFontMatch gifParams' = do - fontNames <- getListOfFontNames - let match = bestFontNameMatch (fontChoiceOrDefault gifParams') fontNames - putStrLn $ "[INFO] Your font choice matched to \"" ++ match ++ "\"." - return match - defaultFontMatch :: IO String - defaultFontMatch = return defaultFontChoice + result <- mergeFramesIntoGif gifParams tempDir frameRate + case result of + Left x -> do + putStrLn "[ERROR] Something went wrong with ImageMagick." + return $ Left x + Right gifFilePath -> do + putStrLn "[INFO] All done." + return $ Right gifFilePath + handleFrameMerge _ (Left x) = return $ Left x + +-- | Convenience function that attempts to turn a string into a 'TextOverlayOrigin'. +-- @ +-- textOverlayOriginFromString " cEntEr " -- Just TextOverlayOriginCenter +-- textOverlayOriginFromString "test" -- Nothing +-- @ +textOverlayOriginFromString :: String -> Maybe Gifcurry.TextOverlayOrigin +textOverlayOriginFromString origin = + textOverlayOriginFromString' $ + stripAndLowerString origin + where + textOverlayOriginFromString' :: String -> Maybe TextOverlayOrigin + textOverlayOriginFromString' "northwest" = Just TextOverlayOriginNorthWest + textOverlayOriginFromString' "north" = Just TextOverlayOriginNorth + textOverlayOriginFromString' "northeast" = Just TextOverlayOriginNorthEast + textOverlayOriginFromString' "west" = Just TextOverlayOriginWest + textOverlayOriginFromString' "center" = Just TextOverlayOriginCenter + textOverlayOriginFromString' "east" = Just TextOverlayOriginEast + textOverlayOriginFromString' "southwest" = Just TextOverlayOriginSouthWest + textOverlayOriginFromString' "south" = Just TextOverlayOriginSouth + textOverlayOriginFromString' "southeast" = Just TextOverlayOriginSouthEast + textOverlayOriginFromString' _ = Nothing + +-- | Convenience function that attempts to turn a string into a 'Quality'. +-- @ +-- qualityFromString " hIgH " -- Just QualityHigh +-- qualityFromString "test" -- Nothing +-- @ +qualityFromString :: String -> Maybe Quality +qualityFromString quality = + qualityFromString' $ + stripAndLowerString quality + where + qualityFromString' :: String -> Maybe Quality + qualityFromString' "high" = Just QualityHigh + qualityFromString' "medium" = Just QualityMedium + qualityFromString' "low" = Just QualityLow + qualityFromString' _ = Nothing -- | Outputs `True` or `False` if the parameters in the `GifParams` record are valid. gifParamsValid :: GifParams -> IO Bool @@ -168,37 +328,41 @@ gifParamsValid , startTime , durationTime , widthSize - , qualityPercent , leftCrop , rightCrop , topCrop , bottomCrop + , textOverlays } = do inputFileExists <- case Prelude.length inputFile of 0 -> return False _ -> doesFileExist inputFile - let widthSize' = fromIntegral widthSize :: Float - let outputFileValid = not $ Data.Text.null $ Data.Text.strip $ Data.Text.pack outputFile - let startTimeValid = startTime >= 0.0 - let durationTimeValid = durationTime > 0.0 - let widthSizeValid = widthSize >= 1 - let qualityPercentValid = qualityPercent >= 1.0 && qualityPercent <= 100.0 - let leftCropValid = cropValid leftCrop - let rightCropValid = cropValid rightCrop - let topCropValid = cropValid topCrop - let bottomCropValid = cropValid bottomCrop - let leftRightCropValid = cropValid (leftCrop + rightCrop) - let topBottomCropValid = cropValid (topCrop + bottomCrop) + let widthSize' = fromIntegral widthSize :: Float + let outputFileValid = not $ Data.Text.null $ Data.Text.strip $ Data.Text.pack outputFile + let startTimeValid = startTime >= 0.0 + let durationTimeValid = durationTime > 0.0 + let widthSizeValid = widthSize >= 1 + let leftCropValid = cropValid leftCrop + let rightCropValid = cropValid rightCrop + let topCropValid = cropValid topCrop + let bottomCropValid = cropValid bottomCrop + let leftRightCropValid = cropValid (leftCrop + rightCrop) + let topBottomCropValid = cropValid (topCrop + bottomCrop) let widthLeftRightCropSizeValid = - (widthSize' - (widthSize' * (leftCrop / 100.0)) - (widthSize' * (rightCrop / 100.0))) >= 1.0 + (widthSize' - (widthSize' * leftCrop) - (widthSize' * rightCrop)) >= 1.0 + let textOverlayColorsValid = + Prelude.all + (\ TextOverlay { textOverlayOutlineColor, textOverlayFillColor } -> + isJust (getRgb textOverlayOutlineColor) && isJust (getRgb textOverlayFillColor) + ) + textOverlays unless inputFileExists $ printError "Input video file does not exist." unless outputFileValid $ printInvalid "Output File" unless startTimeValid $ printInvalid "Start Time" unless durationTimeValid $ printInvalid "Duration Time" unless widthSizeValid $ printInvalid "Width Size" - unless qualityPercentValid $ printInvalid "Quality Percent" unless leftCropValid $ printInvalid "Left Crop" unless rightCropValid $ printInvalid "Right Crop" unless topCropValid $ printInvalid "Top Crop" @@ -206,22 +370,22 @@ gifParamsValid unless leftRightCropValid $ printInvalid "Left and Right Crop" unless topBottomCropValid $ printInvalid "Top and Bottom Crop" unless widthLeftRightCropSizeValid $ printError "Width Size too small with Left and Right Crop." - let valid = - inputFileExists - && outputFileValid - && startTimeValid - && durationTimeValid - && widthSizeValid - && qualityPercentValid - && leftCropValid - && rightCropValid - && topCropValid - && bottomCropValid - && widthLeftRightCropSizeValid - return valid + unless textOverlayColorsValid $ printError "Text overlay color(s) invalid. The format is: rgb(r,g,b)" + return $ + inputFileExists + && outputFileValid + && startTimeValid + && durationTimeValid + && widthSizeValid + && leftCropValid + && rightCropValid + && topCropValid + && bottomCropValid + && widthLeftRightCropSizeValid + && textOverlayColorsValid where cropValid :: Float -> Bool - cropValid c = c >= 0.0 && c <= 100.0 + cropValid c = c >= 0.0 && c < 1.0 printInvalid :: String -> IO () printInvalid s = printError $ s ++ " is invalid." printError :: String -> IO () @@ -340,10 +504,6 @@ getOutputFileWithExtension GifParams { outputFile, saveAsVideo } = ++ "." ++ (if saveAsVideo then videoExtension else gifExtension) --- | Returns the default font choice used if no font choice is specified. -defaultFontChoice :: String -defaultFontChoice = "sans-serif" - gifOutputFile :: String -> String gifOutputFile outputFile = getOutputFileWithExtension $ @@ -354,64 +514,6 @@ videoOutputFile outputFile = getOutputFileWithExtension $ defaultGifParams { outputFile = outputFile, saveAsVideo = True } -defaultFrameRate :: Float -defaultFrameRate = 15.0 - -validateAndAdjustFrameRate :: GifParams -> Maybe Float -> Float -validateAndAdjustFrameRate gifParams = - frameRateBasedOnQualityPercent gifParams . maybeFrameRateOrDefaultFrameRate - -maybeFrameRateOrDefaultFrameRate :: Maybe Float -> Float -maybeFrameRateOrDefaultFrameRate (Just frameRate) = - if frameRate <= defaultFrameRate then defaultFrameRate else frameRate -maybeFrameRateOrDefaultFrameRate Nothing = defaultFrameRate - -frameRateBasedOnQualityPercent :: GifParams -> Float -> Float -frameRateBasedOnQualityPercent GifParams { qualityPercent } frameRate = - if result <= defaultFrameRate then defaultFrameRate else result - where - result :: Float - result = frameRate * (qualityPercent / 100.0) - -getVideoAverageFrameRateInSeconds :: GifParams -> IO (Maybe Float) -getVideoAverageFrameRateInSeconds GifParams { inputFile } = tryFfprobe params >>= result - where - result :: Either IOError String -> IO (Maybe Float) - result (Left _) = return Nothing - result (Right avgFrameRateString) = return $ processString avgFrameRateString - where - processString :: String -> Maybe Float - processString = - divideMaybeFloats . textsToMaybeFloats . filterNullTexts . splitText . cleanString - cleanString :: String -> Text - cleanString = Data.Text.strip . Data.Text.pack - splitText :: Text -> [Text] - splitText = Data.Text.split (== '/') - filterNullTexts :: [Text] -> [Text] - filterNullTexts = Data.List.filter (not . Data.Text.null) - textsToMaybeFloats :: [Text] -> [Maybe Float] - textsToMaybeFloats = - Data.List.filter isJust - . Data.List.map (\ s -> readMaybe (Data.Text.unpack s) :: Maybe Float) - divideMaybeFloats :: [Maybe Float] -> Maybe Float - divideMaybeFloats (Just n:Just d:_) = - if d <= 0 || n <= 0 then Nothing else Just $ n / d - divideMaybeFloats _ = Nothing - params :: [String] - params = - [ "-v" - , "error" - , "-select_streams" - , "v:0" - , "-show_entries" - , "stream=avg_frame_rate" - , "-of" - , "default=noprint_wrappers=1:nokey=1" - , inputFile - ] - -tryFfprobe :: [String] -> IO (Either IOError String) -tryFfprobe params = try $ readProcess "ffprobe" params [] printGifParams :: GifParams -> IO () printGifParams @@ -421,40 +523,88 @@ printGifParams , startTime , durationTime , widthSize - , qualityPercent - , fontChoice - , topText - , bottomText + , quality , leftCrop , rightCrop , topCrop , bottomCrop + , textOverlays } = putStrLn $ - Prelude.unlines - [ "[INFO] Here are your settings." - , "" - , " - FILE IO:" - , " - Input File: " ++ inputFile - , " - Output File: " ++ getOutputFileWithExtension gifParams - , " - Save As Video: " ++ if saveAsVideo then "Yes" else "No" - , " - TIME:" - , " - Start Second: " ++ printFloat startTime - , " - Duration Time: " ++ printFloat durationTime ++ " seconds" - , " - OUTPUT FILE SIZE:" - , " - Width Size: " ++ show widthSize ++ "px" - , " - Quality Percent: " ++ show (qualityPercentClamp qualityPercent) ++ "%" - , " - TEXT:" - , " - Font Choice: " ++ fontChoice - , " - Top Text: " ++ topText - , " - Bottom Text: " ++ bottomText - , " - CROP:" - , " - Left Crop: " ++ printFloat leftCrop - , " - Right crop: " ++ printFloat rightCrop - , " - Top Crop: " ++ printFloat topCrop - , " - Bottom Crop: " ++ printFloat bottomCrop - ] + Prelude.unlines $ + [ "[INFO] Here are your settings." + , "" + , " - FILE IO:" + , " - Input File: " ++ inputFile + , " - Output File: " ++ getOutputFileWithExtension gifParams + , " - Save As Video: " ++ if saveAsVideo then "Yes" else "No" + , " - TIME:" + , " - Start Second: " ++ printFloat startTime + , " - Duration Time: " ++ printFloat durationTime ++ " seconds" + , " - OUTPUT FILE SIZE:" + , " - Width Size: " ++ show widthSize ++ "px" + , " - Quality: " ++ show quality + ] + ++ if Prelude.null textOverlays + then [] + else + [ " - TEXT:" + ] + ++ + Prelude.foldl + (\ xs + TextOverlay + { textOverlayText + , textOverlayFontFamily + , textOverlayFontStyle + , textOverlayFontStretch + , textOverlayFontWeight + , textOverlayFontSize + , textOverlayStartTime + , textOverlayDurationTime + , textOverlayOrigin + , textOverlayXTranslation + , textOverlayYTranslation + , textOverlayRotation + , textOverlayOutlineSize + , textOverlayOutlineColor + , textOverlayFillColor + } + -> + xs + ++ [ " - Text: " ++ textOverlayText + , " - Font:" + , " - Family: " ++ textOverlayFontFamily + , " - Size: " ++ show textOverlayFontSize + , " - Style: " ++ textOverlayFontStyle + , " - Stretch: " ++ textOverlayFontStretch + , " - Weight: " ++ show textOverlayFontWeight + , " - Time:" + , " - Start: " ++ printFloat textOverlayStartTime ++ " seconds" + , " - Duration: " ++ printFloat textOverlayDurationTime ++ " seconds" + , " - Translation:" + , " - Origin: " ++ show textOverlayOrigin + , " - X: " ++ show textOverlayXTranslation + , " - Y: " ++ show textOverlayYTranslation + , " - Rotation:" + , " - Degrees: " ++ show textOverlayRotation + , " - Outline: " + , " - Size: " ++ show textOverlayOutlineSize + , " - Color: " ++ textOverlayOutlineColor + , " - Fill:" + , " - Color: " ++ textOverlayFillColor + ] + ) + [] + textOverlays + ++ + [ " - CROP:" + , " - Left: " ++ printFloat leftCrop + , " - Right: " ++ printFloat rightCrop + , " - Top: " ++ printFloat topCrop + , " - Bottom: " ++ printFloat bottomCrop + ] where printFloat :: Float -> String printFloat = printf "%.3f" @@ -493,7 +643,7 @@ extractFrames widthSize' :: String widthSize' = show widthSize frameRate' :: String - frameRate' = show $ maybeFrameRateOrDefaultFrameRate (Just frameRate) + frameRate' = show frameRate params :: [String] params = [ "-nostats" @@ -515,83 +665,237 @@ extractFrames ++ widthSize' ++ ":-1" ++",crop=w=iw*(1-" - ++ show ((leftCrop + rightCrop) / 100.0) + ++ show (leftCrop + rightCrop) ++ "):h=ih*(1-" - ++ show ((topCrop + bottomCrop) / 100.0) + ++ show (topCrop + bottomCrop) ++ "):x=iw*" - ++ show (leftCrop / 100.0) + ++ show leftCrop ++ ":y=ih*" - ++ show (topCrop / 100.0) + ++ show topCrop ++ ":exact=1" + , "-start_number" + , "0" , "-f" , "image2" - , tempDir ++ "/%010d." ++ frameFileExtension + , tempDir ++ "/extracted-frames_%010d." ++ frameFileExtension ] +annotateImage + :: GifParams + -> Float + -> Float + -> [Text] + -> String + -> [TextOverlay] + -> IO (Either IOError String) +annotateImage + GifParams + { leftCrop + , rightCrop + , topCrop + , bottomCrop + } + gifWidthNoCrop + gifHeightNoCrop + fontFamilies + filePath + textOverlays + = do + let annotations = + Prelude.foldl + (\ xs + TextOverlay + { textOverlayText + , textOverlayFontFamily + , textOverlayFontStyle + , textOverlayFontStretch + , textOverlayFontWeight + , textOverlayFontSize + , textOverlayOrigin + , textOverlayXTranslation + , textOverlayYTranslation + , textOverlayRotation + , textOverlayOutlineSize + , textOverlayOutlineColor + , textOverlayFillColor + } + -> + xs + ++ fontFamilyArg fontFamilies textOverlayFontFamily + ++ [ "-style" + , textOverlayFontStyle + , "-stretch" + , textOverlayFontStretch + , "-weight" + , show textOverlayFontWeight + , "-pointsize" + , show textOverlayFontSize + , "-gravity" + , show textOverlayOrigin + , "-density" + , "96" + ] + ++ ( if textOverlayOutlineSize <= 0 + then [] + else + [ "-strokewidth" + , show textOverlayOutlineSize + , "-stroke" + , textOverlayOutlineColor + , "-annotate" + , rotation textOverlayRotation + ++ position textOverlayOrigin textOverlayXTranslation textOverlayYTranslation + , textOverlayText + ] + ) + ++ ["-stroke" + , "none" + , "-fill" + , textOverlayFillColor + , "-annotate" + , rotation textOverlayRotation + ++ position textOverlayOrigin textOverlayXTranslation textOverlayYTranslation + , textOverlayText + ] + ) + [] + textOverlays + let params = + [ "-quiet" + , filePath + ] + ++ annotations + ++ [filePath] + result <- try $ readProcess "convert" params [] + if isLeft result + then return result + else return $ Right $ "Annotated " ++ filePath + where + {- + .+ .+ +. + + + + + + .+ .+ +. + + + + + + + + + + . + .+ +. + -} + position :: TextOverlayOrigin -> Float -> Float -> String + position TextOverlayOriginNorthWest textOverlayXTranslation textOverlayYTranslation = + toString (x pos textOverlayXTranslation 1.0 0.0) + ++ toString (y pos textOverlayYTranslation 1.0 0.0) + position TextOverlayOriginNorth textOverlayXTranslation textOverlayYTranslation = + toString (x pos textOverlayXTranslation 0.5 0.5) + ++ toString (y pos textOverlayYTranslation 1.0 0.0) + position TextOverlayOriginNorthEast textOverlayXTranslation textOverlayYTranslation = + toString (x neg textOverlayXTranslation 0.0 1.0) + ++ toString (y pos textOverlayYTranslation 1.0 0.0) + position TextOverlayOriginWest textOverlayXTranslation textOverlayYTranslation = + toString (x pos textOverlayXTranslation 1.0 0.0) + ++ toString (y pos textOverlayYTranslation 0.5 0.5) + position TextOverlayOriginCenter textOverlayXTranslation textOverlayYTranslation = + toString (x pos textOverlayXTranslation 0.5 0.5) + ++ toString (y pos textOverlayYTranslation 0.5 0.5) + position TextOverlayOriginEast textOverlayXTranslation textOverlayYTranslation = + toString (x neg textOverlayXTranslation 0.0 1.0) + ++ toString (y pos textOverlayYTranslation 0.5 0.5) + position TextOverlayOriginSouthWest textOverlayXTranslation textOverlayYTranslation = + toString (x pos textOverlayXTranslation 1.0 0.0) + ++ toString (y neg textOverlayYTranslation 0.0 1.0) + position TextOverlayOriginSouth textOverlayXTranslation textOverlayYTranslation = + toString (x pos textOverlayXTranslation 0.5 0.5) + ++ toString (y neg textOverlayYTranslation 0.0 1.0) + position TextOverlayOriginSouthEast textOverlayXTranslation textOverlayYTranslation = + toString (x neg textOverlayXTranslation 0.0 1.0) + ++ toString (y neg textOverlayYTranslation 0.0 1.0) + x :: Float -> Float -> Float -> Float -> Float + x f t lc rc = f * (originX t - (gifWidthLeftCrop * lc) + (gifWidthRightCrop * rc)) + y :: Float -> Float -> Float -> Float -> Float + y f t tc bc = f * (originY t - (gifHeightTopCrop * tc) + (gifHeightBottomCrop * bc)) + originX :: Float -> Float + originX = (*) gifWidthNoCrop + originY :: Float -> Float + originY = (*) gifHeightNoCrop + gifWidthLeftCrop :: Float + gifWidthLeftCrop = gifWidthNoCrop * leftCrop + gifWidthRightCrop :: Float + gifWidthRightCrop = gifWidthNoCrop * rightCrop + gifHeightTopCrop :: Float + gifHeightTopCrop = gifHeightNoCrop * topCrop + gifHeightBottomCrop :: Float + gifHeightBottomCrop = gifHeightNoCrop * bottomCrop + neg :: Float + neg = -1.0 + pos :: Float + pos = 1.0 + toString :: Float -> String + toString f + | f >= 0.0 = "+" ++ show (abs (round f :: Int)) + | otherwise = "-" ++ show (abs (round f :: Int)) + rotation :: Int -> String + rotation d = show d' ++ "x" ++ show d' + where + d' :: Int + d' = mod d 360 + mergeFramesIntoGif :: GifParams -> String -> Float -> IO (Either IOError String) mergeFramesIntoGif GifParams { outputFile - , saveAsVideo - , qualityPercent - , fontChoice - , topText - , bottomText + , quality } tempDir frameRate = do - maybeWidthHeight <- - maybeGetFirstFrameFilePath tempDir >>= - maybeGetFirstFrameWidthHeight - let frameRate' = maybeFrameRateOrDefaultFrameRate (Just frameRate) - let delay = show $ 100.0 / frameRate' - let outputFile' = - if saveAsVideo - then tempDir ++ "/finished-result.gif" - else gifOutputFile outputFile + let outputFile' = gifOutputFile outputFile + let (delay, colors, fuzz) = qualityAndFrameRateToGifSettings quality frameRate let params = - [ "-quiet" - , "-delay" - , delay - , tempDir ++ "/*." ++ frameFileExtension - ] - ++ annotate fontChoice maybeWidthHeight topText "north" - ++ annotate fontChoice maybeWidthHeight bottomText "south" - ++ [ "+dither" - , "-colors" - , show $ numberOfColors qualityPercent - , "-fuzz" - , "2%" - , "-layers" - , "OptimizeFrame" - , "-layers" - , "OptimizeTransparency" - , "-loop" - , "0" - , "+map" - , outputFile' - ] + [ "-quiet" + ] + ++ delay + ++ [ tempDir ++ "/extracted-frames_*." ++ frameFileExtension + , "+dither" + ] + ++ colors + ++ fuzz + ++ [ "-layers" + , "OptimizeFrame" + , "-layers" + , "OptimizeTransparency" + , "-loop" + , "0" + , "+map" + , outputFile' + ] putStrLn $ "[INFO] Saving your GIF to: " ++ outputFile' result <- try $ readProcess "convert" params [] if isLeft result then return result else return $ Right outputFile' -convertGifToVideo :: GifParams -> String -> IO (Either IOError String) -convertGifToVideo GifParams { outputFile } gifFilePath = do +mergeFramesIntoVideo :: GifParams -> String -> Float -> IO (Either IOError String) +mergeFramesIntoVideo GifParams { outputFile, quality } tempDir frameRate = do let outputFile' = videoOutputFile outputFile let params = [ "-nostats" , "-loglevel" , "error" , "-y" + , "-framerate" + , show frameRate + , "-start_number" + , "0" , "-i" - , gifFilePath + , tempDir ++ "/extracted-frames_%010d." ++ frameFileExtension , "-c:v" , "libvpx-vp9" + , "-crf" + , show $ targetQuality quality + , "-b:v" + , "0" , "-pix_fmt" - , "yuva420p" + , "yuv420p" , "-vf" , "scale=trunc(iw/2)*2:trunc(ih/2)*2" , "-an" @@ -602,169 +906,248 @@ convertGifToVideo GifParams { outputFile } gifFilePath = do if isLeft result then return result else return (Right outputFile') + where + targetQuality :: Quality -> Int + targetQuality QualityHigh = 15 + targetQuality QualityMedium = 34 + targetQuality QualityLow = 37 -qualityPercentClamp :: Float -> Float -qualityPercentClamp qualityPercent - | qualityPercent > 100.0 = 100.0 - | qualityPercent < 0.0 = 1.0 - | otherwise = qualityPercent - -numberOfColors :: Float -> Int -numberOfColors qualityPercent - | qualityPercentClamp qualityPercent <= 1.0 = 2 - | qualityPercentClamp qualityPercent >= 100.0 = floor maxColors - | otherwise = truncate $ (qualityPercent / 100.0) * maxColors +getVideoAverageFrameRateInSeconds :: GifParams -> IO (Maybe Float) +getVideoAverageFrameRateInSeconds GifParams { inputFile } = tryFfprobe params >>= result where - maxColors :: Float - maxColors = 256.0 - -annotate :: String -> Maybe (Int, Int) -> String -> String -> [String] -annotate _ _ "" _ = [] -annotate fontChoiceArg maybeWidthHeight text gravity = - [ "-gravity" - , gravity - ] - ++ 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 + result :: Either IOError String -> IO (Maybe Float) + result (Left _) = return Nothing + result (Right avgFrameRateString) = return $ processString avgFrameRateString + where + processString :: String -> Maybe Float + processString = + divideMaybeFloats . textsToMaybeFloats . filterNullTexts . splitText . cleanString + cleanString :: String -> Text + cleanString = Data.Text.strip . Data.Text.pack + splitText :: Text -> [Text] + splitText = Data.Text.split (== '/') + filterNullTexts :: [Text] -> [Text] + filterNullTexts = Data.List.filter (not . Data.Text.null) + textsToMaybeFloats :: [Text] -> [Maybe Float] + textsToMaybeFloats = + Data.List.filter isJust + . Data.List.map (\ s -> readMaybe (Data.Text.unpack s) :: Maybe Float) + divideMaybeFloats :: [Maybe Float] -> Maybe Float + divideMaybeFloats (Just n:Just d:_) = + if d <= 0 || n <= 0 then Nothing else Just $ n / d + divideMaybeFloats _ = Nothing + params :: [String] + params = + [ "-v" + , "error" + , "-select_streams" + , "v:0" + , "-show_entries" + , "stream=avg_frame_rate" + , "-of" + , "default=noprint_wrappers=1:nokey=1" + , inputFile ] + +tryFfprobe :: [String] -> IO (Either IOError String) +tryFfprobe = tryProcess "ffprobe" + +tryProcess :: String -> [String] -> IO (Either IOError String) +tryProcess process params = try $ readProcess process params [] + +qualityAndFrameRateToGifSettings :: Quality -> Float -> ([String], [String], [String]) +qualityAndFrameRateToGifSettings quality@QualityHigh frameRate = + ( ["-delay" + , qualityAndFrameRateToDelay quality frameRate + ] + , [ "-colors" + , show $ toInt $ 256.0 * 1.0 + ] + , [ "-fuzz" + , "1%" + ] + ) +qualityAndFrameRateToGifSettings quality@QualityMedium frameRate = + ( [ "-delay" + , qualityAndFrameRateToDelay quality frameRate + ] + , [ "-colors" + , show $ toInt $ 256.0 * 0.75 + ] + , [ "-fuzz" + , "2%" + ] + ) +qualityAndFrameRateToGifSettings quality@QualityLow frameRate = + ( [ "-delay" + , qualityAndFrameRateToDelay quality frameRate + ] + , [ "-colors" + , show $ toInt $ 256.0 * 0.5 + ] + , [ "-fuzz" + , "3%" + ] + ) + +qualityAndFrameRateToDelay :: Quality -> Float -> String +qualityAndFrameRateToDelay quality frameRate = + if delay <= 2 + then "2" + else show delay 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] + delay :: Int + delay = toInt $ 100.0 / qualityAndFrameRateToFrameRate quality frameRate + +qualityAndFrameRateToFrameRate :: Quality -> Float -> Float +qualityAndFrameRateToFrameRate QualityHigh frameRate = safeFrameRate $ 1.00 * frameRate +qualityAndFrameRateToFrameRate QualityMedium frameRate = safeFrameRate $ 0.75 * frameRate +qualityAndFrameRateToFrameRate QualityLow frameRate = safeFrameRate $ 0.50 * frameRate + +safeFrameRate :: Float -> Float +safeFrameRate frameRate + | frameRate <= defaultFrameRate = defaultFrameRate + | frameRate >= 50.0 = 50.0 + | otherwise = frameRate + +defaultFrameRate :: Float +defaultFrameRate = 15.0 + +fontFamilyArg :: [Text] -> String -> [String] +fontFamilyArg fontFamilies fontFamily = ["-family", fontFamily'] 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 font = ["-font", font] - -bestFontNameMatch :: String -> [Text] -> String -bestFontNameMatch _ [] = "default" -bestFontNameMatch _ [""] = "default" -bestFontNameMatch query fontNames = Data.Text.unpack $ bestMatch $ maximumMatch $ Data.Text.pack query + fontFamily' :: String + fontFamily' = findFontFamily fontFamilies fontFamily + +findFontFamily :: [Text] -> String -> String +findFontFamily fontFamilies fontFamily = + if hasFontFamily fontFamilies fontFamily + then fontFamily + else Data.Text.unpack $ getSansFontFamily fontFamilies + +hasFontFamily :: [Text] -> String -> Bool +hasFontFamily fontFamilies fontFamily = + Prelude.any ((== fontFamily') . Data.Text.toLower) fontFamilies 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 tempDir = - try (makeAbsolute tempDir) >>= tryListDir >>= maybeFirstFilePath + fontFamily' :: Data.Text.Text + fontFamily' = Data.Text.toLower $ Data.Text.pack fontFamily + +getSansFontFamily :: [Text] -> Text +getSansFontFamily fontFamilies + | notNull preferedFontFamily = preferedFontFamily + | notNull' sansFontFamilies = Prelude.head sansFontFamilies + | otherwise = "Sans" 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 + preferedFontFamily :: Text + preferedFontFamily = + Prelude.foldl + (\ xs x -> + if notNull xs + then xs + else + if contains "dejavu" x || + contains "ubuntu" x || + contains "droid" x || + contains "open" x || + contains "helvetica" x || + contains "arial" x + then x + else "" + ) + "" + sansFontFamilies + notNull' :: [Text] -> Bool + notNull' = Prelude.not . Prelude.null + notNull :: Text -> Bool + notNull = Prelude.not . Data.Text.null + contains :: Text -> Text -> Bool + contains h n = Data.Text.isInfixOf h $ Data.Text.toLower n + sansFontFamilies :: [Text] + sansFontFamilies = + Prelude.filter + (Data.Text.isInfixOf "sans" . Data.Text.toLower) + fontFamilies + +getFontFamilies :: IO [Text] +getFontFamilies = do + (_, stdout, _) <- readProcessWithExitCode "convert" ["-list", "font"] [] + let fontFamilies = + Prelude.map + (Data.Text.strip . Data.Text.drop 7 . Data.Text.strip) $ + Prelude.filter (Data.Text.isInfixOf "family:" . Data.Text.toLower) $ + Data.Text.splitOn "\n" $ + Data.Text.strip $ + Data.Text.pack stdout + return fontFamilies + +getFrameNumbers :: [String] -> Maybe [Int] +getFrameNumbers filePaths = + if Prelude.length frameNumbers == Prelude.length filePaths + then Just frameNumbers + else Nothing 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 + maybeFrameNumbers :: [Maybe Int] + maybeFrameNumbers = Prelude.map (getFrameNumber . System.FilePath.takeFileName) filePaths + frameNumbers :: [Int] + frameNumbers = Prelude.foldl folder [] maybeFrameNumbers 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 - -fontChoiceOrDefault :: GifParams -> String -fontChoiceOrDefault GifParams { fontChoice = fontName } = - if Data.List.null cleanedFontName - then defaultFontChoice - else cleanedFontName + folder :: [Int] -> Maybe Int -> [Int] + folder xs (Just int) = xs ++ [int] + folder xs Nothing = xs + +getFrameNumber :: String -> Maybe Int +getFrameNumber s = + readMaybe (parsedResult s) :: Maybe Int + where + parsedResult :: String -> String + parsedResult s' = + case readP_to_S parseFileName s' of + [(x, _)] -> x + _ -> "" + parseFileName :: ReadP String + parseFileName = do + _ <- string "extracted-frames_" + digits <- parseNumber + _ <- char '.' + return digits + +getRgb :: String -> Maybe (Int, Int, Int) +getRgb s = + case parsedResult s of + (r, g, b) -> + case (readMaybe' r, readMaybe' g, readMaybe' b) of + (Just r', Just g', Just b') -> Just (r', g', b') + _ -> Nothing + where + readMaybe' :: String -> Maybe Int + readMaybe' = readMaybe + parsedResult :: String -> (String, String, String) + parsedResult s' = + case readP_to_S parseRgb s' of + [((r,g,b), _)] -> (r, g, b) + _ -> ("", "", "") + parseRgb :: ReadP (String, String, String) + parseRgb = do + _ <- string "rgb(" + r <- parseNumber + _ <- char ',' + g <- parseNumber + _ <- char ',' + b <- parseNumber + _ <- char ')' + return (r, g, b) + +parseNumber :: ReadP String +parseNumber = many (satisfy isNumber) where - cleanedFontName :: String - cleanedFontName = (Data.Text.unpack . Data.Text.strip . Data.Text.pack) fontName + isNumber :: Char -> Bool + isNumber = flip elem numbers + numbers :: String + numbers = "0123456789" + +toInt :: Float -> Int +toInt = round + +stripAndLowerString :: String -> String +stripAndLowerString = + Data.Text.unpack . Data.Text.toLower . Data.Text.strip . Data.Text.pack diff --git a/stack.yaml b/stack.yaml index 104d6c8..613fd4c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,6 +5,7 @@ packages: explicit-setup-deps: ! '*': true extra-deps: + - gi-pango-1.0.15 - gi-gst-1.0.15 - gi-gtk-3.0.20 - gi-cairo-1.0.15