-
Notifications
You must be signed in to change notification settings - Fork 0
/
perlin.scm
104 lines (93 loc) · 3.65 KB
/
perlin.scm
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
(define-module perlin
(use srfi-27)
(use srfi-43)
(use vec :prefix v:)
(export noise)
(export turb))
(select-module perlin)
(define (perlin-generate-float)
(vector-tabulate
256 (lambda (x) (random-real))))
(define (perlin-generate-vec)
(vector-tabulate
256 (lambda (x) (v:unit (v:vec3 (+ -1 (* 2 (random-real)))
(+ -1 (* 2 (random-real)))
(+ -1 (* 2 (random-real))))))))
(define (permute p n)
(let loop ((i (- n 1)))
(if (> i 0)
(let ((target (floor->exact (* (random-real) (+ i 1)))))
(vector-swap! p i target)
(loop (- i 1)))))
p)
(define (perlin-generate-perm)
(let ((p (vector-tabulate 256 (lambda (x) x))))
(permute p 256)))
(define +ranfloat+ (perlin-generate-float))
(define +ranvec+ (perlin-generate-vec))
(define +perm-x+ (perlin-generate-perm))
(define +perm-y+ (perlin-generate-perm))
(define +perm-z+ (perlin-generate-perm))
(define (trilinear-interp c u v w)
(let ((acc 0))
(dotimes (i 2)
(dotimes (j 2)
(dotimes (k 2)
(inc! acc (* (+ (* i u) (* (- 1 i) (- 1 u)))
(+ (* j v) (* (- 1 j) (- 1 v)))
(+ (* k w) (* (- 1 k) (- 1 w)))
(vector-ref (vector-ref (vector-ref c i)
j)
k))))))
acc))
(define (perlin-interp c u v w)
(let ((uu (* u u (- 3 (* 2 u))))
(vv (* v v (- 3 (* 2 v))))
(ww (* w w (- 3 (* 2 w))))
(acc 0))
(dotimes (i 2)
(dotimes (j 2)
(dotimes (k 2)
(inc! acc (* (+ (* i uu) (* (- 1 i) (- 1 uu)))
(+ (* j vv) (* (- 1 j) (- 1 vv)))
(+ (* k ww) (* (- 1 k) (- 1 ww)))
(v:dot
(v:vec3 (- u i) (- v j) (- w k))
(vector-ref (vector-ref (vector-ref c i)
j)
k)))))))
acc))
(define (noise p)
(let* ((u (- (v:x p) (floor->exact (v:x p))))
(v (- (v:y p) (floor->exact (v:y p))))
(w (- (v:z p) (floor->exact (v:z p))))
(i (floor->exact (v:x p)))
(j (floor->exact (v:y p)))
(k (floor->exact (v:z p)))
(c (make-vector 2 (make-vector 2 (make-vector 2)))))
(dotimes
(di 2)
(dotimes
(dj 2)
(dotimes
(dk 2)
(set! (vector-ref (vector-ref (vector-ref c di)
dj)
dk)
(vector-ref +ranvec+
(logxor (vector-ref +perm-x+ (logand (+ i di) 255))
(vector-ref +perm-y+ (logand (+ j dj) 255))
(vector-ref +perm-z+ (logand (+ k dk) 255))))))))
(perlin-interp c u v w)))
(define (turb p . ops)
(let-optionals* ops ((max-depth 7))
(let loop ((depth 0)
(acc 0)
(p p)
(weight 1))
(if (< depth max-depth)
(loop (+ depth 1)
(+ acc (* weight (noise p)))
(v:scale p 2)
(* weight 0.5))
(abs acc)))))