study

binary-heap.lisp

;;;; heap
(defstruct (binary-heap (:conc-name bh-))
  (predicate #'>=)
  (nodes (make-array (list 1024) :adjustable t :fill-pointer 0)))

(defun bh-empty (binary-heap)
  (= (length (bh-nodes binary-heap)) 0))

(defun bh-tail (binary-heap)
  (1- (length (bh-nodes binary-heap))))

(defun bh-invalid-index (binary-heap index)
  (> index (bh-tail binary-heap)))
  
(defun bh-parent (index)
  (when (> index 0)
    (1- (ceiling index 2))))

(defun bh-left (index)
  (+ (* index 2) 1))

(defun bh-right (index)
  (+ (* index 2) 2))

(defun bh-ref (binary-heap index)
  (if (bh-invalid-index binary-heap index)
      nil
      (aref (bh-nodes binary-heap) index)))

(defun bh-ref (binary-heap index)
  (when (<= index (bh-tail binary-heap))
    (aref (bh-nodes binary-heap) index)))

(defsetf bh-ref (binary-heap index) (value)
  `(setf (aref (bh-nodes ,binary-heap) ,index) ,value))

(defun bh-compare (binary-heap p c)
  (cond ((bh-invalid-index binary-heap p)
         nil)
        ((bh-invalid-index binary-heap c)
         t)
        (t
         (funcall (bh-predicate binary-heap) (bh-ref binary-heap p) (bh-ref binary-heap c)))))

(defun bh-rotate (binary-heap a b)
  (rotatef (bh-ref binary-heap a) (bh-ref binary-heap b)))


(defun up-heap (value binary-heap)
  (vector-push-extend value (bh-nodes binary-heap))
  (let* ((c (bh-tail binary-heap))
         (p (bh-parent c)))
    (loop :while p
          :until (bh-compare binary-heap p c)
          :finally (return binary-heap)
          :do (bh-rotate binary-heap p c)
          :do (setf c p)
          :do (setf p (bh-parent c))))
    binary-heap)

(defun down-heap (binary-heap)
  (when (not (bh-empty binary-heap))
    (prog1 (bh-ref binary-heap 0)
      (bh-rotate binary-heap 0 (bh-tail binary-heap))
      (vector-pop (bh-nodes binary-heap))
      (when (not (bh-empty binary-heap))
        (let* ((c 0))
          (loop :for l := (bh-left c)
                :for r := (bh-right c)
                :until (and (bh-compare binary-heap c l) (bh-compare binary-heap c r))
                :do (cond ((bh-compare binary-heap l r)
                           (bh-rotate binary-heap c l)
                           (setf c l))
                          (t
                           (bh-rotate binary-heap c r)
                           (setf c r)))))))))

eratosthenes.lisp

;;;; Eratosthenes
(defun sieve (n)
  (let ((table (make-array (list (1+ n)))))
    (loop :for i :from 1 :to n
          :do (setf (aref table i) i))
    (loop :for i :from 2 :to n
          :do (loop :for j :from (* i 2) :to n :by i
                    :if (= (aref table j) j)
                    :do (setf (aref table j) i)))
    table))

mod.lisp

;;;; mod
(let ((p 1000000007))
  (defun mod+ (a b)
    (mod (+ a b) p))

  (defun mod* (a b)
    (mod (* a b) p))

  (defun mod_expt (a z)
    (loop :with ans := 1
          :with pow := a
          :while (> z 0)
          :do (multiple-value-bind (x y) (floor z 2)
                (setf z x)
                (if (= y 1) (setf ans (mod* ans pow)))
                (setf pow (mod* pow pow)))
          :finally (return ans)))

  (defun mod_inv (a)
    ; TODO use Euclidean
    (mod_expt a (- p 2))))

queue.lisp

;;;; queue
(defstruct queue (entrance nil) (exit nil))

(defun enqueue (item queue)
  (let ((cell (list item)))
    (if (queue-entrance queue)
        (setf (cdr (queue-entrance queue)) cell)
        (setf (queue-exit queue) cell))
    (setf (queue-entrance queue) cell)))

(defun dequeue (queue)
  (when (queue-exit queue)
    (prog1 (pop (queue-exit queue))
      (unless (queue-exit queue)
        (setf (queue-entrance queue) nil)))))

union-find-tree.lisp

;;;; union find tree
(defpackage :union-find-tree
  (:nicknames :uft)
  (:use :cl)
  (:shadow :find :union :set)
  (:export :make :find :union :same))
(in-package :union-find-tree)

(defun make (n)
  (let ((parent (make-array (list (1+ n))))
        (rank (make-array (list (1+ n)))))
    (loop :for i :from 0 :to n
          :do (setf (aref parent i) i))
    (cons parent rank)))

(defun parent (uft x)
  (aref (car uft) x))

(defun set (uft x r)
  (setf (aref (car uft) x) r))

(defun rank (uft x)
  (aref (cdr uft) x))

(defun rank-up (uft x)
  (incf (aref (cdr uft) x)))

(defun find (uft x)
  (loop :with (p . stack) := '(nil . nil)
        :while (/= (parent uft x) x)
        :do (push x stack)
        :do (setf x (parent uft x))
        :finally (return (prog1 (setf p x)
                           (loop :for y :in stack
                                 :do (set uft y p))))))

(defun union (uft x y)
  (let* ((x-root (find uft x))
         (y-root (find uft y))
         (x-rank (rank uft x-root))
         (y-rank (rank uft y-root)))
    (cond ((< y-rank x-rank)
           (set uft y-root x-root))
          ((< x-rank y-rank)
           (set uft x-root y-root))
          ((/= x-root y-root)
           (set uft y-root x-root)
           (rank-up uft x-root)))))

(defun same (uft x y)
  (= (find uft x) (find uft y)))

(in-package :cl-user)