neuttower/map.jor

102 lines
2.7 KiB
Plaintext
Executable file

( 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
array tileflags
( sky ) 0 b,
( cloud ) 0 b,
( wall ) NEUTABLE b,
( carpet ) WALKABLE b,
( comp-off ) 0 b,
( comp-on ) NEUTABLE b,
( table ) 0 b,
( chair ) 0 b,
( table-brok ) 0 b,
( door-close ) 0 b,
( door-open ) WALKABLE b,
( switch-off ) NEUTABLE b,
( switch-on ) NEUTABLE b,
( window ) 0 b,
( chair-brok ) 0 b,
( bookcase ) 0 b,
( bookcase-broke ) 0 b,
( scattered books ) WALKABLE b,
( plant ) 0 b,
( tipped plant ) 0 b,
( scanner-off ) NEUTABLE b,
( scanner-on ) NEUTABLE b,
( cracked-wall ) 0 b,
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