Forth
Version vom 6. September 2011, 17:34 Uhr von Loofmann (Diskussion | Beiträge)
Wunderschöne Programmiersprache! :-)
Hier mal als Beispiel ein in Forth programmiertes Pong für das Open Firmare von Apple Macintosh-Rechnern].
\ \ http://members.aol.com/plforth/ofpong/20020313/ofpong.txt
\ \
\ \ Wednesday, March 13, 2002
\ \ See also http://members.aol.com/plforth/ofpong/index.html
\ \
\ \
\ \ Hello, this is the game of Pong.
\ \
\ \ To play, store this file in the root folder of your Macintosh
\ \ HD, boot with Command+Option+O+F held down, and then enter
\ \ the command `boot hd:\ofpong.txt` but without the quotes.
\ \
\ \ While playing, hold down the A and Z keys to move the left
\ \ paddle up and down, hold down the ' and / keys to move the
\ \ right paddle up and down, press Esc to start a new game,
\ \ press Delete to quit.
\ \
\ \ After playing, enter the command `pong` to play some more,
\ \ or enter the command `bye` to get back to MacOS.
\ \
\ \
\ \ This code has been seen to work on a classic iMac, on an iBook,
\ \ and on a flat-planel iMac. Please write to tell us if it
\ \ doesn't work on your Mac. (Our web pages suggest addresses.)
\ \
\ \ Before modifying this code, you probably want to comment
\ \ out (or delete) the line at the end that says `pong`. That
\ \ way when you `boot` this code you can look at it and modify
\ \ it before running it.
\ \
\ \
\ \ To construct this file, we modified a copy of the
\ \ 1.0d1 MacHack '98 release of OFPong.of found in OFPONG.SIT.
\ \
\ \ 1) We copied the text into a SimpleText file, so that `boot`
\ \ knows it can read the text. (The original was a BBEdit file.)
\ \ To let us edit this in Mac OS X, we had to tell TextEdit to
\ \ make this a plain text file, not an Rtf text file.
\ \
\ \ 2) We commented out the source code below that begins with \.
\ \
\ \ 3) We added the source below that ends with \.
\ \
\ \ 4) We added the comments you see here that begin with \ \.
\ \
\ \
\ \ Technically speaking, our modifications included:
\ \
\ \ 1) Begin with a \ comment, like `boot` wants.
\ \
\ \ 2) Comment out the `dl` command, guessing that has something
\ \ to do with running this game over a serial or Usb connection,
\ \ as opposed to using `boot` to run this from a file system.
\ \
\ \ 3) End with a `pong` command so that `boot` runs the game.
\ \
\ \ 4) Use `dev keyboard` where `dev kbd` is unavailable, and
\ \ accordingly adjust which bits of the key-map to poll to see
\ \ the keys A Z ' / Esc Delete held down.
\ \
\ \ 5) Use [ s" dev keyboard get-key-map 0 to active-package"
\ \ evaluate ] in place of [ " get-key-map" ... $call-method ]
\ \ because [ s" keyboard" open-dev ] crashes a classic iMac hard.
\ \
\ \ 6) Draw with the background-color and erase with the
\ \ foreground-color, rather than with colors -1 and 0, because
\ \ on a flat-panel iMac the color -1 is black or transparent, not
\ \ visibly different from the black background color 0.
\ \
\ \
\ \ If you display this source code in a fixed width font like
\ \ Courier or Monaco, then the column ruler here might help you
\ \ keep your lines of source code short:
\ \
\ \ 0000011111111111222222222223333333333344444444444555555555556666
\ \ 56789_0123456789_0123456789_0123456789_0123456789_0123456789_123
\ dl
decimal
0 value gscreen
" screen" open-dev to gscreen
0 value gkbd
" kbd" open-dev to gkbd
\ 0 value gkeyboard \
\ " keyboard" open-dev to gkeyboard \
0 value erasecol
-1 value drawcol
foreground-color to erasecol \
background-color to drawcol \
0 value key_left_up
0 value key_left_down
0 value key_right_up
0 value key_right_down
0 value key_esc
0 value key_off
get-msecs value grandseed
0 value glastupdate
0 value loopcount
0 value totalupdate
0 value ballstop
0 value ballx
0 value bally
0 value balldx
0 value balldy
0 value leftbaty
0 value rightbaty
0 value batdy
0 value leftscore
0 value rightscore
640 value screenx
480 value screeny
: screen-prop@ ( prop-name prop-len -- value )
gscreen ihandle>phandle get-package-property
0= if
decode-int -rot 2drop
else
256
then
;
" width" screen-prop@ to screenx
" height" screen-prop@ to screeny
20 value ballsize
ballsize 2 / value scoresize
ballsize 5 * value batsize
1000 value pscale
screenx ballsize - pscale * value ball_limit_x
ballsize pscale * value ball_limit_lo_y
screeny ballsize 2 * - pscale * value ball_limit_hi_y
ballsize pscale * value bat_limit_lo_y
screeny ballsize batsize + - pscale * value bat_limit_hi_y
0 value hit_limit_left_lo_x
ballsize 2 * pscale * value hit_limit_left_hi_x
screenx ballsize 3 * - pscale * value hit_limit_right_lo_x
screenx ballsize - pscale * value hit_limit_right_hi_x
ballsize pscale * value reflect_left_x
screenx ballsize 2 * - pscale * value reflect_right_x
: random ( -- n ) grandseed 16807 * 17 + abs to grandseed grandseed 1000 mod ;
: unscale ( n -- n ) pscale 2 / + pscale / ;
: calcbatx ( n -- x ) screenx ballsize 3 * - * ballsize + ;
: paintrect ( c pixx pixy pixw pixh -- ) " fill-rectangle" gscreen $call-method ;
: rectcol ( startx starty x1 y1 x2 y2 c -- startx starty )
{ startx starty x1 y1 x2 y2 c }
c
x1 scoresize * startx +
y1 scoresize * starty +
x2 x1 - scoresize *
y2 y1 - scoresize *
paintrect
startx starty
;
: blackrect ( startx starty x1 y1 x2 y2 -- ) drawcol rectcol ;
: whiterect ( startx starty x1 y1 x2 y2 -- ) erasecol rectcol ;
: drawblank ( startx starty -- startx starty )
0 0 4 7 whiterect
;
: drawzero ( startx starty -- startx starty )
0 0 1 7 blackrect
1 0 3 1 blackrect
1 6 3 7 blackrect
3 0 4 7 blackrect
1 3 3 4 whiterect
;
: drawone ( startx starty -- startx starty )
3 0 4 7 blackrect
0 0 3 7 whiterect
;
: drawtwo ( startx starty -- )
0 0 4 1 blackrect
3 1 4 3 blackrect
0 3 4 4 blackrect
0 4 1 6 blackrect
0 6 4 7 blackrect
0 1 1 3 whiterect
3 4 4 6 whiterect
;
: drawthree ( startx starty -- startx starty )
0 0 4 1 blackrect
3 1 4 3 blackrect
0 3 4 4 blackrect
3 4 4 6 blackrect
0 6 4 7 blackrect
0 1 1 3 whiterect
0 4 1 6 whiterect
;
: drawfour ( startx starty -- startx starty )
0 0 1 3 blackrect
0 3 3 4 blackrect
3 0 4 7 blackrect
1 0 3 1 whiterect
0 4 3 7 whiterect
;
: drawfive ( startx starty -- startx starty )
0 0 4 1 blackrect
0 1 1 3 blackrect
0 3 4 4 blackrect
3 4 4 6 blackrect
0 6 4 7 blackrect
3 1 4 3 whiterect
0 4 1 6 whiterect
;
: drawsix ( startx starty -- startx starty )
0 0 1 7 blackrect
1 3 3 4 blackrect
1 6 3 7 blackrect
3 3 4 7 blackrect
1 0 4 3 whiterect
;
: drawseven ( startx starty -- startx starty )
0 0 3 1 blackrect
3 0 4 7 blackrect
0 1 3 7 whiterect
;
: draweight ( startx starty -- startx starty )
0 0 4 1 blackrect
0 1 1 3 blackrect
3 1 4 3 blackrect
0 3 4 4 blackrect
0 4 1 6 blackrect
3 4 4 6 blackrect
0 6 4 7 blackrect
;
: drawnine ( startx starty -- startx starty )
0 0 1 4 blackrect
1 0 3 1 blackrect
1 3 3 4 blackrect
3 0 4 7 blackrect
0 4 3 7 whiterect
;
: drawdigit ( startx starty n -- )
{ n }
n 0 = if drawzero then
n 1 = if drawone then
n 2 = if drawtwo then
n 3 = if drawthree then
n 4 = if drawfour then
n 5 = if drawfive then
n 6 = if drawsix then
n 7 = if drawseven then
n 8 = if draweight then
n 9 = if drawnine then
2drop
;
: drawnumber ( startx starty num -- )
{ startx starty num }
startx starty num abs 100 mod 10 / drawdigit
startx scoresize 5 * + starty num abs 10 mod drawdigit
;
: plotball ( x y -- ) { x y } drawcol x unscale y unscale ballsize ballsize paintrect ;
: eraseball ( x y -- ) { x y } erasecol x unscale y unscale ballsize ballsize paintrect ;
: plotbat ( n y -- ) { n y } drawcol n calcbatx y unscale ballsize batsize paintrect ;
: erasebat ( n y -- ) { n y } erasecol n calcbatx y unscale ballsize batsize paintrect ;
: redraw ( -- )
drawcol 0 0 screenx ballsize paintrect
drawcol 0 screeny ballsize - screenx ballsize paintrect
drawcol screenx scoresize - 2 / ballsize 2 * scoresize screeny ballsize 4 * - paintrect
ballsize 7 * ballsize 2 * leftscore drawnumber
screenx ballsize 7 * 9 scoresize * + - ballsize 2 * rightscore drawnumber
0 leftbaty plotbat
1 rightbaty plotbat
ballx bally plotball
;
: drawboard ( -- )
drawcol 0 0 screenx screeny paintrect
erasecol 0 0 screenx screeny paintrect
redraw
;
: resetball ( -- )
500 to ballstop
screenx ballsize - 2 / pscale * ballx pscale mod + random + to ballx
screeny ballsize - 2 / pscale * bally pscale mod + random + to bally
random screenx pscale * * 2000000 / to balldx
random screeny pscale * * 2000000 / to balldy
balldx screenx pscale * 3000 / + to balldx
balldy screeny pscale * 6000 / + to balldy
random 500 < if
balldx negate to balldx
then
random 500 < if
balldy negate to balldy
then
;
: initvalues ( -- )
ballsize 2 * pscale * to leftbaty
screeny ballsize 2 * - batsize - pscale * to rightbaty
screeny pscale * 1000 / to batdy
;
: doreset ( -- )
resetball
0 to leftscore
0 to rightscore
drawboard
;
: testkey ( map index mask -- bool )
{ map index mask } map index ca+ c@ mask and 0<>
;
\ : scankeys ( -- )
: gkbd-scankeys ( -- )
" get-key-map" gkbd $call-method
drop
dup 0 128 testkey to key_left_up
dup 0 2 testkey to key_left_down
dup 4 1 testkey to key_right_up
dup 5 8 testkey to key_right_down
dup 6 4 testkey to key_esc
dup 6 16 testkey to key_off
drop
;
: gkeyboard-scankeys ( -- ) \
s" dev keyboard get-key-map 0 to active-package" evaluate \
dup 0 8 testkey to key_left_up \ the A key
dup 3 4 testkey to key_left_down \ the Z key
dup 6 8 testkey to key_right_up \ the ' key
dup 7 128 testkey to key_right_down \ the / key
dup 5 64 testkey to key_esc \ the Esc key
dup 5 32 testkey to key_off \ the Delete key
drop \
; \
: forth-scankeys \
0 to key_esc
key? if \
key
dup 64 or [char] a = to key_left_up \
dup 64 or [char] z = to key_left_down \
dup [char] ' = to key_right_up \
dup [char] / = to key_right_down \
dup 27 = to key_esc \
dup 8 = to key_off \
drop \
then \
; \
: roelf-scankeys \
key? if key case \
[char] a of true to key_left_up endof \
[char] z of true to key_left_down endof \
[char] ' of true to key_right_up endof \
[char] / of true to key_right_down endof \
[char] q of true to key_esc endof \
true to key_off endof \
endcase then \
; \
: scankeys ( -- ) \
\ forth-scankeys \
\ roelf-scankeys \
gkbd if gkbd-scankeys else gkeyboard-scankeys then \
; \
: moveball ( oldx oldy newx newy -- )
{ oldx oldy newx newy }
oldx oldy eraseball
newx newy plotball
;
: doupdateball ( delta -- )
ballx swap bally swap
dup
balldx * ballx + to ballx
balldy * bally + to bally
ballx 0< if
resetball
balldx abs negate to balldx
ballx ballsize 2 * pscale * + to ballx
rightscore 1 + to rightscore
rightscore 15 = if
-1 to ballstop
then
then
ballx ball_limit_x > if
resetball
balldx abs to balldx
ballx ballsize 2 * pscale * - to ballx
leftscore 1 + to leftscore
leftscore 15 = if
-1 to ballstop
then
then
bally ball_limit_lo_y < if
balldy negate to balldy
ball_limit_lo_y 2 * bally - to bally
then
bally ball_limit_hi_y > if
balldy negate to balldy
ball_limit_hi_y 2 * bally - to bally
then
balldx 0< if
ballx hit_limit_left_lo_x hit_limit_left_hi_x between if
bally leftbaty ballsize pscale * - leftbaty batsize pscale * + between if
bally leftbaty < if
balldy abs negate to balldy
then
bally leftbaty batsize ballsize - pscale * + > if
balldy abs to balldy
then
ballx reflect_left_x > if
balldx abs random 50 / + to balldx
leftbaty bally - unscale
dup 0 batsize between if
batsize 2 / - random * 2 / batsize / 25 / balldy + to balldy
else
drop
then
then
then
then
then
balldx 0> if
ballx hit_limit_right_lo_x hit_limit_right_hi_x between if
bally rightbaty ballsize pscale * - rightbaty batsize pscale * + between if
bally rightbaty < if
balldy abs negate to balldy
then
bally rightbaty batsize ballsize - pscale * + > if
balldy abs to balldy
then
ballx reflect_right_x < if
balldx abs random 50 / + negate to balldx
rightbaty bally - unscale
dup 0 batsize between if
batsize 2 / - random * 2 / batsize / 25 / balldy + to balldy
else
drop
then
then
then
then
then
bally ball_limit_lo_y < if
ball_limit_lo_y to bally
then
bally ball_limit_hi_y > if
ball_limit_hi_y to bally
then
ballx bally moveball
;
: updateball ( delta -- )
ballstop 0= if
doupdateball
else
ballstop -1 = if
drop
else
ballstop swap - to ballstop
ballstop 0<= if
0 to ballstop
then
then
then
;
: movebatup ( n oldp delta -- )
{ n oldp delta }
erasecol n calcbatx oldp batsize + delta + ballsize delta negate paintrect
drawcol n calcbatx oldp delta + ballsize delta negate paintrect
;
: movebatdown ( n oldp delta -- )
{ n oldp delta }
erasecol n calcbatx oldp ballsize delta paintrect
drawcol n calcbatx oldp batsize + ballsize delta paintrect
;
: movebat ( n oldy newy -- )
{ n oldy newy }
newy unscale oldy unscale -
dup abs batsize < if
dup 0<> if
dup 0< if
n swap oldy unscale swap movebatup
else
n swap oldy unscale swap movebatdown
then
else
drop
then
else
drop
n oldy erasebat
n newy plotbat
then
;
: updatebats ( delta -- )
{ delta }
0 leftbaty 0
over bat_limit_lo_y > if
key_left_up 0<> if
batdy -
then then
over bat_limit_hi_y < if
key_left_down 0<> if
batdy +
then then
delta * over +
dup to leftbaty
movebat
1 rightbaty 0
over bat_limit_lo_y > if
key_right_up 0<> if
batdy -
then then
over bat_limit_hi_y < if
key_right_down 0<> if
batdy +
then then
delta * over +
dup to rightbaty
movebat
;
: initeverything ( -- )
cr
0 to loopcount
0 to totalupdate
initvalues
10 0 do scankeys loop
doreset
get-msecs to glastupdate
;
: doloop ( delta -- )
loopcount 1 + to loopcount
dup totalupdate + to totalupdate
dup updatebats
dup updateball
redraw
glastupdate + to glastupdate
;
: page 12 emit ; \
: runpong ( -- )
initeverything
begin
get-msecs glastupdate -
dup 0> if
dup 250 > if
drop
get-msecs to glastupdate
250
then
doloop
else
drop
then
scankeys
key_esc 0<> if
doreset
then
key_off 0<> until
page base @ decimal \
" Count:" type loopcount s. cr
" Avg millisec:" type totalupdate loopcount / s. cr
base ! \
;
: pong runpong ; \
hex \
pong \
\ \ (end of file) \ \
