2020-02-02 23:33:07 +00:00
|
|
|
( M A P )
|
|
|
|
|
var tileselect
|
|
|
|
|
: invalidate-map mapsize mapsize! ;
|
|
|
|
|
: mouseworldpos mousepos scrollpos +pos ;
|
|
|
|
|
: mousetile mouseworldpos world>tile ;
|
|
|
|
|
: tile ( x y -- ptr ) mapsize drop * + map + ;
|
|
|
|
|
|
|
|
|
|
1 const WALKABLE
|
|
|
|
|
2 const NEUTABLE
|
2020-02-18 01:43:14 +00:00
|
|
|
4 const RUBBLE
|
2020-02-02 23:33:07 +00:00
|
|
|
|
|
|
|
|
array tileflags
|
2020-02-22 03:38:32 +00:00
|
|
|
( 0: sky ) 0 b,
|
|
|
|
|
( 1: cloud ) 0 b,
|
|
|
|
|
( 2: wall ) NEUTABLE b,
|
|
|
|
|
( 3: carpet ) WALKABLE b,
|
|
|
|
|
( 4: comp-off ) 0 b,
|
|
|
|
|
( 5: comp-on ) NEUTABLE b,
|
|
|
|
|
( 6: table ) 0 b,
|
|
|
|
|
( 7: chair ) 0 b,
|
|
|
|
|
( 8: table-brok ) RUBBLE b,
|
|
|
|
|
( 9: door-close ) 0 b,
|
|
|
|
|
( 10:door-open ) WALKABLE b,
|
|
|
|
|
( 11:switch-off ) NEUTABLE b,
|
|
|
|
|
( 12:switch-on ) NEUTABLE b,
|
|
|
|
|
( 13:window ) 0 b,
|
|
|
|
|
( 14:chair-brok ) RUBBLE b,
|
|
|
|
|
( 15:bookcase ) 0 b,
|
|
|
|
|
( 16:bookcase-broke ) RUBBLE b,
|
|
|
|
|
( 17:scattered books ) WALKABLE b,
|
|
|
|
|
( 18:plant ) 0 b,
|
|
|
|
|
( 19:tipped plant ) RUBBLE b,
|
|
|
|
|
( 20:scanner-off ) NEUTABLE b,
|
|
|
|
|
( 21:scanner-on ) NEUTABLE b,
|
|
|
|
|
( 22:cracked-wall ) 0 b,
|
|
|
|
|
( 23:rexx-pod ) NEUTABLE b,
|
2020-02-02 23:33:07 +00:00
|
|
|
|
|
|
|
|
here tileflags - 1 - const MAXTILE
|
|
|
|
|
|
|
|
|
|
: mapflag? ( x y flag -- b ) >rot tile b@ tileflags + b@ & ;
|
|
|
|
|
|
|
|
|
|
: tick-mapedit
|
|
|
|
|
tileselect @
|
|
|
|
|
^< key-pressed if 1 - then
|
|
|
|
|
^> key-pressed if 1 + then
|
|
|
|
|
0 max MAXTILE min
|
|
|
|
|
( dup 0 < if drop MAXTILE then
|
|
|
|
|
dup MAXTILE > if drop 0 then )
|
|
|
|
|
tileselect !
|
|
|
|
|
|
|
|
|
|
MOUSEL mousedown if tileselect @ mousetile tile b! invalidate-map then
|
|
|
|
|
MOUSER clicked if
|
|
|
|
|
mouseworldpos world>tile
|
|
|
|
|
2dup tile b@ tileselect !
|
|
|
|
|
swap . . cr then ;
|
|
|
|
|
|
|
|
|
|
: copy-mapseg ( neww oldw y -- )
|
|
|
|
|
>r ( oldw neww r: y )
|
|
|
|
|
2dup min >rot ( copyw neww oldw )
|
|
|
|
|
r@ * map + ( copyw neww src )
|
|
|
|
|
swap <r * map + ( copyw src dst )
|
|
|
|
|
swap <rot memmove ;
|
|
|
|
|
|
|
|
|
|
: resize-map ( neww newh -- )
|
|
|
|
|
swap mapsize >r ( newh neww oldw r: oldh )
|
|
|
|
|
2dup < if 1 <r else <r 1 - 0 then ( newh neww copyw ystart ylim )
|
|
|
|
|
for 2dup i copy-mapseg next
|
|
|
|
|
drop swap mapsize! ; userword
|
|
|
|
|
|
|
|
|
|
: mapw mapsize drop ;
|
|
|
|
|
: maph mapsize nip ;
|
|
|
|
|
|
|
|
|
|
: offset-map ( p d -- p ) dup 0 < if drop else + then ;
|
|
|
|
|
|
|
|
|
|
: shift-map ( dx dy -- )
|
|
|
|
|
maph over abs - >r ( dx dy r: h )
|
|
|
|
|
swap mapw over abs - >rot ( w dy dx r: h )
|
|
|
|
|
2dup map swap offset-map
|
|
|
|
|
swap mapw * offset-map >rot ( w end dy dx r: h )
|
|
|
|
|
map swap negate offset-map
|
|
|
|
|
swap mapw * negate offset-map ( w end start r: h )
|
|
|
|
|
2dup > if r@ mapw * + swap r@ mapw * + swap then
|
|
|
|
|
<r 0 for
|
|
|
|
|
3dup <rot memmove
|
|
|
|
|
2dup < if mapw + swap mapw + swap
|
|
|
|
|
else mapw - swap mapw - swap then
|
|
|
|
|
next drop drop drop invalidate-map ; userword
|
|
|
|
|
|
|
|
|
|
: save-map ( filename -- )
|
|
|
|
|
fdeactivate swap overwrite
|
|
|
|
|
mapsize swap fput fput
|
|
|
|
|
mapsize * map fwrite
|
|
|
|
|
factivate ; userword
|
|
|
|
|
|
|
|
|
|
: load-map ( filename -- )
|
|
|
|
|
fdeactivate swap open
|
|
|
|
|
fget fget
|
|
|
|
|
2dup * map fread
|
|
|
|
|
mapsize!
|
|
|
|
|
factivate ; userword
|
|
|
|
|
|
|
|
|
|
: fill-map ( tile -- )
|
|
|
|
|
0 mapsize * for dup map i + b! next drop invalidate-map ; userword
|
