diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# Changelog for gtk-scaling-image + +## 0.1.0.0 + +- Initial release. +- Extract generic pixbuf scaling, CSS inset measurement, and draw-based + auto-fill image helpers from `taffybar` and `gtk-sni-tray`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Ivan Malison (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ivan Malison nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,12 @@ +# gtk-scaling-image + +`gtk-scaling-image` provides generic GTK image sizing helpers for Haskell GI +applications. It includes: + +- aspect-ratio-preserving pixbuf scaling to a target size +- CSS-aware border and padding measurement helpers +- a draw-based auto-fill image widget that scales to allocation without + `Gtk.Image` resize feedback loops + +This package was extracted from the shared image widget code used by +`taffybar` and `gtk-sni-tray`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/gtk-scaling-image.cabal b/gtk-scaling-image.cabal new file mode 100644 --- /dev/null +++ b/gtk-scaling-image.cabal @@ -0,0 +1,43 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.38.3. +-- +-- see: https://github.com/sol/hpack + +name: gtk-scaling-image +version: 0.1.0.0 +synopsis: Generic GTK image scaling helpers for haskell-gi +description: Please see the README on Github at +category: Graphics +homepage: https://github.com/taffybar/gtk-scaling-image#readme +bug-reports: https://github.com/taffybar/gtk-scaling-image/issues +author: Ivan Malison +maintainer: IvanMalison@gmail.com +copyright: Ivan Malison +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/taffybar/gtk-scaling-image + +library + exposed-modules: + Graphics.UI.GIGtkScalingImage + other-modules: + Paths_gtk_scaling_image + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , gi-cairo-connector ==0.1.* + , gi-cairo-render ==0.1.* + , gi-gdk3 ==3.0.* + , gi-gdkpixbuf >=2.0.16 && <2.1 + , gi-gtk3 ==3.0.* + , hslogger >=1.2 && <1.4 + default-language: Haskell2010 diff --git a/src/Graphics/UI/GIGtkScalingImage.hs b/src/Graphics/UI/GIGtkScalingImage.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GIGtkScalingImage.hs @@ -0,0 +1,331 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Graphics.UI.GIGtkScalingImage + ( BorderInfo (..), + borderInfoZero, + borderWidth, + borderHeight, + getBorderInfo, + getInsetInfo, + getContentAllocation, + scalePixbufToSize, + AutoFillCache (..), + fitPixbufToBox, + autoFillImage, + autoFillImageNew, + ) +where + +import qualified Control.Concurrent.MVar as MV +import Control.Monad +import Control.Monad.IO.Class +import Data.Int +import qualified GI.Cairo.Render as C +import GI.Cairo.Render.Connector (renderWithContext) +import qualified GI.Gdk as Gdk +import qualified GI.GdkPixbuf.Enums as GdkPixbuf +import GI.GdkPixbuf.Objects.Pixbuf as Gdk +import qualified GI.Gtk as Gtk +import System.Log.Logger +import Text.Printf + +imageLog :: Priority -> String -> IO () +imageLog = logM "Graphics.UI.GIGtkScalingImage" + +getScaledWidthHeight :: Bool -> Int32 -> Int32 -> Int32 -> (Int32, Int32) +getScaledWidthHeight shouldTargetWidth targetSize width height = + let getRatio :: Int32 -> Rational + getRatio toScale = + fromIntegral targetSize / fromIntegral toScale + getOther :: Int32 -> Int32 -> Int32 + getOther toScale other = max 1 $ floor $ getRatio toScale * fromIntegral other + in if shouldTargetWidth + then (targetSize, getOther width height) + else (getOther height width, targetSize) + +data BorderInfo = BorderInfo + { borderTop :: Int16, + borderBottom :: Int16, + borderLeft :: Int16, + borderRight :: Int16 + } + deriving (Eq, Show) + +borderInfoZero :: BorderInfo +borderInfoZero = BorderInfo 0 0 0 0 + +borderWidth :: BorderInfo -> Int16 +borderWidth borderInfo = borderLeft borderInfo + borderRight borderInfo + +borderHeight :: BorderInfo -> Int16 +borderHeight borderInfo = borderTop borderInfo + borderBottom borderInfo + +borderFunctions :: [Gtk.StyleContext -> [Gtk.StateFlags] -> IO Gtk.Border] +borderFunctions = + [ Gtk.styleContextGetPadding, + Gtk.styleContextGetMargin, + Gtk.styleContextGetBorder + ] + +insetFunctions :: [Gtk.StyleContext -> [Gtk.StateFlags] -> IO Gtk.Border] +insetFunctions = + [ Gtk.styleContextGetPadding, + Gtk.styleContextGetBorder + ] + +toBorderInfo :: (MonadIO m) => Gtk.Border -> m BorderInfo +toBorderInfo border = + BorderInfo + <$> Gtk.getBorderTop border + <*> Gtk.getBorderBottom border + <*> Gtk.getBorderLeft border + <*> Gtk.getBorderRight border + +addBorderInfo :: BorderInfo -> BorderInfo -> BorderInfo +addBorderInfo + (BorderInfo t1 b1 l1 r1) + (BorderInfo t2 b2 l2 r2) = + BorderInfo (t1 + t2) (b1 + b2) (l1 + l2) (r1 + r2) + +getBorderInfo :: (MonadIO m, Gtk.IsWidget a) => a -> m BorderInfo +getBorderInfo widget = liftIO $ do + stateFlags <- Gtk.widgetGetStateFlags widget + styleContext <- Gtk.widgetGetStyleContext widget + let getBorderInfoFor borderFn = + borderFn styleContext stateFlags >>= toBorderInfo + combineBorderInfo lastSum fn = + addBorderInfo lastSum <$> getBorderInfoFor fn + foldM combineBorderInfo borderInfoZero borderFunctions + +getInsetInfo :: (MonadIO m, Gtk.IsWidget a) => a -> m BorderInfo +getInsetInfo widget = liftIO $ do + stateFlags <- Gtk.widgetGetStateFlags widget + styleContext <- Gtk.widgetGetStyleContext widget + let getBorderInfoFor borderFn = + borderFn styleContext stateFlags >>= toBorderInfo + combineBorderInfo lastSum fn = + addBorderInfo lastSum <$> getBorderInfoFor fn + foldM combineBorderInfo borderInfoZero insetFunctions + +getContentAllocation :: + (MonadIO m, Gtk.IsWidget a) => + a -> + BorderInfo -> + m Gdk.Rectangle +getContentAllocation widget borderInfo = do + allocation <- Gtk.widgetGetAllocation widget + currentWidth <- Gdk.getRectangleWidth allocation + currentHeight <- Gdk.getRectangleHeight allocation + currentX <- Gdk.getRectangleX allocation + currentY <- Gdk.getRectangleY allocation + + Gdk.setRectangleWidth allocation $ + max 1 $ + currentWidth - fromIntegral (borderWidth borderInfo) + Gdk.setRectangleHeight allocation $ + max 1 $ + currentHeight - fromIntegral (borderHeight borderInfo) + Gdk.setRectangleX allocation $ + currentX + fromIntegral (borderLeft borderInfo) + Gdk.setRectangleY allocation $ + currentY + fromIntegral (borderTop borderInfo) + + pure allocation + +scalePixbufToSize :: Int32 -> Gtk.Orientation -> Gdk.Pixbuf -> IO Gdk.Pixbuf +scalePixbufToSize size orientation pixbuf = do + width <- Gdk.pixbufGetWidth pixbuf + height <- Gdk.pixbufGetHeight pixbuf + let warnAndReturnOrig = + imageLog WARNING "Unable to scale pixbuf" >> pure pixbuf + if size <= 0 + then pure pixbuf + else + if width <= 0 || height <= 0 + then warnAndReturnOrig + else do + let targetWidth = case orientation of + Gtk.OrientationHorizontal -> False + _ -> True + (scaledWidth, scaledHeight) = + getScaledWidthHeight targetWidth size width height + imageLog DEBUG $ + printf + "Scaling pb to %s, actualW: %s, actualH: %s, scaledW: %s, scaledH: %s" + (show size) + (show width) + (show height) + (show scaledWidth) + (show scaledHeight) + maybe + warnAndReturnOrig + pure + =<< Gdk.pixbufScaleSimple pixbuf scaledWidth scaledHeight GdkPixbuf.InterpTypeBilinear + +data AutoFillCache = AutoFillCache + { afRequestSize :: Int32, + afScaleFactor :: Int32, + afInsets :: BorderInfo, + afContentWidth :: Int32, + afContentHeight :: Int32, + afSourcePixbuf :: Maybe Gdk.Pixbuf, + afScaledPixbuf :: Maybe Gdk.Pixbuf, + afOffsetX :: Double, + afOffsetY :: Double + } + +fitPixbufToBox :: + Int32 -> + BorderInfo -> + Int32 -> + Int32 -> + Gdk.Pixbuf -> + IO (Int32, Int32, Double, Double, Maybe Gdk.Pixbuf) +fitPixbufToBox scaleFactor insets allocW allocH pixbuf = do + pbW' <- Gdk.getPixbufWidth pixbuf + pbH' <- Gdk.getPixbufHeight pixbuf + + let contentW = max 1 $ allocW - fromIntegral (borderWidth insets) + contentH = max 1 $ allocH - fromIntegral (borderHeight insets) + targetWDev = max 1 $ contentW * scaleFactor + targetHDev = max 1 $ contentH * scaleFactor + pbW = fromIntegral pbW' :: Double + pbH = fromIntegral pbH' :: Double + targetW = fromIntegral targetWDev :: Double + targetH = fromIntegral targetHDev :: Double + scale = + if pbW <= 0 || pbH <= 0 + then 1 + else min (targetW / pbW) (targetH / pbH) + drawWDev = max 1 $ floor (pbW * scale) + drawHDev = max 1 $ floor (pbH * scale) + drawWLogical = fromIntegral drawWDev / fromIntegral scaleFactor + drawHLogical = fromIntegral drawHDev / fromIntegral scaleFactor + leftInset = fromIntegral (borderLeft insets) :: Double + topInset = fromIntegral (borderTop insets) :: Double + offsetX = leftInset + (fromIntegral contentW - drawWLogical) / 2 + offsetY = topInset + (fromIntegral contentH - drawHLogical) / 2 + + scaledM <- Gdk.pixbufScaleSimple pixbuf drawWDev drawHDev GdkPixbuf.InterpTypeBilinear + pure (contentW, contentH, offsetX, offsetY, scaledM) + +autoFillImage :: + (MonadIO m) => + Gtk.DrawingArea -> + (Int32 -> IO (Maybe Gdk.Pixbuf)) -> + Gtk.Orientation -> + m (IO ()) +autoFillImage drawArea getPixbuf orientation = liftIO $ do + case orientation of + Gtk.OrientationHorizontal -> Gtk.widgetSetVexpand drawArea True + _ -> Gtk.widgetSetHexpand drawArea True + + Gtk.widgetSetSizeRequest drawArea 16 16 + + cacheVar <- + MV.newMVar + AutoFillCache + { afRequestSize = 0, + afScaleFactor = 1, + afInsets = borderInfoZero, + afContentWidth = 1, + afContentHeight = 1, + afSourcePixbuf = Nothing, + afScaledPixbuf = Nothing, + afOffsetX = 0, + afOffsetY = 0 + } + + let recompute force = do + allocation <- Gtk.widgetGetAllocation drawArea + allocW <- Gdk.getRectangleWidth allocation + allocH <- Gdk.getRectangleHeight allocation + insets <- getInsetInfo drawArea + scaleFactor <- Gtk.widgetGetScaleFactor drawArea + + let contentW = max 1 $ allocW - fromIntegral (borderWidth insets) + contentH = max 1 $ allocH - fromIntegral (borderHeight insets) + requestSize = + case orientation of + Gtk.OrientationHorizontal -> contentH + _ -> contentW + scaledFactor = max 1 scaleFactor + + Gtk.widgetSetSizeRequest + drawArea + (fromIntegral requestSize + fromIntegral (borderWidth insets)) + (fromIntegral requestSize + fromIntegral (borderHeight insets)) + + old <- MV.readMVar cacheVar + srcFresh <- + if force || requestSize /= afRequestSize old + then getPixbuf requestSize + else pure Nothing + + let src = maybe (afSourcePixbuf old) Just srcFresh + needsRefit = + force + || requestSize /= afRequestSize old + || scaledFactor /= afScaleFactor old + || insets /= afInsets old + || contentW /= afContentWidth old + || contentH /= afContentHeight old + + when needsRefit $ do + newCache <- + case src of + Nothing -> + pure + old + { afRequestSize = requestSize, + afScaleFactor = scaledFactor, + afInsets = insets, + afContentWidth = contentW, + afContentHeight = contentH, + afSourcePixbuf = Nothing, + afScaledPixbuf = Nothing, + afOffsetX = 0, + afOffsetY = 0 + } + Just pb -> do + (cw, ch, ox, oy, scaledM) <- + fitPixbufToBox scaledFactor insets allocW allocH pb + pure + old + { afRequestSize = requestSize, + afScaleFactor = scaledFactor, + afInsets = insets, + afContentWidth = cw, + afContentHeight = ch, + afSourcePixbuf = Just pb, + afScaledPixbuf = scaledM, + afOffsetX = ox, + afOffsetY = oy + } + + void $ MV.swapMVar cacheVar newCache + Gtk.widgetQueueDraw drawArea + + void $ Gtk.onWidgetSizeAllocate drawArea $ \_ -> recompute False + void $ Gtk.onWidgetStyleUpdated drawArea $ recompute True + + void $ Gtk.onWidgetDraw drawArea $ \ctx -> do + st <- MV.readMVar cacheVar + case afScaledPixbuf st of + Nothing -> pure True + Just pb -> do + Gdk.cairoSetSourcePixbuf ctx pb (afOffsetX st) (afOffsetY st) + renderWithContext C.paint ctx + pure True + + pure $ recompute True + +autoFillImageNew :: + (MonadIO m) => + (Int32 -> IO (Maybe Gdk.Pixbuf)) -> + Gtk.Orientation -> + m Gtk.DrawingArea +autoFillImageNew getPixbuf orientation = do + drawArea <- Gtk.drawingAreaNew + void $ autoFillImage drawArea getPixbuf orientation + pure drawArea