{-|
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
<https://www.cl.cam.ac.uk/~mgk25/ucs-fonts.html 5x8 fixed font>
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
<https://hackage.haskell.org/package/unicode-transforms unicode-transforms>
package to convert to Normalization Form C.

Displays up to 20x4 should be supported, although only 16x2 has been tested.

'Lcd' is not threadsafe (you'll need to do your own locking), but it
is safe in the presence of async exceptions.
-}

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.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

-- | 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)
  }

instance NFData CustomInfo where
  rnf x = (rnf $ ciGeneration x) `seq` (rnf $ ciChars x)

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
-- <https://www.adafruit.com/datasheets/HD44780.pdf HD44780U datasheet>.)
-- Unfortunately, as best as I can interpret
-- <https://forums.adafruit.com/viewtopic.php?f=50&t=111019 this exchange with Adafruit customer support>,
-- 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 = 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

-- 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
                                -- <https://www.cl.cam.ac.uk/~mgk25/ucs-fonts.html 5x8 fixed font>,
                                -- 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')
  ci' `deepseq` 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