Advertisement
Guest User

Untitled

a guest
May 19th, 2010
169
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. -- Local Propagation Network
  2.  
  3. module LPN where
  4.  
  5. import List
  6. import Data.Maybe
  7. import Control.Monad.State
  8. import Debug.Trace
  9.  
  10.  
  11. {-- Types --}
  12.  
  13. type WireName = String
  14. type Value = Double
  15. type WireValue = Maybe Double
  16. type NodeName = String
  17. type Settor = Maybe NodeName
  18. type Connection = (WireName, NodeName)
  19.  
  20. data Wire = Wire { wname :: WireName, wvalue :: WireValue, wsettor :: Settor }
  21.             deriving (Show)
  22.  
  23. data Node = Constant   { nname :: NodeName, nwire :: WireName } |
  24.             IO         { nname :: NodeName, nwire :: WireName } |
  25.             Adder      { nname :: NodeName, naddend1 :: WireName, naddend2 :: WireName, nsum :: WireName } |
  26.             Multiplier { nname :: NodeName, nfactor1 :: WireName, nfactor2 :: WireName, nproduct :: WireName }
  27.             deriving (Show)
  28.  
  29. data Network = Network { nodes :: [Node], wires :: [Wire], conns :: [Connection], msgs :: [String] }
  30.              deriving (Show)
  31.  
  32. type LPN a = State Network a
  33.  
  34.  
  35. {-- Wire API --}
  36.  
  37. wireMake :: WireName -> Wire
  38. wireMake name = Wire name Nothing Nothing
  39.  
  40. wireName :: Wire -> WireName
  41. wireName = wname
  42.  
  43. wireSettor :: Wire -> Settor
  44. wireSettor = wsettor
  45.  
  46. wireHasSettor :: Wire -> Bool
  47. wireHasSettor = isJust . wsettor
  48.  
  49. wireSettorIs :: Wire -> NodeName -> Bool
  50. wireSettorIs wire settor | wireHasSettor wire = fromJust (wireSettor wire) == settor
  51. wireSettorIs _ _         | otherwise          = False
  52.  
  53. wireHasValue :: Wire -> NodeName -> Bool
  54. wireHasValue wire querent | wireHasSettor wire = fromJust (wireSettor wire) /= querent
  55. wireHasValue _ _          | otherwise          = False
  56.  
  57. wireValue :: Wire -> NodeName -> WireValue
  58. wireValue wire querent | wireHasValue wire querent  = wvalue wire
  59. wireValue _    _       | otherwise                  = Nothing
  60.  
  61. wireSet :: Wire -> NodeName -> Value -> Wire
  62. wireSet (Wire name _ _) settor v = Wire name (Just v) (Just settor)
  63.  
  64. wireRevoke :: Wire -> Wire
  65. wireRevoke (Wire name _ _) = Wire name Nothing Nothing
  66.  
  67.  
  68. {-- Node API --}
  69.  
  70. nodeName :: Node -> NodeName
  71. nodeName = nname
  72.  
  73.  
  74. {-- Network API --}
  75.  
  76. networkMake :: Network
  77. networkMake = Network [] [] [] []
  78.  
  79. lookupWire :: WireName -> LPN Wire
  80. lookupWire name = get >>= return . fromJust . find (\w -> wireName w == name) . wires
  81.  
  82.  
  83. lookupWireValue :: WireName -> NodeName -> LPN WireValue
  84. lookupWireValue name querent = lookupWire name >>= (\w -> return . wireValue w $ querent)
  85.  
  86.  
  87. lookupNode :: NodeName -> LPN Node
  88. lookupNode name = get >>= return . fromJust . find (\n -> nodeName n == name) . nodes
  89.  
  90.  
  91. findConnected :: Wire -> LPN [NodeName]
  92. findConnected wire = do
  93.   net <- get
  94.   let name = wireName wire
  95.   return (map snd . filter (\(wn,nn) -> wn == name) $ conns net)
  96.  
  97.  
  98. updateWire :: Wire -> NodeName -> LPN ()
  99. updateWire wire except = do
  100.   let name = wireName wire
  101.   net@(Network ns ws cs ms) <- get
  102.   let ws' = map (\w -> if wireName w == name then wire else w) ws
  103.  put $ Network ns ws' cs ms
  104.   findConnected wire >>= sequence . map notifyNode . filter (/= except)
  105.   return ()
  106.  
  107.  
  108. addMessage :: String -> LPN ()
  109. addMessage msg = do
  110.   net@(Network ns ws cs ms) <- get
  111.   put $ Network ns ws cs $ msg:ms
  112.  
  113.  
  114. addWire :: WireName -> LPN WireName
  115. addWire name = do
  116.   Network ns ws cs ms <- get
  117.   put $ Network ns ((wireMake name) : ws) cs ms
  118.   return name
  119.  
  120.  
  121. addConstant :: NodeName -> Value -> WireName -> LPN ()
  122. addConstant name v wire = do
  123.   Network ns ws cs ms <- get
  124.   put $ Network (c:ns) ws ((wire,name):cs) ms
  125.   setWire wire name v
  126.     where c = Constant name wire
  127.  
  128.  
  129. addAdder :: NodeName -> WireName -> WireName -> WireName -> LPN ()
  130. addAdder name ad1 ad2 sum = do
  131.   Network ns ws cs ms <- get
  132.   put $ Network (a:ns) ws ((ad1,name):(ad2,name):(sum,name):cs) ms
  133.     where a = Adder name ad1 ad2 sum
  134.  
  135. adder :: NodeName -> WireName -> WireName -> WireName -> LPN ()
  136. adder name ad1 ad2 sum = do
  137.   v1 <- lookupWireValue ad1 name
  138.   v2 <- lookupWireValue ad2 name
  139.   vs <- lookupWireValue sum name
  140.   if isJust v1 && isJust v2
  141.     then setWire sum name (fromJust v1 + fromJust v2)
  142.     else revokeWire sum name
  143.   if isJust v1 && isJust vs
  144.     then setWire ad2 name (fromJust vs - fromJust v1)
  145.     else revokeWire ad2 name
  146.   if isJust v2 && isJust vs
  147.     then setWire ad1 name (fromJust vs - fromJust v2)
  148.     else revokeWire ad1 name
  149.  
  150.  
  151. addMultiplier :: NodeName -> WireName -> WireName -> WireName -> LPN ()
  152. addMultiplier name fa1 fa2 pro = do
  153.   Network ns ws cs ms <- get
  154.   put $ Network (m:ns) ws ((fa1,name):(fa2,name):(pro,name):cs) ms
  155.     where m = Multiplier name fa1 fa2 pro
  156.  
  157. multiplier :: NodeName -> WireName -> WireName -> WireName -> LPN ()
  158. multiplier name fa1 fa2 pro = do
  159.   v1 <- lookupWireValue fa1 name
  160.   v2 <- lookupWireValue fa2 name
  161.   vp <- lookupWireValue pro name
  162.   if isJust v1 && isJust v2
  163.     then setWire pro name (fromJust v1 * fromJust v2)
  164.     else
  165.       if isJust v1 && fromJust v1 == 0
  166.         then setWire pro name 0
  167.         else
  168.           if isJust v2 && fromJust v2 == 0
  169.             then setWire pro name 0
  170.             else revokeWire pro name
  171.   if isJust v1 && isJust vp
  172.     then
  173.       if fromJust v1 /= 0
  174.         then setWire fa2 name (fromJust vp / fromJust v1)
  175.         else
  176.           if fromJust vp /= 0
  177.             then error "Division by zero"
  178.             else return ()
  179.     else revokeWire fa2 name
  180.   if isJust v2 && isJust vp
  181.     then
  182.       if fromJust v2 /= 0
  183.         then setWire fa1 name (fromJust vp / fromJust v2)
  184.         else
  185.           if fromJust vp /= 0
  186.             then error "Division by zero"
  187.             else return ()
  188.     else revokeWire fa1 name
  189.  
  190.  
  191. addIO :: NodeName -> WireName -> LPN NodeName
  192. addIO name wire = do
  193.   Network ns ws cs ms <- get
  194.   put $ Network (i:ns) ws ((wire,name):cs) ms
  195.   return name
  196.     where i = IO name wire
  197.  
  198. io :: NodeName -> WireName -> LPN ()
  199. io name wire = do
  200.     v <- lookupWire wire >>= (\w -> return . wireValue w $ name)
  201.     let msg = wire ++ ": " ++
  202.                if isJust v
  203.                  then show . fromJust $ v
  204.                  else ": is no longer defined"
  205.     addMessage msg
  206.  
  207.  
  208. setWire :: WireName -> NodeName -> Value -> LPN ()
  209. setWire wire settor v = do
  210.   w <- lookupWire wire
  211.   if (not . wireHasSettor $ w) || (wireSettorIs w settor)
  212.     then updateWire (wireSet w settor v) settor
  213.     else
  214.       if wireHasSettor $ w
  215.         then do
  216.           let curv = fromJust . wireValue w $ settor
  217.           if v /= curv
  218.             then error $ "Wire " ++ wire ++ "has inconsistent value (" ++ show v ++ " != " ++ show curv ++ ")"
  219.             else return ()
  220.         else return ()
  221.  
  222.  
  223. revokeWire :: WireName -> NodeName -> LPN ()
  224. revokeWire wire revoker = do
  225.   w <- lookupWire wire
  226.   if wireSettorIs w revoker
  227.     then updateWire (wireRevoke w) revoker
  228.     else return ()
  229.  
  230.  
  231. notifyNode :: NodeName -> LPN ()
  232. notifyNode name = do
  233.   n <- lookupNode name
  234.   case n of
  235.     IO name wire              -> io name wire
  236.     Adder name ad1 ad2 sum -> adder name ad1 ad2 sum
  237.     Multiplier name fa1 fa2 pro -> multiplier name fa1 fa2 pro
  238.  
  239.  
  240. input :: NodeName -> Value -> LPN ()
  241. input name v = do
  242.   n <- lookupNode name
  243.   case n of
  244.     IO name wire -> setWire wire name v
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement