LINUX.ORG.RU
Форум — Development  

простая геометрия


0

2

На самом деле детский вопрос) или др. словами что-то я туплю.

Как определить проходит ли отрезок через четырёхугольник? У меня как-то криво получается - построить треугольник, проведя линии от концов отрезка к 1 из вершин четырёхугольника, найти высоту и коррдинаты её точки на основании, проверить меньше ли эта высота стороны 4х-угольника и лежит ли точка в пределах 2х вершин(вершины 3угольника и диагональной) - вроде можно проще было.

 ← 1 2 →
Ответ на: комментарий от pseudo-cat

спасибо за самый понятный вариант beastie :)

quasimoto, у меня ваш вариант проваливается в бесконечную рекурсию) вот с такими or* и lines - 

(defun include-p (point rectangle) 
  (and (> (point-x point) (point-x (rectangle-a rectangle))) 
       (> (point-y point) (point-y (rectangle-a rectangle))) 
       (< (point-x point) (point-x (rectangle-b rectangle))) 
       (< (point-y point) (point-y (rectangle-b rectangle))))) 

(defun intersects-p (line rectangle) 
  (or (include-p (line-a line) rectangle) 
      (include-p (line-b line) rectangle) 
      (apply #'or* (mapcar #'(lambda (e) 
			      (intersects-p line e)) 
			  (lines rectangle)))))

(defun point-x (p)
  (car p))

(defun point-y (p)
  (cdr p))

(defun line-a (l)
  (car l))

(defun line-b (l)
  (cadr l))

(defun rectangle-a (r) 
  (car r))

(defun rectangle-b (r)
  (cadr r))

(defun lines (r)
  (labels ((iter-lines (p1 p2 p3 p4)
	     (list (list p1 p2)
		   (list p2 p3)
		   (list p3 p4)
		   (list p4 p1))))
    (iter-lines (rectangle-a r) 
		(cons (point-x (rectangle-a r)) (point-y (rectangle-b r)))
		(rectangle-b r)
		(cons (point-x (rectangle-b r)) (point-y (rectangle-a r))))))


(defun or* (ps)
  (not (loop for p in ps never p)))

pseudo-cat ★★★
() автор топика
Ответ на: комментарий от pseudo-cat

Есть такая особенность - (or form_1 .. form_k) вернёт T на первой же истинной форме, и дальнейшие вычисления производиться не будут, это хорошо с точки зрения производительности. Но из-за этого же or это макрос, нельзя сделать

(mapcar #'or list)

или

(apply #'or list)

так что

(defun or* (list)
  (if (endp list)
      nil
      (if (car list)
          t
          (or* (cdr list)))))

но он не ленивый - и это плохо. Либо есть вариант с macro-call, но он использует eval, поэтому тут лучше просто написать:

(defmethod intersects-p ((line line) (rectangle rectangle)) 
  (or (include-p (line-a line) rectangle)
      (include-p (line-b line) rectangle)
      (let ((lines (lines rectangle)))
        (or (intersects-p line (nth 0 lines))
            (intersects-p line (nth 1 lines))
            (intersects-p line (nth 2 lines))
            (intersects-p line (nth 3 lines))))))
quasimoto ★★★★
()
Ответ на: комментарий от pseudo-cat

Так вообще никогда не поедет :) У меня там генерируются CLOS структуры (ниже макрос define-structured-set и прочие), а include-p и intersects-p - это методы для них.

quasimoto ★★★★
()
Ответ на: комментарий от quasimoto

не в обиду, но ваш код реально сложен, особенно для наглядного пояснения идеи :) 

(defmethod intersects-p ((line line) (rectangle rectangle)) 
  (or (include-p (line-a line) rectangle) 
      (include-p (line-b line) rectangle) 
      (apply #'or* (mapcar #'(lambda (e) 
                               (intersects-p line e)) 
                            (lines rectangle)))))
lines возвращает объекты типа rectangle? или должен быть ещё один метод? иначе ведь (intersects-p line e) не выполнится ниразу

