diff --git a/flac-decoder.rkt b/flac-decoder.rkt index ed07eaf..010e172 100644 --- a/flac-decoder.rkt +++ b/flac-decoder.rkt @@ -96,7 +96,7 @@ (for ([channel (in-range channels)]) (let* ([chan (ptr-ref buffer _pointer channel)] [sample (ptr-ref chan _int32 k)]) - (integer->integer-bytes sample bytes #t big? bs out-pos) + (integer->int-bytes sample bytes #t big? bs out-pos) (set! out-pos (+ out-pos bytes))))) ;(memcpy out bs buf-size) diff --git a/libao-async-ffi-racket.rkt b/libao-async-ffi-racket.rkt index 9677693..9c4360b 100644 --- a/libao-async-ffi-racket.rkt +++ b/libao-async-ffi-racket.rkt @@ -59,11 +59,11 @@ (define libao (get-lib (list (case (system-type 'os) [(windows) "libao-1.2.2"] - [else "ao"])) '(#f))) + [else "libao"])) '(#f))) (define-ffi-definer define-ao libao) -(define _ao-device (_cpointer 'ao-device)) +(define _ao-device (_cpointer/null 'ao-device)) (define _ao-option (_cpointer/null 'ao-option)) (define-cstruct _ao_sample_format @@ -87,7 +87,7 @@ (define-ao ao_play ;(_fun #:blocking? #t _ao-device _pointer _uint32 -> _int)) ;(_fun _ao-device _pointer _uint32 -> _int)) - (_fun _ao-device _bytes _uint32 -> _int)) + (_fun #:blocking? #t _ao-device _bytes _uint32 -> _int)) ;; ------------------------------------------------------------------------- ;; Mutex stuff @@ -209,114 +209,8 @@ ;;; Volume -#| -(define (adjust-volume h buf buf-size volume-in-10000) - (let* ((bytes-per-sample (ao-handle-dev-bits-per-sample h)) - (endianness (ao-handle-dev-endianness h)) - (i 0) - (sample 0) - (sample32 #f) - (k 0) - (little-endian (if (eq? endianness 'little-endian) - #t - (if (eq? endianness 'native-endian) - (system-little-endian?) - #f))) - ) - (while (< i buf-size) - (if little-endian - (begin - (set! sample (if (> (ptr-ref buf _uint8 (- i 1)) 127) - -1 - 0)) - (set! k (- (+ bytes-per-sample i) 1)) - (while (>= k i) - (set! sample (bitwise-ior (arithmetic-shift sample 8) - (ptr-ref buf _uint8 k))) - (set! k (- k 1))) - ) - (begin - (set! sample (if (> (ptr-ref buf _uint8 i) 127) - -1 - 0)) - (set! k i) - (while (< k (+ i bytes-per-sample)) - (set! sample (bitwise-ior (arithmetic-shift sample 8) - (ptr-ref buf _uint8 k))) - (set! k (+ k 1))) - )) - (set! sample (round (inexact->exact (/ (* sample volume-in-10000) 10000)))) - (set! sample32 (integer->integer-bytes sample 4 #f (not little-endian))) - (set! k 0) - (while (< k bytes-per-sample) - (ptr-set! buf _uint8 (+ i k) (bytes-ref sample32 k)) - (set! k (+ k 1))) - - (set! i (+ i bytes-per-sample)) - ) - ) - ) -|# -#| -(define (adjust-volume h buf buf-size volume-in-10000) - (let* ((bits (ao-handle-dev-bits-per-sample h)) - (bytes-per-sample (arithmetic-shift bits -3)) - (endianness (ao-handle-dev-endianness h)) - (little-endian? (if (eq? endianness 'little-endian) - #t - (if (eq? endianness 'native-endian) - (system-little-endian?) - #f))) - (sample 0) - ) - - (for ([i (in-range 0 buf-size bytes-per-sample)]) - - ;; read signed sample - (set! sample - (if little-endian? - (let ([last (+ i bytes-per-sample -1)]) - (let loop ([k last] - [s (if (> (ptr-ref buf _uint8 last) 127) -1 0)]) - (if (< k i) - s - (loop (sub1 k) - (bitwise-ior - (arithmetic-shift s 8) - (ptr-ref buf _uint8 k)))))) - (let ([first i]) - (let loop ([k first] - [s (if (> (ptr-ref buf _uint8 first) 127) -1 0)]) - (if (= k (+ i bytes-per-sample)) - s - (loop (add1 k) - (bitwise-ior - (arithmetic-shift s 8) - (ptr-ref buf _uint8 k)))))))) - - ;; scale - (set! sample (quotient (* sample volume-in-10000) 10000)) - - ;; write signed sample back - (if little-endian? - (let loop ([k i] - [s sample]) - (unless (= k (+ i bytes-per-sample)) - (ptr-set! buf _uint8 k (bitwise-and s #xff)) - (loop (add1 k) (arithmetic-shift s -8)))) - (let loop ([k (+ i bytes-per-sample -1)] - [s sample]) - (unless (< k i) - (ptr-set! buf _uint8 k (bitwise-and s #xff)) - (loop (sub1 k) (arithmetic-shift s -8)))))) - - ) - #t - ) -|# - (define (adjust-volume h bs buf-size volume-in-10000) ;; bs: bytes ;; buf-size: aantal geldige bytes in bs @@ -327,64 +221,21 @@ (unless (= volume-in-10000 10000) (for ([i (in-range 0 buf-size bytes-per-sample)]) - (let* ([sample (integer-bytes->integer bs #t big? - i - (+ i bytes-per-sample))] + (let* ([sample (int-bytes->integer bs #t big? + i + (+ i bytes-per-sample))] [scaled (quotient (* sample volume-in-10000) 10000)]) - (integer->integer-bytes scaled - bytes-per-sample - #t - big? - bs - i)))) + (integer->int-bytes scaled + bytes-per-sample + #t + big? + bs + i)))) #t)) ;;; planar -> intereleaved -#| -(define (planar-to-interleaved mem buf-size info) - (let* ([type (buffer-info-type info)] - [bits (buffer-info-sample-bits info)] - [channels (buffer-info-channels info)] - [bytes (arithmetic-shift bits -3)] - [out-size buf-size] - [mem-out (malloc out-size 'atomic)]) - - (unless (or (eq? type 'planar) (eq? type 'flac)) - (error (format "expected planar buffer, got: ~a" type))) - - (unless (zero? (remainder buf-size (* channels bytes))) - (error (format "buffer size ~a is not aligned to ~a channels of ~a-bit samples" - buf-size channels bits))) - - (let* ([samples-total (quotient buf-size bytes)] - [samples-per-channel (quotient samples-total channels)] - [plane-size (* samples-per-channel bytes)]) - - (dbg-sound "~a ~a ~a ~a ~a" bits bytes buf-size samples-total samples-per-channel) - - ;; Input: - ;; C0[0] C0[1] ... C0[n] - ;; C1[0] C1[1] ... C1[n] - ;; - ;; Output: - ;; C0[0] C1[0] ... Ck[0] - ;; C0[1] C1[1] ... Ck[1] - ;; - (for ([sample-index (in-range samples-per-channel)]) - (for ([channel (in-range channels)]) - (let* ([in-pos (+ (* channel plane-size) - (* sample-index bytes))] - [out-pos (* (+ (* sample-index channels) - channel) - bytes)]) - (for ([b (in-range bytes)]) - (ptr-set! mem-out _uint8 (+ out-pos b) - (ptr-ref mem _uint8 (+ in-pos b))))))) - - (list mem-out out-size)))) -|# (define (planar-to-interleaved mem buf-size info) ;; mem: bytes @@ -420,54 +271,6 @@ ;;; requested bits to device bits -#| -(define (convert-bits buf buf-size in-bits in-endianness out-bits out-endianness) - (let* ([in-bytes (arithmetic-shift in-bits -3)] - [out-bytes (arithmetic-shift out-bits -3)] - [samples (quotient buf-size in-bytes)] - [out-size (* samples out-bytes)] - [out-buf (malloc out-size 'atomic)] - [shift (- out-bits in-bits)] - [in-little? (is-little-endian? in-endianness)] - [out-little? (is-little-endian? out-endianness)]) - - (for ([n (in-range samples)]) - (let* ([in-pos (* n in-bytes)] - [out-pos (* n out-bytes)] - [sample - (if in-little? - (let* ([last (+ in-pos in-bytes -1)] - [sign (if (> (ptr-ref buf _uint8 last) 127) -1 0)]) - (let loop ([k last] [s sign]) - (if (< k in-pos) - s - (loop (sub1 k) - (bitwise-ior - (arithmetic-shift s 8) - (ptr-ref buf _uint8 k)))))) - (let* ([first in-pos] - [sign (if (> (ptr-ref buf _uint8 first) 127) -1 0)]) - (let loop ([k first] [s sign]) - (if (= k (+ in-pos in-bytes)) - s - (loop (add1 k) - (bitwise-ior - (arithmetic-shift s 8) - (ptr-ref buf _uint8 k)))))))] - [converted (arithmetic-shift sample shift)]) - - (if out-little? - (let loop ([k out-pos] [s converted]) - (unless (= k (+ out-pos out-bytes)) - (ptr-set! out-buf _uint8 k (bitwise-and s #xff)) - (loop (add1 k) (arithmetic-shift s -8)))) - (let loop ([k (+ out-pos out-bytes -1)] [s converted]) - (unless (< k out-pos) - (ptr-set! out-buf _uint8 k (bitwise-and s #xff)) - (loop (sub1 k) (arithmetic-shift s -8))))))) - - (list out-buf out-size))) -|# (define (convert-bits buf buf-size in-bits in-endianness out-bits out-endianness) ;; buf: bytes @@ -485,41 +288,22 @@ (for ([n (in-range samples)]) (let* ([in-pos (* n in-bytes)] [out-pos (* n out-bytes)] - [sample (integer-bytes->integer - buf #t in-big? - in-pos - (+ in-pos in-bytes))] + [sample (int-bytes->integer buf #t in-big? in-pos (+ in-pos in-bytes))] [converted (arithmetic-shift sample shift)]) - (integer->integer-bytes converted - out-bytes - #t - out-big? - out - out-pos))) - + (integer->int-bytes converted out-bytes #t out-big? out out-pos))) + (list out out-size))) - - (define (convert-req-bits-to-dev-bits h mem buf-size info) (if (and (= (buffer-info-sample-bits info) (ao-handle-dev-bits-per-sample h)) (endian-eq? (buffer-info-endianness info) (ao-handle-dev-endianness h))) (list mem buf-size) - (begin - (dbg-sound "Converting info bits to dev bits: ~a ~a ~a ~a" - (buffer-info-sample-bits info) - (ao-handle-dev-bits-per-sample h) - (buffer-info-endianness info) - (ao-handle-dev-endianness h) - ) - - (convert-bits mem buf-size - (buffer-info-sample-bits info) - (buffer-info-endianness info) - (ao-handle-dev-bits-per-sample h) - (ao-handle-dev-endianness h) - ) - ) + (convert-bits mem buf-size + (buffer-info-sample-bits info) + (buffer-info-endianness info) + (ao-handle-dev-bits-per-sample h) + (ao-handle-dev-endianness h) + ) ) ) @@ -612,6 +396,7 @@ (set! i n) ) ) + (set! i (+ i 1)) ) ) @@ -775,339 +560,3 @@ (define (ao_real_output_bits_async h) (ao-handle-dev-bits-per-sample h)) - - - - - -#| -(define initialized? #f) -(define (ensure-ao-initialized!) - (unless initialized? - (ao_initialize) - (set! initialized? #t))) - -;; ------------------------------------------------------------------------- -;; Async player state. - -(struct play-frame (command music-id at-second music-duration data) #:transparent) - -(struct ao-async-handle - (device - requested-bits - device-bits - byte-format - channels - rate - queue - sema - lock - worker - paused-sema - paused-box - stopped-box - at-second-box - music-duration-box - at-music-id-box - buf-size-box - volume-box) - #:mutable) - -(define (with-lock l thunk) - (call-with-semaphore l thunk)) - -(define (box-set-under-lock! h b v) - (with-lock (ao-async-handle-lock h) - (lambda () (set-box! b v)))) - -(define (box-ref-under-lock h b) - (with-lock (ao-async-handle-lock h) - (lambda () (unbox b)))) - -(define (enqueue! h frame) - (with-lock (ao-async-handle-lock h) - (lambda () - (let ([q (ao-async-handle-queue h)] - [n (bytes-length (play-frame-data frame))]) - (q:enqueue! q frame) - (set-box! (ao-async-handle-buf-size-box h) - (+ (unbox (ao-async-handle-buf-size-box h)) n))))) - (semaphore-post (ao-async-handle-sema h))) - -(define (dequeue/timeout h timeout-ms) - (and (sync/timeout (/ timeout-ms 1000.0) (ao-async-handle-sema h)) - (with-lock (ao-async-handle-lock h) - (lambda () - (let ([q (ao-async-handle-queue h)]) - (and (not (q:queue-empty? q)) - (let ([frame (q:dequeue! q)]) - (set-box! (ao-async-handle-buf-size-box h) - (max 0 (- (unbox (ao-async-handle-buf-size-box h)) - (bytes-length (play-frame-data frame))))) - frame))))))) - - -(define (clear-queue! h) - (with-lock (ao-async-handle-lock h) - (lambda () - (let ([q (ao-async-handle-queue h)]) - (let loop () - (unless (q:queue-empty? q) - (q:dequeue! q) - (loop)))) - (set-box! (ao-async-handle-buf-size-box h) 0))) - ;; Drain semaphore posts that belonged to discarded queue elements. - (let loop () - (when (sync/timeout 0 (ao-async-handle-sema h)) - (loop)))) - -(define (wait-while-paused h) - (let loop () - (when (box-ref-under-lock h (ao-async-handle-paused-box h)) - (sync (ao-async-handle-paused-sema h)) - (loop)))) - -(define (player-loop h) - (let loop () - (wait-while-paused h) - (define frame (dequeue/timeout h 250)) - (cond - [(not frame) - (unless (box-ref-under-lock h (ao-async-handle-stopped-box h)) - (sleep 0.005) - (loop))] - [(eq? (play-frame-command frame) 'stop) - (box-set-under-lock! h (ao-async-handle-stopped-box h) #t) - (void)] - [else - (with-lock (ao-async-handle-lock h) - (lambda () - (set-box! (ao-async-handle-at-second-box h) (play-frame-at-second frame)) - (set-box! (ao-async-handle-music-duration-box h) (play-frame-music-duration frame)) - (set-box! (ao-async-handle-at-music-id-box h) (play-frame-music-id frame)))) - (define out (apply-volume h (play-frame-data frame))) - (ao_play (ao-async-handle-device h) out (bytes-length out)) - (loop)]))) - -;; ------------------------------------------------------------------------- -;; Opening and closing. - -(define (ao_async_version) 2) - -(define (make-format bits rate channels byte-format) - (make-ao_sample_format bits rate channels (endian->int byte-format) #f)) - -(define (endian->int e) - (case e - [(little-endian) 1] - [(big-endian) 2] - [(native-endian) 4] - [else e])) - -(define (try-open-device bits rate channels byte-format wav-file-output) - (define candidates - (append (list bits) - (if (> bits 24) (list 24) null) - (if (> bits 16) (list 16) null))) - (let loop ([xs candidates]) - (cond - [(null? xs) (values #f 0)] - [else - (define out-bits (car xs)) - (define fmt (make-format out-bits rate channels byte-format)) - (define dev - (if wav-file-output - (ao_open_file (ao_driver_id "wav") wav-file-output 1 fmt #f) - (ao_open_live (ao_default_driver_id) fmt #f))) - (if dev - (values dev out-bits) - (loop (cdr xs)))]))) - -(define (ao_create_async bits rate channels byte-format wav-file-output) - (ensure-ao-initialized!) - (define-values (dev opened-bits) - (try-open-device bits rate channels byte-format wav-file-output)) - (and dev - (letrec ([h (ao-async-handle dev - bits - opened-bits - byte-format - channels - rate - (q:make-queue) - (make-semaphore 0) - (make-semaphore 1) - #f - (make-semaphore 0) - (box #f) - (box #f) - (box -1.0) - (box 0.0) - (box -1) - (box 0) - (box 100.0))] - [t (thread (lambda () (player-loop h)))]) - (set-ao-async-handle-worker! h t) - h))) - -(define (ao_stop_async h) - (when h - (clear-queue! h) - (ao_pause_async h 0) - (enqueue! h (play-frame 'stop 0 0.0 0.0 #"")) - (thread-wait (ao-async-handle-worker h)) - (ao_close (ao-async-handle-device h)) - (void))) - -;; ------------------------------------------------------------------------- -;; Buffer conversion. - -(define (native-little-endian?) - ;(= 1 (integer-bytes->integer #"\1\0" #f #t))) - (not (system-big-endian?))) - -(define (little-endian-format? byte-format) - (case byte-format - [(little-endian) #t] - [(big-endian) #f] - [(native-endian) (native-little-endian?)] - [else (= byte-format 1)])) - -(define (copy-pointer-bytes ptr len) - (define bs (make-bytes len)) - (for ([i (in-range len)]) - (bytes-set! bs i (ptr-ref ptr _uint8 i))) - bs) - -(define (read-sample bs pos byte-count little?) - (define unsigned - (for/fold ([v 0]) ([i (in-range byte-count)]) - (define idx (if little? i (- byte-count i 1))) - (bitwise-ior v (arithmetic-shift (bytes-ref bs (+ pos idx)) (* 8 i))))) - (define bits (* byte-count 8)) - (define sign (arithmetic-shift 1 (- bits 1))) - (if (zero? (bitwise-and unsigned sign)) - unsigned - (- unsigned (arithmetic-shift 1 bits)))) - -(define (store-sample! bs pos byte-count little? sample) - (for ([i (in-range byte-count)]) - (define idx (if little? i (- byte-count i 1))) - (bytes-set! bs (+ pos idx) (bitwise-and sample #xff)) - (set! sample (arithmetic-shift sample -8)))) - -(define (convert-bits sample in-bits out-bits) - (cond - [(> in-bits out-bits) (arithmetic-shift sample (- out-bits in-bits))] - [(< in-bits out-bits) (arithmetic-shift sample (- out-bits in-bits))] - [else sample])) - -(define (convert-requested-to-real h bs info) - (define requested-bits (BufferInfo_t-sample_bits info)) - (define output-bits (ao-async-handle-device-bits h)) - (define in-bytes (/ requested-bits 8)) - (define out-bytes (/ output-bits 8)) - (cond - [(= requested-bits output-bits) bs] - [else - (define samples (quotient (bytes-length bs) in-bytes)) - (define out (make-bytes (* samples out-bytes))) - (define little? (little-endian-format? (ao-async-handle-byte-format h))) - (for ([s (in-range samples)]) - (define sample (read-sample bs (* s in-bytes) in-bytes little?)) - (define converted (convert-bits sample requested-bits output-bits)) - (store-sample! out (* s out-bytes) out-bytes little? converted)) - out])) - -(define (flac-pointer->interleaved-bytes ptr sample-count info) - ;; FLAC buffers are int32_t *buffer[]: channel-oriented signed 32-bit - ;; samples. buf_size is the number of samples per channel. - (define bits (BufferInfo_t-sample_bits info)) - (define bytes-per-sample (/ bits 8)) - (define channels (BufferInfo_t-channels info)) - (define little? (little-endian-format? (BufferInfo_t-endiannes info))) - (define out (make-bytes (* sample-count channels bytes-per-sample))) - (define pos 0) - (for ([k (in-range sample-count)]) - (for ([ch (in-range channels)]) - (define channel-ptr (ptr-ref ptr _pointer ch)) - (define sample (ptr-ref channel-ptr _int32 k)) - (store-sample! out pos bytes-per-sample little? sample) - (set! pos (+ pos bytes-per-sample)))) - out) - -(define (ao_play_async h music-id at-second music-duration buf-size mem info) - (define source - (case (BufferInfo_t-type info) - [(ao) (copy-pointer-bytes mem buf-size)] - [(flac) (flac-pointer->interleaved-bytes mem buf-size info)] - [(mp3 ogg) - (eprintf "format ~a not supported yet\n" (BufferInfo_t-type info)) - #f] - [else - (eprintf "unknown buffer type ~a\n" (BufferInfo_t-type info)) - #f])) - (when source - (define out (convert-requested-to-real h source info)) - (enqueue! h (play-frame 'play - music-id - (real->double-flonum at-second) - (real->double-flonum music-duration) - out)))) - -;; ------------------------------------------------------------------------- -;; Status and controls. - -(define (ao_clear_async h) - (clear-queue! h)) - -(define (ao_is_at_second_async h) - (box-ref-under-lock h (ao-async-handle-at-second-box h))) - -(define (ao_is_at_music_id_async h) - (box-ref-under-lock h (ao-async-handle-at-music-id-box h))) - -(define (ao_music_duration_async h) - (box-ref-under-lock h (ao-async-handle-music-duration-box h))) - -(define (ao_bufsize_async h) - (box-ref-under-lock h (ao-async-handle-buf-size-box h))) - -(define (ao_real_output_bits_async h) - (ao-async-handle-device-bits h)) - -(define (ao_pause_async h paused) - (define pause? (not (zero? paused))) - (with-lock (ao-async-handle-lock h) - (lambda () - (define was-paused? (unbox (ao-async-handle-paused-box h))) - (set-box! (ao-async-handle-paused-box h) pause?) - (when (and was-paused? (not pause?)) - (semaphore-post (ao-async-handle-paused-sema h)))))) - -(define (ao_set_volume_async h percentage) - ;; Keep the old public meaning: 100.0 means 100 percent. - (define v (if (integer? percentage) (exact->inexact percentage) percentage)) - (with-lock (ao-async-handle-lock h) - (lambda () - (set-box! (ao-async-handle-volume-box h) - (if (and (>= v 99.9) (<= v 100.1)) 100.0 v))))) - -(define (ao_volume_async h) - (box-ref-under-lock h (ao-async-handle-volume-box h))) - -(define (apply-volume h bs) - (define volume (box-ref-under-lock h (ao-async-handle-volume-box h))) - (cond - [(= volume 100.0) bs] - [else - (define out (bytes-copy bs)) - (define bytes-per-sample (/ (ao-async-handle-device-bits h) 8)) - (define little? (little-endian-format? (ao-async-handle-byte-format h))) - (define factor (/ volume 100.0)) - (for ([pos (in-range 0 (bytes-length out) bytes-per-sample)]) - (define sample (read-sample out pos bytes-per-sample little?)) - (define scaled (inexact->exact (truncate (* sample factor)))) - (store-sample! out pos bytes-per-sample little? scaled)) - out])) -|# \ No newline at end of file diff --git a/libao.rkt b/libao.rkt index 442b68b..e5cc1ca 100644 --- a/libao.rkt +++ b/libao.rkt @@ -1,7 +1,7 @@ #lang racket/base (require (prefix-in fin: finalizer) - (prefix-in ffi: "libao-async-ffi-racket.rkt") + (prefix-in ffi: "libao-async-ffi.rkt") ffi/unsafe ffi/unsafe/custodian data/queue diff --git a/play-test.rkt b/play-test.rkt index 1050706..4118e58 100644 --- a/play-test.rkt +++ b/play-test.rkt @@ -6,7 +6,7 @@ racket-sprintf racket/runtime-path ;data/queue - ;racket-sound + ;racket-sound ) (define-runtime-path tests "tests") @@ -17,8 +17,8 @@ (define test-file4-id 4) (let ((os (system-type 'os))) (when (eq? os 'unix) - (set! test-file3 (build-path tests "mahler-1.ogg")) - (set! test-file4 (build-path tests "mahler-2.ogg")) + (set! test-file3 (build-path tests "idyll.mp3")) + (set! test-file4 (build-path tests "idyll.flac")) ) (when (eq? os 'windows) (set! test-file3 (build-path tests "idyll.mp3")) diff --git a/private/downloader.rkt b/private/downloader.rkt index dc09ece..855f867 100644 --- a/private/downloader.rkt +++ b/private/downloader.rkt @@ -24,9 +24,9 @@ ;; Version info of the version to download ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define version-major 0) -(define version-minor 2) -(define version-patch 1) +(define version-major 1) +(define version-minor 0) +(define version-patch 0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Internal functions diff --git a/private/utils.rkt b/private/utils.rkt index 0d3a6f1..113bd0e 100644 --- a/private/utils.rkt +++ b/private/utils.rkt @@ -19,6 +19,8 @@ warn-sound fatal-sound sync-log-sound + integer->int-bytes + int-bytes->integer ) (sl-def-log racket-sound sound) @@ -69,18 +71,56 @@ (soundlibs-directory)) (define (get-lib* libs-to-try orig-libs versions) - (unless (soundlibs-available?) - (download-soundlibs)) - (if (null? libs-to-try) - (begin - (displayln (format "Warning: Cannot find library, tried ~a in ~a" orig-libs (build-lib-path))) - #f) - (ffi-lib (car libs-to-try) versions - #:get-lib-dirs (λ () (cons (build-lib-path) (get-lib-search-dirs))) - #:fail (λ () (get-lib* (cdr 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