( bump micro 06.06.2001 )

"modules" 
"graphics" 
"rnd"
"os_events"

api: WinDrawRectangle
api: WinEraseLine
api: WinEraseRectangle

: boxr ( x y w h r -- )
    >r rect1 rect!
    rect1 >abs r> WinDrawRectangle
;

: box ( x y w h -- )
    0 boxr
;

: EraseBoxR
    >r rect1 rect!
    rect1 >abs r> WinEraseRectangle
;

: EraseBox ( x y w h -- )
    0 EraseBoxR
;

module: Blocks
80 value cnt
0 value array
8 constant blw
8 constant blh
20 constant cx
20 constant cy

: AllotArray
cx cy * allocate throw to array ;

: FreeArray array free throw ;

: coord> ( x y -- addr )
cx * + array + ;

: IsBlock ( x y -- f ) coord> C@ 0<> ;

: SetBlock ( x y -- ) coord> 0xFF swap C! ;

: ShowBlock ( x y -- )
2dup 2>r
blw * swap blh * swap
blw blh
2r> IsBlock
 if Box else EraseBox then ;

: BlankArray
array cx cy * erase
cx 0 do i 0 SetBlock i cy 1- SetBlock loop
cy 1- 1 do 0 i SetBlock cx 1- i SetBlock loop ;

: FillArray ( -- )
cnt 0 do
cx 2 - choose 1+
cy 2 - choose 1+
SetBlock
loop ;

: ShowArray
cy 0 do i
cx 0 do i over ShowBlock
loop drop loop ;

: >BlockCoord ( x y -- x1 y1 )
blh / swap blw / swap ;
;module

module: Ball
module: pix
0
cell -- x
cell -- y
cell -- sx
cell -- sy
cell -- head
cell -- stopped
constant /size


100 constant units/pixel

: >scr ( x|y -- x1|y1 ) units/pixel / ;

: show ( pix -- )
>r r@ x @ >scr r@ y @ >scr r> head @ 
if plot else 2dup WinEraseLine then ;

: InBlock ( pix -- f )
dup x @ >scr swap y @ >scr
{{ Blocks >BlockCoord IsBlock }} ;

units/pixel 2 / constant OnBlockHeight

: OnBlock ( pix -- f )
dup y OnBlockHeight swap +!
dup InBlock >r
dup y OnBlockHeight negate swap +!
sy @ abs OnBlockHeight < r> and ;

: OntoBlock ( pix -- f )
dup OnBlock swap
sy @ abs OnBlockHeight 10 / < and ;

: sgn dup 0< if drop -1 else if 1 else 0 then then ;

: to0 ( n1 -- n2 ) 0 max ;

: SlowerSpeed ( s1 s -- s2 ) over abs swap - to0 swap sgn * ;

: HorizBumpNewSpeed ( s1 -- s2 ) 1 SlowerSpeed ;
: VertBumpNewSpeed ( s1 -- s2 ) 5 SlowerSpeed ;
: VertGravNewSpeed ( s1 -- s2 ) 1 + ;
: RollNewSpeed ( s1 -- s2 ) 1 SlowerSpeed ;

: moveH ( pix -- ) >r
r@ x @ r@ sx @ + r@ x !
r@ InBlock if
r@ x @ r@ sx @ 2 * - r@ x !
r@ sx @ negate HorizBumpNewSpeed r@ sx !
then rdrop ;

: moveV ( pix -- ) >r
r@ y @ r@ sy @ + r@ y !
r@ InBlock if
r@ y @ r@ sy @ 2 * - r@ y !
r@ sy @ negate VertBumpNewSpeed r@ sy !
then r@ OnBlock 0= if r@ sy @ VertGravNewSpeed r@ sy ! then rdrop ;

: move ( pix -- ) >r
r@ stopped @ 0= if
r@ InBlock if r@ stopped on else
r@ sx @ r@ sy @ or 0= r@ OnBlock and if
r@ stopped on else
r@ moveH r@ moveV
r@ OntoBlock if r@ sx @ RollNewSpeed r@ sx ! then
then then then rdrop ;
;module

variable cnt

create p0 800 , 800 , 100 , 0 , -1 , 0 ,

create head {{ pix /size }} allot
create tail {{ pix /size }} allot

20 value TailLen

: init
p0 head {{ pix /size }} move
p0 tail {{ pix /size }} move
tail {{ pix head }} off
0 cnt ! ;

: move
head {{ pix move }} head {{ pix show }}
cnt @ TailLen <> if 1 cnt +! else
tail {{ pix move }} tail {{ pix show }}
then ;

: go
init
head {{ pix InBlock }} 0= if
begin 0 (ekey) drop
move
tail {{ pix stopped }} @ until
then ;
;module

module: Options
: blocks {{ Blocks to cnt }} ;
: sx {{ Ball p0 {{ pix sx }} ! }} ;
: sy {{ Ball p0 {{ pix sy }} ! }} ;
: len {{ Ball to TailLen }} ;
;module

: go
randomize
{{ Blocks
AllotArray
BlankArray
FillArray
ShowArray }}
{{ Ball go }} catch
{{ Blocks FreeArray }}
throw 
;

: LoadCfg
also Options
s" bump.cfg" ['] included catch
if 2drop then
previous ;

:noname LoadCfg ( CreateCanvas) go ; to PilotMain
+names on 
s" bump" 'bump' build