module ButtonBorderF(buttonBorderF) where
--import BgF
import Border3dF
--import ButtonGroupF
import Color
import Command(XCommand(ChangeWindowAttributes,ClearArea,DrawMany,Draw))
import XDraw
import CompOps((>^=<))
import Defaults(look3d, shadowColor, shineColor,bgColor)
import Dlayout(groupF)
import Event
import Fudget
--import FudgetIO
import FRequest
import Xcommand
import Gc
import Geometry(Line(..), Point(..), Rect(..), origin, pP, padd, psub)
import LayoutRequest
--import Message(Message(..))
import NullF
import Spacer(marginF)
import EitherUtils(stripEither)
import Xtypes
import GreyBgF(changeBg)

buttonBorderF :: Int -> F a b -> F (Either Bool a) b
buttonBorderF :: forall a b. Int -> F a b -> F (Either Bool a) b
buttonBorderF = if Bool
look3d then forall {a} {b}. Bool -> Int -> F a b -> F (Either Bool a) b
border3dF Bool
False else forall a b. Int -> F a b -> F (Either Bool a) b
stdButtonBorderF

stdButtonBorderF :: Int -> F c b -> F (Either Bool c) b
stdButtonBorderF Int
edgew F c b
f =
    let 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 -> ColorName -> (Pixel -> f hi ho) -> f hi ho
allocNamedColorDefPixel ColormapId
defaultColormap ColorName
shineColor ColorName
"white" forall a b. (a -> b) -> a -> b
$ \Pixel
shine->
	  forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId
-> ColorName -> ColorName -> (Pixel -> f hi ho) -> f hi ho
allocNamedColorDefPixel ColormapId
defaultColormap ColorName
shadowColor ColorName
"black" 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 -> GCAttributes a b
GCBackground Pixel
shine] forall a b. (a -> b) -> a -> b
$ \GCId
drawGC ->
	  forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
GCId -> GCAttributeList -> (GCId -> f hi ho) -> f hi ho
wCreateGC GCId
drawGC [forall a b. a -> GCAttributes a b
GCForeground Pixel
shine] forall a b. (a -> b) -> a -> b
$ \GCId
shineGC ->
	  forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
GCId -> GCAttributeList -> (GCId -> f hi ho) -> f hi ho
wCreateGC GCId
rootGC (forall {b}. Pixel -> Pixel -> [GCAttributes Pixel b]
invertColorGCattrs Pixel
shine Pixel
shadow) forall a b. (a -> b) -> a -> b
$ \GCId
invertGC ->
	  let bpx :: Int
bpx = Int
edgew
	      bpy :: Int
bpy = Int
edgew
	      upperLeftCorner :: Point
upperLeftCorner = Int -> Int -> Point
Point Int
bpx Int
bpy
	      dRAW :: Point -> ([XCommand], [XCommand])
dRAW Point
s = 
		 let size :: Point
size@(Point Int
sx Int
sy) = Point -> Point -> Point
psub Point
s (Int -> Int -> Point
Point Int
1 Int
1)
		     rect :: Rect
rect = Point -> Point -> Rect
Rect Point
origin Point
size
		     upperRightCorner :: Point
upperRightCorner = Int -> Int -> Point
Point (Int
sx forall a. Num a => a -> a -> a
- Int
bpx) Int
bpy
		     lowerLeftCorner :: Point
lowerLeftCorner = Int -> Int -> Point
Point Int
bpx (Int
sy forall a. Num a => a -> a -> a
- Int
bpy)
		     lowerRightCorner :: Point
lowerRightCorner = Point -> Point -> Point
psub Point
size Point
upperLeftCorner
		     leftBorder :: Line
leftBorder = Point -> Point -> Line
Line Point
upperLeftCorner Point
lowerLeftCorner
		     upperBorder :: Line
upperBorder = Point -> Point -> Line
Line Point
upperLeftCorner Point
upperRightCorner
		     upperLeftLine :: Line
upperLeftLine = Point -> Point -> Line
Line Point
origin Point
upperLeftCorner
		     lowerRightLine :: Line
