Commit af49667e authored by Peter Achten's avatar Peter Achten

(PA): synchronised my local version with latest CVS version.

parent b74455b1
......@@ -11,8 +11,8 @@ import code from "cCrossCallGame_121.obj",
"cOSGameLib_121.obj"
// "ddutil.obj"
// "dsutil.obj"
//import code from library "ddraw_library"
//import code from library "dsound_library"
import code from library "ddraw_library"
import code from library "dsound_library"
gameCrossCall_12FatalError :: String String -> .x
......
wsock32.dll
WSACleanup@0
WSAStartup@8
ntohs@4
ntohl@4
accept@12
listen@8
bind@12
htons@4
socket@12
connect@12
htonl@4
send@16
recv@16
closesocket@4
WSAGetLastError@0
gethostbyname@4
inet_addr@4
ioctlsocket@12
select@20
sendto@24
recvfrom@24
getservbyname@8
WSAAsyncGetHostByName@20
WSAAsyncSelect@16
setsockopt@20
shutdown@8
__WSAFDIsSet@8
getsockopt@20
\ No newline at end of file
......@@ -18,7 +18,7 @@ import code from library "advapi32_library",
library "shell32_library",
library "winmm_library",
library "winspool_library",
library "wsock_library",
// library "wsock_library", // PA: should not be necessary
library "kernelExt_library",
library "gdiExt_library",
library "userExt_library"
......
......@@ -874,7 +874,10 @@ where
inRange :: !Int !Int !Int !Int -> Int
inRange destMin destRange sourceValue sourceRange
= destMin + (toInt (((toReal sourceValue) / (toReal sourceRange)) * (toReal destRange)))
| sourceRange == 0
= 0 // DvA: avoid obscure windows bug for ide
| otherwise
= destMin + (toInt (((toReal sourceValue) / (toReal sourceRange)) * (toReal destRange)))
OSSliderMin :== 0 // 0
OSSliderMax :== 32767 // MaxSigned2ByteInt
......
......@@ -9,11 +9,12 @@ definition module StdBitmap
import StdMaybe
from StdFile import FileSystem
from StdFile import FileSystem//, Files
from osbitmap import Bitmap
import StdPicture
//1.3
export FileSystem World
//3.1
openBitmap :: !{#Char} !*env -> (!Maybe Bitmap,!*env) | FileSystem env
/* openBitmap reads in a bitmap from file.
......
......@@ -134,12 +134,13 @@ instance Menus (Menu m) | MenuElements m where
validateMenuId :: !(Maybe Id) !(IOSt .l) -> (!Maybe Id,!IOSt .l)
validateMenuId Nothing ioState
# (mId,ioState) = openId ioState
# (mId,ioState) = openId ioState
= (Just mId,ioState)
validateMenuId (Just id) ioState
# (idtable,ioState) = ioStGetIdTable ioState
| memberIdTable id idtable = (Nothing,ioStSetIdTable idtable ioState)
| otherwise = (Just id,ioStSetIdTable idtable ioState)
# (idtable,ioState) = ioStGetIdTable ioState
# (member,idtable) = memberIdTable id idtable
| member = (Nothing,ioStSetIdTable idtable ioState)
| otherwise = (Just id,ioStSetIdTable idtable ioState)
instance Menus (PopUpMenu m) | PopUpMenuElements m where
openMenu :: .ls !(PopUpMenu m .ls (PSt .l)) !(PSt .l) -> (!ErrorReport,!PSt .l) | PopUpMenuElements m
......@@ -397,7 +398,8 @@ openRadioMenuItems rId pos radioItems ioState
| isEmpty radioItems
= (NoError,ioStSetIdTable idtable ioState)
# radioIds = filterMap (\(_,maybeId,_,_)->(isJust maybeId,fromJust maybeId)) radioItems
| not (okMembersIdTable radioIds idtable)
# (ok,idtable) = okMembersIdTable radioIds idtable
| not ok
= (ErrorIdsInUse,ioStSetIdTable idtable ioState)
| otherwise
# mId = parent.idpId
......
......@@ -46,6 +46,7 @@ instance PopUpMenuElements (ListLS m) | PopUpMenuElements m
instance PopUpMenuElements NilLS
instance PopUpMenuElements ((:+:) m1 m2) | PopUpMenuElements m1
& PopUpMenuElements m2
instance PopUpMenuElements (SubMenu m) | PopUpMenuElements m
instance PopUpMenuElements RadioMenu
instance PopUpMenuElements MenuItem
instance PopUpMenuElements MenuSeparator
......@@ -273,6 +273,28 @@ instance PopUpMenuElements ((:+:) m1 m2) | PopUpMenuElements m1 & PopUpMenuEleme
getPopUpMenuElementType _
= ""
instance PopUpMenuElements (SubMenu m) | PopUpMenuElements m where
popUpMenuElementToHandles :: !(SubMenu m .ls (PSt .l)) !(PSt .l) -> (![MenuElementState .ls (PSt .l)],!PSt .l) | PopUpMenuElements m
popUpMenuElementToHandles (SubMenu title items atts) pState
# (ms,pState) = popUpMenuElementToHandles items pState
(selectAtt,atts) = validateSelectState atts
(idAtt, atts) = validateId atts
= ( [menuElementHandleToMenuElementState
(SubMenuHandle { mSubHandle = OSNoMenu
, mSubMenuId = idAtt
, mSubOSMenuNr= 0
, mSubItems = map menuElementStateToMenuElementHandle ms
, mSubTitle = title
, mSubSelect = enabled selectAtt
, mSubAtts = atts
}
)
]
, pState
)
getPopUpMenuElementType _
= "SubMenu"
instance PopUpMenuElements RadioMenu where
popUpMenuElementToHandles :: !(RadioMenu .ls (PSt .l)) !(PSt .l) -> (![MenuElementState .ls (PSt .l)],!PSt .l)
popUpMenuElementToHandles radioMenu pState
......
......@@ -22,11 +22,12 @@ class Receivers rdef where
instance Receivers (Receiver m) where
// MW11 was openReceiver :: .ls !(Receiver m .ls (PSt .l)) !(PSt .l) -> (!ErrorReport,!PSt .l)
openReceiver :: .ls !*(*Receiver m .ls (PSt .l)) !(PSt .l) -> (!ErrorReport,!PSt .l)
openReceiver :: .ls !*(Receiver m .ls (PSt .l)) !(PSt .l) -> (!ErrorReport,!PSt .l)
openReceiver ls rDef pState
# pState = receiverFunctions.dOpen pState
# (idtable,ioState) = ioStGetIdTable pState.io
| memberIdTable id idtable
# (member,idtable) = memberIdTable id idtable
| member
= (ErrorIdsInUse,{pState & io=ioStSetIdTable idtable ioState})
# (rt,ioState) = ioStGetReceiverTable ioState
# (maybe_parent,rt) = getReceiverTableEntry id rt
......@@ -63,16 +64,17 @@ instance Receivers (Receiver m) where
reopenReceiver ls rDef pState
= openReceiver ls rDef (appPIO (closeReceiver (rIdtoId (receiverDefRId rDef))) pState)
*/
getReceiverType :: *(*Receiver m .ls .pst) -> ReceiverType
getReceiverType :: *(Receiver m .ls .pst) -> ReceiverType
getReceiverType _ = "Receiver"
instance Receivers (Receiver2 m r) where
// MW11 was openReceiver :: .ls !(Receiver2 m r .ls (PSt .l)) !(PSt .l) -> (!ErrorReport,!PSt .l)
openReceiver :: .ls !*(*Receiver2 m r .ls (PSt .l)) !(PSt .l) -> (!ErrorReport,!PSt .l)
openReceiver :: .ls !*(Receiver2 m r .ls (PSt .l)) !(PSt .l) -> (!ErrorReport,!PSt .l)
openReceiver ls rDef pState
# pState = receiverFunctions.dOpen pState
# (idtable,ioState) = ioStGetIdTable pState.io
| memberIdTable id idtable
# (member,idtable) = memberIdTable id idtable
| member
= (ErrorIdsInUse,{pState & io=ioStSetIdTable idtable ioState})
# (rt,ioState) = ioStGetReceiverTable ioState
# (maybe_parent,rt) = getReceiverTableEntry id rt
......@@ -110,7 +112,7 @@ instance Receivers (Receiver2 m r) where
= openReceiver ls rDef (appPIO (closeReceiver (r2IdtoId (receiver2DefR2Id rDef))) pState)
*/
getReceiverType :: *(*Receiver2 m r .ls .pst) -> ReceiverType
getReceiverType :: *(Receiver2 m r .ls .pst) -> ReceiverType
getReceiverType _ = "Receiver2"
......@@ -134,19 +136,19 @@ closeReceiver id ioState
# ioState = ioStSetDevice (ReceiverSystemState {rReceivers=rsHs}) ioState
| not found
= ioState
| otherwise
# (idtable,ioState) = ioStGetIdTable ioState
ioState = ioStSetIdTable (snd (removeIdFromIdTable id idtable)) ioState
ioState = unbindRId id ioState
# (idtable,ioState) = ioStGetIdTable ioState
# ioState = ioStSetIdTable (snd (removeIdFromIdTable id idtable)) ioState
# ioState = unbindRId id ioState
// MW11..
ioState = ioStSetRcvDisabled True ioState
connectedIds = rsH.rHandle.rConnected
ioState = seq (map closeReceiver connectedIds) ioState
inetInfo = rsH.rHandle.rInetInfo
| isNothing inetInfo
= ioState
# (_,_,_,closeFun) = fromJust inetInfo
ioState = appIOToolbox closeFun ioState
# ioState = ioStSetRcvDisabled True ioState
connectedIds = rsH.rHandle.rConnected
# ioState = seq (map closeReceiver connectedIds) ioState
inetInfo = rsH.rHandle.rInetInfo
| isNothing inetInfo
= ioState
| otherwise
# (_,_,_,closeFun) = fromJust inetInfo
# ioState = appIOToolbox closeFun ioState
// ..MW11
= ioState
where
......
......@@ -79,7 +79,8 @@ instance Timers (Timer t) | TimerElements t where
= (Just tId,ioState)
validateTimerId (Just id) ioState
# (it,ioState) = ioStGetIdTable ioState
| memberIdTable id it = (Nothing,ioStSetIdTable it ioState)
# (member,it) = memberIdTable id it
| member = (Nothing,ioStSetIdTable it ioState)
| otherwise = (Just id,ioStSetIdTable it ioState)
addAbleTimerToTimerTable :: !Bool !TimerLoc !TimerInterval !(IOSt .l) -> IOSt .l
......
......@@ -171,7 +171,8 @@ controlIdsAreConsistent :: !SystemId !Id ![WElementHandle .ls .pst] !*ReceiverTa
-> (!Bool,![WElementHandle .ls .pst],!*ReceiverTable,!*IdTable)
controlIdsAreConsistent ioId wId itemHs rt it
# (ids,itemHs) = getWElementControlIds itemHs
| not (okMembersIdTable ids it)
# (ok,it) = okMembersIdTable ids it
| not ok
= (False,itemHs,rt,it)
# idParent = {idpIOId=ioId,idpDevice=WindowDevice,idpId=wId}
(ok,it) = addIdsToIdTable [(id,idParent) \\ id<-ids] it
......
......@@ -56,12 +56,12 @@ initialIdTable :: *IdTable
/* memberIdTable checks if the Id argument is a member of the IdTable (True) or not (False).
*/
memberIdTable :: !Id !IdTable -> Bool
memberIdTable :: !Id !*IdTable -> (!Bool,!*IdTable)
/* okMembersIdTable returns True only iff the list of Ids contains no duplicates and all Ids in
the list do not occur in the IdTable.
*/
okMembersIdTable :: ![Id] !IdTable -> Bool
okMembersIdTable :: ![Id] !*IdTable -> (!Bool,!*IdTable)
/* getIdParent(s) returns the currently bound IdParent associated with the argument Id(s).
If such a parent was found, Just parent is returned. Otherwise, Nothing is returned.
......
......@@ -162,12 +162,12 @@ initialIdTable
]
*/ }
memberIdTable :: !Id !IdTable -> Bool
memberIdTable (CustomId nr) {customIds} = membersortlist nr customIds
memberIdTable (CustomRId nr) {customRIds} = membersortlist nr customRIds
memberIdTable (CustomR2Id nr) {customR2Ids} = membersortlist nr customR2Ids
memberIdTable (SysId nr) {sysIds} = membersortlist nr sysIds
memberIdTable (SpecialId _) _ = False
memberIdTable :: !Id !*IdTable -> (!Bool,!*IdTable)
memberIdTable (CustomId nr) it=:{customIds} = (membersortlist nr customIds,it)
memberIdTable (CustomRId nr) it=:{customRIds} = (membersortlist nr customRIds,it)
memberIdTable (CustomR2Id nr) it=:{customR2Ids} = (membersortlist nr customR2Ids,it)
memberIdTable (SysId nr) it=:{sysIds} = (membersortlist nr sysIds,it)
memberIdTable (SpecialId _) it = (False,it)
// membersortlist checks for membership in a < sorted list
membersortlist :: !Int ![(Int,x)] -> Bool
......@@ -177,9 +177,26 @@ membersortlist x [(y,_):ys]
| otherwise = membersortlist x ys
membersortlist _ _ = False
okMembersIdTable :: ![Id] !IdTable -> Bool
okMembersIdTable :: ![Id] !*IdTable -> (!Bool,!*IdTable)
okMembersIdTable ids idTable
= noDuplicates ids && all (\id->not (memberIdTable id idTable)) ids
| not (noDuplicates ids)
= (False,idTable)
| otherwise
= allList noMember ids idTable
where
noMember :: !Id !*IdTable -> (!Bool,!*IdTable)
noMember id table
# (yes,table) = memberIdTable id table
= (not yes,table)
allList :: !(.x .s -> .(Bool,.s)) ![.x] !.s -> (!Bool,!.s)
allList cond [x:xs] s
# (ok,s) = cond x s
| ok = allList cond xs s
| otherwise = (False,s)
allList _ _ s
= (True,s)
getIdParent :: !Id !*IdTable -> (!Maybe IdParent,!*IdTable)
getIdParent (CustomId nr) idTable=:{customIds} = (getparentsortlist nr customIds, idTable)
......
......@@ -92,7 +92,8 @@ menuIdsAreConsistent :: !SystemId !Id !*[MenuElementHandle .ls .pst] !*ReceiverT
-> (!Bool,!*[MenuElementHandle .ls .pst],!*ReceiverTable,!*IdTable)
menuIdsAreConsistent ioId menuId itemHs rt it
# (itemHs,ids) = stateMap getMenuElementMenuId itemHs []
| not (okMembersIdTable ids it)
# (ok,it) = okMembersIdTable ids it
| not ok
= (False,itemHs,rt,it)
# (ok,it) = addIdsToIdTable (map (\id->(id,{idpIOId=ioId,idpDevice=MenuDevice,idpId=menuId})) ids) it
# (itemHs,rt) = bindReceiverMenuIds ioId menuId itemHs rt
......
......@@ -160,8 +160,9 @@ where
= att
validatePopUpMenuFunction (MenuReceiverHandle _)
= menucreateFatalError "validatePopUpMenuFunction" "Receiver(2) should not be an element of PopUpMenus"
validatePopUpMenuFunction (SubMenuHandle _)
= menucreateFatalError "validatePopUpMenuFunction" "SubMenu should not be an element of PopUpMenus"
validatePopUpMenuFunction (SubMenuHandle submH=:{mSubItems})
// = menucreateFatalError "validatePopUpMenuFunction" "SubMenu should not be an element of PopUpMenus"
= SubMenuHandle {submH & mSubItems = map validatePopUpMenuFunction mSubItems}
validatePopUpMenuFunction (RadioMenuHandle radioH=:{mRadioItems})
= RadioMenuHandle {radioH & mRadioItems=map validatePopUpMenuFunction mRadioItems}
validatePopUpMenuFunction (MenuSeparatorHandle separatorH)
......
......@@ -30,7 +30,8 @@ where
bindTimerElementIds` :: !SystemId !Id !*(TimerElementHandle .ls .pst) !*ReceiverTable !*IdTable
-> (!Bool, !*TimerElementHandle .ls .pst, !*ReceiverTable,!*IdTable)
bindTimerElementIds` pid timerid (TimerReceiverHandle itemH=:{tReceiverHandle=trH}) rt it
| memberIdTable rid it
# (member,it) = memberIdTable rid it
| member
= (False,TimerReceiverHandle itemH,rt,it)
# (maybeRTE,rt) = getReceiverTableEntry rid rt
| isJust maybeRTE // This situation should not occur: the IdTable didn't contain the id while the ReceiverTable does.
......
......@@ -84,12 +84,22 @@ where
pState1 = appPIO (ioStSetDevice timers1) pState
(tH1,pState2) = letTimerDoIO nrOfIntervals tH pState1
timers1 = TimerSystemState {timers & tTimers=tHs1++[tH1]}
/* Compiling with 'Reuse Unique Nodes' causes a space-leak in this function definition.
Therefore it is replaced temporarily with the function below.
letTimerDoIO :: !NrOfIntervals !(TimerStateHandle .ps) !.ps -> (!TimerStateHandle .ps, .ps)
letTimerDoIO nrOfIntervals (TimerLSHandle tsH=:{tState=ls,tHandle=tH=:{tFun}}) pState
= (TimerLSHandle {tsH & tState=ls1},pState1)
where
(ls1,pState1) = tFun nrOfIntervals (ls,pState)
*/
letTimerDoIO :: !NrOfIntervals !(TimerStateHandle .ps) !.ps -> (!TimerStateHandle .ps, .ps)
letTimerDoIO nrOfIntervals (TimerLSHandle tsH=:{tState=ls,tHandle=tH=:{tFun}}) pState
= (TimerLSHandle {tsH & tState=ls1},pState1)
where
(ls1,pState1) = apply tFun nrOfIntervals ls pState
apply :: !(TimerFunction *(.ls,.pst)) !NrOfIntervals .ls !.pst -> (.ls,!.pst)
apply f d_i ls pst = f d_i (ls,pst)
timerIO deviceEvent=:(ReceiverEvent (QASyncMessage event)) pState
= (deviceEvent,timerQASync event pState)
......
......@@ -328,7 +328,7 @@ setcontrolpositions wMetrics newPoss
viewFrame = posSizeToRectangle origin {w=curw,h=curh}
updState = rectangleToUpdateState viewFrame
drawbackground = if (whKind==IsDialog) (\x y->(x,y)) (drawwindowlook wMetrics wPtr id updState)
# (wH,tb) = drawbackground wH tb
// # (wH,tb) = drawbackground wH tb // DvA: seems to be unnecessary
# (updRgn,newItems,tb) = relayoutControls wMetrics whSelect whShow wFrame wFrame zero zero wPtr whDefaultId oldItems` wH.whItems tb
# (wH,tb) = updatewindowbackgrounds wMetrics updRgn wshIds {wH & whItems=newItems} tb
# tb = osValidateWindowRect wPtr (sizeToRect whSize) tb
......
......@@ -42,7 +42,7 @@ exactWindowSize :: OSWindowMetrics ViewDomain !Size Bool Bool !WindowKind -> Siz
*/
exactWindowPos :: !OSWindowMetrics !Size !(Maybe ItemPos) !WindowKind !WindowMode !(WindowHandles .pst) !*OSToolbox
-> (!Point2, !WindowHandles .pst, !*OSToolbox)
-> (!Point2, !WindowHandles .pst, !*OSToolbox)
/* exactWindowPos determines the exact position of a window.
The size argument must be the exact size of the window.
The ItemPos argument must be a valid ItemPos attribute. It should not be one of (LeftOf/RightTo/Above/Below)Prev.
......
......@@ -34,7 +34,8 @@ validateWindowId Nothing ioState
= (Just wId,ioState)
validateWindowId (Just id) ioState
# (idtable,ioState) = ioStGetIdTable ioState
| memberIdTable id idtable = (Nothing,ioStSetIdTable idtable ioState)
# (member,idtable) = memberIdTable id idtable
| member = (Nothing,ioStSetIdTable idtable ioState)
| otherwise = (Just id,ioStSetIdTable idtable ioState)
......@@ -469,29 +470,33 @@ where
-> (!Point2,!WindowHandles .pst, !*OSToolbox)
getItemPosPosition wMetrics size itemPos windows=:{whsWindows=wsHs} tb
| isRelative
# (rect,tb) = osScreenrect tb
screenDomain = rectToRectangle rect
screenOrigin = {x=rect.rleft,y=rect.rtop}
# (before,after) = uspan (unidentifyWindow (toWID relativeTo)) wsHs
(wPtr,wsH,after) = case after of
[] -> windowvalidateFatalError "getItemPosPosition" "target window could not be found"
[wsH=:{wshIds={wPtr}}:after] -> (wPtr,wsH,after)
(relativeSize,wsH) = getWindowStateHandleSize wsH
windows = {windows & whsWindows=before++[wsH:after]}
# ((relativeX,relativeY),tb)= osGetWindowPos wPtr tb
/* PA: do not use OSgetWindowViewFrameSize.
# ((relativeW,relativeH),tb)= OSgetWindowViewFrameSize wPtr tb
# (rect,tb) = osScreenrect tb
screenDomain = rectToRectangle rect
screenOrigin = {x=rect.rleft,y=rect.rtop}
#! (before,after) = uspan (unidentifyWindow (toWID relativeTo)) wsHs
(wPtr,wsH,after) = case after of
[]
-> windowvalidateFatalError "getItemPosPosition" "target window could not be found"
[wsH:after]
# (wPtr,wsH) = wsH!wshIds.wPtr
-> (wPtr,wsH,after)
(relativeSize,wsH) = getWindowStateHandleSize wsH
wsHs = before ++ [wsH:after]
windows = {windows & whsWindows=wsHs}
# ((relativeX,relativeY),tb)= osGetWindowPos wPtr tb
/* PA: do not use OSgetWindowViewFrameSize.
# ((relativeW,relativeH),tb)= OSgetWindowViewFrameSize wPtr tb
*/
(relativeW,relativeH) = toTuple relativeSize
(exactW,exactH) = (size.w,size.h)
{vx,vy} = itemPosOffset (snd itemPos) screenDomain screenOrigin
pos = case (fst itemPos) of
(relativeW,relativeH) = toTuple relativeSize
(exactW,exactH) = (size.w,size.h)
{vx,vy} = itemPosOffset (snd itemPos) screenDomain screenOrigin
pos = case (fst itemPos) of
(LeftOf _) -> {x=relativeX+vx-exactW, y=relativeY+vy}
(RightTo _) -> {x=relativeX+vx+relativeW,y=relativeY+vy}
(Above _) -> {x=relativeX+vx, y=relativeY+vy-exactH}
(Below _) -> {x=relativeX+vx, y=relativeY+vy+relativeH}
other -> windowvalidateFatalError "getItemPosPosition" "unexpected ItemLoc alternative"
= (pos,windows,tb)
= (pos,windows,tb)
where
(isRelative,relativeTo) = isRelativeItemPos itemPos
......
Markdown is supported
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