/[cello]/cello/pick.lisp
ViewVC logotype

Contents of /cello/pick.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Mon Jun 5 01:47:49 2006 UTC (7 years, 10 months ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.3: +17 -1 lines
Beginnings only of merge with Celtk
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*-
2 #|
3
4 Copyright (C) 2004 by Kenneth William Tilton
5
6 This library is free software; you can redistribute it and/or
7 modify it under the terms of the Lisp Lesser GNU Public License
8 (http://opensource.franz.com/preamble.html), known as the LLGPL.
9
10 This library is distributed WITHOUT ANY WARRANTY; without even
11 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
12
13 See the Lisp Lesser GNU Public License for more details.
14
15 |#
16
17 (in-package :cello)
18
19 (defun glut-mouse-is-over (pos self)
20 (r-contains (g-box self) pos)
21 ;; following works, but too much work when above suffices
22 #+(or) (member self
23 (ix-select pos (click-tolerance self) :target self)))
24
25 (dft uint* :pointer :int)
26 (dft int* :pointer :int)
27
28 ;;;#-lispworks
29 ;;;(declaim (type int* *ix-select-r*))
30 (defparameter *ix-select-r* (fgn-alloc 'glint 4))
31
32 (defun view-b (n)
33 (cffi:mem-aref *ix-select-r* 'glint n))
34
35 ;;;#-lispworks
36 ;;;(declaim (type uint* *ix-select-buffer*))
37
38 (defparameter *ix-select-buffer* (fgn-alloc 'gluint 512))
39 (defun buffy (y)
40 (cffi:mem-aref *ix-select-buffer* 'gluint) y)
41
42 (defun ix-select (pos tolerance &key (select :nearest) (target ctk::*tkw*))
43 (declare (ignorable select pos tolerance))
44 (gl-get-integerv gl_viewport *ix-select-r*)
45
46 (print `(ix-select viewport ,(loop for n below 4 collecting (view-b n))))
47
48 (gl-select-buffer 512 *ix-select-buffer*)
49 (gl-render-mode gl_select)
50 (gl-init-names)
51
52 (gl-push-name 0)
53 (gl-matrix-mode gl_projection)
54 (gl-push-matrix)
55 (gl-load-identity)
56
57 #+(or) (when pos ;; pass nil to select all visible
58 (glu-pick-matrix
59 (v2-h pos) (ups (view-b 3) (v2-v pos)) ;;OQ: are GLUT mouse y's up or down?
60 (v2-h tolerance) (v2-v tolerance) *ix-select-r*))
61
62 (glu-pick-matrix
63 500 500
64 1000 1000 *ix-select-r*)
65
66 #+(or) (let ((aspect (/ (- (view-b 2)(view-b 0))
67 (- (view-b 3)(view-b 1)))))
68 ;;(format t "~&perspective sees aspect: ~a" aspect)
69 (glu-perspective 45 aspect 0.1 100.0)) ;;OQ: appropriate for ortho?
70
71 (gl-matrix-mode gl_modelview)
72 #+(or) (let ((*ogl-listing-p* target)
73 *selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*)
74 (with-metrics (nil nil "ix-paint" self)
75 (ix-paint target)))
76 (gl-call-list (dsp-list target))
77
78
79 (gl-matrix-mode gl_projection)
80 (gl-pop-matrix)
81
82 (gl-matrix-mode gl_modelview)
83
84 (let ((hits (gl-render-mode gl_render)))
85 (print `(:hits ,hits))
86 (when (plusp hits)
87 (print `(:got-hits ,hits))
88 #+(or) (flet ((dist (n)
89 (buffy (1+ (* n 4))))
90 (self (n)
91 (buffy (+ 3 (* n 4)))))
92 (ecase select
93 (:all (let ((names (maptimes (x (1- hits)) #'self )))
94 (fm-collect-if target (lambda (node)
95 (member (gl-name node) names)))))
96 (:nearest (let ((closest 0))
97 (dotimes (n (1- hits))
98 (let ((next (1+ n)))
99 (if (< (dist next) (dist closest))
100 (setf closest next))))
101 (values (fm-find-if target (lambda (node)
102 (eql closest (gl-name node))))
103 (dist closest)))))))))
104

  ViewVC Help
Powered by ViewVC 1.1.5