lowerRightLine = Point -> Point -> Line
Line Point
lowerRightCorner Point
size
		     incx :: Point -> Point
incx = Point -> Point -> Point
padd (Int -> Int -> Point
Point Int
1 Int
0)
		     incy :: Point -> Point
incy = Point -> Point -> Point
padd (Int -> Int -> Point
Point Int
0 Int
1)
		     decx :: Point -> Point
decx = Point -> Point -> Point
padd (Int -> Int -> Point
Point (-Int
1) Int
0)
		     decy :: Point -> Point
decy = Point -> Point -> Point
padd (Int -> Int -> Point
Point Int
0 (-Int
1))
		     lowerBorderPoints :: [Point]
lowerBorderPoints = [Point
lowerLeftCorner, Point
lowerRightCorner, 
					  Point
upperRightCorner, Int -> Int -> Point
Point Int
sx Int
0, Point
size, Int -> Int -> Point
Point Int
0 Int
sy]
		     borderPoints :: [Point]
borderPoints =
		       [Int -> Int -> Point
pP Int
1 Int
1, Int -> Int -> Point
pP Int
1 Int
sy, Point
size, Int -> Int -> Point
pP Int
sx Int
1, Point
origin, Point
upperLeftCorner, 
		        Point -> Point
incy Point
lowerLeftCorner, (Point -> Point
incx forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Point
incy) Point
lowerRightCorner, 
			Point -> Point
incx Point
upperRightCorner, Point
upperLeftCorner]
		 in  ( [Rect -> Bool -> XCommand
ClearArea Rect
rect Bool
False, 
		        Drawable -> [(GCId, [DrawCommand])] -> XCommand
DrawMany Drawable
MyWindow [
			  (GCId
shineGC,[Shape -> CoordMode -> [Point] -> DrawCommand
FillPolygon Shape
Nonconvex CoordMode
CoordModeOrigin
			            [Point]
borderPoints]),
			  (GCId
drawGC,[Shape -> CoordMode -> [Point] -> DrawCommand
FillPolygon Shape
Nonconvex CoordMode
CoordModeOrigin 
			           [Point]
lowerBorderPoints, 
			           Line -> DrawCommand
DrawLine Line
leftBorder, 
			           Line -> DrawCommand
DrawLine Line
upperBorder, 
			           Line -> DrawCommand
DrawLine Line
upperLeftLine]), 
			  (GCId
invertGC,[Line -> DrawCommand
DrawLine Line
lowerRightLine]), 
			  (GCId
drawGC,[Rect -> DrawCommand
DrawRectangle Rect
rect])]], 
			 [Drawable -> GCId -> DrawCommand -> XCommand
Draw Drawable
MyWindow GCId
invertGC forall a b. (a -> b) -> a -> b
$ Shape -> CoordMode -> [Point] -> DrawCommand
FillPolygon Shape
Nonconvex 
				  CoordMode
CoordModeOrigin [Point]
borderPoints])
	      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
		      ([XCommand]
drawit_size, [XCommand]
pressit_size) = Point -> ([XCommand], [XCommand])
dRAW Point
size
		      redraw :: Bool -> [XCommand]
redraw Bool
b = if Bool
b forall a. Eq a => a -> a -> Bool
== Bool
pressed then [] else [XCommand]
pressit_size
		  in  case KEvent Bool
bmsg of
			Low (XEvt (Expose Rect
_ Int
0)) -> forall {i} {o}. [XCommand] -> K i o -> K i o
xcommandsK ([XCommand]
drawit_size forall a. [a] -> [a] -> [a]
++ 
			    (if Bool
pressed then [XCommand]
pressit_size else [])) K Bool ho
same
			Low (LEvt (LayoutSize Point
newsize)) -> 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]
redraw 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
False

        startcmds :: [FRequest]
startcmds = [XCommand -> FRequest
XCmd forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [[EventMask] -> WindowAttributes
CWEventMask [EventMask
ExposureMask]]]
    in  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 forall a. Num a => a -> a -> a
+ Int
1)) F c b
f)