contrib/f0/Fleet.lhs

   1 \begin{code}
   2 module Fleet where
   3 import SBP
   4 import Util
   5
   6 itake  box = IMove { m_count=1, m_recycle=False, m_tokenIn=False, m_dataIn=True,
   7                      m_latch=True, m_dataOut=False, m_tokenOut=False, m_dest=Nothing,
   8                      m_pump=box }
   9 move   box = (itake box){ m_dataOut=True }
  10 copy   box = (move box){ m_dataIn=False }
  11 send   box = (move box){ m_dataIn=False, m_latch=False }
  12 notify box dest = IMove { m_count=1, m_recycle=False, m_tokenIn=False, m_dataIn=False,
  13                           m_latch=False, m_dataOut=False, m_tokenOut=True, m_dest=(Just dest),
  14                           m_pump=box }
  15 wait box = IMove { m_count=1, m_recycle=False, m_tokenIn=True, m_dataIn=False,
  16                    m_latch=False, m_dataOut=False, m_tokenOut=False, m_dest=Nothing,
  17                    m_pump=box }
  18 dismiss box = IMove { m_count=1, m_recycle=False, m_tokenIn=False, m_dataIn=True,
  19                       m_latch=False, m_dataOut=False, m_tokenOut=False, m_dest=Nothing,
  20                       m_pump=box }
  21 accept box = move box
  22
  23 -- Port ------------------------------------------------------------------------------
  24 data Port = ShipPort String String
  25           | IdPort   String
  26  deriving (Eq, Ord)
  27
  28 instance Show Port where
  29  show (ShipPort a b) = a++"."++b
  30  show (IdPort a)     = a
  31
  32 instance FromTree Port where
  33  fromTree (Tree "Port" [s] _)   = IdPort (fromTree s)
  34  fromTree (Tree "Port" [a,b] _) = ShipPort (fromTree a) (fromTree b)
  35  fromTree t = error (show t)
  36
  37 type PortBox = Port
  38 data Inst =
  39     IKill        PortBox Int
  40   | ILiteral     Int           PortBox
  41   | ILiteralBag  String        PortBox
  42   | IBagDef      String        [Inst]
  43   | IMove   { m_pump :: PortBox ,
  44               m_dest     :: Maybe PortBox ,
  45               m_count    :: Int ,
  46               m_recycle  :: Bool ,
  47               m_tokenIn  :: Bool ,
  48               m_dataIn   :: Bool ,
  49               m_latch    :: Bool ,
  50               m_dataOut  :: Bool ,
  51               m_tokenOut :: Bool }
  52
  53 showCount 0 True  = "[*r] "
  54 showCount 0 False = "[*] "
  55 showCount 1 _     = ""
  56 showCount n True  = "["++(show n)++"r] "
  57 showCount n False = "["++(show n)++"] "
  58
  59 instance Show Inst where
  60  show (IKill bb count)  = (show bb)++": "++(showCount count False)++" kill;"
  61  show (ILiteral lit bb) = (show lit)++": sendto "++(show bb)++";"
  62  show (ILiteralBag bagname bb) = bagname++": sendto "++(show bb)++";"
  63  show (IBagDef bagname is) = bagname++": {\n  "++(join "" $ map (\i -> (show i)++"\n  ") is)++"}\n"
  64  show m@(_)             = (show $ m_pump m) ++
  65                          ": "++
  66                          (showCount (m_count m) $ m_recycle m) ++
  67                          (join ", " $ showrest m)++
  68                          ";"
  69                            where
  70                              showrest m = wait++takelatch++out++ack
  71                               where
  72                                wait      = if m_tokenIn m then ["wait"] else []
  73                                takelatch = if m_dataIn m then (if m_latch m then ["take"] else ["dismiss"]) else []
  74                                out       = if m_dataOut m then (case m_dest m of { Nothing -> ["deliver"]; (Just j) -> ["sendto "++(show j)] }) else []
  75                                ack       = if m_tokenOut m then (case m_dest m of (Just j) -> ["notify "++(show j)]) else []
  76 \end{code}