Форум программистов, компьютерный форум, киберфорум
Наши страницы
KolodeznyDiver
Войти
Регистрация
Восстановить пароль
Оценить эту запись

GUI-SDL2 – GUI написанный на Haskell. Часть 5.2. Делаем свой виджет

Запись от KolodeznyDiver размещена 07.07.2018 в 21:59
Обновил(-а) KolodeznyDiver 08.07.2018 в 10:19

В предыдущей теме мы сделали виджет отслеживающий перемещение мыши. Сейчас я предлагаю сохранить вариант предыдущей темы для истории, и скопировать весь каталог 5.1.CustomWidget под именем 5.2.CustomWidget где и дополнить наш виджет возможностями изменения его свойств после создания, а так же установки обработчиков событий виджета.

Внимание: вначале обновите у себя версию GUI-SDL2 до последней - 0.1.22. (На прошлом занятии была ещё 0.1.21.)

В package.yaml добавляем
Haskell
1
2
3
4
5
  5.2.CustomWidget:    
    source-dirs:      5.2.CustomWidget
    main:             Main.hs
    dependencies:
    - text-show
Открываем 5.2.CustomWidget/GUI/Widget/MouseWatcher.hs.

Вначале добавим изменяемое свойство. Допустим нам понадобилось менять цвет надписи отображаемой в виджете.
В файле GUI.Widget.Types пакета GUI-SDL2 имеется подходящий класс
Haskell
1
2
3
4
-- | Для экземпляров этого класса типов можно назначить установку и извлечение некоего цвета.
class TextColorProperty a where
    setTextColor :: MonadIO m => a -> GuiColor -> m ()
    getTextColor :: MonadIO m => a -> m GuiColor
Если нам нужны другие имена функций, для изменения и извлечения некоего динамически меняющегося свойства, то мы можем легко сделать похожий тип по аналогии.
Мало того, функциям установки и извлечения динамического значения из виджета не обязательно входить в состав класса типов. Это делается только для того, что бы разными типами виджетов можно было управлять функциями с одинаковыми именами (перегруженные функции). Если у вас какой то, весьма специфический параметр, с уникальным именем, например, мы хотим изменять размер крестика который бегает за указателем мыши. Тогда функция изменения его размера может выглядеть просто как
Haskell
1
setCrossSize :: MonadIO m => GuiWidget MouseWatcherData -> Coord -> m ()
Динамически изменяемые (или извлекаемые из виджета) параметры, доступные извне виджета, должны как то быть представлены в типе данных виджета (MouseWatcherData). Самый очевидный способ – добавить туда поле со ссылкой на эти данные
Haskell
1
data MouseWatcherData = MouseWatcherData    { rfTextColor :: IORef GuiColor }
тогда экземпляр TextColorProperty для нашего виджета реализуется просто
Haskell
1
2
3
4
5
6
7
8
instance TextColorProperty (GuiWidget MouseWatcherData) where
    setTextColor widget color = do
        let rf = rfTextColor $ widgetData widget
        oldC <- readMonadIORef rf
        when (oldC /= color) $ do
            writeMonadIORef rf color
            markWidgetForRedraw $ baseWidget widget
    getTextColor widget = readMonadIORef $ rfTextColor $ widgetData $ widget
Если уж мы собираемся менять параметр, то логично (но не обязательно) сделать его настраиваемым и при создании виджета. То есть добавим поле mouseWatcherTextColor в MouseWatcherDef и неким образом его инициализируем
Haskell
1
2
3
4
5
6
7
8
9
10
11
12
13
14
-- | Параметры настройки виджета @mouseWatcher@.
data MouseWatcherDef = MouseWatcherDef {
    mouseWatcherFormItemDef  :: FormItemWidgetDef -- ^ Общие настройки для всех виджетов для форм
  , mouseWatcherSize      :: GuiSize -- ^ размер без полей.
  , mouseWatcherFlags     :: WidgetFlags -- ^ Флаги базового виджета.
  , mouseWatcherTextColor :: GuiColor
                                       }
 
instance Default MouseWatcherDef where
    def = MouseWatcherDef   { mouseWatcherFormItemDef = def
                            , mouseWatcherSize = zero
                            , mouseWatcherFlags = WidgetVisible .|. WidgetEnable 
                            , mouseWatcherTextColor = grayColor 255
                            }
