Оконное приложение на чистом Win API
03.06.2015, 20:46. Показов 1501. Ответов 1
Один японец сделал, ради демки, оконное приложение на чистом Win API. Win API совсем не функциональное, и в нём есть сложность, связанная с передачей изменяемого состояния. Все действия обрабатываются оконной процедурой (callback-ом, устанавливаемым при создании окна). Так вот, он придумал весьма функциональный подход - при изменении внутреннего состояния программы (для простоты, там просто счётчик), он, каждый раз, заменяет оконную процедуру передавая счётчик через замыкание.
Оно, конечно, функционально весьма, но, мне не нравится такое обращение с Win API. В общем, его идею я изложил, в программе исправил кое чего, в разных местах, чтобы компилировалось без предупреждений. А потом и эту новаторскую идею убрал. Заменил на обычную мутабельную ссылку IORef. Стало пошустрее.
Погрызенный мной исходник:
Кликните здесь для просмотра всего текста
| 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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
| module Main where
-- Original code from: [url]http://d.hatena.ne.jp/Otter_O/20090217/1234861028[/url]
import System.Win32.Types
import System.Win32.DLL
import Graphics.Win32
import Data.List (unfoldr)
import Data.Int (Int32)
import Data.Maybe
import Control.Monad
import Control.Arrow
import Data.IORef
foreign import stdcall "PostQuitMessage"
postQuitMessage :: Int32 -> IO ()
type Vector = [Float]
type Matrix = [ [Float] ]
transform :: Matrix -> Vector -> Vector
transform mx v = [ mul r v| r <- mx]
where
mul rs cs = sum $ zipWith ( * ) rs cs
mxRotXZ :: Float -> Matrix
mxRotXZ rot = [ [cos rot, 0, (-1) * sin rot ],
[0, 1, 0 ],
[sin rot, 0, cos rot ] ]
proj :: Vector -> Vector
proj ~(x: y: z: _) = [x * fac, y * fac]
where
fac = (z - zvp) / (zvf - zvp)
zvp = -4 :: Float
zvf = -1 :: Float
cube :: [Vector]
cube = [ [1, 1, 1], [1, -1, 1], [-1, -1, 1], [-1, 1, 1],
[1, 1, -1], [1, -1, -1], [-1, -1, -1], [-1, 1, -1],
[1, 1, 1], [1, 1, -1], [-1, 1, -1], [-1, 1, 1],
[1, -1, 1], [1, -1, -1], [-1, -1, -1], [-1, -1, 1] ]
toMaybe :: Bool -> a -> Maybe a
toMaybe p a
| p = Just a
| otherwise = Nothing
varMap :: ( [a] -> (b, [a] ) ) -> [a] -> [b]
varMap f = unfoldr (uncurry toMaybe . (not.null &&& f) )
main :: IO ()
main = do
let clsName = mkClassName "My Window Class"
hinst <- getModuleHandle Nothing
whiteBrush <- getStockBrush wHITE_BRUSH
curArrow <- loadCursor Nothing iDC_ARROW
mAtom <- registerClass
(cS_DBLCLKS,
hinst, -- HINSTANCE
Nothing, -- Maybe HICON
Just curArrow, -- Maybe HCURSOR
Just whiteBrush,-- Maybe HBRUSH
Nothing, -- Maybe LPCTSTR
clsName)
iRf <- newIORef 0
when (isJust mAtom) $ do
hwnd <- createWindow
clsName
"Rotating Box Demo"
(wS_THICKFRAME + wS_CAPTION + wS_SYSMENU)
Nothing
Nothing
Nothing
Nothing
Nothing
Nothing
hinst
(wndProc iRf)
_ <- setWinTimer hwnd 0{-tid-} 50{-msec-}
_ <- showWindow hwnd sW_SHOWNORMAL
updateWindow hwnd
allocaMessage pump
unregisterClass clsName hinst
pump :: LPMSG -> IO ()
pump lpmsg = do
fContinue <- getMessage lpmsg Nothing
when fContinue $ do
_ <- translateMessage lpmsg
_ <- dispatchMessage lpmsg
pump lpmsg
drawBox4 :: HDC -> [ [Int32] ] -> IO ()
drawBox4 hdc ~[ [x1, y1], [x2, y2], [x3, y3], [x4, y4] ] =
moveToEx hdc x1 y1 >>
lineTo hdc x2 y2 >>
lineTo hdc x3 y3 >>
lineTo hdc x4 y4 >>
lineTo hdc x1 y1
drawCube :: HDC -> Matrix -> IO ()
drawCube hdc rot = mapM_ (drawBox4 hdc) $
varMap (splitAt 4) $
map (
(map $ ( + 400).round.( * 100) ) . proj . transform rot)
cube
render :: HWND -> HDC -> Int -> IO ()
render _ hdc = drawCube hdc . rot . fromIntegral
where
rot :: Float -> Matrix
rot x = mxRotXZ $ pi * x/ 180
onTimer :: HWND -> IORef Int -> IO ()
onTimer hwnd iRf = do
invalidateRect (Just hwnd) Nothing True
modifyIORef' iRf $ \i -> (i + 2) `mod` 360
wndProc :: IORef Int -> HWND -> WindowMessage -> WPARAM ->
LPARAM -> IO LRESULT
wndProc iRf hwnd wm wp lp
| wm == wM_KEYDOWN = doFinish
| wm == wM_LBUTTONDOWN = doFinish
| wm == wM_DESTROY = killTimer (Just hwnd) 0 >>
postQuitMessage 0 >> return 0
| wm == wM_SIZE = doInvalRender
| wm == wM_PAINT = onPaint
| wm == wM_TIMER = onTimer hwnd iRf >> return 0
| otherwise = defWindowProc (Just hwnd) wm wp lp
where
doFinish = sendMessage hwnd wM_CLOSE 1 0 >> return 0
doInvalRender = do
invalidateRect (Just hwnd) Nothing True
return 0
onPaint = allocaPAINTSTRUCT $ \ lpps -> do
hdc <- beginPaint hwnd lpps
i <- readIORef iRf
render hwnd hdc i
endPaint hwnd lpps
return 0 |
|
И win32test.cabal
Кликните здесь для просмотра всего текста
name: win32test
version: 0.1.0.0
synopsis: test
-- description:
-- license:
license-file: LICENSE
author: KolodeznyDiver
maintainer: none@mail.ru
-- copyright:
category: Testing
build-type: Simple
-- extra-source-files:
cabal-version: >=1.10
executable win32test
main-is: Main.hs
GHC-Options: -Wall -optl-mwindows
--subsystem,windows
-- other-modules:
-- other-extensions:
build-depends: base >=4.8 && <4.9
, Win32
hs-source-dirs: src
default-language: Haskell2010
|
- то есть не используются никакие дополнительные пакеты, кроме входящих в дистрибутив ghc. Я использую ghc 7.10.1. Для более старых, может понадобится другой диапазон версий пакета base указать. Хотя, в коде, врят ли что менять понадобится.
p.s. Я знаю что с платформой haskell идёт обёртка для GLUT. А ещё wxHaskell есть. И с ними может короче получиться. Но, тут используется минимальное кол-во пакетов и никаких сторонних библиотек.
p.p.s. Интересно было бы глянуть на оконное приложение низкого уровня для "иксов".
Добавлено через 4 минуты
Хм. Код вставился как то очень криво. Не знаю почему так. Повторяю:
Кликните здесь для просмотра всего текста
| 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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
| module Main where
-- Original code from: [url]http://d.hatena.ne.jp/Otter_O/20090217/1234861028[/url]
import System.Win32.Types
import System.Win32.DLL
import Graphics.Win32
import Data.List (unfoldr)
import Data.Int (Int32)
import Data.Maybe
import Control.Monad
import Control.Arrow
import Data.IORef
foreign import stdcall "PostQuitMessage"
postQuitMessage :: Int32 -> IO ()
type Vector = [Float]
type Matrix = [ [Float] ]
transform :: Matrix -> Vector -> Vector
transform mx v = [ mul r v| r <- mx]
where
mul rs cs = sum $ zipWith ( * ) rs cs
mxRotXZ :: Float -> Matrix
mxRotXZ rot = [ [cos rot, 0, (-1) * sin rot ],
[0, 1, 0 ],
[sin rot, 0, cos rot ] ]
proj :: Vector -> Vector
proj ~(x: y: z: _) = [x * fac, y * fac]
where
fac = (z - zvp) / (zvf - zvp)
zvp = -4 :: Float
zvf = -1 :: Float
cube :: [Vector]
cube = [ [1, 1, 1], [1, -1, 1], [-1, -1, 1], [-1, 1, 1],
[1, 1, -1], [1, -1, -1], [-1, -1, -1], [-1, 1, -1],
[1, 1, 1], [1, 1, -1], [-1, 1, -1], [-1, 1, 1],
[1, -1, 1], [1, -1, -1], [-1, -1, -1], [-1, -1, 1] ]
toMaybe :: Bool -> a -> Maybe a
toMaybe p a
| p = Just a
| otherwise = Nothing
varMap :: ( [a] -> (b, [a] ) ) -> [a] -> [b]
varMap f = unfoldr (uncurry toMaybe . (not.null &&& f) )
main :: IO ()
main = do
let clsName = mkClassName "My Window Class"
hinst <- getModuleHandle Nothing
whiteBrush <- getStockBrush wHITE_BRUSH
curArrow <- loadCursor Nothing iDC_ARROW
mAtom <- registerClass
(cS_DBLCLKS,
hinst, -- HINSTANCE
Nothing, -- Maybe HICON
Just curArrow, -- Maybe HCURSOR
Just whiteBrush,-- Maybe HBRUSH
Nothing, -- Maybe LPCTSTR
clsName)
iRf <- newIORef 0
when (isJust mAtom) $ do
hwnd <- createWindow
clsName
"Rotating Box Demo"
(wS_THICKFRAME + wS_CAPTION + wS_SYSMENU)
Nothing
Nothing
Nothing
Nothing
Nothing
Nothing
hinst
(wndProc iRf)
_ <- setWinTimer hwnd 0{-tid-} 50{-msec-}
_ <- showWindow hwnd sW_SHOWNORMAL
updateWindow hwnd
allocaMessage pump
unregisterClass clsName hinst
pump :: LPMSG -> IO ()
pump lpmsg = do
fContinue <- getMessage lpmsg Nothing
when fContinue $ do
_ <- translateMessage lpmsg
_ <- dispatchMessage lpmsg
pump lpmsg
drawBox4 :: HDC -> [ [Int32] ] -> IO ()
drawBox4 hdc ~[ [x1, y1], [x2, y2], [x3, y3], [x4, y4] ] =
moveToEx hdc x1 y1 >>
lineTo hdc x2 y2 >>
lineTo hdc x3 y3 >>
lineTo hdc x4 y4 >>
lineTo hdc x1 y1
drawCube :: HDC -> Matrix -> IO ()
drawCube hdc rot = mapM_ (drawBox4 hdc) $
varMap (splitAt 4) $
map (
(map $ ( + 400).round.( * 100) ) . proj . transform rot)
cube
render :: HWND -> HDC -> Int -> IO ()
render _ hdc = drawCube hdc . rot . fromIntegral
where
rot :: Float -> Matrix
rot x = mxRotXZ $ pi * x/ 180
onTimer :: HWND -> IORef Int -> IO ()
onTimer hwnd iRf = do
invalidateRect (Just hwnd) Nothing True
modifyIORef' iRf $ \i -> (i + 2) `mod` 360
wndProc :: IORef Int -> HWND -> WindowMessage -> WPARAM ->
LPARAM -> IO LRESULT
wndProc iRf hwnd wm wp lp
| wm == wM_KEYDOWN = doFinish
| wm == wM_LBUTTONDOWN = doFinish
| wm == wM_DESTROY = killTimer (Just hwnd) 0 >>
postQuitMessage 0 >> return 0
| wm == wM_SIZE = doInvalRender
| wm == wM_PAINT = onPaint
| wm == wM_TIMER = onTimer hwnd iRf >> return 0
| otherwise = defWindowProc (Just hwnd) wm wp lp
where
doFinish = sendMessage hwnd wM_CLOSE 1 0 >> return 0
doInvalRender = do
invalidateRect (Just hwnd) Nothing True
return 0
onPaint = allocaPAINTSTRUCT $ \ lpps -> do
hdc <- beginPaint hwnd lpps
i <- readIORef iRf
render hwnd hdc i
endPaint hwnd lpps
return 0 |
|
Добавлено через 5 минут
... ну японцы! В общем, редакторы всякие включая Word этих значков не замечают считая их пробельными. А я уж, не буду третий раз сюда копировать. 
1
|
(
