-
Notifications
You must be signed in to change notification settings - Fork 20
/
inplace-merge.lisp
86 lines (83 loc) · 3.91 KB
/
inplace-merge.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
(defpackage :cp/inplace-merge
(:use :cl)
(:export #:inplace-merge! #:inplace-merge-sort!)
(:export "Provides in-place and stable merge sort with time complexity
O(N(logN)^2)."))
(in-package :cp/inplace-merge)
(declaim (inline %reverse))
(defun %reverse (vector start end)
(declare ((mod #.array-dimension-limit) start end))
(let ((mid (ash (+ start end) -1)))
(loop for i from 0 below (- mid start)
do (rotatef (aref vector (the (mod #.array-dimension-limit) (+ start i)))
(aref vector (the (mod #.array-dimension-limit) (- end i 1)))))))
(declaim (inline inplace-merge!))
(defun inplace-merge! (vector order start mid end)
"Destructively merges two sorted subarrays of VECTOR in the ranges [START,
MID) and [MID, END). The result are stored in VECTOR itself. Time complexity is
O(NlogN)."
(declare (vector vector)
((mod #.array-dimension-limit) start mid end))
(assert (<= start mid end))
(labels
((proc (start cut1 mid cut2 end)
(%reverse vector cut1 mid)
(%reverse vector mid cut2)
(%reverse vector cut1 cut2)
(let ((new-mid (+ cut1 (- cut2 mid))))
(%merge start cut1 new-mid)
(%merge new-mid cut2 end)))
(%merge (start mid end)
(declare ((mod #.array-dimension-limit) start mid end))
(let ((len1 (- mid start))
(len2 (- end mid)))
(cond ((zerop len1))
((zerop len2))
((= 2 (+ len1 len2))
(when (funcall order (aref vector mid) (aref vector start))
(rotatef (aref vector start) (aref vector mid))))
(t
(if (> len1 len2)
(let* ((cut1 (+ start (ash len1 -1)))
(cut2
(let ((cut-val (aref vector cut1))
(ng (- mid 1))
(ok end))
(loop (when (<= (- ok ng) 1)
(return ok))
(let ((mid (ash (+ ng ok) -1)))
(if (funcall order (aref vector mid) cut-val)
(setq ng mid)
(setq ok mid)))))))
(declare ((mod #.array-dimension-limit) cut1 cut2))
(proc start cut1 mid cut2 end))
(let* ((cut2 (+ mid (ash len2 -1)))
(cut1
(let ((cut-val (aref vector cut2))
(ng (- start 1))
(ok mid))
(loop (when (<= (- ok ng) 1)
(return ok))
(let ((mid (ash (+ ng ok) -1)))
(if (funcall order cut-val (aref vector mid))
(setq ok mid)
(setq ng mid)))))))
(declare ((mod #.array-dimension-limit) cut1 cut2))
(proc start cut1 mid cut2 end))))))))
(%merge start mid end)
vector))
(declaim (inline merge-sort!))
(defun inplace-merge-sort! (vector order &key (start 0) end)
"ORDER := strict order."
(declare (vector vector)
(function order))
(let* ((end (or end (length vector))))
(declare ((mod #.array-dimension-limit) start end))
(assert (<= start end (length vector)))
(loop for width of-type (mod #.array-dimension-limit) = 1 then (* width 2)
while (< width end)
do (loop for l from start below end by (* width 2)
for mid = (min end (+ l width))
for r = (min end (+ mid width))
do (inplace-merge! vector order l mid r)))
vector))