{-# LANGUAGE CPP #-}
module GraphicsF(GraphicsF,setCursorSolid,setGfxEventMask,
setAdjustSize,setCursor,setDoubleBuffer,
graphicsF,graphicsF',
graphicsGroupF,graphicsGroupF',
graphicsDispGroupF,graphicsDispGroupF',
graphicsLabelF,graphicsLabelF',
graphicsDispF,graphicsDispF',
GfxEventMask(..),GfxChange(..),GfxCommand(..),GfxEvent(..),
GfxFCmd,GfxFEvent,
replaceGfx,replaceAllGfx,showGfx,highlightGfx) where
import Fudget
import FudgetIO
import Xcommand
import FRequest
import NullF(putK,putsK,getK,nullF)
import Spops(nullSP)
import CompSP(postMapSP)
import SpEither(filterLeftSP)--mapFilterSP
--import SerCompF(stubF)
import Command
import DrawInPixmap(pmFillRectangle,pmDrawPoint)
--import DrawInWindow(wCopyArea)
import Event
import Xtypes
import Geometry
import Gc
import Pixmap
import Cursor
--import Color
--import Font(font_id,string_box_size)
--import LoadFont(safeLoadQueryFont)
import BgF(changeGetBackPixel)
import Defaults(fgColor,bgColor,paperColor,labelFont)
import CmdLineEnv(argFlag,argKeyList,argReadKey)
import LayoutRequest
import Alignment
import Spacers(noStretchS,compS,minSizeS)
import Message
import CompOps
import CompSP(idRightSP)
import Dlayout(groupF)
import Utils(number,pairwith)
import HbcUtils(mapFst,mapSnd)
--import InputMsg
import Graphic
import CompiledGraphics
import MeasuredGraphics(MeasuredGraphics(SpacedM,MarkM),compileMG,DPath(..))--,emptyMG,emptyMG'
import Graphic2Pixmap
import GCtx(GCtx(..),wCreateGCtx,rootGCtx)
import GCAttrs
import MGOps(parentGctx,replaceMGPart,updateMGPart,groupMGParts,ungroupMGParts)
import IdempotSP
import DrawCompiledGraphics
import Rects(intersectRects,overlaps)
import EitherUtils(stripEither)--,mapEither
import Sizing(newSize,Sizing(..))
--import HO(apSnd)
--import Maybe(fromMaybe)
import Xrequest(xrequestK)
import StdIoUtil(echoStderrK)
--import ContinuationIO(stderr)
--import Maptrace(ctrace) -- debugging
import FDefaults
#include "defaults.h"
#include "exists.h"
-- Commands for grapihcsF: ---------------------------------------------------
data GfxChange gfx
= GfxReplace (Bool,Maybe gfx)
| GfxGroup Int Int -- position & length
| GfxUngroup Int -- position
data GfxCommand path gfx
= ChangeGfx [(path,GfxChange gfx)]
| ChangeGfxBg ColorSpec
| ChangeGfxBgPixmap PixmapId Bool -- True = free pixmap
#ifdef USE_EXIST_Q
| EXISTS(bg) TSTHACK((Graphic EQV(bg)) =>) ChangeGfxBgGfx EQV(bg)
#endif
| ChangeGfxCursor CursorId
| ChangeGfxFontCursor Int
| ShowGfx path (Maybe Alignment,Maybe Alignment) -- makes the selected part visible
| BellGfx Int -- sound the bell
| GetGfxPlaces [path] -- ask for rectangles of listed paths
replaceAllGfx = replaceGfx []
replaceGfx path gfx = ChangeGfx [(path,GfxReplace (False,Just gfx))]
showGfx path = ShowGfx path (Nothing,Nothing)
highlightGfx path on = ChangeGfx [(path,GfxReplace (on,Nothing))]
instance Functor GfxChange where
fmap f (GfxReplace r) = GfxReplace (fmap (fmap f) r)
fmap f (GfxGroup from count) = GfxGroup from count
fmap f (GfxUngroup at) = GfxUngroup at
instance Functor (GfxCommand path) where
fmap f cmd =
case cmd of
ChangeGfx changes -> ChangeGfx (mapSnd (fmap f) changes)
-- _ -> cmd -- Operationally, the rest is the same as this line.
ChangeGfxBg c -> ChangeGfxBg c
ChangeGfxBgPixmap pm b -> ChangeGfxBgPixmap pm b
#ifdef USE_EXIST_Q
ChangeGfxBgGfx gfx -> ChangeGfxBgGfx gfx
#endif
ChangeGfxCursor cursor -> ChangeGfxCursor cursor
ChangeGfxFontCursor shape -> ChangeGfxFontCursor shape
ShowGfx path a -> ShowGfx path a
BellGfx n -> BellGfx n
GetGfxPlaces paths -> GetGfxPlaces paths
-- Events from graphicsF: ----------------------------------------------------
data GfxEvent path
= GfxButtonEvent { gfxTime :: Time,
gfxState :: ModState,
gfxType :: Pressed,
gfxButton:: Button,
gfxPaths :: [(path,(Point,Rect))] }
| GfxMotionEvent { gfxTime :: Time,
gfxState :: ModState,
gfxPaths :: [(path,(Point,Rect))] }
| GfxKeyEvent { gfxTime :: Time,
gfxState::ModState,
gfxKeySym::KeySym,
gfxKeyLookup::KeyLookup }
| GfxFocusEvent { gfxHasFocus :: Bool }
| GfxPlaces [Rect] -- response to GetGfxPlaces
| GfxResized Size
deriving (Eq,Show)
-- graphicsF event masks: ----------------------------------------------------
data GfxEventMask = GfxButtonMask | GfxMotionMask | GfxDragMask | GfxKeyMask
allGfxEvents = [GfxButtonMask, GfxMotionMask, GfxDragMask, GfxKeyMask]
gfxMouseMask = [GfxButtonMask, GfxDragMask] -- backward compat
gfxEventMask = concatMap events
where
events GfxButtonMask = buttonmask
events GfxMotionMask = motionmask
events GfxDragMask = dragmask
events GfxKeyMask = keventmask
buttonmask = [ButtonPressMask,ButtonReleaseMask]
motionmask = [PointerMotionMask]
dragmask = [Button1MotionMask]
keventmask =
[KeyPressMask,
EnterWindowMask, LeaveWindowMask -- because of CTT implementation
]
-- Customisers for graphicsF: ------------------------------------------------
newtype GraphicsF gfx = Pars [Pars gfx]
data Pars gfx
-- Standard customisers:
= BorderWidth Int
| BgColorSpec ColorSpec
| FgColorSpec ColorSpec
| FontSpec FontSpec
| Sizing Sizing
| Stretchable (Bool,Bool)
| InitSize gfx
| InitDisp gfx
-- Special customisers:
| CursorSolid Bool
| GfxEventMask [GfxEventMask]
| AdjustSize Bool
| Cursor Int -- pointer cursor shape for XCreateFontCursor
| DoubleBuffer Bool
-- Could also support:
-- | Align Alignment
-- | Spacer Spacer
-- | Margin Int
parameter_instance1(BorderWidth,GraphicsF)
parameter_instance1(BgColorSpec,GraphicsF)
parameter_instance1(FgColorSpec,GraphicsF)
parameter_instance1(Sizing,GraphicsF)
parameter_instance1(FontSpec,GraphicsF)
parameter_instance1(Stretchable,GraphicsF)
parameter_instance(InitSize,GraphicsF)
parameter_instance(InitDisp,GraphicsF)
parameter(CursorSolid)
parameter(GfxEventMask)
parameter(AdjustSize)
parameter(Cursor)
parameter(DoubleBuffer)
-------------------------------------------------------------------------------
type GfxFCmd a = GfxCommand DPath a
type GfxFEvent = GfxEvent DPath
graphicsDispF :: Graphic a => F (GfxFCmd a) (GfxFEvent)
graphicsDispF = graphicsDispF' standard
graphicsLabelF lbl = graphicsLabelF' standard lbl
graphicsLabelF' customiser gfx = nullSP >^^=< d >=^^< nullSP'
where d = graphicsF' (customiser . params)
params = setInitDisp gfx .setGfxEventMask [] . setSizing Static .
setBgColor bgColor . setBorderWidth 0
nullSP' = nullSP -- :: (SP anything (GfxCommand MeasuredGraphics))
-- this is a workaround necessary to resolve the overloading
graphicsDispF' :: Graphic gfx => Customiser (GraphicsF gfx) -> F (GfxFCmd gfx) (GfxFEvent)
graphicsDispF' customiser = graphicsF' (customiser . dispCustomiser)
graphicsDispGroupF fud = graphicsGroupF' dispCustomiser fud
graphicsDispGroupF' customiser fud =
graphicsGroupF' (customiser . dispCustomiser) fud
dispCustomiser =
setCursorSolid True . setGfxEventMask gfxMouseMask . setSizing Growing
graphicsF :: Graphic gfx => F (GfxFCmd gfx) (GfxFEvent)
graphicsF = graphicsF' standard
graphicsF' custom = filterLeftSP >^^=< graphicsGroupF' custom nullF >=^< Left
graphicsGroupF :: Graphic gfx => F i o -> F (Either (GfxFCmd gfx) i) (Either (GfxFEvent) o)
graphicsGroupF = graphicsGroupF' standard
--graphicsGroupF' :: (Graphic init,Graphic gfx => Customiser (GraphicsF init) -> F i o -> F (Either (GfxFCmd gfx) i) (Either (GfxFEvent) o)
graphicsGroupF' :: Graphic gfx => Customiser (GraphicsF gfx) -> F i o -> F (Either (GfxFCmd gfx) i) (Either (GfxFEvent) o)
graphicsGroupF' customiser fud =
let solid = getCursorSolid params
mask = getGfxEventMask params
sizing = getSizing params
adjsize = getAdjustSize params
doublebuffer = getDoubleBuffer params
optcursor = getCursorMaybe params
font = getFontSpec params
bw = getBorderWidth params
bgcol = getBgColorSpec params
fgcol = getFgColorSpec params
optx = getInitDispMaybe params
optstretch = getStretchableMaybe params
optinitsize = getInitSizeMaybe params
params = customiser defaults
defaults = Pars [BorderWidth 1,
BgColorSpec (colorSpec paperColor),
FgColorSpec (colorSpec fgColor),
Sizing Dynamic,
CursorSolid False,
GfxEventMask allGfxEvents,
AdjustSize True,
DoubleBuffer defaultdoublebuffer,
FontSpec (fontSpec labelFont)]
eventmask = ExposureMask:
gfxEventMask mask
--grabmask = [ButtonReleaseMask, PointerMotionMask]
-- NOTE: some code below assumes that motion events occur ONLY
-- while Button1 is pressed!
startcmds = [ChangeWindowAttributes [CWEventMask eventmask,
CWBitGravity NorthWestGravity],
ConfigureWindow [CWBorderWidth bw]--,
--GrabButton False (Button 1) [] grabmask,
--GrabButton False (Button 2) [] [ButtonReleaseMask]
]
in --compMsgSP layoutOptSP (idRightSP idempotSP) `serCompSP`
idRightSP (stripEither `postMapSP` idRightSP idempotSP) >^^=<
groupF (fmap XCmd startcmds)
(initK doublebuffer font optcursor fgcol bgcol $
graphicsK0 solid sizing adjsize optstretch optinitsize optx)
fud
dbeSwapBuffers cont =
xrequestK (DbeSwapBuffers swapaction) Just $ \ (DbeBuffersSwapped _) -> cont
optDoubleBufferK False cont = cont Nothing
optDoubleBufferK True cont =
xrequestK DbeQueryExtension Just $ \ (DbeExtensionQueried status major minor) ->
let ok=status/=0
in if not ok
then echoStderrK "Sorry, double buffering not available." $
cont Nothing
else xrequestK (DbeAllocateBackBufferName swapaction) Just $ \ (DbeBackBufferNameAllocated backbuf) ->
--xcommandK ClearWindow $
cont (Just backbuf)
initK doublebuffer font optcursor fgcol bgcol k =
changeGetBackPixel bgcol $ \ bg ->
maybe id setFontCursor optcursor $
convColorK [fgcol,colorSpec "black"] $ \ fg ->
wCreateGCtx rootGCtx [GCFont [font,fontSpec "fixed"],GCForeground fg,GCBackground bg] $ \ gctx@(GC gc _) ->
wCreateGC rootGC [GCForeground bg] $ \ cleargc ->
createCursorGC gc bg fg $ \ higc ->
optDoubleBufferK doublebuffer $ \ optbackbuf ->
k optbackbuf gctx bg cleargc higc
optCompileGraphicK gctx optgfx cont =
case optgfx of
Nothing -> cont Nothing
Just gfx ->
measureGraphicK gfx gctx $ \ mg ->
cont (Just (mg,compileMG id mg))
graphicsK0 solid sizing adjsize optstretch optinitsize optx optbackbuf gctx bg cleargc higc =
graphicsK1
where
graphicsK1 =
optCompileGraphicK gctx optinitsize $ \ optcgsize ->
optCompileGraphicK gctx optx $ \ optcgx ->
graphicsK2 optcgsize optcgx
graphicsK2 optcgsize optcgx =
graphicsK init
where
optSizeS = fmap (minSizeS . minsize . snd . snd) optcgsize
optStretchS = fmap stretchS optstretch
where stretchS (sh,sv) = noStretchS (not sh) (not sv)
spacerM =
case (optStretchS,optSizeS) of
(Just stretchS,Just sizeS) -> SpacedM (stretchS `compS` sizeS)
(Just stretchS,_ ) -> SpacedM stretchS
(_ ,Just sizeS) -> SpacedM sizeS
_ -> MarkM gctx
-- All incoming and outgoing paths have to be adjusted because of
-- the extra spacer. The functions pathIn & pathOut handle this.
init = pairwith (compileMG id) $ spacerM $ maybe (emptyMG 10) fst optcgx
-- Stretchiness is applied to all drawings as it should be, but
-- optinitsize should be applied only to the first drawing!!!
pathIn path = 0:path
-- pathOut (0:path) = path
-- locatePointOut p = mapFst pathOut . locatePoint p
locatePointOut p (CGMark cg) = locatePoint p cg
-- bug if top node isn't a CGMark !!
graphicsK (mg,(cg,req)) =
putLayoutReq req $
idleK cleargc req mg cg solid []
idleK cleargc req mg cg active es =
seq size $ -- prevents a space leak when sizing==Dynamic, TH 980724
getK $ message lowK highK
where
size = minsize req -- == current window size most of the time
curR = hiR (solid||active)
same = idleK cleargc req mg cg active es
newcleargc cleargc' = idleK cleargc' req mg cg active es
optInsertNew mg cg gctx path optreq optnew k =
case optnew of
Nothing -> k mg cg optreq
Just new -> measureGraphicK new gctx $ \ newmg ->
let mg' = replaceMGPart mg path newmg
(cg',req) = compileMG (newSize sizing size) mg'
in k mg' cg' (Just req)
updGraphicsK mg cg optreq [] c =
case optreq of
Just req' | not (similar req' req)
-> --ctrace "updgfx" (show (req,req')) $
putLayoutReq req' $ c req' mg cg False
_ -> c req mg cg True
updGraphicsK mg cg optreq ((path,change):changes) c =
case change of
GfxReplace r -> replace r
GfxGroup from count -> group from count
GfxUngroup pos -> ungroup pos
where
replace (hi,optnew) =
optInsertNew mg cg (parentGctx gctx mg path) path optreq optnew $ \ mg' cg' optreq' ->
let cg'' = case (hi,optnew) of
(False,Nothing) -> cgupdate cg' path removecursor
(True,_) -> cgupdate cg' path addcursor
_ -> cg'
in updGraphicsK mg' cg'' optreq' changes c
group from count = updGraphicsK mg' cg' optreq changes c
where mg' = updateMGPart mg path (groupMGParts from count)
cg' = cgupdate cg path (cgGroup from count)
ungroup pos = updGraphicsK mg' cg' optreq changes c
where mg' = updateMGPart mg path (ungroupMGParts pos)
cg' = cgupdate cg path (cgUngroup pos)
bufDrawChangesK = maybe drawChangesK backBufDrawChangesK optbackbuf
bufDrawK = maybe drawK backBufDrawK optbackbuf
backBufDrawChangesK backbuf beQuick cur new old changes cont =
drawChangesK' (Just (DbeBackBuffer backbuf,cleargc)) False cur new old changes $
dbeSwapBuffers $
cont
backBufDrawK backbuf cur clip cg cont =
drawK' (DbeBackBuffer backbuf) cur clip cg $
dbeSwapBuffers $
--putLow (wCopyArea gc (DbeBackBuffer backbuf) (Rect 0 size) 0) $
cont
where (GC gc _) = gctx
buttonEvent t p state type' button =
-- High level output tagged Left is sent through idempotSP
putHigh (Left $
GfxButtonEvent t state type' button (locatePointOut p cg)) $
same
motionEvent t p state =
-- High level output tagged Left is sent through idempotSP
putHigh (Left $ GfxMotionEvent t state (locatePointOut p cg)) $
same
key t mods sym lookup =
putHigh (Right $ GfxKeyEvent t mods sym lookup) $ same
highK (ShowGfx path align) = mkPathVisible cg (pathIn path) align same
highK (BellGfx n) = xcommandK (Bell n) same
highK (GetGfxPlaces paths) =
putHigh (Right $ GfxPlaces $ fmap (cgrect . cgpart cg . pathIn) paths) $
same
highK (ChangeGfxBg bgspec) =
convColorK bgspec $ \ bgcol ->
xcommandK (ChangeWindowAttributes [CWBackPixel bgcol]) $
xcommandK clearWindowExpose $
wCreateGC rootGC [GCForeground bgcol] $ \ cleargc' ->
-- FreeGC cleargc
newcleargc cleargc'
highK (ChangeGfxBgPixmap pixmap freeIt) =
xcommandK (ChangeWindowAttributes [CWBackPixmap pixmap]) $
xcommandK clearWindowExpose $
wCreateGC rootGC [GCFillStyle FillTiled,GCTile pixmap] $ \ cleargc' ->
-- FreeGC cleargc
(if freeIt then xcommandK (FreePixmap pixmap) else id) $
newcleargc cleargc'
#ifdef USE_EXIST_Q
highK (ChangeGfxBgGfx gfx) =
graphic2PixmapImage gfx gctx $ \ (PixmapImage size pm) ->
highK (ChangeGfxBgPixmap pm True)
#endif
highK (ChangeGfxCursor cursor) =
defineCursor cursor $
xcommandK Flush $
same
highK (ChangeGfxFontCursor shape) =
setFontCursor shape $
xcommandK Flush $
same
highK (ChangeGfx changes0) =
updGraphicsK mg cg Nothing changes $ \ req' mg' cg' beQuick ->
bufDrawChangesK beQuick (higc,curR) cg' cg (fmap fst changes) $
--mkChangeVisible cg' changes $
idleK cleargc req' mg' cg' active []
where changes = mapFst pathIn changes0
changeActive active' =
if active'==active
then same
else putHigh (Left $ GfxFocusEvent { gfxHasFocus=active' }) $
bufDrawChangesK True (higc,hiR (solid||active')) cg cg (cursorPaths cg) $
idleK cleargc req mg cg active' es
lowK (XEvt e) = eventK e
lowK (LEvt lresp) = layoutK lresp
lowK _ = same
layoutK lresp =
case lresp of
LayoutSize size'
| adjsize ->
if size' == size then same
else let cg'' = foldr restorecursor cg' (cgcursors cg)
where
restorecursor path cg = cgupdate cg path addcursor
(cg',_) = compileMG (const size') mg
in putHigh (Left $ GfxResized size') $
bufDrawChangesK True (higc,curR) cg'' cg [] $
idleK cleargc req' mg cg'' active es
| otherwise -> idleK cleargc req' mg cg active es
where req' = mapLayoutSize (const size') req
_ -> same
eventK event =
case event of
Expose r 0 ->
let rs = r:es
in bufDrawK (higc,curR) (intersectRects rs) (prune rs cg) $
idleK cleargc req mg cg active []
Expose r _ -> idleK cleargc req mg cg active (r:es)
FocusIn {} -> changeActive True
FocusOut {} -> changeActive False
ButtonEvent {time=t, pos=pos, type'=type', button=button, state=state} ->
buttonEvent t pos state type' button
MotionNotify {time=t,pos=pos,state=state} -> motionEvent t pos state
KeyEvent t _ _ mods Pressed _ sym lookup -> key t mods sym lookup
_ -> same
prune rs (CGMark cg) = CGMark (prune rs cg)
prune rs (CGraphics r cur cmds cgs) =
if any (overlaps r) rs
then if null cmds -- || all (null.snd) cmds
then CGraphics r cur cmds (fmap (prune rs) cgs)
else CGraphics r cur cmds cgs
-- cmds may overlap with cgs, so
-- if cmds are redrawn then all cgs should be redrawn too.
else CGraphics r cur [] [] -- subtree rectangles are inside parent rectangles.
{-
locatePoint' p cg = fmap addrect $ locatePoint p cg
where
addrect = pairwith (cgrect . cgpart cg)
-}
locatePoint p (CGMark cg) = [(0:path,geom)|(path,geom)<-locatePoint p cg]
-- ^^ the wrong geometry will be return if CGMark came from a SpacerM !!
locatePoint p (CGraphics r _ _ gs) =
if p `inRect` r
then let ps = fmap (locatePoint p) gs
in case [ (i:path,pr) | (i,paths)<-number 1 ps, (path,pr)<-paths] of
[] -> [([],(p-rectpos r,r))]
ps -> ps
else []
cursorPaths (CGMark cg) = fmap (0:) (cursorPaths cg)
cursorPaths (CGraphics _ cur _ gs) =
if cur
then [[]]
else [i:p | (i,g)<-number 1 gs, p<-cursorPaths g]
hiR True = solidCursorRects
hiR False = hollowCursorRects
solidCursorRects r = [r]
hollowCursorRects (Rect (Point x y) (Point w h)) =
[rR x y w lw,rR x y lw h,rR x (y+h-lw) w lw,rR (x+w-lw) y lw h]
where lw=minimum [2,w,h]
--putSize cg = putLayoutReq (Layout (cgsize cg) False False)
mkChangeVisible cg changes =
case [ path | (path,(True,_))<-changes] of
path:_ -> mkPathVisible cg path (Nothing,Nothing)
_ -> id
mkPathVisible cg path align =
putLayout (lMkVis (cgrect (cgpart cg path)))
where
lMkVis r = LayoutMakeVisible (r `growrect` 5) align
-- growrect compensates for a layout bug !!
putLayoutReq = putLayout . LayoutRequest
--putSpacer = putLayout . LayoutSpacer
putLayout = putK . Low . LCmd
createCursorGC gc bg fg cont =
--allocNamedColorDefPixel defaultColormap cursorcolor "white" $ \ hipix ->
tryConvColorK cursorcolor $ \ opthipix ->
let hipix = fromMaybe fg opthipix
in if hipix/=bg && hipix/=fg && not mono
then wCreateGC gc [GCForeground hipix] $ \ cursorgc ->
cont cursorgc
else createPixmap (Point 2 2) copyFromParent $ \ pm ->
wCreateGC gc [GCForeground bg] $ \ cleargc ->
putsK [Low $ pmFillRectangle pm cleargc (rR 0 0 2 2),
Low $ pmDrawPoint pm gc 0] $
wCreateGC gc [GCFillStyle FillTiled,GCTile pm] $ \ cursorgc ->
cont cursorgc
similar l1 l2 =
minsize l1==minsize l2 &&
fixedh l1==fixedh l2 &&
fixedv l1==fixedv l2
cursorcolor = argKeyList "cursor" ["yellow"]
mono = argFlag "mono" False
defaultdoublebuffer = argFlag "doublebuffer" False
swapaction = argReadKey "swapaction" DbeCopied