Render image to Lighthouse in demo

README.md

@@ -1,2 +1,4 @@
 # Project Lighthouse API for Haskell
 An API wrapper for a light installation at the University of Kiel written in Haskell.
+
+![Facade](facade.png)

lighthouse-api/src/Lighthouse/Utils/General.hs

@@ -1,11 +1,20 @@
-module Lighthouse.Utils.General (fst3, snd3, thd3, (<.$>), (<$.>), (<.$.>)) where
+module Lighthouse.Utils.General (fst3, snd3, thd3, liftMaybe, (<.$>), (<$.>), (<.$.>)) where
 
+import Control.Monad.Trans.Maybe
+
+-- | Lifts an optional value into the maybe transformer.
+liftMaybe :: Monad m => Maybe a -> MaybeT m a
+liftMaybe = MaybeT . return
+
+-- | Fetches the first element of a triple.
 fst3 :: (a, b, c) -> a
 fst3 (x, _, _) = x
 
+-- | Fetches the second element of a triple.
 snd3 :: (a, b, c) -> b
 snd3 (_, y, _) = y
 
+-- | Fetches the third element of a triple.
 thd3 :: (a, b, c) -> c
 thd3 (_, _, z) = z
 

lighthouse-demo/README.md

@@ -1,7 +1,9 @@
 # Lighthouse Demo
-A demo application running for the Lighthouse.
+A demo application that renders a single image to the Lighthouse.
 
 ## Running
 Firstly, you will need a valid login at [lighthouse.uni-kiel.de](https://lighthouse.uni-kiel.de). Acquire an authentication and then run:
 
-`stack run [username] [api token]`
+`stack run [username] [api token] [path to png image]`
+
+A sample image can be found in the `assets` directory.

lighthouse-demo/app/Main.hs

@@ -1,24 +1,44 @@
 {-# LANGUAGE RecordWildCards #-}
 module Main where
 
-import Control.Monad.Trans (liftIO)
+import qualified Codec.Picture as P
+import Control.Monad (void)
+import Control.Monad.Trans (lift, liftIO)
+import Control.Monad.Trans.Maybe
 import qualified Data.Text as T
 import Lighthouse.Authentication
 import Lighthouse.Connection
-import Lighthouse.Display (coloredDisplay)
+import Lighthouse.Display
 import Lighthouse.Utils.Color
+import Lighthouse.Utils.General (liftMaybe)
 import System.Environment (getArgs)
 import System.Random
 
-app :: LighthouseIO ()
-app = do
-    display <- liftIO $ randomIO
-    sendDisplay display
+-- | Renders a single image to the lighthouse.
+app :: String -> LighthouseIO ()
+app imagePath = do
+    optDimg <- liftIO $ P.readPng imagePath
+    case optDimg of
+        Left e -> liftIO $ putStrLn e
+        Right dimg -> void $ runMaybeT $ do
+            d <- liftMaybe $ dynImgToDisplay dimg
+            lift $ sendDisplay d
     sendClose
 
+dynImgToDisplay :: P.DynamicImage -> Maybe Display
+dynImgToDisplay dimg = case dimg of
+    P.ImageRGB8 img -> Just $ imgToDisplay img $ \(P.PixelRGB8 r g b) -> Color (fromIntegral r) (fromIntegral g) (fromIntegral b)
+    P.ImageRGBA8 img -> Just $ imgToDisplay img $ \(P.PixelRGBA8 r g b _) -> Color (fromIntegral r) (fromIntegral g) (fromIntegral b)
+    _ -> Nothing
+
+imgToDisplay :: P.Pixel a => P.Image a -> (a -> Color) -> Display
+imgToDisplay img pxToColor = Display $ (\y -> Row $ (\x -> pxToColor $ P.pixelAt img x y) <$> [0..width - 1]) <$> [0..height - 1]
+    where width = P.imageWidth img
+          height = P.imageHeight img
+
 main :: IO ()
 main = do
     args <- getArgs
     case args of
-        [username, token] -> runLighthouseIO app $ Authentication { username = T.pack username, token = T.pack token }
-        _ -> putStrLn "Arguments: [api username] [api token]"
+        [username, token, imagePath] -> runLighthouseIO (app imagePath) $ Authentication { username = T.pack username, token = T.pack token }
+        _ -> putStrLn "Arguments: [api username] [api token] [path to png image]"

lighthouse-demo/package.yaml

@@ -21,7 +21,9 @@ dependencies:
 - base >= 4.7 && < 5
 - text < 1.3
 - mtl < 2.3
+- transformers < 0.6
 - random < 1.2
+- JuicyPixels < 3.4
 
 executables:
   lighthouse-demo-exe: