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 Bool -> Int -> F a b -> F (Either Bool a) b
forall a b. Bool -> Int -> F a b -> F (Either Bool a) b
newBorder3dF
else Bool -> Int -> F a b -> F (Either Bool a) b
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 :: Bool -> Int -> F a b -> F (Either Bool a) b
newBorder3dF Bool
down Int
edgew F a b
f =
Either b b -> b
forall p. Either p p -> p
stripEither (Either b b -> b)
-> F (Either Bool a) (Either b b) -> F (Either Bool a) b
forall a b e. (a -> b) -> F e a -> F e b
>^=< (([FRequest] -> K Bool b -> F a b -> F (Either Bool 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 Bool b
forall b. K Bool b
kernel (F a b -> F (Either Bool a) (Either b b))
-> (F a b -> F a b) -> F a b -> F (Either Bool a) (Either b b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> F a b -> F a b
forall a b. Int -> F a b -> F a b
marginF Int
edgew) F a b
f)
where
startcmds :: [FRequest]
startcmds =
[XCommand -> FRequest
XCmd (XCommand -> FRequest) -> XCommand -> FRequest
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 =
GCtx -> [GCAttributes a1 a2] -> (GCtx -> f i o) -> f i o
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 FontData
forall a. HasCallStack => a
undefined) [GCAttributes a1 a2]
gcas ((GCtx -> f i o) -> f i o) -> (GCtx -> f i o) -> f i o
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 = GCId -> [GCAttributes a1 FontSpec] -> (GCId -> f i o) -> f i o
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 ([GCAttributes a1 FontSpec] -> (GCId -> f i o) -> f i o)
-> [GCAttributes a1 FontSpec] -> (GCId -> f i o) -> f i o
forall a b. (a -> b) -> a -> b
$ a1 -> [GCAttributes a1 FontSpec]
forall c. c -> [GCAttributes c FontSpec]
gcFgA a1
x
kernel :: K Bool b
kernel =
ColorName -> K Bool b -> K Bool b
forall a b. ColorName -> K a b -> K a b
changeBg ColorName
bgColor (K Bool b -> K Bool b) -> K Bool b -> K Bool b
forall a b. (a -> b) -> a -> b
$
ColorName -> (GCId -> K Bool b) -> K Bool b
forall a1 (f :: * -> * -> *) i o.
(ColorGen a1, FudgetIO f, Show a1) =>
a1 -> (GCId -> f i o) -> f i o
gcFg ColorName
shineColor ((GCId -> K Bool b) -> K Bool b) -> (GCId -> K Bool b) -> K Bool b
forall a b. (a -> b) -> a -> b
$ \ GCId
whiteGC ->
ColorName -> (GCId -> K Bool b) -> K Bool b
forall a1 (f :: * -> * -> *) i o.
(ColorGen a1, FudgetIO f, Show a1) =>
a1 -> (GCId -> f i o) -> f i o
gcFg ColorName
"black" ((GCId -> K Bool b) -> K Bool b) -> (GCId -> K Bool b) -> K Bool b
forall a b. (a -> b) -> a -> b
$ \ GCId
blackGC ->
[ColorName] -> (GCId -> K Bool b) -> K Bool b
forall a1 (f :: * -> * -> *) i o.
(ColorGen a1, FudgetIO f, Show a1) =>
a1 -> (GCId -> f i o) -> f i o
gcFg [ColorName
shadowColor,ColorName
"black"] ((GCId -> K Bool b) -> K Bool b) -> (GCId -> K Bool b) -> K Bool b
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
sPoint -> Point -> Point
forall 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
llcPoint -> Point -> Point
forall a. Num a => a -> a -> a
+Point
nw; lri :: Point
lri = Point
lrcPoint -> Point -> Point
forall a. Num a => a -> a -> a
-Point
1; uri :: Point
uri = Point
urcPoint -> Point -> Point
forall 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 [
GCId -> [Point] -> (GCId, [DrawCommand])
forall a. a -> [Point] -> (a, [DrawCommand])
drawlines GCId
shadowGC [Point]
dls,
GCId -> [Point] -> (GCId, [DrawCommand])
forall a. a -> [Point] -> (a, [DrawCommand])
drawlines GCId
whiteGC [Point]
wls,
GCId -> [Point] -> (GCId, [DrawCommand])
forall a. a -> [Point] -> (a, [DrawCommand])
drawlines GCId
blackGC [Point]
bls]]
proc :: Bool -> Point -> K Bool o
proc Bool
pressed Point
size =
Cont (K Bool o) (KEvent Bool)
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont (K Bool o) (KEvent Bool) -> Cont (K Bool o) (KEvent Bool)
forall a b. (a -> b) -> a -> b
$ \KEvent Bool
bmsg ->
let same :: K Bool o
same = Bool -> Point -> K Bool o
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)) -> [XCommand] -> K Bool o -> K Bool o
forall i o. [XCommand] -> K i o -> K i o
xcommandsK [XCommand]
redraw K Bool o
same
Low (LEvt (LayoutSize Point
newsize)) | Point
newsizePoint -> Point -> Bool
forall a. Eq a => a -> a -> Bool
/=Point
size ->
[XCommand] -> K Bool o -> K Bool o
forall i o. [XCommand] -> K i o -> K i o
xcommandsK (Point -> Bool -> [XCommand]
dRAW Point
newsize Bool
pressed) (K Bool o -> K Bool o) -> K Bool o -> K Bool o
forall a b. (a -> b) -> a -> b
$
Bool -> Point -> K Bool o
proc Bool
pressed Point
newsize
High Bool
change | Bool
changeBool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/=Bool
pressed ->
[XCommand] -> K Bool o -> K Bool o
forall i o. [XCommand] -> K i o -> K i o
xcommandsK (Bool -> [XCommand]
draw Bool
change) (Bool -> Point -> K Bool o
proc Bool
change Point
size)
KEvent Bool
_ -> K Bool o
same
proc0 :: Bool -> K Bool ho
proc0 Bool
pressed =
Cont (K Bool ho) (KEvent Bool)
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont (K Bool ho) (KEvent Bool) -> Cont (K Bool ho) (KEvent Bool)
forall a b. (a -> b) -> a -> b
$ \KEvent Bool
msg ->
case KEvent Bool
msg of
Low (LEvt (LayoutSize Point
size)) -> Bool -> Point -> K Bool ho
forall o. Bool -> Point -> K Bool o
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 Bool -> K Bool b
forall ho. Bool -> K Bool ho
proc0 Bool
down
oldBorder3dF :: Bool -> Int -> F a b -> F (Either Bool a) b
oldBorder3dF :: Bool -> Int -> F a b -> F (Either Bool a) b
oldBorder3dF Bool
down Int
edgew F a b
f =
Either b b -> b
forall p. Either p p -> p
stripEither (Either b b -> b)
-> F (Either Bool a) (Either b b) -> F (Either Bool a) b
forall a b e. (a -> b) -> F e a -> F e b
>^=< (([FRequest] -> K Bool b -> F a b -> F (Either Bool 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 Bool b
forall b. K Bool b
kernel (F a b -> F (Either Bool a) (Either b b))
-> (F a b -> F a b) -> F a b -> F (Either Bool a) (Either b b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> F a b -> F a b
forall a b. Int -> F a b -> F a b
marginF Int
edgew) F a b
f)
where
startcmds :: [FRequest]
startcmds =
[XCommand -> FRequest
XCmd (XCommand -> FRequest) -> XCommand -> FRequest
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 =
ColorName -> K Bool b -> K Bool b
forall a b. ColorName -> K a b -> K a b
changeBg ColorName
bgColor (K Bool b -> K Bool b) -> K Bool b -> K Bool b
forall a b. (a -> b) -> a -> b
$
ColormapId -> ColorName -> Cont (K Bool b) Pixel
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> ColorName -> Cont (f b ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap ColorName
shineColor Cont (K Bool b) Pixel -> Cont (K Bool b) Pixel
forall a b. (a -> b) -> a -> b
$ \Pixel
shine ->
ColormapId -> ColorName -> Cont (K Bool b) Pixel
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> ColorName -> Cont (f b ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap ColorName
shadowColor Cont (K Bool b) Pixel -> Cont (K Bool b) Pixel
forall a b. (a -> b) -> a -> b
$ \Pixel
shadow ->
GCId
-> [GCAttributes Pixel FontId] -> (GCId -> K Bool b) -> K Bool b
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
GCId -> [GCAttributes Pixel FontId] -> (GCId -> f b ho) -> f b ho
wCreateGC GCId
rootGC [GCFunction -> GCAttributes Pixel FontId
forall a b. GCFunction -> GCAttributes a b
GCFunction GCFunction
GXcopy,
Pixel -> GCAttributes Pixel FontId
forall a b. a -> GCAttributes a b
GCForeground Pixel
shadow] ((GCId -> K Bool b) -> K Bool b) -> (GCId -> K Bool b) -> K Bool b
forall a b. (a -> b) -> a -> b
$ \GCId
shadowGC ->
GCId
-> [GCAttributes Pixel FontId] -> (GCId -> K Bool b) -> K Bool b
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
GCId -> [GCAttributes Pixel FontId] -> (GCId -> f b ho) -> f b ho
wCreateGC GCId
shadowGC [Pixel -> GCAttributes Pixel FontId
forall a b. a -> GCAttributes a b
GCForeground Pixel
shine] ((GCId -> K Bool b) -> K Bool b) -> (GCId -> K Bool b) -> K Bool b
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
edgew)
lri :: Point
lri = Int -> Int -> Point
pP (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
edgew) (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
edgew)
uri :: Point
uri = Int -> Int -> Point
pP (Int
w Int -> Int -> Int
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 (GCId, GCId) -> (GCId, GCId)
forall b a. (b, a) -> (a, b)
swap
else (GCId, GCId) -> (GCId, GCId)
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 o
proc Bool
pressed Point
size =
Cont (K Bool o) (KEvent Bool)
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont (K Bool o) (KEvent Bool) -> Cont (K Bool o) (KEvent Bool)
forall a b. (a -> b) -> a -> b
$ \KEvent Bool
bmsg ->
let same :: K Bool o
same = Bool -> Point -> K Bool o
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)) -> [XCommand] -> K Bool o -> K Bool o
forall i o. [XCommand] -> K i o -> K i o
xcommandsK [XCommand]
redraw K Bool o
same
Low (LEvt (LayoutSize Point
newsize)) ->
if Point
newsizePoint -> Point -> Bool
forall a. Eq a => a -> a -> Bool
==Point
size
then K Bool o
same
else [XCommand] -> K Bool o -> K Bool o
forall i o. [XCommand] -> K i o -> K i o
xcommandsK (Point -> Bool -> [XCommand]
dRAW Point
newsize Bool
pressed) (K Bool o -> K Bool o) -> K Bool o -> K Bool o
forall a b. (a -> b) -> a -> b
$
Bool -> Point -> K Bool o
proc Bool
pressed Point
newsize
High Bool
change -> [XCommand] -> K Bool o -> K Bool o
forall i o. [XCommand] -> K i o -> K i o
xcommandsK (Bool -> [XCommand]
draw Bool
change) (Bool -> Point -> K Bool o
proc Bool
change Point
size)
KEvent Bool
_ -> K Bool o
same
proc0 :: Bool -> K Bool ho
proc0 Bool
pressed =
Cont (K Bool ho) (KEvent Bool)
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont (K Bool ho) (KEvent Bool) -> Cont (K Bool ho) (KEvent Bool)
forall a b. (a -> b) -> a -> b
$ \KEvent Bool
msg ->
case KEvent Bool
msg of
Low (LEvt (LayoutSize Point
size)) -> Bool -> Point -> K Bool ho
forall o. Bool -> Point -> K Bool o
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 Bool -> K Bool b
forall ho. Bool -> K Bool ho
proc0 Bool
down