share/graphs/spring_embedding.lisp

   1 ;;;
   2 ;;;  GRAPHS - graph theory package for Maxima
   3 ;;;
   4 ;;;  Copyright (C) 2007-2011 Andrej Vodopivec <andrej.vodopivec@gmail.com>
   5 ;;;
   6 ;;;  This program is free software; you can redistribute it and/or modify
   7 ;;;  it under the terms of the GNU General Public License as published by
   8 ;;;  the Free Software Foundation; either version 2 of the License, or
   9 ;;;  (at your option) any later version.
  10 ;;;
  11 ;;;  This program is distributed in the hope that it will be useful,
  12 ;;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;  GNU General Public License for more details.
  15 ;;;
  16 ;;;  You should have received a copy of the GNU General Public License
  17 ;;;  along with this program; if not, write to the Free Software
  18 ;;;  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA
  19 ;;;
  20
  21
  22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23 ;;;
  24 ;;; force-based graph embedding algorithm
  25 ;;;
  26 ;;; Based on:
  27 ;;; T.M.J. Fruchterman, E.M. Reingold, Graph drawing by force-directed
  28 ;;; placement, Software practice and experience 21 (1991), 11, 1129--1164.
  29 ;;;
  30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31
  32 (in-package :maxima)
  33
  34 (defvar *vertex-position*)
  35 (defvar *optimal-distance*)
  36
  37 (defvar *epsilon-distance* 0.5)
  38 (defvar *frame-width* 10.0)
  39
  40 (defvar *fixed-vertices* nil)
  41
  42 (defun attractive-force (d)
  43   (/ (* d d) *optimal-distance*))
  44
  45 (defun repulsive-force (d)
  46   (let ((d (max d *epsilon-distance*)))
  47     (/ (* *optimal-distance* *optimal-distance*) d 100)))
  48
  49 (defun distance (p1 p2)
  50   (let ((d (mapcar #'- p1 p2)))
  51     (sqrt (apply #'+ (mapcar #'* d d)))))
  52
  53 (defun random-positions (v-list dimension)
  54   (when *fixed-vertices*
  55     (let ((n (length *fixed-vertices*)))
  56       (dotimes (i (length *fixed-vertices*))
  57         (let ((v (nth i *fixed-vertices*))
  58               (x (* *frame-width* ($sin (/ (* 2 i pi) n))))
  59               (y (* *frame-width* ($cos (/ (* 2 i pi) n)))))
  60           (setf (gethash v *vertex-position*)
  61                 (list x y))))))
  62   (dolist (v v-list)
  63     (unless (member v *fixed-vertices*)
  64       (let* ((x (- *frame-width* (random (* 2 *frame-width*))))
  65              (y (- *frame-width* (random (* 2 *frame-width*))))
  66              (z (- *frame-width* (random (* 2 *frame-width*)))))
  67         (setf (gethash v *vertex-position*)
  68               (if (= dimension 3)
  69                   (list x y z)
  70                   (list x y)))))))
  71
  72 (defmfun $spring_embedding (g depth fixed-vertices dimension continue)
  73   (let ((*vertex-position* (make-hash-table))
  74         (vertex-displacement (make-hash-table))
  75         (*fixed-vertices* (cdr fixed-vertices))
  76         (*optimal-distance* (/ (* 2 *frame-width*)
  77                                (sqrt ($graph_order g)))))
  78
  79     ;; Start with current positions if we already have some.
  80     (if (and continue
  81              (> (length ($get_positions g)) 1)
  82              (= ($length ($first ($get_positions g))) dimension))
  83         (dolist (v (cdr ($get_positions g)))
  84           (setf (gethash (cadr v) *vertex-position*) (cdaddr v)))
  85         (random-positions (vertices g) dimension))
  86
  87     (let* ((step (/ *frame-width* 5))
  88            (d-step (/ step (1+ depth))))
  89       (dotimes (i depth)
  90         (setq step (- step d-step))
  91
  92         (dolist (v (vertices g))
  93           (setf (gethash v vertex-displacement) (if (= dimension 2) (list 0 0) (list 0 0 0))))
  94
  95         ;; calculate repulsive forces
  96         (when (null *fixed-vertices*)
  97           (let ((v-vrt (vertices g)))
  98             (loop while v-vrt do
  99                  (let* ((v (car v-vrt))
 100                         (u-vrt (cdr v-vrt))
 101                         (v-pos (gethash v *vertex-position*)))
 102                    (loop while u-vrt do
 103                         (let* ((u (car u-vrt))
 104                                (u-pos (gethash u *vertex-position*))
 105                                (delta (mapcar #'- v-pos u-pos))
 106                                (delta-abs (distance v-pos u-pos))
 107                                (force (repulsive-force delta-abs))
 108                                (vu-disp (mapcar
 109                                          #'(lambda (u) (* (/ u (max delta-abs *epsilon-distance*)) force))
 110                                          delta))
 111                                (v-disp (gethash v vertex-displacement))
 112                                (u-disp (gethash u vertex-displacement)))
 113                           (setf (gethash v vertex-displacement)
 114                                 (mapcar #'+ v-disp vu-disp)
 115                                 (gethash u vertex-displacement)
 116                                 (mapcar #'- u-disp vu-disp))
 117                           (setq u-vrt (cdr u-vrt)))))
 118                  (setq v-vrt (cdr v-vrt)))))
 119
 120         ;; calculate attractive forces
 121         (dolist (e (edges g))
 122           (let* ((v (first e))
 123                  (u (second e))
 124                  (v-pos (gethash v *vertex-position*))
 125                  (u-pos (gethash u *vertex-position*))
 126                  (delta (mapcar #'- v-pos u-pos))
 127                  (delta-abs (distance v-pos u-pos))
 128                  (v-disp (gethash v vertex-displacement))
 129                  (u-disp (gethash u vertex-displacement))
 130                  (force (attractive-force delta-abs))
 131                  (vu-disp (mapcar
 132                            #'(lambda (u)
 133                                (* (/ u (max delta-abs *epsilon-distance*)) force))
 134                            delta)))
 135             (setf (gethash v vertex-displacement)
 136                   (mapcar #'- v-disp vu-disp)
 137                   (gethash u vertex-displacement)
 138                   (mapcar #'+ u-disp vu-disp))))
 139
 140         ;; Limit the displacement
 141         (dolist (v (vertices g))
 142           (unless (member v *fixed-vertices*)
 143             (let* ((v-disp (gethash v vertex-displacement))
 144                    (v-disp (mapcar #'(lambda (u) (/ u 2)) v-disp))
 145                    (v-disp-abs (sqrt (apply #'+ (mapcar #'* v-disp v-disp))))
 146                    (v-pos (gethash v *vertex-position*)))
 147               (if (> v-disp-abs step)
 148                   (setq v-pos (mapcar #'(lambda (u v)
 149                                           (+ u (* (/ v v-disp-abs) step)))
 150                                       v-pos v-disp))
 151                   (setq v-pos (mapcar #'+ v-pos v-disp)))
 152               (setq v-pos (mapcar #'(lambda (u) (min *frame-width* (max u (- *frame-width*))))
 153                                   v-pos))
 154               (setf (gethash v *vertex-position*) v-pos))))
 155         ))
 156
 157     (let (result)
 158       (maphash #'(lambda (vrt pos)
 159                    (setq result
 160                          (cons `((mlist simp) ,vrt ((mlist simp) ,@pos))
 161                                result)))
 162                *vertex-position*)
 163       (cons '(mlist simp) result)) ))