diff options
| -rw-r--r-- | sly/color.scm | 62 | ||||
| -rw-r--r-- | sly/math.scm | 14 | ||||
| -rw-r--r-- | sly/math/vector.scm | 4 | ||||
| -rw-r--r-- | sly/transition.scm | 50 |
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) |