@@ 0,0 1,5 @@ 
+Various datastructures I have written during my scheming years. 
+
+Undocumented, but simple enough that you should be able to understand most of it.
+
+See each file for license info.

          

@@ 0,0 1,174 @@ 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Copyright 2018, 2019 Linus Björnstam
+;;
+;; Permission to use, copy, modify, and/or distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all source copies.
+;; The software is provided "as is", without any express or implied warranties.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; A mutable, vector-based heap for r6rs scheme.
+;; If you don't need immutability, this is a nice and fast option. 
+;; For very large heaps, consider using something that has better cache
+;; locality.
+
+(library (mutable-heap)
+  (export
+   make-mutable-heap
+   mutable-heap?
+   heap-empty?
+   heap-add!
+   heap-min
+   heap-delete-min!
+   heap-delete-min-and-insert!
+   heap-pop!
+   heap-pop-and-insert!
+   heap-merge!
+   list->heap
+   heap->list!)
+
+  (import (rnrs base)
+          (rnrs control)
+          (rnrs records syntactic))
+
+  (define def-val 0)
+  (define-record-type mutable-heap
+    (fields
+     (immutable comparator)
+     (mutable storage)
+     (mutable growth-factor)
+     (mutable first-empty))
+    (protocol
+     (lambda (new)
+       (case-lambda
+         [()
+          (new < (make-vector 1000 def-val) 2 1)]
+         [(capacity)
+          (new < (make-vector capacity def-val) 2 1)]
+         [(capacity comparator)
+          (new comparator (make-vector capacity def-val) 2 1)]
+         [(capacity comparator growth-factor)
+          (new comparator (make-vector capacity def-val) growth-factor 1)])))
+    (opaque #t))
+  
+  (define (prnt i)
+    (div i 2))
+  
+  (define (left i)
+    (* 2 i))
+  
+  (define (right i)
+    (+ 1 (* 2 i)))
+  
+  (define (heapify! hp i)
+    (define cmp (mutable-heap-comparator hp))
+    (define heap-last (mutable-heap-first-empty hp))
+    (define l (left i))
+    (define r (right i))
+
+    (define smallest i)
+
+    (when (and (< l heap-last)
+               (cmp (storage-ref hp l) (storage-ref hp i)))
+      (set! smallest l))
+
+    (when (and (< r heap-last)
+               (cmp (storage-ref hp r) (storage-ref hp smallest)))
+      (set! smallest r))
+
+    (unless (= i smallest)
+      (storage-swap! hp i smallest)
+      (heapify! hp smallest)))
+  
+  (define (heap-empty? hp)
+    (= 1 (mutable-heap-first-empty hp)))
+  
+  ;; adds x to the end of x and percolates it upwards
+  (define (heap-add! hp x)
+    (define cmp (mutable-heap-comparator hp))
+    (let loop ([pos (storage-add! hp x)])
+      (let ([prnt-pos (prnt pos)])
+        (when (and (< 1 pos) (cmp x (storage-ref hp prnt-pos)))
+          (storage-swap! hp pos prnt-pos)
+          (loop prnt-pos)))))
+  
+  (define (heap-min hp)
+    (when (heap-empty? hp)
+      (error 'heap-min "Heap is empty" hp))
+    (storage-ref hp 1))
+  
+  (define (heap-delete-min! hp)
+    (when (heap-empty? hp)
+      (error 'heap-delete-min! "heap is empty"))
+    (storage-set! hp 1 def-val)
+    (let ([new-first-empty (- (mutable-heap-first-empty hp) 1)])
+      (storage-swap! hp 1 new-first-empty)
+      (mutable-heap-first-empty-set! hp new-first-empty))
+    (heapify! hp 1))
+  
+  (define (heap-pop! hp)
+    (let ([res (heap-min hp)])
+      (heap-delete-min! hp)
+      res))
+
+  (define (heap-delete-min-and-insert! hp ins)
+    (storage-set! hp 1 ins)
+    (heapify! hp 1))
+
+  (define (heap-pop-and-insert! hp ins)
+    (let ([res (heap-min hp)])
+      (heap-delete-min-and-insert! hp ins)
+      res))
+
+  (define (heap-merge! h1 h2)
+    (unless (heap-empty? h2)
+      (heap-add! h1 (heap-pop! h2))
+      (heap-merge! h1 h2)))
+  
+  (define (list->heap lst)
+    (define hp (make-mutable-heap (length lst)))
+    (let loop ([lst lst])
+      (unless (null? lst)
+        (heap-add! hp (car lst))
+        (loop (cdr lst))))
+    hp)
+  
+  (define (heap->list! hp)
+    (let loop ([acc '()])
+      (if (heap-empty? hp)
+          (reverse acc)
+          (loop (cons (heap-pop! hp) acc)))))
+  
+  ;; For internal use
+  (define (storage-add! hp val)
+    (cond
+     [(>= (mutable-heap-first-empty hp) (vector-length (mutable-heap-storage hp)))
+      (grow-storage! hp)
+      (storage-add! hp val)]
+     [else
+      (let ([new-element-pos (mutable-heap-first-empty hp)])
+        (storage-set! hp new-element-pos val)
+        (mutable-heap-first-empty-set! hp (+ 1 new-element-pos))
+        new-element-pos)]))
+  
+  (define (grow-storage! hp)
+    (define newlen (* (vector-length (mutable-heap-storage hp)) (mutable-heap-growth-factor hp)))
+    (define new (make-vector newlen))
+    (vector-copy! (mutable-heap-storage hp) new 0 (vector-length (mutable-heap-storage hp)))
+    (mutable-heap-storage-set! hp new))
+  
+  (define (storage-ref hp i)
+    (vector-ref (mutable-heap-storage hp) i))
+  
+  (define (storage-set! hp pos val)
+    (vector-set! (mutable-heap-storage hp) pos val))
+  
+  (define (storage-swap! hp i1 i2)
+    (let ([temp (storage-ref hp i1)])
+      (storage-set! hp i1 (storage-ref hp i2))
+      (storage-set! hp i2 temp)))
+  
+  (define (vector-copy! from to start end)
+    (let loop ([i start])
+      (when (< i end)
+        (vector-set! to i (vector-ref from i))
+        (loop (+ i 1))))))

          

@@ 0,0 1,89 @@ 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Copyright 2018, 2019 Linus Björnstam
+;;
+;; Permission to use, copy, modify, and/or distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all source copies.
+;; The software is provided "as is", without any express or implied warranties.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; A pairing heap implementation. 
+;; All operations take a compare procedure as a first element.
+;; 
+;; The procedures you should be using are the ones starting with node-
+;; and list->node. 
+
+
+
+(library (pairing-heap)
+  (export
+   make-node
+   make-leaf
+   node?
+   node-empty?
+   node-merge
+   node-insert
+   node-min
+   node-delete-min
+   node-delete-min-and-insert
+   list->node node->list)
+  (import (rnrs))
+
+  (define-record-type leaf)
+  (define-record-type node
+    (fields
+     (immutable element)
+     (immutable subheaps))
+    (opaque #t))
+
+  (define (node-empty? h)
+    (leaf? h))
+
+  (define (merge-pairs cmp lst)
+    (cond
+     [(null? lst) (make-leaf)]
+     [(null? (cdr lst))
+      (car lst)]
+     [else
+      (node-merge cmp (node-merge cmp (car lst) (cadr lst))
+                  (merge-pairs cmp (cddr lst)))]))
+
+  (define (node-merge cmp h1 h2)
+    (cond
+     [(leaf? h1) h2]
+     [(leaf? h2) h1]
+     [(cmp (node-element h1) (node-element h2))
+      (make-node (node-element h1)
+                 (cons h2 (node-subheaps h1)))]
+     [else
+      (make-node (node-element h2)
+                 (cons h1 (node-subheaps h2)))]))
+
+  (define (node-insert cmp h val)
+    (node-merge cmp h (make-node val '())))
+
+  (define (node-min h)
+    (node-element h))
+
+  (define (node-delete-min cmp h)
+    (merge-pairs cmp (node-subheaps h)))
+
+  ;; For most other heap implementations, this operation
+  ;; can provide a huge speedup compared to first removing
+  ;; and then inserting. For a pairing heap, is does not really matter
+  ;; but it is included for ease of porting
+  (define (node-delete-and-insert cmp h val)
+    (merge-pairs cmp (cons (make-node val '()) (node-subheaps h))))
+
+  (define (list->node cmp lst)
+    (let loop ([n (make-leaf)]
+               [lst lst])
+      (if (null? lst)
+          n
+          (loop (node-insert cmp n (car lst)) (cdr lst)))))
+
+  (define (node->list cmp n)
+    (let loop ([n n]
+               [acc '()])
+      (if (leaf? n)
+          (reverse acc)
+          (loop (node-delete-min cmp n) (cons (node-min n) acc))))))