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

Re-organize code

Browse source
This commit is contained in:
Loic Guegan 2019-02-24 10:30:57 +01:00
parent d0f6e2ff9c
commit 5725987c8d
9 changed files with 213 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
lisp-algo.asd Normal file
View file

@ -0,0 +1,19 @@
;;;; Define ASDF system
(defsystem "lisp-algo"
:description "Provide several lisp algorithms"
:version "0.0.1"
:depends-on ("lisp-unit")
:perform (test-op (o s) (symbol-call :com.lisp-algo.test :do-tests))
:components ((:file "packages")
(:module "union-find"
:depends-on ("packages")
:components ((:file "quick-find")
(:file "quick-union")
(:file "weighted-quick-union")
(:file "weighted-quick-union-path-compression")))
(:module "test"
:depends-on ("packages")
:components ((:file "test")
(:file "union-find")))))

35
packages.lisp Normal file
View file

@ -0,0 +1,35 @@
;;;; This file contains lisp-algos packages definitions
;;; Union-Find packages
(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))
;;; Unit tests
(defpackage :com.lisp-algo.test
(:use :common-lisp
:lisp-unit
:com.lisp-algo.union-find)
(:export :get-row))

8
test/test.lisp Normal file
View file

@ -0,0 +1,8 @@
(in-package :com.lisp-algo.test)
(defun do-tests ()
"Configure lisp-unit and run all tests."
(setq *print-errors* t) ; Details tests locations when running tests
(setq *print-summary* t) ; Details on tests
(setq *print-failures* t) ; Details tests locations when failures
(run-tests :all :com.lisp-algo.test))

68
test/union-find.lisp Normal file
View file

@ -0,0 +1,68 @@
(in-package :com.lisp-algo.test)
;;; Utils
(defun get-row (array &optional (row-id 0))
(let* ((row-size (array-dimension array 1)) ; Deduce row size from array
(row (make-array row-size :fill-pointer 0))) ; Initialize a new vector (which will contain the row row-id from array)
;; Fill row with the right values of array
(do ((cur-id 0 (+ cur-id 1)))
((>= cur-id row-size) row)
(vector-push (row-major-aref array (+ cur-id (* row-size row-id ))) row))))
;;; 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)

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

@ -0,0 +1,45 @@
(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)

11
src/union-find/quick-find.lisp → union-find/quick-find.lisp
View file

