roguestar-gl-0.6.0.0: src/PrintText.hs

{-# LANGUAGE OverloadedStrings #-}

-- | A 'PrintTextObject' renders the text console at the bottom of the screen.

module PrintText
    (newPrintTextObject,
     printText,
     setStatus,
     PrintTextObject,
     renderText,
     PrintTextMode(..),
     TextType(..),
     getInputBuffer,
     pushInputBuffer,
     pullInputBuffer,
     setInputBuffer,
     setPrintTextMode,
     clearOutputBuffer,
     clearInputBuffer)
    where

import Control.Concurrent.STM
import Graphics.Rendering.OpenGL as GL
import PrintTextData
import Control.Monad
import Control.Concurrent.Chan
import qualified Data.ByteString.Char8 as B
import qualified Data.Map as Map
import RSAGL.Color
import RSAGL.Color.RSAGLColors
import qualified KeyStroke as K
import DrawString
import Data.Monoid

data PrintTextData = PrintTextData {
    text_output_buffer :: [(TextType,B.ByteString)],
    text_input_buffer :: K.KeyString,
    text_status_lines :: Map.Map StatusField B.ByteString,
    text_output_mode :: PrintTextMode,
    text_draw_strategy :: DrawString }

data PrintTextObject = PrintTextObject (TVar PrintTextData) (Chan K.KeyString)

newPrintTextObject :: DrawString -> IO PrintTextObject
newPrintTextObject draw_strategy =
    do pt_data <- newTVarIO $ PrintTextData {
           text_output_buffer = [],
           text_input_buffer = mempty,
           text_status_lines = Map.empty,
           text_output_mode = Unlimited,
           text_draw_strategy = draw_strategy }
       pt_chan <- newChan
       return $ PrintTextObject pt_data pt_chan

printText :: PrintTextObject -> TextType -> B.ByteString -> STM ()
printText (PrintTextObject pto _) text_type str =
    do print_text <- readTVar pto
       writeTVar pto $ print_text {
           text_output_buffer = text_output_buffer print_text ++
                                map ((,) text_type) (B.lines str) }

setStatus :: PrintTextObject -> Map.Map StatusField B.ByteString -> STM ()
setStatus p@(PrintTextObject pto _) status_lines =
    do print_text <- readTVar pto
       let changes = Map.differenceWith
               (\new old -> if new==old then Nothing else Just new)
               status_lines
               (text_status_lines print_text)
       forM_ (Map.toAscList changes) $ \(field,string) ->
           printText p Update $ onChange field string
       writeTVar pto . (\x -> x { text_status_lines = status_lines }) =<< readTVar pto

pushInputBuffer :: PrintTextObject -> K.KeyStroke -> IO ()
pushInputBuffer (PrintTextObject _ chan) stroke = writeChan chan (K.keyStroke stroke)

getInputBuffer :: PrintTextObject -> IO K.KeyString
getInputBuffer (PrintTextObject pto _) =
    liftM text_input_buffer $ atomically $ readTVar pto

-- | Pull one keypress into the input buffer, if it exists.
pullInputBuffer :: PrintTextObject -> IO ()
pullInputBuffer (PrintTextObject pto chan) =
    do e <- isEmptyChan chan
       when (not e) $
           do stroke <- readChan chan
              atomically $
                  do print_text <- readTVar pto
                     writeTVar pto $ print_text {
                         text_input_buffer = text_input_buffer print_text
                                                 `mappend` stroke }
              return ()

setInputBuffer :: PrintTextObject -> K.KeyString -> IO ()
setInputBuffer (PrintTextObject pto _) new_input_buffer = atomically $
    do print_text <- readTVar pto
       writeTVar pto $ print_text { text_input_buffer = new_input_buffer }

clearOutputBuffer :: PrintTextObject -> STM ()
clearOutputBuffer (PrintTextObject pto _) =
    do print_text <- readTVar pto
       writeTVar pto $ print_text { text_output_buffer = [] }

setPrintTextMode :: PrintTextObject -> PrintTextMode -> STM ()
setPrintTextMode (PrintTextObject pto _) pt_mode =
    do print_text <- readTVar pto
       writeTVar pto $ print_text { text_output_mode = pt_mode }

clearInputBuffer :: PrintTextObject -> IO ()
clearInputBuffer (PrintTextObject pto _) = atomically $
    do print_text <- readTVar pto
       writeTVar pto $ print_text { text_input_buffer = mempty }

renderText :: Size -> PrintTextObject -> IO ()
renderText (Size width height) (PrintTextObject pto _) =
    do ptd <- atomically $ readTVar pto
       let draw_strategy = text_draw_strategy ptd
       let max_characters_height =
               (fromIntegral height - 2 * fromIntegral (draw_string_padding draw_strategy)) `div`
               (fromIntegral (draw_string_font_height draw_strategy))
       let max_characters_width =
               (fromIntegral width - 2 * fromIntegral (draw_string_padding draw_strategy)) `div`
               (fromIntegral (draw_string_font_width draw_strategy))
       let lines_to_print =
               restrictLines max_characters_height max_characters_width $
                   (case (text_output_mode ptd) of
                       PrintTextData.Disabled -> []
                       Limited -> reverse $ take 5 $ reverse $
                                      text_output_buffer ptd
                       Unlimited -> (text_output_buffer ptd)) ++
                   (if K.length (text_input_buffer ptd) > 0 ||
                                text_output_mode ptd /= PrintTextData.Disabled
                       then [(Input,"> " `B.append` (B.pack $ K.prettyString $ text_input_buffer ptd))]
                       else [])
       let status_lines = flip map (Map.toAscList $ text_status_lines ptd) $
               \(field,string) -> (Update,whileActive field string)
       drawLines (Size width height) (reverse lines_to_print) Log draw_strategy
       drawLines (Size width height) (reverse status_lines) Status draw_strategy

data PrintTextPosition = Status | Log

drawLines :: Size ->
             [(TextType,B.ByteString)] ->
             PrintTextPosition ->
             DrawString ->
             IO ()
drawLines (Size width height) lines_to_print position draw_strategy =
    do save_depth_func <- get depthFunc
       save_depth_mask <- get depthMask
       save_blend <- get blend
       depthFunc $= Nothing
       depthMask $= GL.Disabled
       blend $= Enabled
       matrixMode $= Projection
       loadIdentity
       ortho2D 0 (fromIntegral width) 0 (fromIntegral height)
       matrixMode $= Modelview 0
       loadIdentity
       let actual_width_pixels :: Int
           actual_width_pixels = draw_string_font_width draw_strategy *
                                 (maximum $ map (B.length . snd) $ (undefined,""):lines_to_print)
       let actual_height_pixels :: Int
           actual_height_pixels = draw_string_font_height draw_strategy * (length lines_to_print)
       let y_position :: Int
           y_position = case position of
               Status -> fromIntegral height - actual_height_pixels - (draw_string_padding draw_strategy)
               Log -> draw_string_padding draw_strategy
       color $ (Color4 0 0 0 0.92 :: Color4 GLfloat)
       (rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO ())
           (Vertex2 (fromIntegral (draw_string_padding draw_strategy))
                    (fromIntegral y_position))
           (Vertex2 (fromIntegral (actual_width_pixels +
                                   (draw_string_padding draw_strategy)))
                    (fromIntegral (actual_height_pixels +
                                   y_position +
                                   (draw_string_padding draw_strategy)*2)))
       currentRasterPosition $= (Vertex4 (fromIntegral $ draw_string_padding draw_strategy)
                                         (fromIntegral $ y_position + draw_string_padding draw_strategy)
                                         0 1)
       mapM_ (drawLine draw_strategy) lines_to_print
       blend $= save_blend
       depthMask $= save_depth_mask
       depthFunc $= save_depth_func

drawLine :: DrawString -> (TextType,B.ByteString) -> IO ()
drawLine draw_strategy (textType,str) =
    do (Vertex4 x y _ _) <- get currentRasterPosition
       color $ colorToOpenGL $ textTypeToColor textType
       currentRasterPosition $= (Vertex4 x y 0 1)
       drawString draw_strategy $ B.unpack str
       currentRasterPosition $= (Vertex4 x (y + fromIntegral (draw_string_font_height draw_strategy)) 0 1)

restrictLines :: Int -> Int -> [(TextType,B.ByteString)] -> [(TextType,B.ByteString)]
restrictLines height width text_lines = reverse $ take height $ reverse $ concatMap splitLongLines text_lines
    where splitLongLines (_,l) | B.null l = []
	  splitLongLines (textType,str) = (textType,B.take width str):(splitLongLines (textType,B.drop width str))

textTypeToColor :: TextType -> RGB
textTypeToColor UnexpectedEvent = orange
textTypeToColor Event =  yellow
textTypeToColor Input =  white
textTypeToColor Query =  grey
textTypeToColor Update = light_brown