module Print (print) where
import Prelude hiding (print)
import Data.Array.Unboxed (UArray, bounds, (!))
import Data.ByteString.Char8 (ByteString, pack)
import Numeric (showFFloat)
import Types
import Graphics
print :: Graphics -> Header -> [Double] -> [Double] -> [ByteString] -> UArray Int Double -> UArray (Int, Int) Double -> [ByteString]
print gfx header sticks vticks labels times coords =
let bands = toPoints (bounds coords) times coords
filled c = visual gfx (Just c) Nothing Nothing Nothing
polygons = concat . zipWith (\c ps -> filled c (polygon gfx ps)) colours . map (map p) $ bands
key = concat . zipWith3 (keyBox (gW + border * 2.5) (border * 1.5) (gH / 16)) [(0::Int) ..] colours . reverse $ labels
keyBox x y0 dy i c l =
let y = y0 + fromIntegral i * dy
in (filled c $ rect gfx (x, y + 0.1 * dy) (dy * 0.8, dy * 0.8)) ++
text gfx Nothing Start 15 (x + dy, y + dy * 0.6) [l]
w = 1280
h = 720
gW = 960 - 2 * border
gH = 720 - 3 * border
border = 60
textOffset = 10
(xMin, xMax) = hSampleRange header
(yMin, yMax) = hValueRange header
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 gfx Nothing Middle 25 (w / 2, border * 0.75) [hJob header, pack " (", hDate header, pack ")"]
background = filled white $ rect gfx (0,0) (w,h)
box = filled white $ rect gfx (gx0,gy1) (gW,gH)
leftLabel = text gfx (Just (-90)) Middle 20 (border/2, (gy0 + gy1)/2) [hValueUnit header]
leftTicks = concatMap (\(y,l) -> let { (x1, y1) = p (xMin, y) ; (x2, y2) = p (xMax, y) } in
line gfx (x1 - border/2, y1) (x2, y2) ++
if l then [] else text gfx Nothing End 15 (x1 - textOffset, y1 - textOffset) (showSI y)
) (zip vticks (replicate (length vticks - 1) False ++ [True]))
bottomLabel = text gfx Nothing Middle 20 ((gx0 + gx1)/2, gy0 + border) [hSampleUnit header]
bottomTicks = concatMap (\(x,l) -> let { (x1, y1) = p (x, yMin) ; (x2, y2) = p (x, yMax) } in
line gfx (x1, y1 + border/2) (x2, y2) ++
if l then [] else text gfx Nothing Start 15 (x1 + textOffset, y1+2*textOffset) (showSI x)
) (zip sticks (replicate (length sticks - 1) False ++ [True]))
in document gfx (w,h) . concat $
[ background
, visual gfx (Just black) Nothing (Just black) (Just 1) $ concat
[ title
, leftLabel
, bottomLabel
, leftTicks
, bottomTicks
, visual gfx Nothing (Just 0.7) Nothing Nothing $ concat
[ box
, polygons
, key
]
]
]
toPoints :: ((Int,Int),(Int,Int)) -> UArray Int Double -> UArray (Int,Int) Double -> [[(Double,Double)]]
toPoints ((b0,s0),(b1,s1)) times coords =
[ fwd ++ rwd
| b <- [b1, b1 - 1 .. b0 + 1]
, let fwd = [ (times ! s, coords ! (b - 1, s)) | s <- up b ]
, let rwd = [ (times ! s, coords ! (b, s)) | s <- down b ]
]
where
-- ugly hack to force recomputation instead of sharing a large list
up b = [s0 + b - b .. s1]
down b = [s1 + b - b, s1 - 1 .. s0]
showSI :: Double -> [ByteString]
showSI x | x < 1e3 = [ showF x "" ]
| x < 1e6 = [ showF (x/1e3 ) "k" ]
| x < 1e9 = [ showF (x/1e6 ) "M" ]
| x < 1e12 = [ showF (x/1e9 ) "G" ]
| x < 1e15 = [ showF (x/1e12) "T" ]
| otherwise = [ showF (x/1e15) "P" ]
where
showF y si = let (xs, ys) = break ('.' ==) $ showFFloat (Just 3) y ""
zs = reverse . dropWhile ('0' ==) . reverse . drop 1 $ ys
in case zs of
"" -> pack $ xs ++ si
ws -> pack $ xs ++ "." ++ ws ++ si