Lovesan/rwa-contest.lisp

## rwa-contest.lisp
(in-package #:cl-user)

(defpackage #:rwa-contest
  (:use #:cl)
  (:export
   #:address
   #:address-value
   #:book
   #:parse-ranges
   #:parse-ips
   #:book-size
   #:book-search
   #:generate-ranges
   #:generate-ips
   #:main))

(in-package #:rwa-contest)

(declaim (optimize (speed 3) (safety 0)))

(deftype u8 () '(unsigned-byte 8))
(deftype u16 () '(unsigned-byte 16))
(deftype u32 () '(unsigned-byte 32))
(deftype u8vector () '(simple-array u8 (*)))
(deftype u32vector () '(simple-array u32 (*)))
(deftype index () '(integer 0 #.array-total-size-limit))

(defconstant index-limit array-total-size-limit)
(defconstant slice-size 4096)
(defconstant comma 44)
(defconstant dot 46)
(defconstant zero 48)
(defconstant nine 57)

(declaim (inline address))
(defstruct (address (:constructor address (value)))
  (value 0 :type u32))

(defstruct (book (:constructor make-book ()))
  (high (make-array slice-size :element-type 'u32)
        :type u32vector)
  (low (make-array slice-size :element-type 'u32)
       :type u32vector)
  (size 0 :type index))

(defun grow-book (book)
  (declare (type book book))
  (with-accessors ((book-low book-low)
                   (book-high book-high))
      book
    (let* ((new-size (the index (min (1- index-limit)
                                     (1+ (ash (length book-low) 1)))))
           (new-low (make-array new-size :element-type 'u32))
           (new-high (make-array new-size :element-type 'u32)))
      (replace new-low book-low)
      (replace new-high book-high)
      (setf book-low new-low
            book-high new-high)
      (values))))

(defun book-sort (book)
  (declare (type book book))
  (let ((low (book-low book))
        (high (book-high book))
        (size (book-size book)))
    (declare (type u32vector low high))
    (unless (> size 1) (return-from book-sort book))
    (labels ((%less (i j)
               (declare (type index i j))
               (and (< (elt low i) (elt low j))
                    (< (elt high i) (elt high j))))
             (%sort (start end)
               (declare (type index start end))
               (let ((i start)
                     (j end)
                     (p (+ start (ash (- end start) -1))))
                 (declare (type index i j p))
                 (loop (loop :while (%less i p) :do (incf i))
                       (loop :while (and (%less p j) (> j 1)) :do (decf j))
                       (when (> i j) (return))
                       (rotatef (elt low i) (elt low j))
                       (rotatef (elt high i) (elt high j))
                       (incf i)
                       (decf j))
                 (when (< start j)
                   (%sort start j))
                 (when (< i end)
                   (%sort i end)))))
      (%sort 0 (1- size))
      book)))

(defun u32-to-string (u32)
  (declare (type u32 u32))
  (format nil "~a.~a.~a.~a"
          (ldb (byte 8 24) u32)
          (ldb (byte 8 16) u32)
          (ldb (byte 8 8) u32)
          (ldb (byte 8 0) u32)))

(defun book-search (address book)
  (declare (type address address))
  (let ((address (address-value address))
        (low (book-low book))
        (high (book-high book))
        (size (book-size book)))
    (declare (type u32 address))
    (when (zerop size) (return-from book-search))
    (let ((i 0)
          (j size)
          (p 0))
      (loop (unless (< i j) (return))
            (setf p (+ i (ash (- j i) -1)))
            (if (and (< address (elt low p))
                     (< address (elt high p)))
              (setf j p)
              (setf i (1+ p))))
      (<= (elt low p) address (elt high p)))))

(defun parse-ranges (filename)
  (with-open-file (in filename :element-type 'u8)
    (let ((buffer (make-array slice-size))
          (book (make-book))
          (address 0)
          (octet 0)
          (i 0)
          (end 0)
          (c -1)
          (line 1)
          (column 0)
          seen-cr
          eof)
      (declare (type u32 address)
               (type u16 octet)
               (type index i end line column)
               (type fixnum c))
      (labels
          ((fail (message &rest args)
             (apply #'error
                    (concatenate 'string
                                 "~a:~a:~a: "
                                 message)
                    filename line column args))
           (next ()
             (cond ((< i end) (setf c (elt buffer i)
                                    i (1+ i)))
                   (eof (setf c -1))
                   (T (setf end (read-sequence buffer in)
                            i 1)
                      (if (< end slice-size)
                        (setf eof t
                              c (if (zerop end) -1 (elt buffer 0)))
                        (setf c (elt buffer 0)))))
             (case c
               (10 (if seen-cr
                     (setf seen-cr nil)
                     (setf column 0
                           line (1+ line))))
               (13 (setf seen-cr t
                         column 0
                         line (1+ line)))
               (T (setf seen-cr nil
                        column (1+ column)))))
           (octet ()
             (prog ()
                (unless (<= zero c nine) (fail "Octet expected."))
                (setf octet (- c zero))
                (next)
                (unless (<= zero c nine) (go end))
                (setf octet (+ (* octet 10) (- c zero)))
                (next)
                (unless (<= zero c nine) (go end))
                (setf octet (+ (* octet 10) (- c zero)))
                (next)
              end
                (unless (< octet 256)
                  (fail "Octet expected but number found is too large: ~a."
                        octet))))
           (dot ()
             (unless (= c dot) (fail "Dot expected."))
             (next))
           (comma ()
             (unless (= c comma) (fail "Comma expected."))
             (next))
           (eol ()
             (case c
               (10 (next))
               (13 (next)
                   (when (= c 10)
                     (next)))
               (T (unless (= c -1)
                    (fail "End of line expected.")))))
           (address ()
             (octet)
             (setf address octet)
             (dot)
             (octet)
             (setf address (logior octet (the u32 (ash address 8))))
             (dot)
             (octet)
             (setf address (logior octet (the u32 (ash address 8))))
             (dot)
             (octet)
             (setf address (logior octet (the u32 (ash address 8)))))
           (range ()
             (address)
             (unless (< (book-size book) (length (book-low book)))
               (grow-book book))
             (setf (aref (book-low book) (book-size book))
                   address)
             (comma)
             (address)
             (setf (aref (book-high book) (book-size book))
                   address)
             (incf (book-size book))
             (eol))
           (book ()
             (loop :until (= c -1) :do (range)
                   :finally (return book))))
        (next)
        (book-sort (book))))))

(defun parse-ips (filename)
  (with-open-file (in filename :element-type 'u8)
    (let ((buffer (make-array slice-size))
          (addresses (make-array 4096 :element-type 'u32))
          (size 0)
          (address 0)
          (octet 0)
          (i 0)
          (end 0)
          (c -1)
          (line 1)
          (column 0)
          seen-cr
          eof)
      (declare (type u32 address)
               (type u32vector addresses)
               (type u16 octet)
               (type index i end line column size)
               (type fixnum c))
      (labels
          ((fail (message &rest args)
             (apply #'error
                    (concatenate 'string
                                 "~a:~a:~a: "
                                 message)
                    filename line column args))
           (next ()
             (cond ((< i end) (setf c (elt buffer i)
                                    i (1+ i)))
                   (eof (setf c -1))
                   (T (setf end (read-sequence buffer in)
                            i 1)
                      (if (< end slice-size)
                        (setf eof t
                              c (if (zerop end) -1 (elt buffer 0)))
                        (setf c (elt buffer 0)))))
             (case c
               (10 (if seen-cr
                     (setf seen-cr nil)
                     (setf column 0
                           line (1+ line))))
               (13 (setf seen-cr t
                         column 0
                         line (1+ line)))
               (T (setf seen-cr nil
                        column (1+ column)))))
           (octet ()
             (prog ()
                (unless (<= zero c nine) (fail "Octet expected."))
                (setf octet (- c zero))
                (next)
                (unless (<= zero c nine) (go end))
                (setf octet (+ (* octet 10) (- c zero)))
                (next)
                (unless (<= zero c nine) (go end))
                (setf octet (+ (* octet 10) (- c zero)))
                (next)
              end
                (unless (< octet 256)
                  (fail "Octet expected but number found is too large: ~a."
                        octet))))
           (dot ()
             (unless (= c dot) (fail "Dot expected."))
             (next))
           (eol ()
             (case c
               (10 (next))
               (13 (next)
                   (when (= c 10)
                     (next)))
               (T (unless (= c -1)
                    (fail "End of line expected.")))))
           (address ()
             (octet)
             (setf address octet)
             (dot)
             (octet)
             (setf address (logior octet (the u32 (ash address 8))))
             (dot)
             (octet)
             (setf address (logior octet (the u32 (ash address 8))))
             (dot)
             (octet)
             (setf address (logior octet (the u32 (ash address 8))))
             (eol)
             (unless (< size (length addresses))
               (let* ((new-size (the index (min (1+ (ash (length addresses) 1))
                                                (1- index-limit))))
                      (new (make-array new-size :element-type 'u32)))
                 (replace new addresses)
                 (setf addresses new)))
             (setf (elt addresses size) address)
             (incf size))
           (addresses ()
             (loop :until (= c -1) :do (address)
                   :finally (return (values addresses size)))))
        (next)
        (addresses)))))

(defun generate-ranges (filename &optional (n 10000))
  (with-open-file (out filename
                       :if-exists :supersede
                       :direction :output
                       :external-format :ascii)
    (dotimes (i n)
      (let* ((a1 (random #x7FFFFFFF))
             (a2 (+ a1 (random #x7FFFFFFF))))
        (write-string (u32-to-string a1) out)
        (write-char #\, out)
        (write-string (u32-to-string a2) out)
        (terpri out)))))

(defun generate-ips (filename &optional (n 3000000))
  (with-open-file (out filename
                       :if-exists :supersede
                       :direction :output
                       :external-format :ascii)
    (dotimes (i n)
      (write-line (u32-to-string (random #xFFFFFFFF))
                  out))))

#+sbcl
(defun main ()
  (handler-case
      (let* ((usage (format nil "Usage: ~a ranges_file ips_file~%"
                            (first sb-ext:*posix-argv*)))
             (range-file (or (second sb-ext:*posix-argv*)
                             (error usage)))
             (ips-file (or (third sb-ext:*posix-argv*)
                           (error usage))))
        (let ((book (the book (parse-ranges range-file)))
              (address (address 0)))
          (declare (type address address)
                   (dynamic-extent address))
          (multiple-value-bind
                (ips size)
              (parse-ips ips-file)
            (declare (type u32vector ips)
                     (type index size))
            (dotimes (i size)
              (setf (address-value address) (elt ips i))
              (book-search address book)))))
    (error (e) (princ e *error-output*) nil)))

;; #+sbcl
;; (sb-ext:save-lisp-and-die "rwa-contest" :executable t :toplevel #'main)
	(in-package #:cl-user)

	(defpackage #:rwa-contest
	(:use #:cl)
	(:export
	#:address
	#:address-value
	#:book
	#:parse-ranges
	#:parse-ips
	#:book-size
	#:book-search
	#:generate-ranges
	#:generate-ips
	#:main))

	(in-package #:rwa-contest)

	(declaim (optimize (speed 3) (safety 0)))

	(deftype u8 () '(unsigned-byte 8))
	(deftype u16 () '(unsigned-byte 16))
	(deftype u32 () '(unsigned-byte 32))
	(deftype u8vector () '(simple-array u8 (*)))
	(deftype u32vector () '(simple-array u32 (*)))
	(deftype index () '(integer 0 #.array-total-size-limit))

	(defconstant index-limit array-total-size-limit)
	(defconstant slice-size 4096)
	(defconstant comma 44)
	(defconstant dot 46)
	(defconstant zero 48)
	(defconstant nine 57)

	(declaim (inline address))
	(defstruct (address (:constructor address (value)))
	(value 0 :type u32))

	(defstruct (book (:constructor make-book ()))
	(high (make-array slice-size :element-type 'u32)
	:type u32vector)
	(low (make-array slice-size :element-type 'u32)
	:type u32vector)
	(size 0 :type index))

	(defun grow-book (book)
	(declare (type book book))
	(with-accessors ((book-low book-low)
	(book-high book-high))
	book
	(let* ((new-size (the index (min (1- index-limit)
	(1+ (ash (length book-low) 1)))))
	(new-low (make-array new-size :element-type 'u32))
	(new-high (make-array new-size :element-type 'u32)))
	(replace new-low book-low)
	(replace new-high book-high)
	(setf book-low new-low
	book-high new-high)
	(values))))

	(defun book-sort (book)
	(declare (type book book))
	(let ((low (book-low book))
	(high (book-high book))
	(size (book-size book)))
	(declare (type u32vector low high))
	(unless (> size 1) (return-from book-sort book))
	(labels ((%less (i j)
	(declare (type index i j))
	(and (< (elt low i) (elt low j))
	(< (elt high i) (elt high j))))
	(%sort (start end)
	(declare (type index start end))
	(let ((i start)
	(j end)
	(p (+ start (ash (- end start) -1))))
	(declare (type index i j p))
	(loop (loop :while (%less i p) :do (incf i))
	(loop :while (and (%less p j) (> j 1)) :do (decf j))
	(when (> i j) (return))
	(rotatef (elt low i) (elt low j))
	(rotatef (elt high i) (elt high j))
	(incf i)
	(decf j))
	(when (< start j)
	(%sort start j))
	(when (< i end)
	(%sort i end)))))
	(%sort 0 (1- size))
	book)))

	(defun u32-to-string (u32)
	(declare (type u32 u32))
	(format nil "~a.~a.~a.~a"
	(ldb (byte 8 24) u32)
	(ldb (byte 8 16) u32)
	(ldb (byte 8 8) u32)
	(ldb (byte 8 0) u32)))

	(defun book-search (address book)
	(declare (type address address))
	(let ((address (address-value address))
	(low (book-low book))
	(high (book-high book))
	(size (book-size book)))
	(declare (type u32 address))
	(when (zerop size) (return-from book-search))
	(let ((i 0)
	(j size)
	(p 0))
	(loop (unless (< i j) (return))
	(setf p (+ i (ash (- j i) -1)))
	(if (and (< address (elt low p))
	(< address (elt high p)))
	(setf j p)
	(setf i (1+ p))))
	(<= (elt low p) address (elt high p)))))

	(defun parse-ranges (filename)
	(with-open-file (in filename :element-type 'u8)
	(let ((buffer (make-array slice-size))
	(book (make-book))
	(address 0)
	(octet 0)
	(i 0)
	(end 0)
	(c -1)
	(line 1)
	(column 0)
	seen-cr
	eof)
	(declare (type u32 address)
	(type u16 octet)
	(type index i end line column)
	(type fixnum c))
	(labels
	((fail (message &rest args)
	(apply #'error
	(concatenate 'string
	"~a:~a:~a: "
	message)
	filename line column args))
	(next ()
	(cond ((< i end) (setf c (elt buffer i)
	i (1+ i)))
	(eof (setf c -1))
	(T (setf end (read-sequence buffer in)
	i 1)
	(if (< end slice-size)
	(setf eof t
	c (if (zerop end) -1 (elt buffer 0)))
	(setf c (elt buffer 0)))))
	(case c
	(10 (if seen-cr
	(setf seen-cr nil)
	(setf column 0
	line (1+ line))))
	(13 (setf seen-cr t
	column 0
	line (1+ line)))
	(T (setf seen-cr nil
	column (1+ column)))))
	(octet ()
	(prog ()
	(unless (<= zero c nine) (fail "Octet expected."))
	(setf octet (- c zero))
	(next)
	(unless (<= zero c nine) (go end))
	(setf octet (+ (* octet 10) (- c zero)))
	(next)
	(unless (<= zero c nine) (go end))
	(setf octet (+ (* octet 10) (- c zero)))
	(next)
	end
	(unless (< octet 256)
	(fail "Octet expected but number found is too large: ~a."
	octet))))
	(dot ()
	(unless (= c dot) (fail "Dot expected."))
	(next))
	(comma ()
	(unless (= c comma) (fail "Comma expected."))
	(next))
	(eol ()
	(case c
	(10 (next))
	(13 (next)
	(when (= c 10)
	(next)))
	(T (unless (= c -1)
	(fail "End of line expected.")))))
	(address ()
	(octet)
	(setf address octet)
	(dot)
	(octet)
	(setf address (logior octet (the u32 (ash address 8))))
	(dot)
	(octet)
	(setf address (logior octet (the u32 (ash address 8))))
	(dot)
	(octet)
	(setf address (logior octet (the u32 (ash address 8)))))
	(range ()
	(address)
	(unless (< (book-size book) (length (book-low book)))
	(grow-book book))
	(setf (aref (book-low book) (book-size book))
	address)
	(comma)
	(address)
	(setf (aref (book-high book) (book-size book))
	address)
	(incf (book-size book))
	(eol))
	(book ()
	(loop :until (= c -1) :do (range)
	:finally (return book))))
	(next)
	(book-sort (book))))))

	(defun parse-ips (filename)
	(with-open-file (in filename :element-type 'u8)
	(let ((buffer (make-array slice-size))
	(addresses (make-array 4096 :element-type 'u32))
	(size 0)
	(address 0)
	(octet 0)
	(i 0)
	(end 0)
	(c -1)
	(line 1)
	(column 0)
	seen-cr
	eof)
	(declare (type u32 address)
	(type u32vector addresses)
	(type u16 octet)
	(type index i end line column size)
	(type fixnum c))
	(labels
	((fail (message &rest args)
	(apply #'error
	(concatenate 'string
	"~a:~a:~a: "
	message)
	filename line column args))
	(next ()
	(cond ((< i end) (setf c (elt buffer i)
	i (1+ i)))
	(eof (setf c -1))
	(T (setf end (read-sequence buffer in)
	i 1)
	(if (< end slice-size)
	(setf eof t
	c (if (zerop end) -1 (elt buffer 0)))
	(setf c (elt buffer 0)))))
	(case c
	(10 (if seen-cr
	(setf seen-cr nil)
	(setf column 0
	line (1+ line))))
	(13 (setf seen-cr t
	column 0
	line (1+ line)))
	(T (setf seen-cr nil
	column (1+ column)))))
	(octet ()
	(prog ()
	(unless (<= zero c nine) (fail "Octet expected."))
	(setf octet (- c zero))
	(next)
	(unless (<= zero c nine) (go end))
	(setf octet (+ (* octet 10) (- c zero)))
	(next)
	(unless (<= zero c nine) (go end))
	(setf octet (+ (* octet 10) (- c zero)))
	(next)
	end
	(unless (< octet 256)
	(fail "Octet expected but number found is too large: ~a."
	octet))))
	(dot ()
	(unless (= c dot) (fail "Dot expected."))
	(next))
	(eol ()
	(case c
	(10 (next))
	(13 (next)
	(when (= c 10)
	(next)))
	(T (unless (= c -1)
	(fail "End of line expected.")))))
	(address ()
	(octet)
	(setf address octet)
	(dot)
	(octet)
	(setf address (logior octet (the u32 (ash address 8))))
	(dot)
	(octet)
	(setf address (logior octet (the u32 (ash address 8))))
	(dot)
	(octet)
	(setf address (logior octet (the u32 (ash address 8))))
	(eol)
	(unless (< size (length addresses))
	(let* ((new-size (the index (min (1+ (ash (length addresses) 1))
	(1- index-limit))))
	(new (make-array new-size :element-type 'u32)))
	(replace new addresses)
	(setf addresses new)))
	(setf (elt addresses size) address)
	(incf size))
	(addresses ()
	(loop :until (= c -1) :do (address)
	:finally (return (values addresses size)))))
	(next)
	(addresses)))))

	(defun generate-ranges (filename &optional (n 10000))
	(with-open-file (out filename
	:if-exists :supersede
	:direction :output
	:external-format :ascii)
	(dotimes (i n)
	(let* ((a1 (random #x7FFFFFFF))
	(a2 (+ a1 (random #x7FFFFFFF))))
	(write-string (u32-to-string a1) out)
	(write-char #\, out)
	(write-string (u32-to-string a2) out)
	(terpri out)))))

	(defun generate-ips (filename &optional (n 3000000))
	(with-open-file (out filename
	:if-exists :supersede
	:direction :output
	:external-format :ascii)
	(dotimes (i n)
	(write-line (u32-to-string (random #xFFFFFFFF))
	out))))

	#+sbcl
	(defun main ()
	(handler-case
	(let* ((usage (format nil "Usage: ~a ranges_file ips_file~%"
	(first sb-ext:posix-argv)))
	(range-file (or (second sb-ext:posix-argv)
	(error usage)))
	(ips-file (or (third sb-ext:posix-argv)
	(error usage))))
	(let ((book (the book (parse-ranges range-file)))
	(address (address 0)))
	(declare (type address address)
	(dynamic-extent address))
	(multiple-value-bind
	(ips size)
	(parse-ips ips-file)
	(declare (type u32vector ips)
	(type index size))
	(dotimes (i size)
	(setf (address-value address) (elt ips i))
	(book-search address book)))))
	(error (e) (princ e error-output) nil)))

	;; #+sbcl
	;; (sb-ext:save-lisp-and-die "rwa-contest" :executable t :toplevel #'main)