Module: tetris			Group: Introduction


Word: TheTetrisGame

Text: TheTetrisGame
  ணࠬ ᮧ  ᭮ "tt.pfe"-Tetris, ᠭ 
મ ஬  PFE.   ANSI-ᮢ⨬  ਣ, 
 - ⠪  ।⠢ ᨨ.
Tetris  ७  Holon ᮬ ૥  筮 
ࠡ⠭ 䮬 म.  
Tetris   Holon  ࠡ 樮 ணࠬ.



Word: TheRules

Text: TheRules
 ࠧ筮   㣠  ३  륬. 
  ६ ⥪騩    ࠢ   
   ?    ? ,        ? . 
  ⮨  ⮬, ⮡ ନ஢  ப  
஬⪮.  "⮢" ப 㤠, ᢮ 
࠭⢮  㣨 . 
  ப  㢥稢 ਧ 窨.    ?    
 אַ ,   ஡  ਮ⠭ ,
     ୮,    Q  稢 ⥪ .



Group: Pit

Word: PitWidth
12 constant PitWidth


Word: PitDepth
16 constant PitDepth


Word: DefinePit
\ ।饥 ᫮  pit (륬).   ᨢ   
\ । ⢨ 륬.  륬 頥   i,j. 
: DefinePit 
create   PitWidth  PitDepth  *  allot
does>   rot  PitWidth  *  rot  +  +   ;    ( i j -- adr )


Word: Pit       	\ ।  륬.
DefinePit  Pit


Word: PitX0		\ 孨  㣮 륬.
5  constant  PitX0


Word: PitY0
4  constant  PitY0



Word: Position	\ ⠭     row  col   륬.
: Position  ( row col -- )
2* PitX0 + swap PitY0 + xy ;


Word: Black		\  䮭.
0 constant Black


Word: Draw?
Flag Draw?


Word: 2emit	
	: 2emit   ( c -- ) 
	dup  emit  emit  ;


Word: Stone
\ 뢮  뢮  ᨬ  ਡ⮬ b (=0, ᫨ blank)
 : Stone   ( b -- ) 
Attribute  swap 
Draw?  over  and
if    8  +  Black  +  is  Attribute   178  2emit 
else  drop  Black  is  Attribute  2  spaces 
then  is  Attribute   ;



Word: EmptyPit	\  pit-ᨢ ﬨ.
: EmptyPit
0  0  Pit  PitWidth  PitDepth  *  erase   ;


Group: Drawing

Word: Wall
: Wall
      177  2emit   ;


Word: DrawBottom		\   ( ) 륬.
: DrawBottom
 PitDepth  -1  Position 
 PitWidth  2+  0  do  Wall  loop   ;


Word: DrawFrame		\ 뢮 ࠬ 륬.
    : DrawFrame
 PitDepth  0 
 do i -1  Position  Wall  i PitWidth  Position  Wall  loop 
 DrawBottom  ;


Word: DrawLine
: DrawLine  ( line -- ) 
dup  0  Position 
PitWidth  0  do  dup  i  Pit  c@  stone  loop   drop  ;



Word: DrawPit		\ 뢮 ᮤন 륬.
: DrawPit
 PitDepth  0  do  i  DrawLine  loop  ;


Word: ShowHelp
: ShowHelp
50   1 xy  ." ***** T E T R I S *****"
50   2 xy  ." ======================="
50   5 xy  ." left :       Move left"
50   6 xy  ." right:      Move right"
50   7 xy  ." up   :      Rotate"
50   8 xy  ." down :   Drop"
50   9 xy  ." space:   Pause"
50 11 xy  ." 'Q'  :      Quit"
  3   1 xy  ." Score:"
16   1 xy  ." Pieces:"
31   1 xy  ." Levels:" 
;


Word: Score		0  integer  Score


Word: Pieces		0 integer Pieces


Word: Levels		0 integer Levels


Word: Delay		0 integer Delay


Word: UpdateScore		\ 뢠 ⥪騩 
: UpdateScore
10 1 xy  bold Score   3 .r normal
24 1 xy  Pieces  3 .r
39 1 xy  Levels  3 .r  ;


Word: Refresh		\ ᮢ뢠   ࠭.
: Refresh 
page  DrawFrame  DrawPit  ShowHelp  UpdateScore  ;



Group: Bricks

Word: Brick:
\ ।饥 ᫮  .
:  Brick: 
create  8 0 do  c,  loop   ( 8bytes -- )
does>  ;


Word: Brick1 
\ ଠ  梥 ⭮ , । ᫠ <> 0.
	1 1 1 0
0 1 0 0   Brick: Brick1


Word: Brick2		2 2 2 2
0 0 0 0   Brick: Brick2


Word: Brick3		0 3 3 3
0 3 0 0   Brick: Brick3


Word: Brick4		4 4 4 0
0 0 4 0   Brick: Brick4


Word: Brick5		0 5 5 0
0 5 5 0   Brick: Brick5


Word: Brick6		6 6 0 0
0 6 6 0   Brick: Brick6


Word: Brick7		0 7 7 0
7 7 0 0   Brick: Brick7


