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 :: Int -> F a b -> F (Either Bool a) b
buttonBorderF = if Bool
look3d then Bool -> Int -> F a b -> F (Either Bool a) b
forall a b. Bool -> Int -> F a b -> F (Either Bool a) b
border3dF Bool
False else Int -> F a b -> F (Either Bool a) b
forall c b. Int -> F c b -> F (Either Bool c) 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 =
ColorName -> K Bool b -> K Bool b
forall a b. ColorName -> K a b -> K a b
changeBg ColorName
bgColor (K Bool b -> K Bool b) -> K Bool b -> K Bool b
forall a b. (a -> b) -> a -> b
$
ColormapId
-> ColorName -> ColorName -> (Pixel -> K Bool b) -> K Bool b
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> ColorName -> ColorName -> (Pixel -> f b ho) -> f b ho
allocNamedColorDefPixel ColormapId
defaultColormap ColorName
shineColor ColorName
"white" ((Pixel -> K Bool b) -> K Bool b)
-> (Pixel -> K Bool b) -> K Bool b
forall a b. (a -> b) -> a -> b
$ \Pixel
shine->
ColormapId
-> ColorName -> ColorName -> (Pixel -> K Bool b) -> K Bool b
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> ColorName -> ColorName -> (Pixel -> f b ho) -> f b ho
allocNamedColorDefPixel ColormapId
defaultColormap ColorName
shadowColor ColorName
"black" ((Pixel -> K Bool b) -> K Bool b)
-> (Pixel -> K Bool b) -> K Bool b
forall a b. (a -> b) -> a -> b
$ \Pixel
shadow ->
GCId
-> [GCAttributes Pixel FontId] -> (GCId -> K Bool b) -> K Bool b
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
GCId -> [GCAttributes Pixel FontId] -> (GCId -> f b ho) -> f b ho
wCreateGC GCId
rootGC [GCFunction -> GCAttributes Pixel FontId
forall a b. GCFunction -> GCAttributes a b
GCFunction GCFunction
GXcopy, Pixel -> GCAttributes Pixel FontId
forall a b. a -> GCAttributes a b
GCForeground Pixel
shadow,
Pixel -> GCAttributes Pixel FontId
forall a b. a -> GCAttributes a b
GCBackground Pixel
shine] ((GCId -> K Bool b) -> K Bool b) -> (GCId -> K Bool b) -> K Bool b
forall a b. (a -> b) -> a -> b
$ \GCId
drawGC ->
GCId
-> [GCAttributes Pixel FontId] -> (GCId -> K Bool b) -> K Bool b
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
GCId -> [GCAttributes Pixel FontId] -> (GCId -> f b ho) -> f b ho
wCreateGC GCId
drawGC [Pixel -> GCAttributes Pixel FontId
forall a b. a -> GCAttributes a b
GCForeground Pixel
shine] ((GCId -> K Bool b) -> K Bool b) -> (GCId -> K Bool b) -> K Bool b
forall a b. (a -> b) -> a -> b
$ \GCId
shineGC ->
GCId
-> [GCAttributes Pixel FontId] -> (GCId -> K Bool b) -> K Bool b
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
GCId -> [GCAttributes Pixel FontId] -> (GCId -> f b ho) -> f b ho
wCreateGC GCId
rootGC (Pixel -> Pixel -> [GCAttributes Pixel FontId]
forall b. Pixel -> Pixel -> [GCAttributes Pixel b]
invertColorGCattrs Pixel
shine Pixel
shadow) ((GCId -> K Bool b) -> K Bool b) -> (GCId -> K Bool b) -> K Bool b
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bpx) Int
bpy
lowerLeftCorner :: Point
lowerLeftCorner = Int -> Int -> Point
Point Int
bpx (Int
sy Int -> Int -> Int
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 (Point -> Point) -> (Point -> Point) -> Point -> Point
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 (DrawCommand -> XCommand) -> DrawCommand -> XCommand
forall a b. (a -> b) -> a -> b
$ Shape -> CoordMode -> [Point] -> DrawCommand
FillPolygon Shape
Nonconvex
CoordMode
CoordModeOrigin [Point]
borderPoints])
proc :: Bool -> Point -> K Bool o
proc Bool
pressed Point
size =
Cont (K Bool o) (KEvent Bool)
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont (K Bool o) (KEvent Bool) -> Cont (K Bool o) (KEvent Bool)
forall a b. (a -> b) -> a -> b
$ \KEvent Bool
bmsg ->
let same :: K Bool o
same = Bool -> Point -> K Bool o
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 Bool -> Bool -> Bool
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)) -> [XCommand] -> K Bool o -> K Bool o
forall i o. [XCommand] -> K i o -> K i o
xcommandsK ([XCommand]
drawit_size [XCommand] -> [XCommand] -> [XCommand]
forall a. [a] -> [a] -> [a]
++
(if Bool
pressed then [XCommand]
pressit_size else [])) K Bool o
same
Low (LEvt (LayoutSize Point
newsize)) -> Bool -> Point -> K Bool o
proc Bool
pressed Point
newsize
High Bool
change -> [XCommand] -> K Bool o -> K Bool o
forall i o. [XCommand] -> K i o -> K i o
xcommandsK (Bool -> [XCommand]
redraw Bool
change) (Bool -> Point -> K Bool o
proc Bool
change Point
size)
KEvent Bool
_ -> K Bool o
same
proc0 :: Bool -> K Bool ho
proc0 Bool
pressed =
Cont (K Bool ho) (KEvent Bool)
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont (K Bool ho) (KEvent Bool) -> Cont (K Bool ho) (KEvent Bool)
forall a b. (a -> b) -> a -> b
$ \KEvent Bool
msg ->
case KEvent Bool
msg of
Low (LEvt (LayoutSize Point
size)) -> Bool -> Point -> K Bool ho
forall o. Bool -> Point -> K Bool o
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 Bool -> K Bool b
forall ho. Bool -> K Bool ho
proc0 Bool
False
startcmds :: [FRequest]
startcmds = [XCommand -> FRequest
XCmd (XCommand -> FRequest) -> XCommand -> FRequest
forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [[EventMask] -> WindowAttributes
CWEventMask [EventMask
ExposureMask]]]
in Either b b -> b
forall p. Either p p -> p
stripEither (Either b b -> b)
-> F (Either Bool c) (Either b b) -> F (Either Bool c) b
forall a b e. (a -> b) -> F e a -> F e b
>^=< (([FRequest] -> K Bool b -> F c b -> F (Either Bool c) (Either b b)
forall a b c d.
[FRequest] -> K a b -> F c d -> F (Either a c) (Either b d)
groupF [FRequest]
startcmds K Bool b
forall b. K Bool b
kernel (F c b -> F (Either Bool c) (Either b b))
-> (F c b -> F c b) -> F c b -> F (Either Bool c) (Either b b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> F c b -> F c b
forall a b. Int -> F a b -> F a b
marginF (Int
edgew Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) F c b
f)