-
Notifications
You must be signed in to change notification settings - Fork 1
/
generator.rkt
executable file
·150 lines (117 loc) · 6.38 KB
/
generator.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
#lang racket/gui
(provide fill-generator% uniform-random-fill-generator% rogue-dungeon-generator%)
(require "scene.rkt" "point.rkt" "util.rkt" "room.rkt")
(define fill-generator%
(class object%
(init-field scene canvas tiles)
(field [tile null] [new-scene null])
(super-new)
(define/public (get-scene) new-scene)
(define dialog (new (class dialog% (init label)
(super-new [label label])
(define/override (on-subwindow-char receiver event)
(case (send event get-key-code)
[(#\return) (set-tile ok-btn event)]
[(escape) (send this show #f)]
[else #f])))
[label "Choose a tile"]))
(define hpanel (new horizontal-panel% [parent dialog]))
(define tile-choices
(new choice% [label "Tiles"] [parent hpanel] [choices (map tile-descr tiles)]))
(define choice->tile ((curry list-ref) tiles))
(define (set-tile btn evt)
(when (not (null? scene))
(let* ([t (choice->tile (send tile-choices get-selection))]
[s (make-object scene% (send scene get-width) (send scene get-height) t)])
(set! new-scene s)
(send dialog show #f))))
(define ok-btn (new button% [label "OK"] [parent hpanel] [callback set-tile]))
(define/public (process)
(send dialog show #t))))
(define uniform-random-fill-generator%
(class object%
(init-field scene canvas tiles num-tiles)
(super-new)
(define (place-random-tile tiles)
(send scene set
(sub1 (random (send scene get-width)))
(sub1 (random (send scene get-height)))
(random-element tiles)))
(define dialog (new (class dialog% (init label)
(super-new [label label])
(define/override (on-subwindow-char receiver event)
(case (send event get-key-code)
[(#\return) (set-tile ok-btn event)]
[(escape) (send this show #f)]
[else #f])))
[label "Choose a tile"]))
(define hpanel (new horizontal-panel% [parent dialog]))
(define tile-choices
(new list-box% [label ""] [parent hpanel] [choices (map tile-descr tiles)]
[style (list 'multiple)] [min-width 200] [min-height 200]))
(define vpanel (new vertical-panel% [parent hpanel]))
(define choice->tile ((curry list-ref) tiles))
(define number-field (new text-field% [label "Amount to add"] [parent vpanel]))
(define (set-tile btn evt)
(if (null? (send tile-choices get-selections)) (send this process)
(let ([tiles (map choice->tile (send tile-choices get-selections))])
(let loop ([n (string->number (send number-field get-value))])
(place-random-tile tiles)
(unless (zero? n) (loop (sub1 n))))
(send dialog show #f))))
(define ok-btn (new button% [label "OK"] [parent vpanel] [callback set-tile]))
(define/public (process)
(send number-field set-value "10")
(send dialog show #t))))
(define rogue-dungeon-generator%
(class object%
(init-field scene canvas tiles rooms)
(field [new-rooms null]
[paths null]
[tile null]
[xmin 5]
[xmax 7]
[ymin 5]
[ymax 7]
[num-rooms 6])
(super-new)
(define (add-room! r) (set! new-rooms (append new-rooms (list r))))
(define dialog (new dialog% [label "Choose a tile"]))
(define hpanel (new horizontal-panel% [parent dialog]))
(define tile-choices (new choice% [label "Tiles"] [parent hpanel] [choices (map tile-descr tiles)]))
(define (room-ok? r rs) (and (andmap (lambda (v) (< v 3)) (map (lambda (v) (room-distance v r)) rs))
(andmap (lambda (v) (room-intersects? r v)) rs)))
(define (set-tile btn evt)
(send dialog show #f)
(let place-rooms ([n num-rooms])
(unless (<= n 0)
(let* ([p (random-pt 0 (send scene get-width) 0 (send scene get-height))]
[width (random-integer xmin xmax)] [height (random-integer ymin ymax)]
[q (pt-add p (pt width height))] [walls null] [interior null])
(trace-filled-rectangle (lambda (x y)
(if (or (= x (pt-x q)) (= x (pt-x p)) (= y (pt-y p)) (= y (pt-y q)))
(set! walls (append walls (list (pt x y))))
(set! interior (append interior (list (pt x y)))))) p q)
(let ([r (room walls interior)])
(if (room-ok? r (append rooms new-rooms))
(begin (set! new-rooms (append new-rooms (list r))) (place-rooms (sub1 n)))
(place-rooms n))))))
(let connect-rooms ([unconnected-rooms (append rooms new-rooms)])
(unless (null? unconnected-rooms)
(when (= 1 (length unconnected-rooms))
(set! unconnected-rooms (append unconnected-rooms (random-element rooms))))
(let* ([r1 (random-element unconnected-rooms)]
[r2 (random-element (filter (lambda (r) (false? (equal? r r1))) unconnected-rooms))])
(let* ([pts null] [p1 (random-wall-pt r1)] [p3 (random-wall-pt r2)] [p2 (pt (pt-x p1) (pt-y p3))])
(trace-line (lambda (x y) (set! pts (append pts (list (pt x y))))) p1 p2)
(trace-line (lambda (x y) (set! pts (append pts (list (pt x y))))) p2 p3)
(set! paths (append paths (list (path r1 r2 pts)))))
(connect-rooms (filter (lambda (r) (and (false? (equal? r r1)) (false? (equal? r r2))))
unconnected-rooms)))))
(let ([t (list-ref tiles (send tile-choices get-selection))])
(map (lambda (r) (map (lambda (p) (send scene set (pt-x p) (pt-y p) t)) (room-wall-pts r))) new-rooms)
(map (lambda (path) (map (lambda (p) (send scene set (pt-x p) (pt-y p) t)) (path-pts path))) paths)))
(define ok-btn (new button% [label "OK"] [parent hpanel] [callback set-tile]))
(define/public (get-rooms) (append rooms new-rooms))
(define/public (process)
(send dialog show #t))))