( 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
4 const RUBBLE

array tileflags
( 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 RUBBLE | 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,
( 24:keypad )          NEUTABLE b,

here tileflags - 1 - const MAXTILE

 3 const CARPET
 4 const COMP-OFF
 5 const COMP-ON
 7 const CHAIR
 9 const DOOR-CLOSED
10 const DOOR-OPENED
11 const SWITCH-OFF
12 const SWITCH-ON
20 const SCAN-OFF
21 const SCAN-ON
23 const REXX-POD

: 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