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
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
module MeshMaker where
import Control.Monad
import Data.Coerce
import Data.IORef
import Foreign.C.Types
import GI.Gdk
import GI.GObject.Functions
import GI.Gtk
import Numeric.LinearAlgebra
data MeshMaker = MeshMaker
{ mmWidget :: GLArea
, mmRealized :: IORef (Maybe State)
}
data Camera = Camera
{ camHeightAngle :: Float
, camTarget :: Vector Float
, camDirection :: Vector Float
, camDistance :: Float
, camWidth :: Float
, camHeight :: Float
, camWorldToScreen :: Maybe (Matrix Float)
, camScreenToWorld :: Maybe (Matrix Float)
}
data State = State
{ stCamera :: IORef Camera
}
initCamera = Camera
{ camHeightAngle = pi/6
, camTarget = fromList [0,0,0]
, camDirection = fromList [0,0,-1]
, camDistance = 10
, camWidth = 0
, camHeight = 0
, camWorldToScreen = Nothing
, camScreenToWorld = Nothing
}
new :: IO GLArea
new = do
w <- gLAreaNew
ref <- newIORef Nothing
let mm = MeshMaker w ref
-- _ <- on w #createContext $ onCreateContext mm
_ <- on w #realize $ onRealize mm
_ <- on w #unrealize $ onUnrealize mm
-- _ <- on w #destroy $ onDestroy mm
return w
onRealize :: MeshMaker -> IO ()
onRealize mm@(MeshMaker w ref) = do
putStrLn "realize!"
readIORef ref >>= \case
Just st -> onUnrealize mm -- Shouldn't happen.
Nothing -> return ()
widgetAddEvents w
[ EventMaskPointerMotionMask
, EventMaskButtonPressMask
, EventMaskButtonReleaseMask
, EventMaskTouchMask
, EventMaskScrollMask
]
_ <- on w #event $ onEvent mm
cam <- newIORef initCamera
writeIORef ref $ Just State
{ stCamera = cam
}
onUnrealize :: MeshMaker -> IO ()
onUnrealize (MeshMaker w ref) = do
putStrLn "unrealize!"
readIORef ref >>= \case
Just st -> do
return ()
Nothing -> return () -- Shouldn't happen.
writeIORef ref Nothing
onRender :: MeshMaker -> GLContext -> IO Bool
onRender (MeshMaker w ref) gl = do
return True
onEvent mm@(MeshMaker w ref) ev = do
msrc <- eventGetSourceDevice ev
inputSource <- forM msrc $ \src -> do
src <- get src #inputSource
return src
etype <- get ev #type
-- putStrLn $ "onEvent! " ++ show (etype,inputSource)
let put x = putStrLn (show inputSource ++ " " ++ show x)
case etype of
EventTypeMotionNotify -> do
mev <- get ev #motion
x <- get mev #x
y <- get mev #y
put (x,y)
return ()
EventTypeScroll -> do
sev <- get ev #scroll
d <- get sev #direction
put d
return ()
_ -> return ()
return False
|
