minecraft style level gen in racket

levelgen.rkt

#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)