-------------------------------------------------------------------------------- -- | -- Module : test -- Copyright : (c) 2008-2010 Galois, Inc. -- License : BSD3 -- -- Maintainer : John Launchbury -- Stability : -- Portability : concurrency -- -- A test file for the Orc EDSL -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Main ( module Orc , main ) where import Orc import Control.DeepSeq import System.Random(randomIO) import Data.List(sortBy) main = do putStrLn "Enter a number 1-9 to run that example:" ans <- getLine putStrLn "----------------------------" case ans of "1" -> printOrc baseball "2" -> printOrc (collect patterns) "3" -> printOrc firstmetro "4" -> printOrc parvalueVal "5" -> printOrc $ count queens "6" -> printOrc numbers "7" -> printOrc (scan (flip (++)) [] (takeOrc 10 queens)) "8" -> printOrc $ count (chans [1 .. 12]) "9" -> printOrc $ takeOrc 100 $ zipOrc (recursive 1) (recursive 1000) _ -> putStrLn "Unknown" putStrLn "----------------------------" ------------------------------------- -- Shows a rich and nested set of Orc interactions baseball :: Orc (String,String) baseball = do team <- prompt "Name a baseball team" `notBefore` 10 <|> prompt "Name another team" `butAfter` (12, return "Yankees") <|> (delay 8 >> return "Mariners") agree <- prompt ("Do you like "++team++"?") `butAfter` (20, guard (team/="Mets") >> return "maybe") return (team, agree) ----------------------------- -- Pattern guards patterns :: Orc Int patterns = do x <- liftList [1..10] y <- liftList [2,4..10] (n,True) <- return (x, x `mod` y /= 0) return n ------------------ -- Metronome example. Shows recursion. Also demonstrates the killing -- of the metronome thread when the output is killed with ^C, or -- after 3 prompts are fulfilled firstmetro :: Orc String firstmetro = return "Respond to 2 prompt within 15 seconds, then check all prompts are dead" <|> (delay 1 >> takeOrc 2 (metronome >> prompt "Hello")) <|> (delay 15 >> return "15 seconds...") metronome = signal <|> (delay 2 >> metronome) ------------------ -- Demonstrates the concurency of 'eagerly' parvalue :: Orc Quote parvalue = quotes (Query "Quote A: Enter a number") (Query "Quote B: Enter a number") newtype Query = Query {text::String} deriving (Eq,Show) newtype Quote = Quote {price::Int} deriving (Eq,Show,Num,NFData) noQuote = Quote 0 quotes :: Query -> Query -> Orc Quote quotes srcA srcB = do quoteA <- eagerly $ getQuote srcA quoteB <- eagerly $ getQuote srcB cut ( (pure least <*> quoteA <*> quoteB) <|> (quoteA >>= threshold) <|> (quoteB >>= threshold) <|> (delay 25 >> quoteA <|> quoteB) <|> (delay 30 >> return noQuote)) least qa qb = if price qa < price qb then qa else qb threshold q = guard (price q < 300) >> return q getQuote q = prompt (text q) >>= (return . Quote . read) parallelOr orc1 orc2 = do ox <- eagerly orc1 oy <- eagerly orc2 cut ( (ox >>= guard >> return True) <|> (oy >>= guard >> return True) <|> (pure (||) <*> ox <*> oy)) parvalueVal :: Orc Quote parvalueVal = quotesVal (Query "Quote A: Enter a number") (Query "Quote B: Enter a number") quotesVal :: Query -> Query -> Orc Quote quotesVal srcA srcB = do quoteA <- val $ getQuote srcA quoteB <- val $ getQuote srcB cut ( publish (least quoteA quoteB) <|> (threshold quoteA) <|> (threshold quoteB) <|> (delay 25 >> publish quoteA <|> publish quoteB) <|> (delay 30 >> return noQuote)) parallelOrVal orc1 orc2 = do x <- val orc1 y <- val orc2 cut ( (guard x >> publish True) <|> (guard y >> publish True) <|> publish (x || y) ) ------------------ -- N queens queens = return ("Computing "++show size++"-queens...") <+> fmap show (extend []) size = 13 :: Int extend :: [Int] -> Orc [Int] extend xs | length xs == 3 = liftList $ extendL xs | otherwise = do j <- liftList [1 .. size] guard $ not (conflict xs j) extend (j:xs) conflict :: [Int] -> Int -> Bool conflict rs n = n `elem` rs -- column clash || n `elem` zipWith (+) rs [1 .. size] -- diagonal clash || n `elem` zipWith (-) rs [1 .. size] -- other diagonal extendL :: (MonadPlus liftList) => [Int] -> liftList [Int] extendL xs | length xs == size = return xs | otherwise = do j <- liftList [1 .. size] guard $ not (conflict xs j) extendL (j:xs) ------------------------ -- Shows numbers interpreted as Orc terms numbers :: Orc String numbers = tally $ map prompt ["one","two","three","four"] tally ps = do n <- fmap sum (syncList (map success ps)) guard (n/=2) return $ show n return ("You responded to two, you lose... :-)") success :: Orc String -> Orc Int success m = (m >> return 1) `butAfter` (10, return 0) ----------------------- -- Demonstrates lifting functions to complex Orc expressions. pairs :: Orc (String, String) pairs = sync (,) numbers queens ----------------------- -- Demonstrate that recursion needs to be guarded, otherwise runs away. recursive :: Int -> Orc Int recursive n = do putStrLine ("Recursion: "++show n) liftList [1,-1] <|> (recursive (n+1) >>= \x->return (x+sign(x))) sign x = if x<0 then -1 else 1 powerset :: [a] -> Orc [a] powerset xs = liftList $ filterM (const $ liftList [False, True]) xs threeset :: [a] -> Orc [a] threeset xs = do ys <- powerset xs guard (length ys == 3) return ys hassle = (metronome >> putStrLine("Simon")) `onlyUntil` (delay 15 >> signal) chans :: [a] -> Orc [a] chans xs = do ch <- newChan readChans 4000 ch <|> silent (count (powerset xs) >>= writeChan ch) readChans 0 ch = do ch' <- dupChan ch readChans' ch <|> readChans' ch' readChans n ch = do mxs <- readChan ch case mxs of Left xs -> readChans (n-1) ch Right n -> stop readChans' ch = do mxs <- readChan ch case mxs of Left xs -> return xs <|> readChans' ch Right n -> stop ------------------------------ shuffle :: [a] -> IO [a] shuffle xs = do ks <- sequence $ take (length xs) $ repeat (randomIO :: IO Int) return $ map snd $ sortBy key $ zip ks xs where key (a,x) (b,y) = if a