Freelog 33

home *** CD-ROM | disk | FTP | other *** search

/ Freelog 33 / Freelog033.iso / Palm / Tetris / Source / FreeTris11.txt < prev

Wrap

Text File | 2001-12-04 | 30KB | 1,651 lines

\ STris Main 11/17/01 9:33 CJS \ 65 k include STris-Variables include STris-Setup include STris-Num2Lab include STris-Height include STris-Startup include STris-Color include STris-Config include STris-Sound include STris-Score include STris-BitMap include STris-Blocks include STris-Rows include STris-Move include STris-Rotate include STris-HighS include STris-Main2 .( Main...) cr : (MenuItem) on: QuitID do: bye on: AboutID do: ShowAbout on: NGameID do: Startup on: SettingsID do: ShowPref on: HowID do: ShowHelp on: HSMenuID do: ShowHighScores ; : MenuItem ( -- ) event >abs itemid (MenuItem) drop ; : dispatch-event ( ekey -- ekey ) on: menuEvent do: MenuItem on: penDownEvent do: PDown ; : CleanUp ( -- ) UnlockKeys >State UnlockHandles ; : LauncherMode ( -- ) event >abs itemid StartButton = if Setup then ; : NormalPlayMode ( -- ) TimeOut KeyWait @ KeySpeed @ > if KeyPress else KeyWait @ 1+ KeyWait ! then ; : GameEndingMode ( -- ) 4 GameState ! OverID PopupForm UpdateStats 2000 MS UnlockKeys ; : GameOverMode ( -- ) event >abs itemid GmOvrOK = if score @ bonus @ + high? if GetName else Startup then drop then ; : OptionsMode ( -- ) event >abs itemid OptOK = if OptReturn then ; : HSMode ( -- ) event >abs itemid HSOK = if HSReturn then ; : EnterNameMode ( -- ) event >abs itemid NameOK = if NameReturn Startup ShowHighScores then ; : ModeControl on: 2 do: NormalPlayMode on: 0 do: LauncherMode on: 3 do: GameEndingMode on: 4 do: GameOverMode on: 5 do: OptionsMode on: 6 do: HSMode on: 7 do: EnterNameMode ; : (Restore) (Setup) State> drop UpdateScore DrawNextBlock PauseIt ; : [Restore] on: 0 do: Startup on: 1 or: 2 do: (Restore) on: 3 or: 4 or: 5 or: 6 or: 8 do: Startup ; : Restore ( -- ) State> 0= if Startup else GameState @ [Restore] drop then ; : go ( -- ) LockHandles 3.0-features? if GetConfig GetHS ConfigColor then 6000 ShowForm 0 Begin 1+ dup 7 > ekey penDownEvent = or Until drop Restore begin 1 0 ['] (ekey) catch ByeThrow = if CleanUp (bye) then dispatch-event drop GameState @ ModeControl drop again ; \ STris-Main2 (ID) MXTs (ID) rsrc use-resources : ScreenComponents ( -- ) 152 102 4 43 0 rounded-rectangle 150 100 5 44 0 erase-rounded-rectangle 39 0 39 42 line 81 0 81 42 line 96 0 96 42 line 117 0 117 42 line ; : PauseIt ( -- ) 1 GameState ! ScreenComponents 7 5 AT-XY ." Paused... " 5 8 AT-XY ." < Tap to Resume >" 4 12 AT-XY ." Version 1.1" ; : Unpause ( -- ) 2 GameState ! ReDraw DrawBlock ; : PDown ( -- ) GameState @ dup 1 = if Unpause then 2 = if PauseIt then ; : (KeyPress) ( Addr -- ) @ on: 0 do: BLeft on: 1 do: BRight on: 2 do: PDown on: 3 do: BDown on: 4 do: RotateLeft on: 5 do: RotateRight ; : KeyPress ( -- ) KeyCurrentState 2dup 8. Dand 8. D= if KeyA (KeyPress) drop then 2dup 16. Dand 16. D= if KeyB (KeyPress) drop then 2dup 32. Dand 32. D= if KeyC (KeyPress) drop then 2dup 64. Dand 64. D= if KeyD (KeyPress) drop then 2dup 4. Dand 4. D= if KeyDn (KeyPress) drop then 2. Dand 2. D= if KeyUp (KeyPress) drop then ; : Startup ( -- ) Page ." Starting . " UnlockKeys StartFormID PopupForm 0 Level ! 0 BaseLevel ! 0 GameState ! ; : (Setup) ( -- ) Page InitializeVariables SetupShapes 2 GameState ! FormID PopupForm LockKeys ScreenComponents ShowTime ; : Setup ( -- ) ClearBoard ClearBuffer ClearCBuffer ClearShapes LevelSetup HeightSetup (Setup) RandomNext Next>Current 0 Score! 5 BlockY ! 3 BlockX ! ReDraw DrawBlock DrawNextBlock ; : ShowAbout ( -- ) UnlockKeys AlertID FrmAlert drop LockKeys ; : ShowHelp ( -- ) UnlockKeys How$ID FrmHelp LockKeys ; \ STris-Variables 11/16/01 8:46 CJS .( ids...sarrary.... ) cr needs ids needs sarray \ ⌐Robert L. Ryan .( Variables... ) 3000 constant FormID 3001 constant AlertID 3002 constant OverID 3003 constant StartFormID 3004 constant OptFormID 3005 constant HSFormID 3006 constant NameFormID 3041 constant AboutID 3042 constant NGameID 3043 constant QuitID 3044 constant SettingsID 3045 constant HowID 3046 constant HSMenuID 3101 constant How$ID 3203 constant ScoreLbID 3301 constant GmOvrOK 3302 constant StartButton 3379 constant HSOK 3380 constant OptOK 3381 constant NameOK 3401 constant NameField -257 constant ByeThrow here constant state-base variable BlockX variable BlockY variable NextBlock variable BlockSpeed variable WaitCount variable Score variable Level variable Bonus variable BaseLevel variable RMode variable GameState variable vTet variable vTri variable vDou variable vSin variable vLin 28 4 1 cells matrix Shapes{{ 4 4 1 cells matrix BlockBuffer{{ 4 4 1 cells matrix BlockCBuffer{{ 20 10 1 cells matrix Board{{ here state-base - constant state-size variable StatePtr State-size StatePtr ! variable KeySpeed variable KeyWait variable Svol 32 Svol ! here constant prefs-base variable VolumeP variable SensitiveP variable KeyA variable KeyB variable KeyC variable KeyD variable KeyUp variable KeyDn variable bw variable DelayNext variable Flat here prefs-base - constant prefs-size variable SizePtr prefs-size SizePtr ! variable LastMode variable LabelString variable PrefLabel create LblTxtBufferV 20 chars allot create LblTxtBufferS 20 chars allot create LblTxtBuffer1 20 chars allot create LblTxtBuffer2 20 chars allot create LblTxtBuffer3 20 chars allot create LblTxtBuffer4 20 chars allot create LblTxtBufferU 20 chars allot create LblTxtBufferD 20 chars allot create TxtBuffer 10 chars allot variable StatNum variable StatLabel 2variable RocketPtr 2variable Block1Ptr 2variable Block2Ptr 2variable Block3Ptr 2variable Block4Ptr 2variable Block5Ptr 2variable Block6Ptr 2variable Block7Ptr 2variable Block8Ptr ID Tbmp variable BlkOffSet variable LoopX variable LoopY variable BlocksFound variable RowsCleared variable BombsFound variable Can? variable YMove variable XMove here constant HS-base 10 22 chars array Names{ 10 1 cells array Scores{ here HS-base - constant HS-size variable HSPtr HS-size HSPtr ! create NameBuffer 21 chars allot variable StartY 2variable OldKeyMask \ STris-Setup 9/26/01 13:27 CJS \ Copyright 2001 ⌐ \ Christopher J. Smith .( Standard Libs... ) cr .( . ) needs facility .( . ) needs facility-ext .( . ) needs resources .( . ) needs Events .( . ) needs Forms .( . ) needs ids .( . ) needs graphics .( . ) needs double .( . ) needs random .( . ) needs sound .( . ) needs music .( . ) needs zstrings .( . ) needs color .( . ) needs ver .( Extended Librarys... ) cr .( . ) needs color35 .( . ) needs UIColor .( . ) needs Double-Tools .( . ) needs ondo \ ⌐Kristopher Johnson .( . ) needs sarray \ ⌐Robert L. Ryan cr .( SetUp... ) cr : ShowTime 0 13 AT-XY TIME&DATE 2drop drop . ." :" dup 10 < if ." 0" then . drop ." " ; : LockKeys ( -- ) 126 s>d Dinvert KeySetMask OldKeyMask 2! ; : UnlockKeys ( -- ) OldKeyMask 2@ KeySetMask 2drop ; : >State ( -- ) false state-size state-base >abs 1 1 [id] MxTs PrefSetAppPreferences ; : State> ( -- f ) false stateptr >abs state-base >abs 1 [id] MxTs PrefGetAppPreferences 1 = ; : InitializeVariables 5 BlockY ! 3 BlockX ! 180 BlockSpeed ! 0 WaitCount ! 0 KeyWait ! 0 Score ! 0 Bonus ! 2 GameState ! 0 vTet ! 0 vTri ! 0 vDou ! 0 vSin ! 0 vLin ! ; : shuffle ( x1 x2 x3 x4 -- x4 x3 x1 x2 ) swap 2swap ; : ClearBoard ( -- ) 20 Begin 1- 10 Begin 1- 2dup Board{{ 0 shuffle }} ! dup 0 = until drop dup 0 = until drop ; : ClearBuffer ( -- ) 4 Begin 1- 4 Begin 1- 2dup BlockBuffer{{ 0 shuffle }} ! dup 0 = until drop dup 0 = until drop ; : ClearCBuffer ( -- ) 4 Begin 1- 4 Begin 1- 2dup BlockCBuffer{{ 0 shuffle }} ! dup 0 = until drop dup 0 = until drop ; : ClearShapes ( -- ) 28 Begin 1- 4 Begin 1- 2dup Shapes{{ 0 shuffle }} ! dup 0 = until drop dup 0 = until drop ; : SetupShapes ( -- ) \ Tetris Flat @ 0= if 3 dup Shapes{{ 0 1 }} ! dup Shapes{{ 1 1 }} ! dup Shapes{{ 2 1 }} ! Shapes{{ 3 1 }} ! else 3 dup Shapes{{ 1 0 }} ! dup Shapes{{ 1 1 }} ! dup Shapes{{ 1 2 }} ! Shapes{{ 1 3 }} ! then \ 'T' Shape 1 dup Shapes{{ 4 1 }} ! dup Shapes{{ 5 0 }} ! dup Shapes{{ 5 1 }} ! Shapes{{ 5 2 }} ! \ Square 4 dup Shapes{{ 9 1 }} ! dup Shapes{{ 9 2 }} ! dup Shapes{{ 10 1 }} ! Shapes{{ 10 2 }} ! \ 'L' Shape 2 dup Shapes{{ 13 0 }} ! dup Shapes{{ 13 1 }} ! dup Shapes{{ 13 2 }} ! Shapes{{ 14 0 }} ! \ Backwards 'L' 7 dup Shapes{{ 17 0 }} ! dup Shapes{{ 17 1 }} ! dup Shapes{{ 17 2 }} ! Shapes{{ 18 2 }} ! \ Backwards 'S' 5 dup Shapes{{ 20 0 }} ! dup Shapes{{ 20 1 }} ! dup Shapes{{ 21 1 }} ! Shapes{{ 21 2 }} ! \ Forwards 'S' 6 dup Shapes{{ 24 1 }} ! dup Shapes{{ 24 2 }} ! dup Shapes{{ 25 0 }} ! Shapes{{ 25 1 }} ! ; \ STris-Num2Lab 10/10/01 14:47 CJS \ Copyright 2001 ⌐ \ Christopher J. Smith .( STris-Num2Lab... ) : CreateTxt ( # -- c-addr u ) TxtBuffer 0 StatNum @ 0 <# #s #> append z" " 1+ append ; : Stat ( ID # -- ) StatNum ! StatLabel ! StatLabel @ GetObjectIndex FrmGetActiveForm FrmHideObject CreateTxt drop >abs StatLabel @ SetLabel StatLabel @ GetObjectIndex FrmGetActiveForm FrmShowObject ; : UpdateStats ( -- ) 3242 vTet @ Stat 3243 vTri @ Stat 3244 vDou @ Stat 3245 vSin @ Stat 3246 vLin @ Stat 3248 Level @ Stat 3206 Score @ Bonus @ + Stat ; \ STris-Height 10/11/01 15:02 CJS \ Copyright 2001 ⌐ \ Christopher J. Smith .( STris-Height... ) : Brick? ( -- 0|8 ) rand 2 mod 8 * ; : FillRow ( Row# -- ) 1- Begin 1+ 10 Begin 1- 2dup Board{{ Brick? shuffle }} ! dup 0 = until drop dup 19 = until drop ; \ STris-Startup 10/10/01 10:13 CJS \ Copyright 2001 ⌐ \ Christopher J. Smith .( STris-Startup... ) : Level? ( Flag Level -- ) swap if dup BaseLevel ! Level ! else drop then ; : LevelSetup ( -- ) -1 Begin 1+ dup dup 3350 + GetControlValue swap Level? dup 9 = Until drop ; : Scramble? ( Flag Row -- ) swap if FillRow else drop then ; : HeightSetup ( -- ) -1 Begin 1+ dup dup 3361 + GetControlValue swap 18 swap - Scramble? dup 8 = Until drop ; \ STris-Color 11/8/01 11:27 CJS .( STris-Color... ) variable CurrentDepth variable TempDepth variable MaxDepth 2variable black 2variable white 2variable blue : SetColors 3.5-features? if Black >abs WinRGBToIndex WinSetForeColor drop white >abs WinRGBToIndex WinSetBackColor drop Black >abs WinRGBToIndex WinSetTextColor drop else Black 2@ foreground White 2@ background then ; : Check 0= if TempDepth @ CurrentDepth ! CurrentDepth @ MaxDepth @ > if CurrentDepth @ MaxDepth ! then else drop then ; : SetTemp dup TempDepth ! ; : Depth ( depth -- ) SetTemp ['] color-depth catch Check ; : SetUITable ( -- ) 3.5-features? if Blue >abs UIObjectFrame UIColorSetTableEntry drop Black >abs UIObjectForeground UIColorSetTableEntry drop Blue >abs UIFormFrame UIColorSetTableEntry drop white >abs UIFormFill UIColorSetTableEntry drop blue >abs UIDialogFrame UIColorSetTableEntry drop white >abs UIDialogFill UIColorSetTableEntry drop blue >abs UIAlertFrame UIColorSetTableEntry drop white >abs UIAlertFill UIColorSetTableEntry drop black >abs UIMenuFrame UIColorSetTableEntry drop white >abs UIMenuFill UIColorSetTableEntry drop black >abs UIMenuForeground UIColorSetTableEntry drop blue >abs UIMenuSelectedFill UIColorSetTableEntry drop white >abs UIMenuSelectedForeground UIColorSetTableEntry drop then ; : ConfigColor ( -- ) (hex) 0. black 2! (hex) FFFFFF. white 2! (hex) 0000FF. blue 2! 1 MaxDepth ! 1 depth bw @ 0= if 2 depth 4 depth 8 depth SetUITable SetColors then ; \ STris-Config 10/15/01 10:33 CJS \ Copyright 2001 ⌐ \ Christopher J. Smith .( STris-Config... ) : >prefs ( -- ) false Prefs-Size Prefs-base >abs 1 0 [id] MxTs PrefSetAppPreferences ; : prefs> ( -- f ) false SizePtr >abs Prefs-base >abs 0 [id] MxTs PrefGetAppPreferences 1 = ; : HideControl ( ID -- ) GetObjectIndex FrmGetActiveForm FrmHideObject ; : ShowControl ( ID -- ) GetObjectIndex FrmGetActiveForm FrmShowObject ; : Volume@ ( -- volumeP ) VolumeP @ ; : Volume! ( volume -- ) dup 0 = if 0 Svol ! then dup 1 = if 16 Svol ! then dup 2 = if 32 Svol ! then dup 3 = if 64 Svol ! then VolumeP ! ; : Sensitive@ ( -- KeySpdP ) SensitiveP @ ; : Sensitive! ( KeySpdP -- ) dup 0 = if 22 KeySpeed ! then dup 1 = if 18 KeySpeed ! then dup 2 = if 14 KeySpeed ! then dup 3 = if 10 KeySpeed ! then dup 4 = if 6 KeySpeed ! then SensitiveP ! ; : GetConfig ( -- ) prefs> 0= if 1 Volume! 1 Sensitive! 0 KeyA ! 1 KeyB ! 4 KeyC ! 5 KeyD ! 2 KeyUp ! 3 KeyDn ! false bw ! false DelayNext ! false Flat ! then SensitiveP @ Sensitive! VolumeP @ Volume! ; : IdListSet GetObjectPtr LstSetSelection ; : IdListGetText GetObjectPtr LstGetSelectionText >rel 20 append drop >abs ; : SetUpPrefsForm ( -- ) Volume@ 3636 IdListSet LblTxtBufferV 0 Volume@ 3636 IdListGetText 3370 SetLabel Sensitive@ 3637 IdListSet LblTxtBufferS 0 Sensitive@ 3637 IdListGetText 3371 SetLabel KeyA @ 3638 IdListSet LblTxtBuffer1 0 KeyA @ 3638 IdListGetText 3372 SetLabel KeyB @ 3639 IdListSet LblTxtBuffer2 0 KeyB @ 3639 IdListGetText 3373 SetLabel KeyC @ 3640 IdListSet LblTxtBuffer3 0 KeyC @ 3640 IdListGetText 3374 SetLabel KeyD @ 3641 IdListSet LblTxtBuffer4 0 KeyD @ 3641 IdListGetText 3375 SetLabel KeyUp @ 3642 IdListSet LblTxtBufferU 0 KeyUp @ 3642 IdListGetText 3376 SetLabel KeyDn @ 3643 IdListSet LblTxtBufferD 0 KeyDn @ 3643 IdListGetText 3377 SetLabel bw @ 3378 GetObjectPtr CtlSetValue DelayNext @ 3382 GetObjectPtr CtlSetValue Flat @ 3383 GetObjectPtr CtlSetValue ; : IdGetList ( ID -- Value ) GetObjectPtr LstGetSelection ; : IdGetCtl ( ID -- value ) GetObjectPtr CtlGetValue ; : StorePrefs ( -- ) 3636 IdGetList Volume! 3637 IdGetList Sensitive! 3638 IdGetList KeyA ! 3639 IdGetList KeyB ! 3640 IdGetList KeyC ! 3641 IdGetList KeyD ! 3642 IdGetList KeyUp ! 3643 IdGetList KeyDn ! 3378 IdGetCtl bw ! 3382 IdGetCtl DelayNext ! 3383 IdGetCtl Flat ! >Prefs ; : ShowPref ( -- ) UnlockKeys GameState @ LastMode ! 5 GameState ! OptFormID PopupForm SetUpPrefsForm ; : OptReturn ( -- ) LastMode @ dup GameState ! StorePrefs ClearShapes SetupShapes 0 = if StartFormID FrmReturnToForm else LockKeys FormID FrmReturnToForm then ; \ STris-Sound 11/8/01 15:16 CJS .( STris-Sound... ) needs sound : tick ( -- ) Svol @ 5 262 sound ; : woop ( -- ) Svol @ 494 Begin 32 - 2dup 1 swap sound dup 294 < until drop drop ; : Tetris! ( -- ) Svol @ v 1 o sixteenth 2 o c e d f e g f ; : bell ( -- ) Svol @ 2801 Begin 200 + 2dup 1 swap sound dup 3600 > Until drop drop \ drop the 10... ; \ STris-Score 10/5/01 9:20 CJS \ Copyright 2001 ⌐ \ Christopher J. Smith .( STris-Score... ) : Level>Speed ( Level -- Level Speed ) on: 0 do: 180 on: 1 do: 160 on: 2 do: 140 on: 3 do: 120 on: 4 do: 100 on: 5 do: 80 on: 6 do: 60 on: 7 do: 40 on: 8 do: 30 on: 9 do: 25 on: 10 do: 22 on: 11 do: 20 on: 12 do: 18 on: 13 do: 17 on: 14 do: 16 on: 15 do: 15 on: 16 do: 14 on: 17 do: 13 on: 18 do: 12 on: 19 do: 11 on: 20 do: 10 on: 21 do: 9 on: 22 do: 8 on: 23 do: 7 on: 24 do: 6 on: 25 do: 5 on: 26 do: 4 on: 27 do: 3 on: 28 do: 2 on: 29 do: 1 ; : EraseRocket ( -- ) 143 15 17 145 0 erase-rounded-rectangle ; : DrawRocket ( -- ) 148 9 Level @ * - 148 RocketPtr 2@ WinDrawBitmap ; : UpdateScore ( -- ) ScoreLbID Score @ Bonus @ + Stat ; : Score! ( # -- ) Score @ + Score ! UpdateScore EraseRocket Score @ 100 / BaseLevel @ + dup 29 > if drop 29 then Level ! DrawRocket Level @ Level>Speed swap drop BlockSpeed ! ; : Rows>Score ( #rows -- ) dup 1 = if 10 score! vSin @ 1+ vSin ! then dup 2 = if 10 score! vDou @ 1+ vDou ! then dup 3 = if 20 score! vTri @ 1+ vTri ! then 4 = if 40 score! vTet @ 1+ vTet ! then ; \ STris-BitMap 9/27/01 11:07 CJS \ Copyright 2001 ⌐ \ Christopher J. Smith .( STris-BitMap... ) : Block0 ( y x Block# -- ) 3drop ; : Block1 ( y x Block# -- ) drop Block1Ptr 2@ WinDrawBitmap ; : Block2 ( y x Block# -- ) drop Block2Ptr 2@ WinDrawBitmap ; : Block3 ( y x Block# -- ) drop Block3Ptr 2@ WinDrawBitmap ; : Block4 ( y x Block# -- ) drop Block4Ptr 2@ WinDrawBitmap ; : Block5 ( y x Block# -- ) drop Block5Ptr 2@ WinDrawBitmap ; : Block6 ( y x Block# -- ) drop Block6Ptr 2@ WinDrawBitmap ; : Block7 ( y x Block# -- ) drop Block7Ptr 2@ WinDrawBitmap ; : Block9 ( y x Block# -- ) drop 10 10 2swap erase-rectangle ; : Block8 ( y x Block# -- ) drop Block8Ptr 2@ WinDrawBitmap ; : DBlock ( y x Block# -- ) on: 0 do: Block0 on: 1 do: Block1 on: 2 do: Block2 on: 3 do: Block3 on: 4 do: Block4 on: 5 do: Block5 on: 6 do: Block6 on: 7 do: Block7 on: 8 do: Block8 on: 9 do: Block9 ; : IdLock Tbmp DmGetResource MemHandleLock ; : LockHandles ( -- ) 3083 IdLock Block1Ptr 2! 3084 IdLock Block2Ptr 2! 3085 IdLock Block3Ptr 2! 3086 IdLock Block4Ptr 2! 3087 IdLock Block5Ptr 2! 3088 IdLock Block6Ptr 2! 3089 IdLock Block7Ptr 2! 3090 IdLock Block8Ptr 2! 3091 IdLock RocketPtr 2! ; : UnlockHandles ( -- ) 3082 Begin 1+ dup Tbmp DmGetResource MemHandleUnlock drop dup 3091 = Until drop ; \ STris-Blocks 9/28/01 11:08 CJS \ Copyright 2001 ⌐ \ Christopher J. Smith .( STris-Blocks... ) : (BStore) ( y x block# -- ) Board{{ 2swap }} ! ; : Block>Board ( -- ) 4 Begin 1- 4 Begin 1- 2dup 2dup 2>r >r >r BlockY @ r> + BlockX @ r> + BlockBuffer{{ 2r> }} @ dup 0 > if (BStore) else 3drop then dup 0 = until drop dup 0 = until drop ; : Block>CBuffer ( Block# -- ) 1- 4 * BlkOffSet ! 4 Begin 1- 4 Begin 1- 2dup 2dup 2>r >r >r shapes{{ r> BlkOffSet @ + r> }} @ BlockCBuffer{{ 2r> }} ! dup 0 = until drop dup 0 = until drop ; : DrawNextBlock ( -- ) ShowTime NextBlock @ Block>CBuffer 4 Begin 1- 4 Begin 1- 2dup 2dup 2>r >r >r r> 10 * 40 + r> 10 * BlockCBuffer{{ 2r> }} @ dup 0= if drop 9 then DBlock dup 0 = until drop dup 0 = until drop ; : SetRMode ( Block# -- Block#) 2 RMode ! dup 1 = if 3 RMode ! then dup 3 = if 3 RMode ! then ; : Block>Buffer ( Block# -- ) SetRMode 1- 4 * BlkOffSet ! 4 Begin 1 - 4 Begin 1 - 2dup 2dup 2>r >r >r shapes{{ r> BlkOffSet @ + r> }} @ BlockBuffer{{ 2r> }} ! dup 0 = until drop dup 0 = until drop ; : RandomNext ( -- ) rand 7 mod 1+ NextBlock ! ; : YStore! ( # -- ) dup BlockY ! StartY ! ; : Next>Current ( -- ) NextBlock @ dup Block>Buffer dup 1 = if 0 YStore! then dup 2 = if 2 YStore! then dup 3 = if 1 YStore! then dup 4 = if 1 YStore! then dup 5 = if 1 YStore! then dup 6 = if 2 YStore! then 7 = if 2 YStore! then 3 BlockX ! RandomNext ; : DrawBlock ( -- ) 4 Begin 1- 4 Begin 1- 2dup 2dup 2>r >r >r 5 BlockY @ 10 * + r> 10 * + 40 - 44 BlockX @ 10 * + r> 10 * + BlockBuffer{{ 2r> }} @ 0 2swap swap dup 3 > if swap 2swap drop DBlock else 2drop 2drop then dup 0 = until drop dup 0 = until drop ; : ClearBlock ( -- ) 4 Begin 1- 4 Begin 1- 2dup 2dup 2>r >r >r 5 BlockY @ 10 * + r> 10 * + 40 - 44 BlockX @ 10 * + r> 10 * + BlockBuffer{{ 2r> }} @ 0 2swap swap dup 3 > if swap 2swap drop dup 0 > if drop 9 then DBlock else 2drop 2drop then dup 0 = until drop dup 0 = until drop ; \ STris-Rows 10/1/01 8:47 CJS \ Copyright 2001 ⌐ \ Christopher J. Smith .( STris-Rows... ) : ReDraw ( -- ) 10 Begin 1- 19 Begin 1- 2dup 2dup LoopY ! LoopX ! 10 * 35 - swap 10 * 44 + Board{{ LoopY @ LoopX @ }} @ dup 0 = if drop 9 then DBlock dup 4 = until drop dup 0 = until drop ; : DropRow ( row -- row ) dup Begin 1- 10 Begin 1- 2dup LoopX ! LoopY ! Board{{ LoopY @ LoopX @ }} @ Board{{ LoopY @ 1+ LoopX @ }} ! dup 0 = until drop dup 0 = until drop vLin @ 1+ vLin ! ; : ClearRows ( -- ) 0 RowsCleared ! 20 Begin 1- 0 BlocksFound ! 0 BombsFound ! 10 Begin 1- 2dup Board{{ 0 shuffle }} @ swap drop dup 0 > if BlocksFound @ 1+ BlocksFound ! then 8 = if BombsFound @ 1+ BombsFound ! then dup 0 = until drop BlocksFound @ 10 = if BombsFound @ 0= 0= if BombsFound @ 1+ Begin 1- Bell Bonus @ 10 + Bonus ! UpdateScore dup 0= Until drop then DropRow RowsCleared @ 1+ dup RowsCleared ! Rows>Score ReDraw Woop Drop 19 RowsCleared @ 4 = if Tetris! then then dup 2 = until drop ; \ STris-HighS 11/10/01 11:56 CJS \ Copyright 2001 ⌐ \ Christopher J. Smith .( STris-HighS... ) needs STris-Setup needs syncname needs fields : >HighScores ( -- ) false HS-Size HS-base >abs 1 2 [id] MxTs PrefSetAppPreferences ; : HighScores> ( -- f ) false HSPtr >abs HS-base >abs 2 [id] MxTs PrefGetAppPreferences 1 = ; : high? ( score -- pos f ) 10 Begin 1- 2dup Scores{ swap } @ > if swap drop true exit then dup 0= Until drop drop -1 False ; : high>buffer ( pos -- ) Names{ swap } NameBuffer 22 chars move ; : buffer>high ( pos -- ) Names{ swap } NameBuffer swap 22 chars move ; : shiftdown ( pos -- ) dup 0> if 0 Begin 1+ dup dup scores{ swap 1+ } @ swap scores{ swap } ! dup 1+ high>buffer dup buffer>high 2dup = Until drop then drop ; : s>high ( c-addr u pos -- ) Names{ swap } swap chars move ; : DefaultHS ( -- ) 712 Scores{ 0 } ! 855 Scores{ 1 } ! 981 Scores{ 2 } ! 1062 Scores{ 3 } ! 1100 Scores{ 4 } ! 1241 Scores{ 5 } ! 1372 Scores{ 6 } ! 1433 Scores{ 7 } ! 1572 Scores{ 8 } ! 1635 Scores{ 9 } ! 10 Begin 1- dup s" " rot s>high dup 0= Until drop s" Harry S. Truman" 0 s>high s" Dwight D. Eisenhower" 1 s>high s" John F. Kennedy" 2 s>high s" Lyndon B. Johnson" 3 s>high s" Richard M. Nixon" 4 s>high s" Gerald R. Ford " 5 s>high s" Jimmy Carter" 6 s>high s" Ronald W. Reagan" 7 s>high s" George Bush" 8 s>high s" William J. Clinton" 9 s>high ; : GetHS ( -- ) HighScores> 0= if DefaultHS then ; : SetUpHSForm ( -- ) 0 2 AT-XY 10 Begin 1- dup ." " 1+ dup 1 > if ." " then 11 swap - . ." " dup dup scores{ swap } @ dup 1000 < if ." " then . ." " names{ swap } 21 type cr dup 0 = Until drop ; : ShowHighScores ( -- ) UnlockKeys GameState @ LastMode ! 6 GameState ! HSFormID PopupForm SetUpHSForm ; : HSReturn ( -- ) LastMode @ dup GameState ! 0 = if StartFormID FrmReturnToForm else LockKeys FormID FrmReturnToForm then ; : GetName ( -- ) UnlockKeys GameState @ LastMode ! 7 GameState ! NameFormID PopupForm UserName NameField string>field drop ; : NameReturn ( -- ) score @ bonus @ + dup high? drop dup shiftdown s" " NameBuffer swap chars move NameBuffer NameField Field>String drop dup buffer>high scores{ swap } ! >HighScores ; \ STris-Rotate 9/30/01 11:48 CJS \ Copyright 2001 ⌐ \ Christopher J. Smith .( Rotate... ) cr : Buffer>CBuffer ( -- ) 4 Begin 1- 4 Begin 1- 2dup 2dup 2>r 2>r BlockBuffer{{ 2r> }} @ BlockCBuffer{{ 2r> }} ! dup 0 = until drop dup 0 = until drop ; : CBuffer>Buffer 4 Begin 1- 4 Begin 1- 2dup 2dup 2>r 2>r BlockCBuffer{{ 2r> }} @ BlockBuffer{{ 2r> }} ! dup 0 = until drop dup 0 = until drop ; : RotateRight 0 KeyWait ! Buffer>CBuffer ClearBlock RMode @ 1+ Begin 1- RMode @ 1+ Begin 1- 2dup 2dup 2>r 2>r BlockCBuffer{{ RMode @ r> - r> }} @ BlockBuffer{{ 2r> }} ! dup 0 = until drop dup 0 = until drop 0 YMove ! 0 XMove ! Move? if DrawBlock else CBuffer>Buffer DrawBlock then ; : RotateLeft 0 KeyWait ! Buffer>CBuffer ClearBlock RMode @ 1+ Begin 1- RMode @ 1+ Begin 1- 2dup 2dup 2>r 2>r BlockCBuffer{{ r> RMode @ r> - }} @ BlockBuffer{{ 2r> }} ! dup 0 = until drop dup 0 = until drop 0 YMove ! 0 XMove ! Move? if DrawBlock else CBuffer>Buffer DrawBlock then ; \ STris-Move 9/28/01 14:11 CJS \ Copyright 2001 ⌐ \ Christopher J. Smith .( Move... ) cr : (Move?) ( y x -- ) dup 10 < if dup -1 > if swap dup 19 < if swap 0 Board{{ 2swap }} @ swap drop 0 > if False Can? ! then else 2drop False Can? ! then else 2drop False Can? ! then else 2drop False Can? ! then ; : Move? ( -- Flag ) True Can? ! 4 Begin 1- 4 Begin 1- 2dup 2dup 2>r >r >r BlockY @ r> + YMove @ + BlockX @ r> + XMove @ + BlockBuffer{{ 2r> }} @ 0 > if (Move?) else 2drop then dup 0 = until drop dup 0 = until drop Can? @ dup False = if YMove @ 1 = if BlockY @ 2 < if 3 GameState ! then tick Block>Board Next>Current DelayNext @ 0= if DrawNextBlock then ClearRows 1 Score! ReDraw then else DelayNext @ if BlockY @ StartY @ = if DrawNextBlock then then then ; : BDown ( -- ) KeySpeed @ 4 - KeyWait ! 0 WaitCount ! 1 YMove ! 0 XMove ! Move? if ClearBlock BlockY @ 1+ BlockY ! DrawBlock then ; INLINE : BLeft ( -- ) 0 KeyWait ! 0 YMove ! 0 1- XMove ! Move? if ClearBlock BlockX @ 1- BlockX ! DrawBlock then ; INLINE : BRight ( -- ) 0 KeyWait ! 0 YMove ! 1 XMove ! Move? if ClearBlock BlockX @ 1+ BlockX ! DrawBlock then ; INLINE : TimeOut ( -- ) WaitCount @ 1+ dup BlockSpeed @ > if 1 YMove ! 0 XMove ! Move? if ClearBlock BlockY @ 1+ BlockY ! DrawBlock then drop 0 then WaitCount ! ; INLINE \ STris-Make 11/14/01 7:23 CJS needs STris cr .( Build PRC... ) ' go (id) MxTs MakePRC FreeTris cr .( Copy Resources... ) 3040 (ID) MBAR CopyRsrc 3001 (ID) Talt CopyRsrc 3082 (ID) Tbmp CopyRsrc 3083 (ID) Tbmp CopyRsrc 3084 (ID) Tbmp CopyRsrc 3085 (ID) Tbmp CopyRsrc 3086 (ID) Tbmp CopyRsrc 3087 (ID) Tbmp CopyRsrc 3088 (ID) Tbmp CopyRsrc 3089 (ID) Tbmp CopyRsrc 3090 (ID) Tbmp CopyRsrc 3091 (ID) Tbmp CopyRsrc 3092 (ID) Tbmp CopyRsrc 3095 (ID) Tbmp CopyRsrc 3096 (ID) Tbmp CopyRsrc 3097 (ID) Tbmp CopyRsrc 3098 (ID) Tbmp CopyRsrc 6004 (ID) Tbmp CopyRsrc 6005 (ID) Tbmp CopyRsrc 6006 (ID) Tbmp CopyRsrc 1000 (ID) tAIB CopyRsrc 1001 (ID) tAIB CopyRsrc 3104 (ID) tAIN CopyRsrc 3000 (ID) tFRM CopyRsrc 3002 (ID) tFRM CopyRsrc 3003 (ID) tFRM CopyRsrc 3004 (ID) tFRM CopyRsrc 3005 (ID) tFRM CopyRsrc 3006 (ID) tFRM CopyRsrc 6000 (ID) tFRM CopyRsrc 3101 (ID) tSTR CopyRsrc 3102 (ID) tSTR CopyRsrc \ 3103 (ID) tSTR CopyRsrc 3104 (ID) tSTR CopyRsrc 3106 (ID) tSTR CopyRsrc 1 (ID) tver CopyRsrc .( Delete Unused Resources... ) 1000 (ID) tFRM DelRsrc 1001 (ID) tFRM DelRsrc 1002 (ID) tFRM DelRsrc .( Complete ) a bye Version Log 1.0 Initial Release 1.1 Added Splash Screen Fixed Bug at level 21 Quicker Button Reading Optimized code Fixed High Score Numbering Bug Improved Graphics