#lang racket/base
(require trace)
(define simply-scheme:* *)
(define simply-scheme:+ +)
(define simply-scheme:- -)
(define simply-scheme:/ /)
(define simply-scheme:< <)
(define simply-scheme:<= <=)
(define simply-scheme:= =)
(define simply-scheme:> >)
(define simply-scheme:>= >=)
(define simply-scheme:abs abs)
(define simply-scheme:acos acos)
(define simply-scheme:asin asin)
(define simply-scheme:atan atan)
(define simply-scheme:ceiling ceiling)
(define simply-scheme:close-input-port close-input-port)
(define simply-scheme:close-output-port close-output-port)
(define simply-scheme:cos cos)
(define simply-scheme:equal? equal?)
(define simply-scheme:even? even?)
(define simply-scheme:exp exp)
(define simply-scheme:expt expt)
(define simply-scheme:floor floor)
(define simply-scheme:gcd gcd)
(define simply-scheme:integer? integer?)
(define simply-scheme:lcm lcm)
(define simply-scheme:list-ref list-ref)
(define simply-scheme:log log)
(define simply-scheme:make-vector make-vector)
(define simply-scheme:max max)
(define simply-scheme:min min)
(define simply-scheme:modulo modulo)
(define simply-scheme:negative? negative?)
(define simply-scheme:number->string number->string)
(define simply-scheme:number? number?)
(define simply-scheme:odd? odd?)
(define simply-scheme:open-input-file open-input-file)
(define simply-scheme:open-output-file open-output-file)
(define simply-scheme:positive? positive?)
(define simply-scheme:quotient quotient)
(define simply-scheme:random random)
(define simply-scheme:read-line read-line)
(define simply-scheme:read-string read-string)
(define simply-scheme:remainder remainder)
(define simply-scheme:round round)
(define simply-scheme:sin sin)
(define simply-scheme:sqrt sqrt)
(define simply-scheme:tan tan)
(define simply-scheme:truncate truncate)
(define simply-scheme:vector-ref vector-ref)
(define simply-scheme:vector-set! vector-set!)
(define simply-scheme:zero? zero?)
(void (if (simply-scheme:equal? 'foo (symbol->string 'foo))
(error "Simply.scm already loaded!!")
#f))
(void (if (char=? #\+ (string-ref (simply-scheme:number->string 1.0) 0))
(let-values (((old-ns) simply-scheme:number->string)
((char=?) char=?)
((string-ref) string-ref)
((substring) substring)
((string-length) string-length))
(set! simply-scheme:number->string
(lambda args
(let-values (((result) (apply old-ns args)))
(if (char=? #\+ (string-ref result 0))
(substring result 1 (string-length result))
result)))))
'no-problem))
(set! simply-scheme:number->string
(let-values (((old-ns) simply-scheme:number->string) ((string?) string?))
(lambda args (if (string? (car args)) (car args) (apply old-ns args)))))
(define-values
(whoops)
(let-values (((string?) string?)
((string-append) string-append)
((error) error)
((cons) cons)
((map) map)
((apply) apply))
(letrec-values (((error-printform)
(lambda (x)
(if (string? x) (string-append "\"" x "\"") x))))
(lambda (string . args)
(apply error (cons string (map error-printform args)))))))
(void
(if (if (inexact? (simply-scheme:round (simply-scheme:sqrt 2))) (exact? 1) #f)
(let-values (((old-round) simply-scheme:round)
((inexact->exact) inexact->exact))
(set! simply-scheme:round
(lambda (number) (inexact->exact (old-round number)))))
'no-problem))
(void (if (inexact? (simply-scheme:* 0.25 4))
(let-values (((rem) simply-scheme:remainder)
((quo) simply-scheme:quotient)
((inexact->exact) inexact->exact)
((integer?) simply-scheme:integer?))
(set! simply-scheme:remainder
(lambda (x y)
(rem
(if (integer? x) (inexact->exact x) x)
(if (integer? y) (inexact->exact y) y))))
(set! simply-scheme:quotient
(lambda (x y)
(quo
(if (integer? x) (inexact->exact x) x)
(if (integer? y) (inexact->exact y) y)))))
'done))
(set! simply-scheme:random
(let-values (((*seed*) 1)
((quotient) simply-scheme:quotient)
((modulo) simply-scheme:modulo)
((+) simply-scheme:+)
((-) simply-scheme:-)
((*) simply-scheme:*)
((>) simply-scheme:>))
(lambda (x)
(let-values (((hi) (quotient *seed* 127773)))
(let-values (((low) (modulo *seed* 127773)))
(let-values (((test) (- (* 16807 low) (* 2836 hi))))
(if (> test 0)
(set! *seed* test)
(set! *seed* (#%app + test (#%datum . 2147483647)))))))
(modulo *seed* x))))
(define-values
(word?)
(let-values (((number?) simply-scheme:number?)
((symbol?) symbol?)
((string?) string?))
(lambda (x)
(let-values (((or-part) (symbol? x)))
(if or-part
or-part
(let-values (((or-part) (number? x)))
(if or-part or-part (string? x))))))))
(define-values
(sentence?)
(let-values (((null?) null?)
((pair?) pair?)
((word?) word?)
((car) car)
((cdr) cdr))
(letrec-values (((list-of-words?)
(lambda (l)
(if (null? l)
(begin #t)
(if (pair? l)
(begin
(if (word? (car l)) (list-of-words? (cdr l)) #f))
(begin #f))))))
list-of-words?)))
(define-values
(empty?)
(let-values (((null?) null?) ((string?) string?) ((string=?) string=?))
(lambda (x)
(let-values (((or-part) (null? x)))
(if or-part or-part (if (string? x) (string=? x "") #f))))))
(define-values
(char-rank)
(let-values (((*the-char-ranks*) (simply-scheme:make-vector 256 3))
((=) simply-scheme:=)
((+) simply-scheme:+)
((string-ref) string-ref)
((string-length) string-length)
((vector-set!) simply-scheme:vector-set!)
((char->integer) char->integer)
((symbol->string) symbol->string)
((vector-ref) simply-scheme:vector-ref))
(letrec-values (((rank-string)
(lambda (str rank)
(letrec-values (((helper)
(lambda (i len)
(if (= i len)
'done
(begin
(vector-set!
*the-char-ranks*
(char->integer
(string-ref str i))
rank)
(helper (+ i 1) len))))))
(helper 0 (string-length str))))))
(rank-string (symbol->string 'abcdefghijklmnopqrstuvwxyz) 0)
(rank-string "!$%&*/:<=>?~_^" 0)
(rank-string "+-." 1)
(rank-string "0123456789" 2)
(lambda (char) (vector-ref *the-char-ranks* (char->integer char))))))
(define-values
(string->word)
(let-values (((=) simply-scheme:=)
((<=) simply-scheme:<=)
((+) simply-scheme:+)
((-) simply-scheme:-)
((char-rank) char-rank)
((string-ref) string-ref)
((string-length) string-length)
((string=?) string=?)
((not) not)
((char=?) char=?)
((string->number) string->number)
((string->symbol) string->symbol))
(lambda (string)
(letrec-values (((subsequents?)
(lambda (string i length)
(if (= i length)
(begin #t)
(if (<= (char-rank (string-ref string i)) 2)
(begin (subsequents? string (+ i 1) length))
(begin #f)))))
((special-id?)
(lambda (string)
(let-values (((or-part) (string=? string "+")))
(if or-part
or-part
(let-values (((or-part) (string=? string "-")))
(if or-part
or-part
(string=? string "...")))))))
((ok-symbol?)
(lambda (string)
(if (string=? string "")
#f
(let-values (((rank1)
(char-rank (string-ref string 0))))
(if (= rank1 0)
(begin
(subsequents?
string
1
(string-length string)))
(if (= rank1 1)
(begin (special-id? string))
(begin #f)))))))
((nn-helper)
(lambda (string i len seen-point?)
(if (= i len)
(begin
(if seen-point?
(not (char=? (string-ref string (- len 1)) #\0))
#t))
(if (char=? #\. (string-ref string i))
(begin
(if seen-point?
(begin #f)
(if (= (+ i 2) len)
(begin #t)
(begin (nn-helper string (+ i 1) len #t)))))
(if (= 2 (char-rank (string-ref string i)))
(begin
(nn-helper string (+ i 1) len seen-point?))
(begin #f))))))
((narrow-number?)
(lambda (string)
(if (string=? string "")
#f
(let-values (((c0) (string-ref string 0)))
(let-values (((start) 0))
(let-values (((len) (string-length string)))
(let-values (((cn)
(string-ref string (- len 1))))
(if (if (char=? c0 #\-) (not (= len 1)) #f)
(begin
(set! start (#%datum . 1))
(set! c0
(#%app
string-ref
string
(#%datum . 1))))
#f)
(if (not (= (char-rank cn) 2))
(begin #f)
(if (char=? c0 #\.)
(begin #f)
(if (char=? c0 #\0)
(begin
(if (= len 1)
(begin #t)
(if (= len 2)
(begin #f)
(if (char=?
(string-ref
string
(+ start 1))
#\.)
(begin
(nn-helper
string
(+ start 2)
len
#t))
(begin #f)))))
(begin
(nn-helper
string
start
len
#f)))))))))))))
(if (narrow-number? string)
(begin (string->number string))
(if (ok-symbol? string)
(begin (string->symbol string))
(begin string)))))))
(define-values
(char->word)
(let-values (((=) simply-scheme:=)
((char-rank) char-rank)
((make-string) make-string)
((string->symbol) string->symbol)
((string->number) string->number)
((char=?) char=?))
(lambda (char)
(let-values (((rank) (char-rank char)) ((string) (make-string 1 char)))
(if (= rank 0)
(begin (string->symbol string))
(if (= rank 2)
(begin (string->number string))
(if (char=? char #\+)
(begin '+)
(if (char=? char #\-) (begin '-) (begin string)))))))))
(define-values
(word->string)
(let-values (((number?) simply-scheme:number?)
((string?) string?)
((number->string) simply-scheme:number->string)
((symbol->string) symbol->string))
(lambda (wd)
(if (string? wd)
(begin wd)
(if (number? wd)
(begin (number->string wd))
(begin (symbol->string wd)))))))
(define-values
(count)
(let-values (((word?) word?)
((string-length) string-length)
((word->string) word->string)
((length) length))
(lambda (stuff)
(if (word? stuff) (string-length (word->string stuff)) (length stuff)))))
(define-values
(word)
(let-values (((string->word) string->word)
((apply) apply)
((string-append) string-append)
((map) map)
((word?) word?)
((word->string) word->string)
((whoops) whoops))
(lambda x
(string->word
(apply
string-append
(map
(lambda (arg)
(if (word? arg)
(word->string arg)
(whoops "Invalid argument to WORD: " arg)))
x))))))
(define-values
(se)
(let-values (((pair?) pair?)
((null?) null?)
((word?) word?)
((car) car)
((cons) cons)
((cdr) cdr)
((whoops) whoops))
(letrec-values (((paranoid-append)
(lambda (a original-a b)
(if (null? a)
(begin b)
(if (word? (car a))
(begin
(cons
(car a)
(paranoid-append (cdr a) original-a b)))
(begin
(whoops
"Argument to SENTENCE not a word or sentence"
original-a))))))
((combine-two)
(lambda (a b)
(if (pair? a)
(begin (paranoid-append a a b))
(if (null? a)
(begin b)
(if (word? a)
(begin (cons a b))
(begin
(whoops
"Argument to SENTENCE not a word or sentence:"
a)))))))
((real-se)
(lambda (args)
(if (null? args)
'()
(combine-two (car args) (real-se (cdr args)))))))
(lambda args (real-se args)))))
(define-values (sentence) se)
(define-values
(first)
(let-values (((pair?) pair?)
((char->word) char->word)
((string-ref) string-ref)
((word->string) word->string)
((car) car)
((empty?) empty?)
((whoops) whoops)
((word?) word?))
(letrec-values (((word-first)
(lambda (wd)
(char->word (string-ref (word->string wd) 0)))))
(lambda (x)
(if (pair? x)
(begin (car x))
(if (empty? x)
(begin (whoops "Invalid argument to FIRST: " x))
(if (word? x)
(begin (word-first x))
(begin (whoops "Invalid argument to FIRST: " x)))))))))
(define-values
(last)
(let-values (((pair?) pair?)
((-) simply-scheme:-)
((word->string) word->string)
((char->word) char->word)
((string-ref) string-ref)
((string-length) string-length)
((empty?) empty?)
((cdr) cdr)
((car) car)
((whoops) whoops)
((word?) word?))
(letrec-values (((word-last)
(lambda (wd)
(let-values (((s) (word->string wd)))
(char->word (string-ref s (- (string-length s) 1))))))
((list-last)
(lambda (lst)
(if (empty? (cdr lst))
(car lst)
(list-last (cdr lst))))))
(lambda (x)
(if (pair? x)
(begin (list-last x))
(if (empty? x)
(begin (whoops "Invalid argument to LAST: " x))
(if (word? x)
(begin (word-last x))
(begin (whoops "Invalid argument to LAST: " x)))))))))
(define-values
(bf)
(let-values (((pair?) pair?)
((substring) substring)
((string-length) string-length)
((string->word) string->word)
((word->string) word->string)
((cdr) cdr)
((empty?) empty?)
((whoops) whoops)
((word?) word?))
(letrec-values (((string-bf)
(lambda (s) (substring s 1 (string-length s))))
((word-bf)
(lambda (wd)
(string->word (string-bf (word->string wd))))))
(lambda (x)
(if (pair? x)
(begin (cdr x))
(if (empty? x)
(begin (whoops "Invalid argument to BUTFIRST: " x))
(if (word? x)
(begin (word-bf x))
(begin (whoops "Invalid argument to BUTFIRST: " x)))))))))
(define-values (butfirst) bf)
(define-values
(bl)
(let-values (((pair?) pair?)
((-) simply-scheme:-)
((cdr) cdr)
((cons) cons)
((car) car)
((substring) substring)
((string-length) string-length)
((string->word) string->word)
((word->string) word->string)
((empty?) empty?)
((whoops) whoops)
((word?) word?))
(letrec-values (((list-bl)
(lambda (list)
(if (null? (cdr list))
'()
(cons (car list) (list-bl (cdr list))))))
((string-bl)
(lambda (s) (substring s 0 (- (string-length s) 1))))
((word-bl)
(lambda (wd)
(string->word (string-bl (word->string wd))))))
(lambda (x)
(if (pair? x)
(begin (list-bl x))
(if (empty? x)
(begin (whoops "Invalid argument to BUTLAST: " x))
(if (word? x)
(begin (word-bl x))
(begin (whoops "Invalid argument to BUTLAST: " x)))))))))
(define-values (butlast) bl)
(define-values
(item)
(let-values (((>) simply-scheme:>)
((-) simply-scheme:-)
((<) simply-scheme:<)
((integer?) simply-scheme:integer?)
((list-ref) simply-scheme:list-ref)
((char->word) char->word)
((string-ref) string-ref)
((word->string) word->string)
((not) not)
((whoops) whoops)
((count) count)
((word?) word?)
((list?) list?))
(letrec-values (((word-item)
(lambda (n wd)
(char->word (string-ref (word->string wd) (- n 1))))))
(lambda (n stuff)
(if (not (integer? n))
(begin
(whoops "Invalid first argument to ITEM (must be an integer): " n))
(if (< n 1)
(begin
(whoops "Invalid first argument to ITEM (must be positive): " n))
(if (> n (count stuff))
(begin (whoops "No such item: " n stuff))
(if (word? stuff)
(begin (word-item n stuff))
(if (list? stuff)
(begin (list-ref stuff (- n 1)))
(begin
(whoops
"Invalid second argument to ITEM: "
stuff)))))))))))
(set! simply-scheme:equal?
(let-values (((vector-length) vector-length)
((=) simply-scheme:=)
((vector-ref) simply-scheme:vector-ref)
((+) simply-scheme:+)
((string?) string?)
((symbol?) symbol?)
((null?) null?)
((pair?) pair?)
((car) car)
((cdr) cdr)
((eq?) eq?)
((string=?) string=?)
((symbol->string) symbol->string)
((number?) simply-scheme:number?)
((string->word) string->word)
((vector?) vector?)
((eqv?) eqv?))
(letrec-values (((vector-equal?)
(lambda (v1 v2)
(let-values (((len1) (vector-length v1))
((len2) (vector-length v2)))
(letrec-values (((helper)
(lambda (i)
(if (= i len1)
#t
(if (simply-scheme:equal?
(vector-ref v1 i)
(vector-ref v2 i))
(helper (+ i 1))
#f)))))
(if (= len1 len2) (helper 0) #f))))))
(lambda (x y)
(if (null? x)
(begin (null? y))
(if (null? y)
(begin #f)
(if (pair? x)
(begin
(if (pair? y)
(if (simply-scheme:equal? (car x) (car y))
(simply-scheme:equal? (cdr x) (cdr y))
#f)
#f))
(if (pair? y)
(begin #f)
(if (symbol? x)
(begin
(let-values (((or-part) (if (symbol? y) (eq? x y) #f)))
(if or-part
or-part
(if (string? y) (string=? (symbol->string x) y) #f))))
(if (symbol? y)
(begin (if (string? x) (string=? x (symbol->string y)) #f))
(if (number? x)
(begin
(let-values (((or-part) (if (number? y) (= x y) #f)))
(if or-part
or-part
(if (string? y)
(let-values (((possible-num) (string->word y)))
(if (number? possible-num)
(= x possible-num)
#f))
#f))))
(if (number? y)
(begin
(if (string? x)
(let-values (((possible-num) (string->word x)))
(if (number? possible-num)
(= possible-num y)
#f))
#f))
(if (string? x)
(begin (if (string? y) (string=? x y) #f))
(if (string? y)
(begin #f)
(if (vector? x)
(begin (if (vector? y) (vector-equal? x y) #f))
(if (vector? y)
(begin #f)
(begin (eqv? x y))))))))))))))))))
(define-values
(member?)
(let-values (((>) simply-scheme:>)
((-) simply-scheme:-)
((<) simply-scheme:<)
((null?) null?)
((symbol?) symbol?)
((eq?) eq?)
((car) car)
((not) not)
((symbol->string) symbol->string)
((string=?) string=?)
((cdr) cdr)
((equal?) simply-scheme:equal?)
((word->string) word->string)
((string-length) string-length)
((whoops) whoops)
((string-ref) string-ref)
((char=?) char=?)
((list?) list?)
((number?) simply-scheme:number?)
((empty?) empty?)
((word?) word?)
((string?) string?))
(letrec-values (((symbol-in-list?)
(lambda (symbol string lst)
(if (null? lst)
(begin #f)
(let-values (((g174)
(if (symbol? (car lst))
(eq? symbol (car lst))
#f)))
(if g174
g174
(if (string? (car lst))
(begin
(if (not string)
(begin
(symbol-in-list?
symbol
(symbol->string symbol)
lst))
(if (string=? string (car lst))
(begin #t)
(begin
(symbol-in-list?
symbol
string
(cdr lst))))))
(begin
(symbol-in-list?
symbol
string
(cdr lst)))))))))
((word-in-list?)
(lambda (wd lst)
(if (null? lst)
(begin #f)
(if (equal? wd (car lst))
(begin #t)
(begin (word-in-list? wd (cdr lst)))))))
((word-in-word?)
(lambda (small big)
(let-values (((one-letter-str) (word->string small)))
(if (> (string-length one-letter-str) 1)
(whoops "Invalid arguments to MEMBER?: " small big)
(let-values (((big-str) (word->string big)))
(char-in-string?
(string-ref one-letter-str 0)
big-str
(- (string-length big-str) 1)))))))
((char-in-string?)
(lambda (char string i)
(if (< i 0)
(begin #f)
(if (char=? char (string-ref string i))
(begin #t)
(begin (char-in-string? char string (- i 1))))))))
(lambda (x stuff)
(if (empty? stuff)
(begin #f)
(if (word? stuff)
(begin (word-in-word? x stuff))
(if (not (list? stuff))
(begin (whoops "Invalid second argument to MEMBER?: " stuff))
(if (symbol? x)
(begin (symbol-in-list? x #f stuff))
(if (let-values (((or-part) (number? x)))
(if or-part or-part (string? x)))
(begin (word-in-list? x stuff))
(begin
(whoops "Invalid first argument to MEMBER?: " x)))))))))))
(define-values
(before?)
(let-values (((not) not)
((word?) word?)
((whoops) whoops)
((string<?) string<?)
((word->string) word->string))
(lambda (wd1 wd2)
(if (not (word? wd1))
(begin (whoops "Invalid first argument to BEFORE? (not a word): " wd1))
(if (not (word? wd2))
(begin
(whoops "Invalid second argument to BEFORE? (not a word): " wd2))
(begin (string<? (word->string wd1) (word->string wd2))))))))
(define-values
(filter)
(let-values (((null?) null?)
((car) car)
((cons) cons)
((cdr) cdr)
((not) not)
((procedure?) procedure?)
((whoops) whoops)
((list?) list?))
(lambda (pred l)
(letrec-values (((real-filter)
(lambda (l)
(if (null? l)
(begin '())
(if (pred (car l))
(begin (cons (car l) (real-filter (cdr l))))
(begin (real-filter (cdr l))))))))
(if (not (procedure? pred))
(begin
(whoops
"Invalid first argument to FILTER (not a procedure): "
pred))
(if (not (list? l))
(begin
(whoops "Invalid second argument to FILTER (not a list): " l))
(begin (real-filter l))))))))
(define-values
(keep)
(let-values (((+) simply-scheme:+)
((=) simply-scheme:=)
((pair?) pair?)
((substring) substring)
((char->word) char->word)
((string-ref) string-ref)
((string-set!) string-set!)
((word->string) word->string)
((string-length) string-length)
((string->word) string->word)
((make-string) make-string)
((procedure?) procedure?)
((whoops) whoops)
((word?) word?)
((null?) null?))
(lambda (pred w-or-s)
(letrec-values (((keep-string)
(lambda (in i out out-len len)
(if (= i len)
(begin (substring out 0 out-len))
(if (pred (char->word (string-ref in i)))
(begin
(string-set! out out-len (string-ref in i))
(keep-string in (+ i 1) out (+ out-len 1) len))
(begin
(keep-string in (+ i 1) out out-len len))))))
((keep-word)
(lambda (wd)
(let-values (((string) (word->string wd)))
(let-values (((len) (string-length string)))
(string->word
(keep-string
string
0
(make-string len)
0
len)))))))
(if (not (procedure? pred))
(begin
(whoops "Invalid first argument to KEEP (not a procedure): " pred))
(if (pair? w-or-s)
(begin (filter pred w-or-s))
(if (word? w-or-s)
(begin (keep-word w-or-s))
(if (null? w-or-s)
(begin '())
(begin
(whoops
"Bad second argument to KEEP (not a word or sentence): "
w-or-s))))))))))
(define-values
(appearances)
(let-values (((count) count) ((keep) keep) ((equal?) simply-scheme:equal?))
(lambda (item aggregate)
(count (keep (lambda (element) (equal? item element)) aggregate)))))
(define-values
(every)
(let-values (((=) simply-scheme:=)
((+) simply-scheme:+)
((se) se)
((char->word) char->word)
((string-ref) string-ref)
((empty?) empty?)
((first) first)
((bf) bf)
((not) not)
((procedure?) procedure?)
((whoops) whoops)
((word?) word?)
((word->string) word->string)
((string-length) string-length))
(lambda (fn stuff)
(letrec-values (((string-every)
(lambda (string i length)
(if (= i length)
'()
(se
(fn (char->word (string-ref string i)))
(string-every string (+ i 1) length)))))
((sent-every)
(lambda (sent)
(if (empty? sent)
sent
(se (fn (first sent)) (sent-every (bf sent)))))))
(if (not (procedure? fn))
(begin
(whoops "Invalid first argument to EVERY (not a procedure):" fn))
(if (word? stuff)
(begin
(let-values (((string) (word->string stuff)))
(string-every string 0 (string-length string))))
(begin (sent-every stuff))))))))
(define-values
(accumulate)
(let-values (((not) not)
((empty?) empty?)
((bf) bf)
((first) first)
((procedure?) procedure?)
((whoops) whoops)
((member) member)
((list) list))
(lambda (combiner stuff)
(letrec-values (((real-accumulate)
(lambda (stuff)
(if (empty? (bf stuff))
(first stuff)
(combiner
(first stuff)
(real-accumulate (bf stuff)))))))
(if (not (procedure? combiner))
(begin
(whoops
"Invalid first argument to ACCUMULATE (not a procedure):"
combiner))
(if (not (empty? stuff))
(begin (real-accumulate stuff))
(if (member
combiner
(list simply-scheme:+ simply-scheme:* word se))
(begin (combiner))
(begin
(whoops
"Can't accumulate empty input with that combiner")))))))))
(define-values
(reduce)
(let-values (((null?) null?)
((cdr) cdr)
((car) car)
((not) not)
((procedure?) procedure?)
((whoops) whoops)
((member) member)
((list) list))
(lambda (combiner stuff)
(letrec-values (((real-reduce)
(lambda (stuff)
(if (null? (cdr stuff))
(car stuff)
(combiner (car stuff) (real-reduce (cdr stuff)))))))
(if (not (procedure? combiner))
(begin
(whoops
"Invalid first argument to REDUCE (not a procedure):"
combiner))
(if (not (null? stuff))
(begin (real-reduce stuff))
(if (member
combiner
(list simply-scheme:+ simply-scheme:* word se append))
(begin (combiner))
(begin
(whoops "Can't reduce empty input with that combiner")))))))))
(define-values
(repeated)
(let-values (((=) simply-scheme:=) ((-) simply-scheme:-))
(lambda (fn number)
(if (= number 0)
(lambda (x) x)
(lambda (x) ((repeated fn (- number 1)) (fn x)))))))
(define-values (make-node) cons)
(define-values (datum) car)
(define-values (children) cdr)
(define-values
(show)
(let-values (((=) simply-scheme:=)
((length) length)
((display) display)
((car) car)
((newline) newline)
((not) not)
((output-port?) output-port?)
((apply) apply)
((whoops) whoops))
(lambda args
(if (= (length args) 1)
(begin (display (car args)) (newline))
(if (= (length args) 2)
(begin
(if (not (output-port? (car (cdr args))))
(whoops
"Invalid second argument to SHOW (not an output port): "
(car (cdr args)))
(void))
(apply display args)
(newline (car (cdr args))))
(begin
(whoops "Incorrect number of arguments to procedure SHOW")))))))
(define-values
(show-line)
(let-values (((>=) simply-scheme:>=)
((length) length)
((whoops) whoops)
((null?) null?)
((current-output-port) current-output-port)
((car) car)
((not) not)
((list?) list?)
((display) display)
((for-each) for-each)
((cdr) cdr)
((newline) newline))
(lambda (line . args)
(if (>= (length args) 2)
(whoops "Too many arguments to show-line")
(let-values (((port)
(if (null? args) (current-output-port) (car args))))
(if (not (list? line))
(begin (whoops "Invalid argument to SHOW-LINE (not a list):" line))
(if (null? line)
(begin #f)
(begin
(display (car line) port)
(for-each
(lambda (wd) (display " " port) (display wd port))
(cdr line)))))
(newline port))))))
(set! simply-scheme:read-string
(let-values (((read-char) read-char)
((eqv?) eqv?)
((apply) apply)
((string-append) string-append)
((substring) substring)
((reverse) reverse)
((cons) cons)
((>=) simply-scheme:>=)
((+) simply-scheme:+)
((string-set!) string-set!)
((length) length)
((whoops) whoops)
((null?) null?)
((current-input-port) current-input-port)
((car) car)
((cdr) cdr)
((eof-object?) eof-object?)
((list) list)
((make-string) make-string)
((peek-char) peek-char))
(letrec-values (((read-string-helper)
(lambda (chars all-length chunk-length port)
(let-values (((char) (read-char port))
((string) (car chars)))
(if (let-values (((or-part) (eof-object? char)))
(if or-part or-part (eqv? char #\newline)))
(begin
(apply
string-append
(reverse
(cons
(substring (car chars) 0 chunk-length)
(cdr chars)))))
(if (>= chunk-length 80)
(begin
(let-values (((newstring) (make-string 80)))
(string-set! newstring 0 char)
(read-string-helper
(cons newstring chars)
(+ all-length 1)
1
port)))
(begin
(string-set! string chunk-length char)
(read-string-helper
chars
(+ all-length 1)
(+ chunk-length 1)
port))))))))
(lambda args
(if (>= (length args) 2)
(whoops "Too many arguments to read-string")
(let-values (((port)
(if (null? args) (current-input-port) (car args))))
(if (eof-object? (peek-char port))
(read-char port)
(read-string-helper (list (make-string 80)) 0 0 port))))))))
(set! simply-scheme:read-line
(let-values (((=) simply-scheme:=)
((list) list)
((string->word) string->word)
((substring) substring)
((char-whitespace?) char-whitespace?)
((string-ref) string-ref)
((+) simply-scheme:+)
((string-length) string-length)
((apply) apply)
((read-string) simply-scheme:read-string))
(lambda args
(letrec-values (((tokenize)
(lambda (string)
(letrec-values (((helper)
(lambda (i start len)
(if (= i len)
(begin
(if (= i start)
'()
(list
(string->word
(substring
string
start
i)))))
(if (char-whitespace?
(string-ref string i))
(begin
(if (= i start)
(helper
(+ i 1)
(+ i 1)
len)
(cons
(string->word
(substring
string
start
i))
(helper
(+ i 1)
(+ i 1)
len))))
(begin
(helper
(+ i 1)
start
len)))))))
(if (eof-object? string)
string
(helper 0 0 (string-length string)))))))
(tokenize (apply read-string args))))))
(define-values (*the-open-inports*) '())
(define-values (*the-open-outports*) '())
(define-values
(align)
(let-values (((<) simply-scheme:<)
((abs) simply-scheme:abs)
((*) simply-scheme:*)
((expt) simply-scheme:expt)
((>=) simply-scheme:>=)
((-) simply-scheme:-)
((+) simply-scheme:+)
((=) simply-scheme:=)
((null?) null?)
((car) car)
((round) simply-scheme:round)
((number->string) simply-scheme:number->string)
((string-length) string-length)
((string-append) string-append)
((make-string) make-string)
((substring) substring)
((string-set!) string-set!)
((number?) simply-scheme:number?)
((word->string) word->string))
(lambda (obj width . rest)
(letrec-values (((align-number)
(lambda (obj width rest)
(let-values (((sign) (< obj 0)))
(let-values (((num) (abs obj)))
(let-values (((prec)
(if (null? rest) 0 (car rest))))
(let-values (((big)
(round (* num (expt 10 prec)))))
(let-values (((cvt0) (number->string big)))
(let-values (((cvt)
(if (< num 1)
(string-append "0" cvt0)
cvt0)))
(let-values (((pos-str)
(if (>=
(string-length cvt0)
prec)
cvt
(string-append
(make-string
(-
prec
(string-length cvt0))
#\0)
cvt))))
(let-values (((string)
(if sign
(string-append
"-"
pos-str)
pos-str)))
(let-values (((length)
(+
(string-length string)
(if (= prec 0) 0 1))))
(let-values (((left)
(-
length
(+ 1 prec))))
(let-values (((result)
(if (= prec 0)
string
(string-append
(substring
string
0
left)
"."
(substring
string
left
(-
length
1))))))
(if (= length width)
(begin result)
(if (< length width)
(begin
(string-append
(make-string
(- width length)
#\space)
result))
(begin
(let-values (((new)
(substring
result
0
width)))
(string-set!
new
(- width 1)
#\+)
new)))))))))))))))))
((align-word)
(lambda (string)
(let-values (((length) (string-length string)))
(if (= length width)
(begin string)
(if (< length width)
(begin
(string-append
string
(make-string (- width length) #\space)))
(begin
(let-values (((new)
(substring string 0 width)))
(string-set! new (- width 1) #\+)
new))))))))
(if (number? obj)
(align-number obj width rest)
(align-word (word->string obj)))))))
(set! simply-scheme:open-output-file
(let-values (((oof) simply-scheme:open-output-file) ((cons) cons))
(lambda (filename)
(let-values (((port) (oof filename)))
(set! *the-open-outports*
(#%app cons port (#%top . *the-open-outports*)))
port))))
(set! simply-scheme:open-input-file
(let-values (((oif) simply-scheme:open-input-file) ((cons) cons))
(lambda (filename)
(let-values (((port) (oif filename)))
(set! *the-open-inports*
(#%app cons port (#%top . *the-open-inports*)))
port))))
(define-values
(remove)
(let-values (((null?) null?)
((cdr) cdr)
((eq?) eq?)
((car) car))
(lambda (thing lst)
(letrec-values (((r)
(lambda (prev)
(if (null? (cdr prev))
(begin lst)
(if (eq? thing (car (cdr prev)))
(begin (cons (car prev)
(cdr (cdr prev))))
(begin (cons (car prev)
(r (cdr prev)))))))))
(if (null? lst)
(begin lst)
(if (eq? thing (car lst))
(begin (cdr lst))
(begin (r lst))))))))
(set! simply-scheme:close-input-port
(let-values (((cip) simply-scheme:close-input-port) ((remove) remove))
(lambda (port)
(set! *the-open-inports*
(#%app remove port (#%top . *the-open-inports*)))
(cip port))))
(set! simply-scheme:close-output-port
(let-values (((cop) simply-scheme:close-output-port) ((remove) remove))
(lambda (port)
(set! *the-open-outports*
(#%app remove port (#%top . *the-open-outports*)))
(cop port))))
(define-values
(close-all-ports)
(let-values (((for-each) for-each)
((close-input-port) simply-scheme:close-input-port)
((close-output-port) simply-scheme:close-output-port))
(lambda ()
(for-each close-input-port *the-open-inports*)
(for-each close-output-port *the-open-outports*)
'closed)))
(define-values
(maybe-num)
(let-values (((string?) string?) ((string->number) string->number))
(lambda (arg)
(if (string? arg)
(let-values (((num) (string->number arg))) (if num num arg))
arg))))
(define-values
(logoize)
(let-values (((apply) apply) ((map) map) ((maybe-num) maybe-num))
(lambda (fn) (lambda args (apply fn (map maybe-num args))))))
(define-values
(logoize-1)
(let-values (((maybe-num) maybe-num))
(lambda (fn) (lambda (x) (fn (maybe-num x))))))
(define-values
(logoize-2)
(let-values (((maybe-num) maybe-num))
(lambda (fn) (lambda (x y) (fn (maybe-num x) (maybe-num y))))))
(define-values
(strings-are-numbers)
(let-values (((are-they?) #f)
((real-*) simply-scheme:*)
((real-+) simply-scheme:+)
((real--) simply-scheme:-)
((real-/) simply-scheme:/)
((real-<) simply-scheme:<)
((real-<=) simply-scheme:<=)
((real-=) simply-scheme:=)
((real->) simply-scheme:>)
((real->=) simply-scheme:>=)
((real-abs) simply-scheme:abs)
((real-acos) simply-scheme:acos)
((real-asin) simply-scheme:asin)
((real-atan) simply-scheme:atan)
((real-ceiling) simply-scheme:ceiling)
((real-cos) simply-scheme:cos)
((real-even?) simply-scheme:even?)
((real-exp) simply-scheme:exp)
((real-expt) simply-scheme:expt)
((real-floor) simply-scheme:floor)
((real-align) align)
((real-gcd) simply-scheme:gcd)
((real-integer?) simply-scheme:integer?)
((real-item) item)
((real-lcm) simply-scheme:lcm)
((real-list-ref) simply-scheme:list-ref)
((real-log) simply-scheme:log)
((real-make-vector) simply-scheme:make-vector)
((real-max) simply-scheme:max)
((real-min) simply-scheme:min)
((real-modulo) simply-scheme:modulo)
((real-negative?) simply-scheme:negative?)
((real-number?) simply-scheme:number?)
((real-odd?) simply-scheme:odd?)
((real-positive?) simply-scheme:positive?)
((real-quotient) simply-scheme:quotient)
((real-random) simply-scheme:random)
((real-remainder) simply-scheme:remainder)
((real-repeated) repeated)
((real-round) simply-scheme:round)
((real-sin) simply-scheme:sin)
((real-sqrt) simply-scheme:sqrt)
((real-tan) simply-scheme:tan)
((real-truncate) simply-scheme:truncate)
((real-vector-ref) simply-scheme:vector-ref)
((real-vector-set!) simply-scheme:vector-set!)
((real-zero?) simply-scheme:zero?)
((maybe-num) maybe-num)
((number->string) simply-scheme:number->string)
((cons) cons)
((car) car)
((cdr) cdr)
((eq?) eq?)
((show) show)
((logoize) logoize)
((logoize-1) logoize-1)
((logoize-2) logoize-2)
((not) not)
((whoops) whoops))
(lambda (yesno)
(if (if are-they? (eq? yesno #t) #f)
(begin (show "Strings are already numbers"))
(if (eq? yesno #t)
(begin
(set! are-they? (#%datum . #t))
(set! simply-scheme:* (logoize real-*))
(set! simply-scheme:+ (logoize real-+))
(set! simply-scheme:- (logoize real--))
(set! simply-scheme:/ (logoize real-/))
(set! simply-scheme:< (logoize real-<))
(set! simply-scheme:<= (logoize real-<=))
(set! simply-scheme:= (logoize real-=))
(set! simply-scheme:> (logoize real->))
(set! simply-scheme:>= (logoize real->=))
(set! simply-scheme:abs (logoize-1 real-abs))
(set! simply-scheme:acos (logoize-1 real-acos))
(set! simply-scheme:asin (logoize-1 real-asin))
(set! simply-scheme:atan (logoize real-atan))
(set! simply-scheme:ceiling (logoize-1 real-ceiling))
(set! simply-scheme:cos (logoize-1 real-cos))
(set! simply-scheme:even? (logoize-1 real-even?))
(set! simply-scheme:exp (logoize-1 real-exp))
(set! simply-scheme:expt (logoize-2 real-expt))
(set! simply-scheme:floor (logoize-1 real-floor))
(set! align (#%app logoize (#%top . align)))
(set! simply-scheme:gcd (logoize real-gcd))
(set! simply-scheme:integer? (logoize-1 real-integer?))
(set! item
(lambda (n stuff) (#%app real-item (#%app maybe-num n) stuff)))
(set! simply-scheme:lcm (logoize real-lcm))
(set! simply-scheme:list-ref
(lambda (lst k) (real-list-ref lst (maybe-num k))))
(set! simply-scheme:log (logoize-1 real-log))
(set! simply-scheme:max (logoize real-max))
(set! simply-scheme:min (logoize real-min))
(set! simply-scheme:modulo (logoize-2 real-modulo))
(set! simply-scheme:negative? (logoize-1 real-negative?))
(set! simply-scheme:number? (logoize-1 real-number?))
(set! simply-scheme:odd? (logoize-1 real-odd?))
(set! simply-scheme:positive? (logoize-1 real-positive?))
(set! simply-scheme:quotient (logoize-2 real-quotient))
(set! simply-scheme:random (logoize real-random))
(set! simply-scheme:remainder (logoize-2 real-remainder))
(set! simply-scheme:round (logoize-1 real-round))
(set! simply-scheme:sin (logoize-1 real-sin))
(set! simply-scheme:sqrt (logoize-1 real-sqrt))
(set! simply-scheme:tan (logoize-1 real-tan))
(set! simply-scheme:truncate (logoize-1 real-truncate))
(set! simply-scheme:zero? (logoize-1 real-zero?))
(set! simply-scheme:vector-ref
(lambda (vec i) (real-vector-ref vec (maybe-num i))))
(set! simply-scheme:vector-set!
(lambda (vec i val) (real-vector-set! vec (maybe-num i) val)))
(set! simply-scheme:make-vector
(lambda (num . args)
(apply real-make-vector (cons (maybe-num num) args))))
(set! simply-scheme:list-ref
(lambda (lst i) (real-list-ref lst (maybe-num i))))
(set! repeated
(lambda (fn n) (#%app real-repeated fn (#%app maybe-num n)))))
(if (if (not are-they?) (not yesno) #f)
(begin (show "Strings are already not numbers"))
(if (not yesno)
(begin
(set! are-they? (#%datum . #f))
(set! simply-scheme:* real-*)
(set! simply-scheme:+ real-+)
(set! simply-scheme:- real--)
(set! simply-scheme:/ real-/)
(set! simply-scheme:< real-<)
(set! simply-scheme:<= real-<=)
(set! simply-scheme:= real-=)
(set! simply-scheme:> real->)
(set! simply-scheme:>= real->=)
(set! simply-scheme:abs real-abs)
(set! simply-scheme:acos real-acos)
(set! simply-scheme:asin real-asin)
(set! simply-scheme:atan real-atan)
(set! simply-scheme:ceiling real-ceiling)
(set! simply-scheme:cos real-cos)
(set! simply-scheme:even? real-even?)
(set! simply-scheme:exp real-exp)
(set! simply-scheme:expt real-expt)
(set! simply-scheme:floor real-floor)
(set! align real-align)
(set! simply-scheme:gcd real-gcd)
(set! simply-scheme:integer? real-integer?)
(set! item real-item)
(set! simply-scheme:lcm real-lcm)
(set! simply-scheme:list-ref real-list-ref)
(set! simply-scheme:log real-log)
(set! simply-scheme:max real-max)
(set! simply-scheme:min real-min)
(set! simply-scheme:modulo real-modulo)
(set! simply-scheme:odd? real-odd?)
(set! simply-scheme:quotient real-quotient)
(set! simply-scheme:random real-random)
(set! simply-scheme:remainder real-remainder)
(set! simply-scheme:round real-round)
(set! simply-scheme:sin real-sin)
(set! simply-scheme:sqrt real-sqrt)
(set! simply-scheme:tan real-tan)
(set! simply-scheme:truncate real-truncate)
(set! simply-scheme:zero? real-zero?)
(set! simply-scheme:positive? real-positive?)
(set! simply-scheme:negative? real-negative?)
(set! simply-scheme:number? real-number?)
(set! simply-scheme:vector-ref real-vector-ref)
(set! simply-scheme:vector-set! real-vector-set!)
(set! simply-scheme:make-vector real-make-vector)
(set! simply-scheme:list-ref real-list-ref)
(set! item real-item)
(set! repeated real-repeated))
(begin (whoops "Strings-are-numbers: give a #t or a #f"))))))
are-they?)))
(void (strings-are-numbers #t))
(provide (except-out (all-from-out racket/base)
*
+
-
/
<
<=
=
>
>=
abs
acos
asin
atan
ceiling
close-input-port
close-output-port
cos
equal?
even?
exp
expt
floor
gcd
integer?
lcm
list-ref
log
make-vector
max
min
modulo
negative?
number->string
number?
odd?
open-input-file
open-output-file
positive?
quotient
random
read-line
read-string
remainder
round
sin
sqrt
tan
truncate
vector-ref
vector-set!
zero?)
(all-from-out trace)
*the-open-inports*
*the-open-outports*
accumulate
align
appearances
before?
bf
bl
butfirst
butlast
char->word
char-rank
children
close-all-ports
count
datum
empty?
every
filter
first
item
keep
last
logoize
logoize-1
logoize-2
make-node
maybe-num
member?
reduce
remove
repeated
se
sentence
sentence?
show
show-line
string->word
strings-are-numbers
whoops
word
word->string
word?
(rename-out [simply-scheme:* *]
[simply-scheme:+ +]
[simply-scheme:- -]
[simply-scheme:/ /]
[simply-scheme:< <]
[simply-scheme:<= <=]
[simply-scheme:= =]
[simply-scheme:> >]
[simply-scheme:>= >=]
[simply-scheme:abs abs]
[simply-scheme:acos acos]
[simply-scheme:asin asin]
[simply-scheme:atan atan]
[simply-scheme:ceiling ceiling]
[simply-scheme:close-input-port close-input-port]
[simply-scheme:close-output-port close-output-port]
[simply-scheme:cos cos]
[simply-scheme:equal? equal?]
[simply-scheme:even? even?]
[simply-scheme:exp exp]
[simply-scheme:expt expt]
[simply-scheme:floor floor]
[simply-scheme:gcd gcd]
[simply-scheme:integer? integer?]
[simply-scheme:lcm lcm]
[simply-scheme:list-ref list-ref]
[simply-scheme:log log]
[simply-scheme:make-vector make-vector]
[simply-scheme:max max]
[simply-scheme:min min]
[simply-scheme:modulo modulo]
[simply-scheme:negative? negative?]
[simply-scheme:number->string number->string]
[simply-scheme:number? number?]
[simply-scheme:odd? odd?]
[simply-scheme:open-input-file open-input-file]
[simply-scheme:open-output-file open-output-file]
[simply-scheme:positive? positive?]
[simply-scheme:quotient quotient]
[simply-scheme:random random]
[simply-scheme:read-line read-line]
[simply-scheme:read-string read-string]
[simply-scheme:remainder remainder]
[simply-scheme:round round]
[simply-scheme:sin sin]
[simply-scheme:sqrt sqrt]
[simply-scheme:tan tan]
[simply-scheme:truncate truncate]
[simply-scheme:vector-ref vector-ref]
[simply-scheme:vector-set! vector-set!]
[simply-scheme:zero? zero?]))![[logo]](/logo.png){kind=logo}