module ShapedButtonsF (radioF1, radioGroupF1, toggleF1, toggleButtonF1, RBBT (..)) where
import AllFudgets
import HbcUtils(lookupWithDefault)

data RBBT = Circle | Square | Triangle
type RadioButtonBorderType = RBBT

radioF1 :: RadioButtonBorderType -> String -> [(a, String)] -> a -> F a a
radioF1 RadioButtonBorderType
bbt String
fname [(a, String)]
alts a
startalt =
    forall a.
Eq a =>
RadioButtonBorderType
-> String -> [a] -> a -> (a -> String) -> F a a
radioGroupF1 RadioButtonBorderType
bbt String
fname (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(a, String)]
alts) a
startalt 
      (forall a b. Eq a => [(a, b)] -> b -> a -> b
lookupWithDefault [(a, String)]
alts (forall a. HasCallStack => String -> a
error String
"radioF"))

radioGroupF1 :: Eq a => RadioButtonBorderType -> FontName -> [a] -> a -> 
                        (a -> String) -> F a a
radioGroupF1 :: forall a.
Eq a =>
RadioButtonBorderType
-> String -> [a] -> a -> (a -> String) -> F a a
radioGroupF1 RadioButtonBorderType
bbt String
fname [a]
alts a
startalt a -> String
show_alt =
    let radioAlts :: F (a, Bool) (a, Bool)
radioAlts = forall {a}.
Eq a =>
RadioButtonBorderType
-> String -> [a] -> (a -> String) -> F (a, Bool) (a, Bool)
radioButtonsF1 RadioButtonBorderType
bbt String
fname [a]
alts a -> String
show_alt
        buttons :: F (Either (a, Bool) (a, Bool)) (a, Bool)
buttons = F (a, Bool) (a, Bool)
radioAlts forall c d e. F c d -> (e -> c) -> F e d
>=^< forall {a}. Either a a -> a
stripEither
    in  forall a b c. F (Either a b) (Either a c) -> F b c
loopLeftF (forall {b}. Eq b => b -> F (b, Bool) (Either (b, Bool) b)
excludeF1 a
startalt forall {a1} {b} {a2}. F a1 b -> F a2 a1 -> F a2 b
>==< F (Either (a, Bool) (a, Bool)) (a, Bool)
buttons) forall c d e. F c d -> (e -> c) -> F e d
>=^<
        (\a
x -> forall {a} {b}. a -> b -> (a, b)
pair a
x Bool
True)

radioButtonsF1 :: RadioButtonBorderType
-> String -> [a] -> (a -> String) -> F (a, Bool) (a, Bool)
radioButtonsF1 RadioButtonBorderType
bbt String
fname [a]
alts a -> String
show_alt =
    let radiobutton :: a -> (a, F Bool Bool)
radiobutton a
alt =
            (
             a
alt,
             forall {a} {b}. Bool -> Bool -> F a b -> F a b
noStretchF Bool
False Bool
True 
               (RadioButtonBorderType
-> String -> [(ModState, String)] -> String -> F Bool Bool
toggleButtonF1 RadioButtonBorderType
bbt String
fname [] (a -> String
show_alt a
alt))
            )
    in  forall {a} {b} {c}.
Eq a =>
Placer -> [(a, F b c)] -> F (a, b) (a, c)
listLF (Distance -> Placer
verticalP' Distance
0) (forall a b. (a -> b) -> [a] -> [b]
map a -> (a, F Bool Bool)
radiobutton [a]
alts)

excludeF1 :: b -> F (b, Bool) (Either (b, Bool) b)
excludeF1 b
start =
    let excl :: b -> SP (b, Bool) (Either (b, Bool) b)
excl b
last' =
            let same :: SP (b, Bool) (Either (b, Bool) b)
same = b -> SP (b, Bool) (Either (b, Bool) b)
excl b
last'
                cont :: b -> SP (b, Bool) (Either (b, Bool) b)
cont b
last'' = b -> SP (b, Bool) (Either (b, Bool) b)
excl b
last''
            in  forall a b. Cont (SP a b) a
