A recent post on Reddit actually reminded me of that.
I will call the program race
, although there are not going to be any winners.
The idea of the program is simple: it will run each process in a separate thread. This runner thread will read the output of the program (both stdout
and stderr
, I just don't care) and send this to the main thread. This way, there will always single thread writing the actual output.
The communication between threads will happen through Control.Concurrent.Chan
, and we will be sending simple messages:
data Msg = Quit -- ^The process finished
| Msg Int ByteString -- ^A single line of output
The number in the message will indicate which child process is sending the line and will be used to pick a color.
The thread for consuming these messages and printing the data is not too complex. It's a loop that keeps track of the number of running processes. In each iteration, we read a single message from the channel and depending on what it is, we either decrement the process counter or print the message wrapped in ANSI color sequences.
printer :: Chan Msg -> Int -> IO ()
printer _ 0 = return ()
printer chan num = do
msg <- readChan chan
case msg of
Quit -> printer chan (num - 1)
Msg i d -> do
B.putStr $ colored i d
reader chan num
colored :: Int -> ByteString -> ByteString
colored i d = let col = colors !! i
in "\ESC[" <> col <> ";1m" <> d <> "\ESC[0m\n"
where
colors = cycle ["36", "35", "32", "33", "34", "31"]
Reading the output of a random program is a bit more involved. As input, we will submit the channel, process number and a string with the command.
There is a very helpful tutorial for Data.Conduit.Process
which contains an example. We can adapt this to our needs.
The biggest hurdle here is that glibc will by default line-buffer standard output if it goes to interactive terminal, but as soon as we redirect it to a pipe, it gets fully buffered in 4 KiB blocks.
This is definitely not what we want. There are a few ways to mitigate this: the easiest is to use stdbuf
executable, which modifies the buffering mode. The problem with it is that it does not work for all cases, especially for commands involving piping data between multiple processes.
Another attempt that I made was to use a pseudoterminal. This approach is however quite complex, and I failed to get it running reliably.
In the end I settled for script
command. By using the -c
argument it can run a complex command and it handles buffering just the way I wanted.
runProcess :: Chan Msg -> Int -> String -> IO ()
runProcess chan' i cmd = do
let cmd' = "script -qfc \"" <> cmd <> "\" /dev/null"
(ClosedStream, fromProcess, fromProcessErr, cph) <-
streamingProcess (shell cmd')
let output h = CB.sourceHandle h $$ CB.lines =$ CL.mapM_
(writeChan chan . Msg i)
_ <- runConcurrently $
Concurrently (output fromProcess) *>
Concurrently (output fromProcessErr) *>
Concurrently (waitForStreamingProcess cph)
writeChan chan Quit
All that is left to do is to tie it all together: get command line arguments, spawn a thread for each one and run the printer function in the main thread. We will create the channel with one duplicate: the copy will be shared by all worker threads.
main :: IO ()
main = do
args <- getArgs
readEnd <- newChan
writeEnd <- dupChan readEnd
mapM_ (forkIO . uncurry (runProcess writeEnd)) (zip [0..] args)
reader readEnd (length args)
The program can now be used like this:
$ race "python -m SimpleHTTPServer" "make rebuild-on-change"
Arguably, it is just a glorified wrapper for the &
Bash functionality and wait
command. Nonetheless, I still consider it useful.
You can get the whole project including cabal file with list of dependencies on GitHub.
]]>There were two elevators, each equipped with a single button that should tell the elevator to come to your floor. However, if the elevator is currently going somewhere, it will ignore your request. You have to wait for it to stop and press the button again. Should someone press it faster, you are out of luck and have to wait for next try.
Obviously, the two elevators do not communicate in any way, so in fact you gamble with two elevators at the same time.
This system seemed very stupid to me, so I decided to create a simple model to verify how much better it would be if the elevator was somewhat smarter.
So let's model a building with a single elevator. The simulation will run in turns. At the beginning of each turn, a person can appear at each floor with some probability. All people want to go to the lowest floor (think busy morning). Next, the elevator must decide whether to go up, down, load or unload people or wait.
We will test three different elevator logics. In the simulation, the elevator is represented by a Haskell
function with type Building -> Decision
, where Building
is a data type with information about waiting people and actual position of the elevator.
Note that even the simplest elevator in the simulation is still more elaborate than the one in my building. To simulate that, it would be necessary to choose floor to pick people up at random. This would require the elevator logic to retain some state between each call, which currently is not possible.
The simplest elevator is called dumbElevator
, but none-the-less it still is a bit smarter that the one in my former building. This elevator stores each request in a queue and works in a first-come-first-served fashion.
dumbElevator b
| hasPeople b = if inBasement b then Unload else GoDown
| otherwise = case (== b ^. curPosition) `fmap` (b ^. queue ^? _head) of
Just True -> Load
Just False -> GoUp
Nothing -> Wait
If there are people on the elevator, it will take them to the basement and unload. Otherwise it will go to the next floor in the queue and load all the people there.
We will improve this elevator with slightly nicer behavior in niceElevator
: when it goes down through a floor with people, it will stop and let them on.
niceElevator b
| hasPeople b = if inBasement b
then Unload
else if peopleOnCurrentFloor b then Load else GoDown
| otherwise = dumbElevator b
The last modeled elevator behaves the same as niceElevator
when going down. Where it differs is that when it decides where to start loading people, it ignores the order of requests and goes to the highest floor with waiting people.
smartElevator b
| hasPeople b = niceElevator b
| any (> b ^. curPosition) (b ^. queue) = GoUp
| peopleOnCurrentFloor b = Load
| otherwise = Wait
It does not preserve any state. In each turn, it will check if there is a floor above it with people. If so, it will go for them. If not and there are people on current floor, it lets them on, otherwise it will wait. Note that a situation when people are waiting below the elevator can never happen, as the elevator goes up only if it can pick someone up there.
It should not be a surprise that the dumb elevator does not behave very well. The metric that I measured is the average waiting time. Every time a person got on the elevator, their waiting time (current time minus the appearance of this person) was recorded. This way we can determine how bad the elevator is. The number itself does not say much, but a comparison of different elevators does.
The first graph displays the average waiting time with regards to the probability of a person appearing.
If the building has more floors, the trend remains the same. The wait time for dumb elevator goes much higher than for the other two elevators. However, the additional cunning of smart elevator does not seem to bring much.
It seems from the graphs that at certain point the elevators can no longer deal with the amount of people appearing in the building. The simulation was run for 10000 turns and people who were never picked up do not have any effect on the average time, thus the upper bound on the wait time.
It might also be interesting to have a look at the relation between waiting time and number of floors.
Interestingly, the probability of people appearing has pretty much no influence on the results.
There is one positive result: I don't have to live a with a dumb elevator anymore. The simulation confirmed that a slight improvement in the logic – letting people get on the elevator when it is going down – can have significant impact on average waiting time.
The code used for this is available at GitHub.
]]>