This does not

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 * (1-c)))
37:14: Warning: Redundant bracket
Found:
(fromIntegral sizeX) * (fromIntegral sizeY)
Why not:
fromIntegral sizeX * (fromIntegral sizeY)
37:14: Warning: Redundant bracket
Found:
(fromIntegral sizeX) * (fromIntegral sizeY)
Why not:
(fromIntegral sizeX) * fromIntegral sizeY
70:3: Warning: Redundant $
Found:
putStrLn $ "[Out ] Send:"
Why not:
putStrLn "[Out ] Send:"
76:7: Error: Redundant lambda
Found:
fp = \ (x, y) -> let i = pixel_index (x, y) in iarray_read fb2 i
Why not:
fp (x, y) = let i = pixel_index (x, y) in iarray_read fb2 i
85:1: Warning: Use camelCase
Found:
block_size = ...
Why not:
blockSize = ...
114:1: Warning: Use camelCase
Found:
pixel_index (px, py) = ...
Why not:
pixelIndex (px, py) = ...
114:24: Warning: Redundant bracket
Found:
(fromIntegral px) + (fromIntegral sizeX) * (fromIntegral py)
Why not:
fromIntegral px + (fromIntegral sizeX) * (fromIntegral py)
114:44: Warning: Redundant bracket
Found:
(fromIntegral sizeX) * (fromIntegral py)
Why not:
fromIntegral sizeX * (fromIntegral py)
114:44: Warning: Redundant bracket
Found:
(fromIntegral sizeX) * (fromIntegral py)
Why not:
(fromIntegral sizeX) * fromIntegral py