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)