{-# LANGUAGE OverloadedStrings #-}
module Print where
import Prelude hiding (concat, unlines)
import qualified Prelude as P
import Data.Array.Unboxed (bounds, (!))
import Data.ByteString.Lazy.Char8 (ByteString, pack, concat)
import Numeric (showHex, showFFloat)
import Types
print :: Graph -> ByteString
print hpg =
let fwd = hpgSamples hpg
rwd = reverse fwd --)) (hpgBands hpg)
((b0,s0),(b1,s1)) = bounds (hpgBands hpg)
bands =
[ (fwd ++ rwd) `zip` (bfwd ++ brwd)
| b <- [b0 + 1 .. b1]
, let bfwd = [ hpgBands hpg ! (b - 1, s) | s <- [s0 .. s1] ]
, let brwd = [ hpgBands hpg ! (b, s) | s <- [s1, s1 - 1 .. s0] ]
] -- zipWith (\s t -> s ++ reverse t) paths (tail paths)
polygons = zipWith polygon colours . map (map p) . reverse $ bands
key = zipWith3 (keyBox (gW + border * 2.5) (border * 1.5) (gH / 16)) [0..] colours . reverse . hpgLabels $ hpg
w = 1280
h = 720
gW = 960 - 2 * border
gH = 720 - 3 * border
border = 60
textOffset = 10
(xMin, xMax) = hpgSampleRange hpg
(yMin, yMax) = hpgValueRange hpg
gRange@((gx0,gy0),(gx1,gy1)) = ((border*1.5, gH + border*1.5), (gW + border*1.5, border*1.5))
p = rescalePoint ((xMin, yMin), (xMax, yMax)) gRange
title = [ "<text font-size='25' text-anchor='middle' x='" , showF (fromIntegral w / 2) , "' y='" , showF (border * 0.75) , "'>" , hpgJob hpg , " (" , hpgDate hpg , ")</text>" ]
background = [ "<rect fill='white' x='0' y='0' width='" , showI w , "' height='" , showI h , "' />" ]
box = [ "<rect fill='white' x='" , showF gx0 , "' y='" , showF gy1 , "' width='" , showF gW , "' height='" , showF gH , "' />" ]
gStart = [ "<g fill-opacity='0.5' fill='black' stroke='black' stroke-width='1'>" ]
leftLabel = [ "<text font-size='20' text-anchor='middle' transform='translate(" , showF (border/2) , "," , showF ((gy0 + gy1)/2) , ") rotate(-90)'>" , hpgValueUnit hpg , "</text>" ]
leftTicks = map (\(y,l) -> let { (x1, y1) = p (xMin, y) ; (x2, y2) = p (xMax, y) } in
[ "<line x1='" , showF (x1 - border/2) , "' x2='" , showF x2 , "' y1='" , showF y1 , "' y2='" , showF y2 , "' />" ] ++
if l then [] else [ "<text font-size='15' text-anchor='end' x='" , showF (x1 - textOffset) , "' y='" , showF (y1 - textOffset) , "'>" , showSI y , "</text>" ]
) (zip (hpgValueTicks hpg) (replicate (length (hpgValueTicks hpg) - 1) False ++ [True]))
bottomLabel = [ "<text font-size='20' text-anchor='middle' x='" , showF ((gx0 + gx1)/2) , "' y='" , showF (gy0 + border) , "'>" , hpgSampleUnit hpg , "</text>" ]
bottomTicks = map (\(x,l) -> let { (x1, y1) = p (x, yMin) ; (x2, y2) = p (x, yMax) } in
[ "<line y1='" , showF (y1 + border/2) , "' y2='" , showF y2 , "' x1='" , showF x1 , "' x2='" , showF x2 , "' />" ] ++
if l then [] else [ "<text font-size='15' text-anchor='start' x='" , showF (x1 + textOffset) , "' y='" , showF (y1+2*textOffset) , "'>" , showSI x , "</text>" ]
) (zip (hpgSampleTicks hpg) (replicate (length (hpgSampleTicks hpg) - 1) False ++ [True]))
gEnd = [ "</g>" ]
in concat . P.concat $ [ xmldecl, svgStart w h, background, gStart, title, leftLabel, P.concat leftTicks, bottomLabel, P.concat bottomTicks, box, P.concat polygons, P.concat key, gEnd, svgEnd ]
showSI :: Double -> ByteString
showSI x | x < 1e3 = showF x
| x < 1e6 = concat [ showF (x/1e3 ) , "k" ]
| x < 1e9 = concat [ showF (x/1e6 ) , "M" ]
| x < 1e12 = concat [ showF (x/1e9 ) , "G" ]
| x < 1e15 = concat [ showF (x/1e12) , "T" ]
| otherwise = concat [ showF (x/1e15) , "P" ]
showF :: Double -> ByteString
showF x = pack $ showFFloat Nothing x ""
showI :: Int -> ByteString
showI x = pack $ show x
keyBox :: Double -> Double -> Double -> Int -> ByteString -> ByteString -> [ByteString]
keyBox x y0 dy i c l =
let y = y0 + fromIntegral i * dy
in [ "<rect fill-opacity='0.7' fill='" , c , "' x='" , showF x , "' y='" , showF (y + 0.1 * dy) , "' width='" , showF (dy * 0.8) , "' height='" , showF (dy * 0.8) , "' />"
, "<text font-size='15' text-anchor='start' x='" , showF (x + dy) , "' y='" , showF (y + dy * 0.6) , "'>" , l , "</text>" ]
polygon :: ByteString -> [(Double,Double)] -> [ByteString]
polygon c ps = [ "<path fill-opacity='0.7' fill='" , c , "' d='" ] ++ path ps ++ [ "' />" ]
path :: [(Double,Double)] -> [ByteString]
path [] = error "Print.path: []"
path (p0:ps) =
let lineTo p = [ " L " ] ++ toSVGPoint p
in [ "M " ] ++ toSVGPoint p0 ++ concatMap lineTo (ps ++ [p0]) ++ [ " Z" ]
rescalePoint :: ((Double,Double),(Double,Double)) -> ((Double,Double),(Double,Double)) -> (Double, Double) -> (Double,Double)
rescalePoint ((inX0,inY0),(inX1,inY1)) ((outX0,outY0),(outX1,outY1)) (x,y) =
let inW = inX1 - inX0
inH = inY1 - inY0
outW = outX1 - outX0
outH = outY1 - outY0
in ((x - inX0) / inW * outW + outX0, (y - inY0) / inH * outH + outY0)
toSVGPoint :: (Double,Double) -> [ByteString]
toSVGPoint (x,y) = [ showF x , "," , showF y ]
xmldecl :: [ByteString]
xmldecl = [ "<?xml version='1.0' encoding='UTF-8' ?>" ]
svgStart :: Int -> Int -> [ByteString]
svgStart w h = [ "<svg xmlns='http://www.w3.org/2000/svg' version='1.0' width='" , showI w , "' height='" , showI h , "'>" ]
svgEnd :: [ByteString]
svgEnd = [ "</svg>" ]
phi :: Double
phi = (sqrt 5 + 1) / 2
hues :: [Double]
hues = [0, 2 * pi / (phi * phi) ..]
sats :: [Double]
sats = repeat 1
vals :: [Double]
vals = repeat 1
wrap :: Double -> Double
wrap x = x - fromIntegral (floor x :: Int)
colours :: [ByteString]
colours = map toSVGColour $ zipWith3 toRGB hues sats vals
toRGB :: Double -> Double -> Double -> (Double, Double, Double)
toRGB h s v =
let hh = h * 3 / pi
i = floor hh `mod` 6 :: Int
f = hh - fromIntegral (floor hh :: Int)
p = v * (1 - s)
q = v * (1 - s * f)
t = v * (1 - s * (1 - f))
in case i of
0 -> (v,t,p)
1 -> (q,v,p)
2 -> (p,v,t)
3 -> (p,q,v)
4 -> (t,p,v)
_ -> (v,p,q)
toSVGColour :: (Double, Double, Double) -> ByteString
toSVGColour (r,g,b) =
let toInt x = let y = floor (256 * x) in 0 `max` y `min` 255 :: Int
hex2 i = (if i < 16 then ('0':) else id) (showHex i "")
in pack $ '#' : concatMap (hex2 . toInt) [r,g,b]