Initial data commit
This commit is contained in:
Ingy döt Net
parent
72d218235f
commit
f23f22d71c
199087 changed files with 3378941 additions and 0 deletions
|
|
@ -0,0 +1,11 @@
|
|||
;; Create an associative array (hash-table) whose keys are strings:
|
||||
(define table (hash-table 'string=?
|
||||
'("hello" . 0) '("world" . 22) '("!" . 999)))
|
||||
|
||||
;; Iterate over the table, passing the key and the value of each entry
|
||||
;; as arguments to a function:
|
||||
(hash-table-for-each
|
||||
table
|
||||
;; Create by "partial application" a function that accepts 2 arguments,
|
||||
;; the key and the value:
|
||||
(pa$ format #t "Key = ~a, Value = ~a\n"))
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
;; Iterate over the table and create a list of the keys and the
|
||||
;; altered values:
|
||||
(hash-table-map
|
||||
table
|
||||
(lambda (key val) (list key (+ val 5000))))
|
||||
|
||||
;; Create a new table that has the same keys but altered values.
|
||||
(use gauche.collection)
|
||||
(map-to <hash-table>
|
||||
(lambda (k-v) (cons (car k-v) (+ (cdr k-v) 5000)))
|
||||
table)
|
||||
|
|
@ -0,0 +1,407 @@
|
|||
(cond-expand
|
||||
(r7rs)
|
||||
(chicken (import r7rs)))
|
||||
|
||||
(define-library (suspendable-procedures)
|
||||
|
||||
(export &fail failure? success? suspend fail-forever
|
||||
make-generator-procedure)
|
||||
|
||||
(import (scheme base))
|
||||
|
||||
(begin
|
||||
|
||||
(define-record-type <&fail>
|
||||
(make-the-one-unique-&fail-that-you-must-not-make-twice)
|
||||
do-not-use-this:&fail?)
|
||||
|
||||
(define &fail
|
||||
(make-the-one-unique-&fail-that-you-must-not-make-twice))
|
||||
|
||||
(define (failure? f) (eq? f &fail))
|
||||
(define (success? f) (not (failure? f)))
|
||||
(define *suspend* (make-parameter (lambda (x) x)))
|
||||
(define (suspend v) ((*suspend*) v))
|
||||
(define (fail-forever)
|
||||
(let loop ()
|
||||
(suspend &fail)
|
||||
(loop)))
|
||||
|
||||
(define (make-generator-procedure thunk)
|
||||
;; This is for making a suspendable procedure that takes no
|
||||
;; arguments when resumed. The result is a simple generator of
|
||||
;; values.
|
||||
(define (next-run return)
|
||||
(define (my-suspend v)
|
||||
(set! return (call/cc (lambda (resumption-point)
|
||||
(set! next-run resumption-point)
|
||||
(return v)))))
|
||||
(parameterize ((*suspend* my-suspend))
|
||||
(suspend (thunk))
|
||||
(fail-forever)))
|
||||
(lambda () (call/cc next-run)))
|
||||
|
||||
)) ;; end library (suspendable-procedures)
|
||||
|
||||
(define-library (avl-trees)
|
||||
;;
|
||||
;; Persistent (that is, ‘immutable’) AVL trees for R7RS Scheme.
|
||||
;;
|
||||
;; References:
|
||||
;;
|
||||
;; * Niklaus Wirth, 1976. Algorithms + Data Structures =
|
||||
;; Programs. Prentice-Hall, Englewood Cliffs, New Jersey.
|
||||
;;
|
||||
;; * Niklaus Wirth, 2004. Algorithms and Data Structures. Updated
|
||||
;; by Fyodor Tkachov, 2014.
|
||||
;;
|
||||
|
||||
(export avl-make-generator)
|
||||
(export avl avl? avl-empty? avl-insert avl-search-values)
|
||||
(export avl-check-usage)
|
||||
|
||||
(import (scheme base))
|
||||
(import (scheme case-lambda))
|
||||
(import (scheme process-context))
|
||||
(import (scheme write))
|
||||
(import (suspendable-procedures))
|
||||
|
||||
(begin
|
||||
|
||||
(define-syntax avl-check-usage
|
||||
(syntax-rules ()
|
||||
((_ pred msg)
|
||||
(or pred (usage-error msg)))))
|
||||
|
||||
(define-record-type <avl>
|
||||
(%avl key data bal left right)
|
||||
avl?
|
||||
(key %key)
|
||||
(data %data)
|
||||
(bal %bal)
|
||||
(left %left)
|
||||
(right %right))
|
||||
|
||||
(define avl-make-generator
|
||||
(case-lambda
|
||||
((tree) (avl-make-generator tree 1))
|
||||
((tree direction)
|
||||
(if (negative? direction)
|
||||
(make-generator-procedure
|
||||
(lambda ()
|
||||
(define (traverse p)
|
||||
(unless (or (not p) (avl-empty? p))
|
||||
(traverse (%right p))
|
||||
(suspend (cons (%key p) (%data p)))
|
||||
(traverse (%left p)))
|
||||
&fail)
|
||||
(traverse tree)))
|
||||
(make-generator-procedure
|
||||
(lambda ()
|
||||
(define (traverse p)
|
||||
(unless (or (not p) (avl-empty? p))
|
||||
(traverse (%left p))
|
||||
(suspend (cons (%key p) (%data p)))
|
||||
(traverse (%right p)))
|
||||
&fail)
|
||||
(traverse tree)))))))
|
||||
|
||||
(define (avl) (%avl #f #f #f #f #f))
|
||||
|
||||
(define (avl-empty? tree)
|
||||
(avl-check-usage
|
||||
(avl? tree)
|
||||
"avl-empty? expects an AVL tree as argument")
|
||||
(not (%bal tree)))
|
||||
|
||||
(define (avl-search-values pred<? tree key)
|
||||
(define (search p)
|
||||
(if (not p)
|
||||
(values #f #f)
|
||||
(let ((k (%key p)))
|
||||
(cond ((pred<? key k) (search (%left p)))
|
||||
((pred<? k key) (search (%right p)))
|
||||
(else (values (%data p) #t))))))
|
||||
(avl-check-usage
|
||||
(procedure? pred<?)
|
||||
"avl-search-values expects a procedure as first argument")
|
||||
(if (avl-empty? tree)
|
||||
(values #f #f)
|
||||
(search tree)))
|
||||
|
||||
(define (avl-insert pred<? tree key data)
|
||||
(define (search p fix-balance?)
|
||||
(cond
|
||||
((not p)
|
||||
(values (%avl key data 0 #f #f) #t))
|
||||
((pred<? key (%key p))
|
||||
(let-values (((p1 fix-balance?)
|
||||
(search (%left p) fix-balance?)))
|
||||
(cond
|
||||
((not fix-balance?)
|
||||
(let ((p^ (%avl (%key p) (%data p) (%bal p)
|
||||
p1 (%right p))))
|
||||
(values p^ #f)))
|
||||
(else
|
||||
(case (%bal p)
|
||||
((1)
|
||||
(let ((p^ (%avl (%key p) (%data p) 0
|
||||
p1 (%right p))))
|
||||
(values p^ #f)))
|
||||
((0)
|
||||
(let ((p^ (%avl (%key p) (%data p) -1
|
||||
p1 (%right p))))
|
||||
(values p^ fix-balance?)))
|
||||
((-1)
|
||||
(case (%bal p1)
|
||||
((-1)
|
||||
(let* ((p^ (%avl (%key p) (%data p) 0
|
||||
(%right p1) (%right p)))
|
||||
(p1^ (%avl (%key p1) (%data p1) 0
|
||||
(%left p1) p^)))
|
||||
(values p1^ #f)))
|
||||
((0 1)
|
||||
(let* ((p2 (%right p1))
|
||||
(bal2 (%bal p2))
|
||||
(p^ (%avl (%key p) (%data p)
|
||||
(- (min bal2 0))
|
||||
(%right p2) (%right p)))
|
||||
(p1^ (%avl (%key p1) (%data p1)
|
||||
(- (max bal2 0))
|
||||
(%left p1) (%left p2)))
|
||||
(p2^ (%avl (%key p2) (%data p2) 0
|
||||
p1^ p^)))
|
||||
(values p2^ #f)))
|
||||
(else (internal-error))))
|
||||
(else (internal-error)))))))
|
||||
|
||||
((pred<? (%key p) key)
|
||||
(let-values (((p1 fix-balance?)
|
||||
(search (%right p) fix-balance?)))
|
||||
(cond
|
||||
((not fix-balance?)
|
||||
(let ((p^ (%avl (%key p) (%data p) (%bal p)
|
||||
(%left p) p1)))
|
||||
(values p^ #f)))
|
||||
(else
|
||||
(case (%bal p)
|
||||
((-1)
|
||||
(let ((p^ (%avl (%key p) (%data p) 0
|
||||
(%left p) p1)))
|
||||
(values p^ #f)))
|
||||
((0)
|
||||
(let ((p^ (%avl (%key p) (%data p) 1
|
||||
(%left p) p1)))
|
||||
(values p^ fix-balance?)))
|
||||
((1)
|
||||
(case (%bal p1)
|
||||
((1)
|
||||
(let* ((p^ (%avl (%key p) (%data p) 0
|
||||
(%left p) (%left p1)))
|
||||
(p1^ (%avl (%key p1) (%data p1) 0
|
||||
p^ (%right p1))))
|
||||
(values p1^ #f)))
|
||||
((-1 0)
|
||||
(let* ((p2 (%left p1))
|
||||
(bal2 (%bal p2))
|
||||
(p^ (%avl (%key p) (%data p)
|
||||
(- (max bal2 0))
|
||||
(%left p) (%left p2)))
|
||||
(p1^ (%avl (%key p1) (%data p1)
|
||||
(- (min bal2 0))
|
||||
(%right p2) (%right p1)))
|
||||
(p2^ (%avl (%key p2) (%data p2) 0
|
||||
p^ p1^)))
|
||||
(values p2^ #f)))
|
||||
(else (internal-error))))
|
||||
(else (internal-error)))))))
|
||||
(else
|
||||
(values (%avl key data (%bal p) (%left p) (%right p))
|
||||
#f))))
|
||||
(avl-check-usage
|
||||
(procedure? pred<?)
|
||||
"avl-insert expects a procedure as first argument")
|
||||
(if (avl-empty? tree)
|
||||
(%avl key data 0 #f #f)
|
||||
(let-values (((p fix-balance?) (search tree #f)))
|
||||
p)))
|
||||
|
||||
(define (internal-error)
|
||||
(display "internal error\n" (current-error-port))
|
||||
(emergency-exit 123))
|
||||
|
||||
(define (usage-error msg)
|
||||
(display "Procedure usage error:\n" (current-error-port))
|
||||
(display " " (current-error-port))
|
||||
(display msg (current-error-port))
|
||||
(newline (current-error-port))
|
||||
(exit 1))
|
||||
|
||||
)) ;; end library (avl-trees)
|
||||
|
||||
|
||||
(define-library (associative-arrays)
|
||||
;;
|
||||
;; Persistent associative ‘arrays’ for R7RS Scheme.
|
||||
;;
|
||||
;; The structure is not actually an array, but is made of AVL trees
|
||||
;; and association lists. Given a good hash function, it should
|
||||
;; average logarithmic performance.
|
||||
;;
|
||||
|
||||
(export assoc-array-make-pair-generator
|
||||
assoc-array-make-key-generator
|
||||
assoc-array-make-data-generator)
|
||||
(export assoc-array assoc-array? assoc-array-set assoc-array-ref)
|
||||
|
||||
(import (scheme base))
|
||||
(import (scheme case-lambda))
|
||||
(import (scheme write))
|
||||
(import (suspendable-procedures))
|
||||
(import (avl-trees))
|
||||
|
||||
(cond-expand
|
||||
(chicken (import (only (srfi 1) alist-delete)))
|
||||
;; Insert whatever you need here for your Scheme.
|
||||
(else))
|
||||
|
||||
(begin
|
||||
|
||||
(define-record-type <assoc-array>
|
||||
(%assoc-array hashfunc pred=? default table)
|
||||
assoc-array?
|
||||
(hashfunc %hashfunc)
|
||||
(pred=? %pred=?)
|
||||
(default %default)
|
||||
(table %table))
|
||||
|
||||
(define (assoc-array-make-generator array kind)
|
||||
(define tree-traverser (avl-make-generator (%table array)))
|
||||
(define get-desired-part
|
||||
(cond ((eq? kind 'key) (lambda (pair) (car pair)))
|
||||
((eq? kind 'data) (lambda (pair) (cdr pair)))
|
||||
(else (lambda (pair) pair))))
|
||||
(make-generator-procedure
|
||||
(lambda ()
|
||||
(let traverse ()
|
||||
(let ((tree-entry (tree-traverser)))
|
||||
(when (success? tree-entry)
|
||||
(let scan-lst ((lst (cdr tree-entry)))
|
||||
(when (pair? lst)
|
||||
(suspend (get-desired-part (car lst)))
|
||||
(scan-lst (cdr lst))))
|
||||
(traverse))))
|
||||
&fail)))
|
||||
|
||||
(define (assoc-array-make-pair-generator array)
|
||||
(assoc-array-make-generator array 'pair))
|
||||
|
||||
(define (assoc-array-make-key-generator array)
|
||||
(assoc-array-make-generator array 'key))
|
||||
|
||||
(define (assoc-array-make-data-generator array)
|
||||
(assoc-array-make-generator array 'data))
|
||||
|
||||
(define assoc-array
|
||||
(case-lambda
|
||||
((hashfunc)
|
||||
(let ((pred=? equal?)
|
||||
(default #f))
|
||||
(assoc-array hashfunc pred=? default)))
|
||||
((hashfunc pred=?)
|
||||
(let ((default #f))
|
||||
(assoc-array hashfunc pred=? default)))
|
||||
((hashfunc pred=? default)
|
||||
(%assoc-array hashfunc pred=? default (avl)))))
|
||||
|
||||
(define (assoc-array-set array key data)
|
||||
(let ((hashfunc (%hashfunc array))
|
||||
(pred=? (%pred=? array))
|
||||
(default (%default array))
|
||||
(table (%table array)))
|
||||
(let ((hash-value (hashfunc key)))
|
||||
(let*-values
|
||||
(((alst found?) (avl-search-values < table hash-value)))
|
||||
(cond
|
||||
(found?
|
||||
(let* ((alst (alist-delete key alst pred=?))
|
||||
(alst `((,key . ,data) . ,alst))
|
||||
(table (avl-insert < table hash-value alst)))
|
||||
(%assoc-array hashfunc pred=? default table)))
|
||||
(else
|
||||
(let* ((alst `((,key . ,data)))
|
||||
(table (avl-insert < table hash-value alst)))
|
||||
(%assoc-array hashfunc pred=? default table))))))))
|
||||
|
||||
(define (assoc-array-ref array key)
|
||||
(let* ((hashfunc (%hashfunc array))
|
||||
(hash-value (hashfunc key)))
|
||||
(let*-values
|
||||
(((alst found?)
|
||||
(avl-search-values < (%table array) hash-value)))
|
||||
(if found?
|
||||
(let ((pair (assoc key alst (%pred=? array))))
|
||||
(if pair
|
||||
(cdr pair)
|
||||
(%default array)))
|
||||
(%default array)))))
|
||||
|
||||
)) ;; end library (associative-arrays)
|
||||
|
||||
|
||||
(cond-expand
|
||||
(DEMONSTRATION
|
||||
(begin
|
||||
(import (scheme base))
|
||||
(import (scheme write))
|
||||
(import (suspendable-procedures))
|
||||
(import (associative-arrays))
|
||||
|
||||
(define (hashfunc s)
|
||||
;; Using Knuth’s random number generator to concoct a quick and
|
||||
;; dirty and probably very bad hash function. It should be much
|
||||
;; better to use something like SpookyHash, but this is a demo.
|
||||
(define a 6364136223846793005)
|
||||
(define c 1442695040888963407)
|
||||
(define M (expt 2 64))
|
||||
(let ((n (string-length s))
|
||||
(h 123))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i n))
|
||||
(let* ((x (char->integer (string-ref s i)))
|
||||
(x (+ (* a (+ h x)) c)))
|
||||
(set! h (truncate-remainder x M))))
|
||||
h))
|
||||
|
||||
(define a (assoc-array hashfunc))
|
||||
|
||||
;; Fill the associative array ‘a’ with (string . number)
|
||||
;; associations.
|
||||
(do ((i 1 (+ i 1)))
|
||||
((= i 11))
|
||||
(set! a (assoc-array-set a (number->string i) i)))
|
||||
|
||||
;; Go through the association pairs (in arbitrary order) with a
|
||||
;; generator.
|
||||
(let ((gen (assoc-array-make-pair-generator a)))
|
||||
(do ((pair (gen) (gen)))
|
||||
((failure? pair))
|
||||
(write pair) (display " "))
|
||||
(newline))
|
||||
|
||||
;; Go through the keys (in arbitrary order) with a generator.
|
||||
(let ((gen (assoc-array-make-key-generator a)))
|
||||
(do ((key (gen) (gen)))
|
||||
((failure? key))
|
||||
(write key) (display " "))
|
||||
(newline))
|
||||
|
||||
;; Go through the values (in arbitrary order) with a generator.
|
||||
(let ((gen (assoc-array-make-data-generator a)))
|
||||
(do ((value (gen) (gen)))
|
||||
((failure? value))
|
||||
(write value) (display " "))
|
||||
(newline))
|
||||
|
||||
))
|
||||
(else))
|
||||
Loading…
Add table
Add a link
Reference in a new issue