module BitmapF (bitmapButtonF, bitmapDispF, bitmapDispBorderF) where
import AllFudgets

windowKernel :: [Char] -> K BitmapReturn ho
windowKernel [Char]
filename =
  ColormapId -> [Char] -> Cont (K BitmapReturn ho) Pixel
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> [Char] -> Cont (f b ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap [Char]
"black" Cont (K BitmapReturn ho) Pixel -> Cont (K BitmapReturn ho) Pixel
forall a b. (a -> b) -> a -> b
$ \Pixel
fg ->
  ColormapId -> [Char] -> Cont (K BitmapReturn ho) Pixel
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> [Char] -> Cont (f b ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap [Char]
"white" Cont (K BitmapReturn ho) Pixel -> Cont (K BitmapReturn ho) Pixel
forall a b. (a -> b) -> a -> b
$ \Pixel
bg ->
  [Char] -> K BitmapReturn ho -> K BitmapReturn ho
forall a i o. (Show a, ColorGen a) => a -> K i o -> K i o
changeBackPixel [Char]
"white" (K BitmapReturn ho -> K BitmapReturn ho)
-> K BitmapReturn ho -> K BitmapReturn ho
forall a b. (a -> b) -> a -> b
$
  GCId
-> [GCAttributes Pixel FontId]
-> (GCId -> K BitmapReturn ho)
-> K BitmapReturn ho
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
fg,
                    Pixel -> GCAttributes Pixel FontId
forall a b. a -> GCAttributes a b
GCBackground Pixel
bg,
                    Bool -> GCAttributes Pixel FontId
forall a b. Bool -> GCAttributes a b
GCGraphicsExposures Bool
False] ((GCId -> K BitmapReturn ho) -> K BitmapReturn ho)
-> (GCId -> K BitmapReturn ho) -> K BitmapReturn ho
forall a b. (a -> b) -> a -> b
$ \GCId
drawGC ->
  let displayImage :: Point -> PixmapId -> K BitmapReturn ho
displayImage Point
size PixmapId
bitmapid =
        Point
-> Int -> (PixmapId -> K BitmapReturn ho) -> K BitmapReturn ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
Point -> Int -> (PixmapId -> f b ho) -> f b ho
createPixmap Point
size Int
copyFromParent (\PixmapId
pixmapid ->
          [KCommand ho] -> K BitmapReturn ho -> K BitmapReturn ho
forall b a. [KCommand b] -> K a b -> K a b
putsK [FRequest -> KCommand ho
forall a b. a -> Message a b
Low (PixmapId -> GCId -> Drawable -> Rect -> Point -> Int -> FRequest
pmCopyPlane PixmapId
pixmapid GCId
drawGC (PixmapId -> Drawable
Pixmap PixmapId
bitmapid) 
                    (Point -> Point -> Rect
Rect (Int -> Int -> Point
Point Int
0 Int
0) Point
size) (Int -> Int -> Point
Point Int
0 Int
0) Int
0),
                XCommand -> KCommand ho
forall b. XCommand -> Message FRequest b
lxcmd ([WindowAttributes] -> XCommand
ChangeWindowAttributes [PixmapId -> WindowAttributes
CWBackPixmap PixmapId
pixmapid]),
                XCommand -> KCommand ho
forall b. XCommand -> Message FRequest b
lxcmd (PixmapId -> XCommand
FreePixmap PixmapId
bitmapid),
                XCommand -> KCommand ho
forall b. XCommand -> Message FRequest b
lxcmd (PixmapId -> XCommand
FreePixmap PixmapId
pixmapid),
                FRequest -> KCommand ho
forall a b. a -> Message a b
Low (LayoutRequest -> FRequest
layoutRequestCmd (Point -> Bool -> Bool -> LayoutRequest
plainLayout Point
size Bool
True Bool
True)),
                XCommand -> KCommand ho
forall b. XCommand -> Message FRequest b
lxcmd XCommand
ClearWindow] 
               K BitmapReturn ho
displayproc)
      lxcmd :: XCommand -> Message FRequest b
lxcmd = FRequest -> Message FRequest b
forall a b. a -> Message a b
Low (FRequest -> Message FRequest b)
-> (XCommand -> FRequest) -> XCommand -> Message FRequest b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XCommand -> FRequest
XCmd
      displayproc :: K BitmapReturn ho
displayproc =
        Cont (K BitmapReturn ho) (KEvent BitmapReturn)
forall hi ho. Cont (K hi ho) (KEvent hi)
getK (\KEvent BitmapReturn
msg ->
          case KEvent BitmapReturn
msg of
            Low (XEvt (Expose Rect
_ Int
0)) -> XCommand -> K BitmapReturn ho -> K BitmapReturn ho
forall i o. XCommand -> K i o -> K i o
xcommandK XCommand
ClearWindow K BitmapReturn ho
displayproc 
            High BitmapReturn
BitmapBad -> [Char] -> K BitmapReturn ho
forall a. HasCallStack => [Char] -> a
error ([Char]
"Invalid bitmap file")
            High (BitmapReturn Point
size Maybe Point
_ PixmapId
bitmapid) -> Point -> PixmapId -> K BitmapReturn ho
displayImage Point
size PixmapId
bitmapid
            KEvent BitmapReturn
_ -> K BitmapReturn ho
displayproc)
  in [Char] -> (BitmapReturn -> K BitmapReturn ho) -> K BitmapReturn ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
[Char] -> (BitmapReturn -> f b ho) -> f b ho
readBitmapFile [Char]
filename (\BitmapReturn
bmr ->
       case BitmapReturn
bmr of
         BitmapReturn
BitmapBad -> [Char] -> K BitmapReturn ho
forall a. HasCallStack => [Char] -> a
error ([Char]
"Invalid bitmap file " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
filename)
         BitmapReturn Point
size Maybe Point
_ PixmapId
bitmapid -> Point -> PixmapId -> K BitmapReturn ho
forall ho. Point -> PixmapId -> K BitmapReturn ho
displayImage Point
size PixmapId
bitmapid)

bitmapDispF :: FilePath -> F BitmapReturn a
bitmapDispF :: [Char] -> F BitmapReturn a
bitmapDispF [Char]
filename =
  let wattrs :: [WindowAttributes]
wattrs = [BackingStore -> WindowAttributes
CWBackingStore BackingStore
WhenMapped, [EventMask] -> WindowAttributes
CWEventMask [EventMask
ExposureMask]]
      kernelF :: F BitmapReturn b
kernelF =  [FRequest] -> K BitmapReturn b -> F BitmapReturn b
forall a b. [FRequest] -> K a b -> F a b
windowF ([XCommand -> FRequest
XCmd (XCommand -> FRequest) -> XCommand -> FRequest
forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [WindowAttributes]
wattrs])
                         ([Char] -> K BitmapReturn b
forall ho. [Char] -> K BitmapReturn ho
windowKernel [Char]
filename)
  in Int
-> Alignment -> Alignment -> F BitmapReturn a -> F BitmapReturn a
forall a b. Int -> Alignment -> Alignment -> F a b -> F a b
marginHVAlignF Int
0 Alignment
aCenter Alignment
aCenter F BitmapReturn a
forall b. F BitmapReturn b
kernelF

bitmapDispBorderF :: Int -> FilePath -> F BitmapReturn a
bitmapDispBorderF :: Int -> [Char] -> F BitmapReturn a
bitmapDispBorderF Int
width [Char]
filename =
  let wattrs :: [WindowAttributes]
wattrs = [BackingStore -> WindowAttributes
CWBackingStore BackingStore
WhenMapped, [EventMask] -> WindowAttributes
CWEventMask [EventMask
ExposureMask]]
      kernelF :: F BitmapReturn b
kernelF = [FRequest] -> K BitmapReturn b -> F BitmapReturn b
forall a b. [FRequest] -> K a b -> F a b
windowF [XCommand -> FRequest
XCmd ([WindowAttributes] -> XCommand
ChangeWindowAttributes [WindowAttributes]
wattrs),
                         XCommand -> FRequest
XCmd ([WindowChanges] -> XCommand
ConfigureWindow [Int -> WindowChanges
CWBorderWidth Int
width])]
                         ([Char] -> K BitmapReturn b
forall ho. [Char] -> K BitmapReturn ho
windowKernel [Char]
filename)
  in Int
-> Alignment -> Alignment -> F BitmapReturn a -> F BitmapReturn a
forall a b. Int -> Alignment -> Alignment -> F a b -> F a b
marginHVAlignF Int
0 Alignment
aCenter Alignment
aCenter F BitmapReturn a
forall b. F BitmapReturn b
kernelF

bitmapButtonF :: [(ModState, [Char])] -> [Char] -> F BitmapReturn Click
bitmapButtonF [(ModState, [Char])]
keys [Char]
filename =
  let kernelF :: F BitmapReturn a
kernelF = Int -> [Char] -> F BitmapReturn a
forall a. Int -> [Char] -> F BitmapReturn a
bitmapDispBorderF Int
0 [Char]
filename 
  in Either Any Click -> Click
forall a b. Either a b -> b
fromRight (Either Any Click -> Click)
-> F BitmapReturn (Either Any Click) -> F BitmapReturn Click
forall a b e. (a -> b) -> F e a -> F e b
>^=< ([(ModState, [Char])]
-> F BitmapReturn Any -> F BitmapReturn (Either Any Click)
forall b1 b2.
[(ModState, [Char])] -> F b1 b2 -> F b1 (Either b2 Click)
pushButtonF [(ModState, [Char])]
keys F BitmapReturn Any
forall b. F BitmapReturn b
kernelF)