1+ # Randomized Prim's Algorithm
2+ # Choose a random cell within the maze grid (given by its width and height) and design it as a start cell.
3+ # Add the start cell to (by now empty) inCells set.
4+ # Mark cells around the start cell as frontier, i.e. add them to frontierCells set.
5+ # While frontierCells set is not empty:
6+ # Choose a random frontier cell cF from frontierCells.
7+ # Choose a random in-cell cI adjacent to cF.
8+ # Add cF to inCells.
9+ # Mark all out-cells around cF as frontier.
10+ # Add a path between cI and cF to the maze paths set.
11+ # Remove cF from frontierCells set
12+ # ################
13+ # Set slowly to any value to sleep that much per drawing cycle
14+ pmaze <- function (dimx , dimy , slowly = FALSE , tcols , ... ) {
15+ if (missing(tcols ) ) tcols <- rainbow((dimx + dimy )/ 10 ) # a wag at count
16+ # plotting the full grid:
17+ mardef <- par()$ mar
18+ par(mar = c(.1 ,.1 ,.1 ,.1 ))
19+ # build init matrices; remember cells are ID'd by "top left" coord
20+ icell <- matrix (0 ,nrow = (dimy ),ncol = (dimx ) )
21+ fcell <- matrix (0 ,nrow = (dimy ),ncol = (dimx ) )
22+ walls <- NULL # store indices of removed walls
23+ dewall <- vector(length = 4 )
24+ # select starting cell
25+ initx <- sample(1 : dimx ,1 )
26+ inity <- sample(1 : dimy ,1 )
27+ icell [inity ,initx ] <- 1
28+ # calculate frontier cells from that cell. Watch for borders!
29+ # zero values are ignored, hence the mod func
30+ fcell [inity , c(initx - 1 ,(initx + 1 )%% (dimx + 1 ) )]<- 1
31+ fcell [c(inity - 1 ,(inity + 1 )%% (dimy + 1 ) ), initx ]<- 1
32+ # OK, so now fcell is nonempty, and can start the while loop
33+ while (sum(fcell ) > 0 ) {
34+ # pick a random frontier cell.
35+ fronts <- which (fcell > 0 , arr.ind = TRUE )
36+ fgrab <- fronts [sample(1 : nrow(fronts ),1 ),]
37+ doorx <- fgrab [2 ] + c(1 ,- 1 )
38+ doorx <- doorx [doorx %in% 1 : dimx ]
39+ doory <- fgrab [1 ] + c(1 ,- 1 )
40+ doory <- doory [doory %in% 1 : dimy ]
41+ # want only the "cross" 4 cells, and only the ones which are in Icell
42+ adjac <- NULL
43+ for (j in 1 : length(doorx ) ) if ( icell [fgrab [1 ],doorx [j ]]> 0 ) adjac <- rbind(adjac ,c(fgrab [1 ],doorx [j ]) )
44+ for (j in 1 : length(doory ) ) if ( icell [doory [j ],fgrab [2 ]]> 0 ) adjac <- rbind(adjac ,c(doory [j ],fgrab [2 ]) )
45+ # pick one at random
46+ igrab <- adjac [sample(1 : nrow(adjac ),1 ),]
47+ # Now figure out the coordinates of the endpoints of this segment.
48+ # go from (max_row_ind,max_col_ind) and increment whichever index
49+ # was the same for both.
50+ dewall [2 ] <- max(igrab [1 ],fgrab [1 ])
51+ dewall [1 ] <- max(igrab [2 ],fgrab [2 ])
52+ dewall [4 ] <- dewall [2 ] + 1 * (igrab [1 ]== fgrab [1 ])
53+ dewall [3 ] <- dewall [1 ] + 1 * (igrab [2 ]== fgrab [2 ])
54+ # add it to a matrix.
55+ walls <- rbind(walls ,dewall )
56+ # clean up
57+ rownames(walls ) <- NULL
58+ colnames(walls ) <- c(' x1' ' y1' ' x2' ' y2'
59+ # need to zero the frontier cell and unzero the matching icell
60+ fcell [fgrab [1 ],fgrab [2 ]] <- 0
61+ icell [fgrab [1 ],fgrab [2 ]] <- 1
62+ # and set neighbors of fgrab to 1 in fcell.
63+ # But there's more: do NOT assign a "former" frontier cell even if it's a
64+ # neighbor of the current fgrab. This can be done by skipping neighbors
65+ # whose icell value is 1.
66+ for (j in 1 : length(doorx ) )
67+ if ( icell [fgrab [1 ],doorx [j ]] == 0 ) fcell [fgrab [1 ], doorx [j ]] <- 1
68+ for (j in 1 : length(doory ) )
69+ if ( icell [doory [j ],fgrab [2 ]] == 0 ) fcell [doory [j ], fgrab [2 ]] <- 1
70+ # now rinse lather repeat.
71+ } # end of while
72+ # modify limits to make it easier to plot in/out labels
73+ plot( c(1 ,(dimx + 1 ),(dimx + 1 ),1 ,1 ), c(1 ,1 ,(dimy + 1 ),dimy + 1 ,1 ),t = ' l' axes = F ,xlab = ' ' ylab = ' ' xlim = c(0 ,dimx + 2 ),ylim = c(0 ,dimy + 2 ) )
74+ df = as.matrix(expand.grid( xvert = seq_len(dimx ),yvert = seq_len(dimy )))
75+ dfv <- cbind(df ,df [,1 ],df [,2 ]+ 1 )
76+ df2 <- as.matrix(expand.grid(yvert = seq_len(dimy ), xvert = seq_len(dimx )))
77+ dfh <- cbind(df2 [,2 ],df2 [,1 ],df2 [,2 ]+ 1 ,df2 [,1 ])
78+ # concatenate each row w/ delimiter (so that 2_13 is not same as 21_3 )
79+ # nb alternative methods as found on SO turn out to be much slower
80+ allwalls <- rbind(dfv ,dfh )
81+ allrows <- unlist(sapply(1 : nrow(allwalls ),function (j ) paste(allwalls [j ,],collapse = ' _'
82+ # the maze walls:
83+ allfoo <- unlist(sapply(1 : nrow(walls ),function (j ) paste(walls [j ,],collapse = ' _'
84+ thewalls <- setdiff(allrows ,allfoo )
85+ dowalls <- allwalls [allrows %in% thewalls ,]
86+ # ##################################################################
87+ # New project: start at any wall touching border, and plot all segments in
88+ # that 'tree,' defineds as segments w/ common endpoints. Then pick a remaining
89+ # segment touching border, etc.
90+ # Note: fortunately, which(dist(rbind(foo,empty_matrix))) returns nothing rather
91+ # than any crash.
92+ # pick any wall to start, remove it from starting set
93+ treecnt <- 1
94+ # kill edge walls -oops , not equality but equal to 1 or nrow/ncol
95+ vedges <- which( (dowalls [,1 ]== dowalls [,3 ]) & (dowalls [,1 ]== 1 | dowalls [,1 ]== dimx + 1 ) )
96+ hedges <- which( (dowalls [,2 ]== dowalls [,4 ]) & (dowalls [,2 ]== 1 | dowalls [,2 ]== dimy + 1 ) )
97+ dowalls <- dowalls [- c(vedges ,hedges ),,drop = FALSE ]
98+ # now sort into trees
99+ # this appears to take rather a while. What can I vectorize?
100+ while (nrow(dowalls )> 0 ) {
101+ tree <- matrix (dowalls [1 ,],nr = 1 ) # force dimensions
102+ dowalls <- dowalls [- 1 ,,drop = FALSE ]
103+ treerow <- 1 # current row of tree we're looking at
104+ while ( treerow < = nrow(tree ) ) {
105+ # only examine the first 'column' of the dist() matrix 'cause those are the
106+ # distances from the tree[] endpoints
107+ # Still seems to me that one bigass dist(dowalls) matrix should be
108+ # sortable by identified row/column per tree[] element, thus saving
109+ # an absurd amount of processing. Let's get on that
110+ touch <- c( which(dist(rbind(tree [treerow ,1 : 2 ],dowalls [,1 : 2 ]) )[1 : nrow(dowalls )]== 0 ), which(dist(rbind(tree [treerow ,1 : 2 ],dowalls [,3 : 4 ]) )[1 : nrow(dowalls )]== 0 ), which(dist(rbind(tree [treerow ,3 : 4 ],dowalls [,1 : 2 ]) )[1 : nrow(dowalls )]== 0 ), which(dist(rbind(tree [treerow ,3 : 4 ],dowalls [,3 : 4 ]) )[1 : nrow(dowalls )]== 0 ) )
111+ if (length(touch ) ) {
112+ tree <- rbind(tree ,dowalls [c(touch ),])
113+ dowalls <- dowalls [- c(touch ),,drop = FALSE ]
114+ }
115+ # track the row of tree[] we're working with AND track how many rows there currently are in tree[]
116+ treerow <- treerow + 1
117+ } # end of while treerow <= nrow
118+ for (k in 1 : nrow(tree ) ) {
119+ lines(tree [k ,c(1 ,3 )],tree [k ,c(2 ,4 )] , col = tcols [treecnt %% (length(tcols )- 1 ) + 1 ] )
120+ if (slowly ) Sys.sleep(slowly )
121+ }
122+ treecnt <- treecnt + 1
123+ } # end of while dwalls exists
124+ # end of new project
125+ # original method:
126+ # dowalls <- dowalls[order(rowSums(dowalls[,1:2])),]
127+ # timng is kinda cruddy here. Experiment with (if(slowly & !j%%10)) sort of thing
128+ # for(j in 1:nrow(dowalls) ) {
129+ # lines(dowalls[j,c(1,3)],dowalls[j,c(2,4)],...)
130+ # if(slowly) Sys.sleep(slowly)
131+ # }
132+ # #
133+ par(mar = c(mardef ))
134+ return (invisible (walls ))
135+ }
136+ #
137+ # ################################
138+ #
139+ # This will "kick off" my "fill dead end" function,
140+ fillij <- function (wallmat , into = c(1 ,1 ), outof = c(apply(wallmat [,1 : 2 ],2 , max )),... ) {
141+ dimx <- max(wallmat [,1 ])
142+ dimy <- max(wallmat [,2 ])
143+ ijfoo <- cbind(expand.grid(x = 1 : dimx ,y = 1 : dimy ), matrix (0 , nc = 4 ))
144+ for (j in 1 : (nrow(wallmat )) ) {
145+ xind <- wallmat [j ,1 ]
146+ yind <- wallmat [j ,2 ]
147+ # Another win for DWIM!
148+ ijrow <- which(ijfoo [,1 ]== xind & ijfoo [,2 ]== yind )
149+ if ( xind == wallmat [j ,3 ]) {
150+ # OK, verified that initial ijfoo is dead on (at least for test case)
151+ ijfoo [ijrow ,6 ]<- 1
152+ # we never remove a vertical wall where x==1, so ijrow-1 is OK
153+ ijfoo [(ijrow - 1 ),4 ] <- 1
154+ } else {
155+ # only other possibility is horiz wall
156+ ijfoo [ijrow ,3 ] <- 1
157+ # want the row with same x values
158+ # and y values one less: ijrow- dimx , (dimx is the fast-changing index)
159+ ijfoo [ijrow - dimx ,5 ] <- 1
160+ }
161+ } # end for (j) loop
162+ # now turn any deadend into an x,y,0,0,0,0 row and assign a zero to
163+ # the matching wall of its neighbor. But first...
164+ # lockdown 'into' and 'outof' rows by setting to 5 and 6
165+ oldijfoo <- ijfoo
166+ inrow <- into [1 ]+ dimx * (into [2 ]- 1 )
167+ outrow <- outof [1 ] + dimx * (outof [2 ]- 1 )
168+ ijfoo [inrow ,3 : 6 ]<- 5
169+ ijfoo [outrow ,3 : 6 ]<- 6
170+ startijfoo <- ijfoo
171+ changed <- TRUE
172+ while (changed ) {
173+ deads <- which(rowSums(ijfoo [,3 : 6 ]) == 1 )
174+ # aha: if have two deads, and the first one cleans out the second one,
175+ # that's where I get the zero-length fillwall!
176+ for (k in deads ) {
177+ # find the live wall and so on. k= 1,2,3,4 --> N,E,S,W
178+ fillwall <- which(ijfoo [k ,3 : 6 ] == 1 )
179+ if ( length(fillwall ) > 0 ) {
180+ ijfoo [k ,(fillwall + 2 )] <- 0
181+ # and its neighbor...
182+ switch (fillwall ,
183+ {ijfoo [(k - dimx ),5 ] <- 0 },
184+ {ijfoo [(k + 1 ),6 ] <- 0 },
185+ {ijfoo [(k + dimx ),3 ] <- 0 },
186+ {ijfoo [ (k - 1 ),4 ] <- 0 } )
187+ }
188+ } # end for k in deads loop
189+ # reset start and end cells to 'lockout' value, just in case
190+ ijfoo [inrow ,3 : 6 ]<- 5
191+ ijfoo [outrow ,3 : 6 ]<- 6
192+ changed <- ! identical(oldijfoo ,ijfoo )
193+ oldijfoo <- ijfoo
194+ }
195+ # so now ijfoo has been reduced to valid paths; all other rows sum to zero
196+ # label start and stop
197+ incell <- which(ijfoo [,3 ] == 5 )
198+ outcell <- which(ijfoo [,3 ] == 6 )
199+ xfoo <- ijfoo [incell ,1 ]
200+ yfoo <- ijfoo [incell ,2 ]
201+ text(xfoo - 1.5 * (xfoo == 1 )+ .5 + 1.5 * (xfoo > = dimx ), yfoo - (yfoo == 1 )+ (yfoo > = dimy ) + .5 ,' IN' font = 2 ,cex = .6 )
202+ xfoo <- ijfoo [outcell ,1 ]
203+ yfoo <- ijfoo [outcell ,2 ]
204+ text(xfoo - 1.5 * (xfoo == 1 )+ .5 + 1.5 * (xfoo > = dimx ), yfoo - (yfoo == 1 )+ (yfoo > = dimy ) + .5 , ' OUT' font = 2 ,cex = .6 )
205+ return (invisible (ijfoo ))
206+ }
207+
208+ # ########################### draw the path
209+ #
210+ # wallmat: matrix generated with pmaze() containing "door" vertex coordinates
211+ # into: coordinates of cell for start/entering the maze
212+ # outof: coordinates of cell at finish of maze
213+ # color: color of path drawn
214+ # sleeptime: delay between increments of path drawing
215+ # ... : optional arguments compatible with lines()
216+ dopath <- function (wallmat , into = c(1 ,1 ), outof = c(apply(wallmat [,1 : 2 ],2 , max )), color = ' red' sleeptime = 0 , ... ) {
217+ dimx <- max(wallmat [,1 ])
218+ dimy <- max(wallmat [,2 ])
219+ # do input validation. But if someone sends a negative dim,poop on him
220+ into <- c(min(into [1 ],dimx ), min(into [2 ],dimy ) )
221+ outof <- c(min(outof [1 ],dimx ), min(outof [2 ],dimy ) )
222+ # call fillij() here
223+ pathmat <- fillij(wallmat , into ,outof )
224+ # remove deadends - I think this is redundant, but leave in for the moment
225+ pathmat <- pathmat [rowSums(pathmat [,3 : 6 ])> 0 ,]
226+ # Start at IN, find the location of distance==1, that may be in
227+ # either the IN row or IN column of distmat. Draw the path, delete/change
228+ # that "1" value and find the distance==1 for the adjacent cell we just found,
229+ # and so on until we find the "END" cell.
230+ startcell <- which(pathmat [,3 ]== 5 )
231+ distmat <- dist(pathmat [,1 : 2 ]) # object vector class 'dist'
232+ matdist <- as.matrix(distmat )
233+ mbar <- lower.tri(matdist )* matdist # kill upper triangle
234+ # run until startcell has "6" in it
235+ while (pathmat [startcell ,3 ] != 6 ) {
236+ nextcell <- c(which(mbar [,startcell ]== 1 ),which(mbar [startcell ,]== 1 ))
237+ # fix to "bad" distance==1 locations (with overkill):
238+ mbar [nextcell ,startcell ] <- 0
239+ mbar [startcell ,nextcell ] <- 0
240+ # # that works because I will never want to "find" startcell as a
241+ # # "nextcell" to some other cell.
242+ if (length(nextcell )> 1 ) {
243+ mated <- vector(length = length(nextcell ))
244+ startloc <- pathmat [startcell ,1 : 2 ] # move outside jj loop duh
245+ for ( jj in 1 : length(nextcell )) {
246+ # # compare Nvs S and E vs W . Want a pair to be "1" --necessary but not sufficient
247+ delcell <- ( pathmat [startcell ,3 : 6 ] * pathmat [nextcell [jj ],c(5 ,6 ,3 ,4 )] )
248+ # # now reject NS or EW if it's in wrong direction, i.e. calculate which wall/door
249+ # # the two have in common. if startcell is N of nextcell, y1<y2 . and so on.
250+ nextloc <- pathmat [nextcell [jj ],1 : 2 ]
251+ matchwall <- c(startloc [2 ]> nextloc [2 ], startloc [1 ]< nextloc [1 ], startloc [2 ]< nextloc [2 ], startloc [1 ]> nextloc [1 ])
252+ # mated is TRUE only when they share a door
253+ mated [jj ]<- sum(delcell * matchwall )
254+ }
255+ # # so now set actual nextcell to the mated==TRUE element
256+ nextcell <- nextcell [as.logical(mated )]
257+ } # end of if(length) block
258+ # loop over NESW
259+ for (j in 3 : 6 ) {
260+ # create the offsets for the given column
261+ offs <- c( 0.5 * (- 1 )^ (j == 6 ), 0.5 + (j == 4 ), 0.5 * (- 1 )^ (j == 3 ), 0.5 + (j == 5 ) )
262+ if ( pathmat [nextcell ,j ] == 1 ) {
263+ lines(pathmat [nextcell ,1 ]+ offs [1 : 2 ], pathmat [nextcell ,2 ]+ offs [3 : 4 ], col = color , ... )
264+ }
265+ }
266+ Sys.sleep(sleeptime )
267+ # update starting location
268+ startcell <- nextcell
269+ } # end of while(not in END cell)
270+ # get the path
271+ return (invisible (pathmat ))
272+ }
273+ #
274+ # ########################### loop it
275+ # # edited to handle any maze w/ compatible walls output
276+ # old "dopmaze" doesn't have a 'mazename' arg
277+ # dopmaze <- function(reps,slowly=.01, sleep=.2) {
278+ domaze <- function (reps ,mazetype = c(' rbmaze' ' pmaze' slowly = .01 , sleep = .2 ) {
279+ cols <- c(' red' ' blue' ' green' ' purple' ' pink'
280+ dimrange <- 15 : 50
281+ for (j in 1 : reps ) {
282+ # change to a do.call
283+ # foo <- pmaze(sample(dimrange,1),sample(dimrange,1),slowly=slowly )
284+ foo <- do.call(mazetype , args = list (dimx = sample(dimrange ,1 ),dimy = sample(dimrange ,1 ),slowly = slowly ) )
285+ # into and outof are forced to be on
286+ # the perimeter.
287+ dimx <- max(foo [,1 ])
288+ dimy <- max(foo [,2 ])
289+ insamp <- rbind(c(1 ,dimx ,sample(2 : (dimx - 1 ),2 )),c(sample(2 : (dimy - 1 ),2 ),1 ,dimy ) )
290+ outsamp <- rbind(c(1 ,dimx ,sample(2 : (dimx - 1 ),2 )),c(sample(2 : (dimy - 1 ),2 ),1 ,dimy ) )
291+ into <- c(insamp [,sample(1 : 4 ,1 )] )
292+ outof <- c(outsamp [,sample(1 : 4 ,1 )] )
293+ # semiBUG: don't allow IN and OUT to be too close to each other, or
294+ # the fact that dopath never zeroes out those rows will lead to a crash
295+ # force separation of IN and OUT
296+ while (dist(rbind(into ,outof ))< 4 ) {
297+ outsamp <- rbind(c(1 ,dimx ,sample(2 : (dimx - 1 ),2 )),c(sample(2 : (dimy - 1 ),2 ),1 ,dimy ) )
298+ outof <- c(outsamp [,sample(1 : 4 ,1 )] )
299+ }
300+ dopath(foo , into = into , outof = outof , col = sample(cols ,1 ), sleep = sleep )
301+ Sys.sleep(5 )
302+ }
303+ # just in case I'm interested.
304+ outs <- list (fmaze = foo , into = into , outof = outof )
305+ return (invisible (outs ))
306+ }
307+
308+ # ######################## a simple "replot" function to take the
309+ # output of pmaze and redraw the maze
310+ repmaze <- function (walls ) {
311+ mardef <- par()$ mar
312+ dimx <- max(walls [,1 ])
313+ dimy <- max(walls [,2 ])
314+ par(mar = c(.1 ,.1 ,.1 ,.1 ))
315+ plot( c(1 ,(dimx + 1 )), c(1 ,(dimy + 1 )),t = ' n' axes = F ,xlab = ' ' ylab = ' '
316+ # kill the sapplys if go to post-wall cell plotting
317+ sapply(1 : (dimy + 1 ), function (j ) lines(c(1 ,dimx + 1 ),c(j ,j )) )- > ssfoo
318+ sapply(1 : (dimx + 1 ), function (j ) lines(c(j ,j ),c(1 ,dimy + 1 )) )- > ssfoo
319+ for ( j in 1 : nrow(walls ) ) lines(walls [j ,c(1 ,3 )],walls [j ,c(2 ,4 )],col = ' white'
320+ par(mar = c(mardef ))
321+ }
0 commit comments