Initial check-in
authorJoachim Breitner <mail@joachim-breitner.de>
Sun, 9 Mar 2014 20:50:32 +0000 (21:50 +0100)
committerJoachim Breitner <mail@joachim-breitner.de>
Sun, 9 Mar 2014 20:52:06 +0000 (21:52 +0100)
18 files changed:
5x7.png [new file with mode: 0644]
icons/cloudy.gif [new file with mode: 0644]
icons/fog.gif [new file with mode: 0644]
icons/partly-cloudy.gif [new file with mode: 0644]
icons/rain.gif [new file with mode: 0644]
icons/skull.gif [new file with mode: 0644]
icons/smiley.gif [new file with mode: 0644]
icons/snow.gif [new file with mode: 0644]
icons/sun.gif [new file with mode: 0644]
src/Fonts.hs [new file with mode: 0644]
src/LedXML.hs [new file with mode: 0644]
src/Screen.hs [new file with mode: 0644]
src/ScreenFile.hs [new file with mode: 0644]
src/Sinus.hs [new file with mode: 0644]
src/Terminal.hs [new file with mode: 0644]
src/Types.hs [new file with mode: 0644]
src/USB.hs [new file with mode: 0644]
src/led-main.hs [new file with mode: 0644]

diff --git a/5x7.png b/5x7.png
new file mode 100644 (file)
index 0000000..519299e
Binary files /dev/null and b/5x7.png differ
diff --git a/icons/cloudy.gif b/icons/cloudy.gif
new file mode 100644 (file)
index 0000000..02701f5
Binary files /dev/null and b/icons/cloudy.gif differ
diff --git a/icons/fog.gif b/icons/fog.gif
new file mode 100644 (file)
index 0000000..e360557
Binary files /dev/null and b/icons/fog.gif differ
diff --git a/icons/partly-cloudy.gif b/icons/partly-cloudy.gif
new file mode 100644 (file)
index 0000000..8fadb87
Binary files /dev/null and b/icons/partly-cloudy.gif differ
diff --git a/icons/rain.gif b/icons/rain.gif
new file mode 100644 (file)
index 0000000..f120e09
Binary files /dev/null and b/icons/rain.gif differ
diff --git a/icons/skull.gif b/icons/skull.gif
new file mode 100644 (file)
index 0000000..41fa746
Binary files /dev/null and b/icons/skull.gif differ
diff --git a/icons/smiley.gif b/icons/smiley.gif
new file mode 100644 (file)
index 0000000..a297f9b
Binary files /dev/null and b/icons/smiley.gif differ
diff --git a/icons/snow.gif b/icons/snow.gif
new file mode 100644 (file)
index 0000000..e656e59
Binary files /dev/null and b/icons/snow.gif differ
diff --git a/icons/sun.gif b/icons/sun.gif
new file mode 100644 (file)
index 0000000..9e94f00
Binary files /dev/null and b/icons/sun.gif differ
diff --git a/src/Fonts.hs b/src/Fonts.hs
new file mode 100644 (file)
index 0000000..9a4d137
--- /dev/null
@@ -0,0 +1,42 @@
+module Fonts where
+
+import qualified Data.ByteString as B
+import Codec.Picture
+import Data.Char
+import Data.Bits
+import Data.List
+
+import Screen
+
+type Font = (Char -> ScreenElement)
+
+readFont :: IO Font
+readFont = do
+    Right (ImageRGBA8 i) <- readImage "5x7.png"
+    let i' = pixelMap (\ (PixelRGBA8 r _ _ _) -> r) i
+    return $ \c ->
+        let n = ord c - ord ' '
+        in toElem $ cut (6 * n, 0) (5,7) i'
+
+-- thin font
+-- http://ardurct.googlecode.com/svn-history/r633/trunk/arduino/libraries/LCD_PCD8544/fonts.cpp
+-- Copyright (c) 2010 Laurent Wibaux <lm.wibaux@gmail.com>
+-- MIT license
+thinfontRaw = B.pack [ 0x00, 0x00, 0x00, 0x00, 0x17, 0x00, 0x03, 0x00, 0x03, 0x1F, 0x0A, 0x1F, 0x1C, 0x14, 0x1F, 0x19, 0x04, 0x13, 0x1C, 0x17, 0x04, 0x00, 0x03, 0x00, 0x0E, 0x1B, 0x11, 0x11, 0x1B, 0x0E, 0x0A, 0x04, 0x0A, 0x04, 0x0E, 0x04, 0x10, 0x0C, 0x00, 0x04, 0x04, 0x04, 0x10, 0x00, 0x00, 0x18, 0x04, 0x03, 0x1F, 0x11, 0x1F, 0x12, 0x1F, 0x10, 0x19, 0x15, 0x17, 0x15, 0x15, 0x0A, 0x07, 0x04, 0x1F, 0x17, 0x15, 0x09, 0x1F, 0x15, 0x1D, 0x01, 0x01, 0x1F, 0x1F, 0x15, 0x1F, 0x17, 0x15, 0x1F, 0x0A, 0x00, 0x00, 0x10, 0x0A, 0x00, 0x04, 0x0A, 0x11, 0x0A, 0x0A, 0x0A, 0x11, 0x0A, 0x04, 0x01, 0x15, 0x03, 0x0E, 0x15, 0x12, 0x1F, 0x05, 0x1F, 0x1F, 0x15, 0x0A, 0x0E, 0x11, 0x11, 0x1F, 0x11, 0x0E, 0x1F, 0x15, 0x11, 0x1F, 0x05, 0x01, 0x1F, 0x11, 0x1D, 0x1F, 0x04, 0x1F, 0x11, 0x1F, 0x11, 0x09, 0x11, 0x1F, 0x1F, 0x04, 0x1B, 0x1F, 0x10, 0x10, 0x1F, 0x02, 0x1F, 0x1F, 0x02, 0x1E, 0x0E, 0x11, 0x0E, 0x1F, 0x05, 0x07, 0x07, 0x05, 0x1F, 0x1F, 0x05, 0x1A, 0x17, 0x15, 0x1D, 0x01, 0x1F, 0x01, 0x1F, 0x10, 0x1F, 0x0F, 0x10, 0x0F, 0x1F, 0x08, 0x1F, 0x1B, 0x04, 0x1B, 0x07, 0x1C, 0x07, 0x19, 0x15, 0x13, 0x1F, 0x11, 0x11, 0x03, 0x04, 0x18, 0x11, 0x11, 0x1F, 0x02, 0x01, 0x02, 0x10, 0x10, 0x10, 0x01, 0x02, 0x00]
+
+thinfont :: Font
+thinfont c | n < 0 = blank
+           | n >= B.length thinfontRaw `div` 3 = blank
+           | otherwise = toElem $ generateScreen (3,5) $ \x y ->
+                                    testBit (thinfontRaw `B.index` (n*3+x)) y
+    where n = ord c - ord ' '
+          blank = toElem $ blankScreen (3,5)
+
+text :: Font -> String -> ScreenElement
+text font = hconcat . intersperse (padX 1) . map font
+
+toMinutes :: Font -> Int -> ScreenElement
+toMinutes font s | m < 0     = text font "<?"
+                 | m > 100   = text font ">"
+                 | otherwise = text font $ show m
+  where m = s `div` 60
diff --git a/src/LedXML.hs b/src/LedXML.hs
new file mode 100644 (file)
index 0000000..5be2aa6
--- /dev/null
@@ -0,0 +1,47 @@
+module LedXML where
+
+import Text.XML.Light
+import Data.Functor
+import qualified Data.Map as M
+import Data.Char
+import Data.Maybe
+import System.FilePath
+
+import Screen
+import ScreenFile
+import Sinus
+import Fonts
+
+-- XML file parsing
+
+readXMLFile :: Font -> FilePath -> IO ScreenElement
+readXMLFile font path = do
+    xml <- readFile path
+    let Just root = parseXMLDoc xml
+    xmlToScreenElement font root
+
+
+xmlToScreenElement :: Font -> Element -> IO ScreenElement
+xmlToScreenElement f e
+  | n == "screen"  = hconcat <$> ch
+  | n == "scrollH" = scrollH <$> hconcat <$> ch
+  | n == "spaceout" = spaceOut <$> ch
+  | n == "center"  = center <$> hconcat <$> ch
+  | n == "alternate", Just t <- findAttr (unqual "transition") e
+                     = let trans = fromMaybe (error $ "Unknown transition " ++ show t) $
+                                   M.lookup (map toLower t) transitions
+                       in alternateScroll trans <$> ch
+  | n == "alternate" = alternate <$> ch
+  | n == "sinus"   = return sinusScreenElement
+  | n == "icon"    = do
+        let basename = strContent e
+        readFromGif $ "icons" </> basename ++ ".gif"
+  | n == "thintext" = return $ text thinfont (strContent e)
+  | n == "text"     = return $ text f (strContent e)
+  | otherwise = error $ "Unknown element  " ++ show e
+
+  where
+    n = qName (elName e)
+    ch = mapM (xmlToScreenElement f) (elChildren e)
+
+
diff --git a/src/Screen.hs b/src/Screen.hs
new file mode 100644 (file)
index 0000000..e6cbc1f
--- /dev/null
@@ -0,0 +1,189 @@
+module Screen where
+
+import Codec.Picture
+import qualified Data.Map as M
+
+import Types
+
+-- The type of an LED screen
+
+-- 0 == off, anything else == 1
+type Screen = Image Pixel8
+
+emptyScreen :: Screen
+emptyScreen = blankScreen (wIDTH, hEIGHT)
+
+pixAt :: Screen -> Int -> Int -> Bool
+pixAt s x y = pixelAt s x y == 0
+
+pixAt' :: Screen -> Int -> Int -> Bool
+pixAt' s x y = x >= 0 && y >= 0 &&
+               x < imageWidth s && y < imageHeight s &&
+               pixAt s x y
+
+resize :: Rect -> Screen -> Screen
+resize r i | r == (iw, ih) = i
+           | otherwise     = generateScreen r $ pixAt' i
+  where iw = imageWidth i
+        ih = imageHeight i
+
+cut :: Rect -> Rect -> Screen -> Screen
+cut (x0,y0) (w,h) i = generateScreen (w,h) $ \x y -> pixAt' i (x+x0) (y+y0)
+
+
+
+-- The type of a screen element
+
+type Rect = (Int, Int)
+type FrameCounter = Int
+type Elem = Image Pixel8
+
+generateScreen :: Rect -> (Int -> Int -> Bool) -> Screen
+generateScreen (w,h) f = generateImage (\x y -> if f x y then 0 else 0xff) w h
+
+blankScreen :: Rect -> Screen
+blankScreen r = generateScreen r (\ _ _ -> False)
+
+
+data ScreenElement = ScreenElement
+    { seSize :: Rect
+    , seRender :: Rect -> FrameCounter -> Elem
+    }
+
+toElem :: Screen -> ScreenElement
+toElem i = ScreenElement (imageWidth i, imageHeight i) $ \r _ -> resize r i
+
+padElem :: Rect -> ScreenElement
+padElem r = ScreenElement r (\r' _ -> generateScreen r' (\_ _ -> False))
+
+padX x = padElem (x,0)
+padY y = padElem (0,y)
+
+center :: ScreenElement -> ScreenElement
+center se = ScreenElement (seSize se) $ \(w',h') f ->
+    let i = seRender se (w,h) f
+    in if (w,h) == (w',h')
+       then i
+       else generateScreen (w',h') $ \x y -> pixAt' i (x - (w'-w)`div`2) (y - (h'-h)`div`2)
+  where (w,h) = seSize se
+
+above :: ScreenElement -> ScreenElement -> ScreenElement
+above se1 se2 = ScreenElement (max w1 w2, h1 + h2) $ \(w,h) f ->
+    let h2 = h `div` 2
+        i1 = seRender se1 (w, h2) f
+        i2 = seRender se2 (w, h - h2) f
+    in generateScreen (w,h) $ \x y ->
+        if y < h2
+        then pixAt i1 x y
+        else pixAt i2 x (y - h2)
+  where (w1,h1) = seSize se1
+        (w2,h2) = seSize se2
+
+besides :: ScreenElement -> ScreenElement -> ScreenElement
+besides se1 se2 = ScreenElement (w1 + w2, max h1 h2) $ \(w,h) f ->
+    let w2 = w `div` 2
+        i1 = seRender se1 (w2, h) f
+        i2 = seRender se2 (w - w2, h) f
+    in generateScreen (w,h) $ \x y ->
+        if x < w2
+        then pixAt i1 x y
+        else pixAt i2 (x-w2) y
+  where (w1,h1) = seSize se1
+        (w2,h2) = seSize se2
+
+andElem :: ScreenElement -> ScreenElement -> ScreenElement
+andElem se1 se2 = ScreenElement (max w1 w2, max h1 h2) $ \r f ->
+    let i1 = seRender se1 r f
+        i2 = seRender se2 r f
+    in generateScreen r $ \x y -> pixAt i1 x y || pixAt i2 x y
+  where (w1,h1) = seSize se1
+        (w2,h2) = seSize se2
+
+hconcat :: [ScreenElement] -> ScreenElement
+hconcat elems = ScreenElement (w, h) $ \(w,h) f ->
+    let is = map (\e -> seRender e (fst (seSize e), h) f) elems
+    in generateScreen (w,h) $ \x y -> go x y is
+  where w = sum $ map (fst . seSize) elems
+        h = maximum $ 0 : map (snd . seSize) elems
+        go x y [] = False
+        go x y (i:is) | x < imageWidth i = pixAt i x y
+                      | otherwise = go (x - imageWidth i) y is
+
+scrollH :: ScreenElement -> ScreenElement
+scrollH se = ScreenElement (w,h) $ \(w',h') f ->
+    let cycleTime = w' + w
+        i = seRender se (w, h) f
+    in generateScreen (w',h') (\x y -> pixAt' i ((x - w' + f `div` slowness) `mod` cycleTime) y)
+  where
+    (w,h) = seSize se
+    slowness = 2
+
+spaceOut :: [ScreenElement] -> ScreenElement
+spaceOut elems = ScreenElement (w, h) $ \(w',h') f ->
+    let extraPixels = max 0 (w' - w)
+        -- TO improve:
+        holes = length elems - 1
+        pad1 = extraPixels `div` holes 
+        pad2 = pad1 + 1
+        pad2n = extraPixels - holes * pad1
+        pads = replicate (holes - pad2n) pad1 `zigZag` replicate pad2n pad2
+        ScreenElement _ r = hconcat (elems `zigZag` map padX pads) 
+    in r (w',h') f
+  where
+    w = sum $ map (fst . seSize) elems
+    h = maximum $ 0 : map (snd . seSize) elems
+
+zigZag :: [a] -> [a] -> [a]
+zigZag [] ys = ys
+zigZag (x:xs) ys = x : zigZag ys xs
+
+alternate :: [ScreenElement] -> ScreenElement
+alternate [] = toElem $ blankScreen (0,0)
+alternate elems = ScreenElement (w,h) $ \(w,h) f ->
+    seRender (elems !! ((f `div` duration) `mod` length elems)) (w,h) f
+  where w = maximum $ map (fst . seSize) elems
+        h = maximum $ map (snd . seSize) elems
+        duration = 5 * fPS
+
+alternateScroll :: Transition -> [ScreenElement] -> ScreenElement
+alternateScroll tran [] = toElem $ blankScreen (0,0)
+alternateScroll tran elems = ScreenElement (w,h) $ \(w,h) f ->
+    let i1  = seRender (elems !! ( (f `div` duration)      `mod` length elems)) (w,h) f
+        i2 = seRender (elems !! (((f `div` duration) + 1) `mod` length elems)) (w,h) f
+        d = 1 - min 1 (fromIntegral (duration - (f `mod` duration)) / fromIntegral transitionTime)
+    in  tran i1 i2 d
+  where w = maximum $ map (fst . seSize) elems
+        h = maximum $ map (snd . seSize) elems
+        duration = 5 * fPS
+        transitionTime = fPS
+
+type Transition = Screen -> Screen -> Double -> Screen
+
+dirac :: Transition
+dirac i _ _ = i
+
+scrollUp :: Transition
+scrollUp i1 i2 d =
+    generateScreen (w,h) $ \x y -> pixAt' i1  x (y+dy) || pixAt' i2 x (y+dy-h)
+  where
+    w = imageWidth i1
+    h = imageHeight i1
+    dy = round (d * fromIntegral h)
+
+rollUp :: Transition
+rollUp i1 i2 d =
+    generateScreen (w,h) $
+        \x y -> if y < dy then pixAt' i1 x y
+                          else pixAt' i2 x y
+  where
+    w = imageWidth i1
+    h = imageHeight i1
+    dy = round ((1-d) * fromIntegral h)
+
+transitions :: M.Map String Transition
+transitions = M.fromList
+    [ ("dirac", dirac)
+    , ("scrollup", scrollUp)
+    , ("rollup", rollUp)
+    ]
+
diff --git a/src/ScreenFile.hs b/src/ScreenFile.hs
new file mode 100644 (file)
index 0000000..a99c2d1
--- /dev/null
@@ -0,0 +1,16 @@
+module ScreenFile where
+
+import Codec.Picture
+import Data.Functor
+
+import Screen
+
+readFromGif :: FilePath -> IO ScreenElement
+readFromGif filename = do
+    gif <- either error id <$> readGifImages filename
+    let elems = map (pixelMap (\ (PixelRGB8 r g b) -> maximum [r,g,b])) gif
+    let n = length elems
+    return $ ScreenElement (imageWidth (head elems), imageHeight (head elems)) $
+        \r f -> resize r (elems !! (f `mod` n))
+
+
diff --git a/src/Sinus.hs b/src/Sinus.hs
new file mode 100644 (file)
index 0000000..7ac8233
--- /dev/null
@@ -0,0 +1,8 @@
+module Sinus where
+
+import Screen
+
+sinusScreenElement = ScreenElement (0,0) $ \(w,h) f ->
+    generateScreen (w,h) $ \x y ->
+        abs (fromIntegral y + 0.5  - (fromIntegral h/2)
+                 - sin (fromIntegral (x + f) / 2) * (fromIntegral h/2)) <= (0.5::Double)
diff --git a/src/Terminal.hs b/src/Terminal.hs
new file mode 100644 (file)
index 0000000..4155919
--- /dev/null
@@ -0,0 +1,20 @@
+module Terminal where
+
+import System.Console.ANSI
+import Control.Exception
+
+import Screen
+import Types
+
+openTerminal :: ((Screen -> IO ()) -> IO a) -> IO a
+openTerminal cont = do
+    clearScreen
+    setSGR [SetColor Foreground Vivid Green]
+    hideCursor
+    let upd i = do
+        clearScreen
+        putStr $ unlines
+            [ [ if pixAt i x y then '★' else ' ' | x <- [0..wIDTH-1]] | y <- [0..hEIGHT-1] ]
+    cont upd `finally` (showCursor >> setSGR [Reset])
+
+
diff --git a/src/Types.hs b/src/Types.hs
new file mode 100644 (file)
index 0000000..077ab40
--- /dev/null
@@ -0,0 +1,10 @@
+module Types where
+
+wIDTH, hEIGHT, fPS, fRAME_DELAY :: Int
+
+wIDTH = 21
+hEIGHT = 7
+fPS = 15
+fRAME_DELAY = 1000000 `div` fPS
+
+
diff --git a/src/USB.hs b/src/USB.hs
new file mode 100644 (file)
index 0000000..5c1ef1c
--- /dev/null
@@ -0,0 +1,61 @@
+module USB where
+
+import Codec.Picture
+import System.USB
+import qualified Data.ByteString as B
+import Data.Bits
+import Data.IORef
+import Control.Concurrent
+import Control.Monad
+import qualified Data.Vector as V
+import System.Exit
+
+
+import Screen
+import Types
+
+-- USB interface
+
+toPkg :: Screen -> [B.ByteString]
+toPkg s =
+    [ B.pack $ 0 : fromIntegral r : row r ++ row (r+1)
+    | r <- [0,2,4,6]]
+  where
+    row r = [ byte r o | o <- [16,8,0] ]
+    byte r o = sum [ bit i | r < hEIGHT, i <- [0..7], o + i < wIDTH, pixelAt s (o+i) r > 0]
+
+
+openLEDDevice :: ((Screen -> IO ()) -> IO a) -> IO a
+openLEDDevice cont = do
+    ref <- newIORef emptyScreen
+    forkIO $ do
+        ctx <- newCtx
+        setDebug ctx PrintWarnings
+        devs <- getDevices ctx
+        mbdev <- findM isLEDDisplay devs
+        case mbdev of
+            Nothing -> do
+                putStrLn "Device 0x1d34:0013 not found."
+                putStrLn "Devices present:"
+                V.mapM (putStrLn . ("    "++) . show) devs
+                exitFailure
+            Just dev -> withDeviceHandle dev $ \h -> forever $ do
+                    s <- readIORef ref
+                    forM_ (toPkg s) $ \p -> do
+                        writeControl h Class ToEndpoint 0x09 0 0 p 1000
+                    threadDelay fRAME_DELAY
+    cont (writeIORef ref)
+
+isLEDDisplay :: Device -> IO Bool
+isLEDDisplay dev = do
+    desc <- getDeviceDesc dev
+    return $     deviceVendorId desc  == 0x1d34
+             &&  deviceProductId desc == 0x0013
+
+
+findM :: Monad m => (a -> m Bool) -> V.Vector a -> m (Maybe a)
+findM pred = go . V.toList
+  where go [] = return Nothing
+        go (x:xs) = do
+            p <- pred x
+            if p then return (Just x) else go xs
diff --git a/src/led-main.hs b/src/led-main.hs
new file mode 100644 (file)
index 0000000..5f6072b
--- /dev/null
@@ -0,0 +1,45 @@
+import qualified Data.Map as M
+import System.Environment
+import Control.Concurrent
+import System.FSNotify
+import System.FilePath
+import qualified Filesystem.Path.CurrentOS as FP
+import Data.IORef
+
+import Types
+import Screen
+import Fonts
+import USB
+import LedXML
+
+--main = openTerminal $ \setScreen -> do
+main = openLEDDevice $ \setScreen -> do
+    font <- readFont
+    [filename] <- getArgs
+    elemRef <- reReadFile (readXMLFile font) filename 
+
+    renderLoop setScreen elemRef
+
+reReadFile :: (FilePath -> IO a) -> FilePath -> IO (IORef a)
+reReadFile read name = do
+    let name' = FP.decodeString name
+    x <- read name
+    ref <- newIORef x
+    manager <- startManager
+    watchDir manager (FP.directory name')
+        (\e -> case e of Modified p _ -> FP.filename p == FP.filename name'
+                         Added p _    -> FP.filename p == FP.filename name'
+                         _            -> False)
+        (\e -> read name >>= writeIORef ref)
+    return ref
+
+
+renderLoop :: (Elem -> IO a) -> IORef ScreenElement -> IO a
+renderLoop setScreen elemRef = go 0
+  where
+    go n = do
+        elem <- readIORef elemRef
+        setScreen (seRender elem (wIDTH, hEIGHT) n)
+        threadDelay fRAME_DELAY
+        go (n+1)
+