More naval gazing

.gitignore

@@ -1,4 +1,5 @@
 *.png
 *.gif
+*.webp
 cgif/libguilecgif.so
 cgif/config.scm

cgif.scm

@@ -1,5 +0,0 @@
-(define-module (cgif)
-  #:use-module (cgif config)
-  #:export (make-gif))
-
-(load-extension (in-vicinity installdir "libguilecgif") "init_cgif")

cgif/Makefile

@@ -1,14 +0,0 @@
-INSTALL = $(PWD)
-CFLAGS = `pkg-config --cflags guile-cairo cgif`
-LIBS = `pkg-config --libs guile-cairo cgif`
-
-all: libguilecgif.so config.scm
-
-libguilecgif.so: guile-cgif.c
-	$(CC) $(CFLAGS) -shared -fPIC -o $@ $^ $(LIBS)
-
-config.scm: config.scm.in
-	sed 's|INSTALLDIR|$(INSTALL)|' < $< > $@
-
-clean:
-	rm -rf libguilecgif.so config.scm

cgif/config.scm.in

@@ -1,4 +0,0 @@
-(define-module (cgif config)
-  #:export (installdir))
-
-(define installdir "INSTALLDIR")

cgif/guile-cgif.c

@@ -1,80 +0,0 @@
-#include <stdlib.h>
-#include <string.h>
-#include <guile-cairo.h>
-#include <cgif.h>
-
-
-const uint8_t PALETTE[] = {
-  0xFF, 0xFF, 0xFF, // WHITE
-  0x00, 0x00, 0x00, // BLACK
-  0xFF, 0x00, 0x00  // RED
-};
-
-#define CAIRO_RED   0x00FF0000
-#define CAIRO_BLACK 0x00000000
-
-void encode_frame(cairo_surface_t *surface, CGIF_FrameConfig *frameconfig) {
-  // TODO pull colors from cairo
-  size_t size = cairo_image_surface_get_width(surface) * cairo_image_surface_get_height(surface);
-  frameconfig->pLocalPalette = (uint8_t*) &PALETTE;
-  frameconfig->numLocalPaletteEntries = 3;
-  frameconfig->pImageData = (uint8_t*)calloc(size, sizeof(uint8_t));
-
-  if (cairo_image_surface_get_format(surface) == CAIRO_FORMAT_RGB24) {
-    uint32_t* pen = (uint32_t*) cairo_image_surface_get_data(surface);
-    for (size_t i = 0; i < size; i++) {
-      uint32_t cairo_color = pen[i];
-      switch (cairo_color & 0x00FFFFFF) {
-      case CAIRO_BLACK:
-	frameconfig->pImageData[i] = 1;
-	break;
-      case CAIRO_RED:
-	frameconfig->pImageData[i] = 2;
-	break;
-      }
-    }
-  }
-}
-
-void make_gif_inner(cairo_surface_t *frames[], size_t n_frames, const char* path) {
-  CGIF_Config cgif_config;
-  memset(&cgif_config, 0, sizeof(CGIF_Config));
-  cgif_config.path = path;
-  cgif_config.attrFlags = CGIF_ATTR_IS_ANIMATED | CGIF_ATTR_NO_GLOBAL_TABLE;
-  cgif_config.width = cairo_image_surface_get_width(frames[0]);
-  cgif_config.height = cairo_image_surface_get_height(frames[0]);
-
-  CGIF *cgif = cgif_newgif(&cgif_config);
-
-  for (size_t i = 0; i < n_frames; i++) {
-    cairo_surface_t *frame = frames[i];
-    // Flush pending writes
-    cairo_surface_flush(frame);
-
-    CGIF_FrameConfig cgif_frameconfig;
-    memset(&cgif_frameconfig, 0, sizeof(CGIF_FrameConfig));
-    cgif_frameconfig.attrFlags = CGIF_FRAME_ATTR_USE_LOCAL_TABLE;
-    cgif_frameconfig.delay = 100;
-
-    encode_frame(frame, &cgif_frameconfig);
-    cgif_addframe(cgif, &cgif_frameconfig);
-  }
-
-  cgif_close(cgif);
-}
-
-SCM make_gif(SCM frames, SCM path) {
-  size_t n_frames = scm_to_size_t(scm_length(frames));
-  cairo_surface_t **c_frames = (cairo_surface_t **) malloc(sizeof(cairo_surface_t*) * n_frames);
-  for (size_t i = 0; i < n_frames; i++) {
-    c_frames[i] = scm_to_cairo_surface(scm_list_ref(frames, scm_from_size_t(i)));
-  }
-  const char* c_path = scm_to_locale_string(path);
-
-  make_gif_inner(c_frames, n_frames, c_path);
-  return SCM_UNSPECIFIED;
-}
-
-void init_cgif() {
-  scm_c_define_gsubr("make-gif", 2, 0, 0, &make_gif);
-}

demo.scm

@@ -1,19 +1,26 @@
-(use-modules (graphgif))
+(use-modules (graphgif)
+	     (d-))
 
-(define red (create-color 1 0 0))
+(define graph
+  (~> (generate-web 10 10)
+      (remove-rect 10 1 3 6 3)
+      (remove-rect 10 6 3 6 7)))
 
-(define my-graph
+(define (color-graph graph visited heap)
-  `(((10 . 10) (1))
+  (map (lambda (pair)
-    ((30 . 20) () ,red)))
+	 (cons (car pair)
+	       (if (memq (car pair) visited)
+		   (set-node-color (cdr pair) red)
+		   (cdr pair))))
+       graph))
+(define (make-graph-generator f)
+  (generator
+   (f graph 90 9
+      (lambda (visited heap)
+	(yield (color-graph graph visited heap))))
+   #f))
 
-(define more-complex-graph
+(define djikstra-generator (make-graph-generator djikstra))
-  `(((10 . 10) ()) 
+(define a*-generator (make-graph-generator a*))
-    ((40 . 10) (0))
+(write-graphs-to-file "djikstra.webp" djikstra-generator)
-    ((25 . 25) (0 1))
+(write-graphs-to-file "astar.webp" a*-generator)
-    ((10 . 40) (0 2 4))
-    ((40 . 40) (1 2 3))))
-
-(let* ([graph1 (generate-web 10 10)]
-       [graph2 (list-copy graph1)])
-  (set-car! graph2 (append (car graph2) `(,red)))
-  (write-graphs-to-file (list graph1 graph2) "graph.gif"))

graphgif.scm

@@ -1,44 +1,53 @@
 (define-module (graphgif))
-
 (use-modules (cairo)
-	     (cgif)
+	     (d-)
-	     (srfi srfi-1))
+	     (srfi srfi-1)
-
+	     (srfi srfi-9 gnu)
-(re-export (cairo-pattern-create-rgb . create-color))
+	     (srfi srfi-11)
+	     (srfi srfi-43))
 
 ;;;;;;;;;;;;;;;;;;;
 ;; Basic Drawing ;;
 ;;;;;;;;;;;;;;;;;;;
 
-(define-public pi 3.14159)
+(define-public pi  3.14159) ;; Good enough
 (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-public red   (cairo-pattern-create-rgb 1 0 0))
+
+(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)
+  "Creates a closure that draws the edges of graph using cr"
   (lambda (node)
     (cairo-set-source cr black)
-    (let ([x (caar node)]
+    (let-values ([(x y) (car+cdr (node-coords node))]
-	  [y (cdar node)]
+		 [(edges) (node-edges node)])
-	  [edges (cadr node)])
       (for-each
        (lambda (edge)
-	 (let* ([other (list-ref graph edge)]
+	 (let*-values ([(other) (assq-ref graph edge)]
-		[ox (caar other)]
+		       [(ox oy) (car+cdr (node-coords other))])
-		[oy (cdar other)])
 	   (cairo-move-to cr x y)
 	   (cairo-line-to cr ox oy)
 	   (cairo-stroke cr)))
        edges))))
 
 (define (node-painter cr)
+  "Creates a closure that draws the nodes of graph using cr"
   (lambda (node)
-    (let ([x (caar node)]
+    (let-values ([(x y) (car+cdr (node-coords node))]
-	  [y (cdar node)]
+		 [(color) (or (node-color node) white)])
-	  [color (if (null? (cddr node))
-		     white
-		     (caddr node))])
       (cairo-arc cr x y 4. 0. tau)
       (cairo-set-source cr color)
       (cairo-fill-preserve cr)
@@ -46,6 +55,7 @@
       (cairo-stroke cr))))
 
 (define-public (draw-abstract-graph graph)
+  "Creates a cairo surface with graph drawn on it"
   (let* ([surface (cairo-image-surface-create 'rgb24 400 400)]
 	 [cr (cairo-create surface)])
     (define paint-edges (edge-painter cr graph))
@@ -54,30 +64,29 @@
     (cairo-rectangle cr 0 0 400 400)
     (cairo-set-source cr white)
     (cairo-fill cr)
-    (for-each paint-edges graph)
+    (for-each paint-edges (map cdr graph))
-    (for-each paint-nodes graph)
+    (for-each paint-nodes (map cdr graph))
     (cairo-destroy cr)
     surface))
 
-(define-public (write-graphs-to-file graphs filename)
-  (let ([surfaces (map draw-abstract-graph graphs)])
-    (make-gif surfaces filename)
-    (for-each (lambda (s) (cairo-surface-destroy s)) surfaces)))
-
 ;;;;;;;;;;;;;;;;;;;;;;
 ;; Graph Generation ;;
 ;;;;;;;;;;;;;;;;;;;;;;
 
 (define (idx->x i w)
+  "Given i and width w, returns the x value"
   (modulo i w))
 
 (define (idx->y i w)
+  "Given i and width w, returns the y value"
   (quotient i w))
 
 (define (xy->idx x y w)
+  "Returns the index of x y on width x in a linear buffer"
   (+ (* y w) x))
 
 (define (idx->edges i w)
+  "Returns the edges needed to fully connect i on graph width w"
   (filter-map
    (lambda (offset)
      (let* ([x (idx->x i w)]
@@ -90,23 +99,202 @@
 	(< ox w)
 	(xy->idx ox oy w))))
    ;; Auto-connect these directions if legal indices
-   '(( 0 . -1)
+   ;; This combined with forwards and back connections create a
-     (-1 .  0)
+   ;; fully connected graph
-     (-1 . -1)
+   '(( 0 . -1) ;; Above
-     (+1 . -1))))
+     (-1 .  0) ;; Right
+     (-1 . -1) ;; Right-above
+     (+1 . -1) ;; Left above
+     )))
+
+(define lset-unionq (partial lset-union eq?))
+
+(define (forward-connect node graph idx)
+  (cons idx
+	(set-node-edges
+	 node
+	 (lset-unionq
+	  (node-edges node)
+	  (fold (lambda (entry set)
+		  (if (memq idx (node-edges (cdr entry)))
+		      (cons (car entry) set)
+		      set))
+		'()
+		graph)))))
+
+(define (back-connect edges graph idx)
+  (map
+   (lambda (entry)
+     (cons (car entry)
+	   (if (memq (car entry) edges)
+	       (set-node-edges
+		(cdr entry)
+		(lset-unionq (node-edges (cdr entry)) `(,idx)))
+	       (cdr entry))))
+   graph))
+
+(define-public (connect-bidirectionally graph)
+  "Takes a directed graph and connects all edges to make it fully bidirectional"
+  (if (null? graph) '()
+      (let* ([idx (caar graph)]
+	     [node (cdar graph)])
+	(cons (forward-connect node (cdr graph) idx)
+	      (back-connect
+	       (node-edges node)
+	       (connect-bidirectionally (cdr graph))
+	       idx)))))
 
 (define-public (generate-web w h)
+  "Creates a fully connected graph of width w and height h"
   (define (make-node i)
-    (list
+    (cons i
-     (cons (+ (* 30 (idx->x i w)) 10)
+	  (node
-	   (+ (* 30 (idx->y i w)) 10))
+	   (cons (+ (* 30 (idx->x i w)) 10)
-     (idx->edges i w)))
+		 (+ (* 30 (idx->y i w)) 10))
+	   (idx->edges i w)
+	   #f)))
   (let loop ([i 0]
 	     [lst '()])
     (if (>= i (* w h))
-	(reverse lst)
+	(connect-bidirectionally (reverse lst))
 	(loop (1+ i) (cons (make-node i) lst)))))
 
-;; Local Variables:
+(define-public (remove-rect graph w x1 y1 x2 y2)
-;; geiser-scheme-implementation: guile
+  "Removes a rectangular section of a fully connected rectangular graph"
-;; End:
+  ;; 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))
+
+;;;;;;;;;;;;;;;;;;;
+;; ALGORITHMS!!! ;;
+;;;;;;;;;;;;;;;;;;;
+
+(define-public (heap-insert priority item heap)
+  (define (fix-up! i heap)
+    (if (zero? i)
+	heap
+	(let* ([parent (quotient (1- i) 2)]
+	       [i-priority (car (vector-ref heap i))]
+	       [parent-priority (car (vector-ref heap parent))])
+	  (when (< i-priority parent-priority)
+	    (vector-swap! heap i parent))
+	  (fix-up! parent heap))))
+  (fix-up! (vector-length heap)
+	   (vector-append heap (vector (cons priority item)))))
+
+(define-public (heap-peek heap)
+  (if (vector-empty? heap) #f (vector-ref heap 0)))
+
+(define-public (heap-pop heap)
+  (define (fix-down! heap i)
+    (let* ([len (vector-length heap)]
+	   [left (1+ (* 2 i))]
+	   [right (1+ left)])
+      (if (< left len)
+	  (let ([min (if (< right len)
+			 (argmin (compose car (partial vector-ref heap)) < i left right)
+			 (argmin (compose car (partial vector-ref heap)) < i left))])
+	    (if (= min i)
+		heap
+		(begin
+		  (vector-swap! heap i min)
+		  (fix-down! heap min))))
+	  heap)))
+  (if (or (vector-empty? heap) (= (vector-length heap) 1))
+      #()
+      (let ([new-heap (vector-copy heap 0 (1- (vector-length heap)))])
+	(vector-set! new-heap 0 (vector-ref heap (1- (vector-length heap))))
+	(fix-down! new-heap 0))))
+
+(define (make-inf-queue graph)
+  "Creates a heap of the graph where all priorities are +inf"
+  (list->vector
+   (map (lambda (entry)
+	  (cons (inf) (car entry)))
+	graph)))
+
+(define* (djikstra graph source sink #:optional update)
+  (define unvisited (make-inf-queue graph))
+  (let iter ([heap (heap-insert 0 source unvisited)]
+	     [visited '()])
+    (define-values (dist idx) (car+cdr (heap-peek heap)))
+    (cond
+     [(eqv? sink idx) dist]
+     [(memv idx visited) (iter (heap-pop heap) visited)]
+     [(inf? dist) #f]
+     [else
+      (when update (update visited heap))
+      (iter (fold
+	     (lambda (edge heap)
+	       (heap-insert (+ dist 1) edge heap))
+	     (heap-pop heap)
+	     (node-edges (assv-ref graph idx)))
+	    (cons idx visited))])))
+(export djikstra)
+
+(define* (a* graph source sink #:optional update)
+  (define (chebychev idx) ;; Uses the Chebychev distance as a heuristic
+    (let-values ([(x1 y1) (car+cdr (node-coords (assv-ref graph idx)))]
+		 [(x2 y2) (car+cdr (node-coords (assv-ref graph sink)))])
+      (max (abs (- x1 x2)) (abs (- y1 y2)))))
+  (define unvisited (make-inf-queue graph))
+  (let iter ([heap (heap-insert (chebychev source) source unvisited)]
+	     [visited '()])
+    (define-values (dist idx) (car+cdr (heap-peek heap)))
+    (cond
+     [(eqv? sink idx) dist]
+     [(memv idx visited) (iter (heap-pop heap) visited)]
+     [(inf? dist) #f]
+     [else
+      (when update (update visited heap))
+      (iter (fold
+	     (lambda (edge heap)
+p	       (heap-insert (+ dist (chebychev edge) 1) edge heap))
+	     (heap-pop heap)
+	     (node-edges (assv-ref graph idx)))
+	    (cons idx visited))])))
+(export a*)
+
+;;;;;;;;;;;;
+;; Output ;;
+;;;;;;;;;;;;
+
+(define (output-to-file filename surface-gen)
+  "Takes a filename and a coroutine to generate surfaces, and creates an animation"
+  (define pngdir (mkdtemp "/tmp/graphgif_XXXXXX"))
+  (let loop ([surface (surface-gen)]
+	     [i 1])
+    (when surface
+      (cairo-surface-write-to-png
+       surface
+       (string-append pngdir "/img-" (number->string i) ".png"))
+      (loop (surface-gen) (1+ i))))
+  (system* "ffmpeg" "-y"
+	   "-i" (string-append pngdir "/img-%d.png")
+	   "-loop" "0" filename))
+
+(define-public (write-graphs-to-file filename graph-gen)
+  "Takes a filename and a couroutine to generate graphs, and creates an animation"
+  (define (surface-gen)
+    (let ([graph (graph-gen)])
+      (and graph (draw-abstract-graph graph))))
+  (output-to-file filename surface-gen))

test.scm

@@ -0,0 +1,20 @@
+(use-modules (rnrs base)
+	     (d-)
+	     (graphgif))
+
+(begin
+  (display "Testing heap operations...")
+  (newline)
+  (let ([heap (~>> #()
+		   (heap-insert (inf) 1)
+		   (heap-insert (inf) 2)
+		   (heap-insert (inf) 3)
+		   (heap-insert 0 1))])
+    (assert (equal? (heap-peek heap) '(0 . 1)))
+    (set! heap (heap-insert 1 2 (heap-pop heap)))
+    (assert (equal? (heap-peek heap) '(1 . 2)))
+    (set! heap (heap-insert 3 3 heap))
+    (assert (equal? (heap-peek heap) '(1 . 2)))
+    (assert (equal? (heap-peek (heap-pop heap)) '(3 . 3))))
+  (assert (equal? (heap-pop #((0 . 0))) #()))
+  (assert (equal? (heap-peek (heap-pop (heap-pop #((1 . 1) (1 . 10) (+inf.0 . 2) (+inf.0 . 3) (1 . 11))))) '(1 . 11))))