diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2020 Gergő Érdi (http://gergo.erdi.hu/)
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
diff --git a/retroclash-lib.cabal b/retroclash-lib.cabal
new file mode 100644
--- /dev/null
+++ b/retroclash-lib.cabal
@@ -0,0 +1,115 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.34.4.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: 63033a7be2d6ae3d881c517aef6195d61a5d85ec40614c32287bfaccb2176dc4
+
+name:           retroclash-lib
+version:        0.1.0
+synopsis:       Code shared across the code samples in the book "Retrocomputing with Clash"
+description:    Clash components useful when implementing, or interfacing with,
+                retro-computers:
+                .
+                  * UART
+                .
+                  * Multi-digit seven-segment display driver
+                .
+                  * Keypad matrix scanner
+                .
+                  * PS/2 keyboard driver
+                .
+                  * VGA signal generator
+                .
+                  * Video coordinate transformers
+                .
+                  * A framework for monadic CPU descriptions
+                .
+                  * Address maps
+                .
+                  * Various small utilities
+                .
+category:       Hardware
+homepage:       https://unsafePerform.IO/retroclash/
+bug-reports:    https://github.com/gergoerdi/retroclash-lib/issues
+author:         Gergő Érdi
+maintainer:     gergo@erdi.hu
+copyright:      2021 Gergő Érdi
+license:        MIT
+license-file:   LICENSE
+build-type:     Simple
+
+source-repository head
+  type: git
+  location: https://github.com/gergoerdi/retroclash-lib
+
+library
+  exposed-modules:
+      RetroClash.Utils
+      RetroClash.Clock
+      RetroClash.Barbies
+      RetroClash.Keypad
+      RetroClash.SevenSegment
+      RetroClash.SerialRx
+      RetroClash.SerialTx
+      RetroClash.VGA
+      RetroClash.Video
+      RetroClash.CPU
+      RetroClash.Delayed
+      RetroClash.Stack
+      RetroClash.BCD
+      RetroClash.Port
+      RetroClash.PS2
+      RetroClash.PS2.ASCII
+      RetroClash.Memory
+  other-modules:
+      Paths_retroclash_lib
+  hs-source-dirs:
+      src
+  default-extensions:
+      BinaryLiterals
+      ConstraintKinds
+      DataKinds
+      DeriveAnyClass
+      DeriveGeneric
+      DeriveLift
+      DerivingStrategies
+      ExplicitForAll
+      ExplicitNamespaces
+      FlexibleContexts
+      FlexibleInstances
+      KindSignatures
+      MagicHash
+      MonoLocalBinds
+      NoImplicitPrelude
+      NoMonomorphismRestriction
+      NoStarIsType
+      NoStrictData
+      NoStrict
+      QuasiQuotes
+      ScopedTypeVariables
+      TemplateHaskellQuotes
+      TemplateHaskell
+      TypeApplications
+      TypeFamilies
+      TypeInType
+      TypeOperators
+  ghc-options: -fexpose-all-unfoldings -fno-worker-wrapper -fplugin GHC.TypeLits.KnownNat.Solver -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.Extra.Solver
+  build-depends:
+      barbies >=2.0.1 && <2.1
+    , base >=4.14 && <5
+    , clash-ghc >=1.4.2 && <1.5
+    , clash-lib >=1.4.2 && <1.5
+    , clash-prelude >=1.4.2 && <1.5
+    , containers
+    , ghc-typelits-extra
+    , ghc-typelits-knownnat
+    , ghc-typelits-natnormalise
+    , lens
+    , lift-type ==0.1.*
+    , monoidal-containers ==0.6.*
+    , mtl
+    , template-haskell
+    , transformers
+  default-language: Haskell2010
diff --git a/src/RetroClash/BCD.hs b/src/RetroClash/BCD.hs
new file mode 100644
--- /dev/null
+++ b/src/RetroClash/BCD.hs
@@ -0,0 +1,50 @@
+{-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-}
+module RetroClash.BCD
+    ( Digit, toDigit
+    , BCD
+    , fromBCD
+    , BCDSize
+    , toBCD
+    , ShiftAdd, initBCD, stepBCD
+    , prop_BCD
+    ) where
+
+import Clash.Prelude hiding (shift, add)
+import RetroClash.Utils
+
+type Digit = Index 10
+type BCD n = Vec n Digit
+
+toDigit :: Unsigned 4 -> Digit
+toDigit = bitCoerce
+
+fromBCD :: BCD n -> Integer
+fromBCD = foldl (\x d -> x * 10 + fromIntegral d) 0
+
+type BCDSize n = CLog 10 (2 ^ n)
+type ShiftAdd n = (Vec (BCDSize n) (Unsigned 4), Unsigned n)
+
+{-# INLINE initBCD #-}
+initBCD :: (KnownNat n) => Unsigned n -> ShiftAdd n
+initBCD = (,) (repeat 0)
+
+stepBCD :: (KnownNat n) => ShiftAdd n -> ShiftAdd n
+stepBCD = shift . add
+  where
+    shift :: (KnownNat n) => ShiftAdd n -> ShiftAdd n
+    shift = bitwise (`shiftL` 1)
+
+    add :: ShiftAdd n -> ShiftAdd n
+    add (digits, buf) = (map add3 digits, buf)
+      where
+        add3 d = if d >= 5 then d + 3 else d
+
+{-# INLINE toBCD #-}
+toBCD :: forall n. (KnownNat n) => Unsigned n -> BCD (BCDSize n)
+toBCD = map toDigit . fst . last . iterate (SNat @(n + 1)) stepBCD . initBCD
+
+roundtrip :: (KnownNat n) => Unsigned n -> Unsigned n
+roundtrip = fromIntegral . fromBCD . map bitCoerce . toBCD
+
+prop_BCD :: (KnownNat n) => Unsigned n -> Bool
+prop_BCD x = x == roundtrip x
diff --git a/src/RetroClash/Barbies.hs b/src/RetroClash/Barbies.hs
new file mode 100644
--- /dev/null
+++ b/src/RetroClash/Barbies.hs
@@ -0,0 +1,29 @@
+module RetroClash.Barbies
+    ( Pure
+    , Partial
+    , Signals
+    , bbundle
+    , bunbundle
+    ) where
+
+import Clash.Prelude
+import Data.Monoid (Last(..))
+import Data.Functor.Identity
+
+import Barbies
+import Barbies.Bare
+
+type Pure b = b Bare Identity
+type Partial b = Barbie (b Covered) Last
+type Signals dom b = b Covered (Signal dom)
+
+bbundle :: (Applicative f, BareB b, TraversableB (b Covered)) => b Covered f -> f (Pure b)
+bbundle = fmap bstrip . bsequence'
+
+bunbundle :: (Functor f, BareB b, DistributiveB (b Covered)) => f (Pure b) -> b Covered f
+bunbundle = bdistribute' . fmap bcover
+
+instance (BareB b, TraversableB (b Covered), DistributiveB (b Covered)) => Bundle (Pure b) where
+    type Unbundled dom (Pure b) = Signals dom b
+    bundle = bbundle
+    unbundle = bunbundle
diff --git a/src/RetroClash/CPU.hs b/src/RetroClash/CPU.hs
new file mode 100644
--- /dev/null
+++ b/src/RetroClash/CPU.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE RankNTypes #-}
+module RetroClash.CPU where
+
+import Clash.Prelude
+import RetroClash.Utils
+import RetroClash.Barbies
+
+import Data.Functor.Identity
+
+import Control.Monad.Writer
+import Control.Monad.State
+import Control.Lens (Setter', scribe, iso)
+
+import Barbies
+import Barbies.Bare
+
+infix 4 .:=
+(.:=) :: (Applicative f, MonadWriter (Barbie b f) m) => Setter' (b f) (f a) -> a -> m ()
+fd .:= x = scribe (iso getBarbie Barbie . fd) (pure x)
+
+assignOut :: (Applicative f, MonadWriter (Barbie b f) m) => Setter' (b f) (f a) -> a -> m ()
+assignOut fd x = fd .:= x
+
+update :: (BareB b, ApplicativeB (b Covered)) => Pure b -> Partial b -> Pure b
+update initials edits = bstrip $ bzipWith update1 (bcover initials) (getBarbie edits)
+  where
+    update1 :: Identity a -> Last a -> Identity a
+    update1 initial edit = maybe initial Identity (getLast edit)
+
+type CPUM s o = WriterT (Barbie (o Covered) Last) (State s)
+
+mealyCPU
+    :: (BareB i, TraversableB (i Covered))
+    => (NFDataX s)
+    => (BareB o, ApplicativeB (o Covered), DistributiveB (o Covered))
+    => (HiddenClockResetEnable dom)
+    => s
+    -> (s -> Pure o)
+    -> (Pure i -> CPUM s o ())
+    -> Signals dom i -> Signals dom o
+mealyCPU initState defaultOutput step =
+    bunbundle . mealyState (runCPU defaultOutput . step) initState . bbundle
+
+runCPU
+    :: (BareB o, ApplicativeB (o Covered))
+    => (s -> Pure o)
+    -> CPUM s o ()
+    -> State s (Pure o)
+runCPU defaultOutput step = do
+    edits <- execWriterT step
+    out0 <- gets defaultOutput
+    return $ update out0 edits
diff --git a/src/RetroClash/Clock.hs b/src/RetroClash/Clock.hs
new file mode 100644
--- /dev/null
+++ b/src/RetroClash/Clock.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE ScopedTypeVariables, NumericUnderscores, PartialTypeSignatures #-}
+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
+module RetroClash.Clock
+    ( HzToPeriod
+
+    , Seconds
+    , Milliseconds
+    , Microseconds
+    , Nanoseconds
+    , Picoseconds
+
+    , ClockDivider
+    , risePeriod
+    , riseRate
+    ) where
+
+import Clash.Prelude
+
+type HzToPeriod (rate :: Nat) = Seconds 1 `Div` rate
+
+type Seconds      (s  :: Nat) = Milliseconds (1_000 * s)
+type Milliseconds (ms :: Nat) = Microseconds (1_000 * ms)
+type Microseconds (us :: Nat) = Nanoseconds  (1_000 * us)
+type Nanoseconds  (ns :: Nat) = Picoseconds  (1_000 * ns)
+type Picoseconds  (ps :: Nat) = ps
+
+type ClockDivider dom ps = ps `Div` DomainPeriod dom
+
+risePeriod
+    :: forall ps dom. (HiddenClockResetEnable dom, _)
+    => SNat ps
+    -> Signal dom Bool
+risePeriod _ = riseEvery (SNat @(ClockDivider dom ps))
+
+riseRate
+    :: forall rate dom. (HiddenClockResetEnable dom, _)
+    => SNat rate
+    -> Signal dom Bool
+riseRate _ = risePeriod (SNat @(HzToPeriod rate))
diff --git a/src/RetroClash/Delayed.hs b/src/RetroClash/Delayed.hs
new file mode 100644
--- /dev/null
+++ b/src/RetroClash/Delayed.hs
@@ -0,0 +1,116 @@
+{-# LANGUAGE RecordWildCards, RankNTypes #-}
+module RetroClash.Delayed
+    ( delayVGA
+
+    , delayedRom
+    , delayedRam
+    , delayedBlockRam1
+    , sharedDelayed
+    , sharedDelayedRW
+
+    , delayedRegister
+    , liftD
+    , liftD2
+    , matchDelay
+    )
+    where
+
+import Clash.Prelude
+import qualified Clash.Signal.Delayed.Bundle as D
+import RetroClash.VGA
+import RetroClash.Utils (enable, guardA, muxA, (.<|))
+import Data.Maybe
+import Control.Monad (mplus)
+
+delayVGA
+    :: (KnownNat d, KnownNat r, KnownNat g, KnownNat b)
+    => (HiddenClockResetEnable dom)
+    => VGASync dom
+    -> DSignal dom d (Unsigned r, Unsigned g, Unsigned b)
+    -> VGAOut dom r g b
+delayVGA VGASync{..} rgb = vgaOut vgaSync' (toSignal rgb)
+  where
+    vgaSync' = VGASync
+        { vgaHSync = matchDelay rgb undefined vgaHSync
+        , vgaVSync = matchDelay rgb undefined vgaVSync
+        , vgaDE = matchDelay rgb False vgaDE
+        }
+
+matchDelay
+    :: (KnownNat d, NFDataX a, HiddenClockResetEnable dom)
+    => DSignal dom d any
+    -> a
+    -> Signal dom a
+    -> Signal dom a
+matchDelay ref x0 = toSignal . (ref *>) . delayI x0 . fromSignal
+
+delayedRam
+    :: (HiddenClockResetEnable dom)
+    => (forall dom'. (HiddenClockResetEnable dom') => Signal dom' addr -> Signal dom' wr -> Signal dom' a)
+    -> DSignal dom d addr
+    -> DSignal dom d wr
+    -> DSignal dom (d + 1) a
+delayedRam syncRam addr write = unsafeFromSignal $ syncRam (toSignal addr) (toSignal write)
+
+delayedRom
+    :: (HiddenClockResetEnable dom)
+    => (forall dom'. (HiddenClockResetEnable dom') => Signal dom' addr -> Signal dom' a)
+    -> DSignal dom d addr
+    -> DSignal dom (d + 1) a
+delayedRom syncRom addr = unsafeFromSignal $ syncRom (toSignal addr)
+
+delayedBlockRam1
+    :: (1 <= n, Enum addr, NFDataX a, HiddenClockResetEnable dom)
+    => ResetStrategy r
+    -> SNat n
+    -> a
+    -> DSignal dom d addr
+    -> DSignal dom d (Maybe (addr, a))
+    -> DSignal dom (d + 1) a
+delayedBlockRam1 resetStrat size content = delayedRam (blockRam1 resetStrat size content)
+
+delayedRegister
+    :: (NFDataX a, HiddenClockResetEnable dom)
+    => a
+    -> (DSignal dom d a -> DSignal dom d a)
+    -> DSignal dom (d + 1) a
+delayedRegister initial feedback = r
+  where
+    r = unsafeFromSignal $ register initial $ toSignal new
+    old = antiDelay (SNat @1) r
+    new = feedback old
+
+liftD
+    :: (HiddenClockResetEnable dom)
+    => (forall dom'. (HiddenClockResetEnable dom') => Signal dom' a -> Signal dom' b)
+    -> DSignal dom d a -> DSignal dom d b
+liftD f = unsafeFromSignal . f . toSignal
+
+liftD2
+    :: (HiddenClockResetEnable dom)
+    => (forall dom'. (HiddenClockResetEnable dom') => Signal dom' a -> Signal dom' b -> Signal dom' c)
+    -> DSignal dom d a -> DSignal dom d b -> DSignal dom d c
+liftD2 f x y = unsafeFromSignal $ f (toSignal x) (toSignal y)
+
+sharedDelayed
+    :: (KnownNat k, KnownNat n, HiddenClockResetEnable dom)
+    => (DSignal dom d (Maybe addr) -> DSignal dom (d + k) a)
+    -> Vec (n + 1) (DSignal dom d (Maybe addr))
+    -> Vec (n + 1) (DSignal dom (d + k) (Maybe a))
+sharedDelayed mem reqs = reads
+  where
+    addrs = snd $ mapAccumL step (pure True) reqs
+      where
+        step en addr = (en .&&. isNothing <$> addr, guardA en addr)
+
+    addr = muxA addrs
+
+    read = mem addr
+    reads = map (\addr -> enable (delayI False $ isJust <$> addr) read) addrs
+
+sharedDelayedRW
+    :: (KnownNat k, KnownNat n, HiddenClockResetEnable dom)
+    => (DSignal dom d addr -> DSignal dom d (Maybe wr) -> DSignal dom (d + k) a)
+    -> Vec (n + 1) (DSignal dom d (Maybe (addr, Maybe wr)))
+    -> Vec (n + 1) (DSignal dom (d + k) (Maybe a))
+sharedDelayedRW ram = sharedDelayed $ uncurry ram . D.unbundle . (.<| (undefined, Nothing))
diff --git a/src/RetroClash/Keypad.hs b/src/RetroClash/Keypad.hs
new file mode 100644
--- /dev/null
+++ b/src/RetroClash/Keypad.hs
@@ -0,0 +1,72 @@
+module RetroClash.Keypad
+    ( Matrix(..), KeyStates(..), KeyEvent(..), KeyEvents(..)
+    , scanKeypad, keypadEvents
+    , pressedKeys
+    , firstJust2D
+    , inputKeypad
+    ) where
+
+import Clash.Prelude
+import RetroClash.Utils
+import RetroClash.Clock
+import Control.Monad (mplus)
+
+type Matrix rows cols a = Vec rows (Vec cols a)
+
+type KeyStates rows cols = Matrix rows cols Bool
+
+data KeyEvent
+    = Pressed
+    | Released
+    deriving (Show, Eq, Generic, NFDataX)
+
+type KeyEvents rows cols = Matrix rows cols (Maybe KeyEvent)
+
+scanKeypad
+    :: (KnownNat rows, KnownNat cols, IsActive rowAct, IsActive colAct, HiddenClockResetEnable dom)
+    => Signal dom (Vec rows (Active rowAct))
+    -> (Signal dom (Vec cols (Active colAct)), Signal dom (KeyStates rows cols))
+scanKeypad rows = (map toActive <$> cols, transpose <$> bundle state)
+  where
+    (cols, currentCol) = roundRobin nextCol
+    nextCol = riseEvery (SNat @1000)
+
+    state = map colState indicesI
+      where
+        colState thisCol = regEn (repeat False) (stable .&&. currentCol .== thisCol) $ map fromActive <$> rows
+
+        stable = cnt .== maxBound
+        cnt = register (0 :: Index 10) $ mux nextCol 0 (moreIdx <$> cnt)
+
+keypadEvents
+    :: (KnownNat rows, KnownNat cols, HiddenClockResetEnable dom)
+    => Signal dom (KeyStates rows cols)
+    -> Signal dom (KeyEvents rows cols)
+keypadEvents states = zipWith (zipWith event) <$> delayed <*> states
+  where
+    delayed = register (repeat $ repeat False) states
+
+    event False True = Just Pressed
+    event True False = Just Released
+    event _ _ = Nothing
+
+pressedKeys :: Matrix rows cols a -> KeyEvents rows cols  -> Matrix rows cols (Maybe a)
+pressedKeys = zipWith (zipWith decode)
+  where
+    decode mapping (Just Pressed) = Just mapping
+    decode _ _ = Nothing
+
+firstJust2D :: (KnownNat rows, KnownNat cols) => Matrix (rows + 1) (cols + 1) (Maybe a) -> Maybe a
+firstJust2D = fold mplus . map (fold mplus)
+
+inputKeypad
+    :: (KnownNat rows, KnownNat cols, IsActive rowAct, IsActive colAct)
+    => (HiddenClockResetEnable dom, KnownNat (ClockDivider dom (Milliseconds 5)))
+    => Matrix (rows + 1) (cols + 1) a
+    -> Signal dom (Vec (rows + 1) (Active rowAct))
+    -> (Signal dom (Vec (cols + 1) (Active colAct)), Signal dom (Maybe a))
+inputKeypad keymap rows = (cols, pressedKey)
+  where
+    (cols, keyState) = scanKeypad rows
+    events = keypadEvents . debounce (SNat @(Milliseconds 5)) (repeat . repeat $ False) $ keyState
+    pressedKey = firstJust2D . pressedKeys keymap <$> events
diff --git a/src/RetroClash/Memory.hs b/src/RetroClash/Memory.hs
new file mode 100644
--- /dev/null
+++ b/src/RetroClash/Memory.hs
@@ -0,0 +1,268 @@
+{-# LANGUAGE DerivingStrategies, GeneralizedNewtypeDeriving #-}
+module RetroClash.Memory
+    ( RAM, ROM, Port, Port_
+    , packRam
+
+    , Handle
+    , mapH
+
+    , Addressing
+    , memoryMap, memoryMap_
+
+    , conduit, readWrite, readWrite_
+    , romFromVec, romFromFile
+    , ram0, ramFromFile
+    , port, port_
+
+    , connect
+    , override
+
+    , from
+    , matchJust
+    , matchLeft, matchRight
+    , tag
+    ) where
+
+import Clash.Prelude hiding (Exp, lift)
+import RetroClash.Utils
+import RetroClash.Port
+import Data.Maybe
+import Control.Arrow (second)
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Data.Kind (Type)
+
+import Data.List as L
+import Data.Map.Monoidal as Map
+
+import Language.Haskell.TH hiding (Type)
+import LiftType
+import Type.Reflection (Typeable)
+
+type RAM dom addr dat = Signal dom addr -> Signal dom (Maybe (addr, dat)) -> Signal dom dat
+type ROM dom addr dat = Signal dom addr ->                                   Signal dom dat
+type Port dom addr dat a = Signal dom (Maybe (PortCommand addr dat)) -> (Signal dom dat, a)
+type Port_ dom addr dat = Signal dom (Maybe (PortCommand addr dat)) -> Signal dom dat
+
+packRam :: (BitPack dat) => RAM dom addr (BitVector (BitSize dat)) -> RAM dom addr dat
+packRam ram addr = fmap unpack . ram addr . fmap (second pack <$>)
+
+data Handle addr = Handle Name Name
+
+-- | type Addr dom addr = TExpQ (Signal dom (Maybe addr))
+type Addr = ExpQ
+
+-- | type Dat dom dat = TExpQ (Signal dom (Maybe dat))
+type Dat = ExpQ
+
+-- | type Component dom dat a = TExpQ (Signal dom (Maybe dat))
+type Component = ExpQ
+
+newtype Addressing addr a = Addressing
+    { runAddressing :: ReaderT (Addr, Dat) (WriterT (DecsQ, MonoidalMap Name [Addr], [Component]) Q) a }
+    deriving newtype (Functor, Applicative, Monad)
+
+class Backpane a where
+    backpane :: a -> ExpQ
+
+instance Backpane () where
+    backpane () = [|()|]
+
+instance (Backpane a1, Backpane a2) => Backpane (a1, a2) where
+    backpane (x1, x2) = [| ($(backpane x1), $(backpane x2)) |]
+
+instance (Backpane a1, Backpane a2, Backpane a3) => Backpane (a1, a2, a3) where
+    backpane (x1, x2, x3) = [| ($(backpane x1), $(backpane x2), $(backpane x3)) |]
+
+data Result = Result ExpQ
+
+instance Backpane Result where
+    backpane (Result e) = e
+
+compile
+    :: forall addr a b. (Backpane a)
+    => Addressing addr a
+    -> Addr
+    -> Dat
+    -> Component
+compile addressing addr wr = do
+    (x, (decs, conns, rds)) <-
+        runWriterT $ runReaderT (runAddressing addressing) ([| Just <$> $addr |], wr)
+
+    let compAddrs = [ [d| $(varP nm) = muxA $(listE addrs) |]
+                    | (nm, addrs) <- Map.toList conns
+                    ]
+    decs <- mconcat (decs:compAddrs)
+    letE (pure <$> decs) [| (muxA $(listE rds), $(backpane x)) |]
+
+memoryMap
+    :: forall addr a. (Backpane a)
+    => Addr
+    -> Dat
+    -> Addressing addr a
+    -> Component
+memoryMap addr wr addressing =
+    [| let addr' = $addr; wr' = $wr
+        in $(compile addressing [| addr' |] [| wr' |])
+    |]
+
+memoryMap_
+    :: forall addr dat. ()
+    => Addr
+    -> Dat
+    -> Addressing addr ()
+    -> Dat
+memoryMap_ addr wr addressing = [| fst $(memoryMap addr wr addressing) |]
+
+connect
+    :: Handle addr
+    -> Addressing addr ()
+connect (Handle rd compAddr) = Addressing $ do
+    (addr, _) <- ask
+    let masked = [| enable (delay False $ isJust <$> $addr) $(varE rd) |]
+    tell (mempty, Map.singleton compAddr [addr], [masked])
+
+override
+    :: ExpQ
+    -> Addressing addr ()
+override sig = Addressing $ do
+    rd <- lift . lift $ newName "rd"
+    let decs = [d| $(varP rd) = $sig |]
+    tell (decs, mempty, [varE rd])
+
+matchAddr
+    :: ExpQ {-(addr -> Maybe addr')-}
+    -> Addressing addr' a
+    -> Addressing addr a
+matchAddr match body = Addressing $ do
+    nm <- lift . lift $ newName "addr"
+    let addr' = varE nm
+    ReaderT $ \(addr, wr) -> do
+        let dec = [d| $(varP nm) = ($match =<<) <$> $addr |]
+        runReaderT
+          (tell (dec, mempty, mempty) >> runAddressing body)
+          (addr', wr)
+
+mapH :: ExpQ -> Handle addr' -> Addressing addr (Handle addr')
+mapH f (Handle rd compAddr) = Addressing $ do
+    rd' <- lift . lift $ newName "rd"
+    tell ([d| $(varP rd') = $f <$> $(varE rd)|], mempty, mempty)
+    return $ Handle rd' compAddr
+
+readWrite
+    :: forall addr' addr. ()
+    => (Addr -> Dat -> Component)
+    -> Addressing addr (Handle addr', Result)
+readWrite component = Addressing $ do
+    rd <- lift . lift $ newName "rd"
+    addr <- lift . lift $ newName "compAddr"
+    result <- lift . lift $ newName "result"
+    (_, wr) <- ask
+    let decs = [d| ($(varP rd), $(varP result)) = $(component (varE addr) wr) |]
+    tell (decs, Map.singleton addr mempty, mempty)
+    return (Handle rd addr, Result (varE result))
+
+readWrite_
+    :: forall addr' addr. ()
+    => (Addr -> Dat -> Dat)
+    -> Addressing addr (Handle addr')
+readWrite_ component = fmap fst $ readWrite $ \addr wr -> [| ($(component addr wr), ()) |]
+
+conduit
+    :: forall addr' addr. ()
+    => ExpQ
+    -> Addressing addr (Handle addr', Result, Result)
+conduit rdExt = do
+    (h, Result x) <- readWrite $ \addr wr -> [| ($rdExt, ($addr, $wr)) |]
+    return (h, Result [| fst $x |], Result [| snd $x |])
+
+romFromVec
+    :: (1 <= n)
+    => SNat n
+    -> ExpQ {-(Vec n dat)-}
+    -> Addressing addr (Handle (Index n))
+romFromVec size xs = readWrite_ $ \addr _wr ->
+    [| rom $xs (bitCoerce . fromJustX <$> $addr) |]
+
+romFromFile
+    :: (1 <= n)
+    => SNat n
+    -> ExpQ
+    -> Addressing addr (Handle (Index n))
+romFromFile size fileName = readWrite_ $ \addr _wr ->
+    [| fmap unpack $ romFilePow2 $fileName (bitCoerce . fromJustX <$> $addr) |]
+
+ram0
+    :: (1 <= n)
+    => SNat n
+    -> Addressing addr (Handle (Index n))
+ram0 size = readWrite_ $ \addr wr ->
+    [| blockRam1 NoClearOnReset size 0 (fromJustX <$> $addr) (liftA2 (,) <$> $addr <*> $wr) |]
+
+ramFromFile
+    :: SNat n
+    -> ExpQ {- FilePath -}
+    -> Addressing addr (Handle (Index n))
+ramFromFile size fileName = readWrite_ $ \addr wr ->
+    [| packRam (blockRamFile size $fileName)
+           (fromJustX <$> $addr)
+           (liftA2 (,) <$> $addr <*> $wr)
+    |]
+
+port
+    :: forall addr' a addr. ()
+    => ExpQ
+    -> Addressing addr (Handle addr', Result)
+port mkPort = readWrite $ \addr wr ->
+  [| let (read, x) = $mkPort $ portFromAddr $addr $wr
+     in (delay undefined read, x)
+  |]
+
+port_
+    :: forall addr' addr. ()
+    => ExpQ
+    -> Addressing addr (Handle addr')
+port_ mkPort = readWrite_ $ \addr wr ->
+  [| let read = $mkPort $ portFromAddr $addr $wr
+     in delay undefined read
+  |]
+
+from
+    :: forall addr' addr a. (Typeable addr', Lift addr)
+    => (Integral addr, Ord addr, Integral addr', Bounded addr')
+    => addr
+    -> Addressing addr' a
+    -> Addressing addr a
+from base = matchAddr [| from' @($(liftTypeQ @addr')) base |]
+
+tag
+    :: (Lift addr')
+    => addr'
+    -> Addressing (addr', addr) a
+    -> Addressing addr a
+tag t = matchAddr [| \addr -> Just (t, addr) |]
+
+matchJust
+    :: Addressing addr a
+    -> Addressing (Maybe addr) a
+matchJust = matchAddr [| id |]
+
+matchLeft
+    :: Addressing addr1 a
+    -> Addressing (Either addr1 addr2) a
+matchLeft = matchAddr [| either Just (const Nothing) |]
+
+matchRight
+    :: Addressing addr2 a
+    -> Addressing (Either addr1 addr2) a
+matchRight = matchAddr [| either (const Nothing) Just |]
+
+from'
+    :: forall addr' addr. (Integral addr, Ord addr, Integral addr', Bounded addr')
+    => addr -> addr -> Maybe addr'
+from' base addr = do
+    guard $ addr >= base
+    let offset = addr - base
+    guard $ offset <= fromIntegral (maxBound :: addr')
+    return (fromIntegral offset)
diff --git a/src/RetroClash/PS2.hs b/src/RetroClash/PS2.hs
new file mode 100644
--- /dev/null
+++ b/src/RetroClash/PS2.hs
@@ -0,0 +1,116 @@
+{-# LANGUAGE RecordWildCards, LambdaCase #-}
+module RetroClash.PS2
+    ( PS2(..)
+    , samplePS2
+
+    , decodePS2
+
+    , KeyEvent(..)
+    , ScanCode(..)
+    , KeyCode(..)
+    , parseScanCode
+
+    , keyPress
+    , keyState
+    ) where
+
+import Clash.Prelude
+import RetroClash.Utils
+import RetroClash.Clock
+import Control.Monad.State
+import Control.Monad.Trans.Writer
+import Data.Monoid (Last(..))
+import Data.Foldable (traverse_)
+
+data PS2 dom = PS2
+    { ps2Clk :: "CLK"   ::: Signal dom Bit
+    , ps2Data :: "DATA" ::: Signal dom Bit
+    }
+
+samplePS2
+    :: forall dom. (HiddenClockResetEnable dom, KnownNat (ClockDivider dom (Microseconds 1)))
+    => PS2 dom -> Signal dom (Maybe Bit)
+samplePS2 PS2{..} =
+    enable (isFalling low . lowpass $ ps2Clk) (lowpass ps2Data)
+  where
+    lowpass :: Signal dom Bit -> Signal dom Bit
+    lowpass = debounce (SNat @(Microseconds 1)) low
+
+data PS2State
+    = Idle
+    | Bit (BitVector 8) (Index 8)
+    | Parity (BitVector 8)
+    | Stop (Maybe (Unsigned 8))
+    deriving (Show, Eq, Generic, NFDataX)
+
+decoder :: Bit -> WriterT (Last (Unsigned 8)) (State PS2State) ()
+decoder x = get >>= \case
+    Idle -> do
+        when (x == low) $ put $ Bit 0 0
+    Bit xs i -> do
+        let (xs', _) = bvShiftR x xs
+        put $ maybe (Parity xs') (Bit xs') $ succIdx i
+    Parity xs -> do
+        put $ Stop $ unpack xs <$ guard (parity xs /= x)
+    Stop b -> do
+        when (x == high) $ tell . Last $ b
+        put Idle
+
+decodePS2
+    :: (HiddenClockResetEnable dom)
+    => Signal dom (Maybe Bit) -> Signal dom (Maybe (Unsigned 8))
+decodePS2 = mealyState sampleDecoder Idle
+  where
+    sampleDecoder = fmap getLast . execWriterT . traverse_ decoder
+
+data KeyEvent = KeyPress | KeyRelease
+    deriving (Generic, Eq, Show, NFDataX)
+
+type KeyCode = Unsigned 9
+
+data ScanCode = ScanCode KeyEvent KeyCode
+    deriving (Generic, Eq, Show, NFDataX)
+
+data ScanState
+    = Init
+    | Extended
+    | Code KeyEvent Bit
+    deriving (Show, Generic, NFDataX)
+
+parser :: Unsigned 8 -> WriterT (Last ScanCode) (State ScanState) ()
+parser raw = get >>= \case
+    Init
+        | raw == 0xe0 -> put $ Extended
+        | raw == 0xf0 -> put $ Code KeyRelease 0
+        | otherwise   -> finish KeyPress 0
+    Extended
+        | raw == 0xf0 -> put $ Code KeyRelease 1
+        | otherwise   -> finish KeyPress 1
+    Code ev ext       -> finish ev ext
+  where
+    finish ev ext = do
+        tell $ Last . Just $ ScanCode ev $ bitCoerce (ext, raw)
+        put Init
+
+parseScanCode
+    :: (HiddenClockResetEnable dom)
+    => Signal dom (Maybe (Unsigned 8)) -> Signal dom (Maybe ScanCode)
+parseScanCode = mealyState byteParser Init
+  where
+    byteParser = fmap getLast . execWriterT . traverse_ parser
+
+keyPress :: ScanCode -> Maybe KeyCode
+keyPress (ScanCode KeyPress kc) = Just kc
+keyPress _ = Nothing
+
+keyState
+    :: (HiddenClockResetEnable dom)
+    => KeyCode
+    -> Signal dom (Maybe ScanCode)
+    -> Signal dom Bool
+keyState target = regMaybe False . fmap fromScanCode
+  where
+    fromScanCode sc = do
+        ScanCode ev kc <- sc
+        guard $ kc == target
+        return $ ev == KeyPress
diff --git a/src/RetroClash/PS2/ASCII.hs b/src/RetroClash/PS2/ASCII.hs
new file mode 100644
--- /dev/null
+++ b/src/RetroClash/PS2/ASCII.hs
@@ -0,0 +1,93 @@
+{-# LANGUAGE RecordWildCards, LambdaCase #-}
+module RetroClash.PS2.ASCII
+    ( Side(..), Modifier(..)
+    , modMap
+    , asciiMap
+    ) where
+
+import Clash.Prelude
+import RetroClash.PS2
+import Data.Char
+
+data Side
+    = OnLeft
+    | OnRight
+    deriving (Eq, Show, Enum, Bounded, Generic, NFDataX)
+
+data Modifier
+    = Shift
+    | Ctrl
+    | Alt
+    | Win
+    deriving (Eq, Show, Enum, Bounded, Generic, NFDataX)
+
+modMap :: KeyCode -> Maybe (Modifier, Side)
+modMap 0x012 = Just (Shift, OnLeft)
+modMap 0x059 = Just (Shift, OnRight)
+modMap 0x014 = Just (Ctrl, OnLeft)
+modMap 0x114 = Just (Ctrl, OnRight)
+modMap 0x011 = Just (Alt, OnLeft)
+modMap 0x111 = Just (Alt, OnRight)
+modMap 0x11f = Just (Win, OnLeft)
+modMap 0x127 = Just (Win, OnRight)
+modMap _ = Nothing
+
+{-# INLINE asciiMap #-}
+asciiMap :: KeyCode -> Maybe (Unsigned 7)
+asciiMap = fmap fromChar . charMap
+  where
+    fromChar = fromIntegral . ord
+
+{-# INLINE charMap #-}
+charMap :: KeyCode -> Maybe Char
+charMap 0x05a = Just '\r'
+charMap 0x15a = Just '\r' -- Keypad
+charMap 0x00d = Just '\t'
+charMap 0x029 = Just ' '
+charMap 0x04c = Just ';'
+charMap 0x052 = Just '\''
+charMap 0x054 = Just '['
+charMap 0x05b = Just ']'
+charMap 0x05d = Just '\\'
+charMap 0x04a = Just '/'
+charMap 0x041 = Just ','
+charMap 0x049 = Just '.'
+charMap 0x04e = Just '-'
+charMap 0x055 = Just '='
+charMap 0x045 = Just '0'
+charMap 0x016 = Just '1'
+charMap 0x01e = Just '2'
+charMap 0x026 = Just '3'
+charMap 0x025 = Just '4'
+charMap 0x02e = Just '5'
+charMap 0x036 = Just '6'
+charMap 0x03d = Just '7'
+charMap 0x03e = Just '8'
+charMap 0x046 = Just '9'
+charMap 0x01c = Just 'a'
+charMap 0x032 = Just 'b'
+charMap 0x021 = Just 'c'
+charMap 0x023 = Just 'd'
+charMap 0x024 = Just 'e'
+charMap 0x02b = Just 'f'
+charMap 0x034 = Just 'g'
+charMap 0x033 = Just 'h'
+charMap 0x043 = Just 'i'
+charMap 0x03b = Just 'j'
+charMap 0x042 = Just 'k'
+charMap 0x04b = Just 'l'
+charMap 0x03a = Just 'm'
+charMap 0x031 = Just 'n'
+charMap 0x044 = Just 'o'
+charMap 0x04d = Just 'p'
+charMap 0x015 = Just 'q'
+charMap 0x02d = Just 'r'
+charMap 0x01b = Just 's'
+charMap 0x02c = Just 't'
+charMap 0x03c = Just 'u'
+charMap 0x02a = Just 'v'
+charMap 0x01d = Just 'w'
+charMap 0x022 = Just 'x'
+charMap 0x035 = Just 'y'
+charMap 0x01a = Just 'z'
+charMap _ = Nothing
diff --git a/src/RetroClash/Port.hs b/src/RetroClash/Port.hs
new file mode 100644
--- /dev/null
+++ b/src/RetroClash/Port.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE LambdaCase, ApplicativeDo #-}
+module RetroClash.Port
+    ( PortCommand(..)
+    , portFromAddr
+    ) where
+
+import Clash.Prelude
+
+import Data.Bifunctor
+import Data.Bifoldable
+import Data.Bitraversable
+
+data PortCommand port a
+    = ReadPort port
+    | WritePort port a
+    deriving (Generic, NFDataX, Show)
+
+instance Functor (PortCommand port) where
+    {-# INLINE fmap #-}
+    fmap f = \case
+        ReadPort port -> ReadPort port
+        WritePort port val -> WritePort port (f val)
+
+instance Bifunctor PortCommand where
+    {-# INLINE bimap #-}
+    bimap f g = \case
+        ReadPort port -> ReadPort (f port)
+        WritePort port val -> WritePort (f port) (g val)
+
+    {-# INLINE second #-}
+    second = fmap
+
+instance Bifoldable PortCommand where
+    {-# INLINE bifoldMap #-}
+    bifoldMap f g = \case
+        ReadPort port -> f port
+        WritePort port val -> f port <> g val
+
+instance Bitraversable PortCommand where
+    {-# INLINE bitraverse #-}
+    bitraverse f g = \case
+        ReadPort port -> ReadPort <$> f port
+        WritePort port val -> WritePort <$> f port <*> g val
+
+portFromAddr :: Signal dom (Maybe port) -> Signal dom (Maybe a) -> Signal dom (Maybe (PortCommand port a))
+portFromAddr addr w = do
+    addr <- addr
+    w <- w
+    pure $ case (addr, w) of
+        (Just addr, Nothing) -> Just $ ReadPort addr
+        (Just addr, Just w) -> Just $ WritePort addr w
+        _ -> Nothing
diff --git a/src/RetroClash/SerialRx.hs b/src/RetroClash/SerialRx.hs
new file mode 100644
--- /dev/null
+++ b/src/RetroClash/SerialRx.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE RecordWildCards, LambdaCase #-}
+module RetroClash.SerialRx
+    ( serialRx
+    , serialRxDyn
+    , RxState(..)
+    , RxBit(..)
+    , rxStep
+    ) where
+
+import Clash.Prelude
+import RetroClash.Utils
+import RetroClash.Clock
+
+import Control.Monad.State
+import Control.Monad.Trans.Writer
+import Data.Monoid
+import Data.Word
+
+data RxState n
+    = RxIdle
+    | RxBit Word32 (Maybe Bit) (RxBit n)
+    deriving (Generic, Eq, Show, NFDataX)
+
+data RxBit n
+    = StartBit
+    | DataBit (BitVector n) (Index n)
+    | StopBit (BitVector n)
+    deriving (Generic, Eq, Show, NFDataX)
+
+rxStep :: (KnownNat n) => Word32 -> Bit -> State (RxState n) (Maybe (BitVector n))
+rxStep bitDuration input = fmap getLast . execWriterT $ get >>= \case
+    RxIdle -> do
+        when (input == low) $ put $ RxBit (bitDuration1 - 1) Nothing StartBit
+    RxBit cnt sample b | cnt > 1 -> do
+        put $ RxBit (cnt - 1) sample b
+    RxBit _ Nothing b -> do
+        consume input b
+    RxBit _ (Just sample) rx -> case rx of
+        StartBit -> do
+            if sample == low then waitFor (DataBit 0 0) else put RxIdle
+        DataBit xs i -> do
+            let (xs', _) = bvShiftR sample xs
+            waitFor $ maybe (StopBit xs') (DataBit xs') $ succIdx i
+        StopBit xs -> do
+            when (sample == high) $ tell $ pure xs
+            put RxIdle
+  where
+    bitDuration1 = half bitDuration
+    bitDuration2 = bitDuration - bitDuration1
+
+    waitFor = put . RxBit bitDuration1 Nothing
+    consume input = put . RxBit bitDuration2 (Just input)
+
+serialRxDyn
+    :: (KnownNat n, HiddenClockResetEnable dom)
+    => Signal dom Word32
+    -> Signal dom Bit
+    -> Signal dom (Maybe (BitVector n))
+serialRxDyn bitDuration input = mealyStateB (uncurry rxStep) RxIdle (bitDuration, input)
+
+serialRx
+    :: forall n rate dom. (KnownNat n, KnownNat (ClockDivider dom (HzToPeriod rate)), HiddenClockResetEnable dom)
+    => SNat rate
+    -> Signal dom Bit
+    -> Signal dom (Maybe (BitVector n))
+serialRx rate = serialRxDyn $ pure bitDuration
+  where
+    bitDuration = fromIntegral . natVal $ SNat @(ClockDivider dom (HzToPeriod rate))
diff --git a/src/RetroClash/SerialTx.hs b/src/RetroClash/SerialTx.hs
new file mode 100644
--- /dev/null
+++ b/src/RetroClash/SerialTx.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE RecordWildCards, LambdaCase #-}
+module RetroClash.SerialTx
+    ( serialTx
+    , serialTxDyn
+    , fifo
+    , TxState(..)
+    , TxBit(..)
+    , txStep
+    ) where
+
+import Clash.Prelude
+import RetroClash.Utils
+import RetroClash.Clock
+
+import Control.Monad.State
+import Control.Monad.Writer
+import Data.Foldable (traverse_)
+import Data.Word
+
+data TxState n
+    = TxIdle
+    | TxBit Word32 (TxBit n)
+    deriving (Show, Eq, Generic, NFDataX)
+
+data TxBit n
+    = StartBit (BitVector n)
+    | DataBit (BitVector n) (Index n)
+    | StopBit
+    deriving (Show, Eq, Generic, NFDataX)
+
+txStep :: forall n. (KnownNat n) => Word32 -> Maybe (BitVector n) -> State (TxState n) (Bit, Bool)
+txStep bitDuration input = fmap (fmap getAny) . runWriterT $ get >>= \case
+    TxIdle -> do
+        tell $ Any True
+        traverse_ (goto . StartBit) input
+        return high
+    TxBit cnt tx -> slowly cnt tx $ case tx of
+        StartBit xs -> do
+            goto $ DataBit xs 0
+            return low
+        DataBit xs i -> do
+            let (xs', _) = bvShiftR 0 xs
+            goto $ maybe StopBit (DataBit xs') $ succIdx i
+            return $ lsb xs
+        StopBit -> do
+            put TxIdle
+            return high
+  where
+    goto = put . TxBit bitDuration
+
+    slowly cnt tx act
+        | cnt > 1 = act <* put (TxBit (cnt - 1) tx)
+        | otherwise = act
+
+serialTxDyn
+    :: (KnownNat n, HiddenClockResetEnable dom)
+    => Signal dom Word32
+    -> Signal dom (Maybe (BitVector n))
+    -> (Signal dom Bit, Signal dom Bool)
+serialTxDyn bitDuration input = mealyStateB (uncurry txStep) TxIdle (bitDuration, input)
+
+serialTx
+    :: forall n rate dom. (KnownNat n, KnownNat (ClockDivider dom (HzToPeriod rate)), HiddenClockResetEnable dom)
+    => SNat rate
+    -> Signal dom (Maybe (BitVector n))
+    -> (Signal dom Bit, Signal dom Bool)
+serialTx rate = serialTxDyn $ pure . fromIntegral . natVal $ SNat @(ClockDivider dom (HzToPeriod rate))
+
+fifo
+    :: forall a dom. (NFDataX a, HiddenClockResetEnable dom)
+    => Signal dom (Maybe a) -> Signal dom Bool -> Signal dom (Maybe a)
+fifo input outReady = r
+  where
+    r = register Nothing $ mux outReady input (mplus <$> r <*> input)
diff --git a/src/RetroClash/SevenSegment.hs b/src/RetroClash/SevenSegment.hs
new file mode 100644
--- /dev/null
+++ b/src/RetroClash/SevenSegment.hs
@@ -0,0 +1,115 @@
+{-# LANGUAGE PartialTypeSignatures, RecordWildCards, ApplicativeDo #-}
+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
+module RetroClash.SevenSegment
+    ( SevenSegment(..)
+    , encodeHexSS
+    , showSS
+    , showSSs
+    , muxRR
+    , driveSS
+    , sevenSegmentPort
+    -- , bytesSS
+    ) where
+
+import Clash.Prelude
+import qualified Data.List as L
+import RetroClash.Utils
+import RetroClash.Clock
+
+data SevenSegment n anodes segments dp = SevenSegment
+    { anodes :: "AN" ::: Vec n (Active anodes)
+    , segments :: "SEG" ::: Vec 7 (Active segments)
+    , dp :: "DP" ::: Active dp
+    }
+    deriving (Generic)
+
+muxRR
+    :: (KnownNat n, HiddenClockResetEnable dom)
+    => Signal dom Bool
+    -> Signal dom (Vec n a)
+    -> (Signal dom (Vec n Bool), Signal dom a)
+muxRR tick xs = (selector, current)
+  where
+    (selector, i) = roundRobin tick
+    current = (!!) <$> xs <*> i
+
+driveSS
+    :: (KnownNat n, HiddenClockResetEnable dom, _)
+    => (a -> (Vec 7 Bool, Bool))
+    -> Signal dom (Vec n (Maybe a))
+    -> Signal dom (SevenSegment n anodes segments dp)
+driveSS draw digits = do
+    anodes <- map toActive <$> anodes
+    segments <- map toActive <$> segments
+    dp <- toActive <$> dp
+    pure SevenSegment{..}
+  where
+    (anodes, digit) = muxRR (risePeriod (SNat @(Milliseconds 1))) digits
+    (segments, dp) = unbundle $ maybe (repeat False, False) draw <$> digit
+
+sevenSegmentPort :: PortName
+sevenSegmentPort = PortProduct "SS" $ PortName <$> ["AN", "SEG", "DP"]
+
+bytesSS
+    :: forall n div dom clk sync. (KnownNat n, KnownNat div, HiddenClockResetEnable dom)
+    => Unsigned div
+    -> Signal dom (Vec n (Maybe (Unsigned 8)))
+    -> (Signal dom (Vec (n * 2) Bool), Signal dom (Vec 7 Bool))
+bytesSS div bytes = (shownDigit, segments)
+  where
+    digit = regEn (0 :: Index (n * 2)) timer $ nextIdx <$> digit
+      where
+        counter = countFromTo 0 div (pure True)
+        timer = counter .==. pure 0
+
+    shownDigit = oneHot <$> digit
+    segments = maybe (pure False) encodeHexSS <$> nibble
+
+    nibble = (!!) <$> nibbles <*> digit
+
+    nibbles = concatMap (traverse splitByte) <$> bytes
+
+    splitByte :: Unsigned 8 -> Vec 2 (Unsigned 4)
+    splitByte byte = hi :> lo :> Nil
+      where
+        (hi, lo) = bitCoerce byte
+
+encodeHexSS :: Unsigned 4 -> Vec 7 Bool
+encodeHexSS n = case n of
+    --       a        b        c        d        e        f        g
+    0x0 ->  True  :> True  :> True  :> True  :> True  :> True  :> False :> Nil
+    0x1 ->  False :> True  :> True  :> False :> False :> False :> False :> Nil
+    0x2 ->  True  :> True  :> False :> True  :> True  :> False :> True  :> Nil
+    0x3 ->  True  :> True  :> True  :> True  :> False :> False :> True  :> Nil
+    0x4 ->  False :> True  :> True  :> False :> False :> True  :> True  :> Nil
+    0x5 ->  True  :> False :> True  :> True  :> False :> True  :> True  :> Nil
+    0x6 ->  True  :> False :> True  :> True  :> True  :> True  :> True  :> Nil
+    0x7 ->  True  :> True  :> True  :> False :> False :> False :> False :> Nil
+    0x8 ->  True  :> True  :> True  :> True  :> True  :> True  :> True  :> Nil
+    0x9 ->  True  :> True  :> True  :> True  :> False :> True  :> True  :> Nil
+    0xa ->  True  :> True  :> True  :> False :> True  :> True  :> True  :> Nil
+    0xb ->  False :> False :> True  :> True  :> True  :> True  :> True  :> Nil
+    0xc ->  True  :> False :> False :> True  :> True  :> True  :> False :> Nil
+    0xd ->  False :> True  :> True  :> True  :> True  :> False :> True  :> Nil
+    0xe ->  True  :> False :> False :> True  :> True  :> True  :> True  :> Nil
+    0xf ->  True  :> False :> False :> False :> True  :> True  :> True  :> Nil
+
+showSS :: Vec 7 Bool -> String
+showSS (a :> b :> c :> d :> e :> f :> g :> Nil) = unlines . L.concat $
+    [ L.replicate 1 $ horiz   a
+    , L.replicate 3 $ vert  f   b
+    , L.replicate 1 $ horiz   g
+    , L.replicate 3 $ vert  e   c
+    , L.replicate 1 $ horiz   d
+    ]
+  where
+    horiz True  = " ###### "
+    horiz False = " ...... "
+
+    vert b1 b2 = part b1 <> "      " <> part b2
+      where
+        part True  = "#"
+        part False = "."
+
+showSSs :: [Vec 7 Bool] -> String
+showSSs = unlines . L.map (L.intercalate "  ") . L.transpose . L.map (lines . showSS)
diff --git a/src/RetroClash/Stack.hs b/src/RetroClash/Stack.hs
new file mode 100644
--- /dev/null
+++ b/src/RetroClash/Stack.hs
@@ -0,0 +1,12 @@
+module RetroClash.Stack where
+
+import Clash.Prelude
+
+data Stack n a = Stack (Vec n a) (Index n)
+    deriving (Generic, NFDataX, Show)
+
+push :: (KnownNat n) => a -> Stack n a -> Stack n a
+push x (Stack xs i) = Stack (replace i x xs) (i + 1)
+
+pop :: (KnownNat n) => Stack n a -> (a, Stack n a)
+pop (Stack xs i) = (xs !! (i - 1), Stack xs (i - 1))
diff --git a/src/RetroClash/Utils.hs b/src/RetroClash/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/RetroClash/Utils.hs
@@ -0,0 +1,365 @@
+{-# LANGUAGE ScopedTypeVariables, ApplicativeDo, Rank2Types #-}
+{-# LANGUAGE TupleSections #-}
+module RetroClash.Utils
+    ( withResetEnableGen
+    , withEnableGen
+
+    , withStart
+
+    , Polarity(..), Active, active, IsActive(..)
+    , toActiveDyn
+
+    , bitwise
+    , parity
+    , half
+    , halfIndex
+
+    , bvShiftL
+    , bvShiftR
+
+    , (.==)
+    , (==.)
+    , (./=)
+    , (/=.)
+    , (.>)
+    , (.>=)
+    , (.<)
+    , (.<=)
+    , (<=.)
+
+    , (.!!.)
+    , (.!!)
+    , (!!.)
+
+    , changed
+    , integrate
+    , debounce
+
+    , riseEveryWhen
+    , oscillateWhen
+
+    , oneHot
+    , roundRobin
+
+    , countFromTo
+    , nextIdx, prevIdx
+    , succIdx, predIdx
+    , moreIdx, lessIdx
+
+    , mealyState
+    , mealyStateB
+
+    , mooreState
+    , mooreStateB
+
+    , enable
+    , guardA
+    , muxA
+    , (.<|>.)
+    , (.|>.)
+    , (|>.)
+    , (.<|.)
+    , (.<|)
+    , muxMaybe
+
+    , packWrite
+    , noWrite
+    , withWrite
+    , singlePort
+    , unbraid
+
+    , shifterL
+    , shifterR
+    ) where
+
+import Clash.Prelude
+import RetroClash.Clock
+import Data.Maybe (fromMaybe)
+import Control.Monad.State
+import qualified Data.Foldable as F
+import Data.Monoid
+
+withResetEnableGen
+    :: (KnownDomain dom)
+    => (HiddenClockResetEnable dom => r)
+    -> Clock dom -> r
+withResetEnableGen board clk = withClockResetEnable clk resetGen enableGen board
+
+withEnableGen
+    :: (KnownDomain dom)
+    => (HiddenClockResetEnable dom => r)
+    -> Clock dom -> Reset dom -> r
+withEnableGen board clk rst = withClockResetEnable clk rst enableGen board
+
+oneHot :: forall n. (KnownNat n) => Index n -> Vec n Bool
+oneHot = reverse . bitCoerce . bit @(Unsigned n) . fromIntegral
+
+changed :: (HiddenClockResetEnable dom, Eq a, NFDataX a) => a -> Signal dom a -> Signal dom Bool
+changed x0 x = x ./=. register x0 x
+
+integrate
+    :: (Monoid a, NFDataX a, HiddenClockResetEnable dom)
+    => Signal dom Bool -> Signal dom a -> Signal dom a
+integrate clear x = acc
+  where
+    acc = register mempty $ mux clear x $ mappend <$> acc <*> x
+
+debounce
+    :: forall ps a dom. (Eq a, NFDataX a, HiddenClockResetEnable dom, KnownNat (ClockDivider dom ps))
+    => SNat ps -> a -> Signal dom a -> Signal dom a
+debounce SNat start this = regEn start stable this
+  where
+    counter = register (0 :: Index (ClockDivider dom ps)) counterNext
+    counterNext = mux (changed start this) 0 (moreIdx <$> counter)
+    stable = counterNext .==. pure maxBound
+
+roundRobin
+    :: forall n dom a. (KnownNat n, HiddenClockResetEnable dom)
+    => Signal dom Bool
+    -> (Signal dom (Vec n Bool), Signal dom (Index n))
+roundRobin next = (selector, i)
+  where
+    i = regEn (0 :: Index n) next $ nextIdx <$> i
+    selector = oneHot <$> i
+
+data Polarity = High | Low
+    deriving (Show, Eq)
+
+newtype Active (p :: Polarity) = MkActive{ activeLevel :: Bit }
+    deriving (Show, Eq, Ord, Generic, NFDataX, BitPack)
+
+active :: Bit -> Active p
+active = MkActive
+
+toActiveDyn :: Polarity -> Bool -> Bit
+toActiveDyn High = boolToBit
+toActiveDyn Low = complement . boolToBit
+
+fromActiveDyn :: Polarity -> Bit -> Bool
+fromActiveDyn High = bitToBool
+fromActiveDyn Low = bitToBool . complement
+
+class IsActive p where
+    fromActive :: Active p -> Bool
+    toActive :: Bool -> Active p
+
+instance IsActive High where
+    fromActive = fromActiveDyn High . activeLevel
+    toActive = MkActive . toActiveDyn High
+
+instance IsActive Low where
+    fromActive = fromActiveDyn Low . activeLevel
+    toActive = MkActive . toActiveDyn Low
+
+infix 4 ==.
+(==.) :: (Eq a, Functor f) => a -> f a -> f Bool
+x ==. fy = (x ==) <$> fy
+
+infix 4 .==
+(.==) :: (Eq a, Functor f) => f a -> a -> f Bool
+fx .== y = (== y) <$> fx
+
+infix 4 /=.
+(/=.) :: (Eq a, Functor f) => a -> f a -> f Bool
+x /=. fy = (x /=) <$> fy
+
+infix 4 ./=
+(./=) :: (Eq a, Functor f) => f a -> a -> f Bool
+fx ./= y = (/= y) <$> fx
+
+infix 4 .>
+(.>) :: (Ord a, Functor f) => f a -> a -> f Bool
+fx .> y = (> y) <$> fx
+
+infix 4 .>=
+(.>=) :: (Ord a, Functor f) => f a -> a -> f Bool
+fx .>= y = (>= y) <$> fx
+
+infix 4 .<
+(.<) :: (Ord a, Functor f) => f a -> a -> f Bool
+fx .< y = (< y) <$> fx
+
+infix 4 .<=
+(.<=) :: (Ord a, Functor f) => f a -> a -> f Bool
+fx .<= y = (<= y) <$> fx
+
+infix 4 <=.
+(<=.) :: (Ord a, Functor f) => a -> f a -> f Bool
+x <=. fy = (x <=) <$> fy
+
+(.!!.) :: (KnownNat n, Enum i, Applicative f) => f (Vec n a) -> f i -> f a
+(.!!.) = liftA2 (!!)
+
+(!!.) :: (KnownNat n, Enum i, Functor f) => Vec n a -> f i -> f a
+xs !!. i = (xs !!) <$> i
+
+(.!!) :: (KnownNat n, Enum i, Functor f) => f (Vec n a) -> i -> f a
+xs .!! i = (!! i) <$> xs
+
+countFromTo :: (Eq a, Enum a, NFDataX a, HiddenClockResetEnable dom) => a -> a -> Signal dom Bool -> Signal dom a
+countFromTo from to tick = counter
+  where
+    counter = regEn from tick $ mux (counter .==. pure to) (pure from) (succ <$> counter)
+
+nextIdx :: (Eq a, Enum a, Bounded a) => a -> a
+nextIdx = fromMaybe minBound . succIdx
+
+prevIdx :: (Eq a, Enum a, Bounded a) => a -> a
+prevIdx = fromMaybe maxBound . predIdx
+
+moreIdx :: (Eq a, Enum a, Bounded a) => a -> a
+moreIdx = fromMaybe maxBound . succIdx
+
+lessIdx :: (Eq a, Enum a, Bounded a) => a -> a
+lessIdx = fromMaybe minBound . predIdx
+
+succIdx :: (Eq a, Enum a, Bounded a) => a -> Maybe a
+succIdx x | x == maxBound = Nothing
+          | otherwise = Just $ succ x
+
+predIdx :: (Eq a, Enum a, Bounded a) => a -> Maybe a
+predIdx x | x == minBound = Nothing
+          | otherwise = Just $ pred x
+
+mealyState
+   :: (HiddenClockResetEnable dom, NFDataX s)
+   => (i -> State s o) -> s -> (Signal dom i -> Signal dom o)
+mealyState f = mealy step
+  where
+    step s x = let (y, s') = runState (f x) s in (s', y)
+
+mealyStateB
+    :: (HiddenClockResetEnable dom, NFDataX s, Bundle i, Bundle o)
+    => (i -> State s o) -> s -> (Unbundled dom i -> Unbundled dom o)
+mealyStateB f s0 = unbundle . mealyState f s0 . bundle
+
+mooreState
+    :: (HiddenClockResetEnable dom, NFDataX s)
+    => (i -> State s ()) -> (s -> o) -> s -> (Signal dom i -> Signal dom o)
+mooreState step = moore step'
+  where
+    step' s x = execState (step x) s
+
+mooreStateB
+    :: (HiddenClockResetEnable dom, NFDataX s, Bundle i, Bundle o)
+    => (i -> State s ()) -> (s -> o) -> s -> (Unbundled dom i -> Unbundled dom o)
+mooreStateB step out s0 = unbundle . mooreState step out s0 . bundle
+
+enable :: (Applicative f) => f Bool -> f a -> f (Maybe a)
+enable en x = mux en (Just <$> x) (pure Nothing)
+
+guardA :: (Applicative f, Alternative m) => f Bool -> f (m a) -> f (m a)
+guardA en x = mux en x (pure empty)
+
+packWrite :: addr -> Maybe val -> Maybe (addr, val)
+packWrite addr val = (addr,) <$> val
+
+withWrite :: (Applicative f) => f (Maybe addr) -> f (Maybe wr) -> f (Maybe (addr, Maybe wr))
+withWrite = liftA2 $ \addr wr -> (,wr) <$> addr
+
+noWrite :: (Applicative f) => f (Maybe addr) -> f (Maybe (addr, Maybe wr))
+noWrite addr = addr `withWrite` pure Nothing
+
+singlePort :: (Applicative f) => (f addr -> f (Maybe (addr, wr)) -> r) -> (f addr -> f (Maybe wr) -> r)
+singlePort mem addr wr = mem addr (packWrite <$> addr <*> wr)
+
+unbraid
+    :: (KnownNat n, KnownNat k, 1 <= n, 1 <= (n * 2 ^ k), (CLog 2 (2 ^ k)) ~ k, (CLog 2 (n * 2 ^ k)) ~ (CLog 2 n + k))
+    => Maybe (Index (n * 2 ^ k))
+    -> Vec (2 ^ k) (Maybe (Index n))
+unbraid Nothing = repeat Nothing
+unbraid (Just addr) = map (\k -> addr' <$ guard (sel == k)) indicesI
+  where
+    (addr', sel) = bitCoerce addr
+
+muxA :: (Foldable t, Alternative m, Applicative f) => t (f (m a)) -> f (m a)
+muxA = fmap getAlt . getAp . F.foldMap (Ap . fmap Alt)
+
+infixl 3 .<|>.
+(.<|>.) :: (Applicative f, Alternative m) => f (m a) -> f (m a) -> f (m a)
+(.<|>.) = liftA2 (<|>)
+
+infix 2 .<|., .<|, |>., .|>.
+
+(.<|.) :: (Applicative f) => f (Maybe a) -> f a -> f a
+(.<|.) = flip (.|>.)
+
+(.<|) :: (Applicative f) => f (Maybe a) -> a -> f a
+(.<|) = flip (|>.)
+
+(.|>.) :: (Applicative f) => f a -> f (Maybe a) -> f a
+(.|>.) = muxMaybe
+
+(|>.) :: (Applicative f) => a -> f (Maybe a) -> f a
+x |>. fmx = fromMaybe x <$> fmx
+
+muxMaybe :: (Applicative f) => f a -> f (Maybe a) -> f a
+muxMaybe = liftA2 fromMaybe
+
+withStart :: (HiddenClockResetEnable dom) => a -> Signal dom a -> Signal dom a
+withStart x0 = mux (register True $ pure False) (pure x0)
+
+bitwise :: (BitPack a) => (BitVector (BitSize a) -> BitVector (BitSize a)) -> (a -> a)
+bitwise f = unpack . f . pack
+
+parity :: forall a n. (BitPack a, BitSize a ~ (n + 1)) => a -> Bit
+parity = fold xor . bitCoerce @_ @(Vec (BitSize a) Bit)
+
+half :: (Bits a) => a -> a
+half x = x `shiftR` 1
+
+halfIndex
+    :: (KnownNat n, 1 <= (2 * n), (CLog 2 (2 * n)) ~ (CLog 2 n + 1))
+    => Index (2 * n)
+    -> Index n
+halfIndex = fst . bitCoerce @_ @(_, Bit)
+
+bvShiftL :: (KnownNat n) => BitVector n -> Bit -> (Bit, BitVector n)
+bvShiftL xs x = bitCoerce (xs, x)
+
+bvShiftR :: (KnownNat n) => Bit -> BitVector n -> (BitVector n, Bit)
+bvShiftR x xs = bitCoerce (x, xs)
+
+riseEveryWhen
+    :: forall n dom. (HiddenClockResetEnable dom, KnownNat n)
+    => SNat n -> Signal dom Bool -> Signal dom Bool
+riseEveryWhen n trigger = isRising False $ cnt .==. pure maxBound
+  where
+    cnt = regEn (0 :: Index n) trigger (nextIdx <$> cnt)
+
+oscillateWhen
+    :: (HiddenClockResetEnable dom)
+    => Bool -> Signal dom Bool -> Signal dom Bool
+oscillateWhen init trigger = r
+  where
+    r = regEn init trigger $ not <$> r
+
+shifterL
+    :: (BitPack a, HiddenClockResetEnable dom)
+    => Signal dom (Maybe a)
+    -> Signal dom Bool
+    -> Signal dom Bit
+shifterL load tick = msb <$> next
+  where
+    r = register 0 next
+
+    next = muxA
+        [ fmap pack <$> load
+        , enable tick $ (`shiftL` 1) <$> r
+        ] .<|.
+        r
+
+shifterR
+    :: (BitPack a, HiddenClockResetEnable dom)
+    => Signal dom (Maybe a)
+    -> Signal dom Bool
+    -> Signal dom Bit
+shifterR load tick = lsb <$> next
+  where
+    r = register 0 next
+
+    next = muxA
+        [ fmap pack <$> load
+        , enable tick $ (`shiftR` 1) <$> r
+        ] .<|.
+        r
diff --git a/src/RetroClash/VGA.hs b/src/RetroClash/VGA.hs
new file mode 100644
--- /dev/null
+++ b/src/RetroClash/VGA.hs
@@ -0,0 +1,158 @@
+{-# LANGUAGE ScopedTypeVariables, NumericUnderscores, PartialTypeSignatures #-}
+{-# LANGUAGE DuplicateRecordFields, RecordWildCards, ApplicativeDo #-}
+{-# LANGUAGE ExistentialQuantification, StandaloneDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
+module RetroClash.VGA
+    ( VGASync(..)
+    , VGADriver(..)
+    , vgaDriver
+    , VGAOut(..)
+    , vgaOut
+    , VGATiming(..), VGATimings(..)
+
+    , vga640x480at60
+    , vga800x600at60
+    , vga800x600at72
+    , vga1024x768at60
+    ) where
+
+import Clash.Prelude
+import RetroClash.Clock
+import RetroClash.Utils
+import Data.Maybe (isJust)
+
+data VGASync dom = VGASync
+    { vgaHSync :: "HSYNC" ::: Signal dom Bit
+    , vgaVSync :: "VSYNC" ::: Signal dom Bit
+    , vgaDE :: "DE" ::: Signal dom Bool
+    }
+
+data VGAOut dom r g b = VGAOut
+    { vgaSync  :: VGASync dom
+    , vgaR     :: "RED" ::: Signal dom (Unsigned r)
+    , vgaG     :: "GREEN" ::: Signal dom (Unsigned g)
+    , vgaB     :: "BLUE" ::: Signal dom (Unsigned b)
+    }
+
+data VGADriver dom w h = VGADriver
+    { vgaSync :: VGASync dom
+    , vgaX :: Signal dom (Maybe (Index w))
+    , vgaY :: Signal dom (Maybe (Index h))
+    }
+
+data VGATiming (visible :: Nat) = forall front pulse back. VGATiming
+    { polarity :: Polarity
+    , preWidth :: SNat front
+    , pulseWidth :: SNat pulse
+    , postWidth :: SNat back
+    }
+deriving instance Show (VGATiming vis)
+
+data VGATimings (ps :: Nat) (w :: Nat) (h :: Nat) = VGATimings
+    { vgaHorizTiming :: VGATiming w
+    , vgaVertTiming :: VGATiming h
+    }
+    deriving (Show)
+
+data VGAState visible front pulse back
+    = Visible (Index visible)
+    | FrontPorch (Index front)
+    | SyncPulse (Index pulse)
+    | BackPorch (Index back)
+    deriving (Show, Generic, NFDataX)
+
+visible :: VGAState visible front pulse back -> Maybe (Index visible)
+visible (Visible coord) = Just coord
+visible _ = Nothing
+
+sync :: VGAState visible front pulse back -> Bool
+sync SyncPulse{} = True
+sync _ = False
+
+end :: (KnownNat back) => VGAState visible front pulse back -> Bool
+end (BackPorch cnt) | cnt == maxBound = True
+end _ = False
+
+type Step a = a -> a
+
+data VGACounter visible
+    = forall front pulse back. (KnownNat front, KnownNat pulse, KnownNat back)
+    => VGACounter (Step (VGAState visible front pulse back))
+
+mkVGACounter
+    :: SNat front -> SNat pulse -> SNat back
+    -> Step (VGAState visible front pulse back)
+    -> VGACounter visible
+mkVGACounter SNat SNat SNat = VGACounter
+
+vgaCounter :: (KnownNat visible) => VGATiming visible -> VGACounter visible
+vgaCounter (VGATiming _ front@SNat pulse@SNat back@SNat) =
+    mkVGACounter front pulse back $ \case
+        Visible cnt    -> count Visible    FrontPorch cnt
+        FrontPorch cnt -> count FrontPorch SyncPulse  cnt
+        SyncPulse cnt  -> count SyncPulse  BackPorch  cnt
+        BackPorch cnt  -> count BackPorch  Visible    cnt
+  where
+    count :: (KnownNat n, KnownNat m) => (Index n -> a) -> (Index m -> a) -> Index n -> a
+    count this next = maybe (next 0) this . succIdx
+
+vgaDriver
+    :: (HiddenClockResetEnable dom, KnownNat w, KnownNat h)
+    => (DomainPeriod dom ~ ps)
+    => VGATimings ps w h
+    -> VGADriver dom w h
+vgaDriver VGATimings{..} = case (vgaCounter vgaHorizTiming, vgaCounter vgaVertTiming) of
+    (VGACounter nextH, VGACounter nextV) -> VGADriver{ vgaSync = VGASync{..}, .. }
+      where
+        stateH = register (Visible 0) $ nextH <$> stateH
+        stateV = regEn (Visible 0) endLine $ nextV <$> stateV
+
+        vgaX = visible <$> stateH
+        vgaHSync = toActiveDyn (polarity vgaHorizTiming) . sync <$> stateH
+        endLine = end <$> stateH
+
+        vgaY = visible <$> stateV
+        vgaVSync = toActiveDyn (polarity vgaVertTiming) . sync <$> stateV
+
+        vgaDE = isJust <$> vgaX .&&. isJust <$> vgaY
+
+
+vgaOut
+    :: (HiddenClockResetEnable dom, KnownNat r, KnownNat g, KnownNat b)
+    => VGASync dom
+    -> Signal dom (Unsigned r, Unsigned g, Unsigned b)
+    -> VGAOut dom r g b
+vgaOut vgaSync@VGASync{..} rgb = VGAOut{..}
+  where
+    (vgaR, vgaG, vgaB) = unbundle $ blank rgb
+
+    blank = mux (not <$> vgaDE) (pure (0, 0, 0))
+
+-- | VGA 640*480@60Hz, 25.175 MHz pixel clock
+vga640x480at60 :: VGATimings (HzToPeriod 25_175_000) 640 480
+vga640x480at60 = VGATimings
+    { vgaHorizTiming = VGATiming Low (SNat @16) (SNat @96) (SNat @48)
+    , vgaVertTiming  = VGATiming Low (SNat @11) (SNat @2)  (SNat @31)
+    }
+
+-- | VGA 800x600@72Hz, 50 MHz pixel clock
+vga800x600at72 :: VGATimings (HzToPeriod 50_000_000) 800 600
+vga800x600at72 = VGATimings
+    { vgaHorizTiming = VGATiming High (SNat @56) (SNat @120) (SNat @64)
+    , vgaVertTiming  = VGATiming High (SNat @37) (SNat @6)   (SNat @23)
+    }
+
+-- | VGA 800x600@60Hz, 40 MHz pixel clock
+vga800x600at60 :: VGATimings (HzToPeriod 40_000_000) 800 600
+vga800x600at60 = VGATimings
+    { vgaHorizTiming = VGATiming High (SNat @40) (SNat @128) (SNat @88)
+    , vgaVertTiming  = VGATiming High (SNat @1)  (SNat @4)   (SNat @23)
+    }
+
+-- | VGA 1024*768@60Hz, 65 MHz pixel clock
+vga1024x768at60 :: VGATimings (HzToPeriod 65_000_000) 1024 768
+vga1024x768at60 = VGATimings
+    { vgaHorizTiming = VGATiming Low (SNat @24) (SNat @136) (SNat @160)
+    , vgaVertTiming  = VGATiming Low (SNat @3)  (SNat @6)   (SNat @29)
+    }
diff --git a/src/RetroClash/Video.hs b/src/RetroClash/Video.hs
new file mode 100644
--- /dev/null
+++ b/src/RetroClash/Video.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module RetroClash.Video
+    ( maskStart, maskEnd, maskSides
+    , center
+    , scale
+    , withBorder
+    ) where
+
+import Clash.Prelude
+import RetroClash.Utils
+import Data.Maybe
+
+maskStart
+    :: forall k n dom. (KnownNat n, KnownNat k)
+    => (HiddenClockResetEnable dom)
+    => Signal dom (Maybe (Index (k + n)))
+    -> Signal dom (Maybe (Index n))
+maskStart = maskSides (SNat @k)
+
+maskEnd
+    :: forall k n dom. (KnownNat n, KnownNat k)
+    => (HiddenClockResetEnable dom)
+    => Signal dom (Maybe (Index (n + k)))
+    -> Signal dom (Maybe (Index n))
+maskEnd = maskSides (SNat @0)
+
+center
+    :: forall n n0 k m dom. (KnownNat n, KnownNat n0, KnownNat k, KnownNat m)
+    => (k ~ ((n0 - n) `Div` 2), n0 ~ (k + n + m))
+    => (HiddenClockResetEnable dom)
+    => Signal dom (Maybe (Index n0))
+    -> Signal dom (Maybe (Index n))
+center = maskSides (SNat @k)
+
+maskSides
+    :: (KnownNat n, KnownNat m, KnownNat k)
+    => (HiddenClockResetEnable dom)
+    => SNat k
+    -> Signal dom (Maybe (Index (k + n + m)))
+    -> Signal dom (Maybe (Index n))
+maskSides k raw = transformed
+  where
+    changed = register Nothing raw ./=. raw
+    started = raw .== Just (snatToNum k)
+
+    r = register Nothing transformed
+    transformed =
+        mux (not <$> changed) r $
+        mux (isNothing <$> raw) (pure Nothing) $
+        mux started (pure $ Just 0) $
+        (succIdx =<<) <$> r
+
+scale
+    :: forall n k dom. (KnownNat n, KnownNat k, 1 <= k)
+    => (HiddenClockResetEnable dom)
+    => SNat k
+    -> Signal dom (Maybe (Index (n * k)))
+    -> (Signal dom (Maybe (Index n)), Signal dom (Maybe (Index k)))
+scale k raw = (scaledNext, enable (isJust <$> scaledNext) counterNext)
+  where
+    prev = register Nothing raw
+    changed = raw ./=. prev
+
+    counter = register (0 :: Index k) counterNext
+    counterNext =
+        mux (not <$> changed) counter $
+        mux (isNothing <$> prev) (pure 0) $
+        nextIdx <$> counter
+
+    scaled = register Nothing scaledNext
+    scaledNext =
+        mux (not <$> changed) scaled $
+        mux (counterNext .== 0) (maybe (Just 0) succIdx <$> scaled) $
+        scaled
+
+withBorder
+    :: (BitPack a, BitPack a', BitSize a' ~ BitSize a)
+    => a
+    -> (x -> y -> a')
+    -> Maybe x -> Maybe y -> a
+withBorder border draw x y = case (x, y) of
+    (Just x, Just y) -> bitCoerce $ draw x y
+    _ -> border