getSP (\(b, Bool)
msg ->
                       case (b, Bool)
msg of
                         (b
new, Bool
False) -> if b
new forall a. Eq a => a -> a -> Bool
== b
last' then
                                             forall b a. [b] -> SP a b -> SP a b
putsSP [forall a b. a -> Either a b
Left (b
new, Bool
True)] (b -> SP (b, Bool) (Either (b, Bool) b)
cont b
new)
                                         else
                                             SP (b, Bool) (Either (b, Bool) b)
same
                         (b
new, Bool
True) -> if b
new forall a. Eq a => a -> a -> Bool
== b
last' then
                                            forall b a. [b] -> SP a b -> SP a b
putsSP [forall a b. b -> Either a b
Right b
new] (b -> SP (b, Bool) (Either (b, Bool) b)
cont b
new)
                                        else
                                            forall b a. [b] -> SP a b -> SP a b
putsSP [forall a b. a -> Either a b
Left (b
last', Bool
False), forall a b. b -> Either a b
Right b
new]
                                                  (b -> SP (b, Bool) (Either (b, Bool) b)
cont b
new))
    in  forall a b. SP a b -> F a b
absF (forall b a. [b] -> SP a b -> SP a b
putsSP [forall a b. a -> Either a b
Left (b
start, Bool
True)] (forall {b}. Eq b => b -> SP (b, Bool) (Either (b, Bool) b)
excl b
start))

toggleF1 :: RadioButtonBorderType
-> [(ModState, String)]
-> F a b
-> F (Either Bool a) (Either Bool b)
toggleF1 RadioButtonBorderType
bbt [(ModState, String)]
keys F a b
f =
  case RadioButtonBorderType
bbt of
    RadioButtonBorderType
Square ->
      let edgew :: Distance
edgew = Distance
3
          dsize :: Point
dsize = Distance -> Distance -> Point
Point Distance
10 Distance
10
          innersep :: Distance
innersep = Distance
3
          fudgetsep :: Distance
fudgetsep = Distance
5
          toggleK :: K Bool ho
toggleK =
              let cid :: Bool -> a
cid Bool
False = a
0
                  cid Bool
True = a
1
              in  forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId -> String -> Cont (f hi ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap
                                  String
onColor1
                                  (\Pixel
onC ->
                                   forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId -> String -> Cont (f hi ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap
                                                   String
offColor1
                                                   (\Pixel
offC ->
                                                    let toggle :: Bool -> [Message FRequest b]
toggle Bool
s =
                                                            forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> Message a b
Low forall b c a. (b -> c) -> (a -> b) -> a -> c
. XCommand -> FRequest
XCmd)
                                                                [[WindowAttributes] -> XCommand
ChangeWindowAttributes [Pixel -> WindowAttributes
CWBackPixel (if Bool
s then Pixel
onC else Pixel
offC)],
                                                                 XCommand
ClearWindow]
                                                        k :: Message a Bool -> [Message FRequest b]
k (High Bool
s) = forall {b}. Bool -> [Message FRequest b]
toggle Bool
s
                                                        k Message a Bool
_ = []
                                                    in  forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall a b. a -> Message a b
Low (LayoutRequest -> FRequest
layoutRequestCmd (Point -> Bool -> Bool -> LayoutRequest
plainLayout Point
dsize Bool
True Bool
True)) forall a. a -> [a] -> [a]
:
                                                              forall {b}. Bool -> [Message FRequest b]
toggle Bool
False)
                                                             (forall hi ho. KSP hi ho -> K hi ho
K forall a b. (a -> b) -> a -> b
$ forall {t} {b}. (t -> [b]) -> SP t b
concmapSP forall {a} {b}. Message a Bool -> [Message FRequest b]
k)))
          toggleb :: F (Either Bool Bool) b
toggleb =
                forall a b.
RadioButtonBorderType -> Distance -> F a b -> F (Either Bool a) b
buttonBorderF1 RadioButtonBorderType
bbt Distance
edgew
                              (forall {a} {b}. Distance -> F a b -> F a b
marginF Distance
innersep
                                    (forall a b. [FRequest] -> K a b -> F a b
windowF [{-ConfigureWindow [CWBorderWidth 0]-}] forall {ho}. K Bool ho
toggleK))
          togglebd :: F (Either (Either Bool Bool) a) b
togglebd =
              let post :: Either a (Either (Either a b) (Either a b)) -> Either a b
post (Left a
a) = forall a b. a -> Either a b
Left a
a
                  post (Right Either (Either a b) (Either a b)
b) = forall {a}. Either a a -> a
stripEither Either (Either a b) (Either a b)
b
              in  forall {a}. Either a a -> a
stripEither forall a b e. (a -> b) -> F e a -> F e b
>^=<
                  (forall {a} {b}.
Distance -> Alignment -> Alignment -> F a b -> F a b
marginHVAlignF Distance
0 Alignment
aCenter Alignment
aCenter forall {b}. F (Either Bool Bool) b
toggleb forall {a} {b} {c} {d}.
F a b
-> (Distance, Orientation, F c d) -> F (Either a c) (Either b d)
>+#<
                   (Distance
fudgetsep, Orientation
LeftOf, F a b
f))
      in  forall a b.
