OS / FP midterm solutions

OS.hs

{-# LANGUAGE MultiParamTypeClasses #-}

import System.IO (readLn)

data Request = ReadInt Int | WriteInt Int Int | Halt | Fork | Pipe

newtype Program = Program { runProgram :: Int -> (Request, Program) }

mainP :: Program
mainP = undefined

readInt :: IO Int
readInt = readLn

bottom :: Program
bottom = Program $ \_ -> (Halt, bottom)

adder :: Program
adder = Program $ \_ ->
  (ReadInt 0, Program $ \x ->
    (ReadInt 0, Program $ \y ->
      (WriteInt 0 (x + y), bottom)))

replace :: [a] -> Int -> a -> [a]
replace [] _ _ = []
replace (x:xs) 0 y = y:xs
replace (x:xs) n y = x:(replace xs (n - 1) y)

remove :: [a] -> Int -> [a]
remove [] _ = []
remove (x:xs) 0 = xs
remove (x:xs) n = x:(remove xs (n - 1))

iter :: Int -> Int -> Int -> Program
iter bi step x = Program $ \_ ->
  (WriteInt bi x, iter bi step (step + x))

sim :: Program
sim = Program $ \_ ->
  (Fork, Program $ \pid ->
    if pid == 0
    then (WriteInt 0 (-2), iter 0 3 0)
    else (WriteInt 0 (-1), iter 0 2 0))

multiplier :: Int -> Program
multiplier bi = Program $ \_ ->
  (ReadInt bi, Program $ \x ->
    (WriteInt 0 (x * 2), multiplier bi))

pipe :: Program
pipe = Program $ \_ ->
  (Pipe, Program $ \bi ->
    (Fork, Program $ \pid ->
      if pid == 0
      then (WriteInt 0 (-2), iter bi 1 0)
      else (WriteInt 0 (-1), multiplier bi)))

type Buffer = Maybe [Int]

roundRobin :: ([(Either Int Request, Program)], [[Int]]) -> Int -> IO ()
roundRobin ([], _) _ = return ()
roundRobin (ls, bbs) num = do
  let (inp, prog) = ls !! num
      n = length ls
      m = length bbs
  case inp of
    Left input ->
      case runProgram prog input of
        (ReadInt b, p) -> do
          roundRobin (replace ls num (Right $ ReadInt b, p), bbs) (mod (num + 1) n)
        (WriteInt b i, p) -> do
          roundRobin (replace ls num (Right $ WriteInt b i, p), bbs) (mod (num + 1) n)
        (Halt, _) -> do
          roundRobin (remove ls num, bbs) (mod num (n - 1))
        (Fork, p) -> do
          roundRobin ((Left 0, p):(Left 1, p):remove ls num, bbs) (mod (num + 2) n)
        (Pipe, p) -> do
          roundRobin (replace ls num (Left m, p), bbs ++ [[]]) (mod (num + 1) n)
    Right call ->
      case call of
        ReadInt 0 ->
          do int <- readInt
             roundRobin (replace ls num (Left int, prog), bbs) (mod (num + 1) n)
        ReadInt bi -> do
          -- putStrLn $ "reading from " ++ show bi
          -- putStrLn $ show (bbs !! bi)
          case bbs !! bi of
            [] -> roundRobin (ls, bbs) (mod (num + 1) n)
            (x:xs) -> roundRobin (replace ls num (Left x, prog), replace bbs bi xs) (mod (num + 1) n)
        WriteInt 0 x ->
          do putStrLn $ show x
             roundRobin (replace ls num (Left 0, prog), bbs) (mod (num + 1) n)
        WriteInt bi x -> do
          -- putStrLn $ "writing to " ++ show bi
          let buffercont = bbs !! bi
          roundRobin (replace ls num (Left 0, prog), replace bbs bi (buffercont ++ [x])) (mod (num + 1) n)

os :: Program -> IO ()
os p = roundRobin ([(Left 0, p)], [[]]) 0

main :: IO ()
main = os pipe

proof.c

#include <stdio.h>
#include <unistd.h>
#include <stdio.h>

int main() {
    int pid = 0;
    int status = 0;
    int fds[2];
    pipe(fds);

    char string1[10] = "aaaaaaaaaa";
    char string2[10] = "bbbbbbbbbb";
    if (pid = fork()) {
        // reader thread
        char buffer[10];
        while (1) {
            int start = 0;
            while (start < 10) {
                start = read(fds[0], buffer, 10 - start);
            }
            int ok = 1;
            int i;
            for (i = 1; i < 10; i++) {
                if (buffer[0] != buffer[i]) {
                    ok = 0;
                }
            }
            if (ok) {
                printf("OK %s\n", buffer);
            } else {
                printf("ERROR! found %s\n", buffer);
            }
        }
    } else {
        if (pid = fork()) {
            while (1) {
                write(fds[1], string1, 10);
            }
        } else {
            while (1) {
                write(fds[1], string2, 10);
            }
        }
    }
    return 0;
}

Sentence.hs

module Main where

import Prelude hiding (id)

data SentenceElem = Text String
                  | List [SentenceElem]

type Builder = SentenceElem -> Maybe String

id :: Builder
id (Text x) = Just x
id _ = Nothing

last2 :: Builder -> Builder -> Builder
last2 b1 b2 (List [x, y]) =
  do r1 <- b1 x
     r2 <- b2 y
     return $ r1 ++ r2
last2 _ _ _ = Nothing

append :: String -> Builder -> Builder
append s b1 x =
  do r1 <- b1 x
     return $ r1 ++ s

(<|>) :: Builder -> Builder -> Builder
(b1 <|> b2) x = case b1 x of
  r@Just{} -> r
  Nothing -> b2 x

eat1 :: Builder -> Builder -> Builder
eat1 b1 b2 x = case x of
  List (x:xs) ->
    do r1 <- b1 x
       r2 <- b2 $ List xs
       return $ r1 ++ r2
  _ -> Nothing

test = List [Text "1", Text "2", Text "3"]

russianStyle = (last2 (append " & " id) id)
               <|> eat1 (append ", " id) russianStyle