How to resolve the algorithm Maze generation step by step in the Forth programming language
Published on 12 May 2024 09:40 PM
How to resolve the algorithm Maze generation step by step in the Forth programming language
Table of Contents
Problem Statement
Generate and show a maze, using the simple Depth-first search algorithm.
Let's start with the solution:
Step by Step solution about How to resolve the algorithm Maze generation step by step in the Forth programming language
Source code in the forth programming language
\ Bit Arrays
: to-bits ( c -- f f f f f f f f )
8 0 ?do
2 /mod
swap negate swap
loop
drop ;
: from-bits ( f f f f f f f f -- )
8 0 ?do
if [char] 1 emit else [char] 0 emit then
loop ;
: byte-bin. ( c -- )
to-bits from-bits space ;
: byte. ( c -- )
dup byte-bin.
dup 2 ['] u.r 16 base-execute space
3 u.r space ;
: bytes-for-bits ( u1 -- u2 )
8 /mod swap
0> if 1+ then ;
: bits ( u -- bits )
dup bytes-for-bits cell + \ u-bits u-bytes
dup allocate throw \ u-bits u-bytes addr
2dup swap erase nip \ u-bits addr
swap over ! ; \ addr
: free-bits ( bits -- )
free throw ;
: bits. ( bits -- )
dup @ bytes-for-bits \ addr bytes
swap cell+ swap \ addr+cell bytes
bounds ?do
i cr 20 ['] u.r 16 base-execute space
i c@ byte.
loop
cr ;
: bit-position ( u -- u-bit u-byte )
8 /mod ;
: assert-bit ( bits u -- bits u )
assert( 2dup swap @ < ) ;
: find-bit ( bits u1 -- addr u2 )
assert-bit
bit-position \ addr bit byte
rot \ bit byte addr
cell+ + swap ; \ addr' bit
: set-true ( addr u -- )
1 swap lshift over \ addr mask addr
c@ or swap c! ;
: set-false ( addr u -- )
1 swap lshift invert over \ addr mask addr
c@ and swap c! ;
: set ( addr u f -- )
if set-true else set-false then ;
: set-bit ( bits u f -- )
{ f }
find-bit f set ;
: set-bits-at-addr ( addr u-start u-stop f -- )
{ f }
1+ swap u+do
dup i f set
loop
drop ;
: byte-from-flag ( f -- c )
if 255 else 0 then ;
: set-bits { bits u-start u-stop f -- }
u-start u-stop > if exit then
bits u-start find-bit { addr-start bit-start }
bits u-stop find-bit { addr-stop bit-stop }
addr-start addr-stop = if
addr-start bit-start bit-stop f set-bits-at-addr
else
addr-start bit-start 7 f set-bits-at-addr
addr-start 1+ addr-stop addr-start - 1- f byte-from-flag fill
addr-stop 0 bit-stop f set-bits-at-addr
then ;
: check-bit ( addr u -- f )
find-bit \ addr bit
1 swap lshift swap \ mask addr
c@ and 0> ;
: resize-bits ( bits u -- bits )
over @ { old-size }
tuck bytes-for-bits cell + resize throw \ u-bits bits
2dup ! swap \ bits u-bits
dup old-size > if
over swap \ bits bits u-bits
1- old-size swap false set-bits
else
drop
then ;
#! /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
You may also check:How to resolve the algorithm Character codes step by step in the VBA programming language
You may also check:How to resolve the algorithm Loops/For with a specified step step by step in the Perl programming language
You may also check:How to resolve the algorithm Number names step by step in the 360 Assembly programming language
You may also check:How to resolve the algorithm Repeat a string step by step in the Oz programming language
You may also check:How to resolve the algorithm 100 doors step by step in the Potion programming language