Complete refactoring for rktplayer, in order to make it play on DLNA renderers and also use UpNP media server resources.

2026-08-08 14:29:01 +02:00
parent 186b3bb8d7
commit f5fdc38e67
69 changed files with 5953 additions and 1647 deletions
@@ -0,0 +1,163 @@
+#lang racket/base
+
+(require racket/class
+         racket/list
+         "../../misc/utils.rkt")
+
+(provide renderer%
+         renderer-preferences%)
+
+(define renderer-preferences%
+  (class object%
+    (init-field settings)
+
+    (define cfg
+      (send settings clone 'renderers))
+
+    (define/private (stored)
+      (send cfg get
+            'volume-curves
+            '()))
+
+    (define/public (get-volume-curve id)
+      (let ((entry
+             (assoc id
+                    (stored)
+                    equal?)))
+        (if entry
+            (cadr entry)
+            'linear)))
+
+    (define/public (set-volume-curve! id curve)
+      (check/c renderer-preferences%
+               set-volume-curve!
+               curve
+               (or/c 'linear
+                     'logarithmic))
+      (let ((without-id
+             (filter
+               (lambda (entry)
+                (not
+                 (equal? (car entry)
+                         id)))
+              (stored))))
+        (send cfg
+              set!
+              'volume-curves
+              (cons (list id curve)
+                    without-id))))
+
+    (super-new)))
+
+(module+ test
+  (require rackunit)
+
+  (define values (make-hash))
+  (define test-settings%
+    (class object%
+      (define/public (clone name)
+        (void name)
+        this)
+      (define/public (get name default)
+        (hash-ref values name default))
+      (define/public (set! name value)
+        (hash-set! values name value))
+      (super-new)))
+
+  (define preferences
+    (new renderer-preferences%
+         [settings (new test-settings%)]))
+  (define renderer
+    (new renderer%
+         [id "renderer-id"]
+         [name "Renderer"]
+         [kind 'test]
+         [device 'device]
+         [preferences preferences]))
+
+  (check-= (send renderer
+                 logical-volume->device
+                 25)
+           25
+           0.001)
+  (send renderer
+        set-volume-curve!
+        'logarithmic)
+  (check-eq? (send renderer get-volume-curve)
+             'logarithmic)
+  (check-= (send renderer
+                 logical-volume->device
+                 50)
+           25
+           0.001)
+  (check-= (send renderer
+                 device-volume->logical
+                 25)
+           50
+           0.001))
+
+(define renderer%
+  (class object%
+    (init-field
+     id
+     name
+     kind
+     device
+     preferences)
+
+    (check/c* renderer%
+              (id string?)
+              (name string?)
+              (kind symbol?)
+              (preferences
+               (is-a?/c renderer-preferences%)))
+
+    (define/public (get-id)
+      id)
+
+    (define/public (get-name)
+      name)
+
+    (define/public (get-kind)
+      kind)
+
+    (define/public (get-device)
+      device)
+
+    (define/public (get-volume-curve)
+      (send preferences
+            get-volume-curve
+            id))
+
+    (define/public (set-volume-curve! curve)
+      (send preferences
+            set-volume-curve!
+            id
+            curve))
+
+    (define/private (clamp percentage)
+      (min 100.0
+           (max 0.0
+                percentage)))
+
+    (define/public (logical-volume->device percentage)
+      (let ((value
+             (/ (clamp percentage)
+                100.0)))
+        (* 100.0
+           (case (send this get-volume-curve)
+             ((logarithmic)
+              (* value value))
+             (else value)))))
+
+    (define/public (device-volume->logical percentage)
+      (let ((value
+             (/ (clamp percentage)
+                100.0)))
+        (* 100.0
+           (case (send this get-volume-curve)
+             ((logarithmic)
+              (sqrt value))
+             (else value)))))
+
+    (super-new)))