@@ -10,6 +10,7 @@ import Data.Ratio
1010import Data.Time
1111import Data.Word
1212import qualified Data.Text as T
13+import qualified Graphics.Vty as V
1314import Text.Printf
1415
1516import Reflex
@@ -136,15 +137,56 @@ chart pct = do
136137 grout flex blank
137138 dh <- displayHeight
138139 let heights = calcRowHeights <$> dh <*> pct
139− tile (fixed 1) $ fill $ current $ eighthBlocks . snd <$> heights
140− tile (fixed $ fst <$> heights) $ fill $ pure '█'
140+ quarters = fst <$> heights
141+ eighths = snd <$> heights
142+ eighthRow = ffor eighths $ \x -> if x == 0 then 0 else 1
143+ tile (fixed eighthRow) $ fill' (current $ eighthBlocks <$> eighths) $ current $
144+ ffor quarters $ \q ->
145+ if | _quarter_fourth q > 0 -> red
146+ | _quarter_third q > 0 -> orange
147+ | _quarter_second q > 0 -> yellow
148+ | otherwise -> white
149+ tile (fixed $ _quarter_fourth <$> quarters) $ fill' (pure '█') (pure red)
150+ tile (fixed $ _quarter_third <$> quarters) $ fill' (pure '█') (pure orange)
151+ tile (fixed $ _quarter_second <$> quarters) $ fill' (pure '█') (pure yellow)
152+ tile (fixed $ _quarter_first <$> quarters) $ fill' (pure '█') (pure white)
141153 where
142154 -- Calculate number of full rows, height of partial row
143− calcRowHeights :: Int -> Ratio Word64 -> (Int, Int)
155+ calcRowHeights :: Int -> Ratio Word64 -> (Quarter Int, Int)
144156 calcRowHeights h r =
145157 let (full, leftovers) = divMod (numerator r * fromIntegral h) (denominator r)
146158 partial = ceiling $ 8 * (leftovers % denominator r)
147− in (fromIntegral full, partial)
159+ quarter = ceiling $ fromIntegral h / (4 :: Double)
160+ n = fromIntegral full
161+ in if | n <= quarter ->
162+ (Quarter n 0 0 0, partial)
163+ | n <= (2 * quarter) ->
164+ (Quarter quarter (n - quarter) 0 0, partial)
165+ | n <= (3 * quarter) ->
166+ (Quarter quarter quarter (n - (2 * quarter)) 0, partial)
167+ | otherwise ->
168+ (Quarter quarter quarter quarter (n - (3 * quarter)), partial)
169+ fill' bc attr = do
170+ dw <- displayWidth
171+ dh <- displayHeight
172+ let fillImg =
173+ (\w h c a -> [V.charFill a c w h])
174+ <$> current dw
175+ <*> current dh
176+ <*> bc
177+ <*> attr
178+ tellImages fillImg
179+ red = V.withForeColor V.defAttr $ V.rgbColor 255 0 0
180+ orange = V.withForeColor V.defAttr $ V.rgbColor 255 165 0
181+ yellow = V.withForeColor V.defAttr $ V.rgbColor 255 255 0
182+ white = V.withForeColor V.defAttr $ V.rgbColor 255 255 255
183+
184+data Quarter a = Quarter
185+ { _quarter_first :: a
186+ , _quarter_second :: a
187+ , _quarter_third :: a
188+ , _quarter_fourth :: a
189+ }
148190
149191eighthBlocks :: (Eq a, Num a, Ord a) => a -> Char
150192eighthBlocks n =