module Border3dF(border3dF) where
import Color
import Command
import XDraw
import CompOps((>^=<))
import Defaults(bgColor, shadowColor, shineColor,new3d)
import Dlayout(groupF)
import Event
import Fudget
import FRequest
import Xcommand
import Gc
import Geometry(Point(..), origin, pP)
import GreyBgF(changeBg)
import LayoutRequest
import NullF
import Spacer(marginF)
import EitherUtils(stripEither)
import Utils(swap)
import Xtypes
import GCtx(wCreateGCtx,GCtx(..))
import GCAttrs(gcFgA)
border3dF :: Bool -> Int -> F a b -> F (Either Bool a) b
border3dF =
if Bool
new3d
then forall a b. Bool -> Int -> F a b -> F (Either Bool a) b
newBorder3dF
else forall a b. Bool -> Int -> F a b -> F (Either Bool a) b
oldBorder3dF
newBorder3dF :: Bool -> Int -> F a b -> F (Either Bool a) b
newBorder3dF :: forall a b. Bool -> Int -> F a b -> F (Either Bool a) b
newBorder3dF Bool
down Int
edgew F a b
f =
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 {b}. K Bool b
kernel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. Int -> F a b -> F a b
marginF Int
edgew) F a b
f)
where
startcmds :: [FRequest]
startcmds =
[XCommand -> FRequest
XCmd forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [[EventMask] -> WindowAttributes
CWEventMask [EventMask
ExposureMask],
Gravity -> WindowAttributes
CWBitGravity Gravity
NorthWestGravity]]
wCreateGC :: GCId -> [GCAttributes a1 a2] -> (GCId -> f i o) -> f i o
wCreateGC GCId
gc0 [GCAttributes a1 a2]
gcas GCId -> f i o
cont =
forall {a1} {f :: * -> * -> *} {a2} {i} {o}.
(ColorGen a1, FudgetIO f, FontGen a2, Show a1, Show a2) =>
GCtx -> [GCAttributes a1 a2] -> (GCtx -> f i o) -> f i o
wCreateGCtx (GCId -> FontData -> GCtx
GC GCId
gc0 forall a. HasCallStack => a
undefined) [GCAttributes a1 a2]
gcas forall a b. (a -> b) -> a -> b
$ \ (GC GCId
gc FontData
_) -> GCId -> f i o
cont GCId
gc
gcFg :: a1 -> (GCId -> f i o) -> f i o
gcFg a1
x = forall {a1} {f :: * -> * -> *} {a2} {i} {o}.
(ColorGen a1, FudgetIO f, FontGen a2, Show a1, Show a2) =>
GCId -> [GCAttributes a1 a2] -> (GCId -> f i o) -> f i o
wCreateGC GCId
rootGC forall a b. (a -> b) -> a -> b
$ forall c. c -> [GCAttributes c FontSpec]
gcFgA a1
x
kernel :: K Bool b
kernel =
forall a b. ColorName -> K a b -> K a b
changeBg ColorName
bgColor forall a b. (a -> b) -> a -> b
$
forall {a1} {f :: * -> * -> *} {i} {o}.
(ColorGen a1, FudgetIO f, Show a1) =>
a1 -> (GCId -> f i o) -> f i o
gcFg ColorName
shineColor forall a b. (a -> b) -> a -> b
$ \ GCId
whiteGC ->
forall {a1} {f :: * -> * -> *} {i} {o}.
(ColorGen a1, FudgetIO f, Show a1) =>
a1 -> (GCId -> f i o) -> f i o
gcFg ColorName
"black" forall a b. (a -> b) -> a -> b
$ \ GCId
blackGC ->
forall {a1} {f :: * -> * -> *} {i} {o}.
(ColorGen a1, FudgetIO f, Show a1) =>
a1 -> (GCId -> f i o) -> f i o
gcFg [ColorName
shadowColor,ColorName
"black"] forall a b. (a -> b) -> a -> b
$ \ GCId
shadowGC ->
let dRAW :: Point -> Bool -> [XCommand]
dRAW Point
s Bool
pressed =
let lrc :: Point
lrc@(Point Int
w Int
h) = Point
sforall a. Num a => a -> a -> a
-Point
1
ulc :: Point
ulc = Point
0; llc :: Point
llc = Int -> Int -> Point
pP Int
0 Int
h; urc :: Point
urc = Int -> Int -> Point
pP Int
w Int
0
uli :: Point
uli = Point
1; lli :: Point
lli = Point
llcforall a. Num a => a -> a -> a
+Point
nw; lri :: Point
lri = Point
lrcforall a. Num a => a -> a -> a
-Point
1; uri :: Point
uri = Point
urcforall a. Num a => a -> a -> a
-Point
nw
nw :: Point
nw = Int -> Int -> Point
pP Int
1 (-Int
1)
upper1 :: [Point]
upper1 = [Point
llc,Point
ulc,Point
urc]
upper2 :: [Point]
upper2 = [Point
lli,Point
uli,Point
uri]
lower1 :: [Point]
lower1 = [Point
llc,Point
lrc,Point
urc]
lower2 :: [Point]
lower2 = [Point
lli,Point
lri,Point
uri]
in if Bool
pressed
then [Point] -> [Point] -> [Point] -> [XCommand]
draw [Point]
lower1 [Point]
upper1 [Point]
upper2
else [Point] -> [Point] -> [Point] -> [XCommand]
draw [Point]
upper1 [Point]
lower1 [Point]
lower2
drawlines :: a -> [Point] -> (a, [DrawCommand])
drawlines a
gc [Point]
ls = (a
gc,[CoordMode -> [Point] -> DrawCommand
DrawLines CoordMode
CoordModeOrigin [Point]
ls])
draw :: [Point] -> [Point] -> [Point] -> [XCommand]
draw [Point]
wls [Point]
bls [Point]
dls =
[XCommand
ClearWindow,
Drawable -> [(GCId, [DrawCommand])] -> XCommand
DrawMany Drawable
MyWindow [
forall {a}. a -> [Point] -> (a, [DrawCommand])
drawlines GCId
shadowGC [Point]
dls,
forall {a}. a -> [Point] -> (a, [DrawCommand])
drawlines GCId
whiteGC [Point]
wls,
forall {a}. a -> [Point] -> (a, [DrawCommand])
drawlines GCId
blackGC [Point]
bls]]
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
draw :: Bool -> [XCommand]
draw = Point -> Bool -> [XCommand]
dRAW Point
size
redraw :: [XCommand]
redraw = Bool -> [XCommand]
draw Bool
pressed
in case KEvent Bool
bmsg of
Low (XEvt (Expose Rect
_ Int
0)) -> forall {i} {o}. [XCommand] -> K i o -> K i o
xcommandsK [XCommand]
redraw K Bool ho
same
Low (LEvt (LayoutSize Point
newsize)) | Point
newsizeforall a. Eq a => a -> a -> Bool
/=Point
size ->
forall {i} {o}. [XCommand] -> K i o -> K i o
xcommandsK (Point -> Bool -> [XCommand]
dRAW Point
newsize Bool
pressed) forall a b. (a -> b) -> a -> b
$
Bool -> Point -> K Bool ho
proc Bool
pressed Point
newsize
High Bool
change | Bool
changeforall a. Eq a => a -> a -> Bool
/=Bool
pressed ->
forall {i} {o}. [XCommand] -> K i o -> K i o
xcommandsK (Bool -> [XCommand]
draw 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
down
oldBorder3dF :: Bool -> Int -> F a b -> F (Either Bool a) b
oldBorder3dF :: forall a b. Bool -> Int -> F a b -> F (Either Bool a) b
oldBorder3dF Bool
down Int
edgew F a b
f =
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 {b}. K Bool b
kernel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. Int -> F a b -> F a b
marginF Int
edgew) F a b
f)
where
startcmds :: [FRequest]
startcmds =
[XCommand -> FRequest
XCmd forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [[EventMask] -> WindowAttributes
CWEventMask [EventMask
ExposureMask],
Gravity -> WindowAttributes
CWBitGravity Gravity
NorthWestGravity]]
kernel :: K Bool b
kernel =
forall a b. ColorName -> K a b -> K a b
changeBg ColorName
bgColor forall a b. (a -> b) -> a -> b
$
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId -> ColorName -> Cont (f hi ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap ColorName
shineColor forall a b. (a -> b) -> a -> b
$ \Pixel
shine ->
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId -> ColorName -> Cont (f hi ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap ColorName
shadowColor 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 -> b) -> a -> b
$ \GCId
shadowGC ->
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
GCId -> GCAttributeList -> (GCId -> f hi ho) -> f hi ho
wCreateGC GCId
shadowGC [forall a b. a -> GCAttributes a b
GCForeground Pixel
shine] forall a b. (a -> b) -> a -> b
$ \GCId
shineGC ->
let dRAW :: Point -> Bool -> [XCommand]
dRAW Point
s Bool
pressed =
let lrc :: Point
lrc@(Point Int
w Int
h) = Point
s
e :: Int
e = Int
edgew
ulc :: Point
ulc = Point
origin
urc :: Point
urc = Int -> Int -> Point
pP Int
w Int
0
llc :: Point
llc = Int -> Int -> Point
pP Int
0 Int
h
uli :: Point
uli = Int -> Int -> Point
pP Int
e Int
e
lli :: Point
lli = Int -> Int -> Point
pP Int
e (Int
h forall a. Num a => a -> a -> a
- Int
edgew)
lri :: Point
lri = Int -> Int -> Point
pP (Int
w forall a. Num a => a -> a -> a
- Int
edgew) (Int
h forall a. Num a => a -> a -> a
- Int
edgew)
uri :: Point
uri = Int -> Int -> Point
pP (Int
w forall a. Num a => a -> a -> a
- Int
edgew) Int
e
upper :: [Point]
upper = [Point
ulc, Point
urc, Point
uri, Point
uli, Point
lli, Point
llc]
lower :: [Point]
lower = [Point
llc, Point
lrc, Point
urc, Point
uri, Point
lri, Point
lli]
(GCId
upperGC, GCId
lowerGC) = (if Bool
pressed
then forall {b} {a}. (b, a) -> (a, b)
swap
else forall a. a -> a
id) (GCId
shineGC, GCId
shadowGC)
in [XCommand
ClearWindow,
Drawable -> [(GCId, [DrawCommand])] -> XCommand
DrawMany Drawable
MyWindow [
(GCId
lowerGC,[Shape -> CoordMode -> [Point] -> DrawCommand
FillPolygon Shape
Nonconvex CoordMode
CoordModeOrigin [Point]
lower]),
(GCId
upperGC,[Shape -> CoordMode -> [Point] -> DrawCommand
FillPolygon Shape
Nonconvex CoordMode
CoordModeOrigin [Point]
upper])]]
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
draw :: Bool -> [XCommand]
draw = Point -> Bool -> [XCommand]
dRAW Point
size
redraw :: [XCommand]
redraw = Bool -> [XCommand]
draw Bool
pressed
in case KEvent Bool
bmsg of
Low (XEvt (Expose Rect
_ Int
0)) -> forall {i} {o}. [XCommand] -> K i o -> K i o
xcommandsK [XCommand]
redraw K Bool ho
same
Low (LEvt (LayoutSize Point
newsize)) ->
if Point
newsizeforall a. Eq a => a -> a -> Bool
==Point
size
then K Bool ho
same
else forall {i} {o}. [XCommand] -> K i o -> K i o
xcommandsK (Point -> Bool -> [XCommand]
dRAW Point
newsize Bool
pressed) forall a b. (a -> b) -> a -> b
$
Bool -> Point -> K Bool ho
proc Bool
pressed Point
newsize
High Bool
change -> forall {i} {o}. [XCommand] -> K i o -> K i o
xcommandsK (Bool -> [XCommand]
draw 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
down