Percolation problem

percolation.lisp

(defconstant +L+ 8)
(defconstant +p+ (random 1.0))

(setf *random-state* (make-random-state t))

(defun cluster-contains-the-point-predicate (point grid-size)
  (let ((*surrounding-points* (list (- point grid-size)
                                    (if (= (mod point grid-size) 0)
                                      -1
                                      (1- point)))))
    (lambda (cluster)
      (find-if (lambda (cluster-point)
                 (find cluster-point *surrounding-points*)) cluster))))

(defun init-clusters (p grid-size)
  (let ((*clusters* (list)))
    (dotimes (point (* grid-size grid-size))
      (if (<= (random 1.0) p)
        (let ((*cluster-predicate* (cluster-contains-the-point-predicate point grid-size)))
          (let ((*clusters-contains-the-point-quantity* (count-if *cluster-predicate* *clusters*)))
            (cond
              ((> *clusters-contains-the-point-quantity* 1)
               (setf *clusters*
                     (concatenate 'list
                                  (remove-if *cluster-predicate* *clusters*)
                                  (list (remove-duplicates (concatenate 'list
                                                                  (reduce (lambda (f s)
                                                                            (concatenate 'list f s))
                                                                          (remove-if (lambda (cluster)
                                                                                       (not (funcall *cluster-predicate* cluster)))
                                                                                     *clusters*))
                                                                  (list point)))))))

              ((= *clusters-contains-the-point-quantity* 1)
               (push point (elt *clusters* (position-if *cluster-predicate* *clusters*))))

              ((= *clusters-contains-the-point-quantity* 0)
               (push (list point) *clusters*)))))))
    *clusters*))

(defun connecting-cluster-predicate (grid-size)
  (lambda (cluster)
    (or (and (find-if (lambda (point)
                        (= (mod point grid-size) 0)) cluster)
             (find-if (lambda (point)
                        (= (mod point grid-size) (1- grid-size))) cluster))
        (and (find-if (lambda (point)
                        (< point grid-size)) cluster)
             (find-if (lambda (point)
                        (> point (* grid-size (1- grid-size)))) cluster)))))

(do ((p 0.00 (+ p 0.01)))
  ((>= p 1.00))
  (format t "~2$" p)
  (do ((L 16 (* L 2)))
    ((> L 128))
    (let ((*sum* 0.0))
      (dotimes (i 1000)
        (when (find-if (connecting-cluster-predicate L) (init-clusters p L))
          (setf *sum* (1+ *sum*))))
      (format t "~t~3$" (/ *sum* 1000))))
  (format t "~%"))