grayColor 255 то же что rgb 255 255 255, и то же что V4 255 255 255 0.

Можно было бы сделать цвет текста по умолчанию зависящий от какого то цвета в текущем Skin. Тогда бы тип поля был бы Maybe GuiColor, а значение по умолчанию Nothing. Тогда бы в начале виджета можно было установить начальный цвет или непосредственно из mouseWatcherTextColor, если его значение Just …, или взять из Skin. Но, не будем усложнять.

В начале функции mouseWatcher мы добавляем
Haskell
1
    rfTC <- newMonadIORef mouseWatcherTextColor
А в вызове mkFormWidget вместо аргумента MouseWatcherData запишем (MouseWatcherData rfTC).
Остаётся только извлекать текущее значение цвета при отрисовке. Строку с drawText заменим на
Haskell
1
2
            tc <- readMonadIORef rfTC
            drawText fnt tc (P (V2 5 5)) s
И в самом начале файла добавим
Haskell
1
{-# LANGUAGE FlexibleInstances #-}
Полный текст MouseWatcher.hs
Haskell
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module GUI.Widget.MouseWatcher(
    MouseWatcherData,MouseWatcherDef(..)
    ,mouseWatcher
    ) where
 
import Control.Monad
import Control.Monad.IO.Class
import Data.Bits
import Data.IORef
import Data.Maybe
import Data.Monoid
import qualified TextShow as TS
import TextShow (showb)
import qualified SDL
import SDL.Vect
import Data.Default
import GUI
import GUI.Widget.Handlers
 
data MouseWatcherData = MouseWatcherData    { rfTextColor :: IORef GuiColor }
                                              
 
-- | Параметры настройки виджета @mouseWatcher@.
data MouseWatcherDef = MouseWatcherDef {
    mouseWatcherFormItemDef  :: FormItemWidgetDef -- ^ Общие настройки для всех виджетов для форм
  , mouseWatcherSize      :: GuiSize -- ^ размер без полей.
  , mouseWatcherFlags     :: WidgetFlags -- ^ Флаги базового виджета.
  , mouseWatcherTextColor :: GuiColor -- ^ начальный размер текста.
                                       }
 
instance Default MouseWatcherDef where
    def = MouseWatcherDef   { mouseWatcherFormItemDef = def
                            , mouseWatcherSize = zero
                            , mouseWatcherFlags = WidgetVisible .|. WidgetEnable 
                            , mouseWatcherTextColor = grayColor 255
                            }
 
instance TextColorProperty (GuiWidget MouseWatcherData) where
    setTextColor widget color = do
        let rf = rfTextColor $ widgetData widget
        oldC <- readMonadIORef rf
        when (oldC /= color) $ do
            writeMonadIORef rf color
            markWidgetForRedraw $ baseWidget widget
    getTextColor widget = readMonadIORef $ rfTextColor $ widgetData $ widget
 
                            
                            
-- | Создание виджета @mouseWatcher@.
mouseWatcher :: MonadIO m =>
                 MouseWatcherDef ->  -- ^ Параметры виджета.
                 Widget ->  -- ^ Будующий предок в дереве виджетов.
                 Skin -> -- ^ Skin.
                 m (GuiWidget MouseWatcherData)
mouseWatcher MouseWatcherDef{..} parent skin = do
    rfTC <- newMonadIORef mouseWatcherTextColor
    rfState <- newMonadIORef Nothing
    mkFormWidget mouseWatcherFormItemDef mouseWatcherFlags skin id
            (MouseWatcherData rfTC) parent (noChildrenFns mouseWatcherSize){
        onGainedMouseFocus = \widget pnt -> do
            writeMonadIORef rfState $ Just pnt
            markWidgetForRedraw widget
        ,onMouseMotion = \widget _btnsLst pnt _relMv -> do
            writeMonadIORef rfState $ Just pnt
            markWidgetForRedraw widget
        ,onLostMouseFocus = \widget -> do
            writeMonadIORef rfState Nothing 
            markWidgetForRedraw widget
        ,onDraw= \widget -> do
            rectAll <- getWidgetCanvasRect widget
            setColor $ grayColor 100
            fillRect rectAll
            fnt <- getFont "label"
            state <- readMonadIORef rfState
            s <- case state of
                Just p@(P (V2 x y)) -> do
                    setColor $ grayColor 255
                    let crossSz = 10
                    drawLine (p .-^ V2 crossSz 0) (p .+^ V2 crossSz 0)
                    drawLine (p .-^ V2 0 crossSz) (p .+^ V2 0 crossSz)
                    return $ TS.toText $ showb x <> "x" <> showb y
                _ -> return "No mouse"
            tc <- readMonadIORef rfTC
            drawText fnt tc (P (V2 5 5)) s
                                                                         }

Теперь вернёмся к Main.hs. Так как виджета задания цвета в GUI-SDL2 пока ещё нет, я буду использовать три трекбара на каждый компонент цвета.
Я не демонстрировал ещё в этом блоге трекбары, вот, заодно и продемонстрирую.
Main.hs
Haskell
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
{-# LANGUAGE OverloadedStrings #-}
module Main where
 
import Control.Monad
import Data.Default
import qualified SDL
import GUI
import GUI.Skin.DefaultSkin
import GUI.Widget.Layout.LinearLayout
import SDL.Vect
import GUI.Widget.MouseWatcher
import GUI.Widget.LinearTrackBar
import Control.Applicative
 
main :: IO ()
main = runGUI defSkin  -- Запуск GUI с оформлением по умолчанию
 
        -- Список предзагруженных шрифтов : ключ, имя файла, размер шрифта, опции
        [GuiFontDef "label"       "PTN57F.ttf" 15 def
        ] 
        def $ \gui -> do
    win <- newWindow gui "5.2.CustomWidget" SDL.defaultWindow{SDL.windowInitialSize  = V2 400 400}
    vL <- win $+ vLayout def
    hL <- vL $+ hLayout def
    mw <- hL $+ mouseWatcher def{mouseWatcherSize= V2 (-1) (-1)}
    V4 initR initG initB _initAlpha <- getTextColor mw 
    let addColorTB color initV = hL $+ vTrackBar' def{
              linearTrackBarFormItemDef = def{formItemMargin=Just $ WidgetMarginXY 3 5}
            , linearTrackMaxValue = 255
            , linearTrackBarPos = 255 - fromIntegral initV  
            , linearTrackBarSliderLn = 0.04
                                                    }  $ \d -> 
                d{ linearTrackBarSliderDraw = \ w mSt r -> do
                        linearTrackBarSliderDraw d w mSt r
                        setColor color 
                        fillRect $ shrinkRect' 3 r
                 }
                 
        setMWColor fr fg fb = do
            let component = (((255 -).fromIntegral) <$>) 
            color <- rgb <$> (component fr) <*> (component fg) <*> (component fb)
            setTextColor mw color 
    tbR <- addColorTB (rgb 255 0 0) initR
    tbG <- addColorTB (rgb 0 255 0) initG
    tbB <- addColorTB (rgb 0 0 255) initB
    
    onChanged tbR $ \v -> setMWColor (return v)     (getValue tbG) (getValue tbB)
    onChanged tbG $ \v -> setMWColor (getValue tbR) (return v)     (getValue tbB)  
    onChanged tbB $ \v -> setMWColor (getValue tbR) (getValue tbG) (return v)

Всё должно быть понятно из прошлых тем и базового знания Haskell.

В GUI-SDL2 есть самые простые функции создания горизонтального и вертикального трекбаров - hTrackBar,vTrackBar. С апострофом в конце - vTrackBar' отличается дополнительным аргументом – функцией, позволяющей дополнить отрисовку полосы и/или слайдера трекбара. См. фрагмент кода
Haskell
1
2
3
4
5
                d{ linearTrackBarSliderDraw = \ w mSt r -> do
                        linearTrackBarSliderDraw d w mSt r
                        setColor color 
                        fillRect $ shrinkRect' 3 r
                 }
- здесь вначале вызывается функция отрисовки которая была установлена внутри vTrackBar', а затем, сверху рисуется ещё и квадратик показывающий каким цветом какой трекбар управляет.

Можно проверить как это работает
Bash
1
stack build --exec 5.2.CustomWidget
Нажмите на изображение для увеличения
Название: 5.2.CustomWidget.png
Просмотров: 41
Размер:	18.8 Кб
ID:	4911

Теперь, давайте сделаем ранее упомянутую возможность изменения размера крестика который следит за мышью. Но сделаем это другим способом.

Во первых, будем использовать функцию – не член класса.
Во вторых (а это с первым не связано), в MouseWatcherData добавим не ссылку на размер крестика, а функцию которая сделает всё что надо.
Haskell
1
2
3
4
data MouseWatcherData = MouseWatcherData
        { rfTextColor :: IORef GuiColor 
        , setCrossSz  :: forall m. MonadIO m => Coord -> m ()
        }
Функцию которую запишем в последнее поле определим локально внутри mouseWatcher.
Для использования forall понадобится добавить прагму
Haskell
1
{-# LANGUAGE RankNTypes #-}
К тому же, в отличии от реализаций instance, функцию – не член класса типа придётся указать в экспорте.
Сравните изменения
MouseWatcher.hs
Haskell
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module GUI.Widget.MouseWatcher(
    MouseWatcherData,MouseWatcherDef(..)
    ,setCrossSize,mouseWatcher
    ) where
 
import Control.Monad
import Control.Monad.IO.Class
import Data.Bits
import Data.IORef
import Data.Maybe
import Data.Monoid
import qualified TextShow as TS
import TextShow (showb)
import qualified SDL
import SDL.Vect
import Data.Default
import GUI
import GUI.Widget.Handlers
 
data MouseWatcherData = MouseWatcherData
        { rfTextColor :: IORef GuiColor 
        , setCrossSz  :: forall m. MonadIO m => Widget -> Coord -> m ()
        }
                                              
 
-- | Параметры настройки виджета @mouseWatcher@.
data MouseWatcherDef = MouseWatcherDef {
    mouseWatcherFormItemDef  :: FormItemWidgetDef -- ^ Общие настройки для всех виджетов для форм
  , mouseWatcherSize      :: GuiSize -- ^ размер без полей.
  , mouseWatcherFlags     :: WidgetFlags -- ^ Флаги базового виджета.
  , mouseWatcherTextColor :: GuiColor -- ^ начальный размер текста.
  , mouseWatcherCrossSize :: Coord  -- ^ Начальный размер (радиус) крестика.
                                       }
 
instance Default MouseWatcherDef where
    def = MouseWatcherDef   { mouseWatcherFormItemDef = def
                            , mouseWatcherSize = zero
                            , mouseWatcherFlags = WidgetVisible .|. WidgetEnable 
                            , mouseWatcherTextColor = grayColor 255
                            , mouseWatcherCrossSize = 10
                            }
 
instance TextColorProperty (GuiWidget MouseWatcherData) where
    setTextColor widget color = do
        let rf = rfTextColor $ widgetData widget
        oldC <- readMonadIORef rf
        when (oldC /= color) $ do
            writeMonadIORef rf color
            markWidgetForRedraw $ baseWidget widget
    getTextColor widget = readMonadIORef $ rfTextColor $ widgetData $ widget
 
setCrossSize :: MonadIO m => GuiWidget MouseWatcherData -> Coord -> m ()
setCrossSize widget sz = setCrossSz (widgetData widget) (baseWidget widget) sz
                            
-- | Создание виджета @mouseWatcher@.
mouseWatcher :: MonadIO m =>
                 MouseWatcherDef ->  -- ^ Параметры виджета.
                 Widget ->  -- ^ Будующий предок в дереве виджетов.
                 Skin -> -- ^ Skin.
                 m (GuiWidget MouseWatcherData)
mouseWatcher MouseWatcherDef{..} parent skin = do
    rfTC <- newMonadIORef mouseWatcherTextColor
    rfState <- newMonadIORef Nothing
    rfCrossSize <- newMonadIORef mouseWatcherCrossSize
    let setCrossSize' w newSz = do
            oldSz <- readMonadIORef rfCrossSize
            when (newSz /= oldSz) $ do
                writeMonadIORef rfCrossSize newSz
                markWidgetForRedraw w
    mkFormWidget mouseWatcherFormItemDef mouseWatcherFlags skin id
            (MouseWatcherData rfTC setCrossSize') parent 
            (noChildrenFns mouseWatcherSize){
        onGainedMouseFocus = \widget pnt -> do
            writeMonadIORef rfState $ Just pnt
            markWidgetForRedraw widget
        ,onMouseMotion = \widget _btnsLst pnt _relMv -> do
            writeMonadIORef rfState $ Just pnt
            markWidgetForRedraw widget
        ,onLostMouseFocus = \widget -> do
            writeMonadIORef rfState Nothing 
            markWidgetForRedraw widget
        ,onDraw= \widget -> do
            rectAll <- getWidgetCanvasRect widget
            setColor $ grayColor 100
            fillRect rectAll
            fnt <- getFont "label"
            state <- readMonadIORef rfState
            s <- case state of
                Just p@(P (V2 x y)) -> do
                    setColor $ grayColor 255
                    crossSz <- readMonadIORef rfCrossSize
                    drawLine (p .-^ V2 crossSz 0) (p .+^ V2 crossSz 0)
                    drawLine (p .-^ V2 0 crossSz) (p .+^ V2 0 crossSz)
                    return $ TS.toText $ showb x <> "x" <> showb y
                _ -> return "No mouse"
            tc <- readMonadIORef rfTC
            drawText fnt tc (P (V2 5 5)) s
            
                                                                    }

Вернёмся к Main.hs, к демонстрации использования виджета.
Для имзменения размера крекстика я использую горизонтальный трекбар, более простую функцию без апострофа на конце и без пользовательской отрисовки.
Main.hs
Haskell
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
{-# LANGUAGE OverloadedStrings #-}
module Main where
 
import Control.Monad
import Data.Default
import qualified SDL
import GUI
import GUI.Skin.DefaultSkin
import GUI.Widget.Label
import GUI.Widget.Layout.LinearLayout
import SDL.Vect
import GUI.Widget.MouseWatcher
import GUI.Widget.LinearTrackBar
import Control.Applicative
 
main :: IO ()
main = runGUI defSkin  -- Запуск GUI с оформлением по умолчанию
 
        -- Список предзагруженных шрифтов : ключ, имя файла, размер шрифта, опции
        [GuiFontDef "label"       "PTN57F.ttf" 15 def
        ] 
        def $ \gui -> do
    win <- newWindow gui "5.2.CustomWidget" SDL.defaultWindow{SDL.windowInitialSize  = V2 400 400}
    vL <- win $+ vLayout def
    hL <- vL $+ hLayout def
    mw <- hL $+ mouseWatcher def{mouseWatcherSize= V2 (-1) (-1)}
    V4 initR initG initB _initAlpha <- getTextColor mw 
    let addColorTB color initV = hL $+ vTrackBar' def{
              linearTrackBarFormItemDef = def{formItemMargin=Just $ WidgetMarginXY 3 5}
            , linearTrackMaxValue = 255
            , linearTrackBarPos = 255 - fromIntegral initV  
            , linearTrackBarSliderLn = 0.04
                                                    }  $ \d -> 
                d{ linearTrackBarSliderDraw = \ w mSt r -> do
                        linearTrackBarSliderDraw d w mSt r
                        setColor color 
                        fillRect $ shrinkRect' 3 r
                 }
                 
        setMWColor fr fg fb = do
            let component = (((255 -).fromIntegral) <$>) 
            color <- rgb <$> (component fr) <*> (component fg) <*> (component fb)
            setTextColor mw color 
    tbR <- addColorTB (rgb 255 0 0) initR
    tbG <- addColorTB (rgb 0 255 0) initG
    tbB <- addColorTB (rgb 0 0 255) initB
    
    onChanged tbR $ \v -> setMWColor (return v)     (getValue tbG) (getValue tbB)
    onChanged tbG $ \v -> setMWColor (getValue tbR) (return v)     (getValue tbB)  
    onChanged tbB $ \v -> setMWColor (getValue tbR) (getValue tbG) (return v)
 
    hBottom <- vL $+ hLayout def
    void $ hBottom  $+ label  def{ labelSize=V2 100 20
                                , labelAlignment=AlignRightCenter
                                , labelText="Размер крестика :"}
    tbCS <- hBottom  $+ hTrackBar def   
                { linearTrackBarFormItemDef = 
                    def{formItemMargin=Just $ WidgetMarginEvenly 10}
                , linearTrackMinValue = 5
                , linearTrackMaxValue = 50
                , linearTrackBarPos = 10 }
                
    onChanged tbCS (setCrossSize mw)

Запускаем и проверяем
Bash
1
stack build --exec 5.2.CustomWidget
Нажмите на изображение для увеличения
Название: 5.2.CustomWidget_2.png
Просмотров: 38
Размер:	24.2 Кб
ID:	4912

Осталось ещё прикрутить обработчик событий. Пусть это будет уже использованный с другими виджетами onChanged, который будет вызываться при изменении состояния мыши - её координаты или входа-выхода из области виджета.

Посмотрим, как определена onChanged в GUI.Widget.Types.
Haskell
1
2
3
4
-- | Для экземпляров этого класса типов можно назначить действие вызываемое виджетом при изменении
-- ассоциированного с ним значения.
class Changeable a b | a -> b where
    onChanged :: MonadIO m => a -> (forall n. MonadIO n => b -> n ()) -> m ()
Где a – виджет, а b – изменяющийся тип.

Лучше описать свой тип состояния мыши
Haskell
1
type MouseWatcherState = Maybe GuiPoint
А так же вынести из onDraw преобразование MouseWatcherState в текст, в отдельную функцию
Haskell
1
mouseWatcherStateToText :: MouseWatcherState -> T.Text
, для чего понадобится подключить пакет text (ради возможности указать в программе сам тип Text).

Вернёмся к созданию обработчика события изменения данных.
В MouseWatcherData мы добавляем.
Haskell
1
2
3
4
5
data MouseWatcherData = MouseWatcherData
        { rfTextColor :: IORef GuiColor 
        , setCrossSz  :: forall m. MonadIO m => Widget -> Coord -> m ()
        , rfOnChange   :: IORef (OneArgAction MouseWatcherState)
        }
Что это за OneArgAction ? Он определён в том же GUI.Widget.Types. Что бы передать функцию через ссылку, её придётся во что то завернуть. В данном случае в newtype.

(Примечание: Если обработчиков у виджета много, возможно имеет смысл вынести их в отдельную запись и хранить ссылку на целую запись из функций обработчиков. Так для некоторых виджетов в GUI-SDL2 и делается.)

Реализация установки нового значения функции обработчика тривиальна
Haskell
1
2
instance Changeable (GuiWidget MouseWatcherData) MouseWatcherState where
    onChanged w a = writeMonadIORef (rfOnChange $ widgetData w) $ OneArgAction a
В функции виджета, вначале, в это поле заносится ссылка на функцию - заглушку
Haskell
1
    rfOnChange' <- newMonadIORef $ OneArgAction $ \_ -> return ()
Далее, в коде объединены ситуации где состояние меняется, в локальную функцию onChangeState.
В конце неё и вызывается функция по ссылке.
MouseWatcher.hs
Haskell
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module GUI.Widget.MouseWatcher(
    MouseWatcherState,MouseWatcherData,MouseWatcherDef(..)
    ,setCrossSize,mouseWatcherStateToText,mouseWatcher
    ) where
 
import Control.Monad
import Control.Monad.IO.Class
import Data.Bits
import Data.IORef
import Data.Maybe
import Data.Monoid
import qualified TextShow as TS
import TextShow (showb)
import qualified SDL
import SDL.Vect
import Data.Default
import GUI
import GUI.Widget.Handlers
import Control.Monad.Extra (whenJust)
import qualified Data.Text as T
 
type MouseWatcherState = Maybe GuiPoint
 
data MouseWatcherData = MouseWatcherData
        { rfTextColor :: IORef GuiColor 
        , setCrossSz  :: forall m. MonadIO m => Widget -> Coord -> m ()
        , rfOnChange  :: IORef (OneArgAction MouseWatcherState)
        }
                                              
 
-- | Параметры настройки виджета @mouseWatcher@.
data MouseWatcherDef = MouseWatcherDef {
    mouseWatcherFormItemDef  :: FormItemWidgetDef -- ^ Общие настройки для всех виджетов для форм
  , mouseWatcherSize      :: GuiSize -- ^ размер без полей.
  , mouseWatcherFlags     :: WidgetFlags -- ^ Флаги базового виджета.
  , mouseWatcherTextColor :: GuiColor -- ^ начальный размер текста.
  , mouseWatcherCrossSize :: Coord  -- ^ Начальный размер (радиус) крестика.
                                       }
 
instance Default MouseWatcherDef where
    def = MouseWatcherDef   { mouseWatcherFormItemDef = def
                            , mouseWatcherSize = zero
                            , mouseWatcherFlags = WidgetVisible .|. WidgetEnable 
                            , mouseWatcherTextColor = grayColor 255
                            , mouseWatcherCrossSize = 10
                            }
 
instance TextColorProperty (GuiWidget MouseWatcherData) where
    setTextColor widget color = do
        let rf = rfTextColor $ widgetData widget
        oldC <- readMonadIORef rf
        when (oldC /= color) $ do
            writeMonadIORef rf color
            markWidgetForRedraw $ baseWidget widget
    getTextColor widget = readMonadIORef $ rfTextColor $ widgetData $ widget
 
setCrossSize :: MonadIO m => GuiWidget MouseWatcherData -> Coord -> m ()
setCrossSize widget sz = setCrossSz (widgetData widget) (baseWidget widget) sz
 
mouseWatcherStateToText :: MouseWatcherState -> T.Text
mouseWatcherStateToText (Just (P (V2 x y))) = TS.toText $ showb x <> "x" <> showb y
mouseWatcherStateToText _ = "No mouse"
                
instance Changeable (GuiWidget MouseWatcherData) MouseWatcherState where
    onChanged w a = writeMonadIORef (rfOnChange $ widgetData w) $ OneArgAction a
                
-- | Создание виджета @mouseWatcher@.
mouseWatcher :: MonadIO m =>
                 MouseWatcherDef ->  -- ^ Параметры виджета.
                 Widget ->  -- ^ Будующий предок в дереве виджетов.
                 Skin -> -- ^ Skin.
                 m (GuiWidget MouseWatcherData)
mouseWatcher MouseWatcherDef{..} parent skin = do
    rfTC <- newMonadIORef mouseWatcherTextColor
    rfState <- newMonadIORef Nothing
    rfCrossSize <- newMonadIORef mouseWatcherCrossSize
    rfOnChange' <- newMonadIORef $ OneArgAction $ \_ -> return ()
    let setCrossSize' w newSz = do
            oldSz <- readMonadIORef rfCrossSize
            when (newSz /= oldSz) $ do
                writeMonadIORef rfCrossSize newSz
                markWidgetForRedraw w
        onChangeState widget newState = do
            writeMonadIORef rfState newState
            markWidgetForRedraw widget
            readMonadIORef rfOnChange' >>= ( $ newState) . oneArgAction
    mkFormWidget mouseWatcherFormItemDef mouseWatcherFlags skin id
            (MouseWatcherData rfTC setCrossSize' rfOnChange') parent 
            (noChildrenFns mouseWatcherSize){
        onGainedMouseFocus = \widget pnt -> do
            onChangeState widget $ Just pnt
        ,onMouseMotion = \widget _btnsLst pnt _relMv -> do
            onChangeState widget $ Just pnt
        ,onLostMouseFocus = \widget -> do
            onChangeState widget Nothing 
        ,onDraw= \widget -> do
            rectAll <- getWidgetCanvasRect widget
            setColor $ grayColor 100
            fillRect rectAll
            fnt <- getFont "label"
            state <- readMonadIORef rfState
            whenJust state $ \p -> do
                    setColor $ grayColor 255
                    crossSz <- readMonadIORef rfCrossSize
                    drawLine (p .-^ V2 crossSz 0) (p .+^ V2 crossSz 0)
                    drawLine (p .-^ V2 0 crossSz) (p .+^ V2 0 crossSz)
            tc <- readMonadIORef rfTC
            drawText fnt tc (P (V2 5 5)) $ mouseWatcherStateToText state
                                                                   }

Я воспользовался функцией whenJust из пакета extra, не забудьте и его включить его в package.yaml
Haskell
1
2
3
4
5
6
7
  5.2.CustomWidget:    
    source-dirs:      5.2.CustomWidget
    main:             Main.hs
    dependencies:
    - text-show 
    - text
    - extra
Main.hs
Haskell
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
{-# LANGUAGE OverloadedStrings #-}
module Main where
 
import Control.Monad
import Data.Default
import qualified SDL
import GUI
import GUI.Skin.DefaultSkin
import GUI.Widget.Label
import GUI.Widget.Layout.LinearLayout
import SDL.Vect
import GUI.Widget.MouseWatcher
import GUI.Widget.LinearTrackBar
import Control.Applicative
 
main :: IO ()
main = runGUI defSkin  -- Запуск GUI с оформлением по умолчанию
 
        -- Список предзагруженных шрифтов : ключ, имя файла, размер шрифта, опции
        [GuiFontDef "label"       "PTN57F.ttf" 15 def
        ] 
        def $ \gui -> do
    win <- newWindow gui "5.2.CustomWidget" SDL.defaultWindow{SDL.windowInitialSize  = V2 400 400}
    vL <- win $+ vLayout def
    lbStatus <- vL $+ label  def{ labelSize=V2 (-1) 20
                                , labelAlignment=AlignCenter
                                , labelText="Сюда будут выводится сообщения"} 
    hL <- vL $+ hLayout def
    mw <- hL $+ mouseWatcher def{mouseWatcherSize= V2 (-1) (-1)}
    V4 initR initG initB _initAlpha <- getTextColor mw 
    let addColorTB color initV = hL $+ vTrackBar' def{
              linearTrackBarFormItemDef = def{formItemMargin=Just $ WidgetMarginXY 3 5}
            , linearTrackMaxValue = 255
            , linearTrackBarPos = 255 - fromIntegral initV  
            , linearTrackBarSliderLn = 0.04
                                                    }  $ \d -> 
                d{ linearTrackBarSliderDraw = \ w mSt r -> do
                        linearTrackBarSliderDraw d w mSt r
                        setColor color 
                        fillRect $ shrinkRect' 3 r
                 }
                 
        setMWColor fr fg fb = do
            let component = (((255 -).fromIntegral) <$>) 
            color <- rgb <$> (component fr) <*> (component fg) <*> (component fb)
            setTextColor mw color 
    tbR <- addColorTB (rgb 255 0 0) initR
    tbG <- addColorTB (rgb 0 255 0) initG
    tbB <- addColorTB (rgb 0 0 255) initB
    
    onChanged tbR $ \v -> setMWColor (return v)     (getValue tbG) (getValue tbB)
    onChanged tbG $ \v -> setMWColor (getValue tbR) (return v)     (getValue tbB)  
    onChanged tbB $ \v -> setMWColor (getValue tbR) (getValue tbG) (return v)
 
    hBottom <- vL $+ hLayout def
    void $ hBottom  $+ label  def{ labelSize=V2 100 20
                                , labelAlignment=AlignRightCenter
                                , labelText="Размер крестика :"}
    tbCS <- hBottom  $+ hTrackBar def   
                { linearTrackBarFormItemDef = 
                    def{formItemMargin=Just $ WidgetMarginEvenly 10}
                , linearTrackMinValue = 5
                , linearTrackMaxValue = 50
                , linearTrackBarPos = 10 }
                
    onChanged tbCS (setCrossSize mw)
    
    onChanged mw $ \s -> setText lbStatus $ mouseWatcherStateToText s

Запускаем и проверяем
Bash
1
stack build --exec 5.2.CustomWidget
Нажмите на изображение для увеличения
Название: 5.2.CustomWidget_3.png
Просмотров: 37
Размер:	34.5 Кб
ID:	4913

Про создание своих виджетов можно писать очень долго, но пока я остановлюсь на этом и, в следующих темах рассмотрю другие виджеты GUI-SDL2.
Размещено в Без категории
Просмотров 115 Комментарии 0
Всего комментариев 0
Комментарии
 
КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2018, vBulletin Solutions, Inc.
Рейтинг@Mail.ru