<DEFINE EXIT-TO (EXITS RMS)
#DECL ((EXITS) EXIT (RMS) <UVECTOR [REST ROOM]>)
<MAPF <>
<FUNCTION (E)
#DECL ((E) <OR DIRECTION ROOM CEXIT NEXIT DOOR>)
<COND (<TYPE? .E DIRECTION>)
(<AND <TYPE? .E ROOM> <MEMQ .E .RMS>>
<MAPLEAVE T>)
(<AND <TYPE? .E CEXIT> <MEMQ <2 .E> .RMS>>
<MAPLEAVE T>)
(<AND <TYPE? .E DOOR>
<OR <MEMQ <DROOM1 .E> .RMS>
<MEMQ <DROOM2 .E> .RMS>>>
<MAPLEAVE T>)>>
.EXITS>>
https://en.wikipedia.org/wiki/MDL_(programming_language)
<OBJECT LANTERN
(LOC LIVING-ROOM)
(SYNONYM LAMP LANTERN LIGHT)
(ADJECTIVE BRASS)
(DESC "brass lantern")
(FLAGS TAKEBIT LIGHTBIT)
(ACTION LANTERN-F)
(FDESC "A battery-powered lantern is on the trophy
case.")
(LDESC "There is a brass lantern (battery-powered)
here.")
(SIZE 15)>
https://www.filfre.net/2012/01/zil-and-the-z-machine/
@mul 1000 c -> sp; d6 2f 03 e8 02 00
variable form; count 2OP; opcode number 22; operands:
03 e8 long constant (1000 decimal)
02 variable c
store result to stack pointer (var number 00).
https://www.inform-fiction.org/zmachine/standards/z1point0/sect04.html
Z-char 6789abcdef0123456789abcdef
current --------------------------
A0 abcdefghijklmnopqrstuvwxyz
A1 ABCDEFGHIJKLMNOPQRSTUVWXYZ
A2 ^0123456789.,!?_#'"/\-:()
--------------------------
https://www.inform-fiction.org/zmachine/standards/z1point0/sect03.html
hallway: Room 'Hallway'
"This hall is pretty bare,
but there are exits to west and south. "
south = startRoom
west = study
;
study: Room 'Study'
"This study is much as you would expect.
A desk stands in the middle of the
room. The way out is to the east. "
east = hallway
;
https://www.tads.org/t3doc/doc/t3QuickStart.htm#sample
Object foyer "Foyer of the Opera House"
with description
"You are standing in a spacious hall,
splendidly decorated in red
and gold, with glittering chandeliers overhead.
The entrance from the street is to the north,
and there are doorways south and west.",
s_to bar,
w_to cloakroom,
n_to
"You've only just arrived, and besides,
the weather outside seems to be getting worse.",
has light;
http://www.firthworks.com/roger/cloak/inform/index.html
Foyer of the Opera House is a room. "You are standing in a spacious hall, splendidly decorated in red and gold, with glittering chandeliers overhead. The entrance from the street is to the north, and there are doorways south and west." Instead of going north in the Foyer, say "You've only just arrived, and besides, the weather outside seems to be getting worse."http://www.firthworks.com/roger/cloak/inform/index.html
ROOM: shed Inside Shed DESCRIPTION: The shed is illuminated by a single dim lightbulb. A small hatch in the floor leads into darkness. A metal ladder, fused with the concrete is visible.
( Manipulate the rest of the current line ) : trailing? ( -- f) source nip >in @ - ; : trailing ( -- a n ) source >in @ - swap >in @ + swap ; : space? ( -- f ) source drop >in @ + c@ bl = ; : skip-space begin trailing? space? and while 1 >in +! repeat ; : skip-trailing source nip >in ! ; : eat-trailing skip-space trailing skip-trailing ; : trailing, eat-trailing dup , dup >r here swap cmove r> allot ; : while-trailing ( xt -- ) begin trailing? while dup execute repeat drop ;
( Words common to many games ) game-words set-current NOUNS: north south east west up down NOUNS: northwest northeast southwest southeast NOUNS: n s e w nw ne sw se u d NOUNS: all VERBS: inventory i get drop look examine eat drink go FILLERS: a an the at only forth definitions
( Handle parts of a phrase ) variable cmd variable obj variable failed variable uid 2 uid ! : noun create uid @++ , does> @ obj @ 8 lshift + obj ! ; : NOUNS: ['] noun while-trailing ; : verb create uid @++ , does> @ cmd @ 8 lshift + cmd ! ; : VERBS: ['] verb while-trailing ; : filler create does> drop ; : FILLERS: ['] filler while-trailing ;
q" drop" verb= if
ego find-object
dup if
room into
say: Dropped.
else
drop
say: I don't have that.
then
exit
then
( Print with word wrap ) : last-ch ( a n -- ch ) dup 0= if 2drop bl else + 1- c@ then ; : bl-trim ( a n -- a n ) begin 2dup last-ch bl <> while 1- repeat ; : wrap-point ( a n -- n ) dup cols < if nip else drop cols 1- bl-trim nip then ; : wrap-one ( a n -- a n ) 2dup wrap-point swap >r over >r dup >r type cr r> r> over + swap r> swap - ; : wrap ( a n -- ) begin dup 0<> while wrap-one repeat 2drop cr ; : cwrap ( ccs -- ) cc>s wrap ; : say: eat-trailing postpone sliteral postpone wrap ; immediate
variable property-count : property create property-count @++ , does> @ cells + ; : PROPERTIES: ['] property while-trailing ; ( Built-in properties ) PROPERTIES: .parent .children .sibling PROPERTIES: .short-name .description .attributes .called
( Game object attributes ) variable attribute-count : attribute create attribute-count @++ 1 swap lshift , does> @ ; : ATTRIBUTES: ['] attribute while-trailing ; : set ( a attr -- ) swap .attributes or! ; : clear ( a attr -- ) invert swap .attributes and! ; : get ( a attr -- f ) swap .attributes @ and 0<> ; ( Built-in attributes ) ATTRIBUTES: .room .entity .prop
( Additional attributes and properties ) PROPERTIES: .north .south .east .west .up .down PROPERTIES: .northeast .northwest .southwest .southeast ATTRIBUTES: .holdable .described ATTRIBUTES: .open .locked
: remove' ( o -- )
dup .parent @ .children begin dup @ while
2dup @ = if dup @ .sibling @ swap ! drop exit then
@ .sibling
repeat 2drop ;
: insert' ( o p -- )
2dup swap .parent !
dup .children @ >r over r> swap .sibling ! .children ! ;
: into ( o p -- ) over remove' insert' ;
: contains ( o p -- f ) swap .parent = ;
: iterate ( o xt -- )
swap .children begin dup @ while
2dup dup @ >r >r >r @ swap execute r> r> r>
over @ = if @ .sibling then
repeat 2drop ;
: drop-all-one ( o -- ) dup .holdable get if room into else drop then ; : drop-all ego ['] drop-all-one iterate ; : get-all-one ( o -- ) dup .holdable get if ego into else drop then ; : get-all room ['] get-all-one iterate ;
create direction-table q" n" , q" north" , ' .north , q" s" , q" south" , ' .south , q" e" , q" east" , ' .east , q" w" , q" west" , ' .west , q" nw" , q" northwest" , ' .northwest , q" ne" , q" northeast" , ' .northeast , q" sw" , q" southwest" , ' .southwest , q" se" , q" southeast" , ' .southeast , q" u" , q" up" , ' .up , q" d" , q" down" , ' .down , 10 constant direction-count : direction ( n n -- ) swap 3 * + cells direction-table + @ ; : short-direction 0 direction ; : long-direction 1 direction ; : in-direction 2 direction execute @ ;
( Connect rooms ) : connect-we ( a b -- ) 2dup .west ! swap .east ! ; : connect-ns ( a b -- ) 2dup .north ! swap .south ! ; : connect-nwse ( a b -- ) 2dup .northwest ! swap .southeast ! ; : connect-nesw ( a b -- ) 2dup .northeast ! swap .southwest ! ; : connect-ud ( a b -- ) 2dup .up ! swap .down ! ;
map-inside: 0 R01 0 0 0 R17 |m 0 R02 R03 0 0 R16 |m 0 0 R04 R05 0 R15 |m 0 R07 R06 R11 R12 R14 |m R09 R08 0 0 R13 0 |m 0 R10 0 0 0 0 |m ;map
( Build up a map )
variable map-width variable map-height
variable map-start variable map-outside
: map-init 0 map-width ! 0 map-height ! here map-start ! ;
: map-inside: 0 map-outside ! map-init ;
: map-outside: -1 map-outside ! map-init ;
: |m depth map-width ! 1 map-height +!
depth 0 do , loop ;
: map-x-inside? ( x -- f ) dup 0>= swap map-width @ < and ;
: map-y-inside? ( y -- f ) dup 0>= swap map-height @ < and ;
: map-inside? ( x y -- f ) map-y-inside? swap map-x-inside? and ;
: map-at ( x y -- a ) 2dup map-inside? 0= if 2drop 0 exit then
map-width @ * map-width @ 1- rot - +
cells map-start @ + @ ;
: validpair ( a b xt -- )
-rot 2dup 0<> swap 0<> and if rot execute else 2drop drop then ;
: ;map map-height @ 0 do map-width @ 0 do
i j map-at i 1+ j map-at ['] connect-we validpair
i j map-at i j 1+ map-at ['] connect-ns validpair
map-outside @ if
i j map-at i 1+ j 1+ map-at ['] connect-nwse validpair
i j map-at i 1- j 1+ map-at ['] connect-nesw validpair
then
loop loop ;
4 README.md
127 engine.fs
194 generic.fs
250 svf-adventure.fs
575 total
source
and
slides
at:
github.com/flagxor