1-- program: S.A.R.A.H. jam simulator
2-- author: Maurício C. Antunes
3-- e-mail: mauricio.antunes@gmail.com
4-- license: public domain
5
6module Main where
7
8import Control.Applicative
9import Prelude
10
11import Data.Maybe
12import Graphics.UI.Gtk
13import Graphics.Rendering.Cairo
14import Control.Monad
15import Data.IORef
16import Data.List
17import Data.Time
18import Data.Complex
19
20-- Constants
21
22accelerator = 0.7*carSize :: Double
23brake = 10*accelerator:: Double
24carSize = 2*pi/59 :: Double
25responseTime = 0.24 :: Double
26drawSide = 5/2 :: Double
27
28-- A few conveniences
29
30eventWindowSize = do
31    dr <- eventWindow
32    w <- liftIO $ drawWindowGetWidth dr
33    h <- liftIO $ drawWindowGetHeight dr
34    return $ if w*h > 1
35        then (fromIntegral w, fromIntegral h)
36        else (1,1)
37
38eventPolarCoordinates = do
39    (w,h) <- eventWindowSize
40    (x,y) <- eventCoordinates
41    let (origX, origY) = (w/2, h/2)
42    let (scaleX, scaleY) = (drawSide/w, drawSide/h)
43    let (x',y') = (scaleX*(x-origX), scaleY*(y-origY))
44    let (radius,theta) = polar $ x' :+ y'
45    return $ (radius,theta)
46
47getAndSet :: a -> IO (IO a, a -> IO ())
48getAndSet a = do
49    ior <- newIORef a
50    let get = readIORef ior
51    let set = writeIORef ior
52    return (get,set)
53
54diffTime :: UTCTime -> UTCTime -> Double
55diffTime = (realToFrac .) . diffUTCTime
56
57moveToLineTo :: Double -> Double
58 -> Double -> Double -> Render ()
59moveToLineTo a b c d = moveTo a b >> lineTo c d
60
61-- Car list handling
62
63-- Each car is represented by a pair of Doubles. The first
64-- Double is its position in a circular road, represented by
65-- an angle. The second is its angular velocity. The general
66-- idea behind the simulation is that in a list of cars each
67-- one will try to keep a safe speed to avoid a crash in the
68-- event of a sudden brake of the next car.
69
70newCarList nCars = take nCars $ zip [0,2*pi/nCars'..] (repeat 0)
71    where nCars' = fromIntegral nCars
72
73-- This resizes car lists by copying or keeping those
74-- at lower speeds.
75
76newCarListFromList nCars [] = newCarListFromList nCars [(0,0)]
77newCarListFromList nCars list = sortBy ((. fst).(compare . fst)) $
78    take nCars $ cycle $ sortBy ((. snd).(compare . snd)) list
79
80-- Safe speed for car, given data from itself and the next
81-- and, possibly, a forced (by the user) jam. Speed changes
82-- are limited by accelerator and brake maxima.
83
84newSpeed dt jam (p1,s1) (p2,s2) = min cv $ max bv $ ds - br
85    where
86        pd = (p2-p1-carSize) - responseTime*(s2-s1)
87        pj = maybe pd ((subtract $ carSize/2)
88         . (until (>0) (+2*pi)) . (subtract p1)) jam
89        dd = brake*(max 0 $ min pd pj)
90        br = brake*responseTime
91        ds = sqrt $ br^2 + 2*dd
92        cv = s1 + accelerator*dt
93        bv = s1 - brake*dt
94
95-- Update positions and speeds based on a timestep and maybe
96-- taking a forced congestion into account
97
98updateCarList _ _ [] = []
99updateCarList timestep jam list = zip newPositions' newSpeeds
100    where
101        fakeCar = (p+2*pi,s) where (p,s) = head list
102        newSpeeds = zipWith ns list (tail list ++ [fakeCar])
103            where ns = newSpeed timestep jam
104        newPositions = zipWith3 mean fsts snds newSpeeds
105            where
106                mean a b c = a + timestep*(b+c)/2
107                fsts = map fst list
108                snds = map snd list
109        newPositions' = map (subtract base) newPositions
110        base = (*(2*pi)) $ fromIntegral $ floor $ (/ (2*pi)) $
111            head newPositions
112
113about = do
114    ad <- aboutDialogNew
115    set ad [ aboutDialogName := "S.A.R.A.H."
116           , aboutDialogVersion := "1.0"
117           , aboutDialogAuthors := ["Maurício C. Antunes "
118                                ++ "<mauricio.antunes@gmail.com>"]
119           , aboutDialogComments := "Software Automation of "
120                                ++ "Road Automobile Headache"]
121    dialogRun ad
122    widgetDestroy ad
123
124main :: IO ()
125main = do
126
127    initGUI
128
129    mainWindow <- windowNew
130    drawingArea <- drawingAreaNew
131
132    (getTimeStamp,setTimeStamp) <- getCurrentTime >>= getAndSet
133    (getCars,setCars) <- getAndSet $ newCarList 20
134    (getJam,setJam) <- getAndSet Nothing
135    (getTimeoutId,setTimeoutId) <- getAndSet Nothing
136
137    -- If 'resume' is called, 'step' will be called at small
138    -- timesteps to update car data. If 'pause' is called, 'step'
139    -- calls are stoped.  'resume' is called at program startup,
140    -- and then the pause button alternates 'resume' and 'pause'.
141
142    let step = do
143         time <- getCurrentTime
144         dt <- getTimeStamp >>= return . (diffTime time)
145         setTimeStamp time
146         liftM2 (updateCarList dt) getJam getCars >>= setCars
147    let pause = do
148         maybe (return ()) timeoutRemove =<< getTimeoutId
149         setTimeoutId Nothing
150    let resume = do
151         setTimeoutId . Just =<< flip timeoutAdd 33
152          (step >> widgetQueueDraw drawingArea >> return True)
153         getCurrentTime >>= setTimeStamp
154
155    -- The elements of the graphic interface are the set of
156    -- buttons, the scale to set the number of cars and the
157    -- car track. They are named as 'buttons', 'howMany' and
158    -- 'track'. Each of them contains other widgets inside, but
159    -- there's no reason to expose their names to the main IO.
160
161    buttons <- do
162
163        qr <- buttonNewFromStock stockClear
164        on qr buttonActivated $ do
165            (liftM length) getCars >>= setCars . newCarList
166            getCurrentTime >>= setTimeStamp
167            widgetQueueDraw drawingArea
168
169        qp <- toggleButtonNewWithLabel stockMediaPause
170        buttonSetUseStock qp True
171        on qp toggled $ do
172            p <- toggleButtonGetActive qp
173            case p of
174                True -> pause
175                False -> resume
176
177        qa <- buttonNewFromStock stockAbout
178        on qa buttonActivated $ about
179
180        qq <- buttonNewFromStock stockQuit
181        on qq buttonActivated (do
182                       widgetDestroy mainWindow
183                       mainQuit)
184
185        bb <- hButtonBoxNew
186        containerAdd bb qr
187        containerAdd bb qp
188        containerAdd bb qa
189        containerAdd bb qq
190        return bb
191
192    howMany <- do
193
194        sc <- vScaleNewWithRange 1 40 1
195        after sc valueChanged $ do
196            v <- liftM floor $ rangeGetValue sc
197            c <- getCars
198            setCars $ newCarListFromList v c
199            widgetQueueDraw drawingArea
200
201        scaleSetValuePos sc PosTop
202        scaleSetDigits sc 0
203--        rangeSetUpdatePolicy sc UpdateDiscontinuous
204        rangeSetValue sc =<< liftM (fromIntegral . length) getCars
205
206        al <- alignmentNew 0.5 0.5 0 1
207        alignmentSetPadding al 15 15 15 15
208        containerAdd al sc
209        return al
210
211    track <- do
212
213        let dr = drawingArea
214        widgetAddEvents dr [PointerMotionMask]
215
216        on dr motionNotifyEvent $ do
217            (r,t) <- eventPolarCoordinates
218            liftIO $ if (0.8<r && r<1.2)
219                then setJam (Just t)
220                else setJam Nothing
221            liftIO $ widgetQueueDraw dr
222            return True
223
224        on dr leaveNotifyEvent $ liftIO $
225            setJam Nothing >> return True
226
227        on dr draw $ do
228            w <- liftIO $ (fromIntegral <$> widgetGetAllocatedWidth dr)
229            h <- liftIO $ (fromIntegral <$> widgetGetAllocatedHeight dr)
230            jam <- liftIO getJam
231            cars <- liftIO getCars
232            translate (w/2) (h/2)
233            scale (w/drawSide) (h/drawSide)
234            road2render jam cars
235            -- return True
236
237        af <- aspectFrameNew 0.5 0.5 (Just 1)
238        frameSetShadowType af ShadowNone
239        containerAdd af dr
240        return af
241
242    -- 'layout' is a widget that contains all interface elements
243    -- properly arranged.
244
245    layout <- do
246        vb <- vBoxNew False 0
247        hb <- hBoxNew False 0
248        boxPackStart vb track PackGrow 0
249        boxPackStart vb buttons PackNatural 0
250        boxPackStart hb howMany PackNatural 0
251        boxPackStart hb vb PackGrow 0
252        return hb
253
254    set mainWindow [ windowTitle := "S.A.R.A.H."
255                   , windowDefaultWidth := 400
256                   , windowDefaultHeight := 400 ]
257    on mainWindow objectDestroy mainQuit
258    containerAdd mainWindow layout
259    widgetShowAll mainWindow
260
261    resume
262
263    mainGUI
264
265-- As the name says, this takes road info, in the form of a
266-- possible jam and a list of cars, and make it into a Cairo
267-- render.  Road will have radius 1.
268
269road2render :: Maybe Double -> [(Double,Double)] -> Render ()
270road2render jam cars = do
271    newPath
272    setSourceRGB 0 0 0
273    drawRoad
274    when (isJust jam) drawJam
275    setSourceRGBA 0 0 0 0.55
276    let cars' = map fst cars
277    let rotations = zipWith subtract (0:cars') cars'
278    sequence_ $ map ((>> drawCar) . rotate) rotations
279 where
280    drawRoad = setLineWidth 0.01 >> setDash [2*pi/34,2*pi/34]
281     (pi/34) >> arc 0.0 0.0 1.0 0.0 (2*pi) >> stroke
282    drawJam = setLineWidth 0.005 >> setDash [0.03,0.02] 0.04 >>
283     save >> rotate (fromJust jam) >> moveToLineTo 0.8 0 1.2
284     0 >> stroke >> setDash [] 0 >> moveToLineTo 0.8 (-0.015)
285     0.8 0.015 >> moveToLineTo 1.2 (-0.015) 1.2 0.015 >> stroke
286     >> restore
287    drawCar = arc 1 0 (carSize/2) 0 (2*pi) >> fill
288