{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Main where
import Diagrams.Backend.Braille.CmdLine
import Diagrams.Backend.CmdLine (Parseable(..))
import Diagrams.Prelude hiding (option, value)
import Options.Applicative
d = f 1 `atop` f (sqrt 2 / 2) `atop` f (sqrt 2 * (sqrt 2 / 2) / 2) where
f x = circle x `atop` square (x * sqrt 2)
sol = circle 1 <> atPoints (hexagon 1) (repeat $ circle 1)
fol = circle 1 <> atPoints (hexagon 1) (map (`rotateBy` pedal) [0, 1/6 ..])
pedal = circle 1 <> circle 1 # translateX 1 # rotateBy (-1/3)
clock h m = circle 0.35 # fc silver # lwG 0
<> bigHand # f 12 h <> littleHand # f 60 m
<> circle 1 # fc black # lwG 0
<> circle 11 # lwG 1.5 # lc slategray -- # fc lightsteelblue
where
bigHand = (0 ^& (-1.5)) ~~ (0 ^& 7.5) # lwG 0.5
littleHand = (0 ^& (-2)) ~~ (0 ^& 9.5) # lwG 0.2
f n v = rotate (- v / n @@ turn)
hilbert 0 = mempty
hilbert n = hilbert' (n-1) # reflectY <> vrule 1
<> hilbert (n-1) <> hrule 1
<> hilbert (n-1) <> vrule (-1)
<> hilbert' (n-1) # reflectX
where hilbert' = rotateBy (1/4) . hilbert
newtype Opts = Opts { draw :: Diagram B }
instance Parseable Opts where
parser = fmap (Opts . mconcat) $ some $ hsubparser $ mconcat [
commandGroup "Diagrams"
, cmd "hrule" "A centered horizontal (L-R) line of the given length." $
hrule <$> arg (metavar "LENGTH")
, cmd "vrule" "A centered vertical (T-B) line of the given length." $
vrule <$> arg (metavar "LENGTH")
, cmd "triangle" "An equilateral triangle, with sides of the given length and base parallel to the x-axis." $
triangle <$> arg (metavar "LENGTH")
, cmd "rect" "An axis-aligned rectangle of the given width and height, centered at the origin." $
rect <$> arg (metavar "WIDTH")
<*> arg (metavar "HEIGHT")
, cmd "roundedRect" "An axis-aligned rectangle with the given width and height with circular rounded corners of radius, centered at the origin." $
roundedRect <$> arg (metavar "WIDTH")
<*> arg (metavar "HEIGHT")
<*> arg (metavar "RADIUS")
, cmd "square" "A square with its center at the origin and sides of the given length, oriented parallel to the axes." $
square <$> arg (metavar "LENGTH")
, cmd "pentagon" "A regular pentagon, with sides of the given length and base parallel to the x-axis." $
pentagon <$> arg (metavar "LENGTH")
, cmd "hexagon" "A regular hexagon, with sides of the given length and base parallel to the x-axis." $
hexagon <$> arg (metavar "LENGTH")
, cmd "heptagon" "A regular heptagon, with sides of the given length and base parallel to the x-axis." $
heptagon <$> arg (metavar "LENGTH")
, cmd "octagon" "A regular octagon, with sides of the given length and base parallel to the x-axis." $
octagon <$> arg (metavar "LENGTH")
, cmd "nonagon" "A regular nonagon, with sides of the given length and base parallel to the x-axis." $
nonagon <$> arg (metavar "LENGTH")
, cmd "decagon" "A regular decagon, with sides of the given length and base parallel to the x-axis." $
decagon <$> arg (metavar "LENGTH")
, cmd "hendecagon" "A regular hendecagon, with sides of the given length and base parallel to the x-axis." $
hendecagon <$> arg (metavar "LENGTH")
, cmd "dodecagon" "A regular dodecagon, with sides of the given length and base parallel to the x-axis." $
dodecagon <$> arg (metavar "LENGTH")
, cmd "circle" "A circle of the given radius, centered at the origin." $
circle <$> arg (metavar "RADIUS")
, cmd "text" "Print text." $ text <$> strArgument (metavar "STRING")
, cmd "baselineText" "Print text." $ baselineText <$> strArgument (metavar "STRING")
, cmd "clock" "A clock showing the time given in hours and minutes." $
clock <$> arg (metavar "HOUR")
<*> arg (metavar "MINUTE")
, cmd "flower-of-life" "The \"flower of life\"." $
pure fol
, cmd "hilbert" "A hilbert curve of the given order." $
strokeT . hilbert <$> arg (metavar "ORDER")
, cmd "seed-of-life" "The \"seed of life\"." $ pure sol
] where cmd s d p = command s $ info (foldr ($) <$> p <*> many modifier) $
progDesc d
arg = argument auto
modifier = flag' alignL (long "alignL") <|> flag' alignR (long "alignR")
<|> flag' alignT (long "alignT") <|> flag' alignB (long "alignB")
<|> flag' centerX (long "centerX" <> help "Center the local origin along the X-axis.")
<|> flag' centerY (long "centerY" <> help "Center the local origin along the Y-axis.")
<|> flag' centerXY (long "centerXY" <> help "Center along both the X- and Y-axes.")
<|> (named :: String -> Diagram B -> Diagram B) <$> option auto (long "named" <> metavar "NAME")
<|> flag' reflectX (long "reflectX" <> help "Flip a diagram from left to right, i.e. send the point (x,y) to (-x,y).")
<|> flag' reflectY (long "reflectY" <> help "Flip a diagram from top to bottom, i.e. send the point (x,y) to (x,-y).")
<|> flag' reflectXY (long "reflectXY" <> help "Flips the diagram about x=y, i.e. send the point (x,y) to (y,x).")
<|> rotateBy <$> option auto (long "rotateBy")
<|> scaleX <$> option auto (long "scaleX" <> metavar "FACTOR" <> help "Scale a diagram by the given factor in the x (horizontal) direction.")
<|> scaleY <$> option auto (long "scaleY" <> metavar "FACTOR" <> help "Scale a diagram by the given factor in the y (vertical) direction.")
<|> flag' showOrigin (long "showOrigin")
<|> translateX <$> option auto (long "translateX")
<|> translateY <$> option auto (long "translateY")
main = mainWith draw