module BubbleF(bubbleF, bubblePopupF, bubbleRootPopupF) where
--import Alignment(Alignment(..))
import Command
import XDraw
import CompOps((>=^<), (>^=<))
import Dlayout(groupF)
import Event
import Fudget(F)
--import FudgetIO
import FRequest
import NullF()
import Gc
import Geometry(origin,pP,Point(..),psub,padd)
import LayoutRequest(LayoutResponse(..))
import Message(Message(..))
import PopupGroupF
--import Popupmsg
import Spacer(sepF)
import ShapeK
import MapstateK
import EitherUtils(stripEither)
import Xtypes

default(Int) -- mostly for Hugs

bubblePopupF :: F b2 d2 -> F (PopupMsg b2) d2
bubblePopupF F b2 d2
f =
    forall {b1} {d1} {b2} {d2}.
(Size -> Size, [WindowAttributes], K b1 d1)
-> F b2 d2 -> F (PopupMsg b2) d2
popupGroupF (Size -> Size
bubbleOffset, [WindowAttributes]
wattrs, forall {hi} {ho}. K hi ho
bubbleShapeK) (forall a b. F a b -> F a b
bubbleF F b2 d2
f)

bubbleRootPopupF :: F b2 d2 -> F (PopupMsg b2) d2
bubbleRootPopupF F b2 d2
f =
    forall {b1} {d1} {b2} {d2}.
(Size -> Size, [WindowAttributes], K b1 d1)
-> F b2 d2 -> F (PopupMsg b2) d2
rootPopupF (Size -> Size
bubbleOffset, [WindowAttributes]
rwattrs, forall {hi} {ho}. K hi ho
bubbleShapeK) (forall a b. F a b -> F a b
bubbleF F b2 d2
f)

bubbleF :: (F a b) -> F a b
bubbleF :: forall a b. F a b -> F a b
bubbleF F a b
f =
  let startcmds :: [FRequest]
startcmds = [XCommand -> FRequest
XCmd forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [WindowAttributes]
wattrs]
  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 {hi} {ho}. K hi ho
bubbleShapeK (forall {a} {b}. Size -> F a b -> F a b
sepF Size
sep F a b
f) forall c d e. F c d -> (e -> c) -> F e d
>=^< forall a b. b -> Either a b
Right

wattrs :: [WindowAttributes]
wattrs = [[EventMask] -> WindowAttributes
CWEventMask [EventMask
ExposureMask]]
rwattrs :: [WindowAttributes]
rwattrs = Bool -> WindowAttributes
CWOverrideRedirect Bool
Trueforall a. a -> [a] -> [a]
:[WindowAttributes]
wattrs

bubbleShapeK :: K hi ho
bubbleShapeK =
  forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
GCId -> GCAttributeList -> (GCId -> f hi ho) -> f hi ho
wCreateGC GCId
rootGC [forall a b. Width -> GCAttributes a b
GCLineWidth Width
2] forall a b. (a -> b) -> a -> b
$
  forall a b. (Size -> [DrawCommand]) -> K a b -> K a b
shapeK Size -> [DrawCommand]
fillBubble forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {hi} {ho}. GCId -> K hi ho
bubbleK

bubbleK :: GCId -> K hi 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 forall a. Eq a => a -> a -> Bool
== Size
origin
	            then []
		    else [forall a b. a -> Message a b
Low forall a b. (a -> b) -> a -> b
$ GCId -> DrawCommand -> FRequest
wDraw GCId
gc (Size -> DrawCommand
drawBubble (Size
sizeforall a. Num a => a -> a -> a
-Size
1))])
	  Message FResponse b
_ -> (Size
state, [])
  in forall {t} {hi} {ho}.
(t -> KEvent hi -> (t, [KCommand ho])) -> t -> K hi ho
mapstateK 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 forall a. Num a => a -> a -> a
+ Width
c
sep :: Size
sep = Width -> Width -> Size
pP (Width
2 forall a. Num a => a -> a -> a
* Width
c) (Width
2 forall a. Num a => a -> a -> a
* Width
c 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 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 forall a. Num a => a -> a -> a
* Width
bubbleBorder))
    in  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 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 forall a. Num a => a -> a -> a
- Width
c),
             Width -> Width -> Size
pP (Width
w forall a. Num a => a -> a -> a
- Width
c) Width
h,
             Width -> Width -> Size
pP (Width
ax forall a. Num a => a -> a -> a
+ Width
aw) Width
h,
             Width -> Width -> Size
pP Width
atx (Width
h 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 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]

--drawlines (p1 : p2 : ps) = DrawLine (Line p1 p2) : drawlines (p2 : ps)
--drawlines _ = []