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 =
    (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)

bubbleRootPopupF :: F b2 d2 -> F (PopupMsg b2) d2
bubbleRootPopupF 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]

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