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))))
-