From RevaWiki
Index: examples/caravan.f
===================================================================
RCS file: /vservers/ronwareo/cvs/reva/examples/caravan.f,v
retrieving revision 1.6
diff -d -u -w -r1.6 caravan.f
--- examples/caravan.f 12 Oct 2006 16:29:33 -0000 1.6
+++ examples/caravan.f 24 Oct 2006 20:39:22 -0000
@@ -4,22 +4,17 @@
macro
: 1if p: 1- p: 0if ;
- : 2if p: 1- p: 1if ;
- : 3if p: 1- p: 2if ;
forth
alias: ]; }cb
alias: :[ cb{
-alias: 0;; 0; | picky editor...
-alias: 00;; 00;
alias: of caseof
alias: >< between
alias: stack stack:
alias: list variable
-alias: const constant
alias: context context:
-: ver " Caravan 0.12 - a Roguelike Adventure- by macoln" ;
+: ver " Caravan 0.13 - a Roguelike Adventure- by macoln" ;
| •••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••
|
| ££££££££ £ £££££££ £ ££££ £££ £ £ ££££
@@ -62,9 +57,10 @@
context ~caravan
~caravan
-defer act defer cave-alg defer europe defer meander defer meander?
-defer north-alg defer polar-alg defer river-alg defer road-alg defer room-alg
-defer scatter-alg defer shave-alg defer south-alg
+defer act defer colours
+defer cave-alg defer europe defer meander defer meander?
+defer north-alg defer polar-alg defer river-alg defer road-alg
+defer room-alg defer scatter-alg defer shave-alg defer south-alg
: array ( size <name> -- does: a) | create an array
create cells
@@ -78,7 +74,7 @@
| dup allocate dup , swap 0 fill | and fill with zero's
| does> @ ;
- 47 value Y ( >47 causes europe to crash) | map length
+ 46 value Y ( >47 causes europe to crash) | map length
79 value X | map width
5 value Z | layers: 4-actor 3-ground 2-items 1-terrain 0-hidden
@@ -93,33 +89,70 @@
0 value keypress | last key or direction input
0 value thiswater | ascii value of current stream or river
- list census | all in-game people
- list structures | all in-game structures
+ variable in-map? | check if we've exited map
+ list census | all people
+ list structures | all structures
+ list usables | all usable objects
+ list events | all objects that trigger events
| •••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••
| £££ £££ £££ £ ££
| £ £ £ £ £ £ £
| £ £££ £££ £££ ££
| •••••••••••••••••••
-: ++_ inline{ ff 06 } ; : 2+ 1+ 1+ ; : 2- 1- 1- ; : .# (.) type ;
+: 2+ 1+ 1+ ; : 2- 1- 1- ; : .# (.) type ; : ++_ inline{ ff 06 } ;
variable st
: .stack | print contents of data stack to screen
0 Y 3 + st @ + gotoxy st @ .# ." ." .s st ++ ;
-: >x x push ; : x> x pop ; : x@ x peek ; : xdrop x> drop ;
-: xflush ( --)
- x stack-empty? not 0;; drop xdrop xflush ;
+: >x x push ; : x> x pop ; : x@ x peek ; : xdrop x> drop ; : .x ['] . x stack-iterate ;
+: xreset ( --)
+ x stack-empty? not 0; drop xdrop xreset ;
: xyz>a ( x y z -- a) | given x y z, get a in 2-byte array
X Z * rot * + swap Z * + cells map + ;
: a>xyz ( a -- x y z) | now the opposite
map - 1 cells / X Z * /mod swap Z /mod -rot ;
: ?execute ( xt-c | 0 -- c | 0)
dup if execute then ;
-: true; ( n --) | if true, exit a word from inside a loop
- true =if unloop rdrop then ;
+: count-nodes ( list -- n)
+ 0 :[ ++_ ]; rot iterate ;
+: get-node ( a -- a-node)
+ cell- @ ;
+: in-list? ( n list -- t)
+ over 0drop; drop
+ :[ @ over xor dup 0if nip dup then ]; swap iterate not ;
+: print-list ( list --)
+ :[ @ dup 2dup colours emit normal . ]; swap iterate ;
+: all ( list -- list node n node n...) | return all nodes and data in list
+ temp off
+ dup dup @ | start with top node
+ :[ dup @ @ | fetch data
+ swap get-node | go back one and fetch node address
+ temp ++ true ]; | keep a count of the # of nodes for sort
+ rot iterate drop ;
+: sort ( node n node n... -- node-max n-max...node-min n-min)
+ temp @ 0do
+ remains 0do | pass through data
+ 0 pick 3 pick <if | leaving largest on stack
+ >x >x | while moving
+ else | all lesser
+ rot >x rot >x | to aux stack
+ then
+ loop
+ remains 0do | now output all
+ x> x> | lesser
+ loop
+ loop ; | for the next pass
+: relink ( list node-max n-max...node-min n-min --)
+ drop 0 over !
+ temp @ 1 ?do
+ 2 pick !
+ drop
+ loop
+ swap ! ;
: center ( u -- )
X over - 2/ abs 1- Y gotoxy space ;
-: clearline ( n --) | clear n+1 lines on the screen
+: clear-line ( n --) | clear n+1 lines on the screen
0do 0 Y i + gotoxy X normal spaces loop ;
: msg) ( n --) | place cursor n lines below the map
0 Y rot + gotoxy ;
@@ -148,11 +181,11 @@
: tracks@ ( -- x y) tracks 2@ ;
: 0tracks ( --) 0 0 tracks! ;
-: (map) parsews >single 0;; drop 2, (map) ;
+: (map) parsews >single 0; drop 2, (map) ;
: map[ ( <bytes> <]> --) | inline data of 2-bytes max
16 base xchg (map) 2drop base ! ;
- 0 const hidden 1 const terrain 2 const item 3 const ground 4 const above
+ 0 constant hidden 1 constant terrain 2 constant item 3 constant ground 4 constant above
: >layer ( a n | x y z n -- a') | no matter if input is a ptr or 3-D coord,
swap dup Z >if a>xyz then drop rot xyz>a ; | convert to specified map layer
: >above above >layer ;
@@ -295,17 +328,17 @@
| ... orchard, vineyard...
| occupations
- 133 const archer 134 const cavalry 168 const corpse 570 const foot
- '@ const hero 'h const highwayman 143 const knight 'm const merchant
- 7 const actor 131 const scout 160 const slinger 132 const spearman
- 142 const swordsman
+ 133 constant archer 134 constant cavalry 168 constant corpse 570 constant foot
+ '@ constant hero 'h constant highwayman 143 constant knight 'm constant merchant
+ 7 constant actor 131 constant scout 160 constant slinger 132 constant spearman
+ 142 constant swordsman
| races
- 1000 const Petcheneg 1001 const Varangian 1002 const Celt 1003 const German
- 1004 const Frank 1005 const Magyar 1006 const Jew 1007 const Turk
- 1008 const Hindu 1009 const Persian 1010 const Byzantine 1011 const Moor
- 1012 const Arab 1013 const Slav
+ 1000 constant Petcheneg 1001 constant Varangian 1002 constant Celt 1003 constant German
+ 1004 constant Frank 1005 constant Magyar 1006 constant Jew 1007 constant Turk
+ 1008 constant Hindu 1009 constant Persian 1010 constant Byzantine 1011 constant Moor
+ 1012 constant Arab 1013 constant Slav
| misc
- 235 const bomb 15 const snowflake 46 const blood1 505 const blood2
+ 235 constant bomb 15 constant snowflake 46 constant blood1 505 constant blood2
: blood red 2 rand 0if blood1 ;then blood2 ;
: traveler? ( c -- t)
@@ -329,7 +362,7 @@
drop
endcase ;
-: colours ( c --)
+:: ( c --)
case
brick of 2grey endof bridge of white endof bleaf of 2green endof
blood1 of red endof blood2 of red endof conifer of green endof
@@ -351,8 +384,9 @@
Arab of lemon endof Slav of pearl endof
drop grey
endcase ;
+is colours
-: backgrounds
+: Bgcolours
case
ice of onIce endof river of onBlue endof sand of onbYellow endof
snow of onSnow endof swamp of onGreen endof water of onBlue endof
@@ -382,7 +416,7 @@
: colour ( a --)
dup w@ actor? if ( a) | is it hero/npc/animal? if so
dup >terrain w@ ( a c-terrain) | fetch that square's terrain
- filter backgrounds ( a) | and colour the background.
+ filter Bgcolours ( a) | and colour the background.
w@ census fetch race ( a-race) | get the npc's race, or if hero, state
then
w@ filter colours ; | else/then colour the foreground
@@ -452,22 +486,22 @@
: E) dup E 1 0 ; : SE) dup SE 1 1 ; | dup and x+ y+ is for bounds check
: S) dup S 0 1 ; : SW) dup SW -1 1 ;
: W) dup W -1 0 ; : NW) dup NW -1 -1 ;
-: err .border " Eh?" msg ; : err2 err false ;
+: err .border " Eh?" msg ;
: Quit
" Retire? (y/n)" lemon msg ekey 'y =if
- " Farewell..." msg drop 500 ms cls bye
+ " Farewell..." msg .stack 2000 ms cls bye
;then .border ;
: bump ( a' c --)
- 2drop true ;
+ 2drop ;
-: shut ( a-xyz a-layer -- t)
+: shut ( a-xyz a-layer --)
nip " The door shuts." ?msg
- dup door+ swap w! .square true ;
-: lock ( a-xyz a-layer -- t)
+ dup door+ swap w! .square ;
+: lock ( a-xyz a-layer --)
nip " It's now locked." ?msg
- dup door++ swap w! .square true ;
-: ?unlock ( a-xyz a-layer -- t)
+ dup door++ swap w! .square ;
+: ?unlock ( a-xyz a-layer --)
dup w@ ( a-xyz a-layer c)
case
door++ of door/ 10 endof door+++ of door/ 20 endof
@@ -478,20 +512,23 @@
me skill roll <if ( a-xyz a-layer c')
over w! .square
" Deftly freed." ?msg
- drop true
+ drop
;then
- " Won't budge." ?msg 3drop true ;
+ " Won't budge." ?msg 3drop ;
-: directions ( a-xyz k --)
+: ?direction ( a-xyz k --)
case
33 of NE endof 34 of SE endof 35 of SW endof 36 of NW endof
37 of W endof 38 of N endof 39 of E endof 40 of S endof
'p of NE endof '/ of SE endof ', of SW endof 'i of NW endof
'k of W endof 'o of N endof '; of E endof '. of S endof
- drop err2
+ drop err
endcase ;
-: usables ( a-xyz a-layer c-layer -- t)
+ door/ usables link door+ usables link door++ usables link door+++ usables link
+ door++++ usables link window+ usables link window/ usables link
+
+: use) ( a-xyz a-layer c-layer --)
case
door/ of shut endof door+ of lock endof door++ of ?unlock endof
door+++ of ?unlock endof door++++ of ?unlock endof window+ of ?unlock endof
@@ -499,36 +536,24 @@
drop
endcase ;
-: ?usable ( a-loc --)
+: ?usable ( a-xyz --)
Z 0do | for every layer in that square
- dup remains 1- >layer dup w@ filter ( a-me a-layer c-layer)
- usables true; | find any usable objects
+ dup remains 1- >layer dup w@ filter ( a-xyz a-layer c-layer)
+ dup usables in-list? if use) unloop ;then | find any usable objects
+ 2drop
loop drop " He clutches at the air." ?msg ; | else give the fool's message
-: use ( a-loc --)
+: use ( --)
+ me location xyz>a ( a-xyz)
" Where?" ?msg | computer is dumb, so player
- ekey directions 0;; | must specify what he wants to use
+ ekey ?direction 0; | must specify where he wants to use
?usable ;
-: actions ( a-loc k --)
- case
- 0 of N) endof 1 of NE) endof 2 of E) endof 3 of SE) endof
- 4 of S) endof 5 of SW) endof 6 of W) endof 7 of NW) endof
- 12 of drop endof
- 33 of NE) endof 34 of SE) endof 35 of SW) endof 36 of NW) endof
- 37 of W) endof 38 of N) endof 39 of E) endof 40 of S) endof
- 'l of drop endof
- 'p of NE) endof '/ of SE) endof ', of SW) endof 'i of NW) endof
- 'k of W) endof 'o of N) endof '; of E) endof '. of S) endof
- 'Q of Quit endof 'u of use endof
- drop err
- endcase ;
-
-: movekey? ( k -- t)
+: move-key? ( k -- t)
dup >r 0 7 >< r@ 33 40 >< or r@ ', = or r@ '. '/ >< or
r@ '; = or r@ 'i = or r@ 'k = or r> 'o 'p >< or ;
-: validkey? ( k -- t)
- dup >r movekey? r@ 12 = or r@ 'l = or r@ 'Q = or r> 'u = or ;
+: valid-key? ( k -- t)
+ dup >r move-key? r@ 12 = or r@ 'l = or r@ 'Q = or r> 'u = or ;
: wipe ( a-me --)
location xyz>a dup ( a-xyz a-xyz) | get previous location (now vacated square)
@@ -549,7 +574,7 @@
then then | and
r> a>xyz drop gotoxy emit normal ; | print to screen
-: moveok ( a'--)
+: move-ok ( a'--)
me dup >r w@ over w! ( a') | store actor glyph to map square
dup .square ( a') | print to screen
r@ wipe ( a') | reprint contents of last location
@@ -557,22 +582,14 @@
r@ +leagues r> -energy ; | incr turns and leagues, decr energy
: ?boat ( a'c --)
- 2drop " The sea waves." ?msg true ;
+ 2drop " The sea waves." ?msg ;
-: ?climb ( a'c -- t)
+: ?climb ( a'c --)
2 rand 0if
- drop moveok
+ drop move-ok
" He clambers over." ?msg 250 ms
- keypress act drop true
- ;then 2drop " It's too high!" ?msg true ;
-
-: .redraw ( x y --)
- 2dup 0 xyz>a >r
- swap 15 + swap Z xyz>a r> do | beginning at the input coordinates
- i dup w@ if i .square then | if the square is non-zero, colour and print.
- S w@ if i S .square then
- 1 cells skip
- loop ;
+ keypress act
+ ;then 2drop " It's too high!" ?msg ;
: say-x ( u -- x)
dup 2/
@@ -587,36 +604,39 @@
x> x> x> 2dup 0 xyz>a >r ( u x y)
swap rot + swap Z xyz>a r> do
i w@ if i .square then
- 1 cells skip
+ 1 cells 1- skip
loop
then ;
-: ?combat ( a'c -- t)
+: ?combat ( a'c --)
dup traveler? if
census fetch skill roll me skill roll <if ( a')
blood swap >item w!
" The foe is vanquished." ?msg
- true
;then
drop
blood me location xyz>a >item w!
" Beaten..." ?msg
- true
;then
- 2drop " \"Sorry\"" .say true ;
+ 2drop " \"Sorry\"" .say ;
| Conversations eat up turns, as to advance dialog one must press 'stay' key.
| Indicate speaker has more to say with > symbol.
-: locked ( a' c -- t)
- 2drop " Seems to be locked." ?msg true ;
+: locked ( a' c --)
+ 2drop " Seems to be locked." ?msg ;
-: open ( a' c -- t)
- drop >terrain door/ over w! .square true ;
+: open ( a' c --)
+ drop >terrain door/ over w! .square ;
-: ?swim ( a' c -- t)
- 2drop " He seems unsure of the water." ?msg true ;
+: ?swim ( a' c --)
+ 2drop " He seems unsure of the water." ?msg ;
-: events ( a' c c -- t)
+ ocean events link brick events link stone events link window/ events link
+ fence events link door+ events link door++ events link door+++ events link
+ door++++ events link window+ events link river events link water events link
+ actor events link
+
+: event) ( a' c c --)
case
ocean of ?boat endof brick of bump endof stone of bump endof
window/ of ?climb endof fence of ?climb endof door+ of open endof
@@ -628,10 +648,12 @@
: ?event ( a' --)
Z 0do
- dup remains >layer w@ filter dup ( a' c c) | check all the square's layers
- dup actor? if drop actor then | (actor's converted to universal ID)
- events true; | trigger any events, exit if true flag is returned
- loop moveok ; | otherwise move there
+ dup remains >layer w@ filter ( a'c) | check all the square's layers
+ dup actor? if drop actor then | (actors converted to universal ID)
+ dup events in-list? if
+ dup event) unloop | trigger any events
+ ;then drop
+ loop move-ok ; | otherwise move there
: outbounds? ( x y -- t)
over 0 < >r | did we pass the left edge?
@@ -644,20 +666,28 @@
>r rot a>xyz drop r> + >r + r> | add proposed x+ y+ to current xyz
outbounds? not ; | test, return opposite truth val
-: t-act ( c a n -- c a't | t)
- dup to keypress actions ( c a a'x+ y+) | process act
- inbounds? if ( c a') | are we still inside the map?
- dup a>xyz drop tracks! true ( c a't) | if so, update tracks and exit, continuing loop
- ;then 2drop false ; | else drop everything and stop loop
+: move ( xt-direction --)
+ me location xyz>a | fetch actor's current location
+ swap execute | process directional move
+ inbounds? if ?event ;then | if still inbounds, check for events in that square
+ me player =if drop in-map? off ;then | else we passed edge, so if hero, exit
+ drop ; | else we're an npc so stop at the edge
-:: ( k | n -- t)
- dup to keypress ( k) | save keypress for later
- me location xyz>a swap ( a-loc k) | get current actor's location address
- actions ( a-me a' x+ y+ | ???) | process action
- keypress movekey? 0if true ;then | if move key wasn't pressed, continue play
- inbounds? if ?event true ;then | else if still inside map, check square for events
- me player =if drop false false ;then | else we passed edge, so if hero, exit
- drop true ; | else we're an npc so stop at the edge
+:: ( k --)
+ dup to keypress
+ case
+ 0 of ['] N) move endof 1 of ['] NE) move endof 2 of ['] E) move endof
+ 3 of ['] SE) move endof 4 of ['] S) move endof 5 of ['] SW) move endof
+ 6 of ['] W) move endof 7 of ['] NW) move endof
+ 33 of ['] NE) move endof 34 of ['] SE) move endof 35 of ['] SW) move endof
+ 36 of ['] NW) move endof 37 of ['] W) move endof 38 of ['] N) move endof
+ 39 of ['] E) move endof 40 of ['] S) move endof 12 of noop endof
+ 'p of ['] NE) move endof '/ of ['] SE) move endof ', of ['] SW) move endof
+ 'i of ['] NW) move endof 'k of ['] W) move endof 'o of ['] N) move endof
+ '; of ['] E) move endof '. of ['] S) move endof 'l of noop endof
+ 'Q of Quit endof 'u of use endof
+ drop err
+ endcase ;
is act
| •••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••
@@ -666,6 +696,21 @@
| ££ £ \ £ £ £££
| •••••••••••••••
+: advance ( a-xyz k --)
+ dup to keypress
+ case
+ 0 of N) endof 1 of NE) endof 2 of E) endof 3 of SE) endof
+ 4 of S) endof 5 of SW) endof 6 of W) endof 7 of NW) endof
+ drop err
+ endcase ;
+
+: advance-terrain ( c a n -- c a't | t)
+ advance ( c a a'x+ y+) | advance to next square
+ inbounds? if ( c a') | are we still inside the map?
+ dup a>xyz drop tracks! true ( c a't) | if so, update tracks and exit, continuing loop
+ ;then 2drop false ; | else drop everything and stop loop
+
+
: .test dup .square ;
:: ( xt-c --)
@@ -680,7 +725,7 @@
| .test
tracks@ nip
Y 8 / <if 6 rand 2+ else 8 rand then | > 1/8 from top? E SE S SW W NW, else any
- t-act
+ advance-terrain
while ;
is cave-alg
@@ -695,7 +740,7 @@
Y 7 / <if drop 6 rand 1+ else | < 1/7 from top? NE E SE S SW W
Y 2/ >if 4 rand else 8 rand | > 1/2 from top? N NE E SE, else any
then then
- t-act
+ advance-terrain
while ;
is north-alg
@@ -714,7 +759,7 @@
else | else,
2 rand | N NE
then then then
- t-act
+ advance-terrain
while ;
is polar-alg
@@ -765,7 +810,7 @@
else
4 rand | or mostly N NE E SE
then then
- t-act
+ advance-terrain
while
undo meander undo meander? ;
is river-alg
@@ -773,15 +818,15 @@
: buildbridge ( a --)
bridge over w!
| .test
- keypress t-act ; | draw across last given direction
+ keypress advance-terrain ; | draw across last given direction
: ?bridge ( xt-c a c-terrain c-water -- c a)
=if | if it's water,
repeat
- buildbridge 00;; drop | build a bridge square
+ buildbridge 00; drop | build a bridge square
dup w@ filter water = | as many times as there are water squares
while
- buildbridge 00;; drop | plus one for good measure
+ buildbridge 00; drop | plus one for good measure
bridge over w!
| .test
else | otherwise,
@@ -791,7 +836,7 @@
2dup ?thicken ; | double-sized if we're inworld
:: ( xt-c --)
- 4 rand dup >x 3if | prepare direction offset, is it 3? if so,
+ 4 rand dup >x 3 =if | prepare direction offset, is it 3? if so,
X 1- Y rand | start somewhere at the right edge
else | otherwise
0 Y rand | somewhere at the left edge
@@ -802,7 +847,7 @@
ocean =if | is it an ocean? if so,
3drop | quit blazing.
;then
- filter water ?bridge 0;; | water? build bridge, else build road
+ filter water ?bridge 0; | water? build bridge, else build road
3 rand x@ dup 1if
2 rand 0if
+
@@ -810,13 +855,13 @@
2drop keypress
then | roll an overriding set of directions
else
- dup 3if
+ dup 3 =if
nip 4 rand 1+ +
else
+
then
then
- t-act
+ advance-terrain
while ;
is road-alg
@@ -841,7 +886,7 @@
0 ?do
N 2dup etch
loop
- 2drop 2 t-act
+ 2drop 2 advance-terrain
while ;
is shave-alg
@@ -858,7 +903,7 @@
else
8 rand | else, any direction
then
- t-act
+ advance-terrain
while ;
is south-alg
@@ -910,7 +955,7 @@
-1 +to long -1 +to wide
then false ;
-: ?tryagain ( a1 x'y't --)
+: ?retry ( a1 x'y't -- t)
if 3drop impossible? | check if we ain't beating a dead horse
if 2drop false ;then
room-alg false | before trying another start square
@@ -969,16 +1014,13 @@
| 2dup gotoxy red bold 177 emit 200 ms normal
terrain xyz>a ( ...a1) | calculate corresponding address in array
measure ( ...a1 x'y') | add wide and long to x y
- 2dup outabounds? ?tryagain 0;; | if outside the map, start over
- 2 pick obstacle? ?tryagain 0;; ( ...a1 x'y') | if on an obstacle, start over
+ 2dup outabounds? ?retry 0; | if outside the map, start over
+ 2 pick obstacle? ?retry 0; ( ...a1 x'y') | if on an obstacle, start over
terrain xyz>a NW ( ...a1 a2) | otherwise calculate address
walls doors windows floor | build it
- 3drop xflush ; | clean up
+ 3drop xreset ; | clean up
is room-alg
-: .walls ( --)
- ['] . x stack-iterate ;
-
| •••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••
| £££ £ £££
| £|£ £_£ £_£
@@ -1135,11 +1177,11 @@
: mapsize ( -- n)
X Y Z * * cells ; | note reverse polish notation
-: fillmap ( xt-c | 0 --)
+: fill-map ( xt-c | 0 --)
| " filling..." msg
0 0 terrain xyz>a dup mapsize + swap do | for every terrain square in the map
dup ?execute i w! | store fill character
- Z cells skip
+ Z cells 1- skip
loop drop ;
: 0map ( --)
@@ -1151,7 +1193,7 @@
: blaze ( xt-c xt-alg --)
| " drawing..." msg
execute | process the algorithm at xt-alg
- 0tracks temp off xflush
+ 0tracks temp off xreset
| stack) off | reset for next time
;
@@ -1161,10 +1203,9 @@
i w@ if | if the square is non-zero,
i .square | colour and print.
then | otherwise
- 1 cells skip | (try the next layer/square)
+ 1 cells 1- skip | (try the next layer/square)
loop cr ;
-| ** TODO: map array should only contain terrain and footprints, everything else is printed
-| by iterating over a linked list of actors, items and hidden objects.
+
: terrain: ( xt -- )
create , does> ( n-limit a --)
swap 0 ?do ( a)
@@ -1183,14 +1224,14 @@
: terrain1 ( n --) 0 ?do 11 rand ?terrain1 blaze loop ;
: terrain2 ( n --) 0 ?do 7 rand ?terrain2 blaze loop ;
-: convert ( c -- c')
- case
- 32 of ocean endof 'S of desert endof '= of river endof
- '- of grassl endof '^ of hill endof '> of hill2 endof
- '* of mount endof '& of conifer endof '` of steppe endof
- '% of bleaf endof 'i of ice endof
- ." couldn't find " emit
- endcase ;
+| : convert ( c -- c')
+| case
+| 32 of ocean endof 'S of desert endof '= of river endof
+| '- of grassl endof '^ of hill endof '> of hill2 endof
+| '* of mount endof '& of conifer endof '` of steppe endof
+| '% of bleaf endof 'i of ice endof
+| ." couldn't find " emit
+| endcase ;
: inline>map ( a-inline-map --)
map dup mapsize +
@@ -1198,11 +1239,11 @@
dup w@ ( a c)
i >terrain w! ( a)
2+ ( a')
- Z cells skip
+ Z cells 1- skip
loop drop ;
: outworld ( --)
- ['] ocean fillmap
+ ['] ocean fill-map
1 icecaps 26 terrain1 1 icecaps 12 rivers
['] ocean shave-alg ;
@@ -1215,12 +1256,12 @@
4 rand streams 1 lakes 3 rand roads
4 rand pens 7 rand stonehouses 9 rand brickhouses ;
-: randworld ( --)
+: rand-world ( --)
9 rand
dup 0if drop europe inline>map ;then
dup 1if drop outworld ;then
2 5 >< if ['] grass else ['] prairie then
- fillmap inworld ;
+ fill-map inworld ;
| •••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••
| £££ £ £ £ £
@@ -1228,15 +1269,15 @@
| £ £££ £ £ £
| ••••••••••••••
-: getkey ( -- key)
+: get-key ( -- k)
repeat
0 Y gotoxy 40 ms key? not | wait until a key is pressed
while
ekey
.border
?say-wipe | clear any messages or speech
- dup validkey? 0if | if invalid key
- drop err getkey | wait until a key is pressed
+ dup valid-key? 0if | if invalid key
+ drop err get-key | wait until a key is pressed
then ;
: obstacles? ( c -- t)
@@ -1244,8 +1285,8 @@
door++ r@ = or door+++ r@ = or door++++ r@ = or window+ r> = or ;
: unique ( n -- n | n')
- :[ @ w@ over <> dup 00;; drop ]; census iterate ( n 0 0 | n -1 -1)
- dup not 0;; 2drop 256 + unique ;
+ :[ @ w@ over <> dup 00; drop ]; census iterate ( n 0 0 | n -1 -1)
+ dup not 0; 2drop 256 + unique ;
: .people ( list --)
:[ @ w@ . space true ]; census iterate cr ;
@@ -1253,20 +1294,20 @@
: populate ( list --)
:[ @ dup w@ swap location xyz>a w! true ]; swap iterate ;
-: randjob ( -- glyph)
+: rand-job ( -- glyph)
254 rand 1+ dup npc? 0if | roll any glyph, but if it's a non-npc one
- drop randjob | try again
+ drop rand-job | try again
;then | else
unique ; | make sure it's unique
-: randrace ( -- race)
+: rand-race ( -- race)
14 rand 1000 + ;
-: randxyz ( -- x y z)
+: rand-xyz ( -- x y z)
X rand Y rand
2dup terrain xyz>a w@ filter ( x y c) | roll a random location, fetch terrain there
obstacles? if ( x y) | if there's an obstacle
- 2drop randxyz | try again
+ 2drop rand-xyz | try again
;then | else,
above ;
@@ -1274,9 +1315,9 @@
255 dup allocate dup >r
swap 0 fill | fill with zero's
r@ census link | add to census list
- randjob dup r@ w! | store glyph
- randrace r@ race w! | roll random race, store
- randxyz r@ xyz! | roll random xyz, store
+ rand-job dup r@ w! | store glyph
+ rand-race r@ race w! | roll random race, store
+ rand-xyz r@ xyz! | roll random xyz, store
10 r@ energy c! | store 10 energy points
traveler?
if | able to venture beyond home?
@@ -1288,51 +1329,15 @@
: people ( n --)
0 ?do person loop ;
-: getnode ( a -- a-node)
- cell- @ ;
-
-: getinit ( a -- n)
+: get-init ( a -- n)
@ init roll ;
: init-rolls ( list -- list node n node n...) | return all nodes and init rolls in list
temp off
dup dup @
- :[ dup getinit swap getnode temp ++ true ]; rot iterate
+ :[ dup get-init swap get-node temp ++ true ]; rot iterate
drop ;
-: all ( list -- list node n node n...) | return all nodes and data in list
- temp off
- dup dup @ | start with top node
- :[ dup @ @ | fetch data
- swap getnode | go back one and fetch node address
- temp ++ true ]; | keep a count of the # of nodes for sort
- rot iterate drop ;
-
-: nodecount ( list -- n)
- 0 :[ ++_ ]; rot iterate ;
-
-: sort ( node n node n... -- node-max n-max...node-min n-min)
- temp @ 0do
- remains 0do | pass through data
- 0 pick 3 pick <if | leaving largest on stack
- >x >x | while moving
- else | all lesser
- rot >x rot >x | to aux stack
- then
- loop
- remains 0do | now output all
- x> x> | lesser
- loop
- loop ; | for the next pass
-
-: relink ( list node-max n-max...node-min n-min --)
- drop 0 over !
- temp @ 1 ?do
- 2 pick !
- drop
- loop
- swap ! ;
-
: turns ( -- list node n node n...)
census init-rolls ;
@@ -1344,20 +1349,22 @@
| :[ @ dup init roll rot 2dup >if drop rot drop else nip nip then true ];
| census iterate drop ;
-: 1-round ( -- t | t false)
+: 1-round ( -- t)
@ dup to me
- player =if getkey else 8 rand then | get key input, else npc's move at random
+ player =if get-key else 8 rand then | get key input, else npc's move at random
| .info | print info
me +turns | increment turns
- act dup 0if temp off then ; | process actor's action
+ act | process actor's action
+ in-map? @ ;
-: GO! ( -- | t)
- temp on
+: GO! ( --)
+ in-map? on
turns queue
['] 1-round census iterate
- temp @ 0;; drop GO! ;
+ in-map? @ 0; drop | unless hero exits map,
+ GO! ; | actors continue taking turns
-: nextxyz ( a-me --) | calculate new position after exiting map edge
+: next-xyz ( a-me --) | calculate new position after exiting map edge
dup wipe
dup location drop ( a-me x y )
dup 0if drop Y 1- else dup Y 1- =if drop 0 then then swap
@@ -1368,14 +1375,11 @@
noop ;
: play ( --)
-
- cls cr ver type cr
- ." to generate terrain, type " aqua ." randworld .map" cr normal
- 9 spaces ." to explore, type " aqua ." play" cr normal
- 1500 ms
+ cr ver type cr
+ 1000 ms
.menu | display menu
- randworld | below a random map
+ rand-world | below a random map
?name
outworld? 0if | if not in outworld,
1 people | generate people
@@ -1384,12 +1388,12 @@
GO! | hero and npc's take turns moving around
| until hero passes map edge
- player nextxyz | calculate next position for hero
+ player next-xyz | calculate next position for hero
0map | clean up
play ; | play again...
: test) cls
- 0map ['] grass fillmap .map
+ 0map ['] grass fill-map .map
" streams" msg 3 streams .map
" roads" msg 2 roads .map
" pens" msg 4 pens .map
@@ -1398,6 +1402,7 @@
" display..." msg .map ;
: test ['] test) bench ;
+
| code to make executable: change '1' to '0' below:
with~ ~sys
' play is appstart
@@ -1407,6 +1412,11 @@
" caravan" makeexename (save) bye
[THEN]
+| ** TODO **
+| map array should only contain terrain and footprints, everything else is printed
+| by iterating over a linked list of actors, items and hidden objects
+
+
| •••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••
| ££ £ £££ £
| £ £ £-£ £ £-£
