Commit 3cb3e377 authored by Peter Achten's avatar Peter Achten
Browse files

(PA): moveWindowViewFrame now takes advantage of system look.

parent 42aafe76
......@@ -3,7 +3,7 @@ implementation module controlpos
// Clean Object I/O library version 1.2
import StdBool, StdFunc, StdMisc, StdTuple
import StdBool, StdFunc, StdInt, StdList, StdMisc, StdTuple
import commondef, windowaccess
from controllayout import layoutControls, getWindowContentRect
from controlrelayout import relayoutControls
......@@ -11,65 +11,108 @@ from windowclipstate import forceValidWindowClipState
from windowdefaccess import isWindowItemSpace, getWindowItemSpaceAtt,
isWindowHMargin, getWindowHMarginAtt,
isWindowVMargin, getWindowVMarginAtt
from windowdraw import drawwindowlook
from windowdraw import drawwindowlook`
from windowupdate import updatewindowbackgrounds
from ospicture import pictscroll
from osrgn import osgetrgnbox
from ostypes import Rect
from ostoolbox import OSToolbox
from oswindow import OSWindowMetrics, OSscrollbarsAreVisible, OSsetWindowSliderThumb, toOSscrollbarRange, OSMinWindowSize
controlposFatalError :: String String -> .x
controlposFatalError function error
= FatalError function "controlpos" error
/* movewindowviewframe moves the current view frame of the WindowHandle by the given Vector2.
movewindowviewframe assumes that the argument WindowHandle is a Window.
*/
movewindowviewframe :: !OSWindowMetrics !Vector2 !WIDS !(WindowHandle .ls .pst) !*OSToolbox -> (!WindowHandle .ls .pst,!*OSToolbox)
movewindowviewframe wMetrics v wids=:{wPtr} wH tb
# visScrolls = OSscrollbarsAreVisible wMetrics (RectangleToRect domain) (toTuple wSize) (hasHScroll,hasVScroll)
contentRect = getWindowContentRect wMetrics visScrolls (SizeToRect wSize)
contentSize = RectSize contentRect
(minx,maxx,viewx) = (domainRect.rleft,domainRect.rright, contentSize.w)
(miny,maxy,viewy) = (domainRect.rtop, domainRect.rbottom,contentSize.h)
newOrigin = movePoint v oldOrigin
newOrigin = {x=SetBetween newOrigin.x minx (maxx-viewx),y=SetBetween newOrigin.y miny (maxy-viewy)}
movewindowviewframe wMetrics v wids=:{wPtr} wH=:{whWindowInfo,whItems=oldItems,whSize,whAtts,whSelect} tb
| newOrigin==oldOrigin
= (wH,tb)
| otherwise
# tb = setsliderthumb hasHScroll wMetrics wPtr True (minx,newOrigin.x,maxx) viewx (toTuple wSize) tb
# tb = setsliderthumb hasVScroll wMetrics wPtr False (miny,newOrigin.y,maxy) viewy (toTuple wSize) tb
(defHSpace,defVSpace) = (wMetrics.osmHorItemSpace,wMetrics.osmVerItemSpace)
hMargins = getWindowHMarginAtt (snd (Select isWindowHMargin (WindowHMargin 0 0) atts))
vMargins = getWindowVMarginAtt (snd (Select isWindowVMargin (WindowVMargin 0 0) atts))
spaces = getWindowItemSpaceAtt (snd (Select isWindowItemSpace (WindowItemSpace defHSpace defVSpace) atts))
# tb = setsliderthumb hasHScroll wMetrics wPtr True (minx,newOrigin.x,maxx) vieww (toTuple whSize) tb
# tb = setsliderthumb hasVScroll wMetrics wPtr False (miny,newOrigin.y,maxy) viewh (toTuple whSize) tb
reqSize = {w=contentSize.w-fst hMargins-snd hMargins,h=contentSize.h-fst vMargins-snd vMargins}
# (_,newItems,tb) = layoutControls wMetrics hMargins vMargins spaces reqSize minSize [(domain,newOrigin)] oldItems tb
windowInfo = {windowInfo & windowOrigin=newOrigin}
// wH = {wH & whItems=newItems,whWindowInfo=Just windowInfo} Mike: changed Just into WindowInfo
wH = {wH & whItems=newItems,whWindowInfo=WindowInfo windowInfo}
# (wH,tb) = forceValidWindowClipState wMetrics True wPtr wH tb
# (updRgn,tb) = relayoutControls wMetrics whSelect contentRect contentRect zero zero wPtr whDefaultId oldItems wH.whItems tb
# (isRect,areaRect,tb) = case wH.whWindowInfo of
WindowInfo {windowClip={clipRgn}} -> osgetrgnbox clipRgn tb
_ -> controlposFatalError "movewindowviewframe" "unexpected whWindowInfo field"
# (updRgn,tb) = relayoutControls wMetrics whSelect contentRect contentRect zero zero wPtr wH.whDefaultId oldItems wH.whItems tb
# (wH,tb) = updatewindowbackgrounds wMetrics updRgn wids wH tb
newFrame = PosSizeToRectangle newOrigin contentSize // PA: drawinwindow might be redundant because of updatewindowbackgrounds
updState = {oldFrame=PosSizeToRectangle oldOrigin contentSize,newFrame=newFrame,updArea=[newFrame]}
# (wH,tb) = drawwindowlook wMetrics wPtr id updState wH tb
newFrame = PosSizeToRectangle newOrigin contentSize
toMuch = (abs (newOrigin.x-oldOrigin.x)>=w`) || (abs (newOrigin.y-oldOrigin.y)>=h`)
(updArea,updAction) = if (not lookInfo.lookSysUpdate || toMuch || not isRect)
([newFrame],return []) (calcScrollUpdateArea oldOrigin newOrigin areaRect)
updState = {oldFrame=PosSizeToRectangle oldOrigin contentSize,newFrame=newFrame,updArea=updArea}
# (wH,tb) = drawwindowlook` wMetrics wPtr updAction updState wH tb
= (wH,tb)
where
wSize = wH.whSize
// windowInfo = fromJust wH.whWindowInfo Mike: changed fromJust into getWindowInfoWindowData
windowInfo = getWindowInfoWindowData wH.whWindowInfo
domainRect = windowInfo.windowDomain
windowInfo = getWindowInfoWindowData whWindowInfo
(oldOrigin,domainRect,hasHScroll,hasVScroll,lookInfo)
= (windowInfo.windowOrigin,windowInfo.windowDomain,isJust windowInfo.windowHScroll,isJust windowInfo.windowVScroll,windowInfo.windowLook)
domain = RectToRectangle domainRect
oldOrigin = windowInfo.windowOrigin
hasHScroll = isJust windowInfo.windowHScroll
hasVScroll = isJust windowInfo.windowVScroll
atts = wH.whAtts
oldItems = wH.whItems
whSelect = wH.whSelect
whDefaultId = wH.whDefaultId
visScrolls = OSscrollbarsAreVisible wMetrics domainRect (toTuple whSize) (hasHScroll,hasVScroll)
contentRect = getWindowContentRect wMetrics visScrolls (SizeToRect whSize)
contentSize = RectSize contentRect
{w=w`,h=h`} = contentSize
(minx,maxx,vieww) = (domainRect.rleft,domainRect.rright, contentSize.w)
(miny,maxy,viewh) = (domainRect.rtop, domainRect.rbottom,contentSize.h)
newOrigin = { x = SetBetween (oldOrigin.x+v.vx) minx (max minx (maxx-vieww))
, y = SetBetween (oldOrigin.y+v.vy) miny (max miny (maxy-viewh))
}
(defMinW,defMinH) = OSMinWindowSize
minSize = {w=defMinW,h=defMinH}
(defHSpace,defVSpace) = (wMetrics.osmHorItemSpace,wMetrics.osmVerItemSpace)
hMargins = getWindowHMarginAtt (snd (Select isWindowHMargin (WindowHMargin 0 0) whAtts))
vMargins = getWindowVMarginAtt (snd (Select isWindowVMargin (WindowVMargin 0 0) whAtts))
spaces = getWindowItemSpaceAtt (snd (Select isWindowItemSpace (WindowItemSpace defHSpace defVSpace) whAtts))
setsliderthumb :: !Bool OSWindowMetrics OSWindowPtr Bool (Int,Int,Int) Int (Int,Int) !*OSToolbox -> *OSToolbox
setsliderthumb :: !Bool !OSWindowMetrics !OSWindowPtr !Bool !(!Int,!Int,!Int) !Int !(!Int,!Int) !*OSToolbox -> *OSToolbox
setsliderthumb hasScroll wMetrics wPtr isHScroll scrollValues viewSize maxcoords tb
| hasScroll = OSsetWindowSliderThumb wMetrics wPtr isHScroll osThumb maxcoords True tb
| otherwise = tb
where
(_,osThumb,_,_) = toOSscrollbarRange scrollValues viewSize
/* calcScrollUpdateArea p1 p2 area calculates the new update area that has to be updated.
Assumptions: p1 is the origin before scrolling,
p2 is the origin after scrolling,
area is the visible area of the window view frame.
*/
calcScrollUpdateArea :: !Point2 !Point2 !Rect -> (![Rectangle],!St *Picture [Rect])
calcScrollUpdateArea oldOrigin newOrigin areaRect
= (map RectToRectangle updArea,scroll {newOriginAreaRect & rright=rright+1,rbottom=rbottom+1} restArea v)
where
newOriginAreaRect = addVector (toVector newOrigin) areaRect
{rleft,rtop,rright,rbottom} = newOriginAreaRect
v = toVector (oldOrigin-newOrigin)
{vx,vy} = v
(updArea,restArea) = if (vx<=0 && vy<=0)
( [{newOriginAreaRect & rleft=rright+vx,rbottom=rbottom+vy},{newOriginAreaRect & rtop=rbottom+vy}]
, {newOriginAreaRect & rright=rright+vx,rbottom=rbottom+vy}
)
(if (vx<=0 && vy>=0)
( [{newOriginAreaRect & rbottom=rtop+vy},{newOriginAreaRect & rleft=rright+vx,rtop=rtop+vy}]
, {newOriginAreaRect & rtop=rtop+vy,rright=rright+vx}
)
(if (vx>=0 && vy<=0)
( [{newOriginAreaRect & rright=rleft+vx,rbottom=rbottom+vy},{newOriginAreaRect & rtop=rbottom+vy}]
, {newOriginAreaRect & rleft=rleft+vx,rbottom=rbottom+vy}
)
// if (vx>=0 && vy>=0)
( [{newOriginAreaRect & rbottom=rtop+vy},{newOriginAreaRect & rtop=rtop+vy,rright=rleft+vx}]
, {newOriginAreaRect & rleft=rleft+vx,rtop=rtop+vy}
)))
scroll :: !Rect !Rect !Vector2 !*Picture -> (![Rect],!*Picture)
scroll scrollRect restRect v picture
# (updRect,picture) = pictscroll scrollRect v picture
| updRect==zero
= ([],picture)
| otherwise
= ([restRect],picture)
definition module documentinterface
// Clean Object I/O library, version 1.2
from iostate import PSt, IOSt
from osdocumentinterface import OSDInfo
/* setOSDInfoInMenuDevice stores process document interface information in the menu device.
*/
setOSDInfoInMenuDevice :: !OSDInfo !(PSt .l .p) -> PSt .l .p
/* closeOSDInfo is the final call needed to close the proper document interface resources.
It should be called only after all other devices have been closed.
*/
closeOSDInfo :: !(IOSt .l .p) -> IOSt .l .p
implementation module documentinterface
// Clean Object I/O library, version 1.2
import StdBool, StdFunc, StdMisc
import osdocumentinterface, osmenu
import commondef, iostate, menudevice, menuevent
documentinterfaceFatalError :: String String -> .x
documentinterfaceFatalError function error
= FatalError function "documentinterface" error
/* setOSDInfoInMenuDevice stores process document interface information in the menu device.
*/
setOSDInfoInMenuDevice :: !OSDInfo !(PSt .l .p) -> PSt .l .p
setOSDInfoInMenuDevice OSNoInfo pState
= pState
setOSDInfoInMenuDevice osdinfo pState
# pState = MenuFunctions.dOpen pState
# (mDevice,ioState) = IOStGetDevice MenuDevice pState.io
mHs = MenuSystemStateGetMenuHandles mDevice
mHs = {mHs & mOSMenuBar=OSMenuBarNew frame client menubar}
# ioState = IOStSetDevice (MenuSystemState mHs) ioState
= {pState & io=ioState}
where
(frame,client,menubar) = case osdinfo of
OSMDInfo info -> (info.osmdFrame,info.osmdClient,info.osmdMenubar)
OSSDInfo info -> (info.ossdFrame,info.ossdClient,info.ossdMenubar)
OSNoInfo -> documentinterfaceFatalError "setOSDInfoInMenuDevice" "unexpected OSDInfo argument"
closeOSDInfo :: !(IOSt .l .p) -> IOSt .l .p
closeOSDInfo ioState
# (osdinfo,ioState) = IOStGetOSDInfo ioState
close = case osdinfo of
OSMDInfo info -> OScloseMDI info
OSSDInfo info -> OScloseSDI info
_ -> id
= appIOToolbox close ioState
......@@ -1387,33 +1387,29 @@ where
= (wH,tb)
| otherwise
# (_,newOSThumb,_,_) = toOSscrollbarRange (min`,newThumb,max`) viewSize
newOrigin = if isHorizontal {origin & x=newThumb} {origin & y=newThumb}
newOrigin = if isHorizontal {oldOrigin & x=newThumb} {oldOrigin & y=newThumb}
# tb = OSsetWindowSliderThumb wMetrics wPtr isHorizontal newOSThumb (toTuple whSize) True tb
# (_,newItems,tb) = layoutControls wMetrics hMargins vMargins spaces contentSize minSize [(domain,newOrigin)] oldItems tb
wH = { wH & whWindowInfo = WindowInfo {windowInfo & windowOrigin=newOrigin}
, whItems = newItems
}
# (wH,tb) = forceValidWindowClipState wMetrics True wPtr wH tb
(scrollWindowInfo,wH) = (\wH=:{whWindowInfo}->(whWindowInfo,wH)) wH
# (isRect,areaRect,tb) = case scrollWindowInfo of
# (isRect,areaRect,tb) = case wH.whWindowInfo of
WindowInfo {windowClip={clipRgn}} -> osgetrgnbox clipRgn tb
_ -> windowdeviceFatalError "windowScrollActionIO" "unexpected empty whWindowInfo field"
_ -> windowdeviceFatalError "windowScrollActionIO" "unexpected whWindowInfo field"
# (updRgn,tb) = relayoutControls wMetrics whSelect contentRect contentRect zero zero wPtr wH.whDefaultId oldItems wH.whItems tb
# (wH,tb) = updatewindowbackgrounds wMetrics updRgn info.wsaWIDS wH tb
newFrame = PosSizeToRectangle newOrigin contentSize
toMuch = if isHorizontal (abs (newOrigin.x-origin.x)>=w`) (abs (newOrigin.y-origin.y)>=h`)
toMuch = if isHorizontal (abs (newOrigin.x-oldOrigin.x)>=w`) (abs (newOrigin.y-oldOrigin.y)>=h`)
(updArea,updAction) = if (not lookInfo.lookSysUpdate || toMuch || not isRect)
(newFrame,\s->(zero,s)) (calcScrollUpdateArea origin newOrigin areaRect)
updState = { oldFrame=oldFrame
, newFrame=newFrame
, updArea =[updArea]
}
(newFrame,return []) (calcScrollUpdateArea oldOrigin newOrigin areaRect)
updState = {oldFrame=oldFrame,newFrame=newFrame,updArea=[updArea]}
# (wH,tb) = drawwindowlook` wMetrics wPtr updAction updState wH tb
# tb = OSvalidateWindowRect wPtr (SizeToRect whSize) tb
// # tb = OSvalidateWindowRect wPtr (SizeToRect whSize) tb
= (wH,tb)
where
windowInfo = getWindowInfoWindowData whWindowInfo
(origin,domainRect,hasHScroll,hasVScroll,lookInfo)
(oldOrigin,domainRect,hasHScroll,hasVScroll,lookInfo)
= (windowInfo.windowOrigin,windowInfo.windowDomain,isJust windowInfo.windowHScroll,isJust windowInfo.windowVScroll,windowInfo.windowLook)
isHorizontal = info.wsaDirection==Horizontal
domain = RectToRectangle domainRect
......@@ -1421,11 +1417,11 @@ where
contentRect = getWindowContentRect wMetrics visScrolls (SizeToRect whSize)
contentSize = RectSize contentRect
{w=w`,h=h`} = contentSize
oldFrame = PosSizeToRectangle origin contentSize
oldFrame = PosSizeToRectangle oldOrigin contentSize
(min`,oldThumb,max`,viewSize)
= if isHorizontal
(domain.corner1.x,origin.x,domain.corner2.x,w`)
(domain.corner1.y,origin.y,domain.corner2.y,h`)
(domain.corner1.x,oldOrigin.x,domain.corner2.x,w`)
(domain.corner1.y,oldOrigin.y,domain.corner2.y,h`)
sliderState = {sliderMin=min`,sliderThumb=oldThumb,sliderMax=max`-viewSize}
scrollInfo = fromJust (if isHorizontal windowInfo.windowHScroll windowInfo.windowVScroll)
scrollFun = scrollInfo.scrollFunction
......@@ -1444,28 +1440,28 @@ where
area is the visible area of the window view frame,
scrolling occurs either horizontally or vertically.
*/
calcScrollUpdateArea :: !Point2 !Point2 !Rect -> (!Rectangle,!St *Picture Rect)
calcScrollUpdateArea :: !Point2 !Point2 !Rect -> (!Rectangle,!St *Picture [Rect])
calcScrollUpdateArea oldOrigin newOrigin areaRect
= (updArea,scroll {originAreaRect & rright=rright+1,rbottom=rbottom+1} restArea v)
= (updArea,scroll {newOriginAreaRect & rright=rright+1,rbottom=rbottom+1} restArea v)
where
originAreaRect = addVector (toVector newOrigin) areaRect
{rleft,rtop,rright,rbottom} = originAreaRect
originAreaRectangle = RectToRectangle originAreaRect
newOriginAreaRect = addVector (toVector newOrigin) areaRect
{rleft,rtop,rright,rbottom} = newOriginAreaRect
newOriginAreaRectangle = RectToRectangle newOriginAreaRect
v = toVector (oldOrigin-newOrigin)
{vx,vy} = v
(updArea,restArea) = if (vx<0) ({originAreaRectangle & corner1={x=rright+vx,y=rtop}}, {originAreaRect & rright =rright +vx})
(if (vx>0) ({originAreaRectangle & corner2={x=rleft+vx, y=rbottom}}, {originAreaRect & rleft =rleft +vx})
(if (vy<0) ({originAreaRectangle & corner1={x=rleft, y=rbottom+vy}},{originAreaRect & rbottom=rbottom+vy})
(if (vy>0) ({originAreaRectangle & corner2={x=rright, y=rbottom+vy}},{originAreaRect & rtop =rtop +vy})
(windowdeviceFatalError "calcUpdateArea (scrolling window)" "assumption violation"))))
(updArea,restArea) = if (vx<0) ({newOriginAreaRectangle & corner1={x=rright+vx,y=rtop}}, {newOriginAreaRect & rright =rright +vx})
(if (vx>0) ({newOriginAreaRectangle & corner2={x=rleft+vx, y=rbottom}}, {newOriginAreaRect & rleft =rleft +vx})
(if (vy<0) ({newOriginAreaRectangle & corner1={x=rleft, y=rbottom+vy}},{newOriginAreaRect & rbottom=rbottom+vy})
(if (vy>0) ({newOriginAreaRectangle & corner2={x=rright, y=rtop+vy}}, {newOriginAreaRect & rtop =rtop +vy})
(windowdeviceFatalError "calcScrollUpdateArea (scrolling window)" "assumption violation"))))
scroll :: !Rect !Rect !Vector2 !*Picture -> (!Rect,!*Picture)
scroll :: !Rect !Rect !Vector2 !*Picture -> (![Rect],!*Picture)
scroll scrollRect restRect v picture
# (updRect,picture) = pictscroll scrollRect v picture
| updRect==zero
= (zero,picture)
= ([],picture)
| otherwise
= (restRect,picture)
= ([restRect],picture)
windowStateScrollActionIO _ _ _ _
= windowdeviceFatalError "windowStateScrollActionIO" "unexpected window placeholder"
......
......@@ -18,9 +18,9 @@ import windowhandle
*/
drawwindowlook :: !OSWindowMetrics !OSWindowPtr !(IdFun *Picture) !UpdateState !(WindowHandle .ls .pst) !*OSToolbox
-> (!WindowHandle .ls .pst, !*OSToolbox)
drawwindowlook` :: !OSWindowMetrics !OSWindowPtr !(St *Picture Rect) !UpdateState !(WindowHandle .ls .pst) !*OSToolbox
drawwindowlook` :: !OSWindowMetrics !OSWindowPtr !(St *Picture [Rect]) !UpdateState !(WindowHandle .ls .pst) !*OSToolbox
-> (!WindowHandle .ls .pst, !*OSToolbox)
drawinwindow :: !OSWindowMetrics !OSWindowPtr !.(St *Picture .x) !(WindowHandle .ls .pst) !*OSToolbox
-> (.x, !WindowHandle .ls .pst, !*OSToolbox)
-> (.x,!WindowHandle .ls .pst, !*OSToolbox)
......@@ -43,17 +43,17 @@ where
{w,h} = RectSize (getWindowContentRect wMetrics visScrolls (SizeToRect whSize))
wFrame = {corner1=origin,corner2={x=origin.x+w,y=origin.y+h}}
drawwindowlook` :: !OSWindowMetrics !OSWindowPtr !(St *Picture Rect) !UpdateState !(WindowHandle .ls .pst) !*OSToolbox
drawwindowlook` :: !OSWindowMetrics !OSWindowPtr !(St *Picture [Rect]) !UpdateState !(WindowHandle .ls .pst) !*OSToolbox
-> (!WindowHandle .ls .pst, !*OSToolbox)
drawwindowlook` wMetrics wPtr drawFirst updState wH=:{whSelect,whSize,whWindowInfo} tb
#! (osPict,tb) = OSgrabWindowPictContext wPtr tb
#! picture = packPicture origin (copyPen look.lookPen) True osPict tb
#! picture = pictsetcliprgn clipRgn picture
#! (additionalUpdateRect,picture)
#! (additionalUpdateArea,picture)
= drawFirst picture
updState = if (additionalUpdateRect==zero) updState {updState & updArea=[RectToRectangle additionalUpdateRect:updState.updArea]}
updState = {updState & updArea = [RectToRectangle r \\ r<-additionalUpdateArea | not (IsEmptyRect r)] ++ updState.updArea}
#! picture = appClipPicture (toRegion wFrame) (look.lookFun select updState) picture
#! (_,pen,_,osPict,tb)= unpackPicture picture
#! (_,pen,_,osPict,tb) = unpackPicture picture
#! tb = OSreleaseWindowPictContext wPtr osPict tb
#! tb = OSvalidateWindowRgn wPtr clipRgn tb // PA: added to eliminate update of window (in drawing part)
#! look = {look & lookPen=pen}
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment