Browse files

Initial commit

  • Loading branch information...
0 parents commit 1004445f4836ed5b237bdf1805dd986053041cce @dleslie committed Jan 7, 2013
Showing with 524 additions and 0 deletions.
  1. +212 −0 easing.scm
  2. +72 −0 selectors.scm
  3. +158 −0 test.scm
  4. +28 −0 tween.import.scm
  5. +7 −0 tween.meta
  6. +3 −0 tween.release-info
  7. +33 −0 tween.scm
  8. +11 −0 tween.setup
212 easing.scm
@@ -0,0 +1,212 @@
+(define (linear-ease direction percent)
+ (assert (and (<= 0 percent) (>= 1 percent)))
+ percent)
+
+(define (quadratic-ease direction percent)
+ (assert (or (eq? direction 'in) (eq? direction 'out) (eq? direction 'inout)))
+ (linear-ease
+ direction
+ (cond
+ ((eq? direction 'in)
+ (expt percent 2))
+ ((eq? direction 'out)
+ (* percent (- 2 percent)))
+ ((eq? direction 'inout)u
+ (let ((p (* percent 2)))
+ (if (< p 1)
+ (* 0.5 (expt percent 2))
+ (let ((p (- p 1)))
+ (* -0.5 (- (* p (- p 2)) 1)))))))))
+
+(define (cubic-ease direction percent)
+ (assert (or (eq? direction 'in) (eq? direction 'out) (eq? direction 'inout)))
+ (linear-ease
+ direction
+ (cond
+ ((eq? direction 'in)
+ (expt percent 3))
+ ((eq? direction 'out)
+ (let ((p (- percent 1)))
+ (+ 1 (* (expt p 3)))))
+ ((eq? direction 'inout)
+ (let ((p (* percent 2)))
+ (if (< p 1)
+ (* 0.5 (expt p 3))
+ (let ((p (- p 2)))
+ (* 0.5 (+ 2 (expt p 3))))))))))
+
+(define (quartic-ease direction percent)
+ (assert (or (eq? direction 'in) (eq? direction 'out) (eq? direction 'inout)))
+ (linear-ease
+ direction
+ (cond
+ ((eq? direction 'in)
+ (expt percent 4))
+ ((eq? direction 'out)
+ (let ((p (- percent 1)))
+ (- 1 (expt p 4))))
+ ((eq? direction 'inout)
+ (let ((p (* percent 2)))
+ (if (< p 1)
+ (* 0.5 (expt p 4))
+ (let ((p (- p 2)))
+ (* -0.5 (- (expt p 4) 2)))))))))
+
+(define (quintic-ease direction percent)
+ (assert (or (eq? direction 'in) (eq? direction 'out) (eq? direction 'inout)))
+ (linear-ease
+ direction
+ (cond
+ ((eq? direction 'in)
+ (expt percent 5))
+ ((eq? direction 'out)
+ (let ((p (- percent 1)))
+ (+ 1 (expt p 5))))
+ ((eq? direction 'inout)
+ (let ((p (* percent 2)))
+ (if (< p 1)
+ (* 0.5 (expt p 5))
+ (let ((p (- p 2)))
+ (* 0.5 (+ (expt p 5) 2)))))))))
+
+(define (sinusoidal-ease direction percent)
+ (assert (or (eq? direction 'in) (eq? direction 'out) (eq? direction 'inout)))
+ (define pi 3.14159265358979)
+ (linear-ease
+ direction
+ (cond
+ ((eq? direction 'in)
+ (- 1 (cos (* percent pi 0.5))))
+ ((eq? direction 'out)
+ (sin (* percent pi 0.5)))
+ ((eq? direction 'inout)
+ (* 0.5 (- 1 (cos (* pi percent))))))))
+
+(define (exponential-ease direction percent)
+ (assert (or (eq? direction 'in) (eq? direction 'out) (eq? direction 'inout)))
+ (linear-ease
+ direction
+ (cond
+ ((eq? direction 'in)
+ (if (= percent 0)
+ 0
+ (expt 1024 (- percent 1))))
+ ((eq? direction 'out)
+ (if (= percent 1)
+ 1
+ (- 1 (expt 2 (* -10 percent)))))
+ ((eq? direction 'inout)
+ (cond
+ ((= percent 0) 0)
+ ((= percent 1) 1)
+ ((< (* percent 2) 1)
+ (* 0.5 (expt 1024 (- (* percent 2) 1))))
+ (else
+ (* 0.5 (- 2 (expt 2 (* -10 (- (* percent 2) 1)))))))))))
+
+(define (circular-ease direction percent)
+ (assert (or (eq? direction 'in) (eq? direction 'out) (eq? direction 'inout)))
+ (linear-ease
+ direction
+ (cond
+ ((eq? direction 'in)
+ (- 1 (sqrt (- 1 (expt percent 2)))))
+ ((eq? direction 'out)
+ (sqrt (- 1 (expt (- percent 1) 2))))
+ ((eq? direction 'inout)
+ (let ((p (* percent 2)))
+ (if (< p 1)
+ (* -0.5 (- (sqrt (- 1 (expt p 2))) 1))
+ (* 0.5 (+ (sqrt (- 1 (expt (- p 2) 2))) 1))))))))
+
+(define (elastic-ease direction percent #!optional (a 1.0) (p 0.4))
+ (assert (or (eq? direction 'in) (eq? direction 'out) (eq? direction 'inout)))
+ (define pi 3.14159265358979)
+ (define invpi (/ 1 pi))
+ (define invp (/ 1 p))
+ (define k
+ (let ((s (if (< a 1)
+ (/ p 4)
+ (* p (asin (/ 1 a)) 0.5 invpi)))
+ (a (if (< a 1) 1 a)))
+ (cond
+ ((= percent 0) 0)
+ ((= percent 1) 1)
+ ((eq? direction 'in)
+ (let ((percent (- percent 1)))
+ (- (* a
+ (expt 2 (* 10 percent))
+ (sin (* (- percent s) 2 pi invp))))))
+ ((eq? direction 'out)
+ (+ (* a
+ (expt 2 (* -10 percent))
+ (sin (* (- percent s) 2 pi invp)))
+ 1))
+ ((eq? direction 'inout)
+ (let ((p (* percent 2)))
+ (if (< p 1)
+ (* -0.5 a
+ (expt 2 (* 10 (- p 1)))
+ (sin (* (- p 1 s) 2 pi invp)))
+ (+ 1 (* a 0.5
+ (expt 2 (* -10 (- p 1)))
+ (sin (* (- p 1 s) 2 pi invpi))))))))))
+ (linear-ease
+ direction
+ (cond
+ ((< k 0) 0)
+ ((> k 1) 1)
+ (else k))))
+
+(define (back-ease direction percent #!optional (s 1.70158))
+ (assert (or (eq? direction 'in) (eq? direction 'out) (eq? direction 'inout)))
+ (define k (cond
+ ((eq? direction 'in)
+ (* (expt percent 2)
+ (- (* percent (+ s 1)) s)))
+ ((eq? direction 'out)
+ (let ((p (- percent 1)))
+ (+ 1 (* (expt p 2)
+ (+ s (* p (+ s 1)))))))
+ ((eq? direction 'inout)
+ (let ((s (* s 1.525))
+ (p (* percent 2)))
+ (if (< p 1)
+ (* 0.5 (* (expt p 2) (- (* p (+ s 1)) s)))
+ (let ((p (- p 2)))
+ (* 0.5 (+ 2 (* (expt p 2) (+ s (* p (+ s 1))))))))))))
+ (linear-ease
+ direction
+ (cond
+ ((< k 0) 0)
+ ((> k 1) 1)
+ (else k))))
+
+(define (bounce-ease direction percent)
+ (assert (or (eq? direction 'in) (eq? direction 'out) (eq? direction 'inout)))
+ (define (out p)
+ (cond
+ ((< p (/ 1 2.75))
+ (* 7.5625 (expt p 2)))
+ ((< p (/ 2 2.75))
+ (let ((p (- p (/ 1.5 2.75))))
+ (+ 0.75 (* 7.5625 (expt p 2)))))
+ ((< p (/ 2.5 2.75))
+ (let ((p (- p (/ 2.25 2.75))))
+ (+ 0.9375 (* 7.5625 (expt p 2)))))
+ (else
+ (let ((p (- p (/ 2.625 2.75))))
+ (+ 0.984375 (* 7.5625 (expt p 2)))))))
+ (define (in p)
+ (- 1 (out (- 1 p))))
+ (linear-ease
+ direction
+ (cond
+ ((eq? direction 'in)
+ (in percent))
+ ((eq? direction 'out)
+ (out percent))
+ ((eq? direction 'inout)
+ (if (< percent 0.5)
+ (* 0.5 (in (* percent 2)))
+ (+ 0.5 (* 0.5 (out (- (* percent 2) 1)))))))))
72 selectors.scm
@@ -0,0 +1,72 @@
+(define (linear-select v p)
+ (define (fn p0 p1 t)
+ (+ (* (- p1 p0) t) p0))
+ (define m (- (vector-length v) 1))
+ (define f (* m p))
+ (define idx (floor f))
+ (case
+ ((< p 0) (fn (vector-ref v 0)
+ (vector-ref v 1)
+ f))
+ ((> p 1) (fn (vector-ref v m)
+ (vector-ref v (- m 1))
+ (- m f)))
+ (else (fn (vector-ref v idx)
+ (vector-ref v (if (> (+ idx 1) m) m (+ idx 1)))
+ (- f idx)))))
+
+(define (bezier-select v p)
+ (define (fn n i)
+ (/ (factorial n) (* (factorial i) (factorial (- n i)))))
+ (define n (vector-length v))
+ (define (loop i b)
+ (if (> i n) b
+ (loop (+ i 1)
+ (+ b (* (expt (- 1 p) (- n i))
+ (vector-ref v i)
+ (fn n i))))))
+ (loop 0 0))
+
+(define (catmullrom-select v p)
+ (define (fn p0 p1 p2 p3 t)
+ (define v0 (* 0.5 (- p2 p0)))
+ (define v1 (* 0.5 (- p3 p1)))
+ (define t2 (expt t 2))
+ (define t3 (expt t 3))
+ (+ p1
+ (* v0 t)
+ (* (- v1 (* 2 v0) (* -3 p2) (* 3 p1)) t2)
+ (* (+ (* 2 p1) (* -2 p2) v0 v1) t3)))
+ (define m (- (vector-length v) 1))
+ (define f (* m p))
+ (define i (floor f))
+ (if
+ (and (= (vector-ref v 0) (vector-ref v m))
+ (< p 0))
+ (let* ((f (* m (+ 1 p)))
+ (i (floor f)))
+ (fn (vector-ref v (modulo (+ i -1 m) m))
+ (vector-ref v i)
+ (vector-ref v (modulo (+ i 1) m))
+ (vector-ref v (modulo (+ i 2) m))
+ (- f i)))
+ (cond
+ ((< p 0) (- (vector-ref v 0)
+ (fn (vector-ref v 0)
+ (vector-ref v 0)
+ (vector-ref v 1)
+ (vector-ref v 1)
+ (- f))
+ (vector-ref v 0)))
+ ((> p 1) (- (vector-ref v m)
+ (fn (vector-ref v m)
+ (vector-ref v m)
+ (vector-ref v (- m 1))
+ (vector-ref v (- m 1))
+ (- f m))
+ (vector-ref v m)))
+ (else (fn (vector-ref v (if (< 0 i) (- i 1) 0))
+ (vector-ref v i)
+ (vector-ref v (if (< m (+ i 1)) m (+ i 1)))
+ (vector-ref v (if (< m (+ i 2)) m (+ i 2)))
+ (- f i))))))
158 test.scm
@@ -0,0 +1,158 @@
+(use tween)
+
+(assert (= 3628800 (factorial 10)))
+(assert (= 1.0 (rationalize 4 0.99999998 0.0001)))
+
+;; Linear ease
+
+(assert (= (tween linear-ease 'in 0 10 0) 0))
+(assert (= (tween linear-ease 'in 0 10 1) 10))
+(assert (= (tween linear-ease 'in 0 10 0.5) 5))
+
+(assert (= (tween linear-ease 'out 0 10 0) 0))
+(assert (= (tween linear-ease 'out 0 10 1) 10))
+(assert (= (tween linear-ease 'out 0 10 0.5) 5))
+
+(assert (= (tween linear-ease 'inout 0 10 0) 0))
+(assert (= (tween linear-ease 'inout 0 10 1) 10))
+(assert (= (tween linear-ease 'inout 0 10 0.5) 5))
+
+;; Quadratic ease
+
+(assert (= (tween quadratic-ease 'in 0 10 0) 0))
+(assert (= (tween quadratic-ease 'in 0 10 1) 10))
+(assert (= (tween quadratic-ease 'in 0 10 0.5) 2.5))
+
+(assert (= (tween quadratic-ease 'out 0 10 0) 0))
+(assert (= (tween quadratic-ease 'out 0 10 1) 10))
+(assert (= (tween quadratic-ease 'out 0 10 0.5) 7.5))
+
+(assert (= (tween quadratic-ease 'inout 0 10 0) 0))
+(assert (= (tween quadratic-ease 'inout 0 10 1) 10))
+(assert (= (tween quadratic-ease 'inout 0 10 0.5) 5.0))
+
+;; Cubic ease
+
+(assert (= (tween cubic-ease 'in 0 10 0) 0))
+(assert (= (tween cubic-ease 'in 0 10 1) 10))
+(assert (= (tween cubic-ease 'in 0 10 0.5) 1.25))
+
+(assert (= (tween cubic-ease 'out 0 10 0) 0))
+(assert (= (tween cubic-ease 'out 0 10 1) 10))
+(assert (= (tween cubic-ease 'out 0 10 0.5) 8.75))
+
+(assert (= (tween cubic-ease 'inout 0 10 0) 0))
+(assert (= (tween cubic-ease 'inout 0 10 1) 10))
+(assert (= (tween cubic-ease 'inout 0 10 0.5) 5.0))
+
+;; Quartic ease
+
+(assert (= (tween quartic-ease 'in 0 10 0) 0))
+(assert (= (tween quartic-ease 'in 0 10 1) 10))
+(assert (= (tween quartic-ease 'in 0 10 0.5) 0.625))
+
+(assert (= (tween quartic-ease 'out 0 10 0) 0))
+(assert (= (tween quartic-ease 'out 0 10 1) 10))
+(assert (= (tween quartic-ease 'out 0 10 0.5) 9.375))
+
+(assert (= (tween quartic-ease 'inout 0 10 0) 0))
+(assert (= (tween quartic-ease 'inout 0 10 1) 10))
+(assert (= (tween quartic-ease 'inout 0 10 0.5) 5.0))
+
+;; Quintic ease
+
+(assert (= (tween quintic-ease 'in 0 10 0) 0))
+(assert (= (tween quintic-ease 'in 0 10 1) 10))
+(assert (= (tween quintic-ease 'in 0 10 0.5) 0.3125))
+
+(assert (= (tween quintic-ease 'out 0 10 0) 0))
+(assert (= (tween quintic-ease 'out 0 10 1) 10))
+(assert (= (tween quintic-ease 'out 0 10 0.5) 9.6875))
+
+(assert (= (tween quintic-ease 'inout 0 10 0) 0))
+(assert (= (tween quintic-ease 'inout 0 10 1) 10))
+(assert (= (tween quintic-ease 'inout 0 10 0.5) 5.0))
+
+;; Sinusoidal ease
+
+(assert (= (tween sinusoidal-ease 'in 0 10 0) 0))
+(assert (= (rationalize 4 (tween sinusoidal-ease 'in 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween sinusoidal-ease 'in 0 10 0.5) 0.00001) 2.9289))
+
+(assert (= (tween sinusoidal-ease 'out 0 10 0) 0))
+(assert (= (rationalize 4 (tween sinusoidal-ease 'out 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween sinusoidal-ease 'out 0 10 0.5) 0.00001) 7.0710))
+
+(assert (= (tween sinusoidal-ease 'inout 0 10 0) 0))
+(assert (= (rationalize 4 (tween sinusoidal-ease 'inout 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween sinusoidal-ease 'inout 0 10 0.5) 0.00001) 5.0))
+
+;; Exponential ease
+
+(assert (= (tween exponential-ease 'in 0 10 0) 0))
+(assert (= (rationalize 4 (tween exponential-ease 'in 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween exponential-ease 'in 0 10 0.5) 0.00001) 0.3125))
+
+(assert (= (tween exponential-ease 'out 0 10 0) 0))
+(assert (= (rationalize 4 (tween exponential-ease 'out 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween exponential-ease 'out 0 10 0.5) 0.00001) 9.6875))
+
+(assert (= (tween exponential-ease 'inout 0 10 0) 0))
+(assert (= (rationalize 4 (tween exponential-ease 'inout 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween exponential-ease 'inout 0 10 0.5) 0.00001) 5.0))
+
+;; Circular ease
+
+(assert (= (tween circular-ease 'in 0 10 0) 0))
+(assert (= (rationalize 4 (tween circular-ease 'in 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween circular-ease 'in 0 10 0.5) 0.00001) 1.3397))
+
+(assert (= (tween circular-ease 'out 0 10 0) 0))
+(assert (= (rationalize 4 (tween circular-ease 'out 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween circular-ease 'out 0 10 0.5) 0.00001) 8.6602))
+
+(assert (= (tween circular-ease 'inout 0 10 0) 0))
+(assert (= (rationalize 4 (tween circular-ease 'inout 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween circular-ease 'inout 0 10 0.5) 0.00001) 5.0))
+
+;; Elastic ease
+
+(assert (= (tween elastic-ease 'in 0 10 0) 0))
+(assert (= (rationalize 4 (tween elastic-ease 'in 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween elastic-ease 'in 0 10 0.5) 0.00001) 0.0))
+
+(assert (= (tween elastic-ease 'out 0 10 0) 0))
+(assert (= (rationalize 4 (tween elastic-ease 'out 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween elastic-ease 'out 0 10 0.5) 0.00001) 10.0))
+
+(assert (= (tween elastic-ease 'inout 0 10 0) 0))
+(assert (= (rationalize 4 (tween elastic-ease 'inout 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween elastic-ease 'inout 0 10 0.5) 0.00001) 9.0066))
+
+;; Back ease
+
+(assert (= (tween back-ease 'in 0 10 0) 0))
+(assert (= (rationalize 4 (tween back-ease 'in 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween back-ease 'in 0 10 0.5) 0.00001) 0.0))
+
+(assert (= (tween back-ease 'out 0 10 0) 0))
+(assert (= (rationalize 4 (tween back-ease 'out 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween back-ease 'out 0 10 0.5) 0.00001) 10.0))
+
+(assert (= (tween back-ease 'inout 0 10 0) 0))
+(assert (= (rationalize 4 (tween back-ease 'inout 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween back-ease 'inout 0 10 0.5) 0.00001) 5.0))
+
+;; Bounce ease
+
+(assert (= (tween bounce-ease 'in 0 10 0) 0))
+(assert (= (rationalize 4 (tween bounce-ease 'in 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween bounce-ease 'in 0 10 0.5) 0.00001) 2.3437))
+
+(assert (= (tween bounce-ease 'out 0 10 0) 0))
+(assert (= (rationalize 4 (tween bounce-ease 'out 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween bounce-ease 'out 0 10 0.5) 0.00001) 7.6562))
+
+(assert (= (tween bounce-ease 'inout 0 10 0) 0))
+(assert (= (rationalize 4 (tween bounce-ease 'inout 0 10 1) 0.00001) 10))
+(assert (= (rationalize 4 (tween bounce-ease 'inout 0 10 0.5) 0.00001) 5.0))
28 tween.import.scm
@@ -0,0 +1,28 @@
+;;;; tween.import.scm - GENERATED BY CHICKEN 4.8.0 -*- Scheme -*-
+
+(eval '(import scheme chicken))
+(##sys#register-compiled-module
+ 'tween
+ (list)
+ '((bounce-ease . tween#bounce-ease)
+ (back-ease . tween#back-ease)
+ (elastic-ease . tween#elastic-ease)
+ (circular-ease . tween#circular-ease)
+ (exponential-ease . tween#exponential-ease)
+ (sinusoidal-ease . tween#sinusoidal-ease)
+ (quintic-ease . tween#quintic-ease)
+ (quartic-ease . tween#quartic-ease)
+ (cubic-ease . tween#cubic-ease)
+ (quadratic-ease . tween#quadratic-ease)
+ (linear-ease . tween#linear-ease)
+ (catmullrom-select . tween#catmullrom-select)
+ (bezier-select . tween#bezier-select)
+ (linear-select . tween#linear-select)
+ (interpolate . tween#interpolate)
+ (tween . tween#tween)
+ (factorial . tween#factorial)
+ (factorial* . tween#factorial*))
+ (list)
+ (list))
+
+;; END OF FILE
7 tween.meta
@@ -0,0 +1,7 @@
+;;;; opengl.setup -*- Scheme -*-
+
+((license "BSD")
+ (category math)
+ (author "Daniel J. Leslie")
+ (synopsis "Tweens")
+ (doc-from-wiki))
3 tween.release-info
@@ -0,0 +1,3 @@
+(repo git "git@github.com:dleslie/tween-egg.git")
+(uri targz "https://github.com/dleslie/tween-egg/tarball/{egg-release}")
+(release "1.0")
33 tween.scm
@@ -0,0 +1,33 @@
+(module
+ tween *
+ (import scheme chicken)
+
+ (define factorial* (make-vector 1 1))
+ (define (factorial n)
+ (assert (and (exact? n)
+ (vector? factorial*)))
+ (when (>= n (vector-length factorial*))
+ (set! factorial* (vector-resize factorial* (+ n 1) #f)))
+ (when (and (<= 1 n) (not (vector-ref factorial* n)))
+ (set! (vector-ref factorial* n) (* n (factorial (- n 1)))))
+ (if (>= 1 n) 1
+ (vector-ref factorial* n)))
+
+ (define (rationalize count value #!optional (epsilon 0))
+ (let ((f (expt 10 count))
+ (n (+ value epsilon)))
+ (+ (truncate n)
+ (/ (truncate (* (- n (truncate n)) f)) f))))
+
+ (define (tween easing-function direction start stop percent)
+ (assert (and (<= 0 percent) (>= 1 percent)
+ (number? start) (number? stop)))
+ (+ (* (easing-function direction percent) (- stop start)) start))
+
+ (define (interpolate selector-function value-vector percent)
+ (assert (and (<= 0 percent) (>= 1 percent)
+ (vector? value-vector)))
+ (selector-function value-vector percent))
+
+ (include "selectors")
+ (include "easing"))
11 tween.setup
@@ -0,0 +1,11 @@
+;;;; tween.setup -*- Scheme -*-
+(define compile-options "-O3 -C -O3")
+(define link-options "")
+
+(compile -s -d1 tween.scm -j tween ,link-options ,compile-options)
+(compile -s tween.import.scm -d0 ,link-options ,compile-options)
+
+(install-extension
+ 'tween
+ '("tween.so" "tween.import.so")
+ '((version 1.0)))

0 comments on commit 1004445

Please sign in to comment.