{-# LANGUAGE DeriveDataTypeable        #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeSynonymInstances      #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns              #-}

-------------------------------------------------------------------------------
-- | A rendering backend for Braille diagrams using Rasterific,
-- implemented natively in Haskell (making it easy to use on any
-- platform).
--
-- To invoke the Braille backend, you have three options.
--
-- * You can use the "Diagrams.Backend.Braille.CmdLine" module to create
--   standalone executables which output images when invoked.
--
-- * You can use the 'renderBraille' function provided by this module,
--   which gives you more flexible programmatic control over when and
--   how images are output (making it easy to, for example, write a
--   single program that outputs multiple images, or one that outputs
--   images dynamically based on user input, and so on).
--
-- * For the most flexibility (/e.g./ if you want access to the
--   resulting Braille value directly in memory without writing it to
--   disk), you can manually invoke the 'renderDia' method from the
--   'Diagrams.Core.Types.Backend' instance for @Braille@.  In particular,
--   'Diagrams.Core.Types.renderDia' has the generic type
--
-- > renderDia :: b -> Options b v n -> QDiagram b v n m -> Result b v n
--
-- (omitting a few type class constraints).  @b@ represents the
-- backend type, @v@ the vector space, @n@ the numeric field, and @m@ the type
-- of monoidal query annotations on the diagram.  'Options' and 'Result' are
-- associated data and type families, respectively, which yield the
-- type of option records and rendering results specific to any
-- particular backend.  For @b ~ Braille@, @v ~ V2@, and @n ~ n@, we have
--
-- > data Options Braille V2 n = BrailleOptions
-- >        { _size      :: SizeSpec2D n -- ^ The requested size of the output
-- >        }
--
-- @
-- type family Result Braille V2 n = String
-- @
--
-- So the type of 'renderDia' resolves to
--
-- @
-- renderDia :: Braille -> Options Braille V2 n -> QDiagram Braille V2 n m -> String
-- @
--
-- which you could call like @renderDia Braille (BrailleOptions (mkWidth 80))
-- myDiagram@.
--
-------------------------------------------------------------------------------
module Diagrams.Backend.Braille
  ( -- * Braille backend
    Braille(..)
  , B -- rendering token
  , Options(..)

    -- * Rendering
  , rasterBraille
  , renderBraille
  , size
  ) where

import           Codec.Picture
import           Codec.Picture.Types                 (convertImage,
                                                      promoteImage)
import           Control.Lens                        hiding ((#), transform)
import           Control.Monad                       (when)
import           Control.Monad.Reader                (ReaderT, runReaderT, ask, local)
import           Control.Monad.Writer                (Writer, execWriter, tell)
import           Data.Bits                           (setBit)
import           Data.Char                           (chr)
import           Data.Foldable                       (foldMap)
import           Data.Hashable                       (Hashable(..))
import           Data.Maybe                          (fromMaybe)
import           Data.Tree
import           Data.Typeable
import           Diagrams.Backend.Rasterific.Text
import           Diagrams.Core.Compile
import           Diagrams.Core.Transform             (matrixHomRep)
import           Diagrams.Core.Types
import           Diagrams.Prelude                    hiding (local)
import           Diagrams.TwoD.Adjust                (adjustDia2D)
import           Diagrams.TwoD.Text                  hiding (Font)
import qualified Graphics.Rasterific                 as R
import           Graphics.Rasterific.Texture         (Gradient,
                                                      linearGradientTexture,
                                                      radialGradientWithFocusTexture,
                                                      transformTexture,
                                                      uniformTexture,
                                                      withSampler)
import qualified Graphics.Rasterific.Transformations as R
import           System.FilePath                     (takeExtension)

data Braille = Braille deriving (Braille -> Braille -> Bool
(Braille -> Braille -> Bool)
-> (Braille -> Braille -> Bool) -> Eq Braille
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Braille -> Braille -> Bool
$c/= :: Braille -> Braille -> Bool
== :: Braille -> Braille -> Bool
$c== :: Braille -> Braille -> Bool
Eq, Eq Braille
Eq Braille
-> (Braille -> Braille -> Ordering)
-> (Braille -> Braille -> Bool)
-> (Braille -> Braille -> Bool)
-> (Braille -> Braille -> Bool)
-> (Braille -> Braille -> Bool)
-> (Braille -> Braille -> Braille)
-> (Braille -> Braille -> Braille)
-> Ord Braille
Braille -> Braille -> Bool
Braille -> Braille -> Ordering
Braille -> Braille -> Braille
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Braille -> Braille -> Braille
$cmin :: Braille -> Braille -> Braille
max :: Braille -> Braille -> Braille
$cmax :: Braille -> Braille -> Braille
>= :: Braille -> Braille -> Bool
$c>= :: Braille -> Braille -> Bool
> :: Braille -> Braille -> Bool
$c> :: Braille -> Braille -> Bool
<= :: Braille -> Braille -> Bool
$c<= :: Braille -> Braille -> Bool
< :: Braille -> Braille -> Bool
$c< :: Braille -> Braille -> Bool
compare :: Braille -> Braille -> Ordering
$ccompare :: Braille -> Braille -> Ordering
$cp1Ord :: Eq Braille
Ord, ReadPrec [Braille]
ReadPrec Braille
Int -> ReadS Braille
ReadS [Braille]
(Int -> ReadS Braille)
-> ReadS [Braille]
-> ReadPrec Braille
-> ReadPrec [Braille]
-> Read Braille
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Braille]
$creadListPrec :: ReadPrec [Braille]
readPrec :: ReadPrec Braille
$creadPrec :: ReadPrec Braille
readList :: ReadS [Braille]
$creadList :: ReadS [Braille]
readsPrec :: Int -> ReadS Braille
$creadsPrec :: Int -> ReadS Braille
Read, Int -> Braille -> ShowS
[Braille] -> ShowS
Braille -> String
(Int -> Braille -> ShowS)
-> (Braille -> String) -> ([Braille] -> ShowS) -> Show Braille
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Braille] -> ShowS
$cshowList :: [Braille] -> ShowS
show :: Braille -> String
$cshow :: Braille -> String
showsPrec :: Int -> Braille -> ShowS
$cshowsPrec :: Int -> Braille -> ShowS
Show, Typeable)

type B = Braille

type instance V Braille = V2
type instance N Braille = Double

-- | The custom monad in which intermediate drawing options take
--   place; 'Graphics.Rasterific.Drawing' is Rasterific's own rendering
--   monad.
type RenderM n = ReaderT (Style V2 n) (Writer Draw)

newtype Draw = Draw (R.Drawing PixelRGBA8 (), [((Int, Int), String)])
             deriving (b -> Draw -> Draw
NonEmpty Draw -> Draw
Draw -> Draw -> Draw
(Draw -> Draw -> Draw)
-> (NonEmpty Draw -> Draw)
-> (forall b. Integral b => b -> Draw -> Draw)
-> Semigroup Draw
forall b. Integral b => b -> Draw -> Draw
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Draw -> Draw
$cstimes :: forall b. Integral b => b -> Draw -> Draw
sconcat :: NonEmpty Draw -> Draw
$csconcat :: NonEmpty Draw -> Draw
<> :: Draw -> Draw -> Draw
$c<> :: Draw -> Draw -> Draw
Semigroup, Semigroup Draw
Draw
Semigroup Draw
-> Draw
-> (Draw -> Draw -> Draw)
-> ([Draw] -> Draw)
-> Monoid Draw
[Draw] -> Draw
Draw -> Draw -> Draw
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Draw] -> Draw
$cmconcat :: [Draw] -> Draw
mappend :: Draw -> Draw -> Draw
$cmappend :: Draw -> Draw -> Draw
mempty :: Draw
$cmempty :: Draw
$cp1Monoid :: Semigroup Draw
Monoid)

tellR :: R.Drawing PixelRGBA8 () -> RenderM n ()
tellR :: Drawing PixelRGBA8 () -> RenderM n ()
tellR = Draw -> RenderM n ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Draw -> RenderM n ())
-> (Drawing PixelRGBA8 () -> Draw)
-> Drawing PixelRGBA8 ()
-> RenderM n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Drawing PixelRGBA8 (), [((Int, Int), String)]) -> Draw
Draw ((Drawing PixelRGBA8 (), [((Int, Int), String)]) -> Draw)
-> (Drawing PixelRGBA8 ()
    -> (Drawing PixelRGBA8 (), [((Int, Int), String)]))
-> Drawing PixelRGBA8 ()
-> Draw
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,[((Int, Int), String)]
forall a. Monoid a => a
mempty)

