Merge pull request #235 from kaveh808/opengl-mouse-picking-lines-sele…

…ction-cone

Opengl mouse picking - Pick Curves and lines using a selection cone

kons-9.asd

@@ -56,6 +56,7 @@
    (:file "src/kernel/clobber")
    (:file "src/kernel/ray-triangle-intersect")
    (:file "src/kernel/ray")
+   (:file "src/kernel/selection-cone")
    (:file "src/kernel/object-picking")
    (:file "src/kernel/main")
    ;; font libraries -- tmp until we use 3b-bmfont

src/graphics/glfw/glfw-gui.lisp

@@ -329,8 +329,8 @@
 
   ;; object picking
 
-  (when-pick-requested (ray multi-select)
-    (pick ray multi-select (scene view)))
+  (when-pick-requested (ray-from ray-to multi-select)
+    (pick ray-from ray-to multi-select (scene view)))
 
   ;; display ui layer
 

src/kernel/object-picking.lisp

@@ -4,17 +4,36 @@
 (defparameter *picking-request* nil)
 (defparameter *picking-selector* nil)
 
+(defparameter *object-picking-selection-cone-angle* (/ PI 180))
+
+;; While debugging, it can be useful to see what is actually being
+;; intersected. Setting the below debug flag to true causes the selection cone
+;; to be drawn along with the points of intersection. Note: The selection cone
+;; only becomes visible once the scene is rotated immediately after a pick.
+(defparameter *debug-object-picking-selection-cone* ())
+
+;; Similarly for debugging ray intersection
+(defparameter *debug-object-picking-ray* ())
+
 (defmacro make-pick-request (x y multi-select)
-  `(when *picking-enabled*
-     (setf *picking-request* (list ,x ,y ,multi-select))))
+  (when *picking-enabled*
+    `(setf *picking-request* (list ,x ,y ,multi-select))))
 
-(defmacro when-pick-requested ((ray multi-select) &body body)
-  `(when *picking-request*
-     (let ((,multi-select (elt *picking-request* 2))
-           (,ray (make-ray (elt *picking-request* 0)
-                           (elt *picking-request* 1))))
-       (setf *picking-request* nil)
-       ,@body)))
+(defmacro when-pick-requested ((from to multi-select) &body body)
+  (when *picking-enabled*
+    `(progn
+       (when *picking-request*
+         (let ((screen-x (elt *picking-request* 0))
+               (screen-y (elt *picking-request* 1))
+               (,multi-select (elt *picking-request* 2)))
+           (multiple-value-bind (,from ,to)
+               (gl-get-picking-ray-coords screen-x screen-y)
+             (setf *picking-request* nil)
+             ,@body)))
+       (when *debug-object-picking-selection-cone*
+         (draw-previous-selection-cone))
+       (when *debug-object-picking-ray*
+         (draw-previous-ray)))))
 
 ;; Given a scene, the below macro gets the currently selected items. It then
 ;; sets the scene selection to those items returned by the body form.
@@ -29,18 +48,43 @@
            (dolist (item ,g-new-selection)
              (add-to-selection ,g-scene item)))))))
 
