loic/lisp-algo
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add CLOS to union-find

Browse source
This commit is contained in:
Loic Guegan 2019-02-24 20:33:55 +01:00
parent 5725987c8d
commit b256fc334a
9 changed files with 167 additions and 208 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
lisp-algo.asd
View file

@ -4,10 +4,13 @@
:version "0.0.1"
:depends-on ("lisp-unit")
:perform (test-op (o s) (symbol-call :com.lisp-algo.test :do-tests))
:serial t
:components ((:file "packages")
(:module "union-find"
:serial t
:depends-on ("packages")
:components ((:file "quick-find")
:components ((:file "union-find")
(:file "quick-find")
(:file "quick-union")
(:file "weighted-quick-union")
(:file "weighted-quick-union-path-compression")))

33
packages.lisp
View file

@ -5,31 +5,22 @@
(defpackage :com.lisp-algo.union-find
(:use :common-lisp)
(:nicknames :uf)
;; Quick-Find
(:export :qf-create-network
:qf-union
:qf-connected)
;; Quick-Union
(:export :qu-create-network
:qu-union
:qu-connected)
;; Weighted-Quick-Union
(:export :wqu-create-network
:wqu-create-network
:wqu-union
:wqu-connected)
;; Weighted-Quick-Union with Path Compression
(:export :wqupc-create-network
:wqupc-create-network
:wqupc-union
:wqupc-connected))
(:shadow :union)
(:export :union
:connected
:quick-find ; Class
:quick-union ; Class
:weighted-quick-union ; Class
:weighted-quick-union-path-compression ; Class
:network ; Accessor
:network-size ; Accessor
:quick-union))
;;; Unit tests
(defpackage :com.lisp-algo.test
(:use :common-lisp
:lisp-unit
:com.lisp-algo.union-find)
(:export :get-row))
(:shadow :union)
(:export :get-row))

92
test/union-find.lisp
View file

