5504cf7fd389

Initial commit
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Sat, 05 Nov 2016 19:34:10 +0000
parents
children c3d408862ac3
branches/tags (none)
files .ffignore .hgignore .lispwords Makefile README.markdown cl-directed-graph.asd package.lisp src/directed-graph.lisp vendor/make-quickutils.lisp vendor/quickutils-package.lisp vendor/quickutils.lisp

Changes

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgignore	Sat Nov 05 19:34:10 2016 +0000
@@ -0,0 +1,3 @@
+syntax: glob
+
+scratch.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile	Sat Nov 05 19:34:10 2016 +0000
@@ -0,0 +1,8 @@
+.PHONY: vendor
+
+# Vendor ----------------------------------------------------------------------
+vendor/quickutils.lisp: vendor/make-quickutils.lisp
+	cd vendor && sbcl --noinform --load make-quickutils.lisp  --eval '(quit)'
+
+vendor: vendor/quickutils.lisp
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/README.markdown	Sat Nov 05 19:34:10 2016 +0000
@@ -0,0 +1,1 @@
+* **License:** MIT/X11
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/cl-directed-graph.asd	Sat Nov 05 19:34:10 2016 +0000
@@ -0,0 +1,18 @@
+(asdf:defsystem :cl-directed-graph
+  :name "directed-graph"
+  :description "Simple directed graphs in Common Lisp."
+
+  :author "Steve Losh <steve@stevelosh.com>"
+
+  :license "MIT/X11"
+  :version "1.0.0"
+
+  :depends-on ()
+
+  :serial t
+  :components ((:module "vendor" :serial t
+                :components ((:file "quickutils-package")
+                             (:file "quickutils")))
+               (:file "package")
+               (:module "src" :serial t
+                :components ((:file "directed-graph")))))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/package.lisp	Sat Nov 05 19:34:10 2016 +0000
@@ -0,0 +1,4 @@
+(defpackage :directed-graph
+  (:use :cl :directed-graph.quickutils)
+  (:export))
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/directed-graph.lisp	Sat Nov 05 19:34:10 2016 +0000
@@ -0,0 +1,159 @@
+(in-package :directed-graph)
+
+
+;;;; Data ---------------------------------------------------------------------
+(defclass digraph ()
+  ((nodes :initarg :nodes :accessor digraph-nodes)
+   (test :initarg :test :accessor digraph-test)))
+
+(defun make-digraph (&key (test #'eql) initial-vertices)
+  (let ((digraph (make-instance 'digraph
+                   :nodes (make-hash-table :test test
+                                           :size (length initial-vertices))
+                   :test test)))
+    (mapc (curry #'insert-vertex digraph) initial-vertices)
+    digraph))
+
+(defmethod print-object ((d digraph) stream)
+  (print-unreadable-object (d stream :type t :identity t)
+    (format stream "~:S" (hash-table-keys (digraph-nodes d)))))
+
+
+(defmacro pred (digraph object)
+  `(car (gethash ,object (digraph-nodes ,digraph))))
+
+(defmacro succ (digraph object)
+  `(cdr (gethash ,object (digraph-nodes ,digraph))))
+
+
+(defun copy-digraph (digraph)
+  ;; todo make this faster, but at least this works
+  (let ((copy (make-digraph :test (digraph-test digraph)
+                            :initial-vertices (vertices digraph))))
+    (do-edges (p s digraph) (insert-edge digraph p s))
+    copy))
+
+
+;;;; Basic API ----------------------------------------------------------------
+(defun vertices (digraph)
+  (hash-table-keys (digraph-nodes digraph)))
+
+(defun predecessors (digraph object)
+  (pred digraph object))
+
+(defun successors (digraph object)
+  (succ digraph object))
+
+(defun neighbors (digraph object)
+  (union (predecessors digraph object)
+         (predecessors digraph object)
+         :test (digraph-test digraph)))
+
+
+(defun contains-vertex-p (digraph object)
+  (nth-value 1 (gethash object (digraph-nodes digraph))))
+
+(defun contains-edge-p (digraph predecessor successor)
+  (ensure-boolean (member successor (succ digraph predecessor)
+                          :test (digraph-test digraph))))
+
+
+(defun insert-vertex (digraph object)
+  (nth-value 1 (ensure-gethash object (digraph-nodes digraph)
+                               (cons nil nil))))
+
+(defun insert-edge (digraph predecessor successor)
+  (assert (contains-vertex-p digraph predecessor) (predecessor)
+      "Cannot add edge with predecessor ~S because it is not in the graph"
+      predecessor)
+  (assert (contains-vertex-p digraph successor) (successor)
+      "Cannot add edge with successor ~S because it is not in the graph"
+      successor)
+  (pushnew predecessor (pred digraph successor) :test (digraph-test digraph))
+  (pushnew successor (succ digraph predecessor) :test (digraph-test digraph))
+  (values))
+
+
+(defun remove-edge (digraph predecessor successor)
+  (removef (succ digraph predecessor) successor :test (digraph-test digraph))
+  (removef (pred digraph successor) predecessor :test (digraph-test digraph))
+  (values))
+
+(defun remove-vertex (digraph object)
+  (let ((ps (predecessors digraph object))
+        (ss (successors digraph object))
+        (test (digraph-test digraph)))
+    (loop :for p :in ps :do (removef (succ digraph p) object :test test))
+    (loop :for s :in ss :do (removef (pred digraph s) object :test test)))
+  (remhash object (digraph-nodes digraph))
+  (values))
+
+
+(defun degree (digraph object)
+  (length (neighbors digraph object)))
+
+(defun degree-in (digraph object)
+  (length (predecessors digraph object)))
+
+(defun degree-out (digraph object)
+  (length (successors digraph object)))
+
+
+(defun size (digraph)
+  (hash-table-count (digraph-nodes digraph)))
+
+
+;;;; Iteration ----------------------------------------------------------------
+(defmacro do-vertices ((symbol digraph) &body body)
+  `(loop :for ,symbol :being :the hash-keys :of (digraph-nodes ,digraph)
+    :do (progn ,@body)))
+
+(defmacro do-edges ((predecessor-symbol successor-symbol digraph) &body body)
+  (with-gensyms (preds succs)
+    `(loop
+      :for ,predecessor-symbol :being :the hash-keys :of (digraph-nodes ,digraph)
+      :using (hash-value (,preds . ,succs))
+      :do (loop :for ,successor-symbol :in ,succs ; i miss u, iterate
+                :do (progn ,@body)))))
+
+
+(defun mapc-vertices (function digraph)
+  (do-vertices (v digraph) (funcall function v)))
+
+(defun mapc-edges (function digraph)
+  (do-edges (p s digraph) (funcall function p s)))
+
+
+(defun map-vertices (function digraph)
+  (let ((result nil))
+    (do-vertices (v digraph) (push (funcall function v) result))
+    result))
+
+(defun map-edges (function digraph)
+  (let ((result nil))
+    (do-edges (p s digraph) (push (funcall function p s) result))
+    result))
+
+
+(defun dump (digraph)
+  (format t "Digraph :TEST ~A~%:CONTENTS " (digraph-test digraph))
+  (finish-output)
+  (ql:quickload :losh :silent t)
+  (funcall (intern "PRINT-HASH-TABLE" (find-package :losh))
+           (digraph-nodes digraph))
+  (values))
+
+
+;;;; Scratch ------------------------------------------------------------------
+(defparameter *d* (make-digraph))
+
+
+(insert-vertex *d* 'a)
+(insert-vertex *d* 'b)
+(insert-vertex *d* 'c)
+
+(insert-edge *d* 'b 'c)
+
+(remove-edge *d* 'a 'a)
+(remove-vertex *d* 'a)
+(dump *d*)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/make-quickutils.lisp	Sat Nov 05 19:34:10 2016 +0000
@@ -0,0 +1,23 @@
+(ql:quickload 'quickutil)
+
+(qtlc:save-utils-as
+  "quickutils.lisp"
+  :utilities '(
+
+               :compose
+               :curry
+               :dohash
+               :ensure-boolean
+               :ensure-gethash
+               :ensure-list
+               :hash-table-keys
+               :maphash-keys
+               :mkstr
+               :once-only
+               :rcurry
+               :removef
+               :symb
+               :with-gensyms
+
+               )
+  :package "DIRECTED-GRAPH.QUICKUTILS")
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/quickutils-package.lisp	Sat Nov 05 19:34:10 2016 +0000
@@ -0,0 +1,12 @@
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (find-package "DIRECTED-GRAPH.QUICKUTILS")
+    (defpackage "DIRECTED-GRAPH.QUICKUTILS"
+      (:documentation "Package that contains Quickutil utility functions.")
+      (:use :cl))))
+
+(in-package "DIRECTED-GRAPH.QUICKUTILS")
+
+;; need to define this here so sbcl will shut the hell up about it being
+;; undefined when compiling quickutils.lisp.  computers are trash.
+(defparameter *utilities* nil)
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/quickutils.lisp	Sat Nov 05 19:34:10 2016 +0000
@@ -0,0 +1,271 @@
+;;;; This file was automatically generated by Quickutil.
+;;;; See http://quickutil.org for details.
+
+;;;; To regenerate:
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :DOHASH :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :HASH-TABLE-KEYS :MAPHASH-KEYS :MKSTR :ONCE-ONLY :RCURRY :REMOVEF :SYMB :WITH-GENSYMS) :ensure-package T :package "DIRECTED-GRAPH.QUICKUTILS")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (find-package "DIRECTED-GRAPH.QUICKUTILS")
+    (defpackage "DIRECTED-GRAPH.QUICKUTILS"
+      (:documentation "Package that contains Quickutil utility functions.")
+      (:use #:cl))))
+
+(in-package "DIRECTED-GRAPH.QUICKUTILS")
+
+(when (boundp '*utilities*)
+  (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
+                                         :COMPOSE :CURRY :DOHASH
+                                         :ENSURE-BOOLEAN :ENSURE-GETHASH
+                                         :ENSURE-LIST :MAPHASH-KEYS
+                                         :HASH-TABLE-KEYS :MKSTR :ONCE-ONLY
+                                         :RCURRY :REMOVEF :SYMB
+                                         :STRING-DESIGNATOR :WITH-GENSYMS))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun make-gensym-list (length &optional (x "G"))
+    "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
+using the second (optional, defaulting to `\"G\"`) argument."
+    (let ((g (if (typep x '(integer 0)) x (string x))))
+      (loop repeat length
+            collect (gensym g))))
+  )                                        ; eval-when
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  ;;; To propagate return type and allow the compiler to eliminate the IF when
+  ;;; it is known if the argument is function or not.
+  (declaim (inline ensure-function))
+
+  (declaim (ftype (function (t) (values function &optional))
+                  ensure-function))
+  (defun ensure-function (function-designator)
+    "Returns the function designated by `function-designator`:
+if `function-designator` is a function, it is returned, otherwise
+it must be a function name and its `fdefinition` is returned."
+    (if (functionp function-designator)
+        function-designator
+        (fdefinition function-designator)))
+  )                                        ; eval-when
+
+  (defun compose (function &rest more-functions)
+    "Returns a function composed of `function` and `more-functions` that applies its ;
+arguments to to each in turn, starting from the rightmost of `more-functions`,
+and then calling the next one with the primary value of the last."
+    (declare (optimize (speed 3) (safety 1) (debug 1)))
+    (reduce (lambda (f g)
+              (let ((f (ensure-function f))
+                    (g (ensure-function g)))
+                (lambda (&rest arguments)
+                  (declare (dynamic-extent arguments))
+                  (funcall f (apply g arguments)))))
+            more-functions
+            :initial-value function))
+
+  (define-compiler-macro compose (function &rest more-functions)
+    (labels ((compose-1 (funs)
+               (if (cdr funs)
+                   `(funcall ,(car funs) ,(compose-1 (cdr funs)))
+                   `(apply ,(car funs) arguments))))
+      (let* ((args (cons function more-functions))
+             (funs (make-gensym-list (length args) "COMPOSE")))
+        `(let ,(loop for f in funs for arg in args
+                     collect `(,f (ensure-function ,arg)))
+           (declare (optimize (speed 3) (safety 1) (debug 1)))
+           (lambda (&rest arguments)
+             (declare (dynamic-extent arguments))
+             ,(compose-1 funs))))))
+  
+
+  (defun curry (function &rest arguments)
+    "Returns a function that applies `arguments` and the arguments
+it is called with to `function`."
+    (declare (optimize (speed 3) (safety 1) (debug 1)))
+    (let ((fn (ensure-function function)))
+      (lambda (&rest more)
+        (declare (dynamic-extent more))
+        ;; Using M-V-C we don't need to append the arguments.
+        (multiple-value-call fn (values-list arguments) (values-list more)))))
+
+  (define-compiler-macro curry (function &rest arguments)
+    (let ((curries (make-gensym-list (length arguments) "CURRY"))
+          (fun (gensym "FUN")))
+      `(let ((,fun (ensure-function ,function))
+             ,@(mapcar #'list curries arguments))
+         (declare (optimize (speed 3) (safety 1) (debug 1)))
+         (lambda (&rest more)
+           (apply ,fun ,@curries more)))))
+  
+
+  (defmacro dohash ((key value table &optional result) &body body)
+    "Iterate over the hash table `table`, executing `body`, with `key` and
+   `value` bound to the keys and values of the hash table
+   respectively. Return `result` from the iteration form."
+    `(progn
+       (maphash (lambda (,key ,value)
+                  ,@body)
+                ,table)
+       ,result))
+  
+
+  (defun ensure-boolean (x)
+    "Convert `x` into a Boolean value."
+    (and x t))
+  
+
+  (defmacro ensure-gethash (key hash-table &optional default)
+    "Like `gethash`, but if `key` is not found in the `hash-table` saves the `default`
+under key before returning it. Secondary return value is true if key was
+already in the table."
+    `(multiple-value-bind (value ok) (gethash ,key ,hash-table)
+       (if ok
+           (values value ok)
+           (values (setf (gethash ,key ,hash-table) ,default) nil))))
+  
+
+  (defun ensure-list (list)
+    "If `list` is a list, it is returned. Otherwise returns the list designated by `list`."
+    (if (listp list)
+        list
+        (list list)))
+  
+
+  (declaim (inline maphash-keys))
+  (defun maphash-keys (function table)
+    "Like `maphash`, but calls `function` with each key in the hash table `table`."
+    (maphash (lambda (k v)
+               (declare (ignore v))
+               (funcall function k))
+             table))
+  
+
+  (defun hash-table-keys (table)
+    "Returns a list containing the keys of hash table `table`."
+    (let ((keys nil))
+      (maphash-keys (lambda (k)
+                      (push k keys))
+                    table)
+      keys))
+  
+
+  (defun mkstr (&rest args)
+    "Receives any number of objects (string, symbol, keyword, char, number), extracts all printed representations, and concatenates them all into one string.
+
+Extracted from _On Lisp_, chapter 4."
+    (with-output-to-string (s)
+      (dolist (a args) (princ a s))))
+  
+
+  (defmacro once-only (specs &body forms)
+    "Evaluates `forms` with symbols specified in `specs` rebound to temporary
+variables, ensuring that each initform is evaluated only once.
+
+Each of `specs` must either be a symbol naming the variable to be rebound, or of
+the form:
+
+    (symbol initform)
+
+Bare symbols in `specs` are equivalent to
+
+    (symbol symbol)
+
+Example:
+
+    (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
+      (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
+    (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
+          (names-and-forms (mapcar (lambda (spec)
+                                     (etypecase spec
+                                       (list
+                                        (destructuring-bind (name form) spec
+                                          (cons name form)))
+                                       (symbol
+                                        (cons spec spec))))
+                                   specs)))
+      ;; bind in user-macro
+      `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
+              gensyms names-and-forms)
+         ;; bind in final expansion
+         `(let (,,@(mapcar (lambda (g n)
+                             ``(,,g ,,(cdr n)))
+                           gensyms names-and-forms))
+            ;; bind in user-macro
+            ,(let ,(mapcar (lambda (n g) (list (car n) g))
+                    names-and-forms gensyms)
+               ,@forms)))))
+  
+
+  (defun rcurry (function &rest arguments)
+    "Returns a function that applies the arguments it is called
+with and `arguments` to `function`."
+    (declare (optimize (speed 3) (safety 1) (debug 1)))
+    (let ((fn (ensure-function function)))
+      (lambda (&rest more)
+        (declare (dynamic-extent more))
+        (multiple-value-call fn (values-list more) (values-list arguments)))))
+  
+
+  (declaim (inline remove/swapped-arguments))
+  (defun remove/swapped-arguments (sequence item &rest keyword-arguments)
+    (apply #'remove item sequence keyword-arguments))
+
+  (define-modify-macro removef (item &rest remove-keywords)
+    remove/swapped-arguments
+    "Modify-macro for `remove`. Sets place designated by the first argument to
+the result of calling `remove` with `item`, place, and the `keyword-arguments`.")
+  
+
+  (defun symb (&rest args)
+    "Receives any number of objects, concatenates all into one string with `#'mkstr` and converts them to symbol.
+
+Extracted from _On Lisp_, chapter 4.
+
+See also: `symbolicate`"
+    (values (intern (apply #'mkstr args))))
+  
+
+  (deftype string-designator ()
+    "A string designator type. A string designator is either a string, a symbol,
+or a character."
+    `(or symbol string character))
+  
+
+  (defmacro with-gensyms (names &body forms)
+    "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+    (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+    (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+    `(let ,(mapcar (lambda (name)
+                     (multiple-value-bind (symbol string)
+                         (etypecase name
+                           (symbol
+                            (values name (symbol-name name)))
+                           ((cons symbol (cons string-designator null))
+                            (values (first name) (string (second name)))))
+                       `(,symbol (gensym ,string))))
+            names)
+       ,@forms))
+
+  (defmacro with-unique-names (names &body forms)
+    "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+    (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+    (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+    `(with-gensyms ,names ,@forms))
+  
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export '(compose curry dohash ensure-boolean ensure-gethash ensure-list
+            hash-table-keys maphash-keys mkstr once-only rcurry removef symb
+            with-gensyms with-unique-names)))
+
+;;;; END OF quickutils.lisp ;;;;