;; Sort master point list left to right
(setq pts (vl-sort pts '(lambda (a b) (< (car a) (car b)))))
;; While we have pts
(while (setq p (car pts))
;; Group by y values to get rows
(setq tmp (vl-remove-if-not '(lambda (x) (equal (cadr p) (cadr x) 1e-8)) pts))
;; Append sublist to 'out'
(setq out (cons tmp out))
;; Remove sublist items from master list
(mapcar '(lambda (x) (setq pts (vl-remove x pts))) tmp)
)
;; Sort rows from top to bottom
(vl-sort out '(lambda (a b) (> (caar a) (caar b))))
1. Group points by y ordinate (will need to employ a fuzz value).
2. Sort groups by y ordinate (descending).
3. Sort within a group by x ordinate (ascending).
(setq pL '((1 1 2) (2 1 1) (2 2 2) (2 1 2) (2 3 2) (2 1 3) (1 1 3) (3 3 2) (1 1 3) (2 3 3) (3 1 1) (1 2 3) (1 2 1) (1 3 1) (1 3 0) (2 2 0) (2 3 4) (1 1 1) (2 3 0) (3 3 3) (3 4 2)))
_$ (SortPointList 'XYZ 1e-3 > < > pL)
((3 1 1) (3 3 3) (3 3 2) (3 4 2) (2 1 3) (2 1 2) (2 1 1) (2 2 2) (2 2 0) (2 3 4) (2 3 3) (2 3 2) (2 3 0) (1 1 3) (1 1 3) (1 1 2) (1 1 1) (1 2 3) (1 2 1) (1 3 1) (1 3 0))
_$ (SortPointList 'XYZ 1e-3 > > > pL)
((3 4 2) (3 3 3) (3 3 2) (3 1 1) (2 3 4) (2 3 3) (2 3 2) (2 3 0) (2 2 2) (2 2 0) (2 1 3) (2 1 2) (2 1 1) (1 3 1) (1 3 0) (1 2 3) (1 2 1) (1 1 3) (1 1 3) (1 1 2) (1 1 1))
_$ (SortPointList 'XZY 1e-3 > > > pL)
((3 3 3) (3 4 2) (3 3 2) (3 1 1) (2 3 4) (2 3 3) (2 1 3) (2 3 2) (2 2 2) (2 1 2) (2 1 1) (2 3 0) (2 2 0) (1 2 3) (1 1 3) (1 1 3) (1 1 2) (1 3 1) (1 2 1) (1 1 1) (1 3 0))
_$ (SortPointList 'YXZ 1e-3 > > > pL)
((3 4 2) (3 3 3) (3 3 2) (2 3 4) (2 3 3) (2 3 2) (2 3 0) (1 3 1) (1 3 0) (2 2 2) (2 2 0) (1 2 3) (1 2 1) (3 1 1) (2 1 3) (2 1 2) (2 1 1) (1 1 3) (1 1 3) (1 1 2) (1 1 1))
_$ (SortPointList 'YZX 1e-3 > > > pL)
((3 4 2) (2 3 4) (3 3 3) (2 3 3) (3 3 2) (2 3 2) (1 3 1) (2 3 0) (1 3 0) (1 2 3) (2 2 2) (1 2 1) (2 2 0) (2 1 3) (1 1 3) (1 1 3) (2 1 2) (1 1 2) (3 1 1) (2 1 1) (1 1 1))
_$ (SortPointList 'ZXY 1e-3 > > > pL)
((2 3 4) (3 3 3) (2 3 3) (2 1 3) (1 2 3) (1 1 3) (1 1 3) (3 4 2) (3 3 2) (2 3 2) (2 2 2) (2 1 2) (1 1 2) (3 1 1) (2 1 1) (1 3 1) (1 2 1) (1 1 1) (2 3 0) (2 2 0) (1 3 0))
_$ (SortPointList 'ZYX 1e-3 > > > pL)
((2 3 4) (3 3 3) (2 3 3) (1 2 3) (2 1 3) (1 1 3) (1 1 3) (3 4 2) (3 3 2) (2 3 2) (2 2 2) (2 1 2) (1 1 2) (1 3 1) (1 2 1) (3 1 1) (2 1 1) (1 1 1) (2 3 0) (1 3 0) (2 2 0))
_$ (SortPointList 'XYZ 1e-3 < < < pL)
((1 1 1) (1 1 2) (1 1 3) (1 1 3) (1 2 1) (1 2 3) (1 3 0) (1 3 1) (2 1 1) (2 1 2) (2 1 3) (2 2 0) (2 2 2) (2 3 0) (2 3 2) (2 3 3) (2 3 4) (3 1 1) (3 3 2) (3 3 3) (3 4 2))
_$ (SortPointList 'XZY 1e-3 < < < pL)
((1 3 0) (1 1 1) (1 2 1) (1 3 1) (1 1 2) (1 1 3) (1 1 3) (1 2 3) (2 2 0) (2 3 0) (2 1 1) (2 1 2) (2 2 2) (2 3 2) (2 1 3) (2 3 3) (2 3 4) (3 1 1) (3 3 2) (3 4 2) (3 3 3))
_$ (SortPointList 'YXZ 1e-3 < < < pL)
((1 1 1) (1 1 2) (1 1 3) (1 1 3) (2 1 1) (2 1 2) (2 1 3) (3 1 1) (1 2 1) (1 2 3) (2 2 0) (2 2 2) (1 3 0) (1 3 1) (2 3 0) (2 3 2) (2 3 3) (2 3 4) (3 3 2) (3 3 3) (3 4 2))
_$ (SortPointList 'YZX 1e-3 < < < pL)
((1 1 1) (2 1 1) (3 1 1) (1 1 2) (2 1 2) (1 1 3) (1 1 3) (2 1 3) (2 2 0) (1 2 1) (2 2 2) (1 2 3) (1 3 0) (2 3 0) (1 3 1) (2 3 2) (3 3 2) (2 3 3) (3 3 3) (2 3 4) (3 4 2))
_$ (SortPointList 'ZXY 1e-3 < < < pL)
((1 3 0) (2 2 0) (2 3 0) (1 1 1) (1 2 1) (1 3 1) (2 1 1) (3 1 1) (1 1 2) (2 1 2) (2 2 2) (2 3 2) (3 3 2) (3 4 2) (1 1 3) (1 1 3) (1 2 3) (2 1 3) (2 3 3) (3 3 3) (2 3 4))
_$ (SortPointList 'ZYX 1e-3 < < < pL)
((2 2 0) (1 3 0) (2 3 0) (1 1 1) (2 1 1) (3 1 1) (1 2 1) (1 3 1) (1 1 2) (2 1 2) (2 2 2) (2 3 2) (3 3 2) (3 4 2) (1 1 3) (1 1 3) (2 1 3) (1 2 3) (2 3 3) (3 3 3) (2 3 4))
(defun _GroupAndSort ( points fuzz / test sort result y )
;; Note: test exploits lexical globals y & fuzz
(defun test (p) (equal y (cadr p) fuzz))
(defun sort (l f g) (vl-sort l (function (lambda (a b) (f (g a) (g b))))))
(while (setq y (cadar points))
(setq
result (cons (sort (vl-remove-if-not 'test points) < car) result)
points (vl-remove-if 'test points)
)
)
(sort result > cadar)
)
(foreach group (_GroupAndSort points 0.5)
(princ "\n")
(foreach p group (princ p) (princ " "))
(princ)
)
(defun _groupandsort ( lst fuz / rtn tmp ycl yco )
(while (setq yco (cadar lst))
(setq lst (vl-remove-if '(lambda ( p ) (if (equal (cadr p) yco fuz) (setq tmp (cons p tmp)))) lst)
rtn (cons (vl-sort tmp '(lambda ( a b ) (< (car a) (car b)))) rtn)
ycl (cons yco ycl)
tmp nil
)
)
(mapcar '(lambda ( n ) (nth n rtn)) (vl-sort-i ycl '>))
)
(foo
'( ; a random messed up list of lists is given to be sorted:
(1 3 6 2)
(1 2 3 4)
(1 3 4 5)
(2 4 6 1 3)
(3 2 4 5 4)
(3 2 4 8 2)
(2 5 5 1 2)
(2 5 6 1 7)
(1 2 3 5)
)
)
>>
'( ; Priority, sort by the minimal (car) value, if there are other elements that are equal, then group and try sorting by (cadr), if some of them have equal, try (caddr)... and so on
(1 2 3 4) ; CAR = 1
(1 2 3 5) ; CAR = 1, the next ones are equal to the first, but the last one is above 4
(1 3 4 5) ; CAR = 1, but CADR = 3, thats why is 3rd (because the (cadr) of the first set is with value of 2)
(1 3 6 2) ; CAR = 1, and CADR = 3, but the 3rd element is higher than the previous item
(2 4 6 1 3) ; CAR = 2 .. compare CADRs, if there are equals, then compare CADDRs
(2 5 5 1 2)
(2 5 6 1 7)
(3 2 4 5 4) ; CAR-CADR have equals, compare CADDR
(3 2 4 8 2)
)
-={Challenge}=- Ultimate Sorter
(defun foo ( l ) (vl-sort l 'bar))
(defun bar ( a b )
(cond
( (not (and a b)) b)
( (= (car a) (car b)) (bar (cdr a) (cdr b)))
( (< (car a) (car b)))
)
)
(vl-string-subst "good" "tough" "tough job!")
Quick & Dirty inspired by Ron's post:Code: [Select]< .. >
;; Note: test exploits lexical globals y & fuzz
< ... >