peter
/
define-namespace
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

aatree and linked-list

This commit is contained in:
Peter McGoron 2024-07-29 21:18:46 -04:00
parent 5a5fbd861f
commit c18bee846d
7 changed files with 1577 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
README.rst
View File

@ -49,3 +49,13 @@ Differences from R7RS
* Namespace names are identifers, not lists. * Namespace names are identifers, not lists.
* Namespaces are Scheme objects. * Namespaces are Scheme objects.
* To import outside of namespaces, use IMPORT-FROM-NAMSPACE, not IMPORT. * To import outside of namespaces, use IMPORT-FROM-NAMSPACE, not IMPORT.
--------
Examples
--------
* ``srfi/srfi-1.scm`` is the reference implementation of SRFI-1 wrapped in
a namespace.
* ``examples/aatree.scm`` is an imperative binary tree implementation.
``examples/test-aatree.scm`` uses SRFI-64 to run some tests on the
implementation. Requires SRFI-9 and SRFI-11 (``let-values``).

4
define-namespace-5.scm
View File

@ -85,7 +85,3 @@
(syntax-rules () (syntax-rules ()
((import-from-namespace body ...) ((import-from-namespace body ...)
(%import-from-namespace '() body ...)))) (%import-from-namespace '() body ...))))
(import-from-namespace (only srfi-1 fold))
(fold (lambda (elem acc) (+ elem acc)) 0'(1 2 3 4 5))

232
examples/aatree.scm Normal file
View File

@ -0,0 +1,232 @@
;;;; Copyright (c) 2024, Peter McGoron
;;;;
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions
;;;; are met:
;;;;
;;;; 1) Redistributions of source code must retain the above copyright
;;;; notice, this list of conditions and the following disclaimer.
;;;; 2) Redistributions in binary form must reproduce the above copyright
;;;; notice, this list of conditions and the following disclaimer
;;;; in the documentation and/or other materials provided with the
;;;; distribution.
;;;;
;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
;;;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
;;;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
;;;; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
;;;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
;;;; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;;; POSSIBILITY OF SUCH DAMAGE.
;;;;
;;;; This implements functional balanced binary search trees (AA Trees).
;;;;
;;;; (NEW <=>) makes a new AA Tree root.
;;;; (<=> KEY1 KEY2) must return one of the symbols in '(< = >), which
;;;; denote that KEY1 is less than, equivalent to, or greater than KEY2.
;;;;
;;;; (SEARCH TREE KEY) searches the tree for the first node equivalent
;;;; to KEY. If successful, it returns (VALUES 'FOUND KEY VAL). Otherwise
;;;; it returns (VALUES 'NOT-FOUND '() '()).
;;;;
;;;; (INSERT TREE KEY VAL) inserts KEY into TREE with value VAL. If
;;;; a key equivalent to KEY is already in TREE, the old key is replaced with
;;;; KEY and the old value is replaced with VAL, and the function returns
;;;; (VALUES 'FOUND OLDKEY OLDVAL). If the value is not found, then
;;;; the function returns (VALUES 'NOT-FOUND OLDKEY OLDVAL).
;;;;
;;;; (DELETE TREE KEY) deletes the node equivalent to KEY, if it exists.
;;;; It returns
(define-namespace aatree
(begin
(define-record-type :aatree-node
(new-node key value left right level)
node?
(key get-key key-set!)
(value get-value value-set!)
(left get-left left-set!)
(right get-right right-set!)
(level get-level-raw level-set!))
(define-record-type :aatree
(%aatree <=> root)
aatree?
(<=> get-<=>)
(root get-root set-root!))
(define leaf '())
(define (new <=>) (%aatree <=> leaf))
(define leaf? null?)
(define (get-level r)
(if (leaf? r)
0
(get-level-raw r)))
; Option-like accessors
(define (maybe-right t)
(if (null? t)
leaf
(get-right t)))
(define (maybe-left t)
(if (null? t)
leaf
(get-left t)))
; right rotation
; a b
; / \ / \
; b c -> d a
; / \ / \
; d e e c
(define (skew A)
(let* ((B (maybe-left A))
(E (maybe-right B)))
(if (and (not (leaf? A))
(eq? (get-level B)
(get-level A)))
(begin
(right-set! B A)
(left-set! A E)
B)
A)))
; left rotation
; a c
; / \ / \
; b c -> a e
; / \ / \
; d e b d
;
(define (split A)
(let* ((C (maybe-right A))
(E (maybe-right C))
(D (maybe-left C)))
(if (and (not (leaf? A))
(not (leaf? C))
(eq? (get-level E)
(get-level A)))
(begin
(left-set! C A)
(right-set! A D)
(level-set! C (+ (get-level C) 1))
C)
A)))
(define (search* <=> tree key)
(if (leaf? tree)
(values 'not-found '() '())
(let ((nodekey (get-key tree)))
(case (<=> key nodekey)
((<) (search* <=> (get-left tree) key))
((>) (search* <=> (get-right tree) key))
((=) (values 'found nodekey (get-value tree)))))))
(define (search tree key) (search* (get-<=> tree) (get-root tree) key))
(define (insert* <=> node key val)
(if (leaf? node)
(values (new-node key val '() '() 1) 'not-found '() '())
(case (<=> key (get-key node))
((=) (let ((oldval (get-value node)))
(value-set! node val)
(values node 'found (get-key node) oldval)))
((<) (let-values (((newnode . rest)
(insert* <=> (get-left node) key val)))
(left-set! node newnode)
(apply values (cons (split (skew node)) rest))))
((>) (let-values (((newnode . rest)
(insert* <=> (get-right node) key val)))
(right-set! node newnode)
(apply values (cons (split (skew node)) rest))))
(else (error "comparision must return <, =, or >")))))
(define (insert tree key val)
(let-values (((new-root . rest) (insert* (get-<=> tree) (get-root tree) key val)))
(set-root! tree new-root)
(apply values rest)))
(define (delete* <=> tree key)
(if (leaf? tree)
(values tree 'not-found '() '())
(let ((process (lambda (t)
(if (leaf? t)
t
(let* ((level (get-level t))
(level-l (get-level (get-left t)))
(level-r (get-level (get-right t)))
(new-level (- level 1)))
(if (or (< level-l new-level)
(< level-r new-level))
(begin
(if (> level-r new-level)
(level-set! (get-right t)
(min level-r new-level)))
(level-set! t new-level)
(set! t (skew t))
(right-set! t (skew (get-right t)))
(right-set! (get-right t)
(skew (get-right (get-right t))))
(set! t (split t))
(right-set! t (split (get-right t)))))
t)))))
(case (<=> key (get-key tree))
((<) (let-values (((newnode . rest)
(delete* <=> (get-left tree) key)))
(left-set! tree newnode)
(apply values (cons (process tree) rest))))
((>) (let-values (((newnode . rest)
(delete* <=> (get-right tree) key)))
(right-set! tree newnode)
(apply values (cons (process tree) rest))))
((=) (letrec
((del-min (lambda (t)
(if (leaf? (get-left t))
(values (get-right t) 'found (get-key t)
(get-value t))
(let-values (((newnode . rest)
(del-min (get-left t))))
(if (leaf? (get-right t))
(error "imbalanced tree"))
(left-set! t newnode)
(apply values
(cons (process t) rest)))))))
(if (leaf? (get-right tree))
(if (not (leaf? (get-left tree)))
(error "imbalanced tree")
(values '() 'found (get-key tree) (get-value tree)))
(let-values (((newnode status key value)
(del-min (get-right tree)))
((oldvalue) (get-value tree))
((oldkey) (get-key tree)))
(key-set! tree key)
(value-set! tree value)
(right-set! tree newnode)
(values (process tree) status oldkey oldvalue)))))))))
(define (delete tree key)
(let-values (((new-root . rest) (delete* (get-<=> tree)
(get-root tree)
key)))
(set-root! tree new-root)
(apply values rest)))
(define (aatree->alist* node alist)
(if (leaf? node)
alist
(let ((alist-right (aatree->alist* (get-right node) alist)))
(aatree->alist* (get-left node)
(cons (cons (get-key node)
(get-value node))
alist-right)))))
(define (aatree->alist tree) (aatree->alist* (get-root tree) '()))
(define (alist->aatree* node <=> alist)
(if (null? alist)
node
(let ((pair (car alist)))
(let-values (((node . _)
(insert node <=>
(car pair)
(cdr pair))))
(alist->aatree* node (cdr alist) <=>)))))
(define (alist->aatree tree)
(alist->aatree* (get-root tree) (get-<=> tree) '())))
(export
aatree?
new
aatree->alist alist->aatree
search insert delete))

27
examples/linked-list.scm Normal file
View File

@ -0,0 +1,27 @@
(define-namespace linked-list
(define-record-type linked-list
(linked-list head tail)
linked-list?
(head get-head set-head!)
(tail get-tail set-tail!))
(define (new) (linked-list '() '()))
(define (empty? lst) (null? (get-head lst)))
(define (linked-list->list lst) (get-head lst))
(define (push-first lst val)
(let ((container (list val)))
(set-head! lst container)
(set-tail! list container)))
(define (push-head lst val)
(if (empty? lst)
(push-first lst val)
(set-head! lst (cons val (get-head lst)))))
(define (push-tail lst val)
(if (empty? lst)
(push-first lst val)
(let ((container (list val)))
(set-cdr! (get-tail lst) container)
(set-tail! lst container))))
(export new empty?
push-head push-tail
linked-list->list))

188
examples/test-aatree.scm Normal file
View File

@ -0,0 +1,188 @@
;;;; Copyright (c) 2024, Peter McGoron
;;;;
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions
;;;; are met:
;;;;
;;;; 1) Redistributions of source code must retain the above copyright
;;;; notice, this list of conditions and the following disclaimer.
;;;; 2) Redistributions in binary form must reproduce the above copyright
;;;; notice, this list of conditions and the following disclaimer
;;;; in the documentation and/or other materials provided with the
;;;; distribution.
;;;;
;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
;;;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
;;;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
;;;; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
;;;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
;;;; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;;; POSSIBILITY OF SUCH DAMAGE.
(load "../srfi/srfi-64.scm")
(load "../define-namespace-5.scm")
(load "aatree.scm")
(define (string<=> x y)
(if (string<? x y)
'<
(if (string=? x y)
'=
'>)))
(import-from-namespace
(only aatree aatree? aatree->alist)
(rename aatree
(new aatree/new)
(search aatree/search)
(insert aatree/insert)
(delete aatree/delete)))
(test-begin "AATree")
(test-begin "insert one")
(define tree (aatree/new string<=>))
(let-values (((status key value)
(aatree/insert tree "a" 1)))
(test-equal "insert status" 'not-found status)
(let-values (((status key value)
(aatree/search tree "a")))
(test-equal "search status" 'found status)
(test-equal "search key" "a" key)
(test-equal "search value" 1 value)))
(test-end "insert one")
(test-begin "insert many in order")
(define inspairs
'(("a" . 1) ("b" . 2) ("c" . 3) ("d" . 4) ("e" . 5) ("f" . 6)
("g" . 7) ("h" . 8) ("i" . 9) ("j" . 10) ("k" . 11) ("l" . 12)
("m" . 13) ("n" . 14) ("o" . 15) ("p" . 16) ("q" . 17) ("r" . 18)
("s" . 19) ("t" . 20) ("u" . 21) ("v" . 22) ("w" . 23) ("x" . 24)
("y" . 25) ("z" . 26)))
(define (fold-collect f start processed to-process)
(if (null? to-process)
start
(let ((new-elem (car to-process)))
(fold-collect f (f start new-elem processed)
(cons new-elem processed)
(cdr to-process)))))
(define (iter f l)
(if (pair? l)
(begin
(f (car l))
(iter f (cdr l)))))
(define (test-insert node pair searchlist)
(let-values (((status key value)
(aatree/insert node (car pair) (cdr pair))))
(test-equal "insert" 'not-found status)
(iter (lambda (pair)
(let ((key (car pair))
(val (cdr pair)))
(let-values (((status retkey retval)
(aatree/search node key)))
(test-equal "search status" 'found status)
(test-equal "search key" key retkey)
(test-equal "search value" val retval))))
searchlist)
node))
(define inserted-in-order
(fold-collect test-insert (aatree/new string<=>) '() inspairs))
(test-end "insert many in order")
(display "a\n")
;; Not possible to implement good randomin strictly portable R5RS scheme,
;; Shuffled using "shuf"
(test-begin "insert shuffled")
(define shuffled-list
'(("k" . 11)
("p" . 16)
("r" . 18)
("w" . 23)
("x" . 24)
("t" . 20)
("f" . 6)
("z" . 26)
("h" . 8)
("a" . 1)
("s" . 19)
("e" . 5)
("d" . 4)
("y" . 25)
("c" . 3)
("j" . 10)
("v" . 22)
("g" . 7)
("o" . 15)
("q" . 17)
("m" . 13)
("u" . 21)
("l" . 12)
("b" . 2)
("n" . 14)
("i" . 9)))
(fold-collect test-insert (aatree/new string<=>) '() shuffled-list)
(test-end "insert shuffled")
(test-begin "delete one")
(define tree (aatree/new string<=>))
(let-values (((status key value)
(aatree/insert tree "a" 1)))
(test-equal "insert status" 'not-found status)
(let-values (((status retkey retval)
(aatree/search tree "a")))
(test-equal "search 1 status" 'found status)
(test-equal "search 1 key" "a" retkey)
(test-equal "search 1 value" 1 retval)
(let-values (((status retkey retval)
(aatree/delete tree "a")))
(test-equal "delete status" 'found status)
(test-equal "delete key" "a" retkey)
(test-equal "delete value" 1 retval)
(let-values (((status . _)
(aatree/search tree "a")))
(test-equal "search 2 status" status 'not-found)))))
(test-end "delete one")
(define (test-delete tree deleted to-delete)
(if (pair? to-delete)
(let ((pair (car to-delete)))
(let-values (((status retkey retval)
(aatree/delete tree (car pair))))
(test-equal "delete status" 'found status)
(test-equal "delete key" (car pair) retkey)
(test-equal "delete value" (cdr pair) retval)
(iter (lambda (pair)
(let ((key (car pair)))
(let-values (((status . _)
(aatree/search tree key)))
(test-equal "deleted search" 'not-found status))))
(cons pair deleted))
(iter (lambda (pair)
(let ((key (car pair))
(val (cdr pair)))
(let-values (((status retkey retval)
(aatree/search tree key)))
(test-equal "to-delete search" 'found status)
(test-equal "to-delete search value" val retval)
(test-equal "to-delete search key" key retkey))))
(cdr to-delete))
(test-delete tree (cons pair deleted) (cdr to-delete))))))
(test-begin "insert and shuffled delete")
(test-delete inserted-in-order '() shuffled-list)
(test-end "insert and shuffled delete")
(test-end "AATree")

34
srfi/srfi-11.scm Normal file
View File

@ -0,0 +1,34 @@
(define-syntax let-values
(syntax-rules ()
((let-values (?binding ...) ?body0 ?body1 ...)
(let-values "bind" (?binding ...) () (begin ?body0 ?body1 ...)))
((let-values "bind" () ?tmps ?body)
(let ?tmps ?body))
((let-values "bind" ((?b0 ?e0) ?binding ...) ?tmps ?body)
(let-values "mktmp" ?b0 ?e0 () (?binding ...) ?tmps ?body))
((let-values "mktmp" () ?e0 ?args ?bindings ?tmps ?body)
(call-with-values
(lambda () ?e0)
(lambda ?args
(let-values "bind" ?bindings ?tmps ?body))))
((let-values "mktmp" (?a . ?b) ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
(let-values "mktmp" ?b ?e0 (?arg ... x) ?bindings (?tmp ... (?a x)) ?body))
((let-values "mktmp" ?a ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
(call-with-values
(lambda () ?e0)
(lambda (?arg ... . x)
(let-values "bind" ?bindings (?tmp ... (?a x)) ?body))))))
(define-syntax let*-values
(syntax-rules ()
((let*-values () ?body0 ?body1 ...)
(begin ?body0 ?body1 ...))
((let*-values (?binding0 ?binding1 ...) ?body0 ?body1 ...)
(let-values (?binding0)
(let*-values (?binding1 ...) ?body0 ?body1 ...)))))

1086
srfi/srfi-64.scm Normal file
View File

File diff suppressed because it is too large Load Diff