)
31 | r> code> ['] upscaled ?blitthen> noop ;
32 |
33 | : subscreen> ( w h - )
34 | res 2@ tempres 2!
35 | ( w h ) 2i res 2!
36 | r> code> ['] upscaled ?blitthen>
37 | tempres 2@ res 2! ;
38 |
--------------------------------------------------------------------------------
/afkit/ans/version.f:
--------------------------------------------------------------------------------
1 | [undefined] [version] [if]
2 | : packver swap 8 lshift or swap 24 lshift or ;
3 | : (checkver) ( ver ver - )
4 | over 0 = if 2drop exit then
5 | 2dup
6 | swap $ff000000 and swap $ff000000 and <> abort" Incompatible major version!"
7 | 2dup
8 | swap $00ffffff and swap $00ffffff and > abort" Incompatible minor version and/or revision!"
9 | swap $00ffff00 and swap $00ffff00 and < if
10 | cr #2 attribute ." Version mismatch warning: "
11 | #3 attribute
12 | space including -path type ." : "
13 | space tib #tib @ type
14 | #0 attribute
15 | then
16 | ;
17 | : .line cr tib #tib @ type ;
18 | : [version] ( M m R - ) .line packver constant ;
19 | : [checkver] ( M m R packver - )
20 | depth 4 < abort" Missing version spec!"
21 | >r packver r> (checkver) ;
22 |
23 | [then]
24 |
25 | \ versions are expressed as three values M = major, m = minor, R = revision
26 | \ in documentation, they're expressed as M.m.r
27 | \ Major versions are always source breaking
28 | \ Minor versions are generally additions, but also sometimes deletions, renames, and semantic changes
29 | \ Revisions are bugfixes, and benign tweaks such as dox and housekeeping
30 |
31 |
32 |
--------------------------------------------------------------------------------
/afkit/ans/strops.f:
--------------------------------------------------------------------------------
1 | : zcount ( zaddr - addr n ) dup dup if 65535 0 scan drop over - then ;
2 | : zlength ( zaddr - n ) zcount nip ;
3 | : zplace ( from n to - ) tuck over + >r cmove 0 r> c! ;
4 | : zappend ( from n to - ) zcount + zplace ;
5 | create $buffers 16384 allot \ string concatenation buffer stack (circular)
6 | variable >s \ pointer into $buffers
7 | : s[ ( adr c - ) >s @ 256 + 16383 and >s ! >s @ $buffers + place ;
8 | : +s ( adr c - ) >s @ $buffers + append ;
9 | : +c ( c - ) >s @ $buffers + count + c! 1 >s @ $buffers + +! ;
10 | create $outbufs 16384 allot \ output buffers; circular stack of buffers
11 | variable >out
12 | : ]s ( - adr c ) \ fetch finished string
13 | >s @ $buffers + count >out @ $outbufs + place
14 | >out @ $outbufs + count
15 | >out @ 256 + 16383 and >out !
16 | >s @ 256 - 16383 and >s ! ;
17 | : zstring ( addr c - zaddr ) s[ ]s over + 0 swap c! ;
18 | : addchar ( c adr - ) dup >r count + c! 1 r> c+! ;
19 | : uncount ( adr c - adr-1 ) drop 1 - ;
20 | : strjoin ( first c second c - first+second c ) 2swap s[ +s ]s ;
21 | \ : input ( adr c - ) over 1 + swap accept swap c! ;
22 | : ( - addr c ) 0 parse -trailing bl skip ; \ rol=remainder of line
23 |
--------------------------------------------------------------------------------
/sample/platformer/player.f:
--------------------------------------------------------------------------------
1 | ( player )
2 | : aligned at@ 2dup 16 16 2mod 2- at ;
3 | : ?dig
4 | dir @ 0 = if x 2@ 22 u+ tile@ 1 = if me 22 0 from aligned 0 at@ tile! me { break } then then
5 | dir @ 180 = if x 2@ -8 u+ tile@ 1 = if me -8 0 from aligned 0 at@ tile! me { break } then then
6 | ;
7 | : ?jump
8 | onground @ -exit
9 | pressed -exit \ if on the ground, then check if player jumps
10 | -2 vy ! \ initial y velocity
11 | \ allow player to propel upward for up to 23 frames:
12 | 23 for kstate if -0.17 vy +! else unloop ;then pause loop
13 | ;
14 | : /jumping 0 perform> begin ?jump pause again ;
15 | : /controls
16 | /jumping
17 | act>
18 | 0
19 | kstate if drop 180 dir ! -1.25 then
20 | kstate if drop 0 dir ! 1.25 then
21 | vx !
22 | pressed if ?dig then
23 | hitceiling @ if /jumping then \ reset the jumping task if we hit the ceiling
24 | ;
25 | \ draw a box, offset by the background's scroll coords. TINTED sets TINT according to FORE (set by RED)
26 | : /box tinted draw> cam 's x 2@ 2pfloor 2negate +at tint 4@ rgba 14 14 rectf ;
27 |
28 | guy as
29 | red /box /solid \ /SOLID enables tilemap collision
30 | /controls \ and enable the controls
31 | startxy 2@ x 2! \ and put him at the starting position
32 |
--------------------------------------------------------------------------------
/ramen/publish.f:
--------------------------------------------------------------------------------
1 | ( ---=== Publish: SwiftForth ===--- )
2 |
3 | create default-font \ note not a registered asset
4 | /assetheader /allot al-default-font , 8 , 0 ,
5 |
6 | defer cold :make cold ; \ cold boot: executed once at runtime
7 | defer warm :make warm ; \ warm boot: executed potentially multiple times
8 |
9 | : boot
10 | false to allegro?
11 | fullscreen
12 | al-default-font default-font font.fnt !
13 | project off
14 | oscursor off
15 | fixed
16 | ['] initdata catch abort" An asset failed to load."
17 | ;
18 |
19 | : kickoff
20 | boot cold warm go ;
21 |
22 | : error ( message count - )
23 | zstring >r display z" Bad trouble" z" " r> z" Shoot" ALLEGRO_MESSAGEBOX_ERROR
24 | al_show_native_message_box drop ;
25 |
26 | : runtime
27 | [in-platform] sf [if]
28 | ['] kickoff catch ?dup if
29 | (THROW) error
30 | then
31 | [else]
32 | kickoff
33 | [then]
34 | bye ;
35 |
36 | : relify
37 | dup asset? if srcfile dup count s" data/" search if rot place else 3drop then
38 | else drop then ;
39 |
40 | [in-platform] sf [if]
41 | [defined] program [if]
42 |
43 | : publish ( - )
44 | cr ." Publishing to " >in @ bl parse type >in ! ." .exe ... "
45 | ['] relify assets each
46 | ['] runtime 'main !
47 | program
48 | >host ;
49 |
50 | [else]
51 | cr .( PROGRAM not defined; PUBLISH disabled )
52 | [then]
53 | [then]
--------------------------------------------------------------------------------
/sample/platformer/particles.f:
--------------------------------------------------------------------------------
1 | \ the bottleneck is probably rendering. could be sped up by drawing a vertex list.
2 |
3 | _node sizeof 32 cells class: _particle
4 | var x var y var vx var vy
5 | var fric var lifetime var lifespan var gnd
6 | var fr = ;
24 | _particle :- stopped lifetime @ 10 >= y @ pfloor gnd @ 1 - >= and vy @ abs 0.2 < and ;
25 | _particle :- ?die lifetime ++ expired stopped or if r> drop die then ;
26 | _particle :- fade fa sf@ afade sf@ f- fa sf! ;
27 | _particle :- friction vx 2@ fric @ dup 2* vx 2! ;
28 | _particle :- accel ax 2@ vx 2+! ;
29 | _particle :- bounce y @ gnd @ min y ! vy @ -0.8 -0.33 between * vy ! vy @ abs 0.5 < ?exit
30 | vx @ -0.25 0.25 between + vx ! ;
31 | _particle :- ?bounce gnd @ -exit y @ vy @ + gnd @ >= -exit bounce r> drop ;
32 | _particle :- step ?die ?bounce accel friction vx 2@ x 2+! ;
33 | _particle :+ +particles particles each> as step fade ;
34 | _particle :- draw fr 4@ fore 4! x 2@ at pixel ;
35 | _particle :+ draw-particles cam view> particles each> as draw ;
36 |
37 | particles as :now draw> me { draw-particles } act> +particles ;
--------------------------------------------------------------------------------
/ramen/lib/std/transform.f:
--------------------------------------------------------------------------------
1 | ( transformation stack )
2 | create mstack 16 cells 32 * /allot
3 | transform: t:m
4 | variable (m)
5 |
6 | : mactive ( - adr ) (m) @ 16 cells - [ 16 cells 32 * #1 - ]# and mstack + ;
7 | : mtop ( - adr ) (m) @ [ 16 cells 32 * #1 - ]# and mstack + ;
8 | : mget ( - ) al_get_current_transform mtop 16 cells move ;
9 | : tpush ( - ) 16 cells (m) +! mactive al_use_transform mactive mtop 16 cells move ;
10 | : tpop ( - ) -16 cells (m) +! mactive al_use_transform mactive mtop 16 cells move ;
11 |
12 | ( transformation ops )
13 | : translate ( x y - ) 2af mtop -rot al_translate_transform ;
14 | : scale ( sx sy - ) 2af mtop -rot al_scale_transform ;
15 | : rotate ( angle - ) >rad 1af mtop swap al_rotate_transform ;
16 | : hshear ( n - ) 1af mtop swap al_horizontal_shear_transform ;
17 | : vshear ( n - ) 1af mtop swap al_vertical_shear_transform ;
18 | : identity ( - ) mtop al_identity_transform ;
19 | : compose ( - ) mtop mactive al_compose_transform ;
20 | : mount ( - ) tpop mount mget tpush ;
21 | : unmount ( - ) tpop unmount mget tpush ;
22 |
23 | identity tpush
24 |
25 | : transform ( - )
26 | identity
27 | sx 2@ scale
28 | ang @ rotate
29 | x 2@ [undefined] HD [if] 2pfloor [then] translate
30 | compose
31 | 0 0 at
32 | ;
33 |
34 | : view ( - )
35 | x 2@ [undefined] HD [if] 2pfloor [then] 2negate translate
36 | ang @ negate rotate
37 | 1 1 sx 2@ 2/ scale
38 | ;
39 |
40 | : view> ( - )
41 | view tpush r> call tpop ;
42 |
43 | : transform> ( - )
44 | r> at@ 2>r transform tpush call tpop 2r> at ;
45 |
--------------------------------------------------------------------------------
/ex/bubbles.f:
--------------------------------------------------------------------------------
1 | include ramen/ramen.f
2 | empty
3 | depend ramen/basic.f
4 |
5 | _actor fields: var radius
6 | _actor >prototype { 16 radius ! }
7 |
8 | : sf@+ dup sf@ cell+ ;
9 | : tinted fore sf@+ f>p swap sf@+ f>p swap sf@+ f>p swap sf@+ f>p nip tint 4! ;
10 | : view/ globalscale dup 2/ ;
11 | : mousexy mouse 2@ view/ ;
12 | : mdelta mouse 2@ mickey 2@ 2- view/ ;
13 |
14 | ( beat counter )
15 | 0 value beat
16 | stage *actor as
17 | :now act> beat 1 + 24 mod to beat ;
18 |
19 | ( draw bubble and line connecting to previous )
20 | role: [bubble]
21 | : prev me node.previous ;
22 | : rope prev @ @ -exit prev @ { role @ [bubble] = if x 2@ line then } ;
23 |
24 | ( wiggling and rising motion )
25 | : /rise
26 | act>
27 | y @ -1000 < if me dismiss ;then
28 | radius @ 0.5 - 3 max radius !
29 | beat 0= 4 rnd 1 < and if radius @ 10 max radius ! then
30 | vx @ 0 > if -1 vx +! then
31 | vx @ 0 < if 1 vx +! then
32 | vy @ -2 > if -2 vy +! then
33 | ;
34 |
35 | : /bubble /rise tinted [bubble] role !
36 | draw> tint 4@ rgba rope radius @ circlef ;
37 |
38 | : *bubble ( -- actor )
39 | stage *actor {
40 | /bubble
41 | me }
42 | ;
43 |
44 | ( bubble generator - controlled with mouse )
45 | stage *actor as
46 | : 2abs abs swap abs swap ;
47 | : propel ( vx vy ) 2 2 2/ vx 2! ;
48 | : inflate ( vx vy ) 2abs + 2 / 3 + radius ! ;
49 | : spurt me 0 0 from vx 2@ 1 rnd 1 rnd 1 rnd rgb *bubble { 2dup propel inflate } ;
50 | : control mousexy x 2@ 2- vx 2! ;
51 | : /spurt act> control spurt ;
52 | : /gen /spurt draw> 5 ang +! transform> -5 -5 +at white 10 10 rect ;
53 |
54 | create gen stage actor, /gen
55 |
--------------------------------------------------------------------------------
/ramen/lib/std/v2d.f:
--------------------------------------------------------------------------------
1 |
2 | \ 2D vectors! fixed point or integer either works
3 | \ in experimental stage
4 | \ future ideas:
5 | \ - "V" registers with push and pop words. all "vector" params implicit?
6 |
7 | : vector: ( x y - ) create swap , , ;
8 | 2 cells constant /vector
9 | : 2. swap . . ;
10 | : 3. rot . 2. ;
11 | : 2? swap ? ? ;
12 | : vadd swap 2@ rot 2+! ;
13 | : x@ @ ;
14 | : y@ cell+ @ ;
15 | : x! ! ;
16 | : y! cell+ ! ;
17 | : x+! +! ;
18 | : y+! cell+ +! ;
19 | : vcopy swap 2@ rot 2! ;
20 | : vclamp ( lowx lowy highx highy vec - ) >r 2@ 2min 2max r> 2! ;
21 | : 2rnd ( x y - x y ) rnd swap rnd swap ;
22 | : vrnd >r 2rnd r> 2! ;
23 | : uvec ( deg - x y ) >r r@ cos r> sin ; \ get unit vector from angle
24 | : vec ( deg len - x y ) >r uvec r> dup 2* ;
25 | : angle ( x y - deg ) 1pf 1pf fatan2 r>d f>p 360 + 360 mod ;
26 | : magnitude ( x y - n ) 2pf fdup f* fswap fdup f* f+ fsqrt f>p ;
27 | : normalize ( vec - ) dup 2@ 2dup 0 0 d= ?exit 2dup magnitude dup 2/ ( 1 1 2+ ) rot 2! ;
28 | : vdif ( vec1 vec2 - x y ) 2@ rot 2@ 2- ;
29 | : proximity ( vec1 vec2 - n ) vdif magnitude ; \ distance between two vectors
30 | : hypot ( vec - n ) 2@ 1pf fdup f* 1pf fdup f* f+ fsqrt f>p ;
31 | : dotp ( vec1 vec2 - n ) swap 2@ rot 2@ -rot ( b.x a.y ) * >r ( a.x b.y ) * r> - ;
32 | : rotate ( deg vec - )
33 | swap dup cos swap sin locals| sin(ang) cos(ang) v |
34 | v x@ cos(ang) * v y@ sin(ang) * -
35 | v x@ sin(ang) * v y@ cos(ang) * + v 2! ;
36 | : scale ( x y vec - )
37 | >r 2@ 2* r> 2! ;
38 | : vlerp ( vec1 vec2 n - )
39 | locals| n v2 v1 |
40 | v1 x@ v2 x@ n lerp v1 y@ v2 y@ n lerp v2 2! ;
41 |
--------------------------------------------------------------------------------
/ramen/assets.f:
--------------------------------------------------------------------------------
1 | ( ---=== Asset framework ===--- )
2 |
3 | cell #256 + cell+ constant /assetheader
4 | defer initdata ( - )
5 |
6 | create assets 1000 *stack drop
7 | variable permanent permanent on
8 | variable #permanents
9 |
10 | \ "permanent" or "system" assets; not needed by games so reloader is a no-op
11 | : ?permanent permanent @ -exit nip ['] drop swap 1 #permanents +! ;
12 |
13 | : register ( reloader-xt unloader-xt asset - )
14 | cr ." [Asset] " #tib 2@ swap type
15 | ?permanent dup assets push 2! ;
16 |
17 |
18 | \ structure: reloader , unloader , filepath ...
19 | : reload ( asset - ) ( asset - ) dup @ execute ;
20 | : unload ( asset - ) ( asset - ) dup cell+ @ execute ;
21 | : srcfile ( asset - adr ) cell+ cell+ ;
22 |
23 |
24 | : -assets ( - ) ['] unload assets each #permanents @ assets truncate ;
25 |
26 |
27 | \ Note: Don't worry that the paths during development are absolute;
28 | \ in publish.f, all asset paths are "normalized".
29 | : findfile ( path c - path c )
30 | locals| c fn |
31 | fn c 2dup file-exists ?exit
32 | including -name #1 + 2swap strjoin 2dup file-exists ?exit
33 | true abort" File not found" ;
34 |
35 | : asset: ( - ) struct: /assetheader lastbody struct.size ! ;
36 | : .asset ( asset - ) srcfile count dup if type else 2drop then ;
37 | : .assets ( - ) assets each> cr .asset ;
38 | : asset? srcfile count nip 0<> ;
39 |
40 | ( Loadtrigs )
41 | 3 cells constant loadtrig-size
42 |
43 | : +loadtrig ( xt - )
44 | cr ." [Loadtrig] " #tib 2@ swap type
45 | here assets push , ['] drop , 0 , ;
46 |
47 | ( Standard synchronous loader )
48 | :make initdata assets each> reload ;
49 |
--------------------------------------------------------------------------------
/ramen/default.f:
--------------------------------------------------------------------------------
1 | \ --------------------------------------------------------------------------------------------------
2 | \ some graphics tools for the default engine state
3 |
4 | \ draw a rectangular vertical gradient
5 | define internal
6 | create gv 4 /ALLEGRO_VERTEX * /allot
7 | create gi 0 , #1 , #2 , #3 ,
8 | using internal
9 | : v! ( x y a n - ) /ALLEGRO_VERTEX * + >r 2af r> 2! ;
10 | : color! ( color a n - ) /ALLEGRO_VERTEX * + >r 4@ 4af r> ALLEGRO_VERTEX.r 4! ;
11 | : vgradient ( color1 color2 w h - )
12 | at@ 2+ at@ locals| y x y2 x2 c2 c1 |
13 | x y gv 0 v! x2 y gv 1 v! x2 y2 gv 2 v! x y2 gv 3 v!
14 | c1 gv 2dup 0 color! 1 color! c2 gv 2dup 2 color! 3 color!
15 | gv 0 0 gi #4 ALLEGRO_PRIM_TRIANGLE_FAN al_draw_indexed_prim ;
16 | previous
17 |
18 | \ convert lch, hsl, hsv to rgb
19 | \ hue is in degrees
20 | create (fc) 3 cells allot
21 | : !color ( adr - ) >r (fc) color.r sf@ f>p (fc) color.g sf@ f>p (fc) color.b sf@ f>p r> 3! ;
22 | : lch! ( l c h color - ) >r >rad 3af (fc) dup cell+ dup cell+ al_color_lch_to_rgb r> !color ;
23 | : hsl! ( h s l color - ) >r 3af (fc) dup cell+ dup cell+ al_color_hsl_to_rgb r> !color ;
24 | : hsv! ( h s v color - ) >r 3af (fc) dup cell+ dup cell+ al_color_hsv_to_rgb r> !color ;
25 | \ --------------------------------------------------------------------------------------------------
26 |
27 | \ default engine state; chill vibes
28 | create c1 0 , 0 , 0 , 1 ,
29 | create c2 0 , 0 , 0 , 1 ,
30 | : colorcycle
31 | 0.4 0.4 now 1p -20 / 75 + c1 lch!
32 | 0.4 0.4 now 1p -20 / c2 lch!
33 | c1 c2
34 | ;
35 | : ramenbg ( - ) 0 0 at unmount colorcycle displaywh vgradient ;
36 |
--------------------------------------------------------------------------------
/afkit/ans/files.f:
--------------------------------------------------------------------------------
1 | decimal
2 |
3 | : file! ( addr count filename c - ) \ file store
4 | w/o create-file throw >r
5 | r@ write-file throw
6 | r> close-file throw ;
7 |
8 | : @file ( filename c dest maxsize - ) \ fetch file into a mem range
9 | locals| maxsize dest c filename |
10 | filename c r/o open-file throw >r
11 | dest r@ file-size throw drop maxsize min r@ read-file throw drop
12 | r> close-file throw ;
13 |
14 |
15 | \ system heap version
16 |
17 | : file@ ( filename c - mem size )
18 | r/o open-file throw >r
19 | r@ file-size throw d>s dup dup allocate throw dup rot
20 | r@ read-file throw drop
21 | r> close-file throw
22 | swap ;
23 |
24 | \ dictionary version
25 |
26 | : file ( filename c - addr size )
27 | file@ 2dup here dup >r swap dup /allot move swap free throw r> swap ;
28 |
29 | : file, ( filename c - ) \ file comma
30 | file 2drop ;
31 |
32 | : ending ( addr len char - addr len )
33 | >r begin 2dup r@ scan
34 | ?dup while 2swap 2drop #1 /string
35 | repeat r> 2drop ;
36 |
37 | : -EXT ( a n - a n ) 2DUP [CHAR] . ENDING NIP - 1- 0 MAX ;
38 |
39 | [defined] linux [if]
40 | : slashes 2dup over + swap do i c@ [char] \ = if [char] / i c! then #1 +loop ;
41 | : -filename ( a n - a n ) slashes 2dup [char] / ending nip - ;
42 | : -PATH ( a n - a n ) slashes [CHAR] / ENDING 0 MAX ;
43 | [else]
44 | : slashes 2dup over + swap do i c@ [char] / = if [char] \ i c! then #1 +loop ;
45 | : -filename ( a n - a n ) slashes 2dup [char] \ ending nip - ;
46 | : -PATH ( a n - a n ) slashes [CHAR] \ ENDING 0 MAX ;
47 | [then]
48 |
49 | : 0file ( adr c len - )
50 | locals| len c adr |
51 | here len erase here len adr c file! ;
52 |
--------------------------------------------------------------------------------
/afkit/plat/sf.f:
--------------------------------------------------------------------------------
1 | \ None of this needs to be ported to other systems. All non-essential.
2 |
3 | : l locate ;
4 | : e edit ;
5 |
6 | \ variable newquit
7 | \ create backup 11 cells allot
8 | \
9 | \ : savestack
10 | \ dup
11 | \ depth 10 min cells backup !
12 | \ sp@ backup cell+ backup @ move
13 | \ drop ;
14 | \
15 | \ : restorestack
16 | \ s0 @ backup @ - dup sp!
17 | \ backup cell+ swap backup @ move
18 | \ drop ;
19 | \
20 | \ : (QUIT) ( - )
21 | \ .STACK BEGIN
22 | \ REFILL DROP INTERPRET savestack PROMPT AGAIN ;
23 | \
24 | \ : asdfQUIT ( - )
25 | \ BEGIN
26 | \ R0 @ RP! \ clear return stack
27 | \ /INTERPRETER
28 | \ newquit @ not if newquit on else prompt then
29 | \ ['] (QUIT) CATCH .catch
30 | \ restorestack
31 | \ \ S0 @ SP! \ resets datastack
32 | \ \ /NDP \ resets fstack
33 | \ AGAIN ;
34 | \
35 | \ THIS DOESN'T WORK ^^^
36 |
37 |
38 | \ : newprompt
39 | \ cr
40 | \ DEPTH 0> if DEPTH 0 DO S0 @ I 1+ CELLS - @ h. LOOP ." > " THEN
41 | \ depth 0= if ." > " then
42 | \ \ newquit @ not if quit then
43 | \ ;
44 | \
45 | \ \ FDEPTH ?DUP IF
46 | \ \ ." FSTACK: "
47 | \ \ 0 DO I' I - 1- FPICK N. LOOP
48 | \ \ THEN ;
49 |
50 | \ ' newprompt is prompt
51 |
52 | : /s s0 @ sp! ;
53 | : empty /s empty ;
54 |
55 | : .s base @ >r hex .s r> base ! ;
56 |
57 |
58 | create ldr 256 /allot
59 | : rld ldr count nip -exit ldr count included ;
60 | : ld bl parse ldr place s" .f" ldr append rld ;
61 |
62 |
63 | \ don't touch this
64 | : (EVALUATE)
65 | SAVE-INPUT N>R
66 | ( c-addr u ) #TIB 2! >IN OFF LINE OFF BLK OFF -1 'SOURCE-ID !
67 | ['] INTERPRET CATCH ( * )
68 | ( * ) DUP IF POSTPONE [ THEN
69 | NR> RESTORE-INPUT DROP ( * ) THROW ;
70 |
71 | warning off
--------------------------------------------------------------------------------
/ramen/structs.f:
--------------------------------------------------------------------------------
1 | also venery
2 | 0 value lastfield
3 |
4 | struct %struct
5 | %struct %node sembed struct>node
6 | %struct svar struct.size
7 |
8 | struct %field
9 | %field %node sembed field>node
10 | %field svar field.offset
11 | %field svar field.size
12 | %field svar field.inspector
13 |
14 | : struct: create %struct *struct /node ;
15 |
16 | : (.field) ( adr size - )
17 | bounds ?do i @ dup if . else i. then cell +loop ;
18 |
19 | : create-field ( struct bytes - ) ( - field )
20 | swap >r
21 | create
22 | here to lastfield
23 | %field *struct dup /node dup r@ push
24 | r@ struct.size @ over field.offset !
25 | ['] (.field) over field.inspector ! \ initialize the inspector
26 | udup field.size !
27 | r> struct.size +! ;
28 |
29 | previous
30 |
31 |
32 | : sfield ( struct bytes - ) ( adr - adr+n )
33 | create-field
34 | does> [ 0 field.offset ]# + @ + ;
35 |
36 | : svar ( struct - ) ( adr - adr+n )
37 | cell sfield ;
38 |
39 | : sizeof ( struct - size )
40 | struct.size @ ;
41 |
42 | : *struct ( struct - adr )
43 | here swap sizeof /allot ;
44 |
45 | : struct, ( struct - )
46 | *struct drop ;
47 |
48 | : is> ( - ; ) ( adr size - )
49 | r> code> lastfield field.inspector ! ;
50 |
51 | : (.fields)
52 | each> ( adr field )
53 | normal
54 | dup body> >name ccount type space
55 | bright
56 | 2dup dup field.size @ swap field.inspector @ execute
57 | field.size @ + \ go to next field in the passed instance
58 | ;
59 |
60 | : .fields ( adr struct - )
61 | dup node.first @ field.offset @ u+ (.fields) drop ;
62 |
63 | [defined] h. [if]
64 | : drop @ dup 0= if #5 attribute then ." $" h. normal ;
65 | : drop sf@ f. ." e" ;
71 | [then]
72 | : drop ccount type ;
73 | : drop count type ;
74 | : drop @ if ." true " else ." false " then ;
75 | : drop @ .name ;
76 | : drop @ dup if >body .name else i. then ;
77 |
--------------------------------------------------------------------------------
/afkit/dep/allegro5/allegro5_06_fs.f:
--------------------------------------------------------------------------------
1 | decimal \ important
2 |
3 | function: al_create_fs_entry ( path -- entry )
4 | function: al_destroy_fs_entry ( entry -- )
5 | function: al_get_fs_entry_name ( entry -- cname )
6 |
7 | : bit dup constant 1 lshift ;
8 | 1
9 | bit ALLEGRO_FILEMODE_READ \ 1
10 | bit ALLEGRO_FILEMODE_WRITE \ 1 << 1
11 | bit ALLEGRO_FILEMODE_EXECUTE \ 1 << 2
12 | bit ALLEGRO_FILEMODE_HIDDEN \ 1 << 3
13 | bit ALLEGRO_FILEMODE_ISFILE \ 1 << 4
14 | bit ALLEGRO_FILEMODE_ISDIR \ 1 << 5
15 | drop
16 |
17 | \ AL_FUNC(bool, al_update_fs_entry, (ALLEGRO_FS_ENTRY *e));
18 |
19 | function: al_get_fs_entry_mode ( fsentry -- n )
20 |
21 | function: al_get_fs_entry_atime ( ALLEGRO_FS_ENTRY -- ms )
22 | function: al_get_fs_entry_mtime ( ALLEGRO_FS_ENTRY -- ms )
23 | function: al_get_fs_entry_ctime ( ALLEGRO_FS_ENTRY -- ms )
24 | function: al_get_fs_entry_size ( ALLEGRO_FS_ENTRY -- ofs )
25 | function: al_fs_entry_exists ( ALLEGRO_FS_ENTRY -- flag )
26 | function: al_remove_fs_entry ( ALLEGRO_FS_ENTRY -- flag )
27 |
28 | function: al_open_directory ( ALLEGRO_FS_ENTRY -- bool )
29 | function: al_read_directory ( ALLEGRO_FS_ENTRY -- fsentry )
30 | function: al_close_directory ( ALLEGRO_FS_ENTRY -- bool )
31 |
32 |
33 | \ AL_FUNC(bool, al_filename_exists, (const char *path));
34 | \ AL_FUNC(bool, al_remove_filename, (const char *path));
35 |
36 | function: al_get_current_directory ( -- char* )
37 | function: al_change_directory ( char* -- bool )
38 |
39 | \ AL_FUNC(bool, al_make_directory, (const char *path));
40 | \
41 | \ AL_FUNC(ALLEGRO_FILE *, al_open_fs_entry, (ALLEGRO_FS_ENTRY *e,
42 | \ const char *mode));
43 | \
44 |
45 |
46 | \ /* Helper function for iterating over a directory using a callback. */
47 |
48 | -1
49 | enum ALLEGRO_FOR_EACH_FS_ENTRY_ERROR \ = -1
50 | enum ALLEGRO_FOR_EACH_FS_ENTRY_OK \ = 0
51 | enum ALLEGRO_FOR_EACH_FS_ENTRY_SKIP \ = 1
52 | enum ALLEGRO_FOR_EACH_FS_ENTRY_STOP \ = 2
53 | drop
54 | 5 1 9 [compatible] function: al_for_each_fs_entry ( fs_entry_dir callback extra -- int ) \ ( fs_entry extra -- enum )
55 | \ AL_FUNC(int, al_for_each_fs_entry, (ALLEGRO_FS_ENTRY *dir,
56 | \ int (*callback)(ALLEGRO_FS_ENTRY *entry, void *extra),
57 | \ void *extra));
58 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | Ramen 2.0
2 |
3 | a 2D game dev framework and optional engine for making commercial-quality PC games in Forth.
4 |
5 | Update:
6 | i've gone from a submodule-based system to including all dependencies in the repository.
7 |
8 | the following repositories will house the stable releases of each dependency from now on:
9 |
10 | - [AllegroForthKit](https://github.com/RogerLevy/afkit)
11 | - [Ramen](https://github.com/RogerLevy/ramen) (archived for history)
12 | - [Workspace](https://github.com/RogerLevy/ws)
13 | - [Venery](https://github.com/RogerLevy/venery)
14 |
15 | ## Features
16 |
17 | * Built on Allegro 5, using [AllegroForthKit](https://github.com/RogerLevy/AllegroForthKit).
18 | * Sprite animation
19 | * Multiple display list support
20 | * Interactive commandline console
21 | * Fast rectangle collision detection
22 | * Roundrobin multitasking
23 | * Graphics primitives such as line, rectangle, ellipse, blit, text, etc.
24 | * Publish facility
25 | * Z-sorted rendering
26 | * Basic sound support
27 | * Collections with [Venery](https://github.com/RogerLevy/venery)
28 |
29 | ## Getting Started
30 |
31 | 1. Download [SwiftForth](https://www.forth.com/swiftforth/).
32 | 1. After installation is complete, add SwiftForth's bin\ folder to your PATH.
33 | 1. Copy kitconfig.f to your drive's root folder and customize it if desired.
34 | 1. Run ramen.bat
35 |
36 | Note: SwiftForth's evaluation version doesn't support creating executables, therefore none of the make scripts will work. Work on porting to GForth is underway.
37 |
38 | ## Help
39 |
40 | * Submit [Issues](https://github.com/RogerLevy/ramen/issues)
41 | * Tweet [@RamenEngine](https://twitter.com/RamenEngine)
42 |
43 | ## Links and Resources
44 |
45 | * [Forth: The Hacker's Language on HACKADAY](https://hackaday.com/2017/01/27/forth-the-hackers-language/)
46 | * [Programming Forth by Stephen Pelc](http://www.mpeforth.com/arena/ProgramForth.pdf)
47 | * [Forth Programming 21st Century on Facebook](https://www.facebook.com/groups/PROGRAMMINGFORTH/) - The current active and growing forum on the web for modern desktop Forth programming \(as opposed to on embedded or classic computers.\)
48 | * [Allegro 5.2.3 Documentation](http://liballeg.org/a5docs/5.2.3/)
49 | * [Allegro.cc forum](https://www.allegro.cc/forums) - A very helpful and fairly active community. And gladly, language-agnostic.
50 | * [The DPANS94 Forth Standard](http://dl.forth.com/sitedocs/dpans94.pdf)
51 |
--------------------------------------------------------------------------------
/ramen/image.f:
--------------------------------------------------------------------------------
1 |
2 | asset: %image
3 | %image svar image.bmp
4 | %image svar image.subw
5 | %image svar image.subh
6 | %image svar image.subcols
7 | %image svar image.subrows
8 | %image svar image.subcount
9 | %image svar canvas.w
10 | %image svar canvas.h
11 | %image svar image.regions
12 |
13 |
14 | \ get dimensions, fixed point
15 | : imagew image.bmp @ bmpw ;
16 | : imageh image.bmp @ bmph ;
17 | : imagewh image.bmp @ bmpwh ;
18 |
19 | \ reload-image ( image - ) (re)load from file
20 | \ init-image ( path c image - ) normal asset init
21 | \ image: ( path c - ) declare named image.
22 | \ >bmp ( image - ALLEGRO_BITMAP )
23 | : reload-image >r r@ srcfile count findfile zstring al_load_bitmap r> image.bmp ! ;
24 | : unload-image image.bmp @ al_destroy_bitmap ;
25 | : init-image >r r@ srcfile place ['] reload-image ['] unload-image r@ register r> reload-image ;
26 | : image: create %image *struct init-image ;
27 | : >bmp image.bmp @ ;
28 |
29 | \ load-image ( path c image - )
30 | \ free-image ( image - )
31 | : free-image image.bmp @ -bmp ;
32 | : load-image dup free-image init-image ;
33 |
34 | \ Canvas (images without source files)
35 |
36 | \ recreate-canvas ( image - )
37 | \ resize-canvas ( w h image - )
38 | \ init-canvas ( w h image - )
39 | \ canvas: ( w h - )
40 | : recreate-canvas #24 al_set_new_bitmap_depth >r r@ canvas.w 2@ 2i al_create_bitmap r> image.bmp ! ;
41 | : unload-canvas unload-image ;
42 | :slang ?samesize >r 2dup r@ canvas.w 2@ d= if 2drop r> r> 2drop exit then r> ;
43 | : resize-canvas ?samesize >r r@ free-image r@ canvas.w 2! r> recreate-canvas ;
44 | : init-canvas >r ['] recreate-canvas ['] unload-canvas r@ register r@ canvas.w 2! r> recreate-canvas ;
45 | : canvas: create %image *struct init-canvas ;
46 |
47 | \ Sub-image stuff
48 |
49 | \ subdivide ( tilew tileh image - ) calculate subimage parameters
50 | \ subxy ( n img - x y ) locate a subimg by index
51 | \ subxywh ( n img - x y w h ) get full rect of subimage
52 | : subdivide
53 | >r 2dup r@ image.subw 2!
54 | r@ imagewh r@ image.subw 2@ 2/ 2pfloor r@ image.subcols 2!
55 | * r> image.subcount ! ;
56 | : subxy >r pfloor r@ image.subcols @ /mod 2pfloor r> image.subw 2@ 2* ;
57 | : subwh image.subw 2@ ;
58 | : subxywh dup >r subxy r> subwh ;
59 |
60 | : tileset: ( tilew tileh imagepath c - )
61 | image: lastbody subdivide ;
62 |
--------------------------------------------------------------------------------
/ramen/base.f:
--------------------------------------------------------------------------------
1 | exists ramen [if] \\ [then]
2 | true constant ramen
3 | include afkit/afkit.f \ AllegroForthKit
4 | #1 #6 #0 [afkit] [checkver]
5 |
6 | ( Low-level )
7 | 0 value (count)
8 | 0 value (ts)
9 | 0 value (bm)
10 | [undefined] LIGHTWEIGHT [if]
11 | include afkit/dep/zlib/zlib.f
12 | [then]
13 | include ramen/fixops.f
14 | include afkit/plat/sf/fixedp.f \ must come after fixops.
15 | include ramen/res.f
16 | include venery/venery.f
17 | include ramen/structs.f
18 |
19 | : ?p. p. ; \ dup $0000fff and if p. else i. then ;
20 | : bounds ?do i @ ." #" i. cell +loop ;
21 | : dump ;
22 | : nip ." ( " cell i/ i. ." )" space ;
23 | : bounds ?do i @ ?p. cell +loop ;
24 | : sfield sfield noop ;
47 | : void ( - ) stop show> ramenbg ;
48 |
49 | : project: ( -- )
50 | bl parse project place s" /" project append
51 | project count slashes 2drop ;
52 |
53 | : .project project count type ;
54 |
55 | variable ldl
56 |
57 | : ?project project count nip ?exit ldr count -filename project place ;
58 |
59 | : (included) 1 ldl +! ['] included catch
60 | dup 0= if -1 ldl +! ?project else 0 ldl ! then
61 | throw ;
62 |
63 | : rld ldr count nip -exit ldr count (included) ;
64 |
65 | : ld ( -- )
66 | bl parse s" .f" strjoin 2>r
67 | 2r@ file-exists not if
68 | project count 2r> strjoin 2>r
69 | then
70 | ldl @ 0= if 2r@ ldr place then
71 |
72 | 2r@ (included)
73 | 2r> 2drop ;
74 |
75 | : empty
76 | displaywh resolution
77 | oscursor on
78 | page
79 | cr
80 | ." [Empty]"
81 | void
82 | -assets
83 | 0 to now
84 | source-id 0> if including -name #1 + slashes project place then \ swiftforth
85 | empty
86 | ;
87 | : gild
88 | only forth definitions
89 | s" marker (empty)" evaluate
90 | cr ." [Gild] "
91 | ;
92 | : now now 1p ; \ must go last
93 |
94 |
95 | gild void
--------------------------------------------------------------------------------
/venery/string.f:
--------------------------------------------------------------------------------
1 |
2 | ( String )
3 | struct %string
4 | %string %collection sembed string.collection
5 | %string svar string.data
6 |
7 | collection-vtable-size vtable string-vtable ( collection 0 )
8 | \ [] ( index collection -- adr )
9 | :vector array.data @ swap bytes + ;
10 | \ truncate ( n collection -- )
11 | :vector collection.length dup @ rot min swap ! ;
12 | \ push ( val collection -- )
13 | :vector >r r@ length r@ [] c! 1 r> collection.length +! ;
14 | \ pop ( collection -- val )
15 | :vector >r r@ length 1 - r@ [] c@ -1 r> collection.length +! ;
16 | \ each ( xt collection -- ) ( val -- )
17 | :vector xt >r swap to xt dup string.data @ swap length bounds ?do
18 | i c@ xt execute 1 bytes +loop r> to xt ;
19 | \ deletes ( index count collection -- )
20 | :vector 3dup nip length >= if 3drop exit then
21 | locals| c n i |
22 | i n + c length min i - to n \ adjust count if needed
23 | i bytes c string.data @ + \ dest
24 | dup n bytes + \ src
25 | swap \ src dest
26 | c string.data @ c length bytes + \ end
27 | over - ?move
28 | n negate c collection.length +! ;
29 | \ .each ( collection -- )
30 | :vector dup string.data @ swap length dup 1i i. ." : " type ;
31 | \ remove ( val collection -- ) \ remove all instances
32 | :vector locals| c itm |
33 | c length 0 ?do
34 | i c length >= if unloop exit then
35 | i c [] c@ itm = if i 1 c deletes then
36 | loop ;
37 | \ ?@ ( adr collection -- val ) \ adr is val adr, or node, depending, e.g. in EACH SOME DIFF
38 | :vector drop c@ ;
39 | \ removeat ( i collection -- ) \ deletes or removes the value at i, depending.
40 | :vector 1 swap deletes ;
41 | \ insert ( val i dest-collection -- )
42 | :vector locals| dest i val |
43 | dest 1 more? abort" Error in INSERT: Destination collection is full."
44 | dest string.data @ i bytes + dup 1 bytes + dest length i - bytes move
45 | val i dest [] c!
46 | 1 dest collection.length +! ;
47 | 2drop
48 |
49 |
50 | : *empty-string ( n -- string )
51 | %string *struct >r
52 | string-vtable r@ collection.vtable !
53 | here r@ string.data !
54 | dup /allot
55 | r@ collection.capacity !
56 | r> ;
57 |
58 | : set-string ( adr n string - )
59 | >r
60 | 2dup r@ string.data @ swap move
61 | nip
62 | r> collection.length !
63 | ;
64 |
65 | : *string ( adr length capacity -- string ) \ data will be copied from adr
66 | *empty-string >r
67 | r@ set-string
68 | r> ;
--------------------------------------------------------------------------------
/afkit/dep/allegro5/allegro-5.2.x.f:
--------------------------------------------------------------------------------
1 | decimal \ important
2 |
3 | [undefined] #defined [if]
4 | : #define create 0 parse bl skip evaluate , does> @ ;
5 | : #fdefine create 0 parse bl skip evaluate sf, does> sf@ ;
6 | [then]
7 |
8 | : cfield create over , + does> @ + ;
9 | : cvar cell cfield ;
10 | : fload include ;
11 | : ?constant constant ;
12 |
13 | \ intent: speeding up some often-used short routines
14 | \ usage: macro: ; \ entire declaration must be a one-liner!
15 | : macro: ( - ; ) \ define a macro; the given string will be evaluated when called
16 | create immediate
17 | [char] ; parse string,
18 | does> count evaluate ;
19 |
20 | [undefined] ALLEGRO_VERSION_INT [if]
21 | [defined] linux [if] $5020401 [else] $5020300 [then]
22 | constant ALLEGRO_VERSION_INT
23 | [then]
24 |
25 | ALLEGRO_VERSION_INT $ffffff00 and $5020300 = [if] cd afkit/dep/allegro5/5.2.3 [then]
26 | ALLEGRO_VERSION_INT $ffffff00 and $5020400 = [if] cd afkit/dep/allegro5/5.2.4 [then]
27 |
28 | cr .( Loading Allegro ) ALLEGRO_VERSION_INT h. .( ... )
29 |
30 | [defined] linux [if]
31 | create libcmd 256 allot
32 | : linux-library
33 | s" library " libcmd place
34 | 0 parse libcmd append
35 | s" .so.5.2" libcmd append
36 | libcmd count evaluate
37 | ;
38 | linux-library liballegro
39 | linux-library liballegro_memfile
40 | linux-library liballegro_primitives
41 | linux-library liballegro_acodec
42 | linux-library liballegro_audio
43 | linux-library liballegro_color
44 | linux-library liballegro_font
45 | linux-library liballegro_image
46 | linux-library liballegro_font
47 | [else]
48 | : linux-library 0 parse 2drop ;
49 | [defined] allegro-debug [if]
50 | library allegro_monolith-debug-5.2.dll
51 | [else]
52 | library allegro_monolith-5.2.dll
53 | [then]
54 | cd ../../../..
55 | [then]
56 |
57 | : void ;
58 |
59 | : /* postpone \ ; immediate
60 |
61 |
62 | : [COMPATIBLE] ( ver subver rev -- )
63 | 8 lshift swap 16 lshift rot 24 lshift or or ALLEGRO_VERSION_INT $ffffff00 and > if 0 parse 2drop then ;
64 |
65 |
66 | \ ----------------------------- load files --------------------------------
67 |
68 | include afkit/dep/allegro5/allegro5_01_general.f
69 | include afkit/dep/allegro5/allegro5_02_events.f
70 | include afkit/dep/allegro5/allegro5_03_keys.f
71 | include afkit/dep/allegro5/allegro5_04_audio.f
72 | include afkit/dep/allegro5/allegro5_05_graphics.f
73 | include afkit/dep/allegro5/allegro5_06_fs.f
74 | include afkit/dep/allegro5/allegro5_07_misc.f
75 |
76 | \ =============================== END ==================================
77 |
78 | .( Done )
79 |
--------------------------------------------------------------------------------
/sample/platformer/lib/collision.f:
--------------------------------------------------------------------------------
1 | ( Simple tilemap collision )
2 | depend sample/platformer/lib/array2d.f
3 |
4 | ( what sides the object collided )
5 | 0 value lwall?
6 | 0 value rwall?
7 | 0 value floor?
8 | 0 value ceiling?
9 |
10 | [undefined] tstep@ [if] : tstep@ 16 16 ; [then]
11 |
12 | extend: _actor
13 | var mbw var mbh \ object collision box width,height
14 | ;class
15 |
16 | defer on-tilemap-collide ' drop is on-tilemap-collide ( tilecell - )
17 | defer tileprops@ :noname drop 0 ; is tileprops@ ( tilecell - bitmask )
18 |
19 | #1
20 | bit BIT_CEL
21 | bit BIT_FLR
22 | bit BIT_WLT
23 | bit BIT_WRT
24 | value tile-bits
25 |
26 | define collisioning
27 |
28 | 0 value map
29 | : map@ ( col row - tile ) map loc @ ;
30 |
31 | : cel? BIT_CEL and ; \ ' ceiling '
32 | : flr? BIT_FLR and ; \ ' floor '
33 | : wlt? BIT_WLT and ; \ ' wall left '
34 | : wrt? BIT_WRT and ; \ ' wall right '
35 |
36 | : vector create 0 , here 0 , constant ;
37 | vector nx ny
38 |
39 | : gap ( - n ) tstep@ drop ; \ just square tiles supported for now
40 |
41 | : px x @ ;
42 | : py y @ ;
43 |
44 | variable t
45 | : xy>cr ( x y tilesize - ) dup 2/ 2pfloor ;
46 | : pt gap xy>cr map@ dup t ! tileprops@ ; \ point
47 |
48 | ( increment coordinates )
49 | : ve+ swap gap + mbw @ #1 - px + min swap ;
50 | : he+ gap + mbh @ #1 - ny @ + min ;
51 |
52 | : +vy ny +! ny @ py - vy ! ;
53 | : +vx nx +! nx @ px - vx ! ;
54 |
55 | ( push up/down )
56 | : pu ( xy ) nip gap mod negate +vy true to floor? t @ on-tilemap-collide ;
57 | : pd ( xy ) nip gap mod negate gap + +vy true to ceiling? t @ on-tilemap-collide ;
58 |
59 | ( check up/down )
60 | : cu mbw @ gap / 2 + for 2dup pt cel? if pd unloop exit then ve+ loop 2drop ;
61 | : cd mbw @ gap / 2 + for 2dup pt flr? if pu unloop exit then ve+ loop 2drop ;
62 |
63 | ( push left/right )
64 | : pl ( xy ) drop gap mod negate ( -1.0 + ) +vx true to rwall? t @ on-tilemap-collide ;
65 | : pr ( xy ) drop gap mod negate gap + +vx true to lwall? t @ on-tilemap-collide ;
66 |
67 | ( check left/right )
68 | : cl mbh @ gap / 2 + for 2dup pt wrt? if pr unloop exit then he+ loop 2drop ;
69 | : crt mbh @ gap / 2 + for 2dup pt wlt? if pl unloop exit then he+ loop 2drop ;
70 |
71 | : ud vy @ -exit vy @ 0 < if px ny @ cu exit then px ny @ mbh @ + cd ;
72 | : lr vx @ -exit vx @ 0 < if nx 2@ cl exit then nx @ mbw @ + ny @ crt ;
73 |
74 | : init px py vx 2@ 2+ nx 2! 0 to lwall? 0 to rwall? 0 to floor? 0 to ceiling? ;
75 |
76 | only forth definitions fixed
77 | also collisioning
78 |
79 | : collide-tilemap ( array2d - ) to map init ud lr ;
80 |
81 | only forth definitions
--------------------------------------------------------------------------------
/venery/array.f:
--------------------------------------------------------------------------------
1 |
2 | ( Array )
3 | struct %array
4 | %array %collection sembed array.collection
5 | %array svar array.data
6 |
7 | collection-vtable-size vtable array-vtable ( collection 0 )
8 | \ [] ( index collection -- adr )
9 | :vector array.data @ swap cells + ;
10 | \ truncate ( n collection -- )
11 | :vector collection.length dup @ rot min swap ! ;
12 | \ push ( val collection -- )
13 | :vector >r r@ length r@ [] ! 1 r> collection.length +! ;
14 | \ pop ( collection -- val )
15 | :vector >r r@ length 1 - r@ [] @ -1 r> collection.length +! ;
16 | \ each ( xt collection -- ) ( val -- )
17 | :vector xt >r swap to xt dup array.data @ swap length cells bounds ?do
18 | i @ xt execute cell +loop r> to xt ;
19 | \ deletes ( index count collection -- )
20 | :vector 3dup nip length >= if 3drop exit then
21 | locals| c n i |
22 | i n + c length min i - to n \ adjust count if needed
23 | i cells c array.data @ + \ dest
24 | dup n cells + \ src
25 | swap \ src dest
26 | c array.data @ c length cells + \ end
27 | over - ?move
28 | n negate c collection.length +! ;
29 | \ .each ( collection -- )
30 | :vector dup length 1i i. ." items: " each> . ;
31 | \ remove ( val collection -- ) \ remove all instances
32 | :vector locals| c itm |
33 | c length 0 ?do
34 | i c length >= if unloop exit then
35 | i c [] @ itm = if i 1 c deletes then
36 | loop ;
37 | \ ?@ ( adr collection -- val ) \ adr is val adr, or node, depending, e.g. in EACH SOME DIFF
38 | :vector drop @ ;
39 | \ removeat ( i collection -- ) \ deletes or removes the value at i, depending.
40 | :vector 1 swap deletes ;
41 | \ insert ( val i dest-collection -- )
42 | :vector locals| dest i val |
43 | dest 1 more? abort" Error in INSERT: Destination collection is full."
44 | dest array.data @ i cells + dup cell+ dest length i - cells move
45 | val i dest [] !
46 | 1 dest collection.length +! ;
47 | 2drop
48 |
49 | : *array ( n -- array )
50 | %array *struct >r
51 | array-vtable r@ collection.vtable !
52 | here r@ array.data ! dup r@ collection.length !
53 | dup r@ collection.capacity !
54 | cells /allot
55 | r> ;
56 | : *stack ( n -- array )
57 | %array *struct >r
58 | array-vtable r@ collection.vtable !
59 | here r@ array.data ! 0 r@ collection.length !
60 | dup r@ collection.capacity !
61 | cells /allot
62 | r> ;
63 |
64 | : array, *array drop ;
65 | : stack, *stack drop ;
66 |
67 | : 0array ( array/stack - )
68 | 0 over [] ( array adr ) over collection.capacity @ cells erase
69 | ( array ) vacate ;
--------------------------------------------------------------------------------
/sample/platformer/data/level01.tmx:
--------------------------------------------------------------------------------
1 |
2 |
13 |
--------------------------------------------------------------------------------
/ramen/lib/std/task.f:
--------------------------------------------------------------------------------
1 | 0 value task \ current task
2 |
3 | fixed
4 |
5 | extend: _actor
6 | var sp = sp@ dtop < and ;
44 | : halt (task) off running? if pause then ;
45 | : end me dismiss halt ;
46 | : ?end -exit end ;
47 |
48 | decimal
49 | : ?stacks (rs) @ ?exit _taskstack dynamic (rs) ! ;
50 | : perform ( n xt - )
51 | ?stacks \ tasks don't allocate their return stacks until their first PERFORM
52 | (task) on
53 | running? if
54 | rtop cell- rp!
55 | ( xt ) >code >r
56 | ( n )
57 | dtop cell- cell- sp!
58 | ;then
59 | ( xt ) >code rtop cell- cell- !
60 | ( n ) dtop cell- !
61 | dtop cell- cell- sp !
62 | ['] halt >code rtop cell- !
63 | rtop cell- cell- rp !
64 | ;
65 | : perform> ( n - )
66 | r> code> perform ;
67 |
68 | fixed
69 |
70 | \ pulse the multitasker.
71 | : multi ( objlist - )
72 | dup 0= if drop ;then
73 | dup length 0= if drop ;then
74 | >first main node.next !
75 | dup
76 | sp@ main 's sp !
77 | rp@ main 's rp !
78 | main {
79 | begin
80 | ['] pause catch if
81 | cr ." A task crashed. Halting it."
82 | dtop cell- sp! .me
83 | cr ." Data stack: "
84 | .ds
85 | (task) off \ don't call HALT, we don't want PAUSE
86 | then
87 | me node.next @ 0= me main = or until
88 | }
89 | drop
90 | main to task
91 | ;
92 |
93 | : free-task ( - )
94 | (rs) @ -exit (rs) @ destroy ;
95 |
96 |
97 | : task:free-node
98 | dup _actor is? not if destroy ;then
99 | dup actor:free-node
100 | { free-task }
101 | ;
102 |
103 |
104 | \ : empty sp@ main 's sp ! rp@ main 's rp ! empty ;
105 | sp@ main 's sp ! rp@ main 's rp !
106 |
107 | ' task:free-node is free-node
108 |
109 |
--------------------------------------------------------------------------------
/ramen/lib/tween.f:
--------------------------------------------------------------------------------
1 | variable (delay)
2 | variable (length)
3 |
4 |
5 |
6 | create tweens _node static,
7 |
8 | _node sizeof 0 class: _tween
9 |
10 | \ to prevent tweening objects that don't exist anymore
11 | var target parent remove ;
33 |
34 | : store ( val - ) dest @ ! ; \ storer @ execute ;
35 |
36 | : target! dup target ! { ?id } ?dup if @ targetid ! then ;
37 |
38 | : orphaned? ( - flag ) target @ { ?id } dup if @ targetid @ <> then ;
39 |
40 | : tween+ ( - )
41 | now starttime @ < ?exit
42 | orphaned? if me dismiss ;then
43 | startval @ delta @ now starttime @ - endtime @ starttime @ - / ( start delta ratio )
44 | in/out @ execute ease @ execute store
45 | now endtime @ = if me dismiss ;then
46 | ;
47 |
48 |
49 | using tweening
50 |
51 | : does-xt does> @ ;
52 | : :xt create does-xt here 0 , :noname swap ! ;
53 |
54 | \ ease modifiers ( start delta ratio -- progress )
55 | ' noop constant in
56 | :xt out
57 | negate 1.0 + >r swap over + swap negate r> ;
58 | :xt inout
59 | dup 0.5 < if 0.5 2 2* ;then
60 | 0.5 - #1 lshift >r #1 rshift dup u+ r> [ out compile, ]
61 | ;
62 |
63 |
64 | ( Ease functions )
65 | \ all these describe the "in" animations, transformed by IN OUT and INOUT.
66 |
67 | \ exponential formula: c * math.pow(2, 10 * (t / d - 1)) + b;
68 | \ quadratic formula: c * (t /= d) * t + b
69 |
70 | ( startval ratio delta -- val )
71 | :xt LINEAR * + ;
72 | :xt EXPONENTIAL 1 - 10 * 2e 1pf f** f>p * + ;
73 | :xt SINE 90 * 90 - sin 1 + * + ;
74 | :xt QUADRATIC dup * * + ;
75 | :xt CUBIC dup * dup * * + ;
76 | :xt QUARTIC dup * dup * dup * * + ;
77 | :xt QUINTIC dup * dup * dup * dup * * + ;
78 | :xt CIRCULAR dup * 1 swap - sqrt 1 - * negate + ;
79 | : overshoot-func >r dup dup r@ 1 + * r> - * * * + ;
80 | :xt OVERSHOOT 1.70158 overshoot-func ;
81 |
82 | \ call this before calling TWEEN
83 | : timespan ( delay length - ) \ in frames
84 | (length) ! (delay) ! ;
85 |
86 | : *tween ( adr start end ease-xt in/out-xt - tween )
87 | me _tween dynamic {
88 | me tweens push target!
89 | in/out ! ease ! over - delta ! startval !
90 | dest !
91 | (delay) @ now + dup starttime !
92 | (length) @ + endtime !
93 | me }
94 | ;
95 |
96 | : tween ( adr start end ease-xt in/out-xt - )
97 | *tween drop ;
98 |
99 | : tweento ( adr end ease-xt in/out-xt - )
100 | 2>r over @ swap 2r> tween ;
101 |
102 | : tweens+ ( - )
103 | tweens each> as tween+ ;
104 |
105 | stage actor: tweener
106 | :now act> me stage push me { tweens+ } ;
107 |
108 | previous
109 |
--------------------------------------------------------------------------------
/ramen/lib/rsort.f:
--------------------------------------------------------------------------------
1 |
2 | \ 16-bit positive-integer-fixed-point-identifier optimized radix sort!
3 | \ supports sorting a range of numbers between and including 0 ~ 65535
4 |
5 | \ the "radix" in a radix sort is a position or digit within the numbers
6 | \ we're sorting. with each pass, we move the radix one digit. in this case,
7 | \ we start at the right and move to the left until we reach the most significant
8 | \ digit. after all passes are complete, the list is magically sorted.
9 |
10 | \ a radix sort involves no comparisons, but requires a large amount of memory.
11 | \ to control memory use we limit the range of values that this routine
12 | \ can recognize.
13 |
14 | \ for this routine to require just 4 passes, we do it by nybbles,
15 | \ which requires 16 buckets * 2. each bucket needs to be big enough for the
16 | \ entire array, otherwise we'd need extra passes to figure out how big each one
17 | \ needs to be and there'd be more code and we have tons of RAM.
18 | \ since this is meant to be used for the stage, a reasonable maximum limit is
19 | \ 8192 items which works out to 1MB.
20 |
21 | \ $0fff f000 <--- significant bits.
22 |
23 | [undefined] src [if]
24 | 0 value src
25 | 0 value dest
26 | : src! to src ;
27 | : dest! to dest ;
28 | [then]
29 |
30 | define rsorting
31 | decimal
32 |
33 | $0000f000 constant nyb0
34 | nyb0 value radix
35 | 12 constant pass1shift
36 | pass1shift value radixShift
37 |
38 | 15 constant bucketShift
39 | 8192 constant #max \ actual max is #MAX - 1, one cell is reserved for bucket count
40 |
41 | defer @key ( item - key )
42 |
43 | create table0 #max cells 16 * allot
44 | create table1 #max cells 16 * allot
45 | table0 value table
46 |
47 | : other table table0 = if table1 else table0 then to table ;
48 | : radix++ radix 4 << to radix 4 +to radixShift ;
49 | : bucket ( bucket# - bucket ) bucketShift << table + ;
50 | : !bucket ( n bucket# - ) bucket 1 over +! dup @ cells + ! ;
51 | : /buckets ( - ) 16 0 do 0 i bucket ! loop ;
52 |
53 | : irpass ( first-item count - )
54 | cells bounds ?do i @ dup @key radix and radixShift >> !bucket cell +loop ;
55 |
56 | : tablepass ( - )
57 | other /buckets 16 0 do other i bucket @+ other irpass loop radix++ ;
58 |
59 | : irinit ( xt - )
60 | is @key
61 | pass1shift to radixShift nyb0 to radix
62 | table0 to table /buckets other /buckets other ;
63 |
64 | : !result ( - )
65 | 16 0 do i bucket @+ cells dup >r dest swap move r> +to dest loop ;
66 |
67 | only forth definitions also rsorting
68 | fixed
69 | : rsort ( addr cells xt - ) \ destructive, XT is @KEY ( addr - key )
70 | swap 1i swap
71 | over 0= if 2drop drop exit then
72 | irinit over src! irpass radix++
73 | tablepass tablepass tablepass
74 | src dest! !result
75 | ;
76 |
77 | \ test
78 | fixed
79 | marker dispose
80 | create sortable 4123 , 9 , 5 , 1 , 401 , 234 , 100 , 5 , 99 , 4123 , 23 , 3 , 400 , 50 ,
81 | : test <> abort" rsort.f: unit test failed!" ;
82 | sortable 14 ' noop rsort
83 | sortable
84 | @+ 1 test
85 | @+ 3 test
86 | @+ 5 test
87 | @+ 5 test
88 | @+ 9 test
89 | @+ 23 test
90 | @+ 50 test
91 | @+ 99 test
92 | @+ 100 test
93 | @+ 234 test
94 | @+ 400 test
95 | @+ 401 test
96 | @+ 4123 test
97 | @+ 4123 test
98 | drop
99 | dispose
100 |
--------------------------------------------------------------------------------
/sample/platformer/lib/array2d.f:
--------------------------------------------------------------------------------
1 | fixed
2 | struct: %array2d
3 | %array2d svar array2d.cols
4 | %array2d svar array2d.rows
5 | %array2d svar array2d.pitch
6 | %array2d svar array2d.data
7 | %array2d svar array2d.ref \ another array2d
8 | %array2d svar array2d.col \ coords in the referenced array2d
9 | %array2d svar array2d.row
10 |
11 | : 2move ( src /pitch dest /pitch /bytes #rows - )
12 | locals| #rows #bytes destpitch dest srcpitch src |
13 | #rows for
14 | src dest #bytes move
15 | srcpitch +to src destpitch +to dest
16 | loop ;
17 |
18 | \ incomplete ... need to adjust address for negative clip
19 | : clip ( col row #cols #rows #destcols #destrows - col row #cols #rows )
20 | 2>r 2over 2+ 0 0 2r@ 2clamp 2swap 0 0 2r> 2clamp 2swap 2over 2- ;
21 |
22 | : array2d-head, ( cols rows - )
23 | udup 2pfloor 2, cells ( pitch ) , here 4 cells + ,
24 | 0 , 0 , 0 , ;
25 |
26 | \ by default the data field is set to the adjacent dictionary space
27 | : array2d, ( numcols numrows - )
28 | 2dup array2d-head, * cells /allot ;
29 |
30 | : array2d: ( numcols numrows - )
31 | create array2d, ;
32 |
33 | : dims ( array2d - numcols numrows )
34 | array2d.cols 2@ ;
35 |
36 | : cols dims drop ;
37 | : rows dims nip ;
38 |
39 |
40 | : (clamp) ( col row array2d - col row array2d )
41 | >r 2pfloor 0 0 r@ array2d.cols 2@ 2clamp r> ;
42 |
43 | : ?ref
44 | dup array2d.ref @ ?dup if nip then ;
45 |
46 | : >data
47 | ?ref array2d.data @ ;
48 |
49 | : pitch@
50 | ?ref array2d.pitch @ ;
51 |
52 | : colrow+
53 | array2d.col 2@ 2+ ;
54 |
55 | : loc ( col row array2d - adr )
56 | (clamp) >r r@ colrow+ r@ pitch@ * swap cells + r> >data + ;
57 |
58 | : count2d ( array2d - data size )
59 | dup >data swap array2d.cols 2@ * cells ;
60 |
61 | : section2d: ( array2d col row #cols #rows - )
62 | create array2d-head, lastbody array2d.ref 3! ;
63 |
64 | : adr-pitch ( col row array2d - adr /pitch )
65 | dup >r loc r> pitch@ ;
66 |
67 | : eachrow ( ... col row #cols #rows XT array2d - ... ) ( ... adr #cells - ... )
68 | swap >r >r r@ dims clip 2swap r> adr-pitch
69 | r> locals| xt pitch src #rows #cols |
70 | #rows 0 do src #cols xt execute pitch +to src loop ;
71 |
72 | : eachrow> ( ... col row #cols #rows array2d - ... ) ( ... adr #cells - ... )
73 | r> code> swap eachrow ;
74 |
75 | : fill2d ( val col row #cols #rows array2d - )
76 | eachrow> third ifill ;
77 |
78 | : clear2d ( array2d - )
79 | >r 0 0 0 r@ dims r> fill2d ;
80 |
81 | : 2d. >r 0 0 r@ dims 16 16 2min r>
82 | eachrow> cr cells bounds do i @ h. cell +loop ;
83 |
84 | : put2d ( src-array2d dest-array2d col row - ) \ uses SRCRECT ; no clipping
85 | rot adr-pitch 2>r
86 | srcrect xy@ rot adr-pitch 2r> ( adr pitch adr pitch )
87 | srcrect wh@ >r cells r> 2move ;
88 |
89 |
90 | \ TABLE2D: ( cols - array2d adr )
91 | \ TABLE2D ( cols - array2d array2d adr ) the table will be left on the stack after ;TABLE2D
92 | \ ;TABLE2D ( array2d adr - ) call to terminate the definition
93 |
94 | : table2d here swap 0 array2d-head, dup here ;
95 | : table2d: create table2d nip ;
96 | : ;table2d here swap - cell/ over array2d.cols @ / pceil swap array2d.rows ! ;
97 |
98 | \ test
99 | marker dispose
100 | create a 10 15 array2d,
101 | create b 12 7 array2d,
102 | a count2d cell/ 5 ifill
103 | b count2d cell/ 10 ifill
104 | dispose
105 |
--------------------------------------------------------------------------------
/afkit/plat/win/fpext.f:
--------------------------------------------------------------------------------
1 | \ Words for passing floats and doubles to DLL's
2 |
3 | \ iCODE 4sf ( f: x y z t - ) ( s: - x y z t )
4 | \ 4 >fs \ make sure data on hardware stack
5 | \ 16 # EBP SUB \ room for 4 integers and tos
6 | \ 12 [EBP] DWORD FSTP \ convert t
7 | \ 0 [EBP] DWORD FSTP \ convert z
8 | \ 4 [EBP] DWORD FSTP \ convert y
9 | \ 8 [EBP] DWORD FSTP \ convert x
10 | \ 12 [EBP] EBX XCHG \ swap t and old tos
11 | \ RET END-CODE
12 | \
13 | \ iCODE 1df ( f: x - ) ( s: - xl xh )
14 | \ >f \ make sure data on hardware stack
15 | \ 8 # EBP SUB \ make room for double
16 | \ 0 [EBP] QWORD FSTP \ convert
17 | \ 4 [EBP] EBX XCHG \ swap xh and old tos
18 | \ RET END-CODE
19 | \
20 | \ iCODE 3sf ( f: x y z - ) ( s: - x y z )
21 | \ 3 >fs \ make sure data on hardware stack
22 | \ 12 # EBP SUB \ room for 3 integers and tos
23 | \ 8 [EBP] DWORD FSTP \ convert z
24 | \ 0 [EBP] DWORD FSTP \ convert y
25 | \ 4 [EBP] DWORD FSTP \ convert x
26 | \ 8 [EBP] EBX XCHG \ swap z and old tos
27 | \ RET END-CODE
28 | \
29 | \ iCODE 2sf ( f: x y z - ) ( s: - x y z )
30 | \ 2 >fs \ make sure data on hardware stack
31 | \ 8 # EBP SUB \ room for 2 integers and tos
32 | \ 4 [EBP] DWORD FSTP \ convert y
33 | \ 0 [EBP] DWORD FSTP \ convert x
34 | \ 4 [EBP] EBX XCHG \ swap z and old tos
35 | \ RET END-CODE
36 | \
37 | \ iCODE 1sf ( f: x - ) ( s: - x )
38 | \ 1 >fs \ make sure data on hardware stack
39 | \ 4 # EBP SUB \ room for 1 integers and tos
40 | \ 0 [EBP] DWORD FSTP \ convert x
41 | \ 0 [EBP] EBX XCHG \ swap x and old tos
42 | \ RET END-CODE
43 |
44 |
45 | variable sf
46 | : 1sf sf sf! sf @ ;
47 | : 2sf 1sf 1sf swap ;
48 | : 3sf 1sf 2sf rot ;
49 | : 4sf 2sf 2sf 2swap ;
50 |
51 | variable df
52 | : 1df df f! df 2@ ;
53 |
54 | : 0e ( - f: n ) STATE @ IF POSTPONE #0.0e ELSE #0.0e THEN ; immediate
55 | : 1e ( - f: n ) STATE @ IF POSTPONE #1.0e ELSE #1.0e THEN ; immediate
56 |
57 | : 2s>f swap s>f s>f ; ( x y - f: x y )
58 | : 3s>f rot s>f swap s>f s>f ; ( x y z - f: x y z )
59 | : 4s>f 2swap 2s>f 2s>f ;
60 | : c>f s>f 255e f/ ; ( c - f: n )
61 |
62 | : fValue ( "name" - )
63 | Create f, immediate does> state @ if s" literal f@ " evaluate exit then
64 | f@ ;
65 |
66 | : fto ( f: v - )
67 | ' >body state @
68 | if postpone literal
69 | postpone f!
70 | else f!
71 | then ; immediate
72 |
73 | \ \ NOTE: these are not conversion routines, these are TRANSFER routines. the numbers
74 | \ \ returned on the data static are unusable except by DLL's.
75 | \
76 | \ : 2df 1df 2>r 1df 2r> ; ( f: x y - ) ( s: float float )
77 | \
78 | \ : 3df ( f: x y z - ) ( s: float float float )
79 | \ 1df 2>r 1df 2>r 1df 2r> 2r> ;
80 | \
81 | \ : 4df ( f: x y z a - ) ( s: float float float float )
82 | \ 1df 2>r 1df 2>r 1df 2>r 1df 2r> 2r> 2r> ;
83 | \
84 | \ : 5df ( f: x y z a b - ) ( s: float float float float float )
85 | \ 1df 2>r 1df 2>r 1df 2>r 1df 2>r 1df 2r> 2r> 2r> 2r> ;
86 | \
87 | \ : 6df ( f: x y z a b c - ) ( s: float float float float float float )
88 | \ 1df 2>r 1df 2>r 1df 2>r 1df 2>r 1df 2>r 1df 2r> 2r> 2r> 2r> 2r> ;
89 | \
90 | \ : 9df ( f: x y z a b c d e f - ) ( s: float float float float float float float float float )
91 | \ 1df 2>r 1df 2>r 1df 2>r 1df 2>r 1df 2>r 1df 2>r 1df 2>r 1df 2>r 1df
92 | \ 2r> 2r> 2r> 2r> 2r> 2r> 2r> 2r> ;
93 |
--------------------------------------------------------------------------------
/sample/platformer/tools.f:
--------------------------------------------------------------------------------
1 | depend sample/platformer/lib/tilemap2.f
2 |
3 | ( misc )
4 | : enum dup constant 1 + ;
5 | : ztype zcount type ;
6 | : live-for ( n - ) perform> pauses end ;
7 | : (those) ( filter-xt code objlist - filter-xt code )
8 | each> as over execute if dup >r then ;
9 | : those> ( filter-xt objlist - ) ( - ) \ note you can't pass anything to
10 | r> me { swap (those) 2drop } ;
11 | : njump ( n adr - )
12 | swap cells + @ execute ;
13 | : rndcolor ( - ) 1 rnd 1 rnd 1 rnd rgb ;
14 | : bit# ( bitmask - n )
15 | #1 32 for 2dup and if 2drop i unloop ;then 1 << loop 2drop -1 ;
16 | : sf@+ dup sf@ cell+ ;
17 | : tinted fore sf@+ f>p swap sf@+ f>p swap sf@+ f>p swap sf@+ f>p nip tint 4! ;
18 | : /sprite draw> sprite ;
19 | : *sprite ( image - obj ) stage *actor { tinted img ! /sprite me } ;
20 | : csprite img @ imagewh 0.5 0.5 2* cx 2! sprite ;
21 | : *csprite ( image - obj ) stage *actor { tinted img ! draw> csprite me } ;
22 | : >data project count s" data/" strjoin 2swap strjoin ; \ prepend assets with data path
23 | : hide 's hidden on ;
24 | : reveal 's hidden off ;
25 | : dynamic? dyn @ 0<> ;
26 | : static? dyn @ 0= ;
27 |
28 | ( directional key tools )
29 | variable lastkeydir
30 | : left? kstate ;
31 | : right? kstate ;
32 | : up? kstate ;
33 | : down? kstate ;
34 | : pleft? pressed ;
35 | : pright? pressed ;
36 | : pup? pressed ;
37 | : pdown? pressed ;
38 | : dirkeys? left? right? or up? or down? or ;
39 | : rdirkeys? released released or released or released or ;
40 | : pdirkeys? pressed pressed or pressed or pressed or ;
41 | : keydir ( -- n )
42 | left? if 180 exit then
43 | right? if 0 exit then
44 | up? if 270 exit then
45 | down? if 90 exit then
46 | -1 ;
47 | : pkeydir ( -- n )
48 | pleft? if 180 exit then
49 | pright? if 0 exit then
50 | pup? if 270 exit then
51 | pdown? if 90 exit then
52 | -1 ;
53 | : !dirkey
54 | pdirkeys? if pkeydir lastkeydir ! exit then
55 | rdirkeys? if keydir lastkeydir ! exit then ;
56 |
57 | ( tasks )
58 | objlist: tasks
59 |
60 | extend: _actor
61 | var (xt) ?end then ;
67 | : target! dup target ! { ?id } ?dup if @ targetid ! then ;
68 | : *task me tasks *actor target! act> ?waste ;
69 | : (after) perform> pauses (xt) @ target @ { execute } end ;
70 | : after ( xt n - ) me { *task swap (xt) ! (after) } ;
71 | : after> ( n - ) r> code> swap after ;
72 | : (every) perform> begin (xt) @ target @ { execute } dup pauses again ;
73 | : every ( xt n - ) me { *task swap (xt) ! (every) } ;
74 | : every> ( n - ) r> code> swap every ;
75 |
76 | ( physics )
77 | _actor fields: var 'physics r> 'physics ! ;
79 | : ?physics 'physics @ ?dup if >r then ;
80 |
81 | ( tilemap collision )
82 | _actor fields: var onmaphit ;
84 | :make on-tilemap-collide onmaphit @ execute ;
85 |
86 | ( extend loop )
87 | : think ( - ) stage acts tasks multi stage multi tasks acts ;
88 | : physics ( - ) stage each> as ?physics vx 2@ x 2+! ;
89 | : tools:step ( - ) step> think physics sweep ;
90 | tools:step
91 |
92 | ( canned movements )
93 | : control-8way
94 | act>
95 | 0
96 | kstate if drop -1 then
97 | kstate if drop 1 then
98 | 0
99 | kstate if drop -1 then
100 | kstate if drop 1 then
101 | vx 2!
102 | ;
103 |
--------------------------------------------------------------------------------
/afkit/ans/roger.f:
--------------------------------------------------------------------------------
1 | : zcount ( zaddr - addr n ) dup dup if 65535 0 scan drop over - then ;
2 | : zlength ( zaddr - n ) zcount nip ;
3 | : zplace ( from n to - ) tuck over + >r cmove 0 r> c! ;
4 | : zappend ( from n to - ) zcount + zplace ;
5 | [undefined] third [if] : third >r over r> swap ; [then]
6 | [undefined] @+ [if] : @+ dup @ swap cell+ swap ; [then]
7 | : u+ rot + swap ; \ "under plus"
8 | : ?lit state @ if postpone literal then ;
9 | : do postpone ?do ; immediate
10 | : for s" 0 ?do" evaluate ; immediate
11 | : /allot here over allot swap erase ;
12 | : allotment here swap /allot ;
13 | : move, here over allot swap move ;
14 | : h? @ h. ;
15 | : reclaim h ! ;
16 | : ]# ] postpone literal ;
17 | : << s" lshift" evaluate ; immediate
18 | : >> s" rshift" evaluate ; immediate
19 | : bit dup constant 1 lshift ;
20 | : clamp ( n low high - n ) -rot max min ;
21 | : and! dup >r @ and r> ! ;
22 | : or! dup >r @ or r> ! ;
23 | : xor! dup >r @ xor r> ! ;
24 | : not! >r invert r> and! ;
25 | : @! dup @ >r ! r> ;
26 | : bounds over + swap ;
27 | : lastbody last @ name> >body ;
28 | : ccount dup c@ 1 u+ ;
29 | : .name dup if body> >name ccount type space else . then ;
30 | : $= compare 0= ;
31 |
32 | : count dup @ cell u+ ;
33 | : string, dup , move, ;
34 | : place 2dup ! cell+ swap move ;
35 | : append 2dup 2>r count + swap move 2r> +! ;
36 | : count! ! ;
37 | : count+! +! ;
38 | : ," [char] " parse string, ;
39 | : included 2dup cr ." [Include] " type included ;
40 |
41 | \ lo and hi are inclusive
42 | : inrange ( n lo hi - flag ) over - >r - r> #1 + u< ;
43 |
44 | : ifill ( addr count val - ) -rot 0 do over !+ loop 2drop ;
45 | : ierase 0 ifill ;
46 | : imove ( from to count - ) cells move ;
47 | : time? ( xt - ) ucounter 2>r execute ucounter 2r> d- d>s . ;
48 |
49 | : kbytes #1024 * ;
50 | : megs #1048576 * ;
51 | : udup over swap ;
52 | : 2, swap , , ;
53 | : 3, rot , swap , , ;
54 | : 4, 2swap swap , , swap , , ;
55 | : :make :noname postpone [ [compile] is ] ;
56 | : reverse ( ... count - ... ) 1 + 1 ?do i 1 - roll loop ;
57 | : ;then s" exit then" evaluate ; immediate
58 | : free dup 0= if ;then free ;
59 |
60 | \ Random numbers
61 | 0 VALUE seed
62 | : /rnd ucounter drop to seed ; /rnd
63 | : random ( - u ) seed $107465 * $234567 + DUP TO seed ;
64 | : rnd ( n - 0..n-1 ) random um* nip ;
65 |
66 | \ readability helper: slang words. callable once then they self-destruct.
67 | : ?compile state @ if compile, else execute then ;
68 | : does-slang does> dup @ ?compile 0 swap body> >name c! ;
69 | : :slang ( - ; ) create immediate here 0 , does-slang :noname swap ! ;
70 |
71 | \ vocabulary helpers
72 | : define
73 | >in @
74 | exists if >in ! also ' execute definitions exit then \ already defined
75 | dup >in ! vocabulary
76 | >in ! also ' execute definitions ;
77 | : using only forth definitions also ;
78 | vocabulary internal
79 |
80 | \ on-stack vector stuff (roger)
81 | : 2! swap over cell+ ! ! ;
82 | : 2@ dup @ swap cell+ @ ;
83 | : 2+! swap over cell+ +! +! ;
84 | : 3@ dup @ swap cell+ dup @ swap cell+ @ ;
85 | : 4@ dup @ swap cell+ dup @ swap cell+ dup @ swap cell+ @ ;
86 | : 3! dup >r 2 cells + ! r> 2! ;
87 | : 4! dup >r 2 cells + 2! r> 2! ;
88 | : 2min rot min >r min r> ;
89 | : 2max rot max >r max r> ;
90 | : 2+ rot + >r + r> ;
91 | : 2- rot swap - >r - r> ;
92 | : 2negate negate swap negate swap ;
93 | : 2clamp ( x y lowx lowy highx highy - x y ) 2>r 2max 2r> 2min ;
94 |
95 | \ Word tools
96 | : defined ( - c-addr 0 | xt -1 | - xt 1 ) bl word find ;
97 | : exists ( - flag ) defined 0 <> nip ;
98 |
99 | \ compile and exec
100 | : :now :noname [char] ; parse evaluate postpone ; execute ;
101 |
102 | include afkit/ans/depend.f
103 |
104 | defer alert ( a c - )
105 | :make alert type true abort ;
106 |
--------------------------------------------------------------------------------
/ramen/lib/std/sprites.f:
--------------------------------------------------------------------------------
1 | ( Sprite objects )
2 |
3 | \ animation format:
4 | \ region table,
5 | \ image,
6 | \ speed,
7 | \ <...frame indices...>,
8 | \ $DEADBEEF,
9 | \ offset to loop start, (from location of $DEADBEEF)
10 |
11 | defer animlooped ( - ) :make animlooped ; \ define this in your app to do stuff every time an animation ends/loops
12 |
13 | \ Region tables
14 | 6 cells constant /region
15 | \ x , y , w , h , originx , originy ,
16 |
17 | cell constant /frame
18 | \ index+flip , ...
19 | \ hflip = $1
20 | \ vflip = $2
21 | \ index is fixed point
22 |
23 | extend: _actor
24 | \ Transformation info
25 | var sx var sy \ scale
26 | var ang \ rotation
27 | var cx var cy \ center
28 | %color sizeof field tint
29 |
30 | \ animation state; all can be modified freely. only required value is IMG.
31 | var img prototype as
39 | 1 1 sx 2!
40 | 1 1 1 1 tint 4!
41 | 1 anmspd !
42 |
43 | ( Drawing )
44 | : bsprite ( srcx srcy w h flip )
45 | locals| flip h w y x |
46 | img @ -exit
47 | img @ >bmp x y w h 4af tint 4@ 4af cx 2@ destxy 4af sx 2@ 2af
48 | ang @ >rad 1af flip
49 | al_draw_tinted_scaled_rotated_bitmap_region ;
50 |
51 | ( Frame stuff )
52 | : rgntbl img @ image.regions ;
53 |
54 | : framexywh ( n rgntbl - srcx srcy w h )
55 | swap /region * + 4@ ;
56 |
57 | : >region ( n - srcx srcy w h )
58 | img @ 0= if 0 0 0 0 ;then
59 | rgntbl @ if
60 | rgntbl @ framexywh
61 | ;then
62 | img @ image.subw @ if
63 | img @ subxywh
64 | else
65 | 0 0 img @ imagewh
66 | then
67 | ;
68 |
69 | ( Animation )
70 | : >frame ( anm - adr )
71 | ( skip the settings ) 2 cells + anmctr @ pfloor /frame * + ;
72 |
73 | : curflip ( index - index n )
74 | anm @ if anm @ >frame @ #3 and ;then dup 3 and ;
75 |
76 | : ?regorg ( index - index ) \ apply the region origin
77 | img @ -exit rgntbl @ -exit
78 | rgntbl @ over /region * + 4 cells + 2@ cx 2! ;
79 |
80 | : frame@ ( - n ) \ fetch FRM if ANM is 0
81 | anm @ dup if >frame @ else drop frm @ then ;
82 |
83 | \ NSPRITE
84 | \ draw a sprite either from a subdivided image, animation, or image plus region table.
85 | \ if there's no animation, you can pack the flip info into the index. (lower 2 bits)
86 | \ IMG must be subdivided and/or it must have a region table. (region table takes precedence.)
87 | \ if neither, then the whole IMG will be drawn
88 | : nsprite ( index - )
89 | img @ 0= if drop ;then
90 | anm @ if frm ! frame@ then
91 | ?regorg >region curflip bsprite ;
92 |
93 | : +frame ( speed - ) \ Advance the animation
94 | ?dup -exit anm @ -exit
95 | anmctr +!
96 | ( looping: )
97 | frame@ $deadbeef = if anm @ >frame cell+ @ anmctr +! animlooped then
98 | ;
99 |
100 | : sprite ( - ) \ draw sprite and advance the animation if any
101 | frame@ nsprite anmspd @ +frame ;
102 |
103 | \ Play an animation from the beginning, using its settings
104 | : animate ( anim - )
105 | dup anm ! @+ img ! @+ anmspd ! drop 0 anmctr ! ;
106 |
107 | \ Define animations
108 | : anim: ( image speed - loopadr )
109 | create 2, here ;
110 | : autoanim: ( image speed - loopadr ) ( - )
111 | anim: does> animate ;
112 |
113 | : ,, for dup , loop drop ;
114 | : loop: drop here ;
115 | : ;anim ( loopaddr - ) $deadbeef , here - /frame i/ 1p 1 + , ;
116 | : range, ( start len - ) bounds do i , loop ;
117 |
118 | \ flipped frame utilities
119 | : ,h #1 or , ;
120 | : ,v #2 or , ;
121 | : ,hv #3 or , ;
122 |
--------------------------------------------------------------------------------
/venery/nodetree.f:
--------------------------------------------------------------------------------
1 | ( Node tree )
2 | struct %node
3 | %node %collection sembed node.collection
4 | %node svar node.parent
5 | %node svar node.previous
6 | %node svar node.next
7 | %node svar node.first
8 | %node svar node.last
9 |
10 | collection-vtable-size vtable node-vtable ( collection 0 )
11 | \ [] ( index node -- node|0 )
12 | :vector
13 | dup length 0 = if 2drop 0 exit then
14 | node.first @ swap 0 ?do node.next @ loop ;
15 | \ truncate ( newlength node -- )
16 | :vector
17 | locals| c newlen |
18 | newlen c length over - c deletes
19 | newlen c collection.length dup @ rot min swap ! ;
20 | \ push ( node destnode -- )
21 | :vector
22 | locals| b a |
23 | a node.parent @ ?dup if a swap remove then
24 | b node.last @ a node.previous !
25 | b node.first @ 0 = if a b node.first ! then
26 | a b node.last !
27 | a node.previous @ ?dup if a swap node.next ! then
28 | b a node.parent !
29 | 1 b collection.length +!
30 | ;
31 | \ pop ( node -- node|0 )
32 | :vector
33 | locals| a |
34 | a node.last @ dup 0 = abort" Tried to pop from empty node"
35 | dup a remove ;
36 | \ each ( xt collection -- ) ( val -- )
37 | :vector
38 | dup length 0 = over 0 = or if 2drop exit then
39 | xt >r swap to xt
40 | node.first @ begin ?dup while
41 | dup node.next @ >r
42 | xt execute
43 | r>
44 | repeat
45 | r> to xt ;
46 | \ deletes ( index count collection -- )
47 | :vector 3dup nip length >= if 3drop exit then
48 | locals| c n i0 |
49 | n 0 do
50 | i0 c [] dup c remove free-node
51 | loop
52 | ;
53 | \ .each ( collection -- )
54 | :vector locals| c | c length dup 1i i. ." items: " 0 ?do i c [] . loop ;
55 | \ remove ( node collection -- )
56 | :vector locals| c n |
57 | n 0 = if exit then
58 | n node.parent @ 0 = if exit then \ not already in any container
59 | n node.parent @ c = not if abort" Tried to remove node from an unrelated node" then
60 | -1 c collection.length +!
61 | c length if
62 | n c node.first @ = if n node.next @ c node.first ! then
63 | n c node.last @ = if n node.previous @ c node.last ! then
64 | else
65 | 0 c node.first ! 0 c node.last !
66 | then
67 | 0 n node.parent !
68 | n node.previous @ if n node.next @ n node.previous @ node.next ! then
69 | n node.next @ if n node.previous @ n node.next @ node.previous ! then
70 | 0 n node.previous ! 0 n node.next ! ;
71 | \ ?@ ( adr collection -- val ) \ adr is val adr, or node, depending, e.g. in EACH SOME DIFF
72 | :vector drop ;
73 | \ removeat ( i collection -- ) \ deletes or removes the value at i, depending.
74 | :vector dup >r [] r> remove ;
75 | \ insert ( node i dest-collection -- )
76 | :vector 2dup [] locals| sibling b i a |
77 | a node.parent @ ?dup if a swap remove then
78 | i b length 1 - >= if
79 | a b push
80 | exit
81 | then
82 | i 0 = if
83 | b node.first @ a node.next !
84 | a b node.first !
85 | a dup node.next @ node.previous !
86 | else
87 | sibling a node.next !
88 | sibling node.previous @ a node.previous !
89 | a sibling node.previous !
90 | a dup node.previous @ node.next !
91 | then
92 | b a node.parent !
93 | 1 b collection.length +! ;
94 | 2drop
95 |
96 | : /node ( node -- )
97 | $ffffffff over collection.capacity !
98 | node-vtable swap collection.vtable ! ;
99 |
100 | : 0node ( node -- )
101 | dup %node venery:sizeof erase /node ;
102 |
--------------------------------------------------------------------------------
/ramen/README.md:
--------------------------------------------------------------------------------
1 | # README
2 |
3 | Ramen is a 2D game engine written in standard Forth.
4 |
5 | This is the package repository, containing only Ramen and none of its dependencies or any examples.
6 |
7 | Currently all documentation pertains to the 1.0 branch.
8 |
9 | 2.0 is being developed on the Master branch. The new main distribution repository, containing all dependencies (as submodules) and examples, is at https://github.com/RogerLevy/RamenEngine.
10 |
11 | I didn't see any conversion on 1.0/1.x (and probably for good reason) and I don't expect anyone to use it right now , but here is a link to the 1.x documentation anyway: [Documentation](https://rogerlevy.gitbook.io/ramen/v/docs/)
12 |
13 |
14 |
15 | ## Features
16 |
17 | * Built with Allegro 5, using [AllegroForthKit](https://github.com/RogerLevy/AllegroForthKit).
18 | * [Tiled](https://www.mapeditor.org/) map support \(partial\)
19 | * Sprite animation
20 | * Multiple display list support
21 | * Interactive commandline console
22 | * Fast rectangle collision detection
23 | * Roundrobin multitasking
24 | * Graphics primitives such as line, rectangle, ellipse, blit, text, etc.
25 | * Publish facility
26 | * Z-sorted rendering
27 | * Basic sound support
28 | * Collections with [Venery](https://github.com/RogerLevy/venery)
29 |
30 | ## See Ramen in Action
31 |
32 | Want to watch some videos? Here's footage of examples from Ramen's predecessor. They're being updated to work on Ramen.
33 |
34 | [https://www.youtube.com/playlist?list=PLO8m1cHe8erpbejS5yZVJAsQNI4Lmpo\_Y](https://www.youtube.com/playlist?list=PLO8m1cHe8erpbejS5yZVJAsQNI4Lmpo_Y)
35 |
36 | Also check out [The Lady](https://store.steampowered.com/app/341060/The_Lady/%20), a commercial game I wrote in Forth to prove it can be done. Large chunks of this game's engine live on in Ramen.
37 |
38 | ## Getting Started
39 |
40 | 1. Download [SwiftForth](https://www.forth.com/swiftforth/). After installing add the bin folder to your path.
41 | 2. Download or clone [ramenExamples](https://github.com/RogerLevy/ramenExamples)
42 | 3. \(If you download a release directly into your project, rename the folder to just `ramen`\).
43 | 4. Copy and rename `afkit/kitconfig.f_` and `afkit/allegro5.cfg_` to the project root, removing the underscores. Edit them if needed.
44 | 5. Optionally get [Komodo Edit](https://www.activestate.com/komodo-ide/downloads/edit) and loading the project file - just hit F5 and the IDE should start.
45 | 6. Otherwise load up SwiftForth, navigate to the project directory with `cd` and `include session.f` - the IDE should start.
46 | 7. You can `ld` any of these: `depth` `flies` `rectland` `island` `stickerknight`
47 | 8. Hit Tab to toggle between IDE and the running demo. Only `rectland` has any controls.
48 | 9. For a more advanced example check out [LinkGoesForth](https://github.com/RogerLevy/linkgoesforth). Note the IDE is active by default. The game won't receive input until you toggle out of it.
49 |
50 | ## Help
51 |
52 | * Submit [Issues](https://github.com/RogerLevy/ramen/issues)
53 | * Tweet [@RamenEngine](https://twitter.com/RamenEngine)
54 |
55 | ## Links and Resources
56 |
57 | * [Forth: The Hacker's Language on HACKADAY](https://hackaday.com/2017/01/27/forth-the-hackers-language/)
58 | * [Programming Forth by Stephen Pelc](http://www.mpeforth.com/arena/ProgramForth.pdf)
59 | * [Forth Programming 21st Century on Facebook](https://www.facebook.com/groups/PROGRAMMINGFORTH/) - The current active and growing forum on the web for modern desktop Forth programming \(as opposed to on embedded or classic computers.\)
60 | * [Allegro 5.2.3 Documentation](http://liballeg.org/a5docs/5.2.3/)
61 | * [Allegro.cc forum](https://www.allegro.cc/forums) - A very helpful and fairly active community. And gladly, language-agnostic.
62 | * [The DPANS94 Forth Standard](http://dl.forth.com/sitedocs/dpans94.pdf)
63 |
64 | ## Projects
65 |
66 | * [Zelda clone](https://github.com/RogerLevy/linkgoesforth)
67 | * [Starfox-like Dogfighting game](https://github.com/RogerLevy/triplestrength)
68 | * [3D Packet](https://github.com/RogerLevy/3dpack)
69 | * [Bento 2D Physics Packet](https://github.com/RogerLevy/bento)
70 |
--------------------------------------------------------------------------------
/ramen/lib/std/actor.f:
--------------------------------------------------------------------------------
1 | 0 value lastRole \ used by map loaders (when loading objects scripts)
2 | variable nextid
3 |
4 | 0 4 kbytes class: _role
5 | ;class
6 |
7 | 512 cells node-class: _actor
8 | var role prototype ; \ default role-var and action values for all newly created roles
21 |
22 | 64 cells node-class: _objlist
23 | ;class
24 |
25 | create objlists _node static, \ parent of all objlists
26 |
27 | : >first ( node - node|0 ) node.first @ ;
28 | : >last ( node - node|0 ) node.last @ ;
29 | : >parent ( node - node|0 ) node.parent @ ;
30 | : ?id id $80000000 and 0= if id else 0 then ;
31 | : !id 1 nextid +! nextid @ id ! ;
32 | : *actor ( parent - actor ) _actor dynamic { me swap push !id at@ x 2! dyn on me } ;
33 | : detach ( node - ) dup >parent dup if remove else drop drop then ;
34 | : dismiss ( actor - ) 's marked on ;
35 |
36 | : actor:free-node
37 | dup _actor is? not if destroy ;then
38 | {
39 | dyn @ if me destroy then
40 | id off \ necessary for breaking connections
41 | }
42 | ;
43 |
44 | ' actor:free-node is free-node
45 |
46 | \ making stuff move and displaying them
47 | : ?call ( adr - ) ?dup -exit call ;
48 | : draw ( - ) en @ -exit hidden @ ?exit x 2@ at drw @ ?call ;
49 | : draws ( objlist ) each> as draw ;
50 | : act ( - ) en @ -exit beha @ ?call ;
51 | : sweep ( - ) objlists each> each> as marked @ -exit marked off id off me free-node ;
52 | : acts ( objlist ) each> as act ;
53 | : draw> ( - ) r> drw ! hidden off ;
54 | : act> ( - ) r> beha ! ;
55 | : from ( actor x y - ) rot 's x 2@ 2+ at ;
56 | : -act ( - ) act> noop ;
57 | : objlist: ( - ) create _objlist static objlists push ;
58 |
59 | ( stage )
60 | objlist: stage \ default object list
61 |
62 | : one ( - actor )
63 | stage *actor ;
64 |
65 | ( static actors )
66 | : actor, ( parent - ) _actor static as me swap push !id ;
67 | : actor: ( parent - ) create actor, _actor fields: ;
68 |
69 | ( role stuff )
70 |
71 | : role's ( - adr )
72 | s" role @" evaluate ' >body _role superfield>offset ?literal s" +" evaluate
73 | ; immediate
74 |
75 | ( actions )
76 | : is-action? field.attributes @ ;
77 |
78 | : action: ( - ) ( ??? - ??? )
79 | _role fields:
80 | cell ?superfield _role superfield>offset role @ + @ execute ;
84 |
85 | : role-var class _role to class var to class ;
86 | : role-field class >r _role to class field r> to class ;
87 |
88 | : :to ( role - ... )
89 | postpone 's :noname swap ! ;
90 |
91 | : :action ( - ; ) ( ??? - ??? )
92 | >in @ action: >in ! basis :to ;
93 |
94 |
95 | : -> ( role - )
96 | postpone 's s" @ execute" evaluate ; immediate
97 |
98 | ( create role )
99 | : ?update ( - )
100 | >in @
101 | defined if >body to lastRole r> drop drop ;then
102 | drop
103 | >in ! ;
104 |
105 | : role: ( - )
106 | ?update create _role static as
107 | me to lastRole
108 | _actor fields:
109 | ['] is-action? _role >fields some>
110 | :noname swap
111 | field.offset @
112 | dup basis + postpone literal s" @ execute ; " evaluate \ compile "bridge" code
113 | lastRole + ! \ assign our "bridge" to the corresponding action
114 | ;
115 |
116 |
117 | ( inspection )
118 | : .role ( actor - )
119 | >class ?dup if peek else ." No role" then ;
120 |
121 | : .objlist ( objlist - )
122 | dup length 1i i. each>
123 | { cr me h. ." ID: " id ? ." X/Y: " x 2@ 2. } ;
124 |
125 | _actor >prototype as
126 | en on
127 | basis role !
128 |
--------------------------------------------------------------------------------
/ramen/fixops.f:
--------------------------------------------------------------------------------
1 | \ Basic Fixed-point ops (assuming no fixed-point literal support)
2 | \ the following words will be redefined
3 | \ * / /mod
4 | \ loop
5 | \ the following words will remain untouched
6 | \ + - mod */
7 | \ the following words will use prefixes to avoid collision with float words
8 | \ pfloor pceil
9 | \ additional words for conversion to and from other formats
10 | \ 1p 2p 3p 4p --- int to fixed
11 | \ 1i 2i 3i 4i --- fixed to int
12 | \ 1pf 2pf 3pf 4pf --- fixed to float
13 |
14 | \ words should take fixed unless otherwise noted:
15 | \ ( n - ) <-- fixed
16 | \ ( n# - ) < - integer ( #n ) means # of n's, in fixed point. ( #n# - ) means # of n's, in integer.
17 |
18 | 12 constant /FRAC
19 | $FFFFF000 constant INT_MASK
20 | $00000FFF constant FRAC_MASK
21 | : FPRES s" 4096e" evaluate ; immediate
22 | 4096 constant PGRAN
23 | $1000 constant 1.0
24 |
25 | : i* * ;
26 | : i/ / ;
27 | : iloop postpone loop ; immediate
28 |
29 | : 1p state @ if /frac postpone literal postpone lshift else /frac lshift then ; immediate
30 |
31 |
32 | [in-platform] sf [if]
33 | icode arshift ( x1 n - x2 )
34 | ebx ecx mov \ shift count in ecx
35 | pop(ebx) \ get new tos
36 | ebx cl sar \ and shift bits right
37 | ret end-code
38 | package OPTIMIZING-COMPILER
39 | optimize (literal) arshift with lit-shift assemble sar
40 | end-package
41 | : 1i state @ if /frac postpone literal postpone arshift else /frac arshift then ; immediate
42 | [else]
43 | : 1i state @ if 1.0 postpone literal postpone / else 1.0 / then ; immediate
44 | [then]
45 |
46 | : 2p 1p swap 1p swap ;
47 | : 3p 1p rot 1p rot 1p rot ;
48 | : 4p 2p 2swap 2p 2swap ;
49 | : 2i swap 1i swap 1i ;
50 | : 3i >r 1i swap 1i swap r> 1i ;
51 | : 4i swap 1i swap 1i 2>r swap 1i swap 1i 2r> ;
52 | : 1pf s>f FPRES f/ ;
53 | : 2pf swap 1pf 1pf ;
54 | : pfloor INT_MASK and ;
55 | : pfrac FRAC_MASK and ;
56 | : pceil #1 - pfloor 1.0 + ;
57 | : 2pfloor pfloor swap pfloor swap ;
58 | : 2pceil pceil swap pceil swap ;
59 | : f>p FPRES f* f>s ;
60 |
61 | wordlist constant fixpointing
62 | : fixed fixpointing +order decimal ; \ assumes no support for fixed point literals
63 | : decimal fixpointing -order decimal ;
64 |
65 | \ NTS: keep these as one-liners, I might make them macros...
66 | fixed definitions
67 | : * ( n n - n ) 1pf s>f f* f>s ;
68 | : / ( n n - n ) swap s>f 1pf f/ f>s ;
69 | : /mod ( n n - r q ) 2dup mod -rot / pfloor ;
70 | : loop s" 1.0 +loop" evaluate ; immediate
71 | previous definitions
72 |
73 | \ Literal helpers
74 | \ : .0 1p ;
75 | \ : .125 1p $200 or ;
76 | \ : .25 1p $400 or ;
77 | \ : .375 1p $600 or ;
78 | \ : .5 1p $800 or ;
79 | \ : .625 1p $a00 or ;
80 | \ : .75 1p $c00 or ;
81 | \ : .875 1p $e00 or ;
82 |
83 | \ External library helpers
84 | : 1af 1pf 1sf ; \ covert a fixed point value to allegro on-stack float
85 | : 2af 1pf 1pf 1sf 1sf ;
86 | : 3af 1pf 1pf 1pf 1sf 1sf 1sf ;
87 | : 4af 1pf 1pf 1pf 1pf 1sf 1sf 1sf 1sf ;
88 |
89 | \ advanced fixed point math
90 | : cos ( deg - n ) 1pf cos f>p ;
91 | : sin ( deg - n ) 1pf sin f>p ;
92 | : asin ( n - deg ) 1pf fasin r>d f>p ;
93 | : acos ( n - deg ) 1pf facos r>d f>p ;
94 | fixed
95 | : lerp ( src dest factor - n ) >r over - r> * + ;
96 | : anglerp ( src dest factor - n )
97 | >r over - 360 mod 540 + 360 mod 180 - r> * + ;
98 |
99 | : sqrt ( n - n ) 1pf fsqrt f>p ;
100 | : tan ( rad - n ) 1pf ftan f>p ;
101 | : atan ( n - n ) 1pf fatan f>p ;
102 | : atan2 ( n n - n ) 2pf fatan2 f>p ;
103 | : log2 ( n - n ) 1e 1pf y*log2(x) f>p ; \ binary logarithm (for fixed-point)
104 | : rescale ( n min1 max1 min2 max2 - n ) \ transform a number from one range to another.
105 | locals| max2 min2 max1 min1 n |
106 | n min1 - max1 min1 - / max2 min2 - * min2 + ;
107 | : >rad 1pf d>r f>p ;
108 |
109 | \ on-stack vector stuff (fixed point specific)
110 | : 2* rot * >r * r> ;
111 | : 2/ rot swap / >r / r> ;
112 | : 2mod rot swap mod >r mod r> ;
113 |
--------------------------------------------------------------------------------
/afkit/README.md:
--------------------------------------------------------------------------------
1 | # README
2 |
3 | AllegroForthKit \(aka AFKit\) is a framework for making games \(and other apps\) in standard Forth using [Allegro 5](www.liballeg.org).
4 |
5 | [Documentation on GitBook](https://rogerlevy.gitbook.io/afkit/v/docs/)
6 |
7 | ## Overview
8 |
9 | The main point of this framework is to bring up a hardware-accelerated graphics window.
10 |
11 | The portable low-level gaming library Allegro 5 powers it. [http://liballeg.org/](http://liballeg.org/)
12 |
13 | [Forth Foundation Library](http://soton.mpeforth.com/flag/ffl/index.html) is included for capabilities often required when working with modern libaries and file formats- features such as XML, Base64, MD5 etc. XML DOM access and Base64 are automatically loaded.
14 |
15 | AFKit is not a comprehensive game development library; it is a cleaned-up version of [Bubble](http://github.com/rogerlevy/bubble/) with fixed-point, Komodo-specific, and game-development-framework files removed and provisions for portability added. For a more complete game development package check out [Ramen](http://github.com/rogerlevy/ramen/).
16 |
17 | ## Cross-platform Support
18 |
19 | ### Currently officially supported platforms:
20 |
21 | * sfwin32 - [SwiftForth](https://www.forth.com/download/) \(Win32\)
22 | * sflinux32 - [SwiftForth](https://www.forth.com/download/) \(Linux\)
23 |
24 | ### Details
25 |
26 | /kitconfig.f specifies compile-time parameters, and loads the appropriate platform config file. That files defines the PLATFORM string, which follows this format: `` For example: sfwin32 = SwiftForth, Windows, 32-bit
27 |
28 | The platform config file creates other compile-time constants and loading platform-specific files such as FFL and Allegro. These files are the appropriate place to put "adapter" definitions or include other optional libraries.
29 |
30 | ## Getting Started
31 |
32 | If you downloaded a release, put it in your project folder.
33 |
34 | Make copies of kitconfig.f _and allegro5.cfg_, removing the underscores.
35 |
36 | Set platform to the appropriate string. See the Cross-platform Support section.
37 |
38 | On Linux, you will need to install Allegro and the addons. As of this writing 5.2 is the latest version.
39 |
40 | ```text
41 | sudo apt-get install liballegro5.2:i386 \
42 | liballegro-acodec5.2:i386 \
43 | liballegro-audio5.2:i386 \
44 | liballegro-dialog5.2:i386 \
45 | liballegro-image5.2:i386 \
46 | liballegro-physfs5.2:i386 \
47 | liballegro-ttf5.2:i386 \
48 | liballegro-video5.2:i386
49 | ```
50 |
51 | ### SwiftForth
52 |
53 | [SwiftForth](https://www.forth.com/download/) is available from [FORTH Inc](http://www.forth.com). The trial is fully functional apart from lacking source code.
54 |
55 | From the SwiftForth prompt, change the current path to the root of your project \(if needed\) and "0 0 0 INCLUDE afkit/afkit.f" or "include afkit/main.f" and type `go` for a simple demonstration.
56 |
57 | ## Audio
58 |
59 | When allegro-audio is defined, audio-allegro.f will be loaded, which reserves 32 samples for playing samples with play\_sample, and a default mixer and voice.
60 |
61 | ## The Piston \(main loop\) - afkit/piston.f
62 |
63 | This is a standard main loop with many features.
64 |
65 | To enter the main loop type GO or just press enter without entering anything. A default program defined in display.f will run. Stop the loop by pressing F12.
66 |
67 | The piston has 3 phases. The event handling phase, the step phase, and the display phase. 3 words are used to tell the loop what to do during these phases. These words have a syntax similar to DOES>.
68 |
69 | * SHOW> sets the display.
70 | * STEP> sets the logic.
71 | * PUMP> sets the event handler.
72 |
73 | ## Links and Resources
74 |
75 | * [Forth: The Hacker's Language on HACKADAY](https://hackaday.com/2017/01/27/forth-the-hackers-language/)
76 | * [Programming Forth by Stephen Pelc](http://www.mpeforth.com/arena/ProgramForth.pdf)
77 | * [Forth Programming 21st Century on Facebook](https://www.facebook.com/groups/PROGRAMMINGFORTH/) - The current active and growing forum on the web for modern desktop Forth programming \(as opposed to on embedded or classic computers.\)
78 | * [Allegro 5.2.3 Documentation](http://liballeg.org/a5docs/5.2.3/)
79 | * [Allegro.cc forum](https://www.allegro.cc/forums) - A very helpful and fairly active community. And gladly, language-agnostic.
80 | * [The DPANS94 Forth Standard](http://dl.forth.com/sitedocs/dpans94.pdf)
81 |
82 |
--------------------------------------------------------------------------------
/afkit/dep/allegro5/allegro5_03_keys.f:
--------------------------------------------------------------------------------
1 | decimal \ important
2 |
3 | #define 1
4 | #define 2
5 | #define 3
6 | #define 4
7 | #define 5
8 | #define 6
9 | #define 7
10 | #define 8
11 | #define 9
12 | #define 10
13 | #define 11
14 | #define 12
15 | #define 13
16 | #define 14
17 | #define 15
18 | #define 16
19 | #define 17
20 | #define 18
21 | #define 19
22 | #define 20
23 | #define 21
24 | #define 22
25 | #define 23
26 | #define 24
27 | #define 25
28 | #define 26
29 |
30 | #define <0> 27
31 | #define <1> 28
32 | #define <2> 29
33 | #define <3> 30
34 | #define <4> 31
35 | #define <5> 32
36 | #define <6> 33
37 | #define <7> 34
38 | #define <8> 35
39 | #define <9> 36
40 |
41 | #define 37
42 | #define 38
43 | #define 39
44 | #define 40
45 | #define 41
46 | #define 42
47 | #define 43
48 | #define 44
49 | #define 45
50 | #define 46
51 |
52 | #define 47
53 | #define 48
54 | #define 49
55 | #define 50
56 | #define 51
57 | #define 52
58 | #define 53
59 | #define 54
60 | #define 55
61 | #define 56
62 | #define 57
63 | #define 58
64 |
65 | #define 59
66 | constant
67 | #define 60
68 | constant <`>
69 | constant <~>
70 | #define 61
71 | constant <->
72 | #define 62
73 | constant <=>
74 | constant <+>
75 | #define 63
76 | constant
77 | #define 64
78 | #define 65
79 | constant <[>
80 | #define 66
81 | constant <]>
82 | #define 67
83 | #define 68
84 | constant <;>
85 | #define 69
86 | constant <'>
87 | #define 70
88 | constant <\>
89 | #define 71 /* DirectInput calls this DIK_OEM_102: "< > | on UK/Germany keyboards" */
90 | #define 72
91 | constant <,>
92 | #define 73
93 | constant <.>
94 | #define 74
95 | constant
96 | #define 75
97 |
98 | #define 76
99 | constant
100 | #define 77
101 | constant
102 | #define 78
103 | #define 79
104 | #define 80
105 | #define 81
106 | #define 82
107 | #define 83
108 | #define 84
109 | #define 85
110 |
111 | #define 86
112 | #define 87
113 | #define 88
114 | #define 89
115 | #define 90
116 | #define 91
117 |
118 | #define 92
119 | #define 93
120 |
121 | #define 94
122 | #define 95
123 | #define 96
124 | #define 97
125 | #define 98
126 | #define 99
127 | #define 100
128 | #define 101
129 | #define 102
130 |
131 | #define 103 /* MacOS X */
132 | #define 104 /* MacOS X */
133 | #define 105 /* MacOS X -- TODO: ask lillo what this should be */
134 | #define 106 /* MacOS X */
135 | #define 107
136 |
137 | \ /* All codes up to before #define 215
143 | #define 216
144 | #define 217
145 | #define 218
146 | #define 219
147 | #define 220
148 | #define 221
149 | #define 222
150 | #define