\ tt.pfe        Tetris for terminals, redone in ANSI-Forth.
\               Written 05Apr94 by Dirk Uwe Zoller,
\                       e-mail duz@roxi.rz.fht-mannheim.de.
\               Look&feel stolen from Mike Taylor's "TETRIS FOR TERMINALS"
\
\               Please copy and share this program, modify it for your system
\               and improve it as you like. But don't remove this notice.
\

WINAPI: GetTickCount KERNEL32.DLL

\ ONLY FORTH ALSO DEFINITIONS DECIMAL

: BLANK ( --> ) BL FILL ;
: MS ( ms - ) >R  GetTickCount BEGIN GetTickCount OVER - R@ > UNTIL R> 2DROP ;
0 CONSTANT false
-1 CONSTANT true
: >=   < 0= ;
: <=   > 0= ;

: OFF 0! ;
: ON TRUE SWAP ! ;

: .R ( n # --> )
     >R DUP >R ABS S>D <# #S R> SIGN #> R> OVER - 0 MAX SPACES TYPE ;

S" lib\ext\case.f" INCLUDED
S" lib\include\facil.f" INCLUDED
S" devel\~day\common\console.f" INCLUDED
: PAGE  CLS ;

-1 VALUE create-turnkey? \ set to false when you don't want a turnkey app

\ warning OFF

\ Variables, constants

: 2CONSTANT ( x1 x2 "<spaces>name" -- )
  CREATE  , ,  DOES> 2@
;

BL BL 2CONSTANT empty           \ an empty position
VARIABLE wiping                 \ if true: wipe brick, else draw brick
2 CONSTANT col0                \ position of the pit
0 CONSTANT row0

10 CONSTANT wide                \ size of pit in brick positions
20 CONSTANT deep

\ 0x20004 VALUE left-key          \ customize if you don't like them
\ 0x20006 VALUE rot-key           \ currently this values are for the
\ 0x20005 VALUE right-key         \ arrow key's in Win32Forth
\ 0x20007 VALUE drop-key

90 VALUE left-key          \ customize if you don't like them
88 VALUE rot-key           \ currently this values are for the
67 VALUE right-key         \ arrow key's in Win32Forth
32 VALUE drop-key

CHAR P  VALUE pause-key
12      VALUE refresh-key
CHAR Q  VALUE quit-key

VARIABLE score
VARIABLE pieces
VARIABLE levels
VARIABLE delay

VARIABLE brow                   \ where the brick is
VARIABLE bcol


\ stupid random number generator

VARIABLE seed

: randomize     TIME&DATE + + + + + seed ! ;

1 CELLS 4 = [IF]
0x10450405 CONSTANT generator

: rnd  ( -- n )  seed @ generator UM* DROP 1+ DUP seed ! ;

: random ( n -- 0..n-1 )  rnd UM* NIP ;
[ELSE]
: random        \ max --- n ; return random number < max
                seed @ 13 * [ HEX ] 07FFF [ DECIMAL ] AND
                DUP seed !  SWAP MOD ;
[THEN]

\ Access pairs of characters in memory:

: 2C@           DUP 1+ C@ SWAP C@ ;
: 2C!           DUP >R C! R> 1+ C! ;

: d<>           D= 0= ;


\ Drawing primitives:

: 2emit         EMIT EMIT ;

: position      \ row col --- ; cursor to the position in the pit
                2* col0 + SWAP row0 + AT-XY ;

: stone         \ c1 c2 --- ; draw OR undraw these two characters
                wiping @ IF   2DROP 2 SPACES  ELSE  2emit  THEN ;


\ Define the pit where bricks fall into:

: def-pit       CREATE  wide deep * 2* ALLOT
                DOES>   ROT wide * ROT + 2* + ;

def-pit pit

: empty-pit     deep 0 DO wide 0 DO  empty J I pit 2C!
                LOOP LOOP ;


\ Displaying:

: draw-bottom   \ --- ; redraw the bottom of the pit
                deep -1 position
                [CHAR] + DUP stone
                wide 0 DO  [CHAR] = DUP stone  LOOP
                [CHAR] + DUP stone ;

: draw-frame    \ --- ; draw the border of the pit
                deep 0 DO
                    I -1   position [CHAR] | DUP stone
                    I wide position [CHAR] | DUP stone
                LOOP  draw-bottom ;

: bottom-msg    \ addr cnt --- ; output a message in the bottom of the pit
                deep OVER 2/ wide SWAP - 2/ position TYPE ;

: draw-line     \ line ---
                DUP 0 position  wide 0 DO  DUP I pit 2C@ 2emit  LOOP  DROP ;

: draw-pit      \ --- ; draw the contents of the pit
                deep 0 DO  I draw-line  LOOP ;

: show-key      \ char --- ; visualization of that character
                DUP BL <
                IF   [CHAR] @ OR  [CHAR] ^ EMIT  EMIT  SPACE
                ELSE  [CHAR] ` EMIT  EMIT  [CHAR] ' EMIT
                THEN ;

: show-help     \ --- ; display some explanations
                30  1 AT-XY ." ***** T E T R I S *****"
                30  2 AT-XY ." ======================="
                30  4 AT-XY ." Use keys:"
                32  5 AT-XY ." 'key   Z'  Move left"
                32  6 AT-XY ." 'key   C'  Move right"
                32  7 AT-XY ." 'key   X'    Rotate"
                32  8 AT-XY ." 'key Space'   Drop"
                32  9 AT-XY pause-key   show-key ."  Pause"
                32 10 AT-XY refresh-key show-key ."  Refresh"
                32 11 AT-XY quit-key    show-key ."  Quit"
                30 16 AT-XY ." Score:              Next piece:"
                30 17 AT-XY ." Pieces:"
                30 18 AT-XY ." Levels:"
                 0 22 AT-XY ."  ==== This program was written 1994 in pure dpANS Forth by Dirk Uwe Zoller ===="
                 0 23 AT-XY ."  =============================== SPF4 port  ===================================" ;

: update-score  \ --- ; display current score
                38 16 AT-XY score @ 3 .R
                38 17 AT-XY pieces @ 3 .R
                38 18 AT-XY levels @ 3 .R ;

: refresh       \ --- ; redraw everything ON screen
                PAGE draw-frame draw-pit show-help update-score ;


\ Define shapes of bricks:

: def-brick     CREATE  4 0 DO
                            ' EXECUTE  0 DO  DUP I CHARS + C@ C,  LOOP DROP
                            REFILL DROP
                        LOOP
                DOES>   ROT 4 * ROT + 2* + ;

def-brick brick1        S"         "
                        S" ######  "
                        S"   ##    "
                        S"         "

def-brick brick2        S"         "
                        S" <><><><>"
                        S"         "
                        S"         "

def-brick brick3        S"         "
                        S"   {}{}{}"
                        S"   {}    "
                        S"         "

def-brick brick4        S"         "
                        S" ()()()  "
                        S"     ()  "
                        S"         "

def-brick brick5        S"         "
                        S"   [][]  "
                        S"   [][]  "
                        S"         "

def-brick brick6        S"         "
                        S" @@@@    "
                        S"   @@@@  "
                        S"         "

def-brick brick7        S"         "
                        S"   %%%%  "
                        S" %%%%    "
                        S"         "

\ this brick is actually in use:
def-brick brick         S"         "
                        S"         "
                        S"         "
                        S"         "

\ this brick will come next:
def-brick next-brick    S"         "
                        S"         "
                        S"         "
                        S"         "

def-brick scratch       S"         "
                        S"         "
                        S"         "
                        S"         "

CREATE bricks   ' brick1 ,  ' brick2 ,  ' brick3 ,  ' brick4 ,
                ' brick5 ,  ' brick6 ,  ' brick7 ,

CREATE brick-val 1 C, 2 C, 3 C, 3 C, 4 C, 5 C, 5 C,

VARIABLE brick-value

: is-next-brick \ brick --- ; activate a shape of brick
                >BODY ['] next-brick >BODY 32 CMOVE ;

: get-next-brick \ --- ; select the next brick by random
                1 pieces +!  7 random
                bricks OVER CELLS + @ is-next-brick
                brick-val SWAP CHARS + C@ brick-value ! ;

: is-brick      \ brick --- ; activate a shape of brick
                >BODY ['] brick >BODY 32 CMOVE ;

: new-brick     \ --- ; select brick, count it
                ['] next-brick is-brick brick-value @ score +!
                get-next-brick ;

: rotleft       4 0 DO 4 0 DO
                    J I brick 2C@  3 I - J scratch 2C!
                LOOP LOOP
                ['] scratch is-brick ;

: rotright      4 0 DO 4 0 DO
                    J I brick 2C@  I 3 J - scratch 2C!
                LOOP LOOP
                ['] scratch is-brick ;

: draw-brick    \ row col
                4 0 DO 4 0 DO
                    J I brick 2C@  empty d<>
                    IF   OVER J + OVER I +  position
                        J I brick 2C@  stone
                    THEN
                LOOP LOOP 2DROP ;

: show-brick    wiping OFF draw-brick ;
: hide-brick    wiping ON  draw-brick ;

: draw-next-brick \ row col ---
                4 0 DO 4 0 DO
                    J I next-brick 2C@  empty d<>
                    IF   OVER J + OVER I +  position
                        J I next-brick 2C@  stone
                    THEN
                LOOP LOOP 2DROP ;

: show-next-brick    wiping OFF draw-next-brick ;
: hide-next-brick    wiping ON  draw-next-brick ;

: put-brick     \ row col --- ; put the brick into the pit
                4 0 DO 4 0 DO
                    J I brick 2C@  empty d<>
                    IF   OVER J +  OVER I +  pit
                        J I brick 2C@  ROT 2C!
                    THEN
                LOOP LOOP  2DROP ;

: remove-brick  \ row col --- ; remove the brick from that position
                4 0 DO 4 0 DO
                    J I brick 2C@  empty d<>
                    IF   OVER J + OVER I + pit empty ROT 2C!  THEN
                LOOP LOOP  2DROP ;

: test-brick    \ row col --- flag ; could the brick be there?
                4 0 DO 4 0 DO
                    J I brick 2C@ empty d<>
                    IF   OVER J +  OVER I +
                        OVER DUP 0< SWAP deep >= OR
                        OVER DUP 0< SWAP wide >= OR
                        2SWAP pit 2C@  empty d<>
                        OR OR IF   UNLOOP UNLOOP 2DROP false  EXIT  THEN
                    THEN
                LOOP LOOP  2DROP true ;

: move-brick    \ rows cols --- flag ; try to move the brick
                brow @ bcol @ remove-brick
                SWAP brow @ + SWAP bcol @ + 2DUP test-brick
                IF   brow @ bcol @ hide-brick
                    2DUP bcol ! brow !  2DUP show-brick put-brick  true
                ELSE  2DROP brow @ bcol @ put-brick  false
                THEN ;

: rotate-brick  \ flag --- flag ; left/right, success
                brow @ bcol @ remove-brick
                DUP IF   rotright  ELSE  rotleft  THEN
                brow @ bcol @ test-brick
                OVER IF   rotleft  ELSE  rotright  THEN
                IF   brow @ bcol @ hide-brick
                    IF   rotright  ELSE  rotleft  THEN
                    brow @ bcol @ put-brick
                    brow @ bcol @ show-brick  true
                ELSE  DROP false  THEN ;

: insert-brick  \ row col --- flag ; introduce a new brick
                2DUP test-brick
                IF   2DUP bcol ! brow !
                    2DUP put-brick  draw-brick  true
                ELSE  false  THEN ;

: drop-brick    \ --- ; move brick down fast
                BEGIN  1 0 move-brick 0=  UNTIL ;

: move-line     \ from to ---
                OVER 0 pit  OVER 0 pit  wide 2*  CMOVE  draw-line
                DUP 0 pit  wide 2*  BLANK  draw-line ;

: line-full     \ line-no --- flag
                true  wide 0
                DO  OVER I pit 2C@ empty D=
                    IF   DROP false  LEAVE  THEN
                LOOP NIP ;

: remove-lines  \ ---
                deep deep
                BEGIN
                    SWAP
                    BEGIN  1- DUP 0< IF   2DROP EXIT  THEN  DUP line-full
                    WHILE  1 levels +!  10 score +!  REPEAT
                    SWAP 1-
                    2DUP <> IF   2DUP move-line  THEN
                AGAIN ;

: to-upper      \ char --- char ; convert to upper case
                DUP [CHAR] a >= OVER [CHAR] z <= AND IF   BL -  THEN ;

: interaction   \ --- flag

                CASE  KEY to-upper 
                    left-key    OF  0 -1 move-brick DROP  ENDOF
                    right-key   OF  0  1 move-brick DROP  ENDOF
                    rot-key     OF  0 rotate-brick DROP  ENDOF
                    drop-key    OF  drop-brick  ENDOF
                    pause-key   OF  S"  paused " bottom-msg  KEY DROP
                                    draw-bottom  ENDOF
                    refresh-key OF  refresh  ENDOF
                    quit-key    OF  false EXIT  ENDOF
                ENDCASE  true ;

: initialize    \ --- ; prepare for playing
                randomize empty-pit refresh
                0 score !  0 pieces !  0 levels !  100 delay !
                get-next-brick ;

: adjust-delay  \ --- ; make it faster with increasing score
                levels @
                DUP  50 < IF   100 OVER -  ELSE
                DUP 100 < IF    62 OVER 4 / -  ELSE
                DUP 500 < IF    31 OVER 16 / -  ELSE  0  THEN THEN THEN
                delay !  DROP ;

: play-game     \ --- ; play one tetris game
                BEGIN
                    15 30 hide-next-brick
                    new-brick
                    15 30 show-next-brick

                    -1 3 insert-brick
                WHILE
                    BEGIN  4 0
                        DO  35 13 AT-XY
                            delay @ MS  KEY?
                            IF  interaction 0=
                                IF   UNLOOP EXIT  THEN
                            THEN
                        LOOP
                        1 0 move-brick  0=
                    UNTIL
                    remove-lines
                    update-score
                    adjust-delay
                REPEAT ;

\ FORTH DEFINITIONS

: tt            \ --- ; play the tetris game
      PAGE
                initialize
                S"  Press any key " bottom-msg KEY DROP draw-bottom
                BEGIN
                    play-game
                    S"  Again? " bottom-msg KEY to-upper [CHAR] Y =
                WHILE  initialize  REPEAT
                create-turnkey?
                IF    BYE \ quit our turnkey application
                ELSE 0 23 AT-XY CR
                THEN ;


\ create a turnkey application
create-turnkey? [IF]

FALSE TO SPF-INIT?
' ANSI>OEM TO ANSI><OEM
FALSE TO ?GUI
' tt TO <MAIN>
S" tetris.exe" SAVE

tt

[ELSE]

tt

[THEN]

Джеймс Хейг

В те времена, когда я следил за группой comp.lang.forth в Usenet, я был не единственным, кого неприятно удивляло отсутствие людей, способных выделывать интересные штуки с Фортом. Элизабет Ратер, сооснователь Forth, Inc., предложила такое объяснение: есть люди, занимающиеся реальными проблемами языка, но в ньюсгруппе они не сидят. Она это знала наверняка: её компания была создана для поддержки создания коммерческих проектов на Форте.

В 1996 году я работал над портированием игры The Need for Speed на Sega Saturn. (Эта игровая приставка вам кажется необычной для того, чтобы с ней связываться? А я занимался разработкой под 3DO и посетил конференцию Jaguar в головном отделе Atari.) Уже в 90-х было некоторое количество известных разработчиков, но ведущие специалисты, занимавшиеся оригинальной версией выпущенной в 1994 году The Need for Speed, были никому неизвестными людьми. И это несмотря на то, что они написали игру, основанную на физике твердых тел, до того, как большинство других узнали, что эти слова вообще относятся к разработке 3D-видеоигр. И сделали они это без математического сопроцессора: весь движок использовал арифметику с фиксированной запятой.

Да, сейчас многие пишут в блогах или ещё каким-то путем публично обсуждают методологию и то, над чем они сейчас работают, но есть ещё большей людей, не делающих этого. Блогерство отнимает время, и, к примеру, не всем оно нравится. Другие же работают над коммерческими продуктами и не могут позволить себе разглашать внутренние наработки собственного кода.

Необычный аспект наших сетевых обсуждений состоит в том, что от тихого большинства мы научиться ничему не можем. Факт наличия известного ореола презрения вокруг C++, Perl или других языков ещё не означает того, что этими языками не пользуются очень умные ребята, которые строят потрясающие, прекрасно выполненные программы. Безумно плюсуемая привлекательная теория может иметь хорошо известные, но неочевидные недостатки. Мы видим лишь мнения людей, которые работают над интересными вещами и пишут о них — только и всего. Большая же часть разработчиков, к примеру, Chrome не имеет активных профилей в Twitter, не пишет в блоги, не использует Github, вы сможете связаться с ними только в списках рассылок и в багрепортах, и то лишь потому, что Chrome является свободным программным обеспечением.

Вам лучше будет попробовать многое самим, чем слушать то, что думают другие.