module System.Hardware.PiLcd.UnicodeLcd
(
mkLcd
, Lcd
, lcdOptions
, LcdOptions(..)
, defaultLcdOptions
, RomCode(..)
, updateDisplay
, getCharStatus
, CharStatus(..)
, nativeChar
) where
import Control.Arrow
import Control.DeepSeq
import Control.Exception
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
data Lcd =
Lcd
{ lcdOptions :: !LcdOptions
, lcdCb :: !LcdCallbacks
, lcdLines :: IORef [B.ByteString]
, lcdCustom :: IORef CustomInfo
, lcdEncoding :: !CharEncoding
}
data CustomInfo =
CustomInfo
{ ciGeneration :: !Integer
, ciChars :: ![(Char, Integer)]
}
instance NFData CustomInfo where
rnf x = (rnf $ ciGeneration x) `seq` (rnf $ ciChars x)
data CharEncoding =
CharEncoding
{ ceBuiltIn :: EncodingHash
, ceCustom :: [(Char, [Word8])]
, ceCustomMapping :: [Char]
}
data LcdOptions =
LcdOptions
{ loLines :: !Int
, loColumns :: !Int
, loRomCode :: RomCode
, loCustomChars :: [(Char, [Word8])]
} deriving (Eq, Ord, Show, Read)
defaultLcdOptions :: LcdOptions
defaultLcdOptions =
LcdOptions
{ loLines = 2
, loColumns = 16
, loRomCode = RomA00
, loCustomChars = []
}
data RomCode = RomA00 | RomA02
deriving (Eq, Ord, Show, Read, Bounded, Enum)
type EncodingHash = H.HashMap Char Word8
tableA00 :: [(Int, Word8)]
tableA00 =
[ (0x00A5, 0x5c)
, (0x2192, 0x7e)
, (0x2190, 0x7f)
, (0x2219, 0xa5)
, (0x2203, 0xd6)
, (0x25AF, 0xdb)
, (0x00B0, 0xdf)
, (0x03B1, 0xe0)
, (0x00E4, 0xe1)
, (0x03B2, 0xe2)
, (0x03B5, 0xe3)
, (0x03BC, 0xe4)
, (0x03C3, 0xe5)
, (0x03C1, 0xe6)
, (0x221A, 0xe8)
, (0x00A2, 0xec)
, (0x00F6, 0xef)
, (0x0398, 0xf2)
, (0x03A9, 0xf4)
, (0x00FC, 0xf5)
, (0x03A3, 0xf6)
, (0x03C0, 0xf7)
, (0x00F7, 0xfd)
, (0x2588, 0xff)
]
hashA00 :: EncodingHash
hashA00 = mkTable tableA00 $ [0x20..0x5b] ++ [0x5d..0x7d]
tableA02 :: [(Int, Word8)]
tableA02 =
[ (0x25B6, 0x10)
, (0x25C0, 0x11)
, (0x201c, 0x12)
, (0x201d, 0x13)
, (0x23EB, 0x14)
, (0x23EC, 0x15)
, (0x2022, 0x16)
, (0x23CE, 0x17)
, (0x2191, 0x18)
, (0x2193, 0x19)
, (0x2192, 0x1a)
, (0x2190, 0x1b)
, (0x2264, 0x1c)
, (0x2265, 0x1d)
, (0x25B2, 0x1e)
, (0x25BC, 0x1f)
, (0x2302, 0x7f)
, (0x0411, 0x80)
, (0x0414, 0x81)
, (0x0416, 0x82)
, (0x0417, 0x83)
, (0x0418, 0x84)
, (0x0419, 0x85)
, (0x041B, 0x86)
, (0x041F, 0x87)
, (0x0423, 0x88)
, (0x0426, 0x89)
, (0x0427, 0x8a)
, (0x0428, 0x8b)
, (0x0429, 0x8c)
, (0x042A, 0x8d)
, (0x042B, 0x8e)
, (0x042D, 0x8f)
, (0x03B1, 0x90)
, (0x266A, 0x91)
, (0x0393, 0x92)
, (0x03C0, 0x93)
, (0x03A3, 0x94)
, (0x03C3, 0x95)
, (0x266C, 0x96)
, (0x03C4, 0x97)
, (0x1F514, 0x98)
, (0x0398, 0x99)
, (0x03A9, 0x9a)
, (0x03B4, 0x9b)
, (0x2665, 0x9d)
, (0x03B5, 0x9e)
, (0x2229, 0x9f)
, (0x2016, 0xa0)
]
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)
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
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
updateDisplay :: Lcd -> [T.Text] -> IO ()
updateDisplay lcd newText = mask_ $ 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
newBs `deepseq` writeIORef (lcdLines lcd) newBs
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)
mkLcd :: LcdCallbacks -> LcdOptions -> IO Lcd
mkLcd cb lo = do
let ls = rearrange $ replicate (loLines lo) $ B.replicate (loColumns lo) 0x20
nonChar = chr 0xffff
ref <- newIORef ls
cust <- newIORef $ CustomInfo 0 (replicate 8 (nonChar, 0))
let (Just builtIn) = loRomCode lo `lookup` hashTables
ce = CharEncoding
{ ceBuiltIn = builtIn
, ceCustom = loCustomChars lo
, ceCustomMapping = []
}
return $ Lcd lo cb ref cust ce
nativeChar :: Word8 -> Char
nativeChar x = chr (0x10FE00 + fromIntegral x)
data CharStatus = CharBuiltin
| CharCustom
| CharNotFound
deriving (Eq, Ord, Show, Read, Bounded, Enum)
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')
ci' `deepseq` writeIORef ref ci'
forM oldNew $ \(i, old, new) -> do
when (old /= new) $ do
let (Just cd) = getCharData lcd new
lcdDefineChar (lcdCb lcd) i cd
return new