Moved TriadCommittee to hierarchical location.

1 files changed, 89 insertions, 0 deletions

diff --git a/src/Control/TriadCommittee.hs b/src/Control/TriadCommittee.hs
new file mode 100644
index 00000000..88e665b6
--- /dev/null
+++ b/src/Control/TriadCommittee.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE TupleSections #-}
+module Control.TriadCommittee where
+
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Maybe
+
+
+data TriadSlot = SlotA | SlotB | SlotC
+ deriving (Eq,Ord,Enum,Show,Read)
+
+data TriadCommittee voter a = TriadCommittee
+    { triadDecider :: TVar TriadSlot
+    , triadA :: TVar (Maybe (voter,a))
+    , triadB :: TVar (Maybe (voter,a))
+    , triadC :: TVar (Maybe (voter,a))
+    , triadNewDecision :: a -> STM ()
+    }
+
+triadSlot :: TriadSlot -> TriadCommittee voter a -> TVar (Maybe (voter,a))
+triadSlot SlotA = triadA
+triadSlot SlotB = triadB
+triadSlot SlotC = triadC
+
+triadDecision :: a -> TriadCommittee voter a -> STM a
+triadDecision fallback triad = do
+    slot <- readTVar (triadDecider triad)
+    maybe fallback snd <$> readTVar (triadSlot slot triad)
+
+
+newTriadCommittee :: (a -> STM ()) -> STM (TriadCommittee voter a)
+newTriadCommittee onChange =
+    TriadCommittee <$> newTVar SlotA
+                   <*> newTVar Nothing
+                   <*> newTVar Nothing
+                   <*> newTVar Nothing
+                   <*> pure onChange
+
+
+triadCountVotes :: Eq a => Maybe a -> TriadCommittee voter a -> STM ()
+triadCountVotes prior triad = do
+    a <- fmap ((SlotA,) . snd) <$> readTVar (triadA triad)
+    b <- fmap ((SlotB,) . snd) <$> readTVar (triadB triad)
+    c <- fmap ((SlotC,) . snd) <$> readTVar (triadC triad)
+    let (slot,vote) = case catMaybes [a,b,c] of
+            [  (x,xvote)
+             , (y,yvote)
+             , (z,zvote) ]  -> if xvote == yvote then (x,Just xvote)
+                                                 else (z,Just zvote)
+            []              -> (SlotA,Nothing)
+            ((slot,vote):_) -> (slot, Just vote)
+    writeTVar (triadDecider triad) slot
+    case vote of
+        Just v | vote /= prior -> triadNewDecision triad v
+        _                      -> return ()
+
+
+addVote :: (Eq voter, Eq a) => TriadCommittee voter a -> voter -> a -> STM ()
+addVote triad voter vote = do
+    a <- (SlotA,) . fmap fst <$> readTVar (triadA triad)
+    b <- (SlotB,) . fmap fst <$> readTVar (triadB triad)
+    c <- (SlotC,) . fmap fst <$> readTVar (triadC triad)
+    let avail (_,Nothing) = True
+        avail (_,Just x ) = (x == voter)
+        slots = filter avail [a,b,c]
+    forM_ (take 1 slots) $ \(slot,_) -> do
+        prior <- do
+            slotp <- readTVar (triadDecider triad)
+            fmap snd <$> readTVar (triadSlot slotp triad)
+        writeTVar (triadSlot slot triad)
+                  (Just (voter,vote))
+        triadCountVotes prior triad
+
+
+delVote :: (Eq voter, Eq a) => TriadCommittee voter a -> voter -> STM ()
+delVote triad voter = do
+    a <- (SlotA,) . fmap fst <$> readTVar (triadA triad)
+    b <- (SlotB,) . fmap fst <$> readTVar (triadB triad)
+    c <- (SlotC,) . fmap fst <$> readTVar (triadC triad)
+    let match (_,Just x ) = (x == voter)
+        match _           = False
+        slots = filter match [a,b,c]
+    forM_ (take 1 slots) $ \(slot,_) -> do
+        prior <- do
+            slotp <- readTVar (triadDecider triad)
+            fmap snd <$> readTVar (triadSlot slotp triad)
+        writeTVar (triadSlot slot triad) Nothing
+        triadCountVotes prior triad
+