graphgif/graphgif.scm

(define-module (graphgif))

(use-modules (cairo)
	     (srfi srfi-1)
	     (srfi srfi-9 gnu)
	     (srfi srfi-43))

(re-export (cairo-pattern-create-rgb . create-color))

;;;;;;;;;;;;;;;;;;;
;; Basic Drawing ;;
;;;;;;;;;;;;;;;;;;;

(define-public pi 3.14159)
(define-public tau (* 2 pi))

(define-public black (cairo-pattern-create-rgb 0 0 0))
(define-public white (cairo-pattern-create-rgb 1 1 1))

(define-immutable-record-type <node>
  (node coords edges color)
  node?
  (coords node-coords set-node-coords)
  (edges node-edges set-node-edges)
  (color node-color set-node-color))
(export node node?
	node-coords set-node-coords
	node-edges set-node-edges
	node-color set-node-color)

(define (edge-painter cr graph)
  (lambda (node)
    (cairo-set-source cr black)
    (let ([x (car (node-coords node))]
	  [y (cdr (node-coords node))]
	  [edges (node-edges node)])
      (for-each
       (lambda (edge)
	 (let* ([other (assq-ref graph edge)]
		[ox (car (node-coords other))]
		[oy (cdr (node-coords other))])
	   (cairo-move-to cr x y)
	   (cairo-line-to cr ox oy)
	   (cairo-stroke cr)))
       edges))))

(define (node-painter cr)
  (lambda (node)
    (let ([x (car (node-coords node))]
	  [y (cdr (node-coords node))]
	  [color (or (node-color node) white)])
      (cairo-arc cr x y 4. 0. tau)
      (cairo-set-source cr color)
      (cairo-fill-preserve cr)
      (cairo-set-source cr black)
      (cairo-stroke cr))))

(define-public (draw-abstract-graph graph)
  (let* ([surface (cairo-image-surface-create 'rgb24 400 400)]
	 [cr (cairo-create surface)])
    (define paint-edges (edge-painter cr graph))
    (define paint-nodes (node-painter cr))
    ;; White background
    (cairo-rectangle cr 0 0 400 400)
    (cairo-set-source cr white)
    (cairo-fill cr)
    (for-each paint-edges (map cdr graph))
    (for-each paint-nodes (map cdr graph))
    (cairo-destroy cr)
    surface))

;;;;;;;;;;;;;;;;;;;;;;
;; Graph Generation ;;
;;;;;;;;;;;;;;;;;;;;;;

(define (idx->x i w)
  (modulo i w))

(define (idx->y i w)
  (quotient i w))

(define (xy->idx x y w)
  (+ (* y w) x))

(define (idx->edges i w)
  (filter-map
   (lambda (offset)
     (let* ([x (idx->x i w)]
	    [y (idx->y i w)]
	    [ox (+ x (car offset))]
	    [oy (+ y (cdr offset))])
       (and
	(not (negative? ox))
	(not (negative? oy))
	(< ox w)
	(xy->idx ox oy w))))
   ;; Auto-connect these directions if legal indices
   '(( 0 . -1)
     (-1 .  0)
     (-1 . -1)
     (+1 . -1))))

(define-public (generate-web w h)
  (define (make-node i)
    (cons i
	  (node
	   (cons (+ (* 30 (idx->x i w)) 10)
		 (+ (* 30 (idx->y i w)) 10))
	   (idx->edges i w)
	   #f)))
  (let loop ([i 0]
	     [lst '()])
    (if (>= i (* w h))
	(reverse lst)
	(loop (1+ i) (cons (make-node i) lst)))))

(define-public (remove-rect graph w x1 y1 x2 y2)
  ;; Assumption is that is a graph generated by generate-web
  ;; and that it has not been re-indexed
  ;; x1 < x2, y1 < y2
  (define edges-to-remove
    (unfold (lambda (s) (> s (xy->idx x2 y2 w)))
	    identity
	    (lambda (s) (if (>= (idx->x s w) x2)
			    (xy->idx x1 (1+ (idx->y s w)) w)
			    (1+ s)))
	    (xy->idx x1 y1 w)))
  (filter-map
   (lambda (idx/node)
     (if (memq (car idx/node) edges-to-remove)
	 #f
	 (cons (car idx/node)
	       (set-node-edges (cdr idx/node)
			       (remove
				(lambda (edge) (memq edge edges-to-remove))
				(node-edges (cdr idx/node)))))))
   graph))

;;;;;;;;;;;;
;; Output ;;
;;;;;;;;;;;;

(define (output-to-file surfaces filename)
  (define pngdir (mkdtemp "/tmp/graphgif_XXXXXX"))
  (vector-for-each
   (lambda (i surface)
     (cairo-surface-write-to-png
      surface
      (string-append pngdir "/img-" (number->string i) ".png")))
   surfaces)
  (system* "ffmpeg" "-i" (string-append pngdir "/img-%d.png") "-r" "1" filename))

(define-public (write-graphs-to-file graphs filename)
  (output-to-file (vector-map (lambda (_ graph) (draw-abstract-graph graph)) graphs) filename))

;; Local Variables:
;; geiser-scheme-implementation: guile
;; End: