Forth

\ \ 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) \ \