aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorThomas White <taw@physics.org>2021-04-07 21:09:00 +0200
committerThomas White <taw@physics.org>2021-04-07 21:09:00 +0200
commit25c5bed4f890b1e921b5933efe1933f64d09372e (patch)
tree9e39773ba7602395fb3b03be7d408778e7c68f36
parent376f1322adf585617cf173ef34832ed910b6b49c (diff)
Fade colours nicely
-rw-r--r--guile/starlet/colours.scm49
-rw-r--r--guile/starlet/playback.scm124
2 files changed, 136 insertions, 37 deletions
diff --git a/guile/starlet/colours.scm b/guile/starlet/colours.scm
index 5ed4f81..c76ebf2 100644
--- a/guile/starlet/colours.scm
+++ b/guile/starlet/colours.scm
@@ -1,9 +1,12 @@
(define-module (starlet colours)
#:use-module (oop goops)
+ #:use-module (ice-9 exceptions)
#:export (<colour>
+ colour?
make-colour-cmy
make-colour-rgb
colour-as-cmy
+ interpolate-colour
white))
@@ -19,10 +22,18 @@
#:getter colour-value))
+(define (colour? c)
+ (is-a? c <colour>))
+
+
(define cyan car)
(define magenta cadr)
(define yellow caddr)
+(define red car)
+(define green cadr)
+(define blue caddr)
+
(define-method (display (col <colour>) port)
(format port "#<<colour> ~a ~a>"
(colour-type col)
@@ -54,4 +65,40 @@
(define (colour-as-cmy col)
- (colour-value col))
+ (let ((val (colour-value col)))
+ (case (colour-type col)
+
+ ((cmy)
+ val)
+
+ ((rgb)
+ (list (- 100 (red val))
+ (- 100 (green val))
+ (- 100 (blue val))))
+
+ (else
+ (raise-exception (make-exception
+ (make-exception-with-message "Unrecognised colour type")
+ (make-exception-with-irritants (colour-type col))))))))
+
+
+(define (interpolate-cmy a b frac)
+ (let ((cmy1 (colour-as-cmy a))
+ (cmy2 (colour-as-cmy b)))
+ (make-colour-cmy
+ (+ (cyan cmy1) (* frac (- (cyan cmy2) (cyan cmy1))))
+ (+ (magenta cmy1) (* frac (- (magenta cmy2) (magenta cmy1))))
+ (+ (yellow cmy1) (* frac (- (yellow cmy2) (yellow cmy1)))))))
+
+
+(define* (interpolate-colour a b frac #:key (interpolation-type 'linear-cmy))
+ (case interpolation-type
+
+ ((linear-cmy)
+ (interpolate-cmy a b frac))
+
+ (else
+ (raise-exception (make-exception
+ (make-exception-with-message
+ "Unrecognised colour interpolation type")
+ (make-exception-with-irritants interpolation-type))))))
diff --git a/guile/starlet/playback.scm b/guile/starlet/playback.scm
index 9d372bf..742d314 100644
--- a/guile/starlet/playback.scm
+++ b/guile/starlet/playback.scm
@@ -8,6 +8,7 @@
#:use-module (srfi srfi-43)
#:use-module (starlet base)
#:use-module (starlet utils)
+ #:use-module (starlet colours)
#:export (make-playback
cue
cue-part
@@ -179,6 +180,39 @@
'no-more-cues-in-list)))
+(define (colour-fade start-val
+ end-val
+ fade-time
+ start-time
+ current-time)
+
+ (unless (and (colour? start-val)
+ (colour? end-val))
+ (raise-exception (make-exception
+ (make-exception-with-message
+ "Non-colour arguments given to simple-fade")
+ (make-exception-with-irritants
+ (list start-val end-val)))))
+
+ (let ((elapsed-fade-time (- current-time start-time)))
+ (cond
+
+ ;; Before start of fade
+ ((< elapsed-fade-time 0)
+ start-val)
+
+ ;; After fade
+ ((> elapsed-fade-time fade-time)
+ end-val)
+
+ ;; During the fade
+ (else
+ (interpolate-colour start-val
+ end-val
+ (/ elapsed-fade-time fade-time)
+ #:interpolation-type 'linear-cmy)))))
+
+
(define (simple-fade start-val
end-val
fade-time
@@ -310,33 +344,17 @@
(else target-val))))
-(define (make-colour-fade start-val
- target-val
- preset-val
- fade-time
- fade-start-time
- preset-time
- preset-start-time)
- (lambda (time)
- (cond
-
- ((< time fade-start-time) start-val)
-
- ((and (not (eq? 'no-value preset-val))
- (> time (+ preset-start-time preset-time)))
- preset-val)
-
- (else target-val))))
-
+(define (make-general-fade start-val
+ target-val
+ preset-val
+ fade-time
+ fade-start-time
+ preset-time
+ preset-start-time
+ fade-func)
-(define (make-continuous-attr-fade start-val
- target-val
- preset-val
- fade-time
- fade-start-time
- preset-time
- preset-start-time)
- (if (and (number? target-val)
+ (if (and (not (procedure? target-val))
+ (not (eq? target-val 'no-value))
(not (eq? start-val 'no-value)))
;; It makes sense to do a fade
@@ -347,18 +365,18 @@
((and (not (eq? 'no-value preset-val))
(> time preset-start-time))
- (simple-fade target-val
- preset-val
- preset-time
- preset-start-time
- time))
+ (fade-func target-val
+ preset-val
+ preset-time
+ preset-start-time
+ time))
(else
- (simple-fade real-start-val
- target-val
- fade-time
- fade-start-time
- time)))))
+ (fade-func real-start-val
+ target-val
+ fade-time
+ fade-start-time
+ time)))))
;; A fade doesn't make sense, so make do with a snap transition
(lambda (time)
@@ -372,6 +390,40 @@
(else target-val)))))
+(define (make-colour-fade start-val
+ target-val
+ preset-val
+ fade-time
+ fade-start-time
+ preset-time
+ preset-start-time)
+ (make-general-fade start-val
+ target-val
+ preset-val
+ fade-time
+ fade-start-time
+ preset-time
+ preset-start-time
+ colour-fade))
+
+
+(define (make-continuous-attr-fade start-val
+ target-val
+ preset-val
+ fade-time
+ fade-start-time
+ preset-time
+ preset-start-time)
+ (make-general-fade start-val
+ target-val
+ preset-val
+ fade-time
+ fade-start-time
+ preset-time
+ preset-start-time
+ simple-fade))
+
+
(define (match-fix-attr attr-el fix attr)
(cond