module HandleF(hHandleF,vHandleF) where
import AllFudgets
hHandleF :: Double -> F Point d
hHandleF = LayoutDir -> Int -> Double -> F Point d
forall d. LayoutDir -> Int -> Double -> F Point d
handleF' LayoutDir
Horizontal Int
108
vHandleF :: Double -> F Point d
vHandleF = LayoutDir -> Int -> Double -> F Point d
forall d. LayoutDir -> Int -> Double -> F Point d
handleF' LayoutDir
Vertical Int
116
sepSize :: Int
sepSize = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
2 Int
forall a. Num a => a
defaultSep
sepD :: LayoutDir -> Drawing lbl Gfx
sepD LayoutDir
dir =
Placer -> Drawing lbl Gfx -> Drawing lbl Gfx
forall lbl leaf. Placer -> Drawing lbl leaf -> Drawing lbl leaf
placedD (Int -> Int -> Spacer
margS Int
d (Int
d2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
d) Spacer -> Placer -> Placer
`spacerP` LayoutDir -> Int -> Placer
linearP LayoutDir
dir Int
0) (Drawing lbl Gfx -> Drawing lbl Gfx)
-> Drawing lbl Gfx -> Drawing lbl Gfx
forall a b. (a -> b) -> a -> b
$
[Drawing lbl Gfx] -> Drawing lbl Gfx
forall lbl leaf. [Drawing lbl leaf] -> Drawing lbl leaf
boxD [[ColorName] -> Drawing lbl Gfx -> Drawing lbl Gfx
forall a lbl leaf.
(Show a, ColorGen a) =>
a -> Drawing lbl leaf -> Drawing lbl leaf
fgD [ColorName
shadowColor,ColorName
"black"] Drawing lbl Gfx
forall lbl. Drawing lbl Gfx
l,[ColorName] -> Drawing lbl Gfx -> Drawing lbl Gfx
forall a lbl leaf.
(Show a, ColorGen a) =>
a -> Drawing lbl leaf -> Drawing lbl leaf
fgD [ColorName
shineColor,ColorName
"white"] Drawing lbl Gfx
forall lbl. Drawing lbl Gfx
l]
where l :: Drawing lbl Gfx
l = FlexibleDrawing -> Drawing lbl Gfx
forall a lbl. Graphic a => a -> Drawing lbl Gfx
g FlexibleDrawing
line
d2 :: Int
d2 = Int
sepSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2
d :: Int
d = Int
d2 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
margS :: Int -> Int -> Spacer
margS = LayoutDir
-> (Int -> Int -> Spacer)
-> (Int -> Int -> Spacer)
-> Int
-> Int
-> Spacer
forall p. LayoutDir -> p -> p -> p
colinear LayoutDir
dir Int -> Int -> Spacer
hMarginS Int -> Int -> Spacer
vMarginS
line :: FlexibleDrawing
line = LayoutDir
-> (Int -> FlexibleDrawing)
-> (Int -> FlexibleDrawing)
-> Int
-> FlexibleDrawing
forall p. LayoutDir -> p -> p -> p
colinear LayoutDir
dir Int -> FlexibleDrawing
vFiller Int -> FlexibleDrawing
hFiller Int
1
handleF' :: LayoutDir -> Int -> Double -> F Point d
handleF' LayoutDir
dir Int
cur Double
alignment =
SP (Either Any Any) d
forall a b. SP a b
nullSP SP (Either Any Any) d
-> F (Either Point Any) (Either Any Any) -> F (Either Point Any) d
forall a b e. SP a b -> F e a -> F e b
>^^=<
(TCommand -> TCommand)
-> F (Either Point Any) (Either Any Any)
-> F (Either Point Any) (Either Any Any)
forall hi ho. (TCommand -> TCommand) -> F hi ho -> F hi ho
postMapLow TCommand -> TCommand
post ([FRequest]
-> K Point Any
-> F Any Any
-> F (Either Point Any) (Either Any Any)
forall a b c d.
[FRequest] -> K a b -> F c d -> F (Either a c) (Either b d)
groupF [FRequest]
startcmds K Point Any
forall b. K Point b
handleK0 (Drawing Any Gfx -> F Any Any
forall g a b. Graphic g => g -> F a b
labelF (LayoutDir -> Drawing Any Gfx
forall lbl. LayoutDir -> Drawing lbl Gfx
sepD LayoutDir
dir)))
F (Either Point Any) d -> (Point -> Either Point Any) -> F Point d
forall c d e. F c d -> (e -> c) -> F e d
>=^< Point -> Either Point Any
forall a b. a -> Either a b
Left
where
post :: TCommand -> TCommand
post ([Direction
L],cmd :: FRequest
cmd@(LCmd LayoutMessage
_)) = ([Direction
R,Direction
R],FRequest
cmd)
post TCommand
tcmd = TCommand
tcmd
startcmds :: [FRequest]
startcmds =
[
XCommand -> FRequest
XCmd (XCommand -> FRequest) -> XCommand -> FRequest
forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [[EventMask] -> WindowAttributes
CWEventMask [EventMask]
eventmask,
PixmapId -> WindowAttributes
CWBackPixmap PixmapId
parentRelative]]
eventmask :: [EventMask]
eventmask = [EventMask
ButtonPressMask,EventMask
ButtonReleaseMask,EventMask
ButtonMotionMask]
layoutreq :: LayoutRequest
layoutreq = Point -> Bool -> Bool -> LayoutRequest
plainLayout (Int -> Point
diag Int
sepSize) Bool
isHoriz (Bool -> Bool
not Bool
isHoriz)
isHoriz :: Bool
isHoriz = LayoutDir
dirLayoutDir -> LayoutDir -> Bool
forall a. Eq a => a -> a -> Bool
==LayoutDir
Horizontal
wantposreq :: Point -> Point -> LayoutRequest
wantposreq Point
size Point
p = LayoutRequest
layoutreq{wantedPos :: Maybe (Point, Point, Double)
wantedPos=(Point, Point, Double) -> Maybe (Point, Point, Double)
forall a. a -> Maybe a
Just(Point
p,Point
size,Double
alignment)}
handleK0 :: K Point b
handleK0 =
Int -> K Point b -> K Point b
forall a b. Int -> K a b -> K a b
setFontCursor Int
cur (K Point b -> K Point b) -> K Point b -> K Point b
forall a b. (a -> b) -> a -> b
$
K Point b
forall b. K Point b
handleK
handleK :: K Point ho
handleK = Point -> Point -> K Point ho
forall ho. Point -> Point -> K Point ho
idleK Point
0 Point
0
where
idleK :: Point -> Point -> K Point ho
idleK Point
parentp Point
size = Cont (K Point ho) (KEvent Point)
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont (K Point ho) (KEvent Point)
-> Cont (K Point ho) (KEvent Point)
forall a b. (a -> b) -> a -> b
$ (FResponse -> K Point ho)
-> (Point -> K Point ho) -> KEvent Point -> K Point ho
forall t1 p t2. (t1 -> p) -> (t2 -> p) -> Message t1 t2 -> p
message FResponse -> K Point ho
low Point -> K Point ho
high
where
same :: K Point ho
same = Point -> Point -> K Point ho
idleK Point
parentp Point
size
high :: Point -> K Point ho
high Point
size' = Point -> Point -> K Point ho
idleK Point
parentp Point
size'
low :: FResponse -> K Point ho
low FResponse
event =
case FResponse
event of
XEvt ButtonEvent {type' :: XEvent -> Pressed
type'=Pressed
Pressed,rootPos :: XEvent -> Point
rootPos=Point
pabs} ->
Point -> Point -> Point -> Point -> K Point ho
dragK Point
parentp Point
size (Point
pabsPoint -> Point -> Point
forall a. Num a => a -> a -> a
-Point
parentp) Point
pabs
LEvt (LayoutPos Point
parentp') -> Point -> Point -> K Point ho
idleK Point
parentp' Point
size
FResponse
_ -> K Point ho
same
dragK :: Point -> Point -> Point -> Point -> K Point ho
dragK Point
parentp Point
size Point
refp Point
curp = Cont (K Point ho) (KEvent Point)
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont (K Point ho) (KEvent Point)
-> Cont (K Point ho) (KEvent Point)
forall a b. (a -> b) -> a -> b
$ (FResponse -> K Point ho)
-> (Point -> K Point ho) -> KEvent Point -> K Point ho
forall t1 p t2. (t1 -> p) -> (t2 -> p) -> Message t1 t2 -> p
message FResponse -> K Point ho
low Point -> K Point ho
high
where
moveto :: Point -> K Point ho
moveto = Point -> Point -> Point -> Point -> K Point ho
dragK Point
parentp Point
size Point
refp
same :: K Point ho
same = Point -> K Point ho
moveto Point
curp
putpos :: Point -> K hi ho -> K hi ho
putpos = KCommand ho -> K hi ho -> K hi ho
forall ho hi. KCommand ho -> K hi ho -> K hi ho
putK (KCommand ho -> K hi ho -> K hi ho)
-> (Point -> KCommand ho) -> Point -> K hi ho -> K hi ho
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FRequest -> KCommand ho
forall a b. a -> Message a b
Low (FRequest -> KCommand ho)
-> (Point -> FRequest) -> Point -> KCommand ho
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutRequest -> FRequest
layoutRequestCmd (LayoutRequest -> FRequest)
-> (Point -> LayoutRequest) -> Point -> FRequest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Point -> LayoutRequest
wantposreq Point
size
high :: Point -> K Point ho
high Point
size' = Point -> Point -> Point -> Point -> K Point ho
dragK Point
parentp Point
size' Point
refp Point
curp
low :: FResponse -> K Point ho
low FResponse
event =
case FResponse
event of
LEvt (LayoutPos Point
parentp') -> Point -> Point -> Point -> Point -> K Point ho
dragK Point
parentp' Point
size Point
refp Point
curp
XEvt ButtonEvent {type' :: XEvent -> Pressed
type'=Pressed
Released,rootPos :: XEvent -> Point
rootPos=Point
curp0'} ->
(if Point
curp'Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
==Point
curp
then K Point ho -> K Point ho
forall a. a -> a
id
else Point -> K Point ho -> K Point ho
forall hi ho. Point -> K hi ho -> K hi ho
putpos (Point
curp'Point -> Point -> Point
forall a. Num a => a -> a -> a
-Point
refp)) (K Point ho -> K Point ho) -> K Point ho -> K Point ho
forall a b. (a -> b) -> a -> b
$
Point -> Point -> K Point ho
idleK Point
parentp Point
size
where curp' :: Point
curp' = Point -> Point -> Point
constrain Point
size (Point
curp0'Point -> Point -> Point
forall a. Num a => a -> a -> a
-Point
refp)Point -> Point -> Point
forall a. Num a => a -> a -> a
+Point
refp
XEvt MotionNotify {rootPos :: XEvent -> Point
rootPos=Point
curp0',state :: XEvent -> ModState
state=ModState
mods} ->
if Point
curp'Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
==Point
curp Bool -> Bool -> Bool
|| Modifiers
Shift Modifiers -> ModState -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ModState
mods
then K Point ho
same
else Point -> K Point ho -> K Point ho
forall hi ho. Point -> K hi ho -> K hi ho
putpos (Point
curp'Point -> Point -> Point
forall a. Num a => a -> a -> a
-Point
refp) (K Point ho -> K Point ho) -> K Point ho -> K Point ho
forall a b. (a -> b) -> a -> b
$
Point -> K Point ho
moveto Point
curp'
where curp' :: Point
curp' = Point -> Point -> Point
constrain Point
size (Point
curp0'Point -> Point -> Point
forall a. Num a => a -> a -> a
-Point
refp)Point -> Point -> Point
forall a. Num a => a -> a -> a
+Point
refp
FResponse
_ -> K Point ho
same
constrain :: Point -> Point -> Point
constrain Point
size =
if Point
sizePoint -> Point -> Bool
forall a. Ord a => a -> a -> Bool
>Point
forall a. Num a => a
defaultSep
then Point -> Point -> Point
pmin (Point
sizePoint -> Point -> Point
forall a. Num a => a -> a -> a
-Point
forall a. Num a => a
defaultSep) (Point -> Point) -> (Point -> Point) -> Point -> Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Point -> Point
pmax Point
forall a. Num a => a
defaultSep
else Point -> Point
forall a. a -> a
id