implementation module StdGame import StdArray, StdBool, StdClass, StdFunc, StdInt, StdList, StdMisc import StdId, StdProcess import fixed, GameFunctions, gamehandle, gameutils, gst from gameobjectutils import toBoundMapCode, fromBoundMapCode from StdPSt import appPIO, accPIO import commondef, iostate, windowdevice from windowaccess import initWindowHandle, checkZeroWindowHandlesBound, decreaseWindowHandlesBound, addWindowHandlesWindow from windowcreate import bufferDelayedEvents from windowvalidate import validateWindowId from ostypes import OSNoWindowPtr /* predefined bounds */ BND_MAP_CODES :== 1 << 30 BND_STATIC_BOUNDS :== 1 << 31 /* skipmove constant */ SK_FOREVER :== -1 StdGameFatalError :: String String -> .x StdGameFatalError function error = fatalError function "StdGame" error startGame :: .(Game a) a [.GameAttribute a] !*World -> .World startGame gamedef initialstate options world = startIO SDI 0 init [ProcessClose closeProcess] world where init ps # (finalstate, _, ps) = openGame initialstate gamedef options ps = closeProcess ps openGame :: .gs !(Game .gs) ![GameAttribute .gs] !(PSt .l) -> (.gs, !ErrorReport, !PSt .l) openGame gs gdef attr ps # (wId, ps) = accPIO openId ps # size = findSize attr {w=320,h=240} # bpp = findBPP attr 8 # (_, ps) = openGameWindow wId size bpp True ps # (tb,ps) = accPIO getIOToolbox ps # gst = toGSt gs tb # (initLevel,gst) = gdef.nextlevel gst # (gs,tb) = fromGSt gst # (gs, _, tb) = PlayLevels initLevel gs gdef tb # ps = appPIO (setIOToolbox tb) ps = (gs, NoError, ps) where findSize :: ![GameAttribute .gs] !Size -> Size findSize [] s = s findSize [ScreenSize x:xs] s = x findSize [x:xs] s = findSize xs s findBPP :: ![GameAttribute .gs] !Int -> Int findBPP [] s = s findBPP [ColorDepth x:xs] s = x findBPP [x:xs] s = findBPP xs s // always full screen, game in a window not implemented yet openGameWindow :: !Id !Size !Int !Bool !(PSt .l) -> (!ErrorReport, !PSt .l) openGameWindow id gamewindowsize bitsperpixel fullscreen pState # pState = windowFunctions.dOpen pState // Install the window device # maybe_id = Just id # (maybe_okId,ioState) = validateWindowId maybe_id pState.io | isNothing maybe_okId = (ErrorIdsInUse,{pState & io=ioState}) # (found,wDevice,ioState) = ioStGetDevice WindowDevice ioState | not found // This condition should never occur: WindowDevice must have been 'installed' = StdGameFatalError "openGame" "could not retrieve WindowSystemState from IOSt" # windows = windowSystemStateGetWindowHandles wDevice # (isZero,windows) = checkZeroWindowHandlesBound windows | isZero # ioState = ioStSetDevice (WindowSystemState windows) ioState = (ErrorViolateDI,{pState & io=ioState}) | otherwise # info = { gamewindowDDPtr = OSNoWindowPtr , gamewindowCDepth = bitsperpixel , gamewindowSize = gamewindowsize , gamewindowFullScreen = fullscreen } okId = fromJust maybe_okId # wH = initWindowHandle "" Modeless IsGameWindow (GameWindowInfo info) [] [WindowId okId] # wH = {wH & whSize=gamewindowsize} # (tb,ioState) = getIOToolbox ioState # tb = OSinitialiseGame tb # (delayinfo,wPtr,tb) = OScreateGameWindow fullscreen (toTuple gamewindowsize) bitsperpixel tb # ioState = setIOToolbox tb ioState wlsH = {wlsState=undef,wlsHandle=wH} wIds = {wId=okId,wPtr=wPtr,wActive=False} wsH = {wshIds=wIds,wshHandle=Just wlsH} windows = addWindowHandlesWindow 0 wsH windows windows = decreaseWindowHandlesBound windows # ioState = ioStSetDevice (WindowSystemState windows) ioState # ioState = bufferDelayedEvents delayinfo ioState = (NoError,{pState & io=ioState}) PlayLevels :: !Int .gs !(Game .gs) !*OSToolbox -> (.gs, !ErrorReport, !*OSToolbox) PlayLevels level gs gdef tb | level == 0 = (gs, NoError, tb) # ghnd = createGameHandle gdef # (_, gs, tb) = PlayLevel level gs ghnd tb # gst = toGSt gs tb # (nextlevel, gst) = gdef.nextlevel gst # (gs,tb) = fromGSt gst = PlayLevels nextlevel gs gdef tb 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 [] 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 _ Nothing tb = (GR_OK, tb) MaybeSetTransparentColor bid (Just p) tb = SetTransparentColor bid p tb MovementFunctions :: ![Layer] -> [Movement] MovementFunctions [] = [] MovementFunctions [l:ls] = [l.movement] ++ MovementFunctions ls 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 # tb = InitBlockSequences newbid l.sequences tb # (_, tb) = InitGameLayerMap newmapid newbid l.layermap True tb // l.tile = (bids++[newbid], mapids++[newmapid], tb) where b = l.bmp us = b.unitsize (nh, nv) = b.dimensions newmapid = (FindMaxID 0 mapids) + 1 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 bids mapids tb # tb = MapsDone mapids tb # tb = BitmapsDone bids tb = tb MapsDone :: ![MAPID] !*OSToolbox -> *OSToolbox MapsDone [] tb = tb MapsDone [m:ms] tb # (_, tb) = GameLayerMapDone m tb = MapsDone ms tb 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 levelnumber gs gamehnd tb # (_, tb) = SetGameBoundMap wid ht bm os stx sty tb # (_, tb) = MoveScreenTo curLevelHnd.initpos` tb # lyrs = curLevelHnd.layers` # (bids, mapids, tb) = InitLayers lyrs [] [] tb # movements = zip2 mapids (MovementFunctions lyrs) # (_, tb) = initsoundsamples curLevelHnd.soundsamples` tb # tb = maybePlayMusic curLevelHnd.music` tb # gst = toGSt gs tb # firstlevel = curLevelHnd # (obj, gst) = map2 convertobjsprites firstlevel.objects` gst # firstlevel = {firstlevel & objects` = obj} # curgamehnd = {gamehnd & levels` = [firstlevel]} # (gs,tb) = fromGSt gst # (_, tb) = OSGameLevelOptions fill rgb esc dbg fdin fdout tb # (gs, tb) = RunGameEngine { scroll = movements , gamest = gs , gamehnd = curgamehnd} tb # tb = maybeStopMusic curLevelHnd.music` tb # (_, tb) = OSInitSoundSample (-1) "" 0 tb // remove samples # tb = LayersDone bids mapids tb # (_, tb) = ClearAllGameBitmaps tb = (NoError, gs, tb) where curLevelHnd = gamehnd.levels`!!(levelnumber-1) options = curLevelHnd.leveloptions` { map = bm, blocksize = bs, objstart = os, startobjx = stx, startobjy = sty} = curLevelHnd.boundmap` { w = wid, h = ht } = bs 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 Nothing tb = tb maybeStopMusic (Just m) tb | m.continue = tb # (_, tb) = StopMusic tb = tb esc = options.escquit dbg = options.debugscroll fdin = options.fadein fdout = options.fadeout // rgb :: Colour rgb = if fill (fromJust options.fillbackground) (RGB {r= -1, g= -1, b= -1}) fill = isJust options.fillbackground initsoundsamples sndlist gs = map2 initsoundsample sndlist gs initsoundsample sample gs = OSInitSoundSample sample.soundid sample.soundfile sample.soundbuffers gs convertobjsprites (GameObjectHandleLS obj) gst # (sprids, gst) = convertsprites obj.sprites` gst = (GameObjectHandleLS {obj & spriteids` = sprids}, gst) where convertsprites :: ![Sprite] !(GSt .gs) -> (![SpriteID], !GSt .gs) convertsprites spr gst # (idlst, gst) = map2 createAnimation spr gst # idlst = map (\x->0-x)/*(~)*/ idlst = (idlst, gst) createGameBitmap :: !GameBitmap !(GSt .gs) -> (!GRESULT, !GSt .gs) createGameBitmap 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) where w = unitsize.w h = unitsize.h (nh,nv) = dimensions createAnimation :: !Sprite !(GSt .gs) -> (!GRESULT, !GSt .gs) createAnimation sprite=:{bitmap, sequence, loop} gst # (bid, gst) = createGameBitmap bitmap gst # (sprid, gst) = accGStTb (InitSpriteAnimation bid sequence loop) gst = (0-sprid, gst) createNewGameObject :: !ObjectCode !SubCode !Point2 !(GSt .gs) -> (!GRESULT, !GSt .gs) createNewGameObject ot st p gst = accGStTb (InitGameObject ot st p) gst :: ObjectFocus = { scrollleft :: !Int , scrollup :: !Int , scrollright :: !Int , scrolldown :: !Int , maxxscrollspeed :: !Int , maxyscrollspeed :: !Int } instance zero ObjectFocus where zero = { scrollleft = 0 , scrollup = 0 , scrollright = 0 , scrolldown = 0 , maxxscrollspeed = 0 , maxyscrollspeed = 0 } createObjectFocus :: !ObjectFocus !(GSt .gs) -> (!GRESULT, !GSt .gs) createObjectFocus o gst = accGStTb (SetObjectFocus o.scrollleft o.scrollup o.scrollright o.scrolldown o.maxxscrollspeed o.maxyscrollspeed) gst MAX_VOLUME :== 10000 MIN_VOLUME :== 0 :: Volume :== Int PAN_LEFT :== -10000 PAN_CENTER :== 0 PAN_RIGHT :== 10000 :: Pan :== Int DEFAULT_FREQUENCY :== 0 :: Frequency :== Int playSoundSample :: !SoundID !Volume !Pan !Frequency !GameTime !(GSt .gs) -> (!GRESULT, !GSt .gs) playSoundSample 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 (BoundType b) = b // modified 01/11/99 createUserGameEvent :: !EventCode !EventPar !EventPar !EventTarget !SubCode !GameTime !(GSt .gs) -> (!GRESULT, !GSt .gs) createUserGameEvent ev evpar1 evpar2 dest subdest time gst = accGStTb (CreateUserEvent ev evpar1 evpar2 (EventTargetToInt dest) subdest time) gst // added 01/11/99 ANY_SUBTYPE :== -1 getBoundMap :: !Int !Int !(GSt .gs) -> (!GRESULT, !(!Int, !DirectionSet), !GSt .gs) getBoundMap x y gst # (result, gst) = accGStTb (OSGetBoundMap x y) gst # (gr, val) = result = (gr, fromBoundMapCode val, gst) setBoundMap :: !Int !Int !(!Int, !DirectionSet) !(GSt .gs) -> (!GRESULT, !GSt .gs) setBoundMap x y newvalue gst = accGStTb (OSSetBoundMap x y (toBoundMapCode newvalue)) gst defaultObjectOptions :: ObjectOptions defaultObjectOptions = { // fixed = False // , ignorestaticbounds = False ignorelevelbounds = False // , bounceatcollisions = False // , checkmapcodes = False , checkkeyboard = False , allowkeyboardrepeat = False , static = False , hdirection = DirRight , vdirection = DirDown , automirrorleftright = False , automirrorupdown = False , freeze = False , removemapcode = False } defaultObjectRec :: SubCode Point2 Size GameTime !*(GSt .gs) -> (!GameObjectRec,!*GSt .gs) defaultObjectRec objsubcode position size time gs = ( { active = True , subcode = objsubcode , size = size , pos = position , offset = zero , currentsprite = 1 , displayoptions = { blink = False , stretch = False , mirrorleftright = False , mirrorupdown = False , rotation = NoRotation } , ownbounds = 0 , bouncebounds = 0 , collidebounds = 0 , forgetdistance = {x = 1, y = 1} , framecounter = time , layer = InFront , acceleration = zero , speed = zero , bounce = {fvx = Value 0.0, fvy = Value 0.0} , maxspeed = {rx = fxr EVERYTHING,ry = fxr EVERYTHING} , slowdown = {fvx = Value 0.0, fvy = Value 0.0} , skipmove = SK_FOREVER , options = defaultObjectOptions } , gs) defaultInitObject :: Size state SubCode Point2 GameTime !*(GSt .gs) -> GameObjectState state *(GSt .gs) defaultInitObject size state subtype pos time gs # (newobjrec, gs) = defaultObjectRec subtype pos size time gs = {st=state,gs=gs,or=newobjrec} defaultGameObject :: !ObjectCode !Size state -> GameObject state *(GSt .gs) defaultGameObject objcode size state = { objectcode = objcode , sprites = [] , init = defaultInitObject size state , done = \{gs} -> gs , move = id , animation = id , touchbound = \_ _ -> id , collide = \_ _ _ -> id , frametimer = id , keydown = \_ -> id , keyup = \_ -> id , userevent = \_ _ _ -> id } blankScreen :: Level (GSt .gs) blankScreen = { boundmap = { map = [{0}] , blocksize = {w = 10000, h = 10000} , objstart = 1 , startobjx = 1 , startobjy = 1 } , initpos = zero , layers = [] , objects = [] , music = Nothing , soundsamples = [] , leveloptions = { fillbackground = Just Black , escquit = True , debugscroll = False , fadein = False , fadeout = False } } defaultShadow :: !Int -> Shadow defaultShadow n = { shadowpos = {x = n, y = n} , shadowcolor = Black } defaultMovement :: Movement defaultMovement = const defaultScrollMovement :: !Int -> Movement defaultScrollMovement n = \p _ -> {x = p.x / n, y = p.y / n} alignCentered :: TextAlignment alignCentered = { xyfromscreencenter = (True, True) , xycentered = (True, True) }