module BubbleF(bubbleF, bubblePopupF, bubbleRootPopupF) where
import Command
import XDraw
import CompOps((>=^<), (>^=<))
import Dlayout(groupF)
import Event
import Fudget(F)
import FRequest
import NullF()
import Gc
import Geometry(origin,pP,Point(..),psub,padd)
import LayoutRequest(LayoutResponse(..))
import Message(Message(..))
import PopupGroupF
import Spacer(sepF)
import ShapeK
import MapstateK
import EitherUtils(stripEither)
import Xtypes
default(Int)
F b2 d2
f =
(Size -> Size, [WindowAttributes], K Any Any)
-> F b2 d2 -> F (PopupMsg b2) d2
forall b1 d1 b2 d2.
(Size -> Size, [WindowAttributes], K b1 d1)
-> F b2 d2 -> F (PopupMsg b2) d2
popupGroupF (Size -> Size
bubbleOffset, [WindowAttributes]
wattrs, K Any Any
forall b ho. K b ho
bubbleShapeK) (F b2 d2 -> F b2 d2
forall a b. F a b -> F a b
bubbleF F b2 d2
f)
F b2 d2
f =
(Size -> Size, [WindowAttributes], K Any Any)
-> F b2 d2 -> F (PopupMsg b2) d2
forall b1 d1 b2 d2.
(Size -> Size, [WindowAttributes], K b1 d1)
-> F b2 d2 -> F (PopupMsg b2) d2
rootPopupF (Size -> Size
bubbleOffset, [WindowAttributes]
rwattrs, K Any Any
forall b ho. K b ho
bubbleShapeK) (F b2 d2 -> F b2 d2
forall a b. F a b -> F a b
bubbleF F b2 d2
f)
bubbleF :: (F a b) -> F a b
bubbleF :: F a b -> F a b
bubbleF F a b
f =
let startcmds :: [FRequest]
startcmds = [XCommand -> FRequest
XCmd (XCommand -> FRequest) -> XCommand -> FRequest
forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [WindowAttributes]
wattrs]
in Either b b -> b
forall p. Either p p -> p
stripEither (Either b b -> b)
-> F (Either Any a) (Either b b) -> F (Either Any a) b
forall a b e. (a -> b) -> F e a -> F e b
>^=<
[FRequest] -> K Any b -> F a b -> F (Either Any a) (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 Any b
forall b ho. K b ho
bubbleShapeK (Size -> F a b -> F a b
forall a b. Size -> F a b -> F a b
sepF Size
sep F a b
f) F (Either Any a) b -> (a -> Either Any a) -> F a b
forall c d e. F c d -> (e -> c) -> F e d
>=^< a -> Either Any a
forall a b. b -> Either a b
Right
wattrs :: [WindowAttributes]
wattrs = [[EventMask] -> WindowAttributes
CWEventMask [EventMask
ExposureMask]]
rwattrs :: [WindowAttributes]
rwattrs = Bool -> WindowAttributes
CWOverrideRedirect Bool
TrueWindowAttributes -> [WindowAttributes] -> [WindowAttributes]
forall a. a -> [a] -> [a]
:[WindowAttributes]
wattrs
bubbleShapeK :: K b ho
bubbleShapeK =
GCId -> [GCAttributes Pixel FontId] -> (GCId -> K b ho) -> K b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
GCId -> [GCAttributes Pixel FontId] -> (GCId -> f b ho) -> f b ho
wCreateGC GCId
rootGC [Width -> GCAttributes Pixel FontId
forall a b. Width -> GCAttributes a b
GCLineWidth Width
2] ((GCId -> K b ho) -> K b ho) -> (GCId -> K b ho) -> K b ho
forall a b. (a -> b) -> a -> b
$
(Size -> [DrawCommand]) -> K b ho -> K b ho
forall a b. (Size -> [DrawCommand]) -> K a b -> K a b
shapeK Size -> [DrawCommand]
fillBubble (K b ho -> K b ho) -> (GCId -> K b ho) -> GCId -> K b ho
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GCId -> K b ho
forall b ho. GCId -> K b ho
bubbleK
bubbleK :: GCId -> K b ho
bubbleK GCId
gc =
let bubbleT :: Size -> Message FResponse b -> (Size, [Message FRequest b])
bubbleT state :: Size
state@Size
size Message FResponse b
msg =
case Message FResponse b
msg of
Low (LEvt (LayoutSize Size
size')) -> (Size
size', [])
Low (XEvt (Expose Rect
_ Width
0)) ->
(Size
state, if Size
size Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
origin
then []
else [FRequest -> Message FRequest b
forall a b. a -> Message a b
Low (FRequest -> Message FRequest b) -> FRequest -> Message FRequest b
forall a b. (a -> b) -> a -> b
$ GCId -> DrawCommand -> FRequest
wDraw GCId
gc (Size -> DrawCommand
drawBubble (Size
sizeSize -> Size -> Size
forall a. Num a => a -> a -> a
-Size
1))])
Message FResponse b
_ -> (Size
state, [])
in (Size -> KEvent b -> (Size, [KCommand ho])) -> Size -> K b ho
forall t hi ho.
(t -> KEvent hi -> (t, [KCommand ho])) -> t -> K hi ho
mapstateK Size -> KEvent b -> (Size, [KCommand ho])
forall b b.
Size -> Message FResponse b -> (Size, [Message FRequest b])
bubbleT Size
origin
drawBubble :: Size -> DrawCommand
drawBubble Size
size = CoordMode -> [Size] -> DrawCommand
DrawLines CoordMode
CoordModeOrigin (Size -> [Size]
bubblePoints Size
size)
fillBubble :: Size -> [DrawCommand]
fillBubble Size
size = [Shape -> CoordMode -> [Size] -> DrawCommand
FillPolygon Shape
Convex CoordMode
CoordModeOrigin (Size -> [Size]
bubblePoints Size
size)]
c :: Width
c = Width
4
ah :: Width
ah = Width
12
ax :: Width
ax = Width
12
aw :: Width
aw = Width
6
atx :: Width
atx = Width
6
bubbleBorder :: Width
bubbleBorder = Width
ah Width -> Width -> Width
forall a. Num a => a -> a -> a
+ Width
c
sep :: Size
sep = Width -> Width -> Size
pP (Width
2 Width -> Width -> Width
forall a. Num a => a -> a -> a
* Width
c) (Width
2 Width -> Width -> Width
forall a. Num a => a -> a -> a
* Width
c Width -> Width -> Width
forall a. Num a => a -> a -> a
+ Width
bubbleBorder)
bubbleOffset :: Size -> Size
bubbleOffset (Point Width
_ Width
h) = Width -> Width -> Size
Point Width
atx (Width
h Width -> Width -> Width
forall a. Num a => a -> a -> a
- Width
c)
bubblePoints :: Size -> [Size]
bubblePoints Size
size =
let Point Width
w Width
h = Size -> Size -> Size
psub Size
size (Width -> Width -> Size
pP Width
0 (Width
2 Width -> Width -> Width
forall a. Num a => a -> a -> a
* Width
bubbleBorder))
in (Size -> Size) -> [Size] -> [Size]
forall a b. (a -> b) -> [a] -> [b]
map (Size -> Size -> Size
padd (Width -> Width -> Size
pP Width
0 Width
bubbleBorder))
[Width -> Width -> Size
pP Width
c Width
0,
Width -> Width -> Size
pP (Width
w Width -> Width -> Width
forall a. Num a => a -> a -> a
- Width
c) Width
0,
Width -> Width -> Size
pP Width
w Width
c,
Width -> Width -> Size
pP Width
w (Width
h Width -> Width -> Width
forall a. Num a => a -> a -> a
- Width
c),
Width -> Width -> Size
pP (Width
w Width -> Width -> Width
forall a. Num a => a -> a -> a
- Width
c) Width
h,
Width -> Width -> Size
pP (Width
ax Width -> Width -> Width
forall a. Num a => a -> a -> a
+ Width
aw) Width
h,
Width -> Width -> Size
pP Width
atx (Width
h Width -> Width -> Width
forall a. Num a => a -> a -> a
+ Width
ah),
Width -> Width -> Size
pP Width
ax Width
h,
Width -> Width -> Size
pP Width
c Width
h,
Width -> Width -> Size
pP Width
0 (Width
h Width -> Width -> Width
forall a. Num a => a -> a -> a
- Width
c),
Width -> Width -> Size
pP Width
0 Width
c,
Width -> Width -> Size
pP Width
c Width
0]