0a51cb856ebb — Linus Björnstam 5 years ago
Moved the data structures to a different repo
4 files changed, 1 insertions(+), 368 deletions(-)

M README.md
R mutable-heap/mutable-heap.scm => 
R pairing-heap/pairing-heap.scm => 
R persistent-fifo.scm => 
M README.md +1 -1
@@ 1,6 1,6 @@ 
 # Misc utilities
 
-These are just some misc scripts I put online in case someone finds them useful. They are all written for guile scheme, but should be easily portable across implementations.
+These are just some misc scripts I put online in case someone finds them useful. They are all written for guile scheme, but should be easily portable across implementations. See my data-structures repo for some data structure goodness
 
 
 # License

          
R mutable-heap/mutable-heap.scm =>  +0 -168
@@ 1,168 0,0 @@ 
-;; a pure r6rs mutable heap.
-
-;; Copyright 2017 Linus Björnstam
-;; This Source Code Form is subject to the terms of the Mozilla Public
-;; License, v. 2.0. If a copy of the MPL was not distributed with this
-;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(library (data 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))))))

          
R pairing-heap/pairing-heap.scm =>  +0 -86
@@ 1,86 0,0 @@ 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Copyright 2018 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.
-
-
-
-(library (pairing-heap)
-  (export
-   make-node
-   make-leaf
-   node?
-   node-empty?
-   node-merge
-   node-insert
-   node-min
-   node-delete-min
-   node-delete-min-and-inser
-   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))))))

          
R persistent-fifo.scm =>  +0 -113
@@ 1,113 0,0 @@ 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Copyright 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.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Yall should check out the following srfis before deciding to use this:
-;; srfi-134 (ideques): a generalisation of fifo/lifo that is persistent.
-;;                     as described by Chris Okasaki. If you only want a
-;;                     fifo, this library should be slightly faster, since it does
-;;                     not do any "balancing".
-;; srfi-117 (list-queues): a mutable general queue. Could be both fifo and lifo.
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; A persistent fifo. Enqueue operations are O(1), while dequeue is amortized O(1).
-;; It is a simple system of 2 lists, one of items available for dequeue with the next
-;; element to dequeue in it's car. The second list contains enqueued items where the
-;; car being the most recently enqueued. The worst case for a dequeue is then O(n)
-;; which entails a reverse of the enqueued items.
-;;
-;; pfifo-length, pfifo-merge, pfifo-fold, pfifo-map and pfifo-filter are all O(n)-ish
-;; as they just transverse the deq and (reverse enq).
-;;
-;; Now, as they say: "Take my clothes off, dip me in chocolate and throw me to the
-;; homophobes".
-
-(define-module (persistent-fifo)
-  #:use-module ((srfi srfi-1)
-                #:select (fold))
-  #:use-module (srfi srfi-8)
-  #:use-module (srfi srfi-9)
-  #:export (pfifo
-            pfifo-empty?
-            pfifo-length
-            pfifo-enqueue
-            pfifo-dequeue
-            pfifo-dequeue/pair
-            pfifo->list
-            pfifo-merge
-            pfifo-fold
-            pfifo-map
-            pfifo-filter))
-
-(define-record-type <pfifo>
-  (%make-pfifo enq deq)
-  pfifo?
-  (enq pfifo-get-enq)
-  (deq pfifo-get-deq))
-
-
-(define (pfifo . items)
-  (pfifo-enqueue (%make-pfifo '() items)))
-
-(define (pfifo-empty? pfifo)
-  (and (null? (pfifo-get-deq pfifo)) (null? (pfifo-get-enq pfifo))))
-
-;; Helper function so that I don't have to do (when (pfifo-empty? pf) ...)
-(define (check-pfifo pf)
-  (when (pfifo-empty? pf)
-    (error "Pfifo is empty" pf)))
-
-(define (pfifo-length pfifo)
-  (+ (length (pfifo-get-enq pfifo)) (length (pfifo-get-enq pfifo))))
-
-;; enqueues items in pfifo. items are enqueued front to back.
-;; It is faster to enqueue many items at once than to enqueue
-;; several items in separate pfifo-enqueue calls.
-(define (pfifo-enqueue pfifo . items)
-  (define enq (pfifo-get-enq pfifo))
-  (define new-enq (fold cons enq items))
-  (%make-pfifo new-enq (pfifo-get-deq pfifo)))
-
-;; Dequeues an element from the pfifo.
-;; returns 2 values: a new pfifo, the dequeued element.
-(define (pfifo-dequeue pfifo)
-  (check-pfifo pfifo)
-  (receive (enq deq)
-      (if (null? (pfifo-get-deq pfifo))
-          (values '() (reverse (pfifo-get-enq pfifo)))
-          (values (pfifo-get-enq pfifo) (pfifo-get-deq pfifo)))
-    (values (%make-pfifo enq (cdr deq)) (car deq))))
-
-(define (pfifo-dequeue/pair pfifo)
-  (call-with-values (lambda () (pfifo-dequeue pfifo)) cons))
-
-
-(define (pfifo->list pf)
-  (append (pfifo-get-deq pf) (reverse (pfifo-get-enq pf))))
-
-;; Merges the content of p2 into p1, by putting all of the elements in both p1 and p2
-;; in a new pfifo's deq. o(n)-ish. 
-(define (pfifo-merge p1 p2)
-  (%make-pfifo '() (append (pfifo-get-deq p1) (reverse (pfifo-get-enq p1))
-                           (pfifo-get-deq p2) (reverse (pfifo-get-deq p2)))))
-
-
-(define (pfifo-fold proc identity pf)
-  (define first-round (fold proc identity (pfifo-get-deq pf)))
-  (fold proc first-round (reverse (pfifo-get-enq pf))))
-
-
-(define (pfifo-map proc pf)
-  (check-pfifo pf)
-  (%make-pfifo '() (reverse (pfifo-fold (lambda (x acc) (cons (proc x) acc)) '() pf))))
-
-
-(define (pfifo-filter pred pf)
-  (check-pfifo pf)
-  (%make-pfifo '() (reverse (pfifo-fold (lambda (x acc) (if (pred x) (cons x acc) acc)) '() pf))))
-