Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
clean-compiler-and-rts
stdenv
Commits
47644197
Commit
47644197
authored
Dec 23, 1999
by
Peter Achten
Browse files
(PA) Modernised code. GameObjectState record introduced.
Object renamed to GameObject. Strictness information added.
parent
679155a4
Changes
15
Expand all
Hide whitespace changes
Inline
Side-by-side
ObjectIO/GameLib/GameFunctions.dcl
View file @
47644197
...
...
@@ -20,22 +20,22 @@ GameBitmapDone :: !BID !*OSToolbox -> (!GRESULT, !*OSToolbox)
ClearAllGameBitmaps
::
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
SetTransparentColor
::
!
BID
Point2
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
SetTransparentColor
::
!
BID
!
Point2
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
InitBlockSequence
::
!
BID
(!
SEQID
,
[(
Int
,
Int
)])
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
InitBlockSequence
::
!
BID
!
(!
SEQID
,
!
[(
Int
,
Int
)])
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
InitGameLayerMap
::
!
MAPID
!
BID
[{#
Int
}]
!
Bool
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
InitGameLayerMap
::
!
MAPID
!
BID
!
[{#
Int
}]
!
Bool
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
GameLayerMapDone
::
!
MAPID
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
// OSGameData gs should only contain the current level here!
RunGameEngine
::
(
OSGameData
gs
)
!*
OSToolbox
->
(
gs
,
!*
OSToolbox
)
RunGameEngine
::
!
(
OSGameData
.
gs
)
!*
OSToolbox
->
(
.
gs
,
!*
OSToolbox
)
SetGameBoundMap
::
!
Int
!
Int
[{#
Int
}]
!
Int
!
Int
!
Int
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
MoveScreenTo
::
Point2
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
MoveScreenTo
::
!
Point2
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
InitSpriteAnimation
::
!
BID
[(
Int
,
Int
)]
!
Bool
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
InitSpriteAnimation
::
!
BID
!
[(
Int
,
Int
)]
!
Bool
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
InitGameObject
::
!
ObjectType
!
SubType
!
Point2
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
...
...
@@ -51,4 +51,3 @@ ShowStatistic :: !Int !Int !{#Char} !Int !Colour !{#Char} !Int !Bool !Bool !Boo
PlayMusic
::
!{#
Char
}
!
Bool
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
StopMusic
::
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
ObjectIO/GameLib/GameFunctions.icl
View file @
47644197
...
...
@@ -51,15 +51,15 @@ ClearAllGameBitmaps :: !*OSToolbox -> (!GRESULT, !*OSToolbox)
ClearAllGameBitmaps
tb
=
OSClearAllGameBitmaps
tb
SetTransparentColor
::
!
BID
Point2
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
SetTransparentColor
::
!
BID
!
Point2
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
SetTransparentColor
id
p
tb
=
OSSetTransparentColor
id
p
.
x
p
.
y
tb
InitBlockSequence
::
!
BID
(!
SEQID
,
[(
Int
,
Int
)])
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
InitBlockSequence
::
!
BID
!
(!
SEQID
,
!
[(
Int
,
Int
)])
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
InitBlockSequence
bid
(
seqid
,
seq
)
tb
=
OSInitBlockSequence
bid
seqid
(
TupleListStr
seq
)
tb
InitGameLayerMap
::
!
MAPID
!
BID
[{#
Int
}]
!
Bool
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
InitGameLayerMap
::
!
MAPID
!
BID
!
[{#
Int
}]
!
Bool
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
InitGameLayerMap
mapid
bid
levelmap
tile
tb
=
OSInitGameLayerMap
mapid
bid
(
OSIntListArrayToString
levelmap
)
(
MapWidth
levelmap
)
(
MapHeight
levelmap
)
tile
tb
...
...
@@ -68,7 +68,7 @@ GameLayerMapDone :: !MAPID !*OSToolbox -> (!GRESULT, !*OSToolbox)
GameLayerMapDone
mapid
tb
=
OSGameLayerMapDone
mapid
tb
RunGameEngine
::
(
OSGameData
gs
)
!*
OSToolbox
->
(
gs
,
!*
OSToolbox
)
RunGameEngine
::
!
(
OSGameData
.
gs
)
!*
OSToolbox
->
(
.
gs
,
!*
OSToolbox
)
RunGameEngine
gd
tb
=
OSRunGameEngine
gd
tb
...
...
@@ -77,11 +77,11 @@ SetGameBoundMap w h boundmap objstart startobjx startobjy tb
=
OSSetGameBoundMap
w
h
(
OSIntListArrayToString
boundmap
)
(
MapWidth
boundmap
)
(
MapHeight
boundmap
)
objstart
startobjx
startobjy
tb
MoveScreenTo
::
Point2
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
MoveScreenTo
::
!
Point2
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
MoveScreenTo
p
tb
=
OSMoveScreenTo
p
.
x
p
.
y
tb
InitSpriteAnimation
::
!
BID
[(
Int
,
Int
)]
!
Bool
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
InitSpriteAnimation
::
!
BID
!
[(
Int
,
Int
)]
!
Bool
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
InitSpriteAnimation
bid
seq
loop
tb
=
OSInitSpriteAnimation
bid
(
TupleListStr
seq
)
loop
tb
...
...
@@ -112,4 +112,3 @@ PlayMusic midifile restart tb
StopMusic
::
!*
OSToolbox
->
(!
GRESULT
,
!*
OSToolbox
)
StopMusic
tb
=
OSStopMusic
tb
ObjectIO/GameLib/StdGSt.dcl
View file @
47644197
definition
module
StdGSt
from
gst
import
GSt
,
appGSt
,
accGSt
// ********************************************************************************
// Clean Standard Game library, version 1.2
//
// StdGSt imports the GSt type and some handy access functions.
// ********************************************************************************
from
gst
import
GSt
,
appGSt
,
accGSt
,
IdFun
,
St
ObjectIO/GameLib/StdGame.dcl
View file @
47644197
definition
module
StdGame
// ********************************************************************************
// Clean Standard Game library, version 1.2
//
// StdGame contains the functions one needs during a game.
// ********************************************************************************
import
StdInt
,
StdString
from
StdIOCommon
import
ErrorReport
,
NoError
,
ErrorViolateDI
,
ErrorIdsInUse
,
ErrorUnknownObject
,
OtherError
NoError
,
ErrorViolateDI
,
ErrorIdsInUse
,
ErrorUnknownObject
,
OtherError
from
StdPSt
import
PSt
,
IOSt
import
StdGameDef
from
osgame
import
GRESULT
// PA: this type should be shielded
from
osgame
import
GRESULT
/* predefined bounds */
BND_MAP_CODES
:==
(
1
<<
30
)
BND_STATIC_BOUNDS
:==
(
1
<<
31
)
BND_MAP_CODES
:==
1
<<
30
BND_STATIC_BOUNDS
:==
1
<<
31
/* skipmove constant */
SK_FOREVER
:==
(
~1
)
SK_FOREVER
:==
-1
::
NoState
=
NoState
OpenGame
::
gs
(
Game
gs
)
[
GameAttribute
gs
]
!(
PSt
.
l
)
->
(
ErrorReport
,
!
PSt
.
l
)
openGame
::
.
gs
!(
Game
.
gs
)
![
GameAttribute
.
gs
]
!(
PSt
.
l
)
->
(!
ErrorReport
,!
PSt
.
l
)
C
reateGameBitmap
::
!
GameBitmap
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
c
reateGameBitmap
::
!
GameBitmap
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
C
reateAnimation
::
!
Sprite
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
c
reateAnimation
::
!
Sprite
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
CreateNewGameObject
::
!
ObjectType
!
SubType
!
Point2
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
createNewGameObject
::
!
ObjectType
!
SubType
!
Point2
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
::
ObjectFocus
=
{
scrollleft
::
Int
,
scrollup
::
Int
,
scrollright
::
Int
,
scrolldown
::
Int
,
maxxscrollspeed
::
Int
,
maxyscrollspeed
::
Int
=
{
scrollleft
::
!
Int
,
scrollup
::
!
Int
,
scrollright
::
!
Int
,
scrolldown
::
!
Int
,
maxxscrollspeed
::
!
Int
,
maxyscrollspeed
::
!
Int
}
instance
zero
ObjectFocus
C
reateObjectFocus
::
!
ObjectFocus
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
c
reateObjectFocus
::
!
ObjectFocus
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
::
EventTarget
=
Self
|
AllObjects
|
BoundType
Bounds
// modified 01/11/99
CreateUserGameEvent
::
!
EventType
!
EventPar
!
EventPar
!
EventTarget
!
SubType
!
GameTime
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
createUserGameEvent
::
!
EventType
!
EventPar
!
EventPar
!
EventTarget
!
SubType
!
GameTime
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
// added 01/11/99
ANY_SUBTYPE
:==
(
~1
)
ANY_SUBTYPE
:==
-1
MAX_VOLUME
:==
10000
MIN_VOLUME
:==
0
...
...
@@ -54,7 +69,7 @@ MIN_VOLUME :== 0
::
Volume
:==
Int
PAN_LEFT
:==
~
10000
PAN_LEFT
:==
-
10000
PAN_CENTER
:==
0
PAN_RIGHT
:==
10000
...
...
@@ -66,22 +81,30 @@ DEFAULT_FREQUENCY :== 0
::
Frequency
:==
Int
PlaySoundSample
::
!
SoundID
!
Volume
!
Pan
!
Frequency
!
GameTime
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
playSoundSample
::
!
SoundID
!
Volume
!
Pan
!
Frequency
!
GameTime
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
GetBoundMap
::
!
Int
!
Int
!(
GSt
.
gs
)
->
(!
GRESULT
,
!(!
Int
,
!
DirectionSet
),
!
GSt
.
gs
)
SetBoundMap
::
!
Int
!
Int
(!
Int
,
!
DirectionSet
)
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
getBoundMap
::
!
Int
!
Int
!(
GSt
.
gs
)
->
(!
GRESULT
,
!(!
Int
,
!
DirectionSet
),
!
GSt
.
gs
)
setBoundMap
::
!
Int
!
Int
!(!
Int
,
!
DirectionSet
)
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
defaultInitObject
::
.
Size
.
a
.
Int
.
Point2
.
GameTime
!*(
GSt
.
b
)
->
(!(.
a
,!.
ObjectRec
),!*
GSt
.
b
)
defaultGameObject
::
.
Int
.
Size
b
->
.
Object
*(
GSt
.
c
)
defaultObjectRec
::
.
Int
.
Point2
.
Size
.
GameTime
!*(
GSt
.
a
)
->
(!.
ObjectRec
,!*
GSt
.
a
)
defaultInitObject
::
Size
state
SubType
Point2
GameTime
!*(
GSt
.
gs
)
->
GameObjectState
state
*(
GSt
.
gs
)
defaultGameObject
::
!
ObjectType
!
Size
state
->
GameObject
*(
GSt
.
gs
)
defaultObjectRec
::
SubType
Point2
Size
GameTime
!*(
GSt
.
gs
)
->
(!
GameObjectRec
,!*
GSt
.
gs
)
B
lankScreen
::
Level
(
GSt
gs
)
b
lankScreen
::
Level
(
GSt
.
gs
)
defaultShadow
::
Int
->
Shadow
defaultShadow
::
!
Int
->
Shadow
defaultMovement
::
Movement
defaultScrollMovement
::
Int
->
Movement
defaultMovement
::
Movement
defaultScrollMovement
::
!
Int
->
Movement
alignCentered
::
Alignment
alignCentered
::
Alignment
ObjectIO/GameLib/StdGame.icl
View file @
47644197
implementation
module
StdGame
import
StdArray
,
StdBool
,
StdClass
,
StdInt
,
StdList
,
StdMisc
import
StdArray
,
StdBool
,
StdClass
,
StdFunc
,
StdInt
,
StdList
,
StdMisc
import
StdId
import
fixed
,
GameFunctions
,
gamehandle
,
gameutils
,
gst
from
gameobjectutils
import
toBoundMapCode
,
fromBoundMapCode
...
...
@@ -13,18 +13,15 @@ from ostypes import OSNoWindowPtr
/* predefined bounds */
BND_MAP_CODES
:==
(
1
<<
30
)
BND_STATIC_BOUNDS
:==
(
1
<<
31
)
BND_MAP_CODES
:==
1
<<
30
BND_STATIC_BOUNDS
:==
1
<<
31
/* skipmove constant */
SK_FOREVER
:==
(
~1
)
SK_FOREVER
:==
-1
::
NoState
=
NoState
OpenGame
::
gs
(
Game
gs
)
[
GameAttribute
gs
]
!(
PSt
.
l
)
->
(
ErrorReport
,
!(
PSt
.
l
))
OpenGame
gs
gdef
attr
ps
openGame
::
.
gs
!(
Game
.
gs
)
![
GameAttribute
.
gs
]
!(
PSt
.
l
)
->
(!
ErrorReport
,
!
PSt
.
l
)
openGame
gs
gdef
attr
ps
#
(
wId
,
ps
)
=
accPIO
openId
ps
#
size
=
findSize
attr
{
w
=
320
,
h
=
240
}
#
bpp
=
findBPP
attr
8
...
...
@@ -37,13 +34,13 @@ OpenGame gs gdef attr ps
#
ps
=
appPIO
(
setIOToolbox
tb
)
ps
=
(
NoError
,
ps
)
where
findSize
::
[
GameAttribute
gs
]
Size
->
Size
findSize
::
!
[
GameAttribute
.
gs
]
!
Size
->
Size
findSize
[]
s
=
s
findSize
[
(
ScreenSize
x
)
:
xs
]
s
=
x
findSize
[
ScreenSize
x
:
xs
]
s
=
x
findSize
[
x
:
xs
]
s
=
findSize
xs
s
findBPP
::
[
GameAttribute
gs
]
Int
->
Int
findBPP
::
!
[
GameAttribute
.
gs
]
!
Int
->
Int
findBPP
[]
s
=
s
findBPP
[
(
ColorDepth
x
)
:
xs
]
s
=
x
findBPP
[
ColorDepth
x
:
xs
]
s
=
x
findBPP
[
x
:
xs
]
s
=
findBPP
xs
s
// always full screen, game in a window not implemented yet
...
...
@@ -70,7 +67,7 @@ where
#
pState
=
appPIO
decreaseWindowBound
pState
=
(
NoError
,
pState
)
PlayLevels
::
Int
gs
(
Game
gs
)
!*
OSToolbox
->
(
ErrorReport
,
!*
OSToolbox
)
PlayLevels
::
!
Int
.
gs
!
(
Game
.
gs
)
!*
OSToolbox
->
(
!
ErrorReport
,
!*
OSToolbox
)
PlayLevels
level
gs
gdef
tb
|
level
==
0
=
(
NoError
,
tb
)
...
...
@@ -81,28 +78,28 @@ PlayLevels level gs gdef tb
#
(
gs
,
tb
)
=
fromGSt
gst
=
PlayLevels
nextlevel
gs
gdef
tb
FindMaxID
::
a
[
a
]
->
a
|
<
a
FindMaxID
::
a
!
[
a
]
->
a
|
<
a
FindMaxID
x
[]
=
x
FindMaxID
x
[
y
:
ys
]
|
y
>
x
=
FindMaxID
y
ys
|
otherwise
=
FindMaxID
x
ys
InitLayers
::
[
Layer
]
[
BID
]
[
MAPID
]
!*
OSToolbox
->
([
BID
],
[
MAPID
],
!*
OSToolbox
)
InitLayers
::
!
[
Layer
]
!
[
BID
]
!
[
MAPID
]
!*
OSToolbox
->
(
!
[
BID
],
!
[
MAPID
],
!*
OSToolbox
)
InitLayers
[]
bids
mapids
tb
=
(
bids
,
mapids
,
tb
)
InitLayers
[
l
:
ls
]
bids
mapids
tb
#
(
bids
,
mapids
,
tb
)
=
InitLayer
l
bids
mapids
tb
=
InitLayers
ls
bids
mapids
tb
MaybeSetTransparentColor
::
BID
(
Maybe
Point2
)
!*
OSToolbox
->
(
GRESULT
,
!*
OSToolbox
)
MaybeSetTransparentColor
::
!
BID
!
(
Maybe
Point2
)
!*
OSToolbox
->
(
!
GRESULT
,
!*
OSToolbox
)
MaybeSetTransparentColor
_
Nothing
tb
=
(
GR_OK
,
tb
)
MaybeSetTransparentColor
bid
(
Just
p
)
tb
=
SetTransparentColor
bid
p
tb
MovementFunctions
::
[
Layer
]
->
[
(
Movement
)
]
MovementFunctions
::
!
[
Layer
]
->
[
Movement
]
MovementFunctions
[]
=
[]
MovementFunctions
[
l
:
ls
]
=
[
l
.
movement
]
++
(
MovementFunctions
ls
)
MovementFunctions
[
l
:
ls
]
=
[
l
.
movement
]
++
MovementFunctions
ls
InitLayer
::
Layer
[
BID
]
[
MAPID
]
!*
OSToolbox
->
([
BID
],
[
MAPID
],
!*
OSToolbox
)
InitLayer
::
!
Layer
!
[
BID
]
!
[
MAPID
]
!*
OSToolbox
->
(
!
[
BID
],
!
[
MAPID
],
!*
OSToolbox
)
InitLayer
l
bids
mapids
tb
#
(
newbid
,
tb
)
=
InitGameBitmap
0
b
.
bitmapname
(
us
.
w
*
nh
)
(
us
.
h
*
nv
)
us
.
w
us
.
h
tb
// newbid
#
(_,
tb
)
=
MaybeSetTransparentColor
newbid
b
.
transparent
tb
...
...
@@ -113,33 +110,33 @@ where
b
=
l
.
bmp
us
=
b
.
unitsize
(
nh
,
nv
)
=
b
.
dimensions
newmapid
=
(
(
FindMaxID
0
mapids
)
+
1
)
newmapid
=
(
FindMaxID
0
mapids
)
+
1
InitBlockSequences
::
BID
[
TileSequence
]
!*
OSToolbox
->
!*
OSToolbox
InitBlockSequences
::
!
BID
!
[
TileSequence
]
!*
OSToolbox
->
!*
OSToolbox
InitBlockSequences
bid
[]
tb
=
tb
InitBlockSequences
bid
[
s
:
ss
]
tb
#
(_,
tb
)
=
InitBlockSequence
bid
s
tb
=
InitBlockSequences
bid
ss
tb
LayersDone
::
[
BID
]
[
MAPID
]
!*
OSToolbox
->
!*
OSToolbox
LayersDone
::
!
[
BID
]
!
[
MAPID
]
!*
OSToolbox
->
!*
OSToolbox
LayersDone
bids
mapids
tb
#
tb
=
MapsDone
mapids
tb
#
tb
=
BitmapsDone
bids
tb
=
tb
MapsDone
::
[
MAPID
]
!*
OSToolbox
->
!*
OSToolbox
MapsDone
::
!
[
MAPID
]
!*
OSToolbox
->
!*
OSToolbox
MapsDone
[]
tb
=
tb
MapsDone
[
m
:
ms
]
tb
#
(_,
tb
)
=
GameLayerMapDone
m
tb
=
MapsDone
ms
tb
BitmapsDone
::
[
BID
]
!*
OSToolbox
->
!*
OSToolbox
BitmapsDone
::
!
[
BID
]
!*
OSToolbox
->
!*
OSToolbox
BitmapsDone
[]
tb
=
tb
BitmapsDone
[
b
:
bs
]
tb
#
(_,
tb
)
=
GameBitmapDone
b
tb
=
BitmapsDone
bs
tb
PlayLevel
::
Int
gs
(
GameHandle
gs
)
!*
OSToolbox
->
(
ErrorReport
,
gs
,!*
OSToolbox
)
PlayLevel
::
!
Int
.
gs
!
(
GameHandle
.
gs
)
!*
OSToolbox
->
(
!
ErrorReport
,
.
gs
,!*
OSToolbox
)
PlayLevel
levelnumber
gs
gamehnd
tb
#
(_,
tb
)
=
SetGameBoundMap
wid
ht
bm
os
stx
sty
tb
#
(_,
tb
)
=
MoveScreenTo
curLevelHnd
.
initpos`
tb
...
...
@@ -155,11 +152,11 @@ PlayLevel levelnumber gs gamehnd tb
#
curgamehnd
=
{
gamehnd
&
levels`
=
[
firstlevel
]}
#
(
gs
,
tb
)
=
fromGSt
gst
#
(_,
tb
)
=
OSGameLevelOptions
fill
rgb
esc
dbg
fdin
fdout
tb
#
(
gs
,
tb
)
=
RunGameEngine
{
scroll
=
movements
,
gamest
ate
=
gs
,
gamehnd
=
curgamehnd
}
tb
#
(
gs
,
tb
)
=
RunGameEngine
{
scroll
=
movements
,
gamest
=
gs
,
gamehnd
=
curgamehnd
}
tb
#
tb
=
maybeStopMusic
curLevelHnd
.
music`
tb
#
(_,
tb
)
=
OSInitSoundSample
(
~
1
)
""
0
tb
// remove samples
#
(_,
tb
)
=
OSInitSoundSample
(
-
1
)
""
0
tb
// remove samples
#
tb
=
LayersDone
bids
mapids
tb
#
(_,
tb
)
=
ClearAllGameBitmaps
tb
=
(
NoError
,
gs
,
tb
)
...
...
@@ -172,12 +169,12 @@ where
startobjx
=
stx
,
startobjy
=
sty
}
=
curLevelHnd
.
boundmap`
{
w
=
wid
,
h
=
ht
}
=
bs
maybePlayMusic
::
(
Maybe
Music
)
!*
OSToolbox
->
!*
OSToolbox
maybePlayMusic
::
!
(
Maybe
Music
)
!*
OSToolbox
->
!*
OSToolbox
maybePlayMusic
Nothing
tb
=
tb
maybePlayMusic
(
Just
m
)
tb
#
(_,
tb
)
=
PlayMusic
m
.
musicfile
m
.
restart
tb
=
tb
maybeStopMusic
::
(
Maybe
Music
)
!*
OSToolbox
->
!*
OSToolbox
maybeStopMusic
::
!
(
Maybe
Music
)
!*
OSToolbox
->
!*
OSToolbox
maybeStopMusic
Nothing
tb
=
tb
maybeStopMusic
(
Just
m
)
tb
|
m
.
continue
...
...
@@ -188,11 +185,11 @@ where
dbg
=
options
.
debugscroll
fdin
=
options
.
fadein
fdout
=
options
.
fadeout
rgb
::
Colour
//
rgb :: Colour
rgb
=
if
fill
(
fromJust
options
.
fillbackground
)
(
RGB
{
r
=
~
1
,
g
=
~
1
,
b
=
~
1
})
fill
=
(
isJust
options
.
fillbackground
)
(
RGB
{
r
=
-
1
,
g
=
-
1
,
b
=
-
1
})
fill
=
isJust
options
.
fillbackground
initsoundsamples
sndlist
gs
=
map2
initsoundsample
sndlist
gs
...
...
@@ -206,15 +203,15 @@ where
#
(
sprids
,
gst
)
=
convertsprites
obj
.
sprites`
gst
=
({
obj
&
spriteids`
=
sprids
},
gst
)
//
convertsprites :: ![Sprite] !
.
(GSt .gs) -> (![SpriteID], !
.(
GSt .gs)
)
convertsprites
::
![
Sprite
]
!(
GSt
.
gs
)
->
(![
SpriteID
],
!
GSt
.
gs
)
convertsprites
spr
gst
#
(
idlst
,
gst
)
=
map2
C
reateAnimation
spr
gst
#
idlst
=
map
(
~)
idlst
#
(
idlst
,
gst
)
=
map2
c
reateAnimation
spr
gst
#
idlst
=
map
(
\
x
->
0
-
x
)
/*(~)*/
idlst
=
(
idlst
,
gst
)
C
reateGameBitmap
::
!
GameBitmap
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
C
reateGameBitmap
bitmap
=:{
bitmapname
,
unitsize
,
dimensions
,
transparent
}
gst
c
reateGameBitmap
::
!
GameBitmap
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
c
reateGameBitmap
bitmap
=:{
bitmapname
,
unitsize
,
dimensions
,
transparent
}
gst
#
(
bid
,
gst
)
=
accGStTb
(
InitGameBitmap
0
bitmapname
(
w
*
nh
)
(
h
*
nv
)
w
h
)
gst
#
(_,
gst
)
=
accGStTb
(
MaybeSetTransparentColor
bid
transparent
)
gst
=
(
bid
,
gst
)
...
...
@@ -224,27 +221,26 @@ where
(
nh
,
nv
)
=
dimensions
C
reateAnimation
::
!
Sprite
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
C
reateAnimation
sprite
=:{
bitmap
,
sequence
,
loop
}
gst
#
(
bid
,
gst
)
=
C
reateGameBitmap
bitmap
gst
c
reateAnimation
::
!
Sprite
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
c
reateAnimation
sprite
=:{
bitmap
,
sequence
,
loop
}
gst
#
(
bid
,
gst
)
=
c
reateGameBitmap
bitmap
gst
#
(
sprid
,
gst
)
=
accGStTb
(
InitSpriteAnimation
bid
sequence
loop
)
gst
=
(
~
sprid
,
gst
)
=
(
0
-
sprid
,
gst
)
C
reateNewGameObject
::
!
ObjectType
!
SubType
!
Point2
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
C
reateNewGameObject
ot
st
p
gst
c
reateNewGameObject
::
!
ObjectType
!
SubType
!
Point2
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
c
reateNewGameObject
ot
st
p
gst
=
accGStTb
(
InitGameObject
ot
st
p
)
gst
::
ObjectFocus
=
{
scrollleft
::
Int
,
scrollup
::
Int
,
scrollright
::
Int
,
scrolldown
::
Int
,
maxxscrollspeed
::
Int
,
maxyscrollspeed
::
Int
=
{
scrollleft
::
!
Int
,
scrollup
::
!
Int
,
scrollright
::
!
Int
,
scrolldown
::
!
Int
,
maxxscrollspeed
::
!
Int
,
maxyscrollspeed
::
!
Int
}
instance
zero
ObjectFocus
where
instance
zero
ObjectFocus
where
zero
=
{
scrollleft
=
0
,
scrollup
=
0
,
scrollright
=
0
...
...
@@ -253,8 +249,8 @@ where
,
maxyscrollspeed
=
0
}
C
reateObjectFocus
::
!
ObjectFocus
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
C
reateObjectFocus
o
gst
c
reateObjectFocus
::
!
ObjectFocus
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
c
reateObjectFocus
o
gst
=
accGStTb
(
SetObjectFocus
o
.
scrollleft
o
.
scrollup
o
.
scrollright
o
.
scrolldown
o
.
maxxscrollspeed
o
.
maxyscrollspeed
)
gst
...
...
@@ -265,7 +261,7 @@ MIN_VOLUME :== 0
::
Volume
:==
Int
PAN_LEFT
:==
~
10000
PAN_LEFT
:==
-
10000
PAN_CENTER
:==
0
PAN_RIGHT
:==
10000
...
...
@@ -277,35 +273,35 @@ DEFAULT_FREQUENCY :== 0
::
Frequency
:==
Int
P
laySoundSample
::
!
SoundID
!
Volume
!
Pan
!
Frequency
!
GameTime
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
P
laySoundSample
id
vol
pan
freq
delay
gst
p
laySoundSample
::
!
SoundID
!
Volume
!
Pan
!
Frequency
!
GameTime
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
p
laySoundSample
id
vol
pan
freq
delay
gst
=
accGStTb
(
OSPlaySoundSample
id
(
vol
-
10000
)
pan
freq
delay
)
gst
::
EventTarget
=
Self
|
AllObjects
|
BoundType
Bounds
EventTargetToInt
::
EventTarget
->
Int
EventTargetToInt
Self
=
0
EventTargetToInt
AllObjects
=
-1
EventTargetToInt
::
!
EventTarget
->
Int
EventTargetToInt
Self
=
0
EventTargetToInt
AllObjects
=
-1
EventTargetToInt
(
BoundType
b
)
=
b
// modified 01/11/99
C
reateUserGameEvent
::
!
EventType
!
EventPar
!
EventPar
!
EventTarget
!
SubType
!
GameTime
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
C
reateUserGameEvent
ev
evpar1
evpar2
dest
subdest
time
gst
c
reateUserGameEvent
::
!
EventType
!
EventPar
!
EventPar
!
EventTarget
!
SubType
!
GameTime
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
c
reateUserGameEvent
ev
evpar1
evpar2
dest
subdest
time
gst
=
accGStTb
(
CreateUserEvent
ev
evpar1
evpar2
(
EventTargetToInt
dest
)
subdest
time
)
gst
// added 01/11/99
ANY_SUBTYPE
:==
(
~1
)
ANY_SUBTYPE
:==
-1
G
etBoundMap
::
!
Int
!
Int
!(
GSt
.
gs
)
->
(!
GRESULT
,
!(!
Int
,
!
DirectionSet
),
!
GSt
.
gs
)
G
etBoundMap
x
y
gst
g
etBoundMap
::
!
Int
!
Int
!(
GSt
.
gs
)
->
(!
GRESULT
,
!(!
Int
,
!
DirectionSet
),
!
GSt
.
gs
)
g
etBoundMap
x
y
gst
#
(
result
,
gst
)
=
accGStTb
(
OSGetBoundMap
x
y
)
gst
#
(
gr
,
val
)
=
result
=
(
gr
,
fromBoundMapCode
val
,
gst
)
S
etBoundMap
::
!
Int
!
Int
(!
Int
,
!
DirectionSet
)
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
S
etBoundMap
x
y
newvalue
gst
s
etBoundMap
::
!
Int
!
Int
!
(!
Int
,
!
DirectionSet
)
!(
GSt
.
gs
)
->
(!
GRESULT
,
!
GSt
.
gs
)
s
etBoundMap
x
y
newvalue
gst
=
accGStTb
(
OSSetBoundMap
x
y
(
toBoundMapCode
newvalue
))
gst
...
...
@@ -328,13 +324,13 @@ defaultObjectOptions
,
removemapcode
=
False
}
defaultObjectRec
::
.
Int
.
Point2
.
Size
.
GameTime
!*(
GSt
.
a
)
->
(!
.
ObjectRec
,!*
GSt
.
a
)
defaultObjectRec
::
SubType
Point2
Size
GameTime
!*(
GSt
.
gs
)
->
(!
Game
ObjectRec
,!*
GSt
.
gs
)
defaultObjectRec
objsubtype
position
size
time
gs
=
(
{
active
=
True
,
subtype
=
objsubtype
,
size
=
size
,
pos
=
position
,
offset
=
{
x
=
0
,
y
=
0
}
,
offset
=
zero
,
currentsprite
=
1
,
displayoptions
=
{
blink
=
False
,
stretch
=
False
...
...
@@ -350,45 +346,44 @@ defaultObjectRec objsubtype position size time gs
,
acceleration
=
zero
,
speed
=
zero
,
bounce
=
{
fvx
=
Value
0.0
,
fvy
=
Value
0.0
}
,
maxspeed
=
{
rx
=
(
fxr
EVERYTHING
),
ry
=
(
fxr
EVERYTHING
)
}
,
maxspeed
=
{
rx