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
| module Main where
import Data.Word
import Network
import System.IO
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad.ST
import Data.Array.Vanilla.Unsafe
import Network.RFB.Rectangle
import Network.RFB.PixelFormat
import Network.RFB.State
import Network.RFB.Server.Handshake
import Network.RFB.Server.Receive
import Network.RFB.Server.Send
import Network.RFB.Server.Encode
sizeX = 640 :: Word16
sizeY = 480 :: Word16
main = withSocketsDo $ do
putStrLn "[Main] Open server socket..."
socket <- listenOn (PortNumber 3141)
putStrLn "[Main] Wait for connection..."
(h, host, port) <- accept socket
putStrLn "[Main] Close server socket..."
sClose socket
putStrLn "[Main] Do RFB handshake..."
v <- rfb_handshake h "Haskell RFB Test" (sizeX, sizeY)
print v
putStrLn "[Main] Initialising framebuffer..."
let size = (fromIntegral sizeX) * (fromIntegral sizeY)
putStrLn $ "[Main] Size = " ++ show size ++ " pixels."
fb <- stToIO $ marray_new size (0x80, 0x80, 0x80)
putStrLn "[Main] Initialise variables..."
var <- newEmptyMVar
putStrLn "[Main] Fork processes..."
forkIO (reader h var (rfb_default_State (sizeX, sizeY)))
forkIO (writer h var fb)
forkIO (render fb)
putStrLn "[Main] Wait."
getLine
putStrLn "[Main] Exit."
reader h v state = do
msg <- rfb_receive h
case msg of
RFB_SetPixelFormat fmt' -> do
putStrLn $ "[In ] " ++ show msg
reader h v (state {rfb_PixelFormat = fmt'})
RFB_FramebufferUpdateRequest {} -> do
putStrLn $ "[In ] " ++ show msg
putMVar v (state, rfb_RequestRectangle msg)
reader h v state
_ -> reader h v state
writer :: Handle -> MVar (RFB_State, RFB_Rectangle) -> MArray RealWorld (Word16, Word16, Word16) -> IO ()
writer h v fb = do
(state, rect) <- takeMVar v
let fmt = rfb_PixelFormat state
let cm = rfb_ColourMap state
putStrLn $ "[Out ] Send:"
putStrLn $ "[Out ] " ++ show rect
putStrLn $ "[Out ] " ++ show fmt
let rs = split rect
putStrLn $ "[Out ] " ++ show (length rs) ++ " rectangles."
fb2 <- stToIO $ marray_freeze fb
let fp = \ (x, y) -> let i = pixel_index (x, y) in iarray_read fb2 i
let ds = map (\ r -> rfb_encode_raw state r fp) rs
rfb_send h (RFB_FramebufferUpdate ds)
hFlush h
putStrLn "[Out ] Sent."
threadDelay (1000 * 1000)
writer h v fb
block_size :: Word16
block_size = 8
split :: RFB_Rectangle -> [RFB_Rectangle]
split (RFB_Rectangle rx0 ry0 rsx rsy) = do
let rx1 = rx0 + rsx 1
let ry1 = ry0 + rsy 1
bx0 <- [rx0, rx0 + block_size .. rx1]
by0 <- [ry0, ry0 + block_size .. ry1]
let bx1 = rx1 `min` (bx0 + block_size 1)
let by1 = ry1 `min` (by0 + block_size 1)
let bdx = bx1 bx0 + 1
let bdy = by1 by0 + 1
if bdx > 0 && bdy > 0
then return $ RFB_Rectangle bx0 by0 bdx bdy
else []
render :: MArray RealWorld (Word16, Word16, Word16) -> IO ()
render fb =
mapM_
(\ (x, y) -> do
let n = pixel_index (x, y)
let p = fn (x, y)
putStrLn $ "[Draw] " ++ show (x, y) ++ " <=> [" ++ show n ++ "] := " ++ show p
hFlush stdout
stToIO $ marray_write fb n p
)
[ (x, y) | y <- [0 .. sizeY 1], x <- [0 .. sizeX 1] ]
pixel_index :: (Word16, Word16) -> Int
pixel_index (px, py) = (fromIntegral px) + (fromIntegral sizeX) * (fromIntegral py)
fn :: (Word16, Word16) -> (Word16, Word16, Word16)
fn (px, py) =
let
x = (fromIntegral px 320) / 240
y = (fromIntegral py 240) / 240
c = abs $ sin $ (12*) $ x*x*x + y*y*y
in (floor (0x00FF * c), floor (0x00FF * c), floor (0x00FF * (1c)))
|