diff --git a/Async.hs b/Async.hs new file mode 100644 --- /dev/null +++ b/Async.hs @@ -0,0 +1,118 @@ +module Async ( + Async, + async, + withAsync, + cancel, + waitCatch, + waitCatchSTM, + waitSTM, + wait, + waitEither, + waitAny, + waitBoth, + concurrently + ) where + +import Control.Concurrent.STM +import Control.Exception +import Control.Concurrent (ThreadId, forkIO) + +-- <> + +forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId +forkFinally action fun = + mask $ \restore -> + forkIO (do r <- try (restore action); fun r) + +-- < IO (Async a) +async action = do + var <- newEmptyTMVarIO + t <- forkFinally action (atomically . putTMVar var) + return (Async t (readTMVar var)) +-- >> + +-- < return (Left e) + Right a -> return (Right (f a)) +-- >> + +--- < IO (Either SomeException a) +waitCatch = atomically . waitCatchSTM +-- >> + +-- < STM (Either SomeException a) +waitCatchSTM (Async _ stm) = stm +-- >> + +-- < STM a +waitSTM a = do + r <- waitCatchSTM a + case r of + Left e -> throwSTM e + Right a -> return a +-- >> + +-- < IO a +wait = atomically . waitSTM +-- >> + +-- < IO () +cancel (Async t _) = throwTo t ThreadKilled +-- >> + +-- < Async b -> IO (Either a b) +waitEither a b = atomically $ + fmap Left (waitSTM a) + `orElse` + fmap Right (waitSTM b) +-- >> + +-- < IO a +waitAny asyncs = + atomically $ foldr orElse retry $ map waitSTM asyncs +-- >> + +-- < (Async a -> IO b) -> IO b +withAsync io operation = bracket (async io) cancel operation +-- >> + +-- < Async b -> IO (a,b) +waitBoth a1 a2 = + atomically $ do + r1 <- waitSTM a1 `orElse` (do waitSTM a2; retry) -- <1> + r2 <- waitSTM a2 + return (r1,r2) +-- >> + +-- < IO b -> IO (a,b) +concurrently ioa iob = + withAsync ioa $ \a -> + withAsync iob $ \b -> + waitBoth a b +-- >> + +-- < IO b -> IO (Either a b) +race ioa iob = + withAsync ioa $ \a -> + withAsync iob $ \b -> + waitEither a b +-- >> diff --git a/ByteStringCompat.hs b/ByteStringCompat.hs new file mode 100644 --- /dev/null +++ b/ByteStringCompat.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE CPP #-} +module ByteStringCompat () where + +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) +import Control.DeepSeq + +#if !MIN_VERSION_bytestring(0,10,0) + +instance NFData ByteString where + rnf x = B.length x `seq` () + +#endif diff --git a/CasIORef.hs b/CasIORef.hs new file mode 100644 --- /dev/null +++ b/CasIORef.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +module CasIORef (casIORef) where + +import GHC.IORef +import GHC.STRef +import GHC.Exts +import GHC.IO + +casIORef :: IORef a -> a -> a -> IO Bool +casIORef (IORef (STRef r#)) old new = IO $ \s -> + case casMutVar# r# old new s of + (# s', did, val #) -> + if did ==# 0# then (# s', True #) + else (# s', False #) + diff --git a/ConcurrentUtils.hs b/ConcurrentUtils.hs new file mode 100644 --- /dev/null +++ b/ConcurrentUtils.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} + +module ConcurrentUtils ( + -- * Variants of forkIO + forkFinally + ) where + +import Control.Concurrent.STM +import Control.Exception +import Control.Concurrent +import Prelude hiding (catch) +import Control.Monad +import Control.Applicative + +import GHC.Exts +import GHC.IO hiding (finally) +import GHC.Conc + +#if __GLASGOW_HASKELL__ < 706 +-- | fork a thread and call the supplied function when the thread is about +-- to terminate, with an exception or a returned value. The function is +-- called with asynchronous exceptions masked. +forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId +forkFinally action and_then = + mask $ \restore -> + forkIO $ try (restore action) >>= and_then +#endif diff --git a/DistribUtils.hs b/DistribUtils.hs new file mode 100644 --- /dev/null +++ b/DistribUtils.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskell #-} +module DistribUtils ( distribMain ) where + +import Control.Distributed.Process +import Control.Distributed.Process.Closure +import Control.Distributed.Process.Node (initRemoteTable) +import Control.Distributed.Process.Backend.SimpleLocalnet +import Control.Distributed.Static hiding (initRemoteTable) + +import System.Environment +import Network.Socket hiding (shutdown) + +import Language.Haskell.TH + +distribMain :: ([NodeId] -> Process ()) -> (RemoteTable -> RemoteTable) -> IO () +distribMain master frtable = do + args <- getArgs + let rtable = frtable initRemoteTable + + case args of + [] -> do + backend <- initializeBackend defaultHost defaultPort rtable + startMaster backend master + [ "master" ] -> do + backend <- initializeBackend defaultHost defaultPort rtable + startMaster backend master + [ "master", port ] -> do + backend <- initializeBackend defaultHost port rtable + startMaster backend master + [ "slave" ] -> do + backend <- initializeBackend defaultHost defaultPort rtable + startSlave backend + [ "slave", port ] -> do + backend <- initializeBackend defaultHost port rtable + startSlave backend + [ "slave", host, port ] -> do + backend <- initializeBackend host port rtable + startSlave backend + +defaultHost = "localhost" +defaultPort = "44444" diff --git a/GetURL.hs b/GetURL.hs new file mode 100644 --- /dev/null +++ b/GetURL.hs @@ -0,0 +1,25 @@ +-- (c) Simon Marlow 2011, see the file LICENSE for copying terms. + +-- Simple wrapper around HTTP, allowing proxy use + +module GetURL (getURL) where + +import Network.HTTP +import Network.Browser +import Network.URI +import Data.ByteString (ByteString) + +getURL :: String -> IO ByteString +getURL url = do + Network.Browser.browse $ do + setCheckForProxy True + setDebugLog Nothing + setOutHandler (const (return ())) + (_, rsp) <- request (getRequest' (escapeURIString isUnescapedInURI url)) + return (rspBody rsp) + where + getRequest' :: String -> Request ByteString + getRequest' urlString = + case parseURI urlString of + Nothing -> error ("getRequest: Not a valid URL - " ++ urlString) + Just u -> mkRequest GET u diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,33 @@ +Unless stated otherwise in individual source files, the code in this +package is made available under the following license: + +Copyright (c) 2012, Simon Marlow + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Simon Marlow nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Stream.hs b/Stream.hs new file mode 100644 --- /dev/null +++ b/Stream.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE BangPatterns, CPP #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing -fwarn-unused-imports #-} +-- -Wall + +-- A module for stream processing built on top of Control.Monad.Par + +-- (In the future may want to look into the stream interface used by +-- the stream fusion framework.) + +module Stream + ( + Stream, streamFromList, streamMap, streamFold, streamFilter + ) where + +import Control.Monad.Par.Scheds.Trace as P +import Control.DeepSeq + +-------------------------------------------------------------------------------- +-- Types + +-- <> + +instance NFData a => NFData (IList a) where +-- rnf Nil = r0 + rnf Nil = () + rnf (Cons a b) = rnf a `seq` rnf b + +-- ----------------------------------------------------------------------------- +-- Stream operators + +-- < [a] -> Par (Stream a) +streamFromList xs = do + var <- new -- <1> + fork $ loop xs var -- <2> + return var -- <3> + where + loop [] var = put var Nil -- <4> + loop (x:xs) var = do -- <5> + tail <- new -- <6> + put var (Cons x tail) -- <7> + loop xs tail -- <8> +-- >> + +-- < (a -> b) -> Stream a -> Par (Stream b) +streamMap fn instrm = do + outstrm <- new + fork $ loop instrm outstrm + return outstrm + where + loop instrm outstrm = do + ilst <- get instrm + case ilst of + Nil -> put outstrm Nil + Cons h t -> do + newtl <- new + put outstrm (Cons (fn h) newtl) + loop t newtl +-- >> + + +-- | Reduce a stream to a single value. This function will not return +-- until it reaches the end-of-stream. +-- < b -> a) -> a -> Stream b -> Par a +streamFold fn !acc instrm = do + ilst <- get instrm + case ilst of + Nil -> return acc + Cons h t -> streamFold fn (fn acc h) t +-- >> + +streamFilter :: NFData a => (a -> Bool) -> Stream a -> Par (Stream a) +streamFilter p instr = do + outstr <- new + fork $ loop instr outstr + return outstr + where + loop instr outstr = do + v <- get instr + case v of + Nil -> put outstr Nil + Cons x instr' + | p x -> do + tail <- new + put_ outstr (Cons x tail) + loop instr' tail + | otherwise -> do + loop instr' outstr + diff --git a/Sudoku.hs b/Sudoku.hs new file mode 100644 --- /dev/null +++ b/Sudoku.hs @@ -0,0 +1,150 @@ +-- +-- Sudoku solver using constraint propagation. The algorithm is by +-- Peter Norvig http://norvig.com/sudoku.html; the Haskell +-- implementation is by Manu and Daniel Fischer, and can be found on +-- the Haskell Wiki http://www.haskell.org/haskellwiki/Sudoku +-- +-- The Haskell wiki license applies to this code: +-- +-- Permission is hereby granted, free of charge, to any person obtaining +-- this work (the "Work"), to deal in the Work without restriction, +-- including without limitation the rights to use, copy, modify, merge, +-- publish, distribute, sublicense, and/or sell copies of the Work, and +-- to permit persons to whom the Work is furnished to do so. +-- +-- THE WORK IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +-- LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +-- OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +-- WITH THE WORK OR THE USE OR OTHER DEALINGS IN THE WORK. + +module Sudoku (solve, printGrid) where + +import Data.List hiding (lookup) +import Data.Array +import Control.Monad +import Data.Maybe + +-- Types +type Digit = Char +type Square = (Char,Char) +type Unit = [Square] + +-- We represent our grid as an array +type Grid = Array Square [Digit] + + +-- Setting Up the Problem +rows = "ABCDEFGHI" +cols = "123456789" +digits = "123456789" +box = (('A','1'),('I','9')) + +cross :: String -> String -> [Square] +cross rows cols = [ (r,c) | r <- rows, c <- cols ] + +squares :: [Square] +squares = cross rows cols -- [('A','1'),('A','2'),('A','3'),...] + +peers :: Array Square [Square] +peers = array box [(s, set (units!s)) | s <- squares ] + where + set = nub . concat + +unitlist :: [Unit] +unitlist = [ cross rows [c] | c <- cols ] ++ + [ cross [r] cols | r <- rows ] ++ + [ cross rs cs | rs <- ["ABC","DEF","GHI"], + cs <- ["123","456","789"]] + +-- this could still be done more efficiently, but what the heck... +units :: Array Square [Unit] +units = array box [(s, [filter (/= s) u | u <- unitlist, s `elem` u ]) | + s <- squares] + + +allPossibilities :: Grid +allPossibilities = array box [ (s,digits) | s <- squares ] + +-- Parsing a grid into an Array +parsegrid :: String -> Maybe Grid +parsegrid g = do regularGrid g + foldM assign allPossibilities (zip squares g) + + where regularGrid :: String -> Maybe String + regularGrid g = if all (`elem` "0.-123456789") g + then Just g + else Nothing + +-- Propagating Constraints +assign :: Grid -> (Square, Digit) -> Maybe Grid +assign g (s,d) = if d `elem` digits + -- check that we are assigning a digit and not a '.' + then do + let ds = g ! s + toDump = delete d ds + foldM eliminate g (zip (repeat s) toDump) + else return g + +eliminate :: Grid -> (Square, Digit) -> Maybe Grid +eliminate g (s,d) = + let cell = g ! s in + if d `notElem` cell then return g -- already eliminated + -- else d is deleted from s' values + else do let newCell = delete d cell + newV = g // [(s,newCell)] + newV2 <- case newCell of + -- contradiction : Nothing terminates the computation + [] -> Nothing + -- if there is only one value left in s, remove it from peers + [d'] -> do let peersOfS = peers ! s + foldM eliminate newV (zip peersOfS (repeat d')) + -- else : return the new grid + _ -> return newV + -- Now check the places where d appears in the peers of s + foldM (locate d) newV2 (units ! s) + +locate :: Digit -> Grid -> Unit -> Maybe Grid +locate d g u = case filter ((d `elem`) . (g !)) u of + [] -> Nothing + [s] -> assign g (s,d) + _ -> return g + +-- Search +search :: Grid -> Maybe Grid +search g = + case [(l,(s,xs)) | (s,xs) <- assocs g, let l = length xs, l /= 1] of + [] -> return g + ls -> do let (_,(s,ds)) = minimum ls + msum [assign g (s,d) >>= search | d <- ds] + +solve :: String -> Maybe Grid +solve str = do + grd <- parsegrid str + search grd + +-- Display solved grid +printGrid :: Grid -> IO () +printGrid = putStrLn . gridToString + +gridToString :: Grid -> String +gridToString g = + let l0 = elems g + -- [("1537"),("4"),...] + l1 = (map (\s -> " " ++ s ++ " ")) l0 + -- ["1 "," 2 ",...] + l2 = (map concat . sublist 3) l1 + -- ["1 2 3 "," 4 5 6 ", ...] + l3 = (sublist 3) l2 + -- [["1 2 3 "," 4 5 6 "," 7 8 9 "],...] + l4 = (map (concat . intersperse "|")) l3 + -- ["1 2 3 | 4 5 6 | 7 8 9 ",...] + l5 = (concat . intersperse [line] . sublist 3) l4 + in unlines l5 + where sublist n [] = [] + sublist n xs = ys : sublist n zs + where (ys,zs) = splitAt n xs + line = hyphens ++ "+" ++ hyphens ++ "+" ++ hyphens + hyphens = replicate 9 '-' diff --git a/TBQueue.hs b/TBQueue.hs new file mode 100644 --- /dev/null +++ b/TBQueue.hs @@ -0,0 +1,40 @@ +module TBQueue (TBQueue, newTBQueue, writeTBQueue, readTBQueue) where + +import Control.Concurrent.STM + (STM, TVar, newTVar, readTVar, writeTVar, retry) + +-- < + +newTBQueue :: Int -> STM (TBQueue a) +newTBQueue size = do + read <- newTVar [] + write <- newTVar [] + cap <- newTVar size + return (TBQueue cap read write) + +writeTBQueue :: TBQueue a -> a -> STM () +writeTBQueue (TBQueue cap _read write) a = do + avail <- readTVar cap -- <2> + if avail == 0 -- <3> + then retry -- <4> + else writeTVar cap (avail - 1) -- <5> + listend <- readTVar write + writeTVar write (a:listend) + +readTBQueue :: TBQueue a -> STM a +readTBQueue (TBQueue cap read write) = do + avail <- readTVar cap -- <6> + writeTVar cap (avail + 1) + xs <- readTVar read + case xs of + (x:xs') -> do writeTVar read xs' + return x + [] -> do ys <- readTVar write + case ys of + [] -> retry + _ -> do let (z:zs) = reverse ys + writeTVar write [] + writeTVar read zs + return z +-- >> diff --git a/TChan.hs b/TChan.hs new file mode 100644 --- /dev/null +++ b/TChan.hs @@ -0,0 +1,72 @@ +import Control.Concurrent.STM (STM, TVar, newTVar, readTVar, writeTVar, retry, atomically) + +-- < STM a +readTChan (TChan readVar _) = do + listHead <- readTVar readVar + head <- readTVar listHead + case head of + TNil -> retry + TCons val tail -> do + writeTVar readVar tail + return val + +writeTChan :: TChan a -> a -> STM () +writeTChan (TChan _ writeVar) a = do + newListEnd <- newTVar TNil + listEnd <- readTVar writeVar + writeTVar writeVar newListEnd + writeTVar listEnd (TCons a newListEnd) +-- >> + +-- < STM (TChan a) +dupTChan (TChan _ writeVar) = do + hole <- readTVar writeVar + newReadVar <- newTVar hole + return (TChan newReadVar writeVar) +-- >> + +-- < a -> STM () +unGetTChan (TChan readVar _) a = do + listHead <- readTVar readVar + newHead <- newTVar (TCons a listHead) + writeTVar readVar newHead +-- >> + +-- < STM Bool +isEmptyTChan (TChan read _write) = do + listhead <- readTVar read + head <- readTVar listhead + case head of + TNil -> return True + TCons _ _ -> return False +-- >> + +main = do + c <- atomically $ newTChan + atomically $ writeTChan c 'a' + atomically (readTChan c) >>= print + atomically (isEmptyTChan c) >>= print + atomically $ unGetTChan c 'a' + atomically (isEmptyTChan c) >>= print + atomically (readTChan c) >>= print + c2 <- atomically $ dupTChan c + atomically $ writeTChan c 'b' + atomically (readTChan c) >>= print + atomically (readTChan c2) >>= print diff --git a/TList.hs b/TList.hs new file mode 100644 --- /dev/null +++ b/TList.hs @@ -0,0 +1,26 @@ +module TList (TList, newTList, readTList, writeTList) where + +import Control.Concurrent.STM + +-- < a -> STM () +writeTList (TList v) a = do + list <- readTVar v + writeTVar v (list ++ [a]) + +readTList :: TList a -> STM a +readTList (TList v) = do + xs <- readTVar v + case xs of + [] -> retry + (x:xs') -> do + writeTVar v xs' + return x +-- >> diff --git a/TQueue.hs b/TQueue.hs new file mode 100644 --- /dev/null +++ b/TQueue.hs @@ -0,0 +1,32 @@ +module TQueue (TQueue, newTQueue, writeTQueue, readTQueue) where + +import Control.Concurrent.STM (STM, TVar, newTVar, readTVar, writeTVar, retry) + +-- < a -> STM () +writeTQueue (TQueue _read write) a = do + listend <- readTVar write + writeTVar write (a:listend) + +readTQueue :: TQueue a -> STM a +readTQueue (TQueue read write) = do + xs <- readTVar read + case xs of + (x:xs') -> do writeTVar read xs' + return x + [] -> do ys <- readTVar write + case ys of + [] -> retry -- <1> + _ -> do let (z:zs) = reverse ys -- <2> + writeTVar write [] + writeTVar read zs + return z +-- >> diff --git a/TimeIt.hs b/TimeIt.hs new file mode 100644 --- /dev/null +++ b/TimeIt.hs @@ -0,0 +1,14 @@ +-- (c) Simon Marlow 2011, see the file LICENSE for copying terms. + +-- Returns the number of realtime seconds an action takes + +module TimeIt (timeit) where + +import Data.Time + +timeit :: IO a -> IO (a,Double) +timeit io = do + t0 <- getCurrentTime + a <- io + t1 <- getCurrentTime + return (a, realToFrac (t1 `diffUTCTime` t0)) diff --git a/catch-mask.hs b/catch-mask.hs new file mode 100644 --- /dev/null +++ b/catch-mask.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE BangPatterns #-} +import System.IO +import System.IO.Error +import System.Environment +import Control.Exception as E + +-- <
if isDoesNotExistError e + then loop n fs + else throwIO e) $ + do + getMaskingState >>= print + h <- openFile f ReadMode + s <- hGetContents h + loop (n + length (lines s)) fs + + n <- loop 0 fs + print n +-- >> diff --git a/catch-mask2.hs b/catch-mask2.hs new file mode 100644 --- /dev/null +++ b/catch-mask2.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE BangPatterns #-} +import System.IO +import System.IO.Error +import System.Environment +import Control.Exception + +-- <
>= print + r <- Control.Exception.try (openFile f ReadMode) + case r of + Left e | isDoesNotExistError e -> loop n fs + | otherwise -> throwIO e + Right h -> do + s <- hGetContents h + loop (n + length (lines s)) fs + + n <- loop 0 fs + print n +-- >> diff --git a/chan.hs b/chan.hs new file mode 100644 --- /dev/null +++ b/chan.hs @@ -0,0 +1,52 @@ +import Control.Concurrent hiding (Chan, newChan, readChan, writeChan) + +-- <> + +-- <> + +-- <> + +-- < a -> IO () +writeChan (Chan _ writeVar) val = do + newHole <- newEmptyMVar + oldHole <- takeMVar writeVar + putMVar oldHole (Item val newHole) + putMVar writeVar newHole +-- >> + +-- < IO a +readChan (Chan readVar _) = do + stream <- takeMVar readVar -- <1> + Item val tail <- takeMVar stream -- <2> + putMVar readVar tail -- <3> + return val +-- >> + +-- < IO (Chan a) +dupChan (Chan _ writeVar) = do + hole <- readMVar writeVar + newReadVar <- newMVar hole + return (Chan newReadVar writeVar) +-- >> + +main = do + c <- newChan + writeChan c 'a' + readChan c >>= print diff --git a/chan2.hs b/chan2.hs new file mode 100644 --- /dev/null +++ b/chan2.hs @@ -0,0 +1,66 @@ +import Control.Concurrent hiding (Chan, newChan, readChan, writeChan, dupChan) + +-- <> + +-- <> + +-- <> + +-- < a -> IO () +writeChan (Chan _ writeVar) val = do + newHole <- newEmptyMVar + oldHole <- takeMVar writeVar + putMVar oldHole (Item val newHole) + putMVar writeVar newHole +-- >> + +-- < IO a +readChan (Chan readVar _) = do + stream <- takeMVar readVar + Item val tail <- readMVar stream -- <1> + putMVar readVar tail + return val +-- >> + +-- < IO (Chan a) +dupChan (Chan _ writeVar) = do + hole <- takeMVar writeVar + putMVar writeVar hole + newReadVar <- newMVar hole + return (Chan newReadVar writeVar) +-- >> + +-- < a -> IO () +unGetChan (Chan readVar _) val = do + newReadEnd <- newEmptyMVar -- <1> + readEnd <- takeMVar readVar -- <2> + putMVar newReadEnd (Item val readEnd) -- <3> + putMVar readVar newReadEnd -- <4> +-- >> + +main = do + c <- newChan + writeChan c 'a' + readChan c >>= print + c2 <- dupChan c + writeChan c 'b' + readChan c >>= print + readChan c2 >>= print diff --git a/chan3.hs b/chan3.hs new file mode 100644 --- /dev/null +++ b/chan3.hs @@ -0,0 +1,54 @@ +import Control.Concurrent hiding (Chan, newChan, readChan, writeChan, dupChan) +import Control.Exception + +-- <> + +-- <> + +-- <> + +-- < a -> IO () +wrongWriteChan (Chan _ writeVar) val = do + newHole <- newEmptyMVar + modifyMVar_ writeVar $ \oldHole -> do + putMVar oldHole (Item val newHole) -- <1> + return newHole -- <2> +-- >> + +-- < a -> IO () +writeChan (Chan _ writeVar) val = do + newHole <- newEmptyMVar + mask_ $ do + oldHole <- takeMVar writeVar + putMVar oldHole (Item val newHole) + putMVar writeVar newHole +-- >> + +-- < IO a +readChan (Chan readVar _) = do + modifyMVar readVar $ \stream -> do + Item val tail <- readMVar stream + return (tail, val) +-- >> + +main = do + c <- newChan + writeChan c 'a' + readChan c >>= print diff --git a/chat.hs b/chat.hs new file mode 100644 --- /dev/null +++ b/chat.hs @@ -0,0 +1,251 @@ +{- + Adapted from haskell-chat-sever-example which is + Copyright (c) 2012, Joseph Adams + + Modifications (c) 2012, Simon Marlow +-} + +{-# LANGUAGE RecordWildCards #-} +module Main where + +import ConcurrentUtils + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Concurrent.Async +import qualified Data.Map as Map +import Data.Map (Map) +import System.IO +import Control.Exception +import Network +import Control.Monad +import Text.Printf + +{- +Notes + +- protocol: + Server: "Name?" + Client: + -- if is already in use, ask for another name + -- Commands: + -- /tell message... (single-user tell) + -- /quit (exit) + -- /kick (kick another user) + -- message... (broadcast to all connected users) + +- a client needs to both listen for commands from the socket and + listen for activity from other clients. Therefore we're going to + need at least two threads per client (for listening to multiple + things). Easiest is to use STM for in-process communication, and to + have a receiving thread that listens on the socket and forwards to a + TChan. + +- Handle all errors properly, be async-exception safe + +- Consistency: + - if two clients simultaneously kick a third client, only one will be + successful + +See doc/lab-exercises.tex for some ideas for enhancements that you +could try. + +-} + +-- <
hClose handle) + +port :: Int +port = 44444 +-- >> + + +-- --------------------------------------------------------------------------- +-- Data structures and initialisation + +-- <> + +-- < Handle -> STM Client +newClient name handle = do + c <- newTChan + k <- newTVar Nothing + return Client { clientName = name + , clientHandle = handle + , clientSendChan = c + , clientKicked = k + } +-- >> + +-- <> + +-- <> + +-- ----------------------------------------------------------------------------- +-- Basic operations + +-- < Message -> STM () +broadcast Server{..} msg = do + clientmap <- readTVar clients + mapM_ (\client -> sendMessage client msg) (Map.elems clientmap) +-- >> + +-- < Message -> STM () +sendMessage Client{..} msg = + writeTChan clientSendChan msg +-- >> + +-- < ClientName -> Message -> STM Bool +sendToName server@Server{..} name msg = do + clientmap <- readTVar clients + case Map.lookup name clientmap of + Nothing -> return False + Just client -> sendMessage client msg >> return True +-- >> + +tell :: Server -> Client -> ClientName -> String -> IO () +tell server@Server{..} Client{..} who msg = do + ok <- atomically $ sendToName server who (Tell clientName msg) + if ok + then return () + else hPutStrLn clientHandle (who ++ " is not connected.") + +kick :: Server -> ClientName -> ClientName -> STM () +kick server@Server{..} who by = do + clientmap <- readTVar clients + case Map.lookup who clientmap of + Nothing -> + void $ sendToName server by (Notice $ who ++ " is not connected") + Just victim -> do + writeTVar (clientKicked victim) $ Just ("by " ++ by) + void $ sendToName server by (Notice $ "you kicked " ++ who) + +-- ----------------------------------------------------------------------------- +-- The main server + +talk :: Handle -> Server -> IO () +talk handle server@Server{..} = do + hSetNewlineMode handle universalNewlineMode + -- Swallow carriage returns sent by telnet clients + hSetBuffering handle LineBuffering + readName + where +-- < do -- <1> + ok <- checkAddClient server name handle + case ok of + Nothing -> restore $ do -- <2> + hPrintf handle + "The name %s is in use, please choose another\n" name + readName + Just client -> + restore (runClient server client) -- <3> + `finally` removeClient server name +-- >> + +-- < ClientName -> Handle -> IO (Maybe Client) +checkAddClient server@Server{..} name handle = atomically $ do + clientmap <- readTVar clients + if Map.member name clientmap + then return Nothing + else do client <- newClient name handle + writeTVar clients $ Map.insert name client clientmap + broadcast server $ Notice (name ++ " has connected") + return (Just client) +-- >> + +-- < ClientName -> IO () +removeClient server@Server{..} name = atomically $ do + modifyTVar' clients $ Map.delete name + broadcast server $ Notice (name ++ " has disconnected") +-- >> + +-- < Client -> IO () +runClient serv@Server{..} client@Client{..} = do + race server receive + return () + where + receive = forever $ do + msg <- hGetLine clientHandle + atomically $ sendMessage client (Command msg) + + server = join $ atomically $ do + k <- readTVar clientKicked + case k of + Just reason -> return $ + hPutStrLn clientHandle $ "You have been kicked: " ++ reason + Nothing -> do + msg <- readTChan clientSendChan + return $ do + continue <- handleMessage serv client msg + when continue $ server +-- >> + +-- < Client -> Message -> IO Bool +handleMessage server client@Client{..} message = + case message of + Notice msg -> output $ "*** " ++ msg + Tell name msg -> output $ "*" ++ name ++ "*: " ++ msg + Broadcast name msg -> output $ "<" ++ name ++ ">: " ++ msg + Command msg -> + case words msg of + ["/kick", who] -> do + atomically $ kick server who clientName + return True + "/tell" : who : what -> do + tell server client who (unwords what) + return True + ["/quit"] -> + return False + ('/':_):_ -> do + hPutStrLn clientHandle $ "Unrecognised command: " ++ msg + return True + _ -> do + atomically $ broadcast server $ Broadcast clientName msg + return True + where + output s = do hPutStrLn clientHandle s; return True +-- >> diff --git a/deadlock1.hs b/deadlock1.hs new file mode 100644 --- /dev/null +++ b/deadlock1.hs @@ -0,0 +1,10 @@ +import Control.Concurrent +import Control.Exception + +-- <
> diff --git a/deadlock2.hs b/deadlock2.hs new file mode 100644 --- /dev/null +++ b/deadlock2.hs @@ -0,0 +1,10 @@ +import Control.Concurrent +import Control.Exception as E + +-- <
> diff --git a/distrib-chat/chat-noslave.hs b/distrib-chat/chat-noslave.hs new file mode 100644 --- /dev/null +++ b/distrib-chat/chat-noslave.hs @@ -0,0 +1,419 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +import Control.Distributed.Process hiding (mask, finally) +import Control.Distributed.Process.Closure +import Control.Distributed.Process.Backend.SimpleLocalnet +import Control.Distributed.Process.Node as Node hiding (newLocalNode) +import Control.Concurrent.Async +import Control.Monad.IO.Class +import Control.Monad +import Text.Printf +import Control.Concurrent +import GHC.Generics (Generic) +import Data.Binary +import Data.Typeable +import Network +import System.IO +import Control.Concurrent.STM +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Foldable as F +import Control.Exception +import System.Environment + +import ConcurrentUtils + +-- --------------------------------------------------------------------------- +-- Data structures and initialisation + +-- < ClientName +clientName (ClientLocal c) = localName c +clientName (ClientRemote c) = remoteName c + +newLocalClient :: ClientName -> Handle -> STM LocalClient +newLocalClient name handle = do + c <- newTChan + k <- newTVar Nothing + return LocalClient { localName = name + , clientHandle = handle + , clientSendChan = c + , clientKicked = k + } +-- >> + + +-- <> + + +-- <> + + +-- < Process Server +newServer pids = do + pid <- getSelfPid + liftIO $ do + s <- newTVarIO pids + c <- newTVarIO Map.empty + o <- newTChanIO + return Server { clients = c, servers = s, proxychan = o, spid = pid } + +localClientNames :: Map ClientName Client -> [ClientName] +localClientNames m = [ localName c | ClientLocal c <- Map.elems m ] +-- >> + +-- ----------------------------------------------------------------------------- +-- Basic operations + +-- < Message -> STM () +sendLocal LocalClient{..} msg = writeTChan clientSendChan msg +-- >> + +-- < ProcessId -> PMessage -> STM () +sendRemote Server{..} pid pmsg = writeTChan proxychan (send pid pmsg) +-- >> + +-- < Client -> Message -> STM () +sendMessage server (ClientLocal client) msg = + sendLocal client msg +sendMessage server (ClientRemote client) msg = + sendRemote server (clientHome client) (MsgSend (remoteName client) msg) +-- >> + +-- < ClientName -> Message -> STM Bool +sendToName server@Server{..} name msg = do + clientmap <- readTVar clients + case Map.lookup name clientmap of + Nothing -> return False + Just client -> sendMessage server client msg >> return True +-- >> + +-- < PMessage -> STM () +sendRemoteAll server@Server{..} pmsg = do + pids <- readTVar servers + mapM_ (\pid -> sendRemote server pid pmsg) pids +-- >> + +-- < Message -> STM () +broadcastLocal server@Server{..} msg = do + clientmap <- readTVar clients + mapM_ sendIfLocal (Map.elems clientmap) + where + sendIfLocal (ClientLocal c) = sendLocal c msg + sendIfLocal (ClientRemote _) = return () +-- >> + +-- < Message -> STM () +broadcast server@Server{..} msg = do + sendRemoteAll server (MsgBroadcast msg) + broadcastLocal server msg +-- >> + +-- < LocalClient -> ClientName -> String -> IO () +tell server@Server{..} LocalClient{..} who msg = do + ok <- atomically $ sendToName server who (Tell localName msg) + if ok + then return () + else hPutStrLn clientHandle (who ++ " is not connected.") +-- >> + +-- < ClientName -> ClientName -> STM () +kick server@Server{..} who by = do + clientmap <- readTVar clients + case Map.lookup who clientmap of + Nothing -> + void $ sendToName server by (Notice $ who ++ " is not connected") + Just (ClientLocal victim) -> do + writeTVar (clientKicked victim) $ Just ("by " ++ by) + void $ sendToName server by (Notice $ "you kicked " ++ who) + Just (ClientRemote victim) -> do + sendRemote server (clientHome victim) (MsgKick who by) +-- >> + +-- ----------------------------------------------------------------------------- +-- Handle a local client + +talk :: Server -> Handle -> IO () +talk server@Server{..} handle = do + hSetNewlineMode handle universalNewlineMode + -- Swallow carriage returns sent by telnet clients + hSetBuffering handle LineBuffering + readName + where +-- < do + client <- atomically $ newLocalClient name handle + ok <- atomically $ checkAddClient server (ClientLocal client) + if not ok + then restore $ do + hPrintf handle + "The name %s is in use, please choose another\n" name + readName + else do + atomically $ sendRemoteAll server (MsgNewClient name spid) + restore (runClient server client) + `finally` disconnectLocalClient server name +-- >> + +checkAddClient :: Server -> Client -> STM Bool +checkAddClient server@Server{..} client = do + clientmap <- readTVar clients + let name = clientName client + if Map.member name clientmap + then return False + else do writeTVar clients (Map.insert name client clientmap) + broadcastLocal server $ Notice $ name ++ " has connected" + return True + +deleteClient :: Server -> ClientName -> STM () +deleteClient server@Server{..} name = do + modifyTVar' clients $ Map.delete name + broadcastLocal server $ Notice $ name ++ " has disconnected" + +disconnectLocalClient :: Server -> ClientName -> IO () +disconnectLocalClient server@Server{..} name = atomically $ do + deleteClient server name + sendRemoteAll server (MsgClientDisconnected name spid) + +-- < LocalClient -> IO () +runClient serv@Server{..} client@LocalClient{..} = do + race server receive + return () + where + receive = forever $ do + msg <- hGetLine clientHandle + atomically $ sendLocal client (Command msg) + + server = join $ atomically $ do + k <- readTVar clientKicked + case k of + Just reason -> return $ + hPutStrLn clientHandle $ "You have been kicked: " ++ reason + Nothing -> do + msg <- readTChan clientSendChan + return $ do + continue <- handleMessage serv client msg + when continue $ server +-- >> + +-- < LocalClient -> Message -> IO Bool +handleMessage server client@LocalClient{..} message = + case message of + Notice msg -> output $ "*** " ++ msg + Tell name msg -> output $ "*" ++ name ++ "*: " ++ msg + Broadcast name msg -> output $ "<" ++ name ++ ">: " ++ msg + Command msg -> + case words msg of + ["/kick", who] -> do + atomically $ kick server who localName + return True + "/tell" : who : what -> do + tell server client who (unwords what) + return True + ["/quit"] -> + return False + ('/':_):_ -> do + hPutStrLn clientHandle $ "Unrecognised command: " ++ msg + return True + _ -> do + atomically $ broadcast server $ Broadcast localName msg + return True + where + output s = do hPutStrLn clientHandle s; return True +-- >> + +-- ----------------------------------------------------------------------------- +-- Main server + +-- < Int -> IO () +socketListener server port = withSocketsDo $ do + sock <- listenOn (PortNumber (fromIntegral port)) + printf "Listening on port %d\n" port + forever $ do + (handle, host, port) <- accept sock + printf "Accepted connection from %s: %s\n" host (show port) + forkFinally (talk server handle) + (\_ -> hClose handle) +-- >> + +-- < Process () +proxy Server{..} = forever $ join $ liftIO $ atomically $ readTChan proxychan +-- >> + +chatServer :: Int -> Process () +chatServer port = do + server <- newServer [] + liftIO $ forkIO (socketListener server port) + spawnLocal (proxy server) + forever $ + receiveWait + [ match $ handleRemoteMessage server + , match $ handleMonitorNotification server + , matchIf (\(WhereIsReply l _) -> l == "chatServer") $ + handleWhereIsReply server + , matchAny $ \_ -> return () -- discard unknown messages + ] + +handleWhereIsReply _ (WhereIsReply _ Nothing) = return () +handleWhereIsReply server@Server{..} (WhereIsReply _ (Just pid)) = + liftIO $ atomically $ do + clientmap <- readTVar clients + -- send our own server info,and request a response: + sendRemote server pid (MsgServerInfo True spid (localClientNames clientmap)) + +handleMonitorNotification :: Server -> ProcessMonitorNotification -> Process () +handleMonitorNotification + server@Server{..} (ProcessMonitorNotification _ pid _) = do + say (printf "server on %s has died" (show pid)) + liftIO $ atomically $ do + old_pids <- readTVar servers + writeTVar servers (filter (/= pid) old_pids) + clientmap <- readTVar clients + let + now_disconnected (ClientRemote RemoteClient{..}) = clientHome == pid + now_disconnected _ = False + + disconnected_clients = Map.filter now_disconnected clientmap + + writeTVar clients (Map.filter (not . now_disconnected) clientmap) + mapM_ (deleteClient server) (Map.keys disconnected_clients) + +handleRemoteMessage :: Server -> PMessage -> Process () +handleRemoteMessage server@Server{..} m = + case m of + MsgServerInfo rsvp pid clients -> newServerInfo server rsvp pid clients + MsgSend name msg -> liftIO $ atomically $ void $ sendToName server name msg + MsgBroadcast msg -> liftIO $ atomically $ broadcastLocal server msg + MsgKick who by -> liftIO $ atomically $ kick server who by + + MsgNewClient name pid -> liftIO $ atomically $ do + ok <- checkAddClient server (ClientRemote (RemoteClient name pid)) + when (not ok) $ + sendRemote server pid (MsgKick name "SYSTEM") + + MsgClientDisconnected name pid -> liftIO $ atomically $ do + clientmap <- readTVar clients + case Map.lookup name clientmap of + Nothing -> return () + Just (ClientRemote (RemoteClient _ pid')) | pid == pid' -> + deleteClient server name + Just _ -> + return () + +newServerInfo :: Server -> Bool -> ProcessId -> [ClientName] -> Process () +newServerInfo server@Server{..} rsvp pid remote_clients = do + liftIO $ printf "%s received server info from %s\n" (show spid) (show pid) + join $ liftIO $ atomically $ do + old_pids <- readTVar servers + writeTVar servers (pid : filter (/= pid) old_pids) + + clientmap <- readTVar clients + + let new_clientmap = Map.union clientmap $ Map.fromList + [ (n, ClientRemote (RemoteClient n pid)) | n <- remote_clients ] + -- ToDo: should remove other remote clients with this pid + -- ToDo: also deal with conflicts + writeTVar clients new_clientmap + + when rsvp $ do + sendRemote server pid + (MsgServerInfo False spid (localClientNames new_clientmap)) + + -- monitor the new server + return (when (pid `notElem` old_pids) $ void $ monitor pid) + +remotable ['chatServer] + +port :: Int +port = 44444 + +master :: Backend -> String -> Process () +master backend port = do + + mynode <- getSelfNode + + peers0 <- liftIO $ findPeers backend 1000000 + let peers = filter (/= mynode) peers0 + + say ("peers are " ++ show peers) + + mypid <- getSelfPid + register "chatServer" mypid + + forM_ peers $ \peer -> do + whereisRemoteAsync peer "chatServer" + + chatServer (read port :: Int) + +-- <
> + diff --git a/distrib-chat/chat.hs b/distrib-chat/chat.hs new file mode 100644 --- /dev/null +++ b/distrib-chat/chat.hs @@ -0,0 +1,355 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +import Control.Distributed.Process hiding (mask, finally) +import Control.Distributed.Process.Closure +import Control.Concurrent.Async +import Control.Monad.IO.Class +import Control.Monad +import Text.Printf +import Control.Concurrent +import GHC.Generics (Generic) +import Data.Binary +import Data.Typeable +import Network +import System.IO +import Control.Concurrent.STM +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Foldable as F +import Control.Exception + +import ConcurrentUtils +import DistribUtils + +-- --------------------------------------------------------------------------- +-- Data structures and initialisation + +-- < ClientName +clientName (ClientLocal c) = localName c +clientName (ClientRemote c) = remoteName c + +newLocalClient :: ClientName -> Handle -> STM LocalClient +newLocalClient name handle = do + c <- newTChan + k <- newTVar Nothing + return LocalClient { localName = name + , clientHandle = handle + , clientSendChan = c + , clientKicked = k + } +-- >> + + +-- <> + + +-- <> + + +-- < Process Server +newServer pids = do + pid <- getSelfPid + liftIO $ do + s <- newTVarIO pids + c <- newTVarIO Map.empty + o <- newTChanIO + return Server { clients = c, servers = s, proxychan = o, spid = pid } +-- >> + +-- ----------------------------------------------------------------------------- +-- Basic operations + +-- < Message -> STM () +sendLocal LocalClient{..} msg = writeTChan clientSendChan msg +-- >> + +-- < ProcessId -> PMessage -> STM () +sendRemote Server{..} pid pmsg = writeTChan proxychan (send pid pmsg) +-- >> + +-- < Client -> Message -> STM () +sendMessage server (ClientLocal client) msg = + sendLocal client msg +sendMessage server (ClientRemote client) msg = + sendRemote server (clientHome client) (MsgSend (remoteName client) msg) +-- >> + +-- < ClientName -> Message -> STM Bool +sendToName server@Server{..} name msg = do + clientmap <- readTVar clients + case Map.lookup name clientmap of + Nothing -> return False + Just client -> sendMessage server client msg >> return True +-- >> + +-- < PMessage -> STM () +sendRemoteAll server@Server{..} pmsg = do + pids <- readTVar servers + mapM_ (\pid -> sendRemote server pid pmsg) pids +-- >> + +-- < Message -> STM () +broadcastLocal server@Server{..} msg = do + clientmap <- readTVar clients + mapM_ sendIfLocal (Map.elems clientmap) + where + sendIfLocal (ClientLocal c) = sendLocal c msg + sendIfLocal (ClientRemote _) = return () +-- >> + +-- < Message -> STM () +broadcast server@Server{..} msg = do + sendRemoteAll server (MsgBroadcast msg) + broadcastLocal server msg +-- >> + +-- < LocalClient -> ClientName -> String -> IO () +tell server@Server{..} LocalClient{..} who msg = do + ok <- atomically $ sendToName server who (Tell localName msg) + if ok + then return () + else hPutStrLn clientHandle (who ++ " is not connected.") +-- >> + +-- < ClientName -> ClientName -> STM () +kick server@Server{..} who by = do + clientmap <- readTVar clients + case Map.lookup who clientmap of + Nothing -> + void $ sendToName server by (Notice $ who ++ " is not connected") + Just (ClientLocal victim) -> do + writeTVar (clientKicked victim) $ Just ("by " ++ by) + void $ sendToName server by (Notice $ "you kicked " ++ who) + Just (ClientRemote victim) -> do + sendRemote server (clientHome victim) (MsgKick who by) +-- >> + +-- ----------------------------------------------------------------------------- +-- Handle a local client + +talk :: Server -> Handle -> IO () +talk server@Server{..} handle = do + hSetNewlineMode handle universalNewlineMode + -- Swallow carriage returns sent by telnet clients + hSetBuffering handle LineBuffering + readName + where +-- < do + client <- atomically $ newLocalClient name handle + ok <- atomically $ checkAddClient server (ClientLocal client) + if not ok + then restore $ do + hPrintf handle + "The name %s is in use, please choose another\n" name + readName + else do + atomically $ sendRemoteAll server (MsgNewClient name spid) + restore (runClient server client) + `finally` disconnectLocalClient server name +-- >> + +checkAddClient :: Server -> Client -> STM Bool +checkAddClient server@Server{..} client = do + clientmap <- readTVar clients + let name = clientName client + if Map.member name clientmap + then return False + else do writeTVar clients (Map.insert name client clientmap) + broadcastLocal server $ Notice $ name ++ " has connected" + return True + +deleteClient :: Server -> ClientName -> STM () +deleteClient server@Server{..} name = do + modifyTVar' clients $ Map.delete name + broadcastLocal server $ Notice $ name ++ " has disconnected" + +disconnectLocalClient :: Server -> ClientName -> IO () +disconnectLocalClient server@Server{..} name = atomically $ do + deleteClient server name + sendRemoteAll server (MsgClientDisconnected name spid) + +-- < LocalClient -> IO () +runClient serv@Server{..} client@LocalClient{..} = do + race server receive + return () + where + receive = forever $ do + msg <- hGetLine clientHandle + atomically $ sendLocal client (Command msg) + + server = join $ atomically $ do + k <- readTVar clientKicked + case k of + Just reason -> return $ + hPutStrLn clientHandle $ "You have been kicked: " ++ reason + Nothing -> do + msg <- readTChan clientSendChan + return $ do + continue <- handleMessage serv client msg + when continue $ server +-- >> + +-- < LocalClient -> Message -> IO Bool +handleMessage server client@LocalClient{..} message = + case message of + Notice msg -> output $ "*** " ++ msg + Tell name msg -> output $ "*" ++ name ++ "*: " ++ msg + Broadcast name msg -> output $ "<" ++ name ++ ">: " ++ msg + Command msg -> + case words msg of + ["/kick", who] -> do + atomically $ kick server who localName + return True + "/tell" : who : what -> do + tell server client who (unwords what) + return True + ["/quit"] -> + return False + ('/':_):_ -> do + hPutStrLn clientHandle $ "Unrecognised command: " ++ msg + return True + _ -> do + atomically $ broadcast server $ Broadcast localName msg + return True + where + output s = do hPutStrLn clientHandle s; return True +-- >> + +-- ----------------------------------------------------------------------------- +-- Main server + +-- < Int -> IO () +socketListener server port = withSocketsDo $ do + sock <- listenOn (PortNumber (fromIntegral port)) + printf "Listening on port %d\n" port + forever $ do + (handle, host, port) <- accept sock + printf "Accepted connection from %s: %s\n" host (show port) + forkFinally (talk server handle) + (\_ -> hClose handle) +-- >> + +-- < Process () +proxy Server{..} = forever $ join $ liftIO $ atomically $ readTChan proxychan +-- >> + +-- < Process () +chatServer port = do + server <- newServer [] + liftIO $ forkIO (socketListener server port) -- <1> + spawnLocal (proxy server) -- <2> + forever $ do m <- expect; handleRemoteMessage server m -- <3> +-- >> + +-- < PMessage -> Process () +handleRemoteMessage server@Server{..} m = liftIO $ atomically $ + case m of + MsgServers pids -> writeTVar servers (filter (/= spid) pids) -- <1> + MsgSend name msg -> void $ sendToName server name msg -- <2> + MsgBroadcast msg -> broadcastLocal server msg -- <2> + MsgKick who by -> kick server who by -- <2> + + MsgNewClient name pid -> do -- <3> + ok <- checkAddClient server (ClientRemote (RemoteClient name pid)) + when (not ok) $ + sendRemote server pid (MsgKick name "SYSTEM") + + MsgClientDisconnected name pid -> do -- <4> + clientmap <- readTVar clients + case Map.lookup name clientmap of + Nothing -> return () + Just (ClientRemote (RemoteClient _ pid')) | pid == pid' -> + deleteClient server name + Just _ -> + return () +-- >> + +remotable ['chatServer] + +-- <
Process () +master peers = do + + let run nid port = do + say $ printf "spawning on %s" (show nid) + spawn nid ($(mkClosure 'chatServer) port) + + pids <- zipWithM run peers [port+1..] + mypid <- getSelfPid + let all_pids = mypid : pids + mapM_ (\pid -> send pid (MsgServers all_pids)) all_pids + + chatServer port + +main = distribMain master Main.__remoteTable +-- >> diff --git a/distrib-db/Database.hs b/distrib-db/Database.hs new file mode 100644 --- /dev/null +++ b/distrib-db/Database.hs @@ -0,0 +1,31 @@ +module Database ( + Database, + Key, Value, + createDB, + get, set, + rcdata, + ) where + +import Control.Distributed.Process + +import qualified Data.Map as Map +import Data.Map (Map) + +type Key = String +type Value = String + +type Database = ProcessId + +createDB :: [NodeId] -> Process Database +createDB nodes = error "not implemented!" -- exercise + +set :: Database -> Key -> Value -> Process () +set db k v = error "not implemented!" -- exercise + +get :: Database -> Key -> Process (Maybe Value) +get db k = error "not implemented!" -- exercise + +rcdata :: RemoteTable -> RemoteTable +rcdata = id + -- For the exercise, change this to include your + -- remote metadata, e.g. rcdata = Database.__remoteTable diff --git a/distrib-db/db.hs b/distrib-db/db.hs new file mode 100644 --- /dev/null +++ b/distrib-db/db.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Distributed.Process +import Control.Monad.IO.Class +import Control.Monad +import System.IO + +import DistribUtils + +import Database (Database, createDB, get, set, rcdata) + +main = distribMain master rcdata + +master :: [NodeId] -> Process () +master peers = do + db <- createDB peers + + f <- liftIO $ readFile "Database.hs" + let ws = words f + + zipWithM_ (set db) ws (tail ws) + + get db "module" >>= liftIO . print + get db "xxxx" >>= liftIO . print + + forever $ do + l <- liftIO $ do putStr "key: "; hFlush stdout; getLine + when (not (null l)) $ do + r <- get db l + liftIO $ putStrLn ("response: " ++ show r) + + return () diff --git a/distrib-ping/ping-fail.hs b/distrib-ping/ping-fail.hs new file mode 100644 --- /dev/null +++ b/distrib-ping/ping-fail.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-} +{-# OPTIONS_GHC -Wall #-} +import Control.Distributed.Process +import Control.Distributed.Process.Closure + +import Text.Printf +import GHC.Generics (Generic) +import Data.Binary +import Data.Typeable + +import DistribUtils + +-- <> + +-- <> + +-- <> + +master :: Process () +master = do + node <- getSelfNode + + say $ printf "spawning on %s" (show node) + pid <- spawn node $(mkStaticClosure 'pingServer) + + mypid <- getSelfPid + say $ printf "sending ping to %s" (show pid) + +-- < + receiveWait + [ match $ \(Pong _) -> do + say "pong." + terminate + , match $ \(ProcessMonitorNotification _ref deadpid reason) -> do + say (printf "process %s died: %s" (show deadpid) (show reason)) + terminate + ] +-- >> + +-- <
master) Main.__remoteTable +-- >> diff --git a/distrib-ping/ping-multi.hs b/distrib-ping/ping-multi.hs new file mode 100644 --- /dev/null +++ b/distrib-ping/ping-multi.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-} +{-# OPTIONS_GHC -Wall #-} +import Control.Distributed.Process +import Control.Distributed.Process.Closure + +import Control.Monad +import Text.Printf +import GHC.Generics (Generic) +import Data.Binary +import Data.Typeable + +import DistribUtils + +-- < + +instance Binary Message -- <2> +-- >> + +-- < + say $ printf "ping received from %s" (show from) -- <2> + mypid <- getSelfPid -- <3> + send from (Pong mypid) -- <4> +-- >> + +-- <> + +-- < Process () -- <1> +master peers = do + + ps <- forM peers $ \nid -> do -- <2> + say $ printf "spawning on %s" (show nid) + spawn nid $(mkStaticClosure 'pingServer) + + mypid <- getSelfPid + + forM_ ps $ \pid -> do -- <3> + say $ printf "pinging %s" (show pid) + send pid (Ping mypid) + + waitForPongs ps -- <4> + + say "All pongs successfully received" + terminate + +waitForPongs :: [ProcessId] -> Process () -- <5> +waitForPongs [] = return () +waitForPongs ps = do + m <- expect + case m of + Pong p -> waitForPongs (filter (/= p) ps) + _ -> say "MASTER received ping" >> terminate +-- >> + +-- <
> diff --git a/distrib-ping/ping-tc-merge.hs b/distrib-ping/ping-tc-merge.hs new file mode 100644 --- /dev/null +++ b/distrib-ping/ping-tc-merge.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-} +{-# OPTIONS_GHC -Wall #-} +import Control.Distributed.Process +import Control.Distributed.Process.Closure + +import Control.Monad +import Text.Printf +import GHC.Generics (Generic) +import Data.Binary +import Data.Typeable + +import DistribUtils + +-- <> + +-- <> + +-- <> + +-- < Process () +master peers = do + + ps <- forM peers $ \nid -> do + say $ printf "spawning on %s" (show nid) + spawn nid $(mkStaticClosure 'pingServer) + + ports <- forM ps $ \pid -> do + say $ printf "pinging %s" (show pid) + (sendport,recvport) <- newChan + send pid (Ping sendport) + return recvport + + oneport <- mergePortsBiased ports -- <1> + waitForPongs oneport ps -- <2> + + say "All pongs successfully received" + terminate + +waitForPongs :: ReceivePort ProcessId -> [ProcessId] -> Process () +waitForPongs _ [] = return () +waitForPongs port ps = do + pid <- receiveChan port + waitForPongs port (filter (/= pid) ps) +-- >> + +-- <
> diff --git a/distrib-ping/ping-tc-notify.hs b/distrib-ping/ping-tc-notify.hs new file mode 100644 --- /dev/null +++ b/distrib-ping/ping-tc-notify.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-} +{-# OPTIONS_GHC -Wall #-} +import Control.Distributed.Process +import Control.Distributed.Process.Closure + +import Control.Monad +import Text.Printf +import GHC.Generics (Generic) +import Data.Binary +import Data.Typeable + +import DistribUtils + +-- <> + +-- <> + +-- <> + +-- < Process () -- <1> +master peers = do + + ps <- forM peers $ \nid -> do -- <2> + say $ printf "spawning on %s" (show nid) + spawn nid $(mkStaticClosure 'pingServer) + + mapM_ monitor ps + + mypid <- getSelfPid + + ports <- forM ps $ \pid -> do + say $ printf "pinging %s" (show pid) + (sendport,recvport) <- newChan + send pid (Ping sendport) + return recvport + + let loop [] = return () + loop (port:ps) = do + receiveWait + [ match $ \(ProcessMonitorNotification ref pid reason) -> do + say (show pid ++ " died: " ++ show reason) + loop (port:ps) + , matchChan port $ \p -> do + say "pong on channel" + loop ps + ] + loop ports + + say "All pongs successfully received" + terminate +-- >> + +-- <
> diff --git a/distrib-ping/ping-tc.hs b/distrib-ping/ping-tc.hs new file mode 100644 --- /dev/null +++ b/distrib-ping/ping-tc.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-} +{-# OPTIONS_GHC -Wall #-} +import Control.Distributed.Process +import Control.Distributed.Process.Closure + +import Control.Monad +import Text.Printf +import GHC.Generics (Generic) +import Data.Binary +import Data.Typeable + +import DistribUtils + +-- <> + +-- <> + +-- <> + +-- < Process () +master peers = do + + ps <- forM peers $ \nid -> do + say $ printf "spawning on %s" (show nid) + spawn nid $(mkStaticClosure 'pingServer) + + mapM_ monitor ps + + ports <- forM ps $ \pid -> do + say $ printf "pinging %s" (show pid) + (sendport,recvport) <- newChan -- <1> + send pid (Ping sendport) -- <2> + return recvport + + forM_ ports $ \port -> do -- <3> + _ <- receiveChan port + return () + + say "All pongs successfully received" + terminate +-- >> + +-- <
> diff --git a/distrib-ping/ping.hs b/distrib-ping/ping.hs new file mode 100644 --- /dev/null +++ b/distrib-ping/ping.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-} +{-# OPTIONS_GHC -Wall #-} +import Control.Distributed.Process +import Control.Distributed.Process.Closure + +import DistribUtils + +import Text.Printf +import Data.Binary +import Data.Typeable +import GHC.Generics (Generic) + +-- < + +instance Binary Message -- <2> +-- >> + +-- < + say $ printf "ping received from %s" (show from) -- <2> + mypid <- getSelfPid -- <3> + send from (Pong mypid) -- <4> +-- >> + +-- <> + +-- < + + say $ printf "spawning on %s" (show node) + pid <- spawn node $(mkStaticClosure 'pingServer) -- <2> + + mypid <- getSelfPid -- <3> + say $ printf "sending ping to %s" (show pid) + send pid (Ping mypid) -- <4> + + Pong _ <- expect -- <5> + say "pong." + + terminate -- <6> +-- >> + +-- <
master) Main.__remoteTable +-- >> diff --git a/findpar.hs b/findpar.hs new file mode 100644 --- /dev/null +++ b/findpar.hs @@ -0,0 +1,43 @@ +import System.Directory +import Control.Concurrent +import System.FilePath +import Control.Concurrent.Async +import System.Environment +import Data.List hiding (find) + +main = do + [s,d] <- getArgs + find s d >>= print + +-- < FilePath -> IO (Maybe FilePath) +find s d = do + fs <- getDirectoryContents d + let fs' = sort $ filter (`notElem` [".",".."]) fs + if any (== s) fs' + then return (Just (d s)) + else do + let ps = map (d ) fs' -- <1> + foldr (subfind s) dowait ps [] -- <2> + where + dowait as = loop (reverse as) -- <3> + + loop [] = return Nothing + loop (a:as) = do -- <4> + r <- wait a + case r of + Nothing -> loop as + Just a -> return (Just a) +-- >> + +-- < FilePath + -> ([Async (Maybe FilePath)] -> IO (Maybe FilePath)) + -> [Async (Maybe FilePath)] -> IO (Maybe FilePath) + +subfind s p inner asyncs = do + isdir <- doesDirectoryExist p + if not isdir + then inner asyncs + else withAsync (find s p) $ \a -> inner (a:asyncs) +-- >> diff --git a/findpar2.hs b/findpar2.hs new file mode 100644 --- /dev/null +++ b/findpar2.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE BangPatterns #-} +import System.Directory +import System.FilePath +import Control.Concurrent.Async +import System.Environment +import Data.List hiding (find) +import Control.Exception (finally) +import Data.Maybe (isJust) +import Control.Concurrent.MVar +import Data.IORef +import GHC.Conc (getNumCapabilities) + +-- <
>= print +-- >> + +-- < String -> FilePath -> IO (Maybe FilePath) +find sem s d = do + fs <- getDirectoryContents d + let fs' = sort $ filter (`notElem` [".",".."]) fs + if any (== s) fs' + then return (Just (d s)) + else do + let ps = map (d ) fs' -- <1> + foldr (subfind sem s) dowait ps [] -- <2> + where + dowait as = loop (reverse as) -- <3> + + loop [] = return Nothing + loop (a:as) = do -- <4> + r <- wait a -- <5> + case r of + Nothing -> loop as -- <6> + Just a -> return (Just a) -- <7> +-- >> + +-- < String -> FilePath + -> ([Async (Maybe FilePath)] -> IO (Maybe FilePath)) + -> [Async (Maybe FilePath)] -> IO (Maybe FilePath) + +subfind sem s p inner asyncs = do + isdir <- doesDirectoryExist p + if not isdir + then inner asyncs + else do + q <- tryAcquireNBSem sem -- <1> + if q + then do + let dofind = find sem s p `finally` releaseNBSem sem -- <2> + withAsync dofind $ \a -> inner (a:asyncs) + else do + r <- find sem s p -- <3> + case r of + Nothing -> inner asyncs + Just _ -> return r +-- >> + +-- < IO NBSem +newNBSem i = do + m <- newMVar i + return (NBSem m) + +tryAcquireNBSem :: NBSem -> IO Bool +tryAcquireNBSem (NBSem m) = + modifyMVar m $ \i -> + if i == 0 + then return (i, False) + else let !z = i-1 in return (z, True) + +releaseNBSem :: NBSem -> IO () +releaseNBSem (NBSem m) = + modifyMVar m $ \i -> + let !z = i+1 in return (z, ()) +-- >> diff --git a/findpar3.hs b/findpar3.hs new file mode 100644 --- /dev/null +++ b/findpar3.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE BangPatterns,CPP #-} +import System.Directory +import System.FilePath +import Control.Concurrent.Async +import System.Environment +import Data.List hiding (find) +import Control.Exception (finally) +import Data.Maybe (isJust) +import Control.Concurrent.MVar +import Control.Concurrent.STM +import Data.IORef +import GHC.Conc (getNumCapabilities) +import CasIORef + +-- <
>= print +-- >> + +-- < String -> FilePath -> IO (Maybe FilePath) +find sem s d = do + fs <- getDirectoryContents d + let fs' = sort $ filter (`notElem` [".",".."]) fs + if any (== s) fs' + then return (Just (d s)) + else do + let ps = map (d ) fs' -- <1> + foldr (subfind sem s) dowait ps [] -- <2> + where + dowait as = loop (reverse as) -- <3> + + loop [] = return Nothing + loop (a:as) = do -- <4> + r <- wait a -- <5> + case r of + Nothing -> loop as -- <6> + Just a -> return (Just a) -- <7> +-- >> + +-- < String -> FilePath + -> ([Async (Maybe FilePath)] -> IO (Maybe FilePath)) + -> [Async (Maybe FilePath)] -> IO (Maybe FilePath) + +subfind sem s p inner asyncs = do + isdir <- doesDirectoryExist p + if isdir + then do + q <- tryWaitNBSem sem + if q + then withAsync (find sem s p `finally` signalNBSem sem) $ \a -> + inner (a:asyncs) + else do r <- find sem s p + if isJust r then return r else inner asyncs + else inner asyncs +-- >> + +-- < IO NBSem +newNBSem i = do + m <- newIORef i + return (NBSem m) + +tryWaitNBSem :: NBSem -> IO Bool +tryWaitNBSem (NBSem m) = do + atomicModifyIORef m $ \i -> + if i == 0 + then (i, False) + else let !z = i-1 in (z, True) + +signalNBSem :: NBSem -> IO () +signalNBSem (NBSem m) = + atomicModifyIORef m $ \i -> + let !z = i+1 in (z, ()) +-- >> diff --git a/findpar4.hs b/findpar4.hs new file mode 100644 --- /dev/null +++ b/findpar4.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +import System.Directory +import Control.Concurrent +import System.FilePath +import System.Environment +import Data.List hiding (find) +import GHC.Conc (getNumCapabilities) +import Text.Printf + +import Control.Monad.Par.IO +import Control.Monad.Par.Class +import Control.Monad.IO.Class + +import Control.Exception + +-- <
>= print +-- >> + +-- < FilePath -> ParIO (Maybe FilePath) +find s d = do + fs <- liftIO $ getDirectoryContents d + let fs' = sort $ filter (`notElem` [".",".."]) fs + if any (== s) fs' + then return (Just (d s)) + else do + let ps = map (d ) fs' + foldr (subfind s) dowait ps [] + where + dowait vs = loop (reverse vs) + + loop [] = return Nothing + loop (v:vs) = do + r <- get v + case r of + Nothing -> loop vs + Just a -> return (Just a) +-- >> + +-- < FilePath + -> ([IVar (Maybe FilePath)] -> ParIO (Maybe FilePath)) + -> [IVar (Maybe FilePath)] -> ParIO (Maybe FilePath) + +subfind s p inner ivars = do + isdir <- liftIO $ doesDirectoryExist p + if not isdir + then inner ivars + else do v <- new -- <1> + fork (find s p >>= put v) -- <2> + inner (v : ivars) -- <3> +-- >> diff --git a/findseq.hs b/findseq.hs new file mode 100644 --- /dev/null +++ b/findseq.hs @@ -0,0 +1,34 @@ +{-# OPTIONS_GHC -Wall #-} +import System.Directory +import System.FilePath +import System.Environment +import Data.List hiding (find) + +-- <
> + +-- < FilePath -> IO (Maybe FilePath) +find s d = do + fs <- getDirectoryContents d -- <1> + let fs' = sort $ filter (`notElem` [".",".."]) fs -- <2> + if any (== s) fs' -- <3> + then return (Just (d s)) + else loop fs' -- <4> + where + loop [] = return Nothing -- <5> + loop (f:fs) = do + let d' = d f -- <6> + isdir <- doesDirectoryExist d' -- <7> + if isdir + then do r <- find s d' -- <8> + case r of + Just _ -> return r -- <9> + Nothing -> loop fs -- <10> + else loop fs -- <11> +-- >> diff --git a/fork.hs b/fork.hs new file mode 100644 --- /dev/null +++ b/fork.hs @@ -0,0 +1,10 @@ +-- < + forkIO (replicateM_ 100000 (putChar 'A')) -- <2> + replicateM_ 100000 (putChar 'B') -- <3> +-- >> diff --git a/fwaccel.hs b/fwaccel.hs new file mode 100644 --- /dev/null +++ b/fwaccel.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE CPP, BangPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} + +module Main ( main, test {-, maxDistances -} ) where + +import Prelude +import System.Environment +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Interpreter + +-- <> + +-- ----------------------------------------------------------------------------- +-- shortestPaths + +-- < Graph +shortestPaths g0 = run (shortestPathsAcc n (use g0)) + where + Z :. _ :. n = arrayShape g0 +-- >> + +-- < Acc Graph -> Acc Graph +shortestPathsAcc n g0 = foldl1 (>->) steps g0 -- <3> + where + steps :: [ Acc Graph -> Acc Graph ] -- <1> + steps = [ step (unit (constant k)) | k <- [0 .. n-1] ] -- <2> +-- >> + +-- < Acc Graph -> Acc Graph +step k g = generate (shape g) sp -- <1> + where + k' = the k -- <2> + + sp :: Exp DIM2 -> Exp Weight + sp ix = let + (Z :. i :. j) = unlift ix -- <3> + in + A.min (g ! (index2 i j)) -- <4> + (g ! (index2 i k') + g ! (index2 k' j)) +-- >> + +-- ----------------------------------------------------------------------------- +-- Testing + +-- <> + +testGraph :: Graph +testGraph = toAdjMatrix $ + [[ 0, inf, inf, 13, inf, inf], + [inf, 0, inf, inf, 4, 9], + [ 11, inf, 0, inf, inf, inf], + [inf, 3, inf, 0, inf, 7], + [ 15, 5, inf, 1, 0, inf], + [ 11, inf, inf, 14, inf, 0]] + +-- correct result: +expectedResult :: Graph +expectedResult = toAdjMatrix $ + [[0, 16, inf, 13, 20, 20], + [19, 0, inf, 5, 4, 9], + [11, 27, 0, 24, 31, 31], + [18, 3, inf, 0, 7, 7], + [15, 4, inf, 1, 0, 8], + [11, 17, inf, 14, 21, 0] ] + +test :: Bool +test = toList (shortestPaths testGraph) == toList expectedResult + +toAdjMatrix :: [[Weight]] -> Graph +toAdjMatrix xs = A.fromList (Z :. k :. k) (concat xs) + where k = length xs + + +main :: IO () +main = do + (n:_) <- fmap (fmap read) getArgs + print (run (let g :: Acc Graph + g = generate (constant (Z:.n:.n) :: Exp DIM2) f + + f :: Exp DIM2 -> Exp Weight + f ix = let i,j :: Exp Int + Z:.i:.j = unlift ix + in + A.fromIntegral j + + A.fromIntegral i * constant (Prelude.fromIntegral n) + in + A.foldAll (+) (constant 0) (shortestPathsAcc n g))) diff --git a/fwdense.hs b/fwdense.hs new file mode 100644 --- /dev/null +++ b/fwdense.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE CPP, BangPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} + +module Main ( main, test, maxDistances ) where + +import System.Environment +import Data.Array.Repa + +-- <> + +-- ----------------------------------------------------------------------------- +-- shortestPaths + +-- < Graph U +shortestPaths g0 = go g0 0 -- <2> + where + Z :. _ :. n = extent g0 -- <1> + + go !g !k | k == n = g -- <3> + | otherwise = + let g' = computeS (fromFunction (Z:.n:.n) sp) -- <4> + in go g' (k+1) -- <5> + where + sp (Z:.i:.j) = min (g ! (Z:.i:.j)) (g ! (Z:.i:.k) + g ! (Z:.k:.j)) -- <6> +-- >> + +-- ----------------------------------------------------------------------------- + +-- < Weight -> Weight +maxDistance x y + | x == inf = y + | y == inf = x + | otherwise = max x y +-- >> + +maxDistances :: Graph U -> Array U DIM1 Weight +maxDistances = foldS maxDistance inf + +-- ----------------------------------------------------------------------------- +-- Testing + +-- <> + +testGraph :: Graph U +testGraph = toAdjMatrix $ + [[ 0, inf, inf, 13, inf, inf], + [inf, 0, inf, inf, 4, 9], + [ 11, inf, 0, inf, inf, inf], + [inf, 3, inf, 0, inf, 7], + [ 15, 5, inf, 1, 0, inf], + [ 11, inf, inf, 14, inf, 0]] + +-- correct result: +expectedResult :: Graph U +expectedResult = toAdjMatrix $ + [[0, 16, inf, 13, 20, 20], + [19, 0, inf, 5, 4, 9], + [11, 27, 0, 24, 31, 31], + [18, 3, inf, 0, 7, 7], + [15, 4, inf, 1, 0, 8], + [11, 17, inf, 14, 21, 0] ] + +test :: Bool +test = shortestPaths testGraph == expectedResult + +toAdjMatrix :: [[Weight]] -> Graph U +toAdjMatrix xs = fromListUnboxed (Z :. k :. k) (concat xs) + where k = length xs + +main :: IO () +main = do + [n] <- fmap (fmap read) getArgs + let g = fromListUnboxed (Z:.n:.n) [0..n^(2::Int)-1] :: Graph U + print (sumAllS (shortestPaths g)) + diff --git a/fwdense1.hs b/fwdense1.hs new file mode 100644 --- /dev/null +++ b/fwdense1.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP, BangPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} + +module Main ( main, test ) where + +import System.Environment +import Data.Array.Repa +import Data.Functor.Identity + +-- <> + +-- ----------------------------------------------------------------------------- +-- shortestPaths + +-- < Graph U +shortestPaths g0 = runIdentity $ go g0 0 -- <1> + where + Z :. _ :. n = extent g0 + + go !g !k | k == n = return g -- <2> + | otherwise = do + g' <- computeP (fromFunction (Z:.n:.n) sp) -- <3> + go g' (k+1) + where + sp (Z:.i:.j) = min (g ! (Z:.i:.j)) (g ! (Z:.i:.k) + g ! (Z:.k:.j)) +-- >> + +-- ----------------------------------------------------------------------------- +-- Testing + +input :: [[Int]] +input = [[ 0, 999, 999, 13, 999, 999], + [999, 0, 999, 999, 4, 9], + [ 11, 999, 0, 999, 999, 999], + [999, 3, 999, 0, 999, 7], + [ 15, 5, 999, 1, 0, 999], + [ 11, 999, 999, 14, 999, 0]] + +-- correct result: +result :: [[Int]] +result = [[0, 16, 999, 13, 20, 20], + [19, 0, 999, 5, 4, 9], + [11, 27, 0, 24, 31, 31], + [18, 3, 999, 0, 7, 7], + [15, 4, 999, 1, 0, 8], + [11, 17, 999, 14, 21, 0] ] + +test :: Bool +test = fromAdjMatrix (shortestPaths (toAdjMatrix input)) == result + +toAdjMatrix :: [[Int]] -> Graph U +toAdjMatrix xs = fromListUnboxed (Z :. k :. k) (concat xs) + where k = length xs + +fromAdjMatrix :: Graph U -> [[Int]] +fromAdjMatrix m = chunk k (toList m) + where + (Z :. _ :. k) = extent m + +chunk :: Int -> [a] -> [[a]] +chunk _ [] = [] +chunk n xs = as : chunk n bs + where (as,bs) = splitAt n xs + +main :: IO () +main = do + [n] <- fmap (fmap read) getArgs + let g = fromListUnboxed (Z:.n:.n) [1..n^(2::Int)] :: Graph U + print (sumAllS (shortestPaths g)) + diff --git a/fwsparse/MapCompat.hs b/fwsparse/MapCompat.hs new file mode 100644 --- /dev/null +++ b/fwsparse/MapCompat.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE CPP #-} + +module MapCompat (module MapCompat, module Map) where + +#if !MIN_VERSION_containers(0,5,0) + +import Data.IntMap as Map +import Control.Applicative +import Data.Traversable + +traverseWithKey :: Applicative f => (Int -> a -> f b) -> IntMap a -> f (IntMap b) +traverseWithKey f m = + Map.fromList `fmap` traverse (\(k,v) -> (,) <$> pure k <*> f k v) (Map.toList m) + +#else + +import Data.IntMap.Strict as Map + +#endif diff --git a/fwsparse/SparseGraph.hs b/fwsparse/SparseGraph.hs new file mode 100644 --- /dev/null +++ b/fwsparse/SparseGraph.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE CPP #-} +module SparseGraph ( + Vertex, Weight, + Graph, + weight, insertEdge, + randomGraph, + mkGraph, + toAdjMatrix, + fromAdjMatrix, + checksum + ) where + +#if MIN_VERSION_containers(0,5,0) +import qualified Data.IntMap.Strict as Map +#else +import qualified Data.IntMap as Map +#endif +import qualified Data.IntSet as IntSet +import Data.IntMap (IntMap) +import System.Random +import Data.Array.Unboxed + +-- ----------------------------------------------------------------------------- +-- Graph representation + +-- < Vertex -> Vertex -> Maybe Weight +weight g i j = do + jmap <- Map.lookup i g + Map.lookup j jmap +-- >> + +insertEdge :: Vertex -> Vertex -> Weight -> Graph -> Graph +insertEdge i j w m = Map.insertWith Map.union i (Map.singleton j w) m + +-- ----------------------------------------------------------------------------- +-- Testing + +randomGraph :: StdGen -> Int -> Int -> Int -> (Graph, [Vertex]) +randomGraph g max_vertex max_weight edges = (mat, vs) + where + (g1,g2) = split g + (g3,g4) = split g2 + is = take edges $ randomRs (0,max_vertex) g1 + js = take edges $ randomRs (0,max_vertex) g3 + ws = take edges $ randomRs (1,max_weight) g4 + + mat = foldr ins Map.empty (zip3 is js ws) + where ins (i,j,w) = insertEdge i j w + + vs = IntSet.elems (IntSet.fromList (is ++ js)) + +mkGraph :: [[Int]] -> Graph +mkGraph xss = Map.fromList (zipWith row [0..] xss) + where + row i xs = (i, Map.fromList [ (j, w) | (j,w) <- zip [0..] xs, w /= 100 ]) + +type AdjMatrix = UArray (Int,Int) Weight + +toAdjMatrix :: Int -> Graph -> AdjMatrix +toAdjMatrix k m = accumArray (\_ e -> e) 999 ((0,0),(k,k)) + [ ((i,j),w) | (i,jmap) <- Map.toList m, (j,w) <- Map.toList jmap ] + +fromAdjMatrix :: AdjMatrix -> [[Int]] +fromAdjMatrix m = chunk (k+1) (elems m) + where + (_, (k,_)) = bounds m + +chunk :: Int -> [a] -> [[a]] +chunk _ [] = [] +chunk n xs = as : chunk n bs + where (as,bs) = splitAt n xs + +checksum :: Graph -> Int +checksum m = sum (concat (map Map.elems (Map.elems m))) + + diff --git a/fwsparse/fwsparse.hs b/fwsparse/fwsparse.hs new file mode 100644 --- /dev/null +++ b/fwsparse/fwsparse.hs @@ -0,0 +1,63 @@ +{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} + +module Main ( main, runtest ) where + +import System.Environment +import qualified MapCompat as Map +import MapCompat (IntMap) +import System.Random +import Data.List +import SparseGraph + +-- ----------------------------------------------------------------------------- +-- shortestPaths + +-- < Graph -> Graph +shortestPaths vs g = foldl' update g vs -- <1> + where + update g k = Map.mapWithKey shortmap g -- <2> + where + shortmap :: Vertex -> IntMap Weight -> IntMap Weight + shortmap i jmap = foldr shortest Map.empty vs -- <3> + where shortest j m = + case (old,new) of -- <6> + (Nothing, Nothing) -> m + (Nothing, Just w ) -> Map.insert j w m + (Just w, Nothing) -> Map.insert j w m + (Just w1, Just w2) -> Map.insert j (min w1 w2) m + where + old = Map.lookup j jmap -- <4> + new = do w1 <- weight g i k -- <5> + w2 <- weight g k j + return (w1+w2) +-- >> + +-- ----------------------------------------------------------------------------- +-- Testing + +test :: [[Int]] +test = [[ 0, 999, 999, 13, 999, 999], + [999, 0, 999, 999, 4, 9], + [ 11, 999, 0, 999, 999, 999], + [999, 3, 999, 0, 999, 7], + [ 15, 5, 999, 1, 0, 999], + [ 11, 999, 999, 14, 999, 0]] + +-- correct result: +-- [ [0, 16, 999, 13, 20, 20], +-- [19, 0, 999, 5, 4, 9], +-- [11, 27, 0, 24, 31, 31], +-- [18, 3, 999, 0, 7, 7], +-- [15, 4, 999, 1, 0, 8], +-- [11, 17, 999, 14, 21, 0] ] + +runtest :: [[Int]] +runtest = fromAdjMatrix (toAdjMatrix 5 (shortestPaths [0..5] (mkGraph test))) + +main :: IO () +main = do + [h,n] <- fmap (fmap read) getArgs + let g = mkStdGen 9999 + let (mat,vs) = randomGraph g h 100 n + print (checksum (shortestPaths vs mat)) diff --git a/fwsparse/fwsparse1.hs b/fwsparse/fwsparse1.hs new file mode 100644 --- /dev/null +++ b/fwsparse/fwsparse1.hs @@ -0,0 +1,70 @@ +{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} + +module Main ( main, runtest ) where + +import Control.Monad.Par.Scheds.Trace + -- gives slightly better results than Control.Monad.Par with monad-par-0.3.4 +import System.Environment +import qualified MapCompat as Map +import MapCompat (IntMap) +import System.Random +import Data.List +import Data.Traversable hiding (mapM) + +import SparseGraph + +-- ----------------------------------------------------------------------------- +-- shortestPaths + +shortestPaths :: [Vertex] -> Graph -> Graph +shortestPaths vs g = foldl' update g vs + where +-- < spawn (return (shortmap i jmap))) g + traverse get m +-- >> + where + shortmap :: Vertex -> IntMap Weight -> IntMap Weight + shortmap i jmap = foldr shortest Map.empty vs + where shortest j m = + case (old,new) of + (Nothing, Nothing) -> m + (Nothing, Just w ) -> Map.insert j w m + (Just w, Nothing) -> Map.insert j w m + (Just w1, Just w2) -> Map.insert j (min w1 w2) m + where + old = Map.lookup j jmap + new = do w1 <- weight g i k + w2 <- weight g k j + return (w1+w2) + +-- ----------------------------------------------------------------------------- +-- Testing + +test :: [[Int]] +test = [[ 0, 999, 999, 13, 999, 999], + [999, 0, 999, 999, 4, 9], + [ 11, 999, 0, 999, 999, 999], + [999, 3, 999, 0, 999, 7], + [ 15, 5, 999, 1, 0, 999], + [ 11, 999, 999, 14, 999, 0]] + +-- correct result: +-- [ [0, 16, 999, 13, 20, 20], +-- [19, 0, 999, 5, 4, 9], +-- [11, 27, 0, 24, 31, 31], +-- [18, 3, 999, 0, 7, 7], +-- [15, 4, 999, 1, 0, 8], +-- [11, 17, 999, 14, 21, 0] ] + +runtest :: [[Int]] +runtest = fromAdjMatrix (toAdjMatrix 5 (shortestPaths [0..5] (mkGraph test))) + +main :: IO () +main = do + [h,n] <- fmap (fmap read) getArgs + let g = mkStdGen 9999 + let (mat,vs) = randomGraph g h 100 n + print (checksum (shortestPaths vs mat)) + diff --git a/geturls1.hs b/geturls1.hs new file mode 100644 --- /dev/null +++ b/geturls1.hs @@ -0,0 +1,21 @@ +-- < + m2 <- newEmptyMVar -- <1> + + forkIO $ do -- <2> + r <- getURL "http://www.wikipedia.org/wiki/Shovel" + putMVar m1 r + + forkIO $ do -- <3> + r <- getURL "http://www.wikipedia.org/wiki/Spade" + putMVar m2 r + + r1 <- takeMVar m1 -- <4> + r2 <- takeMVar m2 -- <5> + print (B.length r1, B.length r2) -- <6> +-- >> diff --git a/geturls2.hs b/geturls2.hs new file mode 100644 --- /dev/null +++ b/geturls2.hs @@ -0,0 +1,31 @@ +import GetURL + +import Control.Concurrent +import qualified Data.ByteString as B + +----------------------------------------------------------------------------- +-- Our Async API: + +-- < IO (Async a) +async action = do + var <- newEmptyMVar + forkIO (do r <- action; putMVar var r) + return (Async var) + +wait :: Async a -> IO a +wait (Async var) = readMVar var +-- >> + +----------------------------------------------------------------------------- + +-- <
> diff --git a/geturls3.hs b/geturls3.hs new file mode 100644 --- /dev/null +++ b/geturls3.hs @@ -0,0 +1,50 @@ +-- (c) Simon Marlow 2011, see the file LICENSE for copying terms. +-- +-- Sample geturls.hs (CEFP summer school notes, 2011) +-- +-- Downloading multiple URLs concurrently, timing the downloads +-- +-- Compile with: +-- ghc -threaded --make geturls.hs + +import GetURL +import TimeIt + +import Control.Concurrent +import Text.Printf +import qualified Data.ByteString as B + +----------------------------------------------------------------------------- +-- Our Async API: + +-- < IO (Async a) +async action = do + var <- newEmptyMVar + forkIO (do r <- action; putMVar var r) + return (Async var) + +wait :: Async a -> IO a +wait (Async var) = readMVar var +-- >> + +----------------------------------------------------------------------------- + +-- <
IO () +timeDownload url = do + (page, time) <- timeit $ getURL url -- <1> + printf "downloaded: %s (%d bytes, %.2fs)\n" url (B.length page) time + +main = do + as <- mapM (async . timeDownload) sites -- <2> + mapM_ wait as -- <3> +-- >> diff --git a/geturls4.hs b/geturls4.hs new file mode 100644 --- /dev/null +++ b/geturls4.hs @@ -0,0 +1,39 @@ +import GetURL + +import Control.Concurrent +import Control.Exception +import qualified Data.ByteString as B + +----------------------------------------------------------------------------- +-- Our Async API: + +-- < + +async :: IO a -> IO (Async a) +async action = do + var <- newEmptyMVar + forkIO (do r <- try action; putMVar var r) -- <2> + return (Async var) + +waitCatch :: Async a -> IO (Either SomeException a) -- <3> +waitCatch (Async var) = readMVar var + +wait :: Async a -> IO a -- <4> +wait a = do + r <- waitCatch a + case r of + Left e -> throwIO e + Right a -> return a +-- >> + +----------------------------------------------------------------------------- + +-- <
> diff --git a/geturls5.hs b/geturls5.hs new file mode 100644 --- /dev/null +++ b/geturls5.hs @@ -0,0 +1,28 @@ +import Control.Concurrent +import GetURL +import qualified Data.ByteString as B +import Text.Printf +import Control.Monad + +-- <
> + diff --git a/geturls6.hs b/geturls6.hs new file mode 100644 --- /dev/null +++ b/geturls6.hs @@ -0,0 +1,70 @@ +import GetURL +import TimeIt + +import Control.Monad +import Control.Concurrent +import Control.Exception +import Text.Printf +import qualified Data.ByteString as B + +----------------------------------------------------------------------------- +-- Our Async API: + +data Async a = Async (MVar (Either SomeException a)) + +async :: IO a -> IO (Async a) +async action = do + var <- newEmptyMVar + forkIO (do r <- try action; putMVar var r) -- <1> + return (Async var) + +waitCatch :: Async a -> IO (Either SomeException a) -- <2> +waitCatch (Async var) = readMVar var + +wait :: Async a -> IO a -- <3> +wait a = do + r <- waitCatch a + case r of + Left e -> throwIO e + Right a -> return a + +-- < Async b -> IO (Either a b) +waitEither a b = do + m <- newEmptyMVar + forkIO $ do r <- try (fmap Left (wait a)); putMVar m r + forkIO $ do r <- try (fmap Right (wait b)); putMVar m r + wait (Async m) +-- >> + +-- < IO a +waitAny as = do + m <- newEmptyMVar + let forkwait a = forkIO $ do r <- try (wait a); putMVar m r + mapM_ forkwait as + wait (Async m) +-- >> + +----------------------------------------------------------------------------- + +sites = ["http://www.google.com", + "http://www.bing.com", + "http://www.yahoo.com", + "http://www.wikipedia.com/wiki/Spade", + "http://www.wikipedia.com/wiki/Shovel"] + +-- <
> diff --git a/geturls7.hs b/geturls7.hs new file mode 100644 --- /dev/null +++ b/geturls7.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE CPP #-} + +import GetURL + +import Control.Concurrent +#if __GLASGOW_HASKELL__ < 706 +import ConcurrentUtils (forkFinally) +#endif +import Control.Exception +import qualified Data.ByteString as B +import Control.Concurrent.STM + +----------------------------------------------------------------------------- +-- Our Async API: + +-- <> + +-- < IO (Async a) +async action = do + var <- newEmptyTMVarIO + t <- forkFinally action (atomically . putTMVar var) + return (Async t var) +-- >> + +--- < IO (Either SomeException a) +waitCatch = atomically . waitCatchSTM +-- >> + +-- < STM (Either SomeException a) +waitCatchSTM (Async _ var) = readTMVar var +-- >> + +-- < STM a +waitSTM a = do + r <- waitCatchSTM a + case r of + Left e -> throwSTM e + Right a -> return a +-- >> + +-- < IO a +wait = atomically . waitSTM +-- >> + +-- < IO () +cancel (Async t _) = throwTo t ThreadKilled +-- >> + +-- < Async b -> IO (Either a b) +waitEither a b = atomically $ + fmap Left (waitSTM a) + `orElse` + fmap Right (waitSTM b) +-- >> + +-- < IO a +waitAny asyncs = + atomically $ foldr orElse retry $ map waitSTM asyncs +-- >> + +-- < (Async a -> IO b) -> IO b +withAsync io operation = bracket (async io) cancel operation +-- >> + +----------------------------------------------------------------------------- + +-- <
+ withAsync (getURL "http://www.wikipedia.org/wiki/Spade") $ \a2 -> do + r1 <- wait a1 + r2 <- wait a2 + print (B.length r1, B.length r2) +-- >> diff --git a/geturls8.hs b/geturls8.hs new file mode 100644 --- /dev/null +++ b/geturls8.hs @@ -0,0 +1,15 @@ +import GetURL + +import Async + +import qualified Data.ByteString as B + +----------------------------------------------------------------------------- + +-- <
> diff --git a/geturls9.hs b/geturls9.hs new file mode 100644 --- /dev/null +++ b/geturls9.hs @@ -0,0 +1,23 @@ +import GetURL + +import Async + +import qualified Data.ByteString as B + +----------------------------------------------------------------------------- + +sites = ["http://www.google.com", + "http://www.bing.com", + "http://www.yahoo.com", + "http://www.wikipedia.com/wiki/Spade", + "http://www.wikipedia.com/wiki/Shovel"] + +-- <
> diff --git a/geturlscancel.hs b/geturlscancel.hs new file mode 100644 --- /dev/null +++ b/geturlscancel.hs @@ -0,0 +1,74 @@ +-- (c) Simon Marlow 2011, see the file LICENSE for copying terms. +-- +-- Sample geturls.hs (CEFP summer school notes, 2011) +-- +-- Downloading multiple URLs concurrently, timing the downloads, +-- and the user may press 'q' to stop the downloads at any time. +-- +-- Compile with: +-- ghc -threaded --make geturlscancel.hs + +import GetURL +import TimeIt + +import Data.Either +import System.IO +import Control.Monad +import Control.Concurrent +import Control.Exception +import Text.Printf +import qualified Data.ByteString as B +import Prelude hiding (catch) + +----------------------------------------------------------------------------- +-- Our Async API: + +-- <> + +-- < IO (Async a) +async action = do + m <- newEmptyMVar + t <- forkIO (do r <- try action; putMVar m r) + return (Async t m) +-- >> + +-- < IO (Either SomeException a) +waitCatch (Async _ var) = readMVar var +-- >> + +-- < IO () +cancel (Async t var) = throwTo t ThreadKilled +-- >> + +----------------------------------------------------------------------------- + +sites = ["http://www.google.com", + "http://www.bing.com", + "http://www.yahoo.com", + "http://www.wikipedia.com/wiki/Spade", + "http://www.wikipedia.com/wiki/Shovel"] + +timeDownload :: String -> IO () +timeDownload url = do + (page, time) <- timeit $ getURL url + printf "downloaded: %s (%d bytes, %.2fs)\n" url (B.length page) time + +-- <
+ + forkIO $ do -- <2> + hSetBuffering stdin NoBuffering + forever $ do + c <- getChar + when (c == 'q') $ mapM_ cancel as + + rs <- mapM waitCatch as -- <3> + printf "%d/%d succeeded\n" (length (rights rs)) (length rs) -- <4> +-- >> + diff --git a/geturlscancel2.hs b/geturlscancel2.hs new file mode 100644 --- /dev/null +++ b/geturlscancel2.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DeriveDataTypeable, CPP #-} +-- (c) Simon Marlow 2011, see the file LICENSE for copying terms. +-- +-- Sample geturls.hs (CEFP summer school notes, 2011) +-- +-- Downloading multiple URLs concurrently, timing the downloads, +-- and the user may press 'q' to stop the downloads at any time. +-- +-- Compile with: +-- ghc -threaded --make geturlscancel.hs + +import GetURL +import TimeIt + +import Data.Either +import System.IO +import Control.Monad +#if __GLASGOW_HASKELL__ < 706 +import Control.Concurrent +#else +-- forkFinally was added in GHC 7.6 +import Control.Concurrent hiding (forkFinally) +#endif +import Control.Exception +import Text.Printf +import qualified Data.ByteString as B +import Data.Typeable +import Prelude hiding (catch) + +----------------------------------------------------------------------------- +-- Our Async API: + +-- <> + +-- < (Either SomeException a -> IO ()) -> IO ThreadId +forkFinally action fun = + mask $ \restore -> + forkIO (do r <- try (restore action); fun r) +-- >> + +-- < IO (Async a) +async action = do + m <- newEmptyMVar + t <- forkFinally action (putMVar m) + return (Async t m) +-- >> + +-- < IO (Either SomeException a) +waitCatch (Async _ var) = readMVar var +-- >> + +-- < IO () +cancel (Async t var) = throwTo t ThreadKilled +-- >> + +----------------------------------------------------------------------------- + +sites = ["http://www.google.com", + "http://www.bing.com", + "http://www.yahoo.com", + "http://www.wikipedia.com/wiki/Spade", + "http://www.wikipedia.com/wiki/Shovel"] + +timeDownload :: String -> IO () +timeDownload url = do + (page, time) <- timeit $ getURL url + printf "downloaded: %s (%d bytes, %.2fs)\n" url (B.length page) time + +-- <
+ + forkIO $ do -- <2> + hSetBuffering stdin NoBuffering + forever $ do + c <- getChar + when (c == 'q') $ mapM_ cancel as + + rs <- mapM waitCatch as -- <3> + printf "%d/%d succeeded\n" (length (rights rs)) (length rs) -- <4> +-- >> + diff --git a/geturlsfirst.hs b/geturlsfirst.hs new file mode 100644 --- /dev/null +++ b/geturlsfirst.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE CPP #-} +-- STM Async API used in \secref{stm-async} + +module Main where + +import GetURL + +#if __GLASGOW_HASKELL__ < 706 +import ConcurrentUtils (forkFinally) +#endif +import Control.Concurrent +import Control.Exception +import Control.Concurrent.STM +import Text.Printf +import qualified Data.ByteString as B + +-- ----------------------------------------------------------------------------- +-- STM Async API + +-- <> + +-- < IO (Async a) +async action = do + var <- newEmptyTMVarIO + t <- forkFinally action (atomically . putTMVar var) + return (Async t var) +-- >> + +--- < IO (Either SomeException a) +waitCatch = atomically . waitCatchSTM +-- >> + +-- < STM (Either SomeException a) +waitCatchSTM (Async _ var) = readTMVar var +-- >> + +-- < STM a +waitSTM a = do + r <- waitCatchSTM a + case r of + Left e -> throwSTM e + Right a -> return a +-- >> + +-- < IO a +wait = atomically . waitSTM +-- >> + +-- < IO () +cancel (Async t _) = throwTo t ThreadKilled +-- >> + +-- < Async b -> IO (Either a b) +waitEither a b = atomically $ + fmap Left (waitSTM a) + `orElse` + fmap Right (waitSTM b) +-- >> + +-- < IO a +waitAny asyncs = + atomically $ foldr orElse retry $ map waitSTM asyncs +-- >> + +----------------------------------------------------------------------------- + +sites = ["http://www.google.com", + "http://www.bing.com", + "http://www.yahoo.com", + "http://www.wikipedia.com/wiki/Spade", + "http://www.wikipedia.com/wiki/Shovel"] + +-- <
> diff --git a/geturlsstm.hs b/geturlsstm.hs new file mode 100644 --- /dev/null +++ b/geturlsstm.hs @@ -0,0 +1,50 @@ +-- (c) Simon Marlow 2011, see the file LICENSE for copying terms. +-- +-- Sample geturls.hs (CEFP summer school notes, 2011) +-- +-- Downloading multiple URLs concurrently, timing the downloads +-- +-- Compile with: +-- ghc -threaded --make geturls.hs + +import GetURL +import TimeIt + +import Control.Monad +import Control.Concurrent +import Control.Exception +import Text.Printf +import Control.Concurrent.STM +import qualified Data.ByteString as B + +----------------------------------------------------------------------------- +-- Our Async API: + +data Async a = Async (TVar (Maybe a)) + +async :: IO a -> IO (Async a) +async action = do + var <- atomically $ newTVar Nothing + forkIO (do a <- action; atomically (writeTVar var (Just a))) + return (Async var) + +wait :: Async a -> IO a +wait (Async var) = atomically $ do + m <- readTVar var + case m of + Nothing -> retry + Just a -> return a + +----------------------------------------------------------------------------- + +sites = ["http://www.google.com", + "http://www.bing.com", + "http://www.yahoo.com", + "http://www.wikipedia.com/wiki/Spade", + "http://www.wikipedia.com/wiki/Shovel"] + +main = mapM (async.http) sites >>= mapM wait + where + http url = do + (page, time) <- timeit $ getURL url + printf "downloaded: %s (%d bytes, %.2fs)\n" url (B.length page) time diff --git a/kmeans/GenSamples.hs b/kmeans/GenSamples.hs new file mode 100644 --- /dev/null +++ b/kmeans/GenSamples.hs @@ -0,0 +1,75 @@ +import KMeansCore +import Data.Random.Normal +import System.Random +import System.IO +import Data.Array +import System.Environment +import Control.Monad +import Data.List +import Data.Binary + +minX, maxX, minY, maxY, minSD, maxSD :: Double +minX = -10 +maxX = 10 +minY = -10 +maxY = 10 +minSD = 1.5 +maxSD = 2.0 + +main = do + n: minp: maxp: rest <- fmap (fmap read) getArgs + + case rest of + [seed] -> setStdGen (mkStdGen seed) + _ -> return () + + nps <- replicateM n (randomRIO (minp, maxp)) + xs <- replicateM n (randomRIO (minX, maxY)) + ys <- replicateM n (randomRIO (minX, maxY)) + sds <- replicateM n (randomRIO (minSD, maxSD)) + + let params = zip5 nps xs ys sds sds + + -- first generate a set of points for each set of sample parameters + ss <- mapM (\(a,b,c,d,e) -> generate2DSamples a b c d e) params + let points = concat ss + + -- dump all the points into the file "points" + hsamp <- openFile "points" WriteMode + mapM_ (printPoint hsamp) points + hClose hsamp + + encodeFile "points.bin" points + + -- generate the initial clusters by assigning each point to random + -- cluster. + gen <- newStdGen + let + rand_clusters = randomRs (0,n-1) gen :: [Int] + arr = accumArray (flip (:)) [] (0,n-1) $ + zip rand_clusters points + clusters = map (uncurry makeCluster) (assocs arr) + writeFile "clusters" (show clusters) + + -- so we can tell what the answer should be: + writeFile "params" (show params) + + +printPoint :: Handle -> Point -> IO () +printPoint h (Point x y) = do + hPutStr h (show x) + hPutChar h ' ' + hPutStr h (show y) + hPutChar h '\n' + +generate2DSamples :: Int -- number of samples to generate + -> Double -> Double -- X and Y of the mean + -> Double -> Double -- X and Y standard deviations + -> IO [Point] + +generate2DSamples n mx my sdx sdy = do + gen <- newStdGen + let (genx, geny) = split gen + xsamples = normals' (mx,sdx) genx + ysamples = normals' (my,sdy) geny + return (zipWith Point (take n xsamples) ysamples) diff --git a/kmeans/KMeansCore.hs b/kmeans/KMeansCore.hs new file mode 100644 --- /dev/null +++ b/kmeans/KMeansCore.hs @@ -0,0 +1,67 @@ +-- +-- Adapted from the K-Means example in the remote-0.1.1 package, +-- (c) Jeff Epstein +-- + +{-# LANGUAGE DeriveDataTypeable #-} +module KMeansCore where + +import Data.List +import Data.Typeable (Typeable) +import Data.Data (Data) +import qualified Data.ByteString.Char8 as B +import Data.Binary +import Control.DeepSeq + +-- ----------------------------------------------------------------------------- +-- Points + +data Point = Point {-#UNPACK#-}!Double {-#UNPACK#-}!Double + deriving (Show,Read,Eq) + +instance NFData Point + +-- < Point -> Double +sqDistance (Point x1 y1) (Point x2 y2) = ((x1-x2)^2) + ((y1-y2)^2) +-- >> + +instance Binary Point where + put (Point a b) = put a >> put b + get = do a <- get; b <- get; return (Point a b) + +readPoints :: FilePath -> IO [Point] +readPoints f = do + s <- B.readFile f + let ls = map B.words $ B.lines s + points = [ Point (read (B.unpack sx)) (read (B.unpack sy)) + | (sx:sy:_) <- ls ] + -- + return points + +----------------------------------------------------------------------------- +-- Clusters + +data Cluster + = Cluster { clId :: {-# UNPACK #-} !Int + , clCent :: {-# UNPACK #-} !Point + } + deriving (Show,Read,Eq) + +instance NFData Cluster -- default is ok, all the fields are strict + + +makeCluster :: Int -> [Point] -> Cluster +makeCluster clid points = + Cluster { clId = clid + , clCent = Point (a / fromIntegral count) (b / fromIntegral count) + } + where + pointsum@(Point a b) = foldl' addPoint zeroPoint points + count = length points + + addPoint :: Point -> Point -> Point + addPoint (Point a b) (Point c d) = Point (a+c) (b+d) diff --git a/kmeans/kmeans.hs b/kmeans/kmeans.hs new file mode 100644 --- /dev/null +++ b/kmeans/kmeans.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} + +-- K-Means sample from "Parallel and Concurrent Programming in Haskell" +-- +-- With three versions: +-- [ kmeans_seq ] a sequential version +-- [ kmeans_strat ] a parallel version using Control.Parallel.Strategies +-- [ kmeans_par ] a parallel version using Control.Monad.Par +-- +-- Usage (sequential): +-- $ ./kmeans seq +-- +-- Usage (Strategies): +-- $ ./kmeans strat 600 +RTS -N4 +-- +-- Usage (Par monad): +-- $ ./kmeans par 600 +RTS -N4 +-- +-- Usage (divide-and-conquer / Par monad): +-- $ ./kmeans divpar 7 +RTS -N4 +-- +-- Usage (divide-and-conquer / Eval monad): +-- $ ./kmeans diveval 7 +RTS -N4 + +import System.IO +import KMeansCore +import Data.Array +import Data.Array.Unsafe as Unsafe +import Text.Printf +import Data.List +import Data.Function +import Data.Binary (decodeFile) +import Debug.Trace +import Control.Parallel.Strategies as Strategies +import Control.Monad.Par as Par +import Control.DeepSeq +import System.Environment +import Data.Time.Clock +import Control.Exception +import Control.Concurrent +import Control.Monad.ST +import Data.Array.ST +import System.Mem +import Data.Maybe + +import qualified Data.Vector as Vector +import Data.Vector (Vector) +import qualified Data.Vector.Mutable as MVector + +-- ----------------------------------------------------------------------------- +-- main: read input files, time calculation + +main = runInUnboundThread $ do + points <- decodeFile "points.bin" + clusters <- read `fmap` readFile "clusters" + let nclusters = length clusters + args <- getArgs + npoints <- evaluate (length points) + performGC + t0 <- getCurrentTime + final_clusters <- case args of + ["seq" ] -> kmeans_seq nclusters points clusters + ["strat", n] -> kmeans_strat (read n) nclusters points clusters + ["par", n] -> kmeans_par (read n) nclusters points clusters + ["divpar", n] -> kmeans_div_par (read n) nclusters points clusters npoints + ["diveval", n] -> kmeans_div_eval (read n) nclusters points clusters npoints + _other -> error "args" + t1 <- getCurrentTime + print final_clusters + printf "Total time: %.2f\n" (realToFrac (diffUTCTime t1 t0) :: Double) + +-- ----------------------------------------------------------------------------- +-- K-Means: repeatedly step until convergence (sequential) + +-- < [Point] -> [Cluster] -> IO [Cluster] +kmeans_seq nclusters points clusters = + let + loop :: Int -> [Cluster] -> IO [Cluster] + loop n clusters | n > tooMany = do -- <1> + putStrLn "giving up." + return clusters + loop n clusters = do + printf "iteration %d\n" n + putStr (unlines (map show clusters)) + let clusters' = step nclusters clusters points -- <2> + if clusters' == clusters -- <3> + then return clusters + else loop (n+1) clusters' + in + loop 0 clusters + +tooMany = 80 +-- >> + +-- ----------------------------------------------------------------------------- +-- K-Means: repeatedly step until convergence (Strategies) + +-- < Int -> [Point] -> [Cluster] -> IO [Cluster] +kmeans_strat numChunks nclusters points clusters = + let + chunks = split numChunks points -- <1> + + loop :: Int -> [Cluster] -> IO [Cluster] + loop n clusters | n > tooMany = do + printf "giving up." + return clusters + loop n clusters = do + printf "iteration %d\n" n + putStr (unlines (map show clusters)) + let clusters' = parSteps_strat nclusters clusters chunks -- <2> + if clusters' == clusters + then return clusters + else loop (n+1) clusters' + in + loop 0 clusters +-- >> + +-- < [a] -> [[a]] +split numChunks xs = chunk (length xs `quot` numChunks) xs + +chunk :: Int -> [a] -> [[a]] +chunk n [] = [] +chunk n xs = as : chunk n bs + where (as,bs) = splitAt n xs +-- >> + +-- ----------------------------------------------------------------------------- +-- K-Means: repeatedly step until convergence (Par monad) + +kmeans_par :: Int -> Int -> [Point] -> [Cluster] -> IO [Cluster] +kmeans_par mappers nclusters points clusters = + let + chunks = split mappers points + + loop :: Int -> [Cluster] -> IO [Cluster] + loop n clusters | n > tooMany = do printf "giving up."; return clusters + loop n clusters = do + printf "iteration %d\n" n + putStr (unlines (map show clusters)) + let + clusters' = steps_par nclusters clusters chunks + + if clusters' == clusters + then return clusters + else loop (n+1) clusters' + in + loop 0 clusters + +-- ----------------------------------------------------------------------------- +-- kmeans_div_par: Use divide-and-conquer, and the Par monad for parallellism. + +kmeans_div_par :: Int -> Int -> [Point] -> [Cluster] -> Int -> IO [Cluster] +kmeans_div_par threshold nclusters points clusters npoints = + let + tree = mkPointTree threshold points npoints + + loop :: Int -> [Cluster] -> IO [Cluster] + loop n clusters | n > tooMany = do printf "giving up."; return clusters + loop n clusters = do + hPrintf stderr "iteration %d\n" n + hPutStr stderr (unlines (map show clusters)) + let + divconq :: Tree [Point] -> Par (Vector PointSum) + divconq (Leaf points) = return $ assign nclusters clusters points + divconq (Node left right) = do + i1 <- spawn $ divconq left + i2 <- spawn $ divconq right + c1 <- get i1 + c2 <- get i2 + return $! combine c1 c2 + + clusters' = makeNewClusters $ runPar $ divconq tree + + if clusters' == clusters + then return clusters + else loop (n+1) clusters' + in + loop 0 clusters + +data Tree a = Leaf a + | Node (Tree a) (Tree a) + + +mkPointTree :: Int -> [Point] -> Int -> Tree [Point] +mkPointTree threshold points npoints = go 0 points npoints + where + go depth points npoints + | depth >= threshold = Leaf points + | otherwise = Node (go (depth+1) xs half) + (go (depth+1) ys half) + where + half = npoints `quot` 2 + (xs,ys) = splitAt half points + +-- ----------------------------------------------------------------------------- +-- kmeans_div_eval: Use divide-and-conquer, and the Eval monad for parallellism. + +kmeans_div_eval :: Int -> Int -> [Point] -> [Cluster] -> Int -> IO [Cluster] +kmeans_div_eval threshold nclusters points clusters npoints = + let + tree = mkPointTree threshold points npoints + + loop :: Int -> [Cluster] -> IO [Cluster] + loop n clusters | n > tooMany = do printf "giving up."; return clusters + loop n clusters = do + hPrintf stderr "iteration %d\n" n + hPutStr stderr (unlines (map show clusters)) + let + divconq :: Tree [Point] -> Vector PointSum + divconq (Leaf points) = assign nclusters clusters points + divconq (Node left right) = runEval $ do + c1 <- rpar $ divconq left + c2 <- rpar $ divconq right + rdeepseq c1 + rdeepseq c2 + return $! combine c1 c2 + + clusters' = makeNewClusters $ divconq tree + + if clusters' == clusters + then return clusters + else loop (n+1) clusters' + in + loop 0 clusters + +-- ----------------------------------------------------------------------------- +-- Perform one step of the K-Means algorithm + +-- < [Cluster] -> [Point] -> [Cluster] +step nclusters clusters points + = makeNewClusters (assign nclusters clusters points) +-- >> + +-- < [Cluster] -> [Point] -> Vector PointSum +assign nclusters clusters points = Vector.create $ do + vec <- MVector.replicate nclusters (PointSum 0 0 0) + let + addpoint p = do + let c = nearest p; cid = clId c + ps <- MVector.read vec cid + MVector.write vec cid $! addToPointSum ps p + + mapM_ addpoint points + return vec + where + nearest p = fst $ minimumBy (compare `on` snd) + [ (c, sqDistance (clCent c) p) | c <- clusters ] +-- >> + +data PointSum = PointSum {-# UNPACK #-} !Int {-# UNPACK #-} !Double {-# UNPACK #-} !Double + +instance NFData PointSum + +-- < Point -> PointSum +addToPointSum (PointSum count xs ys) (Point x y) + = PointSum (count+1) (xs + x) (ys + y) +-- >> + +-- < PointSum -> Cluster +pointSumToCluster i (PointSum count xs ys) = + Cluster { clId = i + , clCent = Point (xs / fromIntegral count) (ys / fromIntegral count) + } +-- >> + +-- < PointSum -> PointSum +addPointSums (PointSum c1 x1 y1) (PointSum c2 x2 y2) + = PointSum (c1+c2) (x1+x2) (y1+y2) +-- >> + +-- < Vector PointSum -> Vector PointSum +combine = Vector.zipWith addPointSums +-- >> + +-- < [Cluster] -> [[Point]] -> [Cluster] +parSteps_strat nclusters clusters pointss + = makeNewClusters $ + foldr1 combine $ + (map (assign nclusters clusters) pointss + `using` parList rseq) +-- >> + +steps_par :: Int -> [Cluster] -> [[Point]] -> [Cluster] +steps_par nclusters clusters pointss + = makeNewClusters $ + foldl1' combine $ + (runPar $ Par.parMap (assign nclusters clusters) pointss) + +-- < [Cluster] +makeNewClusters vec = + [ pointSumToCluster i ps + | (i,ps@(PointSum count _ _)) <- zip [0..] (Vector.toList vec) + , count > 0 + ] +-- >> + -- v. important: filter out any clusters that have + -- no points. This can happen when a cluster is not + -- close to any points. If we leave these in, then + -- the NaNs mess up all the future calculations. diff --git a/logger.hs b/logger.hs new file mode 100644 --- /dev/null +++ b/logger.hs @@ -0,0 +1,56 @@ +import Control.Concurrent +import Control.Monad + +-- ----------------------------------------------------------------------------- + +-- <> + +-- <> + +-- < IO () +logger (Logger m) = loop + where + loop = do + cmd <- takeMVar m + case cmd of + Message msg -> do + putStrLn msg + loop + Stop s -> do + putStrLn "logger: stop" + putMVar s () +-- >> + +-- < String -> IO () +logMessage (Logger m) s = putMVar m (Message s) +-- >> + +-- < IO () +logStop (Logger m) = do + s <- newEmptyMVar + putMVar m (Stop s) + takeMVar s +-- >> + +-- <
> diff --git a/mandel/Config.hs b/mandel/Config.hs new file mode 100644 --- /dev/null +++ b/mandel/Config.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Config ( + + Options, optBackend, optSize, optLimit, optBench, + processArgs, run, run1 + +) where + +import Data.Label +import System.Exit +import System.Console.GetOpt +import Data.Array.Accelerate ( Arrays, Acc ) +import qualified Data.Array.Accelerate.Interpreter as Interp +#ifdef ACCELERATE_CUDA_BACKEND +import qualified Data.Array.Accelerate.CUDA as CUDA +#endif + +data Backend = Interpreter +#ifdef ACCELERATE_CUDA_BACKEND + | CUDA +#endif + deriving (Bounded, Show) + +data Options = Options + { + optBackend :: Backend + , optSize :: Int + , optLimit :: Int + , optBench :: Bool + , optHelp :: Bool + } + deriving Show + +defaultOptions :: Options +defaultOptions = Options + { optBackend = maxBound + , optSize = 512 + , optLimit = 255 + , optBench = False + , optHelp = False + } + + +run :: Arrays a => Options -> Acc a -> a +run opts = case optBackend opts of + Interpreter -> Interp.run +#ifdef ACCELERATE_CUDA_BACKEND + CUDA -> CUDA.run +#endif + +run1 :: (Arrays a, Arrays b) => Options -> (Acc a -> Acc b) -> a -> b +run1 opts f = case optBackend opts of + Interpreter -> head . Interp.stream f . return +#ifdef ACCELERATE_CUDA_BACKEND + CUDA -> CUDA.run1 f +#endif + + +options :: [OptDescr (Options -> Options)] +options = + [ Option [] ["interpreter"] (NoArg (\o -> o{optBackend=Interpreter})) "reference implementation (sequential)" +#ifdef ACCELERATE_CUDA_BACKEND + , Option [] ["cuda"] (NoArg (\o -> o{optBackend = CUDA})) "implementation for NVIDIA GPUs (parallel)" +#endif + , Option [] ["size"] (ReqArg (\i o -> o{optSize = read i}) "INT") "visualisation size (512)" + , Option [] ["limit"] (ReqArg (\i o -> o{optLimit = read i}) "INT") "iteration limit for escape (255)" + , Option [] ["benchmark"] (NoArg (\o -> o{optBench = True})) "benchmark instead of displaying animation (False)" + , Option "h?" ["help"] (NoArg (\o -> o{optHelp = True})) "show help message" + ] + + +processArgs :: [String] -> IO (Options, [String]) +processArgs argv = + case getOpt' Permute options argv of + (o,_,n,[]) -> case foldl (flip id) defaultOptions o of + opts | False <- optHelp opts -> return (opts, n) + opts | True <- optBench opts -> return (opts, "--help":n) + _ -> putStrLn (helpMsg []) >> exitSuccess + (_,_,_,err) -> error (helpMsg err) + where + helpMsg err = concat err ++ usageInfo header options + header = unlines + [ "accelerate-mandelbrot (c) [2011..2012] The Accelerate Team" + , "" + , "Usage: accelerate-mandelbrot [OPTIONS]" + ] + diff --git a/mandel/mandel.hs b/mandel/mandel.hs new file mode 100644 --- /dev/null +++ b/mandel/mandel.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE TypeOperators #-} +-- +-- A Mandelbrot set generator. Submitted by Simon Marlow as part of Issue #49. +-- + + +import Config +import Control.Monad +import Control.Exception +import Foreign.Ptr +import Foreign.ForeignPtr +import System.IO.Unsafe +import System.Environment +import Data.Array.Accelerate.Array.Data ( ptrsOfArrayData ) +import Data.Array.Accelerate.Array.Sugar ( Array(..) ) + +import Prelude as P +import Data.Array.Accelerate as A hiding ( size ) +import Data.Array.Accelerate.IO +import qualified Data.Array.Repa as R +import qualified Data.Array.Repa.Repr.ForeignPtr as R +import Data.Array.Repa.IO.DevIL + + +-- Mandelbrot Set -------------------------------------------------------------- + +-- <> + +-- < F -> F -> F -> Int -> Int -> Int + -> Acc (Array DIM2 (Complex,Int)) + +mandelbrot x y x' y' screenX screenY max_depth + = iterate go zs0 !! max_depth -- <4> + where + cs = genPlane x y x' y' screenX screenY -- <1> + zs0 = mkinit cs -- <2> + + go :: Acc (Array DIM2 (Complex,Int)) + -> Acc (Array DIM2 (Complex,Int)) + go = A.zipWith iter cs -- <3> +-- >> + + +-- < F + -> F -> F + -> Int + -> Int + -> Acc ComplexPlane +-- >> +genPlane lowx lowy highx highy viewx viewy + = generate (constant (Z:.viewy:.viewx)) + (\ix -> let pr = unindex2 ix + x = A.fromIntegral (A.fst pr) + y = A.fromIntegral (A.snd pr) + in + lift ( elowx + (x * exsize) / eviewx + , elowy + (y * eysize) / eviewy)) + where + elowx, elowy, exsize, eysize, eviewx, eviewy :: Exp F + + elowx = constant lowx + elowy = constant lowy + + exsize = constant (highx - lowx) + eysize = constant (highy - lowy) + + eviewx = constant (P.fromIntegral viewx) + eviewy = constant (P.fromIntegral viewy) + + +-- < Exp Complex -> Exp Complex +next c z = c `plus` (z `times` z) +-- >> + +-- < Exp Complex -> Exp Complex +plus = lift2 f + where f :: (Exp F, Exp F) -> (Exp F, Exp F) -> (Exp F, Exp F) + f (x1,y1) (x2,y2) = (x1+x2,y1+y2) +-- >> + +-- < Exp Complex -> Exp Complex +times = lift2 f + where f :: (Exp F, Exp F) -> (Exp F, Exp F) -> (Exp F, Exp F) + f (ax,ay) (bx,by) = (ax*bx-ay*by, ax*by+ay*bx) +-- >> + +-- < Exp F +dot = lift1 f + where f :: (Exp F, Exp F) -> Exp F + f (x,y) = x*x + y*y +-- >> + + +-- < Exp (Complex,Int) -> Exp (Complex,Int) +iter c p = + let + (z,i) = unlift p :: (Exp Complex, Exp Int) + z' = next c z + in + (dot z' >* 4.0) ? + ( p + , lift (z', i+1) + ) +-- >> + +-- < Acc (Array DIM2 (Complex,Int)) +mkinit cs = A.map (lift1 f) cs + where f :: (Exp F, Exp F) -> ((Exp F, Exp F), Exp Int) + f (x,y) = ((x,y),0) +-- >> + + +-- Rendering ------------------------------------------------------------------- + +type RGBA = Word32 + +prettyRGBA :: Exp Int -> Exp (Complex, Int) -> Exp RGBA +prettyRGBA lIMIT s' = r + g + b + a + where + (_, s) = unlift s' :: (Exp (F, F), Exp Int) + t = A.fromIntegral $ ((lIMIT - s) * 255) `quot` lIMIT + r = (t `mod` 128 + 64) + g = (t * 2 `mod` 128 + 64) * 0x100 + b = (t * 3 `mod` 256 ) * 0x10000 + a = 0xFF000000 + + +makePicture :: Options -> Int -> Acc (Array DIM2 (Complex, Int)) + -> R.Array R.F R.DIM3 Word8 +makePicture opt limit zs = R.fromForeignPtr (R.Z R.:. h R.:. w R.:. 4) rawData + where + arrPixels = run opt $ A.map (prettyRGBA (constant limit)) zs + (Z:.h:.w) = arrayShape arrPixels + + {-# NOINLINE rawData #-} + rawData = let (Array _ adata) = arrPixels + ((), ptr) = ptrsOfArrayData adata + in + unsafePerformIO $ newForeignPtr_ (castPtr ptr) + + + +-- Main ------------------------------------------------------------------------ + +main :: IO () +main + = do (config, nops) <- processArgs =<< getArgs + let size = optSize config + limit = optLimit config + -- + x = -0.25 -- should get this from command line as well + y = -1.0 + x' = 0.0 + y' = -0.75 + -- + image = makePicture config limit + $ mandelbrot x y x' y' size size limit + + runIL $ writeImage "out.png" (RGBA image) diff --git a/modifytwo.hs b/modifytwo.hs new file mode 100644 --- /dev/null +++ b/modifytwo.hs @@ -0,0 +1,15 @@ +import Control.Concurrent + +-- < MVar b -> (a -> b -> IO (a,b)) -> IO () +modifyTwo ma mb f = + modifyMVar_ mb $ \b -> + modifyMVar ma $ \a -> f a b +-- >> + +main = do + ma <- newMVar 'a' + mb <- newMVar 'b' + modifyTwo ma mb (\a b -> return (succ a, succ b)) + readMVar ma >>= print + readMVar mb >>= print diff --git a/mvar1.hs b/mvar1.hs new file mode 100644 --- /dev/null +++ b/mvar1.hs @@ -0,0 +1,10 @@ +import Control.Concurrent + +-- <
> + diff --git a/mvar2.hs b/mvar2.hs new file mode 100644 --- /dev/null +++ b/mvar2.hs @@ -0,0 +1,11 @@ +import Control.Concurrent + +-- <
> diff --git a/mvar3.hs b/mvar3.hs new file mode 100644 --- /dev/null +++ b/mvar3.hs @@ -0,0 +1,7 @@ +import Control.Concurrent + +-- <
> diff --git a/mvar4.hs b/mvar4.hs new file mode 100644 --- /dev/null +++ b/mvar4.hs @@ -0,0 +1,17 @@ +import Control.Concurrent +import GHC.Conc +import Debug.Trace + +-- <
> diff --git a/other/BingTranslate.hs b/other/BingTranslate.hs new file mode 100644 --- /dev/null +++ b/other/BingTranslate.hs @@ -0,0 +1,73 @@ +module BingTranslate ( + detectLanguage, + getLanguages, + translateText + ) where + +import GetURL +import Text.XML.Light +import Text.Printf +import Data.ByteString.UTF8 as UTF8 + +-- Simon Marlow's AppId, please get your own from http://msdn.microsoft.com/en-us/library/ff512386.aspx +myAppId = "3157F269F56493B5581BAA4AE7B99C35052DA38B" + +-- New v2 API: +getlanguagesUri = "http://api.microsofttranslator.com/v2/Http.svc/GetLanguagesForTranslate?appId=" ++ myAppId +detectUri = "http://api.microsofttranslator.com/v2/Http.svc/Detect?appId=" ++ myAppId +translateUri = "http://api.microsofttranslator.com/v2/Http.svc/Translate?appId=" ++ myAppId + +getLanguages :: IO [String] +getLanguages = do + r <- getURL getlanguagesUri + return (getLangs (parseXML r)) + +detectLanguage :: String -> IO String +detectLanguage text = do + r <- getURL (detectUri ++ "&text=" ++ text) + return (head (map getString (parseXML r))) + +translateText :: String -> String -> String -> IO String +translateText text fromLang toLang = do + r <- getURL (printf "%s&text=%s&from=%s&to=%s" translateUri text fromLang toLang) + return (concat (map getString (parseXML (UTF8.toString r)))) + +----------------------------------------------------------------------------- +-- Hacky XML decoding + +-- This will fail utterly if the input is not in the right form. + +getLangs :: [Content] -> [String] +getLangs [Elem (Element {elName = QName { qName = "ArrayOfstring" }, elContent = strs })] + = map getString strs + +getString :: Content -> String +getString (Elem (Element {elName = QName { qName = "string" }, elContent = [Text (CData { cdData = str })]})) = str + + +-- OLD stuff that we might need later: + +-- httpRequestUTF8 :: String -> Maybe ByteString -> IO String +-- httpRequestUTF8 url body = do +-- let request_hdr = postRequest url +-- request | Just text <- body = request_hdr `addRequestContent` text +-- | otherwise = request_hdr +-- s <- simpleHTTP request >>= getResponseBody +-- return (chopBOM (UTF8.toString s)) +-- +-- chopBOM ('\xfeff' : s) = s +-- chopBOM s = s +-- +-- postRequest :: HStream a => String -> Request a +-- postRequest urlString = +-- case parseURI urlString of +-- Nothing -> error ("postRequest: Not a valid URL - " ++ urlString) +-- Just u -> mkRequest POST u +-- +-- addRequestContent :: Request ByteString -> ByteString -> Request ByteString +-- addRequestContent rq content +-- = rq {rqBody = content, +-- rqHeaders = +-- mkHeader HdrContentType "text/plain" : +-- mkHeader HdrContentLength (show (B.length content)) : rqHeaders rq +-- } diff --git a/other/bingtranslator.hs b/other/bingtranslator.hs new file mode 100644 --- /dev/null +++ b/other/bingtranslator.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE PatternGuards #-} + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Text.Printf +import qualified Data.ByteString.UTF8 as UTF8 +import qualified Data.ByteString.Char8 as B +import System.Environment +import Prelude hiding (catch) + +import BingTranslate as Bing + +main = do + [text] <- fmap (fmap (B.unpack . UTF8.fromString)) getArgs + + languages <- Bing.getLanguages + + fromLang <- Bing.detectLanguage text + printf "\"%s\" appears to be in language \"%s\"\n" text fromLang + + forM_ (filter (/= fromLang) languages) $ \toLang -> do + str <- Bing.translateText text fromLang toLang + printf "%s: %s\n" toLang str + +----------------------------------------------------------------------------- +-- Our Async API: + +data Async a = Async ThreadId (MVar (Either SomeException a)) + +async :: IO a -> IO (Async a) +async action = do + var <- newEmptyMVar + t <- forkIO ((do r <- action; putMVar var (Right r)) + `catch` \e -> putMVar var (Left e)) + return (Async t var) + +wait :: Async a -> IO (Either SomeException a) +wait (Async t var) = readMVar var + +cancel :: Async a -> IO () +cancel (Async t var) = throwTo t ThreadKilled diff --git a/other/bingtranslatorconc.hs b/other/bingtranslatorconc.hs new file mode 100644 --- /dev/null +++ b/other/bingtranslatorconc.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE PatternGuards #-} +import Network.HTTP hiding (postRequest) +import Control.Exception +import Control.Monad +import Text.Printf +import Data.ByteString (ByteString) +import qualified Data.ByteString.UTF8 as UTF8 +import Network.URI +import System.Environment +import Control.Concurrent +import Prelude hiding (catch) +import Network.HTTP +import Network.Browser +import Network.URI +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Text.XML.Light + +import BingTranslate as Bing + +main = do + [text] <- fmap (fmap (B.unpack . UTF8.fromString)) getArgs + + languages <- Bing.getLanguages + + fromLang <- Bing.detectLanguage text + printf "\"%s\" appears to be in language \"%s\"\n" text fromLang + + translations <- concurrently $ + map (\lang -> do r <- Bing.translateText text fromLang lang; return (lang,r)) + (filter (/= fromLang) languages) + + forM_ translations $ \(lang,str) -> + printf "%s: %s\n" lang str + +----------------------------------------------------------------------------- +-- Our Async API: + +data Async a = Async ThreadId (MVar (Either SomeException a)) + +async :: IO a -> IO (Async a) +async action = do + var <- newEmptyMVar + t <- forkIO ((do r <- action; putMVar var (Right r)) + `catch` \e -> putMVar var (Left e)) + return (Async t var) + +wait :: Async a -> IO (Either SomeException a) +wait (Async t var) = readMVar var + +waitFail :: Async a -> IO a +waitFail (Async t var) = do + e <- readMVar var + case e of + Left err -> throw err + Right a -> return a + +cancel :: Async a -> IO () +cancel (Async t var) = throwTo t ThreadKilled + +concurrently :: [IO a] -> IO [a] +concurrently ios = mapM async ios >>= mapM waitFail + +-- httpRequestUTF8 :: String -> Maybe ByteString -> IO String +-- httpRequestUTF8 url body = do +-- let request_hdr = postRequest url +-- request | Just text <- body = request_hdr `addRequestContent` text +-- | otherwise = request_hdr +-- s <- simpleHTTP request >>= getResponseBody +-- return (chopBOM (UTF8.toString s)) +-- +-- chopBOM ('\xfeff' : s) = s +-- chopBOM s = s +-- +-- postRequest :: HStream a => String -> Request a +-- postRequest urlString = +-- case parseURI urlString of +-- Nothing -> error ("postRequest: Not a valid URL - " ++ urlString) +-- Just u -> mkRequest POST u +-- +-- addRequestContent :: Request ByteString -> ByteString -> Request ByteString +-- addRequestContent rq content +-- = rq {rqBody = content, +-- rqHeaders = +-- mkHeader HdrContentType "text/plain" : +-- mkHeader HdrContentLength (show (B.length content)) : rqHeaders rq +-- } diff --git a/parconc-examples.cabal b/parconc-examples.cabal new file mode 100644 --- /dev/null +++ b/parconc-examples.cabal @@ -0,0 +1,883 @@ +name: parconc-examples +version: 0.1 +synopsis: Examples to accompany the book "Parallel and Concurrent Programming in Haskell" +-- description: +license: BSD3 +license-file: LICENSE +author: Simon Marlow +maintainer: Simon Marlow +copyright: (c) Simon Marlow 2011-2013 +category: Sample Code +build-type: Simple +cabal-version: >=1.10 + +-- ----------------------------------------------------------------------------- +-- Flags + +-- -f llvm: enable -fllvm to GHC; requires LLVM to be installed, but +-- makes the Repa programs faster + +flag llvm + default: False + +-- -f devil: Enable the image-maniputation programs, which are +-- disabled by default because they require the devil library which +-- needs to be installed separately. + +flag devil + default: False + +-- -f cuda: Build the examples that require accelerate-cuda. These +-- need the NVidia CUDA tools installed. + +flag cuda + default: False + +-- ----------------------------------------------------------------------------- +-- par-eval + +executable sudoku1 + main-is: sudoku1.hs + other-modules: Sudoku + build-depends: base >= 4.5 && < 4.7 + , parallel ==3.2.* + , array ==0.4.* + default-language: Haskell2010 + +executable sudoku2 + main-is: sudoku2.hs + other-modules: Sudoku + build-depends: base >= 4.5 && < 4.7 + , parallel ==3.2.* + , array ==0.4.* + , deepseq ==1.3.* + ghc-options: -threaded + default-language: Haskell2010 + +executable sudoku3 + main-is: sudoku3.hs + other-modules: Sudoku + build-depends: base >= 4.5 && < 4.7 + , parallel ==3.2.* + , array ==0.4.* + ghc-options: -threaded + default-language: Haskell2010 + +executable sudoku4 + main-is: sudoku4.hs + other-modules: Sudoku + build-depends: base >= 4.5 && < 4.7 + , parallel ==3.2.* + , array ==0.4.* + ghc-options: -threaded + default-language: Haskell2010 + +-- ----------------------------------------------------------------------------- +-- par-strat + +executable strat + main-is: strat.hs + build-depends: base >= 4.5 && < 4.7 + , parallel ==3.2.* + ghc-options: -threaded + default-language: Haskell2010 + +executable strat2 + main-is: strat2.hs + build-depends: base >= 4.5 && < 4.7 + , parallel ==3.2.* + ghc-options: -threaded + default-language: Haskell2010 + +executable strat3 + main-is: strat3.hs + build-depends: base >= 4.5 && < 4.7 + , parallel ==3.2.* + ghc-options: -threaded + default-language: Haskell2010 + +executable rsa + main-is: rsa.hs + other-modules: ByteStringCompat + build-depends: base >= 4.5 && < 4.7 + , bytestring >= 0.9 && < 0.11 + , deepseq ==1.3.* + default-language: Haskell2010 + +executable rsa1 + main-is: rsa1.hs + other-modules: ByteStringCompat + build-depends: base >= 4.5 && < 4.7 + , bytestring >= 0.9 && < 0.11 + , parallel ==3.2.* + , deepseq ==1.3.* + ghc-options: -threaded + default-language: Haskell2010 + +executable rsa2 + main-is: rsa2.hs + other-modules: ByteStringCompat + build-depends: base >= 4.5 && < 4.7 + , bytestring >= 0.9 && < 0.11 + , parallel ==3.2.* + , deepseq ==1.3.* + ghc-options: -threaded + default-language: Haskell2010 + +executable kmeans + hs-source-dirs: kmeans + main-is: kmeans.hs + other-modules: KMeansCore + build-depends: base >= 4.5 && < 4.7 + , parallel ==3.2.* + , time ==1.4.* + , deepseq ==1.3.* + , monad-par >= 0.3.4 && < 0.4 + -- monad-par 0.3 has a bug: + -- https://github.com/simonmar/monad-par/issues/23 + , binary >= 0.5 && < 0.7 + , array ==0.4.* + , bytestring >= 0.9 && < 0.11 + , vector >= 0.10 && < 0.11 + ghc-options: -threaded + default-language: Haskell2010 + +executable GenSamples + hs-source-dirs: kmeans + main-is: GenSamples.hs + build-depends: base >= 4.5 && < 4.7 + , binary >= 0.5 && < 0.7 + , array ==0.4.* + , vector >= 0.10 && < 0.11 + , random >= 1.0 && < 1.1 + , normaldistribution >= 1.1 && < 1.2 + , deepseq ==1.3.* + , bytestring >= 0.9 && < 0.11 + default-language: Haskell2010 + +-- ----------------------------------------------------------------------------- +-- par-monad + +executable parmonad + main-is: parmonad.hs + build-depends: base >= 4.5 && < 4.7 + , monad-par >= 0.3.4 && < 0.4 + ghc-options: -threaded + default-language: Haskell2010 + +executable rsa-pipeline + main-is: rsa-pipeline.hs + other-modules: ByteStringCompat Stream + build-depends: base >= 4.5 && < 4.7 + , bytestring >= 0.9 && < 0.11 + , monad-par >= 0.3.4 && < 0.4 + , deepseq ==1.3.* + ghc-options: -threaded + default-language: Haskell2010 + +executable fwsparse + main-is: fwsparse.hs + other-modules: SparseGraph MapCompat + hs-source-dirs: fwsparse + build-depends: base >= 4.5 && < 4.7 + , random >= 1.0 && < 1.1 + , array ==0.4.* + , containers >= 0.4 && < 0.6 + default-language: Haskell2010 + +executable fwsparse1 + main-is: fwsparse1.hs + other-modules: SparseGraph MapCompat + hs-source-dirs: fwsparse + build-depends: base >= 4.5 && < 4.7 + , random >= 1.0 && < 1.1 + , array ==0.4.* + , containers >= 0.4 && < 0.6 + , monad-par >= 0.3.4 && < 0.4 + , deepseq ==1.3.* + ghc-options: -threaded + default-language: Haskell2010 + +executable timetable + main-is: timetable.hs + build-depends: base >= 4.5 && < 4.7 + , containers >= 0.4 && < 0.6 + , deepseq ==1.3.* + , random >= 1.0 && < 1.1 + default-language: Haskell2010 + +executable timetable1 + main-is: timetable1.hs + build-depends: base >= 4.5 && < 4.7 + , containers >= 0.4 && < 0.6 + , deepseq ==1.3.* + , monad-par >= 0.3.4 && < 0.4 + , random >= 1.0 && < 1.1 + default-language: Haskell2010 + +executable timetable2 + main-is: timetable2.hs + build-depends: base >= 4.5 && < 4.7 + , containers >= 0.4 && < 0.6 + , deepseq ==1.3.* + , monad-par >= 0.3.4 && < 0.4 + , random >= 1.0 && < 1.1 + default-language: Haskell2010 + +executable timetable3 + main-is: timetable3.hs + build-depends: base >= 4.5 && < 4.7 + , containers >= 0.4 && < 0.6 + , deepseq ==1.3.* + , monad-par >= 0.3.4 && < 0.4 + , random >= 1.0 && < 1.1 + default-language: Haskell2010 + +-- ----------------------------------------------------------------------------- +-- par-repa + +executable fwdense + main-is: fwdense.hs + build-depends: base >= 4.5 && < 4.7 + , repa == 3.2.* + ghc-options: -O2 + if flag(llvm) + ghc-options: -fllvm + default-language: Haskell2010 + +executable fwdense1 + main-is: fwdense1.hs + build-depends: base >= 4.5 && < 4.7 + , repa == 3.2.* + , transformers ==0.3.* + ghc-options: -O2 -threaded + if flag(llvm) + ghc-options: -fllvm + default-language: Haskell2010 + +executable rotateimage + main-is: rotateimage.hs + build-depends: base >= 4.5 && < 4.7 + , repa == 3.2.* + ghc-options: -O2 -threaded + if flag(devil) + build-depends: repa-devil == 0.3.* + else + buildable: False + if flag(llvm) + ghc-options: -fllvm + default-language: Haskell2010 + +-- ----------------------------------------------------------------------------- +-- par-accel + +executable fwaccel + main-is: fwaccel.hs + build-depends: base >= 4.5 && < 4.7 + , accelerate >= 0.12 + ghc-options: -O2 + default-language: Haskell2010 + +executable fwaccel-gpu + main-is: fwaccel.hs + build-depends: base >= 4.5 && < 4.7 + , accelerate >= 0.12 + if flag(cuda) + build-depends: accelerate-cuda >= 0.12 + else + buildable: False + ghc-options: -O2 + default-language: Haskell2010 + +executable mandel + main-is: mandel.hs + other-modules: Config + hs-source-dirs: mandel + build-depends: base >= 4.5 && < 4.7 + , accelerate >= 0.12 + , fclabels + , accelerate-io + if flag(cuda) + build-depends: accelerate-cuda >= 0.12 + else + buildable: False + ghc-options: -O2 + default-language: Haskell2010 + +-- ----------------------------------------------------------------------------- +-- conc-fork + +executable fork + main-is: fork.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +executable reminders + main-is: reminders.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +executable reminders2 + main-is: reminders2.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +-- ----------------------------------------------------------------------------- +-- conc-mvar + +executable mvar1 + main-is: mvar1.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +executable mvar2 + main-is: mvar2.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +executable mvar3 + main-is: mvar3.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +executable logger + main-is: logger.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +executable phonebook + main-is: phonebook.hs + build-depends: base >= 4.5 && < 4.7 + , containers >= 0.4 && < 0.6 + default-language: Haskell2010 + +executable chan + main-is: chan.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +executable chan2 + main-is: chan2.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +-- ----------------------------------------------------------------------------- +-- conc-overlap + +executable geturls1 + main-is: geturls1.hs + other-modules: GetURL + build-depends: base >= 4.5 && < 4.7 + , containers >= 0.4 && < 0.6 + , network >= 2.3 && < 2.5 + , HTTP ==4000.2.* + , bytestring >= 0.9 && < 0.11 + default-language: Haskell2010 + +executable geturls2 + main-is: geturls2.hs + other-modules: GetURL + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + , bytestring >= 0.9 && < 0.11 + , time ==1.4.* + , network >= 2.3 && < 2.5 + , HTTP ==4000.2.* + default-language: Haskell2010 + +executable geturls3 + main-is: geturls3.hs + other-modules: TimeIt GetURL + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + , bytestring >= 0.9 && < 0.11 + , time ==1.4.* + , network >= 2.3 && < 2.5 + , HTTP ==4000.2.* + default-language: Haskell2010 + +executable geturls4 + main-is: geturls4.hs + other-modules: GetURL + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + , bytestring >= 0.9 && < 0.11 + , time ==1.4.* + , network >= 2.3 && < 2.5 + , HTTP ==4000.2.* + default-language: Haskell2010 + +executable geturls5 + main-is: geturls5.hs + other-modules: GetURL + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + , bytestring >= 0.9 && < 0.11 + , time ==1.4.* + , network >= 2.3 && < 2.5 + , HTTP ==4000.2.* + default-language: Haskell2010 + +executable geturls6 + main-is: geturls6.hs + other-modules: TimeIt GetURL + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + , bytestring >= 0.9 && < 0.11 + , time ==1.4.* + , network >= 2.3 && < 2.5 + , HTTP ==4000.2.* + default-language: Haskell2010 + +-- ----------------------------------------------------------------------------- +-- conc-asyncex + +executable geturlscancel + main-is: geturlscancel.hs + other-modules: TimeIt GetURL + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + , bytestring >= 0.9 && < 0.11 + , time ==1.4.* + , network >= 2.3 && < 2.5 + , HTTP ==4000.2.* + default-language: Haskell2010 + +executable geturlscancel2 + main-is: geturlscancel2.hs + other-modules: TimeIt GetURL + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + , bytestring >= 0.9 && < 0.11 + , time ==1.4.* + , network >= 2.3 && < 2.5 + , HTTP ==4000.2.* + default-language: Haskell2010 + +executable modifytwo + main-is: modifytwo.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +executable chan3 + main-is: chan3.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +executable timeout + main-is: timeout.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +executable catch-mask + main-is: catch-mask.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +executable catch-mask2 + main-is: catch-mask2.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +-- ----------------------------------------------------------------------------- +-- conc-stm + +-- not mentioned in the text? +executable windowman + main-is: windowman.hs + build-depends: base >= 4.5 && < 4.7 + , containers >= 0.4 && < 0.6 + , stm ==2.4.* + default-language: Haskell2010 + +executable tmvar + main-is: tmvar.hs + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + default-language: Haskell2010 + +executable geturlsfirst + main-is: geturlsfirst.hs + other-modules: ConcurrentUtils + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + , bytestring >= 0.9 && < 0.11 + , time ==1.4.* + , HTTP ==4000.2.* + , network >= 2.3 && < 2.5 + default-language: Haskell2010 + +executable TChan + main-is: TChan.hs + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + default-language: Haskell2010 + +executable TList + main-is: TList.hs + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + default-language: Haskell2010 + +executable TQueue + main-is: TQueue.hs + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + default-language: Haskell2010 + +executable TBQueue + main-is: TBQueue.hs + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + default-language: Haskell2010 + +-- ----------------------------------------------------------------------------- +-- conc-higher + +executable geturls7 + main-is: geturls7.hs + other-modules: ConcurrentUtils + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + , bytestring >= 0.9 && < 0.11 + , time ==1.4.* + , network >= 2.3 && < 2.5 + , HTTP ==4000.2.* + default-language: Haskell2010 + +executable geturls8 + main-is: geturls8.hs + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + , bytestring >= 0.9 && < 0.11 + , time ==1.4.* + , network >= 2.3 && < 2.5 + , HTTP ==4000.2.* + default-language: Haskell2010 + +executable geturls9 + main-is: geturls9.hs + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + , bytestring >= 0.9 && < 0.11 + , time ==1.4.* + , network >= 2.3 && < 2.5 + , HTTP ==4000.2.* + default-language: Haskell2010 + +executable timeout2 + main-is: timeout.hs + build-depends: base >= 4.5 && < 4.7 + , async ==2.0.* + default-language: Haskell2010 + +-- ----------------------------------------------------------------------------- +-- conc-par + +executable findseq + main-is: findseq.hs + build-depends: base >= 4.5 && < 4.7 + , filepath ==1.3.* + , directory >= 1.1 && < 1.3 + default-language: Haskell2010 + +executable findpar + main-is: findpar.hs + build-depends: base >= 4.5 && < 4.7 + , filepath ==1.3.* + , directory >= 1.1 && < 1.3 + , async ==2.0.* + default-language: Haskell2010 + +executable findpar2 + main-is: findpar2.hs + build-depends: base >= 4.5 && < 4.7 + , filepath ==1.3.* + , directory >= 1.1 && < 1.3 + , async ==2.0.* + default-language: Haskell2010 + +executable findpar3 + main-is: findpar3.hs + other-modules: CasIORef + build-depends: base >= 4.5 && < 4.7 + , filepath ==1.3.* + , directory >= 1.1 && < 1.3 + , async ==2.0.* + , stm ==2.4.* + default-language: Haskell2010 + +executable findpar4 + main-is: findpar4.hs + build-depends: base >= 4.5 && < 4.7 + , filepath ==1.3.* + , directory >= 1.1 && < 1.3 + , async ==2.0.* + , stm ==2.4.* + , transformers ==0.3.* + , abstract-par ==0.3.* + , monad-par >= 0.3.4 && < 0.4 + default-language: Haskell2010 + +-- ----------------------------------------------------------------------------- +-- conc-server + +executable server + main-is: server.hs + other-modules: ConcurrentUtils + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + , network >= 2.3 && < 2.5 + default-language: Haskell2010 + +executable server2 + main-is: server2.hs + other-modules: ConcurrentUtils + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + , async ==2.0.* + , network >= 2.3 && < 2.5 + default-language: Haskell2010 + +executable chat + main-is: chat.hs + other-modules: ConcurrentUtils + build-depends: base >= 4.5 && < 4.7 + , containers >= 0.4 && < 0.6 + , async ==2.0.* + , stm ==2.4.* + , network >= 2.3 && < 2.5 + default-language: Haskell2010 + +-- ----------------------------------------------------------------------------- +-- conc-distrib + +executable ping + main-is: distrib-ping/ping.hs + other-modules: DistribUtils + build-depends: base >= 4.5 && < 4.7 + , network >= 2.3 && < 2.5 + , binary >= 0.5 && < 0.7 + , distributed-process >= 0.4.2 && < 0.5 + , distributed-process-simplelocalnet ==0.2.* + , distributed-static ==0.2.* + , template-haskell >= 2.7 && < 2.9 + if impl(ghc <= 7.6) + -- prior to ghc-7.4 generics lived in ghc-prim + build-depends: ghc-prim + default-language: Haskell2010 + +executable ping-multi + main-is: distrib-ping/ping-multi.hs + other-modules: DistribUtils + build-depends: base >= 4.5 && < 4.7 + , network >= 2.3 && < 2.5 + , binary >= 0.5 && < 0.7 + , distributed-process >= 0.4.2 && < 0.5 + , distributed-process-simplelocalnet ==0.2.* + , distributed-static ==0.2.* + , template-haskell >= 2.7 && < 2.9 + if impl(ghc <= 7.6) + -- prior to ghc-7.4 generics lived in ghc-prim + build-depends: ghc-prim + default-language: Haskell2010 + +executable ping-tc + main-is: distrib-ping/ping-tc.hs + other-modules: DistribUtils + build-depends: base >= 4.5 && < 4.7 + , network >= 2.3 && < 2.5 + , binary >= 0.5 && < 0.7 + , distributed-process >= 0.4.2 && < 0.5 + , distributed-process-simplelocalnet ==0.2.* + , distributed-static ==0.2.* + , template-haskell >= 2.7 && < 2.9 + if impl(ghc <= 7.6) + -- prior to ghc-7.4 generics lived in ghc-prim + build-depends: ghc-prim + default-language: Haskell2010 + +executable ping-tc-merge + main-is: distrib-ping/ping-tc-merge.hs + other-modules: DistribUtils + build-depends: base >= 4.5 && < 4.7 + , network >= 2.3 && < 2.5 + , binary >= 0.5 && < 0.7 + , distributed-process >= 0.4.2 && < 0.5 + , distributed-process-simplelocalnet ==0.2.* + , distributed-static ==0.2.* + , template-haskell >= 2.7 && < 2.9 + if impl(ghc <= 7.6) + -- prior to ghc-7.4 generics lived in ghc-prim + build-depends: ghc-prim + default-language: Haskell2010 + +-- extra, not in the text? +executable ping-tc-notify + main-is: distrib-ping/ping-tc-notify.hs + other-modules: DistribUtils + build-depends: base >= 4.5 && < 4.7 + , network >= 2.3 && < 2.5 + , binary >= 0.5 && < 0.7 + , distributed-process >= 0.4.2 && < 0.5 + , distributed-process-simplelocalnet ==0.2.* + , distributed-static ==0.2.* + , template-haskell >= 2.7 && < 2.9 + if impl(ghc <= 7.6) + -- prior to ghc-7.4 generics lived in ghc-prim + build-depends: ghc-prim + default-language: Haskell2010 + +executable ping-fail + main-is: distrib-ping/ping-fail.hs + build-depends: base >= 4.5 && < 4.7 + , network >= 2.3 && < 2.5 + , binary >= 0.5 && < 0.7 + , distributed-process >= 0.4.2 && < 0.5 + , distributed-process-simplelocalnet ==0.2.* + , distributed-static ==0.2.* + , template-haskell >= 2.7 && < 2.9 + if impl(ghc <= 7.6) + -- prior to ghc-7.4 generics lived in ghc-prim + build-depends: ghc-prim + default-language: Haskell2010 + +executable distrib-chat + main-is: distrib-chat/chat.hs + other-modules: ConcurrentUtils DistribUtils + build-depends: base >= 4.5 && < 4.7 + , containers >= 0.4 && < 0.6 + , stm ==2.4.* + , async ==2.0.* + , network >= 2.3 && < 2.5 + , binary >= 0.5 && < 0.7 + , distributed-process >= 0.4.2 && < 0.5 + , distributed-process-simplelocalnet ==0.2.* + , distributed-static ==0.2.* + , transformers ==0.3.* + , template-haskell >= 2.7 && < 2.9 + if impl(ghc <= 7.6) + -- prior to ghc-7.4 generics lived in ghc-prim + build-depends: ghc-prim + default-language: Haskell2010 + +executable distrib-chat-noslave + main-is: distrib-chat/chat-noslave.hs + other-modules: ConcurrentUtils + build-depends: base >= 4.5 && < 4.7 + , containers >= 0.4 && < 0.6 + , stm ==2.4.* + , async ==2.0.* + , network >= 2.3 && < 2.5 + , binary >= 0.5 && < 0.7 + , distributed-process >= 0.4.2 && < 0.5 + , distributed-process-simplelocalnet ==0.2.* + , distributed-static ==0.2.* + , transformers ==0.3.* + , template-haskell >= 2.7 && < 2.9 + if impl(ghc <= 7.6) + -- prior to ghc-7.4 generics lived in ghc-prim + build-depends: ghc-prim + default-language: Haskell2010 + +executable distrib-db + main-is: db.hs + hs-source-dirs: . distrib-db + other-modules: DistribUtils Database + build-depends: base >= 4.5 && < 4.7 + , containers >= 0.4 && < 0.6 + , stm ==2.4.* + , async ==2.0.* + , network >= 2.3 && < 2.5 + , binary >= 0.5 && < 0.7 + , distributed-process >= 0.4.2 && < 0.5 + , distributed-process-simplelocalnet ==0.2.* + , distributed-static ==0.2.* + , transformers ==0.3.* + , template-haskell >= 2.7 && < 2.9 + if impl(ghc <= 7.6) + -- prior to ghc-7.4 generics lived in ghc-prim + build-depends: ghc-prim + default-language: Haskell2010 + +-- ----------------------------------------------------------------------------- +-- conc-debugging-tuning + +executable mvar4 + main-is: mvar4.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +executable deadlock1 + main-is: deadlock1.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +executable deadlock2 + main-is: deadlock2.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +executable threadperf1 + main-is: threadperf1.hs + build-depends: base >= 4.5 && < 4.7 + default-language: Haskell2010 + +executable threadperf2 + main-is: threadperf2.hs + build-depends: base >= 4.5 && < 4.7 + ghc-options: -rtsopts + default-language: Haskell2010 + +-- ----------------------------------------------------------------------------- +-- Extras (exercises etc.) + +executable bingtranslator + main-is: bingtranslator.hs + other-modules: BingTranslate GetURL + hs-source-dirs: other . + build-depends: base >= 4.5 && < 4.7 + , bytestring >= 0.9 && < 0.11 + , time ==1.4.* + , HTTP ==4000.2.* + , network >= 2.3 && < 2.5 + , utf8-string ==0.3.* + , xml ==1.3.* + default-language: Haskell2010 + +executable bingtranslatorconc + main-is: bingtranslatorconc.hs + other-modules: BingTranslate GetURL + hs-source-dirs: other . + build-depends: base >= 4.5 && < 4.7 + , bytestring >= 0.9 && < 0.11 + , time ==1.4.* + , HTTP ==4000.2.* + , network >= 2.3 && < 2.5 + , utf8-string ==0.3.* + , xml ==1.3.* + default-language: Haskell2010 + +executable geturlsstm + main-is: geturlsstm.hs + other-modules: TimeIt GetURL + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + , bytestring >= 0.9 && < 0.11 + , time ==1.4.* + , network >= 2.3 && < 2.5 + , HTTP ==4000.2.* + default-language: Haskell2010 + +executable Async + main-is: Async.hs + build-depends: base >= 4.5 && < 4.7 + , stm ==2.4.* + default-language: Haskell2010 + +-- ToDo: +-- euler35 +-- index +-- sudoku-par{1,2,3,4,5} +-- parinfer + diff --git a/parmonad.hs b/parmonad.hs new file mode 100644 --- /dev/null +++ b/parmonad.hs @@ -0,0 +1,27 @@ +import Control.Exception +import System.Environment +import Control.Monad.Par.Scheds.Trace +-- NB. using Trace here, Direct is too strict and forces the fibs in +-- the parent; see https://github.com/simonmar/monad-par/issues/27 + +-- < Integer +fib 0 = 1 +fib 1 = 1 +fib n = fib (n-1) + fib (n-2) +-- >> + +main = do + args <- getArgs + let [n,m] = map read args + print $ +-- < + j <- new -- <1> + fork (put i (fib n)) -- <2> + fork (put j (fib m)) -- <2> + a <- get i -- <3> + b <- get j -- <3> + return (a+b) -- <4> +-- >> diff --git a/phonebook.hs b/phonebook.hs new file mode 100644 --- /dev/null +++ b/phonebook.hs @@ -0,0 +1,42 @@ +import Data.Map (Map) +import qualified Data.Map as Map +import Control.Concurrent +import Prelude hiding (lookup) + +-- <> + +-- <> + +-- < Name -> PhoneNumber -> IO () +insert (PhoneBookState m) name number = do + book <- takeMVar m + putMVar m (Map.insert name number book) +-- >> + +-- < Name -> IO (Maybe PhoneNumber) +lookup (PhoneBookState m) name = do + book <- takeMVar m + putMVar m book + return (Map.lookup name book) +-- >> + +-- <
>= print + lookup s "unknown" >>= print +-- >> diff --git a/reminders.hs b/reminders.hs new file mode 100644 --- /dev/null +++ b/reminders.hs @@ -0,0 +1,17 @@ +-- < + forkIO $ setReminder s -- <2> + +setReminder :: String -> IO () +setReminder s = do + let t = read s :: Int + printf "Ok, I'll remind you in %d seconds\n" t + threadDelay (10^6 * t) -- <3> + printf "%d seconds is up! BING!\BEL\n" t -- <4> +-- >> diff --git a/reminders2.hs b/reminders2.hs new file mode 100644 --- /dev/null +++ b/reminders2.hs @@ -0,0 +1,21 @@ +import Control.Concurrent +import Text.Printf +import Control.Monad + +-- <
> + +setReminder :: String -> IO () +setReminder s = do + let t = read s :: Int + printf "Ok, I'll remind you in %d seconds\n" t + threadDelay (10^6 * t) -- <3> + printf "%d seconds is up! BING!\BEL\n" t -- <4> diff --git a/rotateimage.hs b/rotateimage.hs new file mode 100644 --- /dev/null +++ b/rotateimage.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE FlexibleContexts, BangPatterns #-} + +import Data.Array.Repa +import Data.Array.Repa.IO.DevIL +import System.Environment +import Data.Array.Repa.Repr.ForeignPtr +import Data.Word + +-- <
+ rotated <- computeP $ rotate (read n) v :: IL (Array F DIM3 Word8) -- <2> + writeImage f2 (RGB rotated) -- <3> +-- >> + +-- < Array F DIM3 Word8 -> Array D DIM3 Word8 +rotate deg g = fromFunction (Z :. y :. x :. k) f -- <1> + where + sh@(Z :. y :. x :. k) = extent g + + !theta = pi/180 * deg -- <2> + + !st = sin theta -- <3> + !ct = cos theta + + !cy = fromIntegral y / 2 :: Double -- <4> + !cx = fromIntegral x / 2 :: Double + + f (Z :. i :. j :. k) -- <5> + | inShape sh old = g ! old -- <6> + | otherwise = 0 -- <7> + where + fi = fromIntegral i - cy -- <8> + fj = fromIntegral j - cx + + i' = round (st * fj + ct * fi + cy) -- <9> + j' = round (ct * fj - st * fi + cx) + + old = Z :. i' :. j' :. k -- <10> +-- >> + diff --git a/rsa-pipeline.hs b/rsa-pipeline.hs new file mode 100644 --- /dev/null +++ b/rsa-pipeline.hs @@ -0,0 +1,103 @@ +-- +-- Derived from a program believed to be originally written by John +-- Launchbury, and incorporating the RSA algorithm which is in the +-- public domain. +-- + +import System.Environment +import Data.List +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) +import ByteStringCompat +import Control.Monad.Par.Scheds.Trace + +import Stream + +main = do + [f] <- getArgs + text <- case f of + "-" -> B.getContents + _ -> B.readFile f + B.putStr (pipeline n e d text) + +-- example keys, created by makeKey below +n, d, e :: Integer +(n,d,e) = (3539517541822645630044332546732747854710141643130106075585179940882036712515975698104695392573887034788933523673604280427152984392565826058380509963039612419361429882234327760449752708861159361414595229,121492527803044541056704751360974487724009957507650761043424679483464778334890045929773805597614290949,216244483337223224019000724904989828660716358310562600433314577442746058361727768326718965949745599136958260211917551718034992348233259083876505235987999070191048638795502931877693189179113255689722281) + + +-- < Integer -> Stream ByteString -> Par (Stream ByteString) +encrypt n e s = streamMap (B.pack . show . power e n . code) s + +decrypt :: Integer -> Integer -> Stream ByteString -> Par (Stream ByteString) +decrypt n d s = streamMap (B.pack . decode . power d n . integer) s +-- >> + +integer :: ByteString -> Integer +integer b | Just (i,_) <- B.readInteger b = i + +-- < Integer -> Integer -> ByteString -> ByteString +pipeline n e d b = runPar $ do + s0 <- streamFromList (chunk (size n) b) + s1 <- encrypt n e s0 + s2 <- decrypt n d s1 + xs <- streamFold (\x y -> (y : x)) [] s2 + return (B.unlines (reverse xs)) +-- >> + +integers :: [ByteString] -> [Integer] +integers bs = [ i | Just (i,_) <- map B.readInteger bs ] + +-------- Converting between Strings and Integers ----------- + +code :: ByteString -> Integer +code = B.foldl' accum 0 + where accum x y = (128 * x) + fromIntegral (fromEnum y) + +decode :: Integer -> String +decode n = reverse (expand n) + where expand 0 = [] + expand x = toEnum (fromIntegral (x `mod` 128)) : expand (x `div` 128) + +chunk :: Int -> ByteString -> [ByteString] +chunk n xs | B.null xs = [] +chunk n xs = as : chunk n bs + where (as,bs) = B.splitAt (fromIntegral n) xs + +size :: Integer -> Int +size n = (length (show n) * 47) `div` 100 -- log_128 10 = 0.4745 + +------- Constructing keys ------------------------- + +makeKeys :: Integer -> Integer -> (Integer, Integer, Integer) +makeKeys r s = (p*q, d, invert ((p-1)*(q-1)) d) + where p = nextPrime r + q = nextPrime s + d = nextPrime (p+q+1) + +nextPrime :: Integer -> Integer +nextPrime a = head (filter prime [odd,odd+2..]) + where odd | even a = a+1 + | True = a + prime p = and [power (p-1) p x == 1 | x <- [3,5,7]] + +invert :: Integer -> Integer -> Integer +invert n a = if e<0 then e+n else e + where e=iter n 0 a 1 + +iter :: Integer -> Integer -> Integer -> Integer -> Integer +iter g v 0 w = v +iter g v h w = iter h w (g `mod` h) (v - (g `div` h)*w) + +------- Fast exponentiation, mod m ----------------- + +power :: Integer -> Integer -> Integer -> Integer +power 0 m x = 1 +power n m x | even n = sqr (power (n `div` 2) m x) `mod` m + | True = (x * power (n-1) m x) `mod` m + +sqr :: Integer -> Integer +sqr x = x * x + + diff --git a/rsa.hs b/rsa.hs new file mode 100644 --- /dev/null +++ b/rsa.hs @@ -0,0 +1,94 @@ +-- +-- Derived from a program believed to be originally written by John +-- Launchbury, and incorporating the RSA algorithm which is in the +-- public domain. +-- + +import System.Environment +import Data.List +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) +import ByteStringCompat + +main = do + [cmd,f] <- getArgs + text <- case f of + "-" -> B.getContents + _ -> B.readFile f + case cmd of + "encrypt" -> B.putStr (encrypt n e text) + "decrypt" -> B.putStr (decrypt n d text) + +-- example keys, created by makeKey below +n, d, e :: Integer +(n,d,e) = (3539517541822645630044332546732747854710141643130106075585179940882036712515975698104695392573887034788933523673604280427152984392565826058380509963039612419361429882234327760449752708861159361414595229,121492527803044541056704751360974487724009957507650761043424679483464778334890045929773805597614290949,216244483337223224019000724904989828660716358310562600433314577442746058361727768326718965949745599136958260211917551718034992348233259083876505235987999070191048638795502931877693189179113255689722281) + + +encrypt, decrypt :: Integer -> Integer -> ByteString -> ByteString + +-- < + . map (B.pack . show . power e n . code) -- <2> + . chunk (size n) -- <1> +-- >> + +decrypt n d = B.concat + . map (B.pack . decode . power d n) + . integers + . B.lines + +integers :: [ByteString] -> [Integer] +integers bs = [ i | Just (i,_) <- map B.readInteger bs ] + +-------- Converting between Strings and Integers ----------- + +code :: ByteString -> Integer +code = B.foldl' accum 0 + where accum x y = (128 * x) + fromIntegral (fromEnum y) + +decode :: Integer -> String +decode n = reverse (expand n) + where expand 0 = [] + expand x = toEnum (fromIntegral (x `mod` 128)) : expand (x `div` 128) + +chunk :: Int -> ByteString -> [ByteString] +chunk n xs | B.null xs = [] +chunk n xs = as : chunk n bs + where (as,bs) = B.splitAt (fromIntegral n) xs + +size :: Integer -> Int +size n = (length (show n) * 47) `div` 100 -- log_128 10 = 0.4745 + +------- Constructing keys ------------------------- + +makeKeys :: Integer -> Integer -> (Integer, Integer, Integer) +makeKeys r s = (p*q, d, invert ((p-1)*(q-1)) d) + where p = nextPrime r + q = nextPrime s + d = nextPrime (p+q+1) + +nextPrime :: Integer -> Integer +nextPrime a = head (filter prime [odd,odd+2..]) + where odd | even a = a+1 + | True = a + prime p = and [power (p-1) p x == 1 | x <- [3,5,7]] + +invert :: Integer -> Integer -> Integer +invert n a = if e<0 then e+n else e + where e=iter n 0 a 1 + +iter :: Integer -> Integer -> Integer -> Integer -> Integer +iter g v 0 w = v +iter g v h w = iter h w (g `mod` h) (v - (g `div` h)*w) + +------- Fast exponentiation, mod m ----------------- + +power :: Integer -> Integer -> Integer -> Integer +power 0 m x = 1 +power n m x | even n = sqr (power (n `div` 2) m x) `mod` m + | True = (x * power (n-1) m x) `mod` m + +sqr :: Integer -> Integer +sqr x = x * x + + diff --git a/rsa1.hs b/rsa1.hs new file mode 100644 --- /dev/null +++ b/rsa1.hs @@ -0,0 +1,96 @@ +-- +-- Derived from a program believed to be originally written by John +-- Launchbury, and incorporating the RSA algorithm which is in the +-- public domain. +-- + +import System.Environment +import Control.Parallel.Strategies +import Data.List +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) +import ByteStringCompat + +main = do + [cmd,f] <- getArgs + text <- case f of + "-" -> B.getContents + _ -> B.readFile f + case cmd of + "encrypt" -> B.putStr (encrypt n e text) + "decrypt" -> B.putStr (decrypt n d text) + +-- example keys, created by makeKey below +n, d, e :: Integer +(n,d,e) = (3539517541822645630044332546732747854710141643130106075585179940882036712515975698104695392573887034788933523673604280427152984392565826058380509963039612419361429882234327760449752708861159361414595229,121492527803044541056704751360974487724009957507650761043424679483464778334890045929773805597614290949,216244483337223224019000724904989828660716358310562600433314577442746058361727768326718965949745599136958260211917551718034992348233259083876505235987999070191048638795502931877693189179113255689722281) + + +encrypt, decrypt :: Integer -> Integer -> ByteString -> ByteString + +-- < + . map (B.pack . show . power e n . code) + . chunk (size n) +-- >> + +decrypt n d = B.concat + . map (B.pack . decode . power d n) + . integers + . B.lines + +integers :: [ByteString] -> [Integer] +integers bs = [ i | Just (i,_) <- map B.readInteger bs ] + +-------- Converting between Strings and Integers ----------- + +code :: ByteString -> Integer +code = B.foldl' accum 0 + where accum x y = (128 * x) + fromIntegral (fromEnum y) + +decode :: Integer -> String +decode n = reverse (expand n) + where expand 0 = [] + expand x = toEnum (fromIntegral (x `mod` 128)) : expand (x `div` 128) + +chunk :: Int -> ByteString -> [ByteString] +chunk n xs | B.null xs = [] +chunk n xs = as : chunk n bs + where (as,bs) = B.splitAt (fromIntegral n) xs + +size :: Integer -> Int +size n = (length (show n) * 47) `div` 100 -- log_128 10 = 0.4745 + +------- Constructing keys ------------------------- + +makeKeys :: Integer -> Integer -> (Integer, Integer, Integer) +makeKeys r s = (p*q, d, invert ((p-1)*(q-1)) d) + where p = nextPrime r + q = nextPrime s + d = nextPrime (p+q+1) + +nextPrime :: Integer -> Integer +nextPrime a = head (filter prime [odd,odd+2..]) + where odd | even a = a+1 + | True = a + prime p = and [power (p-1) p x == 1 | x <- [3,5,7]] + +invert :: Integer -> Integer -> Integer +invert n a = if e<0 then e+n else e + where e=iter n 0 a 1 + +iter :: Integer -> Integer -> Integer -> Integer -> Integer +iter g v 0 w = v +iter g v h w = iter h w (g `mod` h) (v - (g `div` h)*w) + +------- Fast exponentiation, mod m ----------------- + +power :: Integer -> Integer -> Integer -> Integer +power 0 m x = 1 +power n m x | even n = sqr (power (n `div` 2) m x) `mod` m + | True = (x * power (n-1) m x) `mod` m + +sqr :: Integer -> Integer +sqr x = x * x + + diff --git a/rsa2.hs b/rsa2.hs new file mode 100644 --- /dev/null +++ b/rsa2.hs @@ -0,0 +1,96 @@ +-- +-- Derived from a program believed to be originally written by John +-- Launchbury, and incorporating the RSA algorithm which is in the +-- public domain. +-- + +import System.Environment +import Control.Parallel.Strategies +import Data.List +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) +import ByteStringCompat + +main = do + [cmd,f] <- getArgs + text <- case f of + "-" -> B.getContents + _ -> B.readFile f + case cmd of + "encrypt" -> B.putStr (encrypt n e text) + "decrypt" -> B.putStr (decrypt n d text) + +-- example keys, created by makeKey below +n, d, e :: Integer +(n,d,e) = (3539517541822645630044332546732747854710141643130106075585179940882036712515975698104695392573887034788933523673604280427152984392565826058380509963039612419361429882234327760449752708861159361414595229,121492527803044541056704751360974487724009957507650761043424679483464778334890045929773805597614290949,216244483337223224019000724904989828660716358310562600433314577442746058361727768326718965949745599136958260211917551718034992348233259083876505235987999070191048638795502931877693189179113255689722281) + + +encrypt, decrypt :: Integer -> Integer -> ByteString -> ByteString + +-- < + . map (B.pack . show . power e n . code) + . chunk (size n) +-- >> + +decrypt n d = B.concat + . map (B.pack . decode . power d n) + . integers + . B.lines + +integers :: [ByteString] -> [Integer] +integers bs = [ i | Just (i,_) <- map B.readInteger bs ] + +-------- Converting between Strings and Integers ----------- + +code :: ByteString -> Integer +code = B.foldl' accum 0 + where accum x y = (128 * x) + fromIntegral (fromEnum y) + +decode :: Integer -> String +decode n = reverse (expand n) + where expand 0 = [] + expand x = toEnum (fromIntegral (x `mod` 128)) : expand (x `div` 128) + +chunk :: Int -> ByteString -> [ByteString] +chunk n xs | B.null xs = [] +chunk n xs = as : chunk n bs + where (as,bs) = B.splitAt (fromIntegral n) xs + +size :: Integer -> Int +size n = (length (show n) * 47) `div` 100 -- log_128 10 = 0.4745 + +------- Constructing keys ------------------------- + +makeKeys :: Integer -> Integer -> (Integer, Integer, Integer) +makeKeys r s = (p*q, d, invert ((p-1)*(q-1)) d) + where p = nextPrime r + q = nextPrime s + d = nextPrime (p+q+1) + +nextPrime :: Integer -> Integer +nextPrime a = head (filter prime [odd,odd+2..]) + where odd | even a = a+1 + | True = a + prime p = and [power (p-1) p x == 1 | x <- [3,5,7]] + +invert :: Integer -> Integer -> Integer +invert n a = if e<0 then e+n else e + where e=iter n 0 a 1 + +iter :: Integer -> Integer -> Integer -> Integer -> Integer +iter g v 0 w = v +iter g v h w = iter h w (g `mod` h) (v - (g `div` h)*w) + +------- Fast exponentiation, mod m ----------------- + +power :: Integer -> Integer -> Integer -> Integer +power 0 m x = 1 +power n m x | even n = sqr (power (n `div` 2) m x) `mod` m + | True = (x * power (n-1) m x) `mod` m + +sqr :: Integer -> Integer +sqr x = x * x + + diff --git a/server.hs b/server.hs new file mode 100644 --- /dev/null +++ b/server.hs @@ -0,0 +1,35 @@ +import ConcurrentUtils +import Network +import Control.Monad +import Control.Concurrent (forkIO) +import System.IO +import Text.Printf +import Control.Exception + +-- <
+ printf "Listening on port %d\n" port + forever $ do -- <2> + (handle, host, port) <- accept sock -- <3> + printf "Accepted connection from %s: %s\n" host (show port) + forkFinally (talk handle) (\_ -> hClose handle) -- <4> + +port :: Int +port = 44444 +-- >> + +-- < IO () +talk h = do + hSetBuffering h LineBuffering -- <1> + loop -- <2> + where + loop = do + line <- hGetLine h -- <3> + if line == "end" -- <4> + then hPutStrLn h ("Thank you for using the " ++ -- <5> + "Haskell doubling service.") + else do hPutStrLn h (show (2 * (read line :: Integer))) -- <6> + loop -- <7> +-- >> diff --git a/server2.hs b/server2.hs new file mode 100644 --- /dev/null +++ b/server2.hs @@ -0,0 +1,74 @@ +import Network +import Control.Monad +import Control.Concurrent +import System.IO +import Text.Printf +import Control.Exception +import Control.Concurrent.Async +import Control.Concurrent.STM +import ConcurrentUtils (forkFinally) + +-- <
+ forever $ do + (handle, host, port) <- accept sock + printf "Accepted connection from %s: %s\n" host (show port) + forkFinally (talk handle factor) (\_ -> hClose handle) -- <2> + +port :: Int +port = 44444 +-- >> + +-- < TVar Integer -> IO () +talk h factor = do + hSetBuffering h LineBuffering + c <- atomically newTChan -- <1> + race (server h factor c) (receive h c) -- <2> + return () +-- >> + +-- < TChan String -> IO () +receive h c = forever $ do + line <- hGetLine h + atomically $ writeTChan c line +-- >> + +-- < TVar Integer -> TChan String -> IO () +server h factor c = do + f <- atomically $ readTVar factor -- <1> + hPrintf h "Current factor: %d\n" f -- <2> + loop f -- <3> + where + loop f = do + action <- atomically $ do -- <4> + f' <- readTVar factor -- <5> + if (f /= f') -- <6> + then return (newfactor f') -- <7> + else do + l <- readTChan c -- <8> + return (command f l) -- <9> + action + + newfactor f = do -- <10> + hPrintf h "new factor: %d\n" f + loop f + + command f s -- <11> + = case s of + "end" -> + hPutStrLn h ("Thank you for using the " ++ + "Haskell doubling service.") -- <12> + '*':s -> do + atomically $ writeTVar factor (read s :: Integer) -- <13> + loop f + line -> do + hPutStrLn h (show (f * (read line :: Integer))) + loop f +-- >> + diff --git a/strat.hs b/strat.hs new file mode 100644 --- /dev/null +++ b/strat.hs @@ -0,0 +1,26 @@ +import Control.Parallel +import Control.Parallel.Strategies (rpar, Strategy, using) +import Text.Printf +import System.Environment + +-- < Integer +fib 0 = 1 +fib 1 = 1 +fib n = fib (n-1) + fib (n-2) +-- >> + +main = print pair + where + pair = +-- <> + +-- <> diff --git a/strat2.hs b/strat2.hs new file mode 100644 --- /dev/null +++ b/strat2.hs @@ -0,0 +1,31 @@ +import Control.Parallel +import Control.Parallel.Strategies (rpar, Strategy, using) +import Text.Printf +import System.Environment + +-- < Integer +fib 0 = 1 +fib 1 = 1 +fib n = fib (n-1) + fib (n-2) +-- >> + +main = print pair + where + pair = +-- <> + +-- < Strategy b -> Strategy (a,b) +evalPair sa sb (a,b) = do + a' <- sa a + b' <- sb b + return (a',b') +-- >> + +-- <> diff --git a/strat3.hs b/strat3.hs new file mode 100644 --- /dev/null +++ b/strat3.hs @@ -0,0 +1,32 @@ +import Control.Parallel +import Control.Parallel.Strategies (rpar, rseq, Strategy, using, rparWith) +import Control.Exception +import Text.Printf +import System.Environment + +-- < Integer +fib 0 = 1 +fib 1 = 1 +fib n = fib (n-1) + fib (n-2) +-- >> + +main = print pair + where + pair = +-- <> + +-- < Strategy b -> Strategy (a,b) +evalPair sa sb (a,b) = do + a' <- sa a + b' <- sb b + return (a',b') +-- >> + +-- < Strategy b -> Strategy (a,b) +parPair sa sb = evalPair (rparWith sa) (rparWith sb) +-- >> diff --git a/sudoku1.hs b/sudoku1.hs new file mode 100644 --- /dev/null +++ b/sudoku1.hs @@ -0,0 +1,16 @@ +-- < + file <- readFile f -- <2> + + let puzzles = lines file -- <3> + solutions = map solve puzzles -- <4> + + print (length (filter isJust solutions)) -- <5> +-- >> diff --git a/sudoku2.hs b/sudoku2.hs new file mode 100644 --- /dev/null +++ b/sudoku2.hs @@ -0,0 +1,27 @@ +import Sudoku +import Control.Exception +import System.Environment +import Control.Parallel.Strategies +import Control.DeepSeq +import Data.Maybe + +-- <
+ + solutions = runEval $ do + as' <- rpar (force (map solve as)) -- <2> + bs' <- rpar (force (map solve bs)) -- <2> + rseq as' -- <3> + rseq bs' -- <3> + return (as' ++ bs') -- <4> + + print (length (filter isJust solutions)) +-- >> + diff --git a/sudoku3.hs b/sudoku3.hs new file mode 100644 --- /dev/null +++ b/sudoku3.hs @@ -0,0 +1,26 @@ +import Sudoku +import Control.Exception +import System.Environment +import Control.Parallel.Strategies hiding (parMap) +import Data.Maybe + +-- <
> + +-- < b) -> [a] -> Eval [b] +parMap f [] = return [] +parMap f (a:as) = do + b <- rpar (f a) + bs <- parMap f as + return (b:bs) +-- >> diff --git a/sudoku4.hs b/sudoku4.hs new file mode 100644 --- /dev/null +++ b/sudoku4.hs @@ -0,0 +1,25 @@ +import Sudoku +import Control.Exception +import System.Environment +import Control.Parallel.Strategies hiding (parMap) +import Data.Maybe + +-- <
> + +parMap :: (a -> b) -> [a] -> Eval [b] +parMap f [] = return [] +parMap f (a:as) = do + b <- rpar (f a) + bs <- parMap f as + return (b:bs) diff --git a/threadperf1.hs b/threadperf1.hs new file mode 100644 --- /dev/null +++ b/threadperf1.hs @@ -0,0 +1,11 @@ +import Control.Concurrent +import Control.Monad + +-- <
> diff --git a/threadperf2.hs b/threadperf2.hs new file mode 100644 --- /dev/null +++ b/threadperf2.hs @@ -0,0 +1,13 @@ +import Control.Concurrent +import Control.Monad + +-- <
> diff --git a/timeout.hs b/timeout.hs new file mode 100644 --- /dev/null +++ b/timeout.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveDataTypeable #-} +import Control.Concurrent +import Data.Unique +import Control.Exception +import Data.Typeable + +data Timeout = Timeout Unique deriving (Eq, Typeable) + +instance Show Timeout where + show (Timeout _) = "timeout" + +instance Exception Timeout + +-- < IO a -> IO (Maybe a) +-- >> + +-- < + | t == 0 = return Nothing -- <1> + | otherwise = do + pid <- myThreadId -- <2> + u <- newUnique -- <3> + let ex = Timeout u -- <3> + handleJust -- <4> + (\e -> if e == ex then Just () else Nothing) -- <5> + (\_ -> return Nothing) -- <6> + (bracket (forkIO $ do threadDelay t -- <7> + throwTo pid ex) + (\tid -> throwTo tid ThreadKilled) -- <8> + (\_ -> fmap Just m)) -- <9> +-- >> + +main = (timeout 200000 $ timeout 100000 $ timeout 300000 $ threadDelay 1000000) >>= print diff --git a/timetable.hs b/timetable.hs new file mode 100644 --- /dev/null +++ b/timetable.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE OverloadedStrings #-} + +import System.Random +import System.Environment +import Debug.Trace +import Data.List +import Control.DeepSeq + +import Data.Map (Map) +import qualified Data.Map as Map + +-- ---------------------------------------------------------------------------- + +-- <> + +-- <> + +-- <> + +-- ---------------------------------------------------------------------------- + +-- < [Talk] -> Int -> Int -> [TimeTable] +timetable people allTalks maxTrack maxSlot = +-- >> +-- <> + where +-- < Int -- current track number + -> [[Talk]] -- slots allocated so far + -> [Talk] -- talks in this slot + -> [Talk] -- talks that can be allocated in this slot + -> [Talk] -- all talks remaining to be allocated + -> [TimeTable] -- all possible solutions +-- >> + +-- < + | trackNo == maxTrack = + generate (slotNo+1) 0 (slot:slots) [] talks talks -- <2> + | otherwise = concat -- <3> + [ generate slotNo (trackNo+1) slots (t:slot) slotTalks' talks' -- <8> + | (t, ts) <- selects slotTalks -- <4> + , let clashesWithT = Map.findWithDefault [] t clashes -- <5> + , let slotTalks' = filter (`notElem` clashesWithT) ts -- <6> + , let talks' = filter (/= t) talks -- <7> + ] +-- >> + +-- <> + +-- ---------------------------------------------------------------------------- +-- Utils + +-- < [(a,[a])] +selects xs0 = go [] xs0 + where + go xs [] = [] + go xs (y:ys) = (y,xs++ys) : go (y:xs) ys +-- >> + +-- ---------------------------------------------------------------------------- +-- Benchmarking / Testing + +bench :: Int -> Int -> Int -> Int -> Int -> StdGen + -> ([Person],[Talk],[TimeTable]) + +bench nslots ntracks ntalks npersons c_per_s gen = + (persons,talks, timetable persons talks ntracks nslots) + where + total_talks = nslots * ntracks + + talks = map Talk [1..total_talks] + persons = mkpersons npersons gen + + mkpersons :: Int -> StdGen -> [Person] + mkpersons 0 g = [] + mkpersons n g = Person ('P':show n) (take c_per_s cs) : rest + where + (g1,g2) = split g + rest = mkpersons (n-1) g2 + cs = nub [ talks !! n | n <- randomRs (0,ntalks-1) g ] + +main = do + [ a, b, c, d, e ] <- fmap (fmap read) getArgs + let g = mkStdGen 1001 + let (ss,cs,ts) = bench a b c d e g + print ss + print (length ts) +-- [ a, b ] <- fmap (fmap read) getArgs +-- print (head (test2 a b)) + +test = timetable testPersons cs 2 2 + where + cs@[c1,c2,c3,c4] = map Talk [1..4] + + testPersons = + [ Person "P" [c1,c2] + , Person "Q" [c2,c3] + , Person "R" [c3,c4] + , Person "S" [c1,c4] + ] + +test2 n m = timetable testPersons cs m n + where + cs = map Talk [1 .. (n * m)] + + testPersons = + [ Person "1" (take n cs) + ] diff --git a/timetable1.hs b/timetable1.hs new file mode 100644 --- /dev/null +++ b/timetable1.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE OverloadedStrings #-} + +import System.Random +import System.Environment +import Debug.Trace +import Data.List +import Control.DeepSeq + +import Data.Map (Map) +import qualified Data.Map as Map + +-- ---------------------------------------------------------------------------- + +-- <> + +-- <> + +-- <> + +-- ---------------------------------------------------------------------------- +-- The parallel skeleton + +-- < Maybe solution ) -- <1> + -> ( partial -> [ partial ] ) -- <2> + -> partial -- <3> + -> [solution] -- <4> +-- >> + +-- <> + +-- ---------------------------------------------------------------------------- + +-- <> + +-- < [Talk] -> Int -> Int -> [TimeTable] +timetable people allTalks maxTrack maxSlot = + search finished refine emptysoln + where + emptysoln = (0, 0, [], [], allTalks, allTalks) + + finished (slotNo, trackNo, slots, slot, slotTalks, talks) + | slotNo == maxSlot = Just slots + | otherwise = Nothing + + clashes :: Map Talk [Talk] + clashes = Map.fromListWith union + [ (t, ts) + | s <- people + , (t, ts) <- selects (talks s) ] + + refine (slotNo, trackNo, slots, slot, slotTalks, talks) + | trackNo == maxTrack = [(slotNo+1, 0, slot:slots, [], talks, talks)] + | otherwise = + [ (slotNo, trackNo+1, slots, t:slot, slotTalks', talks') + | (t, ts) <- selects slotTalks + , let clashesWithT = Map.findWithDefault [] t clashes + , let slotTalks' = filter (`notElem` clashesWithT) ts + , let talks' = filter (/= t) talks + ] +-- >> + +-- ---------------------------------------------------------------------------- +-- Utils + +-- < [(a,[a])] +selects xs0 = go [] xs0 + where + go xs [] = [] + go xs (y:ys) = (y,xs++ys) : go (y:xs) ys +-- >> + +-- ---------------------------------------------------------------------------- +-- Benchmarking / Testing + +bench :: Int -> Int -> Int -> Int -> Int -> StdGen + -> ([Person],[Talk],[TimeTable]) + +bench nslots ntracks ntalks npersons c_per_s gen = + (persons,talks, timetable persons talks ntracks nslots) + where + total_talks = nslots * ntracks + + talks = map Talk [1..total_talks] + persons = mkpersons npersons gen + + mkpersons :: Int -> StdGen -> [Person] + mkpersons 0 g = [] + mkpersons n g = Person ('P':show n) (take c_per_s cs) : rest + where + (g1,g2) = split g + rest = mkpersons (n-1) g2 + cs = nub [ talks !! n | n <- randomRs (0,ntalks-1) g ] + +main = do + [ a, b, c, d, e ] <- fmap (fmap read) getArgs + let g = mkStdGen 1001 + let (ss,cs,ts) = bench a b c d e g + print ss + print (length ts) +-- [ a, b ] <- fmap (fmap read) getArgs +-- print (head (test2 a b)) + +test = timetable testPersons cs 2 2 + where + cs@[c1,c2,c3,c4] = map Talk [1..4] + + testPersons = + [ Person "P" [c1,c2] + , Person "Q" [c2,c3] + , Person "R" [c3,c4] + ] + +test2 n m = timetable testPersons cs m n + where + cs = map Talk [1 .. (n * m)] + + testPersons = + [ Person "1" (take n cs) + ] diff --git a/timetable2.hs b/timetable2.hs new file mode 100644 --- /dev/null +++ b/timetable2.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE OverloadedStrings #-} + +import System.Random +import System.Environment +import Debug.Trace +import Data.List +import Control.Monad.Par +import Control.DeepSeq + +import Data.Map (Map) +import qualified Data.Map as Map + +-- ---------------------------------------------------------------------------- + +-- <> + +-- <> + +-- <> + +-- ---------------------------------------------------------------------------- +-- The parallel skeleton + +-- < Maybe solution ) -- <1> + -> ( partial -> [ partial ] ) -- <2> + -> partial -- <3> + -> [solution] -- <4> +-- >> + +-- <> + +-- < ( partial -> Maybe solution ) + -> ( partial -> [ partial ] ) + -> partial + -> [solution] + +parsearch finished refine emptysoln + = runPar $ generate emptysoln + where + generate partial + | Just soln <- finished partial = return [soln] + | otherwise = do + solnss <- parMapM generate (refine partial) + return (concat solnss) +-- >> + +-- ---------------------------------------------------------------------------- + +-- <> + +-- < [Talk] -> Int -> Int -> [TimeTable] +timetable people allTalks maxTrack maxSlot = + parsearch finished refine emptysoln + where + emptysoln = (0, 0, [], [], allTalks, allTalks) + + finished (slotNo, trackNo, slots, slot, slotTalks, talks) + | slotNo == maxSlot = Just slots + | otherwise = Nothing + + clashes :: Map Talk [Talk] + clashes = Map.fromListWith union + [ (t, ts) + | s <- people + , (t, ts) <- selects (talks s) ] + + refine (slotNo, trackNo, slots, slot, slotTalks, talks) + | trackNo == maxTrack = [(slotNo+1, 0, slot:slots, [], talks, talks)] + | otherwise = + [ (slotNo, trackNo+1, slots, t:slot, slotTalks', talks') + | (t, ts) <- selects slotTalks + , let clashesWithT = Map.findWithDefault [] t clashes + , let slotTalks' = filter (`notElem` clashesWithT) ts + , let talks' = filter (/= t) talks + ] +-- >> + +-- ---------------------------------------------------------------------------- +-- Utils + +-- < [(a,[a])] +selects xs0 = go [] xs0 + where + go xs [] = [] + go xs (y:ys) = (y,xs++ys) : go (y:xs) ys +-- >> + +-- ---------------------------------------------------------------------------- +-- Benchmarking / Testing + +bench :: Int -> Int -> Int -> Int -> Int -> StdGen + -> ([Person],[Talk],[TimeTable]) + +bench nslots ntracks ntalks npersons c_per_s gen = + (persons,talks, timetable persons talks ntracks nslots) + where + total_talks = nslots * ntracks + + talks = map Talk [1..total_talks] + persons = mkpersons npersons gen + + mkpersons :: Int -> StdGen -> [Person] + mkpersons 0 g = [] + mkpersons n g = Person ('P':show n) (take c_per_s cs) : rest + where + (g1,g2) = split g + rest = mkpersons (n-1) g2 + cs = nub [ talks !! n | n <- randomRs (0,ntalks-1) g ] + +main = do + [ a, b, c, d, e ] <- fmap (fmap read) getArgs + let g = mkStdGen 1001 + let (ss,cs,ts) = bench a b c d e g + print ss + print (length ts) +-- [ a, b ] <- fmap (fmap read) getArgs +-- print (head (test2 a b)) + +test = timetable testPersons cs 2 2 + where + cs@[c1,c2,c3,c4] = map Talk [1..4] + + testPersons = + [ Person "P" [c1,c2] + , Person "Q" [c2,c3] + , Person "R" [c3,c4] + ] + +test2 n m = timetable testPersons cs m n + where + cs = map Talk [1 .. (n * m)] + + testPersons = + [ Person "1" (take n cs) + ] diff --git a/timetable3.hs b/timetable3.hs new file mode 100644 --- /dev/null +++ b/timetable3.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE OverloadedStrings #-} + +import System.Random +import System.Environment +import Debug.Trace +import Data.List +import Control.Monad.Par +import Control.DeepSeq + +import Data.Map (Map) +import qualified Data.Map as Map + +-- ---------------------------------------------------------------------------- + +-- <> + +-- <> + +-- <> + +-- ---------------------------------------------------------------------------- +-- The parallel skeleton + +-- < Maybe solution ) -- <1> + -> ( partial -> [ partial ] ) -- <2> + -> partial -- <3> + -> [solution] -- <4> +-- >> + +-- <> + +-- < Int + -> ( partial -> Maybe solution ) -- finished? + -> ( partial -> [ partial ] ) -- refine a solution + -> partial -- initial solution + -> [solution] + +parsearch maxdepth finished refine emptysoln + = runPar $ generate 0 emptysoln + where + generate d partial | d >= maxdepth -- <1> + = return (search finished refine partial) + generate d partial + | Just soln <- finished partial = return [soln] + | otherwise = do + solnss <- parMapM (generate (d+1)) (refine partial) + return (concat solnss) +-- >> + +-- ---------------------------------------------------------------------------- + +-- <> + +-- < [Talk] -> Int -> Int -> [TimeTable] +timetable people allTalks maxTrack maxSlot = + parsearch 3 finished refine emptysoln + where + emptysoln = (0, 0, [], [], allTalks, allTalks) + + finished (slotNo, trackNo, slots, slot, slotTalks, talks) + | slotNo == maxSlot = Just slots + | otherwise = Nothing + + clashes :: Map Talk [Talk] + clashes = Map.fromListWith union + [ (t, ts) + | s <- people + , (t, ts) <- selects (talks s) ] + + refine (slotNo, trackNo, slots, slot, slotTalks, talks) + | trackNo == maxTrack = [(slotNo+1, 0, slot:slots, [], talks, talks)] + | otherwise = + [ (slotNo, trackNo+1, slots, t:slot, slotTalks', talks') + | (t, ts) <- selects slotTalks + , let clashesWithT = Map.findWithDefault [] t clashes + , let slotTalks' = filter (`notElem` clashesWithT) ts + , let talks' = filter (/= t) talks + ] +-- >> + +-- ---------------------------------------------------------------------------- +-- Utils + +-- < [(a,[a])] +selects xs0 = go [] xs0 + where + go xs [] = [] + go xs (y:ys) = (y,xs++ys) : go (y:xs) ys +-- >> + +-- ---------------------------------------------------------------------------- +-- Benchmarking / Testing + +bench :: Int -> Int -> Int -> Int -> Int -> StdGen + -> ([Person],[Talk],[TimeTable]) + +bench nslots ntracks ntalks npersons c_per_s gen = + (persons,talks, timetable persons talks ntracks nslots) + where + total_talks = nslots * ntracks + + talks = map Talk [1..total_talks] + persons = mkpersons npersons gen + + mkpersons :: Int -> StdGen -> [Person] + mkpersons 0 g = [] + mkpersons n g = Person ('P':show n) (take c_per_s cs) : rest + where + (g1,g2) = split g + rest = mkpersons (n-1) g2 + cs = nub [ talks !! n | n <- randomRs (0,ntalks-1) g ] + +main = do + [ a, b, c, d, e ] <- fmap (fmap read) getArgs + let g = mkStdGen 1001 + let (ss,cs,ts) = bench a b c d e g + print ss + print (length ts) +-- [ a, b ] <- fmap (fmap read) getArgs +-- print (head (test2 a b)) + +test = timetable testPersons cs 2 2 + where + cs@[c1,c2,c3,c4] = map Talk [1..4] + + testPersons = + [ Person "P" [c1,c2] + , Person "Q" [c2,c3] + , Person "R" [c3,c4] + ] + +test2 n m = timetable testPersons cs m n + where + cs = map Talk [1 .. (n * m)] + + testPersons = + [ Person "1" (take n cs) + ] diff --git a/tmvar.hs b/tmvar.hs new file mode 100644 --- /dev/null +++ b/tmvar.hs @@ -0,0 +1,49 @@ +module TMVar where + +import Control.Concurrent.STM hiding (TMVar, takeTMVar) + +-- <> + +newTMVar :: a -> STM (TMVar a) +newTMVar a = do + t <- newTVar (Just a) + return (TMVar t) + +-- <> + +-- < STM a +takeTMVar (TMVar t) = do + m <- readTVar t -- <1> + case m of + Nothing -> retry -- <2> + Just a -> do + writeTVar t Nothing -- <3> + return a +-- >> + +-- < a -> STM () +putTMVar (TMVar t) a = do + m <- readTVar t + case m of + Nothing -> do + writeTVar t (Just a) + return () + Just _ -> retry +-- >> + +-- < TMVar b -> STM (Either a b) +takeEitherTMVar ma mb = + fmap Left (takeTMVar ma) + `orElse` + fmap Right (takeTMVar mb) +-- >> diff --git a/windowman.hs b/windowman.hs new file mode 100644 --- /dev/null +++ b/windowman.hs @@ -0,0 +1,74 @@ +module WindowManager where + +import Control.Concurrent.STM +import Data.Map as Map +import Data.Set as Set +import Data.Maybe + +data Window +instance Eq Window +instance Ord Window + +data Desktop +instance Eq Desktop +instance Ord Desktop + +type Display = Map Desktop (TVar (Set Window)) + +-- < Window -> Desktop -> Desktop -> STM () +moveWindowSTM disp win a b = do + wa <- readTVar ma + wb <- readTVar mb + writeTVar ma (Set.delete win wa) + writeTVar mb (Set.insert win wb) + where + ma = disp ! a + mb = disp ! b +-- >> + +-- < Window -> Desktop -> Desktop -> IO () +moveWindow disp win a b = atomically $ moveWindowSTM disp win a b +-- >> + +-- < Window -> Desktop + -> Window -> Desktop + -> IO () +swapWindows disp w a v b = atomically $ do + moveWindowSTM disp w a b + moveWindowSTM disp v b a +-- >> + +render :: Set Window -> IO () +render = undefined + +-- <> + +-- < UserFocus -> STM (Set Window) +getWindows disp focus = do + desktop <- readTVar focus + readTVar (disp ! desktop) +-- >> + +-- < UserFocus -> IO () +renderThread disp focus = do + wins <- atomically $ getWindows disp focus -- <1> + loop wins -- <2> + where + loop wins = do -- <3> + render wins -- <4> + next <- atomically $ do + wins' <- getWindows disp focus -- <5> + if (wins == wins') -- <6> + then retry -- <7> + else return wins' -- <8> + loop next +-- >> +