module Relayout where


--	********************************************************************************
--	Clean to Haskell Standard Object I/O library, version 1.2
--	
--	OSWindow contains OS operations to manage windows and controls.
--	********************************************************************************

import	OSRgn
import  OSWindow
import  OSPicture(Draw(..), defaultPen, 
		  getPictOrigin, setPictOrigin, getPictPen, setPictPen,
		  pictGetClipRgn, pictSetClipRgn, pictAndClipRgn, doDraw)
import	CommonDef
import  WindowHandle
import  WindowAccess(getCompoundContentRect, getCompoundHScrollRect, getCompoundVScrollRect)
import  StdPicture(Look, toRegion, accClipPicture)
import  Control.Monad(when)
import  Cutil_12(addr2int, nullPtr)

data RelayoutItem
   = RelayoutItem
   	{ rliItemKind	:: !ControlKind		-- The control kind
	, rliItemPtr	:: !OSWindowPtr		-- The ptr to the item
	, rliItemPos	:: !Point2		-- The exact position of the item
	, rliItemSize	:: !Size		-- The exact size of the item
	, rliItemSelect	:: !Bool		-- The item is Able (True) or Unable (False)
	, rliItemShow	:: !Bool		-- The item is visible (True) or invisible (False)
	, rliItemInfo	:: CompoundInfo		-- If the control kind is IsCompoundControl: its CompoundInfo; otherwise undefined
	, rliItemLook	:: LookInfo		-- If the control kind is IsCustom(Button)Control: its LookInfo; otherwise undefined
	, rliItems	:: ![RelayoutItem]	-- If the control kind is Is(Compound/Layout)Control: its elements; otherwise: []
	}

relayoutFatalError :: String -> String -> x
relayoutFatalError function error
	= dumpFatalError function "relayout" error


{-	relayoutItems resizes and moves changed items.
		The two Rect   arguments are the window frames in which the elements reside.
		The two Point2 arguments are the positions of the parent window/compound.
		The OSWindowPtr is the parent window/dialog.
		The first  RelayoutItem list contains the elements at their original location and size.
		The second RelayoutItem list contains the elements at their new location and size.
	Assumptions: 
		* The two lists contain elements that are identical except for size and position
		* (Radio/Check)Controls are flattened and have rliItemKind Is(Radio/Check)Control
		* The ClipStates of CompoundControls are valid.
	This version uses the HDC of the parent window in order to suppress calls to initpicture.
		Regions are used to clip sibling controls.
		In addition, two regions (validRegion,invalidRegion) are maintained that administrate whether part of the window requires
		update after relayout. This is done as follows:
			* initially validRegion and invalidRegion are empty.
			* for each relayoutitem: if its oldFrame<>newFrame then it adds newFrame to validRegion, and oldFrame to invalidRegion
			* the area to be updated equals validRegion - invalidRegion (so if its empty, then no update is required)
	relayoutItems returns the update region. 
-}


