From 25c5bed4f890b1e921b5933efe1933f64d09372e Mon Sep 17 00:00:00 2001 From: Thomas White Date: Wed, 7 Apr 2021 21:09:00 +0200 Subject: Fade colours nicely --- guile/starlet/colours.scm | 49 +++++++++++++++++- guile/starlet/playback.scm | 124 ++++++++++++++++++++++++++++++++------------- 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? 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 )) + + (define cyan car) (define magenta cadr) (define yellow caddr) +(define red car) +(define green cadr) +(define blue caddr) + (define-method (display (col ) port) (format port "#< ~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 -- cgit v1.2.3