module HTk.Canvasitems.CanvasTag (
CanvasTag,
TaggedCanvasItem(..),
SearchSpec,
allItems,
aboveItem,
belowItem,
withTag,
closest,
enclosed,
overlapping,
createCanvasTag,
addCanvasTag,
removeCanvasTag,
(&#&),
(|#|),
(^#),
tagNot,
) where
import HTk.Kernel.Core
import HTk.Canvasitems.CanvasItem
import HTk.Canvasitems.CanvasItemAux (canvasitemMethods)
import Events.Destructible
import Events.Synchronized
import Util.Computation
import HTk.Kernel.Geometry (Position,Distance)
infixr 3 &#&
infixr 2 |#|
infixr 2 ^#
class CanvasItem w => TaggedCanvasItem w where
tags :: [CanvasTag] -> Config w
tags cts item =
mapM (\ct -> do
CanvasItemName name tid <-
getObjectName (toGUIObject ct)
cset item "tag" (show tid)) cts >> return item
newtype CanvasTag = CanvasTag GUIOBJECT deriving Eq
createCanvasTag :: Canvas
-> [Config CanvasTag]
-> IO CanvasTag
createCanvasTag cnv cnf =
do
wid <- createGUIObject (toGUIObject cnv) (CANVASITEM CANVASTAG [])
tagMethods
configure (CanvasTag wid) cnf
instance GUIObject CanvasTag where
toGUIObject (CanvasTag wid) = wid
cname _ = "CanvasTag"
instance Destroyable CanvasTag where
destroy = destroy . toGUIObject
instance CanvasItem CanvasTag
instance Synchronized CanvasTag where
synchronize w = synchronize (toGUIObject w)
addCanvasTag :: SearchSpec
-> CanvasTag
-> IO ()
addCanvasTag spec@(SearchSpec cmd) tag =
do
spec' <- cmd
execMethod tag (\tnm -> tkAddTag tnm spec')
removeCanvasTag :: CanvasItem i => i
-> CanvasTag
-> IO ()
removeCanvasTag item tag =
do
tnm <- getObjectName (toGUIObject tag)
execMethod item (\cnm -> tkDTag cnm tnm)
(&#&) :: CanvasTag -> CanvasTag
-> IO CanvasTag
(&#&) = complexCanvasTag CanvasTagAnd
(|#|) :: CanvasTag -> CanvasTag
-> IO CanvasTag
(|#|) = complexCanvasTag CanvasTagOr
(^#) :: CanvasTag -> CanvasTag
-> IO CanvasTag
(^#) = complexCanvasTag CanvasTagXOr
tagNot :: CanvasTag
-> IO CanvasTag
tagNot t = complexCanvasTag (\ x _ -> CanvasTagNot x) t t
complexCanvasTag :: (CanvasTagOrID -> CanvasTagOrID -> CanvasTagOrID)
-> CanvasTag -> CanvasTag -> IO CanvasTag
complexCanvasTag f t1 t2
= do
CanvasItemName oid tid1 <- getObjectName (toGUIObject t1)
tid2 <- getCanvasTagOrID (toGUIObject t2)
Just par <- getParentObject (toGUIObject t1)
wid <- createGUIObject par
(CANVASITEM CANVASTAG [])
tagMethods
setObjectName wid (CanvasItemName oid (f tid1 tid2))
ct <- configure (CanvasTag wid) []
return ct
data SearchSpec = SearchSpec (IO String)
allItems :: SearchSpec
allItems = SearchSpec (return "all")
aboveItem :: CanvasItem item => item
-> SearchSpec
aboveItem item = SearchSpec (do {
tid <- getCanvasTagOrID (toGUIObject item);
return ("above [" ++ declVarList tid ++ "; list " ++ show tid ++ "]")
})
belowItem :: CanvasItem item => item
-> SearchSpec
belowItem item = SearchSpec (do {
tid <- getCanvasTagOrID (toGUIObject item);
return ("below [" ++ declVarList tid ++ "; list " ++ show tid ++ "]")
})
withTag :: CanvasItem item => item
-> SearchSpec
withTag item = SearchSpec (do {
tid <- getCanvasTagOrID (toGUIObject item);
return ("withtag [" ++ declVarList tid ++ "; list " ++ show tid ++ "]")
})
closest :: Position
-> SearchSpec
closest pos@(x, y) =
SearchSpec (return ("closest " ++ show x ++ " " ++ show y))
enclosed :: Position
-> Position
-> SearchSpec
enclosed pos1 pos2 =
SearchSpec (return ("enclosed " ++ showPos pos1 ++ " " ++ showPos pos2))
overlapping :: Position
-> Position
-> SearchSpec
overlapping pos1 pos2 =
SearchSpec (return ("overlapping " ++ showPos pos1 ++ " " ++ showPos pos2))
showPos :: (Distance,Distance) -> String
showPos (x,y) = " "++show x++" "++show y++" "
getCanvasTagOrID :: GUIOBJECT -> IO CanvasTagOrID
getCanvasTagOrID wid =
do
nm <- getObjectName wid
case nm of
CanvasItemName name tid -> return tid
_ -> error "CanvasTag (getCanvasTagOrID) : not a canvas item name"
tagMethods = canvasitemMethods {createCmd = tkCreateTag}
tkCreateTag :: ObjectName -> ObjectKind -> ObjectName -> ObjectID ->
[ConfigOption] -> TclScript
tkCreateTag _ (CANVASITEM CANVASTAG []) (CanvasItemName name tid) oid _ =
declVar tid ++ [" set " ++ vname ++ " t" ++ show oid]
where vname = (drop 1 (show tid))
tkAddTag :: ObjectName -> String -> TclScript
tkAddTag (CanvasItemName name tid) spec =
declVar tid ++ [show name ++ " addtag " ++ show tid ++ " " ++ spec]
tkDTag :: ObjectName -> ObjectName -> TclScript
tkDTag (CanvasItemName name cid) (CanvasItemName _ tid) =
declVar tid ++ declVar cid ++
[show name ++ " dtag " ++ show cid ++ " " ++ show tid]