diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,20 @@
+The MIT License (MIT)
+
+Copyright (c) 2014 Robert Vollmert
+
+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/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/puzzle-draw.cabal b/puzzle-draw.cabal
new file mode 100644
--- /dev/null
+++ b/puzzle-draw.cabal
@@ -0,0 +1,106 @@
+-- Initial puzzle-draw.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+-- The name of the package.
+name:                puzzle-draw
+
+-- The package version.  See the Haskell package versioning policy (PVP) 
+-- for standards guiding when and how versions should be incremented.
+-- http://www.haskell.org/haskellwiki/Package_versioning_policy
+-- PVP summary:      +-+------- breaking API changes
+--                   | | +----- non-breaking API additions
+--                   | | | +--- code changes with no API change
+version:             0.1.0.0
+
+-- A short (one-line) description of the package.
+synopsis:            Creating graphics for pencil puzzles.
+
+-- A longer description of the package.
+description:         puzzle-draw is a library for drawing pencil puzzles
+                     using Diagrams. It aims to provide a utility layer
+                     on top of Diagrams to help with drawing arbitrary
+                     puzzles, as well as supporting several specific
+                     puzzle types directly. In addition, it includes
+                     functionality for parsing puzzle data from a
+                     YAML file format.
+
+-- The license under which the package is released.
+license:             MIT
+
+-- The file containing the license text.
+license-file:        LICENSE
+
+-- The package author(s).
+author:              Robert Vollmert
+
+-- An email address to which users can send suggestions, bug reports, and 
+-- patches.
+maintainer:          rfvollmert@gmail.com
+
+-- A copyright notice.
+-- copyright:           
+
+category:            Graphics
+
+build-type:          Simple
+
+-- Constraint on the version of Cabal needed to build this package.
+cabal-version:       >=1.8
+Source-repository head
+  type:     git
+  location: http://github.com/robx/puzzle-draw.git
+
+library
+  -- Modules exported by the library.
+  exposed-modules:     Data.Puzzles.Grid
+                       Data.Puzzles.GridShape
+                       Data.Puzzles.Elements
+                       Data.Puzzles.Pyramid
+                       Data.Puzzles.Sudoku
+                       Data.Puzzles.Compose
+                       Data.Puzzles.PuzzleTypes
+                       Text.Puzzles.Util
+                       Text.Puzzles.Puzzle
+                       Text.Puzzles.PuzzleTypes
+                       Diagrams.Puzzles.Grid
+                       Diagrams.Puzzles.Lib
+                       Diagrams.Puzzles.Elements
+                       Diagrams.Puzzles.Widths
+                       Diagrams.Puzzles.Pyramid
+                       Diagrams.Puzzles.PuzzleGrids
+                       Diagrams.Puzzles.PuzzleTypes
+                       Diagrams.Puzzles.Draw
+  
+  -- Modules included in this library but not exported.
+  -- other-modules:       
+  
+  -- Other library packages from which modules are imported.
+  build-depends:       base >= 4.2 && < 4.8,
+                       diagrams-lib >= 1.1 && < 1.2,
+                       parsec >= 3.1 && < 3.2,
+                       yaml >= 0.8.4 && < 0.9,
+                       aeson >= 0.7 && < 0.8,
+                       unordered-containers >= 0.2 && < 0.3,
+                       containers >= 0.5 && < 0.6,
+                       hashable >= 1.2 && < 1.3,
+                       text >= 1.1 && < 1.2,
+                       SVGFonts >= 1.4 && < 1.5
+  hs-source-dirs:      src
+  ghc-options:         -Wall
+
+test-suite test
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      tests
+  main-is:             tests.hs
+  build-depends:       base >= 4.2 && < 4.8,
+                       tasty >= 0.8 && < 0.9,
+                       tasty-hunit >= 0.8 && < 0.9,
+                       yaml >= 0.8.4 && < 0.9,
+                       text >= 1.1 && < 1.2,
+                       deepseq >= 1.3 && < 1.4,
+                       blaze-svg >= 0.3 && < 0.4,
+                       diagrams-lib >= 1.1 && < 1.2,
+                       diagrams-svg >= 1.0 && < 1.1,
+                       bytestring >= 0.10 && < 0.11,
+                       puzzle-draw
+  ghc-options:         -Wall
diff --git a/src/Data/Puzzles/Compose.hs b/src/Data/Puzzles/Compose.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Puzzles/Compose.hs
@@ -0,0 +1,113 @@
+{-# LANGUAGE FlexibleContexts, RankNTypes #-}
+
+-- |
+-- Helpers to string together parser and renderer by puzzle type.
+
+module Data.Puzzles.Compose (
+    PuzzleHandler,
+    handle,
+    -- * Handlers
+    drawPuzzle,
+    drawPuzzleSol,
+    drawPuzzleMaybeSol,
+    drawPuzzle',
+    drawSolution',
+    drawExample'
+  ) where
+
+import Data.Maybe
+import Diagrams.Prelude
+import Data.Yaml (Parser, Value)
+import Data.Traversable (traverse)
+
+import Text.Puzzles.Puzzle
+import Diagrams.Puzzles.Draw
+import Data.Puzzles.PuzzleTypes
+
+import qualified Text.Puzzles.PuzzleTypes as R
+import qualified Diagrams.Puzzles.PuzzleTypes as D
+
+-- | A function to compose an arbitrary matching pair of parser and renderer.
+--   In @PuzzleHandler b a@, @b@ is the rendering backend type, while @a@ is
+--   the result type of the composition.
+type PuzzleHandler b a = forall p q.
+                         ParsePuzzle p q -> RenderPuzzle b p q -> a
+
+-- | @handle h t@ composes the parser and renderer for the puzzle
+--   type @t@ with the handler @h@.
+handle :: (Backend b R2, Renderable (Path R2) b) =>
+        PuzzleHandler b a -> PuzzleType -> a
+handle f LITS                 = f R.lits                D.lits
+handle f LITSPlus             = f R.litsplus            D.litsplus
+handle f Geradeweg            = f R.geradeweg           D.geradeweg
+handle f Fillomino            = f R.fillomino           D.fillomino
+handle f Masyu                = f R.masyu               D.masyu
+handle f Nurikabe             = f R.nurikabe            D.nurikabe
+handle f LatinTapa            = f R.latintapa           D.latintapa
+handle f Sudoku               = f R.sudoku              D.sudoku
+handle f ThermoSudoku         = f R.thermosudoku        D.thermosudoku
+handle f Pyramid              = f R.pyramid             D.pyramid
+handle f RowKropkiPyramid     = f R.kpyramid            D.kpyramid
+handle f SlitherLink          = f R.slither             D.slither
+handle f SlitherLinkLiar      = f R.liarslither         D.liarslither
+handle f TightfitSkyscrapers  = f R.tightfitskyscrapers D.tightfitskyscrapers
+handle f WordLoop             = f R.wordloop            D.wordloop
+handle f WordSearch           = f R.wordsearch          D.wordsearch
+handle f CurveData            = f R.curvedata           D.curvedata
+handle f DoubleBack           = f R.doubleback          D.doubleback
+handle f Slalom               = f R.slalom              D.slalom
+handle f Compass              = f R.compass             D.compass
+handle f BoxOf2Or3            = f R.boxof2or3           D.boxof2or3
+handle f AfternoonSkyscrapers = f R.afternoonskyscrapers D.afternoonskyscrapers
+handle f CountNumbers         = f R.countnumbers        D.countnumbers
+
+-- | Handler that parses a puzzle from a YAML value, and renders.
+drawPuzzle :: PuzzleHandler b (Value -> Parser (Diagram b R2))
+drawPuzzle (pp, _) (dp, _) p = do
+    p' <- pp p
+    return $ dp p'
+
+-- | Handler that parses puzzle and solution from a pair of corresponding
+--   YAML values, and renders both individually.
+drawPuzzleSol :: PuzzleHandler b ((Value, Value)
+                 -> Parser (Diagram b R2, Diagram b R2))
+drawPuzzleSol (pp, ps) (dp, ds) (p, s) = do
+    p' <- pp p
+    s' <- ps s
+    return (dp p', ds (p', s'))
+
+-- | Handler that parses puzzle and an optional solution from a pair of
+--   corresponding YAML values, and renders both individually, optionally
+--   for the solution.
+drawPuzzleMaybeSol :: PuzzleHandler b ((Value, Maybe Value)
+                      -> Parser (Diagram b R2, Maybe (Diagram b R2)))
+drawPuzzleMaybeSol (pp, ps) (dp, ds) (p, s) = do
+    p' <- pp p
+    s' <- traverse ps $ s
+    let mps = case s' of Nothing  -> Nothing
+                         Just s'' -> Just (p', s'')
+    return (dp p', ds <$> mps)
+
+-- | Variant of 'drawPuzzle' that accepts a pair of puzzle YAML value and
+--   optional solution YAML value.
+drawPuzzle' :: PuzzleHandler b ((Value, Maybe Value) -> Parser (Diagram b R2))
+drawPuzzle' (pp, _) (dp, _) (p, _) = do
+    p' <- pp p
+    return $ dp p'
+
+-- | Handler that accepts a pair of puzzle YAML value and optional solution
+--   YAML value, and renders the solution, failing if the solution is not
+--   provided.
+drawSolution' :: PuzzleHandler b ((Value, Maybe Value) -> Parser (Diagram b R2))
+drawSolution' (pp, ps) (_, ds) (p, ms) = do
+    p' <- pp p
+    s' <- maybe (fail "no solution provided") ps ms
+    return $ ds (p', s')
+
+-- | Like 'drawSolution'', but renders puzzle and solution in example layout.
+drawExample' :: (Backend b R2, Renderable (Path R2) b) =>
+                PuzzleHandler b ((Value, Maybe Value) -> Parser (Diagram b R2))
+drawExample' (pp, ps) (dp, ds) (p, ms) = do
+    p' <- pp p
+    s' <- maybe (fail "no solution provided") ps ms
+    return . fromJust $ draw (dp p', Just $ ds (p', s')) DrawExample
diff --git a/src/Data/Puzzles/Elements.hs b/src/Data/Puzzles/Elements.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Puzzles/Elements.hs
@@ -0,0 +1,54 @@
+-- | Types for a variety of puzzle elements.
+module Data.Puzzles.Elements where
+
+import Data.Puzzles.GridShape (Coord, Edge)
+
+type Clue a = Maybe a
+
+data MasyuPearl = MWhite | MBlack
+type MasyuClue = Clue MasyuPearl
+
+type IntClue = Clue Int
+
+-- | A Compass clue, specifiying optional numbers in the
+--   four cardinal directions.
+data CompassC = CC (Maybe Int) (Maybe Int) (Maybe Int) (Maybe Int)
+    deriving Show
+
+type CompassClue = Clue CompassC
+
+-- | A cell that is optionally bisected by a diagonal
+--   (up-right or down-right).
+data Tightfit a = Single a | UR a a | DR a a
+
+instance Show a => Show (Tightfit a) where
+    show c = "(" ++ show' c ++ ")"
+        where show' (Single x) = show x
+              show' (UR x y)   = show x ++ "/" ++ show y
+              show' (DR x y)   = show x ++ "\\" ++ show y
+
+-- | A marked word in a letter grid, by its start and end
+--   coordinates.
+data MarkedWord = MW { mwstart :: Coord, mwend :: Coord }
+
+-- | A loop of edges.
+type Loop = [Edge]
+
+-- | A thermometer, as a list of coordinates from bulb to end.
+--   There should be at least two entries, entries should be distinct,
+--   and successive entries should be neighbours (diagonal neighbours
+--   are fine).
+type Thermometer = [Coord]
+
+-- | A forward or backward diagonal as occurring in the solution
+--   of a slalom puzzle.
+data SlalomDiag = SlalomForward | SlalomBackward
+    deriving Show
+
+-- | Shadow along from the western and southern side, as used for
+--   afternoon skyscrapers.
+data Shade = Shade Bool Bool
+    deriving Show
+
+data KropkiDot = None | Black | White
+    deriving Show
diff --git a/src/Data/Puzzles/Grid.hs b/src/Data/Puzzles/Grid.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Puzzles/Grid.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE FlexibleContexts, GADTs, StandaloneDeriving #-}
+
+-- | Puzzle grids.
+module Data.Puzzles.Grid where
+
+import Data.Maybe
+import qualified Data.Map as Map
+import Data.Foldable (Foldable, fold)
+import Data.Traversable (Traversable, traverse)
+import Control.Applicative ((<$>))
+
+import Data.Puzzles.GridShape hiding (size, cells)
+import qualified Data.Puzzles.GridShape as GS
+import Data.Puzzles.Elements
+
+-- | A generic grid, with the given shape and contents.
+data Grid s a where
+    Grid :: { shape :: s
+            , contents :: Map.Map (Cell s) a} -> Grid s a
+
+deriving instance (Show a, Show s, GridShape s) => Show (Grid s a)
+
+-- | Standard square grid.
+type SGrid = Grid Square
+
+type CharGrid = SGrid Char
+type AreaGrid = CharGrid
+type ShadedGrid = SGrid Bool
+type CharClueGrid = SGrid (Maybe Char)
+type IntGrid = SGrid (Clue Int)
+
+-- | Lookup a grid value at a given cell. Unsafe.
+(!) :: (GridShape s, Ord (Cell s)) => Grid s a -> Cell s -> a
+(!) (Grid _ m) = (m Map.!)
+
+instance Functor (Grid s) where
+    fmap f (Grid s m) = Grid s (fmap f m)
+
+instance Foldable (Grid s) where
+    fold (Grid _ m) = fold m
+
+instance Traversable (Grid s) where
+    traverse f (Grid s m) = Grid s <$> (traverse f m)
+
+-- | Initialize a square grid from a list of lists. The grid
+--   might be incomplete if some rows are shorter.
+fromListList :: [[a]] -> Grid Square a
+fromListList g = Grid s m
+  where
+    w = maximum . map length $ g
+    h = length g
+    s = Square w h
+    m = Map.fromList . concat
+      . zipWith (\y -> zipWith (\x -> (,) (x, y)) [0..]) [h-1,h-2..]
+      $ g
+
+size :: GridShape s => Grid s a -> GridSize s
+size = GS.size . shape
+
+cells :: GridShape s => Grid s a -> [Cell s]
+cells = GS.cells . shape
+
+inBounds :: (GridShape s, Eq (Cell s)) => Grid s a -> Cell s -> Bool
+inBounds g c = c `elem` cells g
+
+-- | For a grid with value type @Maybe a@, return an association
+--   list of cells and @Just@ values.
+clues :: GridShape s => Grid s (Maybe a) -> [(Cell s, a)]
+clues g = [ (k, v) | (k, Just v) <- values g ]
+
+-- | Association list of cells and values.
+values :: GridShape s => Grid s a -> [(Cell s, a)]
+values (Grid _ m) = Map.toList m
+
+-- | The inner edges of a grid that separate unequal cells.
+borders :: Eq a => Grid Square a -> [Edge]
+borders g = [ E p V | p <- vborders ] ++ [ E p H | p <- hborders ]
+  where
+    borders' f (sx, sy) = [ (x + 1, y) | x <- [0 .. sx - 2]
+                                       , y <- [0 .. sy - 1]
+                                       , f (x, y) /= f (x + 1, y) ]
+    vborders = borders' (g !) (size g)
+    hborders = map swap $ borders' ((g !) . swap) (swap . size $ g)
+    swap (x, y) = (y, x)
+
+-- | Clues along the outside of a square grid.
+data OutsideClues a = OC { left :: [a], right :: [a], bottom :: [a], top :: [a] }
+    deriving Show
+
+-- | Convert outside clues to association list mapping coordinate to value.
+outsideclues :: OutsideClues (Maybe a) -> [((Int, Int), a)]
+outsideclues (OC l r b t) = mapMaybe liftMaybe . concat $
+                             [ zipWith (\ y c -> ((-1, y), c)) [0..h-1] l
+                             , zipWith (\ y c -> (( w, y), c)) [0..h-1] r
+                             , zipWith (\ x c -> (( x,-1), c)) [0..w-1] b
+                             , zipWith (\ x c -> (( x, h), c)) [0..w-1] t
+                             ]
+  where
+    w = length b
+    h = length l
+    liftMaybe (p, Just x)  = Just (p, x)
+    liftMaybe (_, Nothing) = Nothing
diff --git a/src/Data/Puzzles/GridShape.hs b/src/Data/Puzzles/GridShape.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Puzzles/GridShape.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
+
+-- | Grid shapes.
+module Data.Puzzles.GridShape where
+
+-- | The geometry of a grid.
+class Show (Cell a) => GridShape a where
+    type GridSize a :: *
+    type Cell     a :: *
+    type Vertex   a :: *
+
+    size :: a -> GridSize a
+    cells :: a -> [Cell a]
+    vertices :: a -> [Vertex a]
+    neighbours :: a -> Cell a -> [Cell a]
+
+-- | A standard square grid, with cells and vertices
+--   indexed by pairs of integers in mathematical coordinates.
+--   The bottom-left corner is vertex (0, 0), the bottom-left
+--   cell is cell (0, 0).
+data Square = Square !Int !Int
+    deriving Show
+
+instance GridShape Square where
+    type GridSize Square = (Int, Int)
+    type Cell Square     = (Int, Int)
+    type Vertex Square   = (Int, Int)
+
+    size (Square w h)       = (w, h)
+    cells (Square w h)      = [(x, y) | x <- [0..w-1], y <- [0..h-1]]
+    vertices (Square w h)   = [(x, y) | x <- [0..w], y <- [0..h]]
+    neighbours (Square w h) c = filter inBounds . map (add c) $ deltas
+      where
+        inBounds (x, y) = x >= 0 && x < w && y >= 0 && y < h
+        deltas = [ (dx, dy)
+                 | dx <- [-1..1], dy <- [-1..1]
+                 , dx /= 0 || dy /= 0
+                 ]
+        add (x, y) (x', y') = (x + x', y + y')
+
+-- | Edge direction in a square grid, vertical or horizontal.
+data Dir = V | H
+    deriving (Eq, Ord, Show)
+
+-- | An edge in a square grid, going up or right from the given cell
+--   centre.
+data Edge = E (Cell Square) Dir
+    deriving (Show, Eq, Ord)
+
+type Coord = Cell Square
+type Size = GridSize Square
diff --git a/src/Data/Puzzles/PuzzleTypes.hs b/src/Data/Puzzles/PuzzleTypes.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Puzzles/PuzzleTypes.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE FlexibleContexts, RankNTypes #-}
+
+-- |
+-- List of specific puzzle types.
+
+module Data.Puzzles.PuzzleTypes (
+    PuzzleType(..),
+    lookupType,
+  ) where
+
+import Data.Tuple (swap)
+
+-- | The list of specific puzzle types we can handle.
+data PuzzleType = LITS
+                | LITSPlus
+                | Geradeweg
+                | Fillomino
+                | Masyu
+                | Nurikabe
+                | LatinTapa
+                | Sudoku
+                | ThermoSudoku
+                | Pyramid
+                | RowKropkiPyramid
+                | SlitherLink
+                | SlitherLinkLiar
+                | TightfitSkyscrapers
+                | WordLoop
+                | WordSearch
+                | CurveData
+                | DoubleBack
+                | Slalom
+                | Compass
+                | BoxOf2Or3
+                | AfternoonSkyscrapers
+                | CountNumbers
+    deriving (Show, Eq)
+
+typeNames :: [(PuzzleType, String)]
+typeNames = [ (LITS, "lits")
+            , (LITSPlus, "litsplus")
+            , (Geradeweg, "geradeweg")
+            , (Fillomino, "fillomino")
+            , (Masyu, "masyu")
+            , (Nurikabe, "nurikabe")
+            , (LatinTapa, "latintapa")
+            , (Sudoku, "sudoku")
+            , (ThermoSudoku, "thermosudoku")
+            , (Pyramid, "pyramid")
+            , (RowKropkiPyramid, "rowkropkipyramid")
+            , (SlitherLink, "slitherlink")
+            , (SlitherLinkLiar, "slitherlinkliar")
+            , (TightfitSkyscrapers, "skyscrapers-tightfit")
+            , (WordLoop, "wordloop")
+            , (WordSearch, "wordsearch")
+            , (CurveData, "curvedata")
+            , (DoubleBack, "doubleback")
+            , (Slalom, "slalom")
+            , (Compass, "compass")
+            , (BoxOf2Or3, "boxof2or3")
+            , (AfternoonSkyscrapers, "afternoonskyscrapers")
+            , (CountNumbers, "countnumbers")
+            ]
+
+-- | Look up a puzzle type by name.
+lookupType :: String -> Maybe PuzzleType
+lookupType t = lookup t (map swap typeNames)
diff --git a/src/Data/Puzzles/Pyramid.hs b/src/Data/Puzzles/Pyramid.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Puzzles/Pyramid.hs
@@ -0,0 +1,129 @@
+-- | Data types and parsing for pyramid puzzles.
+module Data.Puzzles.Pyramid (
+    Row(..),
+    Pyramid(..),
+    PyramidSol(..),
+    KropkiRow(..),
+    RowKropkiPyramid(..),
+    mergepyramidsol,
+    mergekpyramidsol,
+    plainpyramid,
+    psize
+  ) where
+
+import Data.Char (digitToInt)
+import Text.ParserCombinators.Parsec hiding ((<|>), many)
+import Control.Monad (liftM2, mplus)
+import Data.Yaml hiding (Parser)
+import qualified Data.Yaml as Yaml
+import qualified Data.Text as T
+import Control.Applicative
+
+import Data.Puzzles.Elements
+
+data Row = R { entries :: [Maybe Int]
+             , shaded  :: Bool
+             }
+
+newtype Pyramid = Pyr {unPyr :: [Row]}
+
+newtype PyramidSol = PyramidSol [[Int]]
+    deriving Show
+
+-- | The size (number of rows) of a pyramid.
+psize :: Pyramid -> Int
+psize (Pyr rows) = length rows
+
+-- | Merge a solution into a pyramid.
+mergepyramidsol :: Pyramid -> PyramidSol -> Pyramid
+mergepyramidsol (Pyr rs) (PyramidSol qs)
+    | length rs /= length qs  = error "can't merge differently sized pyramids"
+    | otherwise               = Pyr (zipWith mergerow rs qs)
+    where mergerow (R es s) es' = R (zipWith mplus es (map Just es')) s
+
+-- | Merge a solution into a kropki pyramid.
+mergekpyramidsol :: RowKropkiPyramid -> PyramidSol -> RowKropkiPyramid
+mergekpyramidsol (KP rs) (PyramidSol qs)
+    | length rs /= length qs  = error "can't merge differently sized pyramids"
+    | otherwise               = KP (zipWith mergerow rs qs)
+    where mergerow (KR es s ds) es' =
+              KR (zipWith mplus es (map Just es')) s ds
+
+prow :: GenParser Char st Row
+prow = do s <- pshaded
+          spaces
+          es <- pclues
+          return (R es s)
+
+pplainrow :: GenParser Char st [Int]
+pplainrow = many (spaces >> fmap digitToInt digit)
+
+pshaded :: GenParser Char st Bool
+pshaded = (char 'G' >> return True) <|> (char 'W' >> return False)
+
+pclues :: GenParser Char st [Maybe Int]
+pclues = do c <- pclue
+            cs <- many (spaces >> pclue)
+            return (c:cs)
+
+pclue :: GenParser Char st (Maybe Int)
+pclue = fmap (Just . digitToInt) digit
+        <|> (char '.' >> return Nothing)
+
+showClues :: [Maybe Int] -> String
+showClues = map showClue
+    where showClue = maybe '.' (head . show)
+
+instance Show Row where
+    show (R c True) = 'G' : showClues c
+    show (R c False) = 'W' : showClues c
+
+instance Show Pyramid where
+    show = unlines . map show . unPyr
+
+data KropkiRow = KR { entriesk :: [Maybe Int]
+                    , shadedk  :: Bool
+                    , dotsk    :: [KropkiDot]
+                    }
+    deriving Show
+
+newtype RowKropkiPyramid = KP {unKP :: [KropkiRow]}
+    deriving Show
+
+-- | Forget the kropki dots.
+plainpyramid :: RowKropkiPyramid -> Pyramid
+plainpyramid (KP rows) = Pyr (map r rows)
+    where r x = R (entriesk x) (shadedk x)
+
+pkropkirow :: GenParser Char st KropkiRow
+pkropkirow = do s <- pshaded
+                spaces
+                (ks, cs) <- pkropkiclues
+                return (KR cs s ks)
+
+pkropkiclues :: GenParser Char st ([KropkiDot], [Maybe Int])
+pkropkiclues = do c <- pclue
+                  kcs <- many (liftM2 (,) pkropki pclue)
+                  let (ks, cs) = unzip kcs in return (ks, c:cs)
+
+pkropki :: GenParser Char st KropkiDot
+pkropki = (char '*' >> return Black)
+          <|> (char 'o' >> return White)
+          <|> (char ' ' >> return None)
+
+toParser :: GenParser a () b -> [a] -> Yaml.Parser b
+toParser p v = case parse p "(unknown)" v of Left e  -> fail (show e)
+                                             Right x -> pure x
+
+instance FromJSON Pyramid where
+    parseJSON (String t) = Pyr <$> (mapM (toParser prow . T.unpack) $ T.lines t)
+    parseJSON _          = empty
+
+instance FromJSON RowKropkiPyramid where
+    parseJSON (String t) = KP <$> (mapM (toParser pkropkirow . T.unpack) $ T.lines t)
+    parseJSON _          = empty
+
+instance FromJSON PyramidSol where
+    parseJSON (String t) = PyramidSol <$>
+                           (mapM (toParser pplainrow . T.unpack) $ T.lines t)
+    parseJSON _          = empty
diff --git a/src/Data/Puzzles/Sudoku.hs b/src/Data/Puzzles/Sudoku.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Puzzles/Sudoku.hs
@@ -0,0 +1,36 @@
+module Data.Puzzles.Sudoku (
+    sudokuborders,
+    sudokubordersg
+  ) where
+
+import Data.Puzzles.Grid
+import Data.Puzzles.GridShape hiding (size)
+
+msqrt :: Integral a => a -> Maybe a
+msqrt x = if r ^ (2 :: Int) == x then Just r else Nothing
+    where r = round . (sqrt :: Double -> Double) . fromIntegral $ x
+
+mhalf :: Integral a => a -> Maybe a
+mhalf x = if even x then Just (x `div` 2) else Nothing
+
+-- | Determine the internal borders of a standard sudoku of the
+--   given size.
+sudokuborders :: Int -> [Edge]
+sudokuborders s =
+    case msqrt s of
+        Just r  -> squareborders r
+        Nothing -> case mhalf s of
+                       Just h  -> rectborders h
+                       Nothing -> error "no sudoku layout of this size"
+    where squareborders r = [ E (r*x, y) V | x <- [1..r-1], y <- [0..r*r-1] ]
+                            ++ [ E (x, r*y) H | x <- [0..r*r-1], y <- [1..r-1] ]
+          rectborders h = [ E (h, y) V | y <- [0..2*h-1] ]
+                          ++ [ E (x, 2*y) H | x <- [0..2*h-1], y <- [1..h-1] ]
+
+-- | Determine the internal borders of a standard sudoku of the
+--   on the given grid.
+sudokubordersg :: SGrid a -> [Edge]
+sudokubordersg g = sudokuborders s
+   where (w, h) = size g
+         s | w == h    = w
+           | otherwise = error "non-square sudoku grid?"
diff --git a/src/Diagrams/Puzzles/Draw.hs b/src/Diagrams/Puzzles/Draw.hs
new file mode 100644
--- /dev/null
+++ b/src/Diagrams/Puzzles/Draw.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Diagrams.Puzzles.Draw (
+    PuzzleSol,
+    RenderPuzzle,
+    OutputChoice(..),
+    draw
+  ) where
+
+import Diagrams.Prelude
+
+type RenderPuzzle b p s = (p -> Diagram b R2, (p, s) -> Diagram b R2)
+
+type PuzzleSol b = (Diagram b R2, Maybe (Diagram b R2))
+
+data OutputChoice = DrawPuzzle | DrawSolution | DrawExample
+    deriving Show
+
+-- | Optionally render the puzzle, its solution, or a side-by-side
+--   example with puzzle and solution.
+draw :: (Backend b R2, Renderable (Path R2) b) =>
+        PuzzleSol b -> OutputChoice -> Maybe (Diagram b R2)
+draw (p, ms) = fmap (bg white) . d
+    where d DrawPuzzle   = Just p
+          d DrawSolution = ms
+          d DrawExample  = ms >>= \s -> return $ p ||| strutX 2.0 ||| s
diff --git a/src/Diagrams/Puzzles/Elements.hs b/src/Diagrams/Puzzles/Elements.hs
new file mode 100644
--- /dev/null
+++ b/src/Diagrams/Puzzles/Elements.hs
@@ -0,0 +1,143 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+-- | Module: Diagrams.TwoD.Puzzles.Elements
+--
+-- Tools to draw individual puzzle components. In particular
+-- contents and decorations for individual cells.
+
+module Diagrams.Puzzles.Elements where
+
+import Diagrams.Prelude
+import Diagrams.TwoD.Offset
+
+import Data.Puzzles.Elements
+import Data.Puzzles.GridShape
+
+import Diagrams.Puzzles.Lib
+import Diagrams.Puzzles.Widths
+import Diagrams.Puzzles.Grid
+
+pearl :: (Renderable (Path R2) b, Backend b R2) =>
+         MasyuPearl -> Diagram b R2
+pearl m = circle 0.35 # lw 0.05 # fc (c m)
+  where
+    c MWhite = white
+    c MBlack = black
+
+smallPearl :: (Renderable (Path R2) b, Backend b R2) =>
+              MasyuPearl -> Diagram b R2
+smallPearl = scale 0.4 . pearl
+
+-- | The up-right diagonal of a centered unit square.
+ur :: Path R2
+ur = fromVertices [p2 (-1/2,-1/2), p2 (1/2,1/2)]
+
+-- | The down-right diagonal of a centered unit square.
+dr :: Path R2
+dr = fromVertices [p2 (1/2,-1/2), p2 (-1/2,1/2)]
+
+-- | Both diagonals of a centered unit square.
+cross :: Path R2
+cross = ur <> dr
+
+-- | Draw a cross.
+drawCross :: Renderable (Path R2) b => Diagram b R2
+drawCross = stroke cross # scale 0.8 # lw edgewidth
+
+-- | Draw a Compass clue.
+drawCompassClue :: (Renderable (Path R2) b, Backend b R2) =>
+                   CompassC -> Diagram b R2
+drawCompassClue (CC n e s w) = texts <> stroke cross # lw onepix
+    where tx Nothing _ = mempty
+          tx (Just x) v = text' (show x) # scale 0.5 # translate (r2 v)
+          texts = mconcat . zipWith tx [n, e, s, w] $
+                  [(0,f), (f,0), (0,-f), (-f,0)]
+          f = 3/10
+
+-- | Draw a thermometer, given by a list of bottom-left corners
+-- of square cells.
+thermo :: Renderable (Path R2) b => [P2] -> QDiagram b R2 Any
+thermo vs@(v:_) = (bulb `atop` line) # col # translate (r2 (0.5, 0.5))
+    where bulb = circle 0.4 # moveTo v
+          line = strokeLocLine (fromVertices vs)
+                 # lw 0.55 # lineCap LineCapSquare
+          col = lc gr . fc gr
+          gr = blend 0.6 white black
+thermo [] = error "invalid empty thermometer"
+
+-- | Draw a list of thermometers, given as lists of @(Int, Int)@ cell
+-- coordinates.
+drawThermos :: Renderable (Path R2) b => [Thermometer] -> QDiagram b R2 Any
+drawThermos = mconcat . map (thermo . map p2i)
+
+-- | @drawTight d t@ draws the tight-fit value @t@, using @d@ to
+-- draw the components.
+drawTight :: (Renderable (Path R2) b, Backend b R2) =>
+             (a -> Diagram b R2) -> Tightfit a -> Diagram b R2
+drawTight d (Single x) = d x
+drawTight d (UR x y) = stroke ur # lw onepix
+                       <> d x # scale s # translate (r2 (-t,t))
+                       <> d y # scale s # translate (r2 (t,-t))
+    where t = 1/5
+          s = 2/3
+drawTight d (DR x y) = stroke dr # lw onepix
+                       <> d x # scale s # translate (r2 (-t,-t))
+                       <> d y # scale s # translate (r2 (t,t))
+    where t = 1/5
+          s = 2/3
+
+-- | Stack the given words, left-justified.
+stackWords :: (Backend b R2, Renderable (Path R2) b) => [String] -> QDiagram b R2 Any
+stackWords = vcat' with {_sep = 0.1} . scale 0.8 . map (alignL . text')
+
+-- | Mark a word in a grid of letters.
+drawMarkedWord :: (Renderable (Path R2) b) => MarkedWord -> QDiagram b R2 Any
+drawMarkedWord (MW s e) = lw onepix . stroke $ expandTrail' with {_expandCap = LineCapRound} 0.4 t
+    where t = fromVertices [p2i s, p2i e] # translate (r2 (1/2,1/2))
+
+-- | Apply 'drawMarkedWord' to a list of words.
+drawMarkedWords :: (Renderable (Path R2) b) => [MarkedWord] -> QDiagram b R2 Any
+drawMarkedWords = mconcat . map drawMarkedWord
+
+-- | Draw a slalom clue.
+drawSlalomClue :: (Show a, Renderable (Path R2) b, Backend b R2) =>
+                  a -> Diagram b R2
+drawSlalomClue x = text' (show x) # scale 0.75
+                   <> circle 0.4 # fc white # lw onepix
+
+-- | Draw text. Shouldn't be more than two characters or so to fit a cell.
+drawText :: (Backend b R2, Renderable (Path R2) b) => String -> QDiagram b R2 Any
+drawText = text'
+
+-- | Draw an @Int@.
+drawInt :: (Renderable (Path R2) b, Backend b R2) =>
+           Int -> Diagram b R2
+drawInt s = drawText (show s)
+
+-- | Draw a character.
+drawChar :: (Renderable (Path R2) b, Backend b R2) =>
+            Char -> Diagram b R2
+drawChar c = drawText [c]
+
+-- | Stack a list of words into a unit square. Scaled such that at least
+-- three words will fit.
+drawWords :: (Renderable (Path R2) b, Backend b R2) =>
+             [String] -> Diagram b R2
+drawWords ws = spread (-1.0 *^ unitY)
+                      (map (centerXY . scale 0.4 . drawText) ws)
+               # centerY
+
+-- | Fit a line drawing into a unit square.
+--   For example, a Curve Data clue.
+drawCurve :: Renderable (Path R2) b => [Edge] -> Diagram b R2
+drawCurve = lw onepix . fit 0.6 . centerXY . mconcat . map (stroke . edge)
+
+-- | Draw a shadow in the style of Afternoon Skyscrapers.
+drawShade :: Renderable (Path R2) b => Shade -> Diagram b R2
+drawShade (Shade s w) = (if s then south else mempty) <>
+                        (if w then west else mempty)
+  where
+    shape = translate (r2 (-1/2, -1/2)) . fromVertices . map p2 $
+        [ (0, 0), (1/4, 1/4), (1, 1/4), (1, 0), (0, 0) ]
+    south = strokeLocLoop shape # lw 0 # fc gray
+    west = reflectAbout (p2 (0, 0)) (r2 (1, 1)) south
diff --git a/src/Diagrams/Puzzles/Grid.hs b/src/Diagrams/Puzzles/Grid.hs
new file mode 100644
--- /dev/null
+++ b/src/Diagrams/Puzzles/Grid.hs
@@ -0,0 +1,148 @@
+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
+
+module Diagrams.Puzzles.Grid where
+
+import Data.Char (isUpper)
+
+import Diagrams.Prelude
+
+import Data.Puzzles.Grid
+import Data.Puzzles.GridShape hiding (size, cells)
+
+import Diagrams.Puzzles.Lib
+import Diagrams.Puzzles.Widths
+
+-- | Draw a small black dot with no envelope.
+dot :: (Renderable (Path R2) b, Backend b R2) => Diagram b R2
+dot = circle 0.05 # fc black # smash
+
+-- | Draw a Slither Link style grid of dots of the specified size.
+slithergrid :: (Backend b R2, Renderable (Path R2) b) =>
+               Size -> Diagram b R2
+slithergrid s@(x, y) = dots <> phantom' (border s)
+    where dots = hcatsep . replicate (x + 1) . vcatsep . replicate (y + 1) $ dot
+
+-- | The inner grid lines of a square grid of the specified size.
+gridlines :: Size -> Path R2
+gridlines (w, h) = (decoratePath xaxis . repeat . alignB . vrule . fromIntegral $ h)
+            <> (decoratePath yaxis . repeat . alignL . hrule . fromIntegral $ w)
+    where xaxis = fromVertices [ p2 (fromIntegral x, 0) | x <- [1..w-1] ]
+          yaxis = fromVertices [ p2 (0, fromIntegral y) | y <- [1..h-1] ]
+
+-- | Draw a frame around the outside of a rectangle.
+outframe :: Renderable (Path R2) b => Size -> Diagram b R2
+outframe (w, h) = strokePointLoop r # lw fw
+    where wd = fromIntegral w
+          hd = fromIntegral h
+          strokePointLoop = strokeLocTrail . mapLoc (wrapLoop . closeLine)
+                            . fromVertices . map p2
+          fw = framewidthfactor * gridwidth
+          e = fw / 2 - gridwidth / 2
+          r = [(-e, -e), (wd + e, -e), (wd + e, hd + e), (-e, hd + e)]
+
+-- | Draw a square grid, applying the given style to the grid lines.
+grid' :: (Backend b R2, Renderable (Path R2) b) =>
+         (Diagram b R2 -> Diagram b R2) -> Size -> Diagram b R2
+grid' gridstyle s =
+    outframe s
+    <> stroke (gridlines s) # lw gridwidth # gridstyle
+    <> phantom' (border s)
+
+-- | Draw a square grid with default grid line style.
+grid :: (Backend b R2, Renderable (Path R2) b) =>
+        Size -> Diagram b R2
+grid = grid' id
+
+bgdashing :: (Semigroup a, HasStyle a) =>
+             [Double] -> Double -> Colour Double -> a -> a
+bgdashing ds offs c x = x # dashing ds offs <> x # lc c
+
+dashes :: [Double]
+dashes = [5 / 40, 3 / 40]
+
+dashoffset :: Double
+dashoffset = 2.5 / 40
+
+-- | Draw a square grid with dashed grid lines. The gaps
+--   between dashes are off-white to aid in using filling
+--   tools.
+dashedgrid :: (Backend b R2, Renderable (Path R2) b) =>
+              Size -> Diagram b R2
+dashedgrid = grid' $ bgdashing dashes dashoffset white'
+  where
+    white' = blend 0.95 white black
+
+-- | In a square grid, use the first argument to draw things at the centres
+--   of cells given by coordinates.
+atCentres :: (Transformable a, Monoid a, V a ~ R2) =>
+             (t -> a) -> [(Coord, t)] -> a
+atCentres dc = translate (r2 (0.5, 0.5)) . atVertices dc
+
+atCentres' :: (Transformable a, V a ~ R2) => SGrid a -> [a]
+atCentres' = translate (r2 (1/2, 1/2)) . atVertices'
+
+-- | In a square grid, use the first argument to draw things
+--   at the grid vertices given by coordinates.
+atVertices :: (Transformable a, Monoid a, V a ~ R2) =>
+              (t -> a) -> [(Coord, t)] -> a
+atVertices dc = mconcat . map (\ (p, c) -> dc c # translatep p)
+
+atVertices' :: (Transformable a, V a ~ R2) => SGrid a -> [a]
+atVertices' g = [ (g ! c) # translatep c | c <- cells g ]
+
+-- | Frame a rectangle of the given size with a border of width
+--   'borderwidth'.
+border :: (Backend b R2, Renderable (Path R2) b) => Size -> Diagram b R2
+border (w, h) = stroke . translate (r2 (-bw, -bw)) . alignBL
+               $ rect (fromIntegral w + 2 * bw) (fromIntegral h + 2 * bw)
+  where
+    bw = borderwidth
+
+edge :: Edge -> Path R2
+edge (E c d) = rule d # translate (r2i c)
+  where
+    rule V = vrule 1.0 # alignB
+    rule H = hrule 1.0 # alignL
+
+dualEdge :: Edge -> Path R2
+dualEdge = translate (r2 (1/2, 1/2)) . edge
+
+edgeStyle :: HasStyle a => a -> a
+edgeStyle = lineCap LineCapSquare . lw edgewidth
+
+thinEdgeStyle :: HasStyle a => a -> a
+thinEdgeStyle = lineCap LineCapSquare . lw onepix
+
+drawEdges :: Renderable (Path R2) b => [Edge] -> Diagram b R2
+drawEdges = edgeStyle . stroke . mconcat . map edge
+
+drawDualEdges :: Renderable (Path R2) b => [Edge] -> Diagram b R2
+drawDualEdges = edgeStyle . stroke . mconcat . map dualEdge
+
+drawThinDualEdges :: Renderable (Path R2) b => [Edge] -> Diagram b R2
+drawThinDualEdges = thinEdgeStyle . stroke . mconcat . map dualEdge
+
+drawAreaGrid :: (Backend b R2, Renderable (Path R2) b, Eq a) =>
+                  SGrid a -> Diagram b R2
+drawAreaGrid = drawEdges . borders <> grid . size
+
+fillBG :: (Backend b R2, Renderable (Path R2) b) => Colour Double -> Diagram b R2
+fillBG c = square 1 # fc c
+
+shadeGrid :: (Backend b R2, Renderable (Path R2) b) =>
+              SGrid (Maybe (Colour Double)) -> Diagram b R2
+shadeGrid = mconcat . atCentres' . fmap (maybe mempty fillBG)
+
+drawShadedGrid :: (Backend b R2, Renderable (Path R2) b) =>
+                  SGrid Bool -> Diagram b R2
+drawShadedGrid = shadeGrid . fmap f
+  where
+    f True  = Just gray
+    f False = Nothing
+
+drawAreaGridGray :: (Backend b R2, Renderable (Path R2) b) =>
+                    SGrid Char -> Diagram b R2
+drawAreaGridGray = drawAreaGrid <> shadeGrid . fmap cols
+  where
+    cols c | isUpper c  = Just (blend 0.1 black white)
+           | otherwise  = Nothing
diff --git a/src/Diagrams/Puzzles/Lib.hs b/src/Diagrams/Puzzles/Lib.hs
new file mode 100644
--- /dev/null
+++ b/src/Diagrams/Puzzles/Lib.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
+
+module Diagrams.Puzzles.Lib where
+
+import Diagrams.Prelude
+
+import Graphics.SVGFonts.ReadFont
+
+import Control.Arrow ((***))
+
+-- | Vertical/horizontal stroked line of given length.
+vline, hline :: Renderable (Path R2) b => Double -> Diagram b R2
+vline n = strokeLine . fromVertices . map p2 $ [(0, 0), (0, n)]
+hline n = strokeLine . fromVertices . map p2 $ [(0, 0), (n, 0)]
+
+-- | Variant of 'hcat'' that spreads with distance @1@.
+hcatsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => [a] -> a
+hcatsep = hcat' with {_sep = 1}
+
+-- | Variant of 'vcat'' that spreads with distance @1@,
+-- and stacks towards the top.
+vcatsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => [a] -> a
+vcatsep = cat' (r2 (0,1)) with {_sep = 1}
+
+-- | Collapse the envelope to a point.
+smash :: Backend b R2 => QDiagram b R2 Any -> QDiagram b R2 Any
+smash = withEnvelope (vrule 0 :: D R2)
+
+-- | Helper to translate by a point given as @(Int, Int)@.
+translatep :: (Transformable t, V t ~ R2) => (Int, Int) -> t -> t
+translatep = translate . r2i
+
+-- | Convert pair of @Int@ to vector.
+r2i :: (Int, Int) -> R2
+r2i = r2 . (fromIntegral *** fromIntegral)
+
+-- | Convert pair of @Int@ to point.
+p2i :: (Int, Int) -> P2
+p2i = p2 . (fromIntegral *** fromIntegral)
+
+-- | Interleave two lists.
+interleave :: [a] -> [a] -> [a]
+interleave [] _ = []
+interleave (x:xs) ys = x : interleave ys xs
+
+-- | Spread diagrams evenly along the given vector.
+spread :: (Backend b R2) => R2 -> [Diagram b R2] -> Diagram b R2
+spread v things = cat v . interleave (repeat (strut vgap)) $ things
+    where ds = map (diameter v) things
+          gap' = (magnitude v - sum ds) / fromIntegral (length things + 1)
+          vgap = (gap' / magnitude v) *^ v
+
+dmid ::  (Enveloped a, V a ~ R2) => a -> Double
+dmid a = (dtop + dbot) / 2 - dbot
+    where menv v = magnitude . envelopeV v
+          dtop = menv unitY a
+          dbot = menv ((-1) *^ unitY) a
+
+-- | Place the second diagram to the right of the first, aligning both
+-- vertically. The origin is the origin of the left diagram.
+besidesL :: (Semigroup m, Backend b R2, Monoid m, Renderable (Path R2) b) =>
+            QDiagram b R2 m -> QDiagram b R2 m -> QDiagram b R2 m
+besidesL a b = a ||| strutX 0.5 ||| b'
+    where b' = b # centerY # translate (dmid a *^ unitY)
+
+-- | Variant of 'besidesL' where the origin is that of the right diagram.
+besidesR :: (Semigroup m, Backend b R2, Monoid m, Renderable (Path R2) b) =>
+           QDiagram b R2 m -> QDiagram b R2 m -> QDiagram b R2 m
+besidesR b a =  b' ||| strutX 0.5 ||| a
+    where b' = b # centerY # translate (dmid a *^ unitY)
+
+-- | @fit f a@ scales @a@ to fit into a square of size @f@.
+fit :: (Transformable t, Enveloped t, V t ~ R2) =>
+       Double -> t -> t
+fit f a = scale (f / m) a
+    where m = max (magnitude (diameter unitX a))
+                  (magnitude (diameter unitY a))
+
+-- | Write text that is centered both vertically and horizontally and that
+-- has an envelope. Sized such that single capital characters fit nicely
+-- into a square of size @1@.
+text' :: (Renderable (Path R2) b, Backend b R2) => String -> Diagram b R2
+text' t = stroke (textSVG' $ TextOpts t bit INSIDE_H KERN False 1 1)
+          # lw 0 # fc black # scale 0.8
+
+-- text' t = text t # fontSize 0.8 # font "Helvetica" # translate (r2 (0.04, -0.07))
+--          <> phantom' (textrect t)
+--textrect :: (Renderable (Path R2) b, Backend b R2) => String -> Diagram b R2
+--textrect t = rect (fromIntegral (length t) * 0.4) 0.7 # lc red
+--text'' :: (Renderable (Path R2) b, Backend b R2) => String -> Diagram b R2
+--text'' t = text' t `atop` textrect t
+
+-- | Variant of 'phantom' that forces the argument backend type.
+phantom' :: (Backend b R2) => D R2 -> Diagram b R2
+phantom' = phantom
diff --git a/src/Diagrams/Puzzles/PuzzleGrids.hs b/src/Diagrams/Puzzles/PuzzleGrids.hs
new file mode 100644
--- /dev/null
+++ b/src/Diagrams/Puzzles/PuzzleGrids.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE FlexibleContexts          #-}
+{-# LANGUAGE TypeFamilies              #-}
+
+module Diagrams.Puzzles.PuzzleGrids where
+
+import Diagrams.Prelude
+
+import Data.Puzzles.Grid
+import Data.Puzzles.Elements
+import Data.Puzzles.Sudoku
+
+import Diagrams.Puzzles.Lib
+import Diagrams.Puzzles.Grid
+import Diagrams.Puzzles.Widths
+import Diagrams.Puzzles.Elements
+
+drawFillo :: (Backend b R2, Renderable (Path R2) b) =>
+             SGrid (Clue Int) -> Diagram b R2
+drawFillo = drawIntClues <> dashedgrid . size
+
+drawClueGrid :: (Backend b R2, Renderable (Path R2) b) =>
+                SGrid (Clue Char) -> Diagram b R2
+drawClueGrid = atCentres drawChar . clues <> grid . size
+
+drawIntClues :: (Backend b R2, Renderable (Path R2) b) =>
+                SGrid (Clue Int) -> Diagram b R2
+drawIntClues = atCentres drawInt . clues
+
+drawInts :: (Backend b R2, Renderable (Path R2) b) =>
+            SGrid Int -> Diagram b R2
+drawInts = atCentres drawInt . values
+
+drawIntGrid :: (Backend b R2, Renderable (Path R2) b) =>
+               SGrid (Clue Int) -> Diagram b R2
+drawIntGrid = drawIntClues <> grid . size
+
+drawSlitherGrid :: (Backend b R2, Renderable (Path R2) b) =>
+                   SGrid (Clue Int) -> Diagram b R2
+drawSlitherGrid = atCentres drawInt . clues <> slithergrid . size
+
+drawMasyuGrid :: (Backend b R2, Renderable (Path R2) b) =>
+                 SGrid MasyuClue -> Diagram b R2
+drawMasyuGrid = atCentres pearl . clues <> grid . size
+
+drawCompassClues :: (Backend b R2, Renderable (Path R2) b) =>
+                    SGrid CompassClue -> Diagram b R2
+drawCompassClues = atCentres drawCompassClue . clues
+
+drawCompassGrid :: (Backend b R2, Renderable (Path R2) b) =>
+                   SGrid CompassClue -> Diagram b R2
+drawCompassGrid = drawCompassClues <> grid . size
+
+sudokugrid :: (Backend b R2, Renderable (Path R2) b) =>
+              SGrid a -> Diagram b R2
+sudokugrid = drawEdges . sudokubordersg  <> grid . size
+
+drawWordsClues :: (Backend b R2, Renderable (Path R2) b) =>
+                  SGrid (Clue [String]) -> Diagram b R2
+drawWordsClues = atCentres drawWords . clues
+
+drawTightGrid :: (Backend b R2, Renderable (Path R2) b) =>
+                 (t -> Diagram b R2) -> SGrid (Tightfit t) -> Diagram b R2
+drawTightGrid d g = atCentres (drawTight d) (values g)
+                    <> grid (size g)
+                    <> phantom' (border (sx + 2, sy + 2) # translate (r2 (-1,-1)))
+    where (sx, sy) = size g
+
+drawSlalomGrid :: (Backend b R2, Renderable (Path R2) b) =>
+                  SGrid (Clue Int) -> Diagram b R2
+drawSlalomGrid g = atVertices drawSlalomClue (clues g)
+                   <> grid (w-1, h-1)
+                   <> phantom' (border (size g)) # translate (r2 (-1/2,-1/2))
+    where (w, h) = size g
+
+drawSlalomDiags :: (Backend b R2, Renderable (Path R2) b) =>
+                   SGrid SlalomDiag -> Diagram b R2
+drawSlalomDiags = atCentres diag . clues . fmap Just
+    where diag SlalomForward  = stroke ur # lw edgewidth
+          diag SlalomBackward = stroke dr # lw edgewidth
+
+drawCrosses ::  (Backend b R2, Renderable (Path R2) b) =>
+                 SGrid Bool -> Diagram b R2
+drawCrosses = atCentres (if' drawCross mempty) . values
+  where
+    if' a b x = if x then a else b
diff --git a/src/Diagrams/Puzzles/PuzzleTypes.hs b/src/Diagrams/Puzzles/PuzzleTypes.hs
new file mode 100644
--- /dev/null
+++ b/src/Diagrams/Puzzles/PuzzleTypes.hs
@@ -0,0 +1,179 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Diagrams.Puzzles.PuzzleTypes (
+    lits, litsplus, geradeweg, fillomino, masyu, nurikabe, latintapa,
+    sudoku, thermosudoku, pyramid, kpyramid, slither,
+    liarslither, tightfitskyscrapers, wordloop, wordsearch,
+    curvedata, doubleback, slalom, compass, boxof2or3,
+    afternoonskyscrapers, countnumbers,
+  ) where
+
+import Diagrams.Prelude hiding (Loop)
+
+import Diagrams.Puzzles.PuzzleGrids
+import Diagrams.Puzzles.Draw
+import Diagrams.Puzzles.Grid
+import qualified Diagrams.Puzzles.Pyramid as DPyr
+import Diagrams.Puzzles.Elements
+import Diagrams.Puzzles.Lib
+
+import Data.Puzzles.Grid
+import Data.Puzzles.GridShape (Edge)
+import Data.Puzzles.Elements
+import qualified Data.Puzzles.Pyramid as Pyr
+
+lits :: (Backend b R2, Renderable (Path R2) b) => RenderPuzzle b AreaGrid ShadedGrid
+lits = (,)
+    drawAreaGridGray
+    (drawAreaGrid . fst <> drawShadedGrid . snd)
+
+litsplus :: (Backend b R2, Renderable (Path R2) b) => RenderPuzzle b AreaGrid ShadedGrid
+litsplus = lits
+
+solstyle :: HasStyle a => a -> a
+solstyle = lc (blend 0.8 black white)
+
+geradeweg :: (Backend b R2, Renderable (Path R2) b) => RenderPuzzle b IntGrid Loop
+geradeweg = (,)
+    drawIntGrid
+    (drawIntClues . fst
+     <> solstyle . drawDualEdges . snd
+     <> grid . size . fst)
+
+fillomino :: (Backend b R2, Renderable (Path R2) b) => RenderPuzzle b IntGrid IntGrid
+fillomino = (,)
+    drawFillo
+    (drawFillo . snd)
+
+masyu :: (Backend b R2, Renderable (Path R2) b) =>
+         RenderPuzzle b (SGrid (Clue MasyuPearl)) Loop
+masyu = (,)
+    drawMasyuGrid
+    (solstyle . drawDualEdges . snd <> drawMasyuGrid . fst)
+
+nurikabe :: (Backend b R2, Renderable (Path R2) b) =>
+            RenderPuzzle b IntGrid ShadedGrid
+nurikabe = (,)
+    drawIntGrid
+    (drawIntGrid . fst <> drawShadedGrid . snd)
+
+latintapa :: (Backend b R2, Renderable (Path R2) b) =>
+             RenderPuzzle b (SGrid (Clue [String])) CharClueGrid
+latintapa = (,)
+    l
+    (l . fst <> atCentres drawChar . clues . snd)
+  where
+    l = grid . size <> drawWordsClues
+
+sudoku :: (Backend b R2, Renderable (Path R2) b) =>
+          RenderPuzzle b IntGrid IntGrid
+sudoku = (,)
+    (drawIntClues <> sudokugrid)
+    ((drawIntClues <> sudokugrid) . snd)
+
+thermosudoku :: (Backend b R2, Renderable (Path R2) b) =>
+                RenderPuzzle b (SGrid Int, [Thermometer]) IntGrid
+thermosudoku = (,)
+    (drawInts . fst <> sudokugrid . fst <> drawThermos . snd)
+    (drawIntClues . snd <> sudokugrid . snd <> drawThermos . snd . fst)
+
+pyramid :: (Backend b R2, Renderable (Path R2) b) =>
+    RenderPuzzle b Pyr.Pyramid Pyr.PyramidSol
+pyramid = (,)
+    DPyr.pyramid
+    (DPyr.pyramid . merge)
+  where
+    merge (p, q) = Pyr.mergepyramidsol p q
+
+kpyramid :: (Backend b R2, Renderable (Path R2) b) =>
+    RenderPuzzle b Pyr.RowKropkiPyramid Pyr.PyramidSol
+kpyramid = (,)
+    DPyr.kpyramid
+    (DPyr.kpyramid . merge)
+  where
+    merge (p, q) = Pyr.mergekpyramidsol p q
+
+slither :: (Backend b R2, Renderable (Path R2) b) =>
+           RenderPuzzle b IntGrid Loop
+slither = (,)
+    drawSlitherGrid
+    (drawSlitherGrid . fst <> solstyle . drawEdges . snd)
+
+liarslither :: (Backend b R2, Renderable (Path R2) b) =>
+               RenderPuzzle b IntGrid (Loop, SGrid Bool)
+liarslither = (,)
+    drawSlitherGrid
+    (solstyle . drawCrosses . snd . snd
+     <> drawSlitherGrid . fst
+     <> solstyle . drawEdges . fst . snd)
+
+tightfitskyscrapers :: (Backend b R2, Renderable (Path R2) b) =>
+                       RenderPuzzle b (OutsideClues (Maybe Int), SGrid (Tightfit ()))
+                                      (SGrid (Tightfit Int))
+tightfitskyscrapers = (,)
+    (atCentres drawInt . outsideclues . fst
+     <> drawTightGrid (const mempty) . snd)
+    (atCentres drawInt . outsideclues . fst . fst
+     <> drawTightGrid drawInt . snd)
+
+wordgrid :: (Backend b R2, Renderable (Path R2) b) =>
+            SGrid (Maybe Char) -> [String] -> Diagram b R2
+wordgrid g ws = stackWords ws `besidesR` drawClueGrid g
+
+wordloop :: (Backend b R2, Renderable (Path R2) b) =>
+            RenderPuzzle b (CharClueGrid, [String]) CharClueGrid
+wordloop = (,)
+    (uncurry wordgrid)
+    (drawClueGrid . snd)
+
+wordsearch :: (Backend b R2, Renderable (Path R2) b) =>
+              RenderPuzzle b (CharClueGrid, [String]) (CharClueGrid, [MarkedWord])
+wordsearch = (,)
+    (uncurry wordgrid) 
+    (solstyle . drawMarkedWords . snd . snd
+     <> drawClueGrid . fst . snd)
+
+curvedata :: (Backend b R2, Renderable (Path R2) b) =>
+             RenderPuzzle b (SGrid (Clue [Edge])) [Edge]
+curvedata = (,)
+    cd
+    ((solstyle . drawDualEdges . snd) <> cd . fst)
+    where cd = (atCentres drawCurve . clues <> grid . size)
+
+doubleback :: (Backend b R2, Renderable (Path R2) b) =>
+              RenderPuzzle b AreaGrid Loop
+doubleback = (,)
+    drawAreaGridGray
+    (solstyle . drawDualEdges . snd <> drawAreaGridGray . fst)
+
+slalom :: (Backend b R2, Renderable (Path R2) b) =>
+          RenderPuzzle b IntGrid (SGrid SlalomDiag)
+slalom = (,)
+    drawSlalomGrid
+    (drawSlalomGrid . fst <> solstyle . drawSlalomDiags . snd)
+
+compass :: (Backend b R2, Renderable (Path R2) b) =>
+           RenderPuzzle b (SGrid (Clue CompassC)) AreaGrid
+compass = (,)
+    drawCompassGrid
+    (drawCompassClues . fst <> drawAreaGridGray . snd)
+
+boxof2or3 :: (Backend b R2, Renderable (Path R2) b) =>
+             RenderPuzzle b (SGrid MasyuPearl, [Edge]) ()
+boxof2or3 = (,)
+    (atCentres smallPearl . values . fst
+     <> phantom' . grid . size . fst
+     <> drawThinDualEdges . snd)
+    (error "boxof2or3 solution not implemented")
+
+afternoonskyscrapers :: (Backend b R2, Renderable (Path R2) b) =>
+                        RenderPuzzle b (SGrid Shade) IntGrid
+afternoonskyscrapers = (,)
+    (grid . size <> atCentres drawShade . values)
+    (drawIntGrid . snd <> atCentres drawShade . values . fst)
+
+countnumbers :: (Backend b R2, Renderable (Path R2) b) =>
+                        RenderPuzzle b AreaGrid IntGrid
+countnumbers = (,)
+    drawAreaGrid
+    (drawIntGrid . snd <> drawAreaGrid . fst)
diff --git a/src/Diagrams/Puzzles/Pyramid.hs b/src/Diagrams/Puzzles/Pyramid.hs
new file mode 100644
--- /dev/null
+++ b/src/Diagrams/Puzzles/Pyramid.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Diagrams.Puzzles.Pyramid where
+
+import Diagrams.Prelude
+
+import Data.Puzzles.Elements
+import Data.Puzzles.Pyramid
+import Diagrams.Puzzles.Lib
+import Diagrams.Puzzles.Widths
+import Diagrams.Puzzles.Grid (border)
+
+pgray :: Colour Double
+pgray = blend 0.6 white black
+
+cell :: (Backend b R2, Renderable (Path R2) b) => Bool -> Diagram b R2
+cell s = square 1 # lw onepix # if s then fc pgray else id
+
+clue :: (Backend b R2, Renderable (Path R2) b) => Maybe Int -> Diagram b R2
+clue Nothing = mempty
+clue (Just c) = text' (show c)
+
+cellc :: (Backend b R2, Renderable (Path R2) b) => Bool -> Maybe Int -> Diagram b R2
+cellc s c = clue c `atop` cell s
+
+row :: (Backend b R2, Renderable (Path R2) b) => Row -> Diagram b R2
+row (R cs s) = centerX . hcat . map (cellc s) $ cs
+
+pyramid :: (Backend b R2, Renderable (Path R2) b) => Pyramid -> Diagram b R2
+pyramid p = phantom' (border (s, s)) <> (alignBL . vcat . map row . unPyr $ p)
+    where s = psize p
+
+kropki :: (Backend b R2, Renderable (Path R2) b) => KropkiDot -> Diagram b R2
+kropki None = mempty
+kropki c = circle 0.1 # lw 0.03 # fc (col c) # smash
+    where col White = white
+          col Black = blend 0.98 black white
+          col None  = error "can't reach"
+
+krow :: (Backend b R2, Renderable (Path R2) b) => KropkiRow -> Diagram b R2
+krow (KR cs s ks) = ccat dots <> ccat clues
+    where ccat = centerX . hcat
+          clues = map (cellc s) cs
+          clues' = map (cellc s) cs :: [D R2]
+          dots = interleave (map phantom' clues') (map kropki ks)
+
+kpyramid :: (Backend b R2, Renderable (Path R2) b) => RowKropkiPyramid -> Diagram b R2
+kpyramid p = phantom' (border (s, s)) <> (alignBL . vcat . map krow . unKP $ p)
+    where s = psize (plainpyramid p)
diff --git a/src/Diagrams/Puzzles/Widths.hs b/src/Diagrams/Puzzles/Widths.hs
new file mode 100644
--- /dev/null
+++ b/src/Diagrams/Puzzles/Widths.hs
@@ -0,0 +1,21 @@
+module Diagrams.Puzzles.Widths where
+
+gridres :: Int
+gridres = 40
+
+onepix :: Double
+onepix = 1 / fromIntegral gridres
+
+twopix, fourpix :: Double
+twopix = 2 * onepix
+fourpix = 4 * onepix
+
+gridwidth :: Double
+gridwidth = onepix
+
+framewidthfactor :: Double
+framewidthfactor = 4
+
+edgewidth, borderwidth :: Double
+edgewidth = 3 * onepix
+borderwidth = 1 / 4 + onepix / 2
diff --git a/src/Text/Puzzles/Puzzle.hs b/src/Text/Puzzles/Puzzle.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/Puzzles/Puzzle.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Text.Puzzles.Puzzle where
+
+import Data.Yaml
+import Control.Applicative
+
+import Data.Puzzles.PuzzleTypes
+
+data TypedPuzzle = TP (Maybe String) Value (Maybe Value)
+    deriving Show
+
+instance FromJSON TypedPuzzle where
+    parseJSON (Object v) = TP <$>
+                           v .:? "type" <*>
+                           v .:  "puzzle" <*>
+                           v .:? "solution"
+    parseJSON _          = empty
+
+-- | A pair of parsers for a puzzle type.
+-- First parses the puzzle, second the solution.
+type ParsePuzzle a b = (Value -> Parser a, Value -> Parser b)
+
+parseType :: String -> Parser PuzzleType
+parseType t = case lookupType t of
+                  Nothing -> fail $ "unknown puzzle type: " ++ t
+                  Just p  -> return p
diff --git a/src/Text/Puzzles/PuzzleTypes.hs b/src/Text/Puzzles/PuzzleTypes.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/Puzzles/PuzzleTypes.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Text.Puzzles.PuzzleTypes (
+    lits, litsplus, geradeweg, fillomino, masyu, nurikabe, latintapa,
+    sudoku, thermosudoku, pyramid, kpyramid, slither,
+    liarslither, tightfitskyscrapers, wordloop, wordsearch,
+    curvedata, doubleback, slalom, compass, boxof2or3,
+    afternoonskyscrapers, countnumbers,
+  ) where
+
+import Prelude hiding (sequence)
+
+import Control.Applicative
+import Control.Monad hiding (sequence)
+
+import Data.Yaml
+
+import Text.Puzzles.Util
+import Text.Puzzles.Puzzle
+import Data.Puzzles.Grid
+import Data.Puzzles.GridShape hiding (size)
+import qualified Data.Puzzles.Pyramid as Pyr
+import Data.Puzzles.Elements
+
+lits :: ParsePuzzle AreaGrid ShadedGrid
+lits = (parseGrid, parseShadedGrid)
+
+litsplus :: ParsePuzzle AreaGrid ShadedGrid
+litsplus = lits
+
+geradeweg :: ParsePuzzle (SGrid (Clue Int)) Loop
+geradeweg = (parseClueGrid, parseEdges)
+
+fillomino :: ParsePuzzle IntGrid IntGrid
+fillomino = (parseClueGrid, parseClueGrid)
+
+masyu :: ParsePuzzle (SGrid (Clue MasyuPearl)) Loop
+masyu = (parseClueGrid, parseEdges)
+
+nurikabe :: ParsePuzzle IntGrid ShadedGrid
+nurikabe = (parseSpacedClueGrid, parseShadedGrid)
+
+latintapa :: ParsePuzzle (SGrid (Clue [String])) (SGrid (Maybe Char))
+latintapa = ((unRG <$>) . parseJSON, parseClueGrid)
+
+sudoku :: ParsePuzzle IntGrid IntGrid
+sudoku = (parseClueGrid, parseClueGrid)
+
+thermosudoku :: ParsePuzzle (SGrid Int, [Thermometer]) IntGrid
+thermosudoku = ((parseThermoGrid =<<) . parseJSON, parseClueGrid)
+
+pyramid :: ParsePuzzle Pyr.Pyramid Pyr.PyramidSol
+pyramid = (parseJSON, parseJSON)
+
+kpyramid :: ParsePuzzle Pyr.RowKropkiPyramid Pyr.PyramidSol
+kpyramid = (parseJSON, parseJSON)
+
+slither :: ParsePuzzle (SGrid (Clue Int)) Loop
+slither = (parseClueGrid, parseEdges)
+
+newtype LSol = LSol { unLSol :: (Loop, SGrid Bool) }
+instance FromJSON LSol where
+    parseJSON (Object v) = LSol <$> ((,) <$>
+                           (parseEdges =<< v .: "loop") <*>
+                           (parseShadedGrid =<< v .: "liars"))
+    parseJSON _          = mzero
+
+liarslither :: ParsePuzzle (SGrid (Clue Int)) (Loop, SGrid Bool)
+liarslither = (parseClueGrid, (unLSol <$>) . parseJSON)
+
+tightfitskyscrapers :: ParsePuzzle
+                       (OutsideClues (Maybe Int), SGrid (Tightfit ()))
+                       (SGrid (Tightfit Int))
+tightfitskyscrapers = (parseTightOutside, parseTightIntGrid)
+
+newtype GridWords = GW { unGW :: (CharClueGrid, [String]) }
+
+instance FromJSON GridWords where
+    parseJSON (Object v) = GW <$> ((,) <$>
+                                   (parseClueGrid =<< v .: "grid") <*>
+                                   v .: "words")
+    parseJSON _ = empty
+
+wordloop :: ParsePuzzle (CharClueGrid, [String]) CharClueGrid
+wordloop = ((unGW <$>) . parseJSON, parseClueGrid)
+
+newtype GridMarked = GM { unGM :: (CharClueGrid, [MarkedWord]) }
+
+instance FromJSON GridMarked where
+    parseJSON (Object v) = GM <$> ((,) <$>
+                                   (parseClueGrid =<< v .: "grid") <*>
+                                   (map unPMW <$> v .: "words"))
+    parseJSON _          = mzero
+
+wordsearch :: ParsePuzzle (CharClueGrid, [String]) (CharClueGrid, [MarkedWord])
+wordsearch = ((unGW <$>) . parseJSON, (unGM <$>) . parseJSON)
+
+newtype Curve = Curve { unCurve :: [Edge] }
+
+instance FromJSON Curve where
+    parseJSON v = Curve <$> parsePlainEdges v
+
+curvedata :: ParsePuzzle (SGrid (Clue [Edge])) [Edge]
+curvedata = ((fmap (fmap unCurve) . unRG <$>) . parseJSON, parsePlainEdges)
+
+doubleback :: ParsePuzzle AreaGrid Loop
+doubleback = (parseGrid, parseEdges)
+
+slalom :: ParsePuzzle (SGrid (Clue Int)) (SGrid SlalomDiag)
+slalom = (parseClueGrid, \v -> rectToSGrid <$> parseJSON v)
+
+compass :: ParsePuzzle (SGrid (Clue CompassC)) CharGrid
+compass = ((fmap (fmap unPCC) . unRG <$>) . parseJSON, parseGrid)
+
+boxof2or3 :: ParsePuzzle (SGrid MasyuPearl, [Edge]) ()
+boxof2or3 = (parseNodeEdges, error "boxof2or3 parsing not implemented")
+
+afternoonskyscrapers :: ParsePuzzle (SGrid Shade) IntGrid
+afternoonskyscrapers = (parseAfternoonGrid, parseGrid)
+
+-- this should be changed to support clue numbers
+countnumbers :: ParsePuzzle AreaGrid IntGrid
+countnumbers = (parseGrid, parseGrid)
diff --git a/src/Text/Puzzles/Util.hs b/src/Text/Puzzles/Util.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/Puzzles/Util.hs
@@ -0,0 +1,396 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Text.Puzzles.Util where
+
+import Prelude hiding (sequence)
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad hiding (sequence)
+
+import Data.Hashable
+import Data.Maybe (catMaybes)
+import qualified Data.Map as Map
+import qualified Data.HashMap.Strict as HMap
+import Data.Traversable (traverse, sequence, sequenceA, Traversable)
+import Data.Foldable (Foldable, fold)
+import Data.Monoid ((<>))
+import Data.List (intersect)
+
+import Data.Char (digitToInt, isAlpha, isDigit)
+import Text.Read (readMaybe)
+import qualified Data.Text as T
+
+import Data.Yaml
+
+import Data.Puzzles.Grid
+import Data.Puzzles.GridShape hiding (size)
+import Data.Puzzles.Elements
+
+class FromChar a where
+    parseChar :: Char -> Parser a
+
+instance FromChar Char where
+    parseChar = pure
+
+class FromString a where
+    parseString :: String -> Parser a
+
+instance FromChar Int where
+    parseChar c
+        | isDigit c  = digitToInt <$> parseChar c
+        | otherwise  = fail $ "expected a digit, got '" ++ [c] ++ "'"
+
+newtype Alpha = Alpha { unAlpha :: Char }
+    deriving (Show, Ord, Eq)
+
+instance FromChar Alpha where
+    parseChar c
+        | isAlpha c  = Alpha <$> parseChar c
+        | otherwise  = empty
+
+-- | A rectangle. Each row has length `w`.
+data Rect a = Rect !Int !Int [[a]]
+    deriving Show
+
+instance Functor Rect where
+    fmap f (Rect w h ls) = Rect w h (map (map f) ls)
+
+instance FromChar a => FromJSON (Rect a) where
+    parseJSON (String t) = Rect w h <$> filled
+      where
+        ls = map T.stripEnd . T.lines $ t
+        w = maximum . map T.length $ ls
+        h = length ls
+        filledc = map (T.unpack . T.justifyLeft w ' ') ls
+        filled = sequence . map (mapM parseChar) $ filledc
+    parseJSON _          = empty
+
+data Border a = Border [a] [a] [a] [a]
+    deriving Show
+
+-- | This instance might be a lie.
+instance Foldable Border where
+    fold (Border l r b t) = fold l <> fold r <> fold b <> fold t
+
+instance Traversable Border where
+    sequenceA (Border l r b t) = Border <$> sequenceA l
+                                        <*> sequenceA r
+                                        <*> sequenceA b
+                                        <*> sequenceA t
+
+instance Functor Border where
+    f `fmap` (Border l r b t) = Border (f <$> l) (f <$> r) (f <$> b) (f <$> t)
+
+data BorderedRect a b = BorderedRect !Int !Int [[a]] (Border b)
+    deriving Show
+
+instance (FromChar a, FromChar b) => FromJSON (BorderedRect a b) where
+    parseJSON v = do
+        Rect w h ls <- parseJSON v
+        let b = Border (reverse . map head . middle h $ ls)
+                       (reverse . map last . middle h $ ls)
+                       (middle w . last $ ls)
+                       (middle w . head $ ls)
+            ls' = map (middle w) . middle h $ ls
+        mapM_ ((parseChar :: Char -> Parser Space) . flip ($) ls)
+              [head . head, head . last, last . head, last . last]
+        lsparsed <- sequence . map (mapM parseChar) $ ls'
+        bparsed  <- sequenceA . fmap parseChar $ b
+        return $ BorderedRect (w-2) (h-2) lsparsed bparsed
+      where
+        middle len = take (len - 2) . drop 1
+
+newtype SpacedRect a = SpacedRect { unSpaced :: Rect a }
+
+instance FromString a => FromJSON (SpacedRect a) where
+    parseJSON (String t) = if w == wmin then SpacedRect . Rect w h <$> p
+                                        else empty
+      where
+        ls = map T.words . T.lines $ t
+        w = maximum . map length $ ls
+        wmin = minimum . map length $ ls
+        h = length ls
+        p = sequence . map (mapM (parseString . T.unpack)) $ ls
+    parseJSON _          = empty
+
+instance FromChar MasyuPearl where
+    parseChar '*' = pure MBlack
+    parseChar 'o' = pure MWhite
+    parseChar _   = empty
+
+data Space = Space
+
+instance FromChar Space where
+    parseChar ' ' = pure Space
+    parseChar _   = empty
+
+data Blank = Blank
+
+instance FromChar Blank where
+    parseChar '.' = pure Blank
+    parseChar '-' = pure Blank
+    parseChar _   = empty
+
+instance FromString Blank where
+    parseString "." = pure Blank
+    parseString "-" = pure Blank
+    parseString _   = empty
+
+instance FromChar SlalomDiag where
+    parseChar '/'  = pure SlalomForward
+    parseChar '\\' = pure SlalomBackward
+    parseChar _    = empty
+
+instance (FromChar a, FromChar b) => FromChar (Either a b) where
+    parseChar c = Left <$> parseChar c <|> Right <$> parseChar c
+
+instance (FromString a, FromString b) => FromString (Either a b) where
+    parseString c = Left <$> parseString c <|> Right <$> parseString c
+
+instance FromChar a => FromChar (Maybe a) where
+    parseChar = optional . parseChar
+
+listListToMap :: [[a]] -> Map.Map (Cell Square) a
+listListToMap ls = Map.fromList . concat
+                 . zipWith (\y -> zipWith (\x -> (,) (x, y)) [0..]) [h-1,h-2..]
+                 $ ls
+  where
+    h = length ls
+
+rectToSGrid :: Rect a -> SGrid a
+rectToSGrid (Rect w h ls) = Grid (Square w h) (listListToMap ls)
+
+rectToClueGrid :: Rect (Either Blank a) -> SGrid (Clue a)
+rectToClueGrid = fmap (either (const Nothing) Just) . rectToSGrid
+
+newtype Shaded = Shaded { unShaded :: Bool }
+
+instance FromChar Shaded where
+    parseChar 'x'  = pure . Shaded $ True
+    parseChar 'X'  = pure . Shaded $ True
+    parseChar _    = pure . Shaded $ False
+
+parseShadedGrid :: Value -> Parser (SGrid Bool)
+parseShadedGrid v = rectToSGrid . fmap unShaded <$> parseJSON v
+
+parseGrid :: FromChar a => Value -> Parser (SGrid a)
+parseGrid v = rectToSGrid <$> parseJSON v
+
+parseClueGrid :: FromChar a => Value -> Parser (SGrid (Clue a))
+parseClueGrid v = rectToClueGrid <$> parseJSON v
+
+parseSpacedClueGrid :: FromString a => Value -> Parser (SGrid (Clue a))
+parseSpacedClueGrid v = rectToClueGrid . unSpaced <$> parseJSON v
+
+-- parses a string like
+--  o-o-o
+--  |   |
+--  o-o o
+--    | |
+--    o-o
+parsePlainEdges :: Value -> Parser [Edge]
+parsePlainEdges v = readEdges <$> parseGrid v
+
+readEdges :: SGrid Char -> [Edge]
+readEdges g = horiz ++ vert
+    where (w, h) = size g
+          w' = w `div` 2
+          h' = h `div` 2
+          isHoriz (x, y) = g ! (2 * x + 1, 2 * y) == '-'
+          isVert  (x, y) = g ! (2 * x, 2 * y + 1) == '|'
+          horiz = [ E (x, y) H | x <- [0 .. w' - 1]
+                               , y <- [0 .. h']
+                               , isHoriz (x, y)
+                               ]
+          vert =  [ E (x, y) V | x <- [0 .. w']
+                               , y <- [0 .. h' - 1]
+                               , isVert (x, y)
+                               ]
+
+parseGridChars :: FromChar a => SGrid Char -> Parser (SGrid a)
+parseGridChars = traverse parseChar
+
+-- | Parse a grid of edges with values at the nodes.
+--
+-- E.g. o-*-*-o
+--      | |
+--      *-o
+-- to a grid of masyu pearls and some edges.
+parseNodeEdges :: FromChar a =>
+                  Value -> Parser (SGrid a, [Edge])
+parseNodeEdges v = (,) <$>
+                   (parseGridChars =<< halveGrid =<< parseGrid v) <*>
+                   parsePlainEdges v
+  where
+    halveGrid (Grid (Square w h) m)
+        | odd w && odd h = pure $ Grid s' m'
+        | otherwise      = empty
+      where
+        s' = Square ((w + 1) `div` 2) ((h + 1) `div` 2)
+        m' = Map.mapKeys (both (`div` 2))
+           . Map.filterWithKey (const . (uncurry (&&) . both even))
+           $ m
+        both f (x, y) = (f x, f y)
+
+data HalfDirs = HalfDirs {unHalfDirs :: [Dir]}
+
+instance FromChar HalfDirs where
+    parseChar c | c == '└'        = pure . HalfDirs $ [V, H]
+                | c `elem` "│┘"   = pure . HalfDirs $ [V]
+                | c `elem` "─└┌"  = pure . HalfDirs $ [H]
+                | otherwise       = pure . HalfDirs $ []
+
+-- parses a string like
+--  ┌┐┌─┐
+--  ││└┐│
+--  │└─┘│
+--  └──┐│
+--     └┘
+parseEdges :: Value -> Parser [Edge]
+parseEdges v = do
+    Grid _ m <- rectToSGrid . fmap unHalfDirs <$> parseJSON v
+    return [ E p d | (p, ds) <- Map.toList m, d <- ds ]
+
+type ThermoRect = Rect (Either Blank (Either Int Alpha))
+
+partitionEithers :: Ord k => Map.Map k (Either a b) -> (Map.Map k a, Map.Map k b)
+partitionEithers = Map.foldrWithKey insertEither (Map.empty, Map.empty)
+  where
+    insertEither k = either (first . Map.insert k) (second . Map.insert k)
+
+parseThermos :: SGrid Alpha -> Parser [Thermometer]
+parseThermos (Grid s m) = catMaybes <$> mapM parseThermo (Map.keys m)
+  where
+    m' = fmap unAlpha m
+    parseThermo :: Cell Square -> Parser (Maybe Thermometer)
+    parseThermo p | not (isStart p)           = pure Nothing
+                  | not (isAlmostIsolated p)  = fail $ show p ++ " not almost isolated"
+                  | otherwise                 = Just <$> parseThermo' p
+    parseThermo' :: Cell Square -> Parser Thermometer
+    parseThermo' p = do
+        q <- next p
+        maybe (fail "no succ for thermo bulb") (fmap (p:) . parseThermo'') q
+    parseThermo'' :: Cell Square -> Parser Thermometer
+    parseThermo'' p = do
+        q <- next p
+        maybe (pure [p]) (fmap (p:) . parseThermo'') q
+    next :: Cell Square -> Parser (Maybe (Cell Square))
+    next p = case succs p of
+        []   -> pure Nothing
+        [q]  -> pure (Just q)
+        _    -> fail "multiple successors"
+    succs      p = filter    (test ((==) . succ) p) . neighbours s $ p
+    isStart    p = not . any (test ((==) . pred) p) . neighbours s $ p
+    test f p q = maybe False (f (m' Map.! p)) (Map.lookup q m')
+    isAlmostIsolated p = all disjointSucc . neighbours s $ p
+      where
+        disjointSucc q = null $ intersect (succs p) (succs' q)
+        succs' q = maybe [] (const $ succs q) (Map.lookup q m')
+
+parseThermoGrid :: ThermoRect -> Parser (SGrid Int, [Thermometer])
+parseThermoGrid (Rect w h ls) = (,) (Grid s ints) <$>
+                                (parseThermos $ Grid s alphas)
+  where
+    s = Square w h
+    (ints, alphas) = partitionEithers . snd . partitionEithers $
+                     listListToMap ls
+
+newtype Tight = Tight { unTight :: Tightfit () }
+
+instance FromChar Tight where
+    parseChar '.'  = pure . Tight $ Single ()
+    parseChar '/'  = pure . Tight $ UR () ()
+    parseChar '\\' = pure . Tight $ DR () ()
+    parseChar _    = empty
+
+parseTightOutside :: Value -> Parser (OutsideClues (Maybe Int),
+                                      SGrid (Tightfit ()))
+parseTightOutside v = do
+    BorderedRect w h ls b <- parseJSON v
+        :: Parser (BorderedRect Tight (Either Blank Int))
+    return (outside . fmap (either (const Nothing) Just) $ b,
+            fmap unTight . rectToSGrid $ Rect w h ls)
+  where outside (Border l r b t) = OC l r b t
+
+instance FromChar a => FromString (Tightfit a) where
+    parseString [c]           = Single <$> parseChar c
+    parseString (c: '/':d:[]) = UR <$> parseChar c <*> parseChar d
+    parseString (c:'\\':d:[]) = DR <$> parseChar c <*> parseChar d
+    parseString _             = empty
+
+parseTightIntGrid :: Value -> Parser (SGrid (Tightfit Int))
+parseTightIntGrid v = rectToSGrid . unSpaced <$> parseJSON v
+
+newtype PMarkedWord = PMW {unPMW :: MarkedWord}
+
+parseNWords :: Int -> String -> Parser [String]
+parseNWords n s | length ws == n  = pure ws
+                | otherwise       = empty
+  where
+    ws = words s
+
+instance FromJSON PMarkedWord where
+    parseJSON v = PMW <$> (MW <$>
+                  ((,) <$> ((!!0) <$> x) <*> ((!!1) <$> x)) <*>
+                  ((,) <$> ((!!2) <$> x) <*> ((!!3) <$> x)))
+        where x = parseJSON v >>= parseNWords 4 >>= mapM parseString
+
+instance FromString Int where
+    parseString s = maybe empty pure $ readMaybe s
+
+newtype PCompassC = PCC {unPCC :: CompassC}
+
+instance FromJSON PCompassC where
+    parseJSON (String t) = comp . map T.unpack . T.words $ t
+        where c "." = pure Nothing
+              c x   = Just <$> parseString x
+              comp [n, e, s, w] = PCC <$> (CC <$> c n <*> c e <*> c s <*> c w)
+              comp _            = empty
+    parseJSON _          = empty
+
+newtype RefGrid a = RefGrid { unRG :: SGrid a }
+
+data Ref = Ref { unRef :: Char }
+    deriving Show
+
+instance FromChar Ref where
+    parseChar c | isAlpha c = pure (Ref c)
+    parseChar _             = empty
+
+hashmaptomap :: (Eq a, Hashable a, Ord a) => HMap.HashMap a b -> Map.Map a b
+hashmaptomap = Map.fromList . HMap.toList
+
+compose :: (Ord a, Ord b) => Map.Map a b -> Map.Map b c -> Maybe (Map.Map a c)
+compose m1 m2 = sequence . Map.map (flip Map.lookup m2) $ m1
+
+instance FromJSON a => FromJSON (RefGrid a) where
+    parseJSON (Object v) = RefGrid <$> do
+        Grid s refs <- fmap (fmap ((:[]) . unRef)) . rectToClueGrid <$>
+                       (v .: "grid" :: Parser (Rect (Either Blank Ref)))
+        m <- hashmaptomap <$> v .: "clues"
+        case compose (Map.mapMaybe id refs) m of
+            Nothing -> mzero
+            Just m' -> return $ Grid s m'
+    parseJSON _ = empty
+
+parseAfternoonGrid :: Value -> Parser (SGrid Shade)
+parseAfternoonGrid v = do
+    (Grid s _ , es) <- parseNodeEdges v :: Parser (SGrid Char, [Edge])
+    let (m, b) = splitBorder s $ toMap es
+    guard $ Map.null b
+    return $ Grid (shrink s) m
+  where
+    shrink (Square w h) = Square (w-1) (h-1)
+    toShade V = Shade False True
+    toShade H = Shade True  False
+    merge (Shade a b) (Shade c d)
+        | a && c || b && d  = error "shading collision"
+        | otherwise         = Shade (a || c) (b || d)
+    toMap es = Map.fromListWith
+        merge
+        [(p, toShade d) | E p d <- es]
+    splitBorder (Square w h) = Map.partitionWithKey
+        (\(x, y) _ -> x < w - 1 && y < h - 1)
+
+
diff --git a/tests/tests.hs b/tests/tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/tests.hs
@@ -0,0 +1,325 @@
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Data.Yaml
+import qualified Data.ByteString.Char8 as B
+import Data.Maybe (fromJust)
+import Data.List (sort)
+
+import Control.DeepSeq
+
+import Data.Puzzles.Elements (Thermometer)
+import Text.Puzzles.Util (parseChar)
+import Text.Puzzles.PuzzleTypes
+import qualified Data.Puzzles.Grid as Grid
+import Data.Puzzles.Pyramid (PyramidSol(..))
+
+import Diagrams.Puzzles.PuzzleGrids
+import Diagrams.Prelude
+import Diagrams.Backend.SVG
+
+import Text.Blaze.Svg.Renderer.Text (renderSvg)
+import qualified Data.Text as T
+
+main :: IO ()
+main = defaultMain tests
+
+tests :: TestTree
+tests = testGroup "Tests" [unitTests]
+
+decodeLines :: [String] -> Value
+decodeLines = fromJust . decode . B.pack . unlines
+
+packLine :: String -> Value
+packLine = String . T.pack
+
+packLines :: [String] -> Value
+packLines = String . T.pack . unlines
+
+geradeweg_1 :: Value
+geradeweg_1 = packLines $
+    [ ".....    "
+    , ".211."
+    , "..2..  "
+    , "3...4"
+    , "....."
+    ]
+
+geradeweg_1_sol :: Value
+geradeweg_1_sol = packLines $
+    [ "┌┐┌─┐"
+    , "││└┐│  "
+    , "│└─┘│"
+    , "└──┐│"
+    , "  .└┘ "
+    ]
+
+tightfit_1 :: Value
+tightfit_1 = packLines $
+    [ " --- "
+    , "3/\\.-"
+    , "-\\.\\4"
+    , "-.\\/-"
+    , " 35-"
+    ]
+
+tightfit_broken_1 :: Value
+tightfit_broken_1 = packLines $
+    [ " --- "
+    , "3/\\.-"
+    , "-\\x\\4"
+    , "-.\\/-"
+    , " 35-"
+    ]
+
+tightfit_broken_2 :: Value
+tightfit_broken_2 = packLines $
+    [ "3/\\.-"
+    , "-\\x\\4"
+    , "-.\\/-"
+    , " 35-"
+    ]
+
+tightfit_1_sol :: Value
+tightfit_1_sol = packLines $
+    [ "2/1 4\\5  3"
+    , "  4\\5  3  2\\1 "
+    , "   3  1\\2 5/4"
+    ]
+
+tightfit_sol_broken :: Value
+tightfit_sol_broken = packLine "2/1 4 /5"
+
+tightfit_sol_broken_2 :: Value
+tightfit_sol_broken_2 = packLine "2/x 4 3/5"
+
+slalom_sol_broken :: Value
+slalom_sol_broken = packLine "//\\ /\\x5 "
+
+kpyramid_1 :: Value
+kpyramid_1 = packLines $
+    [ "G     3"
+    , "G    . ."
+    , "G   . . ."
+    , "W  .o. . ."
+    , "G 1*.*.o.*6"
+    ]
+
+kpyramid_1_sol :: Value
+kpyramid_1_sol = packLines $
+    [ "    3"
+    , "   8 5"
+    , "  1 9 4"
+    , " 3 2 7 3"
+    , "1 2 4 3 6"
+    ]
+
+kpyramid_broken_1 :: Value
+kpyramid_broken_1 = packLines $
+    [ "  G     3"
+    , "  G    . 22"
+    , "  H   . aa ."
+    , "  W  .o. .|. "
+    , "  G 1*.*.o.*6"
+    ]
+
+kpyramid_broken_2 :: Value
+kpyramid_broken_2 = packLines $
+    [ "G     3"
+    , "G    . 22"
+    , "H   . aa ."
+    , "W  .o. .|. "
+    , "G 1*.*.o.*6"
+    ]
+
+kpyramid_broken_3 :: Value
+kpyramid_broken_3 = packLines $
+    [ "G     3"
+    , "G    . ."
+    , "G   . . ."
+    , "W  .o. . ."
+    , "G a*.*.o.*6"
+    ]
+
+compass_1 :: Value
+compass_1 = decodeLines $
+    [ "grid: |"
+    , "  ..."
+    , "  a.b"
+    , "clues:"
+    , "  a: 2 1 . 2"
+    , "  b: 21 . . 0"
+    ]
+
+compass_broken_1 :: Value
+compass_broken_1 = decodeLines $
+    [ "grid: |"
+    , "  a.b"
+    , "clues:"
+    , "  b: 21 . . 0"
+    ]
+
+compass_broken_2 :: Value
+compass_broken_2 = decodeLines $
+    [ "grid: |"
+    , "  a.b"
+    , "clues:"
+    , "  a: x . . 0"
+    , "  b: 21 . . 0"
+    ]
+
+compass_broken_3 :: Value
+compass_broken_3 = decodeLines $
+    [ "grid: |"
+    , "  a.b"
+    , "clues:"
+    , "  a: 1 . ."
+    , "  b: 21 . . 0"
+    ]
+
+compass_broken_4 :: Value
+compass_broken_4 = decodeLines $
+    [ "grid: |"
+    , "  a.b"
+    , "clues:"
+    , "  a: 1 . . 2 3"
+    , "  b: 21 . . 0"
+    ]
+
+compass_broken_5 :: Value
+compass_broken_5 = decodeLines $
+    [ "grid: |"
+    , "  a3b"
+    , "clues:"
+    , "  a: 1 . . 2 3"
+    , "  b: 21 . . 0"
+    ]
+
+thermo_1 :: Value
+thermo_1 = packLines $
+    [ ".b..2."
+    , "a.c5.1"
+    , ".d..6."
+    , ".4..c."
+    , "5.3b.d"
+    , ".2..a."
+    ]
+
+test_thermo_1 :: [Thermometer]
+test_thermo_1 = either (const []) snd res
+  where
+    res = parseEither (fst thermosudoku) thermo_1
+
+-- two neighbouring a's, should be fine
+thermo_2 :: Value
+thermo_2 = packLines $
+    [ "....2."
+    , "..c5.1"
+    , ".b..6."
+    , "a..c.."
+    , "a...b."
+    , ".bc.a."
+    ]
+
+test_thermo_2 :: [Thermometer]
+test_thermo_2 = either (const []) snd res
+  where
+    res = parseEither (fst thermosudoku) thermo_2
+
+thermo_broken_1 :: Value
+thermo_broken_1 = packLines $
+    [ ".."
+    , "a."
+    ]
+
+thermo_broken_2 :: Value
+thermo_broken_2 = packLines $
+    [ "bb"
+    , "a."
+    ]
+
+justShow :: Show a => Maybe a -> Bool
+justShow Nothing = False
+justShow (Just x) = show x `deepseq` True
+
+eitherShow :: Show a => Either e a -> Bool
+eitherShow (Left _) = False
+eitherShow (Right x) = show x `deepseq` True
+
+testParse :: Show a => (Value -> Parser a) -> Value -> Assertion
+testParse p t = eitherShow res @? "bad parse: " ++ err
+  where
+    res = parseEither p t
+    err = either id (const "no error") res
+
+testNonparse :: Show a => (Value -> Parser a) -> Value -> Assertion
+testNonparse p t = (not . justShow . parseMaybe p $ t)
+                   @? "parsed but shouldn't"
+
+testBreakSlalom :: Bool
+testBreakSlalom =
+    case parseMaybe (snd slalom) slalom_sol_broken of
+        Nothing -> True
+        Just s  -> let d = drawSlalomDiags s
+                       svg = renderDia SVG (SVGOptions (Width 100) Nothing) d
+                       svgt = renderSvg svg
+                   in (show svgt) `deepseq` True
+
+test_tightfit_1 :: Bool
+test_tightfit_1 = either (const False) test_both res
+  where
+    res = parseEither (fst tightfitskyscrapers) tightfit_1
+    test_both (o, g) = test_size g && test_clues o
+    test_size g = Grid.size g == (3, 3)
+    test_clues (Grid.OC l r b t) = l == [Nothing, Nothing, Just 3] &&
+                                   r == [Nothing, Just 4, Nothing] &&
+                                   b == [Just 3, Just 5, Nothing] &&
+                                   t == [Nothing, Nothing, Nothing]
+
+test_pyramid_sol :: Bool
+test_pyramid_sol = either (const False) test_content res
+  where
+    res = parseEither (snd kpyramid) kpyramid_1_sol
+    test_content (PyramidSol rs) = rs == [[3], [8,5], [1,9,4], [3,2,7,3], [1,2,4,3,6]]
+
+unitTests :: TestTree
+unitTests = testGroup "Unit tests"
+    [ testCase "parse geradeweg" $ testParse (fst geradeweg) geradeweg_1
+    , testCase "parse geradeweg solution" $ testParse (snd geradeweg) geradeweg_1_sol
+    , testCase "parse tightfit" $ testParse (fst tightfitskyscrapers) tightfit_1
+    , testCase "parse tightfit, correct size" $ test_tightfit_1 @? "error in puzzle"
+    , testCase "parse tightfit solution" $ testParse (snd tightfitskyscrapers) tightfit_1_sol
+    , testCase "don't parse broken tighfit" $ testNonparse (fst tightfitskyscrapers) tightfit_broken_1
+    , testCase "don't parse broken tighfit" $ testNonparse (fst tightfitskyscrapers) tightfit_broken_2
+    , testCase "don't parse broken tightfit solution" $
+        testNonparse (snd tightfitskyscrapers) tightfit_sol_broken
+    , testCase "don't parse broken tightfit solution" $
+        testNonparse (snd tightfitskyscrapers) tightfit_sol_broken_2
+    , testCase "parse digit" $ (parseMaybe parseChar '5' :: Maybe Int) @=? Just 5
+    , testCase "don't parse hex chars" $ (parseMaybe parseChar 'a' :: Maybe Int) @=? Nothing
+    , testCase "don't break on non-digits" $ (parseMaybe parseChar ' ' :: Maybe Int) @=? Nothing
+    , testCase "don't parse invalid slalom solution" $ testNonparse (snd slalom) slalom_sol_broken
+    , testCase "don't break rendering invalid slalom solution"
+         $ testBreakSlalom @? "just testing against errors"
+    , testCase "parse kpyramid" $ testParse (fst kpyramid) kpyramid_1
+    , testCase "parse kpyramid sol" $ testParse (snd kpyramid) kpyramid_1_sol
+    , testCase "parse kpyramid sol properly" $ test_pyramid_sol @? "wrong solution"
+    , testCase "don't parse broken kpyramid" $ testNonparse (fst kpyramid) kpyramid_broken_1
+    , testCase "don't parse broken kpyramid" $ testNonparse (fst kpyramid) kpyramid_broken_2
+    , testCase "don't parse broken kpyramid" $ testNonparse (fst kpyramid) kpyramid_broken_3
+    , testCase "parse compass" $ testParse (fst compass) compass_1
+    , testCase "don't parse borken compass" $ testNonparse (fst compass) compass_broken_1
+    , testCase "don't parse borken compass" $ testNonparse (fst compass) compass_broken_2
+    , testCase "don't parse borken compass" $ testNonparse (fst compass) compass_broken_3
+    , testCase "don't parse borken compass" $ testNonparse (fst compass) compass_broken_4
+    , testCase "don't parse borken compass" $ testNonparse (fst compass) compass_broken_5
+    , testCase "parse thermo" $ testParse (fst thermosudoku) thermo_1
+    , testCase "parse thermo" $ testParse (fst thermosudoku) thermo_2
+    , testCase "parse thermo, thermometers" $ sort test_thermo_1 @?= [ [(0, 4), (1, 5), (2, 4), (1, 3)]
+                                                                     , [(4, 0), (3, 1), (4, 2), (5, 1)] ]
+    , testCase "parse thermo, thermometers" $ sort test_thermo_2 @?= [ [(0, 1), (1, 0), (2, 0)]
+                                                                     , [(0, 2), (1, 3), (2, 4)]
+                                                                     , [(4, 0), (4, 1), (3, 2)] ]
+    , testCase "don't parse broken thermo" $ testNonparse (fst thermosudoku) thermo_broken_1
+    , testCase "don't parse broken thermo" $ testNonparse (fst thermosudoku) thermo_broken_2
+    ]