TW-Logo-Haskell
Jump to navigation
Jump to search
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.
Thompson-Wheeler logo in Haskell
The following Haskell script (originally by Jared Updike) will create a number of SVG files with variations in color and style.
{-# LANGUAGE FlexibleInstances #-}
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-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), _, _) =
"<td><embed src=\""++fname++"\" width='"++show (round sizex)++
"' height='"++show (round sizey)++"' /></td>\n"
insides = concatMap embed (flattened [triple])
in "<tr>\n<td>"++desc++"</td>\n"++insides++"</tr>\n"
let svgHTML = "<html><title>Haskell Logo variations</title><body>\n"++
"<table>\n" ++ concatMap htmlChunk variations ++ "\n</table>\n</body>\n</html>"
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 }
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 = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>\n" ++
"<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.0//EN\" \"http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd\">" ++ "\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)
-- 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 = unwords [cmdToStr c | c <- path]
pathToSVG outline strokeWid (col,path) =
"<path d=\""++d++"\" "++style++" />"
where style = svgColorToStyle outline col strokeWid
d = pathToStr path
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 =
-- "<svg width=\""++w++"\" height=\""++h++"\" viewBox=\""++box++"\" xmlns=\"http://www.w3.org/2000/svg\" version=\"1.0\">\
"<svg width=\""++w++"\" height=\""++h++"\" xmlns=\"http://www.w3.org/2000/svg\" version=\"1.0\">\
\\n <title>"++title++"</title>\
\\n <desc>"++desc++"</desc>"++ "\n"
++ paths ++ "\n" ++
"</svg>" ++"\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