diff --git a/chez-compat.scm b/chez-compat.scm new file mode 100644 index 0000000..39cb31a --- /dev/null +++ b/chez-compat.scm @@ -0,0 +1,49 @@ +;;; 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 . +;;; +;;; Simple COND-EXPAND using SYNTAX-RULES. Designed for chez. + +(define-syntax cond-expand-conditional + (syntax-rules (and or not chez r6rs) + ;; Defined keywords + ((cond-expand-conditional chez execute alt) execute) + ((cond-expand-conditional r6rs execute alt) execute) + ;; Conditional statements: AND + ((cond-expand-conditional (and e1 e2 ...) execute alt) + (cond-expand-conditional e1 + (cond-expand-conditional + (and e2 ...) + execute + alt) + alt)) + ((cond-expand-conditional (and) execute alt) execute) + ;; OR + ((cond-expand-conditional (or e1 e2 ...) execute alt) + (cond-expand-conditional e1 execute + (cond-expand-conditional + (or e2 ...) execute alt))) + ((cond-expand-conditional (or) execute alt) alt) + ;; NOT + ((cond-expand-conditional (not e) execute alt) + (cond-expand-conditional e alt execute)) + ;; All other conditions + ((cond-expand-conditional unknown execute alt) alt))) + +(define-syntax cond-expand + (syntax-rules (else) + ((cond-expand (else evaluated ...)) (begin evaluated ...)) + ((cond-expand (conditional evaluated ...) rest ...) + (cond-expand-conditional conditional + (begin evaluated ...) + (cond-expand rest ...))))) + diff --git a/set.scm b/set.scm index c5f4e90..d00d96f 100644 --- a/set.scm +++ b/set.scm @@ -34,7 +34,12 @@ ;;; Gets data from node value given accessor symbol. (define set:get (lambda (t sym) - (vector-ref t (%set:accessor sym)))) + (let ((acc (%set:accessor sym))) + (if (null? t) + (cond + ((eq? sym 'h) 0) + (else '())) + (vector-ref t (%set:accessor sym)))))) (define %set->sexpr (lambda (node) @@ -44,6 +49,50 @@ (list '< (%set->sexpr (set:get node '<))) (list '> (%set->sexpr (set:get node '>))))))) +(cond-expand + (chicken + (import (chicken process)) + (define (set:display set) + (call-with-output-pipe + "dot -T png > /tmp/dot.png" + (lambda (out) + (letrec + ((D + (lambda (o) + (display o out) + (display o))) + (dump-data + (lambda (tree) + (D "\"") + (D (set:get tree '=)) + (D "\""))) + (connect + (lambda (parent child) + (if (null? child) + '() + (begin + (dump-data parent) + (D " -> ") + (dump-data child) + (D " ;\n") + (loop child))))) + (loop + (lambda (parent) + (if (null? parent) + '() + (begin + (connect parent (set:get parent '<)) + (connect parent (set:get parent '>))))))) + (D "digraph t {\n") + (loop set) + (D "}\n")))) + (system "imv-wayland /tmp/dot.png"))) + (else + (define set:display + (lambda (set) + (display (%set->sexpr set)) + (newline))))) + ;;; Get the height of a node, handling the empty node. (define %set:height (lambda (node) @@ -123,7 +172,7 @@ (let ((node (%set:node val heavier-dir heavy-light lighter-dir lighter))) - (if (<= (abs (%set:bal node)) 1) + (if (<= (%set:height-diff node heavy-heavy) 1) (%set:node heavy-val heavier-dir heavy-heavy lighter-dir node) @@ -165,11 +214,56 @@ tree (let ((last (split-last right))) (%set:node (set:get last '=) - (set:join (set:get tree '=) - '< (set:get tree '<) - '> (set:get last '>))))))))) + '< (set:join (set:get tree '=) + '< (set:get tree '<) + '> (set:get last '>)) + '> '()))))))) join2)) +(define set:split + (lambda (<=>) + (letrec + ((split + (lambda (set data) + (if (null? set) + (%set:node #f '< '() '> '()) + (let ((set-data (set:get set '=))) + (let ((dir (<=> data set-data))) + (if (eq? dir '=) + (set:node-new-val set #t) + (let ((new-tree (split (set:get set dir) data)) + (invdir (%set:invdir dir))) + (%set:node (set:get new-tree '=) + dir (set:get new-tree dir) + invdir (set:join set-data + dir (set:get new-tree invdir) + invdir (set:get set invdir))))))))))) + split))) + +;;; ;;;;;;;;;;;;; +;;; Set functions +;;; ;;;;;;;;;;;;; + +;;; Generate union operation from split operation. +;;; Union prioritizes data in PRIORITY over keys in SECONDARY. +(define set:union + (lambda (split) + (letrec + ((union + (lambda (priority secondary) + (cond + ((null? priority) secondary) + ((null? secondary) priority) + (else + (let ((key (set:get priority '=))) + (let ((split-tree (split secondary key))) + (set:join key + '< (union (set:get priority '<) + (set:get split-tree '<)) + '> (union (set:get priority '>) + (set:get split-tree '>)))))))))) + union))) + ;;; ;;;;;;;;;;;;;;;;; ;;; Element functions ;;; ;;;;;;;;;;;;;;;;; @@ -185,7 +279,7 @@ (lambda (tree) (if (null? tree) '() - (let ((dir (<=> (set:get tree '=) data))) + (let ((dir (<=> data (set:get tree '=)))) (if (eq? dir '=) tree (loop (set:get tree dir)))))))) @@ -203,8 +297,8 @@ (lambda (tree) (if (null? tree) (update node #f) - (let ((dir (<=> (set:get tree '=) - (set:get node '=)))) + (let ((dir (<=> (set:get node '=) + (set:get tree '=)))) (if (eq? dir '=) (update node tree) (let ((invdir (%set:invdir dir))) @@ -236,19 +330,19 @@ ;;; <=>. ;;; (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 +;;; deleted node, or NULL if not found, and NEWTREE is the root of the new ;;; tree. (define set:delete (lambda (<=>) (lambda (tree node) - (let ((found #f)) + (let ((found '())) (letrec ((loop (lambda (tree) (if (null? tree) node - (let ((dir (<=> (set:get tree '=) - (set:get node '=)))) + (let ((dir (<=> (set:get node '=) + (set:get tree '=)))) (if (eq? dir '=) (begin (set! found tree) @@ -313,6 +407,12 @@ (lambda (tree key) (delete tree (map:empty-node key '())))))) +(define map:split + (lambda (<=>) (set:split <=>))) + +(define map:union + (lambda (split) (set:union split))) + ;;; ;;;;;;;;;;; ;;; For strings ;;; ;;;;;;;;;;; @@ -323,14 +423,16 @@ (cond ((string? x y) '>) - (else '=))))) + (else '=)))) + (else #f)) (cond-expand ((and (not miniscm-unslisp) (not r7rs)) (define (list-set! lst n val) (if (= n 0) (set-car! lst val) - (list-set! (cdr lst) (- n 1) val))))) + (list-set! (cdr lst) (- n 1) val)))) + (else #f)) (define map:string<=> (set:<=>-to-map string<=>)) (define %smap:update (set:update map:string<=>)) @@ -340,6 +442,9 @@ (define smap:search (map:search map:string<=>)) (define smap:delete (map:delete map:string<=>)) +(define %smap:split (map:split map:string<=>)) +(define smap:union (map:union %smap:split)) + ;;; ;;;;; ;;; Tests ;;; ;;;;; @@ -358,7 +463,7 @@ (already-in (list-ref (car lst) 2))) (let ((insert-return (f tree key val))) (cond - ((and already-in (not (cdr insert-return))) + ((and already-in (null? (cdr insert-return))) "should have been found") ((and already-in (not (equal? already-in (map:val (cdr insert-return))))) @@ -454,7 +559,16 @@ (list (string #\a #\b #\c) 1 #f) (list (string #\a #\b #\d) 2 #f) (list (string #\d #\e #\f) 3 #f) - (list (string #\1 #\2 #\3 #\a #\C) 4 #f)))) + (list (string #\1 #\2 #\3 #\a #\C) 4 #f) + (list (string #\q #\w #\e) 5 #f) + (list (string #\1 #\2 #\3) 5 #f) + (list (string #\l #\i #\s #\p) 6 #f) + (list (string #\c) 7 #f) + (list (string #\s #\c #\m) 8 #f) + (list (string #\a #\l #\g #\o #\l) 9 #f) + (list (string #\a #\s #\m) 10 #f) + (list (string #\4) 11 #f) + (list (string #\a #\s #\m #\e) 12 #f)))) (display "insert all") (newline) (let ((tree (%set:insert-all '() to-insert))) (if (string? tree) @@ -498,4 +612,25 @@ (list (string #\a #\b #\c #\d #\e) 10 10))))) (if (string? res) res - #t))))))))) + #t))))))) + (cons "union a few" + (lambda () + (let ((tree1 (%set:insert-all '() + (list + (list (string #\a) 1 #f) + (list (string #\b) 2 #f) + (list (string #\c) 3 #f)))) + (tree2 (%set:insert-all '() + (list + (list (string #\c) 4 #f) + (list (string #\d) 5 #f) + (list (string #\e) 6 #f))))) + (let ((tree (smap:union tree1 tree2)) + (to-search (list + (list (string #\a) 1 1) + (list (string #\b) 2 2) + (list (string #\c) 3 3) + (list (string #\d) 5 5) + (list (string #\e) 6 6)))) + (not (string? (%set:search-all tree to-search))))))))) + diff --git a/trie.scm b/trie.scm index 1e70e37..c384e12 100644 --- a/trie.scm +++ b/trie.scm @@ -34,29 +34,37 @@ ;;; ;;;;;;;;;; ;;; Char tries +;;; +;;; Tries are pairs, CAR = backing map from chars to trie nodes, and +;;; CDR = function tied to this part of the trie. ;;; ;;;;;;;;;; +;;; (TRIE:NEW TABLE FUNCTION) (define trie:new cons) -(define trie:empty (trie:new #f '())) +(define trie:empty (trie:new '() #f)) + +;;; Get the function inside of trie NODE. (define trie:function (lambda (node) (if (null? node) #f - (car node)))) -(define %trie:set + (cdr node)))) + +;;; Get the backing set inside of trie NODE. +(define trie:backing (lambda (node) (if (null? node) '() - (cdr node)))) + (car node)))) ;;; Insert STRING-AS-LIST into NODE with value FUNCTION. (define trie:insert (lambda (node string-as-list function) (if (null? string-as-list) - (trie:new function (%trie:set node)) + (trie:new (trie:backing node) function) (let ((ch (car string-as-list)) (string-as-list (cdr string-as-list))) - (let ((newtree (charmap:update (%trie:set node) ch + (let ((newtree (charmap:update (trie:backing node) ch (lambda (node oldnode) (if oldnode (map:node-new-val @@ -70,12 +78,17 @@ trie:empty string-as-list function))))))) - (trie:new (trie:function node) newtree)))))) + (trie:new newtree (trie:function node))))))) (define trie:insert-many (lambda (node lst) (fold (lambda (pair node) - (trie:insert node (string->list (car pair)) (cdr pair))) + (let ((key (car pair))) + (let ((key (cond + ((list? key) key) + ((string? key) (string->list key)) + ((char? key) (list key))))) + (trie:insert node key (cdr pair))))) node lst))) ;;; Search for CH in NODE. @@ -83,7 +96,7 @@ (lambda (ch node) (if (null? node) '() - (let ((node (charmap:search (%trie:set node) ch))) + (let ((node (charmap:search (trie:backing node) ch))) (if (null? node) '() (map:val node))))))