mirror of
https://github.com/samsonjs/elschemo.git
synced 2026-03-25 09:15:55 +00:00
226 lines
No EOL
6.8 KiB
Scheme
226 lines
No EOL
6.8 KiB
Scheme
;; the basics
|
|
(define nil ())
|
|
(define null nil)
|
|
(define true #t)
|
|
(define false #f)
|
|
(define (pair? x) (and (list? x) (not (null? x))))
|
|
(define (not x) (if (eq? #f x) #t #f))
|
|
(define (newline) (display "\n"))
|
|
|
|
(define (list . objs) objs)
|
|
(define (id obj) obj)
|
|
(define (flip func)
|
|
(lambda (arg1 arg2) (func arg2 arg1)))
|
|
(define (curry func arg1)
|
|
(lambda (arg) (func arg1 arg)))
|
|
(define (compose f g)
|
|
(lambda (arg) (f (apply g arg))))
|
|
|
|
;; math
|
|
(define zero? (curry = 0))
|
|
(define negative? (curry (flip <) 0))
|
|
(define positive? (curry (flip >) 0))
|
|
(define inc (curry + 1))
|
|
(define dec (curry (flip -) 1))
|
|
|
|
(define (divides? a b)
|
|
(zero? (remainder b a)))
|
|
|
|
(define (prime? x)
|
|
(= x (smallest-divisor x)))
|
|
|
|
;; this sort of coercion shouldn't be necessary
|
|
(define (odd? num)
|
|
(cond ((and (float? num) (equal? num (floor num))) (= (mod (floor num) 2) 1))
|
|
((float? num) (display "odd? expects an integer, given:" num) #f)
|
|
(else (= (mod num 2) 1))))
|
|
(define (even? num)
|
|
(cond ((and (float? num) (equal? num (floor num))) (zero? (mod (floor num) 2)))
|
|
((float? num) (display "even? expects an integer, given:" num) #f)
|
|
(else (zero? (mod num 2)))))
|
|
|
|
(define (square x) (* x x))
|
|
(define (abs x)
|
|
(cond ((< x 0) (- x))
|
|
(else x)))
|
|
|
|
;; exponentation using recursion (pretty fast)
|
|
(define (expt-rec b n)
|
|
(if (zero? n)
|
|
1
|
|
(* b (expt-rec b (dec n)))))
|
|
|
|
;; exponentation using foldl (slowest)
|
|
(define (expt-fold b n)
|
|
(fold * 1 (fill (range 1 n) b)))
|
|
|
|
;; exponentation using iteration
|
|
;; (seems a bit slower than the recursive version, but still fast)
|
|
(define (expt-iter b counter . product)
|
|
(let product (lambda (if (null? product) 1 (car product)))
|
|
(if (zero? counter)
|
|
product
|
|
(expt-iter b (dec counter) (* b product)))))
|
|
|
|
;; fast exponentation
|
|
(define (fast-expt b n)
|
|
(cond ((= n 0) 1)
|
|
((even? n) (square (fast-expt b (/ n 2))))
|
|
(else (* b (fast-expt b (- n 1))))))
|
|
(define expt fast-expt)
|
|
|
|
;; calculate square roots
|
|
(define (sqrt-good-enough? guess x)
|
|
(let ((delta 0.0001))
|
|
(< (abs (- (square guess) x))
|
|
delta)))
|
|
|
|
(define (sqrt-improve guess x)
|
|
(average guess (/ x guess)))
|
|
|
|
(define (sqrt-iter guess x)
|
|
(if (sqrt-good-enough? guess x)
|
|
guess
|
|
(sqrt-iter (sqrt-improve guess x) x)))
|
|
|
|
(define (sqrt x)
|
|
(sqrt-iter 1.0 x))
|
|
|
|
(define (factorial n)
|
|
(if (<= n 1)
|
|
1
|
|
(* n (factorial (- n 1)))))
|
|
(define ! factorial)
|
|
|
|
;; greatest common denominator
|
|
(define (gcd a b)
|
|
(if (zero? b)
|
|
a
|
|
(gcd b (remainder a b))))
|
|
|
|
(define (find-divisor n test-divisor)
|
|
(let ((next (lambda (n)
|
|
(if (eq? n 2)
|
|
3
|
|
(+ n 2)))))
|
|
(cond ((> (square test-divisor) n) n)
|
|
((divides? test-divisor n) test-divisor)
|
|
(else (find-divisor n (next test-divisor))))))
|
|
|
|
(define (smallest-divisor n)
|
|
(find-divisor n 2))
|
|
|
|
(define (expmod base exp m)
|
|
(cond ((zero? exp) 1)
|
|
((even? exp)
|
|
(remainder (square (expmod base (/ exp 2) m))
|
|
m))
|
|
(else
|
|
(remainder (* base (expmod base (dec exp) m))
|
|
m))))
|
|
|
|
;; test for prime numbers using Fermat's method
|
|
(define (fermat-test n)
|
|
(let ((try-it (lambda (a)
|
|
(= (expmod a n n) a))))
|
|
(try-it (inc (random (dec n))))))
|
|
|
|
;; this runs Fermat's test a given number of times
|
|
(define (fast-prime? n times)
|
|
(cond ((zero? times) true)
|
|
((fermat-test n) (fast-prime? n (dec times)))
|
|
(else false)))
|
|
|
|
;; folds
|
|
|
|
;; SICP calls this accumulate
|
|
(define (foldr func end lst)
|
|
(if (null? lst)
|
|
end
|
|
(func (car lst) (foldr func end (cdr lst)))))
|
|
|
|
(define (foldl func accum lst)
|
|
(if (null? lst)
|
|
accum
|
|
(foldl func (func accum (car lst)) (cdr lst))))
|
|
|
|
(define fold foldl)
|
|
(define reduce fold)
|
|
|
|
(define (unfold func init pred)
|
|
(if (pred init)
|
|
(cons init '())
|
|
(cons init (unfold func (func init) pred))))
|
|
|
|
(define (sum-list lst) (fold + 0 lst))
|
|
(define (sum . lst) (sum-list lst))
|
|
(define (product . lst) (fold * 0 lst))
|
|
(define (average . xs) (/ (sum-list xs) (length xs)))
|
|
(define avg average)
|
|
|
|
(define (max first . num-list) (fold (lambda (old new) (if (> old new) old new)) first num-list))
|
|
(define (min first . num-list) (fold (lambda (old new) (if (< old new) old new)) first num-list))
|
|
(define (length lst) (fold (lambda (x y) (+ x 1)) 0 lst))
|
|
(define (reverse lst) (fold (flip cons) '() lst))
|
|
(define (nth n lst) (if (= n 1) (car lst) (nth (- n 1) (cdr lst))))
|
|
|
|
|
|
(define (mem-helper pred op) (lambda (acc next) (if (and (not acc) (pred (op next))) next acc)))
|
|
(define (memq obj lst) (fold (mem-helper (curry eq? obj) id) #f lst))
|
|
(define (memv obj lst) (fold (mem-helper (curry eqv? obj) id) #f lst))
|
|
(define (member obj lst) (fold (mem-helper (curry equal? obj) id) #f lst))
|
|
(define (assq obj alist) (fold (mem-helper (curry eq? obj) car) #f alist))
|
|
(define (assv obj alist) (fold (mem-helper (curry eqv? obj) car) #f alist))
|
|
(define (assoc obj alist) (fold (mem-helper (curry equal? obj) car) #f alist))
|
|
|
|
;; TODO define fold-k (fold w/ continuations) and use it to short-circuit these
|
|
(define (any? pred lst) (fold (lambda (any-found x) (or any-found (pred x))) #f lst))
|
|
(define (all? pred lst) (fold (lambda (all-matched x) (and (pred x) all-matched)) #t lst))
|
|
|
|
;; transformations
|
|
;; (define (map func lst) (foldr (lambda (x y) (cons (func x) y)) '() lst))
|
|
;; (define (mapr func lst) (fold (lambda (x y) (cons (func y) x)) '() lst))
|
|
(define (filter pred lst) (foldr (lambda (x y) (if (pred x) (cons x y) y)) '() lst))
|
|
(define (fill lst n) (map (lambda (x) n) lst))
|
|
|
|
;; the more general version of map, similar to mapcar in Lisp
|
|
(define (map func . seqs)
|
|
(cond ((= 1 (length seqs))
|
|
(foldr (lambda (x y) (cons (func x) y)) '() (car seqs)))
|
|
((null? (car seqs)) nil)
|
|
(else
|
|
(cons (apply func (map car seqs))
|
|
(apply map (cons func (map cdr seqs)))))))
|
|
|
|
|
|
(define (caar lst) (car (car lst)))
|
|
(define (cadr lst) (car (cdr lst)))
|
|
(define (caddr lst) (car (cdr (cdr lst))))
|
|
(define (cadddr lst) (car (cdr (cdr (cdr lst)))))
|
|
|
|
|
|
;; like python's range
|
|
;; SICP calls this enumerate-interval ... i prefer range
|
|
(define (range min max)
|
|
(if (> min max)
|
|
nil
|
|
(cons min (range (inc min) max))))
|
|
|
|
;; recursive method of concatenating 2 lists
|
|
(define (append list1 list2)
|
|
(if (null? list1)
|
|
list2
|
|
(cons (car list1) (append (cdr list1) list2))))
|
|
|
|
;; string manipulation
|
|
(define (string-map func s)
|
|
(list->string (map func (string->list s))))
|
|
|
|
(define (string-upcase s)
|
|
(string-map char-upcase s))
|
|
|
|
(define (string-downcase s)
|
|
(string-map char-downcase s))
|
|
|
|
(define (string-append . lst)
|
|
(string-concatenate lst)) |