summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--sly/color.scm62
-rw-r--r--sly/math.scm14
-rw-r--r--sly/math/vector.scm4
-rw-r--r--sly/transition.scm50
4 files changed, 47 insertions, 83 deletions
diff --git a/sly/color.scm b/sly/color.scm
index 4b82df7..2611b31 100644
--- a/sly/color.scm
+++ b/sly/color.scm
@@ -30,53 +30,19 @@
#:export (<color>
make-color
color?
- color-r
- color-g
- color-b
- color-a
- rgba
- rgb
- color*
- color-scale
- color+
- color-
- color-inverse
- white
- black
- red
- green
- blue
- yellow
- magenta
- cyan
- transparent
- tango-light-butter
- tango-butter
- tango-dark-butter
- tango-light-orange
- tango-orange
- tango-dark-orange
- tango-light-chocolate
- tango-chocolate
- tango-dark-chocolate
- tango-light-chameleon
- tango-chameleon
- tango-dark-chameleon
- tango-light-sky-blue
- tango-sky-blue
- tango-dark-sky-blue
- tango-light-plum
- tango-plum
- tango-dark-plum
- tango-light-scarlet-red
- tango-scarlet-red
- tango-dark-scarlet-red
- tango-aluminium-1
- tango-aluminium-2
- tango-aluminium-3
- tango-aluminium-4
- tango-aluminium-5
- tango-aluminium-6))
+ color-r color-g color-b color-a
+ rgba rgb
+ color* color+ color- color-inverse color-lerp
+ white black red green blue yellow magenta cyan transparent
+ tango-light-butter tango-butter tango-dark-butter
+ tango-light-orange tango-orange tango-dark-orange
+ tango-light-chocolate tango-chocolate tango-dark-chocolate
+ tango-light-chameleon tango-chameleon tango-dark-chameleon
+ tango-light-sky-blue tango-sky-blue tango-dark-sky-blue
+ tango-light-plum tango-plum tango-dark-plum
+ tango-light-scarlet-red tango-scarlet-red tango-dark-scarlet-red
+ tango-aluminium-1 tango-aluminium-2 tango-aluminium-3
+ tango-aluminium-4 tango-aluminium-5 tango-aluminium-6))
(define-record-type <color>
(%make-color r g b a)
@@ -157,6 +123,8 @@ For example: #xffffff will return a color with RGBA values 1, 1, 1,
(- 1 b)
a)))) ; Do not alter alpha channel.
+(define color-lerp (make-lerp color+ color*))
+
;;;
;;; Pre-defined Colors
;;;
diff --git a/sly/math.scm b/sly/math.scm
index 4169ae4..923a93d 100644
--- a/sly/math.scm
+++ b/sly/math.scm
@@ -33,7 +33,8 @@
cotan
clamp
linear-scale
- half square))
+ half square
+ make-lerp lerp))
;; Dave was editing this module on Pi Approximation Day.
;;
@@ -110,3 +111,14 @@ actually less than MAX."
(define (square x)
(* x x))
+
+(define (make-lerp + *)
+ "Return a new procedure that accepts three arguments: A, B, and
+ALPHA. The returned procedure uses the procedures + and * to linearly
+interpolate a value between A and B. ALPHA should always be in the
+range [0, 1]."
+ (lambda (a b alpha)
+ (+ (* a (- 1 alpha))
+ (* b alpha))))
+
+(define lerp (make-lerp + *))
diff --git a/sly/math/vector.scm b/sly/math/vector.scm
index b9e0302..717c5f6 100644
--- a/sly/math/vector.scm
+++ b/sly/math/vector.scm
@@ -33,7 +33,7 @@
vector2? vector3? vector4?
vx vy vz vw
v+ v- v* vdot vcross
- magnitude normalize))
+ magnitude normalize vlerp))
(define-record-type <vector2>
(vector2 x y)
@@ -153,3 +153,5 @@
(vector3 (/ x m) (/ y m) (/ z m)))
(($ <vector4> x y z w)
(vector4 (/ x m) (/ y m) (/ z m) (/ w m)))))))
+
+(define vlerp (make-lerp v+ v*))
diff --git a/sly/transition.scm b/sly/transition.scm
index 7910962..6871071 100644
--- a/sly/transition.scm
+++ b/sly/transition.scm
@@ -22,6 +22,7 @@
;;; Code:
(define-module (sly transition)
+ #:use-module (ice-9 match)
#:use-module (sly agenda)
#:use-module (sly color)
#:use-module (sly coroutine)
@@ -100,43 +101,24 @@
;; ease-in-out-bounce
;;;
-;;; Interpolators
-;;;
-
-(define (interpolator + *)
- "Return a new procedure that accepts three arguments: a, b, and
-delta. The returned procedure uses the operations + and * to
-interpolate a value between a and b. Delta should always be in the
-range [0, 1]."
- (lambda (a b delta)
- (+ (* a (- 1 delta))
- (* b delta))))
-
-(define number-interpolate (interpolator + *))
-(define vector-interpolate (interpolator v+ v*))
-(define color-interpolate (interpolator color+ color*))
-
-(define (guess-interpolator a b)
- (define (both? pred)
- (and (pred a) (pred b)))
-
- (cond ((both? number?)
- number-interpolate)
- ((or (both? vector2?)
- (both? vector3?)
- (both? vector4?))
- vector-interpolate)
- ((both? color?)
- color-interpolate)
- ((both? quaternion?)
- quaternion-slerp)
- (else
- (error "Failed to guess interpolator: " a b))))
-
-;;;
;;; Transitions
;;;
+(define guess-interpolator
+ (match-lambda*
+ (((? number? _) (? number? _))
+ lerp)
+ ((or ((? vector2? _) (? vector2? _))
+ ((? vector3? _) (? vector3? _))
+ ((? vector4? _) (? vector4? _)))
+ vlerp)
+ (((? color? _) (? color? _))
+ color-lerp)
+ (((? quaternion? _) (? quaternion? _))
+ quaternion-slerp)
+ ((a b)
+ (error "Failed to guess interpolator: " a b))))
+
(define* (transition start end duration
#:optional #:key
(interpolator #f)