module ButtonBorderF(buttonBorderF) where
import Border3dF
import Color
import Command(XCommand(ChangeWindowAttributes,ClearArea,DrawMany,Draw))
import XDraw
import CompOps((>^=<))
import Defaults(look3d, shadowColor, shineColor,bgColor)
import Dlayout(groupF)
import Event
import Fudget
import FRequest
import Xcommand
import Gc
import Geometry(Line(..), Point(..), Rect(..), origin, pP, padd, psub)
import LayoutRequest
import NullF
import Spacer(marginF)
import EitherUtils(stripEither)
import Xtypes
import GreyBgF(changeBg)
buttonBorderF :: Int -> F a b -> F (Either Bool a) b
buttonBorderF :: forall a b. Int -> F a b -> F (Either Bool a) b
buttonBorderF = if Bool
look3d then forall {a} {b}. Bool -> Int -> F a b -> F (Either Bool a) b
border3dF Bool
False else forall a b. Int -> F a b -> F (Either Bool a) b
stdButtonBorderF
stdButtonBorderF :: Int -> F c b -> F (Either Bool c) b
stdButtonBorderF Int
edgew F c b
f =
let kernel :: K Bool b
kernel =
forall a b. ColorName -> K a b -> K a b
changeBg ColorName
bgColor forall a b. (a -> b) -> a -> b
$
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId
-> ColorName -> ColorName -> (Pixel -> f hi ho) -> f hi ho
allocNamedColorDefPixel ColormapId
defaultColormap ColorName
shineColor ColorName
"white" forall a b. (a -> b) -> a -> b
$ \Pixel
shine->
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId
-> ColorName -> ColorName -> (Pixel -> f hi ho) -> f hi ho
allocNamedColorDefPixel ColormapId
defaultColormap ColorName
shadowColor ColorName
"black" forall a b. (a -> b) -> a -> b
$ \Pixel
shadow ->
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. a -> GCAttributes a b
GCForeground Pixel
shadow,
forall a b. a -> GCAttributes a b
GCBackground Pixel
shine] forall a b. (a -> b) -> a -> b
$ \GCId
drawGC ->
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
GCId -> GCAttributeList -> (GCId -> f hi ho) -> f hi ho
wCreateGC GCId
drawGC [forall a b. a -> GCAttributes a b
GCForeground Pixel
shine] forall a b. (a -> b) -> a -> b
$ \GCId
shineGC ->
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
GCId -> GCAttributeList -> (GCId -> f hi ho) -> f hi ho
wCreateGC GCId
rootGC (forall {b}. Pixel -> Pixel -> [GCAttributes Pixel b]
invertColorGCattrs Pixel
shine Pixel
shadow) forall a b. (a -> b) -> a -> b
$ \GCId
invertGC ->
let bpx :: Int
bpx = Int
edgew
bpy :: Int
bpy = Int
edgew
upperLeftCorner :: Point
upperLeftCorner = Int -> Int -> Point
Point Int
bpx Int
bpy
dRAW :: Point -> ([XCommand], [XCommand])
dRAW Point
s =
let size :: Point
size@(Point Int
sx Int
sy) = Point -> Point -> Point
psub Point
s (Int -> Int -> Point
Point Int
1 Int
1)
rect :: Rect
rect = Point -> Point -> Rect
Rect Point
origin Point
size
upperRightCorner :: Point
upperRightCorner = Int -> Int -> Point
Point (Int
sx forall a. Num a => a -> a -> a
- Int
bpx) Int
bpy
lowerLeftCorner :: Point
lowerLeftCorner = Int -> Int -> Point
Point Int
bpx (Int
sy forall a. Num a => a -> a -> a
- Int
bpy)
lowerRightCorner :: Point
lowerRightCorner = Point -> Point -> Point
psub Point
size Point
upperLeftCorner
leftBorder :: Line
leftBorder = Point -> Point -> Line
Line Point
upperLeftCorner Point
lowerLeftCorner
upperBorder :: Line
upperBorder = Point -> Point -> Line
Line Point
upperLeftCorner Point
upperRightCorner
upperLeftLine :: Line
upperLeftLine = Point -> Point -> Line
Line Point
origin Point
upperLeftCorner
lowerRightLine :: Line
lowerRightLine = Point -> Point -> Line
Line Point
lowerRightCorner Point
size
incx :: Point -> Point
incx = Point -> Point -> Point
padd (Int -> Int -> Point
Point Int
1 Int
0)
incy :: Point -> Point
incy = Point -> Point -> Point
padd (Int -> Int -> Point
Point Int
0 Int
1)
decx :: Point -> Point
decx = Point -> Point -> Point
padd (Int -> Int -> Point
Point (-Int
1) Int
0)
decy :: Point -> Point
decy = Point -> Point -> Point
padd (Int -> Int -> Point
Point Int
0 (-Int
1))
lowerBorderPoints :: [Point]
lowerBorderPoints = [Point
lowerLeftCorner, Point
lowerRightCorner,
Point
upperRightCorner, Int -> Int -> Point
Point Int
sx Int
0, Point
size, Int -> Int -> Point
Point Int
0 Int
sy]
borderPoints :: [Point]
borderPoints =
[Int -> Int -> Point
pP Int
1 Int
1, Int -> Int -> Point
pP Int
1 Int
sy, Point
size, Int -> Int -> Point
pP Int
sx Int
1, Point
origin, Point
upperLeftCorner,
Point -> Point
incy Point
lowerLeftCorner, (Point -> Point
incx forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Point
incy) Point
lowerRightCorner,
Point -> Point
incx Point
upperRightCorner, Point
upperLeftCorner]
in ( [Rect -> Bool -> XCommand
ClearArea Rect
rect Bool
False,
Drawable -> [(GCId, [DrawCommand])] -> XCommand
DrawMany Drawable
MyWindow [
(GCId
shineGC,[Shape -> CoordMode -> [Point] -> DrawCommand
FillPolygon Shape
Nonconvex CoordMode
CoordModeOrigin
[Point]
borderPoints]),
(GCId
drawGC,[Shape -> CoordMode -> [Point] -> DrawCommand
FillPolygon Shape
Nonconvex CoordMode
CoordModeOrigin
[Point]
lowerBorderPoints,
Line -> DrawCommand
DrawLine Line
leftBorder,
Line -> DrawCommand
DrawLine Line
upperBorder,
Line -> DrawCommand
DrawLine Line
upperLeftLine]),
(GCId
invertGC,[Line -> DrawCommand
DrawLine Line
lowerRightLine]),
(GCId
drawGC,[Rect -> DrawCommand
DrawRectangle Rect
rect])]],
[Drawable -> GCId -> DrawCommand -> XCommand
Draw Drawable
MyWindow GCId
invertGC forall a b. (a -> b) -> a -> b
$ Shape -> CoordMode -> [Point] -> DrawCommand
FillPolygon Shape
Nonconvex
CoordMode
CoordModeOrigin [Point]
borderPoints])
proc :: Bool -> Point -> K Bool ho
proc Bool
pressed Point
size =
forall {hi} {ho}. Cont (K hi ho) (KEvent hi)
getK forall a b. (a -> b) -> a -> b
$ \KEvent Bool
bmsg ->
let same :: K Bool ho
same = Bool -> Point -> K Bool ho
proc Bool
pressed Point
size
([XCommand]
drawit_size, [XCommand]
pressit_size) = Point -> ([XCommand], [XCommand])
dRAW Point
size
redraw :: Bool -> [XCommand]
redraw Bool
b = if Bool
b forall a. Eq a => a -> a -> Bool
== Bool
pressed then [] else [XCommand]
pressit_size
in case KEvent Bool
bmsg of
Low (XEvt (Expose Rect
_ Int
0)) -> forall {i} {o}. [XCommand] -> K i o -> K i o
xcommandsK ([XCommand]
drawit_size forall a. [a] -> [a] -> [a]
++
(if Bool
pressed then [XCommand]
pressit_size else [])) K Bool ho
same
Low (LEvt (LayoutSize Point
newsize)) -> Bool -> Point -> K Bool ho
proc Bool
pressed Point
newsize
High Bool
change -> forall {i} {o}. [XCommand] -> K i o -> K i o
xcommandsK (Bool -> [XCommand]
redraw Bool
change) (Bool -> Point -> K Bool ho
proc Bool
change Point
size)
KEvent Bool
_ -> K Bool ho
same
proc0 :: Bool -> K Bool ho
proc0 Bool
pressed =
forall {hi} {ho}. Cont (K hi ho) (KEvent hi)
getK forall a b. (a -> b) -> a -> b
$ \KEvent Bool
msg ->
case KEvent Bool
msg of
Low (LEvt (LayoutSize Point
size)) -> forall {ho}. Bool -> Point -> K Bool ho
proc Bool
pressed Point
size
High Bool
change -> Bool -> K Bool ho
proc0 Bool
change
KEvent Bool
_ -> Bool -> K Bool ho
proc0 Bool
pressed
in forall {ho}. Bool -> K Bool ho
proc0 Bool
False
startcmds :: [FRequest]
startcmds = [XCommand -> FRequest
XCmd forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [[EventMask] -> WindowAttributes
CWEventMask [EventMask
ExposureMask]]]
in forall {a}. Either a a -> a
stripEither forall a b e. (a -> b) -> F e a -> F e b
>^=< ((forall {a} {b} {c} {d}.
[FRequest] -> K a b -> F c d -> F (Either a c) (Either b d)
groupF [FRequest]
startcmds forall {b}. K Bool b
kernel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. Int -> F a b -> F a b
marginF (Int
edgew forall a. Num a => a -> a -> a
+ Int
1)) F c b
f)