{-| Module : System.Hardware.PiLcd.UnicodeLcd Description : Display Unicode characters on an LCD Copyright : © Patrick Pelletier, 2017 License : BSD3 Maintainer : code@funwithsoftware.org Displays Unicode text on an LCD. Only updates the parts of the LCD which have changed. Automatically manages custom characters, using the for characters which are not built-in to the the LCD controller's ROM. Only eight distinct non-built-in characters can be on the display at any one time. Only supports characters which are made up of a single code point. (In other words, combining marks are not supported.) If your input contains decomposed characters, consider using the package to convert to Normalization Form C. Displays up to 20x4 should be supported, although only 16x2 has been tested. -} module System.Hardware.PiLcd.UnicodeLcd ( -- * Creating an LCD mkLcd , Lcd , lcdOptions , LcdOptions(..) , defaultLcdOptions , RomCode(..) -- * Displaying text , updateDisplay -- * Characters , getCharStatus , CharStatus(..) , nativeChar ) where import Control.Arrow import Control.Monad import Data.Char import qualified Data.ByteString as B import qualified Data.HashMap.Strict as H import Data.IORef import Data.List import Data.Maybe import Data.Monoid import Data.Ord import qualified Data.Text as T import Data.Word import System.Hardware.PiLcd.Font5x8 import System.Hardware.PiLcd.Hd44780 import System.Hardware.PiLcd.Util -- | An opaque type representing an LCD. data Lcd = Lcd { lcdOptions :: LcdOptions -- ^ Returns the 'LcdOptions' that were passed to 'mkLcd' , lcdCb :: LcdCallbacks , lcdLines :: IORef [B.ByteString] , lcdCustom :: IORef CustomInfo , lcdEncoding :: CharEncoding } data CustomInfo = CustomInfo { ciGeneration :: Integer -- a counter that is incremented -- each time updateDisplay is called , ciChars :: [(Char, Integer)] -- a list of 8 elements, one for each -- custom character slot, indicating -- which character is currently in the -- slot, and when it was last used -- (in terms of the generation counter) } data CharEncoding = CharEncoding { ceBuiltIn :: EncodingHash , ceCustom :: [(Char, [Word8])] , ceCustomMapping :: [Char] } -- | Specifies the characteristics of the LCD. data LcdOptions = LcdOptions { loLines :: !Int -- ^ Number of lines , loColumns :: !Int -- ^ Number of columns , loRomCode :: RomCode -- ^ Built-in character set , loCustomChars :: [(Char, [Word8])] -- ^ Additional user-defined characters, -- beyond those in the 5x8 fixed font. -- Character is defined as 8 bytes, with -- data in least-significant 5 bits. } deriving (Eq, Ord, Show, Read) -- | Defaults to 2 lines, 16 columns, ROM code A00, and no additional -- custom characters. defaultLcdOptions :: LcdOptions defaultLcdOptions = LcdOptions { loLines = 2 , loColumns = 16 , loRomCode = RomA00 , loCustomChars = [] } -- | The HD44780U LCD controller comes in two different variants with -- different character ROMs. (See Table 4 on pages 17-18 of the -- .) -- Unfortunately, as best as I can interpret -- , -- Adafruit ships a mixture of A00 ROMs and A02 ROMs, depending on what's -- available at the moment. -- (\"We take what's available or we don't sell LCDs.\") This is a bit -- annoying, since there doesn't seem to be any way to query the HD44780U -- to find out which ROM it has. So, the user has to test their LCD -- and then specify which ROM they have. data RomCode = RomA00 | RomA02 deriving (Eq, Ord, Show, Read, Bounded, Enum) type EncodingHash = H.HashMap Char Word8 -- This list is incomplete; pull requests are welcome tableA00 :: [(Int, Word8)] tableA00 = [ (0x00A5, 0x5c) -- ¥ YEN SIGN , (0x2192, 0x7e) -- → RIGHTWARDS ARROW , (0x2190, 0x7f) -- ← LEFTWARDS ARROW , (0x2219, 0xa5) -- ∙ BULLET OPERATOR , (0x2203, 0xd6) -- ∃ THERE EXISTS , (0x25AF, 0xdb) -- ▯ WHITE VERTICAL RECTANGLE , (0x00B0, 0xdf) -- ° DEGREE SIGN , (0x03B1, 0xe0) -- α GREEK SMALL LETTER ALPHA , (0x00E4, 0xe1) -- ä LATIN SMALL LETTER A WITH DIAERESIS , (0x03B2, 0xe2) -- β GREEK SMALL LETTER BETA , (0x03B5, 0xe3) -- ε GREEK SMALL LETTER EPSILON , (0x03BC, 0xe4) -- μ GREEK SMALL LETTER MU , (0x03C3, 0xe5) -- σ GREEK SMALL LETTER SIGMA , (0x03C1, 0xe6) -- ρ GREEK SMALL LETTER RHO , (0x221A, 0xe8) -- √ SQUARE ROOT , (0x00A2, 0xec) -- ¢ CENT SIGN , (0x00F6, 0xef) -- ö LATIN SMALL LETTER O WITH DIAERESIS , (0x0398, 0xf2) -- Θ GREEK CAPITAL LETTER THETA , (0x03A9, 0xf4) -- Ω GREEK CAPITAL LETTER OMEGA , (0x00FC, 0xf5) -- ü LATIN SMALL LETTER U WITH DIAERESIS , (0x03A3, 0xf6) -- Σ GREEK CAPITAL LETTER SIGMA , (0x03C0, 0xf7) -- π GREEK SMALL LETTER PI , (0x00F7, 0xfd) -- ÷ DIVISION SIGN , (0x2588, 0xff) -- █ FULL BLOCK ] hashA00 :: EncodingHash hashA00 = mkTable tableA00 $ [0x20..0x5b] ++ [0x5d..0x7d] tableA02 :: [(Int, Word8)] tableA02 = [ (0x25B6, 0x10) -- ▶ BLACK RIGHT-POINTING TRIANGLE , (0x25C0, 0x11) -- ◀ BLACK LEFT-POINTING TRIANGLE , (0x201c, 0x12) -- “ LEFT DOUBLE QUOTATION MARK , (0x201d, 0x13) -- ” RIGHT DOUBLE QUOTATION MARK , (0x23EB, 0x14) -- ⏫ BLACK UP-POINTING DOUBLE TRIANGLE , (0x23EC, 0x15) -- ⏬ BLACK DOWN-POINTING DOUBLE TRIANGLE , (0x2022, 0x16) -- • BULLET , (0x23CE, 0x17) -- ⏎ RETURN SYMBOL , (0x2191, 0x18) -- ↑ UPWARDS ARROW , (0x2193, 0x19) -- ↓ DOWNWARDS ARROW , (0x2192, 0x1a) -- → RIGHTWARDS ARROW , (0x2190, 0x1b) -- ← LEFTWARDS ARROW , (0x2264, 0x1c) -- ≤ LESS-THAN OR EQUAL TO , (0x2265, 0x1d) -- ≥ GREATER-THAN OR EQUAL TO , (0x25B2, 0x1e) -- ▲ BLACK UP-POINTING TRIANGLE , (0x25BC, 0x1f) -- ▼ BLACK DOWN-POINTING TRIANGLE , (0x2302, 0x7f) -- ⌂ HOUSE , (0x0411, 0x80) -- Б CYRILLIC CAPITAL LETTER BE , (0x0414, 0x81) -- Д CYRILLIC CAPITAL LETTER DE , (0x0416, 0x82) -- Ж CYRILLIC CAPITAL LETTER ZHE , (0x0417, 0x83) -- З CYRILLIC CAPITAL LETTER ZE , (0x0418, 0x84) -- И CYRILLIC CAPITAL LETTER I , (0x0419, 0x85) -- Й CYRILLIC CAPITAL LETTER SHORT I , (0x041B, 0x86) -- Л CYRILLIC CAPITAL LETTER EL , (0x041F, 0x87) -- П CYRILLIC CAPITAL LETTER PE , (0x0423, 0x88) -- У CYRILLIC CAPITAL LETTER U , (0x0426, 0x89) -- Ц CYRILLIC CAPITAL LETTER TSE , (0x0427, 0x8a) -- Ч CYRILLIC CAPITAL LETTER CHE , (0x0428, 0x8b) -- Ш CYRILLIC CAPITAL LETTER SHA , (0x0429, 0x8c) -- Щ CYRILLIC CAPITAL LETTER SHCHA , (0x042A, 0x8d) -- Ъ CYRILLIC CAPITAL LETTER HARD SIGN , (0x042B, 0x8e) -- Ы CYRILLIC CAPITAL LETTER YERU , (0x042D, 0x8f) -- Э CYRILLIC CAPITAL LETTER E , (0x03B1, 0x90) -- α GREEK SMALL LETTER ALPHA , (0x266A, 0x91) -- ♪ EIGHTH NOTE , (0x0393, 0x92) -- Γ GREEK CAPITAL LETTER GAMMA , (0x03C0, 0x93) -- π GREEK SMALL LETTER PI , (0x03A3, 0x94) -- Σ GREEK CAPITAL LETTER SIGMA , (0x03C3, 0x95) -- σ GREEK SMALL LETTER SIGMA , (0x266C, 0x96) -- ♬ BEAMED SIXTEENTH NOTES , (0x03C4, 0x97) -- τ GREEK SMALL LETTER TAU , (0x1F514, 0x98) -- 🔔 BELL , (0x0398, 0x99) -- Θ GREEK CAPITAL LETTER THETA , (0x03A9, 0x9a) -- Ω GREEK CAPITAL LETTER OMEGA , (0x03B4, 0x9b) -- δ GREEK SMALL LETTER DELTA -- can't tell what 0x9c is supposed to be , (0x2665, 0x9d) -- ♥ BLACK HEART SUIT , (0x03B5, 0x9e) -- ε GREEK SMALL LETTER EPSILON , (0x2229, 0x9f) -- ∩ INTERSECTION , (0x2016, 0xa0) -- ‖ DOUBLE VERTICAL LINE ] hashA02 :: EncodingHash hashA02 = mkTable tableA02 $ [0x20..0x7e] ++ [0xa1..0xff] hashTables :: [(RomCode, EncodingHash)] hashTables = [(RomA00, hashA00), (RomA02, hashA02)] mkTable :: [(Int, Word8)] -> [Word8] -> EncodingHash mkTable table identityChars = H.fromList $ map (first chr) table ++ map f identityChars ++ map g [0..0xff] where f c = (chr $ fromIntegral c, c) g c = (nativeChar c, c) -- supportedChars :: Lcd -> [(Char, CharStatus)] unicodeToByte :: CharEncoding -> Char -> Maybe Word8 unicodeToByte ce c = case c `elemIndex` ceCustomMapping ce of (Just i) -> Just (fromIntegral i) Nothing -> H.lookup c (ceBuiltIn ce) ff :: (Int, [(Int, Int)]) -> [Bool] -> (Int, [(Int, Int)]) ff (len, spans) bools = let myLen = length bools polarity = head bools spans' = if polarity then spans -- new bytes and old bytes are equal else (len, myLen) : spans len' = len + myLen in (len', spans') extractBytes :: B.ByteString -> (Int, Int) -> (Int, B.ByteString) extractBytes bs (col, len) = (col, subStr) where subStr = B.take len $ B.drop col bs findSpans :: B.ByteString -> B.ByteString -> [(Int, B.ByteString)] findSpans old new = let bitMap = zipWith (==) (B.unpack old) (B.unpack new) grp = group bitMap pairs = snd $ foldl' ff (0, []) grp in sort $ map (extractBytes new) pairs addLine :: [(Int, B.ByteString)] -> Int -> [(Int, Int, B.ByteString)] addLine spans line = map f spans where f (col, bs) = (line, col, bs) bytesToSpans :: [B.ByteString] -> [B.ByteString] -> [(Int, Int, B.ByteString)] bytesToSpans old new = let spans = zipWith findSpans old new spans' = zipWith addLine spans [0..] in concat spans' ensureLength :: LcdOptions -> [T.Text] -> [T.Text] ensureLength lo ls = map ensureCols $ take numLines $ ls ++ repeat T.empty where ensureCols = padLine numColumns numLines = loLines lo numColumns = loColumns lo txtToBs :: CharEncoding -> T.Text -> B.ByteString txtToBs ce txt = B.pack $ map (fromMaybe 0x3f . unicodeToByte ce) $ T.unpack txt -- | Updates the contents of the LCD. You must specify the full contents -- of the screen, but only the parts which have changed since the last update -- are sent to the hardware. Converts from Unicode to the display's -- internal encoding, and automatically creates custom characters for -- characters which are not directly supported by the LCD. updateDisplay :: Lcd -> [T.Text] -> IO () updateDisplay lcd newText = do let cc = getCustomChars lcd $ concatMap T.unpack newText cm <- writeCustomChars lcd cc let ce = (lcdEncoding lcd) { ceCustomMapping = cm } updateDisplay' lcd ce newText updateDisplay' :: Lcd -> CharEncoding -> [T.Text] -> IO () updateDisplay' lcd ce newTxt = do oldBs <- readIORef (lcdLines lcd) let newTxt' = rearrange $ ensureLength (lcdOptions lcd) newTxt newBs = map (txtToBs ce) newTxt' spans = bytesToSpans oldBs newBs forM_ spans $ \(line, col, bs) -> lcdWrite (lcdCb lcd) (fromIntegral line) (fromIntegral col) bs writeIORef (lcdLines lcd) newBs -- Convert multiple lines to 2 or fewer lines. -- In a 4-line display, lines 1 and 3 are treated as a single line, -- and lines 2 and 4 are treated as a single line. rearrange :: Monoid a => [a] -> [a] rearrange [] = [] rearrange [x] = [x] rearrange xs = [l1, l2] where (l1, l2) = f xs f [] = (mempty, mempty) f [y] = (y, mempty) f (y1:y2:rest) = let (z1, z2) = f rest in (y1 <> z1, y2 <> z2) -- | Given callbacks and options, creates an 'Lcd'. Assumes the display -- has already been initialized via a call to 'lcdInitialize'. mkLcd :: LcdCallbacks -> LcdOptions -> IO Lcd mkLcd cb lo = do let ls = rearrange $ replicate (loLines lo) $ B.replicate (loColumns lo) 0x20 nonChar = chr 0xffff -- a noncharacter according to Unicode standard ref <- newIORef ls cust <- newIORef $ CustomInfo 0 (replicate 8 (nonChar, 0)) let (Just builtIn) = loRomCode lo `lookup` hashTables -- should be safe ce = CharEncoding { ceBuiltIn = builtIn , ceCustom = loCustomChars lo , ceCustomMapping = [] -- unused in this context } return $ Lcd lo cb ref cust ce -- | If for some reason you want to specify a character in the native -- 8-bit encoding of the LCD, instead of in Unicode, just call -- 'nativeChar' on the 8-bit character value. This maps it to a -- region of the Private Use Area which is treated specially. nativeChar :: Word8 -> Char nativeChar x = chr (0x10FE00 + fromIntegral x) -- | Indicates whether a character can be found as a built-in or -- custom character data CharStatus = CharBuiltin -- ^ character is supported by the LCD's ROM | CharCustom -- ^ not supported by ROM, but available in -- , -- or in the user-defined characters specified -- in 'loCustomChars' | CharNotFound -- ^ not available in ROM, 5x8 fixed font, or -- 'loCustomChars' deriving (Eq, Ord, Show, Read, Bounded, Enum) -- | Given a Unicode code point, determines whether the character is -- built-in, or is considered a custom character (of which only eight can -- be on the screen at any one time). getCharStatus :: Lcd -> Char -> CharStatus getCharStatus lcd c = let ce = lcdEncoding lcd user = c `lookup` ceCustom ce builtIn = c `H.lookup` ceBuiltIn ce inFont = getCharacter c in case user of (Just _) -> CharCustom Nothing -> case builtIn of (Just _) -> CharBuiltin Nothing -> case inFont of (Just _) -> CharCustom Nothing -> CharNotFound getCharData :: Lcd -> Char -> Maybe [Word8] getCharData lcd c = let ce = lcdEncoding lcd user = c `lookup` ceCustom ce in case user of (Just _) -> user Nothing -> getCharacter c getCustomChars :: Lcd -> String -> String getCustomChars lcd str = sort $ nub $ filter (\x -> getCharStatus lcd x == CharCustom) str matchExistingChars :: [(Char, Integer)] -> String -> (String, [(Int, Integer)]) matchExistingChars cust chars = let pairs = zip [0..] cust existing = map fst cust common = existing `intersect` chars chars' = chars \\ common pairs' = filter ff pairs ff (_, (c, _)) = c `notElem` common f (pos, (_, generation)) = (pos, generation) in (chars', map f pairs') allocateCustomChars :: CustomInfo -> String -> CustomInfo allocateCustomChars ci chars = let (chars', available) = matchExistingChars (ciChars ci) chars available' = map fst $ sortBy (comparing snd) available pairs = zip available' chars' generation = 1 + ciGeneration ci newStuff = zipWith replace [0..] (ciChars ci) replace i old@(c, _) = case i `lookup` pairs of Nothing -> if c `elem` chars then (c, generation) else old (Just c') -> (c', generation) in CustomInfo generation newStuff writeCustomChars :: Lcd -> String -> IO [Char] writeCustomChars lcd chars = do let ref = lcdCustom lcd ci <- readIORef ref let ci' = allocateCustomChars ci chars oldNew = zip3 [0..] (map fst $ ciChars ci) (map fst $ ciChars ci') writeIORef ref ci' forM oldNew $ \(i, old, new) -> do when (old /= new) $ do let (Just cd) = getCharData lcd new -- this should be safe lcdDefineChar (lcdCb lcd) i cd return new