tellT :: Int -> Int -> String -> RenderM n ()
tellT :: Int -> Int -> String -> RenderM n ()
tellT Int
x Int
y String
t = Draw -> RenderM n ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Draw -> RenderM n ()) -> Draw -> RenderM n ()
forall a b. (a -> b) -> a -> b
$ (Drawing PixelRGBA8 (), [((Int, Int), String)]) -> Draw
Draw (() -> Drawing PixelRGBA8 ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), [((Int
x, Int
y), String
t)])

runRenderM :: TypeableFloat n => RenderM n a -> Draw
runRenderM :: RenderM n a -> Draw
runRenderM = Writer Draw a -> Draw
forall w a. Writer w a -> w
execWriter (Writer Draw a -> Draw)
-> (RenderM n a -> Writer Draw a) -> RenderM n a -> Draw
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RenderM n a -> Style V2 n -> Writer Draw a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Style V2 n
sty) where
  sty :: Style V2 n
sty = Style V2 n
forall a. Monoid a => a
mempty Style V2 n -> (Style V2 n -> Style V2 n) -> Style V2 n
forall a b. a -> (a -> b) -> b
# AlphaColour Double -> Style V2 n -> Style V2 n
forall n a c.
(InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) =>
c -> a -> a
recommendFillColor AlphaColour Double
forall a. Num a => AlphaColour a
transparent Style V2 n -> (Style V2 n -> Style V2 n) -> Style V2 n
forall a b. a -> (a -> b) -> b
# Measure (N (Style V2 n)) -> Style V2 n -> Style V2 n
forall a n.
(N a ~ n, Typeable n, HasStyle a) =>
Measure n -> a -> a
recommendFontSize (N (Style V2 n) -> Measure (N (Style V2 n))
forall n. n -> Measure n
output N (Style V2 n)
4)

instance TypeableFloat n => Backend Braille V2 n where
  newtype Render Braille V2 n = R (RenderM n ())
  type Result Braille V2 n = String
  data Options Braille V2 n = BrailleOptions
          { Options Braille V2 n -> SizeSpec V2 n
_sizeSpec  :: SizeSpec V2 n -- ^ The requested size of the output
          } deriving (Int -> Options Braille V2 n -> ShowS
[Options Braille V2 n] -> ShowS
Options Braille V2 n -> String
(Int -> Options Braille V2 n -> ShowS)
-> (Options Braille V2 n -> String)
-> ([Options Braille V2 n] -> ShowS)
-> Show (Options Braille V2 n)
forall n. Show n => Int -> Options Braille V2 n -> ShowS
forall n. Show n => [Options Braille V2 n] -> ShowS
forall n. Show n => Options Braille V2 n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Options Braille V2 n] -> ShowS
$cshowList :: forall n. Show n => [Options Braille V2 n] -> ShowS
show :: Options Braille V2 n -> String
$cshow :: forall n. Show n => Options Braille V2 n -> String
showsPrec :: Int -> Options Braille V2 n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> Options Braille V2 n -> ShowS
Show, Options Braille V2 n -> Options Braille V2 n -> Bool
(Options Braille V2 n -> Options Braille V2 n -> Bool)
-> (Options Braille V2 n -> Options Braille V2 n -> Bool)
-> Eq (Options Braille V2 n)
forall n.
Eq n =>
Options Braille V2 n -> Options Braille V2 n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Options Braille V2 n -> Options Braille V2 n -> Bool
$c/= :: forall n.
Eq n =>
Options Braille V2 n -> Options Braille V2 n -> Bool
== :: Options Braille V2 n -> Options Braille V2 n -> Bool
$c== :: forall n.
Eq n =>
Options Braille V2 n -> Options Braille V2 n -> Bool
Eq)

  renderRTree :: Braille
-> Options Braille V2 n
-> RTree Braille V2 n Annotation
-> Result Braille V2 n
renderRTree Braille
_ Options Braille V2 n
opts RTree Braille V2 n Annotation
t =
    (((Int, Int), String) -> ShowS)
-> String -> [((Int, Int), String)] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Int, Int), String) -> ShowS
drawText (Image PixelRGBA8 -> String
img2brl (Image PixelRGBA8 -> String) -> Image PixelRGBA8 -> String
forall a b. (a -> b) -> a -> b
$ Int
-> Int -> PixelRGBA8 -> Drawing PixelRGBA8 () -> Image PixelRGBA8
forall px.
RenderablePixel px =>
Int -> Int -> px -> Drawing px () -> Image px
R.renderDrawing (n -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round n
w) (n -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round n
h) PixelRGBA8
bgColor Drawing PixelRGBA8 ()
r) [((Int, Int), String)]
txt
    where
      Draw (Drawing PixelRGBA8 ()
r, [((Int, Int), String)]
txt) = RenderM n () -> Draw
forall n a. TypeableFloat n => RenderM n a -> Draw
runRenderM (RenderM n () -> Draw)
-> (RTree Braille V2 n Annotation -> RenderM n ())
-> RTree Braille V2 n Annotation
-> Draw
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render Braille V2 n -> RenderM n ()
forall n. Render Braille V2 n -> RenderM n ()
runR (Render Braille V2 n -> RenderM n ())
-> (RTree Braille V2 n Annotation -> Render Braille V2 n)
-> RTree Braille V2 n Annotation
-> RenderM n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RTree Braille V2 n Annotation -> Render Braille V2 n
forall n.
TypeableFloat n =>
RTree Braille V2 n Annotation -> Render Braille V2 n
fromRTree (RTree Braille V2 n Annotation -> Draw)
-> RTree Braille V2 n Annotation -> Draw
forall a b. (a -> b) -> a -> b
$ RTree Braille V2 n Annotation
t
      V2 n
w n
h  = n -> SizeSpec V2 n -> V2 n
forall (v :: * -> *) n.
(Foldable v, Functor v, Num n, Ord n) =>
n -> SizeSpec v n -> v n
specToSize n
100 (Options Braille V2 n
optsOptions Braille V2 n
-> Getting (SizeSpec V2 n) (Options Braille V2 n) (SizeSpec V2 n)
-> SizeSpec V2 n
forall s a. s -> Getting a s a -> a
^.Getting (SizeSpec V2 n) (Options Braille V2 n) (SizeSpec V2 n)
forall n. Lens' (Options Braille V2 n) (SizeSpec V2 n)
sizeSpec)
      bgColor :: PixelRGBA8
bgColor = Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 Pixel8
0 Pixel8
0 Pixel8
0 Pixel8
0

  adjustDia :: Braille
-> Options Braille V2 n
-> QDiagram Braille V2 n m
-> (Options Braille V2 n, Transformation V2 n,
    QDiagram Braille V2 n m)
adjustDia Braille
c Options Braille V2 n
opts QDiagram Braille V2 n m
d = Lens' (Options Braille V2 n) (SizeSpec V2 n)
-> Braille
-> Options Braille V2 n
-> QDiagram Braille V2 n m
-> (Options Braille V2 n, Transformation V2 n,
    QDiagram Braille V2 n m)
forall n m b.
(TypeableFloat n, Monoid' m) =>
Lens' (Options b V2 n) (SizeSpec V2 n)
-> b
-> Options b V2 n
-> QDiagram b V2 n m
-> (Options b V2 n, Transformation V2 n, QDiagram b V2 n m)
adjustDia2D forall n. Lens' (Options Braille V2 n) (SizeSpec V2 n)
Lens' (Options Braille V2 n) (SizeSpec V2 n)
sizeSpec Braille
c Options Braille V2 n
opts (QDiagram Braille V2 n m
d QDiagram Braille V2 n m
-> (QDiagram Braille V2 n m -> QDiagram Braille V2 n m)
-> QDiagram Braille V2 n m
forall a b. a -> (a -> b) -> b
# QDiagram Braille V2 n m -> QDiagram Braille V2 n m
forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
t -> t
reflectY)

drawText :: ((Int, Int), String) -> ShowS
drawText ((Int
x, Int
y), String
t) = [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> [(Int, Char)] -> [String])
-> [(Int, Char)] -> [String] -> [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Int, Char) -> [String] -> [String])
-> [String] -> [(Int, Char)] -> [String]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (((Int, Char) -> [String] -> [String])
 -> [String] -> [(Int, Char)] -> [String])
