Ticket #1222: Main.hs

File Main.hs, 2.2 kB (added by guest, 4 years ago)

Example code illustrating the problem

Line 
1-----------------------------------------------------------------------------
2--
3-- Module      :  Main
4-- Copyright   :  Marc  Mertens
5-- License     :  AllRightsReserved
6--
7-- Maintainer  :  Marc Mertens
8-- Stability   :  Alpha
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
14
15module Main (main
16) where
17import Graphics.UI.Gtk
18import Graphics.Rendering.Cairo
19       (relMoveTo, moveTo, showText, Render, liftIO)
20import Graphics.UI.Gtk.Gdk.GC
21
22
23
24drawSingleCairo :: Int -> Int -> Int -> Render ()
25drawSingleCairo n minY maxY = do
26  if (n*30 < minY)
27    then drawSingleCairo (n+1) minY maxY
28    else if (maxY < (n-1)*30)
29            then return ()
30            else do
31                pc<-liftIO $ cairoCreateContext Nothing
32                moveTo 0 $ fromIntegral(n-1)*30
33                lay <- liftIO $ layoutText pc ("T'was brillig and the slithy toves (Jabberwocky) " ++ (show n))
34                -- liftIO $ layoutSetAttributes lay [AttrForeground 0 (-1) (Color 255 0 0)] -- Will be neglected
35                liftIO $ layoutSetAttributes lay [AttrBackground 0 (-1) (Color 255 0 0)]
36                showLayout lay
37                drawSingleCairo (n+1) minY maxY
38
39drawWindow :: DrawingArea -> Int -> IO ()
40drawWindow canvas n = do
41   area <- widgetGetDrawWindow canvas
42   region <- drawableGetVisibleRegion area
43   Rectangle x y w h <- regionGetClipbox region
44   renderWithDrawable area $ drawSingleCairo 0 y (y+h)
45   return ()
46
47drawWindowCairo :: IO ()
48drawWindowCairo = do
49  return ()
50main = do
51    let n = 10000000
52    initGUI
53    window <- windowNew
54    set window [windowTitle := "Color Test",
55                windowDefaultWidth := 800,
56                windowDefaultHeight := 800,
57                containerBorderWidth :=5]
58    frame <- frameNew
59    containerAdd window frame
60    scrolledWindow <- scrolledWindowNew Nothing Nothing
61    containerAdd frame scrolledWindow
62    canvas <- drawingAreaNew
63    scrolledWindowAddWithViewport scrolledWindow canvas
64
65    widgetSetSizeRequest canvas 800 (60 * n)
66
67    on canvas exposeEvent $ do
68        liftIO $ drawWindow canvas n
69        return True
70    widgetShowAll window
71    onDestroy window mainQuit
72    mainGUI