Word: Bricks
\  믮塞 ⮪  . 
\   : 
\  ','  騬 ᫮  .
create  Bricks
 ' Brick1 ,  ' Brick2 ,  ' Brick3 ,  ' Brick4 , 
 ' Brick5 ,  ' Brick6 ,  ' Brick7 ,



Word: Scratch	create  Scratch   16  allot



Word: scratch!  (~~   ᠬ 砫, ਯ, ࠡ稩,  ..)
\ ࠭  b   i,j scratch-ᨢ.  뢠  
\    ⢨ ⥪  ࠬ ⥪.
: scratch!   ( b i j -- ) 
scratch                       \ --  b  i  j  adr 
rot                              \ --  b  j  adr  i
4 *                              \ --  b  j  adr  n 
rot                              \ --  b  adr  n  j
+                                \ --  b  adr  n2
+                                \ --  b  adr2 
c!  ;


Word: Brick
\ ন ࠧ ⥪饣 .
create  Brick  16  allot


Word: brick@
: brick@   ( i j -- b ) 
brick rot 4 * rot + + c@  ;


Word: BrickValue	\ 祭  ""  㤭  .
create  BrickValue
1 c,  2 c,  3 c,  3 c,  4 c,  5 c,  5 c,


Word: isBrick
\  ⠢  ⥪饣   "brick". 
\  xt -  믮 ⮪ brick-᫮, 
\   믮  頥   ⮣ .
: isBrick  ( xt -- ) 
Brick  16  erase 
execute        ( -- adr )
8  times  dup  i  +  c@   Brick  4  +  i  +  c!   loop 
drop   ;



Group: ShowBrick

Word: bRow
\ Brick .
0  integer  bRow


Word: bCol
0  integer  bCol


Word: Random
\ ⠢ 砩 ᫮,  祬 ᨬ쭮.
: Random   ( max -- u )
time@  +  +  +   swap  mod   ;


Word: NewBrick
\  ᯮ冷筮 (砩)  brick,    .
: NewBrick
1  add  Pieces   7  Random 
Bricks  over  cells  +  @  isBrick 
BrickValue  swap  chars  +  c@  add  Score   ;


Word: RotateLeft
\ 頥 ⥪騩 brick .
: RotateLeft
4  0  do  4  0  do  j  i  brick@  3  i  -  j  scratch!  loop  loop 
Scratch  Brick  16  move   ;



Word: RotateRight
\ 頥 ⥪騩 brick ࠢ.
: RotateRight
4  0  do  4  0  do  j  i  brick@   i  3  j  -  scratch!  loop  loop 
Scratch  Brick  16  move   ;



Word: Rotate
\ 頥 brick ᮣ᭮ 䫠 f.
: Rotate   ( f -- ) 
if  RotateRight  else  RotateLeft  then   ;



Word: DrawBrick

: DrawBrick
4  0  do  4  0  do 
j  i  brick@  0<> 
if  brow  j  +  bcol  i  +  Position   j  i  brick@  Stone  then 
loop  loop   ;



Word: ShowBrick
: ShowBrick
 set  Draw?  DrawBrick  ;



Word: HideBrick
: HideBrick
clear  Draw?  DrawBrick  ;



Group: MoveBrick

Word: PutBrick
\ 頥  ௨    륬.
: PutBrick
4  0  do  4  0  do 
j  i  brick@  0<> 
if  brow  j  +  bcol  i  +  Pit   j  i  brick@  swap  c!  then 
loop  loop   ;


Word: Brick?
\ ௨    ⠬?
: Brick?  ( row col -- f )
4 0 do  4 0 do 
j  i  brick@  0<> 
if   over  j  +  over  i  + 
     over  dup  0<   swap  PitDepth  >=  or 
     over  dup  0<   swap  PitWidth  >=  or
     2swap  Pit  c@   0<> 
     or  or  if  unloop  unloop  2drop  false  exit  then 
then
loop  loop  2drop  true  ;


Word: RemoveBrick
\  ௨  ⮩ 樨.
: RemoveBrick 
brow  bcol
4  0  do   4  0  do 
j  i  brick@   0<> 
if  over  j  +   over  i  +  Pit   0  swap  c!  then 
loop  loop
2drop ;


Word: MoveBrick?
\ ஡ ६ ௨.
: MoveBrick?  ( rows cols -- f ) 
RemoveBrick
swap  brow  +   swap  bcol  +
2dup  Brick?
if    HideBrick   is  bCol  is  bRow 
      ShowBrick   PutBrick   true 
else  2drop  PutBrick   false 
then ;


Word: RotateBrick		\ f = /ࠢ

    : RotateBrick  ( f -- ) 
brow 0< if drop exit then          \      饭 
RemoveBrick  dup  Rotate 
brow  bcol  Brick?
over  0=  Rotate 
if   HideBrick  Rotate  PutBrick  ShowBrick 
else  drop 
then   ;


Word: InsertBrick?		\ ।⠢  ௨.

: InsertBrick?  ( row col -- flag )
2dup Brick?
if   is  bcol  is  brow  PutBrick  DrawBrick  true 
else  2drop  false 
then   ;


