diff --git a/kons-9.asd b/kons-9.asd index 41a3514..eac6929 100644 --- a/kons-9.asd +++ b/kons-9.asd @@ -54,6 +54,9 @@ (:file "src/kernel/scene-duplicate") (:file "src/kernel/protocol") (:file "src/kernel/clobber") + (:file "src/kernel/ray-triangle-intersect") + (:file "src/kernel/ray") + (:file "src/kernel/object-picking") (:file "src/kernel/main") ;; font libraries -- tmp until we use 3b-bmfont (:module "lib/JMC-font-libs/font-master" @@ -115,7 +118,8 @@ (:file "assertions") (:module "kernel" :components ((:file "utils") - (:file "point-cloud"))) + (:file "point-cloud") + (:file "ray-triangle-intersect"))) (:file "entrypoint"))))) (asdf:defsystem #:kons-9/api-docs diff --git a/src/graphics/glfw/glfw-gui.lisp b/src/graphics/glfw/glfw-gui.lisp index 810a305..8464253 100644 --- a/src/graphics/glfw/glfw-gui.lisp +++ b/src/graphics/glfw/glfw-gui.lisp @@ -42,6 +42,32 @@ view) |# +;;;; utils ===================================================================== + +(let ((mouse-moved "undefined")) + + (defun simple-click-disturbed () + (setf mouse-moved t)) + + (defun simple-click-left-p (button action) + (when (eq button :left) + (when (eq action :press) + (setf mouse-moved nil)) + (when (eq action :release) + (eq mouse-moved nil)))) + ) + +(defun win-to-screen-xy (win-x win-y) + ;; In `screen space` (also for OpenGL) origin is in the botton-left. In window + ;; space, origin is in the top-left. So, screen-x is same as win-x but we need + ;; to translate win-y to get screen-y. + (values + win-x + (- (second *window-size*) win-y))) + +(defun shift-key-p (modifier-keys) + (not (not (find :shift modifier-keys)))) + ;;;; scene-view ================================================================ (defclass-kons-9 scene-view () @@ -301,6 +327,11 @@ (when *display-ground-plane?* (draw-ground-plane)) + ;; object picking + + (when-pick-requested (ray multi-select) + (pick ray multi-select (scene view))) + ;; display ui layer (2d-setup-projection (first *window-size*) (second *window-size*)) @@ -476,7 +507,10 @@ (setf *current-mouse-pos-y* (second pos)) (setf *current-mouse-modifier* (and mod-keys (car mod-keys))) (cond ((eq action :press) - (mouse-click (first pos) (second pos) button mod-keys))))) + (mouse-click (first pos) (second pos) button mod-keys))) + (when (simple-click-left-p button action) + (multiple-value-bind (x y) (win-to-screen-xy (first pos) (second pos)) + (make-pick-request x y (shift-key-p mod-keys)))))) (glfw:def-cursor-pos-callback cursor-position-callback (window x y) ;; (format t "mouse x: ~a, y: ~a~%" x y) @@ -488,7 +522,8 @@ (cond ((eq action :press) (mouse-dragged x y dx dy)) (t - (mouse-moved x y dx dy)))))) + (mouse-moved x y dx dy))))) + (simple-click-disturbed)) (defun register-choice-menu (menu x y) (setf *current-choice-menu-and-pos* (list menu x y))) diff --git a/src/graphics/opengl/opengl.lisp b/src/graphics/opengl/opengl.lisp index 124d705..a386e2b 100644 --- a/src/graphics/opengl/opengl.lisp +++ b/src/graphics/opengl/opengl.lisp @@ -508,4 +508,18 @@ (gl:enable :blend) ) +;;; ray ======================================================================= +(defun gl-get-camera-position () + (let* ((inverse-matrix (origin.dmat4:invert (gl:get-double :modelview-matrix))) + (position (origin.dmat4:get-translation inverse-matrix))) + (p-vec position))) + +(defun gl-unproject-to-far-plane (screen-x screen-y) + (multiple-value-bind (x y z) + (glu:un-project screen-x screen-y 1.d0) + (p! x y z))) + +(defun gl-get-picking-ray-coords (screen-x screen-y) + (values (gl-get-camera-position) + (gl-unproject-to-far-plane screen-x screen-y))) diff --git a/src/kernel/object-picking.lisp b/src/kernel/object-picking.lisp new file mode 100644 index 0000000..3f04473 --- /dev/null +++ b/src/kernel/object-picking.lisp @@ -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)))) diff --git a/src/kernel/polyhedron.lisp b/src/kernel/polyhedron.lisp index 9659da2..c30b700 100644 --- a/src/kernel/polyhedron.lisp +++ b/src/kernel/polyhedron.lisp @@ -118,6 +118,24 @@ (defmethod face-points-array ((polyh polyhedron) (face list)) (coerce (face-points-list polyh face) 'vector)) +(defmethod triangles-list ((polyh polyhedron) &key (matrix nil)) + ;; TODO: this function will only work for convex polyhedrons but it should + ;; work for all cases. + (let ((triangles '()) + (tri-polyh (if (is-triangulated-polyhedron? polyh) + polyh + (triangulate-polyhedron polyh)))) + (flet ((transform-if (xs) (if matrix (transform-points xs matrix) xs))) + (do-array (_ face (faces tri-polyh)) + (push (transform-if (face-points-array tri-polyh face)) triangles))) + triangles)) + +(defmethod triangles-array ((polyh polyhedron) &key (matrix nil)) + (coerce (triangles-list polyh :matrix matrix) 'vector)) + +(defmethod triangles-world-array ((polyh polyhedron)) + (triangles-array polyh :matrix (transform-matrix (transform polyh)))) + (defmethod reverse-face-normals ((polyh polyhedron)) (dotimes (i (length (face-normals polyh))) (setf (aref (face-normals polyh) i) (p:negate (aref (face-normals polyh) i)))) diff --git a/src/kernel/ray-triangle-intersect.lisp b/src/kernel/ray-triangle-intersect.lisp new file mode 100644 index 0000000..7113400 --- /dev/null +++ b/src/kernel/ray-triangle-intersect.lisp @@ -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)))))))) + diff --git a/src/kernel/ray.lisp b/src/kernel/ray.lisp new file mode 100644 index 0000000..7537e66 --- /dev/null +++ b/src/kernel/ray.lisp @@ -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)))) diff --git a/src/kernel/shape.lisp b/src/kernel/shape.lisp index 9da79a9..775288b 100644 --- a/src/kernel/shape.lisp +++ b/src/kernel/shape.lisp @@ -46,6 +46,12 @@ (warn "Shape ~a does not have GET-BOUNDS defined. Using default bounds values." self) (values (p! -1 -1 -1) (p! 1 1 1))) +(defmethod get-bounds-world ((self shape)) + (multiple-value-bind (lo hi) (get-bounds self) + (let ((m (transform-matrix (transform self)))) + (values (transform-point lo m) + (transform-point hi m))))) + (defmethod center-at-origin ((self shape)) (multiple-value-bind (bounds-lo bounds-hi) (get-bounds self) diff --git a/src/kernel/utils.lisp b/src/kernel/utils.lisp index 9b6d387..4b7d070 100644 --- a/src/kernel/utils.lisp +++ b/src/kernel/utils.lisp @@ -148,6 +148,11 @@ (defun vec-last (vec) (aref vec (1- (length vec)))) +(defun list-subtract (list-1 list-2) + (remove-if + (lambda (el) (member el list-2)) + list-1)) + ;;;; math ====================================================================== (defconstant 2pi (* 2 pi)) diff --git a/test/demo-object-picking.lisp b/test/demo-object-picking.lisp new file mode 100644 index 0000000..79a38d6 --- /dev/null +++ b/test/demo-object-picking.lisp @@ -0,0 +1,133 @@ +(in-package #:kons-9) + +#| + +These demos assume that you have succeeded in loading the system and opening +the graphics window. If you have not, please check the README file. + +Make sure you have opened the graphics window by doing: + +(in-package :kons-9) +(run) + +|# + +;;; Object selection =========================================================== + +;;; To select objects, a ray is cast out from the camera to the far point under +;;; the mouse cursor. The ray penetrates through all objects in its path. + +;;; xs-hit is a list of objects hit by the ray. + +;;; xs-miss is a list of objects not hit. + +;;; Below are a couple of custom "picking selection" functions to demonstrate +;;; how xs-hit and xs-miss along with the current selection can be used to +;;; decide which objects remain selected in a scene after a ray is cast out. + + +;;; Example 1 - Laser gun ====================================================== + +;;; First, create random shapes to shoot at by evaluating the following: + +(with-clear-scene + (flet ((random-shape (size) + (funcall + (elt '(make-cube make-octahedron make-icosahedron) (random 3)) + size))) + (let ((step 1) (shape-size 0.4) (bound 1)) + (do ((x (- bound) (+ x step))) + ((> x bound)) + (do ((y (- bound) (+ y step))) + ((> y bound)) + (do ((z (- bound) (+ z step))) + ((> z bound)) + (add-shape (scene *scene-view*) + (translate-to (random-shape shape-size) (p! x y z))))))))) + +;;; Next, assign a function to global variable *picking-selector*. Normally, +;;; *picking-selector* remains nil and in which case the default inbuilt +;;; selector function is used. + +;;; This function should have `(&key xs-hit xs-miss xs-current)` as its expected +;;; arguments (lambda list). This function gets called by kons-9 whenever its +;;; time to decide which objects make up the new selection of the scene after a +;;; object picking ray is cast out. + +;;; The list returned by the function becomes the new scene selection. + +;;; btw, for this demo shooting an object only selects it. + +;;; To act like a laser gun, shooting should select all xs-hit but we also +;;; maintain previously hit objects. So we need to return a concatenation of +;;; xs-hit and xs-current. + +;;; xs-current which is also passed as an argument to this function is a list of +;;; all items currently selected in the scene. + +(setf *picking-selector* + (lambda (&key xs-hit xs-miss xs-current) + (declare (ignore xs-miss)) + ;; laser shoot - append to the current selection all objects which were + ;; hit by the laser. + (concatenate 'list xs-current xs-hit))) + +;;; Now, try clicking on objects in the scene to shoot them! + +;;; At anytime to clear selections, evaluate: + +(clear-selection *scene*) + +;;; You can also try rotating the scene until many objects line up and then +;;; shoot all aligned objects in one shot. + + +;;; Example 2 - All except closest ============================================= + +;;; This selector function will select all items in the scene except for the +;;; closest hit. + +(setf *picking-selector* + (lambda (&key xs-hit xs-miss xs-current) + (declare (ignore xs-current)) + ;; select everything except the closest hit + (when (> (length xs-hit) 0) + (concatenate 'list (cdr xs-hit) xs-miss)))) + + +;;; Once done, you can bring back the default selector using: + +(setf *picking-selector* nil) + +;;; Default selectors ========================================================== + +;;; By default, there are actually two selector functions, not one: + +;;; 1. `picking-selector-click-1` - This selector function comes into effect +;;; when a left click is done without using any modifier keys such as shift or +;;; control. Only one object gets selected at a time. + +;;; Apart from selecting only one object at a time, this function selects a +;;; different object on each subsequent click in the case when multiple objects +;;; are in the line of the picking ray. This behaviour also makes it easy to +;;; choose objects which are extremely close to each other. + +;;; To bring in the default picking behaviour set *picking-selector* to nil: + +(setf *picking-selector* nil) + +;;; Populate the scene with closely placed cubes and try single left clicks +;;; multiple times to select the cubes. As long as the cubes are oriented such +;;; that they all in the line of the ray, they will each get their turn in being +;;; selected. + +(with-clear-scene + (add-shapes (scene *scene-view*) + (list + (translate-to (make-cube 1) (p! 0 0 0)) + (translate-to (make-cube 1) (p! -0.05 0.05 -0.05)) + (translate-to (make-cube 1) (p! -0.1 0.1 -0.1))))) + +;;; 2. `picking-selector-click-multi` - This selector function comes into effect +;;; when a left click occurs while the shift key was pressed down. The behaviour +;;; is to `add` to the current selection, the closest unselected object. diff --git a/testsuite/entrypoint.lisp b/testsuite/entrypoint.lisp index 771b98e..cd755a5 100644 --- a/testsuite/entrypoint.lisp +++ b/testsuite/entrypoint.lisp @@ -11,4 +11,5 @@ (define-testcase run-all-tests () "Run all available tests." (testsuite-utils) - (testsuite-point-cloud)) + (testsuite-point-cloud) + (testsuite-ray-triangle)) diff --git a/testsuite/kernel/ray-triangle-intersect.lisp b/testsuite/kernel/ray-triangle-intersect.lisp new file mode 100644 index 0000000..8fee298 --- /dev/null +++ b/testsuite/kernel/ray-triangle-intersect.lisp @@ -0,0 +1,78 @@ +(in-package #:kons-9/testsuite) + +(define-testcase exercise-ray-traingle-intersect () + (flet ((vec (a b c) + (origin.vec3:vec (coerce a 'single-float) + (coerce b 'single-float) + (coerce c 'single-float))) + (mk-ray (from to) + (origin.geometry.ray:ray :origin from :direction to))) + (let ((triangle (origin.geometry.triangle:triangle + (vec -3.5 0 -4.5) + (vec -4 1 -4.0) + (vec -4.5 0 -3.5)))) + (flet ((intersect (from to) + (kons-9::intersect/triangle triangle (mk-ray from to)))) + + ;;; Try intersections With default camera position + ;; top vertex + (assert-float-is-essentially-equal ;; inside triangle + 15.355117 + (intersect (vec 5.540323 2.5881906 7.912401) + (vec -0.6207694 -0.10930262 -0.7763364))) + (assert-eq ;; outside triangle + nil + (intersect (vec 5.540323 2.5881906 7.912401) + (vec -0.619678 -0.10301772 -0.7780659))) + ;; left vertex + (assert-float-is-essentially-equal ;; inside triangle + 15.416862 + (intersect (vec 5.540323 2.5881906 7.912401) + (vec -0.6404545 -0.16041444 -0.7510561))) + (assert-eq ;; outside triangle + nil + (intersect (vec 5.540323 2.5881906 7.912401) + (vec -0.6561073 -0.16276513 -0.73690623))) + ;; right vertex + (assert-float-is-essentially-equal ;; inside triangle + 15.5198345 + (intersect (vec 5.540323 2.5881906 7.912401) + (vec -0.59513503 -0.1619278 -0.7871427))) + (assert-eq ;; outside triangle + nil + (intersect (vec 5.540323 2.5881906 7.912401) + (vec -0.5779269 -0.1710878 -0.79795325))) + + ;;; Retry intersections after zoomin in (closer to triangle) + ;; top vertex + (assert-float-is-essentially-equal ;; inside triangle + 1.7190325 + (intersect (vec -3.2982311 0.5 -2.5083206) + (vec -0.4080841 0.28324336 -0.86789435))) + (assert-eq ;; outside triangle + nil + (intersect (vec -3.2982311 0.5 -2.5083206) + (vec -0.4061101 0.29344934 -0.8654259))) + ;; left vertex + (assert-float-is-essentially-equal ;; inside triangle + 1.6304653 + (intersect (vec -3.2982311 0.5 -2.5083206) + (vec -0.72773695 -0.29837447 -0.6175529))) + (assert-eq ;; outside triangle + nil + (intersect (vec -3.2982311 0.5 -2.5083206) + (vec -0.73710036 -0.3065231 -0.6022679))) + ;; right vertex + (assert-float-is-essentially-equal ;; inside triangle + 2.0412412 + (intersect (vec -3.2982311 0.5 -2.5083206) + (vec -0.10965764 -0.23859437 -0.9649082))) + (assert-eq ;; outside triangle + nil + (intersect (vec -3.2982311 0.5 -2.5083206) + (vec -0.09089148 -0.24464947 -0.9653421))) + )))) + + +(define-testcase testsuite-ray-triangle () + (exercise-ray-traingle-intersect))