Plaster
New
List
Login
common-lisp
default
anonymous
2021.12.29 13:49:44
(defun mergeablep (range1 range2) (destructuring-bind (min1 max1) range1 (destructuring-bind (min2 max2) range2 (or ;; RANGE1 being left neighbor of RANGE2 (= (1+ max1) min2) ;; RANGE2 being left neighbor of RANGE1 (= (1+ max2) min1) ;; RANGE1 has left overlap with RANGE2 (<= min1 min2 max1 max2) ;; RANGE2 has right overlap with RANGE1 (<= min2 min1 max2 max1) ;; RANGE1 is inside RANGE2 (<= min2 min1 max1 max2) ;; RANGE2 is inside RANGE1 (<= min1 min2 max2 max1))))) (defun %merge (range1 range2) (destructuring-bind (min1 max1) range1 (destructuring-bind (min2 max2) range2 (let ((former (if (< min1 min2) range1 range2)) (latter (if (> max1 max2) range1 range2))) (list (first former) (second latter)))))) (defun merge-ranges (&rest ranges) (let ((ranges (copy-seq ranges))) (loop for cons1 on ranges for range1 = (car cons1) when range1 do (loop for cons2 on (cdr cons1) for range2 = (car cons2) when (and range2 (mergeablep range1 range2)) do (let ((result (%merge range1 range2))) (setf range1 result (car cons1) result (car cons2) nil)))) (if (loop for thing in (cdr ranges) never thing) (car ranges) nil))) (defun merge-ranges-and-numbers (&rest things) (flet ((fix (x) (if (consp x) x (list x x)))) (apply #'merge-ranges (mapcar #'fix things)))) (defun test () (flet ((true (x) (if x t nil))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; MERGEABLEP ;; Non-neighbors (assert (null (mergeablep '(1 1) '(3 3)))) (assert (null (mergeablep '(3 3) '(1 1)))) (assert (null (mergeablep '(1 1) '(3 9)))) (assert (null (mergeablep '(3 9) '(1 1)))) ;; Neighbors (assert (true (mergeablep '(1 2) '(3 4)))) (assert (true (mergeablep '(3 4) '(1 2)))) ;; Overlaps (assert (true (mergeablep '(1 5) '(3 9)))) (assert (true (mergeablep '(3 9) '(1 5)))) ;; Inside (assert (true (mergeablep '(1 9) '(3 5)))) (assert (true (mergeablep '(3 5) '(1 9)))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; %MERGE ;; Neighbors (assert (equal '(1 4) (%merge '(1 2) '(3 4)))) (assert (equal '(1 4) (%merge '(3 4) '(1 2)))) ;; Overlaps (assert (equal '(1 9) (%merge '(1 5) '(3 9)))) (assert (equal '(1 9) (%merge '(3 9) '(1 5)))) ;; Inside (assert (equal '(1 9) (%merge '(1 9) '(3 5)))) (assert (equal '(1 9) (%merge '(3 5) '(1 9)))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; MERGE-RANGES (assert (equal '(1 9) (merge-ranges '(1 2) '(3 5) '(5 6) '(4 4) '(6 8) '(9 9)))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; MERGE-RANGES-AND-NUMBERS (assert (equal '(1 9) (merge-ranges-and-numbers '(1 2) '(3 5) '(5 6) 4 '(6 8) 9)))))
Raw
Annotate
Repaste
Edit