2016 Update

Task/Colour-bars-Display/Haskell/colour-bars-display-1.hs

@@ -0,0 +1,38 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-7.0 --install-ghc runghc --package vty -- -threaded
+
+import Graphics.Vty
+
+colorBars :: Int -> [(Int, Attr)] -> Image
+colorBars h bars = horizCat $ map colorBar bars
+  where colorBar (w, attr) = charFill attr ' ' w h
+
+barWidths :: Int -> Int -> [Int]
+barWidths nBars totalWidth = map barWidth [0..nBars-1]
+  where fracWidth = fromIntegral totalWidth / fromIntegral nBars
+        barWidth n =
+          let n' = fromIntegral n :: Double
+          in floor ((n' + 1) * fracWidth) - floor (n' * fracWidth)
+
+barImage :: Int -> Int -> Image
+barImage w h = colorBars h $ zip (barWidths nBars w) attrs
+  where attrs = map color2attr colors
+        nBars = length colors
+        colors = [black, brightRed, brightGreen, brightMagenta, brightCyan, brightYellow, brightWhite]
+        color2attr c = Attr Default Default (SetTo c)
+
+main = do
+    cfg <- standardIOConfig
+    vty <- mkVty cfg
+    let output = outputIface vty
+    bounds <- displayBounds output
+    let showBars (w,h) = do
+          let img = barImage w h
+              pic = picForImage img
+          update vty pic
+          e <- nextEvent vty
+          case e of
+            EvResize w' h' -> showBars (w',h')
+            _ -> return ()
+    showBars bounds
+    shutdown vty

Task/Colour-bars-Display/Haskell/colour-bars-display-2.hs

@@ -0,0 +1,51 @@
+-- Before you can install the SFML Haskell library, you need to install
+-- the CSFML C library.  (For example, "brew install csfml" on OS X.)
+
+-- This program runs in fullscreen mode.
+-- Press any key or mouse button to exit.
+
+import Control.Exception
+import SFML.Graphics
+import SFML.SFResource
+import SFML.Window hiding (width, height)
+
+withResource :: SFResource a => IO a -> (a -> IO b) -> IO b
+withResource acquire = bracket acquire destroy
+
+withResources :: SFResource a => IO [a] -> ([a] -> IO b) -> IO b
+withResources acquire = bracket acquire (mapM_ destroy)
+
+colors :: [Color]
+colors = [black, red, green, magenta, cyan, yellow, white]
+
+makeBar :: (Float, Float) -> (Color, Int) -> IO RectangleShape
+makeBar (barWidth, height) (c, i) = do
+  bar <- err $ createRectangleShape
+  setPosition  bar $ Vec2f (fromIntegral i * barWidth) 0
+  setSize      bar $ Vec2f barWidth height
+  setFillColor bar c
+  return bar
+
+barSize :: VideoMode -> (Float, Float)
+barSize (VideoMode w h _ ) = ( fromIntegral w / fromIntegral (length colors)
+                             , fromIntegral h )
+
+loop :: RenderWindow -> [RectangleShape] -> IO ()
+loop wnd bars = do
+  mapM_ (\x -> drawRectangle wnd x Nothing) bars
+  display wnd
+  evt <- waitEvent wnd
+  case evt of
+    Nothing -> return ()
+    Just SFEvtClosed -> return ()
+    Just (SFEvtKeyPressed {}) -> return ()
+    Just (SFEvtMouseButtonPressed {}) -> return ()
+    _ -> loop wnd bars
+
+main :: IO ()
+main = do
+  vMode <- getDesktopMode
+  let wStyle = [SFFullscreen]
+  withResource (createRenderWindow vMode "color bars" wStyle Nothing) $
+     \wnd -> withResources (mapM (makeBar $ barSize vMode) $ zip colors [0..]) $
+     \bars -> loop wnd bars