diff options
Diffstat (limited to 'adv.f')
| -rwxr-xr-x | adv.f | 779 |
1 files changed, 779 insertions, 0 deletions
diff --git a/adv.f b/adv.f new file mode 100755 index 0000000..e8dc6fe --- /dev/null +++ b/adv.f @@ -0,0 +1,779 @@ +#! /usr/bin/env gforth + +\ adventure game (very WIP) +\ 24 Dec 2023 + +\ no content yet + +\ i plan to try and keep development of this on +\ tilde.town, so i have a reason to come back other +\ than website stuff. + +\ to do: + +\ - add exits and movement + +\ - implement basic actions for movement, examination, object manipulation + +\ - start fleshing out game world with stuff to do + +\ - assemble a... plot? a plotline? a story? gotta have some end goal to +\ work towards, even if it's just something like "find all thirteen +\ ancient artifacts and put them in the museum case! :3" + +\ - polish, polish, polish. ANSI colors, custom display words to allow +\ for screen effects or whatver + +\ - tell people about it? + +( State ) + +variable playing? + +: init playing? on ; +: fini ; + +( Utils ) + +: ], ] postpone literal ; + +( ANSI escape sequences ) + +char 1 constant red +char 2 constant green +char 3 constant yellow +char 4 constant blue +char 5 constant magenta +char 6 constant cyan +char 7 constant white +char 9 constant default +: fg! .\" \x1b[3" emit ." m" ; +: bg! .\" \x1b[4" emit ." m" ; +: norm .\" \x1b[0m" ; +: bold .\" \x1b[1m" ; +: ;bold .\" \x1b[22m" ; + +( Display output ) + +\ carriage returns will cause the next character to +\ be uppercased automatically! very convenient, i +\ think, given how new lines generally comprise new +\ sentences + +variable cap variable capslock variable col +: emwait ; +: crwait ; +: cr cr crwait col off ; +: lower? dup [char] a >= swap [char] z <= and ; +: ?>upper dup lower? if -33 and then ; +variable (pbl) +: emit dup bl = >r 1 col +! dup bl <> (pbl) @ and + col @ 64 >= and r> (pbl) ! if cr then + cap @ if ?>upper cap @ capslock @ and cap ! then emit emwait ; +: type bounds ?do i c@ emit loop ; +: ." postpone s" postpone type ; immediate +: cr cr cap on ; +: space bl emit ; + +\ FIXME: scan for parenthesized bits of code, such that +\ .{ You poke [dob .the].} gets ultimately compiled as +\ S" You poke " TYPE DOB .THE S" ." TYPE +char [ constant lesc +char ] constant resc +: /scan >r over swap r> scan drop over - ; +\ feels inefficient -- probably a better way +: {...} begin 2dup lesc scan nip while + 2dup lesc /scan tuck postpone sliteral postpone type + 1+ /string 2dup resc /scan tuck evaluate + 1+ /string repeat dup 0> + if postpone sliteral postpone type + else 2drop then ; +: .{ postpone cr + begin [char] } parse {...} + tib >in @ 1- + c@ [char] } = ?dup 0= + if postpone space refill 0= then until ; immediate + +( String hashing ) + +: digit? dup [char] 0 >= swap [char] 9 <= and ; + +\ collides deliberately, for entertainment purposes. +\ to calculate max number of letters stored in a single +\ 64-bit cell, we need to solve for x in 26^x = 2^64. +\ which is log26(2^64), which is log(2^64)/log(26), which +\ is a little over thirteen and a half characters. + +\ i could be wrong about all of that btw <3 + +\ considering this is a stupid litle text adventure game, +\ and something like "construction" is only twelve letters +\ long, and really it doesn't matter if things get truncated +\ anyway, i think we're safe. + +\ another way fit for 16-bit systems would be to have a +\ limited vocabulary of words that appear in object names +\ etc., like the old Infocom games did. writing a vocabulary +\ by hand would be boring. i guess i could make a global +\ flag called FLESHVOCAB? or sth, and have it so when set +\ the vocabulary-searching word would add a new vocabulary +\ entry on failure instead of just returning zero. + +\ i'm not gonna do that today! it would be more portable, +\ and mister moore says portability's the devil's business. +\ maybe next time i do something for DOS? that'd be cool. +\ forth feels a good fit for text adventure making on small +\ systems -- 'specially since string parsing words can be +\ user-defined so it'd be really easy to introduce a custom +\ text encoding/compression scheme... + +\ that sounds so cool, now i think of it... + +\ a project for another time! + +\ XOR'ing a letter with 32 will toggle upper and lowercase +: >5bit dup digit? if [char] 0 - else -33 and [char] A - then 1+ ; +: hash ( a u -- n ) 0 -rot bounds do 26 * i c@ >5bit + loop ; +: hash" [char] " parse hash state @ if postpone literal then ; immediate + +( String -> word hashes ) + +create wdbuf 256 allot + +\ hehehe, blch + +: blch? bl <= ; +: andch? dup [char] , = swap [char] & = or ; +: thenc? dup [char] ; = swap [char] . = or ; +: punct? dup andch? swap thenc? or ; +: wdch? dup blch? swap punct? or 0= ; + +: more? ( a u xt -- ) >r over c@ r> execute over 0> and ; +: /bl begin ['] blch? more? while 1 /string repeat ; +: >word wdbuf count + c! wdbuf c@ 1+ wdbuf c! ; + +: punctw ( a u -- a u ) over c@ + dup andch? if drop s" and" exit then + dup thenc? if drop s" then" exit then + drop s" unknown" ; + +\ side effects taste nice! + +: /word ( a u -- a' u' ) /bl 0 wdbuf c! + ['] punct? more? + if punctw wdbuf place 1 /string exit then + begin ['] wdch? more? while + over c@ >word 1 /string repeat ; + +( Chain words ) + +\ basically words which can be modified later to have +\ new bits of code running before or after older versions, +\ stored as a linked list of execution tokens. this makes +\ it easy to, for instance, define the body of a word and +\ then narrow it down with special cases and sanity checks +\ later on down the line. or, in our case here, to define +\ actions simply, and only afterwards specify "can't do +\ that, stupid!" under different conditions. + +variable ;xt variable chcont? variable curch +: ; postpone ; ;xt @ if ;xt @ execute ;xt off then ; immediate +: ch>head ; : ch>tail cell+ ; : ch>next ; : ch>xt cell+ ; +: instead chcont? off ; +: (chain) chcont? @ >r chcont? on ch>head @ + begin dup 0<> chcont? @ and + while dup >r ch>xt @ execute r> ch>next @ + repeat drop r> chcont? ! ; +: ;chain here curch @ 2dup ch>head ! ch>tail ! 0 , , ; +: (:chain) create here curch ! 0 , 0 , does> (chain) ; +: :chain (:chain) ['] ;chain ;xt ! :noname ; +: ch< ch>tail @ ch>next ! ch>tail ! ; +: >ch ch>head @ swap ch>next ! ch>head ! ; +: ;ere here 0 , swap , swap 2dup >ch ; +: ;aft here 0 , swap , swap 2dup ch< ; +: :ere ' >body ['] ;ere ;xt ! :noname ; +: :aft ' >body ['] ;aft ;xt ! :noname ; + +: ?deny{ postpone if postpone .{ postpone instead + postpone exit postpone then ; immediate +: ?or{ postpone 0= postpone ?deny{ ; immediate + +( Actions ) + +\ action buffers are null-terminated, like c strings +\ for ease of iteration etc + +-1 constant argwd +create lastact 0 , +: act>prev ; +: act>proc cell+ ; +: act>buf [ 2 cells ], + ; + +\ i think this is a term real people use? +: glob? 1 = swap c@ [char] * = and ; + +: actwd 2dup glob? if 2drop argwd else hash then ; +: s>act, ( a u -- ) + begin /word wdbuf c@ 0> + while wdbuf count actwd , + repeat 0 , 2drop ; + +\ i love parsing words + +: act: ( xt -- ) >r + begin [char] / parse dup 0> + while here lastact @ , lastact ! r@ , s>act, + repeat 2drop r> drop ; + +( Structures ) + +\ state-smart fields to yield ... efficiency, maybe? +\ in this non-realtime text adventure, throttled by the +\ speed of SSH connections, not the FORTH program? +\ at the cost of filling SEE with magic numbers? +\ that part's kinda funny, so i'm keeping it. + +\ opaque byte offsets, fuck yeah + +\ in a native code forth you could have FIELD directly +\ compile an inline addition instruction, even w/o a +\ peephole optimizer to that kinda thing automatically +\ -- just poke opcodes right into fuckin memory, hell +\ yeah. + +\ this is for gforth, though, which is lame and boring +\ and traditional and Good Enough + +: :recd create here 0 , 0 does> @ ; +: field create immediate over , + does> @ + state @ if postpone literal postpone + else + then ; +: enum dup constant 1+ ; +: recd; swap ! ; + +( Exits ) + +:recd exits + enum north + enum northeast + enum east + enum southeast + enum south + enum southwest + enum west + enum northwest + enum up + enum down +recd; + +create oppotbl south , southwest , west , northwest , +north , northeast , east , southeast , down , up , +: opposite cells oppotbl + @ ; + +( Game objects ) + +:recd gob + cell field >last + cell field >flags + cell field >rel + cell field >env + cell field >inv \ latest child object + cell field >pob \ previous sibling + cell field >nob \ next sibling +exits cells field >exits + 0 field >name +recd; +: >keys >name count + ; \ name hash, null-terminated, count-preceded +: >desc >keys count 1+ cells + ; +: >exit cells + >exits ; + +: zallot here over 0 fill allot ; + +variable desc# +variable curob + +\ gob zallot! gob zallot! +\ sounds like a magic spell + +: id: create here gob zallot curob @ over >last ! curob ! ; +: desc, dup desc# +! 0 do count c, loop drop ; +: ?desc, dup 0> if desc, else 2drop then ; +: keys, curob @ >name count here >r 0 c, + begin /word wdbuf c@ 0> + while wdbuf count hash , r@ c@ 1+ r@ c! + repeat 2drop r> drop 0 , ; +: name: $0A parse tuck here place 1+ allot keys, ; +: syn: $0A parse -1 cells allot + begin /word wdbuf c@ 0> while wdbuf count hash , + curob @ >keys dup c@ 1+ swap c! repeat 0 , 2drop ; +: nl s" " ; +: desc: desc# off here 0 , + begin source >in @ /string /bl + ?desc, nl desc, refill 0= #tib @ 0= or + until desc# @ swap ! ; +: $@ dup cell+ swap @ ; + +: excise ( obj -- ) + dup dup >env @ >inv @ = if dup >nob @ over >env @ >inv ! then + dup >pob @ ?dup if over >nob @ swap >nob ! then + dup >nob @ ?dup if over >pob @ swap >pob ! then + dup >pob off dup >nob off >env off ; + +: inv+ ( c to -- ) + over >nob over >inv @ swap ! + dup >inv @ if 2dup >inv @ >pob ! then + >inv ! ; + +: env! dup >env @ if dup excise then + 2dup swap inv+ >env ! ; + +variable player +variable intang +: you player @ ; + +( Flags ) + +create flag# 1 , +: !flag! create , does> @ curob @ >flags tuck @ or swap ! ; +: !flag? create , does> @ swap >flags @ and 0<> ; +: flag flag# @ dup !flag! dup !flag? 2* flag# ! ; + +flag room room? +flag item item? +flag contr contr? +flag suprt suprt? +flag scen scen? + +( Gender and grammar ) + +\ yaay, my favorite... + +flag an an? +flag the the? +flag proper proper? +flag plur plur? +flag ucnt ucnt? +flag masc masc? +flag fem fem? +flag neut neut? + +: you? you = ; + +: .you drop bold ." you" ;bold ; +: .name >name count bold type ;bold ; + +: when postpone dup ' compile, postpone if + $0A parse evaluate postpone exit postpone then ; immediate + +: .the + when you? .name + when proper? .name + ." the " .name ; + +: .a + when you? .you + when the? .the + when proper? .name + when ucnt? .name + when plur? ." some " .name + when an? ." an " .name + ." a " .name ; + +: .nom + when you? drop ." you" + when masc? drop ." he" + when fem? drop ." she" + when neut? drop ." they" + when plur? drop ." they" + drop ." it" ; + +: .acc + when you? drop ." you" + when masc? drop ." him" + when fem? drop ." her" + when neut? drop ." them" + when plur? drop ." them" + drop ." it" ; + +: .gen + when you? drop ." your" + when masc? drop ." his" + when fem? drop ." her" + when neut? drop ." their" + when plur? drop ." their" + drop ." its" ; + +: .gens + when you? drop ." yours" + when masc? drop ." his" + when fem? drop ." hers" + when neut? drop ." theirs" + when plur? drop ." theirs" + drop ." its" ; + +: .ref + when you? drop ." yourself" + when masc? drop ." himself" + when fem? drop ." herself" + when neut? drop ." themself" + when plur? drop ." themselves" + drop ." itself" ; + +: .that + when you? drop ." yourself" + when masc? drop ." him" + when fem? drop ." her" + when neut? drop ." them" + when plur? drop ." those" + drop ." that" ; + +: are? dup plur? over neut? or swap you? or ; +: .is are? if ." are" else ." is" then ; +: (s) are? 0= if ." s" then ; + +( Relations ) + +1 constant in +2 constant atop +3 constant under +4 constant heldby +: now ( ob rel env -- ) rot tuck env! >rel ! ; +: is? ( ob rel env -- ? ) rot tuck >env @ = -rot >rel @ = and ; +: isn't? ( ob rel env -- ? ) rot tuck >env @ <> -rot >rel @ <> or ; +: first ( rel env -- ) curob @ -rot now ; +: .rel case + in of ." inside" endof + atop of ." on top of" endof + under of ." underneath" endof + heldby of ." held by" endof + ." child of" + endcase ; + +( Object definition shortcuts ) + +variable lastroom +: room room curob @ lastroom ! ; +: item item in lastroom @ first ; +: scen scen in lastroom @ first ; + +( Object debug info display ) + +8 constant o#max +create o# 0 , +: o.cr cr o# @ 2* spaces ; + +: o.type bounds do i c@ $0A = if o.cr else i c@ emit then loop ; +: o.f flag# @ begin dup 0> while + 2dup and if dup ." $" u. then 2/ repeat 2drop ; +: .o o# @ o#max > if drop exit then + base @ >r hex + o.cr dup >pob @ u. ." <- " dup u. ." -> " dup >nob @ u. + o.cr dup >name count type ." ( " dup >flags @ o.f ." ) " + dup >rel @ .rel space dup >env @ u. + dup >env @ ?dup if ." (" >name count type ." )" then + o.cr dup >desc $@ o.type + >inv @ begin ?dup while + 1 o# +! dup recurse -1 o# +! >nob @ repeat + r> base ! ; +: .o cr .o cr ; +: .e you >env @ ?dup if .o then ; + +( Object resolution ) + +: self-word? + dup hash" me" = + over hash" self" = or + swap hash" myself" = or ; + +: called-word? ( hash obj -- ) + \ over self-word? over you = and if 2drop true exit then + false -rot + >keys count cells bounds do + i @ over = if nip true swap leave then + cell +loop drop ; + +: called? ( ha u obj -- ) + >r true -rot r> + -rot cells bounds do + i @ over called-word? 0= + if nip false swap leave then + cell +loop drop ; + +: inv{ postpone >inv postpone @ postpone begin postpone ?dup + postpone while postpone >r ; immediate +: inv; postpone r@ postpone r> postpone xor postpone >r ; immediate +: }inv postpone r@ postpone if postpone r> postpone >nob + postpone @ postpone then postpone repeat ; immediate +: child postpone r@ ; immediate + +8 constant maxro# variable ro# 2variable ron ( resob name ) +: (resob) + dup ron 2@ rot called? if exit then + ro# @ maxro# >= if drop exit then + ro# @ dup >r 1+ ro# ! + 0 swap inv{ + child recurse ?dup if nip then + }inv r> ro# ! ; +: resob ro# off ron 2! you >env @ (resob) ; +: rob parse-word hash pad ! pad 1 resob ; + +( Action matching ) + +16 constant #args +16 constant #argb + +variable arg# +variable argb# +create argb #argb cells allot +create args #args cells allot +: argz args #args cells 0 fill ; + +( Most of these words act on a pair of pointers to word hashes, + TOS the pattern to check against. ) + +\ this took me so long to get working, and the main bug +\ was in the loop condition the whole time, not any of +\ the code i was looking at. + +variable inarg? +: advance cell+ swap cell+ swap ; +variable argend +: arg arg# @ cells args + ; +: arg? argb# @ 0> ; + +\ EOMATCH gets reset for each action we search, so the highest +\ priority error to occur during FINDACT is used for error msgs +variable matcherr +variable eomatch +: eomatch: create , does> @ eomatch ! ; + +1 dup eomatch: succ +1+ dup constant #nomatch +1+ dup constant #notfound +1+ dup constant #noarg +drop +#notfound eomatch: notfound +#nomatch eomatch: nomatch +#noarg eomatch: noarg + +: badmatch cr matcherr @ case + #noarg of ." Regarding what?" endof + #nomatch of ." I didn't understand that." endof + #notfound of ." I don't know what that is." endof + endcase ; + +: :arg dup @ argend ! inarg? on argb# off ; +: article? + dup hash" the" = over hash" an" = or + over hash" a" = or swap hash" some" = or ; +: >arg + dup article? if drop exit then + argb# @ #argb 1- >= if drop exit then + argb# @ cells argb + ! 1 argb# +! ; +: ;arg argb argb# @ resob + ?dup if arg ! 1 arg# +! + else notfound then inarg? off ; + +: argend? dup argend @ = swap 0= or ; +: ?;arg arg? if ;arg else noarg then ; +: >arg+ over @ >arg swap cell+ swap ; +: inarg over @ argend? if ?;arg else >arg+ then ; +: same? over @ over @ = ; +: atend? dup @ 0= ; +: grammar + eomatch @ if exit then + dup @ argwd = + if cell+ :arg + else same? + if atend? if succ else advance then + else nomatch then + then ; +: match? ( b1 b2 -- ? ) + eomatch off arg# off inarg? off argz + begin inarg? @ if inarg else grammar then + eomatch @ arg# @ #args >= or + until 2drop eomatch @ dup matcherr @ > + if dup matcherr ! then 1 = ; + +: findact matcherr off + lastact + begin @ dup + while 2dup act>buf match? + if nip exit then + repeat nip ; + +( Command execution ) + +64 constant #cmd +variable cmd# +create cmdbuf #cmd cells allot +: >cmd cmd# @ cells cmdbuf + ! 1 cmd# +! ; +: cmd>buf cmd# off + begin /word wdbuf c@ 0> + cmd# @ #cmd 1- < and ( leave room for final 0 ) + while wdbuf count hash >cmd + repeat 0 >cmd 2drop ; + +\ confusion stolen from t2tmud.org:9999 +: perform act>proc @ execute ; + +: nostk depth 0 ?do drop loop ; +: .exc bold red fg! ." EXCEPTION #" . norm ; +: .ok bold green fg! ." ok" norm ; +: cmd4 cr ['] evaluate catch ?dup if .exc nostk else .ok then ; + +: cmd over c@ [char] ; = over 0> and + if 1 /string cmd4 exit then + cmd>buf cmdbuf findact + ?dup if perform else badmatch then ; + +( Verb procedures ) + +: dob args @ ; +: iob args cell+ @ ; + +: .inv + inv{ child .a child >nob @ + if child >nob @ >nob @ + if ." , " else ." , and " then + then }inv ; + +\ Universal verbs + +:noname you >inv @ + if cr ." You hold " you .inv ." ." + else cr ." You are empty-handed." then ; +act: inventory / inv / i + +:noname cr ." Goodbye." cr playing? off ; +act: quit + +\ Chain verbs (modifiable) +\ these end in underscores because it looks like a text cursor + +: grammar ' act: ; + + +: in-desc? dup you <> swap scen? 0= and ; +: #others 0 over inv{ child in-desc? if 1+ then }inv ; +: has-others? #others 0> ; + +:chain look_ + you >env @ + capslock on cr bold dup .name norm cr capslock off + cr dup >desc $@ type + has-others? if cr cyan fg! then + inv{ child in-desc? + if .{ [child .a] [child .is] here.} + then }inv norm ; + +:chain exam_ cr dob >desc $@ type + dob >inv @ if cyan fg! cr + .{ [dob .the] hold[dob (s)] [dob .inv].} + norm then ; + +:chain take_ dob heldby you now + .{ You pick up [dob .the].} ; + +:chain drop_ dob you >rel @ you >env @ now + .{ You drop [dob .the].} ; + +:chain put_in_ dob in iob now + .{ You put [dob .the] in [iob .the].} ; +:chain put_on_ dob in iob now + .{ You put [dob .the] on [iob .the].} ; + +grammar look_ look / l +grammar exam_ look * / l * / examine * / x * / look at * / l at * +grammar take_ get * / take * / pick up * / pick * up +grammar drop_ drop * / put * down / put down * +grammar put_in_ put * in */put * into */put * inside */put * inside of */put * within * +grammar put_on_ put * on * / put * onto */put * atop */put * on top of * + +: held heldby you is? ; + +:ere drop_ dob held ?or{ You'd need to pick [dob .nom] up first.} ; +:ere take_ dob item? ?or{ You can't take [dob .the].} ; +:ere take_ dob held if instead + cr .{ You're already holding [dob .that].} then ; +:ere take_ dob you = ?deny{ You've always been self-possessed.} ; + +variable putrel +create relatbl ' contr? , ' suprt? , +: relacc? iob putrel @ 1- cells relatbl + @ execute ; + +: ?put-rel putrel ! + dob held ?or{ You're not holding [dob .that].} + dob iob = ?deny{ [putrel @ .rel] [dob .ref]?} + dob you = iob you = or ?deny{ Yourself?} + relacc? ?or{ You can't put anything [putrel @ .rel] [dob .that]!} ; + +:ere put_in_ in ?put-rel ; +:ere put_on_ atop ?put-rel ; + +: ?go-to ?dup + if you in rot now look_ + else .{ You can't go that way.} + then ; +: exit: >r :chain s" you >env @ >exits" evaluate + r> cells postpone literal s" + @ ?go-to" evaluate + postpone ; ; + +north exit: n_ +northeast exit: ne_ +east exit: e_ +southeast exit: se_ +south exit: s_ +southwest exit: sw_ +west exit: w_ +northwest exit: nw_ +up exit: u_ +down exit: d_ +grammar d_ d / down / go d / go down +grammar n_ n / north / go n / go north +grammar ne_ ne / northeast / go ne / go northeast +grammar e_ e / east / go e / go east +grammar se_ se / southeast / go se / go southeast +grammar s_ s / south / go s / go south +grammar sw_ sw / southwest / go sw / go southwest +grammar w_ w / west / go w / go west +grammar nw_ nw / northwest / go nw / go northwest +grammar u_ u / up / go u / go up +grammar d_ d / down / go d / go down + +: -> ' execute swap cells curob @ >exits + ! ; +: <- curob @ swap cells ' execute >exits + ! ; +: <-> >r curob @ ' execute 2dup + >exits r@ opposite cells + ! + swap >exits r> cells + ! ; + +: :diob curob @ postpone literal postpone <> + postpone if postpone exit postpone then postpone instead ; +\ doesn't work in VFX Forth? +: :iob :ere postpone iob :diob ; +: :dob :ere postpone dob :diob ; + +\ Grammar + +( User interface ) + +256 constant #inbuf +create inbuf #inbuf allot +: prompt ." > " ; +: input green fg! cr bold prompt ;bold + inbuf #inbuf accept inbuf swap norm ; +: intro page look_ cr ; +: play init intro begin playing? @ while input cmd cr repeat fini ; + +( Game world ) + +: room: id: room ; +: item: id: item ; +: scen: id: scen ; +: you: id: in lastroom @ first curob @ player ! ; +: to: >r lastroom @ room: curob @ + 2dup r@ opposite >exit ! swap r> >exit ! ; + +include gam.f + +( Play ) + +play bye |