module TerminalF(terminalF,cmdTerminalF,TerminalCmd(..)) where
import Spacer(marginF)
import BgF
import Color
import Command
import FRequest
import DrawInWindow(wDrawImageString,wDrawImageString16,wCopyArea)
import XDraw
import Defaults(paperColor, fgColor)
import Dlayout(simpleGroupF, windowF)
import Event
import Font
import Fudget
import Gc
import Geometry(Point(..), Rect(..), origin, pP, padd,)
import LayoutRequest
import LoadFont
import NullF
import StateMonads
import Xtypes
import CompOps
import GCAttrs()
grmarginF :: Distance -> F hi ho -> F hi ho
grmarginF Distance
m F hi ho
f = forall {hi} {ho}. [WindowAttributes] -> F hi ho -> F hi ho
simpleGroupF [] (forall {a} {b}. Distance -> F a b -> F a b
marginF Distance
m F hi ho
f)
data TerminalCmd
= TermText String
| TermAppend String
| TermClear
terminalF :: FontName -> Int -> Int -> F String a
terminalF :: forall a. FontName -> Distance -> Distance -> F FontName a
terminalF FontName
fname Distance
nrows Distance
ncols = forall a. FontName -> Distance -> Distance -> F TerminalCmd a
cmdTerminalF FontName
fname Distance
nrows Distance
ncols forall c d e. F c d -> (e -> c) -> F e d
>=^< FontName -> TerminalCmd
TermText
cmdTerminalF :: FontName -> Int -> Int -> F TerminalCmd a
cmdTerminalF :: forall a. FontName -> Distance -> Distance -> F TerminalCmd a
cmdTerminalF FontName
fname Distance
nrows Distance
ncols =
let wattrs :: [WindowAttributes]
wattrs = [BackingStore -> WindowAttributes
CWBackingStore BackingStore
WhenMapped, [EventMask] -> WindowAttributes
CWEventMask [EventMask
ExposureMask]]
in forall {a} {b}. Distance -> F a b -> F a b
grmarginF Distance
2
(forall a b. [FRequest] -> K a b -> F a b
windowF [XCommand -> FRequest
XCmd forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [WindowAttributes]
wattrs,
XCommand -> FRequest
XCmd forall a b. (a -> b) -> a -> b
$ [WindowChanges] -> XCommand
ConfigureWindow [Distance -> WindowChanges
CWBorderWidth Distance
1]]
(forall {ho}. FontName -> Distance -> Distance -> K TerminalCmd ho
terminalK FontName
fname Distance
nrows Distance
ncols))
terminalK :: FontName -> Distance -> Distance -> K TerminalCmd ho
terminalK FontName
fname Distance
nrows Distance
ncols =
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
FontName
-> (FontStructF (Array Char CharStruct) -> f hi ho) -> f hi ho
safeLoadQueryFont FontName
fname forall a b. (a -> b) -> a -> b
$ \FontStructF (Array Char CharStruct)
fs ->
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId -> FontName -> Cont (f hi ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap FontName
fgColor forall a b. (a -> b) -> a -> b
$ \Pixel
fg ->
forall {a} {i} {o}.
(Show a, ColorGen a) =>
a -> (Pixel -> K i o) -> K i o
changeGetBackPixel FontName
paperColor forall a b. (a -> b) -> a -> b
$ \Pixel
bg ->
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
GCId -> GCAttributeList -> (GCId -> f hi ho) -> f hi ho
wCreateGC GCId
rootGC [forall a b. GCFunction -> GCAttributes a b
GCFunction GCFunction
GXcopy, forall a b. b -> GCAttributes a b
GCFont (forall per_char. FontStructF per_char -> FontId
font_id FontStructF (Array Char CharStruct)
fs), forall a b. a -> GCAttributes a b
GCForeground Pixel
fg, forall a b. a -> GCAttributes a b
GCBackground Pixel
bg]
(forall {ho}.
FontStructF (Array Char CharStruct)
-> Distance -> Distance -> GCId -> K TerminalCmd ho
terminalK1 FontStructF (Array Char CharStruct)
fs Distance
nrows Distance
ncols)
m a
m1 $$$ :: m a -> m b -> m b
$$$ m b
m2 = m a
m1forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>m b
m2
m a
m1 $> :: m a -> (a -> m b) -> m b
$> a -> m b
xm2 = m a
m1 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m b
xm2
terminalK1 :: FontStructF (Array Char CharStruct)
-> Distance -> Distance -> GCId -> K TerminalCmd ho
terminalK1 FontStructF (Array Char CharStruct)
fs Distance
nrows Distance
ncols GCId
gc =
let charsize :: Size
charsize@(Point Distance
charw Distance
charh) = FontStructF (Array Char CharStruct) -> FontName -> Size
string_box_size FontStructF (Array Char CharStruct)
fs FontName
"M"
startsize :: Size
startsize = Distance -> Distance -> Size
curpos Distance
nrows Distance
ncols
size :: Size
size = Size
startsize
curpos :: Distance -> Distance -> Size
curpos Distance
row Distance
col = Distance -> Distance -> Size
pP (Distance
charw forall a. Num a => a -> a -> a
* Distance
col) (Distance
charh forall a. Num a => a -> a -> a
* Distance
row)
drawpos :: Distance -> Distance -> Size
drawpos Distance
row Distance
col = Size -> Size -> Size
padd (Distance -> Distance -> Size
curpos Distance
row Distance
col) (Distance -> Distance -> Size
pP Distance
0 (forall per_char. FontStructF per_char -> Distance
font_ascent FontStructF (Array Char CharStruct)
fs))
drimstr :: GCId -> Size -> FontName -> FRequest
drimstr = if forall a b. (a, b) -> b
snd (forall {per_char}. FontStructF per_char -> (Char, Char)
font_range FontStructF (Array Char CharStruct)
fs) forall a. Ord a => a -> a -> Bool
> Char
'\xff'
then GCId -> Size -> FontName -> FRequest
wDrawImageString16
else GCId -> Size -> FontName -> FRequest
wDrawImageString
k :: Mk
(([FontName], Distance, Distance, Distance, Distance)
-> K TerminalCmd ho)
b
k =
forall {hi} {ho} {s}. Ms (K hi ho) s (KEvent hi)
getKs forall {m :: * -> *} {a} {b}. Monad m => m a -> (a -> m b) -> m b
$>
(\KEvent TerminalCmd
msg ->
(case KEvent TerminalCmd
msg of
Low (XEvt (Expose Rect
_ Distance
0)) -> forall {b} {c} {d} {e} {hi} {ho}.
Mk (([FontName], b, c, d, e) -> K hi ho) ()
redraw
Low (LEvt (LayoutSize Size
newsize)) -> forall {hi} {ho}.
Size
-> Mk
(([FontName], Distance, Distance, Distance, Distance) -> K hi ho)
()
setSize Size
newsize
Low FResponse
_ -> forall k s. Msc k s
nopMs
High TerminalCmd
cmd -> case TerminalCmd
cmd of
TermText FontName
line -> forall {f :: * -> * -> *} {c} {hi} {ho}.
FudgetIO f =>
FontName
-> Mk (([FontName], Distance, c, Distance, Distance) -> f hi ho) ()
addDrawLine FontName
line
TermAppend FontName
s -> forall {f :: * -> * -> *} {c} {d} {e} {hi} {ho}.
FudgetIO f =>
FontName -> Mk (([FontName], Distance, c, d, e) -> f hi ho) ()
appendDrawLine FontName
s
TerminalCmd
TermClear -> forall {d} {e} {hi} {ho}.
Mk (([FontName], Distance, Distance, d, e) -> K hi ho) ()
clearit) forall {m :: * -> *} {a} {b}. Monad m => m a -> m b -> m b
$$$
Mk
(([FontName], Distance, Distance, Distance, Distance)
-> K TerminalCmd ho)
b
k)
drawline :: (Distance, FontName) -> Mk ((a, b, c, d, e) -> f hi ho) ()
drawline (Distance
r, FontName
l) =
forall k s. Ms k s s
loadMs forall {m :: * -> *} {a} {b}. Monad m => m a -> (a -> m b) -> m b
$>
(\(a
lines', b
row, c
col, d
nrows', e
ncols') ->
forall {f :: * -> * -> *} {hi} {ho} {r}.
FudgetIO f =>
FRequest -> Msc (f hi ho) r
putLowMs (GCId -> Size -> FontName -> FRequest
drimstr GCId
gc (Distance -> Distance -> Size
drawpos Distance
r Distance
0) FontName
l))
redraw :: Mk (([FontName], b, c, d, e) -> K hi ho) ()
redraw =
forall k s. Ms k s s
loadMs forall {m :: * -> *} {a} {b}. Monad m => m a -> (a -> m b) -> m b
$>
(\([FontName]
lines', b
row, c
col, d
nrows', e
ncols') ->
forall {f :: * -> * -> *} {hi} {ho} {r}.
FudgetIO f =>
FRequest -> Msc (f hi ho) r
putLowMs FRequest
clearWindow forall {m :: * -> *} {a} {b}. Monad m => m a -> m b -> m b
$$$
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Distance, FontName)
l -> (forall {f :: * -> * -> *} {a} {b} {c} {d} {e} {hi} {ho}.
FudgetIO f =>
(Distance, FontName) -> Mk ((a, b, c, d, e) -> f hi ho) ()
drawline (Distance, FontName)
l forall {m :: * -> *} {a} {b}. Monad m => m a -> m b -> m b
$$$)) forall k s. Msc k s
nopMs (forall a b. [a] -> [b] -> [(a, b)]
zip [Distance
0 ..] (forall a. [a] -> [a]
reverse [FontName]
lines')))
setSize :: Size
-> Mk
(([FontName], Distance, Distance, Distance, Distance) -> K hi ho)
()
setSize (Point Distance
x Distance
y) =
forall k s. Ms k s s
loadMs forall {m :: * -> *} {a} {b}. Monad m => m a -> (a -> m b) -> m b
$>
(\([FontName]
lines', Distance
row, Distance
col, Distance
nrows', Distance
ncols') ->
let ncols'' :: Distance
ncols'' = Distance
x forall a. Integral a => a -> a -> a
`quot` Distance
charw
nrows'' :: Distance
nrows'' = Distance
y forall a. Integral a => a -> a -> a
`quot` Distance
charh
row' :: Distance
row' = Distance
row forall a. Ord a => a -> a -> a
`min` Distance
nrows''
col' :: Distance
col' = Distance
col forall a. Ord a => a -> a -> a
`min` Distance
ncols''
lines'' :: [FontName]
lines'' = forall a. Distance -> [a] -> [a]
take Distance
nrows'' [FontName]
lines'
in forall s k. s -> Msc k s
storeMs ([FontName]
lines'', Distance
row', Distance
col', Distance
nrows'', Distance
ncols'') forall {m :: * -> *} {a} {b}. Monad m => m a -> m b -> m b
$$$ forall {b} {c} {d} {e} {hi} {ho}.
Mk (([FontName], b, c, d, e) -> K hi ho) ()
redraw)
addLine :: p -> Mk (([p], Distance, c, Distance, Distance) -> f hi ho) ()
addLine p
line =
forall k s. Ms k s s
loadMs forall {m :: * -> *} {a} {b}. Monad m => m a -> (a -> m b) -> m b
$>
(\([p]
lines', Distance
row, c
col, Distance
nrows', Distance
ncols') ->
if Distance
row forall a. Ord a => a -> a -> Bool
< Distance
nrows' forall a. Num a => a -> a -> a
- Distance
1 then
let lines'' :: [p]
lines'' = p
line forall a. a -> [a] -> [a]
: [p]
lines'
row' :: Distance
row' = Distance
row forall a. Num a => a -> a -> a
+ Distance
1
in forall s k. s -> Msc k s
storeMs ([p]
lines'', Distance
row', c
col, Distance
nrows', Distance
ncols')
else
let lines'' :: [p]
lines'' = forall a. Distance -> [a] -> [a]
take Distance
nrows' (p
line forall a. a -> [a] -> [a]
: [p]
lines')
in forall s k. s -> Msc k s
storeMs ([p]
lines'', Distance
row, c
col, Distance
nrows', Distance
ncols') forall {m :: * -> *} {a} {b}. Monad m => m a -> m b -> m b
$$$
forall {t :: * -> *} {f :: * -> * -> *} {hi} {ho} {r}.
(Foldable t, FudgetIO f) =>
t FRequest -> Msc (f hi ho) r
putLowsMs [GCId -> Drawable -> Rect -> Size -> FRequest
wCopyArea GCId
gc
Drawable
MyWindow
(Size -> Size -> Rect
Rect (Distance -> Distance -> Size
pP Distance
0 Distance
charh)
(Distance -> Distance -> Size
curpos (Distance
nrows' forall a. Num a => a -> a -> a
- Distance
1) Distance
ncols'))
Size
origin,
Rect -> Bool -> FRequest
clearArea (Size -> Size -> Rect
Rect (Distance -> Distance -> Size
curpos Distance
row Distance
0)
(Distance -> Distance -> Size
curpos Distance
1 Distance
ncols'))
Bool
False])
appendLine :: [a] -> Mk (([[a]], b, c, d, e) -> k) ()
appendLine [a]
s =
forall k s. Ms k s s
loadMs forall {m :: * -> *} {a} {b}. Monad m => m a -> (a -> m b) -> m b
$> \([[a]]
lines', b
row, c
col, d
nrows', e
ncols') ->
case [[a]]
lines' of
[] -> forall s k. s -> Msc k s
storeMs ([[a]
s],b
rowforall a. Num a => a -> a -> a
+b
1,c
col,d
nrows',e
ncols')
[a]
l:[[a]]
ls -> forall s k. s -> Msc k s
storeMs (([a]
lforall a. [a] -> [a] -> [a]
++[a]
s)forall a. a -> [a] -> [a]
:[[a]]
ls, b
row, c
col, d
nrows', e
ncols')
clearit :: Mk (([FontName], Distance, Distance, d, e) -> K hi ho) ()
clearit = forall k s. Ms k s s
loadMs forall {m :: * -> *} {a} {b}. Monad m => m a -> (a -> m b) -> m b
$> \([FontName]
lines, Distance
row, Distance
col, d
nrows, e
ncols) ->
forall s k. s -> Msc k s
storeMs ([],-Distance
1,Distance
0,d
nrows,e
ncols) forall {m :: * -> *} {a} {b}. Monad m => m a -> m b -> m b
$$$ forall {b} {c} {d} {e} {hi} {ho}.
Mk (([FontName], b, c, d, e) -> K hi ho) ()
redraw
addDrawLine :: FontName
-> Mk (([FontName], Distance, c, Distance, Distance) -> f hi ho) ()
addDrawLine FontName
line =
(forall {f :: * -> * -> *} {p} {c} {hi} {ho}.
FudgetIO f =>
p -> Mk (([p], Distance, c, Distance, Distance) -> f hi ho) ()
addLine FontName
line forall {m :: * -> *} {a} {b}. Monad m => m a -> m b -> m b
$$$ forall k s. Ms k s s
loadMs) forall {m :: * -> *} {a} {b}. Monad m => m a -> (a -> m b) -> m b
$>
(\([FontName]
lines', Distance
row, c
col, Distance
nrows', Distance
ncols') -> forall {f :: * -> * -> *} {a} {b} {c} {d} {e} {hi} {ho}.
FudgetIO f =>
(Distance, FontName) -> Mk ((a, b, c, d, e) -> f hi ho) ()
drawline (Distance
row, FontName
line))
appendDrawLine :: FontName -> Mk (([FontName], Distance, c, d, e) -> f hi ho) ()
appendDrawLine FontName
s =
(forall {b} {a} {c} {d} {e} {k}.
Num b =>
[a] -> Mk (([[a]], b, c, d, e) -> k) ()
appendLine FontName
s forall {m :: * -> *} {a} {b}. Monad m => m a -> m b -> m b
$$$ forall k s. Ms k s s
loadMs) forall {m :: * -> *} {a} {b}. Monad m => m a -> (a -> m b) -> m b
$>
(\(FontName
line:[FontName]
_, Distance
row, c
col, d
nrows', e
ncols') -> forall {f :: * -> * -> *} {a} {b} {c} {d} {e} {hi} {ho}.
FudgetIO f =>
(Distance, FontName) -> Mk ((a, b, c, d, e) -> f hi ho) ()
drawline (Distance
row, FontName
line))
in forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK (forall a b. a -> Message a b
Low (LayoutRequest -> FRequest
layoutRequestCmd (Size -> Bool -> Bool -> LayoutRequest
plainLayout Size
size Bool
False Bool
False))) forall a b. (a -> b) -> a -> b
$
forall {t1} {t2} {r}. t1 -> Mk (t1 -> t2) r -> t2 -> t2
stateK ([], -Distance
1, Distance
0, Distance
nrows, Distance
ncols) forall {ho} {b}.
Mk
(([FontName], Distance, Distance, Distance, Distance)
-> K TerminalCmd ho)
b
k forall {hi} {ho}. K hi ho
nullK