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 :: Int -> F a b -> F (Either Bool a) b
buttonBorderF = if Bool
look3d then Bool -> Int -> F a b -> F (Either Bool a) b
forall a b. Bool -> Int -> F a b -> F (Either Bool a) b
border3dF Bool
False else Int -> F a b -> F (Either Bool a) b
forall c b. Int -> F c b -> F (Either Bool c) 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 =
          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 -> ColorName -> (Pixel -> K Bool b) -> K Bool b
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> ColorName -> ColorName -> (Pixel -> f b ho) -> f b ho
allocNamedColorDefPixel ColormapId
defaultColormap ColorName
shineColor ColorName
"white" ((Pixel -> K Bool b) -> K Bool b)
-> (Pixel -> K Bool b) -> K Bool b
forall a b. (a -> b) -> a -> b
$ \Pixel
shine->
	  ColormapId
-> ColorName -> ColorName -> (Pixel -> K Bool b) -> K Bool b
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> ColorName -> ColorName -> (Pixel -> f b ho) -> f b ho
allocNamedColorDefPixel ColormapId
defaultColormap ColorName
shadowColor ColorName
"black" ((Pixel -> K Bool b) -> K Bool b)
-> (Pixel -> K Bool b) -> K Bool b
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,
			    Pixel -> GCAttributes Pixel FontId
forall a b. a -> GCAttributes a b
GCBackground Pixel
shine] ((GCId -> K Bool b) -> K Bool b) -> (GCId -> K Bool b) -> K Bool b
forall a b. (a -> b) -> a -> b
$ \GCId
drawGC ->
	  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
drawGC [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 ->
	  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 (Pixel -> Pixel -> [GCAttributes Pixel FontId]
forall b. Pixel -> Pixel -> [GCAttributes Pixel b]
invertColorGCattrs Pixel
shine Pixel
shadow) ((GCId -> K Bool b) -> K Bool b) -> (GCId -> K Bool b) -> K Bool b
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bpx) Int
bpy
		     lowerLeftCorner :: Point
lowerLeftCorner = Int -> Int -> Point
Point Int
bpx (Int
sy Int -> Int -> Int
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 (Point -> Point) -> (Point -> Point) -> Point -> Point
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 (DrawCommand -> XCommand) -> DrawCommand -> XCommand
forall a b. (a -> b) -> a -> b
$ Shape -> CoordMode -> [Point] -> DrawCommand
FillPolygon Shape
Nonconvex 
				  CoordMode
CoordModeOrigin [Point]
borderPoints])
	      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
		      ([XCommand]
drawit_size, [XCommand]
pressit_size) = Point -> ([XCommand], [XCommand])
dRAW Point
size
		      redraw :: Bool -> [XCommand]
redraw Bool
b = if Bool
b Bool -> Bool -> Bool
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)) -> [XCommand] -> K Bool o -> K Bool o
forall i o. [XCommand] -> K i o -> K i o
xcommandsK ([XCommand]
drawit_size [XCommand] -> [XCommand] -> [XCommand]
forall a. [a] -> [a] -> [a]
++ 
			    (if Bool
pressed then [XCommand]
pressit_size else [])) K Bool o
same
			Low (LEvt (LayoutSize Point
newsize)) -> 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]
redraw 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
False

        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]]]
    in  Either b b -> b
forall p. Either p p -> p
stripEither (Either b b -> b)
-> F (Either Bool c) (Either b b) -> F (Either Bool c) b
forall a b e. (a -> b) -> F e a -> F e b
>^=< (([FRequest] -> K Bool b -> F c b -> F (Either Bool c) (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 c b -> F (Either Bool c) (Either b b))
-> (F c b -> F c b) -> F c b -> F (Either Bool c) (Either b b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> F c b -> F c b
forall a b. Int -> F a b -> F a b
marginF (Int
edgew Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) F c b
f)