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