peter
/
UNSLISP
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

169
set.scm
View File

@ -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) '<)
((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)))))))))

31
trie.scm
View File

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