module Border3dF(border3dF) where
--import ButtonGroupF
import Color
import Command
import XDraw
import CompOps((>^=<))
import Defaults(bgColor, shadowColor, shineColor,new3d)
--import CmdLineEnv(argFlag)
import Dlayout(groupF)
import Event
import Fudget
--import FudgetIO
import FRequest
import Xcommand
import Gc
import Geometry(Point(..), origin, pP)
import GreyBgF(changeBg)
import LayoutRequest
--import Message(Message(..))
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]]
				      -- bit gravity reduces flicker on resize

    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
$ 
		     -- redraw needed here because of bit gravity
		     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]]
				      -- bitgravity reduces flicker on resize
    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	-- pP (w - 1) 0
		llc :: Point
llc = Int -> Int -> Point
pP Int
0 Int
h	-- pP 0 (h - 1)
		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
$ 
			  -- redraw needed here because of bit gravity
			  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