Convex hull: Difference between revisions
→{{header|D}}
m (→{{header|ATS}}) |
|||
Line 1,275:
{{out}}
<pre>Convex Hull: [(-9, -3), (-3, -9), (19, -8), (17, 5), (12, 17), (5, 19), (-3, 15)]</pre>
=={{header|Common Lisp}}==
{{trans|Scheme}}
The program is wrapped in a [https://roswell.github.io/ Roswell] script, which is one of the popular ways to get around differences between Common Lisp implementations.
<lang lisp>#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#
(progn ;;init forms
(ros:ensure-asdf)
#+quicklisp(ql:quickload '() :silent t)
)
(defpackage :ros.script.convex-hull-task.3861520611
(:use :cl))
(in-package :ros.script.convex-hull-task.3861520611)
;;;
;;; Convex hulls by Andrew's monotone chain algorithm.
;;;
;;; For a description of the algorithm, see
;;; https://en.wikibooks.org/w/index.php?title=Algorithm_Implementation/Geometry/Convex_hull/Monotone_chain&stableid=40169
;;;
;;; This program is translated rather faithfully from the Scheme,
;;; complete with tail recursions.
;;;
;; x and y coordinates of a "point". A "point" is represented by a
;; list of length 2.
(defun x@ (u) (car u))
(defun y@ (u) (cadr u))
(defun cross (u v)
;; Cross product (as a signed scalar).
(- (* (x@ u) (y@ v)) (* (y@ u) (x@ v))))
(defun point- (u v)
(list (- (x@ u) (x@ v)) (- (y@ u) (y@ v))))
(defun sort-points-vector (points-vector)
;; Ascending sort on x-coordinates, followed by ascending sort
;; on y-coordinates.
(sort points-vector #'(lambda (u v)
(or (< (x@ u) (x@ v))
(and (= (x@ u) (x@ v))
(< (y@ u) (y@ v)))))))
(defun construct-lower-hull (sorted-points-vector)
(let* ((pt sorted-points-vector)
(n (length pt))
(hull (make-array n))
(j 1))
(setf (aref hull 0) (aref pt 0))
(setf (aref hull 1) (aref pt 1))
(loop for i from 2 to (1- n)
do (progn
(defun inner-loop ()
(if (or (zerop j)
(plusp
(cross (point- (aref hull j)
(aref hull (1- j)))
(point- (aref pt i)
(aref hull (1- j))))))
(progn
(setf j (1+ j))
(setf (aref hull j) (aref pt i)))
(progn
(setf j (1- j))
(inner-loop))))
(inner-loop)))
(values (+ j 1) hull))) ; Hull size, hull points.
(defun construct-upper-hull (sorted-points-vector)
(let* ((pt sorted-points-vector)
(n (length pt))
(hull (make-array n))
(j 1))
(setf (aref hull 0) (aref pt (- n 1)))
(setf (aref hull 1) (aref pt (- n 2)))
(loop for i from (- n 3) downto 0
do (progn
(defun inner-loop ()
(if (or (zerop j)
(plusp
(cross (point- (aref hull j)
(aref hull (1- j)))
(point- (aref pt i)
(aref hull (1- j))))))
(progn
(setf j (1+ j))
(setf (aref hull j) (aref pt i)))
(progn
(setf j (1- j))
(inner-loop))))
(inner-loop)))
(values (+ j 1) hull))) ; Hull size, hull points.
(defun construct-hull (sorted-points-vector)
;; Notice that the lower and upper hulls could be constructed in
;; parallel. (The Scheme "let-values" macro made this apparent,
;; despite not actually doing the computation in parallel. The
;; coding here makes it less obvious.)
(multiple-value-bind (lower-hull-size lower-hull)
(construct-lower-hull sorted-points-vector)
(multiple-value-bind (upper-hull-size upper-hull)
(construct-upper-hull sorted-points-vector)
(let* ((hull-size (+ lower-hull-size upper-hull-size -2))
(hull (make-array hull-size)))
(loop for i from 0 to (- lower-hull-size 2)
do (setf (aref hull i) (aref lower-hull i)))
(loop for i from 0 to (- upper-hull-size 2)
do (setf (aref hull (+ i (1- lower-hull-size)))
(aref upper-hull i)))
hull))))
(defun vector-delete-neighbor-dups (elt= v)
;; A partial clone of the SRFI-132 procedure of the same name. This
;; implementation is similar to the reference implementation for
;; SRFI-132, and may use a bunch of stack space. That reference
;; implementation is by Olin Shivers and rests here:
;; https://github.com/scheme-requests-for-implementation/srfi-132/blob/master/sorting/delndups.scm
;; The license is:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code is
;;; Copyright (c) 1998 by Olin Shivers.
;;; The terms are: You may do as you please with this code, as long as
;;; you do not delete this notice or hold me responsible for any outcome
;;; related to its use.
;;;
;;; Blah blah blah. Don't you think source files should contain more lines
;;; of code than copyright notice?
;;;
(let ((start 0)
(end (length v)))
(let ((x (aref v start)))
(defun recur (x i j)
(if (< i end)
(let ((y (aref v i))
(nexti (1+ i)))
(if (funcall elt= x y)
(recur x nexti j)
(let ((ansvec (recur y nexti (1+ j))))
(setf (aref ansvec j) y)
ansvec)))
(make-array j)))
(let ((ans (recur x start 1)))
(setf (aref ans 0) x)
ans))))
(defun vector-convex-hull (points)
(let* ((points-vector (coerce points 'vector))
(sorted-points-vector
(vector-delete-neighbor-dups
#'equalp
(sort-points-vector points-vector))))
(if (<= (length sorted-points-vector) 2)
sorted-points-vector
(construct-hull sorted-points-vector))))
(defun list-convex-hull (points)
(coerce (vector-convex-hull points) 'list))
(defconstant example-points
'((16 3) (12 17) (0 6) (-4 -6) (16 6)
(16 -7) (16 -3) (17 -4) (5 19) (19 -8)
(3 16) (12 13) (3 -4) (17 5) (-3 15)
(-3 -9) (0 11) (-9 -3) (-4 -2) (12 10)))
(defun main (&rest argv)
(declare (ignorable argv))
(write (list-convex-hull example-points))
(terpri))
;;; vim: set ft=lisp lisp:</lang>
{{out}}
<pre>$ ./convex-hull-task.ros
((-9 -3) (-3 -9) (19 -8) (17 5) (12 17) (5 19) (-3 15))</pre>
=={{header|D}}==
| |||