module Id
          {-# DEPRECATED "This module has been superseded by Graphics.UI.ObjectIO" #-}
          ( Id, RId, R2Id, IdTable
          , IdParent (..)
          , windowMenuId, windowMenuRadioId, windowMenuCascadeId, windowMenuTileHId, windowMenuTileVId, windowMenuSeparatorId
          , toId, toRId, toR2Id, sysId, fromId, isSysId, isCustomId, isCustomRId, isSpecialId
          , r2IdtoId, rIdtoId
          , getRIdIn, getR2IdIn, getR2IdOut
          , initialIdTable, memberIdTable, okMembersIdTable, getIdParent, getIdParents 
          , addIdToIdTable, addIdsToIdTable, removeIdFromIdTable, removeIdsFromIdTable
          , module Device, module SystemId
          ) where


--	********************************************************************************
--	Clean to Haskell Standard Object I/O library, version 1.2
--	
--	Id defines the various kinds of identification values that identify GUI objects.
--	In addition, an IdTable is defined in which all bound GUI objects are 
--	administered. 
--	********************************************************************************

import Device
import SystemId
import Data.IORef


data	Id						-- The Id data type:
	= CustomId   !Int				-- Range of Ids generated by programs
	| CustomRId  !Int				-- Range of Ids generated by programs for uni-receivers	
	| SysId      !Int				-- Range of Ids generated for device instances
	| SpecialId  !Int				-- Range of Ids generated for special components

data	RId mess					-- The identification of bi-directional receivers:
 =	RId
 		{ rid        :: !Int			-- The identification value
 		, ridIn      :: !(IORef [mess])		-- The message input  channel
 		}
 		
data	R2Id mess resp					-- The identification of bi-directional receivers:
 =	R2Id
 		{ r2id       :: !Int			-- The identification value
 		, r2idIn     :: !(IORef mess)		-- The message input
 		, r2idOut    :: !(IORef resp)		-- The message output
 		}
 		
data	IdTable						-- The table of all Id entries
	= IdTable
		{ customIds   :: ![(Int,IdParent)]	-- all CustomId   entries
		, customRIds  :: ![(Int,IdParent)]	-- all CustomRId  entries
		, sysIds      :: ![(Int,IdParent)]	-- all SysId      entries
		}
data	IdParent
	= IdParent
		{ idpIOId     :: !SystemId		-- Id of parent process
		, idpDevice   :: !Device		-- Device kind of parent GUI object
		, idpId       :: !Id			-- Id of parent GUI object
		}

--	Special Ids:

specialWindowMenuId          = 1
specialWindowMenuRadioId     = 2
specialWindowMenuCascadeId   = 3
specialWindowMenuTileHId     = 4
specialWindowMenuTileVId     = 5
specialWindowMenuSeparatorId = 6

specialIdName :: Int -> String
specialIdName id
	= if id==specialWindowMenuId          then "WindowMenuId"               else
	  if id==specialWindowMenuRadioId     then "WindowMenuRadioId"          else
	  if id==specialWindowMenuCascadeId   then "SpecialWindowMenuCascadeId" else
	  if id==specialWindowMenuTileHId     then "SpecialWindowMenuTileHId"   else
	  if id==specialWindowMenuTileVId     then "SpecialWindowMenuTileVId"   else
	  if id==specialWindowMenuSeparatorId then "WindowMenuSeparatorId"      else
	                                           "Fatal error in rule show (Id) [Id]: undefined special Id.\n"

windowMenuId          :: Id;	windowMenuId          = SpecialId specialWindowMenuId		-- Id of the WindowMenu
windowMenuRadioId     :: Id;	windowMenuRadioId     = SpecialId specialWindowMenuRadioId	-- Id of the RadioMenu displaying the open windows
windowMenuCascadeId   :: Id;	windowMenuCascadeId   = SpecialId specialWindowMenuCascadeId	-- Id of the Cascade WindowMenu item
windowMenuTileHId     :: Id;	windowMenuTileHId     = SpecialId specialWindowMenuTileHId	-- Id of the Tile Horizontally WindowMenu item
windowMenuTileVId     :: Id;	windowMenuTileVId     = SpecialId specialWindowMenuTileVId	-- Id of the Tile Vertically WindowMenu item
windowMenuSeparatorId :: Id;	windowMenuSeparatorId = SpecialId specialWindowMenuSeparatorId	-- Id of the MenuSeparator item


toId :: Int -> Id
toId i = CustomId i

toRId :: Int -> IORef [mess] -> RId mess
toRId i cIn = RId {rid=i,ridIn=cIn}

toR2Id :: Int -> IORef mess -> IORef resp -> R2Id mess resp
toR2Id i cIn cOut = R2Id {r2id=i,r2idIn=cIn,r2idOut=cOut}

sysId :: Int -> Id
sysId i = SysId i

fromId :: Id -> Int
fromId (CustomId   id) = id
fromId (CustomRId  id) = id
fromId (SysId      id) = id
fromId (SpecialId  id) = id

isSysId :: Id -> Bool
isSysId (SysId _) = True
isSysId _         = False

isCustomId :: Id -> Bool
isCustomId (CustomId _) = True
isCustomId _            = False

isCustomRId :: Id -> Bool
isCustomRId (CustomRId _) = True
isCustomRId _             = False

isSpecialId :: Id -> Bool
isSpecialId (SpecialId _) = True
isSpecialId _             = False

instance Eq Id where
	(==) (CustomId   id1) id = case id of
	                               (CustomId   id2) -> id1==id2
	                               (CustomRId  id2) -> id1==id2	                               
	                               _                -> False
	(==) (CustomRId  id1) id = case id of
	                               (CustomId   id2) -> id1==id2
	                               (CustomRId  id2) -> id1==id2	                               
	                               _                -> False	
	(==) (SysId      id1) id = case id of
	                               (SysId      id2) -> id1==id2
	                               _                -> False
	(==) (SpecialId  id1) id = case id of
	                               (SpecialId id2)  -> id1==id2
	                               _                -> False
instance Eq (RId mess) where
	(==) rid1 rid2 = rid rid1 == rid rid2

instance Eq (R2Id mess resp) where
	(==) rid1 rid2 = r2id rid1 == r2id rid2


rIdtoId :: RId mess -> Id
rIdtoId id = CustomRId (rid id)

r2IdtoId :: R2Id mess resp -> Id
r2IdtoId id = CustomRId (r2id id)


instance Show Id where
	show (CustomId id)  = "toId " ++ show id
	show (CustomRId _)  = "RId"
	show (SysId _)      = "Id"
	show (SpecialId id) = specialIdName id


{-	Additional R(2)Id access operations:
-}

getRIdIn :: RId msg -> IORef [msg]
getRIdIn id = ridIn id

getR2IdIn :: R2Id msg resp -> IORef msg
getR2IdIn id = r2idIn id

getR2IdOut :: R2Id msg resp -> IORef resp
getR2IdOut id = r2idOut id


--	IdTable operations:

initialIdTable :: IdTable
initialIdTable
	= IdTable
		{ customIds   = []
		, customRIds  = []
		, sysIds      = []
		}

memberIdTable :: Id -> IdTable -> Bool
memberIdTable (CustomId   nr) table = membersortlist nr (customIds   table)
memberIdTable (CustomRId  nr) table = membersortlist nr (customRIds  table)
memberIdTable (SysId      nr) table = membersortlist nr (sysIds      table)
memberIdTable (SpecialId _)    _    = False

-- membersortlist checks for membership in a < sorted list
membersortlist :: Int -> [(Int,x)] -> Bool
membersortlist x ((y,_):ys)
	| x==y       = True
	| x>y        = False
	| otherwise  = membersortlist x ys
membersortlist _ _
	= False

okMembersIdTable :: [Id] -> IdTable -> Bool
okMembersIdTable ids idTable
	= noDuplicates ids && all (\id->not (memberIdTable id idTable)) ids
	where
		noDuplicates :: (Eq x) => [x] -> Bool
		noDuplicates (x:xs) = not (x `elem` xs) && noDuplicates xs
		noDuplicates _      = True

getIdParent :: Id -> IdTable -> Maybe IdParent
getIdParent (CustomId   nr) table = getparentsortlist nr (customIds   table)
getIdParent (CustomRId  nr) table = getparentsortlist nr (customRIds  table)
getIdParent (SysId      nr) table = getparentsortlist nr (sysIds      table)
getIdParent (SpecialId  _)  _     = Nothing

-- getparentsortlist retrieves (Just parent) in a < sorted list. If not found, Nothing is returned
getparentsortlist :: Int -> [(Int,x)] -> Maybe x
getparentsortlist x ((y,py):ys)
	| x==y      = Just py
	| x>y       = Nothing
	| otherwise = getparentsortlist x ys
getparentsortlist _ _
	= Nothing

getIdParents :: [Id] -> IdTable -> [Maybe IdParent]
getIdParents ids idTable
	= [getIdParent id idTable | id<-ids]

addIdToIdTable :: Id -> IdParent -> IdTable -> (Bool,IdTable)
addIdToIdTable (CustomId nr) idParent idTable
	= let (found,ids) = addtosortlist nr idParent (customIds idTable)
	  in  (not found, idTable {customIds=ids})
addIdToIdTable (CustomRId nr) idParent idTable
	= let (found,ids) = addtosortlist nr idParent (customRIds idTable)
	  in  (not found,idTable {customRIds=ids})
addIdToIdTable (SysId nr) idParent idTable
	= let (found,ids) = addtosortlist nr idParent (sysIds idTable)
	  in  (not found,idTable {sysIds=ids})
addIdToIdTable (SpecialId nr) idParent idTable
	= (False,idTable)

-- addtosortlist adds an element in a < sorted list. True iff element is already member.
addtosortlist :: Int -> IdParent -> [(Int,IdParent)] -> (Bool,[(Int,IdParent)])
addtosortlist x px ((y,py):ys)
	| x==y		= (True, (y,py):ys)
	| x>y		= (False,(x,px):((y,py):ys))
	| otherwise	= let (found,ys') = addtosortlist x px ys
			  in  (found,(y,py):ys')
addtosortlist x px _
	= (False,[(x,px)])

addIdsToIdTable :: [(Id,IdParent)] -> IdTable -> (Bool,IdTable)
addIdsToIdTable idparents idTable
	= (and oks,idTable1)
	where
		(oks,idTable1) = seqList (map add idparents) idTable		
		
		seqList :: [s -> (a,s)] -> s -> ([a],s)
		seqList (f:fs) s = (a:as,u)
			where
				(as,u) = seqList fs t 
				(a,t)  = f s
		seqList [] s = ([],s)
		
		add :: (Id,IdParent) -> IdTable -> (Bool,IdTable)
		add (id,parent) idTable = addIdToIdTable id parent idTable

removeIdFromIdTable :: Id -> IdTable -> (Bool,IdTable)
removeIdFromIdTable (CustomId nr) idTable
	= let (found,ids) = removefromsortlist nr (customIds idTable)
	  in  (not found,idTable {customIds=ids})
removeIdFromIdTable (CustomRId nr) idTable
	= let (found,ids) = removefromsortlist nr (customRIds idTable)
	  in  (not found,idTable {customRIds=ids})
removeIdFromIdTable (SysId nr) idTable
	= let (found,ids) = removefromsortlist nr (sysIds idTable)
	  in  (not found,idTable {sysIds=ids})
removeIdFromIdTable (SpecialId _) idTable
	= (False,idTable)

-- removefromsortlist removes an element from a < sorted list. True iff element was member.
removefromsortlist :: Int -> [(Int,x)] -> (Bool,[(Int,x)])
removefromsortlist x ((y,py):ys)
	| x==y		= (True, ys)
	| x>y		= (False,((y,py):ys))
	| otherwise	= let (found,ys') = removefromsortlist x ys
			  in  (found,((y,py):ys'))
removefromsortlist _ _
	= (False,[])

removeIdsFromIdTable :: [Id] -> IdTable -> (Bool,IdTable)
removeIdsFromIdTable (id:ids) idTable
	= (removed1 && removed2,idTable2)
	where
		(removed1,idTable1) = removeIdFromIdTable  id  idTable
		(removed2,idTable2) = removeIdsFromIdTable ids idTable1
removeIdsFromIdTable _ idTable
	= (True,idTable)
