Forth

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