(defun make-long-list (x)
(do* ((y (make-list x))
(i y (cdr i)))
(nil)
(when (null i) (return y))
(rplaca i (random 1000))))
(defun make-long-array (x)
(do* ((y (make-array x :element-type 'fixnum))
(i 0 (1+ i)))
(nil)
(when (= x i) (return y))
(setf (aref y i) (random 1000))))
(defun count-inversions (lst &optional (predicate #'<))
(if (or (null lst) (null (cdr lst)))
0
(let* ((half (ceiling (/ (length lst) 2)))
(left-list (subseq lst 0 half))
(right-list (subseq lst half)))
(+ (loop for a in left-list
summing (loop for b in right-list
counting (not (funcall predicate a b))))
(count-inversions left-list predicate)
(count-inversions right-list predicate)))))
(defun count-inversions-1 (x &optional (predicate #'<) (len (length x)))
(if (or (null x) (null (cdr x)))
0
(let* ((half-a (1- (ash len -1)))
(half-b (- len half-a))
(right-list (split-in-two! x)))
(+ (loop for a in x
summing (loop for b in right-list
counting (not (funcall predicate a b))))
(count-inversions-1 x predicate half-a)
(count-inversions-1 right-list predicate half-b)))))
(defun split-in-two! (x &optional (len (length x)))
(setq len (1- (ash len -1)))
(do ((c x (cdr c))
(r)
(i 0 (1+ i)))
(nil)
(when (= i len)
(setq r (cdr c))
(rplacd c nil)
(return r))))
;; Note that you get a lot of bad optimization warnings, we'll fix that next
(defun count-inversions-2 (lst &optional (predicate #'<))
(declare (optimize (speed 3)
(compilation-speed 0)
(debug 0)
(safety 0)))
(declare (type list lst))
(declare (type (function (fixnum fixnum)) predicate))
(if (or (null lst) (null (cdr lst)))
0
(let* ((half (the fixnum (ceiling (/ (the fixnum (length lst)) 2))))
(left-list (subseq lst 0 half))
(right-list (subseq lst half)))
(declare (type fixnum half))
(declare (type list left-list))
(declare (type list right-list))
(+ (the bignum (loop for a in left-list
summing (loop for b in right-list
counting (not (funcall
(the function predicate)
(the fixnum a)
(the fixnum b))))))
(the bignum (count-inversions-2 left-list predicate))
(the bignum (count-inversions-2 right-list predicate))))))
;; (ftype (function (list function) bignum) count-inversions-3)
(defun count-inversions-3 (lst &optional (predicate #'<))
(declare (optimize (speed 3)
(compilation-speed 0)
(debug 0)
(safety 0))
(type list lst)
(ftype (function (list function) integer) count-inversions-3)
(type (function (fixnum fixnum) boolean) predicate))
(if (or (null lst) (null (cdr lst)))
0
(let* ((len (length lst))
(half (the (unsigned-byte 32) (- len (ash len -1))))
(left-list (subseq lst 0 half))
(right-list (subseq lst half))
(total 0))
(declare (type (unsigned-byte 32) len)
(type (unsigned-byte 32) half)
(type list left-list)
(type list right-list)
(type integer total))
(the integer
(+
(dolist (i left-list total)
(dolist (j right-list)
(when (not (funcall
predicate
(the fixnum i)
(the fixnum j)))
(setq total (the (unsigned-byte 32) (+ total 1))))))
(count-inversions-3 left-list predicate)
(count-inversions-3 right-list predicate))))))
(defun count-inversions-4 (x &optional (predicate #'<) (len (length x)))
(declare (optimize (speed 3)
(compilation-speed 0)
(debug 0)
(safety 0))
(ftype (function (list function (unsigned-byte 32)) (unsigned-byte 32))
count-inversions-4)
(type (function (fixnum fixnum) boolean) predicate)
(type list x)
(type (unsigned-byte 32) len)
(inline split-in-two!-1))
(if (or (null x) (null (cdr x)))
0
(let* ((half-a (1- (ash len -1)))
(half-b (- len half-a))
(right-list (split-in-two!-1 x))
(total 0))
(declare (type (unsigned-byte 32) half-a)
(type (unsigned-byte 32) half-b)
(type list right-list)
(type (unsigned-byte 32) total))
(the integer
(+
(dolist (i x total)
(dolist (j right-list)
(when (not (funcall
predicate
(the fixnum i)
(the fixnum j)))
(setq total (the (unsigned-byte 32) (+ total 1))))))
(count-inversions-4 x predicate half-a)
(count-inversions-4 right-list predicate half-b))))))
(defun split-in-two!-1 (x &optional (len (length x)))
(declare (optimize (speed 3)
(compilation-speed 0)
(debug 0)
(safety 0))
(ftype (function (list (unsigned-byte 32)) list) split-in-two!-1)
(type list x)
(type (unsigned-byte 32) len))
(setq len (1- (ash len -1)))
(do ((c x (cdr c))
(r)
(i 0 (1+ i)))
(nil)
(declare (type list c)
(type (unsigned-byte 32) i)
(type list r))
(when (= i len)
(setq r (cdr c))
(rplacd c nil)
(return r))))
(defun count-inversions-5 (x &optional (predicate #'<))
(declare (optimize (speed 3)
(compilation-speed 0)
(debug 0)
(safety 0))
(ftype (function ((simple-array fixnum (*)) function)
(unsigned-byte 32))
count-inversions-5)
(type (function (fixnum fixnum) boolean) predicate)
(type (simple-array fixnum (*)) x))
(if (< (length x) 2)
0
(let* ((half-a (ash (length x) -1))
(left-array (subseq x 0 half-a))
(half-b (- (length x) half-a))
(right-array (subseq x half-a))
(current 0)
(total 0))
(declare (type (unsigned-byte 32) half-a)
(type (unsigned-byte 32) half-b)
(type fixnum current)
(type (simple-array fixnum (*)) right-array)
(type (simple-array fixnum (*)) left-array)
(type (unsigned-byte 32) total))
(the (unsigned-byte 32)
(+
(dotimes (i half-a total)
(setq current (aref left-array i))
(dotimes (j half-b)
(when (not (funcall
predicate
current
(the fixnum (aref right-array j))))
(setq total (the (unsigned-byte 32) (+ total 1))))))
(count-inversions-5 left-array predicate)
(count-inversions-5 right-array predicate))))))
(defun count-inversions-6 (x)
(declare (optimize (speed 3)
(compilation-speed 0)
(debug 0)
(safety 0))
(ftype (function ((simple-array fixnum (*)))
(unsigned-byte 32))
count-inversions-6)
(type (simple-array fixnum (*)) x))
(if (< (length x) 2)
0
(let* ((half-a (ash (length x) -1))
(left-array (subseq x 0 half-a))
(half-b (- (length x) half-a))
(right-array (subseq x half-a))
(current 0)
(total 0))
(declare (type (unsigned-byte 32) half-a)
(type (unsigned-byte 32) half-b)
(type fixnum current)
(type (simple-array fixnum (*)) right-array)
(type (simple-array fixnum (*)) left-array)
(type (unsigned-byte 32) total))
(the (unsigned-byte 32)
(+
(dotimes (i half-a total)
(setq current (aref left-array i))
(dotimes (j half-b)
(when (>= current
(the fixnum (aref right-array j)))
(setq total (the (unsigned-byte 32) (+ total 1))))))
(count-inversions-6 left-array)
(count-inversions-6 right-array))))))
(time (make-long-list 10000))
;; Evaluation took:
;; 0.000 seconds of real time
;; 0.000000 seconds of total run time (0.000000 user, 0.000000 system)
;; 100.00% CPU
;; 865,284 processor cycles
;; 159,744 bytes consed
(time (count-inversions (make-long-list 10000)))
;; Evaluation took:
;; 2.548 seconds of real time
;; 2.540159 seconds of total run time (2.536159 user, 0.004000 system)
;; 99.69% CPU
;; 7,126,743,462 processor cycles
;; 3,080,976 bytes consed
(time (count-inversions-1 (make-long-list 10000)))
;; Evaluation took:
;; 2.528 seconds of real time
;; 2.520157 seconds of total run time (2.520157 user, 0.000000 system)
;; 99.68% CPU
;; 7,074,236,361 processor cycles
;; 194,672 bytes consed
(time (count-inversions-2 (make-long-list 10000)))
;; Evaluation took:
;; 2.423 seconds of real time
;; 2.416151 seconds of total run time (2.416151 user, 0.000000 system)
;; 99.71% CPU
;; 6,781,155,228 processor cycles
;; 3,076,880 bytes consed
(time (count-inversions-3 (make-long-list 10000)))
;; Evaluation took:
;; 2.290 seconds of real time
;; 2.280143 seconds of total run time (2.280143 user, 0.000000 system)
;; 99.56% CPU
;; 6,407,376,423 processor cycles
;; 2,647,840 bytes consed
(time (count-inversions-4 (make-long-list 10000)))
;; Evaluation took:
;; 2.294 seconds of real time
;; 2.284143 seconds of total run time (2.284143 user, 0.000000 system)
;; 99.56% CPU
;; 6,417,973,587 processor cycles
;; 190,128 bytes consed
(time (count-inversions-5 (make-long-array 10000)))
;; Evaluation took:
;; 2.326 seconds of real time
;; 2.316144 seconds of total run time (2.316144 user, 0.000000 system)
;; 99.57% CPU
;; 6,506,879,880 processor cycles
;; 1,617,056 bytes consed
(time (count-inversions-6 (make-long-array 10000)))
;; Evaluation took:
;; 0.171 seconds of real time
;; 0.172010 seconds of total run time (0.168010 user, 0.004000 system)
;; 100.58% CPU
;; 478,246,785 processor cycles
;; 1,584,240 bytes consed