Hypergiant/utils.scm at master · AlexCharlton/Hypergiant · GitHub

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
;;;; utils.scm

;;;; Small functions that don't have a home elsewhere
;;;; Imported by hypergiant.scm

(export update-string-mesh!
        make-string-mesh
        make-rgb-color make-rgba-color
        color-r color-g color-b color-a
        color-r-set! color-g-set! color-b-set! color-a-set!
        rgb-color-set! rgba-color-set!
        rgb-color-set-color! rgba-color-set-color!
        black white
        add-light)

(use srfi-4 miscmacros)

;;; Strings
(define (update-string-mesh! mesh node string face)
  (if (and node (zero? (string-length string)))
      (glls:set-renderable-n-elements! (scene:node-data node) 0)
      (begin
        (string-mesh string face mesh: mesh)
        (when node
          (glls:set-renderable-n-elements! (scene:node-data node)
                                           (mesh-n-indices mesh))))))

(define (make-string-mesh n-chars)
  (make-mesh vertices: `(attributes: ((position #:float 2)
                                      (tex-coord #:unsigned-short 2
                                                 normalized: #t))
                         n-vertices: ,(* n-chars 4))
             indices: `(type: #:ushort
                        n-indices: ,(* n-chars 6))))

;;; Colors
(define (make-rgb-color r g b #!optional non-gc?)
  (let ((v (make-f32vector 3 0 non-gc?)))
    (f32vector-set! v 0 r)
    (f32vector-set! v 1 g)
    (f32vector-set! v 2 b)
    v))

(define (make-rgba-color r g b a #!optional non-gc?)
  (let ((v (make-f32vector 4 0 non-gc?)))
    (f32vector-set! v 0 r)
    (f32vector-set! v 1 g)
    (f32vector-set! v 2 b)
    (f32vector-set! v 3 a)
    v))

(define (color-r c)
  (f32vector-ref c 0))

(define (color-g c)
  (f32vector-ref c 1))

(define (color-b c)
  (f32vector-ref c 2))

(define (color-a c)
  (f32vector-ref c 3))

(define (color-r-set! c r)
  (f32vector-set! c 0 r))

(define (color-g-set! c g)
  (f32vector-set! c 1 g))

(define (color-b-set! c b)
  (f32vector-set! c 2 b))

(define (color-a-set! c a)
  (f32vector-set! c 3 a))

(define (rgb-color-set! c r g b)
  (color-r-set! c r)
  (color-g-set! c g)
  (color-b-set! c b))

(define (rgba-color-set! c r g b a)
  (rgb-color-set! c r g b)
  (color-a-set! c a))

(define (rgb-color-set-color! c d)
  (color-r-set! c (color-r d))
  (color-g-set! c (color-g d))
  (color-b-set! c (color-b d)))

(define (rgba-color-set-color! c d)
  (rgb-color-set-color! c d)
  (color-a-set! c (color-a d)))

(define black (make-rgb-color 0 0 0 #t))
(define white (make-rgb-color 1 1 1 #t))

;;; Hyperscene
(define (add-light node color intensity . args)
  (let ((light (apply scene:add-light node color intensity args)))
    (if* (get-keyword position: args)
         (scene:set-node-position! light it))
    (if* (get-keyword radius: args)
         (scene:set-node-bounding-sphere! light it))
    light))