diff --git a/doubly-linked-list.scm b/doubly-linked-list.scm index fa6bd20..8906f83 100644 --- a/doubly-linked-list.scm +++ b/doubly-linked-list.scm @@ -174,7 +174,7 @@ (dl:set-head! ctr next) #f) (if was-tail? - (dl:set-tail! ctr tail) + (dl:set-tail! ctr prev) #f)))) ;;; (DL:PUSH-LIST-BACK CTR LST) appends LST to CTR. diff --git a/miniscm/init.scm b/miniscm/init.scm index c3f5612..91abe72 100644 --- a/miniscm/init.scm +++ b/miniscm/init.scm @@ -114,3 +114,63 @@ (if (< (char->integer x) (char->integer y)) '< '>)))))) + +(define max + (lambda (curmax . rest) + (if (null? rest) + curmax + (let ((next-num (car rest))) + (apply max + (cons (if (> next-num curmax) next-num curmax) + (cdr rest))))))) + +(define all + (lambda (f l) + (cond + ((null? l) #t) + ((not (f (car l))) (all f (cdr l))) + (else #f)))) + +(define any + (lambda (f l) + (cond + ((null? l) #f) + ((f (car l)) #t) + (else (any f (cdr l)))))) + +(macro + cond-expand + (lambda (body) + (letrec + ((loop + (lambda (body) + (if (null? body) + #f + (let ((elem (car body))) + (cond + ((eqv? (car elem) 'else) + (cons 'begin (cdr elem))) + ((and (pair? elem) + (passes? (car elem))) + (cons 'begin (cdr elem))) + (else (loop (cdr body)))))))) + (passes? + (lambda (boolean-form) + (cond + ((eqv? boolean-form 'miniscm-unslisp) #t) + ((eqv? boolean-form 'r3rs) #t) + ((symbol? boolean-form) #f) + ((not (pair? boolean-form)) (error "invalid boolean form")) + ((eqv? (car boolean-form) 'and) + (all passes? (cdr boolean-form))) + ((eqv? (car boolean-form) 'or) + (any passes? (cdr boolean-form))) + ((eqv? (car boolean-form) 'not) + (not (passes? (cadr boolean-form)))) + (else (error "invalid boolean function")))))) + (loop (cdr body))))) + +(define (abs x) + (if (< x 0) + (- x) + x)) diff --git a/miniscm/miniscm.c b/miniscm/miniscm.c index e7597c9..6708a1a 100644 --- a/miniscm/miniscm.c +++ b/miniscm/miniscm.c @@ -79,7 +79,6 @@ * Define or undefine following symbols as you need. */ /* #define VERBOSE */ /* define this if you want verbose GC */ -#define VERBOSE #define AVOID_HACK_LOOP /* define this if your compiler is poor * enougth to complain "do { } while (0)" * construction. @@ -91,6 +90,8 @@ #define USE_MACRO /* undef this if you do not need macro */ #endif +#define USE_MACRO + #ifdef USE_QQUOTE /*-- * If your machine can't support "forward single quotation character" diff --git a/set.scm b/set.scm new file mode 100644 index 0000000..f43a19f --- /dev/null +++ b/set.scm @@ -0,0 +1,357 @@ +;;; Copyright (C) Peter McGoron 2024 +;;; This program is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, version 3 of the License. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see . + +;;; Persistent AVL sets and maps using JOIN. + +;;; ;;;;;;;;;;;;;;;; +;;; Nodes, direction +;;; ;;;;;;;;;;;;;;;; + +;;; Returns the slot number for +;;; =: The node data +;;; h: the height +;;; <: the left child +;;; >: the right child +(define %set:accessor + (lambda (sym) + (cond + ((eq? sym '=) 0) + ((eq? sym 'h) 1) + ((eq? sym '<) 2) + ((eq? sym '>) 3) + (else (error "invalid direction"))))) + +;;; Gets data from node value given accessor symbol. +(define %set:get + (lambda (t sym) + (vector-ref t (%set:accessor sym)))) + +(define %set->sexpr + (lambda (node) + (if (null? node) + '() + (list (list 'data (%set:get node '=)) + (list '< (%set->sexpr (%set:get node '<))) + (list '> (%set->sexpr (%set:get node '>))))))) + +;;; Get the height of a node, handling the empty node. +(define %set:height + (lambda (node) + (if (null? node) + 0 + (%set:get node 'h)))) + +;;; Get the difference between the heights of two trees. +(define %set:height-diff + (lambda (t1 t2) + (- (%set:height t1) (%set:height t2)))) + +;;; Get the balance factor of a tree. +(define %set:bal + (lambda (t) (%set:height-diff (%set:get t '<) + (%set:get t '>)))) + +;;; Set data in node given accessor symbol. +(define %set:set! + (lambda (node dir x) + (vector-set! node (%set:accessor dir) x))) + +;;; Construct a new tree with data VAL. +(define %set:node + (lambda (val dir1 node1 dir2 node2) + (let ((node (vector val (+ 1 + (max (%set:height node1) + (%set:height node2))) + '() '()))) + (%set:set! node dir1 node1) + (%set:set! node dir2 node2) + node))) + +(define %set:invdir + (lambda (dir) + (cond + ((eq? dir '<) '>) + ((eq? dir '>) '<) + (else (error "invalid direction"))))) + +;;; ;;;;;;;;;;;;;; +;;; Tree rotations +;;; ;;;;;;;;;;;;;; + +;;; Rotate NODE to the left (dir = '>) or right (dir = '<). +(define %set:rotate + (lambda (node dir) + (if (null? node) + #f + (let ((invdir (%set:invdir dir))) + (let ((child (%set:get node invdir))) + (let ((to-swap (%set:get child dir))) + (%set:node (%set:get child '=) + dir (%set:node (%set:get node '=) + dir (%set:get node dir) + invdir to-swap) + invdir (%set:get child invdir)))))))) + +;;; ;;;;;;;;;;;;;;;;;;; +;;; JOIN function for AVL trees. +;;; ;;;;;;;;;;;;;;;;;;; + +;;; Handles rebalancing of the tree. +(define %set:join + (lambda (heavier val lighter heavier-dir) + (let ((heavy-val (%set:get heavier '=)) + (lighter-dir (%set:invdir heavier-dir))) + (let ((heavy-heavy (%set:get heavier heavier-dir)) + (heavy-light (%set:get heavier lighter-dir))) + (if (<= (abs (%avl:diff heavy-light lighter) 1)) + (let ((node (%set:node val + heavier-dir heavy-light + lighter-dir lighter))) + (if (<= (abs (%set:bal node)) 1) + (%set:node heavy-val + heavier-dir heavy-heavy + lighter-dir node) + (%set:rotate (%set:node heavy-val + heavier-dir heavy-heavy + lighter-dir + (%set:rotate node lighter-dir)) + heavier-dir))) + (let ((new-light (%set:join heavy-light val lighter heavier-dir))) + (let ((node (%set:node heavy-val + heavier-dir heavy-heavy + lighter-dir new-light))) + (if (<= (abs (%set:bal node)) 1) + node + (%set:rotate node heavier-dir))))))))) + +;;; JOIN takes two trees and the data for a node, such that all nodes +;;; in LEFT are less than or equal to VAL, and all nodes in RIGHT are +;;; greater than or equal to VAL, and outputs a balanced binary search +;;; tree. +(define set:join + (lambda (left val right) + (let ((diff (%set:diff left right))) + (cond + ((> diff 1) (%set:join left val right '<)) + ((< diff -1) (%set:join right val left '>)) + (else (set:node val '< left '> right)))))) + +(define set:join2 + (letrec + ((join2 + (lambda (left right) + (if (null? left) + right + (let ((split-last-tree (split-last left))) + (set:join (bst:get split-last-tree '<) + (bst:get split-last-tree '=) + right))))) + (split-last + (lambda (tree) + (let ((right (set:get tree '>))) + (if (null? right) + tree + (let ((last (split-last right))) + (bst:node (set:get last '=) + (join (set:get tree '<) + (set:get tree '=) + (set:get last '<)) + '()))))))) + join2)) + +;;; ;;;;;;;;;;;;;;;;; +;;; Element functions +;;; ;;;;;;;;;;;;;;;;; + +;;; (SET:IN <=>) generates a search function for comparison function <=>. +;;; (SEARCH TREE DATA) searches TREE for a node that matches DATA. +;;; It will return the node that contains the matched DATA, or #F. +(define set:in + (lambda (<=>) + (lambda (tree data) + (letrec + ((loop + (lambda (tree) + (if (null? tree) + #f + (let ((dir (<=> (%set:get tree '=) data))) + (if (eq? dir '=) + tree + (loop (set:get tree dir)))))))) + (loop tree))))) + +;;; (SET:INSERT <=>) generates an insert function for comparison function +;;; <=>. +;;; (INSERT TREE NODE) inserts NODE into TREE. It returns +;;; (CONS NEWTREE FOUND), where FOUND is the node that was replaced by +;;; NODE, and #F otherwise, and NEWTREE is the new root of the tree. +(define set:insert + (lambda (<=>) + (lambda (tree node) + (let ((found #f)) + (letrec + ((loop + (lambda (tree) + (if (null? tree) + node + (let ((dir (<=> (%set:get tree '=) + (%set:get node '=))) + (left (%set:get tree '<)) + (right (%set:get tree '>))) + (if (eq? dir '=) + (begin + (set! found tree) + (set:node (set:get node '=) + '< left '> right)) + (join (set:node (%set:get tree '=) + dir (loop left) + (set:invdir dir) right)))))))) + (let ((newtree (loop tree))) + (cons newtree found))))))) + +;;; (SET:DELETE <=>) generates a delete function for comparison function +;;; <=>. +;;; (DELETE TREE DATA) deletes a node from TREE that compares equal to +;;; DATA. The function returns (CONS NEWTREE FOUND), where FOUND is the +;;; deleted node, or #F if not found, and NEWTREE is the root of the new +;;; tree. +(define set:delete + (lambda (<=>) + (lambda (tree node) + (let ((found #f)) + (letrec + ((loop + (lambda (tree) + (if (null? tree) + node + (let ((dir (<=> (%set:get tree '=) + (%set:get node '=))) + (left (%set:get tree '<)) + (right (%set:get tree '>))) + (if (eq? dir '=) + (begin + (set! found tree) + (set:join2 left right)) + (join (set:node (%set:get tree '=) + dir (loop left) + (set:invdir dir) right)))))))) + (let ((newtree (loop tree))) + (cons newtree found))))))) + +;;; ;;;;;;;;;;; +;;; For strings +;;; ;;;;;;;;;;; + +(cond-expand + ((not miniscm-unslisp) + (define (string<=> x y) + (cond + ((string? x y) '>) + (else '=))))) + +(define map:string<=> + (lambda (x y) + (string<=> (car x) (car y)))) + +(define %smap:insert (set:insert map:string<=>)) +(define smap:insert + (lambda (tree key val) + (%smap:insert tree (%set:node (cons key val) + '< '() + '> '())))) + +(define %smap:search (set:in map:string<=>)) +(define smap:search + (lambda (tree key) + (%smap:search tree (cons key '())))) + +(define %smap:delete (set:delete map:string<=>)) +(define smap:delete + (lambda (tree key) + (%smap:delete tree (%set:node (cons key '()) + '< '() '> '())))) + +(define smap:key + (lambda (node) (car (%set:get node '=)))) +(define smap:val + (lambda (node) (cdr (%set:get node '=)))) + +(define %set:tests + (list + (cons "rotate right" + (lambda () + (let ((right (%set:rotate (%set:node 1 + '< (%set:node 2 + '< (%set:node 3 + '< '() + '> '()) + '> (%set:node 4 + '< '() + '> '())) + '> (%set:node 5 '< '() '> '())) + '>))) + (cond + ((not (eqv? (%set:get right '=) 2)) "bad parent") + ((not (eqv? (%set:get (%set:get right '>) '=) 1)) "bad right child") + ((not (eqv? (%set:get (%set:get right '<) '=) 3)) "bad left child") + ((not (eqv? (%set:get (%set:get (%set:get right '>) '>) '=) 5)) + "bad right child of right child") + ((not (eqv? (%set:get (%set:get (%set:get right '>) '<) '=) 4)) + "bad left child of right child") + (else #t))))) + (cons "rotate left" + (lambda () + (let ((right (%set:rotate (%set:node 1 + '> (%set:node 2 + '< (%set:node 3 + '< '() + '> '()) + '> (%set:node 4 + '< '() + '> '())) + '< (%set:node 5 '< '() '> '())) + '<))) + (cond + ((not (eqv? (%set:get right '=) 2)) "bad parent") + ((not (eqv? (%set:get (%set:get right '>) '=) 4)) "bad right child") + ((not (eqv? (%set:get (%set:get right '<) '=) 1)) "bad left child") + ((not (eqv? (%set:get (%set:get (%set:get right '<) '>) '=) 3)) + "bad right child of left child") + ((not (eqv? (%set:get (%set:get (%set:get right '<) '<) '=) 5)) + "bad left child of left child") + (else #t))))) + (cons "insert then delete" + (lambda () + (let ((insert-return (smap:insert '() (string #\a) 5))) + (cond + ((not (pair? insert-return)) "invalid insert return") + ((cdr insert-return) "string found in empty tree") + (else + (let ((tree (car insert-return))) + (let ((found (smap:search tree (string #\a)))) + (cond + ((not found) "string not in tree") + ((not (equal? (smap:key tree) (string #\a))) + "returned key not equal to a") + ((not (equal? (smap:val tree) 5)) + "returned value not equal to 5") + (else + (let ((delete-return (smap:delete tree (string #\a)))) + (cond + ((not (pair? delete-return)) + "invalid delete return") + ((not (cdr delete-return)) "string not found") + ((not (eqv? (car delete-return) '())) + "returned tree not null") + (else #t)))))))))))))) diff --git a/tests.scm b/tests.scm index 717a0be..a7b4b67 100644 --- a/tests.scm +++ b/tests.scm @@ -48,10 +48,22 @@ (loop (cdr rest))))))))) (loop tests)))) +(define report-tests + (lambda (tests) + (let ((res (run-tests tests))) + (if (eq? res #t) + (display "passed") + (begin + (display "failed: ") + (display res)))) + (newline))) + (load "doubly-linked-list.scm") -(display "running doubly linked list tests") +(display "running doubly linked list tests: ") (newline) -(if (run-tests %dl:tests) - (display "doubly linked list tests: passed") - (display "doubly linked list tests: failed")) +(report-tests %dl:tests) + +(load "set.scm") +(display "running string BST-AVL tests") (newline) +(report-tests %set:tests)