PropLogic-0.9: TextDisplay.hs
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
{- |
The default representation of any type is the string and the @show@ function, which returns a string for each element
of an instance of the @Show@ class. But sometimes, it is more intuitive, if a type is represented by a more
three-dimensional layout. For that matter, we not only have a @show@ function for many types to come, but also a
@textFrame@ converter, where a @TextFrame@ is basically defined as a list of strings of equal length.
Similar to the @Show@ type class, we also define a @Display@ type class.
-}
module TextDisplay (
-- * Text frames
TextFrame,
-- | A TextFrame is a list of strings. But for a /correct/ TextFrame, there are more constraints that have to hold:
-- 1. The strings must all be of equal length.
-- 2. There must be no white space characters in a string, other than the space character ' '.
isNonSpaceWhite,
-- | True if the character is any white space character, except the space character itself.
findTextFrameError,
-- | A TextFrame is /correct/ iff all its strings are of equal length and (isNonSpaceWhite ch) is false for all characters ch.
correctTextFrame,
-- | Turns the argument string list into a correct version by adding spaces. But returns an error in case any string contains a character ch with (isNonSpaceWhite ch).
-- IMPROVE the String instance of Display: new line characters should create new lines in the text frame and what about tabs etc? !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
width,
-- | The width of a TextFrame [str1,...,strN] is the maximal length of the strings str1,...,strN.
-- In particular,
--
-- > (width []) == 0 (width [""]) == 0
--
height,
-- | The height of a TextFrame [str1,...,strN] is N.
printTextFrame,
-- | prints its TextFrame argument.
textFrameBox,
-- | surrounds the text frame with a solid line
textFrameBracket,
-- | surrounds the text frame with a square bracket
defaultTextFrame,
-- | @(defaultTextFrame x) == [show x]@
-- * The @Display@ type class
Display(..),
-- | @textFrame@ converts into a @TextFrame@.
-- @display@ prints the text frame (actually, @display = printTextFrame . textFrame@, i.e. to define an instance of @Display@,
-- Actually, when an instance of @Display@ is defined, only @textFrame@ needs to be specified.
-- * Text frame tables
TextFrameTable,
-- | A @TextFrameTable@ is a list of rows, where each cell is a @TextFrame@. For example,
--
-- > [[["aaa","aaa"],["b","b","b"]],
-- > [["cccccccc","cccccccc"],["ddddddddd","ddddddddd","ddddddddd"],["eeeee","eeeee","eeeee","eeeee"]],
-- > [["ff","ff"],[],["ggg","ggg","ggg","ggg"]]]
--
-- or, more intuitively in table layout
--
-- > "aaa" "b"
-- > "aaa" "b"
-- > "b"
-- >
-- > "cccccccc" "ddddddddd" "eeeee"
-- > "cccccccc" "ddddddddd" "eeeee"
-- > "ddddddddd" "eeeee"
-- > "eeeee"
-- >
-- > "ff" "ggg"
-- > "ff" "ggg"
-- > "ggg"
-- > "ggg"
--
columnWidthList,
rowHeightList,
-- | Column widths and row heights for the previous example text frame table @tft@ are given by
--
-- > (columnWidthList tft) == [8,9,5]
-- > (rowHeightList tft) == [3,4,4]
--
correctTextFrameTable,
-- | A @TextFrameTable@ is said to be /correct/, if
-- (1) each row has the same amount of cells,
-- (2) there is no column of zero width,
-- (3) there is no row of zero height.
-- With @correctTextFrameTable@ we remove these flaws.
--
bottomAlign, topAlign, centerAlign,
leftAlign, rightAlign, middleAlign,
-- | A @TextFrameTable@ is said to be /normal/, if it is correct and each of its @TextFrame@ cells has the width of its according column
-- and the height of its row.
-- To convert a text frame table into a normal one, we need to perform two steps (in arbitrary order):
--
-- * A row normalization, which makes all text frame cells in one row of equal height. We use three modes to achieve that:
-- @bottomAlign@, @topAlign@ and @centerAlign@.
--
-- * A column normalization, which makes all text frame cells in one column of equal width. Again, we have three functions to do that:
-- @leftAlign@, @rightAlign@, and @middleAlign@.
--
-- For example, given the correct text frame table @tft@, we obtain (we use @_@ for space characters):
--
-- > tft = leftAlign tft = middleAlign (leftAlign tft) =
-- >
-- > "aaa" "b" "" "aaa ____" "b________" "_____" "aaa_____" "b________" "_____"
-- > "aaa" "b" "aaa_____" "b________" "aaa_____" "b________" "_____"
-- > "b" "b________" "________" "b________" "_____"
-- >
-- > "cccccccc" "ddddddddd" "eeeee" "cccccccc" "ddddddddd" "eeeee" "________" "ddddddddd" "eeeee"
-- > "cccccccc" "ddddddddd" "eeeee" "cccccccc" "ddddddddd" "eeeee" "cccccccc" "ddddddddd" "eeeee"
-- > "ddddddddd" "eeeee" "ddddddddd" "eeeee" "cccccccc" "ddddddddd" "eeeee"
-- > "eeeee" "eeeee" "________" "_________" "eeeee"
-- >
-- > "ff" "ggg" "ff______" "_________" "ggg__" "________" "_________" "ggg__"
-- > "ff" "ggg" "ff______" "ggg__" "ff______" "_________" "ggg__"
-- > "ggg" "ggg__" "ff______" "_________" "ggg__"
-- > "ggg" "ggg__" "________" "_________" "ggg__"
--
--
normalTextFrameTable,
-- | The default way to convert any text frame table into a normal one is defined by the @normalTextFrameTable@ function,
-- which is defined by
--
-- > normalTextFrameTable = middleAlign . centerAlign . correctTextFrameTable
--
plainMerge, gridMerge,
-- | There is a @plainMerge@ and a @gridMerge@ to turn a normal text frame table into a single text frame. For the example,
--
-- > tft = plainMerge tft = gridMerge tft =
-- >
-- > "___aaa__" "____b____" "_____" "___aaa______b_________" "+----------+-----------+-------+"
-- > "___aaa__" "____b____" "_____" "___aaa______b_________" "| ___aaa__ | ____b____ | _____ |"
-- > "________" "____b____" "_____" "____________b_________" "| ___aaa__ | ____b____ | _____ |"
-- > "________dddddddddeeeee" "| ________ | ____b____ | _____ |"
-- > "________" "ddddddddd" "eeeee" "ccccccccdddddddddeeeee" "+----------+-----------+-------+"
-- > "cccccccc" "ddddddddd" "eeeee" "ccccccccdddddddddeeeee" "| ________ | ddddddddd | eeeee |"
-- > "cccccccc" "ddddddddd" "eeeee" "_________________eeeee" "| cccccccc | ddddddddd | eeeee |"
-- > "________" "_________" "eeeee" "__________________ggg_" "| cccccccc | ddddddddd | eeeee |"
-- > "___ff_____________ggg_" "| ________ | _________ | eeeee |"
-- > "________" "_________" "_ggg_" "___ff_____________ggg_" "+----------+-----------+-------+"
-- > "___ff___" "_________" "_ggg_" "__________________ggg_" "| ________ | _________ | _ggg_ |"
-- > "___ff___" "_________" "_ggg_" "| ___ff___ | _________ | _ggg_ |"
-- > "________" "_________" "_ggg_" "| ___ff___ | _________ | _ggg_ |"
-- > "| ________ | _________ | _ggg_ |"
-- > "+----------+-----------+-------+"
--
) where ---------------------------------------------------------------------------------------------------------------
-- import
import qualified Char as Ch
import qualified List as L
-- basic definitions and basic functions
type TextFrame = [String]
isNonSpaceWhite :: Char -> Bool
isNonSpaceWhite ch = (Ch.isSpace ch) && (ch /= ' ')
findTextFrameError :: [String] -> Maybe String
findTextFrameError [] = Nothing
findTextFrameError (str:strL) = iter(length str, strL)
where iter(n,[]) = Nothing
iter(n,str:strL) = if any isNonSpaceWhite str
then Just ("String contains illegat white space characters: \n" ++ str)
else let n' = length str
in if n' == n
then iter(n,strL)
else Just (concat ["Contains strings of different length (e.g. ",
show n, " and ", show n', ")."])
correctTextFrame :: [String] -> TextFrame
correctTextFrame tf =
if or (map (\ str -> any isNonSpaceWhite str) tf)
then error "Illegal white space characters."
else let w = width tf
in (map (\ str -> str ++ (replicate (w - (length str)) ' ')) tf)
width :: TextFrame -> Int
width [] = 0
width strL = maximum (map length strL)
height :: TextFrame -> Int
height = length
printTextFrame :: TextFrame -> IO ()
printTextFrame = putStr . unlines
textFrameBox :: TextFrame -> TextFrame
textFrameBox tf = [rule] ++ (map (\ str -> ("| " ++ str ++ " |")) tf) ++ [rule]
where w = width tf
rule = "+" ++ (replicate (w + 2) '-') ++ "+"
textFrameBracket :: TextFrame -> TextFrame
textFrameBracket [] = ["[]"]
textFrameBracket [str] = [ "[" ++ str ++ "]" ]
textFrameBracket strL = line ++ (map (\ str -> "| " ++ str ++ " |") strL) ++ line
where line = [ "+-" ++ (replicate (width strL) ' ') ++ "-+" ]
defaultTextFrame :: Show a => a -> TextFrame
defaultTextFrame x = [show x]
-- the Display type class
class Display a where
textFrame :: a -> TextFrame
display :: a -> IO ()
display = printTextFrame . textFrame
instance Display Bool where
textFrame b = if b then ["1"] else ["0"]
instance Display Int where
textFrame = defaultTextFrame
instance Display Integer where
textFrame = defaultTextFrame
instance Display Float where
textFrame = defaultTextFrame
instance Display Double where
textFrame = defaultTextFrame
instance Display Char where
textFrame ch = [[ch]]
instance Display String where
textFrame str = [str]
instance Display () where
textFrame () = [""]
-- text frame tables
type TextFrameTable = [[TextFrame]]
columnWidthList :: TextFrameTable -> [Int]
columnWidthList tft = iter [] tft
where listMax [] mL = mL
listMax nL [] = nL
listMax (n:nL) (m:mL) = (max n m) : (listMax nL mL)
iter nL [] = nL
iter nL (row:tft) = iter (listMax nL (map width row)) tft
rowHeightList :: TextFrameTable -> [Int]
rowHeightList tft = map (\ row -> (maximum (0 : (map (\ cell -> (height cell)) row)))) tft
correctTextFrameTable :: TextFrameTable -> TextFrameTable
correctTextFrameTable tft = tft''''
where colWidthL = columnWidthList tft
rowHeightL = rowHeightList tft
-- 1. remove empty rows
tft' = filter (not . null) tft
-- 2. fill up the rows to equal length
colNumber = length colWidthL
dummyTextFrame = [""] :: TextFrame
fillRow row = row ++ (replicate (colNumber - (length row)) dummyTextFrame)
tft'' = map fillRow tft' :: TextFrameTable
-- 3. remove zero width columns
remove [] [] = []
remove (n:nL) (cell:row) = if n == 0
then remove nL row
else cell : (remove nL row)
remove _ _ = error "correctTextFrameTable -- unexpected error!"
tft''' = map (remove colWidthL) tft''
-- 4. remove empty rows again
tft'''' = filter (not . null) tft'''
bottomAlign :: TextFrameTable -> TextFrameTable
bottomAlign tft = allRows tft (rowHeightList tft)
where flushBottom tf h = (replicate (h - (height tf)) (replicate (width tf) ' ')) ++ tf
oneRow row h = map (\ cell -> (flushBottom cell h)) row
allRows tft rowHeightList = map (\ (row,h) -> oneRow row h) (zip tft rowHeightList)
topAlign :: TextFrameTable -> TextFrameTable
topAlign tft = allRows tft (rowHeightList tft)
where flushTop tf h = tf ++ (replicate (h - (height tf)) (replicate (width tf) ' '))
oneRow row h = map (\ cell -> (flushTop cell h)) row
allRows tft rowHeightList = map (\ (row,h) -> oneRow row h) (zip tft rowHeightList)
centerAlign :: TextFrameTable -> TextFrameTable
centerAlign tft = allRows tft (rowHeightList tft)
where center tf h = let emptyRow = (replicate (width tf) ' ')
h' = height tf
topBlock = replicate ((h - h') `div` 2) emptyRow
botBlock = replicate (((h - h') `div` 2) + ((h - h') `mod` 2)) emptyRow
in topBlock ++ tf ++ botBlock
oneRow row h = map (\ cell -> (center cell h)) row
allRows tft rowHeightList = map (\ (row,h) -> oneRow row h) (zip tft rowHeightList)
leftAlign :: TextFrameTable -> TextFrameTable
leftAlign tft = map rowAlign tft
where colWidthL = columnWidthList tft
rowAlign row = map (\ (cell,w) -> (flushLeft cell w)) (zip row colWidthL)
flushLeft tf n = map (\ str -> (str ++ (replicate (n - (length str)) ' '))) tf
rightAlign :: TextFrameTable -> TextFrameTable
rightAlign tft = map rowAlign tft
where colWidthL = columnWidthList tft
rowAlign row = map (\ (cell,w) -> (flushRight cell w)) (zip row colWidthL)
flushRight tf n = map (\ str -> ((replicate (n - (length str)) ' ') ++ str)) tf
middleAlign :: TextFrameTable -> TextFrameTable
middleAlign tft = map rowAlign tft
where colWidthL = columnWidthList tft
rowAlign row = map (\ (cell,w) -> (centralize cell w)) (zip row colWidthL)
centralize tf n = map (\ str -> (center str (length str) n)) tf
center str l n = let d = (n - l) `div` 2
m = (n - l) `mod` 2
in (replicate d ' ') ++ str ++ (replicate (d + m) ' ')
normalTextFrameTable :: TextFrameTable -> TextFrameTable
normalTextFrameTable = middleAlign . centerAlign . correctTextFrameTable
plainMerge :: TextFrameTable -> TextFrame
plainMerge tft = concat (map mergeTextFrames tft)
where mergeTextFrames tfL = map concat (L.transpose tfL)
gridMerge :: TextFrameTable -> TextFrame
gridMerge tft = tf
where oneLine strL = "| " ++ (concat (L.intersperse " | " strL)) ++ " |"
oneFrameRow row = map oneLine (L.transpose row)
lineRow = "+-" ++ (concat (L.intersperse "-+-" (map (\ n -> (replicate n '-')) (columnWidthList tft)))) ++ "-+"
tf = [lineRow] ++ (concat (L.intersperse [lineRow] (map oneFrameRow tft))) ++ [lineRow]