-> ((Int, Char) -> [String] -> [String])
-> [String]
-> [(Int, Char)]
-> [String]
forall a b. (a -> b) -> a -> b
$ (Int -> Char -> [String] -> [String])
-> (Int, Char) -> [String] -> [String]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Char -> [String] -> [String]
f) ([Int] -> String -> [(Int, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
x..] String
t) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
  where f :: Int -> Char -> [String] -> [String]
f Int
x' = ASetter [String] [String] Char Char -> Char -> [String] -> [String]
forall s t a b. ASetter s t a b -> b -> s -> t
set (ASetter [String] [String] Char Char
 -> Char -> [String] -> [String])
-> ASetter [String] [String] Char Char
-> Char
-> [String]
-> [String]
forall a b. (a -> b) -> a -> b
$ Int -> IndexedTraversal' Int [String] String
forall (t :: * -> *) a.
Traversable t =>
Int -> IndexedTraversal' Int (t a) a
element Int
y ((String -> Identity String) -> [String] -> Identity [String])
-> ((Char -> Identity Char) -> String -> Identity String)
-> ASetter [String] [String] Char Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IndexedTraversal' Int String Char
forall (t :: * -> *) a.
Traversable t =>
Int -> IndexedTraversal' Int (t a) a
element Int
x'

fromRTree :: TypeableFloat n => RTree Braille V2 n Annotation -> Render Braille V2 n
fromRTree :: RTree Braille V2 n Annotation -> Render Braille V2 n
fromRTree (Node RNode Braille V2 n Annotation
n Forest (RNode Braille V2 n Annotation)
rs) = case RNode Braille V2 n Annotation
n of
  RPrim Prim Braille V2 n
p                 -> Braille
-> Prim Braille V2 n
-> Render Braille (V (Prim Braille V2 n)) (N (Prim Braille V2 n))
forall t b. Renderable t b => b -> t -> Render b (V t) (N t)
render Braille
Braille Prim Braille V2 n
p
  RStyle Style V2 n
sty              -> RenderM n () -> Render Braille V2 n
forall n. RenderM n () -> Render Braille V2 n
R (RenderM n () -> Render Braille V2 n)
-> RenderM n () -> Render Braille V2 n
forall a b. (a -> b) -> a -> b
$ (Style V2 n -> Style V2 n) -> RenderM n () -> RenderM n ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Style V2 n -> Style V2 n -> Style V2 n
forall a. Semigroup a => a -> a -> a
<> Style V2 n
sty) RenderM n ()
r
  RNode Braille V2 n Annotation
_                       -> RenderM n () -> Render Braille V2 n
forall n. RenderM n () -> Render Braille V2 n
R RenderM n ()
r
  where R r = (RTree Braille V2 n Annotation -> Render Braille V2 n)
-> Forest (RNode Braille V2 n Annotation) -> Render Braille V2 n
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap RTree Braille V2 n Annotation -> Render Braille V2 n
forall n.
TypeableFloat n =>
RTree Braille V2 n Annotation -> Render Braille V2 n
fromRTree Forest (RNode Braille V2 n Annotation)
rs

runR :: Render Braille V2 n -> RenderM n ()
runR :: Render Braille V2 n -> RenderM n ()
runR (R r) = RenderM n ()
r

instance Semigroup (Render Braille V2 n) where
  R rd1 <> :: Render Braille V2 n -> Render Braille V2 n -> Render Braille V2 n
<> R rd2 = RenderM n () -> Render Braille V2 n
forall n. RenderM n () -> Render Braille V2 n
R (RenderM n () -> Render Braille V2 n)
-> RenderM n () -> Render Braille V2 n
forall a b. (a -> b) -> a -> b
$ RenderM n ()
rd1 RenderM n () -> RenderM n () -> RenderM n ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RenderM n ()
rd2

instance Monoid (Render Braille V2 n) where
  mempty :: Render Braille V2 n
mempty = RenderM n () -> Render Braille V2 n
forall n. RenderM n () -> Render Braille V2 n
R (RenderM n () -> Render Braille V2 n)
-> RenderM n () -> Render Braille V2 n
forall a b. (a -> b) -> a -> b
$ () -> RenderM n ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance Hashable n => Hashable (Options Braille V2 n) where
  hashWithSalt :: Int -> Options Braille V2 n -> Int