pseudo-cat ★★★
() автор топика
Ответ на: комментарий от pseudo-cat

не в обиду, но ваш код реально сложен, особенно для наглядного пояснения идеи :)

Да, он не наглядный. Я бы даже сказал там есть признакии неких маний :) Вот всё вместе, плюс парочка примеров:


(defun symbol+ (&rest symbols)
  (intern (apply #'concatenate 'string (mapcar #'string symbols))))

;;;
;;; Define set as structure.
;;;

(defmacro define-structured-set ((name &key (element-type t) (initial-value nil) constructor) &rest elements)
  `(progn
     (defparameter ,(symbol+ '* name '-slots*) (list ,@(mapcar #'(lambda (e)
                                                                   `',(symbol+ name '- e))
                                                               elements)))
     (defstruct (,name (:constructor ,(if constructor constructor name) (,@elements)))
       ,@(mapcar #'(lambda (e) `(,e ,initial-value :type ,element-type)) elements))
     (defmethod print-object ((,name ,name) stream)
       (format stream "{~A}"
               (let ((string (format nil "~{~A, ~}"
                                     (list ,@(mapcar #'(lambda (e)
                                                         `(,(symbol+ name '- e) ,name))
                                                     elements)))))
                 (subseq string 0 (- (length string) 2)))))
     (defmacro for-each ((e type set) &body body)
       `(let (,e)
          (loop :for acc :in ,(symbol+ '* type '-slots*)
                :do (progn
                      (setf ,e (funcall acc ,set))
                      ,@body))))
     (values ',name)))

;;;
;;; Linear vector spaces
;;;

;; Define LVS point as set of coordinates (for some basis)
;;
(defmacro define-linear-vector-space (name &rest coordinates)
  `(define-structured-set (,name :element-type integer :initial-value 0) ,@coordinates))

;; Define figure as set of points
;;
(defmacro define-figure ((name linear-vector-space &rest other-args) &rest points)
  `(define-structured-set (,name :element-type ,linear-vector-space ,@other-args) ,@points))

;;;
;;; Euclidean plane geometry
;;;

(define-linear-vector-space point x y) ;; or vector

(defconstant +zero-vector+ (point 0 0))

(defmacro define-point-op (name op)
  `(defun ,name (a b)
     (point (,op (point-x a) (point-x b))
            (,op (point-y a) (point-y b)))))

(define-point-op point+ +)
(define-point-op point- -)

(define-figure (line point) a b)

;; (line (point 1 2) (point 3 4))
;; => {{1, 2}, {3, 4}}

(define-figure (rectangle point :constructor %rectangle) a b c d)
(defun rectangle (a dx dy)
  (%rectangle a
              (point+ a (point dx 0))
              (point+ a (point dx dy))
              (point+ a (point 0 dy))))

;; (rectangle (point 1 2) 3 4)
;; => {{1, 2}, {4, 2}, {1, 6}, {4, 6}}

(defmethod first-point ((rectangle rectangle)) (rectangle-a rectangle))

(defmethod lines ((rectangle rectangle))
  (let (prev-point lines)
    (for-each (point rectangle rectangle)
      (when prev-point
        (push (line prev-point point) lines))
      (setf prev-point point))
    (list (nreverse lines) (line prev-point (first-point rectangle)))))

;; (lines (rectangle (point 1 2) 3 4))
;; => (({{1, 2}, {4, 2}} {{4, 2}, {4, 6}} {{4, 6}, {1, 6}}) {{1, 6}, {1, 2}})

(defmethod include-p ((point point) (rectangle rectangle))
  (and (> (point-x point) (point-x (rectangle-a rectangle)))
       (> (point-y point) (point-y (rectangle-a rectangle)))
       (< (point-x point) (point-x (rectangle-b rectangle)))
       (< (point-y point) (point-y (rectangle-b rectangle)))))

(defmethod include-p ((line line) (rectangle rectangle))
  (and (include-p (line-a line) rectangle)
       (include-p (line-b line) rectangle)))

(defmethod intersects-p ((line1 line) (line2 line))
;; TODO
)

(defmethod intersects-p ((line line) (rectangle rectangle))  
  (or (include-p (line-a line) rectangle) 
      (include-p (line-b line) rectangle) 
      (let ((lines (lines rectangle))) 
        (or (intersects-p line (nth 0 lines)) 
            (intersects-p line (nth 1 lines)) 
            (intersects-p line (nth 2 lines)) 
            (intersects-p line (nth 3 lines))))))

Только intersects-p не сделан - нужно списать отсюда

Если нужен самый простой способ (притом быстрый), то - Liang-Barsky

quasimoto ★★★★
()
Ответ на: комментарий от quasimoto

вообще-то можно было не изобретать велосипед и воспользоваться, например find и вместо 

(apply #'or* (mapcar #'(lambda (e) (intersects-p line e))  
             (lines rectangle))
написать 
(find line (lines rectangle) :test intersects-p)
и проще, и понятней, и никаких промежуточных списков и ненужных вычислений =)

korvin_ ★★★★★
()
Ответ на: комментарий от korvin_

Find не получиться - нужно использовать спец. форму с ленивым поведением, т.е. or. Вот

(find :a (list :a :b :c (sleep 10)) :test #'eq)
;; упс. ждём 10 сек. А зачем?

(or :a :b :c (sleep 10))
;; ничего не ждём

Я на предыдущей странице расписывал - мол, сложность от 4 гп до 40 гп при различных случаях. Если не использовать or, а использовать энергичные функции CL - мы будем всегда получать максимальную сложность (40 гп).

quasimoto ★★★★
()
Ответ на: комментарий от korvin_ 
or
  точка в контуре (1)
  другая точка в контуре (2)
  линия пересекает первое ребро (3)
  ..
  линия пересекает четвёртое ребро (6)

or (ленивый) сам управляет сложностью - может хватить вычисления только (1) (остальное *не* будет вычисляться), а может (1)(2), а может и всех (6) условий.

quasimoto ★★★★
()

Кстати, не надо думать о задаче (об этой задаче) в терминах языка (в данном случае CL), нужно думать в терминах самой задачи. В терминах данной задачи есть фундаментальный or, но никакого find нет.

quasimoto ★★★★
()
Ответ на: комментарий от quasimoto

использую такую ф-цию(не я автор) для проверки пересечения отрезка с рёбрами - 

(defun get-intersection (x1 y1 x2 y2 x3 y3 x4 y4)
  (let ((denom (- (* (- y4 y3) (- x2 x1)) (* (- x4 x3) (- y2 y1))))
	(ua-num (- (* (- x4 x3) (- y1 y3)) (* (- y4 y3) (- x1 x3))))
	(ub-num (- (* (- x2 x1) (- y1 y3)) (* (- y2 y1) (- x1 x3)))))
    (cond 
      ((and (zerop denom) (zerop ua-num) (zerop ub-num)) (list x1 y1))
      ((zerop denom) nil)
      (t 
       (let ((ua (/ ua-num denom))
	     (ub (/ ub-num denom)))
	 (if (and (<= 0 ua 1) (<= 0 ub 1))
	     (list (+ x1 (* ua (- x2 x1)))
		   (+ y1 (* ua (- y2 y1))))
	     nil))))))

pseudo-cat ★★★
() автор топика
Ответ на: комментарий от pseudo-cat

Но ведь портянка не на языке задачи :)

(↑) :: Point -> Line -> Bool 
(Vector x y) ↑ (Line (Vector x1 y1) (Vector x2 y2)) = if x1 == x2 
        then x < x1 
        else if y1 == y2 
             then y > y1 
             else (y / x) > ((y2 - y1) / (x2 - x1)) 
 
(↓) :: Point -> Line -> Bool 
point ↓ line = not (point ↑ line) 

(×) :: Line -> Line -> Bool 
line1@(Line p11 p12) × line2@(Line p21 p22) = (((p11 ↑ line2) && (p12 ↓ line2)) || ((p11 ↓ line2) && (p12 ↑ line2))) 
                                           && (((p21 ↑ line1) && (p22 ↓ line1)) || ((p21 ↓ line1) && (p22 ↑ line1)))

Будет


(defmethod up/left ((point point) (line line))
  (if (= (point-x (line-a line)) (point-x (line-b line)))
      (< (point-x point) (point-x (line-a line)))
      (if (= (point-y (line-a line)) (point-y (line-b line)))
          (> (point-y point) (point-y (line-a line)))
          (> (/ (point-y point) (point-x point))
             (/ (- (point-y (line-b line)) (point-y (line-a line)))
                (- (point-x (line-b line)) (point-y (line-x line))))))))

(defmethod down/rigth ((point point) (line line))
  (not (up/left point line)))

(defmethod intersects-p ((line1 line) (line2 line))
  (and (or (and (up/left (point-a line1) line2)    (down/rigth (point-b line1) line2))
           (and (down/rigth (point-a line1) line2) (up/left (point-b line1) line2)))
       (or (and (up/left (point-a line2) line1)    (down/rigth (point-b line2) line1))
           (and (down/rigth (point-a line2) line1) (up/left (point-b line2) line1)))))

но я не проверял, там ещё simplification - for positive numbers only. И это для произвольных линий, для только верт. и гориз. всё очень упрощается.

quasimoto ★★★★
()
Ответ на: комментарий от quasimoto

я хаскеля не читаю)

надо было просто побыстрее получить рабочий intersects-p для line и rectangle, это не особо важная возможность в моей программе и хотелось продолжить основную работу как можно быстрей)

pseudo-cat ★★★
() автор топика
Ответ на: комментарий от pseudo-cat

вариант beastie(первоначальный) самый быстрый вроде как, хотя и работает только для выпуклых многоугольников , ocaml для разнообразия :) 

type orientation = Left|Right|Zero;; 
type point = float * float;;
type poly = point list;;
let orientation (a:point) (b:point) (c:point) = 
  match a,b,c with
      (xa,ya),(xb,yb),(xc,yc) -> let det = (xb -. xa) *. (yc -. yb) -. (xc -. xb) *. (yb -. ya) in
	if det< 0.0 then Left
	else
	  if det = 0.0 then Zero else Right;;
let isSame a b = 
  match a,b with
      Left,Left -> true
    | Right,Right -> true
    | Zero, _ -> true
    | _, Zero -> true
    | _,_ -> false;;
let isInner p poly = 
  let fst = (List.hd poly) in
  let rec loop prevOrientation = function
      h::t -> let nv = try (List.hd t) with _ -> fst in
	(
	  match prevOrientation with
	    Zero -> loop (orientation p h nv) t  
	  | _ -> (isSame prevOrientation (orientation p h nv)) && (loop prevOrientation t)
	)
    | _ -> true
  in loop Zero poly;;
let outer_line a b poly = 
  not ((isInner a poly) or (isInner b poly));;

anonymous
()
Ответ на: комментарий от anonymous

а, пардон, не совсем то, что предлагал beastie -- здесь используется тот факт, что при обходе замкнутой кривой, радиус-вектор относительно заданной точки совершает по крайней мере один оборот, если точка внутренняя и ни одного - если внешняя.

Поскольку у нас выпуклый многоугольник, радиус-вектор, во-первых совершит точно один оборот или ни одного, а во-вторых имеется однозначное соответствие между количеством оборотов и ориентацией пар векторов составленных из радиус-вектора вершины относительно точки и примыкающего к ней ребра. Для внутренней точки ориентация будет постоянна, для внешней сменится один раз.

Это решение требует 5 сложений и 2 умножений на каждую вершину, что вроде как меньше чем, нужно для расчета точек пересечения.

anonymous
()
Вы не можете добавлять комментарии в эту тему. Тема перемещена в архив.
 ← 1 2 →
Development