[OpenBIOS] r538 - ofw/gui
svn at openbios.org
svn at openbios.org
Wed Aug 15 05:02:48 CEST 2007
Author: wmb
Date: 2007-08-15 05:02:48 +0200 (Wed, 15 Aug 2007)
New Revision: 538
Added:
ofw/gui/ofpong.fth
Log:
Pong - initial checkin.
Added: ofw/gui/ofpong.fth
===================================================================
--- ofw/gui/ofpong.fth (rev 0)
+++ ofw/gui/ofpong.fth 2007-08-15 03:02:48 UTC (rev 538)
@@ -0,0 +1,572 @@
+\ Adapted from http://members.aol.com/plforth/ofpong/20020313/ofpong.txt
+\ See also http://members.aol.com/plforth/ofpong/index.html
+\ Originally from 1.0d1 MacHack '98 release of OFPong.of found in OFPONG.SIT.
+
+decimal
+
+ 0 value erasecol
+-1 value 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
+
+0 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 screenw
+480 value screenh
+
+20 value ballsize
+ballsize 2 / value scoresize
+ballsize 5 * value batsize
+1000 value pscale
+
+0 value ball_limit_x
+ballsize pscale * value ball_limit_lo_y
+0 value ball_limit_hi_y
+
+ballsize pscale * value bat_limit_lo_y
+0 value bat_limit_hi_y
+
+0 value hit_limit_left_lo_x
+ballsize 2 * pscale * value hit_limit_left_hi_x
+0 value hit_limit_right_lo_x
+0 value hit_limit_right_hi_x
+
+ballsize pscale * value reflect_left_x
+0 value reflect_right_x
+
+: initlimits
+ " dimensions" $call-screen to screenh to screenw
+ screenw ballsize - pscale * to ball_limit_x
+ screenh ballsize 2 * - pscale * to ball_limit_hi_y
+ screenh ballsize batsize + - pscale * to bat_limit_hi_y
+ screenw ballsize 3 * - pscale * to hit_limit_right_lo_x
+ screenw ballsize - pscale * to hit_limit_right_hi_x
+
+ screenw ballsize 2 * - pscale * to reflect_right_x
+ get-msecs to grandseed
+;
+
+: random ( -- n ) grandseed 16807 * 17 + abs to grandseed grandseed 1000 mod ;
+: unscale ( n -- n ) pscale 2/ + pscale / ;
+: calcbatx ( n -- x ) screenw ballsize 3 * - * ballsize + ;
+: paintrect ( c pixx pixy pixw pixh -- ) " fill-rectangle" $call-screen ;
+
+\needs xy* : xy* ( x y w h -- x' y' ) rot * >r * r> ;
+
+\ Big digits for the score
+
+0 0 2value digitxy
+
+: rectcol ( x y w h c -- )
+ -rot >r >r -rot ( c x y r: h w )
+ scoresize dup xy* ( c x' y' r: h w )
+ digitxy xy+ ( c base-xy r: h w )
+ r> r> scoresize dup xy* ( c base-xy wh-scaled )
+ paintrect
+;
+
+: blackrect ( x y w h -- ) drawcol rectcol ;
+: whiterect ( x y w h -- ) erasecol rectcol ;
+
+: drawblank ( -- ) 0 0 4 7 whiterect ;
+
+: drawzero ( -- )
+ 0 0 1 7 blackrect
+ 1 0 2 1 blackrect
+ 1 6 2 1 blackrect
+ 3 0 1 7 blackrect
+ 1 3 2 1 whiterect
+;
+
+: drawone ( -- )
+ 3 0 1 7 blackrect
+ 0 0 3 7 whiterect
+;
+
+: drawtwo ( -- )
+ 0 0 4 1 blackrect
+ 3 1 1 2 blackrect
+ 0 3 4 1 blackrect
+ 0 4 1 2 blackrect
+ 0 6 4 1 blackrect
+ 0 1 1 2 whiterect
+ 3 4 1 2 whiterect
+;
+
+: drawthree ( -- )
+ 0 0 4 1 blackrect
+ 3 1 1 2 blackrect
+ 0 3 4 1 blackrect
+ 3 4 1 2 blackrect
+ 0 6 4 1 blackrect
+ 0 1 1 2 whiterect
+ 0 4 1 2 whiterect
+;
+
+: drawfour ( -- )
+ 0 0 1 3 blackrect
+ 0 3 3 1 blackrect
+ 3 0 1 7 blackrect
+ 1 0 2 1 whiterect
+ 0 4 3 3 whiterect
+;
+
+: drawfive ( -- )
+ 0 0 4 1 blackrect
+ 0 1 1 2 blackrect
+ 0 3 4 1 blackrect
+ 3 4 1 2 blackrect
+ 0 6 4 1 blackrect
+ 3 1 1 2 whiterect
+ 0 4 1 2 whiterect
+;
+
+: drawsix ( -- )
+ 0 0 1 7 blackrect
+ 1 3 2 1 blackrect
+ 1 6 2 1 blackrect
+ 3 3 1 4 blackrect
+ 1 0 3 3 whiterect
+;
+
+: drawseven ( -- )
+ 0 0 3 1 blackrect
+ 3 0 1 7 blackrect
+ 0 1 3 6 whiterect
+;
+
+: draweight ( -- )
+ 0 0 4 1 blackrect
+ 0 1 1 2 blackrect
+ 3 1 1 2 blackrect
+ 0 3 4 1 blackrect
+ 0 4 1 2 blackrect
+ 3 4 1 2 blackrect
+ 0 6 4 1 blackrect
+;
+
+: drawnine ( -- )
+ 0 0 1 4 blackrect
+ 1 0 2 1 blackrect
+ 1 3 2 1 blackrect
+ 3 0 1 7 blackrect
+ 0 4 3 3 whiterect
+;
+
+: drawdigit ( x y n -- )
+ -rot to digitxy ( n )
+ case
+ 0 of drawzero endof
+ 1 of drawone endof
+ 2 of drawtwo endof
+ 3 of drawthree endof
+ 4 of drawfour endof
+ 5 of drawfive endof
+ 6 of drawsix endof
+ 7 of drawseven endof
+ 8 of draweight endof
+ 9 of drawnine endof
+ endcase
+;
+
+: drawnumber ( startx starty num -- )
+ abs 100 /mod drop 10 /mod ( startxy 1s 10s )
+ swap >r >r ( startxy r: 10s 1s )
+ 2dup r> drawdigit ( startxy r: 1s )
+ scoresize 5 * 0 xy+ r> drawdigit ( )
+;
+
+\ Ball and bats
+
+: plotball ( x y -- )
+ drawcol -rot swap unscale swap unscale ballsize ballsize paintrect
+;
+: eraseball ( x y -- )
+ erasecol -rot swap unscale swap unscale ballsize ballsize paintrect
+;
+: plotbat ( x y -- )
+ drawcol -rot swap swap unscale ballsize batsize paintrect
+;
+: erasebat ( x y -- )
+ erasecol -rot swap swap unscale ballsize batsize paintrect
+;
+
+: redraw ( -- )
+ drawcol 0 0 screenw ballsize paintrect
+ drawcol 0 screenh ballsize - screenw ballsize paintrect
+
+ drawcol screenw scoresize - 2/ ballsize 2*
+ scoresize screenh ballsize 4 * - paintrect
+
+ ballsize 7 * ballsize 2* leftscore drawnumber
+ screenw ballsize 7 * 9 scoresize * + - ballsize 2* rightscore drawnumber
+ 0 calcbatx leftbaty plotbat
+ 1 calcbatx rightbaty plotbat
+ ballx bally plotball
+;
+
+: drawboard ( -- )
+ drawcol 0 0 screenw screenh paintrect
+ erasecol 0 0 screenw screenh paintrect
+ redraw
+;
+
+: resetball ( -- )
+ 500 to ballstop
+ screenw ballsize - 2 / pscale * ballx pscale mod + random + to ballx
+ screenh ballsize - 2 / pscale * bally pscale mod + random + to bally
+
+ random screenw pscale * * 2000000 / to balldx
+ random screenh pscale * * 2000000 / to balldy
+ balldx screenw pscale * 3000 / + to balldx
+ balldy screenh 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
+ screenh ballsize 2 * - batsize - pscale * to rightbaty
+
+ screenh pscale * 1000 / to batdy
+;
+
+: doreset ( -- )
+ resetball
+ 0 to leftscore
+ 0 to rightscore
+ drawboard
+;
+
+\ Keyboard drivers; just receiving keys is usually not good enough;
+\ the response is too slow. It is better to get up/down events or
+\ poll key states if you can.
+
+[ifdef] olpc
+\ This works with the FirmWorks pckbd driver. The key map below
+\ is good for the OLPC keyboard.
+: initkeys
+ ." Shift, Hand, Esc, Square" cr
+ d# 3000 ms
+ " stdin @ iselect ' get-scan 0 alarm iunselect" eval
+ false to key_left_up
+ false to key_left_down
+ false to key_right_up
+ false to key_right_down
+ false to key_esc
+ false to key_off
+;
+: restorekeys
+ " stdin @ iselect ' get-scan d# 10 alarm iunselect" eval
+;
+0 value e0-seen?
+: scankeys
+ begin " get-data?" stdin @ $call-method while ( scancode )
+ dup h# e0 = if
+ drop true to e0-seen?
+ else
+ dup h# 80 and 0= swap h# 7f and ( down? station )
+ case
+ h# 65 of
+ e0-seen? if to key_right_up else to key_left_up then
+ endof \ game up
+ h# 66 of
+ e0-seen? if to key_right_down else to key_left_down then
+ endof \ game down
+ h# 69 of to key_esc endof \ lower left game button
+ h# 2a of to key_left_up endof \ shift-left
+ h# 5b of to key_left_down endof \ hand-left
+ h# 36 of to key_right_up endof \ shift-right
+ h# 5c of to key_right_down endof \ hand-right
+ h# 5d of to key_esc endof \ square
+ h# 1 of to key_off endof \ ESC scancode
+ nip
+ endcase
+ false to e0-seen?
+ then
+ repeat
+;
+[else]
+\ This version uses "key" with normal ASCII. It is typically too slow
+\ dup to limited keyboard repeat rate.
+: initkeys ;
+: restorekeys ;
+: scankeys
+ false to key_left_up
+ false to key_left_down
+ false to key_right_up
+ false to key_right_down
+ false to key_esc
+ false to key_off
+ 0 to key_esc
+ key? if
+ key upc 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
+ 27 of true to key_esc endof
+ 8 of true to key_off endof
+ endcase
+ then
+;
+[then]
+
+: moveball ( oldx oldy newx newy -- ) 2swap eraseball 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
+;
+
+0 value batx
+: movebatup ( oldp delta -- )
+ 2dup >r >r ( oldp delta r: delta oldp )
+ erasecol batx r> batsize + r@ + ballsize r> negate paintrect
+
+ >r >r ( r: delta oldp )
+ drawcol batx r> r@ + ballsize r> negate paintrect
+;
+
+: movebatdown ( oldp delta -- )
+ 2dup >r >r ( oldp delta r: delta oldp )
+ erasecol batx r> ballsize r> paintrect
+
+ >r >r ( r: delta oldp )
+ drawcol batx r> batsize + ballsize r> paintrect
+;
+
+: movebat ( n oldy newy -- )
+ rot calcbatx to batx swap ( newy oldy )
+ over unscale over unscale - ( newy oldy deltay )
+ dup abs batsize < if ( newy oldy deltay )
+ dup if ( newy oldy deltay )
+ dup 0< if ( newy oldy deltay )
+ swap unscale swap movebatup ( newy )
+ else
+ swap unscale swap movebatdown ( newy )
+ then ( newy )
+ drop ( )
+ else ( newy oldy deltay )
+ 3drop ( )
+ then ( )
+ else ( newy oldy deltay )
+ drop ( newy oldy )
+ batx swap erasebat ( newy )
+ batx swap plotbat ( )
+ then
+;
+
+: updatebats ( deltat -- )
+ >r
+ 0 leftbaty 0 ( n oldy deltay )
+
+ over bat_limit_lo_y > if
+ key_left_up if batdy - then
+ then
+
+ over bat_limit_hi_y < if
+ key_left_down if batdy + then
+ then
+
+ r@ * ( n oldy deltay' ) \ Scale by the elapsed time
+ over + ( n oldy newy )
+ dup to leftbaty ( n oldy newy )
+ movebat
+
+ 1 rightbaty 0 ( 1 right dy )
+
+ over bat_limit_lo_y > if
+ key_right_up if batdy - then
+ then
+
+ over bat_limit_hi_y < if
+ key_right_down if batdy + then
+ then
+
+ r> * over +
+ dup to rightbaty
+ movebat
+;
+
+: initeverything ( -- )
+ cr
+ 0 to loopcount
+ 0 to totalupdate
+ initlimits
+ initvalues
+ initkeys
+ doreset
+ get-msecs to glastupdate
+;
+
+: doloop ( deltat -- )
+ loopcount 1 + to loopcount
+ dup totalupdate + to totalupdate
+
+ dup updatebats
+ dup updateball
+ redraw
+
+ glastupdate + to glastupdate
+;
+
+: pong ( -- )
+ 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 if doreset begin scankeys key_esc 0= until then
+ key_off until
+ restorekeys
+ h# ffff 0 0 screenw screenh paintrect
+ page
+\ " Count:" type loopcount .d cr
+\ " Avg millisec:" type totalupdate loopcount / .d cr
+;
+
+hex
+
+\ pong
More information about the OpenBIOS
mailing list