Flip-Flops

FlipFlops.hs

{-# LANGUAGE NamedFieldPuns #-}

-- | https://en.wikipedia.org/wiki/Flip-flop_(electronics)#SR_NOR_latch
module FlipFlops
  ( -- * Logic primitives
    -- * SR-NOR--Latch
    SRNORLatch
  , mkSRNORLatch
  , runSRNORLatch
    -- ** SR-NAND--Latch
  , SRNANDLatch
  , mkSRNANDLatch
  , runSRNANDLatch
    -- ** Gated SR-Latch
  , GatedSRLatch
  , runGatedSRLatch
  , mkGatedSRLatch
    -- ** Gated D-Latch
  , GatedDLatch
  , runGatedDLatch
  , mkGatedDLatch
  , readGatedDLatch
    -- ** Logic primitives
  , nor
  , nand

    -- * Applications
    -- ** Counter
  , Counter
  , runCounter
  , mkCounter
  , readCounter
  , zeroCounter
  , succCounter
  ) where

-- | A nand gate, lazy in the second argument.
--
nand :: Bool -> Bool -> Bool
nand False _ = True
nand True  x = not x

-- | A nor gate, lazy in the second argument.
--
nor :: Bool -> Bool -> Bool
nor True  _ = False
nor False x = not x

-- | SR NOR latch: two nand gates; It will halt on 'False' 'False'.
--
sr_nor_latch :: Bool -> Bool -> (Bool, Bool)
sr_nor_latch r s =
    let q  = r `nor` q'
        q' = s `nor` q
    in (q, q')


-- | 'SRNORLatch', it keeps state of the result of the first nand gate.
-- [https://en.wikipedia.org/wiki/Flip-flop_(electronics)#SR_NOR_latch](SR
-- NOR latch)
--
-- @
--     ┌───┐
-- r ──┤ ≥1│
--     │   ├○┬──▶ q
--    ┌┤   │ │
--    │└───┘ │
--    └───────┐
--    ┌──────┘│
--    │┌───┐  │
--    └┤ ≥1│  │
--     │   ├○─┴─▶ ¬q
-- s ──┤   │
--     └───┘
-- @
--
--
-- ```
-- r     s     │ q
-- ────────────┼─────────────
-- False False │ read
-- False True  │ set
-- True  False │ reset
-- True  True  │ unspecified
-- ```
--
newtype SRNORLatch = SRNORLatch { runSRNORLatch :: Bool -> Bool -> (Bool, SRNORLatch) }


-- | 'SRNORLatch' smart constructor.
--
mkSRNORLatch :: Bool -- ^ initial state
             -> SRNORLatch
mkSRNORLatch = SRNORLatch . run
  where
    run :: Bool
        -> Bool -> Bool -> (Bool, SRNORLatch)
    run q False False =
      -- resolve mutual recursion in 'sr_nor_latch' using the state
      (q, SRNORLatch (run q))
    run _ r s =
      let (q, _) = sr_nor_latch r s
      in (q, SRNORLatch (run q))


--
-- SR NAND Latch
--

sr_nand_latch :: Bool -- ^ r
              -> Bool -- ^ s
              -> (Bool, Bool)
sr_nand_latch r s =
    let q  = r `nand` q'
        q' = s `nand` q
    in (q, q')

-- SR NAND Latch
--
-- @
--     ┌───┐
-- s ──┤ & │
--     │   ├○┬──▶ q
--    ┌┤   │ │
--    │└───┘ │
--    └───────┐
--    ┌──────┘│
--    │┌───┐  │
--    └┤ & │  │
--     │   ├○─┴─▶ ¬q
-- r ──┤   │
--     └───┘
-- @
--
-- ```
-- r     s     │ q
-- ────────────┼─────────────
-- False False │ unspecified
-- False True  │ set
-- True  False │ reset
-- True  True  │ read
-- ```
newtype SRNANDLatch = SRNANDLatch {
    runSRNANDLatch :: Bool -- ^ r
                   -> Bool -- ^ s
                   -> (Bool, SRNANDLatch) }


-- | 'SRNANDLatch' smart constructor.
--
mkSRNANDLatch :: Bool -- ^ initial state
              -> SRNANDLatch
mkSRNANDLatch = SRNANDLatch . run
  where
    run :: Bool
        -> Bool -> Bool -> (Bool, SRNANDLatch)
    run q True True =
      -- resolve mutual recursion in 'sr_nand_latch' using the state
      (q, SRNANDLatch (run q))
    run _ r s =
      let (q, _) = sr_nand_latch r s
      in (q, SRNANDLatch (run q))

--
-- Gated SRLatch
--

newtype GatedSRLatch = GatedSRLatch {
    runGatedSRLatch :: Bool -- ^ e
                    -> Bool -- ^ s
                    -> Bool -- ^ r
                    -> (Bool, GatedSRLatch) }

mkGatedSRLatch :: Bool -> GatedSRLatch
mkGatedSRLatch = fromSRLatch . mkSRNORLatch
  where
    fromSRLatch :: SRNORLatch -> GatedSRLatch
    fromSRLatch (SRNORLatch f) = GatedSRLatch
      $ \e r s -> case f (r && e) (s && e) of
        (q, srl) -> (q, fromSRLatch srl)

--
-- Gated DLatch
--


-- | Gated D-Latch
--
-- @
--  ┌─────────┐
-- ─┤ d     q ├─
--  │         │
-- ─┤ e    ¬q ├─
--  └─────────┘
-- @
--
-- Which is a composition of two nand gates and an SR NAND Latch:
-- @
--     ┌───┐
-- d ──┤ & │     ┌───┐         
--     │   ├○─┬──┤ & │         
--   ┌─┤   │  │  │   ├○┬──▶ q  
--   │ └───┘  │ ┌┤   │ │       
--   │┌───────┘ │└───┘ │       
--   ││         └───────┐      
--   ││         ┌──────┘│      
--   ││         │┌───┐  │      
--   ││┌───┐    └┤ & │  │      
--   │└┤ & │     │   ├○─┴─▶ ¬q 
--   │ │   ├○────┤   │         
-- e ┴─┤   │     └───┘         
--     └───┘   
-- @
--
-- ```
-- d     e     │
-- ────────────┼──────────────
-- _     False │ read
-- False True  │ set to False
-- True  True  │ set to True
-- ```
newtype GatedDLatch = GatedDLatch {
    runGatedDLatch :: Bool -- ^ d
                   -> Bool -- ^ e
                   -> (Bool, GatedDLatch) }

mkGatedDLatch :: Bool -> GatedDLatch
mkGatedDLatch = fromSRNANDLatch . mkSRNANDLatch
  where
    fromSRNANDLatch :: SRNANDLatch -> GatedDLatch
    fromSRNANDLatch srl =
      GatedDLatch $
        \d e ->
          let r = d `nand` e
              s = r `nand` e
          in case runSRNANDLatch srl r s of
            (q, srl') -> (q, fromSRNANDLatch srl')

readGatedDLatch :: GatedDLatch -> Bool
readGatedDLatch gdl = fst $ runGatedDLatch gdl False False


--
-- Applications
--


-- | Two bit counter (Z₄)
--
data Counter = Counter {
    runCounter :: Bool -> Counter,

    -- | internal, low bit Gated D-Latch
    --
    lowLatch   :: GatedDLatch,

    -- | internal, high bit Gated D-Latch
    --
    highLatch  :: GatedDLatch
  }

readCounter :: Counter -> (Bool, Bool)
readCounter Counter {lowLatch, highLatch} =
    ( readGatedDLatch lowLatch
    , readGatedDLatch highLatch
    )


-- | 'Counter' smart constructor.
--
-- The frist Gated DLatch represents the low bit, the sencond the high bit:
-- @
-- ┌─────────────┐┌─────────────┐
-- │ ┌─────────┐ ││ ┌─────────┐ │
-- └─┤ d     q ├ │└─┤ d      q├─│─▶
--   │         │ │  │         │ │
-- ──┤ e    ¬q ├─┴──┤ e     ¬q├─┘
--   └─────────┘    └─────────┘
-- @
--
--
mkCounter :: Bool -> Bool
          -> Counter
mkCounter lowBit highBit = fromGDLs (mkGatedDLatch lowBit) (mkGatedDLatch highBit)
  where
    fromGDLs :: GatedDLatch -> GatedDLatch -> Counter
    fromGDLs lowLatch highLatch = Counter {
        lowLatch, highLatch,
        runCounter =
         \e ->
           let qbar = not $ readGatedDLatch lowLatch
               (q, lowLatch') = runGatedDLatch lowLatch qbar e

               qbar' = not $ readGatedDLatch highLatch
               (_, highLatch') = runGatedDLatch highLatch qbar' (not q)

           in fromGDLs lowLatch' highLatch'
      }


zeroCounter :: Counter
zeroCounter = mkCounter False False

succCounter :: Counter -> Counter
succCounter = flip runCounter True

{-
-- (True, True)
threeCounter :: (Bool, Bool)
threeCounter = readCounter
             . succCounter
             . succCounter
             . succCounter
             $ zeroCounter
-}