The Seasoned Schemer
Ported from on-scheme's seasoned-schemer.scm, after The Seasoned Schemer.
Implementation
(module
(aux schemer seasoned)
*
(import
scheme
(chicken base)
(aux base)
(aux continuation)
(aux continuation classic))
(define multi-insert*&co
(λ (new old_l old_r sexp coll)
(let M ((sexp sexp) (coll coll))
(cond ((null? sexp) (coll '() 0 0))
((atom? (car sexp))
(cond ((equal? (car sexp) old_l)
(M (cdr sexp)
(λ (new_sexp L R)
(coll (cons new (cons old_l new_sexp))
(add1 L)
R))))
((equal? (car sexp) old_r)
(M (cdr sexp)
(λ (new_sexp L R)
(coll (cons old_r (cons new new_sexp))
L
(add1 R)))))
(else
(M (cdr sexp)
(λ (new_sexp L R)
(coll (cons (car sexp) new_sexp) L R))))))
(else
(M (car sexp)
(λ (new_sexp_car L_car R_car)
(M (cdr sexp)
(λ (new_sexp_cdr L_cdr R_cdr)
(coll (cons new_sexp_car new_sexp_cdr)
(+ L_car L_cdr)
(+ R_car R_cdr)))))))))))
(define two-in-a-row?
(λ (lat)
(cond ((null? lat) #f)
(else
(let T ((preceding (car lat)) (rest (cdr lat)))
(cond ((null? rest) #f)
(else
(or (equal? preceding (car rest))
(T (car rest) (cdr rest))))))))))
(define two-in-a-row?&hop
(λ (lat)
(cond ((null? lat) #f)
(else
(letcc hop
(let T ((preceding (car lat)) (rest (cdr lat)))
(cond ((null? rest) (hop #f))
((equal? preceding (car rest)) (hop #t))
(else (T (car rest) (cdr rest))))))))))
(define intersect/letrec
(λ (this that)
(letrec ((I (λ (set)
(cond ((null? set) '())
((member (car set) that)
(cons (car set) (I (cdr set))))
(else (I (cdr set)))))))
(I this))))
(define intersect
(λ (this that)
(letrec ((I (λ (l)
(match/first
l
(() '())
((,i unquote is)
(cond ((member i that) (cons i (I is)))
(else (I is))))))))
(I this))))
(define intersect+all
(λ (sets)
(letcc hop
(letrec ((intersect
(λ (this that)
(cond ((null? that) (hop '()))
(else
(letrec ((I (λ (l)
(match/first
l
(() '())
((,i unquote is)
(if (member i that) (cons i (I is)) (I is)))))))
(I this))))))
(all-null?
(λ (l)
(cond ((null? l) #t)
((null? (car l)) (all-null? (cdr l)))
(else #f))))
(A (λ (sets)
(cond ((all-null? sets) (hop '()))
((null? (cdr sets)) (car sets))
(else (intersect (car sets) (A (cdr sets))))))))
(cond ((null? sets) '()) (else (A sets)))))))
(define comb-upto-last
(λ (atom k lat)
(reverse
(letcc skip
(letrec ((R (λ (prefix k lat)
(match/first
lat
(() prefix)
((,a unquote as)
(cond ((equal? atom a)
(cond ((zero? k) prefix)
(else (skip (R '() (sub1 k) as)))))
(else (R (cons a prefix) k as))))))))
(R '() (sub1 k) lat))))))
(define atom/book? (λ (x) (not (or (pair? x) (null? x)))))
(define leftmost/awkward
(λ (l)
(letrec ((L (λ (ll)
(match/first
ll
(() '())
((,first unquote rest)
(cond ((atom/book? first) first)
(else
(let1 (a (L first))
(cond ((atom/book? a) a) (else (L rest)))))))))))
(let1 (atom (L l)) (cond ((atom/book? atom) atom) (else l))))))
(define leftmost/awkward+letcc
(λ (l)
(letrec ((L (λ (ll hop)
(match/first
ll
(() '())
((,first unquote rest)
(cond ((atom/book? first) (hop first))
(else
(let1 (a (L first hop))
(cond ((atom/book? a) a) (else (L rest hop)))))))))))
(let1 (atom (letcc hop (L l hop)))
(cond ((atom/book? atom) atom) (else l))))))
(define leftmost/escape+explicit
(λ (l)
(letrec ((L (λ (ll out)
(cond ((null? ll) '(no symbol here))
((atom/book? (car ll)) (out (car ll)))
(else (begin (L (car ll) out) (L (cdr ll) out)))))))
(escapecc (hop (L l hop)) (else l)))))
(define leftmost/escape
(λ (l)
(escapecc
(hop (let L ((ll l))
(match/first
ll
(() '(no symbol here))
((,first unquote rest)
(cond ((atom/book? first) (hop first))
(else (begin (L first) (L rest))))))))
(else l))))
(define rember1*/letcc
(λ (atom sexp)
(letrec ((R (λ (sexp skip)
(match/first
sexp
(() (skip 'no-present))
((,a unquote d)
(cond ((atom/book? a)
(cond ((equal? a atom) d)
(else (cons a (R d skip)))))
(else
(let1 (new-car (apply/cc R (list a)))
(cond ((symbol? new-car) (cons a (R d skip)))
(else (cons new-car d)))))))))))
(let1 (s (apply/cc R (list sexp)))
(cond ((symbol? s) sexp) (else s))))))
(define rember1*/try
(λ (atom sexp)
(letrec ((make-skipper
(λ (skip sexp)
(τ (let1 (reason `(,atom not present in ,sexp))
(display reason)
(skip reason)))))
(R (λ (sexp keep-searching)
(match/first
sexp
(() (keep-searching))
((,a unquote d)
(cond ((atom/book? a)
(cond ((equal? a atom) d)
(else (cons a (R d keep-searching)))))
(else
(trycc/named
(skip (cons (R a (make-skipper skip a)) d))
(else (cons a (R d keep-searching)))))))))))
(trycc/named
(skip (R sexp (make-skipper skip sexp)))
(else => (λ (previous) (display previous) sexp)))))))
test/multi-insert*&co: pass
(define (test/multi-insert*&co _)
(let ((sexp '((((orange fish)) apple anchovy) apple (orange)))
(sexp-expected
'((((orange tuna fish)) apple tuna anchovy) apple (orange tuna)))
(identity-abridged (λ args args)))
(⊦= `(,sexp-expected 1 2)
(multi-insert*&co 'tuna 'anchovy 'orange sexp identity-abridged))
(⊦= `(,sexp-expected 1 2)
(letcc hop
(multi-insert*&co
'tuna
'anchovy
'orange
sexp
(λ args (hop args)))))))
((eta 0.0) (memory #(6291456 2063584 1048576)) (stdout "") (stderr ""))
test/two-in-a-row?: pass
(define (test/two-in-a-row? _)
(⊦= #f (two-in-a-row? '()))
(⊦= #f (two-in-a-row? '(j f r e k s i)))
(⊦= #t (two-in-a-row? '(j f r e k s s)))
(⊦= #f (two-in-a-row?&hop '()))
(⊦= #f (two-in-a-row?&hop '(j f r e k s i)))
(⊦= #t (two-in-a-row?&hop '(j f r e k s s))))
((eta 0.0) (memory #(6291456 2064896 1048576)) (stdout "") (stderr ""))
test/intersect: pass
(define (test/intersect _)
(⊦= '() (intersect '(1 2 3) '()))
(⊦= '(2 3) (intersect '(1 2 3) '(2 3 4))))
((eta 0.0) (memory #(6291456 2063152 1048576)) (stdout "") (stderr ""))
test/intersect+all: pass
(define (test/intersect+all _)
(⊦= '(3) (intersect+all '((3 mango and) (3 kiwis and) (3 hamburgers))))
(⊦= '()
(intersect+all '((3 steaks and) (no food and) () (3 diet hamburgers))))
(⊦= '()
(intersect+all '((3 steaks and) (no food and) (3 diet hamburgers) ())))
(⊦= '()
(intersect+all
'((3 steaks and)
(no food and)
(three baked potatoes)
(3 diet hamburgers)))))
((eta 0.0) (memory #(6291456 2064384 1048576)) (stdout "") (stderr ""))
test/comb-upto-last: pass
(define (test/comb-upto-last _)
(⊦= '(e f) (comb-upto-last 'a -1 '(a b a d a e f)))
(⊦= '(a b c d a e f) (comb-upto-last 'r -1 '(a b c d a e f)))
(⊦= '() (comb-upto-last 'a 1 '(a b c d a e f a g h)))
(⊦= '(b c d) (comb-upto-last 'a 1 '(b c d a e f a g h)))
(⊦= '(e f) (comb-upto-last 'a 2 '(b c d a e f a g h)))
(⊦= '(g h) (comb-upto-last 'a 3 '(b c d a e f a g h)))
(⊦= '(g h) (comb-upto-last 'a 50 '(b c d a e f a g h))))
((eta 0.0) (memory #(6291456 2065472 1048576)) (stdout "") (stderr ""))
test/leftmost: pass
(define (test/leftmost _)
(let1 (leftmost leftmost/escape)
(⊦= 'a (leftmost '(((a)) b (c))))
(⊦= 'b (leftmost '((() ((() (())))) b (c))))
(let1 (sexp '((() ((() (())))) (((() ()))) ()))
(⊦= sexp (leftmost sexp)))))
((eta 0.0) (memory #(6291456 2066696 1048576)) (stdout "") (stderr ""))
test/rember1*: pass
(define (test/rember1* _)
(let1 (R (λ args
(let1 (result #f)
(with-output-to-string
(τ (set! result (apply rember1*/try args))))
result)))
(⊦= '((delicious) (food)) (R 'more '((delicious) more (food))))
(⊦= '((orange) more (fruits)) (R 'pizza '((orange) more (fruits))))))
((eta 0.0) (memory #(6291456 2068344 1048576)) (stdout "") (stderr ""))
test/leftmost/variants: pass
(define (test/leftmost/variants _)
(let1 (sexp '((() ((() (())))) (((() ()))) ()))
(for-each
(λ (leftmost)
(⊦= 'a (leftmost '(((a)) b (c))))
(⊦= 'b (leftmost '((() ((() (())))) b (c))))
(⊦= sexp (leftmost sexp)))
(list leftmost/awkward
leftmost/awkward+letcc
leftmost/escape+explicit
leftmost/escape))))
((eta 0.0) (memory #(6291456 2069008 1048576)) (stdout "") (stderr ""))
test/leftmost/non-symbol-atoms: pass
(define (test/leftmost/non-symbol-atoms _)
(for-each
(λ (leftmost)
(⊦= 1 (leftmost '(1 a)))
(⊦= "s" (leftmost '(("s") a)))
(⊦= #f (leftmost '((() #f) a)))
(⊦= 'a (leftmost '(() (a) 1))))
(list leftmost/awkward
leftmost/awkward+letcc
leftmost/escape+explicit
leftmost/escape)))
((eta 0.0) (memory #(6291456 2070104 1048576)) (stdout "") (stderr ""))
test/rember1*/non-symbol-atoms: pass
(define (test/rember1*/non-symbol-atoms _)
(let1 (R (λ args
(let1 (result #f)
(with-output-to-string
(τ (set! result (apply rember1*/try args))))
result)))
(for-each
(λ (rember1*)
(⊦= '(1 2) (rember1* 'x '(1 x 2)))
(⊦= '(1 (2)) (rember1* 3 '(1 (3 2))))
(⊦= '((1 "t") "s") (rember1* "s" '((1 "s" "t") "s")))
(⊦= '(1 (2) #t) (rember1* 'x '(1 (2) #t))))
(list rember1*/letcc R))))
((eta 0.0) (memory #(6291456 2072072 1048576)) (stdout "") (stderr ""))
test/rember1*/variants: pass
(define (test/rember1*/variants _)
(⊦= '((delicious) (food)) (rember1*/letcc 'more '((delicious) more (food))))
(⊦= '((orange) more (fruits))
(rember1*/letcc 'pizza '((orange) more (fruits))))
(⊦= '((a) x) (rember1*/letcc 'x '((a x) x)))
(⊦= '((a) x) (rember1*/try 'x '((a x) x)))
(⊦= "(more not present in (delicious))"
(with-output-to-string
(τ (rember1*/try 'more '((delicious) more (food))))))
(⊦= (string-append
"(pizza not present in (orange))"
"(pizza not present in (fruits))"
"(pizza not present in ((orange) more (fruits)))"
"((pizza not present in ((orange) more (fruits))))")
(with-output-to-string
(τ (rember1*/try 'pizza '((orange) more (fruits)))))))
((eta 0.0) (memory #(6291456 2072632 1048576)) (stdout "") (stderr ""))
test/intersect/letrec: pass
(define (test/intersect/letrec _)
(⊦= '() (intersect/letrec '(1 2 3) '()))
(⊦= '(2 3) (intersect/letrec '(1 2 3) '(2 3 4)))
(⊦= '() (intersect+all '()))
(⊦= '(a b) (intersect+all '((a b))))
(⊦= '() (intersect+all '(() ()))))
((eta 0.0) (memory #(6291456 2073640 1048576)) (stdout "") (stderr ""))
Categories: scheme
See also
The (aux anthropic) module
The Anthropic Messages API, offline
The (aux cml) module
Events, threads, synchronous variables, the library and I/O
The (aux hakaru10) modules
Random sources, distributions, the language, exact inference and examples
The (aux kanren) modules
Arithmetic, dates, presentation of answers and a union-find miniKanren
The (aux games dice-of-doom) module
Dice of Doom
The (aux machine) modules
Environments, the SC machine and the SECD machine
The (aux continuation) modules
Classic operators, escapers, amb and Collatz sequences
The (aux category) modules
Monads: list, maybe, probability, ziplist, difference lists and state
The (aux timsort) module
Sorting and the trace buffer
The (aux fds) modules
Functional queues and union-find
The (aux sxml) module
Rendering SXML to HTML
The (aux variable) module
Logic variables introduced by fresh
The (aux tabling) module
Memoization and tabled definitions
The (aux commons) module
Learning tests for CHICKEN Scheme
Promises
delay and make-promise
The Ackermann function
On unary numbers, as lists
Concurrent ML for CHICKEN Scheme
Porting SML/NJ CML as the (aux cml) library
CHICKEN Scheme
Versions and implementation notes
The SBRAL data structure
Skew Binary Random-Access Lists
Pattern matching
Scheme macrology: a generalized pattern matcher
The (aux hansei) modules
Inference, random sources, lazy lists, logic programming and example models
The (aux nondeterministic) module
Learning tests for Scheme
The (aux stream) modules
Streams, streams after SICP, and sequences and power series
The (aux unittest) module
Bootstrapping a unittest framework
Scheme lang: Chez, 48 and Chicken
Some docs, refs and containers, respectively.
The Reasoned Schemer
miniKanren, microKanren and some implementations
Aggregation predicates for µkanren
Groups, window functions, sets and enumerations
miniKanren, live and untagged
Quine generation via relational interpreters
Pure, declarative, and constructive arithmetic relations
A declarative pearl
Final shift for call/cc
Direct implementation of shift and reset
Call with Current Continuation Patterns
Cogen in six lines
The Seasoned Schemer
The Little Schemer
Adding generic functions to Scheme
Handling control