-(defun make-ray (screen-x screen-y)
-  (multiple-value-bind (from to) (gl-get-picking-ray-coords screen-x screen-y)
-    (make-instance 'ray :from from :to to)))
-
-(defun pick (ray multi-select scene)
-  (multiple-value-bind (xs-hit xs-miss) (intersect ray scene)
-    (update-scene-selection (current-selection scene)
-      (funcall (choose-picking-selector multi-select)
-               :xs-hit xs-hit
-               :xs-miss xs-miss
-               :xs-current current-selection
-               ))))
+(defun pick (from to multi-select scene)
+  (flet ((make-ray () (make-instance 'ray :from from :to to))
+         (make-cone ()
+           (make-instance 'selection-cone
+                          :from from
+                          :to to
+                          :angle *object-picking-selection-cone-angle*)))
+    (let ((shapes (find-shapes scene #'identity)))
+      (multiple-value-bind (xs-hit xs-miss)
+          (intersect-shapes (make-ray) (make-cone) shapes)
+        (update-scene-selection (current-selection scene)
+          (funcall (choose-picking-selector multi-select)
+                   :xs-hit xs-hit
+                   :xs-miss xs-miss
+                   :xs-current current-selection))))))
+
+(defun intersect-shape (ray cone shape)
+  (if (typep shape 'curve)
+      (intersect cone shape)
+      (intersect ray shape)))
+
+(defun intersect-shapes (ray cone shapes)
+  (when *debug-object-picking-selection-cone*
+    (set-previous-selection-cone-and-intersects cone))
+  (when *debug-object-picking-ray*
+    (set-previous-ray ray))
+  (let ((xs-hit-distances '())
+        (xs-miss '()))
+    (mapc (lambda (shape)
+            (let ((distance (intersect-shape ray cone shape)))
+              (if distance
+                  (push (cons distance shape) xs-hit-distances)
+                  (push shape xs-miss))))
+          shapes)
+    (setf xs-hit-distances (stable-sort xs-hit-distances #'< :key #'car))
+    (let ((xs-hit (mapcar #'cdr xs-hit-distances)))
+      (values xs-hit xs-miss))))
 
 (defun choose-picking-selector (multi-select)
   (when (functionp *picking-selector*)

src/kernel/ray.lisp

@@ -1,5 +1,7 @@
 (in-package #:kons-9)
 
+(defparameter *previous-selection-ray* nil)
+
 (defclass ray ()
   ((from :initarg :from :reader from)
    (to :initarg :to :reader to)))
@@ -31,6 +33,26 @@
             (setf min-distance distance)))))
     min-distance))
 
+;;;; display ray (useful for debugging) ========================================
+
+(defun set-previous-ray (ray)
+  (setf *previous-selection-ray* ray))
+
+(defun draw-previous-ray ()
+  (when *previous-selection-ray*
+    (gl:line-width 1)
+    (gl:color 1.0 0.8 0.0)
+    (gl:shade-model :flat)
+    (gl:disable :lighting)
+    (flet ((v (vec3) (apply #'gl:vertex (coerce vec3 'list))))
+      (gl:begin :lines)
+      (v (from *previous-selection-ray*))
+      (v (to *previous-selection-ray*))
+      (gl:end))))
+
+
+;;;; intersect routines ========================================================
+
 ;;; ignore shapes for which the method is not defined; do not throw error
 (defmethod intersect ((self ray) (shape shape))
   nil)
@@ -46,16 +68,3 @@
         ;; of intersecting with triangles.
         (intersect-triangles self (triangles-world-array polyh))))))
 
-(defmethod intersect ((self ray) (scene scene))
-  (let ((xs-hit-distances '())
-        (xs-miss '())
-        (xs-all (find-shapes scene #'identity)))
-    (mapc (lambda (shape)
-            (let ((distance (intersect self shape)))
-              (if distance
-                  (push (cons distance shape) xs-hit-distances)
-                  (push shape xs-miss))))
-          xs-all)
-    (setf xs-hit-distances (stable-sort xs-hit-distances #'< :key #'car))
-    (let ((xs-hit (mapcar #'cdr xs-hit-distances)))
-      (values xs-hit xs-miss))))

src/kernel/selection-cone.lisp

@@ -0,0 +1,167 @@
+(in-package #:kons-9)
+
+(defparameter *previous-selection-cone* nil)
+(defparameter *previous-selection-cone-intersect-list* nil)
+
+(defclass selection-cone ()
+  ((from :initarg :from :reader from)
+   (to :initarg :to :reader to)
+   (angle :initarg :angle :reader angle)
+   (triangles :accessor triangles)))
+
+(defmethod print-object ((self selection-cone) stream)
+  (print-unreadable-object (self stream :type t)
+    (format stream "~s - ~s, ~s" (from self) (to self) (angle self))))
+
+(defmethod initialize-instance :after ((self selection-cone) &rest initargs)
+  (declare (ignore initargs))
+  (macrolet ((triangle-points (tri)
+               `(vector
+                 (origin.geometry.triangle::triangle-a ,tri)
+                 (origin.geometry.triangle::triangle-b ,tri)
+                 (origin.geometry.triangle::triangle-c ,tri))))
+    (multiple-value-bind (faces points)
+        (make-pyramid-faces (from self) (to self) (angle self))
+      (setf (triangles self) 
+            (map 'vector
+                 (lambda (face)
+                   (list
+                    (aref points (elt face 0))
+                    (aref points (elt face 1))
+                    (aref points (elt face 2))))
+                 (subseq faces 0 4))) ;;; the first 4 are lateral faces
+      )))
+
+(defun make-pyramid-faces (apex centroid angle)
+  (flet ((arbitrary-perpendicular (vec)
+           (dolist (a (list (p! 0 0 1) (p! 0 1 0)))
+             (let ((vec-norm (p:normalize vec)))
+               (when (not (p:parallel-p vec-norm a))
+                 (return (p:normalize (p:cross vec-norm a))))))))
+    (let* ((axis (p:- centroid apex))
+           (p-0 (arbitrary-perpendicular axis))
+           (p-1 (p:normalize (p:cross (p:normalize axis) p-0)))
+           (len (/ (coerce (* (p:length axis) (sin angle)) 'single-float) 2))
+           (-len (- len))
+           (q0 (p:+ (p:lerp (p:zero) p-0 len) axis))
+           (q1 (p:+ (p:lerp (p:zero) p-1 len) axis))
+           (q2 (p:+ (p:lerp (p:zero) p-0 -len) axis))
+           (q3 (p:+ (p:lerp (p:zero) p-1 -len) axis))
+           (c-0 (p:+ centroid q0))
+           (c-1 (p:+ centroid q1))
+           (c-2 (p:+ centroid q2))
+           (c-3 (p:+ centroid q3))
+           (points (vector apex c-0 c-1 c-2 c-3))
+           (faces (vector
+                   '(0 1 2)
+                   '(0 2 3)
+                   '(0 3 4)
+                   '(0 4 1)
+                   '(1 2 3 4))))
+      (values faces points))))
+
+(defun intersect-line (selection-cone p0 p1)
+  (let* ((line-start (p-vec p0))
+         (line-end (p-vec p1))
+         (line-vec (p:- line-end line-start))
+         (line-length (p:length line-vec))
+         (ray (make-instance 'ray :from line-start :to line-end))
+         (triangles (triangles selection-cone)))
+    (flet ((dist-from-cone-apex-to-pt (pt)
+             (p:length (p:- pt (from selection-cone))))
+           (positive? (a)
+             (when (and a (> a 0))
+               a)))
+      (dotimes (i (length triangles))
+        (destructuring-bind (p0 p1 p2) (aref triangles i)
+          (let ((distance (positive? (intersect-triangle ray p0 p1 p2))))
+            ;; successful intersection of a ray does not imply intersection of
+            ;; the line because a ray is infinite while a line is finite.
+            (when (and distance (<= distance line-length))
+              (let* ((intersect-pt (p:lerp line-start line-end
+                                           (/ distance line-length))))
+                (push intersect-pt *previous-selection-cone-intersect-list*)
+                (return-from intersect-line
+                  (dist-from-cone-apex-to-pt intersect-pt))))))))))
+
+(defun get-lines (curve)
+  ;;; the resulting lines reverse in order of the curve's points
+  (let* ((points (points curve))
+         (count (length points))
+         (lines '()))
+    (when (< (length points) 2)
+      (return-from get-lines))
+    (flet ((add-line (index-0 index-1)
+             (push (list (aref points index-0) (aref points index-1)) lines)))
+      (dotimes (i (- count 1) lines)
+        (add-line i (+ i 1)))
+      (when (is-closed-curve? curve)
+        (add-line (- count 1) 0)))
+    lines))
+
+
+;;;; display selection cone (useful for debugging) =============================
+
+(defun set-previous-selection-cone-and-intersects (cone)
+  (setf *previous-selection-cone* cone)
+  (setf *previous-selection-cone-intersect-list* nil))
+
+(defun draw-previous-selection-cone ()
+  (flet ((v (vec3) (apply #'gl:vertex (coerce vec3 'list))))
+    (when *previous-selection-cone*
+      (let ((triangles (triangles *previous-selection-cone*)))
+        (gl:shade-model :flat)
+        (gl:disable :lighting)
+        (dotimes (i (length triangles))
+          (destructuring-bind (p0 p1 p2) (aref triangles i)
+            (gl:color 1.0 1.0 0.0)
+            (gl:polygon-mode :front :fill)
+            (gl:begin :polygon)
+            (v p0)
+            (v p1)
+            (v p2)
+            (gl:end)
+
+            (gl:color 0.0 1.1 0.0)
+            (gl:polygon-mode :back :fill)
+            (gl:begin :polygon)
+            (v p0)
+            (v p1)
+            (v p2)
+            (gl:end)
+
+            (gl:line-width 1)
+            (gl:color 0.0 0.0 1.0)
+            (gl:begin :lines)
+            (v p0)
+            (v p1)
+            (v p2)
+            (gl:end)
+            ))))
+
+    (when *previous-selection-cone-intersect-list*
+      (gl:shade-model :flat)
+      (gl:disable :lighting)
+      (gl:point-size 10.0)
+      (gl:color 1.0 0.0 0.0 0.5)
+      (gl:begin :points)
+      (mapc #'v *previous-selection-cone-intersect-list*)
+      (gl:end))))
+
+
+;;;; intersect routines ========================================================
+
+(defmethod intersect ((self selection-cone) (shape shape))
+  nil)
+
+(defmethod intersect ((self selection-cone) (curve curve))
+  (setf *previous-selection-cone* self)
+  (flet ((intersect-with-line (line) ))
+    (let* ((distances (mapcar
+                       (lambda (line)
+                         (intersect-line self (car line) (cadr line)))
+                       (get-lines curve)))
+           (distances-non-null (remove-if #'null distances)))
+      (when distances-non-null
+        (apply #'min distances-non-null)))))
+