\ Fortris - a tetris clone in forth \ Alexander Bachinger, 0225468 \ Daniel Feledi, 0426231 \ Rudolf Mildner, 0426776 needs random.fs char # CONSTANT Border char @ CONSTANT Block_Char 32 CONSTANT Free 22 CONSTANT Field_Width 22 CONSTANT Field_Height 200000 CONSTANT var_level variable var_timestamp variable var_score create block_ary 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , variable block_pos_x variable block_pos_y create coll_ary Field_Width Field_Height * cells allot create count_line_ary Field_Height cells allot : store_block ( x4 y4 x3 y3 x2 y2 x1 y1 posx posy -- ) \ stores a block from the stack into the memory area block_pos_y ! block_pos_x ! 8 0 u+do block_ary 7 i - cells + ! loop ; : increase_score ( row_count -- ) \ increases the score according to the amount of rows deleted dup 1000 * * var_score @ + var_score ! ; : print_score ( -- ) \ prints out score on screen 0 Field_Height at-xy s" Score:" type 6 Field_Height at-xy var_score @ . ; : field_draw ( -- ) \ clears screen and draws the game's playfield page Field_Height 0 u+do Field_Width 0 u+do coll_ary Field_Width j * i + cells + @ emit loop cr loop print_score ; : add_pos ( x y dx dy -- x y ) \ does a translation dx,dy to x,y on the stack rot + rot rot + swap ; : draw_block_xy ( ch -- ) \ draws block currently in block_pos_x,block_pos_y,block_ary onto the screen { ch } 4 0 u+do block_pos_x @ block_pos_y @ block_ary i 2 * cells + @ block_ary i 2 * 1 + cells + @ add_pos at-xy ch emit loop 0 0 at-xy ; : generate_block ( -- ) \ creates a new tetris block randomly and stores it 7 random case \ create random block 0 of 0 -1 -1 0 0 0 1 0 endof \ block 1 "T" 1 of 0 -1 0 0 -1 1 0 1 endof \ block 2 "L1" 2 of 0 -1 0 0 0 1 1 1 endof \ block 3 "L2" 3 of 0 -1 -1 0 0 0 -1 1 endof \ block 4 "Z1" 4 of 0 -1 0 0 1 0 1 1 endof \ block 5 "Z2" 5 of 0 0 1 0 0 1 1 1 endof \ block 6 "O" 6 of 0 -1 0 0 0 1 0 2 endof \ block 7 "I" ( n ) 0 0 0 0 0 0 0 0 ( n ) endcase Field_Width 2 / 1- 2 \ set block origin store_block ; : simple_collision ( -- b ) \ checks if the currently active block collides with other blocks and returns -1 if 4 0 u+do block_pos_x @ block_pos_y @ block_ary i 2 * cells + @ block_ary i 2 * 1 + cells + @ add_pos Field_Width * + cells coll_ary + @ Free <> if true unloop exit endif loop false ; : del_rows ( -- ) \ checks which rows are full and deletes them, putting the rows over them down 0 \ counter #rows to move down 0 Field_Height 2 - -do \ loop over Field_Height Field_Width 1- 1 u+do \ loop over Field_Width coll_ary Field_Width j * i + cells + \ calc address dup dup >r >r @ \ save address in return stack Free r> ! \ Clear Field over Field_Width * cells r> + ! \ calc new position and store loop count_line_ary i cells + dup @ dup >r >r ( counter -- counter addr ; R: -- value value ) \ get row count 0 over ! ( counter addr -- counter addr ) \ reset old row over cells + r> swap ! ( counter addr -- counter ; R: value value -- value ) \ move row count r> Field_Width 2 - = if ( counter -- counter ; R: value -- ) \ check if full row 1+ ( counter -- counter++ ) \ inc counter endif 1 -loop increase_score \ = + row_count^2 * 1000 field_draw ; : fix_block ( -- ) \ write currently active block to the coll_ary, means fixing the block at its current position 4 0 u+do block_pos_x @ block_pos_y @ block_ary i 2 * cells + @ block_ary i 2 * 1 + cells + @ add_pos dup count_line_ary swap cells + dup @ 1+ swap ! Field_Width * + cells coll_ary + Block_char swap ! loop ; : new_timestamp \ calculate new timestamp and saves it utime drop var_level + var_timestamp ! ; : auto_move ( -- b ) \ returns if enough time has elapsed for next game move; if get new timestamp var_timestamp @ utime drop < dup if new_timestamp endif ; : move_down \ move active block down, if it collides, move it back and fix it at that pos Free draw_block_xy block_pos_y @ 1+ block_pos_y ! simple_collision if block_pos_y @ 1- block_pos_y ! Block_Char draw_block_xy fix_block del_rows generate_block simple_collision if unloop exit endif endif Block_Char draw_block_xy ; : move_side ( direction -- ) \ moves block left or right (direction: 1 = right or -1 left) dup -1 * >r >r Free draw_block_xy block_pos_x @ r> + block_pos_x ! simple_collision if block_pos_x @ r> + block_pos_x ! else r> drop endif Block_Char draw_block_xy ; : rotate_block ( angle -- ) \ rotates the currently active block according to angle (to left or right) 4 0 u+do dup dup ( angle -- angle angle angle ) \ dup rotation angle twice block_ary i 2 * cells + ( angle angle angle -- angle angle angle addr ) \ calc address dup dup dup >r >r >r ( angle angle angle addr -- angle angle angle addr ; R: -- addr addr addr ) \ save address 1 cells + @ ( angle angle angle addr -- angle angle angle y_value ) \ load y value swap ( angle angle angle y_value -- angle angle y_value angle ) \ swap y value and rotation angle r> @ ( angle angle y_value angle -- angle angle y_value angle x_value ; R: addr addr addr -- addr addr ) \ load x value * ( angle angle y_value angle x_value -- angle angle y_value y_new ) \ y' = x*angle r> 1 cells + ! ( angle angle y_value y_new -- angle angle y_value ; R: addr addr -- addr ) \ store new y value -1 * * ( angle angle y_value -- angle x_new )\ x' = -y*angle r> ! ( angle x_new -- angle ; R: addr -- ) \ store new x value loop drop \ drop angle ( angle -- ) ; : rotate ( -- ) \ rotates block and checks for collision Free draw_block_xy 1 rotate_block simple_collision if -1 rotate_block endif Block_Char draw_block_xy ; : end ( -- ) \ ends the game page s" Game Over! " type cr s" Your Score Is: " type var_score @ . cr bye ; : run ( -- ) \ main colon definition, gameloop Block_Char draw_block_xy begin auto_move if move_down else ekey? if ekey case [CHAR] w of rotate endof [CHAR] q of end endof [CHAR] a of -1 move_side \ move left endof [CHAR] d of 1 move_side \ move right endof [CHAR] s of move_down endof ( n ) ( n ) endcase endif endif again ; : init_coll_ary ( -- ) \ initializes collision array Field_Height 0 u+do Field_Width 0 u+do j 0 = j Field_Height 1- = or if Border else Free endif i 0 = i Field_Width 1- = or if drop Border endif coll_ary Field_Width j * i + cells + ! loop loop ; : init ( -- ) \ initialize game vars 0 var_score ! init_coll_ary generate_block new_timestamp Field_Height 0 u+do 0 count_line_ary i cells + ! loop ; : start ( -- ) \ starts the game init field_draw run ; start end