564d579c018b

--- a/make-quickutils.lisp	Mon May 09 00:18:57 2016 +0000
+++ b/make-quickutils.lisp	Mon May 09 01:01:35 2016 +0000
@@ -12,5 +12,6 @@
                :curry
                :rcurry
                :compose
+               :n-grams
                )
   :package "CODING-MATH.QUICKUTILS")

--- a/package.lisp	Mon May 09 00:18:57 2016 +0000
+++ b/package.lisp	Mon May 09 01:01:35 2016 +0000
@@ -127,6 +127,7 @@
     #:cubic-bezier
     #:quadratic-bezier-curve
     #:draw-function
+    #:multicurve
     ))
 
 (defpackage #:coding-math.fps

--- a/quickutils.lisp	Mon May 09 00:18:57 2016 +0000
+++ b/quickutils.lisp	Mon May 09 01:01:35 2016 +0000
@@ -2,7 +2,7 @@
 ;;;; See http://quickutil.org for details.
 
 ;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SWITCH :WHILE :ENSURE-BOOLEAN :WITH-GENSYMS :ONCE-ONLY :IOTA :CURRY :RCURRY :COMPOSE) :ensure-package T :package "CODING-MATH.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SWITCH :WHILE :ENSURE-BOOLEAN :WITH-GENSYMS :ONCE-ONLY :IOTA :CURRY :RCURRY :COMPOSE :N-GRAMS) :ensure-package T :package "CODING-MATH.QUICKUTILS")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (unless (find-package "CODING-MATH.QUICKUTILS")
@@ -18,7 +18,7 @@
                                          :SWITCH :UNTIL :WHILE :ENSURE-BOOLEAN
                                          :MAKE-GENSYM-LIST :ONCE-ONLY :IOTA
                                          :ENSURE-FUNCTION :CURRY :RCURRY
-                                         :COMPOSE))))
+                                         :COMPOSE :TAKE :N-GRAMS))))
 
   (defun %reevaluate-constant (name value test)
     (if (not (boundp name))
@@ -307,8 +307,30 @@
              (declare (dynamic-extent arguments))
              ,(compose-1 funs))))))
   
+
+  (defun take (n sequence)
+    "Take the first `n` elements from `sequence`."
+    (subseq sequence 0 n))
+  
+
+  (defun n-grams (n sequence)
+    "Find all `n`-grams of the sequence `sequence`."
+    (assert (and (plusp n)
+                 (<= n (length sequence))))
+    
+    (etypecase sequence
+      ;; Lists
+      (list (loop :repeat (1+ (- (length sequence) n))
+                  :for seq :on sequence
+                  :collect (take n seq)))
+      
+      ;; General sequences
+      (sequence (loop :for i :to (- (length sequence) n)
+                      :collect (subseq sequence i (+ i n))))))
+  
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (export '(define-constant switch eswitch cswitch while ensure-boolean
-            with-gensyms with-unique-names once-only iota curry rcurry compose)))
+            with-gensyms with-unique-names once-only iota curry rcurry compose
+            n-grams)))
 
 ;;;; END OF quickutils.lisp ;;;;

--- a/src/main.lisp	Mon May 09 00:18:57 2016 +0000
+++ b/src/main.lisp	Mon May 09 01:01:35 2016 +0000
@@ -39,13 +39,12 @@
                :debug :scancode-d)
     ((ready)
      (mouse)
-     (p0)
-     (p1)
-     (p2)
-     (cp)
+     (start)
+     (end)
+     (controls)
      (end-pen (make-pen :fill (gray 0.2)))
      (control-pen (make-pen :stroke (gray 0.1) :fill (gray 0.5)))
-     (line-pen (make-pen :stroke (gray 0.5)))
+     (line-pen (make-pen :stroke (gray 0.8)))
      (target-pen (make-pen :fill (rgb 0.5 0.0 0.0)))
      (fn-pen (make-pen :stroke (rgb 0.0 0 0.5)
                        :weight 1
@@ -60,38 +59,17 @@
     ;;
     (when ready
 
-      (with-vecs ((p0x p0y) p0
-                  (p1x p1y) mouse
-                  (p2x p2y) p2)
-        (setf cp (make-vec
-                   (- (* p1x 2)
-                      (/ (+ p0x p2x) 2))
-                   (- (* p1y 2)
-                      (/ (+ p0y p2y) 2))))
-        (with-pen line-pen
-          (draw-line p0 cp)
-          (draw-line cp p2))
-        (with-pen end-pen
-          (draw-circle p0 5)
-          (draw-circle p2 5))
-        (with-pen target-pen
-          (draw-circle mouse 5))
-        (with-pen control-pen
-          (draw-circle cp 5))
-        (with-pen fn-pen
-          (draw-function
-            (lambda (v)
-              (make-vec (map-range 0.0 tau 0.0 *width* v)
-                        (+ *center-y* (* 100.0 (sin v)))))
-            :start 0.0
-            :end tau
-            )
-          )
-        (with-pen curve-pen
-          (quadratic-bezier-curve p0 p2 mouse)
-          (quadratic-bezier-curve p0 p2 cp)
-                
-                ))
+      (with-pen line-pen
+        (loop :for (a b) :on (append (list start) controls (list end))
+              :when b :do (draw-line a b)))
+      (with-pen end-pen
+        (draw-circle start 5)
+        (draw-circle end 5))
+      (with-pen control-pen
+        (mapc (rcurry #'draw-circle 5) controls))
+      (with-pen curve-pen
+        (multicurve start controls end))
+
       )
 
     ;;
@@ -105,12 +83,15 @@
 (defun reset (game)
   (setf (slot-value game 'ready) nil)
   (setf
-    (slot-value game 'p0)
-    (make-random-vec *width* *height*)
-    (slot-value game 'p1)
-    (make-random-vec *width* *height*)
-    (slot-value game 'p2)
-    (make-random-vec *width* *height*)
+    (slot-value game 'start)
+    (make-vec 0 *center-y*)
+    (slot-value game 'end)
+    (make-vec *width* *center-y*)
+    (slot-value game 'controls)
+    ; (loop :for x :from 100 :below *width* :by 100
+    ;       :collect (make-vec x (random *height*)))
+    (loop :repeat 8
+          :collect (make-random-vec *width* *height*))
     )
   (setf (slot-value game 'ready) t))
 

--- a/src/points.lisp	Mon May 09 00:18:57 2016 +0000
+++ b/src/points.lisp	Mon May 09 01:01:35 2016 +0000
@@ -44,11 +44,13 @@
   (draw-function (curry #'fast-quadratic-bezier from to control)))
 
 
-; (defun multicurve (points)
-;   (loop :for (p0 p1 . remaining) :on points
-;         :when remaining
-;         :for midx = (/ (+ (vec-x p0) (vec-x p1)) 2)
-;         :for midy = (/ (+ (vec-y p0) (vec-y p1)) 2)
-;         )
-  
-;   )
+(defun multicurve (from controls to)
+  (labels ((midpoint (pair)
+             (vec-lerp (car pair) (cadr pair) 0.5))
+           (midpoints (points)
+             (mapcar #'midpoint (n-grams 2 points))))
+    (let ((mids (midpoints controls)))
+      (loop :for start :in (cons from mids)
+            :for end :in (append mids (list to))
+            :for control :in controls
+            :do (quadratic-bezier-curve start end control)))))