hashWithSalt Int
s (BrailleOptions sz) = Int
s Int -> SizeSpec V2 n -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` SizeSpec V2 n
sz

sizeSpec :: Lens' (Options Braille V2 n) (SizeSpec V2 n)
sizeSpec :: (SizeSpec V2 n -> f (SizeSpec V2 n))
-> Options Braille V2 n -> f (Options Braille V2 n)
sizeSpec = (Options Braille V2 n -> SizeSpec V2 n)
-> (Options Braille V2 n -> SizeSpec V2 n -> Options Braille V2 n)
-> Lens
     (Options Braille V2 n)
     (Options Braille V2 n)
     (SizeSpec V2 n)
     (SizeSpec V2 n)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Options Braille V2 n -> SizeSpec V2 n
forall n. Options Braille V2 n -> SizeSpec V2 n
_sizeSpec (\Options Braille V2 n
o SizeSpec V2 n
s -> Options Braille V2 n
R:OptionsBrailleV2n n
o {_sizeSpec :: SizeSpec V2 n
_sizeSpec = SizeSpec V2 n
s})

rasterificStrokeStyle :: TypeableFloat n => Style v n
                     -> (n, R.Join, (R.Cap, R.Cap), Maybe (R.DashPattern, n))
rasterificStrokeStyle :: Style v n -> (n, Join, (Cap, Cap), Maybe (DashPattern, n))
rasterificStrokeStyle Style v n
s = (n
strokeWidth, Join
strokeJoin, (Cap
strokeCap, Cap
strokeCap), Maybe (DashPattern, n)
strokeDash)
  where
    strokeWidth :: n
strokeWidth = LensLike' (Const n) (Style v n) (Maybe n)
-> (Maybe n -> n) -> Style v n -> n
forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views LensLike' (Const n) (Style v n) (Maybe n)
forall n (v :: * -> *). Typeable n => Lens' (Style v n) (Maybe n)
_lineWidthU (n -> Maybe n -> n
forall a. a -> Maybe a -> a
fromMaybe n
1) Style v n
s
    strokeJoin :: Join
strokeJoin  = LensLike' (Const Join) (Style v n) LineJoin
-> (LineJoin -> Join) -> Style v n -> Join
forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views LensLike' (Const Join) (Style v n) LineJoin
forall (v :: * -> *) n. Lens' (Style v n) LineJoin
_lineJoin   LineJoin -> Join
fromLineJoin Style v n
s
    strokeCap :: Cap
strokeCap   = LensLike' (Const Cap) (Style v n) LineCap
-> (LineCap -> Cap) -> Style v n -> Cap
forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views LensLike' (Const Cap) (Style v n) LineCap
forall (v :: * -> *) n. Lens' (Style v n) LineCap
_lineCap    LineCap -> Cap
fromLineCap Style v n
s
    strokeDash :: Maybe (DashPattern, n)
strokeDash  = LensLike'
  (Const (Maybe (DashPattern, n))) (Style v n) (Maybe (Dashing n))
-> (Maybe (Dashing n) -> Maybe (DashPattern, n))
-> Style v n
-> Maybe (DashPattern, n)
forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views LensLike'
  (Const (Maybe (DashPattern, n))) (Style v n) (Maybe (Dashing n))
forall n (v :: * -> *).
Typeable n =>
Lens' (Style v n) (Maybe (Dashing n))
_dashingU   ((Dashing n -> (DashPattern, n))
-> Maybe (Dashing n) -> Maybe (DashPattern, n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dashing n -> (DashPattern, n)
forall n. Real n => Dashing n -> (DashPattern, n)
fromDashing) Style v n
s

fromLineCap :: LineCap -> R.Cap
fromLineCap :: LineCap -> Cap
fromLineCap LineCap
LineCapButt   = Float -> Cap
R.CapStraight Float
0
fromLineCap LineCap
LineCapRound  = Cap
R.CapRound
fromLineCap LineCap
LineCapSquare = Float -> Cap
R.CapStraight Float
1

fromLineJoin :: LineJoin -> R.Join
fromLineJoin :: LineJoin -> Join
fromLineJoin LineJoin
LineJoinMiter = Float -> Join
R.JoinMiter Float
0
fromLineJoin LineJoin
LineJoinRound = Join
R.JoinRound
fromLineJoin LineJoin
LineJoinBevel = Float -> Join
R.JoinMiter Float
1

fromDashing :: Real n => Dashing n -> (R.DashPattern, n)
fromDashing :: Dashing n -> (DashPattern, n)
fromDashing (Dashing [n]
ds n
d) = ((n -> Float) -> [n] -> DashPattern
forall a b. (a -> b) -> [a] -> [b]
map n -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac [n]
ds, n
d)

fromFillRule :: FillRule -> R.FillMethod
fromFillRule :: FillRule -> FillMethod
fromFillRule FillRule
EvenOdd = FillMethod
R.FillEvenOdd
fromFillRule FillRule
_       = FillMethod
R.FillWinding

rasterificColor :: SomeColor -> Double -> PixelRGBA8
rasterificColor :: SomeColor -> Double -> PixelRGBA8
rasterificColor SomeColor
c Double
o = Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 Pixel8
r Pixel8
g Pixel8
b Pixel8
a
  where
    (Pixel8
r, Pixel8
g, Pixel8
b, Pixel8
a) = (Double -> Pixel8
forall a b. (RealFrac a, Integral b) => a -> b
int Double
r', Double -> Pixel8
forall a b. (RealFrac a, Integral b) => a -> b
int Double
g', Double -> Pixel8
forall a b. (RealFrac a, Integral b) => a -> b
int Double
b', Double -> Pixel8
forall a b. (RealFrac a, Integral b) => a -> b
int (Double
o Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
a'))
    (Double
r', Double
g', Double
b', Double
a') = AlphaColour Double -> (Double, Double, Double, Double)
forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA (SomeColor -> AlphaColour Double
forall c. Color c => c -> AlphaColour Double
toAlphaColour SomeColor
c)
    int :: a -> b
int a
x = a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a
255 a -> a -> a
forall a. Num a => a -> a -> a
* a
x)

rasterificSpreadMethod :: SpreadMethod -> R.SamplerRepeat
rasterificSpreadMethod :: SpreadMethod -> SamplerRepeat
rasterificSpreadMethod SpreadMethod
GradPad     = SamplerRepeat
R.SamplerPad
rasterificSpreadMethod SpreadMethod
GradReflect = SamplerRepeat
R.SamplerReflect
rasterificSpreadMethod SpreadMethod
GradRepeat  = SamplerRepeat
R.SamplerRepeat

rasterificStops :: TypeableFloat n => [GradientStop n] -> Gradient PixelRGBA8
rasterificStops :: [GradientStop n] -> Gradient PixelRGBA8
rasterificStops = (GradientStop n -> (Float, PixelRGBA8))
-> [GradientStop n] -> Gradient PixelRGBA8
forall a b. (a -> b) -> [a] -> [b]
map GradientStop n -> (Float, PixelRGBA8)
forall a a.
(Real a, Fractional a) =>
GradientStop a -> (a, PixelRGBA8)
fromStop
  where
    fromStop :: GradientStop a -> (a, PixelRGBA8)
fromStop (GradientStop SomeColor
c a
v) = (a -> a
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
v, SomeColor -> Double -> PixelRGBA8
rasterificColor SomeColor
c Double
1)

rasterificLinearGradient :: TypeableFloat n => LGradient n -> R.Texture PixelRGBA8
rasterificLinearGradient :: LGradient n -> Texture PixelRGBA8
rasterificLinearGradient LGradient n
g = Transformation -> Texture PixelRGBA8 -> Texture PixelRGBA8
forall px. Transformation -> Texture px -> Texture px
transformTexture Transformation
tr Texture PixelRGBA8
tx
  where
    tr :: Transformation
tr = T2 n -> Transformation
forall n. TypeableFloat n => T2 n -> Transformation
rasterificMatTransf (T2 n -> T2 n
forall (v :: * -> *) n.
(Functor v, Num n) =>
Transformation v n -> Transformation v n
inv (T2 n -> T2 n) -> T2 n -> T2 n
forall a b. (a -> b) -> a -> b
$ LGradient n
gLGradient n -> Getting (T2 n) (LGradient n) (T2 n) -> T2 n
forall s a. s -> Getting a s a -> a
^.Getting (T2 n) (LGradient n) (T2 n)
forall n. Lens' (LGradient n) (Transformation V2 n)
lGradTrans)
    tx :: Texture PixelRGBA8
tx = SamplerRepeat -> Texture PixelRGBA8 -> Texture PixelRGBA8
forall px. SamplerRepeat -> Texture px -> Texture px
withSampler SamplerRepeat
spreadMethod (Gradient PixelRGBA8 -> Point -> Point -> Texture PixelRGBA8
forall px. Gradient px -> Point -> Point -> Texture px
linearGradientTexture Gradient PixelRGBA8
gradDef Point
p0 Point
p1)
    spreadMethod :: SamplerRepeat
spreadMethod = SpreadMethod -> SamplerRepeat
rasterificSpreadMethod (LGradient n
gLGradient n
-> Getting SpreadMethod (LGradient n) SpreadMethod -> SpreadMethod
forall s a. s -> Getting a s a -> a
^.Getting SpreadMethod (LGradient n) SpreadMethod
forall n. Lens' (LGradient n) SpreadMethod
lGradSpreadMethod)
    gradDef :: Gradient PixelRGBA8
gradDef = [GradientStop n] -> Gradient PixelRGBA8
forall n.
TypeableFloat n =>
[GradientStop n] -> Gradient PixelRGBA8
rasterificStops (LGradient n
gLGradient n
-> Getting [GradientStop n] (LGradient n) [GradientStop n]
-> [GradientStop n]
forall s a. s -> Getting a s a -> a
^.Getting [GradientStop n] (LGradient n) [GradientStop n]
forall n. Lens' (LGradient n) [GradientStop n]
lGradStops)
    p0 :: Point
p0 = P2 n -> Point
forall n. Real n => P2 n -> Point
p2v2 (LGradient n
gLGradient n -> Getting (P2 n) (LGradient n) (P2 n) -> P2 n
forall s a. s -> Getting a s a -> a
^.Getting (P2 n) (LGradient n) (P2 n)
forall n. Lens' (LGradient n) (Point V2 n)
lGradStart)
    p1 :: Point
p1 = P2 n -> Point
forall n. Real n => P2 n -> Point
p2v2 (LGradient n
gLGradient n -> Getting (P2 n) (LGradient n) (P2 n) -> P2 n
forall s a. s -> Getting a s a -> a
^.Getting (P2 n) (LGradient n) (P2 n)
forall n. Lens' (LGradient n) (Point V2 n)
lGradEnd)

rasterificRadialGradient :: TypeableFloat n => RGradient n -> R.Texture PixelRGBA8
rasterificRadialGradient :: RGradient n -> Texture PixelRGBA8
rasterificRadialGradient RGradient n
g = Transformation -> Texture PixelRGBA8 -> Texture PixelRGBA8
forall px. Transformation -> Texture px -> Texture px
transformTexture Transformation
tr Texture PixelRGBA8
tx
  where
    tr :: Transformation
tr = T2 n -> Transformation
forall n. TypeableFloat n => T2 n -> Transformation
rasterificMatTransf (T2 n -> T2 n
forall (v :: * -> *) n.
(Functor v, Num n) =>
Transformation v n -> Transformation v n
inv (T2 n -> T2 n) -> T2 n -> T2 n
forall a b. (a -> b) -> a -> b
$ RGradient n
gRGradient n -> Getting (T2 n) (RGradient n) (T2 n) -> T2 n
forall s a. s -> Getting a s a -> a
^.Getting (T2 n) (RGradient n) (T2 n)
forall n. Lens' (RGradient n) (Transformation V2 n)
rGradTrans)
    tx :: Texture PixelRGBA8
tx = SamplerRepeat -> Texture PixelRGBA8 -> Texture PixelRGBA8
forall px. SamplerRepeat -> Texture px -> Texture px
withSampler SamplerRepeat
spreadMethod (Gradient PixelRGBA8
-> Point -> Float -> Point -> Texture PixelRGBA8
forall px. Gradient px -> Point -> Float -> Point -> Texture px
radialGradientWithFocusTexture Gradient PixelRGBA8
gradDef Point
c (n -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac n
r1) Point
f)
    spreadMethod :: SamplerRepeat
spreadMethod = SpreadMethod -> SamplerRepeat
rasterificSpreadMethod (RGradient n
gRGradient n
-> Getting SpreadMethod (RGradient n) SpreadMethod -> SpreadMethod
forall s a. s -> Getting a s a -> a
^.Getting SpreadMethod (RGradient n) SpreadMethod
forall n. Lens' (RGradient n) SpreadMethod
rGradSpreadMethod)
    c :: Point
c = P2 n -> Point
forall n. Real n => P2 n -> Point
p2v2 (RGradient n
gRGradient n -> Getting (P2 n) (RGradient n) (P2 n) -> P2 n
forall s a. s -> Getting a s a -> a
^.Getting (P2 n) (RGradient n) (P2 n)
forall n. Lens' (RGradient n) (Point V2 n)
rGradCenter1)
    f :: Point
f = P2 n -> Point
forall n. Real n => P2 n -> Point
p2v2 (RGradient n
gRGradient n -> Getting (P2 n) (RGradient n) (P2 n) -> P2 n
forall s a. s -> Getting a s a -> a
^.Getting (P2 n) (RGradient n) (P2 n)
forall n. Lens' (RGradient n) (Point V2 n)
rGradCenter0)
    gradDef :: Gradient PixelRGBA8
gradDef = [GradientStop n] -> Gradient PixelRGBA8
forall n.
TypeableFloat n =>
[GradientStop n] -> Gradient PixelRGBA8
rasterificStops [GradientStop n]
ss

    -- Adjust the stops so that the gradient begins at the perimeter of
    -- the inner circle (center0, radius0) and ends at the outer circle.
    r0 :: n
r0 = RGradient n
gRGradient n -> Getting n (RGradient n) n -> n
forall s a. s -> Getting a s a -> a
^.Getting n (RGradient n) n
forall n. Lens' (RGradient n) n
rGradRadius0
    r1 :: n
r1 = RGradient n
gRGradient n -> Getting n (RGradient n) n -> n
forall s a. s -> Getting a s a -> a
^.Getting n (RGradient n) n
forall n. Lens' (RGradient n) n
rGradRadius1
    stopFracs :: [n]
stopFracs = n
r0 n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
r1 n -> [n] -> [n]
forall a. a -> [a] -> [a]
: (GradientStop n -> n) -> [GradientStop n] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map (\GradientStop n
s -> (n
r0 n -> n -> n
forall a. Num a => a -> a -> a
+ (GradientStop n
sGradientStop n -> Getting n (GradientStop n) n -> n
forall s a. s -> Getting a s a -> a
^.Getting n (GradientStop n) n
forall n. Lens' (GradientStop n) n
stopFraction) n -> n -> n
forall a. Num a => a -> a -> a
* (n
r1 n -> n -> n
forall a. Num a => a -> a -> a
- n
r0)) n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
r1)
                (RGradient n
gRGradient n
-> Getting [GradientStop n] (RGradient n) [GradientStop n]
-> [GradientStop n]
forall s a. s -> Getting a s a -> a
^.Getting [GradientStop n] (RGradient n) [GradientStop n]
forall n. Lens' (RGradient n) [GradientStop n]
rGradStops)
    gradStops :: [GradientStop n]
gradStops = case RGradient n
gRGradient n
-> Getting [GradientStop n] (RGradient n) [GradientStop n]
-> [GradientStop n]
forall s a. s -> Getting a s a -> a
^.Getting [GradientStop n] (RGradient n) [GradientStop n]
forall n. Lens' (RGradient n) [GradientStop n]
rGradStops of
      []       -> []
      xs :: [GradientStop n]
xs@(GradientStop n
x:[GradientStop n]
_) -> GradientStop n
x GradientStop n -> [GradientStop n] -> [GradientStop n]
forall a. a -> [a] -> [a]
: [GradientStop n]
xs
    ss :: [GradientStop n]
ss = (GradientStop n -> n -> GradientStop n)
-> [GradientStop n] -> [n] -> [GradientStop n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\GradientStop n
gs n
sf -> GradientStop n
gs GradientStop n
-> (GradientStop n -> GradientStop n) -> GradientStop n
forall a b. a -> (a -> b) -> b
& (n -> Identity n) -> GradientStop n -> Identity (GradientStop n)
forall n. Lens' (GradientStop n) n
stopFraction ((n -> Identity n) -> GradientStop n -> Identity (GradientStop n))
-> n -> GradientStop n -> GradientStop n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ n
sf ) [GradientStop n]
gradStops [n]
stopFracs

-- Convert a diagrams @Texture@ and opacity to a rasterific texture.
rasterificTexture :: TypeableFloat n => Texture n -> Double -> R.Texture PixelRGBA8
rasterificTexture :: Texture n -> Double -> Texture PixelRGBA8
rasterificTexture (SC SomeColor
c) Double
o = PixelRGBA8 -> Texture PixelRGBA8
forall px. px -> Texture px
uniformTexture (PixelRGBA8 -> Texture PixelRGBA8)
-> PixelRGBA8 -> Texture PixelRGBA8
forall a b. (a -> b) -> a -> b
$ SomeColor -> Double -> PixelRGBA8
rasterificColor SomeColor
c Double
o
rasterificTexture (LG LGradient n
g) Double
_ = LGradient n -> Texture PixelRGBA8
forall n. TypeableFloat n => LGradient n -> Texture PixelRGBA8
rasterificLinearGradient LGradient n
g
rasterificTexture (RG RGradient n
g) Double
_ = RGradient n -> Texture PixelRGBA8
forall n. TypeableFloat n => RGradient n -> Texture PixelRGBA8
rasterificRadialGradient RGradient n
g

p2v2 :: Real n => P2 n -> R.Point
p2v2 :: P2 n -> Point
p2v2 (P V2 n
v) = V2 n -> Point
forall n. Real n => V2 n -> Point
r2v2 V2 n
v
{-# INLINE p2v2 #-}

r2v2 :: Real n => V2 n -> R.Point
r2v2 :: V2 n -> Point
r2v2 (V2 n
x n
y) = Float -> Float -> Point
forall a. a -> a -> V2 a
R.V2 (n -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac n
x) (n -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac n
y)
{-# INLINE r2v2 #-}

rv2 :: (Real n, Fractional n) => Iso' R.Point (P2 n)
rv2 :: Iso' Point (P2 n)
rv2 = (Point -> V2 n) -> (V2 n -> Point) -> Iso Point Point (V2 n) (V2 n)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(R.V2 Float
x Float
y) -> n -> n -> V2 n
forall a. a -> a -> V2 a
V2 (Float -> n
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
x) (Float -> n
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
y)) V2 n -> Point
forall n. Real n => V2 n -> Point
r2v2 (p (V2 n) (f (V2 n)) -> p Point (f Point))
-> (p (P2 n) (f (P2 n)) -> p (V2 n) (f (V2 n)))
-> p (P2 n) (f (P2 n))
-> p Point (f Point)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnIso (P2 n) (P2 n) (V2 n) (V2 n)
-> Iso (V2 n) (V2 n) (P2 n) (P2 n)
forall s t a b. AnIso s t a b -> Iso b a t s
from AnIso (P2 n) (P2 n) (V2 n) (V2 n)
forall (f :: * -> *) a. Iso' (Point f a) (f a)
_Point
{-# INLINE rv2 #-}

rasterificPtTransf :: TypeableFloat n => T2 n -> R.Point -> R.Point
rasterificPtTransf :: T2 n -> Point -> Point
rasterificPtTransf T2 n
t = ASetter Point Point (Point V2 n) (Point V2 n)
-> (Point V2 n -> Point V2 n) -> Point -> Point
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Point Point (Point V2 n) (Point V2 n)
forall n. (Real n, Fractional n) => Iso' Point (P2 n)
rv2 (T2 n -> Point V2 n -> Point V2 n
forall (v :: * -> *) n.
(Additive v, Num n) =>
Transformation v n -> Point v n -> Point v n
papply T2 n
t)

rasterificMatTransf :: TypeableFloat n => T2 n -> R.Transformation
rasterificMatTransf :: T2 n -> Transformation
rasterificMatTransf T2 n
tr = Float
-> Float -> Float -> Float -> Float -> Float -> Transformation
R.Transformation Float
a Float
c Float
e Float
b Float
d Float
f
  where
    [[Float
a, Float
b], [Float
c, Float
d], [Float
e, Float
f]] = (n -> Float) -> [n] -> DashPattern
forall a b. (a -> b) -> [a] -> [b]
map n -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac ([n] -> DashPattern) -> [[n]] -> [DashPattern]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> T2 n -> [[n]]
forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> [[n]]
matrixHomRep T2 n
tr

-- Note: Using view patterns confuses ghc to think there are missing patterns,
-- so we avoid them here.
renderSeg :: TypeableFloat n => Located (Segment Closed V2 n) -> R.Primitive
renderSeg :: Located (Segment Closed V2 n) -> Primitive
renderSeg Located (Segment Closed V2 n)
l =
  case Located (Segment Closed V2 n)
-> (Point (V (Segment Closed V2 n)) (N (Segment Closed V2 n)),
    Segment Closed V2 n)
forall a. Located a -> (Point (V a) (N a), a)
viewLoc Located (Segment Closed V2 n)
l of
    (Point (V (Segment Closed V2 n)) (N (Segment Closed V2 n))
p, Linear (OffsetClosed V2 n
v)) ->
      Line -> Primitive
R.LinePrim (Line -> Primitive) -> Line -> Primitive
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Line
R.Line Point
p' (Point
p' Point -> Point -> Point
forall a. Num a => a -> a -> a
+ V2 n -> Point
forall n. Real n => V2 n -> Point
r2v2 V2 n
v)
      where
        p' :: Point
p' = P2 n -> Point
forall n. Real n => P2 n -> Point
p2v2 Point (V (Segment Closed V2 n)) (N (Segment Closed V2 n))
P2 n
p
    (Point (V (Segment Closed V2 n)) (N (Segment Closed V2 n))
p, Cubic V2 n
u1 V2 n
u2 (OffsetClosed V2 n
u3)) ->
      CubicBezier -> Primitive
R.CubicBezierPrim (CubicBezier -> Primitive) -> CubicBezier -> Primitive
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Point -> Point -> CubicBezier
R.CubicBezier Point
q0 Point
q1 Point
q2 Point
q3
      where
        (Point
q0, Point
q1, Point
q2, Point
q3) = (P2 n -> Point
forall n. Real n => P2 n -> Point
p2v2 Point (V (Segment Closed V2 n)) (N (Segment Closed V2 n))
P2 n
p, Point
q0 Point -> Point -> Point
forall a. Num a => a -> a -> a
+ V2 n -> Point
forall n. Real n => V2 n -> Point
r2v2 V2 n
u1, Point
q0 Point -> Point -> Point
forall a. Num a => a -> a -> a
+ V2 n -> Point
forall n. Real n => V2 n -> Point
r2v2 V2 n
u2, Point
q0 Point -> Point -> Point
forall a. Num a => a -> a -> a
+ V2 n -> Point
forall n. Real n => V2 n -> Point
r2v2 V2 n
u3)

renderPath :: TypeableFloat n => Path V2 n -> [[R.Primitive]]
renderPath :: Path V2 n -> [[Primitive]]
renderPath Path V2 n
p = (([Located (Segment Closed V2 n)] -> [Primitive])
-> [[Located (Segment Closed V2 n)]] -> [[Primitive]]
forall a b. (a -> b) -> [a] -> [b]
map (([Located (Segment Closed V2 n)] -> [Primitive])
 -> [[Located (Segment Closed V2 n)]] -> [[Primitive]])
-> ((Located (Segment Closed V2 n) -> Primitive)
    -> [Located (Segment Closed V2 n)] -> [Primitive])
-> (Located (Segment Closed V2 n) -> Primitive)
-> [[Located (Segment Closed V2 n)]]
-> [[Primitive]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located (Segment Closed V2 n) -> Primitive)
-> [Located (Segment Closed V2 n)] -> [Primitive]
forall a b. (a -> b) -> [a] -> [b]
map) Located (Segment Closed V2 n) -> Primitive
forall n.
TypeableFloat n =>
Located (Segment Closed V2 n) -> Primitive
renderSeg (Path V2 n -> [[Located (Segment Closed V2 n)]]
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Path v n -> [[Located (Segment Closed v n)]]
pathLocSegments Path V2 n
p)

-- Stroke both dashed and solid lines.
mkStroke :: TypeableFloat n => n ->  R.Join -> (R.Cap, R.Cap) -> Maybe (R.DashPattern, n)
      -> [[R.Primitive]] -> R.Drawing PixelRGBA8 ()
mkStroke :: n
-> Join
-> (Cap, Cap)
-> Maybe (DashPattern, n)
-> [[Primitive]]
-> Drawing PixelRGBA8 ()
mkStroke (n -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac -> Float
l) Join
j (Cap, Cap)
c Maybe (DashPattern, n)
d [[Primitive]]
primList =
  Drawing PixelRGBA8 ()
-> ((DashPattern, n) -> Drawing PixelRGBA8 ())
-> Maybe (DashPattern, n)
-> Drawing PixelRGBA8 ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Float -> Join -> (Cap, Cap) -> [Primitive] -> Drawing PixelRGBA8 ()
forall geom px.
Geometry geom =>
Float -> Join -> (Cap, Cap) -> geom -> Drawing px ()
R.stroke Float
l Join
j (Cap, Cap)
c ([Primitive] -> Drawing PixelRGBA8 ())
-> [Primitive] -> Drawing PixelRGBA8 ()
forall a b. (a -> b) -> a -> b
$ [[Primitive]] -> [Primitive]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Primitive]]
primList)
        (\(DashPattern
dsh, n
off) -> Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> [Primitive]
-> Drawing PixelRGBA8 ()
forall geom px.
Geometry geom =>
Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> geom
-> Drawing px ()
R.dashedStrokeWithOffset (n -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac n
off) DashPattern
dsh Float
l Join
j (Cap, Cap)
c ([Primitive] -> Drawing PixelRGBA8 ())
-> [Primitive] -> Drawing PixelRGBA8 ()
forall a b. (a -> b) -> a -> b
$ [[Primitive]] -> [Primitive]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Primitive]]
primList)
        Maybe (DashPattern, n)
d

instance TypeableFloat n => Renderable (Path V2 n) Braille where
  render :: Braille
-> Path V2 n -> Render Braille (V (Path V2 n)) (N (Path V2 n))
render Braille
_ Path V2 n
p = RenderM n () -> Render Braille V2 n
forall n. RenderM n () -> Render Braille V2 n
R (RenderM n () -> Render Braille V2 n)
-> RenderM n () -> Render Braille V2 n
forall a b. (a -> b) -> a -> b
$ do
    Style V2 n
sty <- ReaderT (Style V2 n) (Writer Draw) (Style V2 n)
forall r (m :: * -> *). MonadReader r m => m r
ask
    let f :: Texture n
f = Style V2 n
sty Style V2 n
-> Getting (Texture n) (Style V2 n) (Texture n) -> Texture n
forall s a. s -> Getting a s a -> a
^. Getting (Texture n) (Style V2 n) (Texture n)
forall n.
(Typeable n, Floating n) =>
Lens' (Style V2 n) (Texture n)
_fillTexture
        s :: Texture n
s = Style V2 n
sty Style V2 n
-> Getting (Texture n) (Style V2 n) (Texture n) -> Texture n
forall s a. s -> Getting a s a -> a
^. Getting (Texture n) (Style V2 n) (Texture n)
forall n.
(Floating n, Typeable n) =>
Lens' (Style V2 n) (Texture n)
_lineTexture
        o :: Double
o = Style V2 n
sty Style V2 n -> Getting Double (Style V2 n) Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double (Style V2 n) Double
forall (v :: * -> *) n. Lens' (Style v n) Double
_opacity
        r :: FillRule
r = Style V2 n
sty Style V2 n -> Getting FillRule (Style V2 n) FillRule -> FillRule
forall s a. s -> Getting a s a -> a
^. Getting FillRule (Style V2 n) FillRule
forall n. Lens' (Style V2 n) FillRule
_fillRule

        (n
l, Join
j, (Cap, Cap)
c, Maybe (DashPattern, n)
d) = Style V2 n -> (n, Join, (Cap, Cap), Maybe (DashPattern, n))
forall n (v :: * -> *).
TypeableFloat n =>
Style v n -> (n, Join, (Cap, Cap), Maybe (DashPattern, n))
rasterificStrokeStyle Style V2 n
sty
        canFill :: Bool
canFill      = Getting Any (Path V2 n) (Trail V2 n)
-> (Trail V2 n -> Bool) -> Path V2 n -> Bool
forall s a. Getting Any s a -> (a -> Bool) -> s -> Bool
anyOf ((Located (Trail V2 n) -> Const Any (Located (Trail V2 n)))
-> Path V2 n -> Const Any (Path V2 n)
forall s a. Cons s s a a => Traversal' s a
_head ((Located (Trail V2 n) -> Const Any (Located (Trail V2 n)))
 -> Path V2 n -> Const Any (Path V2 n))
-> ((Trail V2 n -> Const Any (Trail V2 n))
    -> Located (Trail V2 n) -> Const Any (Located (Trail V2 n)))
-> Getting Any (Path V2 n) (Trail V2 n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Trail V2 n -> Const Any (Trail V2 n))
-> Located (Trail V2 n) -> Const Any (Located (Trail V2 n))
forall a b. SameSpace a b => Lens (Located a) (Located b) a b
located) Trail V2 n -> Bool
forall (v :: * -> *) n. Trail v n -> Bool
isLoop Path V2 n
p Bool -> Bool -> Bool
&& (Texture n
f Texture n
-> Getting
     (First (AlphaColour Double)) (Texture n) (AlphaColour Double)
-> Maybe (AlphaColour Double)
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting
  (First (AlphaColour Double)) (Texture n) (AlphaColour Double)
forall n. Prism' (Texture n) (AlphaColour Double)
_AC) Maybe (AlphaColour Double) -> Maybe (AlphaColour Double) -> Bool
forall a. Eq a => a -> a -> Bool
/= AlphaColour Double -> Maybe (AlphaColour Double)
forall a. a -> Maybe a
Just AlphaColour Double
forall a. Num a => AlphaColour a
transparent
        rule :: FillMethod
rule         = FillRule -> FillMethod
fromFillRule FillRule
r

        -- For stroking we need to keep all of the contours separate.
        primList :: [[Primitive]]
primList = Path V2 n -> [[Primitive]]
forall n. TypeableFloat n => Path V2 n -> [[Primitive]]
renderPath Path V2 n
p

        -- For filling we need to concatenate them into a flat list.
        prms :: [Primitive]
prms = [[Primitive]] -> [Primitive]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Primitive]]
primList

    Bool -> RenderM n () -> RenderM n ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
canFill (RenderM n () -> RenderM n ()) -> RenderM n () -> RenderM n ()
forall a b. (a -> b) -> a -> b
$
      Drawing PixelRGBA8 () -> RenderM n ()
forall n. Drawing PixelRGBA8 () -> RenderM n ()
tellR (Texture PixelRGBA8
-> Drawing PixelRGBA8 () -> Drawing PixelRGBA8 ()
forall px. Texture px -> Drawing px () -> Drawing px ()
R.withTexture (Texture n -> Double -> Texture PixelRGBA8
forall n.
TypeableFloat n =>
Texture n -> Double -> Texture PixelRGBA8
rasterificTexture Texture n
f Double
o) (Drawing PixelRGBA8 () -> Drawing PixelRGBA8 ())
-> Drawing PixelRGBA8 () -> Drawing PixelRGBA8 ()
forall a b. (a -> b) -> a -> b
$ FillMethod -> [Primitive] -> Drawing PixelRGBA8 ()
forall geom px.
Geometry geom =>
FillMethod -> geom -> Drawing px ()
R.fillWithMethod FillMethod
rule [Primitive]
prms)

    Drawing PixelRGBA8 () -> RenderM n ()
forall n. Drawing PixelRGBA8 () -> RenderM n ()
tellR (Texture PixelRGBA8
-> Drawing PixelRGBA8 () -> Drawing PixelRGBA8 ()
forall px. Texture px -> Drawing px () -> Drawing px ()
R.withTexture (Texture n -> Double -> Texture PixelRGBA8
forall n.
TypeableFloat n =>
Texture n -> Double -> Texture PixelRGBA8
rasterificTexture Texture n
s Double
o) (Drawing PixelRGBA8 () -> Drawing PixelRGBA8 ())
-> Drawing PixelRGBA8 () -> Drawing PixelRGBA8 ()
forall a b. (a -> b) -> a -> b
$ n
-> Join
-> (Cap, Cap)
-> Maybe (DashPattern, n)
-> [[Primitive]]
-> Drawing PixelRGBA8 ()
forall n.
TypeableFloat n =>
n
-> Join
-> (Cap, Cap)
-> Maybe (DashPattern, n)
-> [[Primitive]]
-> Drawing PixelRGBA8 ()
mkStroke n
l Join
j (Cap, Cap)
c Maybe (DashPattern, n)
d [[Primitive]]
primList)

instance TypeableFloat n => Renderable (Text n) Braille where
  render :: Braille -> Text n -> Render Braille (V (Text n)) (N (Text n))
render Braille
_ (Text T2 n
tr TextAlignment n
al String
str) = RenderM n () -> Render Braille V2 n
forall n. RenderM n () -> Render Braille V2 n
R (RenderM n () -> Render Braille V2 n)
-> RenderM n () -> Render Braille V2 n
forall a b. (a -> b) -> a -> b
$ do
    n
fs    <- LensLike' (Const n) (Style V2 n) (Maybe n)
-> (Maybe n -> n) -> ReaderT (Style V2 n) (Writer Draw) n
forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views LensLike' (Const n) (Style V2 n) (Maybe n)
forall n (v :: * -> *). Typeable n => Lens' (Style v n) (Maybe n)
_fontSizeU (n -> Maybe n -> n
forall a. a -> Maybe a -> a
fromMaybe n
12)
    FontSlant
slant <- Getting FontSlant (Style V2 n) FontSlant
-> ReaderT (Style V2 n) (Writer Draw) FontSlant
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FontSlant (Style V2 n) FontSlant
forall (v :: * -> *) n. Lens' (Style v n) FontSlant
_fontSlant
    FontWeight
fw    <- Getting FontWeight (Style V2 n) FontWeight
-> ReaderT (Style V2 n) (Writer Draw) FontWeight
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FontWeight (Style V2 n) FontWeight
forall (v :: * -> *) n. Lens' (Style v n) FontWeight
_fontWeight
    let fs' :: PointSize
fs'    = Float -> PointSize
R.PointSize (n -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac n
fs)
        fnt :: Font
fnt    = FontSlant -> FontWeight -> Font
fromFontStyle FontSlant
slant FontWeight
fw
        bb :: BoundingBox V2 n
bb     = Font -> PointSize -> String -> BoundingBox V2 n
forall n.
RealFloat n =>
Font -> PointSize -> String -> BoundingBox V2 n
textBoundingBox Font
fnt PointSize
fs' String
str
        P (V2 n
x n
y) = Transformation (V (Point V2 n)) (N (Point V2 n))
-> Point V2 n -> Point V2 n
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Point V2 n)) (N (Point V2 n))
T2 n
tr (Point V2 n -> Point V2 n) -> Point V2 n -> Point V2 n
forall a b. (a -> b) -> a -> b
$ case TextAlignment n
al of
          TextAlignment n
BaselineText         -> PrevDim (Point V2 n)
0 PrevDim (Point V2 n) -> FinalCoord (Point V2 n) -> Point V2 n
forall c. Coordinates c => PrevDim c -> FinalCoord c -> c
^& FinalCoord (Point V2 n)
0
          BoxAlignedText n
xt n
yt -> case BoundingBox V2 n -> Maybe (Point V2 n, Point V2 n)
forall (v :: * -> *) n.
BoundingBox v n -> Maybe (Point v n, Point v n)
getCorners BoundingBox V2 n
bb of
            Just (P (V2 n
xl n
yl), P (V2 n
xu n
yu)) -> (-n -> n -> n -> n
forall a b. (Real a, Fractional b) => a -> a -> a -> b
lerp' n
xt n
xu n
xl) PrevDim (Point V2 n) -> FinalCoord (Point V2 n) -> Point V2 n
forall c. Coordinates c => PrevDim c -> FinalCoord c -> c
^& n -> n -> n -> n
forall a b. (Real a, Fractional b) => a -> a -> a -> b
lerp' n
yt n
yu n
yl
            Maybe (Point V2 n, Point V2 n)
Nothing                           -> PrevDim (Point V2 n)
0 PrevDim (Point V2 n) -> FinalCoord (Point V2 n) -> Point V2 n
forall c. Coordinates c => PrevDim c -> FinalCoord c -> c
^& FinalCoord (Point V2 n)
0
    Int -> Int -> String -> RenderM n ()
forall n. Int -> Int -> String -> RenderM n ()
tellT (n -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (n -> Int) -> n -> Int
forall a b. (a -> b) -> a -> b
$ n
x n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2) (n -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (n -> Int) -> n -> Int
forall a b. (a -> b) -> a -> b
$ n
y n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
4) String
str
    where
      lerp' :: a -> a -> a -> b
lerp' a
t a
u a
v = a -> b
forall a b. (Real a, Fractional b) => a -> b
realToFrac (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
t a -> a -> a
forall a. Num a => a -> a -> a
* a
u a -> a -> a
forall a. Num a => a -> a -> a
+ (a
1 a -> a -> a
forall a. Num a => a -> a -> a
- a
t) a -> a -> a
forall a. Num a => a -> a -> a
* a
v

toImageRGBA8 :: DynamicImage -> Image PixelRGBA8
toImageRGBA8 :: DynamicImage -> Image PixelRGBA8
toImageRGBA8 (ImageRGBA8 Image PixelRGBA8
i)  = Image PixelRGBA8
i
toImageRGBA8 (ImageRGB8 Image PixelRGB8
i)   = Image PixelRGB8 -> Image PixelRGBA8
forall a b. ColorConvertible a b => Image a -> Image b
promoteImage Image PixelRGB8
i
toImageRGBA8 (ImageYCbCr8 Image PixelYCbCr8
i) = Image PixelRGB8 -> Image PixelRGBA8
forall a b. ColorConvertible a b => Image a -> Image b
promoteImage (Image PixelYCbCr8 -> Image PixelRGB8
forall a b. ColorSpaceConvertible a b => Image a -> Image b
convertImage Image PixelYCbCr8
i :: Image PixelRGB8)
toImageRGBA8 (ImageY8 Image Pixel8
i)     = Image Pixel8 -> Image PixelRGBA8
forall a b. ColorConvertible a b => Image a -> Image b
promoteImage Image Pixel8
i
toImageRGBA8 (ImageYA8 Image PixelYA8
i)    = Image PixelYA8 -> Image PixelRGBA8
forall a b. ColorConvertible a b => Image a -> Image b
promoteImage Image PixelYA8
i
toImageRGBA8 (ImageCMYK8 Image PixelCMYK8
i)  = Image PixelRGB8 -> Image PixelRGBA8
forall a b. ColorConvertible a b => Image a -> Image b
promoteImage (Image PixelCMYK8 -> Image PixelRGB8
forall a b. ColorSpaceConvertible a b => Image a -> Image b
convertImage Image PixelCMYK8
i :: Image PixelRGB8)
toImageRGBA8 DynamicImage
_               = String -> Image PixelRGBA8
forall a. HasCallStack => String -> a
error String
"Unsupported Pixel type"

instance TypeableFloat n => Renderable (DImage n Embedded) Braille where
  render :: Braille
-> DImage n Embedded
-> Render Braille (V (DImage n Embedded)) (N (DImage n Embedded))
render Braille
_ (DImage ImageData Embedded
iD Int
w Int
h Transformation V2 n
tr) = RenderM n () -> Render Braille V2 n
forall n. RenderM n () -> Render Braille V2 n
R (RenderM n () -> Render Braille V2 n)
-> RenderM n () -> Render Braille V2 n
forall a b. (a -> b) -> a -> b
$ Drawing PixelRGBA8 () -> RenderM n ()
forall n. Drawing PixelRGBA8 () -> RenderM n ()
tellR
                               (Transformation -> Drawing PixelRGBA8 () -> Drawing PixelRGBA8 ()
forall px. Transformation -> Drawing px () -> Drawing px ()
R.withTransformation
                               (Transformation V2 n -> Transformation
forall n. TypeableFloat n => T2 n -> Transformation
rasterificMatTransf (Transformation V2 n
tr Transformation V2 n -> Transformation V2 n -> Transformation V2 n
forall a. Semigroup a => a -> a -> a
<> Transformation V2 n
forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
Transformation v n
reflectionY))
                               (Image PixelRGBA8 -> Float -> Point -> Drawing PixelRGBA8 ()
forall px. Image px -> Float -> Point -> Drawing px ()
R.drawImage Image PixelRGBA8
img Float
0 Point
p))
    where
      ImageRaster DynamicImage
dImg = ImageData Embedded
iD
      img :: Image PixelRGBA8
img = DynamicImage -> Image PixelRGBA8
toImageRGBA8 DynamicImage
dImg
      trl :: Transformation V2 n
trl = V2 n -> Transformation V2 n -> Transformation V2 n
forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, HasOrigin t) =>
v n -> t -> t
moveOriginBy ((n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2, Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2 :: n)) Transformation V2 n
forall a. Monoid a => a
mempty
      p :: Point
p   = Transformation V2 n -> Point -> Point
forall n. TypeableFloat n => T2 n -> Point -> Point
rasterificPtTransf Transformation V2 n
trl (Float -> Float -> Point
forall a. a -> a -> V2 a
R.V2 Float
0 Float
0)

-- Saving files --------------------------------------------------------

rasterBraille :: SizeSpec V2 n -> QDiagram Braille V2 n m -> Result Braille V2 n
rasterBraille SizeSpec V2 n
sz = Braille
-> Options Braille V2 n
-> QDiagram Braille V2 n m
-> Result Braille V2 n
forall b (v :: * -> *) n m.
(Backend b v n, HasLinearMap v, Metric v, Typeable n,
 OrderedField n, Monoid' m) =>
b -> Options b v n -> QDiagram b v n m -> Result b v n
renderDia Braille
Braille (SizeSpec V2 n -> Options Braille V2 n
forall n. SizeSpec V2 n -> Options Braille V2 n
BrailleOptions SizeSpec V2 n
sz)

-- | Render a 'Braille' diagram to a file with the given size. The
--   format is determined by the extension (@.png@, @.tif@, @.bmp@, @.jpg@ and
--   @.pdf@ supported.
renderBraille :: TypeableFloat n => FilePath -> SizeSpec V2 n
              -> QDiagram Braille V2 n Any -> IO ()
renderBraille :: String -> SizeSpec V2 n -> QDiagram Braille V2 n Any -> IO ()
renderBraille String
outFile SizeSpec V2 n
spec QDiagram Braille V2 n Any
d =
  case ShowS
takeExtension String
outFile of
    String
_      -> String -> String -> IO ()
writeBrl String
outFile String
Result Braille V2 n
brl
  where
    brl :: Result Braille V2 n
brl = Braille
-> Options Braille V2 n
-> QDiagram Braille V2 n Any
-> Result Braille V2 n
forall b (v :: * -> *) n m.
(Backend b v n, HasLinearMap v, Metric v, Typeable n,
 OrderedField n, Monoid' m) =>
b -> Options b v n -> QDiagram b v n m -> Result b v n
renderDia Braille
Braille (SizeSpec V2 n -> Options Braille V2 n
forall n. SizeSpec V2 n -> Options Braille V2 n
BrailleOptions SizeSpec V2 n
spec) QDiagram Braille V2 n Any
d

writeBrl :: String -> String -> IO ()
writeBrl = String -> String -> IO ()
writeFile

img2brl :: Image PixelRGBA8 -> String
img2brl = Int -> (PixelRGBA8 -> Bool) -> Image PixelRGBA8 -> String
forall t. Pixel t => Int -> (t -> Bool) -> Image t -> String
img2brl' Int
8 PixelRGBA8 -> Bool
f where
  f :: PixelRGBA8 -> Bool
f (PixelRGBA8 Pixel8
_ Pixel8
_ Pixel8
_ Pixel8
a) | Pixel8
a Pixel8 -> Pixel8 -> Bool
forall a. Ord a => a -> a -> Bool
> Pixel8
20 = Bool
True
  f PixelRGBA8
_ = Bool
False

img2brl' :: Int -> (t -> Bool) -> Image t -> String
img2brl' Int
dots t -> Bool
c Image t
img = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                      (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
y -> (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Char
f Int
y) [Int]
columnIndices) [Int]
lineIndices where
  f :: Int -> Int -> Char
f Int
y Int
x = Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ ((Int -> Int) -> Int -> Int) -> Int -> [Int -> Int] -> Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
($) Int
0x2800 ([Int -> Int] -> Int) -> [Int -> Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int -> [Int -> Int] -> [Int -> Int]
forall a. Int -> [a] -> [a]
take Int
dots ([Int -> Int] -> [Int -> Int]) -> [Int -> Int] -> [Int -> Int]
forall a b. (a -> b) -> a -> b
$ ((Int -> Int -> Int) -> Int -> Int -> Int)
-> [Int -> Int -> Int] -> [Int] -> [Int -> Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> Int -> Int) -> Int -> Int -> Int
forall a b. (a -> b) -> a -> b
($) [
                                    Int -> Int -> Bool -> Int -> Int -> Int
g Int
y Int
x       Bool
True
    , let y' :: Int
y' = Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 in               Int -> Int -> Bool -> Int -> Int -> Int
g Int
y' Int
x    (Bool -> Int -> Int -> Int) -> Bool -> Int -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
y' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
h
    , let y'' :: Int
y'' = Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2 in              Int -> Int -> Bool -> Int -> Int -> Int
g Int
y'' Int
x   (Bool -> Int -> Int -> Int) -> Bool -> Int -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
y'' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
h
    , let x' :: Int
x' = Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 in               Int -> Int -> Bool -> Int -> Int -> Int
g Int
y Int
x'    (Bool -> Int -> Int -> Int) -> Bool -> Int -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
x' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
w
    , let {y' :: Int
y' = Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1; x' :: Int
x' = Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1} in   Int -> Int -> Bool -> Int -> Int -> Int
g Int
y' Int
x'   (Bool -> Int -> Int -> Int) -> Bool -> Int -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
y' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
h Bool -> Bool -> Bool
&& Int
x' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
w
    , let {y'' :: Int
y'' = Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2; x' :: Int
x' = Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1} in  Int -> Int -> Bool -> Int -> Int -> Int
g Int
y'' Int
x'  (Bool -> Int -> Int -> Int) -> Bool -> Int -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
y'' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
h Bool -> Bool -> Bool
&& Int
x' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
w
    , let y''' :: Int
y''' = Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3 in             Int -> Int -> Bool -> Int -> Int -> Int
g Int
y''' Int
x  (Bool -> Int -> Int -> Int) -> Bool -> Int -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
y''' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
h
    , let {y''' :: Int
y''' = Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3; x' :: Int
x' = Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1} in Int -> Int -> Bool -> Int -> Int -> Int
g Int
y''' Int
x' (Bool -> Int -> Int -> Int) -> Bool -> Int -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
y''' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
h Bool -> Bool -> Bool
&& Int
x' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
w] [Int
0..]
  g :: Int -> Int -> Bool -> Int -> Int -> Int
g Int
y Int
x Bool
True Int
b Int
a | t -> Bool
c (t -> Bool) -> t -> Bool
forall a b. (a -> b) -> a -> b
$ Image t -> Int -> Int -> t
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image t
img Int
x Int
y = Int -> Int -> Int
forall a. Bits a => a -> Int -> a
setBit Int
a Int
b
  g Int
_ Int
_ Bool
_ Int
_ Int
a = Int
a
  lineIndices :: [Int]
lineIndices = [Int
0, (Int
dots Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) .. Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  columnIndices :: [Int]
columnIndices = [Int
0, Int
2 .. Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  (Int
h, Int
w) = (Image t -> Int
forall a. Image a -> Int
imageHeight Image t
img, Image t -> Int
forall a. Image a -> Int
imageWidth Image t
img)