122 lines
7 KiB
Forth
122 lines
7 KiB
Forth
#! /usr/bin/gforth
|
|
\ Maze Generation
|
|
|
|
warnings off
|
|
|
|
require random.fs
|
|
require bits.fs
|
|
|
|
\ command line
|
|
|
|
: parse-number s>number? invert throw drop ;
|
|
: parse-width ." width : " next-arg parse-number dup . cr ;
|
|
: parse-height ." height: " next-arg parse-number dup . cr ;
|
|
: parse-args cr parse-width parse-height ;
|
|
|
|
parse-args constant HEIGHT constant WIDTH
|
|
|
|
2 CONSTANT AISLE-WIDTH
|
|
1 CONSTANT AISLE-HEIGHT
|
|
|
|
WIDTH HEIGHT * bits CONSTANT VISITED
|
|
WIDTH 1- HEIGHT * bits CONSTANT EAST-WALLS
|
|
HEIGHT 1- WIDTH * bits CONSTANT SOUTH-WALLS
|
|
|
|
0 CONSTANT NORTH
|
|
1 CONSTANT EAST
|
|
2 CONSTANT SOUTH
|
|
3 CONSTANT WEST
|
|
|
|
: visited-ix ( x y -- u ) WIDTH * + ;
|
|
: east-wall-ix ( x y -- u ) [ WIDTH 1- ] literal * + ;
|
|
: south-wall-ix ( x y -- u ) WIDTH * + ;
|
|
: visited! ( x y -- ) visited-ix VISITED swap TRUE set-bit ;
|
|
: visited? ( x y -- f ) visited-ix VISITED swap check-bit ;
|
|
: east-wall? ( x y -- f ) east-wall-ix EAST-WALLS swap check-bit ;
|
|
: south-wall? ( x y -- f ) south-wall-ix SOUTH-WALLS swap check-bit ;
|
|
: remove-east-wall ( x y -- ) east-wall-ix EAST-WALLS swap FALSE set-bit ;
|
|
: remove-south-wall ( x y -- ) south-wall-ix SOUTH-WALLS swap FALSE set-bit ;
|
|
|
|
: clear-visited ( -- ) VISITED 0 WIDTH 1- HEIGHT 1- visited-ix FALSE set-bits ;
|
|
: set-east-walls ( -- ) EAST-WALLS 0 WIDTH 2 - HEIGHT 1- east-wall-ix TRUE set-bits ;
|
|
: set-south-walls ( -- ) SOUTH-WALLS 0 WIDTH 1- HEIGHT 2 - south-wall-ix TRUE set-bits ;
|
|
: initial-pos ( -- x y ) WIDTH random HEIGHT random ;
|
|
: init-state ( -- -1 x y 0 ) clear-visited set-east-walls set-south-walls -1 initial-pos 2dup visited! 0 ;
|
|
|
|
: north-valid? ( x y -- f ) nip 0> ;
|
|
: east-valid? ( x y -- f ) drop [ WIDTH 1- ] literal < ;
|
|
: south-valid? ( x y -- f ) nip [ HEIGHT 1- ] literal < ;
|
|
: west-valid? ( x y -- f ) drop 0> ;
|
|
: dir-valid? ( x y d -- f ) case
|
|
NORTH of north-valid? endof
|
|
EAST of east-valid? endof
|
|
SOUTH of south-valid? endof
|
|
WEST of west-valid? endof
|
|
endcase ;
|
|
: move-north ( x y -- x' y' ) 1- ;
|
|
: move-east ( x y -- x' y' ) swap 1+ swap ;
|
|
: move-south ( x y -- x' y' ) 1+ ;
|
|
: move-west ( x y -- x' y' ) swap 1- swap ;
|
|
: move ( x y d -- x' y' ) case
|
|
NORTH of move-north endof
|
|
EAST of move-east endof
|
|
SOUTH of move-south endof
|
|
WEST of move-west endof
|
|
endcase ;
|
|
|
|
: remove-north-wall ( x y -- ) 1- remove-south-wall ;
|
|
: remove-west-wall ( x y -- ) swap 1- swap remove-east-wall ;
|
|
: remove-wall ( x y d -- ) case
|
|
NORTH of remove-north-wall endof
|
|
EAST of remove-east-wall endof
|
|
SOUTH of remove-south-wall endof
|
|
WEST of remove-west-wall endof
|
|
endcase ;
|
|
|
|
: dir? ( m d -- f ) 1 swap lshift and 0= ;
|
|
: dir! ( m d -- m' ) 1 swap lshift or ;
|
|
: pick-dir ( m -- m' d ) assert( dup $f <> ) begin 4 random 2dup dir? if tuck dir! swap exit then drop again ;
|
|
|
|
: update-state ( x y m d -- x' y' m' ) { x y m d }
|
|
x y d dir-valid? if
|
|
x y m
|
|
x y d move
|
|
2dup visited? if
|
|
2drop
|
|
else
|
|
2dup visited!
|
|
x y d remove-wall
|
|
0
|
|
then
|
|
else
|
|
x y m
|
|
then ;
|
|
|
|
: step ( x y m -- x' y' m' ) dup $f = if
|
|
drop 2drop \ backtracking!
|
|
else
|
|
pick-dir update-state
|
|
then ;
|
|
|
|
: build-maze ( -- ) init-state
|
|
begin
|
|
dup -1 <> while
|
|
step
|
|
repeat drop ;
|
|
|
|
: corner ( -- ) [char] + emit ;
|
|
: h-wall ( -- ) [char] - emit ;
|
|
: v-wall ( -- ) [char] | emit ;
|
|
: top-bottom. ( -- ) cr corner WIDTH 0 ?do AISLE-WIDTH 0 ?do h-wall loop corner loop ;
|
|
: empty ( -- ) AISLE-WIDTH 0 ?do space loop ;
|
|
: interior-cell ( x y -- ) empty east-wall? if v-wall else space then ;
|
|
: last-cell ( -- ) empty v-wall ;
|
|
: row ( y -- ) cr v-wall [ WIDTH 1- ] literal 0 ?do i over interior-cell loop drop last-cell ;
|
|
: last-row ( y -- ) cr WIDTH 0 ?do corner i over south-wall? if AISLE-WIDTH 0 ?do h-wall loop else empty then loop drop corner ;
|
|
: aisle ( y -- ) AISLE-HEIGHT 0 ?do dup row loop dup [ HEIGHT 1- ] literal < if last-row else drop then ;
|
|
: maze. ( -- ) top-bottom.
|
|
HEIGHT 0 ?do i aisle loop
|
|
top-bottom. ;
|
|
: maze ( width height -- ) build-maze maze. ;
|
|
|
|
maze cr bye
|