relayoutItems :: OSWindowMetrics -> Rect -> Rect -> Point2 -> Point2 -> OSWindowPtr -> [RelayoutItem] -> [RelayoutItem] -> IO OSRgnHandle
relayoutItems wMetrics oldFrame newFrame oldParentPos newParentPos wPtr oldHs newHs = do
    clipRgn <- osNewRectRgn newFrame
    validRgn <- osNewRectRgn zero
    invalidRgn <- osNewRectRgn zero
    osPict <- osGrabWindowPictContext wPtr
    ((clipRgn,validRgn,invalidRgn), _, _, _) <-
    		doDraw zero defaultPen True osPict (accClipPicture (toRegion (rectToRectangle newFrame))
			(relayoutItems' wPtr wMetrics newArea (oldFrame,oldParentPos,oldHs)
				(newFrame,newParentPos,newHs)
				(clipRgn,validRgn,invalidRgn)))
    osReleaseWindowPictContext wPtr osPict
    updRgn <- osDiffRgn	invalidRgn validRgn
    mapM_ osDisposeRgn [clipRgn,validRgn,invalidRgn]
    return updRgn
    where
	newArea				= subtractRects newFrame oldFrame
	
	relayoutItems' :: OSWindowPtr -> OSWindowMetrics -> [Rect] -> (Rect,Point2,[RelayoutItem]) -> (Rect,Point2,[RelayoutItem]) 
			-> (OSRgnHandle,OSRgnHandle,OSRgnHandle) -> Draw (OSRgnHandle,OSRgnHandle,OSRgnHandle)
	relayoutItems' wPtr wMetrics newArea (oldFrame,oldParentPos,(oldH:oldHs)) (newFrame,newParentPos,(newH:newHs)) rgnHs = do
	    rgnHs1 <- relayoutItem wPtr wMetrics newArea (oldFrame,oldParentPos,oldH)  (newFrame,newParentPos,newH)  rgnHs
	    rgnHs2 <- relayoutItems' wPtr wMetrics newArea (oldFrame,oldParentPos,oldHs) (newFrame,newParentPos,newHs) rgnHs1
	    return rgnHs2
	    where
		relayoutItem :: OSWindowPtr -> OSWindowMetrics -> [Rect] -> (Rect,Point2,RelayoutItem) -> (Rect,Point2,RelayoutItem) ->
						(OSRgnHandle,OSRgnHandle,OSRgnHandle) -> Draw (OSRgnHandle,OSRgnHandle,OSRgnHandle)
		relayoutItem wPtr wMetrics newArea old@(_,_,RelayoutItem{rliItemKind=k1}) new@(_,_,RelayoutItem{rliItemKind=k2}) rgnHs
			| k1 /= k2		= relayoutFatalError "relayoutItem" "mismatching RelayoutItems"		
			| otherwise		= relayout wPtr wMetrics newArea k1 old new rgnHs
			where
			    {-	relayout assumes that the two RelayoutItem arguments 
				    have the same ControlKind (fourth argument) and differ only in size or position or both.
			    -}
			    relayout :: OSWindowPtr -> OSWindowMetrics -> [Rect] -> ControlKind -> (Rect,Point2,RelayoutItem) -> (Rect,Point2,RelayoutItem) ->
						    (OSRgnHandle,OSRgnHandle,OSRgnHandle) -> Draw (OSRgnHandle,OSRgnHandle,OSRgnHandle)

			    relayout wPtr wMetrics newArea IsCompoundControl (oldFrame,oldParentPos,old) (newFrame,newParentPos,new)
					    (clipRgn,validRgn,invalidRgn) = do
				liftIO (sizeF >> moveF)
				updF
				liftIO updScrollbars		-- update scrollbars AFTER moving/sizing/updating
				(clipRgn,validRgn,invalidRgn) <- relayoutItems' wPtr wMetrics newArea1 (oldFrame1,oldPos,rliItems old)
											(newFrame1,newPos,rliItems new) (clipRgn,validRgn,invalidRgn)
				(if rliItemShow new then do
				   (validRgn1,invalidRgn1) <- liftIO (checkUpdateRegions oldFrame1 newFrame1 (validRgn,invalidRgn))
				   clipRgn1 <- liftIO (subtractRectFromRgn (intersectRects newFrame newCompoundRect) clipRgn)
				   return (clipRgn1,validRgn1,invalidRgn1)
				 else
				   return (clipRgn,validRgn,invalidRgn))				
				 where
				    sameSize = oldSize==newSize
				    samePos	 = osCompoundMovesControls && oldPos-oldParentPos==newPos-newParentPos || oldPos==newPos
				    sizeF	 = when (not sameSize) 
					    (osSetCompoundSize wPtr newParentPos' itemPtr newPos' newSize' True)
				    moveF	 = when (not (samePos && all isEmptyRect (map (intersectRects newFrame1) newArea)))
					    (osSetCompoundPos  wPtr newParentPos' itemPtr newPos' newSize' True)
				    updScrollbars = when (not (sameSize && samePos && all isEmptyRect (concat (map (\area->[intersectRects hRect' area,intersectRects vRect' area]) newArea))))
					    ( (setCompoundScroll (fst hasScrolls) wMetrics itemPtr True  newHThumbSize (x oldOrigin) (x newOrigin) hRect) >>
					      (setCompoundScroll (snd hasScrolls) wMetrics itemPtr False newVThumbSize (y oldOrigin) (y newOrigin) vRect)
					    )
				    updF = when (not (sameSize && oldPos==newPos && oldFrame1==newFrame1 || isEmptyRect newFrame1 || not (rliItemShow new)))
					    (updateCustomControl wPtr clipRgn newFrame1 new)
				    newParentPos'	= toTuple newParentPos
				    itemPtr		= rliItemPtr new
				    newSize		= rliItemSize new
				    newSize'		= toTuple newSize
				    oldSize		= rliItemSize old
				    newPos		= rliItemPos new
				    newPos'		= toTuple newPos
				    oldPos		= rliItemPos old
				    newInfo		= rliItemInfo new
				    oldInfo		= rliItemInfo old 
				    newOrigin		= compoundOrigin newInfo
				    oldOrigin		= compoundOrigin oldInfo
				    newDomainRect	= compoundDomain newInfo
				    oldDomainRect	= compoundDomain oldInfo
				    newCompoundRect	= posSizeToRect newPos newSize
				    oldCompoundRect	= posSizeToRect oldPos oldSize
				    newFrame1		= intersectRects newFrame newContentRect
				    oldFrame1		= intersectRects oldFrame oldContentRect
				    newArea1		= subtractRects newFrame1 oldFrame1
				    hasScrolls		= (isJust (compoundHScroll newInfo),isJust (compoundVScroll newInfo))
				    newVisScrolls	= osScrollbarsAreVisible wMetrics newDomainRect newSize' hasScrolls
				    oldVisScrolls	= osScrollbarsAreVisible wMetrics oldDomainRect (toTuple oldSize) hasScrolls
				    newHThumbSize	= ((w newSize)-(if snd newVisScrolls then osmVSliderWidth  wMetrics else 0)+1)
				    newVThumbSize	= ((h newSize)-(if fst newVisScrolls then osmHSliderHeight wMetrics else 0)+1)
				    oldContentRect	= getCompoundContentRect wMetrics oldVisScrolls oldCompoundRect
				    newContentRect	= getCompoundContentRect wMetrics newVisScrolls newCompoundRect
				    hRect		= getCompoundHScrollRect wMetrics newVisScrolls (sizeToRect newSize)
				    hRect'		= addVector (toVector newPos) hRect
				    vRect		= getCompoundVScrollRect wMetrics newVisScrolls (sizeToRect newSize)
				    vRect'		= addVector (toVector newPos) vRect

				    setCompoundScroll :: Bool -> OSWindowMetrics -> OSWindowPtr -> Bool -> Int -> Int -> Int -> Rect -> IO ()
				    setCompoundScroll hasScroll wMetrics compoundPtr isHorizontal size old new (Rect {rright=right,rbottom=bottom})
					    | not hasScroll	= return ()
					    | otherwise = do
						    osSetCompoundSliderThumbSize wMetrics compoundPtr isHorizontal size (right,bottom) (old==new)
						    when (old /= new) (osSetCompoundSliderThumb wMetrics compoundPtr isHorizontal new (right,bottom) True)

			    relayout wPtr wMetrics newArea IsLayoutControl (oldFrame,oldParentPos,old) (newFrame,newParentPos,new) rgnHs =
				    relayoutItems' wPtr wMetrics newArea (oldFrame1,oldParentPos,rliItems old) (newFrame1,newParentPos,rliItems new) rgnHs				    
				    where
				      newSize	= rliItemSize new
				      oldSize	= rliItemSize old
				      newPos	= rliItemPos  new
				      oldPos	= rliItemPos  old
				      newLayoutRect	= posSizeToRect newPos newSize
				      oldLayoutRect	= posSizeToRect oldPos oldSize
				      newFrame1	= intersectRects newFrame newLayoutRect
				      oldFrame1	= intersectRects oldFrame oldLayoutRect

			    relayout wPtr wMetrics newArea controlKind (oldFrame,oldParentPos,old) (newFrame,newParentPos,new) (clipRgn,validRgn,invalidRgn) = do
				    liftIO (sizeF >> moveF)
				    updF
				    (if rliItemShow new then do
					    (validRgn,invalidRgn) <- liftIO (checkUpdateRegions oldFrame1 newFrame1 (validRgn,invalidRgn))
					    clipRgn <- liftIO (subtractRectFromRgn newFrame1 clipRgn)
					    return (clipRgn,validRgn,invalidRgn)
				     else return (clipRgn,validRgn,invalidRgn))				    
				    where
					sameSize	= oldSize==newSize
					samePos		= osCompoundMovesControls && oldPos-oldParentPos==newPos-newParentPos || oldPos==newPos
					sizeF		= when (not sameSize) 
					    			(setSize wPtr newParentPos' itemPtr newPos' newSize' (not redraw))
					moveF		= when (not (samePos && all isEmptyRect (map (intersectRects newFrame1) newArea)))
					    			(setPos  wPtr newParentPos' itemPtr newPos' (toTuple oldSize) (not redraw))
					updF		= when (not (not redraw || sameSize && oldPos==newPos && newFrame1==oldFrame1 || isEmptyRect newFrame1 || not (rliItemShow new)))
					    			(updateCustomControl wPtr clipRgn newFrame1 new)
					newParentPos'	= toTuple newParentPos
					itemPtr		= rliItemPtr new
					newPos		= rliItemPos new
					newPos'		= toTuple newPos
					oldPos		= rliItemPos  old
					newSize		= rliItemSize new
					newSize'	= toTuple newSize
					oldSize		= rliItemSize old				    
					oldFrame1	= intersectRects oldFrame (posSizeToRect oldPos oldSize)
					newFrame1	= intersectRects newFrame (posSizeToRect newPos newSize)
					(setPos,setSize,redraw) = case controlKind of
						    IsRadioControl		-> (osSetRadioControlPos,		\_ _ _ _ _ _ -> return (),	False)
						    IsCheckControl		-> (osSetCheckControlPos,		\_ _ _ _ _ _ -> return (),	False)
						    IsPopUpControl		-> (osSetPopUpControlPos,		osSetPopUpControlSize,		False)
						    IsSliderControl		-> (osSetSliderControlPos,		osSetSliderControlSize,		False)
						    IsTextControl		-> (osSetTextControlPos,		osSetTextControlSize,		False)
						    IsEditControl		-> (osSetEditControlPos,		osSetEditControlSize,		False)
						    IsButtonControl		-> (osSetButtonControlPos,		osSetButtonControlSize,		False)
						    IsCustomButtonControl	-> (osSetCustomButtonControlPos,	osSetCustomButtonControlSize,	True)
						    IsCustomControl		-> (osSetCustomControlPos,		osSetCustomControlSize,		True)
						    IsReceiverControl 		-> (\_ _ _ _ _ _ -> return (),		\_ _ _ _ _ _ -> return (),	False)
						    _			-> relayoutFatalError "relayout" "unexpected ControlKind alternative"
			
	relayoutItems' _ _ _ (_,_,[]) (_,_,[]) rgnHs = return rgnHs
	relayoutItems' _ _ _ _ _ _
		= relayoutFatalError "relayoutItems'" "mismatching RelayoutItems"
	
	checkUpdateRegions :: Rect -> Rect -> (OSRgnHandle,OSRgnHandle) -> IO (OSRgnHandle,OSRgnHandle)
	checkUpdateRegions oldFrame newFrame rgnHs@(validRgn,invalidRgn)
		| oldFrame==newFrame = return rgnHs
		| otherwise = do
		    newFrameRgn <- osNewRectRgn newFrame
		    oldFrameRgn <- osNewRectRgn oldFrame
		    okNewRgn <- osDiffRgn  newFrameRgn invalidRgn			-- PA+++
		    newValidRgn <- osUnionRgn okNewRgn validRgn				-- PA: okNewRgn <-- newFrameRgn
		    newInvalidRgn <- osUnionRgn oldFrameRgn invalidRgn
		    mapM_ osDisposeRgn [validRgn,invalidRgn,newFrameRgn,oldFrameRgn,okNewRgn]	-- PA: okNewRgn added
		    return (newValidRgn,newInvalidRgn)
	
	subtractRectFromRgn :: Rect -> OSRgnHandle -> IO OSRgnHandle
	subtractRectFromRgn rect rgn
		| isEmptyRect rect = return rgn
		| otherwise = do
		    rectRgn <- osNewRectRgn rect
		    diffRgn <- osDiffRgn rgn rectRgn
		    osDisposeRgn rectRgn
		    osDisposeRgn rgn
		    return diffRgn
	
	--	updateCustomControl assumes that the item is visible.
	updateCustomControl :: OSWindowPtr -> OSRgnHandle -> Rect -> RelayoutItem -> Draw ()
	updateCustomControl parentPtr clipRgn contentRect itemH@(RelayoutItem{rliItemKind=IsCustomButtonControl}) = do		
		curOrigin <- getPictOrigin
		curPen <- getPictPen
		setPictOrigin (zero-itemPos)
		setPictPen lookPen
		clipOSPicture clipRgn contentRect (lookFun selectState updState)
		setPictPen curPen
		setPictOrigin curOrigin
		return ()
		where
		  selectState		= if rliItemSelect itemH then Able else Unable
		  itemPos		= rliItemPos itemH		  
		  cFrame		= sizeToRectangle (rliItemSize itemH)
		  updState		= UpdateState{oldFrame=cFrame,newFrame=cFrame,updArea=[cFrame]}
		  LookInfo{lookFun=lookFun,lookPen=lookPen} = rliItemLook itemH
	
	updateCustomControl parentPtr clipRgn contentRect itemH@(RelayoutItem{rliItemKind=IsCustomControl}) = do
		curOrigin <- getPictOrigin
		curPen <- getPictPen
		setPictOrigin (zero-itemPos)
		setPictPen lookPen
		clipOSPicture clipRgn contentRect (lookFun selectState updState)
		setPictPen curPen
		setPictOrigin curOrigin
		return ()
		where
		  selectState		= if rliItemSelect itemH then Able else Unable
		  itemPos		= rliItemPos itemH		  
		  cFrame		= sizeToRectangle (rliItemSize itemH)
		  updState		= UpdateState{oldFrame=cFrame,newFrame=cFrame,updArea=[cFrame]}
		  LookInfo{lookFun=lookFun,lookPen=lookPen} = rliItemLook itemH
	
	updateCustomControl parentPtr clipRgn' contentRect itemH@(RelayoutItem{rliItemKind=IsCompoundControl}) = do
		curOrigin <- getPictOrigin
		curPen <- getPictPen
		setPictOrigin (origin-itemPos)
		setPictPen lookPen
		clip <- liftIO (osSectRgn clipRgn' (clipRgn clipInfo)) -- PA+++
		clipOSPicture clip clipRect (lookFun selectState updState)
		liftIO (osDisposeRgn clip)				-- PA+++
		setPictPen curPen
		setPictOrigin curOrigin
		return ()
		where
		  selectState		= if rliItemSelect itemH then Able else Unable
		  itemSize		= rliItemSize itemH
		  itemPos		= rliItemPos itemH
		  info			= rliItemInfo itemH		  
		  visScrolls		= osScrollbarsAreVisible wMetrics domainRect (toTuple itemSize) hasScrolls
		  cFrameRect		= getCompoundContentRect wMetrics visScrolls (posSizeToRect origin itemSize)
		  cFrame		= rectToRectangle cFrameRect
		  compLookInfo		= compoundLookInfo info		  
		  clipInfo		= compoundClip compLookInfo
		  updState		= UpdateState{oldFrame=cFrame,newFrame=cFrame,updArea=[cFrame]}
		  cRect			= addVector (toVector (itemPos-origin)) cFrameRect
		  clipRect		= intersectRects contentRect cRect
		  LookInfo{lookFun=lookFun,lookPen=lookPen} = compoundLook compLookInfo
		  (origin,domainRect,hasScrolls) = (compoundOrigin info,compoundDomain info,(isJust (compoundHScroll info),isJust (compoundVScroll info)))

	clipOSPicture :: OSRgnHandle -> Rect -> Draw () -> Draw ()
	clipOSPicture newClipRgn rect drawf = do
		rectRgn <- liftIO (osNewRectRgn rect)
		curClipRgn <- pictGetClipRgn
		(if curClipRgn==nullPtr then pictSetClipRgn else pictAndClipRgn) rectRgn
		when (newClipRgn /= nullPtr) (pictAndClipRgn newClipRgn)
		drawf
		pictSetClipRgn curClipRgn
		liftIO (when (curClipRgn /= nullPtr) (osDisposeRgn curClipRgn) >> osDisposeRgn rectRgn)
