{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
module Draw.Lib where
import Diagrams.Path (pathPoints)
import Diagrams.Prelude
import Graphics.SVGFonts.Text (TextOpts(..), Mode(..), Spacing(..), textSVG')
import Graphics.SVGFonts.Fonts (bit)
import Graphics.SVGFonts.ReadFont (PreparedFont, loadFont)
import Control.Arrow ((***))
import Paths_puzzle_draw (getDataFileName)
import System.IO.Unsafe (unsafePerformIO)
type Backend' b = (V b ~ V2, N b ~ Double,
Renderable (Path V2 Double) b, Backend b V2 Double)
vline, hline :: Backend' b => Double -> Diagram b
vline n = strokeLine . fromVertices . map p2 $ [(0, 0), (0, n)]
hline n = strokeLine . fromVertices . map p2 $ [(0, 0), (n, 0)]
hcatsep :: (InSpace V2 Double a, Juxtaposable a, HasOrigin a, Monoid' a)
=> [a] -> a
hcatsep = hcat' with {_sep = 1}
vcatsep :: (InSpace V2 Double a, Juxtaposable a, HasOrigin a, Monoid' a)
=> [a] -> a
vcatsep = cat' (r2 (0,1)) with {_sep = 1}
smash :: Backend' b => Diagram b -> Diagram b
smash = withEnvelope (pointDiagram origin :: D V2 Double)
translatep :: (InSpace V2 Double t, Transformable t)
=> (Int, Int) -> t -> t
translatep = translate . r2i
r2i :: (Int, Int) -> V2 Double
r2i = r2 . (fromIntegral *** fromIntegral)
p2i :: (Int, Int) -> P2 Double
p2i = p2 . (fromIntegral *** fromIntegral)
mirror :: (InSpace V2 Double t, Transformable t) => t -> t
mirror = reflectAbout (p2 (0, 0)) (direction $ r2 (1, -1))
interleave :: [a] -> [a] -> [a]
interleave [] _ = []
interleave (x:xs) ys = x : interleave ys xs
magnitude :: V2 Double -> Double
magnitude = norm
spread :: Backend' b => V2 Double -> [Diagram b] -> Diagram b
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 :: (InSpace V2 Double a, Enveloped a) => V2 Double -> a -> Double
dmid u a = (dtop + dbot) / 2 - dbot
where menv v = magnitude . envelopeV v
dtop = menv u a
dbot = menv ((-1) *^ u) a
besidesL :: Backend' b =>
Diagram b -> Diagram b -> Diagram b
besidesL a b = a ||| strutX 0.5 ||| b'
where b' = b # centerY # translate (dmid unitY a *^ unitY)
besidesR :: Backend' b =>
Diagram b -> Diagram b -> Diagram b
besidesR b a = b' ||| strutX 0.5 ||| a
where b' = b # centerY # translate (dmid unitY a *^ unitY)
aboveT :: Backend' b =>
Diagram b -> Diagram b -> Diagram b
aboveT a b = a === strutY 0.5 === b'
where b' = b # centerX # translate (dmid unitX a *^ unitX)
fit :: (Transformable t, Enveloped t, InSpace V2 Double t) =>
Double -> t -> t
fit f a = scale (f / m) a
where m = max (diameter unitX a)
(diameter unitY a)
type Font = PreparedFont Double
text'' :: Backend' b => Font -> String -> Diagram b
text'' fnt t = stroke (textSVG' (TextOpts fnt INSIDE_H KERN False 1 1) t)
# lwG 0 # rfc black # scale 0.8
where
rfc :: (HasStyle a, InSpace V2 Double a) => Colour Double -> a -> a
rfc = recommendFillColor
text' :: Backend' b => String -> Diagram b
text' = text'' fontGenLight
textFixed :: Backend' b => String -> Diagram b
textFixed = text'' fontBit
fontGenLight :: Font
fontGenLight = unsafePerformIO . loadFont . unsafePerformIO . getDataFileName
$ "data/fonts/gen-light.svg"
fontBit :: Font
fontBit = unsafePerformIO $ bit
phantom' :: Backend' b => Diagram b -> Diagram b
phantom' = phantom
debugPath :: Backend' b => Path V2 Double -> Diagram b
debugPath p = mconcat . map draw $ prts'
where
prts = zip (pathVertices p) ['a'..]
prts' = concatMap (\(ps,c) -> zipWith (\pt d -> (pt, c:d:[])) ps ['0'..]) prts
draw (pt, l) = moveTo pt $ text' l
debugPath' :: Backend' b => Path V2 Double -> Diagram b
debugPath' p = mconcat . map draw $ prts'
where
prts = zip (pathPoints p) ['a'..]
prts' = concatMap (\(ps,c) -> zipWith (\pt d -> (pt, c:d:[])) ps ['0'..]) prts
draw (pt, l) = moveTo pt $ text' l