{-# LANGUAGE FlexibleInstances #-} import List (intersperse) import Control.Monad (forM) ---------------------------------------------- -- VARIATIONS -- YOU: feel free to play with the variations sizes = [ (16,16), (32,32), (64,64), (128,128), (256, 256) ] variations = [ ( "normal-partround-lambda-col1", sizes, col1 opt0 ), ( "normal-partround-lambda-blacks", sizes, blacks opt0 ), ( "normal-partround-lambda-col2", sizes, col2 opt0 ), ( "normal-partround-lambda", sizes, opt0 ), ( "bold-round-lambda", sizes, opt3 ), ( "bold-lambda-on-top", sizes, opt5 ), ( "bold-bind-on-top", sizes, opt1 ), ( "skinny-lambda-on-top", sizes, opt2 ), ( "skinny-round-lambda", sizes, opt4 ), ( "outline-bold", sizes, outline opt5 ), ( "outline-normal-partrounded", sizes, partRounded $ outline opt0 ), ( "outline-skinny-partrounded", sizes, partRounded $ outline opt2 ) ] main = do let flatVars = flattened variations forM flatVars $ \ (fname, size, opt, _) -> do let svgStr = svgShapes size opt writeFile fname svgStr let htmlChunk triple@(desc,_,_) = let embed (fname, (sizex,sizey), _, _) = "\n" insides = concatMap embed (flattened [triple]) in "\n"++desc++"\n"++insides++"\n" let svgHTML = "Haskell Logo variations\n"++ "\n" ++ concatMap htmlChunk variations ++ "\n
\n\n" let htmlOut = "svg-test.html" writeFile htmlOut svgHTML putStrLn$ "Wrote out files. Point your browser at "++htmlOut flattened vars = [ (desc ++ "-" ++ show (round sizex) ++ ".svg", size, opt, desc) | (desc, size@(sizex, _), opt) <- flatten vars ] flatten vars = do (desc, sizes, opt) <- vars size <- sizes return (desc, size, opt) opt0 = partRounded optNormal opt1 = optBold { lambda = leg } opt2 = optSkinny opt3 = rounded optBold opt4 = rounded opt2 opt5 = optBold data Options a = Opt { hh, bb, kk, kk2, tt, tt2, ee, kk3 :: a, roundness, looseness :: a, monochrome, lambda, overlap, nofill, roundCorners, allRound :: Bool, color1, color2 :: RGB a } optSkinny = optBold { kk = 0.8, kk2 = 0.8*sqrt2*0.7, kk3 = 0.8/sqrt2, tt = 1.5/2, tt2 = 1.5/2/sqrt2, roundness = 0.2 } optNormal = optBold { kk = 0.8, kk2 = 0.8*sqrt2*0.7, kk3 = 0.8/sqrt2, tt = 2.5/2, tt2 = 2.5/2/sqrt2, roundness = 0.2 } outline opt = opt { nofill = True, monochrome = True, lambda = True } rounded opt = opt { roundCorners = True } partRounded opt = opt { roundCorners = True, allRound = False } black = RGB 0.0 0.0 0.0 gray = RGB 0.1 0.1 0.1 gray1 = RGB (75/255) (84/255) (87/255) gray2 = RGB (113/255) (127/255) (129/255) khaki1 = RGB (175/255) (167/255) (159/255) khaki2 = RGB (215/255) (210/255) (203/255) teal = RGB (60/255) (130/255) (132/255) royal = RGB (73/255) (21/255) (123/255) dteal = RGB (70/255) (120/255) (122/255) droyal = RGB (63/255) (41/255) (113/255) col1 opt = opt { color1 = droyal, color2 = dteal } col2 opt = opt { color1 = khaki1, color2 = khaki2 } blacks opt = opt { color1 = black, color2 = black } leg = False optBold = Opt { -- COLOR/STYLE ISSUES -- could force colors to be the same as color1 monochrome = False, -- could do only outlines, no fill (best with monochrome==True) nofill = False, -- draw the leg under the right '>' sign (==True, recommended) or just touch shapes overlap = True, -- rounded corners? roundness = 0.3, -- 0 = start curving at midpoint, 1 = no curve at all looseness = 0.7, -- 0 = curve control points sit atop one another, 1 = floppy, loose curves (higher radius) roundCorners = False, allRound = True, -- style: lambda on top (colorwise, lambda solid color) or '>>' on top (leg its own color) lambda = True, -- basic colors color1 = gray1, color2 = gray2, -- DESIGN/SHAPE hh = 6.0, -- height bb = 2.0, -- horizontal distance between left end of '>' and right point of '>' kk = 0.5, kk2 = 0.5*sqrt2, kk3 = 0.5/sqrt2, -- padding values tt = 1.5, tt2 = 1.5/sqrt2, -- thickness of various parts (horizontal and diagonal, respectively) ee = 2.5 -- length of equals sign } ---------------------------------------------- -- Mini EDSL for creating SVGs instance Num a => Num (a,a) where (x0,y0) + (x1,y1) = (x0+x1, y0+y1) (x0,y0) - (x1,y1) = (x0-x1, y0-y1) (x0,y0) * (s,_) = (s*x0, s*y0) -- note that this is a hack! fromInteger i = (fromInteger i,0) -- this hack goes with the above hack negate (x,y) = (negate x, negate y) abs (x,y) = error "abs of tuple undefined" signum (x,y) = error "signum of tuple undefined" instance (Num a, Fractional a) => Fractional (a,a) where recip (x0,y0) = error "recip of tuple undefiened" (x0,y0) / (x1,_) = (x0/x1, y0/x1) fromRational r = (fromRational r,0) type Pt a = (a,a) data Command a = Move (Pt a) | LineTo (Pt a) | Control { c1, c2, nextPt :: (Pt a) } | Cycle deriving (Show, Eq) -- type Path a = [Command a] -- too general! 'a' must be Show-able!!!!!! type Path = [Either (Command Double) (Command Double)] m p = Move p z = Cycle l p = LineTo p c p1 p2 pNext = Control p1 p2 pNext data RGB a = RGB { red, green, blue :: a } deriving (Eq, Show) ---------------------------------------------- -- CUSTOM HASKELL LOGO sqrt2 = 1.4142 unEither (Left x) = x unEither (Right x) = x -- like LineTo (or 'l') but here we draw the line and a control curve around the end point roundLineTo (roundness,looseness) prevW meW nextW = let me = unEither meW prev = unEither prevW next = unEither nextW sharp = case meW of { Left _ -> True; Right _ -> False } percMe = 1/2 + (1-roundness)/2 nearMe = me `times` percMe + prev `times` (1-percMe) nearMe' = me `times` percMe + next `times` (1-percMe) ctrlPerc = 1/2 + (1-looseness)/2 me1 = nearMe `times` (1-ctrlPerc) + me `times` ctrlPerc me2 = nearMe' `times` (1-ctrlPerc) + me `times` ctrlPerc in if sharp then [l me, l nearMe'] else [l nearMe, c me1 me2 nearMe'] makeRound' parms first (sndlast:lst:[]) = roundLineTo parms sndlast lst first makeRound' parms first (prev:(rest@(me:next:_))) = roundLineTo parms prev me next ++ makeRound' parms first rest makeRound' parms first _ = error "Expected at least three points for makeRound'" pt `times` s = (s * fst pt, s * snd pt) makeRoundBase parms@(roundness,looseness) (rest@(firstW:secondW:_)) = let percMe = 1/2 + (1-roundness)/2 lstW = last rest lst = unEither lstW first = unEither firstW -- second = unEither secondW startNearLast = lst `times` percMe + first `times` (1-percMe) firstLineTo = roundLineTo parms lstW firstW secondW in [m startNearLast] ++ firstLineTo ++ makeRound' parms firstW rest -- ++ [z] -- not needed since we manually reconnect -- pass on the sharpPt (Left) / roundPt (Right) information getPoints [] = [] getPoints (Left Cycle:[]) = [] getPoints (Right Cycle:[]) = [] getPoints ((Left (LineTo pt)):l) = Left pt : getPoints l getPoints ((Right (LineTo pt)):l) = Right pt : getPoints l getPoints ((Left (Move pt)):l) = Left pt : getPoints l getPoints ((Right (Move pt)):l) = Right pt : getPoints l getPoints _ = error "Badly formed input: makeRound expects a shape ending with a Z (Cycle), containing no Control points, just Move and LineTo" -- make all points rounded! (Right) getPointsR [] = [] getPointsR (Left Cycle:[]) = [] getPointsR (Right Cycle:[]) = [] getPointsR ((Left (LineTo pt)):l) = Right pt : getPointsR l getPointsR ((Right (LineTo pt)):l) = Right pt : getPointsR l getPointsR ((Left (Move pt)):l) = Right pt : getPointsR l getPointsR ((Right (Move pt)):l) = Right pt : getPointsR l getPointsR _ = error "Badly formed input: makeRound expects a shape ending with a Z (Cycle), containing no Control points, just Move and LineTo" makeRound getpts parms list = makeRoundBase parms (getpts list) -- the heart of the Logo shapes opt = let -- colors col1 = color1 opt col2 = if monochrome opt then col1 else color2 opt round = roundCorners opt getPoints' = if allRound opt then getPointsR else getPoints rounder = if round then makeRound getPoints' parms else map unEither -- NOTE: wrapping Either for prounding (Partial Rounding): Left=point is 'left' alone, Right=round that point roundPt = Right sharpPt = Left -- point 'left' sharp parms = (roundness opt, looseness opt) -- constants h = hh opt; b = bb opt; e = ee opt k = kk opt; k2 = kk2 opt; k3 = kk3 opt t = tt opt; t2 = tt2 opt s = k3 + t2 rstroke = (t/2,0) lstroke = (-t/2,0) -- skeleton 0 : left '>' symbol skel0 = [(0,0), (b,h/2), (0,h)] leftGT = leftGT' skel0 leftGT' s0 = rounder [roundPt$ m$ s0!!0 + rstroke, sharpPt$ l$ s0!!1 + rstroke, roundPt$ l$ s0!!2 + rstroke, roundPt$ l$ s0!!2 + lstroke, sharpPt$ l$ s0!!1 + lstroke, roundPt$ l$ s0!!0 + lstroke, roundPt z] -- skeleton 1 : right '>' symbol skel1 = [(b+t+k-b,0), (b+t+k,h/2), (b+t+k-b,h)] rightGT = leftGT' skel1 -- skeleton 2 : lambda and/or leg skel2 = [ skel1!!1, (fst(skel1!!0) + 2*b, snd(skel1!!0)) ] why x = let bl = skel2!!1 + lstroke tl = skel1!!2 + lstroke dx = fst tl - fst bl dy = h y = dy * (x - fst bl) / dx + snd bl in y crosspt = let x = fst(skel2!!0) in (x, why x) lam = rounder [roundPt$ m$ skel1!!0 + rstroke, sharpPt$ l$ crosspt, roundPt$ l$ skel2!!1 + lstroke, roundPt$ l$ skel2!!1 + rstroke, roundPt$ l$ skel1!!2 + rstroke, roundPt$ l$ skel1!!2 + lstroke, sharpPt$ l$ skel1!!1 + lstroke, roundPt$ l$ skel1!!0 + lstroke, roundPt z] leg' = [roundPt$ m$ skel2!!0 + rstroke, sharpPt$ l$ skel2!!1 + rstroke, sharpPt$ l$ skel2!!1 + lstroke] leg = if overlap opt then rounder $ leg' ++ [roundPt$ l$ skel2!!0 + lstroke, roundPt z] else rounder $ leg' ++ [sharpPt$ l$ crosspt, roundPt z] -- calculate the slanted part of the equals sign eqCtrLft = skel1!!1 + (t2/2+k2,0) eqCtrRgt = eqCtrLft + (e,0) farRight = fst eqCtrRgt eks y = fst eqCtrLft + 2*b*(h/2 - y)/h xy y = (eks y, y) -- skel3 = [ xy (h/2+s/2), eqCtrRgt + (0,s/2) ] -- skeleton or guide to bisect equals sign -- the two pieces of the equals sign eqTop = rounder [ sharpPt$ m$ xy (h/2+s/2-t2/2), roundPt$ l$ (farRight,h/2+s/2-t2/2), roundPt$ l$ (farRight,h/2+s/2+t2/2), sharpPt$ l$ xy (h/2+s/2+t2/2), roundPt z] eqBot = rounder [ sharpPt$ m$ xy (h/2-s/2-t2/2), roundPt$ l$ (farRight,h/2-s/2-t2/2), roundPt$ l$ (farRight,h/2-s/2+t2/2), sharpPt$ l$ xy (h/2-s/2+t2/2), roundPt z] boundsBL = (-1.5*t,-t) boundsBR = (farRight+t,-t) boundsTR = (farRight+t,h+t) boundsTL = (-1.5*t,h+t) bounds = (boundsBL,boundsTR) in if lambda opt then (bounds, [(col1, leftGT), (col2, lam), (col1, eqTop), (col1, eqBot)]) else (bounds, [(col1, leftGT), (col2, leg), (col1, rightGT), (col1, eqTop), (col1, eqBot)]) ---------------------------------------------- -- SVG string concatenation code svgXMLheaders = "\n" ++ "" ++ "\n" hexChars = "0123456789abcdef" byteToHex b | b <= 0 = "00" | b >= 255 = "ff" | otherwise = big:small:[] where big = hexChars !! hi small = hexChars !! lo hi = b `div` 16 lo = b `mod` 16 svgColorToStyle outline col thick = if outline then "fill=\"none\" stroke=\""++c++"\" stroke-width=\""++show thick++"\"" else "fill=\""++c++"\" stroke=\""++c++"\" stroke-width=\""++show thick++"\"" where c = "#" ++ r ++ g ++ b r = byteToHex $ round (255 * red col) g = byteToHex $ round (255 * green col) b = byteToHex $ round (255 * blue col) unspaces pieces = concat $ intersperse " " pieces -- see http://www.w3.org/TR/SVG11/paths.html#PathDataGeneralInformation cmdToStr (Move p) = "M "++showPt p cmdToStr (LineTo p) = "L "++showPt p cmdToStr (Control c1 c2 p) = "C "++showPt c1++" "++showPt c2++" "++showPt p cmdToStr Cycle = "z" showPt (x,y) = show x++" "++show y pathToStr path = unspaces [cmdToStr c | c <- path] pathToSVG outline strokeWid (col,path) = "" where style = svgColorToStyle outline col strokeWid d = pathToStr path {- mmin val Nothing = val mmin val (Just a) = min val a mmax val Nothing = val mmax val (Just a) = max val a getBounds paths = getBounds' (99999,99999) (-99999,-99999) (concatMap snd paths) getBounds' lo hi [] = (lo,hi) getBounds' lo hi (cmd:cmds) = getBounds' newlo newhi cmds where newlo = (cmdx (mmin (fst lo)) cmd, cmdy (mmin (snd lo)) cmd) newhi = (cmdx (mmax (fst hi)) cmd, cmdy (mmax (snd hi)) cmd) cmdx f (Move (x,_)) = f $ Just x cmdx f (LineTo (x,_)) = f $ Just x cmdx f _ = f $ Nothing cmdy f (Move (_,y)) = f $ Just y cmdy f (LineTo (_,y)) = f $ Just y cmdy f _ = f $ Nothing -} flipCmd f (Move p) = Move (f p) flipCmd f (LineTo p) = LineTo (f p) flipCmd f (Control p q r) = Control (f p) (f q) (f r) flipCmd f Cycle = Cycle flipPath f path = [flipCmd f c | c <- path] flipPaths f paths = [(col,flipPath f p) | (col,p) <- paths] svg (w,h) box title desc paths = -- "\ "\ \\n "++title++"\ \\n "++desc++""++ "\n" ++ paths ++ "\n" ++ "" ++"\n" pathsToSVG strokeWid wh box outline paths = svgXMLheaders ++ svg wh box title desc bigstr where bigstr = unlines [pathToSVG outline strokeWid p | p <- paths] title = "Haskell Logo" desc = "Combination bind and lambda symbol" svgShapes (w,h) opt = let (bounds@((blx,bly),(trx,try)),paths') = shapes opt xscale = trx - blx yscale = try - bly slide (x,y) = (x - blx, y - bly) flipy (x,y) = (x, yscale - y) scale (x,y) = (w * x / xscale, w * y / xscale) trans = scale . flipy . slide newbnds@((a,b),(c,d)) = (trans (blx,bly), trans (trx,try)) box = show a++" "++show b++" "++show c++" "++show d paths = flipPaths trans paths' wh = (show $ round w, show $ round h) --("8cm", "8cm") outline = nofill opt strokeWid = w/128 in pathsToSVG strokeWid wh box outline paths