module Diagrams.Puzzles.Elements where
import Diagrams.Prelude hiding (N)
import Diagrams.TwoD.Offset
import qualified Data.Map as Map
import Data.Puzzles.Grid
import Data.Puzzles.Elements hiding (Loop)
import Data.Puzzles.GridShape hiding (edge)
import Diagrams.Puzzles.Lib
import Diagrams.Puzzles.Style
import Diagrams.Puzzles.Widths
import Diagrams.Puzzles.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
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
hintTL :: Backend' b => String -> Diagram b
hintTL = moveTo (p2 (0.4,0.4)) . scale 0.5 . alignTL . 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 = acosA off ^+^ (90 @@ deg)
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
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)
placeNote :: Backend' b =>
Size -> Diagram b -> Diagram b
placeNote 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,n1..], x*x <= n ]
placed = zip [(x, y) | x <- [0..root], y <- [root,root1..0]] [a..b]
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