The Haskell code below uses Software Transactional Memory to concurrently manage a factory with a set of production line, each with a set of raw materials.
The raw materials can be moved from one production line to the other. One production line is supplied with power at a time, the initial processing of raw materials in one production assembly can be done in parallel.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| module FactoryManager where | |
| import Control.Concurrent.STM | |
| import Data.Map as Map | |
| import Data.Set as Set | |
| import Data.Maybe | |
| data RawMaterial | |
| instance Eq RawMaterial | |
| instance Ord RawMaterial | |
| data ProductionLine | |
| instance Eq ProductionLine | |
| instance Ord ProductionLine | |
| type Factory = Map ProductionLine (TVar (Set RawMaterial)) | |
| — moveRawMaterialSTM | |
| moveRawMaterialSTM :: Factory -> RawMaterial -> ProductionLine -> ProductionLine -> STM () | |
| moveRawMaterialSTM factory raw_mat a b = do | |
| wa <- readTVar ma | |
| wb <- readTVar mb | |
| writeTVar ma (Set.delete raw_mat wa) | |
| writeTVar mb (Set.insert raw_mat wb) | |
| where | |
| ma = factory ! a | |
| mb = factory ! b | |
| — >> | |
| — moveRawMaterial | |
| moveRawMaterial :: Factory -> RawMaterial -> ProductionLine -> ProductionLine -> IO () | |
| moveRawMaterial factory raw_mat a b = atomically $ moveRawMaterialSTM factory raw_mat a b | |
| — >> | |
| — swapRawMaterials | |
| swapRawMaterials :: Factory | |
| -> RawMaterial -> ProductionLine | |
| -> RawMaterial -> ProductionLine | |
| -> IO () | |
| swapRawMaterials factory w a v b = atomically $ do | |
| moveRawMaterialSTM factory w a b | |
| moveRawMaterialSTM factory v b a | |
| — >> | |
| process_raw_materials :: Set RawMaterial -> IO () | |
| process_raw_materials = undefined | |
| — ProductionLineToProcess | |
| type ProductionLineToProcess = TVar ProductionLine | |
| — >> | |
| — getRawMaterials | |
| getRawMaterials :: Factory -> ProductionLineToProcess -> STM (Set RawMaterial) | |
| getRawMaterials factory prod_line_to_process = do | |
| pline <- readTVar prod_line_to_process | |
| readTVar (factory ! pline) | |
| — >> | |
| — process_raw_materialsThread | |
| process_raw_materialsThread :: Factory -> ProductionLineToProcess -> IO () | |
| process_raw_materialsThread factory prod_line_to_process = do | |
| raw_mats <- atomically $ getRawMaterials factory prod_line_to_process | |
| loop raw_mats | |
| where | |
| loop raw_mats = do | |
| process_raw_materials raw_mats | |
| next <- atomically $ do | |
| raw_mats' <- getRawMaterials factory prod_line_to_process | |
| if (raw_mats == raw_mats') | |
| then retry | |
| else return raw_mats' | |
| loop next | |
| — |