dane/graphgif
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

More naval gazing

Browse Source
This commit is contained in:
Dane Johnson 2024-11-19 12:01:07 -06:00
parent 3eb52aa430
commit b753c9ee9c
2 changed files with 8 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
demo.scm
View File

@ -1,11 +1,6 @@
(use-modules (graphgif) (use-modules (graphgif)
(srfi srfi-1)
(srfi srfi-43)
(ice-9 copy-tree)
(d-)) (d-))
(define red (create-color 1 0 0))
(define graph (define graph
(~> (generate-web 10 10) (~> (generate-web 10 10)
(remove-rect 10 1 3 6 3) (remove-rect 10 1 3 6 3)
@ -20,12 +15,12 @@
graph)) graph))
(define (make-graph-generator f) (define (make-graph-generator f)
(generator (generator
(f graph 90 9 (lambda (visited heap) (f graph 90 9
(yield (color-graph graph visited heap)))) (lambda (visited heap)
(yield (color-graph graph visited heap))))
#f)) #f))
(define djikstra-generator (make-graph-generator djikstra)) (define djikstra-generator (make-graph-generator djikstra))
(define a*-generator (make-graph-generator a*)) (define a*-generator (make-graph-generator a*))
(write-graphs-to-file "djikstra.webp" djikstra-generator) (write-graphs-to-file "djikstra.webp" djikstra-generator)
(write-graphs-to-file "astar.webp" a*-generator) (write-graphs-to-file "astar.webp" a*-generator)

9
graphgif.scm
View File

@ -5,17 +5,17 @@
(srfi srfi-9 gnu) (srfi srfi-9 gnu)
(srfi srfi-11) (srfi srfi-11)
(srfi srfi-43)) (srfi srfi-43))
(re-export (cairo-pattern-create-rgb . create-color))
;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;
;; Basic Drawing ;; ;; Basic Drawing ;;
;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;
(define-public pi 3.14159) ;; Good enough (define-public pi 3.14159) ;; Good enough
(define-public tau (* 2 pi)) (define-public tau (* 2 pi))
(define-public black (cairo-pattern-create-rgb 0 0 0)) (define-public black (cairo-pattern-create-rgb 0 0 0))
(define-public white (cairo-pattern-create-rgb 1 1 1)) (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> (define-immutable-record-type <node>
(node coords edges color) (node coords edges color)
@ -198,7 +198,8 @@
(when (< i-priority parent-priority) (when (< i-priority parent-priority)
(vector-swap! heap i parent)) (vector-swap! heap i parent))
(fix-up! parent heap)))) (fix-up! parent heap))))
(fix-up! (vector-length heap) (vector-append heap (vector (cons priority item))))) (fix-up! (vector-length heap)
(vector-append heap (vector (cons priority item)))))
(define-public (heap-peek heap) (define-public (heap-peek heap)
(if (vector-empty? heap) #f (vector-ref heap 0))) (if (vector-empty? heap) #f (vector-ref heap 0)))
@ -267,7 +268,7 @@
(when update (update visited heap)) (when update (update visited heap))
(iter (fold (iter (fold
(lambda (edge heap) (lambda (edge heap)
(heap-insert (+ dist (chebychev edge) 1) edge heap)) p (heap-insert (+ dist (chebychev edge) 1) edge heap))
(heap-pop heap) (heap-pop heap)
(node-edges (assv-ref graph idx))) (node-edges (assv-ref graph idx)))
(cons idx visited))]))) (cons idx visited))])))