[Question] Is it possible to save the current view as an image?
Closed this issue · 10 comments
I have to print some stuff that's shown in the app. Having to use a different library to create an image for printing, not to mention fiddling with layout, it's not easy. At least, I don't know of a simple way to do that. As Monomer provides all the needed things for this, it would make things really easy to print custom-layout stuff.
Because Monomer is using SDL and I guess rendering to a screen is not coupled with rendering itself [1], it seems doable to save a view to an image?
[1] I haven't used SDL, so I maybe wrong.
I think capturing the screen content should be possible, but I can't find anything confirming it (what I found only mentions SDL surfaces, not OpenGL ones). I'll take a deeper look and let you know.
Beyond this, it is possible to implement a custom Renderer, and I remember Cairo even allows saving to pdf. Of course, implementing this is a lot of effort.
A quick search gave some possible ways to convert OpenGL buffer to image. I don't know how many of them actually works though. I have also seen a similiar option in Tecgraf's IM library [1].
[1] https://www.tecgraf.puc-rio.br/im/en/guide.html#opengl
Edit: Maybe helpful:
Here's a possible solution. This shows the standard monomer-starter application, with an extra button to trigger a screen capture. The ImageCapture takes care of getting the screen contents and passing it to the application as an event, and the application takes this data and saves it as an image. The image flipping is needed because of how OpenGL returns the information.
I won't include this as part of the library for the moment since it's too tied to OpenGL, and it's most likely a source of compatibility issues. I will add it to Recipes whenever I get around to creating that section.
Starting from the monomer-starter project, you need to add/replace these files:
package.yaml
name: monomer-starter
version: 0.1.0.0
#synopsis:
#description:
homepage: https://github.com/githubuser/monomer-starter#readme
license: BSD3
author: Author name here
maintainer: example@example.com
copyright: 2021 Author name here
#category:
extra-source-files:
- README.md
default-extensions:
- OverloadedStrings
dependencies:
- base >= 4.7 && < 5
- bytestring >= 0.10 && < 0.12
- containers >= 0.5.11 && < 0.7
- data-default
- JuicyPixels >= 3.2.9 && < 3.5
- JuicyPixels-extra >= 0.5.2
- lens
- monomer
- OpenGLRaw >= 3.3 && < 3.4
- stm >= 2.5 && < 2.6
- text
- text-show
executables:
app:
source-dirs: src
main: Main.hs
ghc-options:
- -fwarn-incomplete-patterns
- -threadedMain.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Main where
import Control.Lens
import Data.ByteString (ByteString)
import Foreign (newForeignPtr_, castForeignPtr)
import Monomer
import TextShow
import qualified Codec.Picture as CP
import qualified Codec.Picture.Extra as CPE
import qualified Data.ByteString as BS
import ImageCapture
import qualified Monomer.Lens as L
newtype AppModel = AppModel {
_clickCount :: Int
} deriving (Eq, Show)
data AppEvent
= AppIgnore
| AppIncrease
| AppCaptureImage
| OnCaptureImage Int Int ByteString
deriving (Eq, Show)
makeLenses 'AppModel
buildUI
:: WidgetEnv AppModel AppEvent
-> AppModel
-> WidgetNode AppModel AppEvent
buildUI wenv model = widgetTree where
content = vstack [
label "Hello world",
spacer,
hstack [
label $ "Click count: " <> showt (model ^. clickCount),
spacer,
button "Increase count" AppIncrease,
spacer,
button "Capture image" AppCaptureImage
]
] `styleBasic` [padding 10]
widgetTree = imageCapture_ [onCapture OnCaptureImage] content
`nodeKey` "imageCapture"
handleEvent
:: WidgetEnv AppModel AppEvent
-> WidgetNode AppModel AppEvent
-> AppModel
-> AppEvent
-> [AppEventResponse AppModel AppEvent]
handleEvent wenv node model evt = case evt of
AppIgnore -> []
AppIncrease -> [Model (model & clickCount +~ 1)]
AppCaptureImage -> [
Message "imageCapture" ImageCaptureNextFrame
]
OnCaptureImage w h img -> [
Task $ do
BS.useAsCStringLen img $ \(ptr, len) -> do
fptr <- newForeignPtr_ ptr
let dimg = CP.imageFromUnsafePtr w h (castForeignPtr fptr)
let flipped = CPE.flipVertically dimg
CP.saveBmpImage "test.bmp" (CP.ImageRGBA8 flipped)
return AppIgnore
]
main :: IO ()
main = do
startApp model handleEvent buildUI config
where
config = [
appWindowTitle "Hello world",
appWindowIcon "./assets/images/icon.bmp",
appTheme darkTheme,
appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf"
]
model = AppModel 0ImageCapture.hs
{-# LANGUAGE FlexibleContexts #-}
{-|
Allows capturing the contents of the screen. It is recommended that it wraps the
top-level widget, so all rendering operations are reflected in the provided
event.
The capture process requires sending a message to the widget, and providing an
event where the captured data will be sent.
@
buildUI wenv model = widgetTree where
content = label "Test"
widgetTree = imageCapture_ [onCapture OnCaptureImage] content
`nodeKey` "imageCapture"
handleEvent wenv node model evt = case evt of
OnCaptureImage w h img -> [ ... ]
@
See comments in 'renderAfter' for implementation details.
-}
module ImageCapture (
ImageCaptureMsg(ImageCaptureNextFrame),
onCapture,
imageCapture,
imageCapture_
) where
import Control.Concurrent.STM.TQueue
import Control.Lens
import Control.Monad (forM_, when)
import Control.Monad.STM (atomically)
import Data.ByteString (ByteString)
import Data.Default
import Data.Maybe
import Data.Typeable
import Graphics.GL
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BSI
import qualified Data.ByteString.Unsafe as BSU
import qualified Data.Sequence as Seq
import Monomer.Widgets.Container
import qualified Monomer.Lens as L
newtype ImageCaptureCfg s e = ImageCaptureCfg {
_iccOnCaptureReq :: [Int -> Int -> ByteString -> WidgetRequest s e]
}
instance Default (ImageCaptureCfg s e) where
def = ImageCaptureCfg {
_iccOnCaptureReq = []
}
instance Semigroup (ImageCaptureCfg s e) where
(<>) t1 t2 = ImageCaptureCfg {
_iccOnCaptureReq = _iccOnCaptureReq t1 <> _iccOnCaptureReq t2
}
instance Monoid (ImageCaptureCfg s e) where
mempty = def
data ImageCaptureMsg
= ImageCaptureInit (TQueue (Int, Int, ByteString))
| ImageCaptureNextFrame
| ImageCaptureReport Int Int ByteString
deriving (Eq)
data ImageCaptureState = ImageCaptureState {
_icsTs :: Millisecond,
_icsQueue :: Maybe (TQueue (Int, Int, ByteString))
} deriving (Eq)
onCapture :: WidgetEvent e => (Int -> Int -> ByteString -> e) -> ImageCaptureCfg s e
onCapture fn = def {
_iccOnCaptureReq = [((RaiseEvent .) .) . fn]
}
imageCapture :: WidgetNode s e -> WidgetNode s e
imageCapture = imageCapture_ []
imageCapture_ :: [ImageCaptureCfg s e] -> WidgetNode s e -> WidgetNode s e
imageCapture_ configs managedWidget = newNode where
config = mconcat configs
state = ImageCaptureState 0 Nothing
widget = makeImageCapture config state
newNode = defaultWidgetNode "imageCapture" widget
& L.info . L.focusable .~ False
& L.children .~ Seq.singleton managedWidget
makeImageCapture :: ImageCaptureCfg s e -> ImageCaptureState -> Widget s e
makeImageCapture config state = widget where
widget = createContainer state def {
containerInit = init,
containerMerge = merge,
containerHandleMessage = handleMessage,
containerRenderAfter = renderAfter
}
init wenv node = result where
widgetId = node ^. L.info . L.widgetId
path = node ^. L.info . L.path
createQueue = ImageCaptureInit <$> newTQueueIO
result = resultReqs node [ RunTask widgetId path createQueue ]
merge wenv node oldNode oldState = result where
newNode = node
& L.widget .~ makeImageCapture config oldState
result = resultNode newNode
handleMessage wenv node target message = result where
result = cast message >>= handleCaptureMsg
handleCaptureMsg (ImageCaptureInit queue) = Just result where
newState = state {
_icsQueue = Just queue
}
newNode = node
& L.widget .~ makeImageCapture config newState
result = resultNode newNode
handleCaptureMsg ImageCaptureNextFrame = Just result where
widgetId = node ^. L.info . L.widgetId
path = node ^. L.info . L.path
waitImg = do
-- Waits for the rendering process to send a message
(w, h, image) <- atomically . readTQueue . fromJust $ _icsQueue state
return $ ImageCaptureReport w h image
newState = state {
_icsTs = wenv ^. L.timestamp
}
newNode = node
& L.widget .~ makeImageCapture config newState
reqs = [ RunTask widgetId path waitImg, RenderOnce ]
result = resultReqs newNode reqs
handleCaptureMsg (ImageCaptureReport w h image) = Just result where
reqs = fmap (\fn -> fn w h image) (_iccOnCaptureReq config)
result = resultReqs node reqs
{-
The 'renderAfter' function is called by a Container after all its children
have finished rendering.
Since 'widgetRender' works in 'MonadIO' and does not return a 'WidgetResult',
a channel is used to send the information to a Task created previously. This
task takes care of sending data to clients and updating internal state when
needed using a 'WidgetResult', as is used in most common use cases.
-}
renderAfter wenv node renderer = do
forM_ mqueue $ \queue -> do
when (wenv ^. L.timestamp == ts) $ do
-- This is the last rendering operation type to run in each frame
createRawOverlay renderer $ do
bs <- BSI.create (fbw * fbh * 4) (const $ return ())
BSU.unsafeUseAsCStringLen bs $ \(ptr, len) -> do
glReadBuffer GL_FRONT
glReadPixels 0 0 (fromIntegral fbw) (fromIntegral fbh) GL_RGBA GL_UNSIGNED_BYTE ptr
atomically $ writeTQueue queue (fbw, fbh, bs)
where
Size ww wh = wenv ^. L.windowSize
dpr = wenv ^. L.dpr
(fbw, fbh) = (round $ dpr * ww, round $ dpr * wh)
ts = _icsTs state
mqueue = _icsQueue state
Thanks a lot for looking into this! I really appreciate it! :-)
I am getting this error when running:
app: SDLCallFailed {sdlExceptionCaller = "SDL.Video.loadBMP", sdlFunction = "SDL_LoadBMP", sdlExceptionError = "Parameter 'src' is invalid"}
stack.yaml:
resolver:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/9.yaml
packages:
- .
extra-deps:
- nanovg-0.8.0.0@sha256:0183b4295ccc2dfb94a7eca977fb45759e1480652578936aa7b71bb4b9626480,4742
- /path/to/monomer-repo
# Override default flag values for local packages and extra-deps
flags:
nanovg:
stb_truetype: true
I'm using lts-18.27; I haven't had time to upgrade to a newer LTS yet.
When I tried updating to a nightly, I got a bunch of version errors and gave up. I'll wait until a stable LTS for GHC 9.2.2 comes out.
Extra note: I'm not using that SDL.Video.loadBMP function. Is it possible that it's because of the SDL binary version you have installed?
I'm using
lts-18.27; I haven't had time to upgrade to a newer LTS yet.
I will try this.
Extra note: I'm not using that
SDL.Video.loadBMPfunction. Is it possible that it's because of the SDL binary version you have installed?
The sdl2 package in lts-18.27 mentions 2.0.6+ as supported version.
The installed version is 2.0.22.
Which version do you use?
I won't include this as part of the library for the moment since it's too tied to OpenGL, and it's most likely a source of compatibility issues. I will add it to Recipes whenever I get around to creating that section.
Maybe you could create a monomer-contrib repo (similiar to XMonad's contrib + extras)? This could also be used for widgets built upon widgets in this repo, which won't be included here, but are useful nonetheless.
Using lts-18.27 didn't work. Getting same error. I guess this has to do with SDL version.
I'm wondering if it's because of this:
appWindowIcon "./assets/images/icon.bmp",If you don't have that file, you may need to remove the line.
I'm wondering if it's because of this:
appWindowIcon "./assets/images/icon.bmp",If you don't have that file, you may need to remove the line.
You're right! Sorry!
It's working! Once again, thanks a lot! I am closing this as resolved. :-)