[(ModState, String)]
-> F (Either (Either Bool Bool) a) b
-> F (Either Bool a) (Either Bool b)
toggleGroupF [(ModState, String)]
keys (forall {a} {b}.
Distance -> Alignment -> Alignment -> F a b -> F a b
marginHVAlignF Distance
0 Alignment
aLeft Alignment
aCenter F (Either (Either Bool Bool) a) b
togglebd)
    RadioButtonBorderType
Triangle ->
      let edgew :: Distance
edgew = Distance
3
          dsize :: Point
dsize = Distance -> Distance -> Point
Point Distance
12 Distance
12
          innersep :: Distance
innersep = Distance
6
          fudgetsep :: Distance
fudgetsep = Distance
5
          toggleK :: K Bool ho
toggleK =
              let cid :: Bool -> a
cid Bool
False = a
0
                  cid Bool
True = a
1
              in  forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId -> String -> Cont (f hi ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap
                                  String
onColor1
                                  (\Pixel
onC ->
                                   forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId -> String -> Cont (f hi ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap
                                                   String
offColor1
                                                   (\Pixel
offC ->
                                                    let toggle :: Bool -> [Message FRequest b]
toggle Bool
s =
                                                            forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> Message a b
Low forall b c a. (b -> c) -> (a -> b) -> a -> c
. XCommand -> FRequest
XCmd)
                                                                [[WindowAttributes] -> XCommand
ChangeWindowAttributes [Pixel -> WindowAttributes
CWBackPixel (if Bool
s then Pixel
onC else Pixel
offC)],
                                                                 XCommand
ClearWindow]
                                                        k :: Message a Bool -> [Message FRequest b]
k (High Bool
s) = forall {b}. Bool -> [Message FRequest b]
toggle Bool
s
                                                        k Message a Bool
_ = []
                                                    in  forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall a b. a -> Message a b
Low (LayoutRequest -> FRequest
layoutRequestCmd (Point -> Bool -> Bool -> LayoutRequest
plainLayout Point
dsize Bool
True Bool
True)) forall a. a -> [a] -> [a]
:
                                                              forall {b}. Bool -> [Message FRequest b]
toggle Bool
False)
                                                             (forall hi ho. KSP hi ho -> K hi ho
K forall a b. (a -> b) -> a -> b
$ forall {t} {b}. (t -> [b]) -> SP t b
concmapSP forall {a} {b}. Message a Bool -> [Message FRequest b]
k)))
          vormT :: Point -> [DrawCommand]
vormT Point
punt = [Shape -> CoordMode -> [Point] -> DrawCommand
FillPolygon Shape
Nonconvex CoordMode
CoordModeOrigin [Point
origin, Point -> Point -> Point
padd Point
origin (Distance -> Distance -> Point
Point Distance
0 ((Point -> Distance
ycoord Point
punt)forall a. Num a => a -> a -> a
-Distance
1)),
                        Point -> Point -> Point
padd Point
origin (Distance -> Distance -> Point
Point ((Point -> Distance
xcoord Point
punt)forall a. Num a => a -> a -> a
-Distance
1) (((Point -> Distance
ycoord Point
punt)forall a. Integral a => a -> a -> a
`div`Distance
2)forall a. Num a => a -> a -> a
-Distance
1))]]
          toggleb :: F (Either Bool Bool) b
toggleb =
                forall a b.
RadioButtonBorderType -> Distance -> F a b -> F (Either Bool a) b
buttonBorderF1 RadioButtonBorderType
bbt Distance
edgew
                              (forall {a} {b}. Distance -> F a b -> F a b
marginF Distance
innersep
                                    (forall a b. [FRequest] -> K a b -> F a b
windowF [{-ConfigureWindow [CWBorderWidth 0]-}]
                                              (forall a b. (Point -> [DrawCommand]) -> K a b -> K a b
shapeK Point -> [DrawCommand]
vormT forall {ho}. K Bool ho
toggleK)))
          togglebd :: F (Either (Either Bool Bool) a) b
togglebd =
              let post :: Either a (Either (Either a b) (Either a b)) -> Either a b
post (Left a
a) = forall a b. a -> Either a b
Left a
a
                  post (Right Either (Either a b) (Either a b)
b) = forall {a}. Either a a -> a
stripEither Either (Either a b) (Either a b)
b
              in  forall {a}. Either a a -> a