Word: DropBrick
\ ६頥  ௨ .
: DropBrick 
begin 1 0 MoveBrick? 0= until ;




Group: Lines

Word: MoveLine
: MoveLine  ( from to -- ) 
over  0  Pit   over  0  Pit   PitWidth  move   DrawLine 
dup  0  Pit  PitWidth  erase   DrawLine   ;



Word: LineFull?
\ ⠢ ⨭, ᫨ ப  ௨砬.
: LineFull?   ( line# - f ) 
true
PitWidth  0 
do   over  i  Pit  c@  0=  if  drop  false  leave  then   loop 
nip   ;


Word: RemoveLines
: RemoveLines
 PitDepth  dup 
 begin  swap 
begin  1-  dup  0<  if  2drop  exit  then 
dup  LineFull?
while   1 add Levels  10 add Score 
repeat
swap  1-  2dup  <>  if   2dup  MoveLine   then 
again ;




Group: Playing


Word: End?
Flag End?



Word: AskMessage
\ 뢠 ᮮ饭 "adr   , ⠢  . 
: AskMessage   ( "adr -- c )
@xy  rot  SaveScreen
50  20  xy  ." --- "  "type  ."  ---"  key 
RestoreScreen  -rot  xy   ;



Word: >Upper
\ ८ࠧ뢠 ᨬ c1  孨 ॣ c2.
: >Upper  ( c1 -- c2) 
dup  [char]  a  >=  over  [char]  z  <=  and  if  $20  -  then  ;



Word: CharCases
: CharCases   ( c -- ) 
case  >Upper 
'bl      of  "  paused " AskMessage drop  endof
 [char]  Q  of  set  End?   endof 
drop  endcase  ;


Word: FuncCases
: FuncCases   ( c -- )
case
75 ( left ) of  0 -1 MoveBrick? drop   endof
77 ( right) of  0  1 MoveBrick? drop   endof 
\     		            72 ( up )   of  0 RotateBrick  endof 
\ 		            80 ( down ) of  DropBrick  endof 
drop  endcase   ;




Word: Interaction
: Interaction  ( -- ) 
key ?dup if CharCases else FuncCases then  ;



Word: Initialize
\ ࠡ⪠  .
: Initialize
0 is Score  0 is Pieces  0 is Levels  100 is Delay 
emptyPit  Refresh  clear End?  !sp  ;



Word: AdjustDelay
\   ॥  㢥稢饣 .
: AdjustDelay 
Levels
dup  50 < if  100 swap - 
else dup 100 < if  62 swap 4 /  -
else dup 500 < if  31 swap 16 / -
else drop 0 
then then then 
is Delay  ;



Word: ?Interaction
\ ⢨ 짮⥫?
: ?Interaction
 Delay  msec 
 key?  if  Interaction  then   ;


Word: StartBrick?
\  :  ...  ⮤ ⠢  ६ 믮 Tetris' ...
\  ( backslash । 㣮 ப,  १㧨 ᫮).

   : StartBrick?   ( -- f ) 
   \     NewBrick  -1  8 InsertBrick?           \ ⠢  業 
         NewBrick  -1  PitWidth  2/  Random  InsertBrick?   \ ⠢ ந쭮 
       ;



Word: PlayGame
\   Tetris-.
: PlayGame 
begin  StartBrick?
while   begin  4  0  do  ?Interaction  loop 
End?  if  exit  then
1  0  moveBrick?   0= 
until
RemoveLines  UpdateScore  AdjustDelay 
repeat  ;




Group: Tetris

Word: TetrisGame
\ ⥫쭮 ᫮ ६-믮... ᪠ .

: TetrisGame 
Initialize CurOff " Press any key" AskMessage drop 
begin  PlayGame 
"  Again? (Y/N)" AskMessage >Upper [char] Y =
while  Initialize 
repeat
page  50 20 xy  ." --- bye (see you later) --- " ;



Word: Tetris
\ Tetrisprogram 믮  ᭮  (the main task).
\ ᫨  ᪠    ,   (host)  
\ 襭 ணࠬ.
: Tetris 
      Console TetrisGame  ;


Word: TheTetris
\  Tetris ⮢ ᫮ (the startword) turnkey-ᨨ 
\ ணࠬ  tetris.
\  Ctl+F7=Turnkey, ⮡ ࠭   䠩 TURNKEY.EXE.
( TheTetris ) 
Program: Tetris




Group: TetrisTask

Word: TetrisTask

\   믮 Tetris  . 
\    ⠭ ᯮᮡ묨  
\  ࠡ  Tetris'   ६  믮.

Task  TetrisTask




Word: TaskProgram

\ Task-ணࠬ,  ⮢  祩.
: TaskProgram 
Screen  TaskKeys  TetrisGame  ;




Word: StartTetris

\ 稭 Tetris .
: StartTetris
 make  TetrisTask  TaskProgram   start  TetrisTask   ;




Word: StopTetris		\ ⠭ .
: StopTetris
 stop  TetrisTask   ;



