initial import from racket-sound -> racket-audio

2026-05-04 12:07:45 +02:00
parent f500f1711b
commit 87980f508a
28 changed files with 6282 additions and 16 deletions
@@ -0,0 +1,126 @@
+(module utils racket/base
+
+  (require racket/path
+           racket/runtime-path
+           ffi/unsafe
+           setup/dirs
+           "downloader.rkt"
+           simple-log
+           )
+  
+  (provide while
+           until
+           build-lib-path
+           get-lib
+           do-for
+           dbg-sound
+           info-sound
+           err-sound
+           warn-sound
+           fatal-sound
+           sync-log-sound
+           integer->int-bytes
+           int-bytes->integer
+           )
+
+  (sl-def-log racket-sound sound)
+
+  (define-syntax while
+    (syntax-rules ()
+      ((_ cond body ...)
+       (letrec ((while-f (lambda (last-result)
+                           (if cond
+                               (let ((last-result (begin
+                                                    body
+                                                    ...)))
+                                 (while-f last-result))
+                               last-result))))
+         (while-f #f))
+       )
+      ))
+
+  (define-syntax until
+    (syntax-rules ()
+      ((_ cond body ...)
+       (letrec ((until-f (lambda (last-result)
+                           (if cond
+                               last-result
+                               (let ((last-reult (begin
+                                                   body
+                                                   ...)))
+                                 (until-f last-result))))))
+         (until-f #f)))))
+
+  (define-syntax do-for
+    (syntax-rules ()
+      ((_ (init cond next) body ...)
+       (begin
+         init
+         (letrec ((do-for-f (lamba ()
+                                   (if cond
+                                       (begin
+                                         (begin
+                                           body
+                                           ...)
+                                         next
+                                         (do-for-f))))))
+           (do-for-f))))))
+
+
+  (define (build-lib-path)
+    (soundlibs-directory))
+
+  (define (get-lib* libs-to-try orig-libs versions)
+    (let ((libs-path (cons (build-lib-path) (get-lib-search-dirs))))
+      (unless (soundlibs-available?)
+        (download-soundlibs))
+      (if (null? libs-to-try)
+          (begin
+            (displayln (format "Warning: Cannot find library, tried ~a in ~a" orig-libs libs-path))
+            #f)
+          (ffi-lib (car libs-to-try) versions
+                   #:get-lib-dirs (λ () libs-path)
+                   #:fail (λ ()
+                            (ffi-lib (car libs-to-try) versions
+                                     #:fail (λ () 
+                                              (get-lib* (cdr libs-to-try) orig-libs versions))))
+                   )
+          )
+      )
+    )
+
+  (define (get-lib libs-to-try versions)
+    (get-lib* libs-to-try libs-to-try versions))
+
+  (define-syntax-rule (integer->int-bytes v size signed? big? bs pos)
+    (if (= size 3)
+        (if big?
+            (begin
+              (bytes-set! bs pos       (bitwise-and (arithmetic-shift v -16) #xff))
+              (bytes-set! bs (+ pos 1) (bitwise-and (arithmetic-shift v -8)  #xff))
+              (bytes-set! bs (+ pos 2) (bitwise-and v #xff)))
+            (begin
+              (bytes-set! bs pos       (bitwise-and v #xff))
+              (bytes-set! bs (+ pos 1) (bitwise-and (arithmetic-shift v -8)  #xff))
+              (bytes-set! bs (+ pos 2) (bitwise-and (arithmetic-shift v -16) #xff))))
+        (integer->integer-bytes v size signed? big? bs pos)))
+
+  (define-syntax-rule (int-bytes->integer bs signed? big? start end)
+    (let ([size (- end start)])
+      (if (= size 3)
+          (let* ([b0 (bytes-ref bs start)]
+                 [b1 (bytes-ref bs (+ start 1))]
+                 [b2 (bytes-ref bs (+ start 2))]
+                 [u  (if big?
+                         (bitwise-ior (arithmetic-shift b0 16)
+                                      (arithmetic-shift b1 8)
+                                      b2)
+                         (bitwise-ior b0
+                                      (arithmetic-shift b1 8)
+                                      (arithmetic-shift b2 16)))])
+            (if (and signed? (not (zero? (bitwise-and u #x800000))))
+                (- u #x1000000)
+                u))
+          (integer-bytes->integer bs signed? big? start end))))
+  
+) ; end of module