stripEither forall a b e. (a -> b) -> F e a -> F e b
>^=<
                  (forall {a} {b}.
Distance -> Alignment -> Alignment -> F a b -> F a b
marginHVAlignF Distance
0 Alignment
aCenter Alignment
aCenter forall {b}. F (Either Bool Bool) b
toggleb forall {a} {b} {c} {d}.
F a b
-> (Distance, Orientation, F c d) -> F (Either a c) (Either b d)
>+#<
                   (Distance
fudgetsep, Orientation
LeftOf, F a b
f))
      in  forall a b.
[(ModState, String)]
-> F (Either (Either Bool Bool) a) b
-> F (Either Bool a) (Either Bool b)
toggleGroupF [(ModState, String)]
keys (forall {a} {b}.
Distance -> Alignment -> Alignment -> F a b -> F a b
marginHVAlignF Distance
0 Alignment
aLeft Alignment
aCenter F (Either (Either Bool Bool) a) b
togglebd)
    RadioButtonBorderType
Circle ->
      let edgew :: Distance
edgew = Distance
3
          dsize :: Point
dsize = Distance -> Distance -> Point
Point Distance
16 Distance
16
          innersep :: Distance
innersep = Distance
2
          fudgetsep :: Distance
fudgetsep = Distance
5
          toggleK :: K Bool ho
toggleK =
              let cid :: Bool -> a
cid Bool
False = a
0
                  cid Bool
True = a
1
              in  forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId -> String -> Cont (f hi ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap
                                  String
onColor1
                                  (\Pixel
onC ->
                                   forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId -> String -> Cont (f hi ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap
                                                   String
offColor1
                                                   (\Pixel
offC ->
                                                    let toggle :: Bool -> [Message FRequest b]
toggle Bool
s =
                                                            forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> Message a b
Low forall b c a. (b -> c) -> (a -> b) -> a -> c
. XCommand -> FRequest
XCmd)
                                                                [[WindowAttributes] -> XCommand
ChangeWindowAttributes [Pixel -> WindowAttributes
CWBackPixel (if Bool
s then Pixel
onC else Pixel
offC)],
                                                                 XCommand
ClearWindow]
                                                        k :: Message a Bool -> [Message FRequest b]
k (High Bool
s) = forall {b}. Bool -> [Message FRequest b]
toggle Bool
s
                                                        k Message a Bool
_ = []
                                                    in  forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall a b. a -> Message a b
Low (LayoutRequest -> FRequest
layoutRequestCmd (Point -> Bool -> Bool -> LayoutRequest
plainLayout Point
dsize Bool
True Bool
True)) forall a. a -> [a] -> [a]
:
                                                              forall {b}. Bool -> [Message FRequest b]
toggle Bool
False)
                                                             (forall hi ho. KSP hi ho -> K hi ho
K forall a b. (a -> b) -> a -> b
$ forall {t} {b}. (t -> [b]) -> SP t b
concmapSP forall {a} {b}. Message a Bool -> [Message FRequest b]
k)))
          vormC :: Point -> [DrawCommand]
vormC Point
punt = [Rect -> Distance -> Distance -> DrawCommand
FillArc (Point -> Point -> Rect
Rect Point
origin (Distance -> Distance -> Point
Point ((Point -> Distance
xcoord Point
punt)forall a. Num a => a -> a -> a
-Distance
1) ((Point -> Distance
ycoord Point
punt)forall a. Num a => a -> a -> a
-Distance
1))) (Distance
0forall a. Num a => a -> a -> a
*Distance
64) (Distance
360forall a. Num a => a -> a -> a
*Distance
64)]
          toggleb :: F (Either Bool Bool) b
toggleb =
                forall a b.
RadioButtonBorderType -> Distance -> F a b -> F (Either Bool a) b
buttonBorderF1 RadioButtonBorderType
bbt Distance
edgew
                              (forall {a} {b}. Distance -> F a b -> F a b
marginF Distance
innersep
                                    (forall a b. [FRequest] -> K a b -> F a b
windowF [{-ConfigureWindow [CWBorderWidth 0]-}]
                                             (forall a b. (Point -> [DrawCommand]) -> K a b -> K a b
shapeK Point -> [DrawCommand]
vormC forall {ho}. K Bool ho
toggleK)))
          togglebd :: F (Either (Either Bool Bool) a) b
togglebd =
              let post :: Either a (Either (Either a b) (Either a b)) -> Either a b
