255 lines
8 KiB
Scheme
255 lines
8 KiB
Scheme
;; -*- mode: scheme -*-
|
|
;;
|
|
;; basic layout attempts
|
|
;;
|
|
;; copyright (C) 2004 FoAM vzw
|
|
;; You are granted the rights to distribute and use this software
|
|
;; under the terms of the GNU Lesser General Public License as
|
|
;; published by the Free Software Foundation; either version 2.1 of
|
|
;; the License, or (at your option) any later version. The LGPL is
|
|
;; distributed with this code (see: LICENCE) and available online
|
|
;; at http://www.gnu.org/copyleft/lesser.html
|
|
|
|
;; authors
|
|
;; - nik gaffney <nik@fo.am>
|
|
;; - tim boykett <tim@timesup.org>
|
|
;; - dave griffiths <dave@pawfal.org>
|
|
|
|
;; requirements
|
|
;; - qfwfq and descendants
|
|
|
|
;; commentary
|
|
;; - wobble -> hierarchical rectangular spread
|
|
;; - shuffle -> randomise positions
|
|
;; - relax -> pseudo stabilisation using edge lengths
|
|
;; - circles -> concentric radial layout
|
|
;; - shadowpi -> variation on circular parent-centric splay
|
|
|
|
|
|
;; changes
|
|
;; 2006-09-11
|
|
;; - scraped into coherence from various sources
|
|
;; 2006-11-12
|
|
;; - mottled shadows, multiple beginning
|
|
;; 2006-11-26
|
|
;; - reshaping showdowpi with help from Dr Boykett
|
|
|
|
|
|
(module layout mzscheme
|
|
(require (lib "misc.ss" "swindle")
|
|
(lib "class.ss")
|
|
(lib "list.ss")
|
|
(lib "math.ss")
|
|
"scritch.scm"
|
|
"snipets.scm"
|
|
"graph.scm")
|
|
|
|
(provide wobble-tree
|
|
shuffle-tree
|
|
relax-tree
|
|
circles-tree
|
|
shadowpi-tree)
|
|
|
|
|
|
;;;;;; ; ; ;; ;;;; ;; ; ;;
|
|
;;
|
|
;; traverse from a node, and s p r e a d
|
|
;;
|
|
;;;;; ; ; ; ; ;
|
|
|
|
(define (wobble-tree node pb)
|
|
(let* ([parents (reverse (send node get-parents))]
|
|
[n (length parents)]
|
|
[x1 50]
|
|
[y1 30])
|
|
(debug 2 "~% node.~a " node)
|
|
(debug 2 "~% parents.~a " parents)
|
|
(send pb move node x1 y1)
|
|
(do ((i 0 (+ i 1)))
|
|
((= i n))
|
|
(debug 2 ".~a." i)
|
|
(let* ([parent (list-ref parents i)]
|
|
[nx (box 0)]
|
|
[ny (box 0)]
|
|
[loco (send pb get-snip-location node nx ny)])
|
|
(debug 2 ".[~a,~a]." (unbox nx) (unbox ny))
|
|
(send pb move-to parent
|
|
(+ (* i x1) (/ (unbox nx) n))
|
|
(+ y1 (unbox ny)))
|
|
(wobble-tree parent pb)))))
|
|
|
|
|
|
;;;;;;;;;;; ;; ; ;; ;
|
|
;;
|
|
;; autoslonk
|
|
;;
|
|
;;;;; ; ;; ;; ; ;
|
|
|
|
(define (shuffle-tree node pb x y)
|
|
(let ([parents (send node get-parents)]
|
|
[x1 200]
|
|
[y1 200])
|
|
(debug 2 "shuffling: ~a ~%" parents)
|
|
(send pb move node (random x1) (random y1))
|
|
(cond
|
|
((= 1 (length parents))
|
|
(shuffle-tree (car parents) pb (random x1) (random y1)))
|
|
((< 1 (length parents))
|
|
(for-each
|
|
(lambda (parent)
|
|
(shuffle-tree parent pb (random x1) (random y1)))
|
|
parents)))))
|
|
|
|
;;;;;;;;;;; ;; ; ;; ;
|
|
;;
|
|
;; circles-tree
|
|
;;
|
|
;; renders nodes on concentric circles centred on the root node.
|
|
;; each node is given a section of the circle with which to divide
|
|
;; between its parents. same algorithm used in fastbreeder for
|
|
;; visualising code trees generated by genetic programming
|
|
;;
|
|
;;;;; ; ;; ;; ; ;
|
|
|
|
(define (circles-tree node pb x y angle-start angle-end radius)
|
|
;; loop over all parents for this node
|
|
(define (parent-loop parents n angle-per-parent)
|
|
;; calculate the section of angles for this node, and call circles-tree for it
|
|
(let ([parent-start (+ angle-start (* angle-per-parent n))])
|
|
(circles-tree (car parents) pb x y parent-start (+ parent-start angle-per-parent) (+ radius 50)))
|
|
(if (not (null? (cdr parents)))
|
|
(parent-loop (cdr parents)
|
|
(+ n 1) angle-per-parent)))
|
|
|
|
;; position this in the middle of the range of angles we've been given
|
|
(send pb move node
|
|
(* (sin (+ angle-start (/ (- angle-end angle-start) 2))) radius)
|
|
(* (cos (+ angle-start (/ (- angle-end angle-start) 2))) radius))
|
|
|
|
;; now call parent-loop for the parents if we have any parents
|
|
(let ([parents (send node get-parents)])
|
|
(if (not (null? parents))
|
|
(let ([angle-per-parent (/ (- angle-end angle-start)
|
|
(length parents))])
|
|
(parent-loop parents 0 angle-per-parent)))))
|
|
|
|
|
|
|
|
;;;;; ;;;;;; ;; ; ;; ;
|
|
;;
|
|
;; energy stabilisation
|
|
;; - single iteration only, call as reqd.
|
|
;; - local epsilon & delta only
|
|
;;
|
|
;;;;; ; ;;; ; ;
|
|
|
|
(define (relax-tree node pb x y)
|
|
(let ([parents (send node get-parents)])
|
|
(debug 2 "minimising: ~a ~%" node)
|
|
;; move given node
|
|
(send pb move node x y)
|
|
;; stabilise distance between siblings
|
|
(if (not (empty? parents))
|
|
(for-each
|
|
(lambda (parent)
|
|
(let ([siblings (send parent get-children)])
|
|
(if(< 1 (length siblings))
|
|
(send pb move node
|
|
(shuffle-x node (random-ref siblings))
|
|
(shuffle-y node (random-ref siblings)))))) parents))
|
|
;; stabilise distance betwen node and parents
|
|
(cond
|
|
((= 1 (length parents))
|
|
(debug 1 "distance between ~a and ~a is ~a~%"
|
|
node (car parents) (distance node (car parents)))
|
|
(let ([parent (car parents)])
|
|
(relax-tree parent pb
|
|
(shuffle-x node parent)
|
|
(shuffle-y node parent))))
|
|
((< 1 (length parents))
|
|
(for-each
|
|
(lambda (parent)
|
|
(debug 1 "distance between ~a and ~a is ~a~%" node parent (distance node parent))
|
|
(relax-tree parent pb
|
|
(shuffle-x node parent)
|
|
(shuffle-y node parent))) parents)))))
|
|
|
|
(define (random-ref l)
|
|
(list-ref l (random (length l))))
|
|
|
|
(define (shuffle-x n1 n2)
|
|
(let ([x1 (snip-x n1)]
|
|
[x2 (snip-x n2)]
|
|
[epsilon 100]
|
|
[d 10])
|
|
(if (> epsilon (distance n1 n2))
|
|
(if (= x2 (max x1 x2)) ;; move outward
|
|
(random d)
|
|
(-ve (random d)))
|
|
(if (= x2 (max x1 x2)) ;; move inward
|
|
(-ve (random d))
|
|
(random d)))))
|
|
|
|
(define (shuffle-y n1 n2)
|
|
(let ([y1 (snip-y n1)]
|
|
[y2 (snip-y n2)]
|
|
[epsilon 100]
|
|
[d 10])
|
|
(if (> epsilon (distance n1 n2))
|
|
(if (= y2 (max y1 y2)) ;; move outward
|
|
(random d)
|
|
(-ve (random d)))
|
|
(if (= y2 (max y1 y2)) ;; move inward
|
|
(-ve (random d))
|
|
(random d)))))
|
|
|
|
(define (distance n1 n2)
|
|
(let ([x1 (snip-x n1)]
|
|
[x2 (snip-x n2)]
|
|
[y1 (snip-y n1)]
|
|
[y2 (snip-y n2)])
|
|
(sqrt (+ (sq (abs (- x1 x2)))
|
|
(sq (abs (- y1 y2)))))))
|
|
|
|
(define (sq n)
|
|
(* n n))
|
|
|
|
(define (-ve n)
|
|
(- 0 n))
|
|
|
|
|
|
;;;;;;;;;;; ;; ; ;; ;
|
|
;;
|
|
;; circular parent centric layout, in the shade of twopi
|
|
;;
|
|
;; ref: arxiv:cs.HC/0606007 v1 -> "A parent-centered radial layout algorithm
|
|
;; for interactive graph visualization and animation" by Andrew Pavlo,
|
|
;; Christopher Homan & Jonathan Schull
|
|
;;
|
|
;;;;; ; ;;; ; ;
|
|
|
|
(define twopi (* 2 pi))
|
|
|
|
(define (shadowpi-tree node pb theta r)
|
|
;; given a node from which to draw the layout, angle theta, radius, r
|
|
(let* ([parents (send node get-parents)]
|
|
[e (length parents)]
|
|
[xi (snip-x node)]
|
|
[yi (snip-y node)]
|
|
(b (/ pi (if (eq? e 0) 1 e))) ;; twopi -> full circle
|
|
(a (- (+ theta (/ pi 2)) (/ b 2)))
|
|
(r1 (* 2 r (sin (/ b 2)))))
|
|
|
|
;; distribute parents of given node evenly along a containment circle
|
|
;; centered on the node.
|
|
(for-each (lambda (parent)
|
|
(let ((x1 (+ xi (* r (cos a))))
|
|
(y1 (+ yi (* r (sin a)))))
|
|
(send pb move-to parent x1 y1)
|
|
(shadowpi-tree parent pb a r1)
|
|
(set! a (- a b))))
|
|
parents)))
|
|
|
|
) ;; end of module
|
|
|