{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
module Draw.Elements where
import Diagrams.Prelude hiding (N)
import Diagrams.TwoD.Offset
import qualified Data.Map.Strict as Map
import Data.List (groupBy, sortOn)
import Data.Grid
import Data.Elements hiding (Loop)
import Data.GridShape hiding (edge)
import Draw.Lib
import Draw.Style
import Draw.Widths
import Draw.Grid
pearl :: Backend' b =>
MasyuPearl -> Diagram b
pearl m = circle 0.35 # lwG 0.05 # fc (c m)
where
c MWhite = white
c MBlack = black
smallPearl :: Backend' b =>
MasyuPearl -> Diagram b
smallPearl = scale 0.4 . pearl
drawEnd :: Backend' b =>
MEnd -> Diagram b
drawEnd MEnd = smallPearl MBlack
drawBigEnd :: Backend' b =>
MEnd -> Diagram b
drawBigEnd MEnd = pearl MBlack
ur :: Path V2 Double
ur = fromVertices [p2 (-1/2,-1/2), p2 (1/2,1/2)]
dr :: Path V2 Double
dr = fromVertices [p2 (1/2,-1/2), p2 (-1/2,1/2)]
cross :: Path V2 Double
cross = ur <> dr
drawCross :: Backend' b => Bool -> Diagram b
drawCross True = stroke cross # scale 0.8 # lwG edgewidth
drawCross False = mempty
drawCompassClue :: Backend' b =>
CompassC -> Diagram b
drawCompassClue (CC n e s w) = texts <> stroke cross # lwG 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
drawSlovakClue :: Backend' b =>
SlovakClue -> Diagram b
drawSlovakClue (SlovakClue s c) =
centerY (drawInt s === strutY 0.1 === dots c) <> fillBG gray
where
dots n = centerX $ hcat' with {_sep = 0.04} (replicate n $ d)
d = circle 0.1 # lwG 0.02 # fc white
thermo :: Backend' b => [P2 Double] -> Diagram b
thermo vs@(v:_) = (bulb `atop` line) # col
where bulb = circle 0.4 # moveTo v
line = strokeLocLine (fromVertices vs)
# lwG 0.55 # lineCap LineCapSquare
col = lc gr . fc gr
gr = blend 0.6 white black
thermo [] = error "invalid empty thermometer"
drawThermos :: Backend' b => [Thermometer] -> Diagram b
drawThermos = mconcat . map (thermo . map toPoint)
drawTight :: Backend' b =>
(a -> Diagram b) -> Tightfit a -> Diagram b
drawTight d (Single x) = d x
drawTight d (UR x y) = stroke ur # lwG 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 # lwG onepix
<> d x # scale s # translate (r2 (-t,-t))
<> d y # scale s # translate (r2 (t,t))
where t = 1/5
s = 2/3
stackWords :: Backend' b => [String] -> Diagram b
stackWords = vcat' with {_sep = 0.1} . scale 0.8 . map (alignL . textFixed)
stackWordsLeft :: Backend' b => [String] -> Diagram b
stackWordsLeft = vcat' (with & catMethod .~ Distrib & sep .~ 1) . map (alignL . text')
stackWordsRight :: Backend' b => [String] -> Diagram b
stackWordsRight = vcat' (with & catMethod .~ Distrib & sep .~ 1) . map (alignR . text')
drawMarkedWord :: Backend' b => MarkedWord -> Diagram b
drawMarkedWord (MW s e) = lwG onepix . stroke $ expandTrail' with {_expandCap = LineCapRound} 0.4 t
where t = fromVertices [p2i s, p2i e] # translate (r2 (1/2,1/2))
drawMarkedWords :: Backend' b => [MarkedWord] -> Diagram b
drawMarkedWords = mconcat . map drawMarkedWord
drawMarkedLine :: (ToPoint a, Backend' b) => MarkedLine a -> Diagram b
drawMarkedLine (MarkedLine s e) = strokePath (toPoint s ~~ toPoint e) # lwG edgewidth # lc gray
drawMarkedLines :: (ToPoint a, Backend' b) => [MarkedLine a] -> Diagram b
drawMarkedLines = mconcat . map drawMarkedLine
drawSlalomClue :: (Show a, Backend' b) =>
a -> Diagram b
drawSlalomClue x = text' (show x) # scale 0.75
<> circle 0.4 # fc white # lwG onepix
drawSlalomDiag :: Backend' b
=> SlalomDiag -> Diagram b
drawSlalomDiag d = stroke (v d) # lwG edgewidth
where
v SlalomForward = ur
v SlalomBackward = dr
drawText :: Backend' b => String -> Diagram b
drawText = text'
drawTextFixed :: Backend' b => String -> Diagram b
drawTextFixed = textFixed
drawInt :: Backend' b =>
Int -> Diagram b
drawInt s = drawText (show s)
drawChar :: Backend' b =>
Char -> Diagram b
drawChar c = drawText [c]
drawCharFixed :: Backend' b =>
Char -> Diagram b
drawCharFixed c = drawTextFixed [c]
drawCharOpaque :: Backend' b =>
Char -> Diagram b
drawCharOpaque c = drawChar c <> circle 0.5 # lwG 0 # fc white
placeTL :: Backend' b => Diagram b -> Diagram b
placeTL = moveTo (p2 (-0.4,0.4)) . scale 0.5 . alignTL
hintTL :: Backend' b => String -> Diagram b
hintTL = placeTL . drawText
drawWords :: Backend' b =>
[String] -> Diagram b
drawWords ws = spread (-1.0 *^ unitY)
(map (centerXY . scale 0.4 . drawText) ws)
# centerY
drawCurve :: Backend' b => [Edge N] -> Diagram b
drawCurve = lwG onepix . fit 0.6 . centerXY . mconcat . map (stroke . edge)
drawShadow :: Backend' b => Shade -> Diagram b
drawShadow (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 # lwG 0 # fc gray
west = reflectAbout (p2 (0, 0)) (direction $ r2 (1, 1)) south
drawTapaClue :: Backend' b =>
TapaClue -> Diagram b
drawTapaClue (TapaClue [x]) = drawInt x
drawTapaClue (TapaClue xs) = fit 0.8
. atPoints (p (length xs))
. map drawInt
$ xs
where
p n = mconcat . pathVertices $ centerXY (p' n)
p' 2 = p2 (-1/4, 1/4) ~~ p2 (1/4, -1/4)
p' 3 = reflectX . rotateBy (1/6) $ triangle 0.8
p' 4 = reflectX . rotateBy (3/8) $ square 0.7
p' 1 = error "singleton clues handled separately"
p' _ = error "invalid tapa clue"
drawPrimeDiag :: Backend' b =>
PrimeDiag -> Diagram b
drawPrimeDiag (PrimeDiag d) = stroke p # lwG (3 * onepix) # lc (blend 0.5 gray white)
where
p = case d of (False, False) -> mempty
(True, False) -> ur
(False, True) -> dr
(True, True) -> ur <> dr
drawAnglePoly :: Backend' b =>
Int -> Diagram b
drawAnglePoly 3 = strokePath (triangle 0.3) # fc black
drawAnglePoly 4 = strokePath (square 0.25) # fc gray
drawAnglePoly 5 = strokePath (pentagon 0.2) # fc white
drawAnglePoly _ = error "expected 3..5"
fish :: Double -> Angle Double -> Trail' Loop V2 Double
fish off startAngle = closeLine $ half <> half # reverseLine # reflectY
where
half = arc (angleDir startAngle) endAngle # translateY (-off)
endAngle = ((180 @@ deg) ^-^ acosA off ^-^ startAngle)
drawFish :: Backend' b =>
Fish -> Diagram b
drawFish Fish = fit 0.6 . centerXY . fc black . strokeLoop $
fish 0.7 (30 @@ deg)
drawStar :: Backend' b =>
Star -> Diagram b
drawStar Star = fc black . stroke . star (StarSkip 2) $ pentagon 0.3
drawTree :: Backend' b => Tree -> Diagram b
drawTree Tree =
fit 0.5 $ centerXY $ scaleY 0.5 $ fc black $ mconcat
[ rect 0.1 0.6 # moveTo (p2 (0.5, 0.7))
, circle 0.1 # moveTo (p2 (0.4, 0.9))
, circle 0.2 # moveTo (p2 (0.6, 1.0))
, circle 0.2 # moveTo (p2 (0.4, 1.2))
, circle 0.16 # moveTo (p2 (0.6, 1.3))
, circle 0.15 # moveTo (p2 (0.45, 1.45))
, circle 0.1 # moveTo (p2 (0.7, 1.4))
]
drawTent :: Backend' b => PlacedTent -> Diagram b
drawTent (Tent d) = tent <> lwG gridwidth (stroke conn)
where
conn :: Path V2 Double
conn = p2 (0, 0) ~~ p2 (case d of
U -> (0, 1)
R -> (1, 0)
D -> (0, -1)
L -> (-1, 0))
tent = fit 0.7 $ centerXY $ lwG 0 $ mconcat
[ rect 10 (1/4) # fc black
, shape [(-2, 0), (0, 4), (2, 0), (-2, 0)] # fc white
, shape [(-4, 0), (0, 8), (4, 0), (-4, 0)] # fc black
, shape [(0, 8), (-1/2, 8 + 1), (-1, 8 + 1 - 1/4), (0, 8 + 1 - 1/4 - 2), (0, 8) ] # fc black
, shape [(0, 8), (1/2, 8 + 1), (1, 8 + 1 - 1/4), (0, 8 + 1 - 1/4 - 2), (0, 8) ] # fc black
]
shape = strokeLocLoop . fromVertices . map p2
vertexLoop :: VertexLoop -> Located (Trail' Loop V2 Double)
vertexLoop = mapLoc closeLine . fromVertices . map toPoint
note :: Backend' b =>
Diagram b -> Diagram b
note d = d # frame 0.2 # bg (blend 0.2 black white)
placeNoteTR :: Backend' b =>
Size -> Diagram b -> Diagram b
placeNoteTR sz d = note d # alignBL # translatep sz # translate (r2 (0.6,0.6))
placeNoteTL :: Backend' b =>
Size -> Diagram b -> Diagram b
placeNoteTL sz d = note d # alignBR # translatep sz # translate (r2 (-0.6,0.6))
placeNoteBR :: Backend' b =>
Size -> Diagram b -> Diagram b
placeNoteBR (x,_) d = note d # alignTL # translatep (x,0) # translate (r2 (0.6,-0.6))
miniloop :: Backend' b => Diagram b
miniloop = (drawThinEdges (map unorient out) <> grid gSlither g)
# centerXY # scale 0.4
where
g = sizeGrid (1, 1)
(out, _) = edgesM g
dominoBG :: Colour Double
dominoBG = blend 0.3 black white
drawDomino :: Backend' b => (Int, Int) -> Diagram b
drawDomino (x, y) =
(drawInt x # smash ||| strutX 0.65 ||| drawInt y # smash) # centerXY # scale 0.6
<> strokePath (rect 0.8 0.5) # lwG 0 # fc dominoBG
newtype DominoC = DominoC C
deriving (Ord, Eq)
instance ToPoint DominoC where
toPoint (DominoC (C x y)) = p2 ((1.0 * fromIntegral x),
(0.7 * fromIntegral y))
drawDominos :: Backend' b => DigitRange -> Diagram b
drawDominos = centerXY . placeGrid
. Map.mapKeys DominoC . fmap drawDomino . dominoGrid
drawPill :: Backend' b => Int -> Diagram b
drawPill x = drawInt x # scale 0.6
<> strokePath (roundedRect 0.8 0.5 0.2) # lwG 0 # fc dominoBG
drawPills :: Backend' b => DigitRange -> Diagram b
drawPills (DigitRange a b) = centerXY . onGrid 1.0 0.7 drawPill $ placed
where
n = b - a + 1
root = head [ x | x <- [n,n-1..], x*x <= n ]
placed = zip [(x, y) | x <- [0..root], y <- [root,root-1..0]] [a..b]
polyominoGrid :: Backend' b => Grid C (Maybe Char) -> Diagram b
polyominoGrid = placeGrid . fmap (scale 0.8) . fmap
(\x -> case x of
Nothing -> fillBG black
Just c -> (drawText [c] # fc white # lc white) <> fillBG black)
drawPentominos :: Backend' b => Diagram b
drawPentominos = centerXY . scale 0.5 . polyominoGrid $ pentominoGrid
drawLITS :: Backend' b => Diagram b
drawLITS = centerXY . scale 0.5 . polyominoGrid $ litsGrid
drawLITSO :: Backend' b => Diagram b
drawLITSO = centerXY . scale 0.5 . polyominoGrid $ litsoGrid
drawCrossing :: Backend' b => Crossing -> Diagram b
drawCrossing = const $ drawChar '+'
drawBahnhofClue :: Backend' b => BahnhofClue -> Diagram b
drawBahnhofClue = either drawInt drawCrossing
kropkiDot :: Backend' b => KropkiDot -> Diagram b
kropkiDot KNone = mempty
kropkiDot c = circle 0.1 # lwG 0.03 # fc (col c) # smash
where col KWhite = white
col KBlack = blend 0.98 black white
col KNone = error "can't reach"
drawFraction :: Backend' b => Fraction -> Diagram b
drawFraction f = centerX $ case f of
FInt a -> drawText a # scale 0.8
FFrac a b -> frac a b
FComp a b c -> (drawText a # scale 0.8) ||| strutX (1/10) ||| frac b c
where
frac b c = stroke slash # scale (1/4) # lwG onepix
<> drawText b # scale s # translate (r2 (-t,t))
<> drawText c # scale s # translate (r2 (t,-t))
where t = 1/6
s = 1/2
slash :: Path V2 Double
slash = fromVertices [p2 (-1/3,-1/2), p2 (1/3,1/2)]
drawMyopia :: Backend' b => Myopia -> Diagram b
drawMyopia = foldMap d'
where
d' = lwG onepix . scale (1/3) . d
d U = a (0, 0) (0, 1)
d R = a (0, 0) (1, 0)
d D = a (0, 0) (0, -1)
d L = a (0, 0) (-1, 0)
a p q = arrowBetween' (with & arrowHead .~ tri & lengths .~ verySmall) (p2 p) (p2 q)
greaterClue :: Backend' b => GreaterClue -> [Diagram b]
greaterClue [] = mempty
greaterClue (_:rs) = g rs
where
g [] = [placeholder]
g (r:rs') = placeholder : drawRel r : g rs'
drawRel RUndetermined = mempty
drawRel RLess = drawText "<"
drawRel RGreater = drawText ">"
drawRel REqual = drawText "="
placeholder = circle 0.35 # lwG onepix # dashingG [0.05, 0.05] 0
drawCages :: (Backend' b, Eq a, Ord a) =>
Grid C a -> Map.Map a (Diagram b) -> Diagram b
drawCages g m =
hints <> (mconcat . map cage . Map.elems) byChar
where
hints = placeGrid . fmap (bgFrame 0.05 white . placeTL) . clues
. fmap (flip Map.lookup m . head) . invertMap . fmap tl $ byChar
tl = head . sortOn (\ (C x y) -> (-y, x))
byChar = invertMap g
invertMap :: (Eq a, Ord a) => Map.Map k a -> Map.Map a [k]
invertMap
= Map.fromList
. map (\ l -> (fst (head l), map snd l))
. groupBy (\ x y -> fst x == fst y)
. sortOn fst
. map (\ (x,y) -> (y,x))
. Map.toList