post (Left a
a) = forall a b. a -> Either a b
Left a
a
                  post (Right Either (Either a b) (Either a b)
b) = forall {a}. Either a a -> a
stripEither Either (Either a b) (Either a b)
b
              in  forall {a}. Either a a -> a
stripEither forall a b e. (a -> b) -> F e a -> F e b
>^=<
                  (forall {a} {b}.
Distance -> Alignment -> Alignment -> F a b -> F a b
marginHVAlignF Distance
0 Alignment
aCenter Alignment
aCenter forall {b}. F (Either Bool Bool) b
toggleb forall {a} {b} {c} {d}.
F a b
-> (Distance, Orientation, F c d) -> F (Either a c) (Either b d)
>+#<
                   (Distance
fudgetsep, Orientation
LeftOf, F a b
f))
      in  forall a b.
[(ModState, String)]
-> F (Either (Either Bool Bool) a) b
-> F (Either Bool a) (Either Bool b)
toggleGroupF [(ModState, String)]
keys (forall {a} {b}.
Distance -> Alignment -> Alignment -> F a b -> F a b
marginHVAlignF Distance
0 Alignment
aLeft Alignment
aCenter F (Either (Either Bool Bool) a) b
togglebd)

toggleButtonF1 :: RadioButtonBorderType -> String -> [(ModState, KeySym)] -> String -> F Bool Bool
toggleButtonF1 :: RadioButtonBorderType
-> String -> [(ModState, String)] -> String -> F Bool Bool
toggleButtonF1 RadioButtonBorderType
bbt String
fname [(ModState, String)]
keys String
text =
  forall {a}. Either a a -> a
stripEither forall a b e. (a -> b) -> F e a -> F e b
>^=<
  forall {a} {b}.
RadioButtonBorderType
-> [(ModState, String)]
-> F a b
-> F (Either Bool a) (Either Bool b)
toggleF1 RadioButtonBorderType
bbt [(ModState, String)]
keys (forall {a} {b}. Bool -> Bool -> F a b -> F a b
noStretchF Bool
True Bool
True (forall {a1} {a2} {b}.
Graphic a1 =>
Customiser (DisplayF a1) -> a1 -> F a2 b
labelF' (forall {xxx} {a}.
(HasFontSpec xxx, Show a, FontGen a) =>
a -> Customiser xxx
setFont String
fname) String
text))
  forall c d e. F c d -> (e -> c) -> F e d
>=^< forall a b. a -> Either a b
Left

offColor1 :: String
offColor1 = String -> String -> String
argKey String
"toggleoff" String
bgColor

onColor1 :: String
onColor1 = String -> String -> String
argKey String
"toggleon" String
fgColor

buttonBorderF1 :: RadioButtonBorderType -> Int -> (F a b) -> F (Either Bool a) b
buttonBorderF1 :: forall a b.
RadioButtonBorderType -> Distance -> F a b -> F (Either Bool a) b
buttonBorderF1 = forall a b.
RadioButtonBorderType -> Distance -> F a b -> F (Either Bool a) b
stdButtonBorderF1

stdButtonBorderF1 :: RadioButtonBorderType -> Distance -> F c b -> F (Either Bool c) b
stdButtonBorderF1 RadioButtonBorderType
bbt Distance
edgew F c b
f =
    let kernel :: K Bool ho
kernel =
          forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId -> String -> String -> (Pixel -> f hi ho) -> f hi ho
allocNamedColorDefPixel ColormapId
defaultColormap String
shineColor String
"white" forall a b. (a -> b) -> a -> b
$ \Pixel
shine ->
          forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId -> String -> String -> (Pixel -> f hi ho) -> f hi ho
allocNamedColorDefPixel ColormapId
defaultColormap String
shadowColor String
"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
rootGC [forall a b. GCFunction -> GCAttributes a b
GCFunction GCFunction
GXcopy, forall a b. a -> GCAttributes a b
GCForeground Pixel
shine, forall a b. a -> GCAttributes a b
GCBackground Pixel
shine] forall a b. (a -> b) -> a -> b
$ \GCId
extraGC ->
          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
              dRAWS :: Point -> ([Message FRequest b], [Message FRequest b])
dRAWS Point
s =
                    let bpx :: Distance
bpx = Distance
edgew
                        bpy :: Distance
bpy = Distance
edgew
                        upperLeftCorner :: Point
upperLeftCorner = Distance -> Distance -> Point
Point Distance
bpx Distance
bpy
                        size :: Point
size@(Point Distance
sx Distance
sy) = Point -> Point -> Point
psub Point
s (Distance -> Distance -> Point
Point Distance
1 Distance
1)
                        rect :: Rect
