Skip to content

@thomcc /levelgen.rkt
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
minecraft style level gen in racket
#lang racket/gui
(define (floor* n [v 1.0])
(inexact->exact (floor (/ n v))))
(define (offset n v)
(+ n (- (random v) (random v))))
(define (take-average lst)
(let ([n (exact->inexact (length lst))])
(for/sum ([e (in-list lst)]) (/ e n))))
(define (scaled-diff a b) (- (* (abs (- a b)) 3.0) 2.0))
(define (diff a b) (abs (- a b)))
(define (scaled-diff3 a b c) (scaled-diff (diff a b) c))
(define (max-distance x y w h)
(max (abs (sub1 (* 2.0 (/ x (- w 1.0)))))
(abs (sub1 (* 2.0 (/ y (- h 1.0)))))))
(define noise-diff
(case-lambda
[(n1 n2 i) (scaled-diff (n1 i) (n2 i))]
[(n1 n2 n3 i) (scaled-diff (diff (n1 i) (n2 i)) (n3 i))]))
(define (gen-noise w h feature-size)
(let ([data (make-vector (* w h) 0.0)] [maximum (* w h)])
(define (sample x y)
(vector-ref data (+ (bitwise-and x (sub1 w)) (* w (bitwise-and y (sub1 h))))))
(define (set-sample x y v)
(vector-set! data (+ (bitwise-and x (sub1 w)) (* w (bitwise-and y (sub1 h)))) v))
(define (scaled-random [scale 1.0]) (* scale (sub1 (* 2.0 (random)))))
(for* ([y (in-range 0 w feature-size)] [x (in-range 0 w feature-size)])
(set-sample x y (scaled-random)))
(let loop ([step-size feature-size] [scale (/ 1.0 w)] [scale-mod 1.0])
(let ([half-step (floor* step-size 2)])
(define (calc-posn . items)
(+ (scaled-random (* step-size scale))
(take-average items)))
(for* ([y (in-range 0 w step-size)] [x (in-range 0 w step-size)])
(set-sample
(+ x half-step) (+ y half-step)
(calc-posn (sample x y)
(sample (+ x step-size) y)
(sample x (+ y step-size))
(sample (+ x step-size) (+ y step-size)))))
(for* ([y (in-range 0 w step-size)] [x (in-range 0 w step-size)])
(set-sample (+ x half-step) y
(calc-posn (sample x y)
(sample (+ x step-size) y)
(sample (+ x half-step) (+ y half-step))
(sample (+ x half-step) (- y half-step))))
(set-sample x (+ y half-step)
(calc-posn (sample x y)
(sample x (+ y step-size))
(sample (+ x half-step) (+ y half-step))
(sample (- x half-step) (- y half-step)))))
(let ([step-size (floor* step-size 2)])
(when (> step-size 1)
(loop step-size
(* scale (+ scale-mod 0.8))
(* scale-mod 0.3))))))
(case-lambda
[(i) (vector-ref data (modulo i maximum))]
[(x y) (sample x y)])))
(define (biome #:predicate [pred (const #t)]; predicate: should we set this tile? a function of (tile -> boolean)
#:check-position [pcheck (const #t)]; check-position: is this position okay? (checked after bounds-checks)
#:result [result (const 'grass)]; result: the function which maps input tiles to output tiles
#:size-multiplier [size-mul 1] ; spot-sets per biome, essentially
#:spots [spots 100] ; spots: how many spots should we set when we settle on a location
#:spot-size [spot-size 1] ; spot-size: size of spot (how filled-in the biome is)
#:frequency [freq 1/1000] ; apply-biome is run (* width height frequency) times
#:offset [offset-sz 10]) ; jitter applied to spot's x and y value.
(lambda (map width height)
(for* ([i (in-range (inexact->exact (floor (* width height freq))))]
[xs (in-value (random width))]
[ys (in-value (random height))]
[k (in-range size-mul)]
[x (in-value (+ xs (- (random (add1 (* 2 size-mul))) size-mul)))]
[y (in-value (+ ys (- (random (add1 (* 2 size-mul))) size-mul)))]
[j (in-range spots)]
[xo (in-value (offset x offset-sz))]
[yo (in-value (offset y offset-sz))]
[yy (in-range (- yo (sub1 spot-size)) (+ yo spot-size))]
[xx (in-range (- xo (sub1 spot-size)) (+ xo spot-size))]
#:when (and (< -1 xx width) (< -1 yy height) (pcheck xx yy))
[s (in-value (vector-ref map (+ xx (* yy width))))]
#:when (pred s))
(vector-set! map (+ xx (* yy width)) (result s)))))
(provide create-map)
(define (create-map w h)
(let ([mnoise1 (gen-noise w h 16)]
[mnoise2 (gen-noise w h 16)]
[mnoise3 (gen-noise w h 16)]
[noise1 (gen-noise w h 32)]
[noise2 (gen-noise w h 32)]
[map (make-vector (* w h) 0)])
(for* ([y (in-range h)]
[x (in-range w)]
[i (in-value (+ x (* y w)))])
(let* ([val (noise-diff noise1 noise2 i)]
[mval (noise-diff mnoise1 mnoise2 mnoise3 i)]
[dist (max-distance x y w h)]
[val (- (add1 val) (* (expt dist 16) 20.0))])
(cond
[(< val -0.5) (vector-set! map i 'water)]
[(and (> val 0.5) (< mval -1.5)) (vector-set! map i 'rock)]
[else (vector-set! map i 'grass)])))
(define desert
(biome #:predicate (λ (tile) (eq? tile 'grass))
#:result (const 'sand)
#:frequency 1/2800
#:size-multiplier 10
#:spots 100
#:offset 5
#:spot-size 2))
(define forest
(biome #:predicate (λ (tile) (eq? tile 'grass))
#:result (const 'tree)
#:frequency 1/400
#:spots 100
#:offset 15))
(desert map w h)
(forest map w h)
map))
(define (test)
(define colors
(make-hasheq
`((water . ,(make-object color% 0 0 128))
(grass . ,(make-object color% 32 128 32))
(rock . ,(make-object color% 160 160 160))
(sand . ,(make-object color% 160 160 64))
(dirt . ,(make-object color% 96 64 64))
(tree . ,(make-object color% 0 48 0))
(lava . ,(make-object color% 255 32 32)))))
(define (make-map-bitmap)
(let* ([m (create-map 128 128)]
[b (make-bitmap 128 128)]
[dc (make-object bitmap-dc% b)])
(for* ([x (in-range 128)] [y (in-range 128)])
(send dc set-pixel x y (dict-ref colors (vector-ref m (+ x (* 128 y))))))
b))
(define test-frame
(new (class frame% (super-new)
(define c
(make-object
(class canvas% (super-new) (inherit get-dc refresh)
(define bmp (make-map-bitmap))
(define/override (on-size w h) (set))
(define/public (reset) (set! bmp (make-map-bitmap)) (refresh))
(define/override (on-paint)
(send* (get-dc)
(set-scale 4 4)
(draw-bitmap bmp 0 0))))
this))
(define b (new button% [label "another!"]
[parent this]
[callback (lambda _ (send c reset))])))
[label "maptest"]
[width (* 4 128)]
[height (* 4 128)]))
(send test-frame show #t))
(test)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.