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

Implement the a* algorithm

Browse Source
This commit is contained in:
Dane Johnson 2024-11-11 21:07:19 -06:00
parent d0967f0580
commit cd2a616ccb
2 changed files with 39 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
demo.scm
View File

@ -19,11 +19,18 @@
(cdr pair)))) (cdr pair))))
graph)) graph))
(define graph-generator (define djikstra-generator
(make-generator (make-generator
(lambda (yield) (lambda (yield)
(djikstra graph 90 9 (lambda (visited heap) (djikstra graph 90 9 (lambda (visited heap)
(yield (color-graph graph visited heap)))) (yield (color-graph graph visited heap))))
#f))) #f)))
(define a*-generator
(make-generator
(lambda (yield)
(a* graph 90 9 (lambda (visited heap)
(yield (color-graph graph visited heap))))
#f)))
(write-graphs-to-file "djikstra.webp" djikstra-generator)
(write-graphs-to-file "astar.webp" a*-generator)
(write-graphs-to-file "djikstra.webp" graph-generator)

42
graphgif.scm
View File

@ -4,6 +4,7 @@
(d-) (d-)
(srfi srfi-1) (srfi srfi-1)
(srfi srfi-9 gnu) (srfi srfi-9 gnu)
(srfi srfi-11)
(srfi srfi-43)) (srfi srfi-43))
(re-export (cairo-pattern-create-rgb . create-color)) (re-export (cairo-pattern-create-rgb . create-color))
@ -179,15 +180,6 @@
;; ALGORITHMS!!! ;; ;; ALGORITHMS!!! ;;
;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;
(define (lex< a b)
(cond
[(and (number? a) (number? b)) (< a b)]
[(and (null? a) (null? b)) #f]
[(and (pair? a) (null? b)) #f]
[(and (null? a) (pair? b)) #t]
[(= (car a) (car b)) (lex< (cdr a) (cdr b))]
[else (< (car a) (car b))]))
;; Heap algorithms ;; Heap algorithms
(define-public (heap-insert priority item heap) (define-public (heap-insert priority item heap)
(define (fix-up! i heap) (define (fix-up! i heap)
@ -196,7 +188,7 @@
(let* ([parent (quotient (1- i) 2)] (let* ([parent (quotient (1- i) 2)]
[i-priority (car (vector-ref heap i))] [i-priority (car (vector-ref heap i))]
[parent-priority (car (vector-ref heap parent))]) [parent-priority (car (vector-ref heap parent))])
(when (lex< 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)))))
@ -211,8 +203,8 @@
[right (1+ left)]) [right (1+ left)])
(if (< left len) (if (< left len)
(let ([min (if (< right len) (let ([min (if (< right len)
(argmin (compose car (partial vector-ref heap)) lex< i left right) (argmin (compose car (partial vector-ref heap)) < i left right)
(argmin (compose car (partial vector-ref heap)) lex< i left))]) (argmin (compose car (partial vector-ref heap)) < i left))])
(if (= min i) (if (= min i)
heap heap
(begin (begin
@ -246,6 +238,32 @@
(cons idx visited))]))) (cons idx visited))])))
(export djikstra) (export djikstra)
(define* (a* graph source sink #:optional update)
"Uses the Chebychev distance as a heuristic"
(define (chebychev idx)
(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 (list->vector (map (lambda (entry)
(cons (inf) (car entry)))
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)
(heap-insert (+ dist (chebychev edge) 1) edge heap))
(heap-pop heap)
(node-edges (assv-ref graph idx)))
(cons idx visited))])))
(export a*)
;;;;;;;;;;;; ;;;;;;;;;;;;
;; Output ;; ;; Output ;;
;;;;;;;;;;;; ;;;;;;;;;;;;