module App.LCD(
LCD, LCDController(..), lcdRegister
, lcdClear, lcdWrite
, lcdHome, lcdSetCursor
, lcdAutoScrollOn, lcdAutoScrollOff
, lcdScrollDisplayLeft, lcdScrollDisplayRight
, lcdLeftToRight, lcdRightToLeft
, lcdBlinkOn, lcdBlinkOff
, lcdCursorOn, lcdCursorOff
, lcdDisplayOn, lcdDisplayOff
, LCDSymbol, lcdInternalSymbol, lcdWriteSymbol
, lcdCreateSymbol
, lcdFlash
) where
import Control.Concurrent (threadDelay)
import Control.Concurrent (MVar,modifyMVar,newMVar)
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Data.Bits (testBit, (.|.), (.&.), setBit, clearBit, shiftL, bit)
import Data.Char (ord, isSpace)
import Data.Maybe (fromMaybe)
import Data.Word (Word8)
import STM32.MachineInterface
import STM32.GPIO as GPIO
debug :: String -> MI ()
debug = liftIO . putStrLn
delay :: Int -> MI ()
delay = liftIO . threadDelay
digitalWrite :: Wire -> Bool -> MI ()
digitalWrite = GPIO.pinOut
data LCD = LCD {
_controller :: LCDController
,_state :: MVar LCDData
}
data LCDController = Hitachi44780 {
lcdRS :: Wire
, lcdEN :: Wire
, lcdD4 :: Wire
, lcdD5 :: Wire
, lcdD6 :: Wire
, lcdD7 :: Wire
, lcdRows :: Int
, lcdCols :: Int
, dotMode5x10 :: Bool
}
deriving Show
data LCDData = LCDData {
lcdDisplayMode :: Word8
, lcdDisplayControl :: Word8
, lcdGlyphCount :: Word8
, lcdController :: LCDController
}
data Cmd = LCD_INITIALIZE
| LCD_INITIALIZE_END
| LCD_FUNCTIONSET
| LCD_DISPLAYCONTROL Word8
| LCD_CLEARDISPLAY
| LCD_ENTRYMODESET Word8
| LCD_RETURNHOME
| LCD_SETDDRAMADDR Word8
| LCD_CURSORSHIFT Word8
| LCD_SETCGRAMADDR Word8
getCmdVal :: LCDController -> Cmd -> Word8
getCmdVal Hitachi44780{lcdRows, dotMode5x10} = get
where multiLine
| lcdRows > 1 = 0x08 :: Word8
| True = 0x00 :: Word8
dotMode
| dotMode5x10 = 0x04 :: Word8
| True = 0x00 :: Word8
displayFunction = multiLine .|. dotMode
get LCD_INITIALIZE = 0x33
get LCD_INITIALIZE_END = 0x32
get LCD_FUNCTIONSET = 0x20 .|. displayFunction
get (LCD_DISPLAYCONTROL w) = 0x08 .|. w
get LCD_CLEARDISPLAY = 0x01
get (LCD_ENTRYMODESET w) = 0x04 .|. w
get LCD_RETURNHOME = 0x02
get (LCD_SETDDRAMADDR w) = 0x80 .|. w
get (LCD_CURSORSHIFT w) = 0x10 .|. 0x08 .|. w
get (LCD_SETCGRAMADDR w) = 0x40 .|. w `shiftL` 3
initLCD :: LCD -> LCDController -> MI ()
initLCD lcd c@Hitachi44780{lcdRS, lcdEN, lcdD4, lcdD5, lcdD6, lcdD7} = do
debug "Starting the LCD initialization sequence"
mapM_ (\w -> GPIO.pinMode w $ GPOutPushPull MHz_2)
[lcdRS, lcdEN, lcdD4, lcdD5, lcdD6, lcdD7]
delay 50
sendCmd c LCD_INITIALIZE
delay 5
sendCmd c LCD_INITIALIZE_END
sendCmd c LCD_FUNCTIONSET
lcdCursorOff lcd
lcdBlinkOff lcd
lcdLeftToRight lcd
lcdAutoScrollOff lcd
lcdHome lcd
lcdClear lcd
lcdDisplayOn lcd
getController :: LCD -> MI LCDController
getController lcd = return $ _controller lcd
sendCmd :: LCDController -> Cmd -> MI ()
sendCmd c = transmit False c . getCmdVal c
sendData :: LCDController -> Word8 -> MI ()
sendData lcd n = do debug $ "Transmitting LCD data: " ++ show n
transmit True lcd n
pulseEnable :: LCDController -> MI ()
pulseEnable Hitachi44780{lcdEN} = do
debug "Sending LCD pulseEnable"
digitalWrite lcdEN False
delay 1
digitalWrite lcdEN True
delay 1
digitalWrite lcdEN False
delay 1
transmit :: Bool -> LCDController -> Word8 -> MI ()
transmit mode c@Hitachi44780{lcdRS, lcdEN, lcdD4, lcdD5, lcdD6, lcdD7} val = do
digitalWrite lcdRS mode
digitalWrite lcdEN False
let [b7, b6, b5, b4, b3, b2, b1, b0] = [val `testBit` i | i <- [7, 6 .. 0]]
digitalWrite lcdD4 b4
digitalWrite lcdD5 b5
digitalWrite lcdD6 b6
digitalWrite lcdD7 b7
pulseEnable c
digitalWrite lcdD4 b0
digitalWrite lcdD5 b1
digitalWrite lcdD6 b2
digitalWrite lcdD7 b3
pulseEnable c
withLCD :: LCD -> String -> (LCDController -> MI a) -> MI a
withLCD lcd what action = do
debug what
c <- getController lcd
action c
lcdRegister :: LCDController -> MI LCD
lcdRegister controller = do
let
ld = LCDData { lcdDisplayMode = 0
, lcdDisplayControl = 0
, lcdGlyphCount = 0
, lcdController = controller
}
ref <- liftIO $ newMVar ld
let lcd = LCD {_controller=controller,_state=ref}
case controller of
Hitachi44780{} -> initLCD lcd controller
return lcd
lcdWrite :: LCD -> String -> MI ()
lcdWrite lcd m = withLCD lcd ("Writing " ++ show m ++ " to LCD") $ \c -> mapM_ (sendData c) m'
where m' = map (\ch -> fromIntegral (ord ch) .&. 0xFF) m
lcdClear :: LCD -> MI ()
lcdClear lcd = withLCD lcd "Sending clearLCD" $ \c ->
do sendCmd c LCD_CLEARDISPLAY
delay 2
lcdHome :: LCD -> MI ()
lcdHome lcd = withLCD lcd "Sending the cursor home" $ \c ->
do sendCmd c LCD_RETURNHOME
delay 2
lcdSetCursor :: LCD -> (Int, Int) -> MI ()
lcdSetCursor lcd (givenCol, givenRow) = withLCD lcd ("Sending the cursor to Row: " ++ show givenRow ++ " Col: " ++ show givenCol) set
where set c@Hitachi44780{lcdRows, lcdCols} = sendCmd c (LCD_SETDDRAMADDR offset)
where align :: Int -> Int -> Word8
align i m
| i < 0 = 0
| i >= m = fromIntegral $ m1
| True = fromIntegral i
col = align givenCol lcdCols
row = align givenRow lcdRows
rowOffsets = [(0, 0), (1, 0x40), (2, 0x14), (3, 0x54)]
offset = col + fromMaybe 0x54 (row `lookup` rowOffsets)
lcdScrollDisplayLeft :: LCD -> MI ()
lcdScrollDisplayLeft lcd = withLCD lcd "Scrolling display to the left by 1" $ \c -> sendCmd c (LCD_CURSORSHIFT lcdMoveLeft)
where lcdMoveLeft = 0x00
lcdScrollDisplayRight :: LCD -> MI ()
lcdScrollDisplayRight lcd = withLCD lcd "Scrolling display to the right by 1" $ \c -> sendCmd c (LCD_CURSORSHIFT lcdMoveRight)
where lcdMoveRight = 0x04
updateDisplayData :: String -> (Word8 -> Word8, Word8 -> Word8) -> LCD -> MI ()
updateDisplayData what (f, g) lcd = do
debug what
( LCDData {lcdDisplayControl = oldC, lcdDisplayMode = oldM}
, LCDData {lcdDisplayControl = newC, lcdDisplayMode = newM, lcdController = c})
<- liftIO $ modifyMVar (_state lcd) $
\ld@LCDData{lcdDisplayControl, lcdDisplayMode} -> do
let ld' = ld { lcdDisplayControl = f lcdDisplayControl
, lcdDisplayMode = g lcdDisplayMode
}
return (ld',(ld,ld'))
when (oldC /= newC) $ sendCmd c (LCD_DISPLAYCONTROL newC)
when (oldM /= newM) $ sendCmd c (LCD_ENTRYMODESET newM)
updateDisplayControl :: String -> (Word8 -> Word8) -> LCD -> MI ()
updateDisplayControl what f = updateDisplayData what (f, id)
updateDisplayMode :: String -> (Word8 -> Word8) -> LCD -> MI ()
updateDisplayMode what g = updateDisplayData what (id, g)
data Hitachi44780Mask = LCD_BLINKON
| LCD_CURSORON
| LCD_DISPLAYON
| LCD_ENTRYSHIFTINCREMENT
| LCD_ENTRYLEFT
maskBit :: Hitachi44780Mask -> Int
maskBit LCD_BLINKON = 0
maskBit LCD_CURSORON = 1
maskBit LCD_DISPLAYON = 2
maskBit LCD_ENTRYSHIFTINCREMENT = 0
maskBit LCD_ENTRYLEFT = 1
clearMask :: Hitachi44780Mask -> Word8 -> Word8
clearMask m w = w `clearBit` maskBit m
setMask :: Hitachi44780Mask -> Word8 -> Word8
setMask m w = w `setBit` maskBit m
lcdBlinkOff :: LCD -> MI ()
lcdBlinkOff = updateDisplayControl "Turning blinking off" (clearMask LCD_BLINKON)
lcdBlinkOn :: LCD -> MI ()
lcdBlinkOn = updateDisplayControl "Turning blinking on" (setMask LCD_BLINKON)
lcdCursorOff :: LCD -> MI ()
lcdCursorOff = updateDisplayControl "Not showing the cursor" (clearMask LCD_CURSORON)
lcdCursorOn :: LCD -> MI ()
lcdCursorOn = updateDisplayControl "Showing the cursor" (setMask LCD_CURSORON)
lcdDisplayOff :: LCD -> MI ()
lcdDisplayOff = updateDisplayControl "Turning display off" (clearMask LCD_DISPLAYON)
lcdDisplayOn :: LCD -> MI ()
lcdDisplayOn = updateDisplayControl "Turning display on" (setMask LCD_DISPLAYON)
lcdLeftToRight :: LCD -> MI ()
lcdLeftToRight = updateDisplayMode "Setting left-to-right entry mode" (setMask LCD_ENTRYLEFT)
lcdRightToLeft :: LCD -> MI ()
lcdRightToLeft = updateDisplayMode "Setting right-to-left entry mode" (clearMask LCD_ENTRYLEFT)
lcdAutoScrollOn :: LCD -> MI ()
lcdAutoScrollOn = updateDisplayMode "Setting auto-scroll ON" (setMask LCD_ENTRYSHIFTINCREMENT)
lcdAutoScrollOff :: LCD -> MI ()
lcdAutoScrollOff = updateDisplayMode "Setting auto-scroll OFF" (clearMask LCD_ENTRYSHIFTINCREMENT)
lcdFlash :: LCD
-> Int
-> Int
-> MI ()
lcdFlash lcd n d = sequence_ $ concat $ replicate n [lcdDisplayOff lcd, delay d, lcdDisplayOn lcd, delay d]
newtype LCDSymbol = LCDSymbol Word8
lcdCreateSymbol :: LCD -> [String] -> MI LCDSymbol
lcdCreateSymbol lcd glyph
| length glyph /= 8 || any (/= 5) (map length glyph)
= error "hArduino: lcdCreateSymbol: Invalid glyph description: must be 8x5!"
| True
= do (i, c) <- liftIO $ modifyMVar (_state lcd) $
\ld@LCDData{lcdGlyphCount, lcdController} -> do
let ld' = ld { lcdGlyphCount = lcdGlyphCount + 1 }
return (ld', (lcdGlyphCount, lcdController))
sendCmd c (LCD_SETCGRAMADDR i)
let cvt :: String -> Word8
cvt s = foldr (.|.) 0 [bit p | (ch, p) <- zip (reverse s) [0..], not (isSpace ch)]
mapM_ (sendData c . cvt) glyph
return $ LCDSymbol i
lcdWriteSymbol :: LCD -> LCDSymbol -> MI ()
lcdWriteSymbol lcd (LCDSymbol i) = withLCD lcd ("Writing custom symbol " ++ show i ++ " to LCD") $ \c -> sendData c i
lcdInternalSymbol :: Word8 -> LCDSymbol
lcdInternalSymbol = LCDSymbol