fix set and trie, add compat COND-EXPAND for chez

This commit is contained in:
Peter McGoron 2024-09-05 03:03:22 -04:00
parent c510054119
commit 1e93de26d5
3 changed files with 223 additions and 26 deletions

49
chez-compat.scm Normal file
View File

@ -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 <https://www.gnu.org/licenses/>.
;;;
;;; 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 ...)))))

167
set.scm
View File

@ -34,7 +34,12 @@
;;; Gets data from node value given accessor symbol. ;;; Gets data from node value given accessor symbol.
(define set:get (define set:get
(lambda (t sym) (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 (define %set->sexpr
(lambda (node) (lambda (node)
@ -44,6 +49,50 @@
(list '< (%set->sexpr (set:get node '<))) (list '< (%set->sexpr (set:get node '<)))
(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. ;;; Get the height of a node, handling the empty node.
(define %set:height (define %set:height
(lambda (node) (lambda (node)
@ -123,7 +172,7 @@
(let ((node (%set:node val (let ((node (%set:node val
heavier-dir heavy-light heavier-dir heavy-light
lighter-dir lighter))) lighter-dir lighter)))
(if (<= (abs (%set:bal node)) 1) (if (<= (%set:height-diff node heavy-heavy) 1)
(%set:node heavy-val (%set:node heavy-val
heavier-dir heavy-heavy heavier-dir heavy-heavy
lighter-dir node) lighter-dir node)
@ -165,11 +214,56 @@
tree tree
(let ((last (split-last right))) (let ((last (split-last right)))
(%set:node (set:get last '=) (%set:node (set:get last '=)
(set:join (set:get tree '=) '< (set:join (set:get tree '=)
'< (set:get tree '<) '< (set:get tree '<)
'> (set:get last '>))))))))) '> (set:get last '>))
'> '())))))))
join2)) 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 ;;; Element functions
;;; ;;;;;;;;;;;;;;;;; ;;; ;;;;;;;;;;;;;;;;;
@ -185,7 +279,7 @@
(lambda (tree) (lambda (tree)
(if (null? tree) (if (null? tree)
'() '()
(let ((dir (<=> (set:get tree '=) data))) (let ((dir (<=> data (set:get tree '=))))
(if (eq? dir '=) (if (eq? dir '=)
tree tree
(loop (set:get tree dir)))))))) (loop (set:get tree dir))))))))
@ -203,8 +297,8 @@
(lambda (tree) (lambda (tree)
(if (null? tree) (if (null? tree)
(update node #f) (update node #f)
(let ((dir (<=> (set:get tree '=) (let ((dir (<=> (set:get node '=)
(set:get node '=)))) (set:get tree '=))))
(if (eq? dir '=) (if (eq? dir '=)
(update node tree) (update node tree)
(let ((invdir (%set:invdir dir))) (let ((invdir (%set:invdir dir)))
@ -236,19 +330,19 @@
;;; <=>. ;;; <=>.
;;; (DELETE TREE DATA) deletes a node from TREE that compares equal to ;;; (DELETE TREE DATA) deletes a node from TREE that compares equal to
;;; DATA. The function returns (CONS NEWTREE FOUND), where FOUND is the ;;; 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. ;;; tree.
(define set:delete (define set:delete
(lambda (<=>) (lambda (<=>)
(lambda (tree node) (lambda (tree node)
(let ((found #f)) (let ((found '()))
(letrec (letrec
((loop ((loop
(lambda (tree) (lambda (tree)
(if (null? tree) (if (null? tree)
node node
(let ((dir (<=> (set:get tree '=) (let ((dir (<=> (set:get node '=)
(set:get node '=)))) (set:get tree '=))))
(if (eq? dir '=) (if (eq? dir '=)
(begin (begin
(set! found tree) (set! found tree)
@ -313,6 +407,12 @@
(lambda (tree key) (lambda (tree key)
(delete tree (map:empty-node key '())))))) (delete tree (map:empty-node key '()))))))
(define map:split
(lambda (<=>) (set:split <=>)))
(define map:union
(lambda (split) (set:union split)))
;;; ;;;;;;;;;;; ;;; ;;;;;;;;;;;
;;; For strings ;;; For strings
;;; ;;;;;;;;;;; ;;; ;;;;;;;;;;;
@ -323,14 +423,16 @@
(cond (cond
((string<? x y) '<) ((string<? x y) '<)
((string>? x y) '>) ((string>? x y) '>)
(else '=))))) (else '=))))
(else #f))
(cond-expand (cond-expand
((and (not miniscm-unslisp) (not r7rs)) ((and (not miniscm-unslisp) (not r7rs))
(define (list-set! lst n val) (define (list-set! lst n val)
(if (= n 0) (if (= n 0)
(set-car! lst val) (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 map:string<=> (set:<=>-to-map string<=>))
(define %smap:update (set:update map:string<=>)) (define %smap:update (set:update map:string<=>))
@ -340,6 +442,9 @@
(define smap:search (map:search map:string<=>)) (define smap:search (map:search map:string<=>))
(define smap:delete (map:delete map:string<=>)) (define smap:delete (map:delete map:string<=>))
(define %smap:split (map:split map:string<=>))
(define smap:union (map:union %smap:split))
;;; ;;;;; ;;; ;;;;;
;;; Tests ;;; Tests
;;; ;;;;; ;;; ;;;;;
@ -358,7 +463,7 @@
(already-in (list-ref (car lst) 2))) (already-in (list-ref (car lst) 2)))
(let ((insert-return (f tree key val))) (let ((insert-return (f tree key val)))
(cond (cond
((and already-in (not (cdr insert-return))) ((and already-in (null? (cdr insert-return)))
"should have been found") "should have been found")
((and already-in (not (equal? already-in ((and already-in (not (equal? already-in
(map:val (cdr insert-return))))) (map:val (cdr insert-return)))))
@ -454,7 +559,16 @@
(list (string #\a #\b #\c) 1 #f) (list (string #\a #\b #\c) 1 #f)
(list (string #\a #\b #\d) 2 #f) (list (string #\a #\b #\d) 2 #f)
(list (string #\d #\e #\f) 3 #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) (display "insert all") (newline)
(let ((tree (%set:insert-all '() to-insert))) (let ((tree (%set:insert-all '() to-insert)))
(if (string? tree) (if (string? tree)
@ -498,4 +612,25 @@
(list (string #\a #\b #\c #\d #\e) 10 10))))) (list (string #\a #\b #\c #\d #\e) 10 10)))))
(if (string? res) (if (string? res)
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)))))))))

View File

@ -34,29 +34,37 @@
;;; ;;;;;;;;;; ;;; ;;;;;;;;;;
;;; Char tries ;;; 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:new cons)
(define trie:empty (trie:new #f '())) (define trie:empty (trie:new '() #f))
;;; Get the function inside of trie NODE.
(define trie:function (define trie:function
(lambda (node) (lambda (node)
(if (null? node) (if (null? node)
#f #f
(car node)))) (cdr node))))
(define %trie:set
;;; Get the backing set inside of trie NODE.
(define trie:backing
(lambda (node) (lambda (node)
(if (null? node) (if (null? node)
'() '()
(cdr node)))) (car node))))
;;; Insert STRING-AS-LIST into NODE with value FUNCTION. ;;; Insert STRING-AS-LIST into NODE with value FUNCTION.
(define trie:insert (define trie:insert
(lambda (node string-as-list function) (lambda (node string-as-list function)
(if (null? string-as-list) (if (null? string-as-list)
(trie:new function (%trie:set node)) (trie:new (trie:backing node) function)
(let ((ch (car string-as-list)) (let ((ch (car string-as-list))
(string-as-list (cdr 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) (lambda (node oldnode)
(if oldnode (if oldnode
(map:node-new-val (map:node-new-val
@ -70,12 +78,17 @@
trie:empty trie:empty
string-as-list string-as-list
function))))))) function)))))))
(trie:new (trie:function node) newtree)))))) (trie:new newtree (trie:function node)))))))
(define trie:insert-many (define trie:insert-many
(lambda (node lst) (lambda (node lst)
(fold (lambda (pair node) (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))) node lst)))
;;; Search for CH in NODE. ;;; Search for CH in NODE.
@ -83,7 +96,7 @@
(lambda (ch node) (lambda (ch node)
(if (null? node) (if (null? node)
'() '()
(let ((node (charmap:search (%trie:set node) ch))) (let ((node (charmap:search (trie:backing node) ch)))
(if (null? node) (if (null? node)
'() '()
(map:val node)))))) (map:val node))))))