2007-09-20 18:09:08 -04:00
|
|
|
! From http://www.ffconsultancy.com/ocaml/maze/index.html
|
2013-02-14 17:36:11 -05:00
|
|
|
USING: accessors arrays fry kernel math math.order math.vectors
|
2018-01-27 14:07:00 -05:00
|
|
|
namespaces opengl.demo-support opengl.gl random sequences ui
|
|
|
|
ui.gadgets ui.gadgets.canvas ui.render ;
|
2007-09-20 18:09:08 -04:00
|
|
|
IN: maze
|
|
|
|
|
2009-02-23 22:40:17 -05:00
|
|
|
CONSTANT: line-width 8
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
SYMBOL: visited
|
|
|
|
|
|
|
|
: unvisited? ( cell -- ? ) first2 visited get ?nth ?nth ;
|
|
|
|
|
|
|
|
: visit ( cell -- ) f swap first2 visited get ?nth ?set-nth ;
|
|
|
|
|
|
|
|
: choices ( cell -- seq )
|
|
|
|
{ { -1 0 } { 1 0 } { 0 -1 } { 0 1 } }
|
2008-01-09 17:36:30 -05:00
|
|
|
[ v+ ] with map
|
2008-04-26 00:17:08 -04:00
|
|
|
[ unvisited? ] filter ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: random-neighbour ( cell -- newcell ) choices random ;
|
|
|
|
|
|
|
|
: vertex ( pair -- )
|
2008-03-29 21:36:58 -04:00
|
|
|
first2 [ 0.5 + line-width * ] bi@ glVertex2d ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: (draw-maze) ( cell -- )
|
|
|
|
dup vertex
|
|
|
|
glEnd
|
2018-01-27 14:07:00 -05:00
|
|
|
GL_POINTS [ dup vertex ] do-state
|
2007-09-20 18:09:08 -04:00
|
|
|
GL_LINE_STRIP glBegin
|
|
|
|
dup vertex
|
|
|
|
dup visit
|
|
|
|
dup random-neighbour dup [
|
|
|
|
(draw-maze) (draw-maze)
|
|
|
|
] [
|
|
|
|
2drop
|
|
|
|
glEnd
|
|
|
|
GL_LINE_STRIP glBegin
|
|
|
|
] if ;
|
|
|
|
|
|
|
|
: draw-maze ( n -- )
|
|
|
|
line-width 2 - glLineWidth
|
|
|
|
line-width 2 - glPointSize
|
|
|
|
1.0 1.0 1.0 1.0 glColor4d
|
2013-02-14 17:36:11 -05:00
|
|
|
dup '[ _ t <array> ] replicate visited set
|
2018-01-27 14:07:00 -05:00
|
|
|
GL_LINE_STRIP [
|
|
|
|
{ 0 0 } dup vertex (draw-maze)
|
|
|
|
] do-state ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-08-27 17:24:04 -04:00
|
|
|
TUPLE: maze < canvas ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-08-27 17:24:04 -04:00
|
|
|
: <maze> ( -- gadget ) maze new-canvas ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2009-02-05 04:28:41 -05:00
|
|
|
: n ( gadget -- n ) dim>> first2 min line-width /i ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
M: maze layout* delete-canvas-dlist ;
|
|
|
|
|
|
|
|
M: maze draw-gadget* [ n draw-maze ] draw-canvas ;
|
|
|
|
|
|
|
|
M: maze pref-dim* drop { 400 400 } ;
|
|
|
|
|
2010-01-15 19:55:43 -05:00
|
|
|
MAIN-WINDOW: maze-window { { title "Maze" } }
|
|
|
|
<maze> >>gadgets ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
MAIN: maze-window
|