@ -12,57 +12,45 @@
;;; Test create network
(define-test create-network-test ()
;; ----- Length tests
(dotimes (nw-size 1000)
(assert-equal nw-size (length (qf-create-network nw-size))) ; Quick-Find
(assert-equal nw-size (length (qu-create-network nw-size))) ; Quick-Union
;; Weighted-Quick-Union
(assert-equal 10 (length (get-row (wqu-create-network 10) 0)))
(assert-equal 10 (length (get-row (wqu-create-network 10) 1)))
;; Weighted-Quick-Union with Path Compression
(assert-equal 10 (length (get-row (wqupc-create-network 10) 0)))
(assert-equal 10 (length (get-row (wqupc-create-network 10) 1))))
;; ----- Value tests
(assert-equalp #(0 1 2 3 4) (qf-create-network 5)) ; Quick-Find
(assert-equalp #(0 1 2 3 4) (qu-create-network 5)) ; Quick-Union
;; Weighted-Quick-Union
(assert-true (equalp #(0 1 2 3 4 5 6 7 8 9) (get-row (wqu-create-network 10) 0)))
(assert-true (equalp (make-array 10 :initial-element 1) (get-row (wqu-create-network 10) 1)))
;; Weighted-Quick-Union with Path Compression
(assert-true (equalp #(0 1 2 3 4 5 6 7 8 9) (get-row (wqupc-create-network 10) 0)))
(assert-true (equalp (make-array 10 :initial-element 1) (get-row (wqupc-create-network 10) 1))))
;; (define-test test-union_
;; (let ((nw (create-network 10)))
;; (setf nw (union_ nw 1 2))
;; (setf nw (union_ nw 0 5))
;; (assert-equal (aref nw 1) (aref nw 2))
;; (assert-equal (aref nw 0) (aref nw 5))
;; (assert-false (equal (aref nw 0) (aref nw 8)))
;; (assert-false (equal (aref nw 0) (aref nw 2)))))
;; (define-test test-connected
;; (let ((nw (create-network 10)))
;; (setf nw (union_ nw 1 2))
;; (setf nw (union_ nw 0 5))
;; (assert-true (connected nw 1 2))
;; (assert-true (connected nw 0 5))
;; (assert-false (connected nw 0 8))
;; (assert-false (connected nw 0 2))))
;; (define-test test-nunion__
;; (let ((nw (create-network 10)))
;; (nunion_ nw 1 2)
;; (nunion_ nw 0 5)
;; (assert-equal (aref nw 1) (aref nw 2))
;; (assert-equal (aref nw 0) (aref nw 5))
;; (assert-false (equal (aref nw 0) (aref nw 8)))
;; (assert-false (equal (aref nw 0) (aref nw 2)))))
;; ;; Run all tests
;; (setq *print-summary* t) ; Details tests locations when running tests
;; (run-tests :all)
(define-test initialize-instance-test ()
;; ----- Network Length Tests
(dotimes (test-size 100)
(let* ((algo (make-instance 'quick-find :network-size test-size)) ; Quick Find
(nw (network algo))
(nw-size (network-size algo)))
(assert-equal test-size nw-size)
(assert-equal test-size (length nw)))
(let* ((algo (make-instance 'quick-union :network-size test-size)) ; Quick Union
(nw (network algo))
(nw-size (network-size algo)))
(assert-equal test-size nw-size)
(assert-equal test-size (length nw)))
(let* ((algo (make-instance 'weighted-quick-union :network-size test-size)) ; Weighted Quick Union
(nw (network algo))
(nw-size (network-size algo)))
(assert-equal test-size nw-size)
(assert-equal test-size (length (get-row nw 0)))
(assert-equal test-size (length (get-row nw 1))))
(let* ((algo (make-instance 'weighted-quick-union-path-compression :network-size test-size)) ; Weighted Quick Union Path Compression
(nw (network algo))
(nw-size (network-size algo)))
(assert-equal test-size nw-size)
(assert-equal test-size (length (get-row nw 0)))
(assert-equal test-size (length (get-row nw 1)))))
;; ----- Network Values Tests
(let* ((algo (make-instance 'quick-find :network-size 5)) ; Quick Find
(nw (network algo)))
(assert-true #(0 1 2 3 4) nw))
(let* ((algo (make-instance 'quick-union :network-size 5)) ; Quick Union
(nw (network algo)))
(assert-true #(0 1 2 3 4) nw))
(let* ((algo (make-instance 'weighted-quick-union :network-size 10)) ; Weighted Quick Union
(nw (network algo)))
(assert-true (equalp #(0 1 2 3 4 5 6 7 8 9) (get-row nw 0)))
(assert-true (equalp (make-array 10 :initial-element 1) (get-row nw 1))))
(let* ((algo (make-instance 'weighted-quick-union-path-compression :network-size 10)) ; Weighted Quick Union Path Compression
(nw (network algo)))
(assert-true (equalp #(0 1 2 3 4 5 6 7 8 9) (get-row nw 0)))
(assert-true (equalp (make-array 10 :initial-element 1) (get-row nw 1)))))

45
test/union-find/test-quick-find.lisp
View file

@ -1,45 +0,0 @@
(load "../lisp-unit.lisp")
(defpackage :test-quick-find
(:use :common-lisp
:lisp-unit))
(in-package :test-quick-find)
(load "../../src/union-find/quick-find.lisp")
;;; Define tests
(define-test test-create-network
(assert-equal 10 (length (create-network 10)))
(assert-equalp #(0 1 2 3 4) (create-network 5)))
(define-test test-union_
(let ((nw (create-network 10)))
(setf nw (union_ nw 1 2))
(setf nw (union_ nw 0 5))
(assert-equal (aref nw 1) (aref nw 2))
(assert-equal (aref nw 0) (aref nw 5))
(assert-false (equal (aref nw 0) (aref nw 8)))
(assert-false (equal (aref nw 0) (aref nw 2)))))
(define-test test-connected
(let ((nw (create-network 10)))
(setf nw (union_ nw 1 2))
(setf nw (union_ nw 0 5))
(assert-true (connected nw 1 2))
(assert-true (connected nw 0 5))
(assert-false (connected nw 0 8))
(assert-false (connected nw 0 2))))
(define-test test-nunion__
(let ((nw (create-network 10)))
(nunion_ nw 1 2)
(nunion_ nw 0 5)
(assert-equal (aref nw 1) (aref nw 2))
(assert-equal (aref nw 0) (aref nw 5))
(assert-false (equal (aref nw 0) (aref nw 8)))
(assert-false (equal (aref nw 0) (aref nw 2)))))
;; Run all tests
(setq *print-summary* t) ; Details tests locations when running tests
(run-tests :all)

45
union-find/quick-find.lisp
View file

@ -5,34 +5,35 @@
(in-package :com.lisp-algo.union-find)
;;; Base functions
(defclass quick-find ()
((nw-size
:initarg :network-size
:initform 10
:accessor network-size)
(nw
:initform nil
:accessor network)))
(defun qf-create-network (n)
"Build a quick-find network using a dynamic vector"
(let ((nodes (make-array n :fill-pointer 0)))
(dotimes (id n)
(defmethod initialize-instance :after ((algo quick-find) &key)
;; Initialize network using dynamic vector
(let* ((nw-size (slot-value algo 'nw-size))
(nodes (make-array nw-size :fill-pointer 0)))
(dotimes (id nw-size)
(vector-push id nodes))
nodes))
(setf (slot-value algo 'nw) nodes)))
;; Link two nodes in the network
(defun qf-union (network n1 n2)
"Link two nodes in the quick-find network. union_ represent the union operation of the Quick Find Algorithm"
(let ((v-n1 (elt network n1))
(v-n2 (elt network n2))
(new-network (copy-seq network)))
(defmethod union ((algo-instance quick-find) n1 n2)
(with-slots ((nw nw)) algo-instance
(let ((v-n1 (elt nw n1))
(v-n2 (elt nw n2))
(new-network (copy-seq nw)))
(dotimes (n (length new-network))
(if (= (elt new-network n) v-n2) (setf (elt new-network n) v-n1)))
new-network))
(setf nw new-network))))
;;; Macro definitions
(defmacro qf-connected (network n1 n2)
(defmethod connected ((algo-instance quick-find) n1 n2)
" Return t if there is a path between n1 and n2, nil otherwise. connected represent the find operation of the Quick Find Algorithm"
`(= (elt ,network ,n1) (elt ,network ,n2)))
(defmacro qf-nunion (network n1 n2)
"A destructive version of union_"
`(setq ,network (union ,network ,n1 ,n2)))
(with-slots ((nw nw)) algo-instance
(= (elt nw n1) (elt nw n2))))

37
union-find/quick-union.lisp
View file

@ -7,37 +7,40 @@
(in-package :com.lisp-algo.union-find)
;;; Base functions
(defclass quick-union ()
((nw-size
:initarg :network-size
:initform 10
:accessor network-size)
(nw
:initarg nil
:accessor network)))
(defun qu-create-network (n)
(defmethod initialize-instance :after ((algo quick-union) &key)
"Build a quick-find network using a dynamic vector"
(with-slots ((n nw-size) (nw nw)) algo
(let ((nodes (make-array n :fill-pointer 0)))
(dotimes (id n)
(vector-push id nodes))
nodes))
(setf nw nodes))))
(defun qu-find-root (network node)
(defun quick-union-find-root (network node)
"Find the root of a sub-tree in the network."
(do ((id node value)
(value (elt network node) (elt network value)))
((= id value) id)))
(defun qu-union (network n1 n2)
(defmethod union ((algo quick-union) n1 n2)
"Connect to sub-tree together. union represent the union operation on the Quick Union algorithm"
(with-slots ((network nw)) algo
(let ((new-network (copy-seq network)))
(setf (elt new-network (qu-find-root new-network n1))
(qu-find-root new-network n2))
new-network))
(setf (elt new-network (quick-union-find-root new-network n1))
(quick-union-find-root new-network n2))
(setf network new-network))))
;;; Macro definitions
(defmacro qu-connected (network n1 n2)
(defmethod connected ((algo quick-union) n1 n2)
"Return true if n1 and n2 are connected and nil otherwise. connection represent
the find operation on the Quick Union algorithm"
`(= (qu-find-root ,network ,n1) (qu-find-root ,network ,n2)))
(defmacro qu-nunion (network n1 n2)
"A destructive version of union_"
`(setf ,network (qu-union ,network ,n1 ,n2)))
(with-slots ((network nw)) algo
(= (quick-union-find-root network n1) (quick-union-find-root network n2))))

10
union-find/union-find.lisp Normal file
View file

@ -0,0 +1,10 @@
(in-package :com.lisp-algo.union-find)
(defgeneric create-network (algo-instance n)
(:documentation "Create a network for the algo-instance"))
(defgeneric union (algo-instance n1 n2)
(:documentation "Link two nodes in the quick-find network. union_ represent the union operation of the Quick Find Algorithm"))
(defgeneric connected (algo-instance n1 n2)
(:documentation "Check is there is a path between n1 and n2"))

54
union-find/weighted-quick-union-path-compression.lisp
View file

@ -11,15 +11,28 @@
(in-package :com.lisp-algo.union-find)
(defclass weighted-quick-union-path-compression ()
((nw-size
:initarg :network-size
:initform 10
:accessor network-size)
(nw
:initform nil
:accessor network)))
;;; Base functions
(defun wqupc-create-network (n)
(defmethod initialize-instance :after ((algo weighted-quick-union-path-compression) &key)
"Build a quick-find network using a multi-dimensional dynamic vector:\n
1st dimension = the network\n 2nd dimension = each subtree node quantities"
(with-slots ((n nw-size) (nw nw)) algo
(let ((network (make-array `(2 ,n) :initial-element 1)))
(dotimes (id n)
(setf (aref network 0 id) id))
network))
(setf nw network))))
(defun wqupc-find-root (network node)
"Find the root of a sub-tree in the network. This is a destructive version of find-root that
@ -29,33 +42,26 @@ include path compression"
((= id value) (progn (setf (aref network 0 node) id) ; Path compression
id))))
(defun wqupc-union (network n1 n2)
(defmethod union ((algo weighted-quick-union-path-compression) n1 n2)
"Connect to sub-tree together. union represent the union operation on the Quick Union algorithm"
(let ((new-network (copy-tree network))) ; Duplicate network
(let* ((n1-root (wqupc-find-root new-network n1))
(n2-root (wqupc-find-root new-network n2))
(n1-size (aref new-network 1 n1-root))
(n2-size (aref new-network 1 n2-root)))
(if (>= n1-size n2-size) ; Check which subtree is LARGER (not deeper)
(progn (setf (aref new-network 0 n2-root) (aref new-network 0 n1-root)) ; Modify the second node
(setf (aref new-network 1 n1-root) ; Update tree larger
(+ (aref new-network 1 n1-root) (aref new-network 1 n2-root))))
(with-slots ((network nw)) algo
(let ((new-network (copy-tree network))) ; Duplicate network
(let* ((n1-root (wqupc-find-root new-network n1))
(n2-root (wqupc-find-root new-network n2))
(n1-size (aref new-network 1 n1-root))
(n2-size (aref new-network 1 n2-root)))
(if (>= n1-size n2-size) ; Check which subtree is LARGER (not deeper)
(progn (setf (aref new-network 0 n2-root) (aref new-network 0 n1-root)) ; Modify the second node
(setf (aref new-network 1 n1-root) ; Update tree larger
(+ (aref new-network 1 n1-root) (aref new-network 1 n2-root))))
(progn (setf (aref new-network 0 n1-root) (aref new-network 0 n2-root)) ; Otherwise modify the first node
(setf (aref new-network 1 n2-root) ; Update tree larger
(+ (aref new-network 1 n2-root) (aref new-network 1 n1-root)))))
new-network)))
new-network))))
;;; Macro definitions
(defmacro wqupc-connected (network n1 n2)
(defmethod connected ((algo weighted-quick-union-path-compression) n1 n2)
"Return true if n1 and n2 are connected and nil otherwise. connection represent
the find operation on the Quick Union algorithm"
`(= (wqupc-find-root ,network ,n1) (wqupc-find-root ,network ,n2)))
(defmacro wqupc-nunion (network n1 n2)
"A destructive version of the union function."
`(setf ,network (wqupc-union ,network ,n1 ,n2)))
(with-slots ((network nw)) algo
(= (wqupc-find-root network n1) (wqupc-find-root network n2))))

54
union-find/weighted-quick-union.lisp
View file

@ -9,15 +9,24 @@
(in-package :com.lisp-algo.union-find)
;;; Base functions
(defun wqu-create-network (n)
"Build a quick-find network using a multi-dimensional dynamic vector:\n
(defclass weighted-quick-union ()
((nw-size
:initarg :network-size
:initform 10
:accessor network-size)
(nw
:initform nil
:accessor network)))
(defmethod initialize-instance :after ((algo weighted-quick-union) &key)
"Build a quick-find network using a multi-dimensional dynamic vector:\n
1st dimension = the network\n 2nd dimension = each subtree node quantities"
(with-slots ((n nw-size) (nw nw)) algo
(let ((network (make-array `(2 ,n) :initial-element 1)))
(dotimes (id n)
(setf (aref network 0 id) id))
network))
(setf nw network))))
(defun wqu-find-root (network node)
"Find the root of a sub-tree in the network."
@ -25,33 +34,26 @@
(value (aref network 0 node) (aref network 0 value)))
((= id value) id)))
(defun wqu-union-union (network n1 n2)
(defmethod union ((algo weighted-quick-union) n1 n2)
"Connect to sub-tree together. union represent the union operation on the Quick Union algorithm"
(let ((new-network (copy-tree network))) ; Duplicate network
(let* ((n1-root (wqu-find-root new-network n1))
(n2-root (wqu-find-root new-network n2))
(n1-size (aref new-network 1 n1-root))
(n2-size (aref new-network 1 n2-root)))
(if (>= n1-size n2-size) ; Check which subtree is LARGER (not deeper)
(progn (setf (aref new-network 0 n2-root) (aref new-network 0 n1-root)) ; Modify the second node
(setf (aref new-network 1 n1-root) ; Update tree larger
(+ (aref new-network 1 n1-root) (aref new-network 1 n2-root))))
(with-slots ((network nw)) algo
(let ((new-network (copy-tree network))) ; Duplicate network
(let* ((n1-root (wqu-find-root new-network n1))
(n2-root (wqu-find-root new-network n2))
(n1-size (aref new-network 1 n1-root))
(n2-size (aref new-network 1 n2-root)))
(if (>= n1-size n2-size) ; Check which subtree is LARGER (not deeper)
(progn (setf (aref new-network 0 n2-root) (aref new-network 0 n1-root)) ; Modify the second node
(setf (aref new-network 1 n1-root) ; Update tree larger
(+ (aref new-network 1 n1-root) (aref new-network 1 n2-root))))
(progn (setf (aref new-network 0 n1-root) (aref new-network 0 n2-root)) ; Otherwise modify the first node
(setf (aref new-network 1 n2-root) ; Update tree larger
(+ (aref new-network 1 n2-root) (aref new-network 1 n1-root)))))
new-network)))
(setf network new-network)))))
;;; Macro definitions
(defmacro wqu-connected (network n1 n2)
(defmethod connected ((algo weighted-quick-union) n1 n2)
"Return true if n1 and n2 are connected and nil otherwise. connection represent
the find operation on the Quick Union algorithm"
`(= (wqu-find-root ,network ,n1) (wqu-find-root ,network ,n2)))
(defmacro wqu-nunion (network n1 n2)
"A destructive version of the union function."
`(setf ,network (wqu-union ,network ,n1 ,n2)))
(with-slots ((network nw)) algo
(= (wqu-find-root network n1) (wqu-find-root network n2))))