gistfile1.cl

;; ２次割り当て問題の解を評価する(1) - 象徴ヶ淵 <http://d.hatena.ne.jp/knenet/20100626/1277567322>
;; 3.10 8パズルと2つの後者関数 - 象徴ヶ淵 <http://d.hatena.ne.jp/knenet/20090601/1243864248>

(defvar *size*)
(defvar *distance*)
(defvar *flow*)

(defun shuffle (lst)
  (let ((l (copy-seq lst))
        (len (1+ (length lst)))
        res)
    (while (plusp (decf len))
      (push (nthpop (random len) l) res))
    res))

(defun nthpop (x lst)
  (let* ((l (nthcdr x lst))
         (r (car l)))
    (rplaca l (cadr l))
    (rplacd l (cddr l))
    r))

(defun qap-read (file)
  (with-open-file (fp file :direction :input
                      :if-does-not-exist :error)
    (let ((size (read fp))
          ll ll2)
      (dotimes (a size (setq ll (reverse ll)))
        (let (l)
          (dotimes (b size (push (reverse l) ll))
            (push (read fp) l))))
      (dotimes (a size (setq ll2 (reverse ll2)))
        (let (l)
          (dotimes (b size (push (reverse l) ll2))
            (push (read fp) l))))
      (values size ll ll2))))

(defun qap-load (file)
  (multiple-value-bind (size distance flow)
      (qap-read file)
    (setq *size* size
          *distance* distance
          *flow* flow)))

(defun %qap-eval (x)
  (macrolet ((distance (i j)
               `(elt (elt *distance* ,i) ,j))
             (flow (i j)
               `(elt (elt *flow* ,i) ,j)))
    (let ((sum 0))
      (dotimes (i *size* sum)
        (dotimes (j *size*)
          (incf sum (* (distance i j) (flow (elt x i) (elt x j)))))))))

;; ;読み込み
;; (qap-load "tai30b.dat")
;;
;; ;解を作る
;; (let (l)
;;   (dotimes (a 30 (setq x (shuffle l)))
;;     (push a l)))
;;
;; (compile '%qap-eval)
;; (time (dotimes (a 10000) (%qap-eval x)))

gistfile2.cl

(defvar *aqap-size*)
(defvar *aqap-distance*)
(defvar *aqap-flow*)

(defun aqap-init ()
  (setf *random-state* (make-random-state t)))

(defun aqap-shuffle! (s)
  (do ((i (length s) (1- i)))
      ((>= 1 i))
    (rotatef (elt s (1- i)) (elt s (random i))))
  s)

(defun aqap-read (file)
  (with-open-file (in file :direction :input :if-does-not-exist :error)
    (let* ((size (read in))
           (d (make-array (list size size)))
           (f (make-array (list size size))))
      (dotimes (i size)
        (dotimes (j size)
          (setf (aref d i j) (read in))))
      (dotimes (i size)
        (dotimes (j size)
          (setf (aref f i j) (read in))))
      (values size d f))))

(defun aqap-load (file)
  (multiple-value-bind (size distance flow)
      (aqap-read file)
    (setf *aqap-size* size
          *aqap-distance* distance
          *aqap-flow* flow)))

(defun %aqap-eval (x)
  (let ((sum 0)
        (size *aqap-size*))
    (dotimes (i size sum)
      (dotimes (j size)
        (incf sum (* (aref *aqap-distance* i j)
                     (aref *aqap-flow* (svref x i) (svref x j))))))))

gistfile3.cl

(defvar *vqap-size*)
(defvar *vqap-distance*)
(defvar *vqap-flow*)

(defun vqap-init ()
  (setf *random-state* (make-random-state t)))

(defun vqap-shuffle! (s)
  (do ((i (length s) (1- i)))
      ((>= 1 i))
    (rotatef (elt s (1- i)) (elt s (random i))))
  s)

(defun vqap-read (file)
  (with-open-file (in file :direction :input :if-does-not-exist :error)
    (let* ((size (read in))
           (d (make-array (* size size)))
           (f (make-array (* size size))))
      (dotimes (i size)
        (dotimes (j size)
          (setf (svref d (+ (* size i) j)) (read in))))
      (dotimes (i size)
        (dotimes (j size)
          (setf (svref f (+ (* size i) j)) (read in))))
      (values size d f))))

(defun vqap-load (file)
  (multiple-value-bind (size distance flow)
      (vqap-read file)
    (setf *vqap-size* size
          *vqap-distance* distance
          *vqap-flow* flow)))

(defun %vqap-eval (x)
  (let ((sum 0)
        (size *vqap-size*))
    (dotimes (i size sum)
      (dotimes (j size)
        (incf sum (* (svref *vqap-distance* (+ (* size i) j))
                     (svref *vqap-flow* (+ (* size (svref x i)) (svref x j)))))))))

(defun make-ans (size)
  (let ((v (make-array size)))
    (dotimes (i size (vqap-shuffle! v))
      (setf (svref v i) i))))

;; ;読み込み
;; (vqap-load "tai30b.dat")
;;
;; ;解を作る
;; (defparameter *x* (make-ans 30))
;;
;; (time (dotimes (a 10000) (%vqap-eval *x*)))

gistfile4.txt

;読み込み
(qap-load "tai30b.dat")

;解を作る
(let (l)
  (dotimes (a 30 (setq x (shuffle l)))
    (push a l)))

(compile '%qap-eval)
(time (dotimes (a 10000) (%qap-eval x)))
get-internal-real-time : 6688.0d0 ms
   performance-counter : 6689.670893926463d0 ms

get-internal-real-time : 6719.0d0 ms
   performance-counter : 6716.358363982015d0 ms

get-internal-real-time : 6703.0d0 ms
   performance-counter : 6700.561663563386d0 ms

get-internal-real-time : 6703.0d0 ms
   performance-counter : 6702.639581287566d0 ms

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;読み込み
(aqap-load "tai30b.dat")

;解を作る
(defparameter *x* (make-ans 30))

(time (dotimes (a 10000) (%aqap-eval *x*)))
get-internal-real-time : 8969.0d0 ms
   performance-counter : 8963.537265211082d0 ms

get-internal-real-time : 8969.0d0 ms
   performance-counter : 8961.790674513102d0 ms

get-internal-real-time : 8953.0d0 ms
   performance-counter : 8945.513186731834d0 ms

get-internal-real-time : 9000.0d0 ms
   performance-counter : 9002.04970184758d0 ms

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;読み込み
(vqap-load "tai30b.dat")

;解を作る
(defparameter *x* (make-ans 30))

(time (dotimes (a 10000) (%vqap-eval *x*)))
get-internal-real-time : 4438.0d0 ms
   performance-counter : 4440.114036839877d0 ms

get-internal-real-time : 4469.0d0 ms
   performance-counter : 4467.394599034235d0 ms

get-internal-real-time : 4500.0d0 ms
   performance-counter : 4496.426780498638d0 ms

get-internal-real-time : 4469.0d0 ms
   performance-counter : 4474.444377707223d0 ms

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- xyzzyのバイトコードにはarefに対応する命令がないので、遅くなっているの
  はそれが原因でしょう。