pete286/map.jor
2019-03-14 22:18:20 -04:00

84 lines
2 KiB
Plaintext
Executable file

( M A P )
: +pos ( x1 y1 x2 y2 -- x y )
<rot + >rot + swap ;
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 DRIVABLE
array tileflags
( grass ) WALKABLE b,
( dirt ) WALKABLE DRIVABLE | b,
( water ) 0 b,
( pavement ) WALKABLE DRIVABLE | b,
( brick ) 0 b,
( forest ) 0 b,
( roof ) 0 b,
( brick ) 0 b,
( window ) 0 b,
( carpet ) WALKABLE b,
( wallpaper ) 0 b,
( tile ) WALKABLE b,
( door ) 0 b,
( cabinet ) 0 b,
( fridge ) 0 b,
( countertop ) 0 b,
( sink ) 0 b,
( house ) 0 b,
( fence ) 0 b,
( storefront ) 0 b,
here tileflags - 1 - const MAXTILE
: mapflag? ( x y flag -- b ) >rot tile b@ tileflags + b@ & ;
: walkable? ( x y -- b ) WALKABLE mapflag? ;
: drivable? ( x y -- b ) DRIVABLE mapflag? ;
: tick-mapedit
tileselect @
^< key-pressed if 1 - then
^> key-pressed if 1 + then
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! ;
: save-map ( filename -- )
fdeactivate swap overwrite
mapsize swap fput fput
mapsize * map fwrite
factivate ;
: load-map ( filename -- )
fdeactivate swap open
fget fget
2dup * map fread
mapsize!
factivate ;
: fill-map ( tile -- )
0 mapsize * for dup map i + b! next drop invalidate-map ;