108 lines
3.7 KiB
Scheme
108 lines
3.7 KiB
Scheme
; Save bitmap to external file
|
|
(define (save-pbm bitmap filename)
|
|
(define f (open-output-file filename))
|
|
(simple-format f "P1\n~A ~A\n"
|
|
(list-ref (array-dimensions bitmap) 0)
|
|
(list-ref (array-dimensions bitmap) 1))
|
|
(do ((c 0 (+ c 1))) ((eqv? c (list-ref (array-dimensions bitmap) 1)))
|
|
(do ((r 0 (+ r 1))) ((eqv? r (list-ref (array-dimensions bitmap) 0)))
|
|
(display (array-ref bitmap r c) f))
|
|
(newline f))
|
|
(close-output-port f)
|
|
)
|
|
|
|
; Return a random coordinate in the bitmap that isn't filled yet along with a direction
|
|
(define (new-particle bitmap)
|
|
(define x (random (list-ref (array-dimensions bitmap) 0)))
|
|
(define y (random (list-ref (array-dimensions bitmap) 1)))
|
|
(define dx (- (random 3) 1))
|
|
(define dy (- (random 3) 1))
|
|
;Repeat until we find an unused location
|
|
(if (> (array-ref bitmap x y) 0)
|
|
(new-particle bitmap)
|
|
(list (list x y) (list dx dy))))
|
|
|
|
; Check neighboring coordinates to see if a collision occured
|
|
(define (collision-check bitmap p)
|
|
(define c #f)
|
|
(define oob #f)
|
|
(define x (list-ref (car p) 0))
|
|
(define y (list-ref (car p) 1))
|
|
(define dx (list-ref (cadr p) 0))
|
|
(define dy (list-ref (cadr p) 1))
|
|
(define w (list-ref (array-dimensions bitmap) 0))
|
|
(define h (list-ref (array-dimensions bitmap) 1))
|
|
|
|
; If the particle hasn't gone out of bounds keep checking for a collision
|
|
(if (or (> 0 x) (> 0 y) (<= w x) (<= h y))
|
|
(set! oob #t)
|
|
(do ((x (- (list-ref (car p) 0) 1) (+ x 1))) ((eqv? x (+ (list-ref (car p) 0) 2)))
|
|
(do ((y (- (list-ref (car p) 1) 1) (+ y 1))) ((eqv? y (+ (list-ref (car p) 1) 2)))
|
|
; Check existing neighbors for collisions
|
|
(if (and (<= 0 x) (<= 0 y) (> w x) (> h y))
|
|
(if (not (zero? (array-ref bitmap x y)))
|
|
(set! c #t))))))
|
|
(if oob
|
|
#f ; Return false if out of bounds
|
|
(if c
|
|
p ; Return the point of collision if a collision occured
|
|
(if (and (zero? dx) (zero? dy))
|
|
#f ; Return false if particle is motionless with no collision
|
|
(collision-check bitmap (particle-move p))))))
|
|
|
|
; Plot a particle on the bitmap
|
|
(define (particle-plot! bitmap p)
|
|
(array-set! bitmap 1 (list-ref (car p) 0) (list-ref (car p) 1)))
|
|
|
|
; Move a particle along its slope
|
|
(define (particle-move p)
|
|
(list (list
|
|
(+ (list-ref (car p) 0) (list-ref (cadr p) 0))
|
|
(+ (list-ref (car p) 1) (list-ref (cadr p) 1)))
|
|
(cadr p)))
|
|
|
|
; Grow a brownian tree
|
|
(define (grow-brownian-tree! bitmap collisions)
|
|
(define w (list-ref (array-dimensions bitmap) 0))
|
|
(define h (list-ref (array-dimensions bitmap) 1))
|
|
|
|
; Generate a new particle at a random location
|
|
(define p (new-particle bitmap))
|
|
|
|
; Find a collision or lack of one and plot it on the bitmap
|
|
(set! p (collision-check bitmap p))
|
|
(if p (begin
|
|
; Display collision number and the place it happened
|
|
(display collisions)(display ": ")(display (car p))(newline)
|
|
(set! collisions (- collisions 1))
|
|
; Plot the point
|
|
(particle-plot! bitmap p)))
|
|
|
|
; If we're done say so
|
|
(if (zero? collisions)
|
|
(display "Done\n"))
|
|
|
|
; Keep going until we have enough collisions
|
|
; or have filled the bitmap
|
|
(if (and (< 0 collisions) (memq 0 (array->list (array-contents bitmap))))
|
|
(grow-brownian-tree! bitmap collisions)))
|
|
|
|
; Plot a random point to seed the brownian tree
|
|
(define (seed-brownian-tree! bitmap)
|
|
(define p (new-particle bitmap))
|
|
(particle-plot! bitmap p))
|
|
|
|
;;; Example usage ;;;
|
|
; Seed the random number generator
|
|
(let ((time (gettimeofday)))
|
|
(set! *random-state*
|
|
(seed->random-state (+ (car time) (cdr time)))))
|
|
|
|
; Generate a tree with 320*240 collisions on a bitmap of the size 640x480
|
|
; The bitmap is zeroed to start and written with a one where a collision occurs
|
|
(define bitmap (make-array 0 640 480))
|
|
(seed-brownian-tree! bitmap)
|
|
(grow-brownian-tree! bitmap (* 320 240))
|
|
|
|
; Save to a portable bitmap file
|
|
(save-pbm bitmap "brownian-tree.pbm")
|