rect = Point -> Point -> Rect
Rect Point
origin Point
size
                        upperRightCorner :: Point
upperRightCorner = Distance -> Distance -> Point
Point (Distance
sx forall a. Num a => a -> a -> a
- Distance
bpx) Distance
bpy
                        lowerLeftCorner :: Point
lowerLeftCorner = Distance -> Distance -> Point
Point Distance
bpx (Distance
sy forall a. Num a => a -> a -> a
- Distance
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 (Distance -> Distance -> Point
Point Distance
1 Distance
0)
                        incy :: Point -> Point
incy = Point -> Point -> Point
padd (Distance -> Distance -> Point
Point Distance
0 Distance
1)
                        decx :: Point -> Point
decx = Point -> Point -> Point
padd (Distance -> Distance -> Point
Point (-Distance
1) Distance
0)
                        decy :: Point -> Point
decy = Point -> Point -> Point
padd (Distance -> Distance -> Point
Point Distance
0 (-Distance
1))
                        lowerBorderPoints :: [Point]
lowerBorderPoints = [Point
lowerLeftCorner, Point
lowerRightCorner,
                                             Point
upperRightCorner, Distance -> Distance -> Point
Point Distance
sx Distance
0, Point
size, Distance -> Distance -> Point
Point Distance
0 Distance
sy]
                        borderPoints :: [Point]
borderPoints =
                          [Distance -> Distance -> Point
pP Distance
1 Distance
1, Distance -> Distance -> Point
pP Distance
1 Distance
sy, Point
size, Distance -> Distance -> Point
pP Distance
sx Distance
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]
                        rectPoints :: [Point]
rectPoints = [Point
origin, Point -> Point -> Point
padd Point
origin (Distance -> Distance -> Point
Point (Distance
sxforall a. Num a => a -> a -> a
-Distance
1) Distance
0), Point
size, Point -> Point -> Point
padd Point
origin (Distance -> Distance -> Point
Point Distance
0 (Distance
syforall a. Num a => a -> a -> a
-Distance
1))]
                    in  (forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Message a b
Low [
                                  GCId -> Shape -> CoordMode -> [Point] -> FRequest
wFillPolygon GCId
extraGC Shape
Convex CoordMode
CoordModeOrigin [Point]
rectPoints,
                                  GCId -> Shape -> CoordMode -> [Point] -> FRequest
wFillPolygon GCId
drawGC Shape
Nonconvex CoordMode
CoordModeOrigin [Point]
lowerBorderPoints,
                                  GCId -> Line -> FRequest
wDrawLine GCId
drawGC Line
leftBorder,
                                  GCId -> Line -> FRequest
wDrawLine GCId
drawGC Line
upperBorder,
                                  GCId -> Line -> FRequest
wDrawLine GCId
drawGC Line
upperLeftLine,
                                  GCId -> Line -> FRequest
wDrawLine GCId
invertGC Line
lowerRightLine,
                                  GCId -> Rect -> FRequest
wDrawRectangle GCId
drawGC Rect
rect
                                 ],
                                 [forall a b. a -> Message a b
Low (GCId -> Shape -> CoordMode -> [Point] -> FRequest
wFillPolygon GCId
invertGC Shape
Nonconvex CoordMode
CoordModeOrigin [Point]
borderPoints)])
              dRAWT :: Point -> ([Message FRequest b], [Message FRequest b])
dRAWT Point
s =
                    let bpx :: Distance
bpx = Distance
edgew
                        bpy :: Distance
bpy = Distance
edgewforall a. Num a => a -> a -> a
+Distance
2
                        upperLeftCorner :: Point
upperLeftCorner = Distance -> Distance -> Point
Point Distance
bpx Distance
bpy
                        size :: Point
size@(Point Distance
sx Distance
sy) = Point -> Point -> Point
psub Point
s (Distance -> Distance -> Point
Point Distance
1 Distance
1)
                        ap :: Point
ap = Point -> Point -> Point
padd Point
origin (Distance -> Distance -> Point
Point Distance
5 Distance
2)
                        bp :: Point
bp = Point -> Point -> Point
padd Point
origin (Distance -> Distance -> Point
Point Distance
5 (Distance
syforall a. Num a => a -> a -> a
-Distance
3))
                        cp :: Point
cp = Distance -> Distance -> Point
Point (Distance
sx) (((Distance
sy forall a. Num a => a -> a -> a
- Distance
bpy)forall a. Integral a => a -> a -> a
`div`Distance
2)forall a. Num a => a -> a -> a
+Distance
2)
                        dp :: Point
dp = Point -> Point -> Point
padd Point
ap (Distance -> Distance -> Point
Point Distance
bpx Distance
bpy)
                        ep :: Point
ep = Point -> Point -> Point
padd Point
bp (Distance -> Distance -> Point
Point Distance
bpx (-Distance
bpy))
                        fp :: Point
fp = Point -> Point -> Point
psub Point
cp (Distance -> Distance -> Point
Point (Distance
bpxforall a. Num a => a -> a -> a
+Distance
4) Distance
0)
                        l1 :: Line
l1 = Point -> Point -> Line
Line Point
ap Point
bp
                        l2 :: Line
l2 = Point -> Point -> Line
Line Point
bp Point
cp
                        l3 :: Line
l3 = Point -> Point -> Line
Line Point
cp Point
ap
                        l4 :: Line
l4 = Point -> Point -> Line
Line Point
dp Point
ep
                        l5 :: Line
l5 = Point -> Point -> Line
Line Point
ep Point
fp
                        l6 :: Line
l6 = Point -> Point -> Line
Line Point
fp Point
dp
                        l7 :: Line
l7 = Point -> Point -> Line
Line Point
ap Point
dp
                        l8 :: Line
l8 = Point -> Point -> Line
Line Point
bp Point
ep
                        l9 :: Line
l9 = Point -> Point -> Line
Line Point
cp Point
fp
                        incx :: Point -> Point
incx = Point -> Point -> Point
padd (Distance -> Distance -> Point
Point Distance
1 Distance
0)
                        incy :: Point -> Point
incy = Point -> Point -> Point
padd (Distance -> Distance -> Point
Point Distance
0 Distance
1)
                        decx :: Point -> Point
decx = Point -> Point -> Point
padd (Distance -> Distance -> Point
Point (-Distance
1) Distance
0)
                        decy :: Point -> Point
decy = Point -> Point -> Point
padd (Distance -> Distance -> Point
Point Distance
0 (-Distance
1))
                        tBorderPoints :: [Point]
tBorderPoints = [(Point -> Point
incx forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Point
incy) Point
ap, Point -> Point
decy Point
bp, Point -> Point
decx Point
cp, (Point -> Point
incx forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Point
incy) Point
ap, Point
dp, Point
fp, Point
ep, Point
dp]
                        tLowerBorderPoints :: [Point]
tLowerBorderPoints = [Point
ep,Point
bp,Point
cp,Point
fp]
                        trianglePoints :: [Point]
trianglePoints = [Point
ap,Point
bp,Point
cp]
                    in  (forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Message a b
Low [
                                  GCId -> Shape -> CoordMode -> [Point] -> FRequest
wFillPolygon GCId
extraGC Shape
Nonconvex CoordMode
CoordModeOrigin [Point]
trianglePoints,
                                  GCId -> Shape -> CoordMode -> [Point] -> FRequest
wFillPolygon GCId
drawGC Shape
Nonconvex CoordMode
CoordModeOrigin [Point]
tLowerBorderPoints,
                                  GCId -> Line -> FRequest
wDrawLine GCId
drawGC Line
l1,
                                  GCId -> Line -> FRequest
wDrawLine GCId
drawGC Line
l2,
                                  GCId -> Line -> FRequest
wDrawLine GCId
drawGC Line
l3,
                                  GCId -> Line -> FRequest
wDrawLine GCId
drawGC Line
l4,
                                  GCId -> Line -> FRequest
wDrawLine GCId
drawGC Line
l5,
                                  GCId -> Line -> FRequest
wDrawLine GCId
drawGC Line
l6,
                                  GCId -> Line -> FRequest
wDrawLine GCId
drawGC Line
l7,
                                  GCId -> Line -> FRequest
wDrawLine GCId
drawGC Line
l8,
                                  GCId -> Line -> FRequest
wDrawLine GCId
drawGC Line
l9
                                 ],
                                 [
                                  forall a b. a -> Message a b
Low (GCId -> Shape -> CoordMode -> [Point] -> FRequest
wFillPolygon GCId
invertGC Shape
Nonconvex
                                  CoordMode
CoordModeOrigin [Point]
tBorderPoints)
                                 ])
              dRAWC :: Point -> ([Message FRequest b], [Message FRequest b])
dRAWC Point
s =
                    let bpx :: Distance
bpx = Distance
edgew
                        bpy :: Distance
bpy = Distance
edgew
                        upperLeftCorner :: Point
upperLeftCorner = Distance -> Distance -> Point
Point Distance
bpx Distance
bpy
                        size :: Point
size@(Point Distance
sx Distance
sy) = Point -> Point -> Point
psub Point
s (Distance -> Distance -> Point
Point Distance
1 Distance
1)
                        groteRechthoek :: Rect
groteRechthoek = Point -> Point -> Rect
Rect Point
origin Point
size
                        groteRechthoek2 :: Rect
groteRechthoek2 = Point -> Point -> Rect
Rect (Point -> Point -> Point
psub Point
origin (Distance -> Distance -> Point
Point Distance
1 Distance
1)) Point
size
                        kleineRechthoek :: Rect
kleineRechthoek = Point -> Point -> Rect
Rect (Point -> Point -> Point
padd Point
origin (Distance -> Distance -> Point
Point Distance
edgew Distance
edgew)) (Distance -> Distance -> Point
Point (Distance
sxforall a. Num a => a -> a -> a
-(Distance
2forall a. Num a => a -> a -> a
*Distance
edgew)) (Distance
syforall a. Num a => a -> a -> a
-(Distance
2forall a. Num a => a -> a -> a
*Distance
edgew)))
                    in  (forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Message a b
Low [
                                  GCId -> Rect -> Distance -> Distance -> FRequest
wFillArc GCId
extraGC Rect
groteRechthoek (Distance
0forall a. Num a => a -> a -> a
*Distance
64) (Distance
360forall a. Num a => a -> a -> a
*Distance
64),
                                  GCId -> Rect -> Distance -> Distance -> FRequest
wFillArc GCId
drawGC Rect
groteRechthoek (-Distance
135forall a. Num a => a -> a -> a
*Distance
64) (Distance
180forall a. Num a => a -> a -> a
*Distance
64),
                                  GCId -> Rect -> Distance -> Distance -> FRequest
wDrawArc GCId
drawGC Rect
groteRechthoek (Distance
0forall a. Num a => a -> a -> a
*Distance
64) (Distance
360forall a. Num a => a -> a -> a
*Distance
64),
                                  GCId -> Rect -> Distance -> Distance -> FRequest
wFillArc GCId
extraGC Rect
kleineRechthoek (Distance
0forall a. Num a => a -> a -> a
*Distance
64) (Distance
360forall a. Num a => a -> a -> a
*Distance
64),
                                  GCId -> Rect -> Distance -> Distance -> FRequest
wDrawArc GCId
drawGC Rect
kleineRechthoek (Distance
0forall a. Num a => a -> a -> a
*Distance
64) (Distance
360forall a. Num a => a -> a -> a
*Distance
64)
                                 ],
                                 [forall a b. a -> Message a b
Low (GCId -> Rect -> Distance -> Distance -> FRequest
wFillArc GCId
invertGC Rect
groteRechthoek2 (Distance
0forall a. Num a => a -> a -> a
*Distance
64) (Distance
360forall a. Num a => a -> a -> a
*Distance
64))])
              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
                      ([Message FRequest b]
drawit_size, [Message FRequest b]
pressit_size) = case RadioButtonBorderType
bbt of
                                                      RadioButtonBorderType
Square -> forall {b} {b}.
Point -> ([Message FRequest b], [Message FRequest b])
dRAWS Point
size
                                                      RadioButtonBorderType
Triangle -> forall {b} {b}.
Point -> ([Message FRequest b], [Message FRequest b])
dRAWT Point
size
                                                      RadioButtonBorderType
Circle -> forall {b} {b}.
Point -> ([Message FRequest b], [Message FRequest b])
dRAWC Point
size
                      redraw :: Bool -> [Message FRequest b]
redraw Bool
b = if (Bool
b forall a. Eq a => a -> a -> Bool
== Bool
pressed) then [] else forall {b}. [Message FRequest b]
pressit_size
                  in  case KEvent Bool
bmsg of
                        Low (XEvt (Expose Rect
_ Distance
0)) -> forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {b}. [Message FRequest b]
drawit_size forall a. [a] -> [a] -> [a]
++
                            (if Bool
pressed then forall {b}. [Message FRequest b]
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 {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {b}. Bool -> [Message FRequest b]
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
$ [WindowChanges] -> XCommand
ConfigureWindow [Distance -> WindowChanges
CWBorderWidth Distance
0],
           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 a b. String -> K a b -> K a b
changeBg String
bgColor forall {ho}. K Bool ho
kernel)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. Distance -> F a b -> F a b
marginF (Distance
edgew forall a. Num a => a -> a -> a
+ Distance
1)) F c b
f)