;;; -*- mode: lisp; syntax: common-lisp -*-

;;; Based on bezier.cc

(require :cl-opengl)
(require :cl-glu)
(require :cl-glut)

(defparameter *resolution* 100)
(defparameter *width* 800)
(defparameter *height* 600)

(defclass bezier-window (glut:window)
  ((control-points :accessor control-points :initform nil)
   (dragging :accessor dragging :initform nil))
  (:default-initargs :width *width* :height *height*
                     :mode '(:double :rgb) :title "glut-Casteljau"))

(defun interpolate (a u b)
  (list (+ (first a) (* (- (first b) (first a)) u))
        (+ (second a) (* (- (second b) (second a)) u))))

(defun de-casteljau (control-points ratio)
  (if (= (length control-points) 1)
      (first control-points)
      (de-casteljau (mapcar #'(lambda (p q) (interpolate p ratio q))
                            (butlast control-points) (rest control-points))
                    ratio)))

(defun draw-curve (control-points)
  (unless (null control-points)
    ;; control polygon
    (gl:color 1.0 1.0 0.0)
    (gl:begin :line-strip)
    (dolist (p control-points)
      (gl:vertex (first p) (second p)))
    (gl:end)
    ;; control point boxes
    (gl:color 1.0 0.0 0.0)
    (gl:point-size 10.0)
    (gl:begin :points)
    (dolist (p control-points)
      (gl:vertex (first p) (second p)))
    (gl:end)
    ;; the curve itself
    (gl:color 0.0 1.0 0.0)
    (gl:begin :line-strip)
    (dotimes (i *resolution*)
      (let ((p (de-casteljau control-points (/ i (1- *resolution*)))))
        (gl:vertex (first p) (second p))))
    (gl:end)))

(defmethod glut:display ((w bezier-window))
  (gl:matrix-mode :modelview)
  (gl:clear :color-buffer-bit)
  (gl:load-identity)
  (gl:scale 0.341 0.455 1.0)
  (gl:translate -2.45 1.0 0.0)
  (draw-curve (control-points w))
  (glut:swap-buffers))

(defmethod glut:keyboard ((w bezier-window) key x y)
  (declare (ignore x y))
  (case (char-downcase (code-char key))
    (#\r (setf (control-points w) nil) (glut:post-redisplay))
    (#\q (glut:destroy-current-window))))

(defun distance (p q)
  (let ((x (- (first p) (first q)))
        (y (- (second p) (second q))))
    (sqrt (+ (* x x) (* y y)))))

(defun get-object-coordinates (x y)
  (multiple-value-bind (obj-x obj-y)
      (glu:un-project x (- (elt (gl:get-integer :viewport) 3) y) 0)
    (list (coerce obj-x 'single-float) (coerce obj-y 'single-float))))

(defun get-window-coordinates (p)
  (multiple-value-bind (x y)
      (glu:project (first p) (second p) 0)
    (list (round x) (- (elt (gl:get-integer :viewport) 3) (round y)))))

(defmethod glut:mouse ((w bezier-window) button state x y)
  (cond ((and (eq button :left-button) (eq state :up))
         (setf (dragging w) nil))
        ((and (eq button :left-button) (eq state :down))
         (setf (dragging w)
               (position (list x y)
                         (mapcar #'get-window-coordinates
                                 (control-points w))
                         :test #'(lambda (p q) (< (distance p q) 7))))
         (unless (dragging w)
           ;; insert new control point
           (setf (control-points w)
                 (append (control-points w)
                         (list (get-object-coordinates x y))))
           (glut:post-redisplay)))))

(defmethod glut:motion ((w bezier-window) x y)
  (when (dragging w)
    (setf (nth (dragging w) (control-points w))
          (get-object-coordinates x y))
    (glut:post-redisplay)))

(defun bezier ()
  (glut:display-window (make-instance 'bezier-window)))