@ -3,10 +3,11 @@
;;;; problem by providing a way to find if there
;;;; is a path between two nodes in a dynamic graph
(in-package :com.lisp-algo.union-find)
;;; Base functions
(defun create-network (n)
(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)
@ -14,7 +15,7 @@
nodes))
;; Link two nodes in the network
(defun union_ (network n1 n2)
(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))
@ -25,13 +26,13 @@
;;; Macro definitions
(defmacro connected (network n1 n2)
(defmacro qf-connected (network 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 nunion_ (network n1 n2)
(defmacro qf-nunion (network n1 n2)
"A destructive version of union_"
`(setq ,network (union_ ,network ,n1 ,n2)))
`(setq ,network (union ,network ,n1 ,n2)))

19
src/union-find/quick-union.lisp → union-find/quick-union.lisp
View file

@ -5,38 +5,39 @@
;;;; It is an improved version of the Quick Find algorithm
;;;; It optimize the union function
(in-package :com.lisp-algo.union-find)
;;; Base functions
(defun create-network (n)
(defun qu-create-network (n)
"Build a quick-find network using a dynamic vector"
(let ((nodes (make-array n :fill-pointer 0)))
(dotimes (id n)
(vector-push id nodes))
nodes))
(defun find-root (network node)
(defun qu-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 union_ (network n1 n2)
(defun qu-union (network n1 n2)
"Connect to sub-tree together. union represent the union operation on the Quick Union algorithm"
(let ((new-network (copy-seq network)))
(setf (elt new-network (find-root new-network n1))
(find-root new-network n2))
(setf (elt new-network (qu-find-root new-network n1))
(qu-find-root new-network n2))
new-network))
;;; Macro definitions
(defmacro connected (network n1 n2)
(defmacro qu-connected (network n1 n2)
"Return true if n1 and n2 are connected and nil otherwise. connection represent
the find operation on the Quick Union algorithm"
`(= (find-root ,network ,n1) (find-root ,network ,n2)))
`(= (qu-find-root ,network ,n1) (qu-find-root ,network ,n2)))
(defmacro nunion_ (network n1 n2)
(defmacro qu-nunion (network n1 n2)
"A destructive version of union_"
`(setf ,network (union_ ,network ,n1 ,n2)))
`(setf ,network (qu-union ,network ,n1 ,n2)))

20
src/union-find/weighted-quick-union-path-compression.lisp → union-find/weighted-quick-union-path-compression.lisp
View file

@ -9,9 +9,11 @@
;;;; The path compression is ensure by the find-root function
;;;; IMPORTANT: find-root is now a destructive function ! Be aware...
(in-package :com.lisp-algo.union-find)
;;; Base functions
(defun create-network (n)
(defun wqupc-create-network (n)
"Build a quick-find network using a multi-dimensional dynamic vector:\n
1st dimension = the network\n 2nd dimension = each subtree node quantities"
(let ((network (make-array `(2 ,n) :initial-element 1)))
@ -19,7 +21,7 @@
(setf (aref network 0 id) id))
network))
(defun find-root (network node)
(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
include path compression"
(do ((id node value)
@ -27,11 +29,11 @@ include path compression"
((= id value) (progn (setf (aref network 0 node) id) ; Path compression
id))))
(defun union_ (network n1 n2)
(defun wqupc-union (network 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 (find-root new-network n1))
(n2-root (find-root new-network n2))
(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)
@ -47,13 +49,13 @@ include path compression"
;;; Macro definitions
(defmacro connected (network n1 n2)
(defmacro wqupc-connected (network n1 n2)
"Return true if n1 and n2 are connected and nil otherwise. connection represent
the find operation on the Quick Union algorithm"
`(= (find-root ,network ,n1) (find-root ,network ,n2)))
`(= (wqupc-find-root ,network ,n1) (wqupc-find-root ,network ,n2)))
(defmacro nunion_ (network n1 n2)
(defmacro wqupc-nunion (network n1 n2)
"A destructive version of the union function."
`(setf ,network (union_ ,network ,n1 ,n2)))
`(setf ,network (wqupc-union ,network ,n1 ,n2)))

20
src/union-find/weighted-quick-union.lisp → union-find/weighted-quick-union.lisp
View file

@ -7,9 +7,11 @@
;;;; The algorithm try to reduce the deepness of the tree in
;;;; order to optimize the find-root function
(in-package :com.lisp-algo.union-find)
;;; Base functions
(defun create-network (n)
(defun wqu-create-network (n)
"Build a quick-find network using a multi-dimensional dynamic vector:\n
1st dimension = the network\n 2nd dimension = each subtree node quantities"
(let ((network (make-array `(2 ,n) :initial-element 1)))
@ -17,17 +19,17 @@
(setf (aref network 0 id) id))
network))
(defun find-root (network node)
(defun wqu-find-root (network node)
"Find the root of a sub-tree in the network."
(do ((id node value)
(value (aref network 0 node) (aref network 0 value)))
((= id value) id)))
(defun union_ (network n1 n2)
(defun wqu-union-union (network 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 (find-root new-network n1))
(n2-root (find-root new-network n2))
(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)
@ -43,13 +45,13 @@
;;; Macro definitions
(defmacro connected (network n1 n2)
(defmacro wqu-connected (network n1 n2)
"Return true if n1 and n2 are connected and nil otherwise. connection represent
the find operation on the Quick Union algorithm"
`(= (find-root ,network ,n1) (find-root ,network ,n2)))
`(= (wqu-find-root ,network ,n1) (wqu-find-root ,network ,n2)))
(defmacro nunion_ (network n1 n2)
(defmacro wqu-nunion (network n1 n2)
"A destructive version of the union function."
`(setf ,network (union_ ,network ,n1 ,n2)))
`(setf ,network (wqu-union ,network ,n1 ,n2)))