-
Notifications
You must be signed in to change notification settings - Fork 32
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge pull request #222 from kaveh808/opengl-mouse-picking-with-ray-c…
…asting OpenGL mouse picking with ray casting
- Loading branch information
Showing
12 changed files
with
512 additions
and
4 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,74 @@ | ||
(in-package #:kons-9) | ||
|
||
(defparameter *picking-enabled* t) | ||
(defparameter *picking-request* nil) | ||
(defparameter *picking-selector* nil) | ||
|
||
(defmacro make-pick-request (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))) | ||
|
||
;; 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. | ||
(defmacro update-scene-selection ((current-selection scene) &body body) | ||
(let ((g-scene (gensym)) | ||
(g-new-selection (gensym))) | ||
`(let* ((,g-scene ,scene) | ||
(,current-selection (copy-list (selected-shapes ,g-scene)))) | ||
(let ((,g-new-selection (progn ,@body))) | ||
(when (listp ,g-new-selection) | ||
(clear-selection ,g-scene) | ||
(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 choose-picking-selector (multi-select) | ||
(when (functionp *picking-selector*) | ||
(return-from choose-picking-selector *picking-selector*)) | ||
|
||
(if multi-select | ||
#'picking-selector-click-multi | ||
#'picking-selector-click-1)) | ||
|
||
;; picking selector functions ================================================== | ||
|
||
(let ((prev-xs-hit nil) | ||
(i -1)) | ||
(defun picking-selector-click-1 (&key xs-hit xs-miss xs-current) | ||
(declare (ignore xs-miss xs-current)) | ||
(flet ((next-i () | ||
(setf i (mod (+ 1 i) (length xs-hit))) | ||
i)) | ||
(when (not (equal prev-xs-hit xs-hit)) | ||
(setf prev-xs-hit xs-hit) | ||
(setf i -1)) | ||
|
||
(when (not (null xs-hit)) | ||
(list (elt xs-hit (next-i))))))) | ||
|
||
(defun picking-selector-click-multi (&key xs-hit xs-miss xs-current) | ||
(declare (ignore xs-miss)) | ||
(let ((xs-hit-unselected (list-subtract xs-hit xs-current))) | ||
(if (null xs-hit-unselected) | ||
xs-current | ||
(cons (car xs-hit-unselected) xs-current)))) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,81 @@ | ||
(in-package #:kons-9) | ||
|
||
;;; Common Lisp port of the Moller-Trumbore ray-triangle intersection algorithm. | ||
;;; The original C code (raytri.c) authored by Tomas Moller was found here: | ||
;;; https://fileadmin.cs.lth.se/cs/Personal/Tomas_Akenine-Moller/raytri/raytri.c | ||
|
||
;;; Function `intersect_triangle` from raytri.c has been ported below as | ||
;;; `intersect/triangle`. Other optimized variations of this function still | ||
;;; remain to be ported to CL. Read more about the optimized variations in | ||
;;; Moller's insightful article here: | ||
;;; https://fileadmin.cs.lth.se/cs/Personal/Tomas_Akenine-Moller/raytri/ | ||
|
||
|
||
;; Ray-Triangle Intersection Test Routines | ||
;; Different optimizations of my and Ben Trumbore's | ||
;; code from journals of graphics tools (JGT) | ||
;; http://www.acm.org/jgt/ | ||
;; by Tomas Moller, May 2000 | ||
|
||
;; Copyright 2020 Tomas Akenine-Moller | ||
|
||
;; Permission is hereby granted, free of charge, to any person obtaining a copy | ||
;; of this software and associated documentation files (the "Software"), to deal | ||
;; in the Software without restriction, including without limitation the rights | ||
;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell | ||
;; copies of the Software, and to permit persons to whom the Software is | ||
;; furnished to do so, subject to the following conditions: | ||
|
||
;; The above copyright notice and this permission notice shall be included in | ||
;; all copies or substantial portions of the Software. | ||
|
||
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR | ||
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, | ||
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE | ||
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER | ||
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, | ||
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE | ||
;; SOFTWARE. | ||
|
||
(defun intersect/triangle (tri ray) | ||
(let ((epsilon 0.000001)) | ||
(let ((orig (origin.geometry.ray:origin ray)) | ||
(dir (origin.geometry.ray:direction ray)) | ||
(vert0 (origin.geometry.triangle::a tri)) | ||
(vert1 (origin.geometry.triangle::b tri)) | ||
(vert2 (origin.geometry.triangle::c tri))) | ||
(let* ( | ||
;; find vectors for two edges sharing vert0 | ||
(edge1 (p:- vert1 vert0)) | ||
(edge2 (p:- vert2 vert0)) | ||
;; begin calculating determinant - also used to calculate U | ||
(pvec (p:cross dir edge2)) | ||
;; if determinant is near zero, ray lies in plane of triangle | ||
(det (p:dot edge1 pvec))) | ||
(when (and (> det (- epsilon)) (< det epsilon)) | ||
(return-from intersect/triangle nil)) | ||
(let* ((inv-det (/ 1.0 det)) | ||
;; calculate distance from vert0 to ray origin | ||
(tvec (p:- orig vert0)) | ||
;; calculate U and test bounds | ||
(u (* (p:dot tvec pvec) inv-det))) | ||
(when (or (< u 0.0) (> u 1.0)) | ||
(return-from intersect/triangle nil)) | ||
(let* (;;prepare to test V | ||
(qvec (p:cross tvec edge1)) | ||
;; calculate V parameter and test bounds | ||
(v (* (p:dot dir qvec) inv-det))) | ||
(when (or (< v 0.0) (> (+ u v) 1.0)) | ||
(return-from intersect/triangle nil)) | ||
(let (;; calculate t, ray intersects triangle | ||
;; (using `t_` since `t` clashes in Common Lisp) | ||
(t_ (* (p:dot edge2 qvec) inv-det))) | ||
;; The original C code returns 1 if intersection occurs and 0 | ||
;; otherwise, while the actual values computed by the function, | ||
;; namely t, u, v are returned indirectly via pointer arguments | ||
;; whoose contents are populated by the function. | ||
|
||
;; Instead, we return `(values t u v)` if intersection occurs and | ||
;; nil otherwise. | ||
(values t_ u v)))))))) | ||
|
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,59 @@ | ||
(in-package #:kons-9) | ||
|
||
(defclass ray () | ||
((from :initarg :from :reader from) | ||
(to :initarg :to :reader to))) | ||
|
||
(defmethod print-object ((self ray) stream) | ||
(print-unreadable-object (self stream :type t) | ||
(format stream "~s - ~s" (from self) (to self)))) | ||
|
||
(defun intersect-aabb (ray point-min point-max) | ||
(origin.geometry:raycast-aabb | ||
(origin.geometry.ray:ray :origin (from ray) :direction (to ray)) | ||
(origin.geometry.aabb:aabb-from-min/max | ||
:min point-min :max point-max))) | ||
|
||
(defun intersect-triangle (ray p0 p1 p2) | ||
(intersect/triangle | ||
(origin.geometry.triangle:triangle p0 p1 p2) | ||
(origin.geometry.ray:ray :origin (from ray) :direction (to ray)))) | ||
|
||
(defun intersect-triangles (ray triangles) | ||
(let ((min-distance nil)) | ||
(do-array (_ points triangles) | ||
(let ((distance (intersect-triangle ray | ||
(aref points 0) | ||
(aref points 1) | ||
(aref points 2)))) | ||
(when distance | ||
(when (or (null min-distance) (< distance min-distance)) | ||
(setf min-distance distance))))) | ||
min-distance)) | ||
|
||
(defmethod intersect ((self ray) (shape shape)) | ||
(error "INTERSECT not implemented")) | ||
|
||
(defmethod intersect ((self ray) (polyh polyhedron)) | ||
(multiple-value-bind (lo hi) (get-bounds-world polyh) | ||
(when (and lo hi) | ||
(when (intersect-aabb self lo hi) | ||
;; before doing a more expensive operation of intersecting many | ||
;; triangles we first do a quick intersect with the shapes aabb (axis | ||
;; aligned bounding box). If the aabb does not intersect there is no use | ||
;; 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)))) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Oops, something went wrong.