LANGUAGE GADTs FlexibleContexts DeriveDataTypeable import Control Conc

  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
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
{-# LANGUAGE GADTs, FlexibleContexts, DeriveDataTypeable #-}
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Control.Monad.State
import Data.Array.Diff
import Data.Maybe
import Data.Typeable
import Graphics.Rendering.Cairo hiding (scale)
import Graphics.Rendering.Cairo.Matrix
import Graphics.UI.Gtk hiding (get, fill)
import Graphics.UI.Gtk.Abstract.Widget
import System.IO
import System.Random
sendMsg :: TChan a -> a -> IO ()
sendMsg chan msg = atomically $ writeTChan chan msg
sendMsgs :: TChan a -> [a] -> IO ()
sendMsgs chan msgs = atomically $ forM_ msgs $ writeTChan chan
loBound = 1
hiBound = 60
data Message = ComeTo Int | DropBag | Disappear | Clean [Int] deriving (Eq, Show)
newtype HooliganS = HooliganS {
bagCount :: Int
}
hooligan :: TChan Message -> StateT HooliganS IO ()
hooligan chan = forever $ do
bags <- gets bagCount
let drop = bags > 0
when drop $ put $ HooliganS (bags - 1)
liftIO $ do
pos <- randomRIO (loBound, hiBound)
sendMsgs chan $ [ComeTo pos] ++ if drop then [DropBag] else []
threadDelay 60000
sendMsg chan Disappear
threadDelay 300000
runHooligan :: TChan Message -> IO ()
runHooligan chan =
evalStateT (hooligan chan) (HooliganS 22)
data JanitorS = JanitorS {
position :: Int
, direction :: Int
}
janitor :: TChan Message -> StateT JanitorS IO ()
janitor chan = forever $ do
(JanitorS pos dx) <- get
let clean = [x | x <- [pos - 1 .. pos + 1], x >= loBound && x <= hiBound]
liftIO $ sendMsg chan $ Clean clean
let dx' = if pos == loBound && dx < 0 || pos == hiBound && dx > 0 then -dx else dx
put $ JanitorS (pos + dx') dx'
liftIO $ threadDelay 400000
runJanitor :: TChan Message -> IO ()
runJanitor chan =
evalStateT (janitor chan) (JanitorS loBound 1)
data Cell = Empty | Bag
data Field where
Field :: IArray a Cell => a Int Cell -> Field
data Playground = Playground {
hooliganPos :: Maybe Int
, janitorPos :: [Int]
, field :: Field
}
instance Show Playground where
show (Playground hooligan janitor (Field field)) =
map pchar (assocs field)
where pchar (i, _)
| (Just i) == hooligan = 'H'
| i `elem` janitor = 'J'
pchar (_, Empty) = '.'
pchar (_, Bag) = 'X'
updateField p@(Playground _ _ (Field a)) d = p { field = Field $ a // d }
data HooliganCaught = HooliganCaught Int deriving (Show, Typeable)
instance Exception HooliganCaught
mainLoop :: TChan Message -> (Playground -> IO ()) -> IO ()
mainLoop chan draw = do
let field = listArray (loBound, hiBound) (repeat Empty) :: DiffArray Int Cell
catchJust (\e -> (fromException e) :: Maybe HooliganCaught)
(evalStateT loop (Playground Nothing [] (Field field)))
(const $ return ()) where
loop = do
state@(Playground hooligan janitor (Field field)) <- get
liftIO $ draw state
let caught = (hooligan >>= return . (`elem` janitor)) == Just True
when caught $ liftIO $ throwIO $ HooliganCaught $ fromJust hooligan
msg <- liftIO $ atomically $ readTChan chan
liftIO $ print msg
put $ case msg of
ComeTo x -> state { hooliganPos = Just x }
DropBag -> updateField state [(fromJust hooligan, Bag)]
Disappear -> state { hooliganPos = Nothing }
Clean xs -> (updateField state (zip xs $ repeat Empty)) { janitorPos = xs }
loop
renderPlayground :: Playground -> Render ()
renderPlayground (Playground hooligan janitor (Field field)) = do
setSourceRGB 255 255 255
paint
let cellRGB x r g b = do
setSourceRGB r g b
newPath
rectangle (realToFrac $ x - 1) 0 1 1
fill
let drawElem (i, _)
| (Just i) == hooligan =
if fromJust hooligan `elem` janitor then do
setSourceRGB 255 0 0
newPath
arc (realToFrac i - 0.5) 0.5 0.4 0 (2 * pi)
fill
else cellRGB i 255 255 0
| i `elem` janitor = cellRGB i 255 0 0
drawElem (i, Bag) = cellRGB i 0 0 255
drawElem (_, Empty) = return ()
forM_ (assocs field) drawElem
drawPlayground :: WidgetClass a => a -> Playground -> IO ()
drawPlayground widget playground = postGUIAsync $ do
drawWindow <- widgetGetDrawWindow widget
(w, h) <- drawableGetSize drawWindow
drawWindowBeginPaintRect drawWindow (Rectangle 0 0 w h)
renderWithDrawable drawWindow $ do
setMatrix $ scale 15 15 identity
renderPlayground playground
drawWindowEndPaint drawWindow
main = do
unsafeInitGUIForThreadedRTS
window <- windowNew
set window [ containerBorderWidth := 10, windowTitle := "Hooligan and Janitor",
windowWindowPosition := WinPosCenter ]
window `onDestroy` mainQuit
area <- drawingAreaNew
area `onSizeRequest` return (Requisition 900 15)
buttonQuit <- buttonNewWithLabel "Quit"
buttonQuit `onClicked` (widgetDestroy window)
vbox <- vBoxNew False 20
window `containerAdd` vbox
boxPackStartDefaults vbox area
boxPackStartDefaults vbox buttonQuit
chan <- newTChanIO
t1 <- forkIO $ runHooligan chan
t2 <- forkIO $ runJanitor chan
forkIO $ do
mainLoop chan (drawPlayground area)
killThread t1
killThread t2
widgetShowAll window
mainGUI