From 43d00c233d4bda38bc5882e7fe1ca2f37837fef2 Mon Sep 17 00:00:00 2001 From: Thomas White Date: Fri, 6 May 2022 16:22:59 +0200 Subject: Move useful functions to utils --- .../fixture-library/adj/mega-tripar-profile.scm | 1 + guile/starlet/fixture-library/generic/dimmer.scm | 1 + .../stairville/octagon-theater-cw-ww.scm | 1 + guile/starlet/fixture.scm | 48 +--------------- guile/starlet/scanout.scm | 14 ----- guile/starlet/utils.scm | 65 +++++++++++++++++++++- 6 files changed, 68 insertions(+), 62 deletions(-) (limited to 'guile') diff --git a/guile/starlet/fixture-library/adj/mega-tripar-profile.scm b/guile/starlet/fixture-library/adj/mega-tripar-profile.scm index cec35a6..6f70d40 100644 --- a/guile/starlet/fixture-library/adj/mega-tripar-profile.scm +++ b/guile/starlet/fixture-library/adj/mega-tripar-profile.scm @@ -20,6 +20,7 @@ ;; (define-module (starlet fixture-library adj mega-tripar-profile) #:use-module (starlet fixture) + #:use-module (starlet utils) #:use-module (starlet colours) #:export ( )) diff --git a/guile/starlet/fixture-library/generic/dimmer.scm b/guile/starlet/fixture-library/generic/dimmer.scm index b1894b7..844b697 100644 --- a/guile/starlet/fixture-library/generic/dimmer.scm +++ b/guile/starlet/fixture-library/generic/dimmer.scm @@ -20,6 +20,7 @@ ;; (define-module (starlet fixture-library generic dimmer) #:use-module (starlet fixture) + #:use-module (starlet utils) #:export ()) (define-fixture diff --git a/guile/starlet/fixture-library/stairville/octagon-theater-cw-ww.scm b/guile/starlet/fixture-library/stairville/octagon-theater-cw-ww.scm index d79dcc9..f2ed8a5 100644 --- a/guile/starlet/fixture-library/stairville/octagon-theater-cw-ww.scm +++ b/guile/starlet/fixture-library/stairville/octagon-theater-cw-ww.scm @@ -20,6 +20,7 @@ ;; (define-module (starlet fixture-library stairville octagon-theater-cw-ww) #:use-module (starlet fixture) + #:use-module (starlet utils) #:export ()) (define-fixture diff --git a/guile/starlet/fixture.scm b/guile/starlet/fixture.scm index 5ef3492..c6a6edf 100644 --- a/guile/starlet/fixture.scm +++ b/guile/starlet/fixture.scm @@ -20,6 +20,7 @@ ;; (define-module (starlet fixture) #:use-module (starlet colours) + #:use-module (starlet utils) #:use-module (oop goops) #:use-module (ice-9 exceptions) #:use-module (srfi srfi-1) @@ -41,13 +42,6 @@ continuous-attribute? colour-attribute? intensity? - - scale-to-range - scale-and-clamp-to-range - round-dmx - percent->dmxval8 - percent->dmxval16 - define-fixture)) @@ -188,46 +182,6 @@ (get-attr-type aobj))) -;; Helper functions for fixture scanout routines -(define (percent->dmxval8 val) - (round-dmx - (scale-to-range val '(0 100) '(0 255)))) - - -(define (percent->dmxval16 val) - (scale-to-range val '(0 100) '(0 65535))) - - -(define (round-dmx a) - (inexact->exact - (min 255 (max 0 (round a))))) - - -(define (scale-to-range val orig-range dest-range) - - (define (range r) - (- (cadr r) (car r))) - - (+ (car dest-range) - (* (range dest-range) - (/ (- val (car orig-range)) - (range orig-range))))) - - -(define (clamp-to-range val val1 val2) - (let ((minval (min val1 val2)) - (maxval (max val1 val2))) - (max minval - (min val maxval)))) - -;; Like scale-to-range, but result is clamped within dest-range -(define (scale-and-clamp-to-range val orig-range dest-range) - (clamp-to-range - (scale-to-range val orig-range dest-range) - (car dest-range) - (cadr dest-range))) - - (define-syntax define-fixture (syntax-rules () diff --git a/guile/starlet/scanout.scm b/guile/starlet/scanout.scm index f5f4baa..43c2cf0 100644 --- a/guile/starlet/scanout.scm +++ b/guile/starlet/scanout.scm @@ -194,26 +194,12 @@ (list new-state))))) -(define (msb val) - (round-dmx (euclidean-quotient val 256))) - -(define (lsb val) - (round-dmx (euclidean-remainder val 256))) - - (define (send-to-ola ola-client universe-buffer-pair) (let ((uni (car universe-buffer-pair)) (buf (cdr universe-buffer-pair))) (send-streaming-dmx-data! ola-client uni buf))) -(define (ensure-number value irritating) - (unless (number? value) - (raise-exception (make-exception - (make-exception-with-message "Value is not a number") - (make-exception-with-irritants irritating))))) - - (define scanout-freq 0) (define ola-thread #f) diff --git a/guile/starlet/utils.scm b/guile/starlet/utils.scm index 2f4e613..8508079 100644 --- a/guile/starlet/utils.scm +++ b/guile/starlet/utils.scm @@ -21,6 +21,7 @@ (define-module (starlet utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-8) + #:use-module (ice-9 exceptions) #:export (print-hash-table copy-hash-table in-range @@ -28,7 +29,15 @@ flatten-sublists more-than-one hirestime - categorize)) + categorize + lsb + msb + ensure-number + round-dmx + scale-to-range + scale-and-clamp-to-range + percent->dmxval8 + percent->dmxval16)) (define (print-hash-table ht) @@ -96,3 +105,57 @@ (define (categorize items . predicates) (apply values (categorize-rec predicates items '()))) + + +(define (msb val) + (round-dmx (euclidean-quotient val 256))) + +(define (lsb val) + (round-dmx (euclidean-remainder val 256))) + + +(define (round-dmx a) + (inexact->exact + (min 255 (max 0 (round a))))) + + +(define (ensure-number value irritating) + (unless (number? value) + (raise-exception (make-exception + (make-exception-with-message "Value is not a number") + (make-exception-with-irritants irritating))))) + + +(define (percent->dmxval8 val) + (round-dmx + (scale-to-range val '(0 100) '(0 255)))) + + +(define (percent->dmxval16 val) + (scale-to-range val '(0 100) '(0 65535))) + + +(define (scale-to-range val orig-range dest-range) + + (define (range r) + (- (cadr r) (car r))) + + (+ (car dest-range) + (* (range dest-range) + (/ (- val (car orig-range)) + (range orig-range))))) + + +(define (clamp-to-range val val1 val2) + (let ((minval (min val1 val2)) + (maxval (max val1 val2))) + (max minval + (min val maxval)))) + + +;; Like scale-to-range, but result is clamped within dest-range +(define (scale-and-clamp-to-range val orig-range dest-range) + (clamp-to-range + (scale-to-range val orig-range dest-range) + (car dest-range) + (cadr dest-range))) -- cgit v1.2.3